diff --git a/MultiSlice.lfm b/MultiSlice.lfm new file mode 100755 index 0000000..747436f --- /dev/null +++ b/MultiSlice.lfm @@ -0,0 +1,172 @@ +object MultiSliceForm: TMultiSliceForm + Left = 340 + Height = 242 + Top = 557 + Width = 745 + Caption = 'MultiSlice' + ClientHeight = 242 + ClientWidth = 745 + Font.Height = -11 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object MultiPanel: TScrollBox + Left = 0 + Height = 242 + Top = 0 + Width = 745 + HorzScrollBar.Page = 14 + VertScrollBar.Page = 14 + Align = alClient + ClientHeight = 227 + ClientWidth = 730 + TabOrder = 0 + object MultiImage: TImage + Tag = 2 + Cursor = crCross + Left = 2 + Height = 12 + Top = 2 + Width = 12 + AutoSize = True + Stretch = True + end + end + object MainMenu1: TMainMenu + left = 40 + top = 8 + object File1: TMenuItem + Caption = 'File' + object Settings1: TMenuItem + Caption = 'Open settings' + OnClick = Settings1Click + end + object Savesettings1: TMenuItem + Caption = 'Save settings' + ShortCut = 16467 + OnClick = Savesettings1Click + end + object Saveasbitmap1: TMenuItem + Caption = 'Save as bitmap...' + OnClick = Saveasbitmap1Click + end + object Closewindow1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Closewindow1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + ShortCut = 16451 + OnClick = Copy1Click + end + end + object View1: TMenuItem + Caption = 'View' + object OrientMenu: TMenuItem + Caption = 'Orient' + object Sagittal1: TMenuItem + Tag = 2 + Caption = 'Sagittal' + GroupIndex = 129 + RadioItem = True + OnClick = OrientClick + end + object Coronal1: TMenuItem + Tag = 3 + Caption = 'Coronal' + GroupIndex = 129 + RadioItem = True + OnClick = OrientClick + end + object Axial1: TMenuItem + Tag = 1 + Caption = 'Axial' + Checked = True + GroupIndex = 129 + RadioItem = True + OnClick = OrientClick + end + end + object OversliceMenu: TMenuItem + Caption = 'Overslice' + object N501: TMenuItem + Tag = -50 + Caption = '-50%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N331: TMenuItem + Tag = -35 + Caption = '-35%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N201: TMenuItem + Tag = -20 + Caption = '-20%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N01: TMenuItem + Caption = '0%' + Checked = True + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N202: TMenuItem + Tag = 20 + Caption = '20%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N351: TMenuItem + Tag = 35 + Caption = '35%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N502: TMenuItem + Tag = 50 + Caption = '50%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + end + object Orthoview: TMenuItem + Caption = 'Orthogonal view' + Checked = True + OnClick = OrthoviewClick + end + object SliceLabelCheck: TMenuItem + Caption = 'Show slice label' + Checked = True + OnClick = SliceLabelCheckClick + end + object Slices1: TMenuItem + Caption = 'Slices...' + OnClick = Slices1Click + end + end + end + object MultiSaveDialog: TSaveDialog + DefaultExt = '.ini' + Filter = 'Settings file|*.ini' + FilterIndex = 0 + left = 97 + top = 11 + end +end diff --git a/MultiSlice.lrs b/MultiSlice.lrs new file mode 100644 index 0000000..60b9b64 --- /dev/null +++ b/MultiSlice.lrs @@ -0,0 +1,49 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TMultiSliceForm','FORMDATA',[ + 'TPF0'#15'TMultiSliceForm'#14'MultiSliceForm'#4'Left'#3'T'#1#6'Height'#3#242#0 + +#3'Top'#3'-'#2#5'Width'#3#233#2#7'Caption'#6#10'MultiSlice'#12'ClientHeight' + +#3#242#0#11'ClientWidth'#3#233#2#11'Font.Height'#2#245#4'Menu'#7#9'MainMenu1' + +#7'OnClose'#7#9'FormClose'#8'OnCreate'#7#10'FormCreate'#6'OnShow'#7#8'FormSh' + +'ow'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#3'1.5'#0#10'TScrollBo' + +'x'#10'MultiPanel'#4'Left'#2#0#6'Height'#3#242#0#3'Top'#2#0#5'Width'#3#233#2 + +#18'HorzScrollBar.Page'#2#14#18'VertScrollBar.Page'#2#14#5'Align'#7#8'alClie' + +'nt'#12'ClientHeight'#3#227#0#11'ClientWidth'#3#218#2#8'TabOrder'#2#0#0#6'TI' + +'mage'#10'MultiImage'#3'Tag'#2#2#6'Cursor'#7#7'crCross'#4'Left'#2#2#6'Height' + +#2#12#3'Top'#2#2#5'Width'#2#12#8'AutoSize'#9#7'Stretch'#9#0#0#0#9'TMainMenu' + +#9'MainMenu1'#4'left'#2'('#3'top'#2#8#0#9'TMenuItem'#5'File1'#7'Caption'#6#4 + +'File'#0#9'TMenuItem'#9'Settings1'#7'Caption'#6#13'Open settings'#7'OnClick' + +#7#14'Settings1Click'#0#0#9'TMenuItem'#13'Savesettings1'#7'Caption'#6#13'Sav' + +'e settings'#8'ShortCut'#3'S@'#7'OnClick'#7#18'Savesettings1Click'#0#0#9'TMe' + +'nuItem'#13'Saveasbitmap1'#7'Caption'#6#17'Save as bitmap...'#7'OnClick'#7#18 + +'Saveasbitmap1Click'#0#0#9'TMenuItem'#12'Closewindow1'#7'Caption'#6#12'Close' + +' window'#8'ShortCut'#3'W@'#7'OnClick'#7#17'Closewindow1Click'#0#0#0#9'TMenu' + +'Item'#5'Edit1'#7'Caption'#6#4'Edit'#0#9'TMenuItem'#5'Copy1'#7'Caption'#6#4 + +'Copy'#8'ShortCut'#3'C@'#7'OnClick'#7#10'Copy1Click'#0#0#0#9'TMenuItem'#5'Vi' + +'ew1'#7'Caption'#6#4'View'#0#9'TMenuItem'#10'OrientMenu'#7'Caption'#6#6'Orie' + +'nt'#0#9'TMenuItem'#9'Sagittal1'#3'Tag'#2#2#7'Caption'#6#8'Sagittal'#10'Grou' + +'pIndex'#3#129#0#9'RadioItem'#9#7'OnClick'#7#11'OrientClick'#0#0#9'TMenuItem' + +#8'Coronal1'#3'Tag'#2#3#7'Caption'#6#7'Coronal'#10'GroupIndex'#3#129#0#9'Rad' + +'ioItem'#9#7'OnClick'#7#11'OrientClick'#0#0#9'TMenuItem'#6'Axial1'#3'Tag'#2#1 + +#7'Caption'#6#5'Axial'#7'Checked'#9#10'GroupIndex'#3#129#0#9'RadioItem'#9#7 + +'OnClick'#7#11'OrientClick'#0#0#0#9'TMenuItem'#13'OversliceMenu'#7'Caption'#6 + +#9'Overslice'#0#9'TMenuItem'#4'N501'#3'Tag'#2#206#7'Caption'#6#4'-50%'#10'Gr' + +'oupIndex'#3#158#0#9'RadioItem'#9#7'OnClick'#7#14'OverlsiceClick'#0#0#9'TMen' + +'uItem'#4'N331'#3'Tag'#2#221#7'Caption'#6#4'-35%'#10'GroupIndex'#3#158#0#9'R' + +'adioItem'#9#7'OnClick'#7#14'OverlsiceClick'#0#0#9'TMenuItem'#4'N201'#3'Tag' + +#2#236#7'Caption'#6#4'-20%'#10'GroupIndex'#3#158#0#9'RadioItem'#9#7'OnClick' + +#7#14'OverlsiceClick'#0#0#9'TMenuItem'#3'N01'#7'Caption'#6#2'0%'#7'Checked'#9 + +#10'GroupIndex'#3#158#0#9'RadioItem'#9#7'OnClick'#7#14'OverlsiceClick'#0#0#9 + +'TMenuItem'#4'N202'#3'Tag'#2#20#7'Caption'#6#3'20%'#10'GroupIndex'#3#158#0#9 + +'RadioItem'#9#7'OnClick'#7#14'OverlsiceClick'#0#0#9'TMenuItem'#4'N351'#3'Tag' + +#2'#'#7'Caption'#6#3'35%'#10'GroupIndex'#3#158#0#9'RadioItem'#9#7'OnClick'#7 + +#14'OverlsiceClick'#0#0#9'TMenuItem'#4'N502'#3'Tag'#2'2'#7'Caption'#6#3'50%' + +#10'GroupIndex'#3#158#0#9'RadioItem'#9#7'OnClick'#7#14'OverlsiceClick'#0#0#0 + +#9'TMenuItem'#9'Orthoview'#7'Caption'#6#15'Orthogonal view'#7'Checked'#9#7'O' + +'nClick'#7#14'OrthoviewClick'#0#0#9'TMenuItem'#15'SliceLabelCheck'#7'Caption' + +#6#16'Show slice label'#7'Checked'#9#7'OnClick'#7#20'SliceLabelCheckClick'#0 + +#0#9'TMenuItem'#7'Slices1'#7'Caption'#6#9'Slices...'#7'OnClick'#7#12'Slices1' + +'Click'#0#0#0#0#11'TSaveDialog'#15'MultiSaveDialog'#10'DefaultExt'#6#4'.ini' + +#6'Filter'#6#19'Settings file|*.ini'#11'FilterIndex'#2#0#4'left'#2'a'#3'top' + +#2#11#0#0#0 +]); diff --git a/MultiSlice.pas b/MultiSlice.pas new file mode 100755 index 0000000..30ddb07 --- /dev/null +++ b/MultiSlice.pas @@ -0,0 +1,896 @@ +unit MultiSlice; +interface + {$mode delphi} +uses +{$IFNDEF Unix} Windows,wgraphics, +{$ELSE} +//not used by Darwin... RGBGraphics,rgbroutines, +{$ENDIF} + LResources,LCLType,SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls,nifti_img,define_types,nifti_img_view, + StdCtrls,GraphicsMathLibrary, Menus,ClipBrd,IniFiles,userdir; +const + kMaxMultiSlice = 24; +type + TMultiSlice = record + Orient,nSlices,OverslicePct: integer; + OrthoView,SliceLabel: boolean; + SliceList: array [1..kMaxMultiSlice] of integer; + end;//TMultiSlice + + { TMultiSliceForm } + + TMultiSliceForm = class(TForm) + MainMenu1: TMainMenu; + File1: TMenuItem; + Closewindow1: TMenuItem; + Saveasbitmap1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + MultiPanel: TScrollBox; + MultiImage: TImage; + View1: TMenuItem; + OrientMenu: TMenuItem; + Axial1: TMenuItem; + Sagittal1: TMenuItem; + Coronal1: TMenuItem; + Orthoview: TMenuItem; + Slices1: TMenuItem; + Savesettings1: TMenuItem; + Settings1: TMenuItem; + MultiSaveDialog: TSaveDialog; + SliceLabelCheck: TMenuItem; + OversliceMenu: TMenuItem; + N501: TMenuItem; + N331: TMenuItem; + N201: TMenuItem; + N01: TMenuItem; + N202: TMenuItem; + N351: TMenuItem; + N502: TMenuItem; + procedure Copy1Click(Sender: TObject); +procedure MenuItem1Click(Sender: TObject); + procedure Saveasbitmap1Click(Sender: TObject); + procedure OrientClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure CreateMultiAx; + procedure CreateMultiCor; + procedure CreateMultiSag; + procedure CreateMultiSlice; + procedure OrthoviewClick(Sender: TObject); +procedure Settings1Click(Sender: TObject); + procedure Slices1Click(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure UpdateMultiSliceDisplay; + procedure OpenMultiMRU(Sender:TObject); + procedure UpdateMultiSliceMRU; + {$IFNDEF FPC} + procedure FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} + procedure FormClose(Sender: TObject); + + {$ENDIF} + procedure Savesettings1Click(Sender: TObject); + procedure SliceLabelCheckClick(Sender: TObject); + procedure OverlsiceClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + MultiSliceForm: TMultiSliceForm; + gMulti:TMultiSlice; + gMultiSliceDir,gMultiSliceStartupFilename,gMultiSliceDefaultsFilename:string; +{$IFDEF FPC} + gMultiBuff: RGBQuadp; + gMultiWid,gMultiHt: Integer; + gMultiXCenterRA: array [1..kMaxMultiSlice] of integer; +{$ENDIF} +implementation + + {$IFNDEF FPC} +{$R *.DFM} + {$ENDIF} + +function MultiSliceNum2String: string; +var + lSlice: integer; +begin + if gMulti.nSlices = 0 then begin + gMulti.nSlices := 1; + gMulti.SliceList[1] := 1; + end; + result := ''; + for lSlice := 1 to gMulti.nSlices do begin + result := result+inttostr(gMulti.SliceList[lSlice]); + if lSlice < gMulti.nSlices then + result := result+','; + end; //for each slice +end; + +procedure MultiSliceString2Num (var lStr: string); +var + lSliceStr: string; + lStrPos,lStrLen,lSlice: integer; +begin + //showmessage(lStr); + lStrLen := length(lStr); + if lStrLen < 1 then exit; + lSlice := 0; + lSliceStr := ''; + for lStrPos := 1 to lStrLen do begin + if lStr[lStrPos] in ['0'..'9'] then + lSliceStr := lSliceStr+lStr[lStrPos]; + if ((not (lStr[lStrPos] in ['0'..'9'])) or (lStrPos=lStrLen)) and (lSliceStr<>'') then begin + inc(lSlice); + if lSlice <= kMaxMultiSlice then + gMulti.SliceList[lSlice] := strtoint(lSliceStr); + lSliceStr := ''; + end; //if white space or eoln + end; //for lStrPos + gMulti.nSlices := lSlice; + if lSlice > kMaxMultiSlice then begin + showmessage('Warning: maximum number of slices is '+inttostr(kMaxMultiSlice)); + gMulti.nSlices := kMaxMultiSlice; + end; +end; + +procedure WriteMultiSliceIniFile (lFilename: string); +var + lIniFile: TIniFile; +begin + if DiskFreeEx(lFilename) < 1 then + exit; + if not DirectoryExists(extractfiledir(lFilename)) then begin + mkDir(extractfiledir(lFilename)); + end; + lIniFile := TIniFile.Create(lFilename); + //Slice Index + lIniFile.WriteString('STR', 'Slices', MultiSliceNum2String); + //Booleans + lIniFile.WriteString('BOOL', 'OrthoView',Bool2Char( gMulti.OrthoView)); + lIniFile.WriteString('BOOL', 'SliceLabel',Bool2Char( gMulti.SliceLabel)); + //Integers LicenseID + lIniFile.WriteString('INT', 'Orient',IntToStr(gMulti.Orient)); + lIniFile.WriteString('INT', 'OverslicePct',IntToStr(gMulti.OverslicePct)); + lIniFile.Free; +end; + +procedure ReadMultiSliceIniFile (lFilename: string); +var + lStr: string; + lIniFile: TIniFile; +begin + if not FileexistsEx(lFilename) then begin + exit; + end; + lIniFile := TIniFile.Create(lFilename); + lStr := lIniFile.ReadString('STR', 'Slices', '10,20,30');//file0 - last file viewed + MultiSliceString2Num(lStr); + gMulti.OrthoView := IniBool(lIniFile,'OrthoView',gMulti.OrthoView); + gMulti.SliceLabel := IniBool(lIniFile,'SliceLabel',gMulti.SliceLabel); + gMulti.Orient:= IniInt(lIniFile,'Orient',gMulti.Orient); + gMulti.OverslicePct:= IniInt(lIniFile,'OverslicePct',gMulti.OverslicePct); + lIniFile.Free; +end; + +procedure TMultiSliceForm.OpenMultiMRU(Sender:TObject); +var + lFilename: string; +begin + lFilename := gMultiSliceDir +(Sender as TMenuItem).caption+'.ini' ; + ReadMultiSliceIniFile(lFilename); + UpdateMultiSliceDisplay; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.UpdateMultiSliceMRU; +var + NewItem: TMenuItem; + lSearchRec: TSearchRec; +begin + While Settings1.Count > 0 do Settings1.Items[0].Free; + if FindFirst(gMultiSliceDir +'*.ini', faAnyFile, lSearchRec) = 0 then + repeat + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ParseFileName(ExtractFileName(lSearchRec.Name)); + {$IFDEF FPC} + NewItem.Onclick := OpenMultiMRU; //Lazarus + {$ELSE} + NewItem.Onclick := OpenMultiMRU; + {$ENDIF} + Settings1.Add(NewItem); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end; + +procedure TMultiSliceForm.Copy1Click(Sender: TObject); +{$IFNDEF FPC} +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; + {$ENDIF} +begin + {$IFDEF Darwin} + Showmessage('Copy not yet supported with OSX: use File/Save'); + {$ENDIF} + if (MultiImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + {$IFNDEF FPC} + MultiImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); + {$ELSE} + MultiSliceForm.MultiImage.Picture.Bitmap.SaveToClipboardFormat(2); + {$ENDIF} +end; + +procedure TMultiSliceForm.MenuItem1Click(Sender: TObject); +begin + + +end; + + + +procedure TMultiSliceForm.Saveasbitmap1Click(Sender: TObject); +begin + SaveImgAsPNGBMP (MultiImage); +end; + + + +procedure CreateBlankBitmap (lPGHt,lPGWid:integer;var lImage: TImage); +var + lPos: integer; + lBGInvisibleColor: TRGBQuad; +begin +{$IFDEF ENDIAN_BIG} +lBGInvisibleColor :=TColor2TRGBQuad(clBlack); + {$ELSE} + //lBGInvisibleColor := gMRIcroOverlay[kBGOverlayNum].LUTinvisible; + lBGInvisibleColor := gMRIcroOverlay[kBGOverlayNum].LUT[0]; + {$ENDIF} + gMultiWid := lPGWid; + gMultiHt := lPGHt; + if (gMultiWid < 1) or (gMultiHt < 1) then + exit; + getmem (gMultiBuff, gMultiHt*gMultiWid*sizeof(TRGBQuad) ); + //fillchar(gMultiBuff^,gMultiHt*gMultiWid*sizeof(TRGBQuad),0); + for lPos := 1 to (gMultiHt*gMultiWid) do + gMultiBuff^[lPos] := lBGInvisibleColor; +end; + +procedure MultiHLine (lX1,lX2,lY1,lThick: integer; lClr: TRGBQuad); +var + lLine,lY,lYPos,lX,lXlo,lXhi: integer; +begin + if (lThick < 1) or (gMultiWid < 1) or (gMultiHt < 1) or (lY1 < 1) or (lY1 >gMultiHt) or (gMultiBuff = nil) then + exit; + lXlo := lX1; + lXHi := lX2; + SortInteger(lXlo,lXhi); + if lXlo < 1 then + lXlo := 1; + if lXlo > gMultiWid then + lXlo := gMultiWid; + if lXhi < 1 then + lXhi := 1; + if lXhi > gMultiWid then + lXhi := gMultiWid; + lY := lY1-((lThick{+1}) div 2); + for lLine := 1 to lThick do begin + lYPos := (lY)*gMultiWid; + if lY < gMultiHt then + for lX := lXlo to lXhi do + gMultiBuff^[lYPos+lX] := lClr; + inc(lY); + end; +end; + +procedure MultiVLine (lX1,lY1,lY2,lThick: integer; lClr: TRGBQuad); +var + lXs, lX,lY,lYlo,lYhi: integer; +begin + if (lThick < 1) or (gMultiWid < 1) or (gMultiHt < 1) or (lX1 < 1) or (lX1 >gMultiWid) or (gMultiBuff = nil) then + exit; + lYlo := lY1; + lYHi := lY2; + SortInteger(lYlo,lYhi); + if lYlo < 1 then + lYlo := 1; + if lYlo > gMultiHt then + lYlo := gMultiHt; + if lYhi < 1 then + lYhi := 1; + if lYhi > gMultiHt then + lYhi := gMultiHt; + lXs := lX1-((lThick{+1}) div 2)-2;//-2 as indexed from 0 and line is at least 1 pixel thick + for lX := lXs to (lXs+lThick-1) do + if (lX >= 0) and (lX < gMultiWid) then + for lY := lYlo to lYHi do + gMultiBuff^[((lY-1)*gMultiWid)+lX] := lClr; + +end; + +procedure DefineBackGround(var lBMP: DWordp; lBGInvisibleColor: DWord; lMaskHt,lMaskWid: integer); +//lMaskP should have all invis voxels as 128, non as 255 +//sets all invis boundary voxels to 0 +var + lMaskP: ByteP; + lBGvisibleColor: DWord; + lPos,lMaskSz, + lQSz,lQHead,lQTail: integer; + lQRA: LongIntp; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; +PROCEDURE RetirePixel; //FIFO cleanup +VAR + lVal,lPos: integer; +BEGIN + lVal := lQra^[lQTail]; + lPos := lVal-1; + if (lPos > 0) and (lMaskP^[lPos]=128) then begin//add item to left + incQra(lQHead,lQSz); + lMaskP^[lPos] := 0; + lQra^[lQHead] := lPos; + end; + if (lPos > 0) then lMaskP^[lPos] := 0; + lPos := lVal+1; + if (lPos < lMaskSz) and (lMaskP^[lPos]=128) then begin//add item to right + incQra(lQHead,lQSz); + lMaskP^[lPos] := 0; + lQra^[lQHead] := lPos; + end; + if (lPos < lMaskSz) then lMaskP^[lPos] := 0; + lPos := lVal-lMaskWid; + if (lPos > 0) and (lMaskP^[lPos]=128) then begin//add item above + incQra(lQHead,lQSz); + lMaskP^[lPos] := 0; + lQra^[lQHead] := lPos; + end; + if (lPos > 0) then lMaskP^[lPos] := 0; + lPos := lVal+lMaskWid; + if (lPos < lMaskSz) and(lMaskP^[lPos]=128) then begin//add item below + incQra(lQHead,lQSz); + lMaskP^[lPos] := 0; + lQra^[lQHead] := lPos; + end; + if (lPos < lMaskSz) then lMaskP^[lPos] := 0; + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +begin + if (lPt < 1) or (lPt > lMaskSz) or (lMaskP^[lPt] <> 128) then exit; + //lQSz := 8000;//size of FIFO Queue Array + lQHead := 1; + lQTail := 1; + lQra^[lQTail] := (lPt); //NOTE: both X and Y start from 0 not 1 + lMaskP^[lPt] := 0; + RetirePixel; + if lQHead >= lQTail then begin + while lQHead <> lQTail do + RetirePixel; + end; +end; +begin //proc DefineBG + lMaskSz := lMaskWid * lMaskHt; + Getmem(lMaskP,lMaskSz); + for lPos := 1 to lMaskSz do + if lBMP^[lPos] = lBGInvisibleColor then + lMaskP^[lPos] := 128 + else + lMaskP^[lPos] := 255; + lQSz := lMaskSz div 4; + GetMem(lQra,lQSz*sizeof(LongInt)); + //erase all rows + for lPos := 1 to lMaskHt do begin + FillStart( (lPos-1)*lMaskWid + 1); + FillStart( (lPos)*lMaskWid); + end; + //erase all cols + for lPos := 1 to lMaskWid do begin + FillStart( lPos + 1); + FillStart( ((lMaskHt-1) *lMaskWid) + lPos); + end; + Freemem(lQRa); + //make sure bright blue 0000FF becauses neighbor 0000FE instead of 000100 + if (lBGInvisibleColor and 255) = 255 then + lBGVisibleColor:= lBGInvisibleColor-1 + else + lBGVisibleColor:= lBGInvisibleColor+1; + //now, fill in islands so they are not transparent + for lPos := 1 to lMaskSz do + if lMaskP^[lPos] = 128 then + lBMP^[lPos] := lBGVisibleColor; + Freemem(lMaskP); +end; + +{$IFDEF FLIPV} +procedure SetDim (lInPGHt,lInPGWid,lWriteColumn: integer; var l32OutBitP : DWordp); +var + lLen,lSrc,lDest,lY: integer; + lTBuff: RGBQuadp; +begin + getmem(lTBuff,lInPGHt*lWriteColumn*4); + lLen := lWriteColumn*4; + lSrc := 1; + lDest := 1; + for lY := 1 to lInPGHt do begin + Move(l32OutBitP^[lSrc],lTBuff^[lDest],lLen); + lSrc := lSrc + lInPGWid; + lDest := lDest + lWriteColumn; + end; + DrawBMP( lWriteColumn, lInPGHt, lTBuff, MultiSliceForm.MultiImage); + freemem(lTBuff); +end; +{$ELSE} +procedure SetDim (lInPGHt,lInPGWid,lWriteColumn: integer; var l32OutBitP : DWordp); +var + lLen,lSrc,lDest,lY: integer; + lTBuff: RGBQuadp; +begin + getmem(lTBuff,lInPGHt*lWriteColumn*4); + lLen := lWriteColumn*4; + lSrc := 1; + //lDest := 1; + lDest := 1+ ((lInPGHt-1) * lWriteColumn); + + for lY := 1 to lInPGHt do begin + Move(l32OutBitP^[lSrc],lTBuff^[lDest],lLen); + lSrc := lSrc + lInPGWid; + lDest := lDest - lWriteColumn; + end; + DrawBMP( lWriteColumn, lInPGHt, lTBuff, MultiSliceForm.MultiImage); + freemem(lTBuff); +end; +{$ENDIF} + + +procedure RemoveHorizGaps (lMaxOverlapWid,lColWid: integer); //will overlap gaps from 1..lMaxOverlapWid, leave right non-overlapped); +var + l32BitP,l32OutBitP : DWordp; + lBGInvisibleColor,lBGInvisibleColorShr8: DWord; + lIsGap,lPrevIsGap: boolean; + lInc,lPrevSliceStart,lPrevSliceEnd,lPrevWriteColumn,lWid,lHt,lReadRow, + lMaxWriteColumn,lReadColumn,lWriteColumn,lReadOffset,lWriteOffset,lPos,x,y: integer; + lTextPos,lTextReadColumn: integer; +begin + (*freemem (gMultiBuff ); + gMultiBuff := nil; + exit;*) + + + for lTextPos := 1 to kMaxMultiSlice do + gMultiXCenterRA[lTextPos] := 0; + lTextPos := 0; + lTextReadColumn := lColWid div 2; + if (gMultiWid < 1) or (gMultiHt < 1) or (gMultiBuff = nil) then + exit; + lBGInvisibleColor := TRGBQuad2DWord(gMRIcroOverlay[kBGOverlayNum].LUTinvisible); + //fx(lBGInvisibleColor); + //lBGInvisibleColorShr8 := lBGInvisibleColor Shr 8; + lHt := gMultiHt;//MultiSliceForm.MultiImage.Picture.Bitmap.Height; + lWid := gMultiWid; //MultiSliceForm.MultiImage.Picture.Bitmap.Width; + if (lHt < 2) or (lWid < 2) then exit; + //next: prepare input + l32BitP := DWordP(gMultiBuff); + lBGInvisibleColor := l32BitP^[1]; + DefineBackGround(l32BitP,lBGInvisibleColor, lHt,lWid); + //next prepare output + GetMem(l32OutBitP,lHt*lWid*sizeof(DWord)); + for lInc := 1 to (lwid*lHt) do + l32OutBitP^[lInc] := lBGInvisibleColor; + //next: compress by deleting empty columns + lWriteColumn := 0; + lPrevIsGap := true; + lPrevSliceStart := maxint -10; + lPrevSliceEnd := 0; + lPrevWriteColumn := maxint-10;//do not degap 1st line + + +if gMulti.OverSlicePct = 0 then begin //simply remove gaps between slice + for lReadColumn := 1 to lWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + if lReadColumn >= lTextReadColumn then begin + inc(lTextPos); + lTextReadColumn := lTextReadColumn+lColWid; + if lTextPos <= kMaxMultiSlice then + gMultiXCenterRA[lTextPos] := lWriteColumn; + end; + while (lReadRow < lHt) and (lIsGap) do begin + if l32BitP^[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + if not lIsGap then begin//data in this column + if lReadColumn > (lPrevWriteColumn+1) then begin //leave one pixel gap between noncontiguous columns + inc(lWriteColumn); + lReadOffset := lReadColumn-1; + lWriteOffset := lWriteColumn; + //showmessage(inttostr(lWriteColumn)+' '+inttostr(lReadOffset)); + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //leave 1 pixel gap + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + lPrevWriteColumn := lReadColumn; + end; //not Gap - write this column + end; //for each column +end else begin //overslice <> 0: show subsequent slices above/below each other + lMaxWriteColumn := -maxint; + for lReadColumn := 1 to lMaxOverlapWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + while (lReadRow < lHt) and (lIsGap) do begin + //ovx + if l32BitP^[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + if (lPrevIsGap <> lIsGap) then begin//change from prev column + if not (lIsGap) then begin + //fx(lPrevSliceStart,lPrevSliceEnd,lReadColumn,abs(((lPrevSliceEnd-lPrevSliceStart) * gMulti.OverSlicePct)div 100)); + if lPrevSliceEnd > lPrevSliceStart then + lWriteColumn := lPrevSliceEnd-abs(((lPrevSliceEnd-lPrevSliceStart) * gMulti.OverSlicePct)div 100); + lPrevSliceStart := lWriteColumn; + + end; + if (lIsGap) then + lPrevSliceEnd := lWriteColumn; + end; + lPrevIsGap := lIsGap; + if gMulti.OverSlicePct > 0 then begin + if not lIsGap then begin//data in this column + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + if l32BitP^[lReadOffset] <> lBGInvisibleColor then + l32OutBitP^[lWriteOffset] := l32BitP^[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //not Gap - write this column + end else begin //if overwrite, else underwrite + if not lIsGap then begin//data in this column + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + if l32OutBitP^[lWriteOffset] = lBGInvisibleColor then + l32OutBitP^[lWriteOffset] := l32BitP^[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //not Gap - write this column + end; + if lReadColumn >= lTextReadColumn then begin //text + inc(lTextPos); + lTextReadColumn := lTextReadColumn+lColWid; + if lTextPos <= kMaxMultiSlice then + gMultiXCenterRA[lTextPos] := lWriteColumn; + end; //text + if lWriteColumn > lMaxWriteColumn then + lMaxWriteColumn := lWriteColumn; + end; //for each column + if lWriteColumn < lMaxWriteColumn then + lWriteColumn := lMaxWriteColumn; + if lMaxOverlapWid < lWid then begin + lReadColumn := lMaxOverlapWid; + if (lWriteColumn) < lReadColumn then //add gap if some compression + inc(lWriteColumn); + for lReadColumn := (lMaxOverlapWid+1) to lWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + while (lReadRow < lHt) and (lIsGap) do begin + if l32BitP^[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + if not lIsGap then begin + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; //for each row + end; //not gap + end; //for each column + if (lWriteColumn+1) < lWid then + inc(lWriteColumn); + end; //if maxwid < wid - unoverlapped +end; + + SetDim (lHt,lWid,lWriteColumn,l32OutBitP); + FreeMem(l32OutBitP); + freemem (gMultiBuff ); + gMultiBuff := nil; +end; + + +procedure TMultiSliceForm.CreateMultiSag; +var + lSlice,lHt,lWid,lSlicePos,lSliceWid: integer; +begin + + lHt:= gBGIMg.ScrnDim[3]; + lSliceWid :=gBGIMg.ScrnDim[2]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := (lSliceWid*gMulti.nSlices); + if lWid < 2 then exit; + if gMulti.OrthoView then //coro crossview + lWid := lWid + gBGIMg.ScrnDim[1]+2; + if lWid < 2 then exit; + + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + DrawSag (gMulti.SliceList[lSlice],1+((lSlice-1)*lSliceWid));//+lSlice because we want 1-voxel gap between slices + //if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],1),((lSlice-1)*lSliceWid)+(lSliceWid div 2),lWid); + end; + if gMulti.OrthoView then begin //coro crossview + DrawCor (gBGImg.ScrnDim[2] div 2,(lSliceWid*gMulti.nSlices)-1); + //MultiImage.Canvas.Pen.Color := clWhite; + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + for lSlice := 1 to gMulti.nSlices do begin //draw lines + lSlicePos := (gMulti.nSlices*lSliceWid)+(gMulti.SliceList[lSlice]); + MultiVLine (lSlicePos,0,lHt,gBGImg.XBarThick,TColor2TRGBQuad(gBGImg.XBarClr)); + {MultiImage.Canvas.MoveTo(lSlicePos,0); + MultiImage.Canvas.LineTo(lSlicePos,lHt);} + end;//line for each slice + end;//if cross view + RemoveHorizGaps(lSliceWid*gMulti.nSlices,lSliceWid); +end; //CreateMultiSag + +procedure TMultiSliceForm.CreateMultiCor; +var + lSlice,lHt,lWid,lLeft,lSliceWid: integer; +begin + lHt:= gBGIMg.ScrnDim[3]; + lSliceWid :=gBGIMg.ScrnDim[1]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := lSliceWid*gMulti.nSlices; + if lWid < 2 then exit; + if gMulti.OrthoView then //sag crossview + lWid := lWid + gBGIMg.ScrnDim[2]+2; + if lWid < 2 then exit; + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + //ImgForm.YViewEdit.value := gMulti.SliceList[lSlice]; + DrawCor (gMulti.SliceList[lSlice],1+((lSlice-1)*lSliceWid)); + //if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],2),((lSlice-1)*lSliceWid)+(gBGIMg.ScrnDim[1] div 2),lWid); + end; + if gMulti.OrthoView then begin + DrawSag (gBGImg.ScrnDim[1] div 2,(gMulti.nSlices*lSliceWid)-1); + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Color := clWhite; + MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + + for lSlice := 1 to gMulti.nSlices do begin + lLeft := gMulti.nSlices*lSliceWid+(gMulti.SliceList[lSlice]); + MultiVLine (lLeft,0,lHt,gBGImg.XBarThick,TColor2TRGBQuad(gBGImg.XBarClr)); + + {MultiImage.Canvas.MoveTo(lLeft,0); + MultiImage.Canvas.LineTo(lLeft,lHt);} + end; + end;//if orthoview + RemoveHorizGaps(lSliceWid*gMulti.nSlices,lSliceWid); +end; //CreateMultiCor + +procedure TMultiSliceForm.CreateMultiAx; +var + lSliceWid,lSlice,lHt,lWid,lLeft: integer; +begin + lHt:= gBGIMg.ScrnDim[2]; + lSliceWid :=gBGIMg.ScrnDim[1]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := lSliceWid*gMulti.nSlices; + if lWid < 2 then exit; + if gMulti.OrthoView then begin //sag crossview + lWid := lWid + gBGIMg.ScrnDim[2]+2; + if gBGIMg.ScrnDim[3]> lHt then + lHt := gBGIMg.ScrnDim[3]; + end; + if lWid < 2 then exit; + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + DrawAxial (gMulti.SliceList[lSlice],1+((lSlice-1)*lSliceWid)); + //if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],3),((lSlice-1)*lSliceWid)+(gBGIMg.ScrnDim[1] div 2),lWid); + end; + if gMulti.OrthoView then begin + lLeft := gMulti.nSlices*lSliceWid; + //DrawSag (gBGImg.ScrnDim[1] div 2,lLeft); + DrawSag (gBGImg.ScrnDim[1] div 2,lLeft-1); + + //MultiImage.Canvas.pen.Color := clWhite; + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + + for lSlice := 1 to gMulti.nSlices do begin + lHt := gBGImg.ScrnDim[3]-(gMulti.SliceList[lSlice]); + MultiHLine (lLeft,lWid,lHt,gBGImg.XBarThick,TColor2TRGBQuad(gBGImg.XBarClr)); + end; + end; + RemoveHorizGaps(lSliceWid*gMulti.nSlices,lSliceWid); +end; //CreateMultiAx + +procedure DrawLabels; +var + lSlice,lOrient: integer; +begin + case gMulti.Orient of + 3: lOrient := 2; + 2: lOrient := 1; + else lOrient := 3; + end;//case + + if not gMulti.SliceLabel then + exit; + for lSlice := 1 to gMulti.nSlices do begin + if gMultiXCenterRA[lSlice] > 0 then DrawLabel(MultiSliceForm.MultiImage,DimToMM(gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],lOrient),gMultiXCenterRA[lSlice],maxint); + end; +end; +//gMultiXCenterRA + +procedure TMultiSliceForm.CreateMultiSlice; +//test var lI: integer; +begin + if gMulti.nSlices < 1 then begin + showmessage('No valid slices selected - please use View/Slices.'); + end; + //MultiImage.Canvas.Font.Color := clWhite; +//for lI := 1 to 32 do begin //test + case gMulti.Orient of + 3: CreateMultiCor; + 2: CreateMultiSag; + else CreateMultiAx; + end;//case + DrawLabels; + // end; //test +end;//CreateMultiSlice + +procedure TMultiSliceForm.OrientClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gMulti.Orient := (sender as TMenuItem).tag; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.FormShow(Sender: TObject); +begin + ReadMultiSliceIniFile (gMultiSliceStartupFilename ); + UpdateMultiSliceMRU; + UpdateMultiSliceDisplay; + CreateMultiSlice; + MultiSliceForm.BringToFront; +end; + +procedure TMultiSliceForm.OrthoviewClick(Sender: TObject); +begin + OrthoView.checked := not OrthoView.Checked; + gMulti.OrthoView := OrthoView.checked; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.Settings1Click(Sender: TObject); +begin + +end; + +procedure TMultiSliceForm.Slices1Click(Sender: TObject); +var + lStr: string; +begin + lStr := InputBox('Select multislices', 'Slice numbers [e.g. 10,16,24]',MultiSliceNum2String); + //now parse line + MultiSliceString2Num(lStr); + CreateMultiSlice; +end; + +procedure TMultiSliceForm.Closewindow1Click(Sender: TObject); +begin + MultiSliceForm.Close; +end; + +procedure TMultiSliceForm.UpdateMultiSliceDisplay; +begin + SetSubmenuWithTag(OversliceMenu, gMulti.OverslicePct); + SetSubmenuWithTag(OrientMenu, gMulti.Orient); + OrthoView.Checked := gMulti.OrthoView; + SliceLabelCheck.Checked := gMulti.SliceLabel; +end; + +procedure TMultiSliceForm.FormCreate(Sender: TObject); +var + lSlice:integer; +begin + gMultiBuff := nil; + gMultiSliceDir := DefaultsDir('multislice'); + //gMultiSliceDir := extractfiledir(paramstr(0))+pathdelim+'multislice'+pathdelim; + gMultiSliceDefaultsFilename := gMultiSliceDir + 'default.ini'; + gMultiSliceStartupFilename := gMultiSliceDefaultsFilename; + gMulti.Orient := 1; + gMulti.OverslicePct := 0; + gMulti.nSlices:= 4; + gMulti.OrthoView := true; + gMulti.SliceLabel := true; + for lSlice := 1 to gMulti.nSlices do + gMulti.SliceList[lSlice] := 62+10*lSlice; + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Savesettings1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Closewindow1.ShortCut := ShortCut(Word('W'), [ssMeta]); + {$ENDIF} + {$ENDIF} +end; + + {$IFNDEF FPC} +procedure TMultiSliceForm.FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} +procedure TMultiSliceForm.FormClose(Sender: TObject); + {$ENDIF} +begin +WriteMultiSliceIniFile (gMultiSliceDefaultsFilename ); +end; + +procedure TMultiSliceForm.Savesettings1Click(Sender: TObject); +begin + MultiSaveDialog.InitialDir := extractfiledir(gMultiSliceDir ); + if not MultiSaveDialog.Execute then exit; + {$IFDEF Unix} + WriteMultiSliceIniFile(extractfiledir(gMultiSliceDir)+pathdelim+extractfilename(MultiSaveDialog.Filename)); + + {$ELSE} + WriteMultiSliceIniFile(MultiSaveDialog.Filename); + {$ENDIF} + UpdateMultiSliceMRU; +end; + +procedure TMultiSliceForm.SliceLabelCheckClick(Sender: TObject); +begin + SliceLabelCheck.checked := not SliceLabelCheck.Checked; + gMulti.SliceLabel := SliceLabelCheck.checked; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.OverlsiceClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gMulti.OverslicePct := (sender as TMenuItem).tag; + CreateMultiSlice; +end; + + {$IFDEF FPC} +initialization + {$I MultiSlice.lrs} +{$ENDIF} + +end. diff --git a/ROIfilt.lfm b/ROIfilt.lfm new file mode 100755 index 0000000..8d7b8a9 --- /dev/null +++ b/ROIfilt.lfm @@ -0,0 +1,92 @@ +object FilterROIform: TFilterROIform + Left = 569 + Height = 190 + Top = 107 + Width = 240 + HorzScrollBar.Page = 209 + VertScrollBar.Page = 196 + ActiveControl = MinROIfilt + BorderIcons = [biSystemMenu] + BorderStyle = bsToolWindow + Caption = 'Intensity filter' + ClientHeight = 190 + ClientWidth = 240 + Constraints.MaxHeight = 190 + Constraints.MaxWidth = 240 + Constraints.MinHeight = 190 + OnClose = FormClose + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '0.9.29' + object Label42: TLabel + Left = 4 + Height = 17 + Top = 14 + Width = 89 + Caption = 'Min. Threshold' + ParentColor = False + end + object FilterROIBtn: TSpeedButton + Left = 4 + Height = 25 + Top = 143 + Width = 221 + Caption = 'Filter VOI with highlighted' + Color = clBtnFace + NumGlyphs = 0 + OnClick = FilterROIBtnClick + ShowHint = True + ParentShowHint = False + end + object Label43: TLabel + Left = 4 + Height = 14 + Top = 49 + Width = 75 + Caption = 'Max. Threshold' + Font.CharSet = 13 + ParentColor = False + ParentFont = False + end + object Filter2NIfTIBtn: TSpeedButton + Tag = 128 + Left = 4 + Height = 25 + Top = 107 + Width = 221 + Caption = 'Save highlighted as NIfTI or VOI' + Color = clBtnFace + NumGlyphs = 0 + OnClick = Filter2NIfTIBtnClick + ShowHint = True + ParentShowHint = False + end + object FiltROILabel: TLabel + Left = 8 + Height = 17 + Top = 81 + Width = 22 + Caption = ' ' + ParentColor = False + end + object MinROIfilt: TSpinEdit + Left = 120 + Height = 24 + Top = 7 + Width = 52 + MaxValue = 254 + OnChange = MinROIfiltChange + TabOrder = 0 + Value = 100 + end + object MaxROIfilt: TSpinEdit + Left = 120 + Height = 24 + Top = 42 + Width = 52 + MaxValue = 255 + OnChange = MinROIfiltChange + TabOrder = 1 + Value = 255 + end +end diff --git a/ROIfilt.lrs b/ROIfilt.lrs new file mode 100644 index 0000000..a2eb102 --- /dev/null +++ b/ROIfilt.lrs @@ -0,0 +1,27 @@ +LazarusResources.Add('TFilterROIform','FORMDATA',[ + 'TPF0'#14'TFilterROIform'#13'FilterROIform'#4'Left'#3'9'#2#6'Height'#3#190#0#3 + +'Top'#2'k'#5'Width'#3#240#0#18'HorzScrollBar.Page'#3#209#0#18'VertScrollBar.' + +'Page'#3#196#0#13'ActiveControl'#7#10'MinROIfilt'#11'BorderIcons'#11#12'biSy' + +'stemMenu'#0#11'BorderStyle'#7#12'bsToolWindow'#7'Caption'#6#16'Intensity fi' + +'lter'#12'ClientHeight'#3#190#0#11'ClientWidth'#3#240#0#21'Constraints.MaxHe' + +'ight'#3#190#0#20'Constraints.MaxWidth'#3#240#0#21'Constraints.MinHeight'#3 + +#190#0#7'OnClose'#7#9'FormClose'#6'OnShow'#7#8'FormShow'#8'Position'#7#14'po' + +'ScreenCenter'#10'LCLVersion'#6#6'0.9.29'#0#6'TLabel'#7'Label42'#4'Left'#2#4 + +#6'Height'#2#17#3'Top'#2#14#5'Width'#2'Y'#7'Caption'#6#14'Min. Threshold'#11 + +'ParentColor'#8#0#0#12'TSpeedButton'#12'FilterROIBtn'#4'Left'#2#4#6'Height'#2 + +#25#3'Top'#3#143#0#5'Width'#3#221#0#7'Caption'#6#27'Filter VOI with highligh' + +'ted'#5'Color'#7#9'clBtnFace'#9'NumGlyphs'#2#0#7'OnClick'#7#17'FilterROIBtnC' + +'lick'#8'ShowHint'#9#14'ParentShowHint'#8#0#0#6'TLabel'#7'Label43'#4'Left'#2 + +#4#6'Height'#2#14#3'Top'#2'1'#5'Width'#2'K'#7'Caption'#6#14'Max. Threshold' + +#12'Font.CharSet'#2#13#11'ParentColor'#8#10'ParentFont'#8#0#0#12'TSpeedButto' + +'n'#15'Filter2NIfTIBtn'#3'Tag'#3#128#0#4'Left'#2#4#6'Height'#2#25#3'Top'#2'k' + +#5'Width'#3#221#0#7'Caption'#6' Save highlighted as NIfTI or VOI'#5'Color'#7 + +#9'clBtnFace'#9'NumGlyphs'#2#0#7'OnClick'#7#20'Filter2NIfTIBtnClick'#8'ShowH' + +'int'#9#14'ParentShowHint'#8#0#0#6'TLabel'#12'FiltROILabel'#4'Left'#2#8#6'He' + +'ight'#2#17#3'Top'#2'Q'#5'Width'#2#22#7'Caption'#6#7' '#11'ParentColor' + +#8#0#0#9'TSpinEdit'#10'MinROIfilt'#4'Left'#2'x'#6'Height'#2#24#3'Top'#2#7#5 + +'Width'#2'4'#8'MaxValue'#3#254#0#8'OnChange'#7#16'MinROIfiltChange'#8'TabOrd' + +'er'#2#0#5'Value'#2'd'#0#0#9'TSpinEdit'#10'MaxROIfilt'#4'Left'#2'x'#6'Height' + +#2#24#3'Top'#2'*'#5'Width'#2'4'#8'MaxValue'#3#255#0#8'OnChange'#7#16'MinROIf' + +'iltChange'#8'TabOrder'#2#1#5'Value'#3#255#0#0#0#0 +]); diff --git a/ROIfilt.pas b/ROIfilt.pas new file mode 100755 index 0000000..dfe9d90 --- /dev/null +++ b/ROIfilt.pas @@ -0,0 +1,183 @@ +unit ROIfilt; + +interface + +uses + {$IFNDEF FPC} + RXSpin, + {$ELSE} + Spin,LResources, + {$ENDIF} + {$IFNDEF Unix} Windows,{$ENDIF} + Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Buttons,define_types, nifti_hdr, nifti_types; + +type + TFilterROIform = class(TForm) + Label42: TLabel; + FilterROIBtn: TSpeedButton; + Label43: TLabel; + Filter2NIfTIBtn: TSpeedButton; + FiltROILabel: TLabel; + MinROIfilt: TSpinEdit; + MaxROIfilt: TSpinEdit; + procedure MinROIfiltChange(Sender: TObject); + procedure FilterROIBtnClick(Sender: TObject); + {$IFNDEF FPC} + procedure FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} + procedure FormClose(Sender: TObject); + {$ENDIF} + + procedure FormShow(Sender: TObject); + procedure Filter2NIfTIBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + FilterROIform: TFilterROIform; + +implementation +uses nifti_img_view,nifti_img; + + {$IFNDEF FPC} +{$R *.DFM} + {$ENDIF} + +procedure TFilterROIform.MinROIfiltChange(Sender: TObject); +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then exit; + FilterLUT (gBGImg, gMRIcroOverlay[kBGOverlayNum], round(MinROIFilt.Value),round(MaxROIfilt.value)); //lLUT: 0=gray,1=red,2=green,3=blue + FiltROILabel.caption := 'Calibrated range: '+realtostr(Scrn2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],MinROIfilt.value),3) + +'...'+realtostr(Scrn2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],MaxROIfilt.value),3); + ImgForm.RefreshImagesTimer.enabled := true; +end; + +procedure TFilterROIform.FilterROIBtnClick(Sender: TObject); +var lBGBuffer,lVOIBuffer:ByteP; + lInc,lMin,lMax,lBufferItems,lVOIvoxelsAfter,lVOIvoxelsBefore: integer; +begin + lBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lBufferItems < 1 then begin + showmessage('You need to open up a VOI (Draw/Open) in order to apply an intensity filter to the VOI.'); + exit; + end; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lBufferItems then begin + showmessage('Error: VOI dimensions do not match background image.'); + exit; + end; + CreateUndoVol; + (*case MessageDlg('Unable to undo this operation. You should save a backup copy prior to this (Draw/Save). Are you sure you wish to filter your VOI?', mtConfirmation, + [mbYes, mbCancel], 0) of + id_Cancel: exit; + end; //case *) + lMin := round(MinROIFilt.value); + lMax := round(MaxROIFilt.value); + if lMin > lMax then begin //swap + lInc := lMin; + lMin := lMax; + lMax := lInc; + end; //swap + if lBufferItems < 1 then + showmessage('Error: no background image open to filter.') + else begin + lBGBuffer := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer; + lVOIBuffer := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer; + lVOIvoxelsBefore := 0; + for lInc := 1 to lBufferItems do + if (lVOIBuffer^[lInc] > 0) then + inc(lVOIvoxelsBefore); + for lInc := 1 to lBufferItems do + if (lBGBuffer^[lInc] < lMin) or (lBGBuffer^[lInc] > lMax) then + lVOIBuffer^[lInc] := 0; + lVOIvoxelsAfter := 0; + for lInc := 1 to lBufferItems do + if (lVOIBuffer^[lInc] > 0) then + inc(lVOIvoxelsAfter); + showmessage('VOI voxels prior to filter = '+inttostr(lVOIvoxelsBefore)+kCR + + 'VOI voxels after filter = '+inttostr(lVOIvoxelsAfter)); + gBGImg.VOIchanged := true; + //Save8BitAsVOIorNIFTI(lFilteredBuffer,lBufferItems); + end; //BGimage open + FilterROIForm.Close; +//nn +end; + + {$IFNDEF FPC} +procedure TFilterROIform.FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} +procedure TFilterROIform.FormClose(Sender: TObject); + {$ENDIF} +begin + FilterLUT (gBGImg, gMRIcroOverlay[kBGOverlayNum], -1,-1); //lLUT: 0=gray,1=red,2=green,3=blue + ImgForm.RefreshImagesTimer.enabled := true; +end; + +procedure TFilterROIform.FormShow(Sender: TObject); +var lInc: integer; +begin + for lInc := 0 to 255 do + gBGImg.BackupLUT[lInc]:= gMRIcroOverlay[kBGOverlayNum].LUT[lInc]; + MinROIfiltChange(nil); +end; + +procedure MirrorBuffer(var lBuffer8:ByteP; lX,lXYZ: integer ); +var + lnRow,lRow,lHlfX,lLineOffset,lXPos,lTemp: integer; +begin + if (lXYZ < 2) or (lX > lXYZ) or ((lXYZ mod lX) <> 0) then + exit; + lnRow := lXYZ div lX; + lHlfX := lX div 2; + lLineOffset := 0; + for lRow := 1 to lnRow do begin + for lXPos := 1 to lHlfX do begin + lTemp := lBuffer8^[lXPos+lLineOffset]; + lBuffer8^[lXPos+lLineOffset] := lBuffer8^[1+lX-lXPos+lLineOffset]; + lBuffer8^[1+lX-lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + end;//for each row... + +end; //MirrorBuffer + +procedure TFilterROIform.Filter2NIfTIBtnClick(Sender: TObject); +var lFilteredBuffer:ByteP; + lInc,lMin,lMax,lBufferItems: integer; + lNiftiHdr : TNIFTIhdr; +begin + lBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + lMin := round(MinROIFilt.value); + lMax := round(MaxROIFilt.value); + if lMin > lMax then begin //swap + lInc := lMin; + lMin := lMax; + lMax := lInc; + end; //swap + if lBufferItems < 1 then + showmessage('Error: no background image open to filter.') + else begin + getmem(lFilteredBuffer,lBufferItems); + move(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^,lFilteredBuffer^,lBufferItems); + for lInc := 1 to lBufferItems do + if (lFilteredBuffer^[lInc] < lMin) or (lFilteredBuffer^[lInc] > lMax) then + lFilteredBuffer^[lInc] := 0; + lNiftiHdr := gMRIcroOverlay[kBGOverlayNum].NiftiHdr; + if gBGImg.Mirror then + MirrorBuffer(lFilteredBuffer,gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.Dim[1], lBufferItems); //10/2010 + SaveAsVOIorNIFTI(lFilteredBuffer,lBufferItems,1,1,true,{gMRIcroOverlay[kBGOverlayNum].}lNiftiHdr,''); + //SaveAsVOIorNIFTI(lFilteredBuffer,lBufferItems,1,true,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,''); + freemem(lFilteredBuffer); + end; + FilterROIForm.Close; +end; + + {$IFDEF FPC} +initialization + {$I ROIfilt.lrs} +{$ENDIF} + +end. \ No newline at end of file diff --git a/ReadFloat.lfm b/ReadFloat.lfm new file mode 100755 index 0000000..5d9a8b9 --- /dev/null +++ b/ReadFloat.lfm @@ -0,0 +1,51 @@ +object ReadFloatForm: TReadFloatForm + Left = 335 + Height = 95 + Top = 308 + Width = 465 + HorzScrollBar.Page = 464 + VertScrollBar.Page = 94 + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'Real number required' + ClientHeight = 95 + ClientWidth = 465 + Constraints.MaxHeight = 95 + Constraints.MaxWidth = 465 + Constraints.MinHeight = 95 + Constraints.MinWidth = 465 + Position = poScreenCenter + LCLVersion = '0.9.29' + object ReadFloatLabel: TLabel + Left = 16 + Height = 14 + Top = 15 + Width = 312 + Alignment = taRightJustify + AutoSize = False + Caption = 'Enter a number' + ParentColor = False + end + object OKBtn: TButton + Left = 368 + Height = 25 + Top = 55 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + OnClick = OKBtnClick + TabOrder = 0 + end + object ReadFloatEdit: TFloatSpinEdit + Left = 336 + Height = 21 + Top = 12 + Width = 119 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 100000000 + MinValue = -100000000 + TabOrder = 1 + Value = 0 + end +end diff --git a/ReadFloat.lrs b/ReadFloat.lrs new file mode 100644 index 0000000..9f5a75f --- /dev/null +++ b/ReadFloat.lrs @@ -0,0 +1,17 @@ +LazarusResources.Add('TReadFloatForm','FORMDATA',[ + 'TPF0'#14'TReadFloatForm'#13'ReadFloatForm'#4'Left'#3'O'#1#6'Height'#2'_'#3'T' + +'op'#3'4'#1#5'Width'#3#209#1#18'HorzScrollBar.Page'#3#208#1#18'VertScrollBar' + +'.Page'#2'^'#11'BorderIcons'#11#12'biSystemMenu'#0#11'BorderStyle'#7#8'bsDia' + +'log'#7'Caption'#6#20'Real number required'#12'ClientHeight'#2'_'#11'ClientW' + +'idth'#3#209#1#21'Constraints.MaxHeight'#2'_'#20'Constraints.MaxWidth'#3#209 + +#1#21'Constraints.MinHeight'#2'_'#20'Constraints.MinWidth'#3#209#1#8'Positio' + +'n'#7#14'poScreenCenter'#10'LCLVersion'#6#6'0.9.29'#0#6'TLabel'#14'ReadFloat' + +'Label'#4'Left'#2#16#6'Height'#2#14#3'Top'#2#15#5'Width'#3'8'#1#9'Alignment' + +#7#14'taRightJustify'#8'AutoSize'#8#7'Caption'#6#14'Enter a number'#11'Paren' + +'tColor'#8#0#0#7'TButton'#5'OKBtn'#4'Left'#3'p'#1#6'Height'#2#25#3'Top'#2'7' + +#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#2'OK'#7'OnClic' + +'k'#7#10'OKBtnClick'#8'TabOrder'#2#0#0#0#14'TFloatSpinEdit'#13'ReadFloatEdit' + +#4'Left'#3'P'#1#6'Height'#2#21#3'Top'#2#12#5'Width'#2'w'#13'DecimalPlaces'#2 + +#4#9'Increment'#2#1#8'MaxValue'#4#0#225#245#5#8'MinValue'#4#0#31#10#250#8'Ta' + +'bOrder'#2#1#5'Value'#2#0#0#0#0 +]); diff --git a/ReadFloat.pas b/ReadFloat.pas new file mode 100755 index 0000000..b652b62 --- /dev/null +++ b/ReadFloat.pas @@ -0,0 +1,53 @@ +unit ReadFloat; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, + Spin; + +type + + { TReadFloatForm } + + TReadFloatForm = class(TForm) + ReadFloatEdit: TFloatSpinEdit; + OKBtn: TButton; + ReadFloatLabel: TLabel; + procedure OKBtnClick(Sender: TObject); + function GetFloat(lStr: string; lMin,lDefault,lMax: double): double; + private + { private declarations } + public + { public declarations } + end; + +var + ReadFloatForm: TReadFloatForm; + +implementation + +{ TReadFloatForm } + function TReadFloatForm.GetFloat(lStr: string; lMin,lDefault,lMax: double): double; + begin + //result := lDefault; + ReadFloatLabel.caption := lStr+' ['+floattostr(lMin)+'..'+floattostr(lMax)+']'; + ReadFloatEdit.MinValue := lMin; + ReadFloatEdit.MaxValue := lMax; + ReadFloatEdit.Value := lDefault; + ReadFloatForm.ShowModal; + result := ReadFloatEdit.value; + end; + +procedure TReadFloatForm.OKBtnClick(Sender: TObject); +begin + ReadFloatForm.ModalResult := mrOK; +end; + +initialization + {$I ReadFloat.lrs} + +end. + diff --git a/ReadInt.lfm b/ReadInt.lfm new file mode 100755 index 0000000..e190437 --- /dev/null +++ b/ReadInt.lfm @@ -0,0 +1,47 @@ +object ReadIntForm: TReadIntForm + Left = 334 + Height = 95 + Top = 206 + Width = 600 + ActiveControl = ReadIntEdit + BorderStyle = bsDialog + Caption = 'Integer required' + ClientHeight = 95 + ClientWidth = 600 + Constraints.MaxHeight = 95 + Constraints.MaxWidth = 600 + Constraints.MinHeight = 95 + Constraints.MinWidth = 600 + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.0.12.0' + object ReadIntLabel: TLabel + Left = 8 + Height = 14 + Top = 15 + Width = 448 + Alignment = taRightJustify + AutoSize = False + Caption = 'Enter a number' + ParentColor = False + end + object ReadIntEdit: TSpinEdit + Left = 472 + Height = 16 + Top = 12 + Width = 120 + MaxValue = 0 + TabOrder = 1 + end + object OKBtn: TButton + Left = 472 + Height = 25 + Top = 55 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + OnClick = OKBtnClick + TabOrder = 0 + end +end diff --git a/ReadInt.lrs b/ReadInt.lrs new file mode 100644 index 0000000..f05823d --- /dev/null +++ b/ReadInt.lrs @@ -0,0 +1,15 @@ +LazarusResources.Add('TReadIntForm','FORMDATA',[ + 'TPF0'#12'TReadIntForm'#11'ReadIntForm'#4'Left'#3'N'#1#6'Height'#2'_'#3'Top'#3 + +#206#0#5'Width'#3'X'#2#13'ActiveControl'#7#11'ReadIntEdit'#11'BorderStyle'#7 + +#8'bsDialog'#7'Caption'#6#16'Integer required'#12'ClientHeight'#2'_'#11'Clie' + +'ntWidth'#3'X'#2#21'Constraints.MaxHeight'#2'_'#20'Constraints.MaxWidth'#3'X' + +#2#21'Constraints.MinHeight'#2'_'#20'Constraints.MinWidth'#3'X'#2#8'OnCreate' + +#7#10'FormCreate'#6'OnShow'#7#8'FormShow'#8'Position'#7#14'poScreenCenter'#10 + +'LCLVersion'#6#8'1.0.12.0'#0#6'TLabel'#12'ReadIntLabel'#4'Left'#2#8#6'Height' + +#2#14#3'Top'#2#15#5'Width'#3#192#1#9'Alignment'#7#14'taRightJustify'#8'AutoS' + +'ize'#8#7'Caption'#6#14'Enter a number'#11'ParentColor'#8#0#0#9'TSpinEdit'#11 + +'ReadIntEdit'#4'Left'#3#216#1#6'Height'#2#16#3'Top'#2#12#5'Width'#2'x'#8'Max' + +'Value'#2#0#8'TabOrder'#2#1#0#0#7'TButton'#5'OKBtn'#4'Left'#3#216#1#6'Height' + +#2#25#3'Top'#2'7'#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption' + +#6#2'OK'#7'OnClick'#7#10'OKBtnClick'#8'TabOrder'#2#0#0#0#0 +]); diff --git a/ReadInt.pas b/ReadInt.pas new file mode 100755 index 0000000..ff9c0d7 --- /dev/null +++ b/ReadInt.pas @@ -0,0 +1,79 @@ +unit ReadInt; + +interface + +uses + {$IFDEF FPC} LResources,{$ENDIF} + Buttons{only Lazarus?},SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Spin; + +type + + { TReadIntForm } + + TReadIntForm = class(TForm) + ReadIntEdit: TSpinEdit; + ReadIntLabel: TLabel; + OKBtn: TButton; + procedure FormShow(Sender: TObject); + function GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + procedure OKBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + public + + { Public declarations } + end; + +var + ReadIntForm: TReadIntForm; + +implementation + +uses nifti_img_view,{license,} MultiSlice, render; + + {$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + function TReadIntForm.GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + begin + //result := lDefault; + ReadIntLabel.caption := lStr+' ['+inttostr(lMin)+'..'+inttostr(lMax)+']'; + ReadIntEdit.MinValue := lMin; + ReadIntEdit.MaxValue := lMax; + ReadIntEdit.Value := lDefault; + //ReadIntForm.OKBtn.Focused := true; + //ReadIntForm.OKBtn.SetFocus; + ReadIntForm.ShowModal; + result := ReadIntEdit.Value; + end; + + procedure TReadIntForm.FormShow(Sender: TObject); + begin + //OKBtn.SetFocus;; + end; + +procedure TReadIntForm.OKBtnClick(Sender: TObject); +begin + ReadIntForm.ModalResult := mrOK; +end; + + +procedure TReadIntForm.FormCreate(Sender: TObject); +//var lCPUid: longint; +begin + //Jan 2008 39448 + if Date > (400003) then begin + showmessage('This software became obsolete on '+datetostr(40000)+'. Please update to the current version.'); + //gBGImg.LicenseID := 1626; + //ImgForm.Exit1Click(nil); + end; +end; + +{$IFDEF FPC} +initialization + {$I ReadInt.lrs} +{$ENDIF} + +end. diff --git a/Readme.txt b/Readme.txt new file mode 100755 index 0000000..8838dc6 --- /dev/null +++ b/Readme.txt @@ -0,0 +1,50 @@ +This is a beta release of MRIcron. You can compile this using Lazarus. It has been compiled on Windows, Linux-x86, OSX-x86 and OSX-PPC. It requires builds of Lazarus and FreePascal created after October 7, 2007. + http://www.hu.freepascal.org/lazarus/ + +------------------------------------------- +To compile for OSX [Carbon] - +1.) Launch Lazarus and open the project. +2.) Select Project/CompilerOptions + Paths tab: make sure the "LCL widget type" is set to "carbon" + Linking tab: make sure the "Pass options to linker" checkbox is selected and + set the text to "-framework carbon" (no quotes). +3.) Select Project/ProjectOptions and set "Use application bundle for running and debugging" +4.) If using OSX 10.5 or later, add to Project / Compiler options / Other / Custom options: + -k-macosx_version_min -k10.4 + -XR/Developer/SDKs/MacOSX10.4u.sdk/ + Alternative: Project/ProjectOptions/Linking/ Check 'pass options to linker' and add this line -macosx_version_min 10.4 +5.) For debugging, you will want to create an alias from the application folder to the compiled executable: + The exact value will depend on your paths, but it will be similar to this: + rm ~/Documents/mricron/mricron.app/mricron + ln -s ~/Documents/mricron/mricron ~/Documents/mricron/mricron.app/mricron + rm ~/Documents/mricron/npm/npm.app/npm + ln -s ~/Documents/mricron/npm/npm ~/Documents/mricron/npm/npm.app/npm + rm ~/Documents/mricron/dcm2nii/dcm2niigui.app/dcm2niigui + ln -s ~/Documents/mricron/dcm2nii/dcm2niigui ~/Documents/mricron/dcm2nii/dcm2niigui.app/dcm2niigui + +6.) Select Run/Run to build and execute your program +7.) For making an executable to distribute, control+click on the program's .app folder (e.g. the file named mricron that has a brain icon) and choose "show package contents" - move the executable generated with Lazarus into the folder, overwriting the symbolic link created in step 4. + +------------------------------------------- +To compile for Linux GTK1 - +1.) Launch Lazarus and open the project. +2.) Select Project/CompilerOptions + Paths tab: make sure the "LCL widget type" is set to "default [gtk]" + Linking tab: make sure the "Pass options to linker" checkbox is UNCHECKED. +3.) Choose Run/Run to build and execute the program + +------------------------------------------- +To compile for Linux GTK2 - +1.) Launch Lazarus and open the project. +2.) Select Project/CompilerOptions + Paths tab: make sure the "LCL widget type" is set to "gtk2" + Linking tab: make sure the "Pass options to linker" checkbox is UNCHECKED. +3.) Choose Run/Run to build and execute the program + +------------------------------------------- +To compile for Windows - +1.) Launch Lazarus and open the project. +2.) Select Project/CompilerOptions + Paths tab: make sure the "LCL widget type" is set to "default [Win API]" + Linking tab: make sure the "Pass options to linker" checkbox is UNCHECKED. +3.) Choose Run/Run to build and execute the program diff --git a/RenderThds.pas b/RenderThds.pas new file mode 100755 index 0000000..76b18e8 --- /dev/null +++ b/RenderThds.pas @@ -0,0 +1,550 @@ +unit RenderThds; +interface +{$include isthreaded.inc} + {$mode delphi} +uses +{$IFDEF UNIX} +lclintf,//critical sections +{$ELSE} + Windows, +{$ENDIF} + ComCtrls,Classes, Graphics, ExtCtrls, define_types,GraphicsMathLibrary + ,sysutils; +const + kSh = 10; //bits to shift - precision for integers to simulate floats +var + ThreadsRunning: Integer = 0; + + type + + TRotateVals = record + InSliceSz,ZDimStart,ZDimEnd,YDimStart,YDimEnd,OutPivot,OutDim,OutSliceSz: integer; + XPivotInU2,YDimIN,YPivotInU2,ZDimIN,ZPivotInU2,XDimIN: integer; + XPivotIn,YPivotIn,ZPivotIn: integer; + Xxra,Xyra,Xzra: longintp; + //RenderCutout: boolean; + end; + + + TRenderThread = class(TThread) + private + lBarX: TProgressBar; + lRV: TRotateVals; + lMx : TMatrix; + lThreadX: integer; + lRenderCutoutX: boolean; + lBuffInX,lBuffOutX: ByteP; + lPosX: integer; + procedure DoVisualSwap; + protected + procedure Execute; override; + procedure VisualProg(lPos: Integer); + procedure Rotate(lThread: integer; l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); virtual; abstract; + public + + constructor Create(lBar: TProgressBar; lThread: integer; l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); + end; + +{ NearestNeighbor } + + TNNRender = class(TRenderThread) + protected + procedure Rotate(lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); override; + end; + +{ Trilinear } + + TTriRender = class(TRenderThread) + protected + procedure Rotate(lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); override; + end; + +implementation + +uses Render; + +var + {$IFDEF UNIX} + {$ifdef cpux86_64} + CritSect : QWord; + {$else} + CritSect : LongWord; + {$endif} + {$ELSE} + CritSect : TRTLCriticalSection; + {$ENDIF} + +procedure ThreadDone; +begin + EnterCriticalSection(CritSect); + Dec(ThreadsRunning); + LeaveCriticalSection(CritSect); + +end; + +procedure TRenderThread.DoVisualSwap; +begin + {$IFDEF SHOWPROG} + lBarX.Position := lPosX; + {$ENDIF} +end; + +procedure TRenderThread.VisualProg(lPos: Integer); +begin + lPosX := lPos; + {$IFDEF SHOWPROG} + {$IFDEF FPC} + Synchronize(DoVisualSwap); + {$ELSE} + Synchronize(DoVisualSwap); + {$ENDIF} + {$ENDIF} + +end; + +constructor TRenderThread.Create(lBar: TProgressBar;lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +begin + lBarX := lBar; + lRV := l; + lMx := lM; + lRenderCutoutX := lRenderCutout; + lBuffInX := lBuffIn; + lBuffOutX := lBuffOut; + lThreadX := lThread; + FreeOnTerminate := True; + inherited Create(False); +end; + +// The Execute method is called when the thread starts + +procedure TRenderThread.Execute; +begin + Rotate(lThreadX,lRV,lMx,lRenderCutoutX, lBuffInX,lBuffOutX); +end; + +procedure FindXBounds (var lXMax,lXMin: integer; +lXDimIN,lYxiZxi,lXPivotInU2,lYDimIN,lYyiZyi,lYPivotInU2,lZDimIN,lYziZzi,lZPivotInU2,lOutDim:integer; + lXxra,lXyra,lXzra : LongIntP); +var + lXo,lYo,lZo,Xo_at_one,Xo_at_two,Xo_grad,Xo_offs,lShiftedOne : integer; + when_it_is_zero, when_it_is_max: double; + lReallySmall {, debugx0, debugx1, debugy0, debugy1, debugz0, debugz1}: double; + l2: integer; +begin + lXMax := lOutDim; + lXMin := 1; + l2 := 2; + lShiftedOne := 1 shl ksh; + lReallySmall := 1e-6; + Xo_at_one := lXxRA^[1] +lYxiZxi + (lXPivotInU2 shl kSh); + Xo_at_two := lXxRA^[l2] +lYxiZxi + (lXPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lXDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugx0 := when_it_is_zero; debugx1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + Xo_at_one := lXyRA^[1] +lYyiZyi + (lYPivotInU2 shl kSh); + Xo_at_two := lXyRA^[l2] +lYyiZyi + (lYPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lYDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugy0 := when_it_is_zero; debugy1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + Xo_at_one := lXzRA^[1] +lYziZzi + (lZPivotInU2 shl kSh); + Xo_at_two := lXzRA^[l2] +lYziZzi + (lZPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lZDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugz0 := when_it_is_zero; debugz1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + // even with all the care about rounding, it's possible that we've got the + // edges wrong in ultra-high-gradient cases + if lXMin < lXMax then begin + while true do begin + lXo := ((lXxRA^[lXMin] +lYxiZxi) shr kSh)+lXPivotInU2; + lYo := ((lXyRA^[lXMin] +lYyiZyi) shr kSh)+lYPivotInU2; + lZo := ((lXzRA^[lXMin] +lYziZzi) shr kSh)+lZPivotInU2; + if (lXMin < lXMax) and ((lXo<1) or (lXo>lXDimIn) or (lYo<1) or (lYo>lYDimIn) or (lZo<1) or (lZo>lZDimIn)) then begin + lXMin := 1+lXMin; + end else + break; + end; + while true do begin + lXo := ((lXxRA^[lXMax] +lYxiZxi) shr kSh)+lXPivotInU2; + lYo := ((lXyRA^[lXMax] +lYyiZyi) shr kSh)+lYPivotInU2; + lZo := ((lXzRA^[lXMax] +lYziZzi) shr kSh)+lZPivotInU2; + if (lXMax > lXMin) and ((lXo<1) or (lXo>lXDimIn) or (lYo<1) or (lYo>lYDimIn) or (lZo<1) or (lZo>lZDimIn)) then begin + lXMax := lXMax-1; + end else + break; + end; + end; +end;//proc findXBounds + +//Nearest Neighbor +procedure TNNRender.Rotate (lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +const kshx = ksh shr 1; +var + + lZxi,lZyi,lZzi,lYxiZxi,lYyiZyi,lYziZzi,lZ,lY,lX,lOutPos, + lMaxX,lMinX,lXo,lYo,lZo: integer; +begin + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := round(lZ*lM.matrix[1,3]* (1 shl kSh) ); + lZyi := round(lZ*lM.matrix[2,3]* (1 shl kSh) ); + lZzi := round(lZ*lM.matrix[3,3]* (1 shl kSh) ); + if {(RenderForm.RenderRefreshTimer.enabled) or} (Terminated) then begin + ThreadDone; + exit; + end; + {$IFDEF SHOWPROG} //flicker with lazarus + if (lThread = 1) and ((lZ mod 30)=0) then + VisualProg(lZ); + {$ENDIF} + //ImgForm.ProgressBar1.Position := lZ; + for lY := l.YDimStart to l.YDimEnd do begin + lYxiZxi := round(lY * lM.matrix[1,2]* (1 shl kSh) )+lZxi; + lYyiZyi := round(lY * lM.matrix[2,2]* (1 shl kSh) )+lZyi; + lYziZzi := round(lY * lM.matrix[3,2]* (1 shl kSh) )+lZzi; + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + //if gAbortRender > 0 then goto 345; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXo := ((l.XxRA^[lX] +lYxiZxi) shr kSh)+l.XPivotInU2; + lYo := ((l.XyRA^[lX] +lYyiZyi) shr kSh)+l.YPivotInU2; + lZo := ((l.XzRA^[lX] +lYziZzi) shr kSh)+l.ZPivotInU2; + {lXo := (lXo shr 1) + 1; + lYo := lYo shr 1; + lZo := lZo shr 1;} + lBuffOut[lX+lOutPos] := lBuffIn[(lXo)+((lYo-1)*l.XdimIn)+((lZo-1)*l.InSliceSz)] + end; + end; //for y + end; //for z + ThreadDone; +end; + +procedure TTriRender.Rotate (lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +//Trilinear - this uses integer math, and on CoreDuo CPUs is 30% faster than Floating Point +//For precision, integers are multiplied by kSh (~2^10 bits) to simulate floats +// However, we will use 32-bit integers and the image intensity is 8 bit values, +// with the final interpolation multiplying X*Y*Z*intensity +// Therefore, this final interpolation adjusts kSh to be 2^8, avoiding overflow +var + lMi: TMatrixi; + lXr,lYr,lZr,lYxi,lYyi,lYzi,lXxi,lXyi,lXzi,lZxi,lZyi,lZzi, + lYxiZxi,lYyiZyi,lYziZzi,lZ,lY,lX,lOutPos, + lXPiv,lYPiv,lZPiv,lXrM1i,lYrM1i,lZrM1i, + lShr,lShl,lShlTo8,lShl8, + lMinZ,lMaxZ,lMinY,lMaxY,lMaxX,lMinX,lXo,lYo,lZo: integer; +begin + lShl := 1 shl kSh; + lShl8 := 1 shl 8; //8bit precision + lShlTo8 := (kSh - 8); //shr the kSh precision by this to get 8-bit precision + lShr := 24;//24-bits * 8 bit intensity = 32 bits + lXPiv := l.XPivotIn * lShl; + lYPiv := l.YPivotIn * lShl; + lZPiv := l.ZPivotIn * lShl; + for lX := 1 to 3 do + for lY := 1 to 3 do + lMi.matrix[lX,lY] := round(lM.matrix[lX,lY] * lShl); + if (lRenderCutout ) then begin //only separated to unroll IF rendercutout + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := (lZ*lMi.matrix[1,3] ); + lZyi := (lZ*lMi.matrix[2,3] ); + lZzi := (lZ*lMi.matrix[3,3] ); + if {(RenderForm.RenderRefreshTimer.enabled) or} (Terminated) then begin + ThreadDone; + exit; + end; + {$IFDEF SHOWPROG} //flicker with lazarus + if (lThread = 1) and ((lZ mod 30)=0) then + VisualProg(lZ); + {$ENDIF} + for lY := l.YDimStart to l.YDimEnd do begin + lYxi := lY * lMi.matrix[1,2]; + lYyi := lY * lMi.matrix[2,2]; + lYzi := lY * lMi.matrix[3,2]; + lYxiZxi := (lY * lMi.matrix[1,2] )+lZxi; + lYyiZyi := (lY * lMi.matrix[2,2] )+lZyi; + lYziZzi := (lY * lMi.matrix[3,2] )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXr := ( (lX*lMi.matrix[1,1])+lYxi+lZxi)+lXPiv; + lYr := ((lX*lMi.matrix[2,1])+lYyi+lZyi)+lYPiv; + lZr := ( (lX*lMi.matrix[3,1])+lYzi+lZzi)+lZPiv; + lXo := (lXr shr kSh); + lYo := (lYr shr kSh); + lZo := (lZr shr kSh); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXr := (lXr- (lXo * lShl)) shr lShlTo8; + lYr := (lYr- (lYo * lShl)) shr lShlTo8; + lZr := (lZr- (lZo * lShl)) shr lShlTo8; + lXrM1i := lShl8-lXr; + lYrM1i := lShl8-lYr; + lZrM1i := lShl8-lZr; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + if {(lRenderCutout ) and} ((lBuffIn^[lXo+lMinY+lMinZ]=255) or (lBuffIn^[lXo+1+lMinY+lMinZ]=255) + or (lBuffIn^[lXo+lMaxY+lMinZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMinZ]=255) + or (lBuffIn^[lXo+lMinY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMinY+lMaxZ]=255) + or (lBuffIn^[lXo+lMaxY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMaxZ]=255)) + then lBuffOut^[lX+l.OutPivot+lOutPos] := 255 + else + lBuffOut^[lX+l.OutPivot+lOutPos] := ( + (lXrM1i*lYrM1i*lZrM1i *lBuffIn^[lXo+lMinY+lMinZ] ) + +(lXr*lYrM1i*lZrM1i *lBuffIn^[lXo+1+lMinY+lMinZ]) + +(lXrM1i*lYr*lZrM1i *lBuffIn^[lXo+lMaxY+lMinZ] ) + +(lXrM1i*lYrM1i*lZr *lBuffIn^[lXo+lMinY+lMaxZ] ) + +(lXr*lYr*lZrM1i *lBuffIn^[lXo+1+lMaxY+lMinZ] ) + +(lXr*lYrM1i*lZr *lBuffIn^[lXo+1+lMinY+lMaxZ] ) + +(lXrM1i*lYr*lZr *lBuffIn^[lXo+lMaxY+lMaxZ]) + +(lXr*lYr*lZr *lBuffIn^[lXo+1+lMaxY+lMaxZ] ) + ) shr lShr; + end; //values in range + end; //for x + end; //for y + end; //for z + ThreadDone; + exit; + end; //if RenderCutout + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := (lZ*lMi.matrix[1,3] ); + lZyi := (lZ*lMi.matrix[2,3] ); + lZzi := (lZ*lMi.matrix[3,3] ); + if {(RenderForm.RenderRefreshTimer.enabled) or} (Terminated) then begin + ThreadDone; + exit; + end; + {$IFDEF SHOWPROG} //flicker with lazarus + if (lThread = 1) and ((lZ mod 30)=0) then + VisualProg(lZ); + {$ENDIF} + for lY := l.YDimStart to l.YDimEnd do begin + lYxi := lY * lMi.matrix[1,2]; + lYyi := lY * lMi.matrix[2,2]; + lYzi := lY * lMi.matrix[3,2]; + lYxiZxi := (lY * lMi.matrix[1,2] )+lZxi; + lYyiZyi := (lY * lMi.matrix[2,2] )+lZyi; + lYziZzi := (lY * lMi.matrix[3,2] )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXr := ( (lX*lMi.matrix[1,1])+lYxi+lZxi)+lXPiv; + lYr := ((lX*lMi.matrix[2,1])+lYyi+lZyi)+lYPiv; + lZr := ( (lX*lMi.matrix[3,1])+lYzi+lZzi)+lZPiv; + lXo := (lXr shr kSh); + lYo := (lYr shr kSh); + lZo := (lZr shr kSh); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXr := (lXr- (lXo * lShl)) shr lShlTo8; + lYr := (lYr- (lYo * lShl)) shr lShlTo8; + lZr := (lZr- (lZo * lShl)) shr lShlTo8; + lXrM1i := lShl8-lXr; + lYrM1i := lShl8-lYr; + lZrM1i := lShl8-lZr; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + lBuffOut^[lX+l.OutPivot+lOutPos] :=( + (lXrM1i*lYrM1i*lZrM1i *lBuffIn^[lXo+lMinY+lMinZ] ) + +(lXr*lYrM1i*lZrM1i *lBuffIn^[lXo+1+lMinY+lMinZ]) + +(lXrM1i*lYr*lZrM1i *lBuffIn^[lXo+lMaxY+lMinZ] ) + +(lXrM1i*lYrM1i*lZr *lBuffIn^[lXo+lMinY+lMaxZ] ) + +(lXr*lYr*lZrM1i *lBuffIn^[lXo+1+lMaxY+lMinZ] ) + +(lXr*lYrM1i*lZr *lBuffIn^[lXo+1+lMinY+lMaxZ] ) + +(lXrM1i*lYr*lZr *lBuffIn^[lXo+lMaxY+lMaxZ]) + +(lXr*lYr*lZr *lBuffIn^[lXo+1+lMaxY+lMaxZ] ) + ) shr lShr; + end; //values in range + end; //for x + end; //for y + end; //for z + ThreadDone; +end; + +(* +// floating point version of the same algorithm... +procedure TTriRender.Rotate (lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +var + lXreal,lYreal,lZreal,lZx,lZy,lZz,lYx,lYy,lYz,lXrM1,lYrM1,lZrM1: single; + lXxi,lXyi,lXzi,lZxi,lZyi,lZzi,lYxiZxi,lYyiZyi,lYziZzi,lZ,lY,lX,lOutPos, + lMinZ,lMaxZ,lMinY,lMaxY,lMaxX,lMinX,lXo,lYo,lZo: integer; +begin +if (lRenderCutout ) then begin + + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZx := lZ*lM.matrix[1,3]; + lZy := lZ*lM.matrix[2,3]; + lZz := lZ*lM.matrix[3,3]; + lZxi := round(lZ*lM.matrix[1,3]* (1 shl kSh) ); + lZyi := round(lZ*lM.matrix[2,3]* (1 shl kSh) ); + lZzi := round(lZ*lM.matrix[3,3]* (1 shl kSh) ); + if RenderForm.RenderRefreshTimer.enabled then exit;//abort + if Terminated then exit; //goto 345;//abort + if (lThread = 1) and ((lZ mod 10)=0) then + VisualProg(lZ); + for lY := l.YDimStart to l.YDimEnd do begin + lYx := lY * lM.matrix[1,2]; + lYy := lY * lM.matrix[2,2]; + lYz := lY * lM.matrix[3,2]; + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + lYxiZxi := round(lY * lM.matrix[1,2]* (1 shl kSh) )+lZxi; + lYyiZyi := round(lY * lM.matrix[2,2]* (1 shl kSh) )+lZyi; + lYziZzi := round(lY * lM.matrix[3,2]* (1 shl kSh) )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXreal := ( (lX*lM.matrix[1,1])+lYx+lZx)+l.XPivotIn; + lYreal := ( (lX*lM.matrix[2,1])+lYy+lZy)+l.YPivotIn; + lZreal := ( (lX*lM.matrix[3,1])+lYz+lZz)+l.ZPivotIn; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + if {(l.RenderCutout ) and} ((lBuffIn^[lXo+lMinY+lMinZ]=255) or (lBuffIn^[lXo+1+lMinY+lMinZ]=255) + or (lBuffIn^[lXo+lMaxY+lMinZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMinZ]=255) + or (lBuffIn^[lXo+lMinY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMinY+lMaxZ]=255) + or (lBuffIn^[lXo+lMaxY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMaxZ]=255)) + then lBuffOut^[lX+l.OutPivot+lOutPos] := 255 + else + lBuffOut^[lX+l.OutPivot+lOutPos] := round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn^[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for x + end; //for y + end; //for z + ThreadDone; +exit; +end; //rendercutout + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZx := lZ*lM.matrix[1,3]; + lZy := lZ*lM.matrix[2,3]; + lZz := lZ*lM.matrix[3,3]; + lZxi := round(lZ*lM.matrix[1,3]* (1 shl kSh) ); + lZyi := round(lZ*lM.matrix[2,3]* (1 shl kSh) ); + lZzi := round(lZ*lM.matrix[3,3]* (1 shl kSh) ); + if RenderForm.RenderRefreshTimer.enabled then exit;//abort + if Terminated then exit; //goto 345;//abort + if (lThread = 1) and ((lZ mod 10)=0) then + VisualProg(lZ); + for lY := l.YDimStart to l.YDimEnd do begin + lYx := lY * lM.matrix[1,2]; + lYy := lY * lM.matrix[2,2]; + lYz := lY * lM.matrix[3,2]; + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + lYxiZxi := round(lY * lM.matrix[1,2]* (1 shl kSh) )+lZxi; + lYyiZyi := round(lY * lM.matrix[2,2]* (1 shl kSh) )+lZyi; + lYziZzi := round(lY * lM.matrix[3,2]* (1 shl kSh) )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXreal := ( (lX*lM.matrix[1,1])+lYx+lZx)+l.XPivotIn; + lYreal := ((lX*lM.matrix[2,1])+lYy+lZy)+l.YPivotIn; + lZreal := ( (lX*lM.matrix[3,1])+lYz+lZz)+l.ZPivotIn; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + + lBuffOut^[lX+l.OutPivot+lOutPos] := + round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn^[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for x + end; //for y + end; //for z + // if Terminated then Exit; + ThreadDone; +end; *) + + +initialization + InitializeCriticalSection(CritSect); + + +finalization + DeleteCriticalSection(CritSect); +end. \ No newline at end of file diff --git a/Thumbs.db b/Thumbs.db new file mode 100755 index 0000000..6a0b2f5 Binary files /dev/null and b/Thumbs.db differ diff --git a/_clean.bat b/_clean.bat new file mode 100755 index 0000000..9c0921d --- /dev/null +++ b/_clean.bat @@ -0,0 +1,15 @@ +del /S *.a +del /S *.o +del /S *.ppu +del /S *.bak +del /S *.~* +del /S *.dcu +del /S *.dsk +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt +del /S *.exe +del /S *.old +rmdir /S /Q mricron.app diff --git a/_delphi.bat b/_delphi.bat new file mode 100755 index 0000000..30535f2 --- /dev/null +++ b/_delphi.bat @@ -0,0 +1,42 @@ +del c:\mricron\*.ini + +call _clean.bat +copy /Y .\common\notgui.inc .\common\isgui.inc + +cd .\dcm2nii +C:\PROGRA~2\BORLAND\DELPHI7\BIN\dcc32 -CC -B dcm2nii.dpr +c:\strip dcm2nii.exe +copy /Y dcm2nii.exe c:\mricron +cd .. + +call _clean.bat +copy /Y .\common\gui.inc .\common\isgui.inc + +cd .\npm +C:\PROGRA~2\BORLAND\DELPHI7\BIN\dcc32 -U..\delphionly -B npm.dpr +c:\strip npm.exe +copy /Y npm.exe c:\mricron +cd .. + +cd .\dcm2nii +C:\PROGRA~2\BORLAND\DELPHI7\BIN\dcc32 -U..\delphionly;C:\pas\d7\rx275d7\Units -B dcm2niigui.dpr +c:\strip dcm2niigui.exe +copy /Y dcm2niigui.exe c:\mricron +cd .. + +call _clean.bat + +cd c:\pas\mricron\niftiview7 +C:\PROGRA~2\BORLAND\DELPHI7\BIN\dcc32 -UC:\pas\d7\rx275d7\Units;C:\PROGRA~2\PngComponents\Source -B mricron.dpr +c:\strip c:\pas\mricron\niftiview7\mricron.exe +copy /Y c:\pas\mricron\niftiview7\mricron.exe c:\mricron\ + +REM compress MRIcron +c:\Progra~1\7-Zip\7z a -tzip c:\pas\wincron.zip c:\mricron +REM copy /Y c:\pas\wincron.zip Y:\mcbi\MCBI\CRNL\sw\mricron\win.zip + +REM compress Source +c:\Progra~1\7-Zip\7z a -tzip c:\pas\srccron.zip c:\pas\mricron +REM copy c:\pas\srccron.zip Y:\mcbi\MCBI\CRNL\sw\mricron\source.zip + + diff --git a/_mricron.bat b/_mricron.bat new file mode 100755 index 0000000..e83e4b9 --- /dev/null +++ b/_mricron.bat @@ -0,0 +1,38 @@ +#!/bin/sh + +cd ~/mricron + +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild -B ./dcm2nii/dcm2nii.lpr +cp ./dcm2nii/dcm2nii ~/mricron_lx + +lazbuild --cpu=i386 -B ./dcm2nii/dcm2nii.lpr +cp ./dcm2nii/dcm2nii ~/mricron_lx/dcm2nii32 + + + +./_xclean.bat +cp ./common/gui.inc ./common/isgui.inc + +lazbuild -B ./mricron.lpr +lazbuild -B ./npm/npm.lpr +lazbuild -B ./dcm2nii/dcm2niigui.lpr +cp ./mricron ~/mricron_lx +cp ./npm/npm ~/mricron_lx +cp ./dcm2nii/dcm2niigui ~/mricron_lx + +lazbuild --cpu=i386 -B ./mricron.lpr +lazbuild --cpu=i386 -B ./npm/npm.lpr +lazbuild --cpu=i386 -B ./dcm2nii/dcm2niigui.lpr +cp ./mricron ~/mricron_lx/mricron32 +cp ./npm/npm ~/mricron_lx/npm32 +cp ./dcm2nii/dcm2niigui ~/mricron_lx/dcm2niigui32 + + +./_xclean.bat + +cd ~ +zip -r ~/mricron_lx.zip mricron_lx + diff --git a/_osx.command b/_osx.command new file mode 100755 index 0000000..10dfcac --- /dev/null +++ b/_osx.command @@ -0,0 +1,45 @@ +#!/bin/sh + +cd /Users/rorden/Documents/pas/mricron + +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr --cpu=x86_64 --compiler="/usr/local/bin/ppcx64" +cp ./dcm2nii/dcm2nii /Users/rorden/Documents/mricron/dcm2nii64 + +# lazbuild -B ./dcm2nii/dcm2nii.lpr +lazbuild -B dcm2nii.lpr --ws=cocoa --cpu=x86_64 --os=darwin --compiler=/usr/local/bin/ppcx64 +cp ./dcm2nii/dcm2nii /Users/rorden/Documents/mricron/dcm2nii + +./_xclean.bat +cp ./common/gui.inc ./common/isgui.inc + +#compile MRIcroGn 4 +lazbuild ./mricron.lpr --cpu=x86_64 --ws=cocoa --compiler="/usr/local/bin/ppcx64" +strip ./mricron +cp ./mricron /Users/rorden/Documents/mricron/mricron64.app/Contents/MacOS/mricron + + +# lazbuild -B ./mricron.lpr --ws=carbon +lazbuild -B ./npm/npm.lpr --ws=carbon +lazbuild -B ./dcm2nii/dcm2niigui.lpr --ws=carbon +lazbuild -B ./mricron.lpr --ws=carbon +#lazbuild -B ./dcm2nii/dcm2niigui.lpr --ws=cocoa --cpu=x86_64 --os=darwin --compiler=/usr/local/bin/ppcx64 + +strip ./mricron +strip ./npm/npm +strip ./dcm2nii/dcm2niigui + +cp ./mricron /Users/rorden/Documents/mricron/mricron.app/Contents/MacOS/mricron +cp ./npm/npm /Users/rorden/Documents/mricron/npm.app/Contents/MacOS/npm +cp ./dcm2nii/dcm2niigui /Users/rorden/Documents/mricron/dcm2niigui.app/Contents/MacOS/dcm2niigui + +./_xclean.bat + +cd /Users/rorden/Documents/pas/ +zip -r /Users/rorden/Documents/mricron_source.zip mricron + +cd /Users/rorden/Documents/ +zip -r /Users/rorden/Documents/mricron_osx.zip mricron + diff --git a/_xclean.bat b/_xclean.bat new file mode 100755 index 0000000..eef22fe --- /dev/null +++ b/_xclean.bat @@ -0,0 +1,39 @@ +find . -name \*.dcu -type f -delete +rm -r *.a +rm -r *.o +rm -r *.ppu +rm -r *.bak +rm mricron + +cd ./rgb +rm -r *.a +rm -r *.o +rm -r *.ppu +rm -r *.bak +cd .. + +cd ./common +rm -r *.a +rm -r *.o +rm -r *.ppu +rm -r *.bak +cd .. + + +cd ./dcm2nii +rm ./dcm2niigui +rm ./dcm2nii +rm -r *.a +rm -r *.o +rm -r *.ppu +rm -r *.bak +rm -rf dcm2niigui.app +cd .. + +cd ./npm +rm ./npm +rm -r *.o +rm -r *.ppu +rm -r *.bak + + diff --git a/_xclean.bat~ b/_xclean.bat~ new file mode 100755 index 0000000..0a9f434 --- /dev/null +++ b/_xclean.bat~ @@ -0,0 +1,38 @@ +rm -r *.a +rm -r *.o +rm -r *.ppu +rm -r *.bak +rm mricron + +cd ./rgb +rm -r *.a +rm -r *.o +rm -r *.ppu +rm -r *.bak +cd .. + +cd ./common +rm -r *.a +rm -r *.o +rm -r *.ppu +rm -r *.bak +cd .. + + +cd ./dcm2nii +rm ./dcm2niigui +rm ./dcm2nii +rm -r *.a +rm -r *.o +rm -r *.ppu +rm -r *.bak +rm -rf dcm2niigui.app +cd .. + +cd ./npm +rm ./npm +rm -r *.o +rm -r *.ppu +rm -r *.bak + + diff --git a/about.lfm b/about.lfm new file mode 100755 index 0000000..9104a6b --- /dev/null +++ b/about.lfm @@ -0,0 +1,58 @@ +object AboutForm: TAboutForm + Left = 683 + Height = 127 + Top = 153 + Width = 440 + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'About...' + ClientHeight = 127 + ClientWidth = 440 + Constraints.MaxHeight = 127 + Constraints.MaxWidth = 440 + Constraints.MinHeight = 127 + Constraints.MinWidth = 440 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '1.5' + object Panel2: TPanel + Left = 8 + Height = 67 + Top = 47 + Width = 424 + ClientHeight = 67 + ClientWidth = 424 + TabOrder = 0 + object HomepageLabel: TLabel + Left = 0 + Height = 20 + Top = 10 + Width = 416 + Alignment = taCenter + AutoSize = False + Caption = 'version' + ParentColor = False + OnClick = HomePageClick + end + object ThreadLabel: TLabel + Left = 1 + Height = 20 + Top = 36 + Width = 417 + Alignment = taCenter + AutoSize = False + Caption = ' Threads' + ParentColor = False + end + end + object Label1: TLabel + Left = 8 + Height = 28 + Top = 16 + Width = 95 + Caption = 'MRIcron' + Font.Height = -24 + ParentColor = False + ParentFont = False + end +end diff --git a/about.lrs b/about.lrs new file mode 100644 index 0000000..21a1fe0 --- /dev/null +++ b/about.lrs @@ -0,0 +1,19 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TAboutForm','FORMDATA',[ + 'TPF0'#10'TAboutForm'#9'AboutForm'#4'Left'#3#171#2#6'Height'#2#127#3'Top'#3 + +#153#0#5'Width'#3#184#1#11'BorderIcons'#11#12'biSystemMenu'#0#11'BorderStyle' + +#7#8'bsDialog'#7'Caption'#6#8'About...'#12'ClientHeight'#2#127#11'ClientWidt' + +'h'#3#184#1#21'Constraints.MaxHeight'#2#127#20'Constraints.MaxWidth'#3#184#1 + +#21'Constraints.MinHeight'#2#127#20'Constraints.MinWidth'#3#184#1#8'OnCreate' + +#7#10'FormCreate'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#3'1.5'#0 + +#6'TPanel'#6'Panel2'#4'Left'#2#8#6'Height'#2'C'#3'Top'#2'/'#5'Width'#3#168#1 + +#12'ClientHeight'#2'C'#11'ClientWidth'#3#168#1#8'TabOrder'#2#0#0#6'TLabel'#13 + +'HomepageLabel'#4'Left'#2#0#6'Height'#2#20#3'Top'#2#10#5'Width'#3#160#1#9'Al' + +'ignment'#7#8'taCenter'#8'AutoSize'#8#7'Caption'#6#7'version'#11'ParentColor' + +#8#7'OnClick'#7#13'HomePageClick'#0#0#6'TLabel'#11'ThreadLabel'#4'Left'#2#1#6 + +'Height'#2#20#3'Top'#2'$'#5'Width'#3#161#1#9'Alignment'#7#8'taCenter'#8'Auto' + +'Size'#8#7'Caption'#6#8' Threads'#11'ParentColor'#8#0#0#0#6'TLabel'#6'Label1' + +#4'Left'#2#8#6'Height'#2#28#3'Top'#2#16#5'Width'#2'_'#7'Caption'#6#7'MRIcron' + +#11'Font.Height'#2#232#11'ParentColor'#8#10'ParentFont'#8#0#0#0 +]); diff --git a/about.pas b/about.pas new file mode 100755 index 0000000..8ab9e54 --- /dev/null +++ b/about.pas @@ -0,0 +1,66 @@ +unit about; + +interface + +uses +{$IFDEF FPC}LResources,{$ELSE} ShellAPI, {$ENDIF} +{$IFNDEF Unix} Windows,{$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls, define_types; + +type + + { TAboutForm } + + TAboutForm = class(TForm) + HomepageLabel: TLabel; + Label1: TLabel; + Panel2: TPanel; + ThreadLabel: TLabel; + procedure FormCreate(Sender: TObject); + procedure HomePageClick(Sender: TObject); + procedure Panel1Click(Sender: TObject); + procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer); + private + { Private declarations } + public + { Public declarations } + end; + +var + AboutForm: TAboutForm; + +implementation +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + +procedure TAboutForm.FormCreate(Sender: TObject); +begin + HomepageLabel.caption := 'www.mricro.com :: '+kMRIcronVers ; +end; + +procedure TAboutForm.HomePageClick(Sender: TObject); +begin +{$IFDEF FPC} +{$ELSE} + ShellExecute (0, Nil, 'http://www.mricro.com', Nil, Nil, SW_ShowDefault); +{$ENDIF} +end; + +procedure TAboutForm.Panel1Click(Sender: TObject); +begin + +end; + +procedure TAboutForm.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer); +begin +//showmessage('x'); +end; + +{$IFDEF FPC} +initialization + {$I about.lrs} +{$ENDIF} + +end. diff --git a/autoroi.lfm b/autoroi.lfm new file mode 100755 index 0000000..6bbb428 --- /dev/null +++ b/autoroi.lfm @@ -0,0 +1,174 @@ +object AutoROIForm: TAutoROIForm + Left = 785 + Height = 355 + Top = 200 + Width = 265 + HorzScrollBar.Page = 264 + VertScrollBar.Page = 354 + ActiveControl = VarianceEdit + Caption = 'Create ROI' + ClientHeight = 355 + ClientWidth = 265 + Constraints.MaxHeight = 355 + Constraints.MaxWidth = 265 + Constraints.MinHeight = 355 + Constraints.MinWidth = 265 + OnCreate = FormCreate + OnDestroy = FormDestroy + OnHide = FormHide + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.4.2.0' + object OriginLabel: TLabel + Left = 4 + Height = 17 + Top = 42 + Width = 44 + Caption = 'Origin: ' + Color = clDefault + Transparent = False + end + object OriginBtn: TSpeedButton + Left = 7 + Height = 25 + Hint = 'You can also double-click on the image' + Top = 5 + Width = 114 + Caption = 'Reset origin' + OnClick = OriginBtnClick + ShowHint = True + ParentShowHint = False + end + object DiffLabel: TLabel + Left = 12 + Height = 17 + Top = 98 + Width = 137 + Caption = 'Difference from origin' + Color = clDefault + Transparent = False + end + object Label1: TLabel + Left = 12 + Height = 17 + Top = 132 + Width = 117 + Caption = 'Difference at edge' + Color = clDefault + Transparent = False + end + object Label2: TLabel + Left = 12 + Height = 17 + Top = 167 + Width = 79 + Caption = 'Radius (mm)' + Color = clDefault + Transparent = False + end + object Label3: TLabel + Left = 12 + Height = 17 + Top = 202 + Width = 120 + Caption = 'Erode/dilate cycles' + Color = clDefault + Transparent = False + end + object AutoROIBtn: TSpeedButton + Left = 56 + Height = 25 + Top = 304 + Width = 65 + Caption = 'Apply' + OnClick = AutoROIBtnClick + end + object CancelBtn: TSpeedButton + Left = 120 + Height = 25 + Top = 304 + Width = 65 + Caption = 'Cancel' + OnClick = CancelBtnClick + end + object Label4: TLabel + Left = 4 + Height = 17 + Top = 74 + Width = 72 + Caption = 'Constraints' + Color = clDefault + Transparent = False + end + object ExcludeBlackCheck: TCheckBox + Left = 12 + Height = 18 + Top = 236 + Width = 211 + Caption = 'Zero intensity constrains edge' + OnClick = AutoROIchange + TabOrder = 0 + end + object VarianceEdit: TSpinEdit + Left = 173 + Height = 16 + Top = 90 + Width = 72 + MaxValue = 255 + OnChange = AutoROIchange + TabOrder = 1 + Value = 16 + end + object EdgeEdit: TSpinEdit + Left = 173 + Height = 16 + Top = 126 + Width = 72 + MaxValue = 255 + OnChange = AutoROIchange + TabOrder = 2 + Value = 16 + end + object RadiusEdit: TSpinEdit + Left = 173 + Height = 16 + Top = 161 + Width = 72 + MaxValue = 9999 + OnChange = AutoROIchange + TabOrder = 3 + Value = 32 + end + object ErodeEdit: TSpinEdit + Left = 173 + Height = 16 + Top = 196 + Width = 72 + MaxValue = 12 + OnChange = AutoROIchange + TabOrder = 4 + end + object ROIconstraint: TComboBox + Left = 12 + Height = 20 + Top = 268 + Width = 212 + ItemHeight = 0 + Items.Strings = ( + 'Append to current VOI' + 'Delete from current VOI' + 'Constain with current VOI' + ) + OnChange = AutoROIchange + ParentColor = True + Style = csDropDownList + TabOrder = 5 + end + object Timer1: TTimer + Enabled = False + Interval = 400 + OnTimer = Timer1Timer + left = 40 + top = 34 + end +end diff --git a/autoroi.lrs b/autoroi.lrs new file mode 100644 index 0000000..3c0253b --- /dev/null +++ b/autoroi.lrs @@ -0,0 +1,46 @@ +LazarusResources.Add('TAutoROIForm','FORMDATA',[ + 'TPF0'#12'TAutoROIForm'#11'AutoROIForm'#4'Left'#3#17#3#6'Height'#3'c'#1#3'Top' + +#3#200#0#5'Width'#3#9#1#18'HorzScrollBar.Page'#3#8#1#18'VertScrollBar.Page'#3 + +'b'#1#13'ActiveControl'#7#12'VarianceEdit'#7'Caption'#6#10'Create ROI'#12'Cl' + +'ientHeight'#3'c'#1#11'ClientWidth'#3#9#1#21'Constraints.MaxHeight'#3'c'#1#20 + +'Constraints.MaxWidth'#3#9#1#21'Constraints.MinHeight'#3'c'#1#20'Constraints' + +'.MinWidth'#3#9#1#8'OnCreate'#7#10'FormCreate'#9'OnDestroy'#7#11'FormDestroy' + +#6'OnHide'#7#8'FormHide'#6'OnShow'#7#8'FormShow'#8'Position'#7#14'poScreenCe' + +'nter'#10'LCLVersion'#6#7'1.4.2.0'#0#6'TLabel'#11'OriginLabel'#4'Left'#2#4#6 + +'Height'#2#17#3'Top'#2'*'#5'Width'#2','#7'Caption'#6#8'Origin: '#5'Color'#7#9 + +'clDefault'#11'Transparent'#8#0#0#12'TSpeedButton'#9'OriginBtn'#4'Left'#2#7#6 + +'Height'#2#25#4'Hint'#6'&You can also double-click on the image'#3'Top'#2#5#5 + +'Width'#2'r'#7'Caption'#6#12'Reset origin'#7'OnClick'#7#14'OriginBtnClick'#8 + +'ShowHint'#9#14'ParentShowHint'#8#0#0#6'TLabel'#9'DiffLabel'#4'Left'#2#12#6 + +'Height'#2#17#3'Top'#2'b'#5'Width'#3#137#0#7'Caption'#6#22'Difference from o' + +'rigin'#5'Color'#7#9'clDefault'#11'Transparent'#8#0#0#6'TLabel'#6'Label1'#4 + +'Left'#2#12#6'Height'#2#17#3'Top'#3#132#0#5'Width'#2'u'#7'Caption'#6#18'Diff' + +'erence at edge'#5'Color'#7#9'clDefault'#11'Transparent'#8#0#0#6'TLabel'#6'L' + +'abel2'#4'Left'#2#12#6'Height'#2#17#3'Top'#3#167#0#5'Width'#2'O'#7'Caption'#6 + +#11'Radius (mm)'#5'Color'#7#9'clDefault'#11'Transparent'#8#0#0#6'TLabel'#6'L' + +'abel3'#4'Left'#2#12#6'Height'#2#17#3'Top'#3#202#0#5'Width'#2'x'#7'Caption'#6 + +#19'Erode/dilate cycles'#5'Color'#7#9'clDefault'#11'Transparent'#8#0#0#12'TS' + +'peedButton'#10'AutoROIBtn'#4'Left'#2'8'#6'Height'#2#25#3'Top'#3'0'#1#5'Widt' + +'h'#2'A'#7'Caption'#6#5'Apply'#7'OnClick'#7#15'AutoROIBtnClick'#0#0#12'TSpee' + +'dButton'#9'CancelBtn'#4'Left'#2'x'#6'Height'#2#25#3'Top'#3'0'#1#5'Width'#2 + +'A'#7'Caption'#6#6'Cancel'#7'OnClick'#7#14'CancelBtnClick'#0#0#6'TLabel'#6'L' + +'abel4'#4'Left'#2#4#6'Height'#2#17#3'Top'#2'J'#5'Width'#2'H'#7'Caption'#6#11 + +'Constraints'#5'Color'#7#9'clDefault'#11'Transparent'#8#0#0#9'TCheckBox'#17 + +'ExcludeBlackCheck'#4'Left'#2#12#6'Height'#2#18#3'Top'#3#236#0#5'Width'#3#211 + +#0#7'Caption'#6#30'Zero intensity constrains edge'#7'OnClick'#7#13'AutoROIch' + +'ange'#8'TabOrder'#2#0#0#0#9'TSpinEdit'#12'VarianceEdit'#4'Left'#3#173#0#6'H' + +'eight'#2#16#3'Top'#2'Z'#5'Width'#2'H'#8'MaxValue'#3#255#0#8'OnChange'#7#13 + +'AutoROIchange'#8'TabOrder'#2#1#5'Value'#2#16#0#0#9'TSpinEdit'#8'EdgeEdit'#4 + +'Left'#3#173#0#6'Height'#2#16#3'Top'#2'~'#5'Width'#2'H'#8'MaxValue'#3#255#0#8 + +'OnChange'#7#13'AutoROIchange'#8'TabOrder'#2#2#5'Value'#2#16#0#0#9'TSpinEdit' + +#10'RadiusEdit'#4'Left'#3#173#0#6'Height'#2#16#3'Top'#3#161#0#5'Width'#2'H'#8 + +'MaxValue'#3#15''''#8'OnChange'#7#13'AutoROIchange'#8'TabOrder'#2#3#5'Value' + +#2' '#0#0#9'TSpinEdit'#9'ErodeEdit'#4'Left'#3#173#0#6'Height'#2#16#3'Top'#3 + +#196#0#5'Width'#2'H'#8'MaxValue'#2#12#8'OnChange'#7#13'AutoROIchange'#8'TabO' + +'rder'#2#4#0#0#9'TComboBox'#13'ROIconstraint'#4'Left'#2#12#6'Height'#2#20#3 + +'Top'#3#12#1#5'Width'#3#212#0#10'ItemHeight'#2#0#13'Items.Strings'#1#6#21'Ap' + +'pend to current VOI'#6#23'Delete from current VOI'#6#25'Constain with curre' + +'nt VOI'#0#8'OnChange'#7#13'AutoROIchange'#11'ParentColor'#9#5'Style'#7#14'c' + +'sDropDownList'#8'TabOrder'#2#5#0#0#6'TTimer'#6'Timer1'#7'Enabled'#8#8'Inter' + +'val'#3#144#1#7'OnTimer'#7#11'Timer1Timer'#4'left'#2'('#3'top'#2'"'#0#0#0 +]); diff --git a/autoroi.pas b/autoroi.pas new file mode 100755 index 0000000..027cee1 --- /dev/null +++ b/autoroi.pas @@ -0,0 +1,601 @@ +unit autoroi; + +interface + +uses + {$IFNDEF FPC} + RXSpin,capmenu, + {$ELSE} + Spin,lResources, + {$ENDIF} + {$IFNDEF Unix} Windows,{$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Buttons, StdCtrls, define_types, ExtCtrls, nifti_img,nifti_img_view; + +type + + { TAutoROIForm } + + TAutoROIForm = class(TForm) + OriginLabel: TLabel; + OriginBtn: TSpeedButton; + EdgeEdit: TSpinEdit; + RadiusEdit: TSpinEdit; + ErodeEdit: TSpinEdit; + ROIconstraint: TComboBox; + VarianceEdit: TSpinEdit; + DiffLabel: TLabel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + AutoROIBtn: TSpeedButton; + CancelBtn: TSpeedButton; + Timer1: TTimer; + Label4: TLabel; + ExcludeBlackCheck: TCheckBox; + procedure OriginBtnClick(Sender: TObject); + procedure PreviewBtnClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure AutoROIBtnClick(Sender: TObject); + procedure CancelBtnClick(Sender: TObject); + procedure AutoROIchange(Sender: TObject); + procedure Timer1Timer(Sender: TObject); + procedure FormDestroy(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +procedure ROICluster ({lInROIBuf: bytep;} lXdim, lYDim, lZDim,lXOriginIn,lYOrigin,lZOrigin: integer; lDeleteNotFill: boolean); +var + AutoROIForm: TAutoROIForm; + gOriginX,gOriginY,gOriginZ: integer; +implementation + + {$IFNDEF FPC} + {$R *.DFM} + {$ENDIF} + + +procedure TAutoROIForm.OriginBtnClick(Sender: TObject); +begin + gOriginX := ImgForm.XViewEdit.value; + gOriginY := ImgForm.YViewEdit.value; + gOriginZ := ImgForm.ZViewEdit.value; + OriginLabel.Caption := 'Origin: '+inttostr(gOriginX)+'x'+inttostr(gOriginY)+'x'+inttostr(gOriginZ); + PreviewBtnClick(sender); +end; + +procedure TAutoROIForm.PreviewBtnClick(Sender: TObject); +var + lXmm,lYmm,lZmm,lSqrRadius: single; + lExcludeBlackIfZero,//lX,lY,lZ, //abba + {lMaxROISz,}lEdge,lOriginPos,lROISz,lOriginIntensity,lVariance,lXdim, lYDim, lZDim: integer; + lErodeCycles,lQTail,lQHead,lSliceSz,lQSz,lInc,lVolSz{,lX,lY,lZ}: integer; + lROIConstrain,lReadFilteredData: boolean; + lQra: LongIntP; + lSourceBuffer,lBuff,lPreErodeBuff: ByteP; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; +function UnsmoothedIntensity(lPixel: integer): integer; //1381 +begin + if lReadFilteredData then + result := lBuff^[lPixel] + else + Result :=lSourceBuffer^[lPixel]; +end; + + function MeanIntensity(lPixel: integer): integer; + var lV: integer; + begin + if lReadFilteredData then + result := lBuff^[lPixel] + else if ((lPixel-lSliceSz) > 0) and ((lPixel+lSliceSz) <= lVolSz) then begin + lV :=lSourceBuffer^[lPixel]+lSourceBuffer^[lPixel+1]+lSourceBuffer^[lPixel-1] //L/R + +lSourceBuffer^[lPixel+lXdim]+lSourceBuffer^[lPixel-lXdim] //Anterior/Posterior + +lSourceBuffer^[lPixel+lSliceSz]+lSourceBuffer^[lPixel-lSliceSz]; //Dorsal/Ventral + result := lV div 7; + end else result := lSourceBuffer^[lPixel];//1401 gImageBackupBuffer[lPixel] + end; + procedure Check(lPixel,lIntensity: integer); + var lSmoothInten :integer; + begin + lSmoothInten := MeanIntensity(lPixel); + if (lROIConstrain) and (gBGImg.VOIUndoVol^[lPixel] > 0) then //1410 + //constrain + else if (lBuff^[lPixel]<> 255) and (UnsmoothedIntensity(lPixel) > lExcludeBlackIfZero {1381}) and (abs(lSmoothInten-lIntensity)<=lEdge) and(abs(lSmoothInten-lOriginIntensity)<=lVariance) {}then begin//add item + incQra(lQHead,lQSz); + inc(lROISz); + lBuff^[lPixel] := 255; + lQra^[lQHead] := lPixel; + end; + end; + +PROCEDURE RetirePixel; //FIFO cleanup +function WithinRadius(lXs,lYs,lZs:integer): boolean; +begin + if (sqr((lXs-gOriginX)*lXmm)+sqr((lYs-gOriginY)*lYmm)+sqr((lZs-gOriginZ)*lZmm)) > lSqrRadius then + result := false + else + result := true; +end; +VAR + lVal,lXPos,lYPos,lZPos,lIntensity: integer; +BEGIN + lVal := lQra^[lQTail]; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + if lReadFilteredData then + lIntensity := 128 + else + lIntensity := lSourceBuffer^[lVal];//1401 gImageBackupBuffer[lVal]; + if (lXpos > 1) and WithinRadius(lXpos-1,lYpos,lZpos) then Check(lVal -1,lIntensity);//check to left + if (lXPos < lXDim) and (WithinRadius(lXpos+1,lYpos,lZpos)) then Check(lVal + 1,lIntensity); //check to right + if (lYpos > 1) and (WithinRadius(lXpos,lYpos-1,lZpos)) then Check(lVal -lXdim,lIntensity);//check previous line + if (lYPos < lYDim) and (WithinRadius(lXpos,lYpos+1,lZpos)) then Check(lVal + lXdim,lIntensity); //check next line + if (lZpos > 1) and (WithinRadius(lXpos,lYpos,lZpos-1)) then Check(lVal -lSliceSz,lIntensity);//check previous slice + if (lZPos < lZDim) and (WithinRadius(lXpos,lYpos,lZpos+1)) then Check(lVal + lSliceSz,lIntensity); //check next slice + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + for lI := 1 to lQsz do + lQra^[lI] := 0; + lQHead := 0; + lQTail := 1; + lROISz := 0; + Check(lPt,lOriginIntensity); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +function ROIOnEdge (lVal: integer): boolean; +BEGIN + result := false; + if lBuff^[lVal] <> 255 then exit; //not ROI - is not boundary + //Find + if ((lVal-lSliceSz) > 0) and ((lVal+lSliceSz) <= lVolSz) then begin + if lBuff^[lVal+1] = 0 then result := true; + if lBuff^[lVal-1] = 0 then result := true; + if lBuff^[lVal+lXdim] = 0 then result := true; + if lBuff^[lVal-lXdim] = 0 then result := true; + if lBuff^[lVal+lSliceSz] = 0 then result := true; + if lBuff^[lVal-lSliceSz] = 0 then result := true; + end; +end; + +function ZeroOnEdge (lVal: integer): boolean; +BEGIN + result := false; + if lBuff^[lVal] <> 0 then exit; //not ROI - is not boundary + //Find + if ((lVal-lSliceSz) > 0) and ((lVal+lSliceSz) <= lVolSz) then begin + if lBuff^[lVal+1] = 255 then result := true; + if lBuff^[lVal-1] = 255 then result := true; + if lBuff^[lVal+lXdim] = 255 then result := true; + if lBuff^[lVal-lXdim] = 255 then result := true; + if lBuff^[lVal+lSliceSz] = 255 then result := true; + if lBuff^[lVal-lSliceSz] = 255 then result := true; + end; +end; + +begin //alfa666 + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gBGImg.VOIUndoVolItems) then exit; + //if gImageBackupSz <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + //UpdateBackupBuffer; + lXdim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + if (gBGImg.Scrnmm[1] = 0) or (gBGImg.Scrnmm[2]=0) or (gBGImg.Scrnmm[3]=0) then begin + lXmm := 1; + lYmm := 1; + lZmm := 1; + end else begin + lXmm := gBGImg.Scrnmm[1]; + lYmm := gBGImg.Scrnmm[2]; + lZmm := gBGImg.Scrnmm[3]; + end; + lSliceSz := lXdim * lYdim; + lVolSz := lSliceSz*lZdim; + //lMaxROISz := round(PctImg.Value/100 * lVolSz); + lOriginPos := gOriginX + ((gOriginY-1)*lXdim) + ((gOriginZ-1)*lSliceSz); + if (lOriginPos < 1) or (lVolSz <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) or (lOriginPos > lVolSz) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> gBGImg.VOIUndoVolItems) then + exit; + {$IFNDEF FPC} + lVariance := AutoROIForm.VarianceEdit.asinteger; //asinteger; + lEdge := AutoROIForm.EdgeEdit.asinteger; + lSqrRadius := sqr(AutoROIForm.RadiusEdit.asinteger); + {$ELSE} + lVariance := AutoROIForm.VarianceEdit.value; //asinteger; + lEdge := AutoROIForm.EdgeEdit.value; + lSqrRadius := sqr(AutoROIForm.RadiusEdit.value); + {$ENDIF} + if (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) then exit; + lSourceBuffer := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer;//gBuffer; + //Next - START count cluster size + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + //check positive clusters.... + Getmem(lBuff,lVolSz); + FillChar(lBuff^,lVolSz, 0); + //Move(gImageBackupBuffer^,lBuff^,lVolSz); + if ExcludeBlackCheck.checked then //1381 + lExcludeBlackIfZero := 0 //0 + else + lExcludeBlackIfZero := -1;//impossible 8-bit value: do not use this feature + lOriginIntensity := lSourceBuffer^[lOriginPos]; //1401 gImageBackupBuffer[lOriginPos]; + lReadFilteredData := false; + //ROIconstrainCheck.enabled := (gROIBupSz > 1); //1410: next 3 lines + ROIconstraint.enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); //1410: next 3 lines + if (ROIconstraint.ItemIndex = 2) and (ROIconstraint.enabled) then + lROIConstrain := true + else + lROIconstrain := false; + FillStart(lOriginPos); + lROIConstrain := false;//1410 + //START: ERODE/DILATE CYCLES +{$IFNDEF FPC} + lErodeCycles := AutoROIForm.ErodeEdit.asinteger; +{$ELSE} + lErodeCycles := AutoROIForm.ErodeEdit.value; +{$ENDIF} + if lErodeCycles > 0 then begin + Getmem(lPreErodeBuff,lVolSz); + Move(lBuff^,lPreErodeBuff^,lVolSz); + for lQHead := 1 to lErodeCycles do begin//ERODE + for lInc := 1 to lVolSz do + if ROIonEdge(lInc) then + lBuff^[lInc] :=254; + for lInc := 1 to lVolSz do + if lBuff^[lInc]=254 then + lBuff^[lInc] := 0; //erode + end;//for ErodeCycles = ERODE + //SET ALL VOXELS THAT HAVE SURVIVED EROSION TO 128, WE THEN GROW THE ORIGIN + for lInc := 1 to lVolSz do + if lBuff^[lInc] =255 then lBuff^[lInc] := 128; + //NOW - ONLY PRESERVE STUFF CONNECTED TO ORIGIN + lBuff^[lOriginPos] := 128; + lOriginIntensity := 128; + lVariance := 2; + lEdge := 2; + lReadFilteredData := true; + FillStart(lOriginPos); + //SWITCH OFF ALL UNCONNECTED BLOBS + for lInc := 1 to lVolSz do + if lBuff^[lInc] =128 then lBuff^[lInc] := 0; + //for lInc := 1 to lVolSz do + // if lBuff[lInc] > 0 then showmessage(inttostr(lBuff[lInc]));// := 0; + + for lQHead := 1 to lErodeCycles do begin//DILATE + for lInc := 1 to lVolSz do + if (lPreErodeBuff^[lInc] = 255) and (ZeroonEdge(lInc)) then + lBuff^[lInc] :=254; + for lInc := 1 to lVolSz do + if lBuff^[lInc]=254 then + lBuff^[lInc] := 255; //erode + end;//for ErodeCycles = DILATE + Freemem(lPreErodeBuff); + {} + end; //ERODE cycles > 0 + //END: ERODE/DILATE + Freemem(lQra); + ROIconstraint.enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); //1410: next 3 lines + if (ROIconstraint.ItemIndex = 1) and (ROIconstraint.enabled) then begin //delete ROI + for lInc := 1 to gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems do //gROIBup + if (lBuff^[lInc] = 255) then + lBuff^[lInc] := 0 + else + lBuff^[lInc] := gBGImg.VOIUndoVol^[lInc]; + end else (*if true {alfa (gDynSz > 1) and (gROIBupsz > 1) {and (gImageBackupSz = gDynSz){} then begin + for lInc := 1 to gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems do + if lBuff[lInc] = 255 then + else if gImageBackupBuffer[lInc] = 255 then + lBuff[lInc] := 255//255; + else lBuff[lInc] := lSourceBuffer[lInc]; + + end else *) + for lInc := 1 to lVolSz do + if lBuff^[lInc] <> 255 then + lBuff^[lInc] := gBGImg.VOIUndoVol^[lInc] + else + lBuff^[lInc] := kVOI8bit;//1401 gImageBackupBuffer[lInc]; + Move(lBuff^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lVolSz); + Freemem(lBuff); + //END check clusters + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TAutoROIForm.FormShow(Sender: TObject); +begin +EnsureVOIOpen; +CreateUndoVol; + AutoROIForm.ModalResult := mrCancel; + ROIconstraint.Enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); + OriginBtn.OnClick(sender); + //DeleteCheck.enabled := (gROIBupSz > 1); + //ROIConstrainCheck.enabled := (gROIBupSz > 1); +end; + +procedure TAutoROIForm.FormCreate(Sender: TObject); +begin + {$IFNDEF FPC} + ROIconstraint.SetItemIndex(0);//1410 + {$ELSE} + ROIconstraint.ItemIndex := (0);//1410 + {$ENDIF} +end; + +procedure TAutoROIForm.FormHide(Sender: TObject); +begin +// if (AutoROIForm.ModalResult = mrCancel) and (gBGImg.VOIUndoVolItems > 1) and (gBGImg.VOIUndoVolItems = gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems) then +// Move(gImageBackupBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gImageBackupSz); + if (AutoROIForm.ModalResult = mrCancel) then + UndoVolVOI; + if not (AutoROIForm.ModalResult = mrCancel) then + gBGImg.VOIchanged := true; + //if gImageBackupSz <> 0 then Freemem(gImageBackupBuffer); + //gImageBackupSz := 0; + ImgForm.Fill3DBtn.Down := false; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +//Previous: create 3D ROI +//Below fill bubbles in 3D ROIS +//ROIcluster Follows +(***********************************************************88 +************************************************************ +**********************************************************) +procedure ROICluster (lXdim, lYDim, lZDim,lXOriginIn,lYOrigin,lZOrigin: integer; lDeleteNotFill: boolean); +var + lVariability,lOrigin,lClusterInputValue,lClusterOutputValue, lClusterSz,lQTail, + lXOrigin,lQHead,lSliceSz,lQSz,lInc,lVolSz: integer; + lXInc,lYInc,lZInc,lSlicePos,lYPos, + lMinX,lMaxX,lMinY,lMaxY,lMinZ,lMaxZ, + lMinXBound,lMaxXBound,lMinYBound,lMaxYBound,lMinZBound,lMaxZBound: integer; + lAtEdge: boolean; + lROIBuf: bytep; + lQra: LongIntP; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; + + procedure Check(lPixel: integer); + begin + if (abs(lROIBuf^[lPixel] - lClusterInputValue)) <= lVariability then begin//add item + incQra(lQHead,lQSz); + inc(lClusterSz); + lROIBuf^[lPixel] := lClusterOutputValue; + lQra^[lQHead] := lPixel; + end; + end; + +PROCEDURE RetirePixel; //FIFO cleanup +VAR + lVal,lXPos,lYPos,lZPos: integer; +BEGIN + lVal := lQra^[lQTail]; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + + if lXPos < lMinX then lMinX := lXPos; + if lXPos > lMaxX then lMaxX := lXPos; + if lXpos > lMinXBound then Check(lVal -1);//check to left + if lXPos < lMaxXBound then Check(lVal + 1); //check to right + + if lYPos < lMinY then lMinY := lYPos; + if lYPos > lMaxY then lMaxY := lYPos; + if lYpos > lMinYBound then Check(lVal -lXdim);//check previous line + if lYPos < lMaxYBound then Check(lVal + lXdim); //check next line + + if lZPos < lMinZ then lMinZ := lZPos; + if lZPos > lMaxZ then lMaxZ := lZPos; + if lZpos > lMinZBound then Check(lVal -lSliceSz);//check previous slice + if lZPos < lMaxZBound then Check(lVal + lSliceSz); //check next slice + + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + //1414 follows + for lI := 1 to lQsz do + lQra^[lI] := 0; + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +procedure SelectClusters (lInput,lOutput: integer); +begin + lClusterSz := 0; + lClusterInputValue := lInput; + lClusterOutputValue := lOutput; + FillStart(lOrigin); +end; + +function Lo (lVolumeEdge,lObjectEdge: integer): integer; +begin + if lVolumeEdge > lObjectEdge then + result := lObjectEdge + else begin + lAtEdge := true; + result := lVolumeEdge; + end; +end; + +function Hi (lVolumeEdge,lObjectEdge: integer): integer; +begin + if lVolumeEdge < lObjectEdge then + result := lObjectEdge + else begin + lAtEdge := true; + result := lVolumeEdge; + end; +end; + +begin + lXOrigin := lXOriginIn; + lVolSz := lXdim*lYdim*lZdim; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems <> lVolSz then begin + showmessage('You need to draw or load a VOI in order to use the 3D bubble tool.'); + exit; + end; + CreateUndoVol; + lSliceSz := lXdim * lYdim; + lMinX:=lXOrigin; + lMaxX:=lXOrigin; + lMinY:=lYOrigin; + lMaxY:=lYOrigin; + lMinZ:=lZOrigin; + lMaxZ:=lZOrigin; + lMinXBound := 1; + lMaxXBound := lXDim; + lMinYBound := 1; + lMaxYBound := lYDim; + lMinZBound := 1; + lMaxZBound := lZDim; + lOrigin := lXOrigin + ((lYOrigin-1)*lXdim)+((lZOrigin-1)*lSliceSz); + if (lOrigin > lVolSz) or (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) {or (gROIBupSz <> lVolSz )} then exit; + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lOrigin] = 0) then begin + showmessage('You must click directly on a ROI to select it. The 3D ROI bubble tool will not work unless you choose the ROI you wish to fill/delete.'); + exit; + end; + GetMem(lROIBuf, lVolSz); + for lInc := 1 to lVolSz do + if gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lInc] > 0 then//ROI + lROIBuf^[lInc] := 1 + else + lROIBuf^[lInc] := 0; + //BEGIN: define selected ROI contiguous cluster + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + lVariability := 0; //only convert images that are exactly 1 + SelectClusters(1,255); //selected 3D ROI is 255, other ROI = 1, nonROI 0 + //END: define selected roi + //BEGIN: either delete selected ROI, _OR_ fill bubbles in selected ROI + if lDeleteNotFill then begin + for lInc := 1 to lVolSz do + if lROIBuf^[lInc] = 1 then //alfa + lROIBuf^[lInc] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lInc] //a different ROI + else + lROIBuf^[lInc] := 0;//gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lInc]; //1402 selected ROI or non-ROI + end else begin //fill bubbles in selected ROI + //FindROIbounds; + lMinXBound := Hi(1,lMinX-1); + lMaxXBound := Lo(lXDim,lMaxX+1); + lMinYBound := Hi(1,lMinY-1); + lMaxYBound := Lo(lYDim,lMaxY+1); + lMinZBound := Hi(1,lMinZ-1); + lMaxZBound := Lo(lZDim,lMaxZ+1); + lOrigin := (lMinXBound) + ((lMinYBound-1)*lXdim)+((lMinZBound-1)*lSliceSz); + lVariability := 2;//convert voxels that are either 0 or 1 to 1 + SelectClusters(1,128); + //now bubbles trapped in volume are set to zero + //we next need to distinguish bubbles from unmarked voxels outside the searched object boundary + for lZInc := lMinZBound to lMaxZBound do begin + lSlicePos := (lZInc-1) * lSliceSz; + for lYInc := lMinYBound to lMaxYBound do begin + lYPos := (lYInc-1) * lXDim; + for lXInc := lMinXBound to lMaxXBound do begin + lInc := lXInc + lYPos + lSlicePos; + if lROIBuf^[lInc] = 0 then lROIBuf^[lInc] := 33; + end; //for X + end; //for Y + end; //for Z + + for lInc := 1 to lVolSz do + if lROIBuf^[lInc] = 33 then + lROIBuf^[lInc] := kVOI8bit //bubble in selected ROI + else + lROIBuf^[lInc] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lInc]; + end; + Freemem(lQra); + //BEGIN: CREATE 3D UNDO BUFFER + (*if (gDynSz > 1) and (gDynSz = gImageBackupSz) then begin + if (gUndoBufSz > 0) then freemem(gUndoBuffer); + gUndoBufSz := gDynSz; + getmem(gUndoBuffer,gDynSz); + Move(gImageBackupBuffer^,gUndoBuffer^,gImageBackupSz); + gSaveUndoBuf := true; + end; (**) + //END: CREATE 3D UNDO BUFFER + //BEGIN: mopping up: prepare data for viewing, report ROI change + Move(lROIBuf^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lVolSz); + Freemem(lROIBuf); {} + gBGImg.VOIchanged := true; + //END: mopping up + ImgForm.RefreshImagesTimer.enabled := true; +end; (**) + +procedure TAutoROIForm.AutoROIBtnClick(Sender: TObject); +begin + AutoROIForm.ModalResult := mrOK; + AutoROIForm.close; +end; + +procedure TAutoROIForm.CancelBtnClick(Sender: TObject); +begin + AutoROIForm.close; +end; + +procedure TAutoROIForm.AutoROIchange(Sender: TObject); +begin + if not AutoROIForm.visible then exit; + Timer1.Enabled := true; +end; + +procedure TAutoROIForm.Timer1Timer(Sender: TObject); +begin +Timer1.Enabled := false; +PreviewBtnClick(sender); +end; + +procedure TAutoROIForm.FormDestroy(Sender: TObject); +begin + //if gImageBackupSz <> 0 then Freemem(gImageBackupBuffer); + //gImageBackupSz := 0; +end; + + {$IFDEF FPC} +initialization + {$I autoroi.lrs} +{$ENDIF} + +end. diff --git a/backup/MultiSlice.lfm.bak b/backup/MultiSlice.lfm.bak new file mode 100755 index 0000000..d89586f --- /dev/null +++ b/backup/MultiSlice.lfm.bak @@ -0,0 +1,172 @@ +object MultiSliceForm: TMultiSliceForm + Left = 493 + Height = 242 + Top = 292 + Width = 745 + Caption = 'MultiSlice' + ClientHeight = 242 + ClientWidth = 745 + Font.Height = -11 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object MultiPanel: TScrollBox + Left = 0 + Height = 242 + Top = 0 + Width = 745 + HorzScrollBar.Page = 14 + VertScrollBar.Page = 14 + Align = alClient + ClientHeight = 227 + ClientWidth = 730 + TabOrder = 0 + object MultiImage: TImage + Tag = 2 + Cursor = crCross + Left = 2 + Height = 12 + Top = 2 + Width = 12 + AutoSize = True + Stretch = True + end + end + object MainMenu1: TMainMenu + left = 40 + top = 8 + object File1: TMenuItem + Caption = 'File' + object Settings1: TMenuItem + Caption = 'Open settings' + OnClick = Settings1Click + end + object Savesettings1: TMenuItem + Caption = 'Save settings' + ShortCut = 16467 + OnClick = Savesettings1Click + end + object Saveasbitmap1: TMenuItem + Caption = 'Save as bitmap...' + OnClick = Saveasbitmap1Click + end + object Closewindow1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Closewindow1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + ShortCut = 16451 + OnClick = Copy1Click + end + end + object View1: TMenuItem + Caption = 'View' + object OrientMenu: TMenuItem + Caption = 'Orient' + object Sagittal1: TMenuItem + Tag = 2 + Caption = 'Sagittal' + GroupIndex = 129 + RadioItem = True + OnClick = OrientClick + end + object Coronal1: TMenuItem + Tag = 3 + Caption = 'Coronal' + GroupIndex = 129 + RadioItem = True + OnClick = OrientClick + end + object Axial1: TMenuItem + Tag = 1 + Caption = 'Axial' + Checked = True + GroupIndex = 129 + RadioItem = True + OnClick = OrientClick + end + end + object OversliceMenu: TMenuItem + Caption = 'Overslice' + object N501: TMenuItem + Tag = -50 + Caption = '-50%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N331: TMenuItem + Tag = -35 + Caption = '-35%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N201: TMenuItem + Tag = -20 + Caption = '-20%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N01: TMenuItem + Caption = '0%' + Checked = True + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N202: TMenuItem + Tag = 20 + Caption = '20%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N351: TMenuItem + Tag = 35 + Caption = '35%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + object N502: TMenuItem + Tag = 50 + Caption = '50%' + GroupIndex = 158 + RadioItem = True + OnClick = OverlsiceClick + end + end + object Orthoview: TMenuItem + Caption = 'Orthogonal view' + Checked = True + OnClick = OrthoviewClick + end + object SliceLabelCheck: TMenuItem + Caption = 'Show slice label' + Checked = True + OnClick = SliceLabelCheckClick + end + object Slices1: TMenuItem + Caption = 'Slices...' + OnClick = Slices1Click + end + end + end + object MultiSaveDialog: TSaveDialog + DefaultExt = '.ini' + Filter = 'Settings file|*.ini' + FilterIndex = 0 + left = 97 + top = 11 + end +end diff --git a/backup/MultiSlice.pas.bak b/backup/MultiSlice.pas.bak new file mode 100755 index 0000000..30ddb07 --- /dev/null +++ b/backup/MultiSlice.pas.bak @@ -0,0 +1,896 @@ +unit MultiSlice; +interface + {$mode delphi} +uses +{$IFNDEF Unix} Windows,wgraphics, +{$ELSE} +//not used by Darwin... RGBGraphics,rgbroutines, +{$ENDIF} + LResources,LCLType,SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls,nifti_img,define_types,nifti_img_view, + StdCtrls,GraphicsMathLibrary, Menus,ClipBrd,IniFiles,userdir; +const + kMaxMultiSlice = 24; +type + TMultiSlice = record + Orient,nSlices,OverslicePct: integer; + OrthoView,SliceLabel: boolean; + SliceList: array [1..kMaxMultiSlice] of integer; + end;//TMultiSlice + + { TMultiSliceForm } + + TMultiSliceForm = class(TForm) + MainMenu1: TMainMenu; + File1: TMenuItem; + Closewindow1: TMenuItem; + Saveasbitmap1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + MultiPanel: TScrollBox; + MultiImage: TImage; + View1: TMenuItem; + OrientMenu: TMenuItem; + Axial1: TMenuItem; + Sagittal1: TMenuItem; + Coronal1: TMenuItem; + Orthoview: TMenuItem; + Slices1: TMenuItem; + Savesettings1: TMenuItem; + Settings1: TMenuItem; + MultiSaveDialog: TSaveDialog; + SliceLabelCheck: TMenuItem; + OversliceMenu: TMenuItem; + N501: TMenuItem; + N331: TMenuItem; + N201: TMenuItem; + N01: TMenuItem; + N202: TMenuItem; + N351: TMenuItem; + N502: TMenuItem; + procedure Copy1Click(Sender: TObject); +procedure MenuItem1Click(Sender: TObject); + procedure Saveasbitmap1Click(Sender: TObject); + procedure OrientClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure CreateMultiAx; + procedure CreateMultiCor; + procedure CreateMultiSag; + procedure CreateMultiSlice; + procedure OrthoviewClick(Sender: TObject); +procedure Settings1Click(Sender: TObject); + procedure Slices1Click(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure UpdateMultiSliceDisplay; + procedure OpenMultiMRU(Sender:TObject); + procedure UpdateMultiSliceMRU; + {$IFNDEF FPC} + procedure FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} + procedure FormClose(Sender: TObject); + + {$ENDIF} + procedure Savesettings1Click(Sender: TObject); + procedure SliceLabelCheckClick(Sender: TObject); + procedure OverlsiceClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + MultiSliceForm: TMultiSliceForm; + gMulti:TMultiSlice; + gMultiSliceDir,gMultiSliceStartupFilename,gMultiSliceDefaultsFilename:string; +{$IFDEF FPC} + gMultiBuff: RGBQuadp; + gMultiWid,gMultiHt: Integer; + gMultiXCenterRA: array [1..kMaxMultiSlice] of integer; +{$ENDIF} +implementation + + {$IFNDEF FPC} +{$R *.DFM} + {$ENDIF} + +function MultiSliceNum2String: string; +var + lSlice: integer; +begin + if gMulti.nSlices = 0 then begin + gMulti.nSlices := 1; + gMulti.SliceList[1] := 1; + end; + result := ''; + for lSlice := 1 to gMulti.nSlices do begin + result := result+inttostr(gMulti.SliceList[lSlice]); + if lSlice < gMulti.nSlices then + result := result+','; + end; //for each slice +end; + +procedure MultiSliceString2Num (var lStr: string); +var + lSliceStr: string; + lStrPos,lStrLen,lSlice: integer; +begin + //showmessage(lStr); + lStrLen := length(lStr); + if lStrLen < 1 then exit; + lSlice := 0; + lSliceStr := ''; + for lStrPos := 1 to lStrLen do begin + if lStr[lStrPos] in ['0'..'9'] then + lSliceStr := lSliceStr+lStr[lStrPos]; + if ((not (lStr[lStrPos] in ['0'..'9'])) or (lStrPos=lStrLen)) and (lSliceStr<>'') then begin + inc(lSlice); + if lSlice <= kMaxMultiSlice then + gMulti.SliceList[lSlice] := strtoint(lSliceStr); + lSliceStr := ''; + end; //if white space or eoln + end; //for lStrPos + gMulti.nSlices := lSlice; + if lSlice > kMaxMultiSlice then begin + showmessage('Warning: maximum number of slices is '+inttostr(kMaxMultiSlice)); + gMulti.nSlices := kMaxMultiSlice; + end; +end; + +procedure WriteMultiSliceIniFile (lFilename: string); +var + lIniFile: TIniFile; +begin + if DiskFreeEx(lFilename) < 1 then + exit; + if not DirectoryExists(extractfiledir(lFilename)) then begin + mkDir(extractfiledir(lFilename)); + end; + lIniFile := TIniFile.Create(lFilename); + //Slice Index + lIniFile.WriteString('STR', 'Slices', MultiSliceNum2String); + //Booleans + lIniFile.WriteString('BOOL', 'OrthoView',Bool2Char( gMulti.OrthoView)); + lIniFile.WriteString('BOOL', 'SliceLabel',Bool2Char( gMulti.SliceLabel)); + //Integers LicenseID + lIniFile.WriteString('INT', 'Orient',IntToStr(gMulti.Orient)); + lIniFile.WriteString('INT', 'OverslicePct',IntToStr(gMulti.OverslicePct)); + lIniFile.Free; +end; + +procedure ReadMultiSliceIniFile (lFilename: string); +var + lStr: string; + lIniFile: TIniFile; +begin + if not FileexistsEx(lFilename) then begin + exit; + end; + lIniFile := TIniFile.Create(lFilename); + lStr := lIniFile.ReadString('STR', 'Slices', '10,20,30');//file0 - last file viewed + MultiSliceString2Num(lStr); + gMulti.OrthoView := IniBool(lIniFile,'OrthoView',gMulti.OrthoView); + gMulti.SliceLabel := IniBool(lIniFile,'SliceLabel',gMulti.SliceLabel); + gMulti.Orient:= IniInt(lIniFile,'Orient',gMulti.Orient); + gMulti.OverslicePct:= IniInt(lIniFile,'OverslicePct',gMulti.OverslicePct); + lIniFile.Free; +end; + +procedure TMultiSliceForm.OpenMultiMRU(Sender:TObject); +var + lFilename: string; +begin + lFilename := gMultiSliceDir +(Sender as TMenuItem).caption+'.ini' ; + ReadMultiSliceIniFile(lFilename); + UpdateMultiSliceDisplay; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.UpdateMultiSliceMRU; +var + NewItem: TMenuItem; + lSearchRec: TSearchRec; +begin + While Settings1.Count > 0 do Settings1.Items[0].Free; + if FindFirst(gMultiSliceDir +'*.ini', faAnyFile, lSearchRec) = 0 then + repeat + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ParseFileName(ExtractFileName(lSearchRec.Name)); + {$IFDEF FPC} + NewItem.Onclick := OpenMultiMRU; //Lazarus + {$ELSE} + NewItem.Onclick := OpenMultiMRU; + {$ENDIF} + Settings1.Add(NewItem); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end; + +procedure TMultiSliceForm.Copy1Click(Sender: TObject); +{$IFNDEF FPC} +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; + {$ENDIF} +begin + {$IFDEF Darwin} + Showmessage('Copy not yet supported with OSX: use File/Save'); + {$ENDIF} + if (MultiImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + {$IFNDEF FPC} + MultiImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); + {$ELSE} + MultiSliceForm.MultiImage.Picture.Bitmap.SaveToClipboardFormat(2); + {$ENDIF} +end; + +procedure TMultiSliceForm.MenuItem1Click(Sender: TObject); +begin + + +end; + + + +procedure TMultiSliceForm.Saveasbitmap1Click(Sender: TObject); +begin + SaveImgAsPNGBMP (MultiImage); +end; + + + +procedure CreateBlankBitmap (lPGHt,lPGWid:integer;var lImage: TImage); +var + lPos: integer; + lBGInvisibleColor: TRGBQuad; +begin +{$IFDEF ENDIAN_BIG} +lBGInvisibleColor :=TColor2TRGBQuad(clBlack); + {$ELSE} + //lBGInvisibleColor := gMRIcroOverlay[kBGOverlayNum].LUTinvisible; + lBGInvisibleColor := gMRIcroOverlay[kBGOverlayNum].LUT[0]; + {$ENDIF} + gMultiWid := lPGWid; + gMultiHt := lPGHt; + if (gMultiWid < 1) or (gMultiHt < 1) then + exit; + getmem (gMultiBuff, gMultiHt*gMultiWid*sizeof(TRGBQuad) ); + //fillchar(gMultiBuff^,gMultiHt*gMultiWid*sizeof(TRGBQuad),0); + for lPos := 1 to (gMultiHt*gMultiWid) do + gMultiBuff^[lPos] := lBGInvisibleColor; +end; + +procedure MultiHLine (lX1,lX2,lY1,lThick: integer; lClr: TRGBQuad); +var + lLine,lY,lYPos,lX,lXlo,lXhi: integer; +begin + if (lThick < 1) or (gMultiWid < 1) or (gMultiHt < 1) or (lY1 < 1) or (lY1 >gMultiHt) or (gMultiBuff = nil) then + exit; + lXlo := lX1; + lXHi := lX2; + SortInteger(lXlo,lXhi); + if lXlo < 1 then + lXlo := 1; + if lXlo > gMultiWid then + lXlo := gMultiWid; + if lXhi < 1 then + lXhi := 1; + if lXhi > gMultiWid then + lXhi := gMultiWid; + lY := lY1-((lThick{+1}) div 2); + for lLine := 1 to lThick do begin + lYPos := (lY)*gMultiWid; + if lY < gMultiHt then + for lX := lXlo to lXhi do + gMultiBuff^[lYPos+lX] := lClr; + inc(lY); + end; +end; + +procedure MultiVLine (lX1,lY1,lY2,lThick: integer; lClr: TRGBQuad); +var + lXs, lX,lY,lYlo,lYhi: integer; +begin + if (lThick < 1) or (gMultiWid < 1) or (gMultiHt < 1) or (lX1 < 1) or (lX1 >gMultiWid) or (gMultiBuff = nil) then + exit; + lYlo := lY1; + lYHi := lY2; + SortInteger(lYlo,lYhi); + if lYlo < 1 then + lYlo := 1; + if lYlo > gMultiHt then + lYlo := gMultiHt; + if lYhi < 1 then + lYhi := 1; + if lYhi > gMultiHt then + lYhi := gMultiHt; + lXs := lX1-((lThick{+1}) div 2)-2;//-2 as indexed from 0 and line is at least 1 pixel thick + for lX := lXs to (lXs+lThick-1) do + if (lX >= 0) and (lX < gMultiWid) then + for lY := lYlo to lYHi do + gMultiBuff^[((lY-1)*gMultiWid)+lX] := lClr; + +end; + +procedure DefineBackGround(var lBMP: DWordp; lBGInvisibleColor: DWord; lMaskHt,lMaskWid: integer); +//lMaskP should have all invis voxels as 128, non as 255 +//sets all invis boundary voxels to 0 +var + lMaskP: ByteP; + lBGvisibleColor: DWord; + lPos,lMaskSz, + lQSz,lQHead,lQTail: integer; + lQRA: LongIntp; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; +PROCEDURE RetirePixel; //FIFO cleanup +VAR + lVal,lPos: integer; +BEGIN + lVal := lQra^[lQTail]; + lPos := lVal-1; + if (lPos > 0) and (lMaskP^[lPos]=128) then begin//add item to left + incQra(lQHead,lQSz); + lMaskP^[lPos] := 0; + lQra^[lQHead] := lPos; + end; + if (lPos > 0) then lMaskP^[lPos] := 0; + lPos := lVal+1; + if (lPos < lMaskSz) and (lMaskP^[lPos]=128) then begin//add item to right + incQra(lQHead,lQSz); + lMaskP^[lPos] := 0; + lQra^[lQHead] := lPos; + end; + if (lPos < lMaskSz) then lMaskP^[lPos] := 0; + lPos := lVal-lMaskWid; + if (lPos > 0) and (lMaskP^[lPos]=128) then begin//add item above + incQra(lQHead,lQSz); + lMaskP^[lPos] := 0; + lQra^[lQHead] := lPos; + end; + if (lPos > 0) then lMaskP^[lPos] := 0; + lPos := lVal+lMaskWid; + if (lPos < lMaskSz) and(lMaskP^[lPos]=128) then begin//add item below + incQra(lQHead,lQSz); + lMaskP^[lPos] := 0; + lQra^[lQHead] := lPos; + end; + if (lPos < lMaskSz) then lMaskP^[lPos] := 0; + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +begin + if (lPt < 1) or (lPt > lMaskSz) or (lMaskP^[lPt] <> 128) then exit; + //lQSz := 8000;//size of FIFO Queue Array + lQHead := 1; + lQTail := 1; + lQra^[lQTail] := (lPt); //NOTE: both X and Y start from 0 not 1 + lMaskP^[lPt] := 0; + RetirePixel; + if lQHead >= lQTail then begin + while lQHead <> lQTail do + RetirePixel; + end; +end; +begin //proc DefineBG + lMaskSz := lMaskWid * lMaskHt; + Getmem(lMaskP,lMaskSz); + for lPos := 1 to lMaskSz do + if lBMP^[lPos] = lBGInvisibleColor then + lMaskP^[lPos] := 128 + else + lMaskP^[lPos] := 255; + lQSz := lMaskSz div 4; + GetMem(lQra,lQSz*sizeof(LongInt)); + //erase all rows + for lPos := 1 to lMaskHt do begin + FillStart( (lPos-1)*lMaskWid + 1); + FillStart( (lPos)*lMaskWid); + end; + //erase all cols + for lPos := 1 to lMaskWid do begin + FillStart( lPos + 1); + FillStart( ((lMaskHt-1) *lMaskWid) + lPos); + end; + Freemem(lQRa); + //make sure bright blue 0000FF becauses neighbor 0000FE instead of 000100 + if (lBGInvisibleColor and 255) = 255 then + lBGVisibleColor:= lBGInvisibleColor-1 + else + lBGVisibleColor:= lBGInvisibleColor+1; + //now, fill in islands so they are not transparent + for lPos := 1 to lMaskSz do + if lMaskP^[lPos] = 128 then + lBMP^[lPos] := lBGVisibleColor; + Freemem(lMaskP); +end; + +{$IFDEF FLIPV} +procedure SetDim (lInPGHt,lInPGWid,lWriteColumn: integer; var l32OutBitP : DWordp); +var + lLen,lSrc,lDest,lY: integer; + lTBuff: RGBQuadp; +begin + getmem(lTBuff,lInPGHt*lWriteColumn*4); + lLen := lWriteColumn*4; + lSrc := 1; + lDest := 1; + for lY := 1 to lInPGHt do begin + Move(l32OutBitP^[lSrc],lTBuff^[lDest],lLen); + lSrc := lSrc + lInPGWid; + lDest := lDest + lWriteColumn; + end; + DrawBMP( lWriteColumn, lInPGHt, lTBuff, MultiSliceForm.MultiImage); + freemem(lTBuff); +end; +{$ELSE} +procedure SetDim (lInPGHt,lInPGWid,lWriteColumn: integer; var l32OutBitP : DWordp); +var + lLen,lSrc,lDest,lY: integer; + lTBuff: RGBQuadp; +begin + getmem(lTBuff,lInPGHt*lWriteColumn*4); + lLen := lWriteColumn*4; + lSrc := 1; + //lDest := 1; + lDest := 1+ ((lInPGHt-1) * lWriteColumn); + + for lY := 1 to lInPGHt do begin + Move(l32OutBitP^[lSrc],lTBuff^[lDest],lLen); + lSrc := lSrc + lInPGWid; + lDest := lDest - lWriteColumn; + end; + DrawBMP( lWriteColumn, lInPGHt, lTBuff, MultiSliceForm.MultiImage); + freemem(lTBuff); +end; +{$ENDIF} + + +procedure RemoveHorizGaps (lMaxOverlapWid,lColWid: integer); //will overlap gaps from 1..lMaxOverlapWid, leave right non-overlapped); +var + l32BitP,l32OutBitP : DWordp; + lBGInvisibleColor,lBGInvisibleColorShr8: DWord; + lIsGap,lPrevIsGap: boolean; + lInc,lPrevSliceStart,lPrevSliceEnd,lPrevWriteColumn,lWid,lHt,lReadRow, + lMaxWriteColumn,lReadColumn,lWriteColumn,lReadOffset,lWriteOffset,lPos,x,y: integer; + lTextPos,lTextReadColumn: integer; +begin + (*freemem (gMultiBuff ); + gMultiBuff := nil; + exit;*) + + + for lTextPos := 1 to kMaxMultiSlice do + gMultiXCenterRA[lTextPos] := 0; + lTextPos := 0; + lTextReadColumn := lColWid div 2; + if (gMultiWid < 1) or (gMultiHt < 1) or (gMultiBuff = nil) then + exit; + lBGInvisibleColor := TRGBQuad2DWord(gMRIcroOverlay[kBGOverlayNum].LUTinvisible); + //fx(lBGInvisibleColor); + //lBGInvisibleColorShr8 := lBGInvisibleColor Shr 8; + lHt := gMultiHt;//MultiSliceForm.MultiImage.Picture.Bitmap.Height; + lWid := gMultiWid; //MultiSliceForm.MultiImage.Picture.Bitmap.Width; + if (lHt < 2) or (lWid < 2) then exit; + //next: prepare input + l32BitP := DWordP(gMultiBuff); + lBGInvisibleColor := l32BitP^[1]; + DefineBackGround(l32BitP,lBGInvisibleColor, lHt,lWid); + //next prepare output + GetMem(l32OutBitP,lHt*lWid*sizeof(DWord)); + for lInc := 1 to (lwid*lHt) do + l32OutBitP^[lInc] := lBGInvisibleColor; + //next: compress by deleting empty columns + lWriteColumn := 0; + lPrevIsGap := true; + lPrevSliceStart := maxint -10; + lPrevSliceEnd := 0; + lPrevWriteColumn := maxint-10;//do not degap 1st line + + +if gMulti.OverSlicePct = 0 then begin //simply remove gaps between slice + for lReadColumn := 1 to lWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + if lReadColumn >= lTextReadColumn then begin + inc(lTextPos); + lTextReadColumn := lTextReadColumn+lColWid; + if lTextPos <= kMaxMultiSlice then + gMultiXCenterRA[lTextPos] := lWriteColumn; + end; + while (lReadRow < lHt) and (lIsGap) do begin + if l32BitP^[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + if not lIsGap then begin//data in this column + if lReadColumn > (lPrevWriteColumn+1) then begin //leave one pixel gap between noncontiguous columns + inc(lWriteColumn); + lReadOffset := lReadColumn-1; + lWriteOffset := lWriteColumn; + //showmessage(inttostr(lWriteColumn)+' '+inttostr(lReadOffset)); + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //leave 1 pixel gap + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + lPrevWriteColumn := lReadColumn; + end; //not Gap - write this column + end; //for each column +end else begin //overslice <> 0: show subsequent slices above/below each other + lMaxWriteColumn := -maxint; + for lReadColumn := 1 to lMaxOverlapWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + while (lReadRow < lHt) and (lIsGap) do begin + //ovx + if l32BitP^[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + if (lPrevIsGap <> lIsGap) then begin//change from prev column + if not (lIsGap) then begin + //fx(lPrevSliceStart,lPrevSliceEnd,lReadColumn,abs(((lPrevSliceEnd-lPrevSliceStart) * gMulti.OverSlicePct)div 100)); + if lPrevSliceEnd > lPrevSliceStart then + lWriteColumn := lPrevSliceEnd-abs(((lPrevSliceEnd-lPrevSliceStart) * gMulti.OverSlicePct)div 100); + lPrevSliceStart := lWriteColumn; + + end; + if (lIsGap) then + lPrevSliceEnd := lWriteColumn; + end; + lPrevIsGap := lIsGap; + if gMulti.OverSlicePct > 0 then begin + if not lIsGap then begin//data in this column + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + if l32BitP^[lReadOffset] <> lBGInvisibleColor then + l32OutBitP^[lWriteOffset] := l32BitP^[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //not Gap - write this column + end else begin //if overwrite, else underwrite + if not lIsGap then begin//data in this column + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + if l32OutBitP^[lWriteOffset] = lBGInvisibleColor then + l32OutBitP^[lWriteOffset] := l32BitP^[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //not Gap - write this column + end; + if lReadColumn >= lTextReadColumn then begin //text + inc(lTextPos); + lTextReadColumn := lTextReadColumn+lColWid; + if lTextPos <= kMaxMultiSlice then + gMultiXCenterRA[lTextPos] := lWriteColumn; + end; //text + if lWriteColumn > lMaxWriteColumn then + lMaxWriteColumn := lWriteColumn; + end; //for each column + if lWriteColumn < lMaxWriteColumn then + lWriteColumn := lMaxWriteColumn; + if lMaxOverlapWid < lWid then begin + lReadColumn := lMaxOverlapWid; + if (lWriteColumn) < lReadColumn then //add gap if some compression + inc(lWriteColumn); + for lReadColumn := (lMaxOverlapWid+1) to lWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + while (lReadRow < lHt) and (lIsGap) do begin + if l32BitP^[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + if not lIsGap then begin + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; //for each row + end; //not gap + end; //for each column + if (lWriteColumn+1) < lWid then + inc(lWriteColumn); + end; //if maxwid < wid - unoverlapped +end; + + SetDim (lHt,lWid,lWriteColumn,l32OutBitP); + FreeMem(l32OutBitP); + freemem (gMultiBuff ); + gMultiBuff := nil; +end; + + +procedure TMultiSliceForm.CreateMultiSag; +var + lSlice,lHt,lWid,lSlicePos,lSliceWid: integer; +begin + + lHt:= gBGIMg.ScrnDim[3]; + lSliceWid :=gBGIMg.ScrnDim[2]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := (lSliceWid*gMulti.nSlices); + if lWid < 2 then exit; + if gMulti.OrthoView then //coro crossview + lWid := lWid + gBGIMg.ScrnDim[1]+2; + if lWid < 2 then exit; + + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + DrawSag (gMulti.SliceList[lSlice],1+((lSlice-1)*lSliceWid));//+lSlice because we want 1-voxel gap between slices + //if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],1),((lSlice-1)*lSliceWid)+(lSliceWid div 2),lWid); + end; + if gMulti.OrthoView then begin //coro crossview + DrawCor (gBGImg.ScrnDim[2] div 2,(lSliceWid*gMulti.nSlices)-1); + //MultiImage.Canvas.Pen.Color := clWhite; + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + for lSlice := 1 to gMulti.nSlices do begin //draw lines + lSlicePos := (gMulti.nSlices*lSliceWid)+(gMulti.SliceList[lSlice]); + MultiVLine (lSlicePos,0,lHt,gBGImg.XBarThick,TColor2TRGBQuad(gBGImg.XBarClr)); + {MultiImage.Canvas.MoveTo(lSlicePos,0); + MultiImage.Canvas.LineTo(lSlicePos,lHt);} + end;//line for each slice + end;//if cross view + RemoveHorizGaps(lSliceWid*gMulti.nSlices,lSliceWid); +end; //CreateMultiSag + +procedure TMultiSliceForm.CreateMultiCor; +var + lSlice,lHt,lWid,lLeft,lSliceWid: integer; +begin + lHt:= gBGIMg.ScrnDim[3]; + lSliceWid :=gBGIMg.ScrnDim[1]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := lSliceWid*gMulti.nSlices; + if lWid < 2 then exit; + if gMulti.OrthoView then //sag crossview + lWid := lWid + gBGIMg.ScrnDim[2]+2; + if lWid < 2 then exit; + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + //ImgForm.YViewEdit.value := gMulti.SliceList[lSlice]; + DrawCor (gMulti.SliceList[lSlice],1+((lSlice-1)*lSliceWid)); + //if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],2),((lSlice-1)*lSliceWid)+(gBGIMg.ScrnDim[1] div 2),lWid); + end; + if gMulti.OrthoView then begin + DrawSag (gBGImg.ScrnDim[1] div 2,(gMulti.nSlices*lSliceWid)-1); + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Color := clWhite; + MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + + for lSlice := 1 to gMulti.nSlices do begin + lLeft := gMulti.nSlices*lSliceWid+(gMulti.SliceList[lSlice]); + MultiVLine (lLeft,0,lHt,gBGImg.XBarThick,TColor2TRGBQuad(gBGImg.XBarClr)); + + {MultiImage.Canvas.MoveTo(lLeft,0); + MultiImage.Canvas.LineTo(lLeft,lHt);} + end; + end;//if orthoview + RemoveHorizGaps(lSliceWid*gMulti.nSlices,lSliceWid); +end; //CreateMultiCor + +procedure TMultiSliceForm.CreateMultiAx; +var + lSliceWid,lSlice,lHt,lWid,lLeft: integer; +begin + lHt:= gBGIMg.ScrnDim[2]; + lSliceWid :=gBGIMg.ScrnDim[1]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := lSliceWid*gMulti.nSlices; + if lWid < 2 then exit; + if gMulti.OrthoView then begin //sag crossview + lWid := lWid + gBGIMg.ScrnDim[2]+2; + if gBGIMg.ScrnDim[3]> lHt then + lHt := gBGIMg.ScrnDim[3]; + end; + if lWid < 2 then exit; + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + DrawAxial (gMulti.SliceList[lSlice],1+((lSlice-1)*lSliceWid)); + //if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],3),((lSlice-1)*lSliceWid)+(gBGIMg.ScrnDim[1] div 2),lWid); + end; + if gMulti.OrthoView then begin + lLeft := gMulti.nSlices*lSliceWid; + //DrawSag (gBGImg.ScrnDim[1] div 2,lLeft); + DrawSag (gBGImg.ScrnDim[1] div 2,lLeft-1); + + //MultiImage.Canvas.pen.Color := clWhite; + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + + for lSlice := 1 to gMulti.nSlices do begin + lHt := gBGImg.ScrnDim[3]-(gMulti.SliceList[lSlice]); + MultiHLine (lLeft,lWid,lHt,gBGImg.XBarThick,TColor2TRGBQuad(gBGImg.XBarClr)); + end; + end; + RemoveHorizGaps(lSliceWid*gMulti.nSlices,lSliceWid); +end; //CreateMultiAx + +procedure DrawLabels; +var + lSlice,lOrient: integer; +begin + case gMulti.Orient of + 3: lOrient := 2; + 2: lOrient := 1; + else lOrient := 3; + end;//case + + if not gMulti.SliceLabel then + exit; + for lSlice := 1 to gMulti.nSlices do begin + if gMultiXCenterRA[lSlice] > 0 then DrawLabel(MultiSliceForm.MultiImage,DimToMM(gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],lOrient),gMultiXCenterRA[lSlice],maxint); + end; +end; +//gMultiXCenterRA + +procedure TMultiSliceForm.CreateMultiSlice; +//test var lI: integer; +begin + if gMulti.nSlices < 1 then begin + showmessage('No valid slices selected - please use View/Slices.'); + end; + //MultiImage.Canvas.Font.Color := clWhite; +//for lI := 1 to 32 do begin //test + case gMulti.Orient of + 3: CreateMultiCor; + 2: CreateMultiSag; + else CreateMultiAx; + end;//case + DrawLabels; + // end; //test +end;//CreateMultiSlice + +procedure TMultiSliceForm.OrientClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gMulti.Orient := (sender as TMenuItem).tag; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.FormShow(Sender: TObject); +begin + ReadMultiSliceIniFile (gMultiSliceStartupFilename ); + UpdateMultiSliceMRU; + UpdateMultiSliceDisplay; + CreateMultiSlice; + MultiSliceForm.BringToFront; +end; + +procedure TMultiSliceForm.OrthoviewClick(Sender: TObject); +begin + OrthoView.checked := not OrthoView.Checked; + gMulti.OrthoView := OrthoView.checked; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.Settings1Click(Sender: TObject); +begin + +end; + +procedure TMultiSliceForm.Slices1Click(Sender: TObject); +var + lStr: string; +begin + lStr := InputBox('Select multislices', 'Slice numbers [e.g. 10,16,24]',MultiSliceNum2String); + //now parse line + MultiSliceString2Num(lStr); + CreateMultiSlice; +end; + +procedure TMultiSliceForm.Closewindow1Click(Sender: TObject); +begin + MultiSliceForm.Close; +end; + +procedure TMultiSliceForm.UpdateMultiSliceDisplay; +begin + SetSubmenuWithTag(OversliceMenu, gMulti.OverslicePct); + SetSubmenuWithTag(OrientMenu, gMulti.Orient); + OrthoView.Checked := gMulti.OrthoView; + SliceLabelCheck.Checked := gMulti.SliceLabel; +end; + +procedure TMultiSliceForm.FormCreate(Sender: TObject); +var + lSlice:integer; +begin + gMultiBuff := nil; + gMultiSliceDir := DefaultsDir('multislice'); + //gMultiSliceDir := extractfiledir(paramstr(0))+pathdelim+'multislice'+pathdelim; + gMultiSliceDefaultsFilename := gMultiSliceDir + 'default.ini'; + gMultiSliceStartupFilename := gMultiSliceDefaultsFilename; + gMulti.Orient := 1; + gMulti.OverslicePct := 0; + gMulti.nSlices:= 4; + gMulti.OrthoView := true; + gMulti.SliceLabel := true; + for lSlice := 1 to gMulti.nSlices do + gMulti.SliceList[lSlice] := 62+10*lSlice; + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Savesettings1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Closewindow1.ShortCut := ShortCut(Word('W'), [ssMeta]); + {$ENDIF} + {$ENDIF} +end; + + {$IFNDEF FPC} +procedure TMultiSliceForm.FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} +procedure TMultiSliceForm.FormClose(Sender: TObject); + {$ENDIF} +begin +WriteMultiSliceIniFile (gMultiSliceDefaultsFilename ); +end; + +procedure TMultiSliceForm.Savesettings1Click(Sender: TObject); +begin + MultiSaveDialog.InitialDir := extractfiledir(gMultiSliceDir ); + if not MultiSaveDialog.Execute then exit; + {$IFDEF Unix} + WriteMultiSliceIniFile(extractfiledir(gMultiSliceDir)+pathdelim+extractfilename(MultiSaveDialog.Filename)); + + {$ELSE} + WriteMultiSliceIniFile(MultiSaveDialog.Filename); + {$ENDIF} + UpdateMultiSliceMRU; +end; + +procedure TMultiSliceForm.SliceLabelCheckClick(Sender: TObject); +begin + SliceLabelCheck.checked := not SliceLabelCheck.Checked; + gMulti.SliceLabel := SliceLabelCheck.checked; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.OverlsiceClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gMulti.OverslicePct := (sender as TMenuItem).tag; + CreateMultiSlice; +end; + + {$IFDEF FPC} +initialization + {$I MultiSlice.lrs} +{$ENDIF} + +end. diff --git a/backup/about.lfm.bak b/backup/about.lfm.bak new file mode 100755 index 0000000..4f8c116 --- /dev/null +++ b/backup/about.lfm.bak @@ -0,0 +1,58 @@ +object AboutForm: TAboutForm + Left = 683 + Height = 127 + Top = 153 + Width = 380 + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'About...' + ClientHeight = 127 + ClientWidth = 380 + Constraints.MaxHeight = 127 + Constraints.MaxWidth = 380 + Constraints.MinHeight = 127 + Constraints.MinWidth = 380 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '1.5' + object Panel2: TPanel + Left = 8 + Height = 67 + Top = 47 + Width = 364 + ClientHeight = 67 + ClientWidth = 364 + TabOrder = 0 + object HomepageLabel: TLabel + Left = 0 + Height = 20 + Top = 10 + Width = 360 + Alignment = taCenter + AutoSize = False + Caption = 'version' + ParentColor = False + OnClick = HomePageClick + end + object ThreadLabel: TLabel + Left = 1 + Height = 20 + Top = 36 + Width = 361 + Alignment = taCenter + AutoSize = False + Caption = ' Threads' + ParentColor = False + end + end + object Label1: TLabel + Left = 8 + Height = 28 + Top = 16 + Width = 95 + Caption = 'MRIcron' + Font.Height = -24 + ParentColor = False + ParentFont = False + end +end diff --git a/backup/about.pas.bak b/backup/about.pas.bak new file mode 100755 index 0000000..8ab9e54 --- /dev/null +++ b/backup/about.pas.bak @@ -0,0 +1,66 @@ +unit about; + +interface + +uses +{$IFDEF FPC}LResources,{$ELSE} ShellAPI, {$ENDIF} +{$IFNDEF Unix} Windows,{$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls, define_types; + +type + + { TAboutForm } + + TAboutForm = class(TForm) + HomepageLabel: TLabel; + Label1: TLabel; + Panel2: TPanel; + ThreadLabel: TLabel; + procedure FormCreate(Sender: TObject); + procedure HomePageClick(Sender: TObject); + procedure Panel1Click(Sender: TObject); + procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer); + private + { Private declarations } + public + { Public declarations } + end; + +var + AboutForm: TAboutForm; + +implementation +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + +procedure TAboutForm.FormCreate(Sender: TObject); +begin + HomepageLabel.caption := 'www.mricro.com :: '+kMRIcronVers ; +end; + +procedure TAboutForm.HomePageClick(Sender: TObject); +begin +{$IFDEF FPC} +{$ELSE} + ShellExecute (0, Nil, 'http://www.mricro.com', Nil, Nil, SW_ShowDefault); +{$ENDIF} +end; + +procedure TAboutForm.Panel1Click(Sender: TObject); +begin + +end; + +procedure TAboutForm.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer); +begin +//showmessage('x'); +end; + +{$IFDEF FPC} +initialization + {$I about.lrs} +{$ENDIF} + +end. diff --git a/backup/autoroi.lfm.bak b/backup/autoroi.lfm.bak new file mode 100755 index 0000000..ae5bbbc --- /dev/null +++ b/backup/autoroi.lfm.bak @@ -0,0 +1,174 @@ +object AutoROIForm: TAutoROIForm + Left = 785 + Height = 355 + Top = 200 + Width = 265 + HorzScrollBar.Page = 264 + VertScrollBar.Page = 354 + ActiveControl = VarianceEdit + Caption = 'Create ROI' + ClientHeight = 355 + ClientWidth = 265 + Constraints.MaxHeight = 355 + Constraints.MaxWidth = 265 + Constraints.MinHeight = 355 + Constraints.MinWidth = 265 + Font.Name = 'MS Sans Serif' + OnCreate = FormCreate + OnDestroy = FormDestroy + OnHide = FormHide + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '0.9.28.2' + object OriginLabel: TLabel + Left = 4 + Height = 18 + Top = 42 + Width = 48 + Caption = 'Origin: ' + ParentColor = False + end + object OriginBtn: TSpeedButton + Left = 7 + Height = 25 + Hint = 'You can also double-click on the image' + Top = 5 + Width = 114 + Caption = 'Reset origin' + Color = clBtnFace + NumGlyphs = 0 + OnClick = OriginBtnClick + ShowHint = True + ParentShowHint = False + end + object DiffLabel: TLabel + Left = 12 + Height = 18 + Top = 98 + Width = 147 + Caption = 'Difference from origin' + ParentColor = False + end + object Label1: TLabel + Left = 12 + Height = 18 + Top = 132 + Width = 130 + Caption = 'Difference at edge' + ParentColor = False + end + object Label2: TLabel + Left = 12 + Height = 18 + Top = 167 + Width = 85 + Caption = 'Radius (mm)' + ParentColor = False + end + object Label3: TLabel + Left = 12 + Height = 18 + Top = 202 + Width = 129 + Caption = 'Erode/dilate cycles' + ParentColor = False + end + object AutoROIBtn: TSpeedButton + Left = 56 + Height = 25 + Top = 304 + Width = 65 + Caption = 'Apply' + Color = clBtnFace + NumGlyphs = 0 + OnClick = AutoROIBtnClick + end + object CancelBtn: TSpeedButton + Left = 120 + Height = 25 + Top = 304 + Width = 65 + Caption = 'Cancel' + Color = clBtnFace + NumGlyphs = 0 + OnClick = CancelBtnClick + end + object Label4: TLabel + Left = 4 + Height = 18 + Top = 74 + Width = 79 + Caption = 'Constraints' + ParentColor = False + end + object ExcludeBlackCheck: TCheckBox + Left = 12 + Height = 21 + Top = 236 + Width = 230 + Caption = 'Zero intensity constrains edge' + OnClick = AutoROIchange + TabOrder = 0 + end + object VarianceEdit: TSpinEdit + Left = 173 + Height = 27 + Top = 90 + Width = 72 + MaxValue = 255 + OnChange = AutoROIchange + TabOrder = 1 + Value = 16 + end + object EdgeEdit: TSpinEdit + Left = 173 + Height = 27 + Top = 126 + Width = 72 + MaxValue = 255 + OnChange = AutoROIchange + TabOrder = 2 + Value = 16 + end + object RadiusEdit: TSpinEdit + Left = 173 + Height = 27 + Top = 161 + Width = 72 + MaxValue = 9999 + OnChange = AutoROIchange + TabOrder = 3 + Value = 32 + end + object ErodeEdit: TSpinEdit + Left = 173 + Height = 27 + Top = 196 + Width = 72 + MaxValue = 12 + OnChange = AutoROIchange + TabOrder = 4 + end + object ROIconstraint: TComboBox + Left = 12 + Height = 31 + Top = 268 + Width = 212 + ItemHeight = 0 + Items.Strings = ( + 'Append to current VOI' + 'Delete from current VOI' + 'Constain with current VOI' + ) + OnChange = AutoROIchange + Style = csDropDownList + TabOrder = 5 + end + object Timer1: TTimer + Enabled = False + Interval = 400 + OnTimer = Timer1Timer + left = 40 + top = 34 + end +end diff --git a/backup/autoroi.pas.bak b/backup/autoroi.pas.bak new file mode 100755 index 0000000..027cee1 --- /dev/null +++ b/backup/autoroi.pas.bak @@ -0,0 +1,601 @@ +unit autoroi; + +interface + +uses + {$IFNDEF FPC} + RXSpin,capmenu, + {$ELSE} + Spin,lResources, + {$ENDIF} + {$IFNDEF Unix} Windows,{$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Buttons, StdCtrls, define_types, ExtCtrls, nifti_img,nifti_img_view; + +type + + { TAutoROIForm } + + TAutoROIForm = class(TForm) + OriginLabel: TLabel; + OriginBtn: TSpeedButton; + EdgeEdit: TSpinEdit; + RadiusEdit: TSpinEdit; + ErodeEdit: TSpinEdit; + ROIconstraint: TComboBox; + VarianceEdit: TSpinEdit; + DiffLabel: TLabel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + AutoROIBtn: TSpeedButton; + CancelBtn: TSpeedButton; + Timer1: TTimer; + Label4: TLabel; + ExcludeBlackCheck: TCheckBox; + procedure OriginBtnClick(Sender: TObject); + procedure PreviewBtnClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure AutoROIBtnClick(Sender: TObject); + procedure CancelBtnClick(Sender: TObject); + procedure AutoROIchange(Sender: TObject); + procedure Timer1Timer(Sender: TObject); + procedure FormDestroy(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +procedure ROICluster ({lInROIBuf: bytep;} lXdim, lYDim, lZDim,lXOriginIn,lYOrigin,lZOrigin: integer; lDeleteNotFill: boolean); +var + AutoROIForm: TAutoROIForm; + gOriginX,gOriginY,gOriginZ: integer; +implementation + + {$IFNDEF FPC} + {$R *.DFM} + {$ENDIF} + + +procedure TAutoROIForm.OriginBtnClick(Sender: TObject); +begin + gOriginX := ImgForm.XViewEdit.value; + gOriginY := ImgForm.YViewEdit.value; + gOriginZ := ImgForm.ZViewEdit.value; + OriginLabel.Caption := 'Origin: '+inttostr(gOriginX)+'x'+inttostr(gOriginY)+'x'+inttostr(gOriginZ); + PreviewBtnClick(sender); +end; + +procedure TAutoROIForm.PreviewBtnClick(Sender: TObject); +var + lXmm,lYmm,lZmm,lSqrRadius: single; + lExcludeBlackIfZero,//lX,lY,lZ, //abba + {lMaxROISz,}lEdge,lOriginPos,lROISz,lOriginIntensity,lVariance,lXdim, lYDim, lZDim: integer; + lErodeCycles,lQTail,lQHead,lSliceSz,lQSz,lInc,lVolSz{,lX,lY,lZ}: integer; + lROIConstrain,lReadFilteredData: boolean; + lQra: LongIntP; + lSourceBuffer,lBuff,lPreErodeBuff: ByteP; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; +function UnsmoothedIntensity(lPixel: integer): integer; //1381 +begin + if lReadFilteredData then + result := lBuff^[lPixel] + else + Result :=lSourceBuffer^[lPixel]; +end; + + function MeanIntensity(lPixel: integer): integer; + var lV: integer; + begin + if lReadFilteredData then + result := lBuff^[lPixel] + else if ((lPixel-lSliceSz) > 0) and ((lPixel+lSliceSz) <= lVolSz) then begin + lV :=lSourceBuffer^[lPixel]+lSourceBuffer^[lPixel+1]+lSourceBuffer^[lPixel-1] //L/R + +lSourceBuffer^[lPixel+lXdim]+lSourceBuffer^[lPixel-lXdim] //Anterior/Posterior + +lSourceBuffer^[lPixel+lSliceSz]+lSourceBuffer^[lPixel-lSliceSz]; //Dorsal/Ventral + result := lV div 7; + end else result := lSourceBuffer^[lPixel];//1401 gImageBackupBuffer[lPixel] + end; + procedure Check(lPixel,lIntensity: integer); + var lSmoothInten :integer; + begin + lSmoothInten := MeanIntensity(lPixel); + if (lROIConstrain) and (gBGImg.VOIUndoVol^[lPixel] > 0) then //1410 + //constrain + else if (lBuff^[lPixel]<> 255) and (UnsmoothedIntensity(lPixel) > lExcludeBlackIfZero {1381}) and (abs(lSmoothInten-lIntensity)<=lEdge) and(abs(lSmoothInten-lOriginIntensity)<=lVariance) {}then begin//add item + incQra(lQHead,lQSz); + inc(lROISz); + lBuff^[lPixel] := 255; + lQra^[lQHead] := lPixel; + end; + end; + +PROCEDURE RetirePixel; //FIFO cleanup +function WithinRadius(lXs,lYs,lZs:integer): boolean; +begin + if (sqr((lXs-gOriginX)*lXmm)+sqr((lYs-gOriginY)*lYmm)+sqr((lZs-gOriginZ)*lZmm)) > lSqrRadius then + result := false + else + result := true; +end; +VAR + lVal,lXPos,lYPos,lZPos,lIntensity: integer; +BEGIN + lVal := lQra^[lQTail]; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + if lReadFilteredData then + lIntensity := 128 + else + lIntensity := lSourceBuffer^[lVal];//1401 gImageBackupBuffer[lVal]; + if (lXpos > 1) and WithinRadius(lXpos-1,lYpos,lZpos) then Check(lVal -1,lIntensity);//check to left + if (lXPos < lXDim) and (WithinRadius(lXpos+1,lYpos,lZpos)) then Check(lVal + 1,lIntensity); //check to right + if (lYpos > 1) and (WithinRadius(lXpos,lYpos-1,lZpos)) then Check(lVal -lXdim,lIntensity);//check previous line + if (lYPos < lYDim) and (WithinRadius(lXpos,lYpos+1,lZpos)) then Check(lVal + lXdim,lIntensity); //check next line + if (lZpos > 1) and (WithinRadius(lXpos,lYpos,lZpos-1)) then Check(lVal -lSliceSz,lIntensity);//check previous slice + if (lZPos < lZDim) and (WithinRadius(lXpos,lYpos,lZpos+1)) then Check(lVal + lSliceSz,lIntensity); //check next slice + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + for lI := 1 to lQsz do + lQra^[lI] := 0; + lQHead := 0; + lQTail := 1; + lROISz := 0; + Check(lPt,lOriginIntensity); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +function ROIOnEdge (lVal: integer): boolean; +BEGIN + result := false; + if lBuff^[lVal] <> 255 then exit; //not ROI - is not boundary + //Find + if ((lVal-lSliceSz) > 0) and ((lVal+lSliceSz) <= lVolSz) then begin + if lBuff^[lVal+1] = 0 then result := true; + if lBuff^[lVal-1] = 0 then result := true; + if lBuff^[lVal+lXdim] = 0 then result := true; + if lBuff^[lVal-lXdim] = 0 then result := true; + if lBuff^[lVal+lSliceSz] = 0 then result := true; + if lBuff^[lVal-lSliceSz] = 0 then result := true; + end; +end; + +function ZeroOnEdge (lVal: integer): boolean; +BEGIN + result := false; + if lBuff^[lVal] <> 0 then exit; //not ROI - is not boundary + //Find + if ((lVal-lSliceSz) > 0) and ((lVal+lSliceSz) <= lVolSz) then begin + if lBuff^[lVal+1] = 255 then result := true; + if lBuff^[lVal-1] = 255 then result := true; + if lBuff^[lVal+lXdim] = 255 then result := true; + if lBuff^[lVal-lXdim] = 255 then result := true; + if lBuff^[lVal+lSliceSz] = 255 then result := true; + if lBuff^[lVal-lSliceSz] = 255 then result := true; + end; +end; + +begin //alfa666 + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gBGImg.VOIUndoVolItems) then exit; + //if gImageBackupSz <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + //UpdateBackupBuffer; + lXdim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + if (gBGImg.Scrnmm[1] = 0) or (gBGImg.Scrnmm[2]=0) or (gBGImg.Scrnmm[3]=0) then begin + lXmm := 1; + lYmm := 1; + lZmm := 1; + end else begin + lXmm := gBGImg.Scrnmm[1]; + lYmm := gBGImg.Scrnmm[2]; + lZmm := gBGImg.Scrnmm[3]; + end; + lSliceSz := lXdim * lYdim; + lVolSz := lSliceSz*lZdim; + //lMaxROISz := round(PctImg.Value/100 * lVolSz); + lOriginPos := gOriginX + ((gOriginY-1)*lXdim) + ((gOriginZ-1)*lSliceSz); + if (lOriginPos < 1) or (lVolSz <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) or (lOriginPos > lVolSz) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> gBGImg.VOIUndoVolItems) then + exit; + {$IFNDEF FPC} + lVariance := AutoROIForm.VarianceEdit.asinteger; //asinteger; + lEdge := AutoROIForm.EdgeEdit.asinteger; + lSqrRadius := sqr(AutoROIForm.RadiusEdit.asinteger); + {$ELSE} + lVariance := AutoROIForm.VarianceEdit.value; //asinteger; + lEdge := AutoROIForm.EdgeEdit.value; + lSqrRadius := sqr(AutoROIForm.RadiusEdit.value); + {$ENDIF} + if (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) then exit; + lSourceBuffer := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer;//gBuffer; + //Next - START count cluster size + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + //check positive clusters.... + Getmem(lBuff,lVolSz); + FillChar(lBuff^,lVolSz, 0); + //Move(gImageBackupBuffer^,lBuff^,lVolSz); + if ExcludeBlackCheck.checked then //1381 + lExcludeBlackIfZero := 0 //0 + else + lExcludeBlackIfZero := -1;//impossible 8-bit value: do not use this feature + lOriginIntensity := lSourceBuffer^[lOriginPos]; //1401 gImageBackupBuffer[lOriginPos]; + lReadFilteredData := false; + //ROIconstrainCheck.enabled := (gROIBupSz > 1); //1410: next 3 lines + ROIconstraint.enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); //1410: next 3 lines + if (ROIconstraint.ItemIndex = 2) and (ROIconstraint.enabled) then + lROIConstrain := true + else + lROIconstrain := false; + FillStart(lOriginPos); + lROIConstrain := false;//1410 + //START: ERODE/DILATE CYCLES +{$IFNDEF FPC} + lErodeCycles := AutoROIForm.ErodeEdit.asinteger; +{$ELSE} + lErodeCycles := AutoROIForm.ErodeEdit.value; +{$ENDIF} + if lErodeCycles > 0 then begin + Getmem(lPreErodeBuff,lVolSz); + Move(lBuff^,lPreErodeBuff^,lVolSz); + for lQHead := 1 to lErodeCycles do begin//ERODE + for lInc := 1 to lVolSz do + if ROIonEdge(lInc) then + lBuff^[lInc] :=254; + for lInc := 1 to lVolSz do + if lBuff^[lInc]=254 then + lBuff^[lInc] := 0; //erode + end;//for ErodeCycles = ERODE + //SET ALL VOXELS THAT HAVE SURVIVED EROSION TO 128, WE THEN GROW THE ORIGIN + for lInc := 1 to lVolSz do + if lBuff^[lInc] =255 then lBuff^[lInc] := 128; + //NOW - ONLY PRESERVE STUFF CONNECTED TO ORIGIN + lBuff^[lOriginPos] := 128; + lOriginIntensity := 128; + lVariance := 2; + lEdge := 2; + lReadFilteredData := true; + FillStart(lOriginPos); + //SWITCH OFF ALL UNCONNECTED BLOBS + for lInc := 1 to lVolSz do + if lBuff^[lInc] =128 then lBuff^[lInc] := 0; + //for lInc := 1 to lVolSz do + // if lBuff[lInc] > 0 then showmessage(inttostr(lBuff[lInc]));// := 0; + + for lQHead := 1 to lErodeCycles do begin//DILATE + for lInc := 1 to lVolSz do + if (lPreErodeBuff^[lInc] = 255) and (ZeroonEdge(lInc)) then + lBuff^[lInc] :=254; + for lInc := 1 to lVolSz do + if lBuff^[lInc]=254 then + lBuff^[lInc] := 255; //erode + end;//for ErodeCycles = DILATE + Freemem(lPreErodeBuff); + {} + end; //ERODE cycles > 0 + //END: ERODE/DILATE + Freemem(lQra); + ROIconstraint.enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); //1410: next 3 lines + if (ROIconstraint.ItemIndex = 1) and (ROIconstraint.enabled) then begin //delete ROI + for lInc := 1 to gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems do //gROIBup + if (lBuff^[lInc] = 255) then + lBuff^[lInc] := 0 + else + lBuff^[lInc] := gBGImg.VOIUndoVol^[lInc]; + end else (*if true {alfa (gDynSz > 1) and (gROIBupsz > 1) {and (gImageBackupSz = gDynSz){} then begin + for lInc := 1 to gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems do + if lBuff[lInc] = 255 then + else if gImageBackupBuffer[lInc] = 255 then + lBuff[lInc] := 255//255; + else lBuff[lInc] := lSourceBuffer[lInc]; + + end else *) + for lInc := 1 to lVolSz do + if lBuff^[lInc] <> 255 then + lBuff^[lInc] := gBGImg.VOIUndoVol^[lInc] + else + lBuff^[lInc] := kVOI8bit;//1401 gImageBackupBuffer[lInc]; + Move(lBuff^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lVolSz); + Freemem(lBuff); + //END check clusters + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TAutoROIForm.FormShow(Sender: TObject); +begin +EnsureVOIOpen; +CreateUndoVol; + AutoROIForm.ModalResult := mrCancel; + ROIconstraint.Enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); + OriginBtn.OnClick(sender); + //DeleteCheck.enabled := (gROIBupSz > 1); + //ROIConstrainCheck.enabled := (gROIBupSz > 1); +end; + +procedure TAutoROIForm.FormCreate(Sender: TObject); +begin + {$IFNDEF FPC} + ROIconstraint.SetItemIndex(0);//1410 + {$ELSE} + ROIconstraint.ItemIndex := (0);//1410 + {$ENDIF} +end; + +procedure TAutoROIForm.FormHide(Sender: TObject); +begin +// if (AutoROIForm.ModalResult = mrCancel) and (gBGImg.VOIUndoVolItems > 1) and (gBGImg.VOIUndoVolItems = gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems) then +// Move(gImageBackupBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gImageBackupSz); + if (AutoROIForm.ModalResult = mrCancel) then + UndoVolVOI; + if not (AutoROIForm.ModalResult = mrCancel) then + gBGImg.VOIchanged := true; + //if gImageBackupSz <> 0 then Freemem(gImageBackupBuffer); + //gImageBackupSz := 0; + ImgForm.Fill3DBtn.Down := false; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +//Previous: create 3D ROI +//Below fill bubbles in 3D ROIS +//ROIcluster Follows +(***********************************************************88 +************************************************************ +**********************************************************) +procedure ROICluster (lXdim, lYDim, lZDim,lXOriginIn,lYOrigin,lZOrigin: integer; lDeleteNotFill: boolean); +var + lVariability,lOrigin,lClusterInputValue,lClusterOutputValue, lClusterSz,lQTail, + lXOrigin,lQHead,lSliceSz,lQSz,lInc,lVolSz: integer; + lXInc,lYInc,lZInc,lSlicePos,lYPos, + lMinX,lMaxX,lMinY,lMaxY,lMinZ,lMaxZ, + lMinXBound,lMaxXBound,lMinYBound,lMaxYBound,lMinZBound,lMaxZBound: integer; + lAtEdge: boolean; + lROIBuf: bytep; + lQra: LongIntP; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; + + procedure Check(lPixel: integer); + begin + if (abs(lROIBuf^[lPixel] - lClusterInputValue)) <= lVariability then begin//add item + incQra(lQHead,lQSz); + inc(lClusterSz); + lROIBuf^[lPixel] := lClusterOutputValue; + lQra^[lQHead] := lPixel; + end; + end; + +PROCEDURE RetirePixel; //FIFO cleanup +VAR + lVal,lXPos,lYPos,lZPos: integer; +BEGIN + lVal := lQra^[lQTail]; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + + if lXPos < lMinX then lMinX := lXPos; + if lXPos > lMaxX then lMaxX := lXPos; + if lXpos > lMinXBound then Check(lVal -1);//check to left + if lXPos < lMaxXBound then Check(lVal + 1); //check to right + + if lYPos < lMinY then lMinY := lYPos; + if lYPos > lMaxY then lMaxY := lYPos; + if lYpos > lMinYBound then Check(lVal -lXdim);//check previous line + if lYPos < lMaxYBound then Check(lVal + lXdim); //check next line + + if lZPos < lMinZ then lMinZ := lZPos; + if lZPos > lMaxZ then lMaxZ := lZPos; + if lZpos > lMinZBound then Check(lVal -lSliceSz);//check previous slice + if lZPos < lMaxZBound then Check(lVal + lSliceSz); //check next slice + + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + //1414 follows + for lI := 1 to lQsz do + lQra^[lI] := 0; + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +procedure SelectClusters (lInput,lOutput: integer); +begin + lClusterSz := 0; + lClusterInputValue := lInput; + lClusterOutputValue := lOutput; + FillStart(lOrigin); +end; + +function Lo (lVolumeEdge,lObjectEdge: integer): integer; +begin + if lVolumeEdge > lObjectEdge then + result := lObjectEdge + else begin + lAtEdge := true; + result := lVolumeEdge; + end; +end; + +function Hi (lVolumeEdge,lObjectEdge: integer): integer; +begin + if lVolumeEdge < lObjectEdge then + result := lObjectEdge + else begin + lAtEdge := true; + result := lVolumeEdge; + end; +end; + +begin + lXOrigin := lXOriginIn; + lVolSz := lXdim*lYdim*lZdim; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems <> lVolSz then begin + showmessage('You need to draw or load a VOI in order to use the 3D bubble tool.'); + exit; + end; + CreateUndoVol; + lSliceSz := lXdim * lYdim; + lMinX:=lXOrigin; + lMaxX:=lXOrigin; + lMinY:=lYOrigin; + lMaxY:=lYOrigin; + lMinZ:=lZOrigin; + lMaxZ:=lZOrigin; + lMinXBound := 1; + lMaxXBound := lXDim; + lMinYBound := 1; + lMaxYBound := lYDim; + lMinZBound := 1; + lMaxZBound := lZDim; + lOrigin := lXOrigin + ((lYOrigin-1)*lXdim)+((lZOrigin-1)*lSliceSz); + if (lOrigin > lVolSz) or (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) {or (gROIBupSz <> lVolSz )} then exit; + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lOrigin] = 0) then begin + showmessage('You must click directly on a ROI to select it. The 3D ROI bubble tool will not work unless you choose the ROI you wish to fill/delete.'); + exit; + end; + GetMem(lROIBuf, lVolSz); + for lInc := 1 to lVolSz do + if gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lInc] > 0 then//ROI + lROIBuf^[lInc] := 1 + else + lROIBuf^[lInc] := 0; + //BEGIN: define selected ROI contiguous cluster + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + lVariability := 0; //only convert images that are exactly 1 + SelectClusters(1,255); //selected 3D ROI is 255, other ROI = 1, nonROI 0 + //END: define selected roi + //BEGIN: either delete selected ROI, _OR_ fill bubbles in selected ROI + if lDeleteNotFill then begin + for lInc := 1 to lVolSz do + if lROIBuf^[lInc] = 1 then //alfa + lROIBuf^[lInc] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lInc] //a different ROI + else + lROIBuf^[lInc] := 0;//gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lInc]; //1402 selected ROI or non-ROI + end else begin //fill bubbles in selected ROI + //FindROIbounds; + lMinXBound := Hi(1,lMinX-1); + lMaxXBound := Lo(lXDim,lMaxX+1); + lMinYBound := Hi(1,lMinY-1); + lMaxYBound := Lo(lYDim,lMaxY+1); + lMinZBound := Hi(1,lMinZ-1); + lMaxZBound := Lo(lZDim,lMaxZ+1); + lOrigin := (lMinXBound) + ((lMinYBound-1)*lXdim)+((lMinZBound-1)*lSliceSz); + lVariability := 2;//convert voxels that are either 0 or 1 to 1 + SelectClusters(1,128); + //now bubbles trapped in volume are set to zero + //we next need to distinguish bubbles from unmarked voxels outside the searched object boundary + for lZInc := lMinZBound to lMaxZBound do begin + lSlicePos := (lZInc-1) * lSliceSz; + for lYInc := lMinYBound to lMaxYBound do begin + lYPos := (lYInc-1) * lXDim; + for lXInc := lMinXBound to lMaxXBound do begin + lInc := lXInc + lYPos + lSlicePos; + if lROIBuf^[lInc] = 0 then lROIBuf^[lInc] := 33; + end; //for X + end; //for Y + end; //for Z + + for lInc := 1 to lVolSz do + if lROIBuf^[lInc] = 33 then + lROIBuf^[lInc] := kVOI8bit //bubble in selected ROI + else + lROIBuf^[lInc] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lInc]; + end; + Freemem(lQra); + //BEGIN: CREATE 3D UNDO BUFFER + (*if (gDynSz > 1) and (gDynSz = gImageBackupSz) then begin + if (gUndoBufSz > 0) then freemem(gUndoBuffer); + gUndoBufSz := gDynSz; + getmem(gUndoBuffer,gDynSz); + Move(gImageBackupBuffer^,gUndoBuffer^,gImageBackupSz); + gSaveUndoBuf := true; + end; (**) + //END: CREATE 3D UNDO BUFFER + //BEGIN: mopping up: prepare data for viewing, report ROI change + Move(lROIBuf^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lVolSz); + Freemem(lROIBuf); {} + gBGImg.VOIchanged := true; + //END: mopping up + ImgForm.RefreshImagesTimer.enabled := true; +end; (**) + +procedure TAutoROIForm.AutoROIBtnClick(Sender: TObject); +begin + AutoROIForm.ModalResult := mrOK; + AutoROIForm.close; +end; + +procedure TAutoROIForm.CancelBtnClick(Sender: TObject); +begin + AutoROIForm.close; +end; + +procedure TAutoROIForm.AutoROIchange(Sender: TObject); +begin + if not AutoROIForm.visible then exit; + Timer1.Enabled := true; +end; + +procedure TAutoROIForm.Timer1Timer(Sender: TObject); +begin +Timer1.Enabled := false; +PreviewBtnClick(sender); +end; + +procedure TAutoROIForm.FormDestroy(Sender: TObject); +begin + //if gImageBackupSz <> 0 then Freemem(gImageBackupBuffer); + //gImageBackupSz := 0; +end; + + {$IFDEF FPC} +initialization + {$I autoroi.lrs} +{$ENDIF} + +end. diff --git a/backup/fx8.pas.bak b/backup/fx8.pas.bak new file mode 100755 index 0000000..7ea4bf3 --- /dev/null +++ b/backup/fx8.pas.bak @@ -0,0 +1,610 @@ +unit fx8; +{$DEFINE VFLIP} +{$mode objfpc}{$H+} + +interface + +uses + SysUtils, define_types, Classes,dialogs{, Graphics, Controls, Forms, Dialogs,Menus,ComCtrls, ExtCtrls}; +type + Tfx8 = RECORD + + Width,Height,X,Y,PenThick: integer; + Img: Bytep; + end; +procedure CreateFX8(var lFX8: Tfx8); +procedure DefineFX8(var lFX8: Tfx8; lWid,lHt: integer); +procedure DefineBuffFX8(var lFX8: Tfx8; lWid,lHt: integer; lBuff: ByteP); +procedure CopyFX8(var lFX8src, lFX8dest: Tfx8); +procedure RectangleFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +procedure FillRectFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +procedure EllipseFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +procedure FillEllipseFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +procedure MoveToFX8(var lFX8: Tfx8; lXin,lYin: integer); +procedure LineToFX8(var lFX8: Tfx8; lXin,lYin: integer; lClr: byte); overload; +procedure LineToFX8(var lFX8: Tfx8; lXin,lYin: integer; lClr, lLineThick: byte); overload; +procedure FloodFillFX8 (var lFX8: Tfx8; lXin, lYin: Integer; lBoundClr,lWriteClr: byte; lfsSurface: boolean); +procedure FreeFX8(var lFX8: Tfx8); + + + +implementation +uses nifti_img_view; + +function FX8x( lXin: integer): integer; +begin + result := lXin ; +end; + +function FX8y(var lFX8: Tfx8; lYin: integer): integer; +begin + {$IFDEF VFLIP} + result := lFX8.Height- lYin + 1; + {$ELSE} + result := lYin; + {$ENDIF} +end; + +procedure sortLTRB(var lXoutLow,lYOutLow,lXoutHi,lYOutHi: integer); //left lFX8.width then + lX := lFX8.width; + if lY < 1 then + lY := 1; + if lY > lFX8.height then + lY := lFX8.height; + +end; + +procedure boundrect(var lL,lT,lR,lB: integer; var lFX8: TFX8); +begin + sortLTRB(lL,lT,lR,lB); + bound(lL,lT,lFX8); + bound(lR,lB,lFX8); +end; + +procedure MoveToFX8(var lFX8: Tfx8; lXin,lYin: integer); +var + lX,lY: integer; +begin + lX := FX8x(lXin); lY := FX8y(lFX8, lYin); + bound(lX,lY,lFX8); + lFX8.X := lX; + lFX8.Y := lY; +end; + +procedure HorLine(var lFX8: Tfx8; x1,x2,y: integer; lClr: byte); +var + x,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lStart := (y -1)* lFX8.Width; + if x1 < x2 then begin + for x := x1 to x2 do + lFX8.Img^[lStart+x] := lClr; + end else + for x := x2 to x1 do + lFX8.Img^[lStart+x] := lClr; +end; + + +function isOutOfBounds(var lFX8: Tfx8; var x,y:integer): boolean; +var + iy: integer; +begin + iy := y; + x := FX8x(x); y := FX8y(lFX8, y); + + if (x < 0) or (y < 0) or (x > lFX8.Width) or (y > lFX8.Height) then begin + imgform.StatusLabel.caption := inttostr(iy)+'pixel error '+inttostr(x)+'x'+inttostr(y)+' '+inttostr(lFX8.Width)+'x'+inttostr(lFX8.Height); + result := true; + exit; + + end; + result := false; +end; + +function getpixel(var lFX8: Tfx8; x,y: integer): byte; +begin + result := lFX8.Img^[(Y -1)* lFX8.Width+x]; +end; + +procedure putpixel(var lFX8: Tfx8; x,y: integer; lClr: byte); +begin + if (x < 1) or (y < 1) or (x > lFX8.width) or (y > lFX8.height) then + exit; //putwidepixel and puttallpixel can have x < 1, x > width, etc... + lFX8.Img^[(Y -1)* lFX8.Width+x] := lClr; +end; + +procedure putwidepixel(var lFX8: Tfx8; x,y: integer; lClr, lLineThick: byte); +var lBar: integer; +begin + putpixel(lFX8,x,y,lClr); + if lLineThick < 2 then exit; + for lBar := 1 to ((lLineThick-1) div 2) do begin + putpixel(lFX8,x-lBar,y,lClr); + putpixel(lFX8,x+lBar,y,lClr); + end; +end; + +procedure puttallpixel(var lFX8: Tfx8; x,y: integer; lClr, lLineThick: byte); +var lBar: integer; +begin + putpixel(lFX8,x,y,lClr); + if lLineThick < 2 then exit; + for lBar := 1 to ((lLineThick-1) div 2) do begin + putpixel(lFX8,x,y-lBar,lClr); + putpixel(lFX8,x,y+lBar,lClr); + end; +end; + +procedure LineToFX8(var lFX8: Tfx8; lXin,lYin: integer; lClr, lLineThick: byte) ; overload; +var + lSlope: single; + lX2,lY2,lX1,lY1,lP,lCol,lStart,lX,lY: integer; +begin + lX1 := lFX8.X; + lY1 := lFX8.Y; + lX2 := FX8x(lXin); lY2 := FX8y(lFX8, lYin); + Bound(lX2,lY2,lFX8); + lFX8.X := lX2; + lFX8.Y := lY2; + //next: endpoints - required if no line + lFX8.Img^[(lY1 -1)* lFX8.Width+lX1] := lClr; + lFX8.Img^[(lY2 -1)* lFX8.Width+lX2] := lClr; + if (lX1 = lX2) and (lY1 = lY2) then + exit; + if abs(lY1-lY2) > abs(lX1-lX2) then begin //mostly vertical + if lY1 > lY2 then begin + lSlope := (lX1-lX2) /(lY1-lY2); + for lY := lY2 to lY1 do + putwidepixel(lFX8,lX2+round(lSlope*(lY-lY2)),lY, lClr, lLineThick); + //lFX8.Img^[((lY -1)* lFX8.Width)+lX2+round(lSlope*(lY-lY2))] := lClr; + end else begin + lSlope := (lX2-lX1) /(lY2-lY1); + for lY := lY1 to lY2 do + putwidepixel(lFX8,lX1+round(lSlope*(lY-lY1)),lY, lClr, lLineThick); + //lFX8.Img^[((lY -1)* lFX8.Width)+lX1+round(lSlope*(lY-lY1))] := lClr; + end; + end else begin //mostly horizontal - primary change in X + if lX1 > lX2 then begin + lSlope := (lY1-lY2) /(lX1-lX2); + for lX := lX2 to lX1 do + puttallpixel(lFX8,lX,lY2+round(lSlope*(lX-lX2) ) , lClr, lLineThick); + //lFX8.Img^[((lY2+round(lSlope*(lX-lX2) ) -1)* lFX8.Width)+lX] := lClr; + end else begin + lSlope := (lY2-lY1) /(lX2-lX1); + for lX := lX1 to lX2 do + puttallpixel(lFX8,lX,lY1+round(lSlope*(lX-lX1) ) , lClr, lLineThick); + //lFX8.Img^[((lY1+round(lSlope*(lX-lX1) ) -1)* lFX8.Width)+lX] := lClr; + end; + end; +end; + +procedure LineToFX8(var lFX8: Tfx8; lXin,lYin: integer; lClr: byte); overload; +//for speed: lSingle could use integer math +var + lSlope: single; + lX2,lY2,lX1,lY1,lX,lY: integer; +begin + if lFX8.PenThick > 2 then begin + LineToFX8(lFX8,lXin,lYin, lClr,lFX8.PenThick); + exit; + end; + lX1 := lFX8.X; + lY1 := lFX8.Y; + lX2 := FX8x(lXin); lY2 := FX8y(lFX8, lYin); + Bound(lX2,lY2,lFX8); + lFX8.X := lX2; + lFX8.Y := lY2; + //next: endpoints - required if no line + lFX8.Img^[(lY1 -1)* lFX8.Width+lX1] := lClr; + lFX8.Img^[(lY2 -1)* lFX8.Width+lX2] := lClr; + if (lX1 = lX2) and (lY1 = lY2) then + exit; + if abs(lY1-lY2) > abs(lX1-lX2) then begin //mostly vertical + if lY1 > lY2 then begin + lSlope := (lX1-lX2) /(lY1-lY2); + for lY := lY2 to lY1 do + lFX8.Img^[((lY -1)* lFX8.Width)+lX2+round(lSlope*(lY-lY2))] := lClr; + end else begin + lSlope := (lX2-lX1) /(lY2-lY1); + for lY := lY1 to lY2 do + lFX8.Img^[((lY -1)* lFX8.Width)+lX1+round(lSlope*(lY-lY1))] := lClr; + end; + end else begin //mostly horizontal - primary change in X + if lX1 > lX2 then begin + lSlope := (lY1-lY2) /(lX1-lX2); + for lX := lX2 to lX1 do + lFX8.Img^[((lY2+round(lSlope*(lX-lX2) ) -1)* lFX8.Width)+lX] := lClr; + end else begin + lSlope := (lY2-lY1) /(lX2-lX1); + for lX := lX1 to lX2 do + lFX8.Img^[((lY1+round(lSlope*(lX-lX1) ) -1)* lFX8.Width)+lX] := lClr; + end; + end; +end; + +Procedure FillEllipseDefault(var lFX8: Tfx8; X,Y: smallint;XRadius: word; + YRadius:word; lClr: byte); + Const ConvFac = Pi/180.0; + + var + j, Delta, DeltaEnd: single; + NumOfPixels: longint; + TempTerm: single; + xtemp, ytemp, xp, yp, xm, ym, xnext, ynext, + plxpyp, plxmyp, plxpym, plxmym: smallint; + BackupColor, TmpAngle, OldLineWidth: word; + Begin + + If xradius = 0 then inc(xradius); + if yradius = 0 then inc(yradius); + { check for an ellipse with negligable x and y radius } + If (xradius <= 1) and (yradius <= 1) then begin + putpixel(lFX8, x,y, lClr); + exit; + end; + { approximate the number of pixels required by using the circumference } + { equation of an ellipse. } + { Changed this formula a it (trial and error), but the net result is that } + { less pixels have to be calculated now } + NumOfPixels:=Round(Sqrt(3)*sqrt(sqr(XRadius)+sqr(YRadius))); + { Calculate the angle precision required } + Delta := 90.0 / NumOfPixels; + { for restoring after PatternLine } + + { removed from inner loop to make faster } + { Always just go over the first 90 degrees. Could be optimized a } + { bit if StAngle and EndAngle lie in the same quadrant, left as an } + { exercise for the reader :) (JM) } + j := 0; + { calculate stop position, go 1 further than 90 because otherwise } + { 1 pixel is sometimes not drawn (JM) } + DeltaEnd := 91; + { Calculate points } + xnext := XRadius; + ynext := 0; + Repeat + xtemp := xnext; + ytemp := ynext; + { this is used by both sin and cos } + TempTerm := (j+Delta)*ConvFac; + { Calculate points } + xnext := round(XRadius*Cos(TempTerm)); + ynext := round(YRadius*Sin(TempTerm+Pi)); + xp := x + xtemp; + xm := x - xtemp; + yp := y + ytemp; + ym := y - ytemp; + plxpyp := maxsmallint; + plxmyp := -maxsmallint-1; + plxpym := maxsmallint; + plxmym := -maxsmallint-1; + plxpyp := xp; + PutPixel(lFX8,xp,yp,lClr); + plxmyp := xm; + PutPixel(lFX8,xm,yp,lClr); + plxmym := xm; + PutPixel(lFX8,xm,ym,lClr); + plxpym := xp; + PutPixel(lFX8,xp,ym,lClr); + If (ynext <> ytemp) and + (xp - xm >= 1) then + begin + //CurrentColor := FillSettings.Color; + HorLine(lFX8,plxmyp+1,plxpyp-1,yp,lClr); + HorLine(lFX8,plxmym+1,plxpym-1,ym,lClr); + //CurrentColor := BackupColor;*) + end; + j:=j+Delta; + Until j > (DeltaEnd); + end; + + Procedure EllipseDefault(var lFX8: Tfx8; X,Y: smallint;XRadius: word; + YRadius:word; lClr: byte); + Const ConvFac = Pi/180.0; + + var + j, Delta, DeltaEnd: single; + NumOfPixels: longint; + TempTerm: single; + xtemp, ytemp, xp, yp, xm, ym, xnext, ynext, + plxpyp, plxmyp, plxpym, plxmym: smallint; + BackupColor, TmpAngle, OldLineWidth: word; + Begin + + If xradius = 0 then inc(xradius); + if yradius = 0 then inc(yradius); + { check for an ellipse with negligable x and y radius } + If (xradius <= 1) and (yradius <= 1) then begin + putpixel(lFX8, x,y, lClr); + exit; + end; + { approximate the number of pixels required by using the circumference } + { equation of an ellipse. } + { Changed this formula a it (trial and error), but the net result is that } + { less pixels have to be calculated now } + NumOfPixels:=Round(Sqrt(3)*sqrt(sqr(XRadius)+sqr(YRadius))); + { Calculate the angle precision required } + Delta := 90.0 / NumOfPixels; + { for restoring after PatternLine } + + { removed from inner loop to make faster } + { Always just go over the first 90 degrees. Could be optimized a } + { bit if StAngle and EndAngle lie in the same quadrant, left as an } + { exercise for the reader :) (JM) } + j := 0; + { calculate stop position, go 1 further than 90 because otherwise } + { 1 pixel is sometimes not drawn (JM) } + DeltaEnd := 91; + { Calculate points } + xnext := XRadius; + ynext := 0; + Repeat + xtemp := xnext; + ytemp := ynext; + { this is used by both sin and cos } + TempTerm := (j+Delta)*ConvFac; + { Calculate points } + xnext := round(XRadius*Cos(TempTerm)); + ynext := round(YRadius*Sin(TempTerm+Pi)); + xp := x + xtemp; + xm := x - xtemp; + yp := y + ytemp; + ym := y - ytemp; + PutPixel(lFX8,xp,yp,lClr); + PutPixel(lFX8,xm,yp,lClr); + PutPixel(lFX8,xm,ym,lClr); + PutPixel(lFX8,xp,ym,lClr); + j:=j+Delta; + Until j > (DeltaEnd); + end; + + +procedure EllipseFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +var + lL,lT,lR,lB,lP,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lL := FX8x(lLin); lB := FX8y(lFX8, lBin); + lR := FX8x(lRin); lT := FX8y(lFX8, lTin); + + BoundRect(lL,lT,lR,lB,lFX8); + EllipseDefault(lFX8, (lL+lR) shr 1,(lT+lB) shr 1, (lR-lL) shr 1, (lB-lT) shr 1,lClr); +end; + +procedure FillEllipseFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +var + lL,lT,lR,lB,lP,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lL := FX8x(lLin); lB := FX8y(lFX8, lBin); + lR := FX8x(lRin); lT := FX8y(lFX8, lTin); + + BoundRect(lL,lT,lR,lB,lFX8); + FillEllipseDefault(lFX8, (lL+lR) shr 1,(lT+lB) shr 1, (lR-lL) shr 1, (lB-lT) shr 1,lClr); +end; + +procedure RectangleFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +var + lL,lT,lR,lB,lP,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lL := FX8x(lLin); lB := FX8y(lFX8, lBin); + lR := FX8x(lRin); lT := FX8y(lFX8, lTin); + + BoundRect(lL,lT,lR,lB,lFX8); + //top line + lStart := (lT -1)* lFX8.Width; + for lP := lL to lR do + lFX8.Img^[lStart+lP] := lClr; + //bottom line + lStart := (lB -1)* lFX8.Width; + for lP := lL to lR do + lFX8.Img^[lStart+lP] := lClr; + //left and right lines + lStart := (lT -1)* lFX8.Width; + for lP := lT to lB do begin + lFX8.Img^[lStart+lL] := lClr; + lFX8.Img^[lStart+lR] := lClr; + lStart := lStart + lFX8.Width; + end; +end; + +procedure FillRectFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +var + lL,lT,lR,lB,lRow,lCol,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lL := FX8x(lLin); lB := FX8y(lFX8, lBin); + lR := FX8x(lRin); lT := FX8y(lFX8, lTin); + + BoundRect(lL,lT,lR,lB,lFX8); + lStart := (lT -1)* lFX8.Width; + for lRow := lT to lB do begin + for lCol := lL to lR do + lFX8.Img^[lStart+lCol] := lClr; + lStart := lStart + lFX8.Width; + end; +end; + +procedure DefineFX8(var lFX8: Tfx8; lWid,lHt: integer); +begin + if (lFX8.img = nil) or (lWid <> lFX8.Width) or (lHt <> lFX8.Height) then begin + if lFX8.img <> nil then + freemem(lFX8.Img); + Getmem(lFX8.img, lWid*lHt); + lFX8.Height := lHt; + lFX8.Width := lWid; + end; + fillchar(lFX8.Img^,lWid*lHt,0); + lFX8.X := 1; + lFX8.Y := 1; +end; + +procedure DefineBuffFX8(var lFX8: Tfx8; lWid,lHt: integer; lBuff: ByteP); +begin + if lBuff = nil then exit; + DefineFX8(lFX8, lWid,lHt); + Move(lBuff^,lFX8.Img^,lWid*lHt); +end; + +procedure CopyFX8(var lFX8src, lFX8dest: Tfx8); +begin + if (lFX8src.Img = nil) then + exit; + DefineFX8(lFX8dest, lFX8src.Width,lFX8src.Height); + Move(lFX8src.Img^,lFX8dest.Img^,lFX8src.Width*lFX8src.Height); +end; + +procedure FloodFillFX8 (var lFX8: Tfx8; lXin, lYin: Integer; lBoundClr,lWriteClr: byte; lfsSurface: boolean); +//Written by Chris Rorden +//A simple first-in-first-out circular buffer (the queue) for flood-filling contiguous voxels. +//This algorithm avoids stack problems associated simple recursive algorithms +//http://steve.hollasch.net/cgindex/polygons/floodfill.html +const + kFill = 0; //pixels we will want to flood fill + kFillable = 128; //voxels we might flood fill + kUnfillable = 255; //voxels we can not flood fill +var + lWid,lHt,lQSz,lQHead,lQTail: integer; + lQRA: LongIntP; + lMaskRA: ByteP; +procedure IncQra(var lVal, lQSz: integer);//nested inside FloodFill +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; //nested Proc IncQra +function Pos2XY (lPos: integer): TPoint; +begin + result.X := ((lPos-1) mod lWid)+1; //horizontal position + result.Y := ((lPos-1) div lWid)+1; //vertical position +end; //nested Proc Pos2XY +procedure TestPixel(lPos: integer); +begin + if (lMaskRA^[lPos]=kFillable) then begin + lMaskRA^[lPos] := kFill; + lQra^[lQHead] := lPos; + incQra(lQHead,lQSz); + end; +end; //nested Proc TestPixel +procedure RetirePixel; //nested inside FloodFill +var + lVal: integer; + lXY : TPoint; +begin + lVal := lQra^[lQTail]; + lXY := Pos2XY(lVal); + if lXY.Y > 1 then + TestPixel (lVal-lWid);//pixel above + if lXY.Y < lHt then + TestPixel (lVal+lWid);//pixel below + if lXY.X > 1 then + TestPixel (lVal-1); //pixel to left + if lXY.X < lWid then + TestPixel (lVal+1); //pixel to right + incQra(lQTail,lQSz); //done with this pixel +end; //nested proc RetirePixel +const + kIndex0or1 = 0; +var + lTargetColorVal,lDefaultVal: byte; + lX,lY,lPos,x,y: integer; +begin //FloodFill + X := lXin; Y := lYin; + if isOutOfBounds(lFX8, X,Y) then exit; + //lX := FX8x(lXin); lY := FX8y(lFX8, lYin); + // imgform.StatusLabel.caption := 'pixel error '+inttostr(X)+'x'+inttostr(Y); + //exit; + if lfsSurface then begin + if getpixel(lFX8, x,y) <> lBoundClr then exit; + lTargetColorVal := kFillable; + lDefaultVal := kUnfillable; + end else begin //fsBorder + //fill non-target color with brush - bounded by target-color + if getpixel(lFX8, x,y) = lBoundClr then exit; + lTargetColorVal := kUnfillable; + lDefaultVal := kFillable; + end; + //imgform.StatusLabel.caption := 'pxl '+inttostr(lTargetColorVal)+'x'+inttostr(lDefaultVal); + lHt := lFX8.Height; + lWid := lFX8.Width; + lQSz := lHt * lWid; + //Qsz should be more than the most possible simultaneously active pixels + //Worst case scenario is a click at the center of a 3x3 image: all 9 pixels will be active simultaneously + //for larger images, only a tiny fraction of pixels will be active at one instance. + //perhaps lQSz = ((lHt*lWid) div 4) + 32; would be safe and more memory efficient + if (lHt < 1) or (lWid < 1) then exit; + getmem(lQra,lQSz*sizeof(longint)); //very wasteful - + getmem(lMaskRA,lHt*lWid*sizeof(byte)); + for lPos := 1 to (lHt*lWid) do + if lFX8.Img^[lPos] = lBoundClr then + lMaskRA^[lPos] := lTargetColorVal //assume all voxels are non targets + else + lMaskRA^[lPos] := lDefaultVal; //assume all voxels are non targets + + lQHead := 2; + lQTail := 1; + lQra^[lQTail] := (((Y-1) * lWid)+X+kIndex0or1); //NOTE: both X and Y start from 0 not 1 + lMaskRA^[lQra^[lQTail]] := kFill; + RetirePixel; + {for lPos := 1 to 100 do + RetirePixel;} + while lQHead <> lQTail do + RetirePixel; + + lPos := 0; + + for lY := 0 to (lHt-1) do + for lX := 0 to (lWid-1) do begin + lPos := lPos + 1; + if lMaskRA^[lPos] = kFill then + lFX8.Img^[lPos] := lWriteClr; + end; + freemem(lMaskRA); + freemem(lQra); +end;// proc FloodFill + + +procedure CreateFX8(var lFX8: Tfx8); +begin + lFX8.Img := nil; +end; + +procedure FreeFX8(var lFX8: Tfx8); +begin + if lFX8.Img <> nil then + Freemem(lFX8.Img); + lFX8.Img := nil; +end; + + +end. + diff --git a/backup/histoform.lfm.bak b/backup/histoform.lfm.bak new file mode 100755 index 0000000..230aba0 --- /dev/null +++ b/backup/histoform.lfm.bak @@ -0,0 +1,59 @@ +object HistogramForm: THistogramForm + Left = 1007 + Height = 336 + Top = 272 + Width = 465 + Caption = 'Histogram' + ClientHeight = 336 + ClientWidth = 465 + Font.Height = -11 + Menu = MainMenu1 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '0.9.30.2' + object HistoPanel: TScrollBox + Left = 0 + Height = 336 + Top = 0 + Width = 465 + Align = alClient + ClientHeight = 336 + ClientWidth = 465 + TabOrder = 0 + object HistoImage: TImage + Cursor = crCross + Left = 0 + Height = 336 + Top = 0 + Width = 465 + Align = alClient + AutoSize = True + Center = True + end + end + object MainMenu1: TMainMenu + left = 113 + top = 51 + object File1: TMenuItem + Caption = 'File' + object Saveasbitmap1: TMenuItem + Caption = 'Save as bitmap...' + ShortCut = 16467 + OnClick = Saveasbitmap1Click + end + object Closewindow1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Closewindow1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + ShortCut = 16451 + OnClick = Copy1Click + end + end + end +end diff --git a/backup/histoform.pas.bak b/backup/histoform.pas.bak new file mode 100755 index 0000000..033108b --- /dev/null +++ b/backup/histoform.pas.bak @@ -0,0 +1,99 @@ +unit histoform; + +interface + +uses +{$IFNDEF Unix} Windows,{$ENDIF} + + {$IFDEF FPC} LResources,{$ENDIF} + Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Menus, ExtCtrls,ClipBrd; + +type + + { THistogramForm } + + THistogramForm = class(TForm) + HistoPanel: TScrollBox; + HistoImage: TImage; + MainMenu1: TMainMenu; + File1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Saveasbitmap1: TMenuItem; + Closewindow1: TMenuItem; + procedure Copy1Click(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure Saveasbitmap1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + HistogramForm: THistogramForm; + +implementation +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} +uses nifti_img; + +procedure THistogramForm.Copy1Click(Sender: TObject); +{$IFDEF FPC} +begin + if (HistoImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + HistoImage.Picture.Bitmap.SaveToClipboardFormat(2); +end; +{$ELSE} +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (HistoImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + HistoImage.Picture.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData) +end; +{$ENDIF} + + +procedure THistogramForm.Closewindow1Click(Sender: TObject); +begin + HistogramForm.Close; +end; + +procedure THistogramForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Saveasbitmap1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Closewindow1.ShortCut := ShortCut(Word('W'), [ssMeta]); + {$ENDIF} + {$ENDIF} +end; + +procedure THistogramForm.Saveasbitmap1Click(Sender: TObject); +begin +{$IFNDEF FPC} + SaveImgAsPNGBMP (HistoImage); +{$ELSE} + SaveImgAsPNGBMP (HistoImage); +{$ENDIF} +end; + + {$IFDEF FPC} +initialization + {$I histoform.lrs} +{$ENDIF} + +end. \ No newline at end of file diff --git a/backup/isthreaded.inc.bak b/backup/isthreaded.inc.bak new file mode 100755 index 0000000..ded6db3 --- /dev/null +++ b/backup/isthreaded.inc.bak @@ -0,0 +1,19 @@ +//x86-64 GTK2 crashes with progress bars +//GTK2 crashes with threading + + +{$IFDEF LCLgtk2} + {$ifndef cpux86_64} + {$DEFINE SHOWPROG}//SHOWPROG =ShowProgressBar + {$ENDIF} +{$ELSE} + {$DEFINE SHOWPROG}//SHOWPROG =ShowProgressBar +{$ENDIF} +{$IFDEF UNIX} //Windows is always threaded +{$DEFINE NoThreads}//NoThreads - single threaded execution + {$IFDEF LCLgtk2} + {$DEFINE NoThreads}//NoThreads - single threaded execution + //GTK2 does not allow threading + {$ENDIF} +{$ENDIF} + diff --git a/backup/landmarks.lfm.bak b/backup/landmarks.lfm.bak new file mode 100755 index 0000000..5484a5f --- /dev/null +++ b/backup/landmarks.lfm.bak @@ -0,0 +1,91 @@ +object AnatForm: TAnatForm + Left = 400 + Height = 27 + Top = 606 + Width = 438 + BorderStyle = bsDialog + Caption = 'Landmarks' + ClientHeight = 27 + ClientWidth = 438 + Constraints.MaxHeight = 27 + Constraints.MaxWidth = 438 + Constraints.MinHeight = 27 + Constraints.MinWidth = 438 + Font.Height = -11 + Font.Name = 'MS Sans Serif' + FormStyle = fsStayOnTop + Position = poScreenCenter + LCLVersion = '0.9.29' + object ToolBar1: TToolBar + Left = 0 + Height = 29 + Top = 0 + Width = 438 + ButtonHeight = 21 + Caption = 'ToolBar1' + Font.Name = 'MS Sans Serif' + ParentFont = False + TabOrder = 0 + object OpenBtn: TSpeedButton + Left = 1 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Open' + Color = clBtnFace + NumGlyphs = 0 + OnClick = OpenBtnClick + end + object SaveBtn: TSpeedButton + Left = 57 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Save' + Color = clBtnFace + NumGlyphs = 0 + OnClick = SaveBtnClick + end + object ComboBox1: TComboBox + Left = 113 + Height = 24 + Top = 2 + Width = 145 + DropDownCount = 24 + ItemHeight = 16 + OnChange = ComboBox1Change + Style = csDropDownList + TabOrder = 0 + end + object AddBtn: TSpeedButton + Left = 258 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Add' + Color = clBtnFace + NumGlyphs = 0 + OnClick = AddBtnClick + end + object UpdateBtn: TSpeedButton + Left = 314 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Update' + Color = clBtnFace + NumGlyphs = 0 + OnClick = UpdateBtnClick + end + object DeleteBtn: TSpeedButton + Left = 370 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Delete' + Color = clBtnFace + NumGlyphs = 0 + OnClick = DeleteBtnClick + end + end +end diff --git a/backup/landmarks.pas.bak b/backup/landmarks.pas.bak new file mode 100755 index 0000000..136839e --- /dev/null +++ b/backup/landmarks.pas.bak @@ -0,0 +1,254 @@ +unit landmarks; + +interface +{$H+} + + +uses + {$IFDEF Win32} + Windows, Messages, +{$ELSE} + LMessages, LCLType, +{$ENDIF} + {$IFDEF FPC}LResources, {$ENDIF} + SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, Buttons, ToolWin, ComCtrls; + +type + TAnatForm = class(TForm) + ToolBar1: TToolBar; + SaveBtn: TSpeedButton; + AddBtn: TSpeedButton; + ComboBox1: TComboBox; + UpdateBtn: TSpeedButton; + OpenBtn: TSpeedButton; + DeleteBtn: TSpeedButton; + procedure SaveBtnClick(Sender: TObject); + procedure AddBtnClick(Sender: TObject); + procedure ComboBox1Change(Sender: TObject); + procedure UpdateCombo; + procedure OpenBtnClick(Sender: TObject); + procedure Update(lIndex: integer); + procedure UpdateBtnClick(Sender: TObject); + procedure DeleteBtnClick(Sender: TObject); + procedure OpenAnat(lFilename: string); + procedure CloseAnat; + private + { Private declarations } + public + { Public declarations } + end; + +var + AnatForm: TAnatForm; + +implementation + +uses nifti_img_view, nifti_img, nifti_hdr_view, define_types; + {$IFNDEF FPC} //Delphi +{$R *.dfm} +{$ENDIF} +type + TLandmark = record + Name: string; + X,Y,Z: single; + end; + TLandmarkRA = array of TLandmark; +const +kAnatFilter = 'AnatomyFile|*.anat'; +var + gLandmarks: TLandmarkRA; +procedure TAnatForm.CloseAnat; +begin + if length(gLandmarks) < 1 then + exit; + SetLength(gLandmarks,0); + UpdateCombo; +end; + +procedure TAnatForm.SaveBtnClick(Sender: TObject); +const + kSep = chr(9); +var + i: integer; + lF: TextFile; +begin + if length(gLandmarks) < 1 then begin + showmessage('No landmarks open - either open a file or create new landmarks'); + exit; + end; + ImgForm.SaveDialog1.Filter := kAnatFilter; + ImgForm.SaveDialog1.DefaultExt := '.anat'; + ImgForm.SaveDialog1.Filename := ChangeFileExt(ImgForm.SaveDialog1.Filename, ImgForm.SaveDialog1.DefaultExt); //10102006 + if not ImgForm.SaveDialog1.Execute then exit; + Filemode := 0; + AssignFile(lF, ImgForm.SaveDialog1.Filename); + rewrite(lF); + for i := 0 to length(gLandmarks)-1 do + Writeln(lF, gLandmarks[i].Name+kSep+floattostr(gLandmarks[i].X)+kSep+floattostr(gLandmarks[i].Y)+kSep+floattostr(gLandmarks[i].Z) ); + CloseFile(lF); + +end; + +procedure TAnatForm.UpdateCombo; +var + i: integer; +begin +//xxx + ComboBox1.Items.Clear; + if length(gLandmarks) < 1 then + exit; + for i := 0 to length(gLandmarks)-1 do + ComboBox1.Items.Add(gLandmarks[i].Name); + ComboBox1.ItemIndex := length(gLandmarks)-1; + ComboBox1Change(nil); +end; + + +procedure TAnatForm.AddBtnClick(Sender: TObject); +var + s: string; + i: integer; + lOK: boolean; +begin + i := length(gLandmarks)+1; + s := 'A'+inttostr(i); + lOK := InputQuery('Enter a name', 'region name', s); + if not lOK then + exit; + setlength(gLandmarks,i); + gLandmarks[i-1].Name := s; + Update(i-1); + UpdateCombo; +end; + +(* + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + *) +procedure SetLandmark(index: integer);//indexed from 0 +var +//lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if (index < 0) or (index >= length(gLandmarks)) then + exit; + MMToImgCoord(lX,lY,lZ,gLandmarks[index].X,gLandmarks[index].Y,gLandmarks[index].Z); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + ImgForm.XViewEditChange(nil); +end; + +procedure TAnatForm.ComboBox1Change(Sender: TObject); +begin + SetLandmark(ComboBox1.ItemIndex); +end; + +function NextTab(lStr: string; var lP: integer): string; +//reports text prior to comma... +var + len: integer; +begin + result := ''; + len := length(lStr); + if len < lP then exit; + repeat + if (lStr[lP] = chr(9){','}) then begin + lP := lP + 1; + exit; + end; + //if lStr[lP] <> ' ' then + result := result + lStr[lP]; + lP := lP + 1; + until (lP > len); +end; + +procedure TAnatForm.OpenAnat(lFilename: string); +var + st: string; + sl: TStringList; + n, line, col : integer; +begin + if not Fileexists(lFilename) then begin + CloseAnat; + exit; + end; + //will load the TAB delimited TXT here + sl := TStringList.Create; + try + //load the tab delimited txt file + sl.LoadFromFile(lFilename) ; + //for each tab delimited line + n := 0; + setlength(gLandmarks,sl.Count); + for line := 0 to sl.Count-1 do begin + st := sl[line]; + col := 1; + if (NextTab(st,col) <> '') and (NextTab(st,col) <> '') and(NextTab(st,col) <> '') and(NextTab(st,col) <> '') then begin + inc(n); + col := 1; + gLandmarks[line].Name := NextTab(st,col); + gLandmarks[line].X := strtofloat(NextTab(st,col)); + gLandmarks[line].Y := strtofloat(NextTab(st,col)); + gLandmarks[line].Z := strtofloat(NextTab(st,col)); + end; + end; + setlength(gLandmarks,n); + finally + sl.Free; + end; + UpdateCombo; + AnatForm.show; +end; + + +procedure TAnatForm.OpenBtnClick(Sender: TObject); +begin + if not OpenDialogExecute(kAnatFilter,'Select background image',false) then exit; + OpenAnat(HdrForm.OpenHdrDlg.Filename) ; +end; + +procedure TAnatForm.Update(lIndex: integer); +var + X,Y,Z: integer; +begin + if lIndex >= Length(gLandmarks) then + exit; + X := round(ImgForm.XViewEdit.value); + Y := round(ImgForm.YViewEdit.value); + Z := round(ImgForm.ZViewEdit.value); + ImgCoordToMM(X,Y,Z, gLandmarks[lIndex].X,gLandmarks[lIndex].Y,gLandmarks[lIndex].Z); + ComboBox1Change(nil); +end; + +procedure TAnatForm.UpdateBtnClick(Sender: TObject); +begin + Update(ComboBox1.ItemIndex); + +end; + +procedure TAnatForm.DeleteBtnClick(Sender: TObject); +var + p,i,l: integer; +begin + l := Length(gLandmarks); + i := ComboBox1.ItemIndex; + if (l < 1) or (i >= l) or (i < 0) then + exit; + if i < (l-1) then + for p := i+1 to l-1 do + gLandmarks[p-1] := gLandmarks[p]; + SetLength(gLandmarks,l-1); + UpdateCombo; +end; + +initialization +{$IFDEF FPC} +{$I landmarks.lrs} +{$ENDIF} + +end. + diff --git a/backup/mricron.lpi.bak b/backup/mricron.lpi.bak new file mode 100755 index 0000000..ab40f4f --- /dev/null +++ b/backup/mricron.lpi.bak @@ -0,0 +1,633 @@ + + + + + + + + + + + + <Icon Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="FCL"/> + <MinVersion Major="1" Valid="True"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="53"> + <Unit0> + <Filename Value="mricron.lpr"/> + <IsPartOfProject Value="True"/> + <WindowIndex Value="1"/> + <CursorPos X="129" Y="3"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit0> + <Unit1> + <Filename Value="nifti_hdr_view.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="HdrForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="3"/> + <WindowIndex Value="1"/> + <TopLine Value="150"/> + <CursorPos X="57" Y="165"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit1> + <Unit2> + <Filename Value="define_types.pas"/> + <TopLine Value="410"/> + <CursorPos X="23" Y="420"/> + <UsageCount Value="74"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit2> + <Unit3> + <Filename Value="about.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="AboutForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="19"/> + <CursorPos X="65" Y="40"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit3> + <Unit4> + <Filename Value="text.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="TextForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="36"/> + <CursorPos Y="61"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit4> + <Unit5> + <Filename Value="render.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="RenderForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="527"/> + <CursorPos X="76" Y="534"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit5> + <Unit6> + <Filename Value="ROIfilt.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="FilterROIform"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <CursorPos X="58" Y="13"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit6> + <Unit7> + <Filename Value="nifti_img_view.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ImgForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="1"/> + <WindowIndex Value="1"/> + <TopLine Value="3129"/> + <CursorPos X="30" Y="3154"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit7> + <Unit8> + <Filename Value="nifti_img.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="4565"/> + <CursorPos X="38" Y="4569"/> + <UsageCount Value="100"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit8> + <Unit9> + <Filename Value="cutout.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="CutoutForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="161"/> + <CursorPos X="29" Y="166"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit9> + <Unit10> + <Filename Value="MultiSlice.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MultiSliceForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="430"/> + <CursorPos X="28" Y="452"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit10> + <Unit11> + <Filename Value="autoroi.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="AutoROIForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="534"/> + <CursorPos X="68" Y="537"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit11> + <Unit12> + <Filename Value="spread.pas"/> + <ComponentName Value="SpreadForm"/> + <HasResources Value="True"/> + <TopLine Value="83"/> + <CursorPos X="47" Y="93"/> + <UsageCount Value="173"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit12> + <Unit13> + <Filename Value="design.pas"/> + <ComponentName Value="DesignForm"/> + <HasResources Value="True"/> + <CursorPos X="45" Y="167"/> + <UsageCount Value="173"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit13> + <Unit14> + <Filename Value="histoform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="HistogramForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="6"/> + <CursorPos X="105" Y="19"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit14> + <Unit15> + <Filename Value="logistic.pas"/> + <TopLine Value="1075"/> + <CursorPos Y="1100"/> + <UsageCount Value="3"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit15> + <Unit16> + <Filename Value="ReadInt.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ReadIntForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <WindowIndex Value="1"/> + <CursorPos X="77" Y="2"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit16> + <Unit17> + <Filename Value="nifti_hdr.pas"/> + <TopLine Value="172"/> + <CursorPos X="5" Y="188"/> + <UsageCount Value="66"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit17> + <Unit18> + <Filename Value="gzio2.pas"/> + <TopLine Value="278"/> + <CursorPos X="11" Y="282"/> + <UsageCount Value="18"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit18> + <Unit19> + <Filename Value="cropedges.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="CropEdgeForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="CropEdges"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="81"/> + <CursorPos X="3" Y="83"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit19> + <Unit20> + <Filename Value="bet.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="BETForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="4"/> + <WindowIndex Value="1"/> + <TopLine Value="73"/> + <CursorPos X="48" Y="86"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit20> + <Unit21> + <Filename Value="mni.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MNIForm"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="20"/> + <CursorPos X="3" Y="53"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit21> + <Unit22> + <Filename Value="ugraphics.pas"/> + <CursorPos X="15"/> + <UsageCount Value="66"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit22> + <Unit23> + <Filename Value="fx8.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="549"/> + <CursorPos X="24" Y="552"/> + <UsageCount Value="22"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit23> + <Unit24> + <Filename Value="voismooth.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="voismoothform"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="385"/> + <CursorPos X="36" Y="391"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit24> + <Unit25> + <Filename Value="prefs.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="PrefForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <CursorPos X="55" Y="63"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit25> + <Unit26> + <Filename Value="perisettings.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="PSForm"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="81"/> + <CursorPos X="38" Y="96"/> + <UsageCount Value="224"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit26> + <Unit27> + <Filename Value="graphx.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Graph4DForm"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="1043"/> + <CursorPos X="29" Y="1055"/> + <UsageCount Value="224"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit27> + <Unit28> + <Filename Value="render_composite.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="184"/> + <CursorPos X="80" Y="193"/> + <UsageCount Value="56"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit28> + <Unit29> + <Filename Value="ReadFloat.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ReadFloatForm"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="38"/> + <CursorPos X="38" Y="53"/> + <UsageCount Value="201"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit29> + <Unit30> + <Filename Value="common\nifti_hdr.pas"/> + <EditorIndex Value="5"/> + <WindowIndex Value="1"/> + <TopLine Value="639"/> + <CursorPos X="29" Y="645"/> + <UsageCount Value="59"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit30> + <Unit31> + <Filename Value="common\define_types.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="28"/> + <CursorPos X="69" Y="32"/> + <UsageCount Value="100"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit31> + <Unit32> + <Filename Value="common\dicomhdr.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="402"/> + <CursorPos X="26" Y="415"/> + <UsageCount Value="32"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit32> + <Unit33> + <Filename Value="landmarks.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="AnatForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="166"/> + <CursorPos X="50" Y="175"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit33> + <Unit34> + <Filename Value="batchstatselect.pas"/> + <IsPartOfProject Value="True"/> + <CursorPos X="43" Y="6"/> + <UsageCount Value="201"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit34> + <Unit35> + <Filename Value="otsu2.pas"/> + <IsPartOfProject Value="True"/> + <CursorPos X="13" Y="98"/> + <UsageCount Value="210"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit35> + <Unit36> + <Filename Value="fastsmooth.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="16"/> + <CursorPos X="17" Y="28"/> + <UsageCount Value="210"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit36> + <Unit37> + <Filename Value="common\gzio2.pas"/> + <TopLine Value="111"/> + <CursorPos X="81" Y="119"/> + <UsageCount Value="21"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit37> + <Unit38> + <Filename Value="nii_label.pas"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="122"/> + <CursorPos X="55" Y="128"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit38> + <Unit39> + <Filename Value="common\nifti_types.pas"/> + <EditorIndex Value="2"/> + <WindowIndex Value="1"/> + <TopLine Value="135"/> + <CursorPos X="67" Y="146"/> + <UsageCount Value="73"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit39> + <Unit40> + <Filename Value="common\nifti_foreign.pas"/> + <WindowIndex Value="1"/> + <TopLine Value="886"/> + <CursorPos X="7" Y="886"/> + <UsageCount Value="21"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit40> + <Unit41> + <Filename Value="C:\usr\local\share\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/> + <TopLine Value="157"/> + <CursorPos X="38" Y="170"/> + <UsageCount Value="6"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit41> + <Unit42> + <Filename Value="C:\Developer\lazarus\lcl\include\customform.inc"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="2527"/> + <CursorPos Y="2536"/> + <UsageCount Value="12"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit42> + <Unit43> + <Filename Value="C:\Developer\lazarus\components\lazutils\ttgload.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="119"/> + <CursorPos X="77" Y="125"/> + <UsageCount Value="2"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit43> + <Unit44> + <Filename Value="isthreaded.inc"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <CursorPos X="18" Y="17"/> + <UsageCount Value="56"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit44> + <Unit45> + <Filename Value="..\..\..\..\..\Developer\lazarus\lcl\interfaces\cocoa\cocoawsstdctrls.pp"/> + <UnitName Value="CocoaWSStdCtrls"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="256"/> + <CursorPos X="32" Y="272"/> + <UsageCount Value="55"/> + </Unit45> + <Unit46> + <Filename Value="..\..\..\..\..\Developer\lazarus\lcl\interfaces\cocoa\cocoaint.pas"/> + <UnitName Value="CocoaInt"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="165"/> + <CursorPos X="42" Y="176"/> + <UsageCount Value="55"/> + </Unit46> + <Unit47> + <Filename Value="..\..\..\Desktop\c4\unit1.pas"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <UsageCount Value="36"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit47> + <Unit48> + <Filename Value="..\..\..\..\..\Developer\lazarus\lcl\lclintf.pas"/> + <UnitName Value="LCLIntf"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="60"/> + <CursorPos X="10" Y="72"/> + <UsageCount Value="6"/> + </Unit48> + <Unit49> + <Filename Value="..\..\..\..\..\Developer\lazarus\lcl\interfaces\cocoa\cocoawsmenus.pas"/> + <UnitName Value="CocoaWSMenus"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="46"/> + <CursorPos X="20" Y="56"/> + <UsageCount Value="10"/> + </Unit49> + <Unit50> + <Filename Value="..\raycast\shaderu.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="113"/> + <CursorPos X="19" Y="127"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit50> + <Unit51> + <Filename Value="..\raycast\shaderui.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="277"/> + <CursorPos X="24" Y="300"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit51> + <Unit52> + <Filename Value="reslice_img.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="329"/> + <CursorPos X="5" Y="333"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit52> + </Units> + <JumpHistory Count="5" HistoryIndex="4"> + <Position1> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="594" Column="71" TopLine="569"/> + </Position1> + <Position2> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="731" Column="80" TopLine="706"/> + </Position2> + <Position3> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="732" Column="52" TopLine="707"/> + </Position3> + <Position4> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="1754" Column="16" TopLine="1729"/> + </Position4> + <Position5> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="3157" Column="22" TopLine="3130"/> + </Position5> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="mricron"/> + </Target> + <SearchPaths> + <Libraries Value="rgb;fpmath"/> + <OtherUnitFiles Value="rgb;fpmath;common"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <SyntaxMode Value="Delphi"/> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <SmartLinkUnit Value="True"/> + <Optimizations> + <OptimizationLevel Value="2"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <WriteFPCLogo Value="False"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="2"> + <Item1> + <Name Value="ECodetoolError"/> + </Item1> + <Item2> + <Name Value="EFOpenError"/> + </Item2> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/backup/mricron.lpr.bak b/backup/mricron.lpr.bak new file mode 100755 index 0000000..f14f85f --- /dev/null +++ b/backup/mricron.lpr.bak @@ -0,0 +1,54 @@ +program mricron; + +{$mode objfpc}{$H+} +uses + {$IFDEF UNIX} + cthreads, + {$ENDIF} + Interfaces, + Forms, nifti_img_view, nifti_hdr_view, + about, Text, ReadInt, histoform, autoroi, ROIfilt, render, + MultiSlice, CropEdges, bet, mni, + voismooth, prefs, perisettings, graphx, cutout, ReadFloat, landmarks, +batchstatselect, nii_label; +{$IFNDEF UNIX} + {$IFDEF FPC} + {$R manifest.res} +{$ELSE} + {$R *.res}//windows icon + {$ENDIF} +{$ELSE} + {$R *.res} +{$ENDIF} + + + +{$IFDEF WINDOWS}{$R mricron.rc}{$ENDIF} + +begin + //Application.Title:='MRIcron'; + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TImgForm, ImgForm); + Application.CreateForm(THdrForm, HdrForm); + Application.CreateForm(TAnatForm, AnatForm); + Application.CreateForm(TAboutForm, AboutForm); + Application.CreateForm(TTextForm, TextForm); + Application.CreateForm(TReadIntForm, ReadIntForm); + Application.CreateForm(TAutoROIForm, AutoROIForm); + Application.CreateForm(THistogramForm, HistogramForm); + Application.CreateForm(TFilterROIform, FilterROIform); + Application.CreateForm(TMultiSliceForm, MultiSliceForm); + Application.CreateForm(TRenderForm, RenderForm); + Application.CreateForm(TCropEdgeForm, CropEdgeForm); + Application.CreateForm(TBETForm, BETForm); + Application.CreateForm(TMNIForm, MNIForm); + Application.CreateForm(Tvoismoothform, voismoothform); + Application.CreateForm(TPrefForm, PrefForm); + Application.CreateForm(TPSForm, PSForm); + Application.CreateForm(TGraph4DForm, Graph4DForm); + Application.CreateForm(TCutoutForm, CutoutForm); + Application.CreateForm(TReadFloatForm, ReadFloatForm); + Application.Run; +end. + diff --git a/backup/nifti_hdr_view.lfm.bak b/backup/nifti_hdr_view.lfm.bak new file mode 100755 index 0000000..78da5fa --- /dev/null +++ b/backup/nifti_hdr_view.lfm.bak @@ -0,0 +1,1410 @@ +object HdrForm: THdrForm + Left = 607 + Height = 383 + Top = 155 + Width = 560 + ActiveControl = PageControl1 + Caption = 'NIfTI Header Information' + ClientHeight = 383 + ClientWidth = 560 + Menu = MainMenu1 + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object PageControl1: TPageControl + Left = 4 + Height = 360 + Top = 4 + Width = 552 + ActivePage = TabSheet1 + Align = alClient + BorderSpacing.Left = 2 + BorderSpacing.Top = 2 + BorderSpacing.Right = 2 + BorderSpacing.Bottom = 2 + BorderSpacing.Around = 2 + TabIndex = 3 + TabOrder = 0 + OnChange = PageControl1Change + object TabRequired: TTabSheet + Caption = 'Dimensions' + ClientHeight = 321 + ClientWidth = 546 + OnContextPopup = TabRequiredContextPopup + object Label21: TLabel + Left = 6 + Height = 16 + Top = 6 + Width = 79 + Caption = 'Header Type' + ParentColor = False + end + object Label1: TLabel + Left = 14 + Height = 16 + Top = 35 + Width = 268 + Caption = 'Dimension Length Spacing Unit' + ParentColor = False + end + object Label2: TLabel + Left = 16 + Height = 16 + Top = 67 + Width = 44 + Caption = 'I Space' + ParentColor = False + end + object Label3: TLabel + Left = 16 + Height = 16 + Top = 97 + Width = 44 + Caption = 'J Space' + ParentColor = False + end + object Label4: TLabel + Left = 16 + Height = 16 + Top = 131 + Width = 49 + Caption = 'K Space' + ParentColor = False + end + object Label8: TLabel + Left = 6 + Height = 16 + Top = 297 + Width = 29 + Caption = 'Data' + ParentColor = False + end + object Label7: TLabel + Left = 294 + Height = 16 + Top = 235 + Width = 38 + Caption = 'Offset' + ParentColor = False + end + object Label44: TLabel + Left = 16 + Height = 16 + Top = 166 + Width = 31 + Caption = 'Time' + ParentColor = False + end + object Label29: TLabel + Left = 16 + Height = 16 + Top = 198 + Width = 51 + Caption = '5th Dim' + ParentColor = False + end + object Label41: TLabel + Left = 16 + Height = 16 + Top = 230 + Width = 51 + Caption = '6th Dim' + ParentColor = False + end + object Label42: TLabel + Left = 16 + Height = 16 + Top = 265 + Width = 51 + Caption = '7th Dim' + ParentColor = False + end + object HeaderMagicDrop: TComboBox + Left = 108 + Height = 20 + Top = 2 + Width = 239 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'ni1: NIfTI separate file (hdr+.img)' + 'n+1: NIfTI embedded (.nii)' + 'ni2: NIfTI2 separate file (hdr+.img)' + 'n+2: NIfTI2 embedded (.nii)' + ) + OnSelect = HeaderMagicDropSelect + Style = csDropDownList + TabOrder = 15 + end + object Endian: TComboBox + Left = 231 + Height = 20 + Top = 291 + Width = 210 + ItemHeight = 0 + Items.Strings = ( + 'Native Endian' + 'Swapped Endian' + ) + Style = csDropDownList + TabOrder = 16 + end + object fTypeDrop: TComboBox + Left = 56 + Height = 20 + Top = 291 + Width = 152 + DropDownCount = 20 + ItemHeight = 0 + Items.Strings = ( + 'binary' + '8-bit S' + '8-bit int U*' + '16-bit int S*' + '16-bit int U' + '32-bit int S*' + '32-bit int U' + '64-bit int S' + '64-bit int U' + '32-bit real*' + '64-bit real*' + '128-bit real' + '24-bit rgb' + '64-bit com' + '128-bit complex' + '256-bit complex' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 17 + end + object xyzt_sizeDrop: TComboBox + Left = 262 + Height = 20 + Top = 87 + Width = 128 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'Meter' + 'Millimeter' + 'Micrometer' + 'Micron' + ) + Style = csDropDownList + TabOrder = 18 + end + object xyzt_timeDrop: TComboBox + Left = 262 + Height = 20 + Top = 157 + Width = 128 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'Second' + 'Millisecond' + 'Microsecond' + 'Hertzsecond' + 'Part ' + 'Part per million' + ) + Style = csDropDownList + TabOrder = 19 + end + object Xdim: TSpinEdit + Left = 80 + Height = 16 + Top = 59 + Width = 74 + MaxValue = 9999 + MinValue = 1 + OnExit = ImageSzChange + TabOrder = 0 + Value = 2 + end + object Ydim: TSpinEdit + Left = 80 + Height = 16 + Top = 89 + Width = 74 + MaxValue = 9999 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 1 + Value = 2 + end + object Zdim: TSpinEdit + Left = 80 + Height = 16 + Top = 123 + Width = 74 + MaxValue = 9999 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 2 + Value = 1 + end + object Xmm: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 59 + Width = 74 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 10 + Value = 0 + end + object Ymm: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 89 + Width = 74 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 11 + Value = 0 + end + object Zmm: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 123 + Width = 74 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 12 + Value = 0 + end + object OffsetEdit: TSpinEdit + Left = 342 + Height = 16 + Top = 230 + Width = 94 + MaxValue = 999999 + OnExit = ImageSzChange + TabOrder = 14 + Value = 1 + end + object TDim: TSpinEdit + Left = 80 + Height = 16 + Top = 157 + Width = 74 + MaxValue = 9999 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 3 + Value = 1 + end + object TSec: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 157 + Width = 74 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 13 + Value = 0 + end + object Dim5Edit: TSpinEdit + Left = 80 + Height = 16 + Top = 191 + Width = 74 + MaxValue = 35000 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 4 + Value = 1 + end + object Dim6Edit: TSpinEdit + Left = 80 + Height = 16 + Top = 223 + Width = 74 + MaxValue = 35000 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 5 + Value = 1 + end + object Dim7Edit: TSpinEdit + Left = 80 + Height = 16 + Top = 258 + Width = 74 + MaxValue = 35000 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 9 + Value = 1 + end + object PixDim5: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 191 + Width = 74 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 6 + Value = 0 + end + object PixDim6: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 223 + Width = 74 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 7 + Value = 0 + end + object PixDim7: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 258 + Width = 74 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 8 + Value = 0 + end + end + object TabSheet4: TTabSheet + Caption = 'Reorient' + ClientHeight = 329 + ClientWidth = 528 + object Label24: TLabel + Left = 10 + Height = 18 + Top = 184 + Width = 9 + Caption = 'X' + ParentColor = False + end + object Label36: TLabel + Left = 10 + Height = 18 + Top = 218 + Width = 9 + Caption = 'Y' + ParentColor = False + end + object Label37: TLabel + Left = 10 + Height = 18 + Top = 251 + Width = 8 + Caption = 'Z' + ParentColor = False + end + object Label39: TLabel + Left = 10 + Height = 18 + Top = 123 + Width = 61 + Caption = 'Q Offsets' + ParentColor = False + end + object Label40: TLabel + Left = 10 + Height = 18 + Top = 86 + Width = 76 + Caption = 'Quaternions' + ParentColor = False + end + object Label46: TLabel + Left = 10 + Height = 18 + Top = 46 + Width = 109 + Caption = 'qFactor [1 or -1]' + ParentColor = False + end + object Label38: TLabel + Left = 4 + Height = 18 + Top = 9 + Width = 150 + Caption = 'Quaternion parameters ' + ParentColor = False + end + object Label47: TLabel + Left = 4 + Height = 18 + Top = 157 + Width = 118 + Caption = 'Affine parameters ' + ParentColor = False + end + object QFormDrop: TComboBox + Left = 150 + Height = 20 + Top = 5 + Width = 260 + ItemHeight = 0 + Items.Strings = ( + 'None' + 'Scanner Position' + 'Coregistrationon' + 'Normalized Tal' + 'Normalzied mni152ach' + 'Normalzied mni152' + ) + OnSelect = HeaderMagicDropSelect + Style = csDropDownList + TabOrder = 19 + end + object SFormDrop: TComboBox + Left = 145 + Height = 20 + Top = 150 + Width = 204 + ItemHeight = 0 + Items.Strings = ( + 'None' + 'Scanner Position' + 'Coregistrationon' + 'Normalized Tal' + 'Normalzied mni152ach' + 'Normalzied mni152' + ) + OnSelect = HeaderMagicDropSelect + Style = csDropDownList + TabOrder = 20 + end + object srow_x0Edit: TFloatSpinEdit + Left = 34 + Height = 16 + Top = 188 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 7 + Value = 1 + end + object srow_x1Edit: TFloatSpinEdit + Left = 142 + Height = 16 + Top = 188 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 8 + Value = 1 + end + object srow_x2Edit: TFloatSpinEdit + Left = 254 + Height = 16 + Top = 188 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 9 + Value = 1 + end + object srow_y0Edit: TFloatSpinEdit + Left = 34 + Height = 16 + Top = 222 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 11 + Value = 1 + end + object srow_y1Edit: TFloatSpinEdit + Left = 142 + Height = 16 + Top = 222 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 12 + Value = 1 + end + object srow_y2Edit: TFloatSpinEdit + Left = 254 + Height = 16 + Top = 222 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 13 + Value = 1 + end + object srow_z0Edit: TFloatSpinEdit + Left = 34 + Height = 16 + Top = 255 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 15 + Value = 1 + end + object srow_z1Edit: TFloatSpinEdit + Left = 142 + Height = 16 + Top = 255 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 16 + Value = 1 + end + object srow_z2Edit: TFloatSpinEdit + Left = 254 + Height = 16 + Top = 255 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 17 + Value = 1 + end + object srow_x3Edit: TFloatSpinEdit + Left = 366 + Height = 16 + Top = 188 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 10 + Value = 1 + end + object srow_y3Edit: TFloatSpinEdit + Left = 366 + Height = 16 + Top = 222 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 14 + Value = 1 + end + object srow_z3Edit: TFloatSpinEdit + Left = 366 + Height = 16 + Top = 255 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 18 + Value = 1 + end + object quatern_bEdit: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 84 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 1 + Value = 1 + end + object quatern_cEdit: TFloatSpinEdit + Left = 212 + Height = 16 + Top = 84 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 2 + Value = 1 + end + object quatern_dEdit: TFloatSpinEdit + Left = 332 + Height = 16 + Top = 84 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 3 + Value = 1 + end + object qoffset_xEdit: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 117 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 4 + Value = 1 + end + object qoffset_yEdit: TFloatSpinEdit + Left = 212 + Height = 16 + Top = 117 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 5 + Value = 1 + end + object qoffset_zEdit: TFloatSpinEdit + Left = 332 + Height = 16 + Top = 117 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 6 + Value = 1 + end + object QFacEdit: TFloatSpinEdit + Left = 140 + Height = 16 + Top = 46 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 1 + MinValue = -1 + TabOrder = 0 + Value = 1 + end + end + object TabSheet3: TTabSheet + Caption = 'Image Intensity' + ClientHeight = 321 + ClientWidth = 546 + object Label12: TLabel + Left = 24 + Height = 16 + Top = 163 + Width = 62 + Caption = 'Maximum' + ParentColor = False + end + object Label13: TLabel + Left = 24 + Height = 16 + Top = 129 + Width = 59 + Caption = 'Minimum' + ParentColor = False + end + object Label23: TLabel + Left = 24 + Height = 16 + Top = 28 + Width = 34 + Caption = 'Slope' + ParentColor = False + end + object Label22: TLabel + Left = 24 + Height = 16 + Top = 64 + Width = 56 + Caption = 'Intercept' + ParentColor = False + end + object Label30: TLabel + Left = 6 + Height = 16 + Top = 4 + Width = 118 + Caption = 'Calibration Scaling' + ParentColor = False + end + object Label33: TLabel + Left = 6 + Height = 16 + Top = 103 + Width = 199 + Caption = 'Display Range (calibrated units)' + ParentColor = False + end + object cmax: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 165 + Width = 110 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 3 + Value = 0 + end + object cmin: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 129 + Width = 110 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 2 + Value = 0 + end + object Scale: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 28 + Width = 110 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 0 + Value = 0 + end + object Intercept: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 64 + Width = 110 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 1 + Value = 0 + end + end + object TabSheet1: TTabSheet + Caption = 'Statistics' + ClientHeight = 321 + ClientWidth = 546 + object Label35: TLabel + Left = 8 + Height = 16 + Top = 14 + Width = 57 + Caption = 'Intention' + ParentColor = False + end + object Label25: TLabel + Left = 24 + Height = 16 + Top = 46 + Width = 76 + Caption = 'Parameter 1' + ParentColor = False + end + object Label27: TLabel + Left = 24 + Height = 16 + Top = 83 + Width = 76 + Caption = 'Parameter 2' + ParentColor = False + end + object Label28: TLabel + Left = 24 + Height = 16 + Top = 118 + Width = 76 + Caption = 'Parameter 3' + ParentColor = False + end + object IntentCodeDrop: TComboBox + Left = 76 + Height = 20 + Top = 8 + Width = 218 + DropDownCount = 44 + ItemHeight = 0 + Items.Strings = ( + 'Not statistics' + 'Correlation coefficient ' + 'T-testation coefficient ' + 'F-test' + 'Z-score' + 'Chi-squared' + 'Beta distribution' + 'Binomial distribution' + 'Gamma distribution' + 'Poisson distribution' + 'Normal distribution' + 'Noncentral F statistic' + 'Noncentral chi-squared' + 'Logistic distributiond statistic' + 'Laplace distribution' + 'Uniform distribution' + 'Noncentral t statistic' + 'Weibull distribution' + 'Chi distribution' + 'Inverse Gaussian ' + 'Extreme value type I' + 'p-value value type I' + 'ln(p-value)' + 'log10(p-value)' + 'Estimate' + 'Labels' + 'NeuroN' + 'Generic M' + 'Symmetric Matrix' + 'Displacement Field/Vector' + 'Vectorcement Field/Vector' + 'Points' + 'Triangle (mesh)' + 'Quaternion' + '' + '' + '' + ) + Style = csDropDownList + TabOrder = 3 + end + object intent_p1Edit: TFloatSpinEdit + Left = 110 + Height = 16 + Top = 46 + Width = 138 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 0 + Value = 0 + end + object intent_p2Edit: TFloatSpinEdit + Left = 110 + Height = 16 + Top = 83 + Width = 138 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 1 + Value = 0 + end + object intent_p3Edit: TFloatSpinEdit + Left = 110 + Height = 16 + Top = 119 + Width = 138 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 2 + Value = 0 + end + object EcodeLabel: TLabel + Left = 8 + Height = 16 + Top = 144 + Width = 72 + Caption = 'ECode Text' + ParentColor = False + end + object EcodeMemo: TMemo + Left = 0 + Height = 194 + Top = 127 + Width = 546 + Align = alBottom + ScrollBars = ssVertical + TabOrder = 4 + end + object NoECodeLabel: TLabel + Left = 24 + Height = 16 + Top = 192 + Width = 158 + Caption = 'No ECode Text In Header' + ParentColor = False + end + end + object TabSheet2: TTabSheet + Caption = 'fMRI' + ClientHeight = 356 + ClientWidth = 528 + object Label11: TLabel + Left = 12 + Height = 17 + Top = 145 + Width = 68 + Caption = 'Slice Order' + ParentColor = False + end + object Label16: TLabel + Left = 12 + Height = 17 + Top = 8 + Width = 74 + Caption = 'Time Offset' + ParentColor = False + end + object Label17: TLabel + Left = 14 + Height = 17 + Top = 39 + Width = 85 + Caption = 'Slice duration' + ParentColor = False + end + object Label32: TLabel + Left = 12 + Height = 17 + Top = 74 + Width = 65 + Caption = 'Slice Start' + ParentColor = False + end + object Label20: TLabel + Left = 12 + Height = 17 + Top = 105 + Width = 56 + Caption = 'Slice End' + ParentColor = False + end + object Label31: TLabel + Left = 12 + Height = 17 + Top = 178 + Width = 133 + Caption = 'Frequency Dimension' + ParentColor = False + end + object Label43: TLabel + Left = 12 + Height = 17 + Top = 214 + Width = 105 + Caption = 'Phase Dimension' + ParentColor = False + end + object Label45: TLabel + Left = 12 + Height = 17 + Top = 250 + Width = 97 + Caption = 'Slice Dimension' + ParentColor = False + end + object SliceCodeDrop: TComboBox + Left = 87 + Height = 20 + Top = 137 + Width = 274 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'Sequential Increasing (1 2 3 4)' + 'Sequential Decreasing (4 3 2 1)' + 'Interleaved Increasing (1 3 2 4)' + 'Interleaved Decreasing (4 2 3 1)' + 'Interleaved Increasing2 (2 4 1 3)' + 'Interleaved Decreasing2 (3 1 4 2)' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 4 + end + object FreqDimDrop: TComboBox + Left = 146 + Height = 20 + Top = 174 + Width = 215 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'I' + 'J' + 'K' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 5 + end + object PhaseDimDrop: TComboBox + Left = 146 + Height = 20 + Top = 210 + Width = 215 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'I' + 'J' + 'K' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 6 + end + object SliceDimDrop: TComboBox + Left = 146 + Height = 20 + Top = 246 + Width = 215 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'I' + 'J' + 'K' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 7 + end + object slice_startEdit: TSpinEdit + Left = 120 + Height = 16 + Top = 73 + Width = 112 + TabOrder = 2 + Value = 1 + end + object Slice_durationEdit: TFloatSpinEdit + Left = 120 + Height = 16 + Top = 38 + Width = 112 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 1 + Value = 1 + end + object toffsetEdit: TFloatSpinEdit + Left = 120 + Height = 16 + Top = 7 + Width = 112 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 0 + Value = 1 + end + object slice_endEdit: TSpinEdit + Left = 120 + Height = 16 + Top = 104 + Width = 112 + TabOrder = 3 + Value = 1 + end + end + object TabUnused: TTabSheet + Caption = 'Optional' + ClientHeight = 337 + ClientWidth = 738 + object Label34: TLabel + Left = 3 + Height = 16 + Top = 43 + Width = 64 + Caption = 'Data Type' + ParentColor = False + end + object Label5: TLabel + Left = 3 + Height = 16 + Top = 8 + Width = 57 + Caption = 'Intention' + ParentColor = False + end + object Label6: TLabel + Left = 268 + Height = 16 + Top = 116 + Width = 47 + Caption = 'Extents' + ParentColor = False + end + object Label9: TLabel + Left = 268 + Height = 16 + Top = 76 + Width = 76 + Caption = 'Sesion Error' + ParentColor = False + end + object Label10: TLabel + Left = 268 + Height = 16 + Top = 148 + Width = 85 + Caption = 'Regular [114]' + ParentColor = False + end + object Label14: TLabel + Left = 268 + Height = 16 + Top = 8 + Width = 37 + Caption = 'G Min' + ParentColor = False + end + object Label15: TLabel + Left = 268 + Height = 16 + Top = 43 + Width = 40 + Caption = 'G Max' + ParentColor = False + end + object Label18: TLabel + Left = 3 + Height = 16 + Top = 148 + Width = 51 + Caption = 'Aux File' + ParentColor = False + end + object Label19: TLabel + Left = 3 + Height = 16 + Top = 111 + Width = 57 + Caption = 'DB Name' + ParentColor = False + end + object Label26: TLabel + Left = 3 + Height = 16 + Top = 76 + Width = 36 + Caption = 'Notes' + ParentColor = False + end + object intent_nameEdit: TEdit + Left = 76 + Height = 22 + Top = 6 + Width = 152 + MaxLength = 16 + TabOrder = 0 + Text = 'intent_name' + end + object data_typeEdit: TEdit + Left = 76 + Height = 22 + Top = 41 + Width = 152 + MaxLength = 10 + TabOrder = 1 + Text = 'data_type' + end + object CommentEdit: TEdit + Left = 76 + Height = 22 + Top = 74 + Width = 152 + MaxLength = 80 + TabOrder = 2 + Text = 'CommentEdit' + end + object db_: TEdit + Left = 76 + Height = 22 + Top = 109 + Width = 152 + MaxLength = 18 + TabOrder = 3 + Text = 'db_' + end + object aux: TEdit + Left = 76 + Height = 22 + Top = 148 + Width = 152 + MaxLength = 24 + TabOrder = 4 + Text = 'aux' + end + object gmax: TSpinEdit + Left = 366 + Height = 16 + Top = 44 + Width = 66 + TabOrder = 6 + Value = 1 + end + object gmin: TSpinEdit + Left = 366 + Height = 16 + Top = 9 + Width = 66 + TabOrder = 5 + Value = 1 + end + object ses: TSpinEdit + Left = 366 + Height = 16 + Top = 77 + Width = 66 + TabOrder = 7 + Value = 1 + end + object ext: TSpinEdit + Left = 366 + Height = 16 + Top = 117 + Width = 66 + TabOrder = 8 + Value = 1 + end + object reg: TSpinEdit + Left = 366 + Height = 16 + Top = 151 + Width = 66 + MaxValue = 255 + TabOrder = 9 + Value = 1 + end + end + end + object StatusBar1: TStatusBar + Left = 0 + Height = 15 + Top = 368 + Width = 560 + AutoSize = False + Constraints.MaxHeight = 15 + Panels = < + item + Width = 140 + end + item + Width = 50 + end> + SimplePanel = False + end + object MainMenu1: TMainMenu + left = 424 + top = 72 + object File1: TMenuItem + Caption = '&File' + object Open1: TMenuItem + Caption = 'Open header' + ShortCut = 16463 + OnClick = Open1Click + end + object Save1: TMenuItem + Caption = 'Save header' + ShortCut = 16467 + OnClick = Save1Click + end + object Exit1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Exit1Click + end + end + object Page1: TMenuItem + Caption = '&Tab' + object Dimensions1: TMenuItem + Caption = 'Dimensions' + ShortCut = 16449 + OnClick = TabMenuClick + end + object Rotations1: TMenuItem + Tag = 1 + Caption = 'Reorient' + ShortCut = 16450 + OnClick = TabMenuClick + end + object ImageIntensity1: TMenuItem + Tag = 2 + Caption = 'Image Intensity' + ShortCut = 16457 + OnClick = TabMenuClick + end + object Statistics1: TMenuItem + Tag = 3 + Caption = 'Statistics' + ShortCut = 16452 + OnClick = TabMenuClick + end + object FunctionalMRI1: TMenuItem + Tag = 4 + Caption = 'Functional MRI' + ShortCut = 16453 + OnClick = TabMenuClick + end + object Optional1: TMenuItem + Tag = 5 + Caption = 'Optional' + ShortCut = 16454 + OnClick = TabMenuClick + end + end + end + object OpenHdrDlg: TOpenDialog + FilterIndex = 0 + Options = [ofFileMustExist] + left = 456 + top = 72 + end + object SaveHdrDlg: TSaveDialog + OnClose = SaveHdrDlgClose + Width = 52 + Filter = 'NIfTI embedded header (*.nii)|*.nii|NIfTI separate header (*.hdr)|*.hdr' + FilterIndex = 0 + left = 496 + top = 72 + end +end diff --git a/backup/nifti_hdr_view.pas.bak b/backup/nifti_hdr_view.pas.bak new file mode 100755 index 0000000..ae3843a --- /dev/null +++ b/backup/nifti_hdr_view.pas.bak @@ -0,0 +1,753 @@ +unit nifti_hdr_view; +interface +{$H+} +{$MODE DELPHI} +uses +{$IFNDEF FPC} + RXSpin,capmenu, +{$ELSE} +LResources, Spin, + +{$ENDIF} +{$IFNDEF Unix} ShellAPI, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, nifti_hdr, Menus, ComCtrls, Buttons, define_types, nifti_types; +type + { THdrForm } + THdrForm = class(TForm) + EcodeLabel: TLabel; + EcodeMemo: TMemo; + NoECodeLabel: TLabel; + Ymm: TFloatSpinEdit; + MainMenu1: TMainMenu; + File1: TMenuItem; + Open1: TMenuItem; + Exit1: TMenuItem; + Save1: TMenuItem; + OpenHdrDlg: TOpenDialog; + SaveHdrDlg: TSaveDialog; + PageControl1: TPageControl; + TabRequired: TTabSheet; + TabUnused: TTabSheet; + intent_nameEdit: TEdit; + data_typeEdit: TEdit; + CommentEdit: TEdit; + db_: TEdit; + aux: TEdit; + gmax: TSpinEdit; + gmin: TSpinEdit; + ses: TSpinEdit; + ext: TSpinEdit; + reg: TSpinEdit; + Label34: TLabel; + Label5: TLabel; + Label6: TLabel; + Label9: TLabel; + Label10: TLabel; + Label14: TLabel; + Label15: TLabel; + Label18: TLabel; + Label19: TLabel; + Label26: TLabel; + HeaderMagicDrop: TComboBox; + Label21: TLabel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + Label8: TLabel; + Label7: TLabel; + Endian: TComboBox; + fTypeDrop: TComboBox; + Label44: TLabel; + xyzt_sizeDrop: TComboBox; + xyzt_timeDrop: TComboBox; + Xdim: TSpinEdit; + Ydim: TSpinEdit; + Zdim: TSpinEdit; + Zmm: TFloatSpinEdit; + OffsetEdit: TSpinEdit; + TDim: TSpinEdit; + Xmm: TFloatSpinEdit; + TSec: TFloatSpinEdit; + StatusBar1: TStatusBar; + Label29: TLabel; + Dim5Edit: TSpinEdit; + TabSheet1: TTabSheet; + Label35: TLabel; + IntentCodeDrop: TComboBox; + intent_p1Edit: TFloatSpinEdit; + intent_p2Edit: TFloatSpinEdit; + intent_p3Edit: TFloatSpinEdit; + Label25: TLabel; + Label27: TLabel; + Label28: TLabel; + TabSheet2: TTabSheet; + Label11: TLabel; + Label16: TLabel; + Label17: TLabel; + Label32: TLabel; + slice_startEdit: TSpinEdit; + Slice_durationEdit: TFloatSpinEdit; + toffsetEdit: TFloatSpinEdit; + TabSheet3: TTabSheet; + cmax: TFloatSpinEdit; + cmin: TFloatSpinEdit; + Label12: TLabel; + Label13: TLabel; + Scale: TFloatSpinEdit; + Label23: TLabel; + Intercept: TFloatSpinEdit; + Label22: TLabel; + Label30: TLabel; + Label33: TLabel; + Page1: TMenuItem; + Dimensions1: TMenuItem; + ImageIntensity1: TMenuItem; + Statistics1: TMenuItem; + FunctionalMRI1: TMenuItem; + Optional1: TMenuItem; + TabSheet4: TTabSheet; + Rotations1: TMenuItem; + srow_x0Edit: TFloatSpinEdit; + srow_x1Edit: TFloatSpinEdit; + srow_x2Edit: TFloatSpinEdit; + Label24: TLabel; + Label36: TLabel; + Label37: TLabel; + srow_y0Edit: TFloatSpinEdit; + srow_y1Edit: TFloatSpinEdit; + srow_y2Edit: TFloatSpinEdit; + srow_z0Edit: TFloatSpinEdit; + srow_z1Edit: TFloatSpinEdit; + srow_z2Edit: TFloatSpinEdit; + srow_x3Edit: TFloatSpinEdit; + srow_y3Edit: TFloatSpinEdit; + srow_z3Edit: TFloatSpinEdit; + quatern_bEdit: TFloatSpinEdit; + quatern_cEdit: TFloatSpinEdit; + quatern_dEdit: TFloatSpinEdit; + qoffset_xEdit: TFloatSpinEdit; + qoffset_yEdit: TFloatSpinEdit; + qoffset_zEdit: TFloatSpinEdit; + Label39: TLabel; + Label40: TLabel; + Label41: TLabel; + Dim6Edit: TSpinEdit; + Label42: TLabel; + Dim7Edit: TSpinEdit; + PixDim5: TFloatSpinEdit; + PixDim6: TFloatSpinEdit; + PixDim7: TFloatSpinEdit; + SliceCodeDrop: TComboBox; + Label20: TLabel; + slice_endEdit: TSpinEdit; + FreqDimDrop: TComboBox; + PhaseDimDrop: TComboBox; + SliceDimDrop: TComboBox; + Label31: TLabel; + Label43: TLabel; + Label45: TLabel; + QFacEdit: TFloatSpinEdit; + Label46: TLabel; + QFormDrop: TComboBox; + SFormDrop: TComboBox; + Label38: TLabel; + Label47: TLabel; + procedure FormShow(Sender: TObject); + procedure PageControl1Change(Sender: TObject); + procedure SaveHdrDlgClose(Sender: TObject); + procedure TabRequiredContextPopup(Sender: TObject; MousePos: TPoint; + var Handled: Boolean); + procedure WriteHdrForm (var lHdr: TMRIcroHdr); + procedure ReadHdrDimensionsOnly (var lHdr: TMRIcroHdr); //reads only size dimensions: useful for computing estimated filesize + procedure ReadHdrForm (var lHdr: TMRIcroHdr); //reads entire header + procedure Open1Click(Sender: TObject); + procedure Save1Click(Sender: TObject); + procedure TabMenuClick(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure ImageSzChange(Sender: TObject); + procedure HeaderMagicDropSelect(Sender: TObject); + function OpenAndDisplayHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + private + { Private declarations } +{$IFNDEF FPC} procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES; +{$ENDIF} + public + { Public declarations } + end; + function OpenDialogExecute (lFilter,lCaption: string; lAllowMultiSelect: boolean): boolean; + +var + HdrForm: THdrForm; + +implementation + +uses nifti_img_view, render,nifti_img; +{$IFDEF FPC} +{$R *.lfm} +{$ELSE} +{$R *.DFM} +{$ENDIF} + +function OpenDialogExecute (lFilter,lCaption: string; lAllowMultiSelect: boolean): boolean; +begin + HdrForm.OpenHdrDlg.Filter := lFilter; + HdrForm.OpenHdrDlg.FilterIndex := 1; + HdrForm.OpenHdrDlg.Title := lCaption; + if lAllowMultiSelect then + HdrForm.OpenHdrDlg.Options := [ofAllowMultiSelect,ofFileMustExist]; + result := HdrForm.OpenHdrDlg.Execute; + HdrForm.OpenHdrDlg.Options := [ofFileMustExist]; +end; + +function DropItem2DataType(lItemIndex: integer): integer; //returns NIfTI datatype number +begin + case lItemIndex of + 0: result :=1; //binary + 1 : result := 256; //8-bit S + 2 : result := 2; //8-bit int U* + 3 : result := 4; //16-bit int S* + 4 : result := 512; //16-bit int U + 5 : result := 8; //32-bit int S* + 6 : result := 768; //32-bit int U + 7: result := 1024; //64-bit int S + 8: result := 1280; //64-bit int U + 9: result := 16; //32-bit real* + 10: result := 64; //64-bit real* + 11: result := 1536; //128-bit real + 12: result := 128; //24-bit rgb + 13: result := 32; //64-bit complex + 14: result := 1792; //128-bit complex + 15: result := 2048; //256-bit complex + else + result := 0; + end; //case +end; //func DropItem2DataType + +function DataType2DropItem (lDataType: smallint): integer; +begin + case lDataType of + 1: result := 0; //binary + 256: result := 1; //8-bit S + 2: result := 2; //8-bit int U* + 4: result := 3; //16-bit int S* + 512: result := 4; //16-bit int U + 8: result := 5; //32-bit int S* + 768: result := 6; //32-bit int U + 1024: result := 7; //64-bit int S + 1280: result := 8; //64-bit int U + 16: result := 9; //32-bit real* + 64: result := 10; //64-bit real* + 1536: result := 11; //128-bit real + 128: result := 12; //24-bit rgb + 32: result := 13; //64-bit complex + 1792: result := 14; //128-bit complex + 2048: result := 15; //256-bit complex + else + result := 0; + end; //case +end; //func DataType2DropItem + +function DataType2BitsPerVoxel (lDataType: smallint): integer; +begin + case lDataType of + 1: result := 1; //binary + 256: result := 8; //8-bit S + 2: result := 8; //8-bit int U* + 4: result := 16; //16-bit int S* + 512: result := 16; //16-bit int U + 8: result := 32; //32-bit int S* + 768: result := 32; //32-bit int U + 1024: result := 64; //64-bit int S + 1280: result := 64; //64-bit int U + 16: result := 32; //32-bit real* + 64: result := 64; //64-bit real* + 1536: result := 128; //128-bit real + 128: result := 24; //24-bit rgb + 32: result := 64; //64-bit complex + 1792: result := 128; //128-bit complex + 2048: result := 256; //256-bit complex + else + result := 0; + end; //case +end; //func DataType2BitsPerVoxel + +function time_units2DropItem (lxyzt_units: byte): integer; +var lxyzt_unitsClipped: byte; +begin + lxyzt_unitsClipped := lxyzt_units and 56; + case lxyzt_unitsClipped of + kNIFTI_UNITS_SEC : result := 1;//= 8; + kNIFTI_UNITS_MSEC : result := 2;//= 16; + kNIFTI_UNITS_USEC : result := 3;//= 24; + kNIFTI_UNITS_HZ : result := 4;//= 32; + kNIFTI_UNITS_PPM : result := 5;//= 40; + else result := 0; //unknown + end; //case +end; //func time_units2DropItem + +function DropItem2time_units (lDropItemIndex: byte): integer; //convert ComboBox index to NIFTI time units +begin + case lDropItemIndex of + 1: result := kNIFTI_UNITS_SEC; + 2: result := kNIFTI_UNITS_MSEC; + 3: result := kNIFTI_UNITS_USEC; + 4: result := kNIFTI_UNITS_HZ; + 5: result := kNIFTI_UNITS_PPM; + else result := 0; //unknown + end; //case +end; //func DropItem2time_units + +procedure THdrForm.WriteHdrForm (var lHdr: TMRIcroHdr); //writes a header to the various controls +var //lCStr: string[80]; + lInc: Integer; + s: string; +begin + with lHdr.NIFTIhdr do begin + //numDimEdit.value := dim[0]; + XDim.Value := dim[1]; + YDim.Value := dim[2]; + ZDim.Value := dim[3]; + TDim.Value := dim[4]; + Dim5Edit.value := dim[5]; + Dim6Edit.value := dim[6]; + Dim7Edit.value := dim[7]; + Xmm.Value := pixdim[1]; + Ymm.Value := pixdim[2]; + Zmm.Value := pixdim[3]; + TSec.Value := pixdim[4]; + PixDim5.value := pixdim[5]; + PixDim6.value := pixdim[6]; + PixDim7.value := pixdim[7]; + OffsetEdit.value := round(vox_offset); + Scale.value := scl_slope; + Intercept.value := scl_inter; + {$IFNDEF FPC} + fTypeDrop.SetItemIndex( DataType2DropItem( datatype)); + if lHdr.NativeEndian then + Endian.SetItemIndex(0) + else + Endian.SetItemIndex(1); + //caption := inttohex(Magic); + if Magic = kNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.SetItemIndex(2) + else if Magic = kNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.SetItemIndex(1) + else if Magic = kswapNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.SetItemIndex(2) + else if Magic = kswapNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.SetItemIndex(1) + else + HeaderMagicDrop.SetItemIndex(0); + xyzt_sizeDrop.SetItemIndex(xyzt_units and 3); + xyzt_timeDrop.SetItemIndex(time_units2DropItem(xyzt_units)); + {$ELSE} + fTypeDrop.ItemIndex := ( DataType2DropItem( datatype)); + if lHdr.DiskDataNativeEndian then + Endian.ItemIndex:=(0) + else + Endian.ItemIndex:=(1); + if Magic = kNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.ItemIndex:=(2) + else if Magic = kNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.ItemIndex:=(1) + else if Magic = kswapNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.ItemIndex:=(2) + else if Magic = kswapNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.ItemIndex:=(1) + else + HeaderMagicDrop.ItemIndex:=(0); + xyzt_sizeDrop.ItemIndex:=(xyzt_units and 3); + xyzt_timeDrop.ItemIndex:=(time_units2DropItem(xyzt_units)); + {$ENDIF} + + CommentEdit.text := descrip; + data_typeEdit.text := data_type; + db_.text := db_name; + aux.text := aux_file; + intent_nameEdit.text := intent_name; + ext.value := extents; + lInc := intent_code; + if (intent_code > 1) and (intent_code <= kNIFTI_LAST_STATCODE) then + lInc := lInc - 1 //intent_codes start from 2 not 1 + else if intent_code >= kNIFTI_FIRST_NONSTATCODE then //remove gap in numbers that follow final statcode + lInc := (intent_code - kNIFTI_FIRST_NONSTATCODE)+kNIFTI_LAST_STATCODE + else begin + lInc := 0; //unknown + end; + {$IFNDEF FPC} + IntentCodeDrop .SetItemIndex(lInc); + SliceCodeDrop.SetItemIndex(slice_code); + FreqDimDrop.SetItemIndex(dim_info and 3); + PhaseDimDrop.SetItemIndex((dim_info shr 2) and 3); + SliceDimDrop.SetItemIndex((dim_info shr 4) and 3); + {$ELSE} + IntentCodeDrop.ItemIndex:=lInc; + SliceCodeDrop.ItemIndex:=(slice_code); + FreqDimDrop.ItemIndex:=(dim_info and 3); + PhaseDimDrop.ItemIndex:=((dim_info shr 2) and 3); + SliceDimDrop.ItemIndex:=((dim_info shr 4) and 3); + {$ENDIF} + intent_p1Edit.value := intent_p1; + intent_p2Edit.value := intent_p2; + intent_p3Edit.value := intent_p3; + ses.value := session_error; + reg.value := ord(regular); + slice_startEdit.value := slice_start; + slice_endEdit.value := slice_end; + cmax.value := cal_max; + cmin.value := cal_min; + slice_durationEdit.value := slice_duration; + toffsetEdit.value := toffset; + gmax.value := glmax; + gmin.value := glmin; + //Next: 3D orientation rotations + QFacEdit.value := pixdim[0]; + {$IFNDEF FPC} + QFormDrop.SetItemIndex(qform_code); + SFormDrop.SetItemIndex(sform_code); + {$ELSE} + QFormDrop.ItemIndex:= (qform_code); + SFormDrop.ItemIndex :=(sform_code); + {$ENDIF} + + quatern_bEdit.value := quatern_b; + quatern_cEdit.value := quatern_c; + quatern_dEdit.value := quatern_d; + qoffset_xEdit.value := qoffset_x; + qoffset_yEdit.value := qoffset_y; + qoffset_zEdit.value := qoffset_z; + srow_x0Edit.value := srow_x[0];//12 affine matrix values + srow_x1Edit.value := srow_x[1]; + srow_x2Edit.value := srow_x[2]; + srow_x3Edit.value := srow_x[3]; + srow_y0Edit.value := srow_y[0]; + srow_y1Edit.value := srow_y[1]; + srow_y2Edit.value := srow_y[2]; + srow_y3Edit.value := srow_y[3]; + srow_z0Edit.value := srow_z[0]; + srow_z1Edit.value := srow_z[1]; + srow_z2Edit.value := srow_z[2]; + srow_z3Edit.value := srow_z[3]; + //Finally... check values + HeaderMagicDropSelect(nil); //disable or enable offset based on image format + //showmessage(lHdr.ECodeText); + if length(lHdr.ECodeText) > 0 then begin + s := lHdr.ECodeText; + s := StringReplace(s, chr (0), '',[rfReplaceAll, rfIgnoreCase]); + s := AdjustLineBreaks(s);//, tlbsLF); + EcodeMemo.Lines.Text:= s; + EcodeMemo.Visible := true; + end else + EcodeMemo.Visible := false; + + end; //with lHdr +end; + +(*procedure ApplySaveDlgFilter (lSaveDlg: TSaveDialog); +var + lLen,lPos,lPipes,lPipesReq: integer; + lExt: string; +begin + lPipesReq := (lSaveDlg.FilterIndex * 2)-1; + if lPipesReq < 1 then exit; + lLen := length(lSaveDlg.Filter); + lPos := 1; + lPipes := 0; + while (lPos < lLen) and (lPipes < lPipesReq) do begin + if lSaveDlg.Filter[lPos] = '|' then + inc(lPipes); + inc(lPos); + end; + if (lPos >= lLen) or (lPipes < lPipesReq) then + exit; + lExt := ''; + while (lPos <= lLen) and (lSaveDlg.Filter[lPos] <> '|') do begin + if lSaveDlg.Filter[lPos] <> '*' then + lExt := lExt + lSaveDlg.Filter[lPos]; + inc(lPos); + end; + if lExt <> '' then + lSaveDlg.Filename := ChangeFileExt(lSaveDlg.Filename,lExt); +end; *) + +procedure THdrForm.SaveHdrDlgClose(Sender: TObject); +begin + //ApplySaveDlgFilter(SaveHdrDlg); +end; + + + +procedure THdrForm.TabRequiredContextPopup(Sender: TObject; MousePos: TPoint; + var Handled: Boolean); +begin + +end; + +procedure THdrForm.FormShow(Sender: TObject); +begin + // ImgForm.OnLaunch; +end; + + +procedure THdrForm.PageControl1Change(Sender: TObject); +begin + +end; + +procedure THdrForm.ReadHdrDimensionsOnly (var lHdr: TMRIcroHdr); //reads only size dimensions: useful for computing estimated filesize +var + lInc: Integer; +begin + with lHdr.NIFTIhdr do begin + dim[1] := round(XDim.Value); + dim[2] := round(YDim.Value); + dim[3] := round(ZDim.Value); + dim[4] := round(TDim.Value); + dim[5] := round(Dim5Edit.value); + dim[6] := round(Dim6Edit.value); + dim[7] := round(Dim7Edit.value); + //Next: compute Dim[0]: compute number of dimensions by finding largest dimension with at least two samples + lInc := 7; + while dim[lInc] < 2 do + dec(lInc); + Dim[0] := lInc; //comp + //showmessage(inttostr(Dim[0])); + vox_offset := OffsetEdit.value; + DataType := DropItem2DataType(FTypeDrop.ItemIndex); + bitpix := DataType2BitsPerVoxel(DataType); + if Endian.ItemIndex = 0 then + lHdr.DiskDataNativeEndian := true + else + lHdr.DiskDataNativeEndian := false; + end; //with NIfTIhdr +end; //proc ReadHdrDimensionsOnly + +procedure THdrForm.ReadHdrForm (var lHdr: TMRIcroHdr); //read the values the user has entered +var + lInc: Integer; +begin + NIFTIhdr_ClearHdr(lHdr); //important: reset values like first 4 bytes = 348 + ReadHdrDimensionsOnly(lHdr); + //StatusBar1.Panels[0].text := 'ImageData (bytes)= '+inttostr(ComputeImageDataBytes(lHdr)); + with lHdr.NIFTIhdr do begin + pixdim[1] := Xmm.Value; + pixdim[2] := Ymm.Value; + pixdim[3] := Zmm.Value; + pixdim[4] := TSec.Value; + pixdim[5] := PixDim5.Value; + pixdim[6] := PixDim6.Value; + pixdim[7] := PixDim7.Value; + scl_slope := Scale.value; + scl_inter := Intercept.value; + if HeaderMagicDrop.ItemIndex = 2 then + Magic := kNIFTI_MAGIC_EMBEDDED_HDR + else if HeaderMagicDrop.ItemIndex = 1 then + Magic := kNIFTI_MAGIC_SEPARATE_HDR + else + Magic := 0; //not saed as NIFTI + for lInc := 1 to 80 do + descrip[lInc] := chr(0); + for lInc := 1 to length(CommentEdit.text) do + descrip[lInc] := CommentEdit.text[lInc]; + for lInc := 1 to 10 do + data_type[lInc] := chr(0); + for lInc := 1 to length(data_typeEdit.text) do + data_type[lInc] := data_typeEdit.text[lInc]; + for lInc := 1 to 18 do + db_name[lInc] := chr(0); + for lInc := 1 to length(db_.text) do + db_name[lInc] := db_.text[lInc]; + for lInc := 1 to 24 do + aux_file[lInc] := chr(0); + for lInc := 1 to length(aux.text) do + aux_file[lInc] := aux.text[lInc]; + for lInc := 1 to 16 do + intent_name[lInc] := chr(0); + for lInc := 1 to length(intent_nameEdit.text) do + intent_name[lInc] := intent_nameEdit.text[lInc]; + xyzt_units := xyzt_sizeDrop.ItemIndex; + xyzt_units := xyzt_units+ (DropItem2time_units(xyzt_timeDrop.ItemIndex)); + lInc := IntentCodeDrop.ItemIndex; + if (lInc > 0) and (lInc < kNIFTI_LAST_STATCODE) then + lInc := lInc + 1 //intent_codes start from 2 not 1 + else if (lInc >= kNIFTI_LAST_STATCODE) then //add gap in numbers between last stat code and misc codes + lInc := (lInc - kNIFTI_LAST_STATCODE)+kNIFTI_FIRST_NONSTATCODE + else + lInc := 0; //unknown + intent_code := lInc; + intent_p1 := intent_p1Edit.value; + intent_p2 := intent_p2Edit.value; + intent_p3 := intent_p3Edit.value; + extents:= round(ext.value); + session_error := round(ses.value); + regular := chr(round(reg.value)); + dim_Info := FreqDimDrop.ItemIndex+(PhaseDimDrop.ItemIndex shl 2)+(SliceDimDrop.ItemIndex shl 4); + slice_start := round(slice_startEdit.value); + slice_end := round(slice_endEdit.value); + slice_code := SliceCodeDrop.ItemIndex; + Slice_duration := (Slice_DurationEdit.value); + toffset := (toffsetEdit.value); + cal_max := cmax.value; + cal_min := cmin.value; + glmax := round(gmax.value); + glmin := round(gmin.value); + //Next: 3D orientation rotations + pixdim[0] := QFacEdit.value; + qform_code := QFormDrop.ItemIndex; + quatern_b := quatern_bEdit.value; + quatern_c := quatern_cEdit.value; + quatern_d := quatern_dEdit.value; + qoffset_x := qoffset_xEdit.value; + qoffset_y := qoffset_yEdit.value; + qoffset_z := qoffset_zEdit.value; + sform_code := SFormDrop.ItemIndex; + srow_x[0] := srow_x0Edit.value;//12 affine matrix values + srow_x[1] := srow_x1Edit.value; + srow_x[2] := srow_x2Edit.value; + srow_x[3] := srow_x3Edit.value; + srow_y[0] := srow_y0Edit.value; + srow_y[1] := srow_y1Edit.value; + srow_y[2] := srow_y2Edit.value; + srow_y[3] := srow_y3Edit.value; + srow_z[0] := srow_z0Edit.value; + srow_z[1] := srow_z1Edit.value; + srow_z[2] := srow_z2Edit.value; + srow_z[3] := srow_z3Edit.value; + end; //with lHdr + //zero_intercept := intercept.value; +end; + +function THdrForm.OpenAndDisplayHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +var lFileDir: string; +begin + FreeImgMemory(lHdr); + result := false; + NIFTIhdr_ClearHdr(lHdr); + if not NIFTIhdr_LoadHdr(lFilename, lHdr) then exit; + WriteHdrForm (lHdr); + lFileDir := extractfiledir(lFilename); + if lFileDir <> gTemplateDir then + OpenHdrDlg.InitialDir := lFileDir; + SaveHdrDlg.InitialDir := lFileDir; + //999 ImgForm.SaveDialog1.InitialDir := lFileDir; + SaveHdrDlg.FileName := lFilename; //make this default file to write + StatusBar1.Panels[1].text := lFilename; + StatusBar1.Panels[0].text := 'Img= '+inttostr(ComputeImageDataBytes(lHdr)); + result := true; +end; + +procedure THdrForm.Open1Click(Sender: TObject); +var lHdr: TMRIcroHdr; + lFilename: string; +begin + //NIfTI (*.hdr;*.nii)|*.hdr; *.nii; *.nii.gz|NIfTI separate header (*.hdr)|*.hdr|NIfTI embedded header|*.nii|NIfTI compressed|*.nii.gz + //if not OpenHdrDlg.Execute then exit; + if not OpenDialogExecute(kImgFilter,'Select header',false) then exit; + lFilename := OpenHdrDlg.Filename; + OpenAndDisplayHdr(lFilename,lHdr); +end; + +procedure THdrForm.Save1Click(Sender: TObject); +var lHdr: TMRIcroHdr; + lFilename: string; +begin + NIFTIhdr_ClearHdr(lHdr); + if not SaveHdrDlg.Execute then exit; + lFilename := SaveHdrDlg.Filename; + OpenHdrDlg.InitialDir := extractfiledir(lFilename); + //999 ImgForm.SaveDialog1.InitialDir := extractfiledir(lFilename); + ReadHdrForm (lHdr); + if not NIFTIhdr_SaveHdr (lFilename, lHdr,true) then exit; + OpenHdrDlg.FileName := lFilename; //make this default file to open + StatusBar1.Panels[1].text := 'wrote: '+lFilename; +end; + +procedure THdrForm.TabMenuClick(Sender: TObject); +begin + PageControl1.ActivePage := PageControl1.Pages[(Sender as TMenuItem).Tag]; +end; + +procedure THdrForm.Exit1Click(Sender: TObject); //Quit the program or form +begin + Close; +end; + + {$IFNDEF FPC} +procedure THdrForm.WMDropFiles(var Msg: TWMDropFiles); //implement drag and drop +//NOTE: requires 'ShellAPI' in uses clause +var lHdr: TMRIcroHdr; + CFileName: array[0..MAX_PATH] of Char; + lFilename: string; +begin + try + if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then + begin + lFilename := CFilename; + OpenAndDisplayHdr(lFileName, lHdr); + Msg.Result := 0; + end; + finally + DragFinish(Msg.Drop); + end; +end; + {$ENDIF} + +procedure THdrForm.FormCreate(Sender: TObject); +var lHdr: TMRIcroHdr; +begin + //DecimalSeparator := '.'; //important for reading DICOM data: e.g. Germans write '12,00' but DICOM is '12.00' + {$IFNDEF Unix} DragAcceptFiles(Handle, True); //engage drag and drop + {$ENDIF} + NIFTIhdr_ClearHdr(lHdr); + HdrForm.WriteHdrForm (lHdr); //show default header + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Open1.ShortCut := ShortCut(Word('O'), [ssMeta]); + Save1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Exit1.ShortCut := ShortCut(Word('W'), [ssMeta]); + Dimensions1.ShortCut := ShortCut(Word('A'), [ssMeta]); + Rotations1.ShortCut := ShortCut(Word('B'), [ssMeta]); + ImageIntensity1.ShortCut := ShortCut(Word('I'), [ssMeta]); + Statistics1.ShortCut := ShortCut(Word('D'), [ssMeta]); + FunctionalMRI1.ShortCut := ShortCut(Word('E'), [ssMeta]); + Optional1.ShortCut := ShortCut(Word('F'), [ssMeta]); + {$ENDIF} + {$ENDIF} +end; + +procedure THdrForm.ImageSzChange(Sender: TObject); //report size of image data +var + lHdr: TMRIcroHdr; +begin + NIFTIhdr_ClearHdr(lHdr); //important: reset values like first 4 bytes = 348 + ReadHdrDimensionsOnly(lHdr); + StatusBar1.Panels[0].text := 'Img= '+inttostr(ComputeImageDataBytes(lHdr)); +end; + +procedure THdrForm.HeaderMagicDropSelect(Sender: TObject); +var lHdrIndex: integer; +begin + lHdrIndex := HeaderMagicDrop.ItemIndex; //0=unkown, 1=nifti hdr+img, 2=nifti .nii embedded + if lHdrIndex = 1 then begin//nifti hdr+img, offset must be = 0 + OffsetEdit.MinValue := 0; + OffsetEdit.Enabled := false; + OffsetEdit.value := 0; + end else if lHdrIndex = 2 then begin//embedded header, offset must be at least 348 + OffsetEdit.Enabled := true; + if OffsetEdit.value < sizeof(TNIFTIHdr) then + OffsetEdit.value := sizeof(TNIFTIHdr); + OffsetEdit.MinValue := sizeof(TNIFTIHdr); + end else begin //no embedded header... therefore offset can be zero + OffsetEdit.MinValue := 0; + OffsetEdit.Enabled := true; + + if OffsetEdit.value = sizeof(TNIFTIHdr) then + OffsetEdit.value := 0; + end; +end; + + +end. diff --git a/backup/nifti_img.pas.bak b/backup/nifti_img.pas.bak new file mode 100755 index 0000000..205f943 --- /dev/null +++ b/backup/nifti_img.pas.bak @@ -0,0 +1,5934 @@ +unit nifti_img; +interface +uses +{$H+} +{$IFNDEF FPC} +RXSpin,capmenu,PNGImage,SSE,ShellAPI,Spin, +{$ENDIF} +{$IFNDEF Unix} Windows, +{$ELSE} + //RGBGraphics,rgbroutines, +{$ENDIF} +nifti_types, +SysUtils, Classes, Graphics, Controls, Forms, Dialogs, GraphType, + Menus, ExtCtrls, NIFTI_hdr,nii_label, +Math,ClipBrd,define_types, + GraphicsMathLibrary,Distr,Stat,ReadInt,gzio2; +const + kMultiView = 0; + kAxView0 = 1; + kSagView0 = 2; + kCoroView0 = 3; + kAxViewOnly = -1; + kSagViewOnly = -2; + kCoroViewOnly = -3; + kMaxLabel = 255; +Type + + TBGImg = record //Next: analyze Format Header structure + ScrnDim: array [1..3] of smallint; + ScrnMM,ScrnOri: array [1..3] of single; + XViewCenter,YViewCenter,ZViewCenter: single; + SliceView,SPMDefaultsStatsFmriT,SPMDefaultsStatsFmriT0, + MaxDim,LicenseID,XBarGap,XBarThick,VOIUndoSlice,VOIUndoOrient,VOIUndoVolItems, + RenderDepthBufferItems,VOIInvZoom,ZoomPct,BGTransPct,OverlayTransPct, PlanarRGB, + ImageSeparation,RenderDim,SigDig,LesionSmooth,LesionDilate,FontSize, SaveImgFilter, SaveVoiFilter: integer; + //ResizeBeforeRescale - 0=intensity rescale, then resize; 1= nearest neighbor resize, then rescale;1=trilinear resize, then rescale;12:47 PM 7/13/2006 + UseReorientHdr,XBarVisible,ThinPen,Mirror,OverlaySmooth,VOIchanged,VOImirrored, + SaveDefaultIni,KnownAlignment,Resliced, + FlipAx,FlipSag,SingleRow,ResliceOnLoad,Prompt4DVolume,OrthoReslice, ShowDraw: boolean; + MinChar,MaxChar: array [1..3] of char; //May07 + StretchQuality : TStretchQuality; + VOIClr,XBarClr: TColor; + BackupLUT: TLUT; + //LabelStr20 : Array[0..kMaxLabel] of kstr50; + LabelRA: TStrRA; + {FSLDIR,}FSLBASE,FSLOUTPUTTYPE{,FSLBETEXE}: kStr255; + InvMat: TMatrix; + ReorientHdr: TNIFTIHdr; + //Cutout: TCutout; + VOIUndoVol: bytep; + RenderDepthBuffer: SmallIntp; + end; //TNIFTIhdr Header Structure + procedure CreateAnaRGB; + function SlicesToImgPos(lX,lY,lZ: integer): integer; + procedure ImgPosToSlices(lPos: integer; var lX,lY,lZ: integer); +procedure DrawBMP( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +procedure IntenBar (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer {1=Left,2=Top,3=right,4=bottom}; lMin,lMax: single); +procedure Balance (var lHdr: TMRIcroHdr); +function ImgVaries ( var lHdr: TMRIcroHdr): boolean; +function OpenImg(var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground,lVOILoadAsBinary,lNoScaling8bit,lResliceIn,l4D: boolean): boolean; +procedure InitImgMemory(var lHdr: TMRIcroHdr); +procedure FreeImgMemory(var lHdr: TMRIcroHdr); +procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +//procedure RescaleImgIntensity(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr ); + procedure RescaleImgIntensity(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lLayer: integer ); +procedure LoadColorScheme(lStr: string; var lHdr: TMRIcroHdr); +procedure LoadMonochromeLUT (var lLUT: integer; var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); //lLUT: 0=gray,1=red,2=green,3=blue +procedure FilterLUT (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lMin, lMax: integer); //lLUT: 0=gray,1=red,2=green,3=blue +function Raw2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +function Scaled2RawIntensity (lHdr: TMRIcroHdr; lScaled: single): single; +procedure AlphaBlend32(lBGQuad,lOverlayQuad : RGBQuadp; lBG0Clr,lOverlay0Clr: DWord; lSlicePixels, lOverlayTransPct: integer); // 630 +procedure SetBGImgDefaults (var lBGImg: TBGImg); +function MaxDim (lX,lY,lZ: integer): integer; //returns largest of 3 +procedure DrawHistogram (var lHdr: TMRIcroHdr; var lImage: TImage); +function MirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +procedure MirrorScrnBuffer(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr ); +procedure SetSubmenuWithTag (var lRootMenu: TMenuItem; lTag: Integer); +procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +procedure SaveAsVOIorNIFTI (var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; DefaultFormatVOI: boolean; var lNiftiHdr: TNIFTIHdr; lDefFilename: string); +function Scrn2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +procedure ScaleScrn2BMP (var lX, lY: integer;lImage: TImage); +procedure DrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +function ImageZoomPct( var lImage: TImage): integer; +procedure ScaleBMP2Draw (var InvZoomShl10,lX, lY,lPanel: integer; lImage: TImage); +function ComputeInvZoomShl10(lSelectedImageNum: integer; var lImage: TImage): integer; +function ComputeZoomPct(lSelectedImageNum: integer; var lImage: TImage): integer; +function SelectedImageNum: Integer; +procedure EnsureVOIOpen; +procedure FreeUndoVol; +procedure CreateUndoVol; +procedure UndoVolVOI; +function IsVOIOpen: boolean; +//procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +procedure SaveImgAsPNGBMP (lImage: TImage); +procedure RefreshImages; +procedure DrawAxial (lSlice,lMultiSlice: integer); +procedure DrawSag(lSlice,lMultiSlice: integer); +procedure DrawCor(lSlice,lMultiSlice: integer); +procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +procedure ImgCoordToMM(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +procedure MMToImgCoord(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +//function DimToMM (lIn, lDim: integer): integer; +function DimToMM (lX,lY,lZ, lDim: integer): integer; +function DimToMMx (lDim: integer): integer; +procedure ImgPosToMM(lPos: integer; var lXmm,lYmm,lZmm: single); +procedure MakeStatHdr (var lBGHdr,lStatHdr: TMRIcroHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +function CenterOfMass (lOverlay: integer; var lX,lY,lZ: double): integer; +procedure TextReportHisto (var lHdr: TMRIcroHdr); +function TColor2TRGBQuad(lColor: TColor): TRGBQuad; +function TRGBQuad2DWord (lLUT: TRGBQuad): DWord; +procedure ReturnMinMax (var lHdr: TMRIcroHdr; var lMin,lMax: single; var lFiltMin8bit, lFiltMax8bit: integer); +function RawBGIntensity(lPos: integer): single; + +//procedure FreeImgMemory(var lHdr: TMRIcroHdr); + + +const +gSelectedImageNum :integer= 1; +//gTripleZoom100: integer = 1; +//gImgSpacing: integer = 1; +implementation + +uses nifti_img_view,MultiSlice,histoform,text, ortho_reorient, reslice_img; + +function RawBGIntensity(lPos: integer): single; +var + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + result := 0; + if (lPos > gMRIcroOverlay[kBGOverlayNum].ImgBufferItems) or (lPos < 1) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l32Buf^[lPos]; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l16Buf^[lPos]; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then + result := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos] + else begin + showmessage('Unknown Background Buffer Bytes Per Pixel'); + exit; + end; +end; + +function TRGBQuad2DWord (lLUT: TRGBQuad): DWord; +var + inguy : ^DWord; +begin + inguy := @lLUT; + result := inguy^; +end; + +function TRGBQuad2TColor (lLUT: TRGBQuad): TColor; +begin + result := (lLUT.rgbred)+(lLUT.rgbgreen shl 8)+(lLUT.rgbblue shl 16); +end; + +function TColor2TRGBQuad(lColor: TColor): TRGBQuad; +begin + result.rgbRed := (lColor and 255) ; + result.rgbGreen := (lColor shr 8) and 255 ;// and 65280; + result.rgbBlue := ((lColor shr 16) and 255) ;//and 16711680; + result.rgbReserved := kLUTalpha; +end; + +procedure InitImgMemory(var lHdr: TMRIcroHdr); +begin + with lHdr do begin + RenderBufferItems := 0; + ScrnBufferItems := 0; + ImgBufferItems := 0; + end; +end; + + + + +function CenterOfMass (lOverlay: integer; var lX,lY,lZ: double): integer; +//result is volume in voxels - 0 = no volume or error +var + lXpos,lYpos,lZpos,lInc: integer; + +begin + result := 0; + lX := 0; + lY := 0; + lZ := 0; + //fx((gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1]*gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2]* gMRIcroOverlay[lOverlay].NIFTIhdr.dim[3]), gMRIcroOverlay[lOverlay].ScrnBufferItems); + + if (gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1]*gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2]* gMRIcroOverlay[lOverlay].NIFTIhdr.dim[3]) <> gMRIcroOverlay[lOverlay].ScrnBufferItems then + exit; + //fx(999); + lInc := 0; + for lZpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[3] do begin + for lYpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2] do begin + for lXpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1] do begin + inc(lInc); + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lInc] > 0 then begin + inc(result); + lX := lX + lXpos; + lY := lY + lYpos; + lZ := lZ + lZpos; + end; + end; //lX + end;//Y + end;//Z + //fx(lX,lY,lZ); + if result > 0 then begin + lX := lX / result; + lY := lY / result; + lZ := lZ / result; + end; + //lARDistance := round(sqrt( sqr(lRX-lAX)+sqr(lRY-lAY)+sqr(lRZ-lAZ))); //<- pythagorean theorem for dx +end; + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TMRIcroHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +//lIntent kNIFTI_INTENT_CHISQ lIntent_p1 = DOF +//lIntent kNIFTI_INTENT_ZSCORE no params +//lIntent kNIFTI_INTENT_TTEST lIntent_p1 = DOF +var lIntentNameLen,lPos: integer; +begin + with lStatHdr do begin + move(lBGHdr.niftiHdr,lStatHdr.niftiHdr,sizeof(TniftiHdr)); + ImgBufferBPP := 1; + ImgBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + NIFTIhdr.scl_slope:= 1; + NIFTIhdr.scl_inter:= 0; + NIFTIhdr.glmin := round(lMinIntensity); + NIFTIhdr.glmax := round(lMaxIntensity); + AutoBalMinUnscaled := lMinIntensity; + AutoBalMaxUnscaled := lMaxIntensity; + WindowScaledMin := lMinIntensity; + WindowScaledMax := lMaxIntensity; + GlMinUnscaledS := lMinIntensity; + GlMaxUnscaledS := lMaxIntensity; + HdrFileName := extractfilepath(HdrFilename)+'stat.nii.gz'; + ImgFileName := HdrFileName; + NIFTIhdr.intent_code := lIntent_Code;// kNIFTI_INTENT_ESTIMATE; + NIFTIhdr.intent_p1 := lIntent_p1; + NIFTIhdr.intent_p2 := lIntent_p2; + NIFTIhdr.intent_p3 := lIntent_p3; + lIntentNameLen := length(lIntentName); + if lIntentNameLen > sizeof(NIFTIhdr.intent_name) then + lIntentNameLen := sizeof(NIFTIhdr.intent_name); + if lIntentNameLen > 0 then + for lPos := 1 to lIntentNameLen do + NIFTIhdr.intent_name[lPos] := lIntentName[lPos]; + end; +end; + +procedure MMToImgCoord(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +var + lXx,lYy,lZz: single; +begin + if (not gBGImg.Resliced) and ( gMRIcroOverlay[kBGOverlayNum].NIfTItransform) then begin//vcx + //mirror + lxx := lXmm; + lyy := lYmm; + lzz := lZmm; + mm2Voxel (lxx,lyy,lzz, gBGImg.InvMat); + if gBGImg.Mirror then + lXx := gBGImg.ScrnDim[1]-lXx; + lX := round(lxx); + ly := round(lyy); + lz := round(lzz); + exit; + end; + + if gBGImg.Mirror then + lX := round((gBGImg.ScrnDim[1]-gBGImg.ScrnOri[1]+1)-(lXmm/gBGImg.ScrnMM[1])) + else + lX := round((lXmm/gBGImg.ScrnMM[1])+gBGImg.ScrnOri[1]); + lY := round((lYmm/gBGImg.ScrnMM[2])+gBGImg.ScrnOri[2]); + lZ := round((lZmm/gBGImg.ScrnMM[3])+gBGImg.ScrnOri[3]); + if lX < 1 then lX := 1; + if lY < 1 then lY := 1; + if lZ < 1 then lZ := 1; + if lX > gBGImg.ScrnDim[1] then lX := gBGImg.ScrnDim[1]; + if lY > gBGImg.ScrnDim[2] then lY := gBGImg.ScrnDim[2]; + if lZ > gBGImg.ScrnDim[3] then lZ := gBGImg.ScrnDim[3]; +end; + +(*2008 +procedure MMToImgCoord(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +begin + lX := round((lXmm/gBGImg.ScrnMM[1])+gBGImg.ScrnOri[1]); + lY := round((lYmm/gBGImg.ScrnMM[2])+gBGImg.ScrnOri[2]); + lZ := round((lZmm/gBGImg.ScrnMM[3])+gBGImg.ScrnOri[3]); + if lX < 1 then lX := 1; + if lY < 1 then lY := 1; + if lZ < 1 then lZ := 1; + if lX > gBGImg.ScrnDim[1] then lX := gBGImg.ScrnDim[1]; + if lY > gBGImg.ScrnDim[2] then lY := gBGImg.ScrnDim[2]; + if lZ > gBGImg.ScrnDim[3] then lZ := gBGImg.ScrnDim[3]; +end; *) + +(*procedure ImgCoordToMM(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +begin + lXmm := ((lX)-gBGImg.ScrnOri[1])*gBGImg.ScrnMM[1]; + lYmm := ((lY)-gBGImg.ScrnOri[2])*gBGImg.ScrnMM[2]; + lZmm := ((lZ)-gBGImg.ScrnOri[3])*gBGImg.ScrnMM[3]; +end; *) + +procedure ImgCoordToMM(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +begin + if (not gBGImg.Resliced) and ( gMRIcroOverlay[kBGOverlayNum].NIfTItransform) then begin//vcx + //mirror + lXmm := lX; + if gBGImg.Mirror then + lXmm := gBGImg.ScrnDim[1]-lXmm; + lYmm := lY; + lZmm := lZ; + Voxel2mm (lxmm,lymm,lzmm, gMRIcroOverlay[kBGOverlayNum].NIftiHdr); + exit; + end; +if gBGImg.Mirror then lXmm := ((gBGImg.ScrnDim[1]-lX+1)-gBGImg.ScrnOri[1])*gBGImg.ScrnMM[1] else + + lXmm := ((lX)-gBGImg.ScrnOri[1])*gBGImg.ScrnMM[1]; + lYmm := ((lY)-gBGImg.ScrnOri[2])*gBGImg.ScrnMM[2]; + lZmm := ((lZ)-gBGImg.ScrnOri[3])*gBGImg.ScrnMM[3]; +end; + +function XPos(lPos,XDim: integer): integer; //given 1D array return 3D column +begin + result := lPos mod XDim; + if result = 0 then + result := XDim; +end; + +function ZPos(lPos, XDimTimesYDim: integer): integer; //given 1D array return 3D slice +begin + result := lPos div XDimTimesYDim; + if (lPos mod XDimTimesYDim) <> 0 then + inc(result); +end; + +function YPos(lPos, XDim,YDim: integer): integer; //given 1D array return 3D row +var + lSlicePos: integer; +begin + //first - eliminate slice offset + result := ZPos(lPos,XDim*YDim); + lSlicePos := lPos - ((result-1)*(XDim*YDim)); + //now find row + result :=lSlicePos div XDim; + if (lSlicePos mod XDim) <> 0 then + inc(result); +end; + +(*function XPos(lPos,XDim: integer): integer; //given 1D array return 3D column +begin + result := lPos mod XDim; + if result = 0 then + result := XDim; +end; + +function ZPos(lPos, XDimTimesYDim: integer): integer; //given 1D array return 3D slice +begin + result := lPos div XDimTimesYDim; + if (lPos mod XDimTimesYDim) <> 0 then + inc(result); +end; + +function YPos(lPos, XDim,YDim: integer): integer; //given 1D array return 3D row +var + lSlicePos: integer; +begin + //first - eliminate slice offset + result := ZPos(lPos,XDim*YDim); + lSlicePos := lPos - ((result-1)*(XDim*YDim)); + //now find row + result :=lSlicePos div XDim; + if (lSlicePos mod XDim) <> 0 then + inc(result); +end; *) + +function SlicesToImgPos(lX,lY,lZ: integer): integer; +begin + result := lX + ((lY-1) * gBGImg.ScrnDim[1])+ ((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); +end; +procedure ImgPosToSlices(lPos: integer; var lX,lY,lZ: integer); +begin + lX := XPos(lPos,gBGImg.ScrnDim[1]); + lY := YPos(lPos,gBGImg.ScrnDim[1],gBGImg.ScrnDim[2]); + lZ := ZPos(lPos,gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); +end; + + +procedure ImgPosToMM(lPos: integer; var lXmm,lYmm,lZmm: single); +var lX,lY,lZ: integer; +begin + lX := XPos(lPos,gBGImg.ScrnDim[1]); + lY := YPos(lPos,gBGImg.ScrnDim[1],gBGImg.ScrnDim[2]); + lZ := ZPos(lPos,gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + ImgCoordToMM(lX,lY,lZ, lXmm,lYmm,lZmm); +//xxx lPos := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); +end; + +(*function DimToMM (lIn, lDim: integer): integer; +var + lX,lY,lZ: integer; + lXmm,lYmm,lZmm: single; +begin + + lX := lIn; + lY := lIn; + lZ := lIn; + //if lDim = 2 then imgform.caption := inttostr(lY)+'-'; + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + case lDim of + 3: result := round(lZmm); + 2: result := round(lYmm); + else result := round(lXmm); + end; //case + //imgform.caption := floattostr(lYmm); +end; //DimToMM *) +function DimToMM (lX,lY,lZ, lDim: integer): integer; +//Sept2008 - X/Y/Z required for rotated images +var + lXi,lYi,lZi: integer; + lXmm,lYmm,lZmm: single; +begin + lXi := lX; + lYi := lY; + lZi := lZ; + ImgCoordToMM(lXi,lYi,lZi,lXmm,lYmm,lZmm); + //imgform.Caption := floattostr(lxmm)+' '+floattostr(lymm)+' '+floattostr(lzmm)+' 666'; + case lDim of + 3: result := round(lZmm); + 2: result := round(lYmm); + else result := round(lXmm); + end //case +end; //DimToMM + +function DimToMMx (lDim: integer): integer; +var + lX,lY,lZ: integer; +begin + lX := round(ImgForm.XViewEdit.value); + lY := round(ImgForm.YViewEdit.value); + lZ := round(ImgForm.ZViewEdit.value); + result := DimToMM(lX,lY,lZ,lDim); +end; //DimToMM + + +procedure DrawTextLabel(var lImage: TImage; lOutStr: string; lXCenterIn,lXWidthIn: integer); +var + lXWidth,lXCenter: integer; +begin + lXWidth := lXWidthIn; + lXCenter:= lXCenterIn; + if lXWidth < 1 then begin + lXWidth := lImage.Picture.Bitmap.Width; + end; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + {$IFDEF Darwin} + lImage.Canvas.Font.Name := 'Helvetica'; + + {$ELSE} + lImage.Canvas.Font.Name := 'Arial'; + {$ENDIF} + lImage.Canvas.Font.Size := gBGImg.FontSize; + (*if lXWidth < 100 then + lImage.Canvas.Font.Size := 12 + else if lXWidth < 200 then + lImage.Canvas.Font.Size := 14 + else + lImage.Canvas.Font.Size := 18; *) + //lImage.Canvas.Font.Size := 18; + if lXCenterIn < 1 then + lImage.canvas.TextOut(2,1,lOutStr) + else if lXCenterIn = MaxInt then + lImage.canvas.TextOut((lXWidth div 2)-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) + else + lImage.canvas.TextOut(lXCenter-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) +end; + +procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +begin + DrawTextLabel(lImage,inttostr(lValue),lXCenterIn,lXWidthIn); +end; + +procedure DrawTextLabelV(var lImage: TImage; lOutStr: string); +var + lYHt: integer; +begin + lYHt := lImage.Picture.Bitmap.Height; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + lImage.canvas.TextOut(2,(lYHt div 2)-round(0.5*lImage.Canvas.TextHeight('X')),lOutStr) +end; + +(*procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +var + lOutStr: string; + lXWidth,lXCenter: integer; +begin + lXWidth := lXWidthIn; + lXCenter:= lXCenterIn; + if lXWidth < 1 then begin + lXWidth := lImage.Picture.Bitmap.Width; + end; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + if lXWidth < 100 then + lImage.Canvas.Font.Size := 9 + else if lXWidth < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14; + lOutStr := inttostr(lValue); + if lXCenterIn < 1 then + lImage.canvas.TextOut(2,1,lOutStr) + else if lXCenterIn = MaxInt then + lImage.canvas.TextOut((lXWidth div 2)-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) + else + lImage.canvas.TextOut(lXCenter-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) +end;*) + + + {$IFNDEF FPC} +procedure PasteDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lImage: TImage; lXOffset: integer); +var + sbBits : PByteArray; + lPGWid,lPGHt,nBytesInImage: integer; + lBMP: TBitmap; + lSrcRect,lDestRect: TRect; +begin + if lXOffset < 1 then begin + showmessage('Error with paste dimension - XOffset is <1!'); + exit; + end; + lPGWid := lInPGWid; + lPGHt := lInPGHt; + lBMP := TBitmap.Create; + TRY + lBMP.PixelFormat := pf32bit; + lBMP.Width := lPGwid; + lBMP.Height := lPGHt; + sbBits := lBmp.ScanLine[lPGHt-1]; + nBytesInImage := lPGWid*lPGHt * 4; + CopyMemory(Pointer(sbBits),Pointer(lBuff),nBytesInImage); + lImage.Canvas.CopyMode := cmSrcCopy; + lSrcRect := Rect(0,0,lBMP.Width,lBMP.Height); + lDestRect := Rect(lXOffset,0,lXOffset+lBMP.Width,lBMP.Height); + lImage.Canvas.CopyRect(lDestRect,lBMP.Canvas,lSrcRect); + FINALLY + lBMP.Free; + END; //try..finally +end; //proc PasteDimension32 + {$ELSE} +//PasteDimension32 FPC +procedure PasteDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; lXOffset: integer); +var + lRowStart,x, y,lPos: Integer; +begin + if lBuff = nil then exit; + lPos := 0; + for y:= (lInPGHt-1) downto 0 do begin + lRowStart := (y * gMultiWid)+lXOffset; + for x:=0 to lInPGWid-1 do begin + //dec(lPos); + inc(lPos); + gMultiBuff^[lRowStart+x] := lBuff^[lPos]; + end; + end; +end; + {$ENDIF} + +procedure CreateSag(var lHdr: TMRIcroHdr; lX,lXOffset,lY,lZ,lXYSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + //lLongBuff: LongIntp; + lPixel,lYPos,lZPos,lZOffset,lYOffset: integer; +begin + lSrc := lHdr.ScrnBuffer; + lPixel := 0; + // lLongBuff := LongIntp(lQuadP); + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + lQuadP^[lPixel] := lHdr.LUT[lSrc^[lZOffset+lYOffset+lXOffset]]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z +end; //CreateSag + + +procedure MirrorSlice (lY,lX: integer; lImage: RGBQuadp); +var + lRowData: RGBQuadp; + lXi,lYi,lHalfX,lRowBytes,lTop: integer; +begin + if lX < 2 then exit; + lRowBytes := lX * 4; + getmem(lRowData,lRowBytes); + lHalfX := lX div 2; + lTop := 1; + for lYi := 1 to lY do begin + Move(lImage^[lTop],lRowData^[1],lRowBytes); + for lXi := 1 to lX do + lImage^[lTop+lXi-1] := lRowData^[lX - lXi + 1]; + lTop := lTop + lX; + end; + freemem(lRowData); +end; + +procedure DrawSag (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lOverlay,lnOverlay,lXOffset, lX,lY,lZ,lXYSliceSz,lYZSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lXOffset := round(lSlice); + lXYSliceSz := (lX*lY); + lYZSliceSz := (lY*lZ); + if (lXOffset > lX) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lXOffset < 1 {999+}) or (lXYSliceSz < 1) then + exit; + if (lZ < 2) then begin + SetDimension32(1,1, nil, gBGImg, ImgForm.PGImageSag, ImgForm.TriplePanel); + exit; + end; + GetMem ( lBGQuadP , lYZSliceSz*4); + CreateSag(gMRIcroOverlay[kBGOverlayNum], lX,lXOffset,lY,lZ,lXYSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +lBG0Clr:= TRGBQuad2DWord(gMRIcroOverlay[kBGOverlayNum].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lYZSliceSz*4); + lBG0Clr:= TRGBQuad2DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateSag(gMRIcroOverlay[lOverlay], lX,lXOffset,lY,lZ,lXYSliceSz, lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lYZSliceSz*4); + CreateSag(gMRIcroOverlay[lOverlay], lX,lXOffset,lY,lZ,lXYSliceSz, l2ndOverlayQuadP); + lOverlay0Clr:= TRGBQuad2DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lYZSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible [no alpha] DWord(lHdr.LUTinvisible); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lYZSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + if gBGImg.FlipSag then + MirrorSlice (lZ,lY, lBGQuadP); + if lMultiSlice >= 0 then + PasteDimension32(lZ,lY, lBGQuadP,lMultiSlice)//, MultiSliceForm.MultiImage,lMultiSlice) + else begin + SetDimension32(lZ,lY, lBGQuadP, gBGImg, ImgForm.PGImageSag, ImgForm.TriplePanel); + FreeMem ( lBGQuadP); + if gBGImg.XBarVisible then begin + + if gBGImg.FlipSag then + DrawXBar ( round(lY-gBGImg.YViewCenter), round(gBGImg.ZViewCenter),ImgForm.PGImageSag) + else + DrawXBar ( round(gBGImg.YViewCenter), round({lZ-}gBGImg.ZViewCenter),ImgForm.PGImageSag); + DrawLabel(ImgForm.PGImageSag, DimToMMx(1),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageSag,gBGImg.MaxChar[3]{'S'},MaxInt,-1); + if gBGImg.FlipSag then + DrawTextLabelV(ImgForm.PGImageSag,gBGImg.MaxChar[2]) + else + DrawTextLabelV(ImgForm.PGImageSag,gBGImg.MinChar[2]{'P'}); + end; + end; //XBars + end; //draw +end; + +procedure CreateCor(var lHdr: TMRIcroHdr; lX,lYOffset,lZ,lXYSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + lPixel,lXPos,lZPos,lZOffset: integer; +begin + lSrc := lHdr.ScrnBuffer; + lPixel := 0; + //fx(lYOffset); + for lZPos := 1 to (lZ) do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + lQuadP^[lPixel]:=lHdr.LUT[lSrc^[lZOffset+lYOffset+lXPos]];//+1 Mac??? + + end; //for each Y + end; //for each Z + {$IFDEF ENDIAN_BIG} + lPixel := random(255); + //fixes strange PPC compiler bug where lS value in DrawCor is corrupted + //bug only seen in Lazarus IDE + {$ENDIF} +end; + +procedure DrawCor (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lOverlay,lnOverlay, lYOffset, lX,lY,lZ,lS,lXYSliceSz,lXZSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lS := round(lSlice); + lXYSliceSz := (lX*lY); + lXZSliceSz := (lX*lZ); + lYOffset := (lX) * (lS-1); + if (lS > lY) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 1 {999+}) or (lXYSliceSz < 1) then + exit; + if (lZ < 2) then begin + SetDimension32(1,1, nil, gBGImg, ImgForm.PGImageSag, ImgForm.TriplePanel); + //these do not work when image is stretched + //ImgForm.PGImage3.Width := 1; + //ImgForm.PGImage3.Height := 1; + exit; + end; + + GetMem ( lBGQuadP , (lXZSliceSz*4)); +//imgform.caption := inttostr(lS)+'x666'; + CreateCor(gMRIcroOverlay[kBGOverlayNum], lX,lYOffset,lZ,lXYSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +//imgform.caption := inttostr(lS)+'x666'; +lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lXZSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateCor(gMRIcroOverlay[lOverlay], lX,lYOffset,lZ,lXYSliceSz, lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lXZSliceSz*4); + CreateCor(gMRIcroOverlay[lOverlay], lX,lYOffset,lZ,lXYSliceSz, l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lXZSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUTinvisible); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lXZSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + if lMultiSlice >= 0 then + PasteDimension32(lZ,lX, lBGQuadP,lMultiSlice)// MultiSliceForm.MultiImage,lMultiSlice) + else begin + SetDimension32(lZ,lX, lBGQuadP, gBGImg,ImgForm.PGImageCor, ImgForm.TriplePanel); + if {ImgForm.XBarBtn.Down}gBGImg.XBarVisible then begin + DrawXBar ( round(gBGImg.XViewCenter), round({lZ-}gBGImg.ZViewCenter),ImgForm.PGImageCor); + DrawLabel(ImgForm.PGImageCor, DimToMMx(2),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageCor,gBGImg.MaxChar[3]{'S'},MaxInt,-1); + if gBGImg.Mirror then + DrawTextLabelV(ImgForm.PGImageCor,gBGImg.MaxChar[1]{'R'}) + else + DrawTextLabelV(ImgForm.PGImageCor,gBGImg.MinChar[1]{'L'}); + end; + + end; //XBar + end; + FreeMem ( lBGQuadP); +end; + +procedure CreateAxial(var lHdr: TMRIcroHdr; lStart,lSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + lPixel: integer; +begin + lSrc := lHdr.ScrnBuffer; + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:=lHdr.LUT[lSrc^[lStart+lPixel]]; + //abba lQuadP^[200]:=lHdr.LUT[255]; +end; + +procedure FlipSlice (lY,lX: integer; lImage: RGBQuadp); +var + lRowData: RGBQuadp; + lYi,lHalfY,lRowBytes,lTop,lBottom: integer; +begin + if lY < 2 then exit; + lRowBytes := lX * 4; + getmem(lRowData,lRowBytes); + lHalfY := lY div 2; + lTop := 1; + lBottom := ((lY-1)*lX)+1; + for lYi := 1 to lHalfY do begin + Move(lImage^[lTop],lRowData^[1],lRowBytes); + Move(lImage^[lBottom],lImage^[lTop],lRowBytes); + Move(lRowData^[1],lImage^[lBottom],lRowBytes); + lTop := lTop + lX; + lBottom := lBottom - lX; + end; + freemem(lRowData); +end; + + +procedure DrawAxial (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lnOverlay,lOverlay, lX,lY,lS,lStart,lSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lS := round(lSlice{ImgForm.ZViewEdit.value}); + lSliceSz := (lX * lY{*lByte}); + lStart := lX*lY*(lS-1); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 0) or (lX < 2) or (lStart < 0) or (lSliceSz < 1) or ((lStart+lSliceSz-1) > gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then + exit; + GetMem ( lBGQuadP, lSliceSz*4); + CreateAxial(gMRIcroOverlay[kBGOverlayNum], lStart,lSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + if gBGImg.FlipAx then + FlipSlice (lY,lX, lBGQuadP); + if lMultiSlice >= 0 then + PasteDimension32(lY,lX, lBGQuadP, lMultislice)//MultiSliceForm.MultiImage,lMultiSlice) + else begin + SetDimension32(lY,lX, lBGQuadP, gBGImg, ImgForm.PGImageAx, ImgForm.TriplePanel); + if {ImgForm.XBarBtn.Down}gBGImg.XBarVisible then begin + if gBGImg.FlipAx then + lS := round(lY-gBGImg.YViewCenter) + else + lS := round(gBGImg.YViewCenter); + DrawXBar ( round(gBGImg.XViewCenter), lS{round(gBGImg.YViewCenter)},ImgForm.PGImageAx); + DrawLabel(ImgForm.PGImageAx, DimToMMx(3),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageAx,gBGImg.MaxChar[2]{'A'},MaxInt,-1); + if gBGImg.Mirror then + DrawTextLabelV(ImgForm.PGImageAx,gBGImg.MaxChar[1]{'R'}) + else + DrawTextLabelV(ImgForm.PGImageAx,gBGImg.MinChar[1]{'L'}); + end; + end; //XBar + + end; + FreeMem ( lBGQuadP); +end; //DrawAxial + +procedure DrawAxialCore (lSlice: integer; var lBGQuadP: RGBQuadp); +var + lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lnOverlay,lOverlay, lX,lY,lS,lStart,lSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lS := round(lSlice{ImgForm.ZViewEdit.value}); + lSliceSz := (lX * lY{*lByte}); + lStart := lX*lY*(lS-1); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 0) or (lX < 2) or (lStart < 0) or (lSliceSz < 1) or ((lStart+lSliceSz-1) > gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then + exit; + CreateAxial(gMRIcroOverlay[kBGOverlayNum], lStart,lSliceSz, lBGQuadP); + //next: overlays + lnOverlay := 0; + lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... + for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded + end; //for knOverlay..1 + //Finally: draw overlays on BG + if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); + end; +end; //DrawAxialCore + +procedure SegmentRGBplanes (lSlice,lXVox,lYVox: integer; var lSliceQuadP: RGBQuadp; var lImg3: bytep; isPlanarRGB: boolean); +//analyze RGB saves data as red, green blue planes +var + lLineOffset,lHalfX,lX,lY,lPos,lOutStart,lSliceVox: integer; + lTempQuadP: TRGBQuad; + +begin + lSliceVox := lXVox*lYVox; + if lSliceVox < 1 then exit; + if (ImgForm.FlipLRmenu.checked) and (lXVox > 1) then begin + lHalfX := lXVox div 2; + lLineOffset := 0; + for lY := 1 to lYVox do begin + for lX := 1 to lHalfX do begin + lTempQuadP := lSliceQuadP^[lX+lLineOffset]; + lSliceQuadP^[lX+lLineOffset] := lSliceQuadP^[1+lXVox-lX+lLineOffset]; + lSliceQuadP^[1+lXVox-lX+lLineOffset] := lTempQuadP; + end; //for X + lLineOffset := lLineOffset + lXVox; + end;//lY + + end; //mirror + if isPlanarRGB then begin + // + lOutStart := (lSlice-1)*lSliceVox*3; + for lPos := 1 to lSliceVox do begin + lImg3^[lPos+lOutStart] := lSliceQuadP^[lPos].rgbRed; + lImg3^[lPos+lOutStart+lSliceVox] := lSliceQuadP^[lPos].rgbGreen; + lImg3^[lPos+lOutStart+lSliceVox+lSliceVox] := lSliceQuadP^[lPos].rgbBlue; + end; + end else begin + lOutStart := (lSlice-1)*lSliceVox*3; + for lPos := 1 to lSliceVox do begin + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbRed; + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbGreen; + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbBlue; + end; + + end; + +end; + +procedure CreateAnaRGB; +var + lFilename: string; + lImg3: bytep; + lSliceQuadP: RGBQuadp; + lVolVox,lX,lY,lZ,lI,lnSlice: integer; + isPlanarRGB : boolean; +begin + ImgForm.SaveDialog1.Filter := 'NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.nii)|*.nii|NIfTI (.hdr/.img)|*.hdr|Volume of Interest(.voi)|*.voi|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.DefaultExt := '.hdr'; + ImgForm.SaveDialog1.Filename := ChangeFileExt(ImgForm.SaveDialog1.Filename, ImgForm.SaveDialog1.DefaultExt); //10102006 + if not ImgForm.SaveDialog1.Execute then exit; + isPlanarRGB := false; + case MessageDlg('Save as modern NIfTI style (RGBRGB..)? Press cancel for Analyze style (RR..RGG..GBB..B)?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: isPlanarRGB := true; + end; //case + + lFilename := ImgForm.SaveDialog1.Filename; + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lVolVox := lX*lY*lZ ; + if DiskFreeEx(lFilename) < (lVolVox*3) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; + + getmem(lImg3, lVolVox* 3) ; + //for Sag + lnSlice := lZ; + //fx(lX,lY,lZ); + getmem(lSliceQuadP, lX*lY* sizeof(TRGBQuad)) ; + for lI := 1 to lnSlice do begin //[1+ ((lI-1)*lSliceBytes)] + + DrawAxialCore (lI,lSliceQuadP ); + //SegmentRGBplanes (lI,lX,lY,lSliceQuadP,lImg3, gGBImg.isPlanarRGB); + SegmentRGBplanes (lI,lX,lY,lSliceQuadP,lImg3, isPlanarRGB); + end; + freemem(lSliceQuadP); + //output data + SaveAsVOIorNIFTIcore (lFilename, lImg3, lVolVox, 3,1, gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + freemem(lImg3); +end; + +procedure ComputeTripleZoom; +//computes axial, coronal and sagittal zoom +//values are SHL 10, so a 1% signal change will be 1024 +//this preserves precision (though at the moment we round to nearest 1%) +label 543,641; +//const +// kSHval = 1 shl 10; +procedure SetPct(lAfrac,lCfrac,lSfrac: single); +begin + ImgForm.PGImageAx.Tag := trunc(lAfrac*100); + ImgForm.PGImageCor.Tag := trunc(lCfrac*100) ; + ImgForm.PGImageSag.Tag := trunc(lSfrac*100) ; +end; +var + lHpanel,lWpanel,lH,lW: integer; + lPrimaryZoom,l2ndZoom,lZoomw,lZoomh: single; +begin + SetPct(1,1,1); + lHpanel := ImgForm.TriplePanel.ClientHeight-1; + lWpanel := ImgForm.TriplePanel.ClientWidth-1; + //gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + if gBGImg.ZoomPct > 0 then begin + SetPct(gBGImg.ZoomPct/100,gBGImg.ZoomPct/100,gBGImg.ZoomPct/100); + lPrimaryZoom := ImgForm.PGImageAx.Tag/100; + if abs(gBGImg.SliceView) <> kSagView0 then + lW := gBGImg.ScrnDim[1] //Axial and Coronal width is X + else + lW := gBGImg.ScrnDim[2]; //Sagittal width is Y + goto 543; + exit; + end; + if (abs(gBGImg.SliceView) = kAxView0) or(abs(gBGImg.SliceView) = kCoroView0) or(abs(gBGImg.SliceView) = kSagView0) then begin //only show a single slice + if abs(gBGImg.SliceView) <> kAxView0 then + lH := gBGImg.ScrnDim[3] //Coronal and Sagitall height is Z + else + lH := gBGImg.ScrnDim[2]; //Axial height is Y + + if abs(gBGImg.SliceView) <> kSagView0 then + lW := gBGImg.ScrnDim[1] //Axial and Coronal width is X + else + lW := gBGImg.ScrnDim[2]; //Sagittal width is Y + lH := lH+1; + lW := lW + 1; + end else if gBGImg.SingleRow then begin //show 3 slices in row + lW := gBGImg.ScrnDim[2]+gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1]; + lWpanel := lWpanel-2- (2*gBGImg.ImageSeparation); + if gBGImg.ScrnDim[2]>gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2]+1 + else + lH := gBGImg.ScrnDim[3]+1 + end else begin //show three slices, 2 in top row, one in bottom + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2]+4; + lWpanel := lWpanel - 1 - gBGImg.ImageSeparation; + lH := gBGImg.ScrnDim[3]+gBGImg.ScrnDim[2]+4; + lHpanel := lHpanel - 1 - gBGImg.ImageSeparation; + end; + + if (lW<1) or (lH < 1) or (lHpanel < 1) or (lWpanel < 1) then + exit; + lZoomw := lWpanel/ lW; + lZoomh := lHpanel/ lH; + if lZoomw < lZoomh then + lPrimaryZoom := lZoomw + else + lPrimaryZoom := lZoomh; + if (gBGImg.ZoomPct = 0) then begin//nearest integer + lPrimaryZoom := trunc(lPrimaryZoom); + if lPrimaryZoom < 1 then + lPrimaryZoom := 1; + end; + SetPct(lPrimaryZoom,lPrimaryZoom,lPrimaryZoom); +543: //for single slice views, set residual ... + if gBGImg.SliceView = kMultiView then + exit;//All orientations use primary zoom + if gBGImg.SliceView < 0 then begin + l2ndZoom := 0; + goto 641; + end; + lWpanel := lWpanel-2- (2*gBGImg.ImageSeparation); //see if we can fit in two more images horizontally + //note all images are currently set to primary zooom, so we will read PGImageAx + lWpanel := lWPanel - round(lW*lPrimaryZoom); + l2ndZoom := 0; + if lWpanel < 3 then goto 641; + if (abs(gBGImg.SliceView) = kAxView0) then + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2] //CorX + SagY + else if (abs(gBGImg.SliceView) = kCoroView0) then + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2] //AxX + SagY + else //(gBGImg.SliceView = kSagView) + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1];//AxX+CorX + if lW < 1 then //avoid div0 + lZoomw := 0 + else + lZoomw := lWpanel/ lW; + if gBGImg.ScrnDim[2] > gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2] + else + lH := gBGImg.ScrnDim[3]; + if lH < 1 then //avoid div0 + lZoomh := 0 + else + lZoomh := lHpanel/ lH; + if lZoomw < lZoomh then + l2ndZoom := lZoomw + else + l2ndZoom := lZoomh; +641: + if (abs(gBGImg.SliceView) = kAxView0) then + SetPct(lPrimaryZoom,l2ndZoom,l2ndZoom) + else if (abs(gBGImg.SliceView) = kCoroView0) then + SetPct(l2ndZoom,lPrimaryZoom,l2ndZoom) + else //(gBGImg.SliceView = kSagView) + SetPct(l2ndZoom,l2ndZoom,lPrimaryZoom); + +end; + +(*function ComputeTripleZoom : single; +var + lHc,lWc,lH,lW: integer; + lZw,lZh: single; +begin + result := 1; + lHc := ImgForm.TriplePanel.ClientHeight-1; + lWc := ImgForm.TriplePanel.ClientWidth-1; + //gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + if gBGImg.ZoomPct > 0 then begin + result := gBGImg.ZoomPct / 100; + exit; + end; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + case gBGImg.SliceView of + kSagView: lH := gBGImg.ScrnDim[3]; + kCoroView: lH := gBGImg.ScrnDim[3]; + else lH := gBGImg.ScrnDim[2]; + end;//case + case gBGImg.SliceView of + kSagView: lW := gBGImg.ScrnDim[2]; + kCoroView: lW := gBGImg.ScrnDim[1]; + else lW := gBGImg.ScrnDim[1]; + end;//case + lH := lH+1; + lW := lW + 1; + + end else if gBGImg.SingleRow then begin //show 3 slices in row + lW := gBGImg.ScrnDim[2]+gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1]; + lWc := lWc-2- (2*gBGImg.ImageSeparation); + if gBGImg.ScrnDim[2]>gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2]+1 + else + lH := gBGImg.ScrnDim[3]+1 + end else begin //show three slices, 2 in top row, one in bottom + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2]+4; + lWc := lWc - 1 - gBGImg.ImageSeparation; + lH := gBGImg.ScrnDim[3]+gBGImg.ScrnDim[2]+4; + lHc := lHc - 1 - gBGImg.ImageSeparation; + + end; + if (lW<1) or (lH < 1) or (lHc < 1) or (lWc < 1) then + exit; + lZw := lWc/ lW; + lZh := lHc/ lH; + if lZw < lZh then + result := lZw + else + result := lZh; + if (gBGImg.ZoomPct = 0) then begin//nearest integer + result := trunc(result); + if result < 1 then + result := 1; + end; +end; *) + +procedure ImageLT (lLScroll,lTScroll,lL,lT: integer; var lImage: TImage); +begin + //if (lImage.Left = lL) and (lImage.Top = lT) then + // exit; ImgForm.Caption := 'a'+inttostr(lL)+'x'+inttostr(lT)+'debug'+inttostr(lImage.Left)+'x'+inttostr(lImage.Top); + //if lImage.Left <> lL then + lImage.Left := lL-lLScroll; + //if lImage.Top <> lT then + lImage.Top := lT-lTScroll; +end; + +procedure RefreshImages; +var + lL,lT: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + ImgForm.PGImageAx.Width := 0; + ImgForm.PGImageSag.Width := 0; + ImgForm.PGImageCor.Width := 0; + exit; + end; + {$IFDEF FPC} + lL := 0; + lT := 0; + {$ELSE} + lL := imgForm.Triplepanel.HorzScrollBar.Position; + lT := imgForm.Triplepanel.VertScrollBar.Position; + {$ENDIF} + //imgform.Caption := inttostr(lL)+'x'+inttostr(lT); + ComputeTripleZoom; + ImgForm.PGImageAx.visible := ImgForm.PGImageAx.tag <> 0; + ImgForm.PGImageCor.visible := ImgForm.PGImageCor.tag <> 0; + ImgForm.PGImageSag.visible := ImgForm.PGImageSag.tag <> 0; + if (gBGImg.SliceView = kMultiView) and (not gBGImg.SingleRow) then begin + //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageSag); + end else begin + //Sag is left-most + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + //Next is coronal... + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + //Axial is rightmost + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1,1,ImgForm.PGImageAx); + end; +(* //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end; + + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if (gBGImg.SliceView = kAxView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageAx); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kCoroView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kSagView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := true; + end; + end else if gBGImg.SingleRow then begin + //Sag is left-most + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + //Next is coronal... + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + //Axial is rightmost + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1,1,ImgForm.PGImageAx); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end else begin + //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end; *) + DrawAxial(round(gBGImg.ZViewCenter),-1); + DrawSag (round(gBGImg.XViewCenter),-1); + DrawCor (round(gBGImg.YViewCenter),-1); +end; //RefreshImages + +(*procedure RefreshImages; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + ImgForm.PGImageAx.Width := 0; + ImgForm.PGImageSag.Width := 0; + ImgForm.PGImageCor.Width := 0; + exit; + end; + gTripleZoom100 := trunc(100*ComputeTripleZoom); + if gTripleZoom100 < 1 then + gTripleZOom100 := 1; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if (gBGImg.SliceView = kAxView) then begin + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kCoroView) then begin + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kSagView) then begin + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := true; + end; + end else if gBGImg.SingleRow then begin + ImgForm.PGImageCor.Left := round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1; + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end else begin + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.Top := round(gBGImg.ScrnDim[3]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + + end; + DrawAxial(round(gBGImg.ZViewCenter),-1); + DrawSag (round(gBGImg.XViewCenter),-1); + DrawCor (round(gBGImg.YViewCenter),-1); +end; //RefreshImages +*) +(*function ComputeTripleZoom : single; +var + lHc,lWc,lH,lW: integer; + lZw,lZh: single; +begin + result := 1; + lHc := ImgForm.TriplePanel.ClientHeight-1; + lWc := ImgForm.TriplePanel.ClientWidth-1; + //gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + if gBGImg.ZoomPct > 0 then begin + result := gBGImg.ZoomPct / 100; + exit; + end; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + case gBGImg.SliceView of + kSagView: lH := gBGImg.ScrnDim[3]; + kCoroView: lH := gBGImg.ScrnDim[3]; + else lH := gBGImg.ScrnDim[2]; + end;//case + case gBGImg.SliceView of + kSagView: lW := gBGImg.ScrnDim[2]; + kCoroView: lW := gBGImg.ScrnDim[1]; + else lW := gBGImg.ScrnDim[1]; + end;//case + lH := lH+1; + lW := lW + 1; + + end else if gBGImg.SingleRow then begin //show 3 slices in row + lW := gBGImg.ScrnDim[2]+gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1]; + lWc := lWc-4; + if gBGImg.ScrnDim[2]>gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2]+1 + else + lH := gBGImg.ScrnDim[3]+1 + end else begin //show three slices, 2 in top row, one in bottom + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2]+4; + lWc := lWc - 2; + lH := gBGImg.ScrnDim[3]+gBGImg.ScrnDim[2]+4; + lHc := lHc - 2; + + end; + if (lW<1) or (lH < 1) or (lHc < 1) or (lWc < 1) then + exit; + lZw := lWc/ lW; + lZh := lHc/ lH; + if lZw < lZh then + result := lZw + else + result := lZh; + if (gBGImg.ZoomPct = 0) then begin//nearest integer + result := trunc(result); + if result < 1 then + result := 1; + end; +end; + +procedure RefreshImages; +//var +// lZoom: single; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + ImgForm.PGImageAx.Width := 0; + ImgForm.PGImageSag.Width := 0; + ImgForm.PGImageCor.Width := 0; + //yui + exit; + end; + gTripleZoom100 := trunc(100*ComputeTripleZoom); + if gTripleZoom100 < 1 then + gTripleZOom100 := 1; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if (gBGImg.SliceView = kAxView) then begin + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kCoroView) then begin + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kSagView) then begin + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := true; + end; + end else if gBGImg.SingleRow then begin + ImgForm.PGImageCor.Left := round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+2; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+3; + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end else begin + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+2; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.Top := round(gBGImg.ScrnDim[3]*gTripleZoom100/100)+2; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + + end; + DrawAxial(round(gBGImg.ZViewCenter),-1); + DrawSag (round(gBGImg.XViewCenter),-1); + DrawCor (round(gBGImg.YViewCenter),-1); +end; //RefreshImages + *) + {$IFNDEF FPC} +function PNGFilterSize(lFilter: integer; lImage: TImage): integer; +var + lStream: TMemoryStream; + lPNGFilters : TEncodeFilterSet; +begin + result := 0; + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + lStream := TMemoryStream.Create; + try + with TPNGImage.Create do begin + //gPNGSaveFilters := []; + case lFilter of + 1: lPNGFilters := [efSub]; + 2: lPNGFilters := [efUp]; + 3: lPNGFilters := [efAverage]; + 4: lPNGFilters := [efPaeth];//Include(SaveFilters, efPaeth); + else lPNGFilters := [efNone];//[efNone,efSub,efUp,efAverage,efPaeth]; + end; + Filter := lPNGFilters; + //filters(efNone, efSub, efUp, efAverage, efPaeth); + Assign(lImage.Picture.Graphic); + SaveToStream(lStream); + result := (lStream.Size); + end; + finally + lStream.Free; + end; //Stream TRY..FINALLY +end; + +procedure SaveImgAsPNGBMP (lImage: TImage); +var + lPNGFilter,lMinFilter,lMinFilterSz,lFilter,lSz: integer; + lPNGFilters : TEncodeFilterSet; +begin + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + lPNGFilter := 5; + if lPNGFilter = 5 then begin //find PNG filter for smallest filesize + lMinFilter := 0; + lMinFilterSz := PNGFilterSize(0,lImage); + for lFilter := 1 to 4 do begin + Application.ProcessMessages; + lSz := PNGFilterSize(lFilter,lImage); + if lSz < lMinFilterSz then begin + lMinFilter := lFilter; + lMinFilterSz := lSz; + end; + end; //Filter 1..4 try each filter + end else + lMinFilter := lPNGFilter; //if look for smallest filter + case lMinFilter of + 1: lPNGFilters := [efSub]; + 2: lPNGFilters := [efUp]; + 3: lPNGFilters := [efAverage]; + 4: lPNGFilters := [efPaeth];//Include(SaveFilters, efPaeth); + else lPNGFilters := [efNone];//[efNone,efSub,efUp,efAverage,efPaeth]; + end; + with TPNGImage.Create do begin + //filters(efNone, efSub, efUp, efAverage, efPaeth); + Filter := lPNGFilters; + Assign(lImage.Picture.Bitmap); + SaveToFile(ChangeFileExt(ImgForm.SaveDialog1.FileName,'.png')); + free; + end; +end; + {$ELSE} + procedure SaveImgAsPNGCore (lImage: TBitmap; lFilename: string); + var + PNG: TPortableNetworkGraphic; + begin + if (lImage = nil) then begin + Showmessage('No image found to save.'); + exit; + end; + PNG := TPortableNetworkGraphic.Create; + try + PNG.Assign(lImage); //Convert data into png + PNG.SaveToFile(ChangeFileExt(lFilename,'.png')); + finally + PNG.Free; + end + end; + +procedure SaveImgAsPNGBMP (lImage: TImage); +begin + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + {$IFDEF ENDIAN_BIG} + ImgForm.SaveDialog1.Filter := 'PNG (*.png)|*.png;Bitmap|*.xpm'; + ImgForm.SaveDialog1.DefaultExt := '.png'; + {$ELSE} + ImgForm.SaveDialog1.Filter := 'PNG (*.png)|*.png;Bitmap|*.bmp'; + ImgForm.SaveDialog1.DefaultExt := '.png'; + {$ENDIF} + if not ImgForm.SaveDialog1.Execute then exit; + //showmessage(ImgForm.SaveDialog1.FileName); + if upcaseext(ImgForm.SaveDialog1.Filename)='.BMP' then + lImage.Picture.Bitmap.SaveToFile(ImgForm.SaveDialog1.Filename) + else + SaveImgAsPNGCore(lImage.Picture.Bitmap,ImgForm.SaveDialog1.Filename); +end; + {$ENDIF} + +(*procedure SaveImgAsBMP (lImage: TImage); +begin + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + ImgForm.SaveDialog1.Filter := 'Bitmap|*.bmp'; + ImgForm.SaveDialog1.DefaultExt := '*.bmp'; + if not ImgForm.SaveDialog1.Execute then exit; + lImage.Picture.Bitmap.SaveToFile(ImgForm.SaveDialog1.Filename); +end;*) + + +procedure UndoVolVOI; +var lTempBuf: ByteP; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems < 1 then exit; + if gBGImg.VOIUndoVolItems <> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then exit; + GetMem(lTempBuf,gBGImg.VOIUndoVolItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lTempBuf^,gBGImg.VOIUndoVolItems); + Move(gBGImg.VOIUndoVol^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVolItems); + Move(lTempBuf^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + FreeMem(lTempBuf); + +end; + +procedure FreeUndoVol; +begin + if gBGImg.VOIUndoVolItems > 0 then + freemem(gBGImg.VOIUndoVol); + gBGImg.VOIUndoVolItems := 0; + if gBGImg.RenderDepthBufferItems > 0 then + freemem(gBGImg.RenderDepthBuffer); + gBGImg.RenderDepthBufferItems := 0; +end; + +procedure CreateUndoVol; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems < 1 then exit; + gBGImg.VOIUndoSlice := 1; + gBGImg.VOIUndoOrient := 4; + if gBGImg.VOIUndoVolItems <> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then begin + FreeUndoVol; + gBGImg.VOIUndoVolItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + getmem(gBGImg.VOIUndoVol,gBGImg.VOIUndoVolItems); + end; + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); +end; + +function IsVOIOpen: boolean; +begin + result := false; + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems = gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) + and (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0) then + result := true; +end; + +function SameAsBG(var lBGImg: TBGImg; var lHdr: TMRIcroHdr): boolean; +var + lMatrixBG: TMatrix; + i, j: Integer; +begin + result := false; + for i := 1 to 3 do //999 + if lHdr.NIFTIhdr.dim[i] <>lBGImg.ScrnDim[i] then //999 + exit; //999 + lMatrixBG := Matrix3D ( lBGImg.Scrnmm[1],0,0,-lBGImg.Scrnmm[1]*(lBGImg.ScrnOri[1]-1), + 0,lBGImg.Scrnmm[2],0,-lBGImg.Scrnmm[2]*(lBGImg.ScrnOri[2]-1), + 0,0,lBGImg.Scrnmm[3],-lBGImg.Scrnmm[3]*(lBGImg.ScrnOri[3]-1), + 0,0,0,1); + for i := 1 to 3 do + for j := 1 to 4 do begin + if lMatrixBG.matrix[i,j] <> lHdr.Mat.matrix[i,j] then exit; + end; + //showmessage('same'); + //for i := 1 to 3 do if (lBGIMg.ScrnDim[i])<>lHdr.NIFTIhdr.dim[i] then exit; + result := true; +end; + +procedure EnsureVOIOpen; +var lMaxi: integer; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems = gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then exit; + //showmessage(inttostr(gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems)); + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + Freemem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer); + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[1] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[2] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[3] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[1] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[1]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[2] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[2]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[3] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[3]; + gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + + gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + Getmem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + fillchar(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,0); + lMaxI := maxint; + LoadMonochromeLUT(lMaxi,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + if (gBGImg.Resliced) and (not SameAsBG(gBGImg,gMRIcroOverlay[kBGOverlayNum])) then //fv + showmessage('Warning: you are about to draw a region of interest on an resliced image, which can problems with SPM and FSL. Solution: choose Help/Preferences and uncheck ''Reorient images when loading'', then reload your image.'); +end; + +function SelectedImageNum: Integer; +begin + result := gSelectedImageNum; + if (result < 1) or (result > 3) then + result := 1; +{ with ImgForm do begin + if TriplePanel.BorderStyle = bsSingle then + result := 3 + else if TriplePanel.BorderStyle = bsSingle then + result := 2 + else + result := 1 + end;} //with ImgForm +end;//SelectedImageNum + + +function ComputeInvZoomShl10(lSelectedImageNum: integer; var lImage: TImage): integer; +const + kSHval = 1 shl 10; +var lPGWid,lImgWid: integer; +begin + result := kSHval;//100% + lPGWid := lImage.Picture.Bitmap.Width; + if lImage.Tag > 0 then begin + result := round((100/lImage.Tag)*kShVal); + exit; + end; + if lSelectedImageNum = 2 then + lImgWid := gBGImg.ScrnDim[2] //Sag - horizontal is Y + else + lImgWid := gBGImg.ScrnDim[1]; //cor and ax - horizontal is X + If (lPGWid < 1) or (lImgWid < 1) then exit; + result := round(lImgWid/lPGWid* kShVal); +end; + +function ComputeZoomPct(lSelectedImageNum: integer; var lImage: TImage): integer; +var lPGWid,lImgWid: integer; +begin + result := 100;//100% + lPGWid := lImage.Picture.Bitmap.Width; + if lImage.Tag > 0 then begin + result := lImage.Tag; + exit; + end; + if lSelectedImageNum = 2 then + lImgWid := gBGImg.ScrnDim[2] //Sag - horizontal is Y + else + lImgWid := gBGImg.ScrnDim[1]; //cor and ax - horizontal is X + If (lPGWid < 1) or (lImgWid < 1) then exit; + result := round(lPGWid/lImgWid* 100); +end; //ComputeZoomPct + +procedure ScaleScrn2BMP (var lX, lY: integer;lImage: TImage); +var lScale: single; +begin + if (lImage.Height = 0) or (lImage.Width = 0) then exit; + lScale := lImage.Picture.Bitmap.Height /lImage.Height; + lX := round(lX * lScale); + lY := round(lY * lScale); +end; + +procedure ScaleBMP2Draw (var InvZoomShl10,lX, lY, lPanel: integer; lImage: TImage); +var + pxHt, pxWid : integer; + begin + {$IFDEF Darwin} + //please check if next line required for this OS! 8/8/2014 + {$ENDIF} + lX := lX + 1; + lY := lY + 1; + if lPanel = 2 then + pxWid := gBGImg.ScrnDim[2] + else + pxWid := gBGImg.ScrnDim[1]; + if lPanel = 1 then + pxHt := gBGImg.ScrnDim[2] + else + pxHt := gBGImg.ScrnDim[3]; + //imgForm.statusLabel.caption := inttostr(lPanel)+' '+inttostr(lX)+' '+inttostr(ceil(lX * (pxWid/lImage.Width))); + lX := ceil(lX * (pxWid/lImage.Width)); + lY := ceil(lY * (pxHt/lImage.Height)); + //if (gBGImg.FlipSag) and (lPanel = 2) then + // lX := (lImage.Width-lX) + 1; + if (gBGImg.FlipAx) and (lPanel = 1) then + lY := (lImage.Height-lY) + 1; + + end; + +(*procedure ScaleBMP2DrawOld (var InvZoomShl10,lX, lY, lPanel: integer; lImage: TImage); +var + pxHt, pxWid : integer; +begin + //lScaleShl10 := ComputeInvZoomShl10(SelectedImageNum,lImage); + //ImgForm.StatusLabel.Caption := inttostr(InvZoomShl10); + {$IFDEF Darwin} + please check if next line required for this OS! 8/8/2014 + {$ENDIF} + lX := lX + 1; + //imgForm.statusLabel.caption := inttostr(lPanel)+' '+inttostr(lX)+' '+inttostr(lY); + if (gBGImg.FlipSag) and (lPanel = 2) then + lX := ((lImage.Width-lX) * InvZoomShl10) shr 10 + else if (lX < 1) then + lX := 0 + else + lX := (lX * InvZoomShl10) shr 10; + if (gBGImg.FlipAx) and (lPanel = 1) then + lY := ((lImage.Height-lY) * InvZoomShl10) shr 10 + else if (lY < 1) then + lY := 0 + else + lY := (lY * InvZoomShl10) shr 10; +end; *) + +function ImageZoomPct( var lImage: TImage): integer; +begin + result := ComputeZoomPct(SelectedImageNum,lImage); +end; + +procedure DrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +var lL,lT,lW,lH,lZoomPct: integer; +lOffset: single; +begin + lZoomPct := ImageZoomPct(lImage); + //amx - must match XYscrn2Img and DrawXBar + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + //lL := lHorPos-1; + if lZoomPct > 100 then lOffset := 0.5 else + lOffset := 0; + lL := ceil((lHorPos-lOffset) * lZoomPct/100)-1;// div 100; //-1 as indexed from zero, 0.5 for middle of slice + lT := lH-ceil((lVerPos-lOffset) * lZoomPct/100.0);// div 100; + //ImgForm.Caption := inttostr(lZoomPct); + //lL := (lHorPos * lZoomPct) div 100; + //lT := (lVerPos * lZoomPct) div 100; + + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + //lImage.Canvas.Pen.Color:=$03FF0000; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + //next horizontal lines + lImage.Canvas.MoveTo(0,lT); + lImage.Canvas.LineTo(lL-gBGImg.XBarGap,lT); + lImage.Canvas.MoveTo(lL+gBGImg.XBarGap,lT); + lImage.Canvas.LineTo(lW,lT); + //next vertical lines + lImage.Canvas.MoveTo(lL,0); + lImage.Canvas.LineTo(lL,lT-gBGImg.XBarGap); + lImage.Canvas.MoveTo(lL,lT+gBGImg.XBarGap); + lImage.Canvas.LineTo(lL,lH); +end; //Proc DrawXBar + +function Scrn2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +var lRange,lMin,lMax: single; +begin + lMin := lHdr.WindowScaledMin; + lMax := lHdr.WindowScaledMax; + if lMin > lMax then begin + lRange := lMin; + lMin := lMax; + lMax := lRange; + end; + lRange := lMax - lMin; + result := lMin+(lRaw/255*lRange); +end; + +procedure SaveMRIcroROI (lFilename: string); +const + kMax12bit = 4095; + kMax16bit = (256*256)-1; + kMax20bit = (16*256*256)-1; + k20v16bit = kMax20bit - kMax16bit; + kMaxRuns = 10000; + kMaxFile = 65536; +var lFilePos,lZPos,lZ,lSliceSz,lSliceOffset,lPrevVoxel,lVoxel,lRun,lnRuns,lSlicePos: integer; + lRunStartRA,lRunLengthRA : array [1..kMaxRuns] of longint; + lOutputRA: array [1..kMaxFile] of word; + lF: File; + lBigFormat: boolean; +begin + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + if lSliceSz > 65535 then + lBigFormat := true + else + lBigFormat := false; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems<> (lSLiceSz*lZ) then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + lSliceOffset := 0; + lFilePos := 0; + for lZPos := 1 to lZ do begin + lnRuns := 0; + lPrevVoxel := 0; + for lSlicePos := 1 to lSliceSz do begin + lVoxel := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lSlicePos+lSliceOffset]; + if lVoxel > 1 then lVoxel := 1; + if lVoxel <> lPrevVoxel then begin //start or end run + lPrevVoxel := lVoxel; + if lnRuns = kMaxRuns then + Showmessage('Error: To many runs...') + else if lVoxel = 1 then begin //start new run + inc(lnRuns); + lRunStartRA[lnRuns] := lSlicePos; + + end else begin + lRunLengthRA[lnRuns] := lSlicePos-lRunStartRA[lnRuns]; + end; + end; //if start or end + if (lVoxel > 0) and ((lSlicePos-lRunStartRA[lnRuns])>4090) then begin //end this run, begin new + lRunLengthRA[lnRuns] := lSlicePos-lRunStartRA[lnRuns]+1; + lPrevVoxel := 0; + end; //run >4090 + end; //for each voxel in slice + if lPrevVoxel = 1 then + lRunLengthRA[lnRuns] := lSliceSz-lRunStartRA[lnRuns]+1; + lSliceOffset := lSliceOffset+lSliceSz; + if lnRuns > 0 then begin + inc(lFilePos); + lOutputRA[lFilePos] := lZPos; //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := 2*(lnRuns+1); //words to store this slice: 2 per run, plus 2 for slice number and size + if lBigFormat then begin + for lRun := 1 to lnRuns do begin + inc(lFilePos); + lOutputRA[lFilePos] := (lRunStartRA[lRun] and kMax16bit); //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := (lRunLengthRA[lRun] and kMax12bit)+ ((lRunStartRA[lRun] and k20v16bit)shr 4) ; //record slice number + end; + end else begin + for lRun := 1 to lnRuns do begin + inc(lFilePos); + lOutputRA[lFilePos] := lRunStartRA[lRun]; //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := lRunLengthRA[lRun]; //record slice number + end;//for each run + end; //small format + end; //if data on this slice + end; //for lZ + if lFilePos = 0 then begin + Showmessage('No VOIs detected - unable to create blank MRIcro ROI.'); + exit; + end; + if lBigFormat then + lOutputRA[1] := lOutputRA[1]+ 32768; //set MSB to 1 to denote this file uses 12/20 bytes + Filemode := 1; + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lFilePos*2); + BlockWrite(lF,lOutputRA, 1 {, NumWritten}); + CloseFile(lF); + Filemode := 2; +end; + +procedure SaveAsVOIorNIFTIinnercore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... + kImgOffset2 = 480; //header is 348 bytes, but 352 is divisible by 8... + lNII2 = false; +var + lHdr: TNIFTIhdr; + lBuff: ByteP; + lF: File; + lXmm,lYmm,lZmm: single; + lUnCompressedFilename,lExt: string; + lImgOffset,lC,lFSize: integer; + lMat: TMatrix; +begin + lExt := UpCaseExt(lFileName); + move(lNiftiHdr,lHdr,sizeof(lHdr)); + if (lExt='.VOI') then begin + lHdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.intent_name[1] := 'B';//Binary + lHdr.scl_slope := 1/kVOI8bit; + lHdr.scl_inter := 0; + end; + if lnVol > 1 then begin + lHdr.dim[0] := 4;//3D july2006 + lHdr.dim[4] := lnVol;//3D july2006 + end else begin + lHdr.dim[0] := 3;//3D july2006 + lHdr.dim[4] := 1;//3D july2006 + end; + //if not (lImgBufferItems = (lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3])) then begin //july2006 + //below - images are repositioned to match background + if gBGImg.Resliced then begin + lHdr.dim[1] := gBGImg.ScrnDim[1]; + lHdr.dim[2] := gBGImg.ScrnDim[2]; + lHdr.dim[3] := gBGImg.ScrnDim[3]; + lHdr.pixdim[1] := gBGImg.ScrnMM[1]; //Apr07 + lHdr.pixdim[2] := gBGImg.ScrnMM[2]; //Apr07 + lHdr.pixdim[3] := gBGImg.ScrnMM[3]; //Apr07 + lHdr.sform_code :=kNIFTI_XFORM_SCANNER_ANAT; //10102006 + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + + lHdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; //May07 + lMat:= Matrix3D ( gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3], + 0,0,0,1); + nifti_mat44_to_quatern( lMat,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lXmm,lYmm,lZmm,lHdr.pixdim[0]); + end else begin + //Apr07 - for unresliced data, use raw header for data + end; + case lImgBufferBPP of + 4: begin + {lSingleRA := SingleP(lImgBuffer); + for lPos := 1 to 4 do + fx(22,lSingleRA^[lPos]);} + lHdr.bitpix := 32; + lHdr.datatype := kDT_FLOAT;//note 32-bit integers saved internally as 32-bit float + end; + 3: begin + lHdr.bitpix := 24; + lHdr.datatype := kDT_RGB; + end; + + 2: begin + lHdr.bitpix := 16; + lHdr.datatype := kDT_SIGNED_SHORT; + end; + 1: begin + lHdr.bitpix := 8; + lHdr.datatype := kDT_UNSIGNED_CHAR; + //lHdr.scl_inter := lHdr.WindowScaledMin; + //lHdr.scl_slope := (lHdr.WindowScaledMax-lHdr.WindowScaledMin) /255; + end; + else begin + showmessage('Error: Unsupported bytes per voxel: '+inttostr(lImgBufferBPP)); + exit; + end; + end; + if (lExt='.IMG') or (lExt ='.HDR') then begin + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + lHdr.vox_offset := 0; + Filemode := 1; + //next write header data as .hdr + lFilename := changeFileExt(lFilename,'.hdr'); + AssignFile(lF, lFileName); + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lHdr, 1); + CloseFile(lF); + //next write image data as .img + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lImgBufferItems*lImgBufferBPP); + BlockWrite(lF,lImgBuffer^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //separate header + + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lImgOffset := kImgOffset; + lHdr.vox_offset := lImgOffset;//352 bytes + lFSize := lImgOffset+(lImgBufferItems*lImgBufferBPP); + getmem(lBuff,lFSize); + + move(lHdr,lBuff^,sizeof(lHdr)); + //Next: NIfTI 1.1 requires bytes 349..352 set to zero when no XML information + + lC := lImgOffset; + lBuff^[lC-3] := 0; + lBuff^[lC-2] := 0; + lBuff^[lC-1] := 0; + lBuff^[lC] := 0; + lC := lImgOffset+1; + //move(lImgBuffer^[1],lBuff[lC],lImgBufferItems*lImgBufferBPP); + + move(lImgBuffer^,lBuff^[lC],lImgBufferItems*lImgBufferBPP); + if (lExt='.NII') then begin + Filemode := 1; + AssignFile(lF, lFileName); + Rewrite(lF,lFSize); + BlockWrite(lF,lBuff^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //uncompressed + lUnCompressedFilename := changefileextx(lFilename,'.nii'); + GZipBuffer(lUnCompressedFilename,lFilename,lBuff,lFSize,false); + freemem(lBuff); +end; + +procedure SaveAsVOIorNIFTIcoreOrtho (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +var + lISize: integer; + lTempHdr: TMRIcroHdr; +begin + if not gBGImg.UseReorientHdr then + exit; + lTempHdr.NIFTIhdr := lNIftIHdr; + lISize := (lImgBufferItems*lImgBufferBPP); + GetMem(lTempHdr.ImgBufferUnaligned ,lISize + 16); + {$IFDEF FPC} + lTempHdr.ImgBuffer := align(lTempHdr.ImgBufferUnaligned,16); + {$ELSE} + lTempHdr.ImgBuffer := ByteP($fffffff0 and (integer(lTempHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + lTempHdr.ImgBufferItems := lImgBufferItems; + lTempHdr.ImgBufferBPP := lImgBufferBPP; + move(lImgBuffer^,lTempHdr.ImgBuffer^,lISize); + + Reslice_Img_To_Unaligned (gBGImg.ReorientHdr, lTempHdr ,true); + SaveAsVOIorNIFTIinnercore (lFilename, lTempHdr.ImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lTempHdr.NIFTIhdr); + //restore orientation + //12/2010 remove this line - we changed TMPHdr lNiftiHdr := lTempHdr.NIFtiHdr; + //reslease memory + FreeMem(lTempHdr.ImgBufferUnaligned); +end; + +procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +begin + //10/2007 - scl_slope; + //lExt := UpCaseExt(lFileName); + if DiskFreeEx(lFilename) < (kImgOffset+(lImgBufferItems*lImgBufferBPP)) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; + if FileExistsEX(lFileName) then begin + case MessageDlg('Overwrite the file named '+lFileName+'?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; //file exists + if not gBGImg.UseReorientHdr then + SaveAsVOIorNIFTIinnercore (lFilename, lImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lNiftiHdr) + else + SaveAsVOIorNIFTIcoreOrtho (lFilename, lImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lNiftiHdr); +end; + +(*procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +var + lHdr: TNIFTIhdr; + lBuff: ByteP; + lMat: TMatrix; + lXmm,lYmm,lZmm: single; + lF: File; + lUnCompressedFilename,lExt: string; + lC,lFSize: integer; +begin + lExt := UpCaseExt(lFileName); + if DiskFreeEx(lFilename) < (kImgOffset+(lImgBufferItems*lImgBufferBPP)) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; + if FileExistsEX(lFileName) then begin + case MessageDlg('Overwrite the file named '+lFileName+'?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; //file exists + move(lNiftiHdr,lHdr,sizeof(lHdr)); + if (lExt='.VOI') then begin + lHdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.intent_name[1] := 'B';//Binary + lHdr.scl_slope := 1/kVOI8bit; + lHdr.scl_inter := 0; + end; + if lnVol > 1 then begin + lHdr.dim[0] := 4;//3D july2006 + lHdr.dim[4] := lnVol;//3D july2006 + end else begin + lHdr.dim[0] := 3;//3D july2006 + lHdr.dim[4] := 1;//3D july2006 + end; + //if not (lImgBufferItems = (lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3])) then begin //july2006 + //below - images are repositioned to match background + if gBGImg.Resliced then begin + lHdr.dim[1] := gBGImg.ScrnDim[1]; + lHdr.dim[2] := gBGImg.ScrnDim[2]; + lHdr.dim[3] := gBGImg.ScrnDim[3]; + lHdr.pixdim[1] := gBGImg.ScrnMM[1]; //Apr07 + lHdr.pixdim[2] := gBGImg.ScrnMM[2]; //Apr07 + lHdr.pixdim[3] := gBGImg.ScrnMM[3]; //Apr07 + lHdr.sform_code :=kNIFTI_XFORM_SCANNER_ANAT; //10102006 + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + + lHdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; //May07 + lMat:= Matrix3D ( gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3], + 0,0,0,1); + nifti_mat44_to_quatern( lMat,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lXmm,lYmm,lZmm,lHdr.pixdim[0]); + end else begin + //Apr07 - for unresliced data, use raw header for data + end; + case lImgBufferBPP of + 4: begin + {lSingleRA := SingleP(lImgBuffer); + for lPos := 1 to 4 do + fx(22,lSingleRA^[lPos]);} + lHdr.bitpix := 32; + lHdr.datatype := kDT_FLOAT;//note 32-bit integers saved internally as 32-bit float + end; + 3: begin + lHdr.bitpix := 24; + lHdr.datatype := kDT_RGB; + end; + + 2: begin + lHdr.bitpix := 16; + lHdr.datatype := kDT_SIGNED_SHORT; + end; + 1: begin + lHdr.bitpix := 8; + lHdr.datatype := kDT_UNSIGNED_CHAR; + //lHdr.scl_inter := lHdr.WindowScaledMin; + //lHdr.scl_slope := (lHdr.WindowScaledMax-lHdr.WindowScaledMin) /255; + end; + else begin + showmessage('Error: Unsupported bytes per voxel: '+inttostr(lImgBufferBPP)); + exit; + end; + end; + if (lExt='.IMG') or (lExt ='.HDR') then begin + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + lHdr.vox_offset := 0; + Filemode := 1; + //next write header data as .hdr + lFilename := changeFileExt(lFilename,'.hdr'); + AssignFile(lF, lFileName); + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lHdr, 1); + CloseFile(lF); + //next write image data as .img + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lImgBufferItems*lImgBufferBPP); + BlockWrite(lF,lImgBuffer^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //separate header + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lHdr.vox_offset := kImgOffset;//352 bytes + lFSize := kImgOffset+(lImgBufferItems*lImgBufferBPP); + getmem(lBuff,lFSize); + move(lHdr,lBuff^,sizeof(lHdr)); + //Next: NIfTI 1.1 requires bytes 349..352 set to zero when no XML information + lC := kImgOffset; + lBuff^[lC-3] := 0; + lBuff^[lC-2] := 0; + lBuff^[lC-1] := 0; + lBuff^[lC] := 0; + lC := kImgOffset+1; + //move(lImgBuffer^[1],lBuff[lC],lImgBufferItems*lImgBufferBPP); + + move(lImgBuffer^,lBuff^[lC],lImgBufferItems*lImgBufferBPP); + if (lExt='.NII') then begin + Filemode := 1; + AssignFile(lF, lFileName); + Rewrite(lF,lFSize); + BlockWrite(lF,lBuff^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //uncompressed + lUnCompressedFilename := changefileext(lFilename,'.nii'); + GZipBuffer(lUnCompressedFilename,lFilename,lBuff,lFSize,false); + freemem(lBuff); +end;*) + +{$IFDEF FPC} +// http://bugs.freepascal.org/view.php?id=7797 +function GetExtensionFromFilterAtIndex(Filter: String; Index: Integer): String; +var + p, pipe: Integer; +begin + Result := ''; + if Index < 1 then Exit; + p := 0; + pipe := 0; + while (p < Length(Filter)) do begin + Inc(p); + if Filter[p] = '|' then Inc(pipe); + if (pipe = 2 * (Index - 1)) then break; + end; + if (p = length(Filter)) then exit; + System.Delete(Filter,1,p); + p := Pos('|',Filter); + if (p = 0) then exit; + System.Delete(Filter,1,p); + Filter := Copy(Filter,1,MaxInt); + p := Pos(';',Filter); + pipe := Pos('|',Filter); + if (pipe < p) or (p = 0) then p := pipe; + if (p > 0) then System.Delete(Filter,p,Length(Filter) - p +1); + Filter := StringReplace(Filter, '*', '',[rfReplaceAll, rfIgnoreCase]); + if (Pos('?',Filter) > 0) {or (Pos('*',Filter) > 0)} then exit; + Result := Filter; +end; +{$ENDIF} + +procedure SaveAsVOIorNIFTI (var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; DefaultFormatVOI: boolean; var lNiftiHdr: TNIFTIHdr; lDefFilename: string); +var + lFileName,lExt: string; +begin + if DefaultFormatVOI then begin + ImgForm.SaveDialog1.Filter := 'Volume of Interest(.voi)|*.voi|NIfTI (.nii)|*.nii|NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.hdr/.img)|*.hdr|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.FilterIndex:= gBGImg.SaveVoiFilter; //+1since default added + ImgForm.SaveDialog1.Filename := changefileext(ImgForm.SaveDialog1.Filename,'.voi');//10/10/06 + ImgForm.SaveDialog1.DefaultExt := '.voi'; + end else begin + ImgForm.SaveDialog1.Filter := 'NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.nii)|*.nii|NIfTI (.hdr/.img)|*.hdr|Volume of Interest(.voi)|*.voi|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.Filename := changefileext(ImgForm.SaveDialog1.Filename,'.nii.gz');//10/10/06 + ImgForm.SaveDialog1.FilterIndex:= gBGImg.SaveImgFilter; //8/8/2014 removed +1 new behavior with new lazarus 1.2+1since default added + ImgForm.SaveDialog1.DefaultExt := '.nii.gz'; + end; + if lDefFilename <> '' then + ImgForm.SaveDialog1.Filename := ParseFilename(lDefFilename); + if not ImgForm.SaveDialog1.Execute then exit; + if DefaultFormatVOI then + gBGImg.SaveVoiFilter := ImgForm.SaveDialog1.FilterIndex + else + gBGImg.SaveImgFilter := ImgForm.SaveDialog1.FilterIndex; + lFileName := ImgForm.SaveDialog1.Filename; + {$IFDEF FPC} //recent versions of Lazarus (1.2) do handle this, but will put .gz not .nii.gz + if ImgForm.SaveDialog1.filterIndex > 0 then begin + {$IFNDEF Darwin} + // check next line in each OS + {$ENDIF} + lExt := GetExtensionFromFilterAtIndex(ImgForm.SaveDialog1.Filter,ImgForm.SaveDialog1.FilterIndex); //8/8/2014 check on OSX 10.4 + lFilename := ChangeFileExtX(lFilename,lExt); + end; + {$ENDIF} + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if (lExt='.ROI') then begin + Showmessage('Note that the MRIcro ROI format does not save image dimensions. You may want to save a copy as VOI format.'); + SaveMRIcroROI (lFileName); + exit; + end; + SaveAsVOIorNIFTIcore (lFilename,lImgBuffer, lImgBufferItems, lImgBufferBPP,lnVol,lNiftiHdr); +end; + +procedure SetSubmenuWithTag (var lRootMenu: TMenuItem; lTag: Integer); +var + lCount,lSubMenu: integer; +begin + lCount := lRootMenu.Count; + if lCount < 1 then exit; + for lSubMenu := (lCount-1) downto 0 do + if lRootmenu.Items[lSubmenu].Tag = lTag then begin + lRootmenu.Items[lSubmenu].Checked := true; + exit + end; + //will exit unless tag not found: default select 1st item + lRootmenu.Items[0].Checked := true; + //While Recent1.Count > 0 do Recent1.Items[0].Free; +end; + +function MaxDim (lX,lY,lZ: integer): integer; //returns largest of 3 +begin + result := lX; + if lY > result then + result := lY; + if lZ > result then + result := lZ; +end; +procedure SetBGImgDefaults (var lBGImg: TBGImg); +begin + with lBGImg do begin + FlipAx := false; + FlipSag := false; + SaveImgFilter := 0; + SaveVoiFilter := 0; + + OverlayTransPct := -1; + FontSize := 12; + BGTransPct := 0; + LicenseID := 0; + ShowDraw := false; + ResliceOnLoad := false; + OrthoReslice := true; + Prompt4DVolume := true; + MaxDim := 384; + XBarGap := 7; + XBarThick := 3; + XBarClr := clBlue; + VOIClr := 255;//clRed; + VOIInvZoom := 1 shl 10; //1024 = 100% + LesionSmooth := 3;//3mm smoothing + LesionDilate := 8; + VOIUndoSlice := 0; + VOIUndoOrient := 0; + VOIChanged := false; + VOImirrored := false; + VOIUndoVolItems := 0; + RenderDepthBufferItems := 0; + SigDig := 5; + ImageSeparation := 0; + SliceView := 0;//multiple slices + SPMDefaultsStatsFmriT := 16; + SingleRow := false; + SPMDefaultsStatsFmriT0 := 1; + SaveDefaultIni := true; + ThinPen := true; + PlanarRGB := 2; + XBarVisible := true; + OverlaySmooth := true; + //FSLDIR := 'FSLDIR=/usr/local/fsl'; + FSLBASE := '/usr/local/fsl'; + //FSLBETEXE := '/usr/local/fsl/bin/bet'; + FSLOUTPUTTYPE := 'FSLOUTPUTTYPE=NIFTI_GZ'; + //AutoFill := false; + KnownAlignment := false; + StretchQuality := sqHigh; + end; +end; + +procedure AlphaBlend32(lBGQuad,lOverlayQuad : RGBQuadp; lBG0Clr,lOverlay0Clr: DWord; lSlicePixels, lOverlayTransPct: integer); // 630 +var + lBGwt,lOverlaywt,lPixel,lPos:integer; + lBGp,lOverlayP: ByteP; + lBGDWordp,lOverlayDWordp : DWordp; +begin +//note Here we blend the RGBA values - in fact we only need to blend RGB +//however, the position of Alpha varies between OSX ARGB and Linux/Windows RGBA +//this routine would be ~25% faster if we use a compiler-switch for the OS, +//but I do not want to do this until the Compiler code settles a bit more... + lBGp := ByteP(lBGQuad); + lOverlayP := ByteP(lOverlayQuad); + lOverlayDWordp := DWordp(lOverlayQuad); + lBGDWordp := DWordp(lBGQuad); + //next: transparency weighting + lBGwt := round((lOverlayTransPct)/100 * 1024); + lOverlaywt := round((100-lOverlayTransPct)/100 * 1024); + //next redraw each pixel + lPos := 1; + if lOverlayTransPct > -1 then begin + for lPixel := 1 to lSlicePixels do begin + if lOverlayDWordp^[lPixel] = lOverlay0Clr then + inc(lPos,4) + else if lBGDWordp^[lPixel] = lBG0Clr then begin + lBGDWordp^[lPixel] := lOverlayDWordp^[lPixel]; + inc(lPos,4); + end else begin + lBGp^[lPos] := (lBGp^[lPos]*lBGwt+lOverlayP^[lPos]*lOverlaywt) shr 10; + inc(lPos); + lBGp^[lPos] := (lBGp^[lPos]*lBGwt+lOverlayP^[lPos]*lOverlaywt) shr 10; + inc(lPos); + lBGp^[lPos] := (lBGp^[lPos]*lBGwt+lOverlayP^[lPos]*lOverlaywt) shr 10; + inc(lPos); + lBGp^[lPos] := (lBGp^[lPos]*lBGwt+lOverlayP^[lPos]*lOverlaywt) shr 10; + inc(lPos); + end; + end; + end else begin + for lPixel := 1 to lSlicePixels do begin + if lOverlayDWordp^[lPixel] = lOverlay0Clr then + inc(lPos,4) + else if lBGDWordp^[lPixel] = lBG0Clr then begin + lBGDWordp^[lPixel] := lOverlayDWordp^[lPixel]; + inc(lPos,4); + end else begin + if lOverlayP^[lPos] > lBGp^[lPos] then lBGp^[lPos] := lOverlayP^[lPos]; + inc(lPos); + if lOverlayP^[lPos] > lBGp^[lPos] then lBGp^[lPos] := lOverlayP^[lPos]; + inc(lPos); + if lOverlayP^[lPos] > lBGp^[lPos] then lBGp^[lPos] := lOverlayP^[lPos]; + inc(lPos); + if lOverlayP^[lPos] > lBGp^[lPos] then lBGp^[lPos] := lOverlayP^[lPos]; + inc(lPos); + end; + end; + end; +end; + +function Raw2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +begin + if lHdr.NIFTIhdr.scl_slope = 0 then + result := lRaw+lHdr.NIFTIhdr.scl_inter + else + result := (lRaw * lHdr.NIFTIhdr.scl_slope)+lHdr.NIFTIhdr.scl_inter; +end; + +function Scaled2RawIntensity (lHdr: TMRIcroHdr; lScaled: single): single; +begin + if lHdr.NIFTIhdr.scl_slope = 0 then + result := (lScaled)-lHdr.NIFTIhdr.scl_inter + else + result := (lScaled-lHdr.NIFTIhdr.scl_inter) / lHdr.NIFTIhdr.scl_slope; +end; + +procedure FilterLUT (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lMin, lMax: integer); //lLUT: 0=gray,1=red,2=green,3=blue +var + lInc: integer; + lRGB : TRGBQuad; +begin + for lInc := 0 to 255 do + lHdr.LUT[lInc] := lBackgroundImg.BackupLUT[lInc]; + if (lMin < 0) or (lMin > 255) or (lMax < 0) or (lMax > 255) then + exit; + if lMin > lMax then begin + lInc := lMin; + lMin := lMax; + lMax := lInc; + end; //swap lMin/lMax + lRGB.rgbRed := (lBackgroundImg.XBarClr and 255) ; + lRGB.rgbGreen := ((lBackgroundImg.XBarClr shr 8) and 255) ;// and 65280; + lRGB.rgbBlue := ((lBackgroundImg.XBarClr shr 16) and 255) ;//and 16711680; + lRGB.rgbReserved := kLUTalpha; + for lInc := lMin to lMax do + lHdr.LUT[lInc] := lRGB; +//z +end; + +procedure LoadLabelsOld(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); +var lLUTname: string; + lInc: integer; + lTextFile: TextFile; + lStr1: string; + lCh: char; +begin + SetLength(lBackgroundImg.LabelRA,kMaxLabel+1); //+1 as indexed from 0 + for lInc := 0 to High(lBackgroundImg.LabelRA) do + lBackgroundImg.LabelRA[lInc] := inttostr(lInc); + lLUTname := changefileext(lHdr.HdrFileName,'.txt'); + if not Fileexists(lLUTname) then begin + lLUTname := ParseFileName(lHdr.HdrFileName)+'.txt'; //file.nii.gz -> file.txt + if not Fileexists(lLUTname) then + exit; + end; + assignfile(lTextFile,lLUTname); + lHdr.UsesLabels := true; + Filemode := 0; + reset(lTextFile); + while not EOF(lTextFile) do begin + lStr1 := ''; + repeat + read(lTextFile,lCh); + if (lCh >= '0') and (lCh <= '9') then + lStr1 := lStr1 + lCh; + until (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) or (((lCh=kTab)or (lCh=' ')) and (length(lStr1)>0)); + if (length(lStr1) > 0) and (not EOF(lTextFile)) then begin + linc := strtoint(lStr1); + if (lInc >= 0) and (lInc <= kMaxLabel) then begin + lStr1 := ''; + repeat + read(lTextFile,lCh); + if (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab) or (lCh=' ')} then + else + lStr1 := lStr1 + lCh; + until (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab)or (lCh=' ')}; + //showmessage(inttostr(lInc)+'x'+lStr1); + lBackgroundImg.LabelRA[lInc] := lStr1; + end; + + end; + end; + CloseFile(lTextFile); + Filemode := 2; +end; + +procedure LoadLabelLUT(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr {; isBackground: boolean}); +var lLUTname: string; +(* lInc: integer; + lTextFile: TextFile; + lStr1: string; + lCh: char; *) +begin + lLUTname := changefileext(lHdr.HdrFileName,'.lut'); + if Fileexists(lLUTname) then begin + lHdr.UsesCustomPalette := true; + LoadColorScheme(lLUTname,lHdr); + + end; + //if isBackground then begin + LoadLabelsOld(lBackgroundImg,lHdr); + lHdr.UsesLabels := true; + //end; +end; + +procedure LoadMonochromeLUT (var lLUT: integer; var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); //lLUT: 0=gray,1=red,2=green,3=blue +var + lR,lG,lB,lInc: integer; +begin + for lInc := 0 to 255 do + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + + case lLUT of + 1: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := 0; + end;//red + 2: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := lInc; + end;//blue + 3: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := 0; + end;//green + 4: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := lInc; + end;//r+b=violet + 5: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := 0; + end;//red + green = yellow + 6: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := lINc; + end;//green+blue = cyan + maxint: begin// + //showmessage(inttostr(lBackgroundImg.VOIClr)+' '+'r'+inttostr(lR)+'g'+inttostr(lG)+'b'+inttostr(lB)); + lHdr.LUT[0].rgbRed := 0; + lHdr.LUT[0].rgbGreen := 0; + lHdr.LUT[0].rgbBlue := 0; + + lR := (lBackgroundImg.VOIClr and 255) ; + lG := ((lBackgroundImg.VOIClr shr 8) and 255) ;// and 65280; + lB:= ((lBackgroundImg.VOIClr shr 16) and 255) ;//and 16711680; + for lInc := 1 to kVOI8bit do begin + lHdr.LUT[lInc].rgbRed := round((lInc*lR) div kVOI8bit); + lHdr.LUT[lInc].rgbGreen := round((lInc*lG) div kVOI8bit); + lHdr.LUT[lInc].rgbBlue := round((lInc*lB) div kVOI8bit); + end;//green+blue = cyan + end; + else begin + lLUT := 0; + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := lInc; + end;//for gray + end//else... gray + end; + + + lHdr.LUTinvisible := (lHdr.LUT[0]); +end; + +procedure LUTbias (var lHdr: TMRIcroHdr); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick +Graphics Gems IV, p379-382, April 1994 } +var + lIndex,lBias: integer; + lA,lT: single; + lLUT: TLUT; +begin +//if gBias = 0.5 then exit; + lA := 0.2; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lBias := round(255*(lt/((1/la-2)*(1-lt)+1)) ); + lLUT[lIndex] := lHdr.LUT[(lBias)]; + //lHdr.LUT[lIndex].rgbReserved := kLUTalpha; + end; + for lIndex := 1 to 254 do + lHdr.LUT[lIndex] := lLUT[lIndex]; +end; + +procedure LoadColorScheme(lStr: string; var lHdr: TMRIcroHdr); +const UNIXeoln = chr(10); +var + lF: textfile; + lBuff: bytep0; + lFData: file; + lCh: char; + lNumStr: String; + lZ : integer; + lByte,lIndex: byte; + //lType, + lIndx,lLong,lR,lG: boolean; +procedure ResetBools; //nested +begin + //lType := false; + lIndx := false; + lR := false; + lG := false; + lNumStr := ''; +end; //nested proc ResetBools +begin //proc LoadColorScheme + if not fileexistsex(lStr) then exit; + lZ := FSize(lStr); + if (lZ =768) or (lZ = 800) or (lZ=970) then begin + //binary LUT + assignfile(lFdata,lStr); + Filemode := 0; + reset(lFdata,1); + seek(lFData,lZ-768); + GetMem( lBuff, 768); + BlockRead(lFdata, lBuff^, 768); + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := lBuff^[lZ]; + lHdr.LUT[lZ].rgbGreen := lBuff^[lZ+256]; + lHdr.LUT[lZ].rgbBlue := lBuff^[lZ+512]; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + closefile(lFdata); + Filemode := 2; + + freemem(lBuff); + //LUTBIas (lHdr); + lHdr.LUTinvisible := (lHdr.LUT[0]); + exit; + end; + //Text LUT + assignfile(lF,lStr); + Filemode := 0; + reset(lF); + lLong := false; + lIndex := 0; + ResetBools; + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := 0; + lHdr.LUT[lZ].rgbGreen := 0; + lHdr.LUT[lZ].rgbBlue := 0; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + while not EOF(lF) do begin + read(lF,lCh); + if lCh = '*' then //comment character + while (not EOF(lF)) and (lCh <> kCR) and (lCh <> UNIXeoln) do + read(lF,lCh); + if (lCh = 'L') or (lCh = 'l') then begin + //lType := true; + lLong := true; + end; //'l' + if (lCh = 's') or (lCh = 'S') then begin + //lType := true; + lLong := false; + end; //'s' + if lCh in ['0'..'9'] then + lNumStr := lNumStr + lCh; + if ((not(lCh in ['0'..'9'])) or (EOF(lF)) ) and (length(lNumStr) > 0) then begin //not a number = space??? try to read number string + if not lIndx then begin + lIndex := strtoint(lNumStr); + lIndx := true; + end else begin //not index + if lLong then + lByte := trunc(strtoint(lNumStr) / 256) + else + lByte := strtoint(lNumStr); + if not lR then begin + lHdr.LUT[lIndex].rgbRed := lByte; + lR := true; + end else if not lG then begin + lHdr.LUT[lIndex].rgbGreen := lByte; + lG := true; + end else {final value is blue} begin + lHdr.LUT[lIndex].rgbBlue := lByte; + ResetBools; + end; + end; + lNumStr := ''; + end; + end; //not eof + CloseFile(lF); + Filemode := 2; + //LUTBIas (lHdr); + lHdr.LUTinvisible := (lHdr.LUT[0]); +end; //Proc LoadColorScheme + +procedure FreeImgMemory(var lHdr: TMRIcroHdr); +begin + with lHdr do begin + if ScrnBufferItems > 0 then freemem(ScrnBuffer); + if ImgBufferItems > 0 then freemem(ImgBufferUnaligned); + if RenderBufferItems > 0 then freemem(RenderBuffer); + RenderBufferItems := 0; + ScrnBufferItems := 0; + ImgBufferItems := 0; + end; +end; + +procedure DrawFrame (var lImage: TImage; lL,lT,lR,lB: integer); +begin +lImage.Canvas.Brush.Style := bsSolid; + lImage.canvas.pen.color := clWhite; + + lImage.canvas.pen.color := clSilver; + + lImage.Canvas.Rectangle(lL,lT,lR,lB); + lImage.canvas.pen.color := clBlack; + lImage.Canvas.Rectangle(lL+1,lT+1,lR-1,lB-1); +end; + +procedure IntenLabel (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer;lMinIn,lMaxIn: single); +//special: if lMin=lMax, assumes current window values +var + lDesiredSteps,lPower,lTxtWid,lTxtTop,lPGWid,lPGHt,lBarTop,lBarLeft,lBarLength,lBarBorder,lBarThick: integer; + lMin,lMax,l1stStep,lRange,lStepSize,lStepPos: single; + lSteps,lStep,lDecimals,lStepPosScrn: integer; +begin + lMin := lMinIn; + lMax := lMaxIn; + lBarBorder := 6; + lBarThick := 10; + lPGWid := lImage.Width; + lPGHt := lImage.Height; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + //lImage.canvas.font.Color := clWhite;//gXBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + (*if lPGWid < 100 then + lImage.Canvas.Font.Size := 9 + else if lPGWid < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14;*) + lImage.Canvas.Font.Size := gBGImg.FontSize; + lTxtTop := lPGHt - ( lBarBorder +(lImage.Canvas.TextHeight('X') div 2)); + //next: compute increment + lDesiredSteps := 4; + if lMin=lMax then begin + + lMin := lHdr.WindowScaledMin; + lMax := lHdr.WindowScaledMax; + SortSingle(lMin,lMax); + if (lHdr.WindowScaledMin <= 0) and (lHdr.WindowScaledMax <= 0) then begin + if (lHdr.LutFromZero) then + lMax := 0; + lStepPos := lMin; + lMin := lMax; + lMax := lStepPos; + end else + if (lHdr.LutFromZero) and (lMin > 0) then + lMin := 0; + end; //lMinIn=lMaxIn + if lMin = lMax then exit; + //showmessage(realtostr(lMin,4)+' '+realtostr(lMax,4)); + lRange := abs(lMax - lMin); + //if lRange = 0 then exit; + if lRange < 0.000001 then exit; + lStepSize := lRange / lDesiredSteps; + lPower := 0; + while lStepSize >= 10 do begin + lStepSize := lStepSize/10; + inc(lPower); + end; + while lStepSize < 1 do begin + lStepSize := lStepSize * 10; + dec(lPower); + end; + lStepSize := round(lStepSize) *Power(10,lPower); + if lPower < 0 then + lDecimals := abs(lPower) + else + lDecimals := 0; + if lMin > lMax then begin // inverted + l1stStep := trunc((lMax) / lStepSize)*lStepSize; + if l1stStep < (lMax) then l1stStep := l1stStep+lStepSize; + lSteps := trunc( abs((lMin+0.0001)-l1stStep) / lStepSize)+1; + end else begin + l1stStep := trunc((lMin) / lStepSize)*lStepSize; + if l1stStep < (lMin) then l1stStep := l1stStep+lStepSize; + lSteps := trunc( abs((lMax+0.0001)-l1stStep) / lStepSize)+1; + end; + if not odd(lLTRB) then begin //vertical + if lLTRB > 2 then //right + lBarLeft := lPGWid - (lBarThick+lBarBorder+3) + else //if right else LEFT + lBarLeft := (lBarThick+lBarBorder+3); + lBarLength := lPGHt - (lBarBorder+lBarBorder+2); + for lStep := 1 to lSteps do begin + lStepPos := l1stStep+((lStep-1)*lStepSize); + lStepPosScrn := round( abs(lStepPos-lMin)/lRange*lBarLength); + if lLTRB > 2 then //right - align text for width + lImage.canvas.TextOut(lBarLeft-(lImage.Canvas.TextWidth(realtostr(lStepPos,lDecimals))),lTxtTop-lStepPosScrn,realtostr(lStepPos,lDecimals)) + else + lImage.canvas.TextOut(lBarLeft,lTxtTop-lStepPosScrn,realtostr(lStepPos,lDecimals)); + end; + end else begin //if vert else HORIZ + lBarLength := lPGWid - (lBarBorder+lBarBorder+2); + if lLTRB > 2 then //bottom + lBarTop := lPGHt - (lBarThick+lBarBorder+lImage.Canvas.TextHeight('X')+1 ) + else //top + lBarTop := lBarThick+lBarBorder+1; + for lStep := 1 to lSteps do begin + lStepPos := l1stStep+((lStep-1)*lStepSize); + lStepPosScrn := round(abs(lStepPos-lMin)/lRange*lBarLength); + //lStepPosScrn := 15*lStep; + lTxtWid := lImage.Canvas.TextWidth(realtostr(lStepPos,lDecimals)); + lImage.canvas.TextOut(lBarBorder+lStepPosScrn-(lTxtWid div 2),lBarTop,realtostr(lStepPos,lDecimals)); + end; + end;//if vert else HORIZ +end; + +procedure IntenBar (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer; lMin,lMax: single); +var lPGHt, lPGWid,lClr,lStripe,lBarBorder,lnStripes,lHorBarTop,lVerBarLeft,lBarThick: integer; +begin + //if lMin = lMax then + lBarBorder := 6; + lBarThick := 10; + lPGWid := lImage.Width; + lPGHt := lImage.Height; + lHorBarTop := lBarBorder; + lVerBarLeft := lBarBorder; + lImage.canvas.pen.width := 1; + if not odd(lLTRB) then begin + //vertical + if lLTRB > 2 then //right + lVerBarLeft := lPGWid - (lBarThick+lBarBorder); + lnStripes := lPGHt - (lBarBorder+lBarBorder+2); + + if lnStripes < 1 then exit; + {$IFNDEF FPC} + DrawFrame(lImage, lVerBarLeft-2, lBarBorder-2,lVerBarLeft+lBarThick+2, lBarBorder+lnStripes+3); + {$ELSE} + DrawFrame(lImage, lVerBarLeft-2, lBarBorder-2,lVerBarLeft+lBarThick+2, lBarBorder+lnStripes+2); + lBarBorder := lBarBorder; lBarThick := lBarThick +1; {$ENDIF} + for lStripe := 0 to lnStripes do begin + lClr := round(((lnStripes- lStripe) / lnStripes)*255); + lImage.canvas.pen.color := TRGBQuad2TColor(lHdr.LUT[lClr]); + lImage.canvas.moveto(lVerBarLeft, lBarBorder+lStripe); + lImage.canvas.lineto(lVerBarLeft+lBarThick,lBarBorder+lStripe); + end; //draw each stripe + end else begin //LTRB + //Horizontal + if lLTRB > 2 then //bottom + lHorBarTop := lPGHt - (lBarThick+lBarBorder)-1; + lnStripes := lPGWid - (lBarBorder+lBarBorder+1); + {$IFNDEF FPC} + DrawFrame(lImage,lBarBorder+1, lHorBarTop-2, lBarBorder+lnStripes+3,lHorBarTop+lBarThick+2); + {$ELSE} + DrawFrame(lImage,lBarBorder, lHorBarTop-2, lBarBorder+lnStripes+4,lHorBarTop+lBarThick+2); + lBarBorder := lBarBorder+2; lBarThick := lBarThick +1; {$ENDIF} + + if lnStripes < 1 then exit; + for lStripe := 0 to lnStripes do begin + lClr := round((lStripe / lnStripes)*255); + + {$IFNDEF FPC} +lImage.canvas.pen.color := lHdr.LUT[lClr].rgbRed+(lHdr.LUT[lClr].rgbGreen shl 8)+(lHdr.LUT[lClr].rgbBlue shl 16); + {$ELSE}lImage.canvas.pen.Color := TRGBQuad2TColor(lHdr.LUT[lClr]);{$ENDIF} + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop+lBarThick); + end; //draw each stripe + end; //if horizontal + IntenLabel(lImage,lHdr,lLTRB,lMin,lMax); +end; + +//procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +(*procedure DrawBMPZoom( lx, ly, lZoomPct: integer; lBuff: RGBQuadp; var lImage: TImage); +var + x, y,lYPos,lPos,lImgSz,lOutX,lOutY: Integer; + lRatio,lRatioRecip: single; + TempBitmap: TBitmap; + lLongBuff: LongIntp; + lXlut: LongIntp0; +begin + if lZoomPct > 1 then + lRatio := lZoomPct/100 + else + lRatio := 1; + lRatioRecip := 1/lRatio;//e.g. 200% -> ratio = 2, recip = 0.5 + lImgSz := lx * ly; + TempBitmap := TBitmap.Create; + lLongBuff := LongIntp(lBuff); + lOutX := round(lx*lRatio); + lOutY := round(ly*lRatio); + TempBitmap.Width := lOutX; + TempBitmap.Height := lOutY; + //TempBitmap.PixelFormat := pf32bit ; + TempBitmap.Transparent := False; + if lBuff <> nil then begin + getmem(lXlut,lOutX*sizeof(longint)); + for x:=0 to lOutx-1 do + lXlut^[x] := trunc((x+lRatio)*lRatioRecip); //find col + for y:= (lOutY-1) downto 0 do begin + lYPos := trunc((lOutY-y-0.5)*lRatioRecip) * lx; //find row + for x:=0 to lOutx-1 do begin + lPos := lXlut^[x] + lYPos; + if (lPos > 0) and (lPos <= lImgSz) then + TempBitmap.Canvas.Pixels[x,y] := lLongBuff^[lPos]; + end; //for x + end;//for y + freemem(lXlut); + end; //if Buff<> nil + lImage.Picture.Bitmap := TempBitmap; + TempBitmap.Free; +end;*) + + + (*getmem(lTBuff,lInPGHt*lInPGWid*4); + lLen := lInPGWid*4; + lSrc := 1; + lDest := ((lInPGHt-1)*lInPGWid)+1; + for lY := 1 to lInPGHt do begin + //Move(Pointer(lBuff^[lSrc]),Pointer(lTBuff^[lDest]),lLen); + Move(lBuff^[lSrc],lTBuff^[lDest],lLen); + lSrc := lSrc + lInPGWid; + lDest := lDest - lInPGWid; + end; *) +(*procedure DrawBMP( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +var + DestPtr: PInteger; + row, i: integer; + bmp: TBitmap; +begin + bmp := TBitmap.Create; + bmp.Width:=lx; + bmp.Height:=ly; + bmp.PixelFormat := pf32bit; //if pf32bit the background color is wrong, e.g. when alpha = 0 + if lBuff = nil then exit; + //lImage.Picture.Bitmap.BeginUpdate(False); + DestPtr := PInteger(bmp.RawImage.Data); + if bmp.RawImage.Description.BytesPerLine = (lx * 4) then + Move(lBuff^, DestPtr^, lx * ly * 4) + else begin + i := 1; + for row:=0 to ly-1 do begin + Move(lBuff^[i], DestPtr^, lx * 4); + Inc(PByte(DestPtr),bmp.RawImage.Description.BytesPerLine); + inc(i, lx); + end; + end; + //lImage.Picture.Bitmap.EndUpdate(False); + lImage.Picture.Bitmap := bmp; + bmp.free; +end; *) +(*UPSIDE DOWN! +procedure DrawBMP( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +var + DestPtr: PInteger; + row, i: integer; +begin + lImage.Picture.Bitmap.Width:=lx; + lImage.Picture.Bitmap.Height:=ly; + lImage.Picture.Bitmap.PixelFormat := pf32bit; //if pf32bit the background color is wrong, e.g. when alpha = 0 + if lBuff = nil then exit; + lImage.Picture.Bitmap.BeginUpdate(False); + DestPtr := PInteger(lImage.Picture.Bitmap.RawImage.Data); + if lImage.Picture.Bitmap.RawImage.Description.BytesPerLine = (lx * 4) then + Move(lBuff^, DestPtr^, lx * ly * 4) + else begin + i := 1; + for row:=0 to ly-1 do begin + Move(lBuff^[i], DestPtr^, lx * 4); + Inc(PByte(DestPtr), lImage.Picture.Bitmap.RawImage.Description.BytesPerLine); //Bmp.RawImage.Description.BytesPerLine + inc(i, lx); + end; + end; + lImage.Picture.Bitmap.EndUpdate(False); +end; *) + + +procedure DrawBMP( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +var + DestPtr: PInteger; + row, i: integer; +begin + lImage.Picture.Bitmap.Width:=lx; + lImage.Picture.Bitmap.Height:=ly; + lImage.Picture.Bitmap.PixelFormat := pf32bit; //if pf32bit the background color is wrong, e.g. when alpha = 0 + if lBuff = nil then exit; + lImage.Picture.Bitmap.BeginUpdate(False); + i := 1; + for row:= ly-1 downto 0 do begin + DestPtr := PInteger(lImage.Picture.Bitmap.RawImage.GetLineStart(row)); + Move(lBuff^[i], DestPtr^, lx * 4); + inc(i, lx); + end; + lImage.Picture.Bitmap.EndUpdate(False); +end; + +procedure DrawBMPZoomNN(lSrcHt,lSrcWid: integer; lZoomFrac: single; var lRGBBuff: RGBQuadp; var lImage: TImage); +//Nearest Neighbor Stretch +var + lBuff,lInBuff,lXBuff: LongintP; + lOutRGBBuff: RGBQuadp; + lOutWid,lOutHt,lPos,x,y, lRowPos: integer; + fp, z: single; +begin + lOutwid := round(lSrcWid*lZoomFrac); + lOutHt := round(lSrcHt*lZoomFrac); + if (lOutwid < 2) or (lOutHt < 2) then exit; + z := (1/lZoomFrac)-eps; + lInBuff:= LongIntP(lRGBBuff); + getmem(lBuff, lOutHt*lOutWid * 4); + getmem(lXBuff, lOutWid*sizeof(longint)); + for x := 1 to lOutWid do begin + fp := x * z; + if fp < 1 then + fp := 1; + if fp > lSrcWid then + fp := lSrcWid; + lXBuff^[x] := ceil(fp); + end; + //imgForm.StatusLabel.Caption := floattostr(lZoomFrac); + lPos := 1; + for y:= 1 to lOutHt do begin + fp := y * z; + if fp < 1 then + fp := 1; + if fp > lSrcHt then + fp := lSrcHt; + lRowPos:= lSrcWid * (ceil(fp)-1) ; + + for x := 1 to lOutWid do begin + lBuff^[lPos] := lInBuff^[lRowPos+lXBuff^[x]]; + inc(lPos); + end; + + end;//for each line + freemem(lxBuff); + lOutRGBBuff := RGBQuadp(@lBuff[1]); + DrawBMP( lOutWid, lOutHt, lOutRGBBuff, lImage); + freemem(lBuff); +end; + +function mixColor(XloYlo, XloYhi, XhiYlo, XhiYhi: byte; Xfrac, Yfrac: integer): byte; +var + XfracInv, YfracInv: integer; +begin + YfracInv := 1024 - Yfrac; + XfracInv := 1024 - Xfrac; + result :=( (XloYlo*XfracInv*YfracInv) + + (XloYhi*XfracInv*Yfrac) + + (XhiYlo*Xfrac*YfracInv) + + (XhiYhi*Xfrac*Yfrac)) shr 20; +(* result :=( (XloYlo*Xfrac*Yfrac) + + (XloYhi*Xfrac*YfracInv) + + (XhiYlo*XfracInv*Yfrac) + + (XhiYhi*XfracInv*YfracInv)) shr 10; *) +end; + +function mixRGB( XloYlo, XloYhi, XhiYlo, XhiYhi: TRGBquad; Xfrac, Yfrac: integer): TRGBquad; +begin + result.rgbreserved:= kLUTalpha; + result.rgbRed:= mixColor(XloYlo.rgbRed, XloYhi.rgbRed, XhiYlo.rgbRed, XhiYhi.rgbRed, Xfrac, Yfrac); + result.rgbGreen:= mixColor(XloYlo.rgbGreen, XloYhi.rgbGreen, XhiYlo.rgbGreen, XhiYhi.rgbGreen, Xfrac, Yfrac); + result.rgbBlue:= mixColor(XloYlo.rgbBlue, XloYhi.rgbBlue, XhiYlo.rgbBlue, XhiYhi.rgbBlue, Xfrac, Yfrac); +end; + +(*procedure DrawBMPZoomLin(lSrcHt,lSrcWid: integer; lZoomFrac: single; var lInBuff: RGBQuadp; var lImage: TImage); +//About half the speed of the integer version +const + kBitShift = 10; //integer division 1024 = 1 +var + lOutBuff: RGBQuadp; + lOutWid,lOutHt: integer; + lXlo,lXhi,lXfrac,lYlo,lYhi,lYfrac: array of integer; + mx, x,y, bitShift, i: integer; + lFrac, lZoomReciprocal: single; +begin + lOutwid := round(lSrcWid*lZoomFrac); + lOutHt := round(lSrcHt*lZoomFrac); + if (lOutwid < 2) or (lOutHt < 2) or (lZoomFrac <= 0) then exit; + lZoomReciprocal := 1/lZoomFrac; + setlength(lYlo, lOutHt); + setlength(lYhi, lOutHt); + setlength(lYfrac, lOutHt); + bitShift := 1 shl kBitShift; + mx := (lSrcHt -1) * lSrcWid; + for y := 0 to lOutHt -1 do begin + lFrac := (y * lZoomReciprocal) - 0.5; + if lFrac < 0 then lFrac := 0; + lYfrac[y] := round(frac(lFrac) * bitshift); + lYlo[y] := trunc(lFrac); + lYlo[y] := lYlo[y] * lSrcWid; + lYhi[y] := lYlo[y] + lSrcWid; + if (lYhi[y] > mx) then + lYhi[y] := mx; + end; + setlength(lXlo, lOutWid); + setlength(lXhi, lOutWid); + setlength(lXfrac, lOutWid); + mx := lSrcWid; //no -1: indexed from 1 not 0 + for x := 0 to lOutWid -1 do begin + lFrac := (x * lZoomReciprocal) - 0.5; + if lFrac < 0 then lFrac := 0; + lXlo[x] := trunc(lFrac)+1; + lXhi[x] := lXlo[x] + 1; + if (lXhi[x] > mx) then + lXhi[x] := mx; + lXfrac[x] := round(frac(lFrac) * bitshift); + end; + getmem(lOutBuff, lOutHt*lOutWid*4); + i := 0; + for y:=0 to lOutHt-1 do begin + for x:=0 to lOutWid-1 do begin + i := i + 1; //indexex from 1; + lOutBuff[i] := mixRGB(lInBuff[lXlo[x]+lYlo[y]], lInBuff[lXlo[x]+lYhi[y]], lInBuff[lXhi[x]+lYlo[y]], lInBuff[lXhi[x]+lYhi[y]], lXfrac[x], lYfrac[y]) ; + end;//for x : columns + end; //for y : slices + DrawBMP( lOutWid, lOutHt, lOutBuff, lImage); + freemem(lOutBuff); +end;*) + +procedure DrawBMPZoomLin(lSrcHt,lSrcWid: integer; lZoomFrac: single; var lRGBBuff: RGBQuadp; var lImage: TImage); +//Stretch bitmap with bilinear interpolation +var + lInBuff,lBuff: ByteP; + lOutRGBBuff: RGBQuadp; + lOutWid,lOutHt: integer; + lSrcWidx4, lPos,xPmax, xP,yP,yP2,xP2,z, z2,iz2,w1,w2,w3,w4,lTopPos,lBotPos, + lINSz,x,y, t: integer; +begin + lInBuff:= ByteP(lRGBBuff); + lOutwid := round(lSrcWid*lZoomFrac); + lOutHt := round(lSrcHt*lZoomFrac); + if (lOutwid < 2) or (lOutHt < 2) then exit; + xP2:=((lSrcWid)shl 15)div (lOutWid ); +imgform.StatusLabel.Caption := inttostr(xP2); + yP2:=((lSrcHt) shl 15)div (lOutHt); + lPos := 1; + getmem(lBuff, lOutHt*lOutWid*4); + lInSz := lSrcWid *lSrcHt * 4; //32bytesperpixel + lSrcWidx4 := lSrcWid * 4; + yP:= -16384+ (yP2 shr 1); + //imgform.statuslabel.caption := inttostr(yP2)+' '+inttostr(lSrcWid)+'->'+inttostr(lOutWid); + xPmax := ((lSrcWid - 1) * 32768)-1; + for y:=0 to lOutHt-1 do begin + xP:= -16384+ (xP2 shr 1); //16384, e.g. 0.5 voxel + if yP <= 0 then begin + lTopPos := 0; + lBotPos := 0; + end else begin + lTopPos := lSrcWid * (yP shr 15) *4; //top row + lBotPos := lTopPos+lSrcWidx4; + end; + if lBotPos >= lInSz then lBotPos := lBotPos - lSrcWidx4; + if lTopPos >= lInSz then lTopPos := lTopPos - lSrcWidx4; + z2:=yP and $7FFF; + iz2:=$8000-z2; + for x:=0 to lOutWid-1 do begin + t:= ((xP shr 15) * 4); + if (xP > xPmax) then begin + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); //reds + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + end else if (xP < 0) and ((lBotPos+4) < lInSz) then begin + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reds + lBuff^[lPos] :=(lInBuff^[lTopPos+2]*iz2+lInBuff^[lBotPos+2]*z2)shr 15; inc(lPos); //greens + lBuff^[lPos] :=(lInBuff^[lTopPos+3]*iz2+lInBuff^[lBotPos+3]*z2)shr 15; inc(lPos); //greens + lBuff^[lPos] :=(lInBuff^[lTopPos+4]*iz2+lInBuff^[lBotPos+4]*z2)shr 15; inc(lPos); //greens + (* + if ((lBotPos+t+8) > lInSz) or ((lTopPos+t) < 0) then begin + if (xP < 0) and ((lBotPos+4) < lInSz) then begin + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reds + lBuff^[lPos] :=(lInBuff^[lTopPos+2]*iz2+lInBuff^[lBotPos+2]*z2)shr 15; inc(lPos); //greens + lBuff^[lPos] :=(lInBuff^[lTopPos+3]*iz2+lInBuff^[lBotPos+3]*z2)shr 15; inc(lPos); //greens + lBuff^[lPos] :=(lInBuff^[lTopPos+4]*iz2+lInBuff^[lBotPos+4]*z2)shr 15; inc(lPos); //greens + + end else if (lPos > 4) then begin + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reds + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + + end else begin + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reds + lBuff^[lPos] :=0; inc(lPos); //greens + lBuff^[lPos] :=0; inc(lPos); //blues + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reserved + end; *) + end else begin + z:=xP and $7FFF; + w2:=(z*iz2)shr 15; + w1:=iz2-w2; + w4:=(z*z2)shr 15; + w3:=z2-w4; + {$IFDEF Darwin} + //(lInBuff^[lTopPos+t+1]*w1+lInBuff^[lTopPos+t+5]*w2+lInBuff^[lBotPos+t+1]*w3+lInBuff^[lBotPos+t+5]*w4)shr 15; + //ALPHA + lBuff^[lPos] := kLUTalpha ; + inc(lPos); + //RED + lBuff^[lPos] := (lInBuff^[lTopPos+t+2]*w1+lInBuff^[lTopPos+t+6]*w2+lInBuff^[lBotPos+t+2]*w3+lInBuff^[lBotPos+t+6]*w4)shr 15; ;// + inc(lPos); + //GREEN + lBuff^[lPos] :=(lInBuff^[lTopPos+t+3]*w1+lInBuff^[lTopPos+t+7]*w2+lInBuff^[lBotPos+t+3]*w3+lInBuff^[lBotPos+t+7]*w4)shr 15; + inc(lPos); + //BLUE + lBuff^[lPos] :=(lInBuff^[lTopPos+t+4]*w1+lInBuff^[lTopPos+t+8]*w2+lInBuff^[lBotPos+t+4]*w3+lInBuff^[lBotPos+t+8]*w4)shr 15; + inc(lPos); + {$ELSE} + lBuff^[lPos] :=(lInBuff^[lTopPos+t+1]*w1+lInBuff^[lTopPos+t+5]*w2+lInBuff^[lBotPos+t+1]*w3+lInBuff^[lBotPos+t+5]*w4)shr 15; + inc(lPos); //red + lBuff^[lPos] :=(lInBuff^[lTopPos+t+2]*w1+lInBuff^[lTopPos+t+6]*w2+lInBuff^[lBotPos+t+2]*w3+lInBuff^[lBotPos+t+6]*w4)shr 15; + inc(lPos); //green + lBuff^[lPos] :=(lInBuff^[lTopPos+t+3]*w1+lInBuff^[lTopPos+t+7]*w2+lInBuff^[lBotPos+t+3]*w3+lInBuff^[lBotPos+t+7]*w4)shr 15; + inc(lPos); //blue + lBuff^[lPos] :=kLUTalpha; + inc(lPos); //reserved lPos := lPos + 4; + {$ENDIF} + end; + Inc(xP,xP2); + end; //inner loop + Inc(yP,yP2); + end; + lOutRGBBuff := RGBQuadp(@lBuff[1]); + DrawBMP( lOutWid, lOutHt, lOutRGBBuff, lImage); + freemem(lBuff); +end; + +(*procedure DrawBMPZoomLin(lSrcHt,lSrcWid: integer; lZoomFrac: single; var lRGBBuff: RGBQuadp; var lImage: TImage); +//Stretch bitmap with bilinear interpolation +var + lInBuff,lBuff: ByteP; + lOutRGBBuff: RGBQuadp; + lOutWid,lOutHt: integer; + lSrcWidx4, lPos,xP,yP,yP2,xP2,z, z2,iz2,w1,w2,w3,w4,lTopPos,lBotPos, + lINSz,x,y, t: integer; +begin + lInBuff:= ByteP(lRGBBuff); + lOutwid := round(lSrcWid*lZoomFrac); + lOutHt := round(lSrcHt*lZoomFrac); + if (lOutwid < 2) or (lOutHt < 2) then exit; + xP2:=((lSrcWid)shl 15)div (lOutWid ); + yP2:=((lSrcHt) shl 15)div (lOutHt); + lPos := 1; + getmem(lBuff, lOutHt*lOutWid*4); + lInSz := lSrcWid *lSrcHt * 4; //32bytesperpixel + lSrcWidx4 := lSrcWid * 4; + yP:= -16384+ (yP2 shr 1); + //imgform.statuslabel.caption := inttostr(yP2)+' '+inttostr(lSrcWid)+'->'+inttostr(lOutWid); + + for y:=0 to lOutHt-1 do begin + xP:= -16384+ (xP2 shr 1); //16384, e.g. 0.5 voxel + if yP <= 0 then begin + lTopPos := 0; + lBotPos := 0; + end else begin + lTopPos := lSrcWid * (yP shr 15) *4; //top row + lBotPos := lTopPos+lSrcWidx4; + //if (yP shr 16) < lSrcHt then + //inc(lBotPos, lSrcWidx4) //bottom column + end; + if lBotPos >= lInSz then lBotPos := lBotPos - lSrcWidx4; + if lTopPos >= lInSz then lTopPos := lTopPos - lSrcWidx4; + z2:=yP and $7FFF; + iz2:=$8000-z2; + for x:=0 to lOutWid-1 do begin + t:= ((xP shr 15) * 4); + if ((lBotPos+t+8) > lInSz) or ((lTopPos+t) < 0) then begin + lBuff^[lPos] :=0; inc(lPos); //reds + lBuff^[lPos] :=0; inc(lPos); //greens + lBuff^[lPos] :=0; inc(lPos); //blues + lBuff^[lPos] :=0; inc(lPos); //reserved + end else begin + z:=xP and $7FFF; + w2:=(z*iz2)shr 15; + w1:=iz2-w2; + w4:=(z*z2)shr 15; + w3:=z2-w4; +//burp ScaleStretch 10/2009 + {$IFDEF Darwin} + //(lInBuff^[lTopPos+t+1]*w1+lInBuff^[lTopPos+t+5]*w2+lInBuff^[lBotPos+t+1]*w3+lInBuff^[lBotPos+t+5]*w4)shr 15; + //ALPHA + lBuff^[lPos] := kLUTalpha ; + inc(lPos); + //RED + lBuff^[lPos] := (lInBuff^[lTopPos+t+2]*w1+lInBuff^[lTopPos+t+6]*w2+lInBuff^[lBotPos+t+2]*w3+lInBuff^[lBotPos+t+6]*w4)shr 15; ;// + inc(lPos); + //GREEN + lBuff^[lPos] :=(lInBuff^[lTopPos+t+3]*w1+lInBuff^[lTopPos+t+7]*w2+lInBuff^[lBotPos+t+3]*w3+lInBuff^[lBotPos+t+7]*w4)shr 15; + inc(lPos); + //BLUE + lBuff^[lPos] :=(lInBuff^[lTopPos+t+4]*w1+lInBuff^[lTopPos+t+8]*w2+lInBuff^[lBotPos+t+4]*w3+lInBuff^[lBotPos+t+8]*w4)shr 15; + inc(lPos); + {$ELSE} + lBuff^[lPos] :=(lInBuff^[lTopPos+t+1]*w1+lInBuff^[lTopPos+t+5]*w2+lInBuff^[lBotPos+t+1]*w3+lInBuff^[lBotPos+t+5]*w4)shr 15; + inc(lPos); //red + lBuff^[lPos] :=(lInBuff^[lTopPos+t+2]*w1+lInBuff^[lTopPos+t+6]*w2+lInBuff^[lBotPos+t+2]*w3+lInBuff^[lBotPos+t+6]*w4)shr 15; + inc(lPos); //green + lBuff^[lPos] :=(lInBuff^[lTopPos+t+3]*w1+lInBuff^[lTopPos+t+7]*w2+lInBuff^[lBotPos+t+3]*w3+lInBuff^[lBotPos+t+7]*w4)shr 15; + inc(lPos); //blue + lBuff^[lPos] :=kLUTalpha; + inc(lPos); //reserved lPos := lPos + 4; + {$ENDIF} + end; + Inc(xP,xP2); + end; //inner loop + Inc(yP,yP2); + end; + lOutRGBBuff := RGBQuadp(@lBuff[1]); + DrawBMP( lOutWid, lOutHt, lOutRGBBuff, lImage); + freemem(lBuff); +end; +*) +procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +var + lZoom,lZoomY,lZoomX: integer; + // lStartTime: DWord; i: integer; + lTBuff: RGBQuadp; +begin + //first, compute zoom + if (lPanel = nil) then + lImage.Tag := 100 + else if (lPanel.Tag < 1) then begin//autosize + lZoomY := round(100*(lPanel.Height-8)/lInPGHt); + lZoomX := round(100*(lPanel.Width-8)/lInPGWid); + if lZoomX < lZoomY then + lZoom := lZoomX + else + lZoom := lZoomY; + if lZoom < 1 then //nearest integer e.g. 100% or 200%, not 148% + lZoom := 100; + lImage.Tag := lZoom; + end; + if (lImage.Tag < 1) then + lImage.Tag := 100 ; + + //next draw bitmap + if lBuff = nil then begin + getmem(lTBuff,lInPGHt*lInPGWid*4); + Fillchar(lTBuff^,lInPGHt*lInPGWid*4,0); //set all to zero + DrawBMP( lInPGWid, lInPGHt, lTBuff, lImage); + freemem(lTBuff); + end else if (lImage.Tag = 100) or (lPanel = nil) then begin + DrawBMP( lInPGWid, lInPGHt, lBuff, lImage); + end else begin //not 100% + lZoom := lImage.Tag; + if lZoom = 100 then + DrawBMP( lInPGWid, lInPGHt, lBuff, lImage) + else begin + //lStartTime := GetTickCount; + //for i := 1 to 20 do begin + if gBGImg.StretchQuality = sqHigh then //bilinear smoothed zoom + DrawBMPZoomLin(lInPGHt,lInPGWid,lZoom/100,lBuff, lImage) + else //nearest neighbor + DrawBMPZoomNN(lInPGHt,lInPGWid,lZoom/100,lBuff, lImage); + //end; + //ImgForm.StatusLabel.Caption := inttostr(GetTickCount - lStartTime); + end; + lImage.Tag := lZoom; + end; +end; + +procedure FindImgMinMax8 (var lHdr: TMRIcroHdr; var lMini,lMaxi: integer); +var + lInc: integer; +begin + if (lHdr.ImgBufferBPP <> 1) or (lHdr.ImgBufferItems < 1) then exit; + lMini := lHdr.ImgBuffer^[1]; + lMaxi := lHdr.ImgBuffer^[1]; + for lInc := 1 to lHdr.ImgBufferItems do begin + if lHdr.ImgBuffer^[lInc] > lMaxi then lMaxi := lHdr.ImgBuffer^[lInc]; + if lHdr.ImgBuffer^[lInc] < lMini then lMini := lHdr.ImgBuffer^[lInc]; + end; +end; //FindImgMinMax8 + +procedure FindImgMinMax16 (var lHdr: TMRIcroHdr; var lMini,lMaxi: integer); +//very fast routine for finding brightest and darkest intensity... +var + lImgSamples,lInc,lFinalVal: integer; + l16Buf: SmallIntP; +begin + if (lHdr.ImgBufferBPP <> 2) or (lHdr.ImgBufferItems < 1) then exit; + lImgSamples := lHdr.ImgBufferItems; + lInc:=1; + l16Buf := SmallIntP(lHdr.ImgBuffer ); + lMaxI := l16Buf^[lImgSamples]; + lMinI := lMaxi; + lFinalVal := lMaxi; + l16Buf^[lImgSamples]:=32767; // set last value to the maximum integer value + while true do // no check here at all now + begin + while (lMaxI>l16Buf^[lInc]) and (l16Buf^[lInc] >= lMini) do // stop for a >= value + inc(lInc); + if lInc=lImgSamples then begin + l16Buf^[lImgSamples]:=lFinalVal; + exit; // check to see if new max is actually end of data + end; + if l16Buf^[lInc] >lMaxi then + lMaxI:=l16Buf^[lInc]; + if l16Buf^[lInc] < lMini then + lMini:=l16Buf^[lInc]; + inc(lInc); + end; +end; //FindImgMinMax16 + +procedure FindImgMinMax32 (var lHdr: TMRIcroHdr; var lMin,lMax: single); +var + lInc: integer; + l32Buf : SingleP; +begin + if (lHdr.ImgBufferBPP <> 4) or (lHdr.ImgBufferItems < 2) then exit; + l32Buf := SingleP(lHdr.ImgBuffer ); + //if specialsingle(lHdr.MRIcroHdr.gMultiBuf[1]) then lHdr.MRIcroHdr.gMultiBuf[1] := 0.0; + lMin := l32Buf^[1]; + lMax := l32Buf^[1]; + for lInc := 2 to lHdr.ImgBufferItems do begin + if (l32Buf^[lInc] > lMax) then lMax := l32Buf^[lInc]; + if (l32Buf^[lInc] < lMin) then lMin := l32Buf^[lInc]; + end; +end; //FindImgMinMax32 + +function ImgVaries ( var lHdr: TMRIcroHdr): boolean; +var + lF: single; + lI,lPos: integer; + l32Buf : SingleP; + l16Buf : SmallIntP; + +begin + result := false; + if lHdr.ImgBufferItems = 2 then exit; + result := true; //assume variance... + if lHdr.ImgBufferBPP = 4 then begin //32bit + l32Buf := SingleP(lHdr.ImgBuffer ); + lF := l32Buf^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if l32Buf^[lPos] <> lF then + exit; + end else if lHdr.ImgBufferBPP = 2 then begin //if 16bit ints + l16Buf := SmallIntP(lHdr.ImgBuffer ); + lI := l16Buf^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if l16Buf^[lPos] <> lI then + exit; + end else if lHdr.ImgBufferBPP = 1 then begin //if 16bit ints + lI := lHdr.ImgBuffer^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if lHdr.ImgBuffer^[lPos] <> lI then + exit; + end else + showmessage('ImgVaries error: Unsupported format'); + result := false; //entire image has no variability... +end; + +procedure CreateHisto (var lHdr: TMRIcroHdr; var lHisto: HistoRA); +var + lModShl10,lMinI,lC: integer; + lMod,lRng: double {was extended}; + l32Buf : SingleP; + l16Buf : SmallIntP; +begin + if lHdr.ImgBufferItems = 0 then exit; + for lC := 0 to kHistoBins do + lHisto[lC] := 0; + if lHdr.ImgBufferBPP = 4 then begin //32bit + l32Buf := SingleP(lHdr.ImgBuffer ); + lRng := lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS; + if lRng > 0 then + lMod := (kHistoBins)/lRng + else + lMod := 0; + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[round((l32Buf^[lC]-lHdr.GlMinUnscaledS)*lMod)]); + end else {if lHdr.g16Sz >= lHdr.ScrnBufferSz then}begin //<>32bit.. integer + lMinI := round(lHdr.GlMinUnscaledS); + lRng := lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS; + if lRng > 0 then + lMod := (kHistoBins)/lRng + else + lMod := 0; + lModShl10 := trunc(lMod * 1024); + if lHdr.ImgBufferBPP = 2 then begin //if 16bit ints + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[((l16Buf^[lC]-lMinI)*lModShl10)shr 10]) + end else //else 8 bit data + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[((lHdr.ImgBuffer^[lC]-lMinI)*lModShl10)shr 10]); + end; //not 32bit +end; + +function BinCenter (lBin: integer; var lHdr: TMRIcroHdr): single; +begin + result := (lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS)/(kHistoBins-1); //range div bins + result := (lBin * result)+ lHdr.GlMinUnscaledS+ (0.5*result); + +end; + +procedure TextReportHisto (var lHdr: TMRIcroHdr); +var + lC: integer; + var lHisto: HistoRA; +begin + CreateHisto (lHdr, lHisto); + TextForm.MemoT.Lines.Clear; + TextForm.MemoT.Lines.add('#Histogram summary ~ Approximate Values'); + TextForm.MemoT.Lines.add('#Image intensity range: '+realtostr(lHdr.GlMinUnscaledS,3)+'..'+realtostr(lHdr.GlMaxUnscaledS,3)); + TextForm.MemoT.Lines.add('#BinNumber'+kTextSep+'BinCenter'+kTextSep+'BinCount'); + for lC := 0 to kHistoBins do + TextForm.MemoT.Lines.Add( inttostr(lC) + kTextSep +realtostr(BinCenter(lC,lHdr),3) +kTextSep+ inttostr(lHisto[lC]) ); + TextForm.Show; + +end; + +procedure DrawHistogram (var lHdr: TMRIcroHdr; var lImage: TImage); +var lPGHt, lPGWid,lIntenBarHt,lStripe,lBarBorder,lnStripes,lHorBarTop,lBarHt, + l005Pct,ln005Pct,l02Pct,ln02Pct,l0005Pct,ln0005Pct,l001Pct,ln001Pct,l01Pct,ln01Pct,lMaxFreq,lMaxBarHt,lHistoPos,lPrevHistoPos,lFreq,lPos,lTotFreq: integer; + lPct: double; + lHisto: HistoRA; +begin + lPGWid := lImage.Width; + lPGHt := lImage.Height; + SetDimension32(lPGHt,lPGWid,nil,gBGImg,lImage,nil); + lImage.Canvas.Font.Name := 'Arial'; + (*if lPGWid < 100 then + lImage.Canvas.Font.Size := 9 + else if lPGWid < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14;*) + lImage.Canvas.Font.Size := gBGImg.FontSize; + CreateHisto (lHdr, lHisto); + lBarBorder := 6; + lIntenBarHt := 14; + DrawFrame(lImage, 0, 0,lPGWid,lPGHt); + lHorBarTop := lPGHt - lBarBorder-lIntenBarHt-lImage.Canvas.TextHeight('X'); + lMaxBarHt := lHorBarTop - lBarBorder- lBarBorder- lBarBorder; + lMaxFreq := 0; + lnStripes := lPGWid - (lBarBorder+lBarBorder+1); + if gBGImg.XBarClr = clWhite then + lImage.canvas.pen.color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.pen.color := gBGImg.XBarClr;//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + lImage.Canvas.Font.Color := lImage.canvas.pen.color; + lImage.Canvas.Brush.Style := bsSolid; + lImage.Canvas.Pen.Width := 1; + lImage.Canvas.Pen.Style := psDot; + lImage.canvas.moveto(lBarBorder,lHorBarTop-lMaxBarHt-1); + lImage.canvas.lineto(lPGWid-lBarBorder,lHorBarTop-lMaxBarHt-1); + lImage.Canvas.Brush.Style := bsClear; + if (lnStripes < 1) then exit; + //Next: compute scale find freq in graph - not same as image, as with large graphs bars resampled + lPrevHistoPos := 0; + lTotFreq := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + for lPos := lPrevHistoPos to lHistoPos do + lTotFreq := lTotFreq+lHisto[lPos]; + lPrevHistoPos := lHistoPos+1; + end; + ln02Pct := 0; + ln01Pct := 0; + ln005Pct := 0; + ln001Pct := 0; + ln0005Pct := 0; + l02Pct := round(lTotFreq/50); + l01Pct := round(lTotFreq/100); + l005Pct := round(lTotFreq/200); + l001Pct := round(lTotFreq/1000); + l0005Pct := round(lTotFreq/2000); + lPrevHistoPos := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + lFreq := 0; + for lPos := lPrevHistoPos to lHistoPos do + lFreq := lFreq+lHisto[lPos]; + if lFreq > lMaxFreq then + lMaxFreq := lFreq; + if lFreq > l02Pct then + inc(ln02Pct); + if lFreq > l01Pct then + inc(ln01Pct); + if lFreq > l005Pct then + inc(ln005Pct); + if lFreq > l001Pct then + inc(ln001Pct); + if lFreq > l0005Pct then + inc(ln0005Pct); + //lTotFreq := lTotFreq + lFreq; + lPrevHistoPos := lHistoPos+1; + end; + lImage.Canvas.Pen.Style := psSolid; + if ln02Pct > 5 then + lPct := 5 + else if ln01Pct > 5 then + lPct := 2 + else if ln005Pct > 5 then + lPct := 1 + else if ln001Pct > 4 then + lPct := 0.5 + else if ln0005Pct > 4 then + lPct := 0.01 + else + lPct := 0.05; + lMaxFreq :=round( lTotFreq * (lPct/100)); + if (lMaxFreq = 0) then exit; + //Next: draw bars + lImage.canvas.TextOut(lPGWid div 2,lHorBarTop-lMaxBarHt-1-6,' '+floattostr(lPct)+'% '); + lImage.Canvas.Brush.Style := bsClear; + lPrevHistoPos := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + lFreq := 0; + for lPos := lPrevHistoPos to lHistoPos do + lFreq := lFreq+lHisto[lPos]; + if lFreq > lMaxFreq then begin + lFreq := lMaxFreq; + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-8); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-6); + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-4); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-2); + end; + lBarHt := round(lFreq/lMaxFreq*lMaxBarHt); + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lBarHt); + lPrevHistoPos := lHistoPos+1; + end; //draw each stripe + intenBar(lImage,lHdr,3,Raw2ScaledIntensity(lHdr,lHdr.GlMinUnScaledS),Raw2ScaledIntensity(lHdr,lHdr.GlMaxUnscaledS)); +end; + +procedure Balance (var lHdr: TMRIcroHdr); +var + lPct,lNum,lC: integer; + lHisto: HistoRA; + lBlackAUtoBal,lWhiteAutoBal: integer; +begin //dsa + if lHdr.ImgBufferItems = 0 then exit; + CreateHisto (lHdr, lHisto); + lPct := (lHdr.ImgBufferItems *2) div 100; + lNum := 0; + lC := kHistoBins; + repeat + lNum := lNum + lHisto[lC]; + dec(lC); + until (lC = 0) or (lNum >= lPct); + if (lNum >= lPct) and (lC > 0) then + lWHiteAUtoBal:= lC + else begin + lC := kHistoBins; + repeat + lNum := lHisto[lC]; + dec(lC); + until (lC = 0) or (lNum > 0); + if lC = 0 then + lWHiteAUtoBal := kHistoBins + else + lWHiteAUtoBal := lC; + end; + lNum := 0; + lC := 0; + repeat + lNum := lNum + lHisto[lC]; + inc(lC); + until (lC >= kHistoBins) or (lNum >= lPct); + if (lNum >= lPct) and (lC < kHistoBins) and (lC >2) then + lBlackAutoBal := lC + else + lBlackAutoBal := 2; + if (lWHiteAUtoBal-lBlackAutoBal) < (kHistoBins/20) then begin //5% of range.. + lBlackAutoBal := 2; + lWHiteAUtoBal := kHistoBins; + end; + lHdr.AutoBalMaxUnscaled := ((lWhiteAutoBal/kHistoBins)*(lHdr.GlMaxUnscaledS-lHdr.GlMinUnscaledS))+lHdr.GlMinUnscaledS; + lHdr.AutoBalMinUnscaled := ((lBlackAutoBal/kHistoBins)*(lHdr.GlMaxUnscaledS-lHdr.GlMinUnscaledS))+lHdr.GlMinUnscaledS; + //only apply rounding if there is a large difference - e.g. if range is 0..1 then rounding will hurt + if (lHdr.ImgBufferBPP < 4) and ((lHdr.AutoBalMaxUnscaled-lHdr.AutoBalMinUnscaled) > 50) then begin //round integer values + lHdr.AutoBalMinUnscaled := round(lHdr.AutoBalMinUnscaled); + lHdr.AutoBalMaxUnscaled := round(lHdr.AutoBalMaxUnscaled); + end; +end; //proc Balance + +procedure ReturnMinMax (var lHdr: TMRIcroHdr; var lMin,lMax: single; var lFiltMin8bit, lFiltMax8bit: integer); +var + lSwap,lMinS,lMaxS {,lHalfBit}: single; +begin + lFiltMin8bit := 0; + lFiltMax8bit := 255; + lMinS := lHdr.WindowScaledMin; + lMaxS := lHdr.WindowScaledMax; + if lMinS > lMaxS then begin //swap + lSwap := lMinS; + lMinS := lMaxS; + lMaxS := lSwap; + end;//swap + lMin := (Scaled2RawIntensity(lHdr, lMinS)); + lMax := (Scaled2RawIntensity(lHdr, lMaxS)); + //if lMin = lMax then exit; + if (lHdr.LutFromZero) then begin + if (lMinS > 0) and (lMaxS <> 0) then begin + //lMin := Scaled2RawIntensity(lHdr, 0); + lFiltMin8bit := round(lMinS/lMaxS*255); + //lMinS := - lHalfBit;//0; + lHdr.Zero8Bit := 0; + end else if (lMaxS < 0) and (lMinS <> 0) then begin + //lMax := Scaled2RawIntensity(lHdr, -0.000001); + lFiltMax8bit := 255-round(lMaxS/lMinS*255); + //lMaxS := lHalfBit; //0; + //lFiltMax8bit := (Scaled2RawIntensity(lHdr, lHdr.WindowScaledMax)); + end; //> 0 + end; //LUTfrom Zero + lHdr.Zero8Bit := lMinS; + lHdr.Slope8bit := (lMaxS-lMinS)/255; +end; //ReturnMinMax + + +procedure FilterScrnImg (var lHdr: TMRIcroHdr); +var + lInc,lItems,lFiltMin8bit,lFiltMax8bit: integer; + lMinS,lMaxS,lScale: single; +begin + ReturnMinMax(lHdr,lMinS,lMaxS,lFiltMin8bit,lFiltMax8bit); + lItems :=lHdr.ScrnBufferItems; + if lItems < 1 then exit; +if lFiltMax8Bit < 255 then begin + lFiltMin8bit := 255-lFiltMax8bit; + lFiltMax8Bit := 255; +end; + lScale := (lFiltMax8bit-lFiltMin8bit)/255; + if (lFiltMin8bit > 0) or (lFiltMax8bit < 255) then + for lInc := 1 to lItems do + if lHdr.ScrnBuffer^[lInc] <> 0 then + lHdr.ScrnBuffer^[lInc] := lFiltMin8bit+round(lHdr.ScrnBuffer^[lInc]*lScale); +end; //FilterScrnImg + +procedure RescaleImgIntensity8(var lHdr: TMRIcroHdr ); +var lRng: single; + lLUTra: array[0..255] of byte; + lMax,lMin,lSwap,lMod: single; + lFiltMin8bit,lFiltMax8bit,lInc: integer; +begin + if (lHdr.ImgBufferItems < 2) or (lHdr.ImgBufferBPP <> 1) then + exit; + if (lHdr.UsesCustomPaletteRandomRainbow) then begin + createLutLabel (lHdr.LUT, abs(lHdr.WindowScaledMax-lHdr.WindowScaledMin)/100); + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := lHdr.ImgBuffer^[lInc]; + (* l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := ((l16Buf^[lInc]-1) mod 100)+1; + *) + exit; + end; + + ReturnMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + + lRng := (lMax - lMin); + if lRng <> 0 then + lMod := abs({trunc}(((254)/lRng))) + else + lMod := 0; + if lMin > lMax then begin //maw + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + for lInc := 0 to 255 do begin + if lInc < lMin then + lLUTra[lInc] := 0 + else if lInc >= lMax then + lLUTra[lInc] := 255 + else + lLUTra[lInc] := trunc(((lInc-lMin)*lMod)+1); + end; //fill LUT + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 0 to 255 do + lLUTra[lInc] := 255-lLUTra[lInc]; + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := lLUTra[lHdr.ImgBuffer^[lInc]]; +end;//proc RescaleImgIntensity8 + +procedure ReturnMinMaxInt (var lHdr: TMRIcroHdr; var lMin,lMax, lFiltMin8bit, lFiltMax8bit: integer); +var + lMinS,lMaxS: single; +begin + ReturnMinMax (lHdr, lMinS,lMaxS,lFiltMin8bit, lFiltMax8bit); + lMin := round(lMinS); + lMax := round(lMaxS); +end; + +procedure RescaleImgIntensity16(var lHdr: TMRIcroHdr ); +var lRng: single; + lBuff: bytep0; + l16Buf : SmallIntP; + lFiltMin8bit,lFiltMax8bit,lRngi,lMin16Val,lMax,lMin,lSwap,lModShl10,lInc,lInt: integer; +begin + if (lHdr.ImgBufferBPP <> 2) or (lHdr.ImgBufferItems < 2) then exit; + if (lHdr.UsesCustomPaletteRandomRainbow) then begin + createLutLabel (lHdr.LUT, abs(lHdr.WindowScaledMax-lHdr.WindowScaledMin)/100); + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := ((l16Buf^[lInc]-1) mod 100)+1; + exit; + end; + ReturnMinMaxInt (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + lRng := lMax - lMin; + if lRng <> 0 then + lModShl10 := abs( trunc(((254)/lRng)* 1024)) + else + lModShl10 := 0; + if lMin > lMax then begin + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + lMin16Val := trunc(lHdr.GlMinUnscaledS); + lRngi := (1+ trunc(lHdr.GlMaxUnscaledS))-lMin16Val; + getmem(lBuff, lRngi+1); //+1 if the only values are 0,1,2 the range is 2, but there are 3 values! + for lInc := 0 to (lRngi) do begin //build lookup table + lInt := lInc+lMin16Val; + if lInt >= lMax then + lBuff^[lInc] := (255) + else if lInt < lMin then + lBuff^[lInc] := 0 + else + lBuff^[lInc] := (((lInt-lMin)*lModShl10) shr 10)+1 ; + //lBuff[lInc] := (((lInt-lMin)*lModShl10) shr 10) ; + end; //build lookup table + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 0 to lRngi do + lBuff^[lInc] := 255-lBuff^[lInc]; + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lInc := 1 to lHdr.ImgBufferItems do + lHdr.ScrnBuffer^[lInc] := lBuff^[l16Buf^[lInc]-lMin16Val] ; + freemem(lBuff); //release lookup table +end;//proc RescaleImgIntensity16; + +procedure RescaleImgIntensity32(var lHdr: TMRIcroHdr ); +var lRng: double; +lMod,lMax,lMin,lSwap: single {was extended}; + lInc,lItems,lFiltMin8bit,lFiltMax8bit: integer; + l32Buf : SingleP; +begin + lItems := lHdr.ImgBufferItems ; + //fx(lItems,777); + if (lHdr.ImgBufferBPP <> 4) or (lItems< 2) then exit; + l32Buf := SingleP(lHdr.ImgBuffer ); + //fx(lHdr.WindowScaledMin , lHdr.WindowScaledMax); + ReturnMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); //qaz + lRng := (lMax - lMin); + if lRng <> 0 then + lMod := abs(254/lRng) + else begin //June 2007 - binary contrast + for lInc := 1 to lItems do begin + if l32Buf^[lInc] >= lMax then + lHdr.ScrnBuffer^[lInc] := 255 + else //if l32Buf[lInc] < lMin then + lHdr.ScrnBuffer^[lInc] := 0; + end; + exit; + end; + (*if lRng <> 0 then + lMod := abs(254/lRng) + else + lMod := 0;*) + if lMin > lMax then begin + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + lMin := lMin - abs(lRng/255);//lMod; + //showmessage(realtostr(lMin,3)+' '+realtostr(lMax,3)); + begin//not SSE + for lInc := 1 to lItems do begin + if l32Buf^[lInc] > lMax then + lHdr.ScrnBuffer^[lInc] := 255 + else if l32Buf^[lInc] < lMin then + lHdr.ScrnBuffer^[lInc] := 0 //alfa + else begin + lHdr.ScrnBuffer^[lInc] := round ((l32Buf^[lInc]-lMin)*lMod); + end; + end; //for each voxel + end; // SSE-vs-x87 choice + //next - flip intensity range OPTIONAL + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 1 to lItems do + lHdr.ScrnBuffer^[lInc] := 255-lHdr.ScrnBuffer^[lInc]; +end; //RescaleImgIntensity32 + +function MirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfX,lLineOffset: integer; + lTemp32: single; + lTemp16: SmallInt; + lTemp: byte; + l32: SingleP; + l16: SmallIntP; +begin + result := false; + lX := lHdr.NIFTIhdr.Dim[1]; + lY := lHdr.NIFTIhdr.Dim[2]; + lZ := lHdr.NIFTIhdr.Dim[3]; + if lHdr.NIFTIhdr.Dim[4] > 1 then begin + Showmessage('Can not mirror 4D data : '+lHdr.HdrFileName); + exit; + end; + if (lHdr.ImgBufferItems < (lX*lY*lZ)) or (lX < 2) then begin + Showmessage('Unsupported filetype : '+lHdr.HdrFileName); + exit; + end; + lHlfX := lX div 2; + lLineOffset := 0; + //for each datatype... + if lHdr.ImgBufferBPP = 4 then begin + l32 := SingleP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp32 := l32^[lXPos+lLineOffset]; + l32^[lXPos+lLineOffset] := l32^[1+lX-lXPos+lLineOffset]; + l32^[1+lX-lXPos+lLineOffset] := lTemp32; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 2 then begin + l16 := SmallIntP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp16 := l16^[lXPos+lLineOffset]; + l16^[lXPos+lLineOffset] := l16^[1+lX-lXPos+lLineOffset]; + l16^[1+lX-lXPos+lLineOffset] := lTemp16; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 1 then begin + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp := lHdr.ImgBuffer^[lXPos+lLineOffset]; + lHdr.ImgBuffer^[lXPos+lLineOffset] := lHdr.ImgBuffer^[1+lX-lXPos+lLineOffset]; + lHdr.ImgBuffer^[1+lX-lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); + result := true; +end; //proc MirrorImgBuffer + +procedure MirrorScrnBuffer(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr ); +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfX,lLineOffset: integer; + lTemp: byte; +begin + lX := lBackgroundImg.ScrnDim[1]; + lY := lBackgroundImg.ScrnDim[2]; + lZ := lBackgroundImg.ScrnDim[3]; + if (lHdr.ScrnBufferItems < (lX*lY*lZ)) or (lX < 2) then exit; + lHlfX := lX div 2; + lLineOffset := 0; + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp := lHdr.ScrnBuffer^[lXPos+lLineOffset]; + lHdr.ScrnBuffer^[lXPos+lLineOffset] := lHdr.ScrnBuffer^[1+lX-lXPos+lLineOffset]; + lHdr.ScrnBuffer^[1+lX-lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z +end; //proc MirrorImScrnBuffer + +procedure FindMatrixPt (lX,lY,lZ: single; var lXout,lYOut,lZOut: single; var lMatrix: TMatrix); +begin + lXOut := (lX*lMatrix.matrix[1,1])+(lY*lMatrix.matrix[1,2])+(lZ*lMatrix.matrix[1,3])+lMatrix.matrix[1,4]; + lYOut := (lX*lMatrix.matrix[2,1])+(lY*lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[2,3])+lMatrix.matrix[2,4]; + lZOut := (lX*lMatrix.matrix[3,1])+(lY*lMatrix.matrix[3,2])+(lZ*lMatrix.matrix[3,3])+lMatrix.matrix[3,4]; +end; + +procedure CheckMaxMin(var lX,lY,lZ,lXMax,lYMax,lZMax,lXMin,lYMin,lZMin: single); +begin + if lX > lXMax then lXMax := lX; + if lY > lYMax then lYMax := lY; + if lZ > lZMax then lZMax := lZ; + if lX < lXMin then lXMin := lX; + if lY < lYMin then lYMin := lY; + if lZ < lZMin then lZMin := lZ; +end; + +function FindOriMM (lX1,lY1,lZ1,lX2,lY2,lZ2: integer; var lMatrix: TMatrix): single; +var + lXdx,lYdx,lZdx,lXmm1,lYmm1,lZmm1,lXmm2,lYmm2,lZmm2: single; +begin + FindMatrixPt(lX1,lY1,lZ1,lXmm1,lYmm1,lZmm1,lMatrix); + FindMatrixPt(lX2,lY2,lZ2,lXmm2,lYmm2,lZmm2,lMatrix); + lXdx := abs(lXmm1-lXmm2); + lYdx := abs(lYmm1-lYmm2); + lZdx := abs(lZmm1-lZmm2); + if (lXdx > lYdx) and (lXdx > lZdx) then begin //X greatest + result := lXmm1; + end else if (lYdx > lZdx) then begin //Y greatest + result := lYmm1; + end else begin //Z greatest + result := lZmm1; + end; + result := -(result); +end; + +procedure FindMatrixBounds (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; lReslice: boolean); +label 121; +var + lMatrix: TMatrix; + lPos,lPass: integer; + lXc,lYc,lZc,lXmin,lXMax,lYMin,lYMax,lZMin,lZMax,lX,lY,lZ,lmmMin,lDimMMMax: single; +begin + if not lReslice then begin //Dec06 + lBGImg.ScrnDim[1] := lHdr.NIFTIhdr.Dim[1];//+0.5 Dec06 + lBGImg.ScrnDim[2] := lHdr.NIFTIhdr.Dim[2];//+0.5 Dec06 + lBGImg.ScrnDim[3] := lHdr.NIFTIhdr.Dim[3];//+0.5 Dec06 + lBGImg.ScrnMM[1] := lHdr.NIFTIhdr.pixdim[1]; + lBGImg.ScrnMM[2] := lHdr.NIFTIhdr.pixdim[2]; + lBGImg.ScrnMM[3] := lHdr.NIFTIhdr.pixdim[3]; + //Sept07 -estimate origin + lBGImg.ScrnOri[1] := lBGImg.ScrnDim[1] div 2; + lBGImg.ScrnOri[2] := lBGImg.ScrnDim[2] div 2; + lBGImg.ScrnOri[3] := lBGImg.ScrnDim[3] div 2; + if lHdr.NIfTItransform then begin + lBGImg.ScrnOri[1] := 0; + lBGImg.ScrnOri[2] := 0; + lBGImg.ScrnOri[3] := 0; + mm2Voxel (lBGImg.ScrnOri[1],lBGImg.ScrnOri[2],lBGImg.ScrnOri[3], lBGImg.invMat);//vcx +(* lMatrix := lHdr.Mat; + if lBGImg.ScrnMM[1] <> 0 then + lBGImg.ScrnOri[1] := 1+FindOriMM (0,0,0,lBGImg.ScrnDim[1]-1,0,0, lMatrix)/lBGImg.ScrnMM[1]; + if lBGImg.ScrnMM[2] <> 0 then + lBGImg.ScrnOri[2] := 1+FindOriMM (0,0,0,0,lBGImg.ScrnDim[2]-1,0, lMatrix)/lBGImg.ScrnMM[2]; + if lBGImg.ScrnMM[3] <> 0 then + lBGImg.ScrnOri[3] := 1+FindOriMM (0,0,0,0,0,lBGImg.ScrnDim[3]-1, lMatrix)/lBGImg.ScrnMM[3]; + *) + end; + //end estimate origin + //fx(lBGImg.ScrnOri[1],lBGImg.ScrnMM[1],lBGImg.ScrnOri[3],1112); + exit; + end; + lPass := 0; + if (abs(lHdr.Mat.matrix[1,4]) > maxInt) or (abs(lHdr.Mat.matrix[2,4]) > MaxInt) or (abs(lHdr.Mat.matrix[3,4]) > maxint) then begin + showmessage('Error: the origin is not plausible.'); + lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; + + end; +121: + inc(lPass); + lMatrix := lHdr.Mat; + FindMatrixPt(0,0,0,lX,lY,lZ,lMatrix); + lXMax := lX; + lYMax := lY; + lZMax := lZ; + lXMin := lX; + lYMin := lY; + lZMin := lZ; + for lPos := 1 to 7 do begin + if odd(lPos) then + lXc := lHdr.NIFTIhdr.Dim[1]-1 + else + lXc := 0; + if odd(lPos shr 1) then + lYc := lHdr.NIFTIhdr.Dim[2]-1 + else + lYc := 0; + if odd(lPos shr 2) then + lZc := lHdr.NIFTIhdr.Dim[3]-1 + else + lZc := 0; + //showmessage(floattostr(lXc)+' '+floattostr(lYc)+' '+floattostr(lZc) ); + FindMatrixPt(lXc,lYc,lZc,lX,lY,lZ,lMatrix); + CheckMaxMin(lX,lY,lZ,lXMax,lYMax,lZMax,lXMin,lYMin,lZMin); + end; + //fx(lXMax,lXMin,lZMax,lZMin); + //next find min MM + //fx(lZMin,lZMax); + lmmMin := abs(lHdr.NIFTIhdr.pixdim[1]); + if abs(lHdr.NIFTIhdr.pixdim[2]) < lmmMin then lmmMin := abs(lHdr.NIFTIhdr.pixdim[2]); + if abs(lHdr.NIFTIhdr.pixdim[3]) < lmmMin then lmmMin := abs(lHdr.NIFTIhdr.pixdim[3]); + if lmmMin = 0 then lmmMin := 1; + //next find max Dim + lDimMMMax := abs(lXMax-lXMin); + if abs(lYMax-lYMin) > lDimMMMax then lDimMMMax := abs(lYMax-lYMin); + if abs(lZMax-lZMin) > lDimMMMax then lDimMMMax := abs(lZMax-lZMin); + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scalled by smallest mm, try largest mm + lmmMin := lHdr.NIFTIhdr.pixdim[1]; + if lHdr.NIFTIhdr.pixdim[2] > lmmMin then lmmMin := lHdr.NIFTIhdr.pixdim[2]; + if lHdr.NIFTIhdr.pixdim[3] > lmmMin then lmmMin := lHdr.NIFTIhdr.pixdim[3]; + if lmmMin = 0 then lmmMin := 1; + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scalled by largest mm, try isotropic 1mm + lmmMin := 1; + end; + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scaled by 1mm, find optimal scaling factor + lmmMin := lDimMMMax/gBGImg.MaxDim; + Showmessage('Maximum dimension is >'+inttostr(gBGImg.MaxDim)+' voxels. Therefore the image will resolution will be reduced. If you have a fast computer, you may consider increasing the ''MaxDim'' value saved in the mricron.ini file.'); + //showmessage('Warning: having to downsample this large image - you may wish to view this image with MRIcro.'); + end; + //showmessage( floattostr(lmmMin)); + //lmmMin := 3.5;// + end; + lBGImg.ScrnDim[1] := 1+trunc(0.5+((lXMax-lXMin)/lmmMin));//+0.5 May06 + lBGImg.ScrnDim[2] := 1+trunc(0.5+((lYMax-lYMin)/lmmMin));//+0.5 May06 + lBGImg.ScrnDim[3] := 1+trunc(0.5+((lZMax-lZMin)/lmmMin));//+0.5 May06 + //fx(lBGImg.ScrnDim[3],lmmMin); + lBGImg.ScrnMM[1] := lmmMin; + lBGImg.ScrnMM[2] := lmmMin; + lBGImg.ScrnMM[3] := lmmMin; + //fx(lBGImg.ScrnDim[1],lBGImg.ScrnDim[2],lBGImg.ScrnDim[3]); + //showmessage(floattostr(lZMin)+'...'+floattostr(lZMax)+' '+floattostr((lZMin)/lmmMin)); + lBGImg.ScrnOri[1] := -(((lXMin)/lmmMin))+1; + lBGImg.ScrnOri[2] := -(((lYMin)/lmmMin))+1; + lBGImg.ScrnOri[3] := -(((lZMin)/lmmMin))+1; + + //fx(lBGImg.ScrnOri[1],lBGImg.ScrnOri[2],lBGImg.ScrnOri[3]); + if (lXMin > 0) and (lYMin > 0) and (lZMin > 0) and (lPass <= 2) then begin + lHdr.Mat.matrix[1,4] := -lHdr.Mat.matrix[1,4]; + lHdr.Mat.matrix[2,4] := -lHdr.Mat.matrix[2,4]; + lHdr.Mat.matrix[3,4] := -lHdr.Mat.matrix[3,4]; + {lHdr.NIFTIhdr.srow_x[3] := -lHdr.NIFTIhdr.srow_x[3]; + lHdr.NIFTIhdr.srow_y[3] := -lHdr.NIFTIhdr.srow_y[3]; + lHdr.NIFTIhdr.srow_z[3] := -lHdr.NIFTIhdr.srow_z[3];} + {lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; } + if lPass = 1 then begin + Showmessage('The origin is not in the image... check your transformation matrix - will attempt to invert offsets'); + goto 121; + end else if lPass = 2 then begin + lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; + Showmessage('The origin is not in the image... check your transformation matrix - will attempt to zero offsets'); + goto 121; + end else + showmessage('The origin is not in the image... unable to correct.'); + end; +end; + + +function mat44_inverse(var R: Tmatrix ) : TMatrix; +var + r11,r12,r13,r21,r22,r23,r31,r32,r33,v1,v2,v3 , deti : double; + Q: TMatrix; +begin + r11 := R.matrix[1,1]; r12 := R.matrix[1,2]; r13 := R.matrix[1,3]; //* [ r11 r12 r13 v1 ] */ + r21 := R.matrix[2,1]; r22 := R.matrix[2,2]; r23 := R.matrix[2,3]; //* [ r21 r22 r23 v2 ] */ + r31 := R.matrix[3,1]; r32 := R.matrix[3,2]; r33 := R.matrix[3,3]; //* [ r31 r32 r33 v3 ] */ + v1 := R.matrix[1,4]; v2 := R.matrix[2,4]; v3 := R.matrix[3,4]; //* [ 0 0 0 1 ] */ + + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + + if( deti <> 0.0 ) then + deti := 1.0 / deti ; + + Q.matrix[1,1] := deti*( r22*r33-r32*r23) ; + Q.matrix[1,2] := deti*(-r12*r33+r32*r13) ; + Q.matrix[1,3] := deti*( r12*r23-r22*r13) ; + Q.matrix[1,4] := deti*(-r12*r23*v3+r12*v2*r33+r22*r13*v3 + -r22*v1*r33-r32*r13*v2+r32*v1*r23) ; + + Q.matrix[2,1] := deti*(-r21*r33+r31*r23) ; + Q.matrix[2,2] := deti*( r11*r33-r31*r13) ; + Q.matrix[2,3] := deti*(-r11*r23+r21*r13) ; + Q.matrix[2,4] := deti*( r11*r23*v3-r11*v2*r33-r21*r13*v3 + +r21*v1*r33+r31*r13*v2-r31*v1*r23) ; + + Q.matrix[3,1] := deti*( r21*r32-r31*r22) ; + Q.matrix[3,2] := deti*(-r11*r32+r31*r12) ; + Q.matrix[3,3] := deti*( r11*r22-r21*r12) ; + Q.matrix[3,4] := deti*(-r11*r22*v3+r11*r32*v2+r21*r12*v3 + -r21*r32*v1-r31*r12*v2+r31*r22*v1) ; + + Q.matrix[4,1] := 0; Q.matrix[4,2] := 0; Q.matrix[4,3] := 0.0 ; + Q.matrix[4,4] := 1;// (deti == 0.0l) ? 0.0l : 1.0l ; /* failure flag if deti == 0 */ + + result := Q ; +end; + +function TestSameOrtho(var lHdr: TMRIcroHdr): boolean; +var + lRow,lCol: integer; +begin + result := false; + for lRow := 1 to 3 do + for lCol := 1 to 3 do + if (lRow=lCol) then begin + if lHdr.Mat.Matrix[lRow,lCol] <= 0 then + exit; + end else + if lHdr.Mat.Matrix[lRow,lCol] <> 0 then + exit; + result := true; +end; + +function OrthoReslice (var lBGImg: TBGImg; var lHdr: TMRIcroHdr): boolean; +label + 666; +Type + TXImg = record //Next: analyze Format Header structure + rDim: array [1..3] of integer; + rOri,rMM: array [1..3] of single; + rSliceSz: integer; + end; //TNIFTIhdr Header Structure +var + //lStartTime,lEndTime: DWord; + lIn,lOut: TXImg; + lBuffIn,lBuffOut,lBuffOutUnaligned: Bytep; + lBuffIn16,lBuffOut16 : SmallIntP; + lBuffIn32,lBuffOut32 : SingleP; + lX,lY,lZ,lI,lPos,lOutVolItems,lInZPos,lInYPos,lOutZPos,lOutYPos,lInZPosHi,lInYPosHi: integer; + lXmodLo,lXmodHi,lYmodLo,lYmodHi,lZmodLo,lZmodHi: single; + lScale,lFloatPos: single; + lMin,lMax: array [1..3] of integer; + lLUTra: array [1..3] of LongIntp; + lLUTmodRA: array [1..3] of Singlep; +begin + result := false; + // if lHdr.ImgBufferBPP = 4 then exit; + if not TestSameOrtho(lHdr) then exit; + //if lHdr.ImgBufferBPP <> 1 then exit; + //lStartTime := GetTickCount; + for lI := 1 to 3 do begin + lIn.rDim[lI] := lHdr.NIFTIhdr.dim[lI]; + lIn.rMM[lI] := lHdr.NIFTIhdr.pixdim[lI]; + lIn.rOri[lI] := (abs(lHdr.Mat.Matrix[lI,4]))/abs(lHdr.NIFTIhdr.pixdim[lI])+1;//May07 + end; + lIn.rSliceSz := lIn.rDim[1]*lIn.rDim[2]; + //Output to background size + for lI := 1 to 3 do begin + lOut.rDim[lI] := lBGImg.ScrnDim[lI]; + lOut.rMM[lI] := lBGImg.ScrnMM[lI]; + lOut.rOri[lI] := lBGImg.ScrnOri[lI]; +// fx(lOut.rDim[lI],lOut.rMM[lI],lOut.rOri[lI]); + end; + lOut.rSliceSz := lOut.rDim[1]*lOut.rDim[2]; + lOutVolItems := lOut.rSliceSz * lOut.rDim[3]; //InVolSz! + //find bounding box for overlay, and create lookup tables + for lI := 1 to 3 do begin + lScale := lOut.rMM[lI] / lIn.rMM[lI]; + getmem(lLUTra[lI],lOut.rDim[lI]*4); + getmem(lLUTmodra[lI],lOut.rDim[lI]*4); + lMin[lI] := maxint; + lMax[lI] := -1; + for lPos := 1 to lOut.rDim[lI] do begin + if lBGImg.OverlaySmooth then begin + lFloatPos := ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] {-0.5}; + lLUTra[lI]^[lPos] := trunc ( lFloatPos ); + lLUTmodra[lI]^[lPos] := ( frac (lFloatPos )); + end else begin + lLUTra[lI]^[lPos] := round ( ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] ); + lLUTmodra[lI]^[lPos] :=0;//not used + end; + if (lLUTra[lI]^[lPos] > 0) and (lMin[lI]=MaxInt) then + lMin[lI] := lPos; + if (lLUTra[lI]^[lPos] < lIn.rDim[lI]) {danger! <=} then + lMax[lI] := lPos; + end; + end; + //for lI := 1 to 3 do fx( lOut.rMM[lI],lIn.rMM[lI]); + for lI := 1 to 3 do + if lMin[lI] > lMax[lI] then begin + showmessage ('Unusual rotation matrix - consider viewing with MRIcro.');//goto 345; //do after previous loop so we are sure all buffers used + goto 666; + end; + lMax[1] := lMax[1] -1;{-1 as we do not want to sample past edge} + ImgForm.ProgressBar1.Min := lMin[3]; + ImgForm.ProgressBar1.Max := lMax[3]; + //next - core + + if lHdr.ImgBufferBPP = 4 then begin //next- 32 bit + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + //svn lBuffOut32 := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + lBuffOut32 := Align(lBuffOutUnaligned, 16); + for lX := 1 to lOutVolItems do + lBuffOut32^[lX] := 0; //set all to zero + //fx(lOutVolItems,lHdr.ImgBufferItems); + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3]^[lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3]^[lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2]^[lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2]^[lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1]^[lX]; + lXModLo := 1 - lXmodHi; + lBuffOut32^[lOutZPos+lOutYPos+lX] := ( + lBuffIn32^[lInZPos+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn32^[lInZPos+lInYPos+lLUTra[1]^[lX]+1]*lXModHi*lYModLo*lZModLo + + lBuffIn32^[lInZPos+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn32^[lInZPos+lInYPosHi+lLUTra[1]^[lX]+1]*lXModHi*lYModHi*lZModLo + + lBuffIn32^[lInZPosHi+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn32^[lInZPosHi+lInYPos+lLUTra[1]^[lX]+1]*lXModHi*lYModLo*lZModHi + + lBuffIn32^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn32^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX]+1]*lXModHi*lYModHi*lZModHi) ; + end; //for X + end; //for Y + end; //for Z + + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + //svn lHdr.ImgBuffer := ByteP ($fffffff0 and (integer(lHdr.ImgBufferUnaligned )+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut32^,lHdr.ImgBuffer^,lOutVolItems*sizeof(Single));//source/dest + //678 winOnly-> CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut32),(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin //next- 16 bit + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + //svn lBuffOut16 := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + lBuffOut16 := align(lBuffOutUnaligned, 16); + for lX := 1 to lOutVolItems do + lBuffOut16^[lX] := 0; //set all to zero + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3]^[lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3]^[lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2]^[lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2]^[lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1]^[lX]; + lXModLo := 1 - lXmodHi; + lBuffOut16^[lOutZPos+lOutYPos+lX] := round( + lBuffIn16^[lInZPos+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn16^[lInZPos+lInYPos+lLUTra[1]^[lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn16^[lInZPos+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn16^[lInZPos+lInYPosHi+lLUTra[1]^[lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn16^[lInZPosHi+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn16^[lInZPosHi+lInYPos+lLUTra[1]^[lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn16^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn16^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX+1]]*lXModHi*lYModHi*lZModHi) ; + end; //for X + end; //for Y + end; //for Z + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + //lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); + lHdr.ImgBufferItems := lOutVolItems; + Move((lBuffOut16^),(lHdr.ImgBuffer^),lOutVolItems*sizeof(SmallInt));//source/dest + //678 winOnly-> CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut16),(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin //next- 8 bit + lBuffIn := lHdr.ImgBuffer; + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + //for lI := 1 to lOutVolItems do lBuffOut[lI] := 0; //set all to zero + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3]^[lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3]^[lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2]^[lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2]^[lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1]^[lX]; + lXModLo := 1 - lXmodHi; + lBuffOut^[lOutZPos+lOutYPos+lX] := round( + lBuffIn^[lInZPos+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn^[lInZPos+lInYPos+lLUTra[1]^[lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn^[lInZPos+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn^[lInZPos+lInYPosHi+lLUTra[1]^[lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn^[lInZPosHi+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn^[lInZPosHi+lInYPos+lLUTra[1]^[lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX+1]]*lXModHi*lYModHi*lZModHi); + end; //for X + end; //for Y + end; //for Z + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + //svn lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut^,lHdr.ImgBuffer^,lOutVolItems);//source/dest + //678winonly-> CopyMemory((lHdr.ImgBuffer),(lBuffOut),lOutVolItems); + FreeMem(lBuffOut); + end else + Showmessage('Unsupported BPP '+inttostr(lHdr.ImgBufferBPP)); + ImgForm.ProgressBar1.Position := lMin[3]; + result := true; + +666: + for lI := 1 to 3 do begin + freemem(lLUTra[lI]); + freemem(lLUTmodra[lI]); + end; + //Output dimensions: size of background image + //lEndTime := GetTickCount; + //ImgForm.Label1.caption :=('update(ms): '+inttostr(lEndTime-lStartTime)); +end; //procedure OrthogonalResliceImg + +procedure fSwap(var lX,lY: single); +var + lSwap: single; +begin + lSwap := lX; + lX := lY; + lY := lSwap; +end; + +procedure ResliceScrnImg (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; lTrilinearSmooth: boolean); var + lOverlap: boolean; + lMinY,lMinZ,lMaxY,lMaxZ: integer; //<- used by trilinear + lXreal,lYreal,lZreal,lXrM1,lYrM1,lZrM1, //<- used by trilinear + lZr,lYr,lXr,lZx,lZy,lZz,lYx,lYy,lYz: single;//lSwap + lZ,lY,lX,lOutVolItems,lInVolItems, + lXdimIn,lYDimIn,lZDimIn,lInSliceSz, + lOutPos,lOutDimX,lOutDimY,lOutDimZ,lXo,lYo,lZo: integer;//lSrcPos + lXxp,lXyp,lXzp: Pointer; + lXxra,lXyra,lXzra : SingleP; + lMatrix,lMatrixBG: TMatrix; + lBuffIn,lBuffOut,lBuffOutUnaligned: Bytep; + lBuffIn16,lBuffOut16 : SmallIntP;//16bit + lBuffIn32,lBuffOut32: SingleP; + begin + if SameAsBG(lBGImg,lHdr) then exit; + if lBGImg.OverlaySmooth then showmessage('ats') else showmessage('ann'); + if not lBGImg.Resliced then begin //2008 + Reslice_Img_To_Unaligned (gMRIcroOverlay[kBGOverlayNum].NIftiHdr, lHdr, lBGImg.OverlaySmooth); + exit; + end; + //if lTrilinearSmooth then showmessage('ts') else showmessage('nn'); + if OrthoReslice(lBGImg,lHdr) then exit; + lOverlap := false; + lMatrix := lHdr.Mat; + lMatrix := mat44_inverse(lMatrix); + lMatrixBG := Matrix3D ( lBGImg.Scrnmm[1],0,0,0, + 0,lBGImg.Scrnmm[2],0,0, + 0,0,lBGImg.Scrnmm[3],0, + 0,0,0,1); + lMatrix.size := size3D; + lMatrix := MultiplyMatrices(lMatrix,lMatrixBG); + lXdimIn := lHdr.NiftiHdr.dim[1]; + lYdimIn := lHdr.NiftiHdr.dim[2]; + lZDimIn := lHdr.NiftiHdr.dim[3]; + lInSliceSz := lHdr.NiftiHdr.dim[1]*lHdr.NiftiHdr.dim[2]; + lInVolItems := lInSliceSz*lHdr.NiftiHdr.dim[3]; + if (lHdr.ImgBufferItems < lInVolItems) then + exit; + lBuffIn := lHdr.ImgBuffer; + lOutDimX := lBGImg.ScrnDim[1]; + lOutDimY := lBGImg.ScrnDim[2]; + lOutDimZ := lBGImg.ScrnDim[3]; + //lOutSliceSz := lOutDimX*lOutDimY; + lOutVolItems := lBGImg.ScrnDim[1]*lBGImg.ScrnDim[2]*lBGImg.ScrnDim[3]; + lOutPos := 0; + //start look up table... + GetMem(lXxp, (sizeof(single)* lOutDimX)+16); + GetMem(lXyp, (sizeof(single)* lOutDimX)+16); + GetMem(lXzp, (sizeof(single)* lOutDimX)+16); + lXxRA := align(lXxp, 16); //SingleP($fffffff0 and (integer(lXxP)+15)); //data aligned to quad-word boundary + lXyRA := align(lXyp, 16);//SingleP($fffffff0 and (integer(lXyP)+15)); //quad-word boundary + lXzRA := align(lXzp, 16);//SingleP($fffffff0 and (integer(lXzP)+15)); //quad-word boundary + + for lX := 1 to lOutDimX do begin + lXr := lX-(lBGImg.ScrnOri[1]);//* lBGImg.ScrnMM[1]) ; + //lXr := lX; + lXxRA^[lX] := lXr*lMatrix.matrix[1,1]+1; + lXyRA^[lX] := lXr*lMatrix.matrix[2,1]+1; + lXzRA^[lX] := lXr*lMatrix.matrix[3,1]+1; + end; + + //end look up table +if lTrilinearSmooth then begin //smooth data + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + lBuffOut32 := align(lBuffOutUnaligned, 16); //SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut32^[lX] := 0; //set all to zero + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA^[lX]+lYx+lZx; + lYreal := lXyRA^[lX]+lYy+lZy; + lZreal := lXzRA^[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lMaxY := ((lYo)*lXdimIn); + lMaxZ := ((lZo)*lInSliceSz); + lOverlap := true; + lBuffOut32^[lOutPos] := ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn32^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn32^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn32^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn32^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn32^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn32^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn32^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn32^[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 32 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16);//ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut32^,lHdr.ImgBuffer^,lOutVolItems*sizeof(Single));//source/dest + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + lBuffOut16 := align(lBuffOutUnaligned, 16); //SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut16^[lX] := 0; //set all to zero + //core 16 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA^[lX]+lYx+lZx; + lYreal := lXyRA^[lX]+lYy+lZy; + lZreal := lXzRA^[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lXrM1 := 1-lXreal; + lYreal := lYreal-lYo; + lYrM1 := 1-lYreal; + lZreal := lZreal-lZo; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMaxY := lMinY+lXdimIn; + lMinZ := ((lZo-1)*lInSliceSz); + lMaxZ := lMinZ+lInSliceSz; + lOverlap := true; + lBuffOut16^[lOutPos] := round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn16^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn16^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn16^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn16^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn16^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn16^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn16^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn16^[lXo+1+lMaxY+lMaxZ]) ); (**) + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 16 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); //ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut16^,lHdr.ImgBuffer^,lOutVolItems*sizeof(SmallInt));//source/dest + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA^[lX]+lYx+lZx; + lYreal := lXyRA^[lX]+lYy+lZy; + lZreal := lXzRA^[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lMaxY := ((lYo)*lXdimIn); + lMaxZ := ((lZo)*lInSliceSz); + lOverlap := true; + lBuffOut^[lOutPos] := round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn^[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); //ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut^,lHdr.ImgBuffer^,lOutVolItems);//source/dest + FreeMem(lBuffOut); + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); +end else begin //not trilinear - use nearest neighbor + //start nearest neighbor + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + lBuffOut32 := align(lBuffOutUnaligned, 16);//SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut32^[lX] := 0; //set all to zero + //core 32 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA^[lX]+lYx+lZx); + lYo := round(lXyRA^[lX]+lYy+lZy); + lZo := round(lXzRA^[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lOverlap := true; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lBuffOut32^[lOutPos] := lBuffIn32^[lXo+lMinY+lMinZ]; + end; + end; //for X + end; //for OutY + end; //for OutZ + //core 32 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16);//ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut32^,lHdr.ImgBuffer^,lOutVolItems*sizeof(Single));//source/dest + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + lBuffOut16 := align(lBuffOutUnaligned, 16);//SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut16^[lX] := 0; //set all to zero + //core 16 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA^[lX]+lYx+lZx); + lYo := round(lXyRA^[lX]+lYy+lZy); + lZo := round(lXzRA^[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lOverlap := true; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lBuffOut16^[lOutPos] := lBuffIn16^[lXo+lMinY+lMinZ]//lBuffIn16[lXo+lYo+lZo]; xxxx + + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 16 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16);// ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut16^,lHdr.ImgBuffer^,lOutVolItems*sizeof(SmallInt));//source/dest + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA^[lX]+lYx+lZx); + lYo := round(lXyRA^[lX]+lYy+lZy); + lZo := round(lXzRA^[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lOverlap := true; + lBuffOut^[lOutPos] := lBuffIn^[lXo+lMinY+lMinZ]; + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16);//ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut^,lHdr.ImgBuffer^,lOutVolItems);//source/dest + FreeMem(lBuffOut); + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); //end nearest neighbor +end; //end if trilinear else nearest neighbor +if not lOverlap then + showmessage('No overlap between image and background bounding box - check the transfomation matrices.'); + FreeMem(lXxp); + FreeMem(lXyp); + FreeMem(lXzp); +end; //ResliceScrnImg + + +procedure InvertScrnBuffer(var lHdr: TMRIcroHdr); +var lPos: integer; +begin + if lHdr.ScrnBufferItems < 1 then exit; + lHdr.Zero8Bit := lHdr.Zero8Bit+(255*lHdr.Slope8bit); + lHdr.Slope8bit := -lHdr.Slope8bit; + for lPos := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lPos] := 255- lHdr.ScrnBuffer^[lPos]; + {lMin := 255; + for lPos := 1 to lHdr.ScrnBufferItems do + if lMin > lHdr.ScrnBuffer[lPos] then lMin := lHdr.ScrnBuffer[lPos]; + } + //showmessage('inv'+inttostr(lMin)); +end; + +const + kMin8bit = 1; + +procedure RescaleImgIntensity(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lLayer: integer ); +var + lImgSamples: integer; + //lFiltMin8bit,lFiltMax8bit: integer; + //lMin,lMax: single; +begin + lImgSamples := round(ComputeImageDataBytes8bpp(lHdr)); + if (lHdr.ImgBufferItems = 0) and (lHdr.ScrnBufferItems > 0) then begin //image buffer loaded - not VOIs have screen but not img buffers + if lBackgroundImg.VOImirrored then + MirrorScrnBuffer(lBackgroundImg,lHdr); + lBackgroundImg.VOImirrored := false; + exit; + end; + if lHdr.ImgBufferItems<>lHdr.ScrnBufferItems then begin + if lHdr.ScrnBufferItems > 0 then + freemem(lHdr.ScrnBuffer); + lHdr.ScrnBufferItems := lHdr.ImgBufferItems; + GetMem(lHdr.ScrnBuffer ,lHdr.ScrnBufferItems); + end; + if lHdr.ImgBufferItems = 0 then + exit; //2/2010 + if (lHdr.UsesCustomPalette) and (not lHdr.UsesCustomPaletteRandomRainbow) then begin //2014 + lHdr.WindowScaledMin := kMin8bit; + lHdr.WindowScaledMax := 255; + end; + + if lImgSamples < 1 then + exit; + if (lHdr.ImgBufferBPP = 4) then + RescaleImgIntensity32(lHdr) + else if (lHdr.ImgBufferBPP = 2) then + RescaleImgIntensity16(LHdr) + else if lHdr.ImgBufferBPP = 1 then + RescaleImgIntensity8(lHdr) + else begin + showmessage(inttostr(lHdr.ImgBufferItems)+'Unknown Image Buffer Bytes Per Pixel: '+inttostr(lHdr.ImgBufferBPP)+' : '+lHdr.HdrFileName); + exit; + end; + + //if not lHdr.SameDimsAsBG then OrthogonalResliceScrnImg (lBackgroundImg, lHdr); + //ReturnRawMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + if (lLayer <> kBGOverlayNum) and ((lHdr.WindowScaledMin <= 0) and (lHdr.WindowScaledMax <= 0)) then + InvertScrnBuffer(lHdr); + FilterScrnImg (lHdr);//,lFiltMin8bit,lFiltMax8bit); + + if lBackgroundImg.Mirror then + MirrorScrnBuffer(lBackgroundImg,lHdr); +end; //RescaleImgIntensity32 + +function PtoLog10 ( lIn: double): double; //in= pvalue <=1 +begin + //result := -log(abs(lIn),10) + result := -log((lIn),10) +end; + +function Log10toP (lIn: double): double; +begin + //result := log((lIn),10) + result := 1/power(10,lIn); //requires Math unit +end; + +procedure ComputeFDR (var lInHdr: TMRIcroHdr; var lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01: single); +//(lImg2Load.NIFTIhdr.intent_code,round(lImg2Load.NIFTIhdr.intent_p1),lImg2Load.ImgBufferItems,lImg2Load.ImgBufferBPP,lImg2Load.ImgBuffer,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); +//procedure ComputeFDR(lStatIntent,lDF,lImgSamples,lImgBPP: integer; l32Buf:SingleP; var lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01: single); +//StatIntents in kNIFTI_INTENT_CHISQ, kNIFTI_INTENT_ZSCORE,kNIFTI_INTENT_TTEST +//Note DF meaningless for ZScore +label 555; +var + lPs: SingleP; //array of tests + lStr: string; + lStatIntent,lImgSamples,lnTests,lInc,lDF: integer; + lPrevP,lP,lFDR05p, lFDR01p,lnegFDR05p, lnegFDR01p,lnegFDR05, lnegFDR01 : double; + l32Buf : SingleP; +begin + + lStatIntent := lInHdr.NIFTIhdr.intent_code; + lDF := round(lInHdr.NIFTIhdr.intent_p1); + if ((lStatIntent = kNIFTI_INTENT_CHISQ) or (lStatIntent = kNIFTI_INTENT_TTEST)) and (lDF <= 1) then //May07 + lDF := ReadIntForm.GetInt('Please specify degrees of freedom for '+extractfilename(lInHdr.HdrFileName),1,16,32000); + lImgSamples := lInHdr.ImgBufferItems; + if (lImgSamples < 1) then exit; + ImgForm.StatusLabel.Caption := 'Computing FDR rates...'; + ImgForm.refresh; + //next: count number of tests [we could just rely on value lChiSamples to us, but perhaps value in intention is not correct + lnTests := 0; + + l32Buf := SingleP(lInHdr.ImgBuffer ); + for lInc := 1 to lImgSamples do + if l32Buf^[lInc] <> 0 then + inc(lnTests); + + if lnTests < 1 then exit; + GetMem(lPs,lnTests*sizeof(single)); + //for lInc := 1 to lnTests do lPs[lInc] := 1; + //next - place Pvalues in array, as computing P is slow, we remember last Pvalue + lPrevP := 0; + lnTests := 0; + lP := 1; //never used + //lStartTime := GetTickCount; + for lInc := 1 to lImgSamples do + if l32Buf^[lInc] <> 0 then begin + inc(lnTests); + if l32Buf^[lInc] <> lPrevP then + case lStatIntent of + kNIFTI_INTENT_TTEST: lP := pTdistr(lDF,l32Buf^[lInc]);//slow!! 110ms + kNIFTI_INTENT_ZSCORE: lP := pNormal(l32Buf^[lInc]);//slow!! 94ms + kNIFTI_INTENT_PVAL: lP := l32Buf^[lInc]; + NIFTI_INTENT_LOG10PVAL: lP := Log10toP(l32Buf^[lInc]); + else {kNIFTI_INTENT_CHISQ:}begin + if l32Buf^[lInc] < 0 then //MRIcro saves negative Chi + lP := 0.6 + else + lP := pChi2(lDF,l32Buf^[lInc]);//slow! 47ms + end; + end; + lPs^[lnTests] := lP; + lPrevP := l32Buf^[lInc]; + end; //Chi <> 0 + //ImgForm.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); + + + //EstimateFDR(lnTests, lPs, lFDR05p, lFDR01p); + EstimateFDR2(lnTests, lPs, lFDR05p, lFDR01p,lnegFDR05p, lnegFDR01p); + //lStartTime := GetTickCount; + //next histogram! + (*for lInc := 1 to lnTests do + lPs^[lInc] := pNormalInvQuickApprox(lPs^[lInc]); //slow!!!!!!!!! >5100ms + lHdr.ImgBufferBPP := 4; + lHdr.ImgBufferItems :=lnTests; + lHdr.GlMaxUnscaledS :=lPs^[1]; + lHdr.GlMinUnscaledS := lPs^[lnTests]; + lHdr.ImgBuffer :=bytep(lPs); + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; + lInc := 0;//B&W + LoadMonochromeLUT(lInc,gBGImg,lHdr); + DrawHistogram(lHdr,HistogramForm.HistoImage); + HistogramForm.Caption := 'Z Histogram'+realtostr(lHdr.GlMinUnscaledS,6)+'..'+realtostr(lHdr.GlMaxUnscaledS,6); + HistogramForm.show; + ImgForm.PGImageCor.refresh; + //ImgForm.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); + //showmessage('Z Histogram'+realtostr(lHdr.GlMinUnscaledS,6)+'..'+realtostr(lHdr.GlMaxUnscaledS,6)); + //end histogram *) +555: + + FreeMem(lPs); + case lStatIntent of + kNIFTI_INTENT_CHISQ:begin + lP05:= pChi2Inv(lDF,0.05); + lP01 := pChi2Inv(lDF,0.01); + lFWE05 := pChi2Inv(lDF,0.05/lnTests); + lFWE01 := pChi2Inv(lDF,0.01/lnTests); + lFDR05 := pChi2Inv(lDF,lFDR05p); + lFDR01 := pChi2Inv(lDF,lFDR01p); + lnegFDR05 := pChi2Inv(lDF,lnegFDR05p); + lnegFDR01 := pChi2Inv(lDF,lnegFDR01p); + lStr := 'X DF='+inttostr(lDF); + end; + kNIFTI_INTENT_ZSCORE: begin + lP05:= pNormalInv(0.05); + lP01 := pNormalInv(0.01); + lFWE05 := pNormalInv(0.05/lnTests); + lFWE01 := pNormalInv(0.01/lnTests); + lFDR05 := pNormalInv(lFDR05p); + lFDR01 := pNormalInv(lFDR01p); + lnegFDR05 := pNormalInv(lnegFDR05p); + lnegFDR01 := pNormalInv(lnegFDR01p); + lStr := 'Z'; + end; + kNIFTI_INTENT_TTEST: begin + lP05:= pTdistrInv(lDF,0.05); + lP01 := pTdistrInv(lDF,0.01); + lFWE05 := pTdistrInv(lDF,0.05/lnTests); + lFWE01 := pTdistrInv(lDF,0.01/lnTests); + lFDR05 := pTdistrInv(lDF,lFDR05p); + lFDR01 := pTdistrInv(lDF,lFDR01p); + lnegFDR05 := pTdistrInv(lDF,lnegFDR05p); + lnegFDR01 := pTdistrInv(lDF,lnegFDR01p); + lStr := 't DF='+inttostr(lDF); + + end; + kNIFTI_INTENT_PVAL:begin + lP05:= (0.05); + lP01 := (0.01); + lFWE05 := (0.05/lnTests); + lFWE01 := (0.01/lnTests); + lFDR05 := (lFDR05p); + lFDR01 := (lFDR01p); + lnegFDR05 := (lnegFDR05p); + lnegFDR01 := (lnegFDR01p); + lStr := 'p'; + end; + NIFTI_INTENT_LOG10PVAL: begin + lP05:= PtoLog10(0.05); + lP01 := PtoLog10(0.01); + lFWE05 := PtoLog10(0.05/lnTests); + lFWE01 := PtoLog10(0.01/lnTests); + lFDR05 := PtoLog10(lFDR05p); + lFDR01 := PtoLog10(lFDR01p); + lnegFDR05 := PtoLog10(lnegFDR05p); + lnegFDR01 := PtoLog10(lnegFDR01p); + + lStr := 'log10p'; + end; + else + Showmessage('Error: unknown stats intent'); + end; //case + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lFDR05 < lFWE05) then + lFDR05 := lFWE05; + end else if (lFDR05 > lFWE05) then + lFDR05 := lFWE05; + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lFDR01 < lFWE01) then + lFDR01 := lFWE01; + end else if (lFDR01 > lFWE01) then + lFDR01 := lFWE01; + + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lnegFDR05 > -lFWE05) then + lnegFDR05 := -lFWE05; + if (lnegFDR01 > -lFWE01) then + lnegFDR01 := -lFWE01; + end else begin + if (lnegFDR05 < -lFWE05) then + lnegFDR05 := -lFWE05; + if (lnegFDR01 < -lFWE01) then + lnegFDR01 := -lFWE01; + end; + ImgForm.StatusLabel.Caption := lStr+' Tests='+inttostr(lnTests)+' p05='+realtostr(lP05,4)+ ' p01='+realtostr(lP01,4)+' fwe05='+realtostr(lFWE05,4)+ ' fwe01='+realtostr(lFWE01,4) + +' fdr05='+realtostr(lFDR05,4)+' fdr01='+realtostr(lFDR01,4) + +' -fdr05='+realtostr(lnegFDR05,4)+' -fdr01='+realtostr(lnegFDR01,4) ; +end; + +function MakeSameOrtho(var lBGImg: TBGImg; var lHdr: TMRIcroHdr):boolean; +//this function disables reslicing - images will be shown unrotated and unscaled... +var + lRow: integer; +begin + result := false; + for lRow := 1 to 3 do begin + //lHdr.NIFTIhdr.pixdim[lRow] := 1; //Apr07 + if lHdr.NIFTIhdr.dim[lRow] <>lBGImg.ScrnDim[lRow] then + exit; + end; + lHdr.Mat:= Matrix3D ( lBGImg.Scrnmm[1],0,0,-lBGImg.Scrnmm[1]*(lBGImg.ScrnOri[1]-1), + 0,lBGImg.Scrnmm[2],0,-lBGImg.Scrnmm[2]*(lBGImg.ScrnOri[2]-1), + 0,0,lBGImg.Scrnmm[3],-lBGImg.Scrnmm[3]*(lBGImg.ScrnOri[3]-1), + 0,0,0,1); + result := true; +end; + +procedure FindAlignment (var lBGImg: TBGImg; var lHdr: TMRIcroHdr); +//identifies spatial position of low X,Y,Z voxels : A/P/L/R/S/I +var + lDim: integer; + lXMid,lYMid,lZMid,laX,laY,laZ,lX,lY,lZ,lX2,lY2,lZ2: single; + lMatrix: TMatrix; +begin + lBGImg.KnownAlignment := false; + if not IsNifTiMagic (lHdr.NIFTIHdr) then + exit; //Analyze format: spatial coordinates are amibguous + if (lHdr.NIFTIhdr.sform_code <= 0) and (lHdr.NIFTIhdr.qform_code <= 0) then + exit; //NIfTI format with unspecified coordinates + lBGImg.KnownAlignment := true; + if (lBGImg.Resliced) and (lHdr.NIFTIhdr.sform_code > 0) then begin + lBGImg.MinChar[1] := 'L'; + lBGImg.MaxChar[1] := 'R'; + lBGImg.MinChar[2] := 'P'; + lBGImg.MaxChar[2] := 'A'; + lBGImg.MinChar[3] := 'I'; + lBGImg.MaxChar[3] := 'S'; + exit; + end; + if (not gBGImg.OrthoReslice) then begin + lBGImg.MinChar[1] := ' '; + lBGImg.MaxChar[1] := ' '; + lBGImg.MinChar[2] := ' '; + lBGImg.MaxChar[2] := ' '; + lBGImg.MinChar[3] := ' '; + lBGImg.MaxChar[3] := ' '; + exit; + end; + //there are two approaches to solve this - a more elegant solution is to find the nearest orthogonal aligment + //the method below is simpler, but might give unusual results if the field of view in one dimension is much larger than another + lMatrix := lHdr.Mat; + lXMid := lHdr.NIFTIhdr.Dim[1] div 2; + lYMid := lHdr.NIFTIhdr.Dim[2] div 2; + lZMid := lHdr.NIFTIhdr.Dim[3] div 2; + for lDim := 1 to 3 do begin + if lDim = 1 then begin + FindMatrixPt(0,lYMid,lZMid,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid*2,lYMid,lZMid,lX2,lY2,lZ2,lMatrix); + end else if lDim = 2 then begin + FindMatrixPt(lXMid,0,lZMid,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid,lYMid*2,lZMid,lX2,lY2,lZ2,lMatrix); + end else begin //lDim=3 + FindMatrixPt(lXMid,lYMid,0,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid,lYMid,lZMid*2,lX2,lY2,lZ2,lMatrix); + end; + lX := lX-lX2; laX := abs(lX); + lY := lY-lY2; laY := abs(lY); + lZ := lZ-lZ2; laZ := abs(lZ); + if (laX > laY) and (laX > laZ) then begin + if lX < 0 then begin + lBGImg.MinChar[lDim] := 'L'; + lBGImg.MaxChar[lDim] := 'R'; + end else begin + lBGImg.MinChar[lDim] := 'R'; + lBGImg.MaxChar[lDim] := 'L'; + end; + end else if (laY > laZ) then begin + if lY < 0 then begin + lBGImg.MinChar[lDIm] := 'P'; + lBGImg.MaxChar[lDim] := 'A'; + end else begin + lBGImg.MinChar[lDim] := 'A'; + lBGImg.MaxChar[lDim] := 'P'; + end; + end else if (laZ > laX) then begin + if lZ < 0 then begin + lBGImg.MinChar[lDim] := 'I'; + lBGImg.MaxChar[lDim] := 'S'; + end else begin + lBGImg.MinChar[lDim] := 'S'; + lBGImg.MaxChar[lDim] := 'I'; + end; + end else begin //all dims are equal + lBGImg.MinChar[lDim] := '?'; + lBGImg.MaxChar[lDim] := '?'; + end; + end;//for each dim + +end; //proc FindAlignment + +function DICOMMirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfY,lLineOffset,lLineOffsetIn: integer; + lTemp32: single; + lTemp16: SmallInt; + lTemp: byte; + l32: SingleP; + l16: SmallIntP; +begin + result := false; + lX := lHdr.NIFTIhdr.Dim[1]; + lY := lHdr.NIFTIhdr.Dim[2]; + lZ := lHdr.NIFTIhdr.Dim[3]; + if lHdr.NIFTIhdr.Dim[4] > 1 then begin + Showmessage('Can not mirror 4D data : '+lHdr.HdrFileName); + exit; + end; + if (lHdr.ImgBufferItems < (lX*lY*lZ)) or (lX < 2) then begin + Showmessage('Unsupported filetype : '+lHdr.HdrFileName); + exit; + end; + lHlfY := lY div 2; + lLineOffset := 0; + + //for each datatype... + if lHdr.ImgBufferBPP = 4 then begin + l32 := SingleP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp32 := l32^[lXPos+lLineOffsetIn]; + l32^[lXPos+lLineOffsetIn] := l32^[lXPos+lLineOffset]; + l32^[lXPos+lLineOffset] := lTemp32; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + + end else if lHdr.ImgBufferBPP = 2 then begin + l16 := SmallIntP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp16 := l16^[lXPos+lLineOffsetIn]; + l16^[lXPos+lLineOffsetIn] := l16^[lXPos+lLineOffset]; + l16^[lXPos+lLineOffset] := lTemp16; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 1 then begin + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp := lHdr.ImgBuffer^[lXPos+lLineOffsetIn]; + lHdr.ImgBuffer^[lXPos+lLineOffsetIn] := lHdr.ImgBuffer^[lXPos+lLineOffset]; + lHdr.ImgBuffer^[lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); + result := true; +end; //proc DICOMMirrorImgBuffer + +function isPlanarImg( rawRGB: bytep; lX, lY, lZ: integer): boolean ; +var + pos, posEnd, incPlanar, incPacked, byteSlice: integer; + dxPlanar, dxPacked: double; +begin + //determine if RGB image is PACKED TRIPLETS (RGBRGBRGB...) or planar (RR..RGG..GBB..B) + //assumes strong correlation between voxel and neighbor on next line + result := false; + if (lY < 2) then exit; //requires at least 2 rows of data + incPlanar := lX; //increment next row of PLANAR image + incPacked := lX * 3; //increment next row of PACKED image + byteSlice := incPacked * lY; //bytes per 3D slice of RGB data + dxPlanar := 0.0;//difference in PLANAR + dxPacked := 0.0;//difference in PACKED + pos := ((lZ div 2) * byteSlice)+1; //offset to middle slice for 3D data + posEnd := pos + byteSlice - incPacked; + while (pos <= posEnd) do begin + dxPlanar := dxPlanar + abs(rawRGB[pos]-rawRGB[pos+incPlanar]); + dxPacked := dxPacked + abs(rawRGB[pos]-rawRGB[pos+incPacked]); + pos := pos + 1; + end; + result := (dxPlanar < dxPacked); +end; + +function ParseRGB (var lHdr: TMRIcroHdr): boolean;//RGB +//red green blue saved as contiguous planes... +var + lInSlice,lOutSlice,lZ,lSliceSz,lSliceVox,lInPos,lOutPos: integer; + isPlanarRGB: boolean; + lP: bytep; +begin + result := false; + lSliceSz := lHdr.NIFTIhdr.Dim[1]*lHdr.NIFTIhdr.Dim[2]; + lZ := lSliceSz * 3 * lHdr.NIFTIhdr.Dim[3]; + if lZ < 1 then exit; + getmem( lP,lZ); + Move(lHdr.ImgBuffer^,lP^,lZ); + freemem(lHdr.ImgBufferUnaligned); + lZ := lSliceSz * lHdr.NIFTIhdr.Dim[3]; + GetMem(lHdr.ImgBufferUnaligned ,lZ+16); + //lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned,16); + if gBGImg.PlanarRGB = 0 then + isPlanarRGB := false + else if gBGImg.PlanarRGB = 1 then + isPlanarRGB := true + else + isPlanarRGB := isPlanarImg(lP, lHdr.NIFTIhdr.Dim[1], lHdr.NIFTIhdr.Dim[2], lHdr.NIFTIhdr.Dim[3]); + if isPlanarRGB then begin + if (lHdr.Index mod 3) = 1 then //green + lInSlice := lSliceSz + else if (lHdr.Index mod 3) = 2 then//blue + lInSlice := lSliceSz+lSliceSz + else + lInSlice := 0; + lOutSlice := 0; + for lZ := 1 to lHdr.NIFTIhdr.Dim[3] do begin + for lSliceVox := 1 to lSliceSz do begin + lHdr.ImgBuffer^[lSliceVox+lOutSlice] := lP^[lSliceVox+lInSlice]; + end; + inc(lOutSlice,lSliceSz); + inc(lInSlice,lSliceSz+lSliceSz+lSliceSz); + end; + end else begin + if (lHdr.Index mod 3) = 1 then //green + lInPos := 2 + else if (lHdr.Index mod 3) = 2 then//blue + lInPos := 3 + else + lInPos := 1; + for lOutPos := 1 to lZ do begin + lHdr.ImgBuffer^[lOutPos] := lP^[lInPos]; + lInPos := lInPos + 3; + end; + end; + freemem(lP); + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := 0; + lHdr.LUT[lZ].rgbGreen := 0; + lHdr.LUT[lZ].rgbBlue := 0; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + if (lHdr.Index mod 3) = 1 then begin//green + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbGreen := lZ; + end else if (lHdr.Index mod 3) = 2 then begin //blue + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbBlue := lZ; + end else begin + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbRed := lZ; + end; + result := true; +end; + +(*function ParseRGB (var lHdr: TMRIcroHdr): boolean;//RGB +//red green blue saved as contiguous planes... +var + lInSlice,lOutSlice,lZ,lSliceSz,lSliceVox: integer; + lP: bytep; +begin + result := false; + lSliceSz := lHdr.NIFTIhdr.Dim[1]*lHdr.NIFTIhdr.Dim[2]; + lZ := lSliceSz * 3 * lHdr.NIFTIhdr.Dim[3]; + if lZ < 1 then exit; + getmem( lP,lZ); + Move(lHdr.ImgBuffer^,lP^,lZ); + freemem(lHdr.ImgBufferUnaligned); + lZ := lSliceSz * lHdr.NIFTIhdr.Dim[3]; + GetMem(lHdr.ImgBufferUnaligned ,lZ+16); + {$IFDEF FPC} + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned,16); + {$ELSE} + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + if (lHdr.Index mod 3) = 1 then //green + lInSlice := lSliceSz + else if (lHdr.Index mod 3) = 2 then//blue + lInSlice := lSliceSz+lSliceSz + else + lInSlice := 0; + + lOutSlice := 0; + for lZ := 1 to lHdr.NIFTIhdr.Dim[3] do begin + for lSliceVox := 1 to lSliceSz do begin + lHdr.ImgBuffer^[lSliceVox+lOutSlice] := lP^[lSliceVox+lInSlice]; + end; + inc(lOutSlice,lSliceSz); + inc(lInSlice,lSliceSz+lSliceSz+lSliceSz); + end; + freemem(lP); + if (lHdr.Index mod 3) = 1 then //green + lZ := 3 + else if (lHdr.Index mod 3) = 2 then //blue + lZ := 2 + else //red + lZ := 1; + + LoadMonochromeLUT (lZ, gBGImg, lHdr) ; + result := true; +end; *) + +procedure NonReslicedGB (var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr);//vcx +begin + if lImg2Load.NIfTItransform then + lBackgroundImg.InvMat := Hdr2InvMat (lImg2Load.NIftiHdr,lImg2Load.NIfTItransform ); + FindMatrixBounds(lBackgroundImg,lImg2Load,false); + FindAlignment(lBackgroundImg,lImg2Load); + MakeSameOrtho(lBackgroundImg,lImg2Load); +end; + +procedure ReorientToNearestOrtho (var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground: boolean); +//only apply this to the background image - other routines will reorient overlays +begin + lBackgroundImg.ReorientHdr := lImg2Load.NIFTIhdr;//vcx + if not OrthoReorientCore(lImg2Load,false) then exit;//no change + if not lLoadBackground then exit; //no change in bounding box + lBackgroundImg.UseReorientHdr := true; + NonReslicedGB(lBackgroundImg,lImg2Load); +end; + +function OpenImg(var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground,lVOILoadAsBinary,lNoScaling8bit,lResliceIn,l4D: boolean): boolean; +//lReslice: use orientation matrix to transform image -> do not use if l4D = true +//l4D: load all slices of a 4D volume +label +456; +var + lReslice,lSwap: boolean; + lWordX: word; + lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01:single; + lMinI,lMaxI,lInc: integer; + lMultiImgSzOff,lMultiImgSz,lOffset, + lVol,lnVol,lFileSz,lDataType,lFSz,lImgSamples: Int64; //,lRow + lP: Bytep; + lFName,lParseName: String; + F: file; + l16Buf : SmallIntP; + l32Buf,l32TempBuf : SingleP; + l64Buf : DoubleP; +begin + lReslice := lResliceIn; + if lLoadBackground then begin + lBackgroundImg.LabelRA := nil; + ImgForm.CloseImagesClick(nil); + end; + result := false; + FreeImgMemory(lImg2Load); + if not lImg2Load.DiskDataNativeEndian then + lSwap := true + else + lSwap := false; + if lLoadBackground then begin + lBackgroundImg.UseReorientHdr := false;//vcx + if(lImg2Load.NIFTIhdr.Dim[3] = 1) then + lReslice := false; + lBackgroundImg.Resliced := lReslice; + if not lReslice then + NonReslicedGB(lBackgroundImg,lImg2Load); + FindMatrixBounds(lBackgroundImg,lImg2Load,lReslice); + if (gBGImg.ScrnDim[1] < 2) or (gBGImg.ScrnDim[2] < 2) or (gBGImg.ScrnDim[3] < 1) then begin + Showmessage('Error: this does not appear to be a valid 2D or 3D image.'); + exit; + end; + if (gBGImg.ScrnDim[3] = 1) then begin + lBackgroundImg.Resliced := false; + //showmessage('x'); + end; + FindAlignment(lBackgroundImg,lImg2Load); + end; + + if (not IsNifTiMagic(lImg2Load.niftiHdr)) or (lImg2Load.NIFTIhdr.sform_code < 1) or (lImg2Load.NIFTIhdr.sform_code > 10) then + lBackgroundImg.KnownAlignment := false; + if not lReslice then begin + if lLoadBackground then begin + //MakeSameOrtho(lBackgroundImg,lImg2Load); + FindMatrixBounds(lBackgroundImg,lImg2Load,false); + FindAlignment(lBackgroundImg,lImg2Load); + MakeSameOrtho(lBackgroundImg,lImg2Load); + end; + end; //no reslice... + lDataType := lImg2Load.NIFTIhdr.datatype; + lFName := lImg2Load.ImgFileName; + lMultiImgSz := ComputeImageDataBytes(lImg2Load); + if (lMultiImgSz < 1) then begin + Showmessage('Unable to load this image (to large or corrupt)'); + end; + lOffset := round(lImg2Load.NIFTIhdr.vox_offset); + lMultiImgSzOff := lMultiImgSz + abs(lOffset); + if lImg2Load.NIFTIhdr.dim[4] < 1 then //June2009 - prevent error if 3D image sets field to zero instead of one + lImg2Load.NIFTIhdr.dim[4] := 1; + if lImg2Load.NIFTIhdr.dim[5] < 1 then //June2009 - prevent error if DTI image sets field to zero instead of one + lImg2Load.NIFTIhdr.dim[5] := 1; + lnVol := lImg2Load.NIFTIhdr.dim[4]*lImg2Load.NIFTIhdr.dim[5];//June2009 - for DTI data where direction is 5th dimension + if lMultiImgSz < 1 then exit; + lFSz := FSize(lFName); + + + if (lFSz = 0) then + Showmessage('Unable to find the image file '+lFName); + + lVol := 1; + if lnVol > 1 then begin + if lOffset < 0 then + lFileSz := lMultiImgSzOff * lnVol + else + lFileSz := (lnVol * lMultiImgSz) + lOffset; + lVol := 1; //alpha + if {not l4D} lBackgroundImg.Prompt4DVolume then begin + lVol := ReadIntForm.GetInt('Multi-volume file, please select volume to view.',1,1,lnVol); + application.processmessages; + end; + end else + lFileSz := lMultiImgSzOff; + if ((lFileSz) > lFSz) and (lImg2Load.gzBytesX = K_gzBytes_headerAndImageUncompressed) then begin + ShowMessage('Error: This image file is smaller than described in header.'+ + ' Expected: '+inttostr(lFileSz)+' Selected:'+inttostr(lFSz)+ ' '+lFname); + exit; + end; + {$I-} + AssignFile(F, lFName); + FileMode := 0; { Set file access to read only } + Reset(F, 1); + if (lImg2Load.gzBytesX <> K_gzBytes_headerAndImageUncompressed) then begin //deal with compressed data + if (lImg2Load.gzBytesX = K_gzBytes_headerAndImageCompressed) then begin + if lOffset < 0 then + lOffset := abs(lOffset) + (lMultiImgSzOff *(lVol-1)) + else + lOffset := lOffset + (lMultiImgSz *(lVol-1)); + end else + lOffset := (lMultiImgSz *(lVol-1));//header UNCOMPRESSED! + end else if lOffset < 0 then + Seek (F,abs(lOffset) + (lMultiImgSzOff *(lVol-1)) ) + else + Seek (F,lOffset + (lMultiImgSz *(lVol-1)) ); + + case lDataType of + kDT_SIGNED_SHORT,kDT_UINT16: lImg2Load.ImgBufferBPP := 2; + kDT_SIGNED_INT,kDT_FLOAT: lImg2Load.ImgBufferBPP := 4; + kDT_DOUBLE: lImg2Load.ImgBufferBPP := 8; + kDT_UNSIGNED_CHAR : lImg2Load.ImgBufferBPP := 1; + kDT_RGB: lImg2Load.ImgBufferBPP := 1;//rgb + else begin + showmessage('Unable to read this image format '+inttostr(lDataType)); + goto 456; + end; + end; + //Next get memory + lImgSamples := round(ComputeImageDataBytes8bpp(lImg2Load)); + if lImgSamples < 1 then exit; + lImg2Load.ImgBufferItems := lImgSamples; + lMultiImgSz := (lImgSamples * lImg2Load.ImgBufferBPP); + if lDataType = kDT_RGB then + lMultiImgSz := lMultiImgSz * 3;//RGB + if l4D then begin + lMultiImgSz := lMultiImgSz * lnVol; + lImgSamples := lImgSamples * lnVol; //Apr07 + end; + if lMultiImgSz > freeRam then begin + Showmessage('Unable to load image: not enough RAM.'); + goto 456; + //exit; + end; + try + GetMem(lImg2Load.ImgBufferUnaligned ,lMultiImgSz+16); + except + showmessage('Load Image Error: System memory exhausted.'); + freemem(lImg2Load.ImgBufferUnaligned); + //do goto 456 + exit; + end; + lImg2Load.ImgBuffer := align(lImg2Load.ImgBufferUnaligned, 16); + //Next Load Image + if (lImg2Load.gzBytesX <> K_gzBytes_headerAndImageUncompressed) then begin + lP := ByteP(lImg2Load.ImgBuffer); + if lImg2Load.gzBytesX = K_gzBytes_headerAndImageCompressed then + UnGZip(lFName,lP,lOffset,lMultiImgSz) + else + UnGZip2 (lFName,lP,lOffset,lMultiImgSz, round(lImg2Load.NIFTIhdr.vox_offset)); //unzip + end else + BlockRead(F,lImg2Load.ImgBuffer^,lMultiImgSz); + if IOResult <> 0 then + ShowMessage('Open image file error: '+inttostr(IOResult)); + //Next: prepare image : byte swap, check for special.. + case lDataType of + kDT_RGB: ParseRGB(lImg2Load);//RGB + kDT_SIGNED_SHORT,kDT_UINT16: begin //16-bit int + l16Buf := SmallIntP(lImg2Load.ImgBuffer ); + if lSwap then + for lInc := 1 to lImgSamples do begin + l16Buf^[lInc] := Swap2(l16Buf^[lInc]); + end; + + if (kDT_UINT16=lDataType ) then begin //avoid wrap around if read as signed value + for lInc := 1 to lImgSamples do begin + lWordX := word(l16Buf^[lInc]); + l16Buf^[lInc] := lWordX shr 1; + end; //for + end; //if kDT_UINT16 + end; //16-bit + kDT_SIGNED_INT: begin + l32Buf := SingleP(lImg2Load.ImgBuffer ); + if lSwap then //unswap and convert integer to float + for lInc := 1 to lImgSamples do + l32Buf^[lInc] := (Swap4r4i(l32Buf^[lInc])) + else //convert integer to float + for lInc := 1 to lImgSamples do + l32Buf^[lInc] := Conv4r4i(l32Buf^[lInc]); + end; //32-bit int + kDT_FLOAT: begin + l32Buf := SingleP(lImg2Load.ImgBuffer ); + if lSwap then + for lInc := 1 to lImgSamples do begin + pswap4r(l32Buf^[lInc]) //faster as procedure than function see www.optimalcode.com + end; + for lInc := 1 to lImgSamples do + if specialsingle(l32Buf^[lInc]) then l32Buf^[lInc] := 0.0; + //thresh= for lInc := 1 to lImgSamples do if l32Buf[lInc] < 2.300611 then l32Buf[lInc] := 0.0; + + //invert= for lInc := 1 to lImgSamples do l32Buf[lInc] := -l32Buf[lInc]; + end; //32-bit float + kDT_DOUBLE: begin + l64Buf := DoubleP(lImg2Load.ImgBuffer ); + lImg2Load.ImgBufferBPP := 4; //we will save as 32-bit + lMultiImgSz := (lImgSamples * lImg2Load.ImgBufferBPP); + if l4D then begin + lMultiImgSz := lMultiImgSz * lnVol; + lImgSamples := lImgSamples * lnVol; //Apr07 + end; + try + GetMem(l32TempBuf ,lMultiImgSz+16); + except + showmessage('64-bit Image Error: System memory exhausted.'); + freemem(l32TempBuf); + freemem(lImg2Load.ImgBufferUnaligned); + exit; + end; + if lSwap then begin + for lInc := 1 to lImgSamples do begin + try + l32TempBuf^[lInc] := Swap64r(l64Buf^[lInc]) + except + l32TempBuf^[lInc] := 0; + end; //except + end; //for + end else begin + for lInc := 1 to lImgSamples do begin + try + l32TempBuf^[lInc] := l64Buf^[lInc] + except + l32TempBuf^[lInc] := 0; + end; //except + end; //for + end; //not swap + //now copy from temp buffer to longer-term buffer + freemem(lImg2Load.ImgBufferUnaligned); + try + GetMem(lImg2Load.ImgBufferUnaligned ,lMultiImgSz+16); + except + showmessage('Load Image Error: System memory exhausted.'); + freemem(lImg2Load.ImgBufferUnaligned); + exit; + end; + {$IFDEF FPC} + lImg2Load.ImgBuffer := Align(lImg2Load.ImgBufferUnaligned, 16); + {$ELSE} + lImg2Load.ImgBuffer := ByteP($fffffff0 and (integer(lImg2Load.ImgBufferUnaligned)+15)); + {$ENDIF} + l32Buf := SingleP(lImg2Load.ImgBuffer ); + Move(l32TempBuf^,l32Buf^,lMultiImgSz); + freemem(l32TempBuf); + for lInc := 1 to lImgSamples do + if specialsingle(l32Buf^[lInc]) then l32Buf^[lInc] := 0.0; + //for lInc := 1 to lImgSamples do + // if specialsingle(l32Buf^[lInc]) then l32Buf^[lInc] := 0.0; + end; //64-bit float + kDT_UNSIGNED_CHAR : ; + //else will be aborted at previous case + end;//case lDataType of + if (lDataType = kDT_RGB) then + //do not transform + else if lImg2Load.NIFTIhdr.magic = kNIFTI_MAGIC_DCM then + DICOMMirrorImgBuffer(lImg2Load) + else if (lLoadBackground) and (not lReslice) and (lBackgroundImg.KnownAlignment) and (lBackgroundImg.OrthoReslice) then + ReorientToNearestOrtho(lBackgroundImg,lImg2Load,lLoadBackground) + else if (l4D) and (not lReslice) and (lBackgroundImg.KnownAlignment) and (lBackgroundImg.OrthoReslice) then + OrthoReorientCore(lImg2Load,true); + //next correct image size + if lImg2Load.NIFTIhdr.scl_slope = 0 then + lImg2Load.NIFTIhdr.scl_slope := 1; + if (lLoadBackground) and (not l4D) then + ResliceScrnImg ( lBackgroundImg,lImg2Load,true) + else if not l4D then + ResliceScrnImg ( lBackgroundImg,lImg2Load,lBackgroundImg.OverlaySmooth); //12 April 2009 - allow nearest neighbor + //Next: find min/max - better after reslicing incase we have padded zeros at the edges and zero < min + case lImg2Load.ImgBufferBPP of + 1: begin + FindImgMinMax8 (lImg2Load, lMini,lMaxi); + lImg2Load.GlMaxUnscaledS := lMaxI; + lImg2Load.GlMinUnscaledS := lMinI;; + end; + 2: begin + FindImgMinMax16 (lImg2Load, lMini,lMaxi); + lImg2Load.GlMaxUnscaledS := lMaxI; + lImg2Load.GlMinUnscaledS := lMinI;; + end; + 4: + FindImgMinMax32 (lImg2Load,lImg2Load.GlMinUnscaledS,lImg2Load.GlMaxUnscaledS); + else Showmessage('OpenImg and LoadImg error'); + end; //case ImgBufferBPP + + balance(lImg2Load); //preparecontrast autobalance + lImg2Load.WindowScaledMin := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMinUnscaled); + lImg2Load.WindowScaledMax := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMaxUnscaled); + if (lVOILoadAsBinary) then begin + lImg2Load.WindowScaledMin := kMin8bit;//MAW + lImg2Load.WindowScaledMax := kVOI8bit; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + end else if lDataType = kDT_RGB then begin//RGB + lImg2Load.UsesCustomPalette := true; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lNoScaling8bit) and (lImg2Load.ImgBufferBPP = 1) then begin + lImg2Load.UsesCustomPalette := false; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_ESTIMATE) and (lImg2Load.NIFTIhdr.intent_name[1] = '%') then begin + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 100;//lImg2Load.GlMaxUnscaledS; + lImg2Load.LutFromZero := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if ( (lImg2Load.NIFTIhdr.intent_code = NIFTI_INTENT_LOG10PVAL) or (lImg2Load.NIFTIhdr.intent_code =kNIFTI_INTENT_PVAL) or (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_ZSCORE) or ((lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_TTEST) or (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_CHISQ))) and (lImg2Load.ImgBufferBPP = 4) and (not l4D) then begin + //ComputeFDR(lImg2Load.NIFTIhdr.intent_code,round(lImg2Load.NIFTIhdr.intent_p1),lImg2Load.ImgBufferItems,lImg2Load.ImgBufferBPP,lImg2Load.ImgBuffer,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); + ComputeFDR(lImg2Load,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); + + if (Raw2ScaledIntensity(lImg2Load,lImg2Load.GlMaxUnscaledS)> lFDR05) and (lFDR05 > 0) then begin + lImg2Load.WindowScaledMin := lFDR05; //0.001 xxx + if lFDR01 > 0 then + lImg2Load.WindowScaledMax := lFDR01 + else + lImg2Load.WindowScaledMax := 2*lFDR05; //0.000001 + end else begin + lImg2Load.WindowScaledMin := lP05; //0.001 xxx + lImg2Load.WindowScaledMax := lP01; //0.000001 + end; + if (lImg2Load.WindowScaledMax < 0.00001) and (lImg2Load.WindowScaledMin < 0.00001) then begin + lImg2Load.WindowScaledMax := 5; + lImg2Load.WindowScaledMin := 0; + end; + lImg2Load.LutFromZero := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) and (lImg2Load.ImgBufferBPP = 1) and (lImg2Load.NIFTIhdr.regular = char(98)) then begin + //createLutLabel (lImg2Load, 1.0); + LoadLabelLUT(lBackgroundImg,lImg2Load); + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.UsesCustomPalette := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) and ((lImg2Load.ImgBufferBPP = 1) or (lImg2Load.ImgBufferBPP = 2)) then begin + + createLutLabel (lImg2Load.LUT, 1.0); + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := 0;//kMin8bit; + lImg2Load.WindowScaledMax := 100;//255; + lImg2Load.UsesCustomPalette := true; + lImg2Load.UsesCustomPaletteRandomRainbow := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + if {lLoadBackground} true then begin + if (( lImg2Load.NIFTIhdr.vox_offset- lImg2Load.NIFTIhdr.HdrSz) > 128) then + LoadLabels(lImg2Load.HdrFileName,lBackgroundImg.LabelRA, lImg2Load.NIFTIhdr.HdrSz, round( lImg2Load.NIFTIhdr.vox_offset)) + else + LoadLabelsTxt(lImg2Load.HdrFileName, lBackgroundImg.LabelRA); + if (High(lBackgroundImg.LabelRA) < 1) and (lImg2Load.ImgBufferBPP = 1) then + LoadLabelsOld(lBackgroundImg,lImg2Load); + if High(lBackgroundImg.LabelRA) > 0 then + lImg2Load.UsesLabels := true; + //showmessage(inttostr(High(lBackgroundImg.LabelRA) )+'xxx'); + end + //ImgForm.Help1.caption := 'imaw'+realtostr(lImg2Load.WindowScaledMin,4);//maw + end else begin + if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then begin//>only called when BPP <> 1 + LoadLabelLUT(lBackgroundImg,lImg2Load); + end; + lImg2Load.UsesCustomPalette := false; + lImg2Load.WindowScaledMin := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMinUnscaled); + lImg2Load.WindowScaledMax := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMaxUnscaled); + + end; + lParseName := parsefilename(extractfilename(lImg2Load.HdrFileName)); + if (lParsename = 'ch2bet') or (lParseName = 'ch2better') then begin + lImg2Load.WindowScaledMin := 45; + lImg2Load.WindowScaledMax := 120; + + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end; + if lParseName = 'ch2' then begin + lImg2Load.WindowScaledMin := 30; + lImg2Load.WindowScaledMax := 120; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end; + //Next: create screen buffer [scaled to background] + //if not l4D then //12/2007: do not create screen buffer for 4D load! saves memory and time + // RescaleImgIntensity (lBackgroundImg,lImg2Load); + if not l4D then begin//12/2007: do not create screen buffer for 4D load! saves memory and time + if lLoadBackground then + RescaleImgIntensity (lBackgroundImg,lImg2Load,kBGOverlayNum) + else + RescaleImgIntensity (lBackgroundImg,lImg2Load,kVOIOverlayNum); + end; + if (lVOILoadAsBinary) and (lImg2Load.ScrnBufferItems> 0) then begin + if lImg2Load.NIFTIhdr.intent_name[1] = 'I' then //indexed + showmessage('Indexed drawing - assuming drawing is binary. You may want to upgrade this software.'); + gBGImg.VOIchanged := false; + for lInc := 1 to lImg2Load.ScrnBufferItems do + if lImg2Load.ScrnBuffer^[lInc] > 1 then + lImg2Load.ScrnBuffer^[lInc] := kVOI8bit; + lMaxI := maxint; + LoadMonochromeLUT(lMaxi,lBackgroundImg,lImg2Load); + if lImg2Load.ImgBufferItems > 1 then + freemem(lImg2Load.ImgBufferUnaligned); + lImg2Load.ImgBufferItems := 0; + end else begin + ImgForm.LayerDropSelect(nil); + ImgForm.LUTdropSelect(nil); + end; + result := true; +456: + CloseFile(F); + {$I+} + FileMode := 2; +end; //proc OpenImg + +end. diff --git a/backup/nifti_img_view.lfm.bak b/backup/nifti_img_view.lfm.bak new file mode 100755 index 0000000..0319287 --- /dev/null +++ b/backup/nifti_img_view.lfm.bak @@ -0,0 +1,1609 @@ +object ImgForm: TImgForm + Left = 250 + Height = 469 + Top = 173 + Width = 1025 + ActiveControl = ControlPanel + AllowDropFiles = True + Caption = 'MRIcroN' + ClientHeight = 469 + ClientWidth = 1025 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnDestroy = FormDestroy + OnDropFiles = FormDropFiles + OnKeyDown = FormKeyDown + OnKeyPress = FormKeyPress + OnResize = FormResize + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object ControlPanel: TPanel + Left = 0 + Height = 40 + Top = 0 + Width = 1025 + Align = alTop + BevelOuter = bvNone + ClientHeight = 40 + ClientWidth = 1025 + ParentColor = False + ParentShowHint = False + ShowHint = True + TabOrder = 0 + OnDblClick = ControlPanelDblClick + object LabelX: TLabel + Left = 6 + Height = 16 + Top = 12 + Width = 8 + Caption = 'X' + ParentColor = False + end + object LabelY: TLabel + Left = 81 + Height = 16 + Top = 12 + Width = 8 + Caption = 'Y' + ParentColor = False + end + object LabelZ: TLabel + Left = 153 + Height = 16 + Top = 12 + Width = 8 + Caption = 'Z' + ParentColor = False + end + object HideROIBtn: TSpeedButton + Left = 808 + Height = 30 + Hint = 'Briefly hide VOIs and Overlays' + Top = 4 + Width = 30 + Glyph.Data = { + 36060000424D3606000000000000360000002800000010000000180000000100 + 2000000000000006000064000000640000000000000000000000FFFFFF00FFFF + FF00FFFFFF00C61C1D25C000007F8C4545BCB70B0BCBBF0101E8C00000F6C000 + 00DBC00000BDC00000A0C0000082C0000063C0000024FFFFFF00FFFFFF00D65D + 5F3CCF4142C4C82525FF8D4C4CFF47A0A0FF42A8A8FF983535FFC00000FFC000 + 00FFC00000FFC00000FF9A3333FFC00000FFC00000FFC00000C5DE828486D866 + 67FDD14A4BFFCA2D2EFFAB3030FF30BFBFFF30BFBFFF854F4FFFC00000FFC000 + 00FFBF0101FF7E5858FF3EADADFF519494FFAF1616FFC0000095E08A8DBBDA6E + 70FFD35253FFCC3536FFAB393AFF8C4646FF7A5E5EFFBF0101FFC00000FFC000 + 00FFC00000FF854F4FFF30BFBFFF37B6B6FFA62222FFC000003EE2939557DB77 + 78FFD55A5CFFCE3E3FFFB63636FFC10505FFBB0707FFC00000FFC00000FFC000 + 00FFB21212FF973737FF6F6C6CFF933C3CFFBA0808E5C0000001E49B9E07DD7F + 81ECD26768FFA26F70FF4BB0B0FF746F6FFFB80A0AFFC00000FFBB0606FFA327 + 27FF4E9797FF7E5757FFB80B0BFFBD0404FFC000008FFFFFFF00FFFFFF00DF87 + 8990D96B6CFF729FA0FF33CCCCFF49A9A9FFBD0404FFC00000FFC00000FF5F81 + 81FF30BFBFFF4C9A9AFFBF0101FFC00000FFC0000038FFFFFF00FFFFFF00E190 + 922CDB7375FF889394FF54AFAFFF85696AFFAF1818FFC00000FFC00000FF7268 + 68FF45A3A3FF776161FFAF1616FFC00000E0FFFFFF00FFFFFF00FFFFFF00FFFF + FF00DD7B7DC9D65F61FFB95758FFC82828FFC20A0AFFC00000FFC00000FFC000 + 00FFA62222FFBF0101FFC00000FFC0000089FFFFFF00FFFFFF00FFFFFF00FFFF + FF00DF848665AC8788FFD14B4DFFCB2F30FFC41313FFC00000FFC00000FFA820 + 20FFC00000FFC00000FFC00000FFC0000032FFFFFF00FFFFFF00FFFFFF00FFFF + FF00E18C8E0D4CCDCEFB62AFB0FFC73C3DFFC61B1BFFC00000FF943A3AFF4E97 + 97FF637C7CFFA62222FFC00000DAFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF005AC8C8CC4DC4C5FFC44A4BFFC82324FFC10707FF8E4343FF30BF + BFFF33BBBBFFAC1A1AFFC0000083FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF005ACCCD6BBB787AFFCB4D4EFFCA2C2CFFC30F0FFF904040FF637B + 7BFF726767FFA91E1EFFC000002CFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF0000FFFF03D96C6ED6D25052FFC93738FFC51818FFC00000FFBD04 + 04FFB41010FFC00000D4FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00DB757772D4595AFF957273FF945959FFA62525FFC000 + 00FFC00000FFC000007DFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00DD7D7F159F898AFB37CDCEFF32C9C9FF9A3E3EFFC000 + 00FFC00000FFC0000026FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00B08587B642C7C7FF42BCBCFF836263FFC000 + 00FFC00000CEFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00CE7A7B4AD1585AFF9A6B6BFFC61D1DFFC000 + 00FFC0000077FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00DC7A7C02D65D5FE1CF4142FFB6393AFFC209 + 09FFC0000021FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00D8666780AA6B6CFF5AA1A2FF845E + 5ED7FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00DA6E701F9F7C7DFD33CDCDFF6886 + 879AFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00948D8ECA689E9EFE8A67 + 6727FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00D7636455D04648C2FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00D96B6D06D24F5057FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 + } + OnMouseDown = HideROIBtnMouseDown + OnMouseUp = HideROIBtnMouseUp + end + object XBarBtn: TSpeedButton + Left = 838 + Height = 30 + Hint = 'Toggle Crosshairs'#13#10'right-click to change gap size'#13#10'right+ctrl click to change color'#13#10'right+alt click to change thickness'#13#10'right+shift to reposition origin'#13#10'right+ctrl+alt to adjust font size' + Top = 4 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C00000FF0000FF0000FFC0C0C0 + C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 + C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C00000FF00 + 00FF0000FFC0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 + C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 + C0C0C0C00000FF0000FF0000FFC0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 + C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 321 + OnClick = XBarBtnClick + OnMouseDown = XBarBtnMouseDown + ShowHint = True + ParentShowHint = False + end + object LayerPanel: TPanel + Left = 304 + Height = 36 + Top = 2 + Width = 500 + ClientHeight = 36 + ClientWidth = 500 + ParentColor = False + TabOrder = 5 + object AutoContrastBtn: TSpeedButton + Left = 121 + Height = 28 + Hint = 'Autocontrast' + Top = 3 + Width = 28 + Glyph.Data = { + D6080000424DD608000000000000360000002800000018000000170000000100 + 200000000000A008000064000000640000000000000000000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0000000022191919632E2E + 2EA53F3F3FC2525252D74F4F4FD53C3C3CC02D2D2D9F1111115F0000001AFFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000000C2E2E2EA8777777E8C6C6C6FEF4F4 + F4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0F0F0FF181818FF313030F22A28 + 289D00000005FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF0023232353454545DADCDCDCFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF1B1616FF1A1010FF271A + 1AFF322828EA231E1E3BFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF003030309E969696F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFAFAFF2C2020FF2F1C1CFF3A23 + 23FF3E2525FF5A4545F840363685FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF0024242459909090F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFFFFF5F5FF3A2828FF422828FF5131 + 31FF573434FF4F2F2FFF594040F82B1F1F3DFFFFFF00FFFFFF00FFFFFF000000 + 00164A4A4ADFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFCFFFFF3F3FF422D2DFF4E2F2FFF643C + 3CFF704343FF613A3AFF4B2D2DFF483636E8110A0A0AFFFFFF00FFFFFF003030 + 30C2E8E8E8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFBFAFAFFFDFD + FDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFCFFFFF2F2FF432D2DFF4F2F2FFF663D + 3DFF754646FF633B3BFF4C2E2EFF422E2EFF3A3131AEFFFFFF000000002D8B8B + 8BEEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF3F0EFFF826868FFF4F2 + F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFFFFF5F5FF3C2929FF452929FF5533 + 33FF5C3737FF533232FF422828FF2D1B1BFF3C3333F20000000921212172CFCF + CFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE8DFDFFF835E5DFF633E3EFFF4F2 + F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9F9FF2F2121FF331F1FFF3F26 + 26FF432828FF3D2525FF301D1DFF1F1313FF201C1CFE0303033C313131B1FBFB + FBFFFFFFFFFFFFFFFFFFFFFFFFFFDECCCBFF8D5D5CFF7A4D4CFF6B4342FF7457 + 56FF685150FF5C4848FF4F4040FF433838FF363030FF150D0DFF1E1212FF2717 + 17FF291919FF261717FF1C1111FF0E0808FF020202FF2525258A454545CAFFFF + FFFFFFFFFFFFFFFEFEFFD7B7B6FF9F6564FF905B5AFF815250FF734847FF643F + 3EFF553535FF462C2BFF372322FF281919FF1A1010FF0B0707FF070404FF0E08 + 08FF100A0AFF0D0808FF050303FF000000FF000000FF272727C7545454DBFFFF + FFFFFFFFFFFFE3C0BFFFB67371FFA76968FF98605EFF895655FF7A4D4CFF6B44 + 43FF5D3A39FF4E3130FF3F2827FF301E1EFF211515FF130C0BFF040202FF0000 + 00FF000000FF000000FF000000FF000000FF000000FF2B2B2BDB454545CAFFFF + FFFFFFFFFFFFFEFCFBFFD4A6A6FFAF6E6DFFA06563FF915B5AFF825251FF7349 + 48FF643F3EFF563635FF472D2CFF382323FF291A19FF1A1010FF0C0707FF0000 + 00FF000000FF000000FF000000FF000000FF000000FF272727C7313131B1FBFB + FBFFFFFFFFFFFFFFFFFFFFFEFEFFDAB8B7FFA76A68FF99605FFF8A5756FF7B4D + 4CFF6C4443FF5D3B3AFF4F3231FF402828FF311F1EFF221515FF130C0CFF0403 + 03FF000000FF000000FF000000FF000000FF020202FF2525258921212172CFCF + CFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE2CACAFFA26968FF925C5AFFE1D6 + D5FFF6F4F4FFF5F3F3FFF4F2F2FFF4F2F2FFF3F1F1FF362727FF1B1111FF0C08 + 07FF000000FF000000FF000000FF000000FF161616FE0303033C0000002D8B8B + 8BEEFFFFFFFFFFFEFEFFFFFEFEFFFFFEFEFFFFFFFFFFEADBDBFFA16D6BFFE9DF + DFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF3E2C2CFF231615FF140C + 0CFF050303FF000000FF000000FF000000FF2A2A2AF100000009FFFFFF003A35 + 35C4EAE2E2FFFFF7F7FFFFF7F7FFFFF8F8FFFFF8F8FFFFF8F8FFF3E5E5FFF3ED + EDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF453131FF2B1B1AFF1C11 + 11FF0D0808FF000000FF000000FF131313FF272727A9FFFFFF00FFFFFF002818 + 181A645656E3FFF1F1FFFFF1F1FFFFF1F1FFFFF2F2FFFFF2F2FFFFF2F2FFFFF3 + F3FFFFF8F8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF4C3635FF32201FFF2516 + 16FF1C1111FF130C0CFF110A0AFF2B2626E500000009FFFFFF00FFFFFF00FFFF + FF004F3B3B66A69292F3FFEBEBFFFFEBEBFFFFECECFFFFECECFFFFECECFFFFED + EDFFFFEDEDFFFFF0F0FFFFFBFBFFFFFCFCFFFFFBFBFF604140FF503231FF4C2F + 2FFF412828FF331F1FFF423434F718141439FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00594545ABB19797F4FFE5E5FFFFE6E6FFFFE6E6FFFFE6E6FFFFE7 + E7FFFFE7E7FFFFE7E7FFFFE7E7FFFFE7E7FFFFE7E7FF805353FF6C4242FF603B + 3BFF543433FF654D4DF83A323283FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF0063464668846161E5E6C8C8FFFFE0E0FFFFE0E0FFFFE0 + E0FFFFE1E1FFFFE1E1FFFFE1E1FFFFE1E1FFFFE1E1FF8F5C5CFF7E4D4DFF764B + 4AFF634545EC3328283FFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF009A5D5D1D715050BDAA8484F0DAB6B6FEF8D3 + D3FFFFDBDBFFFFDBDBFFFFDBDBFFFFDBDBFFF5D2D2FFA06969FF906565F56146 + 46AA40272707FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF004429292C754D4D837C56 + 56BE8C6363D79D7171E7986E6EE5865F5FD4775353B75B3C3C720B07071BFFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 + } + OnClick = AutoContrastBtnClick + end + object LutFromZeroBtn: TSpeedButton + Left = 439 + Height = 28 + Hint = 'Color range from zero' + Top = 4 + Width = 28 + AllowAllUp = True + Glyph.Data = { + AE060000424DAE06000000000000360000002800000018000000170000000100 + 180000000000780600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000000000000000000000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000000000000000000000000000000000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000000000000000FF000000000000 + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00000000000000 + 00FF0000000000000000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000000000000000FF0000000000000000FF0000FF00000000000000000000 + 00000000000000FF0000FF0000FF0000FF0000FF0000FF0000FF000000000000 + 0000000000000000000000000000000000FF0000000000000000FF0000FF0000 + 000000000000000000000000000000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF000000000000000000000000000000000000000000000000000000000000 + 0000FF0000FF0000000000000000000000000000000000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000000000000000000000000000000000FF00000000 + 00000000000000FF0000FF0000FF0000FF0000000000000000000000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000000000000000000000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00000000000000 + 00000000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000 + 0000000000000000FF0000FF0000FF000000FF00FF0000FF0000FF0000FF0000 + FF0000FF0000000000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000000000FF0000FF0000FF0000FF000000FF00FF0000FF + 0000FF0000FF0000FF0000FF0000000000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000000000FF0000FF00808080808080 + 0000FF8080808080808080808080808080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080808080808080 + 80808080800000000000000A08080E0808140C0C190F0F1E1212231414281717 + 2C1A1A311D1D3620203923233A25253A27273A29293A2B2B3A2D2D3A30300000 + 000000000000008080808080800000000000002C1A1A4428285935356F424284 + 4F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBE + FFC6C6FFD7D7FFE0E0FFFFFF0000008080808080800000000000002E1B1B4428 + 285935356F4242844F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FF + ACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF000000808080808080000000 + 0000002E1B1B4428285935356F4242844F4F9A5C5CB06969C57676DA8383F190 + 90FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF00000080 + 80808080800000000000002E1B1B4428285935356F4242844F4F9A5C5CB06969 + C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0 + E0FFFFFF0000008080808080800000000000002E1B1B4428285935356F424284 + 4F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBE + FFC6C6FFD7D7FFE0E0FFFFFF0000008080808080800000000000002E1B1B4428 + 285935356F4242844F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FF + ACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF000000808080808080000000 + 0000002E1B1B4428285935356F4242844F4F9A5C5CB06969C57676DA8383F190 + 90FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF00000080 + 8080808080000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000080808080808080808080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080808080808080 + 808080808080808080808080808080808080 + } + GroupIndex = 194 + OnClick = LutFromZeroBtnClick + end + object ColorBarBtn: TSpeedButton + Left = 467 + Height = 28 + Hint = 'Draw color range ' + Top = 4 + Width = 28 + Glyph.Data = { + 96030000424D96030000000000003600000028000000180000000C0000000100 + 180000000000600300006400000064000000000000000000000000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF00808080808080808080808080808080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080808080808080 + 808080808080808080808080800000000000000A08080E0808140C0C190F0F1E + 12122314142817172C1A1A311D1D3620203923233A25253A27273A29293A2B2B + 3A2D2D3A30300000000000000000008080808080800000000000002C1A1A4428 + 285935356F4242844F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FF + ACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF000000808080808080000000 + 0000002E1B1B4428285935356F4242844F4F9A5C5CB06969C57676DA8383F190 + 90FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF00000080 + 80808080800000000000002E1B1B4428285935356F4242844F4F9A5C5CB06969 + C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0 + E0FFFFFF0000008080808080800000000000002E1B1B4428285935356F424284 + 4F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBE + FFC6C6FFD7D7FFE0E0FFFFFF0000008080808080800000000000002E1B1B4428 + 285935356F4242844F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FF + ACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF000000808080808080000000 + 0000002E1B1B4428285935356F4242844F4F9A5C5CB06969C57676DA8383F190 + 90FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF00000080 + 80808080800000000000002E1B1B4428285935356F4242844F4F9A5C5CB06969 + C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0 + E0FFFFFF00000080808080808000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000008080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080 + } + OnMouseDown = ColorBarBtnMouseDown + end + object LayerDrop: TComboBox + Left = 4 + Height = 20 + Top = 4 + Width = 116 + ItemHeight = 0 + ItemIndex = 0 + Items.Strings = ( + 'Background Layer' + ) + OnChange = LayerDropChange + OnSelect = LayerDropSelect + ParentShowHint = False + ShowHint = True + Style = csDropDownList + TabOrder = 0 + Text = 'Background Layer' + end + object MinWindowEdit: TFloatSpinEdit + Left = 153 + Height = 16 + Top = 4 + Width = 88 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 9999999 + MinValue = -9999999 + OnChange = MinContrastWindowEditChange + TabOrder = 1 + Value = 1 + end + object MaxWindowEdit: TFloatSpinEdit + Left = 245 + Height = 16 + Top = 4 + Width = 88 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 9999999 + MinValue = -9999999 + OnChange = MaxContrastWindowEditChange + TabOrder = 2 + Value = 1 + end + object LUTdrop: TComboBox + Left = 340 + Height = 20 + Top = 5 + Width = 100 + DropDownCount = 66 + ItemHeight = 0 + OnChange = LUTdropChange + OnSelect = LUTdropSelect + ParentShowHint = False + ShowHint = True + Style = csDropDownList + TabOrder = 3 + end + end + object ZoomDrop: TComboBox + Left = 225 + Height = 20 + Top = 8 + Width = 79 + DropDownCount = 12 + ItemHeight = 0 + Items.Strings = ( + 'To Fit' + 'To Int' + 'x1' + 'x2' + 'x3' + 'x4' + 'x5' + 'x6' + 'x7' + 'x8' + 'x9' + ) + OnChange = ZoomDropChange + OnSelect = ZoomDropSelect + ParentShowHint = False + ShowHint = True + Style = csDropDownList + TabOrder = 4 + end + object XViewEdit: TSpinEdit + Left = 24 + Height = 16 + Top = 12 + Width = 52 + MinValue = 1 + OnChange = XViewEditChange + TabOrder = 0 + Value = 100 + end + object YViewEdit: TSpinEdit + Left = 97 + Height = 16 + Top = 12 + Width = 52 + MinValue = 1 + OnChange = XViewEditChange + TabOrder = 1 + Value = 32 + end + object ZViewEdit: TSpinEdit + Left = 169 + Height = 16 + Top = 12 + Width = 52 + MinValue = 1 + OnChange = XViewEditChange + TabOrder = 2 + Value = 14 + end + object ToolPanel: TPanel + Left = 872 + Height = 32 + Top = 4 + Width = 165 + BevelOuter = bvNone + ClientHeight = 32 + ClientWidth = 165 + TabOrder = 3 + Visible = False + object PenBtn: TSpeedButton + Left = 0 + Height = 30 + Hint = 'Pen Tool' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF00C9C9CCBABAD0B1B1D2B0B0D2B4B4D1BCBCCFC6C6CD00FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF00CACACCA4A4D57B7BDF3434F13333F23333F23333F13535F1 + 3737F04343ED5656E96F6FE28B8BDBADADD3C8C8CC00FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF00A0A0D62F2FF31717F89797D83A3AF03333F233 + 33F23333F23333F23333F23333F23333F23333F23333F23333F14141EE7575E0 + B8B8D000FF0000FF0000FF0000FF0000FF00ABABD36262FB4C4CFF1414F9C7C7 + CCC2C2CEAFAFD3A1A1D69A9AD89494D98C8CDB8282DE7878E06D6DE35C5CE742 + 42EE3333F13333F23D3DEEBABACF00FF0000FF0000FF0000FF007F7FE3B3B3FF + 3C3CFF0000FE9494D900FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF00C9C9CC8E8EDA3333F23333F2A5A5D500FF0000FF0000FF0000 + FF009F9FDB9898FF3535FF0000FF3F3FEE00FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF00CBCBCC6060E53333F25353E9C9C9CC00FF + 0000FF0000FF0000FF00CACACC7676E41A1AFB2E2EF2A8A8D400FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF009A9AD73333F13C3CEF + B5B5D100FF0000FF0000FF0000FF0000FF00CCCCCCA9A9A93B3B435B5B5DB9B9 + B900FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00CACACC4D + 4DEA3434F19999D800FF0000FF0000FF0000FF0000FF0000FF00CCCCCC404040 + 0E0E0E0000001C1C1CB4B4B400FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF00B8B8D03434F15C5CE7CBCBCC00FF0000FF0000FF0000FF0000FF0000 + FF00CBCBCB44444450505000000000000062626200FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF00C5C5CD4747EC4A4AEBBCBCCF00FF0000FF0000FF + 0000FF0000FF0000FF00CBCBCB4646465F5F5F0000000000003F3F3F00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00B1B1D24949EB4141ED + 9797D8CBCBCC00FF0000FF0000FF0000FF0000FF004949496565650000000000 + 0030303000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C4C4CD7A7ADF3737F05D5DE7B5B5D100FF0000FF0000FF0000FF00505050 + 69696900000000000024242400FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF00CBCBCCB2B2D25B5BE73A3AEF8B8BDBCACACC00 + FF0000FF006969695B5B5B0000000000001D1D1D00FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00CACACC9797 + D83E3EEE7B7BDFCBCBCC00FF009191915050500101010000001B1B1B00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF00CBCBCC7B7BDF3B3BEFC2C2CD00FF00BBBBBB3A3A3A0A0A0A0000 + 0018181800FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF00CBCBCCB6B6D16C6CE35353E9A9A9D400FF0000FF00CACACA + 323232171717000000101010CBCBCB00FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF00CBCBCCAEAED36969E46262E59F9FD6CACACC00FF0000 + FF0000FF0000FF004B4B4B1515150000000B0B0BC6C6C600FF0000FF0000FF00 + 00FF0000FF0000FF0000FF00CACACCA0A0D66E6EE27A7ADFB5B5D1CBCBCC00FF + 0000FF0000FF0000FF0000FF0000FF00858585020202000000050505BBBBBB00 + FF0000FF0000FF0000FF0000FF0000FF00C4C4CD9595D8A5A5D5C8C8CC00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00BFBFBF0808080000 + 00000000A3A3A300FF0000FF0000FF0000FF0000FF0000FF00CBCBCC00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF004A4A4A00000000000084848400FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF00A6A6A603030300000065656500FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0041414100000046464600 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00AAAA + AA05050525252500FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 44 + OnClick = PenBtnClick + end + object ClosedPenBtn: TSpeedButton + Left = 30 + Height = 30 + Hint = 'Autoclose Pen' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF00C9C9CCBABAD0B1B1D2B0B0D2B4B4D1BCBCCFC6C6CD00FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF00CACACCA4A4D57B7BDF3434F13333F23333F23333F13535F1 + 3737F04343ED5656E96F6FE28B8BDBADADD3C8C8CC00FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF00A0A0D62F2FF31717F89797D83A3AF03333F233 + 33F23333F23333F23333F23333F23333F23333F23333F23333F14141EE7575E0 + B8B8D000FF0000FF0000FF0000FF0000FF00ABABD36262FB4C4CFF1414F9C7C7 + CCC2C2CEAFAFD3A1A1D69A9AD89494D98C8CDB8282DE7878E06D6DE35C5CE742 + 42EE3333F13333F23D3DEEBABACF00FF0000FF0000FF0000FF007F7FE3B3B3FF + 3C3CFF0000FE9494D900FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF00C9C9CC8E8EDA3333F23333F2A5A5D500FF0000FF0000FF0000 + FF009F9FDB9898FF3535FF0000FF3F3FEE00FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF00CBCBCC6060E53333F25353E9C9C9CC00FF + 0000FF0000FF0000FF00CACACC7676E41A1AFB2E2EF2A8A8D400FF0000FF00FF + 0000FF000000FF0000FF0000FF0000FF0000FF0000FF009A9AD73333F13C3CEF + B5B5D100FF0000FF0000FF0000FF0000FF00CCCCCCA9A9A93B3B435B5B5DB9B9 + B900FF00FF0000FF0000FF0000FF000000FF0000FF0000FF0000FF00CACACC4D + 4DEA3434F19999D800FF0000FF0000FF0000FF0000FF0000FF00CCCCCC404040 + 0E0E0E0000001C1C1CB4B4B4FF0000FF0000FF0000FF000000FF0000FF0000FF + 0000FF00B8B8D03434F15C5CE7CBCBCC00FF0000FF0000FF0000FF0000FF0000 + FF00CBCBCB44444450505000000000000062626200FF00FF0000FF000000FF00 + 00FF0000FF0000FF0000FF00C5C5CD4747EC4A4AEBBCBCCF00FF0000FF0000FF + 0000FF0000FF0000FF00CBCBCB4646465F5F5F0000000000003F3F3F00FF0000 + FF0000FF0000FF00FF0000FF000000FF0000FF0000FF00B1B1D24949EB4141ED + 9797D8CBCBCC00FF0000FF0000FF0000FF0000FF004949496565650000000000 + 0030303000FF0000FF0000FF00FF0000FF0000FF0000FF000000FF0000FF0000 + FF00C4C4CD7A7ADF3737F05D5DE7B5B5D100FF0000FF0000FF0000FF00505050 + 69696900000000000024242400FF0000FF0000FF00FF0000FF0000FF0000FF00 + 0000FF0000FF0000FF0000FF00CBCBCCB2B2D25B5BE73A3AEF8B8BDBCACACC00 + FF0000FF006969695B5B5B0000000000001D1D1D00FF0000FF0000FF0000FF00 + FF0000FF000000FF0000FF0000FF0000FF0000FF0000FF0000FF00CACACC9797 + D83E3EEE7B7BDFCBCBCC00FF009191915050500101010000001B1B1B00FF0000 + FF0000FF0000FF0000FF0000FF0000FF00FF0000FF000000FF0000FF0000FF00 + 00FF0000FF00CBCBCC7B7BDF3B3BEFC2C2CD00FF00BBBBBB3A3A3A0A0A0A0000 + 0018181800FF0000FF0000FF0000FF0000FF0000FF00FF0000FF0000FF0000FF + 000000FF0000FF00CBCBCCB6B6D16C6CE35353E9A9A9D400FF0000FF00CACACA + 323232171717000000101010CBCBCB00FF0000FF0000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000CBCBCCAEAED36969E46262E59F9FD6CACACC00FF0000 + FF0000FF0000FF004B4B4B1515150000000B0B0BC6C6C600FF0000FF0000FF00 + 00FF0000FF0000FF00FF0000FF0000A0A0D66E6EE27A7ADFB5B5D1CBCBCC00FF + 0000FF0000FF0000FF0000FF0000FF00858585020202000000050505BBBBBB00 + FF0000FF0000FF0000FF0000FF0000FF00C4C4CD9595D8A5A5D5C8C8CC00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00BFBFBF0808080000 + 00000000A3A3A300FF0000FF0000FF0000FF0000FF0000FF00CBCBCC00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF004A4A4A00000000000084848400FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF00A6A6A603030300000065656500FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0041414100000046464600 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00AAAA + AA05050525252500FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 44 + OnClick = PenBtnClick + end + object FillBtn: TSpeedButton + Left = 60 + Height = 30 + Hint = 'Fill tool' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF00CBCBCCC5C5CDB2B2D29B9BD89090DA8585DD7C7CDF8181DE8989 + DC9292DAA7A7D5C1C1CECBCBCC00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00CACACCADADD37979E04646ED1F1FF70808FC0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0606FD2D2DF37777E0C6C6CD00FF0000FF + 0000FF0000FF0000FF002E2EF20101FE0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 4242EDCBCBCC00FF0000FF0000FF0000FF001919F80000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FE19 + 19F85050EAA2A2D6CBCBCC00FF0000FF0000FF0000FF0000FF00C1C1CE5D5DE6 + 0303FE0000FF0707FD1717F92727F43636F14343ED5151EA5F5FE76C6CE38181 + DE9C9CD7B7B7D0A8A8AB5F5F5F959595CACACA00FF0000FF0000FF0000FF0000 + FF0000FF00C9C9CC2D2DF2A0A0D6C4C4CDCACACCCBCBCC00FF0000FF0000FF00 + 00FF0000FF0000FF00C7C7C7696969463536B78A8B755B5C393737A8A8A800FF + 0000FF0000FF0000FF0000FF009191D93939F000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF00CBCBCBA1A1A1353030956D6EFABABCFDC1C3FCC7C9 + DCB3B54138398A8A8ACBCBCB00FF0000FF00CBCBCC3535F06060E600FF0000FF + 0000FF0000FF0000FF0000FF0000FF00C3C3C35D5D5D503939E0A1A2FDBABBFD + C0C1FCC5C7FCCBCDFCD0D2F2CED04F46468F8F8F00FF0000FF00ABABD30101FE + 7676E000FF0000FF0000FF0000FF0000FF00CBCBCB969696352D2DA67273FCB2 + B3FDB8B9FDBEBFFDC3C5FCC9CBFCCED0FCD4D6FCD9DCEED3D63A3637B4B4B400 + FF007272E10000FF7D7DDF00FF0000FF0000FF0000FF00BCBCBC515151604040 + E99D9EFDB1B2FDB6B8FDBCBDFDC1C3FCC7C9FCCCCEFCD2D4FCD7DAFBDDDFFBE2 + E5C5B6B8484848CBCBCB4949EB0000FF7070E200FF0000FF00CACACA89898938 + 2B2BB67676FDA9A9FDAEAFFDB4B5FDBABBFDBFC1FCC5C7FCCACCFCD0D2FCD5D8 + FCDBDDFBE0E3FBE6E9FBEBEF595556A8A8A84E4EEA0000FF4A4AEB00FF00B5B5 + B5474545704646EF9999FEA7A8FDADAEFDB2B3FDB8B9FDBEBFFDC3C5FCC9CBFC + CED0FCD4D6FCD9DCFBDFE1FBE4E7FBE9EDFBEFF3B2AEB06363639696D80202FE + 0B0BFB68688A0F0F16694040F29999FEA5A6FEABACFDB0B1FDB6B7FDBCBDFDC1 + C3FCC7C8FCCCCEFCD2D4FCD7DAFCDDDFFBE2E5FBE7EBFBEDF1F7EFF34F4E4F97 + 9797CBCBCC8F8FDA3131F00202E50303EC0A0A98241939A46D6EFCADAEFDB4B5 + FDB9BBFDBFC1FCC5C6FCCACCFCD0D2FCD5D8FCDBDDFBE0E3FBE6E9FBEBEEFAF1 + F4787577727272CBCBCB00FF0000FF00C7C7C837363CCEC8F10202FE0303F60D + 0D7B5E4346F2B0B1FDBDBEFDC3C4FCC8CAFCCED0FCD3D6FCD9DBFBDEE1FBE4E7 + FBE9EDFBEFF2A6A2A44E4E4ECACACA00FF0000FF0000FF0000FF006A6A6A9F9C + 995250FB0000FF0000FE0706B8362937E0ABACFCC6C8FCCCCEFCD1D4FCD7D9FC + DCDFFBE2E5FBE7EBFBEDF0CDC6C9383738C3C3C300FF0000FF0000FF0000FF00 + 00FF00C3C3C3373636C4BFDC1312FD0000FF0000FF0807D8272039E0B4B6FCD0 + D2FCD5D7FCDADDFBE0E3FBE5E9FBEBEEE7DEE1373636B3B3B300FF0000FF0000 + FF0000FF0000FF0000FF0000FF00A2A2A2454443A7A4EE0504FE0000FF0000FF + 0505DA2A233AE2BEC0FCD9DBFBDEE1FBE3E6FBE9ECF5E9ED4B494A99999900FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0088888852504F95 + 92F00303FE0000FF0000FF0707D33B333EF3D5D7FBE2E4FBE7EAFAECF0736F70 + 76767600FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF008383835452519591EF0808FE0000FF0000FF0B0BAA736769FBE5E8FB + EBEEA1999C525252CACACA00FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF00868686444241A4A1DB1D1CFD0000FF0000 + FE100F58CFC1C4C8BEC13A3A3AC4C4C400FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00A4A4A4363535 + A7A3AF7673F91817FE2F2ECB545051373536B5B5B500FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF00BDBDBD545454555352BBB7BADAD5D70D0C0C9C9C9C00FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF00CBCBCBAAAAAA5E5E5E4545458B8B8B00 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 44 + OnClick = PenBtnClick + end + object EllipseBtn: TSpeedButton + Left = 90 + Height = 30 + Hint = 'Ellipse Tool' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF0000FF0000FF00C9C9CCA7A7D48E8EDB9595D9B8B8D000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF00CACACC8181DE1C1CF70505FD1313F90D0DFB + 0505FD3D3DEFABABD300FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF00CACACC5151E90D0DFB7171E2B9 + B9D0A0A0D6C8C8CCA5A5D54545ED0C0CFB9696D800FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF006D6DE31313 + F9AAAAD3B3B3D14343F31A1AF7CBCBCC00FF00CBCBCC6D6DE20E0EFAB2B2D100 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + B9B9D00B0BFB8F8FDACBCBCC6D6DF07474FF0C0CFBC4C4CD00FF0000FF00CACA + CC3F3FEE4B4BEB00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF007A7AE02525F4CACACCCACACC9696F76161FF0000FF7A7ADF + 00FF0000FF0000FF009F9FD60707FCC4C4CD00FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF004F4FEA5959E800FF0000FF009898DE33 + 33FD0B0BFB9090DA00FF0000FF0000FF0000FF000000FF4343ED00FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF004343ED6767E400FF + 0000FF00C9C9C9575778636377C4C4C400FF000000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF00FF0000FF0000FF0000FF00 + 5454E95252E900FF0000FF00969696141414000000323232C7C7C70000FF00FF + 00C4C4CD0707FCA6A6D400FF0000FF0000FF0000FF0000FF000000FF00FF0000 + FF0000FF0000FF008282DE1D1DF6C9C9CC00FF00808080636363000000000000 + 9999990000FF00FF009090DA0E0EFAC8C8CC00FF0000FF0000FF0000FF0000FF + 000000FF00FF0000FF0000FF0000FF00BFBFCE1010FA8181DE00FF0086868669 + 69690000000000007E7E7E0000FF3E3EEF2B2BF35E5EE600FF0000FF0000FF00 + 00FF0000FF0000FF000000FF00FF0000FF0000FF0000FF0000FF007E7EDE0C0C + FB9999D89898985F5F5F0202020000007272720000FF0303FD1D1DF7BEBECE00 + FF0000FF0000FF0000FF0000FF0000FF000000FF00FF0000FF0000FF0000FF00 + 00FF00CBCBCC6666E40707FC3232CA4D4D4D03030300000039396E0000FF1C1C + F7AEAED200FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00FF0000 + FF0000FF0000FF0000FF0000FF00CBCBCC9797D84343EC3F3F4C0D0D0D000000 + 0C0C720000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 000000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00CACACA4E + 4E4E2828280000002B2B2B0000FF00FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF000000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF005353532B2B2B0000002121210000FF00FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF000000FF00FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF006565653333330000001E1E1E0000FF00FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF007D7D7D363636000000 + 1C1C1C0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00A5 + A5A522222200000014141400FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF00C9C9C91818180000000E0E0EC7C7C700FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00454545000000020202BBBBBB00FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF008C8C8C000000 + 000000A1A1A100FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C8C8C81C1C1C00000083838300FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0078787800000065656500FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 44 + OnClick = PenBtnClick + end + object Fill3DBtn: TSpeedButton + Left = 120 + Height = 30 + Hint = 'Create VOI based on background intensity' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + D6080000424DD608000000000000360000002800000018000000170000000100 + 200000000000A008000064000000640000000000000000000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF1C0000FF510000 + FF830000FFB50000FFE70000FFE70000FFB50000FF830000FF510204FF1CFFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000FF0B0000FF8D0000FFFC0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0102FFFF0A11FFFF121CFFFC1725 + FF8D1A2AFF0BFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000000FF460000FFDF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0305FFFF0E17FFFF1827FFFF2134FFFF273E + FFFF2B44FFDF2B45FF46FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF000000FF870000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0D15FFFF1A29FFFF253CFFFF2F4BFFFF3757 + FFFF3B5FFFFF3C60FFFF395BFF87FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF000000FF4A0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF080CFFFF1623FFFF2439FFFF314EFFFF3D60FFFF4670 + FFFF4C79FFFF4D7AFFFF4974FFFF4167FF4AFFFFFF00FFFFFF00FFFFFF000000 + FF160000FFE90000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0D16FFFF1D2EFFFF2C46FFFF3A5DFFFF4872FFFF5485 + FFFF5C93FFFF5E95FFFF588CFFFF4D7BFFE94066FF16FFFFFF00FFFFFF000000 + FFB40000FFFF0000FFFF0000DAFF0000B9FF0000A0FF0000B8FF0000DEFF0000 + FDFF0000FFFF0102FFFF111BFDFF1927BFFF253ABFFF304CBFFF3C5FBFFF4670 + BFFF5688CCFF649FE7FF649EFEFF5689FFFF4771FFB4FFFFFF000000FF2A0000 + FFFF0000E0FF000045FF000000FF000000FF000000FF000000FF000000FF0000 + 39FF0000DEFF0203FFFF111CF5FF000000FF000000FF000000FF000000FF0000 + 00FF000000FF000000FF0E1723FF345396FF4974FFFF395AFF2A0000FF600000 + FEFF00003DFF000000FF000000FF00007BFF0000ECFF00008DFF000000FF0000 + 00FF000033FF0001FFFF0F19F5FF000000FF000000FF000000FF111C39FF1F32 + 56FF152133FF000000FF000000FF000000FF253C8AFF3656FF600000FF960000 + FFFF0000FDFF0000E7FF0000CDFF0000FAFF0000FFFF0000DEFF000000FF0000 + 00FF000001FF0000F2FF0C13F5FF000000FF000000FF000000FF2A429AFF5180 + FFFF588CFFFF253A68FF000000FF000000FF050713FF304CFF960000FFCB0000 + FFFF0000FFFF0000FFFF0000FFFF0000BBFF00006BFF000027FF000000FF0000 + 00FF00006AFF0000FFFF060AF5FF000000FF000000FF000000FF22379AFF426A + FFFF4872FFFF314EABFF000000FF000000FF000000FF2135D9D10000FFF20000 + FFFF0000FFFF0000FFFF0000FFFF0000AAFF000003FF000000FF000000FF0000 + 7EFF0000FFFF0000FFFF0000F5FF000000FF000000FF000000FF1B2A9AFF3351 + FFFF3758FFFF1F318BFF000000FF000000FF000000FF1927E2F30000FFC80000 + FFFF0000F8FF0000D9FF0000B8FF0000F6FF0000ECFF00003EFF000000FF0000 + 00FF0000AEFF0000FFFF0000F5FF000000FF000000FF000000FF121C9AFF2338 + FFFF2135D9FF080C32FF000000FF000000FF03051EFF0F19FFC80000FF920000 + FFFF000085FF000000FF000000FF00005DFF0000ADFF00002FFF000000FF0000 + 00FF0000BCFF0000FFFF0000F5FF000000FF000000FF000000FF010218FF0203 + 16FF000000FF000000FF000000FF000002FF070BB4FF0203FF920000FF5C0000 + FFFF0000FFFF00007BFF00000FFF000000FF000000FF000000FF00000FFF0000 + 7DFF0000FFFF0000FFFF0000F5FF000000FF000000FF000000FF000000FF0000 + 00FF000003FF01011FFF01024EFF0001CEFF0000FFFF0000FF5C0000FF250000 + FFFF0007FFFF000FFFFF0010FAFF000EE1FF000BD5FF0005E6FF0000FBFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000EFFF0000EFFF0000EFFF0000EFFF0000 + EFFF0000FBFF0000FFFF0000FFFF0000FFFF0000FFFF0000FF25FFFFFF00001C + FFB5001DFFFF001DFFFF001CFFFF001CFFFF001BFFFF001BFFFF0017FFFF000A + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFA4FFFFFF00FFFFFF000032 + FF170026FFE80023FFFF0023FFFF0022FFFF0021FFFF0020FFFF0020FFFF001F + FFFF0017FFFF0004FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0001 + FFFF0007FFFF000EFFFF0012FFFF0014FFE60021FF16FFFFFF00FFFFFF00FFFF + FF000034FF55002BFFFD002AFFFF0029FFFF0028FFFF0027FFFF0026FFFF0025 + FFFF0025FFFF0023FFFF0010FFFF0008FFFF000BFFFF000EFFFF0016FFFF001E + FFFF001FFFFF001EFFFF001EFFFD0020FF4FFFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00002CFF880031FFFD0030FFFF002FFFFF002EFFFF002EFFFF002C + FFFF002CFFFF002BFFFF002AFFFF002AFFFF0028FFFF0028FFFF0027FFFF0026 + FFFF0025FFFF0025FFFD0022FF87FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000041FF4A003DFFDE0037FFFF0036FFFF0035FFFF0035 + FFFF0033FFFF0032FFFF0032FFFF0031FFFF0030FFFF002FFFFF002EFFFF002E + FFFF0030FFDD0031FF47FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000093FF110042FF93003EFFF9003DFFFF003C + FFFF003BFFFF003BFFFF003AFFFF0038FFFF0038FFFF0037FFFF0035FFF9003A + FF92007BFF0EFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000055FF12005BFF5B004F + FF8E004AFFB90046FFDF0046FFDF0048FFBA004CFF8E0051FF590045FF10FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 + } + GroupIndex = 44 + OnClick = Fill3DBtnClick + end + end + end + object MagPanel: TPanel + Left = 0 + Height = 18 + Top = 451 + Width = 1025 + Align = alBottom + BevelOuter = bvNone + ClientHeight = 18 + ClientWidth = 1025 + TabOrder = 1 + object StatusLabel: TLabel + Left = 2 + Height = 16 + Top = 2 + Width = 133 + Caption = ' No Images Loaded ' + ParentColor = False + end + object ProgressBar1: TProgressBar + Left = 875 + Height = 18 + Top = 0 + Width = 150 + Align = alRight + Anchors = [akRight, akBottom] + BorderWidth = 1 + TabOrder = 0 + end + end + object Panel1: TPanel + Left = 0 + Height = 411 + Top = 40 + Width = 1025 + Align = alClient + BevelOuter = bvNone + ClientHeight = 411 + ClientWidth = 1025 + TabOrder = 2 + object TriplePanel: TScrollBox + Tag = 666 + Left = 0 + Height = 411 + Top = 0 + Width = 1025 + HorzScrollBar.Page = 775 + VertScrollBar.Page = 250 + Align = alClient + ClientHeight = 396 + ClientWidth = 1010 + Constraints.MinWidth = 5 + Color = clBlack + ParentColor = False + TabOrder = 0 + OnClick = ImgPanelClick + object PGImageCor: TImage + Tag = 2 + Cursor = crCross + Left = 1 + Height = 12 + Top = 1 + Width = 12 + AutoSize = True + OnDblClick = PGImageCorDblClick + OnMouseDown = PGImageMouseDown + OnMouseMove = PGImageMouseMove + OnMouseUp = PGImageMouseUp + Stretch = True + end + object PGImageSag: TImage + Tag = 3 + Cursor = crCross + Left = 323 + Height = 12 + Top = 110 + Width = 12 + AutoSize = True + OnDblClick = PGImageCorDblClick + OnMouseDown = PGImageMouseDown + OnMouseMove = PGImageMouseMove + OnMouseUp = PGImageMouseUp + Stretch = True + end + object PGImageAx: TImage + Tag = 1 + Cursor = crCross + Left = 763 + Height = 12 + Top = 238 + Width = 12 + AutoSize = True + OnDblClick = PGImageCorDblClick + OnMouseDown = PGImageMouseDown + OnMouseMove = PGImageMouseMove + OnMouseUp = PGImageMouseUp + Stretch = True + end + end + end + object MainMenu1: TMainMenu + left = 112 + top = 212 + object AppleMenu: TMenuItem + Caption = '' + Visible = False + object MenuItem3: TMenuItem + Caption = 'Preferences' + OnClick = Preferences1Click + end + end + object File1: TMenuItem + Caption = '&File' + object NewWindow1: TMenuItem + Caption = 'New window' + Visible = False + OnClick = NewWindow1Click + end + object Open1: TMenuItem + Caption = '&Open' + ShortCut = 16463 + OnClick = Open1Click + end + object Recent1: TMenuItem + Caption = 'Open &recent' + end + object Templates1: TMenuItem + Caption = 'Open &templates' + end + object CloseImages: TMenuItem + Caption = '&Close images' + OnClick = CloseImagesClick + end + object SaveasNIfTI1: TMenuItem + Caption = 'Save as NIfTI...' + ShortCut = 49235 + OnClick = SaveasNIfTI1Click + end + object Saveaspicture1: TMenuItem + Caption = '&Save as bitmap' + ShortCut = 16467 + OnClick = Saveaspicture1Click + end + object Exit1: TMenuItem + Caption = 'E&xit' + OnClick = Exit1Click + end + end + object Edit1: TMenuItem + Caption = '&Edit' + object Copy1: TMenuItem + Caption = 'Copy' + ShortCut = 16451 + OnClick = Copy1Click + end + object Paste1: TMenuItem + Caption = 'Paste' + ShortCut = 16470 + OnClick = Paste1Click + end + object Undo1: TMenuItem + Caption = 'Undo' + ShortCut = 16474 + OnClick = Undo1Click + end + end + object OverlayMenu: TMenuItem + Caption = '&Overlay' + object OverlayOpen: TMenuItem + Caption = 'Add' + ShortCut = 16449 + OnClick = OverlayOpenClick + end + object CloseOverlayImg: TMenuItem + Caption = 'Close overlays' + OnClick = CloseOverlayImgClick + end + object BGTransPctMenu: TMenuItem + Caption = 'Transparency on background' + object BGtrans0: TMenuItem + Caption = '0% opaque' + Checked = True + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans20: TMenuItem + Tag = 20 + Caption = '20%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans40: TMenuItem + Tag = 40 + Caption = '40%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans50: TMenuItem + Tag = 50 + Caption = '50%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans60: TMenuItem + Tag = 60 + Caption = '60%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans80: TMenuItem + Tag = 80 + Caption = '80%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans100: TMenuItem + Tag = 100 + Caption = '100% transparent' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGAdditive: TMenuItem + Tag = -1 + Caption = 'Additive' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + end + object OverlayTransPctMenu: TMenuItem + Caption = 'Transparency on other overlays' + object N0opaque1: TMenuItem + Caption = '0% opaque' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N201: TMenuItem + Tag = 20 + Caption = '20%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N401: TMenuItem + Tag = 40 + Caption = '40%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N501: TMenuItem + Tag = 50 + Caption = '50%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N601: TMenuItem + Tag = 60 + Caption = '60%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N801: TMenuItem + Tag = 80 + Caption = '80%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N100transparent1: TMenuItem + Tag = 100 + Caption = '100% transparent' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object OverlayAdditive: TMenuItem + Tag = -1 + Caption = 'Additive' + Checked = True + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + end + object LayerMenu: TMenuItem + Caption = 'Layer color' + Visible = False + object Noneopen1: TMenuItem + Caption = 'None open' + end + end + object Layerrange1: TMenuItem + Caption = 'Layer intensity' + Visible = False + object Noneopen2: TMenuItem + Caption = 'None open' + end + end + end + object DrawMenu: TMenuItem + Caption = '&Draw' + object HideDrawMenuItem: TMenuItem + Caption = 'Hide drawing tools' + OnClick = ToggleDrawMenu + end + object OpenVOI: TMenuItem + Caption = 'Open VOI...' + OnClick = OpenVOIClick + end + object SaveVOI: TMenuItem + Caption = 'Save VOI...' + OnClick = SaveVOIClick + end + object CloseVOI: TMenuItem + Caption = 'Close VOI...' + OnClick = CloseVOIClick + end + object VOIColor: TMenuItem + Caption = 'VOI color...' + OnClick = VOIColorClick + end + object Applyintensityfiltertovolume1: TMenuItem + Caption = 'Intensity filter...' + ShortCut = 16454 + OnClick = Applyintensityfiltertovolume1Click + end + object SmoothVOI1: TMenuItem + Caption = 'Smooth VOI...' + OnClick = SmoothVOI1Click + end + object MaskimagewithVOI1: TMenuItem + Caption = 'Mask image with VOI' + object VOImaskDelete: TMenuItem + Caption = 'Delete regions with VOI' + OnClick = VOImaskClick + end + object VOImaskPreserve: TMenuItem + Tag = 1 + Caption = 'Preserve regions with VOI' + OnClick = VOImaskClick + end + end + object Overlaycomparisons1: TMenuItem + Caption = 'Overlay comparisons' + object IntersectionmutualtoVOIandoverlays1: TMenuItem + Caption = 'Intersection [VOI and overlays]' + OnClick = ROIcomparisonClick + end + object UnionVOIoroverlays1: TMenuItem + Tag = 1 + Caption = 'Union [VOI or overlays]' + OnClick = ROIcomparisonClick + end + object MaskVOIbutnotoverlays1: TMenuItem + Tag = 2 + Caption = 'Mask [VOI but not overlays]' + OnClick = ROIcomparisonClick + end + end + object Statistics1: TMenuItem + Caption = 'Statistics' + object Beta1: TMenuItem + Caption = 'Create overlap images' + OnClick = CreateOverlap + end + object Chisquare1: TMenuItem + Caption = 'Subtraction Plots' + OnClick = Chisquare1Click + end + object BatchROImean1: TMenuItem + Caption = 'Batch descriptives' + OnClick = BatchROImean1Click + end + object Batchprobmaps1: TMenuItem + Caption = 'Batch prob maps' + OnClick = Batchprobmaps1Click + end + object Batchclusterprobmaps1Batchclusterprobmaps1Click: TMenuItem + Caption = 'Batch cluster prob maps' + OnClick = Batchclusterprobmaps1Batchclusterprobmaps1ClickClick + end + end + object Convert1: TMenuItem + Caption = 'Convert' + object ROIVOI1: TMenuItem + Caption = 'ROI -> VOI' + OnClick = ROIVOI1Click + end + object VOI2NII: TMenuItem + Caption = 'VOI -> NII' + OnClick = VOI2NIIClick + end + object NIIVOI: TMenuItem + Caption = 'NII -> VOI' + OnClick = NIIVOIClick + end + end + object Nudge1: TMenuItem + Caption = 'Nudge' + object Up1: TMenuItem + Caption = 'Left' + OnClick = Up1Click + end + object Left1: TMenuItem + Tag = 1 + Caption = 'Right' + OnClick = Up1Click + end + object LeftX1: TMenuItem + Tag = 2 + Caption = 'Posterior' + OnClick = Up1Click + end + object RightX1: TMenuItem + Tag = 3 + Caption = 'Anterior' + OnClick = Up1Click + end + object Posterior1: TMenuItem + Tag = 4 + Caption = 'Inferior' + OnClick = Up1Click + end + object Posterior2: TMenuItem + Tag = 5 + Caption = 'Superior' + OnClick = Up1Click + end + end + object n5: TMenuItem + Caption = 'Advanced' + object RescaleMenu: TMenuItem + Caption = 'Phase to rad/S' + OnClick = RescaleMenuClick + end + object BrainExtraction1: TMenuItem + Caption = 'Brain extraction' + OnClick = BETmenuClick + end + object CropEdges1: TMenuItem + Caption = 'Crop edges' + OnClick = CropMenuClick + end + object Brainmask1: TMenuItem + Caption = 'Brain mask ' + OnClick = BrainMask1Click + end + object GenerateSPM5maskslesions1: TMenuItem + Caption = 'Create SPM5 mask' + OnClick = GenerateSPM5maskslesions1Click + end + object LRFlip1: TMenuItem + Caption = 'LR Flip' + OnClick = MirrorNII1Click + end + object ApplyClusterThreshold1: TMenuItem + Caption = 'Apply cluster threshold' + OnClick = ApplyClusterThreshold1Click + end + object ExportasRGBAnalyzeimage1: TMenuItem + Caption = 'Export as RGB image' + OnClick = ExportasRGBAnalyzeimage1Click + end + object Resliceimage1: TMenuItem + Caption = 'Reslice images' + OnClick = Resliceimage1Click + end + object AdjustimagessoVOIintensityiszero1: TMenuItem + Caption = 'Adjust images so VOI intensity is zero' + OnClick = AdjustimagessoVOIintensityiszero1Click + end + object Extract1: TMenuItem + Caption = 'Extract objects' + OnClick = Extract1Click + end + end + object DescriptiveMenuItem: TMenuItem + Caption = 'Descriptive' + OnClick = DescriptiveMenuItemClick + end + object N1: TMenuItem + Caption = '-' + end + object Pen1: TMenuItem + Tag = 2 + Caption = 'Pen' + ShortCut = 112 + OnClick = ToolSelectClick + end + object Penautoclose1: TMenuItem + Tag = 3 + Caption = 'Autoclose pen' + ShortCut = 113 + OnClick = ToolSelectClick + end + object CircleSquare1: TMenuItem + Tag = 4 + Caption = 'Fill' + ShortCut = 114 + OnClick = ToolSelectClick + end + object Circle2: TMenuItem + Tag = 5 + Caption = 'Circle' + ShortCut = 115 + OnClick = ToolSelectClick + end + object Circle1: TMenuItem + Tag = 6 + Caption = 'Deselect tools' + ShortCut = 116 + OnClick = ToolSelectClick + end + end + object DrawHiddenMenu: TMenuItem + Caption = 'Draw' + Visible = False + object MenuItem2: TMenuItem + Caption = 'Show drawing tools' + OnClick = ToggleDrawMenu + end + end + object Controls1: TMenuItem + Caption = '&View' + object Display2: TMenuItem + Tag = 2 + Caption = 'Display' + object Axial1: TMenuItem + Tag = 1 + AutoCheck = True + Caption = 'Axial' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Coronal1: TMenuItem + Tag = 3 + AutoCheck = True + Caption = 'Coronal' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Sagittal1: TMenuItem + Tag = 2 + AutoCheck = True + Caption = 'Sagittal' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Multiple1: TMenuItem + AutoCheck = True + Caption = 'Multiple' + Checked = True + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Axial2: TMenuItem + Tag = -1 + AutoCheck = True + Caption = 'Axial only' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Coronal2: TMenuItem + Tag = -3 + AutoCheck = True + Caption = 'Coronal only' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Sagittal2: TMenuItem + Tag = -2 + AutoCheck = True + Caption = 'Sagittal only' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + end + object N3: TMenuItem + Caption = '-' + end + object Quicksmooth1: TMenuItem + Caption = '3D Smooth background' + OnClick = Quicksmooth1Click + end + object OverlaySmoothMenu: TMenuItem + Caption = '3D Smooth overlays' + OnClick = OverlaySmoothMenuClick + end + object Menu2DSmooth: TMenuItem + Caption = '2D Smooth all' + Checked = True + OnClick = Menu2DSmoothClick + end + object N4: TMenuItem + Caption = '-' + end + object FlipLRmenu: TMenuItem + Caption = 'Flip L/R' + OnClick = FlipLRmenuClick + end + object YokeMenu: TMenuItem + Caption = 'Yoke' + ShortCut = 16473 + OnClick = YokeMenuClick + end + object N2: TMenuItem + Caption = '-' + end + object MagnifyMenuItem: TMenuItem + Caption = 'Magnify' + OnClick = MagnifyMenuItemClick + end + object Crosshair1: TMenuItem + Caption = 'Crosshair' + OnClick = ToolSelectClick + end + object MenuItem1: TMenuItem + Caption = '-' + end + object MNIMenu: TMenuItem + Caption = 'MNI coordinates' + OnClick = MNIMenuClick + end + object Landmarks1: TMenuItem + Caption = 'Landmarks' + OnClick = Landmarks1Click + end + end + object Display1: TMenuItem + Caption = 'Window' + object ShowRender: TMenuItem + Caption = 'Render' + ShortCut = 16466 + OnClick = ShowRenderClick + end + object ShowMultislice: TMenuItem + Caption = 'Multislice' + ShortCut = 16461 + OnClick = ShowMultisliceClick + end + object HistoMenu: TMenuItem + Caption = 'Histogram' + ShortCut = 16456 + OnClick = HistoMenuClick + end + object N4DTraces1: TMenuItem + Caption = '4D Traces' + ShortCut = 16452 + OnClick = N4DTraces1Click + end + object Header1: TMenuItem + Caption = 'Information' + ShortCut = 16457 + OnClick = Header1Click + end + end + object Help1: TMenuItem + Caption = '&Help' + object Preferences1: TMenuItem + Caption = 'Preferences...' + OnClick = Preferences1Click + end + object About1: TMenuItem + Caption = 'About' + OnClick = About1Click + end + end + end + object SaveDialog1: TSaveDialog + OnClose = SaveDialog1Close + FilterIndex = 0 + left = 40 + top = 104 + end + object ColorDialog1: TColorDialog + Color = clBlack + CustomColors.Strings = ( + 'ColorA=000000' + 'ColorB=000080' + 'ColorC=008000' + 'ColorD=008080' + 'ColorE=800000' + 'ColorF=800080' + 'ColorG=808000' + 'ColorH=808080' + 'ColorI=C0C0C0' + 'ColorJ=0000FF' + 'ColorK=00FF00' + 'ColorL=00FFFF' + 'ColorM=FF0000' + 'ColorN=FF00FF' + 'ColorO=FFFF00' + 'ColorP=FFFFFF' + 'ColorQ=C0DCC0' + 'ColorR=F0CAA6' + 'ColorS=F0FBFF' + 'ColorT=A4A0A0' + ) + left = 50 + top = 212 + end + object RefreshImagesTimer: TTimer + Enabled = False + Interval = 20 + OnTimer = RefreshImagesTimerTimer + left = 82 + top = 212 + end + object RescaleImagesTimer: TTimer + Enabled = False + Interval = 50 + OnTimer = RescaleImagesTimerTimer + left = 178 + top = 212 + end + object YokeTimer: TTimer + Enabled = False + Interval = 200 + OnTimer = YokeTimerTimer + left = 280 + top = 264 + end +end diff --git a/backup/nifti_img_view.pas.bak b/backup/nifti_img_view.pas.bak new file mode 100755 index 0000000..8a35296 --- /dev/null +++ b/backup/nifti_img_view.pas.bak @@ -0,0 +1,5178 @@ +unit nifti_img_view; + {$mode delphi} +interface +{$IFDEF UNIX} + {$IFNDEF ENDIAN_BIG}{$DEFINE COMPILEYOKE}{$ENDIF} //not supported on PPC +{$ENDIF} +uses +{$H+} +{$IFDEF Darwin}Process,{$ENDIF} //CarbonOpenDoc, +{$IFDEF Unix} + lclintf,LCLType,//gettickcount ,LMessages +{$ELSE} + Windows,ShellAPI, +{$ENDIF} +{$IFDEF COMPILEYOKE} +yokesharemem, +{$ENDIF} + +LResources, fx8, cpucount, SysUtils, Classes, Graphics, Controls, Forms, +Dialogs, Menus, ComCtrls, ExtCtrls, StdCtrls, GraphicsMathLibrary, ClipBrd, +define_types, Spin, Buttons, nifti_hdr, nifti_hdr_view, nifti_img, voismooth, +IniFiles, ReadInt, stat, Distr, bet, mni, prefs, CropEdges,nifti_types, +userdir, graphx, GraphType, IntfGraphics, landmarks,fastsmooth, nii_label;//registry + + +type + + { TImgForm } + + TImgForm = class(TForm) + AutoContrastBtn: TSpeedButton; + ColorBarBtn: TSpeedButton; + LayerDrop: TComboBox; + LUTdrop: TComboBox; + LutFromZeroBtn: TSpeedButton; + MainMenu1: TMainMenu; + File1: TMenuItem; +MaxWindowEdit: TFloatSpinEdit; +MenuItem1: TMenuItem; +HistoMenu: TMenuItem; +Header1: TMenuItem; +ApplyClusterThreshold1: TMenuItem; +LRFlip1: TMenuItem; +ExportasRGBAnalyzeimage1: TMenuItem; +BatchROImean1: TMenuItem; +Batchprobmaps1: TMenuItem; +Batchclusterprobmaps1Batchclusterprobmaps1Click: TMenuItem; +Axial1: TMenuItem; +Coronal1: TMenuItem; +Axial2: TMenuItem; +Coronal2: TMenuItem; +Landmarks1: TMenuItem; +Extract1: TMenuItem; +HideDrawMenuItem: TMenuItem; +DrawHiddenMenu: TMenuItem; +MenuItem2: TMenuItem; +AppleMenu: TMenuItem; +MenuItem3: TMenuItem; +NewWindow1: TMenuItem; +Sagittal2: TMenuItem; +Sagittal1: TMenuItem; +Multiple1: TMenuItem; +PGImageAx: TImage; +PGImageSag: TImage; +Resliceimage1: TMenuItem; +AdjustimagessoVOIintensityiszero1: TMenuItem; +Brainmask1: TMenuItem; +GenerateSPM5maskslesions1: TMenuItem; +RescaleMenu: TMenuItem; +BrainExtraction1: TMenuItem; +CropEdges1: TMenuItem; +NIIVOI: TMenuItem; +MinWindowEdit: TFloatSpinEdit; +N4DTraces1: TMenuItem; +LayerPanel: TPanel; +n5: TMenuItem; +Preferences1: TMenuItem; +Display2: TMenuItem; +MNIMenu: TMenuItem; + Open1: TMenuItem; + CloseImages: TMenuItem; + Exit1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Help1: TMenuItem; + About1: TMenuItem; + ControlPanel: TPanel; + Crosshair1: TMenuItem; + Pen1: TMenuItem; + Penautoclose1: TMenuItem; + CircleSquare1: TMenuItem; + YokeTimer: TTimer; + XViewEdit: TSpinEdit; + YViewEdit: TSpinEdit; + ZViewEdit: TSpinEdit; + MagPanel: TPanel; + ProgressBar1: TProgressBar; + StatusLabel: TLabel; + LabelX: TLabel; + LabelY: TLabel; + LabelZ: TLabel; + Templates1: TMenuItem; + Recent1: TMenuItem; + Controls1: TMenuItem; + ZoomDrop: TComboBox; + Panel1: TPanel; + Saveaspicture1: TMenuItem; + SaveDialog1: TSaveDialog; + ColorDialog1: TColorDialog; + RefreshImagesTimer: TTimer; + MagnifyMenuItem: TMenuItem; + OverlayMenu: TMenuItem; + OverlayOpen: TMenuItem; + LayerMenu: TMenuItem; + Noneopen1: TMenuItem; + OverlaySmoothMenu: TMenuItem; + CloseOverlayImg: TMenuItem; + BGTransPctMenu: TMenuItem; + OverlayTransPctMenu: TMenuItem; + BGtrans0: TMenuItem; + BGtrans20: TMenuItem; + BGtrans40: TMenuItem; + BGtrans50: TMenuItem; + BGtrans60: TMenuItem; + BGtrans80: TMenuItem; + BGtrans100: TMenuItem; + N0opaque1: TMenuItem; + N201: TMenuItem; + N401: TMenuItem; + N501: TMenuItem; + N601: TMenuItem; + N801: TMenuItem; + N100transparent1: TMenuItem; + Layerrange1: TMenuItem; + Noneopen2: TMenuItem; + BGAdditive: TMenuItem; + OverlayAdditive: TMenuItem; + ShowRender: TMenuItem; + DrawMenu: TMenuItem; + OpenVOI: TMenuItem; + SaveVOI: TMenuItem; + CloseVOI: TMenuItem; + VOIColor: TMenuItem; + TriplePanel: TScrollBox; + PGImageCor: TImage; + Undo1: TMenuItem; + Paste1: TMenuItem; + Applyintensityfiltertovolume1: TMenuItem; + Quicksmooth1: TMenuItem; + MaskimagewithVOI1: TMenuItem; + VOImaskDelete: TMenuItem; + VOImaskPreserve: TMenuItem; + SaveasNIfTI1: TMenuItem; + Circle1: TMenuItem; + Overlaycomparisons1: TMenuItem; + IntersectionmutualtoVOIandoverlays1: TMenuItem; + UnionVOIoroverlays1: TMenuItem; + MaskVOIbutnotoverlays1: TMenuItem; + RescaleImagesTimer: TTimer; + SmoothVOI1: TMenuItem; + Circle2: TMenuItem; + Beta1: TMenuItem; + Chisquare1: TMenuItem; + Convert1: TMenuItem; + ROIVOI1: TMenuItem; + Statistics1: TMenuItem; + ShowMultislice: TMenuItem; + DescriptiveMenuItem: TMenuItem; + N1: TMenuItem; + HideROIBtn: TSpeedButton; + XBarBtn: TSpeedButton; + ToolPanel: TPanel; + PenBtn: TSpeedButton; + ClosedPenBtn: TSpeedButton; + FillBtn: TSpeedButton; + EllipseBtn: TSpeedButton; + Fill3DBtn: TSpeedButton; + N2: TMenuItem; + Display1: TMenuItem; + N3: TMenuItem; + FlipLRmenu: TMenuItem; + N4: TMenuItem; + Menu2DSmooth: TMenuItem; + VOI2NII: TMenuItem; + Nudge1: TMenuItem; + Up1: TMenuItem; + Left1: TMenuItem; + LeftX1: TMenuItem; + RightX1: TMenuItem; + Posterior1: TMenuItem; + Posterior2: TMenuItem; + YokeMenu: TMenuItem; + procedure Extract1Click(Sender: TObject); + procedure NewWindow1Click(Sender: TObject); + procedure ToggleDrawMenu(Sender: TObject); + procedure SaveVOIcore(lPromptFilename: boolean); +procedure FormOpenFileMethod(const FileName : string); + +procedure Landmarks1Click(Sender: TObject); +procedure SetIniMenus; +procedure Batchclusterprobmaps1Batchclusterprobmaps1ClickClick(Sender: TObject); +procedure Batchprobmaps1Click(Sender: TObject); +procedure BatchROImean1Click(Sender: TObject); +procedure BrainMask1Click(Sender: TObject); +procedure ControlPanelDragDrop(Sender, Source: TObject; X, Y: Integer); +procedure GenerateSPM5maskslesions1Click(Sender: TObject); +procedure LoadOverlay (lFilename: string); +procedure LoadOverlayIncludingRGB (lFilename: string); +procedure ApplyClusterThreshold1Click(Sender: TObject); +procedure BETmenuClick(Sender: TObject); +procedure C(Sender: TObject); +procedure CropMenuClick(Sender: TObject); +procedure ExportasRGBAnalyzeimage1Click(Sender: TObject); +procedure FormDropFiles(Sender: TObject; const FileNames: array of String); +//procedure DropFilesOSX(Sender: TObject; const FileNames: array of String); +procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +procedure FormKeyPress(Sender: TObject; var Key: char); +procedure Header1Click(Sender: TObject); +procedure HistoMenuClick(Sender: TObject); +procedure LayerDropChange(Sender: TObject); +procedure LUTdropChange(Sender: TObject); +procedure AdjustimagessoVOIintensityiszero1Click(Sender: TObject); +procedure MirrorNII1Click(Sender: TObject); +procedure MNIMenuClick(Sender: TObject); +procedure N4DTraces1Click(Sender: TObject); +procedure NIIVOIClick(Sender: TObject); +procedure PGImageCorDblClick(Sender: TObject); +procedure Preferences1Click(Sender: TObject); +procedure RescaleMenuClick(Sender: TObject); +procedure Resliceimage1Click(Sender: TObject); +procedure SaveasNIfTI1Click(Sender: TObject); +procedure SaveDialog1Close(Sender: TObject); +procedure UpdateColorSchemes; + procedure UpdateTemplates; + procedure UpdateMRU; + procedure UpdateStatusLabel; + procedure Exit1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure DisplayHdrClick(Sender: TObject); + procedure Open1Click(Sender: TObject); + procedure ToolSelectClick(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + function OpenAndDisplayImg(var lFilename: string; lAdd2MRU: boolean): boolean; + procedure OpenTemplateMRU(Sender: TObject); + procedure XViewEditChange(Sender: TObject); + procedure ReadIniFile; //read init file values + procedure WriteIniFile; + {$IFNDEF FPC} + procedure FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} + procedure FormClose(Sender: TObject); + + {$ENDIF} + procedure MagnifyTimerTimer(Sender: TObject); + procedure MagnifyPanelResize(Sender: TObject); + procedure PGImageMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); + procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure PGImageMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure PGImageMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure LUTdropLoad(var lLayer: integer); + procedure LUTdropSelect(Sender: TObject); + procedure ZoomDropChange(Sender: TObject); + procedure ZoomDropSelect(Sender: TObject); + procedure ColorBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Saveaspicture1Click(Sender: TObject); + procedure XBarBtnClick(Sender: TObject); + procedure XBarBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure XBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure AutoContrastBtnClick(Sender: TObject); + procedure RefreshImagesTimerTimer(Sender: TObject); + procedure MinContrastWindowEditChange(Sender: TObject); + procedure ImgPanelClick(Sender: TObject); + procedure MagnifyMenuItemClick(Sender: TObject); + procedure CloseImagesClick(Sender: TObject); + procedure UpdateLayerMenu; + procedure OverlayOpenCore (var lFilename: string; lOverlayNum: integer); + procedure OverlayOpenClick(Sender: TObject); + procedure CloseOverlayImgClick(Sender: TObject); + procedure BGtrans100Click(Sender: TObject); + procedure OverlayTransClick(Sender: TObject); + procedure LayerDropSelect(Sender: TObject); + procedure OverlaySmoothMenuClick(Sender: TObject); + procedure MaxContrastWindowEditChange(Sender: TObject); + procedure ShowRenderClick(Sender: TObject); + procedure PenBtnClick(Sender: TObject); + procedure OpenVOIClick(Sender: TObject); + procedure OpenVOICore(var lFilename : string); + procedure SaveVOIClick(Sender: TObject); + procedure VOIColorClick(Sender: TObject); + procedure CloseVOIClick(Sender: TObject); + procedure SetDimension8(lInPGHt,lInPGWid:integer; lBuff: ByteP; lUndoOnly: boolean); + procedure Undo1Click(Sender: TObject); + procedure Paste1Click(Sender: TObject); + procedure HideROIBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure HideROIBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure XBarColor; + procedure Applyintensityfiltertovolume1Click(Sender: TObject); + procedure Quicksmooth1Click(Sender: TObject); + procedure VOImaskClick(Sender: TObject); + procedure Sagittal1Click(Sender: TObject); + procedure ROIcomparisonClick(Sender: TObject); + procedure RescaleImagesTimerTimer(Sender: TObject); + procedure Fill3DBtnClick(Sender: TObject); + procedure SmoothVOI1Click(Sender: TObject); + procedure CreateOverlap(Sender: TObject); + procedure Chisquare1Click(Sender: TObject); + procedure ROIVOI1Click(Sender: TObject); + procedure LUTinvertBtnClick(Sender: TObject); + procedure LutFromZeroBtnClick(Sender: TObject); + procedure ShowMultisliceClick(Sender: TObject); + procedure DescriptiveMenuItemClick(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure OnLaunch; + procedure FlipLRmenuClick(Sender: TObject); + procedure Menu2DSmoothClick(Sender: TObject); + procedure VALclick(Sender: TObject); + procedure VOI2NIIClick(Sender: TObject); + procedure TtoP1Click(Sender: TObject); + procedure DesignVALClick(Sender: TObject); + procedure Up1Click(Sender: TObject); + procedure SetShareMem (lXmm,lYmm,lZmm: single); + procedure CreateShareMem; + procedure CloseShareMem; + procedure YokeTimerTimer(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure YokeMenuClick(Sender: TObject); + procedure DefaultControlPanel; + procedure ControlPanelDblClick(Sender: TObject); + procedure ResizeControlPanel (lRows: integer); + procedure SaveOrCopyImages(lCopy: boolean); + function ImgIntensityString(var lHdr: TMRIcroHdr; lVox: integer): string; overload; + function ImgIntensityString(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): string; overload; + private + { Private declarations } + +{$IFDEF FPC} function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;MousePos: TPoint): Boolean; override;{$ENDIF} + public + + + { Public declarations } +public + //procedure WMSysCommand (var Msg: TWMSysCommand) ; message WM_SYSCOMMAND; + published + property OnMouseWheel; + end; + +const + kYokeItems= 12; + knMRU = 12;//max items in most recently used list + knMaxOverlay = 20; + kVOIOverlayNum = knMaxOverlay; + kBGOverlayNum = 0; + knAutoLUT = 7; + kVOIFilter = 'Volume of interest (*.voi)|*.voi|MRIcro ROI (*.roi)|*.roi|'+kImgFilter; +var + gYoke: boolean = false; + ImgForm: TImgForm; + gBGImg: TBGImg; + gMRIcroOverlay: array [0..knMaxOverlay] of TMRIcroHdr; + gColorSchemeDir,gTemplateDir: String; + gMRUstr: array [0..knMRU] of String; //most recently used files + gMouseDownX,gMouseDownY: integer; + gSelectOrigin: TPoint; + gSelectRect: TRect; + gOrigBGTransPct : integer= 50; + //gMaxCPUThreads : integer = 8; + gnCPUThreads : integer = 1; + gUndoImg,gDrawImg: Tfx8; + +Type + SingleArr = Array[1..kYokeItems] Of Single; + SingleArrPtr = ^SingleArr; + +implementation + +uses statclustertable,batch,imgutil, reslice_fsl,render,ROIfilt,autoroi, MultiSlice, Text, histoform, + about,clustering,ReadFloat; + +{$IFDEF FPC} +{$R *.lfm} +{$ELSE} +{$R *.DFM} +{$ENDIF} +procedure TImgForm.XBarColor; +begin + ColorDialog1.Color := gBGImg.XBarClr; + if not ColorDialog1.Execute then exit; + gBGImg.XBarClr := ColorDialog1.Color; + RefreshImagesTimer.Enabled := true; + exit; +end; + + +procedure DecViewEdit(var lEdit: TSpinEdit); +begin + if lEdit.Value > 1 then + lEdit.value := lEdit.value -1 + else + lEdit.Value := lEdit.MaxValue; + {$IFDEF FPC} ImgForm.XViewEditChange(nil); {$ENDIF} +end; //DecViewEdit + +procedure IncViewEdit(var lEdit: TSpinEdit); +begin + if lEdit.Value < lEdit.MaxValue then + lEdit.value := lEdit.value +1 + else + lEdit.Value := 1; + {$IFDEF FPC} ImgForm.XViewEditChange(nil); {$ENDIF} +end; //IncViewEdit + + +function TImgForm.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; + MousePos: TPoint): Boolean; +begin + if WheelDelta = 0 then exit; + Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos); + //ImgForm.Caption := inttostr(random(888)); + //... actions after a possible OnMouseWheel[Down|Up] + //ImgForm.Caption := inttostr(WheelDelta)+' '+inttostr(random(888))+' '+inttostr(MousePos.X); + if WheelDelta < 0 then begin + Case SelectedImageNum of + 3: DecViewEdit(YViewEdit); + 2: DecViewEdit(XViewEdit); + else DecViewEdit(ZViewEdit); + end; + end else begin + Case SelectedImageNum of + 3: IncViewEdit(YViewEdit); + 2: IncViewEdit(XViewEdit); + else IncViewEdit(ZViewEdit); + end; + end; +end; + + + +procedure TImgForm.CloseShareMem; +begin +{$IFDEF COMPILEYOKE} +YokeTimer.Enabled := false; + CloseSharedMem; +{$ENDIF} +end; + +procedure TImgForm.SetShareMem (lXmm,lYmm,lZmm: single); +begin +{$IFDEF COMPILEYOKE} + if not gYoke then + exit; + SetShareFloats(lXmm,lYmm,lZmm); + +{$ENDIF} +end; + +procedure TImgForm.CreateShareMem; +begin + {$IFDEF COMPILEYOKE} + CreateSharedMem(self); + SetShareMem (0,0,0); + YokeTimer.Enabled := gYoke; + {$ENDIF} +end; + +procedure TImgForm.YokeTimerTimer(Sender: TObject); +var + lX,lY,lZ: integer; + lXmm,lYmm,lZmm: single; +begin + if not gYoke then + YokeTimer.Enabled := false; + {$IFDEF COMPILEYOKE} + //labelx.caption := inttostr(random(888)); + if not gYoke then + exit; + //LabelX.caption := inttostr(random(888)); + if not GetShareFloats(lXmm,lYmm,lZmm) then + exit; + //LabelY.caption := inttostr(random(888)); + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> XViewEdit.value then XViewEdit.value := lX; + if lY <> YViewEdit.value then YViewEdit.value := lY; + if lZ <> ZViewEdit.value then ZViewEdit.value := lZ; + XViewEditChange(nil); + + {$ENDIF} +end; + +(*var +lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if not gYoke then begin + YokeTimer.Enabled := false; + exit; + end; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; +{$IFDEF FPC} + {$IFDEF COMPILEYOKE} + lXmm:=gShareIntBuf^[1]; + lYmm:=gShareIntBuf^[2]; + lZmm:=gShareIntBuf^[3]; + {$ELSE} + YokeTimer.Enabled := false; + exit; + {$ENDIF} + +{$ELSE} + EMemMap.EnterCriticalSection; + Try + lXmm:=SingleArrPtr(EMemMap.MemMap)^[1]; + lYmm:=SingleArrPtr(EMemMap.MemMap)^[2]; + lZmm:=SingleArrPtr(EMemMap.MemMap)^[3]; + Finally + EMemMap.LeaveCriticalSection; + end; +{$ENDIF} + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> XViewEdit.value then XViewEdit.value := lX; + if lY <> YViewEdit.value then YViewEdit.value := lY; + if lZ <> ZViewEdit.value then ZViewEdit.value := lZ; + YokeTimer.Enabled := false; +end; *) + +{$IFNDEF FPC} +procedure TImgForm.WMSysCommand; +begin + if (Msg.CmdType = SC_MINIMIZE) then + Application.Minimize + else + DefaultHandler(Msg) ; + if (Msg.CmdType = SC_MAXIMIZE) then RefreshImagesTimer.enabled := true; +end; +{$ENDIF} + +function SelectedImagePanel: TScrollBox; +begin + case SelectedImageNum of + 3: result := ImgForm.TriplePanel; + 2: result := ImgForm.TriplePanel; + else result := ImgForm.TriplePanel; + end; +end; + +function DrawToolSelected: boolean; +begin + if ( ImgForm.PenBtn.Down) or ( ImgForm.ClosedPenBtn.Down) or (ImgForm.FillBtn.Down) or (ImgForm.EllipseBtn.Down) then + result := true + else + result := false; +end; + +procedure TImgForm.WriteIniFile; +var + lInc: integer; + lIni: string; + lIniFile: TIniFile; +begin + lIni:= IniName; + if (DiskFreeEx(lIni) < 1) or (not gBGIMg.SaveDefaultIni) then + exit; + //lIniFile := TIniFile.Create(changefileext(paramstr(0),'.ini')); + lIniFile := TIniFile.Create(lIni);//DefaultsDir('')+ParseFileName(extractfilename(paramstr(0)))+'.ini'); + //recent files + lIniFile.WriteString('MRU', 'file0', gMRIcroOverlay[kBGOverlayNum].HdrFilename); + for lInc := 1 to knMRU do + lIniFile.WriteString('MRU', 'file'+inttostr(lInc), gMRUstr[lINc]); + //STR + //lIniFile.WriteString('STR', 'FSLDIR',gBGImg.FSLDIR); + //lIniFile.WriteString('STR', 'FSLBETEXE',gBGImg.FSLBETEXE); + lIniFile.WriteString('STR', 'FSLBASE',gBGImg.FSLBASE); + lIniFile.WriteString('STR', 'FSLOUTPUTTYPE',gBGImg.FSLOUTPUTTYPE); + //Booleans + lIniFile.WriteString('BOOL', 'Reslice',Bool2Char(gBGImg.ResliceOnLoad)); + lIniFile.WriteString('BOOL', 'ResliceOrtho',Bool2Char(gBGImg.OrthoReslice)); + lIniFile.WriteString('BOOL', 'ShowDraw',Bool2Char(gBGImg.ShowDraw)); + lIniFile.WriteString('BOOL', 'ThinPen',Bool2Char(gBGImg.ThinPen)); + + lIniFile.WriteString('BOOL', 'Smooth2D',Bool2Char(Menu2DSmooth.checked)); + lIniFile.WriteString('BOOL', 'XBar',Bool2Char(XBarBtn.Down)); + lIniFile.WriteString('BOOL', 'OverlaySmooth',Bool2Char(OverlaySmoothMenu.Checked)); + lIniFile.WriteString('BOOL', 'LRmirror',Bool2Char(gBGImg.Mirror)); + lIniFile.WriteString('BOOL', 'Yoke',Bool2Char(gYoke)); + lIniFile.WriteString('BOOL', 'SingleRow',Bool2Char(gBGImg.SingleRow)); + lIniFile.WriteString('BOOL', 'FlipAx',Bool2Char(gBGImg.FlipAx)); + lIniFile.WriteString('BOOL', 'FlipSag',Bool2Char(gBGImg.FlipSag)); + YokeTimer.Enabled := gYoke; + //Integers + //lIniFile.WriteString('INT', 'ResizeBeforeRescale',IntToStr(gBGImg.ResizeBeforeRescale)); + lIniFile.WriteString('INT', 'FontSize',IntToStr(gBGImg.FontSize)); + lIniFile.WriteString('INT', 'SaveImgFilter',IntToStr(gBGImg.SaveImgFilter)); + lIniFile.WriteString('INT', 'SaveVoiFilter',IntToStr(gBGImg.SaveVoiFilter)); + lIniFile.WriteString('INT', 'PlanarRGB',IntToStr(gBGImg.PlanarRGB)); + + lIniFile.WriteString('INT', 'MaxDim',IntToStr(gBGImg.MaxDim)); + lIniFile.WriteString('INT', 'LicenseID',IntToStr(gBGImg.LicenseID)); + lIniFile.WriteString('INT', 'Zoom',IntToStr(ZoomDrop.ItemIndex)); + lIniFile.WriteString('INT', 'LUT',IntToStr(gMRIcroOverlay[kBGOverlayNum].LUTindex)); + lIniFile.WriteString('INT', 'XBarGap',IntToStr(gBGImg.XBarGap)); + lIniFile.WriteString('INT', 'XBarThick',IntToStr(gBGImg.XBarThick)); + lIniFile.WriteString('INT', 'XBarClr',IntToStr(gBGIMg.XBarClr)); + lIniFile.WriteString('INT', 'VOIClr',IntToStr(gBGIMg.VOIClr)); + if (gBGImg.BGTransPct < 0) or (gBGImg.BGTransPct > 90) then + gBGImg.BGTransPct := 20; //additive or transparent values can confuse users + if (gBGImg.OverlayTransPct < 0) or (gBGImg.OverlayTransPct > 90) then + gBGImg.OverlayTransPct := 20; //additive or transparent values can confuse users + lIniFile.WriteString('INT', 'BGTransPct',IntToStr(gBGImg.BGTransPct)); + lIniFile.WriteString('INT', 'OverlayTransPct',IntToStr(gBGImg.OverlayTransPct)); + lIniFile.WriteString('INT','MaxThreads',IntToStr(gnCPUThreads)); + + lIniFile.WriteString('INT', 'LesionDilate',IntToStr(gBGImg.LesionDilate)); + lIniFile.WriteString('INT', 'LesionSmooth',IntToStr(gBGImg.LesionSmooth)); +// {$ELSE} +// lIniFile.WriteString('INT', 'MaxThreads',IntToStr(gMaxCPUThreads)); +// {$ENDIF} + lIniFile.WriteString('INT', 'SigDigits',IntToStr(gBGImg.SigDig)); + lIniFile.WriteString('INT', 'ImageSeparation',IntToStr(gBGImg.ImageSeparation)); + + + lIniFile.WriteString('INT', 'SPMDefaultsStatsFmriT',IntToStr(gBGImg.SPMDefaultsStatsFmriT)); + lIniFile.WriteString('INT', 'SPMDefaultsStatsFmriT0',IntToStr(gBGImg.SPMDefaultsStatsFmriT0)); + + lIniFile.Free; +end; +(* +function registerfiletype(inft,inkey,desc,icon:string): boolean; +var myreg : treginifile; + ct : integer; + ft,key: string; +begin + result := true; + ft := inft; + key := inkey; + ct := pos('.',ft); + while ct > 0 do begin + delete(ft,ct,1); + ct := pos('.',ft); + end; + if (ft = '') or (Application.ExeName = '') then exit; //not a valid file-ext or ass. app + ft := '.'+ft; + myreg := treginifile.create(''); + try + myreg.rootkey := hkey_classes_root; // where all file-types are described + if key = '' then key := copy(ft,2,maxint)+'_auto_file'; // if no key-name is given, create one + myreg.writestring(ft,'',key); // set a pointer to the description-key + myreg.writestring(key,'',desc); // write the description + myreg.writestring(key+'\DefaultIcon','',icon); // write the def-icon if given + myreg.writestring(key+'\shell\open\command','',Application.ExeName+' %1'); //association + except + result := false; + showmessage('Only administrators can change file associations. You are currently logged in as a restricted user.'); + end; + myreg.free; +end; *) + +procedure WriteIni2Form (lBGImg: TBGImg); +begin + ImgForm.ToolPanel.Visible := lBGImg.ShowDraw; + ImgForm.DrawMenu.Visible := lBGImg.ShowDraw; + ImgForm.DrawHiddenMenu.Visible := not lBGImg.ShowDraw; +end; + +procedure TImgForm.SetIniMenus; +begin + XBarBtn.Down := gBGImg.XBarVisible; + YokeMenu.Checked := gYoke; + if (gBGImg.StretchQuality = sqLow) then + Menu2DSmooth.checked := false + else begin + Menu2DSmooth.checked := true; + gBGImg.StretchQuality := sqHigh; + end; + //Menu2DSmoothClick(nil);//set quality +end; + +procedure TImgForm.ReadIniFile; +var + lInc,lFilenum: integer; + lFilename: string; + lIniFile: TIniFile; +begin + //lFilename := changefileext(paramstr(0),'.ini'); + + lFilename := ininame;//DefaultsDir('')+ParseFileName(extractfilename(paramstr(0)))+'.ini'; + if not FileexistsEx(lFilename) then begin + //DrawMenu.Visible := ToolPanel.visible; + WriteIni2Form(gBGImg); + exit; + end; + lIniFile := TIniFile.Create(lFilename); + gMRUstr[0] := lIniFile.ReadString('MRU', 'file0', '');//file0 - last file viewed + lFileNum := 0; + for lInc := 1 to knMRU do begin + lFilename := lIniFile.ReadString('MRU', 'file'+inttostr(lInc), ''); + if (length(lFilename) > 0) and (fileexistsex(lFilename)) then begin + Inc(lFileNum); + gMRUstr[lFileNum] := lFilename; + end; + end; + gBGImg.FSLOUTPUTTYPE := lIniFile.ReadString('STR', 'FSLOUTPUTTYPE', gBGImg.FSLOUTPUTTYPE); + //gBGImg.FSLDIR := lIniFile.ReadString('STR', 'FSLDIR', gBGImg.FSLDIR); + //gBGImg.FSLBETEXE := lIniFile.ReadString('STR', 'FSLBETEXE', gBGImg.FSLBETEXE); + gBGImg.FSLBASE := lIniFile.ReadString('STR', 'FSLDIR', gBGImg.FSLBASE); + + gBGImg.ResliceOnLoad := IniBool(lIniFile,'Reslice',gBGImg.ResliceOnLoad); + gBGImg.OrthoReslice := IniBool(lIniFile,'ResliceOrtho',gBGImg.OrthoReslice); + gBGImg.ThinPen := IniBool(lIniFile, 'ThinPen',True); + + gBGImg.ShowDraw := IniBool(lIniFile, 'ShowDraw',gBGImg.ShowDraw); + WriteIni2Form(gBGImg); + if IniBool(lIniFile,'Smooth2D',Menu2DSmooth.checked) then + gBGImg.StretchQuality := sqHigh + else + gBGImg.StretchQuality := sqLow; + //Menu2DSmooth.checked := IniBool(lIniFile,'Smooth2D',Menu2DSmooth.checked); + Menu2DSmoothClick(nil);//set quality + gBGImg.XBarVisible := IniBool(lIniFile,'XBar',XBarBtn.Down); + gBGImg.OverlaySmooth := IniBool(lIniFile,'OverlaySmooth',gBGImg.OverlaySmooth); + OverlaySmoothMenu.Checked := gBGImg.OverlaySmooth; + gBGImg.Mirror := IniBool(lIniFile,'LRmirror',gBGImg.Mirror); + FlipLRmenu.Checked := gBGImg.Mirror; + gYoke := IniBool(lIniFile,'Yoke',gYoke); + gBGImg.SingleRow := IniBool(lIniFile,'SingleRow',gBGImg.SingleRow); + gBGImg.FlipAx := IniBool(lIniFile,'FlipAx',gBGImg.FlipAx); + gBGImg.FlipSag := IniBool(lIniFile,'FlipSag',gBGImg.FlipSag); + gBGImg.MaxDim := IniInt(lIniFile,'MaxDim',gBGImg.MaxDim); + gBGImg.PlanarRGB := IniInt(lIniFile,'PlanarRGB',gBGImg.PlanarRGB); + + gBGImg.LicenseID := IniInt(lIniFile,'LicenseID',gBGImg.LicenseID); +{$IFNDEF FPC} + ZoomDrop.SetItemIndex(IniInt(lIniFile,'Zoom',ZoomDrop.ItemIndex)); + LUTDrop.SetItemIndex(IniInt(lIniFile,'LUT',LUTDrop.ItemIndex)); +{$ELSE} + ZoomDrop.ItemIndex := (IniInt(lIniFile,'Zoom',ZoomDrop.ItemIndex)); + LUTDrop.ItemIndex:= (IniInt(lIniFile,'LUT',LUTDrop.ItemIndex)); +{$ENDIF} + gBGImg.XBarGap := IniInt(lIniFile,'XBarGap',gBGImg.XBarGap); + gBGImg.XBarThick := IniInt(lIniFile,'XBarThick',gBGImg.XBarThick); + gBGImg.XBarClr := IniInt(lIniFile,'XBarClr',gBGImg.XBarClr); + gBGImg.VOIClr := IniInt(lIniFile,'VOIClr',gBGImg.VOIClr); + gBGImg.BGTransPct := IniInt(lIniFile,'BGTransPct',gBGImg.BGTransPct); + gBGImg.OverlayTransPct := IniInt(lIniFile,'OverlayTransPct',gBGImg.OverlayTransPct); + gnCPUThreads := IniInt(lIniFile,'MaxThreads',gnCPUThreads); + gBGImg.SigDig := IniInt(lIniFile,'SigDigits',gBGImg.SigDig); + gBGImg.ImageSeparation := IniInt(lIniFile,'ImageSeparation',gBGImg.ImageSeparation); + gBGImg.FontSize := IniInt(lIniFile,'FontSize',gBGImg.FontSize); + gBGImg.SaveImgFilter := IniInt(lIniFile,'SaveImgFilter',gBGImg.SaveImgFilter); + gBGImg.SaveVoiFilter := IniInt(lIniFile,'SaveVoiFilter',gBGImg.SaveVoiFilter); + gBGImg.SPMDefaultsStatsFmriT := IniInt(lIniFile,'SPMDefaultsStatsFmriT',gBGImg.SPMDefaultsStatsFmriT); + gBGImg.SPMDefaultsStatsFmriT0 := IniInt(lIniFile,'SPMDefaultsStatsFmriT0',gBGImg.SPMDefaultsStatsFmriT0); + gBGImg.LesionSmooth := IniInt(lIniFile,'LesionSmooth',gBGImg.LesionSmooth); + gBGImg.LesionDilate := IniInt(lIniFile,'LesionDilate',gBGImg.LesionDilate); + + + + SetSubmenuWithTag(BGTransPctMenu, gBGImg.BGTransPct); + SetSubmenuWithTag(OverlayTransPctMenu, gBGImg.OverlayTransPct); + lIniFile.Free; + +end; //ReadIniFile + +//lStrings := TStringList.Create; + + +procedure TImgForm.UpdateColorSchemes; +var + lSearchRec: TSearchRec; + lStrings : TStringList; +begin + LUTdrop.Items.Clear; + LUTdrop.Items.Add('Grayscale'); + LUTdrop.Items.Add('Red'); + LUTdrop.Items.Add('Blue'); + LUTdrop.Items.Add('Green'); + LUTdrop.Items.Add('Violet [r+b]'); + LUTdrop.Items.Add('Yellow [r+g]'); + LUTdrop.Items.Add('Cyan [g+b]'); + lStrings := TStringList.Create; + if FindFirst(gColorSchemeDir+pathdelim+'*.lut', faAnyFile, lSearchRec) = 0 then + repeat + lStrings.Add(ParseFileName(ExtractFileName(lSearchRec.Name))); + //LUTdrop.Items.Add(ParseFileName(ExtractFileName(lSearchRec.Name))); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); + lStrings.Sort; + LUTdrop.Items.AddStrings(lStrings); + lStrings.Free; + //LUTDrop.DropDownCount := 66;//LUTDrop.Items.Count; +end;//UpdateColorSchemes + +(*procedure TImgForm.UpdateColorSchemes; +var + lSearchRec: TSearchRec; +begin + LUTdrop.Items.Clear; + LUTdrop.Items.Add('Grayscale'); + LUTdrop.Items.Add('Red'); + LUTdrop.Items.Add('Blue'); + LUTdrop.Items.Add('Green'); + LUTdrop.Items.Add('Violet [r+b]'); + LUTdrop.Items.Add('Yellow [r+g]'); + LUTdrop.Items.Add('Cyan [g+b]'); + if FindFirst(gColorSchemeDir+pathdelim+'*.lut', faAnyFile, lSearchRec) = 0 then + repeat + LUTdrop.Items.Add(ParseFileName(ExtractFileName(lSearchRec.Name))); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); + xxx + //LUTDrop.DropDownCount := 66;//LUTDrop.Items.Count; +end;//UpdateColorSchemes +*) + +procedure TImgForm.BETmenuClick(Sender: TObject); +begin + BetForm.show; +end; + +procedure TImgForm.ApplyClusterThreshold1Click(Sender: TObject); +var + lNumberofFiles,lC,lClusterSz: integer; + lThresh: double; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + lClusterSz := ReadIntForm.GetInt('Minimum cluster size [in voxels]: ', 1,32,9999); + lThresh := ReadFloatForm.GetFloat('Include voxels with an intensity above: ', 0,2,9999); + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + //lFilename := changefileextX(lFilename,'I'+inttostr(round(lThresh))+'C'+inttostr(lClusterSz)+'.nii.gz'); + lFilename := changefileprefix(lFilename,'I'+inttostr(round(lThresh))+'C'+inttostr(lClusterSz)); + if ClusterFilterScrnImg (gMRIcroOverlay[kBGOverlayNum],lClusterSz,lThresh ) then + if ImgVaries(gMRIcroOverlay[kBGOverlayNum]) then + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr) + else + showmessage('No clusters survive filter '+ HdrForm.OpenHdrDlg.Files[lC-1]); + ProgressBar1.Position := lC; + end; + if fileexistsEX(lFilename) then + ImgForm.OpenAndDisplayImg(lFilename,True); + ProgressBar1.Position := 0; +end; + +procedure TImgForm.C(Sender: TObject); +begin + +end; + +procedure TImgForm.CropMenuClick(Sender: TObject); +begin + CropEdgeForm.Show; +end; + +procedure TImgForm.ExportasRGBAnalyzeimage1Click(Sender: TObject); +var + lFlip: boolean; +begin + lFlip := gBGImg.Mirror; + gBGImg.Mirror := true; + CreateAnaRGB; + gBGImg.Mirror := lFlip; +end; + +procedure TImgForm.FormDropFiles(Sender: TObject; const FileNames: array of String); +var + lFilename: string; +begin + if length(FileNames) < 1 then + exit; + lFilename := Filenames[0]; + OpenAndDisplayImg(lFilename,true); +end; + +procedure TImgForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + //ImgForm.caption := inttostr(Key); + if (XViewEdit.focused) or (YViewEdit.focused) or (ZViewEdit.focused) or (MinWindowEdit.focused) or (MaxWindowEdit.focused) then + exit; + Case Key of + 36: DecViewEdit(YViewEdit); + 35: IncViewEdit(YViewEdit); + 37: DecViewEdit(XViewEdit); + 38: IncViewEdit(ZViewEdit); + 39: IncViewEdit(XViewEdit); + 40: DecViewEdit(ZViewEdit); + + end; //case Key + (* if WheelDelta < 0 then begin + Case SelectedImageNum of + 3: DecViewEdit(YViewEdit); + 2: DecViewEdit(XViewEdit); + else DecViewEdit(ZViewEdit); + end; + end else begin + Case SelectedImageNum of + 3: IncViewEdit(YViewEdit); + 2: IncViewEdit(XViewEdit); + else IncViewEdit(ZViewEdit); + end; + end;*) +end; + +procedure TImgForm.FormKeyPress(Sender: TObject; var Key: char); +begin + //imgform.caption := 'zzz'; +end; + + + +procedure TImgForm.Header1Click(Sender: TObject); +begin + DisplayHdrClick(nil); +end; + + +function ActiveLayer:integer; +begin + result := ImgForm.LayerDrop.ItemIndex; + if result < 0 then + result := 0; +end; + +{$DEFINE noTEST} + +{$IFDEF TEST} +procedure DrawBMP2( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +//uses GraphType, IntfGraphics +var + IntfImage: TLazIntfImage; + ScanLineImage: TLazIntfImage; + ImgFormatDescription: TRawImageDescription; + lBitmap: TBitmap; +begin + lBitmap:=TBitmap.Create; + ScanLineImage:=TLazIntfImage.Create(0,0); + ImgFormatDescription.Init_BPP32_B8G8R8_BIO_TTB(lx,ly); + ScanLineImage.DataDescription:=ImgFormatDescription; + // call the pf24bit specific drawing function + Move(lBuff^[1],PByte(ScanLineImage.GetDataLineStart(0))[1],lx*ly*sizeof(TRGBquad) ); + lBitmap.Width:=ScanLineImage.Width; + lBitmap.Height:=ScanLineImage.Height; + IntfImage:=lBitmap.CreateIntfImage; + // convert the content from the very specific to the current format + IntfImage.CopyPixels(ScanLineImage); + lBitmap.LoadFromIntfImage(IntfImage); + ScanLineImage.Free; + IntfImage.Free; + lImage.Picture.Bitmap := lBitmap; + lBitmap.Free; +end; + +procedure FZ; +var + l2Time,lTime: DWord; + y,x,lx, ly, lpos: integer; + lBuff: RGBQuadp ; +begin + lx := 320; + ly := 320; + getmem(lBuff,(lx*ly)*sizeof( TRGBquad)); + lpos := 0; + for y := 1 to ly do begin + for x := 1 to lx do begin + inc(lpos); + lBuff^[lpos].rgbblue := (y mod 255); + lBuff^[lpos].rgbgreen :=(y mod 255); + lBuff^[lpos].rgbred := (x mod 255) ; + lBuff^[lpos].rgbreserved := 0; + end; + end; + l2Time := GetTickCount; + for y := 1 to 100 do + DrawBMP2( lx, ly, lBuff,HistogramForm.HistoImage{lImage}); + l2Time := GetTickCount - l2Time; + lTime := GetTickCount; + for y := 1 to 100 do + DrawBMP( lx, ly, lBuff,HistogramForm.HistoImage{lImage}); + lTime := GetTickCount - lTime; + HistogramForm.Caption := inttostr(lTime)+' '+inttostr(l2Time); + freemem(lBuff); +end; +{$ENDIF} + +procedure TImgForm.HistoMenuClick(Sender: TObject); +VAR + lLayer: integer; +begin + {$IFDEF TEST} + FZ; + {$ELSE} + lLayer := ActiveLayer; + DrawHistogram(gMRIcroOverlay[lLayer],HistogramForm.HistoImage{lImage}); + HistogramForm.Caption := 'Histogram: '+extractfilename(gMRIcroOverlay[lLayer].HdrFileName); + {$ENDIF} + HistogramForm.show; + //HistogramForm.BringToFront; +end; + + + +procedure TImgForm.MNIMenuClick(Sender: TObject); +begin + MNIForm.show; + //MNIForm.BringToFront; + +end; + +procedure TImgForm.N4DTraces1Click(Sender: TObject); +begin + Graph4DForm.show; + //Graph4DForm.BringToFront; +end; + +procedure TImgForm.NIIVOIClick(Sender: TObject); + var + lNumberofFiles,lC: integer; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter {10/2007},'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileextx(lFilename,'.voi'); ////Xversion 10/2007 - removes .nii.gz not just gz + //SaveAsVOIorNIFTIcore (lFilename, lByteP, lVoxels, 1, gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; + +end; + + +procedure TImgForm.PGImageCorDblClick(Sender: TObject); +begin + if Graph4DForm.visible then + Graph4DForm.RefreshBtn.click; +end; + +procedure TImgForm.Preferences1Click(Sender: TObject); +begin + PrefForm.ShowModal; +end; + +function RescaleImg( lRescaleIntercept,lRescaleSlope: double): boolean; +var + //lRow,lNumberofFiles,lX,lY,lZ: integer; + //lFilename: string; + lHdr:TMRIcroHdr; + lImgSamples,lInc,lBPP: integer; + l32Buf,lo32Buf : SingleP; + l16Buf : SmallIntP; +begin + //note ignores input slope/intercept scaling values + result := false; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + if ((gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2] * gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then begin + showmessage('Unable to rescale.'); + exit; + end; + lBPP := gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP;//check if BitsPerPixel is supported + if (lBPP <> 4) and (lBPP <> 2) and (lBPP <> 1) then begin + showmessage('RescaleImg Error: Unsupported BPP: '+inttostr(lBPP)); + exit; + end; + lImgSamples := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lHdr,0{min}, 0{max},0{p1},0{p2},0{p3},kNIFTI_INTENT_NONE,floattostr(lRescaleSlope) ); + GetMem(lHdr.ImgBufferUnaligned ,(lImgSamples*4)+16); + //svn lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); + lo32Buf := SingleP( lHdr.ImgBuffer ); + if lBPP = 4 then begin + l32Buf := SingleP( gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lInc := 1 to lImgSamples do + lo32Buf^[lInc] := (l32Buf^[lInc]+lRescaleIntercept) * lRescaleSlope; + end else if lBPP = 2 then begin //lBPP=4 else + l16Buf := SmallIntP( gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lInc := 1 to lImgSamples do + lo32Buf^[lInc] := (l16Buf^[lInc]+lRescaleIntercept) * lRescaleSlope; + end else if lBPP = 1 then begin //lBPP=2 else + for lInc := 1 to lImgSamples do + lo32Buf^[lInc] := (gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lInc]+lRescaleIntercept) * lRescaleSlope; + end;//lBPP = 1 + SaveAsVOIorNIFTI(bytep(lo32Buf),lImgSamples,4,1,false,lHdr.NiftiHdr,'rscl'+extractfilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename)); + //SaveAsVOIorNIFTI(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); + FreeMem(lHdr.ImgBufferUnaligned); + //lFilename := 'c:\striped2.hdr'; + //SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + result := true; +end; + + +procedure TImgForm.RescaleMenuClick(Sender: TObject); +var ldTE,lScale,lTE1,lTE2: double; + //lStr: string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + if gBGImg.Resliced then begin + if not HdrForm.OpenAndDisplayHdr(gMRIcroOverlay[kBGOverlayNum].HdrFileName,gMRIcroOverlay[kBGOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false) then exit; + end; + if (gMRIcroOverlay[kBGOverlayNum].GlMinUnscaledS < 0) or (gMRIcroOverlay[kBGOverlayNum].GlMaxUnscaledS > 4096) then begin + showmessage('Error: you need to load a Siemens format Phase map with raw values in the range 0..4096'); + exit; + end; + lTE1 := ReadFloatForm.GetFloat('Please enter the first TE (ms) used for phasemap. ', 0,5.19,9999); + lTE2 := ReadFloatForm.GetFloat('Please enter the second TE (ms) used for phasemap. ', 0,7.65,9999); + + (*lStr := floattostr(5.19); //use floattostr for local decimal separator + if not InputQuery('TEs used to create phasemap','Please enter the first TE in ms', lStr) then + exit; + try + lTE1 := strtofloat(lStr); + except + showmessage('Unable to convert the string '+lStr+' to a number'); + exit; + end; + lStr := floattostr(7.65); + if not InputQuery('TEs used to create phasemap','Please enter the second TE in ms', lStr) then + exit; + try + lTE2 := strtofloat(lStr); + except + showmessage('Unable to convert the string '+lStr+' to a number'); + exit; + end;*) + if lTE1 = lTE2 then begin + showmessage('In order to compute Rad/S the two TEs must be different.'); + exit; + end; + //fx(lTE1,lTE2); + //exit; +//the fieldmap is simply a phase +//difference image and is not scaled to any particular units. In Siemens +//phase images the data goes from 0 to 4095 with 0 being -pi radians, 2048 +//is 0 radians, and 4095 is just short of +pi radians. + //So, to get units of radians/s you would need to know the difference in + //echo times (dTE) in units of s (not ms). You would then take + //(x-2048)(2pi/4096)/dTE +//Note ignore original intercept and scale values + //ldTE := abs(5.19 - 7.65)/1000; // div 1000 to scale ms to sec + ldTE := abs(lTE1 - lTE2)/1000; // div 1000 to scale ms to sec + lScale := (2*pi/4096)/ldTE; + //showmessage(floattostr(lScale)); + rescaleImg(-2048,lScale); +end; + +procedure TImgForm.Resliceimage1Click(Sender: TObject); +begin + ResliceFSL; +end; + +procedure TImgForm.SaveasNIfTI1Click(Sender: TObject); + var + lLayer: integer; +begin + //if not SaveDialog2.Execute then exit; + lLayer := ActiveLayer; + if gMRIcroOverlay[lLayer].ImgBufferItems=0 then begin + Showmessage('You must load an image [File/Open] before you can save the image.'); + exit; + end; + if (not IsNifTiMagic(gMRIcroOverlay[lLayer].niftiHdr)) then + Showmessage('Warning: image will be saved with NIfTI spatial transform - ensure this image matches the orientation of the template images.'); + SaveAsVOIorNIFTI(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); +end; + +procedure ApplySaveDlgFilter (lSaveDlg: TSaveDialog); +var + lLen,lPos,lPipes,lPipesReq: integer; + lExt,lName: string; +begin + lPipesReq := (lSaveDlg.FilterIndex * 2)-1; + if lPipesReq < 1 then exit; + lLen := length(lSaveDlg.Filter); + lPos := 1; + lPipes := 0; + while (lPos < lLen) and (lPipes < lPipesReq) do begin + if lSaveDlg.Filter[lPos] = '|' then + inc(lPipes); + inc(lPos); + end; + if (lPos >= lLen) or (lPipes < lPipesReq) then + exit; + lExt := ''; + while (lPos <= lLen) and (lSaveDlg.Filter[lPos] <> '|') do begin + if lSaveDlg.Filter[lPos] <> '*' then + lExt := lExt + lSaveDlg.Filter[lPos]; + inc(lPos); + end; + lName := lSaveDlg.Filename; + if lExt <> '' then + lSaveDlg.Filename := ChangeFileExtX(lName,lExt); +end; + + + +procedure TImgForm.SaveDialog1Close(Sender: TObject); +begin + ApplySaveDlgFilter(SaveDialog1); +end; + + +procedure Add2MRU (var lNewFilename: string); //add new file to most-recent list +var + lStr: string; + lPos,lN : integer; +begin + //first, increase position of all old MRUs + lN := 0; //Number of MRU files + for lPos := 1 to (knMRU) do begin//first, eliminate duplicates + lStr := gMRUstr[lPos]; + if (lStr <> '') and (lStr <> lNewFileName) then begin + inc(lN); + gMRUstr[lN] := lStr; + end; //keep in MRU list + end; //for each MRU + //next, increment positions + if lN >= knMRU then + lN := knMRU - 1; + for lPos := lN downto 1 do + gMRUstr[lPos+1] := gMRUstr[lPos]; + if (lN+2) < (knMRU) then //+1 as we have added a file + for lPos := (lN+2) to knMRU do + gMRUstr[lPos] := ''; + gMRUstr[1] := lNewFilename; + ImgForm.UpdateMRU; + ImgForm.SaveDialog1.FileName := lNewFilename; +end;//Add2MRU + +procedure TImgForm.UpdateMRU;//most-recently-used menu +var + NewItem: TMenuItem; + lPos: integer; +begin + While Recent1.Count < knMRU do begin + NewItem := TMenuItem.Create(Self); + Recent1.Add(NewItem); + end; + for lPos := 1 to knMRU do begin//for each MRU + Recent1.Items[lPos-1].Visible:=gMRUstr[lPos] <> ''; + Recent1.Items[lPos-1].Caption :=ExtractFileName(gMRUstr[lPos]); + Recent1.Items[lPos-1].Tag := lPos; + Recent1.Items[lPos-1].onclick := OpenTemplateMRU; + {$IFDEF Darwin} + Recent1.Items[lPos-1].ShortCut := ShortCut(Word('1')+ord(lPos-1), [ssMeta]); + {$ELSE} + Recent1.Items[lPos-1].ShortCut := ShortCut(Word('1')+ord(lPos-1), [ssCtrl]); + {$ENDIF} + end;//for each MRU +end; //UpdateMRU + +procedure TImgForm.UpdateTemplates; +var + NewItem: TMenuItem; + lN : integer; + lFName : String; + lSearchRec: TSearchRec; +begin + While Templates1.Count < knMRU do begin + NewItem := TMenuItem.Create(Self); + Templates1.Add(NewItem); + end; + lN := 0; + if FindFirst(gTemplateDir+pathdelim+'*.*', faAnyFile, lSearchRec) = 0 then begin + repeat + lFName := lSearchRec.Name; + + if IsNIfTIHdrExt (lFName) then begin + Templates1.Items[lN].Caption :=ExtractFileName(lFName);//(ParseFileName(ExtractFileName(lFName))); + Templates1.Items[lN].Tag := 0; + Templates1.Items[lN].visible := true; + Templates1.Items[lN].onclick := OpenTemplateMRU; + {$IFDEF Darwin} + Templates1.Items[lN].ShortCut := ShortCut(Word('1')+ord(lN), [ssMeta, ssAlt]); + {$ELSE} + Templates1.Items[lN].ShortCut := ShortCut(Word('1')+ord(lN), [ssCtrl, ssShift]); + {$ENDIF} + inc(lN); + end; + until (FindNext(lSearchRec) <> 0) or (lN >= knMRU); + end;// else + if (lN = 0) then ImgForm.Caption :=('Unable to find any files in the folder '+gTemplateDir+pathdelim); + + while lN < knMRU do begin + Templates1.Items[lN].visible := false; + inc(lN); + end; + FindClose(lSearchRec); +end;//UpdateTemplates + +(*NOT OSX 10.7 friendly... procedure TImgForm.UpdateMRU;//most-recently-used menu +var + NewItem: TMenuItem; + lPos,lN : integer; +begin + //Recent1.Clear; + //While Recent1.Count > 1 do Recent1.Delete(0); + // While Recent1.Count > 0 do Recent1.Items[0].Free; + lN := 0; + for lPos := 1 to knMRU do begin//for each MRU + if gMRUstr[lPos] <> '' then begin + inc(lN); + NewItem := TMenuItem.Create(Self); + NewItem.Caption :=ExtractFileName(gMRUstr[lPos]);//(ParseFileName(ExtractFileName(lFName))); + NewItem.Tag := lN; + {$IFDEF FPC} + NewItem.onclick := OpenTemplateMRU; //Lazarus + {$ELSE} + NewItem.onclick := OpenTemplateMRU; + {$ENDIF} + NewItem.ShortCut := ShortCut(Word('1')+ord(lN-1), [ssCtrl]); + Recent1.Add(NewItem); + end;//if mru exists + end;//for each MRU +end; //UpdateMRU + +procedure TImgForm.UpdateTemplates; +var + NewItem: TMenuItem; + lN : integer; + lFName : String; + lSearchRec: TSearchRec; +begin + While Templates1.Count > 0 do Templates1.Items[0].Free; + lN := 0; + if FindFirst(gTemplateDir+pathdelim+'*.*', faAnyFile, lSearchRec) = 0 then begin + repeat + lFName := lSearchRec.Name; + if IsNIfTIHdrExt (lFName) then begin + inc(lN); + NewItem := TMenuItem.Create(Self); + NewItem.Caption :=ExtractFileName(lFName);//(ParseFileName(ExtractFileName(lFName))); + NewItem.Tag := 0; + {$IFDEF FPC} + NewItem.onclick := OpenTemplateMRU; //Lazarus + {$ELSE} + NewItem.onclick := OpenTemplateMRU; + {$ENDIF} + if (lN+knMRU) <= 9 then + NewItem.ShortCut := ShortCut(Word('1')+knMRU+ord(lN-1), [ssCtrl]); + Templates1.Add(NewItem); + end; + until (FindNext(lSearchRec) <> 0) + end; + FindClose(lSearchRec); +end;//UpdateTemplates *) + +procedure TImgForm.OpenTemplateMRU(Sender: TObject);//open template or MRU +//Templates have tag set to 0, Most-Recently-Used items have tag set to position in gMRUstr +var + lFilename: string; +begin + if sender = nil then begin + //autolaunch with last image, or last template image in list + lFilename := gMRUstr[0]; + if (lFilename = '') or (not FileExistsEX(lFilename)) then begin + if Templates1.Count > 0 then + Templates1.Items[Templates1.Count-1].click; + exit; + end; + OpenAndDisplayImg(lFilename,true); //open but do not add templates to MRU + end else if (Sender as TMenuItem).tag = 0 then begin + lFilename := gTemplateDir+pathdelim+(Sender as TMenuItem).caption ;//+ '.hdr'; + OpenAndDisplayImg(lFilename,false); //open but do not add templates to MRU + end else if (Sender as TMenuItem).tag <= knMRU then begin + lFilename := gMRUstr[(Sender as TMenuItem).tag]; + OpenAndDisplayImg(lFilename,true); + end else + Showmessage('OpenTemplateMRU error.'); +end; + +function TImgForm.OpenAndDisplayImg(var lFilename: string; lAdd2MRU: boolean): boolean; +var + lVal: integer; +begin + Result := false; + + if (FSize(lFilename)) < 348 then exit; //to small to be a header or DICOM image + + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kBGOverlayNum]) then exit; + + + //if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + // if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,not gBGImg.ResliceOnLoad,false) then exit + //end else + if (ssCtrl in KeyDataToShiftState(vk_Shift)) and (gBGIMg.OrthoReslice) then begin + gBGIMg.OrthoReslice := false; + OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false); + gBGIMg.OrthoReslice := true; + end else if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,not gBGImg.ResliceOnLoad,false) then exit + end else + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,gBGImg.ResliceOnLoad,false) then exit; + + XViewEdit.MaxValue := gBGImg.ScrnDim[1];//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1]; + YViewEdit.MaxValue := gBGImg.ScrnDim[2];//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]; + ZViewEdit.MaxValue :=gBGImg.ScrnDim[3];// gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3]; + (*XViewEdit.Value := round(gBGImg.ScrnOri[1]);//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1] div 2; + YViewEdit.Value := round(gBGImg.ScrnOri[2]);//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]div 2; + lVal := round(gBGImg.ScrnOri[3]); + if lVal < 1 then + lVal := 1; + ZViewEdit.Value := lVal;//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3] div 2;*) + + XViewEdit.Value := Bound ( round(gBGImg.ScrnOri[1]),1,round(XViewEdit.MaxValue)); + YViewEdit.Value := Bound ( round(gBGImg.ScrnOri[2]),1,round(YViewEdit.MaxValue)); + ZViewEdit.Value := Bound ( round(gBGImg.ScrnOri[3]),1,round(ZViewEdit.MaxValue)); + //ImgForm.Caption := extractfilename(paramstr(0))+' - '+lFilename; + StatusLabel.caption := 'opened: '+lFilename; + + Result := true; + //LayerDrop.ItemIndex := 0; + //LayerDropSelect(nil); + if lAdd2MRU then Add2MRU(lFilename); + if gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.datatype = kDT_RGB then begin //RGB + //we have loaded the first [red] plane - now load green and blue... + OverlayOpenCore(lFilename,1); + OverlayOpenCore(lFilename,2); + //must use additive blending + //gBGImg.BGTransPct := -1; + //gBGImg.OverlayTransPct := -1; + OverlayAdditive.Click; + BGAdditive.Click; + end; + {$IFDEF FPC} + XViewEditChange(nil); + {$ENDIF} + //showmessage(lFilename+' 666 '+ChangeFileext(lFilename,'.anat')); + AnatForm.OpenAnat( ChangeFileextx(lFilename,'.anat')); +end; //OpenAndDisplayImg + +{$IFNDEF FPC} +procedure TImgForm.WMDropFiles(var Msg: TWMDropFiles); //implement drag and drop +var + CFileName: array[0..MAX_PATH] of Char; + lFilename: string; +begin + try + if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then + begin + lFilename := CFilename; + OpenAndDisplayImg(lFilename,true); + Msg.Result := 0; + end; + finally + DragFinish(Msg.Drop); + end; +end; +{$ENDIF} + +procedure TImgForm.Exit1Click(Sender: TObject); +begin + ImgForm.Close; +end; + +function XToStr(lR: extended; lDec: integer): string; +begin + result := FloatToStrF(lR, ffFixed,7,lDec); +end; + +procedure TImgForm.DisplayHdrClick(Sender: TObject); +var + lLayer:integer; +begin + lLayer := ActiveLayer; + HdrForm.SaveHdrDlg.Filename := gMRIcroOverlay[lLayer].HdrFilename; + HdrForm.WriteHdrForm (gMRIcroOverlay[lLayer]); + HdrForm.Show; + //HdrForm.BringToFront; + //HdrForm.BringToFront; +end; + +procedure TImgForm.Open1Click(Sender: TObject); +var + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilterPlusAny,'Select background image',false) then exit; + lFilename := HdrForm.OpenHdrDlg.Filename; + OpenAndDisplayImg(lFilename,True); +end; + +procedure TImgForm.ToolSelectClick(Sender: TObject); +begin + if (not ToolPanel.Visible) and ((Sender as TMenuItem).Tag > 0) then exit; //tools disabled + case (Sender as TMenuItem).Tag of + 0: begin + XBarBtn.Down := not XBarBtn.Down; + {$IFDEF Darwin} XBarbtnClick(nil); exit;{$ENDIF} + end; + 2: PenBtn.Down := true; + 3: ClosedPenBtn.Down := true; + 4: FillBtn.Down := true; + 5: EllipseBtn.Down := true; + 6: begin + PenBtn.Down := false; + ClosedPenBtn.Down := false; + FillBtn.Down := false; + EllipseBtn.Down := false; + end; + end; //case + RefreshImagesTimer.Enabled := true; +end; + +function SelectedImage: TImage; +begin + case SelectedImageNum of + kSagView0: result := ImgForm.PGImageSag; + kCoroView0: result := ImgForm.PGImageCor; + else + result := ImgForm.PGImageAx; + end; +end; + +procedure TImgForm.SetDimension8(lInPGHt,lInPGWid:integer; lBuff: ByteP; lUndoOnly: boolean); +begin + DefineBuffFX8(gDrawImg, lInPGWid,lInPGHt,lBuff); + DefineBuffFX8(gUndoImg, lInPGWid,lInPGHt,lBuff); + +end; + +procedure WriteAxialVOI (lUndoOnly: boolean); +var lX,lY,lSliceOffset,lSliceSz,lSlicePos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lSliceSz := lX*lY; + if lSliceSz < 1 then exit; + lSliceOffset := (ImgForm.ZViewEdit.Value-1)*lX*lY; + gBGImg.VOIUndoSlice := ImgForm.ZViewEdit.Value; + getmem(lInBuff,lSliceSz); + for lSlicePos := 1 to lSliceSz do + lInBuff^[lSlicePos] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lSliceOffset+lSlicePos]; + ImgForm.SetDimension8(lY,lX, lInBuff,lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteCorVOI (lUndoOnly: boolean); +var lX,lY,lZ,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lXPos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lYOffset := (lX) * (round(ImgForm.YViewEdit.Value)-1); + gBGImg.VOIUndoSlice := ImgForm.YViewEdit.Value; + lXYSliceSz := (lX*lY); + getmem(lInBuff,lZ*lX); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + lInBuff^[lPixel] := + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lZOffset+lYOffset+lXPos]; + end; //for each Y + end; //for each Z + ImgForm.SetDimension8(lZ,lX, lInBuff,lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteSagVOI (lUndoOnly: boolean); +var lX,lY,lZ,lXOffset,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lYPos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lXYSliceSz := lX*lY; + lXOffset := round(ImgForm.XViewEdit.Value); + //dec(lXOffset);//999+8 + gBGImg.VOIUndoSlice := ImgForm.XViewEdit.Value; + getmem(lInBuff,lZ*lY); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + lInBuff^[lPixel] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lZOffset+lYOffset+lXOffset]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z + ImgForm.SetDimension8(lZ,lY, lInBuff, lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteUndoVOI(lPanel: integer;lUndoOnly: boolean); +begin + EnsureVOIOPen; + case lPanel of + 3: WriteCorVOI(lUndoOnly); + 2: WriteSagVOI(lUndoOnly); + else WriteAxialVOI(lUndoOnly); + end; + gBGImg.VOIchanged := true; + if gBGImg.VOIUndoOrient = 4 then + FreeUndoVol; //release 3D undo buffer when creating 2D buffer + gBGImg.VOIUndoOrient := lPanel; +end; + +procedure TImgForm.FormOpenFileMethod(const FileName : string); +var + lFilename: string; +begin + lFilename := Filename; + OpenAndDisplayImg(lFilename,true); +end; + +procedure TImgForm.Landmarks1Click(Sender: TObject); +begin + //Graph4DForm.show; + AnatForm.show; +end; + +procedure TImgForm.FormCreate(Sender: TObject); +var + lInc: longint; +begin + Application.ShowButtonGlyphs := sbgNever; + KeyPreview := true; + + {$IFDEF Darwin} + //InitOpenDocHandler;//allows files to be associated... + {$IFNDEF LCLgtk} //for Carbon or Cocoa + AppleMenu.Visible:= true; + NewWindow1.Visible := true; + Open1.ShortCut := ShortCut(Word('O'), [ssMeta]); + SaveasNIfTI1.ShortCut := ShortCut(Word('S'), [ssMeta,ssAlt]); + Saveaspicture1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Paste1.ShortCut := ShortCut(Word('V'), [ssMeta]); + Undo1.ShortCut := ShortCut(Word('Z'), [ssMeta]); + OverlayOpen.ShortCut := ShortCut(Word('A'), [ssMeta]); + Applyintensityfiltertovolume1.ShortCut := ShortCut(Word('F'), [ssMeta]); + HistoMenu.ShortCut := ShortCut(Word('H'), [ssMeta]); + ShowRender.ShortCut := ShortCut(Word('R'), [ssMeta]); + ShowMultislice.ShortCut := ShortCut(Word('M'), [ssMeta]); + N4DTraces1.ShortCut := ShortCut(Word('D'), [ssMeta]); + Header1.ShortCut := ShortCut(Word('I'), [ssMeta]); + YokeMenu.ShortCut := ShortCut(Word('Y'), [ssMeta]); + // OnDropFiles := OnDropFiles; + + {$ENDIF} + {$ENDIF} +{$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Exit1.visible := false;//with OSX users quit from application menu + {$ENDIF} + {$ENDIF} + CreateFX8(gUndoImg); + CreateFX8(gDrawImg); + TriplePanel.OnMouseWheelDown:= FormMouseWheelDown; + TriplePanel.OnMouseWheelUp:= FormMouseWheelUp; + TriplePanel.OnMouseWheelDown:= FormMouseWheelDown; + TriplePanel.OnMouseWheelUp:= FormMouseWheelUp; + TriplePanel.OnMouseWheelDown:= FormMouseWheelDown; + TriplePanel.OnMouseWheelUp:= FormMouseWheelUp; + randomize; + gnCPUThreads := GetLogicalCpuCount; + gMouseDownX := -1; + ImgForm.Caption := extractfilename(paramstr(0)); + ImgForm.DoubleBuffered := true; + TriplePanel.DoubleBuffered := true; + TriplePanel.DoubleBuffered := true; + TriplePanel.DoubleBuffered := true; + for lInc := 0 to knMaxOverlay do begin + FreeImgMemory(gMRIcroOverlay[lInc]); + NIFTIhdr_ClearHdr(gMRIcroOverlay[lInc]); + gMRIcroOverlay[lInc].ScrnBufferItems := 0; + gMRIcroOverlay[lInc].ImgBufferItems := 0; + if lInc < knAutoLUT then + gMRIcroOverlay[lInc].LUTindex := lInc + else + gMRIcroOverlay[lInc].LUTindex := lInc;//B&W + LoadMonochromeLUT(gMRIcroOverlay[lInc].LUTindex,gBGImg,gMRIcroOverlay[lInc]); + end; + lInc:=maxint; + LoadMonochromeLUT(lInc,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + SetBGImgDefaults(gBGImg); + CloseImagesClick(nil); + gColorSchemeDir := extractfilepath(paramstr(0))+'lut'; + {$IFNDEF Unix} DragAcceptFiles(Handle, True); //engage drag and drop + {$ENDIF} + UpdateColorSchemes; + {$IFNDEF FPC} + LUTdrop.SetItemIndex(0); + Zoomdrop.SetItemIndex(0); + LayerDrop.SetItemIndex(0); + {$ELSE} + Application.OnDropFiles := FormDropFiles; + LUTdrop.ItemIndex:=(0); + Zoomdrop.ItemIndex:=(0); + LayerDrop.ItemIndex:=(0); + MagnifyMenuItem.visible := false; + {$IFNDEF COMPILEYOKE} + YokeMenu.visible := false; + {$ENDIF} +{$ENDIF} + gTemplateDir := extractfilepath(paramstr(0))+'templates'; + UpdateTemplates; + + for lInc := 1 to knMRU do + gMRUstr[lInc] := ''; + + (*if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + case MessageDlg('Shift key down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrNo: ReadIniFile; + end; //case + + end else*) + + if ResetDefaults then + DrawMenu.Visible := ToolPanel.visible + else + ReadIniFile; + + SetIniMenus; + UpdateMRU; + DefaultControlPanel; + OverlaySmoothMenuClick(nil); + LUTDrop.OnSelect(nil); + ZoomDrop.OnSelect(nil); + CreateShareMem; + if YokeMenu.checked then YokeTimer.enabled := true; + //gBGIMg.SaveDefaultIni := true; +end; + +function ImgIntensity(var lHdr: TMRIcroHdr; lPos: integer): single; overload; +var + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + + result := 0; + if (lPos > lHdr.ImgBufferItems) or (lPos < 1) then exit; + if (lHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(lHdr.ImgBuffer ); + result := l32Buf^[lPos]; + end else if (lHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(lHdr.ImgBuffer ); + result := l16Buf^[lPos]; + end else if lHdr.ImgBufferBPP = 1 then + result := lHdr.ImgBuffer^[lPos] + else begin + showmessage('Unknown Image Buffer Bytes Per Pixel: '+inttostr(lHdr.ImgBufferBPP)+' '+lHdr.HdrFileName); + exit; + end; + result := Raw2ScaledIntensity (lHdr,result); +end; + +function ImgIntensity(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): single; overload; +var + lPos: integer; +begin + lPos := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + result := ImgIntensity(lHdr,lPos); +end; + +function TImgForm.ImgIntensityString(var lHdr: TMRIcroHdr; lVox: integer): string; overload; +var + lV: integer; +begin + if (lVox > lHdr.ImgBufferItems) or (lVox < 1) then exit; + if lHdr.UsesLabels then begin + lV := round(ImgIntensity(lHdr,lVox)); + if lV <= High(gBGImg.LabelRA) then + result := gBGImg.LabelRA[lV]; + exit; + end; + if (not lHdr.UsesCustomPalette) or (lHdr.NIFTIhdr.datatype = kDT_RGB) then begin + result := realtostr(ImgIntensity(lHdr,lVox),gBGImg.SigDig); + exit; + end; +end; + +function TImgForm.ImgIntensityString(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): string; overload; +var + lVox: integer; +begin + lVox := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + result := ImgIntensityString(lHdr,lVox); +end; + +procedure TImgForm.UpdateStatusLabel; +var + lX,lY,lZ,lOverlay,lLen: integer; + lXmm,lYmm,lZmm: single; + lIntenStr : string; +begin + + lX := XviewEdit.value; + lY := YviewEdit.value; + lZ := ZviewEdit.value; + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + + lIntenStr := ''; +//StatusLabel.Caption := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0); +//lIntenStr := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr;; + +//StatusLabel.Caption := lIntenStr; +//StatusLabel.Caption := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr; +//crash! + for lOverlay := kBGOverlayNum to (kVOIOverlayNum-1) do + if gMRIcroOverlay[lOverlay].ImgBufferItems > 0 then + lIntenStr := lIntenStr + ImgIntensityString(gMRIcroOverlay[lOverlay],lX,lY,lZ)+', '; + lLen := length (lIntenstr); + if lLen > 2 then + lIntenStr[lLen-1] := ' '; + //StatusLabel.Caption := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr; + Caption :=realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr; + SetShareMem (lXmm,lYmm,lZmm); +end; + +procedure TImgForm.XViewEditChange(Sender: TObject); +begin + gBGImg.XViewCenter := XviewEdit.value; + gBGImg.YViewCenter := YviewEdit.value; + gBGImg.ZViewCenter := ZviewEdit.value; + RefreshImagesTimer.Enabled := true; + //UpdateStatusLabel; //caused crash! - only with refreshimagestimes +end; + + {$IFNDEF FPC} +procedure TImgForm.FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} +procedure TImgForm.FormClose(Sender: TObject); + {$ENDIF} +begin + + WriteIniFile; + CloseImagesClick(nil); + FreeFX8(gDrawImg); + FreeFX8(gUndoImg); +end; + +procedure TImgForm.MagnifyTimerTimer(Sender: TObject); + {$IFDEF FPC} + begin +// MagnifyTimer.Enabled := false; + end; + {$ELSE} + var + Srect,Drect,PosForme,ImgForme:TRect; + lZoomSlider,iWidth,iHeight,DmX,DmY:Integer; + iTmpX,iTmpY:Real; + C:TCanvas; + hDesktop: Hwnd; + Kursor:TPoint; +begin + + MagnifyTimer.Enabled := false; + lZoomSlider := 2; + If not IsIconic(Application.Handle) then begin + hDesktop:= GetDesktopWindow; + GetCursorPos(Kursor); + ImgForme := Rect(ImgForm.Left+ImgForm.TriplePanel.Left,ImgForm.Top+ImgForm.TriplePanel.Top,ImgForm.Left+ImgForm.Width,ImgForm.Top+ImgForm.Height); + PosForme:=Rect(MagnifyPanel.Left,MagnifyPanel.Top,MagnifyPanel.Left+MagnifyPanel.Width,MagnifyPanel.Top+MagnifyPanel.Height); + if true then begin + iWidth:=MagnifyImage.Width; + iHeight:=MagnifyImage.Height; + if iHeight < 6 then exit; + Drect:=Rect(0,0,iWidth,iHeight); + iTmpX:=iWidth / (lZoomSlider*4);//(Slider.Position * 4); + iTmpY:=iHeight / (lZoomSlider*4);//(Slider.Position * 4); + Srect:=Rect(Kursor.x,Kursor.y,Kursor.x,Kursor.y); + InflateRect(Srect,Round(iTmpX),Round(iTmpY)); + If Srect.Left<0 then OffsetRect(Srect,-Srect.Left,0); + If Srect.Top<0 then OffsetRect(Srect,0,-Srect.Top); + If Srect.Right>Screen.Width then OffsetRect(Srect,-(Srect.Right-Screen.Width),0); + If Srect.Bottom>Screen.Height then OffsetRect(Srect,0,-(Srect.Bottom-Screen.Height)); + C:=TCanvas.Create; + try + C.Handle:=GetDC(GetDesktopWindow); + SetStretchBltMode(C.Handle,COLORONCOLOR); + //SetStretchBltMode(C.Handle, STRETCH_DELETESCANS); + //SetStretchBltMode(C.Handle,{BILINEAR}TransparencyEdit.value); + MagnifyImage.Canvas.CopyRect(Drect,C,Srect); + finally + ReleaseDC(hDesktop, C.Handle); + C.Free; + end; + If True then begin // show crosshair + MagnifyImage.Canvas.Pen.Color := gBGIMg.XBarClr; + with MagnifyImage.Canvas do begin + DmX:=lZoomSlider * 2 * (Kursor.X-Srect.Left); + DmY:=lZoomSlider * 2 * (Kursor.Y-Srect.Top); + MoveTo(1,DmY); // - + LineTo(iWidth,DmY); // - + MoveTo(DmX,1); // | + LineTo(DmX,iHeight); // | + end; // with MagnifyImage.Canvas + end; // show crosshair + Application.ProcessMessages; + end // Cursor not inside form + end; // IsIconic +end; //magnify image + {$ENDIF} + +procedure TImgForm.MagnifyPanelResize(Sender: TObject); +begin +(* MagnifyImage.Picture:=nil; + if MagnifyPanel.Width < MagnifyPanel.Constraints.MinWidth then + MagnifyPanel.Width := MagnifyPanel.Constraints.MinWidth; + *) +end; //Proc MagnifyPanelResize + +procedure SelectPanel (lPanelNumber: integer); +begin +gSelectedImageNum := lPanelNumber; +end; //Proc SelectPanel + +procedure ShowFocusRect(lInRect: TRect); +var LImage: TImage; +begin + lImage := SelectedImage; + lImage.Canvas.DrawFocusRect(lInRect); +end; //proc ShowFocusRect + +procedure XYscrn2Img (lImage: TIMage;lPanel,lXinRaw,lYinRaw: integer; var lXout,lYOut,lZOut: integer); +var + lYin,lXin,lZoom : integer; + lOffset: single; +begin + //amx - must match XYscrn2Img and DrawXBar - e.g. +0.5 for middle of zoomed slice + lZoom := ImageZoomPct(lImage); + if lZoom = 0 then lZoom := 100; + if lZoom > 100 then lOffset := 0.5 else + lOffset := 0; + lXIn := lXinRaw + 1; //index from 0 + lYin := lImage.Height-lYinRaw; + case lPanel of + 2: begin + if gBGImg.FlipSag then + lXin := lImage.Width-lXinRaw; + lXOut := ImgForm.XViewEdit.value; + lYOut := round((lXin*100) / lZoom +lOffset); + lZOut := round((lYin*100) / lZoom +lOffset); + end; + 3: begin + lXOut := round((lXin*100) / lZoom +lOffset); + lYOut := ImgForm.YViewEdit.value; + lZOut := round((lYin*100) / lZoom +lOffset); + + end; + else begin + if gBGImg.FlipAx then + lYin := lYinRaw; + lXOut := round((lXin*100) / lZoom +lOffset); + lYOut := round((lYin*100) / lZoom +lOffset); + lZOut := ImgForm.ZViewEdit.value; + end; //else + end;//case lPanel + //ImgForm.Caption := inttostr(lXOut)+' '+inttostr(lYOut)+' '+Inttostr(lZOut); +end; //proc XYscrn2Img + +procedure AdjustContrastRectangle (lImage: TImage); +var + lXpos,lYPos,lXOut,lYOut,lZOut,lPanel,lLayer: integer; + lMinInten,lMaxInten,lVal: single; +begin + lPanel := SelectedImageNum; + lLayer := ActiveLayer; + XYscrn2Img (lImage,lPanel,gSelectRect.Left,gSelectRect.Top, lXout,lYOut,lZOut); + lMinInten := ImgIntensity(gMRIcroOverlay[lLayer],lXout,lYOut,lZOut); + lMaxInten := lMinInten; + for lYpos := gSelectRect.Top to gSelectRect.Bottom do begin + for lXpos := gSelectRect.Left to gSelectRect.Right do begin + XYscrn2Img (lImage,lPanel,lXpos,lYPos, lXout,lYOut,lZOut); + // lVox := lXout + ((lYout-1)*gBGImg.ScrnDim[1])+((lZout-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + // lVal := ImgIntensity(gMRIcroOverlay[lLayer],lVox); + lVal:= ImgIntensity(gMRIcroOverlay[lLayer],lXout,lYOut,lZOut); + if lVal < lMinInten then lMinInten := lVal; + + if lVal > lMaxInten then lMaxInten := lVal; + end; //for PGX each column + end; //for PGY2 - each row + //ImgForm.StatusLabel.caption := (RealToStr(lMinInten,4))+'..'+({x} RealToStr(lMaxInten,4))+'bexx'+ inttostr(lXout)+'x'+inttostr(lYOut)+'x'+inttostr(lZOut)+' '+inttostr(ActiveLayer); + + // ImgForm.StatusLabel.caption := 'bexx'+ inttostr(gSelectRect.Top)+'..'+inttostr(gSelectRect.Bottom)+' -> '+inttostr(gSelectRect.Left)+'..'+inttostr(gSelectRect.Right); + ImgForm.StatusLabel.caption := 'Intensity range '+(RealToStr(lMinInten,4))+'..'+({x} RealToStr(lMaxInten,4)); + if lMinInten = lMaxInten then exit; //no range + ImgForm.MinWindowEdit.value := lMinInten; + ImgForm.MaxWindowEdit.value := lMaxInten; + {$IFDEF FPC} ImgForm.MinContrastWindowEditChange(nil); {$ENDIF} +end; + +procedure sortLTRB(var lXoutLow,lYOutLow,lXoutHi,lYOutHi: integer); //left<right, top<bottom +var lXin1,lYin1,lXin2,lYin2: integer; +begin + lXin1 := lXoutLow; + lYin1 := lYOutLow; + lXin2 := lXoutHi; + lYin2 := lYOutHi; + if lXIn1 < lXin2 then begin + lXoutLow := lXIn1; + lXOutHi := lXIn2; + end else begin + lXoutLow := lXIn2; + lXOutHi := lXIn1; + end; + if lYIn1 < lYin2 then begin + lYoutLow := lYIn1; + lYOutHi := lYIn2; + end else begin + lYoutLow := lYIn2; + lYOutHi := lYIn1; + end; +end; //sortLTRB + +procedure DrawEllipse (lImage: TImage;lRect: TRect; lShift: TShiftState; lPanel: integer); +var + i: integer; +begin + ScaleBMP2Draw(gBGImg.VOIInvZoom, lRect.Left,lRect.Top,lPanel,Limage); + ScaleBMP2Draw(gBGImg.VOIInvZoom, lRect.Right,lRect.Bottom,lPanel,lImage); + if ssShift in lShift then + i := 0 + else + i := kVOI8bit; + if (ssCtrl in lShift) then + FillRectFX8(gDrawImg,lRect.Left,lRect.Top,lRect.Right,lRect.Bottom,i) + else + FillEllipseFX8(gDrawImg,lRect.Left,lRect.Top,lRect.Right,lRect.Bottom,i); +end; //DrawEllipse + + +procedure TImgForm.PGImageMouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer); +var lZoom,lPanel,lX, lY,lXout,lYOut,lZOut,lBasePenThick,lX2, lY2: integer; + lImage: TImage; +begin + //ImgForm.GetFocus := true; + gSelectOrigin.X := -1; + + lX := X; lY := Y; + lImage := Sender as TImage; + if lImage.Name = PGImageCor.Name {'PGImageCor'} then lPanel := kCoroView0 + else if lImage.Name = PGImageSag.Name {'PGImageSag'} then lPanel := kSagView0 + else lPanel := kAxView0; + + + //lImage.Canvas.Pen.Width := 1; + // lImage.Canvas.Pen.Color :=gBGImg.VOIClr; + SelectPanel(lPanel); + gBGImg.VOIInvZoom := ComputeInvZoomShl10(lPanel,lImage); + if DrawToolSelected then begin //paint tool + WriteUndoVOI(lPanel,false); + if (ssShift in Shift) then begin //erase + lImage.Canvas.Brush.Color:=clBlack; + lImage.Canvas.Pen.Color := clBlack; + end else begin + lImage.Canvas.Brush.Color:=gBGImg.VOIClr; + lImage.Canvas.Pen.Color := gBGImg.VOIClr; + end; + if gBGImg.ThinPen then + lBasePenThick := 1 + else begin //adjust pen thickness for zoom level + if gBGImg.ZoomPct < 100 then begin + lZoom := ComputeZoomPct(lPanel,lImage); + if lZoom = 100 then + lBasePenThick := 1 + else + lBasePenThick := round((ComputeZoomPct(lPanel,lImage)+50) / 100); + end else if gBGImg.ZoomPct > 100 then + lBasePenThick := gBGImg.ZoomPct div 100 + else + lBasePenThick := 1; + end; //if not thinpen + if (ssCtrl in Shift) then begin + lImage.Canvas.Pen.Width := lBasePenThick*3; + gDrawImg.PenThick := 3; + end else begin + lImage.Canvas.Pen.Width := lBasePenThick; + gDrawImg.PenThick := 1; + end; + end; //paint tool selected + //lImage.Canvas.Pen.Width := 1;//abba + if (FillBtn.Down) and (ssCtrl in Shift) then begin //3D fill + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + XViewEdit.value := lXOut; + YViewEdit.value := lYOut; + ZViewEdit.value := lZOut; + if (ssShift in Shift) then //erase + ROICluster(gBGImg.ScrnDim[1], gBGImg.ScrnDim[2], gBGImg.ScrnDim[3],XViewEdit.value,YViewEdit.value,ZViewEdit.value,true) + else //draw + ROICluster(gBGImg.ScrnDim[1], gBGImg.ScrnDim[2], gBGImg.ScrnDim[3],XViewEdit.value,YViewEdit.value,ZViewEdit.value,false); + exit; + end; //end 3D fill + if (not PenBtn.Down) and (not ClosedPenBtn.Down) and (not FillBtn.Down) then begin + if (EllipseBtn.Down) or (ssRight in Shift) then begin + lImage.Canvas.Brush.Color:=gBGImg.VOIClr; + //lImage.Canvas.Pen.Color :=gBGImg.VOIClr; + ScaleScrn2BMP(lX,lY, lImage); + gSelectRect.Left := lX; + gSelectRect.Top := lY; + gSelectRect.Right := lX; + gSelectRect.Bottom := lY; + ShowFocusRect(gSelectRect); + gSelectOrigin.X := gSelectRect.Left; + gSelectOrigin.Y := gSelectRect.Top; + exit; + end; + //next no paint tools selected - show position where click occurred + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + XViewEdit.value := lXOut; + YViewEdit.value := lYOut; + ZViewEdit.value := lZOut; + //showmessage(floattostr(lXOut)+'x'+floattostr(lYOut)+'x'+floattostr(lZOut)); + //ImgCoordToMM(lXOut,lYOut,lZOut,lXmm,lYmm,lZmm); + //showmessage(floattostr(lXmm)+'x'+floattostr(lYmm)+'x'+floattostr(lZmm)); + + //showmessage(floattostr(gBGImg.ScrnOri[1])+'x'+floattostr(gBGImg.ScrnOri[2])+'x'+floattostr(gBGImg.ScrnOri[3])); + //MMToImgCoord(lXOut,lYOut,lZOut,lXmm,lYmm,lZmm); + //showmessage(floattostr(lXOut)+'x'+floattostr(lYOut)+'x'+floattostr(lZOut)); + + //SetShareMem (lXmm,lYmm,lZmm); + + {$IFDEF FPC} + XViewEditChange(nil); + {$ENDIF} + exit; + end; + ScaleScrn2BMP(lX,lY, lImage); + lImage.Canvas.MoveTo(lX,lY); + + lX2 := X; lY2 := Y; + ScaleBMP2Draw(gBGImg.VOIInvZoom, lX2,lY2,lPanel,lImage); + if (FillBtn.Down) or(ssRight in Shift) then begin + + if (ssShift in Shift) then + FloodFillFX8 (gDrawImg, lX2,lY2,kVOI8bit,0,true) + //FloodFillX(DrawImg2,lX2-1,lY2-1,gBGImg.VOIClr, fsSurface) + else + FloodFillFX8 (gDrawImg, lX2,lY2,kVOI8bit,kVOI8bit,false); + //FloodFillX(DrawImg2,lX2-1,lY2-1,gBGImg.VOIClr, fsBorder); + + exit; + end; + //ImgForm.caption := inttostr(lX2); + MoveToFX8(gDrawImg,lX2,lY2); + if lImage.Canvas.Pen.Color = clBlack then //ensure single pixel is drawn if user clicks without dragging + LineToFX8(gDrawImg,lX2,lY2,0) + else + LineToFX8(gDrawImg,lX2,lY2,kVOI8bit); + gMouseDownX := lX; + gMouseDownY := lY; + +end; //PGImageMouseDown + +var + gDragX,gDragY,gDragZ : integer; + //gDragRefresh : boolean = false; //only redraw one snapshot at a time + +procedure TImgForm.PGImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); +var lX, lY,lPanel,lXOut,lYOut,lZOut: integer; + lImage: TImage; +begin + lImage := Sender as TImage; + lX := X; lY := Y; + ScaleScrn2BMP(lX,lY,lImage); + //if MagnifyImage.Height > 10 then + // MagnifyTimer.Enabled := true;//MagnifyBtn.Down; + //StatusLabel.Caption := inttostr(lX)+','+inttostr(lY); + + if {(ssShift in Shift) and} (gSelectOrigin.X > 0) then begin + ShowFocusRect(gSelectRect); + gSelectRect.Left := gSelectOrigin.X; + gSelectRect.Top := gSelectOrigin.Y; + gSelectRect.Right := lX; + gSelectRect.Bottom := lY; + sortLTRB(gSelectRect.Left,gSelectRect.Top,gSelectRect.Right,gSelectRect.Bottom); + ShowFocusRect(gSelectRect); + exit; + end; + if lImage.Name = PGImageCor.Name then lPanel := kCoroView0 + else if lImage.Name = PGImageSag.Name then lPanel := kSagView0 + else lPanel := kAxView0; + if (not DrawToolSelected) and ((ssLeft in Shift)) then begin + //RefreshImagesTimer.Enabled := false; + //gDragRefresh := true; + + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + if (lXout = gDragX) and (lYout = gDragY) and (lZOut = gDragZ) then + exit;//no change + XViewEdit.value := lXOut; + YViewEdit.value := lYOut; + ZViewEdit.value := lZOut; + + {$IFDEF FPC}XViewEditChange(nil);{$ENDIF} //can generate crash! + //gDragRefresh := false; + exit; + end; + + if (not (ssLeft in Shift)) or (gMouseDownX < 0) then exit; + if PenBtn.Down or ClosedPenBtn.Down then begin + lImage.Canvas.LineTo(lX,lY); + lX := X; lY := Y; + ScaleBMP2Draw(gBGImg.VOIInvZoom, lX,lY,lPanel,lImage); + //DrawImg2.Canvas.LineTo(lX,lY); + if lImage.Canvas.Pen.Color = clBlack then + LineToFX8(gDrawImg,lX,lY,0)//zzzxx + else + LineToFX8(gDrawImg,lX,lY,kVOI8bit);//zzzxx + end; +end; //PGImageMouseMove + +(*procedure Scrn2VOI (var lImage: TImage; lXvoi,lYvoi: integer; var lVOIBuffer: ByteP); + +const + kSh = 10; //bits to shift +var + lInc,lXpos,lYPos,lVOISliceSz: integer; + srcBmp : TBitmap; +begin + srcBmp := lImage.Picture.Bitmap; + lVOISliceSz := lXvoi*lYvoi; + GetMem (lVOIBuffer , lVOISliceSz); + lInc := 0; + for lYpos:=(lYvoi-1) downto 0 do begin + for lXpos:=0 to lXvoi-1 do begin + inc(lInc); //zax + if srcBmp.Canvas.Pixels[lXpos,lYPos] = clBlack then + lVOIBuffer^[lInc] := 0 + else + lVOIBuffer^[lInc] := 100; + end; + end; +end; //Scrn2VOI *) + + +procedure ReadCorVOI (var lImage: TFX8; lSlice: integer); +var lX,lY,lZ,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lXPos: integer; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lYOffset := (lX) * (round(lSlice)-1); + lXYSliceSz := (lX*lY); + //Scrn2VOI (lImage,lX,lZ, lInBuff); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lZOffset+lYOffset+lXPos] :=lImage.Img^[lPixel]; + end; //for each Y + end; //for each Z +end; + +procedure ReadSagVOI (var lImage: TFX8;lSlice: integer); +var lX,lY,lZ,lXOffset,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lYPos: integer; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lXYSliceSz := lX*lY; + lXOffset := round(lSlice); + // dec(lXOffset);//999+8 + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lZOffset+lYOffset+lXOffset] := lImage.Img^[lPixel]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z + //freemem(lInBuff); +end; + +procedure ReadAxialVOI (var lImage: TFX8;lSlice: integer); +var lX,lY,lSliceOffset,lSliceSz: integer; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lSliceSz := lX*lY; + lSliceOffset := (lSlice-1)*lX*lY; + //Scrn2VOI (lImage,lX,lY, lInBuff); + for lX := 1 to lSliceSz do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lSliceOffset+lX] := lImage.Img^[lX]; + +end; + +procedure ReadScrnVOI (lImage: TImage); +var + lView: integer; +begin + if (gBGImg.VOIUndoSlice < 1) or (gBGImg.VOIUndoOrient < 1) or (gBGImg.VOIUndoOrient > 3) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (lImage.Picture.Bitmap.Width < 1) or (lImage.Picture.Bitmap.Height < 1) then + exit; + EnsureVOIOpen; + lView := SelectedImageNum; + case lView of + 3: ReadCorVOI(gDrawImg,ImgForm.YViewEdit.Value); + 2: ReadSagVOI(gDrawImg,ImgForm.XViewEdit.Value); + 1: ReadAxialVOI(gDrawImg,ImgForm.ZViewEdit.Value); + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.PGImageMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var lX, lY,lPanel: integer; +lImage: TImage; +begin + lPanel := SelectedImageNum; + lImage := Sender as TImage; + lX := X; lY := Y; + ScaleScrn2BMP(lX,lY,lImage); + if (gSelectOrigin.X > 0) then begin + sortLTRB(gSelectRect.Left,gSelectRect.Top,gSelectRect.Right,gSelectRect.Bottom); + ShowFocusRect(gSelectRect); + gSelectOrigin.X := -1; + if (EllipseBtn.Down) then + DrawEllipse(Limage,gSelectRect,Shift,lPanel) + else begin + AdjustContrastRectangle(lImage); + exit; + end; + end; + + if ((PenBtn.Down) or (ClosedPenBtn.Down)) and (gMouseDownX > 0) then begin + ScaleBMP2Draw(gBGImg.VOIInvZoom, gMouseDownX,gMouseDownY,lPanel,lImage); + //next: draw single pxiel if user clicks on image without moving the mouse + //DrawImg2.Canvas.Pixels[gMouseDownX,gMouseDownY] := DrawImg2.Canvas.Pen.Color; + if (ClosedPenBtn.Down) then begin + if lImage.Canvas.Pen.Color = clBlack then + LineToFX8(gDrawImg,gMouseDownX,gMouseDownY,0) + else + LineToFX8(gDrawImg,gMouseDownX,gMouseDownY,kVOI8Bit); + end; + end; + + gMouseDownX := -1; //disable draws + //if DrawToolSelected then + if DrawToolSelected and (not (ssAlt in Shift)) then + ReadScrnVOI (lImage); +end; //PGImageMouseUp + + +procedure TImgForm.FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +begin + Case SelectedImageNum of + 3: DecViewEdit(YViewEdit); + 2: DecViewEdit(XViewEdit); + else DecViewEdit(ZViewEdit); + end; +end; + +procedure TImgForm.FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +begin + Case SelectedImageNum of + 3: IncViewEdit(YViewEdit); + 2: IncViewEdit(XViewEdit); + else IncViewEdit(ZViewEdit); + end; +end; + +procedure TImgForm.ZoomDropSelect(Sender: TObject); +begin + gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.ColorBarBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + var lLTRB,lLayer: integer; + lImage: TImage; +begin + + if (ssAlt in Shift) then begin + //lImage := SelectedImage; + lLayer := ActiveLayer; + DrawHistogram(gMRIcroOverlay[lLayer],HistogramForm.HistoImage{lImage}); + HistogramForm.Caption := 'Histogram: '+extractfilename(gMRIcroOverlay[lLayer].HdrFileName); + HistogramForm.show; + if (ssCtrl in Shift) then + TextReportHisto(gMRIcroOverlay[lLayer]); + exit; + end; + lLTRB := 1; + if (ssRight in Shift) then + lLTRB := lLTRB + 1; + if (ssCtrl in Shift) then + lLTRB := lLTRB + 2; + lImage := SelectedImage; + //Caption := inttostr(random(888)); + intenBar(lImage,gMRIcroOverlay[ActiveLayer],lLTRB,0,0); +end; + + + + + +procedure TImgForm.XBarBtnClick(Sender: TObject); +begin + gBGImg.XBarVisible := XBarBtn.Down; + RefreshImagesTimer.Enabled := true; +end; + +procedure RepositionOrigin; +begin + gBGImg.ScrnOri[1] := ImgForm.XviewEdit.value; + gBGImg.ScrnOri[2] := ImgForm.YviewEdit.value; + gBGImg.ScrnOri[3] := ImgForm.ZviewEdit.value; +end; + +procedure TImgForm.XBarBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + +end; + +procedure TImgForm.XBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +label 555; +begin + if not (ssRight in shift) then exit; + if (ssShift in Shift) then begin + RepositionOrigin; + goto 555; + end; + if (ssAlt in Shift) and (ssCtrl in Shift) then begin + inc(gBGImg.FontSize,2); + if gBGImg.FontSize > 24 then + gBGImg.FontSize := 8; + goto 555; + end; + if (ssAlt in Shift) then begin + inc(gBGImg.XBarThick,2); + if gBGImg.XBarThick > 10 then + gBGImg.XBarThick := 1; + goto 555; + end; + if (ssCtrl in Shift) then begin + ColorDialog1.Color := gBGImg.XBarClr; + if not ColorDialog1.Execute then exit; + gBGImg.XBarClr := ColorDialog1.Color; + goto 555; + end; + inc(gBGImg.XBarGap); + if gBGImg.XBarGap > 10 then + gBGImg.XBarGap := 0; +555: + RefreshImagesTimer.Enabled := true; + if MultiSliceForm.Visible then + MultiSliceForm.CreateMultiSlice; +end; //XBarBtnMouseDown + + + +procedure TImgForm.RefreshImagesTimerTimer(Sender: TObject); +begin + RefreshImagesTimer.Enabled := false; + RefreshImages; + UpdateStatusLabel; + + +end; + +procedure TImgForm.ImgPanelClick(Sender: TObject); +begin + SelectPanel((Sender as TScrollBox).tag); +end; + +procedure TImgForm.MagnifyMenuItemClick(Sender: TObject); +begin + (*if MagnifyPanel.Height < 20 then //Height constrained by Y + MagnifyPanel.Height := 128 + else + MagnifyPanel.Height := MagnifyPanel.Constraints.MinHeight; *) +end; + +procedure TImgForm.CloseImagesClick(Sender: TObject); +var + lC: integer; +begin + CloseVOIClick(nil); + FreeUndoVol; + for lC := 0 to knMaxOverlay do //background, all overlays, VOI + FreeImgMemory(gMRIcroOverlay[lC]); + gBGImg.VOIUndoSlice := 0; + + //next- set layers menu + LayerDrop.Items.Clear; + LayerDrop.Items.Add('Background'); + {$IFNDEF FPC} + LayerDrop.SetItemIndex(0); + {$ELSE} + LayerDrop.ItemIndex :=(0); + {$ENDIF} + LayerDropSelect(nil); +end; + +procedure TImgForm.OverlayOpenCore (var lFilename: string; lOverlayNum: integer); +begin + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lOverlayNum]) then exit; + //if not OpenImg(gBGImg,gMRIcroOverlay[lOverlayNum],false,false,false) then exit; + //if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + // if not OpenImg(gBGImg,gMRIcroOverlay[lOverlayNum],false,false,false,not gBGImg.ResliceOnLoad,false) then exit; + //end else + if not OpenImg(gBGImg,gMRIcroOverlay[lOverlayNum],false,false,false,gBGImg.ResliceOnLoad,false) then exit; + ImgForm.UpdateLayerMenu; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LoadOverlay (lFilename: string); +var +lOverlay,lC: integer; +begin + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + OverlayOpenCore ( lFilename, lOverlay); +end; + +procedure TImgForm.LoadOverlayIncludingRGB (lFilename: string); +var +lOverlay,lC: integer; +begin + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + OverlayOpenCore ( lFilename, lOverlay); + if (gMRIcroOverlay[lOverlay].NIFTIhdr.datatype = kDT_RGB) then begin + OverlayOpenCore ( lFilename, lOverlay+1); + OverlayOpenCore ( lFilename, lOverlay+2); + OverlayAdditive.click; + end; +end; + +procedure TImgForm.BrainMask1Click(Sender: TObject); +var + lInc: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + //lImgSamples := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + for lInc := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc] <> 0 then + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc] := 1; + SaveAsVOIorNIFTI(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems,1,1,true,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end; + +procedure TImgForm.ControlPanelDragDrop(Sender, Source: TObject; X, Y: Integer); +begin + +end; + +(*procedure DescribeVOIonLabelsz (lOverlayNum: integer; lShowFilename: boolean); +var + lLocalMax,lLocalSum : HistoDoubleRA; + l16Buf : SmallIntP; + l32Buf : SingleP; + l8Buf: byteP; + lInten: double; + lXmm,lYmm,lZmm: single; + lHisto,lRegionVol,lLocalMaxPos: HistoRA; + lInc,lRegion: Integer; + lLabelStr: string; + lVOI: boolean; + lLabelStr20 : Array[0..kHistoBins] of kstr20; +begin + lInten := 0;//just to hide compiler hint... + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) and ('ratlas.nii.gz' = (extractfilename( gMRIcroOverlay[kBGOverlayNum].HdrFileName))) then begin + // specific for PCDescribeVOIonLabelsRAT(lOverlayNum,lShowFilename); + exit; + end; + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) or (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP <> 1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 2) then + exit; + TextForm.MemoT.Lines.add(' Custom Region Analysis'); + TextForm.MemoT.Lines.add(' For Speculative Brodmann Map: 0=not cortical and 48=no Brodmann label'); + lVOI := IsVOIROIExt(gMRIcroOverlay[lOverlayNum].HdrFileName); + if (not lVOI) and (lOverlayNum = kVOIOverlayNum) then + lVOI := true; + //next describe format + if lShowfilename then + lLabelStr := ' Filename,' + else + lLabelStr := ' '; + if lVOI then //intensity min/max position are not important + TextForm.MemoT.Lines.add(lLabelStr+'Area'+kTextSep+'N>0'+kTextSep+'%N>0') + else + TextForm.MemoT.Lines.add(lLabelStr+'Area'+kTextSep+'N>0'+kTextSep+'%N>0'+kTextSep+'Sum>0'+kTextSep+'Mean>0'+kTextSep+'Max'+kTextSep+'MaxX'+kTextSep+'MaxY'+kTextSep+'MaxZ'); + //next initialize + if lShowFilename then + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName+kTextSep + else + lLabelStr := ''; + for lInc := 0 to kHistoBins do begin + lHisto[lInc] := 0; + lLocalMax[lInc] := 0; + lLocalSum[lInc] := 0; + lRegionVol[lInc] := 0; + if (gMRIcroOverlay[kBGOverlayNum].UsesCustomPalette) then + lLabelStr20[lInc] := gBGImg.LabelStr20[lInc] + else + lLabelStr20[lInc] := inttostr(lInc); + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + inc(lHisto[gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc]]); + //local max start + l32Buf := SingleP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + l16Buf := SmallIntP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + //NEXT if..else July07 - ROIs only use screen buffer, not imgbuffer... + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[lOverlayNum].ImgBufferItems then + l8Buf := gMRIcroOverlay[lOverlayNum].ImgBuffer + else + l8Buf := gMRIcroOverlay[lOverlayNum].ScrnBuffer; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if (gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 4) then + lInten := l32Buf^[lInc] + else if (gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 2) then + lInten := l16Buf^[lInc] + else if gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 1 then + lInten := l8Buf^[lInc];//July07 + lRegion := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc]; + if lInten > 0 then + lLocalSum[lRegion] := lLocalSum[lRegion]+lInten; + if lInten > lLocalMax[lRegion] then begin + lLocalMax[lRegion] := lInten;//intensity + lLocalMaxPos[lRegion] := lInc;//location + end; + inc(lRegionVol[lRegion]); + end; + for lInc := 0 to kHistoBins do begin + if (not lVOI) and (lLocalMax[lInc] > 0) then begin + lLocalMax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[lOverlayNum],lLocalMax[lInc]); + lLocalSum[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[lOverlayNum],lLocalSum[lInc]); + ImgPosToMM(lLocalMaxPos[lInc], lXmm,lYmm,lZmm); + TextForm.MemoT.Lines.Add(lLabelStr+ lLabelStr20[lInc] + kTextSep + inttostr(lHisto[lInc])+kTextSep+floattostr( lHisto[lInc]/lRegionVol[lInc]) + +kTextSep+floattostr( lLocalSum[lInc])+kTextSep+floattostr( lLocalSum[lInc]/lRegionVol[lInc]) //Sum>0, mean>0 + +kTextSep + floattostr(lLocalMax[lInc])+kTextSep+floattostr(lXmm)+kTextSep+floattostr(lYmm)+kTextSep+floattostr(lZmm) ); + end else if (lHisto[lInc] > 0) {necessarily also and (lRegionVol[lInc] > 0)} then + TextForm.MemoT.Lines.Add(lLabelStr+ lLabelStr20[lInc] +kTextSep+ inttostr(lHisto[lInc])+kTextSep+floattostr( lHisto[lInc]/lRegionVol[lInc])) ; + end; //for each row +end; *) +procedure DescribeVOIonLabels (lOverlayNum: integer; lShowFilename: boolean); +const + kT = kTextSep; + PositiveInfinityBits : Int64 = $7FF0000000000000; + NegativeInfinityBits : Int64 = $FFF0000000000000; +VAR + dPositiveInfinity : DOUBLE ABSOLUTE PositiveInfinityBits; + dNegativeInfinity : DOUBLE ABSOLUTE NegativeInfinityBits; +var + l16Buf : SmallIntP; + l32Buf : SingleP; + l8Buf: byteP; + type + TVxStat = RECORD //peristimulus plot + n, nNot0, minPos,maxPos: integer; + sum,sumNot0,min,max: double; + end; +function clearVxStat: TVxStat; +begin + result.sum:=0; + result.sumNot0:= 0; + result.n:=0; + result.nNot0 := 0; + result.minPos:= 0; + result.maxPos:=0; + result.min := dPositiveInfinity; + result.max := dNegativeInfinity; +end; +function roiIntensity(var lHdr: TMRIcroHdr; lPos: integer): integer; +var + l16Buf : SmallIntP; +begin + if (lHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(lHdr.ImgBuffer ); + result := l16Buf^[lPos]; + end else + result := lHdr.ImgBuffer^[lPos]; +end; +function overlayIntensity(var lHdr: TMRIcroHdr; lPos: integer): single; + +begin + if (lHdr.ImgBufferBPP = 4) then begin + result := l32Buf^[lPos]; + end else if (lHdr.ImgBufferBPP = 2) then begin + result := l16Buf^[lPos]; + end else + result := l8Buf^[lPos]; +end; +procedure scaleIntensity(var valn: double); +begin + valn := (valn * gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope)+gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_inter +end; +var + lROI,lVx: integer; + lStat: array of TVxStat; + lVal,loMax,hiMax: double; + lStartTime: DWord; + lBinaryOverlay: boolean; + lLabelStr,lStr: string; +begin + if (not gMRIcroOverlay[kBGOverlayNum].UsesLabels) or (High(gBGImg.LabelRA) < 1) then exit; + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP > 2) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 2) then exit; + //pointers to image data + l32Buf := SingleP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + l16Buf := SmallIntP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[lOverlayNum].ImgBufferItems then + l8Buf := gMRIcroOverlay[lOverlayNum].ImgBuffer + else + l8Buf := gMRIcroOverlay[lOverlayNum].ScrnBuffer; + + lStartTime := GetTickCount; + setlength(lStat, High(gBGImg.LabelRA)+1); + for lROI := 0 to High(gBGImg.LabelRA) do + lStat[lROI] := clearVxStat; + for lVx := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lROI :=roiIntensity(gMRIcroOverlay[kBGOverlayNum], lVx); + inc(lStat[lROI].n); + lVal := overlayIntensity(gMRIcroOverlay[lOverlayNum],lVx); + lStat[lROI].sum := lStat[lROI].sum+ lVal; + if lVal <> 0 then begin + lStat[lROI].sumNot0 := lStat[lROI].sumNot0+ lVal; + inc(lStat[lROI].nNot0); + end; + if lVal > lStat[lROI].max then + lStat[lROI].max := lVal; + if lVal < lStat[lROI].min then + lStat[lROI].min := lVal; + end; //for each voxel + //calibrate values with rescale slope/intercept, see if overlay has variablility + loMax := dPositiveInfinity; + hiMax := dNegativeInfinity; + if gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope = 0 then gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope := 1; + for lROI := 0 to High(gBGImg.LabelRA) do begin + if (lStat[lROI].nNot0 > 0) and (lStat[lROI].max > hiMax) then hiMax := lStat[lROI].max; + if (lStat[lROI].nNot0 > 0) and (lStat[lROI].min < loMax) then loMax := lStat[lROI].max; + scaleIntensity (lStat[lROI].max); + scaleIntensity (lStat[lROI].min); + scaleIntensity (lStat[lROI].sum); + scaleIntensity (lStat[lROI].sumNot0); + end; + lBinaryOverlay := (hiMax <= loMax); + if lShowFilename then begin + if gMRIcroOverlay[lOverlayNum].HdrFileName = '' then + lLabelStr := 'VOI'+kT + else + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName+kT; + end else + lLabelStr := ''; + TextForm.MemoT.Lines.add(lLabelStr+'Custom Region Analysis'); + //add header + lStr := 'Index'+kT+'Name'+kT+'numVox'+kT+'numVoxNotZero'+kT+'fracNotZero'; + if not lBinaryOverlay then + lStr := lStr+kT+'peak'+kT+'min'+kT+'mean'+kT+'meanNotZero'; + TextForm.MemoT.Lines.Add(lLabelStr+lStr); + //report values + for lROI := 0 to High(gBGImg.LabelRA) do begin + if (lStat[lROI].nNot0 > 0) then begin + lStr := inttostr(lROI)+kT+gBGImg.LabelRA[lROI] + +kT+inttostr(lStat[lROI].n)+kT+inttostr(lStat[lROI].nNot0)+kT+ realtoStr(lStat[lROI].nNot0/lStat[lROI].n,3); + if not lBinaryOverlay then + lStr := lStr+kT+floattostr(lStat[lROI].max)+kT+floattostr(lStat[lROI].min) + +kT+floattostr(lStat[lROI].sum/lStat[lROI].n) +kT+floattostr(lStat[lROI].sumNot0/lStat[lROI].nNot0); + TextForm.MemoT.Lines.Add(lLabelStr+lStr ); + end; + + end; +end; + +procedure ShowDescriptive (lOverlayNum: integer; lShowFilename: boolean); +var + lROIVol: array [1..3] of integer; + lInc: integer; + lCenterOfMass,lROISum,lROISumSqr,lROImin,lROImax:array [1..3] of double; + lCC,lVal,lSD,lROImean: double; + lLabelStr,lStr: string; +procedure AddVal( lRA: integer); +begin + inc(lROIVol[lRA]); + lROISum[lRA] := lROISum[lRA]+lVal; + lROISumSqr[lRA] := lROISumSqr[lRA] + sqr(lVal); + if lVal > lROImax[lRA] then + lROImax[lRA] := lVal; + if lVal < lROImin[lRA] then + lROImin[lRA] := lVal; +end; //proc AddVal +begin //proc ShowDescript + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + + if lShowFilename then + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName + else + lLabelStr := ''; + for lInc := 1 to 3 do begin + lROIVol[lInc] := 0; + lROISum[lInc] := 0; + lROISumSqr[lInc] := 0; + lROImin[lInc] := maxint; + lROImax[lInc] := -maxint; + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + //fx(lInc); + lVal := RawBGIntensity(lInc); + AddVal(1); + if lVal <> 0 then + AddVal(2); + if lVal > 0 then + AddVal(3); + end; //if VOI voxel + end; //for each voxel + //next - compute StDev + //compute descriptives for each set of values + if lOverlayNum = kVOIOverlayNum then + lStr := 'VOI notes ' + else + lStr := 'Overlay #'+inttostr(lOverlayNum); + if not lShowFilename then begin + TextForm.MemoT.Lines.Add(lStr+' '+gMRIcroOverlay[lOverlayNum].HdrFileName); + end; + //TextForm.Memo1.Lines.Add('CoM'); + if CenterOfMass (lOverlayNum, lCenterOfMass[1],lCenterOfMass[2],lCenterOfMass[3]) > 0 then + TextForm.MemoT.Lines.Add(' '+lLabelStr+' Center of mass XYZ '+RealToStr(lCenterOfMass[1],2)+'x'+RealToStr(lCenterOfMass[2],2)+'x'+RealToStr(lCenterOfMass[3],2)); + for lInc := 1 to 3 do begin + if lROIVol[lInc] > 1 then begin + lSD := (lROISumSqr[lInc] - ((Sqr(lROISum[lInc]))/lROIVol[lInc])); + if (lSD > 0) then + lSD := Sqrt ( lSD/(lROIVol[lInc]-1)) + else + lSD := 0; + end else + lSD := 0; + //next compute mean + if lROIVol[lInc] > 0 then begin + lROImean := lROISum[lInc]/lROIVol[lInc]; + //next - calibrate values + lROImin[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImin[lInc]); + lROIMean := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROIMean); + lROImax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImax[lInc]); + lSD := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lSD); + + end else begin //2/2008 + lROImin[lInc] := 0; + lROImax[lInc] := 0; + lROImean := 0; + end; + lcc := ((lROIVol[lInc]/1000)*gBGImg.ScrnMM[1]*gBGImg.ScrnMM[2]*gBGImg.ScrnMM[3]); + case lInc of + 3: lStr := 'VOI >0 '; + 2: lStr := 'VOI <>0 '; + else lStr := 'VOI '; + end; + lStr := lStr+' nvox(cc)=min/mean/max=SD: '+inttostr(round(lROIVol[lInc]))+kTextSep+RealToStr(lCC,2)+kTextSep+'='+kTextSep+RealToStr(lROIMin[lInc],4)+kTextSep+realToStr(lROIMean,4)+kTextSep+realToStr(lROIMax[lInc],4)+kTextSep+'='+kTextSep+realtostr(lSD,4); + TextForm.MemoT.Lines.Add(lLabelStr+ lStr); + end; + //June07 if (gMRIcroOverlay[kBGOverlayNum].UsesCustomPalette) or (lShowFilename) then + DescribeVOIonLabels(lOverlayNum,lShowfilename); + TextForm.MemoT.Lines.Add(''); + ImgForm.SaveDialog1.Filename := ExtractFileDirWithPathDelim(gMRIcroOverlay[lOverlayNum].HdrFileName)+'desc.csv'; +end; + + +procedure TImgForm.BatchROImean1Click(Sender: TObject); +var + lInc,lNumberofFiles: integer; + lFilename:string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + UpdateLayerMenu; + if not OpenDialogExecute(kImgFilter,'Select images you wish to analyze',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.MemoT.Lines.Clear; + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + OverlayOpenCore ( lFilename, 2); + ShowDescriptive(2,true); + //LayerDrop.SetItemIndex(LayerDrop.Items.Count-1); + //LayerDropSelect(nil); + end; + FreeImgMemory(gMRIcroOverlay[2]); + UpdateLayerMenu; + //SaveDialog1.Filename := ExtractFileDirWithPathDelim(HdrForm.OpenHdrDlg.Files[0])+'desc.csv'; + TextForm.Show; +end; + +procedure TImgForm.Batchprobmaps1Click(Sender: TObject); +begin + BatchVOI; +end; + +procedure TImgForm.Batchclusterprobmaps1Batchclusterprobmaps1ClickClick( + Sender: TObject); +begin + BatchCluster; +end; + +procedure TImgForm.GenerateSPM5maskslesions1Click(Sender: TObject); +begin + VOISmoothForm.SmoothVOI_SPM5masks; +end; + + +procedure TImgForm.OverlayOpenClick(Sender: TObject); +var + lFilename: string; + lOverlay,lInc: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + if not OpenDialogExecute(kImgFilter,'Select overlay image[s]',true) then exit; + if HdrForm.OpenHdrDlg.Files.Count < 1 then + exit; + for lInc := 1 to HdrForm.OpenHdrDlg.Files.Count do begin //vcx + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + LoadOverlayIncludingRGB{LoadOverlay}(lFilename); + LayerDrop.ItemIndex := (LayerDrop.Items.Count-1); + {$IFNDEF FPC} + LayerDrop.SetItemIndex(LayerDrop.Items.Count-1); + {$ELSE} + LayerDrop.ItemIndex :=(LayerDrop.Items.Count-1); + {$ENDIF} + end; + + +(* //HdrForm.OpenHdrDlg.Filter := kImgFilter; + // if not HdrForm.OpenHdrDlg.Execute then exit; + if not OpenDialogExecute(kImgFilter,'Select overlay image',false) then exit; + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + lFilename := HdrForm.OpenHdrDlg.Filename; + OverlayOpenCore ( lFilename, lOverlay); + *) + LayerDropSelect(nil); +end; //OverlayOpenClick + +procedure TImgForm.BGtrans100Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gBGImg.BGTransPct := (sender as TMenuItem).tag; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.OverlayTransClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gBGImg.OverlayTransPct := (sender as TMenuItem).tag; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LayerDropSelect(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + MaxWindowEdit.Value := gMRIcroOverlay[lLayer].WindowScaledMax; + MinWindowEdit.Value := gMRIcroOverlay[lLayer].WindowScaledMin; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then exit; + {$IFNDEF FPC} + LUTdrop.SetItemIndex(gMRIcroOverlay[lLayer].LUTindex); + {$ELSE} + LUTdrop.ItemIndex :=(gMRIcroOverlay[lLayer].LUTindex); + {$ENDIF} + //LUTinvertBtn.down := gMRIcroOverlay[lLayer].LUTinvert; + LutFromZeroBtn.down := gMRIcroOverlay[lLayer].LutFromZero; +end; + +procedure TImgForm.UpdateLayerMenu; +var + lStrings: TStringList; + lPos,lLayer:integer; +begin + lStrings := TStringList.Create; + lStrings.Add('Background'); + lLayer := 0; + for lPos := 1 to (knMaxOverlay-1) do //-1 as max overlay is VOI + if (gMRIcroOverlay[lPos].ImgBufferItems > 0) then begin + lStrings.Add(ParseFileName(ExtractFileName(gMRIcroOverlay[lPos].HdrFileName))); + inc(lLayer); + LUTdropLoad(lLayer); + end; + LayerDrop.Items := lStrings; + + {$IFNDEF FPC} + if LayerDrop.ItemIndex >= LayerDrop.Items.Count then + LayerDrop.SetItemIndex(LayerDrop.Items.Count-1); + {$ELSE} + if LayerDrop.ItemIndex >= LayerDrop.Items.Count then + LayerDrop.ItemIndex :=(LayerDrop.Items.Count-1); + {$ENDIF} + + LayerDropSelect(nil); + lStrings.Free; +end; + +procedure TImgForm.CloseOverlayImgClick(Sender: TObject); +var + lOverlay: integer; +begin + for lOverlay := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lOverlay]); + UpdateLayerMenu; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LUTdropLoad(var lLayer: integer); +var + lStr: string; +begin + (*if gMRIcroOverlay[lLayer].NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL then begin + createLutLabel (gMRIcroOverlay[lLayer], 1.0); + //RefreshImagesTimer.Enabled := true; + exit; + end; + if gMRIcroOverlay[lLayer].UsesCustomPaletteRandomRainbow then + exit; *) + if gMRIcroOverlay[lLayer].UsesCustomPalette then begin + exit; + end; + //gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + + if gMRIcroOverlay[lLayer].LUTindex < knAutoLUT then begin + LoadMonochromeLUT(gMRIcroOverlay[lLayer].LUTindex,gBGImg,gMRIcroOverlay[lLayer]); + RefreshImagesTimer.Enabled := true; + exit; + end; //if B&W lut + lStr := gColorSchemeDir+pathdelim+LUTdrop.Items.Strings[gMRIcroOverlay[lLayer].LUTindex]+'.lut'; + if not FileExistsEX(lStr) then + showmessage('Can not find '+lStr); + LoadColorScheme(lStr, gMRIcroOverlay[lLayer]); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LUTdropSelect(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + //gMRIcroOverlay[lLayer].LUTinvert := LUTinvertBtn.down; + //gMRIcroOverlay[lLayer].LutFromZero := LutFromZeroBtn.down; + LUTdropLoad(lLayer); + //RescaleImagesTimer.Enabled := true; +end; //proc LUTdropSelect + + + +procedure TImgForm.AutoContrastBtnClick(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + MinWindowEdit.Value := raw2ScaledIntensity(gMRIcroOverlay[lLayer], gMRIcroOverlay[lLayer].AutoBalMinUnscaled); + MaxWindowEdit.Value := raw2ScaledIntensity(gMRIcroOverlay[lLayer],gMRIcroOverlay[lLayer].AutoBalMaxUnscaled);{} + + gMRIcroOverlay[lLayer].WindowScaledMin := MinWindowEdit.Value; + gMRIcroOverlay[lLayer].WindowScaledMax := MaxWindowEdit.Value; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lLayer],lLayer); + + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.MinContrastWindowEditChange(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + //if gMRIcroOverlay[lLayer].WindowScaledMin = MinWindowEdit.Value then exit; + gMRIcroOverlay[lLayer].WindowScaledMin := MinWindowEdit.Value; + gMRIcroOverlay[lLayer].WindowScaledMax := MaxWindowEdit.Value; + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.MaxContrastWindowEditChange(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + if gMRIcroOverlay[lLayer].WindowScaledMax = MaxWindowEdit.Value then exit; + gMRIcroOverlay[lLayer].WindowScaledMax := MaxWindowEdit.Value; + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.OverlaySmoothMenuClick(Sender: TObject); +var + lC: integer; +begin + if Sender = nil then begin + gBGImg.OverlaySmooth := OverlaySmoothMenu.Checked; + exit; + end; + OverlaySmoothMenu.Checked := not OverlaySmoothMenu.Checked; + gBGImg.OverlaySmooth := OverlaySmoothMenu.Checked; + for lC := 1 to knMaxOverlay do + if gMRIcroOverlay[lC].ScrnBufferItems > 0 then + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lC],lC); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.ShowRenderClick(Sender: TObject); +begin + RenderForm.Show; + //RenderForm.BringToFront; +end; + +procedure TImgForm.PenBtnClick(Sender: TObject); +begin + RefreshImagesTimer.Enabled := true; +end; + +procedure OpenMRIcroROI (lFilename: string); +const + kMax12bit = 4095; + kMax16bit = (256*256)-1; + kMax15bit = kMax16bit shr 1; + //kMax20bit = (16*256*256)-1; + // k20v16bit = kMax20bit - kMax16bit; + //kMaxRuns = 10000; + //kMaxFile = 65536; + //k16v12bit = kMax16bit - kMax12bit; +var + lFile32bitItems,lFileSz,lFilePos,lSliceSz,lZ,lRunsOnSlice, + lRunLength,lRun,lRunOffset,lOutputSliceOffset,lRunPos: integer; + lROIformatRA: LongIntp; + lF: File; + lBigFormat: boolean; +begin + lFileSz := FSize(lFilename); + if (lFileSz < 1) or ((lFileSz mod 4) <> 0) then begin + showmessage('Unable to open ROI: file size should be divisible by 4.'); + exit; + end; + lFile32bitItems := lFileSz div 4; //how many 32-bit items? + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + freemem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer); + gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems := lSliceSz * lZ; + getmem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,lSliceSz * lZ); + fillchar(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,0); + if lSliceSz > 65535 then + lBigFormat := true + else + lBigFormat := false; + getmem(lROIformatRA,lFileSz); //file size must be divisible by 4 + {$I-} + AssignFile(lF, lFilename); + FileMode := 0; { Set file access to read only } + Reset(lF, 1); + BlockRead(lF,lROIformatRA^,lFileSz); + CloseFile(lF); + FileMode := 2; + {$I+} + //next: check MSB of first byte to see if this is big format images + if lBigFormat <> odd((lROIformatRA^[1] and kMax16bit) shr 15) then + Showmessage('Warning: this ROI does not appear to be designed for the currently loaded background image.'); + lFilePos := 1; +if lBigFormat then begin //20-byte offset, 12-byte runlength + while lFilePos < lFile32bitItems do begin + lRunsOnSlice := (lROIformatRA^[lFilePos] shr 17) - 1; //shr 17: shift 16 bits, then div 2 (words instead of longints). Subtract 1 as the we have read slice number/ number of runs + lZ := (lROIformatRA^[lFilePos] and kMax15bit); + inc(lFilePos); + lOutputSliceOffset := (lZ-1) * lSliceSz; + for lRun := 1 to lRunsOnSlice do begin + if (lFilePos <= lFileSz) then begin + lRunLength := (lROIformatRA^[lFilePos] shr 16) and kMax12bit; + lRunOffset := (lROIformatRA^[lFilePos] and kMax16bit)+ ((lROIformatRA^[lFilePos] shr 28) shl 16); + if (lOutputSliceOffset+lRunLength+lRunOffset-1)> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then + //showmessage('Overrun on slice '+inttostr(lZ)) + else for lRunPos := lRunOffset to (lRunLength+lRunOffset-1) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lRunPos+lOutputSliceOffset] := kVOI8bit; + end; + inc(lFilePos); + end;//for all runs + end; //while lPos < lFSz +end else begin //not big format format - 16-byte offset, 16-byte length + while lFilePos < lFile32bitItems do begin + //lRunsOnSlice := (lROIformatRA[lFilePos] shr 16) and kMax16bit; + lRunsOnSlice := (lROIformatRA^[lFilePos] shr 17) - 1; //shr 17: shift 16 bits, then div 2 (words instead of longints). Subtract 1 as the we have read slice number/ number of runs + lZ := (lROIformatRA^[lFilePos] and kMax15bit); + inc(lFilePos); + lOutputSliceOffset := (lZ-1) * lSliceSz; + //showmessage(inttostr(lZ)+' '+inttostr(lRunsOnSlice)+' '+inttostr(lFilePos)+' '+inttostr(lFileSz)); + for lRun := 1 to lRunsOnSlice do begin + if (lFilePos <= lFileSz) then begin + lRunLength := (lROIformatRA^[lFilePos] shr 16) and kMax16bit; + lRunOffset := (lROIformatRA^[lFilePos] and kMax16bit); + {if (lRunLength+lRunOffset-1)> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then + showmessage('Overrun on slice '+inttostr(lZ)) + else} for lRunPos := lRunOffset to (lRunLength+lRunOffset-1) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lRunPos+lOutputSliceOffset] := kVOI8bit; + end; + inc(lFilePos); + end;//for all runs + end; //while lPos < lFSz +end; //if bigformat ... else little format + freemem(lROIformatRA); + lRun := maxint; + LoadMonochromeLUT(lRun,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); +end; + +procedure TImgForm.OpenVOICore(var lFilename : string); +var + lExt: string; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + ImgForm.CloseVOIClick(nil); + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if (lExt='.ROI') then begin + Showmessage('Warning: MRIcro ROI format does not save image dimensions. The background image must be in the same dimensions as the ROI.'); + OpenMRIcroROI (lFileName); + ImgForm.RefreshImagesTimer.Enabled := true; + exit; + end; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kVOIOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[kVOIOverlayNum],false,true,false,gBGImg.ResliceOnLoad,false) then exit; + ImgForm.RefreshImagesTimer.Enabled := true; +end;//OpenVOIClick + + +procedure TImgForm.OpenVOIClick(Sender: TObject); +var + lFilename: string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding a VOI.'); + exit; + end; + //HdrForm.OpenHdrDlg.Filter := '*.roi';//kVOIFilter; + //if not HdrForm.OpenHdrDlg.Execute then exit; + if not OpenDialogExecute(kVOIFilter,'Select Volume of Interest drawing',false) then exit; + lFilename := HdrForm.OpenHdrDlg.Filename; + OpenVOICore(lFilename); +end;//OpenVOIClick + +(*procedure TImgForm.SaveVOIClick(Sender: TObject); +var lHdr: TMRIcroHdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); + Freemem(lHdr.ScrnBuffer); + exit; //sept2007 + end; + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end;*) +procedure TImgForm.SaveVOIcore(lPromptFilename: boolean); + var lHdr: TMRIcroHdr; + lNIFTIhdr: TNIFTIhdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + //Start 10/2007: adjust scl_slope;? 10/2007 + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + lNIFTIhdr.scl_slope := 1; + lNIFTIhdr.scl_inter := 0; + //end + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + if lPromptFilename then + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,lNIFTIhdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName) + else + SaveAsVOIorNIFTIcore(gMRIcroOverlay[kVOIOverlayNum].HdrFileName,lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,lNIFTIhdr); + Freemem(lHdr.ScrnBuffer); + exit; //12/2010 + end; + if lPromptFilename then + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,lNiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName) + else + SaveAsVOIorNIFTIcore(gMRIcroOverlay[kVOIOverlayNum].HdrFileName,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,lNiftiHdr); +end; + +procedure TImgForm.Extract1Click(Sender: TObject); +var + lMin : smallint; + lOtsuLevels,lnVox,lVox,lDilate: integer; + lOneContiguousObject : boolean; + l16Buf : SmallIntP; + l32Buf : SingleP; + lMinS: single; +begin + lnVox := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lnVox < 9 then begin + showmessage('Please load a background image.'); + exit; + end; + lOtsuLevels := ReadIntForm.GetInt('Otsu levels: larger values for larger volumes',1,4,5); + lDilate := ReadIntForm.GetInt('Edge dilation voxels: larger values for larger volumes',0,2,12); + lOneContiguousObject := OKMsg('Only extract single largest object?'); + //MaskBackground (var lImg: Bytep; lXi,lYi,lZi,lOtsuLevels: integer; lDilateVox: single; lOneContiguousObject: boolean ); + MaskBackground(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer, gBGImg.ScrnDim[1],gBGImg.ScrnDim[2],gBGImg.ScrnDim[3],lOtsuLevels,lDilate,lOneContiguousObject); + + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + lMinS := l32Buf^[1]; + for lVox := 1 to lnVox do + if l32Buf^[lVox] < lMinS then + lMinS := l32Buf^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + l32Buf^[lVox] := lMinS; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + lMin := l16Buf^[1]; + for lVox := 1 to lnVox do + if l16Buf^[lVox] < lMin then + lMin := l16Buf^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + l16Buf^[lVox] := lMin; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then begin + lMin := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[1]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox] < lMin then + lMin := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox] := lMin; + + end; +end; + +procedure TImgForm.NewWindow1Click(Sender: TObject); +{$IFDEF Darwin} +var + AProcess: TProcess; + i : integer; + //http://wiki.freepascal.org/Executing_External_Programs +begin + AProcess := TProcess.Create(nil); + AProcess.InheritHandles := False; + //AProcess.Options := [poNoConsole]; //poNoConsole is Windows only! http://lazarus-ccr.sourceforge.net/docs/fcl/process/tprocess.options.html + //AProcess.ShowWindow := swoShow; //Windows only http://www.freepascal.org/docs-html/fcl/process/tprocess.showwindow.html + for I := 1 to GetEnvironmentVariableCount do + AProcess.Environment.Add(GetEnvironmentString(I)); + AProcess.Executable := 'open'; + AProcess.Parameters.Add('-n'); + AProcess.Parameters.Add('-a'); + AProcess.Parameters.Add(paramstr(0)); + AProcess.Execute; + AProcess.Free; +end; +{$ELSE} +begin + //only OSX/Darwin +end; +{$ENDIF} + +procedure TImgForm.ToggleDrawMenu(Sender: TObject); +begin + gBGImg.ShowDraw := not DrawMenu.Visible; + WriteIni2Form(gBGImg); +end; + +procedure TImgForm.SaveVOIClick(Sender: TObject); + var lHdr: TMRIcroHdr; + lNIFTIhdr: TNIFTIhdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + //Start 10/2007: adjust scl_slope;? 10/2007 + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + lNIFTIhdr.scl_slope := 1; + lNIFTIhdr.scl_inter := 0; + //end + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,lNIFTIhdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); + Freemem(lHdr.ScrnBuffer); + exit; //sept2007 + end; + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,lNiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end; + +procedure TImgForm.VOIColorClick(Sender: TObject); +var + lMaxi: longint; +begin + ColorDialog1.Color := gBGImg.VOIClr; + if not ColorDialog1.Execute then exit; + gBGImg.VOIClr := ColorDialog1.Color; + if gBGImg.VOIClr = clBlack then + gBGImg.VOIClr := 1; //reserve 0 for deleting + lMaxi:=maxint; + LoadMonochromeLUT(lMaxi,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.CloseVOIClick(Sender: TObject); +begin + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems>0) and (gBGImg.VOIChanged) then begin + case MessageDlg('Do you wish to save the VOI drawing?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + {id_Yes}mrYes: SaveVOIClick(nil); + end; //case + end;//if changed + FreeUndoVol; + FreeImgMemory(gMRIcroOverlay[kVOIOverlayNum]); + gBGImg.VOIUndoSlice := 0; + gBGImg.VOIchanged := false; + gBGImg.VOIUndoOrient := 0; + RefreshImagesTimer.Enabled := true; +end; + +procedure ImageRB (var lMaxR,lMaxB: integer; var lImage: TImage); +var + lPos: integer; +begin + if not lImage.Visible then + exit; + lPos := lImage.Left+lImage.Width; + if lPos > lMaxR then + lMaxR := lPos; + lPos := lImage.Top+lImage.Height; + if lPos > lMaxB then + lMaxB := lPos; +end; + +procedure CopyImg(var lSourceImg,lDestImg: TImage); +var + lPos: integer; +begin + if not lSourceImg.Visible then + exit; + lDestImg.Canvas.Draw(lSourceImg.Left,lSourceImg.Top,lSourceImg.Picture.Graphic); +end; + +procedure TImgForm.SaveOrCopyImages(lCopy: boolean); +var + lMaxR,lMaxB: integer; + lOutImg: TImage; +begin + lMaxR := 0; + lMaxB := 0; + ImageRB(lMaxR,lMaxB,ImgForm.PGImageAx); + ImageRB(lMaxR,lMaxB,ImgForm.PGImageCor); + ImageRB(lMaxR,lMaxB,ImgForm.PGImageSag); + if (lMaxR < 1) or (lMaxB < 1) then + exit; + lOutImg := TImage.Create(ImgForm); + try + //use the object + {$IFDEF FPC} + lOutImg.Width := lMaxR; + lOutImg.Height := lMaxB; + {$ELSE} + CreateImg(lMaxB,lMaxR,lOutImg); + {$ENDIF} + lOutImg.Canvas.Brush.color := ImgForm.TriplePanel.color; + lOutImg.Canvas.Rectangle(0,0,lMaxR+1,lMaxB+1); + CopyImg(ImgForm.PGImageAx,lOutImg); + CopyImg(ImgForm.PGImageCor,lOutImg); + CopyImg(ImgForm.PGImageSag,lOutImg); + if lCopy then begin + {$IFDEF FPC} + lOutImg.Picture.Bitmap.SaveToClipboardFormat(2); + //Clipboard.Assign(lOutImg.Picture.Bitmap); + {$ENDIF} + Clipboard.Assign(lOutImg.Picture.Graphic); + end else + SaveImgAsPNGBMP (lOutImg); + finally + FreeAndNil (lOutImg); + end; +end; + +procedure TImgForm.Saveaspicture1Click(Sender: TObject); +begin + SaveOrCopyImages(false); +end; +(*var + lImage: TImage; +begin + lImage := SelectedImage; + SaveImgAsPNGBMP (lImage); +end; //Proc Saveaspicture1Click +*) +procedure TImgForm.Copy1Click(Sender: TObject); //Requires 'ClipBrd' in uses section +begin + SaveOrCopyImages(true); +end; + +(*procedure TImgForm.Copy1Click(Sender: TObject); //Requires 'ClipBrd' in uses section +var + MyFormat : Word; + lImage: TImage; + AData: THandle; + {$IFNDEF FPC}APalette : HPalette;{$ENDIF} +begin + lImage := SelectedImage; + if (lImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + {$IFNDEF FPC} + lImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); + {$ELSE} + lImage.Picture.Bitmap.SaveToClipboardFormat(2); + {$ENDIF} + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems>0) then + WriteUndoVOI(SelectedImageNum,false); + +end; *) + +procedure TImgForm.Undo1Click(Sender: TObject); +begin + if gBGImg.VOIUndoSlice < 1 then exit; + case gBGImg.VOIUndoOrient of + 4: UndoVolVOI; + 3: ReadCorVOI(gUndoImg,gBGImg.VOIUndoSlice); + 2: ReadSagVOI(gUndoImg,gBGImg.VOIUndoSlice); + 1: ReadAxialVOI(gUndoImg,gBGImg.VOIUndoSlice); + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.Paste1Click(Sender: TObject); +begin + if (gBGImg.VOIUndoSlice < 1) then exit; + if gBGImg.VOIUndoOrient <> SelectedImageNum then //12/2007 + exit; + WriteUndoVOI(SelectedImageNum,true); + case gBGImg.VOIUndoOrient of + 3: ReadCorVOI(gDrawImg,ImgForm.YViewEdit.Value); + 2: ReadSagVOI(gDrawImg,ImgForm.XViewEdit.Value); + 1: ReadAxialVOI(gDrawImg,ImgForm.ZViewEdit.Value); + else exit; + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.HideROIBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + gOrigBGTransPct := gBGImg.BGTransPct; + gBGImg.BGTransPct := 100; + refreshimagestimer.enabled := true; +end; + +procedure TImgForm.HideROIBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + gBGImg.BGTransPct := gOrigBGTransPct; + Refreshimagestimer.enabled := true; +end; + +procedure TImgForm.Applyintensityfiltertovolume1Click(Sender: TObject); +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + showmessage('You must have open a background image in order to apply an intensity filter (use File/Open).'); + exit; + end; + FilterROIform.showmodal; +end; + +procedure TImgForm.Quicksmooth1Click(Sender: TObject); +var + lHdr: TMRicroHdr; + lXDim,lYDim,lZDim,lSum,lMinWt,lMaxWt,lMinInten,lMaxInten,lOutVolVox,lOutSliceSz,lX,lY,lZ,lXxi,l2,lZyi: integer; + lSum32,lMinInten32,lMaxInten32: single; + lTempBuff,lSrcBuff: Bytep; + l16TempBuff,l16SrcBuff: SmallIntP; + l32TempBuff,l32SrcBuff: SingleP; +procedure AddPoint (lInten,lWeight:integer); +begin + lSum := lSum + (lInten*lWeight); + if lInten <= lMinInten then begin + lMinWt := lWeight; + lMinInten := lInten; + end else if lInten >= lMaxInten then begin + lMaxWt := lWeight; + lMaxInten := lInten; + end; +end; //nested AddPoint +procedure AddPoint32 (lInten32: single; lWeight:integer); +begin + lSum32 := lSum32 + (lInten32*lWeight); + if lInten32 <= lMinInten32 then begin + lMinWt := lWeight; + lMinInten32 := lInten32; + end else if lInten32 >= lMaxInten32 then begin + lMaxWt := lWeight; + lMaxInten32 := lInten32; + end; +end; //nested AddPoint32 +begin + lHdr := gMRIcroOverlay[kBGOverlayNum]; + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lOutSliceSz := gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2]; + lOutVolVox := lOutSliceSz * lZDim; + if (lXDim < 3) or (lYDim < 3) or (lZDim < 3) or (lOutVolVox < 36) then begin + showmessage('The 3D smoothing can only be applied to images with at least 3 slices in each dimension.'); + exit; + end; + if (lHdr.ImgBufferItems < 1) then begin + showmessage('Please first load the image you would like to smooth.'); + exit; + end; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lZDim; + StatusLabel.caption := 'Removing noise speckles and smoothing data [blur]'; + if lHdr.ImgBufferBPP = 4 then begin //32-bit float data + l32SrcBuff := SingleP(lHdr.ImgBuffer); + GetMem(l32TempBuff,lOutVolVox*sizeof(single)); + Move(l32SrcBuff^,l32TempBuff^,lOutVolVox*sizeof(single)); + for lZ := 1 to lOutVolVox do + l32SrcBuff^[lZ] := 0; + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum32 := 0; + lMinInten32 := l32TempBuff^[lXxi]; + lMaxInten32 := l32TempBuff^[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint32(l32TempBuff^[lXxi],12);//quad-weight center + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz],2);//prev slice + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz],2);//next slices + AddPoint32(l32TempBuff^[lXxi-1],2);//Left + AddPoint32(l32TempBuff^[lXxi+1],2);//right + AddPoint32(l32TempBuff^[lXxi-lXDim],2);//up + AddPoint32(l32TempBuff^[lXxi+lXDim],2);//down + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz-1],1); + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz+1],1); + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz-lXDim],1); + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz+lXDim],1); + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz-1],1); + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz+1],1); + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz-lXDim],1); + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz+lXDim],1); + AddPoint32(l32TempBuff^[lXxi-lXDim-1],1); + AddPoint32(l32TempBuff^[lXxi+lXDim-1],1); + AddPoint32(l32TempBuff^[lXxi-lXDim+1],1); + AddPoint32(l32TempBuff^[lXxi+lXDim+1],1); + if lMinInten32 = lMaxInten32 then + l32SrcBuff^[lXxi] := lMaxInten32 //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum32 := lSum32 -(lMinWt*lMinInten32) - (lMaxWt*lMaxInten32); //exclude brightest/darkest + l32SrcBuff^[lXxi] := (lSum32/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(l32TempBuff); + end else if (lHdr.ImgBufferBPP = 2) then begin //16-bit int data*) + l16SrcBuff := SmallIntP(lHdr.ImgBuffer ); + GetMem(l16TempBuff,lOutVolVox*sizeof(word)); + Move(l16SrcBuff^,l16TempBuff^,lOutVolVox*sizeof(word)); + for lZ := 1 to lOutVolVox do + l16SrcBuff^[lZ] := 0; + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum := 0; + lMinInten := l16TempBuff^[lXxi]; + lMaxInten := l16TempBuff^[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint(l16TempBuff^[lXxi],12);//quad-weight center + AddPoint(l16TempBuff^[lXxi-lOutSliceSz],2);//prev slice + AddPoint(l16TempBuff^[lXxi+lOutSliceSz],2);//next slices + AddPoint(l16TempBuff^[lXxi-1],2);//Left + AddPoint(l16TempBuff^[lXxi+1],2);//right + AddPoint(l16TempBuff^[lXxi-lXDim],2);//up + AddPoint(l16TempBuff^[lXxi+lXDim],2);//down + AddPoint(l16TempBuff^[lXxi-lOutSliceSz-1],1); + AddPoint(l16TempBuff^[lXxi-lOutSliceSz+1],1); + AddPoint(l16TempBuff^[lXxi-lOutSliceSz-lXDim],1); + AddPoint(l16TempBuff^[lXxi-lOutSliceSz+lXDim],1); + AddPoint(l16TempBuff^[lXxi+lOutSliceSz-1],1); + AddPoint(l16TempBuff^[lXxi+lOutSliceSz+1],1); + AddPoint(l16TempBuff^[lXxi+lOutSliceSz-lXDim],1); + AddPoint(l16TempBuff^[lXxi+lOutSliceSz+lXDim],1); + AddPoint(l16TempBuff^[lXxi-lXDim-1],1); + AddPoint(l16TempBuff^[lXxi+lXDim-1],1); + AddPoint(l16TempBuff^[lXxi-lXDim+1],1); + AddPoint(l16TempBuff^[lXxi+lXDim+1],1); + if lMinInten = lMaxInten then + l16SrcBuff^[lXxi] := lMaxInten //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum := lSum -(lMinWt*lMinInten) - (lMaxWt*lMaxInten); //exclude brightest/darkest + l16SrcBuff^[lXxi] := round(lSum/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(l16TempBuff); + //OptimizeSingle(nil); + end else if lHdr.ImgBufferBPP = 1 then begin //8-bit data + lSrcBuff := lHdr.ImgBuffer; + GetMem(lTempBuff,lOutVolVox); + Move(lSrcBuff^,lTempBuff^,lOutVolVox); + fillchar(lSrcBuff^,lOutVolVox,0); //set edges to 0, as outside voxel is not smoothed + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum := 0; + lMinInten := lTempBuff^[lXxi]; + lMaxInten := lTempBuff^[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint(lTempBuff^[lXxi],12);//quad-weight center + AddPoint(lTempBuff^[lXxi-lOutSliceSz],2);//prev slice + AddPoint(lTempBuff^[lXxi+lOutSliceSz],2);//next slices + AddPoint(lTempBuff^[lXxi-1],2);//Left + AddPoint(lTempBuff^[lXxi+1],2);//right + AddPoint(lTempBuff^[lXxi-lXDim],2);//up + AddPoint(lTempBuff^[lXxi+lXDim],2);//down + AddPoint(lTempBuff^[lXxi-lOutSliceSz-1],1); + AddPoint(lTempBuff^[lXxi-lOutSliceSz+1],1); + AddPoint(lTempBuff^[lXxi-lOutSliceSz-lXDim],1); + AddPoint(lTempBuff^[lXxi-lOutSliceSz+lXDim],1); + AddPoint(lTempBuff^[lXxi+lOutSliceSz-1],1); + AddPoint(lTempBuff^[lXxi+lOutSliceSz+1],1); + AddPoint(lTempBuff^[lXxi+lOutSliceSz-lXDim],1); + AddPoint(lTempBuff^[lXxi+lOutSliceSz+lXDim],1); + AddPoint(lTempBuff^[lXxi-lXDim-1],1); + AddPoint(lTempBuff^[lXxi+lXDim-1],1); + AddPoint(lTempBuff^[lXxi-lXDim+1],1); + AddPoint(lTempBuff^[lXxi+lXDim+1],1); + if lMinInten = lMaxInten then + lSrcBuff^[lXxi] := lMaxInten //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum := lSum -(lMinWt*lMinInten) - (lMaxWt*lMaxInten); //exclude brightest/darkest + lSrcBuff^[lXxi] := round(lSum/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(lTempBuff); + end else begin //8bit data + showmessage('Unknown bits per pixel '+inttostr(lHdr.ImgBufferBPP) ); + end; + ProgressBar1.Position := 0; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[kBGOverlayNum],kBGOverlayNum); + RefreshImagesTimer.Enabled := true; +end; //quicksmooth + +procedure TImgForm.VOImaskClick(Sender: TObject); +var + lPreserve: integer; + lHdr,lMaskHdr: TMRicroHdr; + lXDim,lYDim,lZDim,lOutVolVox,lOutSliceSz,lZ: integer; + lSrcBuff,lMaskBuff: Bytep; + l16SrcBuff: SmallIntP; + l32SrcBuff: SingleP; +begin + lPreserve := (sender as TMenuItem).tag; + lHdr := gMRIcroOverlay[kBGOverlayNum]; + lMaskHdr := gMRIcroOverlay[kVOIOverlayNum]; + + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lOutSliceSz := gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2]; + lOutVolVox := lOutSliceSz * lZDim; + if (lXDim < 2) or (lYDim < 2) or (lZDim < 2) then begin + showmessage('Masking can only be applied to images with multiple slices in 3 dimensions.'); + exit; + end; + if (lHdr.ImgBufferItems <> lMaskHdr.ScrnBufferItems) or (lHdr.ImgBufferItems < 8) then begin + showmessage('Please first load both an image (File/Open) and a masking VOI (Draw/Open).'); + exit; + end; + if gBGImg.Mirror then + MirrorScrnBuffer(gBGImg,lMaskHdr);//4/2008 + lMaskBuff := (lMaskHdr.ScrnBuffer); + ProgressBar1.Min := 0; + ProgressBar1.Max :=lZDim; + StatusLabel.caption := 'Masking data'; + if lHdr.ImgBufferBPP = 4 then begin //32-bit float data + l32SrcBuff := SingleP(lHdr.ImgBuffer); + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] = 0 then + l32SrcBuff^[lZ] := 0; + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] <> 0 then + l32SrcBuff^[lZ] := 0; + end; //if preserve + end else if (lHdr.ImgBufferBPP = 2) then begin //16-bit int data*) + l16SrcBuff := SmallIntP(lHdr.ImgBuffer ); + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] = 0 then + l16SrcBuff^[lZ] := 0; + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] <> 0 then + l16SrcBuff^[lZ] := 0; + end; + end else if lHdr.ImgBufferBPP = 1 then begin //8-bit data + lSrcBuff := lHdr.ImgBuffer; + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] = 0 then + lSrcBuff^[lZ] := 0 + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] <> 0 then + lSrcBuff^[lZ] := 0; + end; + end else begin //8bit data + showmessage('Unknown bits per pixel '+inttostr(lHdr.ImgBufferBPP) ); + end; + if gBGImg.Mirror then + MirrorScrnBuffer(gBGImg,lMaskHdr);//4/2008 + + ProgressBar1.Position := 0; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[kBGOverlayNum],kBGOverlayNum); + RefreshImagesTimer.Enabled := true; +end; //VOImaskClick + +procedure TImgForm.Sagittal1Click(Sender: TObject); +begin + gBGImg.SliceView := (Sender as TMenuItem).Tag; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.ROIcomparisonClick(Sender: TObject); +var lComparison,lVolItems,lOverlay,lnOverlays,lPos: integer; +begin + lComparison := (Sender as TMenuItem).tag; //0=intersect AND,1=union OR ,2=mask + lVolItems := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]* gBGImg.ScrnDim[3]; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lVolItems) or (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems <> lVolItems) then begin + Showmessage('VOI comparisons require a VOI loaded onto a background image (Draw/Open).'); + exit; + end; + lnOverlays := 0; + for lOverlay := 1 to knMaxOverlay do + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then + inc(lnOverlays); + if (lnOverlays = 0) then begin + Showmessage('VOI comparisons require loaded overlays (Overlay/Add).'); + exit; + end; + CreateUndoVol; + if lComparison = 0 then begin //intersect AND + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lPos] = 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lPos] := 0; + end; //if overlay loaded + end; //for each overlay + end else if lComparison = 1 then begin //if intersect else UNION OR + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lPos] > 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lPos] := kVOI8bit; + end; //if overlay loaded + end; //for each overlay + end else if lComparison = 2 then begin //if union else MASK + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lPos] > 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lPos] := 0; + end; //if overlay loaded + end; //for each overlay + end; //if ..else MASK + RefreshImagesTimer.Enabled := true; +end; //ROIcomparisonClick + +procedure TImgForm.RescaleImagesTimerTimer(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + RescaleImagesTimer.Enabled := false; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lLayer],lLayer); + RefreshImages; +end; + +procedure TImgForm.Fill3DBtnClick(Sender: TObject); +begin + AutoROIForm.Show; +end; + + +procedure TImgForm.SmoothVOI1Click(Sender: TObject); +begin + voismoothform.showmodal; + //SmoothVOIForm.Showmodal +end; + +procedure TImgForm.CreateOverlap(Sender: TObject); +var + lNumberofFiles,lC,lOverlay,lPos: integer; + lFilename,lExt: string; + lOverlapBuffer: ByteP; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + if not OpenDialogExecute(kVOIFilter,'Select VOIs you wish to combine',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + exit; + end; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + getmem(lOverlapBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems); + fillchar(lOverlapBuffer^,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems,0); + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lOverlay]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[lOverlay],false,false,false,gBGImg.ResliceOnLoad,false) then exit; + ProgressBar1.Position := lC; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lPos] > 0 then + lOverlapBuffer^[lPos] := lOverlapBuffer^[lPos]+1; + FreeImgMemory(gMRIcroOverlay[lOverlay]); + end; //for each image + //July07 getmem for unaligned buffer getmem(gMRIcroOverlay[lOverlay].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems); + GetMem(gMRIcroOverlay[lOverlay].ImgBufferUnaligned ,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems + 16); //July072007 + //gMRIcroOverlay[lOverlay].ImgBuffer := ByteP($fffffff0 and (integer(gMRIcroOverlay[lOverlay].ImgBufferUnaligned)+15)); + gMRIcroOverlay[lOverlay].ImgBuffer := system.align(gMRIcroOverlay[lOverlay].ImgBufferUnaligned, 16); + gMRIcroOverlay[lOverlay].ImgBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + gMRIcroOverlay[lOverlay].ImgBuffer[lPos] := lOverlapBuffer[lPos]; + freemem(lOverlapBuffer); + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay],0, lNumberofFiles,1,0,0,kNIFTI_INTENT_ESTIMATE,'N'+inttostr(lNumberofFiles) ); + UpdateLayerMenu; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lOverlay],lOverlay); + ProgressBar1.Position := 0; + //SaveAsVOIorNIFTI(gMRIcroOverlay[lOverlay].ImgBuffer,gMRIcroOverlay[lOverlay].ScrnBufferItems,1,false,gMRIcroOverlay[lOverlay].niftiHdr,'sum'+inttostr(lNumberofFiles)); + SaveAsVOIorNIFTI(gMRIcroOverlay[lOverlay].ImgBuffer,gMRIcroOverlay[lOverlay].ScrnBufferItems,1,1,false,gMRIcroOverlay[lOverlay].niftiHdr,'sum'+inttostr(lNumberofFiles)); + RefreshImagesTimer.Enabled := true; +end;//proc CreateOverlap + +procedure TImgForm.Chisquare1Click(Sender: TObject); +var + lNegativeNumbers: boolean; + lVolVoxels,lPos,lnTotalThreshold,lLoop,lnVoxelsTested:integer; + lMinExp,lChi,lChip,luChi, luChiP: double; + lMaxChi,lMinChi: single; + lBufferAligned,lBufferUnAligned,lBuffer: ByteP; + l32Buf : SingleP; + lFilename: string; + lTotal,lYes,lNo: array [1..2] of integer; + lMRIcroHdr: TMRIcroHdr; +begin + lVolVoxels := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lVolVoxels < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + CloseOverlayImgClick(nil); + for lLoop := 1 to 2 do begin //open two images + if lLoop = 1 then begin + if not OpenDialogExecute(kImgFilter,'Select POSITIVE overlap image',false) then exit + end else begin + if not OpenDialogExecute(kImgFilter,'Select NEGATIVE overlap image',false) then exit; + end; + lFilename := HdrForm.OpenHdrDlg.Filename; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lLoop]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[lLoop],false,false,true,gBGImg.ResliceOnLoad,false) then exit; + lTotal[lLoop] := round(gMRIcroOverlay[lLoop].NIFTIhdr.glmax); + if (gMRIcroOverlay[lLoop].NIFTIhdr.intent_code <> kNIFTI_INTENT_ESTIMATE) then + showmessage('Warning: header intent_code is not set to ESTIMATE. Compute Chi-squared only with cumulative maps created with this program.'); + if (gMRIcroOverlay[lLoop].NIFTIhdr.intent_name[1] <> 'N') then + showmessage('Warning: header intention not N. Compute Chi-squared only with cumulative maps created with this program.'); + UpdateLayerMenu; + RefreshImagesTimer.Enabled := true; + end; + if (lVolVoxels<> gMRIcroOverlay[1].ScrnBufferItems) + or (lVolVoxels<> gMRIcroOverlay[2].ScrnBufferItems) then begin + showmessage('Error loading images.'); + exit; + end; + //next - chi squared + lnTotalThreshold:= ReadIntForm.GetInt('Only test voxels damaged in at least N patients [A+B]', 1,1,(lTotal[1]+lTotal[2])); + GetMem(lBufferUnaligned ,(lVolVoxels *sizeof(single) )+16); + //lBufferAligned := ByteP($fffffff0 and (integer(lBufferUnaligned)+15)); + lBufferAligned := system.align(lBufferUnaligned, 16); + l32Buf := SingleP(lBufferAligned); + lnVoxelsTested := 0; + lNegativeNumbers := false; + lMaxChi := 0; + lMinChi := 0; + for lPos := 1 to lVolVoxels do begin + l32Buf^[lPos] := 0; + lYes[1] := gMRIcroOverlay[1].ScrnBuffer^[lPos]; + lNo[1] := lTotal[1]-lYes[1]; + lYes[2] := gMRIcroOverlay[2].ScrnBuffer^[lPos]; + lNo[2] := lTotal[2]-lYes[2]; + if (lYes[1] < 0) or (lNo[1] < 0) or (lYes[2] < 0) or (lNo[2] < 0) then + lNegativeNumbers := true + else if (lYes[1]+lYes[2]) >= lnTotalThreshold then begin//e.g. at least 30% of all patients + inc(lnVoxelsTested); + //showmessage(inttostr(lYes[1])+'x'+inttostr(lNo[1])+'x'+ inttostr(lYes[2])+'x'+inttostr(lNo[2]) ); + Chi2x2 (lYes[1], lNo[1], lYes[2], lNo[2],lMinExp,lChi,lChip,luChi, luChiP); + if (luChi) > lMaxChi then + lMaxChi := (luChi) + else if (luChi < lMinChi) then + lMinChi := luChi; + if (lYes[1]/lTotal[1]) > (lYes[2]/lTotal[2]) then + l32Buf^[lPos] := luChi//100-(100*luChip) //positives more likely than negative + else + l32Buf^[lPos] := -luChi;//-100+(100*luChip); //negatives more common + end;//> threshold + end; //for each voxel + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,lMinChi, lMaxChi,1{df},0,lnVoxelsTested,kNIFTI_INTENT_CHISQ,inttostr(lnVoxelsTested) ); + if lNegativeNumbers then + Showmessage('Serious error: some group sizes were negative. This should be impossible with a Chi-Squared.'); + //SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,false,lMRIcroHdr.NiftiHdr,'chi'+inttostr(lnTotalThreshold)); + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(lnTotalThreshold)); + //next - save log10 p values... + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,lMinChi, lMaxChi,1{df},0,lnVoxelsTested,NIFTI_INTENT_LOG10PVAL,inttostr(lnVoxelsTested) ); + for lPos := 1 to lVolVoxels do + if l32Buf^[lPos] > 0 then + l32Buf^[lPos] := -log(abs(gammq(0.5, 0.5 * l32Buf^[lPos])),10) + else + l32Buf^[lPos] :=0; + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(lnTotalThreshold)); + //next - free float buffer + FreeMem(lBufferUnaligned); + StatusLabel.Caption := 'Voxels tested: '+inttostr(lnVoxelsTested); + //next - subtraction + GetMem(lBuffer ,(lVolVoxels )); + lNegativeNumbers := false; + fillchar(lBuffer^,lVolVoxels,100); + for lPos := 1 to lVolVoxels do begin + lYes[1] := gMRIcroOverlay[1].ScrnBuffer^[lPos]; + lNo[1] := lTotal[1]-lYes[1]; + lYes[2] := gMRIcroOverlay[2].ScrnBuffer^[lPos]; + lNo[2] := lTotal[2]-lYes[2]; + if (lYes[1] < 0) or (lNo[1] < 0) or (lYes[2] < 0) or (lNo[2] < 0) then + lNegativeNumbers := true + else if (lYes[1] >0) or (lYes[2] > 0) then begin + lBuffer^[lPos] := round((100* ((lYes[1]/lTotal[1])-(lYes[2]/lTotal[2])))+100); + end;//> threshold + end; //for each voxel + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,-100, 100,1,0,0,kNIFTI_INTENT_ESTIMATE,'%'+inttostr(lTotal[1])+':'+inttostr(lTotal[2]) ); + lMRIcroHdr.NIFTIhdr.scl_inter:= -100; + if lNegativeNumbers then + Showmessage('Serious error: some group sizes were negative. This should be impossible with a subtraction analysis.'); + SaveAsVOIorNIFTI(lBuffer,lVolVoxels,1,1,false,lMRIcroHdr.NiftiHdr,'Sub'+inttostr(lTotal[1])+'_'+inttostr(lTotal[2])); + FreeMem(lBuffer); +end; //procedure Chisquare1Click + +procedure Paris(lFilename: string); +begin + ImgForm.CloseImagesClick(nil); + + ImgForm.OpenAndDisplayImg(lFilename,True); + ImgForm.caption := 'x'; + //if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kBGOverlayNum]) then exit; + ImgForm.Caption := 'y'; +end; + +procedure Normandy; +begin + gBGImg.Prompt4DVolume := false; + gBGImg.Resliced :=true; + paris('/Users/rorden/downloads/fx/DBM8768/DBM8768_DIFFUSION AX PRE PERFUSION.nii.gz'); + gBGImg.Prompt4DVolume := true; +end; + +procedure TImgForm.ROIVOI1Click(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + Normandy; + exit; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + if gBGImg.Resliced then begin + if not HdrForm.OpenAndDisplayHdr(gMRIcroOverlay[kBGOverlayNum].HdrFileName,gMRIcroOverlay[kBGOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false) then exit; + end; + showmessage('Warning: the currently open background image must have the dimensions (size, space between slices, etc) as the image used when creating the ROIs.'); + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + CloseVOIClick(nil); + if not OpenDialogExecute('MRIcro ROI (.roi)|*.roi','Select MRIcro format ROIs to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + OpenMRIcroROI (lFileName); + lFilename := changefileextX(lFilename,'.voi'); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end; + +procedure TImgForm.LUTinvertBtnClick(Sender: TObject); +begin +end; //proc LUTdropSelect + +procedure TImgForm.LutFromZeroBtnClick(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + gMRIcroOverlay[lLayer].LUTfromZero := LUTfromZeroBtn.down; + LUTdropLoad(lLayer); + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.ShowMultisliceClick(Sender: TObject); +begin +(* if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + MultiSliceForm.MultiImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + MultiSliceForm.MultiImage.canvas.font.Color := gBGImg.XBarClr;*) + MultiSliceForm.Show; + //MultiSliceForm.BringToFront; +end; + +function RawBGIntensity(lPos: integer): single; +var + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + result := 0; + if (lPos > gMRIcroOverlay[kBGOverlayNum].ImgBufferItems) or (lPos < 1) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l32Buf^[lPos]; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l16Buf^[lPos]; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then + result := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos] + else begin + showmessage('Unknown Background Buffer Bytes Per Pixel'); + exit; + end; +end; + +(*procedure DescribeVOIonLabelsX (lOverlayNum: integer); +var + lShowfilename: boolean = true; + lLocalMax,lLocalSum : HistoDoubleRA; + l16Buf : SmallIntP; + l32Buf : SingleP; + l8Buf: byteP; + lInten: double; + lXmm,lYmm,lZmm: single; + lHisto,lRegionVol,lLocalMaxPos: HistoRA; + lInc,lRegion: Integer; + lLabelStr: string; + lVOI: boolean; + lLabelStr20 : Array[0..kHistoBins] of kstr20; +begin + lInten := 0;//just to hide compiler hint... + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) and ('ratlas.nii.gz' = (extractfilename( gMRIcroOverlay[kBGOverlayNum].HdrFileName))) then begin + //DescribeVOIonLabelsRAT(lOverlayNum,lShowFilename); + Showmessage('Please use Windows version.'); + exit; + end; + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) or (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP <> 1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 2) then + exit; + TextForm.MemoT.Lines.add(' Custom Region Analysis'); + TextForm.MemoT.Lines.add(' For Speculative Brodmann Map: 0=not cortical and 48=no Brodmann label'); + lVOI := IsVOIROIExt(gMRIcroOverlay[lOverlayNum].HdrFileName); + if (not lVOI) and (lOverlayNum = kVOIOverlayNum) then + lVOI := true; + //next describe format + if lShowfilename then + lLabelStr := ' Filename,' + else + lLabelStr := ' '; + if lVOI then //intensity min/max position are not important + TextForm.MemoT.Lines.add(lLabelStr+'Area'+kTextSep+'N>0'+kTextSep+'%N>0') + else + TextForm.MemoT.Lines.add(lLabelStr+'Area'+kTextSep+'N>0'+kTextSep+'%N>0'+kTextSep+'Sum>0'+kTextSep+'Mean>0'+kTextSep+'Max'+kTextSep+'MaxX'+kTextSep+'MaxY'+kTextSep+'MaxZ'); + //next initialize + if lShowFilename then + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName+',' + else + lLabelStr := ''; + for lInc := 0 to kHistoBins do begin + lHisto[lInc] := 0; + lLocalMax[lInc] := 0; + lLocalSum[lInc] := 0; + lRegionVol[lInc] := 0; + if (gMRIcroOverlay[kBGOverlayNum].UsesLabels) then + lLabelStr20[lInc] := gBGImg.LabelRA[lInc]// gBGImg.LabelStr20[lInc] + else + lLabelStr20[lInc] := inttostr(lInc); + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + inc(lHisto[gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc]]); + //local max start + l32Buf := SingleP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + l16Buf := SmallIntP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + //NEXT if..else July07 - ROIs only use screen buffer, not imgbuffer... + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[lOverlayNum].ImgBufferItems then + l8Buf := gMRIcroOverlay[lOverlayNum].ImgBuffer + else + l8Buf := gMRIcroOverlay[lOverlayNum].ScrnBuffer; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if (gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 4) then + lInten := l32Buf^[lInc] + else if (gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 2) then + lInten := l16Buf^[lInc] + else if gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 1 then + lInten := l8Buf^[lInc];//July07 + lRegion := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc]; + if lInten > 0 then + lLocalSum[lRegion] := lLocalSum[lRegion]+lInten; + if lInten > lLocalMax[lRegion] then begin + lLocalMax[lRegion] := lInten;//intensity + lLocalMaxPos[lRegion] := lInc;//location + end; + inc(lRegionVol[lRegion]); + end; + + for lInc := 0 to kHistoBins do begin + if (not lVOI) and (lLocalMax[lInc] > 0) then begin + lLocalMax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[lOverlayNum],lLocalMax[lInc]); + lLocalSum[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[lOverlayNum],lLocalSum[lInc]); + ImgPosToMM(lLocalMaxPos[lInc], lXmm,lYmm,lZmm); + TextForm.MemoT.Lines.Add(lLabelStr+ lLabelStr20[lInc] +kTextSep+ inttostr(lHisto[lInc])+kTextSep+floattostr( lHisto[lInc]/lRegionVol[lInc]) + +kTextSep+floattostr( lLocalSum[lInc])+kTextSep+floattostr( lLocalSum[lInc]/lRegionVol[lInc]) //Sum>0, mean>0 + +kTextSep + floattostr(lLocalMax[lInc])+kTextSep+floattostr(lXmm)+kTextSep+floattostr(lYmm)+kTextSep+floattostr(lZmm) ); + end else if (lHisto[lInc] > 0) {necessarily also and (lRegionVol[lInc] > 0)} then + TextForm.MemoT.Lines.Add(gBGImg.LabelRA[lInc] + kTextSep+ inttostr(lHisto[lInc])+kTextSep+floattostr( lHisto[lInc]/lRegionVol[lInc])) ; + end; //for each row +end; 2014: no longer used (16 bit LabelRA)*) + + +function Mode (lOverlayNum: integer): double; +const + kBins = 4095; +var + lInc,lS,lMaxI: integer; + lV,lMin,lMax,lScale: single; + lRA: LongIntP0; +begin + result := nan; //error + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems ) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1)then + exit; + lMin := RawBGIntensity(1); + lMax := lMin; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lV := RawBGIntensity(lInc); + if lV < lMin then + lMin := lV; + if lV > lMax then + lMax := lV; + end; //if VOI voxel + end; //for each voxel + if lMin = lMax then begin //no variability + result := Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],lMin); + exit; + end; + lScale := kBins/(lMax-lMin); + getmem(lRA,(kBins+1) * sizeof(longint) ); //0..kBins + for lInc := 0 to kBins do + lRA^[lInc] := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lV := RawBGIntensity(lInc); + lS := round((lV-lMin)*lScale); + inc(lRA^[lS]); + end; //if VOI voxel + end; //for each voxel + lMaxI := 0; + for lInc := 1 to kBins do + if lRA^[lInc] > lRA^[lMaxI] then + lMaxI := lInc; + result := lMin+ (lMaxI/kBins * (lMax-lMin)); + result := Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],result); + freemem(lRA); +end; + +procedure TImgForm.DescriptiveMenuItemClick(Sender: TObject); +var + lROIVol: array [1..3] of integer; + lInc,lOverlayNum,lImgSz: integer; + lCenterOfMass,lROISum,lROISumSqr,lROImin,lROImax:array [1..3] of double; + lMode,lCC,lVal,lSD,lROImean: double; + lStr: string; +procedure AddVal( lRA: integer); +begin + inc(lROIVol[lRA]); + lROISum[lRA] := lROISum[lRA]+lVal; + lROISumSqr[lRA] := lROISumSqr[lRA] + sqr(lVal); + if lVal > lROImax[lRA] then + lROImax[lRA] := lVal; + if lVal < lROImin[lRA] then + lROImin[lRA] := lVal; +end; +begin + lImgSz := 0; + for lOverlayNum := 1 to knMaxOverlay do + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems > lImgSz then + lImgSz := gMRIcroOverlay[lOverlayNum].ScrnBufferItems; + if (lImgSz < 1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < lImgSz) then begin + Showmessage('You need to create or load an overlay (Overlay/Open or Draw/OpenVOI) to get overlay statistics.'); + exit; + end; + + TextForm.MemoT.Lines.Clear; + for lOverlayNum := 1 to knMaxOverlay do begin + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then begin + for lInc := 1 to 3 do begin + lROIVol[lInc] := 0; + lROISum[lInc] := 0; + lROISumSqr[lInc] := 0; + lROImin[lInc] := maxint; + lROImax[lInc] := -maxint; + + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lVal := RawBGIntensity(lInc); + AddVal(1); + if lVal <> 0 then + AddVal(2); + if lVal > 0 then + AddVal(3); + end; //if VOI voxel + end; //for each voxel + //next - compute StDev + //compute descriptives for each set of values + TextForm.MemoT.Lines.Add('Overlay '+gMRIcroOverlay[lOverlayNum].HdrFileName); + if CenterOfMass (lOverlayNum, lCenterOfMass[1],lCenterOfMass[2],lCenterOfMass[3]) > 0 then + TextForm.MemoT.Lines.Add(' Center of mass XYZ '+RealToStr(lCenterOfMass[1],2)+'x'+RealToStr(lCenterOfMass[2],2)+'x'+RealToStr(lCenterOfMass[3],2)); + for lInc := 1 to 3 do begin + if lROIVol[lInc] > 1 then begin + lSD := (lROISumSqr[lInc] - ((Sqr(lROISum[lInc]))/lROIVol[lInc])); + if (lSD > 0) then + lSD := Sqrt ( lSD/(lROIVol[lInc]-1)) + else + lSD := 0; + end else + lSD := 0; + //next compute mean + if lROIVol[lInc] > 0 then + lROImean := lROISum[lInc]/lROIVol[lInc] + else + lROImean := 0; + //next - calibrate values + lROImin[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImin[lInc]); + lROIMean := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROIMean); + lROImax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImax[lInc]); + lSD := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lSD); + lcc := ((lROIVol[lInc]/1000)*gBGImg.ScrnMM[1]*gBGImg.ScrnMM[2]*gBGImg.ScrnMM[3]); + case lInc of + 3: lStr := 'VOI >0 '; + 2: lStr := 'VOI <>0 '; + else lStr := 'VOI '; + end; + lStr := lStr+' nvox(cc)=min/mean/max=SD: '+inttostr(round(lROIVol[lInc]))+kTextSep+RealToStr(lCC,2)+kTextSep+'='+RealToStr(lROIMin[lInc],4)+kTextSep+realToStr(lROIMean,4)+kTextSep+realToStr(lROIMax[lInc],4)+kTextSep+'='+kTextSep+realtostr(lSD,4); + TextForm.MemoT.Lines.Add(lStr); + end; + lMode := Mode(lOverlayNum); + if lMode <> NaN then + TextForm.MemoT.Lines.Add('Mode:'+kTextSep+floattostr(lMode)); + if gMRIcroOverlay[kBGOverlayNum].UsesLabels then + DescribeVOIonLabels(lOverlayNum,false); + TextForm.MemoT.Lines.Add(''); + end; //overlaynum loaded + end; //for each overlay + TextForm.Show; +end; + +procedure TImgForm.FormResize(Sender: TObject); +begin + + if not ImgForm.visible then + exit; + + RefreshImagesTimer.enabled := true; +end; + +function ParamStrFilename (var lParamPos: integer): string; +var + I: integer; + lStr: string; +begin + result := ''; + if (ParamCount < lParamPos) then exit; + I := lParamPos; + repeat + if I = lParamPos then + lStr := ParamStr(I) + else + lStr := lStr +' '+ ParamStr(I); + inc(I); + until (I>ParamCount) or (fileexistsex(lStr)); + lParamPos := I; + if fileexistsex(lStr) then + result := lStr; +end; + +procedure TImgForm.OnLaunch; +var + lStr: String; + lMaximize,lRender,lMultislice : boolean; + lCommandChar: Char; + I,lError,lOverlayNum,lInc,lLUT: integer; + lSingle: single; +procedure ReadCmdVal;//nested +begin + inc(I); + lStr := ParamStr(I); + {$IFNDEF FPC} + lStr := string(StrUpper(PChar(lStr))) ; + {$ELSE} + {$IFNDEF UNIX} + lStr := UpCase(lStr); //unix file names are case specific /EXAMPLE/ATTENTION.NII <> /Example/Attention + {$ENDIF} + {$ENDIF} +end; //nested ReadCmdVal +begin + {$IFDEF Darwin} + //Darwin starts passing a strange paramstr.... + //with Darwin, opening a file can interfere with opening by association... + exit; + //ResliceImg ('/Users/crlab/Documents/example_func.nii.gz','/Users/crlab/Documents/v1x.voi','/Users/crlab/Documents/example_func2standard.mat','/Users/crlab/Documents/z1x.nii.gz'); + {$ENDIF} + + if (ParamCount < 1) then begin + ImgForm.OpenTemplateMRU(nil); + RefreshImagesTimer.enabled := true; + exit; + + end; + lMaximize := false; + lRender := false; + lMultislice := false; + lOverlayNum := 0; + I := 1; + lStr := ParamStrFilename(I); + if lStr <> '' then + OpenAndDisplayImg(lStr,True) + else begin //no requested image + OpenTemplateMRU(nil); + I := 1;//exit; + end; + I := I-1; + //ShowMultisliceClick(nil); + if I >= ParamCount then exit; + gBGIMg.SaveDefaultIni := false; //do not store changes loaded by script + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') then begin //special command + lCommandChar := UpCase(lStr[2]); + case lCommandChar of + 'B': begin //background transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.BGTransPct := round(lSingle); + SetSubmenuWithTag(BGTransPctMenu, gBGImg.BGTransPct); + end; + 'C': begin //color look up table + ReadCmdVal; + if (Length(lStr)>1) then begin + if lStr[1] = '-' then begin //LUT index number + Val(lStr,lSingle,lError); + if lError = 0 then + lLUT := abs(round(lSingle)) + else + lLUT := -1; + end else begin + lStr := ParseFileName(ExtractFileName(lStr)); + {$IFDEF UNIX} + lStr := UpCase(lStr); + {$ENDIF} + lLUT := -1; + for lInc := 1 to (LUTdrop.Items.Count-1) do + if lStr = string(StrUpper(PChar(LUTdrop.Items.Strings[lINc]))) then + lLUT := lInc; + end; //else text LUTname + if lLUT >= 0 then begin + gMRIcroOverlay[lOverlayNum].LUTindex := lLUT; + LUTdropLoad(lOverlayNum); + end; + end; //str length > 1 + end; + 'D': gBGIMg.SaveDefaultIni := true; + 'F': gBGImg.ResliceOnLoad := false; //turn off reslicing... loads files flat + 'H': begin + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMax := (lSingle); + end; + 'L': begin //Low intensity scale + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMin := (lSingle); + end; + 'M': begin //multislice + lMultislice := true; + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gMultiSliceStartupFilename := (lStr); + + end; //if 'M' + 'O': begin//Overlay + ReadCmdVal; + //Showmessage('o'+lStr); + if (lStr <> '') and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then begin + //Showmessage('oexists'+lStr); + inc(lOverlayNum); + OverlayOpenCore (lStr,lOverlayNum); + end; + end; //if 'O' + 'R': begin//Overlay + lRender := true;//Render + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gRenderStartupFilename := (lStr); + end; //if 'R' + 'S': begin //smooth + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then begin + if odd(round(lSingle)) then begin + gBGImg.StretchQuality := sqHigh; + Menu2DSmooth.checked := true; + end else begin + gBGImg.StretchQuality := sqLow; + Menu2DSmooth.checked := false; + end; + if lSingle > 1 then + gBGIMg.OverlaySmooth := true + else + gBGIMg.OverlaySmooth := false; + OverlaySmoothMenu.Checked := gBGIMg.OverlaySmooth; + end;//error=0 + end; + 'T': begin //overlay transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.OverlayTransPct := round(lSingle); + SetSubmenuWithTag(OverlayTransPctMenu, gBGImg.OverlayTransPct); + end; + 'V': begin //open voi + ReadCmdVal; + if (lStr <> '') and (FileexistsEx(lStr)) then + OpenVOICore(lStr); + end; + 'X': lMaximize := true; //open maximized + 'Z': gMRIcroOverlay[lOverlayNum].LUTfromZero := true; + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + until I >= ParamCount; + LayerDropSelect(nil); + for lInc := 0 to lOverlayNum do + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lInc],lINc); + RefreshImages; + if lMultiSlice then + ShowMultisliceClick(nil); + if lRender then + ShowRenderClick(nil); + if lMaximize then begin + ImgForm.WindowState := wsMaximized; + RefreshImagesTimer.enabled := true; + end; +end; + + +procedure TImgForm.FormShow(Sender: TObject); +var + lStr: String; + lMaximize,lRender,lMultislice : boolean; + lCommandChar: Char; + I,lError,lOverlayNum,lInc,lLUT: integer; + lSingle: single; +procedure ReadCmdVal;//nested +begin + inc(I); + lStr := ParamStr(I); + {$IFNDEF FPC} + lStr := string(StrUpper(PChar(lStr))) ; + {$ELSE} + {$IFNDEF UNIX} + lStr := UpCase(lStr); //unix file names are case specific /EXAMPLE/ATTENTION.NII <> /Example/Attention + {$ENDIF} + {$ENDIF} +end; //nested ReadCmdVal +begin + {$IFDEF Darwin} + //Darwin starts passing a strange paramstr.... + //with Darwin, opening a file can interfere with opening by association... + + (*lStr := '/Users/rorden/desktop/mricrox/templates/aal.nii.gz'; + + ImgForm.OpenAndDisplayImg(lStr,True); + lStr := '/Users/rorden/desktop/mricrox/templates/crap.voi'; + LoadOverlayIncludingRGB{LoadOverlay}(lStr); *) + exit; + //ResliceImg ('/Users/crlab/Documents/example_func.nii.gz','/Users/crlab/Documents/v1x.voi','/Users/crlab/Documents/example_func2standard.mat','/Users/crlab/Documents/z1x.nii.gz'); + {$ENDIF} + + if (ParamCount < 1) then begin + ImgForm.OpenTemplateMRU(nil); + RefreshImagesTimer.enabled := true; + exit; + + end; + lMaximize := false; + lRender := false; + lMultislice := false; + lOverlayNum := 0; + I := 1; + lStr := ParamStrFilename(I); + if lStr <> '' then + OpenAndDisplayImg(lStr,True) + else begin //no requested image + OpenTemplateMRU(nil); + I := 1;//exit; + end; + I := I-1; + //ShowMultisliceClick(nil); + if I >= ParamCount then exit; + gBGIMg.SaveDefaultIni := false; //do not store changes loaded by script + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') then begin //special command + lCommandChar := UpCase(lStr[2]); + case lCommandChar of + 'B': begin //background transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.BGTransPct := round(lSingle); + SetSubmenuWithTag(BGTransPctMenu, gBGImg.BGTransPct); + end; + 'C': begin //color look up table + ReadCmdVal; + if (Length(lStr)>1) then begin + if lStr[1] = '-' then begin //LUT index number + Val(lStr,lSingle,lError); + if lError = 0 then + lLUT := abs(round(lSingle)) + else + lLUT := -1; + end else begin + lStr := ParseFileName(ExtractFileName(lStr)); + {$IFDEF UNIX} + lStr := UpCase(lStr); + {$ENDIF} + lLUT := -1; + for lInc := 1 to (LUTdrop.Items.Count-1) do + if lStr = string(StrUpper(PChar(LUTdrop.Items.Strings[lINc]))) then + lLUT := lInc; + end; //else text LUTname + if lLUT >= 0 then begin + gMRIcroOverlay[lOverlayNum].LUTindex := lLUT; + LUTdropLoad(lOverlayNum); + end; + end; //str length > 1 + end; + 'D': gBGIMg.SaveDefaultIni := true; + 'F': gBGImg.ResliceOnLoad := false; //turn off reslicing... loads files flat + 'H': begin + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMax := (lSingle); + end; + 'L': begin //Low intensity scale + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMin := (lSingle); + end; + 'M': begin //multislice + lMultislice := true; + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gMultiSliceStartupFilename := (lStr); + + end; //if 'M' + 'O': begin//Overlay + ReadCmdVal; + //Showmessage('o'+lStr); + if (lStr <> '') and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then begin + //Showmessage('oexists'+lStr); + inc(lOverlayNum); + OverlayOpenCore (lStr,lOverlayNum); + end; + end; //if 'O' + 'R': begin//Overlay + lRender := true;//Render + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gRenderStartupFilename := (lStr); + end; //if 'R' + 'S': begin //smooth + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then begin + if odd(round(lSingle)) then begin + gBGImg.StretchQuality := sqHigh; + Menu2DSmooth.checked := true; + end else begin + gBGImg.StretchQuality := sqLow; + Menu2DSmooth.checked := false; + end; + if lSingle > 1 then + gBGIMg.OverlaySmooth := true + else + gBGIMg.OverlaySmooth := false; + OverlaySmoothMenu.Checked := gBGIMg.OverlaySmooth; + end;//error=0 + end; + 'T': begin //overlay transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.OverlayTransPct := round(lSingle); + SetSubmenuWithTag(OverlayTransPctMenu, gBGImg.OverlayTransPct); + end; + 'V': begin //open voi + ReadCmdVal; + if (lStr <> '') and (FileexistsEx(lStr)) then + OpenVOICore(lStr); + end; + 'X': lMaximize := true; //open maximized + 'Z': gMRIcroOverlay[lOverlayNum].LUTfromZero := true; + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + until I >= ParamCount; + LayerDropSelect(nil); + for lInc := 0 to lOverlayNum do + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lInc],lINc); + RefreshImages; + if lMultiSlice then + ShowMultisliceClick(nil); + if lRender then + ShowRenderClick(nil); + if lMaximize then begin + ImgForm.WindowState := wsMaximized; + RefreshImagesTimer.enabled := true; + end; +end; + + +procedure TImgForm.FlipLRmenuClick(Sender: TObject); +var + lC: integer; + lStr: string; +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gBGImg.Mirror := (sender as TMenuItem).checked ; + gBGImg.VOImirrored := true; + for lC := 0 to knMaxOverlay do + if gMRIcroOverlay[lC].ScrnBufferItems > 0 then + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lC],lC); + RefreshImagesTimer.Enabled := true; + if gBGImg.Mirror then + lStr := 'radiological [right on left side]' + else + lStr := 'neurological [left on left side]'; + showmessage('Warning: left-right flips can be confusing. From now on, this software will attempt to show NIfTI images in '+lStr+' orientation.'); + if MultiSliceForm.Visible then + MultiSliceForm.CreateMultiSlice; +end; + +procedure TImgForm.Menu2DSmoothClick(Sender: TObject); +begin + if Sender <> nil then + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + if Menu2DSmooth.checked then + gBGImg.StretchQuality := sqHigh + else + gBGImg.StretchQuality := sqLow; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.VALclick(Sender: TObject); +begin + //ComputeValFile( (sender as Tmenuitem).tag); +end; + +procedure TImgForm.VOI2NIIClick(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute('VOI Drawings (.VOI)|*.VOI','Select VOI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + OpenAndDisplayImg(lFilename,True); + lFilename := changefileextx(lFilename,'.nii'); + //SaveAsVOIorNIFTIcore (lFilename, lByteP, lVoxels, 1, gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end;//VOI->NII + +procedure TImgForm.TtoP1Click(Sender: TObject); +var + lBufferAligned,lBufferUnAligned: ByteP; + l32Buf,l32BufSrc : SingleP; + l16BufSrc : SmallIntP; + lSlope,lIntercept: single; + lMRIcroHdr: TMRIcroHdr; + lVolVoxels,lPos: integer; +begin +//alfa - currently open image + lVolVoxels := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lVolVoxels < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + GetMem(lBufferUnaligned ,(lVolVoxels *sizeof(single) )+16); + //lBufferAligned := ByteP($fffffff0 and (integer(lBufferUnaligned)+15)); + lBufferAligned := system.align(lBufferUnaligned, 16); + l32Buf := SingleP(lBufferAligned); + //next load values + case gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP of + 4: begin + l32BufSrc := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lPos := 1 to lVolVoxels do + l32Buf^[lPos] := l32BufSrc^[lPos]; + end; + 2: begin + l16BufSrc := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lPos := 1 to lVolVoxels do + l32Buf^[lPos] := l16BufSrc^[lPos]; + end; + 1: begin + for lPos := 1 to lVolVoxels do + l32Buf^[lPos] := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos]; + end; + else begin + showmessage('unknown datatype'); + end; + end; + //next calibrate values + lSlope := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.scl_slope; + lIntercept := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.scl_inter; + if (lSlope=0) or ((lSlope=1) and (lIntercept=0)) then + //no slope + else begin + for lPos := 1 to lVolVoxels do + l32Buf^[lPos] := (l32Buf^[lPos] * lSlope)+lIntercept; + end; + //next - save log10 p values... + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,0, 255,1{df},0,666,NIFTI_INTENT_LOG10PVAL,inttostr(666) ); + for lPos := 1 to lVolVoxels do + if l32Buf^[lPos] > 0 then + l32Buf^[lPos] := -log(abs(pTdistr(42,l32Buf^[lPos])),10) + else + l32Buf^[lPos] :=0; + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(666)); + //next - free float buffer + FreeMem(lBufferUnaligned); +end; + +procedure TImgForm.DesignVALClick(Sender: TObject); +begin + //SpreadForm.Show; +end; + +procedure TImgForm.Up1Click(Sender: TObject); +var lVolVox,lPos,lShift: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + showmessage('You must have open a background image in order to apply an intensity filter (use File/Open).'); + exit; + end; + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + CreateUndoVol;//create gBGImg.VOIUndoVol + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + lVolVox := gBGImg.ScrnDim[1]* gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]; + case (Sender as TMenuItem).tag of + 0: lShift := 1; + 1: lShift := -1; + 2: lShift := gBGImg.ScrnDim[1]; + 3: lShift := -gBGImg.ScrnDim[1]; + 4: lShift := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + 5: lShift := -gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + end; + if lShift > 0 then begin + for lPos := 1 to (lVolVox-lShift) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := gBGImg.VOIUndoVol[lPos+lShift]; + end else begin + for lPos := (1+abs(lShift)) to lVolVox do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := gBGImg.VOIUndoVol[lPos+lShift]; + end; + gBGImg.VOIchanged := true; + ImgForm.ProgressBar1.Position := 0; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + + +procedure TImgForm.FormDestroy(Sender: TObject); +begin +{$IFDEF Darwin} + FormClose(nil); //OSX does not send a FormClose Event if you choose the Application/Quit option +{$ENDIF} + CloseShareMem; +end; + +procedure TImgForm.YokeMenuClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gYoke := (sender as TMenuItem).checked ; + if gYoke then + CreateShareMem + else + CloseShareMem; + +end; + +procedure TImgForm.About1Click(Sender: TObject); +begin + AboutForm.ThreadLabel.Caption := ' '+inttostr(gnCPUThreads)+' threads'+' '+ininame; + AboutForm.Showmodal; +end; +procedure TImgForm.LayerDropChange(Sender: TObject); +begin + {$IFDEF LCLgtk2} + LayerDropSelect(nil); + {$ENDIF} +end; + +procedure TImgForm.LUTdropChange(Sender: TObject); +begin + {$IFDEF LCLgtk2} + LutDropSelect(nil); + {$ENDIF} +end; + +procedure TImgForm.AdjustimagessoVOIintensityiszero1Click(Sender: TObject); +begin + BatchChangeInterceptSoVOIEqualsZero; +end; + +procedure TImgForm.MirrorNII1Click(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + Showmessage('WARNING: This will flip the images in the Left-Right dimension: this has serious consequences'); + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileextX(lFilename,'lr.nii.gz'); + //zap + //showmessage(lFilename); + if MirrorImgBuffer (gMRIcroOverlay[kBGOverlayNum] ) then begin + //showmessage(lFilename); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + end; + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; + +end; + +procedure TImgForm.ZoomDropChange(Sender: TObject); +begin + {$IFDEF LCLgtk2} + ZoomDropSelect(nil); + {$ENDIF} +end; + + + +procedure TImgForm.ResizeControlPanel (lRows: integer); +begin + if lRows = 2 then begin + ControlPanel.Tag := 2; + LayerPanel.Top := 36; + LayerPanel.Left := 1; + + ControlPanel.Height := 72; + + HideROIBtn.left := 307; + XBarBtn.Left := 307+29; + ToolPanel.Left := 307+61; + end else begin + ControlPanel.Tag := 1; + LayerPanel.Top := 1; + LayerPanel.Left := 307; + HideROIBtn.left := 809; + XBarBtn.Left := 809+29; + ToolPanel.Left := 809+61; + ControlPanel.Height := 40; + end; +end; + +procedure TImgForm.ControlPanelDblClick(Sender: TObject); +begin + if ControlPanel.Tag = 1 then + ResizeControlPanel(2) + else + ResizeControlPanel(1); + ImgForm.RefreshImagesTimer.enabled := true; +end; + +procedure TImgForm.DefaultControlPanel; +begin + if gBGImg.SingleRow then begin + ResizeControlPanel(1); + ImgForm.Width := 1025; + ImgForm.Height := 469; + end else begin + ResizeControlPanel(2); + ImgForm.Width := 524; + ImgForm.Height := 640; + end; +end; + +initialization + + for gMouseDownY := 0 to knMaxOverlay do + gMRIcroOverlay[gMouseDownY].index := gMouseDownY; //RGB + +end. diff --git a/backup/render.lfm.bak b/backup/render.lfm.bak new file mode 100755 index 0000000..8cd2f3b --- /dev/null +++ b/backup/render.lfm.bak @@ -0,0 +1,574 @@ +object RenderForm: TRenderForm + Left = 461 + Height = 512 + Top = 140 + Width = 955 + ActiveControl = RenderBar + Caption = 'Volume Render' + ClientHeight = 512 + ClientWidth = 955 + Menu = MainMenu1 + OnCreate = FormCreate + OnHide = FormHide + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object RenderBar: TPanel + Left = 0 + Height = 32 + Top = 0 + Width = 955 + Align = alTop + BevelOuter = bvNone + ClientHeight = 32 + ClientWidth = 955 + TabOrder = 0 + object Label4: TLabel + Left = 152 + Height = 16 + Top = 5 + Width = 57 + Caption = 'Elevation' + ParentColor = False + end + object Label1: TLabel + Left = 4 + Height = 16 + Top = 5 + Width = 53 + Caption = 'Azimuth' + ParentColor = False + end + object RefreshBtn: TSpeedButton + Left = 296 + Height = 31 + Hint = 'Generate high-resolution rendering' + Top = 0 + Width = 40 + Glyph.Data = { + 76080000424D7608000000000000360000002800000018000000160000000100 + 2000000000004008000064000000640000000000000000000000FFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF + } + OnClick = RefreshClick + ShowHint = True + ParentShowHint = False + end + object RenderImageBUP: TImage + Tag = 2 + Cursor = crCross + Left = 360 + Height = 12 + Top = 8 + Width = 12 + AutoSize = True + Center = True + OnMouseDown = RenderImageMouseDown + OnMouseMove = RenderImageMouseMove + Stretch = True + Visible = False + end + object Label5: TLabel + Left = 616 + Height = 16 + Top = 5 + Width = 63 + Caption = 'Shading %' + ParentColor = False + end + object AzimuthEdit: TSpinEdit + Left = 72 + Height = 16 + Top = 2 + Width = 70 + Increment = 30 + MaxValue = 360 + OnChange = EditChange + TabOrder = 0 + Value = 120 + end + object ElevationEdit: TSpinEdit + Left = 216 + Height = 16 + Top = 2 + Width = 70 + Increment = 30 + MaxValue = 180 + MinValue = -180 + OnChange = EditChange + TabOrder = 1 + Value = 30 + end + object BiasTrack: TTrackBar + Left = 352 + Height = 29 + Top = 2 + Width = 120 + Max = 100 + OnChange = BiasTrackChange + Position = 50 + TickStyle = tsNone + TabOrder = 2 + end + object GainTrack: TTrackBar + Left = 480 + Height = 29 + Top = 2 + Width = 120 + Max = 100 + OnChange = BiasTrackChange + Position = 50 + TickStyle = tsNone + TabOrder = 3 + end + object ShadeEdit: TSpinEdit + Left = 690 + Height = 16 + Top = 2 + Width = 70 + Increment = 10 + OnChange = EditChange + TabOrder = 4 + end + object ClipTrack: TTrackBar + Left = 776 + Height = 29 + Top = 2 + Width = 120 + Max = 999 + OnChange = ClipTrackChange + Position = 0 + TickStyle = tsNone + TabOrder = 5 + end + end + object RenderPanel: TScrollBox + Left = 0 + Height = 480 + Top = 32 + Width = 955 + HorzScrollBar.Page = 14 + VertScrollBar.Page = 14 + Align = alClient + ClientHeight = 465 + ClientWidth = 940 + TabOrder = 1 + object RenderImage: TImage + Tag = 2 + Cursor = crCross + Left = 2 + Height = 12 + Top = 2 + Width = 12 + AutoSize = True + OnMouseDown = RenderImageMouseDown + OnMouseMove = RenderImageMouseMove + Stretch = True + end + end + object MainMenu1: TMainMenu + left = 16 + top = 32 + object FileMenu: TMenuItem + Caption = 'File' + object Settings1: TMenuItem + Caption = 'Open settings' + OnClick = Settings1Click + end + object Savesettings1: TMenuItem + Caption = 'Save settings...' + OnClick = Savesettings1Click + end + object Save1: TMenuItem + Caption = 'Save as bitmap...' + ShortCut = 16467 + OnClick = Save1Click + end + object RotationBMPMenu: TMenuItem + Caption = 'Save Rotation Bitmaps' + OnClick = RotationBMPMenuClick + end + object SaveClipMenu: TMenuItem + Caption = 'Save clip bitmaps' + OnClick = SaveClipMenuClick + end + object Close1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Close1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + end + object Volume1: TMenuItem + Caption = 'Background' + object RenderBGSurfaceMenu: TMenuItem + Caption = 'Air/Skin Threshold' + object N1: TMenuItem + Caption = '0%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N101: TMenuItem + Tag = 25 + Caption = '10%' + Checked = True + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N401: TMenuItem + Tag = 51 + Caption = '20%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N601: TMenuItem + Tag = 76 + Caption = '30%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N801: TMenuItem + Tag = 101 + Caption = '40%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N403: TMenuItem + Tag = 128 + Caption = '50%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N404: TMenuItem + Tag = 152 + Caption = '60%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N405: TMenuItem + Tag = 178 + Caption = '70%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + end + object RenderBGDepthMenu: TMenuItem + Caption = 'Search Depth' + object N1voxel1: TMenuItem + Tag = 1 + Caption = '1 voxel' + Checked = True + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N2voxels1: TMenuItem + Tag = 2 + Caption = '2 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N4voxels1: TMenuItem + Tag = 4 + Caption = '4 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N8voxels1: TMenuItem + Tag = 8 + Caption = '8 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N16voxels1: TMenuItem + Tag = 12 + Caption = '12 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N16voxels: TMenuItem + Tag = 16 + Caption = '16 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object Infinite1: TMenuItem + Tag = 2147483647 + Caption = 'Infinite' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object MIPItem: TMenuItem + Caption = 'MIP' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + end + end + object Overlay1: TMenuItem + Caption = 'Overlay' + object RenderOverlaySurfaceMenu: TMenuItem + Caption = 'Air/Skin Threshold' + object N01: TMenuItem + Caption = '0%' + Checked = True + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N102: TMenuItem + Tag = 25 + Caption = '10%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N201: TMenuItem + Tag = 51 + Caption = '20%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N301: TMenuItem + Tag = 76 + Caption = '30%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N402: TMenuItem + Tag = 101 + Caption = '40%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N501: TMenuItem + Tag = 128 + Caption = '50%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N602: TMenuItem + Tag = 152 + Caption = '60%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N701: TMenuItem + Tag = 178 + Caption = '70%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + end + object RenderOverlayDepthMenu: TMenuItem + Caption = 'Search Depth' + object N1voxel2: TMenuItem + Tag = 1 + Caption = '1 voxel' + Checked = True + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N2voxels2: TMenuItem + Tag = 2 + Caption = '2 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N4voxels2: TMenuItem + Tag = 4 + Caption = '4 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N8voxels2: TMenuItem + Tag = 8 + Caption = '8 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N12voxels1: TMenuItem + Tag = 12 + Caption = '12 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N16voxels2: TMenuItem + Tag = 16 + Caption = '16 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object Infinite2: TMenuItem + Tag = 2147483647 + Caption = 'Infinite' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + end + object Search1: TMenuItem + Caption = 'Search' + object BehindBG1: TMenuItem + Caption = 'Any Depth' + GroupIndex = 17 + RadioItem = True + OnClick = SetSearch + end + object Infront1: TMenuItem + Tag = 1 + Caption = 'Below BG surface [max intensity]' + GroupIndex = 17 + RadioItem = True + OnClick = SetSearch + end + object Anydepth1: TMenuItem + Tag = 2 + Caption = 'Infront/below BG surface' + GroupIndex = 17 + RadioItem = True + OnClick = SetSearch + end + end + end + object Quality1: TMenuItem + Caption = 'View' + object CutoutMenu: TMenuItem + Caption = 'Cutout' + OnClick = Cutout1Click + end + object MenuItem1: TMenuItem + Caption = '-' + end + object RenderSmoothBG: TMenuItem + Caption = 'Smooth Background' + Checked = True + Hint = 'Blur rendering' + OnClick = RenderSmoothBGClick + end + object RenderSmoothOverlay: TMenuItem + Caption = 'Smooth Overlay' + Checked = True + Hint = 'Blur rendering' + OnClick = RenderSmoothBGClick + end + object RenderPreciseInterpolation: TMenuItem + Caption = 'Precise interpolation' + Hint = 'Use trilinear interpolation [slow]' + OnClick = RenderPreciseInterpolationClick + end + object N2: TMenuItem + Caption = '-' + end + object FlipLRcheck: TMenuItem + Caption = 'Flip L/R' + OnClick = RenderSmoothClick + end + end + end + object RenderRefreshTimer: TTimer + Enabled = False + Interval = 150 + OnTimer = RenderRefreshTimerTimer + left = 48 + top = 32 + end +end diff --git a/backup/render.pas.bak b/backup/render.pas.bak new file mode 100755 index 0000000..4c63720 --- /dev/null +++ b/backup/render.pas.bak @@ -0,0 +1,828 @@ +unit render; +interface +{$include isthreaded.inc} +{$mode delphi} +uses +{$IFDEF Unix} +lclintf, //gettickcount +{$ELSE} +Windows, +{$ENDIF} +{$IFNDEF NoThreads} + RenderThds, +{$ELSE} +rendernothreads, +{$ENDIF} + LResources,SysUtils, GraphicsMathLibrary,Classes, Graphics, Controls, Forms, Dialogs,ExtCtrls,Buttons, + nifti_img, nifti_hdr,define_types,nifti_img_view,StdCtrls, Spin, Menus,ClipBrd,ReadInt,IniFiles, + ComCtrls,userdir,render_composite; +type + { TRenderForm } + TRenderForm = class(TForm) + CutoutMenu: TMenuItem; + ClipTrack: TTrackBar; + MenuItem1: TMenuItem; + SaveClipMenu: TMenuItem; + MIPItem: TMenuItem; + ShadeEdit: TSpinEdit; + Label5: TLabel; + RotationBMPMenu: TMenuItem; + RenderBar: TPanel; + AzimuthEdit: TSpinEdit; + ElevationEdit: TSpinEdit; + MainMenu1: TMainMenu; + FileMenu: TMenuItem; + Close1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Save1: TMenuItem; + Label4: TLabel; + RefreshBtn: TSpeedButton; + BiasTrack: TTrackBar; + GainTrack: TTrackBar; + Volume1: TMenuItem; + RenderBGSurfaceMenu: TMenuItem; + N1: TMenuItem; + N101: TMenuItem; + N401: TMenuItem; + N601: TMenuItem; + N801: TMenuItem; + N403: TMenuItem; + N404: TMenuItem; + N405: TMenuItem; + RenderBGDepthMenu: TMenuItem; + N1voxel1: TMenuItem; + N2voxels1: TMenuItem; + N4voxels1: TMenuItem; + N8voxels1: TMenuItem; + N16voxels1: TMenuItem; + N16voxels: TMenuItem; + RenderSmoothBG: TMenuItem; + RenderPreciseInterpolation: TMenuItem; + Label1: TLabel; + Overlay1: TMenuItem; + RenderOverlaySurfaceMenu: TMenuItem; + N701: TMenuItem; + N602: TMenuItem; + N501: TMenuItem; + N402: TMenuItem; + N301: TMenuItem; + N201: TMenuItem; + N102: TMenuItem; + N01: TMenuItem; + RenderOverlayDepthMenu: TMenuItem; + N16voxels2: TMenuItem; + N12voxels1: TMenuItem; + N8voxels2: TMenuItem; + N4voxels2: TMenuItem; + N2voxels2: TMenuItem; + N1voxel2: TMenuItem; + Quality1: TMenuItem; + RenderRefreshTimer: TTimer; + + RenderPanel: TScrollBox; + RenderImage: TImage; + RenderImageBUP: TImage; + //RenderImage2: TImage; + + RenderSmoothOverlay: TMenuItem; + FlipLRcheck: TMenuItem; + Settings1: TMenuItem; + Savesettings1: TMenuItem; + N2: TMenuItem; + Infinite1: TMenuItem; + Infinite2: TMenuItem; + Search1: TMenuItem; + BehindBG1: TMenuItem; + Infront1: TMenuItem; + Anydepth1: TMenuItem; + procedure BiasTrackChange(Sender: TObject); + procedure ClipTrackChange(Sender: TObject); + procedure RenderSmoothBGClick(Sender: TObject); + procedure RotationBMPMenuClick(Sender: TObject); + procedure SaveClipMenuClick(Sender: TObject); + procedure Settings1Click(Sender: TObject); + procedure SetSearch(Sender: TObject); + procedure Save1Click(Sender: TObject); + procedure RenderImageMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure Copy1Click(Sender: TObject); + procedure Close1Click(Sender: TObject); + procedure N1Click(Sender: TObject); + procedure N01Click(Sender: TObject); + procedure N1voxel1Click(Sender: TObject); + procedure N16voxels2Click(Sender: TObject); + procedure RenderSmoothClick(Sender: TObject); + procedure RenderPreciseInterpolationClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure RenderRefreshTimerTimer(Sender: TObject); + procedure EditChange(Sender: TObject); + procedure OverlayRenderDepthItem(Sender: TObject); + procedure RenderImageMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Cutout1Click(Sender: TObject); + procedure Savesettings1Click(Sender: TObject); + procedure UpdateRenderMRU; + procedure OpenRenderMRU(Sender:TObject); + procedure UpdateRenderDisplay; + procedure FormHide(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure RefreshClick(Sender: TObject); + procedure RefreshRotation; + private + { Private declarations } + public + { Public declarations } + end; + +var + RenderForm: TRenderForm; + gZoom : single = 1; + gRenderDir,gRenderStartupFilename,gRenderDefaultsFilename:string; +implementation + +uses MultiSlice,math,cutout; + + + {$IFNDEF FPC} +{$R *.DFM} + {$ENDIF} +procedure MinMaxFilt (var lHdr: TMRIcroHdr; var lFiltMin8bit, lFiltMax8bit: integer);var lMin,lMax: single; +begin +ReturnMinMax (lHdr,lMin,lMax, lFiltMin8bit, lFiltMax8bit); +end; + +procedure TRenderForm.UpdateRenderDisplay; +begin + SetSubmenuWithTag(RenderBGSurfaceMenu,gRender.BGSurface); + SetSubmenuWithTag(RenderOverlaySurfaceMenu,gRender.OverlaySurface); + SetSubmenuWithTag(RenderBGDepthMenu,gRender.BGDepth); + SetSubmenuWithTag(RenderOverlayDepthMenu,gRender.OverlayDepth); + RenderSmoothBG.checked := gRender.SmoothBG; + RenderSmoothOverlay.checked := gRender.SmoothOverlay; + RenderPreciseInterpolation.Checked := gRender.Trilinear; + //RenderSurfaceOverlay.Checked := gRender.OverlayFromBGSurface; + SetSubmenuWithTag(Search1,gRender.OverlayFromBGSurface); + FlipLRCheck.Checked := gRender.FlipLR; + AzimuthEdit.value := gRender.Azimuth; + ElevationEdit.value := gRender.Elevation; + ShadeEdit.value := gRender.ShadePct; + RenderRefreshTimer.tag := -1; + RenderRefreshTimer.enabled := true; +end; + +procedure WriteRenderIniFile (lFilename: string); +var + lIniFile: TIniFile; + lInc: integer; +begin + if DiskFreeEx(lFilename) < 1 then + exit; + if not DirectoryExists(extractfiledir(lFilename)) then begin + mkDir(extractfiledir(lFilename)); + end; + lIniFile := TIniFile.Create(lFilename); + with gRender do begin + lIniFile.WriteString('BOOL', 'SmoothBG',Bool2Char( SmoothBG)); + lIniFile.WriteString('BOOL', 'SmoothOverlay',Bool2Char( SmoothOverlay)); + lIniFile.WriteString('BOOL', 'Trilinear',Bool2Char( Trilinear)); + lIniFile.WriteString('BOOL', 'ShowCutout',Bool2Char( ShowCutout)); + lIniFile.WriteString('BOOL', 'FlipLR',Bool2Char( FlipLR)); + lIniFile.WriteString('INT', 'OverlayFromBGSurface',IntToStr( OverlayFromBGSurface)); + //lIniFile.WriteString('INT', 'BGNearClip',IntToStr(BGNearClip)); + //lIniFile.WriteString('INT', 'OverlayNearClip',IntToStr(OverlayNearClip)); + lIniFile.WriteString('INT', 'Azimuth',IntToStr(Azimuth)); + lIniFile.WriteString('INT', 'Elevation',IntToStr(Elevation)); + lIniFile.WriteString('INT', 'BGSurface',IntToStr(BGSurface)); + lIniFile.WriteString('INT', 'OverlaySurface',IntToStr(OverlaySurface)); + lIniFile.WriteString('INT', 'BGDepth',IntToStr(BGDepth)); + lIniFile.WriteString('INT', 'OverlayDepth',IntToStr(OverlayDepth)); + lIniFile.WriteString('INT', 'CutoutBias',IntToStr(CutoutBias)); + lIniFile.WriteString('INT', 'cutoutLUTindex',IntToStr(cutoutLUTindex)); + lIniFile.WriteString('INT', 'ShadePct',IntToStr(ShadePct)); + for lInc := 1 to 3 do begin + lIniFile.WriteString('INT', 'CutoutLoFrac'+inttostr(lInc),IntToStr(CutoutFrac.Lo[lInc])); + lIniFile.WriteString('INT', 'CutoutHiFrac'+inttostr(lInc),IntToStr(CutoutFrac.Hi[lInc])); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure ReadRenderIniFile (lFilename: string); +var + lIniFile: TIniFile; + //lStr: string; + lInc: integer; +begin + if not FileexistsEx(lFilename) then begin + exit; + end; + lIniFile := TIniFile.Create(lFilename); + //lStr := lIniFile.ReadString('STR', 'Slices', '10,20,30');//file0 - last file viewed + with gRender do begin + //Booleans + //SmoothBG,SmoothOverlay,Trilinear,OverlayFromBGSurface,ShowCutout + SmoothBG := IniBool(lIniFile,'SmoothBG',SmoothBG); + SmoothOverlay := IniBool(lIniFile,'SmoothOverlay',SmoothOverlay); + Trilinear := IniBool(lIniFile,'Trilinear',Trilinear); + //OverlayFromBGSurface := IniBool(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + ShowCutout := IniBool(lIniFile,'ShowCutout',ShowCutout); + FlipLR := IniBool(lIniFile,'FlipLR',FlipLR); + OverlayFromBGSurface:= IniInt(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + //BGNearClip:= IniInt(lIniFile,'BGNearClip',BGNearClip); + //OverlayNearClip:= IniInt(lIniFile,'OverlayNearClip',OverlayNearClip); + Azimuth:= IniInt(lIniFile,'Azimuth',Azimuth); + Elevation:= IniInt(lIniFile,'Elevation',Elevation); + BGSurface:= IniInt(lIniFile,'BGSurface',BGSurface); + OverlaySurface:= IniInt(lIniFile,'OverlaySurface',OverlaySurface); + BGDepth:= IniInt(lIniFile,'BGDepth',BGDepth); + OverlayDepth:= IniInt(lIniFile,'OverlayDepth',OverlayDepth); + CutoutBias:= IniInt(lIniFile,'CutoutBias', CutoutBias); + ShadePct:= IniInt(lIniFile,'ShadePct', 0); + cutoutLUTindex:= IniInt(lIniFile,'cutoutLUTindex',cutoutLUTindex); + + for lInc := 1 to 3 do begin + Cutout.Lo[lInc] := IniInt(lIniFile,'CutoutLo'+inttostr(lInc),Cutout.Lo[lInc]); + Cutout.Hi[lInc] := IniInt(lIniFile,'CutoutHi'+inttostr(lInc),Cutout.Hi[lInc]); + end; + for lInc := 1 to 3 do begin + CutoutFrac.Lo[lInc] := IniInt(lIniFile,'CutoutLoFrac'+inttostr(lInc),-1); + CutoutFrac.Hi[lInc] := IniInt(lIniFile,'CutoutHiFrac'+inttostr(lInc),-1); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure TRenderForm.OpenRenderMRU(Sender:TObject); +var + lFilename: string; +begin + lFilename := gRenderDir+(Sender as TMenuItem).caption+'.ini' ; + ReadRenderIniFile(lFilename); + //07 CutoutForm.Prep; + UpdateRenderDisplay; +end; + +procedure TRenderForm.UpdateRenderMRU; +var + NewItem: TMenuItem; + lSearchRec: TSearchRec; +begin + While Settings1.Count > 0 do Settings1.Items[0].Free; + if FindFirst(gRenderDir+'*.ini', faAnyFile, lSearchRec) = 0 then + repeat + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ParseFileName(ExtractFileName(lSearchRec.Name)); + {$IFDEF FPC} + NewItem.onclick := OpenRenderMRU; //Lazarus + {$ELSE} + NewItem.onclick := OpenRenderMRU; + {$ENDIF} + Settings1.Add(NewItem); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end; + +Function AziElevMatrix: TMatrix; +var + lLRFlipMatrix: TMatrix; +begin + gRender.Azimuth := RenderForm.AzimuthEdit.value; + gRender.Elevation := RenderForm.ElevationEdit.value; + result := ViewTransformMatrix( + coordSpherical, + ToRadians(RenderForm.AzimuthEdit.Value), + ToRadians(RenderForm.ElevationEdit.Value), + 3{Distance.Value},6{ScreenWidthHeight.Value},6{ScreenWidthHeight.Value},{ScreenToCamera.Value}3); + {The ViewTransformMatrix is all that is needed for other objects defined + in world coordinates.} + if {RenderForm.FlipLRcheck.checked} gRender.FlipLR then begin + lLRFlipMatrix := Matrix3D (-1,0,0,0, // 3D "graphics" matrix + 0,1,0,0, + 0,0,1,0, + 0,0,0,0); + result := MultiplyMatrices(lLRFlipMatrix,Result); + end; + +end; + + +procedure InvertMatrixPoint (var lBackgroundImg: TBGImg; var lInMatrix: TMatrix; var lXin,lYin,lZIn, lXout,lYout,lZout: integer); +//convert mouse click to position +var + lZ,lY,lX,lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn: integer; + lMatrix: TMatrix; +begin + //lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutDim := round(gBGImg.RenderDim/gRender.Zoom) + else + lOutDim :=gBGImg.RenderDim; //11/2007b + lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (lBackgroundImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (lBackgroundImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (lBackgroundImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lX := (lXin-lOutPivot); + lY := ({lYin-}lOutPivot-lYin); + lZ := (lZin-lOutPivot); + lMatrix := InvertMatrix3D(lInMatrix); + lXout := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYout := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZout := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXOut := (lXOut+lXPivotIn); + lYOut := (lYOut+lYPivotIn); + lZOut := (lZOut+lZPivotIn); +end; + +procedure TRenderForm.Save1Click(Sender: TObject); +//this code is required for OSX Lazarus, not sure about Windows/Delphi +var +lOutImg: TImage; +begin + lOutImg := TImage.Create(ImgForm); + lOutImg.Width := RenderImage.Width; + lOutImg.Height := RenderImage.Height; + lOutImg.Canvas.Draw(0,0,RenderImage.Picture.Graphic); + SaveImgAsPNGBMP (lOutImg); + FreeAndNil (lOutImg); +end; + +(*procedure TRenderForm.Save1Click(Sender: TObject); +begin + //if (RenderImage.Picture.Graphic = nil) then begin + SaveImgAsPNGBMP (RenderImage); + ///xxxx +end;*) + +procedure TRenderForm.RenderImageMouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +end; + +procedure TRenderForm.Copy1Click(Sender: TObject); +{$IFDEF FPC} +var +lOutImg: TImage; +begin + lOutImg := TImage.Create(ImgForm); + lOutImg.Width := RenderImage.Width; + lOutImg.Height := RenderImage.Height; + lOutImg.Canvas.Draw(0,0,RenderImage.Picture.Graphic); + lOutImg.Picture.Bitmap.SaveToClipboardFormat(2); + Clipboard.Assign(lOutImg.Picture.Graphic); + FreeAndNil (lOutImg); +end; + +(*begin + {$IFDEF zxDarwin} + Showmessage('Copy not yet supported with OSX: use File/Save'); + exit; + {$ENDIF} + if (RenderImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + RenderImage.Picture.Bitmap.SaveToClipboardFormat(2); +end;*) +{$ELSE} +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (RenderImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + RenderImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); +end; +{$ENDIF} + + +procedure TRenderForm.RotationBMPMenuClick(Sender: TObject); +var + lnViews,lC,lAngle,lStartA: integer; + lZoom,lAzi: boolean; + lBaseFilename,lFilename: string; +begin + lnViews:= ReadIntForm.GetInt('How many bitmaps for a 360-degree rotation?', 4,24,72); + {$IFDEF ENDIAN_BIG} + ImgForm.SaveDialog1.Filter := 'Bitmap|*.xpm'; + ImgForm.SaveDialog1.DefaultExt := '.xpm'; + {$ELSE} + ImgForm.SaveDialog1.Filter := 'Bitmap|*.bmp'; + ImgForm.SaveDialog1.DefaultExt := '.bmp'; + {$ENDIF} + if not ImgForm.SaveDialog1.Execute then exit; + lBaseFilename := ImgForm.SaveDialog1.Filename; + lAzi := false; + case MessageDlg('Rotate azimuth?', mtConfirmation, + [mbYes, mbNo], 0) of + mrYes: lAzi := true; + end; //case + case MessageDlg('Generate super-sampled (high quality) renderings?', mtConfirmation, + [mbYes, mbNo], 0) of + mrYes: lZoom := true; + end; //case + + if lAzi then + lStartA := AzimuthEdit.value + else + lStartA := ElevationEdit.value; + for lC := 1 to lnViews do begin + lAngle := round((lC-1) * (360/lnviews)); + if lAzi then + AzimuthEdit.value := lAngle + else + ElevationEdit.value := lAngle - 180; + RenderRefreshTimer.enabled := false; + if lZoom then + gZoom := 2; + RefreshRotation; + DrawRender; + {$IFDEF ENDIAN_BIG} + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lAngle,3),'.xpm'); + {$ELSE} + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lAngle,3),'.bmp'); + {$ENDIF} + RenderImage.Picture.Bitmap.SaveToFile(lFilename); + //SaveImgAsPNGBMPCore(RenderImage,lFilename); + end; //for each of 36 views + if lAzi then + AzimuthEdit.value := lStartA + else + ElevationEdit.value := lStartA; + RenderRefreshTimer.enabled := false; + RefreshRotation; + DrawRender; +end; + +procedure TRenderForm.SaveClipMenuClick(Sender: TObject); +var + lStartClip,lnClips,lC: integer; + lBaseFilename,lFilename: string; + lStartTime: DWord; +begin + lStartClip := gRender.ClipFrac; + lnClips:= ReadIntForm.GetInt('How many bitmaps for a 360-degree rotation?', 4,24,200); + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + lBaseFilename := ImgForm.SaveDialog1.Filename; + lStartTime := GetTickCount; + for lC := 1 to lnClips do begin + gRender.ClipFrac := round( ((lC-1)/lnClips)*kMaxFrac ); + DrawRender; + refresh; + {$IFDEF ENDIAN_BIG} + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lC,3),'.xpm'); + {$ELSE} + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lC,3),'.bmp'); + {$ENDIF} + RenderImage.Picture.Bitmap.SaveToFile(lFilename); + + //SaveImgAsPNGBMPCore(RenderImage,lFilename); + end; //for each of 36 views + ImgForm.StatusLabel.caption :=('batchtime(ms): '+inttostr(GetTickCount-lStartTime)); + gRender.ClipFrac := lStartClip; +end; + + +procedure TRenderForm.Settings1Click(Sender: TObject); +begin + +end; + +procedure TRenderForm.BiasTrackChange(Sender: TObject); +begin + gRender.Bias := BiasTrack.position; + gRender.Gain := GainTrack.Position; + + RenderRefreshTimer.Enabled := true; + //RenderForm.caption := inttostr(BiasTrack.position)+'zzz'+inttostr(GainTrack.Position); +end; + +procedure TRenderForm.ClipTrackChange(Sender: TObject); +begin + gRender.ClipFrac := ClipTrack.Position; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderSmoothBGClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + + gRender.SmoothBG := RenderSmoothBG.checked; + gRender.SmoothOverlay := RenderSmoothOverlay.checked; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.Close1Click(Sender: TObject); +begin + RenderForm.Close; +end; + +procedure TRenderForm.N1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N01Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlaySurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N1voxel1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N16voxels2Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderSmoothClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gRender.FlipLR := FlipLRCheck.Checked; + //RenderSmoothSurface.checked := not RenderSmoothSurface.Checked; + gRender.SmoothBG := RenderSmoothBG.checked; + gRender.SmoothOverlay := RenderSmoothOverlay.checked; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderPreciseInterpolationClick(Sender: TObject); +begin + RenderPreciseInterpolation.Checked := not RenderPreciseInterpolation.Checked; + gRender.Trilinear := RenderPreciseInterpolation.Checked; + RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.FormShow(Sender: TObject); +var + lInc: integer; +begin + gRender.ClipFrac := 0; + gRender.Bias := 50; + gRender.Gain := 50; + gRender.cutoutLUTindex := 0; + gRender.BGSurface := 51; + gRender.OverlaySurface := 1; + gRender.BGDepth := 12; + gRender.OverlayDepth := 8; + gRender.Azimuth := 90; + gRender.Elevation := 45; + gRender.ShadePct := 0; + //gRender.OverlayNearClip := 0; + //gRender.BGNearClip := 0; + gRender.SmoothBG := true; + gRender.SmoothOverlay := false; + gRender.Trilinear := true; + gRender.FlipLR := false; + gRender.OverlayFromBGSurface := kBelow; + gRender.ShowCutout := false; + gRender.CutoutBias := 4; + {for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := gBGImg.ScrnDim[lInc] div 2; + gRender.Cutout.Hi[lInc] := gBGImg.ScrnDim[lInc]; + end;} + for lInc := 1 to 3 do begin + gRender.CutoutFrac.Lo[lInc] := kMaxFrac div 2; + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end; + ReadRenderIniFile (gRenderStartupFilename); + UpdateRenderMRU; + UpdateRenderDisplay; + RenderForm.BringToFront; +end; + + +function RAMok (var lBGImg: TBGImg): boolean; +var + lOutDim,lOutBytes,lBytesNeeded,lFreeRam: int64; + lBGSz,lC: integer; +begin + lBGSz := lBGImg.ScrnDim[1]*lBGImg.ScrnDim[2]*lBGImg.ScrnDim[3]; + lOutDim := round(MaxDim(lBGImg.ScrnDim[1],lBGImg.ScrnDim[2],lBGImg.ScrnDim[3]) * gRender.Zoom); + lOutBytes := lOutDim*lOutDim*lOutDim; + lBytesNeeded := 0; + for lC := 0 to knMaxOverlay do begin + if (gMRIcroOverlay[lC].ScrnBufferItems >= lBGSz) then begin + + lBytesNeeded := lBytesNeeded + (lOutBytes - gMRIcroOverlay[lC].RenderBufferItems); + end; + + end; + if (lBytesNeeded > freeRam) then begin + beep; + ImgForm.StatusLabel.Caption := 'Memory exhausted: unable to render at this quality'; + result := false; + + end else + result := true; +end; + +procedure TRenderForm.RefreshRotation; +var + lC: integer; + lMatrix: TMatrix; + lStartTime: DWord; +begin + lMatrix := AziElevMatrix; + {$IFNDEF FPC} //refresh causes flicker with lazarus + Application.processmessages; + Refresh; + {$ENDIF} + gRender.Zoom := gZoom; //11/2007b + gZoom := 1; + gRender.ClipFrac := ClipTrack.position; + gRender.Bias := BiasTrack.position; + gRender.Gain := GainTrack.Position; + gRender.Azimuth := round(AzimuthEdit.value); + gRender.Elevation := round(ElevationEdit.value); + + if not RAMok(gBGImg) then exit; + lStartTime := GetTickCount; + VolumeRotateMatrix (gBGImg, gMRIcroOverlay[0],lMatrix, gRender.Trilinear,gRender.ShowCutout,true{,round(gRender.BGNearClip*gRender.Zoom)}); + for lC := 1 to knMaxOverlay do + VolumeRotateMatrix (gBGImg, gMRIcroOverlay[lC],lMatrix, gRender.Trilinear,false,false{,round(gRender.OverlayNearClip*gRender.Zoom)}); +end; +var + gRendering: boolean = false; + +procedure TRenderForm.RenderRefreshTimerTimer(Sender: TObject); +begin + if gMRIcroOverlay[0].ScrnBufferItems=0 then begin + RenderRefreshTimer.Enabled := false; + RenderImage.Width := 0; + exit; + end; + if gRendering then exit; + RenderRefreshTimer.Enabled := false; + + gRender.ShadePct := ShadeEdit.value; + gRendering := true; + + if (gMRIcroOverlay[0].RenderBufferItems=0) or (RenderRefreshTimer.Tag <> 0) or (AzimuthEdit.value<>gRender.Azimuth) or (ElevationEdit.value<>gRender.Elevation) then + RefreshRotation; + //RenderRefreshTimer.Enabled := false; + (*if RenderRefreshTimer.Enabled then begin + gRendering := false; + exit; + end; *) + RenderRefreshTimer.Tag := 0; + + DrawRender; + //RenderRefreshTimer.Enabled := false; + gRendering := false; +end; + +procedure TRenderForm.EditChange(Sender: TObject); +begin + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.OverlayRenderDepthItem(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure RenderDrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +var lL,lT,lW,lH,lZoomPct: integer; +begin + lImage.Picture.Graphic := RenderForm.RenderImageBUP.Picture.Graphic; + {$IFNDEF Darwin} + //make sure next line required on this OS! + {$ENDIF} + lImage.Canvas.Draw(0,0,RenderForm.RenderImageBUP.Picture.Graphic); + //lImage.Picture.Bitmap := RenderForm.RenderImageBUP.Picture.Bitmap; //xxxx + //redraw image even if not drawing X-bar: hide visible X-bar if use toggles X-bars off. + if not ImgForm.XBarBtn.Down then + exit; //only draw xbars if requested + //lImage.Refresh; + lZoomPct := 100; //ImageZoomPct(lImage); + lL := (lHorPos * lZoomPct) div 100; + lT := (lVerPos * lZoomPct) div 100; + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + lImage.Canvas.Pen.Color:= gBGImg.XBarClr; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + //next horizontal lines + lImage.Canvas.MoveTo(0,lT); + lImage.Canvas.LineTo(lL-gBGImg.XBarGap,lT); + lImage.Canvas.MoveTo(lL+gBGImg.XBarGap,lT); + lImage.Canvas.LineTo(lW,lT); + //next vertical lines + lImage.Canvas.MoveTo(lL,0); + lImage.Canvas.LineTo(lL,lT-gBGImg.XBarGap); + lImage.Canvas.MoveTo(lL,lT+gBGImg.XBarGap); + lImage.Canvas.LineTo(lL,lH); +end; //Proc RenderDrawXBar + +procedure TRenderForm.RenderImageMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var lXrender,lYrender,lZrender,lXout,lYout,lZOut,lPixelOffset,lZoom: integer; +lMatrix: TMatrix; +begin + + RenderDrawXBar ( X,Y,RenderImage); + //Next: find coordinates for orthogonal views: + lZoom := ImageZoomPct(RenderImage); + lXrender := round((X*100) / lZoom ); + lYrender := round(((Y)*100) / lZoom ); + lPixelOffset := lXrender+ ((gBGImg.RenderDim-lYrender)*gBGImg.RenderDim); + //ImgForm.StatusLabel.caption := inttostr(lXrender)+'x'+inttostr(lYrender)+' -> '+inttostr(gMRIcroOverlay[kBGOverlayNum].RenderDepthBufferItems ); + if (lPixelOffset < 1) or (lPixelOffset >gBGImg.RenderDepthBufferItems ) then exit; + lZrender := gBGImg.RenderDepthBuffer^[lPixelOffset]; + + lXrender := round(lXrender / gRender.Zoom); + lYrender := round(lYrender / gRender.Zoom); + lZrender := round(lZrender / gRender.Zoom); + lMatrix := AziElevMatrix; + InvertMatrixPoint (gBGImg,lMatrix,lXrender,lYrender,lZrender, lXout,lYout,lZOut); + ImgForm.XViewEdit.value := lXOut; + ImgForm.YViewEdit.value := lYOut; + ImgForm.ZViewEdit.value := lZOut; + {$IFDEF FPC} + ImgForm.XViewEditChange(nil); + {$ENDIF} +end; + +procedure TRenderForm.Cutout1Click(Sender: TObject); +begin + CutoutForm.Show; +end; + +procedure TRenderForm.Savesettings1Click(Sender: TObject); +begin + //showmessage(gRenderDir+' '+extractfiledir(gRenderDir)); + MultiSliceForm.MultiSaveDialog.InitialDir := extractfiledir(gRenderDir); + MultiSliceForm.MultiSaveDialog.FileName := 'a'+inttostr(gRender.Azimuth)+'e'+inttostr(gRender.Elevation); + if not MultiSliceForm.MultiSaveDialog.Execute then exit; + {$IFDEF Unix} + WriteRenderIniFile(extractfiledir(gRenderDir)+pathdelim+extractfilename(MultiSliceForm.MultiSaveDialog.Filename)); + {$ELSE} + WriteRenderIniFile(MultiSliceForm.MultiSaveDialog.Filename); + {$ENDIF} + UpdateRenderMRU; +end; + +procedure TRenderForm.FormHide(Sender: TObject); +begin + WriteRenderIniFile (gRenderDefaultsFilename); + //not sure how to make this safe for currently rendering threads... + if gBGImg.RenderDepthBufferItems > 0 then + Freemem(gBGImg.RenderDepthBuffer); + gBGImg.RenderDepthBufferItems := 0; +end; + +procedure TRenderForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + Save1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Close1.ShortCut := ShortCut(Word('W'), [ssMeta]); + {$ENDIF} + gRenderDir := DefaultsDir('render'); + //showmessage(gRenderDir); + //gRenderDir := extractfiledir(paramstr(0))+pathdelim+'render'+pathdelim; + gRenderDefaultsFilename := gRenderDir + 'default.ini'; + gRenderStartupFilename := gRenderDefaultsFilename; + RenderForm.DoubleBuffered := true; +end; + +procedure TRenderForm.RefreshClick(Sender: TObject); +begin + gZoom := 2; + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end; + +procedure TRenderForm.SetSearch(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayFromBGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + + +{$IFDEF FPC} +initialization + {$I render.lrs} +{$ENDIF} + + +end. diff --git a/backup/render_composite.pas.bak b/backup/render_composite.pas.bak new file mode 100755 index 0000000..062a55c --- /dev/null +++ b/backup/render_composite.pas.bak @@ -0,0 +1,1078 @@ +unit render_composite; +interface +{$include isthreaded.inc} +uses +{$IFDEF Unix} +lclintf, //gettickcount +{$ELSE} +Windows, +{$ENDIF} +{$IFNDEF NoThreads} + RenderThds, +{$ELSE} +rendernothreads, +{$ENDIF} +{$IFDEF FPC} + LResources, //not sure if this is used... + {$ENDIF} + SysUtils, GraphicsMathLibrary,Classes, Graphics, Controls, Forms, Dialogs,ExtCtrls,Buttons, + nifti_img, nifti_hdr,define_types,nifti_img_view,StdCtrls, Menus,ClipBrd,ReadInt,cutout,IniFiles, + ComCtrls, nifti_types; +type + TRender = record + Zoom: single; + Cutout,CutoutFrac: TCutout; + //BGNearClipFrac, BGNearClip,OverlayNearClipFrac,OverlayNearClip, + ClipFrac, + Azimuth,Elevation,cutoutLUTindex,ShadePct, + OverlayFromBGSurface,BGSurface,OverlaySurface,BGDepth,OverlayDepth,CutoutBias,Gain,Bias: integer; + SmoothBG,SmoothOverlay,Trilinear,ShowCutout,FlipLR: boolean; + end; + procedure VolumeRotateMatrix (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean{;lNearSlicesClipIn: integer}); + procedure DrawRender; + procedure SliceToFrac(var lBGImg: TBGImg); + +var + + gRender:TRender; +const + kBelow = 1; + kInFront = 2; + +implementation + +uses math,render; + +procedure MinMaxFilt (var lHdr: TMRIcroHdr; var lFiltMin8bit, lFiltMax8bit: integer);var lMin,lMax: single; +begin +ReturnMinMax (lHdr,lMin,lMax, lFiltMin8bit, lFiltMax8bit); +end; + + +procedure Smooth2DImage (lX,lY: integer; lInBuffer: ByteP); +var + lSmoothBuffer: ByteP; + lLine,lLineStart,lInc,lOutPixel,lV: integer; +begin + GetMem (lSmoothBuffer , lX*lY); + FillChar(lSmoothBuffer^,lX*lY, 0); //zero array + for lLine:= (lY-1) downto 2 do begin + lLineStart := ((lLine-1)*(lX)); + for lInc := (lX-1) downto 2 do begin + lOutPixel := lLineStart+lInc; + lV := (lInBuffer^[lOutPixel] shl 3) + +(lInBuffer^[lOutPixel+1] shl 1)+(lInBuffer^[lOutPixel-1] shl 1) + +(lInBuffer^[lOutPixel+lX] shl 1)+(lInBuffer^[lOutPixel-lX] shl 1) + +(lInBuffer^[lOutPixel+lX+1])+(lInBuffer^[lOutPixel+lX-1]) + +(lInBuffer^[lOutPixel-lX+1])+(lInBuffer^[lOutPixel-lX-1]) + ; + lV := lV div 20; + lSmoothBuffer^[lOutPixel] := lV;//lV; + end; //for each column + end; //for each line (row) + Move(lSmoothBuffer^,lInBuffer^,lX*lY); + //Move(lSmoothBuffer^[1],lInBuffer[1]^,lX*lY); + FreeMem(lSmoothBuffer); +end; //proc Smooth2DImage + +procedure CreateOverlayRenderInfrontNear(var lBGHdr,lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDepth: Integer; var lQuadP: RGBQuadp; Smooth2D: boolean); +//changes Aug2007 - make sure search depth is not MAxInt - we get wrap around +var + lSrc,lOutBuffer: Bytep; + lLow,lHigh, + lIntensity,lDepth,lPixel,lSliceSz,lRenderSurface,lRenderDepth,lSamples: integer; +begin + if gBGImg.RenderDepthBufferItems < 1 then exit; + lSrc := lHdr.RenderBuffer;//lHdr.ScrnBuffer; + lSliceSz := lX*lY; + //lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lSliceSz); + fillchar(lOutBuffer^,lSliceSz,0); + lRenderSurface := lInRenderSurface; + RenderForm.caption := inttostr(lRenderSurface); + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1; + for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lIntensity := 0; + lSamples := 0; + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+1 + else + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+lInRenderDepth; + if lRenderDepth >= lX then + lRenderDepth := lX-1; + lDepth := ((lPixel-1)* lX)+1; + lRenderDepth := lDepth + lRenderDepth; + while (lDepth < lRenderDepth) do begin + if (lSrc^[lDepth] > lRenderSurface) then begin + lIntensity := lIntensity+lSrc^[lDepth]; + inc(lSamples); + end; + + inc(lDepth); + end; + if lSamples > 0 then + lOutBuffer^[lPixel]:= lIntensity div lSamples; + end; //for each pixel with a background image +end; //for each pixel + (*for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lDepth := 0; + lIntensity := 0; + lSliceOffset := 0; + lSamples := 0; + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+lInRenderDepth; + while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin + if (lSrc^[lSliceOffset+lPixel] > lRenderSurface) then begin + lIntensity := lIntensity+lSrc^[lSliceOffset+lPixel]; + inc(lSamples); + end; + inc(lSliceOffset,lSliceSz); + inc(lDepth); + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lDepth := lRenderDepth; //only show surface for cutout + end; + if lSamples > 0 then + lOutBuffer^[lPixel]:= lIntensity div lSamples; + end ; //if background + end; *) + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); +//Mar2007 start +if lHdr.LUTfromZero then begin + MinMaxFilt(lHdr,lLow,lHigh); + //fx(lLow,lHigh); + if lLow > 0 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lLow then + lOutBuffer^[lPixel] := 0; + if lHigh < 255 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lHigh then + lOutBuffer^[lPixel] := 0; +end; + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lHdr.LUT[lOutBuffer^[lPixel]]; + Freemem(lOutBuffer); +end; +procedure CreateOverlayRenderBehind(var lBGHdr,lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDepth: Integer; var lQuadP: RGBQuadp; Smooth2D: boolean); +var + lSrc,lOutBuffer: Bytep; + lLow,lHigh,lQ, + lSurfaceDepth,lIntensity,lDepth,lPixel,lSliceSz,lRenderSurface,lRenderDepth: integer; +begin + if gBGImg.RenderDepthBufferItems < 1 then exit; + lSrc := lHdr.RenderBuffer;//lHdr.ScrnBuffer; + lSliceSz := lX*lY; + //lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lSliceSz); + fillchar(lOutBuffer^,lSliceSz,0); + //lRenderDepth := lInRenderDepth; + //if (lRenderDepth < 1) or (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + // lRenderDepth := 1; + lRenderSurface := lInRenderSurface; + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1; + for lPixel := 1 to lSliceSz do begin + lSurfaceDepth := abs(gBGImg.RenderDepthBuffer^[lPixel]); + if (lSurfaceDepth > 0) and (lSurfaceDepth <= lX) then begin //background surface at this voxel + lIntensity := 0; + lRenderDepth := (lSurfaceDepth-1)+lInRenderDepth; + if lRenderDepth >= lX then + lRenderDepth := lX-1; + lDepth := ((lPixel-1)* lX)+1; + lRenderDepth := lDepth + lRenderDepth; + lDepth := lDepth + lSurfaceDepth-1; + lQ := 0; + while (lDepth < lRenderDepth) do begin + if (lSrc^[lDepth] > lRenderSurface) and (lSrc^[lDepth] > lIntensity) then + lIntensity := lSrc^[lDepth]; + //if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + if (gBGImg.RenderDepthBuffer^[lPixel] < 0) and (lQ > 3) then + lDepth := lRenderDepth; //only show surface for cutout + inc(lDepth); + inc(lQ); + end; + + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel with a background image +end; //for each pixel +//renderform.caption := inttostr(lQMax); + + (*for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lDepth := 0; + lIntensity := 0; + lSliceOffset := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)*lSliceSz; //start with nearest slice + while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin + if (lSrc^[lSliceOffset+lPixel] > lRenderSurface) and (lSrc^[lSliceOffset+lPixel] > lIntensity) then + lIntensity := lSrc^[lSliceOffset+lPixel]; + inc(lSliceOffset,lSliceSz); + inc(lDepth); + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lDepth := lRenderDepth; //only show surface for cutout + end; + lOutBuffer^[lPixel]:= lIntensity; + end; //background surface at this voxel + end; *) + + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); + +//Mar2007 start +if lHdr.LUTfromZero then begin + MinMaxFilt(lHdr,lLow,lHigh); + //fx(lLow,lHigh); + if lLow > 0 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lLow then + lOutBuffer^[lPixel] := 0; + if lHigh < 255 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lHigh then + lOutBuffer^[lPixel] := 0; +end; +//Mar2007 end + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lHdr.LUT[lOutBuffer^[lPixel]]; + Freemem(lOutBuffer); +end; + + +Function AziElevMatrix : TMatrix; +var + lLRFlipMatrix: TMatrix; +begin + // gRender.Azimuth := RenderForm.AzimuthEdit.value; + //gRender.Elevation := RenderForm.ElevationEdit.value; + result := ViewTransformMatrix( + coordSpherical, + ToRadians(gRender.Azimuth), + ToRadians(gRender.Elevation), + 3{Distance.Value},6{ScreenWidthHeight.Value},6{ScreenWidthHeight.Value},{ScreenToCamera.Value}3); + {The ViewTransformMatrix is all that is needed for other objects defined + in world coordinates.} + if {RenderForm.FlipLRcheck.checked} gRender.FlipLR then begin + lLRFlipMatrix := Matrix3D (-1,0,0,0, // 3D "graphics" matrix + 0,1,0,0, + 0,0,1,0, + 0,0,0,0); + result := MultiplyMatrices(lLRFlipMatrix,Result); + end; +end; + +procedure ShadeCutoutCrease (var lRenderBuffer: bytep); +var +lZ,lY,lX: single; + lXin,lYin,lZIn,lXm,lYm,lZm,lPixel, + lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn, + lXlo,lXhi,lYlo,lYhi,lZlo,lZhi,lYOffset: integer; + lClose,lScale: single; + lMatrix: TMatrix; +begin + lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutPivot := (round(gBGImg.RenderDim/gRender.Zoom)+1) shr 1 + else + lOutPivot :=(gBGImg.RenderDim+1) shr 1; //11/2007b + //lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (gBGImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (gBGImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (gBGImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lMatrix := InvertMatrix3D(AziElevMatrix); + //next: dilate borders by 1 pixel - draw crease INSIDE cutout + lXlo := gRender.CutOut.Lo[1]-1; + lXhi := gRender.CutOut.Hi[1]+1; + lYlo := gRender.CutOut.Lo[2]-1; + lYhi := gRender.CutOut.Hi[2]+1; + lZlo := gRender.CutOut.Lo[3]-1; + lZhi := gRender.CutOut.Hi[3]+1; +lScale := 1/gRender.Zoom; //11/2007 + + for lYin := 1 to lOutDim do begin + lYOffset := ((gBGImg.RenderDim-lYin)*gBGImg.RenderDim); + for lXin := 1 to lOutDim do begin + lPixel := lXin+ lYOffset; + if gBGImg.RenderDepthBuffer^[lPixel]<0 then begin + lZin := abs(gBGImg.RenderDepthBuffer^[lPixel]); + lX := (lXin *lScale)-lOutPivot ; + lY := lOutPivot -(lYin * lScale); + lZ := (lZin * lScale)-lOutPivot; + lXm := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYm := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZm := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXm := (lXm+lXPivotIn); + lYm := (lYm+lYPivotIn); + lZm := (lZm+lZPivotIn); + if abs(lXlo-lXm) < abs(lXhi-lXm) then + lXm := abs(lXlo-lXm) + else + lXm := abs(lXhi-lXm); + if abs(lYlo-lYm) < abs(lYhi-lYm) then + lYm := abs(lYlo-lYm) + else + lYm := abs(lYhi-lYm); + if abs(lZlo-lZm) < abs(lZhi-lZm) then + lZm := abs(lZlo-lZm) + else + lZm := abs(lZhi-lZm); + if (lXm < lYm) and (lZm < lYm) then + lYm := lZm //Y is furthest, replace with Z + else if lZm < lXm then //X is furthest, replace with Z + lXm := lZm; + lClose := sqrt((lXm*lXm) + (lYm*lYm)); + if lClose < 8 then begin + lClose := 1-sqr(1-(lClose/8)); + lRenderBuffer^[lPixel] := round(lRenderBuffer^[lPixel]*(0.33+(0.67*lClose))); + end; + end; + end; //for lYin + end; //for lXin +end; + +procedure LUTbiasX (var lOutLUT : TLUT); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick +Graphics Gems IV, p379-382, April 1994 } +var + lIndex: integer; + lA,lT,lBias: single; + lLUT: TLUT; +begin + if gRender.CutoutBias = 4 then exit; + lA := (gRender.CutoutBias+1)/10; + + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[round(lBias)]; + {lHdr.LUT[lIndex].rgbRed := round(lBias*lHdr.LUT[lIndex].rgbRed); + lHdr.LUT[lIndex].rgbGreen := round(lBias*lHdr.LUT[lIndex].rgbGreen); + lHdr.LUT[lIndex].rgbBlue := round(lBias*lHdr.LUT[lIndex].rgbBlue);} + //lHdr.LUT[lIndex].rgbReserved := kLUTalpha; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + +procedure LUTgainX (var lOutLUT : TLUT; lBiasIn,lGainIn: integer {0..99}); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick Graphics Gems IV, p379-382, April 1994 } +var + lIndex,lV: integer; + lA,lG,lT,lGain: single; + lLUT: TLUT; +begin + if (lGainIn = 50) and (lBiasIn = 50){gRender.CutoutBias = 4} then exit; + lA := (lBiasIn)/100; + if lA = 0 then + lA := 0.000001; + lG := (lGainIn)/100; + if lG = 0 then + lG := 0.00001; + if lG = 1 then + lG := 0.99999; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //apply bias + lT := (lt/((1/la-2)*(1-lt)+1)) ; + //next apply gain + if lT < 0.5 then + lGain := (lT/((1/lG-2)*(1-2*lT)+1)) + else + lGain := (( (1/lG-2)*(1-2*lT)-lT ) / ( (1/lG-2)*(1-2*lT)-1 ) ); + lGain := lGain / lT; + lV := round(255*lT*lGain); + if lV > 255 then + lV := 255; + if lV < 0 then + lV := 0; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[lV]; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + +function SmoothShading (lX,lY: integer; lRenderDepthBuffer: SmallintP): boolean; +var + kRenderInfiniteDepth,lPrevLineStart,lNextLineStart,lLineStart,lScanLines, + lGap,lDepthSum,lWeightSum,lFar,lClose,lCenter,lInc,lXmG: integer; + lRenderDepthBufferS: SmallIntP; +procedure AddPt (lI,lW: integer; var lSumI,lSumW: integer); +begin + if lI = kRenderInfiniteDepth then exit; + lSumI := lSumI + (lW*lI); //add scaled value + lSumW := lSumW + lW;//add weight +end; +//problem - smoothing gives embossed look! +begin //func Smoothshading + kRenderInfiniteDepth := 0; + result := false; + if (gRender.Zoom < 1) or (lY < 5) or (lX < 5) or (gBGImg.RenderDepthBufferItems <> (lX * lY)) then + exit; + lFar := 2; + lClose := 3; + lCenter := 5; + lGap := trunc((gRender.Zoom-0.001)/1)+1; //must be at least 1! + lXmG := lX-lGap; + Getmem(lRenderDepthBufferS,lX*lY*sizeof(smallint)); + for lInc := 1 to (lX*lY) do + lRenderDepthBufferS^[lInc] := lRenderDepthBuffer^[lInc]; + + for lScanlines := (1+lGap) to (lY - lGap) do begin //can not compute angle for 1st and last scanline + lLineStart := (lScanLines-1)*lX; //inc from 0 + lPrevLineStart := lLineStart-(lX*lGap); //inc from 0 + lNextLineStart := lLineStart+(lX*lGap); //inc from 0 + for lInc := (1+lGap) to (lXmG) do begin + lWeightSum := 0; + lDepthSum := 0; + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc-1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc+1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc-1],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc],lCenter,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc+1],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc-1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc+1],lFar,lDepthSum,lWeightSum); + if lWeightSum > 0 then + lRenderDepthBufferS^[lLineStart+lInc] := round(lDepthSum/lWeightSum); + end; //columns + end; //for scanlines: rows + for lInc := 1 to (lX*lY) do + lRenderDepthBuffer^[lInc] := lRenderDepthBufferS^[lInc]; + freemem(lRenderDepthBufferS); + result := true; +end; //function SmoothShading + + +function IlluminationShading (lX,lY,lPct: integer; lImgBuffer: bytep; lRenderDepthBuffer: SmallintP): boolean; +var + kRenderInfiniteDepth,lXm1,lPrevLineStart,lNextLineStart,lLineStart,lScanLines, + lIntensity,lInc,lGrayMin,lGrayMax: integer; + lShadeFrac,lImgFrac, + lPhongMagic,lMagic,lYVal,lXVal,lNormalPlane,lXLight,lYLight,lZLight,lLightVectorNormalise: single; + lShadeBuffer: bytep; +begin //func illumination shading + + result := false; + if (lPct < 1) or (lY < 5) or (lX < 5) or (gBGImg.RenderDepthBufferItems <> (lX * lY)) then + exit; + lMagic := 1; + lPhongMagic := 1; + kRenderInfiniteDepth := 0; + lXLight := 0;//RenderForm.XL.value / 100;//lXLight / lLightVectorNormalise; + lYLight := -0.5;//Renderform.YL.value / 100;//lYLight / lLightVectorNormalise; + lZLight := -1;//RenderForm.ZL.value / 100;//lZLight / lLightVectorNormalise; + lLightVectorNormalise := sqrt(sqr(lXLight)+sqr(lYLight)+sqr(lZLight)); + lXLight := lXLight / lLightVectorNormalise; + lYLight := lYLight / lLightVectorNormalise; + lZLight := lZLight / lLightVectorNormalise; + lGrayMin := 0{64}; + lGrayMax := 255 - lGrayMin; + lXm1 := lX-1; + Getmem(lShadeBuffer,lX*lY*sizeof(byte)); + fillchar(lShadeBuffer^,lX*lY,0); + + for lScanlines := 2 to (lY - 1) do begin //can not compute angle for 1st and last scanline + lLineStart := (lScanLines-1)*lX; //inc from 0 + lPrevLineStart := lLineStart-lX; //inc from 0 + lNextLineStart := lLineStart+lX; //inc from 0 + for lInc := 2 to (lXm1) do begin + if lImgBuffer^[lLineStart+lInc] <> 0 then begin //only shade non-zero intensities + if ( lRenderDepthBuffer^[lPrevLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lPrevLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lPrevLineStart+lInc+1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc+1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc+1]<>kRenderInfiniteDepth) then begin + lYVal := lRenderDepthBuffer^[lPrevLineStart+lInc-1]+lRenderDepthBuffer^[lPrevLineStart+lInc]+lRenderDepthBuffer^[lPrevLineStart+lInc+1] + -lRenderDepthBuffer^[lNextLineStart+lInc-1]-lRenderDepthBuffer^[lNextLineStart+lInc]-lRenderDepthBuffer^[lNextLineStart+lInc+1]; + lXVal := lRenderDepthBuffer^[lPrevLineStart+lInc-1]+lRenderDepthBuffer^[lLineStart+lInc-1]+lRenderDepthBuffer^[lNextLineStart+lInc-1] + -lRenderDepthBuffer^[lPrevLineStart+lInc+1]-lRenderDepthBuffer^[lLineStart+lInc+1]-lRenderDepthBuffer^[lNextLineStart+lInc+1]; + lNormalPlane := sqrt(sqr(lXVal)+sqr(lYVal)+sqr(lMagic)); + if lNormalPlane <> 0 then begin + lNormalPlane := -((-lXLight*lXVal)-(lYLight*lYVal)+lMagic*lZLight)/lNormalPlane; + if {lImageAndShade} false then begin + lNormalPlane := Power(lNormalPlane,lPhongMagic); + //lIntensity := gProjBuffer[lLineStart+lInc]; + //lIntensity := lPropShadingPivot+round((lPctImage*(lIntensity-lPropShadingPivot))+(lPctShade*(lNormalPlane-0.5)) ); + if lIntensity > 254 then lIntensity := 254; + lShadeBuffer^[lLineStart+lInc] := lIntensity; + end else begin //shading only + //if lAbbaRandom then //abba + lNormalPlane := (lNormalPlane+1) / 2; + if lNormalPlane > 0 then begin + lNormalPlane := Power(lNormalPlane,lPhongMagic); + //if lAbbaRandom then //abba + //if lNormalPlane < 0.5 then lNormalPlane := 1-lNormalPlane; //backlighting + lShadeBuffer^[lLineStart+lInc] := lGrayMin{64}+ round(lNormalPlane*(lGrayMax)); + end else + lShadeBuffer^[lLineStart+lInc] := lGrayMin; + end; //Shading vs ImageAndShading + end; //NormalPlane = 0 + end else begin //samples for each pixel + if {lImageAndShade}false then + lShadeBuffer^[lLineStart+lInc] := 0//lPropShadingPivot+round((lPctImage*(gProjBuffer[lLineStart+lInc]-lPropShadingPivot))+(lPctShade*(-0.5)) )//1362 + else + lShadeBuffer^[lLineStart+lInc] := lGrayMin;//1363;'# 20{64}; + end; + end; //only shade non-zero intensities + end; //columns + end; //for scanlines: rows + if lPct > 99 then begin + for lInc := 1 to (lX*lY) do + lImgBuffer^[lInc] := lShadeBuffer^[lInc]; + + end else begin //partial shade + lImgFrac := (100-lPct)/100; + lShadeFrac := lPct/100; + for lInc := 1 to (lX*lY) do + lImgBuffer^[lInc] := round((lImgBuffer^[lInc]* lImgFrac) + (lShadeBuffer^[lInc]*lShadeFrac )); + end; + freemem(lShadeBuffer); + result := true; +end; //function illuminationshading + +procedure LUTLoad( lLUTindex: integer; var lLUT: TLUT); +var + lHdr: TMRIcroHdr; + lStr: string; + lInc: integer; +begin + //gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + if lLUTindex < knAutoLUT then begin + LoadMonochromeLUT(lLUTindex,gBGImg,lHdr); + end else begin //if B&W lut + lStr := gColorSchemeDir+pathdelim+ImgForm.LUTdrop.Items.Strings[lLUTindex]+'.lut'; + if not FileExistsEX(lStr) then + showmessage('Can not find '+lStr); + LoadColorScheme(lStr, lHdr); + end; + for lInc := 0 to 255 do + lLUT[lInc] := lHdr.LUT[lInc]; +end; + + +procedure CreateRender(var lBGHdr, lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDpeth: Integer; var lQuadP: RGBQuadp; Smooth2D, NormalizeIntensity,lCreateDepthBuffer: boolean;lUseDepthBuffer: integer); +var + lLUT : array [0..255] of byte; + lrgbLUT: TLUT;// array[0..255] of TRGBQuad; + //lTime: DWord; + lSrc,lOutBuffer: Bytep; + lShade,lShadePrecise: boolean; + lPreciseDepthBuffer: Smallintp; + lMaxInten,lDepth,lPixel,lSamples,lSliceOffset,lIntensity,lSliceSz,lSliceEnd,lSliceStart, + lVolSz,lRenderDepth,lRenderSurface,lTemp,lNear,lSubPixel,lClip: integer; +begin + + lShade := false; + lShadePrecise := false; + if {(gRender.BGNearClip<>0) or} (gRender.ShowCutout) then + lMaxInten := 254 + else + lMaxInten := 257; + lRenderDepth := lInRenderDpeth; + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderDepth := 1; + lRenderSurface := lInRenderSurface; + //if not lCreateDepthBuffer then + + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1 + else begin + //make sure at least some voxels are below air-surface threshold + if (lHdr.WindowScaledMin <= (Raw2ScaledIntensity(lHdr,lHdr.GlMinUnscaledS) )) and (lHdr.WindowScaledMax <> 0 ) then begin + lTemp := round( (Raw2ScaledIntensity(lHdr,lHdr.GlMinUnscaledS)-lHdr.WindowScaledMin)/(lHdr.WindowScaledMax)*255); + //showmessage(inttostr(lTemp)); + if lTemp >= lRenderSurface then + lRenderSurface := lTemp + 1; + end; + end; + + if (lUseDepthBuffer=kBelow) then begin + CreateOverlayRenderBehind(lBGHdr,lHdr, lX,lY,lZ,lRenderSurface,lRenderDepth, lQuadP, Smooth2D); + exit; + end; + + if (lUseDepthBuffer=kInFront) then begin + CreateOverlayRenderInfrontNear(lBGHdr,lHdr, lX,lY,lZ,lRenderSurface,lRenderDepth, lQuadP, Smooth2D); + exit; + end; + lSrc := lHdr.RenderBuffer; + lSliceSz := lX*lY; + lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lX*lY); + //gRender.ClipFrac := kMaxFrac div 2; + lClip := round(gRender.ClipFrac/kMaxFrac * lX); + if lClip >= lX then + lClip := 0; + if lCreateDepthBuffer then begin + if (gRender.ShadePct > 0) then begin + lShade := true; + if lRenderDepth > 0 then begin//not MIP + lShadePrecise := true; + getmem(lPreciseDepthBuffer,lSliceSz * sizeof(smallint)); + fillchar(lPreciseDepthBuffer^,lSliceSz* sizeof(smallint),0); + end; + end; + if gBGImg.RenderDepthBufferItems <> lSliceSz then begin + if gBGImg.RenderDepthBufferItems > 0 then + Freemem(gBGImg.RenderDepthBuffer); + gBGImg.RenderDepthBufferItems := lSliceSz; + GetMem(gBGImg.RenderDepthBuffer,lSliceSz*sizeof(smallint)); + end; + fillchar(gBGImg.RenderDepthBuffer^,lSliceSz* sizeof(smallint),0); + //lTime := gettickcount; + if lRenderDepth < 1 then begin//MIP + for lPixel := 1 to lSliceSz do begin + lIntensity := 0; + lSliceStart := ((lPixel-1)* lX)+1; + lSliceOffset := lSliceStart+lClip; //start with nearest slice + lSliceEnd := lSliceStart + lX; + while (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and (lSrc^[lSliceOffset] > lIntensity) then begin + lIntensity := lSrc^[lSliceOffset]; + gBGImg.RenderDepthBuffer^[lPixel] := lSliceOffset - lSliceStart; + end; + inc(lSliceOffset,1); + end; //while traversing front to back + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel + end else begin //if MIP else use opacity filter... + for lPixel := 1 to lSliceSz do begin + lDepth := 0; + lSamples := 0; + lIntensity := 0; + lSliceStart := ((lPixel-1)* lX)+1; + lSliceOffset := lSliceStart+lClip; //start with nearest slice + lSliceEnd := (lPixel* lX); + while (lDepth < lRenderDepth) and (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and ((lDepth > 0) or (lSrc^[lSliceOffset] > lRenderSurface)) then begin + inc(lDepth); + if (lSrc^[lSliceOffset] > lRenderSurface) then begin + lIntensity := lIntensity+ lSrc^[lSliceOffset]; + inc(lSamples); + end; + if (lDepth = 1) then begin + gBGImg.RenderDepthBuffer^[lPixel] := lSliceOffset - lSliceStart; + + if (gBGImg.RenderDepthBuffer^[lPixel]=lCLip ) or ((gBGImg.RenderDepthBuffer^[lPixel] > 1) and (lSrc^[lSliceOffset-1]>=lMaxInten)) then begin //cutout + if lSrc^[lSliceOffset-1]=lMaxInten-1 then + lIntensity := 0; + lDepth := lRenderDepth; + gBGImg.RenderDepthBuffer^[lPixel] := -gBGImg.RenderDepthBuffer^[lPixel]; //negative: this is a cutout + end; + if lShade then begin + if (gBGImg.RenderDepthBuffer^[lPixel] > 1) then begin //estimate surface depth with sub-pixel accuracy + lNear := lSrc^[lSliceOffset-1]; + lSubPixel := lIntensity-lNear; //delta + lSubPixel := round(((lRenderSurface-lNear)/lSubPixel)*10); + if lNear >= lMaxInten then //cutout + lSubPixel := 0; + end else + lSubpixel := 0; + lPreciseDepthBuffer^[lPixel] := (gBGImg.RenderDepthBuffer^[lPixel] * 10)+lSubPixel; + end; + end; + end; + inc(lSliceOffset,1); + + end; //while no voxel found + if lDepth > 0 then + lIntensity := lIntensity div lSamples; + //lIntensity := lIntensity div lDepth; //mean of nDepth voxels + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel 1..sliceSz + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); //only smooth volume renderings - not MIPS (they looked embossed) + end; //if not MIP +end else begin //do not create depth buffer + for lPixel := 1 to lSliceSz do begin + lDepth := 0; + lSamples := 0; + lIntensity := 0; + lSliceOffset := ((lPixel-1)* lX)+1+lClip; //start with nearest slice + lSliceEnd := (lPixel* lX); + while (lDepth < lRenderDepth) and (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and ((lDepth > 0) or (lSrc^[lSliceOffset] > lRenderSurface)) then begin + inc(lDepth); + if (lSrc^[lSliceOffset] > lRenderSurface) then begin + lIntensity := lIntensity+ lSrc^[lSliceOffset]; + inc(lSamples); + end; + end; + inc(lSliceOffset,1); + end; //while no voxel found + if lDepth > 0 then + lIntensity := lIntensity div lSamples; + //lIntensity := lIntensity div lDepth; //mean of nDepth voxels + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel +end; //volume render without depth buffer + //RenderForm.Caption := inttostr(gettickcount - lTime)+' '+inttostr(lRenderDepth); + if (NormalizeIntensity) and (lRenderSurface < 254) then begin //do BEFORE shading! + for lPixel := 0 to 255 do + lLUT[lPixel] := 0; + for lPixel := lRenderSurface to 255 do + lLUT[lPixel] := round(255*(lPixel-lRenderSurface)/(255-lRenderSurface)); + for lPixel := 1 to lSliceSz do + lOutBuffer^[lPixel] := lLUT[lOutBuffer^[lPixel]]; + end; + if lShade then begin + if lShadePrecise then begin + SmoothShading (lX,lY,lPreciseDepthBuffer); + IlluminationShading(lX,lY,gRender.ShadePct,lOutBuffer,lPreciseDepthBuffer{gBGImg.RenderDepthBuffer} ); + freemem(lPreciseDepthBuffer); + end else + IlluminationShading(lX,lY,gRender.ShadePct,lOutBuffer,gBGImg.RenderDepthBuffer); + + end;//shading + + for lPixel := 0 to 255 do + lrgbLUT[lPixel] := lHdr.LUT[lPixel]; + if (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + LUTGainX(lrgbLUT,gRender.Bias,gRender.Gain ); //Mar2007 + + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lrgbLUT[lOutBuffer^[lPixel]]; + if ((lClip >0) or (gRender.ShowCutout)) and (lCreateDepthBuffer) then begin //make cutout grayscale, shade edges + if gRender.ShowCutout then + ShadeCutoutCrease(lOutBuffer); + LUTLoad(gRender.cutoutLUTindex,lrgblut);//11/2007 + {for lPixel := 0 to 255 do begin + lrgbLUT[lPixel].rgbRed := lPixel; + lrgbLUT[lPixel].rgbGreen := lPixel; + lrgbLUT[lPixel].rgbBlue := lPixel; + lrgbLUT[lPixel].rgbReserved := kLUTalpha; + + end;}//create grayscale LUT + LUTBiasX(lrgbLUT); + for lPixel := 1 to lSliceSz do + if gBGImg.RenderDepthBuffer^[lPixel]<0 then //cutout + lQuadP^[lPixel]:= lrgbLUT[lOutBuffer^[lPixel]]; + end; //if BGimg with Cutout + Freemem(lOutBuffer); +end; + +function RenderDepth (lVal: integer): integer;//11/2007 +begin + if (lVal > 0) and (lVal < 16000) and (gBGImg.ScrnMM[1] > 0.1) and (gBGImg.ScrnMM[1] < 10) then begin + result:= round (lVal / gBGImg.ScrnMM[1]); + if result < 1 then + result := 1; + end else + result := lVal; +result := round(result * gRender.Zoom); +end; + +procedure DrawRender; +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lUseBGSurface,lnOverlay,lOverlay, lX,lY,lZ,lSliceSz,lRenderSurface,lRenderDepth: longint; + lBG0Clr,lOverlay0Clr: DWord; + lSmooth : boolean; +begin + lRenderSurface := gRender.BGSurface; + //lRenderDepth:= gRender.BGDepth; + lRenderDepth:= RenderDepth(gRender.BGDepth);//11/2007 + lSmooth := gRender.SmoothBG; + lUseBGSurface := gRender.OverlayFromBGSurface ; + lX := gMRIcroOverlay[kBGOverlayNum].RenderDim; + lY := lX; + lZ := lX; + lSliceSz := (lX * lY); + if (gMRIcroOverlay[kBGOverlayNum].RenderBufferItems=0)or (lX < 2) or (lY < 2) or (lZ < 2) or ((lX*lY*lZ) > gMRIcroOverlay[kBGOverlayNum].RenderBufferItems{ScrnBufferItems}) then + exit; + GetMem ( lBGQuadP, lSliceSz*4); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[kBGOverlayNum], lX,lY,lZ,lRenderSurface,lRenderDepth, lBGQuadP, lSmooth, true,true,0); +//next: overlays + lSmooth := gRender.SmoothOverlay; + lRenderSurface := gRender.OverlaySurface; + //lRenderDepth:= gRender.OverlayDepth; + lRenderDepth:= RenderDepth(gRender.OverlayDepth);//11/2007 +lnOverlay := 0; +lBG0Clr:= TRGBQuad2DWord(gMRIcroOverlay[0].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].RenderBufferItems{ScrnBufferItems} > 0 then begin + if lOverlay = kVOIOverlayNum then //Aug2007 + lRenderSurface := 0 + else + lRenderSurface := gRender.OverlaySurface;// + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= TRGBQuad2DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay],lX,lY,lZ,lRenderSurface,lRenderDepth,lOverlayQuadP,lSmooth,false,false,lUseBGSurface); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay], lX,lY,lZ,lRenderSurface,lRenderDepth,l2ndOverlayQuadP,lSmooth,false,false,lUseBGSurface); + lOverlay0Clr:= TRGBQuad2DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + //lBG0Clr := DWord(lHdr.LUTinvisible); + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + SetDimension32(lY,lX, lBGQuadP, gBGImg, RenderForm.RenderImage, RenderForm.RenderPanel); + SetDimension32(lY,lX, lBGQuadP, gBGImg, RenderForm.RenderImageBUP, RenderForm.RenderPanel); + FreeMem ( lBGQuadP); + if gBGImg.RenderDepthBufferItems > 0 then //negative depth was used for cutouts, now set to true depth + for lX := 1 to gBGImg.RenderDepthBufferItems do + gBGImg.RenderDepthBuffer^[lX] := abs(gBGImg.RenderDepthBuffer^[lX]); +end; + +procedure SliceToFrac(var lBGImg: TBGImg); +var + lInc: integer; +begin + SortCutOut (gRender.CutOut); + for lInc := 1 to 3 do begin + if lBGImg.ScrnDim[lInc] < 1 then begin + gRender.CutoutFrac.Lo[lInc] := round (0.5* kMaxFrac); + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end else begin + gRender.CutoutFrac.Lo[lInc] := round(kMaxFrac * gRender.Cutout.Lo[lInc]/lBGImg.ScrnDim[lInc]); + gRender.CutoutFrac.Hi[lInc] := round(kMaxFrac * gRender.Cutout.Hi[lInc]/lBGImg.ScrnDim[lInc]); + end; + end; +end; + +procedure SetLimits(var lBGImg: TBGImg); +var lInc: integer; +lUpdateCutout: boolean; +lScale: single; +begin + SortCutOut (gRender.CutOutFrac); + if gRender.CutoutFrac.Lo[1] < 0 then + SliceToFrac(lBGImg); + lScale := 1/kMaxFrac; + for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := round(gBGImg.ScrnDim[lInc] * lScale * gRender.CutoutFrac.Lo[lInc]); + gRender.Cutout.Hi[lInc] := round(gBGImg.ScrnDim[lInc] * lScale * gRender.CutoutFrac.Hi[lInc]); + end; + lUpdateCutout := true; + for lInc := 1 to 3 do + if gRender.Cutout.Lo[lInc] <> gRender.Cutout.Hi[lInc] then lUpdateCutout := false; + if lUpdateCutout then + for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := gBGImg.ScrnDim[lInc] div 2; + gRender.Cutout.Hi[lInc] := gBGImg.ScrnDim[lInc]; + end; + for lInc := 1 to 3 do begin + if gRender.Cutout.Lo[lInc] < 1 then gRender.Cutout.Lo[lInc] := 1; + if gRender.Cutout.Lo[lInc] > lBGImg.ScrnDim[lInc] then gRender.Cutout.Lo[lInc] := lBGImg.ScrnDim[lInc]; + if gRender.Cutout.Hi[lInc] < 1 then gRender.Cutout.Hi[lInc] := 1; + if gRender.Cutout.Hi[lInc] > lBGImg.ScrnDim[lInc] then gRender.Cutout.Hi[lInc] := lBGImg.ScrnDim[lInc]; + end; +end; + +procedure VolumeRotateMatrix (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean {;lNearSlicesClipIn: integer}); +label 345; +const + kUgly2 = 10000; + //kSh = 10; //bits to shift + kUgly1 = (kUgly2 shl kSh) + (1 shl kSh); +var + + l: TRotateVals; + lZinc,lZ,lY,lX,lOutVolSz, + lOutPos,lInVolSz, + lYo,lZo,lnThreads: integer; + lBuffIn,lSrcBuff,lBuffOut: Bytep; + lXxp,lXyp,lXzp: Pointer; + lStartTime: DWord; + lM, lScale,lMatrix: TMatrix; + lZoomRatio: Single; + begin + + lMatrix := lMatrixIn; + + if (gRender.Zoom <> 0) and (gRender.Zoom <> 1 )then begin + lZoomRatio := 1/gRender.Zoom; + lScale := Matrix3D(lZoomRatio,0,0,0, 0,lZoomRatio,0,0, 0,0,lZoomRatio,0, 0,0,0,0); + lMatrix := MultiplyMatrices(lMatrixIn,lScale); + end else + gRender.Zoom := 1; + //lScale := Matrix3D(0,1,0,0, 1,0,0,0, 0,0,1,0, 0,0,0,0); + //lScale := Matrix3D(0,1,0,0, 0,0,1,0, 1,0,0,0, 0,0,0,0); + lScale := Matrix3D(0,1,0,0, 0,0,1,0, 1,0,0,0, 0,0,0,0); + lMatrix := MultiplyMatrices(lMatrix,lScale); + lStartTime := GetTickCount; + l.XdimIn := lBGImg.ScrnDim[1]; + l.YdimIn := lBGImg.ScrnDim[2]; + l.ZdimIn := lBGImg.ScrnDim[3];; + l.InSliceSz := l.XDimIn*l.YDimIn; + lInVolSz := l.XdimIn*l.YdimIn*l.ZdimIn; //InVolSz! + if (lHdr.ScrnBufferItems < lInVolSz) then + exit; + lSrcBuff := lHdr.ScrnBuffer; + l.OutDim := MaxDim(l.XDimIn,l.YDimIn,l.ZDimIn); + l.OutDim := round(gRender.Zoom * l.OutDim); //11/2007 + (*lNearSlicesClip := lNearSlicesClipIn;//May07 + if lNearSlicesClip >= l.OutDim then //May07 + lNearSlicesClip := 0; //May07*) + lBGImg.RenderDim := l.OutDim; + lHdr.RenderDim := l.OutDim; + //l.RenderCutout := false; + RenderForm.caption := '2w'+inttostr(222); + if (lRenderCutout) then begin + //l.RenderCutout := true; + + SetLimits(lBGImg); + GetMem(lBuffIn, lInVolSz); + Move(lSrcBuff^,lBuffIn^,lInVolSz); + for lZ := 1 to lInVolSz do + if lBuffIn^[lZ] >= 254 then lBuffIn^[lZ] := 253; + if lRenderCutout then begin + + for lZ := gRender.Cutout.Lo[3] to gRender.Cutout.Hi[3] do begin + lZo := (lZ-1) * l.InSliceSz; + Application.ProcessMessages; + for lY := gRender.Cutout.Lo[2] to gRender.Cutout.Hi[2] do begin + lYo := (lY-1) * l.XdimIn; + for lX := gRender.Cutout.Lo[1] to gRender.Cutout.Hi[1] do + lBuffIn^[lX+lYo+lZo] := 255; + end; //for lY + end; //for lZ + end; + end else + lBuffIn := lSrcBuff; + l.OutPivot := (lHdr.RenderDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + l.XPivotIn := ((l.XdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.YPivotIn := ((l.YdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.ZPivotIn := ((l.ZdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.YDimStart := -l.OutPivot+1; //e.g. if 9, start from -4 + l.ZDimStart := l.YDimStart ; + + l.YDimEnd := l.YDimStart+lHdr.RenderDim-1; //e.g. if 9, go to 4 + l.ZDimEnd := l.YDimEnd; + if l.ZDimStart >= l.ZDimEnd then + l.ZDImStart := l.ZDimStart; + l.OutSliceSz := sqr(lHdr.RenderDim); + lOutVolSz := lHdr.RenderDim*l.OutSliceSz; + RenderForm.caption := '3w'+inttostr(222); + if lHdr.RenderBufferItems <> lOutVolSz then begin + if lHdr.RenderBufferItems > 0 then + Freemem(lHdr.RenderBuffer); + lHdr.RenderBufferItems := lOutVolSz; + try + GetMem(lHdr.RenderBuffer,lOutVolSz); + except //12/2007 + showmessage('Volume Rotate Error: System memory exhausted.'); + lHdr.RenderBufferItems := 0; + exit; + end; + + end; + lBuffOut := lHdr.RenderBuffer; + fillchar(lBuffOut^,lOutVolSz,0); //set all to zero + + //lMatrix := InvertMatrix3D(lMatrix); + lZ := (sizeof(longint)* l.OutDim)+16; + GetMem(lXxp, lZ); + GetMem(lXyp, lZ); + GetMem(lXzp, lZ); +// if RenderForm.RenderRefreshTimer.enabled then goto 345;//abort + {$IFNDEF FPC} + l.XxRA := LongIntP($fffffff0 and (integer(lXxP)+15)); //data aligned to quad-word boundary + l.XyRA := LongIntP($fffffff0 and (integer(lXyP)+15)); //quad-word boundary + l.XzRA := LongIntP($fffffff0 and (integer(lXzP)+15)); //quad-word boundary} + {$ELSE} + l.XxRA := system.align(lXxP, 16); //data aligned to quad-word boundary + l.XyRA := system.align(lXyP, 16); //quad-word boundary + l.XzRA := system.align(lXzP, 16); //quad-word boundary + {$ENDIF} + for lX := 1 to l.OutDim do begin + l.XxRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[1,1]* (1 shl kSh) )+kUgly1; + l.XyRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[2,1]* (1 shl kSh) )+kUgly1; + l.XzRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[3,1]* (1 shl kSh) )+kUgly1; + end; + l.XPivotInU2 := l.XPivotIn-kUgly2; + l.YPivotInU2 := l.YPivotIn-kUgly2; + l.ZPivotInU2 := l.ZPivotIn-kUgly2; + + {$IFNDEF NoThreads} + lnThreads := gnCPUThreads; + {$ELSE} + lnThreads := 1; + {$ENDIF} + //if lIsBG then + //TextForm.Memo1.Lines.Add( 'bg'+(inttostr(RenderForm.ThreadsRunning)+' '+inttostr(lnThreads))) + + //else + //TextForm.Memo1.Lines.Add( 'xx'+(inttostr(RenderForm.ThreadsRunning)+' '+inttostr(lnThreads))); + lZ := l.ZDimStart; + lZo := l.ZDimEnd; + lZinc := (l.ZDimEnd - l.ZDimStart) div lnThreads; + l.ZDimEnd := l.ZDimStart + lZinc; + //showmessage( inttostr(l.ZDimStart)+'..'+inttostr(l.ZDimEnd) +' '+inttostr(lZo)); + if l.ZDimEnd > ImgForm.ProgressBar1.Min then begin //crashes if max < min, so write order important... + ImgForm.ProgressBar1.Max := l.ZDimEnd+1; + ImgForm.ProgressBar1.Min := l.ZDimStart; + end else begin + ImgForm.ProgressBar1.Min := l.ZDimStart; + ImgForm.ProgressBar1.Max := l.ZDimEnd+1; + + end; +{$IFNDEF NoThreads} + Application.processmessages; + for lX := 1 to lnThreads do begin + if lX = lnThreads then + l.ZDimEnd := lZo; //avoid integer rounding error + //TextForm.Memo1.Lines.Add('+'+inttostr(lX)); + if (lBilinearSmooth) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + TTriRender.Create(ImgForm.ProgressBar1,lX,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut) + else + TNNRender.Create(ImgForm.ProgressBar1,lX,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut); + inc(ThreadsRunning); + l.ZDimStart := l.ZDimEnd + 1; + l.ZDimEnd := l.ZDimEnd + lZInc; + + end; //for each thread + l.ZDimStart := lZ; + + repeat + Application.processmessages; + until ThreadsRunning = 0; + Application.processmessages; +{$ELSE}//not threaded + l.ZDimEnd := lZo; //avoid integer rounding error + if (lBilinearSmooth) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + TriRotate(ImgForm.ProgressBar1,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut) + else + NNRotate(ImgForm.ProgressBar1,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut); +{$ENDIF} + + + FreeMem(lXxp); + FreeMem(lXyp); + FreeMem(lXzp); + if (lRenderCutout) then begin + FreeMem(lBuffIn); + end; + ImgForm.ProgressBar1.Position := l.ZDimStart; + ImgForm.StatusLabel.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); +end; //proceudre VolumeRotate; + +end. diff --git a/backup/reslice_img.pas.bak b/backup/reslice_img.pas.bak new file mode 100755 index 0000000..0c47347 --- /dev/null +++ b/backup/reslice_img.pas.bak @@ -0,0 +1,548 @@ +unit reslice_img; +//12 April 2009 - added lTrilinearSmooth option to allow nearest neighbor interpolation +interface +uses +{$ifndef fpc}{windows,} {$endif} +GraphicsMathLibrary,nifti_hdr, nifti_types; +function Reslice_Img_To_Unaligned (var lTargHdr: TNIfTIhdr; var lSrcHdr: TMRIcroHdr; lTrilinearSmoothIn: boolean): boolean; +function Hdr2InvMat (lHdr: TNiftiHdr; var lOK: boolean): TMatrix; +procedure Voxel2mm(var X,Y,Z: single; var lHdr: TNIfTIHdr); +procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +implementation + + + +uses dialogs, define_types, SysUtils; + + +function Hdr2Mat (lHdr: TNIFTIhdr): TMatrix; +begin + Result := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], // 3D "graphics" matrix + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], // 3D "graphics" matrix + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); +end; + +(*procedure ReportMatrix (lM:TMatrix); +const + kCR = chr (13); +begin + showmessage(RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+kCR+ + RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+kCR+ + RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+kCR + +RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6) + ); +end; *) + +(* +procedure SPMmat(var lDestMat: TMatrix); +//SPM matrices are indexed from 1 +//This function is only useful for direct comparisons with SPM +var + lTemp,lVS: TMatrix; +begin + lVS := Matrix3D (1,0,0,-1, + 0,1,0,-1, + 0,0,1,-1, 0,0,0,1);//VoxelShift + lTemp := lDestMat; + lDestMat := MultiplyMatrices(lTemp,lVS); +end;*) + +procedure Coord(var lV: TVector; var lMat: TMatrix); +//transform X Y Z by matrix +var + lXi,lYi,lZi: single; +begin + lXi := lV.x; lYi := lV.y; lZi := lV.z; + lV.x := (lXi*lMat.matrix[1][1]+lYi*lMat.matrix[1][2]+lZi*lMat.matrix[1][3]+lMat.matrix[1][4]); + lV.y := (lXi*lMat.matrix[2][1]+lYi*lMat.matrix[2][2]+lZi*lMat.matrix[2][3]+lMat.matrix[2][4]); + lV.z := (lXi*lMat.matrix[3][1]+lYi*lMat.matrix[3][2]+lZi*lMat.matrix[3][3]+lMat.matrix[3][4]); +end; + +procedure Transposemat(var lMat: TMatrix); +var + lTemp: TMatrix; + i,j: integer; +begin + lTemp := lMat; + for i := 1 to lMat.size do + for j := 1 to lMat.size do + lMat.matrix[i,j] := lTemp.matrix[j,i]; +end; + +function gaussj(VAR a: TMatrix): boolean;//Invert a Matrix - see Numerical Recipes +label + 666; +VAR + big,dum,pivinv: real; + n,i,icol,irow,j,k,l,ll: integer; + indxc,indxr,ipiv: array [1..4] of integer; +BEGIN + result := true; + icol := 1;//not used - avoids compiler warning + irow := 1;//not used - avoids compiler warning + n := a.size; + FOR j := 1 TO n DO BEGIN + ipiv[j] := 0 + END; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO BEGIN + IF (ipiv[j] <> 1) THEN BEGIN + FOR k := 1 TO n DO BEGIN + IF (ipiv[k] = 0) THEN BEGIN + IF (abs(a.matrix[j,k]) >= big) THEN BEGIN + big := abs(a.matrix[j,k]); + irow := j; + icol := k + END + END ELSE IF (ipiv[k] > 1) THEN BEGIN + goto 666; + END + END + END + END; + ipiv[icol] := ipiv[icol]+1; + IF (irow <> icol) THEN BEGIN + FOR l := 1 TO n DO BEGIN + dum := a.matrix[irow,l]; + a.matrix[irow,l] := a.matrix[icol,l]; + a.matrix[icol,l] := dum + END; + END; + indxr[i] := irow; + indxc[i] := icol; + IF (a.matrix[icol,icol] = 0.0) THEN + goto 666; + pivinv := 1.0/a.matrix[icol,icol]; + a.matrix[icol,icol] := 1.0; + FOR l := 1 TO n DO BEGIN + a.matrix[icol,l] := a.matrix[icol,l]*pivinv + END; + FOR ll := 1 TO n DO BEGIN + IF (ll <> icol) THEN BEGIN + dum := a.matrix[ll,icol]; + a.matrix[ll,icol] := 0.0; + FOR l := 1 TO n DO BEGIN + a.matrix[ll,l] := a.matrix[ll,l]-a.matrix[icol,l]*dum + END; + END + END + END; + FOR l := n DOWNTO 1 DO BEGIN + IF (indxr[l] <> indxc[l]) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a.matrix[k,indxr[l]]; + a.matrix[k,indxr[l]] := a.matrix[k,indxc[l]]; + a.matrix[k,indxc[l]] := dum + END + END + END; + exit; + 666: //only get here if there is an error + Showmessage('error in reslice_img - singular matrix. Spatial orientation is ambiguous.'); + a := Eye3D; + result := false; +END; + +procedure SubVec (var lVx: TVector; lV0: TVector); +begin + lVx.x := lVx.x - lV0.x; + lVx.y := lVx.y - lV0.y; + lVx.z := lVx.z - lV0.z; +end; + +(*procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +//returns voxels indexed from 1 not 0! +var + lV: TVector; + lSrcMatInv,lSrcMat: TMatrix; +begin + lV := Vector3D (X,Y,Z); + lV := Transform (lV,lInvMat); + X := lV.x+1; + Y := lV.y+1; + Z := lV.z+1; +end;*) + +procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +//returns voxels indexed from 1 not 0! +var + lV: TVector; + lSrcMatInv,lSrcMat: TMatrix; +begin + lV := Vector3D (X,Y,Z); + Coord (lV,lInvMat); + X := lV.x+1; + Y := lV.y+1; + Z := lV.z+1; +end; + +procedure Voxel2mm(var X,Y,Z: single; var lHdr: TNIfTIHdr); +var + lV: TVector; + lMat: TMatrix; +begin + //lV := Vector3D (X-1,Y-1,Z-1); + lV := Vector3D (X-1,Y-1,Z-1); + lMat := Hdr2Mat(lHdr); + Coord(lV,lMat); + X := lV.x; + Y := lV.y; + Z := lV.z; +end; + +function Voxel2Voxel (var lDestHdr,lSrcHdr: TNIFTIhdr): TMatrix; +//returns matrix for transforming voxels from one image to the other image +//results are in VOXELS not mm +var + lV0,lVx,lVy,lVz: TVector; + lDestMat,lSrcMatInv,lSrcMat: TMatrix; + +begin + //Step 1 - compute source coordinates in mm for 4 voxels + //the first vector is at 0,0,0, with the + //subsequent voxels being left, up or anterior + lDestMat := Hdr2Mat(lDestHdr); + //SPMmat(lDestMat); + lV0 := Vector3D (0,0,0); + lVx := Vector3D (1,0,0); + lVy := Vector3D (0,1,0); + lVz := Vector3D (0,0,1); + Coord(lV0,lDestMat); + Coord(lVx,lDestMat); + Coord(lVy,lDestMat); + Coord(lVz,lDestMat); + lSrcMat := Hdr2Mat(lSrcHdr); + //SPMmat(lSrcMat); + lSrcMatInv := lSrcMat; + gaussj(lSrcMatInv); + //the vectors should be rows not columns.... + //therefore we transpose the matrix + Transposemat(lSrcMatInv); + //the 'transform' multiplies the vector by the matrix + lV0 := Transform (lV0,lSrcMatInv); + lVx := Transform (lVx,lSrcMatInv); + lVy := Transform (lVy,lSrcMatInv); + lVz := Transform (lVz,lSrcMatInv); + //subtract each vector from the origin + // this reveals the voxel-space influence for each dimension + SubVec(lVx,lV0); + SubVec(lVy,lV0); + SubVec(lVz,lV0); + result := Matrix3D(lVx.x,lVy.x,lVz.x,lV0.x, + lVx.y,lVy.y,lVz.y,lV0.y, + lVx.z,lVy.z,lVz.z,lV0.z, 0,0,0,1); +end; + +procedure CopyHdrMat(var lTarg,lDest: TNIfTIHdr); +//destination has dimensions and rotations of destination +var + lI: integer; +begin + //destination will have dimensions of target + lDest.dim[0] := 3; //3D + for lI := 1 to 3 do + lDest.dim[lI] := lTarg.dim[lI]; + lDest.dim[4] := 1; //3D + //destination will have pixdim of target + for lI := 0 to 7 do + lDest.pixdim[lI] := lTarg.pixdim[lI]; + lDest.xyzt_units := lTarg.xyzt_units; //e.g. mm and sec + lDest.qform_code := lTarg.qform_code; + lDest.sform_code := lTarg.sform_code; + lDest.quatern_b := lTarg.quatern_b; + lDest.quatern_c := lTarg.quatern_c; + lDest.quatern_d := lTarg.quatern_d; + lDest.qoffset_x := lTarg.qoffset_x; + lDest.qoffset_y := lTarg.qoffset_y; + lDest.qoffset_z := lTarg.qoffset_z; + for lI := 0 to 3 do begin + lDest.srow_x[lI] := lTarg.srow_x[lI]; + lDest.srow_y[lI] := lTarg.srow_y[lI]; + lDest.srow_z[lI] := lTarg.srow_z[lI]; + end; +end; + +function OneToOne(lM:TMatrix): boolean; +var + lC,lR: integer; +begin + result := false; + for lC := 1 to 3 do + for lR := 1 to 3 do + if (lM.matrix[lC,lR] <> 0) and ((abs(lM.matrix[lC,lR])- 1) > 0.00001) then + exit; + result := true; +end; + + function Reslice_Img_To_Unaligned (var lTargHdr: TNIfTIhdr; var lSrcHdr: TMRIcroHdr; lTrilinearSmoothIn: boolean): boolean; +var + lXrM1,lYrM1,lZrM1,lZx,lZy,lZz,lYx,lYy,lYz,lXreal,lYreal,lZreal: single; + lXo,lYo,lZo,lMinY,lMaxY,lMinZ,lMaxZ, + lPos,lXs,lYs,lZs,lXYs,lXYZs,lX,lY,lZ,lOutVolItems, + lXi,lYi,lZi: integer; + lDestHdr: TNIFTIhdr; + lMat: TMatrix; + lTrilinearSmooth,lOverlap: boolean; + lXx,lXy,lXz: Singlep0; + l32fs,l32f : SingleP; + l16is,l16i : SmallIntP; + l8i,l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned,lBuffOutUnaligned: bytep; +begin + lTrilinearSmooth := lTrilinearSmoothIn; + result := false; + lOverlap := false; + lDestHdr := lSrcHdr.NIfTIHdr; //destination has the comments and voxel BPP of source + CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + lXs := lSrcHdr.NIfTIHdr.Dim[1]; + lYs := lSrcHdr.NIfTIHdr.Dim[2]; + lZs := lSrcHdr.NIfTIHdr.Dim[3]; + + lXYs:=lXs*lYs; //slicesz + lXYZs := lXYs*lZs; + lX := lDestHdr.Dim[1]; + lY := lDestHdr.Dim[2]; + lZ := lDestHdr.Dim[3]; + lOutVolItems :=lX*lY*lZ; + if lSrcHdr.ImgBufferBPP = 4 then begin + l32fs := SingleP(lSrcHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + {$IFDEF FPC} + l32f := align(lBuffOutUnaligned,16); + {$ELSE} + l32f := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + {$ENDIF} + for lPos := 1 to lOutVolItems do + l32f^[lPos] := 0; //set all to zero + end else if lSrcHdr.ImgBufferBPP = 2 then begin + l16is := SmallIntP(lSrcHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + {$IFDEF FPC} + l16i := align(lBuffOutUnaligned,16); + {$ELSE} + l16i := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + {$ENDIF} + for lPos := 1 to lOutVolItems do + l16i^[lPos] := 0; //set all to zero + end else if lSrcHdr.ImgBufferBPP = 1 then begin + l8is := ByteP(lSrcHdr.ImgBuffer); + GetMem(l8i,lOutVolItems); + Fillchar(l8i^,lOutVolItems,0); //set all to zero + end; + lMat := Voxel2Voxel (lTargHdr,lSrcHdr.NIfTIHdr); + //lDestHdr := lSrcHdr; //destination has the comments and voxel BPP of source + //CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + //now we can apply the transforms... + //build lookup table - speed up inner loop + getmem(lXx, lX*sizeof(single)); + getmem(lXy, lX*sizeof(single)); + getmem(lXz, lX*sizeof(single)); + for lXi := 0 to (lX-1) do begin + lXx^[lXi] := lXi*lMat.matrix[1][1]; + lXy^[lXi] := lXi*lMat.matrix[2][1]; + lXz^[lXi] := lXi*lMat.matrix[3][1]; + end; + lPos := 0; + showmessage(format('%g %g %g; %g %g %g; %g %g %g', [ + lMat.matrix[1,1], lMat.matrix[1,2], lMat.matrix[1,3], + lMat.matrix[2,1], lMat.matrix[2,2], lMat.matrix[2,3], + lMat.matrix[3,1], lMat.matrix[3,2], lMat.matrix[3,3]])); + if lTrilinearSmooth then showmessage('ats') else showmessage('ann'); + if (lTrilinearSmooth) and (OneToOne(lMat)) then + lTrilinearSmooth := false; + if lTrilinearSmooth then showmessage('bts') else showmessage('bnn'); +if lTrilinearSmooth then begin//compute trilinear interpolation + //compute trilinear interpolation + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + lXreal := (lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYreal := (lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZreal := (lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXreal >= 0) and (lYreal >= 0) and (lZreal >= 0) and + (lXreal < (lXs -1)) and (lYreal < (lYs -1) ) and (lZreal <= (lZs -1)) //June09 lZReal <= instead of < + then begin + //compute the contribution for each of the 8 source voxels + //nearest to the target + lOverlap := true; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := lYo*lXs; + lMinZ := lZo*lXYs; + lMaxY := lMinY+lXs; + inc(lXo);//images incremented from 1 not 0 + //Check if sample is perfectly in the Z-plane. + //This requires only 8 samples, so its faster + //in addition, for very thin volumes, it allows us to sample to the edge + if lZReal = 0 then begin // perfectly in plane, only sample 4 voxels near each other + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] := + round ( ( (lXrM1*lYrM1)*l8is^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l8is^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l8is^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l8is^[lXo+1+lMaxY+lMinZ])); + 2: l16i^[lPos] := + round (( (lXrM1*lYrM1)*l16is^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l16is^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l16is^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l16is^[lXo+1+lMaxY+lMinZ])); + 4: l32f^[lPos] := + ( (lXrM1*lYrM1)*l32fs^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l32fs^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l32fs^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l32fs^[lXo+1+lMaxY+lMinZ]); + end; //case + end else begin //not perfectly in plane... we need 8 samples... + lMaxZ := lMinZ+lXYs; + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] := + round ({all min} ( (lXrM1*lYrM1*lZrM1)*l8is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l8is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l8is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l8is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l8is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l8is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l8is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l8is^[lXo+1+lMaxY+lMaxZ]) ); + 2:l16i^[lPos] := + round ({all min} ( (lXrM1*lYrM1*lZrM1)*l16is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l16is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l16is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l16is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l16is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l16is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l16is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l16is^[lXo+1+lMaxY+lMaxZ]) ); + 4: l32f^[lPos] := + {all min} ( (lXrM1*lYrM1*lZrM1)*l32fs^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l32fs^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l32fs^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l32fs^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l32fs^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l32fs^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l32fs^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l32fs^[lXo+1+lMaxY+lMaxZ]) ; + end; //case + end; //not perfectly in plane + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z +end else begin //if trilinear, else nearest neighbor +//nearest neighbor - added 12 April 2009 + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + lXo := round(lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYo := round(lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZo := round(lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXo >= 0) and (lYo >= 0{1}) and (lZo >= 0{1}) and + (lXo < (lXs)) and (lYo < (lYs) ) and (lZo < (lZs)) + //2012 removed -1 for nearest neighbor (lXo < (lXs -1)) and (lYo < (lYs -1) ) and (lZo < (lZs)) + then begin + lOverlap := true; + inc(lXo);//images incremented from 1 not 0 + lYo := lYo*lXs; + lZo := lZo*lXYs; + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] :=l8is^[lXo+lYo+lZo]; + 2: l16i^[lPos] :=l16is^[lXo+lYo+lZo]; + 4: l32f^[lPos] :=l32fs^[lXo+lYo+lZo] ; + end; //case + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z +//end nearest neighbor +end; + + //release lookup tables + freemem(lXx); + freemem(lXy); + freemem(lXz); + //check to see if image is empty... + if not lOverlap then + Showmessage('No overlap between overlay and background - these images do not appear coregistered.'); + + if lSrcHdr.ImgBufferBPP = 4 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + lSrcHdr.ImgBufferItems := lOutVolItems; + move(l32f^,lSrcHdr.ImgBuffer^,(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lSrcHdr.ImgBufferBPP = 2 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l16i),(lOutVolItems*sizeof(SmallInt))); + move(l16i^,lSrcHdr.ImgBuffer^,(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lSrcHdr.ImgBufferBPP = 1 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,lOutVolItems + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l8i),lOutVolItems); + move(l8i^,lSrcHdr.ImgBuffer^,lOutVolItems); + FreeMem(l8i); + end; + lSrcHdr.NIfTIHdr := lDestHdr; //header inherits coordinates of target +end; + + +function Hdr2InvMat (lHdr: TNiftiHdr; var lOK: boolean): TMatrix; +var + lSrcMat,lSrcMatInv: TMatrix; +begin + lSrcMat := Hdr2Mat( lHdr); + lSrcMatInv := lSrcMat; + lOK := gaussj(lSrcMatInv); + //the vectors should be rows not columns.... + //therefore we transpose the matrix + //use this if you use transform instead of coord + //Transposemat(lSrcMatInv); + result := lSrcMatInv; +end; + +end. diff --git a/backup/shit.lpi.bak b/backup/shit.lpi.bak new file mode 100644 index 0000000..07b29f1 --- /dev/null +++ b/backup/shit.lpi.bak @@ -0,0 +1,85 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="shit"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <MacroValues Count="1"> + <Macro1 Name="LCLWidgetType" Value="cocoa"/> + </MacroValues> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + <SharedMatrixOptions Count="1"> + <Item1 ID="894178551398" Modes="Default" Type="IDEMacro" MacroName="LCLWidgetType" Value="cocoa"/> + </SharedMatrixOptions> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="shit.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="render.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="RenderForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="shit"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/backup/shit.lps.bak b/backup/shit.lps.bak new file mode 100644 index 0000000..ca8ab7d --- /dev/null +++ b/backup/shit.lps.bak @@ -0,0 +1,184 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectSession> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="6"> + <Unit0> + <Filename Value="shit.lpr"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="-1"/> + <TopLine Value="-1"/> + <CursorPos X="-1" Y="-1"/> + <UsageCount Value="29"/> + </Unit0> + <Unit1> + <Filename Value="render.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="RenderForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <CursorPos X="35" Y="2"/> + <UsageCount Value="29"/> + </Unit1> + <Unit2> + <Filename Value="shitu.pas"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <IsVisibleTab Value="True"/> + <TopLine Value="103"/> + <CursorPos X="36" Y="115"/> + <UsageCount Value="24"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit2> + <Unit3> + <Filename Value="nifti_img_view.pas"/> + <ComponentName Value="ImgForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <UsageCount Value="9"/> + </Unit3> + <Unit4> + <Filename Value="RenderThds.pas"/> + <EditorIndex Value="-1"/> + <CursorPos X="40" Y="11"/> + <UsageCount Value="9"/> + </Unit4> + <Unit5> + <Filename Value="nifti_hdr_view.pas"/> + <ComponentName Value="HdrForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <UsageCount Value="9"/> + </Unit5> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="shitu.pas"/> + <Caret Line="36" Column="38" TopLine="11"/> + </Position1> + <Position2> + <Filename Value="shitu.pas"/> + <Caret Line="37" Column="38" TopLine="11"/> + </Position2> + <Position3> + <Filename Value="shitu.pas"/> + <Caret Line="39" Column="38" TopLine="11"/> + </Position3> + <Position4> + <Filename Value="shitu.pas"/> + <Caret Line="44" Column="32" TopLine="20"/> + </Position4> + <Position5> + <Filename Value="shitu.pas"/> + <Caret Line="46" Column="32" TopLine="21"/> + </Position5> + <Position6> + <Filename Value="shitu.pas"/> + <Caret Line="41" Column="49" TopLine="28"/> + </Position6> + <Position7> + <Filename Value="shitu.pas"/> + <Caret Line="33" Column="50" TopLine="33"/> + </Position7> + <Position8> + <Filename Value="shitu.pas"/> + <Caret Line="44" Column="21" TopLine="33"/> + </Position8> + <Position9> + <Filename Value="shitu.pas"/> + <Caret Line="60" Column="32" TopLine="41"/> + </Position9> + <Position10> + <Filename Value="shitu.pas"/> + <Caret Line="61" Column="32" TopLine="42"/> + </Position10> + <Position11> + <Filename Value="shitu.pas"/> + <Caret Line="62" Column="32" TopLine="43"/> + </Position11> + <Position12> + <Filename Value="shitu.pas"/> + <Caret Line="32" Column="47" TopLine="32"/> + </Position12> + <Position13> + <Filename Value="shitu.pas"/> + <Caret Line="48" Column="55" TopLine="46"/> + </Position13> + <Position14> + <Filename Value="shitu.pas"/> + <Caret Line="57" TopLine="42"/> + </Position14> + <Position15> + <Filename Value="shitu.pas"/> + <Caret Line="62" Column="32" TopLine="44"/> + </Position15> + <Position16> + <Filename Value="shitu.pas"/> + <Caret Line="56" Column="42" TopLine="54"/> + </Position16> + <Position17> + <Filename Value="shitu.pas"/> + <Caret Line="59" Column="42" TopLine="57"/> + </Position17> + <Position18> + <Filename Value="shitu.pas"/> + <Caret Line="84" Column="8" TopLine="71"/> + </Position18> + <Position19> + <Filename Value="shitu.pas"/> + <Caret Line="86" Column="20" TopLine="70"/> + </Position19> + <Position20> + <Filename Value="shitu.pas"/> + <Caret Line="94" Column="38" TopLine="73"/> + </Position20> + <Position21> + <Filename Value="shitu.pas"/> + <Caret Line="78" Column="39" TopLine="74"/> + </Position21> + <Position22> + <Filename Value="shitu.pas"/> + <Caret Line="71" Column="43" TopLine="70"/> + </Position22> + <Position23> + <Filename Value="shitu.pas"/> + <Caret Line="72" Column="43" TopLine="71"/> + </Position23> + <Position24> + <Filename Value="shitu.pas"/> + <Caret Line="73" Column="43" TopLine="72"/> + </Position24> + <Position25> + <Filename Value="shitu.pas"/> + <Caret Line="75" Column="43" TopLine="74"/> + </Position25> + <Position26> + <Filename Value="shitu.pas"/> + <Caret Line="101" Column="71" TopLine="92"/> + </Position26> + <Position27> + <Filename Value="shitu.pas"/> + <Caret Line="102" Column="71" TopLine="93"/> + </Position27> + <Position28> + <Filename Value="shitu.pas"/> + <Caret Line="57" Column="23" TopLine="54"/> + </Position28> + <Position29> + <Filename Value="shitu.pas"/> + <Caret Line="56" Column="3" TopLine="45"/> + </Position29> + <Position30> + <Filename Value="shitu.pas"/> + <Caret Line="79" Column="63" TopLine="75"/> + </Position30> + </JumpHistory> + </ProjectSession> +</CONFIG> diff --git a/backup/shitu.lfm.bak b/backup/shitu.lfm.bak new file mode 100644 index 0000000..e3b46e6 --- /dev/null +++ b/backup/shitu.lfm.bak @@ -0,0 +1,107 @@ +object Form1: TForm1 + Left = 563 + Height = 595 + Top = 152 + Width = 1157 + Caption = 'Form1' + ClientHeight = 595 + ClientWidth = 1157 + Color = clWindow + Menu = MainMenu1 + OnCreate = FormCreate + OnDropFiles = FormDropFiles + OnResize = FormResize + LCLVersion = '1.4.2.0' + object Label1: TLabel + Left = 48 + Height = 16 + Top = 24 + Width = 42 + Caption = 'Label1' + ParentColor = False + end + object Button1: TButton + Left = 208 + Height = 25 + Top = 32 + Width = 75 + Caption = 'Button1' + OnClick = Button1Click + TabOrder = 0 + end + object ComboBox1: TComboBox + Left = 135 + Height = 21 + Top = 112 + Width = 100 + ItemHeight = 0 + Items.Strings = ( + '1' + '2' + '3' + ) + OnChange = ComboBox1Change + TabOrder = 1 + Text = 'ComboBox1' + end + object SpinEdit1: TSpinEdit + Left = 16 + Height = 16 + Top = 69 + Width = 175 + MinValue = 1 + OnChange = SpinEdit1Change + TabOrder = 2 + Value = 2 + end + object SpeedButton1: TSpeedButton + Left = 405 + Height = 102 + Top = 52 + Width = 111 + Caption = '1' + Flat = True + end + object SpeedButton2: TSpeedButton + Left = 528 + Height = 102 + Top = 52 + Width = 111 + Caption = '2' + end + object SpeedButton3: TSpeedButton + Left = 440 + Height = 103 + Top = 176 + Width = 151 + Color = 15758710 + end + object Image1: TImage + Left = 47 + Height = 274 + Top = 180 + Width = 322 + OnMouseDown = Image1MouseDown + OnMouseMove = Image1MouseMove + end + object MainMenu1: TMainMenu + left = 322 + top = 84 + object MenuItem1: TMenuItem + Caption = '' + object MenuItem2: TMenuItem + Caption = 'Preferences' + OnClick = MenuItem2Click + end + end + end + object SelectDirectoryDialog1: TSelectDirectoryDialog + left = 76 + top = 117 + end + object OpenDialog1: TOpenDialog + OnSelectionChange = OpenDialog1SelectionChange + left = 125 + top = 13 + end +end diff --git a/backup/shitu.pas.bak b/backup/shitu.pas.bak new file mode 100644 index 0000000..a0d4b90 --- /dev/null +++ b/backup/shitu.pas.bak @@ -0,0 +1,124 @@ +unit shitu; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, + StdCtrls, Buttons, Spin, ComCtrls, Menus; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + ComboBox1: TComboBox; + Image1: TImage; + Label1: TLabel; + MainMenu1: TMainMenu; + MenuItem1: TMenuItem; + MenuItem2: TMenuItem; + OpenDialog1: TOpenDialog; + SelectDirectoryDialog1: TSelectDirectoryDialog; + SpeedButton1: TSpeedButton; + SpeedButton2: TSpeedButton; + SpeedButton3: TSpeedButton; + SpinEdit1: TSpinEdit; + procedure Button1Click(Sender: TObject); + procedure ComboBox1Change(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDropFiles(Sender: TObject; const FileNames: array of String); + procedure FormResize(Sender: TObject); + procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer + ); + procedure MenuItem2Click(Sender: TObject); + procedure OpenDialog1SelectionChange(Sender: TObject); + procedure SpinEdit1Change(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +begin + OpenDialog1.Filter := 'Project|*.lpr|Unit|*.pas'; + OpenDialog1.execute; + + //Label1.ParentFont := false; + //Label1.Font.Name := 'Arial'; + //Label1.Update; + +end; + +procedure TForm1.ComboBox1Change(Sender: TObject); +begin + Label1.caption := 'Combo changed'+inttostr(random(888)); +end; +// ComboBox1.Style := csDropDownList; + + + +procedure TForm1.FormDropFiles(Sender: TObject; const FileNames: array of String + ); +begin + +end; + +procedure TForm1.FormResize(Sender: TObject); +begin + Label1.caption := 'FormResize'+inttostr(random(888)); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + Image1.Canvas.brush.Color := clGray; + Image1.Canvas.FillRect(0,0,Image1.Width, Image1.Height); + Image1.Canvas.brush.Color := clBlue; + Image1.Canvas.Ellipse(0,0,Image1.Width, Image1.Height); +end; + +procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + Image1.Canvas.pen.color := clRed; + Image1.Canvas.MoveTo(X,Y); +end; + +procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + if not (ssLeft in Shift) then exit; + Image1.Canvas.LineTo(X,Y); +end; + +procedure TForm1.MenuItem2Click(Sender: TObject); +begin + showmessage('x'); +end; + +procedure TForm1.OpenDialog1SelectionChange(Sender: TObject); +begin + caption := inttostr(random(888)); +end; + +procedure TForm1.SpinEdit1Change(Sender: TObject); +begin + Label1.caption := 'Spin changed'+inttostr(random(888)); +end; + +end. + diff --git a/batch.pas b/batch.pas new file mode 100755 index 0000000..25c217f --- /dev/null +++ b/batch.pas @@ -0,0 +1,195 @@ +unit batch; +{$H+} +interface +uses +{$IFNDEF UNIX} Windows, +{$ELSE} + lclintf,LCLType,LResources,BaseUnix, +{$ENDIF} +define_types; +procedure BatchVOI; + +implementation + +uses + Forms, + //lclintf,LResources,{$IFNDEF Unix} Controls, {$ELSE}BaseUnix, LCLType,{$ENDIF} + nifti_img, nifti_img_view, dialogs, nifti_hdr_view, text,sysutils,classes, fdr,batchstatselect; + +(*function LesionFrac (lOverlayNum: integer): double; +var + lLesionSum,lInten: double; + lInc: integer; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lLesionSum := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lInten := RawBGIntensity(lInc); + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then + lLesionSum := lLesionSum + lInten; + end; //for each voxel + result := lLesionSum; +end;*) + +function VOIVol (lOverlayNum: integer): integer; +var + lInc,lVox: integer; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + inc(lVox); + end; //for each voxel + result := lVox; +end; //VOIVol + +function VOIMean (lOverlayNum: integer): double; +var + lSum,lInten,lVol: double; + lInc: integer; +begin + result := 0; + lVol := VOIVol(lOverlayNum); + if lVol < 1 then + exit; + lSum := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lInten := RawBGIntensity(lInc); + //Next line - only voxels that are part of VOI + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + lSum := lSum + lInten; + end; //for each voxel + result := lSum/lVol; +end; //VOIMean + +function VOIMeanFrac10pct (lOverlayNum: integer; lMax: boolean): double; +//if lMax is true, return top 10pct, if false return bottom +var + lSum: double; + lVox,lInc,l10pct: integer; + lRA: singlep; +begin //proc ShowDescript + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + //first - count number of voxels in ROI + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + inc(lVox); + //next - get memory + if lVox < 1 then + exit; + getmem(lRA,lVox * sizeof(single)); + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + inc(lVox); + lRA^[lVox] := RawBGIntensity(lInc); + end; + qsort(1, lVox,lRA); + l10pct := round(lVox / 10); + if l10pct < 1 then + l10pct := 1; + lSum := 0; + if not lMax then begin //lower 10pct + for lInc := 1 to l10pct do + lSum := lSum + lRA^[lInc] + end else begin //top 10pct + for lInc := (lVox-l10pct+1) to lVox do + lSum := lSum + lRA^[lInc]; + end; + result := lSum / l10pct; + freemem(lRA); +end; + +procedure BatchVOI; +var + lNumberofP,lP,lInc,lNumberofFiles,lLoop: integer; + lFilename,lStr:string; + lBGStrings : TStrings; +begin + + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + lBGStrings := TStringList.Create; + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + GetFilesInDir(ExtractFileDir(HdrForm.OpenHdrDlg.Filename),lBGStrings) + end else begin + if not OpenDialogExecute(kImgFilter,'Select background images (stat maps)',true) then + exit; + lBGStrings.AddStrings(HdrForm.OpenHdrDlg.Files); + end; + lNumberofP:= lBGStrings.Count; + if lNumberofP < 1 then begin + lBGStrings.free; + exit; + + end; + + if not OpenDialogExecute(kImgFilter,'Select overlay images (ROIs)',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.MemoT.Lines.Clear; + lStr := 'Function'+kTextSep+'VOIname'+kTextSep+'VOIvol'; + for lP := 1 to lNumberofP do + lStr := lStr + kTextSep+(lBGStrings.Strings[lP-1]); + TextForm.MemoT.lines.add(lStr); + for lLoop := 1 to 3 do begin + {if lLoop=3 then + lStr := 'min10pct'+kSep+'Filename+'kSep+'Vol' + else if lLoop=2 then + lStr := 'max10pct'+Filename+'kSep+'Vol' + else + lStr := 'mean'+Filename+kSep'Vol';} + + for lInc:= 1 to lNumberofFiles do begin + ImgForm.StatusLabel.Caption := inttostr(lInc)+'/'+inttostr(lNumberofFiles); + IMgForm.refresh; + if lLoop=3 then + lStr := 'min10pct' + else if lLoop=2 then + lStr := 'max10pct' + else + lStr := 'mean'; + lStr := lStr +kTextSep+ (HdrForm.OpenHdrDlg.Files[lInc-1]); + for lP := 1 to lNumberofP do begin + lFilename := lBGStrings.Strings[lP-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + ImgForm.OverlayOpenCore ( lFilename, 2); + if lP = 1 then + lStr := lStr + kTextSep+ inttostr(VOIVol(2) ); + if lLoop = 3 then + lStr := lStr + kTextSep+ floattostr(VOIMeanFrac10Pct(2,false)) + else if lLoop = 2 then + lStr := lStr + kTextSep+ floattostr(VOIMeanFrac10Pct(2,true)) + else + lStr := lStr + kTextSep+ floattostr(VOIMean(2)); + end; + TextForm.MemoT.lines.add(lStr ); + end; + end;//lLoop + FreeImgMemory(gMRIcroOverlay[2]); + ImgForm.UpdateLayerMenu; + //SaveDialog1.Filename := ExtractFileDirWithPathDelim(HdrForm.OpenHdrDlg.Files[0])+'desc.csv'; + lBGStrings.Free; + //ImgForm.SaveDialog1.Filename := ExtractFileDirWithPathDelim(gMRIcroOverlay[lOverlayNum].HdrFileName)+'desc.csv'; + TextForm.Show; +end; + +end. + diff --git a/batchstatselect.pas b/batchstatselect.pas new file mode 100755 index 0000000..657462c --- /dev/null +++ b/batchstatselect.pas @@ -0,0 +1,82 @@ +unit batchstatselect; +{$H+} +interface + +uses + Classes, SysUtils,StrUtils, define_types, Dialogs; + +procedure GetFilesInDir (lDefaultFolder: string; var lFilenames: TStrings); + +implementation + +function IsStatHdr(lStr: string): boolean; +//detects 'spmT_000*.hdr and zstat*.nii.gz +//requires StrUtils +var + lExt: string; +begin + result := false; + if not IsExtNIFTIHdr(lStr) then + exit; + if AnsiContainsText(lStr, 'spmT_') or AnsiContainsText(lStr, pathdelim+'zstat') then + result := true; +end; + +procedure FindNIIhdrRecursive (var lFolderNameIn: string; var lStringList : TStrings); +var + len: integer; + lFolderName,lNewDir,lNewName,lExt: String; + lSearchRec: TSearchRec; +begin + lFolderName := lFolderNameIn; + if not DirExists (lFolderName) then begin + lFolderName := ExtractFileDir(lFolderName); + end; + if (length(lFolderName) > 1) and (lFolderName[length(lFolderName)] <> PathDelim) then + lNewDir := lFolderName+PathDelim; + if DirExists (lNewDir) then begin +{$IFDEF UNIX} + if FindFirst(lNewDir+'*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + repeat + lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name = '.') or (lSearchRec.Name = '..') then + //current or parent folder - do nothing + else if DirExists(lNewName) then + FindNIIhdrRecursive (lNewName, lStringList) + else if IsStatHdr(lNewName) then + lStringList.Add(lNewName); + until (FindNext(lSearchRec) <> 0); + end; //if findfirst + FindClose(lSearchRec); + end;//Direxists +end; + +procedure FilterForText (lRequiredText: string; var lFilenames: TStrings); +var + i,len: integer; +begin + len := lFilenames.Count; + if (length(lRequiredText) < 1) or (len < 1) then + exit; + for i := len-1 downto 0 do + if not AnsiContainsText(lFilenames[i], lRequiredText) then + lFilenames.Delete(i); +end; + +procedure GetFilesInDir (lDefaultFolder: string; var lFilenames: TStrings); +var + lParentDir,lFilter : string; +begin + lParentDir := GetDirPrompt (lDefaultFolder); + FindNIIhdrRecursive(lParentDir,lFilenames); + lFilter := '.gfeat'; + InputQuery('Filter data', 'Filter for statistical maps [e.g. ''.gfeat'' will only analyze files with this in their path. Set to blank to analyze all files',lFilter); + FilterForText(lFilter,lFilenames); +end; + + +end. + diff --git a/bet.lfm b/bet.lfm new file mode 100755 index 0000000..18ee2e6 --- /dev/null +++ b/bet.lfm @@ -0,0 +1,76 @@ +object BETForm: TBETForm + Left = 485 + Height = 313 + Top = 539 + Width = 545 + ActiveControl = Panel1 + Caption = 'Brain extraction' + ClientHeight = 313 + ClientWidth = 545 + Constraints.MaxHeight = 313 + Constraints.MaxWidth = 545 + Constraints.MinHeight = 313 + Constraints.MinWidth = 545 + Position = poScreenCenter + LCLVersion = '0.9.28.2' + object Memo1: TMemo + Left = 0 + Height = 281 + Top = 32 + Width = 545 + Align = alClient + TabOrder = 0 + end + object Panel1: TPanel + Left = 0 + Height = 32 + Top = 0 + Width = 545 + Align = alTop + BevelOuter = bvNone + ClientHeight = 32 + ClientWidth = 545 + TabOrder = 1 + object GoBtn: TSpeedButton + Left = 8 + Height = 25 + Top = 2 + Width = 88 + Caption = 'Go' + Color = clBtnFace + NumGlyphs = 0 + OnClick = GoBtnClick + end + object AboutBtn: TSpeedButton + Left = 100 + Height = 25 + Top = 2 + Width = 88 + Caption = 'About' + Color = clBtnFace + NumGlyphs = 0 + OnClick = SpeedButton2Click + end + object CropBtn: TSpeedButton + Left = 192 + Height = 25 + Top = 2 + Width = 88 + Caption = 'Crop Edges' + Color = clBtnFace + NumGlyphs = 0 + OnClick = CropBtnClick + end + object SmoothnessEdit: TFloatSpinEdit + Left = 308 + Height = 27 + Top = 5 + Width = 93 + Increment = 1 + MaxValue = 1 + MinValue = 0 + TabOrder = 0 + Value = 0.5 + end + end +end diff --git a/bet.lrs b/bet.lrs new file mode 100644 index 0000000..afa147c --- /dev/null +++ b/bet.lrs @@ -0,0 +1,21 @@ +LazarusResources.Add('TBETForm','FORMDATA',[ + 'TPF0'#8'TBETForm'#7'BETForm'#4'Left'#3#229#1#6'Height'#3'9'#1#3'Top'#3#27#2#5 + +'Width'#3'!'#2#13'ActiveControl'#7#6'Panel1'#7'Caption'#6#16'Brain extractio' + +'n'#12'ClientHeight'#3'9'#1#11'ClientWidth'#3'!'#2#21'Constraints.MaxHeight' + +#3'9'#1#20'Constraints.MaxWidth'#3'!'#2#21'Constraints.MinHeight'#3'9'#1#20 + +'Constraints.MinWidth'#3'!'#2#8'Position'#7#14'poScreenCenter'#10'LCLVersion' + +#6#8'0.9.28.2'#0#5'TMemo'#5'Memo1'#4'Left'#2#0#6'Height'#3#25#1#3'Top'#2' '#5 + +'Width'#3'!'#2#5'Align'#7#8'alClient'#8'TabOrder'#2#0#0#0#6'TPanel'#6'Panel1' + +#4'Left'#2#0#6'Height'#2' '#3'Top'#2#0#5'Width'#3'!'#2#5'Align'#7#5'alTop'#10 + +'BevelOuter'#7#6'bvNone'#12'ClientHeight'#2' '#11'ClientWidth'#3'!'#2#8'TabO' + +'rder'#2#1#0#12'TSpeedButton'#5'GoBtn'#4'Left'#2#8#6'Height'#2#25#3'Top'#2#2 + +#5'Width'#2'X'#7'Caption'#6#2'Go'#5'Color'#7#9'clBtnFace'#9'NumGlyphs'#2#0#7 + +'OnClick'#7#10'GoBtnClick'#0#0#12'TSpeedButton'#8'AboutBtn'#4'Left'#2'd'#6'H' + +'eight'#2#25#3'Top'#2#2#5'Width'#2'X'#7'Caption'#6#5'About'#5'Color'#7#9'clB' + +'tnFace'#9'NumGlyphs'#2#0#7'OnClick'#7#17'SpeedButton2Click'#0#0#12'TSpeedBu' + +'tton'#7'CropBtn'#4'Left'#3#192#0#6'Height'#2#25#3'Top'#2#2#5'Width'#2'X'#7 + +'Caption'#6#10'Crop Edges'#5'Color'#7#9'clBtnFace'#9'NumGlyphs'#2#0#7'OnClic' + +'k'#7#12'CropBtnClick'#0#0#14'TFloatSpinEdit'#14'SmoothnessEdit'#4'Left'#3'4' + +#1#6'Height'#2#27#3'Top'#2#5#5'Width'#2']'#9'Increment'#2#1#8'MaxValue'#2#1#8 + +'MinValue'#2#0#8'TabOrder'#2#0#5'Value'#5#0#0#0#0#0#0#0#128#254'?'#0#0#0#0 +]); diff --git a/bet.pas b/bet.pas new file mode 100755 index 0000000..63e6376 --- /dev/null +++ b/bet.pas @@ -0,0 +1,490 @@ +unit bet; + +{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, + ExtCtrls, Buttons, Spin,Process,nifti_img,define_types,CropEdges, userdir; + +type + { TBETForm } + TBETForm = class(TForm) + Memo1: TMemo; + SmoothnessEdit: TFloatSpinEdit; + Panel1: TPanel; + GoBtn: TSpeedButton; + AboutBtn: TSpeedButton; + CropBtn: TSpeedButton; + procedure CropBtnClick(Sender: TObject); + procedure GoBtnClick(Sender: TObject); + procedure SpeedButton2Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + BETForm: TBETForm; + +implementation +uses + nifti_img_view; +{ TBETForm } + +procedure TBETForm.SpeedButton2Click(Sender: TObject); +begin + Showmessage('You can skull strip scans to allow you to render the surface of the brain.'+chr (13) ++ 'This uses Steve Smith''s Brain Extraction Tool [BET].'+chr (13)+ +'Default smoothness is 0.50, smaller values generate larger estimates of brain size.'+chr (13) ++'http://www.fmrib.ox.ac.uk/fsl'); +end; + +//lCmd := extractfilepath(paramstr(0))+'bet "'+lSourceFilename+'" "'+SaveDialog1.Filename +// +'" -f '+floattostr(SmoothnessEdit.value{/100}); +function PathExists (lCmd: string): boolean; +begin + result := false; + if FSize(lCmd) < 1 then begin + BETForm.Memo1.Lines.Add('Unable to find executable named '+lCmd); + exit; + end; + result := true; +end; + +procedure RunCmd (lCmd: string); + var + AProcess: TProcess; + AStringList: TStringList; + ACMD,PATH,FSLDIR,FSLCONF,lS,FULL: string; + begin + ACmd := lCmd; + AProcess := TProcess.Create(nil); + AStringList := TStringList.Create; + + //AProcess.CommandLine := lCmd; + {$IFDEF UNIX} + (*if direxists (gBGImg.FSLBASE) then + BETForm.Memo1.Lines.Add('Using folder specified in mricron.ini file [FSLBASE] '+gBGImg.FSLBASE) + else + BETForm.Memo1.Lines.Add('Warning: unable to find folder specified in mricron.ini file [FSLBASE] '+gBGImg.FSLBASE); + AProcess.Environment.Add(gBGImg.FSLBASE); + lBinDir := gBGImg.FSLBASE+'/bin'; + if direxists (lBinDir) then begin + AProcess.Environment.Add(lBinDir); + BETForm.Memo1.Lines.Add('Adding path to environment: '+lBinDir); + end else + BETForm.Memo1.Lines.Add('Warning: unable to find binary folder '+lBinDir);*) + + + PATH:=GetEnvironmentVariable('PATH'); + FSLDIR := gBGImg.FSLBASE; + if (length(FSLDIR)<1) or (not DirExists(FSLDIR)) then begin + if direxists (GetEnvironmentVariable('FSLDIR')) then + FSLDIR:=GetEnvironmentVariable('FSLDIR'); + end; + if direxists (FSLDIR) then + BETForm.Memo1.Lines.Add('Setting FSL folder (if incorrect edit FSLBASE in mricron):'+FSLDIR) + else + BETForm.Memo1.Lines.Add('Warning: unable to find folder specified in mricron.ini file [FSLBASE] '+FSLDIR); + FULL := PATH+':'+FSLDIR+':'+FSLDIR+'/bin' ; + + lS := 'FSLDIR='+FSLDIR; + BETForm.Memo1.Lines.Add(lS); + AProcess.Environment.Add(lS); + + + lS := 'LD_LIBRARY_PATH='+FSLDIR+'/bin'; + BETForm.Memo1.Lines.Add(lS); + AProcess.Environment.Add(lS); + + //lS := '. '+FSLDIR+'/etc/fslconf/fsl.sh'; + //BETForm.Memo1.Lines.Add(lS); + //AProcess.Environment.Add(lS); + + + lS := 'PATH='+FULL; + BETForm.Memo1.Lines.Add(lS); + AProcess.Environment.Add(lS); + + + //AProcess.Environment.Add(FULL); + + lS := 'FSLCLUSTER_MAILOPTS="n"'; + BETForm.Memo1.Lines.Add(lS); + AProcess.Environment.Add(lS); + //lS := 'export '+FULL; + //lS := 'export FSLDIR PATH'; + //BETForm.Memo1.Lines.Add(lS); + //AProcess.Environment.Add(lS); + + + BETForm.Memo1.Lines.Add(gBGImg.FSLOUTPUTTYPE); + AProcess.Environment.Add(gBGImg.FSLOUTPUTTYPE); + {$ENDIF} + AProcess.CommandLine := ACmd; + AProcess.Options := AProcess.Options + [poWaitOnExit, poStderrToOutPut, poUsePipes]; + BETForm.Memo1.Lines.Add(ACmd); + AProcess.Execute; + AStringList.LoadFromStream(AProcess.Output); + BetForm.Memo1.Lines.AddStrings(AStringList); + AStringList.Free; + AProcess.Free; + end; + +(*procedure RunCmdX; + var + AProcess: TProcess; + AStringList: TStringList; + lBinDir: string; + begin + AProcess := TProcess.Create(nil); + AStringList := TStringList.Create; + + AProcess.CommandLine := 'bet /home/crlab/t.nii /home/crlab/xt.nii'; + {$IFDEF UNIX} + AProcess.Environment.Add('FSLOUTPUTTYPE=NIFTI_GZ'); + AProcess.Environment.Add('/usr/local/fsl/'); + AProcess.Environment.Add('/usr/local/fsl/bin'); + + AProcess.Environment.Add('FSLDIR=/usr/local/fsl'); + //AProcess.Environment.Add('FSLOUTPUTTYPE=NIFTI_GZ'); + {$ENDIF} + AProcess.Options := AProcess.Options + [poWaitOnExit, poStderrToOutPut, poUsePipes]; + AProcess.Execute; + AStringList.LoadFromStream(AProcess.Output); + BetForm.Memo1.Lines.AddStrings(AStringList); + AStringList.Free; + AProcess.Free; + end;*) + +function DoBET(lInFile,lOutFile: string; lFrac: single):boolean; +var + lCmd: string; +begin + result := false; + lCmd := extractfilepath(paramstr(0))+'bet'; + {$IFNDEF Unix} + lCmd := lCmd+'.exe'; + {$ELSE} + if not fileexists(lCmd) then begin + lCmd := (gBGImg.FSLBASE+'/bin/bet'); + if fileexists(lCmd) then + BETForm.Memo1.Lines.Add('Using executable location from mricron.ini file [FSLBASE] '+lCmd) + else + BETForm.Memo1.Lines.Add('Unable to find executable suggested by mricron.ini file [FSLBASE] '+lCmd) + + end; + {$ENDIF} + if not PathExists (lCmd) then begin + lCmd := '/usr/local/fsl/bin/bet_8UI'; + if not PathExists (lCmd) then begin + lCmd := '/usr/local/fsl/bin/bet'; + if not PathExists (lCmd) then + exit; + end; + end; //no bet in home folder... + lCmd := lCmd+' "'+lInFile+'" "'+lOutFile +'" -R -f '+floattostr(lFrac); + + RunCmd(lCmd); + (*AProcess := TProcess.Create(nil); + {$IFDEF UNIX} + AProcess.Environment.Add('FSLDIR=/usr/local/fsl'); + AProcess.Environment.Add('FSLOUTPUTTYPE=NIFTI_GZ'); + {$ENDIF} + AProcess.CommandLine := lCmd; + //AProcess.CommandLine := 'C:\bet "C:\txx.hdr" "C:\btxx.hdr" -f 0.5'; + AProcess.Options := AProcess.Options + [poWaitOnExit]; + AProcess.Execute; + AProcess.Free; *) + result := true; +end; + +function Bright95Pct: byte;//returns intensity of 95th percentile +var + lPos,l5Pct,lCumulative: integer; + lHisto: array [0..255] of integer; +begin + result := 0; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems) then exit; + //next - create histogram of intensity + for lPos := 0 to 255 do + lHisto[lPos] := 0; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + inc(lHisto[gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lPos]]); + //next find 95th percentile + l5Pct := (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems div 20); + lCumulative := 0; + lPos := 256; + while (lPos > 0) and (lCumulative < l5Pct) do begin + dec(lPos); + lCumulative := lCumulative + lHisto[lPos]; + end; + result := lPos; +end; + +procedure CropVOI (lVOIIntensity: byte); +var + lPos: integer; +begin + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems) then exit; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lPos] = kVOI8bit then + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lPos] := lVOIIntensity; +end; + +procedure DeleteHdrImg(lFilename: string); +begin +//exit; + if lFilename = '' then + exit; + DeleteFile(lFilename); + if (UpCaseExt(lFileName)='.IMG') then + DeleteFile(changefileext(lFilename,'.hdr')); + if (UpCaseExt(lFileName)='.HDR') then + DeleteFile(changefileext(lFilename,'.img')); +end; + +function Mask8BitImg(lImgName,lMaskName: string): boolean; +//should be two 8-bit image files of identical dimensions +//all non-zero voxels in the mask are written with value of img +//Warning - only works with .img files with zero voxoffset - can corrupt .nii files - would need to read header.... +var + lPos2,lPos,lC,lSz,lMaskSz,lBPP: integer; + lImg,lMask: bytep; + lInF: File; +begin + result := false; + lSz := FSize(lImgName); + lMaskSz := FSize(lMaskName); + if lSz = lMaskSz then + lBPP := 1 + else if lSz = (2*lMaskSz) then + lBPP := 2 + else if lSz = (2*lMaskSz) then + lBPP := 4 + else + lBPP := 0; + if (lSz < 1) or (lBPP = 0 ) then + exit; + //next read mask + GetMem(lMask,lSz); + AssignFile(lInF, lMaskName); + Reset(lInF,1); + BlockRead(lInF, lMask^, lMaskSz); + CloseFile(lInF); + //next: read image + GetMem(lImg,lSz); + AssignFile(lInF, lImgName); + Reset(lInF,1); + BlockRead(lInF, lImg^, lSz); + CloseFile(lInF); + //next mask image + for lPos := 1 to lMaskSz do + if lMask^[lPos] = 0 then begin + lPos2 := ((lPos-1)*lBPP); + for lC := 1 to lBPP do + lImg^[lC+lPos2] := 0; + end; + Freemem(lMask); + //next save masked image + AssignFile(lInF, lImgName); //1/2008.... + //AssignFile(lInF, lMaskName); + Rewrite(lInF,1); + BlockWrite(lInF, lImg^, lSz); + CloseFile(lInF); + Freemem(lImg); + result := true; +end; + +(*function Mask8BitImg(lImgName,lMaskName: string): boolean;//should be two 8-bit image files of identical dimensions +//all non-zero voxels in the mask are written with value of img +//Note: the mask file is changed - not the image +var + lPos,lSz: integer; + lImg,lMask: bytep; + lInF: File; +begin + //showmessage( lMaskName+'xx'+lImgName); + result := false; + lSz := FSize(lImgName); + if (lSz < 1) or (lSz <> FSize(lMaskName)) then + exit; + //fx(lSz,778899); + //next read mask + GetMem(lMask,lSz); + AssignFile(lInF, lMaskName); + Reset(lInF,1); + BlockRead(lInF, lMask^, lSz); + CloseFile(lInF); + //next: read image + GetMem(lImg,lSz); + AssignFile(lInF, lImgName); + Reset(lInF,1); + BlockRead(lInF, lImg^, lSz); + CloseFile(lInF); + //next mask image + for lPos := 1 to lSz do + if lMask^[lPos] = 0 then + lImg^[lPos] := 0; + Freemem(lMask); + //next save masked image + AssignFile(lInF, lMaskName); + Rewrite(lInF,1); + BlockWrite(lInF, lImg^, lSz); + CloseFile(lInF); + Freemem(lImg); + result := true; +end;*) + +function DefaultsDirCmd: string; +//Lazarus for Unix does not seem to execute TProcess commands to ~/.. we need to write them to /Home/chris/.. +var + lLen,lP: integer; + lStr: string; +begin + {$IFDEF UNIX} + lStr := extractfiledir(GetAppConfigFile(false)); + lLen := length(lStr); + if lLen < 1 then exit; + lP := lLen; + while (lP > 0) and (lStr[lP] <> '.') do + dec(lP); + if lP > 1 then begin + for lLen := 1 to (lP-1) do + result := result + lStr[lLen]; + end; + {$ELSE} //else ... assume windows + result := DefaultsDir('') + {$ENDIF} + //showmessage('x'+result+'x'); +end; + +procedure TBETForm.GoBtnClick(Sender: TObject); +label +666; +var + lTempNameOrig,lTempName8bitMask,lTempBetName,lTempGZName: string; +begin + Memo1.Clear; + Memo1.lines.add('Startup Timestamp: '+DateTimeToStr(Now)); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + showmessage('BET error: please use File/Open to display the image you want to brain extract.'); + end; + //showmessage(DefaultsDirCmd); + lTempNameOrig :=DefaultsDirCmd+'orig.hdr';//lTempNameOrig := extractfilepath(paramstr(0))+'orig.hdr'; + SaveAsVOIorNIFTIcore (lTempNameOrig, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems, gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + //SaveAsVOIorNIFTIcore (lTempNameOrig, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems, gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then begin + case MessageDlg('Do you wish to protect tissue shown by the VOI drawing?', mtConfirmation, [mbYes, mbNo], 0) of + mrYes: CropVOI(Bright95Pct); + end; //case for protecting VOI + ImgForm.CloseVOIClick(nil); + end; + if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP <> 1 then + Memo1.lines.add('Warning: converted image downsampled to 8-bit precision.'); + lTempName8bitMask := DefaultsDirCmd+'temp8.hdr';//lTempName8bitMask := extractfilepath(paramstr(0))+'temp8.hdr'; + SaveAsVOIorNIFTIcore (lTempName8bitMask, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + lTempName8bitMask := changefileext(lTempName8bitMask,'.hdr'); //SaveAs renames the .hdr to .img + lTempBetName := DefaultsDirCmd+'btemp8.hdr';//lTempBetName := extractfilepath(paramstr(0))+'btemp8.hdr'; + // showmessage(lTempBetName); + if not DoBET(lTempName8bitMask,lTempBetName,SmoothnessEdit.value) then goto 666; + + + Memo1.lines.add('Shutdown Timestamp: '+DateTimeToStr(Now)); + if Fileexists(lTempBetName) then begin + CopyFileEXoverwrite(lTempName8bitMask,lTempBetName); //the old version of BET corrupts some NIfTI information + end else begin + //assume new version of bet_8UI has saved as .nii.gz + lTempGZName := ChangeFileExt(lTempBetName,'.nii.gz'); + if not Fileexists(lTempGZName) then begin + Memo1.lines.add('BET Error: unable to find BET image '+lTempBetName+ ' or '+lTempGZName); + {$IFDEF Darwin} + Memo1.lines.add(' Try relaunching MRIcron from the Terminal command line, e.g. /Applications/mricron.app/mricron &'); + {$ENDIF} + goto 666; + end; + //convert .nii.gz to hdr/.img so we can mask it... + ImgForm.CloseImagesClick(nil); + ImgForm.OpenAndDisplayImg(lTempGZName,True); + SaveAsVOIorNIFTIcore (lTempBetName,gMRIcroOverlay[kBGOverlayNum].ScrnBuffer, gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + DeleteHdrImg(lTempGZName); + goto 666; +// ImgForm.CloseImagesClick(nil); + end; + + Mask8BitImg(changefileext(lTempNameOrig,'.img'),changefileext(lTempBetName,'.img')); + ImgForm.OpenAndDisplayImg(lTempNameOrig,True); + Memo1.lines.add('Use File/SaveAsNIfTI to save the stripped 8-bit image.'); +666: + + DeleteHdrImg(lTempBetName); + DeleteHdrImg(lTempNameOrig); + DeleteHdrImg(lTempName8bitMask); +end; + +procedure TBETForm.CropBtnClick(Sender: TObject); +begin + CropEdgeForm.Show; +end; + +(*var + lTempNameOrig,lTempName8bitMask,lTempBetName: string; +begin + Memo1.Clear; + Memo1.lines.add('Startup Timestamp: '+DateTimeToStr(Now)); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + showmessage('BET error: please use File/Open to display the image you want to brain extract.'); + end; + lTempNameOrig := ''; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then begin + case MessageDlg('Do you wish to remove tissue shown by the VOI drawing?', mtConfirmation, + [mbYes, mbNo], 0) of + mrYes: CropVOI(0); + else case MessageDlg('Do you wish to protect tissue shown by the VOI drawing?', mtConfirmation, + [mbYes, mbNo], 0) of + mrYes: begin + lTempNameOrig := DefaultsDir('')+'orig8.hdr'; + SaveAsVOIorNIFTIcore (lTempNameOrig, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CropVOI(Bright95Pct); + end; + + end; //case for protecting VOI + end; //case for deleting VOI + + ImgForm.CloseVOIClick(nil); + end; + if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP <> 1 then + Memo1.lines.add('Warning: converted image downsampled to 8-bit precision.'); + lTempName8bitMask := DefaultsDir('')+'temp8.hdr'; + SaveAsVOIorNIFTIcore (lTempName8bitMask, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + lTempName8bitMask := changefileext(lTempName8bitMask,'.hdr'); //SaveAs renames the .hdr to .img + lTempBetName := DefaultsDir('')+'btemp8.hdr'; + DoBET(lTempName8bitMask,lTempBetName,SmoothnessEdit.value); + Memo1.lines.add('Shutdown Timestamp: '+DateTimeToStr(Now)); + + CopyFileEXoverwrite(lTempName8bitMask,lTempBetName); //the old version of BET corrupts some NIfTI information + DeleteHdrImg(lTempName8bitMask); + if lTempNameOrig <> '' then begin + Mask8BitImg(changefileext(lTempNameOrig,'.img'),changefileext(lTempBetName,'.img')); + DeleteHdrImg(lTempNameOrig); + end; + ImgForm.OpenAndDisplayImg(lTempBetName,True); + Memo1.lines.add('Use File/SaveAsNIfTI to save the stripped 8-bit image.'); + DeleteHdrImg(lTempBetName); +end;*) +(*procedure TBETForm.GoBtnClick(Sender: TObject); +begin + Memo1.Clear; + Memo1.lines.add('Startup Timestamp: '+DateTimeToStr(Now)); + DoBET('C:\txx.hdr','C:\btxx.hdr',SmoothnessEdit.value); + Memo1.lines.add('Shutdown Timestamp: '+DateTimeToStr(Now)); +end; *) + +initialization + {$I bet.lrs} + +end. + diff --git a/btn/Thumbs.db b/btn/Thumbs.db new file mode 100755 index 0000000..74630d1 Binary files /dev/null and b/btn/Thumbs.db differ diff --git a/btn/autocon.bmp b/btn/autocon.bmp new file mode 100755 index 0000000..43b7caf Binary files /dev/null and b/btn/autocon.bmp differ diff --git a/btn/autocontrast.png b/btn/autocontrast.png new file mode 100755 index 0000000..8986d08 Binary files /dev/null and b/btn/autocontrast.png differ diff --git a/btn/blackbackbround.svg b/btn/blackbackbround.svg new file mode 100755 index 0000000..8d55061 --- /dev/null +++ b/btn/blackbackbround.svg @@ -0,0 +1,2314 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:xlink="http://www.w3.org/1999/xlink" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + id="svg1141" + sodipodi:version="0.32" + inkscape:version="0.46" + width="210mm" + height="297mm" + sodipodi:docname="blackbackbround.svg" + sodipodi:docbase="C:\Documents and Settings\Chris Rorden\Desktop" + inkscape:output_extension="org.inkscape.output.svg.inkscape"> + <metadata + id="metadata413"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + </cc:Work> + </rdf:RDF> + </metadata> + <defs + id="defs1143"> + <inkscape:perspective + sodipodi:type="inkscape:persp3d" + inkscape:vp_x="0 : 526.18109 : 1" + inkscape:vp_y="0 : 1000 : 0" + inkscape:vp_z="744.09448 : 526.18109 : 1" + inkscape:persp3d-origin="372.04724 : 350.78739 : 1" + id="perspective448" /> + <linearGradient + id="linearGradient1280"> + <stop + style="stop-color:#ffc000;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1281" /> + <stop + style="stop-color:#ff0000;stop-opacity:0.50000000;" + offset="1.0000000" + id="stop1283" /> + </linearGradient> + <linearGradient + id="linearGradient1271"> + <stop + style="stop-color:#ffc87e;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1274" /> + <stop + style="stop-color:#ff0000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1279" /> + </linearGradient> + <linearGradient + id="linearGradient1270"> + <stop + style="stop-color:#ffc000;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1271" /> + <stop + style="stop-color:#e84a50;stop-opacity:1.0000000;" + offset="0.50000000" + id="stop1273" /> + <stop + style="stop-color:#ff0000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1272" /> + </linearGradient> + <linearGradient + id="linearGradient1608"> + <stop + style="stop-color:#ffffff;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1609" /> + <stop + style="stop-color:#9999ff;stop-opacity:1.0000000;" + offset="0.50000000" + id="stop1611" /> + <stop + style="stop-color:#000000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1610" /> + </linearGradient> + <linearGradient + id="linearGradient1563"> + <stop + style="stop-color:#898bdc;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1564" /> + <stop + style="stop-color:#000000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1565" /> + </linearGradient> + <linearGradient + id="linearGradient1547"> + <stop + style="stop-color:#9999ff;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1548" /> + <stop + style="stop-color:#9999fd;stop-opacity:0.00000000;" + offset="1.0000000" + id="stop1549" /> + </linearGradient> + <linearGradient + id="linearGradient1391"> + <stop + style="stop-color:#ffc000;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1392" /> + <stop + style="stop-color:#ff0000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1394" /> + </linearGradient> + <linearGradient + id="linearGradient1111"> + <stop + style="stop-color:#e8e838;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1112" /> + <stop + style="stop-color:#ffff7f;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1114" /> + </linearGradient> + <linearGradient + id="linearGradient1274"> + <stop + style="stop-color:#ff0400;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1275" /> + <stop + style="stop-color:#fd6972;stop-opacity:1.0000000;" + offset="0.0099999998" + id="stop1277" /> + <stop + style="stop-color:#ff0000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1276" /> + </linearGradient> + <linearGradient + id="linearGradient1205"> + <stop + style="stop-color:#ffffff;stop-opacity:0.9;" + offset="0.00000000" + id="stop1206" /> + <stop + style="stop-color:#ffffff;stop-opacity:0;" + offset="1.00000000" + id="stop1207" /> + </linearGradient> + <linearGradient + id="linearGradient1172"> + <stop + style="stop-color:#ffffff;stop-opacity:0.3;" + offset="0.00000000" + id="stop1173" /> + <stop + style="stop-color:#ffffff;stop-opacity:0.8;" + offset="1.00000000" + id="stop1174" /> + </linearGradient> + <linearGradient + id="linearGradient969"> + <stop + style="stop-color:#ffffff;stop-opacity:0.70196080;" + offset="0.00000000" + id="stop970" /> + <stop + style="stop-color:#9999ff;stop-opacity:0.70196080;" + offset="1.0000000" + id="stop971" /> + </linearGradient> + <linearGradient + id="linearGradient684"> + <stop + style="stop-color:#ffffff;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop685" /> + <stop + style="stop-color:#9999ff;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop686" /> + </linearGradient> + <linearGradient + id="linearGradient671"> + <stop + style="stop-color:#ffffff;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop672" /> + <stop + style="stop-color:#ffffff;stop-opacity:0.00000000;" + offset="1.0000000" + id="stop673" /> + </linearGradient> + <linearGradient + id="linearGradient594"> + <stop + style="stop-color:#fffbfb;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop595" /> + <stop + style="stop-color:#007aff;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop596" /> + </linearGradient> + <linearGradient + id="linearGradient1155"> + <stop + style="stop-color:#fffbfb;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1156" /> + <stop + style="stop-color:#9999ff;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1157" /> + </linearGradient> + <radialGradient + xlink:href="#linearGradient1155" + id="radialGradient1158" + cx="0.21874997" + cy="0.23437454" + r="0.70745194" + fx="0.21874997" + fy="0.23437454" /> + <radialGradient + xlink:href="#linearGradient684" + id="radialGradient1169" + cx="0.77941167" + cy="0.65624988" + r="0.32758817" + fx="0.77941167" + fy="0.65624988" /> + <linearGradient + xlink:href="#linearGradient1155" + id="linearGradient1170" + x1="39.904693" + y1="205.22107" + x2="28.554472" + y2="212.26643" + gradientTransform="matrix(4.2446192,0,0,4.0663556,526.57826,-780.11618)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient594" + id="linearGradient588" + x1="331.69558" + y1="519.82318" + x2="377.3627" + y2="537.58599" + gradientTransform="matrix(0.7771299,0,0,1.2867861,-1.839794,-597.93306)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient1547" + id="linearGradient639" + x1="0.47535211" + y1="-0.11428571" + x2="0.58802819" + y2="0.96190476" /> + <linearGradient + xlink:href="#linearGradient1155" + id="linearGradient643" + x1="0.20312500" + y1="0.10687023" + x2="0.50000000" + y2="0.88549620" /> + <linearGradient + xlink:href="#linearGradient1563" + id="linearGradient670" + x1="265.95663" + y1="735.08612" + x2="313.4116" + y2="761.44375" + gradientTransform="matrix(0.9763285,0,0,1.0242454,-241.01302,-713.84008)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient683" + x1="0.39084506" + y1="-0.06603774" + x2="0.59859157" + y2="0.94339621" /> + <linearGradient + xlink:href="#linearGradient1608" + id="linearGradient701" + x1="-196.8662" + y1="425.48517" + x2="-141.23934" + y2="425.48517" + gradientTransform="matrix(1.677741,0,0,0.5960396,114.06723,-183.9794)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient671" + id="linearGradient703" + x1="0.45070422" + y1="-0.93750000" + x2="0.44366196" + y2="1.21875000" /> + <radialGradient + xlink:href="#linearGradient1271" + id="radialGradient704" + cx="292.27442" + cy="807.81573" + r="24.522423" + fx="292.27442" + fy="807.81573" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient969" + id="linearGradient967" + x1="0.39297354" + y1="0.06249970" + x2="0.46580359" + y2="0.96093768" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient968" + x1="0.08771923" + y1="0.02343778" + x2="0.55263156" + y2="1.32031250" /> + <linearGradient + xlink:href="#linearGradient671" + id="linearGradient1138" + x1="0.50000000" + y1="0.05468750" + x2="0.71717173" + y2="1.70312500" /> + <linearGradient + xlink:href="#linearGradient671" + id="linearGradient1139" + x1="359.54053" + y1="199.43834" + x2="383.23312" + y2="207.27092" + gradientTransform="scale(0.4268666,2.3426521)" + gradientUnits="userSpaceOnUse" /> + <radialGradient + xlink:href="#linearGradient969" + id="radialGradient1140" + cx="0.11029412" + cy="0.06250000" + r="1.26334059" + fx="0.11029412" + fy="0.06250000" /> + <linearGradient + xlink:href="#linearGradient1172" + id="linearGradient1175" + x1="210.53689" + y1="386.86683" + x2="206.25145" + y2="389.11669" + gradientTransform="scale(0.758349,1.3186542)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient1202" + x1="0.16197200" + y1="-0.11904722" + x2="0.32746491" + y2="1.99999797" /> + <radialGradient + xlink:href="#linearGradient684" + id="radialGradient1203" + cx="0.77941167" + cy="0.65624988" + r="0.32758817" + fx="0.77941167" + fy="0.65624988" /> + <radialGradient + xlink:href="#linearGradient1547" + id="radialGradient983" + cx="0.73913020" + cy="0.72519094" + r="0.22669560" + fx="0.73913020" + fy="0.72519094" /> + <radialGradient + xlink:href="#linearGradient1205" + id="radialGradient1066" + cx="0.76470590" + cy="0.76562488" + r="0.29453236" + fx="0.76470590" + fy="0.76562482" /> + <linearGradient + xlink:href="#linearGradient1274" + id="linearGradient1273" + x1="-0.019230817" + y1="-3.8570047e-008" + x2="0.51923072" + y2="0.87500006" /> + <linearGradient + xlink:href="#linearGradient1280" + id="linearGradient1110" + x1="459.4994" + y1="1254.0935" + x2="481.37598" + y2="1325.9788" + gradientTransform="matrix(1.6468933,0,0,0.6072039,115.90702,-728.55844)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient1111" + id="linearGradient1118" + x1="0.53521127" + y1="1.0151515" + x2="0.52816904" + y2="0.015151516" /> + <radialGradient + xlink:href="#linearGradient1391" + id="radialGradient1395" + cx="0.69533569" + cy="0.78121674" + r="0.68209499" + fx="0.69533557" + fy="0.76559359" /> + <radialGradient + xlink:href="#linearGradient1547" + id="radialGradient1442" + cx="291.17355" + cy="815.41846" + r="18.939451" + fx="290.62314" + fy="814.83362" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient1604" + x1="0.52343750" + y1="0.0076335878" + x2="1.0312500" + y2="1.1297710" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient1617" + x1="0.10920641" + y1="-0.40239441" + x2="1.2083132" + y2="1.9653628" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient1618" + x1="0.42672610" + y1="-0.31047121" + x2="1.0007051" + y2="2.1198800" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient3271" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" + gradientTransform="matrix(1.646893,0,0,0.607204,-404.3959,232.2467)" + gradientUnits="userSpaceOnUse" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient3289" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient4195" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.646893,0,0,0.607204,-404.3959,232.2467)" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient4197" + gradientUnits="userSpaceOnUse" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient4209" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.646893,0,0,0.607204,-404.3959,232.2467)" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient4211" + gradientUnits="userSpaceOnUse" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient4223" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.646893,0,0,0.607204,-404.3959,232.2467)" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient4225" + gradientUnits="userSpaceOnUse" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient2823" + x1="169.59108" + y1="1212.3388" + x2="175.37662" + y2="1267.5976" + gradientTransform="matrix(1.6468933,0,0,0.6072039,-241.01302,-713.84008)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1172" + id="linearGradient2825" + x1="339.63678" + y1="379.11596" + x2="335.35134" + y2="381.36582" + gradientTransform="matrix(0.758349,0,0,1.3186542,125.10599,-388.19654)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient2827" + x1="588.89265" + y1="195.07545" + x2="612.58524" + y2="202.90803" + gradientTransform="matrix(0.4268666,0,0,2.3426521,125.10599,-388.19654)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1172" + id="linearGradient2829" + x1="477.45044" + y1="381.63529" + x2="473.165" + y2="383.88514" + gradientTransform="matrix(0.758349,0,0,1.3186542,156.38249,-391.87613)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient2831" + x1="833.72519" + y1="196.49355" + x2="857.41778" + y2="204.32614" + gradientTransform="matrix(0.4268666,0,0,2.3426521,156.38249,-391.87613)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1172" + id="linearGradient3604" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.758349,0,0,1.3186542,596.58502,-401.58502)" + x1="210.53689" + y1="386.86683" + x2="206.25145" + y2="389.11669" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3608" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.4268666,0,0,2.3426521,596.58502,-401.58502)" + x1="359.54053" + y1="199.43834" + x2="383.23312" + y2="207.27092" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1608" + id="linearGradient3613" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.677741,0,0,0.5960396,112.0526,-127.41089)" + x1="-196.8662" + y1="425.48517" + x2="-141.23934" + y2="425.48517" /> + </defs> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#666666" + borderopacity="1.0" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="1.130388" + inkscape:cx="443.79091" + inkscape:cy="943.32828" + inkscape:window-width="1096" + inkscape:window-height="675" + inkscape:window-x="84" + inkscape:window-y="-10" + showgrid="false" + snaptogrid="false" + showguides="true" + snaptoguides="true" + inkscape:current-layer="svg1141" + inkscape:snap-global="false"> + <inkscape:grid + type="xygrid" + id="grid3623" /> + </sodipodi:namedview> + <rect + style="opacity:1;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:#ffff00;stroke-width:9.29087925;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:18.58175977, 9.29087989;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="rect2821" + width="962.55579" + height="269.52261" + x="-16.443275" + y="16.154039" /> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;" + id="rect1295" + width="69.963570" + height="45.246185" + x="-101.75949" + y="509.82691" + transform="scale(-1.000000,1.000000)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;fill-opacity:1.0000000;" + id="rect1262" + width="69.963570" + height="45.246185" + x="128.72227" + y="535.48883" + transform="translate(-91.26626,99.11160)" /> + <path + sodipodi:type="arc" + style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:1.0000000pt;" + id="path1286" + sodipodi:cx="88.389725" + sodipodi:cy="698.28027" + sodipodi:rx="18.305565" + sodipodi:ry="18.305565" + d="M 106.69529 698.28027 A 18.305565 18.305565 0 1 0 70.084160,698.28027 A 18.305565 18.305565 0 1 0 106.69529 698.28027 z" + transform="translate(-17.25953,-39.22624)" /> + <path + sodipodi:type="arc" + style="fill-rule:evenodd;stroke-width:1.0000000pt;" + id="path1573" + sodipodi:cx="496.47308" + sodipodi:cy="894.01904" + sodipodi:rx="26.543070" + sodipodi:ry="26.543070" + d="M 523.01615 894.01904 A 26.543070 26.543070 0 1 0 469.93001,894.01904 A 26.543070 26.543070 0 1 0 523.01615 894.01904 z" + transform="translate(185.5400,-212.9984)" /> + <path + sodipodi:type="arc" + style="fill:url(#radialGradient1395);fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000pt;" + id="path1343" + sodipodi:cx="715.48608" + sodipodi:cy="436.77219" + sodipodi:rx="38.180180" + sodipodi:ry="38.180180" + d="M 753.66626 436.77219 A 38.180180 38.180180 0 1 0 677.30590,436.77219 A 38.180180 38.180180 0 1 0 753.66626 436.77219 z" + transform="matrix(0.905654,0.000000,0.000000,0.919132,149.4257,12.54474)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0375195;" + d="M 704.48491,415.34092 C 694.57329,417.80874 687.95315,428.45052 684.92534,434.86193 C 681.89753,441.01182 677.92934,447.28914 688.65031,452.73194 C 698.87767,454.00139 705.70466,453.64762 711.13899,450.11964 C 718.44814,445.58571 724.25946,439.88285 726.48955,434.60790 C 727.94598,431.77023 741.08206,432.37026 740.21539,430.37826 C 740.33314,426.85776 739.63744,419.26753 731.65870,414.99087 C 727.35252,412.29016 710.27910,412.15675 704.48491,415.34092 z " + id="path1377" + sodipodi:nodetypes="czcccccc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 175.16419,313.27629 C 170.59785,312.81843 161.53978,318.62958 157.57044,321.02629 C 146.72186,327.57680 135.88296,343.93132 135.88294,360.30754 C 135.88294,364.40161 132.43921,368.00533 137.35169,380.80754 C 143.39531,391.81829 170.06959,395.25262 170.28919,388.46379 C 170.50878,381.67497 166.19786,385.04854 171.50794,379.87004 C 171.67000,389.89820 175.12385,390.07619 174.97669,395.99504 C 174.88252,399.52179 174.69106,407.40659 176.03919,406.05754 L 177.97669,406.37004 L 177.97669,406.49504 L 178.35169,406.43254 L 180.28919,406.12004 C 181.63732,407.46909 181.44586,399.58428 181.35169,396.05754 C 181.20453,390.13869 184.65838,389.96069 184.82044,379.93254 C 190.13052,385.11104 185.81960,381.73746 186.03919,388.52629 C 186.25879,395.31512 212.93307,391.88078 218.97669,380.87004 C 223.88917,368.06783 220.44544,364.46410 220.44544,360.37004 C 220.44542,343.99382 209.60652,327.63929 198.75794,321.08879 C 194.78860,318.69208 185.73053,312.88092 181.16419,313.33879 C 179.64208,313.49141 178.61613,314.33756 178.44544,316.24504 L 177.64117,368.62731 L 177.88294,316.18254 C 177.71225,314.27507 176.68630,313.42891 175.16419,313.27629 z " + id="path1150" + sodipodi:nodetypes="ccccccccccccccccccccccc" /> + <path + style="fill:#ff0000;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:0.68412900pt;" + d="M 182.78509,493.16200 C 171.13638,496.94695 136.68072,486.89726 135.94501,503.73375 C 135.20931,520.57025 224.59784,516.52427 212.45865,506.21355 C 200.31947,495.90282 194.43381,489.37705 182.78509,493.16200 z " + id="path1140" + sodipodi:nodetypes="cczz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:1.2724125pt;" + d="M 496.61025,315.43263 C 487.70277,315.43523 472.41769,322.55172 466.47718,327.89823 C 454.59613,338.59121 447.94047,366.42388 447.94047,384.24553 C 447.94047,389.67769 447.95637,395.00686 448.18560,400.13622 L 542.84637,400.13622 C 543.08751,395.05165 543.13236,389.79833 543.13236,384.40325 C 543.13232,366.58163 539.47657,339.72728 527.56914,329.01351 C 521.61543,323.65662 505.51773,315.43003 496.61025,315.43263 z " + id="path1063" + sodipodi:nodetypes="cccccccc" /> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.91963024pt;" + d="M 342.97890,399.86026 L 434.73342,400.51279 L 433.34799,392.09524 C 432.07595,388.11087 427.72724,383.73612 426.88022,379.25826 C 425.59125,374.78040 431.80349,377.65786 431.05395,370.30329 C 430.30440,362.94871 428.89800,343.42434 418.26686,333.11605 C 407.32322,323.12026 398.18407,316.70378 378.78742,319.85497 C 360.64077,321.75616 350.23069,330.41956 342.83093,345.70413 C 335.23979,360.98870 343.64369,380.00725 343.40504,387.13431 L 342.97890,399.86026 z " + id="path1052" + sodipodi:nodetypes="ccczzzzzzc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.99068832pt;" + d="M 320.29479,372.55062 C 320.29479,358.42655 311.10597,330.09600 301.99795,321.60508 C 292.88992,313.11416 274.73445,313.13063 265.64663,321.60508 C 256.55879,330.07953 247.47096,358.32768 247.47096,372.45176 C 247.47096,386.57584 256.55879,400.69991 265.64663,406.34955 C 274.73445,411.99918 292.88992,411.98270 301.99795,406.34955 C 311.10597,400.71639 320.29479,386.67470 320.29479,372.55062 z " + id="path1005" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;fill-opacity:1.0000000;" + d="M 285.33919,319.75776 C 285.22106,319.75773 285.10603,319.78538 284.98790,319.78676 L 284.98790,319.81576 C 284.89998,319.80784 284.81324,319.78672 284.72444,319.78676 C 284.51750,319.78683 284.31656,319.84036 284.10969,319.84476 L 284.10969,319.96075 C 283.98357,319.94408 283.85702,319.93179 283.72913,319.93175 C 283.64032,319.93172 283.55359,319.95283 283.46566,319.96075 L 283.46566,319.93175 C 283.34754,319.93038 283.23251,319.90272 283.11438,319.90275 C 276.89311,319.90464 270.66516,321.86677 266.51610,325.76033 C 264.44158,327.70710 252.56791,343.76278 256.56299,346.52283 C 266.50559,353.79628 275.12532,332.38529 265.93062,350.14757 C 265.00413,356.24861 264.76600,359.42978 264.70112,361.02179 C 264.57010,358.10542 263.48646,351.26520 257.79249,347.94373 C 253.03583,345.22610 249.91783,369.23133 249.91783,372.47596 C 249.91783,385.45451 258.21800,398.42830 266.51610,403.61972 C 270.72453,406.25259 277.06786,407.51634 283.37784,407.47644 L 283.37784,407.50544 C 283.70047,407.50809 284.02131,407.48056 284.34388,407.47644 L 284.34388,407.33145 C 284.58784,407.34079 284.83124,407.36248 285.07573,407.36045 L 285.07573,407.33145 C 291.38571,407.37135 297.72904,406.10762 301.93747,403.47473 C 310.23557,398.28331 318.53574,385.30951 318.53574,372.33097 C 318.53574,369.08634 315.41773,345.08110 310.66108,347.79874 C 304.96711,351.12021 303.88347,357.96043 303.75245,360.87680 C 303.68757,359.28479 303.44944,356.10361 302.52294,350.00258 C 293.32825,332.24030 301.94798,353.65128 311.89058,346.37784 C 315.88566,343.61779 304.01199,327.56210 301.93747,325.61534 C 297.78841,321.72178 291.56046,319.75964 285.33919,319.75776 z " + id="path1044" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:#fffffd;fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.875;stroke-dasharray:none;" + id="path695" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,152.3260,-283.6191)" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#linearGradient1202);fill-opacity:0.75;fill-rule:evenodd;stroke:#0050fb;stroke-width:2.47293;stroke-dasharray:none;stroke-opacity:1;" + id="path1200" + sodipodi:cx="604.88873291" + sodipodi:cy="441.20190430" + sodipodi:rx="44.21426392" + sodipodi:ry="13.48378277" + d="M 649.102997 441.201904 A 44.214264 13.483783 0 1 0 560.674469,441.201904 A 44.2143 13.4838 0 1 0 649.103 441.202 L 604.888733 441.201904 z" + transform="matrix(1.042553,0.000000,0.000000,0.882208,-29.50271,47.34934)" /> + <path + style="font-size:12;fill-opacity:0.70196;stroke:#1c66f9;stroke-width:9.25243;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99;fill:url(#linearGradient968);" + d="M -49.21 243.091 C -46.9287 238.079 -38.9781 233.065 -32.1615 233.824 L 173.669 267.357 C 189.611 256.808 212.948 243.966 237.003 247.181 L 271.976 250.84 L 316.171 257.383 C 341.971 263.24 362.36 275.405 364.498 299.613 L 364.227 591.258 L -50.8332 491.502 L -49.21 243.091 z " + id="path10" + transform="matrix(0.180587,0.000000,0.000000,0.239519,475.9239,473.8713)" + sodipodi:nodetypes="cccccccccc" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.25;fill-rule:evenodd;stroke-width:0.0937284;stroke-opacity:0.53137;" + id="rect1408" + x="0.001633" + y="142.499995" + width="14.998365" + height="14.994604" + rx="0" + ry="0" + transform="matrix(15.78489,0.000000,0.000000,15.78489,215.6082,-1931.463)" /> + <rect + style="font-size:12;fill:none;fill-rule:evenodd;stroke-width:0.0520834;" + id="rect702" + width="25.000004" + height="24.999990" + x="24.999998" + y="219.999988" + transform="matrix(14.81984,0.000000,0.000000,14.99259,-23.10420,-2817.060)" /> + <path + style="font-size:12px;fill:url(#linearGradient588);fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:0.47846999pt" + d="M 257.44647,124.75373 C 258.13527,123.03175 285.34249,32.111392 285.34249,32.111392 L 316.33807,119.93219 C 316.33807,119.93219 303.25105,129.23087 288.09766,129.23087 C 272.94426,131.29724 257.10208,124.75373 257.44647,124.75373 z" + id="path593" + sodipodi:nodetypes="ccccc" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon597" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,168.93691,-207.95076)" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon598" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,159.98261,-174.88876)" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon599" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,176.51361,-187.28696)" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon600" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,174.79161,-171.10046)" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon601" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,160.67141,-156.63576)" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon602" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,184.09031,-159.39096)" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <path + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 272.27738,77.494562 C 270.75027,82.584812 270.67003,82.814932 269.13741,87.916252 L 270.27378,91.773922 L 272.65118,87.871392 L 277.07704,88.947952 L 274.87906,84.940762 L 278.03398,81.636322 L 273.47355,81.546602 L 272.27738,77.494562 z" + id="path605" /> + <path + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 290.32432,46.344392 L 289.09823,48.347992 L 284.65743,47.271432 L 286.8554,51.278622 L 283.71544,54.583062 L 288.27586,54.672782 L 289.56175,59.053772 L 291.93915,55.151252 L 293.56895,55.554962 L 290.32432,46.344392 z" + id="path608" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#ffffff;stroke-width:1.875;stroke-dasharray:none" + id="path651" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711,796.11926 A 37.428738,37.428738 0 1 1 233.92963,796.11926 A 37.428738,37.428738 0 1 1 308.78711,796.11926 z" + transform="matrix(1.269231,0,0,1.209574,-302.57031,-890.68908)" /> + <path + style="font-size:12px;fill:url(#linearGradient670);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-opacity:1" + d="M 54.678503,29.191648 L 54.678503,61.925738 L 30.642443,61.925738 L 30.642443,51.417558 C 30.642443,51.417558 30.661543,51.386768 6.2494227,72.018108 L 30.126823,91.446888 L 30.126823,81.732498 L 54.678503,81.732498 L 54.678503,115.44936 C 74.188613,109.81667 88.471763,92.706968 88.471773,72.282708 C 88.471783,51.862398 74.182783,34.827758 54.678503,29.191648 z" + id="path669" /> + <path + style="font-size:12px;fill:url(#linearGradient1170);fill-rule:evenodd;stroke:#9999ff;stroke-width:2.78699999999999990;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 682.44968,99.608656 C 689.1597,98.06451 694.06417,94.112946 698.56742,89.760146 C 702.66943,85.139869 706.77145,78.914687 708.26547,72.689506 L 674.53074,30.508874 L 635.98125,69.479657 L 682.44968,99.608656 z" + id="path709" + sodipodi:nodetypes="cccccc" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:#f5f9ff;fill-rule:evenodd;stroke:#9999ff;stroke-width:10.78610039000000000;stroke-opacity:1" + id="path587" + sodipodi:cx="220.25374" + sodipodi:cy="529.07959" + sodipodi:rx="44.626575" + sodipodi:ry="78.456398" + d="M 264.88031,529.07959 A 44.626575,78.456398 0 1 1 175.62716,529.07959 A 44.626575,78.456398 0 1 1 264.88031,529.07959 z" + transform="matrix(0.26113,0,-0.220403,0.255703,713.29596,-85.850775)" /> + <path + style="font-size:12px;fill:#ff0000;fill-rule:evenodd;stroke-width:1pt" + d="M 642.16121,64.586857 C 606.48435,62.202631 629.35685,95.037197 629.67821,97.724085 C 629.99998,100.41097 610.94825,104.97989 618.96393,114.64855 C 632.19601,124.31725 693.2264,127.53947 692.2359,112.38342 C 691.2454,97.223187 642.9138,101.57645 632.45243,97.570644 C 629.00399,88.119567 628.55736,73.041403 633.78346,68.548785 C 636.84397,66.549706 636.40814,72.019759 642.16121,64.586857 z" + id="path711" + sodipodi:nodetypes="cccccsc" /> + <path + style="font-size:12px;fill:#ff0000;fill-rule:evenodd;stroke-width:10.78610039" + d="M 669.74072,34.390532 C 664.48398,34.390532 653.88503,42.031612 646.0847,51.444467 C 639.65643,59.201621 637.1368,65.745104 639.3868,67.810322 C 646.33212,65.592565 656.79195,57.793375 664.85448,48.43956 C 668.52913,44.176371 671.14022,40.237085 672.62369,36.986075 C 672.51585,35.353721 671.58807,34.390532 669.74072,34.390532 z" + id="path592" /> + <rect + style="font-size:12.000000;fill:url(#linearGradient643);fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000002;stroke-width:1.9439127;" + id="rect642" + width="71.981430" + height="73.806518" + x="355.56149" + y="751.56487" /> + <path + style="font-size:12.000000;fill-rule:evenodd;stroke:#000002;stroke-width:1.9439127;" + d="M 355.86912,768.41833 L 355.86912,825.08081 L 426.31248,825.08081 L 421.69830,821.88448 C 413.18767,816.07293 415.69984,808.37265 406.01003,809.09909 C 396.62784,809.24438 372.43926,821.89222 368.33775,814.53095 C 363.45690,807.88664 365.01940,752.99455 361.12114,759.56548 L 355.86912,768.41833 z " + id="path640" + sodipodi:nodetypes="cccczcsc" /> + <rect + style="font-size:12.000000;fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:4.1028190;" + id="rect615" + width="57.240670" + height="49.173893" + x="519.27698" + y="1042.7878" + transform="matrix(0.859371,-0.511353,0.000000,1.000000,0.000000,0.000000)" /> + <text + xml:space="preserve" + style="font-size:48.000000;font-weight:bold;fill:#000000;stroke-width:1.0000000pt;font-family:Verdana;fill-opacity:1.0000000;" + x="709.86213" + y="1342.1935" + id="text610" + sodipodi:linespacing="100%" + transform="matrix(0.632720,-0.387288,0.000000,0.813305,0.000000,0.000000)"><tspan + x="709.86212" + y="1342.1935" + sodipodi:role="line" + id="tspan613" + style="fill:#000000;fill-opacity:1.0000000;">LR</tspan></text> + <rect + style="font-size:12.000000;fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:4.1239262;" + id="rect627" + width="57.831149" + height="49.173893" + x="-632.70609" + y="457.02159" + transform="matrix(-0.862456,-0.506131,0.000000,1.000000,0.000000,0.000000)" /> + <text + xml:space="preserve" + style="font-size:48.000000;font-weight:bold;stroke-width:1.0000000pt;font-family:Verdana;" + x="-858.67939" + y="596.71201" + id="text628" + sodipodi:linespacing="100%" + transform="matrix(-0.632720,-0.387288,0.000000,0.813305,0.000000,0.000000)"><tspan + x="-858.67938" + y="596.71204" + sodipodi:role="line" + id="tspan629">LR</tspan></text> + <rect + style="font-size:12.000000;fill:url(#linearGradient1617);fill-rule:evenodd;stroke:#000000;stroke-width:0.77675028pt;" + id="rect648" + width="56.066268" + height="49.173893" + x="649.12604" + y="1116.5706" + transform="matrix(0.852907,-0.522062,0.000000,1.000000,0.000000,0.000000)" /> + <rect + style="font-size:12.000000;fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:0.77675028pt;" + id="rect649" + width="56.066268" + height="49.173893" + x="-761.52524" + y="380.12168" + transform="matrix(-0.852907,-0.522062,0.000000,1.000000,0.000000,0.000000)" /> + <path + style="font-size:12.000000;fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2.4003696;fill-opacity:1.0000000;stroke-opacity:1.0000000;" + d="M 586.02954,781.20391 C 576.62200,796.60958 567.62949,793.58791 569.22048,807.83469 C 571.77988,813.49422 577.86711,800.59504 591.84007,797.41464 C 597.37391,793.56282 600.31377,785.36998 593.29271,770.69383 C 584.81901,757.01251 564.65506,775.58222 560.50467,790.68280 C 556.35428,805.45774 563.75581,807.31272 569.01296,805.97641" + id="path646" + sodipodi:nodetypes="ccczzc" /> + <path + style="font-size:12.000000;fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:2.4003696;" + d="M 618.03676,782.42607 C 627.44430,797.83174 636.43680,794.81007 634.84582,809.05685 C 632.28642,814.71638 626.19918,801.81720 612.22623,798.63680 C 606.69238,794.78498 603.75252,786.59214 610.77359,771.91599 C 619.24729,758.23467 639.41124,776.80439 643.56163,791.90496 C 647.71201,806.67990 640.31049,808.53488 635.05334,807.19857" + id="path650" + sodipodi:nodetypes="ccczzc" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient1158);fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="path1411" + d="M 69.375000 165.000000 A 4.375000 4.375000 0 1 0 60.625000,165.000000 A 4.375 4.375 0 1 0 69.375 165 L 65.000000 165.000000 z" + sodipodi:cx="65.000000" + sodipodi:cy="165.000000" + sodipodi:rx="4.375000" + sodipodi:ry="4.375000" + transform="matrix(6.282797,0.000000,0.000000,6.282797,-36.58204,-479.7863)" /> + <path + style="font-size:12;fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:39.4622;stroke-linecap:round;stroke-linejoin:round;" + d="M 550.91978,487.64604 L 629.84423,566.57049" + id="path1413" + sodipodi:nodetypes="cc" + transform="matrix(0.398026,0.000000,0.000000,0.398026,176.0698,386.3398)" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient1203);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87645;stroke-dasharray:none;" + id="path682" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,46.26003,-283.6018)" /> + <path + style="font-size:12;fill:url(#linearGradient683);fill-opacity:0.38017;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 390.66521,633.72235 C 371.44051,633.72235 354.98613,644.70534 347.51136,660.37076 C 353.42953,663.40271 360.03471,666.27491 367.81906,664.18848 C 382.43619,660.99617 387.00568,653.47068 394.31424,650.27839 C 409.63412,649.70584 416.97120,657.57598 432.07387,657.23344 C 423.97641,643.28339 408.56719,633.72236 390.66521,633.72235 z " + id="path687" /> + <text + xml:space="preserve" + style="fill:black;fill-opacity:1;stroke:none;font-family:Palatino Linotype;font-style:normal;font-weight:bold;font-size:48;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;text-anchor:start;writing-mode:lr;" + x="127.75068" + y="373.16888" + id="text688" + sodipodi:linespacing="100%" + transform="scale(2.880225,1.909157)"><tspan + x="127.75068" + y="373.16888" + sodipodi:role="line" + id="tspan693">i</tspan></text> + <path + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 496.33119,633.22307 L 496.33119,725.97164 C 523.77846,725.97164 546.04854,705.21602 546.04851,679.61336 C 546.04851,654.01069 523.77844,633.22305 496.33119,633.22307 z " + id="path700" /> + <path + style="font-size:12;fill:url(#linearGradient639);fill-opacity:0.49999997;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 496.76745,633.22395 C 477.54275,633.22395 461.08837,644.20694 453.61360,659.87236 C 459.53177,662.90431 466.13695,665.77651 473.92130,663.69008 C 488.53843,660.49777 493.10792,652.97228 500.41648,649.77999 C 515.73636,649.20744 523.07344,657.07758 538.17611,656.73504 C 530.07865,642.78499 514.66943,633.22396 496.76745,633.22395 z " + id="path697" /> + <g + id="g708" + transform="matrix(1.262750,0.000000,0.000000,1.262750,-71.71251,-181.4823)" + style=""> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect705" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect706" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g711" + transform="matrix(1.262750,0.000000,0.000000,1.262750,10.32260,-181.7613)" + style=""> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect712" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect713" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g721" + transform="matrix(0.878674,-0.906901,0.906901,0.878674,-460.8343,623.7427)" + style="font-size:12;"> + <g + id="g722"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect723" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect724" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g725" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect726" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect727" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + </g> + <g + id="g728" + transform="matrix(1.073491e-5,-1.262750,1.262750,1.073491e-5,-178.5732,1437.573)" + style="font-size:12;"> + <g + id="g729"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect730" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect731" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g732" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect733" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect734" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + </g> + <g + id="g735" + transform="matrix(0.893911,0.891887,-0.891887,0.893911,758.6406,-462.3620)" + style="font-size:12;"> + <g + id="g736"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect737" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect738" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g739" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect740" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect741" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + </g> + <path + style="font-size:12;fill:#e6e6e6;fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 683.81237,652.51288 C 671.83423,652.51288 661.58216,660.41352 656.92493,671.68248 C 660.61230,673.86352 664.72773,675.92965 669.57785,674.42877 C 678.68520,672.13237 681.53227,666.71889 686.08594,664.42251 C 695.63114,664.01065 700.20259,669.67205 709.61245,669.42564 C 704.56725,659.39064 694.96638,652.51289 683.81237,652.51288 z " + id="path801" /> + <path + style="fill:#fb4100;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 476.34114,554.66904 C 483.92112,533.01461 496.96853,549.86409 506.53666,550.82511 C 514.86216,550.34456 515.73201,524.39800 531.51319,528.72246 C 538.84464,531.28509 536.85645,548.74295 535.61383,558.03249 C 535.48959,568.60329 536.86193,580.71156 526.29423,589.74497 C 511.50642,601.90523 468.76115,575.84293 476.34114,554.66904 z " + id="path760" + sodipodi:nodetypes="ccccsz" /> + <path + style="font-size:12;stroke:#1c4ed9;stroke-width:10.9208;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216;fill:#4789f7;fill-opacity:1;" + d="M -25.481958,248.26603 L 449.26700,273.43400 L 430.54500,310.73100 L -40.947002,275.21320 L -25.481958,248.26603 z " + id="path279" + transform="matrix(0.158157,4.271800e-2,5.364549e-3,0.156933,469.3436,553.4222)" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill:url(#linearGradient967);fill-opacity:0.6993;stroke:#1c66fb;stroke-width:9.25243;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216;" + d="M -49.210000,251.69600 C -50.453100,239.20100 -40.203100,227.28000 -26.572700,228.54900 L 168.87300,263.91600 L 168.28600,299.92400 L 253.04600,316.79000 L 253.93000,278.87900 L 343.03800,291.68700 C 354.24800,294.90300 361.40100,301.55900 364.49800,316.81800 L 362.20763,586.89881 L -28.092563,469.70606 L -49.210000,251.69600 z " + id="path208" + transform="matrix(0.171298,0.000000,6.402228e-2,0.215063,438.9690,493.7050)" + sodipodi:nodetypes="ccccccccccc" /> + <path + style="font-size:12;fill-opacity:0.99;stroke:#0c1dfb;stroke-width:2.63195;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99;fill:url(#radialGradient1140);" + d="M 557.37226,540.24997 C 557.04724,536.47774 559.72713,532.59711 563.29085,532.12238 L 643.91869,532.55043 C 646.84958,532.82956 648.71975,534.42669 649.52947,538.93308 L 649.45887,612.42139 L 641.22180,619.79126 L 564.84594,620.14154 L 557.39252,612.04259 L 557.37226,540.24997 z " + id="path1131" + sodipodi:nodetypes="ccccccccc" /> + <path + style="font-size:12;fill:url(#linearGradient1138);fill-opacity:0.6993;stroke:#1c2942;stroke-width:2.28142;stroke-opacity:0.99216;" + d="M 582.66195,589.79239 L 627.14365,589.80274 L 627.52772,620.32722 L 582.36162,620.36346 L 582.66195,589.79239 z " + id="path230" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill:#ffffff;fill-opacity:0.99216;stroke:#1c2942;stroke-width:1.10123;stroke-opacity:0.99216;" + d="M 568.04305,545.40016 L 562.27509,545.17995 L 562.26523,539.14553 L 568.02662,539.08853 L 568.04305,545.40016 z " + id="path313" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill-opacity:1;stroke:#0c5cff;stroke-width:2.20247;stroke-opacity:0.99216;fill:#fffffd;" + d="M 572.55890,532.87597 L 635.43355,532.88839 L 635.97643,578.77497 L 572.13438,578.81877 L 572.55890,532.87597 z " + id="path412" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill:#1c2942;fill-opacity:0.992157;stroke-width:8.96855;" + d="M 600.69196,615.30986 L 590.20322,615.52766 L 590.18460,593.72001 L 600.66094,593.93144 L 600.69196,615.30986 z " + id="path415" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill:#ffffff;fill-opacity:0.99216;stroke:#1c2942;stroke-width:1.10123;stroke-opacity:0.99216;" + d="M 645.41453,544.95545 L 639.64657,544.73523 L 639.63671,538.70081 L 645.39810,538.64382 L 645.41453,544.95545 z " + id="path420" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:#fb4100;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 576.19524,551.65510 C 583.02443,538.35600 594.77948,548.70415 603.39989,549.29433 C 610.90075,548.99924 611.68442,533.06410 625.90249,535.71996 C 632.50774,537.29380 630.72141,567.64918 621.20046,573.19704 C 607.87739,580.66531 569.36604,564.65909 576.19524,551.65510 z " + id="path1137" + sodipodi:nodetypes="cccsz" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1148" + width="106.29921722" + height="106.29921722" + x="336.61416260" + y="414.56689177" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 399.79349,29.478141 C 394.01003,37.897331 389.76933,44.313401 384.9431,55.360711 C 380.11687,66.790261 374.78829,95.058691 378.54786,99.703761 C 382.30743,104.34882 387.79639,101.28107 391.55595,97.166341 C 395.31552,93.051611 393.41107,72.114871 394.59733,63.001481 C 395.47109,53.888091 397.81554,44.448881 399.79349,29.478141 z" + id="path1163" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:url(#linearGradient2827);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 385.79975,61.950721 C 384.39977,66.053801 382.76808,68.876061 381.59981,74.259941 C 380.43155,79.830111 378.76345,93.606671 379.67351,95.870431 C 380.58358,98.134191 381.91227,96.639131 382.82233,94.633821 C 383.73239,92.628521 383.27139,82.425051 383.55854,77.983661 C 383.77005,73.542261 385.32096,69.246681 385.79975,61.950721 z" + id="path1164" + sodipodi:nodetypes="czzzzc" /> + <path + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 387.76969,122.16169 C 374.14929,118.58454 373.19714,111.18089 376.70862,106.18812 C 378.0326,104.78911 381.14608,102.64524 382.95355,102.77517 C 384.76102,102.90509 386.31925,103.82082 388.64051,105.48324 C 393.90804,109.43309 383.97808,111.14862 387.76969,122.16169 z" + id="path1165" + sodipodi:nodetypes="ccszc" /> + <path + style="font-size:12px;fill:url(#linearGradient2825);fill-rule:evenodd;stroke-width:1pt" + d="M 383.31916,117.56095 C 380.06121,116.73931 378.52695,116.89671 376.51406,111.97105 C 374.50117,107.35789 379.50565,105.84217 380.09993,105.21645 C 380.69421,104.59072 381.56185,105.00397 382.15613,105.55826 C 382.75041,106.11254 382.44937,108.93289 382.63688,110.16053 C 382.775,111.38818 380.50651,113.51302 383.31916,117.56095 z" + id="path1166" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:#ff0000;fill-opacity:1;fill-rule:nonzero;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + id="path1178" + d="M 455.50254,75.604101 C 456.32704,82.434381 433.36083,91.336801 432.43523,95.264781 C 430.53314,99.605271 445.41627,109.90975 441.38223,115.0509 C 438.80608,122.80077 399.07488,126.74456 389.83131,124.33877 C 388.67751,122.94637 388.47739,119.75952 390.59044,117.85443 C 396.23015,114.547 423.95938,117.37599 433.11584,112.39908 C 433.91914,110.30782 423.41753,99.787221 426.63857,94.222171 C 430.01582,87.365091 450.70407,80.206461 450.38751,76.172481 C 447.40747,71.620301 424.32171,64.457751 421.58361,60.527391 C 421.58361,60.527391 451.61221,69.886581 455.50254,75.604101 z" + sodipodi:nodetypes="cccccccccc" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 535.58083,29.120673 C 529.79737,37.539863 525.55667,43.955933 520.73044,55.003243 C 515.90421,66.432793 510.57563,94.701223 514.3352,99.346293 C 518.09477,103.99135 523.58373,100.9236 527.34329,96.808873 C 531.10286,92.694143 529.19841,71.757403 530.38467,62.644013 C 531.25843,53.530623 533.60288,44.091413 535.58083,29.120673 z" + id="path1183" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:url(#linearGradient2831);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 521.58709,61.593253 C 520.18711,65.696333 518.55542,68.518593 517.38715,73.902473 C 516.21889,79.472643 514.55079,93.249203 515.46085,95.512963 C 516.37092,97.776723 517.69961,96.281663 518.60967,94.276353 C 519.51973,92.271053 519.05873,82.067583 519.34588,77.626193 C 519.55739,73.184793 521.1083,68.889213 521.58709,61.593253 z" + id="path1184" + sodipodi:nodetypes="czzzzc" /> + <path + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 523.55702,121.80422 C 509.93663,118.22707 508.98448,110.82343 512.49595,105.83066 C 513.81993,104.43164 516.93341,102.28778 518.74088,102.4177 C 520.54835,102.54763 522.10658,103.46335 524.42784,105.12578 C 529.69537,109.07563 519.76541,110.79116 523.55702,121.80422 z" + id="path1185" + sodipodi:nodetypes="ccszc" /> + <path + style="font-size:12px;fill:url(#linearGradient2829);fill-rule:evenodd;stroke-width:1pt" + d="M 519.1065,117.20348 C 515.84855,116.38184 514.31429,116.53924 512.3014,111.61358 C 510.28851,107.00042 515.29299,105.4847 515.88727,104.85898 C 516.48155,104.23325 517.34919,104.6465 517.94347,105.20079 C 518.53775,105.75507 518.23671,108.57542 518.42422,109.80306 C 518.56234,111.03071 516.29385,113.15555 519.1065,117.20348 z" + id="path1186" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:#ff0000;fill-opacity:1;fill-rule:nonzero;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + id="path1187" + d="M 591.28988,75.246633 C 592.11438,82.076913 569.14817,90.979333 568.22257,94.907313 C 566.32048,99.247803 581.20361,109.55228 577.16957,114.69343 C 574.59342,122.4433 534.86222,126.38709 525.61865,123.9813 C 524.46485,122.5889 524.26473,119.40205 526.37778,117.49696 C 532.01749,114.18953 559.74672,117.01852 568.90318,112.04161 C 569.70648,109.95035 559.20487,99.429753 562.42591,93.864703 C 565.80316,87.007623 586.49141,79.848993 586.17485,75.815013 C 583.19481,71.262833 560.10905,64.100283 557.37095,60.169923 C 557.37095,60.169923 587.39955,69.529113 591.28988,75.246633 z" + sodipodi:nodetypes="cccccccccc" /> + <path + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#00de00;stroke-width:3.88089991;stroke-linecap:round;stroke-dasharray:7.76179, 7.76179;stroke-dashoffset:0" + d="M 557.66559,66.516353 L 524.96189,118.44451" + id="path1189" /> + <path + style="fill:#fb4100;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 561.65094,448.09913 C 571.11508,425.70443 587.40564,443.12995 599.35212,444.12377 C 609.74708,443.62687 610.83312,416.79324 630.53703,421.26553 C 639.69082,423.91576 637.21526,475.03199 624.02079,484.37417 C 605.55720,496.95021 552.18679,469.99689 561.65094,448.09913 z " + id="path1196" + sodipodi:nodetypes="cccsz" /> + <path + style="font-size:12;fill:url(#radialGradient1140);fill-opacity:0.99;stroke:#0c1dfb;stroke-width:2.47208;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99;" + d="M 555.37415,438.95253 C 566.02431,447.52015 591.18209,448.17514 604.56628,448.38069 C 617.95046,448.58624 641.07727,445.71069 647.53136,437.79076 L 639.22369,509.12451 C 628.37584,514.24774 616.58726,517.38839 602.91722,517.02493 C 589.24718,516.66148 572.12780,514.45376 562.84783,509.43353 L 555.37415,438.95253 z " + id="path1199" + sodipodi:nodetypes="czcczcc" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect983" + width="106.29922" + height="106.29922" + x="229.68997" + y="308.89271" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect984" + width="106.29922" + height="106.29922" + x="335.98920" + y="308.89271" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 279.95280,346.67442 C 280.29433,345.98764 279.36877,338.54690 277.95386,336.62391 C 276.53895,334.70092 274.43956,335.54857 274.09803,336.23535 C 273.75651,336.92213 275.86774,336.00777 277.28264,337.93076 C 278.69755,339.85374 279.61128,347.36120 279.95280,346.67442 z " + id="path1018" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt;" + d="M 273.63423,385.40914 C 270.65408,385.12172 270.05831,378.23536 267.98919,382.43631 C 265.82503,386.71235 270.28496,395.88181 270.67731,391.14244 C 270.97461,386.40309 276.51934,385.77163 273.63423,385.40914 z " + id="path1019" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 288.50077,346.53195 C 288.15924,345.84516 289.08480,338.40442 290.49971,336.48144 C 291.91461,334.55844 294.01401,335.40609 294.35554,336.09287 C 294.69706,336.77966 292.58583,335.86530 291.17093,337.78828 C 289.75602,339.71127 288.84229,347.21873 288.50077,346.53195 z " + id="path1036" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt;" + d="M 294.81934,385.26667 C 297.79949,384.97925 298.39526,378.09288 300.46438,382.29384 C 302.62854,386.56988 298.16861,395.73934 297.77626,390.99997 C 297.47896,386.26061 291.93423,385.62916 294.81934,385.26667 z " + id="path1037" + sodipodi:nodetypes="czzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 409.23451,358.84667 C 408.54949,363.52087 396.22993,361.07089 396.03530,368.76520 C 395.84067,375.96034 411.64662,377.37220 417.55186,375.25440 C 423.45711,373.13660 427.32607,369.84225 426.71517,362.54762 C 426.10429,355.25299 424.14266,336.89820 402.58195,326.37323 C 381.45319,316.34743 357.52241,330.01251 349.87361,344.61299 C 342.22480,359.71267 341.61655,375.00482 350.68776,369.51396 C 359.32701,364.52225 369.86822,348.78540 385.68092,346.96694 C 401.06163,345.14847 409.91950,355.17081 409.23451,358.84667 z " + id="path1045" + sodipodi:nodetypes="czzzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0877723pt;fill-opacity:1.0000000;" + d="M 373.63251,370.33086 C 372.33483,368.22505 372.73946,360.23826 365.81846,361.79098 C 358.89746,363.34369 351.38109,370.76217 349.29735,373.43628 C 347.21361,376.11041 348.32990,380.85478 349.29735,381.97618 C 350.26481,383.09758 355.77183,383.70140 357.33465,385.08158 C 358.89746,386.46177 362.54401,391.63747 364.47891,391.29243 C 366.41382,390.94738 370.35806,386.80682 370.50689,385.08160 C 370.65573,383.35636 374.93016,372.43670 373.63251,370.33086 z " + id="path1049" + sodipodi:nodetypes="czzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:none;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 369.80420,399.98508 C 370.22508,395.78373 374.95545,379.12917 375.72069,374.09587 C 376.48592,369.06258 373.57804,371.60003 374.80242,369.35376 C 376.02678,367.10748 380.15902,361.82463 383.06689,360.61829 C 385.97478,359.41197 390.10702,360.11025 392.24966,361.23339 C 394.39230,362.35653 395.73146,366.10916 395.92276,367.35707 C 396.11406,368.60500 394.43057,370.01932 393.39750,369.60335 C 392.36444,369.18737 394.01446,362.68044 391.51002,364.68476 C 389.00558,366.86555 385.84845,370.56008 384.21474,372.09919 C 382.90569,373.63828 386.12783,372.84795 386.74001,374.09587 C 387.35219,375.34380 388.50003,377.42367 387.88785,379.58674 C 387.27565,381.74980 384.63561,385.70156 383.06689,387.07427 C 381.49816,388.44699 380.12076,385.78476 378.47552,387.82304 C 376.83027,389.86131 374.60431,398.21199 373.22688,400.16706 L 369.80420,399.98508 z " + id="path1050" + sodipodi:nodetypes="czzzzzzzzzzzzcc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;fill-opacity:1.0000000;stroke-dasharray:none;" + d="M 368.64815,355.65182 C 369.07734,357.32494 370.41856,361.26175 371.38424,362.14751 C 372.34992,363.03329 374.41542,363.29574 374.76413,362.14751 C 375.11285,360.99928 372.77913,355.22533 378.62686,352.10871 C 384.63554,348.99209 394.02411,349.71383 396.97480,351.12452 C 399.92548,352.53519 404.88802,357.78424 400.19374,361.36016 C 396.30418,364.93605 405.74639,365.03448 407.75823,363.52538 C 409.77007,362.01628 412.69261,356.42939 410.09064,353.73925 C 407.48867,351.04912 400.89223,344.62204 394.77625,343.96592 C 388.66028,343.30978 374.03986,350.59961 372.02803,351.12452 C 369.85526,351.64942 368.21896,353.97868 368.64815,355.65182 z " + id="path1051" + sodipodi:nodetypes="czzzzzzzzzz" /> + <g + id="g1422"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.1655209pt;" + d="M 500.15302,318.39576 C 498.63090,318.58535 497.62728,319.44559 497.45659,321.35308 L 496.27180,334.48360 L 495.12787,321.15593 C 494.44510,313.52598 480.11544,322.81032 474.82299,326.00594 C 463.97441,332.55643 453.12906,348.90299 453.12904,365.27921 C 453.12904,369.37327 450.53202,374.85695 458.19505,375.61014 C 471.12797,372.25560 475.71395,368.40706 475.88521,364.72718 C 475.97004,366.73597 472.22575,370.99591 477.19257,377.85771 C 471.88006,374.61864 449.68734,372.98113 454.59982,385.78334 C 460.64344,396.79407 487.30926,400.22178 487.52886,393.43295 C 487.74845,386.64413 493.79077,380.76155 483.19824,381.13048 C 485.89452,378.43241 492.43160,379.68832 495.12787,376.99022 L 496.31266,372.81053 L 497.66087,376.55648 C 500.35715,379.25456 506.64909,378.23526 509.34537,380.93333 C 500.48613,379.72791 504.79515,386.40754 505.01475,393.19637 C 505.23437,399.98518 531.94102,396.59692 537.98464,385.58618 C 542.89711,372.78397 520.66354,374.42148 515.35103,377.66055 C 520.31782,370.79874 516.57357,366.49938 516.65839,364.49060 C 516.82967,368.17046 521.41564,372.05845 534.34856,375.41298 C 542.01160,374.65978 539.45542,369.17610 539.45542,365.08206 C 539.45542,348.70583 528.61005,332.35928 517.76147,325.80879 C 513.79214,323.41205 504.71936,317.82698 500.15302,318.39576 z " + id="path1060" + sodipodi:nodetypes="cccccccccccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 501.66595,339.08941 C 507.48057,336.85763 507.44235,336.64611 505.77764,338.68995 C 504.31721,340.73379 502.98053,336.92565 501.65049,348.68951 C 500.11618,360.84766 495.64707,341.51834 501.66595,339.08941 z " + id="path1057" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 491.59647,339.30071 C 485.78186,337.06892 485.82008,336.85741 487.48479,338.90125 C 488.94522,340.94509 490.28190,337.13695 491.61194,348.90080 C 493.14625,361.05897 497.61536,341.72965 491.59647,339.30071 z " + id="path1059" + sodipodi:nodetypes="czzz" /> + </g> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient983);fill-opacity:0.50000000;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none;" + id="path1065" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,153.7331,-282.7179)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt;" + id="rect1074" + width="42.038873" + height="31.251435" + x="577.48017" + y="355.15182" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 590.00000,364.23718 C 600.00000,365.07051 608.75000,368.82051 614.37500,377.36218 C 620.00000,386.52885 619.37500,387.36218 619.37500,387.36218 C 619.37500,387.36218 620.62500,396.11218 608.75000,397.36218 C 596.87500,397.98718 583.56694,385.77747 569.81694,385.77747 C 556.69194,385.77747 551.87500,383.73242 553.75000,372.36218 C 555.62500,360.55000 569.06250,334.86218 591.87500,334.23718 C 614.68750,332.98718 635.31250,340.38301 643.75000,355.48718 C 651.56250,370.59135 647.81250,382.36218 643.12500,386.11218 C 638.43750,389.86218 627.70833,384.86218 619.37500,386.73718" + id="path1067" + sodipodi:nodetypes="czzzzzzzzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 605.62500,385.48718 C 598.12500,382.98718 595.00000,382.98718 588.12500,376.73718 C 581.25000,370.48718 580.00000,364.23718 580.00000,364.23718" + id="path1068" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 597.50000,334.86218 C 598.12500,347.36218 604.92417,355.07014 602.71447,365.23480" + id="path1069" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 610.90476,341.83916 C 625.49682,341.59591 628.11190,344.21099 630.20397,355.19433 C 635.95715,352.05623 638.95397,353.81615 640.20397,366.31615" + id="path1070" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 620.21706,362.57924 C 620.21706,362.57924 610.95580,381.48089 620.33080,380.85589 C 629.70580,380.23089 626.05002,380.28181 628.70167,379.17696" + id="path1071" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 565.74009,361.50702 C 565.74009,361.50702 568.88733,353.92082 576.86459,349.47516 C 584.84184,345.55251 590.33862,342.77797 590.55959,337.25370 L 589.89668,342.92311 C 589.16881,349.14804 598.53331,356.11130 595.55959,362.81588" + id="path1072" + sodipodi:nodetypes="czczz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 606.88925,334.11254 C 612.15464,344.40283 608.33289,359.63174 612.31037,370.45931" + id="path1073" + sodipodi:nodetypes="cc" /> + <g + id="g1132" + transform="matrix(1.069142,0.000000,0.000000,1.032969,-32.93548,-15.76150)"> + <g + id="g1107" + transform="matrix(0.841944,0.000000,0.000000,0.873445,74.35371,56.03641)"> + <g + id="g1099" + transform="translate(1.325825,9.280777)"> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.65628657pt;" + d="M 496.65430,493.31750 C 496.65430,484.55800 490.15222,466.98787 483.70730,461.72195 C 477.26238,456.45602 464.41541,456.46624 457.98479,461.72195 C 451.55416,466.97766 445.12353,484.49668 445.12353,493.25619 C 445.12353,502.01571 451.55416,510.77522 457.98479,514.27903 C 464.41541,517.78283 477.26238,517.77261 483.70730,514.27903 C 490.15222,510.78544 496.65430,502.07702 496.65430,493.31750 z " + id="path1075" + sodipodi:nodetypes="czzzzzz" /> + <g + id="g1093"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:0.60115390pt;" + d="M 471.91942,460.57627 C 471.83583,460.57625 471.75443,460.59340 471.67084,460.59426 L 471.67084,460.61224 C 471.60863,460.60733 471.54725,460.59423 471.48442,460.59426 C 471.33798,460.59430 471.19580,460.62750 471.04941,460.63023 L 471.04941,460.70216 C 470.96017,460.69182 470.87062,460.68420 470.78013,460.68418 C 470.71728,460.68416 470.65591,460.69725 470.59369,460.70216 L 470.59369,460.68418 C 470.51011,460.68333 470.42871,460.66617 470.34512,460.66619 C 465.94290,460.66736 461.53595,461.88424 458.60004,464.29896 C 457.13209,465.50632 448.73018,475.46378 451.55713,477.17551 C 458.59260,481.68638 464.69200,468.40765 458.18575,479.42351 C 457.53016,483.20728 457.36165,485.18018 457.31574,486.16752 C 457.22303,484.35884 456.45624,480.11665 452.42714,478.05673 C 449.06128,476.37130 446.85496,491.25894 446.85496,493.27120 C 446.85496,501.32028 452.72823,509.36640 458.60004,512.58603 C 461.57796,514.21889 466.06655,515.00265 470.53155,514.97790 L 470.53155,514.99589 C 470.75985,514.99753 470.98688,514.98046 471.21513,514.97790 L 471.21513,514.88798 C 471.38776,514.89378 471.55999,514.90723 471.73299,514.90597 L 471.73299,514.88798 C 476.19799,514.91273 480.68658,514.12899 483.66451,512.49611 C 489.53631,509.27648 495.40958,501.23035 495.40958,493.18128 C 495.40958,491.16902 493.20325,476.28138 489.83741,477.96681 C 485.80830,480.02673 485.04151,484.26892 484.94880,486.07760 C 484.90289,485.09026 484.73439,483.11735 484.07879,479.33359 C 477.57255,468.31773 483.67194,481.59646 490.70741,477.08559 C 493.53436,475.37386 485.13245,465.41639 483.66451,464.20904 C 480.72859,461.79432 476.32164,460.57744 471.91942,460.57627 z " + id="path1076" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.60115390pt;" + d="M 468.10796,477.26953 C 468.34963,476.84360 467.69470,472.22898 466.69350,471.03637 C 465.69229,469.84376 464.20675,470.36946 463.96508,470.79539 C 463.72341,471.22132 465.21734,470.65425 466.21853,471.84686 C 467.21974,473.03946 467.86630,477.69546 468.10796,477.26953 z " + id="path1077" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.50646687pt;" + d="M 463.63689,501.29214 C 461.52811,501.11389 461.10654,496.84308 459.64241,499.44844 C 458.11103,502.10037 461.26692,507.78711 461.54455,504.84784 C 461.75492,501.90857 465.67842,501.51695 463.63689,501.29214 z " + id="path1078" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.60115390pt;" + d="M 474.15658,477.18117 C 473.91491,476.75523 474.56985,472.14061 475.57105,470.94801 C 476.57224,469.75540 478.05780,470.28110 478.29947,470.70703 C 478.54113,471.13296 477.04720,470.56589 476.04601,471.75849 C 475.04481,472.95110 474.39824,477.60710 474.15658,477.18117 z " + id="path1079" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.50646687pt;" + d="M 478.62766,501.20378 C 480.73643,501.02553 481.15801,496.75472 482.62213,499.36008 C 484.15351,502.01201 480.99763,507.69875 480.72000,504.75948 C 480.50963,501.82021 476.58613,501.42859 478.62766,501.20378 z " + id="path1080" + sodipodi:nodetypes="czzz" /> + </g> + </g> + <g + id="g1088" + transform="matrix(0.528836,0.000000,0.000000,0.528836,234.0955,290.1247)"> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:1.2724125pt;" + d="M 448.76081,243.24146 C 439.85333,243.24406 424.56825,250.36055 418.62774,255.70706 C 406.74669,266.40004 400.09103,294.23271 400.09103,312.05436 C 400.09103,317.48652 400.10693,322.81569 400.33616,327.94505 L 494.99693,327.94505 C 495.23807,322.86048 495.28292,317.60716 495.28292,312.21208 C 495.28288,294.39046 491.62713,267.53611 479.71970,256.82234 C 473.76599,251.46545 457.66829,243.23886 448.76081,243.24146 z " + id="path1084" + sodipodi:nodetypes="cccccccc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.1655209pt;" + d="M 452.30358,246.20459 C 450.78146,246.39418 449.77784,247.25442 449.60715,249.16191 L 448.42236,262.29243 L 447.27843,248.96476 C 446.59566,241.33481 432.26600,250.61915 426.97355,253.81477 C 416.12497,260.36526 405.27962,276.71182 405.27960,293.08804 C 405.27960,297.18210 402.68258,302.66578 410.34561,303.41897 C 423.27853,300.06443 427.86451,296.21589 428.03577,292.53601 C 428.12060,294.54480 424.37631,298.80474 429.34313,305.66654 C 424.03062,302.42747 401.83790,300.78996 406.75038,313.59217 C 412.79400,324.60290 439.45982,328.03061 439.67942,321.24178 C 439.89901,314.45296 445.94133,308.57038 435.34880,308.93931 C 438.04508,306.24124 444.58216,307.49715 447.27843,304.79905 L 448.46322,300.61936 L 449.81143,304.36531 C 452.50771,307.06339 458.79965,306.04409 461.49593,308.74216 C 452.63669,307.53674 456.94571,314.21637 457.16531,321.00520 C 457.38493,327.79401 484.09158,324.40575 490.13520,313.39501 C 495.04767,300.59280 472.81410,302.23031 467.50159,305.46938 C 472.46838,298.60757 468.72413,294.30821 468.80895,292.29943 C 468.98023,295.97929 473.56620,299.86728 486.49912,303.22181 C 494.16216,302.46861 491.60598,296.98493 491.60598,292.89089 C 491.60598,276.51466 480.76061,260.16811 469.91203,253.61762 C 465.94270,251.22088 456.86992,245.63581 452.30358,246.20459 z " + id="path1085" + sodipodi:nodetypes="cccccccccccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 453.81651,266.89824 C 459.63113,264.66646 459.59291,264.45494 457.92820,266.49878 C 456.46777,268.54262 455.13109,264.73448 453.80105,276.49834 C 452.26674,288.65649 447.79763,269.32717 453.81651,266.89824 z " + id="path1086" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 443.74703,267.10954 C 437.93242,264.87775 437.97064,264.66624 439.63535,266.71008 C 441.09578,268.75392 442.43246,264.94578 443.76250,276.70963 C 445.29681,288.86780 449.76592,269.53848 443.74703,267.10954 z " + id="path1087" + sodipodi:nodetypes="czzz" /> + </g> + </g> + <g + id="g1126" + transform="matrix(0.495484,0.000000,0.000000,0.495484,300.5956,311.9146)"> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.91963024pt;" + d="M 390.65866,301.36656 L 482.41318,302.01909 L 481.02775,293.60154 C 479.75571,289.61717 475.40700,285.24242 474.55998,280.76456 C 473.27101,276.28670 479.48325,279.16416 478.73371,271.80959 C 477.98416,264.45501 476.57776,244.93064 465.94662,234.62235 C 455.00298,224.62656 445.86383,218.21008 426.46718,221.36127 C 408.32053,223.26246 397.91045,231.92586 390.51069,247.21043 C 382.91955,262.49500 391.32345,281.51355 391.08480,288.64061 L 390.65866,301.36656 z " + id="path1121" + sodipodi:nodetypes="ccczzzzzzc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 456.91427,260.35297 C 456.22925,265.02717 443.90969,262.57719 443.71506,270.27150 C 443.52043,277.46664 459.32638,278.87850 465.23162,276.76070 C 471.13687,274.64290 475.00583,271.34855 474.39493,264.05392 C 473.78405,256.75929 471.82242,238.40450 450.26171,227.87953 C 429.13295,217.85373 405.20217,231.51881 397.55337,246.11929 C 389.90456,261.21897 389.29631,276.51112 398.36752,271.02026 C 407.00677,266.02855 417.54798,250.29170 433.36068,248.47324 C 448.74139,246.65477 457.59926,256.67711 456.91427,260.35297 z " + id="path1122" + sodipodi:nodetypes="czzzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0877723pt;fill-opacity:1.0000000;" + d="M 421.31227,271.83716 C 420.01459,269.73135 420.41922,261.74456 413.49822,263.29728 C 406.57722,264.84999 399.06085,272.26847 396.97711,274.94258 C 394.89337,277.61671 396.00966,282.36108 396.97711,283.48248 C 397.94457,284.60388 403.45159,285.20770 405.01441,286.58788 C 406.57722,287.96807 410.22377,293.14377 412.15867,292.79873 C 414.09358,292.45368 418.03782,288.31312 418.18665,286.58790 C 418.33549,284.86266 422.60992,273.94300 421.31227,271.83716 z " + id="path1123" + sodipodi:nodetypes="czzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:none;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 417.48396,301.49138 C 417.90484,297.29003 422.63521,280.63547 423.40045,275.60217 C 424.16568,270.56888 421.25780,273.10633 422.48218,270.86006 C 423.70654,268.61378 427.83878,263.33093 430.74665,262.12459 C 433.65454,260.91827 437.78678,261.61655 439.92942,262.73969 C 442.07206,263.86283 443.41122,267.61546 443.60252,268.86337 C 443.79382,270.11130 442.11033,271.52562 441.07726,271.10965 C 440.04420,270.69367 441.69422,264.18674 439.18978,266.19106 C 436.68534,268.37185 433.52821,272.06638 431.89450,273.60549 C 430.58545,275.14458 433.80759,274.35425 434.41977,275.60217 C 435.03195,276.85010 436.17979,278.92997 435.56761,281.09304 C 434.95541,283.25610 432.31537,287.20786 430.74665,288.58057 C 429.17792,289.95329 427.80052,287.29106 426.15528,289.32934 C 424.51003,291.36761 422.28407,299.71829 420.90664,301.67336 L 417.48396,301.49138 z " + id="path1124" + sodipodi:nodetypes="czzzzzzzzzzzzcc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.1391397pt;fill-opacity:1.0000000;" + d="M 416.32791,257.15812 C 416.75710,258.83124 418.09832,262.76805 419.06400,263.65381 C 420.02968,264.53959 422.09518,264.80204 422.44389,263.65381 C 422.79261,262.50558 420.45889,256.73163 426.30662,253.61501 C 432.31530,250.49839 441.70387,251.22013 444.65456,252.63082 C 447.60524,254.04149 452.56778,259.29054 447.87350,262.86646 C 443.98394,266.44235 453.42615,266.54078 455.43799,265.03168 C 457.44983,263.52258 460.37237,257.93569 457.77040,255.24555 C 455.16843,252.55542 448.57199,246.12834 442.45601,245.47222 C 436.34004,244.81608 421.71962,252.10591 419.70779,252.63082 C 417.53502,253.15572 415.89872,255.48498 416.32791,257.15812 z " + id="path1125" + sodipodi:nodetypes="czzzzzzzzzz" /> + </g> + </g> + <rect + style="fill:url(#linearGradient701);fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#ffffff;stroke-width:3.75000000000000000;stroke-dasharray:none" + id="rect1204" + width="91.25" + height="30" + x="-214.68277" + y="57.132778" + ry="12.5" + transform="scale(-1,1)" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:5;stroke-dasharray:none;stroke-opacity:1" + d="M 785.96002,98.902159 C 785.96002,113.04716 774.48002,124.52716 760.33502,124.52716 C 746.19002,124.52716 734.71002,113.04716 734.71002,98.902159 C 734.71002,84.757159 746.19002,73.277159 760.33502,73.277159 C 774.48002,73.277159 785.96002,84.757159 785.96002,98.902159 z" + id="path1291" /> + <path + sodipodi:nodetypes="czzzzc" + id="path1294" + d="M 773.36975,26.31038 C 767.58629,34.72957 763.34559,41.14564 758.51936,52.19295 C 753.69313,63.6225 748.36455,91.89093 752.12412,96.536 C 755.88369,101.18106 761.37265,98.11331 765.13221,93.99858 C 768.89178,89.88385 766.98733,68.94711 768.17359,59.83372 C 769.04735,50.72033 771.3918,41.28112 773.36975,26.31038 z" + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + <path + sodipodi:nodetypes="czzzzc" + id="path1295" + d="M 759.37601,58.78296 C 757.97603,62.88604 756.34434,65.7083 755.17607,71.09218 C 754.00781,76.66235 752.33971,90.43891 753.24977,92.70267 C 754.15984,94.96643 755.48853,93.47137 756.39859,91.46606 C 757.30865,89.46076 756.84765,79.25729 757.1348,74.8159 C 757.34631,70.3745 758.89722,66.07892 759.37601,58.78296 z" + style="fill:url(#linearGradient3608);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccszc" + id="path1296" + d="M 761.34595,118.99393 C 747.72556,115.41678 746.7734,108.01313 750.28488,103.02037 C 751.60886,101.62135 754.72234,99.47749 756.52981,99.60741 C 758.33728,99.73734 759.89551,100.65306 762.21677,102.31548 C 767.4843,106.26534 757.55434,107.98087 761.34595,118.99393 z" + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" /> + <path + sodipodi:nodetypes="czzzzc" + id="path1297" + d="M 756.89542,114.39319 C 753.63747,113.57155 752.10321,113.72895 750.09032,108.80329 C 748.07743,104.19013 753.08191,102.67441 753.67619,102.04869 C 754.27047,101.42296 755.13811,101.83621 755.73239,102.3905 C 756.32667,102.94478 756.02563,105.76513 756.21314,106.99277 C 756.35126,108.22042 754.08277,110.34526 756.89542,114.39319 z" + style="font-size:12px;fill:url(#linearGradient3604);fill-rule:evenodd;stroke-width:1pt" /> + <rect + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:4.56593418" + id="rect1303" + width="48.979599" + height="47.110672" + x="774.80969" + y="53.56987" /> + <path + style="fill:#cccccc;fill-rule:nonzero;stroke:none;fill-opacity:1.0000000;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;" + id="path1142" + d="M 154.48440,498.48337 C 154.25849,492.81414 161.38338,496.65143 161.80515,496.90392 C 164.78182,498.61634 170.39318,504.14280 173.95269,504.05991 C 175.95558,503.84576 177.63390,502.63440 179.05959,501.28272 C 180.33976,499.99776 181.20682,498.58127 182.06397,497.00066 C 183.44438,494.70321 187.18348,487.99384 189.77932,488.11380 C 192.16403,488.34388 196.44293,490.85911 198.63874,491.77507 C 200.34301,492.48848 203.47991,491.83913 205.21157,492.48524 C 206.51580,492.94214 202.88897,499.07531 204.26060,499.25768 C 205.40017,499.35058 206.09747,498.86094 206.93516,498.11576 C 207.57391,497.51451 211.51747,500.31315 210.70090,501.08164 C 208.56717,502.98125 206.27814,503.85683 203.40943,503.55889 C 201.58416,503.29953 199.79391,502.83223 198.06231,502.20168 C 196.27903,501.51624 194.58389,500.64017 192.82470,499.89873 C 191.28048,499.25617 189.66739,498.59467 187.99351,498.39461 C 187.36694,498.35913 187.14450,498.30179 186.79211,498.84177 C 185.67318,500.80361 184.50376,502.56949 182.88013,504.16267 C 180.31823,506.51125 177.42085,508.14583 173.89191,508.33224 C 169.23300,508.20987 162.04502,509.96482 156.25203,500.75392 C 155.96788,500.55562 159.95745,495.74444 159.84831,498.48337 L 154.48440,498.48337 z " + sodipodi:nodetypes="ccccccccccccccccccccc" /> + <rect + style="fill:#f9bac0;fill-rule:evenodd;stroke:#000000;stroke-width:0.49504948pt;" + id="rect1120" + width="12.250767" + height="12.000593" + x="141.62668" + y="387.23074" + ry="3.9226213" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <rect + style="fill:url(#linearGradient1118);fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000pt;" + id="rect1117" + width="53.347649" + height="11.244847" + x="150.89017" + y="387.60864" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.93750000;" + d="M 153.76675,391.00825 L 202.40725,390.74674 L 202.40725,390.74674" + id="path1126" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.93750000;" + d="M 153.76675,395.58464 L 202.40725,395.32313 L 202.40725,395.32313" + id="path1128" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <path + style="fill:#e49415;fill-rule:evenodd;stroke-width:1.0000000pt;fill-opacity:1.0000000;" + d="M 204.76083,387.08564 L 226.72751,392.93844 L 205.02234,399.37652 L 204.76083,387.08564 z " + id="path1129" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <path + style="fill:#040023;fill-rule:evenodd;stroke-width:1.0000000pt;" + d="M 219.01301,390.87754 L 227.25053,392.93225 L 219.11108,395.19241 L 219.01301,390.87754 z " + id="path1132" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <g + id="g1195" + transform="matrix(0.789807,0.000000,0.000000,0.829148,40.60222,144.2242)"> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient1169);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87645;stroke-dasharray:none;" + id="path1190" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,-184.6799,-194.3941)" /> + <path + style="font-size:12;fill:url(#linearGradient683);fill-opacity:0.38017;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 159.72524,722.93003 C 140.50054,722.93003 124.04616,733.91302 116.57139,749.57844 C 122.48956,752.61039 129.09474,755.48259 136.87909,753.39616 C 151.49622,750.20385 156.06571,742.67836 163.37427,739.48607 C 178.69415,738.91352 186.03123,746.78366 201.13390,746.44112 C 193.03644,732.49107 177.62722,722.93004 159.72524,722.93003 z " + id="path1191" /> + <text + xml:space="preserve" + style="fill:black;fill-opacity:1;stroke:none;font-family:Palatino Linotype;font-style:normal;font-weight:bold;font-size:48;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;text-anchor:start;writing-mode:lr;" + x="47.569456" + y="419.89508" + id="text1192" + sodipodi:linespacing="100%" + transform="scale(2.880225,1.909157)"><tspan + x="47.569454" + y="419.89508" + sodipodi:role="line" + id="tspan1193">i</tspan></text> + </g> + <path + style="fill:#fb4100;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 157.91689,807.80962 C 166.13755,791.78371 180.28774,804.25361 190.66459,804.96480 C 199.69378,804.60921 200.63712,785.40677 217.75218,788.60718 C 225.70328,790.50372 223.55297,827.08308 212.09209,833.76845 C 196.05440,842.76799 149.69621,823.47991 157.91689,807.80962 z " + id="path1179" + sodipodi:nodetypes="cccsz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 135.72268,361.98087 C 134.67665,364.33444 139.37290,364.60684 143.68234,366.31209 C 147.99177,368.01734 152.43742,371.67846 155.07429,372.44119 C 160.34804,373.96665 169.84949,374.44608 173.64136,373.48722 C 177.43323,372.52836 177.12814,369.56460 177.82549,365.64199" + id="path1135" + sodipodi:nodetypes="cszzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 163.44255,357.27376 C 158.21239,350.47455 167.88818,351.25907 168.41121,347.07494 C 171.02628,336.87613 161.08898,335.30708 161.08898,335.30708 C 161.08898,335.30708 167.10367,327.72334 168.67271,323.53921 C 163.44255,317.78603 163.96556,318.57056 155.85881,322.23167" + id="path1138" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 169.19573,382.90152 C 169.80591,375.31778 164.40140,374.66401 162.13500,373.48722" + id="path1141" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 135.59193,366.63075 C 138.73003,373.95298 150.19280,376.35013 155.46655,377.87559" + id="path1153" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 163.44255,357.27376 C 158.21239,350.47455 167.88818,351.25907 168.41121,347.07494 C 171.02628,336.87613 161.08898,335.30708 161.08898,335.30708 C 161.08898,335.30708 167.10367,327.72334 168.67271,323.53921 C 163.44255,317.78603 163.96556,318.57056 155.85881,322.23167" + id="path1167" + sodipodi:nodetypes="ccccc" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,355.9476,-0.390884)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 169.19573,382.90152 C 169.80591,375.31778 164.40140,374.66401 162.13500,373.48722" + id="path1169" + sodipodi:nodetypes="cz" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,355.9476,-0.390884)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 135.59193,366.63075 C 138.73003,373.95298 150.19280,376.35013 155.46655,377.87559" + id="path1170" + sodipodi:nodetypes="cz" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,355.9476,-0.390884)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 220.21273,361.50548 C 221.25876,363.85905 216.56251,364.13145 212.25307,365.83670 C 207.94364,367.54195 203.49799,371.20307 200.86112,371.96580 C 195.58737,373.49126 186.08592,373.97069 182.29405,373.01183 C 178.50218,372.05297 177.49973,366.73564 177.84841,362.29001" + id="path1194" + sodipodi:nodetypes="cszzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 140.95285,349.68999 C 133.28195,370.78498 141.91171,361.71936 146.70603,361.98087" + id="path1195" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 214.47932,349.22398 C 222.15022,370.31897 213.52046,361.25335 208.72614,361.51486" + id="path1218" + sodipodi:nodetypes="cz" /> + <g + id="g1278" + transform="matrix(0.605285,0.000000,0.000000,0.597196,215.4523,158.0050)" + style=""> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;fill-opacity:1.0000000;stroke-dasharray:none;" + d="M 804.64950,250.44849 C 797.35720,250.48469 789.33209,251.98524 784.49454,257.96913 C 780.93740,262.11537 778.38323,267.02039 775.64377,271.69315 C 773.68125,276.21594 769.46739,297.45551 769.30129,304.87537 C 770.14526,316.85318 776.63805,328.66066 786.98642,334.95250 C 795.22467,338.99769 804.89497,338.64881 813.70686,337.08266 C 821.45161,335.53674 827.62366,329.95749 831.57563,323.32749 C 837.11921,314.80704 839.26003,304.08986 836.74694,294.17684 C 835.76180,288.84411 831.92018,270.31405 828.52987,266.57056 C 824.89455,259.95461 819.93817,253.06220 812.07514,251.41397 C 809.65774,250.76162 807.15196,250.45235 804.64950,250.44849 z " + id="path1255" + sodipodi:nodetypes="ccccccccccc" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 800.13750,250.65056 C 801.18353,251.26075 803.25316,249.31320 803.64542,263.39105 C 804.03768,277.46890 803.99154,332.67692 804.34021,335.11767 C 804.68888,337.29691 802.01036,338.15546 798.99628,337.91766" + id="path1256" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 807.42479,250.62195 C 806.37876,251.23214 804.30913,249.28459 803.91687,263.36244 C 803.52461,277.44029 804.49532,333.01814 804.14665,335.45889 C 803.79798,337.63813 806.66142,337.94193 809.67549,337.70414" + id="path1257" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 817.70960,290.28376 C 809.84745,280.10959 810.70190,277.13212 818.95501,270.89040 C 813.26525,268.19968 813.19141,265.32450 823.17748,259.01761" + id="path1258" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 787.90305,291.30471 C 795.76520,281.13054 794.91075,278.15307 786.65764,271.91135 C 792.34740,269.22063 792.42124,266.34545 782.43517,260.03856" + id="path1259" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 799.72669,293.23848 C 796.52152,297.49150 789.40232,292.22145 787.89219,291.20442 C 786.38206,290.18739 784.19391,295.08761 779.75597,293.60830 C 775.50295,292.12899 776.05768,287.87597 776.05768,287.87597" + id="path1260" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 802.03812,301.75908 C 797.90838,303.42330 787.64564,300.37222 786.13551,299.35519 C 784.62538,298.33816 782.43723,303.23838 777.99929,301.75907 C 773.74627,300.27976 771.52729,289.36983 771.52729,289.36983" + id="path1261" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 792.23767,329.12637 C 782.56051,317.10695 791.52883,320.52786 791.86785,314.51815 C 792.57669,308.87827 798.04822,307.90662 793.98280,308.72802 C 790.96976,309.36580 788.07711,304.71769 779.29369,308.60089" + id="path1262" + sodipodi:nodetypes="czsz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 807.30819,291.84436 C 810.51336,296.09738 817.63256,290.82733 819.14269,289.81030 C 820.65282,288.79327 822.84097,293.69349 827.27891,292.21418 C 831.53193,290.73487 830.97720,286.48185 830.97720,286.48185" + id="path1263" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 804.99676,300.36496 C 809.12650,302.02918 819.38924,298.97810 820.89937,297.96107 C 822.40950,296.94404 824.59765,301.84426 829.03559,300.36495 C 833.28861,298.88564 835.50759,287.97571 835.50759,287.97571" + id="path1264" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 814.79721,327.73225 C 824.47437,315.71283 815.50605,319.13374 815.16703,313.12403 C 814.45819,307.48415 808.98666,306.51250 813.05208,307.33390 C 816.06512,307.97168 818.95777,303.32357 827.74119,307.20677" + id="path1265" + sodipodi:nodetypes="czsz" /> + </g> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1342" + width="106.29922" + height="106.29922" + x="678.02699" + y="257.57566" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt;" + id="rect1300" + width="42.038873" + height="31.251435" + x="577.48017" + y="355.15182" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 585.39981,368.71772 C 595.39981,369.55105 611.65089,374.39889 615.88182,379.14146 C 620.11275,384.31923 621.65174,382.78809 623.97519,388.42080 C 625.83395,393.88440 626.66596,396.13459 614.79096,397.38459 C 602.91596,398.00959 579.84943,391.38777 567.95818,382.48985 C 556.06694,374.46233 550.94562,372.94946 552.82062,361.57922 C 554.69562,349.76704 569.06250,334.86218 591.87500,334.23718 C 614.68750,332.98718 635.31250,340.38301 643.75000,355.48718 C 651.56250,370.59135 648.46967,378.29310 643.78217,382.04310 C 639.09467,385.79310 631.44519,384.45036 623.11186,386.32536" + id="path1301" + sodipodi:nodetypes="czzzzzzzzz" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 611.66596,385.50959 C 604.16596,383.00959 590.35311,382.60170 583.47811,376.35170" + id="path1302" + sodipodi:nodetypes="cc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 592.66063,336.86850 C 598.86190,345.30503 604.92417,355.07014 602.71447,365.23480" + id="path1303" + sodipodi:nodetypes="cc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 609.51069,344.81342 C 624.10275,344.57017 628.11190,344.21099 630.20397,355.19433 C 635.95715,352.05623 638.95397,353.81615 640.20397,366.31615" + id="path1304" + sodipodi:nodetypes="ccc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 620.21706,362.57924 C 620.21706,362.57924 610.95580,381.48089 620.33080,380.85589 C 629.70580,380.23089 626.05002,380.28181 628.70167,379.17696" + id="path1305" + sodipodi:nodetypes="ccc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 565.74009,361.50702 C 565.74009,361.50702 574.14469,356.44952 582.12195,352.00386 C 590.09920,348.08121 587.55049,347.42089 587.77146,341.89662 L 591.98094,350.60103 C 595.33715,357.54102 598.53331,356.11130 595.55959,362.81588" + id="path1306" + sodipodi:nodetypes="czczz" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 601.31298,337.74082 C 614.47809,348.72995 606.47413,361.56650 612.31037,373.07050" + id="path1307" + sodipodi:nodetypes="cc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0903397;" + d="M 707.72710,418.48163 C 703.50641,414.69683 702.27080,417.21075 699.44787,417.57363" + id="path1387" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0903397;" + d="M 725.11736,413.48274 C 719.32763,412.83604 715.73844,415.08845 712.91551,415.45133" + id="path1389" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0903397;" + d="M 699.48958,421.09685 C 695.79191,420.95903 688.54161,427.33639 686.24170,435.60327" + id="path1390" + sodipodi:nodetypes="cc" /> + <path + style="font-size:12px;fill:url(#linearGradient2823);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 41.242273,25.859958 C 22.017573,25.859958 5.5631927,36.842948 -1.9115773,52.508368 C 4.0065927,55.540318 10.611773,58.412518 18.396123,56.326088 C 33.013253,53.133778 37.582743,45.608288 44.891303,42.415998 C 60.211183,41.843448 67.548263,49.713588 82.650933,49.371048 C 74.553473,35.420998 59.144253,25.859968 41.242273,25.859958 z" + id="path1561" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient983);fill-opacity:0.50000000;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none;" + id="path1574" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(0.484769,0.000000,0.000000,0.461984,554.2006,323.4255)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;fill-opacity:1.0000000;" + id="rect1280" + width="69.963570" + height="45.246185" + x="128.72227" + y="535.48883" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt;" + id="rect1278" + width="42.038872" + height="31.251434" + x="158.54723" + y="572.81548" + transform="matrix(-0.578460,0.000000,0.000000,0.578460,265.2767,219.3138)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:4.1057291;" + d="M 163.87618,583.27959 C 173.87618,584.11292 182.62618,587.86292 188.25118,596.40459 C 193.87618,605.57126 193.25118,606.40459 193.25118,606.40459 C 193.25118,606.40459 194.50118,615.15459 182.62618,616.40459 C 170.75118,617.02959 157.44312,604.81988 143.69312,604.81988 C 130.56812,604.81988 125.75118,602.77483 127.62618,591.40459 C 129.50118,579.59241 142.93868,553.90459 165.75118,553.27959 C 188.56368,552.02959 209.18868,559.42542 217.62618,574.52959 C 225.43868,589.63376 221.68868,601.40459 217.00118,605.15459 C 212.31368,608.90459 201.58451,603.90459 193.25118,605.77959" + id="path1279" + sodipodi:nodetypes="czzzzzzzzz" + transform="matrix(-0.578460,0.000000,0.000000,0.578460,265.2767,219.3138)" /> + <g + id="g1249" + transform="translate(-9.414290,-1.046033)" + style=""> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;stroke-dasharray:none;" + id="rect1289" + width="69.963570" + height="45.246185" + x="128.72227" + y="535.48883" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,355.1279,42.36432)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt;" + id="rect1291" + width="42.038872" + height="31.251434" + x="158.54723" + y="572.81548" + transform="matrix(0.578460,0.000000,0.000000,0.578460,89.85120,261.6781)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:4.1057290;stroke-dasharray:none;" + d="M 163.87618,583.27959 C 173.87618,584.11292 182.62618,587.86292 188.25118,596.40459 C 193.87618,605.57126 193.25118,606.40459 193.25118,606.40459 C 193.25118,606.40459 194.50118,615.15459 182.62618,616.40459 C 170.75118,617.02959 157.44312,604.81988 143.69312,604.81988 C 130.56812,604.81988 125.75118,602.77483 127.62618,591.40459 C 129.50118,579.59241 142.93868,553.90459 165.75118,553.27959 C 188.56368,552.02959 209.18868,559.42542 217.62618,574.52959 C 225.43868,589.63376 221.68868,601.40459 217.00118,605.15459 C 212.31368,608.90459 201.58451,603.90459 193.25118,605.77959" + id="path1292" + sodipodi:nodetypes="czzzzzzzzz" + transform="matrix(0.578460,0.000000,0.000000,0.578460,89.85120,261.6781)" /> + </g> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;" + id="rect1268" + width="69.963570" + height="45.246185" + x="128.72227" + y="535.48883" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,254.4474,140.4299)" /> + <path + sodipodi:type="arc" + style="fill:#9999ff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:1.0000000pt;" + id="path1285" + sodipodi:cx="88.389725" + sodipodi:cy="698.28027" + sodipodi:rx="18.305565" + sodipodi:ry="18.305565" + d="M 106.69529 698.28027 A 18.305565 18.305565 0 1 0 70.084160,698.28027 A 18.305565 18.305565 0 1 0 106.69529 698.28027 z" + transform="translate(3.138097,1.046032)" /> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;" + id="rect1290" + width="69.963570" + height="45.246185" + x="-120.45193" + y="551.95033" + transform="scale(-1.000000,1.000000)" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#ff0000;stroke-opacity:1.0000000;stroke-width:2.5000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 51.673228,577.76346 L 120.04088,577.76346" + id="path1299" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#ff0000;stroke-opacity:1.0000000;stroke-width:2.5000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 88.241974,551.52936 L 87.447001,596.44531" + id="path1300" + sodipodi:nodetypes="cc" /> + <rect + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;" + id="rect1301" + width="69.963570" + height="45.246185" + x="-120.25873" + y="552.13202" + transform="scale(-1.000000,1.000000)" /> + <rect + style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:1.0000000pt;" + id="rect1302" + width="8.9940901" + height="9.2751551" + x="83.195328" + y="573.14581" /> + <path + style="font-size:12.000000;fill:url(#linearGradient968);fill-opacity:0.70196003;stroke:#1c66f9;stroke-width:1.9242834;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99000001;" + d="M 37.920277,322.15339 C 38.332250,320.95292 39.768025,319.75197 40.999014,319.93377 L 78.169327,327.96556 C 81.048244,325.43887 85.262603,322.36297 89.606623,323.13302 L 95.922292,324.00942 L 103.90333,325.57660 C 108.56248,326.97946 112.24447,329.89321 112.63056,335.69148 L 112.58162,405.54600 L 37.627148,381.65255 L 37.920277,322.15339 z " + id="path1266" + sodipodi:nodetypes="cccccccccc" /> + <path + style="font-size:12.000000;fill:#4789f7;stroke:#1c4ed9;stroke-width:1.7125434;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216002;" + d="M 37.528348,381.35197 L 112.74823,405.58198 L 109.98730,410.63535 L 35.227003,384.92024 L 37.528348,381.35197 z " + id="path1271" + sodipodi:nodetypes="ccccc" /> + <g + id="g1279" + transform="matrix(0.688750,0.000000,0.000000,0.640474,44.12231,204.0360)"> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.91963024pt;" + d="M 15.411826,279.67519 L 107.16635,280.32772 L 105.78092,271.91017 C 104.50888,267.92580 100.16017,263.55105 99.313146,259.07319 C 98.024176,254.59533 104.23642,257.47279 103.48688,250.11822 C 102.73733,242.76364 101.33093,223.23927 90.699786,212.93098 C 79.756146,202.93519 70.616996,196.51871 51.220346,199.66990 C 33.073696,201.57109 22.663616,210.23449 15.263856,225.51906 C 7.6727159,240.80363 16.076616,259.82218 15.837966,266.94924 L 15.411826,279.67519 z " + id="path1273" + sodipodi:nodetypes="ccczzzzzzc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 81.667436,238.66160 C 80.982416,243.33580 68.662856,240.88582 68.468226,248.58013 C 68.273596,255.77527 84.079546,257.18713 89.984786,255.06933 C 95.890036,252.95153 99.758996,249.65718 99.148096,242.36255 C 98.537216,235.06792 96.575586,216.71313 75.014876,206.18816 C 53.886116,196.16236 29.955336,209.82744 22.306536,224.42792 C 14.657726,239.52760 14.049476,254.81975 23.120686,249.32889 C 31.759936,244.33718 42.301146,228.60033 58.113846,226.78187 C 73.494556,224.96340 82.352426,234.98574 81.667436,238.66160 z " + id="path1274" + sodipodi:nodetypes="czzzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0877723pt;fill-opacity:1.0000000;" + d="M 46.065436,250.14579 C 44.767756,248.03998 45.172386,240.05319 38.251386,241.60591 C 31.330386,243.15862 23.814016,250.57710 21.730276,253.25121 C 19.646536,255.92534 20.762826,260.66971 21.730276,261.79111 C 22.697736,262.91251 28.204756,263.51633 29.767576,264.89651 C 31.330386,266.27670 34.976936,271.45240 36.911836,271.10736 C 38.846746,270.76231 42.790986,266.62175 42.939816,264.89653 C 43.088656,263.17129 47.363086,252.25163 46.065436,250.14579 z " + id="path1275" + sodipodi:nodetypes="czzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:none;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 42.237126,279.80001 C 42.658006,275.59866 47.388376,258.94410 48.153616,253.91080 C 48.918846,248.87751 46.010966,251.41496 47.235346,249.16869 C 48.459706,246.92241 52.591946,241.63956 55.499816,240.43322 C 58.407706,239.22690 62.539946,239.92518 64.682586,241.04832 C 66.825226,242.17146 68.164386,245.92409 68.355686,247.17200 C 68.546986,248.41993 66.863496,249.83425 65.830426,249.41828 C 64.797366,249.00230 66.447386,242.49537 63.942946,244.49969 C 61.438506,246.68048 58.281376,250.37501 56.647666,251.91412 C 55.338616,253.45321 58.560756,252.66288 59.172936,253.91080 C 59.785116,255.15873 60.932956,257.23860 60.320776,259.40167 C 59.708576,261.56473 57.068536,265.51649 55.499816,266.88920 C 53.931086,268.26192 52.553686,265.59969 50.908446,267.63797 C 49.263196,269.67624 47.037236,278.02692 45.659806,279.98199 L 42.237126,279.80001 z " + id="path1276" + sodipodi:nodetypes="czzzzzzzzzzzzcc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;fill-opacity:1.0000000;stroke-dasharray:none;" + d="M 41.081076,235.46675 C 41.510266,237.13987 42.851486,241.07668 43.817166,241.96244 C 44.782846,242.84822 46.848346,243.11067 47.197056,241.96244 C 47.545776,240.81421 45.212056,235.04026 51.059786,231.92364 C 57.068466,228.80702 66.457036,229.52876 69.407726,230.93945 C 72.358406,232.35012 77.320946,237.59917 72.626666,241.17509 C 68.737106,244.75098 78.179316,244.84941 80.191156,243.34031 C 82.202996,241.83121 85.125536,236.24432 82.523566,233.55418 C 79.921596,230.86405 73.325156,224.43697 67.209176,223.78085 C 61.093206,223.12471 46.472786,230.41454 44.460956,230.93945 C 42.288186,231.46435 40.651886,233.79361 41.081076,235.46675 z " + id="path1277" + sodipodi:nodetypes="czzzzzzzzzz" /> + </g> + <path + style="font-size:12.000000;fill:url(#linearGradient967);fill-opacity:0.69929999;stroke:#1c66fb;stroke-width:1.7758849;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216002;" + d="M 17.536640,337.89268 C 16.523741,335.20546 17.516336,332.64170 19.932441,332.91461 L 55.676174,340.52075 L 57.880936,348.26473 L 73.479955,351.89199 L 71.204233,343.73873 L 87.288253,346.49326 C 89.414399,347.18490 91.065826,348.61636 92.573252,351.89801 L 109.47210,409.98240 L 35.111516,384.77857 L 17.536640,337.89268 z " + id="path1272" + sodipodi:nodetypes="ccccccccccc" /> + <g + id="g1317"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.0770884;" + d="M 472.42571,238.27147 C 472.33405,238.27145 472.24478,238.29291 472.15311,238.29398 L 472.15311,238.31648 C 472.08489,238.31034 472.01758,238.29395 471.94867,238.29398 C 471.78809,238.29403 471.63216,238.33557 471.47163,238.33899 L 471.47163,238.42899 C 471.37376,238.41606 471.27556,238.40652 471.17632,238.40649 C 471.10740,238.40647 471.04010,238.42285 470.97187,238.42899 L 470.97187,238.40649 C 470.88021,238.40543 470.79094,238.38396 470.69928,238.38399 C 465.87162,238.38545 461.03877,239.90805 457.81913,242.92943 C 456.20932,244.44011 446.99543,256.89920 450.09559,259.04098 C 457.81097,264.68512 464.49982,248.07035 457.36480,261.85375 C 456.64585,266.58811 456.46107,269.05668 456.41072,270.29207 C 456.30905,268.02898 455.46815,262.72102 451.04967,260.14359 C 447.35854,258.03472 444.93899,276.66261 444.93899,279.18042 C 444.93899,289.25168 451.37986,299.31925 457.81913,303.34776 C 461.08484,305.39084 466.00722,306.37150 470.90372,306.34054 L 470.90372,306.36305 C 471.15408,306.36510 471.40305,306.34374 471.65336,306.34054 L 471.65336,306.22803 C 471.84267,306.23528 472.03155,306.25211 472.22127,306.25053 L 472.22127,306.22803 C 477.11777,306.25899 482.04015,305.27835 485.30586,303.23524 C 491.74513,299.20674 498.18600,289.13916 498.18600,279.06791 C 498.18600,276.55010 495.76645,257.92220 492.07532,260.03107 C 487.65684,262.60851 486.81594,267.91647 486.71427,270.17956 C 486.66392,268.94417 486.47914,266.47559 485.76018,261.74124 C 478.62517,247.95784 485.31402,264.57260 493.02940,258.92847 C 496.12956,256.78669 486.91567,244.32759 485.30586,242.81691 C 482.08622,239.79554 477.25337,238.27293 472.42571,238.27147 z " + id="path1267" + transform="matrix(1.033174,0.000000,0.000000,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.70418520pt;" + d="M 468.24591,259.15861 C 468.51094,258.62567 467.79271,252.85171 466.69475,251.35949 C 465.59679,249.86726 463.96768,250.52503 463.70265,251.05797 C 463.43764,251.59090 465.07594,250.88137 466.17389,252.37359 C 467.27185,253.86581 467.98090,259.69155 468.24591,259.15861 z " + id="path1270" + sodipodi:nodetypes="czzzz" + transform="matrix(1.033174,0.000000,0.000000,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt;" + d="M 463.34275,289.21648 C 461.03017,288.99344 460.56786,283.64967 458.96224,286.90958 C 457.28286,290.22776 460.74374,297.34319 461.04820,293.66548 C 461.27890,289.98777 465.58157,289.49777 463.34275,289.21648 z " + id="path1278" + sodipodi:nodetypes="czzz" + transform="matrix(1.033174,0.000000,0.000000,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.68256974pt;" + d="M 708.64967,503.43717 C 708.37585,502.95253 709.11791,497.70179 710.25229,496.34479 C 711.38666,494.98778 713.06983,495.58594 713.34365,496.07058 C 713.61745,496.55524 711.92480,495.90999 710.79043,497.26699 C 709.65604,498.62400 708.92347,503.92182 708.64967,503.43717 z " + id="path1283" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.57505898pt;" + d="M 710.57739,531.81732 C 712.96669,531.61449 713.44433,526.75496 715.10322,529.71946 C 716.83831,532.73696 713.26262,539.20762 712.94806,535.86317 C 712.70970,532.51872 708.26430,532.07312 710.57739,531.81732 z " + id="path1284" + sodipodi:nodetypes="czzz" /> + </g> + <g + id="g1329" + transform="translate(-104.0802,-97.80402)"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8718444;" + d="M 841.03523,592.70109 C 835.90467,592.76390 830.22818,593.56676 826.67923,597.28291 C 823.87668,600.24935 817.50896,615.99836 816.60602,618.30168 C 815.09992,624.27793 814.05854,630.78886 816.99244,636.56898 C 819.81959,643.25189 825.72828,649.72836 833.94116,650.75621 C 839.37129,651.44267 845.09032,651.35874 850.31458,649.72833 C 856.42815,647.71665 860.44343,642.53509 863.07436,637.37323 C 865.55779,632.40703 865.94287,626.74320 864.51563,621.47197 C 863.89507,618.11627 856.12574,599.89965 853.80199,597.15457 C 850.54532,594.03086 845.67202,592.69881 841.03523,592.70109 z " + id="path1288" + sodipodi:nodetypes="cccccccccc" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.63460236pt;" + d="M 838.07247,610.64237 C 839.95513,610.18459 838.75317,605.01626 837.71507,603.73449 C 836.67696,602.45272 829.77408,601.13926 832.78769,603.68422 C 836.03445,606.02046 835.95665,611.10014 838.07247,610.64237 z " + id="path1289" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.53464689pt;" + d="M 835.74471,629.37680 C 833.55820,629.18522 829.82379,631.67928 828.30569,634.47943 C 826.71786,637.32962 829.99008,643.44151 830.27794,640.28249 C 830.49606,637.12348 837.86149,629.61842 835.74471,629.37680 z " + id="path1290" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.63460231pt;" + d="M 842.27092,610.67154 C 840.38825,610.21376 841.59021,605.04542 842.62832,603.76366 C 843.66642,602.48189 850.56930,601.16843 847.55570,603.71338 C 844.30893,606.04963 844.38672,611.12931 842.27092,610.67154 z " + id="path1293" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.53464689pt;" + d="M 844.89363,628.76239 C 847.08014,628.57081 850.81456,631.06487 852.33265,633.86502 C 853.92048,636.71521 850.64827,642.82710 850.36040,639.66808 C 850.14228,636.50907 842.77686,629.00401 844.89363,628.76239 z " + id="path1310" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + </g> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient704);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87644994;stroke-dasharray:none" + id="path1268" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711,796.11926 A 37.428738,37.428738 0 1 1 233.92963,796.11926 A 37.428738,37.428738 0 1 1 308.78711,796.11926 z" + transform="matrix(1.269231,0,0,1.209574,540.73332,-885.28294)" /> + <path + style="font-size:12px;fill:url(#linearGradient1110);fill-opacity:0.38016998;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 885.13854,32.041206 C 865.91384,32.041206 849.45946,43.024196 841.98469,58.689616 C 847.90286,61.721566 854.50804,64.593766 862.29239,62.507336 C 876.90952,59.315026 881.47901,51.789536 888.78757,48.597246 C 904.10745,48.024696 911.44453,55.894836 926.5472,55.552296 C 918.44974,41.602246 903.04052,32.041216 885.13854,32.041206 z" + id="path1269" /> + <text + xml:space="preserve" + style="font-size:53.10573959px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:100%;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Arial Black" + x="727.4552" + y="110.45654" + id="text1284" + sodipodi:linespacing="100%" + transform="scale(1.1590137,0.8628026)"><tspan + x="727.4552" + y="110.45654" + sodipodi:role="line" + id="tspan1287">3D</tspan></text> + <path + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 862.36154,831.74143 L 862.36154,924.49 C 889.80881,924.49 912.07889,903.73438 912.07886,878.13172 C 912.07886,852.52905 889.80879,831.74141 862.36154,831.74143 z " + id="path3207" /> + <g + id="g4179"> + <path + transform="matrix(1.269231,0,0,1.209574,-252.0699,-51.3724)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path3205" + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:black;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + <path + sodipodi:nodetypes="csccccccc" + id="path2293" + d="M 121.04942,876.41746 C 115.9942,876.41746 85.290278,896.93033 69.807528,903.81184 C 65.343898,905.79576 131.15987,906.55128 131.15987,906.55128 L 82.62969,924.35764 L 92.74016,875.04774 L 51.091495,891.29811 L 65.441938,915.45446 L 113.97211,928.4668 L 82.951128,953.93266" + style="fill:none;fill-rule:evenodd;stroke:red;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path3209" + d="M 92.371567,865.47065 C 73.146867,865.47065 56.692487,876.45364 49.217717,892.11906 C 55.135887,895.15101 61.741067,898.02321 69.525417,895.93678 C 84.142547,892.74447 88.712037,885.21898 96.020597,882.02669 C 111.34048,881.45414 118.67756,889.32428 133.78023,888.98174 C 125.68277,875.03169 110.27355,865.47066 92.371567,865.47065 z " + style="font-size:12px;fill:url(#linearGradient3271);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,0,1.209574,-254.2131,-49.87948)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path3267" + style="font-size:12px;fill:url(#radialGradient3289);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + </g> + <g + id="g4185" + transform="matrix(0.587317,0,0,0.587317,135.8273,373.3777)"> + <path + transform="matrix(1.269231,0,0,1.209574,-252.0699,-51.3724)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4187" + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:black;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + <path + sodipodi:nodetypes="csccccccc" + id="path4189" + d="M 121.04942,876.41746 C 115.9942,876.41746 85.290278,896.93033 69.807528,903.81184 C 65.343898,905.79576 131.15987,906.55128 131.15987,906.55128 L 82.62969,924.35764 L 92.74016,875.04774 L 51.091495,891.29811 L 65.441938,915.45446 L 113.97211,928.4668 L 82.951128,953.93266" + style="fill:none;fill-rule:evenodd;stroke:red;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path4191" + d="M 92.371567,865.47065 C 73.146867,865.47065 56.692487,876.45364 49.217717,892.11906 C 55.135887,895.15101 61.741067,898.02321 69.525417,895.93678 C 84.142547,892.74447 88.712037,885.21898 96.020597,882.02669 C 111.34048,881.45414 118.67756,889.32428 133.78023,888.98174 C 125.68277,875.03169 110.27355,865.47066 92.371567,865.47065 z " + style="font-size:12px;fill:url(#linearGradient4195);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,0,1.209574,-254.2131,-49.87948)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4193" + style="font-size:12px;fill:url(#radialGradient4197);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + </g> + <g + id="g4199" + transform="matrix(0.75239,0,0,0.75239,212.8041,226.4211)"> + <path + transform="matrix(1.269231,0,0,1.209574,-252.0699,-51.3724)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4201" + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:black;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + <path + sodipodi:nodetypes="csccccccc" + id="path4203" + d="M 121.04942,876.41746 C 115.9942,876.41746 85.290278,896.93033 69.807528,903.81184 C 65.343898,905.79576 131.15987,906.55128 131.15987,906.55128 L 82.62969,924.35764 L 92.74016,875.04774 L 51.091495,891.29811 L 65.441938,915.45446 L 113.97211,928.4668 L 82.951128,953.93266" + style="fill:none;fill-rule:evenodd;stroke:red;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path4205" + d="M 92.371567,865.47065 C 73.146867,865.47065 56.692487,876.45364 49.217717,892.11906 C 55.135887,895.15101 61.741067,898.02321 69.525417,895.93678 C 84.142547,892.74447 88.712037,885.21898 96.020597,882.02669 C 111.34048,881.45414 118.67756,889.32428 133.78023,888.98174 C 125.68277,875.03169 110.27355,865.47066 92.371567,865.47065 z " + style="font-size:12px;fill:url(#linearGradient4209);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,0,1.209574,-254.2131,-49.87948)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4207" + style="font-size:12px;fill:url(#radialGradient4211);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + </g> + <g + id="g4213" + transform="matrix(0.355527,0,0,1.090014,324.7627,-82.64672)"> + <path + transform="matrix(1.269231,0,0,1.209574,-252.0699,-51.3724)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4215" + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:black;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + <path + sodipodi:nodetypes="csccccccc" + id="path4217" + d="M 121.04942,876.41746 C 115.9942,876.41746 85.290278,896.93033 69.807528,903.81184 C 65.343898,905.79576 131.15987,906.55128 131.15987,906.55128 L 82.62969,924.35764 L 92.74016,875.04774 L 51.091495,891.29811 L 65.441938,915.45446 L 113.97211,928.4668 L 82.951128,953.93266" + style="fill:none;fill-rule:evenodd;stroke:red;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path4219" + d="M 92.371567,865.47065 C 73.146867,865.47065 56.692487,876.45364 49.217717,892.11906 C 55.135887,895.15101 61.741067,898.02321 69.525417,895.93678 C 84.142547,892.74447 88.712037,885.21898 96.020597,882.02669 C 111.34048,881.45414 118.67756,889.32428 133.78023,888.98174 C 125.68277,875.03169 110.27355,865.47066 92.371567,865.47065 z " + style="font-size:12px;fill:url(#linearGradient4223);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,0,1.209574,-254.2131,-49.87948)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4221" + style="font-size:12px;fill:url(#radialGradient4225);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + </g> + <flowRoot + xml:space="preserve" + id="flowRoot4227" + style="font-size:36px;font-weight:bold;fill:navy" + transform="translate(33.72834,142.0141)"><flowRegion + id="flowRegion4229"><rect + id="rect4231" + width="361.5441" + height="35.503513" + x="42.604218" + y="822.77283" + style="font-size:36px;font-weight:bold;fill:navy" /></flowRegion><flowPara + id="flowPara4233">A B C D</flowPara></flowRoot> <rect + style="fill:url(#linearGradient3613);fill-opacity:0.75;fill-rule:evenodd;stroke:#ffffff;stroke-width:3.75;stroke-dasharray:none" + id="rect3611" + width="91.25" + height="30" + x="-216.6974" + y="113.70129" + ry="12.5" + transform="scale(-1,1)" /> + <path + sodipodi:type="arc" + style="opacity:1;fill:none;fill-opacity:1;fill-rule:evenodd;stroke:#ff0000;stroke-width:2.78699993999999980;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="path3615" + sodipodi:cx="133.34541" + sodipodi:cy="168.70491" + sodipodi:rx="6.5046539" + sodipodi:ry="10.732679" + d="M 139.85007,168.70491 A 6.5046539,10.732679 0 1 1 126.84076,168.70491 A 6.5046539,10.732679 0 1 1 139.85007,168.70491 z" + transform="matrix(1.0175006,0,0,0.8287883,-2.3336285,26.932865)" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 69.5998,-4.6441188 L 35.125132,-15.702031" + id="path3621" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 101.4726,-7.2459804 L 111.22959,-37.637817 L 121.63703,-8.5469113 L 101.4726,-7.2459804 z" + id="path3625" /> + <path + style="fill:#ff0000;fill-rule:evenodd;stroke:none;stroke-width:0.80189854px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 148.33682,165.27754 L 155.34262,135.45182 C 155.34262,135.45182 161.4727,167.76301 160.59697,169.00575 C 160.59697,169.00575 157.49655,165.13261 155.57225,164.45262 C 153.64794,163.7726 148.33682,165.27754 148.33682,165.27754 z" + id="path3627" + sodipodi:nodetypes="ccczc" /> + <path + style="fill:#ff0000;fill-rule:evenodd;stroke:none;stroke-width:0.80189854px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 207.91289,165.27754 L 214.91869,135.45182 C 214.91869,135.45182 221.04877,167.76301 220.17304,169.00575 C 220.17304,169.00575 217.07262,165.13261 215.14832,164.45262 C 213.22401,163.7726 207.91289,165.27754 207.91289,165.27754 z" + id="path3629" + sodipodi:nodetypes="ccczc" /> +</svg> diff --git a/btn/bucket24.png b/btn/bucket24.png new file mode 100755 index 0000000..95a24c7 Binary files /dev/null and b/btn/bucket24.png differ diff --git a/btn/colorbar.bmp b/btn/colorbar.bmp new file mode 100755 index 0000000..20a4aa6 Binary files /dev/null and b/btn/colorbar.bmp differ diff --git a/btn/colorzero.bmp b/btn/colorzero.bmp new file mode 100755 index 0000000..3e70946 Binary files /dev/null and b/btn/colorzero.bmp differ diff --git a/btn/drawing4z.svg b/btn/drawing4z.svg new file mode 100755 index 0000000..541046f --- /dev/null +++ b/btn/drawing4z.svg @@ -0,0 +1,2513 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:xlink="http://www.w3.org/1999/xlink" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + width="744.09448819" + height="1052.3622047" + id="svg2" + sodipodi:version="0.32" + inkscape:version="0.46" + sodipodi:docbase="C:\Documents and Settings\Chris Rorden\My Documents\mx1390old\btn" + sodipodi:docname="drawing4z.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape"> + <defs + id="defs4"> + <inkscape:perspective + sodipodi:type="inkscape:persp3d" + inkscape:vp_x="0 : 526.18109 : 1" + inkscape:vp_y="0 : 1000 : 0" + inkscape:vp_z="744.09448 : 526.18109 : 1" + inkscape:persp3d-origin="372.04724 : 350.78739 : 1" + id="perspective394" /> + <linearGradient + id="linearGradient17937"> + <stop + style="stop-color:#ffffff;stop-opacity:0.74226803;" + offset="0" + id="stop17939" /> + <stop + id="stop17945" + offset="1" + style="stop-color:#5fbcd3;stop-opacity:1;" /> + </linearGradient> + <radialGradient + r="24.522423" + fy="808.40576" + fx="280.46881" + cy="808.40576" + cx="280.46881" + gradientUnits="userSpaceOnUse" + id="radialGradient2803" + xlink:href="#linearGradient684" + inkscape:collect="always" /> + <radialGradient + fy="812.97649" + fx="289.25905" + r="16.96986" + cy="812.97649" + cx="289.25905" + id="radialGradient983" + xlink:href="#linearGradient1547" + gradientUnits="userSpaceOnUse" /> + <radialGradient + fy="807.81573" + fx="292.27442" + r="24.522423" + cy="807.81573" + cx="292.27442" + id="radialGradient1203" + xlink:href="#linearGradient684" + gradientUnits="userSpaceOnUse" /> + <linearGradient + y2="852.86278" + x2="335.31547" + y1="743.24066" + x1="326.75421" + id="linearGradient1202" + xlink:href="#linearGradient684" + gradientTransform="scale(1.7571663,0.5690981)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + y2="389.11669" + x2="206.25145" + y1="386.86683" + x1="210.53689" + id="linearGradient1175" + xlink:href="#linearGradient1172" + gradientTransform="scale(0.758349,1.3186542)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + y2="207.27092" + x2="383.23312" + y1="199.43834" + x1="359.54053" + id="linearGradient1139" + xlink:href="#linearGradient671" + gradientTransform="scale(0.4268666,2.3426521)" + gradientUnits="userSpaceOnUse" /> + <radialGradient + fy="807.81573" + fx="292.27442" + r="24.522423" + cy="807.81573" + cx="292.27442" + id="radialGradient704" + xlink:href="#linearGradient1271" + gradientUnits="userSpaceOnUse" /> + <linearGradient + y2="2051.6487" + x2="187.71159" + y1="2042.7123" + x1="187.74077" + id="linearGradient703" + xlink:href="#linearGradient671" + gradientTransform="scale(3.0094286,0.332289)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + y2="1239.0289" + x2="101.51829" + y1="1187.1978" + x1="90.8512" + id="linearGradient683" + xlink:href="#linearGradient684" + gradientTransform="scale(1.6468933,0.6072039)" + gradientUnits="userSpaceOnUse" /> + <radialGradient + fy="807.81573" + fx="292.27442" + r="24.522423" + cy="807.81573" + cx="292.27442" + id="radialGradient1169" + xlink:href="#linearGradient684" + gradientUnits="userSpaceOnUse" /> + <radialGradient + fy="162.34375" + fx="62.1875" + r="7.0745194" + cy="162.34375" + cx="62.1875" + id="radialGradient1158" + xlink:href="#linearGradient1155" + gradientUnits="userSpaceOnUse" /> + <linearGradient + id="linearGradient1155"> + <stop + id="stop1156" + offset="0.00000000" + style="stop-color:#fffbfb;stop-opacity:1.0000000;" /> + <stop + id="stop1157" + offset="1.0000000" + style="stop-color:#9999ff;stop-opacity:1.0000000;" /> + </linearGradient> + <linearGradient + id="linearGradient594"> + <stop + id="stop595" + offset="0.00000000" + style="stop-color:#fffbfb;stop-opacity:1.0000000;" /> + <stop + id="stop596" + offset="1.0000000" + style="stop-color:#007aff;stop-opacity:1.0000000;" /> + </linearGradient> + <linearGradient + id="linearGradient671"> + <stop + id="stop672" + offset="0.00000000" + style="stop-color:#ffffff;stop-opacity:1.0000000;" /> + <stop + id="stop673" + offset="1.0000000" + style="stop-color:#ffffff;stop-opacity:0.00000000;" /> + </linearGradient> + <linearGradient + id="linearGradient684"> + <stop + id="stop685" + offset="0.00000000" + style="stop-color:#ffffff;stop-opacity:1.0000000;" /> + <stop + id="stop686" + offset="1.0000000" + style="stop-color:#9999ff;stop-opacity:1.0000000;" /> + </linearGradient> + <linearGradient + id="linearGradient969"> + <stop + id="stop970" + offset="0.00000000" + style="stop-color:#ffffff;stop-opacity:0.70196080;" /> + <stop + id="stop971" + offset="1.0000000" + style="stop-color:#9999ff;stop-opacity:0.70196080;" /> + </linearGradient> + <linearGradient + id="linearGradient1172"> + <stop + id="stop1173" + offset="0.00000000" + style="stop-color:#ffffff;stop-opacity:0.3;" /> + <stop + id="stop1174" + offset="1.00000000" + style="stop-color:#ffffff;stop-opacity:0.8;" /> + </linearGradient> + <linearGradient + id="linearGradient1274"> + <stop + id="stop1275" + offset="0.00000000" + style="stop-color:#ff0400;stop-opacity:1.0000000;" /> + <stop + id="stop1277" + offset="0.0099999998" + style="stop-color:#fd6972;stop-opacity:1.0000000;" /> + <stop + id="stop1276" + offset="1.0000000" + style="stop-color:#ff0000;stop-opacity:1.0000000;" /> + </linearGradient> + <linearGradient + id="linearGradient1111"> + <stop + id="stop1112" + offset="0.00000000" + style="stop-color:#e8e838;stop-opacity:1.0000000;" /> + <stop + id="stop1114" + offset="1.0000000" + style="stop-color:#ffff7f;stop-opacity:1.0000000;" /> + </linearGradient> + <linearGradient + id="linearGradient1547"> + <stop + id="stop1548" + offset="0.00000000" + style="stop-color:#9999ff;stop-opacity:1.0000000;" /> + <stop + id="stop1549" + offset="1.0000000" + style="stop-color:#9999fd;stop-opacity:0.00000000;" /> + </linearGradient> + <linearGradient + id="linearGradient1563"> + <stop + id="stop1564" + offset="0.00000000" + style="stop-color:#898bdc;stop-opacity:1.0000000;" /> + <stop + id="stop1565" + offset="1.0000000" + style="stop-color:#000000;stop-opacity:1.0000000;" /> + </linearGradient> + <linearGradient + id="linearGradient1608"> + <stop + id="stop1609" + offset="0.00000000" + style="stop-color:#ffffff;stop-opacity:1.0000000;" /> + <stop + id="stop1611" + offset="0.50000000" + style="stop-color:#9999ff;stop-opacity:1.0000000;" /> + <stop + id="stop1610" + offset="1.0000000" + style="stop-color:#000000;stop-opacity:1.0000000;" /> + </linearGradient> + <linearGradient + id="linearGradient1271"> + <stop + id="stop1274" + offset="0.00000000" + style="stop-color:#ffc87e;stop-opacity:1.0000000;" /> + <stop + id="stop1279" + offset="1.0000000" + style="stop-color:#ff0000;stop-opacity:1.0000000;" /> + </linearGradient> + <linearGradient + id="linearGradient1280"> + <stop + id="stop1281" + offset="0.00000000" + style="stop-color:#ffc000;stop-opacity:1.0000000;" /> + <stop + id="stop1283" + offset="1.0000000" + style="stop-color:#ff0000;stop-opacity:0.50000000;" /> + </linearGradient> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3036" + x1="187.74077" + y1="2042.7123" + x2="187.71159" + y2="2051.6487" + gradientTransform="scale(3.0094286,0.332289)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3038" + x1="187.74077" + y1="2042.7123" + x2="187.71159" + y2="2051.6487" + gradientTransform="scale(3.0094286,0.332289)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3040" + x1="187.74077" + y1="2042.7123" + x2="187.71159" + y2="2051.6487" + gradientTransform="scale(3.0094286,0.332289)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3042" + x1="187.74077" + y1="2042.7123" + x2="187.71159" + y2="2051.6487" + gradientTransform="scale(3.0094286,0.332289)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3044" + x1="187.74077" + y1="2042.7123" + x2="187.71159" + y2="2051.6487" + gradientTransform="scale(3.0094286,0.332289)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3046" + x1="187.74077" + y1="2042.7123" + x2="187.71159" + y2="2051.6487" + gradientTransform="scale(3.0094286,0.332289)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3048" + x1="187.74077" + y1="2042.7123" + x2="187.71159" + y2="2051.6487" + gradientTransform="scale(3.0094286,0.332289)" + gradientUnits="userSpaceOnUse" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient3062" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" + gradientUnits="userSpaceOnUse" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient3064" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1280" + id="linearGradient3087" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.6468933,0,0,0.6072039,-707.89942,-735.8277)" + x1="459.4994" + y1="1254.0935" + x2="481.37598" + y2="1325.9788" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient969" + id="linearGradient3103" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.0923649,0,0,0.915445,-15.816734,-109.09188)" + x1="48.734489" + y1="368.05664" + x2="55.008646" + y2="445.4552" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient684" + id="linearGradient3113" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.9373488,0,0,1.0668387,-15.816734,-109.09188)" + x1="46.314715" + y1="300.89402" + x2="84.46981" + y2="407.3278" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient3132" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.6468933,0,0,0.6072039,-15.816734,-109.09188)" + x1="169.59108" + y1="1212.3388" + x2="175.37662" + y2="1267.5976" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1111" + id="linearGradient3202" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(2.5036225,0,0,0.5791021,-389.92538,-113.29149)" + x1="85.863811" + y1="835.45038" + x2="85.679877" + y2="809.33162" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1274" + id="linearGradient3226" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.8935111,0,0,1.1191803,27.935496,-68.87518)" + x1="498.83997" + y1="87.851495" + x2="527.61901" + y2="134.61744" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1608" + id="linearGradient3266" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.677741,0,0,0.5960396,15.816734,-109.09188)" + x1="-196.8662" + y1="425.48517" + x2="-141.23934" + y2="425.48517" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient969" + id="radialGradient3315" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.075993,0,0,0.9293741,-15.816734,-109.09188)" + cx="524.70152" + cy="475.22645" + fx="524.70152" + fy="475.22645" + r="111.10576" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1172" + id="linearGradient3321" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.758349,0,0,1.3186542,-15.816734,-109.09188)" + x1="477.45044" + y1="381.63529" + x2="473.165" + y2="383.88514" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3325" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.4268666,0,0,2.3426521,-15.816734,-109.09188)" + x1="833.72519" + y1="196.49355" + x2="857.41778" + y2="204.32614" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1172" + id="linearGradient3330" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.758349,0,0,1.3186542,-15.816734,-109.09188)" + x1="339.63678" + y1="379.11596" + x2="335.35134" + y2="381.36582" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3334" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.4268666,0,0,2.3426521,-15.816734,-109.09188)" + x1="588.89265" + y1="195.07545" + x2="612.58524" + y2="202.90803" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3344" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.2017735,0,0,0.8321036,-15.816734,-109.09188)" + x1="503.37662" + y1="709.5851" + x2="511.95083" + y2="774.66748" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient969" + id="radialGradient3347" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.0227134,0,0,0.977791,-15.816734,-109.09188)" + cx="553.9061" + cy="548.65722" + fx="553.9061" + fy="548.65722" + r="117.12444" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient969" + id="linearGradient3350" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.1837429,0,5.9686051e-2,0.2004968,423.15227,384.61312)" + x1="104.707" + y1="264.74155" + x2="133.43179" + y2="619.09318" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient3383" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.6468933,0,0,0.6072039,-15.816734,-109.09188)" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient684" + id="linearGradient3389" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.6468933,0,0,0.6072039,-15.816734,-109.09188)" + x1="231.07885" + y1="1040.2823" + x2="241.74594" + y2="1092.1133" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient684" + id="linearGradient3398" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.0665122,0,0,0.9376353,-18.544492,-118.77326)" + x1="614.02868" + y1="1168.7988" + x2="672.80902" + y2="1295.4267" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1155" + id="linearGradient3408" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.9878798,0,0,1.0122689,-15.816734,-109.09188)" + x1="374.14027" + y1="749.49296" + x2="396.35611" + y2="807.75935" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1155" + id="linearGradient3414" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(4.2446192,0,0,4.0663556,128.08437,-388.78408)" + x1="39.904693" + y1="205.22107" + x2="28.554472" + y2="212.26643" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1563" + id="linearGradient3417" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.9763285,0,0,1.0242454,-15.816734,-109.09188)" + x1="265.95663" + y1="735.08612" + x2="313.4116" + y2="761.44375" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient594" + id="linearGradient3429" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.7771299,0,0,1.2867861,-15.816734,-109.09188)" + x1="331.69558" + y1="519.82318" + x2="377.3627" + y2="537.58599" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient684" + id="linearGradient3434" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.1943011,0,0,0.2226133,460.10717,364.77942)" + x1="-16.929597" + y1="255.77006" + x2="166.53211" + y2="767.53721" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient4441" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0,0.4268666,-2.3426521,0,866.43476,213.19778)" + x1="636.48645" + y1="194.28539" + x2="682.59552" + y2="198.65256" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1563" + id="linearGradient6399" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.9763285,0,0,1.0110532,-335.13691,-86.646504)" + x1="265.95663" + y1="735.08612" + x2="313.4116" + y2="761.44375" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient6401" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.6468933,0,0,0.6072039,-334.85916,-96.63329)" + x1="169.59108" + y1="1212.3388" + x2="175.37662" + y2="1267.5976" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient6403" + gradientUnits="userSpaceOnUse" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" /> + <filter + inkscape:collect="always" + x="-0.13659227" + width="1.2731845" + y="-0.19308964" + height="1.3861793" + id="filter3825"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="2.9455487" + id="feGaussianBlur3827" /> + </filter> + <filter + inkscape:collect="always" + id="filter3995"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="0.81463544" + id="feGaussianBlur3997" /> + </filter> + <filter + inkscape:collect="always" + id="filter4043"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="1.3482482" + id="feGaussianBlur4045" /> + </filter> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient4653" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.4268666,0,0,2.3426521,-523.80121,11.023625)" + x1="833.72519" + y1="196.49355" + x2="857.41778" + y2="204.32614" /> + <filter + inkscape:collect="always" + id="filter3943"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="0.75213628" + id="feGaussianBlur3945" /> + </filter> + <filter + inkscape:collect="always" + id="filter3996"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="0.65992794" + id="feGaussianBlur3998" /> + </filter> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient17937" + id="linearGradient2702" + gradientUnits="userSpaceOnUse" + x1="7.0675211" + y1="508.37253" + x2="10.845769" + y2="525.86481" /> + </defs> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#666666" + borderopacity="1.0" + gridtolerance="10000" + guidetolerance="10" + objecttolerance="10" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="0.67332995" + inkscape:cx="393.47267" + inkscape:cy="497.65096" + inkscape:document-units="px" + inkscape:current-layer="layer1" + inkscape:window-width="1280" + inkscape:window-height="778" + inkscape:window-x="0" + inkscape:window-y="0" + showgrid="false" /> + <metadata + id="metadata7"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + </cc:Work> + </rdf:RDF> + </metadata> + <g + inkscape:label="Layer 1" + inkscape:groupmode="layer" + id="layer1"> + <rect + style="opacity:1;fill:none;fill-opacity:0;fill-rule:evenodd;stroke:#0000c0;stroke-width:2.65549850000000020;stroke-linecap:square;stroke-linejoin:bevel;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:0;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="rect2766" + width="94.651901" + height="94.651901" + x="782.50494" + y="193.76978" + ry="11.064577" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.375" + id="rect1295" + width="69.96357" + height="45.246185" + x="-85.942757" + y="400.73502" + transform="scale(-1,1)" /> + <rect + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2.375" + id="rect1262" + width="69.96357" + height="45.246185" + x="21.639284" + y="525.50854" /> + <path + sodipodi:type="arc" + style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="path1286" + sodipodi:cx="88.389725" + sodipodi:cy="698.28027" + sodipodi:rx="18.305565" + sodipodi:ry="18.305565" + d="M 106.69529 698.28027 A 18.305565 18.305565 0 1 1 70.08416,698.28027 A 18.305565 18.305565 0 1 1 106.69529 698.28027 z" + transform="translate(-33.076264,-148.31812)" /> + <path + sodipodi:type="arc" + style="fill-rule:evenodd;stroke-width:1pt" + id="path1573" + sodipodi:cx="496.47308" + sodipodi:cy="894.01904" + sodipodi:rx="26.54307" + sodipodi:ry="26.54307" + d="M 523.01615 894.01904 A 26.54307 26.54307 0 1 1 469.93001,894.01904 A 26.54307 26.54307 0 1 1 523.01615 894.01904 z" + transform="translate(169.72327,-322.09028)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.03751945" + d="M 688.66818,306.24904 C 678.75656,308.71686 672.13642,319.35864 669.10861,325.77005 C 666.0808,331.91994 662.11261,338.19726 672.83358,343.64006 C 683.06094,344.90951 689.88793,344.55574 695.32226,341.02776 C 702.63141,336.49383 708.44273,330.79097 710.67282,325.51602 C 712.12925,322.67835 725.26533,323.27838 724.39866,321.28638 C 724.51641,317.76588 723.82071,310.17565 715.84197,305.89899 C 711.53579,303.19828 694.46237,303.06487 688.66818,306.24904 z " + id="path1377" + sodipodi:nodetypes="czcccccc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 159.34746,204.18441 C 154.78112,203.72655 145.72305,209.5377 141.75371,211.93441 C 130.90513,218.48492 120.06623,234.83944 120.06621,251.21566 C 120.06621,255.30973 116.62248,258.91345 121.53496,271.71566 C 127.57858,282.72641 154.25286,286.16074 154.47246,279.37191 C 154.69205,272.58309 150.38113,275.95666 155.69121,270.77816 C 155.85327,280.80632 159.30712,280.98431 159.15996,286.90316 C 159.06579,290.42991 158.87433,298.31471 160.22246,296.96566 L 162.15996,297.27816 L 162.15996,297.40316 L 162.53496,297.34066 L 164.47246,297.02816 C 165.82059,298.37721 165.62913,290.4924 165.53496,286.96566 C 165.3878,281.04681 168.84165,280.86881 169.00371,270.84066 C 174.31379,276.01916 170.00287,272.64558 170.22246,279.43441 C 170.44206,286.22324 197.11634,282.7889 203.15996,271.77816 C 208.07244,258.97595 204.62871,255.37222 204.62871,251.27816 C 204.62869,234.90194 193.78979,218.54741 182.94121,211.99691 C 178.97187,209.6002 169.9138,203.78904 165.34746,204.24691 C 163.82535,204.39953 162.7994,205.24568 162.62871,207.15316 L 161.82444,259.53543 L 162.06621,207.09066 C 161.89552,205.18319 160.86957,204.33703 159.34746,204.18441 z " + id="path1150" + sodipodi:nodetypes="ccccccccccccccccccccccc" /> + <path + style="fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:0.684129pt" + d="M 166.96836,384.07012 C 155.31965,387.85507 120.86399,377.80538 120.12828,394.64187 C 119.39258,411.47837 208.78111,407.43239 196.64192,397.12167 C 184.50274,386.81094 178.61708,380.28517 166.96836,384.07012 z " + id="path1140" + sodipodi:nodetypes="cczz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:1.27241249pt" + d="M 480.79352,206.34075 C 471.88604,206.34335 456.60096,213.45984 450.66045,218.80635 C 438.7794,229.49933 432.12374,257.332 432.12374,275.15365 C 432.12374,280.58581 432.13964,285.91498 432.36887,291.04434 L 527.02964,291.04434 C 527.27078,285.95977 527.31563,280.70645 527.31563,275.31137 C 527.31559,257.48975 523.65984,230.6354 511.75241,219.92163 C 505.7987,214.56474 489.701,206.33815 480.79352,206.34075 z " + id="path1063" + sodipodi:nodetypes="cccccccc" /> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.91963024pt" + d="M 327.16217,290.76838 L 418.91669,291.42091 L 417.53126,283.00336 C 416.25922,279.01899 411.91051,274.64424 411.06349,270.16638 C 409.77452,265.68852 415.98676,268.56598 415.23722,261.21141 C 414.48767,253.85683 413.08127,234.33246 402.45013,224.02417 C 391.50649,214.02838 382.36734,207.6119 362.97069,210.76309 C 344.82404,212.66428 334.41396,221.32768 327.0142,236.61225 C 319.42306,251.89682 327.82696,270.91537 327.58831,278.04243 L 327.16217,290.76838 z " + id="path1052" + sodipodi:nodetypes="ccczzzzzzc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.99068832pt" + d="M 304.47806,263.45874 C 304.47806,249.33467 295.28924,221.00412 286.18122,212.5132 C 277.07319,204.02228 258.91772,204.03875 249.8299,212.5132 C 240.74206,220.98765 231.65423,249.2358 231.65423,263.35988 C 231.65423,277.48396 240.74206,291.60803 249.8299,297.25767 C 258.91772,302.9073 277.07319,302.89082 286.18122,297.25767 C 295.28924,291.62451 304.47806,277.58282 304.47806,263.45874 z " + id="path1005" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt" + d="M 269.52246,210.66588 C 269.40433,210.66585 269.2893,210.6935 269.17117,210.69488 L 269.17117,210.72388 C 269.08325,210.71596 268.99651,210.69484 268.90771,210.69488 C 268.70077,210.69495 268.49983,210.74848 268.29296,210.75288 L 268.29296,210.86887 C 268.16684,210.8522 268.04029,210.83991 267.9124,210.83987 C 267.82359,210.83984 267.73686,210.86095 267.64893,210.86887 L 267.64893,210.83987 C 267.53081,210.8385 267.41578,210.81084 267.29765,210.81087 C 261.07638,210.81276 254.84843,212.77489 250.69937,216.66845 C 248.62485,218.61522 236.75118,234.6709 240.74626,237.43095 C 250.68886,244.7044 259.30859,223.29341 250.11389,241.05569 C 249.1874,247.15673 248.94927,250.3379 248.88439,251.92991 C 248.75337,249.01354 247.66973,242.17332 241.97576,238.85185 C 237.2191,236.13422 234.1011,260.13945 234.1011,263.38408 C 234.1011,276.36263 242.40127,289.33642 250.69937,294.52784 C 254.9078,297.16071 261.25113,298.42446 267.56111,298.38456 L 267.56111,298.41356 C 267.88374,298.41621 268.20458,298.38868 268.52715,298.38456 L 268.52715,298.23957 C 268.77111,298.24891 269.01451,298.2706 269.259,298.26857 L 269.259,298.23957 C 275.56898,298.27947 281.91231,297.01574 286.12074,294.38285 C 294.41884,289.19143 302.71901,276.21763 302.71901,263.23909 C 302.71901,259.99446 299.601,235.98922 294.84435,238.70686 C 289.15038,242.02833 288.06674,248.86855 287.93572,251.78492 C 287.87084,250.19291 287.63271,247.01173 286.70621,240.9107 C 277.51152,223.14842 286.13125,244.5594 296.07385,237.28596 C 300.06893,234.52591 288.19526,218.47022 286.12074,216.52346 C 281.97168,212.6299 275.74373,210.66776 269.52246,210.66588 z " + id="path1044" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:#fffffd;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.875;stroke-dasharray:none" + id="path695" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(1.269231,0,0,1.209574,136.50927,-392.71098)" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#linearGradient1202);fill-opacity:0.75;fill-rule:evenodd;stroke:#0050fb;stroke-width:2.47292995;stroke-dasharray:none;stroke-opacity:1" + id="path1200" + sodipodi:cx="604.88873" + sodipodi:cy="441.2019" + sodipodi:rx="44.214264" + sodipodi:ry="13.483783" + d="M 649.103 441.2019 A 44.214264 13.483783 0 1 1 560.67447,441.2019 A 44.214264 13.483783 0 1 1 649.103 441.2019 z" + transform="matrix(1.042553,0,0,0.882208,-45.319444,-61.74254)" /> + <path + style="font-size:12px;fill:url(#linearGradient3434);fill-opacity:0.70196001;stroke:#1c66f9;stroke-width:1.92428339;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.98999999" + d="M 451.22048,423.00433 C 451.63246,421.80386 453.06823,420.60292 454.29922,420.78471 L 491.46953,428.8165 C 494.34845,426.28982 498.56281,423.21391 502.90683,423.98397 L 509.2225,424.86037 L 517.20354,426.42754 C 521.86269,427.8304 525.54468,430.74415 525.93077,436.54243 L 525.88183,506.39694 L 450.92735,482.50349 L 451.22048,423.00433 z " + id="path10" + sodipodi:nodetypes="cccccccccc" /> + <rect + style="font-size:12px;fill:none;fill-opacity:0.25;fill-rule:evenodd;stroke-width:0.0937284;stroke-opacity:0.53136998" + id="rect1408" + x="199.81725" + y="208.79193" + width="236.74754" + height="236.68817" + rx="0" + ry="0" /> + <rect + style="font-size:12px;fill:none;fill-rule:evenodd;stroke-width:0.0520834" + id="rect702" + width="370.49606" + height="374.81461" + x="331.57504" + y="372.21768" /> + <path + style="font-size:12px;fill:url(#linearGradient3429);fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:0.47846999pt" + d="M 243.46953,613.59491 C 244.15833,611.87293 271.36555,520.95257 271.36555,520.95257 L 302.36113,608.77337 C 302.36113,608.77337 289.27411,618.07205 274.12072,618.07205 C 258.96732,620.13842 243.12514,613.59491 243.46953,613.59491 z " + id="path593" + sodipodi:nodetypes="ccccc" /> + <polygon + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z " + inkscape:randomized="0" + inkscape:rounded="0" + inkscape:flatsided="false" + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon597" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,154.95997,280.89042)" /> + <polygon + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z " + inkscape:randomized="0" + inkscape:rounded="0" + inkscape:flatsided="false" + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon598" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,146.00567,313.95242)" /> + <polygon + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z " + inkscape:randomized="0" + inkscape:rounded="0" + inkscape:flatsided="false" + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon599" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,162.53667,301.55422)" /> + <polygon + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z " + inkscape:randomized="0" + inkscape:rounded="0" + inkscape:flatsided="false" + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon600" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,160.81467,317.74072)" /> + <polygon + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z " + inkscape:randomized="0" + inkscape:rounded="0" + inkscape:flatsided="false" + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon601" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,146.69447,332.20542)" /> + <polygon + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z " + inkscape:randomized="0" + inkscape:rounded="0" + inkscape:flatsided="false" + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon602" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,170.11337,329.45022)" /> + <path + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 258.30044,566.33574 C 256.77333,571.42599 256.69309,571.65611 255.16047,576.75743 L 256.29684,580.6151 L 258.67424,576.71257 L 263.1001,577.78913 L 260.90212,573.78194 L 264.05704,570.4775 L 259.49661,570.38778 L 258.30044,566.33574 z " + id="path605" /> + <path + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 276.34738,535.18557 L 275.12129,537.18917 L 270.68049,536.11261 L 272.87846,540.1198 L 269.7385,543.42424 L 274.29892,543.51396 L 275.58481,547.89495 L 277.96221,543.99243 L 279.59201,544.39614 L 276.34738,535.18557 z " + id="path608" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.875;stroke-dasharray:none" + id="path651" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(1.269231,0,0,1.209574,-77.374024,-285.94088)" /> + <path + style="font-size:12px;fill:url(#linearGradient3417);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-opacity:1" + d="M 279.87479,633.93985 L 279.87479,666.67394 L 255.83873,666.67394 L 255.83873,656.16576 C 255.83873,656.16576 255.85783,656.13497 231.44571,676.76631 L 255.32311,696.19509 L 255.32311,686.4807 L 279.87479,686.4807 L 279.87479,720.19756 C 299.3849,714.56487 313.66805,697.45517 313.66806,677.03091 C 313.66807,656.6106 299.37907,639.57596 279.87479,633.93985 z " + id="path669" /> + <path + style="font-size:12px;fill:url(#linearGradient3414);fill-rule:evenodd;stroke:#000000;stroke-width:2.78715038;stroke-linejoin:round" + d="M 283.95579,490.94075 C 290.66581,489.39661 295.57028,485.44504 300.07353,481.09224 C 304.17555,476.47196 308.27756,470.24678 309.77159,464.0216 L 276.03686,421.84097 L 237.48736,460.81175 L 283.95579,490.94075 z " + id="path709" + sodipodi:nodetypes="cccccc" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:#f5f9ff;fill-rule:evenodd;stroke:#000000;stroke-width:10.78610039" + id="path587" + sodipodi:cx="220.25374" + sodipodi:cy="529.07959" + sodipodi:rx="44.626575" + sodipodi:ry="78.456398" + d="M 264.88031 529.07959 A 44.626575 78.456398 0 1 1 175.62716,529.07959 A 44.626575 78.456398 0 1 1 264.88031 529.07959 z" + transform="matrix(0.26113,0,-0.220403,0.255703,314.80207,305.48132)" /> + <path + style="font-size:12px;fill:#ff0000;fill-rule:evenodd;stroke-width:1pt" + d="M 243.66732,455.91895 C 207.99046,453.53473 230.86297,486.36929 231.18432,489.05618 C 231.50609,491.74307 212.45436,496.31199 220.47004,505.98065 C 233.70212,515.64935 294.73252,518.87157 293.74202,503.71551 C 292.75152,488.55528 244.41991,492.90854 233.95854,488.90274 C 230.5101,479.45166 230.06347,464.3735 235.28957,459.88088 C 238.35009,457.8818 237.91425,463.35185 243.66732,455.91895 z " + id="path711" + sodipodi:nodetypes="cccccsc" /> + <path + style="font-size:12px;fill:#ff0000;fill-rule:evenodd;stroke-width:10.78610039" + d="M 271.24683,425.72263 C 265.99009,425.72263 255.39114,433.36371 247.59081,442.77656 C 241.16254,450.53372 238.64291,457.0772 240.89292,459.14242 C 247.83823,456.92466 258.29806,449.12547 266.36059,439.77166 C 270.03525,435.50847 272.64634,431.56918 274.1298,428.31817 C 274.02196,426.68582 273.09418,425.72263 271.24683,425.72263 z " + id="path592" /> + <rect + style="font-size:12px;fill:url(#linearGradient3408);fill-opacity:1;fill-rule:evenodd;stroke:#000002;stroke-width:1.94391274" + id="rect642" + width="71.98143" + height="73.806519" + x="339.74475" + y="642.47302" /> + <path + style="font-size:12px;fill-rule:evenodd;stroke:#000002;stroke-width:1.94391274" + d="M 340.05239,659.32645 L 340.05239,715.98893 L 410.49575,715.98893 L 405.88157,712.7926 C 397.37094,706.98105 399.88311,699.28077 390.1933,700.00721 C 380.81111,700.1525 356.62253,712.80034 352.52102,705.43907 C 347.64017,698.79476 349.20267,643.90267 345.30441,650.4736 L 340.05239,659.32645 z " + id="path640" + sodipodi:nodetypes="cccczcsc" /> + <rect + style="font-size:12px;fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:4.10281944" + id="rect615" + width="57.240681" + height="49.173893" + x="496.88156" + y="922.24396" + transform="matrix(0.8593708,-0.5113529,0,1,0,0)" /> + <text + xml:space="preserve" + style="font-size:34.43291092px;font-weight:bold;line-height:100%;fill:#000000;fill-opacity:1;stroke-width:1pt;font-family:Verdana" + x="487.49341" + y="857.62598" + id="text610" + sodipodi:linespacing="100%" + transform="matrix(0.8820213,-0.5398853,0,1.1337595,0,0)"><tspan + x="487.49341" + y="857.62598" + sodipodi:role="line" + id="tspan613" + style="fill:#000000;fill-opacity:1">LR</tspan></text> + <rect + style="font-size:12px;fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:4.12392521" + id="rect627" + width="57.83112" + height="49.173893" + x="-614.36664" + y="357.21173" + transform="matrix(-0.8624565,-0.5061313,0,1,0,0)" /> + <text + xml:space="preserve" + style="font-size:34.43291092px;font-weight:bold;line-height:100%;stroke-width:1pt;font-family:Verdana" + x="-598.04327" + y="340.37064" + id="text628" + sodipodi:linespacing="100%" + transform="matrix(-0.8820213,-0.5398853,0,1.1337595,0,0)"><tspan + x="-598.04327" + y="340.37064" + sodipodi:role="line" + id="tspan629">LR</tspan></text> + <rect + style="font-size:12px;fill:url(#linearGradient3398);fill-rule:evenodd;stroke:#000000;stroke-width:0.77675009pt" + id="rect648" + width="56.066242" + height="49.173893" + x="630.58124" + y="997.7973" + transform="matrix(0.8529074,-0.5220622,0,1,0,0)" /> + <rect + style="font-size:12px;fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:0.77675009pt" + id="rect649" + width="56.066242" + height="49.173893" + x="-742.98041" + y="280.71118" + transform="matrix(-0.8529074,-0.5220622,0,1,0,0)" /> + <path + style="font-size:12px;fill:none;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2.40036964;stroke-opacity:1" + d="M 570.21281,672.11203 C 560.80527,687.5177 551.81276,684.49603 553.40375,698.74281 C 555.96315,704.40234 562.05038,691.50316 576.02334,688.32276 C 581.55718,684.47094 584.49704,676.2781 577.47598,661.60195 C 569.00228,647.92063 548.83833,666.49034 544.68794,681.59092 C 540.53755,696.36586 547.93908,698.22084 553.19623,696.88453" + id="path646" + sodipodi:nodetypes="ccczzc" /> + <path + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:2.40036964" + d="M 602.22003,673.33419 C 611.62757,688.73986 620.62007,685.71819 619.02909,699.96497 C 616.46969,705.6245 610.38245,692.72532 596.4095,689.54492 C 590.87565,685.6931 587.93579,677.50026 594.95686,662.82411 C 603.43056,649.14279 623.59451,667.71251 627.7449,682.81308 C 631.89528,697.58802 624.49376,699.443 619.23661,698.10669" + id="path650" + sodipodi:nodetypes="ccczzc" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient1158);fill-rule:evenodd;stroke:#000000;stroke-width:1pt" + id="path1411" + d="M 69.375 165 A 4.375 4.375 0 1 1 60.625,165 A 4.375 4.375 0 1 1 69.375 165 z" + sodipodi:cx="65" + sodipodi:cy="165" + sodipodi:rx="4.375" + sodipodi:ry="4.375" + transform="matrix(6.282797,0,0,6.282797,-52.398774,-588.87818)" /> + <path + style="font-size:12px;fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:15.70698166;stroke-linecap:round;stroke-linejoin:round" + d="M 379.53347,471.34372 L 410.94745,502.75771" + id="path1413" + sodipodi:nodetypes="cc" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient1203);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87644994;stroke-dasharray:none" + id="path682" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(1.269231,0,0,1.209574,30.443296,-392.69368)" /> + <path + style="font-size:12px;fill:url(#linearGradient3389);fill-opacity:0.38016998;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 374.84848,524.63047 C 355.62378,524.63047 339.1694,535.61346 331.69463,551.27888 C 337.6128,554.31083 344.21798,557.18303 352.00233,555.0966 C 366.61946,551.90429 371.18895,544.3788 378.49751,541.18651 C 393.81739,540.61396 401.15447,548.4841 416.25714,548.14156 C 408.15968,534.19151 392.75046,524.63048 374.84848,524.63047 z " + id="path687" /> + <text + xml:space="preserve" + style="font-size:112.55771637px;font-style:normal;font-weight:bold;line-height:100%;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palatino Linotype" + x="286.69199" + y="741.06946" + id="text688" + sodipodi:linespacing="100%" + transform="scale(1.2282659,0.814156)"><tspan + x="286.69199" + y="741.06946" + sodipodi:role="line" + id="tspan693">i</tspan></text> + <path + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 480.51446,524.13119 L 480.51446,616.87976 C 507.96173,616.87976 530.23181,596.12414 530.23178,570.52148 C 530.23178,544.91881 507.96171,524.13117 480.51446,524.13119 z " + id="path700" /> + <path + style="font-size:12px;fill:url(#linearGradient3383);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 480.95072,524.13207 C 461.72602,524.13207 445.27164,535.11506 437.79687,550.78048 C 443.71504,553.81243 450.32022,556.68463 458.10457,554.5982 C 472.7217,551.40589 477.29119,543.8804 484.59975,540.68811 C 499.91963,540.11556 507.25671,547.9857 522.35938,547.64316 C 514.26192,533.69311 498.8527,524.13208 480.95072,524.13207 z " + id="path697" /> + <g + id="g708" + transform="matrix(1.26275,0,0,1.26275,-87.529244,-290.57418)"> + <rect + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect705" + width="15.909903" + height="6.6291261" + x="557.73047" + y="679.8053" + ry="3.314563" /> + <rect + style="font-size:12px;fill:url(#linearGradient3036);fill-rule:evenodd;stroke-width:1pt" + id="rect706" + width="12.472398" + height="1.377152" + x="559.37109" + y="680.06189" + ry="0.68857598" + rx="1.6909561" /> + </g> + <g + id="g711" + transform="matrix(1.26275,0,0,1.26275,-5.494134,-290.85318)"> + <rect + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect712" + width="15.909903" + height="6.6291261" + x="557.73047" + y="679.8053" + ry="3.314563" /> + <rect + style="font-size:12px;fill:url(#linearGradient3038);fill-rule:evenodd;stroke-width:1pt" + id="rect713" + width="12.472398" + height="1.377152" + x="559.37109" + y="680.06189" + ry="0.68857598" + rx="1.6909561" /> + </g> + <g + id="g721" + transform="matrix(0.878674,-0.906901,0.906901,0.878674,-476.65103,514.65082)" + style="font-size:12px"> + <g + id="g722"> + <rect + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect723" + width="15.909903" + height="6.6291261" + x="557.73047" + y="679.8053" + ry="3.314563" /> + <rect + style="font-size:12px;fill:url(#linearGradient3040);fill-rule:evenodd;stroke-width:1pt" + id="rect724" + width="12.472398" + height="1.377152" + x="559.37109" + y="680.06189" + ry="0.68857598" + rx="1.6909561" /> + </g> + <g + id="g725" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect726" + width="15.909903" + height="6.6291261" + x="557.73047" + y="679.8053" + ry="3.314563" /> + <rect + style="font-size:12px;fill:url(#linearGradient3042);fill-rule:evenodd;stroke-width:1pt" + id="rect727" + width="12.472398" + height="1.377152" + x="559.37109" + y="680.06189" + ry="0.68857598" + rx="1.6909561" /> + </g> + </g> + <g + id="g728" + transform="matrix(1.073491e-5,-1.26275,1.26275,1.073491e-5,-194.38993,1328.4811)" + style="font-size:12px"> + <g + id="g729"> + <rect + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect730" + width="15.909903" + height="6.6291261" + x="557.73047" + y="679.8053" + ry="3.314563" /> + <rect + style="font-size:12px;fill:url(#linearGradient3044);fill-rule:evenodd;stroke-width:1pt" + id="rect731" + width="12.472398" + height="1.377152" + x="559.37109" + y="680.06189" + ry="0.68857598" + rx="1.6909561" /> + </g> + <g + id="g732" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect733" + width="15.909903" + height="6.6291261" + x="557.73047" + y="679.8053" + ry="3.314563" /> + <rect + style="font-size:12px;fill:url(#linearGradient3046);fill-rule:evenodd;stroke-width:1pt" + id="rect734" + width="12.472398" + height="1.377152" + x="559.37109" + y="680.06189" + ry="0.68857598" + rx="1.6909561" /> + </g> + </g> + <g + id="g735" + transform="matrix(0.893911,0.891887,-0.891887,0.893911,742.82387,-571.45388)" + style="font-size:12px"> + <g + id="g736"> + <rect + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect737" + width="15.909903" + height="6.6291261" + x="557.73047" + y="679.8053" + ry="3.314563" /> + <rect + style="font-size:12px;fill:url(#linearGradient3048);fill-rule:evenodd;stroke-width:1pt" + id="rect738" + width="12.472398" + height="1.377152" + x="559.37109" + y="680.06189" + ry="0.68857598" + rx="1.6909561" /> + </g> + <g + id="g739" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12px;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect740" + width="15.909903" + height="6.6291261" + x="557.73047" + y="679.8053" + ry="3.314563" /> + <rect + style="font-size:12px;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt" + id="rect741" + width="12.472398" + height="1.377152" + x="559.37109" + y="680.06189" + ry="0.68857598" + rx="1.6909561" /> + </g> + </g> + <path + style="font-size:12px;fill:#e6e6e6;fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 667.99564,543.421 C 656.0175,543.421 645.76543,551.32164 641.1082,562.5906 C 644.79557,564.77164 648.911,566.83777 653.76112,565.33689 C 662.86847,563.04049 665.71554,557.62701 670.26921,555.33063 C 679.81441,554.91877 684.38586,560.58017 693.79572,560.33376 C 688.75052,550.29876 679.14965,543.42101 667.99564,543.421 z " + id="path801" /> + <path + style="fill:#fb4100;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 460.52441,445.57716 C 468.10439,423.92273 481.1518,440.77221 490.71993,441.73323 C 499.04543,441.25268 499.91528,415.30612 515.69646,419.63058 C 523.02791,422.19321 521.03972,439.65107 519.7971,448.94061 C 519.67286,459.51141 521.0452,471.61968 510.4775,480.65309 C 495.68969,492.81335 452.94442,466.75105 460.52441,445.57716 z " + id="path760" + sodipodi:nodetypes="ccccsz" /> + <path + style="font-size:12px;fill:#4789f7;fill-opacity:1;stroke:#1c4ed9;stroke-width:1.71254337;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216003" + d="M 450.82856,482.20291 L 526.04844,506.43293 L 523.28751,511.48629 L 448.52721,485.77118 L 450.82856,482.20291 z " + id="path279" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12px;fill:url(#linearGradient3350);fill-opacity:0.69930001;stroke:#1c66fb;stroke-width:1.77588487;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216003" + d="M 430.83685,438.74362 C 429.82395,436.0564 430.81654,433.49264 433.23265,433.76555 L 468.97638,441.37169 L 471.18114,449.11568 L 486.78016,452.74293 L 484.50444,444.58967 L 500.58846,447.3442 C 502.71461,448.03584 504.36603,449.4673 505.87346,452.74895 L 522.77231,510.83334 L 448.41172,485.62951 L 430.83685,438.74362 z " + id="path208" + sodipodi:nodetypes="ccccccccccc" /> + <path + style="font-size:12px;fill:url(#radialGradient3347);fill-opacity:0.98999999;stroke:#0c1dfb;stroke-width:2.6319499;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.98999999" + d="M 541.55553,431.15809 C 541.23051,427.38586 543.9104,423.50523 547.47412,423.0305 L 628.10196,423.45855 C 631.03285,423.73768 632.90302,425.33481 633.71274,429.8412 L 633.64214,503.32951 L 625.40507,510.69938 L 549.02921,511.04966 L 541.57579,502.95071 L 541.55553,431.15809 z " + id="path1131" + sodipodi:nodetypes="ccccccccc" /> + <path + style="font-size:12px;fill:url(#linearGradient3344);fill-opacity:0.69930001;stroke:#1c2942;stroke-width:2.28141999;stroke-opacity:0.99216003" + d="M 566.84522,480.70051 L 611.32692,480.71086 L 611.71099,511.23534 L 566.54489,511.27158 L 566.84522,480.70051 z " + id="path230" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12px;fill:#ffffff;fill-opacity:0.99216003;stroke:#1c2942;stroke-width:1.10123003;stroke-opacity:0.99216003" + d="M 552.22632,436.30828 L 546.45836,436.08807 L 546.4485,430.05365 L 552.20989,429.99665 L 552.22632,436.30828 z " + id="path313" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12px;fill:#fffffd;fill-opacity:1;stroke:#0c5cff;stroke-width:2.20247006;stroke-opacity:0.99216003" + d="M 556.74217,423.78409 L 619.61682,423.79651 L 620.1597,469.68309 L 556.31765,469.72689 L 556.74217,423.78409 z " + id="path412" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12px;fill:#1c2942;fill-opacity:0.99215698;stroke-width:8.96854973" + d="M 584.87523,506.21798 L 574.38649,506.43578 L 574.36787,484.62813 L 584.84421,484.83956 L 584.87523,506.21798 z " + id="path415" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12px;fill:#ffffff;fill-opacity:0.99216003;stroke:#1c2942;stroke-width:1.10123003;stroke-opacity:0.99216003" + d="M 629.5978,435.86357 L 623.82984,435.64335 L 623.81998,429.60893 L 629.58137,429.55194 L 629.5978,435.86357 z " + id="path420" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:#fb4100;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 560.37851,442.56322 C 567.2077,429.26412 578.96275,439.61227 587.58316,440.20245 C 595.08402,439.90736 595.86769,423.97222 610.08576,426.62808 C 616.69101,428.20192 614.90468,458.5573 605.38373,464.10516 C 592.06066,471.57343 553.54931,455.56721 560.37851,442.56322 z " + id="path1137" + sodipodi:nodetypes="cccsz" /> + <path + style="fill:#000048;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 258.87077,308.5828 C 253.08731,317.00199 248.84661,323.41806 244.02038,334.46537 C 239.19415,345.89492 233.86557,374.16335 237.62514,378.80842 C 241.38471,383.45348 246.87367,380.38573 250.63323,376.271 C 254.3928,372.15627 252.48835,351.21953 253.67461,342.10614 C 254.54837,332.99275 256.89282,323.55354 258.87077,308.5828 z " + id="path1163" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:url(#linearGradient3334);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 244.87703,341.05538 C 243.47705,345.15846 241.84536,347.98072 240.67709,353.3646 C 239.50883,358.93477 237.84073,372.71133 238.75079,374.97509 C 239.66086,377.23885 240.98955,375.74379 241.89961,373.73848 C 242.80967,371.73318 242.34867,361.52971 242.63582,357.08832 C 242.84733,352.64692 244.39824,348.35134 244.87703,341.05538 z " + id="path1164" + sodipodi:nodetypes="czzzzc" /> + <path + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 246.84696,401.26635 C 233.22657,397.6892 232.27442,390.28556 235.78589,385.29279 C 237.10987,383.89377 240.22335,381.74991 242.03082,381.87983 C 243.83829,382.00976 245.39652,382.92548 247.71778,384.58791 C 252.98531,388.53776 243.05535,390.25329 246.84696,401.26635 z " + id="path1165" + sodipodi:nodetypes="ccszc" /> + <path + style="font-size:12px;fill:url(#linearGradient3330);fill-rule:evenodd;stroke-width:1pt" + d="M 242.39644,396.66561 C 239.13849,395.84397 237.60423,396.00137 235.59134,391.07571 C 233.57845,386.46255 238.58293,384.94683 239.17721,384.32111 C 239.77149,383.69538 240.63913,384.10863 241.23341,384.66292 C 241.82769,385.2172 241.52665,388.03755 241.71416,389.26519 C 241.85228,390.49284 239.58379,392.61768 242.39644,396.66561 z " + id="path1166" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:#ff0000;fill-opacity:0.75;fill-rule:nonzero;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + id="path1178" + d="M 314.57982,354.70876 C 315.40432,361.53904 292.43811,370.44146 291.51251,374.36944 C 289.61042,378.70993 304.49355,389.01441 300.45951,394.15556 C 297.88336,401.90543 258.15216,405.84922 248.90859,403.44343 C 247.75479,402.05103 247.55467,398.86418 249.66772,396.95909 C 255.30743,393.65166 283.03666,396.48065 292.19312,391.50374 C 292.99642,389.41248 282.49481,378.89188 285.71585,373.32683 C 289.0931,366.46975 309.78135,359.31112 309.46479,355.27714 C 306.48475,350.72496 283.39899,343.56241 280.66089,339.63205 C 280.66089,339.63205 310.68949,348.99124 314.57982,354.70876 z " + sodipodi:nodetypes="cccccccccc" /> + <path + style="fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 363.38161,311.90492 C 357.59815,320.32411 353.35745,326.74018 348.53122,337.78749 C 343.70499,349.21704 338.37641,377.48547 342.13598,382.13054 C 345.89555,386.7756 351.38451,383.70785 355.14407,379.59312 C 358.90364,375.47839 356.99919,354.54165 358.18545,345.42826 C 359.05921,336.31487 361.40366,326.87566 363.38161,311.90492 z " + id="path1183" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:url(#linearGradient3325);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 349.38787,344.3775 C 347.98789,348.48058 346.3562,351.30284 345.18793,356.68672 C 344.01967,362.25689 342.35157,376.03345 343.26163,378.29721 C 344.1717,380.56097 345.50039,379.06591 346.41045,377.0606 C 347.32051,375.0553 346.85951,364.85183 347.14666,360.41044 C 347.35817,355.96904 348.90908,351.67346 349.38787,344.3775 z " + id="path1184" + sodipodi:nodetypes="czzzzc" /> + <path + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 351.3578,404.58847 C 337.73741,401.01132 336.78526,393.60768 340.29673,388.61491 C 341.62071,387.21589 344.73419,385.07203 346.54166,385.20195 C 348.34913,385.33188 349.90736,386.2476 352.22862,387.91003 C 357.49615,391.85988 347.56619,393.57541 351.3578,404.58847 z " + id="path1185" + sodipodi:nodetypes="ccszc" /> + <path + style="font-size:12px;fill:url(#linearGradient3321);fill-rule:evenodd;stroke-width:1pt" + d="M 346.90728,399.98773 C 343.64933,399.16609 342.11507,399.32349 340.10218,394.39783 C 338.08929,389.78467 343.09377,388.26895 343.68805,387.64323 C 344.28233,387.0175 345.14997,387.43075 345.74425,387.98504 C 346.33853,388.53932 346.03749,391.35967 346.225,392.58731 C 346.36312,393.81496 344.09463,395.9398 346.90728,399.98773 z " + id="path1186" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:#ff0000;fill-opacity:0.75;fill-rule:nonzero;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + id="path1187" + d="M 419.09066,358.03088 C 419.91516,364.86116 396.94895,373.76358 396.02335,377.69156 C 394.12126,382.03205 409.00439,392.33653 404.97035,397.47768 C 402.3942,405.22755 362.663,409.17134 353.41943,406.76555 C 352.26563,405.37315 352.06551,402.1863 354.17856,400.28121 C 359.81827,396.97378 387.5475,399.80277 396.70396,394.82586 C 397.50726,392.7346 387.00565,382.214 390.22669,376.64895 C 393.60394,369.79187 414.29219,362.63324 413.97563,358.59926 C 410.99559,354.04708 387.90983,346.88453 385.17173,342.95417 C 385.17173,342.95417 415.20033,352.31336 419.09066,358.03088 z " + sodipodi:nodetypes="cccccccccc" /> + <path + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#00de00;stroke-width:3.88089991;stroke-linecap:round;stroke-dasharray:7.76179, 7.76179;stroke-dashoffset:0" + d="M 385.46637,349.3006 L 352.76267,401.22876" + id="path1189" /> + <path + style="fill:#fb4100;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 545.83421,339.00725 C 555.29835,316.61255 571.58891,334.03807 583.53539,335.03189 C 593.93035,334.53499 595.01639,307.70136 614.7203,312.17365 C 623.87409,314.82388 621.39853,365.94011 608.20406,375.28229 C 589.74047,387.85833 536.37006,360.90501 545.83421,339.00725 z " + id="path1196" + sodipodi:nodetypes="cccsz" /> + <path + style="font-size:12px;fill:url(#radialGradient3315);fill-opacity:0.98999999;stroke:#0c1dfb;stroke-width:2.47207999;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.98999999" + d="M 539.55742,329.86065 C 550.20758,338.42827 575.36536,339.08326 588.74955,339.28881 C 602.13373,339.49436 625.26054,336.61881 631.71463,328.69888 L 623.40696,400.03263 C 612.55911,405.15586 600.77053,408.29651 587.10049,407.93305 C 573.43045,407.5696 556.31107,405.36188 547.0311,400.34165 L 539.55742,329.86065 z " + id="path1199" + sodipodi:nodetypes="czcczcc" /> + <rect + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt" + id="rect983" + width="106.29922" + height="106.29922" + x="213.87325" + y="199.80083" /> + <rect + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt" + id="rect984" + width="106.29922" + height="106.29922" + x="320.17245" + y="199.80083" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt" + d="M 264.13607,237.58254 C 264.4776,236.89576 263.55204,229.45502 262.13713,227.53203 C 260.72222,225.60904 258.62283,226.45669 258.2813,227.14347 C 257.93978,227.83025 260.05101,226.91589 261.46591,228.83888 C 262.88082,230.76186 263.79455,238.26932 264.13607,237.58254 z " + id="path1018" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt" + d="M 257.8175,276.31726 C 254.83735,276.02984 254.24158,269.14348 252.17246,273.34443 C 250.0083,277.62047 254.46823,286.78993 254.86058,282.05056 C 255.15788,277.31121 260.70261,276.67975 257.8175,276.31726 z " + id="path1019" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt" + d="M 272.68404,237.44007 C 272.34251,236.75328 273.26807,229.31254 274.68298,227.38956 C 276.09788,225.46656 278.19728,226.31421 278.53881,227.00099 C 278.88033,227.68778 276.7691,226.77342 275.3542,228.6964 C 273.93929,230.61939 273.02556,238.12685 272.68404,237.44007 z " + id="path1036" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt" + d="M 279.00261,276.17479 C 281.98276,275.88737 282.57853,269.001 284.64765,273.20196 C 286.81181,277.478 282.35188,286.64746 281.95953,281.90809 C 281.66223,277.16873 276.1175,276.53728 279.00261,276.17479 z " + id="path1037" + sodipodi:nodetypes="czzz" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.0507082pt" + d="M 393.41778,249.75479 C 392.73276,254.42899 380.4132,251.97901 380.21857,259.67332 C 380.02394,266.86846 395.82989,268.28032 401.73513,266.16252 C 407.64038,264.04472 411.50934,260.75037 410.89844,253.45574 C 410.28756,246.16111 408.32593,227.80632 386.76522,217.28135 C 365.63646,207.25555 341.70568,220.92063 334.05688,235.52111 C 326.40807,250.62079 325.79982,265.91294 334.87103,260.42208 C 343.51028,255.43037 354.05149,239.69352 369.86419,237.87506 C 385.2449,236.05659 394.10277,246.07893 393.41778,249.75479 z " + id="path1045" + sodipodi:nodetypes="czzzzzzzz" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.08777227pt" + d="M 357.81578,261.23898 C 356.5181,259.13317 356.92273,251.14638 350.00173,252.6991 C 343.08073,254.25181 335.56436,261.67029 333.48062,264.3444 C 331.39688,267.01853 332.51317,271.7629 333.48062,272.8843 C 334.44808,274.0057 339.9551,274.60952 341.51792,275.9897 C 343.08073,277.36989 346.72728,282.54559 348.66218,282.20055 C 350.59709,281.8555 354.54133,277.71494 354.69016,275.98972 C 354.839,274.26448 359.11343,263.34482 357.81578,261.23898 z " + id="path1049" + sodipodi:nodetypes="czzzzzzz" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.0507082pt" + d="M 353.98747,290.8932 C 354.40835,286.69185 359.13872,270.03729 359.90396,265.00399 C 360.66919,259.9707 357.76131,262.50815 358.98569,260.26188 C 360.21005,258.0156 364.34229,252.73275 367.25016,251.52641 C 370.15805,250.32009 374.29029,251.01837 376.43293,252.14151 C 378.57557,253.26465 379.91473,257.01728 380.10603,258.26519 C 380.29733,259.51312 378.61384,260.92744 377.58077,260.51147 C 376.54771,260.09549 378.19773,253.58856 375.69329,255.59288 C 373.18885,257.77367 370.03172,261.4682 368.39801,263.00731 C 367.08896,264.5464 370.3111,263.75607 370.92328,265.00399 C 371.53546,266.25192 372.6833,268.33179 372.07112,270.49486 C 371.45892,272.65792 368.81888,276.60968 367.25016,277.98239 C 365.68143,279.35511 364.30403,276.69288 362.65879,278.73116 C 361.01354,280.76943 358.78758,289.12011 357.41015,291.07518 L 353.98747,290.8932 z " + id="path1050" + sodipodi:nodetypes="czzzzzzzzzzzzcc" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.875;stroke-dasharray:none" + d="M 352.83142,246.55994 C 353.26061,248.23306 354.60183,252.16987 355.56751,253.05563 C 356.53319,253.94141 358.59869,254.20386 358.9474,253.05563 C 359.29612,251.9074 356.9624,246.13345 362.81013,243.01683 C 368.81881,239.90021 378.20738,240.62195 381.15807,242.03264 C 384.10875,243.44331 389.07129,248.69236 384.37701,252.26828 C 380.48745,255.84417 389.92966,255.9426 391.9415,254.4335 C 393.95334,252.9244 396.87588,247.33751 394.27391,244.64737 C 391.67194,241.95724 385.0755,235.53016 378.95952,234.87404 C 372.84355,234.2179 358.22313,241.50773 356.2113,242.03264 C 354.03853,242.55754 352.40223,244.8868 352.83142,246.55994 z " + id="path1051" + sodipodi:nodetypes="czzzzzzzzzz" /> + <g + id="g1422" + transform="translate(-15.816734,-109.09188)"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.16552086pt" + d="M 500.15302,318.39576 C 498.6309,318.58535 497.62728,319.44559 497.45659,321.35308 L 496.2718,334.4836 L 495.12787,321.15593 C 494.4451,313.52598 480.11544,322.81032 474.82299,326.00594 C 463.97441,332.55643 453.12906,348.90299 453.12904,365.27921 C 453.12904,369.37327 450.53202,374.85695 458.19505,375.61014 C 471.12797,372.2556 475.71395,368.40706 475.88521,364.72718 C 475.97004,366.73597 472.22575,370.99591 477.19257,377.85771 C 471.88006,374.61864 449.68734,372.98113 454.59982,385.78334 C 460.64344,396.79407 487.30926,400.22178 487.52886,393.43295 C 487.74845,386.64413 493.79077,380.76155 483.19824,381.13048 C 485.89452,378.43241 492.4316,379.68832 495.12787,376.99022 L 496.31266,372.81053 L 497.66087,376.55648 C 500.35715,379.25456 506.64909,378.23526 509.34537,380.93333 C 500.48613,379.72791 504.79515,386.40754 505.01475,393.19637 C 505.23437,399.98518 531.94102,396.59692 537.98464,385.58618 C 542.89711,372.78397 520.66354,374.42148 515.35103,377.66055 C 520.31782,370.79874 516.57357,366.49938 516.65839,364.4906 C 516.82967,368.17046 521.41564,372.05845 534.34856,375.41298 C 542.0116,374.65978 539.45542,369.1761 539.45542,365.08206 C 539.45542,348.70583 528.61005,332.35928 517.76147,325.80879 C 513.79214,323.41205 504.71936,317.82698 500.15302,318.39576 z " + id="path1060" + sodipodi:nodetypes="cccccccccccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt" + d="M 501.66595,339.08941 C 507.48057,336.85763 507.44235,336.64611 505.77764,338.68995 C 504.31721,340.73379 502.98053,336.92565 501.65049,348.68951 C 500.11618,360.84766 495.64707,341.51834 501.66595,339.08941 z " + id="path1057" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt" + d="M 491.59647,339.30071 C 485.78186,337.06892 485.82008,336.85741 487.48479,338.90125 C 488.94522,340.94509 490.2819,337.13695 491.61194,348.9008 C 493.14625,361.05897 497.61536,341.72965 491.59647,339.30071 z " + id="path1059" + sodipodi:nodetypes="czzz" /> + </g> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient3062);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + id="path1065" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(1.269231,0,0,1.209574,137.91637,-391.80978)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt" + id="rect1074" + width="42.038872" + height="31.251434" + x="806.71417" + y="226.75293" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 819.23401,235.83827 C 829.23401,236.6716 837.98401,240.4216 843.60901,248.96327 C 849.23401,258.12994 848.60901,258.96327 848.60901,258.96327 C 848.60901,258.96327 849.85901,267.71327 837.98401,268.96327 C 826.10901,269.58827 812.80095,257.37856 799.05095,257.37856 C 785.92595,257.37856 781.10901,255.33351 782.98401,243.96327 C 784.85901,232.15109 798.29651,206.46327 821.10901,205.83827 C 843.92151,204.58827 864.54651,211.9841 872.98401,227.08827 C 880.79651,242.19244 877.04651,253.96327 872.35901,257.71327 C 867.67151,261.46327 856.94234,256.46327 848.60901,258.33827" + id="path1067" + sodipodi:nodetypes="czzzzzzzzz" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 834.85901,257.08827 C 827.35901,254.58827 824.23401,254.58827 817.35901,248.33827 C 810.48401,242.08827 809.23401,235.83827 809.23401,235.83827" + id="path1068" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 826.73401,206.46327 C 827.35901,218.96327 834.15818,226.67123 831.94848,236.83589" + id="path1069" + sodipodi:nodetypes="cc" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 840.13877,213.44025 C 854.73083,213.197 857.34591,215.81208 859.43798,226.79542 C 865.19116,223.65732 868.18798,225.41724 869.43798,237.91724" + id="path1070" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 849.45107,234.18033 C 849.45107,234.18033 840.18981,253.08198 849.56481,252.45698 C 858.93981,251.83198 855.28403,251.8829 857.93568,250.77805" + id="path1071" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 794.9741,233.10811 C 794.9741,233.10811 798.12134,225.52191 806.0986,221.07625 C 814.07585,217.1536 819.57263,214.37906 819.7936,208.85479 L 819.13069,214.5242 C 818.40282,220.74913 827.76732,227.71239 824.7936,234.41697" + id="path1072" + sodipodi:nodetypes="czczz" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 836.12326,205.71363 C 841.38865,216.00392 837.5669,231.23283 841.54438,242.0604" + id="path1073" + sodipodi:nodetypes="cc" + inkscape:export-filename="C:\pas\mricron\btn\render.png" + inkscape:export-xdpi="59.193832" + inkscape:export-ydpi="59.193832" /> + <rect + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt" + id="rect1173" + width="106.29922" + height="106.29922" + x="426.47165" + y="93.501656" /> + <rect + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt" + id="rect1174" + width="106.29922" + height="106.29922" + x="532.77087" + y="93.501656" /> + <rect + style="fill:url(#linearGradient3266);fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:3.75;stroke-dasharray:none" + id="rect1204" + width="91.25" + height="30" + x="-312.93326" + y="132.02031" + ry="12.5" + transform="scale(-1,1)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:1.27241249pt" + d="M 372.7571,104.0435 C 363.84962,104.0461 348.56454,111.16259 342.62403,116.5091 C 330.74298,127.20208 324.08732,155.03475 324.08732,172.8564 C 324.08732,178.28856 324.10322,183.61773 324.33245,188.74709 L 418.99322,188.74709 C 419.23436,183.66252 419.27921,178.4092 419.27921,173.01412 C 419.27917,155.1925 415.62342,128.33815 403.71599,117.62438 C 397.76228,112.26749 381.66458,104.0409 372.7571,104.0435 z " + id="path1205" + sodipodi:nodetypes="cccccccc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.16552086pt" + d="M 376.29987,107.00663 C 374.77775,107.19622 373.77413,108.05646 373.60344,109.96395 L 372.41865,123.09447 L 371.27472,109.7668 C 370.59195,102.13685 356.26229,111.42119 350.96984,114.61681 C 340.12126,121.1673 329.27591,137.51386 329.27589,153.89008 C 329.27589,157.98414 326.67887,163.46782 334.3419,164.22101 C 347.27482,160.86647 351.8608,157.01793 352.03206,153.33805 C 352.11689,155.34684 348.3726,159.60678 353.33942,166.46858 C 348.02691,163.22951 325.83419,161.592 330.74667,174.39421 C 336.79029,185.40494 363.45611,188.83265 363.67571,182.04382 C 363.8953,175.255 369.93762,169.37242 359.34509,169.74135 C 362.04137,167.04328 368.57845,168.29919 371.27472,165.60109 L 372.45951,161.4214 L 373.80772,165.16735 C 376.504,167.86543 382.79594,166.84613 385.49222,169.5442 C 376.63298,168.33878 380.942,175.01841 381.1616,181.80724 C 381.38122,188.59605 408.08787,185.20779 414.13149,174.19705 C 419.04396,161.39484 396.81039,163.03235 391.49788,166.27142 C 396.46467,159.40961 392.72042,155.11025 392.80524,153.10147 C 392.97652,156.78133 397.56249,160.66932 410.49541,164.02385 C 418.15845,163.27065 415.60227,157.78697 415.60227,153.69293 C 415.60227,137.3167 404.7569,120.97015 393.90832,114.41966 C 389.93899,112.02292 380.86621,106.43785 376.29987,107.00663 z " + id="path1206" + sodipodi:nodetypes="cccccccccccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt" + d="M 377.8128,127.70028 C 383.62742,125.4685 383.5892,125.25698 381.92449,127.30082 C 380.46406,129.34466 379.12738,125.53652 377.79734,137.30038 C 376.26303,149.45853 371.79392,130.12921 377.8128,127.70028 z " + id="path1207" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt" + d="M 367.74332,127.91158 C 361.92871,125.67979 361.96693,125.46828 363.63164,127.51212 C 365.09207,129.55596 366.42875,125.74782 367.75879,137.51167 C 369.2931,149.66984 373.76221,130.34052 367.74332,127.91158 z " + id="path1209" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#00ff00;stroke-width:8.125;stroke-linecap:round;stroke-linejoin:bevel;stroke-dasharray:none;stroke-dashoffset:12.5" + d="M 412.42043,191.6321 L 336.35302,117.64904" + id="path1210" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:5;stroke-dasharray:none;stroke-opacity:1" + d="M 591.68327,168.2703 C 591.68327,182.4153 580.20327,193.8953 566.05827,193.8953 C 551.91327,193.8953 540.43327,182.4153 540.43327,168.2703 C 540.43327,154.1253 551.91327,142.6453 566.05827,142.6453 C 580.20327,142.6453 591.68327,154.1253 591.68327,168.2703 z " + id="path1291" /> + <g + id="g1298" + transform="translate(402.30827,-332.21688)"> + <path + style="fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 176.78473,427.8954 C 171.00127,436.31459 166.76057,442.73066 161.93434,453.77797 C 157.10811,465.20752 151.77953,493.47595 155.5391,498.12102 C 159.29867,502.76608 164.78763,499.69833 168.54719,495.5836 C 172.30676,491.46887 170.40231,470.53213 171.58857,461.41874 C 172.46233,452.30535 174.80678,442.86614 176.78473,427.8954 z " + id="path1294" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:url(#linearGradient1139);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 162.79099,460.36798 C 161.39101,464.47106 159.75932,467.29332 158.59105,472.6772 C 157.42279,478.24737 155.75469,492.02393 156.66475,494.28769 C 157.57482,496.55145 158.90351,495.05639 159.81357,493.05108 C 160.72363,491.04578 160.26263,480.84231 160.54978,476.40092 C 160.76129,471.95952 162.3122,467.66394 162.79099,460.36798 z " + id="path1295" + sodipodi:nodetypes="czzzzc" /> + <path + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 164.76093,520.57895 C 151.14054,517.0018 150.18838,509.59815 153.69986,504.60539 C 155.02384,503.20637 158.13732,501.06251 159.94479,501.19243 C 161.75226,501.32236 163.31049,502.23808 165.63175,503.9005 C 170.89928,507.85036 160.96932,509.56589 164.76093,520.57895 z " + id="path1296" + sodipodi:nodetypes="ccszc" /> + <path + style="font-size:12px;fill:url(#linearGradient1175);fill-rule:evenodd;stroke-width:1pt" + d="M 160.3104,515.97821 C 157.05245,515.15657 155.51819,515.31397 153.5053,510.38831 C 151.49241,505.77515 156.49689,504.25943 157.09117,503.63371 C 157.68545,503.00798 158.55309,503.42123 159.14737,503.97552 C 159.74165,504.5298 159.44061,507.35015 159.62812,508.57779 C 159.76624,509.80544 157.49775,511.93028 160.3104,515.97821 z " + id="path1297" + sodipodi:nodetypes="czzzzc" /> + </g> + <rect + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:4.56593418" + id="rect1303" + width="48.979599" + height="47.110672" + x="580.53296" + y="122.93801" /> + <rect + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt" + id="rect1092" + width="106.29922" + height="106.29922" + x="533.39587" + y="-13.422614" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:5;stroke-linecap:round;stroke-dasharray:10, 10;stroke-dashoffset:0;stroke-opacity:1" + d="M 539.64468,67.3328 C 543.73377,67.33772 550.81253,73.21863 551.91196,67.34757 C 553.01139,61.78901 560.6315,5.33969 564.99126,-3.51858 C 569.35102,-12.376848 566.16507,6.13694 579.58734,10.13546 C 593.32211,13.82148 597.36938,71.83083 605.47914,75.3766 C 613.5889,78.60987 615.13616,73.42533 619.49592,70.47257 C 623.85568,67.51982 626.02795,67.34757 630.38772,67.34757" + id="path1280" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#040600;stroke-width:3.75;stroke-linecap:butt;stroke-dasharray:3.75, 3.75;stroke-dashoffset:0;stroke-opacity:1" + d="M 539.43674,67.53502 C 543.52583,67.53994 550.60459,70.92085 551.70402,65.04979 C 552.80345,59.49123 555.42356,24.91691 559.78332,16.05864 C 564.14308,7.20037 567.20713,-4.28584 580.3169,1.58768 C 593.11417,14.6487 606.22394,79.22055 609.3337,80.57882 C 611.50596,81.31209 614.92822,73.62755 619.28798,70.67479 C 623.64774,67.72204 625.82001,67.54979 630.17978,67.54979" + id="path1281" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#040600;stroke-width:3.75;stroke-linecap:butt;stroke-dasharray:3.75, 3.75;stroke-dashoffset:0;stroke-opacity:1" + d="M 395.76647,77.589073 C 399.85556,77.593993 406.93432,80.974903 408.03375,75.103843 C 409.13318,69.545283 411.75329,34.970963 416.11305,26.112693 C 420.47281,17.254423 423.53686,5.7682122 436.64663,11.641733 C 449.4439,24.702753 462.55367,89.274602 465.66343,90.632872 C 467.83569,91.366142 471.25795,83.681603 475.61771,80.728843 C 479.97747,77.776093 482.14974,77.603843 486.50951,77.603843" + id="path1282" + sodipodi:nodetypes="czzzzzz" /> + <g + id="g1163" + transform="matrix(1.152996,0,0,1,-83.837104,-109.09188)"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.07708836;stroke-dasharray:none" + d="M 472.42571,238.27147 C 472.33405,238.27145 472.24478,238.29291 472.15311,238.29398 L 472.15311,238.31648 C 472.08489,238.31034 472.01758,238.29395 471.94867,238.29398 C 471.78809,238.29403 471.63216,238.33557 471.47163,238.33899 L 471.47163,238.42899 C 471.37376,238.41606 471.27556,238.40652 471.17632,238.40649 C 471.1074,238.40647 471.0401,238.42285 470.97187,238.42899 L 470.97187,238.40649 C 470.88021,238.40543 470.79094,238.38396 470.69928,238.38399 C 465.87162,238.38545 461.03877,239.90805 457.81913,242.92943 C 456.20932,244.44011 446.99543,256.8992 450.09559,259.04098 C 457.81097,264.68512 464.49982,248.07035 457.3648,261.85375 C 456.64585,266.58811 456.46107,269.05668 456.41072,270.29207 C 456.30905,268.02898 455.46815,262.72102 451.04967,260.14359 C 447.35854,258.03472 444.93899,276.66261 444.93899,279.18042 C 444.93899,289.25168 451.37986,299.31925 457.81913,303.34776 C 461.08484,305.39084 466.00722,306.3715 470.90372,306.34054 L 470.90372,306.36305 C 471.15408,306.3651 471.40305,306.34374 471.65336,306.34054 L 471.65336,306.22803 C 471.84267,306.23528 472.03155,306.25211 472.22127,306.25053 L 472.22127,306.22803 C 477.11777,306.25899 482.04015,305.27835 485.30586,303.23524 C 491.74513,299.20674 498.186,289.13916 498.186,279.06791 C 498.186,276.5501 495.76645,257.9222 492.07532,260.03107 C 487.65684,262.60851 486.81594,267.91647 486.71427,270.17956 C 486.66392,268.94417 486.47914,266.47559 485.76018,261.74124 C 478.62517,247.95784 485.31402,264.5726 493.0294,258.92847 C 496.12956,256.78669 486.91567,244.32759 485.30586,242.81691 C 482.08622,239.79554 477.25337,238.27293 472.42571,238.27147 z " + id="path1211" + transform="matrix(0.896078,0,0,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.7041852pt" + d="M 468.24591,259.15861 C 468.51094,258.62567 467.79271,252.85171 466.69475,251.35949 C 465.59679,249.86726 463.96768,250.52503 463.70265,251.05797 C 463.43764,251.5909 465.07594,250.88137 466.17389,252.37359 C 467.27185,253.86581 467.9809,259.69155 468.24591,259.15861 z " + id="path1212" + sodipodi:nodetypes="czzzz" + transform="matrix(0.896078,0,0,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt" + d="M 463.34275,289.21648 C 461.03017,288.99344 460.56786,283.64967 458.96224,286.90958 C 457.28286,290.22776 460.74374,297.34319 461.0482,293.66548 C 461.2789,289.98777 465.58157,289.49777 463.34275,289.21648 z " + id="path1213" + sodipodi:nodetypes="czzz" + transform="matrix(0.896078,0,0,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.7041852pt" + d="M 474.87908,259.04805 C 474.61405,258.51511 475.33228,252.74115 476.43024,251.24893 C 477.52819,249.7567 479.15731,250.41447 479.42234,250.9474 C 479.68735,251.48035 478.04905,250.77081 476.9511,252.26303 C 475.85314,253.75526 475.14409,259.58099 474.87908,259.04805 z " + id="path1214" + sodipodi:nodetypes="czzzz" + transform="matrix(0.896078,0,0,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt" + d="M 479.78224,289.10592 C 482.09482,288.88288 482.55713,283.53911 484.16275,286.79902 C 485.84213,290.1172 482.38125,297.23264 482.07679,293.55492 C 481.84609,289.87721 477.54342,289.38721 479.78224,289.10592 z " + id="path1215" + sodipodi:nodetypes="czzz" + transform="matrix(0.896078,0,0,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt" + d="M 479.78224,289.10592 C 482.09482,288.88288 482.55713,283.53911 484.16275,286.79902 C 485.84213,290.1172 482.38125,297.23264 482.07679,293.55492 C 481.84609,289.87721 477.54342,289.38721 479.78224,289.10592 z " + id="path1245" + sodipodi:nodetypes="czzz" + transform="matrix(0.896078,0,0,0.909383,71.19322,13.47142)" /> + <path + transform="matrix(0.820025,0,0,0.858963,104.9588,28.9685)" + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.07708836" + d="M 472.42572,238.27147 C 466.99935,238.3446 460.99557,239.27928 457.242,243.6056 C 454.27786,247.05912 447.543,265.39403 446.588,268.07554 C 444.99506,275.03305 443.89364,282.61304 446.9967,289.34223 C 449.98685,297.12243 456.23622,304.66231 464.92263,305.85892 C 470.66585,306.6581 476.71462,306.56039 482.24009,304.66227 C 488.70615,302.32029 492.95294,296.28794 495.73557,290.27853 C 498.36218,284.49691 498.76947,277.90311 497.25994,271.76637 C 496.6036,267.85969 495.93735,263.78918 493.70802,260.42078 C 490.47721,259.07927 488.59909,263.53006 487.49637,265.86353 C 487.00972,267.33824 486.63024,271.50536 486.49583,267.70454 C 486.56751,263.78501 485.27565,260.09141 483.12367,256.86 C 483.47775,256.38368 486.42646,260.44859 488.46678,259.99317 C 492.66404,261.2943 494.92727,256.76681 492.55453,253.62131 C 490.80672,249.9676 488.38631,246.652 485.92858,243.45619 C 482.48414,239.81958 477.32986,238.26882 472.42572,238.27147 z " + id="path1151" + sodipodi:nodetypes="cccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.7041852pt" + d="M 469.29214,259.15861 C 471.28335,258.62567 470.01209,252.60872 468.91413,251.1165 C 467.81617,249.62427 460.51529,248.09514 463.70265,251.05797 C 467.13661,253.77781 467.05433,259.69155 469.29214,259.15861 z " + id="path1242" + sodipodi:nodetypes="czzz" + transform="matrix(0.820025,0,0,0.858963,104.9588,28.9685)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt" + d="M 466.83017,280.96913 C 464.51759,280.74609 460.56786,283.64967 458.96224,286.90958 C 457.28286,290.22776 460.74374,297.34319 461.0482,293.66548 C 461.2789,289.98777 469.06899,281.25042 466.83017,280.96913 z " + id="path1243" + sodipodi:nodetypes="czzz" + transform="matrix(0.820025,0,0,0.858963,104.9588,28.9685)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59100037pt" + d="M 493.43163,251.60533 C 491.79878,251.14755 492.84125,245.97921 493.74161,244.69745 C 494.64196,243.41568 500.62886,242.10222 498.01515,244.64717 C 495.19921,246.98342 495.26668,252.0631 493.43163,251.60533 z " + id="path1152" + sodipodi:nodetypes="czzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.52140689" + d="M 511.80663,239.60773 C 505.82577,239.32916 500.11547,244.27305 498.49491,246.98563 C 497.16791,249.22473 493.46139,261.39466 492.85327,264.1486 C 492.10462,268.10699 491.68917,272.2685 492.99906,276.15741 C 494.65527,281.44574 497.8549,286.62328 502.77269,289.10403 C 505.89347,290.48383 509.46589,290.71532 512.64653,290.47013 C 516.82711,290.39011 521.1916,289.06289 524.01723,285.6621 C 528.59029,280.58529 531.28514,273.27869 529.87427,266.31128 C 529.26796,262.87343 525.92547,250.57752 524.78129,248.36436 C 522.92298,245.30255 517.65774,239.61035 511.80663,239.60773 z " + id="path1149" + sodipodi:nodetypes="cccccccccc" /> + </g> + <path + style="fill:#cccccc;fill-opacity:1;fill-rule:nonzero;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + id="path1142" + d="M 138.66767,389.39149 C 138.44176,383.72226 145.56665,387.55955 145.98842,387.81204 C 148.96509,389.52446 154.57645,395.05092 158.13596,394.96803 C 160.13885,394.75388 161.81717,393.54252 163.24286,392.19084 C 164.52303,390.90588 165.39009,389.48939 166.24724,387.90878 C 167.62765,385.61133 171.36675,378.90196 173.96259,379.02192 C 176.3473,379.252 180.6262,381.76723 182.82201,382.68319 C 184.52628,383.3966 187.66318,382.74725 189.39484,383.39336 C 190.69907,383.85026 187.07224,389.98343 188.44387,390.1658 C 189.58344,390.2587 190.28074,389.76906 191.11843,389.02388 C 191.75718,388.42263 195.70074,391.22127 194.88417,391.98976 C 192.75044,393.88937 190.46141,394.76495 187.5927,394.46701 C 185.76743,394.20765 183.97718,393.74035 182.24558,393.1098 C 180.4623,392.42436 178.76716,391.54829 177.00797,390.80685 C 175.46375,390.16429 173.85066,389.50279 172.17678,389.30273 C 171.55021,389.26725 171.32777,389.20991 170.97538,389.74989 C 169.85645,391.71173 168.68703,393.47761 167.0634,395.07079 C 164.5015,397.41937 161.60412,399.05395 158.07518,399.24036 C 153.41627,399.11799 146.22829,400.87294 140.4353,391.66204 C 140.15115,391.46374 144.14072,386.65256 144.03158,389.39149 L 138.66767,389.39149 z " + sodipodi:nodetypes="ccccccccccccccccccccc" /> + <rect + style="fill:#f9bac0;fill-rule:evenodd;stroke:#000000;stroke-width:0.59608836pt" + id="rect1120" + width="14.67272" + height="14.527117" + x="-220.29938" + y="355.46417" + ry="4.7484632" + transform="matrix(0.6694625,-0.7428458,0.7836175,0.6212436,0,0)" /> + <rect + style="fill:url(#linearGradient3202);fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.20409851pt" + id="rect1117" + width="63.894375" + height="13.612261" + x="-209.20451" + y="355.92163" + transform="matrix(0.6694625,-0.7428458,0.7836175,0.6212436,0,0)" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.12771654" + d="M 144.38317,376.51805 L 183.13574,333.04569 L 183.13574,333.04569" + id="path1126" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.12771654" + d="M 148.72431,379.95966 L 187.47688,336.4873 L 187.47688,336.4873" + id="path1128" /> + <path + style="fill:#e49415;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 181.54997,328.19842 L 204.7151,313.05607 L 193.41872,337.20894 L 181.54997,328.19842 z " + id="path1129" /> + <path + style="fill:#040023;fill-rule:evenodd;stroke-width:1pt" + d="M 196.57455,318.36983 L 205.12859,312.58608 L 200.74625,321.52752 L 196.57455,318.36983 z " + id="path1132" /> + <g + id="g1195" + transform="matrix(0.789807,0,0,0.829148,24.785486,35.13232)"> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient1169);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87644994;stroke-dasharray:none" + id="path1190" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(1.269231,0,0,1.209574,-184.6799,-194.3941)" /> + <path + style="font-size:12px;fill:url(#linearGradient683);fill-opacity:0.38016998;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 159.72524,722.93003 C 140.50054,722.93003 124.04616,733.91302 116.57139,749.57844 C 122.48956,752.61039 129.09474,755.48259 136.87909,753.39616 C 151.49622,750.20385 156.06571,742.67836 163.37427,739.48607 C 178.69415,738.91352 186.03123,746.78366 201.1339,746.44112 C 193.03644,732.49107 177.62722,722.93004 159.72524,722.93003 z " + id="path1191" /> + <text + xml:space="preserve" + style="font-size:48px;font-style:normal;font-weight:bold;line-height:100%;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palatino Linotype" + x="47.569454" + y="419.89508" + id="text1192" + sodipodi:linespacing="100%" + transform="scale(2.880225,1.909157)"><tspan + x="47.569454" + y="419.89508" + sodipodi:role="line" + id="tspan1193">i</tspan></text> + </g> + <path + style="fill:#fb4100;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 142.10016,698.71774 C 150.32082,682.69183 164.47101,695.16173 174.84786,695.87292 C 183.87705,695.51733 184.82039,676.31489 201.93545,679.5153 C 209.88655,681.41184 207.73624,717.9912 196.27536,724.67657 C 180.23767,733.67611 133.87948,714.38803 142.10016,698.71774 z " + id="path1179" + sodipodi:nodetypes="cccsz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 119.90595,252.88899 C 118.85992,255.24256 123.55617,255.51496 127.86561,257.22021 C 132.17504,258.92546 136.62069,262.58658 139.25756,263.34931 C 144.53131,264.87477 154.03276,265.3542 157.82463,264.39534 C 161.6165,263.43648 161.31141,260.47272 162.00876,256.55011" + id="path1135" + sodipodi:nodetypes="cszzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 147.62582,248.18188 C 142.39566,241.38267 152.07145,242.16719 152.59448,237.98306 C 155.20955,227.78425 145.27225,226.2152 145.27225,226.2152 C 145.27225,226.2152 151.28694,218.63146 152.85598,214.44733 C 147.62582,208.69415 148.14883,209.47868 140.04208,213.13979" + id="path1138" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 153.379,273.80964 C 153.98918,266.2259 148.58467,265.57213 146.31827,264.39534" + id="path1141" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 119.7752,257.53887 C 122.9133,264.8611 134.37607,267.25825 139.64982,268.78371" + id="path1153" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 176.68832,247.791 C 181.91848,240.99179 172.24269,241.77631 171.71966,237.59218 C 169.10459,227.39337 179.04189,225.82432 179.04189,225.82432 C 179.04189,225.82432 173.0272,218.24058 171.45816,214.05645 C 176.68832,208.30327 176.16531,209.0878 184.27206,212.74891" + id="path1167" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 170.93514,273.41876 C 170.32496,265.83502 175.72947,265.18125 177.99587,264.00446" + id="path1169" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 204.53894,257.14799 C 201.40084,264.47022 189.93807,266.86737 184.66432,268.39283" + id="path1170" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 204.396,252.4136 C 205.44203,254.76717 200.74578,255.03957 196.43634,256.74482 C 192.12691,258.45007 187.68126,262.11119 185.04439,262.87392 C 179.77064,264.39938 170.26919,264.87881 166.47732,263.91995 C 162.68545,262.96109 161.683,257.64376 162.03168,253.19813" + id="path1194" + sodipodi:nodetypes="cszzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 125.13612,240.59811 C 117.46522,261.6931 126.09498,252.62748 130.8893,252.88899" + id="path1195" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 198.66259,240.1321 C 206.33349,261.22709 197.70373,252.16147 192.90941,252.42298" + id="path1218" + sodipodi:nodetypes="cz" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 169.39735,105.71938 C 162.10505,105.75558 154.07994,107.25613 149.24239,113.24002 C 145.68525,117.38626 143.13108,122.29128 140.39162,126.96404 C 138.4291,131.48683 134.21524,152.7264 134.04914,160.14626 C 134.89311,172.12407 141.3859,183.93155 151.73427,190.22339 C 159.97252,194.26858 169.64282,193.9197 178.45471,192.35355 C 186.19946,190.80763 192.37151,185.22838 196.32348,178.59838 C 201.86706,170.07793 204.00788,159.36075 201.49479,149.44773 C 200.50965,144.115 196.66803,125.58494 193.27772,121.84145 C 189.6424,115.2255 184.68602,108.33309 176.82299,106.68486 C 174.40559,106.03251 171.89981,105.72324 169.39735,105.71938 z " + id="path1223" + sodipodi:nodetypes="ccccccccccc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 164.88535,105.92145 C 165.93138,106.53164 168.00101,104.58409 168.39327,118.66194 C 168.78553,132.73979 168.73939,187.94781 169.08806,190.38856 C 169.43673,192.5678 166.75821,193.42635 163.74413,193.18855" + id="path1220" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 172.17264,105.89284 C 171.12661,106.50303 169.05698,104.55548 168.66472,118.63333 C 168.27246,132.71118 169.24317,188.28903 168.8945,190.72978 C 168.54583,192.90902 171.40927,193.21282 174.42334,192.97503" + id="path1221" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 182.45745,145.55465 C 174.5953,135.38048 175.44975,132.40301 183.70286,126.16129 C 178.0131,123.47057 177.93926,120.59539 187.92533,114.2885" + id="path1224" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-dasharray:none" + d="M 152.6509,146.5756 C 160.51305,136.40143 159.6586,133.42396 151.40549,127.18224 C 157.09525,124.49152 157.16909,121.61634 147.18302,115.30945" + id="path1227" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 164.47454,148.50937 C 161.26937,152.76239 154.15017,147.49234 152.64004,146.47531 C 151.12991,145.45828 148.94176,150.3585 144.50382,148.87919 C 140.2508,147.39988 140.80553,143.14686 140.80553,143.14686" + id="path1228" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 162.60184,160.69108 C 158.4721,162.3553 152.39349,155.64311 150.88336,154.62608 C 149.37323,153.60905 147.18508,158.50927 142.74714,157.02996 C 138.49412,155.55065 136.27514,144.64072 136.27514,144.64072" + id="path1229" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 156.98552,187.53536 C 147.30836,175.51594 156.27668,178.93685 156.6157,172.92714 C 157.32454,167.28726 162.79607,166.31561 158.73065,167.13701 C 155.71761,167.77479 152.82496,163.12668 144.04154,167.00988" + id="path1230" + sodipodi:nodetypes="czsz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 172.05604,147.11525 C 175.26121,151.36827 182.38041,146.09822 183.89054,145.08119 C 185.40067,144.06416 187.58882,148.96438 192.02676,147.48507 C 196.27978,146.00576 195.72505,141.75274 195.72505,141.75274" + id="path1232" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 172.35969,159.29696 C 176.48943,160.96118 184.13709,154.24899 185.64722,153.23196 C 187.15735,152.21493 189.3455,157.11515 193.78344,155.63584 C 198.03646,154.15653 200.25544,143.2466 200.25544,143.2466" + id="path1233" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.70000005;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 181.11411,185.61822 C 190.79127,173.5988 181.82295,177.01971 181.48393,171.01 C 180.77509,165.37012 175.30356,164.39847 179.36898,165.21987 C 182.38202,165.85765 185.27467,161.20954 194.05809,165.09274" + id="path1234" + sodipodi:nodetypes="czsz" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt" + id="rect1300" + width="25.381052" + height="18.778831" + x="735.11206" + y="593.82367" + transform="matrix(0.932103,-0.3621934,0,1,0,0)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 689.65698,333.99075 C 695.28457,332.30474 704.43001,331.66408 706.81101,333.58867 C 709.192,335.77477 710.05808,334.51818 711.36562,337.39476 C 712.41166,340.27135 712.87988,341.44154 706.19712,344.78942 C 699.51435,347.76175 686.53346,348.8268 679.84155,346.0804 C 673.14965,343.85702 670.26758,344.06785 671.32275,336.82552 C 672.37792,329.31762 680.46301,317.21969 693.30095,311.8556 C 706.13889,306.11596 717.7458,306.04991 722.49408,313.28086 C 726.89063,320.64848 725.15011,325.95275 722.51218,329.23114 C 719.87425,332.50954 715.56943,333.37544 710.87978,336.32441" + id="path1301" + sodipodi:nodetypes="czzzzzzzzz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 704.43849,338.33715 C 700.2178,338.47498 692.4445,341.2504 688.57553,338.9982" + id="path1302" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 693.74307,313.26495 C 697.23289,316.97836 700.64449,321.5205 699.40096,328.1116" + id="path1303" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 703.2256,314.35433 C 711.43741,311.01724 713.69359,309.92471 714.87093,316.06706 C 718.10858,312.92332 719.79507,313.32552 720.49852,320.56336" + id="path1304" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 709.2507,322.68851 C 709.2507,322.68851 704.03885,336.07162 709.31471,333.64598 C 714.59058,331.22034 712.53325,332.05037 714.02549,330.80662" + id="path1305" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 678.5933,333.95697 C 678.5933,333.95697 683.32306,329.08006 687.81234,324.66426 C 692.30161,320.56274 690.8673,320.72329 690.99165,317.35547 L 693.36057,321.66539 C 695.24931,325.10168 697.04798,323.54365 695.37449,328.22267" + id="path1306" + sodipodi:nodetypes="czczz" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 698.61226,311.89707 C 706.02105,315.62151 701.51674,325.08519 704.80114,330.72165" + id="path1307" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 691.91037,309.38975 C 687.68968,305.60495 686.45407,308.11887 683.63114,308.48175" + id="path1387" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 709.30063,304.39086 C 703.5109,303.74416 699.92171,305.99657 697.09878,306.35945" + id="path1389" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.09033966" + d="M 683.67285,312.00497 C 679.97518,311.86715 672.72488,318.24451 670.42497,326.51139" + id="path1390" + sodipodi:nodetypes="cc" /> + <path + style="font-size:12px;fill:url(#linearGradient3132);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 266.43856,630.60816 C 247.21386,630.60816 230.75948,641.59115 223.28471,657.25657 C 229.20288,660.28852 235.80806,663.16072 243.59241,661.07429 C 258.20954,657.88198 262.77903,650.35649 270.08759,647.1642 C 285.40747,646.59165 292.74455,654.46179 307.84722,654.11925 C 299.74976,640.1692 284.34054,630.60817 266.43856,630.60816 z " + id="path1561" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient3064);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + id="path1562" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(1.269231,0,0,1.209574,-76.235414,-285.91008)" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient983);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + id="path1574" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(0.484769,0,0,0.461984,538.38387,214.33362)" /> + <rect + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2.375" + id="rect1280" + width="69.96357" + height="45.246185" + x="112.90554" + y="426.39694" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt" + id="rect1278" + width="24.317806" + height="18.077705" + x="-157.74673" + y="441.57275" + transform="scale(-1,1)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.375" + d="M 154.66415,447.62583 C 148.87955,448.10788 143.81803,450.2771 140.56419,455.21812 C 137.31035,460.52067 137.67189,461.00272 137.67189,461.00272 C 137.67189,461.00272 136.94882,466.06424 143.81803,466.78732 C 150.68724,467.14886 158.38542,460.08603 166.33925,460.08603 C 173.93154,460.08603 176.71794,458.90305 175.63333,452.32582 C 174.54872,445.49295 166.77566,430.63357 153.57954,430.27203 C 140.38342,429.54896 128.45269,433.82715 123.57193,442.56431 C 119.05271,451.30146 121.22194,458.11042 123.93347,460.27964 C 126.645,462.44887 132.85139,459.55657 137.67189,460.64118" + id="path1279" + sodipodi:nodetypes="czzzzzzzzz" /> + <rect + transform="scale(-1,1)" + y="467.71524" + x="-201.17461" + height="45.246185" + width="69.96357" + id="rect1289" + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.375;stroke-dasharray:none" /> + <rect + y="482.89105" + x="156.3334" + height="18.077705" + width="24.317806" + id="rect1291" + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt" /> + <path + sodipodi:nodetypes="czzzzzzzzz" + id="path1292" + d="M 159.41599,488.9441 C 165.20059,489.42615 170.26212,491.59537 173.51595,496.53639 C 176.76979,501.83894 176.40825,502.32099 176.40825,502.32099 C 176.40825,502.32099 177.13133,507.38251 170.26212,508.10559 C 163.3929,508.46713 155.69472,501.4043 147.7409,501.4043 C 140.14861,501.4043 137.3622,500.22132 138.44682,493.64409 C 139.53143,486.81122 147.30448,471.95184 160.5006,471.5903 C 173.69672,470.86723 185.62746,475.14542 190.50822,483.88258 C 195.02743,492.61973 192.85821,499.42869 190.14668,501.59791 C 187.43515,503.76714 181.22875,500.87484 176.40825,501.95945" + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.375;stroke-dasharray:none" /> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.375" + id="rect1268" + width="69.96357" + height="45.246185" + x="-109.90839" + y="566.82684" + transform="scale(-1,1)" /> + <path + sodipodi:type="arc" + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="path1285" + sodipodi:cx="88.389725" + sodipodi:cy="698.28027" + sodipodi:rx="18.305565" + sodipodi:ry="18.305565" + d="M 106.69529 698.28027 A 18.305565 18.305565 0 1 1 70.08416,698.28027 A 18.305565 18.305565 0 1 1 106.69529 698.28027 z" + transform="translate(-12.678637,-108.04585)" /> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.375" + id="rect1290" + width="69.96357" + height="45.246185" + x="-104.63519" + y="442.85843" + transform="scale(-1,1)" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 35.856494,468.67158 L 104.22415,468.67158" + id="path1299" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1" + d="M 72.42524,442.43748 L 71.630267,487.35343" + id="path1300" + sodipodi:nodetypes="cc" /> + <rect + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2.375" + id="rect1301" + width="69.96357" + height="45.246185" + x="-104.44199" + y="443.04013" + transform="scale(-1,1)" /> + <rect + style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="rect1302" + width="8.9940901" + height="9.2751551" + x="67.378593" + y="464.05392" /> + <path + style="font-size:12px;fill:url(#linearGradient3113);fill-opacity:0.70196001;stroke:#1c66f9;stroke-width:1.92428339;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.98999999" + d="M 22.103543,213.06151 C 22.515516,211.86104 23.951291,210.66009 25.18228,210.84189 L 62.352593,218.87368 C 65.23151,216.34699 69.445869,213.27109 73.789889,214.04114 L 80.105558,214.91754 L 88.086596,216.48472 C 92.745746,217.88758 96.427736,220.80133 96.813826,226.5996 L 96.764886,296.45412 L 21.810414,272.56067 L 22.103543,213.06151 z " + id="path1266" + sodipodi:nodetypes="cccccccccc" /> + <path + style="font-size:12px;fill:#4789f7;stroke:#1c4ed9;stroke-width:1.71254337;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216003" + d="M 21.711614,272.26009 L 96.931496,296.4901 L 94.170566,301.54347 L 19.410269,275.82836 L 21.711614,272.26009 z " + id="path1271" + sodipodi:nodetypes="ccccc" /> + <g + id="g1279" + transform="matrix(0.68875,0,0,0.640474,28.305576,94.94412)"> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.91963024pt" + d="M 15.411826,279.67519 L 107.16635,280.32772 L 105.78092,271.91017 C 104.50888,267.9258 100.16017,263.55105 99.313146,259.07319 C 98.024176,254.59533 104.23642,257.47279 103.48688,250.11822 C 102.73733,242.76364 101.33093,223.23927 90.699786,212.93098 C 79.756146,202.93519 70.616996,196.51871 51.220346,199.6699 C 33.073696,201.57109 22.663616,210.23449 15.263856,225.51906 C 7.6727159,240.80363 16.076616,259.82218 15.837966,266.94924 L 15.411826,279.67519 z " + id="path1273" + sodipodi:nodetypes="ccczzzzzzc" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.0507082pt" + d="M 81.667436,238.6616 C 80.982416,243.3358 68.662856,240.88582 68.468226,248.58013 C 68.273596,255.77527 84.079546,257.18713 89.984786,255.06933 C 95.890036,252.95153 99.758996,249.65718 99.148096,242.36255 C 98.537216,235.06792 96.575586,216.71313 75.014876,206.18816 C 53.886116,196.16236 29.955336,209.82744 22.306536,224.42792 C 14.657726,239.5276 14.049476,254.81975 23.120686,249.32889 C 31.759936,244.33718 42.301146,228.60033 58.113846,226.78187 C 73.494556,224.9634 82.352426,234.98574 81.667436,238.6616 z " + id="path1274" + sodipodi:nodetypes="czzzzzzzz" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.08777227pt" + d="M 46.065436,250.14579 C 44.767756,248.03998 45.172386,240.05319 38.251386,241.60591 C 31.330386,243.15862 23.814016,250.5771 21.730276,253.25121 C 19.646536,255.92534 20.762826,260.66971 21.730276,261.79111 C 22.697736,262.91251 28.204756,263.51633 29.767576,264.89651 C 31.330386,266.2767 34.976936,271.4524 36.911836,271.10736 C 38.846746,270.76231 42.790986,266.62175 42.939816,264.89653 C 43.088656,263.17129 47.363086,252.25163 46.065436,250.14579 z " + id="path1275" + sodipodi:nodetypes="czzzzzzz" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.0507082pt" + d="M 42.237126,279.80001 C 42.658006,275.59866 47.388376,258.9441 48.153616,253.9108 C 48.918846,248.87751 46.010966,251.41496 47.235346,249.16869 C 48.459706,246.92241 52.591946,241.63956 55.499816,240.43322 C 58.407706,239.2269 62.539946,239.92518 64.682586,241.04832 C 66.825226,242.17146 68.164386,245.92409 68.355686,247.172 C 68.546986,248.41993 66.863496,249.83425 65.830426,249.41828 C 64.797366,249.0023 66.447386,242.49537 63.942946,244.49969 C 61.438506,246.68048 58.281376,250.37501 56.647666,251.91412 C 55.338616,253.45321 58.560756,252.66288 59.172936,253.9108 C 59.785116,255.15873 60.932956,257.2386 60.320776,259.40167 C 59.708576,261.56473 57.068536,265.51649 55.499816,266.8892 C 53.931086,268.26192 52.553686,265.59969 50.908446,267.63797 C 49.263196,269.67624 47.037236,278.02692 45.659806,279.98199 L 42.237126,279.80001 z " + id="path1276" + sodipodi:nodetypes="czzzzzzzzzzzzcc" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.875;stroke-dasharray:none" + d="M 41.081076,235.46675 C 41.510266,237.13987 42.851486,241.07668 43.817166,241.96244 C 44.782846,242.84822 46.848346,243.11067 47.197056,241.96244 C 47.545776,240.81421 45.212056,235.04026 51.059786,231.92364 C 57.068466,228.80702 66.457036,229.52876 69.407726,230.93945 C 72.358406,232.35012 77.320946,237.59917 72.626666,241.17509 C 68.737106,244.75098 78.179316,244.84941 80.191156,243.34031 C 82.202996,241.83121 85.125536,236.24432 82.523566,233.55418 C 79.921596,230.86405 73.325156,224.43697 67.209176,223.78085 C 61.093206,223.12471 46.472786,230.41454 44.460956,230.93945 C 42.288186,231.46435 40.651886,233.79361 41.081076,235.46675 z " + id="path1277" + sodipodi:nodetypes="czzzzzzzzzz" /> + </g> + <path + style="font-size:12px;fill:url(#linearGradient3103);fill-opacity:0.69930001;stroke:#1c66fb;stroke-width:1.77588487;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216003" + d="M 1.719906,228.8008 C 0.707007,226.11358 1.699602,223.54982 4.115707,223.82273 L 39.85944,231.42887 L 42.064202,239.17285 L 57.663221,242.80011 L 55.387499,234.64685 L 71.471519,237.40138 C 73.597665,238.09302 75.249092,239.52448 76.756518,242.80613 L 93.655366,300.89052 L 19.294782,275.68669 L 1.719906,228.8008 z " + id="path1272" + sodipodi:nodetypes="ccccccccccc" /> + <g + id="g1317" + transform="translate(-15.816734,-109.09188)"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.07708836" + d="M 472.42571,238.27147 C 472.33405,238.27145 472.24478,238.29291 472.15311,238.29398 L 472.15311,238.31648 C 472.08489,238.31034 472.01758,238.29395 471.94867,238.29398 C 471.78809,238.29403 471.63216,238.33557 471.47163,238.33899 L 471.47163,238.42899 C 471.37376,238.41606 471.27556,238.40652 471.17632,238.40649 C 471.1074,238.40647 471.0401,238.42285 470.97187,238.42899 L 470.97187,238.40649 C 470.88021,238.40543 470.79094,238.38396 470.69928,238.38399 C 465.87162,238.38545 461.03877,239.90805 457.81913,242.92943 C 456.20932,244.44011 446.99543,256.8992 450.09559,259.04098 C 457.81097,264.68512 464.49982,248.07035 457.3648,261.85375 C 456.64585,266.58811 456.46107,269.05668 456.41072,270.29207 C 456.30905,268.02898 455.46815,262.72102 451.04967,260.14359 C 447.35854,258.03472 444.93899,276.66261 444.93899,279.18042 C 444.93899,289.25168 451.37986,299.31925 457.81913,303.34776 C 461.08484,305.39084 466.00722,306.3715 470.90372,306.34054 L 470.90372,306.36305 C 471.15408,306.3651 471.40305,306.34374 471.65336,306.34054 L 471.65336,306.22803 C 471.84267,306.23528 472.03155,306.25211 472.22127,306.25053 L 472.22127,306.22803 C 477.11777,306.25899 482.04015,305.27835 485.30586,303.23524 C 491.74513,299.20674 498.186,289.13916 498.186,279.06791 C 498.186,276.5501 495.76645,257.9222 492.07532,260.03107 C 487.65684,262.60851 486.81594,267.91647 486.71427,270.17956 C 486.66392,268.94417 486.47914,266.47559 485.76018,261.74124 C 478.62517,247.95784 485.31402,264.5726 493.0294,258.92847 C 496.12956,256.78669 486.91567,244.32759 485.30586,242.81691 C 482.08622,239.79554 477.25337,238.27293 472.42571,238.27147 z " + id="path1267" + transform="matrix(1.033174,0,0,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.7041852pt" + d="M 468.24591,259.15861 C 468.51094,258.62567 467.79271,252.85171 466.69475,251.35949 C 465.59679,249.86726 463.96768,250.52503 463.70265,251.05797 C 463.43764,251.5909 465.07594,250.88137 466.17389,252.37359 C 467.27185,253.86581 467.9809,259.69155 468.24591,259.15861 z " + id="path1270" + sodipodi:nodetypes="czzzz" + transform="matrix(1.033174,0,0,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt" + d="M 463.34275,289.21648 C 461.03017,288.99344 460.56786,283.64967 458.96224,286.90958 C 457.28286,290.22776 460.74374,297.34319 461.0482,293.66548 C 461.2789,289.98777 465.58157,289.49777 463.34275,289.21648 z " + id="path1278" + sodipodi:nodetypes="czzz" + transform="matrix(1.033174,0,0,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.68256974pt" + d="M 708.64967,503.43717 C 708.37585,502.95253 709.11791,497.70179 710.25229,496.34479 C 711.38666,494.98778 713.06983,495.58594 713.34365,496.07058 C 713.61745,496.55524 711.9248,495.90999 710.79043,497.26699 C 709.65604,498.624 708.92347,503.92182 708.64967,503.43717 z " + id="path1283" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.57505898pt" + d="M 710.57739,531.81732 C 712.96669,531.61449 713.44433,526.75496 715.10322,529.71946 C 716.83831,532.73696 713.26262,539.20762 712.94806,535.86317 C 712.7097,532.51872 708.2643,532.07312 710.57739,531.81732 z " + id="path1284" + sodipodi:nodetypes="czzz" /> + </g> + <g + id="g1329" + transform="translate(-119.89693,-206.8959)"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.87184441" + d="M 841.03523,592.70109 C 835.90467,592.7639 830.22818,593.56676 826.67923,597.28291 C 823.87668,600.24935 817.50896,615.99836 816.60602,618.30168 C 815.09992,624.27793 814.05854,630.78886 816.99244,636.56898 C 819.81959,643.25189 825.72828,649.72836 833.94116,650.75621 C 839.37129,651.44267 845.09032,651.35874 850.31458,649.72833 C 856.42815,647.71665 860.44343,642.53509 863.07436,637.37323 C 865.55779,632.40703 865.94287,626.7432 864.51563,621.47197 C 863.89507,618.11627 856.12574,599.89965 853.80199,597.15457 C 850.54532,594.03086 845.67202,592.69881 841.03523,592.70109 z " + id="path1288" + sodipodi:nodetypes="cccccccccc" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.63460236pt" + d="M 838.07247,610.64237 C 839.95513,610.18459 838.75317,605.01626 837.71507,603.73449 C 836.67696,602.45272 829.77408,601.13926 832.78769,603.68422 C 836.03445,606.02046 835.95665,611.10014 838.07247,610.64237 z " + id="path1289" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.53464689pt" + d="M 835.74471,629.3768 C 833.5582,629.18522 829.82379,631.67928 828.30569,634.47943 C 826.71786,637.32962 829.99008,643.44151 830.27794,640.28249 C 830.49606,637.12348 837.86149,629.61842 835.74471,629.3768 z " + id="path1290" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.63460231pt" + d="M 842.27092,610.67154 C 840.38825,610.21376 841.59021,605.04542 842.62832,603.76366 C 843.66642,602.48189 850.5693,601.16843 847.5557,603.71338 C 844.30893,606.04963 844.38672,611.12931 842.27092,610.67154 z " + id="path1293" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.53464689pt" + d="M 844.89363,628.76239 C 847.08014,628.57081 850.81456,631.06487 852.33265,633.86502 C 853.92048,636.71521 850.64827,642.8271 850.3604,639.66808 C 850.14228,636.50907 842.77686,629.00401 844.89363,628.76239 z " + id="path1310" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + </g> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient704);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87644994;stroke-dasharray:none" + id="path1268" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(1.269231,0,0,1.209574,-283.07311,-892.5522)" /> + <path + style="font-size:12px;fill:url(#linearGradient3087);fill-opacity:0.38016998;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 61.332105,24.771938 C 42.107405,24.771938 25.653025,35.754928 18.178255,51.420348 C 24.096425,54.452298 30.701605,57.324498 38.485955,55.238068 C 53.103085,52.045758 57.672575,44.520268 64.981135,41.327978 C 80.301015,40.755428 87.638095,48.625568 102.74077,48.283028 C 94.643305,34.332978 79.234085,24.771948 61.332105,24.771938 z " + id="path1269" /> + <text + xml:space="preserve" + style="font-size:53.10573959px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:100%;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Arial Black" + x="16.672869" + y="102.03138" + id="text1284" + sodipodi:linespacing="100%" + transform="scale(1.1590137,0.8628026)"><tspan + x="16.672869" + y="102.03138" + sodipodi:role="line" + id="tspan1287">3D</tspan></text> + <path + transform="matrix(1.002448,0,0,1.002916,-160.88153,-16.03236)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path2785" + style="font-size:12px;fill:url(#radialGradient2803);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87644994;stroke-dasharray:none" + sodipodi:type="arc" /> + <g + id="g3768" + transform="matrix(0,1,-1,0,1076.3543,565.51512)"> + <path + sodipodi:nodetypes="cccsccsc" + id="path3705" + d="M 194.12568,840.84063 C 188.41896,847.02146 185.33319,854.75383 182.33294,863.19906 L 201.47506,868.27409 C 189.87912,850.75552 209.12233,847.41039 223.32691,857.48974 C 237.53151,867.56909 241.4625,879.07179 233.76248,898.27256 L 238.42629,908.56618 C 253.06732,892.90031 247.20739,863.37366 228.90023,852.45953 C 205.99771,838.8058 192.17055,859.34731 194.12568,840.84063 z " + style="fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:#ff0000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;display:inline" /> + <path + sodipodi:nodetypes="cccsccsc" + id="path3766" + d="M 223.43826,925.93726 C 229.14498,919.75643 232.23075,912.02406 235.231,903.57883 L 216.08888,898.5038 C 227.68482,916.02237 208.44161,919.3675 194.23703,909.28815 C 180.03243,899.2088 176.10144,887.7061 183.80146,868.50533 L 179.13765,858.21171 C 164.49662,873.87758 170.35655,903.40423 188.66371,914.31836 C 211.56623,927.97209 225.39339,907.43058 223.43826,925.93726 z " + style="fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:#ff0000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;display:inline" /> + </g> + <g + id="g3772" + transform="matrix(0,0.616295,-0.828342,0,1009.0693,633.18962)"> + <path + sodipodi:nodetypes="cccsccsc" + id="path3774" + d="M 194.12568,840.84063 C 188.41896,847.02146 185.33319,854.75383 182.33294,863.19906 L 201.47506,868.27409 C 189.87912,850.75552 209.12233,847.41039 223.32691,857.48974 C 237.53151,867.56909 241.4625,879.07179 233.76248,898.27256 L 238.42629,908.56618 C 253.06732,892.90031 247.20739,863.37366 228.90023,852.45953 C 205.99771,838.8058 192.17055,859.34731 194.12568,840.84063 z " + style="fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:#ff0000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;display:inline" /> + <path + sodipodi:nodetypes="cccsccsc" + id="path3776" + d="M 223.43826,925.93726 C 229.14498,919.75643 232.23075,912.02406 235.231,903.57883 L 216.08888,898.5038 C 227.68482,916.02237 208.44161,919.3675 194.23703,909.28815 C 180.03243,899.2088 176.10144,887.7061 183.80146,868.50533 L 179.13765,858.21171 C 164.49662,873.87758 170.35655,903.40423 188.66371,914.31836 C 211.56623,927.97209 225.39339,907.43058 223.43826,925.93726 z " + style="fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:#ff0000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;display:inline" /> + </g> + <path + style="fill:url(#linearGradient4441);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 417.63823,503.43887 C 418.93809,498.49321 401.59543,483.35417 398.57534,480.66632 C 395.46997,477.90258 384.35781,464.40329 381.52358,466.5834 C 378.58446,468.84421 384.30056,470.67943 386.30587,471.58949 C 388.31117,472.49955 396.55321,481.98821 401.26761,486.50842 C 406.07073,491.11369 414.05679,499.07672 417.63823,503.43887 z " + id="path4436" + sodipodi:nodetypes="czzzzc" /> + <g + id="g2679" + transform="translate(127.72341,250.99136)"> + <path + transform="matrix(1.269231,0,0,1.209574,-396.41645,-273.48229)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path6385" + style="font-size:12px;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#9999ff;stroke-width:1.875;stroke-dasharray:none;stroke-opacity:1" + sodipodi:type="arc" /> + <path + id="path6387" + d="M -39.445387,646.81506 L -39.445387,679.12754 L -63.481447,679.12754 L -63.481447,668.7547 C -63.481447,668.7547 -63.462347,668.72431 -87.874467,689.08992 L -63.997067,708.26846 L -63.997067,698.67919 L -39.445387,698.67919 L -39.445387,731.96178 C -19.935277,726.40164 -5.6521274,709.51231 -5.6521174,689.35111 C -5.6521074,669.19381 -19.941107,652.37858 -39.445387,646.81506 z " + style="font-size:12px;fill:url(#linearGradient6399);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-opacity:1" /> + <path + id="path6389" + d="M -52.60387,643.06675 C -71.82857,643.06675 -88.28295,654.04974 -95.75772,669.71516 C -89.83955,672.74711 -83.23437,675.61931 -75.45002,673.53288 C -60.83289,670.34057 -56.2634,662.81508 -48.95484,659.62279 C -33.63496,659.05024 -26.29788,666.92038 -11.19521,666.57784 C -19.29267,652.62779 -34.70189,643.06676 -52.60387,643.06675 z " + style="font-size:12px;fill:url(#linearGradient6401);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,3.7103497e-3,1.209574,-398.23172,-273.72923)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path6391" + style="font-size:12px;fill:url(#radialGradient6403);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none;stroke-opacity:1" + sodipodi:type="arc" /> + </g> + <flowRoot + xml:space="preserve" + id="flowRoot11253" + transform="matrix(2.6418545,0,0,2.7544595,1761.6523,94.933864)"><flowRegion + id="flowRegion11255"><rect + id="rect11257" + width="358.03708" + height="133.35794" + x="-489.9455" + y="234.82002" /></flowRegion><flowPara + id="flowPara11259">153 153 255</flowPara></flowRoot> <path + style="fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:#e80000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 279.19648,907.10288 C 273.31714,906.18832 254.20929,903.57528 250.19174,907.23353 C 246.5112,910.58491 242.70536,923.39061 246.66413,928.26851 C 249.47779,931.73543 254.82989,928.6278 267.82976,932.31872 C 280.82963,936.00964 287.11749,943.54535 298.66362,943.03218 C 307.48263,942.64023 308.06808,940.90589 310.29166,937.67545 C 312.40306,934.60797 310.81821,929.18158 310.42231,928.13786 C 308.98513,924.34895 302.44264,917.85122 297.87971,914.55004 C 293.19098,911.15785 282.07083,907.23354 279.19648,907.10288 z " + id="path2678" + sodipodi:nodetypes="czszssssc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#0000ff;fill-opacity:1;fill-rule:evenodd;stroke:#e80000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 287.7957,882.82029 C 282.34097,888.30767 274.27322,923.4204 287.27309,927.11132 C 300.27296,930.80224 314.92255,930.76014 327.51389,932.86001 C 336.22135,934.31216 340.73969,924.10168 340.97106,920.18677 C 341.38398,913.19973 339.0792,901.48386 326.86063,890.92071 C 314.52634,880.25752 293.38107,877.20226 287.7957,882.82029 z " + id="path2680" + sodipodi:nodetypes="czsszz" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#00ff00;fill-opacity:1;fill-rule:evenodd;stroke:#e80000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 264.58065,887.18507 C 258.37906,892.56924 241.86857,906.00903 252.69131,914.75265 C 263.43519,923.43255 273.41622,925.32602 286.00756,927.42589 C 294.71502,928.87804 309.20089,895.65779 296.98232,885.09464 C 284.64803,874.43145 270.7074,881.86587 264.58065,887.18507 z " + id="path2682" + sodipodi:nodetypes="czszz" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#00ffff;fill-opacity:1;fill-rule:evenodd;stroke:#e80000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 290.92757,880.99004 C 289.79075,881.42333 288.84449,882.00654 288.14632,882.70879 C 282.69159,888.1962 274.6152,923.29912 287.61507,926.99004 C 287.79114,927.04003 287.96966,927.09766 288.14632,927.14629 C 296.8599,924.47318 308.74865,894.82709 297.33382,884.95879 C 295.23315,883.14273 293.07489,881.85608 290.92757,880.99004 z " + id="path2684" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#ffff00;fill-opacity:1;fill-rule:evenodd;stroke:#ffff00;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 259.64577,905.56358 C 255.38842,905.5919 251.77735,906.06674 250.27077,907.43858 C 249.91517,907.76238 249.52784,908.20395 249.17702,908.68858 C 249.1777,908.69901 249.1763,908.70941 249.17702,908.71983 C 249.33048,910.93718 250.38312,913.06611 252.73952,914.96983 C 263.48339,923.64972 273.49193,925.52621 286.08327,927.62608 C 289.84207,928.25294 294.65885,922.43464 297.95827,914.75108 C 293.26951,911.35891 282.14512,907.44424 279.27077,907.31358 C 275.59618,906.74198 266.74136,905.51637 259.64577,905.56358 z " + id="path2686" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#ff00ff;fill-opacity:1;fill-rule:evenodd;stroke:#e80000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 280.82099,907.53045 C 280.06054,916.85265 281.46695,925.60102 287.60224,927.34295 C 295.24836,929.51385 303.44418,930.37199 311.47724,931.15545 C 311.25105,929.83044 310.91163,928.77791 310.75849,928.3742 C 309.3213,924.58531 302.79017,918.08163 298.22724,914.78045 C 294.06816,911.77148 284.85701,908.35766 280.82099,907.53045 z " + id="path2688" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#ffff00;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 280.77068,907.60226 C 280.00332,916.86703 281.43457,925.5553 287.66599,927.28675 C 287.78134,927.3188 287.89992,927.34855 288.01552,927.38004 C 291.46668,926.29971 295.38858,921.19722 298.21548,914.7546 C 294.07186,911.82087 284.99704,908.50815 280.77068,907.60226 z " + id="path2690" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#fffcff;fill-opacity:0.76973683;fill-rule:evenodd;stroke:#e80000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter3825)" + d="M 264.58065,887.18507 C 258.37906,892.56924 241.86857,906.00903 252.69131,914.75265 C 258.06325,919.0926 259.85685,909.80969 258.75146,904.08527 C 258.17203,901.08461 279.46815,887.45077 280.8547,887.17526 C 289.36706,885.48382 309.20089,895.07445 296.98232,884.5113 C 284.64803,873.84811 270.7074,881.86587 264.58065,887.18507 z " + id="path2692" + sodipodi:nodetypes="czsszz" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#f0fcff;fill-opacity:1;fill-rule:evenodd;stroke:#e80000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter4043);opacity:0.46111111" + d="M 287.7957,882.82029 C 282.34097,888.30767 290.70403,885.01703 303.7039,888.70795 C 310.20384,890.55341 329.34209,902.71925 332.09568,913.03342 C 334.84928,923.34759 321.21822,931.81007 327.51389,932.86001 C 336.22135,934.31216 339.76745,924.1989 339.99882,920.28399 C 340.41174,913.29695 338.88475,902.16443 326.66618,891.60128 C 314.33189,880.93809 293.38107,877.20226 287.7957,882.82029 z " + id="path3829" + sodipodi:nodetypes="czssszz" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <path + style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#e80000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter3995);opacity:0.46666667" + d="M 279.19648,907.10288 C 273.31714,906.18832 254.20929,903.57528 250.19174,907.23353 C 246.5112,910.58491 246.55517,919.05709 251.0392,914.65718 C 254.14453,911.61011 297.80278,918.61376 300.78861,921.91578 C 303.86342,925.31622 308.06808,940.90589 310.29166,937.67545 C 312.40306,934.60797 310.81821,929.18158 310.42231,928.13786 C 308.98513,924.34895 302.44264,917.85122 297.87971,914.55004 C 293.19098,911.15785 282.07083,907.23354 279.19648,907.10288 z " + id="path3857" + sodipodi:nodetypes="czszsssc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="45.143608" + inkscape:export-ydpi="45.143608" /> + <g + id="g2692" + transform="translate(674.26081,392.08118)"> + <path + sodipodi:nodetypes="cccccczcc" + id="rect16944" + d="M -101.23452,555.91137 L -135.72917,591.54155 L -135.67885,595.00168 C -135.67885,595.00168 -135.69605,596.90777 -134.07752,596.90776 L -63.022358,596.90776 C -61.344963,596.90776 -59.052197,595.93775 -57.904377,594.72045 C -57.904377,594.72045 -26.337149,560.6591 -25.935153,559.8182 C -25.515851,558.94109 -25.61801,554.93919 -25.61801,554.93919 L -101.23452,555.91137 z " + style="fill:#cccccc;fill-opacity:1;stroke:#000000;stroke-width:1.58905315;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:14;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <g + transform="matrix(1,0,-0.7279374,0.7757272,410.51129,124.1268)" + id="g16937"> + <rect + rx="2.2872064" + style="opacity:1;fill:#cccccc;fill-opacity:1;stroke:#000000;stroke-width:1.79999995;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:14;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" + id="rect16931" + width="76.767708" + height="48.723415" + x="-108.35294" + y="554.36353" + ry="2.8327568" /> + <rect + style="opacity:1;fill:#666666;fill-opacity:1;stroke:none;stroke-width:0.98140889;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:14;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" + id="rect16933" + width="63.422516" + height="22.064268" + x="-101.68034" + y="557.35358" + ry="1.2828063" /> + <rect + style="opacity:1;fill:#999999;fill-opacity:1;stroke:none;stroke-width:0.98140889;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:14;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" + id="rect16935" + width="19.798063" + height="15.832203" + x="-79.868118" + y="583.83984" + ry="0.92047691" /> + </g> + <rect + transform="matrix(1,0,-0.1383274,0.9903866,0,0)" + ry="2.8602536" + y="510.54825" + x="-26.254177" + height="49.196362" + width="76.767708" + id="rect16919" + style="fill:#cccccc;fill-opacity:1;stroke:#000000;stroke-width:1.80871499;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:14;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <rect + transform="matrix(1,0,-0.1383274,0.9903866,0,0)" + y="514.40961" + x="-20.871944" + height="41.473679" + width="66.003235" + id="rect16921" + style="fill:url(#linearGradient2702);fill-opacity:1;stroke:none;stroke-width:2.90499997;stroke-linecap:square;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <path + id="path16956" + d="M -92.277435,594.51054 L -64.16994,594.51054" + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + </g> + <g + id="g2685" + transform="translate(582.18114,338.61556)"> + <rect + transform="matrix(0.9713022,0.2378487,-0.5171396,0.855901,0,0)" + y="508.92459" + x="94.426369" + height="60.465881" + width="77.145607" + id="rect2697" + style="opacity:1;fill:#9999ff;fill-opacity:1;stroke:#000000;stroke-width:7.98921967;stroke-linecap:square;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <path + sodipodi:nodetypes="cccccccccc" + d="M -117.44468,481.34737 C -116.8448,484.69863 -133.55429,489.06659 -134.22773,490.99385 C -135.61163,493.12351 -124.78314,498.17939 -127.71818,500.70189 C -129.5925,504.50435 -158.49967,506.43937 -165.22499,505.25897 C -166.06446,504.57579 -166.21006,503.01216 -164.67268,502.07743 C -160.5694,500.45465 -140.39449,501.84269 -133.73254,499.40077 C -133.14809,498.3747 -140.78872,493.21278 -138.4452,490.4823 C -135.98802,487.11788 -120.9359,483.60551 -121.16622,481.62624 C -123.3344,479.39272 -140.13087,475.87842 -142.12303,473.95 C -142.12303,473.95 -120.27517,478.54207 -117.44468,481.34737 z " + id="path4659" + style="fill:#ff0000;fill-opacity:1;fill-rule:nonzero;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3996)" /> + <rect + transform="matrix(0.9713022,0.2378487,-0.5171396,0.855901,-1.485156,0)" + y="508.17789" + x="94.419182" + height="60.465874" + width="77.145607" + id="rect2920" + style="opacity:0.90659335;fill:none;fill-opacity:1;stroke:#ffffff;stroke-width:1.43310034;stroke-linecap:square;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;filter:url(#filter3943)" /> + <path + sodipodi:nodetypes="czzzzc" + id="path4643" + d="M -146.10287,435.77043 C -150.13633,433.93962 -160.81303,460.49087 -163.95326,471.903 C -167.02949,483.08255 -166.36953,503.35123 -164.3485,503.49605 C -162.07868,503.6587 -158.59997,498.57336 -157.34041,493.95863 C -156.09656,489.40146 -151.23529,478.15716 -150.04903,469.04377 C -149.17527,459.93038 -143.83082,437.24117 -146.10287,435.77043 z " + style="fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + <path + sodipodi:nodetypes="czzzzc" + id="path4645" + d="M -158.59661,464.49301 C -159.99659,468.59609 -161.62828,471.41835 -162.79655,476.80223 C -163.96481,482.3724 -165.63291,496.14896 -164.72285,498.41272 C -163.81278,500.67648 -162.48409,499.18142 -161.57403,497.17611 C -160.66397,495.17081 -161.12497,484.96734 -160.83782,480.52595 C -160.62631,476.08455 -159.0754,471.78897 -158.59661,464.49301 z " + style="fill:url(#linearGradient4653);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" /> + </g> + </g> +</svg> diff --git a/btn/dti.svg b/btn/dti.svg new file mode 100755 index 0000000..5b66740 --- /dev/null +++ b/btn/dti.svg @@ -0,0 +1,3228 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:xlink="http://www.w3.org/1999/xlink" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + id="svg1141" + sodipodi:version="0.32" + inkscape:version="0.46" + width="210mm" + height="297mm" + sodipodi:docname="dti.svg" + sodipodi:docbase="C:\Documents and Settings\Chris Rorden\Desktop" + inkscape:output_extension="org.inkscape.output.svg.inkscape"> + <metadata + id="metadata413"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + </cc:Work> + </rdf:RDF> + </metadata> + <defs + id="defs1143"> + <inkscape:perspective + sodipodi:type="inkscape:persp3d" + inkscape:vp_x="0 : 526.18109 : 1" + inkscape:vp_y="0 : 1000 : 0" + inkscape:vp_z="744.09448 : 526.18109 : 1" + inkscape:persp3d-origin="372.04724 : 350.78739 : 1" + id="perspective448" /> + <linearGradient + id="linearGradient1280"> + <stop + style="stop-color:#ffc000;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1281" /> + <stop + style="stop-color:#ff0000;stop-opacity:0.50000000;" + offset="1.0000000" + id="stop1283" /> + </linearGradient> + <linearGradient + id="linearGradient1271"> + <stop + style="stop-color:#ffc87e;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1274" /> + <stop + style="stop-color:#ff0000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1279" /> + </linearGradient> + <linearGradient + id="linearGradient1270"> + <stop + style="stop-color:#ffc000;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1271" /> + <stop + style="stop-color:#e84a50;stop-opacity:1.0000000;" + offset="0.50000000" + id="stop1273" /> + <stop + style="stop-color:#ff0000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1272" /> + </linearGradient> + <linearGradient + id="linearGradient1608"> + <stop + style="stop-color:#ffffff;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1609" /> + <stop + style="stop-color:#9999ff;stop-opacity:1.0000000;" + offset="0.50000000" + id="stop1611" /> + <stop + style="stop-color:#000000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1610" /> + </linearGradient> + <linearGradient + id="linearGradient1563"> + <stop + style="stop-color:#898bdc;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1564" /> + <stop + style="stop-color:#000000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1565" /> + </linearGradient> + <linearGradient + id="linearGradient1547"> + <stop + style="stop-color:#9999ff;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1548" /> + <stop + style="stop-color:#9999fd;stop-opacity:0.00000000;" + offset="1.0000000" + id="stop1549" /> + </linearGradient> + <linearGradient + id="linearGradient1391"> + <stop + style="stop-color:#ffc000;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1392" /> + <stop + style="stop-color:#ff0000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1394" /> + </linearGradient> + <linearGradient + id="linearGradient1111"> + <stop + style="stop-color:#e8e838;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1112" /> + <stop + style="stop-color:#ffff7f;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1114" /> + </linearGradient> + <linearGradient + id="linearGradient1274"> + <stop + style="stop-color:#ff0400;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1275" /> + <stop + style="stop-color:#fd6972;stop-opacity:1.0000000;" + offset="0.0099999998" + id="stop1277" /> + <stop + style="stop-color:#ff0000;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1276" /> + </linearGradient> + <linearGradient + id="linearGradient1205"> + <stop + style="stop-color:#ffffff;stop-opacity:0.9;" + offset="0.00000000" + id="stop1206" /> + <stop + style="stop-color:#ffffff;stop-opacity:0;" + offset="1.00000000" + id="stop1207" /> + </linearGradient> + <linearGradient + id="linearGradient1172"> + <stop + style="stop-color:#ffffff;stop-opacity:0.3;" + offset="0.00000000" + id="stop1173" /> + <stop + style="stop-color:#ffffff;stop-opacity:0.8;" + offset="1.00000000" + id="stop1174" /> + </linearGradient> + <linearGradient + id="linearGradient969"> + <stop + style="stop-color:#ffffff;stop-opacity:0.70196080;" + offset="0.00000000" + id="stop970" /> + <stop + style="stop-color:#9999ff;stop-opacity:0.70196080;" + offset="1.0000000" + id="stop971" /> + </linearGradient> + <linearGradient + id="linearGradient684"> + <stop + style="stop-color:#ffffff;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop685" /> + <stop + style="stop-color:#9999ff;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop686" /> + </linearGradient> + <linearGradient + id="linearGradient671"> + <stop + style="stop-color:#ffffff;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop672" /> + <stop + style="stop-color:#ffffff;stop-opacity:0.00000000;" + offset="1.0000000" + id="stop673" /> + </linearGradient> + <linearGradient + id="linearGradient594"> + <stop + style="stop-color:#fffbfb;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop595" /> + <stop + style="stop-color:#0000c0;stop-opacity:1;" + offset="1" + id="stop596" /> + </linearGradient> + <linearGradient + id="linearGradient1155"> + <stop + style="stop-color:#fffbfb;stop-opacity:1.0000000;" + offset="0.00000000" + id="stop1156" /> + <stop + style="stop-color:#9999ff;stop-opacity:1.0000000;" + offset="1.0000000" + id="stop1157" /> + </linearGradient> + <radialGradient + xlink:href="#linearGradient1155" + id="radialGradient1158" + cx="0.21874997" + cy="0.23437454" + r="0.70745194" + fx="0.21874997" + fy="0.23437454" /> + <radialGradient + xlink:href="#linearGradient684" + id="radialGradient1169" + cx="0.77941167" + cy="0.65624988" + r="0.32758817" + fx="0.77941167" + fy="0.65624988" /> + <linearGradient + xlink:href="#linearGradient1155" + id="linearGradient1170" + x1="0.81756759" + y1="0.35156253" + x2="0.17567571" + y2="0.75000000" /> + <linearGradient + xlink:href="#linearGradient594" + id="linearGradient588" + x1="321.4625" + y1="541.3602" + x2="354.41388" + y2="556.75934" + gradientTransform="scale(0.8041446,1.2435574)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient1547" + id="linearGradient639" + x1="0.47535211" + y1="-0.11428571" + x2="0.58802819" + y2="0.96190476" /> + <linearGradient + xlink:href="#linearGradient1155" + id="linearGradient643" + x1="0.20312500" + y1="0.10687023" + x2="0.50000000" + y2="0.88549620" /> + <linearGradient + xlink:href="#linearGradient1563" + id="linearGradient670" + x1="0.15079366" + y1="0.11450382" + x2="0.71428573" + y2="0.42748091" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient683" + x1="0.39084506" + y1="-0.06603774" + x2="0.59859157" + y2="0.94339621" /> + <linearGradient + xlink:href="#linearGradient1608" + id="linearGradient701" + x1="0.0035211267" + y1="0.42574257" + x2="0.98591548" + y2="0.42574257" /> + <linearGradient + xlink:href="#linearGradient671" + id="linearGradient703" + x1="0.45070422" + y1="-0.93750000" + x2="0.44366196" + y2="1.21875000" /> + <radialGradient + xlink:href="#linearGradient1271" + id="radialGradient704" + cx="292.27442" + cy="807.81573" + r="24.522423" + fx="292.27442" + fy="807.81573" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient969" + id="linearGradient967" + x1="0.39297354" + y1="0.06249970" + x2="0.46580359" + y2="0.96093768" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient968" + x1="0.08771923" + y1="0.02343778" + x2="0.55263156" + y2="1.32031250" /> + <linearGradient + xlink:href="#linearGradient671" + id="linearGradient1138" + x1="0.50000000" + y1="0.05468750" + x2="0.71717173" + y2="1.70312500" /> + <linearGradient + xlink:href="#linearGradient671" + id="linearGradient1139" + x1="-0.45833334" + y1="0.19531250" + x2="1.12500000" + y2="0.71875000" /> + <radialGradient + xlink:href="#linearGradient969" + id="radialGradient1140" + cx="0.11029412" + cy="0.06250000" + r="1.26334059" + fx="0.11029412" + fy="0.06250000" /> + <linearGradient + xlink:href="#linearGradient1172" + id="linearGradient1175" + x1="0.91071421" + y1="0.53906387" + x2="0.46428558" + y2="0.77343899" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient1202" + x1="0.16197200" + y1="-0.11904722" + x2="0.32746491" + y2="1.99999797" /> + <radialGradient + xlink:href="#linearGradient684" + id="radialGradient1203" + cx="0.77941167" + cy="0.65624988" + r="0.32758817" + fx="0.77941167" + fy="0.65624988" /> + <radialGradient + xlink:href="#linearGradient1547" + id="radialGradient983" + cx="0.73913020" + cy="0.72519094" + r="0.22669560" + fx="0.73913020" + fy="0.72519094" /> + <radialGradient + xlink:href="#linearGradient1205" + id="radialGradient1066" + cx="0.76470590" + cy="0.76562488" + r="0.29453236" + fx="0.76470590" + fy="0.76562482" /> + <linearGradient + xlink:href="#linearGradient1274" + id="linearGradient1273" + x1="-0.019230817" + y1="-3.8570047e-008" + x2="0.51923072" + y2="0.87500006" /> + <linearGradient + xlink:href="#linearGradient1280" + id="linearGradient1110" + x1="459.4994" + y1="1254.0935" + x2="481.37598" + y2="1325.9788" + gradientTransform="matrix(1.6468933,0,0,0.6072039,-185.20999,91.717409)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + xlink:href="#linearGradient1111" + id="linearGradient1118" + x1="0.53521127" + y1="1.0151515" + x2="0.52816904" + y2="0.015151516" /> + <radialGradient + xlink:href="#linearGradient1391" + id="radialGradient1395" + cx="0.69533569" + cy="0.78121674" + r="0.68209499" + fx="0.69533557" + fy="0.76559359" /> + <radialGradient + xlink:href="#linearGradient1547" + id="radialGradient1442" + cx="291.17355" + cy="815.41846" + r="18.939451" + fx="290.62314" + fy="814.83362" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient1604" + x1="0.52343750" + y1="0.0076335878" + x2="1.0312500" + y2="1.1297710" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient1617" + x1="0.10920641" + y1="-0.40239441" + x2="1.2083132" + y2="1.9653628" /> + <linearGradient + xlink:href="#linearGradient684" + id="linearGradient1618" + x1="0.42672610" + y1="-0.31047121" + x2="1.0007051" + y2="2.1198800" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient3181" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient3271" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" + gradientTransform="matrix(1.646893,0,0,0.607204,-404.3959,232.2467)" + gradientUnits="userSpaceOnUse" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient3289" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient4195" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.646893,0,0,0.607204,-404.3959,232.2467)" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient4197" + gradientUnits="userSpaceOnUse" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient4209" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.646893,0,0,0.607204,-404.3959,232.2467)" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient4211" + gradientUnits="userSpaceOnUse" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="linearGradient4223" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(1.646893,0,0,0.607204,-404.3959,232.2467)" + x1="299.8437" + y1="1036.9841" + x2="305.62924" + y2="1092.2429" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient1547" + id="radialGradient4225" + gradientUnits="userSpaceOnUse" + cx="289.25905" + cy="812.97649" + fx="289.25905" + fy="812.97649" + r="16.96986" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1172" + id="linearGradient3598" + x1="339.63678" + y1="379.11596" + x2="335.35134" + y2="381.36582" + gradientTransform="matrix(0.758349,0,0,1.3186542,-197.63622,-8.8758783)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3600" + x1="588.89265" + y1="195.07545" + x2="612.58524" + y2="202.90803" + gradientTransform="matrix(0.4268666,0,0,2.3426521,-197.63622,-8.8758783)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3627" + x1="833.72519" + y1="196.49355" + x2="857.41778" + y2="204.32614" + gradientTransform="matrix(0.4268666,0,0,2.3426521,-108.85068,2.4284606)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1172" + id="linearGradient3629" + x1="477.45044" + y1="381.63529" + x2="473.165" + y2="383.88514" + gradientTransform="matrix(0.758349,0,0,1.3186542,-108.85068,2.4284606)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1608" + id="linearGradient3646" + x1="-196.8662" + y1="425.48517" + x2="-141.23934" + y2="425.48517" + gradientTransform="matrix(1.677741,0,0,0.5960396,144.06957,-177.72971)" + gradientUnits="userSpaceOnUse" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient684" + id="linearGradient3670" + x1="326.75421" + y1="743.24066" + x2="335.31547" + y2="852.86278" + gradientTransform="scale(1.7571663,0.5690981)" + gradientUnits="userSpaceOnUse" /> + <radialGradient + inkscape:collect="always" + xlink:href="#linearGradient969" + id="radialGradient3672" + cx="524.70152" + cy="475.22645" + fx="524.70152" + fy="475.22645" + r="111.10576" + gradientTransform="matrix(1.075993,0,0,0.9293741,-172.89681,-540.25849)" + gradientUnits="userSpaceOnUse" /> + <inkscape:perspective + id="perspective2865" + inkscape:persp3d-origin="372.04724 : 350.78739 : 1" + inkscape:vp_z="744.09448 : 526.18109 : 1" + inkscape:vp_y="0 : 1000 : 0" + inkscape:vp_x="0 : 526.18109 : 1" + sodipodi:type="inkscape:persp3d" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient671" + id="linearGradient3657" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.4268666,0,0,2.3426521,490.80166,-298.10221)" + x1="833.72519" + y1="196.49355" + x2="857.41778" + y2="204.32614" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient1172" + id="linearGradient3659" + gradientUnits="userSpaceOnUse" + gradientTransform="matrix(0.758349,0,0,1.3186542,490.80166,-298.10221)" + x1="477.45044" + y1="381.63529" + x2="473.165" + y2="383.88514" /> + </defs> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#666666" + borderopacity="1.0" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="1.6899736" + inkscape:cx="259.81914" + inkscape:cy="210.13786" + inkscape:window-width="1096" + inkscape:window-height="885" + inkscape:window-x="2" + inkscape:window-y="-2" + showgrid="true" + snaptogrid="false" + showguides="true" + snaptoguides="true" + inkscape:current-layer="svg1141" + inkscape:snap-global="false" + gridtolerance="23"> + <inkscape:grid + type="xygrid" + id="grid3676" + visible="true" + enabled="true" /> + </sodipodi:namedview> + <rect + style="fill:#cccccc;fill-rule:evenodd;stroke:#000000;stroke-width:2.26807213pt" + id="rect1183" + width="802.11261" + height="680.2215" + x="-643.42822" + y="163.21796" /> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;" + id="rect1295" + width="69.963570" + height="45.246185" + x="-101.75949" + y="509.82691" + transform="scale(-1.000000,1.000000)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;fill-opacity:1.0000000;" + id="rect1262" + width="69.963570" + height="45.246185" + x="128.72227" + y="535.48883" + transform="translate(-91.26626,99.11160)" /> + <path + sodipodi:type="arc" + style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:1.0000000pt;" + id="path1286" + sodipodi:cx="88.389725" + sodipodi:cy="698.28027" + sodipodi:rx="18.305565" + sodipodi:ry="18.305565" + d="M 106.69529 698.28027 A 18.305565 18.305565 0 1 0 70.084160,698.28027 A 18.305565 18.305565 0 1 0 106.69529 698.28027 z" + transform="translate(-17.25953,-39.22624)" /> + <path + sodipodi:type="arc" + style="fill-rule:evenodd;stroke-width:1.0000000pt;" + id="path1573" + sodipodi:cx="496.47308" + sodipodi:cy="894.01904" + sodipodi:rx="26.543070" + sodipodi:ry="26.543070" + d="M 523.01615 894.01904 A 26.543070 26.543070 0 1 0 469.93001,894.01904 A 26.543070 26.543070 0 1 0 523.01615 894.01904 z" + transform="translate(185.5400,-212.9984)" /> + <path + sodipodi:type="arc" + style="fill:url(#radialGradient1395);fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000pt;" + id="path1343" + sodipodi:cx="715.48608" + sodipodi:cy="436.77219" + sodipodi:rx="38.180180" + sodipodi:ry="38.180180" + d="M 753.66626 436.77219 A 38.180180 38.180180 0 1 0 677.30590,436.77219 A 38.180180 38.180180 0 1 0 753.66626 436.77219 z" + transform="matrix(0.905654,0.000000,0.000000,0.919132,149.4257,12.54474)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0375195;" + d="M 704.48491,415.34092 C 694.57329,417.80874 687.95315,428.45052 684.92534,434.86193 C 681.89753,441.01182 677.92934,447.28914 688.65031,452.73194 C 698.87767,454.00139 705.70466,453.64762 711.13899,450.11964 C 718.44814,445.58571 724.25946,439.88285 726.48955,434.60790 C 727.94598,431.77023 741.08206,432.37026 740.21539,430.37826 C 740.33314,426.85776 739.63744,419.26753 731.65870,414.99087 C 727.35252,412.29016 710.27910,412.15675 704.48491,415.34092 z " + id="path1377" + sodipodi:nodetypes="czcccccc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 175.16419,313.27629 C 170.59785,312.81843 161.53978,318.62958 157.57044,321.02629 C 146.72186,327.57680 135.88296,343.93132 135.88294,360.30754 C 135.88294,364.40161 132.43921,368.00533 137.35169,380.80754 C 143.39531,391.81829 170.06959,395.25262 170.28919,388.46379 C 170.50878,381.67497 166.19786,385.04854 171.50794,379.87004 C 171.67000,389.89820 175.12385,390.07619 174.97669,395.99504 C 174.88252,399.52179 174.69106,407.40659 176.03919,406.05754 L 177.97669,406.37004 L 177.97669,406.49504 L 178.35169,406.43254 L 180.28919,406.12004 C 181.63732,407.46909 181.44586,399.58428 181.35169,396.05754 C 181.20453,390.13869 184.65838,389.96069 184.82044,379.93254 C 190.13052,385.11104 185.81960,381.73746 186.03919,388.52629 C 186.25879,395.31512 212.93307,391.88078 218.97669,380.87004 C 223.88917,368.06783 220.44544,364.46410 220.44544,360.37004 C 220.44542,343.99382 209.60652,327.63929 198.75794,321.08879 C 194.78860,318.69208 185.73053,312.88092 181.16419,313.33879 C 179.64208,313.49141 178.61613,314.33756 178.44544,316.24504 L 177.64117,368.62731 L 177.88294,316.18254 C 177.71225,314.27507 176.68630,313.42891 175.16419,313.27629 z " + id="path1150" + sodipodi:nodetypes="ccccccccccccccccccccccc" /> + <path + style="fill:#ff0000;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:0.68412900pt;" + d="M 182.78509,493.16200 C 171.13638,496.94695 136.68072,486.89726 135.94501,503.73375 C 135.20931,520.57025 224.59784,516.52427 212.45865,506.21355 C 200.31947,495.90282 194.43381,489.37705 182.78509,493.16200 z " + id="path1140" + sodipodi:nodetypes="cczz" /> + <g + id="g1263" + transform="matrix(0.908672,-0.417511,0.685493,0.785541,-67.19158,231.4487)"> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.99068832pt;" + d="M 420.68026,157.78820 C 420.68026,143.66413 411.49144,115.33358 402.38342,106.84266 C 393.27539,98.351740 375.11992,98.368210 366.03210,106.84266 C 356.94426,115.31711 347.85643,143.56526 347.85643,157.68934 C 347.85643,171.81342 356.94426,185.93749 366.03210,191.58713 C 375.11992,197.23676 393.27539,197.22028 402.38342,191.58713 C 411.49144,185.95397 420.68026,171.91228 420.68026,157.78820 z " + id="path1235" + sodipodi:nodetypes="czzzzzz" + transform="matrix(0.937345,0.000000,-0.521597,0.915342,214.7080,20.05502)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 385.72466,104.99534 C 385.60653,104.99531 385.49150,105.02296 385.37337,105.02434 L 385.37337,105.05334 C 385.28545,105.04542 385.19871,105.02430 385.10991,105.02434 C 384.90297,105.02441 384.70203,105.07794 384.49516,105.08234 L 384.49516,105.19833 C 384.36904,105.18166 384.24249,105.16937 384.11460,105.16933 C 384.02579,105.16930 383.93906,105.19041 383.85113,105.19833 L 383.85113,105.16933 C 383.73301,105.16796 383.61798,105.14030 383.49985,105.14033 C 377.27858,105.14222 371.05063,107.10435 366.90157,110.99791 C 364.82705,112.94468 352.95338,129.00036 356.94846,131.76041 C 366.89106,139.03386 375.51079,117.62287 366.31609,135.38515 C 365.38960,141.48619 365.15147,144.66736 365.08659,146.25937 C 364.95557,143.34300 363.87193,136.50278 358.17796,133.18131 C 353.42130,130.46368 350.30330,154.46891 350.30330,157.71354 C 350.30330,170.69209 358.60347,183.66588 366.90157,188.85730 C 371.11000,191.49017 377.45333,192.75392 383.76331,192.71402 L 383.76331,192.74302 C 384.08594,192.74567 384.40678,192.71814 384.72935,192.71402 L 384.72935,192.56903 C 384.97331,192.57837 385.21671,192.60006 385.46120,192.59803 L 385.46120,192.56903 C 391.77118,192.60893 398.11451,191.34520 402.32294,188.71231 C 410.62104,183.52089 418.92121,170.54709 418.92121,157.56855 C 418.92121,154.32392 415.80320,130.31868 411.04655,133.03632 C 405.35258,136.35779 404.26894,143.19801 404.13792,146.11438 C 404.07304,144.52237 403.83491,141.34119 402.90841,135.24016 C 393.71372,117.47788 402.33345,138.88886 412.27605,131.61542 C 416.27113,128.85537 404.39746,112.79968 402.32294,110.85292 C 398.17388,106.95936 391.94593,104.99722 385.72466,104.99534 z " + id="path1236" + transform="matrix(0.937345,0.000000,-0.521597,0.915342,214.7080,20.05502)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 380.33827,131.91200 C 380.67980,131.22522 379.75424,123.78448 378.33933,121.86149 C 376.92442,119.93850 374.82503,120.78615 374.48350,121.47293 C 374.14198,122.15971 376.25321,121.24535 377.66811,123.16834 C 379.08302,125.09132 379.99675,132.59878 380.33827,131.91200 z " + id="path1237" + sodipodi:nodetypes="czzzz" + transform="matrix(0.937345,0.000000,-0.521597,0.915342,214.7080,20.05502)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt;" + d="M 374.01970,170.64672 C 371.03955,170.35930 370.44378,163.47294 368.37466,167.67389 C 366.21050,171.94993 370.67043,181.11939 371.06278,176.38002 C 371.36008,171.64067 376.90481,171.00921 374.01970,170.64672 z " + id="path1238" + sodipodi:nodetypes="czzz" + transform="matrix(0.937345,0.000000,-0.521597,0.915342,214.7080,20.05502)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 388.88624,131.76953 C 388.54471,131.08274 389.47027,123.64200 390.88518,121.71902 C 392.30008,119.79602 394.39948,120.64367 394.74101,121.33045 C 395.08253,122.01724 392.97130,121.10288 391.55640,123.02586 C 390.14149,124.94885 389.22776,132.45631 388.88624,131.76953 z " + id="path1239" + sodipodi:nodetypes="czzzz" + transform="matrix(0.937345,0.000000,-0.521597,0.915342,214.7080,20.05502)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt;" + d="M 395.20481,170.50425 C 398.18496,170.21683 398.78073,163.33046 400.84985,167.53142 C 403.01401,171.80746 398.55408,180.97692 398.16173,176.23755 C 397.86443,171.49819 392.31970,170.86674 395.20481,170.50425 z " + id="path1240" + sodipodi:nodetypes="czzz" + transform="matrix(0.937345,0.000000,-0.521597,0.915342,214.7080,20.05502)" /> + </g> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:1.2724125pt;" + d="M 496.61025,315.43263 C 487.70277,315.43523 472.41769,322.55172 466.47718,327.89823 C 454.59613,338.59121 447.94047,366.42388 447.94047,384.24553 C 447.94047,389.67769 447.95637,395.00686 448.18560,400.13622 L 542.84637,400.13622 C 543.08751,395.05165 543.13236,389.79833 543.13236,384.40325 C 543.13232,366.58163 539.47657,339.72728 527.56914,329.01351 C 521.61543,323.65662 505.51773,315.43003 496.61025,315.43263 z " + id="path1063" + sodipodi:nodetypes="cccccccc" /> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.91963024pt;" + d="M 342.97890,399.86026 L 434.73342,400.51279 L 433.34799,392.09524 C 432.07595,388.11087 427.72724,383.73612 426.88022,379.25826 C 425.59125,374.78040 431.80349,377.65786 431.05395,370.30329 C 430.30440,362.94871 428.89800,343.42434 418.26686,333.11605 C 407.32322,323.12026 398.18407,316.70378 378.78742,319.85497 C 360.64077,321.75616 350.23069,330.41956 342.83093,345.70413 C 335.23979,360.98870 343.64369,380.00725 343.40504,387.13431 L 342.97890,399.86026 z " + id="path1052" + sodipodi:nodetypes="ccczzzzzzc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.99068832pt;" + d="M 320.29479,372.55062 C 320.29479,358.42655 311.10597,330.09600 301.99795,321.60508 C 292.88992,313.11416 274.73445,313.13063 265.64663,321.60508 C 256.55879,330.07953 247.47096,358.32768 247.47096,372.45176 C 247.47096,386.57584 256.55879,400.69991 265.64663,406.34955 C 274.73445,411.99918 292.88992,411.98270 301.99795,406.34955 C 311.10597,400.71639 320.29479,386.67470 320.29479,372.55062 z " + id="path1005" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;fill-opacity:1.0000000;" + d="M 285.33919,319.75776 C 285.22106,319.75773 285.10603,319.78538 284.98790,319.78676 L 284.98790,319.81576 C 284.89998,319.80784 284.81324,319.78672 284.72444,319.78676 C 284.51750,319.78683 284.31656,319.84036 284.10969,319.84476 L 284.10969,319.96075 C 283.98357,319.94408 283.85702,319.93179 283.72913,319.93175 C 283.64032,319.93172 283.55359,319.95283 283.46566,319.96075 L 283.46566,319.93175 C 283.34754,319.93038 283.23251,319.90272 283.11438,319.90275 C 276.89311,319.90464 270.66516,321.86677 266.51610,325.76033 C 264.44158,327.70710 252.56791,343.76278 256.56299,346.52283 C 266.50559,353.79628 275.12532,332.38529 265.93062,350.14757 C 265.00413,356.24861 264.76600,359.42978 264.70112,361.02179 C 264.57010,358.10542 263.48646,351.26520 257.79249,347.94373 C 253.03583,345.22610 249.91783,369.23133 249.91783,372.47596 C 249.91783,385.45451 258.21800,398.42830 266.51610,403.61972 C 270.72453,406.25259 277.06786,407.51634 283.37784,407.47644 L 283.37784,407.50544 C 283.70047,407.50809 284.02131,407.48056 284.34388,407.47644 L 284.34388,407.33145 C 284.58784,407.34079 284.83124,407.36248 285.07573,407.36045 L 285.07573,407.33145 C 291.38571,407.37135 297.72904,406.10762 301.93747,403.47473 C 310.23557,398.28331 318.53574,385.30951 318.53574,372.33097 C 318.53574,369.08634 315.41773,345.08110 310.66108,347.79874 C 304.96711,351.12021 303.88347,357.96043 303.75245,360.87680 C 303.68757,359.28479 303.44944,356.10361 302.52294,350.00258 C 293.32825,332.24030 301.94798,353.65128 311.89058,346.37784 C 315.88566,343.61779 304.01199,327.56210 301.93747,325.61534 C 297.78841,321.72178 291.56046,319.75964 285.33919,319.75776 z " + id="path1044" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:#fffffd;fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.875;stroke-dasharray:none;" + id="path695" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,152.3260,-283.6191)" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#linearGradient1202);fill-opacity:0.75;fill-rule:evenodd;stroke:#0050fb;stroke-width:2.47293;stroke-dasharray:none;stroke-opacity:1;" + id="path1200" + sodipodi:cx="604.88873291" + sodipodi:cy="441.20190430" + sodipodi:rx="44.21426392" + sodipodi:ry="13.48378277" + d="M 649.102997 441.201904 A 44.214264 13.483783 0 1 0 560.674469,441.201904 A 44.2143 13.4838 0 1 0 649.103 441.202 L 604.888733 441.201904 z" + transform="matrix(1.042553,0.000000,0.000000,0.882208,-29.50271,47.34934)" + inkscape:export-filename="C:\pas\mricron\btn\path.png" + inkscape:export-xdpi="21.807127" + inkscape:export-ydpi="21.807127" /> + <path + style="font-size:12;fill-opacity:0.70196;stroke:#1c66f9;stroke-width:9.25243;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99;fill:url(#linearGradient968);" + d="M -49.21 243.091 C -46.9287 238.079 -38.9781 233.065 -32.1615 233.824 L 173.669 267.357 C 189.611 256.808 212.948 243.966 237.003 247.181 L 271.976 250.84 L 316.171 257.383 C 341.971 263.24 362.36 275.405 364.498 299.613 L 364.227 591.258 L -50.8332 491.502 L -49.21 243.091 z " + id="path10" + transform="matrix(0.180587,0.000000,0.000000,0.239519,475.9239,473.8713)" + sodipodi:nodetypes="cccccccccc" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.25;fill-rule:evenodd;stroke-width:0.0937284;stroke-opacity:0.53137;" + id="rect1408" + x="0.001633" + y="142.499995" + width="14.998365" + height="14.994604" + rx="0" + ry="0" + transform="matrix(15.78489,0.000000,0.000000,15.78489,215.6082,-1931.463)" /> + <rect + style="font-size:12;fill:none;fill-rule:evenodd;stroke-width:0.0520834;" + id="rect702" + width="25.000004" + height="24.999990" + x="24.999998" + y="219.999988" + transform="matrix(14.81984,0.000000,0.000000,14.99259,-23.10420,-2817.060)" /> + <path + style="font-size:12;fill:url(#linearGradient588);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:0.47847000000000001pt" + d="M 260,712.36218 C 260.6888,710.6402 290,637.36218 290,637.36218 L 318.17786,717.86525 C 318.17786,717.86525 305,722.36218 290,722.36218 C 270,722.36218 259.65561,712.36218 260,712.36218 z" + id="path593" + sodipodi:nodetypes="ccczc" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" + inkscape:export-xdpi="25.411764" + inkscape:export-ydpi="25.411764" /> + <polygon + sodipodi:type="star" + style="font-size:12;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="polygon597" + sodipodi:sides="6" + sodipodi:cx="240.40767073" + sodipodi:cy="577.30510872" + sodipodi:r1="15.40403841" + sodipodi:r2="7.70201920" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.17644541" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0.000000,0.000000,0.478471,170.7767,389.9823)" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" /> + <polygon + sodipodi:type="star" + style="font-size:12;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="polygon598" + sodipodi:sides="6" + sodipodi:cx="240.40767073" + sodipodi:cy="577.30510872" + sodipodi:r1="15.40403841" + sodipodi:r2="7.70201920" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.17644541" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0.000000,0.000000,0.478471,161.8224,423.0443)" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon599" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,180.82663,405.61557)" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon600" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,183.55602,422.73609)" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon601" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,166.77658,438.30666)" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <polygon + sodipodi:type="star" + style="font-size:12px;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt" + id="polygon602" + sodipodi:sides="6" + sodipodi:cx="240.40767" + sodipodi:cy="577.30511" + sodipodi:r1="15.404038" + sodipodi:r2="7.7020192" + sodipodi:arg1="0.65284663" + sodipodi:arg2="1.1764454" + points="252.644,586.662 243.367,584.416 238.422,592.581 235.729,583.423 226.186,583.223 232.77,576.312 228.171,567.948 237.448,570.194 242.393,562.03 245.086,571.187 254.629,571.387 248.045,578.298 252.644,586.662 " + transform="matrix(0.478471,0,0,0.478471,191.38779,434.54077)" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 252.64399,586.6623 L 243.36685,584.41597 L 238.42227,592.58067 L 235.72908,583.42327 L 226.18595,583.22349 L 232.76989,576.31241 L 228.17135,567.94793 L 237.44848,570.19426 L 242.39307,562.02956 L 245.08626,571.18696 L 254.62939,571.38674 L 248.04545,578.29781 L 252.64399,586.6623 z" /> + <path + style="font-size:12;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 274.11717,675.42762 C 272.59006,680.51787 272.50982,680.74799 270.97720,685.84931 L 272.11357,689.70698 L 274.49097,685.80445 L 278.91683,686.88101 L 276.71885,682.87382 L 279.87377,679.56938 L 275.31334,679.47966 L 274.11717,675.42762 z " + id="path605" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" /> + <path + style="font-size:12;fill:#ffff00;fill-opacity:0.75;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 292.16411,644.27745 L 290.93802,646.28105 L 286.49722,645.20449 L 288.69519,649.21168 L 285.55523,652.51612 L 290.11565,652.60584 L 291.40154,656.98683 L 293.77894,653.08431 L 295.40874,653.48802 L 292.16411,644.27745 z " + id="path608" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" + inkscape:export-filename="C:\pas\mricron\btn\new\magichat.png" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.875;stroke-dasharray:none;" + id="path651" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,-61.55729,-176.8490)" + inkscape:export-filename="C:\pas\mricron\btn\new\autocontrast.png" + inkscape:export-xdpi="22.289494" + inkscape:export-ydpi="22.289494" /> + <path + style="font-size:12;fill:url(#linearGradient670);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-opacity:1;" + d="M 295.69152,743.03173 L 295.69152,775.76582 L 271.65546,775.76582 L 271.65546,765.25764 C 271.65546,765.25764 271.67456,765.22685 247.26244,785.85819 L 271.13984,805.28697 L 271.13984,795.57258 L 295.69152,795.57258 L 295.69152,829.28944 C 315.20163,823.65675 329.48478,806.54705 329.48479,786.12279 C 329.48480,765.70248 315.19580,748.66784 295.69152,743.03173 z " + id="path669" + inkscape:export-filename="C:\pas\mricron\btn\new\autocontrast.png" + inkscape:export-xdpi="22.289494" + inkscape:export-ydpi="22.289494" /> + <path + style="font-size:12;fill:url(#linearGradient1170);fill-rule:evenodd;stroke:#000054;stroke-width:0.67086999999999997;stroke-linejoin:round;stroke-opacity:1" + d="M 37.736449,210.52722 C 39.360943,210.15769 40.548315,209.21204 41.638551,208.17037 C 42.631649,207.06469 43.624746,205.57494 43.986449,204.08519 L 35.819276,193.99093 L 26.486449,203.31704 L 37.736449,210.52722 z " + id="path709" + sodipodi:nodetypes="cccccc" + transform="matrix(4.130527,0.000000,0.000000,4.178675,143.9011,-279.6922)" + inkscape:export-filename="C:\pas\mricron\btn\new\bucket24x.png" + inkscape:export-xdpi="22.773436" + inkscape:export-ydpi="22.773436" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:#f5f9ff;fill-rule:evenodd;stroke:#000054;stroke-width:10.78609999999999900;stroke-opacity:1" + id="path587" + sodipodi:cx="220.25373840" + sodipodi:cy="529.07958984" + sodipodi:rx="44.62657547" + sodipodi:ry="78.45639801" + d="M 264.880314 529.079590 A 44.626575 78.456398 0 1 0 175.627163,529.079590 A 44.6266 78.4564 0 1 0 264.88 529.08 L 220.253738 529.079590 z" + transform="matrix(0.261130,0.000000,-0.220403,0.255703,330.6188,414.5732)" + inkscape:export-filename="C:\pas\mricron\btn\new\bucket24x.png" + inkscape:export-xdpi="22.773436" + inkscape:export-ydpi="22.773436" /> + <path + style="font-size:12;fill:#ff0000;fill-rule:evenodd;stroke-width:1pt;" + d="M 32.982608,203.39618 C 24.345244,202.82561 29.882675,210.68326 29.960475,211.32626 C 30.038375,211.96926 25.425954,213.06265 27.366549,215.37646 C 30.570035,217.69028 45.345484,218.46139 45.105684,214.83439 C 44.865884,211.20639 33.164810,212.24817 30.632114,211.28954 C 29.797246,209.02780 29.689118,205.41944 30.954356,204.34431 C 31.695306,203.86591 31.589790,205.17495 32.982608,203.39618 z " + id="path711" + transform="matrix(4.130527,0.000000,0.000000,4.178675,123.2485,-284.9157)" + sodipodi:nodetypes="cccccsc" + inkscape:export-filename="C:\pas\mricron\btn\new\bucket24x.png" + inkscape:export-xdpi="22.773436" + inkscape:export-ydpi="22.773436" /> + <path + style="font-size:12;fill:#ff0000;fill-rule:evenodd;stroke-width:10.7861;" + d="M 564.64487,498.84975 C 545.78432,498.84975 507.75654,526.26504 479.76987,560.03725 C 456.70600,587.86900 447.66587,611.34624 455.73862,618.75600 C 480.65758,610.79895 518.18623,582.81638 547.11362,549.25600 C 560.29785,533.96018 569.66613,519.82649 574.98862,508.16225 C 574.60172,502.30556 571.27296,498.84975 564.64487,498.84975 z " + id="path592" + transform="matrix(0.278716,0.000000,0.000000,0.278716,129.6880,395.7771)" + inkscape:export-filename="C:\pas\mricron\btn\new\bucket24x.png" + inkscape:export-xdpi="22.773436" + inkscape:export-ydpi="22.773436" /> + <rect + style="font-size:12.000000;fill:url(#linearGradient643);fill-opacity:1.0000000;fill-rule:evenodd;stroke:#000002;stroke-width:1.9439127;" + id="rect642" + width="71.981430" + height="73.806518" + x="355.56149" + y="751.56487" /> + <path + style="font-size:12.000000;fill-rule:evenodd;stroke:#000002;stroke-width:1.9439127;" + d="M 355.86912,768.41833 L 355.86912,825.08081 L 426.31248,825.08081 L 421.69830,821.88448 C 413.18767,816.07293 415.69984,808.37265 406.01003,809.09909 C 396.62784,809.24438 372.43926,821.89222 368.33775,814.53095 C 363.45690,807.88664 365.01940,752.99455 361.12114,759.56548 L 355.86912,768.41833 z " + id="path640" + sodipodi:nodetypes="cccczcsc" /> + <rect + style="font-size:12.000000;fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:4.1028190;" + id="rect615" + width="57.240670" + height="49.173893" + x="519.27698" + y="1042.7878" + transform="matrix(0.859371,-0.511353,0.000000,1.000000,0.000000,0.000000)" /> + <text + xml:space="preserve" + style="font-size:48.000000;font-weight:bold;fill:#000000;stroke-width:1.0000000pt;font-family:Verdana;fill-opacity:1.0000000;" + x="709.86213" + y="1342.1935" + id="text610" + sodipodi:linespacing="100%" + transform="matrix(0.632720,-0.387288,0.000000,0.813305,0.000000,0.000000)"><tspan + x="709.86212" + y="1342.1935" + sodipodi:role="line" + id="tspan613" + style="fill:#000000;fill-opacity:1.0000000;">LR</tspan></text> + <rect + style="font-size:12.000000;fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:4.1239262;" + id="rect627" + width="57.831149" + height="49.173893" + x="-632.70609" + y="457.02159" + transform="matrix(-0.862456,-0.506131,0.000000,1.000000,0.000000,0.000000)" /> + <text + xml:space="preserve" + style="font-size:48.000000;font-weight:bold;stroke-width:1.0000000pt;font-family:Verdana;" + x="-858.67939" + y="596.71201" + id="text628" + sodipodi:linespacing="100%" + transform="matrix(-0.632720,-0.387288,0.000000,0.813305,0.000000,0.000000)"><tspan + x="-858.67938" + y="596.71204" + sodipodi:role="line" + id="tspan629">LR</tspan></text> + <rect + style="font-size:12.000000;fill:url(#linearGradient1617);fill-rule:evenodd;stroke:#000000;stroke-width:0.77675028pt;" + id="rect648" + width="56.066268" + height="49.173893" + x="649.12604" + y="1116.5706" + transform="matrix(0.852907,-0.522062,0.000000,1.000000,0.000000,0.000000)" /> + <rect + style="font-size:12.000000;fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:0.77675028pt;" + id="rect649" + width="56.066268" + height="49.173893" + x="-761.52524" + y="380.12168" + transform="matrix(-0.852907,-0.522062,0.000000,1.000000,0.000000,0.000000)" /> + <path + style="font-size:12.000000;fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2.4003696;fill-opacity:1.0000000;stroke-opacity:1.0000000;" + d="M 586.02954,781.20391 C 576.62200,796.60958 567.62949,793.58791 569.22048,807.83469 C 571.77988,813.49422 577.86711,800.59504 591.84007,797.41464 C 597.37391,793.56282 600.31377,785.36998 593.29271,770.69383 C 584.81901,757.01251 564.65506,775.58222 560.50467,790.68280 C 556.35428,805.45774 563.75581,807.31272 569.01296,805.97641" + id="path646" + sodipodi:nodetypes="ccczzc" /> + <path + style="font-size:12.000000;fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:2.4003696;" + d="M 618.03676,782.42607 C 627.44430,797.83174 636.43680,794.81007 634.84582,809.05685 C 632.28642,814.71638 626.19918,801.81720 612.22623,798.63680 C 606.69238,794.78498 603.75252,786.59214 610.77359,771.91599 C 619.24729,758.23467 639.41124,776.80439 643.56163,791.90496 C 647.71201,806.67990 640.31049,808.53488 635.05334,807.19857" + id="path650" + sodipodi:nodetypes="ccczzc" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient1158);fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="path1411" + d="M 69.375000 165.000000 A 4.375000 4.375000 0 1 0 60.625000,165.000000 A 4.375 4.375 0 1 0 69.375 165 L 65.000000 165.000000 z" + sodipodi:cx="65.000000" + sodipodi:cy="165.000000" + sodipodi:rx="4.375000" + sodipodi:ry="4.375000" + transform="matrix(6.282797,0.000000,0.000000,6.282797,-36.58204,-479.7863)" /> + <path + style="font-size:12;fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:39.4622;stroke-linecap:round;stroke-linejoin:round;" + d="M 550.91978,487.64604 L 629.84423,566.57049" + id="path1413" + sodipodi:nodetypes="cc" + transform="matrix(0.398026,0.000000,0.000000,0.398026,176.0698,386.3398)" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient1203);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87645;stroke-dasharray:none;" + id="path682" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,46.26003,-283.6018)" /> + <path + style="font-size:12;fill:url(#linearGradient683);fill-opacity:0.38017;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 390.66521,633.72235 C 371.44051,633.72235 354.98613,644.70534 347.51136,660.37076 C 353.42953,663.40271 360.03471,666.27491 367.81906,664.18848 C 382.43619,660.99617 387.00568,653.47068 394.31424,650.27839 C 409.63412,649.70584 416.97120,657.57598 432.07387,657.23344 C 423.97641,643.28339 408.56719,633.72236 390.66521,633.72235 z " + id="path687" /> + <text + xml:space="preserve" + style="fill:black;fill-opacity:1;stroke:none;font-family:Palatino Linotype;font-style:normal;font-weight:bold;font-size:48;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;text-anchor:start;writing-mode:lr;" + x="127.75068" + y="373.16888" + id="text688" + sodipodi:linespacing="100%" + transform="scale(2.880225,1.909157)"><tspan + x="127.75068" + y="373.16888" + sodipodi:role="line" + id="tspan693">i</tspan></text> + <path + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 496.33119,633.22307 L 496.33119,725.97164 C 523.77846,725.97164 546.04854,705.21602 546.04851,679.61336 C 546.04851,654.01069 523.77844,633.22305 496.33119,633.22307 z " + id="path700" /> + <path + style="font-size:12;fill:url(#linearGradient639);fill-opacity:0.49999997;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 496.76745,633.22395 C 477.54275,633.22395 461.08837,644.20694 453.61360,659.87236 C 459.53177,662.90431 466.13695,665.77651 473.92130,663.69008 C 488.53843,660.49777 493.10792,652.97228 500.41648,649.77999 C 515.73636,649.20744 523.07344,657.07758 538.17611,656.73504 C 530.07865,642.78499 514.66943,633.22396 496.76745,633.22395 z " + id="path697" /> + <g + id="g708" + transform="matrix(1.262750,0.000000,0.000000,1.262750,-71.71251,-181.4823)" + style=""> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect705" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect706" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g711" + transform="matrix(1.262750,0.000000,0.000000,1.262750,10.32260,-181.7613)" + style=""> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect712" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect713" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g721" + transform="matrix(0.878674,-0.906901,0.906901,0.878674,-460.8343,623.7427)" + style="font-size:12;"> + <g + id="g722"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect723" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect724" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g725" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect726" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect727" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + </g> + <g + id="g728" + transform="matrix(1.073491e-5,-1.262750,1.262750,1.073491e-5,-178.5732,1437.573)" + style="font-size:12;"> + <g + id="g729"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect730" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect731" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g732" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect733" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect734" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + </g> + <g + id="g735" + transform="matrix(0.893911,0.891887,-0.891887,0.893911,758.6406,-462.3620)" + style="font-size:12;"> + <g + id="g736"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect737" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect738" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + <g + id="g739" + transform="translate(64.96544,-0.220965)"> + <rect + style="font-size:12;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + id="rect740" + width="15.90990257" + height="6.62912607" + x="557.73045492" + y="679.80529213" + ry="3.31456304" /> + <rect + style="font-size:12;fill:url(#linearGradient703);fill-rule:evenodd;stroke-width:1pt;" + id="rect741" + width="12.47239814" + height="1.37715197" + x="559.37109430" + y="680.06188965" + ry="0.68857598" + rx="1.69095615" /> + </g> + </g> + <path + style="font-size:12;fill:#e6e6e6;fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 683.81237,652.51288 C 671.83423,652.51288 661.58216,660.41352 656.92493,671.68248 C 660.61230,673.86352 664.72773,675.92965 669.57785,674.42877 C 678.68520,672.13237 681.53227,666.71889 686.08594,664.42251 C 695.63114,664.01065 700.20259,669.67205 709.61245,669.42564 C 704.56725,659.39064 694.96638,652.51289 683.81237,652.51288 z " + id="path801" /> + <path + style="fill:#fb4100;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 476.34114,554.66904 C 483.92112,533.01461 496.96853,549.86409 506.53666,550.82511 C 514.86216,550.34456 515.73201,524.39800 531.51319,528.72246 C 538.84464,531.28509 536.85645,548.74295 535.61383,558.03249 C 535.48959,568.60329 536.86193,580.71156 526.29423,589.74497 C 511.50642,601.90523 468.76115,575.84293 476.34114,554.66904 z " + id="path760" + sodipodi:nodetypes="ccccsz" /> + <path + style="font-size:12;stroke:#1c4ed9;stroke-width:10.9208;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216;fill:#4789f7;fill-opacity:1;" + d="M -25.481958,248.26603 L 449.26700,273.43400 L 430.54500,310.73100 L -40.947002,275.21320 L -25.481958,248.26603 z " + id="path279" + transform="matrix(0.158157,4.271800e-2,5.364549e-3,0.156933,469.3436,553.4222)" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill:url(#linearGradient967);fill-opacity:0.6993;stroke:#1c66fb;stroke-width:9.25243;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216;" + d="M -49.210000,251.69600 C -50.453100,239.20100 -40.203100,227.28000 -26.572700,228.54900 L 168.87300,263.91600 L 168.28600,299.92400 L 253.04600,316.79000 L 253.93000,278.87900 L 343.03800,291.68700 C 354.24800,294.90300 361.40100,301.55900 364.49800,316.81800 L 362.20763,586.89881 L -28.092563,469.70606 L -49.210000,251.69600 z " + id="path208" + transform="matrix(0.171298,0.000000,6.402228e-2,0.215063,438.9690,493.7050)" + sodipodi:nodetypes="ccccccccccc" /> + <path + style="font-size:12;fill-opacity:0.99;stroke:#0c1dfb;stroke-width:2.63195;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99;fill:url(#radialGradient1140);" + d="M 557.37226,540.24997 C 557.04724,536.47774 559.72713,532.59711 563.29085,532.12238 L 643.91869,532.55043 C 646.84958,532.82956 648.71975,534.42669 649.52947,538.93308 L 649.45887,612.42139 L 641.22180,619.79126 L 564.84594,620.14154 L 557.39252,612.04259 L 557.37226,540.24997 z " + id="path1131" + sodipodi:nodetypes="ccccccccc" /> + <path + style="font-size:12;fill:url(#linearGradient1138);fill-opacity:0.6993;stroke:#1c2942;stroke-width:2.28142;stroke-opacity:0.99216;" + d="M 582.66195,589.79239 L 627.14365,589.80274 L 627.52772,620.32722 L 582.36162,620.36346 L 582.66195,589.79239 z " + id="path230" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill:#ffffff;fill-opacity:0.99216;stroke:#1c2942;stroke-width:1.10123;stroke-opacity:0.99216;" + d="M 568.04305,545.40016 L 562.27509,545.17995 L 562.26523,539.14553 L 568.02662,539.08853 L 568.04305,545.40016 z " + id="path313" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill-opacity:1;stroke:#0c5cff;stroke-width:2.20247;stroke-opacity:0.99216;fill:#fffffd;" + d="M 572.55890,532.87597 L 635.43355,532.88839 L 635.97643,578.77497 L 572.13438,578.81877 L 572.55890,532.87597 z " + id="path412" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill:#1c2942;fill-opacity:0.992157;stroke-width:8.96855;" + d="M 600.69196,615.30986 L 590.20322,615.52766 L 590.18460,593.72001 L 600.66094,593.93144 L 600.69196,615.30986 z " + id="path415" + sodipodi:nodetypes="ccccc" /> + <path + style="font-size:12;fill:#ffffff;fill-opacity:0.99216;stroke:#1c2942;stroke-width:1.10123;stroke-opacity:0.99216;" + d="M 645.41453,544.95545 L 639.64657,544.73523 L 639.63671,538.70081 L 645.39810,538.64382 L 645.41453,544.95545 z " + id="path420" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:#fb4100;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 576.19524,551.65510 C 583.02443,538.35600 594.77948,548.70415 603.39989,549.29433 C 610.90075,548.99924 611.68442,533.06410 625.90249,535.71996 C 632.50774,537.29380 630.72141,567.64918 621.20046,573.19704 C 607.87739,580.66531 569.36604,564.65909 576.19524,551.65510 z " + id="path1137" + sodipodi:nodetypes="cccsz" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1148" + width="106.29921722" + height="106.29921722" + x="336.61416260" + y="414.56689177" /> + <path + style="fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 77.051277,408.7988 C 71.267817,417.21799 67.027117,423.63406 62.200887,434.68137 C 57.374657,446.11092 52.046077,474.37935 55.805647,479.02442 C 59.565217,483.66948 65.054177,480.60173 68.813737,476.487 C 72.573307,472.37227 70.668857,451.43553 71.855117,442.32214 C 72.728877,433.20875 75.073327,423.76954 77.051277,408.7988 z" + id="path1163" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:url(#linearGradient3600);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 63.057537,441.27138 C 61.657557,445.37446 60.025867,448.19672 58.857597,453.5806 C 57.689337,459.15077 56.021237,472.92733 56.931297,475.19109 C 57.841367,477.45485 59.170057,475.95979 60.080117,473.95448 C 60.990177,471.94918 60.529177,461.74571 60.816327,457.30432 C 61.027837,452.86292 62.578747,448.56734 63.057537,441.27138 z" + id="path1164" + sodipodi:nodetypes="czzzzc" /> + <path + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 65.027472,501.48235 C 51.407077,497.9052 50.454926,490.50156 53.966405,485.50879 C 55.290385,484.10977 58.403862,481.96591 60.211329,482.09583 C 62.018803,482.22576 63.57703,483.14148 65.898291,484.80391 C 71.165819,488.75376 61.235859,490.46929 65.027472,501.48235 z" + id="path1165" + sodipodi:nodetypes="ccszc" /> + <path + style="font-size:12px;fill:url(#linearGradient3598);fill-rule:evenodd;stroke-width:1pt" + d="M 60.576947,496.88161 C 57.318997,496.05997 55.784737,496.21737 53.771847,491.29171 C 51.758957,486.67855 56.763437,485.16283 57.357717,484.53711 C 57.951997,483.91138 58.819637,484.32463 59.413917,484.87892 C 60.008197,485.4332 59.707157,488.25355 59.894667,489.48119 C 60.032787,490.70884 57.764297,492.83368 60.576947,496.88161 z" + id="path1166" + sodipodi:nodetypes="czzzzc" /> + <path + style="fill:#ff0000;fill-opacity:1;fill-rule:nonzero;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + id="path1178" + d="M 132.76033,454.92476 C 133.58483,461.75504 110.61862,470.65746 109.69302,474.58544 C 107.79093,478.92593 122.67406,489.23041 118.64002,494.37156 C 116.06387,502.12143 76.332667,506.06522 67.089097,503.65943 C 65.935297,502.26703 65.735177,499.08018 67.848227,497.17509 C 73.487937,493.86766 101.21717,496.69665 110.37363,491.71974 C 111.17693,489.62848 100.67532,479.10788 103.89636,473.54283 C 107.27361,466.68575 127.96186,459.52712 127.6453,455.49314 C 124.66526,450.94096 101.5795,443.77841 98.841397,439.84805 C 98.841397,439.84805 128.87,449.20724 132.76033,454.92476 z" + sodipodi:nodetypes="cccccccccc" /> + <path + style="fill:#000054;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1" + d="M 379.19834,430.4644 C 375.81627,423.04655 369.17418,435.83206 364.34795,446.87937 C 359.52172,458.30892 354.19314,486.57735 357.95271,491.22242 C 361.71228,495.86748 367.20124,492.79973 370.9608,488.685 C 374.72037,484.57027 372.81592,463.63353 374.00218,454.52014 C 374.87594,445.40675 382.58041,437.88226 379.19834,430.4644 z" + id="path1183" + sodipodi:nodetypes="czzzzz" + inkscape:export-filename="C:\pas\mricron\btn\new\autoclose24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="fill:url(#linearGradient1139);fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 365.20460,453.46938 C 363.80462,457.57246 362.17293,460.39472 361.00466,465.77860 C 359.83640,471.34877 358.16830,485.12533 359.07836,487.38909 C 359.98843,489.65285 361.31712,488.15779 362.22718,486.15248 C 363.13724,484.14718 362.67624,473.94371 362.96339,469.50232 C 363.17490,465.06092 364.72581,460.76534 365.20460,453.46938 z " + id="path1184" + sodipodi:nodetypes="czzzzc" + inkscape:export-filename="C:\pas\mricron\btn\new\autoclose24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="font-size:12;fill-rule:evenodd;stroke-width:1pt;fill:#ff0000;fill-opacity:1;" + d="M 367.17453,513.68035 C 353.55414,510.10320 352.60199,502.69956 356.11346,497.70679 C 357.43744,496.30777 360.55092,494.16391 362.35839,494.29383 C 364.16586,494.42376 365.72409,495.33948 368.04535,497.00191 C 373.31288,500.95176 363.38292,502.66729 367.17453,513.68035 z " + id="path1185" + sodipodi:nodetypes="ccszc" + inkscape:export-filename="C:\pas\mricron\btn\new\autoclose24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="font-size:12;fill:url(#linearGradient1175);fill-rule:evenodd;stroke-width:1pt;" + d="M 362.72401,509.07961 C 359.46606,508.25797 357.93180,508.41537 355.91891,503.48971 C 353.90602,498.87655 358.91050,497.36083 359.50478,496.73511 C 360.09906,496.10938 360.96670,496.52263 361.56098,497.07692 C 362.15526,497.63120 361.85422,500.45155 362.04173,501.67919 C 362.17985,502.90684 359.91136,505.03168 362.72401,509.07961 z " + id="path1186" + sodipodi:nodetypes="czzzzc" + inkscape:export-filename="C:\pas\mricron\btn\new\autoclose24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="fill:#ff0000;fill-rule:nonzero;stroke:none;fill-opacity:1;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt" + id="path1187" + d="M 434.90739,467.12276 C 435.73189,473.95304 412.76568,482.85546 411.84008,486.78344 C 409.93799,491.12393 424.82112,501.42841 420.78708,506.56956 C 418.21093,514.31943 378.47973,518.26322 369.23616,515.85743 C 368.08236,514.46503 367.88224,511.27818 369.99529,509.37309 C 375.63500,506.06566 403.36423,508.89465 412.52069,503.91774 C 413.32399,501.82648 402.82238,491.30588 406.04342,485.74083 C 409.42067,478.88375 430.10892,471.72512 429.79236,467.69114 C 426.81232,463.13896 403.72656,455.97641 400.98846,452.04605 C 400.98846,452.04605 431.01706,461.40524 434.90739,467.12276 z " + sodipodi:nodetypes="cccccccccc" + inkscape:export-filename="C:\pas\mricron\btn\new\autoclose24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="font-size:12;fill:none;fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#0000c0;stroke-width:5;stroke-linecap:round;stroke-dasharray:5, 5;stroke-dashoffset:0;stroke-miterlimit:4;stroke-opacity:1" + d="M 400.09965,456.6173 L 371.53803,505.58684" + id="path1189" + inkscape:export-filename="C:\pas\mricron\btn\new\autoclose24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" + sodipodi:nodetypes="cc" /> + <path + style="fill:#fb4100;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 561.65094,448.09913 C 571.11508,425.70443 587.40564,443.12995 599.35212,444.12377 C 609.74708,443.62687 610.83312,416.79324 630.53703,421.26553 C 639.69082,423.91576 637.21526,475.03199 624.02079,484.37417 C 605.55720,496.95021 552.18679,469.99689 561.65094,448.09913 z " + id="path1196" + sodipodi:nodetypes="cccsz" + inkscape:export-filename="C:\pas\mricron\btn\path.png" + inkscape:export-xdpi="21.807127" + inkscape:export-ydpi="21.807127" /> + <path + style="font-size:12;fill:url(#radialGradient1140);fill-opacity:0.99;stroke:#0c1dfb;stroke-width:2.47208;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99;" + d="M 555.37415,438.95253 C 566.02431,447.52015 591.18209,448.17514 604.56628,448.38069 C 617.95046,448.58624 641.07727,445.71069 647.53136,437.79076 L 639.22369,509.12451 C 628.37584,514.24774 616.58726,517.38839 602.91722,517.02493 C 589.24718,516.66148 572.12780,514.45376 562.84783,509.43353 L 555.37415,438.95253 z " + id="path1199" + sodipodi:nodetypes="czcczcc" + inkscape:export-xdpi="21.807127" + inkscape:export-ydpi="21.807127" + inkscape:export-filename="C:\pas\mricron\btn\path.png" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect983" + width="106.29922" + height="106.29922" + x="229.68997" + y="308.89271" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect984" + width="106.29922" + height="106.29922" + x="335.98920" + y="308.89271" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 279.95280,346.67442 C 280.29433,345.98764 279.36877,338.54690 277.95386,336.62391 C 276.53895,334.70092 274.43956,335.54857 274.09803,336.23535 C 273.75651,336.92213 275.86774,336.00777 277.28264,337.93076 C 278.69755,339.85374 279.61128,347.36120 279.95280,346.67442 z " + id="path1018" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt;" + d="M 273.63423,385.40914 C 270.65408,385.12172 270.05831,378.23536 267.98919,382.43631 C 265.82503,386.71235 270.28496,395.88181 270.67731,391.14244 C 270.97461,386.40309 276.51934,385.77163 273.63423,385.40914 z " + id="path1019" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 288.50077,346.53195 C 288.15924,345.84516 289.08480,338.40442 290.49971,336.48144 C 291.91461,334.55844 294.01401,335.40609 294.35554,336.09287 C 294.69706,336.77966 292.58583,335.86530 291.17093,337.78828 C 289.75602,339.71127 288.84229,347.21873 288.50077,346.53195 z " + id="path1036" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt;" + d="M 294.81934,385.26667 C 297.79949,384.97925 298.39526,378.09288 300.46438,382.29384 C 302.62854,386.56988 298.16861,395.73934 297.77626,390.99997 C 297.47896,386.26061 291.93423,385.62916 294.81934,385.26667 z " + id="path1037" + sodipodi:nodetypes="czzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 409.23451,358.84667 C 408.54949,363.52087 396.22993,361.07089 396.03530,368.76520 C 395.84067,375.96034 411.64662,377.37220 417.55186,375.25440 C 423.45711,373.13660 427.32607,369.84225 426.71517,362.54762 C 426.10429,355.25299 424.14266,336.89820 402.58195,326.37323 C 381.45319,316.34743 357.52241,330.01251 349.87361,344.61299 C 342.22480,359.71267 341.61655,375.00482 350.68776,369.51396 C 359.32701,364.52225 369.86822,348.78540 385.68092,346.96694 C 401.06163,345.14847 409.91950,355.17081 409.23451,358.84667 z " + id="path1045" + sodipodi:nodetypes="czzzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0877723pt;fill-opacity:1.0000000;" + d="M 373.63251,370.33086 C 372.33483,368.22505 372.73946,360.23826 365.81846,361.79098 C 358.89746,363.34369 351.38109,370.76217 349.29735,373.43628 C 347.21361,376.11041 348.32990,380.85478 349.29735,381.97618 C 350.26481,383.09758 355.77183,383.70140 357.33465,385.08158 C 358.89746,386.46177 362.54401,391.63747 364.47891,391.29243 C 366.41382,390.94738 370.35806,386.80682 370.50689,385.08160 C 370.65573,383.35636 374.93016,372.43670 373.63251,370.33086 z " + id="path1049" + sodipodi:nodetypes="czzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:none;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 369.80420,399.98508 C 370.22508,395.78373 374.95545,379.12917 375.72069,374.09587 C 376.48592,369.06258 373.57804,371.60003 374.80242,369.35376 C 376.02678,367.10748 380.15902,361.82463 383.06689,360.61829 C 385.97478,359.41197 390.10702,360.11025 392.24966,361.23339 C 394.39230,362.35653 395.73146,366.10916 395.92276,367.35707 C 396.11406,368.60500 394.43057,370.01932 393.39750,369.60335 C 392.36444,369.18737 394.01446,362.68044 391.51002,364.68476 C 389.00558,366.86555 385.84845,370.56008 384.21474,372.09919 C 382.90569,373.63828 386.12783,372.84795 386.74001,374.09587 C 387.35219,375.34380 388.50003,377.42367 387.88785,379.58674 C 387.27565,381.74980 384.63561,385.70156 383.06689,387.07427 C 381.49816,388.44699 380.12076,385.78476 378.47552,387.82304 C 376.83027,389.86131 374.60431,398.21199 373.22688,400.16706 L 369.80420,399.98508 z " + id="path1050" + sodipodi:nodetypes="czzzzzzzzzzzzcc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;fill-opacity:1.0000000;stroke-dasharray:none;" + d="M 368.64815,355.65182 C 369.07734,357.32494 370.41856,361.26175 371.38424,362.14751 C 372.34992,363.03329 374.41542,363.29574 374.76413,362.14751 C 375.11285,360.99928 372.77913,355.22533 378.62686,352.10871 C 384.63554,348.99209 394.02411,349.71383 396.97480,351.12452 C 399.92548,352.53519 404.88802,357.78424 400.19374,361.36016 C 396.30418,364.93605 405.74639,365.03448 407.75823,363.52538 C 409.77007,362.01628 412.69261,356.42939 410.09064,353.73925 C 407.48867,351.04912 400.89223,344.62204 394.77625,343.96592 C 388.66028,343.30978 374.03986,350.59961 372.02803,351.12452 C 369.85526,351.64942 368.21896,353.97868 368.64815,355.65182 z " + id="path1051" + sodipodi:nodetypes="czzzzzzzzzz" /> + <g + id="g1422"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.1655209pt;" + d="M 500.15302,318.39576 C 498.63090,318.58535 497.62728,319.44559 497.45659,321.35308 L 496.27180,334.48360 L 495.12787,321.15593 C 494.44510,313.52598 480.11544,322.81032 474.82299,326.00594 C 463.97441,332.55643 453.12906,348.90299 453.12904,365.27921 C 453.12904,369.37327 450.53202,374.85695 458.19505,375.61014 C 471.12797,372.25560 475.71395,368.40706 475.88521,364.72718 C 475.97004,366.73597 472.22575,370.99591 477.19257,377.85771 C 471.88006,374.61864 449.68734,372.98113 454.59982,385.78334 C 460.64344,396.79407 487.30926,400.22178 487.52886,393.43295 C 487.74845,386.64413 493.79077,380.76155 483.19824,381.13048 C 485.89452,378.43241 492.43160,379.68832 495.12787,376.99022 L 496.31266,372.81053 L 497.66087,376.55648 C 500.35715,379.25456 506.64909,378.23526 509.34537,380.93333 C 500.48613,379.72791 504.79515,386.40754 505.01475,393.19637 C 505.23437,399.98518 531.94102,396.59692 537.98464,385.58618 C 542.89711,372.78397 520.66354,374.42148 515.35103,377.66055 C 520.31782,370.79874 516.57357,366.49938 516.65839,364.49060 C 516.82967,368.17046 521.41564,372.05845 534.34856,375.41298 C 542.01160,374.65978 539.45542,369.17610 539.45542,365.08206 C 539.45542,348.70583 528.61005,332.35928 517.76147,325.80879 C 513.79214,323.41205 504.71936,317.82698 500.15302,318.39576 z " + id="path1060" + sodipodi:nodetypes="cccccccccccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 501.66595,339.08941 C 507.48057,336.85763 507.44235,336.64611 505.77764,338.68995 C 504.31721,340.73379 502.98053,336.92565 501.65049,348.68951 C 500.11618,360.84766 495.64707,341.51834 501.66595,339.08941 z " + id="path1057" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 491.59647,339.30071 C 485.78186,337.06892 485.82008,336.85741 487.48479,338.90125 C 488.94522,340.94509 490.28190,337.13695 491.61194,348.90080 C 493.14625,361.05897 497.61536,341.72965 491.59647,339.30071 z " + id="path1059" + sodipodi:nodetypes="czzz" /> + </g> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient983);fill-opacity:0.50000000;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none;" + id="path1065" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,153.7331,-282.7179)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt;" + id="rect1074" + width="42.038873" + height="31.251435" + x="577.48017" + y="355.15182" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="59.518364" + inkscape:export-ydpi="59.518364" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 590.00000,364.23718 C 600.00000,365.07051 608.75000,368.82051 614.37500,377.36218 C 620.00000,386.52885 619.37500,387.36218 619.37500,387.36218 C 619.37500,387.36218 620.62500,396.11218 608.75000,397.36218 C 596.87500,397.98718 583.56694,385.77747 569.81694,385.77747 C 556.69194,385.77747 551.87500,383.73242 553.75000,372.36218 C 555.62500,360.55000 569.06250,334.86218 591.87500,334.23718 C 614.68750,332.98718 635.31250,340.38301 643.75000,355.48718 C 651.56250,370.59135 647.81250,382.36218 643.12500,386.11218 C 638.43750,389.86218 627.70833,384.86218 619.37500,386.73718" + id="path1067" + sodipodi:nodetypes="czzzzzzzzz" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="59.518364" + inkscape:export-ydpi="59.518364" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 605.62500,385.48718 C 598.12500,382.98718 595.00000,382.98718 588.12500,376.73718 C 581.25000,370.48718 580.00000,364.23718 580.00000,364.23718" + id="path1068" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="59.518364" + inkscape:export-ydpi="59.518364" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 597.50000,334.86218 C 598.12500,347.36218 604.92417,355.07014 602.71447,365.23480" + id="path1069" + sodipodi:nodetypes="cc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="59.518364" + inkscape:export-ydpi="59.518364" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 610.90476,341.83916 C 625.49682,341.59591 628.11190,344.21099 630.20397,355.19433 C 635.95715,352.05623 638.95397,353.81615 640.20397,366.31615" + id="path1070" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="59.518364" + inkscape:export-ydpi="59.518364" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 620.21706,362.57924 C 620.21706,362.57924 610.95580,381.48089 620.33080,380.85589 C 629.70580,380.23089 626.05002,380.28181 628.70167,379.17696" + id="path1071" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="59.518364" + inkscape:export-ydpi="59.518364" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 565.74009,361.50702 C 565.74009,361.50702 568.88733,353.92082 576.86459,349.47516 C 584.84184,345.55251 590.33862,342.77797 590.55959,337.25370 L 589.89668,342.92311 C 589.16881,349.14804 598.53331,356.11130 595.55959,362.81588" + id="path1072" + sodipodi:nodetypes="czczz" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="59.518364" + inkscape:export-ydpi="59.518364" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 606.88925,334.11254 C 612.15464,344.40283 608.33289,359.63174 612.31037,370.45931" + id="path1073" + sodipodi:nodetypes="cc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="59.518364" + inkscape:export-ydpi="59.518364" /> + <g + id="g1132" + transform="matrix(1.069142,0.000000,0.000000,1.032969,-32.93548,-15.76150)"> + <g + id="g1107" + transform="matrix(0.841944,0.000000,0.000000,0.873445,74.35371,56.03641)"> + <g + id="g1099" + transform="translate(1.325825,9.280777)"> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.65628657pt;" + d="M 496.65430,493.31750 C 496.65430,484.55800 490.15222,466.98787 483.70730,461.72195 C 477.26238,456.45602 464.41541,456.46624 457.98479,461.72195 C 451.55416,466.97766 445.12353,484.49668 445.12353,493.25619 C 445.12353,502.01571 451.55416,510.77522 457.98479,514.27903 C 464.41541,517.78283 477.26238,517.77261 483.70730,514.27903 C 490.15222,510.78544 496.65430,502.07702 496.65430,493.31750 z " + id="path1075" + sodipodi:nodetypes="czzzzzz" /> + <g + id="g1093"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:0.60115390pt;" + d="M 471.91942,460.57627 C 471.83583,460.57625 471.75443,460.59340 471.67084,460.59426 L 471.67084,460.61224 C 471.60863,460.60733 471.54725,460.59423 471.48442,460.59426 C 471.33798,460.59430 471.19580,460.62750 471.04941,460.63023 L 471.04941,460.70216 C 470.96017,460.69182 470.87062,460.68420 470.78013,460.68418 C 470.71728,460.68416 470.65591,460.69725 470.59369,460.70216 L 470.59369,460.68418 C 470.51011,460.68333 470.42871,460.66617 470.34512,460.66619 C 465.94290,460.66736 461.53595,461.88424 458.60004,464.29896 C 457.13209,465.50632 448.73018,475.46378 451.55713,477.17551 C 458.59260,481.68638 464.69200,468.40765 458.18575,479.42351 C 457.53016,483.20728 457.36165,485.18018 457.31574,486.16752 C 457.22303,484.35884 456.45624,480.11665 452.42714,478.05673 C 449.06128,476.37130 446.85496,491.25894 446.85496,493.27120 C 446.85496,501.32028 452.72823,509.36640 458.60004,512.58603 C 461.57796,514.21889 466.06655,515.00265 470.53155,514.97790 L 470.53155,514.99589 C 470.75985,514.99753 470.98688,514.98046 471.21513,514.97790 L 471.21513,514.88798 C 471.38776,514.89378 471.55999,514.90723 471.73299,514.90597 L 471.73299,514.88798 C 476.19799,514.91273 480.68658,514.12899 483.66451,512.49611 C 489.53631,509.27648 495.40958,501.23035 495.40958,493.18128 C 495.40958,491.16902 493.20325,476.28138 489.83741,477.96681 C 485.80830,480.02673 485.04151,484.26892 484.94880,486.07760 C 484.90289,485.09026 484.73439,483.11735 484.07879,479.33359 C 477.57255,468.31773 483.67194,481.59646 490.70741,477.08559 C 493.53436,475.37386 485.13245,465.41639 483.66451,464.20904 C 480.72859,461.79432 476.32164,460.57744 471.91942,460.57627 z " + id="path1076" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.60115390pt;" + d="M 468.10796,477.26953 C 468.34963,476.84360 467.69470,472.22898 466.69350,471.03637 C 465.69229,469.84376 464.20675,470.36946 463.96508,470.79539 C 463.72341,471.22132 465.21734,470.65425 466.21853,471.84686 C 467.21974,473.03946 467.86630,477.69546 468.10796,477.26953 z " + id="path1077" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.50646687pt;" + d="M 463.63689,501.29214 C 461.52811,501.11389 461.10654,496.84308 459.64241,499.44844 C 458.11103,502.10037 461.26692,507.78711 461.54455,504.84784 C 461.75492,501.90857 465.67842,501.51695 463.63689,501.29214 z " + id="path1078" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.60115390pt;" + d="M 474.15658,477.18117 C 473.91491,476.75523 474.56985,472.14061 475.57105,470.94801 C 476.57224,469.75540 478.05780,470.28110 478.29947,470.70703 C 478.54113,471.13296 477.04720,470.56589 476.04601,471.75849 C 475.04481,472.95110 474.39824,477.60710 474.15658,477.18117 z " + id="path1079" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.50646687pt;" + d="M 478.62766,501.20378 C 480.73643,501.02553 481.15801,496.75472 482.62213,499.36008 C 484.15351,502.01201 480.99763,507.69875 480.72000,504.75948 C 480.50963,501.82021 476.58613,501.42859 478.62766,501.20378 z " + id="path1080" + sodipodi:nodetypes="czzz" /> + </g> + </g> + <g + id="g1088" + transform="matrix(0.528836,0.000000,0.000000,0.528836,234.0955,290.1247)"> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:1.2724125pt;" + d="M 448.76081,243.24146 C 439.85333,243.24406 424.56825,250.36055 418.62774,255.70706 C 406.74669,266.40004 400.09103,294.23271 400.09103,312.05436 C 400.09103,317.48652 400.10693,322.81569 400.33616,327.94505 L 494.99693,327.94505 C 495.23807,322.86048 495.28292,317.60716 495.28292,312.21208 C 495.28288,294.39046 491.62713,267.53611 479.71970,256.82234 C 473.76599,251.46545 457.66829,243.23886 448.76081,243.24146 z " + id="path1084" + sodipodi:nodetypes="cccccccc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.1655209pt;" + d="M 452.30358,246.20459 C 450.78146,246.39418 449.77784,247.25442 449.60715,249.16191 L 448.42236,262.29243 L 447.27843,248.96476 C 446.59566,241.33481 432.26600,250.61915 426.97355,253.81477 C 416.12497,260.36526 405.27962,276.71182 405.27960,293.08804 C 405.27960,297.18210 402.68258,302.66578 410.34561,303.41897 C 423.27853,300.06443 427.86451,296.21589 428.03577,292.53601 C 428.12060,294.54480 424.37631,298.80474 429.34313,305.66654 C 424.03062,302.42747 401.83790,300.78996 406.75038,313.59217 C 412.79400,324.60290 439.45982,328.03061 439.67942,321.24178 C 439.89901,314.45296 445.94133,308.57038 435.34880,308.93931 C 438.04508,306.24124 444.58216,307.49715 447.27843,304.79905 L 448.46322,300.61936 L 449.81143,304.36531 C 452.50771,307.06339 458.79965,306.04409 461.49593,308.74216 C 452.63669,307.53674 456.94571,314.21637 457.16531,321.00520 C 457.38493,327.79401 484.09158,324.40575 490.13520,313.39501 C 495.04767,300.59280 472.81410,302.23031 467.50159,305.46938 C 472.46838,298.60757 468.72413,294.30821 468.80895,292.29943 C 468.98023,295.97929 473.56620,299.86728 486.49912,303.22181 C 494.16216,302.46861 491.60598,296.98493 491.60598,292.89089 C 491.60598,276.51466 480.76061,260.16811 469.91203,253.61762 C 465.94270,251.22088 456.86992,245.63581 452.30358,246.20459 z " + id="path1085" + sodipodi:nodetypes="cccccccccccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 453.81651,266.89824 C 459.63113,264.66646 459.59291,264.45494 457.92820,266.49878 C 456.46777,268.54262 455.13109,264.73448 453.80105,276.49834 C 452.26674,288.65649 447.79763,269.32717 453.81651,266.89824 z " + id="path1086" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 443.74703,267.10954 C 437.93242,264.87775 437.97064,264.66624 439.63535,266.71008 C 441.09578,268.75392 442.43246,264.94578 443.76250,276.70963 C 445.29681,288.86780 449.76592,269.53848 443.74703,267.10954 z " + id="path1087" + sodipodi:nodetypes="czzz" /> + </g> + </g> + <g + id="g1126" + transform="matrix(0.495484,0.000000,0.000000,0.495484,300.5956,311.9146)"> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.91963024pt;" + d="M 390.65866,301.36656 L 482.41318,302.01909 L 481.02775,293.60154 C 479.75571,289.61717 475.40700,285.24242 474.55998,280.76456 C 473.27101,276.28670 479.48325,279.16416 478.73371,271.80959 C 477.98416,264.45501 476.57776,244.93064 465.94662,234.62235 C 455.00298,224.62656 445.86383,218.21008 426.46718,221.36127 C 408.32053,223.26246 397.91045,231.92586 390.51069,247.21043 C 382.91955,262.49500 391.32345,281.51355 391.08480,288.64061 L 390.65866,301.36656 z " + id="path1121" + sodipodi:nodetypes="ccczzzzzzc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 456.91427,260.35297 C 456.22925,265.02717 443.90969,262.57719 443.71506,270.27150 C 443.52043,277.46664 459.32638,278.87850 465.23162,276.76070 C 471.13687,274.64290 475.00583,271.34855 474.39493,264.05392 C 473.78405,256.75929 471.82242,238.40450 450.26171,227.87953 C 429.13295,217.85373 405.20217,231.51881 397.55337,246.11929 C 389.90456,261.21897 389.29631,276.51112 398.36752,271.02026 C 407.00677,266.02855 417.54798,250.29170 433.36068,248.47324 C 448.74139,246.65477 457.59926,256.67711 456.91427,260.35297 z " + id="path1122" + sodipodi:nodetypes="czzzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0877723pt;fill-opacity:1.0000000;" + d="M 421.31227,271.83716 C 420.01459,269.73135 420.41922,261.74456 413.49822,263.29728 C 406.57722,264.84999 399.06085,272.26847 396.97711,274.94258 C 394.89337,277.61671 396.00966,282.36108 396.97711,283.48248 C 397.94457,284.60388 403.45159,285.20770 405.01441,286.58788 C 406.57722,287.96807 410.22377,293.14377 412.15867,292.79873 C 414.09358,292.45368 418.03782,288.31312 418.18665,286.58790 C 418.33549,284.86266 422.60992,273.94300 421.31227,271.83716 z " + id="path1123" + sodipodi:nodetypes="czzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:none;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 417.48396,301.49138 C 417.90484,297.29003 422.63521,280.63547 423.40045,275.60217 C 424.16568,270.56888 421.25780,273.10633 422.48218,270.86006 C 423.70654,268.61378 427.83878,263.33093 430.74665,262.12459 C 433.65454,260.91827 437.78678,261.61655 439.92942,262.73969 C 442.07206,263.86283 443.41122,267.61546 443.60252,268.86337 C 443.79382,270.11130 442.11033,271.52562 441.07726,271.10965 C 440.04420,270.69367 441.69422,264.18674 439.18978,266.19106 C 436.68534,268.37185 433.52821,272.06638 431.89450,273.60549 C 430.58545,275.14458 433.80759,274.35425 434.41977,275.60217 C 435.03195,276.85010 436.17979,278.92997 435.56761,281.09304 C 434.95541,283.25610 432.31537,287.20786 430.74665,288.58057 C 429.17792,289.95329 427.80052,287.29106 426.15528,289.32934 C 424.51003,291.36761 422.28407,299.71829 420.90664,301.67336 L 417.48396,301.49138 z " + id="path1124" + sodipodi:nodetypes="czzzzzzzzzzzzcc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.1391397pt;fill-opacity:1.0000000;" + d="M 416.32791,257.15812 C 416.75710,258.83124 418.09832,262.76805 419.06400,263.65381 C 420.02968,264.53959 422.09518,264.80204 422.44389,263.65381 C 422.79261,262.50558 420.45889,256.73163 426.30662,253.61501 C 432.31530,250.49839 441.70387,251.22013 444.65456,252.63082 C 447.60524,254.04149 452.56778,259.29054 447.87350,262.86646 C 443.98394,266.44235 453.42615,266.54078 455.43799,265.03168 C 457.44983,263.52258 460.37237,257.93569 457.77040,255.24555 C 455.16843,252.55542 448.57199,246.12834 442.45601,245.47222 C 436.34004,244.81608 421.71962,252.10591 419.70779,252.63082 C 417.53502,253.15572 415.89872,255.48498 416.32791,257.15812 z " + id="path1125" + sodipodi:nodetypes="czzzzzzzzzz" /> + </g> + </g> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1173" + width="106.29922" + height="106.29922" + x="442.28839" + y="202.59353" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1174" + width="106.29922" + height="106.29922" + x="548.58759" + y="202.59353" /> + <rect + style="fill:url(#linearGradient701);fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:3.7500000;stroke-dasharray:none;" + id="rect1204" + width="91.250000" + height="30.000000" + x="-328.75000" + y="241.11218" + ry="12.500000" + transform="scale(-1.000000,1.000000)" + inkscape:export-xdpi="24" + inkscape:export-ydpi="24" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:1.2724125pt;" + d="M 388.57383,213.13538 C 379.66635,213.13798 364.38127,220.25447 358.44076,225.60098 C 346.55971,236.29396 339.90405,264.12663 339.90405,281.94828 C 339.90405,287.38044 339.91995,292.70961 340.14918,297.83897 L 434.80995,297.83897 C 435.05109,292.75440 435.09594,287.50108 435.09594,282.10600 C 435.09590,264.28438 431.44015,237.43003 419.53272,226.71626 C 413.57901,221.35937 397.48131,213.13278 388.57383,213.13538 z " + id="path1205" + sodipodi:nodetypes="cccccccc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.1655209pt;" + d="M 392.11660,216.09851 C 390.59448,216.28810 389.59086,217.14834 389.42017,219.05583 L 388.23538,232.18635 L 387.09145,218.85868 C 386.40868,211.22873 372.07902,220.51307 366.78657,223.70869 C 355.93799,230.25918 345.09264,246.60574 345.09262,262.98196 C 345.09262,267.07602 342.49560,272.55970 350.15863,273.31289 C 363.09155,269.95835 367.67753,266.10981 367.84879,262.42993 C 367.93362,264.43872 364.18933,268.69866 369.15615,275.56046 C 363.84364,272.32139 341.65092,270.68388 346.56340,283.48609 C 352.60702,294.49682 379.27284,297.92453 379.49244,291.13570 C 379.71203,284.34688 385.75435,278.46430 375.16182,278.83323 C 377.85810,276.13516 384.39518,277.39107 387.09145,274.69297 L 388.27624,270.51328 L 389.62445,274.25923 C 392.32073,276.95731 398.61267,275.93801 401.30895,278.63608 C 392.44971,277.43066 396.75873,284.11029 396.97833,290.89912 C 397.19795,297.68793 423.90460,294.29967 429.94822,283.28893 C 434.86069,270.48672 412.62712,272.12423 407.31461,275.36330 C 412.28140,268.50149 408.53715,264.20213 408.62197,262.19335 C 408.79325,265.87321 413.37922,269.76120 426.31214,273.11573 C 433.97518,272.36253 431.41900,266.87885 431.41900,262.78481 C 431.41900,246.40858 420.57363,230.06203 409.72505,223.51154 C 405.75572,221.11480 396.68294,215.52973 392.11660,216.09851 z " + id="path1206" + sodipodi:nodetypes="cccccccccccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 393.62953,236.79216 C 399.44415,234.56038 399.40593,234.34886 397.74122,236.39270 C 396.28079,238.43654 394.94411,234.62840 393.61407,246.39226 C 392.07976,258.55041 387.61065,239.22109 393.62953,236.79216 z " + id="path1207" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.98194113pt;" + d="M 383.56005,237.00346 C 377.74544,234.77167 377.78366,234.56016 379.44837,236.60400 C 380.90880,238.64784 382.24548,234.83970 383.57552,246.60355 C 385.10983,258.76172 389.57894,239.43240 383.56005,237.00346 z " + id="path1209" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#00ff00;stroke-width:8.1250000;stroke-linecap:round;stroke-linejoin:bevel;stroke-dashoffset:12.500000;stroke-dasharray:none;" + d="M 428.23716,300.72398 L 352.16975,226.74092" + id="path1210" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:5;stroke-dasharray:none;stroke-opacity:1" + d="M 845.47619,180.57813 C 845.47619,194.72313 833.99619,206.20313 819.85119,206.20313 C 805.70619,206.20313 794.22619,194.72313 794.22619,180.57813 C 794.22619,166.43313 805.70619,154.95313 819.85119,154.95313 C 833.99619,154.95313 845.47619,166.43313 845.47619,180.57813 z" + id="path1291" + inkscape:export-filename="C:\pas\mricron\btn\new\ellipse.png" + inkscape:export-xdpi="23.179588" + inkscape:export-ydpi="23.179588" /> + <rect + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#ff0000;stroke-width:4.56593418" + id="rect1303" + width="48.979599" + height="47.110672" + x="834.32587" + y="135.24585" + inkscape:export-filename="C:\pas\mricron\btn\new\ellipse.png" + inkscape:export-xdpi="23.179588" + inkscape:export-ydpi="23.179588" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1092" + width="106.29922" + height="106.29922" + x="549.21260" + y="95.669265" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1093" + width="106.29922" + height="106.29922" + x="442.91338" + y="95.669265" /> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1094" + width="106.29922" + height="106.29922" + x="336.61417" + y="95.669265" /> + <rect + style="font-size:12.000000;fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000pt;" + id="rect1095" + width="106.29922" + height="106.29922" + x="230.31496" + y="95.669269" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59819369pt;" + d="M 307.52069,149.83649 C 307.73008,149.34971 307.16264,144.07588 306.29519,142.71291 C 305.42774,141.34993 304.14065,141.95073 303.93127,142.43750 C 303.72189,142.92428 305.01624,142.27620 305.88368,143.63917 C 306.75113,145.00214 307.31131,150.32326 307.52069,149.83649 z " + id="path1097" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.50397291pt;" + d="M 303.64692,177.29080 C 301.81986,177.08709 301.45461,172.20619 300.18608,175.18373 C 298.85928,178.21449 301.59356,184.71360 301.83410,181.35444 C 302.01637,177.99529 305.41572,177.54773 303.64692,177.29080 z " + id="path1098" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59819369pt;" + d="M 312.76126,149.73551 C 312.55187,149.24873 313.11931,143.97489 313.98676,142.61193 C 314.85420,141.24895 316.14130,141.84974 316.35068,142.33652 C 316.56006,142.82330 315.26571,142.17522 314.39827,143.53819 C 313.53082,144.90116 312.97063,150.22228 312.76126,149.73551 z " + id="path1099" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.50397291pt;" + d="M 316.63503,177.18982 C 318.46209,176.98611 318.82734,172.10520 320.09587,175.08275 C 321.42267,178.11351 318.68839,184.61262 318.44784,181.25346 C 318.26558,177.89431 314.86623,177.44675 316.63503,177.18982 z " + id="path1100" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.99068832pt;fill:#f30000;fill-opacity:1.0000000;" + d="M 277.51799,168.04576 C 277.51799,158.03493 271.88453,137.95486 266.30062,131.93668 C 260.71669,125.91850 249.58599,125.93017 244.01446,131.93668 C 238.44291,137.94318 232.87137,157.96485 232.87137,167.97569 C 232.87137,177.98652 238.44291,187.99735 244.01446,192.00169 C 249.58599,196.00603 260.71669,195.99435 266.30062,192.00169 C 271.88453,188.00903 277.51799,178.05659 277.51799,168.04576 z " + id="path1101" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:0.59819369pt;" + d="M 256.08751,130.62734 C 256.01509,130.62732 255.94457,130.64692 255.87215,130.64789 L 255.87215,130.66845 C 255.81824,130.66283 255.76507,130.64786 255.71062,130.64789 C 255.58375,130.64794 255.46056,130.68588 255.33374,130.68900 L 255.33374,130.77121 C 255.25641,130.75940 255.17883,130.75069 255.10042,130.75066 C 255.04598,130.75064 254.99280,130.76560 254.93890,130.77121 L 254.93890,130.75066 C 254.86648,130.74969 254.79596,130.73008 254.72353,130.73010 C 250.90942,130.73144 247.09120,132.12216 244.54751,134.88183 C 243.27567,136.26166 235.99620,147.64157 238.44549,149.59783 C 244.54107,154.75309 249.82562,139.57745 244.18857,152.16697 C 243.62056,156.49125 243.47456,158.74599 243.43479,159.87438 C 243.35446,157.80732 242.69011,152.95912 239.19927,150.60493 C 236.28307,148.67874 234.37149,165.69312 234.37149,167.99284 C 234.37149,177.19175 239.46014,186.38729 244.54751,190.06685 C 247.12760,191.93297 251.01655,192.82869 254.88505,192.80041 L 254.88505,192.82096 C 255.08285,192.82284 255.27955,192.80333 255.47731,192.80041 L 255.47731,192.69764 C 255.62688,192.70426 255.77610,192.71964 255.92599,192.71820 L 255.92599,192.69764 C 259.79450,192.72592 263.68345,191.83022 266.26354,189.96409 C 271.35091,186.28452 276.43955,177.08898 276.43955,167.89007 C 276.43955,165.59035 274.52797,148.57597 271.61178,150.50217 C 268.12094,152.85635 267.45658,157.70455 267.37626,159.77161 C 267.33648,158.64323 267.19049,156.38848 266.62248,152.06420 C 260.98542,139.47469 266.26998,154.65032 272.36556,149.49507 C 274.81485,147.53880 267.53538,136.15888 266.26354,134.77906 C 263.71984,132.01939 259.90163,130.62867 256.08751,130.62734 z " + id="path1102" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59819369pt;" + d="M 252.78524,149.70528 C 252.99463,149.21850 252.42719,143.94467 251.55974,142.58169 C 250.69229,141.21872 249.40520,141.81952 249.19582,142.30629 C 248.98644,142.79307 250.28079,142.14499 251.14823,143.50796 C 252.01568,144.87093 252.57586,150.19205 252.78524,149.70528 z " + id="path1103" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.50397291pt;" + d="M 248.91147,177.15959 C 247.08441,176.95588 246.71916,172.07498 245.45063,175.05252 C 244.12383,178.08328 246.85811,184.58239 247.09865,181.22323 C 247.28092,177.86408 250.68027,177.41652 248.91147,177.15959 z " + id="path1104" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59819369pt;" + d="M 258.02581,149.60430 C 257.81642,149.11751 258.38386,143.84368 259.25131,142.48072 C 260.11875,141.11774 261.40585,141.71853 261.61523,142.20531 C 261.82461,142.69209 260.53026,142.04401 259.66282,143.40697 C 258.79537,144.76995 258.23518,150.09107 258.02581,149.60430 z " + id="path1105" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.50397291pt;" + d="M 261.89958,177.05861 C 263.72664,176.85490 264.09189,171.97399 265.36042,174.95154 C 266.68722,177.98230 263.95294,184.48141 263.71239,181.12225 C 263.53013,177.76310 260.13078,177.31554 261.89958,177.05861 z " + id="path1106" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.37908139pt;fill:#00f300;fill-opacity:1.0000000;" + d="M 284.46583,153.19549 L 284.66716,159.20701 L 284.66716,159.51930 L 270.26011,159.51930 L 270.26011,172.16691 L 284.52875,172.16691 L 284.46583,178.49072 L 298.73447,165.84310 L 284.46583,153.19549 z " + id="path1197" /> + <g + id="g1218" + transform="matrix(0.937345,0.000000,-0.521597,0.915342,103.6709,16.62999)"> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.99068832pt;" + d="M 420.68026,157.78820 C 420.68026,143.66413 411.49144,115.33358 402.38342,106.84266 C 393.27539,98.351740 375.11992,98.368210 366.03210,106.84266 C 356.94426,115.31711 347.85643,143.56526 347.85643,157.68934 C 347.85643,171.81342 356.94426,185.93749 366.03210,191.58713 C 375.11992,197.23676 393.27539,197.22028 402.38342,191.58713 C 411.49144,185.95397 420.68026,171.91228 420.68026,157.78820 z " + id="path1198" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;fill-opacity:1.0000000;" + d="M 385.72466,104.99534 C 385.60653,104.99531 385.49150,105.02296 385.37337,105.02434 L 385.37337,105.05334 C 385.28545,105.04542 385.19871,105.02430 385.10991,105.02434 C 384.90297,105.02441 384.70203,105.07794 384.49516,105.08234 L 384.49516,105.19833 C 384.36904,105.18166 384.24249,105.16937 384.11460,105.16933 C 384.02579,105.16930 383.93906,105.19041 383.85113,105.19833 L 383.85113,105.16933 C 383.73301,105.16796 383.61798,105.14030 383.49985,105.14033 C 377.27858,105.14222 371.05063,107.10435 366.90157,110.99791 C 364.82705,112.94468 352.95338,129.00036 356.94846,131.76041 C 366.89106,139.03386 375.51079,117.62287 366.31609,135.38515 C 365.38960,141.48619 365.15147,144.66736 365.08659,146.25937 C 364.95557,143.34300 363.87193,136.50278 358.17796,133.18131 C 353.42130,130.46368 350.30330,154.46891 350.30330,157.71354 C 350.30330,170.69209 358.60347,183.66588 366.90157,188.85730 C 371.11000,191.49017 377.45333,192.75392 383.76331,192.71402 L 383.76331,192.74302 C 384.08594,192.74567 384.40678,192.71814 384.72935,192.71402 L 384.72935,192.56903 C 384.97331,192.57837 385.21671,192.60006 385.46120,192.59803 L 385.46120,192.56903 C 391.77118,192.60893 398.11451,191.34520 402.32294,188.71231 C 410.62104,183.52089 418.92121,170.54709 418.92121,157.56855 C 418.92121,154.32392 415.80320,130.31868 411.04655,133.03632 C 405.35258,136.35779 404.26894,143.19801 404.13792,146.11438 C 404.07304,144.52237 403.83491,141.34119 402.90841,135.24016 C 393.71372,117.47788 402.33345,138.88886 412.27605,131.61542 C 416.27113,128.85537 404.39746,112.79968 402.32294,110.85292 C 398.17388,106.95936 391.94593,104.99722 385.72466,104.99534 z " + id="path1201" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 380.33827,131.91200 C 380.67980,131.22522 379.75424,123.78448 378.33933,121.86149 C 376.92442,119.93850 374.82503,120.78615 374.48350,121.47293 C 374.14198,122.15971 376.25321,121.24535 377.66811,123.16834 C 379.08302,125.09132 379.99675,132.59878 380.33827,131.91200 z " + id="path1202" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt;" + d="M 374.01970,170.64672 C 371.03955,170.35930 370.44378,163.47294 368.37466,167.67389 C 366.21050,171.94993 370.67043,181.11939 371.06278,176.38002 C 371.36008,171.64067 376.90481,171.00921 374.01970,170.64672 z " + id="path1203" + sodipodi:nodetypes="czzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.90746355pt;" + d="M 388.88624,131.76953 C 388.54471,131.08274 389.47027,123.64200 390.88518,121.71902 C 392.30008,119.79602 394.39948,120.64367 394.74101,121.33045 C 395.08253,122.01724 392.97130,121.10288 391.55640,123.02586 C 390.14149,124.94885 389.22776,132.45631 388.88624,131.76953 z " + id="path1216" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.76453004pt;" + d="M 395.20481,170.50425 C 398.18496,170.21683 398.78073,163.33046 400.84985,167.53142 C 403.01401,171.80746 398.55408,180.97692 398.16173,176.23755 C 397.86443,171.49819 392.31970,170.86674 395.20481,170.50425 z " + id="path1217" + sodipodi:nodetypes="czzz" /> + </g> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.37908139pt;fill:#00f300;fill-opacity:1.0000000;" + d="M 428.01911,162.01828 L 423.37484,168.02980 L 423.12311,168.34209 L 408.71606,168.34209 L 398.52142,180.98970 L 412.79006,180.98970 L 407.62982,187.31351 L 432.09311,174.66589 L 428.01911,162.01828 z " + id="path1225" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.37908139pt;fill:#00f300;fill-opacity:1.0000000;" + d="M 354.54175,137.59503 L 359.18602,131.58351 L 359.43775,131.27122 L 373.84480,131.27122 L 384.03944,118.62361 L 369.77080,118.62361 L 374.93104,112.29980 L 350.46775,124.94742 L 354.54175,137.59503 z " + id="path1226" /> + <path + style="fill:url(#linearGradient1273);fill-rule:evenodd;stroke-width:0.70212674pt;fill-opacity:1.0000000;" + d="M 467.37635,98.353752 C 463.50624,98.508099 459.42100,99.228043 455.01853,100.26653 C 449.14858,101.65118 445.35681,115.09401 447.03802,123.34197 C 448.71924,131.58992 453.74697,146.51332 454.11773,158.09757 L 460.40924,157.95512 C 460.70198,148.86493 458.20224,140.91179 457.10163,132.39714 C 456.41064,127.05144 453.86311,111.80425 462.99904,111.80425 L 470.06467,111.80425 L 470.06467,111.84495 L 478.04518,111.84495 C 487.18110,111.84495 484.61950,127.11248 483.92851,132.45819 C 482.82791,140.97284 480.32815,148.90562 480.62089,157.99581 L 486.91240,158.13826 C 487.28316,146.55402 492.31090,131.63062 493.99211,123.38267 C 495.67333,115.13471 491.88156,101.69188 486.01161,100.30723 C 480.65069,99.042651 475.78320,98.287415 471.17659,98.414798 L 471.17659,98.394449 C 469.92961,98.310515 468.66639,98.302304 467.37635,98.353752 z " + id="path1231" + transform="translate(43.75223,40.21670)" /> + <rect + style="fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.87235308pt;" + id="rect1232" + width="5.7452426" + height="5.3810821" + x="454.09512" + y="152.41942" + transform="translate(43.75223,40.21670)" /> + <rect + style="fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.87235308pt;" + id="rect1233" + width="5.7452426" + height="5.3810821" + x="481.16409" + y="152.41943" + transform="translate(43.75223,40.21670)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#ff0000;stroke-width:5.0000000;stroke-opacity:1.0000000;stroke-linecap:round;stroke-dasharray:10.000000,10.000000;stroke-dashoffset:0.00000000;" + d="M 555.46141,176.42468 C 559.55050,176.42960 566.62926,182.31051 567.72869,176.43945 C 568.82812,170.88089 576.44823,114.43157 580.80799,105.57330 C 585.16775,96.715032 581.98180,115.22882 595.40407,119.22734 C 609.13884,122.91336 613.18611,180.92271 621.29587,184.46848 C 629.40563,187.70175 630.95289,182.51721 635.31265,179.56445 C 639.67241,176.61170 641.84468,176.43945 646.20445,176.43945" + id="path1280" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#040600;stroke-width:3.7500000;stroke-opacity:1.0000000;stroke-linecap:butt;stroke-dasharray:3.7500000,3.7500000;stroke-dashoffset:0.00000000;" + d="M 555.25347,176.62690 C 559.34256,176.63182 566.42132,180.01273 567.52075,174.14167 C 568.62018,168.58311 571.24029,134.00879 575.60005,125.15052 C 579.95981,116.29225 583.02386,104.80604 596.13363,110.67956 C 608.93090,123.74058 622.04067,188.31243 625.15043,189.67070 C 627.32269,190.40397 630.74495,182.71943 635.10471,179.76667 C 639.46447,176.81392 641.63674,176.64167 645.99651,176.64167" + id="path1281" + sodipodi:nodetypes="czzzzzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#040600;stroke-width:3.7500000;stroke-opacity:1.0000000;stroke-linecap:butt;stroke-dasharray:3.7500000,3.7500000;stroke-dashoffset:0.00000000;" + d="M 557.12849,76.779411 C 561.21758,76.784331 568.29634,80.165241 569.39577,74.294181 C 570.49520,68.735621 573.11531,34.161301 577.47507,25.303031 C 581.83483,16.444761 584.89888,4.9585510 598.00865,10.832071 C 610.80592,23.893091 623.91569,88.464940 627.02545,89.823210 C 629.19771,90.556480 632.61997,82.871941 636.97973,79.919181 C 641.33949,76.966431 643.51176,76.794181 647.87153,76.794181" + id="path1282" + sodipodi:nodetypes="czzzzzz" /> + <text + xml:space="preserve" + style="fill:#ff0000;fill-opacity:1.0000000;stroke:none;font-family:Arial;font-style:normal;font-weight:bold;font-size:36.000000;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;font-stretch:normal;font-variant:normal;text-anchor:start;writing-mode:lr;" + x="383.35034" + y="50.653559" + id="text1283" + sodipodi:linespacing="100%" + transform="scale(1.505663,1.564296)"><tspan + id="tspan1284" + style="fill:#ff0000;fill-opacity:1.0000000;">?</tspan></text> + <g + id="g1163" + transform="matrix(1.152996,0.000000,0.000000,1.000000,-68.02037,0.000000)"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.0770883;stroke-dasharray:none;" + d="M 472.42571,238.27147 C 472.33405,238.27145 472.24478,238.29291 472.15311,238.29398 L 472.15311,238.31648 C 472.08489,238.31034 472.01758,238.29395 471.94867,238.29398 C 471.78809,238.29403 471.63216,238.33557 471.47163,238.33899 L 471.47163,238.42899 C 471.37376,238.41606 471.27556,238.40652 471.17632,238.40649 C 471.10740,238.40647 471.04010,238.42285 470.97187,238.42899 L 470.97187,238.40649 C 470.88021,238.40543 470.79094,238.38396 470.69928,238.38399 C 465.87162,238.38545 461.03877,239.90805 457.81913,242.92943 C 456.20932,244.44011 446.99543,256.89920 450.09559,259.04098 C 457.81097,264.68512 464.49982,248.07035 457.36480,261.85375 C 456.64585,266.58811 456.46107,269.05668 456.41072,270.29207 C 456.30905,268.02898 455.46815,262.72102 451.04967,260.14359 C 447.35854,258.03472 444.93899,276.66261 444.93899,279.18042 C 444.93899,289.25168 451.37986,299.31925 457.81913,303.34776 C 461.08484,305.39084 466.00722,306.37150 470.90372,306.34054 L 470.90372,306.36305 C 471.15408,306.36510 471.40305,306.34374 471.65336,306.34054 L 471.65336,306.22803 C 471.84267,306.23528 472.03155,306.25211 472.22127,306.25053 L 472.22127,306.22803 C 477.11777,306.25899 482.04015,305.27835 485.30586,303.23524 C 491.74513,299.20674 498.18600,289.13916 498.18600,279.06791 C 498.18600,276.55010 495.76645,257.92220 492.07532,260.03107 C 487.65684,262.60851 486.81594,267.91647 486.71427,270.17956 C 486.66392,268.94417 486.47914,266.47559 485.76018,261.74124 C 478.62517,247.95784 485.31402,264.57260 493.02940,258.92847 C 496.12956,256.78669 486.91567,244.32759 485.30586,242.81691 C 482.08622,239.79554 477.25337,238.27293 472.42571,238.27147 z " + id="path1211" + transform="matrix(0.896078,0.000000,0.000000,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.70418520pt;" + d="M 468.24591,259.15861 C 468.51094,258.62567 467.79271,252.85171 466.69475,251.35949 C 465.59679,249.86726 463.96768,250.52503 463.70265,251.05797 C 463.43764,251.59090 465.07594,250.88137 466.17389,252.37359 C 467.27185,253.86581 467.98090,259.69155 468.24591,259.15861 z " + id="path1212" + sodipodi:nodetypes="czzzz" + transform="matrix(0.896078,0.000000,0.000000,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt;" + d="M 463.34275,289.21648 C 461.03017,288.99344 460.56786,283.64967 458.96224,286.90958 C 457.28286,290.22776 460.74374,297.34319 461.04820,293.66548 C 461.27890,289.98777 465.58157,289.49777 463.34275,289.21648 z " + id="path1213" + sodipodi:nodetypes="czzz" + transform="matrix(0.896078,0.000000,0.000000,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.70418520pt;" + d="M 474.87908,259.04805 C 474.61405,258.51511 475.33228,252.74115 476.43024,251.24893 C 477.52819,249.75670 479.15731,250.41447 479.42234,250.94740 C 479.68735,251.48035 478.04905,250.77081 476.95110,252.26303 C 475.85314,253.75526 475.14409,259.58099 474.87908,259.04805 z " + id="path1214" + sodipodi:nodetypes="czzzz" + transform="matrix(0.896078,0.000000,0.000000,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt;" + d="M 479.78224,289.10592 C 482.09482,288.88288 482.55713,283.53911 484.16275,286.79902 C 485.84213,290.11720 482.38125,297.23264 482.07679,293.55492 C 481.84609,289.87721 477.54342,289.38721 479.78224,289.10592 z " + id="path1215" + sodipodi:nodetypes="czzz" + transform="matrix(0.896078,0.000000,0.000000,0.909383,46.81814,19.67645)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt;" + d="M 479.78224,289.10592 C 482.09482,288.88288 482.55713,283.53911 484.16275,286.79902 C 485.84213,290.11720 482.38125,297.23264 482.07679,293.55492 C 481.84609,289.87721 477.54342,289.38721 479.78224,289.10592 z " + id="path1245" + sodipodi:nodetypes="czzz" + transform="matrix(0.896078,0.000000,0.000000,0.909383,71.19322,13.47142)" /> + <path + transform="matrix(0.820025,0.000000,0.000000,0.858963,104.9588,28.96850)" + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.0770884;" + d="M 472.42572,238.27147 C 466.99935,238.34460 460.99557,239.27928 457.24200,243.60560 C 454.27786,247.05912 447.54300,265.39403 446.58800,268.07554 C 444.99506,275.03305 443.89364,282.61304 446.99670,289.34223 C 449.98685,297.12243 456.23622,304.66231 464.92263,305.85892 C 470.66585,306.65810 476.71462,306.56039 482.24009,304.66227 C 488.70615,302.32029 492.95294,296.28794 495.73557,290.27853 C 498.36218,284.49691 498.76947,277.90311 497.25994,271.76637 C 496.60360,267.85969 495.93735,263.78918 493.70802,260.42078 C 490.47721,259.07927 488.59909,263.53006 487.49637,265.86353 C 487.00972,267.33824 486.63024,271.50536 486.49583,267.70454 C 486.56751,263.78501 485.27565,260.09141 483.12367,256.86000 C 483.47775,256.38368 486.42646,260.44859 488.46678,259.99317 C 492.66404,261.29430 494.92727,256.76681 492.55453,253.62131 C 490.80672,249.96760 488.38631,246.65200 485.92858,243.45619 C 482.48414,239.81958 477.32986,238.26882 472.42572,238.27147 z " + id="path1151" + sodipodi:nodetypes="cccccccccccccccc" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.70418520pt;" + d="M 469.29214,259.15861 C 471.28335,258.62567 470.01209,252.60872 468.91413,251.11650 C 467.81617,249.62427 460.51529,248.09514 463.70265,251.05797 C 467.13661,253.77781 467.05433,259.69155 469.29214,259.15861 z " + id="path1242" + sodipodi:nodetypes="czzz" + transform="matrix(0.820025,0.000000,0.000000,0.858963,104.9588,28.96850)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt;" + d="M 466.83017,280.96913 C 464.51759,280.74609 460.56786,283.64967 458.96224,286.90958 C 457.28286,290.22776 460.74374,297.34319 461.04820,293.66548 C 461.27890,289.98777 469.06899,281.25042 466.83017,280.96913 z " + id="path1243" + sodipodi:nodetypes="czzz" + transform="matrix(0.820025,0.000000,0.000000,0.858963,104.9588,28.96850)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59100037pt;" + d="M 493.43163,251.60533 C 491.79878,251.14755 492.84125,245.97921 493.74161,244.69745 C 494.64196,243.41568 500.62886,242.10222 498.01515,244.64717 C 495.19921,246.98342 495.26668,252.06310 493.43163,251.60533 z " + id="path1152" + sodipodi:nodetypes="czzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.5214069;" + d="M 511.80663,239.60773 C 505.82577,239.32916 500.11547,244.27305 498.49491,246.98563 C 497.16791,249.22473 493.46139,261.39466 492.85327,264.14860 C 492.10462,268.10699 491.68917,272.26850 492.99906,276.15741 C 494.65527,281.44574 497.85490,286.62328 502.77269,289.10403 C 505.89347,290.48383 509.46589,290.71532 512.64653,290.47013 C 516.82711,290.39011 521.19160,289.06289 524.01723,285.66210 C 528.59029,280.58529 531.28514,273.27869 529.87427,266.31128 C 529.26796,262.87343 525.92547,250.57752 524.78129,248.36436 C 522.92298,245.30255 517.65774,239.61035 511.80663,239.60773 z " + id="path1149" + sodipodi:nodetypes="cccccccccc" /> + </g> + <path + style="fill:#cccccc;fill-rule:nonzero;stroke:none;fill-opacity:1.0000000;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;" + id="path1142" + d="M 154.48440,498.48337 C 154.25849,492.81414 161.38338,496.65143 161.80515,496.90392 C 164.78182,498.61634 170.39318,504.14280 173.95269,504.05991 C 175.95558,503.84576 177.63390,502.63440 179.05959,501.28272 C 180.33976,499.99776 181.20682,498.58127 182.06397,497.00066 C 183.44438,494.70321 187.18348,487.99384 189.77932,488.11380 C 192.16403,488.34388 196.44293,490.85911 198.63874,491.77507 C 200.34301,492.48848 203.47991,491.83913 205.21157,492.48524 C 206.51580,492.94214 202.88897,499.07531 204.26060,499.25768 C 205.40017,499.35058 206.09747,498.86094 206.93516,498.11576 C 207.57391,497.51451 211.51747,500.31315 210.70090,501.08164 C 208.56717,502.98125 206.27814,503.85683 203.40943,503.55889 C 201.58416,503.29953 199.79391,502.83223 198.06231,502.20168 C 196.27903,501.51624 194.58389,500.64017 192.82470,499.89873 C 191.28048,499.25617 189.66739,498.59467 187.99351,498.39461 C 187.36694,498.35913 187.14450,498.30179 186.79211,498.84177 C 185.67318,500.80361 184.50376,502.56949 182.88013,504.16267 C 180.31823,506.51125 177.42085,508.14583 173.89191,508.33224 C 169.23300,508.20987 162.04502,509.96482 156.25203,500.75392 C 155.96788,500.55562 159.95745,495.74444 159.84831,498.48337 L 154.48440,498.48337 z " + sodipodi:nodetypes="ccccccccccccccccccccc" /> + <rect + style="fill:#f9bac0;fill-rule:evenodd;stroke:#000000;stroke-width:0.49504948pt;" + id="rect1120" + width="12.250767" + height="12.000593" + x="141.62668" + y="387.23074" + ry="3.9226213" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <rect + style="fill:url(#linearGradient1118);fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0000000pt;" + id="rect1117" + width="53.347649" + height="11.244847" + x="150.89017" + y="387.60864" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.93750000;" + d="M 153.76675,391.00825 L 202.40725,390.74674 L 202.40725,390.74674" + id="path1126" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:0.93750000;" + d="M 153.76675,395.58464 L 202.40725,395.32313 L 202.40725,395.32313" + id="path1128" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <path + style="fill:#e49415;fill-rule:evenodd;stroke-width:1.0000000pt;fill-opacity:1.0000000;" + d="M 204.76083,387.08564 L 226.72751,392.93844 L 205.02234,399.37652 L 204.76083,387.08564 z " + id="path1129" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <path + style="fill:#040023;fill-rule:evenodd;stroke-width:1.0000000pt;" + d="M 219.01301,390.87754 L 227.25053,392.93225 L 219.11108,395.19241 L 219.01301,390.87754 z " + id="path1132" + transform="matrix(0.801814,-0.889705,0.948595,0.752036,-334.0009,328.3647)" /> + <g + id="g1195" + transform="matrix(0.789807,0.000000,0.000000,0.829148,40.60222,144.2242)"> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient1169);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87645;stroke-dasharray:none;" + id="path1190" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(1.269231,0.000000,0.000000,1.209574,-184.6799,-194.3941)" /> + <path + style="font-size:12;fill:url(#linearGradient683);fill-opacity:0.38017;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 159.72524,722.93003 C 140.50054,722.93003 124.04616,733.91302 116.57139,749.57844 C 122.48956,752.61039 129.09474,755.48259 136.87909,753.39616 C 151.49622,750.20385 156.06571,742.67836 163.37427,739.48607 C 178.69415,738.91352 186.03123,746.78366 201.13390,746.44112 C 193.03644,732.49107 177.62722,722.93004 159.72524,722.93003 z " + id="path1191" /> + <text + xml:space="preserve" + style="fill:black;fill-opacity:1;stroke:none;font-family:Palatino Linotype;font-style:normal;font-weight:bold;font-size:48;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;text-anchor:start;writing-mode:lr;" + x="47.569456" + y="419.89508" + id="text1192" + sodipodi:linespacing="100%" + transform="scale(2.880225,1.909157)"><tspan + x="47.569454" + y="419.89508" + sodipodi:role="line" + id="tspan1193">i</tspan></text> + </g> + <path + style="fill:#fb4100;fill-rule:evenodd;stroke:none;stroke-opacity:1;stroke-width:1pt;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:1;" + d="M 157.91689,807.80962 C 166.13755,791.78371 180.28774,804.25361 190.66459,804.96480 C 199.69378,804.60921 200.63712,785.40677 217.75218,788.60718 C 225.70328,790.50372 223.55297,827.08308 212.09209,833.76845 C 196.05440,842.76799 149.69621,823.47991 157.91689,807.80962 z " + id="path1179" + sodipodi:nodetypes="cccsz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 135.72268,361.98087 C 134.67665,364.33444 139.37290,364.60684 143.68234,366.31209 C 147.99177,368.01734 152.43742,371.67846 155.07429,372.44119 C 160.34804,373.96665 169.84949,374.44608 173.64136,373.48722 C 177.43323,372.52836 177.12814,369.56460 177.82549,365.64199" + id="path1135" + sodipodi:nodetypes="cszzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 163.44255,357.27376 C 158.21239,350.47455 167.88818,351.25907 168.41121,347.07494 C 171.02628,336.87613 161.08898,335.30708 161.08898,335.30708 C 161.08898,335.30708 167.10367,327.72334 168.67271,323.53921 C 163.44255,317.78603 163.96556,318.57056 155.85881,322.23167" + id="path1138" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 169.19573,382.90152 C 169.80591,375.31778 164.40140,374.66401 162.13500,373.48722" + id="path1141" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 135.59193,366.63075 C 138.73003,373.95298 150.19280,376.35013 155.46655,377.87559" + id="path1153" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 163.44255,357.27376 C 158.21239,350.47455 167.88818,351.25907 168.41121,347.07494 C 171.02628,336.87613 161.08898,335.30708 161.08898,335.30708 C 161.08898,335.30708 167.10367,327.72334 168.67271,323.53921 C 163.44255,317.78603 163.96556,318.57056 155.85881,322.23167" + id="path1167" + sodipodi:nodetypes="ccccc" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,355.9476,-0.390884)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 169.19573,382.90152 C 169.80591,375.31778 164.40140,374.66401 162.13500,373.48722" + id="path1169" + sodipodi:nodetypes="cz" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,355.9476,-0.390884)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 135.59193,366.63075 C 138.73003,373.95298 150.19280,376.35013 155.46655,377.87559" + id="path1170" + sodipodi:nodetypes="cz" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,355.9476,-0.390884)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 220.21273,361.50548 C 221.25876,363.85905 216.56251,364.13145 212.25307,365.83670 C 207.94364,367.54195 203.49799,371.20307 200.86112,371.96580 C 195.58737,373.49126 186.08592,373.97069 182.29405,373.01183 C 178.50218,372.05297 177.49973,366.73564 177.84841,362.29001" + id="path1194" + sodipodi:nodetypes="cszzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 140.95285,349.68999 C 133.28195,370.78498 141.91171,361.71936 146.70603,361.98087" + id="path1195" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 214.47932,349.22398 C 222.15022,370.31897 213.52046,361.25335 208.72614,361.51486" + id="path1218" + sodipodi:nodetypes="cz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;fill-opacity:1.0000000;stroke-dasharray:none;" + d="M 185.21408,214.81126 C 177.92178,214.84746 169.89667,216.34801 165.05912,222.33190 C 161.50198,226.47814 158.94781,231.38316 156.20835,236.05592 C 154.24583,240.57871 150.03197,261.81828 149.86587,269.23814 C 150.70984,281.21595 157.20263,293.02343 167.55100,299.31527 C 175.78925,303.36046 185.45955,303.01158 194.27144,301.44543 C 202.01619,299.89951 208.18824,294.32026 212.14021,287.69026 C 217.68379,279.16981 219.82461,268.45263 217.31152,258.53961 C 216.32638,253.20688 212.48476,234.67682 209.09445,230.93333 C 205.45913,224.31738 200.50275,217.42497 192.63972,215.77674 C 190.22232,215.12439 187.71654,214.81512 185.21408,214.81126 z " + id="path1223" + sodipodi:nodetypes="ccccccccccc" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 180.70208,215.01333 C 181.74811,215.62352 183.81774,213.67597 184.21000,227.75382 C 184.60226,241.83167 184.55612,297.03969 184.90479,299.48044 C 185.25346,301.65968 182.57494,302.51823 179.56086,302.28043" + id="path1220" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 187.98937,214.98472 C 186.94334,215.59491 184.87371,213.64736 184.48145,227.72521 C 184.08919,241.80306 185.05990,297.38091 184.71123,299.82166 C 184.36256,302.00090 187.22600,302.30470 190.24007,302.06691" + id="path1221" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 198.27418,254.64653 C 190.41203,244.47236 191.26648,241.49489 199.51959,235.25317 C 193.82983,232.56245 193.75599,229.68727 203.74206,223.38038" + id="path1224" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 168.46763,255.66748 C 176.32978,245.49331 175.47533,242.51584 167.22222,236.27412 C 172.91198,233.58340 172.98582,230.70822 162.99975,224.40133" + id="path1227" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 180.29127,257.60125 C 177.08610,261.85427 169.96690,256.58422 168.45677,255.56719 C 166.94664,254.55016 164.75849,259.45038 160.32055,257.97107 C 156.06753,256.49176 156.62226,252.23874 156.62226,252.23874" + id="path1228" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 178.41857,269.78296 C 174.28883,271.44718 168.21022,264.73499 166.70009,263.71796 C 165.18996,262.70093 163.00181,267.60115 158.56387,266.12184 C 154.31085,264.64253 152.09187,253.73260 152.09187,253.73260" + id="path1229" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 172.80225,296.62724 C 163.12509,284.60782 172.09341,288.02873 172.43243,282.01902 C 173.14127,276.37914 178.61280,275.40749 174.54738,276.22889 C 171.53434,276.86667 168.64169,272.21856 159.85827,276.10176" + id="path1230" + sodipodi:nodetypes="czsz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 187.87277,256.20713 C 191.07794,260.46015 198.19714,255.19010 199.70727,254.17307 C 201.21740,253.15604 203.40555,258.05626 207.84349,256.57695 C 212.09651,255.09764 211.54178,250.84462 211.54178,250.84462" + id="path1232" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 188.17642,268.38884 C 192.30616,270.05306 199.95382,263.34087 201.46395,262.32384 C 202.97408,261.30681 205.16223,266.20703 209.60017,264.72772 C 213.85319,263.24841 216.07217,252.33848 216.07217,252.33848" + id="path1233" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 196.93084,294.71010 C 206.60800,282.69068 197.63968,286.11159 197.30066,280.10188 C 196.59182,274.46200 191.12029,273.49035 195.18571,274.31175 C 198.19875,274.94953 201.09140,270.30142 209.87482,274.18462" + id="path1234" + sodipodi:nodetypes="czsz" /> + <g + id="g1278" + transform="matrix(0.605285,0.000000,0.000000,0.597196,215.4523,158.0050)" + style=""> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;fill-opacity:1.0000000;stroke-dasharray:none;" + d="M 804.64950,250.44849 C 797.35720,250.48469 789.33209,251.98524 784.49454,257.96913 C 780.93740,262.11537 778.38323,267.02039 775.64377,271.69315 C 773.68125,276.21594 769.46739,297.45551 769.30129,304.87537 C 770.14526,316.85318 776.63805,328.66066 786.98642,334.95250 C 795.22467,338.99769 804.89497,338.64881 813.70686,337.08266 C 821.45161,335.53674 827.62366,329.95749 831.57563,323.32749 C 837.11921,314.80704 839.26003,304.08986 836.74694,294.17684 C 835.76180,288.84411 831.92018,270.31405 828.52987,266.57056 C 824.89455,259.95461 819.93817,253.06220 812.07514,251.41397 C 809.65774,250.76162 807.15196,250.45235 804.64950,250.44849 z " + id="path1255" + sodipodi:nodetypes="ccccccccccc" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 800.13750,250.65056 C 801.18353,251.26075 803.25316,249.31320 803.64542,263.39105 C 804.03768,277.46890 803.99154,332.67692 804.34021,335.11767 C 804.68888,337.29691 802.01036,338.15546 798.99628,337.91766" + id="path1256" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 807.42479,250.62195 C 806.37876,251.23214 804.30913,249.28459 803.91687,263.36244 C 803.52461,277.44029 804.49532,333.01814 804.14665,335.45889 C 803.79798,337.63813 806.66142,337.94193 809.67549,337.70414" + id="path1257" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 817.70960,290.28376 C 809.84745,280.10959 810.70190,277.13212 818.95501,270.89040 C 813.26525,268.19968 813.19141,265.32450 823.17748,259.01761" + id="path1258" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 787.90305,291.30471 C 795.76520,281.13054 794.91075,278.15307 786.65764,271.91135 C 792.34740,269.22063 792.42124,266.34545 782.43517,260.03856" + id="path1259" + sodipodi:nodetypes="ccc" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 799.72669,293.23848 C 796.52152,297.49150 789.40232,292.22145 787.89219,291.20442 C 786.38206,290.18739 784.19391,295.08761 779.75597,293.60830 C 775.50295,292.12899 776.05768,287.87597 776.05768,287.87597" + id="path1260" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 802.03812,301.75908 C 797.90838,303.42330 787.64564,300.37222 786.13551,299.35519 C 784.62538,298.33816 782.43723,303.23838 777.99929,301.75907 C 773.74627,300.27976 771.52729,289.36983 771.52729,289.36983" + id="path1261" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 792.23767,329.12637 C 782.56051,317.10695 791.52883,320.52786 791.86785,314.51815 C 792.57669,308.87827 798.04822,307.90662 793.98280,308.72802 C 790.96976,309.36580 788.07711,304.71769 779.29369,308.60089" + id="path1262" + sodipodi:nodetypes="czsz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 807.30819,291.84436 C 810.51336,296.09738 817.63256,290.82733 819.14269,289.81030 C 820.65282,288.79327 822.84097,293.69349 827.27891,292.21418 C 831.53193,290.73487 830.97720,286.48185 830.97720,286.48185" + id="path1263" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 804.99676,300.36496 C 809.12650,302.02918 819.38924,298.97810 820.89937,297.96107 C 822.40950,296.94404 824.59765,301.84426 829.03559,300.36495 C 833.28861,298.88564 835.50759,287.97571 835.50759,287.97571" + id="path1264" + sodipodi:nodetypes="czzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 814.79721,327.73225 C 824.47437,315.71283 815.50605,319.13374 815.16703,313.12403 C 814.45819,307.48415 808.98666,306.51250 813.05208,307.33390 C 816.06512,307.97168 818.95777,303.32357 827.74119,307.20677" + id="path1265" + sodipodi:nodetypes="czsz" /> + </g> + <g + id="g1266" + transform="matrix(0.487368,0.000000,0.000000,0.429443,313.4603,114.8768)" + style=""> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 794.59961,348.91352 C 790.03327,348.45566 780.97520,354.26681 777.00586,356.66352 C 766.15728,363.21403 755.31838,379.56855 755.31836,395.94477 C 755.31836,400.03884 751.87463,403.64256 756.78711,416.44477 C 762.83073,427.45552 789.50501,430.88985 789.72461,424.10102 C 789.94420,417.31220 785.63328,420.68577 790.94336,415.50727 C 791.10542,425.53543 794.55927,425.71342 794.41211,431.63227 C 794.31794,435.15902 794.12648,443.04382 795.47461,441.69477 L 797.41211,442.00727 L 797.41211,442.13227 L 797.78711,442.06977 L 799.72461,441.75727 C 801.07274,443.10632 800.88128,435.22151 800.78711,431.69477 C 800.63995,425.77592 804.09380,425.59792 804.25586,415.56977 C 809.56594,420.74827 805.25502,417.37469 805.47461,424.16352 C 805.69421,430.95235 832.36849,427.51801 838.41211,416.50727 C 843.32459,403.70506 839.88086,400.10133 839.88086,396.00727 C 839.88084,379.63105 829.04194,363.27652 818.19336,356.72602 C 814.22402,354.32931 805.16595,348.51815 800.59961,348.97602 C 799.07750,349.12864 798.05155,349.97479 797.88086,351.88227 L 797.07659,404.26454 L 797.31836,351.81977 C 797.14767,349.91230 796.12172,349.06614 794.59961,348.91352 z " + id="path1241" + sodipodi:nodetypes="ccccccccccccccccccccccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 755.15810,397.61810 C 754.11207,399.97167 758.80832,400.24407 763.11776,401.94932 C 767.42719,403.65457 771.87284,407.31569 774.50971,408.07842 C 779.78346,409.60388 789.28491,410.08331 793.07678,409.12445 C 796.86865,408.16559 796.56356,405.20183 797.26091,401.27922" + id="path1244" + sodipodi:nodetypes="cszzz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 782.87797,392.91099 C 777.64781,386.11178 787.32360,386.89630 787.84663,382.71217 C 790.46170,372.51336 780.52440,370.94431 780.52440,370.94431 C 780.52440,370.94431 786.53909,363.36057 788.10813,359.17644 C 782.87797,353.42326 783.40098,354.20779 775.29423,357.86890" + id="path1246" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 788.63115,418.53875 C 789.24133,410.95501 783.83682,410.30124 781.57042,409.12445" + id="path1247" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 755.02735,402.26798 C 758.16545,409.59021 769.62822,411.98736 774.90197,413.51282" + id="path1248" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 811.94047,392.52010 C 817.17063,385.72089 807.49484,386.50541 806.97181,382.32128 C 804.35674,372.12247 814.29404,370.55342 814.29404,370.55342 C 814.29404,370.55342 808.27935,362.96968 806.71031,358.78555 C 811.94047,353.03237 811.41746,353.81690 819.52421,357.47801" + id="path1249" + sodipodi:nodetypes="ccccc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 806.18729,418.14786 C 805.57711,410.56412 810.98162,409.91035 813.24802,408.73356" + id="path1250" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 839.79109,401.87709 C 836.65299,409.19932 825.19022,411.59647 819.91647,413.12193" + id="path1251" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.7000000;stroke-dasharray:none;" + d="M 839.64815,397.14271 C 840.69418,399.49628 835.99793,399.76868 831.68849,401.47393 C 827.37906,403.17918 822.93341,406.84030 820.29654,407.60303 C 815.02279,409.12849 805.52134,409.60792 801.72947,408.64906 C 797.93760,407.69020 796.93515,402.37287 797.28383,397.92724" + id="path1252" + sodipodi:nodetypes="cszzz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 760.38827,385.32722 C 752.71737,406.42221 761.34713,397.35659 766.14145,397.61810" + id="path1253" + sodipodi:nodetypes="cz" /> + <path + style="fill:none;fill-rule:evenodd;stroke:black;stroke-opacity:1;stroke-width:1.7000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 833.91474,384.86121 C 841.58564,405.95620 832.95588,396.89058 828.16156,397.15209" + id="path1254" + sodipodi:nodetypes="cz" /> + </g> + <rect + style="font-size:12;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt;" + id="rect1342" + width="106.29922" + height="106.29922" + x="678.02699" + y="257.57566" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt;" + id="rect1300" + width="42.038873" + height="31.251435" + x="577.48017" + y="355.15182" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 585.39981,368.71772 C 595.39981,369.55105 611.65089,374.39889 615.88182,379.14146 C 620.11275,384.31923 621.65174,382.78809 623.97519,388.42080 C 625.83395,393.88440 626.66596,396.13459 614.79096,397.38459 C 602.91596,398.00959 579.84943,391.38777 567.95818,382.48985 C 556.06694,374.46233 550.94562,372.94946 552.82062,361.57922 C 554.69562,349.76704 569.06250,334.86218 591.87500,334.23718 C 614.68750,332.98718 635.31250,340.38301 643.75000,355.48718 C 651.56250,370.59135 648.46967,378.29310 643.78217,382.04310 C 639.09467,385.79310 631.44519,384.45036 623.11186,386.32536" + id="path1301" + sodipodi:nodetypes="czzzzzzzzz" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 611.66596,385.50959 C 604.16596,383.00959 590.35311,382.60170 583.47811,376.35170" + id="path1302" + sodipodi:nodetypes="cc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 592.66063,336.86850 C 598.86190,345.30503 604.92417,355.07014 602.71447,365.23480" + id="path1303" + sodipodi:nodetypes="cc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 609.51069,344.81342 C 624.10275,344.57017 628.11190,344.21099 630.20397,355.19433 C 635.95715,352.05623 638.95397,353.81615 640.20397,366.31615" + id="path1304" + sodipodi:nodetypes="ccc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 620.21706,362.57924 C 620.21706,362.57924 610.95580,381.48089 620.33080,380.85589 C 629.70580,380.23089 626.05002,380.28181 628.70167,379.17696" + id="path1305" + sodipodi:nodetypes="ccc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 565.74009,361.50702 C 565.74009,361.50702 574.14469,356.44952 582.12195,352.00386 C 590.09920,348.08121 587.55049,347.42089 587.77146,341.89662 L 591.98094,350.60103 C 595.33715,357.54102 598.53331,356.11130 595.55959,362.81588" + id="path1306" + sodipodi:nodetypes="czczz" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.8750000;" + d="M 601.31298,337.74082 C 614.47809,348.72995 606.47413,361.56650 612.31037,373.07050" + id="path1307" + sodipodi:nodetypes="cc" + transform="matrix(0.562759,-0.218675,0.000000,0.600895,376.0347,349.5343)" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0903397;" + d="M 707.72710,418.48163 C 703.50641,414.69683 702.27080,417.21075 699.44787,417.57363" + id="path1387" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0903397;" + d="M 725.11736,413.48274 C 719.32763,412.83604 715.73844,415.08845 712.91551,415.45133" + id="path1389" + sodipodi:nodetypes="cc" /> + <path + style="fill:none;fill-opacity:0.75000000;fill-rule:evenodd;stroke:#000000;stroke-width:1.0903397;" + d="M 699.48958,421.09685 C 695.79191,420.95903 688.54161,427.33639 686.24170,435.60327" + id="path1390" + sodipodi:nodetypes="cc" /> + <path + style="font-size:12;fill:url(#linearGradient639);fill-opacity:0.49999997;fill-rule:evenodd;stroke:none;stroke-width:1pt;" + d="M 282.25529,739.70004 C 263.03059,739.70004 246.57621,750.68303 239.10144,766.34845 C 245.01961,769.38040 251.62479,772.25260 259.40914,770.16617 C 274.02627,766.97386 278.59576,759.44837 285.90432,756.25608 C 301.22420,755.68353 308.56128,763.55367 323.66395,763.21113 C 315.56649,749.26108 300.15727,739.70005 282.25529,739.70004 z " + id="path1561" + inkscape:export-filename="C:\pas\mricron\btn\new\autocontrast.png" + inkscape:export-xdpi="22.289494" + inkscape:export-ydpi="22.289494" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient3181);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + id="path1562" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + transform="matrix(1.269231,0,0,1.209574,-59.82695,-177.4099)" + inkscape:export-filename="C:\pas\mricron\btn\new\autocontrast.png" + inkscape:export-xdpi="22.289494" + inkscape:export-ydpi="22.289494" /> + <path + sodipodi:type="arc" + style="font-size:12;fill:url(#radialGradient983);fill-opacity:0.50000000;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none;" + id="path1574" + sodipodi:cx="271.35836792" + sodipodi:cy="796.11926270" + sodipodi:rx="37.42873764" + sodipodi:ry="37.42873764" + d="M 308.787106 796.119263 A 37.428738 37.428738 0 1 0 233.929630,796.119263 A 37.4287 37.4287 0 1 0 308.787 796.119 L 271.358368 796.119263 z" + transform="matrix(0.484769,0.000000,0.000000,0.461984,554.2006,323.4255)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;fill-opacity:1.0000000;" + id="rect1280" + width="69.963570" + height="45.246185" + x="128.72227" + y="535.48883" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt;" + id="rect1278" + width="42.038872" + height="31.251434" + x="158.54723" + y="572.81548" + transform="matrix(-0.578460,0.000000,0.000000,0.578460,265.2767,219.3138)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:4.1057291;" + d="M 163.87618,583.27959 C 173.87618,584.11292 182.62618,587.86292 188.25118,596.40459 C 193.87618,605.57126 193.25118,606.40459 193.25118,606.40459 C 193.25118,606.40459 194.50118,615.15459 182.62618,616.40459 C 170.75118,617.02959 157.44312,604.81988 143.69312,604.81988 C 130.56812,604.81988 125.75118,602.77483 127.62618,591.40459 C 129.50118,579.59241 142.93868,553.90459 165.75118,553.27959 C 188.56368,552.02959 209.18868,559.42542 217.62618,574.52959 C 225.43868,589.63376 221.68868,601.40459 217.00118,605.15459 C 212.31368,608.90459 201.58451,603.90459 193.25118,605.77959" + id="path1279" + sodipodi:nodetypes="czzzzzzzzz" + transform="matrix(-0.578460,0.000000,0.000000,0.578460,265.2767,219.3138)" /> + <g + id="g1249" + transform="translate(-9.414290,-1.046033)" + style=""> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;stroke-dasharray:none;" + id="rect1289" + width="69.963570" + height="45.246185" + x="128.72227" + y="535.48883" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,355.1279,42.36432)" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt;" + id="rect1291" + width="42.038872" + height="31.251434" + x="158.54723" + y="572.81548" + transform="matrix(0.578460,0.000000,0.000000,0.578460,89.85120,261.6781)" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:4.1057290;stroke-dasharray:none;" + d="M 163.87618,583.27959 C 173.87618,584.11292 182.62618,587.86292 188.25118,596.40459 C 193.87618,605.57126 193.25118,606.40459 193.25118,606.40459 C 193.25118,606.40459 194.50118,615.15459 182.62618,616.40459 C 170.75118,617.02959 157.44312,604.81988 143.69312,604.81988 C 130.56812,604.81988 125.75118,602.77483 127.62618,591.40459 C 129.50118,579.59241 142.93868,553.90459 165.75118,553.27959 C 188.56368,552.02959 209.18868,559.42542 217.62618,574.52959 C 225.43868,589.63376 221.68868,601.40459 217.00118,605.15459 C 212.31368,608.90459 201.58451,603.90459 193.25118,605.77959" + id="path1292" + sodipodi:nodetypes="czzzzzzzzz" + transform="matrix(0.578460,0.000000,0.000000,0.578460,89.85120,261.6781)" /> + </g> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;" + id="rect1268" + width="69.963570" + height="45.246185" + x="128.72227" + y="535.48883" + transform="matrix(-1.000000,0.000000,0.000000,1.000000,254.4474,140.4299)" /> + <path + sodipodi:type="arc" + style="fill:#9999ff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:1.0000000pt;" + id="path1285" + sodipodi:cx="88.389725" + sodipodi:cy="698.28027" + sodipodi:rx="18.305565" + sodipodi:ry="18.305565" + d="M 106.69529 698.28027 A 18.305565 18.305565 0 1 0 70.084160,698.28027 A 18.305565 18.305565 0 1 0 106.69529 698.28027 z" + transform="translate(3.138097,1.046032)" /> + <rect + style="fill:#ffffff;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;" + id="rect1290" + width="69.963570" + height="45.246185" + x="-120.45193" + y="551.95033" + transform="scale(-1.000000,1.000000)" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#ff0000;stroke-opacity:1.0000000;stroke-width:2.5000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 51.673228,577.76346 L 120.04088,577.76346" + id="path1299" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#ff0000;stroke-opacity:1.0000000;stroke-width:2.5000000;stroke-linejoin:miter;stroke-linecap:butt;fill-opacity:0.75;stroke-dasharray:none;" + d="M 88.241974,551.52936 L 87.447001,596.44531" + id="path1300" + sodipodi:nodetypes="cc" /> + <rect + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2.3750000;" + id="rect1301" + width="69.963570" + height="45.246185" + x="-120.25873" + y="552.13202" + transform="scale(-1.000000,1.000000)" /> + <rect + style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:1.0000000pt;" + id="rect1302" + width="8.9940901" + height="9.2751551" + x="83.195328" + y="573.14581" /> + <path + style="font-size:12.000000;fill:url(#linearGradient968);fill-opacity:0.70196003;stroke:#1c66f9;stroke-width:1.9242834;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99000001;" + d="M 37.920277,322.15339 C 38.332250,320.95292 39.768025,319.75197 40.999014,319.93377 L 78.169327,327.96556 C 81.048244,325.43887 85.262603,322.36297 89.606623,323.13302 L 95.922292,324.00942 L 103.90333,325.57660 C 108.56248,326.97946 112.24447,329.89321 112.63056,335.69148 L 112.58162,405.54600 L 37.627148,381.65255 L 37.920277,322.15339 z " + id="path1266" + sodipodi:nodetypes="cccccccccc" /> + <path + style="font-size:12.000000;fill:#4789f7;stroke:#1c4ed9;stroke-width:1.7125434;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216002;" + d="M 37.528348,381.35197 L 112.74823,405.58198 L 109.98730,410.63535 L 35.227003,384.92024 L 37.528348,381.35197 z " + id="path1271" + sodipodi:nodetypes="ccccc" /> + <g + id="g1279" + transform="matrix(0.688750,0.000000,0.000000,0.640474,44.12231,204.0360)"> + <path + style="fill-rule:evenodd;stroke:none;stroke-width:0.91963024pt;" + d="M 15.411826,279.67519 L 107.16635,280.32772 L 105.78092,271.91017 C 104.50888,267.92580 100.16017,263.55105 99.313146,259.07319 C 98.024176,254.59533 104.23642,257.47279 103.48688,250.11822 C 102.73733,242.76364 101.33093,223.23927 90.699786,212.93098 C 79.756146,202.93519 70.616996,196.51871 51.220346,199.66990 C 33.073696,201.57109 22.663616,210.23449 15.263856,225.51906 C 7.6727159,240.80363 16.076616,259.82218 15.837966,266.94924 L 15.411826,279.67519 z " + id="path1273" + sodipodi:nodetypes="ccczzzzzzc" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 81.667436,238.66160 C 80.982416,243.33580 68.662856,240.88582 68.468226,248.58013 C 68.273596,255.77527 84.079546,257.18713 89.984786,255.06933 C 95.890036,252.95153 99.758996,249.65718 99.148096,242.36255 C 98.537216,235.06792 96.575586,216.71313 75.014876,206.18816 C 53.886116,196.16236 29.955336,209.82744 22.306536,224.42792 C 14.657726,239.52760 14.049476,254.81975 23.120686,249.32889 C 31.759936,244.33718 42.301146,228.60033 58.113846,226.78187 C 73.494556,224.96340 82.352426,234.98574 81.667436,238.66160 z " + id="path1274" + sodipodi:nodetypes="czzzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.0877723pt;fill-opacity:1.0000000;" + d="M 46.065436,250.14579 C 44.767756,248.03998 45.172386,240.05319 38.251386,241.60591 C 31.330386,243.15862 23.814016,250.57710 21.730276,253.25121 C 19.646536,255.92534 20.762826,260.66971 21.730276,261.79111 C 22.697736,262.91251 28.204756,263.51633 29.767576,264.89651 C 31.330386,266.27670 34.976936,271.45240 36.911836,271.10736 C 38.846746,270.76231 42.790986,266.62175 42.939816,264.89653 C 43.088656,263.17129 47.363086,252.25163 46.065436,250.14579 z " + id="path1275" + sodipodi:nodetypes="czzzzzzz" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:none;stroke-width:1.0507082pt;fill-opacity:1.0000000;" + d="M 42.237126,279.80001 C 42.658006,275.59866 47.388376,258.94410 48.153616,253.91080 C 48.918846,248.87751 46.010966,251.41496 47.235346,249.16869 C 48.459706,246.92241 52.591946,241.63956 55.499816,240.43322 C 58.407706,239.22690 62.539946,239.92518 64.682586,241.04832 C 66.825226,242.17146 68.164386,245.92409 68.355686,247.17200 C 68.546986,248.41993 66.863496,249.83425 65.830426,249.41828 C 64.797366,249.00230 66.447386,242.49537 63.942946,244.49969 C 61.438506,246.68048 58.281376,250.37501 56.647666,251.91412 C 55.338616,253.45321 58.560756,252.66288 59.172936,253.91080 C 59.785116,255.15873 60.932956,257.23860 60.320776,259.40167 C 59.708576,261.56473 57.068536,265.51649 55.499816,266.88920 C 53.931086,268.26192 52.553686,265.59969 50.908446,267.63797 C 49.263196,269.67624 47.037236,278.02692 45.659806,279.98199 L 42.237126,279.80001 z " + id="path1276" + sodipodi:nodetypes="czzzzzzzzzzzzcc" /> + <path + style="fill:#9999ff;fill-opacity:1;fill-rule:evenodd;stroke:#800000;stroke-width:1.875;stroke-dasharray:none" + d="M 41.081076,235.46675 C 41.510266,237.13987 42.851486,241.07668 43.817166,241.96244 C 44.782846,242.84822 46.848346,243.11067 47.197056,241.96244 C 47.545776,240.81421 45.212056,235.04026 51.059786,231.92364 C 57.068466,228.80702 66.457036,229.52876 69.407726,230.93945 C 72.358406,232.35012 77.320946,237.59917 72.626666,241.17509 C 68.737106,244.75098 78.179316,244.84941 80.191156,243.34031 C 82.202996,241.83121 85.125536,236.24432 82.523566,233.55418 C 79.921596,230.86405 73.325156,224.43697 67.209176,223.78085 C 61.093206,223.12471 46.472786,230.41454 44.460956,230.93945 C 42.288186,231.46435 40.651886,233.79361 41.081076,235.46675 z" + id="path1277" + sodipodi:nodetypes="czzzzzzzzzz" /> + </g> + <path + style="font-size:12.000000;fill:url(#linearGradient967);fill-opacity:0.69929999;stroke:#1c66fb;stroke-width:1.7758849;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.99216002;" + d="M 17.536640,337.89268 C 16.523741,335.20546 17.516336,332.64170 19.932441,332.91461 L 55.676174,340.52075 L 57.880936,348.26473 L 73.479955,351.89199 L 71.204233,343.73873 L 87.288253,346.49326 C 89.414399,347.18490 91.065826,348.61636 92.573252,351.89801 L 109.47210,409.98240 L 35.111516,384.77857 L 17.536640,337.89268 z " + id="path1272" + sodipodi:nodetypes="ccccccccccc" /> + <g + id="g1317"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:2.0770884;" + d="M 472.42571,238.27147 C 472.33405,238.27145 472.24478,238.29291 472.15311,238.29398 L 472.15311,238.31648 C 472.08489,238.31034 472.01758,238.29395 471.94867,238.29398 C 471.78809,238.29403 471.63216,238.33557 471.47163,238.33899 L 471.47163,238.42899 C 471.37376,238.41606 471.27556,238.40652 471.17632,238.40649 C 471.10740,238.40647 471.04010,238.42285 470.97187,238.42899 L 470.97187,238.40649 C 470.88021,238.40543 470.79094,238.38396 470.69928,238.38399 C 465.87162,238.38545 461.03877,239.90805 457.81913,242.92943 C 456.20932,244.44011 446.99543,256.89920 450.09559,259.04098 C 457.81097,264.68512 464.49982,248.07035 457.36480,261.85375 C 456.64585,266.58811 456.46107,269.05668 456.41072,270.29207 C 456.30905,268.02898 455.46815,262.72102 451.04967,260.14359 C 447.35854,258.03472 444.93899,276.66261 444.93899,279.18042 C 444.93899,289.25168 451.37986,299.31925 457.81913,303.34776 C 461.08484,305.39084 466.00722,306.37150 470.90372,306.34054 L 470.90372,306.36305 C 471.15408,306.36510 471.40305,306.34374 471.65336,306.34054 L 471.65336,306.22803 C 471.84267,306.23528 472.03155,306.25211 472.22127,306.25053 L 472.22127,306.22803 C 477.11777,306.25899 482.04015,305.27835 485.30586,303.23524 C 491.74513,299.20674 498.18600,289.13916 498.18600,279.06791 C 498.18600,276.55010 495.76645,257.92220 492.07532,260.03107 C 487.65684,262.60851 486.81594,267.91647 486.71427,270.17956 C 486.66392,268.94417 486.47914,266.47559 485.76018,261.74124 C 478.62517,247.95784 485.31402,264.57260 493.02940,258.92847 C 496.12956,256.78669 486.91567,244.32759 485.30586,242.81691 C 482.08622,239.79554 477.25337,238.27293 472.42571,238.27147 z " + id="path1267" + transform="matrix(1.033174,0.000000,0.000000,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.70418520pt;" + d="M 468.24591,259.15861 C 468.51094,258.62567 467.79271,252.85171 466.69475,251.35949 C 465.59679,249.86726 463.96768,250.52503 463.70265,251.05797 C 463.43764,251.59090 465.07594,250.88137 466.17389,252.37359 C 467.27185,253.86581 467.98090,259.69155 468.24591,259.15861 z " + id="path1270" + sodipodi:nodetypes="czzzz" + transform="matrix(1.033174,0.000000,0.000000,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.59326982pt;" + d="M 463.34275,289.21648 C 461.03017,288.99344 460.56786,283.64967 458.96224,286.90958 C 457.28286,290.22776 460.74374,297.34319 461.04820,293.66548 C 461.27890,289.98777 465.58157,289.49777 463.34275,289.21648 z " + id="path1278" + sodipodi:nodetypes="czzz" + transform="matrix(1.033174,0.000000,0.000000,0.909383,216.4479,268.3863)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.68256974pt;" + d="M 708.64967,503.43717 C 708.37585,502.95253 709.11791,497.70179 710.25229,496.34479 C 711.38666,494.98778 713.06983,495.58594 713.34365,496.07058 C 713.61745,496.55524 711.92480,495.90999 710.79043,497.26699 C 709.65604,498.62400 708.92347,503.92182 708.64967,503.43717 z " + id="path1283" + sodipodi:nodetypes="czzzz" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.57505898pt;" + d="M 710.57739,531.81732 C 712.96669,531.61449 713.44433,526.75496 715.10322,529.71946 C 716.83831,532.73696 713.26262,539.20762 712.94806,535.86317 C 712.70970,532.51872 708.26430,532.07312 710.57739,531.81732 z " + id="path1284" + sodipodi:nodetypes="czzz" /> + </g> + <g + id="g1329" + transform="translate(-104.0802,-97.80402)"> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:1.8718444;" + d="M 841.03523,592.70109 C 835.90467,592.76390 830.22818,593.56676 826.67923,597.28291 C 823.87668,600.24935 817.50896,615.99836 816.60602,618.30168 C 815.09992,624.27793 814.05854,630.78886 816.99244,636.56898 C 819.81959,643.25189 825.72828,649.72836 833.94116,650.75621 C 839.37129,651.44267 845.09032,651.35874 850.31458,649.72833 C 856.42815,647.71665 860.44343,642.53509 863.07436,637.37323 C 865.55779,632.40703 865.94287,626.74320 864.51563,621.47197 C 863.89507,618.11627 856.12574,599.89965 853.80199,597.15457 C 850.54532,594.03086 845.67202,592.69881 841.03523,592.70109 z " + id="path1288" + sodipodi:nodetypes="cccccccccc" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.63460236pt;" + d="M 838.07247,610.64237 C 839.95513,610.18459 838.75317,605.01626 837.71507,603.73449 C 836.67696,602.45272 829.77408,601.13926 832.78769,603.68422 C 836.03445,606.02046 835.95665,611.10014 838.07247,610.64237 z " + id="path1289" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.53464689pt;" + d="M 835.74471,629.37680 C 833.55820,629.18522 829.82379,631.67928 828.30569,634.47943 C 826.71786,637.32962 829.99008,643.44151 830.27794,640.28249 C 830.49606,637.12348 837.86149,629.61842 835.74471,629.37680 z " + id="path1290" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.63460231pt;" + d="M 842.27092,610.67154 C 840.38825,610.21376 841.59021,605.04542 842.62832,603.76366 C 843.66642,602.48189 850.56930,601.16843 847.55570,603.71338 C 844.30893,606.04963 844.38672,611.12931 842.27092,610.67154 z " + id="path1293" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + <path + style="fill-rule:evenodd;stroke:#000000;stroke-width:0.53464689pt;" + d="M 844.89363,628.76239 C 847.08014,628.57081 850.81456,631.06487 852.33265,633.86502 C 853.92048,636.71521 850.64827,642.82710 850.36040,639.66808 C 850.14228,636.50907 842.77686,629.00401 844.89363,628.76239 z " + id="path1310" + sodipodi:nodetypes="czzz" + transform="translate(-3.661113,-7.322226)" /> + </g> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#radialGradient704);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.87644994;stroke-dasharray:none" + id="path1268" + sodipodi:cx="271.35837" + sodipodi:cy="796.11926" + sodipodi:rx="37.428738" + sodipodi:ry="37.428738" + d="M 308.78711,796.11926 A 37.428738,37.428738 0 1 1 233.92963,796.11926 A 37.428738,37.428738 0 1 1 308.78711,796.11926 z" + transform="matrix(1.269231,0,0,1.209574,239.61631,-65.007091)" + inkscape:export-filename="C:\pas\mricron\btn\3dx.png" + inkscape:export-xdpi="22.768808" + inkscape:export-ydpi="22.768808" /> + <path + style="font-size:12px;fill:url(#linearGradient1110);fill-opacity:0.38016998;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 584.02153,852.31705 C 564.79683,852.31705 548.34245,863.30004 540.86768,878.96546 C 546.78585,881.99741 553.39103,884.86961 561.17538,882.78318 C 575.79251,879.59087 580.362,872.06538 587.67056,868.87309 C 602.99044,868.30054 610.32752,876.17068 625.43019,875.82814 C 617.33273,861.87809 601.92351,852.31706 584.02153,852.31705 z" + id="path1269" + inkscape:export-filename="C:\pas\mricron\btn\3dx.png" + inkscape:export-xdpi="22.768808" + inkscape:export-ydpi="22.768808" /> + <text + xml:space="preserve" + style="font-size:53.10573959px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;line-height:100%;writing-mode:lr-tb;text-anchor:start;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Arial Black" + x="467.65067" + y="1061.1675" + id="text1284" + sodipodi:linespacing="100%" + transform="scale(1.1590137,0.8628026)" + inkscape:export-filename="C:\pas\mricron\btn\3dx.png" + inkscape:export-xdpi="22.768808" + inkscape:export-ydpi="22.768808"><tspan + x="467.65067" + y="1061.1675" + sodipodi:role="line" + id="tspan1287">3D</tspan></text> + <path + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt" + d="M 862.36154,831.74143 L 862.36154,924.49 C 889.80881,924.49 912.07889,903.73438 912.07886,878.13172 C 912.07886,852.52905 889.80879,831.74141 862.36154,831.74143 z " + id="path3207" /> + <g + id="g4179"> + <path + transform="matrix(1.269231,0,0,1.209574,-252.0699,-51.3724)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path3205" + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:black;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + <path + sodipodi:nodetypes="csccccccc" + id="path2293" + d="M 121.04942,876.41746 C 115.9942,876.41746 85.290278,896.93033 69.807528,903.81184 C 65.343898,905.79576 131.15987,906.55128 131.15987,906.55128 L 82.62969,924.35764 L 92.74016,875.04774 L 51.091495,891.29811 L 65.441938,915.45446 L 113.97211,928.4668 L 82.951128,953.93266" + style="fill:none;fill-rule:evenodd;stroke:red;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path3209" + d="M 92.371567,865.47065 C 73.146867,865.47065 56.692487,876.45364 49.217717,892.11906 C 55.135887,895.15101 61.741067,898.02321 69.525417,895.93678 C 84.142547,892.74447 88.712037,885.21898 96.020597,882.02669 C 111.34048,881.45414 118.67756,889.32428 133.78023,888.98174 C 125.68277,875.03169 110.27355,865.47066 92.371567,865.47065 z " + style="font-size:12px;fill:url(#linearGradient3271);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,0,1.209574,-254.2131,-49.87948)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path3267" + style="font-size:12px;fill:url(#radialGradient3289);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + </g> + <g + id="g4185" + transform="matrix(0.587317,0,0,0.587317,135.8273,373.3777)"> + <path + transform="matrix(1.269231,0,0,1.209574,-252.0699,-51.3724)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4187" + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:black;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + <path + sodipodi:nodetypes="csccccccc" + id="path4189" + d="M 121.04942,876.41746 C 115.9942,876.41746 85.290278,896.93033 69.807528,903.81184 C 65.343898,905.79576 131.15987,906.55128 131.15987,906.55128 L 82.62969,924.35764 L 92.74016,875.04774 L 51.091495,891.29811 L 65.441938,915.45446 L 113.97211,928.4668 L 82.951128,953.93266" + style="fill:none;fill-rule:evenodd;stroke:red;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path4191" + d="M 92.371567,865.47065 C 73.146867,865.47065 56.692487,876.45364 49.217717,892.11906 C 55.135887,895.15101 61.741067,898.02321 69.525417,895.93678 C 84.142547,892.74447 88.712037,885.21898 96.020597,882.02669 C 111.34048,881.45414 118.67756,889.32428 133.78023,888.98174 C 125.68277,875.03169 110.27355,865.47066 92.371567,865.47065 z " + style="font-size:12px;fill:url(#linearGradient4195);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,0,1.209574,-254.2131,-49.87948)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4193" + style="font-size:12px;fill:url(#radialGradient4197);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + </g> + <g + id="g4199" + transform="matrix(0.75239,0,0,0.75239,212.8041,226.4211)"> + <path + transform="matrix(1.269231,0,0,1.209574,-252.0699,-51.3724)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4201" + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:black;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + <path + sodipodi:nodetypes="csccccccc" + id="path4203" + d="M 121.04942,876.41746 C 115.9942,876.41746 85.290278,896.93033 69.807528,903.81184 C 65.343898,905.79576 131.15987,906.55128 131.15987,906.55128 L 82.62969,924.35764 L 92.74016,875.04774 L 51.091495,891.29811 L 65.441938,915.45446 L 113.97211,928.4668 L 82.951128,953.93266" + style="fill:none;fill-rule:evenodd;stroke:red;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path4205" + d="M 92.371567,865.47065 C 73.146867,865.47065 56.692487,876.45364 49.217717,892.11906 C 55.135887,895.15101 61.741067,898.02321 69.525417,895.93678 C 84.142547,892.74447 88.712037,885.21898 96.020597,882.02669 C 111.34048,881.45414 118.67756,889.32428 133.78023,888.98174 C 125.68277,875.03169 110.27355,865.47066 92.371567,865.47065 z " + style="font-size:12px;fill:url(#linearGradient4209);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,0,1.209574,-254.2131,-49.87948)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4207" + style="font-size:12px;fill:url(#radialGradient4211);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + </g> + <g + id="g4213" + transform="matrix(0.355527,0,0,1.090014,324.7627,-82.64672)"> + <path + transform="matrix(1.269231,0,0,1.209574,-252.0699,-51.3724)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4215" + style="font-size:12px;fill:black;fill-opacity:1;fill-rule:evenodd;stroke:black;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + <path + sodipodi:nodetypes="csccccccc" + id="path4217" + d="M 121.04942,876.41746 C 115.9942,876.41746 85.290278,896.93033 69.807528,903.81184 C 65.343898,905.79576 131.15987,906.55128 131.15987,906.55128 L 82.62969,924.35764 L 92.74016,875.04774 L 51.091495,891.29811 L 65.441938,915.45446 L 113.97211,928.4668 L 82.951128,953.93266" + style="fill:none;fill-rule:evenodd;stroke:red;stroke-width:2.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path4219" + d="M 92.371567,865.47065 C 73.146867,865.47065 56.692487,876.45364 49.217717,892.11906 C 55.135887,895.15101 61.741067,898.02321 69.525417,895.93678 C 84.142547,892.74447 88.712037,885.21898 96.020597,882.02669 C 111.34048,881.45414 118.67756,889.32428 133.78023,888.98174 C 125.68277,875.03169 110.27355,865.47066 92.371567,865.47065 z " + style="font-size:12px;fill:url(#linearGradient4223);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1pt" /> + <path + transform="matrix(1.269231,0,0,1.209574,-254.2131,-49.87948)" + d="M 308.78711 796.11926 A 37.428738 37.428738 0 1 1 233.92963,796.11926 A 37.428738 37.428738 0 1 1 308.78711 796.11926 z" + sodipodi:ry="37.428738" + sodipodi:rx="37.428738" + sodipodi:cy="796.11926" + sodipodi:cx="271.35837" + id="path4221" + style="font-size:12px;fill:url(#radialGradient4225);fill-opacity:0.5;fill-rule:evenodd;stroke:none;stroke-width:1.875;stroke-dasharray:none" + sodipodi:type="arc" /> + </g> + <flowRoot + xml:space="preserve" + id="flowRoot4227" + style="font-size:36px;font-weight:bold;fill:navy" + transform="translate(33.72834,142.0141)"><flowRegion + id="flowRegion4229"><rect + id="rect4231" + width="361.5441" + height="35.503513" + x="42.604218" + y="822.77283" + style="font-size:36px;font-weight:bold;fill:navy" /></flowRegion><flowPara + id="flowPara4233">A B C D</flowPara></flowRoot> <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + id="rect2823" + width="42.038872" + height="31.251434" + x="844.13184" + y="324.25101" + inkscape:export-filename="C:\pas\mricron\btn\mricrogl256.png" + inkscape:export-xdpi="234.8979" + inkscape:export-ydpi="234.8979" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 856.65166,333.33636 C 866.65166,334.16969 875.40166,337.91969 881.02666,346.46136 C 886.65166,355.62803 886.02666,356.46136 886.02666,356.46136 C 886.02666,356.46136 887.27666,365.21136 875.40166,366.46136 C 863.52666,367.08636 850.2186,354.87665 836.4686,354.87665 C 823.3436,354.87665 818.52666,352.8316 820.40166,341.46136 C 822.27666,329.64918 835.71416,303.96136 858.52666,303.33636 C 881.33916,302.08636 901.96416,309.48219 910.40166,324.58636 C 918.21416,339.69053 914.46416,351.46136 909.77666,355.21136 C 905.08916,358.96136 894.35999,353.96136 886.02666,355.83636" + id="path2825" + sodipodi:nodetypes="czzzzzzzzz" + inkscape:export-filename="C:\pas\mricron\btn\mricrogl256.png" + inkscape:export-xdpi="234.8979" + inkscape:export-ydpi="234.8979" /> + <path + style="fill:none;fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 872.27666,354.58636 C 864.77666,352.08636 861.65166,352.08636 854.77666,345.83636 C 847.90166,339.58636 846.65166,333.33636 846.65166,333.33636" + id="path2827" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\mricrogl256.png" + inkscape:export-xdpi="234.8979" + inkscape:export-ydpi="234.8979" /> + <path + style="fill:none;fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 864.15166,303.96136 C 864.77666,316.46136 871.57583,324.16932 869.36613,334.33398" + id="path2829" + sodipodi:nodetypes="cc" + inkscape:export-filename="C:\pas\mricron\btn\mricrogl256.png" + inkscape:export-xdpi="234.8979" + inkscape:export-ydpi="234.8979" /> + <path + style="fill:none;fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 877.55642,310.93834 C 892.14848,310.69509 894.76356,313.31017 896.85563,324.29351 C 902.60881,321.15541 905.60563,322.91533 906.85563,335.41533" + id="path2831" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\mricrogl256.png" + inkscape:export-xdpi="234.8979" + inkscape:export-ydpi="234.8979" /> + <path + style="fill:none;fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 886.86872,331.67842 C 886.86872,331.67842 877.60746,350.58007 886.98246,349.95507 C 896.35746,349.33007 892.70168,349.38099 895.35333,348.27614" + id="path2833" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\mricrogl256.png" + inkscape:export-xdpi="234.8979" + inkscape:export-ydpi="234.8979" /> + <path + style="fill:none;fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 832.39175,330.6062 C 832.39175,330.6062 835.53899,323.02 843.51625,318.57434 C 851.4935,314.65169 856.99028,311.87715 857.21125,306.35288 L 856.54834,312.02229 C 855.82047,318.24722 865.18497,325.21048 862.21125,331.91506" + id="path2835" + sodipodi:nodetypes="czczz" + inkscape:export-filename="C:\pas\mricron\btn\mricrogl256.png" + inkscape:export-xdpi="234.8979" + inkscape:export-ydpi="234.8979" /> + <path + style="fill:none;fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 873.54091,303.21172 C 878.8063,313.50201 874.98455,328.73092 878.96203,339.55849" + id="path2837" + sodipodi:nodetypes="cc" + inkscape:export-filename="C:\pas\mricron\btn\mricrogl256.png" + inkscape:export-xdpi="234.8979" + inkscape:export-ydpi="234.8979" /> + <path + style="fill:#000054;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 270.34766,432.89286 C 266.96559,425.47501 260.3235,438.26052 255.49727,449.30783 C 250.67104,460.73738 245.34246,489.00581 249.10203,493.65088 C 252.8616,498.29594 258.35056,495.22819 262.11012,491.11346 C 265.86969,486.99873 263.96524,466.06199 265.1515,456.9486 C 266.02526,447.83521 273.72973,440.31072 270.34766,432.89286 z" + id="path3615" + sodipodi:nodetypes="czzzzz" + inkscape:export-filename="C:\pas\mricron\btn\pen24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="fill:url(#linearGradient3627);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 256.35392,455.89784 C 254.95394,460.00092 253.32225,462.82318 252.15398,468.20706 C 250.98572,473.77723 249.31762,487.55379 250.22768,489.81755 C 251.13775,492.08131 252.46644,490.58625 253.3765,488.58094 C 254.28656,486.57564 253.82556,476.37217 254.11271,471.93078 C 254.32422,467.48938 255.87513,463.1938 256.35392,455.89784 z" + id="path3617" + sodipodi:nodetypes="czzzzc" + inkscape:export-filename="C:\pas\mricron\btn\pen24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 258.32385,516.10881 C 244.70346,512.53166 243.75131,505.12802 247.26278,500.13525 C 248.58676,498.73623 251.70024,496.59237 253.50771,496.72229 C 255.31518,496.85222 256.87341,497.76794 259.19467,499.43037 C 264.4622,503.38022 254.53224,505.09575 258.32385,516.10881 z" + id="path3619" + sodipodi:nodetypes="ccszc" + inkscape:export-filename="C:\pas\mricron\btn\pen24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="font-size:12px;fill:url(#linearGradient3629);fill-rule:evenodd;stroke-width:1pt" + d="M 253.87333,511.50807 C 250.61538,510.68643 249.08112,510.84383 247.06823,505.91817 C 245.05534,501.30501 250.05982,499.78929 250.6541,499.16357 C 251.24838,498.53784 252.11602,498.95109 252.7103,499.50538 C 253.30458,500.05966 253.00354,502.88001 253.19105,504.10765 C 253.32917,505.3353 251.06068,507.46014 253.87333,511.50807 z" + id="path3621" + sodipodi:nodetypes="czzzzc" + inkscape:export-filename="C:\pas\mricron\btn\pen24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <path + style="fill:#ff0000;fill-opacity:1;fill-rule:nonzero;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + id="path3623" + d="M 326.05671,469.55122 C 326.88121,476.3815 303.915,485.28392 302.9894,489.2119 C 301.08731,493.55239 315.97044,503.85687 311.9364,508.99802 C 309.36025,516.74789 269.62905,520.69168 260.38548,518.28589 C 259.23168,516.89349 259.03156,513.70664 261.14461,511.80155 C 266.78432,508.49412 294.51355,511.32311 303.67001,506.3462 C 304.47331,504.25494 293.9717,493.73434 297.19274,488.16929 C 300.56999,481.31221 321.25824,474.15358 320.94168,470.1196 C 317.96164,465.56742 294.87588,458.40487 292.13778,454.47451 C 292.13778,454.47451 322.16638,463.8337 326.05671,469.55122 z" + sodipodi:nodetypes="cccccccccc" + inkscape:export-filename="C:\pas\mricron\btn\pen24.png" + inkscape:export-xdpi="24.462318" + inkscape:export-ydpi="24.462318" /> + <rect + style="fill:url(#linearGradient3646);fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:3.75;stroke-dasharray:none" + id="rect3644" + width="91.25" + height="30" + x="-184.68044" + y="63.382465" + ry="12.5" + transform="scale(-1,1)" + inkscape:export-xdpi="22.535858" + inkscape:export-ydpi="22.535858" + inkscape:export-filename="C:\pas\mricron\btn\new\colorbarzero.png" /> + <path + style="fill:none;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:5.22945166;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 103.12986,109.15218 C 103.12986,114.14532 100.93311,118.19773 98.226386,118.19773 C 95.519665,118.19773 93.322908,114.14532 93.322908,109.15218 C 93.322908,104.15903 95.519665,100.10663 98.226386,100.10663 C 100.93311,100.10663 103.12986,104.15903 103.12986,109.15218 z" + id="path3648" + inkscape:export-filename="C:\pas\mricron\btn\new\colorbarzero.png" + inkscape:export-xdpi="22.535858" + inkscape:export-ydpi="22.535858" /> + <path + sodipodi:type="star" + style="opacity:0.78534031000000004;fill:#0000c0;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="path3650" + sodipodi:sides="3" + sodipodi:cx="139.64716" + sodipodi:cy="147.0226" + sodipodi:r1="9.4676037" + sodipodi:r2="4.7338018" + sodipodi:arg1="-1.5707963" + sodipodi:arg2="-0.52359878" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 139.64716,137.55499 L 143.74675,144.6557 L 147.84634,151.7564 L 139.64716,151.7564 L 131.44797,151.7564 L 135.54756,144.6557 L 139.64716,137.55499 z" + transform="matrix(1,0,0,1.3333333,-15.384856,-87.864153)" + inkscape:export-filename="C:\pas\mricron\btn\new\colorbarzero.png" + inkscape:export-xdpi="22.535858" + inkscape:export-ydpi="22.535858" /> + <path + sodipodi:type="star" + style="opacity:0.78534031000000004;fill:#0000c0;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="path3652" + sodipodi:sides="3" + sodipodi:cx="139.64716" + sodipodi:cy="147.0226" + sodipodi:r1="9.4676037" + sodipodi:r2="4.7338018" + sodipodi:arg1="-1.5707963" + sodipodi:arg2="-0.52359878" + inkscape:flatsided="false" + inkscape:rounded="0" + inkscape:randomized="0" + d="M 139.64716,137.55499 L 143.74675,144.6557 L 147.84634,151.7564 L 139.64716,151.7564 L 131.44797,151.7564 L 135.54756,144.6557 L 139.64716,137.55499 z" + transform="matrix(1,0,0,1.3333333,37.278685,-87.864153)" + inkscape:export-filename="C:\pas\mricron\btn\new\colorbarzero.png" + inkscape:export-xdpi="22.535858" + inkscape:export-ydpi="22.535858" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#0000c0;stroke-width:6;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 246.74941,-78.424713 L 339.05855,-78.424713" + id="path3656" + inkscape:export-filename="C:\pas\mricron\btn\new\crosshairs.png" + inkscape:export-xdpi="20.607124" + inkscape:export-ydpi="20.607124" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#0000c0;stroke-width:6;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;stroke-miterlimit:4;stroke-dasharray:none" + d="M 269.23498,-111.56132 L 269.23498,-12.743213" + id="path3660" + inkscape:export-filename="C:\pas\mricron\btn\new\crosshairs.png" + inkscape:export-xdpi="20.607124" + inkscape:export-ydpi="20.607124" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#ff0000;stroke-width:6;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 246.74941,-37.595672 L 339.05855,-37.595672" + id="path3658" + inkscape:export-filename="C:\pas\mricron\btn\new\crosshairs.png" + inkscape:export-xdpi="20.607124" + inkscape:export-ydpi="20.607124" /> + <path + style="fill:none;fill-rule:evenodd;stroke:#ff0000;stroke-width:6;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 301.18814,-111.56132 L 301.18814,-12.743208" + id="path3662" + inkscape:export-filename="C:\pas\mricron\btn\new\crosshairs.png" + inkscape:export-xdpi="20.607124" + inkscape:export-ydpi="20.607124" /> + <path + sodipodi:type="arc" + style="font-size:12px;fill:url(#linearGradient3670);fill-opacity:0.75000000000000000;fill-rule:evenodd;stroke:#0050fb;stroke-width:5.21357274;stroke-dasharray:none;stroke-opacity:1;stroke-miterlimit:4" + id="path3664" + sodipodi:cx="604.88873" + sodipodi:cy="441.2019" + sodipodi:rx="44.214264" + sodipodi:ry="13.483783" + d="M 649.103,441.2019 A 44.214264,13.483783 0 1 1 560.67447,441.2019 A 44.214264,13.483783 0 1 1 649.103,441.2019 z" + transform="matrix(1.042553,0,0,0.882208,-202.39952,-492.90915)" + inkscape:export-filename="C:\pas\mricron\btn\bucket24.png" + inkscape:export-xdpi="21.807127" + inkscape:export-ydpi="21.807127" /> + <path + style="fill:#fb4100;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 388.75413,-92.159361 C 398.21827,-114.55406 414.50883,-97.128541 426.45531,-96.134721 C 436.85027,-96.631621 437.93631,-123.46525 457.64022,-118.99296 C 466.79401,-116.34273 464.31845,-65.226501 451.12398,-55.884321 C 432.66039,-43.308281 379.28998,-70.261601 388.75413,-92.159361 z" + id="path3666" + sodipodi:nodetypes="cccsz" + inkscape:export-filename="C:\pas\mricron\btn\bucket24.png" + inkscape:export-xdpi="21.807127" + inkscape:export-ydpi="21.807127" /> + <path + style="font-size:12px;fill:url(#radialGradient3672);fill-opacity:0.98999999000000005;stroke:#0c1dfb;stroke-width:5;stroke-linecap:round;stroke-linejoin:round;stroke-opacity:0.98999999000000005;stroke-miterlimit:4;stroke-dasharray:none" + d="M 382.47734,-101.30596 C 393.1275,-92.738341 418.28528,-92.083351 431.66947,-91.877801 C 445.05365,-91.672251 468.18046,-94.547801 474.63455,-102.46773 L 466.32688,-31.133981 C 455.47903,-26.010751 443.69045,-22.870101 430.02041,-23.233561 C 416.35037,-23.597011 399.23099,-25.804731 389.95102,-30.824961 L 382.47734,-101.30596 z" + id="path3668" + sodipodi:nodetypes="czcczcc" + inkscape:export-xdpi="21.807127" + inkscape:export-ydpi="21.807127" + inkscape:export-filename="C:\pas\mricron\btn\bucket24.png" /> + <rect + style="opacity:1;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.89315641;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="rect3682" + width="19.872375" + height="19.872383" + x="575.12762" + y="-127.5102" + inkscape:export-filename="C:\pas\mricron\btn\hires.png" + inkscape:export-xdpi="19.659172" + inkscape:export-ydpi="19.659172" /> + <rect + style="font-size:12px;fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1pt" + id="rect3684" + width="106.29922" + height="106.29922" + x="375" + y="6.0629654" /> + <rect + style="opacity:1;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.89315641;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="rect3700" + width="19.872375" + height="19.872383" + x="595.12762" + y="-107.5102" + inkscape:export-filename="C:\pas\mricron\btn\hires.png" + inkscape:export-xdpi="19.659172" + inkscape:export-ydpi="19.659172" /> + <rect + style="opacity:1;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.89315641;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="rect3702" + width="19.872375" + height="19.872383" + x="615.12762" + y="-87.510201" + inkscape:export-filename="C:\pas\mricron\btn\hires.png" + inkscape:export-xdpi="19.659172" + inkscape:export-ydpi="19.659172" /> + <rect + style="opacity:1;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.89315641;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="rect3704" + width="19.872375" + height="19.872383" + x="595.12762" + y="-67.637817" + inkscape:export-filename="C:\pas\mricron\btn\hires.png" + inkscape:export-xdpi="19.659172" + inkscape:export-ydpi="19.659172" /> + <rect + style="opacity:1;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.89315641;stroke-linecap:butt;stroke-linejoin:miter;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="rect3706" + width="19.872375" + height="19.872383" + x="575.12762" + y="-47.637817" + inkscape:export-filename="C:\pas\mricron\btn\hires.png" + inkscape:export-xdpi="19.659172" + inkscape:export-ydpi="19.659172" /> + <path + style="fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 625,-127.63782 L 665,-77.637811 L 625,-27.637811 L 645,-27.637811 L 685,-77.637811 L 645,-127.63782 L 625,-127.63782 z" + id="path3708" + inkscape:export-filename="C:\pas\mricron\btn\hires.png" + inkscape:export-xdpi="19.659172" + inkscape:export-ydpi="19.659172" /> + <rect + style="fill:#9999ff;fill-rule:evenodd;stroke-width:0.84895535pt" + id="rect2871" + width="42.038872" + height="31.251434" + x="545.31689" + y="-195.52676" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="58.834469" + inkscape:export-ydpi="58.834469" /> + <path + style="fill:#9999ff;fill-rule:evenodd;stroke:#000000;stroke-width:3;stroke-miterlimit:4;stroke-dasharray:none" + d="M 557.83671,-186.4414 C 567.83671,-185.60807 576.58671,-181.85807 582.21171,-173.3164 C 587.83671,-164.14973 587.21171,-163.3164 587.21171,-163.3164 C 587.21171,-163.3164 588.46171,-154.5664 576.58671,-153.3164 C 564.71171,-152.6914 551.40365,-164.90111 537.65365,-164.90111 C 524.52865,-164.90111 519.71171,-166.94616 521.58671,-178.3164 C 523.46171,-190.12858 536.89921,-215.8164 559.71171,-216.4414 C 582.52421,-217.6914 603.14921,-210.29557 611.58671,-195.1914 C 619.39921,-180.08723 615.64921,-168.3164 610.96171,-164.5664 C 606.27421,-160.8164 595.54504,-165.8164 587.21171,-163.9414" + id="path2873" + sodipodi:nodetypes="czzzzzzzzz" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="58.834469" + inkscape:export-ydpi="58.834469" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 573.46171,-165.1914 C 565.96171,-167.6914 562.83671,-167.6914 555.96171,-173.9414 C 549.08671,-180.1914 547.83671,-186.4414 547.83671,-186.4414" + id="path2875" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="58.834469" + inkscape:export-ydpi="58.834469" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 565.33671,-215.8164 C 565.96171,-203.3164 572.76088,-195.60844 570.55118,-185.44378" + id="path2877" + sodipodi:nodetypes="cc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="58.834469" + inkscape:export-ydpi="58.834469" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 578.74147,-208.83942 C 593.33353,-209.08267 595.94861,-206.46759 598.04068,-195.48425 C 603.79386,-198.62235 606.79068,-196.86243 608.04068,-184.36243" + id="path2879" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="58.834469" + inkscape:export-ydpi="58.834469" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 588.05377,-188.09934 C 588.05377,-188.09934 578.79251,-169.19769 588.16751,-169.82269 C 597.54251,-170.44769 593.88673,-170.39677 596.53838,-171.50162" + id="path2881" + sodipodi:nodetypes="ccc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="58.834469" + inkscape:export-ydpi="58.834469" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 533.5768,-189.17156 C 533.5768,-189.17156 536.72404,-196.75776 544.7013,-201.20342 C 552.67855,-205.12607 558.17533,-207.90061 558.3963,-213.42488 L 557.73339,-207.75547 C 557.00552,-201.53054 566.37002,-194.56728 563.3963,-187.8627" + id="path2883" + sodipodi:nodetypes="czczz" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="58.834469" + inkscape:export-ydpi="58.834469" /> + <path + style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:1.875" + d="M 574.72596,-216.56604 C 579.99135,-206.27575 576.1696,-191.04684 580.14708,-180.21927" + id="path2885" + sodipodi:nodetypes="cc" + inkscape:export-filename="C:\pas\mricron\btn\icon.png" + inkscape:export-xdpi="58.834469" + inkscape:export-ydpi="58.834469" /> + <path + style="fill:#000054;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 870,132.36218 C 866.61793,124.94433 859.97584,137.72984 855.14961,148.77715 C 850.32338,160.2067 844.9948,188.47513 848.75437,193.1202 C 852.51394,197.76526 858.0029,194.69751 861.76246,190.58278 C 865.52203,186.46805 863.61758,165.53131 864.80384,156.41792 C 865.6776,147.30453 873.38207,139.78004 870,132.36218 z" + id="path3649" + sodipodi:nodetypes="czzzzz" + inkscape:export-filename="C:\pas\mricron\btn\new\ellipse.png" + inkscape:export-xdpi="23.179588" + inkscape:export-ydpi="23.179588" /> + <path + style="fill:url(#linearGradient3657);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 856.00626,155.36716 C 854.60628,159.47024 852.97459,162.2925 851.80632,167.67638 C 850.63806,173.24655 848.96996,187.02311 849.88002,189.28687 C 850.79009,191.55063 852.11878,190.05557 853.02884,188.05026 C 853.9389,186.04496 853.4779,175.84149 853.76505,171.4001 C 853.97656,166.9587 855.52747,162.66312 856.00626,155.36716 z" + id="path3651" + sodipodi:nodetypes="czzzzc" + inkscape:export-filename="C:\pas\mricron\btn\new\ellipse.png" + inkscape:export-xdpi="23.179588" + inkscape:export-ydpi="23.179588" /> + <path + style="font-size:12px;fill:#ff0000;fill-opacity:1;fill-rule:evenodd;stroke-width:1pt" + d="M 857.97619,215.57813 C 844.3558,212.00098 843.40365,204.59734 846.91512,199.60457 C 848.2391,198.20555 851.35258,196.06169 853.16005,196.19161 C 854.96752,196.32154 856.52575,197.23726 858.84701,198.89969 C 864.11454,202.84954 854.18458,204.56507 857.97619,215.57813 z" + id="path3653" + sodipodi:nodetypes="ccszc" + inkscape:export-filename="C:\pas\mricron\btn\new\ellipse.png" + inkscape:export-xdpi="23.179588" + inkscape:export-ydpi="23.179588" /> + <path + style="font-size:12px;fill:url(#linearGradient3659);fill-rule:evenodd;stroke-width:1pt" + d="M 853.52567,210.97739 C 850.26772,210.15575 848.73346,210.31315 846.72057,205.38749 C 844.70768,200.77433 849.71216,199.25861 850.30644,198.63289 C 850.90072,198.00716 851.76836,198.42041 852.36264,198.9747 C 852.95692,199.52898 852.65588,202.34933 852.84339,203.57697 C 852.98151,204.80462 850.71302,206.92946 853.52567,210.97739 z" + id="path3655" + sodipodi:nodetypes="czzzzc" + inkscape:export-filename="C:\pas\mricron\btn\new\ellipse.png" + inkscape:export-xdpi="23.179588" + inkscape:export-ydpi="23.179588" /> + <path + style="fill:#ff0000;fill-rule:evenodd;stroke:#ff0000;stroke-width:1.17575848000000010px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 390.65262,1036.0046 C 384.32806,1048.6538 406.61585,1048.812 395.65262,1051.0046 C 370.65262,1056.0046 308.87744,994.76187 378.01952,968.07569 C 382.21768,966.45536 370.65262,961.00465 370.65262,961.00465 L 390.65262,966.00465 L 382.4278,982.48397 C 382.4278,982.48397 383.01418,970.71107 380.38642,972.15844 C 327.10227,1001.5074 370.65262,1026.0046 390.65262,1036.0046 z" + id="path2868" + sodipodi:nodetypes="csscccsc" + inkscape:export-filename="C:\pas\mricron\btn\new\refresh.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" /> + <path + style="fill:#ff0000;fill-rule:evenodd;stroke:#ff0000;stroke-width:1.17575848000000010px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="M 398.44156,972.80163 C 404.76612,960.15252 382.47833,959.99427 393.44156,957.80163 C 418.44156,952.80163 480.21674,1014.0444 411.07466,1040.7306 C 406.8765,1042.3509 418.44156,1047.8016 418.44156,1047.8016 L 398.44156,1042.8016 L 406.66638,1026.3223 C 406.66638,1026.3223 406.08,1038.0952 408.70776,1036.6478 C 461.99191,1007.2989 418.44156,982.80163 398.44156,972.80163 z" + id="path2884" + sodipodi:nodetypes="csscccsc" + inkscape:export-filename="C:\pas\mricron\btn\new\refresh.png" + inkscape:export-xdpi="22.14864" + inkscape:export-ydpi="22.14864" /> +</svg> diff --git a/btn/icon.png b/btn/icon.png new file mode 100755 index 0000000..593913b Binary files /dev/null and b/btn/icon.png differ diff --git a/btn/info.bmp b/btn/info.bmp new file mode 100755 index 0000000..a1c3913 Binary files /dev/null and b/btn/info.bmp differ diff --git a/btn/magichat.png b/btn/magichat.png new file mode 100755 index 0000000..28e5dea Binary files /dev/null and b/btn/magichat.png differ diff --git a/btn/mini.svg b/btn/mini.svg new file mode 100755 index 0000000..34a5ab4 --- /dev/null +++ b/btn/mini.svg @@ -0,0 +1,199 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://web.resource.org/cc/" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + id="svg2256" + sodipodi:version="0.32" + inkscape:version="0.45.1" + width="128" + height="128" + version="1.0" + sodipodi:docbase="C:\mricron\html" + sodipodi:docname="mini.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape"> + <metadata + id="metadata2261"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + </cc:Work> + </rdf:RDF> + </metadata> + <defs + id="defs2259"> + <filter + inkscape:collect="always" + id="filter3324"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="3.8223414" + id="feGaussianBlur3326" /> + </filter> + <filter + inkscape:collect="always" + id="filter3502"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="3.1080325" + id="feGaussianBlur3504" /> + </filter> + <filter + inkscape:collect="always" + x="-0.068783067" + width="1.1375661" + y="-0.11711711" + height="1.2342342" + id="filter3528"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="3.5630003" + id="feGaussianBlur3530" /> + </filter> + <filter + inkscape:collect="always" + id="filter3740"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="2.7552379" + id="feGaussianBlur3742" /> + </filter> + <filter + inkscape:collect="always" + id="filter3886"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="4.6432082" + id="feGaussianBlur3888" /> + </filter> + <filter + inkscape:collect="always" + id="filter4027"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="3.4304274" + id="feGaussianBlur4029" /> + </filter> + </defs> + <sodipodi:namedview + inkscape:window-height="870" + inkscape:window-width="1240" + inkscape:pageshadow="2" + inkscape:pageopacity="0.0" + guidetolerance="10.0" + gridtolerance="10.0" + objecttolerance="10.0" + borderopacity="1.0" + bordercolor="#666666" + pagecolor="#ffffff" + id="base" + inkscape:zoom="0.75061011" + inkscape:cx="447.21723" + inkscape:cy="-211.51769" + inkscape:window-x="44" + inkscape:window-y="0" + inkscape:current-layer="svg2256" + width="128px" + height="128px" /> + <g + id="g2187" + transform="matrix(0.1391938,0,0,0.1544313,1.9456067,-0.9518683)"> + <path + id="path2277" + d="M 470.26695,122.56853 C 365.28205,122.51433 104.26695,154.59979 104.26695,154.59978 L 61.829448,179.25603 C 61.829448,179.25603 21.863248,302.11966 17.423248,430.88103 C 12.983148,559.64238 44.079448,694.3185 44.079448,694.31853 L 132.86075,749.56858 L 318.36075,735.75603 L 674.54825,734.75603 C 674.54825,734.75603 766.33255,519.66619 785.07945,464.41228 C 803.82635,409.15837 720.92325,186.16229 720.92325,186.16228 C 720.92325,186.16228 575.90705,127.97069 489.07945,123.03728 C 483.59105,122.72894 477.26595,122.57214 470.26695,122.56853 z M 452.54825,307.53728 C 520.08425,307.53729 574.89195,359.02356 574.89195,422.47478 C 574.89205,485.926 520.08425,537.44353 452.54825,537.44353 C 385.01215,537.44352 330.20445,485.926 330.20445,422.47478 C 330.20435,359.02356 385.01215,307.53728 452.54825,307.53728 z " + style="fill:#aeaeae;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.60000002;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path3506" + d="M 609.43985,154.60357 L 716.98765,188.15059 L 733.76115,227.61767 L 666.66715,190.12394 L 609.43985,154.60357 z " + style="opacity:0.21666667;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3528)" /> + <path + id="path3336" + d="M 66.767548,182.23053 L 53.940748,220.71093 L 75.647648,195.05733 L 85.514448,218.73758 L 128.92825,182.23053 L 275.94305,153.61689 L 329.22365,160.52363 L 379.54415,131.91 L 171.35535,149.67019 L 102.28795,158.55028 L 66.767548,182.23053 z " + style="opacity:0.11111109;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3502)" /> + <path + sodipodi:nodetypes="ccscccsssc" + id="path2281" + d="M 467.79528,122.93964 C 283.97738,122.93964 131.89205,254.99623 131.89195,422.47478 C 131.89195,589.95333 281.07405,725.881 464.89195,725.88103 C 648.70985,725.88103 797.89205,589.95333 797.89195,422.47478 C 797.89195,254.99623 651.61318,122.93964 467.79528,122.93964 z M 474.76695,238.47478 C 587.23635,238.47479 678.51695,323.3403 678.51695,427.91228 C 678.51695,532.48427 587.23625,617.34978 474.76695,617.34978 C 362.29765,617.34976 271.01695,532.48426 271.01695,427.91228 C 271.01695,323.34031 362.29765,238.47478 474.76695,238.47478 z " + style="opacity:1;fill:#009990;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccscsc" + id="path3330" + d="M 466.52265,725.68157 C 299.87515,725.68157 162.26495,611.74002 142.65745,468.59724 C 156.42695,468.85724 228.20685,714.18323 470.91455,708.76876 C 731.14935,702.96329 765.39815,528.42344 778.72845,487.00424 C 793.92915,472.92559 792.19825,449.23943 791.78785,460.80489 C 786.85445,600.80324 635.75525,722.72157 466.52265,725.68157 z " + style="opacity:0.46111109;fill:#030103;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <path + id="path2294" + d="M 474.76695,238.47478 C 362.29765,238.47478 271.01695,323.34031 271.01695,427.91228 C 271.01695,532.48426 362.29765,617.34976 474.76695,617.34978 C 587.23625,617.34978 678.51695,532.48427 678.51695,427.91228 C 678.51695,323.3403 587.23635,238.47479 474.76695,238.47478 z M 451.57945,320.34978 C 508.22255,320.3498 554.17325,366.55931 554.17325,423.47478 C 554.17315,480.39023 508.22255,526.56853 451.57945,526.56853 C 394.93625,526.56852 348.95445,480.39025 348.95445,423.47478 C 348.95435,366.55928 394.93635,320.34978 451.57945,320.34978 z " + style="opacity:1;fill:#c0c0c0;fill-opacity:1;stroke:#000000;stroke-width:2;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccccc" + id="path2315" + d="M 306.76523,520.33116 L 426.88496,525.12996 L 489.56056,590.7715 L 308.50345,604.52828 L 306.76523,520.33116 z " + style="fill:#999999;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="cczc" + id="path2279" + d="M 108.20795,428.89977 L 60.847448,441.72657 C 60.847448,441.72657 62.080848,351.44563 72.687648,282.87158 C 83.294448,214.29753 104.26125,154.60357 104.26125,154.60357" + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="cccccccc" + id="path2309" + d="M 751.52135,549.27437 L 751.52135,585.78141 L 720.93435,613.40837 L 561.09275,608.47498 L 530.50575,581.83471 L 526.55895,504.8739 L 735.73455,535.46089 L 751.52135,549.27437 z " + style="fill:#999999;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path2311" + d="M 531.49245,578.87467 L 384.47755,555.19443 L 452.55825,591.70148 L 562.07935,608.47498 L 531.49245,578.87467 z " + style="fill:#999999;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccscsc" + id="path2317" + d="M 463.7235,127.87852 C 297.076,127.87852 157.53025,237.94896 137.92275,381.09174 C 149.7567,345.02397 227.41885,129.58569 470.12655,135.00016 C 730.36135,140.80563 760.66345,321.26554 773.99375,362.68474 C 789.19445,376.76339 790.39498,394.5644 788.9887,383.07743 C 772.44198,247.91796 643.8095,127.87849 463.7235,127.87852 z " + style="opacity:0.3;fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;filter:url(#filter3324)" /> + <path + sodipodi:nodetypes="cccccccc" + id="path2305" + d="M 382.50415,501.91387 L 365.73065,482.18033 L 629.38633,496.56043 L 711.06765,535.46089 L 683.13773,575.61175 L 547.27925,561.11449 L 541.20784,513.4511 L 382.50415,501.91387 z " + style="fill:#848484;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path3328" + d="M 634.10685,520.66073 L 384.47755,500.92719" + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccccc" + id="path2313" + d="M 384.47755,555.19443 L 382.50415,500.92719 L 532.47905,511.78064 L 529.51905,578.87467 L 384.47755,555.19443 z " + style="fill:#999999;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccscscsc" + id="path2275" + d="M 108.20795,429.88645 L 321.33025,431.8598 C 321.33025,431.8598 337.11705,439.75322 330.21025,528.55414 C 323.30355,617.35507 322.31685,735.75631 322.31685,735.75631 C 322.31685,735.75631 315.41015,749.56978 303.56995,750.55648 C 291.72985,751.54318 134.84825,750.55648 134.84825,750.55648 C 134.84825,750.55648 107.22135,642.02201 112.15475,556.18111 C 117.08805,470.34021 109.19465,428.89977 108.20795,429.88645 z " + style="fill:#b4b4b4;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccccccccccccc" + id="path2307" + d="M 629.11678,496.99938 L 634.16352,520.67963 L 650.13935,527.56747 L 657.93823,541.41875 L 672.64392,548.28769 L 680.53732,575.91464 L 826.11952,576.84462 L 834.90434,548.2665 L 848.05259,541.93894 L 855.42734,528.18433 L 871.55888,521.89313 L 877.24515,498.95384 L 629.11678,496.99938 z " + style="fill:#acacac;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="cszccc" + id="path3534" + d="M 47.034048,692.34253 C 47.034048,692.34253 20.147048,566.78788 28.287148,529.54082 C 36.427248,492.29376 39.880548,565.8012 60.847448,582.82138 C 81.814348,599.84156 106.23465,589.72812 106.23465,589.72812 L 130.90155,745.62308 L 47.034048,692.34253 z " + style="opacity:0.05;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3740)" /> + <path + sodipodi:nodetypes="cscscsc" + id="path3744" + d="M 117.08805,589.72812 C 219.70245,717.00945 313.43685,599.59489 319.35685,628.20852 C 325.27695,656.82215 308.50345,721.94284 308.50345,721.94284 C 308.50345,721.94284 290.74315,737.72967 280.87645,738.71635 C 271.00965,739.70301 138.79505,740.6897 138.79505,740.6897 C 138.79505,740.6897 123.00815,684.69578 118.07475,644.98203 C 113.14135,605.26828 117.08805,589.72812 117.08805,589.72812 z " + style="opacity:0.04444442;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3886)" /> + <path + sodipodi:nodetypes="cccsccc" + id="path3890" + d="M 473.78025,229.59469 C 434.90905,229.59469 314.69695,282.2284 294.64115,319.47409 C 290.33955,354.11247 349.78446,363.88688 360.04246,359.01822 C 377.76996,330.10206 409.13294,310.56167 463.43924,312.53502 C 509.92934,314.25561 528.74162,338.97444 542.10032,364.69155 C 595.00092,374.15948 643.67325,321.97478 643.67325,321.97478 C 607.04255,271.60155 544.05705,229.5947 473.78025,229.59469 z " + style="opacity:0.13888891;fill:#646464;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;filter:url(#filter4027)" /> + </g> +</svg> diff --git a/btn/new/3dx.png b/btn/new/3dx.png new file mode 100755 index 0000000..ac07a1d Binary files /dev/null and b/btn/new/3dx.png differ diff --git a/btn/new/Thumbs.db b/btn/new/Thumbs.db new file mode 100755 index 0000000..7d3d5d5 Binary files /dev/null and b/btn/new/Thumbs.db differ diff --git a/btn/new/autoclose24.png b/btn/new/autoclose24.png new file mode 100755 index 0000000..59aa436 Binary files /dev/null and b/btn/new/autoclose24.png differ diff --git a/btn/new/autocontrast.png b/btn/new/autocontrast.png new file mode 100755 index 0000000..8986d08 Binary files /dev/null and b/btn/new/autocontrast.png differ diff --git a/btn/new/bucket24.png b/btn/new/bucket24.png new file mode 100755 index 0000000..dde2a4a Binary files /dev/null and b/btn/new/bucket24.png differ diff --git a/btn/new/bucket24x.png b/btn/new/bucket24x.png new file mode 100755 index 0000000..95a24c7 Binary files /dev/null and b/btn/new/bucket24x.png differ diff --git a/btn/new/colorbar.png b/btn/new/colorbar.png new file mode 100755 index 0000000..10aba6f Binary files /dev/null and b/btn/new/colorbar.png differ diff --git a/btn/new/colorbarzero.png b/btn/new/colorbarzero.png new file mode 100755 index 0000000..997097a Binary files /dev/null and b/btn/new/colorbarzero.png differ diff --git a/btn/new/crosshairs.png b/btn/new/crosshairs.png new file mode 100755 index 0000000..a0ba0c0 Binary files /dev/null and b/btn/new/crosshairs.png differ diff --git a/btn/new/ellipse.png b/btn/new/ellipse.png new file mode 100755 index 0000000..88fe9d9 Binary files /dev/null and b/btn/new/ellipse.png differ diff --git a/btn/new/hat.png b/btn/new/hat.png new file mode 100755 index 0000000..253cd8a Binary files /dev/null and b/btn/new/hat.png differ diff --git a/btn/new/hires.bmp b/btn/new/hires.bmp new file mode 100755 index 0000000..f033ee3 Binary files /dev/null and b/btn/new/hires.bmp differ diff --git a/btn/new/hires.png b/btn/new/hires.png new file mode 100755 index 0000000..50e18a9 Binary files /dev/null and b/btn/new/hires.png differ diff --git a/btn/new/hires16.png b/btn/new/hires16.png new file mode 100755 index 0000000..4a13d96 Binary files /dev/null and b/btn/new/hires16.png differ diff --git a/btn/new/hires16b.png b/btn/new/hires16b.png new file mode 100755 index 0000000..090aadd Binary files /dev/null and b/btn/new/hires16b.png differ diff --git a/btn/new/hires16lx.png b/btn/new/hires16lx.png new file mode 100755 index 0000000..3d6399d Binary files /dev/null and b/btn/new/hires16lx.png differ diff --git a/btn/new/hires16win.PNG b/btn/new/hires16win.PNG new file mode 100755 index 0000000..09aadb6 Binary files /dev/null and b/btn/new/hires16win.PNG differ diff --git a/btn/new/hires16winz.PNG b/btn/new/hires16winz.PNG new file mode 100755 index 0000000..d3593c3 Binary files /dev/null and b/btn/new/hires16winz.PNG differ diff --git a/btn/new/hires256.png b/btn/new/hires256.png new file mode 100755 index 0000000..39bfa48 Binary files /dev/null and b/btn/new/hires256.png differ diff --git a/btn/new/hires256b.png b/btn/new/hires256b.png new file mode 100755 index 0000000..e81d2c4 Binary files /dev/null and b/btn/new/hires256b.png differ diff --git a/btn/new/magichat.png b/btn/new/magichat.png new file mode 100755 index 0000000..48edb63 Binary files /dev/null and b/btn/new/magichat.png differ diff --git a/btn/new/pen24.png b/btn/new/pen24.png new file mode 100755 index 0000000..92991fc Binary files /dev/null and b/btn/new/pen24.png differ diff --git a/btn/new/refresh.png b/btn/new/refresh.png new file mode 100755 index 0000000..2c650b4 Binary files /dev/null and b/btn/new/refresh.png differ diff --git a/btn/pastedpic_08032008_133503.png b/btn/pastedpic_08032008_133503.png new file mode 100755 index 0000000..380f280 Binary files /dev/null and b/btn/pastedpic_08032008_133503.png differ diff --git a/btn/pen.bmp b/btn/pen.bmp new file mode 100755 index 0000000..388ac62 Binary files /dev/null and b/btn/pen.bmp differ diff --git a/btn/penauto.bmp b/btn/penauto.bmp new file mode 100755 index 0000000..0bdf6cf Binary files /dev/null and b/btn/penauto.bmp differ diff --git a/btn/refresh.bmp b/btn/refresh.bmp new file mode 100755 index 0000000..9f323a9 Binary files /dev/null and b/btn/refresh.bmp differ diff --git a/btn/render.png b/btn/render.png new file mode 100755 index 0000000..3f8ef52 Binary files /dev/null and b/btn/render.png differ diff --git a/btn/reslicing.svg b/btn/reslicing.svg new file mode 100755 index 0000000..52dd090 --- /dev/null +++ b/btn/reslicing.svg @@ -0,0 +1,192 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:xlink="http://www.w3.org/1999/xlink" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + width="744.09448819" + height="1052.3622047" + id="svg2" + sodipodi:version="0.32" + inkscape:version="0.46" + sodipodi:docname="reslicing.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape" + inkscape:export-filename="C:\Documents and Settings\Admin\Desktop\image.png" + inkscape:export-xdpi="200" + inkscape:export-ydpi="200"> + <defs + id="defs4"> + <inkscape:perspective + sodipodi:type="inkscape:persp3d" + inkscape:vp_x="0 : 526.18109 : 1" + inkscape:vp_y="0 : 1000 : 0" + inkscape:vp_z="744.09448 : 526.18109 : 1" + inkscape:persp3d-origin="372.04724 : 350.78739 : 1" + id="perspective10" /> + <inkscape:perspective + id="perspective2467" + inkscape:persp3d-origin="372.04724 : 350.78739 : 1" + inkscape:vp_z="744.09448 : 526.18109 : 1" + inkscape:vp_y="0 : 1000 : 0" + inkscape:vp_x="0 : 526.18109 : 1" + sodipodi:type="inkscape:persp3d" /> + </defs> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#666666" + borderopacity="1.0" + gridtolerance="10000" + guidetolerance="10" + objecttolerance="10" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="1.1394642" + inkscape:cx="333.03081" + inkscape:cy="664.38863" + inkscape:document-units="px" + inkscape:current-layer="layer1" + showgrid="false" + inkscape:window-width="1280" + inkscape:window-height="740" + inkscape:window-x="-4" + inkscape:window-y="-4" /> + <metadata + id="metadata7"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + </cc:Work> + </rdf:RDF> + </metadata> + <g + inkscape:label="Layer 1" + inkscape:groupmode="layer" + id="layer1"> + <rect + style="opacity:1;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.26454818;stroke-linecap:square;stroke-linejoin:bevel;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" + id="rect3325" + width="756.53131" + height="369.50735" + x="-14.937018" + y="178.24945" /> + <g + id="g3280" + transform="translate(-8.7760542,1.1538605e-6)"> + <rect + ry="48.268299" + y="194.79956" + x="13.899533" + height="298.67014" + width="231.09453" + id="rect2475" + style="opacity:1;fill:#0000ff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:6.22613287;stroke-linecap:square;stroke-linejoin:bevel;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" /> + <rect + ry="0" + y="259.4205" + x="13.138862" + height="169.42827" + width="232.61589" + id="rect3260" + style="opacity:1;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:4.70479012;stroke-linecap:square;stroke-linejoin:bevel;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" /> + <image + transform="matrix(0.9925462,0.1218693,-0.1218693,0.9925462,0,0)" + xlink:href="C:\Documents and Settings\Admin\Desktop\resx2.png" + sodipodi:absref="C:\Documents and Settings\Admin\Desktop\resx2.png" + width="166.48691" + height="123.87494" + id="image2469" + x="86.945564" + y="265.15503" /> + </g> + <image + y="285.70758" + x="252.0018" + id="image3262" + height="123.87494" + width="166.48691" + sodipodi:absref="C:\Documents and Settings\Admin\Desktop\resx2.png" + xlink:href="C:\Documents and Settings\Admin\Desktop\resx2.png" /> + <image + y="435.22598" + x="-423.86765" + id="image3264" + height="123.87494" + width="166.48691" + sodipodi:absref="C:\Documents and Settings\Admin\Desktop\resx2.png" + xlink:href="C:\Documents and Settings\Admin\Desktop\resx2.png" + transform="matrix(0,-1,1,0,0,0)" /> + <g + id="g3301"> + <rect + y="245.90759" + x="587.1828" + height="182.41235" + width="143.79771" + id="rect3268" + style="opacity:1;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1.42956602999999990;stroke-linecap:square;stroke-linejoin:bevel;marker:none;marker-start:none;marker-mid:none;marker-end:none;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;visibility:visible;display:inline;overflow:visible;enable-background:accumulate" /> + <image + style="stroke:#0000ff;stroke-opacity:1;fill:#00d8ff;fill-opacity:1;stroke-width:1.3;stroke-miterlimit:4;stroke-dasharray:none" + transform="matrix(0.1218693,-0.9925462,0.9925462,0.1218693,0,0)" + xlink:href="C:\Documents and Settings\Admin\Desktop\resx2.png" + sodipodi:absref="C:\Documents and Settings\Admin\Desktop\resx2.png" + width="166.48691" + height="123.87495" + id="image3266" + x="-337.52261" + y="633.31537" /> + </g> + <flowRoot + xml:space="preserve" + id="flowRoot3272" + style="font-size:36px;font-style:normal;font-weight:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Bitstream Vera Sans" + transform="translate(57.044353,-35.135272)"><flowRegion + id="flowRegion3274"><rect + id="rect3276" + width="202.72685" + height="78.10688" + x="27.205769" + y="531.06458" + style="font-size:36px" /></flowRegion><flowPara + id="flowPara3278">Scan</flowPara></flowRoot> <flowRoot + xml:space="preserve" + id="flowRoot3285" + style="font-size:36px;font-style:normal;font-weight:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Bitstream Vera Sans" + transform="translate(256.87221,-35.574725)"><flowRegion + id="flowRegion3287"><rect + id="rect3289" + width="202.72685" + height="78.10688" + x="27.205769" + y="531.06458" + style="font-size:36px" /></flowRegion><flowPara + id="flowPara3291">Raw</flowPara></flowRoot> <text + xml:space="preserve" + style="font-size:40px;font-style:normal;font-weight:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Bitstream Vera Sans" + x="435.41766" + y="528.93951" + id="text3293"><tspan + sodipodi:role="line" + id="tspan3295" + x="435.41766" + y="528.93951">Ortho</tspan></text> + <text + xml:space="preserve" + style="font-size:40px;font-style:normal;font-weight:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Bitstream Vera Sans" + x="573.07635" + y="528.4317" + id="text3297"><tspan + sodipodi:role="line" + id="tspan3299" + x="573.07635" + y="528.4317">Resliced</tspan></text> + </g> +</svg> diff --git a/btn/roi3d.bmp b/btn/roi3d.bmp new file mode 100755 index 0000000..1d0703c Binary files /dev/null and b/btn/roi3d.bmp differ diff --git a/btn/roiellipse.bmp b/btn/roiellipse.bmp new file mode 100755 index 0000000..53d26e2 Binary files /dev/null and b/btn/roiellipse.bmp differ diff --git a/btn/roifill.bmp b/btn/roifill.bmp new file mode 100755 index 0000000..52ed70e Binary files /dev/null and b/btn/roifill.bmp differ diff --git a/btn/roihide.bmp b/btn/roihide.bmp new file mode 100755 index 0000000..408a0e1 Binary files /dev/null and b/btn/roihide.bmp differ diff --git a/btn/xbars.bmp b/btn/xbars.bmp new file mode 100755 index 0000000..88832be Binary files /dev/null and b/btn/xbars.bmp differ diff --git a/btn/zcolor.png b/btn/zcolor.png new file mode 100755 index 0000000..35492ca Binary files /dev/null and b/btn/zcolor.png differ diff --git a/btn/zcolorbar.bmp b/btn/zcolorbar.bmp new file mode 100755 index 0000000..20a4aa6 Binary files /dev/null and b/btn/zcolorbar.bmp differ diff --git a/changes.txt b/changes.txt new file mode 100755 index 0000000..1f89467 --- /dev/null +++ b/changes.txt @@ -0,0 +1,40 @@ +2/2010 + +dcm2niigui: help/preferences allows you to specifiy output folder. This can be a fixed location, or the user can be prompted with each conversion. + +dcm2nii: option to process only specified files rather than searching all in folder. + +MRIcron: Unix version: improved peristimulus plot data export (previous version only saved up to 255 characters per row) + +MRIcron: Windows7 64-bit no longer reports floating point error. + +dcm2niigui: Ability to select export directory. Previous version saved data to input directory. If you select Help/Preferences you can now select three modes: "Save to source folder" (default), "Prompt user for output folder", "Always save to...". + -- "Prompt user for output folder" every time a series of images is dropped onto dcm2niigui, the user is requested to specify the output folder. + -- "Always save to..." when this option is selected the user is requested to select an output folder. All future conversions are sent to this folder. + +dcm2niigui: The ini files (stored in ~/.dcm2niigui for Unix and in the application directory for Windows) include two new properties: OutDirMode and OutDir + -- "OutDirMode" this can have three values: 0="Save to source folder", 1="Prompt user for output folder", 2="Always save to..." + -- "OutDir" This string lists the location for saving files if OutDirMode=2, and the starting location for selecting a folder for OutDirMode=1. If this is blank or a non-existent folder, it reverts to the users home directory (for Windows, this is the Documents folder). + +dcm2niigui: If dcm2niigui is unable to find a ini file in ~/.dcm2niigui, it will open up the defaults file dcm2niigui.ini located in the same folder as the application. This allows Unix administrators give all users consistent settings tuned for their site (e.g. defaulting to SPM or FSL style files, etc). + +dcm2niigui: Previous Linux 64-bit versions of dcm2niigui could have problems if the user did not have write permissions to the input images. This has been fixed. + +dcm2niigui: now checks whether the user has write permission to the output directory, and gives the user a clear description of the problem if the output folder is read-only. + + +---- +2009 +MRIcron + +Images now shown with 2x2 row column format, with Coronal, Sagital on top row and Axial on second row. To return to old horizontal layout, choose Help/Preferences and select "All slices on single row" + +Improved load of overlays on images with very few slices (I suggest you make sure View/3DSmoothOverlays is UNCHECKED if your background image only has a few slices). + +The .ini file now includes the option "FlipAx=0", if you change this with a text-editor to read "FlipAx=1" and relaunch MRIcron the axial images will be displayed upside down (emulating ImageJ when viewing Analyze images). + +Draw/Statistics/BatchProbMaps now reports mean instead of sum (with header text now saying "mean" instead of "filename). This ensures that one gets the same values as Draw/Descriptive (which reports mean, not sum). This also means that units are easier to interpret (as you do not have to divide the sum by the VOI's volume). + +Removed View/Magnify tool from Windows version (I think there are better screen magnifiers). +dcm2nii + +4D par/rec files can now have different scaling factors + +Philips has a new value in the ini file - use "PhilipsPrecise=0" to convert the DV (display values), use "PhilipsPrecise=1" for the FP (Floating point) values. Note that the raw image data is identical, this simply adjusts the scaling factor applied to the data. The "PhilipsPrecise=1" gives the correct values for Phase maps (from -Pi..+Pi) and diffusion images, but many people complain about the huge values generated for T1/T2 images where the scaling factor is arbitrary. In most cases, your selection will not influence data processing in any way (as fMRI/T1/T2 values are relative). + +GE. Some GE scanners will interpolate images to simulate higher-resolution. If you set "UseGE_0021_104F=0" then you will get one image for the actual slices and one for the interpolated slices. If you set "UseGE_0021_104F=1" you will get a single large volume that combines the interpolated and actual slices. + +Philips 4D DICOM image conversion is improved, but this format is changing very rapidly. My software assume all images in a 4D image have the same scaling factors. This is fine form images where signal is relative. However, when you have a image where the 4th dimesion is between modalities (e.g. some images have modulus and some have phase) then the scaling factor may not be preserved. The raw data is correct, but some images with absolute values (phase or diffusion) images may need rescaling. + +When run from the command line, specifying folders is now case sensitive. This fix is specific for Linux users. +NPM + +VLSM commands - Previous version did not always conduct statistical tests on all the voxels (some ventral voxels might show Z=0). +MRIcroGL + +Render/Clip is now viewpoint independent. Previous version always cut slices from viewer's location, new version includes sliders to specify the elevation and azimuth of the clip plane. The scripting includes the new command "CLIPAZIMUTHELEVATION" as well as the old view-point dependent "clip" command. + +Program should not crash if your video card can not support the input image (you will get a polite message describing the problem). + +Help/Preferences adds a new rendering pull-down menu that allows you to choose between three rendering modes: standard (best quality, but slow), fast but blurry, and disabled. In the disabled mode you see orthogonal slices instead of a rendering, which is useful for slow video cards. + +Better display of statistical images as background image (SPM uses 'Not A Number' values for areas where no statistics are calculated). + +More significant digits for statistcal outputs. + +-------------------------------- diff --git a/chris_t1.nii.gz b/chris_t1.nii.gz new file mode 100755 index 0000000..d8d67fb Binary files /dev/null and b/chris_t1.nii.gz differ diff --git a/clustering.pas b/clustering.pas new file mode 100755 index 0000000..7908b16 --- /dev/null +++ b/clustering.pas @@ -0,0 +1,230 @@ +unit clustering; +//USED by stats to select only regions with a given number of connected/contiguous voxels +interface +uses define_types,dialogs,SysUtils,nifti_hdr,nifti_img; + +//procedure FindClusters (lMultiBuf: SingleP; lXdim, lYDim, lZDim, lThreshClusterSz: integer; lMinNeg, lMinPos: single); + +function ClusterFilterScrnImg (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double ): boolean; + + +implementation + + + + + +procedure FindClusters (var lHdr: TMRIcroHdr; lXdim, lYDim, lZDim, lThreshClusterSz: integer; lThresh: double); +var + lThreshClusterSzM1,lScaledThresh,lClusterSign,lClusterSz,lClusterFillValue,lQTail,lQHead,lSliceSz,lQSz,lInc,lVolSz: integer; + lClusterBuff, lQra: LongIntP; + lBuffIn32 : SingleP; + lBuffIn16 : SmallIntP; + lScaledThreshFloat: double; + //lFdata: file;//abba - test +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; + + procedure Check(lPixel: integer); + begin + //if lClusterFillValue = kFillvalue then showmessage(inttostr(lPixel)+'@'); + if (lClusterBuff^[lPixel]=lClusterSign) then begin//add item + //if lClusterFillValue = kFillvalue then showmessage(inttostr(lPixel)); + incQra(lQHead,lQSz); + inc(lClusterSz); + lClusterBuff^[lPixel] := lClusterFillValue; + lQra^[lQHead] := lPixel; + end; + end; + + +PROCEDURE RetirePixel; //FIFO cleanup , 1410: added 18-voxel check +VAR + lXDimM,lVal,lValX,lXPos,lYPos,lZPos: integer; +BEGIN + lVal := lQra^[lQTail]; + if lVal = 0 then begin + //should never happen: unmarked voxel = increment lQTail so not infinite loop + incQra(lQTail,lQSz); //done with this pixel + exit; + end; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + if (lXPos <= 1) or (lXPos >= lXDim) or + (lYPos <= 1) or (lYPos >= lYDim) or + (lZPos <= 1) or (lZPos >= lZDim) then + // retire and exit +else begin +lXDimM := lXDim; + Check(lVal-1); //left + Check(lVal+1); //right + Check(lVal-lXDimM); //up + Check(lVal+lXDimM); //down + Check(lVal-lSliceSz); //up + Check(lVal+lSliceSz); //down + //check plane above + lValX := lVal + lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check plane below + lValX := lVal - lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check diagonals of current plane + Check(lVal-lXDimM-1); //up, left + Check(lVal-lXDimM+1); //up, right + + Check(lVal+lXDimM-1); //down, left + Check(lVal+lXDimM+1); //down, right +end;{} //not edge + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + if (lClusterBuff^[lPt]<>lClusterSign) then exit; + for lI := 1 to lQsz do + lQra^[lI] := 0; + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + // check that there was anything in the cluster at all + //showmessage('head'+inttostr(lQHead)+'.'+inttostr(lQTail)); + //if lQHead > 2 then begin + // and do the recursion to get rid of it + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; + //end; + //showmessage('alldone'); +end; + +procedure SelectClusters (lSign: integer); +var lInc: integer; +begin + for lInc := 1 to lVolSz do begin + if lClusterBuff^[lInc] = lSign then begin + // measure size of the cluster and fill it with kFillValue + lClusterSz := 0; + lClusterSign := lSign; + lClusterFillValue := kFillValue; + FillStart(lInc); + // now fill the cluster with its size (=1 if the voxel was isolated) + lClusterFillValue := lClusterSz; + lClusterSign := kFillValue; + //if lClusterSz > 1 then ShowMessage(inttostr(lClusterSz)+'@'+inttostr(lInc)); + if lClusterSz > 1 then + FillStart(lInc) + else + lClusterBuff^[lInc] := 1; //fill all voxels in cluster with size of voxel + end; + end; +end; + +begin + lVolSz := lXdim*lYdim*lZdim; + lSliceSz := lXdim * lYdim; + if (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) then exit; + GetMem(lClusterBuff, lVolSz* sizeof(LongInt)); + for lInc := 1 to lVolSz do + lClusterBuff^[lInc] := 0; + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + lScaledThreshFloat := Scaled2RawIntensity (lHdr, lThresh); + for lInc := 1 to lVolSz do + if lBuffIn32^[lInc] > lScaledThreshFloat then + lClusterBuff^[lInc] := 1; + lScaledThreshFloat := Scaled2RawIntensity (lHdr, -lThresh); + for lInc := 1 to lVolSz do + if lBuffIn32^[lInc] < lScaledThreshFloat then + lClusterBuff^[lInc] := -1; + end else if lHdr.ImgBufferBPP = 2 then begin //not 32bit - if 16bit input + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + lScaledThresh := round(Scaled2RawIntensity (lHdr, lThresh)); + for lInc := 1 to lVolSz do + if lBuffIn16^[lInc] > lScaledThresh then + lClusterBuff^[lInc] := 1; + lScaledThresh := round(Scaled2RawIntensity (lHdr, -lThresh)); + for lInc := 1 to lVolSz do + if lBuffIn16^[lInc] < lScaledThresh then + lClusterBuff^[lInc] := -1; + end else begin //not 16 or 32 bit input + lScaledThresh := round(Scaled2RawIntensity (lHdr, lThresh)); + for lInc := 1 to lVolSz do + if lHdr.ImgBuffer^[lInc] > lScaledThresh then + lClusterBuff^[lInc] := 1; + lScaledThresh := round(Scaled2RawIntensity (lHdr, -lThresh)); + for lInc := 1 to lVolSz do + if lHdr.ImgBuffer^[lInc] < lScaledThresh then + lClusterBuff^[lInc] := -1; + end; //8-bit input + lThreshClusterSzM1 := lThreshClusterSz; + if lThreshClusterSzM1 < 1 then + lThreshClusterSzM1 := 1; + if (lThreshClusterSzM1 > 1) then begin + //Next - START count cluster size + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + //check positive clusters.... + SelectClusters(1); + //Check negative clusters + SelectClusters(-1); + Freemem(lQra); + //END check clusters + end; //only count clusters if minimum size > 1, otherwise simple intensity threshold... + //NEXT: mask image data with cluster size + + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + for lInc := 1 to lVolSz do + if lClusterBuff^[lInc] < lThreshClusterSzM1 then + lBuffIn32^[lInc] := 0; + end else if lHdr.ImgBufferBPP = 2 then begin + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + + for lInc := 1 to lVolSz do + if lClusterBuff^[lInc] < lThreshClusterSzM1 then + lBuffIn16^[lInc] := 0; + end else begin + for lInc := 1 to lVolSz do + if lClusterBuff^[lInc] < lThreshClusterSzM1 then + lHdr.ImgBuffer^[lInc] := 0; + end; + Freemem(lClusterBuff); +end; + +function ClusterFilterScrnImg (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double ): boolean; +var + lX,lY,lZ: integer; +begin + result := false; + lX := lHdr.NIFTIhdr.Dim[1]; + lY := lHdr.NIFTIhdr.Dim[2]; + lZ := lHdr.NIFTIhdr.Dim[3]; + + if (lHdr.ImgBufferItems < (lX*lY*lZ)) then + exit; + FindClusters (lHdr, lX, lY, lZ, lThreshClusterSz, lThresh); + result := true; +end; + +end. diff --git a/common/DiskSpaceKludge.pas b/common/DiskSpaceKludge.pas new file mode 100755 index 0000000..d73b225 --- /dev/null +++ b/common/DiskSpaceKludge.pas @@ -0,0 +1,200 @@ +// The author gave written permission to distribute this file under the +// same licensing terms as MRICRON. +// Disk Space Kludge for Delphi 3 for > 2 GB disk drives +// Works with Windows 95 OSR2 or later, Windows 98 or Windows 4.0 or later +// See http://msdn.microsoft.com/library/sdkdoc/winbase/filesio_8bso.htm +// +// Use DiskSpaceKludge.DiskFree and DiskSpaceKludge.DiskSize now in D3 and +// replace with equivalent SysUtils.DiskFree and SysUtils.DiskSize in D4 + +// efg, April 1999 + +UNIT DiskSpaceKludge; + +INTERFACE + + USES + Windows; // GetDiskFreeSpace, BOOL + + TYPE + TInteger8 = Comp; // 8-byte integer, since disk sizes may be > 2 GB + pInteger8 = ^TInteger8; + + // Use Delphi 4 trick from D4 SysUtils.PAS + VAR + GetDiskFreeSpaceEx: FUNCTION (DirectoryName: pChar; + FreeBytesAvailableToCaller: pInteger8; + TotalNumberOfBytes : pInteger8; + TotalNumberOfFreeBytes : pInteger8): BOOL + StDCall = NIL; + + FUNCTION GetDiskFreeSpaceExA (DirectoryName: pChar; + FreeBytesAvailableToCaller: pInteger8; + TotalNumberOfBytes : pInteger8; + TotalNumberOfFreeBytes : pInteger8): BOOL; + StDCall; + + FUNCTION DiskFreeA(Drive: BYTE): TInteger8; + FUNCTION DiskSize(Drive: BYTE): TInteger8; + FUNCTION DiskFreeStr(DriveStr: String): TInteger8; + FUNCTION DiskFreeEx (DriveStr: String): Integer; + + +IMPLEMENTATION + + USES + SysUtils; // StrCopy +function DiskFreeEx (DriveStr: String): Integer; +var + lOutDisk: Integer; + lDiskDir : string; + lSize8: Tinteger8; +begin + lOutDisk := ord(upcase(DriveStr[1]))+1-ord('A'); + if (lOutDisk >= ord('A')) and (lOutDisk <= ord('Z')) then begin + DiskFreeEx := DiskFree(lOutDisk); + end else begin + lDiskDir :=(ExtractFileDrive(DriveStr))+'\'; + lSize8 := DiskFreeStr (lDiskDir); + if lSize8 > MaxINt then DiskFreeEx := MaxInt + else DiskFreeEx := round(lSize8); + end; +end; + + /////////////////////////////////////////////////////////////////////////// + + FUNCTION GetDiskFreeSpaceExA; EXTERNAL KERNEL32 NAME 'GetDiskFreeSpaceExA'; + + + /////////////////////////////////////////////////////////////////////////// + + // Borland's DiskFree and DiskSize in D3 SysUtils only return a 4-byte integer. + // Use Integer8 here so values are meaningful on large disk drives. + // These routines may be replaced in D4 with the same name functions that + // return Int64 values. + + // DiskFree returns the number of free bytes on the specified drive number, + // where 0 = Current, 1 = A, 2 = B, etc. DiskFree returns -1 if the drive + // number is invalid. } + + FUNCTION DiskFreeA(Drive: BYTE): TInteger8; + VAR + FreeBytesAvailableToCaller: TInteger8; + RootPath : ARRAY[0..4] OF CHAR; + RootPtr : pChar; + TotalNumberOfBytes : TInteger8; + BEGIN + RootPtr := NIL; + IF Drive > 0 + THEN BEGIN + StrCopy(RootPath, 'A:\'); + RootPath[0] := CHR(Drive + ORD('A') - 1); + StrCopy(RootPath, 'C:\'); + RootPtr := RootPath + END; + + // Use NIL as third parameter, just like in D4 InternalGetDiskSpace routine + IF GetDiskFreeSpaceEx(RootPtr, + @FreeBytesAvailableToCaller, + @TotalNumberOfBytes, + NIL) + THEN RESULT := FreeBytesAvailableToCaller + ELSE RESULT := -1 + END {DiskFree}; + + FUNCTION DiskFreeStr(DriveStr: String): TInteger8; + VAR + FreeBytesAvailableToCaller: TInteger8; + RootPath : ARRAY[0..255] OF CHAR; + RootPtr : pChar; + TotalNumberOfBytes : TInteger8; + BEGIN +// RootPtr := NIL; +// StrCopy(RootPath, DriveStr); +{ RootPath[0] := CHR(Drive + ORD('A') - 1); + StrCopy(RootPath, 'C:\');} + RootPtr := RootPath; + StrPCopy(RootPtr,DriveStr); + + // Use NIL as third parameter, just like in D4 InternalGetDiskSpace routine + IF GetDiskFreeSpaceEx(RootPtr, + @FreeBytesAvailableToCaller, + @TotalNumberOfBytes, + NIL) + THEN RESULT := FreeBytesAvailableToCaller + ELSE RESULT := -1 + END {DiskFree}; + + + // DiskSize returns the size in bytes of the specified drive number, where + // 0 = Current, 1 = A, 2 = B, etc. DiskSize returns -1 if the drive number + // is invalid. } + + FUNCTION DiskSize(Drive: BYTE): TInteger8; + VAR + FreeBytesAvailableToCaller: TInteger8; + RootPath : ARRAY[0..4] OF CHAR; + RootPtr : pChar; + TotalNumberOfBytes : TInteger8; + BEGIN + RootPtr := NIL; + IF Drive > 0 + THEN BEGIN + StrCopy(RootPath, 'A:\'); + RootPath[0] := CHR(Drive + ORD('A') - 1); + RootPtr := RootPath + END; + + // Use NIL as third parameter, just like in D4 InternalGetDiskSpace routine + IF GetDiskFreeSpaceEx(RootPtr, + @FreeBytesAvailableToCaller, + @TotalNumberOfBytes, + NIL) + THEN RESULT := TotalNumberOfBytes + ELSE RESULT := -1 + END {DiskSize}; + + + /////////////////////////////////////////////////////////////////////////// + + // Equivalent to Delphi 4 SysUtils.PAS routines + FUNCTION BackfillGetDiskFreeSpaceEx(Directory: pChar; + VAR FreeAvailable, TotalSpace: TInteger8; + TotalFree: pInteger8): BOOL; StdCall; + + VAR + BytesPerSector : DWORD; + Dir : pChar; + FreeClusters : DWORD; + SectorsPerCluster: DWORD; + Temp : TInteger8; + TotalClusters : DWORD; + BEGIN + IF Directory <> NIL + THEN Dir := Directory + ELSE Dir := NIL; + + RESULT := GetDiskFreeSpaceA(Dir, SectorsPerCluster, BytesPerSector, + FreeClusters, TotalClusters); + Temp := SectorsPerCluster * BytesPerSector; + FreeAvailable := Temp * FreeClusters; + TotalSpace := Temp * TotalClusters + END {BackfillGetDiskFreeSpaceEx}; + + + PROCEDURE InitializeDriveSpacePointer; + VAR + Kernel: THandle; + BEGIN + Kernel := GetModuleHandle(Windows.Kernel32); + + IF Kernel <> 0 + THEN @GetDiskFreeSpaceEx := GetProcAddress(Kernel, 'GetDiskFreeSpaceExA'); + + IF NOT Assigned(GetDiskFreespaceEx) + THEN GetDiskFreeSpaceEx := @BackFillGetDiskFreeSpaceEx + END {InitializeDriveSpacePointer}; + +INITIALIZATION + InitializeDriveSpacePointer +END. diff --git a/common/GraphicsMathLibrary.o b/common/GraphicsMathLibrary.o new file mode 100644 index 0000000..b3f9a16 Binary files /dev/null and b/common/GraphicsMathLibrary.o differ diff --git a/common/GraphicsMathLibrary.pas b/common/GraphicsMathLibrary.pas new file mode 100755 index 0000000..1c6f55e --- /dev/null +++ b/common/GraphicsMathLibrary.pas @@ -0,0 +1,1116 @@ +// The author gave written permission to distribute this file under the +// same licensing terms as MRICRON. +// +// Graphics Math Library +// +// Copyright (C) 1982, 1985, 1992, 1995-1998 Earl F. Glynn, Overland Park, KS. +// All Rights Reserved. E-Mail Address: EarlGlynn@att.net + +UNIT GraphicsMathLibrary; // Matrix/Vector Operations for 2D/3D Graphics} + {$Include isgui.inc} +INTERFACE + + USES + + SysUtils {$IFDEF GUI},Dialogs {$ENDIF}; + + CONST + sizeUndefined = 1; + size2D = 3; // 'size' of 2D homogeneous vector or transform matrix + size3D = 4; // 'size' of 3D homogeneous vector or transform matrix + + TYPE + EVectorError = CLASS(Exception); + EMatrixError = CLASS(Exception); + + TAxis = (axisX, axisY, axisZ); + TCoordinate = (coordCartesian, coordSpherical, coordCylindrical); + TDimension = (dimen2D, dimen3D); // two- or three-dimensional TYPE + TIndex = 1..4; // index of 'TMatrix' and 'TVector' TYPEs + + TMatrixI = // transformation 'matrix' + RECORD + size: TIndex; + matrix: ARRAY[TIndex,TIndex] OF integer; + END; + + TMatrix = // transformation 'matrix' + RECORD + size: TIndex; + matrix: ARRAY[TIndex,TIndex] OF single //azx DOUBLE + END; + + Trotation = (rotateClockwise, rotateCounterClockwise); + + // Normally the TVector TYPE is used to define 2D/3D homogenous + // cartesian coordinates for graphics, i.e., (x,y,1) for 2D and + // (x,y,z,1) for 3D. + // + // Cartesian coordinates can be converted to spherical (r, theta, phi), + // or cylindrical coordinates (r,theta, z). Spherical or cylindrical + // coordinates can be converted back to cartesian coordinates. + TVector = + RECORD + size: TIndex; + CASE INTEGER OF + 0: (vector: ARRAY[TIndex] OF single); + 1: (x: single; + y: single; + z: single; // contains 'h' for 2D cartesian vector + h: single) + END; + + TIntVector = + RECORD + size: TIndex; + CASE INTEGER OF + 0: (vector: ARRAY[TIndex] OF integer); + 1: (x: integer; + y: integer; + z: integer; // contains 'h' for 2D cartesian vector + h: integer) + END; + // Vector Operations + +// FUNCTION Vector2D (CONST xValue, yValue: DOUBLE): TVector; + FUNCTION Vector3D (CONST xValue, yValue, zValue: DOUBLE): TVector; + Function SameVec (const u,v: TVector): boolean; + Function Eye3D: TMatrix; //returns identity matrix + FUNCTION Transform (CONST u: TVector; CONST a: TMatrix): TVector; +(* FUNCTION AddVectors (CONST u,v: TVector): TVector; +// FUNCTION Transform (CONST u: TVector; CONST a: TMatrix): TVector; + + FUNCTION DotProduct (CONST u,v: TVector): DOUBLE; + FUNCTION CrossProduct(CONST u,v: TVector): TVector; + *) + + // Basic Matrix Operations + + FUNCTION Matrix2D (CONST m11,m12,m13, // 2D "graphics" matrix + m21,m22,m23, + m31,m32,m33: DOUBLE): TMatrix; + + FUNCTION Matrix3D (CONST m11,m12,m13,m14, // 3D "graphics" matrix + m21,m22,m23,m24, + m31,m32,m33,m34, + m41,m42,m43,m44: DOUBLE): TMatrix; + FUNCTION DotProduct (CONST u,v: TVector): DOUBLE; + FUNCTION CrossProduct(CONST u,v: TVector): TVector; + + procedure NormalizeVector(var u: TVector); + function nifti_mat33_determ( R: TMatrix ):double; //* determinant of 3x3 matrix */ + + procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + + FUNCTION InvertMatrix3D (CONST Input:TMatrix): TMatrix; + + FUNCTION InvertMatrix (CONST a,b: TMatrix; VAR determinant: DOUBLE): TMatrix; + + + // Transformation Matrices + + FUNCTION RotateMatrix (CONST dimension: TDimension; + CONST xyz : TAxis; + CONST angle : DOUBLE; + CONST rotation : Trotation): TMatrix; + +// FUNCTION ScaleMatrix (CONST s: TVector): TMatrix; + +// FUNCTION TranslateMatrix (CONST t: TVector): TMatrix; + + FUNCTION ViewTransformMatrix (CONST coordinate: TCoordinate; + CONST azimuth {or x}, elevation {or y}, distance {or z}: DOUBLE; + CONST ScreenX, ScreenY, ScreenDistance: DOUBLE): TMatrix; + + + // conversions + +// FUNCTION FromCartesian (CONST ToCoordinate: TCoordinate; CONST u: TVector): TVector; +// FUNCTION ToCartesian (CONST FromCoordinate: TCoordinate; CONST u: TVector): TVector; + + //FUNCTION ToDegrees(CONST angle {radians}: DOUBLE): DOUBLE {degrees}; + FUNCTION ToRadians(CONST angle {degrees}: DOUBLE): DOUBLE {radians}; + + // miscellaneous + + FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; +{ FUNCTION GetFuzz: DOUBLE; + PROCEDURE SetFuzz(CONST x: DOUBLE); + } + +IMPLEMENTATION + +Function Eye3D: TMatrix; //returns identity matrix +begin + result := Matrix3D (1,0,0,0, + 0,1,0,0, + 0,0,1,0, + 0,0,0,1); + end; + + // 'Transform' multiplies a row 'vector' by a transformation 'matrix' + // resulting in a new row 'vector'. The 'size' of the 'vector' and 'matrix' + // must agree. To save execution time, the vectors are assumed to contain + // a homogeneous coordinate. + FUNCTION Transform (CONST u: TVector; CONST a: TMatrix): TVector; + VAR + i,k : TIndex; + temp: DOUBLE; + BEGIN + RESULT.size := a.size; + IF a.size = u.size + THEN BEGIN + FOR i := 1 TO a.size-1 DO + BEGIN + temp := 0.0; + FOR k := 1 TO a.size DO + BEGIN + temp := temp + u.vector[k]*a.matrix[k,i]; + END; + RESULT.vector[i] := Defuzz(temp) + END; + RESULT.vector[a.size] := 1.0 {assume homogeneous coordinate} + END + ELSE raise EMatrixError.Create('Transform multiply error'+inttostr(a.size)+' '+inttostr(u.size)) + END {Transform}; + + + VAR + fuzz : DOUBLE; + FUNCTION DotProduct (CONST u,v: TVector): DOUBLE; + VAR + i: INTEGER; + BEGIN + IF (u.size = v.size) + THEN BEGIN + RESULT := 0.0; + FOR i := 1 TO u.size-1 DO + BEGIN + RESULT := RESULT + u.vector[i] * v.vector[i]; + END; + END + ELSE RAISE EMatrixError.Create('Vector dot product error') + END; {DotProduct} + + FUNCTION CrossProduct(CONST u,v: TVector): TVector; + BEGIN + IF (u.size = v.size) AND (u.size = size3D) + THEN BEGIN + RESULT := Vector3D( u.y*v.z - v.y*u.z, + -u.x*v.z + v.x*u.z, + u.x*v.y - v.x*u.y) + END + ELSE RAISE EMatrixError.Create('Vector cross product error') + END; {CrossProduct} + + procedure NormalizeVector(var u: TVector); + var + lSum: double; + BEGIN + lSum := sqrt((u.x*u.x)+(u.y*u.y)+(u.z*u.z)); + if lSum <> 0 then + u := Vector3D( u.x/lSum, + u.y/lSum, + u.z/lSum) + END; {CrossProduct} + + + +procedure FromMatrix (M: TMatrix; var m11,m12,m13, m21,m22,m23, + m31,m32,m33: DOUBLE) ; + BEGIN + + m11 := M.Matrix[1,1]; + m12 := M.Matrix[1,2]; + m13 := M.Matrix[1,3]; + m21 := M.Matrix[2,1]; + m22 := M.Matrix[2,2]; + m23 := M.Matrix[2,3]; + m31 := M.Matrix[3,1]; + m32 := M.Matrix[3,2]; + m33 := M.Matrix[3,3]; +END {FromMatrix3D}; + + +function nifti_mat33_determ( R: TMatrix ):double; //* determinant of 3x3 matrix */ +begin + result := r.matrix[1,1]*r.matrix[2,2]*r.matrix[3,3] + -r.matrix[1,1]*r.matrix[3,2]*r.matrix[2,3] + -r.matrix[2,1]*r.matrix[1,2]*r.matrix[3,3] + +r.matrix[2,1]*r.matrix[3,2]*r.matrix[1,3] + +r.matrix[3,1]*r.matrix[1,2]*r.matrix[2,3] + -r.matrix[3,1]*r.matrix[2,2]*r.matrix[1,3] ; +end; + + + +function nifti_mat33_rownorm( A: TMatrix ): single; //* max row norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A.matrix[1,1])+abs(A.matrix[1,2])+abs(A.matrix[1,3]) ; + r2 := abs(A.matrix[2,1])+abs(A.matrix[2,2])+abs(A.matrix[2,3]) ; + r3 := abs(A.matrix[3,1])+abs(A.matrix[3,2])+abs(A.matrix[3,3]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_colnorm( A: TMatrix ): single; //* max column norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A.matrix[1,1])+abs(A.matrix[2,1])+abs(A.matrix[3,1]) ; + r2 := abs(A.matrix[1,2])+abs(A.matrix[2,2])+abs(A.matrix[3,2]) ; + r3 := abs(A.matrix[1,3])+abs(A.matrix[2,3])+abs(A.matrix[3,3]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_inverse( R: TMatrix ): TMatrix; //* inverse of 3x3 matrix */ +var + r11,r12,r13,r21,r22,r23,r31,r32,r33 , deti: double ; + Q: TMatrix ; +begin + FromMatrix(R,r11,r12,r13,r21,r22,r23,r31,r32,r33); + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + + if( deti <> 0.0 ) then deti := 1.0 / deti ; + + Q.matrix[1,1] := deti*( r22*r33-r32*r23) ; + Q.matrix[1,2] := deti*(-r12*r33+r32*r13) ; + Q.matrix[1,3] := deti*( r12*r23-r22*r13) ; + + Q.matrix[2,1] := deti*(-r21*r33+r31*r23) ; + Q.matrix[2,2] := deti*( r11*r33-r31*r13) ; + Q.matrix[2,3] := deti*(-r11*r23+r21*r13) ; + + Q.matrix[3,1] := deti*( r21*r32-r31*r22) ; + Q.matrix[3,2] := deti*(-r11*r32+r31*r12) ; + Q.matrix[3,3] := deti*( r11*r22-r21*r12) ; + result := Q; +end; + + + +(*procedure ReportMatrix (lStr: string;lM:TMatrix); +begin + showmessage(lStr); + showmessage( RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)); + showmessage( RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)); + showmessage( RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)); + showmessage( RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6)); +end;*) + +(*---------------------------------------------------------------------------*) +(*! polar decomposition of a 3x3 matrix + + This finds the closest orthogonal matrix to input A + (in both the Frobenius and L2 norms). + + Algorithm is that from NJ Higham, SIAM J Sci Stat Comput, 7:1160-1174. +*)(*-------------------------------------------------------------------------*) +function nifti_mat33_polar( A: TMatrix ): TMatrix; +const + dif: single=1.0 ; + k: integer=0 ; + +var + X , Y , Z: TMatrix ; + alp,bet,gam,gmi : single; +begin + X := A ; + (* force matrix to be nonsingular *) + //reportmatrix('x',X); + gam := nifti_mat33_determ(X) ; + while( gam = 0.0 )do begin (* perturb matrix *) + gam := 0.00001 * ( 0.001 + nifti_mat33_rownorm(X) ) ; + X.matrix[1,1] := X.matrix[1,1]+gam ; + X.matrix[2,2] := X.matrix[2,2]+gam ; + X.matrix[3,3] := X.matrix[3,3] +gam ; + gam := nifti_mat33_determ(X) ; + end; + + while true do begin + Y := nifti_mat33_inverse(X) ; + if( dif > 0.3 )then begin (* far from convergence *) + alp := sqrt( nifti_mat33_rownorm(X) * nifti_mat33_colnorm(X) ) ; + bet := sqrt( nifti_mat33_rownorm(Y) * nifti_mat33_colnorm(Y) ) ; + gam := sqrt( bet / alp ) ; + gmi := 1.0 / gam ; + end else begin + gam := 1.0; + gmi := 1.0 ; (* close to convergence *) + end; + Z.matrix[1,1] := 0.5 * ( gam*X.matrix[1,1] + gmi*Y.matrix[1,1] ) ; + Z.matrix[1,2] := 0.5 * ( gam*X.matrix[1,2] + gmi*Y.matrix[2,1] ) ; + Z.matrix[1,3] := 0.5 * ( gam*X.matrix[1,3] + gmi*Y.matrix[3,1] ) ; + Z.matrix[2,1] := 0.5 * ( gam*X.matrix[2,1] + gmi*Y.matrix[1,2] ) ; + Z.matrix[2,2] := 0.5 * ( gam*X.matrix[2,2] + gmi*Y.matrix[2,2] ) ; + Z.matrix[2,3] := 0.5 * ( gam*X.matrix[2,3] + gmi*Y.matrix[3,2] ) ; + Z.matrix[3,1] := 0.5 * ( gam*X.matrix[3,1] + gmi*Y.matrix[1,3] ) ; + Z.matrix[3,2] := 0.5 * ( gam*X.matrix[3,2] + gmi*Y.matrix[2,3] ) ; + Z.matrix[3,3] := 0.5 * ( gam*X.matrix[3,3] + gmi*Y.matrix[3,3] ) ; + + dif := abs(Z.matrix[1,1]-X.matrix[1,1])+abs(Z.matrix[1,2]-X.matrix[1,2]) + +abs(Z.matrix[1,3]-X.matrix[1,3])+abs(Z.matrix[2,1]-X.matrix[2,1]) + +abs(Z.matrix[2,2]-X.matrix[2,2])+abs(Z.matrix[2,3]-X.matrix[2,3]) + +abs(Z.matrix[3,1]-X.matrix[3,1])+abs(Z.matrix[3,2]-X.matrix[3,2]) + +abs(Z.matrix[3,3]-X.matrix[3,3]) ; + k := k+1 ; + if( k > 100) or (dif < 3.e-6 ) then begin + result := Z; + break ; (* convergence or exhaustion *) + end; + X := Z ; + end; + + result := Z ; +end; + +procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd , a,b,c,d : double; + P,Q: TMatrix; //3x3 +begin + + + (* offset outputs are read write out of input matrix *) + qx := lR.matrix[1,4]; + qy := lR.matrix[2,4]; + qz := lR.matrix[3,4]; + + (* load 3x3 matrix into local variables *) + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + (* compute lengths of each column; these determine grid spacings *) + + xd := sqrt( r11*r11 + r21*r21 + r31*r31 ) ; + yd := sqrt( r12*r12 + r22*r22 + r32*r32 ) ; + zd := sqrt( r13*r13 + r23*r23 + r33*r33 ) ; + + (* if a column length is zero, patch the trouble *) + + if( xd = 0.0 )then begin r11 := 1.0 ; r21 := 0; r31 := 0.0 ; xd := 1.0 ; end; + if( yd = 0.0 )then begin r22 := 1.0 ; r12 := 0; r32 := 0.0 ; yd := 1.0 ; end; + if( zd = 0.0 )then begin r33 := 1.0 ; r13 := 0; r23 := 0.0 ; zd := 1.0 ; end; + + (* assign the output lengths *) + dx := xd; + dy := yd; + dz := zd; + + (* normalize the columns *) + + r11 := r11/xd ; r21 := r21/xd ; r31 := r31/xd ; + r12 := r12/yd ; r22 := r22/yd ; r32 := r32/yd ; + r13 := r13/zd ; r23 := r23/zd ; r33 := r33/zd ; + + (* At this point, the matrix has normal columns, but we have to allow + for the fact that the hideous user may not have given us a matrix + with orthogonal columns. + + So, now find the orthogonal matrix closest to the current matrix. + + One reason for using the polar decomposition to get this + orthogonal matrix, rather than just directly orthogonalizing + the columns, is so that inputting the inverse matrix to R + will result in the inverse orthogonal matrix at this point. + If we just orthogonalized the columns, this wouldn't necessarily hold. *) + Q := Matrix2D (r11,r12,r13, // 2D "graphics" matrix + r21,r22,r23, + r31,r32,r33); + + + + P := nifti_mat33_polar(Q) ; (* P is orthog matrix closest to Q *) + FromMatrix(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + //ReportMatrix('xxx',Q); + //ReportMatrix('svd',P); + (* [ r11 r12 r13 ] *) + (* at this point, the matrix [ r21 r22 r23 ] is orthogonal *) + (* [ r31 r32 r33 ] *) + + (* compute the determinant to determine if it is proper *) + + zd := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; (* should be -1 or 1 *) + + if( zd > 0 )then begin (* proper *) + qfac := 1.0 ; + end else begin (* improper ==> flip 3rd column *) + qfac := -1.0 ; + r13 := -r13 ; r23 := -r23 ; r33 := -r33 ; + end; + + (* now, compute quaternion parameters *) + + a := r11 + r22 + r33 + 1.0; + + if( a > 0.5 ) then begin (* simplest case *) + a := 0.5 * sqrt(a) ; + b := 0.25 * (r32-r23) / a ; + c := 0.25 * (r13-r31) / a ; + d := 0.25 * (r21-r12) / a ; + end else begin (* trickier case *) + xd := 1.0 + r11 - (r22+r33) ; (* 4*b*b *) + yd := 1.0 + r22 - (r11+r33) ; (* 4*c*c *) + zd := 1.0 + r33 - (r11+r22) ; (* 4*d*d *) + if( xd > 1.0 ) then begin + b := 0.5 * sqrt(xd) ; + c := 0.25* (r12+r21) / b ; + d := 0.25* (r13+r31) / b ; + a := 0.25* (r32-r23) / b ; + end else if( yd > 1.0 ) then begin + c := 0.5 * sqrt(yd) ; + b := 0.25* (r12+r21) / c ; + d := 0.25* (r23+r32) / c ; + a := 0.25* (r13-r31) / c ; + end else begin + d := 0.5 * sqrt(zd) ; + b := 0.25* (r13+r31) / d ; + c := 0.25* (r23+r32) / d ; + a := 0.25* (r21-r12) / d ; + end; + if( a < 0.0 )then begin b:=-b ; c:=-c ; d:=-d; {a:=-a; not used} end; + end; + + qb := b ; + qc := c ; + qd := d ; +end; //nifti_mat44_to_quatern + +// ************************* Vector Operations ************************* + + // This procedure defines two-dimensional homogeneous coordinates (x,y,1) + // as a single 'vector' data element 'u'. The 'size' of a two-dimensional + // homogenous vector is 3. + + + // This procedure defines three-dimensional homogeneous coordinates + // (x,y,z,1) as a single 'vector' data element 'u'. The 'size' of a + // three-dimensional homogenous vector is 4. + Function SameVec (const u,v: TVector): boolean; + begin + if (u.x=v.x) and (u.y=v.y) and (u.z=v.z) then + result := true + else + result := false; + + end; + + FUNCTION Vector3D (CONST xValue, yValue, zValue: DOUBLE): TVector; + BEGIN + WITH RESULT DO + BEGIN + x := xValue; + y := yValue; + z := zValue; + h := 1.0; // homogeneous coordinate + size := size3D + END + END {Vector3D}; + + + // AddVectors adds two vectors defined with homogeneous coordinates. + FUNCTION AddVectors (CONST u,v: TVector): TVector; + VAR + i: TIndex; + BEGIN + IF (u.size IN [size2D..size3D]) AND + (v.size IN [size2D..size3D]) AND + (u.size = v.size) + THEN BEGIN + RESULT.size := u.size; + FOR i := 1 TO u.size-1 DO {2D + 2D = 2D or 3D + 3D = 3D} + BEGIN + RESULT.vector[i] := u.vector[i] + v.vector[i] + END; + RESULT.vector[u.size] := 1.0 {homogeneous coordinate} + END + ELSE raise EVectorError.Create('Vector Addition Mismatch') + END {AddVectors}; + + +// *********************** Basic Matrix Operations ********************** + + FUNCTION Matrix2D (CONST m11,m12,m13, m21,m22,m23, m31,m32,m33: DOUBLE): + TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; matrix[1,3] := m13; + matrix[2,1] := m21; matrix[2,2] := m22; matrix[2,3] := m23; + matrix[3,1] := m31; matrix[3,2] := m32; matrix[3,3] := m33; + size := size2D + END + END {Matrix2D}; + + + FUNCTION Matrix3D (CONST m11,m12,m13,m14, m21,m22,m23,m24, + m31,m32,m33,m34, m41,m42,m43,m44: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; + matrix[1,3] := m13; matrix[1,4] := m14; + + matrix[2,1] := m21; matrix[2,2] := m22; + matrix[2,3] := m23; matrix[2,4] := m24; + + matrix[3,1] := m31; matrix[3,2] := m32; + matrix[3,3] := m33; matrix[3,4] := m34; + + matrix[4,1] := m41; matrix[4,2] := m42; + matrix[4,3] := m43; matrix[4,4] := m44; + size := size3D + END + END {Matrix3D}; + + + // Compound geometric transformation matrices can be formed by multiplying + // simple transformation matrices. This procedure only multiplies together + // matrices for two- or three-dimensional transformations, i.e., 3x3 or 4x4 + // matrices. The multiplier and multiplicand must be of the same dimension. + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + VAR + i,j,k: TIndex; + temp : DOUBLE; + BEGIN + RESULT.size := a.size; + IF a.size = b.size + THEN + + FOR i := 1 TO a.size DO + BEGIN + FOR j := 1 TO a.size DO + BEGIN + + temp := 0.0; + FOR k := 1 TO a.size DO + BEGIN + temp := temp + a.matrix[i,k]*b.matrix[k,j]; + END; + RESULT.matrix[i,j] := Defuzz(temp) + + END + END +{$IFDEF GUI} + ELSE Showmessage('MultiplyMatricesError'+inttostr(a.size)+'x'+inttostr(b.size)); +{$ELSE} + else writeln('MultiplyMatricesError'+inttostr(a.size)+'x'+inttostr(b.size)); +{$ENDIF} + + //ELSE EMatrixError.Create('MultiplyMatrices error') + END {MultiplyMatrices}; + +PROCEDURE lubksb(a: {glnpbynp}TMatrix; n: integer; indx: TIntVector; VAR b: TVector); +VAR + j,ip,ii,i: integer; + sum: double; +BEGIN + ii := 0; + FOR i := 1 TO n DO BEGIN + ip := indx.vector[i]; + sum := b.vector[ip]; + b.vector[ip] := b.vector[i]; + IF (ii <> 0) THEN BEGIN + FOR j := ii TO i-1 DO BEGIN + sum := sum-a.matrix[i,j]*b.vector[j] + END + END ELSE IF (sum <> 0.0) THEN BEGIN + ii := i + END; + b.vector[i] := sum + END; + FOR i := n DOWNTO 1 DO BEGIN + sum := b.vector[i]; + IF (i < n) THEN BEGIN + FOR j := i+1 TO n DO BEGIN + sum := sum-a.matrix[i,j]*b.vector[j] + END + END; + b.vector[i] := sum/a.matrix[i,i] + END +end; + + PROCEDURE ludcmp(VAR a: TMatrix; n: integer; + VAR indx: TIntVector; VAR d: double); +CONST + tiny=1.0e-20; +VAR + k,j,imax,i: integer; + sum,dum,big: real; + vv: TVector; +BEGIN + d := 1.0; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO IF (abs(a.matrix[i,j]) > big) THEN big := abs(a.matrix[i,j]); + IF (big = 0.0) THEN BEGIN + writeln('pause in LUDCMP - singular matrix'); readln + END; + vv.vector[i] := 1.0/big + END; + FOR j := 1 TO n DO BEGIN + FOR i := 1 TO j-1 DO BEGIN + sum := a.matrix[i,j]; + FOR k := 1 TO i-1 DO BEGIN + sum := sum-a.matrix[i,k]*a.matrix[k,j] + END; + a.matrix[i,j] := sum + END; + big := 0.0; + FOR i := j TO n DO BEGIN + sum := a.matrix[i,j]; + FOR k := 1 TO j-1 DO BEGIN + sum := sum-a.matrix[i,k]*a.matrix[k,j] + END; + a.matrix[i,j] := sum; + dum := vv.vector[i]*abs(sum); + IF (dum > big) THEN BEGIN + big := dum; + imax := i + END + END; + IF (j <> imax) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a.matrix[imax,k]; + a.matrix[imax,k] := a.matrix[j,k]; + a.matrix[j,k] := dum + END; + d := -d; + vv.vector[imax] := vv.vector[j] + END; + indx.vector[j] := imax; + IF (a.matrix[j,j] = 0.0) THEN a.matrix[j,j] := tiny; + IF (j <> n) THEN BEGIN + dum := 1.0/a.matrix[j,j]; + FOR i := j+1 TO n DO BEGIN + a.matrix[i,j] := a.matrix[i,j]*dum + END + END + END; +END; + + FUNCTION InvertMatrix3D (CONST Input:TMatrix): TMatrix; + var + n,i,j: integer; + d: double; + indx: tIntVector; + col: tvector; + a,y: TMatrix; + begin + a:= Input; + n := 3; + y.size := size3D; + ludcmp(a,n,indx,d); + for j := 1 to n do begin + for i := 1 to n do col.vector[i] := 0; + col.vector[j] := 1.0; + lubksb(a,n,indx,col); + for i := 1 to n do y.matrix[i,j] := col.vector[i]; + end; + result := y; + end; + + // This procedure inverts a general transformation matrix. The user need + // not form an inverse geometric transformation by keeping a product of + // the inverses of simple geometric transformations: translations, rotations + // and scaling. A determinant of zero indicates no inverse is possible for + // a singular matrix. + FUNCTION InvertMatrix (CONST a,b: TMatrix; VAR determinant: DOUBLE): TMatrix; + VAR + c : TMatrix; + i,i_pivot: TIndex; + i_flag : ARRAY[TIndex] OF BOOLEAN; + j,j_pivot: TIndex; + j_flag : ARRAY[TIndex] OF BOOLEAN; + modulus : DOUBLE; + n : TIndex; + pivot : DOUBLE; + pivot_col: ARRAY[TIndex] OF TIndex; + pivot_row: ARRAY[TIndex] OF TIndex; + temporary: DOUBLE; + BEGIN + c := a; // The matrix inversion algorithm used here + WITH c DO // is similar to the "maximum pivot strategy" + BEGIN // described in "Applied Numerical Methods" + FOR i := 1 TO size DO // by Carnahan, Luther and Wilkes, + BEGIN // pp. 282-284. + i_flag[i] := TRUE; + j_flag[i] := TRUE + END; + modulus := 1.0; + i_pivot := 1; // avoid initialization warning + j_pivot := 1; // avoid initialization warning + + FOR n := 1 TO size DO + BEGIN + pivot := 0.0; + IF ABS(modulus) > 0.0 + THEN BEGIN + FOR i := 1 TO size DO + IF i_flag[i] + THEN + + FOR j := 1 TO size DO + IF j_flag[j] + THEN + IF ABS(matrix[i,j]) > ABS(pivot) + THEN BEGIN + pivot := matrix[i,j]; // largest value on which to pivot + i_pivot := i; // indices of pivot element + j_pivot := j + END; + + IF Defuzz(pivot) = 0 // If pivot is too small, consider + THEN modulus := 0 // the matrix to be singular + ELSE BEGIN + pivot_row[n] := i_pivot; + pivot_col[n] := j_pivot; + i_flag[i_pivot] := FALSE; + j_flag[j_pivot] := FALSE; + FOR i := 1 TO size DO + IF i <> i_pivot + THEN + FOR j := 1 TO size DO // pivot column unchanged for elements + IF j <> j_pivot // not in pivot row or column ... + THEN matrix[i,j] := (matrix[i,j]*matrix[i_pivot,j_pivot] - + matrix[i_pivot,j]*matrix[i,j_pivot]) + / modulus; // 2x2 minor / modulus + FOR j := 1 TO size DO + IF j <> j_pivot // change signs of elements in pivot row + THEN matrix[i_pivot,j] := -matrix[i_pivot,j]; + temporary := modulus; // exchange pivot element and modulus + modulus := matrix[i_pivot,j_pivot]; + matrix[i_pivot,j_pivot] := temporary + END + END + END {FOR n} + END {WITH}; + determinant := Defuzz(modulus); + IF determinant <> 0 + THEN BEGIN + RESULT.size := c.size; // The matrix inverse must be unscrambled + FOR i := 1 TO c.size DO // if pivoting was not along main diagonal. + FOR j := 1 TO c.size DO + RESULT.matrix[pivot_row[i],pivot_col[j]] := Defuzz(c.matrix[i,j]/determinant) + END + ELSE EMatrixError.Create('InvertMatrix error') + + END {InvertMatrix}; + + +// *********************** Transformation Matrices ******************** + + + // This procedure defines a matrix for a two- or three-dimensional rotation. + // To avoid possible confusion in the sense of the rotation, 'rotateClockwise' + // or 'roCounterlcockwise' must always be specified along with the axis + // of rotation. Two-dimensional rotations are assumed to be about the z-axis + // in the x-y plane. + // + // A rotation about an arbitrary axis can be performed with the following + // steps: + // (1) Translate the object into a new coordinate system where (x,y,z) + // maps into the origin (0,0,0). + // (2) Perform appropriate rotations about the x and y axes of the + // coordinate system so that the unit vector (a,b,c) is mapped into + // the unit vector along the z axis. + // (3) Perform the desired rotation about the z-axis of the new + // coordinate system. + // (4) Apply the inverse of step (2). + // (5) Apply the inverse of step (1). + FUNCTION RotateMatrix (CONST dimension: TDimension; + CONST xyz : TAxis; + CONST angle : DOUBLE; + CONST rotation : Trotation): TMatrix; + VAR + cosx : DOUBLE; + sinx : DOUBLE; + TempAngle: DOUBLE; + + BEGIN + TempAngle := angle; // Use TempAngle since "angle" is CONST parameter + + IF rotation = rotateCounterClockwise + THEN TempAngle := -TempAngle; + + cosx := Defuzz( COS(TempAngle) ); + sinx := Defuzz( SIN(TempAngle) ); + + CASE dimension OF + dimen2D: + CASE xyz OF + axisX,axisY: EMatrixError.Create('Invalid 2D rotation matrix. Specify axisZ'); + + axisZ: RESULT := Matrix2D ( cosx, -sinx, 0, + sinx, cosx, 0, + 0, 0, 1) + END; + + dimen3D: + CASE xyz OF + axisX: RESULT := Matrix3D ( 1, 0, 0, 0, + 0, cosx, -sinx, 0, + 0, sinx, cosx, 0, + 0, 0, 0, 1); + + axisY: RESULT := Matrix3D ( cosx, 0, sinx, 0, + 0, 1, 0, 0, + -sinx, 0, cosx, 0, + 0, 0, 0, 1); + + axisZ: RESULT := Matrix3D ( cosx, -sinx, 0, 0, + sinx, cosx, 0, 0, + 0, 0, 1, 0, + 0, 0, 0, 1); + END + END + END {RotateMatrix}; + + + // 'ScaleMatrix' accepts a 'vector' containing the scaling factors for + // each of the dimensions and creates a scaling matrix. The size + // of the vector dictates the size of the resulting matrix. + FUNCTION ScaleMatrix (CONST s: TVector): TMatrix; + BEGIN + CASE s.size OF + size2D: RESULT := Matrix2D (s.x, 0, 0, + 0, s.y, 0, + 0, 0, 1); + + size3D: RESULT := Matrix3D (s.x, 0, 0, 0, + 0, s.y, 0, 0, + 0, 0, s.z, 0, + 0, 0, 0, 1) + END + END {ScaleMatrix}; + // 'TranslateMatrix' defines a translation transformation matrix. The + // components of the vector 't' determine the translation components. + // (Note: 'Translate' here is from kinematics in physics.) + FUNCTION TranslateMatrix (CONST t: TVector): TMatrix; + BEGIN + CASE t.size OF + size2D: RESULT := Matrix2D ( 1, 0, 0, + 0, 1, 0, + t.x, t.y, 1); + + size3D: RESULT := Matrix3D ( 1, 0, 0, 0, + 0, 1, 0, 0, + 0, 0, 1, 0, + t.x, t.y, t.z, 1) + END + END {TranslateMatrix}; + // 'ViewTransformMatrix' creates a transformation matrix for changing + // from world coordinates to eye coordinates. The location of the 'eye' + // from the 'object' is given in spherical (azimuth,elevation,distance) + // coordinates or Cartesian (x,y,z) coordinates. The size of the screen + // is 'ScreenX' units horizontally and 'ScreenY' units vertically. The + // eye is 'ScreenDistance' units from the viewing screen. A large ratio + // 'ScreenDistance/ScreenX (or ScreenY)' specifies a narrow aperature + // -- a telephoto view. Conversely, a small ratio specifies a large + // aperature -- a wide-angle view. This view transform matrix is very + // useful as the default three-dimensional transformation matrix. Once + // set, all points are automatically transformed. + FUNCTION ViewTransformMatrix (CONST coordinate: TCoordinate; + CONST azimuth {or x}, elevation {or y}, distance {or z}: DOUBLE; + CONST ScreenX, ScreenY, ScreenDistance: DOUBLE): TMatrix; + + CONST + HalfPI = PI / 2.0; + + VAR + a : TMatrix; + b : TMatrix; + cosm : DOUBLE; // COS(-angle) + hypotenuse: DOUBLE; + sinm : DOUBLE; // SIN(-angle) + temporary : DOUBLE; + u : TVector; + x : DOUBLE ABSOLUTE azimuth; // x and azimuth are synonyms + y : DOUBLE ABSOLUTE elevation; // synonyms + z : DOUBLE ABSOLUTE distance; // synonyms + + BEGIN + CASE coordinate OF + coordCartesian: u := Vector3D (-x, -y, -z); + + coordSpherical: + BEGIN + temporary := -distance * COS(elevation); + u := Vector3D (temporary * COS(azimuth - HalfPI), + temporary * SIN(azimuth - HalfPI), + -distance * SIN(elevation)); + END + END; + a := TranslateMatrix(u); // translate origin to 'eye' + b := RotateMatrix (dimen3D, axisX, HalfPI, rotateClockwise); + a := MultiplyMatrices(a,b); + + CASE coordinate OF + coordCartesian: + BEGIN + temporary := SQR(x) + SQR(y); + hypotenuse := SQRT(temporary); + if hypotenuse <> 0 then begin + cosm := -y/hypotenuse; + sinm := x/hypotenuse; + end else begin + cosm := 1;//abba + sinm := 0; + end; + + b := Matrix3D ( cosm, 0, sinm, 0, + 0, 1, 0, 0, + -sinm, 0, cosm, 0, + 0, 0, 0, 1); + + a := MultiplyMatrices (a,b); + cosm := hypotenuse; + hypotenuse := SQRT(temporary + SQR(z)); + cosm := cosm/hypotenuse; + sinm := -z/hypotenuse; + + b := Matrix3D ( 1, 0, 0, 0, + 0, cosm, -sinm, 0, + 0, sinm, cosm, 0, + 0, 0, 0, 1) + END; + coordSpherical: + BEGIN + b := RotateMatrix (dimen3D,axisY,-azimuth,rotateCounterClockwise); + a := MultiplyMatrices(a,b); + b := RotateMatrix (dimen3D,axisX,elevation,rotateCounterClockwise); + END + END {CASE}; + + a := MultiplyMatrices (a,b); + u := Vector3D (ScreenDistance/(0.5*ScreenX), + ScreenDistance/(0.5*ScreenY),-1.0); + b := ScaleMatrix (u); // reverse sense of z-axis; screen transformation + + RESULT := MultiplyMatrices (a,b); + + END {ViewTransformMatrix}; + +// *************************** Conversions ************************** + // This function converts the vector parameter from Cartesian + // coordinates to the specified type of coordinates. + FUNCTION FromCartesian (CONST ToCoordinate: TCoordinate; CONST u: TVector): TVector; + VAR + phi : DOUBLE; + r : DOUBLE; + temp : DOUBLE; + theta: DOUBLE; + + BEGIN + IF ToCoordinate = coordCartesian + THEN RESULT := u + ELSE BEGIN + RESULT.size := u.size; + + IF (u.size = size3D) AND + (ToCoordinate = coordSpherical) + THEN BEGIN // spherical 3D + temp := SQR(u.x)+SQR(u.y); // (x,y,z) -> (r,theta,phi) + r := SQRT(temp+SQR(u.z)); + IF Defuzz(u.x) = 0.0 + THEN theta := PI/4 + ELSE theta := ARCTAN(u.y/u.x); + IF Defuzz(u.z) = 0.0 + THEN phi := PI/4 + ELSE phi := ARCTAN(SQRT(temp)/u.z); + RESULT.x := r; + RESULT.y := theta; + RESULT.z := phi + END + ELSE BEGIN // cylindrical 2D/3D or spherical 2D + // (x,y) -> (r,theta) or (x,y,z) -> (r,theta,z) + r := SQRT( SQR(u.x) + SQR(u.y) ); + IF Defuzz(u.x) = 0.0 + THEN theta := PI/4 + ELSE theta := ARCTAN(u.y/u.x); + RESULT.x := r; + RESULT.y := theta + END + + END + END {FromCartesian}; + + + // This function converts the vector parameter from specified coordinates + // into Cartesian coordinates. + FUNCTION ToCartesian (CONST FromCoordinate: TCoordinate; CONST u: TVector): TVector; + VAR + phi : DOUBLE; + r : DOUBLE; + sinphi: DOUBLE; + theta : DOUBLE; + + BEGIN + RESULT := u; + + IF FromCoordinate = coordCartesian + THEN RESULT := u + ELSE BEGIN + RESULT.size := u.size; + + IF (u.size = size3D) AND + (FromCoordinate = coordSpherical) + THEN BEGIN // spherical 3D + r := u.x; // (r,theta,phi) -> (x,y,z) + theta := u.y; + phi := u.z; + sinphi := SIN(phi); + RESULT.x := r * COS(theta) * sinphi; + RESULT.y := r * SIN(theta) * sinphi; + RESULT.z := r * COS(phi) + END + ELSE BEGIN // cylindrical 2D/3D or spherical 2D + r := u.x; // (r,theta) -> (x,y) or (r,theta,z) -> (x,y,z) + theta := u.y; + RESULT.x := r * COS(theta); + RESULT.y := r * SIN(theta) + END + END + END {ToCartesian}; + + + + + // Convert angle in degrees to radians. + FUNCTION ToRadians (CONST angle: DOUBLE): DOUBLE; + BEGIN + RESULT := PI/180.0 * angle + END; {ToRadians} + + +// *************************** Miscellaneous ************************** + + // 'Defuzz' is used for comparisons and to avoid propagation of 'fuzzy', + // nearly-zero values. DOUBLE calculations often result in 'fuzzy' values. + // The term 'fuzz' was adapted from the APL language. + FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; + BEGIN + IF ABS(x) < fuzz + THEN RESULT := 0.0 + ELSE RESULT := x + END {Defuzz}; + + +INITIALIZATION + fuzz := 1.0E-6; + +END. {GraphicsMath UNIT} \ No newline at end of file diff --git a/common/GraphicsMathLibrary.ppu b/common/GraphicsMathLibrary.ppu new file mode 100644 index 0000000..216efd8 Binary files /dev/null and b/common/GraphicsMathLibrary.ppu differ diff --git a/common/backup/define_types.pas.bak b/common/backup/define_types.pas.bak new file mode 100755 index 0000000..c915802 --- /dev/null +++ b/common/backup/define_types.pas.bak @@ -0,0 +1,1375 @@ +unit define_types; +interface +{$H+} +{$include isgui.inc} + + uses + {$IFNDEF FPC} + {$IFDEF GUI} FileCtrl, delphiselectfolder, {$ENDIF} + DiskSpaceKludge, Controls, + {$ELSE} + {$IFDEF GUI} lclintf,LResources,{$ENDIF} + {$ENDIF} + {$IFNDEF Unix} Windows, + {$ELSE} + BaseUnix,{$IFDEF GUI} LCLType, {$ENDIF}//lclintf, LMessages,LCLType,//gettickcount + {$ENDIF} + + SysUtils,classes,IniFiles, + {$IFDEF GUI} forms,userdir, dialogs{$ELSE}dialogsx{$ENDIF}; +const + kMRIcronVersDate = '22AUG2015'; + {$IFDEF LCLCocoa} + kMRIcronAPI = 'Cocoa'; + {$ELSE} + {$IFDEF LCLCarbon} + kMRIcronAPI = 'Carbon'; + {$ELSE} + kMRIcronAPI = ''; //windows, GTK, QT + {$ENDIF} + {$ENDIF} + {$ifdef CPU32} + kMRIcronCPU = '32'; + {$ELSE} + kMRIcronCPU = '64'; + {$ENDIF} + kMRIcronVers = kMRIcronVersDate+' '+ kMRIcronCPU +'bit BSD License '+kMRIcronAPI; + NaN : double = 1/0; + kMagicDouble : double = -111666222; + kTxtFilter = 'Text (*.txt)|*.txt;*.csv|Comma Separated (*.csv)|*.csv'; + kAnyFilter = 'Anything (*)|*'; + kAnaHdrFilter = 'Analyze Header (*.hdr)|*.hdr'; + + //kNIIFilter = 'NIfTI (*.nii)|*.nii'; + //kImgPlusVOIFilter = 'NIfTI/Analyze/VOI|*.hdr;*.nii;*.nii.gz;*.voi|NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi'; + //kImgFilter = 'NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi'; + //kImgFilterPlusAny = 'NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi|Any file (*.*)|*.*'; + + kNIIFilter = 'Neuroimaging (*.nii)|*.hdr;*.nii;*.nii.gz;*.voi;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd'; + kImgFilter = 'Neuroimaging|*.hdr;*.nii;*.nii.gz;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd|Volume of interest (*.voi)|*.voi'; + kImgPlusVOIFilter = 'Neuroimaging/VOI|*.hdr;*.nii;*.nii.gz;*.voi;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd|NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi'; + kImgFilterPlusAny = 'Neuroimaging/VOI|*.hdr;*.nii;*.nii.gz;*.voi;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd|NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi|Anything (*.*)|*.*'; + kHistoBins = 256;//numbers of bins for histogram/image balance + PixelCountMax = 32768; + kTab = chr(9); + kEsc = chr(27); + kCR = chr (13); + kBS = #8 ; // Backspace + kDel = #127 ; // Delete + UNIXeoln = chr(10); + kTextSep = kTab;//','; //',' for CSV, kTab for Tab-delimited values + {$IFDEF Darwin} + kLUTalpha = 255; //255 + {$ELSE} + kLUTalpha = 0; //255 + {$ENDIF} + kVOI8bit = 1;//May07 100; +{$IFDEF unix} + PathDelim = '/'; +{$ELSE} + PathDelim = '\'; +{$ENDIF} + +type + TStrRA = Array of String; + TPSPlot = RECORD //peristimulus plot + TRSec,BinWidthSec: single; + nNegBins,nPosBins,SPMDefaultsStatsFmriT,SPMDefaultsStatsFmriT0: integer; + TextOutput,GraphOutput, + SliceTime,SavePSVol,BaselineCorrect,PctSignal,RemoveRegressorVariability,TemporalDeriv,PlotModel,Batch: boolean + end; + TRGBquad = PACKED RECORD + {$IFDEF ENDIAN_BIG} //OSX PPC + rgbreserved,rgbRed,rgbGreen,rgbBlue: byte; + //rgbBlue,rgbGreen,rgbRed,rgbreserved: byte; + {$ELSE} + {$IFDEF UNIX} + {$IFDEF DARWIN} + rgbreserved,rgbRed,rgbGreen,rgbBlue: byte; + {$ELSE} + rgbRed,rgbGreen,rgbBlue,rgbreserved: byte; + {$ENDIF} + {$ELSE} //not unix - windows + //rgbreserved,rgbRed,rgbGreen,rgbBlue: byte; + rgbBlue,rgbGreen,rgbRed,rgbreserved: byte; + {$ENDIF} +// rgbBlue,rgbGreen,rgbRed,rgbreserved: byte; + {$ENDIF} + end; + TStretchQuality = (sqLow, sqHigh); + + //TLUTrgb = array[0..255] of TRGBQuad; + //TLUTtype = DWORD; + TLUT = array[0..255] of TRGBQuad; + kStr20 = string[20]; + kStr50 = string[50]; + + kStr255 = string[255]; + + TCutout = RECORD + Lo : array [1..3] of integer; + Hi : array [1..3] of integer; + end; + int32 = LongInt; + uint32 = Cardinal; + int16 = SmallInt; + uint16 = Word; + int8 = ShortInt; + uint8 = Byte; + Int64RA = array [1..1] of int64; + Int64p = ^Int64RA; + + SingleRA0 = array [0..0] of Single; + Singlep0 = ^SingleRA0; + ByteRA0 = array [0..0] of byte; + Bytep0 = ^ByteRA0; + WordRA0 = array [0..0] of Word; + Wordp0 = ^WordRA0; + SmallIntRA0 = array [0..0] of SmallInt; + SMallIntp0 = ^SmallIntRA0; + LongIntRA0 = array [0..0] of LongInt; + LongIntp0 = ^LongIntRA0; + DWordRA = array [1..1] of DWord; + DWordp = ^DWordRA; + ByteRA = array [1..1] of byte; + Bytep = ^ByteRA; + WordRA = array [1..1] of Word; + Wordp = ^WordRA; + SmallIntRA = array [1..1] of SmallInt; + SMallIntp = ^SmallIntRA; + LongIntRA = array [1..1] of LongInt; + LongIntp = ^LongIntRA; + SingleRA = array [1..1] of Single; + Singlep = ^SingleRA; + SingleRARA = array [1..1] of Singlep; + SingleRAp = ^SingleRARA; + DoubleRA = array [1..1] of Double; + Doublep = ^DoubleRA; + DoubleRA0 = array [0..0] of Double; + Doublep0 = ^DoubleRA0; + HistoRA = array [0..kHistoBins] of longint; + HistoDoubleRA = array [0..kHistoBins] of double; + //pRGBQuadArray = ^TRGBQuad; + //TRGBQuadeArray = ARRAY[0..PixelCountMax-1] OF TRGBQuad; + //RGBQuadRA = array [1..1] of TRGBQuad; + //RGBQuadp = ^RGBQuadRA; + TQuadRA = array [1..1] of TRGBQuad; + + RGBQuadp = ^TQuadRA; + + +// pRGBTripleArray = ^TRGBTripleArray; +// TRGBTripleArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple; +FUNCTION specialsingle (var s:single): boolean; //check if 32-bit float is Not-A-Number, infinity, etc +function FSize (lFName: String): Int64; +function FileExistsEX(Name: String): Boolean; +function ParseFileName (lFilewExt:String): string; +function ParseFileFinalDir (lFileName:String): string; +function ExtractFileDirWithPathDelim(lInFilename: string): string; +function PadStr (lValIn, lPadLenIn: integer): string; +function ChangeFileExtX( var lFilename: string; lExt: string): string; +//function swap2i(SmallInt): Smallint; +function swap4r4i (s:single): longint; //swap and convert: endian-swap and then typecast 32-bit float as 32-bit integer +function conv4r4i (s:single): longint; //convert: typecast 32-bit float as 32-bit integer +function swap8r(s : double):double; //endian-swap 64-bit float +procedure pswap4i(var s : LongInt); //procedure to endian-swap 32-bit integer +procedure pswap4r ( var s:single); //procedure to endian-swap 32-bit integer +function swap64r(s : double):double; +function specialdouble (d:double): boolean; +function RealToStr(lR: double {was extended}; lDec: integer): string; +function UpCaseExt(lFileName: string): string;//file.brik.gz->BRIK.GZ, file.nii.gz -> NII.GZ +function ExtGZ (lFilename: string): boolean; +procedure swap4(var s : LongInt); +procedure Xswap4r ( var s:single); +function Bool2Char (lBool: boolean): char; +function Char2Bool (lChar: char): boolean; +function Log(X, Base: single): single; +//procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +//procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer); +{$IFNDEF FPC} +function DiskFreeEx (DriveStr: String): Integer; +{$ELSE} +function DiskFreeEx (DriveStr: String): Int64; +{$ENDIF} +procedure SortSingle(var lLo,lHi: single); +procedure SortInteger(var lLo,lHi: integer); +function IniInt(lIniFile: TIniFile; lIdent: string; lDefault: integer): integer; +function IniBool(var lIniFile: TIniFile; lIdent: string; lDefault: boolean): boolean; +procedure CopyFileEX (lInName,lOutName: string); +procedure CopyFileEXoverwrite (lInName,lOutName: string); +procedure fx (a: double); overload; //fx used to help debugging - reports number values +procedure fx (a,b: double); overload; +procedure fx (a,b,c: double); overload; +procedure fx (a,b,c,d: double); overload; +function Swap2(s: smallint): smallint; +//function DefaultsDir (lSubFolder: string): string; +function ChangeFilePostfixExt (lInName,lPostfix,lExt: string): string; +procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +function freeRam: Int64; + +function OKMsg(lMsg: string): boolean; //shows dialog with OK/Cancel returns true if user presses OK +function DirExists (lFolderName: String): boolean; +function FilenameParts (lInName: string; var lPath,lName,lExt: string): boolean; +function AddIndexToFilename (lInName: string; lIndex: integer): string; + +procedure createArray64 (var ptr: pointer; var ra :Doublep0; Sz: integer); overload; +procedure createArray64 (var ptr: pointer; var ra :Doublep; Sz: integer); overload; +function GzExt(lFileName: string): boolean; +function ChangeFilePrefixExt (lInName,lPrefix,lExt: string): string; +function ChangeFilePrefix(lInName,lPrefix: string): string; +function makesmallint (b0,b1: byte): smallint; +function makesingle( b0,b1,b2,b3: byte): single; +procedure SortInt (var lMin,lMax: integer); +function Bound (lDefault,lMin,lMax: integer): integer; +function IsNiftiExt(lStr: string): boolean; +function IsExtNIFTIHdr(lStr: string): boolean; +function IsVOIExt(lStr: string): boolean; +//procedure ax(a,b,c,d,e,fx: double); +procedure EnsureDirEndsWithPathDelim (var lDir: string); +//function IsReadOnly(const FileName: string): Boolean;//I think this only works for existing files... not folders and new files +function DirWritePermission(Where: string): Boolean; //I think this is better than above +function ExtractDir (lFilepath: string): string; +{$IFDEF GUI} +function GetDirPrompt (lDefault: string): string; +{$ENDIF} +function Str2Int (lStr: string): integer; +function ResetDefaults : boolean; + +implementation + +function ResetDefaults : boolean; +const + {$IFDEF LINUX} + kKey = 'Right button'; + {$ELSE} + kKey = 'Shift key'; + {$ENDIF} +var + lKey: boolean; +begin + result := false; +{$IFDEF GUI} + {$IFDEF LINUX} + lKey := (GetKeyState(VK_RBUTTON) And $80)<>0; + {$ELSE} + lKey := (ssShift in KeyDataToShiftState(vk_Shift)); + {$ENDIF} + if not lKey then + exit; + {$IFDEF GUI} + case MessageDlg(kKey+' down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + idYes: result := true; + end; //case + {$ENDIF} +{$ENDIF} +end; + +function Str2Int (lStr: string): integer; +//robust stringtoint that strips out any junk so that "Implementation Version Name=MR.VB15A" returns 15 +// warning, strips out decimals, so 15.3 will return 153! +//warning also ignores minus sign so -5.21 will return 521! +var + Len,P: integer; + S: string; +begin + result := 0; + Len := length(lStr); + if Len <1 then exit; + S := ''; + for P := 1 to Len do + if lStr[P] in ['-','0'..'9'] then + S := S + lStr[P]; + if length(S) < 1 then exit; + result := strtoint(S); +end; + + +{$IFDEF GUI} +function GetDirPrompt (lDefault: string): string; +// Old versions of Delphi have a clumsy SelectDirectory function, and locks the folder until you quit your application... +var + lD: string; +begin + lD := lDefault; + if not DirExists(lD) then + lD := UserDataFolder; + result := lD; // Set the starting directory + {$IFDEF FPC} + //Delphi SelectDirectory uses FileCtrl + //Lazarus SelectDirectory uses Dialogs + chdir(result); //start search from previous dir... + if SelectDirectory(result, [sdAllowCreate,sdPerformCreate,sdPrompt], 0) then begin + chdir(result); + exit; + end; + {$ELSE} + if SelectDirectoryDelphi('Select folder', result, true) then + exit; + {$ENDIF} + //if the user aborts, make sure we use the default directory... + result := lD; +end; +{$ENDIF} //GUI + +function ExtractDir (lFilepath: string): string; +//if passed file \usr\temp\data.txt returns \usr\temp\ +//if passed dir \usr\temp returns \usr\temp\ +//note returned always includes pathdelim +var + lName,lExt: string; +begin + FilenameParts (lFilepath,Result,lName,lExt); +end; + +function DirWritePermission(Where: string): Boolean; +{$IFDEF UNIX} +//Uses BaseUnix; +begin + result := (fpAccess (ExtractDir(Where),W_OK)=0); +end; +{$ELSE} +Var + i : Longint; + lFilename: string; +Begin + result := false; + if length(Where) < 1 then + exit; + + if DirExists (Where) then begin + if Where[length(Where)] <> PathDelim then + lFilename := Where + pathdelim + 'dummy.dum' + else + lFilename := Where + 'dummy.dum'; + end else + lFilename := Where; + if fileexists (lFilename) then + exit; //do not overwrite existing file + i:=FileCreate (lFilename); + if i=-1 then + Halt(1); + FileClose(i); + DeleteFile(lFilename); + result := true; +end; +{$ENDIF} +(*function IsReadOnly(const FileName: string): Boolean; +var + sr: TSearchRec; +begin + // Assume not read only + Result := False; + if FindFirst(FileName, faAnyFile, sr) = 0 then + begin + Result := (sr.Attr and faReadOnly) <> 0; + FindClose(sr); + end; +end; *) + +procedure EnsureDirEndsWithPathDelim (var lDir: string); +begin + if length(lDir) < 1 then + exit; + if lDir[length(lDir)] = pathdelim then + exit; + lDir := lDir + pathdelim; +end; + + +function AddIndexToFilename (lInName: string; lIndex: integer): string; +var lPath,lName,lExt: string; +begin + result := ''; + if not FilenameParts (lInName, lPath,lName,lExt) then exit; + result := lPath+lName+inttostr(lIndex)+lExt; +end; + +function Bound (lDefault,lMin,lMax: integer): integer; +begin + result := lDefault; + if result < lMin then + result := lMin; + if result > lMax then + result := lMax; +end; + +function IsVOIExt(lStr: string): boolean; +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.VOI') then + result := true; +end; +function IsNiftiExt(lStr: string): boolean; +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.MGH') or (lExt = '.MGZ') then + result := true; + if (lExt = '.MHA') or (lExt = '.MHD') then + result := true; + if (lExt = '.HEAD') then + result := true; + if (lExt = '.NRRD') then + result := true; + + if (lExt = '.NII') or (lExt = '.NII.GZ') then + result := true; + if (lExt = '.HDR') and (FSize(ChangeFileExt(lStr,'.img'))> 0) then + result := true; + if (lExt = '.IMG') and (FSize(ChangeFileExt(lStr,'.hdr'))> 0) then + result := true; +end; + +function IsExtNIFTIHdr(lStr: string): boolean; +//detect hdr, nii,niigz +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.NII') or (lExt = '.NII.GZ') then + result := true; + if (lExt = '.HDR') and (FSize(ChangeFileExt(lStr,'.img'))> 0) then + result := true; + (*if (lExt = '.IMG') and (FSize(ChangeFileExt(lStr,'.hdr'))> 0) then + result := true; *) +end; + +procedure SortInt (var lMin,lMax: integer); +var + lSwap: integer; +begin + if lMin <= lMax then + exit; + lSwap := lMax; + lMax := lMin; + lMin := lSwap; +end; + +function makesmallint (b0,b1: byte): smallint; +type + swaptype = packed record + case byte of + 0:(b0,b1 : byte); //word is 16 bit + 1:(s:smallint); + end; + swaptypep = ^swaptype; +var + //inguy:swaptypep; + outguy:swaptype; +begin + //inguy := @s; //assign address of s to inguy + outguy.b0 := b0; + outguy.b1 := b1; + result:=outguy.s; +end;//makesmallint + + +function makesingle( b0,b1,b2,b3: byte): single; +type + swaptype = packed record + case byte of + 0:(b0,b1,b2,b3 : byte); //word is 16 bit + 1:(long:single); + end; + swaptypep = ^swaptype; +var + outguy:swaptype; +begin + //inguy := @s; //assign address of s to inguy + outguy.b0 := b0; + outguy.b1 := b1; + outguy.b2 := b2; + outguy.b3 := b3; + result:=outguy.long; +end;//swap4r4i + +function ChangeFilePrefix(lInName,lPrefix: string): string; +var + lC,lLen,lPos: integer; + lStr: string; +begin + //result := changefileext(lInName,lExt); + result := lInName; + lLen := length (result); + if lLen < 1 then exit; + lPos := lLen; + while (lPos > 1) and (result[lPos] <> pathdelim) do + dec(lPos); + lStr := ''; + for lC := 1 to lPos do + lStr := lStr+result[lC]; + lStr := lStr+lPrefix; + if lPos < lLen then + for lC := (lPos+1) to lLen do + lStr := lStr+result[lC]; + result := lStr; +end; + +function ChangeFilePrefixExt (lInName,lPrefix,lExt: string): string; +var + lC,lLen,lPos: integer; + lStr: string; +begin + result := changefileext(lInName,lExt); + lLen := length (result); + if lLen < 1 then exit; + lPos := lLen; + while (lPos > 1) and (result[lPos] <> pathdelim) do + dec(lPos); + lStr := ''; + for lC := 1 to lPos do + lStr := lStr+result[lC]; + lStr := lStr+lPrefix; + if lPos < lLen then begin + lC := lPos+1; + while (lC <= lLen) and (result[lC] <> '.') do begin + lStr := lStr + result[lC]; + inc(lC); + end; + end; + lStr := lStr + lExt; + result := lStr; +end; + + +function GzExt(lFileName: string): boolean; +var lExt: string; +begin + lExt := UpCaseExt(lFilename); + if (lExt = '.VOI') or (lExt = '.NII.GZ') or (lExt = '.GZ') then + result := true + else + result := false; +end; + +function FilenameParts (lInName: string; var lPath,lName,lExt: string): boolean; +var + lLen,lPos,lExtPos,lPathPos: integer; +begin + result := false; + lPath := ''; + lName := ''; + lExt := ''; + lLen := length(lInName); + if lLen < 1 then + exit; + if DirExists(lInName) then begin //we have been passed a folder, not a file + if lInName[lLen] = PathDelim then + lPath := lInName + else + lPath := lInName + pathdelim; + exit; + end; + //next find final pathdelim + lPathPos := lLen; + while (lPathPos > 0) and (lInName[lPathPos] <> '\') and (lInName[lPathPos] <> '/') do + dec(lPathPos); + if (lInName[lPathPos] = '\') or (lInName[lPathPos] = '/') then begin + for lPos := 1 to lPathPos do + lPath := lPath + lInName[lPos]; + end; + // else + // dec(lPathPos); + inc(lPathPos); + //next find first ext + //lExtPos := 1; + lExtPos := length(lPath);//July 2009 -- beware of '.' in foldername... + while (lExtPos <= lLen) and (lInName[lExtPos] <> '.') do + inc(lExtPos); + if (lInName[lExtPos] = '.') then begin + for lPos := lExtPos to lLen do + lExt := lExt + lInName[lPos]; + end; + // else + // inc(lExtPos); + dec(lExtPos); + //next extract filename + //fx(lPathPos,lExtPos); + if (lPathPos <= lExtPos) then + for lPos := lPathPos to lExtPos do + lName := lName + lInName[lPos]; + result := true; + +end; + +procedure createArray64 (var ptr: pointer; var ra :Doublep0; Sz: integer); overload; +var i: integer; +begin + getmem(ptr,16+(sizeof(double)*Sz)); + {$IFDEF FPC} + ra := align(ptr,16); + {$ELSE} + ra := DoubleP0((integer(ptr) and $FFFFFFF0)+16); + {$ENDIF} + for i := (Sz-1) downto 0 do //initialise array + ra^[i] := 0; +end; + +procedure createArray64 (var ptr: pointer; var ra :Doublep; Sz: integer); overload; +var i: integer; +begin + getmem(ptr,16+(sizeof(double)*Sz)); + {$IFDEF FPC} + ra := align(ptr,16); + {$ELSE} + ra := DoubleP((integer(ptr) and $FFFFFFF0)+16); + {$ENDIF} + for i := (Sz) downto 1 do //initialise array + ra^[i] := 0; +end; + + +function OKMsg(lMsg: string): boolean; //shows dialog with OK/Cancel returns true if user presses OK +begin + result := false; + {$IFDEF GUI} + case MessageDlg(lMsg, mtConfirmation, + [mbYes, mbCancel], 0) of + idCancel {mrCancel}: exit; + end; //case + {$ELSE} + case MsgDlg(lMsg, mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + {$ENDIF} + result := true; +end; + +(*function DirExists (lDir: String): boolean; +var lSearchRec: TSearchRec; +begin + FindFirst(lDir, faAnyFile, lSearchRec); + if (faDirectory and lSearchRec.attr) = faDirectory then + DirExists := true + else + DirExists := false; + FindClose(lSearchRec);{} +end;*) + +{$IFNDEF GUI} + {$IFNDEF FPC} + //The FileCtrl unit is pretty bulky, and we only need this one call that it links from SysUtils + function DirectoryExists(const Name: string): Boolean; +var + Code: Integer; +begin + Code := GetFileAttributes(PChar(Name)); + Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); +end; + {$ENDIF} +{$ENDIF} + +function DirExists (lFolderName: string): boolean; +(*{$IFNDEF GUI} +var + lSearchRec: TSearchRec; +begin + result := false; + if fileexists(lFoldername) then //File not folder + exit; + Filemode := 0; //readonly + if FindFirst(lFolderName, faDirectory, lSearchRec) = 0 then begin + result := true; + FindClose(lSearchRec); + end else + result := false; //some files found + Filemode := 2; +{$ELSE} +*) +begin + result := DirectoryExists(lFolderName); +//{$ENDIF} +end; + +function freeRam: Int64; +{$IFDEF UNIX} +begin + result := maxint; +end; +{$ELSE} +var + memory:TMemoryStatus; + +begin + memory.dwLength:=sizeof(memory); + GlobalMemoryStatus(memory); + result := memory.dwavailPhys; + //result := 1024; +end; +{$ENDIF} + +procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +var lInc,lSwap: integer; +begin + for lInc := 1 to 3 do + if lCutout.Lo[lInc] > lCutout.Hi[lInc] then begin + lSwap := lCutout.Lo[lInc]; + lCutout.Lo[lInc] := lCutout.Hi[lInc]; + lCutout.Hi[lInc] := lSwap; + end; +end; + + +function ChangeFilePostfixExt (lInName,lPostfix,lExt: string): string; +var + lPath,lName,lExtIn: string; +begin + FilenameParts (lInName, lPath,lName,lExtIn); + result := lPath+lName+lPostFix+lExt; + //showmessage(result); +end; + +(*var + lC,lLen,lPos: integer; + lStr: string; +begin + result := changefileext(lInName,lExt); + lLen := length (result); + if lLen < 1 then exit; + lPos := lLen; + while (lPos > 1) and (result[lPos] <> pathdelim) and (result[lPos] <> '.') do + dec(lPos); + if result[lPos] = '.' then + dec(lPos); + lStr := ''; + for lC := 1 to lPos do + lStr := lStr+result[lC]; + lStr := lStr+lPostfix; + if lPos < lLen then + for lC := (lPos+1) to lLen do + lStr := lStr+result[lC]; + result := lStr; +end; *) + +(*procedure ApplySaveDlgFilter (lSaveDlg: TSaveDialog); +var + lLen,lPos,lPipes,lPipesReq: integer; + lExt: string; +begin + lPipesReq := (lSaveDlg.FilterIndex * 2)-1; + if lPipesReq < 1 then exit; + lLen := length(lSaveDlg.Filter); + lPos := 1; + lPipes := 0; + while (lPos < lLen) and (lPipes < lPipesReq) do begin + if lSaveDlg.Filter[lPos] = '|' then + inc(lPipes); + inc(lPos); + end; + if (lPos >= lLen) or (lPipes < lPipesReq) then + exit; + lExt := ''; + while (lPos <= lLen) and (lSaveDlg.Filter[lPos] <> '|') do begin + if lSaveDlg.Filter[lPos] <> '*' then + lExt := lExt + lSaveDlg.Filter[lPos]; + inc(lPos); + end; + if lExt <> '' then + lSaveDlg.Filename := ChangeFileExt(lSaveDlg.Filename,lExt); +end; *) + +(*function DefaultsDir (lSubFolder: string): string; +//for Linux: DefaultsDir is ~/appname/SubFolder/, e.g. /home/username/mricron/subfolder/ +//for Windows: DefaultsDir is in the location of the executable, e.g. c:\program files\mricron\subfolder\ +//Note: Final character is pathdelim +var + lBaseDir: string; +begin + {$IFDEF Unix} + lBaseDir := GetEnvironmentVariable ('HOME')+pathdelim+'.' +ParseFileName(ExtractFilename(paramstr(0) ) ); + if not DirectoryExists(lBaseDir) then begin + {$I-} + MkDir(lBaseDir); + if IOResult <> 0 then begin + showmessage('Unble to create new folder '+lBaseDir); + end; + {$I+} + end; + lBaseDir := lBaseDir+pathdelim; + {$ELSE} + lBaseDir := extractfiledir(paramstr(0))+pathdelim; + {$ENDIF} + //if not DirectoryExists(extractfiledir(lBaseDir)) then + //mkDir(extractfiledir(lBaseDir)); + if lSubFolder <> '' then begin + lBaseDir := lBaseDir + lSubFolder; + if not DirectoryExists(lBaseDir) then begin + {$I-} + MkDir(lBaseDir); + if IOResult <> 0 then begin + showmessage('Unable to create new folder '+lBaseDir); + end; + {$I+} + end; + result := lBaseDir + pathdelim; + end else + result := lBaseDir; +end; *) + +function Swap2(s : SmallInt): smallint; +type + swaptype = packed record + case byte of + 0:(Word1 : word); //word is 16 bit + 1:(Small1: SmallInt); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word1); + result :=outguy.Small1; +end; + +{$IFDEF GUI} +procedure ShowMsg(s: string); +begin + showmessage(s); +end; +{$ENDIF} +procedure fx (a: double); overload; //fx used to help debugging - reports number values +begin + ShowMsg(floattostr(a)); +end; + +procedure fx (a,b: double); overload; //fx used to help debugging - reports number values +begin + ShowMsg(floattostr(a)+'x'+floattostr(b)); +end; + +procedure fx (a,b,c: double); overload; //fx used to help debugging - reports number values +begin + ShowMsg(floattostr(a)+'x'+floattostr(b)+'x'+floattostr(c)); +end; + +procedure fx (a,b,c,d: double); overload; //fx used to help debugging - reports number values +begin + ShowMsg(floattostr(a)+'x'+floattostr(b)+'x'+floattostr(c)+'x'+floattostr(d)); +end; + +procedure CopyFileEXoverwrite (lInName,lOutName: string); +var lFSize: Integer; + lBuff: bytep0; + lFData: file; +begin + lFSize := FSize(lInName); + if (lFSize < 1) then exit; + assignfile(lFdata,lInName); + filemode := 0; + reset(lFdata,lFSize{1}); + GetMem( lBuff, lFSize); + BlockRead(lFdata, lBuff^, 1{lFSize}); + closefile(lFdata); + assignfile(lFdata,lOutName); + filemode := 2; + Rewrite(lFdata,lFSize); + BlockWrite(lFdata,lBuff^, 1 {, NumWritten}); + closefile(lFdata); + freemem(lBuff); +end; + +procedure CopyFileEX (lInName,lOutName: string); +var lFSize: Integer; +begin + lFSize := FSize(lInName); + if (lFSize < 1) or (fileexistsEX(lOutName)) then exit; + CopyFileEXoverwrite (lInName,lOutName); +end; + +function IniInt(lIniFile: TIniFile; lIdent: string; lDefault: integer): integer; +var + lStr: string; +begin + result := lDefault; + lStr := lIniFile.ReadString('INT',lIdent, ''); + if length(lStr) > 0 then + result := StrToInt(lStr); +end; //proc IniInt + +function IniBool(var lIniFile: TIniFile; lIdent: string; lDefault: boolean): boolean; +var + lStr: string; +begin + result := lDefault; + lStr := lIniFile.ReadString('BOOL',lIdent, ''); + //showmessage('x'+lStr+'x'); + if length(lStr) > 0 then + result := Char2Bool(lStr[1]); +end; //nested IniBool + + +procedure SortInteger(var lLo,lHi: integer); +var lSwap: integer; +begin + if lLo > lHi then begin + lSwap := lLo; + lLo := lHi; + lHi := lSwap; + end; //if Lo>Hi +end; //proc SortSingle + +procedure SortSingle(var lLo,lHi: single); +var lSwap: single; +begin + if lLo > lHi then begin + lSwap := lLo; + lLo := lHi; + lHi := lSwap; + end; //if Lo>Hi +end; //proc SortSingle + +{$IFDEF FPC} + {$IFDEF UNIX} //FPC and Unix + function DiskFreeEx (DriveStr: String): Int64; + var + lOutDisk: Integer; + begin + + lOutDisk := AddDisk(DriveStr); + result := DiskFree(lOutDisk); + if result < 0 then + result := 9223372036854775807; + end; + {$ELSE} //FPC and Windows + function DiskFreeEx (DriveStr: String): Int64; + var + lOutDisk: Integer; + begin + lOutDisk := ord(upcase(DriveStr[1]))+1-ord('A'); + if (lOutDisk >= 0) and (lOutDisk <= 26) then + result := DiskFree(lOutDisk) + else + result := 0; + //showmessage(DriveStr+'->*'+inttostr(lOutDisk)+'* :'+inttostr(result)); + //showmessage(inttostr(DiskFree(0){current drive})+' :'+inttostr(DiskFree(3) {C drive})); + end; + {$ENDIF} +{$ELSE} //Delphi Windows + +function DiskFreeEx (DriveStr: String): Integer; +var + lOutDisk: Integer; + lDiskDir : string; + lSize8: Tinteger8; +begin + lOutDisk := ord(upcase(DriveStr[1]))+1-ord('A'); + if (lOutDisk >= ord('A')) and (lOutDisk <= ord('Z')) then begin + DiskFreeEx := DiskFree(lOutDisk); + end else begin + lDiskDir :=(ExtractFileDrive(DriveStr))+'\'; + lSize8 := DiskFreeStr (lDiskDir); + if lSize8 > MaxINt then DiskFreeEx := MaxInt + else DiskFreeEx := round(lSize8); + end; +end; + {$ENDIF} + +function Log(X, Base: single): single; +begin + if X = 0 then + result := 0 + else + Log := Ln(X) / Ln(Base); +end; + +function Bool2Char (lBool: boolean): char; +begin + if lBool then + result := '1' + else + result := '0'; +end; + +function Char2Bool (lChar: char): boolean; +begin + if lChar = '1' then + result := true + else + result := false; +end; + +procedure Xswap4r ( var s:single); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + inguy^.Word1 := outguy.Word1; + inguy^.Word2 := outguy.Word2; +end; + +procedure swap4(var s : LongInt); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + s:=outguy.Long; +end; + +function UpCaseExt(lFileName: string): string; +var lI: integer; +l2ndExt,lExt : string; +begin + lExt := ExtractFileExt(lFileName); + if length(lExt) > 0 then + for lI := 1 to length(lExt) do + lExt[lI] := upcase(lExt[lI]); + result := lExt; + if lExt <> '.GZ' then exit; + lI := length(lFileName) - 6; + if li < 1 then exit; + l2ndExt := upcase(lFileName[lI])+upcase(lFileName[lI+1])+upcase(lFileName[li+2])+upcase(lFileName[li+3]); + if (l2ndExt = '.NII')then + result := l2ndExt+lExt + else if (l2ndExt = 'BRIK') and (lI > 1) and (lFileName[lI-1] = '.') then + result := '.BRIK'+lExt; +end; + +function ExtGZ (lFilename: string): boolean; +var + lI: integer; + lExt : string; +begin + lExt := ExtractFileExt(lFileName); + if length(lExt) > 0 then + for lI := 1 to length(lExt) do + lExt[lI] := upcase(lExt[lI]); + if lExt = '.GZ' then + result := true + else + result := false; +end; + +function RealToStr(lR: double {was extended}; lDec: integer): string; +begin + RealTOStr := FloatToStrF(lR, ffFixed,7,lDec); +end; + +FUNCTION specialdouble (d:double): boolean; +//returns true if s is Infinity, NAN or Indeterminate +//8byte IEEE: msb[63] = signbit, bits[52-62] exponent, bits[0..51] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +CONST kSpecialExponent = 2047 shl 20; +VAR Overlay: ARRAY[1..2] OF LongInt ABSOLUTE d; +BEGIN + IF ((Overlay[2] AND kSpecialExponent) = kSpecialExponent) THEN + RESULT := true + ELSE + RESULT := false; +END; + +function swap8r(s : double):double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + try + result:=outguy.float; + except + result := 0; + exit; + end; +end; //func swap8r + +procedure pswap4i(var s : LongInt); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + s:=outguy.Long; +end; //proc swap4 + +function swap64r(s : double):double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + try + swap64r:=outguy.float; + except + swap64r := 0; + exit; + end;{} +end; + +procedure pswap4r ( var s:single); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + inguy^.Word1 := outguy.Word1; + inguy^.Word2 := outguy.Word2; +end; //proc Xswap4r + +function conv4r4i (s:single): longint; +type + swaptype = packed record + case byte of + 1:(long:longint); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; +begin + inguy := @s; //assign address of s to inguy + conv4r4i:=inguy^.long; +end; + +function swap4r4i (s:single): longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(long:longint); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap4r4i:=outguy.long; +end;//swap4r4i + +(*function ChangeFileExtX( var lFilename: string; lExt: string): string; +begin + result := ChangeFileExt(lFilename,lExt); +end; *) + +function ChangeFileExtX(var lFilename: string; lExt: string): string;// overload; +//sees .nii.gz as single extension +var + lPath,lName,lOrigExt: string; +begin + if FilenameParts (lFilename, lPath,lName,lOrigExt) then begin + //showmessage('12222'+lPath +'**'+lName+'**'+lOrigExt); + result := lPath+lName+lExt; + end else begin + //showmessage('z'); + result := ChangeFileExt(lFilename,lExt); + end; +end; + +function PadStr (lValIn, lPadLenIn: integer): string; +var lOrigLen,lPad : integer; +begin + lOrigLen := length(inttostr(lValIn)); + result := inttostr(lValIn); + if lOrigLen < lPadLenIn then begin + lOrigLen := lPadLenIn-lOrigLen; + for lPad := 1 to lOrigLen do + result := '0'+result; + end; +end; + +function ExtractFileDirWithPathDelim(lInFilename: string): string; +//F:\filename.ext -> 'F:\' and F:\dir\filename.ext -> 'F:\dir\' +//Despite documentation, Delphi3's ExtractFileDir does not always retain final pathdelim +var lFilePath: string; +begin + result := ''; + if DirExists(lInFilename) then + lFilePath := lInFilename + else + lFilePath := ExtractFileDir(lInFilename); + if length(lFilepath) < 1 then exit; + if lFilePath[length(lFilepath)] <> pathdelim then + lFilepath := lFilepath + pathdelim; //Delphi3 bug: sometimes forgets pathdelim + result := lFilepath; +end; + +function ParseFileFinalDir (lFileName:String): string; +var + lLen,lInc,lPos: integer; + lInName,lName: String; +begin + lInName := extractfiledir(lFilename); + lName := ''; + lLen := length(lInName); + if lLen < 1 then exit; + lInc := lLen; + repeat + dec(lInc); + until (lInName[lInc] = pathdelim) or (lInc = 1); + if lInName[lInc] = pathdelim then inc(lInc); //if '\folder' then return 'folder' + for lPos := lInc to lLen do + lName := lName + lInName[lPos]; + ParseFileFinalDir := lName; +end; + +function ParseFileName (lFilewExt:String): string; +var + lExt: string; + i: integer; +begin + lExt := UpCaseExt(lFilewExt); + if (length(lExt) < 1) or (length(lExt) >= length(lFilewExt)) then exit; + result := ''; + for i := 1 to (length(lFilewExt)-length(lExt)) do + result := result + lFilewExt[i]; +end; + +(*function ParseFileName (lFilewExt:String): string; +var + lLen,lInc: integer; + lName: String; +begin + lName := ''; + lLen := length(lFilewExt); + lInc := lLen+1; + if lLen > 0 then begin + repeat + dec(lInc); + until (lFileWExt[lInc] = '.') or (lInc = 1); + if (UpCaseExt(lFilewExt) = '.NII.GZ') and (lInc > 1) then + repeat + dec(lInc); + until (lFileWExt[lInc] = '.') or (lInc = 1); + end; + if lInc > 1 then + for lLen := 1 to (lInc - 1) do + lName := lName + lFileWExt[lLen] + else + lName := lFilewExt; //no extension + ParseFileName := lName; +end; *) + +Function {TMainForm.}FileExistsEX(Name: String): Boolean; +var + F: File; +begin + result := false; + if Name = '' then + exit; + result := FileExists(Name); + if result then exit; + //the next bit attempts to check for a file to avoid WinNT bug + AssignFile(F, Name); + {$I-} + Reset(F); + {$I+} + Result:=IOresult = 0; + if Result then + CloseFile(F); +end; + +function FSize (lFName: String): Int64; +var SearchRec: TSearchRec; +begin + result := 0; + if not fileexistsex(lFName) then exit; + FindFirst(lFName, faAnyFile, SearchRec); + result := SearchRec.size; + FindClose(SearchRec); +end; + +procedure Xswap8r(var s : double); +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + //1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + inguy^.Word1 := outguy.Word1; + inguy^.Word2 := outguy.Word2; + inguy^.Word3 := outguy.Word3; + inguy^.Word4 := outguy.Word4; +end; + +FUNCTION specialsingle (var s:single): boolean; +//returns true if s is Infinity, NAN or Indeterminate +//4byte IEEE: msb[31] = signbit, bits[23-30] exponent, bits[0..22] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +CONST kSpecialExponent = 255 shl 23; +VAR Overlay: LongInt ABSOLUTE s; +BEGIN + IF ((Overlay AND kSpecialExponent) = kSpecialExponent) THEN + RESULT := true + ELSE + RESULT := false; +END; + +end. diff --git a/common/backup/nifti_hdr.pas.bak b/common/backup/nifti_hdr.pas.bak new file mode 100755 index 0000000..de3be9e --- /dev/null +++ b/common/backup/nifti_hdr.pas.bak @@ -0,0 +1,1235 @@ +unit nifti_hdr; +interface +{$H+} +{$Include isgui.inc} +{$MODE DELPHI} +uses +{$IFNDEF FPC} + DiskSpaceKludge,gziod, +{$ELSE} + gzio2, +{$ENDIF} +{$IFNDEF Unix} Windows, {$ENDIF} +define_types,SysUtils,GraphicsMathLibrary, nifti_types, nifti_foreign, + dialogsx; + +type + + TAnalyzeHdrSection = packed record //Next: analyze Format Header structure + Pad: array [1..253] of byte; + originator: array [1..5] of smallint; + end;//TAnalyzeHdrSection Structure + + TMRIcroHdr = record //Next: analyze Format Header structure + NIFTIhdr : TNIFTIhdr; + AutoBalMinUnscaled,AutoBalMaxUnscaled + ,WindowScaledMin,WindowScaledMax + ,GlMinUnscaledS,GlMaxUnscaledS,Zero8Bit,Slope8bit: single; //brightness and contrast + NIfTItransform,DiskDataNativeEndian,UsesCustomPalette,UsesCustomPaletteRandomRainbow,UsesLabels,LutFromZero: boolean; + HdrFileName,ImgFileName,ECodeText: string; + gzBytesX: int64; + NIFTIVersion,LUTindex,ScrnBufferItems,ImgBufferItems,RenderBufferItems,ImgBufferBPP,RenderDim,Index: longint; + ImgBufferUnaligned: Pointer; //raw address of Image Buffer: address may not be aligned + ScrnBuffer,ImgBuffer,RenderBuffer: Bytep; + LUTinvisible: TRGBQuad;//DWord; + LUT: TLUT;//array[0..255] of TRGBQuad; + Mat: TMatrix; + end; //TNIFTIhdr Header Structure + + + function IsVOIROIExt (var lFName: string):boolean; + function ComputeImageDataBytes (var lHdr: TMRIcroHdr): longint; //size of image data in bytes + function ComputeImageDataBytes8bpp (var lHdr: TMRIcroHdr): longint; //size of image as 32-bit per voxel data in bytes + function ComputeImageDataBytes32bpp (var lHdr: TMRIcroHdr): longint; //size of image as 32-bit per voxel data in bytes + procedure NIFTIhdr_SwapBytes (var lAHdr: TNIFTIhdr); //Swap Byte order for the Analyze type + procedure NIFTIhdr_ClearHdr (var lHdr: TMRIcroHdr); //set all values of header to something reasonable + function NIFTIhdr_LoadHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TMRIcroHdr; lAllowOverwrite: boolean): boolean; overload; + function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2: boolean): boolean; overload; + procedure NIFTIhdr_SetIdentityMatrix (var lHdr: TMRIcroHdr); //create neutral rotation matrix + function IsNIfTIHdrExt (var lFName: string):boolean; //1494 + function IsNifTiMagic (var lHdr: TNIFTIhdr): boolean; + //procedure NearestOrtho(var lHdr: TMRIcroHdr); +//function nifti_mat44_orthog( lR :TMatrix; lImm,lJmm,lKmm: double): TMatrix; + + function CopyNiftiHdr (var lInHdr,lOutHdr: TNIFTIhdr): boolean; + procedure WriteNiftiMatrix (var lHdr: TNIFTIhdr; + m11,m12,m13,m14, + m21,m22,m23,m24, + m31,m32,m33,m34: Single); + procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); + + +implementation +uses +{$IFDEF GUI} dialogs,{$ENDIF} +dicomhdr;//2/2208 + +function CopyNiftiHdr (var lInHdr,lOutHdr: TNIFTIhdr): boolean; +begin + move(lInHdr,lOutHdr,sizeof(TNIFTIhdr)); + result := true; +end; + +procedure WriteNiftiMatrix (var lHdr: TNIFTIhdr; + m11,m12,m13,m14, + m21,m22,m23,m24, + m31,m32,m33,m34: Single); +begin + with lHdr do begin + srow_x[0] := m11; + srow_x[1] := m12; + srow_x[2] := m13; + srow_x[3] := m14; + srow_y[0] := m21; + srow_y[1] := m22; + srow_y[2] := m23; + srow_y[3] := m24; + srow_z[0] := m31; + srow_z[1] := m32; + srow_z[2] := m33; + srow_z[3] := m34; + end; //with lHdr +end; + +function IsNifTi1Magic (var lHdr: TNIFTIhdr): boolean; +begin + if (lHdr.magic =kNIFTI_MAGIC_SEPARATE_HDR) or (lHdr.Magic = kNIFTI_MAGIC_EMBEDDED_HDR ) then + result := true + else + result :=false; //analyze +end; + +function IsNifTiMagic (var lHdr: TNIFTIhdr): boolean; +begin + if (IsNifTi1Magic(lHdr)) then + result := true + else + result :=false; //analyze +end; + +function IsNIfTIHdrExt (var lFName: string):boolean; +var + lExt: string; +begin + lExt := UpCaseExt(lFName); + if (lExt='.NII') or (lExt = '.HDR') or (lExt = '.NII.GZ') or (lExt = '.VOI') then + result := true + else + result := false; +end; + +function IsVOIROIExt (var lFName: string):boolean; +var + lExt: string; +begin + lExt := UpCaseExt(lFName); + if (lExt = '.VOI') or (lExt = '.ROI') then + result := true + else + result := false; +end; + +function ComputeImageDataBytes32bpp (var lHdr: TMRIcroHdr): integer; +var + lDim, lBytes : integer; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + ShowMsg('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + lBytes := 4; //bits per voxel + for lDim := 1 to 3 {Dim[0]} do + lBytes := lBytes * Dim[lDim]; + end; //with niftihdr + result := lBytes; //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes32bpp + +function ComputeImageDataBytes8bpp (var lHdr: TMRIcroHdr): integer; +var + lDim, lBytes: integer; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + ShowMsg('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + lBytes := 1; //bits per voxel + for lDim := 1 to 3 {Dim[0]} do + lBytes := lBytes * Dim[lDim]; + end; //with niftihdr + result := lBytes; //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes8bpp + +function ComputeImageDataBytes (var lHdr: TMRIcroHdr): integer; +var + lDim : integer; + lSzInBits : Int64; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + ShowMsg('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + lSzInBits := bitpix; //bits per voxel + //showmessage(inttostr(Dim[0])); + for lDim := 1 to 3 {Dim[0]} do + lSzInBits := lSzInBits * Dim[lDim]; + end; //with niftihdr + result := (lSzInBits + 7) div 8; //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes +function orthogonalMatrix(var lHdr: TMRIcroHdr): boolean; +var + lM: TMatrix; + lRow,lCol,lN0: integer; +begin + result := false; + lM := Matrix3D ( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + for lRow := 1 to 3 do begin + lN0 := 0; + for lCol := 1 to 3 do + if lM.matrix[lRow,lCol] = 0 then + inc(lN0); + if lN0 <> 2 then exit; //exactly two values are zero + end; + for lCol := 1 to 3 do begin + lN0 := 0; + for lRow := 1 to 3 do + if lM.matrix[lRow,lCol] = 0 then + inc(lN0); + if lN0 <> 2 then exit; //exactly two values are zero + end; + result := true; +end; + +function EmptyRow (lRow: integer; var lM: TMatrix): boolean; +begin + //fx(lM.matrix[lRow,1],lM.matrix[lRow,2],lM.matrix[lRow,3]); + if (abs(lM.matrix[lRow,1]) < 0.00000001) and (abs(lM.matrix[lRow,2]) < 0.00000001) and (abs(lM.matrix[lRow,3]) < 0.00000001) then + result := true + else + result := false; +end; + +procedure ReportMatrix (lStr: string;lM:TMatrix); +begin + ShowMsg(lStr+kCR+ + RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+ + kCR+RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+ + kCR+RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+ + kCR+RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6)); +end; + +function EmptyMatrix(var lHdr: TMRIcroHdr): boolean; +var + lM: TMatrix; + lRow,lCol: integer; +begin + result := false; + lM := Matrix3D ( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + if EmptyRow(1,lM) or EmptyRow(2,lM) or EmptyRow(3,lM) then begin + ReportMatrix('Matrix appears bogus',lm); + end else begin + for lRow := 1 to 3 do begin {3/2008} + for lCol := 1 to 4 do begin + if (lRow = lCol) then begin + if lM.matrix[lRow,lCol] <> 1 then + exit; + end else begin + if lM.matrix[lRow,lCol] <> 0 then + exit; + end// unity matrix does not count - mriconvert creates bogus [1 0 0 0; 0 1 0 0; 0 0 1 0; 0 0 0 0] + end; //each col + end;//each row + end;//not bogus + result := true; +end; + + + +procedure FromMatrix (M: TMatrix; var m11,m12,m13, m21,m22,m23, + m31,m32,m33: DOUBLE) ; + BEGIN + m11 := M.Matrix[1,1]; + m12 := M.Matrix[1,2]; + m13 := M.Matrix[1,3]; + m21 := M.Matrix[2,1]; + m22 := M.Matrix[2,2]; + m23 := M.Matrix[2,3]; + m31 := M.Matrix[3,1]; + m32 := M.Matrix[3,2]; + m33 := M.Matrix[3,3]; +END {FromMatrix3D}; + + +function nifti_mat33_determ( R: TMatrix ):double; +begin + result := r.matrix[1,1]*r.matrix[2,2]*r.matrix[3,3] + -r.matrix[1,1]*r.matrix[3,2]*r.matrix[2,3] + -r.matrix[2,1]*r.matrix[1,2]*r.matrix[3,3] + +r.matrix[2,1]*r.matrix[3,2]*r.matrix[1,3] + +r.matrix[3,1]*r.matrix[1,2]*r.matrix[2,3] + -r.matrix[3,1]*r.matrix[2,2]*r.matrix[1,3] ; +end; + +procedure FixCrapMat(var lMat: TMatrix); +var + lVec000,lVec100,lVec010,lVec001: TVector; +begin + lVec000 := Vector3D (0, 0, 0); + lVec100 := Vector3D (1, 0, 0); + lVec010 := Vector3D (0, 1, 0); + lVec001 := Vector3D (0, 0, 1); + lVec000 := Transform (lVec000, lMat); + lVec100 := Transform (lVec100, lMat); + lVec010 := Transform (lVec010, lMat); + lVec001 := Transform (lVec001, lMat); + + if SameVec(lVec000,lVec100) or + SameVec(lVec000,lVec010) or + SameVec(lVec000,lVec001) then begin + lMat := eye3D; + ShowMsg('Warning: the transformation matrix is corrupt [some dimensions have zero size]'); + end; +end; + + +function nifti_mat33_rownorm( A: TMatrix ): single; //* max row norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A.matrix[1,1])+abs(A.matrix[1,2])+abs(A.matrix[1,3]) ; + r2 := abs(A.matrix[2,1])+abs(A.matrix[2,2])+abs(A.matrix[2,3]) ; + r3 := abs(A.matrix[3,1])+abs(A.matrix[3,2])+abs(A.matrix[3,3]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_colnorm( A: TMatrix ): single; //* max column norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A.matrix[1,1])+abs(A.matrix[2,1])+abs(A.matrix[3,1]) ; + r2 := abs(A.matrix[1,2])+abs(A.matrix[2,2])+abs(A.matrix[3,2]) ; + r3 := abs(A.matrix[1,3])+abs(A.matrix[2,3])+abs(A.matrix[3,3]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_inverse( R: TMatrix ): TMatrix; //* inverse of 3x3 matrix */ +var + r11,r12,r13,r21,r22,r23,r31,r32,r33 , deti: double ; + Q: TMatrix ; +begin + FromMatrix(R,r11,r12,r13,r21,r22,r23,r31,r32,r33); + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + + if( deti <> 0.0 ) then deti := 1.0 / deti ; + + Q.matrix[1,1] := deti*( r22*r33-r32*r23) ; + Q.matrix[1,2] := deti*(-r12*r33+r32*r13) ; + Q.matrix[1,3] := deti*( r12*r23-r22*r13) ; + + Q.matrix[2,1] := deti*(-r21*r33+r31*r23) ; + Q.matrix[2,2] := deti*( r11*r33-r31*r13) ; + Q.matrix[2,3] := deti*(-r11*r23+r21*r13) ; + + Q.matrix[3,1] := deti*( r21*r32-r31*r22) ; + Q.matrix[3,2] := deti*(-r11*r32+r31*r12) ; + Q.matrix[3,3] := deti*( r11*r22-r21*r12) ; + result := Q; +end; + +function nifti_mat33_polar( A: TMatrix ): TMatrix; +var + k:integer; + X , Y , Z: TMatrix ; + dif,alp,bet,gam,gmi : single; +begin +dif := 1; +k := 0; + X := A ; + // force matrix to be nonsingular + //reportmatrix('x',X); + gam := nifti_mat33_determ(X) ; + while( gam = 0.0 )do begin //perturb matrix + gam := 0.00001 * ( 0.001 + nifti_mat33_rownorm(X) ) ; + X.matrix[1,1] := X.matrix[1,1]+gam ; + X.matrix[2,2] := X.matrix[2,2]+gam ; + X.matrix[3,3] := X.matrix[3,3] +gam ; + gam := nifti_mat33_determ(X) ; + end; + + while true do begin + Y := nifti_mat33_inverse(X) ; + if( dif > 0.3 )then begin // far from convergence + alp := sqrt( nifti_mat33_rownorm(X) * nifti_mat33_colnorm(X) ) ; + bet := sqrt( nifti_mat33_rownorm(Y) * nifti_mat33_colnorm(Y) ) ; + gam := sqrt( bet / alp ) ; + gmi := 1.0 / gam ; + end else begin + gam := 1.0; + gmi := 1.0 ; //close to convergence + end; + Z.matrix[1,1] := 0.5 * ( gam*X.matrix[1,1] + gmi*Y.matrix[1,1] ) ; + Z.matrix[1,2] := 0.5 * ( gam*X.matrix[1,2] + gmi*Y.matrix[2,1] ) ; + Z.matrix[1,3] := 0.5 * ( gam*X.matrix[1,3] + gmi*Y.matrix[3,1] ) ; + Z.matrix[2,1] := 0.5 * ( gam*X.matrix[2,1] + gmi*Y.matrix[1,2] ) ; + Z.matrix[2,2] := 0.5 * ( gam*X.matrix[2,2] + gmi*Y.matrix[2,2] ) ; + Z.matrix[2,3] := 0.5 * ( gam*X.matrix[2,3] + gmi*Y.matrix[3,2] ) ; + Z.matrix[3,1] := 0.5 * ( gam*X.matrix[3,1] + gmi*Y.matrix[1,3] ) ; + Z.matrix[3,2] := 0.5 * ( gam*X.matrix[3,2] + gmi*Y.matrix[2,3] ) ; + Z.matrix[3,3] := 0.5 * ( gam*X.matrix[3,3] + gmi*Y.matrix[3,3] ) ; + + dif := abs(Z.matrix[1,1]-X.matrix[1,1])+abs(Z.matrix[1,2]-X.matrix[1,2]) + +abs(Z.matrix[1,3]-X.matrix[1,3])+abs(Z.matrix[2,1]-X.matrix[2,1]) + +abs(Z.matrix[2,2]-X.matrix[2,2])+abs(Z.matrix[2,3]-X.matrix[2,3]) + +abs(Z.matrix[3,1]-X.matrix[3,1])+abs(Z.matrix[3,2]-X.matrix[3,2]) + +abs(Z.matrix[3,3]-X.matrix[3,3]) ; + k := k+1 ; + if( k > 100) or (dif < 3.e-6 ) then begin + result := Z; + break ; //convergence or exhaustion + end; + X := Z ; + end; + result := Z ; +end; + + +procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd , a,b,c,d : double; + P,Q: TMatrix; //3x3 +begin + + + (* offset outputs are read write out of input matrix *) + qx := lR.matrix[1,4]; + qy := lR.matrix[2,4]; + qz := lR.matrix[3,4]; + + (* load 3x3 matrix into local variables *) + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + (* compute lengths of each column; these determine grid spacings *) + + xd := sqrt( r11*r11 + r21*r21 + r31*r31 ) ; + yd := sqrt( r12*r12 + r22*r22 + r32*r32 ) ; + zd := sqrt( r13*r13 + r23*r23 + r33*r33 ) ; + + (* if a column length is zero, patch the trouble *) + + if( xd = 0.0 )then begin r11 := 1.0 ; r21 := 0; r31 := 0.0 ; xd := 1.0 ; end; + if( yd = 0.0 )then begin r22 := 1.0 ; r12 := 0; r32 := 0.0 ; yd := 1.0 ; end; + if( zd = 0.0 )then begin r33 := 1.0 ; r13 := 0; r23 := 0.0 ; zd := 1.0 ; end; + + (* assign the output lengths *) + dx := xd; + dy := yd; + dz := zd; + + (* normalize the columns *) + + r11 := r11/xd ; r21 := r21/xd ; r31 := r31/xd ; + r12 := r12/yd ; r22 := r22/yd ; r32 := r32/yd ; + r13 := r13/zd ; r23 := r23/zd ; r33 := r33/zd ; + + (* At this point, the matrix has normal columns, but we have to allow + for the fact that the hideous user may not have given us a matrix + with orthogonal columns. + + So, now find the orthogonal matrix closest to the current matrix. + + One reason for using the polar decomposition to get this + orthogonal matrix, rather than just directly orthogonalizing + the columns, is so that inputting the inverse matrix to R + will result in the inverse orthogonal matrix at this point. + If we just orthogonalized the columns, this wouldn't necessarily hold. *) + Q := Matrix2D (r11,r12,r13, // 2D "graphics" matrix + r21,r22,r23, + r31,r32,r33); + + + + P := nifti_mat33_polar(Q) ; (* P is orthog matrix closest to Q *) + FromMatrix(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + //ReportMatrix('xxx',Q); + //ReportMatrix('svd',P); + (* [ r11 r12 r13 ] *) + (* at this point, the matrix [ r21 r22 r23 ] is orthogonal *) + (* [ r31 r32 r33 ] *) + + (* compute the determinant to determine if it is proper *) + + zd := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; (* should be -1 or 1 *) + + if( zd > 0 )then begin (* proper *) + qfac := 1.0 ; + end else begin (* improper ==> flip 3rd column *) + qfac := -1.0 ; + r13 := -r13 ; r23 := -r23 ; r33 := -r33 ; + end; + + (* now, compute quaternion parameters *) + + a := r11 + r22 + r33 + 1.0; + + if( a > 0.5 ) then begin (* simplest case *) + a := 0.5 * sqrt(a) ; + b := 0.25 * (r32-r23) / a ; + c := 0.25 * (r13-r31) / a ; + d := 0.25 * (r21-r12) / a ; + end else begin (* trickier case *) + xd := 1.0 + r11 - (r22+r33) ; (* 4*b*b *) + yd := 1.0 + r22 - (r11+r33) ; (* 4*c*c *) + zd := 1.0 + r33 - (r11+r22) ; (* 4*d*d *) + if( xd > 1.0 ) then begin + b := 0.5 * sqrt(xd) ; + c := 0.25* (r12+r21) / b ; + d := 0.25* (r13+r31) / b ; + a := 0.25* (r32-r23) / b ; + end else if( yd > 1.0 ) then begin + c := 0.5 * sqrt(yd) ; + b := 0.25* (r12+r21) / c ; + d := 0.25* (r23+r32) / c ; + a := 0.25* (r13-r31) / c ; + end else begin + d := 0.5 * sqrt(zd) ; + b := 0.25* (r13+r31) / d ; + c := 0.25* (r23+r32) / d ; + a := 0.25* (r21-r12) / d ; + end; + if( a < 0.0 )then begin b:=-b ; c:=-c ; d:=-d; {a:=-a; this is not used} end; + end; + + qb := b ; + qc := c ; + qd := d ; + //fx(qb,qc,qd); +end; + +procedure nifti_quatern_to_mat44( var lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + a,b,c,d,xd,yd,zd: double; +begin + //a := qb; + b := qb; + c := qc; + d := qd; + //* last row is always [ 0 0 0 1 ] */ + lR.matrix[4,1] := 0; + lR.matrix[4,2] := 0; + lR.matrix[4,3] := 0; + lR.matrix[4,4] := 1; + //* compute a parameter from b,c,d */ + a := 1.0 - (b*b + c*c + d*d) ; + if( a < 1.e-7 ) then begin//* special case */ + a := 1.0 / sqrt(b*b+c*c+d*d) ; + b := b*a ; c := c*a ; d := d*a ;//* normalize (b,c,d) vector */ + a := 0.0 ;//* a = 0 ==> 180 degree rotation */ + end else begin + a := sqrt(a) ; //* angle = 2*arccos(a) */ + end; + //* load rotation matrix, including scaling factors for voxel sizes */ + if dx > 0 then + xd := dx + else + xd := 1; + if dy > 0 then + yd := dy + else + yd := 1; + if dz > 0 then + zd := dz + else + zd := 1; + if( qfac < 0.0 ) then zd := -zd ;//* left handedness? */ + lR.matrix[1,1]:= (a*a+b*b-c*c-d*d) * xd ; + lR.matrix[1,2]:= 2.0 * (b*c-a*d ) * yd ; + lR.matrix[1,3]:= 2.0 * (b*d+a*c ) * zd ; + lR.matrix[2,1]:= 2.0 * (b*c+a*d ) * xd ; + lR.matrix[2,2]:= (a*a+c*c-b*b-d*d) * yd ; + lR.matrix[2,3]:= 2.0 * (c*d-a*b ) * zd ; + lR.matrix[3,1]:= 2.0 * (b*d-a*c ) * xd ; + lR.matrix[3,2]:= 2.0 * (c*d+a*b ) * yd ; + lR.matrix[3,3]:= (a*a+d*d-c*c-b*b) * zd ; + //* load offsets */ + lR.matrix[1,4]:= qx ; + lR.matrix[2,4]:= qy ; + lR.matrix[3,4]:= qz ; + +end; + +function TryQuat2Matrix( var lHdr: TNIfTIHdr ): boolean; +var lR :TMatrix; +begin + + result := false; + if (lHdr.qform_code <= kNIFTI_XFORM_UNKNOWN) or (lHdr.qform_code > kNIFTI_XFORM_MNI_152) then + exit; + + result := true; + nifti_quatern_to_mat44(lR,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lHdr.pixdim[1],lHdr.pixdim[2],lHdr.pixdim[3], + lHdr.pixdim[0]); + lHdr.srow_x[0] := lR.matrix[1,1]; + lHdr.srow_x[1] := lR.matrix[1,2]; + lHdr.srow_x[2] := lR.matrix[1,3]; + lHdr.srow_x[3] := lR.matrix[1,4]; + lHdr.srow_y[0] := lR.matrix[2,1]; + lHdr.srow_y[1] := lR.matrix[2,2]; + lHdr.srow_y[2] := lR.matrix[2,3]; + lHdr.srow_y[3] := lR.matrix[2,4]; + lHdr.srow_z[0] := lR.matrix[3,1]; + lHdr.srow_z[1] := lR.matrix[3,2]; + lHdr.srow_z[2] := lR.matrix[3,3]; + lHdr.srow_z[3] := lR.matrix[3,4]; + lHdr.sform_code := 1; +end; + +{procedure ReportMatrix (lM:TMatrix); +var lStr: string; +begin + + lStr := ( RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)) + +kCR+( RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)) + +kCR+( RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)) + +kCR+( RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6)); +showmessage(lStr); +end; } +function FixDataType (var lHdr: TMRIcroHdr ): boolean; +//correct mistakes of datatype and bitpix - especially for software which only sets one +label + 191; +var + ldatatypebpp,lbitpix: integer; +begin + result := true; + lbitpix := lHdr.NIFTIhdr.bitpix; + case lHdr.NIFTIhdr.datatype of + kDT_BINARY : ldatatypebpp := 1; + kDT_UNSIGNED_CHAR : ldatatypebpp := 8; // unsigned char (8 bits/voxel) + kDT_SIGNED_SHORT : ldatatypebpp := 8; // signed short (16 bits/voxel) + kDT_SIGNED_INT : ldatatypebpp := 32; // signed int (32 bits/voxel) + kDT_FLOAT : ldatatypebpp := 32; // float (32 bits/voxel) + kDT_COMPLEX : ldatatypebpp := 64; // complex (64 bits/voxel) + kDT_DOUBLE : ldatatypebpp := 64; // double (64 bits/voxel) + kDT_RGB : ldatatypebpp := 24; // RGB triple (24 bits/voxel) + kDT_INT8 : ldatatypebpp := 8; // signed char (8 bits) + kDT_UINT16 : ldatatypebpp := 16; // unsigned short (16 bits) + kDT_UINT32 : ldatatypebpp := 32; // unsigned int (32 bits) + kDT_INT64 : ldatatypebpp := 64; // long long (64 bits) + kDT_UINT64 : ldatatypebpp := 64; // unsigned long long (64 bits) + kDT_FLOAT128 : ldatatypebpp := 128; // long double (128 bits) + kDT_COMPLEX128 : ldatatypebpp := 128; // double pair (128 bits) + kDT_COMPLEX256 : ldatatypebpp := 256; // long double pair (256 bits) + else + ldatatypebpp := 0; + end; + if (ldatatypebpp = lHdr.NIFTIhdr.bitpix) and (ldatatypebpp <> 0) then + exit; + if (ldatatypebpp <> 0) then begin + //use bitpix from datatype... + showmessage(inttostr(lHdr.NIFTIhdr.datatype) +' '+inttostr(ldatatypebpp)+' '+inttostr(lbitpix)); + lHdr.NIFTIhdr.bitpix := ldatatypebpp; + exit; + end; + + if (lbitpix <> 0) and (ldatatypebpp = 0) then begin + //assume bitpix is correct.... + //note that several datatypes correspond to each bitpix, so assume most popular... + case lbitpix of + 1: lHdr.NIFTIhdr.datatype := kDT_BINARY; + 8: lHdr.NIFTIhdr.datatype := kDT_UNSIGNED_CHAR; + 16: lHdr.NIFTIhdr.datatype := kDT_SIGNED_SHORT; + 24: lHdr.NIFTIhdr.datatype := kDT_RGB; + 32: lHdr.NIFTIhdr.datatype := kDT_FLOAT; + 64: lHdr.NIFTIhdr.datatype := kDT_DOUBLE; + else goto 191; //impossible bitpix + end; + exit; + end; +191: + //Both bitpix and datatype are wrong... assume most popular format + lHdr.NIFTIhdr.bitpix := 16; + lHdr.NIFTIhdr.datatype := kDT_SIGNED_SHORT; + //fx(lHdr.NIFTIhdr.bitpix, lHdr.NIFTIhdr.datatype); +end; + +//function ReadEcode(lHdr: TMRIcroHdr; swapEndian: boolean): string; +procedure ReadEcode(var lHdr: TMRIcroHdr); +var + + extension : array[0..3] of byte; + myFile : File; + esize , ecode: longint; + lFileSz, lEnd, lStart, i: integer; + lBuff: array of char; +begin + lFileSz := FSize (lHdr.HdrFileName); + if (lFileSz < sizeof(lHdr.NIFTIhdr)+14) then exit; + if (lHdr.gzBytesX = K_gzBytes_headerAndImageUncompressed) then begin + AssignFile(myFile, lHdr.HdrFileName); + FileMode := fmOpenRead; + Reset(myFile, 1); // Now we define one record as 1 byte + seek(myFile, sizeof(lHdr.NIFTIhdr)); + BlockRead(myFile, extension, 4); + if extension[0] = 0 then begin + CloseFile(myFile); + exit; + end; + BlockRead(myFile, esize, 4); + BlockRead(myFile, ecode, 4); + if (lHdr.DiskDataNativeEndian = false) then begin + swap4(esize); + swap4(ecode); + end; + esize := esize - 8; //-8 as esize includes 8 bytes of esize and ecode themselves + lStart := sizeof(lHdr.NIFTIhdr)+12; + lEnd := lStart + esize; + if (lEnd > lFileSz) or (esize < 1) then begin// or ((ecode <> 6) and (ecode <> 4)) then begin //XML or Text + CloseFile(myFile); + exit; + end; + SetLength(lBuff, esize); + BlockRead(myFile, lBuff[0], esize); + SetString(lHdr.ECodeText, PChar(@lBuff[0]), esize); + CloseFile(myFile); + exit; + end; + //next: compressed header + lFileSz := round(lHdr.NIFTIhdr.vox_offset); + SetLength(lBuff, lFileSz); + UnGZip(lHdr.HdrFileName,bytep(lBuff),0,lFileSz); + i := sizeof(lHdr.NIFTIhdr); + extension[0] := ord(lBuff[i]); + if extension[0] = 0 then exit; + i := i + 4; + esize := ord(lBuff[i]) + ord(lBuff[i+1]) shl 8 + ord(lBuff[i+2]) shl 16 + ord(lBuff[i+3]) shl 24; + i := i + 4; + ecode := ord(lBuff[i]) + ord(lBuff[i+1]) shl 8 + ord(lBuff[i+2]) shl 16 + ord(lBuff[i+3]) shl 24; + {$IFDEF ENDIAN_BIG} + if (lHdr.DiskDataNativeEndian = true) then begin + swap4(esize); + swap4(ecode); + end; + {$ELSE} + if (lHdr.DiskDataNativeEndian = false) then begin + swap4(esize); + swap4(ecode); + end; + {$ENDIF} + //showmessage(inttostr(ord(lBuff[i]))+' '+inttostr(ord(lBuff[i+1])) ); + esize := esize - 8; //-8 as esize includes 8 bytes of esize and ecode themselves + lStart := sizeof(lHdr.NIFTIhdr)+12; + lEnd := lStart + esize; + if (lEnd > lFileSz) or (esize < 1) then exit; + SetString(lHdr.ECodeText, PChar(@lBuff[lStart]), esize); + //showmessage(inttostr(esize)); + +end; + +function NIFTIhdr_LoadHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +var + lHdrFile: file; + lOri: array [1..3] of single; + lBuff: Bytep; + lAHdr: TAnalyzeHdrSection; + lFileSz : int64; + swapEndian, isNativeNIfTI: boolean; + lReportedSz, lSwappedReportedSz,lHdrSz: Longint; + lExt: string; //1494 +begin + Result := false; //assume error + if lFilename = '' then exit; + lExt := UpCaseExt(lFilename); + if lExt = '.IMG' then + lFilename := changeFileExt(lFilename,'.hdr'); + if (lExt = '.BRIK') or (lExt = '.BRIK.GZ') then + lFilename := changeFileExtX(lFilename,'.HEAD'); + lExt := UpCaseExt(lFilename); + lHdrSz := sizeof(TniftiHdr); + lFileSz := FSize (lFilename); + if lFileSz = 0 then begin + ShowMsg('Unable to find NIFTI header named '+lFilename+'. Possible solution: make sure VAL file and images are in the same folder.'); + exit; + end; + swapEndian := false; + lHdr.gzBytesX := K_gzBytes_headerAndImageUncompressed; + lHdr.ImgFileName:= lFilename ; + lHdr.HdrFileName:= lFilename ; + lHdr.ECodeText:= ''; + + FileMode := fmOpenRead; //Set file access to read only + isNativeNIfTI := true; + if (lExt = '.MGH') or (lExt = '.MGZ') or (lExt = '.MHD') or (lExt = '.MHA') or (lExt = '.NRRD') or (lExt = '.NHDR') or (lExt = '.HEAD') then begin + result := readForeignHeader( lFilename, lHdr.NIFTIhdr,lHdr.gzBytesX, swapEndian); //we currently ignore result! + lHdr.ImgFileName := lFilename; + isNativeNIfTI := false; + end else begin //native NIfTI + if (lExt = '.NII.GZ') or (lExt = '.VOI') or (lExt = '.GZ') then begin//1388 + lBuff := @lHdr; + UnGZip(lFileName,lBuff,0,lHdrSz); //1388 + lHdr.gzBytesX := K_gzBytes_headerAndImageCompressed; + end else begin //if gzip else uncompressed + if (lFileSz < lHdrSz) then begin + showmsg('Error in reading NIFTI header: NIfTI headers need to be at least '+inttostr(lHdrSz)+ ' bytes: '+lFilename); + result := false; + end else begin + {$I-} + AssignFile(lHdrFile, lFileName); + FileMode := 0; { Set file access to read only } + Reset(lHdrFile, 1); + {$I+} + if ioresult <> 0 then begin + ShowMessage('Error in reading NIFTI header.'+inttostr(IOResult)); + CloseFile(lHdrFile); + FileMode := fmOpenReadWrite; + exit; + end; + BlockRead(lHdrFile, lHdr, lHdrSz); + CloseFile(lHdrFile); + if (lExt = '.HDR') then + lHdr.ImgFileName:= changefileext(lFilename,'.img'); + end; + end; + end; //native NIFTI + // showmessage('---Unable to read this image format '+inttostr(lHdr.NIFTIhdr.datatype)+' '+inttostr(lHdr.NIFTIhdr.bitpix)); + + FileMode := fmOpenReadWrite; + if (IOResult <> 0) then exit; + lReportedSz := lHdr.niftiHdr.HdrSz; + lSwappedReportedSz := lReportedSz; + swap4(lSwappedReportedSz); + lHdr.NIFTIVersion := 1; + if lReportedSz = lHdrSz then begin + lHdr.DiskDataNativeEndian := true; + end else if lSwappedReportedSz = lHdrSz then begin + lHdr.DiskDataNativeEndian := false; + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + end else begin + result := NIFTIhdr_LoadDCM (lFilename,lHdr); //2/2008 + if not result then + ShowMsg('Warning: the header file is not in NIfTi format [the first 4 bytes do not have the value 348]. Assuming big-endian data.'); + exit; + end; + if (lHdr.NIFTIhdr.dim[0] > 7) or (lHdr.NIFTIhdr.dim[0] < 1) then begin //only 1..7 dims, so this + ShowMsg('Illegal NIfTI Format Header: this header does not specify 1..7 dimensions.'); + exit; + end; + FixDataType(lHdr); + result := true; + + if IsNifTiMagic(lHdr.niftiHdr) then begin //must match MAGMA in nifti_img + lOri[1] := (lHdr.NIFTIhdr.dim[1]+1) div 2; + lOri[2] := (lHdr.NIFTIhdr.dim[2]+1) div 2; + lOri[3] := (lHdr.NIFTIhdr.dim[3]+1) div 2; + //TryQuat2Matrix(lHdr.NiftiHdr); + if (lHdr.NIFTIhdr.sform_code <= kNIFTI_XFORM_UNKNOWN) or (lHdr.NIFTIhdr.sform_code > kNIFTI_XFORM_MNI_152) then + TryQuat2Matrix(lHdr.NiftiHdr); + if emptymatrix(lHdr) then begin + + (*if HasQuat(lHdr.NiftiHdr) then + //HasQuat will specify + else*) begin + lHdr.NIFTIhdr.srow_x[0] := lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_x[1] := 0; + lHdr.NIFTIhdr.srow_x[2] := 0; + + lHdr.NIFTIhdr.srow_y[0] := 0; + lHdr.NIFTIhdr.srow_y[1] := lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_y[2] := 0; + lHdr.NIFTIhdr.srow_z[0] := 0; + lHdr.NIFTIhdr.srow_z[1] := 0; + lHdr.NIFTIhdr.srow_z[2] := lHdr.NIFTIhdr.pixdim[3]; + + lHdr.NIFTIhdr.srow_x[3] := -round(lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.pixdim[1]*0.5); + lHdr.NIFTIhdr.srow_y[3] := -round(lHdr.NIFTIhdr.dim[2]*lHdr.NIFTIhdr.pixdim[2]*0.5); + lHdr.NIFTIhdr.srow_z[3] := -round(lHdr.NIFTIhdr.dim[3]*lHdr.NIFTIhdr.pixdim[3]*0.5); + lHdr.NIFTIhdr.sform_code := 1; + end; + end; + + + if (lHdr.NIFTIhdr.srow_x[0] > 0) and (lHdr.NIFTIhdr.srow_y[1] > 0) and (lHdr.NIFTIhdr.srow_z[2] > 0) and + (lHdr.NIFTIhdr.srow_x[3] > 0) and (lHdr.NIFTIhdr.srow_y[3] > 0) and (lHdr.NIFTIhdr.srow_z[3] > 0) then begin + lHdr.NIFTIhdr.srow_x[3] := -lHdr.NIFTIhdr.srow_x[3]; + lHdr.NIFTIhdr.srow_y[3] := -lHdr.NIFTIhdr.srow_y[3]; + lHdr.NIFTIhdr.srow_z[3] := -lHdr.NIFTIhdr.srow_z[3]; + lHdr.NIFTIhdr.sform_code := 1; + end; //added 4Mar2006 -> corrects for improperly signed offset values... + lHdr.NIfTItransform := true;//NIfTI 12/2010 + end else begin //not NIFT: Analyze + + + lHdr.NIfTItransform := false;//Analyze + if not lHdr.DiskDataNativeEndian then begin + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + move(lHdr.niftiHdr,lAHdr,sizeof(lAHdr)); + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + lAHdr.Originator[1] := swap(lAHdr.Originator[1]); + lAHdr.Originator[2] := swap(lAHdr.Originator[2]); + lAHdr.Originator[3] := swap(lAHdr.Originator[3]); + end else + move(lHdr.niftiHdr,lAHdr,sizeof(lAHdr)); + lOri[1] :=lAHdr.Originator[1]; + lOri[2] := lAHdr.Originator[2]; + lOri[3] := lAHdr.Originator[3]; + if (lOri[1]=76) and (lOri[2]=116) and (lOri[3]=64) + and (lHdr.NIFTIhdr.dim[1]=151) and (lHdr.NIFTIhdr.dim[2]=188) and (lHdr.NIFTIhdr.dim[3]=154) then begin + lOri[2] := 111; + lOri[3] := 68; + end; //2/2008 Juelich fudge factor + + if ((lOri[1]<1) or (lOri[1]> lHdr.NIFTIhdr.dim[1])) and + ((lOri[2]<1) or (lOri[2]> lHdr.NIFTIhdr.dim[2])) and + ((lOri[3]<1) or (lOri[3]> lHdr.NIFTIhdr.dim[3])) then begin + lOri[1] := (lHdr.NIFTIhdr.dim[1]+1) / 2; //May07 use / not div + lOri[2] := (lHdr.NIFTIhdr.dim[2]+1) / 2; //May07 use / not div + lOri[3] := (lHdr.NIFTIhdr.dim[3]+1) / 2; //May07 use / not div : if 20 slices, then origin is between 10 and 11 + + end; + //showmessage(inttostr(sizeof(lAHdr))+' '+realtostr(lHdr.Ori[1],1)+' '+ realtostr(lHdr.Ori[2],1)+' '+realtostr(lHdr.Ori[3],1) ); + //DANGER: This header was from ANALYZE format, not NIFTI: make sure the rotation matrix is switched off + NIFTIhdr_SetIdentityMatrix(lHdr); + lHdr.NIFTIhdr.qform_code := kNIFTI_XFORM_UNKNOWN; + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_UNKNOWN; + //test - input estimated orientation matrix + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT ; + lHdr.NIFTIhdr.srow_x[0] := lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[1] := lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[2] := lHdr.NIFTIhdr.pixdim[3]; + + lHdr.NIFTIhdr.srow_x[3] := (lOri[1]-1)*-lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[3] := (lOri[2]-1)*-lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[3] := (lOri[3]-1)*-lHdr.NIFTIhdr.pixdim[3]; + //fx(lHdr.NIFTIhdr.srow_z[3],lOri[3]); + //end test + //Warning: some of the NIFTI float values that do exist as integer values in Analyze may have bizarre values like +INF, -INF, NaN + lHdr.NIFTIhdr.toffset := 0; + lHdr.NIFTIhdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.NIFTIhdr.dim_info := kNIFTI_SLICE_SEQ_UNKNOWN + (kNIFTI_SLICE_SEQ_UNKNOWN shl 2) + (kNIFTI_SLICE_SEQ_UNKNOWN shl 4); //Freq, Phase and Slice order all unknown + lHdr.NIFTIhdr.xyzt_units := kNIFTI_UNITS_UNKNOWN; + lHdr.NIFTIhdr.slice_duration := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p1 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p2 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p3 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.pixdim[0] := 1; //QFactor should be 1 or -1 + + end; + if (lHdr.NIFTIhdr.sform_code > kNIFTI_XFORM_UNKNOWN) and (lHdr.NIFTIhdr.sform_code <= kNIFTI_XFORM_MNI_152) then begin //DEC06 + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + end else begin + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.pixdim[1],0,0,(lOri[1]-1)*-lHdr.NIFTIhdr.pixdim[1], // 3D "graphics" matrix + 0,lHdr.NIFTIhdr.pixdim[2],0,(lOri[2]-1)*-lHdr.NIFTIhdr.pixdim[2], // 3D "graphics" matrix + 0,0,lHdr.NIFTIhdr.pixdim[3],(lOri[3]-1)*-lHdr.NIFTIhdr.pixdim[3], // 3D "graphics" matrix + 0,0,0,1); + end; + FixCrapMat(lHdr.Mat); + if swapEndian then + lHdr.DiskDataNativeEndian := false;//foreign data with swapped image data + if (isNativeNIfTI) and (lHdr.NIFTIhdr.vox_offset > sizeof(TNIFTIHdr)) then + ReadEcode(lHdr);//, swapEndian); + + //showmessage(inttostr(length(lHdr.ECodeText)) ); + //showmessage(lHdr.ECodeText); + //ReportMatrix(lHdr.mat); +end; //func NIFTIhdr_LoadHdr + +procedure NIFTIhdr_SetIdentityMatrix (var lHdr: TMRIcroHdr); //create neutral rotation matrix +var lInc: integer; +begin + with lHdr.NIFTIhdr do begin + for lInc := 0 to 3 do + srow_x[lInc] := 0; + + for lInc := 0 to 3 do + srow_y[lInc] := 0; + for lInc := 0 to 3 do + srow_z[lInc] := 0; + for lInc := 1 to 16 do + intent_name[lInc] := chr(0); + //next: create identity matrix: if code is switched on there will not be a problem + srow_x[0] := 1; + srow_y[1] := 1; + srow_z[2] := 1; + end; +end; //proc NIFTIhdr_IdentityMatrix + +procedure NIFTIhdr_ClearHdr (var lHdr: TMRIcroHdr); //put sensible default values into header +var lInc: byte; +begin + lHdr.NIFTIVersion := 1; + lHdr.UsesCustomPalette := false; + lHdr.UsesCustomPaletteRandomRainbow:= false; + lHdr.UsesLabels := false; + lHdr.DiskDataNativeEndian := true; + lHdr.LutFromZero := false; + lHdr.NIfTItransform := true;//assume genuine NIfTI, not Analyze + with lHdr.NIFTIhdr do begin + {set to 0} + HdrSz := sizeof(TNIFTIhdr); + for lInc := 1 to 10 do + Data_Type[lInc] := chr(0); + for lInc := 1 to 18 do + db_name[lInc] := chr(0); + extents:=0; + session_error:= 0; + regular:='r'{chr(0)}; + dim_info:=(0); + dim[0] := 4; + for lInc := 1 to 7 do + dim[lInc] := 0; + intent_p1 := 0; + intent_p2 := 0; + intent_p3 := 0; + intent_code:=0; + datatype:=0 ; + bitpix:=0; + slice_start:=0; + for lInc := 1 to 7 do + pixdim[linc]:= 1.0; + vox_offset:= 0.0; + scl_slope := 1.0; + scl_inter:= 0.0; + slice_end:= 0; + slice_code := 0; + xyzt_units := 10; + cal_max:= 0.0; + cal_min:= 0.0; + slice_duration:=0; + toffset:= 0; + glmax:= 0; + glmin:= 0; + for lInc := 1 to 80 do + descrip[lInc] := chr(0);{80 spaces} + for lInc := 1 to 24 do + aux_file[lInc] := chr(0);{80 spaces} + {below are standard settings which are not 0} + bitpix := 16;//vc16; {8bits per pixel, e.g. unsigned char 136} + DataType := 4;//vc4;{2=unsigned char, 4=16bit int 136} + Dim[0] := 3; + Dim[1] := 256; + Dim[2] := 256; + Dim[3] := 128; + Dim[4] := 1; {n vols} + Dim[5] := 1; + Dim[6] := 1; + Dim[7] := 1; + glMin := 0; + glMax := 255; + qform_code := kNIFTI_XFORM_UNKNOWN; + sform_code:= kNIFTI_XFORM_UNKNOWN; + quatern_b := 0; + quatern_c := 0; + quatern_d := 0; + qoffset_x := 0; + qoffset_y := 0; + qoffset_z := 0; + NIFTIhdr_SetIdentityMatrix(lHdr); + magic := kNIFTI_MAGIC_SEPARATE_HDR; + end; //with the NIfTI header... + with lHdr do begin + ScrnBufferItems := 0; + ImgBufferItems := 0; + ImgBufferBPP := 0; + RenderBufferItems := 0; + ScrnBuffer:= nil; + ImgBuffer := nil; + end; + +end; //proc NIFTIhdr_ClearHdr + +function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2: boolean): boolean; overload; +var lOutHdr: TNIFTIhdr; + lExt: string; + lF: File; + lOverwrite: boolean; +begin + lOverwrite := false; //will we overwrite existing file? + result := false; //assume failure + if lHdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then begin + lExt := UpCaseExt(lFileName); + if (lExt = '.GZ') or (lExt = '.NII.GZ') then begin + ShowMessage('Unable to save .nii.gz headers (first ungzip your image if you wish to edit the header)'); + exit; + end; + lFilename := changefileext(lFilename,'.nii') + end else + lFilename := changefileext(lFilename,'.hdr'); + if ((sizeof(TNIFTIhdr))> DiskFreeEx(lFileName)) then begin + ShowMessage('There is not enough free space on the destination disk to save the header. '+kCR+ + lFileName+ kCR+' Bytes Required: '+inttostr(sizeof(TNIFTIhdr)) ); + exit; + end; + if Fileexists(lFileName) then begin + if lAllowOverwrite then begin + {$IFNDEF GUI} + ShowMsg('Overwriting '+lFilename); + lOverwrite := true; + {$ELSE} + case MessageDlg('Do you wish to modify the existing file '+lFilename+'?', mtConfirmation,[mbYes, mbNo], 0) of { produce the message dialog box } + 6: lOverwrite := true; //6= mrYes, 7=mrNo... not sure what this is for Linux. Hardcoded as we do not include Form values + end;//case + {$ENDIF} + end else + showmessage('Error: the file '+lFileName+' already exists.'); + if not lOverwrite then Exit; + end; + if lHdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then + if lHdr.vox_offset < sizeof(TNIFTIHdr) then + lHdr.vox_offset := sizeof(TNIFTIHdr); //embedded images MUST start after header + if lHdr.magic = kNIFTI_MAGIC_SEPARATE_HDR then + lHdr.vox_offset := 0; //embedded images MUST start after header + if lSPM2 then begin //SPM2 does not recognize NIfTI - origin values will be wrong + lHdr.magic := 0; + end; + result := true; + move(lHdr, lOutHdr, sizeof(lOutHdr)); + Filemode := 1; + AssignFile(lF, lFileName); {WIN} + if lOverwrite then //this allows us to modify just the 348byte header of an existing NII header without touching image data + Reset(lF,sizeof(TNIFTIhdr)) + else + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lOutHdr, 1 {, NumWritten}); + CloseFile(lF); + Filemode := 2; +end; //func NIFTIhdr_SaveHdr + +function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TMRIcroHdr; lAllowOverwrite: boolean): boolean; overload; +var lOutHdr: TNIFTIhdr; + lExt: string; + lF: File; + lOverwrite: boolean; +begin + lOverwrite := false; //will we overwrite existing file? + result := false; //assume failure + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then begin + lExt := UpCaseExt(lFileName); + if (lExt = '.GZ') or (lExt = '.NII.GZ') then begin + showmessage('Unable to save .nii.gz headers (first ungzip your image if you wish to edit the header)'); + exit; + end; + lFilename := changefileext(lFilename,'.nii') + end else + lFilename := changefileext(lFilename,'.hdr'); + if ((sizeof(TNIFTIhdr))> DiskFreeEx(lFileName)) then begin + ShowMessage('There is not enough free space on the destination disk to save the header. '+kCR+ + lFileName+ kCR+' Bytes Required: '+inttostr(sizeof(TNIFTIhdr)) ); + exit; + end; + if Fileexists(lFileName) then begin + if lAllowOverwrite then begin + {$IFNDEF GUI} + ShowMsg('Overwriting '+lFilename); + lOverwrite := true; + {$ELSE} + case MessageDlg('Do you wish to modify the existing file '+lFilename+'?', mtConfirmation,[mbYes, mbNo], 0) of { produce the message dialog box } + 6: lOverwrite := true; //6= mrYes, 7=mrNo... not sure what this is for unix. Hardcoded as we do not include Form values + end;//case + {$ENDIF} + end else + showmessage('Error: the file '+lFileName+' already exists.'); + if not lOverwrite then Exit; + end; + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then + if lHdr.NIFTIhdr.vox_offset < sizeof(TNIFTIHdr) then + lHdr.NIFTIhdr.vox_offset := sizeof(TNIFTIHdr); //embedded images MUST start after header + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_SEPARATE_HDR then + lHdr.NIFTIhdr.vox_offset := 0; //embedded images MUST start after header + result := true; + move(lHdr.NIFTIhdr, lOutHdr, sizeof(lOutHdr)); + if lHdr.DiskDataNativeEndian= false then + NIFTIhdr_SwapBytes (lOutHdr);{swap to big-endianformat} + Filemode := 1; + AssignFile(lF, lFileName); {WIN} + if lOverwrite then //this allows us to modify just the 348byte header of an existing NII header without touching image data + Reset(lF,sizeof(TNIFTIhdr)) + else + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lOutHdr, 1 {, NumWritten}); + CloseFile(lF); + Filemode := 2; +end; //func NIFTIhdr_SaveHdr + +procedure NIFTIhdr_SwapBytes (var lAHdr: TNIFTIhdr); //Swap Byte order for the Analyze type +var + lInc: integer; +begin + with lAHdr do begin + swap4(hdrsz); + swap4(extents); + session_error := swap(session_error); + for lInc := 0 to 7 do + dim[lInc] := swap(dim[lInc]); + Xswap4r(intent_p1); + Xswap4r(intent_p2); + Xswap4r(intent_p3); + intent_code:= swap(intent_code); + datatype:= swap(datatype); + bitpix := swap(bitpix); + slice_start:= swap(slice_start); + for lInc := 0 to 7 do + Xswap4r(pixdim[linc]); + Xswap4r(vox_offset); + Xswap4r(scl_slope); + Xswap4r(scl_inter); + slice_end := swap(slice_end); + Xswap4r(cal_max); + Xswap4r(cal_min); + Xswap4r(slice_duration); + Xswap4r(toffset); + swap4(glmax); + swap4(glmin); + qform_code := swap(qform_code); + sform_code:= swap(sform_code); + Xswap4r(quatern_b); + Xswap4r(quatern_c); + Xswap4r(quatern_d); + Xswap4r(qoffset_x); + Xswap4r(qoffset_y); + Xswap4r(qoffset_z); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_x[lInc]); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_y[lInc]); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_z[lInc]); + end; //with NIFTIhdr +end; //proc NIFTIhdr_SwapBytes + +end. diff --git a/common/cpucount.o b/common/cpucount.o new file mode 100644 index 0000000..4e04311 Binary files /dev/null and b/common/cpucount.o differ diff --git a/common/cpucount.pas b/common/cpucount.pas new file mode 100755 index 0000000..35aad43 --- /dev/null +++ b/common/cpucount.pas @@ -0,0 +1,87 @@ +unit cpucount; + +interface +//returns number of cores: a computer with two dual cores will report 4 +function GetLogicalCpuCount: Integer; + +implementation +{$Include isgui.inc} +{$IFDEF UNIX} +{$IFDEF Darwin} +uses Process,SysUtils,Controls,classes,IniFiles, +{$IFDEF GUI}dialogs;{$ELSE} dialogsx;{$ENDIF} + + + +function GetLogicalCpuCount: Integer; +//returns number of CPUs for MacOSX computer +//example - will return 4 if the computer has two dual core CPUs +//requires Process in Uses Clause +//see http://wiki.lazarus.freepascal.org/Executing_External_Programs +var + lProcess: TProcess; + lLen,lPos: integer; + lStr: string; + lStringList: TStringList; +begin + Result := 1; + lProcess := TProcess.Create(nil); + lStringList := TStringList.Create; + lProcess.CommandLine := 'sysctl hw.ncpu'; + lProcess.Options := lProcess.Options + [poWaitOnExit, poUsePipes]; + lProcess.Execute; + lStringList.LoadFromStream(lProcess.Output); + lLen := length(lStringList.Text); + if lLen > 0 then begin + lStr := ''; + for lPos := 1 to lLen do + if lStringList.Text[lPos] in ['0'..'9'] then + lStr := lStr + lStringList.Text[lPos]; + if length(lStr) > 0 then + result := strtoint(lStr); + end;//if at least one character returned + if result < 1 then //just incase there is a horrible error, e.g. 0 + result := 1; + lStringList.Free; + lProcess.Free; +end; +{$ELSE} //Not Darwin ... Assume Linux +uses + classes,sysutils; +function GetLogicalCpuCount: Integer; +var lS: TStringList; + lFilename: string; + lLine,lnLines: integer; +begin + result := 1; + lFilename := '/proc/cpuinfo'; + if not fileexists(lFilename) then exit; + lS:= TStringList.Create; + lS.LoadFromFile(lFilename); + lnLines := lS.Count; + if lnLines > 0 then begin + result := 0; + for lLine := 1 to lnLines do + if lS[lLine-1] = '' then + inc(result); + end; + if result < 1 then + result := 1; + lS.Free; +end; +{$ENDIF} //If Darwin Else Linux + +{$ELSE} //If UNIX ELSE NOT Unix +uses Windows; +function GetLogicalCpuCount: Integer; +var + SystemInfo: _SYSTEM_INFO; +begin + GetSystemInfo(SystemInfo); + Result := SystemInfo.dwNumberOfProcessors; +end; + + {$ENDIF} + + +end. diff --git a/common/cpucount.ppu b/common/cpucount.ppu new file mode 100644 index 0000000..2609889 Binary files /dev/null and b/common/cpucount.ppu differ diff --git a/common/define_types.o b/common/define_types.o new file mode 100644 index 0000000..cc3659b Binary files /dev/null and b/common/define_types.o differ diff --git a/common/define_types.pas b/common/define_types.pas new file mode 100755 index 0000000..c915802 --- /dev/null +++ b/common/define_types.pas @@ -0,0 +1,1375 @@ +unit define_types; +interface +{$H+} +{$include isgui.inc} + + uses + {$IFNDEF FPC} + {$IFDEF GUI} FileCtrl, delphiselectfolder, {$ENDIF} + DiskSpaceKludge, Controls, + {$ELSE} + {$IFDEF GUI} lclintf,LResources,{$ENDIF} + {$ENDIF} + {$IFNDEF Unix} Windows, + {$ELSE} + BaseUnix,{$IFDEF GUI} LCLType, {$ENDIF}//lclintf, LMessages,LCLType,//gettickcount + {$ENDIF} + + SysUtils,classes,IniFiles, + {$IFDEF GUI} forms,userdir, dialogs{$ELSE}dialogsx{$ENDIF}; +const + kMRIcronVersDate = '22AUG2015'; + {$IFDEF LCLCocoa} + kMRIcronAPI = 'Cocoa'; + {$ELSE} + {$IFDEF LCLCarbon} + kMRIcronAPI = 'Carbon'; + {$ELSE} + kMRIcronAPI = ''; //windows, GTK, QT + {$ENDIF} + {$ENDIF} + {$ifdef CPU32} + kMRIcronCPU = '32'; + {$ELSE} + kMRIcronCPU = '64'; + {$ENDIF} + kMRIcronVers = kMRIcronVersDate+' '+ kMRIcronCPU +'bit BSD License '+kMRIcronAPI; + NaN : double = 1/0; + kMagicDouble : double = -111666222; + kTxtFilter = 'Text (*.txt)|*.txt;*.csv|Comma Separated (*.csv)|*.csv'; + kAnyFilter = 'Anything (*)|*'; + kAnaHdrFilter = 'Analyze Header (*.hdr)|*.hdr'; + + //kNIIFilter = 'NIfTI (*.nii)|*.nii'; + //kImgPlusVOIFilter = 'NIfTI/Analyze/VOI|*.hdr;*.nii;*.nii.gz;*.voi|NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi'; + //kImgFilter = 'NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi'; + //kImgFilterPlusAny = 'NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi|Any file (*.*)|*.*'; + + kNIIFilter = 'Neuroimaging (*.nii)|*.hdr;*.nii;*.nii.gz;*.voi;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd'; + kImgFilter = 'Neuroimaging|*.hdr;*.nii;*.nii.gz;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd|Volume of interest (*.voi)|*.voi'; + kImgPlusVOIFilter = 'Neuroimaging/VOI|*.hdr;*.nii;*.nii.gz;*.voi;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd|NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi'; + kImgFilterPlusAny = 'Neuroimaging/VOI|*.hdr;*.nii;*.nii.gz;*.voi;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd|NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi|Anything (*.*)|*.*'; + kHistoBins = 256;//numbers of bins for histogram/image balance + PixelCountMax = 32768; + kTab = chr(9); + kEsc = chr(27); + kCR = chr (13); + kBS = #8 ; // Backspace + kDel = #127 ; // Delete + UNIXeoln = chr(10); + kTextSep = kTab;//','; //',' for CSV, kTab for Tab-delimited values + {$IFDEF Darwin} + kLUTalpha = 255; //255 + {$ELSE} + kLUTalpha = 0; //255 + {$ENDIF} + kVOI8bit = 1;//May07 100; +{$IFDEF unix} + PathDelim = '/'; +{$ELSE} + PathDelim = '\'; +{$ENDIF} + +type + TStrRA = Array of String; + TPSPlot = RECORD //peristimulus plot + TRSec,BinWidthSec: single; + nNegBins,nPosBins,SPMDefaultsStatsFmriT,SPMDefaultsStatsFmriT0: integer; + TextOutput,GraphOutput, + SliceTime,SavePSVol,BaselineCorrect,PctSignal,RemoveRegressorVariability,TemporalDeriv,PlotModel,Batch: boolean + end; + TRGBquad = PACKED RECORD + {$IFDEF ENDIAN_BIG} //OSX PPC + rgbreserved,rgbRed,rgbGreen,rgbBlue: byte; + //rgbBlue,rgbGreen,rgbRed,rgbreserved: byte; + {$ELSE} + {$IFDEF UNIX} + {$IFDEF DARWIN} + rgbreserved,rgbRed,rgbGreen,rgbBlue: byte; + {$ELSE} + rgbRed,rgbGreen,rgbBlue,rgbreserved: byte; + {$ENDIF} + {$ELSE} //not unix - windows + //rgbreserved,rgbRed,rgbGreen,rgbBlue: byte; + rgbBlue,rgbGreen,rgbRed,rgbreserved: byte; + {$ENDIF} +// rgbBlue,rgbGreen,rgbRed,rgbreserved: byte; + {$ENDIF} + end; + TStretchQuality = (sqLow, sqHigh); + + //TLUTrgb = array[0..255] of TRGBQuad; + //TLUTtype = DWORD; + TLUT = array[0..255] of TRGBQuad; + kStr20 = string[20]; + kStr50 = string[50]; + + kStr255 = string[255]; + + TCutout = RECORD + Lo : array [1..3] of integer; + Hi : array [1..3] of integer; + end; + int32 = LongInt; + uint32 = Cardinal; + int16 = SmallInt; + uint16 = Word; + int8 = ShortInt; + uint8 = Byte; + Int64RA = array [1..1] of int64; + Int64p = ^Int64RA; + + SingleRA0 = array [0..0] of Single; + Singlep0 = ^SingleRA0; + ByteRA0 = array [0..0] of byte; + Bytep0 = ^ByteRA0; + WordRA0 = array [0..0] of Word; + Wordp0 = ^WordRA0; + SmallIntRA0 = array [0..0] of SmallInt; + SMallIntp0 = ^SmallIntRA0; + LongIntRA0 = array [0..0] of LongInt; + LongIntp0 = ^LongIntRA0; + DWordRA = array [1..1] of DWord; + DWordp = ^DWordRA; + ByteRA = array [1..1] of byte; + Bytep = ^ByteRA; + WordRA = array [1..1] of Word; + Wordp = ^WordRA; + SmallIntRA = array [1..1] of SmallInt; + SMallIntp = ^SmallIntRA; + LongIntRA = array [1..1] of LongInt; + LongIntp = ^LongIntRA; + SingleRA = array [1..1] of Single; + Singlep = ^SingleRA; + SingleRARA = array [1..1] of Singlep; + SingleRAp = ^SingleRARA; + DoubleRA = array [1..1] of Double; + Doublep = ^DoubleRA; + DoubleRA0 = array [0..0] of Double; + Doublep0 = ^DoubleRA0; + HistoRA = array [0..kHistoBins] of longint; + HistoDoubleRA = array [0..kHistoBins] of double; + //pRGBQuadArray = ^TRGBQuad; + //TRGBQuadeArray = ARRAY[0..PixelCountMax-1] OF TRGBQuad; + //RGBQuadRA = array [1..1] of TRGBQuad; + //RGBQuadp = ^RGBQuadRA; + TQuadRA = array [1..1] of TRGBQuad; + + RGBQuadp = ^TQuadRA; + + +// pRGBTripleArray = ^TRGBTripleArray; +// TRGBTripleArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple; +FUNCTION specialsingle (var s:single): boolean; //check if 32-bit float is Not-A-Number, infinity, etc +function FSize (lFName: String): Int64; +function FileExistsEX(Name: String): Boolean; +function ParseFileName (lFilewExt:String): string; +function ParseFileFinalDir (lFileName:String): string; +function ExtractFileDirWithPathDelim(lInFilename: string): string; +function PadStr (lValIn, lPadLenIn: integer): string; +function ChangeFileExtX( var lFilename: string; lExt: string): string; +//function swap2i(SmallInt): Smallint; +function swap4r4i (s:single): longint; //swap and convert: endian-swap and then typecast 32-bit float as 32-bit integer +function conv4r4i (s:single): longint; //convert: typecast 32-bit float as 32-bit integer +function swap8r(s : double):double; //endian-swap 64-bit float +procedure pswap4i(var s : LongInt); //procedure to endian-swap 32-bit integer +procedure pswap4r ( var s:single); //procedure to endian-swap 32-bit integer +function swap64r(s : double):double; +function specialdouble (d:double): boolean; +function RealToStr(lR: double {was extended}; lDec: integer): string; +function UpCaseExt(lFileName: string): string;//file.brik.gz->BRIK.GZ, file.nii.gz -> NII.GZ +function ExtGZ (lFilename: string): boolean; +procedure swap4(var s : LongInt); +procedure Xswap4r ( var s:single); +function Bool2Char (lBool: boolean): char; +function Char2Bool (lChar: char): boolean; +function Log(X, Base: single): single; +//procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +//procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer); +{$IFNDEF FPC} +function DiskFreeEx (DriveStr: String): Integer; +{$ELSE} +function DiskFreeEx (DriveStr: String): Int64; +{$ENDIF} +procedure SortSingle(var lLo,lHi: single); +procedure SortInteger(var lLo,lHi: integer); +function IniInt(lIniFile: TIniFile; lIdent: string; lDefault: integer): integer; +function IniBool(var lIniFile: TIniFile; lIdent: string; lDefault: boolean): boolean; +procedure CopyFileEX (lInName,lOutName: string); +procedure CopyFileEXoverwrite (lInName,lOutName: string); +procedure fx (a: double); overload; //fx used to help debugging - reports number values +procedure fx (a,b: double); overload; +procedure fx (a,b,c: double); overload; +procedure fx (a,b,c,d: double); overload; +function Swap2(s: smallint): smallint; +//function DefaultsDir (lSubFolder: string): string; +function ChangeFilePostfixExt (lInName,lPostfix,lExt: string): string; +procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +function freeRam: Int64; + +function OKMsg(lMsg: string): boolean; //shows dialog with OK/Cancel returns true if user presses OK +function DirExists (lFolderName: String): boolean; +function FilenameParts (lInName: string; var lPath,lName,lExt: string): boolean; +function AddIndexToFilename (lInName: string; lIndex: integer): string; + +procedure createArray64 (var ptr: pointer; var ra :Doublep0; Sz: integer); overload; +procedure createArray64 (var ptr: pointer; var ra :Doublep; Sz: integer); overload; +function GzExt(lFileName: string): boolean; +function ChangeFilePrefixExt (lInName,lPrefix,lExt: string): string; +function ChangeFilePrefix(lInName,lPrefix: string): string; +function makesmallint (b0,b1: byte): smallint; +function makesingle( b0,b1,b2,b3: byte): single; +procedure SortInt (var lMin,lMax: integer); +function Bound (lDefault,lMin,lMax: integer): integer; +function IsNiftiExt(lStr: string): boolean; +function IsExtNIFTIHdr(lStr: string): boolean; +function IsVOIExt(lStr: string): boolean; +//procedure ax(a,b,c,d,e,fx: double); +procedure EnsureDirEndsWithPathDelim (var lDir: string); +//function IsReadOnly(const FileName: string): Boolean;//I think this only works for existing files... not folders and new files +function DirWritePermission(Where: string): Boolean; //I think this is better than above +function ExtractDir (lFilepath: string): string; +{$IFDEF GUI} +function GetDirPrompt (lDefault: string): string; +{$ENDIF} +function Str2Int (lStr: string): integer; +function ResetDefaults : boolean; + +implementation + +function ResetDefaults : boolean; +const + {$IFDEF LINUX} + kKey = 'Right button'; + {$ELSE} + kKey = 'Shift key'; + {$ENDIF} +var + lKey: boolean; +begin + result := false; +{$IFDEF GUI} + {$IFDEF LINUX} + lKey := (GetKeyState(VK_RBUTTON) And $80)<>0; + {$ELSE} + lKey := (ssShift in KeyDataToShiftState(vk_Shift)); + {$ENDIF} + if not lKey then + exit; + {$IFDEF GUI} + case MessageDlg(kKey+' down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + idYes: result := true; + end; //case + {$ENDIF} +{$ENDIF} +end; + +function Str2Int (lStr: string): integer; +//robust stringtoint that strips out any junk so that "Implementation Version Name=MR.VB15A" returns 15 +// warning, strips out decimals, so 15.3 will return 153! +//warning also ignores minus sign so -5.21 will return 521! +var + Len,P: integer; + S: string; +begin + result := 0; + Len := length(lStr); + if Len <1 then exit; + S := ''; + for P := 1 to Len do + if lStr[P] in ['-','0'..'9'] then + S := S + lStr[P]; + if length(S) < 1 then exit; + result := strtoint(S); +end; + + +{$IFDEF GUI} +function GetDirPrompt (lDefault: string): string; +// Old versions of Delphi have a clumsy SelectDirectory function, and locks the folder until you quit your application... +var + lD: string; +begin + lD := lDefault; + if not DirExists(lD) then + lD := UserDataFolder; + result := lD; // Set the starting directory + {$IFDEF FPC} + //Delphi SelectDirectory uses FileCtrl + //Lazarus SelectDirectory uses Dialogs + chdir(result); //start search from previous dir... + if SelectDirectory(result, [sdAllowCreate,sdPerformCreate,sdPrompt], 0) then begin + chdir(result); + exit; + end; + {$ELSE} + if SelectDirectoryDelphi('Select folder', result, true) then + exit; + {$ENDIF} + //if the user aborts, make sure we use the default directory... + result := lD; +end; +{$ENDIF} //GUI + +function ExtractDir (lFilepath: string): string; +//if passed file \usr\temp\data.txt returns \usr\temp\ +//if passed dir \usr\temp returns \usr\temp\ +//note returned always includes pathdelim +var + lName,lExt: string; +begin + FilenameParts (lFilepath,Result,lName,lExt); +end; + +function DirWritePermission(Where: string): Boolean; +{$IFDEF UNIX} +//Uses BaseUnix; +begin + result := (fpAccess (ExtractDir(Where),W_OK)=0); +end; +{$ELSE} +Var + i : Longint; + lFilename: string; +Begin + result := false; + if length(Where) < 1 then + exit; + + if DirExists (Where) then begin + if Where[length(Where)] <> PathDelim then + lFilename := Where + pathdelim + 'dummy.dum' + else + lFilename := Where + 'dummy.dum'; + end else + lFilename := Where; + if fileexists (lFilename) then + exit; //do not overwrite existing file + i:=FileCreate (lFilename); + if i=-1 then + Halt(1); + FileClose(i); + DeleteFile(lFilename); + result := true; +end; +{$ENDIF} +(*function IsReadOnly(const FileName: string): Boolean; +var + sr: TSearchRec; +begin + // Assume not read only + Result := False; + if FindFirst(FileName, faAnyFile, sr) = 0 then + begin + Result := (sr.Attr and faReadOnly) <> 0; + FindClose(sr); + end; +end; *) + +procedure EnsureDirEndsWithPathDelim (var lDir: string); +begin + if length(lDir) < 1 then + exit; + if lDir[length(lDir)] = pathdelim then + exit; + lDir := lDir + pathdelim; +end; + + +function AddIndexToFilename (lInName: string; lIndex: integer): string; +var lPath,lName,lExt: string; +begin + result := ''; + if not FilenameParts (lInName, lPath,lName,lExt) then exit; + result := lPath+lName+inttostr(lIndex)+lExt; +end; + +function Bound (lDefault,lMin,lMax: integer): integer; +begin + result := lDefault; + if result < lMin then + result := lMin; + if result > lMax then + result := lMax; +end; + +function IsVOIExt(lStr: string): boolean; +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.VOI') then + result := true; +end; +function IsNiftiExt(lStr: string): boolean; +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.MGH') or (lExt = '.MGZ') then + result := true; + if (lExt = '.MHA') or (lExt = '.MHD') then + result := true; + if (lExt = '.HEAD') then + result := true; + if (lExt = '.NRRD') then + result := true; + + if (lExt = '.NII') or (lExt = '.NII.GZ') then + result := true; + if (lExt = '.HDR') and (FSize(ChangeFileExt(lStr,'.img'))> 0) then + result := true; + if (lExt = '.IMG') and (FSize(ChangeFileExt(lStr,'.hdr'))> 0) then + result := true; +end; + +function IsExtNIFTIHdr(lStr: string): boolean; +//detect hdr, nii,niigz +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.NII') or (lExt = '.NII.GZ') then + result := true; + if (lExt = '.HDR') and (FSize(ChangeFileExt(lStr,'.img'))> 0) then + result := true; + (*if (lExt = '.IMG') and (FSize(ChangeFileExt(lStr,'.hdr'))> 0) then + result := true; *) +end; + +procedure SortInt (var lMin,lMax: integer); +var + lSwap: integer; +begin + if lMin <= lMax then + exit; + lSwap := lMax; + lMax := lMin; + lMin := lSwap; +end; + +function makesmallint (b0,b1: byte): smallint; +type + swaptype = packed record + case byte of + 0:(b0,b1 : byte); //word is 16 bit + 1:(s:smallint); + end; + swaptypep = ^swaptype; +var + //inguy:swaptypep; + outguy:swaptype; +begin + //inguy := @s; //assign address of s to inguy + outguy.b0 := b0; + outguy.b1 := b1; + result:=outguy.s; +end;//makesmallint + + +function makesingle( b0,b1,b2,b3: byte): single; +type + swaptype = packed record + case byte of + 0:(b0,b1,b2,b3 : byte); //word is 16 bit + 1:(long:single); + end; + swaptypep = ^swaptype; +var + outguy:swaptype; +begin + //inguy := @s; //assign address of s to inguy + outguy.b0 := b0; + outguy.b1 := b1; + outguy.b2 := b2; + outguy.b3 := b3; + result:=outguy.long; +end;//swap4r4i + +function ChangeFilePrefix(lInName,lPrefix: string): string; +var + lC,lLen,lPos: integer; + lStr: string; +begin + //result := changefileext(lInName,lExt); + result := lInName; + lLen := length (result); + if lLen < 1 then exit; + lPos := lLen; + while (lPos > 1) and (result[lPos] <> pathdelim) do + dec(lPos); + lStr := ''; + for lC := 1 to lPos do + lStr := lStr+result[lC]; + lStr := lStr+lPrefix; + if lPos < lLen then + for lC := (lPos+1) to lLen do + lStr := lStr+result[lC]; + result := lStr; +end; + +function ChangeFilePrefixExt (lInName,lPrefix,lExt: string): string; +var + lC,lLen,lPos: integer; + lStr: string; +begin + result := changefileext(lInName,lExt); + lLen := length (result); + if lLen < 1 then exit; + lPos := lLen; + while (lPos > 1) and (result[lPos] <> pathdelim) do + dec(lPos); + lStr := ''; + for lC := 1 to lPos do + lStr := lStr+result[lC]; + lStr := lStr+lPrefix; + if lPos < lLen then begin + lC := lPos+1; + while (lC <= lLen) and (result[lC] <> '.') do begin + lStr := lStr + result[lC]; + inc(lC); + end; + end; + lStr := lStr + lExt; + result := lStr; +end; + + +function GzExt(lFileName: string): boolean; +var lExt: string; +begin + lExt := UpCaseExt(lFilename); + if (lExt = '.VOI') or (lExt = '.NII.GZ') or (lExt = '.GZ') then + result := true + else + result := false; +end; + +function FilenameParts (lInName: string; var lPath,lName,lExt: string): boolean; +var + lLen,lPos,lExtPos,lPathPos: integer; +begin + result := false; + lPath := ''; + lName := ''; + lExt := ''; + lLen := length(lInName); + if lLen < 1 then + exit; + if DirExists(lInName) then begin //we have been passed a folder, not a file + if lInName[lLen] = PathDelim then + lPath := lInName + else + lPath := lInName + pathdelim; + exit; + end; + //next find final pathdelim + lPathPos := lLen; + while (lPathPos > 0) and (lInName[lPathPos] <> '\') and (lInName[lPathPos] <> '/') do + dec(lPathPos); + if (lInName[lPathPos] = '\') or (lInName[lPathPos] = '/') then begin + for lPos := 1 to lPathPos do + lPath := lPath + lInName[lPos]; + end; + // else + // dec(lPathPos); + inc(lPathPos); + //next find first ext + //lExtPos := 1; + lExtPos := length(lPath);//July 2009 -- beware of '.' in foldername... + while (lExtPos <= lLen) and (lInName[lExtPos] <> '.') do + inc(lExtPos); + if (lInName[lExtPos] = '.') then begin + for lPos := lExtPos to lLen do + lExt := lExt + lInName[lPos]; + end; + // else + // inc(lExtPos); + dec(lExtPos); + //next extract filename + //fx(lPathPos,lExtPos); + if (lPathPos <= lExtPos) then + for lPos := lPathPos to lExtPos do + lName := lName + lInName[lPos]; + result := true; + +end; + +procedure createArray64 (var ptr: pointer; var ra :Doublep0; Sz: integer); overload; +var i: integer; +begin + getmem(ptr,16+(sizeof(double)*Sz)); + {$IFDEF FPC} + ra := align(ptr,16); + {$ELSE} + ra := DoubleP0((integer(ptr) and $FFFFFFF0)+16); + {$ENDIF} + for i := (Sz-1) downto 0 do //initialise array + ra^[i] := 0; +end; + +procedure createArray64 (var ptr: pointer; var ra :Doublep; Sz: integer); overload; +var i: integer; +begin + getmem(ptr,16+(sizeof(double)*Sz)); + {$IFDEF FPC} + ra := align(ptr,16); + {$ELSE} + ra := DoubleP((integer(ptr) and $FFFFFFF0)+16); + {$ENDIF} + for i := (Sz) downto 1 do //initialise array + ra^[i] := 0; +end; + + +function OKMsg(lMsg: string): boolean; //shows dialog with OK/Cancel returns true if user presses OK +begin + result := false; + {$IFDEF GUI} + case MessageDlg(lMsg, mtConfirmation, + [mbYes, mbCancel], 0) of + idCancel {mrCancel}: exit; + end; //case + {$ELSE} + case MsgDlg(lMsg, mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + {$ENDIF} + result := true; +end; + +(*function DirExists (lDir: String): boolean; +var lSearchRec: TSearchRec; +begin + FindFirst(lDir, faAnyFile, lSearchRec); + if (faDirectory and lSearchRec.attr) = faDirectory then + DirExists := true + else + DirExists := false; + FindClose(lSearchRec);{} +end;*) + +{$IFNDEF GUI} + {$IFNDEF FPC} + //The FileCtrl unit is pretty bulky, and we only need this one call that it links from SysUtils + function DirectoryExists(const Name: string): Boolean; +var + Code: Integer; +begin + Code := GetFileAttributes(PChar(Name)); + Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); +end; + {$ENDIF} +{$ENDIF} + +function DirExists (lFolderName: string): boolean; +(*{$IFNDEF GUI} +var + lSearchRec: TSearchRec; +begin + result := false; + if fileexists(lFoldername) then //File not folder + exit; + Filemode := 0; //readonly + if FindFirst(lFolderName, faDirectory, lSearchRec) = 0 then begin + result := true; + FindClose(lSearchRec); + end else + result := false; //some files found + Filemode := 2; +{$ELSE} +*) +begin + result := DirectoryExists(lFolderName); +//{$ENDIF} +end; + +function freeRam: Int64; +{$IFDEF UNIX} +begin + result := maxint; +end; +{$ELSE} +var + memory:TMemoryStatus; + +begin + memory.dwLength:=sizeof(memory); + GlobalMemoryStatus(memory); + result := memory.dwavailPhys; + //result := 1024; +end; +{$ENDIF} + +procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +var lInc,lSwap: integer; +begin + for lInc := 1 to 3 do + if lCutout.Lo[lInc] > lCutout.Hi[lInc] then begin + lSwap := lCutout.Lo[lInc]; + lCutout.Lo[lInc] := lCutout.Hi[lInc]; + lCutout.Hi[lInc] := lSwap; + end; +end; + + +function ChangeFilePostfixExt (lInName,lPostfix,lExt: string): string; +var + lPath,lName,lExtIn: string; +begin + FilenameParts (lInName, lPath,lName,lExtIn); + result := lPath+lName+lPostFix+lExt; + //showmessage(result); +end; + +(*var + lC,lLen,lPos: integer; + lStr: string; +begin + result := changefileext(lInName,lExt); + lLen := length (result); + if lLen < 1 then exit; + lPos := lLen; + while (lPos > 1) and (result[lPos] <> pathdelim) and (result[lPos] <> '.') do + dec(lPos); + if result[lPos] = '.' then + dec(lPos); + lStr := ''; + for lC := 1 to lPos do + lStr := lStr+result[lC]; + lStr := lStr+lPostfix; + if lPos < lLen then + for lC := (lPos+1) to lLen do + lStr := lStr+result[lC]; + result := lStr; +end; *) + +(*procedure ApplySaveDlgFilter (lSaveDlg: TSaveDialog); +var + lLen,lPos,lPipes,lPipesReq: integer; + lExt: string; +begin + lPipesReq := (lSaveDlg.FilterIndex * 2)-1; + if lPipesReq < 1 then exit; + lLen := length(lSaveDlg.Filter); + lPos := 1; + lPipes := 0; + while (lPos < lLen) and (lPipes < lPipesReq) do begin + if lSaveDlg.Filter[lPos] = '|' then + inc(lPipes); + inc(lPos); + end; + if (lPos >= lLen) or (lPipes < lPipesReq) then + exit; + lExt := ''; + while (lPos <= lLen) and (lSaveDlg.Filter[lPos] <> '|') do begin + if lSaveDlg.Filter[lPos] <> '*' then + lExt := lExt + lSaveDlg.Filter[lPos]; + inc(lPos); + end; + if lExt <> '' then + lSaveDlg.Filename := ChangeFileExt(lSaveDlg.Filename,lExt); +end; *) + +(*function DefaultsDir (lSubFolder: string): string; +//for Linux: DefaultsDir is ~/appname/SubFolder/, e.g. /home/username/mricron/subfolder/ +//for Windows: DefaultsDir is in the location of the executable, e.g. c:\program files\mricron\subfolder\ +//Note: Final character is pathdelim +var + lBaseDir: string; +begin + {$IFDEF Unix} + lBaseDir := GetEnvironmentVariable ('HOME')+pathdelim+'.' +ParseFileName(ExtractFilename(paramstr(0) ) ); + if not DirectoryExists(lBaseDir) then begin + {$I-} + MkDir(lBaseDir); + if IOResult <> 0 then begin + showmessage('Unble to create new folder '+lBaseDir); + end; + {$I+} + end; + lBaseDir := lBaseDir+pathdelim; + {$ELSE} + lBaseDir := extractfiledir(paramstr(0))+pathdelim; + {$ENDIF} + //if not DirectoryExists(extractfiledir(lBaseDir)) then + //mkDir(extractfiledir(lBaseDir)); + if lSubFolder <> '' then begin + lBaseDir := lBaseDir + lSubFolder; + if not DirectoryExists(lBaseDir) then begin + {$I-} + MkDir(lBaseDir); + if IOResult <> 0 then begin + showmessage('Unable to create new folder '+lBaseDir); + end; + {$I+} + end; + result := lBaseDir + pathdelim; + end else + result := lBaseDir; +end; *) + +function Swap2(s : SmallInt): smallint; +type + swaptype = packed record + case byte of + 0:(Word1 : word); //word is 16 bit + 1:(Small1: SmallInt); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word1); + result :=outguy.Small1; +end; + +{$IFDEF GUI} +procedure ShowMsg(s: string); +begin + showmessage(s); +end; +{$ENDIF} +procedure fx (a: double); overload; //fx used to help debugging - reports number values +begin + ShowMsg(floattostr(a)); +end; + +procedure fx (a,b: double); overload; //fx used to help debugging - reports number values +begin + ShowMsg(floattostr(a)+'x'+floattostr(b)); +end; + +procedure fx (a,b,c: double); overload; //fx used to help debugging - reports number values +begin + ShowMsg(floattostr(a)+'x'+floattostr(b)+'x'+floattostr(c)); +end; + +procedure fx (a,b,c,d: double); overload; //fx used to help debugging - reports number values +begin + ShowMsg(floattostr(a)+'x'+floattostr(b)+'x'+floattostr(c)+'x'+floattostr(d)); +end; + +procedure CopyFileEXoverwrite (lInName,lOutName: string); +var lFSize: Integer; + lBuff: bytep0; + lFData: file; +begin + lFSize := FSize(lInName); + if (lFSize < 1) then exit; + assignfile(lFdata,lInName); + filemode := 0; + reset(lFdata,lFSize{1}); + GetMem( lBuff, lFSize); + BlockRead(lFdata, lBuff^, 1{lFSize}); + closefile(lFdata); + assignfile(lFdata,lOutName); + filemode := 2; + Rewrite(lFdata,lFSize); + BlockWrite(lFdata,lBuff^, 1 {, NumWritten}); + closefile(lFdata); + freemem(lBuff); +end; + +procedure CopyFileEX (lInName,lOutName: string); +var lFSize: Integer; +begin + lFSize := FSize(lInName); + if (lFSize < 1) or (fileexistsEX(lOutName)) then exit; + CopyFileEXoverwrite (lInName,lOutName); +end; + +function IniInt(lIniFile: TIniFile; lIdent: string; lDefault: integer): integer; +var + lStr: string; +begin + result := lDefault; + lStr := lIniFile.ReadString('INT',lIdent, ''); + if length(lStr) > 0 then + result := StrToInt(lStr); +end; //proc IniInt + +function IniBool(var lIniFile: TIniFile; lIdent: string; lDefault: boolean): boolean; +var + lStr: string; +begin + result := lDefault; + lStr := lIniFile.ReadString('BOOL',lIdent, ''); + //showmessage('x'+lStr+'x'); + if length(lStr) > 0 then + result := Char2Bool(lStr[1]); +end; //nested IniBool + + +procedure SortInteger(var lLo,lHi: integer); +var lSwap: integer; +begin + if lLo > lHi then begin + lSwap := lLo; + lLo := lHi; + lHi := lSwap; + end; //if Lo>Hi +end; //proc SortSingle + +procedure SortSingle(var lLo,lHi: single); +var lSwap: single; +begin + if lLo > lHi then begin + lSwap := lLo; + lLo := lHi; + lHi := lSwap; + end; //if Lo>Hi +end; //proc SortSingle + +{$IFDEF FPC} + {$IFDEF UNIX} //FPC and Unix + function DiskFreeEx (DriveStr: String): Int64; + var + lOutDisk: Integer; + begin + + lOutDisk := AddDisk(DriveStr); + result := DiskFree(lOutDisk); + if result < 0 then + result := 9223372036854775807; + end; + {$ELSE} //FPC and Windows + function DiskFreeEx (DriveStr: String): Int64; + var + lOutDisk: Integer; + begin + lOutDisk := ord(upcase(DriveStr[1]))+1-ord('A'); + if (lOutDisk >= 0) and (lOutDisk <= 26) then + result := DiskFree(lOutDisk) + else + result := 0; + //showmessage(DriveStr+'->*'+inttostr(lOutDisk)+'* :'+inttostr(result)); + //showmessage(inttostr(DiskFree(0){current drive})+' :'+inttostr(DiskFree(3) {C drive})); + end; + {$ENDIF} +{$ELSE} //Delphi Windows + +function DiskFreeEx (DriveStr: String): Integer; +var + lOutDisk: Integer; + lDiskDir : string; + lSize8: Tinteger8; +begin + lOutDisk := ord(upcase(DriveStr[1]))+1-ord('A'); + if (lOutDisk >= ord('A')) and (lOutDisk <= ord('Z')) then begin + DiskFreeEx := DiskFree(lOutDisk); + end else begin + lDiskDir :=(ExtractFileDrive(DriveStr))+'\'; + lSize8 := DiskFreeStr (lDiskDir); + if lSize8 > MaxINt then DiskFreeEx := MaxInt + else DiskFreeEx := round(lSize8); + end; +end; + {$ENDIF} + +function Log(X, Base: single): single; +begin + if X = 0 then + result := 0 + else + Log := Ln(X) / Ln(Base); +end; + +function Bool2Char (lBool: boolean): char; +begin + if lBool then + result := '1' + else + result := '0'; +end; + +function Char2Bool (lChar: char): boolean; +begin + if lChar = '1' then + result := true + else + result := false; +end; + +procedure Xswap4r ( var s:single); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + inguy^.Word1 := outguy.Word1; + inguy^.Word2 := outguy.Word2; +end; + +procedure swap4(var s : LongInt); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + s:=outguy.Long; +end; + +function UpCaseExt(lFileName: string): string; +var lI: integer; +l2ndExt,lExt : string; +begin + lExt := ExtractFileExt(lFileName); + if length(lExt) > 0 then + for lI := 1 to length(lExt) do + lExt[lI] := upcase(lExt[lI]); + result := lExt; + if lExt <> '.GZ' then exit; + lI := length(lFileName) - 6; + if li < 1 then exit; + l2ndExt := upcase(lFileName[lI])+upcase(lFileName[lI+1])+upcase(lFileName[li+2])+upcase(lFileName[li+3]); + if (l2ndExt = '.NII')then + result := l2ndExt+lExt + else if (l2ndExt = 'BRIK') and (lI > 1) and (lFileName[lI-1] = '.') then + result := '.BRIK'+lExt; +end; + +function ExtGZ (lFilename: string): boolean; +var + lI: integer; + lExt : string; +begin + lExt := ExtractFileExt(lFileName); + if length(lExt) > 0 then + for lI := 1 to length(lExt) do + lExt[lI] := upcase(lExt[lI]); + if lExt = '.GZ' then + result := true + else + result := false; +end; + +function RealToStr(lR: double {was extended}; lDec: integer): string; +begin + RealTOStr := FloatToStrF(lR, ffFixed,7,lDec); +end; + +FUNCTION specialdouble (d:double): boolean; +//returns true if s is Infinity, NAN or Indeterminate +//8byte IEEE: msb[63] = signbit, bits[52-62] exponent, bits[0..51] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +CONST kSpecialExponent = 2047 shl 20; +VAR Overlay: ARRAY[1..2] OF LongInt ABSOLUTE d; +BEGIN + IF ((Overlay[2] AND kSpecialExponent) = kSpecialExponent) THEN + RESULT := true + ELSE + RESULT := false; +END; + +function swap8r(s : double):double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + try + result:=outguy.float; + except + result := 0; + exit; + end; +end; //func swap8r + +procedure pswap4i(var s : LongInt); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + s:=outguy.Long; +end; //proc swap4 + +function swap64r(s : double):double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + try + swap64r:=outguy.float; + except + swap64r := 0; + exit; + end;{} +end; + +procedure pswap4r ( var s:single); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + inguy^.Word1 := outguy.Word1; + inguy^.Word2 := outguy.Word2; +end; //proc Xswap4r + +function conv4r4i (s:single): longint; +type + swaptype = packed record + case byte of + 1:(long:longint); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; +begin + inguy := @s; //assign address of s to inguy + conv4r4i:=inguy^.long; +end; + +function swap4r4i (s:single): longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(long:longint); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap4r4i:=outguy.long; +end;//swap4r4i + +(*function ChangeFileExtX( var lFilename: string; lExt: string): string; +begin + result := ChangeFileExt(lFilename,lExt); +end; *) + +function ChangeFileExtX(var lFilename: string; lExt: string): string;// overload; +//sees .nii.gz as single extension +var + lPath,lName,lOrigExt: string; +begin + if FilenameParts (lFilename, lPath,lName,lOrigExt) then begin + //showmessage('12222'+lPath +'**'+lName+'**'+lOrigExt); + result := lPath+lName+lExt; + end else begin + //showmessage('z'); + result := ChangeFileExt(lFilename,lExt); + end; +end; + +function PadStr (lValIn, lPadLenIn: integer): string; +var lOrigLen,lPad : integer; +begin + lOrigLen := length(inttostr(lValIn)); + result := inttostr(lValIn); + if lOrigLen < lPadLenIn then begin + lOrigLen := lPadLenIn-lOrigLen; + for lPad := 1 to lOrigLen do + result := '0'+result; + end; +end; + +function ExtractFileDirWithPathDelim(lInFilename: string): string; +//F:\filename.ext -> 'F:\' and F:\dir\filename.ext -> 'F:\dir\' +//Despite documentation, Delphi3's ExtractFileDir does not always retain final pathdelim +var lFilePath: string; +begin + result := ''; + if DirExists(lInFilename) then + lFilePath := lInFilename + else + lFilePath := ExtractFileDir(lInFilename); + if length(lFilepath) < 1 then exit; + if lFilePath[length(lFilepath)] <> pathdelim then + lFilepath := lFilepath + pathdelim; //Delphi3 bug: sometimes forgets pathdelim + result := lFilepath; +end; + +function ParseFileFinalDir (lFileName:String): string; +var + lLen,lInc,lPos: integer; + lInName,lName: String; +begin + lInName := extractfiledir(lFilename); + lName := ''; + lLen := length(lInName); + if lLen < 1 then exit; + lInc := lLen; + repeat + dec(lInc); + until (lInName[lInc] = pathdelim) or (lInc = 1); + if lInName[lInc] = pathdelim then inc(lInc); //if '\folder' then return 'folder' + for lPos := lInc to lLen do + lName := lName + lInName[lPos]; + ParseFileFinalDir := lName; +end; + +function ParseFileName (lFilewExt:String): string; +var + lExt: string; + i: integer; +begin + lExt := UpCaseExt(lFilewExt); + if (length(lExt) < 1) or (length(lExt) >= length(lFilewExt)) then exit; + result := ''; + for i := 1 to (length(lFilewExt)-length(lExt)) do + result := result + lFilewExt[i]; +end; + +(*function ParseFileName (lFilewExt:String): string; +var + lLen,lInc: integer; + lName: String; +begin + lName := ''; + lLen := length(lFilewExt); + lInc := lLen+1; + if lLen > 0 then begin + repeat + dec(lInc); + until (lFileWExt[lInc] = '.') or (lInc = 1); + if (UpCaseExt(lFilewExt) = '.NII.GZ') and (lInc > 1) then + repeat + dec(lInc); + until (lFileWExt[lInc] = '.') or (lInc = 1); + end; + if lInc > 1 then + for lLen := 1 to (lInc - 1) do + lName := lName + lFileWExt[lLen] + else + lName := lFilewExt; //no extension + ParseFileName := lName; +end; *) + +Function {TMainForm.}FileExistsEX(Name: String): Boolean; +var + F: File; +begin + result := false; + if Name = '' then + exit; + result := FileExists(Name); + if result then exit; + //the next bit attempts to check for a file to avoid WinNT bug + AssignFile(F, Name); + {$I-} + Reset(F); + {$I+} + Result:=IOresult = 0; + if Result then + CloseFile(F); +end; + +function FSize (lFName: String): Int64; +var SearchRec: TSearchRec; +begin + result := 0; + if not fileexistsex(lFName) then exit; + FindFirst(lFName, faAnyFile, SearchRec); + result := SearchRec.size; + FindClose(SearchRec); +end; + +procedure Xswap8r(var s : double); +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + //1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + inguy^.Word1 := outguy.Word1; + inguy^.Word2 := outguy.Word2; + inguy^.Word3 := outguy.Word3; + inguy^.Word4 := outguy.Word4; +end; + +FUNCTION specialsingle (var s:single): boolean; +//returns true if s is Infinity, NAN or Indeterminate +//4byte IEEE: msb[31] = signbit, bits[23-30] exponent, bits[0..22] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +CONST kSpecialExponent = 255 shl 23; +VAR Overlay: LongInt ABSOLUTE s; +BEGIN + IF ((Overlay AND kSpecialExponent) = kSpecialExponent) THEN + RESULT := true + ELSE + RESULT := false; +END; + +end. diff --git a/common/define_types.ppu b/common/define_types.ppu new file mode 100644 index 0000000..9aa720d Binary files /dev/null and b/common/define_types.ppu differ diff --git a/common/delphiselectfolder.pas b/common/delphiselectfolder.pas new file mode 100755 index 0000000..af71661 --- /dev/null +++ b/common/delphiselectfolder.pas @@ -0,0 +1,98 @@ +unit delphiselectfolder; + +interface + +function BrowseForFolder(const browseTitle: String; + const initialFolder: String = ''; + mayCreateNewFolder: Boolean = False): String; + +function SelectDirectoryDelphi(const browseTitle: String; var Folder: String; mayCreateNewFolder: Boolean = False): boolean; +implementation + +uses + Windows, Forms, shlobj; + +function SelectDirectoryDelphi(const browseTitle: String; var Folder: String; mayCreateNewFolder: Boolean = False): boolean; +var + lTemp: string; +begin + result := false; + lTemp := BrowseForFolder(browseTitle, Folder, mayCreateNewFolder); + if (lTemp <> '') then begin + Folder := lTemp; + result := true; + end; +// +end; + + + +var + lg_StartFolder: String; + +//////////////////////////////////////////////////////////////////////// +// Call back function used to set the initial browse directory. +//////////////////////////////////////////////////////////////////////// +function BrowseForFolderCallBack(Wnd: HWND; uMsg: UINT; lParam, +lpData: LPARAM): Integer stdcall; +begin + if uMsg = BFFM_INITIALIZED then + SendMessage(Wnd,BFFM_SETSELECTION, 1, Integer(@lg_StartFolder[1])); + result := 0; +end; + +//////////////////////////////////////////////////////////////////////// +// This function allows the user to browse for a folder +// +// Arguments:- +// browseTitle : The title to display on the browse dialog. +// initialFolder : Optional argument. Use to specify the folder +// initially selected when the dialog opens. +// mayCreateNewFolder : Flag indicating whether the user can create a +// new folder. +// +// Returns: The empty string if no folder was selected (i.e. if the user +// clicked cancel), otherwise the full folder path. +//////////////////////////////////////////////////////////////////////// +function BrowseForFolder(const browseTitle: String; + const initialFolder: String =''; + mayCreateNewFolder: Boolean = False): String; +// With later versions of Delphi you may not need these constants. +const + BIF_NEWDIALOGSTYLE=$40; + BIF_NONEWFOLDERBUTTON=$200; + +var + browse_info: TBrowseInfo; + folder: array[0..MAX_PATH] of char; + find_context: PItemIDList; + +begin + //-------------------------- + // Initialise the structure. + //-------------------------- + FillChar(browse_info,SizeOf(browse_info),#0); + lg_StartFolder := initialFolder; + browse_info.pszDisplayName := @folder[0]; + browse_info.lpszTitle := PChar(browseTitle); + browse_info.ulFlags := BIF_RETURNONLYFSDIRS or BIF_NEWDIALOGSTYLE; + if not mayCreateNewFolder then + browse_info.ulFlags := browse_info.ulFlags or BIF_NONEWFOLDERBUTTON; + + browse_info.hwndOwner := Application.Handle; + if initialFolder <> '' then + browse_info.lpfn := BrowseForFolderCallBack; + find_context := SHBrowseForFolder(browse_info); + if Assigned(find_context) then + begin + if SHGetPathFromIDList(find_context,folder) then + result := folder + else + result := ''; + GlobalFreePtr(find_context); + end + else + result := ''; +end; + +end. \ No newline at end of file diff --git a/common/dialogsx.o b/common/dialogsx.o new file mode 100644 index 0000000..a84f988 Binary files /dev/null and b/common/dialogsx.o differ diff --git a/common/dialogsx.pas b/common/dialogsx.pas new file mode 100755 index 0000000..c9f9354 --- /dev/null +++ b/common/dialogsx.pas @@ -0,0 +1,154 @@ +unit dialogsx; +{$Include isgui.inc} +{$H+} +interface +uses + //,IniFiles +SysUtils; + +type + TMsgDlgBtn = (mbYes, mbNo, mbOK, mbCancel, mbAbort, mbRetry, mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp); + TMsgDlgButtons = set of TMsgDlgBtn; + TMsgDlgType = (mtWarning, mtError, mtInformation, mtConfirmation, mtCustom); + +//procedure Msg (lStr: string); +procedure ShowMsg (lStr: string); +procedure msgfx (a,b,c,d: double); overload; //fx used to help debugging - reports number values +function MsgDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Word; +function GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; +procedure MyReadLn;//no GUI: waits for user +function GetStr(lPrompt: string): string; + + + {$IFNDEF GUI}procedure ShowMessage (lStr: string); {$ENDIF} +//procedure vx (a,b,c,d: double); + +const + mrCancel = 2; + mrAbort = 1;// idAbort + mrNo = 0; +implementation +{$IFDEF GUI}uses readint,dialogs; {$ENDIF} + +procedure Msg (lStr: string); +begin +{$IFDEF GUI} + showmessage(lStr); +{$ELSE} + writeln(lStr) +{$ENDIF} +end; + +{$IFNDEF GUI}procedure ShowMessage (lStr: string); +begin +writeln(lStr) ; +end; + +{$ENDIF} + +procedure vx (a,b,c,d: double); //vx used to help debugging - reports number values +begin +msg(floattostr(a)+':'+floattostr(b)+':'+floattostr(c)+':'+floattostr(d)); +end; + + +procedure MyReadLn; +{$IFDEF GUI} +begin + //do nothing +end; +{$ELSE} +begin + {$IFNDEF UNIX} + if IsConsole then + ReadLn; + {$ENDIF} +end; +{$ENDIF} + +function MsgDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Word; +{$IFDEF GUI} +var + lDlgType : Dialogs.TMsgDlgType; + lButtons: Dialogs.TMsgDlgButtons; + +begin + lDlgType := Dialogs.TMsgDlgType(DlgType); + lButtons:= Dialogs.TMsgDlgButtons(Buttons); + result := MessageDlg(Msg, lDlgType, lButtons,HelpCtx); +{$ELSE} +begin + result := 0; + writeln('WARNING: dialogs not being used. Unabled to process this '+Msg); +{$ENDIF} +end; + +procedure ShowMsg (lStr: string); +begin +{$IFDEF GUI} + ShowMessage(lStr); +{$ELSE} + writeln(lStr) +{$ENDIF} +end; +procedure msgfx (a,b,c,d: double); overload; //fx used to help debugging - reports number values +begin + {$IFDEF GUI} + msg(floattostr(a)+'x'+floattostr(b)+'x'+floattostr(c)+'x'+floattostr(d)); + {$ELSE} + msg(floattostr(a)+'x'+floattostr(b)+'x'+floattostr(c)+'x'+floattostr(d)); + {$ENDIF} +end; + + + +function GetStr(lPrompt: string): string; +{$IFDEF GUI} +var + lOK: boolean; +begin + lOK := InputQuery(lPrompt, lPrompt, result); + if not lOK then + result := ''; +end; +{$ELSE} +var + lS: string; +begin + writeln ( lPrompt); + readln(lS); + result := lS; +end; +{$ENDIF} + +function GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; +{$IFDEF GUI} +begin + //result := GetInt(lStr, lMin,lDefault,lMax); + result := lDefault; + Showmessage('Warning - unable to get values for '+lStr); +end; +{$ELSE} +var + lS: string; + lError,lI: integer; +begin + writeln ( lStr+' ['+inttostr(lMin)+'..'+inttostr(lMax)+'], default '+inttostr(lDefault)); + readln(lS); + Val(lS,lI,lError); + if lError = 0 then + result := round(lI) + else begin + writeln(inttostr(lDefault)); + result := lDefault; + end; + if result < lMin then + result := lMin; + if result > lMax then + result := lMax; +end; +{$ENDIF} + + +end. + \ No newline at end of file diff --git a/common/dialogsx.ppu b/common/dialogsx.ppu new file mode 100644 index 0000000..e94f4ee Binary files /dev/null and b/common/dialogsx.ppu differ diff --git a/common/dicomhdr.o b/common/dicomhdr.o new file mode 100644 index 0000000..5c41e7c Binary files /dev/null and b/common/dicomhdr.o differ diff --git a/common/dicomhdr.pas b/common/dicomhdr.pas new file mode 100755 index 0000000..64095f9 --- /dev/null +++ b/common/dicomhdr.pas @@ -0,0 +1,516 @@ +unit dicomhdr; +{$H+} +//Simple dicom to nifti translator +interface +uses +{$IFNDEF FPC}Controls, {$ENDIF} + SysUtils,define_types,classes,nifti_hdr,GraphicsMathLibrary, nifti_types; +function NIFTIhdr_LoadDCM (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + +type + kDICOMStr = String[32]; + DICOMdata = record + XYZdim: array [1..4] of integer; + XYZori: array [1..3] of integer; + XYZmm: array [1..3] of double; + Orient: array [1..6] of double; + Float,file4D: boolean; + PatientPosX,PatientPosY,PatientPosZ,AngulationAP,AngulationFH,AngulationRL: double; + TE, TR,IntenScale,IntenIntercept,location{,DTIv1,DTIv2,DTIv3}: single; + {Bval,}SlicesPer3DVol,SiemensInterleaved {0=no,1=yes,2=not defined},SiemensSlices,SiemensMosaicX,SiemensMosaicY, + nDTIdir,AcquNum,ImageNum,SeriesNum,ImageStart,little_endian,Allocbits_per_pixel,SamplesPerPixel, + PatientIDint,CSAImageHeaderInfoPos,CSAImageHeaderInfoSz,ManufacturerID: integer; + PatientPos,PatientName,ProtocolName,StudyDate,StudyTime,PhilipsSliceOrient,PhaseEncoding: kDICOMStr; + Filename: string[255]; +end; + +implementation + +uses dialogsx; + +procedure Msg(lStr: string); +begin + ShowMsg(lStr); +end; + +procedure clear_dicom_data (var lDicomdata:Dicomdata); +var + lI: integer; +begin + with lDicomData do begin + lDicomData.CSAImageHeaderInfoPos := 0; + lDicomData.CSAImageHeaderInfoSz := 0; + for lI := 1 to 6 do + Orient[lI] := 0; + PatientIDInt := 0; + ManufacturerID := 0; + AngulationFH := 0; + AngulationRL := 0; + AngulationAP := 0; + nDTIdir := 0; + PhilipsSliceOrient := 'NA'; + PhaseEncoding := 'NA'; + PatientPos := 'NA'; + + file4D := false; + PatientName := 'NO NAME'; + StudyDate := ''; + StudyTime := ''; + TR := 0; + TE := 0; + Float := false; + ImageNum := 0; + SlicesPer3DVol := 0; + SiemensInterleaved := 2; //0=no,1=yes,2=undefined + SiemensSlices := 0; + SiemensMosaicX := 1; + SiemensMosaicY := 1; + IntenScale := 1; + IntenIntercept := 0; + SeriesNum := 1; + AcquNum := 0; + ImageNum := 1; + SamplesPerPixel := 1; + XYZmm[1] := 1; + XYZmm[2] := 1; + XYZmm[3] := 1; + XYZdim[1] := 1; + XYZdim[2] := 1; + XYZdim[3] := 1; + XYZdim[4] := 1; + lDicomData.XYZori[1] := 0; + lDicomData.XYZori[2] := 0; + lDicomData.XYZori[3] := 0; + ImageStart := 0; + Little_Endian := 0; + Allocbits_per_pixel := 16;//bits + Location:=0; + PatientPosX := 0;//1392 + PatientPosY := 0;//1392 + PatientPosZ := 0;//1392 + end; +end; + +function NIFTIhdr_LoadDCM (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +var + lDICOMdata: DICOMdata; +const + kMaxBuf = (256*256)-1; //bytes + kMax16bit = (256*256)-1; + kImageType = $0008+($0008 shl 16 ); + kStudyDate = $0008+($0020 shl 16 ); + kStudyTime = $0008+($0030 shl 16 ); + kPatientName = $0010+($0010 shl 16 ); + kSeq = $0018+($0020 shl 16 ); + kZThick = $0018+($0050 shl 16 ); + kTR = $0018+($0080 shl 16 ); + kTE = $0018+($0081 shl 16 ); + kEchoNum = $0018+($0086 shl 16 ); + kZSpacing = $0018+($0088 shl 16 ); + kProtocolName = $0018+($1030shl 16 ); + kPatientPos = $0018+($5100 shl 16 ); + kSeriesNum = $0020+($0011 shl 16 ); + kAcquNum = $0020+($0012 shl 16 ); + kImageNum = $0020+($0013 shl 16 ); + kOrientation = $0020+($0037 shl 16 ); + kLocation = $0020+($1041 shl 16 ); + kDim3 = $0028+($0008 shl 16 ); + kDim2 = $0028+($0010 shl 16 ); + kDim1 = $0028+($0011 shl 16 ); + kXYSpacing = $0028+($0030 shl 16 ); + kPosition = $0020+($0032 shl 16 ); + knVol = $0020+($0105 shl 16 ); + kAlloc = $0028+($0100 shl 16 ); + kIntercept = $0028+($1052 shl 16 ); + kSlope = $0028+($1053 shl 16 ); + kCSAImageHeaderInfo = $0029+($1010 shl 16 ); + kSlicesPer3DVol = $2001+($1018 shl 16 ); + kTransferSyntax = $0002+($0010 shl 16); + kImageStart = $7FE0+($0010 shl 16 ); + kMaxFloats = 6; +var + vr : array [1..2] of Char; + lByteRA: Bytep; + lFloatRA: array [1..kMaxFloats] of double; + lBufferSz,lPos,lFileSz,lBuffStart: integer; + lInFile: file; + lBufferError, lDoEndianSwap: boolean; +procedure Str2FloatNum ( lStr: string; lnFloats: integer); +var + lFStr: string; + lP,lnF: integer; +begin + if (length(lStr) < 1) or (lnFloats < 1) or (lnFloats > kMaxFloats) then + exit; + for lnF := 1 to lnFloats do + lFloatRA[lnF] := 1; + lStr := lStr + ' '; //terminator + lFStr := ''; + lP := 1; + lnF:= 0; + while lP <= length(lStr) do begin + if lStr[lP] in ['+','-','0'..'9','.','e','E'] then + lFStr := lFStr + lStr[lP] + else if (lFStr <> '') then begin + inc(lnF); + try + lFloatRA[lnF] := strtofloat(lFStr); + except on EConvertError do + lFloatRA[lnF] := 1; + end;//except + if lnF = lnFloats then exit; + lFStr := ''; + end; + inc(lP); + end; +end; //function Str2Float + +function GetByte (lFilePos: integer): byte; +var + lBufPos: integer; +begin + //the following error checking slows down reads a lot! + //a simpler alternative would be to make the buffer size the same size as the entire image... + //the current strategy saves memory and is faster for large images with small headers + if lFilepos > lFileSz then begin + lBufferError := true; + result := 0; + exit; + end; + lBufPos := lFilepos - lBuffStart+1; + if (lBufPos > lBufferSz) or (lBufPos < 1) then begin //reload buffer + if lFilePos+kMaxBuf > lFileSz then + lBufferSz := lFileSz - (lFilePos) + else + lBufferSz := kMaxBuf; //read remaining + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lFilePos); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + FileMode := 2; + lBuffStart := lFilePos; + lBufPos := 1; + end; + result := lByteRA^[lBufPos]; +end; + +function ReadInt2x2: integer; +begin + if lDicomData.little_endian = 0 then + result := GetByte(lPos+1)+(GetByte(lPos) shl 8)+(GetByte(lPos+3) shl 16)+(GetByte(lPos+2) shl 24) + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24); + inc(lPos,4); +end; //function Read4 + +function ReadInt4: integer; +begin + if lDicomData.little_endian = 0 then + result := GetByte(lPos+3)+(GetByte(lPos+2) shl 8)+(GetByte(lPos+1) shl 16)+(GetByte(lPos) shl 24) + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24); + inc(lPos,4); +end; //function Read4 + +procedure ReadGroupElementLength(var lGroupElement,lLength: integer); +begin + lGroupElement := ReadInt2x2; + vr[1] := chr(GetByte(lPos)); + vr[2] := chr(GetByte(lPos+1)); + if (lDoEndianSwap) and ((lGroupElement and $FFFF) <> 0002) then begin + //msg('SWAPPING'); + lDoEndianSwap := false; + lDicomData.little_endian := 0; + end; + if vr[2] < 'A' then begin //implicit vr with 32-bit length + lLength := ReadInt4; + exit; + end; + if (vr = 'UN') {2/2008} or (vr = 'OB') or (vr = 'OW') or (vr = 'SQ') then begin {explicit VR with 32-bit length} + lPos := lPos + 4; {skip 2 byte string and 2 reserved bytes = 4 bytes = 2 words} + lLength := ReadInt4;//Ord4(buf[lPos]) + $100 * (buf[lPos+1] + $100 * (buf[lPos+2] + $100 * buf[lPos+3])) + end else begin {explicit VR with 16-bit length} + if lDicomData.little_endian = 0 then + lLength := (GetByte(lPos+3))+(GetByte(lPos+2) shl 8) + else + lLength := (GetByte(lPos+2))+(GetByte(lPos+3) shl 8);//GetLength := Ord4(buf[i+2]) + $100 * (buf[i+3]); + lPos := lPos + 4; {skip 2 byte string and 2 length bytes = 4 bytes = 2 words} + + end; + +end; //procedure ReadGroupElementLength + +function DCMStr(lBytes: integer): string; +var + lC: integer; +begin + result := ''; + if lBytes < 1 then + exit; + for lC := lPos to (lPos+(lBytes-1)) do + result := result + char(GetByte(lC)); + for lC := 1 to lBytes do + if result[lC] in ['+','-','/','\',' ','0'..'9','a'..'z','A'..'Z','.'] then + else + result[lC] := ' '; +end; //function DCMStr + +function DCMStr2Int (lBytes: integer): integer; +var lErr: integer; + lStr: string; +begin + lStr := DCMStr(lBytes); + Val(lStr,result,lErr); +end; //function DCMStr2Int + +procedure DCMStr2FloatNum (lBytes,lnFloats: integer); +begin + Str2FloatNum (DCMStr(lBytes), lnFloats); +end; //function DCMStr2Float + +function DCMStr2Float (lBytes: integer): single; +begin + DCMStr2FloatNum (lBytes,1); + result := lFloatRA[1]; +end; //function DCMStr2Float + +procedure DCMStr2Float2 (lBytes: integer; var lF1,lF2: double); +begin + DCMStr2FloatNum (lBytes,3); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; +end; //function DCMStr2Float2 + +procedure DCMStr2Float3 (lBytes: integer; var lF1,lF2,lF3: double); +begin + DCMStr2FloatNum (lBytes,3); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; + lF3 := lFloatRA[3]; +end; //function DCMStr2Float3 + +procedure DCMStr2Float6 (lBytes: integer; var lF1,lF2,lF3,lF4,lF5,lF6: double); +begin + DCMStr2FloatNum (lBytes,6); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; + lF3 := lFloatRA[3]; + lF4 := lFloatRA[4]; + lF5 := lFloatRA[5]; + lF6 := lFloatRA[6]; +end; //function DCMStr2Float6 + +function DCMint (lBytes: integer): integer; //read 16 bit short integer +begin + if (lDicomData.little_endian = 0) then begin + if lBytes <= 2 then + result := GetByte(lPos+1)+(GetByte(lPos) shl 8) //shortint vs word? + else + result := GetByte(lPos+3)+(GetByte(lPos+2) shl 8)+(GetByte(lPos+1) shl 16)+(GetByte(lPos) shl 24);; //byte order?? + + exit; + end; + if lBytes <= 2 then + result := GetByte(lPos)+(GetByte(lPos+1) shl 8) //shortint vs word? + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24);; //byte order?? +end; //function DCMint +var + lTempStr,lStr: string; + lOffset,lTemp,lGroupElement,lLength,lEchoNum,lnVol: integer; + lResearchMode: boolean; + lThick: double; +begin //function fast_read_dicom_data + lOffset := 128; + lnVol := 1; + lEchoNum := 1; + lDoEndianSwap := false; + lThick := 0; + clear_dicom_data(lDicomData); + lDicomData.little_endian := 1; + result := false; + lResearchMode := false; + lBufferError := false; + lFileSz := FSize(lFilename); + lBufferSz := lFileSz-lOffset; + if lBufferSz < 512 then begin + //showmessage('Error: File too small '+lFilename); + exit; + end; + if lBufferSz > kMaxBuf then + lBufferSz := kMaxBuf; + GetMem(lByteRA,kMaxBuf); + lBufferSz := lBufferSz; + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lOffset); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + FileMode := 2; + lBuffStart := lOffset; + lPos := lOffset; + if lOffset = 128 then begin //DICOM files start with DICM at 128, Siemens shadow headers do not + if DCMStr(4) <> 'DICM' then begin + //Msg(DCMStr(4)+ ' <> DICM'); + FreeMem(lByteRA); + exit; + end; + lPos := lOffset + 4;//DICM read + end;//Offset = 128 + //next check VR + if not( chr(GetByte(lPos+4)) in ['A'..'Z']) or not( chr(GetByte(lPos+5)) in ['A'..'Z']) then + Msg('implicit VR untested'); + //next check Endian + lTemp := lPos; + ReadGroupElementLength(lGroupElement,lLength); + //if lLength > kMax16bit then + // Msg('ByteSwapped'); + lPos := lTemp; + //end VR check + + while (lDICOMData.imagestart = 0) and (not lBufferError) do begin + ReadGroupElementLength(lGroupElement,lLength); + //if (lGroupElement and $FF) > $18 then + // msg(VR+' '+inttohex(lGroupElement and $FFFF,4)+' '+inttohex((lGroupElement shr 16) and $FFFF,4)+' '+inttostr(lLength)); + case lGroupElement of + kTransferSyntax: begin + lTempStr := (DCMStr(lLength)); + if (length(lTempStr) >= 19) and (lTempStr[19] = '2') then begin + //lDicomData.little_endian := 0; + lDoEndianSwap := true; + //msg('Terror'); + end; + end; + kImageType : begin + lTempStr := DCMStr(lLength); + //read last word - ver\mosaic -> MOSAIC + lStr := ''; + lTemp := length(lTempStr); + while (lTemp > 0) and (lTempStr[lTemp] in ['a'..'z','A'..'Z']) do begin + lStr := upcase(lTempStr[lTemp])+lStr; + dec(lTemp); + end; + if lStr = 'MOSAIC' then + lDicomData.SiemensMosaicX := 2; //we need to read numaris for details... + end; + kStudyDate: lDicomData.StudyDate := DCMStr(lLength); + kStudyTime : lDicomData.StudyTime := DCMStr(lLength); + kPatientName : lDicomData.PatientName := DCMStr(lLength); + kProtocolName : lDicomData.ProtocolName :=DCMStr(lLength); + kPatientPos : lDicomData.PatientPos :=DCMStr(lLength); //should be HFS for Siemens = Head First Supine + kSeriesNum : lDicomData.SeriesNum := DCMStr2Int(lLength); + kAcquNum : lDicomData.AcquNum := DCMStr2Int(lLength); + kSeq: begin + if DCMStr(lLength) = 'RM' then + lResearchMode := True; + end; + kImageNum : lDicomData.ImageNum := DCMStr2Int(lLength); + kDim3 :lDicomData.XYZdim[3] := DCMStr2Int(lLength); + kDim2 : lDicomData.XYZdim[2] := DCMint (lLength); + kDim1 : lDicomData.XYZdim[1] := DCMint (lLength); + kLocation : lDICOMData.Location := DCMStr2Float(lLength); + kAlloc: lDicomData.Allocbits_per_pixel := DCMint (lLength); + kTR : lDicomData.TR := DCMStr2Float(lLength); + kTE: lDicomData.TE := DCMStr2Float(lLength); + kEchoNum: lEchoNum := round (DCMStr2Float(lLength)); + kSlope : lDICOMData.IntenScale := DCMStr2Float(lLength); + kIntercept : lDICOMData.IntenIntercept := DCMStr2Float(lLength); + kOrientation : DCMStr2Float6(lLength, lDicomData.Orient[1], lDicomData.Orient[2],lDicomData.Orient[3],lDicomData.Orient[4], lDicomData.Orient[5],lDicomData.Orient[6]); + kPosition : DCMStr2Float3 (lLength,lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ); + knVol: lnVol := round (DCMStr2Float(lLength)); + kZThick: begin lThick := DCMStr2Float(lLength); lDICOMData.XYZmm[3] := lThick; end;//used differently by manufacturers + kZSpacing: begin lDICOMData.XYZmm[3] := DCMStr2Float(lLength); + if (lThick/2) > lDICOMdata.XYZmm[3] then + lDICOMdata.XYZmm[3] := lDICOMdata.XYZmm[3] + lThick + end; //used different by different manufacturers + kXYSpacing: DCMStr2Float2 (lLength, lDICOMdata.XYZmm[2], lDICOMdata.XYZmm[1]); + (*kCSAImageHeaderInfo: begin //order ICE,Acq,Num,Vector + lDICOMdata.CSAImageHeaderInfoPos := lPos; + lDICOMdata.CSAImageHeaderInfoSz := lLength; + end; *) + kSlicesPer3DVol: lDICOMData.SlicesPer3DVol := DCMint (lLength); + kImageStart: lDICOMData.ImageStart := lPos ; //-1 as indexed from 0.. not 1.. + + end; //Case lGroupElement + //Msg(VR+inttohex(lGroupElement and kMax16bit,4) +':'+inttohex( lGroupElement shr 16,4)+' '+inttostr(lLength)+'@'+inttostr(lPos) ); + lPos := lPos + (lLength); + end; //while imagestart=0 and not error + + //clean up + if (lDicomData.SiemensMosaicX > 1) then + lDicomData.AcquNum := 1; + if (lEchoNum > 1) and (lEchoNum < 16) then + lDicomData.AcquNum := lDicomData.AcquNum + (100*lEchoNum); + if lResearchMode then + lDicomData.SeriesNum := lDicomData.SeriesNum + 100; + if (lDICOMData.SlicesPer3DVol > 0) and (lnVol > 1) and (lDicomdata.XYZdim[3] > 1) and (lDicomData.SlicesPer3DVol > 0)and ((lDicomdata.XYZdim[3] mod lDicomData.SlicesPer3DVol) = 0) then + lDICOMdata.File4D := true; + if not lBufferError then + result := true; + FreeMem(lByteRA); + if result then begin + lHdr.HdrFileName:= lFilename; + lHdr.ImgFileName:= lFilename; + lHdr.NIfTItransform := false;//Analyze + case lDicomData.Allocbits_per_pixel of + 8: lHdr.NiftiHdr.datatype := kDT_UNSIGNED_CHAR; + 16: lHdr.NiftiHdr.datatype := kDT_SIGNED_SHORT; + 32: begin + if lDicomdata.Float then + lHdr.NiftiHdr.datatype := kDT_SIGNED_INT + else + lHdr.NiftiHdr.datatype := kDT_FLOAT; // float (32 bits/voxel) + end; + else begin + Msg('Unsupported DICOM bit-depth : '+inttostr(lDicomData.Allocbits_per_pixel) ); + result := false; + end; + end; + lHdr.NIFTIhdr.vox_offset := lDicomData.ImageStart; + lHdr.NIFTIhdr.bitpix := lDicomData.Allocbits_per_pixel; + lHdr.NIFTIhdr.pixdim[1] := lDicomdata.XYZmm[1]; + lHdr.NIFTIhdr.pixdim[2] := lDicomdata.XYZmm[2]; + lHdr.NIFTIhdr.pixdim[3] := lDicomdata.XYZmm[3]; + NIFTIhdr_SetIdentityMatrix(lHdr); + lHdr.NIFTIhdr.dim[1] := lDicomdata.XYZdim[1]; + lHdr.NIFTIhdr.dim[2] := lDicomdata.XYZdim[2]; + lHdr.NIFTIhdr.dim[3] := lDicomdata.XYZdim[3]; + lHdr.NIFTIhdr.dim[4] := lDicomdata.XYZdim[4]; + if lHdr.NIFTIhdr.dim[4] < 2 then + lHdr.NIFTIhdr.dim[0] := 3 + else + lHdr.NIFTIhdr.dim[0] := 4; + lHdr.NIFTIhdr.qform_code := kNIFTI_XFORM_UNKNOWN; + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_UNKNOWN; + //test - input estimated orientation matrix + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT ; + lHdr.NIFTIhdr.srow_x[0] := lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[1] := lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[2] := lHdr.NIFTIhdr.pixdim[3]; + lHdr.NIFTIhdr.srow_x[3] := (lHdr.NIFTIhdr.dim[1] /2)*-lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[3] := (lHdr.NIFTIhdr.dim[2] /2)*-lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[3] := (lHdr.NIFTIhdr.dim[3] /2)*-lHdr.NIFTIhdr.pixdim[3]; + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); //Warning: some of the NIFTI float values that do exist as integer values in Analyze may have bizarre values like +INF, -INF, NaN + lHdr.NIFTIhdr.toffset := 0; + lHdr.NIFTIhdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.NIFTIhdr.dim_info := kNIFTI_SLICE_SEQ_UNKNOWN + (kNIFTI_SLICE_SEQ_UNKNOWN shl 2) + (kNIFTI_SLICE_SEQ_UNKNOWN shl 4); //Freq, Phase and Slie all unknown + lHdr.NIFTIhdr.xyzt_units := kNIFTI_UNITS_UNKNOWN; + lHdr.NIFTIhdr.slice_duration := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p1 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p2 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p3 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.pixdim[0] := 1; //QFactor should be 1 or -1 + lHdr.DiskDataNativeEndian := odd(lDicomData.little_endian); + lHdr.NIFTIHdr.magic := kNIFTI_MAGIC_DCM; + end; +end; //function NIFTIhdr_LoadDCM + + +end. diff --git a/common/dicomhdr.ppu b/common/dicomhdr.ppu new file mode 100644 index 0000000..d06b02b Binary files /dev/null and b/common/dicomhdr.ppu differ diff --git a/common/distr.o b/common/distr.o new file mode 100644 index 0000000..ceefbbf Binary files /dev/null and b/common/distr.o differ diff --git a/common/distr.pas b/common/distr.pas new file mode 100755 index 0000000..348d398 --- /dev/null +++ b/common/distr.pas @@ -0,0 +1,684 @@ + +unit distr; +interface +{$Include isgui.inc} +uses Math, +{$IFDEF GUI}dialogs;{$ELSE} dialogsx;{$ENDIF} +function TtoZ(t,df: extended): extended; + +function lnGamma(f:longint):extended; + + { Computes the logarithm of the gamma function at f/2. } + + +function pGamma(f:longint;y:extended):extended; + + { Returns the right tail probability in the gamma + distribution with lambda = f/2. } + +function pNormal(z:extended):extended; + +//function pNormalOld(z:extended):extended; +//function pNormalOrig(z:extended):extended; //old +//function pNormalOrig(u:extended):extended; //old + + { Returns the right tail probability in the normal distribution. } + + +function pChi2(f:longint;y:extended):extended; + + { Returns the right tail probability in the chi square distribution + with f degrees of freedom. } + + +function pBeta(f1,f2:longint;y:extended):extended; + + { Returns the LEFT tail probability in the beta distribution + with paramters lambda1=f1/2 and lambda2=f2/2. Use only + f1 and f2 < 1E6. } + + +function pFdistr(f1,f2:longint;y:extended):extended; + + { Returns the right tail probability in the F distribution + with (f1,f2) degrees of freedom. + Use only f1 and f2 < 1E6. } + + +function pTdistr(f:longint;y:extended):extended; + + { Returns the right tail probability in the T distribution. + Use only f < 1E6. } + + +function pNormalInv(p:extended):extended; +function pNormalInvQuickApprox(p : extended) : extended;//errors rise with Z>7 + +//function pNormalInvOld(p:extended):extended; + + + + { Inverse of pNormal. } + + +function pGammaInv(f:longint;p:extended):extended; + + { Inverse of pGamma(f,*). } + + +function pChi2Inv(f:longint;p:extended):extended; + + { Inverse of pChi2(f,*). } + + +function pBetaInv(f1,f2:longint;p:extended):extended; + + { Inverse of pBeta(f1,f2,*) (notice: LEFT tail). } + + +function pFdistrInv(f1,f2:longint;p:extended):extended; + + { 1-p percentile of F distribution. } + +function pTdistrInv(f:longint;p:extended):extended; + + { 1-p percentile of T distribution. } + + +function pPoiss(lambda:extended; n:longint): extended; + + { Returns the right tail probability in the Poisson distribution. } + + +function PoissCL(n:longint; p:extended): extended; + + { Lower 1-p confidence limits for lambda in Poisson distribution + when n is observed. } + + +function pBin(n,x:longint; p:extended): extended; + + { Returns the binomial right tail probability. } + + +function BinCL(n,x:longint; pp:extended): extended; + + { Returns confidence limit for binomial probability parameter, + i.e. inverse to pBin(n,*). } + +function ChiSq(x: double; n: integer): double; + +{---------------------------------------------------------------------------} +implementation +//uses stat; + +function ChiSq(x: double; n: integer): double; +var + p,t: double; + var k,a: integer; +begin + p := exp(-0.5*x); + if odd(n) then + p := p * sqrt(2*x/Pi); + k := round(n); + while k >= 2 do begin + p := p *x/k; + k := k-2; + end; + t := p; + a := round(n); + while (t > 0.000001*p) do begin + a := a+2; + t := t*x/a; + p := p + t; + end; + result := 1-p; +end; + + +function TtoZ(t,df: extended): extended; +// Converts a t value to an approximate z value w.r.t the given df +// s.t. std.norm.(z) = t(z, df) at the two-tail probability level. +//from http://www.anu.edu.au/nceph/surfstat/surfstat-home/tables/t.php + var + A9,B9,T9,Z8, P7, B7: extended; + begin + A9 := df - 0.5; + B9 := 48*A9*A9; + T9 := t*t/df; + if T9 >= 0.04 then + Z8 :=A9*ln(1+T9) + else + Z8 := A9*(((1 - T9*0.75)*T9/3 - 0.5)*T9 + 1)*T9; + P7 := ((0.4*Z8 + 3.3)*Z8 + 24)*Z8 + 85.5; + B7 := 0.8*power(Z8, 2) + 100 + B9; + result := (1 + (-P7/B7 + Z8 + 3)/B9)*sqrt(Z8); + if t < 0 then + result := -result; +end; + +function lnGamma(f:longint):extended; +var sum,y : extended; + k : longint; +begin y:=f/2; +if f>500 then + begin + sum:= ln(2*pi)/2 + (y-1/2)*ln(y); sum:=sum -y + 1/(12*y); + sum:=sum - 1/360/y/y/y; + lnGamma:=sum; + end +else + begin + k:=f; sum:=0; + while k>2 do + begin + k:=k-2; + sum:=sum+ln(k/2); + end; + if k=1 then sum:=sum+ln(pi)/2; + lnGamma:=sum; + end; +end; + +function pGamma(f:longint;y:extended):extended; +var term,sum: extended; + k : longint; +begin if (y<=0) then pGamma:=1 else +if (y<f/2) or (y<42) then + begin + term:=(f/2)*ln(y)-y-lnGamma(f+2); + if term>-1000 then term:=exp(term) else term:=0; + sum:=0; k:=0; + while ((f+k)*term>(f+k-2*y)*1E-20) do + begin + sum:=sum+term; + term:=2*term*y/(f+k+2); + k:=k+2; + end; + pGamma:=abs(1-sum); + end +else + begin + term:=(f/2-1)*ln(y)-y-lnGamma(f); + if term>-1000 then term:=exp(term) else term:=0; + sum:=0; k:=0; + while (term*y > (2*y-f+k)*0.5E-20) and (f-k>1) do + begin + sum:=sum+term; + k:=k+2; + term:=term*(f-k)/2/y; + end; + pGamma:=abs(sum); + end; +end; +{---------------------------------------------------------------------------} +function pNormal(z:extended):extended; +const +PiD2=Pi/2; +var q: extended; +begin + q := z*z; + if abs(z)>7.0 then + result := (0.5)*(1-1/q+3/(q*q))*Exp(-q/2)/(Abs(z)*Sqrt(PiD2)) + else + result := pGamma(1,q/2)/2; + if z<0 then result:=1-result; +end; + +function pChi2(f:longint;y:extended):extended; +begin +pChi2:= pGamma(f,y/2); +end; + +function pBeta0(f1,f2:longint; y:extended): extended; + { Returns the left tail probability of the beta distribution + with paramters lambda1=f1/2 and lambda2=f2/2. Use only f1+f2<40. + Accuracy around +/- 1E-16 . } +var sum,term : extended; + k : longint; + +begin +sum:=0; k:=0; +term:=lnGamma(f1+f2)-lnGamma(f2); +term:=term-lnGamma(f1+2)+f1*ln(y)/2; +term:=exp(term); +while (k<f2) or (abs(term) > 1E-20) do + begin + sum:=sum+term; + k:=k+2; + term:=-term*y*(f2-k)*(f1+k-2)/k/(f1+k); + end; +pBeta0:=sum; +end; + +function pBeta(f1,f2:longint;y:extended):extended; +var sum,term : extended; + k : longint; + intch : boolean; + +begin if (f1=f2) and (y=0.5) then pBeta:=0.5 else + if y<=0 then pBeta:=0 else + if y>=1 then pBeta:=1 else + begin + intch:=false; + if y>(1-y) then + begin intch:=true; + k:=f1; f1:=f2; f2:=k; + y:=1-y; + end; + if f1+f2<41 then sum:=pBeta0(f1,f2,y) else + begin + term:= (f2/2-1)*ln(1-y) + (f1/2)*ln(y) + + lnGamma(f1+f2) - lnGamma(f1+2); + term:=term - lnGamma(f2); + if term > -1000 then term:=exp(term) else term:=0; + if (term<1E-35) and (y<f1/(f1+f2)) then sum:=0 + else if (term<1E-35) and (y>f1/(f1+f2)) then sum:=1 + else + begin + k:=0; sum:=0; + while (abs(term)>1E-25) or (y*(f2-k) > (1-y)*(f1+k)) do + begin sum:=sum+term; + k:=k+2; + term:= term*y*(f2-k)/(1-y)/(f1+k); + end; + end; + end; + if intch then sum:=1-sum; + pBeta:= abs(sum); + end; +end; + +function gammln (xx: double): double; {Numerical Recipes for Pascal, p 177} + const + stp = 2.50662827465; + var + x, tmp, ser: double; +begin + x := xx - 1.0; + tmp := x + 5.5; + tmp := (x + 0.5) * ln(tmp) - tmp; + ser := 1.0 + 76.18009173 / (x + 1.0) - 86.50532033 / + (x + 2.0) + 24.01409822 / (x + 3.0) - 1.231739516 / (x + 4.0) + 0.120858003e-2 / (x + 5.0) - 0.536382e-5 / (x + 6.0); + gammln := tmp + ln(stp * ser) +end; {procedure gammln} + +FUNCTION betacf(a,b,x: double): double; +LABEL 1; +CONST + itmax=100; + eps=3.0e-7; +VAR + tem,qap,qam,qab,em,d: double; + bz,bpp,bp,bm,az,app: double; + am,aold,ap: double; + m: integer; +BEGIN + am := 1.0; + bm := 1.0; + az := 1.0; + qab := a+b; + qap := a+1.0; + qam := a-1.0; + bz := 1.0-qab*x/qap; + FOR m := 1 TO itmax DO BEGIN + em := m; + tem := em+em; + d := em*(b-m)*x/((qam+tem)*(a+tem)); + ap := az+d*am; + bp := bz+d*bm; + d := -(a+em)*(qab+em)*x/((a+tem)*(qap+tem)); + app := ap+d*az; + bpp := bp+d*bz; + aold := az; + am := ap/bpp; + bm := bp/bpp; + az := app/bpp; + bz := 1.0; + IF ((abs(az-aold)) < (eps*abs(az))) THEN GOTO 1 + END; + writeln('pause in BETACF'); + writeln('a or b too big, or itmax too small'); readln; +1: betacf := az +END; + + +FUNCTION betai(a,b,x: double): double; +VAR + bt: double; +BEGIN + IF ((x < 0.0) OR (x > 1.0)) THEN BEGIN + writeln('pause in routine BETAI'); readln + END; + IF ((x = 0.0) OR (x = 1.0)) THEN bt := 0.0 + ELSE bt := exp(gammln(a+b)-gammln(a)-gammln(b) + +a*ln(x)+b*ln(1.0-x)); + IF (x < ((a+1.0)/(a+b+2.0))) THEN + betai := bt*betacf(a,b,x)/a + ELSE betai := 1.0-bt*betacf(b,a,1.0-x)/b +END; + +function pFdistr(f1,f2:longint;y:extended):extended; +begin +pFdistr:=pBeta(f2,f1,f2/(f1*y+f2)); +end; + +function pTdistr(f:longint;y:extended):extended; +begin + if y = 0 then + result := 0.5 + else begin + result := betai(0.5*f,0.5,f/(f+sqr(y)))/2; + if y < 0 then + result := 1-result; + end; +end;//from numerical recipes +(*below x5 slower than numerical recipes! +function pTdistr; +//function pTdistr(f:longint;y:extended):extended; +var p: extended; + +begin + +if y=0 then pTdistr:=0.5 else + begin + p:=f/(y*y+f); + p:=pBeta(f,1,p); p:=p/2; + if y<0 then p:=1-p; + pTdistr:=p; + end; +end;*) +{---------------------------------------------------------------------------} +(*function pNormalInv(p:extended):extended; +var + v,dv,z: extended; +begin + v := 0.5; + dv := 0.5; + z := 0; + while (dv>1e-15) do begin + z:=1/v-1; + dv:=dv/2; + if(pNormal(z)>p) then + v:=v-dv + else + v:=v+dv; + end; + result := z; +end; *) +function pNormalInv(p:extended):extended; +var + v,dv,z,tailp: extended; +begin + if p <= 0.5 then + tailp := p + else + tailp := 1-p; + if tailp = 0 then begin + result := 9.2;//fails with Z<-9 + exit; + end; + //showmessage('error'+realtostr(tailp,10)); + //showmessage(realtostr(tailp,10)); + v := 0.5; + dv := 0.5; + z := 0; + while (dv>1e-15) do begin + z:=1/v-1; + dv:=dv/2; + if(pNormal(z)>tailp) then + v:=v-dv + else + v:=v+dv; + end; + if p <= 0.5 then + result := z + else + result := -z; +end; + +function zprob(p : extended {; VAR errorstate : boolean}) : extended; +VAR + z, xp, lim, p0, p1, p2, p3, p4, q0, q1, q2, q3, q4, Y : extended; +begin + // value of probability between approx. 0 and .5 entered in p and the + // z value is returned z + //errorstate := true; + lim := 1E-19; + p0 := -0.322232431088; + p1 := -1.0; + p2 := -0.342242088547; + p3 := -0.0204231210245; + p4 := -4.53642210148E-05; + q0 := 0.099348462606; + q1 := 0.588581570495; + q2 := 0.531103462366; + q3 := 0.10353775285; + q4 := 0.0038560700634; + xp := 0.0; + if (p > 0.5) then + p := 1 - p; + if (p < lim) then //Z>9.5 Z<-9.5 + z := -pNormalInv(p) //use slow method + //z := xp + else if (p = 0.5) then + z := xp + else begin + Y := sqrt(ln(1.0 / (p * p))); + xp := Y + ((((Y * p4 + p3) * Y + p2) * Y + p1) * Y + p0) / + ((((Y * q4 + q3) * Y + q2) * Y + q1) * Y + q0); + if (p < 0.5) then xp := -xp; + z := xp; + end; + zprob := z; +end; // End function zprob + +function pNormalInvQuickApprox(p : extended) : extended; +var + z, px : extended; +// flag : boolean; +begin + // obtains the inverse of z, that is, the z for a probability associated + // with a normally distributed z score. + px := p; + if (p > 0.5) then px := 1.0 - p; + if px < 0.000000000000001 then + z := -8 //lPs[lInc] := 0.000000000000001; + else + z := zprob(px{,flag}); + if (p > 0.5) then z := abs(z); + result := -z; +end; //End of inversez Function + + +(*function zprob(p : double {; VAR errorstate : boolean}) : double; +VAR + z, xp, lim, p0, p1, p2, p3, p4, q0, q1, q2, q3, q4, Y : double; +begin + // value of probability between approx. 0 and .5 entered in p and the + // z value is returned z + //errorstate := true; + lim := 1E-19; + p0 := -0.322232431088; + p1 := -1.0; + p2 := -0.342242088547; + p3 := -0.0204231210245; + p4 := -4.53642210148E-05; + q0 := 0.099348462606; + q1 := 0.588581570495; + q2 := 0.531103462366; + q3 := 0.10353775285; + q4 := 0.0038560700634; + xp := 0.0; + if (p > 0.5) then p := 1 - p; + if (p < lim) then z := xp + else + begin + //errorstate := false; + if (p = 0.5) then z := xp + else + begin + Y := sqrt(ln(1.0 / (p * p))); + xp := Y + ((((Y * p4 + p3) * Y + p2) * Y + p1) * Y + p0) / + ((((Y * q4 + q3) * Y + q2) * Y + q1) * Y + q0); + if (p < 0.5) then xp := -xp; + z := xp; + end; + end; + zprob := z; +end; // End function zprob + +function pNormalInvQuickApprox(p : double) : double; +var + z, px : double; +// flag : boolean; +begin + // obtains the inverse of z, that is, the z for a probability associated + // with a normally distributed z score. + px := p; + if (p > 0.5) then px := 1.0 - p; + z := zprob(px{,flag}); + if (p > 0.5) then z := abs(z); + result := -z; +end; //End of inversez Function +*) +(*function pNormalInvOld; + +var pp,y,a,b,y0 :extended; + +begin +y:= 0; y0:=1; +pp:=0.5; +while y0>1E-10 do + begin y0:=y; + a:=-ln(2*pi)/2-y*y/2; + b:=y; + if abs(b)<1E-2 then y:=y+(pp-p)*exp(-a) + else y:=y+ln(1+b*(pp-p)*exp(-a))/b; + pp:=pNormalOld(y); y0:=abs(y-y0); + end; +result:=y; +end; (**) +function pGammaInv(f:longint;p:extended):extended; +var pp,y,y0,a,b,a0 :extended; + +begin a0:=-lnGamma(f); +if f=1 then + begin + y:=pNormalInv(p/2); y:=y*y/2; + end +else + begin if f>100 then + begin y:= sqrt(2*f-1)+pNormalInv(p); y:=y*y/4; + end + else y:=f/2; + y0:=1; + pp:=pGamma(f,y); + while y0>1E-7 do + begin y0:=y; + a:=a0+(f/2-1)*ln(y)-y; + b:=(f/2-1)/y-1; + if abs(b*(pp-p)*exp(-a))<1E-5 then y:=y+(pp-p)*exp(-a) + else y:=y+ln(1+b*(pp-p)*exp(-a))/b; + pp:=pGamma(f,y); + y0:=abs(y-y0); + end; + end; +pGammaInv:=y; +end; + +function pChi2Inv(f:longint;p:extended):extended; +var y:extended; + +begin +y:=pGammaInv(f,p); +pChi2Inv:=2*y; +end; +{---------------------------------------------------------------------------} +function pBetaInv1(f1,f2:longint;p:extended):extended; + +var pp,y,y0,a,b,a0 :extended; + +begin +if p<=0 then y:=0 +else if p>=1 then y:=1 +else if (f1=1) and (f2=1) then y:=sin(p*pi/2)*sin(p*pi/2) +else if (f1=1) and (f2=2) then y:=p*p +else if (f1=2) and (f2=1) then y:=1-(1-p)*(1-p) +else if (f1=2) and (f2=2) then y:=p +else + begin + a0:=-lnGamma(f1)-lnGamma(f2); a0:=a0+lnGamma(f1+f2); + y:=f1/(f1+f2); + if f1=1 then + begin + y:= pGammaInv(1,1-p); + y:= 2*y/(2*y+f2-1/2); + end; + y0:=1; + pp:=pBeta(f1,f2,y); + while y0>1E-8 do + begin + a:=a0+(f1/2-1)*ln(y)+(f2/2-1)*ln(1-y); + b:=(f1/2-1)/y-(f2/2-1)/(1-y); + if abs(b*(pp-p))*exp(-a)<1E-5 then y0:=-(pp-p)*exp(-a) + else y0:=ln(1-b*(pp-p)*exp(-a))/b; + y:=y+y0; + pp:=pBeta(f1,f2,y); + y0:=abs(y0)/y/(1-y); + end; + end; +pBetaInv1:=y; +end; +{---------------------------------------------------------------------------} +function pBetaInv(f1,f2:longint;p:extended):extended; + +var y: extended; + +begin if f1<=f2 then y:=pBetaInv1(f1,f2,p) +else y:= 1-pBetaInv1(f2,f1,1-p); +pBetaInv := y; +end; +{---------------------------------------------------------------------------} +function pFdistrInv(f1,f2:longint;p:extended):extended; + +var y : extended; + +begin +y:=pBetaInv(f2,f1,p); +if y = 0 then + pFdistrInv:= 0 //infinityINF +else + pFdistrInv:=f2/f1*(1-y)/y; +end; +{---------------------------------------------------------------------------} +function pTdistrInv(f:longint;p:extended):extended; + +var t:extended; + +begin if p<=0.5 then t:=sqrt(pFdistrInv(1,f,2*p)) +else t:=-sqrt(pFdistrInv(1,f,2*(1-p))); +pTdistrInv:=t; +end; +{---------------------------------------------------------------------------} +function pPoiss(lambda:extended; n:longint): extended; +begin pPoiss:= 1-pGamma(2*n,lambda); +end; +{---------------------------------------------------------------------------} + +function pBin(n,x:longint; p:extended): extended; +begin pBin:= pBeta(2*x,2+2*(n-x),p); +end; +{---------------------------------------------------------------------------} +function PoissCL(n:longint; p:extended): extended; + +begin PoissCL := pGammaInv(2*n,1-p); +end; +{---------------------------------------------------------------------------} +function BinCL(n,x:longint; pp:extended): extended; + +begin BinCL:= pBetaInv(2*x,2+2*(n-x),pp); +end; +{---------------------------------------------------------------------------} + +end. diff --git a/common/distr.ppu b/common/distr.ppu new file mode 100644 index 0000000..2091d34 Binary files /dev/null and b/common/distr.ppu differ diff --git a/common/gui.inc b/common/gui.inc new file mode 100755 index 0000000..368e64d --- /dev/null +++ b/common/gui.inc @@ -0,0 +1 @@ +{$DEFINE GUI} //use GUI if you are using a graphic user interface - anything else for console applications diff --git a/common/gzio2.o b/common/gzio2.o new file mode 100644 index 0000000..7c6cfeb Binary files /dev/null and b/common/gzio2.o differ diff --git a/common/gzio2.pas b/common/gzio2.pas new file mode 100755 index 0000000..58a2cf6 --- /dev/null +++ b/common/gzio2.pas @@ -0,0 +1,2144 @@ +Unit gzio2; + +{ + Pascal unit based on gzio.c -- IO on .gz files + Copyright (C) 1995-1998 Jean-loup Gailly. + + Define NO_DEFLATE to compile this file without the compression code + + Pascal tranlastion based on code contributed by Francisco Javier Crespo + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} +{$H+} {$mode Delphi} +interface + +{$I zconf.inc} + +uses + {$ifdef UNIX} + baseunix, + {$else} + dos, + {$endif} + sysutils,zbase, crc, zdeflate, zinflate,define_types; + +type gzFile = pointer; + + +type z_off_t = longint; +function Gunzip (var FFileSource,FFileDestination: string): integer; + +procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean);overload; +procedure GZipBuffer(var FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean);overload; +procedure UnGZip (var lInFname: string; var lBuf: ByteP; lOffset,lMaxSz: int64); //unzip +procedure UnGZip2 (var lInFname: string; var lBuf: ByteP; lOffset,lMaxSz,Skip: int64); //unzip after skipping a few bytes +procedure UnGZipCore (var infile : gzFile; var lBuf: ByteP; lReadBytes: integer; lWrite: boolean); +procedure UnGZipFile (var lFname,lOUtname: string); //unzip +function gzopen (path:string; mode:string) : gzFile; overload; +function gzopen (path:string; mode:string; skip: integer) : gzFile; overload; + +function gzread (f:gzFile; buf:pointer; len:cardinal) : integer; +function gzgetc (f:gzfile) : integer; +function gzgets (f:gzfile; buf:Pchar; len:integer) : Pchar; +procedure GZipFile(lSrcName,lDestName: String); overload; +procedure GZipFile(lSrcName,lDestName: String;lDeleteSrc: boolean);overload; +{$ifndef NO_DEFLATE} +function gzwrite (f:gzFile; buf:pointer; len:cardinal) : integer; +function gzputc (f:gzfile; c:char) : integer; +function gzputs (f:gzfile; s:Pchar) : integer; +function gzflush (f:gzFile; flush:integer) : integer; + {$ifdef GZ_FORMAT_STRING} + function gzprintf (zfile : gzFile; + const format : string; + a : array of integer); { doesn't compile } + {$endif} +{$endif} + + +function gzseek (f:gzfile; offset:z_off_t; whence:integer) : z_off_t; +function gztell (f:gzfile) : z_off_t; +function gzclose (f:gzFile) : integer; +function gzerror (f:gzFile; var errnum:smallint) : string; +function gzsetparams (f:gzfile; level:integer; strategy:integer) : integer; +function gzrewind (f:gzFile) : integer; +function gzeof (f:gzfile) : boolean; + +const + SEEK_SET {: z_off_t} = 0; { seek from beginning of file } + SEEK_CUR {: z_off_t} = 1; { seek from current position } + SEEK_END {: z_off_t} = 2; + +implementation +{$include isgui.inc} +uses dialogsx;//{$IFDEF GUI}uses dialogs;{$ELSE} uses dialogsx;{$ENDIF} +const + Z_EOF = -1; { same value as in STDIO.H } + Z_BUFSIZE = 16384; + { Z_PRINTF_BUFSIZE = 4096; } + + + gz_magic : array[0..1] of byte = ($1F, $8B); { gzip magic header } + + { gzip flag byte } + + //ASCII_FLAG = $01; { bit 0 set: file probably ascii text } + HEAD_CRC = $02; { bit 1 set: header CRC present } + EXTRA_FIELD = $04; { bit 2 set: extra field present } + ORIG_NAME = $08; { bit 3 set: original file name present } + COMMENT = $10; { bit 4 set: file comment present } + RESERVED = $E0; { bits 5..7: reserved } + +type gz_stream = record + stream : z_stream; + z_err : integer; { error code for last stream operation } + z_eof : boolean; { set if end of input file } + gzfile : file; { .gz file } + inbuf : Pbyte; { input buffer } + outbuf : Pbyte; { output buffer } + crc : cardinal; { crc32 of uncompressed data } + + //msg, + zpath : string[255];//6666666666666666 { path name for debugging only - limit 79 chars } + transparent : boolean; { true if input file is not a .gz file } + mode : char; { 'w' or 'r' } + startpos : longint; { start of compressed data in file (header skipped) } +end; + +type gz_streamp = ^gz_stream; + +function zdestroy (var s:gz_streamp) : integer; forward; +procedure check_header(s:gz_streamp); forward; + +procedure UnGZip2 (var lInFname: string; var lBuf: ByteP; lOffset,lMaxSz,Skip: int64); //unzip +const +BUFLEN = 16384; +var + infile : gzFile; + lFname : ansistring; + lbufsz,len,lI,written : int64; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } +begin + lFName := lInFName; + infile := gzopen (lFName, 'r',Skip); + written := 0; + if lOffset > 0 then begin + Len := lOffset div BUFLEN; + if Len > 0 then begin + lI := 1; + while (lI <= Len) do begin + gzread (infile, @buf, BUFLEN {1388}); + inc(lI); + end; + end; + + Len := lOffset mod BUFLEN; + gzread (infile, @buf, Len); + end; + lbufsz := BUFLEN; + if lMaxSz < BUFLEN then + lbufsz := lMaxSz; + while true do begin + len := gzread (infile, @buf, lbufsz); + if (len < 0) then begin + break + end; + if (len = 0) + then break; + if (Written+len) > lMaxSz then begin + if Written < lMaxSz then + Move(buf,lbuf^[Written+1],lMaxSz-Written); //cr2007 + break; + end; + Move(buf,lbuf^[Written+1],len); + Written := Written + len; + end; {WHILE} + gzclose (infile); + //filemode := 2; +end; + +procedure UnGZip (var lInFname: string; var lBuf: ByteP; lOffset,lMaxSz: int64); +begin + UnGZip2 ( lInFname, lBuf, lOffset,lMaxSz,0); + +end; + + +(*procedure UnGZip (var lInFname: string; var lBuf: ByteP; lOffset,lMaxSz: int64); //unzip +const +BUFLEN = 16384; +var + infile : gzFile; + lFname : ansistring; + lI,len ,written, lbufsz : int64; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } +begin + lFName := lInFName; + //filemode := 1; + //if lFName = 'z' then + //showmessage('unzip'); + //ImgForm.Caption := 'gz'; + //ReadIntForm.GetInt('Multi-volume file, please select volume to view.',1,1,3); + //infile := gzopenZ (lFName, 'r', 0); + //showmessage(lFName); + infile := gzopen (lFName, 'r'); + written := 0; + if lOffset > 0 then begin + Len := lOffset div BUFLEN; + if Len > 0 then begin + lI := 1; + while (lI <= Len) do begin + gzread (infile, @buf, BUFLEN {1388}); + inc(lI); + end; + //for lI := 1 to Len do + // gzread (infile, @buf, BUFLEN {1388}); + end; + Len := lOffset mod BUFLEN; + gzread (infile, @buf, Len); + end; + lbufsz := BUFLEN; + if lMaxSz < BUFLEN then + lbufsz := lMaxSz; + while true do begin + len := gzread (infile, @buf, lbufsz); + if (len < 0) then begin + break + end; + if (len = 0) + then break; + if (Written+len) > lMaxSz then begin + if Written < lMaxSz then + Move(buf,lbuf^[Written+1],lMaxSz-Written); //cr2007 + break; + end; + Move(buf,lbuf^[Written+1],len); + Written := Written + len; + end; {WHILE} + gzclose (infile); + //filemode := 2; +end; *) + + +procedure UnGZipCore (var infile : gzFile; var lBuf: ByteP; lReadBytes: integer; lWrite: boolean); +const + BUFLEN = 16384; +var + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } + len,lI,written : integer; +begin + written := 0; + if lReadBytes < 1 then exit; + Len := lReadBytes div BUFLEN; + if Len > 0 then + for lI := 1 to Len do begin + gzread (infile, @buf, BUFLEN {1388}); + if lWrite then + Move(buf,lbuf[Written+1],BUFLEN); + Written := Written + BUFLEN; + end; + Len := lReadBytes mod BUFLEN; + if Len = 0 then exit; + gzread (infile, @buf, Len); + if lWrite then + Move(buf,lbuf[Written+1],len); +end; //ungzipCore + +procedure UnGZipFile (var lFname,lOUtname: string); //unzip +const +bufsz = 16384; +var + infile : gzFile; + len,lI : integer; + //written : integer; + lF: File; + buf : packed array [0..bufsz-1] of byte; { Global uses BSS instead of stack } +begin + //infile := gzopenZ (lFName, 'r', 0); + infile := gzopen (lFName, 'r'); + + //written := 0; + //lbufsz := BUFLEN; + Filemode := 1; + AssignFile(lF, lOUtname); + Rewrite(lF,1); + while true do begin + len := gzread (infile, @buf, bufsz); + if (len < 0) then begin + break + end; + if (len = 0) + then break; + BlockWrite(lF,buf, len); + //Move(buf,lbuf[Written+1],len); + //Written := Written + len; + end; {WHILE} + gzclose (infile); + CloseFile(lF); + Filemode := 2; //1366 +end; + +function gz_compress (var infile:file; outfile:gzFile): integer; +var + len : cardinal; + ioerr : integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + fsize, lensize : DWord; +begin + errorcode := 0; + //Progress := 0; + fsize := FileSize(infile); + lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + {$I-}blockread (infile, buf, Z_BUFSIZE, len);{$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + errorcode := 1; + break + end; + if (len = 0) then break; + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + end; + closeFile (infile); + if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3; + gz_compress := errorcode; +end; // proc gz_compress + +procedure GZipFile(lSrcName,lDestName: String; lDeleteSrc: boolean); overload; +var + infile : file; + outfile : gzFile; + ioerr : integer; + mode : string; +begin + //Msg('GZip ' + extractfilename(lSrcName)); + //writeln(lSrcName+' -> GZ -> '+lDestName); + mode := 'w6 '; + Assign (infile, lSrcName); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + ShowMsg ('GZipFile error: '+inttostr(ioerr)); + halt(1); + end; + outfile := gzopen (lDestName, mode); + if (outfile = NIL) then begin + ShowMsg('unable to create '+lDestName); + exit; + end; + gz_compress(infile, outfile); + if lDeleteSrc then + erase (infile); +end; + +procedure GZipFile(lSrcName,lDestName: String); overload; +var + FGzipFilename : string; + FGzipComments : string; + outmode : string; + s,FFileDestination : string; + infile : file; + outfile : gzFile; + FCompressionLevel{,errorcode} : integer; + flags : Integer; + stream : gz_streamp; + //p : PChar; + ioerr : integer; +begin +//FGzipHeader := [zFilename]; +FGzipFilename:= lSrcName; +FGzipComments := ''; + FCompressionLevel := 6; +//MainForm.ProgressBar1.position :=1; +//Gzip (lFile,lMulti); + FFileDestination := lDestName; + //result := 2; //return error if user aborts +(* if fileexists(FFileDestination) then begin + case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + mrAbort: exit; + end; + end;*) + AssignFile (infile, lSrcName); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + // Showmessage('Can''t open: '+lSrcName); + //errorcode := 1 + end + else begin + outmode := 'w '; + //s := IntToStr(FCompressionLevel); + outmode[2] := '6';//s[1]; + outmode[3] := ' '; + (*case FCompressionType of + Standard : outmode[3] := ' '; + HuffmanOnly : outmode[3] := 'h'; + Filtered : outmode[3] := 'f'; + end;*) + + //flags := 0; + //if (zfilename in FGzipHeader) then + flags := ORIG_NAME; + //if (comment in FGzipHeader) then flags := flags + COMMENT_; + outfile := gzopen (lSrcName, outmode); + if (outfile = NIL) then begin + //Showmessage('Can''t open: '+lSrcName); + close( infile); + exit; + end + else begin + { if flags are set then write them } + stream := gz_streamp(outfile); + if {(zfilename in FGzipHeader)} true then begin + s := lSrcName;//999 ExtractFilename(lSrcName); + //p := PChar(s); + blockWrite( stream^.gzfile, {p[0]}s, length(s)+1); + stream^.startpos := stream^.startpos + length(s) + 1 + end; + gz_compress(infile, outfile); + end + end; +end; + +procedure file_compress2 (filename,outname:string); +var + infile : file; + outfile : gzFile; + ioerr : integer; + mode : string; +begin + mode := 'w6 '; + Assign (infile, filename); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + writeln ('open error: ',ioerr); + halt(1); + end; + outfile := gzopen (outname, mode); + if (outfile = NIL) then begin + //999 showmessage(' can''t gzopen '+outname); + halt(1); + end; + + gz_compress(infile, outfile); + erase (infile); +end; + + + +(*function gz_compressBuffer (lxInBuffer: ByteP;lInSize: integer;outfile:gzFile): integer; +var + len : Integer; + lInBufferPos,ioerr : integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + //lInBufPtr,lOutbufPtr: pointer; + errorcode : byte; + //fsize, lensize : DWord; +function blocktransfer(var lInBuffer: ByteP; lSizeRequested: integer; var lSizeTransferred:integer): integer; +begin + result := 0; + if lInBufferPos > lInSize then begin + result := 666; + exit; + end else if (lInBufferPos + lSizeRequested) <= lInSize then + lSizeTransferred := lSizeRequested + else + lSizeTransferred := lInSize-lInBufferPos; + //for lC := 1 to lSizeTransferred do + // buf[lC-1] := lInBuffer[lInBufferPos+lC] ; + move(lInbuffer[lInBufferPos+1],buf,lSizeTransferred); + //move(src,dest,count); + + lInBufferPos := lInBufferPos+lSizeTransferred; +end; +begin + lInBufferPos := 0; + errorcode := 0; + //Progress := 0; + //fsize := lInSize; + //lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + //lll{$I-}blockread (infile, buf, Z_BUFSIZE, len);{$I+} + ioerr := blocktransfer(lxInBuffer,Z_BUFSIZE, len); + if (ioerr <> 0) then begin + errorcode := 1; + break + end; + if (len = 0) then break; + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + end; {WHILE} + if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3; + result := errorcode; +end; + +procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +var + FGzipComments ,outmode,s : string; + infile : file; + outfile : gzFile; + FCompressionLevel : integer; + flags : uInt; + stream : gz_streamp; + p : PChar; +begin +FGzipComments := ''; +FCompressionLevel := 6; +if (FCompressionLevel > 9) or (FCompressionLevel<0) then FCompressionLevel := 6; + if lOverwritewarn and fileexists(FFileDestination) then begin + case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + mrAbort: exit; + end; + end; + //w adds .gz extension-> outmode := 'w '; + outmode := 'w '; + s := IntToStr(FCompressionLevel); + outmode[2] := s[1]; + outmode[3] := ' '; + flags := ORIG_NAME; + outfile := gzopenZ (FFileDestination, outmode, flags); + if (outfile = NIL) then begin + MessageDlg('Can''t open: '+FFileDestination, mtError, [mbAbort], 0); + close( infile); + exit; + end + else begin + stream := gz_streamp(outfile); + if {(zfilename in FGzipHeader)} true then begin + //s := ExtractFilename(lInFileName); + s := ExtractFilename(FGzipFilename); + //p := PChar(s); + blockWrite( stream^.gzfile,s , length(s)+1); + stream^.startpos := stream^.startpos + length(s) + 1 + end; + gz_compressBuffer (lxInBuffer,lInSize,outfile); + end +end; *) + + +{ GZOPEN ==================================================================== + + Opens a gzip (.gz) file for reading or writing. As Pascal does not use + file descriptors, the code has been changed to accept only path names. + + The mode parameter defaults to BINARY read or write operations ('r' or 'w') + but can also include a compression level ('w9') or a strategy: Z_FILTERED + as in 'w6f' or Z_HUFFMAN_ONLY as in 'w1h'. (See the description of + deflateInit2 for more information about the strategy parameter.) + + gzopen can be used to open a file which is not in gzip format; in this + case, gzread will directly read from the file without decompression. + + gzopen returns NIL if the file could not be opened (non-zero IOResult) + or if there was insufficient memory to allocate the (de)compression state + (zlib error is Z_MEM_ERROR). + +============================================================================} + +(*function gzopenZ(sourceFilename:string; mode:string; flags:uInt) : gzFile; +var + + i : uInt; + err: int; + level: int; + strategy : int; { compression strategy } + s : gz_streamp; + path: string; +{$IFDEF MSDOS} + attr : word; { file attributes } +{$ENDIF} + +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} + +begin + //wait(30); + path := sourceFilename; + + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + result := Z_NULL; + exit; + end; + if (path='') then begin + //999 Showmessage('Error with path'); + result := Z_NULL; + exit; + end; + //showmessage('gzOpenCompleted'); + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + s^.stream.zalloc := NIL; { (alloc_func)0 } + s^.stream.zfree := NIL; { (free_func)0 } + s^.stream.opaque := NIL; { (voidpf)0 } + s^.stream.next_in := Z_NULL; + s^.stream.next_out := Z_NULL; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := Z_NULL; + s^.outbuf := Z_NULL; + s^.crc := crc32(0, Z_NULL, 0); + s^.msg := ''; + s^.transparent := false; + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + //if (s^.mode='w') then begin path := path+'.gz'; end; + s^.path := path; { limit to 255 chars } + if (s^.mode=chr(0)) then begin + zdestroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = Z_NULL) then begin + zdestroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = Z_NULL) then begin + zdestroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + Assign (s^.gzfile, path {10/10/2006 s^.path}); + //Assign (s^.gzfile, s^.path); + {$ifdef MSDOS} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + if {(not FileExists(s^.path)) and} (s^.mode='w') then + // Vincent: changed IF because I don't want old data behind my + // new made .gz-file + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + zdestroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := flags; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := LONG(10); +{$ENDIF} + end + else begin + check_header(s); { skip the .gz header } + {$WARNINGS OFF} { combining signed and unsigned types } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + {$WARNINGS ON} + end; + result := gzFile(s); +end;//gzopenZ *) + + +(*function StringMaxLen (var lInStr: ansistring; lMaxSz: integer): ansistring; +var + lPos: integer; +begin + //note: strings shortened to lMaxSz-1 + //null termination requires one byte + //e.g. size of 80 bytes can become a null terminated string with up to 79 characters + if length(lInStr) >= lMaxSz then begin//crop string + result := ''; + for lPos := 1 to (lMaxSz-1) do + result := result + lInStr[lPos]; + end else + result := lInStr; +end; *) + + +{ GZOPEN ==================================================================== + + Opens a gzip (.gz) file for reading or writing. As Pascal does not use + file descriptors, the code has been changed to accept only path names. + + The mode parameter defaults to BINARY read or write operations ('r' or 'w') + but can also include a compression level ('w9') or a strategy: Z_FILTERED + as in 'w6f' or Z_HUFFMAN_ONLY as in 'w1h'. (See the description of + deflateInit2 for more information about the strategy parameter.) + + gzopen can be used to open a file which is not in gzip format; in this + case, gzread will directly read from the file without decompression. + + gzopen returns nil if the file could not be opened (non-zero IOResult) + or if there was insufficient memory to allocate the (de)compression state + (zlib error is Z_MEM_ERROR). + +============================================================================} +function gzopen (path:string; mode:string; skip: integer) : gzFile; + +var + + i : cardinal; + err : integer; + level : integer; { compression level } + strategy : integer; { compression strategy } + s : gz_streamp; +{$ifdef UNIX} + info: stat; +{$else} + attr: word; +{$endif} + +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} + +begin + + if (path='') or (mode='') then begin + gzopen := nil; + exit; + end; + + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + gzopen := nil; + exit; + end; + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + + s^.stream.next_in := nil; + s^.stream.next_out := nil; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := nil; + s^.outbuf := nil; + s^.crc := crc32(0, nil, 0); + //s^.msg := ''; + s^.transparent := false; + + s^.zpath := path; { limit to 255 chars } + + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + if (s^.mode=chr(0)) then begin + zdestroy(s); + gzopen := gzFile(nil); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = nil) then begin + zdestroy(s); + gzopen := gzFile(nil); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = nil) then begin + zdestroy(s); + gzopen := gzFile(nil); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + //showmessage(s^.path+' '+inttostr(length(path))); + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + //11/11/07 Assign (s^.gzfile, s^.path); + Assign (s^.gzfile, path); + {$ifdef unix} + if (fpstat(s^.zpath,info)<0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else begin + Reset (s^.gzfile,1); + if skip > 0 then Seek(s^.gzfile,skip); + end; + {$else} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else begin + Reset (s^.gzfile,1); + if skip > 0 then Seek(s^.gzfile,skip); + end; + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + + if (IOResult <> 0) then begin + zdestroy(s); + gzopen := gzFile(nil); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := 0; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := longint(10); +{$ENDIF} + end + else begin + check_header(s); { skip the .gz header } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + end; + + gzopen := gzFile(s); +end; + +function gzopen (path:string; mode:string) : gzFile; +begin + result := gzopen(path,mode,0); + +end; + +(*2015 function gzopen (path:string; mode:string) : gzFile; + +var + + i : cardinal; + err : integer; + level : integer; { compression level } + strategy : integer; { compression strategy } + s : gz_streamp; +{$ifdef UNIX} + info: stat; +{$else} + attr: word; +{$endif} + +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} + +begin + + if (path='') or (mode='') then begin + gzopen := nil; + exit; + end; + + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + gzopen := nil; + exit; + end; + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + + s^.stream.next_in := nil; + s^.stream.next_out := nil; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := nil; + s^.outbuf := nil; + s^.crc := crc32(0, nil, 0); + //s^.msg := ''; + s^.transparent := false; + s^.zpath := path; { limit to 255 chars } + + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + if (s^.mode=chr(0)) then begin + zdestroy(s); + gzopen := gzFile(nil); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = nil) then begin + zdestroy(s); + gzopen := gzFile(nil); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = nil) then begin + zdestroy(s); + gzopen := gzFile(nil); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + //showmessage(s^.path+' '+inttostr(length(path))); + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + //11/11/07 Assign (s^.gzfile, s^.path); + Assign (s^.gzfile, path); + {$ifdef unix} + if (fpstat(path,info)<0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + zdestroy(s); + gzopen := gzFile(nil); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := 0; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := longint(10); +{$ENDIF} + end + else begin + check_header(s); { skip the .gz header } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + end; + + gzopen := gzFile(s); +end; *) + + +{ GZSETPARAMS =============================================================== + + Update the compression level and strategy. + +============================================================================} + +function gzsetparams (f:gzfile; level:integer; strategy:integer) : integer; + +var + + s : gz_streamp; + written: integer; + +begin + + s := gz_streamp(f); + + if (s = nil) or (s^.mode <> 'w') then begin + gzsetparams := Z_STREAM_ERROR; + exit; + end; + + { Make room to allow flushing } + if (s^.stream.avail_out = 0) then begin + s^.stream.next_out := s^.outbuf; + blockwrite(s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); + if (written <> Z_BUFSIZE) then s^.z_err := Z_ERRNO; + s^.stream.avail_out := Z_BUFSIZE; + end; + + gzsetparams := deflateParams (s^.stream, level, strategy); +end; + + +{ GET_BYTE ================================================================== + + Read a byte from a gz_stream. Updates next_in and avail_in. + Returns EOF for end of file. + IN assertion: the stream s has been sucessfully opened for reading. + +============================================================================} + +function get_byte (s:gz_streamp) : integer; + +begin + + if (s^.z_eof = true) then begin + get_byte := Z_EOF; + exit; + end; + + if (s^.stream.avail_in = 0) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then s^.z_err := Z_ERRNO; + get_byte := Z_EOF; + exit; + end; + s^.stream.next_in := s^.inbuf; + end; + + Dec(s^.stream.avail_in); + get_byte := s^.stream.next_in^; + Inc(s^.stream.next_in); + +end; + + +{ GETLONG =================================================================== + + Reads a Longint in LSB order from the given gz_stream. + +============================================================================} +{ +function getLong (s:gz_streamp) : cardinal; +var + x : array [0..3] of byte; + i : byte; + c : integer; + n1 : longint; + n2 : longint; +begin + + for i:=0 to 3 do begin + c := get_byte(s); + if (c = Z_EOF) then s^.z_err := Z_DATA_ERROR; + x[i] := (c and $FF) + end; + n1 := (ush(x[3] shl 8)) or x[2]; + n2 := (ush(x[1] shl 8)) or x[0]; + getlong := (n1 shl 16) or n2; +end; +} +function getLong(s : gz_streamp) : cardinal; +var + x : packed array [0..3] of byte; + c : integer; +begin + { x := cardinal(get_byte(s)); - you can't do this with TP, no unsigned longint } + { the following assumes a little endian machine and TP } + x[0] := Byte(get_byte(s)); + x[1] := Byte(get_byte(s)); + x[2] := Byte(get_byte(s)); + c := get_byte(s); + x[3] := Byte(c); + if (c = Z_EOF) then + s^.z_err := Z_DATA_ERROR; + GetLong := cardinal(longint(x)); +end; + + +{ CHECK_HEADER ============================================================== + + Check the gzip header of a gz_stream opened for reading. + Set the stream mode to transparent if the gzip magic header is not present. + Set s^.err to Z_DATA_ERROR if the magic header is present but the rest of + the header is incorrect. + + IN assertion: the stream s has already been created sucessfully; + s^.stream.avail_in is zero for the first time, but may be non-zero + for concatenated .gz files + +============================================================================} + +procedure check_header (s:gz_streamp); +const + z_magic : array[0..1] of byte = ($78, $9C); //.z files simply have an abreviated header + +var + + method : integer; { method byte } + flags : integer; { flags byte } + len : cardinal; + c : integer; + cx: array[0..1] of integer; +begin + + { Check the gzip magic header } + for len := 0 to 1 do begin + c := get_byte(s); + cx[len] := c; + if (c <> gz_magic[len]) and (c <> z_magic[len]) then begin + if (len <> 0) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + end; + if (c <> Z_EOF) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + s^.transparent := TRUE; + end; + if (s^.stream.avail_in <> 0) then s^.z_err := Z_OK + else s^.z_err := Z_STREAM_END; + exit; + end; + end; + if (cx[0] = z_magic[0]) and (cx[1] = z_magic[1]) then begin + //method := Z_DEFLATED; + //flags := 0; //none + s^.z_err := Z_OK; + exit; + end; + method := get_byte(s); + flags := get_byte(s); + if (method <> Z_DEFLATED) or ((flags and RESERVED) <> 0) then begin + s^.z_err := Z_DATA_ERROR; + exit; + end; + + for len := 0 to 5 do get_byte(s); { Discard time, xflags and OS code } + + if ((flags and EXTRA_FIELD) <> 0) then begin { skip the extra field } + len := cardinal(get_byte(s)); + len := len + (cardinal(get_byte(s)) shr 8); + { len is garbage if EOF but the loop below will quit anyway } + while (len <> 0) and (get_byte(s) <> Z_EOF) do Dec(len); + end; + + if ((flags and ORIG_NAME) <> 0) then begin { skip the original file name } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and COMMENT) <> 0) then begin { skip the .gz file comment } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and HEAD_CRC) <> 0) then begin { skip the header crc } + get_byte(s); + get_byte(s); + end; + + if (s^.z_eof = true) then + s^.z_err := Z_DATA_ERROR + else + s^.z_err := Z_OK; + +end; + + +{ DESTROY =================================================================== + + Cleanup then free the given gz_stream. Return a zlib error code. + Try freeing in the reverse order of allocations. + +============================================================================} + +function zdestroy (var s:gz_streamp) : integer; + +begin + + result := Z_OK; + + if not Assigned (s) then begin + result := Z_STREAM_ERROR; + exit; + end; + + if (s^.stream.state <> nil) then begin + + if (s^.mode = 'w') then begin + {$IFDEF NO_DEFLATE} + result := Z_STREAM_ERROR; + {$ELSE} + //showMsg('1666'); + result := deflateEnd(s^.stream); + //showMsg('3666'); + {$ENDIF} + end + else if (s^.mode = 'r') then begin + result := inflateEnd(s^.stream); + end; + end; + + if (s^.zpath <> '') then begin + {$I-} + close(s^.gzfile); + {$I+} + if (IOResult <> 0) then result := Z_ERRNO; + end; + + if (s^.z_err < 0) then result := s^.z_err; + + if Assigned (s^.inbuf) then + FreeMem(s^.inbuf, Z_BUFSIZE); + if Assigned (s^.outbuf) then + FreeMem(s^.outbuf, Z_BUFSIZE); + FreeMem(s, sizeof(gz_stream)); + +end; + + +{ GZREAD ==================================================================== + + Reads the given number of uncompressed bytes from the compressed file. + If the input file was not in gzip format, gzread copies the given number + of bytes into the buffer. + + gzread returns the number of uncompressed bytes actually read + (0 for end of file, -1 for error). + +============================================================================} + +function gzread (f:gzFile; buf:pointer; len:cardinal) : integer; + +var + + s : gz_streamp; + start : Pbyte; + next_out : Pbyte; + n : cardinal; + crclen : cardinal; { Buffer length to update CRC32 } + filecrc : cardinal; { CRC32 stored in GZIP'ed file } + filelen : cardinal; { Total lenght of uncompressed file } + bytes : integer; { bytes actually read in I/O blockread } + total_in : cardinal; + total_out : cardinal; + +begin + + s := gz_streamp(f); + start := Pbyte(buf); { starting point for crc computation } + + if (s = nil) or (s^.mode <> 'r') then begin + gzread := Z_STREAM_ERROR; + exit; + end; + + if (s^.z_err = Z_DATA_ERROR) or (s^.z_err = Z_ERRNO) then begin + gzread := -1; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then begin + gzread := 0; { EOF } + exit; + end; + + s^.stream.next_out := Pbyte(buf); + s^.stream.avail_out := len; + + while (s^.stream.avail_out <> 0) do begin + + if (s^.transparent = true) then begin + { Copy first the lookahead bytes: } + n := s^.stream.avail_in; + if (n > s^.stream.avail_out) then n := s^.stream.avail_out; + if (n > 0) then begin + move(s^.stream.next_in^,s^.stream.next_out^,n); + inc (s^.stream.next_out, n); + inc (s^.stream.next_in, n); + dec (s^.stream.avail_out, n); + dec (s^.stream.avail_in, n); + end; + if (s^.stream.avail_out > 0) then begin + blockread (s^.gzfile, s^.stream.next_out^, s^.stream.avail_out, bytes); + dec (s^.stream.avail_out, cardinal(bytes)); + end; + dec (len, s^.stream.avail_out); + inc (s^.stream.total_in, cardinal(len)); + inc (s^.stream.total_out, cardinal(len)); + gzread := integer(len); + exit; + end; { IF transparent } + + if (s^.stream.avail_in = 0) and (s^.z_eof = false) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then begin + s^.z_err := Z_ERRNO; + break; + end; + end; + s^.stream.next_in := s^.inbuf; + end; + + s^.z_err := inflate(s^.stream, Z_NO_FLUSH); + + if (s^.z_err = Z_STREAM_END) then begin + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + { Check CRC and original size } + s^.crc := crc32(s^.crc, start, crclen); + start := s^.stream.next_out; + + filecrc := getLong (s); + filelen := getLong (s); + + if (s^.crc <> filecrc) or (s^.stream.total_out <> filelen) + then s^.z_err := Z_DATA_ERROR + else begin + { Check for concatenated .gz files: } + check_header(s); + if (s^.z_err = Z_OK) then begin + total_in := s^.stream.total_in; + total_out := s^.stream.total_out; + + inflateReset (s^.stream); + s^.stream.total_in := total_in; + s^.stream.total_out := total_out; + s^.crc := crc32 (0, nil, 0); + end; + end; {IF-THEN-ELSE} + end; + + if (s^.z_err <> Z_OK) or (s^.z_eof = true) then break; + + end; {WHILE} + + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + s^.crc := crc32 (s^.crc, start, crclen); + + gzread := integer(len - s^.stream.avail_out); + +end; + + +{ GZGETC ==================================================================== + + Reads one byte from the compressed file. + gzgetc returns this byte or -1 in case of end of file or error. + +============================================================================} + +function gzgetc (f:gzfile) : integer; + +var c:byte; + +begin + + if (gzread (f,@c,1) = 1) then gzgetc := c else gzgetc := -1; + +end; + + +{ GZGETS ==================================================================== + + Reads bytes from the compressed file until len-1 characters are read, + or a newline character is read and transferred to buf, or an end-of-file + condition is encountered. The string is then Null-terminated. + + gzgets returns buf, or nil in case of error. + The current implementation is not optimized at all. + +============================================================================} + +function gzgets (f:gzfile; buf:Pchar; len:integer) : Pchar; + +var + + b : Pchar; { start of buffer } + bytes : integer; { number of bytes read by gzread } + gzchar : char; { char read by gzread } + +begin + + if (buf = nil) or (len <= 0) then begin + gzgets := nil; + exit; + end; + + b := buf; + repeat + dec (len); + bytes := gzread (f, buf, 1); + gzchar := buf^; + inc (buf); + until (len = 0) or (bytes <> 1) or (gzchar = Chr(13)); + + buf^ := Chr(0); + if (b = buf) and (len > 0) then gzgets := nil else gzgets := b; + +end; + + +{$IFNDEF NO_DEFLATE} + +{ GZWRITE =================================================================== + + Writes the given number of uncompressed bytes into the compressed file. + gzwrite returns the number of uncompressed bytes actually written + (0 in case of error). + +============================================================================} + +function gzwrite (f:gzfile; buf:pointer; len:cardinal) : integer; + +var + + s : gz_streamp; + written : integer; + +begin + + s := gz_streamp(f); + + if (s = nil) or (s^.mode <> 'w') then begin + gzwrite := Z_STREAM_ERROR; + exit; + end; + + s^.stream.next_in := Pbyte(buf); + s^.stream.avail_in := len; + + while (s^.stream.avail_in <> 0) do begin + + if (s^.stream.avail_out = 0) then begin + s^.stream.next_out := s^.outbuf; + blockwrite (s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); + if (written <> Z_BUFSIZE) then begin + s^.z_err := Z_ERRNO; + break; + end; + s^.stream.avail_out := Z_BUFSIZE; + end; + + s^.z_err := deflate(s^.stream, Z_NO_FLUSH); + if (s^.z_err <> Z_OK) then break; + + end; {WHILE} + + s^.crc := crc32(s^.crc, buf, len); + gzwrite := integer(len - s^.stream.avail_in); + +end; + + +{ =========================================================================== + Converts, formats, and writes the args to the compressed file under + control of the format string, as in fprintf. gzprintf returns the number of + uncompressed bytes actually written (0 in case of error). +} + +{$IFDEF GZ_FORMAT_STRING} +function gzprintf (zfile : gzFile; + const format : string; + a : array of integer) : integer; +var + buf : array[0..Z_PRINTF_BUFSIZE-1] of char; + len : integer; +begin +{$ifdef HAS_snprintf} + snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$else} + sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$endif} + len := strlen(buf); { old sprintf doesn't return the nb of bytes written } + if (len <= 0) return 0; + + gzprintf := gzwrite(file, buf, len); +end; +{$ENDIF} + + +{ GZPUTC ==================================================================== + + Writes c, converted to an unsigned char, into the compressed file. + gzputc returns the value that was written, or -1 in case of error. + +============================================================================} + +function gzputc (f:gzfile; c:char) : integer; +begin + if (gzwrite (f,@c,1) = 1) then + {$IFDEF FPC} + gzputc := integer(ord(c)) + {$ELSE} + gzputc := integer(c) + {$ENDIF} + else + gzputc := -1; +end; + + +{ GZPUTS ==================================================================== + + Writes the given null-terminated string to the compressed file, excluding + the terminating null character. + gzputs returns the number of characters written, or -1 in case of error. + +============================================================================} + +function gzputs (f:gzfile; s:Pchar) : integer; +begin + gzputs := gzwrite (f, pointer(s), strlen(s)); +end; + + +{ DO_FLUSH ================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + +============================================================================} + +function do_flush (f:gzfile; flush:integer) : integer; +var + len : cardinal; + done : boolean; + s : gz_streamp; + written : integer; +begin + done := false; + s := gz_streamp(f); + + if (s = nil) or (s^.mode <> 'w') then begin + do_flush := Z_STREAM_ERROR; + exit; + end; + + s^.stream.avail_in := 0; { should be zero already anyway } + + while true do begin + + len := Z_BUFSIZE - s^.stream.avail_out; + + if (len <> 0) then begin + {$I-} + blockwrite(s^.gzfile, s^.outbuf^, len, written); + {$I+} + if (written <> len) then begin + s^.z_err := Z_ERRNO; + do_flush := Z_ERRNO; + exit; + end; + s^.stream.next_out := s^.outbuf; + s^.stream.avail_out := Z_BUFSIZE; + end; + + if (done = true) then break; + s^.z_err := deflate(s^.stream, flush); + + { Ignore the second of two consecutive flushes: } + if (len = 0) and (s^.z_err = Z_BUF_ERROR) then s^.z_err := Z_OK; + + { deflate has finished flushing only when it hasn't used up + all the available space in the output buffer: } + + done := (s^.stream.avail_out <> 0) or (s^.z_err = Z_STREAM_END); + if (s^.z_err <> Z_OK) and (s^.z_err <> Z_STREAM_END) then break; + + end; {WHILE} + + if (s^.z_err = Z_STREAM_END) then do_flush:=Z_OK else do_flush:=s^.z_err; +end; + +{ GZFLUSH =================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + + The return value is the zlib error number (see function gzerror below). + gzflush returns Z_OK if the flush parameter is Z_FINISH and all output + could be flushed. + + gzflush should be called only when strictly necessary because it can + degrade compression. + +============================================================================} + +function gzflush (f:gzfile; flush:integer) : integer; +var + err : integer; + s : gz_streamp; +begin + s := gz_streamp(f); + err := do_flush (f, flush); + + if (err <> 0) then begin + gzflush := err; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then gzflush := Z_OK else gzflush := s^.z_err; +end; + +{$ENDIF} (* NO DEFLATE *) + + +{ GZREWIND ================================================================== + + Rewinds input file. + +============================================================================} + +function gzrewind (f:gzFile) : integer; +var + s:gz_streamp; +begin + s := gz_streamp(f); + + if (s = nil) or (s^.mode <> 'r') then begin + gzrewind := -1; + exit; + end; + + s^.z_err := Z_OK; + s^.z_eof := false; + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + + if (s^.startpos = 0) then begin { not a compressed file } + {$I-} + seek (s^.gzfile, 0); + {$I+} + gzrewind := 0; + exit; + end; + + inflateReset(s^.stream); + {$I-} + seek (s^.gzfile, s^.startpos); + {$I+} + gzrewind := integer(IOResult); + exit; +end; + + +{ GZSEEK ==================================================================== + + Sets the starting position for the next gzread or gzwrite on the given + compressed file. The offset represents a number of bytes from the beginning + of the uncompressed stream. + + gzseek returns the resulting offset, or -1 in case of error. + SEEK_END is not implemented, returns error. + In this version of the library, gzseek can be extremely slow. + +============================================================================} + +function gzseek (f:gzfile; offset:z_off_t; whence:integer) : z_off_t; +var + s : gz_streamp; + size : cardinal; +begin + s := gz_streamp(f); + + if (s = nil) or (whence = SEEK_END) or (s^.z_err = Z_ERRNO) + or (s^.z_err = Z_DATA_ERROR) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzseek := z_off_t(-1); + exit; +{$ELSE} + if (whence = SEEK_SET) then dec(offset, s^.stream.total_out); + if (offset < 0) then begin; + gzseek := z_off_t(-1); + exit; + end; + + { At this point, offset is the number of zero bytes to write. } + if s^.inbuf=nil then begin + getmem(s^.inbuf,Z_BUFSIZE); + fillchar(s^.inbuf^,Z_BUFSIZE,0); + end; + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := cardinal(offset); + + size := gzwrite(f, s^.inbuf, size); + if (size = 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + dec (offset,size); + end; + + gzseek := z_off_t(s^.stream.total_in); + exit; +{$ENDIF} + end; + { Rest of function is for reading only } + + { compute absolute position } + if (whence = SEEK_CUR) then inc (offset, s^.stream.total_out); + if (offset < 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.transparent = true) then begin + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + {$I-} + seek (s^.gzfile, offset); + {$I+} + if (IOResult <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + s^.stream.total_in := cardinal(offset); + s^.stream.total_out := cardinal(offset); + gzseek := z_off_t(offset); + exit; + end; + + { For a negative seek, rewind and use positive seek } + if (cardinal(offset) >= s^.stream.total_out) + then dec (offset, s^.stream.total_out) + else if (gzrewind(f) <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + { offset is now the number of bytes to skip. } + + if (offset <> 0) and (s^.outbuf = nil) + then GetMem (s^.outbuf, Z_BUFSIZE); + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := integer(offset); + + size := gzread (f, s^.outbuf, size); + if (size <= 0) then begin + gzseek := z_off_t(-1); + exit; + end; + dec(offset, size); + end; + + gzseek := z_off_t(s^.stream.total_out); +end; + + +{ GZTELL ==================================================================== + + Returns the starting position for the next gzread or gzwrite on the + given compressed file. This position represents a number of bytes in the + uncompressed data stream. + +============================================================================} + +function gztell (f:gzfile) : z_off_t; +begin + gztell := gzseek (f, 0, SEEK_CUR); +end; + + +{ GZEOF ===================================================================== + + Returns TRUE when EOF has previously been detected reading the given + input stream, otherwise FALSE. + +============================================================================} + +function gzeof (f:gzfile) : boolean; +var + s:gz_streamp; +begin + s := gz_streamp(f); + + if (s=nil) or (s^.mode<>'r') then + gzeof := false + else + gzeof := s^.z_eof; +end; + + +{ PUTLONG =================================================================== + + Outputs a Longint in LSB order to the given file + +============================================================================} + +procedure putLong (var f:file; x:cardinal); +var + n : integer; + c : byte; +begin + for n:=0 to 3 do begin + c := x and $FF; + blockwrite (f, c, 1); + x := x shr 8; + end; +end; + + +{ GZCLOSE =================================================================== + + Flushes all pending output if necessary, closes the compressed file + and deallocates all the (de)compression state. + + The return value is the zlib error number (see function gzerror below). + +============================================================================} + +function gzclose (f:gzFile) : integer; +var + err : integer; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = nil) then begin + gzclose := Z_STREAM_ERROR; + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzclose := Z_STREAM_ERROR; + exit; +{$ELSE} + err := do_flush (f, Z_FINISH); + + if (err <> Z_OK) then begin + gzclose := zdestroy (gz_streamp(f)); + exit; + end; + putLong (s^.gzfile, s^.crc); + putLong (s^.gzfile, s^.stream.total_in); +{$ENDIF} + end; + gzclose := zdestroy (gz_streamp(f)); +end; + + +{ GZERROR =================================================================== + + Returns the error message for the last error which occured on the + given compressed file. errnum is set to zlib error number. If an + error occured in the file system and not in the compression library, + errnum is set to Z_ERRNO and the application may consult errno + to get the exact error code. + +============================================================================} + +function gzerror (f:gzfile; var errnum:smallint) : string; +var + m : string; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = nil) then begin + errnum := Z_STREAM_ERROR; + gzerror := zError(Z_STREAM_ERROR); + end; + + errnum := s^.z_err; + if (errnum = Z_OK) then begin + gzerror := zError(Z_OK); + exit; + end; + + m := s^.stream.msg; + if (errnum = Z_ERRNO) then m := ''; + if (m = '') then m := zError(s^.z_err); + + //s^.msg := s^.path+': '+m; + gzerror := 'GZ error';// s^.msg; +end; + +procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean);overload; +var + lTempName: string; + lFdata: file; +begin + (*if lOverwritewarn and fileexists(FFileDestination) then begin + case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + mrAbort: exit; + end; + end; //if overwrite *) + lTempName := changefileext(FFileDestination,'.tmp'); + assignfile(lFdata,lTempName ); + filemode := 2; + rewrite(lFdata,1); + BlockWrite(lFdata,lxInBuffer^,lInSize); + closefile(lFdata); + file_compress2 (lTempName,FFileDestination ); +end;//GZipBuffer + + +procedure GZipBuffer(var FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); overload; +var + len,lInPos : cardinal; + ioerr : integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + lensize : DWord; + outfile : gzFile; + mode,lDestName : string; +begin + if lInSize < 1 then + exit; + mode := 'w6 '; + if not GzExt(FFileDestination) then + lDestName := FFileDestination + '.gz' + else + lDestName := FFileDestination; + outfile := gzopen (lDestName, mode); + if (outfile = NIL) then begin + ShowMsg('unable to create '+lDestName); + exit; + end; + errorcode := 0; + lensize := 0; + lInPos := 1; + + while true do begin + len := (lInSize-lInPos)+1; + if len > Z_BUFSIZE then + len := Z_BUFSIZE; + if (len <= 0) then break; + Move(lxInBuffer^[lInPos],buf[0],len); + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + lInPos := lInPos + len; + end; + if (gzclose (outfile) <> 0) then errorcode := 3; + //gz_compress := errorcode; +end; // proc gz_compress + +function gz_uncompress (infile:gzFile; var outfile:file;fsize:DWord{LongWord}) : integer; +var + len : integer; + written : Integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + lensize : DWord{LongWord}; +begin + errorcode := 0; + //FProgress := 0; + lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + len := gzread (infile, @buf, Z_BUFSIZE); + if (len < 0) then begin + errorcode := 1; + break + end; + if (len = 0) + then break; + {$I-} + blockwrite (outfile, buf, len, written); + {$I+} + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (written <> len) then begin + {$WARNINGS ON} + errorcode := 2; + break + end; + (*if FProgressStep > 0 then begin + {$WARNINGS OFF} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end *) + end; {WHILE} + if (gzclose (infile) <> 0{Z_OK}) then begin + //if FWindowOnError then + // MessageDlg('gzclose Error.', mtError, [mbAbort], 0); + errorcode := 3 + end; + gz_uncompress := errorcode +end; + +function Gunzip (var FFileSource,FFileDestination: string): integer; +var + infile : gzFile; + outfile : file; + ioerr : integer; + errorcode : integer; + fsize : DWord{LongWord}; + s : gz_streamp; +begin + errorcode := 0; + ShowMsg('unGZip ' + extractfilename(FFileSource)); + infile := gzopen (FFileSource, 'r'); + if (infile = NIL) then begin + //if FWindowOnError then + // MessageDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0); + errorcode := 1 + end + else begin + s := gz_streamp(infile); + fsize := FileSize( s^.gzfile); + + AssignFile (outfile, FFileDestination); + {$I-} + Rewrite (outfile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + //if FWindowOnError then + // MessageDlg('Can''t create: '+FFileDestination, mtError, [mbAbort], 0); + errorcode := 2 + end + else begin + { We could open all files, so time for uncompressing } + gz_uncompress (infile, outfile, fsize); + //if FDeleteSource then DeleteFile(FFileSource); + {$I-} + close (outfile); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + //if FWindowOnError then + // MessageDlg('Can''t close file '+FFileDestination, mtError, [mbAbort], 0); + halt(1) + end + end + end; + + Gunzip := errorcode +end; + + +end. \ No newline at end of file diff --git a/common/gzio2.ppu b/common/gzio2.ppu new file mode 100644 index 0000000..c68a4d8 Binary files /dev/null and b/common/gzio2.ppu differ diff --git a/common/gziod.pas b/common/gziod.pas new file mode 100755 index 0000000..1e3effb --- /dev/null +++ b/common/gziod.pas @@ -0,0 +1,539 @@ +Unit gziod;//GZip input/output for delphi +interface + +uses define_types,gzio,Windows,sysutils; + +procedure UnGZip2 (var lFname: string; var lBuf: ByteP{}; lOffset,lMaxSz: integer; Skip: int64); //unzip +procedure UnGZip (var lFname: string; var lBuf: ByteP{}; lOffset,lMaxSz: integer); //unzip +procedure UnGZipCore (var infile : gzFile; var lBuf: ByteP; lReadBytes: integer; lWrite: boolean); +function Gunzip (var FFileSource,FFileDestination: string): integer; +procedure GZipBuffer(var lFilename: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +procedure GZipFile(lSrcName,lDestName: String;lDeleteSrc: boolean); +procedure UnGZipFile (var lFname,lOUtname: string); //unzip +implementation + +{$include isgui.inc} +{$IFDEF GUI}uses dialogs;{$ELSE} uses dialogsx;{$ENDIF} + +function gz_compressBuffer (lxInBuffer: ByteP;lInSize: integer;outfile:gzFile): integer; +var + len : Integer; + lInBufferPos,ioerr : integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + //lInBufPtr,lOutbufPtr: pointer; + errorcode : byte; + //fsize, lensize : DWord; +function blocktransfer(var lInBuffer: ByteP; lSizeRequested: integer; var lSizeTransferred:integer): integer; +begin + result := 0; + if lInBufferPos > lInSize then begin + result := 666; + exit; + end else if (lInBufferPos + lSizeRequested) <= lInSize then + lSizeTransferred := lSizeRequested + else + lSizeTransferred := lInSize-lInBufferPos; + //for lC := 1 to lSizeTransferred do + // buf[lC-1] := lInBuffer[lInBufferPos+lC] ; + move(lInbuffer[lInBufferPos+1],buf,lSizeTransferred); + //move(src,dest,count); + + lInBufferPos := lInBufferPos+lSizeTransferred; +end; +begin +//showmessage(inttostr(Z_BUFSIZE)); + lInBufferPos := 0; + errorcode := 0; + //Progress := 0; + //fsize := lInSize; + //lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + //lll{$I-}blockread (infile, buf, Z_BUFSIZE, len);{$I+} + ioerr := blocktransfer(lxInBuffer,Z_BUFSIZE, len); + if (ioerr <> 0) then begin + errorcode := 1; + break + end; + if (len = 0) then break; + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + end; {WHILE} + if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3; + result := errorcode; +end; + +procedure GZipBuffer(var lFilename: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +var + FFileDestination,FGzipComments ,outmode,s : string; + infile : file; + outfile : gzFile; + FCompressionLevel{,errorcode} : integer; + flags : uInt; + stream : gz_streamp; + p : PChar; +begin +FGzipComments := ''; +FFileDestination := lFilename; +//if not GzExt(FFileDestination) then +// FFileDestination := FFileDestination + '.gz'; +FCompressionLevel := 6;//MainForm.CompressEdit.value; +if (FCompressionLevel > 9) or (FCompressionLevel<0) then FCompressionLevel := 6; + if lOverwritewarn and fileexists(FFileDestination) then begin + {$IFDEF GUI} + case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + id_Abort: exit; + end; + {$ELSE} + case MsgDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + id_Abort: exit; + end; + + {$ENDIF} + end; + //w adds .gz extension-> outmode := 'w '; + outmode := 'w '; + s := IntToStr(FCompressionLevel); + outmode[2] := s[1]; + outmode[3] := ' '; + flags := ORIG_NAME; + //if (comment in FGzipHeader) then flags := flags + COMMENT_; + outfile := gzopenZ (FFileDestination, outmode, flags); + //showmessage(FFileDestination); + if (outfile = NIL) then begin + //if FWindowOnError then + {$IFDEF GUI} + MessageDlg('Can''t open: '+FFileDestination, mtError, [mbAbort], 0); + {$ELSE} + MsgDlg('Can''t open: '+FFileDestination, mtError, [mbAbort], 0); + {$ENDIF} + close( infile); + //errorcode := 2 + exit; + end + else begin + { if flags are set then write them } + stream := gz_streamp(outfile); + if {(zfilename in FGzipHeader)} true then begin + //s := ExtractFilename(lInFileName); + //s := ExtractFilename(FGzipFilename); + s := ExtractFilename(changefileext(FFileDestination,'')); + p := PChar(s); + blockWrite( stream^.gzfile, p[0], length(s)+1); + stream^.startpos := stream^.startpos + length(s) + 1 + end; + gz_compressBuffer (lxInBuffer,lInSize,outfile); + end +end; + +function gz_uncompress (infile:gzFile; var outfile:file;fsize:DWord{LongWord}) : integer; +var + len : integer; + written : uInt; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + lensize : DWord{LongWord}; +begin + errorcode := 0; + //FProgress := 0; + lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + len := gzread (infile, @buf, Z_BUFSIZE); + if (len < 0) then begin + errorcode := 1; + break + end; + if (len = 0) + then break; + {$I-} + blockwrite (outfile, buf, len, written); + {$I+} + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (written <> len) then begin + {$WARNINGS ON} + errorcode := 2; + break + end; + (*if FProgressStep > 0 then begin + {$WARNINGS OFF} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end *) + end; {WHILE} + if (gzclose (infile) <> 0{Z_OK}) then begin + {$IFDEF GUI} + MessageDlg('gzclose Error.', mtError, [mbAbort], 0); + {$ELSE} + MsgDlg('gzclose Error.', mtError, [mbAbort], 0); + {$ENDIF} + errorcode := 3 + end; + gz_uncompress := errorcode +end; + + +function Gunzip (var FFileSource,FFileDestination: string): integer; +var + infile : gzFile; + outfile : file; + ioerr : integer; + errorcode : integer; + fsize : DWord{LongWord}; + s : gz_streamp; +begin + errorcode := 0; + + infile := gzopenZ (FFileSource, 'r', 0); + if (infile = NIL) then begin + //if FWindowOnError then + {$IFDEF GUI} + MessageDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0); + {$ELSE} + MsgDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0); + {$ENDIF} + errorcode := 1 + end + else begin + s := gz_streamp(infile); + fsize := FileSize( s^.gzfile); + + AssignFile (outfile, FFileDestination); + {$I-} + Rewrite (outfile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + //if FWindowOnError then + {$IFDEF GUI} + MessageDlg('Can''t create: '+FFileDestination, mtError, [mbAbort], 0); + {$ELSE} + MsgDlg('Can''t create: '+FFileDestination, mtError, [mbAbort], 0); + {$ENDIF} + + errorcode := 2 + end + else begin + { We could open all files, so time for uncompressing } + gz_uncompress (infile, outfile, fsize); + //if FDeleteSource then DeleteFile(FFileSource); + {$I-} + close (outfile); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + //if FWindowOnError then + {$IFDEF GUI} + MessageDlg('Can''t close file '+FFileDestination, mtError, [mbAbort], 0); + {$ELSE} + MsgDlg('Can''t close file '+FFileDestination, mtError, [mbAbort], 0); + {$ENDIF} + + halt(1) + end + end + end; + + Gunzip := errorcode +end; + +procedure UnGZipCore (var infile : gzFile; var lBuf: ByteP; lReadBytes: integer; lWrite: boolean); +const + BUFLEN = 16384; +var + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } + len,lI,written : integer; +begin + written := 0; + if lReadBytes < 1 then exit; + Len := lReadBytes div BUFLEN; + if Len > 0 then + for lI := 1 to Len do begin + gzread (infile, @buf, BUFLEN {1388}); + if lWrite then + Move(buf,lbuf[Written+1],BUFLEN); + Written := Written + BUFLEN; + end; + Len := lReadBytes mod BUFLEN; + if Len = 0 then exit; + gzread (infile, @buf, Len); + if lWrite then + Move(buf,lbuf[Written+1],len); +end; //ungzipCore + +procedure UnGZip2 (var lFname: string; var lBuf: ByteP; lOffset,lMaxSz: integer; Skip: int64); +const +BUFLEN = 16384; +var + infile : gzFile; + lbufsz,len,lI : integer; + written : integer; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } +begin + infile := gzopenZskip (lFName, 'r', 0, Skip); + written := 0; + if lOffset > 0 then begin + Len := lOffset div BUFLEN; + if Len > 0 then + for lI := 1 to Len do + gzread (infile, @buf, BUFLEN {1388}); + Len := lOffset mod BUFLEN; + gzread (infile, @buf, Len); + end; + lbufsz := BUFLEN; + if lMaxSz < BUFLEN then + lbufsz := lMaxSz; + while true do begin + len := gzread (infile, @buf, lbufsz); + if (len < 0) then begin + break + end; + if (len = 0) + then break; + if (Written+len) > lMaxSz then begin + if Written < lMaxSz then + Move(buf,lbuf[Written+1],lMaxSz-Written); //cr2007 + break; + end; + Move(buf,lbuf[Written+1],len); + Written := Written + len; + end; {WHILE} + gzclose (infile); +end; + +procedure UnGZip (var lFname: string; var lBuf: ByteP; lOffset,lMaxSz: integer); +begin + UnGZip2 (lFname, lBuf, lOffset,lMaxSz,0); +end; +(*procedure UnGZip (var lFname: string; var lBuf: ByteP; lOffset,lMaxSz: integer); +const +BUFLEN = 16384; +var + infile : gzFile; + lbufsz,len,lI : integer; + written : integer; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } +begin + infile := gzopenZ (lFName, 'r', 0); + written := 0; + if lOffset > 0 then begin + Len := lOffset div BUFLEN; + if Len > 0 then + for lI := 1 to Len do + gzread (infile, @buf, BUFLEN {1388}); + Len := lOffset mod BUFLEN; + gzread (infile, @buf, Len); + end; + lbufsz := BUFLEN; + if lMaxSz < BUFLEN then + lbufsz := lMaxSz; + while true do begin + len := gzread (infile, @buf, lbufsz); + if (len < 0) then begin + break + end; + if (len = 0) + then break; + if (Written+len) > lMaxSz then begin + if Written < lMaxSz then + Move(buf,lbuf[Written+1],lMaxSz-Written); //cr2007 + break; + end; + Move(buf,lbuf[Written+1],len); + Written := Written + len; + end; {WHILE} + gzclose (infile); +end;*) + +procedure UnGZipFile (var lFname,lOUtname: string); //unzip +//1417z- offset +const +bufsz = 16384; +var + infile : gzFile; + len,lI : integer; + //written : integer; + lF: File; + buf : packed array [0..bufsz-1] of byte; { Global uses BSS instead of stack } +begin + infile := gzopenZ (lFName, 'r', 0); + //written := 0; + //lbufsz := BUFLEN; + Filemode := 1; + AssignFile(lF, lOUtname); + Rewrite(lF,1); + while true do begin + len := gzread (infile, @buf, bufsz); + if (len < 0) then begin + break + end; + if (len = 0) + then break; + BlockWrite(lF,buf, len); + //Move(buf,lbuf[Written+1],len); + //Written := Written + len; + end; {WHILE} + gzclose (infile); + CloseFile(lF); + Filemode := 2; //1366 +end; + + +function gz_compress (var infile:file; outfile:gzFile): integer; +var + len : uInt; + ioerr : integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + // fsize, lensize : DWord; +(*{$IFDEF VER100, VER90} + fsize, lensize : DWord; +{$ELSE} + fsize, lensize : LongWord; +{$ENDIF} *) +begin + errorcode := 0; + //Progress := 0; + //fsize := FileSize(infile); + //lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + {$I-} + blockread (infile, buf, Z_BUFSIZE, len); + {$I+} + + ioerr := IOResult; + if (ioerr <> 0) then begin + errorcode := 1; + break + end; + if (len = 0) then break; + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + (*if FProgressStep > 0 then begin + {$WARNINGS OFF}{Calculate progress and raise event} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end *) + end; {WHILE} + + closeFile (infile); + if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3; + + gz_compress := errorcode; +end; + + +procedure GZipFile(lSrcName,lDestName: String;lDeleteSrc: boolean); +var + //FGzipHeader : THeader; + //FCompressionLevel,FProgress,Progress: integer; + FGzipFilename : string; + FGzipComments : string; + outmode : string; + s : string; + infile : file; + outfile : gzFile; + FCompressionLevel{,errorcode} : integer; + flags : uInt; + stream : gz_streamp; + p : PChar; + //lProceed: TModalResult; + ioerr : integer; +begin +//FGzipHeader := [zFilename]; +FGzipFilename:= lSrcName; +FGzipComments := ''; +//FProgress := 0; +FCompressionLevel := 6; +if (FCompressionLevel > 9) or (FCompressionLevel<0) then FCompressionLevel := 6; +//MainForm.ProgressBar1.position :=1; +//Gzip (lFile,lMulti); + //FFileDestination := lSourceFile+'.gz'; + //result := 2; //return error if user aborts + if fileexists(lDestName) then begin + {$IFDEF GUI} + case MessageDlg('Overwrite the file '+lDestName+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + id_Abort: exit; + end; + {$ELSE} + case MsgDlg('Overwrite the file '+lDestName+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + id_Abort: exit; + end; + {$ENDIF} + end; + AssignFile (infile, lSrcName); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + //if FWindowOnError then + // MessageDlg('Can''t open: '+lSourceFile, mtError, [mbAbort], 0); + //errorcode := 1 + end + else begin + outmode := 'w '; + s := IntToStr(FCompressionLevel); + outmode[2] := s[1]; + outmode[3] := ' '; + (*case FCompressionType of + Standard : outmode[3] := ' '; + HuffmanOnly : outmode[3] := 'h'; + Filtered : outmode[3] := 'f'; + end;*) + + //flags := 0; + //if (zfilename in FGzipHeader) then + flags := ORIG_NAME; + //if (comment in FGzipHeader) then flags := flags + COMMENT_; + outfile := gzopenZ (lDestName, outmode, flags); + if (outfile = NIL) then begin + //if FWindowOnError then + // MessageDlg('Can''t open: '+FFileDestination, mtError, [mbAbort], 0); + close( infile); + //errorcode := 2 + exit; + end + else begin + { if flags are set then write them } + stream := gz_streamp(outfile); + if {(zfilename in FGzipHeader)} true then begin + s := ExtractFilename(lSrcName); + p := PChar(s); + blockWrite( stream^.gzfile, p[0], length(s)+1); + stream^.startpos := stream^.startpos + length(s) + 1 + end; + {if (zcomment in FGzipHeader) then begin + p := PChar(FGzipComments); + blockWrite( stream^.gzfile, p[0], length(FGzipComments)+1); + stream^.startpos := stream^.startpos + length(FGzipComments) + 1 + end; } + {errorcode :=} gz_compress(infile, outfile); + {if errorcode <> 0 then errorcode := errorcode+100 + else + if FDeleteSource then erase (infile);} + end + end; + if lDeleteSrc then erase (infile); +end; + +end. diff --git a/common/isgui.inc b/common/isgui.inc new file mode 100755 index 0000000..368e64d --- /dev/null +++ b/common/isgui.inc @@ -0,0 +1 @@ +{$DEFINE GUI} //use GUI if you are using a graphic user interface - anything else for console applications diff --git a/common/nifti_foreign.o b/common/nifti_foreign.o new file mode 100644 index 0000000..0b8cdc2 Binary files /dev/null and b/common/nifti_foreign.o differ diff --git a/common/nifti_foreign.pas b/common/nifti_foreign.pas new file mode 100755 index 0000000..584d2bd --- /dev/null +++ b/common/nifti_foreign.pas @@ -0,0 +1,1303 @@ +unit nifti_foreign; + +interface +{$H+} +{$Include isgui.inc} + +uses +{$IFNDEF FPC} + gziod, +{$ELSE} + gzio2, +{$ENDIF} +{$IFDEF GUI} + dialogs, +{$ELSE} + dialogsx, +{$ENDIF} + nifti_types, define_types, sysutils, classes, StrUtils;//2015! dialogsx + +function readForeignHeader (var lFilename: string; var lHdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +procedure NII_Clear (var lHdr: TNIFTIHdr); +procedure NII_SetIdentityMatrix (var lHdr: TNIFTIHdr); //create neutral rotation matrix + +implementation + +Type + mat44 = array [0..3, 0..3] of Single; + vect4 = array [0..3] of Single; + mat33 = array [0..2, 0..2] of Single; + vect3 = array [0..2] of Single; + ivect3 = array [0..2] of integer; + +{$IFDEF GUI} +procedure ShowMsg(s: string); +begin + Showmessage(s); +end; +{$ENDIF} + +procedure fromMatrix (m: mat44; var r11,r12,r13,r21,r22,r23,r31,r32,r33: double); +begin + r11 := m[0,0]; + r12 := m[0,1]; + r13 := m[0,2]; + r21 := m[1,0]; + r22 := m[1,1]; + r23 := m[1,2]; + r31 := m[2,0]; + r32 := m[2,1]; + r33 := m[2,2]; +end; + +function Matrix2D (r11,r12,r13,r21,r22,r23,r31,r32,r33: double): mat33; +begin + result[0,0] := r11; + result[0,1] := r12; + result[0,2] := r13; + result[1,0] := r21; + result[1,1] := r22; + result[1,2] := r23; + result[2,0] := r31; + result[2,1] := r32; + result[2,2] := r33; +end; + +function nifti_mat33_determ( R: mat33 ):double; //* determinant of 3x3 matrix */ +begin + result := r[0,0]*r[1,1]*r[2,2] + -r[0,0]*r[2,1]*r[1,2] + -r[1,0]*r[0,1]*r[2,2] + +r[1,0]*r[2,1]*r[0,2] + +r[2,0]*r[0,1]*r[1,2] + -r[2,0]*r[1,1]*r[0,2] ; +end; + +function nifti_mat33_rownorm( A: mat33 ): single; // max row norm of 3x3 matrix +var + r1,r2,r3: single ; +begin + r1 := abs(A[0,0])+abs(A[0,1])+abs(A[0,2]); + r2 := abs(A[1,0])+abs(A[1,1])+abs(A[1,2]); + r3 := abs(A[2,0])+abs(A[2,1])+abs(A[2,2]); + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +procedure fromMatrix33 (m: mat33; var r11,r12,r13,r21,r22,r23,r31,r32,r33: double); +begin + r11 := m[0,0]; + r12 := m[0,1]; + r13 := m[0,2]; + r21 := m[1,0]; + r22 := m[1,1]; + r23 := m[1,2]; + r31 := m[2,0]; + r32 := m[2,1]; + r33 := m[2,2]; +end; + +function nifti_mat33_inverse( R: mat33 ): mat33; //* inverse of 3x3 matrix */ +var + r11,r12,r13,r21,r22,r23,r31,r32,r33 , deti: double ; +begin + FromMatrix33(R,r11,r12,r13,r21,r22,r23,r31,r32,r33); + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + if( deti <> 0.0 ) then deti := 1.0 / deti ; + result[0,0] := deti*( r22*r33-r32*r23) ; + result[0,1] := deti*(-r12*r33+r32*r13) ; + result[0,2] := deti*( r12*r23-r22*r13) ; + result[1,0] := deti*(-r21*r33+r31*r23) ; + result[1,1] := deti*( r11*r33-r31*r13) ; + result[1,2] := deti*(-r11*r23+r21*r13) ; + result[2,0] := deti*( r21*r32-r31*r22) ; + result[2,1] := deti*(-r11*r32+r31*r12) ; + result[2,2] := deti*( r11*r22-r21*r12) ; +end; + +function nifti_mat33_colnorm( A: mat33 ): single; //* max column norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A[0,0])+abs(A[1,0])+abs(A[2,0]) ; + r2 := abs(A[0,1])+abs(A[1,1])+abs(A[2,1]) ; + r3 := abs(A[0,2])+abs(A[1,2])+abs(A[2,2]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_polar( A: mat33 ): mat33; +var + k:integer; + X , Y , Z: mat33 ; + dif,alp,bet,gam,gmi : single; +begin + dif := 1; + k := 0; + X := A ; + gam := nifti_mat33_determ(X) ; + while( gam = 0.0 )do begin //perturb matrix + gam := 0.00001 * ( 0.001 + nifti_mat33_rownorm(X) ) ; + X[0,0] := X[0,0]+gam ; + X[1,1] := X[1,1]+gam ; + X[2,2] := X[2,2] +gam ; + gam := nifti_mat33_determ(X) ; + end; + while true do begin + Y := nifti_mat33_inverse(X) ; + if( dif > 0.3 )then begin // far from convergence + alp := sqrt( nifti_mat33_rownorm(X) * nifti_mat33_colnorm(X) ) ; + bet := sqrt( nifti_mat33_rownorm(Y) * nifti_mat33_colnorm(Y) ) ; + gam := sqrt( bet / alp ) ; + gmi := 1.0 / gam ; + end else begin + gam := 1.0; + gmi := 1.0 ; //close to convergence + end; + Z[0,0] := 0.5 * ( gam*X[0,0] + gmi*Y[0,0] ) ; + Z[0,1] := 0.5 * ( gam*X[0,1] + gmi*Y[1,0] ) ; + Z[0,2] := 0.5 * ( gam*X[0,2] + gmi*Y[2,0] ) ; + Z[1,0] := 0.5 * ( gam*X[1,0] + gmi*Y[0,1] ) ; + Z[1,1] := 0.5 * ( gam*X[1,1] + gmi*Y[1,1] ) ; + Z[1,2] := 0.5 * ( gam*X[1,2] + gmi*Y[2,1] ) ; + Z[2,0] := 0.5 * ( gam*X[2,0] + gmi*Y[0,2] ) ; + Z[2,1] := 0.5 * ( gam*X[2,1] + gmi*Y[1,2] ) ; + Z[2,2] := 0.5 * ( gam*X[2,2] + gmi*Y[2,2] ) ; + dif := abs(Z[0,0]-X[0,0])+abs(Z[0,1]-X[0,1])+abs(Z[0,2]-X[0,2]) + +abs(Z[1,0]-X[1,0])+abs(Z[1,1]-X[1,1])+abs(Z[1,2]-X[1,2]) + +abs(Z[2,0]-X[2,0])+abs(Z[2,1]-X[2,1])+abs(Z[2,2]-X[2,2]); + k := k+1 ; + if( k > 100) or (dif < 3.e-6 ) then begin + result := Z; + break ; //convergence or exhaustion + end; + X := Z ; + end; + result := Z ; +end; + +procedure nifti_mat44_to_quatern( lR :mat44; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd , a,b,c,d : double; + P,Q: mat33; //3x3 +begin + // offset outputs are read write out of input matrix + qx := lR[0,3]; + qy := lR[1,3]; + qz := lR[2,3]; + //load 3x3 matrix into local variables + fromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + //compute lengths of each column; these determine grid spacings + xd := sqrt( r11*r11 + r21*r21 + r31*r31 ) ; + yd := sqrt( r12*r12 + r22*r22 + r32*r32 ) ; + zd := sqrt( r13*r13 + r23*r23 + r33*r33 ) ; + //if a column length is zero, patch the trouble + if( xd = 0.0 )then begin r11 := 1.0 ; r21 := 0; r31 := 0.0 ; xd := 1.0 ; end; + if( yd = 0.0 )then begin r22 := 1.0 ; r12 := 0; r32 := 0.0 ; yd := 1.0 ; end; + if( zd = 0.0 )then begin r33 := 1.0 ; r13 := 0; r23 := 0.0 ; zd := 1.0 ; end; + //assign the output lengths + dx := xd; + dy := yd; + dz := zd; + //normalize the columns + r11 := r11/xd ; r21 := r21/xd ; r31 := r31/xd ; + r12 := r12/yd ; r22 := r22/yd ; r32 := r32/yd ; + r13 := r13/zd ; r23 := r23/zd ; r33 := r33/zd ; + { At this point, the matrix has normal columns, but we have to allow + for the fact that the hideous user may not have given us a matrix + with orthogonal columns. So, now find the orthogonal matrix closest + to the current matrix. + One reason for using the polar decomposition to get this + orthogonal matrix, rather than just directly orthogonalizing + the columns, is so that inputting the inverse matrix to R + will result in the inverse orthogonal matrix at this point. + If we just orthogonalized the columns, this wouldn't necessarily hold.} + Q := Matrix2D (r11,r12,r13, // 2D "graphics" matrix + r21,r22,r23, + r31,r32,r33); + P := nifti_mat33_polar(Q) ; //P is orthog matrix closest to Q + FromMatrix33(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); +{ [ r11 r12 r13 ] + at this point, the matrix [ r21 r22 r23 ] is orthogonal + [ r31 r32 r33 ] + compute the determinant to determine if it is proper} + + zd := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; //should be -1 or 1 + + if( zd > 0 )then begin // proper + qfac := 1.0 ; + end else begin //improper ==> flip 3rd column + qfac := -1.0 ; + r13 := -r13 ; r23 := -r23 ; r33 := -r33 ; + end; + // now, compute quaternion parameters + a := r11 + r22 + r33 + 1.0; + if( a > 0.5 ) then begin //simplest case + a := 0.5 * sqrt(a) ; + b := 0.25 * (r32-r23) / a ; + c := 0.25 * (r13-r31) / a ; + d := 0.25 * (r21-r12) / a ; + end else begin //trickier case + xd := 1.0 + r11 - (r22+r33) ;// 4*b*b + yd := 1.0 + r22 - (r11+r33) ;// 4*c*c + zd := 1.0 + r33 - (r11+r22) ;// 4*d*d + if( xd > 1.0 ) then begin + b := 0.5 * sqrt(xd) ; + c := 0.25* (r12+r21) / b ; + d := 0.25* (r13+r31) / b ; + a := 0.25* (r32-r23) / b ; + end else if( yd > 1.0 ) then begin + c := 0.5 * sqrt(yd) ; + b := 0.25* (r12+r21) / c ; + d := 0.25* (r23+r32) / c ; + a := 0.25* (r13-r31) / c ; + end else begin + d := 0.5 * sqrt(zd) ; + b := 0.25* (r13+r31) / d ; + c := 0.25* (r23+r32) / d ; + a := 0.25* (r21-r12) / d ; + end; + if( a < 0.0 )then begin b:=-b ; c:=-c ; d:=-d; {a:=-a; this is not used} end; + end; + qb := b ; + qc := c ; + qd := d ; +end; + + +procedure NII_SetIdentityMatrix (var lHdr: TNIFTIHdr); //create neutral rotation matrix +var lInc: integer; +begin + with lHdr do begin + for lInc := 0 to 3 do + srow_x[lInc] := 0; + for lInc := 0 to 3 do + srow_y[lInc] := 0; + for lInc := 0 to 3 do + srow_z[lInc] := 0; + for lInc := 1 to 16 do + intent_name[lInc] := chr(0); + //next: create identity matrix: if code is switched on there will not be a problem + srow_x[0] := 1; + srow_y[1] := 1; + srow_z[2] := 1; + end; +end; //proc NIFTIhdr_IdentityMatrix + +procedure NII_Clear (var lHdr: TNIFTIHdr); +var + lInc: integer; +begin + with lHdr do begin + HdrSz := sizeof(TNIFTIhdr); + for lInc := 1 to 10 do + Data_Type[lInc] := chr(0); + for lInc := 1 to 18 do + db_name[lInc] := chr(0); + extents:=0; + session_error:= 0; + regular:='r'{chr(0)}; + dim_info:=(0); + dim[0] := 4; + for lInc := 1 to 7 do + dim[lInc] := 0; + intent_p1 := 0; + intent_p2 := 0; + intent_p3 := 0; + intent_code:=0; + datatype:=0 ; + bitpix:=0; + slice_start:=0; + for lInc := 1 to 7 do + pixdim[linc]:= 1.0; + vox_offset:= 0.0; + scl_slope := 1.0; + scl_inter:= 0.0; + slice_end:= 0; + slice_code := 0; + xyzt_units := 10; + cal_max:= 0.0; + cal_min:= 0.0; + slice_duration:=0; + toffset:= 0; + glmax:= 0; + glmin:= 0; + for lInc := 1 to 80 do + descrip[lInc] := chr(0);{80 spaces} + for lInc := 1 to 24 do + aux_file[lInc] := chr(0);{80 spaces} + {below are standard settings which are not 0} + bitpix := 16;//vc16; {8bits per pixel, e.g. unsigned char 136} + DataType := 4;//vc4;{2=unsigned char, 4=16bit int 136} + Dim[0] := 3; + Dim[1] := 256; + Dim[2] := 256; + Dim[3] := 128; + Dim[4] := 1; {n vols} + Dim[5] := 1; + Dim[6] := 1; + Dim[7] := 1; + glMin := 0; + glMax := 255; + qform_code := kNIFTI_XFORM_UNKNOWN; + sform_code:= kNIFTI_XFORM_UNKNOWN; + quatern_b := 0; + quatern_c := 0; + quatern_d := 0; + qoffset_x := 0; + qoffset_y := 0; + qoffset_z := 0; + NII_SetIdentityMatrix(lHdr); + magic := kNIFTI_MAGIC_SEPARATE_HDR; + end; //with the NIfTI header... +end; + + +procedure ZERO_MAT44(var m: mat44); //note sets m[3,3] to one +var + i,j: integer; +begin + for i := 0 to 3 do + for j := 0 to 3 do + m[i,j] := 0.0; + m[3,3] := 1; +end; + +procedure LOAD_MAT33(var m: mat33; m00,m01,m02, m10,m11,m12, m20,m21,m22: single); +begin + m[0,0] := m00; + m[0,1] := m01; + m[0,2] := m02; + m[1,0] := m10; + m[1,1] := m11; + m[1,2] := m12; + m[2,0] := m20; + m[2,1] := m21; + m[2,2] := m22; +end; + +function nifti_mat33_mul( A,B: mat33): mat33; +var + i,j: integer; +begin + for i:=0 to 3 do + for j:=0 to 3 do + result[i,j] := A[i,0] * B[0,j] + + A[i,1] * B[1,j] + + A[i,2] * B[2,j] ; +end; + + +procedure LOAD_MAT44(var m: mat44; m00,m01,m02,m03, m10,m11,m12,m13, m20,m21,m22,m23: single); +begin + m[0,0] := m00; + m[0,1] := m01; + m[0,2] := m02; + m[0,3] := m03; + m[1,0] := m10; + m[1,1] := m11; + m[1,2] := m12; + m[1,3] := m13; + m[2,0] := m20; + m[2,1] := m21; + m[2,2] := m22; + m[2,3] := m23; + m[3,0] := 0.0; + m[3,1] := 0.0; + m[3,2] := 0.0; + m[3,3] := 1.0; +end; + +function validMatrix(var m: mat44): boolean; +var + i: integer; +begin + result := false; + for i := 0 to 2 do begin + if (m[0,i] = 0.0) and (m[1,i] = 0.0) and (m[2,i] = 0.0) then exit; + if (m[i,0] = 0.0) and (m[i,1] = 0.0) and (m[i,2] = 0.0) then exit; + end; + result := true; +end; + +procedure convertForeignToNifti(var nhdr: TNIFTIhdr); +var + i,nonSpatialMult: integer; + qto_xyz: mat44; + //dumqx, dumqy, dumqz, + dumdx, dumdy, dumdz: single; +begin + nhdr.HdrSz := 348; //used to signify header does not need to be byte-swapped + nhdr.magic:=kNIFTI_MAGIC_EMBEDDED_HDR; + if (nhdr.dim[3] = 0) then nhdr.dim[3] := 1; //for 2D images the 3rd dim is not specified and set to zero + nhdr.dim[0] := 3; //for 2D images the 3rd dim is not specified and set to zero + nonSpatialMult := 1; + for i := 4 to 7 do + if nhdr.dim[i] > 0 then + nonSpatialMult := nonSpatialMult * nhdr.dim[i]; + if (nonSpatialMult > 1) then begin + nhdr.dim[0] := 4; + nhdr.dim[4] := nonSpatialMult; + for i := 5 to 7 do + nhdr.dim[i] := 0; + end; + nhdr.bitpix := 8; + if (nhdr.datatype = 4) or (nhdr.datatype = 512) then nhdr.bitpix := 16; + if (nhdr.datatype = 8) or (nhdr.datatype = 16) or (nhdr.datatype = 768) then nhdr.bitpix := 32; + if (nhdr.datatype = 32) or (nhdr.datatype = 64) or (nhdr.datatype = 1024) or (nhdr.datatype = 1280) then nhdr.bitpix := 64; + LOAD_MAT44(qto_xyz, nhdr.srow_x[0], nhdr.srow_x[1], nhdr.srow_x[2], nhdr.srow_x[3], + nhdr.srow_y[0], nhdr.srow_y[1], nhdr.srow_y[2], nhdr.srow_y[3], + nhdr.srow_z[0], nhdr.srow_z[1], nhdr.srow_z[2], nhdr.srow_z[3]); + if not validMatrix(qto_xyz) then begin + nhdr.sform_code := 0; + nhdr.qform_code := 0; + for i := 0 to 3 do begin + nhdr.srow_x[i] := 0; + nhdr.srow_y[i] := 0; + nhdr.srow_z[i] := 0; + end; + nhdr.srow_x[0] := 1; + nhdr.srow_y[1] := 1; + nhdr.srow_z[2] := 1; + exit; + end; + nhdr.sform_code := 1; + nifti_mat44_to_quatern( qto_xyz , nhdr.quatern_b, nhdr.quatern_c, nhdr.quatern_d,nhdr.qoffset_x,nhdr.qoffset_y,nhdr.qoffset_z, dumdx, dumdy, dumdz,nhdr.pixdim[0]) ; + nhdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; +end; + +procedure NSLog( str: string); +begin + showmsg(str); +end; + +function readMGHHeader (var fname: string; var nhdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +Type + Tmgh = packed record //Next: analyze Format Header structure + version, width,height,depth,nframes,mtype,dof : longint; + goodRASFlag: smallint; + spacingX,spacingY,spacingZ,xr,xa,xs,yr,ya,ys,zr,za,zs,cr,ca,cs: single; + end; +var + mgh: Tmgh; + lBuff: Bytep; + lExt: string; + lHdrFile: file; + PxyzOffset, Pcrs: vect4; + i,j: integer; + base: single; + m: mat44; +begin + result := false; + lExt := UpCaseExt(fname); + if (lExt = '.MGZ') then begin + lBuff := @mgh; + UnGZip(fname,lBuff,0,sizeof(Tmgh)); //1388 + gzBytes := K_gzBytes_headerAndImageCompressed; + end else begin //if MGZ, else assume uncompressed MGH + gzBytes := 0; + {$I-} + AssignFile(lHdrFile, fname); + FileMode := 0; //Set file access to read only + Reset(lHdrFile, 1); + {$I+} + if ioresult <> 0 then begin + NSLog('Error in reading NIFTI header.'+inttostr(IOResult)); + FileMode := 2; + exit; + end; + BlockRead(lHdrFile, mgh, sizeof(Tmgh)); + CloseFile(lHdrFile); + end; + {$IFDEF ENDIAN_BIG} //data always stored big endian + swapEndian := false; + {$ELSE} + swapEndian := true; + swap4(mgh.version); + swap4(mgh.width); + swap4(mgh.height); + swap4(mgh.depth); + swap4(mgh.nframes); + swap4(mgh.mtype); + swap4(mgh.dof); + mgh.goodRASFlag := swap(mgh.goodRASFlag); + Xswap4r(mgh.spacingX); + Xswap4r(mgh.spacingY); + Xswap4r(mgh.spacingZ); + Xswap4r(mgh.xr); + Xswap4r(mgh.xa); + Xswap4r(mgh.xs); + Xswap4r(mgh.yr); + Xswap4r(mgh.ya); + Xswap4r(mgh.ys); + Xswap4r(mgh.zr); + Xswap4r(mgh.za); + Xswap4r(mgh.zs); + Xswap4r(mgh.cr); + Xswap4r(mgh.ca); + Xswap4r(mgh.cs); + {$ENDIF} + if ((mgh.version <> 1) or (mgh.mtype < 0) or (mgh.mtype > 4)) then begin + NSLog('Error: first value in a MGH header should be 1 and data type should be in the range 1..4.'); + exit; + end; + if (mgh.mtype = 0) then + nhdr.datatype := kDT_UINT8 + else if (mgh.mtype = 4) then + nhdr.datatype := kDT_INT16 + else if (mgh.mtype = 1) then + nhdr.datatype := kDT_INT32 + else if (mgh.mtype = 3) then + nhdr.datatype := kDT_FLOAT32; + nhdr.dim[1]:=mgh.width; + nhdr.dim[2]:=mgh.height; + nhdr.dim[3]:=mgh.depth; + nhdr.dim[4]:=mgh.nframes; + nhdr.pixdim[1]:=mgh.spacingX; + nhdr.pixdim[2]:=mgh.spacingY; + nhdr.pixdim[3]:=mgh.spacingZ; + nhdr.vox_offset := 284; + nhdr.sform_code := 1; + //convert MGH to NIfTI transform see Bruce Fischl mri.c MRIxfmCRS2XYZ https://github.com/neurodebian/freesurfer/blob/master/utils/mri.c + LOAD_MAT44(m,mgh.xr*nhdr.pixdim[1],mgh.yr*nhdr.pixdim[2],mgh.zr*nhdr.pixdim[3],0, + mgh.xa*nhdr.pixdim[1],mgh.ya*nhdr.pixdim[2],mgh.za*nhdr.pixdim[3],0, + mgh.xs*nhdr.pixdim[1],mgh.ys*nhdr.pixdim[2],mgh.zs*nhdr.pixdim[3],0); + base := 0.0; //0 or 1: are voxels indexed from 0 or 1? + Pcrs[0] := (nhdr.dim[1]/2.0)+base; + Pcrs[1] := (nhdr.dim[2]/2.0)+base; + Pcrs[2] := (nhdr.dim[3]/2.0)+base; + Pcrs[3] := 1; + for i:=0 to 3 do begin //multiply Pcrs * m + PxyzOffset[i] := 0; + for j := 0 to 3 do + PxyzOffset[i] := PxyzOffset[i]+ (m[i,j]*Pcrs[j]); + end; + nhdr.srow_x[0]:=m[0,0]; nhdr.srow_x[1]:=m[0,1]; nhdr.srow_x[2]:=m[0,2]; nhdr.srow_x[3]:=mgh.cr - PxyzOffset[0]; + nhdr.srow_y[0]:=m[1,0]; nhdr.srow_y[1]:=m[1,1]; nhdr.srow_y[2]:=m[1,2]; nhdr.srow_y[3]:=mgh.ca - PxyzOffset[1]; + nhdr.srow_z[0]:=m[2,0]; nhdr.srow_z[1]:=m[2,1]; nhdr.srow_z[2]:=m[2,2]; nhdr.srow_z[3]:=mgh.cs - PxyzOffset[2]; + convertForeignToNifti(nhdr); + result := true; +end; + +procedure splitStr(delimiter: char; str: string; mArray: TStrings); +begin + mArray.Clear; + mArray.Delimiter := delimiter; + mArray.DelimitedText := str; +end; + +procedure splitStrStrict(delimiter: char; S: string; sl: TStrings); +begin + sl.Clear; + sl.Delimiter := delimiter; + sl.DelimitedText := '"' + StringReplace(S, sl.Delimiter, '"' + sl.Delimiter + '"', [rfReplaceAll]) + '"'; +end; + +function cleanStr (S:string): string; // "(12.31)" ->"12.31" +begin + result := StringReplace(S, '(', '', [rfReplaceAll]); + result := StringReplace(result, ')', '', [rfReplaceAll]); +end; + +(*function FSize (lFName: String): Int64; +var SearchRec: TSearchRec; +begin + result := 0; + if not fileexistsex(lFName) then exit; + FindFirst(lFName, faAnyFile, SearchRec); + result := SearchRec.size; + FindClose(SearchRec); +end; *) + +(*procedure report_mat(m: mat33); +begin + showmsg('mat = ['+floattostr(m[0,0])+' ' +floattostr(m[0,1]) +' ' +floattostr(m[0,2]) +'; ' + +floattostr(m[1,0])+' ' +floattostr(m[1,1]) +' ' +floattostr(m[1,2]) +'; ' + +floattostr(m[2,0])+' ' +floattostr(m[2,1]) +' ' +floattostr(m[2,2]) +'] '); +end;*) + +function readMHAHeader (var fname: string; var nhdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +//Read VTK "MetaIO" format image +//http://www.itk.org/Wiki/ITK/MetaIO/Documentation#Reading_a_Brick-of-Bytes_.28an_N-Dimensional_volume_in_a_single_file.29 +//https://www.assembla.com/spaces/plus/wiki/Sequence_metafile_format +//http://itk-insight-users.2283740.n2.nabble.com/MHA-MHD-File-Format-td7585031.html +var + FP: TextFile; + str, tagName, elementNames: string; + ch: char; + isLocal,compressedData: boolean; + matOrient, mat, d, t: mat33; + nPosition, nOffset, matElements, matElementsOrient, compressedDataSize, headerSize, nItems, nBytes, i, channels, fileposBytes: longint; + offset,position, elementSize: array [0..3] of single; + transformMatrix: array [0..11] of single; + mArray: TStringList; +begin + result := false; + if not FileExistsEX(fname) then exit; + {$IFDEF FPC} + DefaultFormatSettings.DecimalSeparator := '.' ; + // DecimalSeparator := '.'; + {$ELSE} + DecimalSeparator := '.'; + {$ENDIF} + for i := 0 to 3 do begin + position[i] := 0; + offset[i] := 0; + elementSize[i] := 1; + end; + nPosition := 0; + nOffset := 0; + gzBytes := 0; + fileposBytes := 0; + compressedDataSize := 0; + swapEndian := false; + isLocal := true; //image and header embedded in same file, if false detached image + headerSize := 0; + matElements := 0; + matElementsOrient := 0; + compressedData := false; + mArray := TStringList.Create; + Filemode := fmOpenRead; + AssignFile(fp,fname); + reset(fp); + while not EOF(fp) do begin + str := ''; + while not EOF(fp) do begin + read(fp,ch); + inc(fileposBytes); + if (ch = chr($0D)) or (ch = chr($0A)) then break; + str := str+ch; + end; + if (length(str) < 1) or (str[1]='#') then continue; + splitstrStrict('=',str,mArray); + if (mArray.count < 2) then continue; + tagName := cleanStr(mArray[0]); + elementNames := mArray[1]; + splitstr(',',elementNames,mArray); + nItems :=mArray.count; + if (nItems < 1) then continue; + for i := 0 to (nItems-1) do + mArray[i] := cleanStr(mArray[i]); //remove '(' and ')', + if AnsiContainsText(tagName, 'ObjectType') and (not AnsiContainsText(mArray.Strings[0], 'Image')) then begin + NSLog('Expecting file with tag "ObjectType = Image" instead of "ObjectType = '+mArray.Strings[0]+'"'); + + end {else if AnsiContainsText(tagName, 'NDims') then begin + nDims := strtoint(mArray[0]); + if (nDims > 4) then begin + NSLog('Warning: only reading first 4 dimensions'); + nDims := 4; + end; + end} else if AnsiContainsText(tagName, 'BinaryDataByteOrderMSB') then begin + {$IFDEF ENDIAN_BIG} //data always stored big endian + if not AnsiContainsText(mArray[0], 'True') then swapEndian := true; + {$ELSE} + if AnsiContainsText(mArray[0], 'True') then swapEndian := true; + {$ENDIF} + end {else if AnsiContainsText(tagName, 'BinaryData') then begin + if AnsiContainsText(mArray[0], 'True') then binaryData := true; + end else if AnsiContainsText(tagName, 'CompressedDataSize') then begin + compressedDataSize := strtoint(mArray[0]); + end} else if AnsiContainsText(tagName, 'CompressedData') then begin + if AnsiContainsText(mArray[0], 'True') then + compressedData := true; + end else if AnsiContainsText(tagName, 'Orientation') and (not AnsiContainsText(tagName, 'Anatomical') ) then begin + if (nItems > 12) then nItems := 12; + matElementsOrient := nItems; + for i := 0 to (nItems-1) do + transformMatrix[i] := strtofloat(mArray[i]); + + + if (matElementsOrient >= 12) then + LOAD_MAT33(matOrient, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[4],transformMatrix[5],transformMatrix[6], + transformMatrix[8],transformMatrix[9],transformMatrix[10]) + else if (matElementsOrient >= 9) then + LOAD_MAT33(matOrient, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[3],transformMatrix[4],transformMatrix[5], + transformMatrix[6],transformMatrix[7],transformMatrix[8]); + + end else if AnsiContainsText(tagName, 'TransformMatrix') then begin + if (nItems > 12) then nItems := 12; + matElements := nItems; + for i := 0 to (nItems-1) do + transformMatrix[i] := strtofloat(mArray[i]); + if (matElements >= 12) then + LOAD_MAT33(mat, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[4],transformMatrix[5],transformMatrix[6], + transformMatrix[8],transformMatrix[9],transformMatrix[10]) + else if (matElements >= 9) then + LOAD_MAT33(mat, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[3],transformMatrix[4],transformMatrix[5], + transformMatrix[6],transformMatrix[7],transformMatrix[8]); + end else if AnsiContainsText(tagName, 'Position') then begin + if (nItems > 3) then nItems := 3; + nPosition := nItems; + for i := 0 to (nItems-1) do + position[i] := strtofloat(mArray[i]); + end else if AnsiContainsText(tagName, 'Offset') then begin + if (nItems > 3) then nItems := 3; + nOffset := nItems; + for i := 0 to (nItems-1) do + offset[i] := strtofloat(mArray[i]); + end else if AnsiContainsText(tagName, 'AnatomicalOrientation') then begin + //e.g. RAI + end else if AnsiContainsText(tagName, 'ElementSpacing') then begin + if (nItems > 4) then nItems := 4; + for i := 0 to (nItems-1) do + nhdr.pixdim[i+1] := strtofloat(mArray[i]); + end else if AnsiContainsText(tagName, 'DimSize') then begin + if (nItems > 4) then nItems := 4; + for i := 0 to (nItems-1) do + nhdr.dim[i+1] := strtoint(mArray[i]); + end else if AnsiContainsText(tagName, 'HeaderSize') then begin + headerSize := strtoint(mArray[0]); + end else if AnsiContainsText(tagName, 'ElementSize') then begin + if (nItems > 4) then nItems := 4; + for i := 0 to (nItems-1) do + elementSize[i] := strtofloat(mArray[i]); + end else if AnsiContainsText(tagName, 'ElementNumberOfChannels') then begin + channels := strtoint(mArray[0]); + if (channels > 1) then NSLog('Unable to read MHA/MHD files with multiple channels '); + end else if AnsiContainsText(tagName, 'ElementByteOrderMSB') then begin + {$IFDEF ENDIAN_BIG} //data always stored big endian + if not AnsiContainsText(mArray[0], 'True') then swapEndian := true; + {$ELSE} + if AnsiContainsText(mArray[0], 'True') then swapEndian := true; + {$ENDIF} + end else if AnsiContainsText(tagName, 'ElementType') then begin + + //convert metaImage format to NIfTI http://portal.nersc.gov/svn/visit/tags/2.2.1/vendor_branches/vtk/src/IO/vtkMetaImageWriter.cxx + //set NIfTI datatype http://nifti.nimh.nih.gov/pub/dist/src/niftilib/nifti1.h + if AnsiContainsText(mArray[0], 'MET_UCHAR') then + nhdr.datatype := kDT_UINT8 // + else if AnsiContainsText(mArray[0], 'MET_CHAR') then + nhdr.dataType := kDT_INT8 // + else if AnsiContainsText(mArray[0], 'MET_SHORT') then + nhdr.dataType := kDT_INT16 // + else if AnsiContainsText(mArray[0], 'MET_USHORT') then + nhdr.dataType := kDT_UINT16 // + else if AnsiContainsText(mArray[0], 'MET_INT') then + nhdr.dataType := kDT_INT32 //DT_INT32 + else if AnsiContainsText(mArray[0], 'MET_UINT') then + nhdr.dataType := kDT_UINT32 //DT_UINT32 + else if AnsiContainsText(mArray[0], 'MET_ULONG') then + nhdr.dataType := kDT_UINT64 //DT_UINT64 + else if AnsiContainsText(mArray[0], 'MET_LONG') then + nhdr.dataType := kDT_INT64 //DT_INT64 + else if AnsiContainsText(mArray[0], 'MET_FLOAT') then + nhdr.dataType := kDT_FLOAT32 //DT_FLOAT32 + else if AnsiContainsText(mArray[0], 'MET_DOUBLE') then + nhdr.dataType := kDT_DOUBLE; //DT_FLOAT64 + end else if AnsiContainsText(tagName, 'ElementDataFile') then begin + if not AnsiContainsText(mArray[0], 'local') then begin + str := mArray.Strings[0]; + if fileexistsex(str) then + fname := str + else begin + fname := ExtractFileDirWithPathDelim(fname)+str; + end; + isLocal := false; + end; + break; + end; + end; //while reading + if (headerSize = 0) and (isLocal) then headerSize :=fileposBytes; //!CRAP 2015 + nhdr.vox_offset := headerSize; + CloseFile(FP); + Filemode := 2; + mArray.free; + //convert transform + if (matElements >= 9) or (matElementsOrient >= 9) then begin + //report_Mat(matOrient); + LOAD_MAT33(d, nhdr.pixdim[1],0,0, + 0, nhdr.pixdim[2],0, + 0,0, nhdr.pixdim[3]); + if (matElements >= 9) then + t := nifti_mat33_mul( d, mat) + else + t := nifti_mat33_mul( d, matOrient) ; + if nPosition > nOffset then begin + offset[0] := position[0]; + offset[1] := position[1]; + offset[2] := position[2]; + + end; + nhdr.srow_x[0] := -t[0,0]; + nhdr.srow_x[1] := -t[1,0]; + nhdr.srow_x[2] := -t[2,0]; + nhdr.srow_x[3] := -offset[0]; + nhdr.srow_y[0] := -t[0,1]; + nhdr.srow_y[1] := -t[1,1]; + nhdr.srow_y[2] := -t[2,1]; + nhdr.srow_y[3] := -offset[1]; + nhdr.srow_z[0] := t[0,2]; + nhdr.srow_z[1] := t[1,2]; + nhdr.srow_z[2] := t[2,2]; + nhdr.srow_z[3] := offset[2]; + end else begin + //NSLog('Warning: unable to determine image orientation (unable to decode metaIO "TransformMatrix" tag)')}; + nhdr.sform_code:=0; + nhdr.srow_x[0] := 0; + nhdr.srow_x[1] := 0; + nhdr.srow_x[2] := 0; + end; + //end transform + convertForeignToNifti(nhdr); + if (compressedData) then + gzBytes := K_gzBytes_onlyImageCompressed; + if (nhdr.vox_offset < 0) then begin + nBytes := (nhdr.bitpix div 8); + for i := 1 to 7 do begin + if nhdr.dim[i] > 0 then + nBytes := nBytes * nhdr.dim[i]; + end; + nhdr.vox_offset := FSize(fname) - nBytes; + if (nhdr.vox_offset < 0) then nhdr.vox_offset := -1; + end; + result := true; +end;//MHA + +Function StrToFloatSafe(Const S : String) : single; +begin + try + result := strtofloat(S); + except on EConvertError do + result := 1/0 + end;//except +end; + +function readNRRDHeader (var fname: string; var nhdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +//http://www.sci.utah.edu/~gk/DTI-data/ +//http://teem.sourceforge.net/nrrd/format.html +label + 666; +var + FP: TextFile; + ch: char; + mArray: TStringList; + str,tagName,elementNames: string; + i,j,s,nItems,headerSize,matElements,fileposBytes: integer; + mat: mat33; + isDetachedFile,isFirstLine: boolean; + offset: array[0..3] of single; + vSqr: single; + transformMatrix: array [0..11] of single; +begin + {$IFDEF FPC} + DefaultFormatSettings.DecimalSeparator := '.' ; + //DecimalSeparator := '.'; + {$ELSE} + DecimalSeparator := '.'; + {$ENDIF} + result := false; + gzBytes :=0; + fileposBytes := 0; + swapEndian :=false; + //nDims := 0; + headerSize :=0; + isDetachedFile :=false; + matElements :=0; + mArray := TStringList.Create; + Filemode := 0; + isFirstLine := true; + AssignFile(fp,fname); + reset(fp); + while (not EOF(fp)) do begin + str := ''; + while not EOF(fp) do begin + read(fp,ch); + fileposBytes := fileposBytes + 1; + if (ch = chr($0D)) or (ch = chr($0A)) then break; + str := str+ch; + end; + if str = '' then break; + if (isFirstLine) then begin + if (length(str) <4) or (str[1]<>'N') or (str[2]<>'R') or (str[3]<>'R') or (str[4]<>'D') then + goto 666; + isFirstLine := false; + end; + //showmessage(str+'->'+inttostr(fileposBytes)); + if (length(str) < 1) or (str[1]='#') then continue; + splitstrStrict(':',str,mArray); + if (mArray.count < 2) then continue; + tagName := mArray[0]; + elementNames := mArray[1]; + splitstr(',',elementNames,mArray); + nItems :=mArray.count; + if (nItems < 1) then continue; + for i := 0 to (nItems-1) do + mArray.Strings[i] := cleanStr(mArray.Strings[i]); //remove '(' and ')' + (*if AnsiContainsText(tagName, 'dimension') then + nDims := strtoint(mArray.Strings[0]) + else*) if AnsiContainsText(tagName, 'spacings') then begin + if (nItems > 6) then nItems :=6; + for i:=0 to (nItems-1) do + nhdr.pixdim[i+1] :=strtofloat(mArray.Strings[i]); + end else if AnsiContainsText(tagName, 'sizes') then begin + if (nItems > 6) then nItems :=6; + for i:=0 to (nItems-1) do + nhdr.dim[i+1] := strtoint(mArray.Strings[i]); + end else if AnsiContainsText(tagName, 'space directions') then begin + j := 0; + while (j < nItems) and (StrToFloatSafe( mArray.Strings[j]) = 1/0) do + j := j + 1; + + if ((nItems-j) >= 12) then begin + if ((nItems+j) > 12) then nItems :=(12+j); + matElements :=nItems; + for i:=0 to (nItems-1) do + transformMatrix[i] :=strtofloat(mArray.Strings[i+j]); + if (matElements >= 12) then + LOAD_MAT33(mat, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[4],transformMatrix[5],transformMatrix[6], + transformMatrix[8],transformMatrix[9],transformMatrix[10]) + else if (matElements >= 9) then + LOAD_MAT33(mat, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[3],transformMatrix[4],transformMatrix[5], + transformMatrix[6],transformMatrix[7],transformMatrix[8]); + end; //if false + end else if AnsiContainsText(tagName, 'type') then begin + if AnsiContainsText(mArray.Strings[0], 'uchar') or + AnsiContainsText(mArray.Strings[0], 'uint8') or + AnsiContainsText(mArray.Strings[0], 'uint8_t') then + nhdr.datatype := KDT_UINT8 //DT_UINT8 DT_UNSIGNED_CHAR + else if AnsiContainsText(mArray.Strings[0], 'short') or //specific so + AnsiContainsText(mArray.Strings[0], 'int16') or + AnsiContainsText(mArray.Strings[0], 'int16_t') then + nhdr.datatype :=kDT_INT16 //DT_INT16 + else if AnsiContainsText(mArray.Strings[0], 'float') then + nhdr.datatype := kDT_FLOAT32 //DT_FLOAT32 + else if AnsiContainsText(mArray.Strings[0], 'unsigned') + and (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'char') then + nhdr.datatype := kDT_UINT8 //DT_UINT8 + else if AnsiContainsText(mArray.Strings[0], 'unsigned') + and (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'short') then + nhdr.datatype := kDT_UINT16 //DT_UINT16 + else if AnsiContainsText(mArray.Strings[0], 'unsigned') and + (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'int') then + nhdr.datatype := kDT_INT32 // + else if AnsiContainsText(mArray.Strings[0], 'signed') and + (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'char') then + nhdr.datatype := kDT_INT8 //do UNSIGNED first, as "isigned" includes string "unsigned" + else if AnsiContainsText(mArray.Strings[0], 'signed') and + (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'short') then + nhdr.datatype := kDT_INT16 //do UNSIGNED first, as "isigned" includes string "unsigned" + else if AnsiContainsText(mArray.Strings[0], 'double') then + nhdr.datatype := kDT_DOUBLE //DT_DOUBLE + else if AnsiContainsText(mArray.Strings[0], 'int') then //do this last and "uint" includes "int" + nhdr.datatype := kDT_UINT32 + else begin + NSLog('Unsupported NRRD datatype'+mArray.Strings[0]); + end + end else if AnsiContainsText(tagName, 'endian') then begin + {$IFDEF ENDIAN_BIG} //data always stored big endian + if AnsiContainsText(mArray.Strings[0], 'little') then swapEndian :=true; + {$ELSE} + if AnsiContainsText(mArray.Strings[0], 'big') then swapEndian :=true; + {$ENDIF} + end else if AnsiContainsText(tagName, 'encoding') then begin + if AnsiContainsText(mArray.Strings[0], 'raw') then + gzBytes :=0 + else if AnsiContainsText(mArray.Strings[0], 'gz') or AnsiContainsText(mArray.Strings[0], 'gzip') then + gzBytes := K_gzBytes_headerAndImageCompressed//K_gzBytes_headeruncompressed + else + NSLog('Unknown encoding format '+mArray.Strings[0]); + end else if AnsiContainsText(tagName, 'space origin') then begin + if (nItems > 3) then nItems :=3; + for i:=0 to (nItems-1) do + offset[i] := strtofloat(mArray.Strings[i]); + end else if AnsiContainsText(tagName, 'data file') then begin + str := mArray.Strings[0]; + if fileexistsex(str) then + fname := str + else begin + fname := ExtractFileDirWithPathDelim(fname)+str; + end; + isDetachedFile :=true; + //break; + end; //for ...else tag names + end; + if ((headerSize = 0) and ( not isDetachedFile)) then begin + if gzBytes = K_gzBytes_headerAndImageCompressed then + gzBytes := K_gzBytes_onlyImageCompressed; //raw text file followed by GZ image + headerSize :=fileposBytes; + end; + result := true; +666: + CloseFile(FP); + Filemode := 2; + mArray.free; + if not result then exit; + nhdr.vox_offset :=headerSize; + if (matElements >= 9) then begin + nhdr.srow_x[0] :=-mat[0,0]; + nhdr.srow_x[1] :=-mat[1,0]; + nhdr.srow_x[2] :=-mat[2,0]; + nhdr.srow_x[3] :=-offset[0]; + nhdr.srow_y[0] :=-mat[0,1]; + nhdr.srow_y[1] :=-mat[1,1]; + nhdr.srow_y[2] :=-mat[2,1]; + nhdr.srow_y[3] :=-offset[1]; + nhdr.srow_z[0] :=mat[0,2]; + nhdr.srow_z[1] :=mat[1,2]; + nhdr.srow_z[2] :=mat[2,2]; + nhdr.srow_z[3] :=offset[2]; + //next: ITK does not generate a "spacings" tag - get this from the matrix... + for s :=0 to 2 do begin + vSqr :=0.0; + for i :=0 to 2 do + vSqr := vSqr+ ( mat[s,i]*mat[s,i]); + nhdr.pixdim[s+1] :=sqrt(vSqr); + end //for each dimension + end else + NSLog('Warning: unable to determine image orientation (unable to decode metaIO "TransformMatrix" tag)'+inttostr(matElements)); + convertForeignToNifti(nhdr); +end; + + +procedure THD_daxes_to_NIFTI (var nhdr: TNIFTIhdr; xyzDelta, xyzOrigin: vect3; orientSpecific: ivect3); +//see http://afni.nimh.nih.gov/pub/dist/src/thd_matdaxes.c +const + ORIENT_xyz1 = 'xxyyzzg'; //note Pascal strings indexed from 1, not 0! + ORIENT_sign1 = '+--++-'; //note Pascal strings indexed from 1, not 0! +var + axnum: array[0..2] of integer; + axcode,axsign: array[0..2] of char; + axstart,axstep: array[0..2] of single; + ii, nif_x_axnum, nif_y_axnum, nif_z_axnum: integer; + qto_xyz: mat44; + +begin + nif_x_axnum := -1; + nif_y_axnum := -1; + nif_z_axnum := -1; + axnum[0] := nhdr.dim[1]; + axnum[1] := nhdr.dim[2]; + axnum[2] := nhdr.dim[3]; + axcode[0] := ORIENT_xyz1[1+ orientSpecific[0] ] ; + axcode[1] := ORIENT_xyz1[1+ orientSpecific[1] ] ; + axcode[2] := ORIENT_xyz1[1+ orientSpecific[2] ] ; + axsign[0] := ORIENT_sign1[1+ orientSpecific[0] ] ; + axsign[1] := ORIENT_sign1[1+ orientSpecific[1] ] ; + axsign[2] := ORIENT_sign1[1+ orientSpecific[2] ] ; + axstep[0] := xyzDelta[0] ; + axstep[1] := xyzDelta[1] ; + axstep[2] := xyzDelta[2] ; + axstart[0] := xyzOrigin[0] ; + axstart[1] := xyzOrigin[1] ; + axstart[2] := xyzOrigin[2] ; + for ii := 0 to 2 do begin + if (axcode[ii] = 'x') then + nif_x_axnum := ii + else if (axcode[ii] = 'y') then + nif_y_axnum := ii + else + nif_z_axnum := ii ; + end; + if (nif_x_axnum < 0) or (nif_y_axnum < 0) or (nif_z_axnum < 0) then exit; //not assigned + if (nif_x_axnum = nif_y_axnum) or (nif_x_axnum = nif_z_axnum) or (nif_y_axnum = nif_z_axnum) then exit; //not assigned + ZERO_MAT44(qto_xyz); + //-- set voxel and time deltas and units -- + nhdr.pixdim[1] := abs ( axstep[0] ) ; + nhdr.pixdim[2] := abs ( axstep[1] ) ; + nhdr.pixdim[3] := abs ( axstep[2] ) ; + qto_xyz[0,nif_x_axnum] := - axstep[nif_x_axnum]; + qto_xyz[1,nif_y_axnum] := - axstep[nif_y_axnum]; + qto_xyz[2,nif_z_axnum] := axstep[nif_z_axnum]; + nhdr.qoffset_x := -axstart[nif_x_axnum] ; + nhdr.qoffset_y := -axstart[nif_y_axnum]; + nhdr.qoffset_z := axstart[nif_z_axnum]; + qto_xyz[0,3] := nhdr.qoffset_x ; + qto_xyz[1,3] := nhdr.qoffset_y ; + qto_xyz[2,3] := nhdr.qoffset_z ; + //nifti_mat44_to_quatern( qto_xyz , nhdr.quatern_b, nhdr.quatern_c, nhdr.quatern_d,dumqx, dumqy, dumqz, dumdx, dumdy, dumdz,nhdr.pixdim[0]) ; + //nhdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; + nhdr.srow_x[0] :=qto_xyz[0,0]; nhdr.srow_x[1] :=qto_xyz[0,1]; nhdr.srow_x[2] :=qto_xyz[0,2]; nhdr.srow_x[3] :=qto_xyz[0,3]; + nhdr.srow_y[0] :=qto_xyz[1,0]; nhdr.srow_y[1] :=qto_xyz[1,1]; nhdr.srow_y[2] :=qto_xyz[1,2]; nhdr.srow_y[3] :=qto_xyz[1,3]; + nhdr.srow_z[0] :=qto_xyz[2,0]; nhdr.srow_z[1] :=qto_xyz[2,1]; nhdr.srow_z[2] :=qto_xyz[2,2]; nhdr.srow_z[3] :=qto_xyz[2,3]; + nhdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT; +end; + +function readAFNIHeader (var fname: string; var nhdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +label + 666; +var + sl, mArray: TStringList; + typeStr,nameStr, valStr: string; + lineNum, itemCount,i, vInt, nVols: integer; + isAllVolumesSame, isProbMap, isStringAttribute: boolean; + valArray : Array of double; + orientSpecific: ivect3; + xyzOrigin, xyzDelta: vect3; +begin + {$IFDEF FPC} + DefaultFormatSettings.DecimalSeparator := '.' ; + //DecimalSeparator := '.'; + {$ELSE} + DecimalSeparator := '.'; + {$ENDIF} + nVols := 1; + result := false; + isProbMap := false; + gzBytes := 0; + swapEndian := false; + sl := TStringList.Create; + mArray := TStringList.Create; + sl.LoadFromFile(fname); + if(sl.count) < 4 then goto 666; + lineNum := -1; + repeat + //read type string + lineNum := lineNum + 1; + if length(sl[lineNum]) < 1 then continue; + splitstr('=',sl[lineNum],mArray); + if mArray.Count < 2 then continue; + if not AnsiContainsText(cleanStr(mArray[0]), 'type') then continue; + typeStr := cleanStr(mArray[1]); + isStringAttribute := AnsiContainsText(typeStr, 'string-attribute'); + //next: read name string + lineNum := lineNum + 1; + if (lineNum >= (sl.count-1)) then continue; + splitstr('=',sl[lineNum],mArray); + if mArray.Count < 2 then continue; + if not AnsiContainsText(cleanStr(mArray[0]), 'name') then continue; + nameStr := cleanStr(mArray[1]); + //if AnsiContainsText(nameStr,'BYTEORDER_STRING') and isStringAttribute then showmessage('txt'); + //next: read count string + lineNum := lineNum + 1; + if (lineNum >= (sl.count-1)) then continue; + splitstr('=',sl[lineNum],mArray); + if mArray.Count < 2 then continue; + if not AnsiContainsText(cleanStr(mArray[0]), 'count') then continue; + itemCount := strtoint(cleanStr(mArray[1])); + if itemCount < 1 then exit; + //next read values + lineNum := lineNum + 1; + if (lineNum > (sl.count-1)) then continue; + valStr := sl[lineNum]; + while ((lineNum+1) <= (sl.count-1)) and (length(sl[lineNum+1]) > 0) do begin + lineNum := lineNum + 1; //AFNI wraps some arrays across multiple lines + valStr := valStr + ' '+ sl[lineNum]; + end; + splitstr(' ',valStr,mArray); + if (mArray.Count < itemCount) then itemCount := mArray.Count; // <- only if corrupt + if itemCount < 1 then continue; // <- only if corrupt data + if isStringAttribute then begin + if AnsiContainsText(nameStr,'BYTEORDER_STRING') then begin + {$IFDEF ENDIAN_BIG} + if AnsiContainsText(mArray[0],'LSB_FIRST') then swapEndian := true; + {$ELSE} + if AnsiContainsText(mArray[0],'MSB_FIRST') then swapEndian := true; + {$ENDIF} + end + end else begin //if numeric attributes... + setlength(valArray,itemCount); + for i := 0 to (itemCount-1) do + valArray[i] := strtofloat(cleanStr(mArray[i]) ); + //next - harvest data from important names + if AnsiContainsText(nameStr,'BRICK_TYPES') then begin + vInt := round(valArray[0]); + if (vInt = 0) then begin + nhdr.datatype := kDT_UINT8; + end else if (vInt = 1) then begin + nhdr.datatype := kDT_INT16; //16 bit signed int + end else if (vInt = 3) then begin + nhdr.datatype := kDT_FLOAT32;//32-bit float + end else begin + NSLog('Unsupported BRICK_TYPES '+inttostr(vInt)); + goto 666; + end; + if (itemCount > 1) then begin //check that all volumes are of the same datatype + nVols := itemCount; + isAllVolumesSame := true; + for i := 1 to (itemCount-1) do + if (valArray[0] <> valArray[i]) then isAllVolumesSame := false; + if (not isAllVolumesSame) then begin + NSLog('Unsupported BRICK_TYPES feature: datatype varies between sub-bricks'); + goto 666; + end; + end; //if acount > 0 + //NSLog('HEAD datatype is '+inttostr(nhdr.datatype) ); + end else if AnsiContainsText(nameStr,'BRICK_FLOAT_FACS') then begin + nhdr.scl_slope := valArray[0]; + if (itemCount > 1) then begin //check that all volumes are of the same datatype + isAllVolumesSame := true; + for i := 1 to (itemCount-1) do + if (valArray[0] <> valArray[i]) then isAllVolumesSame := false; + if (not isAllVolumesSame) then begin + NSLog('Unsupported BRICK_FLOAT_FACS feature: intensity scale between sub-bricks'); + end; + end; //if acount > 0 + end else if AnsiContainsText(nameStr,'DATASET_DIMENSIONS') then begin + if itemCount > 3 then itemCount := 3; + for i := 0 to (itemCount-1) do + nhdr.dim[i+1] := round(valArray[i]); + end else if AnsiContainsText(nameStr,'ORIENT_SPECIFIC') then begin + if itemCount > 3 then itemCount := 3; + for i := 0 to (itemCount-1) do + orientSpecific[i] := round(valArray[i]);; + //NSLog(@"HEAD orient specific %d %d %d",orientSpecific.v[0],orientSpecific.v[1],orientSpecific.v[2]); + end else if AnsiContainsText(nameStr,'ORIGIN') then begin + if itemCount > 3 then itemCount := 3; + for i := 0 to (itemCount-1) do + xyzOrigin[i] := valArray[i]; + //NSLog(@"HEAD origin %g %g %g",xyzOrigin.v[0],xyzOrigin.v[1],xyzOrigin.v[2]); + end else if AnsiContainsText(nameStr,'ATLAS_PROB_MAP') then begin + if (round(valArray[0]) = 1) then isProbMap := true; + end else if AnsiContainsText(nameStr,'ATLAS_LABEL_TABLE') then begin + nhdr.intent_code := kNIFTI_INTENT_LABEL; + end else if AnsiContainsText(nameStr,'DELTA') then begin + if itemCount > 3 then itemCount := 3; + for i := 0 to (itemCount-1) do + xyzDelta[i] := valArray[i]; + //NSLog(@"HEAD delta %g %g %g",xyzDelta.v[0],xyzDelta.v[1],xyzDelta.v[2]); + end else if AnsiContainsText(nameStr,'TAXIS_FLOATS') then begin + if (itemCount > 1) then nhdr.pixdim[4] := valArray[1]; //second item is TR + end; + end;// if isStringAttribute else numeric inputs... + until (lineNum >= (sl.count-1)); + result := true; +666: + valArray := nil; //release dynamic array + Filemode := 2; + sl.free; + mArray.free; + if not result then exit; //error - code jumped to 666 without setting result to true + if (nVols > 1) then nhdr.dim[4] := nVols; + if (isProbMap) and (nhdr.intent_code = kNIFTI_INTENT_LABEL) then nhdr.intent_code := kNIFTI_INTENT_NONE; + THD_daxes_to_NIFTI(nhdr, xyzDelta, xyzOrigin, orientSpecific ); + nhdr.vox_offset := 0; + convertForeignToNifti(nhdr); + fname := ChangeFileExtX(fname, '.BRIK'); + if (not FileExistsEX(fname)) then begin + fname := fname+'.gz'; + gzBytes := K_gzBytes_headerAndImageCompressed; + end; +end; + +function readForeignHeader (var lFilename: string; var lHdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +var + lExt: string; +begin + NII_Clear (lHdr); + result := false; + lExt := UpCaseExt(lFilename); + if (lExt = '.MGH') or (lExt = '.MGZ') then + result := readMGHHeader(lFilename, lHdr, gzBytes, swapEndian) + else if (lExt = '.MHD') or (lExt = '.MHA') then + result := readMHAHeader(lFilename, lHdr, gzBytes, swapEndian) + else if (lExt = '.NRRD') or (lExt = '.NHDR') then + result := readNRRDHeader(lFilename, lHdr, gzBytes, swapEndian) + else if (lExt = '.HEAD') then + result := readAFNIHeader(lFilename, lHdr, gzBytes, swapEndian); +end; + +end. + \ No newline at end of file diff --git a/common/nifti_foreign.ppu b/common/nifti_foreign.ppu new file mode 100644 index 0000000..6bbf785 Binary files /dev/null and b/common/nifti_foreign.ppu differ diff --git a/common/nifti_hdr.o b/common/nifti_hdr.o new file mode 100644 index 0000000..2604201 Binary files /dev/null and b/common/nifti_hdr.o differ diff --git a/common/nifti_hdr.pas b/common/nifti_hdr.pas new file mode 100755 index 0000000..befdae3 --- /dev/null +++ b/common/nifti_hdr.pas @@ -0,0 +1,1235 @@ +unit nifti_hdr; +interface +{$H+} +{$Include isgui.inc} +{$MODE DELPHI} +uses +{$IFNDEF FPC} + DiskSpaceKludge,gziod, +{$ELSE} + gzio2, +{$ENDIF} +{$IFNDEF Unix} Windows, {$ENDIF} +define_types,SysUtils,GraphicsMathLibrary, nifti_types, nifti_foreign, + dialogsx; + +type + + TAnalyzeHdrSection = packed record //Next: analyze Format Header structure + Pad: array [1..253] of byte; + originator: array [1..5] of smallint; + end;//TAnalyzeHdrSection Structure + + TMRIcroHdr = record //Next: analyze Format Header structure + NIFTIhdr : TNIFTIhdr; + AutoBalMinUnscaled,AutoBalMaxUnscaled + ,WindowScaledMin,WindowScaledMax + ,GlMinUnscaledS,GlMaxUnscaledS,Zero8Bit,Slope8bit: single; //brightness and contrast + NIfTItransform,DiskDataNativeEndian,UsesCustomPalette,UsesCustomPaletteRandomRainbow,UsesLabels,LutFromZero: boolean; + HdrFileName,ImgFileName,ECodeText: string; + gzBytesX: int64; + NIFTIVersion,LUTindex,ScrnBufferItems,ImgBufferItems,RenderBufferItems,ImgBufferBPP,RenderDim,Index: longint; + ImgBufferUnaligned: Pointer; //raw address of Image Buffer: address may not be aligned + ScrnBuffer,ImgBuffer,RenderBuffer: Bytep; + LUTinvisible: TRGBQuad;//DWord; + LUT: TLUT;//array[0..255] of TRGBQuad; + Mat: TMatrix; + end; //TNIFTIhdr Header Structure + + + function IsVOIROIExt (var lFName: string):boolean; + function ComputeImageDataBytes (var lHdr: TMRIcroHdr): longint; //size of image data in bytes + function ComputeImageDataBytes8bpp (var lHdr: TMRIcroHdr): longint; //size of image as 32-bit per voxel data in bytes + function ComputeImageDataBytes32bpp (var lHdr: TMRIcroHdr): longint; //size of image as 32-bit per voxel data in bytes + procedure NIFTIhdr_SwapBytes (var lAHdr: TNIFTIhdr); //Swap Byte order for the Analyze type + procedure NIFTIhdr_ClearHdr (var lHdr: TMRIcroHdr); //set all values of header to something reasonable + function NIFTIhdr_LoadHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TMRIcroHdr; lAllowOverwrite: boolean): boolean; overload; + function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2: boolean): boolean; overload; + procedure NIFTIhdr_SetIdentityMatrix (var lHdr: TMRIcroHdr); //create neutral rotation matrix + function IsNIfTIHdrExt (var lFName: string):boolean; //1494 + function IsNifTiMagic (var lHdr: TNIFTIhdr): boolean; + //procedure NearestOrtho(var lHdr: TMRIcroHdr); +//function nifti_mat44_orthog( lR :TMatrix; lImm,lJmm,lKmm: double): TMatrix; + + function CopyNiftiHdr (var lInHdr,lOutHdr: TNIFTIhdr): boolean; + procedure WriteNiftiMatrix (var lHdr: TNIFTIhdr; + m11,m12,m13,m14, + m21,m22,m23,m24, + m31,m32,m33,m34: Single); + procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); + + +implementation +uses +{$IFDEF GUI} dialogs,{$ENDIF} +dicomhdr;//2/2208 + +function CopyNiftiHdr (var lInHdr,lOutHdr: TNIFTIhdr): boolean; +begin + move(lInHdr,lOutHdr,sizeof(TNIFTIhdr)); + result := true; +end; + +procedure WriteNiftiMatrix (var lHdr: TNIFTIhdr; + m11,m12,m13,m14, + m21,m22,m23,m24, + m31,m32,m33,m34: Single); +begin + with lHdr do begin + srow_x[0] := m11; + srow_x[1] := m12; + srow_x[2] := m13; + srow_x[3] := m14; + srow_y[0] := m21; + srow_y[1] := m22; + srow_y[2] := m23; + srow_y[3] := m24; + srow_z[0] := m31; + srow_z[1] := m32; + srow_z[2] := m33; + srow_z[3] := m34; + end; //with lHdr +end; + +function IsNifTi1Magic (var lHdr: TNIFTIhdr): boolean; +begin + if (lHdr.magic =kNIFTI_MAGIC_SEPARATE_HDR) or (lHdr.Magic = kNIFTI_MAGIC_EMBEDDED_HDR ) then + result := true + else + result :=false; //analyze +end; + +function IsNifTiMagic (var lHdr: TNIFTIhdr): boolean; +begin + if (IsNifTi1Magic(lHdr)) then + result := true + else + result :=false; //analyze +end; + +function IsNIfTIHdrExt (var lFName: string):boolean; +var + lExt: string; +begin + lExt := UpCaseExt(lFName); + if (lExt='.NII') or (lExt = '.HDR') or (lExt = '.NII.GZ') or (lExt = '.VOI') then + result := true + else + result := false; +end; + +function IsVOIROIExt (var lFName: string):boolean; +var + lExt: string; +begin + lExt := UpCaseExt(lFName); + if (lExt = '.VOI') or (lExt = '.ROI') then + result := true + else + result := false; +end; + +function ComputeImageDataBytes32bpp (var lHdr: TMRIcroHdr): integer; +var + lDim, lBytes : integer; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + ShowMsg('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + lBytes := 4; //bits per voxel + for lDim := 1 to 3 {Dim[0]} do + lBytes := lBytes * Dim[lDim]; + end; //with niftihdr + result := lBytes; //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes32bpp + +function ComputeImageDataBytes8bpp (var lHdr: TMRIcroHdr): integer; +var + lDim, lBytes: integer; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + ShowMsg('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + lBytes := 1; //bits per voxel + for lDim := 1 to 3 {Dim[0]} do + lBytes := lBytes * Dim[lDim]; + end; //with niftihdr + result := lBytes; //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes8bpp + +function ComputeImageDataBytes (var lHdr: TMRIcroHdr): integer; +var + lDim : integer; + lSzInBits : Int64; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + ShowMsg('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + lSzInBits := bitpix; //bits per voxel + //showmessage(inttostr(Dim[0])); + for lDim := 1 to 3 {Dim[0]} do + lSzInBits := lSzInBits * Dim[lDim]; + end; //with niftihdr + result := (lSzInBits + 7) div 8; //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes +function orthogonalMatrix(var lHdr: TMRIcroHdr): boolean; +var + lM: TMatrix; + lRow,lCol,lN0: integer; +begin + result := false; + lM := Matrix3D ( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + for lRow := 1 to 3 do begin + lN0 := 0; + for lCol := 1 to 3 do + if lM.matrix[lRow,lCol] = 0 then + inc(lN0); + if lN0 <> 2 then exit; //exactly two values are zero + end; + for lCol := 1 to 3 do begin + lN0 := 0; + for lRow := 1 to 3 do + if lM.matrix[lRow,lCol] = 0 then + inc(lN0); + if lN0 <> 2 then exit; //exactly two values are zero + end; + result := true; +end; + +function EmptyRow (lRow: integer; var lM: TMatrix): boolean; +begin + //fx(lM.matrix[lRow,1],lM.matrix[lRow,2],lM.matrix[lRow,3]); + if (abs(lM.matrix[lRow,1]) < 0.00000001) and (abs(lM.matrix[lRow,2]) < 0.00000001) and (abs(lM.matrix[lRow,3]) < 0.00000001) then + result := true + else + result := false; +end; + +procedure ReportMatrix (lStr: string;lM:TMatrix); +begin + ShowMsg(lStr+kCR+ + RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+ + kCR+RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+ + kCR+RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+ + kCR+RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6)); +end; + +function EmptyMatrix(var lHdr: TMRIcroHdr): boolean; +var + lM: TMatrix; + lRow,lCol: integer; +begin + result := false; + lM := Matrix3D ( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + if EmptyRow(1,lM) or EmptyRow(2,lM) or EmptyRow(3,lM) then begin + ReportMatrix('Matrix appears bogus',lm); + end else begin + for lRow := 1 to 3 do begin {3/2008} + for lCol := 1 to 4 do begin + if (lRow = lCol) then begin + if lM.matrix[lRow,lCol] <> 1 then + exit; + end else begin + if lM.matrix[lRow,lCol] <> 0 then + exit; + end// unity matrix does not count - mriconvert creates bogus [1 0 0 0; 0 1 0 0; 0 0 1 0; 0 0 0 0] + end; //each col + end;//each row + end;//not bogus + result := true; +end; + + + +procedure FromMatrix (M: TMatrix; var m11,m12,m13, m21,m22,m23, + m31,m32,m33: DOUBLE) ; + BEGIN + m11 := M.Matrix[1,1]; + m12 := M.Matrix[1,2]; + m13 := M.Matrix[1,3]; + m21 := M.Matrix[2,1]; + m22 := M.Matrix[2,2]; + m23 := M.Matrix[2,3]; + m31 := M.Matrix[3,1]; + m32 := M.Matrix[3,2]; + m33 := M.Matrix[3,3]; +END {FromMatrix3D}; + + +function nifti_mat33_determ( R: TMatrix ):double; +begin + result := r.matrix[1,1]*r.matrix[2,2]*r.matrix[3,3] + -r.matrix[1,1]*r.matrix[3,2]*r.matrix[2,3] + -r.matrix[2,1]*r.matrix[1,2]*r.matrix[3,3] + +r.matrix[2,1]*r.matrix[3,2]*r.matrix[1,3] + +r.matrix[3,1]*r.matrix[1,2]*r.matrix[2,3] + -r.matrix[3,1]*r.matrix[2,2]*r.matrix[1,3] ; +end; + +procedure FixCrapMat(var lMat: TMatrix); +var + lVec000,lVec100,lVec010,lVec001: TVector; +begin + lVec000 := Vector3D (0, 0, 0); + lVec100 := Vector3D (1, 0, 0); + lVec010 := Vector3D (0, 1, 0); + lVec001 := Vector3D (0, 0, 1); + lVec000 := Transform (lVec000, lMat); + lVec100 := Transform (lVec100, lMat); + lVec010 := Transform (lVec010, lMat); + lVec001 := Transform (lVec001, lMat); + + if SameVec(lVec000,lVec100) or + SameVec(lVec000,lVec010) or + SameVec(lVec000,lVec001) then begin + lMat := eye3D; + ShowMsg('Warning: the transformation matrix is corrupt [some dimensions have zero size]'); + end; +end; + + +function nifti_mat33_rownorm( A: TMatrix ): single; //* max row norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A.matrix[1,1])+abs(A.matrix[1,2])+abs(A.matrix[1,3]) ; + r2 := abs(A.matrix[2,1])+abs(A.matrix[2,2])+abs(A.matrix[2,3]) ; + r3 := abs(A.matrix[3,1])+abs(A.matrix[3,2])+abs(A.matrix[3,3]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_colnorm( A: TMatrix ): single; //* max column norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A.matrix[1,1])+abs(A.matrix[2,1])+abs(A.matrix[3,1]) ; + r2 := abs(A.matrix[1,2])+abs(A.matrix[2,2])+abs(A.matrix[3,2]) ; + r3 := abs(A.matrix[1,3])+abs(A.matrix[2,3])+abs(A.matrix[3,3]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_inverse( R: TMatrix ): TMatrix; //* inverse of 3x3 matrix */ +var + r11,r12,r13,r21,r22,r23,r31,r32,r33 , deti: double ; + Q: TMatrix ; +begin + FromMatrix(R,r11,r12,r13,r21,r22,r23,r31,r32,r33); + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + + if( deti <> 0.0 ) then deti := 1.0 / deti ; + + Q.matrix[1,1] := deti*( r22*r33-r32*r23) ; + Q.matrix[1,2] := deti*(-r12*r33+r32*r13) ; + Q.matrix[1,3] := deti*( r12*r23-r22*r13) ; + + Q.matrix[2,1] := deti*(-r21*r33+r31*r23) ; + Q.matrix[2,2] := deti*( r11*r33-r31*r13) ; + Q.matrix[2,3] := deti*(-r11*r23+r21*r13) ; + + Q.matrix[3,1] := deti*( r21*r32-r31*r22) ; + Q.matrix[3,2] := deti*(-r11*r32+r31*r12) ; + Q.matrix[3,3] := deti*( r11*r22-r21*r12) ; + result := Q; +end; + +function nifti_mat33_polar( A: TMatrix ): TMatrix; +var + k:integer; + X , Y , Z: TMatrix ; + dif,alp,bet,gam,gmi : single; +begin +dif := 1; +k := 0; + X := A ; + // force matrix to be nonsingular + //reportmatrix('x',X); + gam := nifti_mat33_determ(X) ; + while( gam = 0.0 )do begin //perturb matrix + gam := 0.00001 * ( 0.001 + nifti_mat33_rownorm(X) ) ; + X.matrix[1,1] := X.matrix[1,1]+gam ; + X.matrix[2,2] := X.matrix[2,2]+gam ; + X.matrix[3,3] := X.matrix[3,3] +gam ; + gam := nifti_mat33_determ(X) ; + end; + + while true do begin + Y := nifti_mat33_inverse(X) ; + if( dif > 0.3 )then begin // far from convergence + alp := sqrt( nifti_mat33_rownorm(X) * nifti_mat33_colnorm(X) ) ; + bet := sqrt( nifti_mat33_rownorm(Y) * nifti_mat33_colnorm(Y) ) ; + gam := sqrt( bet / alp ) ; + gmi := 1.0 / gam ; + end else begin + gam := 1.0; + gmi := 1.0 ; //close to convergence + end; + Z.matrix[1,1] := 0.5 * ( gam*X.matrix[1,1] + gmi*Y.matrix[1,1] ) ; + Z.matrix[1,2] := 0.5 * ( gam*X.matrix[1,2] + gmi*Y.matrix[2,1] ) ; + Z.matrix[1,3] := 0.5 * ( gam*X.matrix[1,3] + gmi*Y.matrix[3,1] ) ; + Z.matrix[2,1] := 0.5 * ( gam*X.matrix[2,1] + gmi*Y.matrix[1,2] ) ; + Z.matrix[2,2] := 0.5 * ( gam*X.matrix[2,2] + gmi*Y.matrix[2,2] ) ; + Z.matrix[2,3] := 0.5 * ( gam*X.matrix[2,3] + gmi*Y.matrix[3,2] ) ; + Z.matrix[3,1] := 0.5 * ( gam*X.matrix[3,1] + gmi*Y.matrix[1,3] ) ; + Z.matrix[3,2] := 0.5 * ( gam*X.matrix[3,2] + gmi*Y.matrix[2,3] ) ; + Z.matrix[3,3] := 0.5 * ( gam*X.matrix[3,3] + gmi*Y.matrix[3,3] ) ; + + dif := abs(Z.matrix[1,1]-X.matrix[1,1])+abs(Z.matrix[1,2]-X.matrix[1,2]) + +abs(Z.matrix[1,3]-X.matrix[1,3])+abs(Z.matrix[2,1]-X.matrix[2,1]) + +abs(Z.matrix[2,2]-X.matrix[2,2])+abs(Z.matrix[2,3]-X.matrix[2,3]) + +abs(Z.matrix[3,1]-X.matrix[3,1])+abs(Z.matrix[3,2]-X.matrix[3,2]) + +abs(Z.matrix[3,3]-X.matrix[3,3]) ; + k := k+1 ; + if( k > 100) or (dif < 3.e-6 ) then begin + result := Z; + break ; //convergence or exhaustion + end; + X := Z ; + end; + result := Z ; +end; + + +procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd , a,b,c,d : double; + P,Q: TMatrix; //3x3 +begin + + + (* offset outputs are read write out of input matrix *) + qx := lR.matrix[1,4]; + qy := lR.matrix[2,4]; + qz := lR.matrix[3,4]; + + (* load 3x3 matrix into local variables *) + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + (* compute lengths of each column; these determine grid spacings *) + + xd := sqrt( r11*r11 + r21*r21 + r31*r31 ) ; + yd := sqrt( r12*r12 + r22*r22 + r32*r32 ) ; + zd := sqrt( r13*r13 + r23*r23 + r33*r33 ) ; + + (* if a column length is zero, patch the trouble *) + + if( xd = 0.0 )then begin r11 := 1.0 ; r21 := 0; r31 := 0.0 ; xd := 1.0 ; end; + if( yd = 0.0 )then begin r22 := 1.0 ; r12 := 0; r32 := 0.0 ; yd := 1.0 ; end; + if( zd = 0.0 )then begin r33 := 1.0 ; r13 := 0; r23 := 0.0 ; zd := 1.0 ; end; + + (* assign the output lengths *) + dx := xd; + dy := yd; + dz := zd; + + (* normalize the columns *) + + r11 := r11/xd ; r21 := r21/xd ; r31 := r31/xd ; + r12 := r12/yd ; r22 := r22/yd ; r32 := r32/yd ; + r13 := r13/zd ; r23 := r23/zd ; r33 := r33/zd ; + + (* At this point, the matrix has normal columns, but we have to allow + for the fact that the hideous user may not have given us a matrix + with orthogonal columns. + + So, now find the orthogonal matrix closest to the current matrix. + + One reason for using the polar decomposition to get this + orthogonal matrix, rather than just directly orthogonalizing + the columns, is so that inputting the inverse matrix to R + will result in the inverse orthogonal matrix at this point. + If we just orthogonalized the columns, this wouldn't necessarily hold. *) + Q := Matrix2D (r11,r12,r13, // 2D "graphics" matrix + r21,r22,r23, + r31,r32,r33); + + + + P := nifti_mat33_polar(Q) ; (* P is orthog matrix closest to Q *) + FromMatrix(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + //ReportMatrix('xxx',Q); + //ReportMatrix('svd',P); + (* [ r11 r12 r13 ] *) + (* at this point, the matrix [ r21 r22 r23 ] is orthogonal *) + (* [ r31 r32 r33 ] *) + + (* compute the determinant to determine if it is proper *) + + zd := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; (* should be -1 or 1 *) + + if( zd > 0 )then begin (* proper *) + qfac := 1.0 ; + end else begin (* improper ==> flip 3rd column *) + qfac := -1.0 ; + r13 := -r13 ; r23 := -r23 ; r33 := -r33 ; + end; + + (* now, compute quaternion parameters *) + + a := r11 + r22 + r33 + 1.0; + + if( a > 0.5 ) then begin (* simplest case *) + a := 0.5 * sqrt(a) ; + b := 0.25 * (r32-r23) / a ; + c := 0.25 * (r13-r31) / a ; + d := 0.25 * (r21-r12) / a ; + end else begin (* trickier case *) + xd := 1.0 + r11 - (r22+r33) ; (* 4*b*b *) + yd := 1.0 + r22 - (r11+r33) ; (* 4*c*c *) + zd := 1.0 + r33 - (r11+r22) ; (* 4*d*d *) + if( xd > 1.0 ) then begin + b := 0.5 * sqrt(xd) ; + c := 0.25* (r12+r21) / b ; + d := 0.25* (r13+r31) / b ; + a := 0.25* (r32-r23) / b ; + end else if( yd > 1.0 ) then begin + c := 0.5 * sqrt(yd) ; + b := 0.25* (r12+r21) / c ; + d := 0.25* (r23+r32) / c ; + a := 0.25* (r13-r31) / c ; + end else begin + d := 0.5 * sqrt(zd) ; + b := 0.25* (r13+r31) / d ; + c := 0.25* (r23+r32) / d ; + a := 0.25* (r21-r12) / d ; + end; + if( a < 0.0 )then begin b:=-b ; c:=-c ; d:=-d; {a:=-a; this is not used} end; + end; + + qb := b ; + qc := c ; + qd := d ; + //fx(qb,qc,qd); +end; + +procedure nifti_quatern_to_mat44( var lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + a,b,c,d,xd,yd,zd: double; +begin + //a := qb; + b := qb; + c := qc; + d := qd; + //* last row is always [ 0 0 0 1 ] */ + lR.matrix[4,1] := 0; + lR.matrix[4,2] := 0; + lR.matrix[4,3] := 0; + lR.matrix[4,4] := 1; + //* compute a parameter from b,c,d */ + a := 1.0 - (b*b + c*c + d*d) ; + if( a < 1.e-7 ) then begin//* special case */ + a := 1.0 / sqrt(b*b+c*c+d*d) ; + b := b*a ; c := c*a ; d := d*a ;//* normalize (b,c,d) vector */ + a := 0.0 ;//* a = 0 ==> 180 degree rotation */ + end else begin + a := sqrt(a) ; //* angle = 2*arccos(a) */ + end; + //* load rotation matrix, including scaling factors for voxel sizes */ + if dx > 0 then + xd := dx + else + xd := 1; + if dy > 0 then + yd := dy + else + yd := 1; + if dz > 0 then + zd := dz + else + zd := 1; + if( qfac < 0.0 ) then zd := -zd ;//* left handedness? */ + lR.matrix[1,1]:= (a*a+b*b-c*c-d*d) * xd ; + lR.matrix[1,2]:= 2.0 * (b*c-a*d ) * yd ; + lR.matrix[1,3]:= 2.0 * (b*d+a*c ) * zd ; + lR.matrix[2,1]:= 2.0 * (b*c+a*d ) * xd ; + lR.matrix[2,2]:= (a*a+c*c-b*b-d*d) * yd ; + lR.matrix[2,3]:= 2.0 * (c*d-a*b ) * zd ; + lR.matrix[3,1]:= 2.0 * (b*d-a*c ) * xd ; + lR.matrix[3,2]:= 2.0 * (c*d+a*b ) * yd ; + lR.matrix[3,3]:= (a*a+d*d-c*c-b*b) * zd ; + //* load offsets */ + lR.matrix[1,4]:= qx ; + lR.matrix[2,4]:= qy ; + lR.matrix[3,4]:= qz ; + +end; + +function TryQuat2Matrix( var lHdr: TNIfTIHdr ): boolean; +var lR :TMatrix; +begin + + result := false; + if (lHdr.qform_code <= kNIFTI_XFORM_UNKNOWN) or (lHdr.qform_code > kNIFTI_XFORM_MNI_152) then + exit; + + result := true; + nifti_quatern_to_mat44(lR,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lHdr.pixdim[1],lHdr.pixdim[2],lHdr.pixdim[3], + lHdr.pixdim[0]); + lHdr.srow_x[0] := lR.matrix[1,1]; + lHdr.srow_x[1] := lR.matrix[1,2]; + lHdr.srow_x[2] := lR.matrix[1,3]; + lHdr.srow_x[3] := lR.matrix[1,4]; + lHdr.srow_y[0] := lR.matrix[2,1]; + lHdr.srow_y[1] := lR.matrix[2,2]; + lHdr.srow_y[2] := lR.matrix[2,3]; + lHdr.srow_y[3] := lR.matrix[2,4]; + lHdr.srow_z[0] := lR.matrix[3,1]; + lHdr.srow_z[1] := lR.matrix[3,2]; + lHdr.srow_z[2] := lR.matrix[3,3]; + lHdr.srow_z[3] := lR.matrix[3,4]; + lHdr.sform_code := 1; +end; + +{procedure ReportMatrix (lM:TMatrix); +var lStr: string; +begin + + lStr := ( RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)) + +kCR+( RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)) + +kCR+( RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)) + +kCR+( RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6)); +showmessage(lStr); +end; } +function FixDataType (var lHdr: TMRIcroHdr ): boolean; +//correct mistakes of datatype and bitpix - especially for software which only sets one +label + 191; +var + ldatatypebpp,lbitpix: integer; +begin + result := true; + lbitpix := lHdr.NIFTIhdr.bitpix; + case lHdr.NIFTIhdr.datatype of + kDT_BINARY : ldatatypebpp := 1; + kDT_UNSIGNED_CHAR : ldatatypebpp := 8; // unsigned char (8 bits/voxel) + kDT_SIGNED_SHORT : ldatatypebpp := 16; // signed short (16 bits/voxel) + kDT_SIGNED_INT : ldatatypebpp := 32; // signed int (32 bits/voxel) + kDT_FLOAT : ldatatypebpp := 32; // float (32 bits/voxel) + kDT_COMPLEX : ldatatypebpp := 64; // complex (64 bits/voxel) + kDT_DOUBLE : ldatatypebpp := 64; // double (64 bits/voxel) + kDT_RGB : ldatatypebpp := 24; // RGB triple (24 bits/voxel) + kDT_INT8 : ldatatypebpp := 8; // signed char (8 bits) + kDT_UINT16 : ldatatypebpp := 16; // unsigned short (16 bits) + kDT_UINT32 : ldatatypebpp := 32; // unsigned int (32 bits) + kDT_INT64 : ldatatypebpp := 64; // long long (64 bits) + kDT_UINT64 : ldatatypebpp := 64; // unsigned long long (64 bits) + kDT_FLOAT128 : ldatatypebpp := 128; // long double (128 bits) + kDT_COMPLEX128 : ldatatypebpp := 128; // double pair (128 bits) + kDT_COMPLEX256 : ldatatypebpp := 256; // long double pair (256 bits) + else + ldatatypebpp := 0; + end; + if (ldatatypebpp = lHdr.NIFTIhdr.bitpix) and (ldatatypebpp <> 0) then + exit; + if (ldatatypebpp <> 0) then begin + //use bitpix from datatype... + //showmessage(inttostr(lHdr.NIFTIhdr.datatype) +' '+inttostr(ldatatypebpp)+' '+inttostr(lbitpix)); + lHdr.NIFTIhdr.bitpix := ldatatypebpp; + exit; + end; + + if (lbitpix <> 0) and (ldatatypebpp = 0) then begin + //assume bitpix is correct.... + //note that several datatypes correspond to each bitpix, so assume most popular... + case lbitpix of + 1: lHdr.NIFTIhdr.datatype := kDT_BINARY; + 8: lHdr.NIFTIhdr.datatype := kDT_UNSIGNED_CHAR; + 16: lHdr.NIFTIhdr.datatype := kDT_SIGNED_SHORT; + 24: lHdr.NIFTIhdr.datatype := kDT_RGB; + 32: lHdr.NIFTIhdr.datatype := kDT_FLOAT; + 64: lHdr.NIFTIhdr.datatype := kDT_DOUBLE; + else goto 191; //impossible bitpix + end; + exit; + end; +191: + //Both bitpix and datatype are wrong... assume most popular format + lHdr.NIFTIhdr.bitpix := 16; + lHdr.NIFTIhdr.datatype := kDT_SIGNED_SHORT; + //fx(lHdr.NIFTIhdr.bitpix, lHdr.NIFTIhdr.datatype); +end; + +//function ReadEcode(lHdr: TMRIcroHdr; swapEndian: boolean): string; +procedure ReadEcode(var lHdr: TMRIcroHdr); +var + + extension : array[0..3] of byte; + myFile : File; + esize , ecode: longint; + lFileSz, lEnd, lStart, i: integer; + lBuff: array of char; +begin + lFileSz := FSize (lHdr.HdrFileName); + if (lFileSz < sizeof(lHdr.NIFTIhdr)+14) then exit; + if (lHdr.gzBytesX = K_gzBytes_headerAndImageUncompressed) then begin + AssignFile(myFile, lHdr.HdrFileName); + FileMode := fmOpenRead; + Reset(myFile, 1); // Now we define one record as 1 byte + seek(myFile, sizeof(lHdr.NIFTIhdr)); + BlockRead(myFile, extension, 4); + if extension[0] = 0 then begin + CloseFile(myFile); + exit; + end; + BlockRead(myFile, esize, 4); + BlockRead(myFile, ecode, 4); + if (lHdr.DiskDataNativeEndian = false) then begin + swap4(esize); + swap4(ecode); + end; + esize := esize - 8; //-8 as esize includes 8 bytes of esize and ecode themselves + lStart := sizeof(lHdr.NIFTIhdr)+12; + lEnd := lStart + esize; + if (lEnd > lFileSz) or (esize < 1) then begin// or ((ecode <> 6) and (ecode <> 4)) then begin //XML or Text + CloseFile(myFile); + exit; + end; + SetLength(lBuff, esize); + BlockRead(myFile, lBuff[0], esize); + SetString(lHdr.ECodeText, PChar(@lBuff[0]), esize); + CloseFile(myFile); + exit; + end; + //next: compressed header + lFileSz := round(lHdr.NIFTIhdr.vox_offset); + SetLength(lBuff, lFileSz); + UnGZip(lHdr.HdrFileName,bytep(lBuff),0,lFileSz); + i := sizeof(lHdr.NIFTIhdr); + extension[0] := ord(lBuff[i]); + if extension[0] = 0 then exit; + i := i + 4; + esize := ord(lBuff[i]) + ord(lBuff[i+1]) shl 8 + ord(lBuff[i+2]) shl 16 + ord(lBuff[i+3]) shl 24; + i := i + 4; + ecode := ord(lBuff[i]) + ord(lBuff[i+1]) shl 8 + ord(lBuff[i+2]) shl 16 + ord(lBuff[i+3]) shl 24; + {$IFDEF ENDIAN_BIG} + if (lHdr.DiskDataNativeEndian = true) then begin + swap4(esize); + swap4(ecode); + end; + {$ELSE} + if (lHdr.DiskDataNativeEndian = false) then begin + swap4(esize); + swap4(ecode); + end; + {$ENDIF} + //showmessage(inttostr(ord(lBuff[i]))+' '+inttostr(ord(lBuff[i+1])) ); + esize := esize - 8; //-8 as esize includes 8 bytes of esize and ecode themselves + lStart := sizeof(lHdr.NIFTIhdr)+12; + lEnd := lStart + esize; + if (lEnd > lFileSz) or (esize < 1) then exit; + SetString(lHdr.ECodeText, PChar(@lBuff[lStart]), esize); + //showmessage(inttostr(esize)); + +end; + +function NIFTIhdr_LoadHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +var + lHdrFile: file; + lOri: array [1..3] of single; + lBuff: Bytep; + lAHdr: TAnalyzeHdrSection; + lFileSz : int64; + swapEndian, isNativeNIfTI: boolean; + lReportedSz, lSwappedReportedSz,lHdrSz: Longint; + lExt: string; //1494 +begin + Result := false; //assume error + if lFilename = '' then exit; + lExt := UpCaseExt(lFilename); + if lExt = '.IMG' then + lFilename := changeFileExt(lFilename,'.hdr'); + if (lExt = '.BRIK') or (lExt = '.BRIK.GZ') then + lFilename := changeFileExtX(lFilename,'.HEAD'); + lExt := UpCaseExt(lFilename); + lHdrSz := sizeof(TniftiHdr); + lFileSz := FSize (lFilename); + if lFileSz = 0 then begin + ShowMsg('Unable to find NIFTI header named '+lFilename+'. Possible solution: make sure VAL file and images are in the same folder.'); + exit; + end; + swapEndian := false; + lHdr.gzBytesX := K_gzBytes_headerAndImageUncompressed; + lHdr.ImgFileName:= lFilename ; + lHdr.HdrFileName:= lFilename ; + lHdr.ECodeText:= ''; + + FileMode := fmOpenRead; //Set file access to read only + isNativeNIfTI := true; + if (lExt = '.MGH') or (lExt = '.MGZ') or (lExt = '.MHD') or (lExt = '.MHA') or (lExt = '.NRRD') or (lExt = '.NHDR') or (lExt = '.HEAD') then begin + result := readForeignHeader( lFilename, lHdr.NIFTIhdr,lHdr.gzBytesX, swapEndian); //we currently ignore result! + lHdr.ImgFileName := lFilename; + isNativeNIfTI := false; + end else begin //native NIfTI + if (lExt = '.NII.GZ') or (lExt = '.VOI') or (lExt = '.GZ') then begin//1388 + lBuff := @lHdr; + UnGZip(lFileName,lBuff,0,lHdrSz); //1388 + lHdr.gzBytesX := K_gzBytes_headerAndImageCompressed; + end else begin //if gzip else uncompressed + if (lFileSz < lHdrSz) then begin + showmsg('Error in reading NIFTI header: NIfTI headers need to be at least '+inttostr(lHdrSz)+ ' bytes: '+lFilename); + result := false; + end else begin + {$I-} + AssignFile(lHdrFile, lFileName); + FileMode := 0; { Set file access to read only } + Reset(lHdrFile, 1); + {$I+} + if ioresult <> 0 then begin + ShowMessage('Error in reading NIFTI header.'+inttostr(IOResult)); + CloseFile(lHdrFile); + FileMode := fmOpenReadWrite; + exit; + end; + BlockRead(lHdrFile, lHdr, lHdrSz); + CloseFile(lHdrFile); + if (lExt = '.HDR') then + lHdr.ImgFileName:= changefileext(lFilename,'.img'); + end; + end; + end; //native NIFTI + // showmessage('---Unable to read this image format '+inttostr(lHdr.NIFTIhdr.datatype)+' '+inttostr(lHdr.NIFTIhdr.bitpix)); + + FileMode := fmOpenReadWrite; + if (IOResult <> 0) then exit; + lReportedSz := lHdr.niftiHdr.HdrSz; + lSwappedReportedSz := lReportedSz; + swap4(lSwappedReportedSz); + lHdr.NIFTIVersion := 1; + if lReportedSz = lHdrSz then begin + lHdr.DiskDataNativeEndian := true; + end else if lSwappedReportedSz = lHdrSz then begin + lHdr.DiskDataNativeEndian := false; + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + end else begin + result := NIFTIhdr_LoadDCM (lFilename,lHdr); //2/2008 + if not result then + ShowMsg('Warning: the header file is not in NIfTi format [the first 4 bytes do not have the value 348]. Assuming big-endian data.'); + exit; + end; + if (lHdr.NIFTIhdr.dim[0] > 7) or (lHdr.NIFTIhdr.dim[0] < 1) then begin //only 1..7 dims, so this + ShowMsg('Illegal NIfTI Format Header: this header does not specify 1..7 dimensions.'); + exit; + end; + FixDataType(lHdr); + result := true; + + if IsNifTiMagic(lHdr.niftiHdr) then begin //must match MAGMA in nifti_img + lOri[1] := (lHdr.NIFTIhdr.dim[1]+1) div 2; + lOri[2] := (lHdr.NIFTIhdr.dim[2]+1) div 2; + lOri[3] := (lHdr.NIFTIhdr.dim[3]+1) div 2; + //TryQuat2Matrix(lHdr.NiftiHdr); + if (lHdr.NIFTIhdr.sform_code <= kNIFTI_XFORM_UNKNOWN) or (lHdr.NIFTIhdr.sform_code > kNIFTI_XFORM_MNI_152) then + TryQuat2Matrix(lHdr.NiftiHdr); + if emptymatrix(lHdr) then begin + + (*if HasQuat(lHdr.NiftiHdr) then + //HasQuat will specify + else*) begin + lHdr.NIFTIhdr.srow_x[0] := lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_x[1] := 0; + lHdr.NIFTIhdr.srow_x[2] := 0; + + lHdr.NIFTIhdr.srow_y[0] := 0; + lHdr.NIFTIhdr.srow_y[1] := lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_y[2] := 0; + lHdr.NIFTIhdr.srow_z[0] := 0; + lHdr.NIFTIhdr.srow_z[1] := 0; + lHdr.NIFTIhdr.srow_z[2] := lHdr.NIFTIhdr.pixdim[3]; + + lHdr.NIFTIhdr.srow_x[3] := -round(lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.pixdim[1]*0.5); + lHdr.NIFTIhdr.srow_y[3] := -round(lHdr.NIFTIhdr.dim[2]*lHdr.NIFTIhdr.pixdim[2]*0.5); + lHdr.NIFTIhdr.srow_z[3] := -round(lHdr.NIFTIhdr.dim[3]*lHdr.NIFTIhdr.pixdim[3]*0.5); + lHdr.NIFTIhdr.sform_code := 1; + end; + end; + + + if (lHdr.NIFTIhdr.srow_x[0] > 0) and (lHdr.NIFTIhdr.srow_y[1] > 0) and (lHdr.NIFTIhdr.srow_z[2] > 0) and + (lHdr.NIFTIhdr.srow_x[3] > 0) and (lHdr.NIFTIhdr.srow_y[3] > 0) and (lHdr.NIFTIhdr.srow_z[3] > 0) then begin + lHdr.NIFTIhdr.srow_x[3] := -lHdr.NIFTIhdr.srow_x[3]; + lHdr.NIFTIhdr.srow_y[3] := -lHdr.NIFTIhdr.srow_y[3]; + lHdr.NIFTIhdr.srow_z[3] := -lHdr.NIFTIhdr.srow_z[3]; + lHdr.NIFTIhdr.sform_code := 1; + end; //added 4Mar2006 -> corrects for improperly signed offset values... + lHdr.NIfTItransform := true;//NIfTI 12/2010 + end else begin //not NIFT: Analyze + + + lHdr.NIfTItransform := false;//Analyze + if not lHdr.DiskDataNativeEndian then begin + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + move(lHdr.niftiHdr,lAHdr,sizeof(lAHdr)); + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + lAHdr.Originator[1] := swap(lAHdr.Originator[1]); + lAHdr.Originator[2] := swap(lAHdr.Originator[2]); + lAHdr.Originator[3] := swap(lAHdr.Originator[3]); + end else + move(lHdr.niftiHdr,lAHdr,sizeof(lAHdr)); + lOri[1] :=lAHdr.Originator[1]; + lOri[2] := lAHdr.Originator[2]; + lOri[3] := lAHdr.Originator[3]; + if (lOri[1]=76) and (lOri[2]=116) and (lOri[3]=64) + and (lHdr.NIFTIhdr.dim[1]=151) and (lHdr.NIFTIhdr.dim[2]=188) and (lHdr.NIFTIhdr.dim[3]=154) then begin + lOri[2] := 111; + lOri[3] := 68; + end; //2/2008 Juelich fudge factor + + if ((lOri[1]<1) or (lOri[1]> lHdr.NIFTIhdr.dim[1])) and + ((lOri[2]<1) or (lOri[2]> lHdr.NIFTIhdr.dim[2])) and + ((lOri[3]<1) or (lOri[3]> lHdr.NIFTIhdr.dim[3])) then begin + lOri[1] := (lHdr.NIFTIhdr.dim[1]+1) / 2; //May07 use / not div + lOri[2] := (lHdr.NIFTIhdr.dim[2]+1) / 2; //May07 use / not div + lOri[3] := (lHdr.NIFTIhdr.dim[3]+1) / 2; //May07 use / not div : if 20 slices, then origin is between 10 and 11 + + end; + //showmessage(inttostr(sizeof(lAHdr))+' '+realtostr(lHdr.Ori[1],1)+' '+ realtostr(lHdr.Ori[2],1)+' '+realtostr(lHdr.Ori[3],1) ); + //DANGER: This header was from ANALYZE format, not NIFTI: make sure the rotation matrix is switched off + NIFTIhdr_SetIdentityMatrix(lHdr); + lHdr.NIFTIhdr.qform_code := kNIFTI_XFORM_UNKNOWN; + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_UNKNOWN; + //test - input estimated orientation matrix + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT ; + lHdr.NIFTIhdr.srow_x[0] := lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[1] := lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[2] := lHdr.NIFTIhdr.pixdim[3]; + + lHdr.NIFTIhdr.srow_x[3] := (lOri[1]-1)*-lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[3] := (lOri[2]-1)*-lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[3] := (lOri[3]-1)*-lHdr.NIFTIhdr.pixdim[3]; + //fx(lHdr.NIFTIhdr.srow_z[3],lOri[3]); + //end test + //Warning: some of the NIFTI float values that do exist as integer values in Analyze may have bizarre values like +INF, -INF, NaN + lHdr.NIFTIhdr.toffset := 0; + lHdr.NIFTIhdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.NIFTIhdr.dim_info := kNIFTI_SLICE_SEQ_UNKNOWN + (kNIFTI_SLICE_SEQ_UNKNOWN shl 2) + (kNIFTI_SLICE_SEQ_UNKNOWN shl 4); //Freq, Phase and Slice order all unknown + lHdr.NIFTIhdr.xyzt_units := kNIFTI_UNITS_UNKNOWN; + lHdr.NIFTIhdr.slice_duration := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p1 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p2 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p3 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.pixdim[0] := 1; //QFactor should be 1 or -1 + + end; + if (lHdr.NIFTIhdr.sform_code > kNIFTI_XFORM_UNKNOWN) and (lHdr.NIFTIhdr.sform_code <= kNIFTI_XFORM_MNI_152) then begin //DEC06 + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + end else begin + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.pixdim[1],0,0,(lOri[1]-1)*-lHdr.NIFTIhdr.pixdim[1], // 3D "graphics" matrix + 0,lHdr.NIFTIhdr.pixdim[2],0,(lOri[2]-1)*-lHdr.NIFTIhdr.pixdim[2], // 3D "graphics" matrix + 0,0,lHdr.NIFTIhdr.pixdim[3],(lOri[3]-1)*-lHdr.NIFTIhdr.pixdim[3], // 3D "graphics" matrix + 0,0,0,1); + end; + FixCrapMat(lHdr.Mat); + if swapEndian then + lHdr.DiskDataNativeEndian := false;//foreign data with swapped image data + if (isNativeNIfTI) and (lHdr.NIFTIhdr.vox_offset > sizeof(TNIFTIHdr)) then + ReadEcode(lHdr);//, swapEndian); + + //showmessage(inttostr(length(lHdr.ECodeText)) ); + //showmessage(lHdr.ECodeText); + //ReportMatrix(lHdr.mat); +end; //func NIFTIhdr_LoadHdr + +procedure NIFTIhdr_SetIdentityMatrix (var lHdr: TMRIcroHdr); //create neutral rotation matrix +var lInc: integer; +begin + with lHdr.NIFTIhdr do begin + for lInc := 0 to 3 do + srow_x[lInc] := 0; + + for lInc := 0 to 3 do + srow_y[lInc] := 0; + for lInc := 0 to 3 do + srow_z[lInc] := 0; + for lInc := 1 to 16 do + intent_name[lInc] := chr(0); + //next: create identity matrix: if code is switched on there will not be a problem + srow_x[0] := 1; + srow_y[1] := 1; + srow_z[2] := 1; + end; +end; //proc NIFTIhdr_IdentityMatrix + +procedure NIFTIhdr_ClearHdr (var lHdr: TMRIcroHdr); //put sensible default values into header +var lInc: byte; +begin + lHdr.NIFTIVersion := 1; + lHdr.UsesCustomPalette := false; + lHdr.UsesCustomPaletteRandomRainbow:= false; + lHdr.UsesLabels := false; + lHdr.DiskDataNativeEndian := true; + lHdr.LutFromZero := false; + lHdr.NIfTItransform := true;//assume genuine NIfTI, not Analyze + with lHdr.NIFTIhdr do begin + {set to 0} + HdrSz := sizeof(TNIFTIhdr); + for lInc := 1 to 10 do + Data_Type[lInc] := chr(0); + for lInc := 1 to 18 do + db_name[lInc] := chr(0); + extents:=0; + session_error:= 0; + regular:='r'{chr(0)}; + dim_info:=(0); + dim[0] := 4; + for lInc := 1 to 7 do + dim[lInc] := 0; + intent_p1 := 0; + intent_p2 := 0; + intent_p3 := 0; + intent_code:=0; + datatype:=0 ; + bitpix:=0; + slice_start:=0; + for lInc := 1 to 7 do + pixdim[linc]:= 1.0; + vox_offset:= 0.0; + scl_slope := 1.0; + scl_inter:= 0.0; + slice_end:= 0; + slice_code := 0; + xyzt_units := 10; + cal_max:= 0.0; + cal_min:= 0.0; + slice_duration:=0; + toffset:= 0; + glmax:= 0; + glmin:= 0; + for lInc := 1 to 80 do + descrip[lInc] := chr(0);{80 spaces} + for lInc := 1 to 24 do + aux_file[lInc] := chr(0);{80 spaces} + {below are standard settings which are not 0} + bitpix := 16;//vc16; {8bits per pixel, e.g. unsigned char 136} + DataType := 4;//vc4;{2=unsigned char, 4=16bit int 136} + Dim[0] := 3; + Dim[1] := 256; + Dim[2] := 256; + Dim[3] := 128; + Dim[4] := 1; {n vols} + Dim[5] := 1; + Dim[6] := 1; + Dim[7] := 1; + glMin := 0; + glMax := 255; + qform_code := kNIFTI_XFORM_UNKNOWN; + sform_code:= kNIFTI_XFORM_UNKNOWN; + quatern_b := 0; + quatern_c := 0; + quatern_d := 0; + qoffset_x := 0; + qoffset_y := 0; + qoffset_z := 0; + NIFTIhdr_SetIdentityMatrix(lHdr); + magic := kNIFTI_MAGIC_SEPARATE_HDR; + end; //with the NIfTI header... + with lHdr do begin + ScrnBufferItems := 0; + ImgBufferItems := 0; + ImgBufferBPP := 0; + RenderBufferItems := 0; + ScrnBuffer:= nil; + ImgBuffer := nil; + end; + +end; //proc NIFTIhdr_ClearHdr + +function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2: boolean): boolean; overload; +var lOutHdr: TNIFTIhdr; + lExt: string; + lF: File; + lOverwrite: boolean; +begin + lOverwrite := false; //will we overwrite existing file? + result := false; //assume failure + if lHdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then begin + lExt := UpCaseExt(lFileName); + if (lExt = '.GZ') or (lExt = '.NII.GZ') then begin + ShowMessage('Unable to save .nii.gz headers (first ungzip your image if you wish to edit the header)'); + exit; + end; + lFilename := changefileext(lFilename,'.nii') + end else + lFilename := changefileext(lFilename,'.hdr'); + if ((sizeof(TNIFTIhdr))> DiskFreeEx(lFileName)) then begin + ShowMessage('There is not enough free space on the destination disk to save the header. '+kCR+ + lFileName+ kCR+' Bytes Required: '+inttostr(sizeof(TNIFTIhdr)) ); + exit; + end; + if Fileexists(lFileName) then begin + if lAllowOverwrite then begin + {$IFNDEF GUI} + ShowMsg('Overwriting '+lFilename); + lOverwrite := true; + {$ELSE} + case MessageDlg('Do you wish to modify the existing file '+lFilename+'?', mtConfirmation,[mbYes, mbNo], 0) of { produce the message dialog box } + 6: lOverwrite := true; //6= mrYes, 7=mrNo... not sure what this is for Linux. Hardcoded as we do not include Form values + end;//case + {$ENDIF} + end else + showmessage('Error: the file '+lFileName+' already exists.'); + if not lOverwrite then Exit; + end; + if lHdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then + if lHdr.vox_offset < sizeof(TNIFTIHdr) then + lHdr.vox_offset := sizeof(TNIFTIHdr); //embedded images MUST start after header + if lHdr.magic = kNIFTI_MAGIC_SEPARATE_HDR then + lHdr.vox_offset := 0; //embedded images MUST start after header + if lSPM2 then begin //SPM2 does not recognize NIfTI - origin values will be wrong + lHdr.magic := 0; + end; + result := true; + move(lHdr, lOutHdr, sizeof(lOutHdr)); + Filemode := 1; + AssignFile(lF, lFileName); {WIN} + if lOverwrite then //this allows us to modify just the 348byte header of an existing NII header without touching image data + Reset(lF,sizeof(TNIFTIhdr)) + else + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lOutHdr, 1 {, NumWritten}); + CloseFile(lF); + Filemode := 2; +end; //func NIFTIhdr_SaveHdr + +function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TMRIcroHdr; lAllowOverwrite: boolean): boolean; overload; +var lOutHdr: TNIFTIhdr; + lExt: string; + lF: File; + lOverwrite: boolean; +begin + lOverwrite := false; //will we overwrite existing file? + result := false; //assume failure + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then begin + lExt := UpCaseExt(lFileName); + if (lExt = '.GZ') or (lExt = '.NII.GZ') then begin + showmessage('Unable to save .nii.gz headers (first ungzip your image if you wish to edit the header)'); + exit; + end; + lFilename := changefileext(lFilename,'.nii') + end else + lFilename := changefileext(lFilename,'.hdr'); + if ((sizeof(TNIFTIhdr))> DiskFreeEx(lFileName)) then begin + ShowMessage('There is not enough free space on the destination disk to save the header. '+kCR+ + lFileName+ kCR+' Bytes Required: '+inttostr(sizeof(TNIFTIhdr)) ); + exit; + end; + if Fileexists(lFileName) then begin + if lAllowOverwrite then begin + {$IFNDEF GUI} + ShowMsg('Overwriting '+lFilename); + lOverwrite := true; + {$ELSE} + case MessageDlg('Do you wish to modify the existing file '+lFilename+'?', mtConfirmation,[mbYes, mbNo], 0) of { produce the message dialog box } + 6: lOverwrite := true; //6= mrYes, 7=mrNo... not sure what this is for unix. Hardcoded as we do not include Form values + end;//case + {$ENDIF} + end else + showmessage('Error: the file '+lFileName+' already exists.'); + if not lOverwrite then Exit; + end; + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then + if lHdr.NIFTIhdr.vox_offset < sizeof(TNIFTIHdr) then + lHdr.NIFTIhdr.vox_offset := sizeof(TNIFTIHdr); //embedded images MUST start after header + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_SEPARATE_HDR then + lHdr.NIFTIhdr.vox_offset := 0; //embedded images MUST start after header + result := true; + move(lHdr.NIFTIhdr, lOutHdr, sizeof(lOutHdr)); + if lHdr.DiskDataNativeEndian= false then + NIFTIhdr_SwapBytes (lOutHdr);{swap to big-endianformat} + Filemode := 1; + AssignFile(lF, lFileName); {WIN} + if lOverwrite then //this allows us to modify just the 348byte header of an existing NII header without touching image data + Reset(lF,sizeof(TNIFTIhdr)) + else + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lOutHdr, 1 {, NumWritten}); + CloseFile(lF); + Filemode := 2; +end; //func NIFTIhdr_SaveHdr + +procedure NIFTIhdr_SwapBytes (var lAHdr: TNIFTIhdr); //Swap Byte order for the Analyze type +var + lInc: integer; +begin + with lAHdr do begin + swap4(hdrsz); + swap4(extents); + session_error := swap(session_error); + for lInc := 0 to 7 do + dim[lInc] := swap(dim[lInc]); + Xswap4r(intent_p1); + Xswap4r(intent_p2); + Xswap4r(intent_p3); + intent_code:= swap(intent_code); + datatype:= swap(datatype); + bitpix := swap(bitpix); + slice_start:= swap(slice_start); + for lInc := 0 to 7 do + Xswap4r(pixdim[linc]); + Xswap4r(vox_offset); + Xswap4r(scl_slope); + Xswap4r(scl_inter); + slice_end := swap(slice_end); + Xswap4r(cal_max); + Xswap4r(cal_min); + Xswap4r(slice_duration); + Xswap4r(toffset); + swap4(glmax); + swap4(glmin); + qform_code := swap(qform_code); + sform_code:= swap(sform_code); + Xswap4r(quatern_b); + Xswap4r(quatern_c); + Xswap4r(quatern_d); + Xswap4r(qoffset_x); + Xswap4r(qoffset_y); + Xswap4r(qoffset_z); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_x[lInc]); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_y[lInc]); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_z[lInc]); + end; //with NIFTIhdr +end; //proc NIFTIhdr_SwapBytes + +end. diff --git a/common/nifti_hdr.ppu b/common/nifti_hdr.ppu new file mode 100644 index 0000000..7295424 Binary files /dev/null and b/common/nifti_hdr.ppu differ diff --git a/common/nifti_types.o b/common/nifti_types.o new file mode 100644 index 0000000..08cedc0 Binary files /dev/null and b/common/nifti_types.o differ diff --git a/common/nifti_types.pas b/common/nifti_types.pas new file mode 100755 index 0000000..78ad791 --- /dev/null +++ b/common/nifti_types.pas @@ -0,0 +1,166 @@ +unit nifti_types; +{$IFDEF FPC} +{$mode objfpc}{$ENDIF}{$H+} +interface + +uses + Classes, SysUtils, define_types; + +type + TNIFTIhdr = packed record //Next: analyze Format Header structure + HdrSz : longint; //MUST BE 348 + Data_Type: array [1..10] of ansichar; //unused + db_name: array [1..18] of ansichar; //unused + extents: longint; //unused + session_error: smallint; //unused + regular: ansichar; ////unused: in Analyze 7.5 this must be 114 + dim_info: byte; //MRI slice order + dim: array[0..7] of smallint; //Data array dimensions + intent_p1, intent_p2, intent_p3: single; + intent_code: smallint; + datatype: smallint; + bitpix: smallint; + slice_start: smallint; + pixdim: array[0..7]of single; + vox_offset: single; + scl_slope: single;//scaling slope + scl_inter: single;//scaling intercept + slice_end: smallint; + slice_code: byte; //e.g. ascending + xyzt_units: byte; //e.g. mm and sec + cal_max,cal_min: single; //unused + slice_duration: single; //time for one slice + toffset: single; //time axis to shift + glmax, glmin: longint; //UNUSED + descrip: array[1..80] of ansichar; + aux_file: array[1..24] of ansichar; + qform_code, sform_code: smallint; + quatern_b,quatern_c,quatern_d, + qoffset_x,qoffset_y,qoffset_z: single; + srow_x: array[0..3]of single; + srow_y: array[0..3]of single; + srow_z: array[0..3]of single; + intent_name: array[1..16] of ansichar; + magic: longint; + end; //TNIFTIhdr Header Structure + TAnalyzeHdrSection = packed record //Next: analyze Format Header structure + Pad: array [1..253] of byte; + originator: array [1..5] of smallint; (* 105 + 10 *) +end;//TAnalyzeHdrSection Structure + + + const + + K_gzBytes_headerAndImageCompressed = -2; + K_gzBytes_onlyImageCompressed= -1; + K_gzBytes_headerAndImageUncompressed= 0; +//DataTypes +kDT_BINARY =1; // binary (1 bit/voxel) +kDT_UNSIGNED_CHAR =2; // unsigned char (8 bits/voxel) +kDT_UINT8 = kDT_UNSIGNED_CHAR; +kDT_SIGNED_SHORT =4; // signed short (16 bits/voxel) +kDT_INT16 = kDT_SIGNED_SHORT; +kDT_SIGNED_INT =8; // signed int (32 bits/voxel) +kDT_INT32 = kDT_SIGNED_INT; +kDT_FLOAT =16; // float (32 bits/voxel) +kDT_FLOAT32 = kDT_FLOAT; +kDT_COMPLEX =32; // complex (64 bits/voxel) +kDT_DOUBLE =64; // double (64 bits/voxel) +kDT_RGB =128; // RGB triple (24 bits/voxel) +kDT_INT8 =256; // signed char (8 bits) +kDT_UINT16 =512; // unsigned short (16 bits) +kDT_UINT32 =768; // unsigned int (32 bits) +kDT_INT64 =1024; // long long (64 bits) +kDT_UINT64 =1280; // unsigned long long (64 bits) +kDT_FLOAT128 =1536; // long double (128 bits) +kDT_COMPLEX128 =1792; // double pair (128 bits) +kDT_COMPLEX256 =2048; // long double pair (256 bits) +// slice_code values + kNIFTI_SLICE_SEQ_UNKNOWN = 0; + kNIFTI_SLICE_SEQ_INC = 1; + kNIFTI_SLICE_SEQ_DEC = 2; + kNIFTI_SLICE_ALT_INC = 3; + kNIFTI_SLICE_ALT_DEC = 4; + kNIFTI_SLICE_ALT_INC2 = 5; // 05 May 2005: RWCox + kNIFTI_SLICE_ALT_DEC2 = 6; // 05 May 2005: RWCox +kSliceOrderStr: array [kNIFTI_SLICE_SEQ_UNKNOWN..kNIFTI_SLICE_ALT_DEC2] of string = + ('UNKNOWN','ascending','descending' + , 'interleaved ascending (1,3..,2,4...)', 'interleaved ascending (N,N-2...N-1,N-3...)' + , 'Siemens-even interleaved ascending (2,4..,1,3...)', 'Siemens-even interleaved ascending (N-1,N-3...N,N-2...)' ); +//xyzt_units values: note 3bit space and 3bit time packed into single byte + kNIFTI_UNITS_UNKNOWN = 0; + kNIFTI_UNITS_METER = 1; + kNIFTI_UNITS_MM = 2; + kNIFTI_UNITS_MICRON = 3; + kNIFTI_UNITS_SEC = 8; + kNIFTI_UNITS_MSEC = 16; + kNIFTI_UNITS_USEC = 24; + kNIFTI_UNITS_HZ = 32; + kNIFTI_UNITS_PPM = 40; + //qform_code, sform_code values + kNIFTI_XFORM_UNKNOWN = 0; + kNIFTI_XFORM_SCANNER_ANAT = 1;//Scanner-based anatomical coordinates + kNIFTI_XFORM_ALIGNED_ANAT = 2; //Coordinates aligned to another file e.g. EPI coregistered to T1 + kNIFTI_XFORM_TALAIRACH = 3; //Talairach-Tournoux Atlas; (0,0,0)=AC, etc. + kNIFTI_XFORM_MNI_152 = 4; //MNI 152 normalized coordinates +{$IFDEF ENDIAN_BIG} + //Magic values + kswapNIFTI_MAGIC_SEPARATE_HDR = $0031696E;//$6E693100; + kswapNIFTI_MAGIC_EMBEDDED_HDR = $00312B6E;//$6E2B3100; + kNIFTI_MAGIC_DCM = $0044434D;//DCM + //byte-swapped magic values + kNIFTI_MAGIC_SEPARATE_HDR = $6E693100; + kNIFTI_MAGIC_EMBEDDED_HDR = $6E2B3100; +{$ELSE} + //Magic values + kNIFTI_MAGIC_SEPARATE_HDR = $0031696E;//$6E693100; + kNIFTI_MAGIC_EMBEDDED_HDR = $00312B6E;//$6E2B3100; + kNIFTI_MAGIC_DCM = $0044434D;//DCM + //byte-swapped magic values + kswapNIFTI_MAGIC_SEPARATE_HDR = $6E693100; + kswapNIFTI_MAGIC_EMBEDDED_HDR = $6E2B3100; +{$ENDIF} + //Statistics Intention + kNIFTI_INTENT_NONE =0; +kNIFTI_INTENT_CORREL =2; +kNIFTI_INTENT_TTEST =3; +kNIFTI_INTENT_FTEST =4; +kNIFTI_INTENT_ZSCORE =5; +kNIFTI_INTENT_CHISQ =6; +kNIFTI_INTENT_BETA =7; +kNIFTI_INTENT_BINOM =8; +kNIFTI_INTENT_GAMMA =9; +kNIFTI_INTENT_POISSON =10; +kNIFTI_INTENT_NORMAL =11; +kNIFTI_INTENT_FTEST_NONC =12; +kNIFTI_INTENT_CHISQ_NONC =13; +kNIFTI_INTENT_LOGISTIC =14; +kNIFTI_INTENT_LAPLACE =15; +kNIFTI_INTENT_UNIFORM =16; +kNIFTI_INTENT_TTEST_NONC =17; +kNIFTI_INTENT_WEIBULL =18; +kNIFTI_INTENT_CHI =19; +kNIFTI_INTENT_INVGAUSS =20; +kNIFTI_INTENT_EXTVAL =21; +kNIFTI_INTENT_PVAL =22; +NIFTI_INTENT_LOGPVAL =23; +NIFTI_INTENT_LOG10PVAL =24; +kNIFTI_LAST_STATCODE = 24;//kNIFTI_INTENT_PVAL; +kNIFTI_INTENT_ESTIMATE =1001; +kNIFTI_FIRST_NONSTATCODE = kNIFTI_INTENT_ESTIMATE; +kNIFTI_INTENT_LABEL =1002; +kNIFTI_INTENT_NEURONAME =1003; +kNIFTI_INTENT_GENMATRIX =1004; +kNIFTI_INTENT_SYMMATRIX =1005; +kNIFTI_INTENT_DISPVECT =1006; +kNIFTI_INTENT_VECTOR =1007; +kNIFTI_INTENT_POINTSET =1008; +kNIFTI_INTENT_TRIANGLE =1009; +kNIFTI_INTENT_QUATERNION =1010; + +implementation + + + +end. + diff --git a/common/nifti_types.ppu b/common/nifti_types.ppu new file mode 100644 index 0000000..30da00c Binary files /dev/null and b/common/nifti_types.ppu differ diff --git a/common/notgui.inc b/common/notgui.inc new file mode 100755 index 0000000..88e92bb --- /dev/null +++ b/common/notgui.inc @@ -0,0 +1 @@ +{$DEFINE notGUI} //use GUI if you are using a graphic user interface - anything else for console applications diff --git a/common/userdir.o b/common/userdir.o new file mode 100644 index 0000000..570d37b Binary files /dev/null and b/common/userdir.o differ diff --git a/common/userdir.pas b/common/userdir.pas new file mode 100755 index 0000000..187873a --- /dev/null +++ b/common/userdir.pas @@ -0,0 +1,220 @@ +unit userdir; +//returns directory where user has read/write permissions... +{$IFDEF FPC} {$mode delphi}{$H+} {$ENDIF} +interface +//returns number of cores: a computer with two dual cores will report 4 +function IniName: string; +function DefaultsDir (lSubFolder: string): string; +function UserDataFolder: string; //uses shlobj + +implementation +{$Include isgui.inc} + +{$IFDEF UNIX} +uses Process, SysUtils,classes,IniFiles, +{$IFDEF GUI}dialogs;{$ELSE} dialogsx;{$ENDIF} + +function UserDataFolder: string; +begin + result :=expandfilename('~/'); +end; + + +function FileNameNoExt (lFilewExt:String): string; +//remove final extension +var + lLen,lInc: integer; + lName: String; +begin + lName := ''; + lLen := length(lFilewExt); + lInc := lLen+1; + if lLen > 0 then begin + repeat + dec(lInc); + until (lFileWExt[lInc] = '.') or (lInc = 1); + end; + if lInc > 1 then + for lLen := 1 to (lInc - 1) do + lName := lName + lFileWExt[lLen] + else + lName := lFilewExt; //no extension + Result := lName; +end; + +function DefaultsDir (lSubFolder: string): string; +//for Linux: DefaultsDir is ~/appname/SubFolder/, e.g. /home/username/mricron/subfolder/ +//Note: Final character is pathdelim +const + pathdelim = '/'; +var + lBaseDir: string; +begin + lBaseDir := GetEnvironmentVariable ('HOME')+pathdelim+'.'+ FileNameNoExt(ExtractFilename(paramstr(0) ) ); + if not DirectoryExists(lBaseDir) then begin + {$I-} + MkDir(lBaseDir); + if IOResult <> 0 then begin + //Msg('Unable to create new folder '+lBaseDir); + end; + {$I+} + end; + lBaseDir := lBaseDir+pathdelim; + if lSubFolder <> '' then begin + lBaseDir := lBaseDir + lSubFolder; + if not DirectoryExists(lBaseDir) then begin + {$I-} + MkDir(lBaseDir); + if IOResult <> 0 then begin + //you may want to show an error, e.g. showmessage('Unable to create new folder '+lBaseDir); + exit; + end; + {$I+} + end; + result := lBaseDir + pathdelim; + end else + result := lBaseDir; +end; + +function IniName: string; +begin + result := DefaultsDir('')+FileNameNoExt(extractfilename(paramstr(0)))+'.ini'; +end; +{$ELSE} //If UNIX ELSE NOT Unix +uses + SysUtils, Windows,shlobj; + +//for administrators, we can write to folder with executable, otherwise we will save data to the user's AppDataFolder +function AppDataFolder: string; //uses shlobj +{$IFDEF FPC} const CSIDL_APPDATA = 26; {$ENDIF} +var + Path : pchar; + idList : PItemIDList; +begin + GetMem(Path, MAX_PATH); + SHGetSpecialFolderLocation(0, CSIDL_APPDATA , idList); + SHGetPathFromIDList(idList, Path); + Result := string(Path); + FreeMem(Path); +end; + +function UserDataFolder: string; //uses shlobj +var + PIDL : PItemIDList; + Folder : array[0..MAX_PATH] of Char; + const CSIDL_PERSONAL = $0005; +begin +SHGetSpecialFolderLocation(0, CSIDL_PERSONAL, PIDL); +SHGetPathFromIDList(PIDL, Folder); +result :=Folder; +end; + +(*function UserDataFolder: string; //uses shlobj +var + Path : pchar; + idList : PItemIDList; +begin + GetMem(Path, MAX_PATH); + SHGetSpecialFolderLocation(0, csidl_Personal , idList); + SHGetPathFromIDList(idList, Path); + Result := string(Path); + FreeMem(Path); +end; *) + +function IsAdmin: Boolean; +const + SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = + (Value: (0, 0, 0, 0, 0, 5)); + SECURITY_BUILTIN_DOMAIN_RID = $00000020; + DOMAIN_ALIAS_RID_ADMINS = $00000220; +var + hAccessToken: THandle; + ptgGroups: PTokenGroups; + dwInfoBufferSize: DWORD; + psidAdministrators: PSID; + x: Integer; + bSuccess: BOOL; + LastError: integer; +begin + + if Win32Platform <> VER_PLATFORM_WIN32_NT then + begin + Result := True; + exit; + end; + + Result := False; + bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, + hAccessToken); + if not bSuccess then + begin + if GetLastError = ERROR_NO_TOKEN then + bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, + hAccessToken); + end; + if bSuccess then + begin + GetMem(ptgGroups, 1024); + {$IFDEF FPC} + bSuccess := GetTokenInformation(hAccessToken, TokenGroups, + ptgGroups, 1024, @dwInfoBufferSize); + {$ELSE} + bSuccess := GetTokenInformation(hAccessToken, TokenGroups, + ptgGroups, 1024, dwInfoBufferSize); + {$ENDIF} + LastError := GetLastError; + if not bSuccess then begin + //you may want to show an error message.. + //showmessage(format('GetLastError %d',[LastError])); + end; + CloseHandle(hAccessToken); + if bSuccess then + begin + AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, + SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, + 0, 0, 0, 0, 0, 0, psidAdministrators); + {$R-} + for x := 0 to ptgGroups.GroupCount - 1 do + if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then + begin + Result := True; + break; + end; + {$R+} + FreeSid(psidAdministrators); + end; + FreeMem(ptgGroups); + end; +end; + + +function IniName: string; +//only administrators can write to c:\program files -use AppDataFolder for non-Administrators +begin + if isAdmin then + result := changefileext(paramstr(0),'.ini') + else + result := AppDataFolder+'\'+changefileext(extractfilename(paramstr(0)),'.ini'); +end; + +function DefaultsDir (lSubFolder: string): string; +const + pathdelim = '\'; +//for Administrators: DefaultsDir is in the location of the executable, e.g. c:\program files\mricron\subfolder\ +//for non-Administrators, the AppDataFolder is returned +//Note: Final character is pathdelim +begin + result := extractfilepath(IniName); + if length(result) < 1 then exit; + if result[length(result)] <> pathdelim then + result := result + pathdelim; + if lSubFolder = '' then + exit; + result := result + lSubFolder; + if result[length(result)] <> pathdelim then + result := result + pathdelim; + +end; +{$ENDIF} + +end. diff --git a/common/userdir.ppu b/common/userdir.ppu new file mode 100644 index 0000000..6f51fd4 Binary files /dev/null and b/common/userdir.ppu differ diff --git a/crop.pas b/crop.pas new file mode 100755 index 0000000..7809103 --- /dev/null +++ b/crop.pas @@ -0,0 +1,263 @@ +unit crop; + +interface +function CropNIfTI(lL,lR,lA,lP,lD,lV: integer):boolean; +function GrowNeck (lFilename: string; lVox: integer): boolean; + +implementation + +uses nifti_hdr_view, nifti_hdr, nifti_img,define_types, GraphicsMathLibrary,dialogs, nifti_img_view, nifti_types; + + // nifti_img_view, nifti_img,nifti_hdr, nifti_hdr_view,{ShellAPI,}ShlObj,periutils, reslice_fsl; +procedure NIFTIhdr_SlicesToCoord (var lHdr: TNIFTIhdr; lXslice,lYslice,lZslice: integer; var lXmm,lYmm,lZmm: single); +//ignores origin offset +begin + lXmm := (lHdr.srow_x[0]*lXslice)+ (lHdr.srow_x[1]*lYslice)+(lHdr.srow_x[2]*lzslice); + lYmm := (lHdr.srow_y[0]*lXslice)+ (lHdr.srow_y[1]*lYslice)+(lHdr.srow_y[2]*lzslice); + lZmm := (lHdr.srow_z[0]*lXslice)+ (lHdr.srow_z[1]*lYslice)+(lHdr.srow_z[2]*lzslice); +end; + + + +function CropNIfTI(lL,lR,lA,lP,lD,lV: integer):boolean; +//to do : data swapping (errors on detection and writing zero in reverse order) +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lXmm,lYmm,lZmm: single; + lMat: TMatrix; + lOutPos,lSlice,lVol,lOutVolBytes,lInVolBytes,lImgSamples,lInc, + lX,lY,lZ,lBPP, lB, + lInZOffset,lInYOffset,lInSliceSz,lInXSz,lInPos,lImgOffset: integer; + lBuffer: bytep; + lWordX: Word; + lSPM2: boolean; + lOutF,lInF: File; + lACrop,lPCrop,lDorsalCrop,lVentralCrop,lLCrop,lRCrop: integer; + lByteSwap: boolean; +begin + result := false; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (gBGImg.ScrnDim[3] < 2) or (gBGImg.ScrnMM[3] = 0) then begin + showmessage('Please load a 3D background image for neck removal.'); + exit; + end; + if (gBGImg.Resliced) then begin + showmessage('You must switch reslicing OFF (Help/Preferences) for image cropping.'); + exit; + end; + lInHdr := gMRIcroOverlay[kBGOverlayNum].NIFTIHdr; + //check orthogonal alignment.... + if lInHdr.dim[4] > 1 then begin + Showmessage('Only Cropping 1st 3D image (reorienting 4D could disrupt slice timing and diffusion directions.'); + //exit; + end; + //Next create reordered or trimmed image in the correct format + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + Showmessage('Crop 3D unsupported datatype.'); + exit; + end; + end; + lOutHdr := lInHdr; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]; + lBPP := (lInHdr.bitpix div 8); //bytes per pixel + lDorsalCrop := lD; + lVentralCrop := lV; + lLCrop := lL; + lRCrop := lR; + lACrop := lA; + lPCrop := lP; + //FreeMem(lBuffUnaligned); + if (lDorsalCrop = 0) and (lVentralCrop = 0) + and (lLCrop = 0) and (lRCrop = 0) + and (lACrop = 0) and (lPCrop = 0) then begin + Showmessage('Grow 3D quitting: no need to add or delete slices.'); + //Freemem(lSrcBuffer); + end; + if (lDorsalCrop < 0) or (lVentralCrop < 0) + or (lLCrop < 0) or (lRCrop < 0) + or (lACrop < 0) or (lPCrop < 0) then begin + Showmessage('Grow 3D quitting: negative values should be impossible.'); + //Freemem(lSrcBuffer); + end; + //next compute size of cropped volume + lInVolBytes := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lBPP; + lOutHdr.Dim[1] := lInHdr.Dim[1]-lLCrop-lRCrop; + lOutHdr.Dim[2] := lInHdr.Dim[2]-lACrop-lPCrop; + lOutHdr.Dim[3] := lInHdr.Dim[3]-lDorsalCrop-lVentralCrop; + lOutVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*lBPP; + //next: readjust origin to take into account removed slices + //REQUIRES images to be aligned to nearest orthogonal to canonical space [1 0 0; 0 1 0; 0 0 1] + NIFTIhdr_SlicesToCoord (lInHdr,lLCrop,lPCrop,lVentralCrop, lXmm,lYmm,lZmm); + lOutHdr.srow_x[3] := lInHdr.srow_x[3] + lXmm; + lOutHdr.srow_y[3] := lInHdr.srow_y[3] + lYmm; + lOutHdr.srow_z[3] := lInHdr.srow_z[3] + lZmm; + lMat := Matrix3D ( + lOutHdr.srow_x[0], lOutHdr.srow_x[1], lOutHdr.srow_x[2], lOutHdr.srow_x[3], + lOutHdr.srow_y[0], lOutHdr.srow_y[1], lOutHdr.srow_y[2], lOutHdr.srow_y[3], + lOutHdr.srow_z[0], lOutHdr.srow_z[1], lOutHdr.srow_z[2], lOutHdr.srow_z[3], + 0, 0, 0, 1); + nifti_mat44_to_quatern( lMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + lXmm, lYmm, lZmm, lOutHdr.pixdim[0]{QFac}); + //note we write to a different buffer, as we may need to grow output + //no need to byteswap data - we will save in the save format as stored + lOutPos := 0; + lInSliceSz := lInHdr.dim[1]*lInHdr.dim[2]*lBPP; + lInXSz := lInHdr.dim[1]*lBPP; + GetMem(lBuffer,lOutVolBytes); + //Move(gMRIcroOverlay[kBGOverlayNum].ImgBuffer^,lTempBuf^,gBGImg.VOIUndoVolItems); + + + for lZ := 1 to lOutHdr.dim[3] do begin + lInZOffset := (lVentralCrop+lZ-1) * lInSliceSz; + if lInZOffset < 0 then + lInZOffset := 0; + for lY := 1 to lOutHdr.dim[2] do begin + lInYOffset := ((lPCrop+lY-1) * lInXSz) + lInZOffset + (lLCrop*lBPP); + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lBPP) + lInYOffset + lB; + if (lInPos < 1) or (lInPos > lInVolBytes) then + lBuffer^[lOutPos] := 128 + else + lBuffer^[lOutPos] := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lInPos]; + end; + end; + end; //for Y + end; //for Z + lOutname := ChangeFilePrefix (gMRIcroOverlay[kBGOverlayNum].HdrFileName,'c'); + //result := SaveNIfTICore (lOutName, lSrcBuffer, kNIIImgOffset+1, lOutHdr, lPrefs,lByteSwap); + result := gBGImg.UseReorientHdr; + gBGImg.UseReorientHdr := false; + SaveAsVOIorNIFTI (lBuffer,lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3], lBPP,1, false, lOutHdr, lOutname); + gBGImg.UseReorientHdr := result; + result := true; + Freemem(lBuffer); +end; + + +function GrowNeck (lFilename: string; lVox: integer): boolean; +//to do : data swapping (errors on detection and writing zero in reverse order) +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lXmm,lYmm,lZmm: single; + lMat: TMatrix; + lOutPos,lSlice,lVol,lOutVolBytes,lInVolBytes,lImgSamples,lInc, + lX,lY,lZ,lBPP, lB, + lVolOffset,lInZOffset,lInYOffset,lInSliceSz,lInXSz,lInPos,lImgOffset: integer; + lBuffer: bytep; + lWordX: Word; + lSPM2: boolean; + lOutF,lInF: File; + lACrop,lPCrop,lDorsalCrop,lVentralCrop,lLCrop,lRCrop: integer; + lByteSwap: boolean; +begin + gBGImg.Prompt4DVolume := false; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kBGOverlayNum]) then exit; + gBGImg.Prompt4DVolume := true; + if not OpenImg(gBGImg,gMRIcroOverlay[kBGOverlayNum],false,false,false,false,true {4D!}) then exit; + lInHdr := gMRIcroOverlay[kBGOverlayNum].NIFTIHdr; + result := false; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferItems < 1) or (lInHdr.dim[1] < 2) or (lInHdr.dim[2] < 2) then begin + showmessage('Please load a 3D background image for neck removal.'); + exit; + end; + if (gBGImg.Resliced) then begin + showmessage('You must switch reslicing OFF (Help/Preferences) for image cropping.'); + exit; + end; + + //check orthogonal alignment.... + lOutHdr := lInHdr; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]; + lBPP := (lInHdr.bitpix div 8); //bytes per pixel + lDorsalCrop := 0; + lVentralCrop := lVox; + lLCrop := 0; + lRCrop := 0; + lACrop := 0; + lPCrop := 0; + //FreeMem(lBuffUnaligned); + if (lDorsalCrop = 0) and (lVentralCrop = 0) + and (lLCrop = 0) and (lRCrop = 0) + and (lACrop = 0) and (lPCrop = 0) then begin + Showmessage('Grow 3D quitting: no need to add or delete slices.'); + //Freemem(lSrcBuffer); + end; + if (lDorsalCrop < 0) or (lVentralCrop < 0) + or (lLCrop < 0) or (lRCrop < 0) + or (lACrop < 0) or (lPCrop < 0) then begin + Showmessage('Grow 3D quitting: negative values should be impossible.'); + //Freemem(lSrcBuffer); + end; + //next compute size of cropped volume + + lOutHdr.Dim[1] := lInHdr.Dim[1]-lLCrop-lRCrop; + lOutHdr.Dim[2] := lInHdr.Dim[2]-lACrop-lPCrop; + lOutHdr.Dim[3] := lInHdr.Dim[3]-lDorsalCrop-lVentralCrop; + + //next: readjust origin to take into account removed slices + //REQUIRES images to be aligned to nearest orthogonal to canonical space [1 0 0; 0 1 0; 0 0 1] + NIFTIhdr_SlicesToCoord (lInHdr,lLCrop,lPCrop,lVentralCrop, lXmm,lYmm,lZmm); + lOutHdr.srow_x[3] := lInHdr.srow_x[3] + lXmm; + lOutHdr.srow_y[3] := lInHdr.srow_y[3] + lYmm; + lOutHdr.srow_z[3] := lInHdr.srow_z[3] + lZmm; + lMat := Matrix3D ( + lOutHdr.srow_x[0], lOutHdr.srow_x[1], lOutHdr.srow_x[2], lOutHdr.srow_x[3], + lOutHdr.srow_y[0], lOutHdr.srow_y[1], lOutHdr.srow_y[2], lOutHdr.srow_y[3], + lOutHdr.srow_z[0], lOutHdr.srow_z[1], lOutHdr.srow_z[2], lOutHdr.srow_z[3], + 0, 0, 0, 1); + nifti_mat44_to_quatern( lMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + lXmm, lYmm, lZmm, lOutHdr.pixdim[0]{QFac}); + //note we write to a different buffer, as we may need to grow output + //no need to byteswap data - we will save in the save format as stored + lOutPos := 0; + lInSliceSz := lInHdr.dim[1]*lInHdr.dim[2]*lBPP; + lInXSz := lInHdr.dim[1]*lBPP; + lInVolBytes := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lInHdr.dim[4]*lBPP; + lOutVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*lOutHdr.dim[4]*lBPP; + GetMem(lBuffer,lOutVolBytes); + //Move(gMRIcroOverlay[kBGOverlayNum].ImgBuffer^,lTempBuf^,gBGImg.VOIUndoVolItems); + + for lVol := 1 to lOutHdr.dim[4] do begin + lVolOffset := (lVol-1) * lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]* lBPP; + for lZ := 1 to lOutHdr.dim[3] do begin + + if lZ > -lVentralCrop then + lInZOffset := ((lVentralCrop+lZ-1) * lInSliceSz) + else + lInZOffset := 0; + for lY := 1 to lOutHdr.dim[2] do begin + lInYOffset := ((lPCrop+lY-1) * lInXSz) + lInZOffset + (lLCrop*lBPP); + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lBPP) + lInYOffset + lB; + if (lInPos < 1) or (lInPos > lInVolBytes) then + lBuffer^[lOutPos] := 0 + else + lBuffer^[lOutPos] := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lInPos+lVolOffset]; + end; + end; + end; //for Y + end; //for Z + end; //lvol + lOutname := ChangeFilePrefix (gMRIcroOverlay[kBGOverlayNum].HdrFileName,'c'); + //result := SaveNIfTICore (lOutName, lSrcBuffer, kNIIImgOffset+1, lOutHdr, lPrefs,lByteSwap); + result := gBGImg.UseReorientHdr; + gBGImg.UseReorientHdr := false; + SaveAsVOIorNIFTI (lBuffer,lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3], lBPP,lOutHdr.dim[4], false, lOutHdr, lOutname); + gBGImg.UseReorientHdr := result; + result := true; + Freemem(lBuffer); +end; + + +end. \ No newline at end of file diff --git a/crop_old.pas b/crop_old.pas new file mode 100755 index 0000000..ac137b8 --- /dev/null +++ b/crop_old.pas @@ -0,0 +1,190 @@ +unit crop; + +interface +function CropNIfTI(lL,lR,lA,lP,lD,lV: integer):boolean; + + +implementation + +uses nifti_hdr, nifti_img,define_types, GraphicsMathLibrary,dialogs, nifti_img_view; + +procedure NIFTIhdr_SlicesToCoord (var lHdr: TNIFTIhdr; lXslice,lYslice,lZslice: integer; var lXmm,lYmm,lZmm: single); +//ignores origin offset +begin + lXmm := (lHdr.srow_x[0]*lXslice)+ (lHdr.srow_x[1]*lYslice)+(lHdr.srow_x[2]*lzslice); + lYmm := (lHdr.srow_y[0]*lXslice)+ (lHdr.srow_y[1]*lYslice)+(lHdr.srow_y[2]*lzslice); + lZmm := (lHdr.srow_z[0]*lXslice)+ (lHdr.srow_z[1]*lYslice)+(lHdr.srow_z[2]*lzslice); +end; + + + +function CropNIfTI(lL,lR,lA,lP,lD,lV: integer):boolean; +//to do : data swapping (errors on detection and writing zero in reverse order) +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lXmm,lYmm,lZmm: single; + lMat: TMatrix; + lOutPos,lSlice,lVol,lVolBytes,lImgSamples,lInc, + lX,lY,lZ,lBPP, lB, + lInZOffset,lInYOffset,lInSliceSz,lInXSz,lInPos,lImgOffset: integer; + lBuffer: bytep; + (*lSrcBuffer,lBuffer, lBuffUnaligned: bytep; + l32Buf,lImgBuffer: singlep; + l16Buf : SmallIntP; + l32BufI : LongIntP;*) + lWordX: Word; + lSPM2: boolean; + lOutF,lInF: File; + lACrop,lPCrop,lDorsalCrop,lVentralCrop,lLCrop,lRCrop: integer; + lByteSwap: boolean; +begin + result := false; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (gBGImg.ScrnDim[3] < 2) or (gBGImg.ScrnMM[3] = 0) then begin + showmessage('Please load a 3D background image for neck removal.'); + exit; + end; + if (gBGImg.Resliced) then begin + showmessage('You must switch reslicing OFF (Help/Preferences) for image cropping.'); + exit; + end; + lInHdr := gMRIcroOverlay[kBGOverlayNum].NIFTIHdr; + //check orthogonal alignment.... + if lInHdr.dim[4] > 1 then begin + Showmessage('Only able to Crop 3D images (reorienting 4D could disrupt slice timing and diffusion directions.'); + exit; + end; + //Next create reordered or trimmed image in the correct format + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + Showmessage('Crop 3D unsupported datatype.'); + exit; + end; + end; + + //Msg('Cropping NIfTI/Analyze image '+lFileName); + lOutHdr := lInHdr; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]; + lBPP := (lInHdr.bitpix div 8); //bytes per pixel + (*lVolBytes := lImgSamples*lBPP; + + //Msg('Automatically Cropping image'); + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + GetMem(lBuffUnaligned ,(sizeof(single)*lImgSamples) + 16); + {$IFDEF FPC} + lImgBuffer := align(lBuffUnaligned,16); + {$ELSE} + lImgBuffer := SingleP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + case lInHdr.datatype of + kDT_UNSIGNED_CHAR : begin //8 bit + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := lBuffer^[lInc]; + end; + kDT_SIGNED_SHORT{,kDT_UINT16}: begin //16-bit int + l16Buf := SmallIntP(lBuffer ); + if lByteSwap then begin + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := Swap(l16Buf^[lInc]); + end else begin + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := l16Buf^[lInc]; + end; + end;//16bit + kDT_SIGNED_INT: begin + l32Buf := SingleP(lBuffer ); + if lByteSwap then //unswap and convert integer to float + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := (Swap4r4i(l32Buf^[lInc])) + else //convert integer to float + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := Conv4r4i(l32Buf^[lInc]); + end; //32-bit int + kDT_FLOAT: begin + l32Buf := SingleP(lBuffer); + for lInc := 1 to lImgSamples do + lImgBuffer[lInc] := l32Buf[lInc]; + if lByteSwap then + for lInc := 1 to lImgSamples do + pswap4r(lImgBuffer^[lInc]); //faster as procedure than function see www.optimalcode.com + for lInc := 1 to lImgSamples do + if specialsingle(lImgBuffer^[lInc]) then lImgBuffer^[lInc] := 0.0; + //invert= for lInc := 1 to lImgSamples do l32Buf[lInc] := -l32Buf[lInc]; + end; //32-bit float + else begin + Showmessage('Serious error: format not supported by Crop3D.'); + exit; + end; + end; //case *) + + lDorsalCrop := lD; + lVentralCrop := lV; + lLCrop := lL; + lRCrop := lR; + lACrop := lA; + lPCrop := lP; + //FreeMem(lBuffUnaligned); + if (lDorsalCrop = 0) and (lVentralCrop = 0) + and (lLCrop = 0) and (lRCrop = 0) + and (lACrop = 0) and (lPCrop = 0) then begin + Showmessage('Crop 3D quitting: no need to delete slices.'); + //Freemem(lSrcBuffer); + end; + if (lDorsalCrop < 0) or (lVentralCrop < 0) + or (lLCrop < 0) or (lRCrop < 0) + or (lACrop < 0) or (lPCrop < 0) then begin + Showmessage('Crop 3D quitting: negative values should be impossible.'); + //Freemem(lSrcBuffer); + end; + //next compute size of cropped volume + lOutHdr.Dim[1] := lInHdr.Dim[1]-lLCrop-lRCrop; + lOutHdr.Dim[2] := lInHdr.Dim[2]-lACrop-lPCrop; + lOutHdr.Dim[3] := lInHdr.Dim[3]-lDorsalCrop-lVentralCrop; + lVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*lBPP; + //next: readjust origin to take into account removed slices + //REQUIRES images to be aligned to nearest orthogonal to canonical space [1 0 0; 0 1 0; 0 0 1] + NIFTIhdr_SlicesToCoord (lInHdr,lLCrop,lPCrop,lVentralCrop, lXmm,lYmm,lZmm); + lOutHdr.srow_x[3] := lInHdr.srow_x[3] + lXmm; + lOutHdr.srow_y[3] := lInHdr.srow_y[3] + lYmm; + lOutHdr.srow_z[3] := lInHdr.srow_z[3] + lZmm; + lMat := Matrix3D ( + lOutHdr.srow_x[0], lOutHdr.srow_x[1], lOutHdr.srow_x[2], lOutHdr.srow_x[3], + lOutHdr.srow_y[0], lOutHdr.srow_y[1], lOutHdr.srow_y[2], lOutHdr.srow_y[3], + lOutHdr.srow_z[0], lOutHdr.srow_z[1], lOutHdr.srow_z[2], lOutHdr.srow_z[3], + 0, 0, 0, 1); + nifti_mat44_to_quatern( lMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + lXmm, lYmm, lZmm, lOutHdr.pixdim[0]{QFac}); + //note we write and read to the same buffer - we will always SHRINK output + //no need to byteswap data - we will save in the save format as stored + lOutPos := 0; + lInSliceSz := lInHdr.dim[1]*lInHdr.dim[2]*lBPP; + lInXSz := lInHdr.dim[1]*lBPP; + GetMem(lBuffer,lVolBytes); + //Move(gMRIcroOverlay[kBGOverlayNum].ImgBuffer^,lTempBuf^,gBGImg.VOIUndoVolItems); + + + for lZ := 1 to lOutHdr.dim[3] do begin + lInZOffset := (lVentralCrop+lZ-1) * lInSliceSz; + for lY := 1 to lOutHdr.dim[2] do begin + lInYOffset := ((lPCrop+lY-1) * lInXSz) + lInZOffset + (lLCrop*lBPP); + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lBPP) + lInYOffset + lB; + lBuffer^[lOutPos] := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lInPos]; + end; + end; + end; //for Y + end; //for Z + lOutname := ChangeFilePrefix (gMRIcroOverlay[kBGOverlayNum].HdrFileName,'c'); + //result := SaveNIfTICore (lOutName, lSrcBuffer, kNIIImgOffset+1, lOutHdr, lPrefs,lByteSwap); + SaveAsVOIorNIFTI (lBuffer,lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3], lBPP,1, false, lOutHdr, lOutname); + result := true; + Freemem(lBuffer); +end; + + +end. \ No newline at end of file diff --git a/cropedges.lfm b/cropedges.lfm new file mode 100755 index 0000000..0d74883 --- /dev/null +++ b/cropedges.lfm @@ -0,0 +1,115 @@ +object CropEdgeForm: TCropEdgeForm + Left = 562 + Height = 142 + Top = 209 + Width = 398 + ActiveControl = DEdit + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'Crop Edges' + ClientHeight = 142 + ClientWidth = 398 + Constraints.MaxHeight = 321 + Constraints.MaxWidth = 398 + Constraints.MinHeight = 12 + Constraints.MinWidth = 398 + OnCreate = FormCreate + OnHide = FormHide + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.0.2.0' + object CancelBtn: TSpeedButton + Left = 320 + Height = 25 + Top = 104 + Width = 65 + Caption = 'Cancel' + NumGlyphs = 0 + OnClick = CancelBtnClick + end + object ApplyBtn: TSpeedButton + Left = 256 + Height = 25 + Top = 104 + Width = 65 + Caption = 'Apply' + NumGlyphs = 0 + OnClick = ApplyBtnClick + end + object CropFileSzBtn: TSpeedButton + Left = 136 + Height = 25 + Top = 104 + Width = 105 + Caption = 'Save Cropped' + NumGlyphs = 0 + OnClick = CropFileSzBtnClick + end + object DEdit: TSpinEdit + Left = 57 + Height = 21 + Top = 8 + Width = 72 + MaxValue = 255 + OnChange = CropEditChange + TabOrder = 0 + Value = 8 + end + object PEdit: TSpinEdit + Left = 8 + Height = 21 + Top = 41 + Width = 72 + MaxValue = 255 + OnChange = CropEditChange + TabOrder = 1 + Value = 8 + end + object AEdit: TSpinEdit + Left = 104 + Height = 21 + Top = 41 + Width = 72 + MaxValue = 255 + OnChange = CropEditChange + TabOrder = 2 + Value = 8 + end + object VEdit: TSpinEdit + Left = 57 + Height = 21 + Top = 73 + Width = 72 + MaxValue = 255 + OnChange = CropEditChange + TabOrder = 3 + Value = 8 + end + object REdit: TSpinEdit + Left = 311 + Height = 21 + Top = 41 + Width = 72 + MaxValue = 255 + OnChange = CropEditChange + TabOrder = 4 + Value = 8 + end + object LEdit: TSpinEdit + Left = 224 + Height = 21 + Top = 41 + Width = 72 + MaxValue = 255 + OnChange = CropEditChange + TabOrder = 5 + Value = 8 + end + object Timer1: TTimer + Enabled = False + Interval = 150 + OnTimer = Timer1Timer + left = 328 + top = 72 + end +end diff --git a/cropedges.lrs b/cropedges.lrs new file mode 100644 index 0000000..8a99034 --- /dev/null +++ b/cropedges.lrs @@ -0,0 +1,31 @@ +LazarusResources.Add('TCropEdgeForm','FORMDATA',[ + 'TPF0'#13'TCropEdgeForm'#12'CropEdgeForm'#4'Left'#3'2'#2#6'Height'#3#142#0#3 + +'Top'#3#209#0#5'Width'#3#142#1#13'ActiveControl'#7#5'DEdit'#11'BorderIcons' + +#11#12'biSystemMenu'#0#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#10'Crop Ed' + +'ges'#12'ClientHeight'#3#142#0#11'ClientWidth'#3#142#1#21'Constraints.MaxHei' + +'ght'#3'A'#1#20'Constraints.MaxWidth'#3#142#1#21'Constraints.MinHeight'#2#12 + +#20'Constraints.MinWidth'#3#142#1#8'OnCreate'#7#10'FormCreate'#6'OnHide'#7#8 + +'FormHide'#6'OnShow'#7#8'FormShow'#8'Position'#7#14'poScreenCenter'#10'LCLVe' + +'rsion'#6#7'1.0.2.0'#0#12'TSpeedButton'#9'CancelBtn'#4'Left'#3'@'#1#6'Height' + +#2#25#3'Top'#2'h'#5'Width'#2'A'#7'Caption'#6#6'Cancel'#9'NumGlyphs'#2#0#7'On' + +'Click'#7#14'CancelBtnClick'#0#0#12'TSpeedButton'#8'ApplyBtn'#4'Left'#3#0#1#6 + +'Height'#2#25#3'Top'#2'h'#5'Width'#2'A'#7'Caption'#6#5'Apply'#9'NumGlyphs'#2 + +#0#7'OnClick'#7#13'ApplyBtnClick'#0#0#12'TSpeedButton'#13'CropFileSzBtn'#4'L' + +'eft'#3#136#0#6'Height'#2#25#3'Top'#2'h'#5'Width'#2'i'#7'Caption'#6#12'Save ' + +'Cropped'#9'NumGlyphs'#2#0#7'OnClick'#7#18'CropFileSzBtnClick'#0#0#9'TSpinEd' + +'it'#5'DEdit'#4'Left'#2'9'#6'Height'#2#21#3'Top'#2#8#5'Width'#2'H'#8'MaxValu' + +'e'#3#255#0#8'OnChange'#7#14'CropEditChange'#8'TabOrder'#2#0#5'Value'#2#8#0#0 + +#9'TSpinEdit'#5'PEdit'#4'Left'#2#8#6'Height'#2#21#3'Top'#2')'#5'Width'#2'H'#8 + +'MaxValue'#3#255#0#8'OnChange'#7#14'CropEditChange'#8'TabOrder'#2#1#5'Value' + +#2#8#0#0#9'TSpinEdit'#5'AEdit'#4'Left'#2'h'#6'Height'#2#21#3'Top'#2')'#5'Wid' + +'th'#2'H'#8'MaxValue'#3#255#0#8'OnChange'#7#14'CropEditChange'#8'TabOrder'#2 + +#2#5'Value'#2#8#0#0#9'TSpinEdit'#5'VEdit'#4'Left'#2'9'#6'Height'#2#21#3'Top' + +#2'I'#5'Width'#2'H'#8'MaxValue'#3#255#0#8'OnChange'#7#14'CropEditChange'#8'T' + +'abOrder'#2#3#5'Value'#2#8#0#0#9'TSpinEdit'#5'REdit'#4'Left'#3'7'#1#6'Height' + +#2#21#3'Top'#2')'#5'Width'#2'H'#8'MaxValue'#3#255#0#8'OnChange'#7#14'CropEdi' + +'tChange'#8'TabOrder'#2#4#5'Value'#2#8#0#0#9'TSpinEdit'#5'LEdit'#4'Left'#3 + +#224#0#6'Height'#2#21#3'Top'#2')'#5'Width'#2'H'#8'MaxValue'#3#255#0#8'OnChan' + +'ge'#7#14'CropEditChange'#8'TabOrder'#2#5#5'Value'#2#8#0#0#6'TTimer'#6'Timer' + +'1'#7'Enabled'#8#8'Interval'#3#150#0#7'OnTimer'#7#11'Timer1Timer'#4'left'#3 + +'H'#1#3'top'#2'H'#0#0#0 +]); diff --git a/cropedges.pas b/cropedges.pas new file mode 100755 index 0000000..da39e26 --- /dev/null +++ b/cropedges.pas @@ -0,0 +1,200 @@ +unit CropEdges; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls, + Spin, Buttons,nifti_img,define_types; + +type + + { TCropEdgeForm } + + TCropEdgeForm = class(TForm) + ApplyBtn: TSpeedButton; + CropFileSzBtn: TSpeedButton; + CancelBtn: TSpeedButton; + Timer1: TTimer; + DEdit: TSpinEdit; + PEdit: TSpinEdit; + AEdit: TSpinEdit; + VEdit: TSpinEdit; + REdit: TSpinEdit; + LEdit: TSpinEdit; + procedure ApplyCrop; + procedure ApplyCrop2Img; + procedure ApplyBtnClick(Sender: TObject); + procedure CancelBtnClick(Sender: TObject); + procedure CropEditChange(Sender: TObject); + procedure CropFileSzBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure Timer1Timer(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + CropEdgeForm: TCropEdgeForm; + +implementation +uses + nifti_img_view, crop; +{ TCropEdgeForm } + +procedure TCropEdgeForm.ApplyBtnClick(Sender: TObject); +begin + CropEdgeForm.ModalResult := mrOK; + CropEdgeForm.close; +end; + +procedure TCropEdgeForm.CancelBtnClick(Sender: TObject); +begin + CropEdgeForm.close; +end; + +procedure TCropEdgeForm.CropEditChange(Sender: TObject); +begin + if not CropEdgeForm.visible then exit; + Timer1.Enabled := true; +end; + + +procedure TCropEdgeForm.CropFileSzBtnClick(Sender: TObject); + var + lV,lD,lA,lP,lL,lR: integer; +begin + lV := VEdit.value; + lD := DEdit.value; + lL := LEdit.value; + lR := REdit.value; + lA := AEdit.value; + lP := PEdit.value; + CropNIfTI(lL,lR,lA,lP,lD,lV); +end; + +procedure TCropEdgeForm.FormCreate(Sender: TObject); +begin + +end; + +procedure TCropEdgeForm.FormHide(Sender: TObject); +begin + UndoVolVOI; + if not (CropEdgeForm.ModalResult = mrCancel) then + ApplyCrop2Img + else + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TCropEdgeForm.FormShow(Sender: TObject); +begin + EnsureVOIOpen; + CreateUndoVol; + CropEdgeForm.ModalResult := mrCancel; + CropEditChange(nil); +end; + +procedure TCropEdgeForm.ApplyCrop2Img; +var + lZLo,lZHi,lXLo,lXHi,lYLo,lYHi,lPos,lX,lY,lZ: integer; + l32Buf : SingleP; + l16Buf : SmallIntP; +begin + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferItems<1) then exit; + if (gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ImgBufferItems then begin + Showmessage('Can not crop edges of a rotated image.'); + exit; + end; + lXlo := round(LEdit.value); + lXHi := gBGImg.ScrnDim[1] - round(REdit.value); + lYlo := round(PEdit.value); + lYHi := gBGImg.ScrnDim[2] - round(AEdit.value); + lZLo := round(VEdit.value); + lZHi := gBGImg.ScrnDim[3] - round(DEdit.value); + lPos := 0; + case gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP of + 1: begin + for lZ := 1 to gBGImg.ScrnDim[3] do + for lY := 1 to gBGImg.ScrnDim[2] do + for lX := 1 to gBGImg.ScrnDim[1] do begin + inc(lPos); + if (lZ >= lZHi) or (lZ <= lZLo) or(lY >= lYHi) or (lY <= lYLo) or (lX >= lXHi) or (lX <= lXLo) then + gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos] := 0; + end; //for X + end; + 2: begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lZ := 1 to gBGImg.ScrnDim[3] do + for lY := 1 to gBGImg.ScrnDim[2] do + for lX := 1 to gBGImg.ScrnDim[1] do begin + inc(lPos); + if (lZ >= lZHi) or (lZ <= lZLo) or(lY >= lYHi) or (lY <= lYLo) or (lX >= lXHi) or (lX <= lXLo) then + l16Buf^[lPos] := 0; + end; //for X + end; + 4: begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lZ := 1 to gBGImg.ScrnDim[3] do + for lY := 1 to gBGImg.ScrnDim[2] do + for lX := 1 to gBGImg.ScrnDim[1] do begin + inc(lPos); + if (lZ >= lZHi) or (lZ <= lZLo) or(lY >= lYHi) or (lY <= lYLo) or (lX >= lXHi) or (lX <= lXLo) then + l32Buf^[lPos] := 0; + end; //for X + end; + else begin showmessage('Unsupported data type'); end + end; //case + ImgForm.RescaleImagesTimer.Enabled := true; +end; + +procedure TCropEdgeForm.ApplyCrop; +var + lZLo,lZHi,lXLo,lXHi,lYLo,lYHi,lPos,lX,lY,lZ: integer; +begin + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gBGImg.VOIUndoVolItems) then exit; + if gBGImg.VOIUndoVolItems <> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then exit; + if (gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then exit; + //CreateUndoVol; + //Move(gBGImg.VOIUndoVol^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVolItems); + FillChar(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVolItems,0); + lXlo := round(LEdit.value); + lXHi := gBGImg.ScrnDim[1] - round(REdit.value); + lYlo := round(PEdit.value); + lYHi := gBGImg.ScrnDim[2] - round(AEdit.value); + lZLo := round(VEdit.value); + lZHi := gBGImg.ScrnDim[3] - round(DEdit.value); + lPos := 0; + for lZ := 1 to gBGImg.ScrnDim[3] do begin + for lY := 1 to gBGImg.ScrnDim[2] do begin + for lX := 1 to gBGImg.ScrnDim[1] do begin + inc(lPos); + if (lZ >= lZHi) or (lZ <= lZLo) or(lY >= lYHi) or (lY <= lYLo) or (lX >= lXHi) or (lX <= lXLo) then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lPos] := kVOI8bit; + end; //for X + end; //for Y + end; //for Z + //gBGImg.VOIchanged := true; + ImgForm.RefreshImagesTimer.enabled := true; +end; + +procedure TCropEdgeForm.Timer1Timer(Sender: TObject); +begin + Timer1.Enabled := false; + ApplyCrop; + +end; + + + + +initialization + {$I cropedges.lrs} + +end. + diff --git a/cutout.lfm b/cutout.lfm new file mode 100755 index 0000000..2526250 --- /dev/null +++ b/cutout.lfm @@ -0,0 +1,202 @@ +object CutoutForm: TCutoutForm + Left = 384 + Height = 334 + Top = 175 + Width = 334 + HorzScrollBar.Page = 335 + VertScrollBar.Page = 316 + ActiveControl = RenderCutoutCheck + BorderIcons = [biSystemMenu, biMinimize] + BorderStyle = bsSingle + Caption = 'Cutouts' + ClientHeight = 334 + ClientWidth = 334 + Constraints.MaxHeight = 334 + Constraints.MaxWidth = 334 + Constraints.MinHeight = 334 + Constraints.MinWidth = 334 + OnClose = FormClose + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '0.9.29' + object RenderCutoutCheck: TCheckBox + Left = 16 + Height = 17 + Top = 8 + Width = 80 + Caption = 'Show cutout' + OnClick = RenderCutoutCheckClick + TabOrder = 0 + end + object CutoutBox: TGroupBox + Left = 16 + Height = 224 + Top = 32 + Width = 304 + ClientHeight = 206 + ClientWidth = 300 + TabOrder = 5 + object Label1: TLabel + Left = 14 + Height = 14 + Top = 8 + Width = 58 + Caption = 'X [low=left]' + ParentColor = False + end + object Label2: TLabel + Left = 14 + Height = 14 + Top = 48 + Width = 85 + Caption = 'Y [low=posterior]' + ParentColor = False + end + object Label3: TLabel + Left = 14 + Height = 14 + Top = 88 + Width = 76 + Caption = 'Z [low=ventral]' + ParentColor = False + end + object Label4: TLabel + Left = 14 + Height = 14 + Top = 135 + Width = 55 + Caption = 'Cutout Tint' + ParentColor = False + end + object Label5: TLabel + Left = 14 + Height = 14 + Top = 175 + Width = 62 + Caption = 'Cutout Color' + ParentColor = False + end + object XLo: TSpinEdit + Left = 118 + Height = 21 + Top = 0 + Width = 82 + MaxValue = 1000 + OnChange = PreviewClick + TabOrder = 0 + end + object XHi: TSpinEdit + Left = 206 + Height = 21 + Top = 0 + Width = 82 + MaxValue = 1000 + OnChange = PreviewClick + TabOrder = 1 + end + object YLo: TSpinEdit + Left = 118 + Height = 21 + Top = 40 + Width = 82 + MaxValue = 1000 + OnChange = PreviewClick + TabOrder = 2 + end + object YHi: TSpinEdit + Left = 206 + Height = 21 + Top = 40 + Width = 82 + MaxValue = 1000 + OnChange = PreviewClick + TabOrder = 3 + end + object ZLo: TSpinEdit + Left = 118 + Height = 21 + Top = 88 + Width = 82 + MaxValue = 1000 + OnChange = PreviewClick + TabOrder = 4 + end + object ZHi: TSpinEdit + Left = 206 + Height = 21 + Top = 88 + Width = 82 + MaxValue = 1000 + OnChange = PreviewClick + TabOrder = 5 + end + object CutoutBiasDrop: TComboBox + Left = 118 + Height = 19 + Top = 128 + Width = 170 + ItemHeight = 13 + Items.Strings = ( + '0.1 Dark' + '0.2' + '0.3' + '0.4' + '0.5' + '0.6' + '0.7' + '0.8' + '0.9 Light' + ) + OnChange = PreviewClick + Style = csOwnerDrawFixed + TabOrder = 6 + end + object CutoutLUTDrop: TComboBox + Left = 118 + Height = 19 + Top = 168 + Width = 170 + ItemHeight = 13 + OnChange = PreviewClick + Style = csOwnerDrawFixed + TabOrder = 7 + end + end + object PreviewBtn: TButton + Left = 128 + Height = 25 + Top = 304 + Width = 75 + Caption = 'Preview' + OnClick = PreviewClick + TabOrder = 2 + Visible = False + end + object DefBtn: TButton + Left = 128 + Height = 25 + Top = 272 + Width = 75 + Caption = 'Defaults' + OnClick = DefBtnClick + TabOrder = 3 + end + object OKBtn: TButton + Left = 237 + Height = 25 + Top = 272 + Width = 75 + Caption = 'OK' + OnClick = OKBtnClick + TabOrder = 4 + end + object PreviewBtn1: TButton + Left = 16 + Height = 25 + Top = 272 + Width = 75 + Caption = 'Preview' + OnClick = PreviewBtn1Click + TabOrder = 1 + end +end diff --git a/cutout.lrs b/cutout.lrs new file mode 100644 index 0000000..110c613 --- /dev/null +++ b/cutout.lrs @@ -0,0 +1,50 @@ +LazarusResources.Add('TCutoutForm','FORMDATA',[ + 'TPF0'#11'TCutoutForm'#10'CutoutForm'#4'Left'#3#128#1#6'Height'#3'N'#1#3'Top' + +#3#175#0#5'Width'#3'N'#1#18'HorzScrollBar.Page'#3'O'#1#18'VertScrollBar.Page' + +#3'<'#1#13'ActiveControl'#7#17'RenderCutoutCheck'#11'BorderIcons'#11#12'biSy' + +'stemMenu'#10'biMinimize'#0#11'BorderStyle'#7#8'bsSingle'#7'Caption'#6#7'Cut' + +'outs'#12'ClientHeight'#3'N'#1#11'ClientWidth'#3'N'#1#21'Constraints.MaxHeig' + +'ht'#3'N'#1#20'Constraints.MaxWidth'#3'N'#1#21'Constraints.MinHeight'#3'N'#1 + +#20'Constraints.MinWidth'#3'N'#1#7'OnClose'#7#9'FormClose'#6'OnShow'#7#8'For' + +'mShow'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#6'0.9.29'#0#9'TChe' + +'ckBox'#17'RenderCutoutCheck'#4'Left'#2#16#6'Height'#2#17#3'Top'#2#8#5'Width' + +#2'P'#7'Caption'#6#11'Show cutout'#7'OnClick'#7#22'RenderCutoutCheckClick'#8 + +'TabOrder'#2#0#0#0#9'TGroupBox'#9'CutoutBox'#4'Left'#2#16#6'Height'#3#224#0#3 + +'Top'#2' '#5'Width'#3'0'#1#12'ClientHeight'#3#206#0#11'ClientWidth'#3','#1#8 + +'TabOrder'#2#5#0#6'TLabel'#6'Label1'#4'Left'#2#14#6'Height'#2#14#3'Top'#2#8#5 + +'Width'#2':'#7'Caption'#6#12'X [low=left]'#11'ParentColor'#8#0#0#6'TLabel'#6 + +'Label2'#4'Left'#2#14#6'Height'#2#14#3'Top'#2'0'#5'Width'#2'U'#7'Caption'#6 + +#17'Y [low=posterior]'#11'ParentColor'#8#0#0#6'TLabel'#6'Label3'#4'Left'#2#14 + +#6'Height'#2#14#3'Top'#2'X'#5'Width'#2'L'#7'Caption'#6#15'Z [low=ventral]'#11 + +'ParentColor'#8#0#0#6'TLabel'#6'Label4'#4'Left'#2#14#6'Height'#2#14#3'Top'#3 + +#135#0#5'Width'#2'7'#7'Caption'#6#11'Cutout Tint'#11'ParentColor'#8#0#0#6'TL' + +'abel'#6'Label5'#4'Left'#2#14#6'Height'#2#14#3'Top'#3#175#0#5'Width'#2'>'#7 + +'Caption'#6#12'Cutout Color'#11'ParentColor'#8#0#0#9'TSpinEdit'#3'XLo'#4'Lef' + +'t'#2'v'#6'Height'#2#21#3'Top'#2#0#5'Width'#2'R'#8'MaxValue'#3#232#3#8'OnCha' + +'nge'#7#12'PreviewClick'#8'TabOrder'#2#0#0#0#9'TSpinEdit'#3'XHi'#4'Left'#3 + +#206#0#6'Height'#2#21#3'Top'#2#0#5'Width'#2'R'#8'MaxValue'#3#232#3#8'OnChang' + +'e'#7#12'PreviewClick'#8'TabOrder'#2#1#0#0#9'TSpinEdit'#3'YLo'#4'Left'#2'v'#6 + +'Height'#2#21#3'Top'#2'('#5'Width'#2'R'#8'MaxValue'#3#232#3#8'OnChange'#7#12 + +'PreviewClick'#8'TabOrder'#2#2#0#0#9'TSpinEdit'#3'YHi'#4'Left'#3#206#0#6'Hei' + +'ght'#2#21#3'Top'#2'('#5'Width'#2'R'#8'MaxValue'#3#232#3#8'OnChange'#7#12'Pr' + +'eviewClick'#8'TabOrder'#2#3#0#0#9'TSpinEdit'#3'ZLo'#4'Left'#2'v'#6'Height'#2 + +#21#3'Top'#2'X'#5'Width'#2'R'#8'MaxValue'#3#232#3#8'OnChange'#7#12'PreviewCl' + +'ick'#8'TabOrder'#2#4#0#0#9'TSpinEdit'#3'ZHi'#4'Left'#3#206#0#6'Height'#2#21 + +#3'Top'#2'X'#5'Width'#2'R'#8'MaxValue'#3#232#3#8'OnChange'#7#12'PreviewClick' + +#8'TabOrder'#2#5#0#0#9'TComboBox'#14'CutoutBiasDrop'#4'Left'#2'v'#6'Height'#2 + +#19#3'Top'#3#128#0#5'Width'#3#170#0#10'ItemHeight'#2#13#13'Items.Strings'#1#6 + +#8'0.1 Dark'#6#3'0.2'#6#3'0.3'#6#3'0.4'#6#3'0.5'#6#3'0.6'#6#3'0.7'#6#3'0.8'#6 + +#9'0.9 Light'#0#8'OnChange'#7#12'PreviewClick'#5'Style'#7#16'csOwnerDrawFixe' + +'d'#8'TabOrder'#2#6#0#0#9'TComboBox'#13'CutoutLUTDrop'#4'Left'#2'v'#6'Height' + +#2#19#3'Top'#3#168#0#5'Width'#3#170#0#10'ItemHeight'#2#13#8'OnChange'#7#12'P' + +'reviewClick'#5'Style'#7#16'csOwnerDrawFixed'#8'TabOrder'#2#7#0#0#0#7'TButto' + +'n'#10'PreviewBtn'#4'Left'#3#128#0#6'Height'#2#25#3'Top'#3'0'#1#5'Width'#2'K' + +#7'Caption'#6#7'Preview'#7'OnClick'#7#12'PreviewClick'#8'TabOrder'#2#2#7'Vis' + +'ible'#8#0#0#7'TButton'#6'DefBtn'#4'Left'#3#128#0#6'Height'#2#25#3'Top'#3#16 + +#1#5'Width'#2'K'#7'Caption'#6#8'Defaults'#7'OnClick'#7#11'DefBtnClick'#8'Tab' + +'Order'#2#3#0#0#7'TButton'#5'OKBtn'#4'Left'#3#237#0#6'Height'#2#25#3'Top'#3 + +#16#1#5'Width'#2'K'#7'Caption'#6#2'OK'#7'OnClick'#7#10'OKBtnClick'#8'TabOrde' + +'r'#2#4#0#0#7'TButton'#11'PreviewBtn1'#4'Left'#2#16#6'Height'#2#25#3'Top'#3 + +#16#1#5'Width'#2'K'#7'Caption'#6#7'Preview'#7'OnClick'#7#16'PreviewBtn1Click' + +#8'TabOrder'#2#1#0#0#0 +]); diff --git a/cutout.pas b/cutout.pas new file mode 100755 index 0000000..b49b3de --- /dev/null +++ b/cutout.pas @@ -0,0 +1,195 @@ +unit cutout; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, + Spin; +const + kMaxFrac = 1000;//e.g. if 100 then cutouts are done by percent, if 1000 then 0.001 + +type + + { TCutoutForm } + + TCutoutForm = class(TForm) + CutoutBiasDrop: TComboBox; + CutoutLUTDrop: TComboBox; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + Label5: TLabel; + PreviewBtn: TButton; + DefBtn: TButton; + OKBtn: TButton; + CutoutBox: TGroupBox; + PreviewBtn1: TButton; + RenderCutoutCheck: TCheckBox; + XLo: TSpinEdit; + XHi: TSpinEdit; + YLo: TSpinEdit; + YHi: TSpinEdit; + ZLo: TSpinEdit; + ZHi: TSpinEdit; + procedure Prep; + procedure DefBtnClick(Sender: TObject); + procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); + procedure FormShow(Sender: TObject); + procedure OKBtnClick(Sender: TObject); + procedure PreviewBtn1Click(Sender: TObject); + procedure PreviewClick(Sender: TObject); + procedure RenderCutoutCheckClick(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + CutoutForm: TCutoutForm; + +implementation +{$DEFINE REND} //if you define "REND" render form will be interactively adjusted +uses render_composite{grender}, nifti_img_view {LUTdrop},define_types {sortcutout} +{$IFDEF REND}, render {$ENDIF}{azimuth,elevation,timer} +; +var gInit: boolean = false; + +{ TCutoutForm } +procedure TCutoutForm.Prep; +begin + gInit := true; + CutoutForm.caption := 'Cutouts: '+inttostr(kMaxFrac)+'= 100%'; + cutoutlutdrop.Items := ImgForm.LUTdrop.items; + if (gRender.cutoutLUTindex < 1) or (gRender.cutoutLUTindex > cutoutlutdrop.Items.Count) then + cutoutlutdrop.itemindex := 0 + else + cutoutlutdrop.itemindex := gRender.cutoutLUTindex; + if gRender.CutoutFrac.Lo[1] < 0 then + SliceToFrac(gBGImg); + SortCutout(gRender.CutoutFrac); + Xlo.maxValue := kMaxFrac;//gBGImg.ScrnDim[1]; + Xhi.maxValue := kMaxFrac;//gBGImg.ScrnDim[1]; + Ylo.maxValue := kMaxFrac;//gBGImg.ScrnDim[2]; + Yhi.maxValue := kMaxFrac;//gBGImg.ScrnDim[2]; + Zlo.maxValue := kMaxFrac;//gBGImg.ScrnDim[3]; + Zhi.maxValue := kMaxFrac;//gBGImg.ScrnDim[3]; + Xlo.Value := gRender.CutoutFrac.Lo[1]; + Xhi.Value := gRender.CutoutFrac.Hi[1]; + Ylo.Value := gRender.CutoutFrac.Lo[2]; + Yhi.Value := gRender.CutoutFrac.Hi[2]; + Zlo.Value := gRender.CutoutFrac.Lo[3]; + Zhi.Value := gRender.CutoutFrac.Hi[3]; + //OverlayClipEdit.value := gRender.OverlayNearClipFrac; + //BGClipEdit.value := gRender.BGNearClipFrac; + RenderCutoutCheck.checked := gRender.ShowCutout; + CutoutBiasDrop.ItemIndex:=( gRender.CutoutBias); + RenderCutoutCheckClick(nil); + gInit := false; +end; + +procedure ReadCutoutForm; +begin + with CutoutForm do begin + gRender.CutoutFrac.Lo[1] := round(Xlo.Value); + gRender.CutoutFrac.Hi[1] := round(Xhi.Value); + gRender.CutoutFrac.Lo[2] := round(Ylo.Value); + gRender.CutoutFrac.Hi[2] := round(Yhi.Value); + gRender.CutoutFrac.Lo[3] := round(Zlo.Value); + gRender.CutoutFrac.Hi[3] := round(Zhi.Value); + SortCutout(gRender.CutoutFrac); + gRender.ShowCutout := RenderCutoutCheck.checked; + gRender.CutoutBias := CutoutBiasDrop.ItemIndex; + gRender.cutoutLUTindex := cutoutlutdrop.itemindex; + //gRender.OverlayNearClipFrac := round(OverlayClipEdit.value); + // gRender.BGNearClipFrac := round(BGClipEdit.value); + + end; +end; + +procedure TCutoutForm.RenderCutoutCheckClick(Sender: TObject); +begin + CutoutBox.visible := RenderCutoutCheck.Checked; + PreviewClick(nil); + +end; + +procedure TCutoutForm.PreviewClick(Sender: TObject); +begin + if gInit then + exit; + ReadCutoutForm; +{$IFDEF REND} + gZoom := 0.5; + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +{$ENDIF} +end; + +procedure TCutoutForm.DefBtnClick(Sender: TObject); +begin + gInit := true; + Ylo.Value := kMaxFrac shr 1; + Yhi.Value := kMaxFrac ; + Zlo.Value := kMaxFrac shr 1; + Zhi.Value := kMaxFrac ; + //OverlayClipEdit.value := 0; + //BGClipEdit.value := 0; + RenderCutoutCheck.checked := true; + CutoutLUTdrop.ItemIndex := 0; + CutoutBiasDrop.ItemIndex:= 3; +{$IFDEF REND} + if renderForm.FlipLRcheck.checked then begin + Xlo.Value := 0; + Xhi.Value := kMaxFrac shr 1; + + end else begin + Xlo.Value := kMaxFrac shr 1; + Xhi.Value := kMaxFrac ; + end; + RenderForm.AzimuthEdit.value := 120; + RenderForm.ElevationEdit.value := 45; +{$ELSE} + Xlo.Value := 0; + Xhi.Value := kMaxFrac shr 1; +{$ENDIF} + gInit := false; + RenderCutoutCheckClick(nil);//PreviewClick(nil); + +end; + +procedure TCutoutForm.FormClose(Sender: TObject; var CloseAction: TCloseAction); +begin + ReadCutoutForm; + //note: exit if no changes +{$IFDEF REND} + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +{$ENDIF} +end; + +procedure TCutoutForm.FormShow(Sender: TObject); +begin + Prep; +end; + +procedure TCutoutForm.OKBtnClick(Sender: TObject); +begin + CutoutForm.close; +end; + +procedure TCutoutForm.PreviewBtn1Click(Sender: TObject); +begin + ReadCutoutForm; + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end; + +initialization + {$I cutout.lrs} + +end. + diff --git a/dcm2nii.svg b/dcm2nii.svg new file mode 100755 index 0000000..34a5ab4 --- /dev/null +++ b/dcm2nii.svg @@ -0,0 +1,199 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://web.resource.org/cc/" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + id="svg2256" + sodipodi:version="0.32" + inkscape:version="0.45.1" + width="128" + height="128" + version="1.0" + sodipodi:docbase="C:\mricron\html" + sodipodi:docname="mini.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape"> + <metadata + id="metadata2261"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + </cc:Work> + </rdf:RDF> + </metadata> + <defs + id="defs2259"> + <filter + inkscape:collect="always" + id="filter3324"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="3.8223414" + id="feGaussianBlur3326" /> + </filter> + <filter + inkscape:collect="always" + id="filter3502"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="3.1080325" + id="feGaussianBlur3504" /> + </filter> + <filter + inkscape:collect="always" + x="-0.068783067" + width="1.1375661" + y="-0.11711711" + height="1.2342342" + id="filter3528"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="3.5630003" + id="feGaussianBlur3530" /> + </filter> + <filter + inkscape:collect="always" + id="filter3740"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="2.7552379" + id="feGaussianBlur3742" /> + </filter> + <filter + inkscape:collect="always" + id="filter3886"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="4.6432082" + id="feGaussianBlur3888" /> + </filter> + <filter + inkscape:collect="always" + id="filter4027"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="3.4304274" + id="feGaussianBlur4029" /> + </filter> + </defs> + <sodipodi:namedview + inkscape:window-height="870" + inkscape:window-width="1240" + inkscape:pageshadow="2" + inkscape:pageopacity="0.0" + guidetolerance="10.0" + gridtolerance="10.0" + objecttolerance="10.0" + borderopacity="1.0" + bordercolor="#666666" + pagecolor="#ffffff" + id="base" + inkscape:zoom="0.75061011" + inkscape:cx="447.21723" + inkscape:cy="-211.51769" + inkscape:window-x="44" + inkscape:window-y="0" + inkscape:current-layer="svg2256" + width="128px" + height="128px" /> + <g + id="g2187" + transform="matrix(0.1391938,0,0,0.1544313,1.9456067,-0.9518683)"> + <path + id="path2277" + d="M 470.26695,122.56853 C 365.28205,122.51433 104.26695,154.59979 104.26695,154.59978 L 61.829448,179.25603 C 61.829448,179.25603 21.863248,302.11966 17.423248,430.88103 C 12.983148,559.64238 44.079448,694.3185 44.079448,694.31853 L 132.86075,749.56858 L 318.36075,735.75603 L 674.54825,734.75603 C 674.54825,734.75603 766.33255,519.66619 785.07945,464.41228 C 803.82635,409.15837 720.92325,186.16229 720.92325,186.16228 C 720.92325,186.16228 575.90705,127.97069 489.07945,123.03728 C 483.59105,122.72894 477.26595,122.57214 470.26695,122.56853 z M 452.54825,307.53728 C 520.08425,307.53729 574.89195,359.02356 574.89195,422.47478 C 574.89205,485.926 520.08425,537.44353 452.54825,537.44353 C 385.01215,537.44352 330.20445,485.926 330.20445,422.47478 C 330.20435,359.02356 385.01215,307.53728 452.54825,307.53728 z " + style="fill:#aeaeae;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1.60000002;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path3506" + d="M 609.43985,154.60357 L 716.98765,188.15059 L 733.76115,227.61767 L 666.66715,190.12394 L 609.43985,154.60357 z " + style="opacity:0.21666667;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3528)" /> + <path + id="path3336" + d="M 66.767548,182.23053 L 53.940748,220.71093 L 75.647648,195.05733 L 85.514448,218.73758 L 128.92825,182.23053 L 275.94305,153.61689 L 329.22365,160.52363 L 379.54415,131.91 L 171.35535,149.67019 L 102.28795,158.55028 L 66.767548,182.23053 z " + style="opacity:0.11111109;fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3502)" /> + <path + sodipodi:nodetypes="ccscccsssc" + id="path2281" + d="M 467.79528,122.93964 C 283.97738,122.93964 131.89205,254.99623 131.89195,422.47478 C 131.89195,589.95333 281.07405,725.881 464.89195,725.88103 C 648.70985,725.88103 797.89205,589.95333 797.89195,422.47478 C 797.89195,254.99623 651.61318,122.93964 467.79528,122.93964 z M 474.76695,238.47478 C 587.23635,238.47479 678.51695,323.3403 678.51695,427.91228 C 678.51695,532.48427 587.23625,617.34978 474.76695,617.34978 C 362.29765,617.34976 271.01695,532.48426 271.01695,427.91228 C 271.01695,323.34031 362.29765,238.47478 474.76695,238.47478 z " + style="opacity:1;fill:#009990;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccscsc" + id="path3330" + d="M 466.52265,725.68157 C 299.87515,725.68157 162.26495,611.74002 142.65745,468.59724 C 156.42695,468.85724 228.20685,714.18323 470.91455,708.76876 C 731.14935,702.96329 765.39815,528.42344 778.72845,487.00424 C 793.92915,472.92559 792.19825,449.23943 791.78785,460.80489 C 786.85445,600.80324 635.75525,722.72157 466.52265,725.68157 z " + style="opacity:0.46111109;fill:#030103;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <path + id="path2294" + d="M 474.76695,238.47478 C 362.29765,238.47478 271.01695,323.34031 271.01695,427.91228 C 271.01695,532.48426 362.29765,617.34976 474.76695,617.34978 C 587.23625,617.34978 678.51695,532.48427 678.51695,427.91228 C 678.51695,323.3403 587.23635,238.47479 474.76695,238.47478 z M 451.57945,320.34978 C 508.22255,320.3498 554.17325,366.55931 554.17325,423.47478 C 554.17315,480.39023 508.22255,526.56853 451.57945,526.56853 C 394.93625,526.56852 348.95445,480.39025 348.95445,423.47478 C 348.95435,366.55928 394.93635,320.34978 451.57945,320.34978 z " + style="opacity:1;fill:#c0c0c0;fill-opacity:1;stroke:#000000;stroke-width:2;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccccc" + id="path2315" + d="M 306.76523,520.33116 L 426.88496,525.12996 L 489.56056,590.7715 L 308.50345,604.52828 L 306.76523,520.33116 z " + style="fill:#999999;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="cczc" + id="path2279" + d="M 108.20795,428.89977 L 60.847448,441.72657 C 60.847448,441.72657 62.080848,351.44563 72.687648,282.87158 C 83.294448,214.29753 104.26125,154.60357 104.26125,154.60357" + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="cccccccc" + id="path2309" + d="M 751.52135,549.27437 L 751.52135,585.78141 L 720.93435,613.40837 L 561.09275,608.47498 L 530.50575,581.83471 L 526.55895,504.8739 L 735.73455,535.46089 L 751.52135,549.27437 z " + style="fill:#999999;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path2311" + d="M 531.49245,578.87467 L 384.47755,555.19443 L 452.55825,591.70148 L 562.07935,608.47498 L 531.49245,578.87467 z " + style="fill:#999999;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccscsc" + id="path2317" + d="M 463.7235,127.87852 C 297.076,127.87852 157.53025,237.94896 137.92275,381.09174 C 149.7567,345.02397 227.41885,129.58569 470.12655,135.00016 C 730.36135,140.80563 760.66345,321.26554 773.99375,362.68474 C 789.19445,376.76339 790.39498,394.5644 788.9887,383.07743 C 772.44198,247.91796 643.8095,127.87849 463.7235,127.87852 z " + style="opacity:0.3;fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;filter:url(#filter3324)" /> + <path + sodipodi:nodetypes="cccccccc" + id="path2305" + d="M 382.50415,501.91387 L 365.73065,482.18033 L 629.38633,496.56043 L 711.06765,535.46089 L 683.13773,575.61175 L 547.27925,561.11449 L 541.20784,513.4511 L 382.50415,501.91387 z " + style="fill:#848484;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + id="path3328" + d="M 634.10685,520.66073 L 384.47755,500.92719" + style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccccc" + id="path2313" + d="M 384.47755,555.19443 L 382.50415,500.92719 L 532.47905,511.78064 L 529.51905,578.87467 L 384.47755,555.19443 z " + style="fill:#999999;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccscscsc" + id="path2275" + d="M 108.20795,429.88645 L 321.33025,431.8598 C 321.33025,431.8598 337.11705,439.75322 330.21025,528.55414 C 323.30355,617.35507 322.31685,735.75631 322.31685,735.75631 C 322.31685,735.75631 315.41015,749.56978 303.56995,750.55648 C 291.72985,751.54318 134.84825,750.55648 134.84825,750.55648 C 134.84825,750.55648 107.22135,642.02201 112.15475,556.18111 C 117.08805,470.34021 109.19465,428.89977 108.20795,429.88645 z " + style="fill:#b4b4b4;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="ccccccccccccc" + id="path2307" + d="M 629.11678,496.99938 L 634.16352,520.67963 L 650.13935,527.56747 L 657.93823,541.41875 L 672.64392,548.28769 L 680.53732,575.91464 L 826.11952,576.84462 L 834.90434,548.2665 L 848.05259,541.93894 L 855.42734,528.18433 L 871.55888,521.89313 L 877.24515,498.95384 L 629.11678,496.99938 z " + style="fill:#acacac;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + sodipodi:nodetypes="cszccc" + id="path3534" + d="M 47.034048,692.34253 C 47.034048,692.34253 20.147048,566.78788 28.287148,529.54082 C 36.427248,492.29376 39.880548,565.8012 60.847448,582.82138 C 81.814348,599.84156 106.23465,589.72812 106.23465,589.72812 L 130.90155,745.62308 L 47.034048,692.34253 z " + style="opacity:0.05;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3740)" /> + <path + sodipodi:nodetypes="cscscsc" + id="path3744" + d="M 117.08805,589.72812 C 219.70245,717.00945 313.43685,599.59489 319.35685,628.20852 C 325.27695,656.82215 308.50345,721.94284 308.50345,721.94284 C 308.50345,721.94284 290.74315,737.72967 280.87645,738.71635 C 271.00965,739.70301 138.79505,740.6897 138.79505,740.6897 C 138.79505,740.6897 123.00815,684.69578 118.07475,644.98203 C 113.14135,605.26828 117.08805,589.72812 117.08805,589.72812 z " + style="opacity:0.04444442;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;filter:url(#filter3886)" /> + <path + sodipodi:nodetypes="cccsccc" + id="path3890" + d="M 473.78025,229.59469 C 434.90905,229.59469 314.69695,282.2284 294.64115,319.47409 C 290.33955,354.11247 349.78446,363.88688 360.04246,359.01822 C 377.76996,330.10206 409.13294,310.56167 463.43924,312.53502 C 509.92934,314.25561 528.74162,338.97444 542.10032,364.69155 C 595.00092,374.15948 643.67325,321.97478 643.67325,321.97478 C 607.04255,271.60155 544.05705,229.5947 473.78025,229.59469 z " + style="opacity:0.13888891;fill:#646464;fill-opacity:1;stroke:none;stroke-width:1;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1;filter:url(#filter4027)" /> + </g> +</svg> diff --git a/dcm2nii/LibTar.o b/dcm2nii/LibTar.o new file mode 100644 index 0000000..e1f60c1 Binary files /dev/null and b/dcm2nii/LibTar.o differ diff --git a/dcm2nii/LibTar.pas b/dcm2nii/LibTar.pas new file mode 100755 index 0000000..20a52fd --- /dev/null +++ b/dcm2nii/LibTar.pas @@ -0,0 +1,914 @@ +(*Name : LibTar +=============================================================================================== +Subject : Handling of "tar" files +=============================================================================================== +Author : Stefan Heymann + Eschenweg 3 + 72076 Tübingen + GERMANY + +E-Mail: stefan@destructor.de +Web: www.destructor.de + +=============================================================================================== +TTarArchive Usage +----------------- +- Choose a constructor +- Make an instance of TTarArchive TA := TTarArchive.Create (Filename); +- Scan through the archive TA.Reset; + WHILE TA.FindNext (DirRec) DO BEGIN +- Evaluate the DirRec for each file ListBox.Items.Add (DirRec.Name); +- Read out the current file TA.ReadFile (DestFilename); + (You can ommit this if you want to + read in the directory only) END; +- You're done TA.Free; + + +TTarWriter Usage +---------------- +- Choose a constructor +- Make an instance of TTarWriter TW := TTarWriter.Create ('my.tar'); +- Add a file to the tar archive TW.AddFile ('foobar.txt'); +- Add a string as a file TW.AddString (SL.Text, 'joe.txt', Now); +- Destroy TarWriter instance TW.Free; +- Now your tar file is ready. + + +Source, Legals ("Licence") +-------------------------- +The official site to get this code is http://www.destructor.de/ + +Usage and Distribution of this Source Code is ruled by the +"Destructor.de Source code Licence" (DSL) which comes with this file or +can be downloaded at http://www.destructor.de/ + +IN SHORT: Usage and distribution of this source code is free. + You use it completely on your own risk. + +Donateware +---------- +If you like this code, you are free to donate +http://www.destructor.de/donateware.htm + +=============================================================================================== +!!! All parts of this code which are not finished or known to be buggy + are marked with three exclamation marks +=============================================================================================== +Date Author Changes +----------------------------------------------------------------------------------------------- +2001-04-26 HeySt 0.0.1 Start +2001-04-28 HeySt 1.0.0 First Release +2001-06-19 HeySt 2.0.0 Finished TTarWriter +2001-09-06 HeySt 2.0.1 Bugfix in TTarArchive.FindNext: FBytesToGo must sometimes be 0 +2001-10-25 HeySt 2.0.2 Introduced the ClearDirRec procedure +2001-11-13 HeySt 2.0.3 Bugfix: Take out ClearDirRec call from WriteTarHeader + Bug Reported by Tony BenBrahim +2001-12-25 HeySt 2.0.4 WriteTarHeader: Fill Rec with zero bytes before filling it +2002-05-18 HeySt 2.0.5 Kylix awareness: Thanks to Kerry L. Davison for the canges +2005-09-03 HeySt 2.0.6 TTarArchive.FindNext: Don't access SourceStream.Size + (for compressed streams, which don't know their .Size) +2006-03-13 HeySt 2.0.7 Bugfix in ReadFile (Buffer : POINTER) +2007-05-16 HeySt 2.0.8 Bugfix in TTarWriter.AddFile (Convertfilename in the ELSE branch) + Bug Reported by Chris Rorden +*) +UNIT LibTar; +INTERFACE + +USES +{$ifdef fpc} {$MODE Delphi} {$H+} {$endif} +{$ifdef Unix} + BaseUnix, Unix, +{$else} +Windows, +{$endif} + SysUtils, Classes; +TYPE + // --- File Access Permissions + TTarPermission = (tpReadByOwner, tpWriteByOwner, tpExecuteByOwner, + tpReadByGroup, tpWriteByGroup, tpExecuteByGroup, + tpReadByOther, tpWriteByOther, tpExecuteByOther); + TTarPermissions = SET OF TTarPermission; + + // --- Type of File + TFileType = (ftNormal, // Regular file + ftLink, // Link to another, previously archived, file (LinkName) + ftSymbolicLink, // Symbolic link to another file (LinkName) + ftCharacter, // Character special files + ftBlock, // Block special files + ftDirectory, // Directory entry. Size is zero (unlimited) or max. number of bytes + ftFifo, // FIFO special file. No data stored in the archive. + ftContiguous, // Contiguous file, if supported by OS + ftDumpDir, // List of files + ftMultiVolume, // Multi-volume file part + ftVolumeHeader); // Volume header. Can appear only as first record in the archive + + // --- Mode + TTarMode = (tmSetUid, tmSetGid, tmSaveText); + TTarModes = SET OF TTarMode; + + // --- Record for a Directory Entry + // Adjust the ClearDirRec procedure when this record changes! + TTarDirRec = RECORD + Name : STRING; // File path and name + Size : INT64; // File size in Bytes + DateTime : TDateTime; // Last modification date and time + Permissions : TTarPermissions; // Access permissions + FileType : TFileType; // Type of file + LinkName : STRING; // Name of linked file (for ftLink, ftSymbolicLink) + UID : INTEGER; // User ID + GID : INTEGER; // Group ID + UserName : STRING; // User name + GroupName : STRING; // Group name + ChecksumOK : BOOLEAN; // Checksum was OK + Mode : TTarModes; // Mode + Magic : STRING; // Contents of the "Magic" field + MajorDevNo : INTEGER; // Major Device No. for ftCharacter and ftBlock + MinorDevNo : INTEGER; // Minor Device No. for ftCharacter and ftBlock + FilePos : INT64; // Position in TAR file + END; + + // --- The TAR Archive CLASS + TTarArchive = CLASS + PROTECTED + FStream : TStream; // Internal Stream + FOwnsStream : BOOLEAN; // True if FStream is owned by the TTarArchive instance + FBytesToGo : INT64; // Bytes until the next Header Record + PUBLIC + CONSTRUCTOR Create (Stream : TStream); OVERLOAD; + CONSTRUCTOR Create (Filename : STRING; + FileMode : WORD = fmOpenRead OR fmShareDenyWrite); OVERLOAD; + DESTRUCTOR Destroy; OVERRIDE; + PROCEDURE Reset; // Reset File Pointer + FUNCTION FindNext (VAR DirRec : TTarDirRec) : BOOLEAN; // Reads next Directory Info Record. FALSE if EOF reached + PROCEDURE ReadFile (Buffer : POINTER); OVERLOAD; // Reads file data for last Directory Record + PROCEDURE ReadFile (Stream : TStream); OVERLOAD; // -;- + PROCEDURE ReadFile (Filename : STRING); OVERLOAD; // -;- + FUNCTION ReadFile : STRING; OVERLOAD; // -;- + + PROCEDURE GetFilePos (VAR Current, Size : INT64); // Current File Position + PROCEDURE SetFilePos (NewPos : INT64); // Set new Current File Position + END; + + // --- The TAR Archive Writer CLASS + TTarWriter = CLASS + PROTECTED + FStream : TStream; + FOwnsStream : BOOLEAN; + FFinalized : BOOLEAN; + // --- Used at the next "Add" method call: --- + FPermissions : TTarPermissions; // Access permissions + FUID : INTEGER; // User ID + FGID : INTEGER; // Group ID + FUserName : STRING; // User name + FGroupName : STRING; // Group name + FMode : TTarModes; // Mode + FMagic : STRING; // Contents of the "Magic" field + CONSTRUCTOR CreateEmpty; + PUBLIC + CONSTRUCTOR Create (TargetStream : TStream); OVERLOAD; + CONSTRUCTOR Create (TargetFilename : STRING; Mode : INTEGER = fmCreate); OVERLOAD; + DESTRUCTOR Destroy; OVERRIDE; // Writes End-Of-File Tag + PROCEDURE AddFile (Filename : STRING; TarFilename : STRING = ''); + PROCEDURE AddStream (Stream : TStream; TarFilename : STRING; FileDateGmt : TDateTime); + PROCEDURE AddString (Contents : STRING; TarFilename : STRING; FileDateGmt : TDateTime); + PROCEDURE AddDir (Dirname : STRING; DateGmt : TDateTime; MaxDirSize : INT64 = 0); + PROCEDURE AddSymbolicLink (Filename, Linkname : STRING; DateGmt : TDateTime); + PROCEDURE AddLink (Filename, Linkname : STRING; DateGmt : TDateTime); + PROCEDURE AddVolumeHeader (VolumeId : STRING; DateGmt : TDateTime); + PROCEDURE Finalize; + PROPERTY Permissions : TTarPermissions READ FPermissions WRITE FPermissions; // Access permissions + PROPERTY UID : INTEGER READ FUID WRITE FUID; // User ID + PROPERTY GID : INTEGER READ FGID WRITE FGID; // Group ID + PROPERTY UserName : STRING READ FUserName WRITE FUserName; // User name + PROPERTY GroupName : STRING READ FGroupName WRITE FGroupName; // Group name + PROPERTY Mode : TTarModes READ FMode WRITE FMode; // Mode + PROPERTY Magic : STRING READ FMagic WRITE FMagic; // Contents of the "Magic" field + END; +// --- Some useful constants +CONST + FILETYPE_NAME : ARRAY [TFileType] OF STRING = + ('Regular', 'Link', 'Symbolic Link', 'Char File', 'Block File', + 'Directory', 'FIFO File', 'Contiguous', 'Dir Dump', 'Multivol', 'Volume Header'); + + ALL_PERMISSIONS = [tpReadByOwner, tpWriteByOwner, tpExecuteByOwner, + tpReadByGroup, tpWriteByGroup, tpExecuteByGroup, + tpReadByOther, tpWriteByOther, tpExecuteByOther]; + READ_PERMISSIONS = [tpReadByOwner, tpReadByGroup, tpReadByOther]; + WRITE_PERMISSIONS = [tpWriteByOwner, tpWriteByGroup, tpWriteByOther]; + EXECUTE_PERMISSIONS = [tpExecuteByOwner, tpExecuteByGroup, tpExecuteByOther]; + + +FUNCTION PermissionString (Permissions : TTarPermissions) : STRING; +FUNCTION ConvertFilename (Filename : STRING) : STRING; +FUNCTION FileTimeGMT (FileName : STRING) : TDateTime; OVERLOAD; +FUNCTION FileTimeGMT (SearchRec : TSearchRec) : TDateTime; OVERLOAD; +PROCEDURE ClearDirRec (VAR DirRec : TTarDirRec); + +IMPLEMENTATION + +FUNCTION PermissionString (Permissions : TTarPermissions) : STRING; +BEGIN + Result := ''; + IF tpReadByOwner IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-'; + IF tpWriteByOwner IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-'; + IF tpExecuteByOwner IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-'; + IF tpReadByGroup IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-'; + IF tpWriteByGroup IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-'; + IF tpExecuteByGroup IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-'; + IF tpReadByOther IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-'; + IF tpWriteByOther IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-'; + IF tpExecuteByOther IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-'; +END; + + +FUNCTION ConvertFilename (Filename : STRING) : STRING; + // Converts the filename to Unix conventions +BEGIN + {$IFDEF LINUX} + Result := Filename; + {$ELSE} + Result := StringReplace (Filename, '\', '/', [rfReplaceAll]); + {$ENDIF} +END; + + +FUNCTION FileTimeGMT (FileName: STRING): TDateTime; + // Returns the Date and Time of the last modification of the given File + // The Result is zero if the file could not be found + // The Result is given in UTC (GMT) time zone +VAR + SR : TSearchRec; +BEGIN + Result := 0.0; + IF FindFirst (FileName, faAnyFile, SR) = 0 THEN + Result := FileTimeGMT (SR); + FindClose (SR); +END; + + +FUNCTION FileTimeGMT (SearchRec : TSearchRec) : TDateTime; +{$IFNDEF UNIX} +VAR + SystemFileTime: TSystemTime; +{$ELSE} +VAR + TimeVal : TTimeVal; + TimeZone : TTimeZone; +{$ENDIF} +BEGIN + Result := 0.0; + {$IFNDEF UNIX} + {$WARNINGS OFF} + IF (SearchRec.FindData.dwFileAttributes AND faDirectory) = 0 THEN + IF FileTimeToSystemTime (SearchRec.FindData.ftLastWriteTime, SystemFileTime) THEN + Result := EncodeDate (SystemFileTime.wYear, SystemFileTime.wMonth, SystemFileTime.wDay) + + EncodeTime (SystemFileTime.wHour, SystemFileTime.wMinute, SystemFileTime.wSecond, SystemFileTime.wMilliseconds); + {$WARNINGS ON} + {$ELSE} + IF SearchRec.Attr AND faDirectory = 0 THEN BEGIN + Result := FileDateToDateTime (SearchRec.Time); + fpGetTimeOfDay (@TimeVal, @TimeZone); + Result := Result + TimeZone.tz_minuteswest / (60 * 24); + END; + {$ENDIF} +end; + + +PROCEDURE ClearDirRec (VAR DirRec : TTarDirRec); + // This is included because a FillChar (DirRec, SizeOf (DirRec), 0) + // will destroy the long string pointers, leading to strange bugs +BEGIN + WITH DirRec DO BEGIN + Name := ''; + Size := 0; + DateTime := 0.0; + Permissions := []; + FileType := TFileType (0); + LinkName := ''; + UID := 0; + GID := 0; + UserName := ''; + GroupName := ''; + ChecksumOK := FALSE; + Mode := []; + Magic := ''; + MajorDevNo := 0; + MinorDevNo := 0; + FilePos := 0; + END; +END; + +CONST + RECORDSIZE = 512; + NAMSIZ = 100; + TUNMLEN = 32; + TGNMLEN = 32; + CHKBLANKS = #32#32#32#32#32#32#32#32; + +TYPE + TTarHeader = PACKED RECORD + Name : ARRAY [0..NAMSIZ-1] OF CHAR; + Mode : ARRAY [0..7] OF CHAR; + UID : ARRAY [0..7] OF CHAR; + GID : ARRAY [0..7] OF CHAR; + Size : ARRAY [0..11] OF CHAR; + MTime : ARRAY [0..11] OF CHAR; + ChkSum : ARRAY [0..7] OF CHAR; + LinkFlag : CHAR; + LinkName : ARRAY [0..NAMSIZ-1] OF CHAR; + Magic : ARRAY [0..7] OF CHAR; + UName : ARRAY [0..TUNMLEN-1] OF CHAR; + GName : ARRAY [0..TGNMLEN-1] OF CHAR; + DevMajor : ARRAY [0..7] OF CHAR; + DevMinor : ARRAY [0..7] OF CHAR; + END; + +FUNCTION ExtractText (P : PChar) : STRING; +BEGIN + Result := STRING (P); +END; + + +FUNCTION ExtractNumber (P : PChar) : INTEGER; OVERLOAD; +VAR + Strg : STRING; +BEGIN + Strg := Trim (StrPas (P)); + P := PChar (Strg); + Result := 0; + WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN + Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3); + INC (P); + END; +END; + +FUNCTION ExtractNumber64 (P : PChar) : INT64; OVERLOAD; +VAR + Strg : STRING; +BEGIN + Strg := Trim (StrPas (P)); + P := PChar (Strg); + Result := 0; + WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN + Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3); + INC (P); + END; +END; + +FUNCTION ExtractNumber (P : PChar; MaxLen : INTEGER) : INTEGER; OVERLOAD; +VAR + S0 : ARRAY [0..255] OF CHAR; + Strg : STRING; +BEGIN + StrLCopy (S0, P, MaxLen); + Strg := Trim (StrPas (S0)); + P := PChar (Strg); + Result := 0; + WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN + Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3); + INC (P); + END; +END; + + +FUNCTION ExtractNumber64 (P : PChar; MaxLen : INTEGER) : INT64; OVERLOAD; +VAR + S0 : ARRAY [0..255] OF CHAR; + Strg : STRING; +BEGIN + StrLCopy (S0, P, MaxLen); + Strg := Trim (StrPas (S0)); + P := PChar (Strg); + Result := 0; + WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN + Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3); + INC (P); + END; +END; + + +FUNCTION Records (Bytes : INT64) : INT64; +BEGIN + Result := Bytes DIV RECORDSIZE; + IF Bytes MOD RECORDSIZE > 0 THEN + INC (Result); +END; + + +PROCEDURE Octal (N : INTEGER; P : PChar; Len : INTEGER); + // Makes a string of octal digits + // The string will always be "Len" characters long +VAR + I : INTEGER; +BEGIN + FOR I := Len-2 DOWNTO 0 DO BEGIN + (P+I)^ := CHR (ORD ('0') + ORD (N AND $07)); + N := N SHR 3; + END; + FOR I := 0 TO Len-3 DO + IF (P+I)^ = '0' + THEN (P+I)^ := #32 + ELSE BREAK; + (P+Len-1)^ := #32; +END; + + +PROCEDURE Octal64 (N : INT64; P : PChar; Len : INTEGER); + // Makes a string of octal digits + // The string will always be "Len" characters long +VAR + I : INTEGER; +BEGIN + FOR I := Len-2 DOWNTO 0 DO BEGIN + (P+I)^ := CHR (ORD ('0') + ORD (N AND $07)); + N := N SHR 3; + END; + FOR I := 0 TO Len-3 DO + IF (P+I)^ = '0' + THEN (P+I)^ := #32 + ELSE BREAK; + (P+Len-1)^ := #32; +END; + + +PROCEDURE OctalN (N : INTEGER; P : PChar; Len : INTEGER); +BEGIN + Octal (N, P, Len-1); + (P+Len-1)^ := #0; +END; + + +PROCEDURE WriteTarHeader (Dest : TStream; DirRec : TTarDirRec); +VAR + Rec : ARRAY [0..RECORDSIZE-1] OF CHAR; + TH : TTarHeader ABSOLUTE Rec; + Mode : INTEGER; + NullDate : TDateTime; + Checksum : CARDINAL; + I : INTEGER; +BEGIN + FillChar (Rec, RECORDSIZE, 0); + StrLCopy (TH.Name, PChar (DirRec.Name), NAMSIZ); + Mode := 0; + IF tmSaveText IN DirRec.Mode THEN Mode := Mode OR $0200; + IF tmSetGid IN DirRec.Mode THEN Mode := Mode OR $0400; + IF tmSetUid IN DirRec.Mode THEN Mode := Mode OR $0800; + IF tpReadByOwner IN DirRec.Permissions THEN Mode := Mode OR $0100; + IF tpWriteByOwner IN DirRec.Permissions THEN Mode := Mode OR $0080; + IF tpExecuteByOwner IN DirRec.Permissions THEN Mode := Mode OR $0040; + IF tpReadByGroup IN DirRec.Permissions THEN Mode := Mode OR $0020; + IF tpWriteByGroup IN DirRec.Permissions THEN Mode := Mode OR $0010; + IF tpExecuteByGroup IN DirRec.Permissions THEN Mode := Mode OR $0008; + IF tpReadByOther IN DirRec.Permissions THEN Mode := Mode OR $0004; + IF tpWriteByOther IN DirRec.Permissions THEN Mode := Mode OR $0002; + IF tpExecuteByOther IN DirRec.Permissions THEN Mode := Mode OR $0001; + OctalN (Mode, @TH.Mode, 8); + OctalN (DirRec.UID, @TH.UID, 8); + OctalN (DirRec.GID, @TH.GID, 8); + Octal64 (DirRec.Size, @TH.Size, 12); + NullDate := EncodeDate (1970, 1, 1); + IF DirRec.DateTime >= NullDate + THEN Octal (Trunc ((DirRec.DateTime - NullDate) * 86400.0), @TH.MTime, 12) + ELSE Octal (Trunc ( NullDate * 86400.0), @TH.MTime, 12); + CASE DirRec.FileType OF + ftNormal : TH.LinkFlag := '0'; + ftLink : TH.LinkFlag := '1'; + ftSymbolicLink : TH.LinkFlag := '2'; + ftCharacter : TH.LinkFlag := '3'; + ftBlock : TH.LinkFlag := '4'; + ftDirectory : TH.LinkFlag := '5'; + ftFifo : TH.LinkFlag := '6'; + ftContiguous : TH.LinkFlag := '7'; + ftDumpDir : TH.LinkFlag := 'D'; + ftMultiVolume : TH.LinkFlag := 'M'; + ftVolumeHeader : TH.LinkFlag := 'V'; + END; + StrLCopy (TH.LinkName, PChar (DirRec.LinkName), NAMSIZ); + StrLCopy (TH.Magic, PChar (DirRec.Magic + #32#32#32#32#32#32#32#32), 8); + StrLCopy (TH.UName, PChar (DirRec.UserName), TUNMLEN); + StrLCopy (TH.GName, PChar (DirRec.GroupName), TGNMLEN); + OctalN (DirRec.MajorDevNo, @TH.DevMajor, 8); + OctalN (DirRec.MinorDevNo, @TH.DevMinor, 8); + StrMove (TH.ChkSum, CHKBLANKS, 8); + + CheckSum := 0; + FOR I := 0 TO SizeOf (TTarHeader)-1 DO + INC (CheckSum, INTEGER (ORD (Rec [I]))); + OctalN (CheckSum, @TH.ChkSum, 8); + + Dest.Write (TH, RECORDSIZE); +END; + +CONSTRUCTOR TTarArchive.Create (Stream : TStream); +BEGIN + INHERITED Create; + FStream := Stream; + FOwnsStream := FALSE; + Reset; +END; + +CONSTRUCTOR TTarArchive.Create (Filename : STRING; FileMode : WORD); +BEGIN + INHERITED Create; + FStream := TFileStream.Create (Filename, FileMode); + FOwnsStream := TRUE; + Reset; +END; + +DESTRUCTOR TTarArchive.Destroy; +BEGIN + IF FOwnsStream THEN + FStream.Free; + INHERITED Destroy; +END; + +PROCEDURE TTarArchive.Reset; + // Reset File Pointer +BEGIN + FStream.Position := 0; + FBytesToGo := 0; +END; + +FUNCTION TTarArchive.FindNext (VAR DirRec : TTarDirRec) : BOOLEAN; + // Reads next Directory Info Record + // The Stream pointer must point to the first byte of the tar header +VAR + Rec : ARRAY [0..RECORDSIZE-1] OF CHAR; + CurFilePos : INTEGER; + Header : TTarHeader ABSOLUTE Rec; + I : INTEGER; + HeaderChkSum : WORD; + Checksum : CARDINAL; +BEGIN + // --- Scan until next pointer + IF FBytesToGo > 0 THEN + FStream.Seek (Records (FBytesToGo) * RECORDSIZE, soFromCurrent); + + // --- EOF reached? + Result := FALSE; + CurFilePos := FStream.Position; + TRY + FStream.ReadBuffer (Rec, RECORDSIZE); + if Rec [0] = #0 THEN EXIT; // EOF reached + EXCEPT + EXIT; // EOF reached, too + END; + Result := TRUE; + + ClearDirRec (DirRec); + + DirRec.FilePos := CurFilePos; + DirRec.Name := ExtractText (Header.Name); + DirRec.Size := ExtractNumber64 (@Header.Size, 12); + DirRec.DateTime := EncodeDate (1970, 1, 1) + (ExtractNumber (@Header.MTime, 12) / 86400.0); + I := ExtractNumber (@Header.Mode); + IF I AND $0100 <> 0 THEN Include (DirRec.Permissions, tpReadByOwner); + IF I AND $0080 <> 0 THEN Include (DirRec.Permissions, tpWriteByOwner); + IF I AND $0040 <> 0 THEN Include (DirRec.Permissions, tpExecuteByOwner); + IF I AND $0020 <> 0 THEN Include (DirRec.Permissions, tpReadByGroup); + IF I AND $0010 <> 0 THEN Include (DirRec.Permissions, tpWriteByGroup); + IF I AND $0008 <> 0 THEN Include (DirRec.Permissions, tpExecuteByGroup); + IF I AND $0004 <> 0 THEN Include (DirRec.Permissions, tpReadByOther); + IF I AND $0002 <> 0 THEN Include (DirRec.Permissions, tpWriteByOther); + IF I AND $0001 <> 0 THEN Include (DirRec.Permissions, tpExecuteByOther); + IF I AND $0200 <> 0 THEN Include (DirRec.Mode, tmSaveText); + IF I AND $0400 <> 0 THEN Include (DirRec.Mode, tmSetGid); + IF I AND $0800 <> 0 THEN Include (DirRec.Mode, tmSetUid); + CASE Header.LinkFlag OF + #0, '0' : DirRec.FileType := ftNormal; + '1' : DirRec.FileType := ftLink; + '2' : DirRec.FileType := ftSymbolicLink; + '3' : DirRec.FileType := ftCharacter; + '4' : DirRec.FileType := ftBlock; + '5' : DirRec.FileType := ftDirectory; + '6' : DirRec.FileType := ftFifo; + '7' : DirRec.FileType := ftContiguous; + 'D' : DirRec.FileType := ftDumpDir; + 'M' : DirRec.FileType := ftMultiVolume; + 'V' : DirRec.FileType := ftVolumeHeader; + END; + DirRec.LinkName := ExtractText (Header.LinkName); + DirRec.UID := ExtractNumber (@Header.UID); + DirRec.GID := ExtractNumber (@Header.GID); + DirRec.UserName := ExtractText (Header.UName); + DirRec.GroupName := ExtractText (Header.GName); + DirRec.Magic := Trim (ExtractText (Header.Magic)); + DirRec.MajorDevNo := ExtractNumber (@Header.DevMajor); + DirRec.MinorDevNo := ExtractNumber (@Header.DevMinor); + + HeaderChkSum := ExtractNumber (@Header.ChkSum); // Calc Checksum + CheckSum := 0; + StrMove (Header.ChkSum, CHKBLANKS, 8); + FOR I := 0 TO SizeOf (TTarHeader)-1 DO + INC (CheckSum, INTEGER (ORD (Rec [I]))); + DirRec.CheckSumOK := WORD (CheckSum) = WORD (HeaderChkSum); + + IF DirRec.FileType in [ftLink, ftSymbolicLink, ftDirectory, ftFifo, ftVolumeHeader] + THEN FBytesToGo := 0 + ELSE FBytesToGo := DirRec.Size; +END; + + +PROCEDURE TTarArchive.ReadFile (Buffer : POINTER); + // Reads file data for the last Directory Record. The entire file is read into the buffer. + // The buffer must be large enough to take up the whole file. +VAR + RestBytes : INTEGER; +BEGIN + IF FBytesToGo = 0 THEN EXIT; + RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo; + FStream.ReadBuffer (Buffer^, FBytesToGo); + FStream.Seek (RestBytes, soFromCurrent); + FBytesToGo := 0; +END; + + +PROCEDURE TTarArchive.ReadFile (Stream : TStream); + // Reads file data for the last Directory Record. + // The entire file is written out to the stream. + // The stream is left at its current position prior to writing +VAR + RestBytes : INTEGER; +BEGIN + IF FBytesToGo = 0 THEN EXIT; + RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo; + Stream.CopyFrom (FStream, FBytesToGo); + FStream.Seek (RestBytes, soFromCurrent); + FBytesToGo := 0; +END; + + +PROCEDURE TTarArchive.ReadFile (Filename : STRING); + // Reads file data for the last Directory Record. + // The entire file is saved in the given Filename +VAR + FS : TFileStream; +BEGIN + FS := TFileStream.Create (Filename, fmCreate); + TRY + ReadFile (FS); + FINALLY + FS.Free; + END; +END; + + +FUNCTION TTarArchive.ReadFile : STRING; + // Reads file data for the last Directory Record. The entire file is returned + // as a large ANSI string. +VAR + RestBytes : INTEGER; +BEGIN + IF FBytesToGo = 0 THEN EXIT; + RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo; + SetLength (Result, FBytesToGo); + FStream.ReadBuffer (PChar (Result)^, FBytesToGo); + FStream.Seek (RestBytes, soFromCurrent); + FBytesToGo := 0; +END; + + +PROCEDURE TTarArchive.GetFilePos (VAR Current, Size : INT64); + // Returns the Current Position in the TAR stream +BEGIN + Current := FStream.Position; + Size := FStream.Size; +END; + + +PROCEDURE TTarArchive.SetFilePos (NewPos : INT64); // Set new Current File Position +BEGIN + IF NewPos < FStream.Size THEN + FStream.Seek (NewPos, soFromBeginning); +END; + + +CONSTRUCTOR TTarWriter.CreateEmpty; +VAR + TP : TTarPermission; +BEGIN + INHERITED Create; + FOwnsStream := FALSE; + FFinalized := FALSE; + FPermissions := []; + FOR TP := Low (TP) TO High (TP) DO + Include (FPermissions, TP); + FUID := 0; + FGID := 0; + FUserName := ''; + FGroupName := ''; + FMode := []; + FMagic := 'ustar'; +END; + +CONSTRUCTOR TTarWriter.Create (TargetStream : TStream); +BEGIN + CreateEmpty; + FStream := TargetStream; + FOwnsStream := FALSE; +END; + + +CONSTRUCTOR TTarWriter.Create (TargetFilename : STRING; Mode : INTEGER = fmCreate); +BEGIN + CreateEmpty; + FStream := TFileStream.Create (TargetFilename, Mode); + FOwnsStream := TRUE; +END; + + +DESTRUCTOR TTarWriter.Destroy; +BEGIN + IF NOT FFinalized THEN BEGIN + Finalize; + FFinalized := TRUE; + END; + IF FOwnsStream THEN + FStream.Free; + INHERITED Destroy; +END; + + +PROCEDURE TTarWriter.AddFile (Filename : STRING; TarFilename : STRING = ''); +VAR + S : TFileStream; + Date : TDateTime; +BEGIN + Date := FileTimeGMT (Filename); + IF TarFilename = '' + THEN TarFilename := ConvertFilename (Filename) + ELSE TarFilename := ConvertFilename (TarFilename); + S := TFileStream.Create (Filename, fmOpenRead OR fmShareDenyWrite); + TRY + AddStream (S, TarFilename, Date); + FINALLY + S.Free + END; +END; + + +PROCEDURE TTarWriter.AddStream (Stream : TStream; TarFilename : STRING; FileDateGmt : TDateTime); +VAR + DirRec : TTarDirRec; + Rec : ARRAY [0..RECORDSIZE-1] OF CHAR; + BytesToRead : INT64; // Bytes to read from the Source Stream + BlockSize : INT64; // Bytes to write out for the current record +BEGIN + ClearDirRec (DirRec); + DirRec.Name := TarFilename; + DirRec.Size := Stream.Size - Stream.Position; + DirRec.DateTime := FileDateGmt; + DirRec.Permissions := FPermissions; + DirRec.FileType := ftNormal; + DirRec.LinkName := ''; + DirRec.UID := FUID; + DirRec.GID := FGID; + DirRec.UserName := FUserName; + DirRec.GroupName := FGroupName; + DirRec.ChecksumOK := TRUE; + DirRec.Mode := FMode; + DirRec.Magic := FMagic; + DirRec.MajorDevNo := 0; + DirRec.MinorDevNo := 0; + + WriteTarHeader (FStream, DirRec); + BytesToRead := DirRec.Size; + WHILE BytesToRead > 0 DO BEGIN + BlockSize := BytesToRead; + IF BlockSize > RECORDSIZE THEN BlockSize := RECORDSIZE; + FillChar (Rec, RECORDSIZE, 0); + Stream.Read (Rec, BlockSize); + FStream.Write (Rec, RECORDSIZE); + DEC (BytesToRead, BlockSize); + END; +END; + + +PROCEDURE TTarWriter.AddString (Contents : STRING; TarFilename : STRING; FileDateGmt : TDateTime); +VAR + S : TStringStream; +BEGIN + S := TStringStream.Create (Contents); + TRY + AddStream (S, TarFilename, FileDateGmt); + FINALLY + S.Free + END +END; + + +PROCEDURE TTarWriter.AddDir (Dirname : STRING; DateGmt : TDateTime; MaxDirSize : INT64 = 0); +VAR + DirRec : TTarDirRec; +BEGIN + ClearDirRec (DirRec); + DirRec.Name := Dirname; + DirRec.Size := MaxDirSize; + DirRec.DateTime := DateGmt; + DirRec.Permissions := FPermissions; + DirRec.FileType := ftDirectory; + DirRec.LinkName := ''; + DirRec.UID := FUID; + DirRec.GID := FGID; + DirRec.UserName := FUserName; + DirRec.GroupName := FGroupName; + DirRec.ChecksumOK := TRUE; + DirRec.Mode := FMode; + DirRec.Magic := FMagic; + DirRec.MajorDevNo := 0; + DirRec.MinorDevNo := 0; + + WriteTarHeader (FStream, DirRec); +END; + + +PROCEDURE TTarWriter.AddSymbolicLink (Filename, Linkname : STRING; DateGmt : TDateTime); +VAR + DirRec : TTarDirRec; +BEGIN + ClearDirRec (DirRec); + DirRec.Name := Filename; + DirRec.Size := 0; + DirRec.DateTime := DateGmt; + DirRec.Permissions := FPermissions; + DirRec.FileType := ftSymbolicLink; + DirRec.LinkName := Linkname; + DirRec.UID := FUID; + DirRec.GID := FGID; + DirRec.UserName := FUserName; + DirRec.GroupName := FGroupName; + DirRec.ChecksumOK := TRUE; + DirRec.Mode := FMode; + DirRec.Magic := FMagic; + DirRec.MajorDevNo := 0; + DirRec.MinorDevNo := 0; + + WriteTarHeader (FStream, DirRec); +END; + + +PROCEDURE TTarWriter.AddLink (Filename, Linkname : STRING; DateGmt : TDateTime); +VAR + DirRec : TTarDirRec; +BEGIN + ClearDirRec (DirRec); + DirRec.Name := Filename; + DirRec.Size := 0; + DirRec.DateTime := DateGmt; + DirRec.Permissions := FPermissions; + DirRec.FileType := ftLink; + DirRec.LinkName := Linkname; + DirRec.UID := FUID; + DirRec.GID := FGID; + DirRec.UserName := FUserName; + DirRec.GroupName := FGroupName; + DirRec.ChecksumOK := TRUE; + DirRec.Mode := FMode; + DirRec.Magic := FMagic; + DirRec.MajorDevNo := 0; + DirRec.MinorDevNo := 0; + + WriteTarHeader (FStream, DirRec); +END; + + +PROCEDURE TTarWriter.AddVolumeHeader (VolumeId : STRING; DateGmt : TDateTime); +VAR + DirRec : TTarDirRec; +BEGIN + ClearDirRec (DirRec); + DirRec.Name := VolumeId; + DirRec.Size := 0; + DirRec.DateTime := DateGmt; + DirRec.Permissions := FPermissions; + DirRec.FileType := ftVolumeHeader; + DirRec.LinkName := ''; + DirRec.UID := FUID; + DirRec.GID := FGID; + DirRec.UserName := FUserName; + DirRec.GroupName := FGroupName; + DirRec.ChecksumOK := TRUE; + DirRec.Mode := FMode; + DirRec.Magic := FMagic; + DirRec.MajorDevNo := 0; + DirRec.MinorDevNo := 0; + + WriteTarHeader (FStream, DirRec); +END; + + +PROCEDURE TTarWriter.Finalize; + // Writes the End-Of-File Tag + // Data after this tag will be ignored + // The destructor calls this automatically if you didn't do it before +VAR + Rec : ARRAY [0..RECORDSIZE-1] OF CHAR; +BEGIN + FillChar (Rec, SizeOf (Rec), 0); + FStream.Write (Rec, RECORDSIZE); + FFinalized := TRUE; +END; + + +END. + diff --git a/dcm2nii/LibTar.ppu b/dcm2nii/LibTar.ppu new file mode 100644 index 0000000..201fe7a Binary files /dev/null and b/dcm2nii/LibTar.ppu differ diff --git a/dcm2nii/SelectFolder.pas b/dcm2nii/SelectFolder.pas new file mode 100755 index 0000000..406d3b1 --- /dev/null +++ b/dcm2nii/SelectFolder.pas @@ -0,0 +1,97 @@ +unit SelectFolder; + +interface + +function BrowseForFolder(const browseTitle: String; + const initialFolder: String = ''; + mayCreateNewFolder: Boolean = False): String; + +function SelectDirectoryDelphi(const browseTitle: String; var Folder: String; mayCreateNewFolder: Boolean = False): boolean; +implementation + +uses + Windows, Forms, shlobj; + +function SelectDirectoryDelphi(const browseTitle: String; var Folder: String; mayCreateNewFolder: Boolean = False): boolean; +var + lTemp: string; +begin + result := false; + lTemp := BrowseForFolder(browseTitle, Folder, mayCreateNewFolder); + if (lTemp <> '') then begin + Folder := lTemp; + result := true; + end; +// +end; + +var + lg_StartFolder: String; + + + +// With later versions of Delphi you may not need these constants. +const + BIF_NEWDIALOGSTYLE=$40; + BIF_NONEWFOLDERBUTTON=$200; + +//////////////////////////////////////////////////////////////////////// +// Call back function used to set the initial browse directory. +//////////////////////////////////////////////////////////////////////// +function BrowseForFolderCallBack(Wnd: HWND; uMsg: UINT; lParam, +lpData: LPARAM): Integer stdcall; +begin + if uMsg = BFFM_INITIALIZED then + SendMessage(Wnd,BFFM_SETSELECTION, 1, Integer(@lg_StartFolder[1])); + result := 0; +end; + +//////////////////////////////////////////////////////////////////////// +// This function allows the user to browse for a folder +// +// Arguments:- +// browseTitle : The title to display on the browse dialog. +// initialFolder : Optional argument. Use to specify the folder +// initially selected when the dialog opens. +// mayCreateNewFolder : Flag indicating whether the user can create a +// new folder. +// +// Returns: The empty string if no folder was selected (i.e. if the user +// clicked cancel), otherwise the full folder path. +//////////////////////////////////////////////////////////////////////// +function BrowseForFolder(const browseTitle: String; + const initialFolder: String =''; + mayCreateNewFolder: Boolean = False): String; +var + browse_info: TBrowseInfo; + folder: array[0..MAX_PATH] of char; + find_context: PItemIDList; +begin + //-------------------------- + // Initialise the structure. + //-------------------------- + FillChar(browse_info,SizeOf(browse_info),#0); + lg_StartFolder := initialFolder; + browse_info.pszDisplayName := @folder[0]; + browse_info.lpszTitle := PChar(browseTitle); + browse_info.ulFlags := BIF_RETURNONLYFSDIRS or BIF_NEWDIALOGSTYLE; + if not mayCreateNewFolder then + browse_info.ulFlags := browse_info.ulFlags or BIF_NONEWFOLDERBUTTON; + + browse_info.hwndOwner := Application.Handle; + if initialFolder <> '' then + browse_info.lpfn := BrowseForFolderCallBack; + find_context := SHBrowseForFolder(browse_info); + if Assigned(find_context) then + begin + if SHGetPathFromIDList(find_context,folder) then + result := folder + else + result := ''; + GlobalFreePtr(find_context); + end + else + result := ''; +end; + +end. \ No newline at end of file diff --git a/dcm2nii/Thumbs.db b/dcm2nii/Thumbs.db new file mode 100755 index 0000000..9904c49 Binary files /dev/null and b/dcm2nii/Thumbs.db differ diff --git a/dcm2nii/backup/dcm2niigui.lpi.bak b/dcm2nii/backup/dcm2niigui.lpi.bak new file mode 100755 index 0000000..e7a91dc --- /dev/null +++ b/dcm2nii/backup/dcm2niigui.lpi.bak @@ -0,0 +1,429 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <LRSInOutputDirectory Value="False"/> + </Flags> + <MainUnit Value="0"/> + <Title Value="dcm2niigui.exe"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <MacroValues Count="1"> + <Macro1 Name="LCLWidgetType" Value="cocoa"/> + </MacroValues> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + <SharedMatrixOptions Count="1"> + <Item1 ID="375676005044" Modes="default" Type="IDEMacro" MacroName="LCLWidgetType" Value="cocoa"/> + </SharedMatrixOptions> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="27"> + <Unit0> + <Filename Value="dcm2niigui.lpr"/> + <IsPartOfProject Value="True"/> + <CursorPos X="2"/> + <UsageCount Value="206"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit0> + <Unit1> + <Filename Value="gui.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MainForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="5"/> + <TopLine Value="387"/> + <CursorPos X="32" Y="398"/> + <UsageCount Value="206"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit1> + <Unit2> + <Filename Value="nifti_form.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="NIfTIForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="66"/> + <CursorPos X="26" Y="73"/> + <UsageCount Value="206"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit2> + <Unit3> + <Filename Value="pref_form.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="PrefsForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <TopLine Value="161"/> + <CursorPos X="26" Y="174"/> + <UsageCount Value="206"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit3> + <Unit4> + <Filename Value="niftiutil.pas"/> + <EditorIndex Value="3"/> + <TopLine Value="320"/> + <CursorPos X="57" Y="343"/> + <UsageCount Value="78"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit4> + <Unit5> + <Filename Value="prefs.pas"/> + <EditorIndex Value="2"/> + <TopLine Value="100"/> + <CursorPos X="17" Y="110"/> + <UsageCount Value="103"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit5> + <Unit6> + <Filename Value="dicomtypes.pas"/> + <EditorIndex Value="10"/> + <TopLine Value="297"/> + <CursorPos X="31" Y="310"/> + <UsageCount Value="104"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit6> + <Unit7> + <Filename Value="..\common\define_types.pas"/> + <EditorIndex Value="8"/> + <CursorPos X="18" Y="2"/> + <UsageCount Value="113"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit7> + <Unit8> + <Filename Value="convert.pas"/> + <TopLine Value="73"/> + <CursorPos X="7" Y="78"/> + <UsageCount Value="115"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit8> + <Unit9> + <Filename Value="..\common\gzio2.pas"/> + <CursorPos X="114"/> + <UsageCount Value="80"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit9> + <Unit10> + <Filename Value="..\common\GraphicsMathLibrary.pas"/> + <TopLine Value="592"/> + <CursorPos X="27" Y="585"/> + <UsageCount Value="111"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit10> + <Unit11> + <Filename Value="..\common\dialogsx.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="74"/> + <CursorPos X="18" Y="86"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit11> + <Unit12> + <Filename Value="dicomcompat.pas"/> + <EditorIndex Value="9"/> + <TopLine Value="6483"/> + <CursorPos X="81" Y="6488"/> + <UsageCount Value="114"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit12> + <Unit13> + <Filename Value="sortdicom.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="330"/> + <CursorPos X="23" Y="351"/> + <UsageCount Value="66"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit13> + <Unit14> + <Filename Value="philips_bvec.pas"/> + <IsPartOfProject Value="True"/> + <CursorPos X="117" Y="248"/> + <UsageCount Value="214"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit14> + <Unit15> + <Filename Value="..\common\isgui.inc"/> + <EditorIndex Value="-1"/> + <CursorPos X="10"/> + <UsageCount Value="11"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit15> + <Unit16> + <Filename Value="csaread.pas"/> + <EditorIndex Value="1"/> + <TopLine Value="233"/> + <CursorPos X="67" Y="239"/> + <UsageCount Value="102"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit16> + <Unit17> + <Filename Value="dialogs_msg.pas"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="-1"/> + <CursorPos X="11" Y="27"/> + <UsageCount Value="208"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit17> + <Unit18> + <Filename Value="..\common\nifti_types.pas"/> + <EditorIndex Value="4"/> + <CursorPos X="9" Y="11"/> + <UsageCount Value="100"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit18> + <Unit19> + <Filename Value="..\common\nifti_foreign.pas"/> + <TopLine Value="416"/> + <CursorPos X="74" Y="419"/> + <UsageCount Value="71"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit19> + <Unit20> + <Filename Value="parconvert.pas"/> + <EditorIndex Value="-1"/> + <CursorPos X="153" Y="4"/> + <UsageCount Value="26"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit20> + <Unit21> + <Filename Value="bvec.pas"/> + <EditorIndex Value="7"/> + <CursorPos X="75" Y="11"/> + <UsageCount Value="44"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit21> + <Unit22> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\customform.inc"/> + <EditorIndex Value="-1"/> + <TopLine Value="2528"/> + <CursorPos Y="2536"/> + <UsageCount Value="25"/> + </Unit22> + <Unit23> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\menuitem.inc"/> + <CursorPos X="50"/> + <UsageCount Value="6"/> + </Unit23> + <Unit24> + <Filename Value="dicom.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="5"/> + <CursorPos X="43" Y="20"/> + <UsageCount Value="25"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit24> + <Unit25> + <Filename Value="paramstrs.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="60"/> + <CursorPos X="10" Y="71"/> + <UsageCount Value="25"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit25> + <Unit26> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\clipbrd.inc"/> + <EditorIndex Value="6"/> + <TopLine Value="51"/> + <CursorPos Y="58"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit26> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="dicomcompat.pas"/> + <Caret Line="3228" Column="52" TopLine="3212"/> + </Position1> + <Position2> + <Filename Value="dicomcompat.pas"/> + <Caret Line="3929" Column="21" TopLine="3913"/> + </Position2> + <Position3> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5972" Column="23" TopLine="5965"/> + </Position3> + <Position4> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5974" Column="26" TopLine="5965"/> + </Position4> + <Position5> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5975" Column="47" TopLine="5965"/> + </Position5> + <Position6> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6097" Column="26" TopLine="6090"/> + </Position6> + <Position7> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6098" Column="47" TopLine="6090"/> + </Position7> + <Position8> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6498" Column="82" TopLine="6482"/> + </Position8> + <Position9> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6499" Column="63" TopLine="6483"/> + </Position9> + <Position10> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6500" Column="122" TopLine="6484"/> + </Position10> + <Position11> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6501" Column="86" TopLine="6485"/> + </Position11> + <Position12> + <Filename Value="dicomcompat.pas"/> + <Caret Line="3228" Column="52" TopLine="3223"/> + </Position12> + <Position13> + <Filename Value="dicomcompat.pas"/> + <Caret Line="3929" Column="21" TopLine="3906"/> + </Position13> + <Position14> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5972" Column="23" TopLine="5961"/> + </Position14> + <Position15> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5974" Column="26" TopLine="5961"/> + </Position15> + <Position16> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5982" Column="29" TopLine="5967"/> + </Position16> + <Position17> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6501" Column="17" TopLine="6483"/> + </Position17> + <Position18> + <Filename Value="dicomtypes.pas"/> + <Caret Line="270" Column="92" TopLine="266"/> + </Position18> + <Position19> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6501" Column="11" TopLine="6483"/> + </Position19> + <Position20> + <Filename Value="dicomtypes.pas"/> + <Caret Line="191" Column="25" TopLine="182"/> + </Position20> + <Position21> + <Filename Value="gui.pas"/> + <Caret Line="4" Column="89"/> + </Position21> + <Position22> + <Filename Value="gui.pas"/> + <Caret Line="492" Column="44" TopLine="488"/> + </Position22> + <Position23> + <Filename Value="gui.pas"/> + <Caret Line="493" Column="44" TopLine="489"/> + </Position23> + <Position24> + <Filename Value="gui.pas"/> + <Caret Line="494" Column="44" TopLine="490"/> + </Position24> + <Position25> + <Filename Value="gui.pas"/> + <Caret Line="18" Column="76" TopLine="17"/> + </Position25> + <Position26> + <Filename Value="gui.pas"/> + <Caret Line="494" Column="47" TopLine="485"/> + </Position26> + <Position27> + <Filename Value="gui.pas"/> + <Caret Line="414" Column="31" TopLine="408"/> + </Position27> + <Position28> + <Filename Value="gui.pas"/> + <Caret Line="82" Column="26" TopLine="71"/> + </Position28> + <Position29> + <Filename Value="gui.pas"/> + <Caret Line="138" Column="26" TopLine="124"/> + </Position29> + <Position30> + <Filename Value="gui.pas"/> + <Caret Line="370" Column="32" TopLine="355"/> + </Position30> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <OtherUnitFiles Value="..\common"/> + <SrcPath Value="C:\lazarus\ideintf"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <SyntaxMode Value="Delphi"/> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + <UseLineInfoUnit Value="False"/> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <WriteFPCLogo Value="False"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="2"> + <Item1> + <Name Value="ECodetoolError"/> + </Item1> + <Item2> + <Name Value="EFOpenError"/> + </Item2> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/dcm2nii/backup/gui.lfm.bak b/dcm2nii/backup/gui.lfm.bak new file mode 100755 index 0000000..272913f --- /dev/null +++ b/dcm2nii/backup/gui.lfm.bak @@ -0,0 +1,163 @@ +object MainForm: TMainForm + Left = 533 + Height = 363 + Top = 105 + Width = 598 + ActiveControl = Panel1 + AllowDropFiles = True + BorderWidth = 1 + Caption = 'dcm2nii' + ClientHeight = 363 + ClientWidth = 598 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnDropFiles = FormDropFiles + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.4.2.0' + object Memo1: TMemo + Left = 5 + Height = 321 + Top = 37 + Width = 588 + Align = alClient + BorderSpacing.Left = 4 + BorderSpacing.Top = 2 + BorderSpacing.Right = 4 + BorderSpacing.Bottom = 4 + ScrollBars = ssAutoVertical + TabOrder = 0 + end + object Panel1: TPanel + Left = 1 + Height = 34 + Top = 1 + Width = 596 + Align = alTop + BevelOuter = bvNone + BorderWidth = 2 + BorderStyle = bsSingle + ClientHeight = 34 + ClientWidth = 596 + TabOrder = 1 + object Label1: TLabel + Left = 1 + Height = 26 + Top = 5 + Width = 140 + Alignment = taRightJustify + Anchors = [akLeft] + AutoSize = False + Caption = 'Output Format: ' + ParentColor = False + end + object TypeCombo: TComboBox + Left = 160 + Height = 20 + Top = 3 + Width = 264 + ItemHeight = 0 + Items.Strings = ( + 'SPM2 (3D Anlyze hdr/img)' + 'SPM5 (3D NIfTI hdr/img)' + 'SPM8 (3D NIfTI nii)' + '4D NIfTI hdr/img' + 'FSL/SPM8 (4D NIfTI nii)' + 'Compressed FSL (4D NIfTI nii)' + ) + Style = csDropDownList + TabOrder = 0 + end + end + object OpenHdrDlg: TOpenDialog + FilterIndex = 0 + left = 24 + top = 48 + end + object MainMenu1: TMainMenu + left = 88 + top = 48 + object AppleMenu: TMenuItem + Caption = '' + Visible = False + object ApplePrefs: TMenuItem + Caption = 'Preferences' + OnClick = Preferences1Click + end + end + object File1: TMenuItem + Caption = 'File' + object DICOMtoNIfTI1: TMenuItem + Caption = 'DICOM to NIfTI' + ShortCut = 16452 + OnClick = dcm2niiBtnClick + end + object ModifyNIfTI1: TMenuItem + Caption = 'Modify NIfTI' + OnClick = ModifyNIfTI1Click + end + object NIfTI3D4D1: TMenuItem + Caption = 'NIfTI 3D -> 4D' + OnClick = NIfTI3D4D1Click + end + object AnonymizeDICOM1: TMenuItem + Caption = 'Anonymize DICOM' + OnClick = AnonymizeDICOM1Click + end + object Exit1: TMenuItem + Caption = 'Exit' + OnClick = Exit1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + end + object UntestedMenu: TMenuItem + Caption = 'Untested' + object MirrorXdimension1: TMenuItem + Caption = 'Mirror X-dimension' + OnClick = MirrorXdimension1Click + end + object SumTPM1: TMenuItem + Caption = 'Sum TPM' + OnClick = SumTPM1Click + end + object ExtractDICOMdims1: TMenuItem + Caption = 'Extract DICOM dims' + OnClick = ExtractDICOMdims1Click + end + object ExtractDICOMhdr1: TMenuItem + Caption = 'Extract DICOM header' + OnClick = ExtractDICOMhdr1Click + end + object ExtractNIfTIhdrs1: TMenuItem + Caption = 'Extract NIfTI header' + OnClick = ExtractNIfTIhdrs1Click + end + object HalveMenu1: TMenuItem + Caption = 'Halve dimensions in-plane' + OnClick = HalveMenu1Click + end + end + object Help1: TMenuItem + Caption = 'Help' + object Preferences1: TMenuItem + Caption = 'Preferences' + OnClick = Preferences1Click + end + object About1: TMenuItem + Caption = 'Help' + OnClick = About1Click + end + end + end + object SelectDirectoryDialog1: TSelectDirectoryDialog + left = 159 + top = 54 + end +end diff --git a/dcm2nii/backup/gui.pas.bak b/dcm2nii/backup/gui.pas.bak new file mode 100755 index 0000000..6584063 --- /dev/null +++ b/dcm2nii/backup/gui.pas.bak @@ -0,0 +1,1179 @@ +unit gui; +{$IFDEF FPC}{$mode objfpc}{$H+}{$ENDIF} +interface +uses + +{$IFDEF FPC}LResources,LCLIntf, {$ELSE} Messages,{$ENDIF} +{$IFNDEF UNIX} Windows,ShellAPI,ShlObj, +{$ELSE} +//BaseUnix, +LCLType, +{$ENDIF} +//Messages, +SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, +//ToolWin, +//ComCtrls, +ExtCtrls, nifti_types, +//IniFiles, +define_types,sortdicom,//dicom, +parconvert, +//filename,convert, nifti_hdr,ConvertSimple, +userdir, paramstrs,nii_math,dicomtypes,nii_crop, +nii_orient, nii_4dto3d,nii_asl,nii_reslice, Menus,nii_3dto4d,prefs, +GraphicsMathLibrary; +{$IFDEF FPC} +type + { TMainForm } + TMainForm = class(TForm) + AppleMenu: TMenuItem; + ApplePrefs: TMenuItem; + SelectDirectoryDialog1: TSelectDirectoryDialog;//<-Lazarus only - does not exist in Delphi 4 + Label1: TLabel; + MainMenu1: TMainMenu; + File1: TMenuItem; + Edit1: TMenuItem; + Help1: TMenuItem; + About1: TMenuItem; + Copy1: TMenuItem; + DICOMtoNIfTI1: TMenuItem; + AnonymizeDICOM1: TMenuItem; + Exit1: TMenuItem; + ExtractDICOMdims1: TMenuItem; + ExtractDICOMhdr1: TMenuItem; + ExtractNIfTIhdrs1: TMenuItem; + SumTPM1: TMenuItem; + MirrorXdimension1: TMenuItem; + UntestedMenu: TMenuItem; + NIfTI3D4D1: TMenuItem; + ModifyNIfTI1: TMenuItem; + Preferences1: TMenuItem; + Memo1: TMemo; + OpenHdrDlg: TOpenDialog; + Panel1: TPanel; + TypeCombo: TComboBox; + ResliceNIfTI1: TMenuItem; + Deletenondcm1: TMenuItem; + HalveMenu1: TMenuItem; + procedure SavePrefs; + procedure ExtractDICOMdims1Click(Sender: TObject); + procedure ExtractDICOMhdr1Click(Sender: TObject); + procedure ExtractNIfTIhdrs1Click(Sender: TObject); + procedure FormClose(Sender: TObject; var vAction: TCloseAction); + procedure FormDropFiles(Sender: TObject; const FileNames: array of String); + procedure HalveMenu1Click(Sender: TObject); + function OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean; + procedure CheckPrefs (var lPrefs: TPrefs; lWrite: boolean); + function ConvertDCM2NII (lFilename: string; var lPrefs: TPrefs): boolean; + procedure FormCreate(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure Preferences1Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure SumTPM1Click(Sender: TObject); + procedure TypeComboChange(Sender: TObject); + procedure AnonymizeDICOM1Click(Sender: TObject); + procedure ModifyNIfTI1Click(Sender: TObject); + procedure NIfTI3D4D1Click(Sender: TObject); + procedure ResliceNIfTI1Click(Sender: TObject); + procedure Deletenondcm1Click(Sender: TObject); + procedure dcm2niiBtnClick(Sender: TObject); + procedure MirrorXdimension1Click(Sender: TObject); + function BrowseDialog(const Title: string): string; + end; +{$ELSE} +type + TMainForm = class(TForm) + Label1: TLabel; + MainMenu1: TMainMenu; + File1: TMenuItem; + Edit1: TMenuItem; + Help1: TMenuItem; + About1: TMenuItem; + Copy1: TMenuItem; + DICOMtoNIfTI1: TMenuItem; + AnonymizeDICOM1: TMenuItem; + Exit1: TMenuItem; + ExtractDICOMdims1: TMenuItem; + ExtractDICOMhdr1: TMenuItem; + ExtractNIfTIhdrs1: TMenuItem; + SumTPM1: TMenuItem; + MirrorXdimension1: TMenuItem; + UntestedMenu: TMenuItem; + NIfTI3D4D1: TMenuItem; + ModifyNIfTI1: TMenuItem; + Preferences1: TMenuItem; + Memo1: TMemo; + OpenHdrDlg: TOpenDialog; + Panel1: TPanel; + TypeCombo: TComboBox; + ResliceNIfTI1: TMenuItem; + Deletenondcm1: TMenuItem; + HalveMenu1: TMenuItem; + procedure SavePrefs; + procedure ExtractDICOMdims1Click(Sender: TObject); + procedure ExtractDICOMhdr1Click(Sender: TObject); + procedure ExtractNIfTIhdrs1Click(Sender: TObject); + procedure FormClose(Sender: TObject; var vAction: TCloseAction); + procedure FormDropFiles(Sender: TObject; const FileNames: array of String); + procedure HalveMenu1Click(Sender: TObject); + function OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean; + procedure CheckPrefs (var lPrefs: TPrefs; lWrite: boolean); + function ConvertDCM2NII (lFilename: string; var lPrefs: TPrefs): boolean; + procedure FormCreate(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure Preferences1Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure SumTPM1Click(Sender: TObject); + procedure TypeComboChange(Sender: TObject); + procedure AnonymizeDICOM1Click(Sender: TObject); + procedure ModifyNIfTI1Click(Sender: TObject); + procedure NIfTI3D4D1Click(Sender: TObject); + procedure ResliceNIfTI1Click(Sender: TObject); + procedure Deletenondcm1Click(Sender: TObject); + procedure dcm2niiBtnClick(Sender: TObject); + procedure MirrorXdimension1Click(Sender: TObject); + function BrowseDialog(const Title: string): string; + private + procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES; //<-Delphi only - does not exist in Lazarus + end; +{$ENDIF} +var + MainForm: TMainForm; + +implementation + +uses untar,pref_form, nifti_form,niftiutil{$IFNDEF UNIX},ActiveX {$ENDIF}; +{$IFNDEF FPC} +{$R *.DFM} +{$R windowsxp.res} +{$ENDIF} + +procedure MsgX (lStr: string); +begin + MainForm.Memo1.Lines.Add(lStr); +end; + +function is4D (var lHdr: TNIFTIhdr): boolean; +begin + if lHdr.dim[4] > 1 then + result := true + else + result := false; +end; +function SelectProcessNIFTI (var lHdr: TNIFTIhdr; var lFilename: string): integer; +begin + result := -1; //returns -1 if error + if is4D(lHdr) then begin + NIfTIForm.Combo3D.visible := false; + NIfTIForm.Combo4D.visible := true; + end else begin + //NIfTIForm.Combo3D.itemIndex := 2; + NIfTIForm.Combo3D.visible := true; + NIfTIForm.Combo4D.visible := false; + end; + NiftiForm.Combo4DChange(nil); + NIftiForm.caption := extractfilename(lFilename); + //next - let user specify task + NiftiForm.showmodal; + if (NiftiForm.ModalResult = mrCancel) then + exit; + if is4D(lHdr) then + result := NiftiForm.Combo4D.ItemIndex + else + result := NiftiForm.Combo3D.ItemIndex; +end; + +procedure ProcessNIfTI(lFilenames : TStrings; lPrefs: TPrefs); +var + l4D, lPrev4D, lByteSwap: boolean; + lINc,lProcess: integer; + lExt,lFilename,lOutname: string; + lHdr: TNIFTIhdr; + lO: TNIIOpts; +begin + if lFilenames.Count < 1 then exit; + lPrev4D := false; //ignored in if statement - set only to avoid compiler warning + lProcess := 0; //always set in if statement - set only to avoid compiler warning + for lInc := 1 to lFilenames.Count do begin + lFilename := lFilenames.Strings[lInc-1]; + lExt := UpCaseExt(lFilename); + if lExt ='.IMG' then + lFilename := changefileext(lFilename,'.hdr'); + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lO) then begin + MsgX('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + l4D := is4D(lHdr); + //choose process + //fx( lFilenames.Count,777); + if (lInc = 1) or (l4D <> lPrev4D) then begin + lProcess := SelectProcessNIFTI(lHdr,lFilename); + if lProcess < 0 then exit; + lPrev4D := l4D; + end; + //next - convert image as specified + SetOutputFormat(NIfTIForm.TypeCombo.ItemIndex,lPrefs); + if l4D then begin + case lProcess of + 0: ChangeNIfTISubformat(lFilename,lHdr,lPrefs); + 1: Reorder4D(lFilename, lHdr, lByteSwap,lPrefs); + 2: Clip4D(lFilename, lHdr, false,lPrefs,NiftiForm.StartEdit.value, NiftiForm.EndEdit.value); + 3: Float32NIfTI(lFilename, lPrefs); + 4: FormulaNIfTI(lFilename,lPrefs, NiftiForm.ScaleEdit.value, NiftiForm.PowerEdit.value); + 5: ASL_subtract(lFilename,false,{subtract} (NiftiForm.AsLCombo.itemIndex ),lPrefs); + 6: CropNIfTIX(lFilename, lPrefs, NiftiForm.EndEdit.value, NiftiForm.StartEdit.value, 0,0,0,0 ); + + else showmessage('Unknown function'); + end; //case combo + end else begin //if 4d else 3d + //Int16LogPtoZNIfTI32Z(lFilename, lPrefs); + case lProcess of + 0: ChangeNIfTISubformat(lFilename,lHdr,lPrefs); + 1: Reorient(lFilename,lHdr, lPrefs,false,false); + 2: begin + lOutname := Reorient(lFilename,lHdr, lPrefs,false,false); + if lOutname <> '' then + CropNIfTI(lOutname,lPrefs); + end;//2 + 3: CropNIfTIX(lFilename, lPrefs, NiftiForm.EndEdit.value, NiftiForm.StartEdit.value, 0,0,0,0 ); + 4: SiemensPhase2RadiansNIfTI(lFilename, lPrefs); + else showmessage('Unknown function'); + + end; //case 3d + end; //if 4d else 3d end + end; //for each image +end; + +procedure PromptOutput (var lPrefs: TPrefs); +begin + if (lPrefs.OutDirMode = kOutDirModePrompt) then + lPrefs.OutDir := GetDirPrompt(lPrefs.OutDir); + //GetDirPrompt(lPrefs.OutDir); +end; + +function TMainForm.ConvertDCM2NII (lFilename: string; var lPrefs: TPrefs): boolean; +//returns true if files treated as DICOM or PAR/REC - these will search entire folder +var + lOutDir,lExt: String; + lStartTime: DWord; + lStrings : TStrings; +begin + {$IFDEF FPC} + DefaultFormatSettings.DecimalSeparator := '.'; + {$ELSE} + DecimalSeparator := '.'; + {$ENDIF} + result := false; + if (not Fileexists(lFilename)) and (not DirExists(lFilename)) then + exit; + PromptOutput ( lPrefs); + result := true; + //3/2011... do not clear here, so we can look across images... Memo1.lines.clear; + MsgX(kVers); + refresh; + Memo1.lines.add('Converting '+lFilename); + lOutDir := extractfiledir(lFilename); + lStartTime := GetTickCount; + if DirExists(lFilename) then begin + RecursiveFolderSearch(lFilename,lFilename,lPrefs,0); + lPrefs.NameAppend := ''; + end else begin + lExt := UpCaseExt(lFilename); + {if (lExt = '.FDF') then + ConvertSimple2NII(lFilename,lOutDir,lPrefs) + else} + if (lExt = '.REC') or (lExt = '.PAR') then begin + LoadFileListPARREC(lFilename,lOutDir,lPrefs) + end else if (lExt = '.TGZ') then + DeTGZ(lFilename,lPrefs) + else if (IsNiftiExt (lFilename)) or (IsVOIExt (lFilename)) then begin + result := false; + lStrings := TStringList.Create; + lStrings.add(lFilename); + ProcessNIfTI(lStrings,lPrefs); + lStrings.Free; + end else begin + if (DirExists(lOutDir)) and (not lPrefs.Verbose) then + RecursiveFolderSearch(lOutDir,lOutDir,lPrefs,0) + else + LoadFileList(lFilename,lOutDir,lPrefs); + lPrefs.NameAppend := ''; + end; + end; + Memo1.lines.add('Conversion completed in '+inttostr(GetTickCount-lStartTime)+' ms'); +end; + +function ShowHeader (lFilename: string): boolean; +var + lPrefs: TPrefs; +begin + PrefsForm.ReadPrefs(lPrefs); + lPrefs.verbose := true; + MainForm.Memo1.lines.add('Location '+lFilename); + result := MainForm.ConvertDCM2NII( lFilename,lPrefs); + +end; + +procedure ProcessFilenames(lFilenames : TStrings; lPrefs: TPrefs); +var + i: integer; + lAllNII: boolean; +begin + if lFilenames.Count < 1 then exit; + MainForm.Memo1.lines.clear; + lAllNii := true; + for i := 0 to (lFilenames.Count-1) do + if (not (IsNiftiExt (lFilenames.Strings[i]))) and (not (IsVOIExt (lFilenames.Strings[i]))) then + lAllNii := false; + if lAllNii then begin + ProcessNiFTI (lFilenames,lPrefs); + exit; + end; + if ssCtrl in KeyDataToShiftState(vk_Shift) then begin + for i := 0 to (lFilenames.Count-1) do + ShowHeader (lFilenames.Strings[i]) + end else + MainForm.ConvertDCM2NII( lFilenames.Strings[0],lPrefs); +end; + +{$IFNDEF FPC}//if delphi + +procedure TMainForm.WMDropFiles(var Msg: TWMDropFiles); +var + CFileName: array[0..MAX_PATH] of Char; + + lInc: integer; + lPrefs: TPrefs; + lStrings: TStrings; +begin + CheckPrefs(lPrefs,False); + //lDone := false; + lInc := 0; + try + lStrings := TStringList.Create; + while (DragQueryFile(Msg.Drop, lInc, CFileName, MAX_PATH) > 0) {and (not lDone)} do begin + lStrings.add(CFilename); + + Msg.Result := 0; + inc(lInc); + end; //while + ProcessFilenames(lStrings,lPrefs); + lStrings.Free; + finally + DragFinish(Msg.Drop); + end; +end; + +function TMainForm.BrowseDialog(const Title: string): string; +var + iFlag: integer; + lpItemID : PItemIDList; + BrowseInfo : TBrowseInfo; + DisplayName : array[0..MAX_PATH] of char; + TempPath : array[0..MAX_PATH] of char; +begin + iFlag := BIF_RETURNONLYFSDIRS; + //iFlag := BIF_BROWSEINCLUDEFILES; + //iFlag := BIF_BROWSEFORCOMPUTER; + //iFlag := BIF_BROWSEFORPRINTER; + Result:=''; + FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); + with BrowseInfo do begin + hwndOwner := Application.Handle; + pszDisplayName := @DisplayName; + lpszTitle := PChar(Title); + ulFlags := iFlag; + end; + lpItemID := SHBrowseForFolder(BrowseInfo); + if lpItemId <> nil then begin + SHGetPathFromIDList(lpItemID, TempPath); + Result := TempPath; + GlobalFreePtr(lpItemID); + end; +end; +{$ELSE} +function TMainForm.BrowseDialog(const Title: string): string; +begin + result := ''; + SelectDirectoryDialog1.title := Title; + if not SelectDirectoryDialog1.execute then exit; + result := SelectDirectoryDialog1.Filename; +end; +{$ENDIF} +procedure TMainForm.dcm2niiBtnClick(Sender: TObject); +var + sTitle,lDirName: string; + lPrefs: TPrefs; +begin + CheckPrefs(lPrefs,False); +// {$IFNDEF UNIX} + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + showmessage('Nice'); +// {$ELSE} +// if not OpenDialogExecute('Select DICOM images you wish to convert)',true,false,kAnyFilter) then +// exit; +// lDirName := extractfiledir( OpenHdrDlg.Filename); +// {$ENDIF} + ConvertDCM2NII(lDirName,lPrefs); +end; + + + +procedure TMainForm.CheckPrefs (var lPrefs: TPrefs; lWrite: boolean); +begin + if lWrite then begin + //showmessage('w'); + //options if writing + TypeCombo.ItemIndex := DefaultOutputFormat (lPrefs); + + (* if lPrefs.SPM2 then + TypeCombo.ItemIndex := 0 //SPM2 3D hdr/img analyze + else if not lPrefs.FourD then begin + if not (lPrefs.SingleNIIFile) then + TypeCombo.ItemIndex := 1 //SPM5 3D hdr/img + else + TypeCombo.ItemIndex := 2; //SPM8 3D nii + end else if not lPrefs.SingleNIIFile then + TypeCombo.ItemIndex := 3 //?? 4D hdr/img + else if not lPrefs.GZip then + TypeCombo.ItemIndex := 4 //FSL 4D nii + else + TypeCombo.ItemIndex := 5; //FSL 4D nii.gz *) + exit; + end; + SetDefaultPrefs (lPrefs); + PrefsForm.ReadPrefs(lPrefs); + SetOutputFormat(TypeCombo.ItemIndex,lPrefs); + lPrefs.AnonymizeSourceDICOM := false; +end; + +(*procedure Fz; +var + lPrefs: TPrefs; + lByteSwap: boolean; + lExt,lFilename,lOutname,lNameWOExt: string; + lHdr: TNIFTIhdr; +begin + lFilename := 'C:\dti64\rapid\fz3.nii'; + lFilename := 'C:\t1\mx.nii'; + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lByteSwap) then begin + MsgX('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + MainForm.CheckPrefs(lPrefs,False); + Reorient(lFilename, lHdr,lPrefs,false); +end; *) + +(*procedure Fz; +var + lPrefs: TPrefs; + lF: string; +begin + lF := 'C:\iceland\temp'; + SetDefaultPrefs (lPrefs); + lPrefs.AnonymizeSourceDICOM := true; + MainForm.ConvertDCM2NII(lF,lPrefs); +end;*) + +procedure TMainForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + Exit1.visible := false; + {$ENDIF} + {$IFNDEF UNIX}DragAcceptFiles(Handle, True);{$ENDIF} + {$IFDEF FPC} + DefaultFormatSettings.DecimalSeparator := '.'; + {$ELSE} + DecimalSeparator := '.'; + {$ENDIF} + Application.HintHidePause := 30000; + {$IFDEF Darwin} + AppleMenu.Visible := true; + {$IFNDEF LCLgtk} //for Carbon and Cocoa + DICOMtoNIfTI1.ShortCut := ShortCut(Word('D'), [ssMeta]); + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Preferences1.ShortCut := ShortCut(Word('P'), [ssMeta]); + About1.ShortCut := ShortCut(Word('A'), [ssMeta]); + {$ENDIF}//Carbon + {$ENDIF}//Darwin +end; + + + +procedure TMainForm.Exit1Click(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.Copy1Click(Sender: TObject); +begin + Memo1.SelectAll; + Memo1.CopyToClipboard; +end; + +(*procedure testpermissions; +var + p,n,x,s: string; + +begin + s:= '/usr/lib64/lazarus/cr/'; + inputquery('cap','name',s); + FilenameParts (s,p,n,x); + if DirWritePermission(p) then + showmessage('+'+p+'*'+n+'*'+x) + else + showmessage('-'+p+'*'+n+'*'+x); +end; *) + +(*procedure testpermissions; +var + p,n,x,s: string; + +begin + s:= '/usr/lib64/lazarus/test/dcm2niigui.ini'; + if fpAccess (s,R_OK)=0 then //ensure user has read-access to prefs file... + showmessage('dcm = 0'); + s:= '/usr/lib64/lazarus/test/dcx.ini'; + if fpAccess (s,R_OK)=0 then //ensure user has read-access to prefs file... + showmessage('dcx = 0'); + +end; *) +(*procedure Force32; +var + lPrefs: TPrefs; + lI: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + for lI := 1 to 6 do + NII_force32 ('C:\walker\vois\i'+inttostr(lI)+'.nii','C:\walker\vois\ri'+inttostr(lI)+'.nii',lPrefs); +end;*) + +(*procedure Force32; +var + lPrefs: TPrefs; +begin + PrefsForm.ReadPrefs(lPrefs); + Rescale_4Dtissuemaps ('C:\walker\vois\4Dsri1.nii','C:\walker\vois\TPMQ.nii',lPrefs); +end;*) + +(*procedure Force32; +var + lPrefs: TPrefs; +const + kDir = 'C:\walker\i3\'; + kTemp = kDir + 'TPM3.nii'; + kTempSym = kDir + 'TPM3sym.nii'; +begin +//exit; + PrefsForm.ReadPrefs(lPrefs); + //scale_4Dtissuemaps ('C:\walker\vois\4Dsri1.nii','C:\walker\TPMLo.nii',lPrefs); + //rge4DFiles ('C:\walker\TPMLo.nii','C:\walker\TPMHi.nii','C:\walker\TPMEX.nii',78,lPrefs); + Insert3Din4D (kDir+'m1.nii.gz',kTemp,kTemp,1, lPrefs); + Insert3Din4D (kDir+'m2.nii.gz',kTemp,kTemp,2, lPrefs); + Insert3Din4D (kDir+'m3.nii.gz',kTemp,kTemp,3, lPrefs); + Insert3Din4D (kDir+'m4.nii.gz',kTemp,kTemp,4, lPrefs); + Insert3Din4D (kDir+'m5.nii.gz',kTemp,kTemp,5, lPrefs); + Insert3Din4D (kDir+'m6.nii.gz',kTemp,kTemp,6, lPrefs); + Rescale_4Dtissuemaps(kTemp,kTempSym,lPrefs,true); +end; *) + +(*procedure Force32; +var + lPrefs: TPrefs; +const + kDir = 'C:\walker\i4\'; + kTemp = kDir + 'TPM4.nii'; + kTempSym = kDir + 'TPM4sym.nii'; +begin +//exit; + PrefsForm.ReadPrefs(lPrefs); + //scale_4Dtissuemaps ('C:\walker\vois\4Dsri1.nii','C:\walker\TPMLo.nii',lPrefs); + //rge4DFiles ('C:\walker\TPMLo.nii','C:\walker\TPMHi.nii','C:\walker\TPMEX.nii',78,lPrefs); + Insert3Din4D (kDir+'sm1.nii',kTemp,kTemp,1, lPrefs); + Insert3Din4D (kDir+'sm2.nii',kTemp,kTemp,2, lPrefs); + Insert3Din4D (kDir+'sm3.nii',kTemp,kTemp,3, lPrefs); + Insert3Din4D (kDir+'sm4.nii',kTemp,kTemp,4, lPrefs); + Insert3Din4D (kDir+'sm5.nii',kTemp,kTemp,5, lPrefs); + Insert3Din4D (kDir+'sm6.nii',kTemp,kTemp,6, lPrefs); + Rescale_4Dtissuemaps(kTemp,kTempSym,lPrefs,true); +end; *) +(*procedure Force32; +var + lPrefs: TPrefs; + lMaskName: string; + lHdr: TNIfTIHdr; + lByteSwap, lSaveThresh3D: boolean; + lV: integer; +begin +//exit; + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select the mask image',false,false,kImgFilter) then + exit; + lMaskName := MainForm.OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr (lMaskName, lHdr, lByteSwap) then + exit; + if (lHdr.Dim[4] < 1) then + exit; + lSaveThresh3D := (MessageDlg('Save thresholded images for each individual?',mtCustom,[mbYes,mbNo], 0)=mrYes); + + for lV := 1 to lHdr.Dim[4] do + if MainForm.OpenDialogExecute('Select NIfTI images you wish to mask with volume '+inttostr(lV),true,false,kImgFilter) then + MaskImages(lMaskName, MainForm.OpenHdrDlg.Files,lPrefs,lV, lSaveThresh3D); +end; *) + +(*procedure Force32; +var + lPrefs: TPrefs; + lI: integer; + //lMaskName: string; +begin +//exit; + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select all the c1 (gray matter) images to binarize. The c2 (gray matter),c3,c4,c5,c6 images should be in th same folder.',true,false,kImgFilter) then + exit; + //lMaskName := ('C:\Documents and Settings\chris\Desktop\walkerseg\zero\wc120100128_102305t1saghiress002a1001.nii'); + //Binarize(lMaskName,lPrefs); + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + Binarize(MainForm.OpenHdrDlg.Files[lI],lPrefs); +end; *) + +{$IFNDEF FPC} +procedure MaskVBM; +var + lPrefs: TPrefs; + lI: integer; + lMaskName: string; +begin + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select all TEMPLATE c1 (gray matter) image.',false,false,kImgFilter) then + exit; + lMaskName := MainForm.OpenHdrDlg.Filename; + if not MainForm.OpenDialogExecute('Select all the c1 (gray matter) images to binarize. The c2 (gray matter),c3,c4,c5,c6 images should be in th same folder.',true,false,kImgFilter) then + exit; + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + MaskImgs(lMaskName, MainForm.OpenHdrDlg.Files[lI],lPrefs, 0.02); +end; +{$ENDIF} +{$IFNDEF FPC} +procedure Mask; +var + lPrefs: TPrefs; + lMaskName: string; + lHdr: TNIfTIHdr; + lO: TNIIOpts; + lI,lV: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select the mask image',false,false,kImgFilter) then + exit; + lMaskName := MainForm.OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr (lMaskName, lHdr, lO) then + exit; + lV := 1; + //lSaveThresh3D := (MessageDlg('Save thresholded images for each individual?',mtCustom,[mbYes,mbNo], 0)=mrYes); + //for lV := 1 to lHdr.Dim[4] do + if not MainForm.OpenDialogExecute('Select NIfTI images you wish to mask with volume '+inttostr(lV),true,false,kImgFilter) then + exit; + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + MaskImg(lMaskName, MainForm.OpenHdrDlg.Files[lI], lPrefs, 1); +end; +{$ENDIF} + + +function ExtNIIorIMG(lStr: string): boolean; +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.NII') or (lExt = '.NII.GZ') then + result := true; + if (lExt = '.IMG') {and (FSize(ChangeFileExt(lStr,'.hdr'))> 0)} then + result := true; +end; + +procedure NIIbatch (lDir,lS: string); +begin + with mainform.Memo1.lines do begin + add('subjx = strvcat'+lS+';'); + add('subj = cellstr(subjx);'); + add('dir = '''+lDir+''';'); + add('tic'); + add('for i=1:length(subj)'); + add(' filename = [dir,filesep,subj{i}];'); + add(' nii_16bit(filename);'); + add('end;'); + add('toc'); + end;//with +end;//proc NIIbatch +procedure NII2Mat; +var + str,pre,sTitle,lDirName: string; + lSearchRec: TSearchRec; +begin + {$IFNDEF FPC} + sTitle:='Choose a folder with DICOM images'; + lDirName := MainForm.BrowseDialog(sTitle); + {$ELSE} + if not MainForm.OpenDialogExecute('Select DICOM images you wish to inspect)',true,false,kAnyFilter) then + exit; + lDirName := extractfiledir( MainForm.OpenHdrDlg.Filename); + {$ENDIF} + str := '('; + pre := ''; + +{$IFDEF UNIX} + if FindFirst(lDirName+pathdelim+'*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lDirName+pathdelim+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + //lFilename := ''; + repeat + //lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name = '.') or (lSearchRec.Name = '..') then begin + // + end else if (lSearchRec.Name <> '') and (ExtNIIorIMG(lSearchRec.Name)) and (not DirExists(lSearchRec.Name)) then begin + str := str +pre+ ''''+extractfilename(lSearchRec.Name)+''''; + pre:=',' + end; + //mainform.Memo1.lines.add(lSearchRec.Name); + until (FindNext(lSearchRec) <> 0); + + end; + FindClose(lSearchRec); + str := str + ')'; + if length(str) > 2 then + NIIbatch (lDirName,str)//mainform.Memo1.lines.add(str) + else + mainform.Memo1.lines.add('No NIfTI images found in '+lDirName) + +end; + +(*procedure NII2Mat(lExt: string); +var + str,pre,sTitle,lDirName: string; + lSearchRec: TSearchRec; +begin + {$IFNDEF FPC} + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + {$ELSE} + if not OpenDialogExecute('Select DICOM images you wish to inspect)',true,false,kAnyFilter) then + exit; + lDirName := extractfiledir( OpenHdrDlg.Filename); + {$ENDIF} + str := '('; + pre := ''; + +{$IFDEF UNIX} + if FindFirst(lDirName+pathdelim+'*.img',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lDirName+pathdelim+'*.img',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + //lFilename := ''; + repeat + //lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name = '.') or (lSearchRec.Name = '..') then begin + // + end else if (lSearchRec.Name <> '') and (not DirExists(lSearchRec.Name)) then begin + str := str +pre+ ''''+extractfilename(lSearchRec.Name)+''''; + pre:=',' + end; + //mainform.Memo1.lines.add(lSearchRec.Name); + until (FindNext(lSearchRec) <> 0); + + end; + FindClose(lSearchRec); + str := str + ')'; + mainform.Memo1.lines.add(str); +end; *) + + +(*procedure BenchMarkDicom; +var + lC: Integer; + lS: TDateTime; + var lDICOMdata: DICOMdata; + lHdrOK, lImageFormatOK: boolean; + lDynStr: string;var lFileName: string; + var lPrefs: TPrefs ; +begin + SetDefaultPrefs (lPrefs); +lS := Now; +lFilename := '/Users/rorden/philips/T1_IM_0007'; +for lC := 1 to 100 do + read_dicom_data(true,false,false,false,false,false,false, lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName, lPrefs); +Showmessage('Milliseconds elapsed '+ FormatDateTime('z', Now-lS) ); +end; *) + +procedure TMainForm.About1Click(Sender: TObject); +//var value: int64; +begin +//fx(VBversion('MR B13 4VB13A')); exit; +//NII2Mat;exit; + //BenchMarkDicom; +{$IFNDEF FPC} + if (ssCtrl in KeyDataToShiftState(vk_Shift)) then begin + Mask; + exit; + end; + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + MaskVBM; + exit; + end; +{$ENDIF} + //force32; + //showmessage(ExtractFileDirWithPathDelim('c:\pas')); + + //testpermissions; + Showmessage(kVers+ kCR+'Fallback ini file: '+ changefileext(paramstr(0),'.ini')); +end; + +procedure TMainForm.Preferences1Click(Sender: TObject); +var + lPrefs: TPrefs; +begin + PrefsForm.ReadPrefs(lPrefs); + PrefsForm.Showmodal; + if (PrefsForm.ModalResult = mrCancel) then + PrefsForm.WritePrefs(lPrefs); +end; + +(*procedure ShowDICOM (var lPrefs: TPrefs); +var +lDICOMdata: DICOMdata; +lHdrOK,lImgOK: boolean; +lDynStr,lFilename: string; + +begin + lFilename := 'c:\i185386.MRDC.94'; + read_dicom_data(true,true{not verbose},true,true,true,true,false, lDICOMdata, lHdrOK, lImgOK, lDynStr,lFileName,lPrefs ); + msgX(lDynStr); +end;*) +procedure TMainForm.FormShow(Sender: TObject); +var + lPrefs: TPrefs; + lIniName: string; +begin + MsgX(kVers); + + SetDefaultPrefs(lPrefs); + lIniName := IniName;//changefileext(paramstr(0),'.ini'); + //showmessage(changefileext(paramstr(0),'.ini')); + (*lReadPrefs := true; + if (ssShift in KeyDataToShiftState(vk_Shift)) then + case MessageDlg('Shift key down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrYes: lReadPrefs := false; + end; //case *) + if not ResetDefaults {lReadPrefs} then begin + {$IFNDEF UNIX} + if (ParamCount > 0) then + ProcessParamStrs + else if fileexists (lIniName) then + IniFile(True,lIniName, lPrefs) + else + IniFile(True,changefileext(paramstr(0),'.ini'), lPrefs); //this allows an administrator to create default startup + //IniFile(True,lIniName, lPrefs); + {$ELSE} + if fileexists (lIniName) then + IniFile(True,lIniName, lPrefs) + else + IniFile(True,changefileext(paramstr(0),'.ini'), lPrefs); //this allows an administrator to create default startup + {$ENDIF} + end; //lReadPrefs + CheckPrefs(lPrefs,True); + PrefsForm.WritePrefs(lPrefs); + NIfTIForm.TypeCombo.ItemIndex := TypeCombo.ItemIndex; + UntestedMenu.visible := lPrefs.UntestedFeatures; + //ConvertDCM2NII('c:\b17\b17\b17.IMA',lPrefs); +end; + + + +procedure TMainForm.TypeComboChange(Sender: TObject); +begin + NIfTIForm.TypeCombo.ItemIndex := TypeCombo.ItemIndex; +end; + +procedure TMainForm.AnonymizeDICOM1Click(Sender: TObject); +var + sTitle,lDirName: string; + lPrefs: TPrefs; +begin + CheckPrefs(lPrefs,False); + lPrefs.AnonymizeSourceDICOM := true; + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + ConvertDCM2NII(lDirName,lPrefs); +end; + +function TMainForm.OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; +var + lNumberofFiles: integer; +begin + OpenHdrDlg.Filter := lFilter;//kAnaHdrFilter;//lFilter; + OpenHdrDlg.FilterIndex := 1; + OpenHdrDlg.Title := lCaption; + if lAllowMultiSelect then + OpenHdrDlg.Options := [ofAllowMultiSelect,ofFileMustExist] + else + OpenHdrDlg.Options := [ofFileMustExist]; + result := OpenHdrDlg.Execute; + if not result then exit; + if lForceMultiSelect then begin + lNumberofFiles:= OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + result := false; + end; + end; +end; + +procedure TMainForm.SavePrefs; +var + lPrefs: TPrefs; + lIniName: string; +begin + lIniName := IniName;//changefileext(paramstr(0),'.ini'); + CheckPrefs(lPrefs,False); + if lPrefs.WritePrefsOnQuit then + IniFile(False,lIniName, lPrefs); +end; + +procedure TMainForm.FormClose(Sender: TObject; var vAction: TCloseAction); +begin + SavePrefs; +end; + + +procedure TMainForm.FormDropFiles(Sender: TObject; + const FileNames: array of String); +var + lI,lN: integer; + lPrefs: TPrefs; + lStrings: TStrings;//lFilename: string; +begin + //lDone := false; + CheckPrefs(lPrefs,False); + lN := length(FileNames); + if lN < 1 then + exit; + lStrings := TStringList.Create; + for lI := 0 to (lN-1) do + lStrings.add(Filenames[lI]); + ProcessFilenames(lStrings,lPrefs); + lStrings.Free; + +end; + +procedure TMainForm.HalveMenu1Click(Sender: TObject); +var + lPrefs: TPrefs; + lI: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select image(s) you wish to LR flip',true,false,kImgFilter) then + exit; + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + ShrinkNII(MainForm.OpenHdrDlg.Files[lI], lPrefs); +end; + +procedure TMainForm.ModifyNIfTI1Click(Sender: TObject); +var + lPrefs: TPrefs; +begin + if not OpenDialogExecute('Select NIfTI images you wish to modify)',true,false,kImgFilter) then + exit; + CheckPrefs(lPrefs,False); + ProcessNIfTI(OpenHdrDlg.Files,lPrefs); +end; //ModifyNIfTI1Click + +procedure TMainForm.NIfTI3D4D1Click(Sender: TObject); +var lStrings: TStringList; + lPrefs: TPrefs; +begin + if not OpenDialogExecute('Select the 3D NIfTI images you wish to stack)',true,false,kImgFilter) then + exit; + lStrings := TStringList.Create; + lStrings.addstrings(OpenHdrDlg.Files); + CheckPrefs(lPrefs,False); + Stack3Dto4D(lStrings, False, lPrefs); + lStrings.Free; +end; + +procedure TMainForm.ResliceNIfTI1Click(Sender: TObject); +var + lDestName,lSourceName,lTargetName: string; + lPos: integer; + lPrefs: TPrefs; +begin + CheckPrefs(lPrefs,False); + Memo1.lines.clear; + refresh; + MsgX(kVers); + MsgX('This function reslices source images to match the dimensions of a target image.'); + MsgX(' Images are assumed to be coregistered.'); + MsgX(' The resulting images will have the orientation, voxel size and bounding box of the target image.'); + MsgX(' Resliced images will be given the prefix ''r''.'); + MsgX(' This function uses trilinear interpolation - there may be some loss of precision.'); + if not OpenDialogExecute('Select target image',true,false,kImgFilter) then + exit; + lTargetName := OpenHdrDlg.Filename; + if not OpenDialogExecute('Select images you wish to reslice to match target)',true,false,kImgFilter) then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lSourceName := OpenHdrDlg.Files[lPos-1]; + lDestName := ChangeFilePrefix (lSourceName,'r'); + MsgX('Reslicing '+lSourceName +' to match dimensions of '+lTargetname+' resliced image = '+lDestName); + Reslice2Targ (lSourceName,lTargetName,lDestName, lPrefs ); + + end; + +end; + + +procedure DelRecursiveFolderSearch (lFolderName: string; lMaxDepth, lDepth: integer); +var + lNewDir,lNewName,lFilename,lExt: String; + lSearchRec: TSearchRec; +begin + lNewDir := lFolderName+PathDelim; +{$IFDEF UNIX} + if FindFirst(lNewDir+'*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + lFilename := ''; + repeat + lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then begin + if DirExists(lNewName) then begin + if lDepth < lMaxDepth then begin + DelRecursiveFolderSearch(lNewName,lMaxDepth,lDepth+1); + end; + //exit;//4/4/2008 + end else + lFilename := lNewname; + end; + if (lFilename <> '') and (not DirExists(lNewName)) then begin + lExt := UpCaseExt(lFilename); + if (lExt <> '.DCM') then begin + msgx('del '+lFilename); + DeleteFile(lFilename); + end; + end; + until (FindNext(lSearchRec) <> 0); + + end; + FindClose(lSearchRec); +end; + + +procedure TMainForm.Deletenondcm1Click(Sender: TObject); +var + sTitle,lDirName: string; +begin + Showmessage('Warning: this command will delete all files that do not have the extension .dcm') ; + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + DelRecursiveFolderSearch(lDirName,32,1); +end; + +procedure TMainForm.MirrorXdimension1Click(Sender: TObject); +//UntestedFeatures +var + lPrefs: TPrefs; + lI: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select image(s) you wish to LR flip',true,false,kImgFilter) then + exit; + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + LRFlip(MainForm.OpenHdrDlg.Files[lI], lPrefs); +end; + +procedure TMainForm.SumTPM1Click(Sender: TObject); +var + lPrefs: TPrefs; + lI: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + if not OpenDialogExecute('Select TPM to sum)',true,false,kAnyFilter) then + exit; + for lI := 1 to 5 do + SumTPM(OpenHdrDlg.Filename,ChangeFilePrefix (OpenHdrDlg.Filename,'sum'+inttostr(lI)) ,lPrefs,lI); +end; + + +procedure TMainForm.ExtractDICOMdims1Click(Sender: TObject); +var + {$IFNDEF FPC}sTitle,{$ENDIF} + lDirName: string; + lPrefs: TPrefs; +begin + CheckPrefs(lPrefs,False); + lPrefs.DebugMode2 := true; + {$IFNDEF FPC} + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + {$ELSE} + if not OpenDialogExecute('Select DICOM images you wish to inspect)',true,false,kAnyFilter) then + exit; + lDirName := extractfiledir( OpenHdrDlg.Filename); + {$ENDIF} + Memo1.lines.Clear; + ConvertDCM2NII(lDirName,lPrefs); +end; + +procedure TMainForm.ExtractDICOMhdr1Click(Sender: TObject); +var + lnVol,lVol: integer; + //lHdrName: string; +begin + if not OpenDialogExecute('Select the 3D NIfTI images to inspect)',true,false,kAnyFilter) then + exit; + lnVol := OpenHdrDlg.Files.count; + Memo1.lines.clear; + for lVol := 1 to lnVol do + ShowHeader (OpenHdrDlg.Files[lVol-1]); +end; + +procedure TMainForm.ExtractNIfTIhdrs1Click(Sender: TObject); +var + lStrings: TStringList; +begin + if not OpenDialogExecute('Select the 3D NIfTI images to inspect)',true,false,kImgFilter) then + exit; + Memo1.lines.clear; + lStrings := TStringList.Create; + lStrings.addstrings(OpenHdrDlg.Files); + ExtractNIFTIHdrs(lStrings); + lStrings.Free; +end; + +{$IFDEF UNIX} +initialization + {$I gui.lrs} +{$ELSE} //not unix: windows +initialization +{$IFDEF FPC} + {$I gui.lrs} + {$ENDIF} + OleInitialize(nil); + +finalization + OleUninitialize +{$ENDIF} +end. + + diff --git a/dcm2nii/bvec.o b/dcm2nii/bvec.o new file mode 100644 index 0000000..c0be7a0 Binary files /dev/null and b/dcm2nii/bvec.o differ diff --git a/dcm2nii/bvec.pas b/dcm2nii/bvec.pas new file mode 100755 index 0000000..c71bffc --- /dev/null +++ b/dcm2nii/bvec.pas @@ -0,0 +1,79 @@ +unit bvec; +{$ifdef fpc}{$mode delphi}{$endif} +{$H+} +interface +uses + //StrUtils, + Classes, SysUtils, define_types, dicomtypes, dialogsx,GraphicsMathLibrary,dialogs_msg; +//{$DEFINE VERBOSE_BVEC} + + +procedure siemensPhilipsCorrectBvecs (var lDICOMdata:dicomdata; var lDTIra: TDTIra; nVec: integer; lSliceOrientMosaicNegativeDeterminant: boolean); + +implementation + +(*function VV (lLabel: string; var lV: TVector): string; +begin + result := lLabel +' =['+ floattostr(lV.x)+','+floattostr(lV.y)+','+ floattostr(lV.z)+']'';'; +end; + +procedure VTX (var bvecs_old,slice_dir,read_dir,phase_dir: TVector); +var lStr : string; +begin + lStr := ''; + lStr := lStr + VV('bvecs_old',bvecs_old); + lStr := lStr + VV('slice_dir',slice_dir); + lStr := lStr + VV('read_dir',read_dir); + lStr := lStr + VV('phase_dir',phase_dir); + dcmMsg(lStr); +end; *) + +procedure siemensPhilipsCorrectBvecs (var lDICOMdata:dicomdata; var lDTIra: TDTIra; nVec: integer; lSliceOrientMosaicNegativeDeterminant: boolean); + //see Matthew Robson's http://users.fmrib.ox.ac.uk/~robson/internal/Dicom2Nifti111.m + //convert DTI vectors from scanner coordinates to image frame of reference + //Uses 6 orient values from ImageOrientationPatient (0020,0037) + // requires PatientPosition 0018,5100 is HFS (head first supine) +var + lI: integer; + read_vector ,phase_vector,slice_vector,bvecs_old,bvecs_new: TVector; +begin + if nVec < 1 then exit; + if (length(lDicomData.PatientPos) >= 3) and (lDicomData.PatientPos[1] = 'H') and (lDicomData.PatientPos[2] = 'F') and (lDicomData.PatientPos[3] = 'S') then + else begin + dcmMsg('DTI vector error: Position is not head first supine'); + exit; + end; + read_vector := Vector3D(lDICOMData.Orient[1],lDICOMData.Orient[2],lDICOMData.Orient[3]); + phase_vector := Vector3D(lDICOMData.Orient[4],lDICOMData.Orient[5],lDICOMData.Orient[6]); + slice_vector := CrossProduct(read_vector ,phase_vector); + + NormalizeVector(read_vector); + NormalizeVector(phase_vector); + NormalizeVector(slice_vector); + for lI := 1 to nVec do begin + //afx('test',lDTIra[lI],lI); + if (lDTIra[lI].bval <= 0) or ((lDTIra[lI].v1 = 0) and (lDTIra[lI].v2 = 0) and (lDTIra[lI].v3 = 0)) then begin + lDTIra[lI].v1 := 0; + lDTIra[lI].v2 := 0; + lDTIra[lI].v3 := 0; + end else begin + bvecs_old := Vector3D(lDTIra[lI].v1,lDTIra[lI].v2,lDTIra[lI].v3); + //VTX (bvecs_old,slice_vector,read_vector,phase_vector ); + bvecs_new :=Vector3D(DotProduct(bvecs_old,read_vector),DotProduct(bvecs_old,phase_vector),DotProduct(bvecs_old,slice_vector) ); + bvecs_new.y := - bvecs_new.y; + NormalizeVector(bvecs_new); + lDTIra[lI].v1 := bvecs_new.x; + if lSliceOrientMosaicNegativeDeterminant then + lDTIra[lI].v2 := -bvecs_new.y + else + lDTIra[lI].v2 := bvecs_new.y; + lDTIra[lI].v3 := bvecs_new.z; + end; + end;//for each bvec + if lSliceOrientMosaicNegativeDeterminant then + dcmmsg('WARNING: please validate DTI vectors (matrix had a negative determinant, perhaps Siemens sagittal).'); + +end;//PhilipsSiemensCorrectBvecs + +end. + diff --git a/dcm2nii/bvec.ppu b/dcm2nii/bvec.ppu new file mode 100644 index 0000000..94627f5 Binary files /dev/null and b/dcm2nii/bvec.ppu differ diff --git a/dcm2nii/convert.o b/dcm2nii/convert.o new file mode 100644 index 0000000..510c031 Binary files /dev/null and b/dcm2nii/convert.o differ diff --git a/dcm2nii/convert.pas b/dcm2nii/convert.pas new file mode 100755 index 0000000..9d85b0a --- /dev/null +++ b/dcm2nii/convert.pas @@ -0,0 +1,1732 @@ +unit convert; +{$H+} +interface +uses +{$IFNDEF UNIX} +Windows, +{$ENDIF} +{$IFDEF FPC} +gzio2, +{$ELSE} + +{$ENDIF} +filename,define_types,classes,SysUtils,dicom,dicomtypes, nifti_types, +niftiutil,GraphicsMathLibrary, userdir,csaread,dialogs_msg, math, +nii_4dto3d,nii_orient,nii_crop,prefs,lsjpeg, bvec; +function Dicom2NII(var lDICOMra: TDICOMrap; var l4dDTIra: TDTIra; lFirstDICOM, lLastDICOM: integer; var lOutDirOrig: string; var lPrefs: TPrefs; lVols: integer): boolean; +implementation +uses +sortdicom,dialogsx; + +function getDeterminant(r: TMatrix): double; +var +r11,r12,r13,r21,r22,r23,r31,r32,r33: double; +begin + r11 := r.matrix[1,1];//[0][0]; + r12 := r.matrix[1,2];//r[0][1]; + r13 := r.matrix[1,3];//r[0][2]; + r21 := r.matrix[2,1];//[0][0]; + r22 := r.matrix[2,2];//r[0][1]; + r23 := r.matrix[2,3];//r[0][2]; + r31 := r.matrix[3,1];//[0][0]; + r32 := r.matrix[3,2];//r[0][1]; + r33 := r.matrix[3,3];//r[0][2]; + result := r11*r22*r33 - r11*r32*r23 - r21*r12*r33 + + r21*r32*r13 + r31*r12*r23 - r31*r22*r13; +end; + +function RealToStr(lR: double ; lDec: integer): string; +begin + RealTOStr := FloatToStrF(lR, ffFixed,7,lDec); +end; + +function UniqueFileName (var lInStr: string): boolean; +var + lInc: integer; + lPathWName,lExt: string; +begin + result := true; + if not Fileexists(lInStr) then exit; + ExtractFileParts(lInStr,lPathWName,lExt); + lInc := ord('A'); + while (lInc <= ord('Z')) and ( Fileexists(lPathWName+chr(lInc)+lExt)) do + inc(lInc); + if lInc > ord('Z') then + result := false + else + lInStr := lPathWName+chr(lInc)+lExt; +end; + +FUNCTION Diag2D (CONST m1,m2,m3: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m1; matrix[1,2] := 0; + matrix[1,3] := 0; + + matrix[2,1] := 0; matrix[2,2] := m2; + matrix[2,3] := 0; + + matrix[3,1] := 0; matrix[3,2] := 0; + matrix[3,3] := m3; + size := size2D + END + END {Diag2D}; +FUNCTION Diag3D (CONST m1,m2,m3,m4: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m1; matrix[1,2] := 0; + matrix[1,3] := 0; matrix[1,4] := 0; + + matrix[2,1] := 0; matrix[2,2] := m2; + matrix[2,3] := 0; matrix[2,4] := 0; + + matrix[3,1] := 0; matrix[3,2] := 0; + matrix[3,3] := m3; matrix[3,4] := 0; + + matrix[4,1] := 0; matrix[4,2] := 0; + matrix[4,3] := 0; matrix[4,4] := m4; + size := size3D + END +END {Diag3D}; + +(*procedure AdjMosaic (var Q: TMatrix; var lDicomData: DicomData); +//Changes suggested by Antonin Skoch" <ansk@medicon.cz<mailto:ansk@medicon.cz>> +// September 23, 2011 10:38:05 AM +var + lFactorX: double; + lFactorY: double; +begin + lFactorX := (lDicomData.XYZdim[1] -(lDicomData.XYZdim[1]/lDicomData.SiemensMosaicX) )/2; + lFactorY := (lDicomData.XYZdim[2] -(lDicomData.XYZdim[2]/lDicomData.SiemensMosaicY) )/2; + Q.matrix[1,4] :=(Q.matrix[1,1]*lFactorX)+(Q.matrix[1,2]*lFactorY)+Q.matrix[1,4]; + Q.matrix[2,4] :=(Q.matrix[2,1]*lFactorX)+(Q.matrix[2,2]*lFactorY)+Q.matrix[2,4]; + Q.matrix[3,4] :=(Q.matrix[3,1]*lFactorX)+(Q.matrix[3,2]*lFactorY)+Q.matrix[3,4]; +end; *) + + +(*procedure get_numaris4_val(lFilename,lTagName1,lTagName2: string; var lnmosaic: integer; var lv1,lv2,lv3:single); // spm_dicom_convert +label 121; +const + kMaxHdrSz = 24000; +var + lHdr : array [1..kMaxHdrSz] of Char; + lTagName,lStr: string; + lLoop,lFileSz,lFilePos,lTagLen,lSubLoop,lnSubloop: integer; + lFile: file; +function IsTag: boolean; +var + lTagPos: integer; +begin + result := false; + for lTagPos := 1 to lTagLen do + if lHdr[lFilePos+lTagPos-1] <> lTagName[lTagPos] then + exit; + result := true; +end; + +function IsNumber: boolean; +begin + if lHdr[lFilePos] in ['-','.','0'..'9'] then + result := true + else + result := false; +end; + +begin + lnmosaic := 0;//detect if function found header + if not fileexists(lFilename) then + exit; + + FileMode := 0; //set to readonly + AssignFile(lFile, lFileName); + Reset(lFile, 1); + lFileSz := FileSize(lFile); + if lFileSz > kMaxHdrSz then + lFileSz := kMaxHdrSz; + if lFilesz < (2000) then begin + //to small to be DICOM mosaic + CloseFile(lFile); + Filemode := 2; + exit; + end; + BlockRead(lFile, lHdr, lFileSz*SizeOf(Char)); + FileMode := 0; //set to readonly + CloseFile(lFile); + lFilePos := 1; +for lLoop := 1 to 2 do begin + if lLoop = 1 then begin + lnSubloop := 1; + lTagName := lTagName1; + end else begin + lnSubloop := 3; + lTagName := lTagName2; + end; + lTagLen := length (lTagName); + while (lFilePos < (lFileSz-lTagLen)) and (not (IsTag)) do + inc(lFilePos); + if (lFilePos >= (lFileSz-lTagLen)) then + exit; + lFilePos := lFilePos + 72; //lots of space between name and value +for lSubloop := 1 to lnSubloop do begin + while (lFilePos < (lFileSz)) and (not (IsNumber)) do + inc(lFilePos); + if (lFilePos >= (lFileSz-lTagLen)) then + exit; + lStr :='';// lHdr[lFilePos]; + while (lFilePos < (lFileSz)) and (IsNumber) do begin + lStr := lStr+lHdr[lFilePos]; + inc(lFilePos); + end; + if lStr = '' then + exit; + if lLoop = 1 then + lnmosaic := strtoint(lStr) + else begin + case lSubloop of + 1: lv1 := strtofloat(lStr); + 2: lv2 := strtofloat(lStr); + 3: lv3 := strtofloat(lStr); + end; //case + end; //else +end; //sublooop +end; //loop +end; *) + + + +function IsNormalMosaic(var lDicomData: DicomData; var lMosaicSlices: integer; var lFilename: string): boolean; +var + Q: TMatrix; + lX,lY,lnmos,lImagesPerRow: integer; + lv1,lv2,lv3: double; +begin + lX := lDICOMdata.SiemensMosaicX; + lY := lDICOMdata.SiemensMosaicY; + result := false; + lMosaicSlices := lDICOMdata.SiemensSlices; + if lMosaicSlices = 0 then + lMosaicSlices := lDICOMdata.SiemensMosaicX*lDICOMdata.SiemensMosaicY; + + if (lDICOMdata.SiemensMosaicX < 1) then + exit; //not mosaic + if (lDICOMdata.SiemensSlices > 0) then + exit; //pre-Trio Siemens Mosaic Data + if not GetCSAImageHeaderInfo (lFilename, lDicomData.CSAImageHeaderInfoPos ,lDicomData.CSAImageHeaderInfoSz, lnmos,lDicomData.SiemensMosaicX,lDicomData.SiemensMosaicY, lv1,lv2,lv3) then begin + lDICOMdata.SiemensMosaicX := lX; + lDICOMdata.SiemensMosaicY := lY; + lMosaicSlices := lX * lY; + exit; + end; + if lnmos < 1 then + exit; + //4/4/2008 I used to read AcquisitionMatrixText from CSA Image Header... however this is a problem if the images are interpolated + lImagesPerRow := 1; + while sqr(lImagesPerRow) < lnMos do + inc(lImagesPerRow); + lDICOMdata.SiemensMosaicX := lDicomData.XYZdim[1] div lImagesPerRow; + lDICOMdata.SiemensMosaicY := lDicomData.XYZdim[2] div lImagesPerRow; //29Sept2008 + //fx(lDicomData.XYZdim[1],lDicomData.XYZdim[2],lnmos,lDICOMdata.SiemensMosaicY); + lDicomData.SiemensMosaicX := lDicomData.XYZdim[1] div lDICOMdata.SiemensMosaicX; + lDicomData.SiemensMosaicY := lDicomData.XYZdim[2] div lDICOMdata.SiemensMosaicY; + //get_numaris4_val(lFilename,'NumberOfImagesInMosaic','SliceNormalVector',lnmos,lv1,lv2,lv3); + //b13 + Q := Matrix2D(lDicomData.Orient[1], lDicomData.Orient[4],lv1, + lDicomData.Orient[2],lDicomData.Orient[5],lv2, + lDicomData.Orient[3],lDicomData.Orient[6],lv3); + if nifti_mat33_determ(Q) < 0 then begin + + //dcmMsg('Note: raw slice order R>>L (Siemens convention), dcm2niiprior to 2014 stored these as L>>R, NIfTI convention). Benefit: simpler slice timing correction (ascending is 1..N, descending is N..1)'); + result := true; + end; + lMosaicSlices := lnmos; +end; + + +function IsSiemensDTI(var lDicomData: DicomData; var lDTI: TDTI;var lFilename: string; var lPrefs: TPrefs): boolean; +begin + result := false; + if (lDICOMdata.SiemensDICOMDTI) and (lDICOMdata.DTI.bval >= 0) and (lDicomData.Vers0018_1020 {ImplementationVersion} >= lPrefs.SiemensDTIUse0019If00181020atleast {IgnoreDTIRotationsIf_0002_0013_atleast}) then begin + lDTI.Bval := lDICOMdata.DTI.bval; + ldti.v1 := lDicomData.DTI.v1; + ldti.v2 := lDicomData.DTI.v2; + ldti.v3 := lDicomData.DTI.v3; + result := true; + exit; + end; + if (lDICOMdata.ManufacturerID <> kSiemensID) then + exit; + + if not GetCSAImageHeaderInfoDTI (lFilename, lDicomData.CSAImageHeaderInfoPos ,lDicomData.CSAImageHeaderInfoSz,lDTI.Bval,ldti.v1,ldti.v2,ldti.v3) then + //if not GetCSAImageHeaderInfoDTI (lFilename, lDicomData.CSAImageHeaderInfoPos ,lDicomData.CSAImageHeaderInfoSz, lDTI.Bval, ldti.v1,ldti.v2,ldti.v3) then + exit; + if lDTI.bval >= 0 then begin + result := true; + lDicomData.SiemensDICOMDTICSA := true; + end; + //fx(lDTI.bval); +end; + +(*procedure ReportMatrix(s: string; q: TMatrix); +begin + dcmmsg(s+Format('=[ %g %g %g %g; %g %g %g %g; %g %g %g %g; 0 0 0 1]', [ + q.matrix[1,1],q.matrix[1,2],q.matrix[1,3],q.matrix[1,4] , + q.matrix[2,1],q.matrix[2,2],q.matrix[2,3],q.matrix[2,4] , + q.matrix[3,1],q.matrix[3,2],q.matrix[3,3],q.matrix[3,4]])); +end; + +procedure ReportMat33(s: string; q: TMatrix); +begin + dcmmsg(s+Format('=[ %g %g %g; %g %g %g; %g %g %g]', [ + q.matrix[1,1],q.matrix[1,2],q.matrix[1,3] , + q.matrix[2,1],q.matrix[2,2],q.matrix[2,3] , + q.matrix[3,1],q.matrix[3,2],q.matrix[3,3]])); +end; *) + +procedure dicom_2_niftiMosaic(var Q44: TMatrix; var d: DicomData; var lHdr: TNiftiHdr ; lMosaicSlices: integer; var lFlipMosaic: boolean); +var + det: TMatrix; + nRowCol,lFactorX,lFactorY: double; + c,r: integer; + v,vO: TVector; +begin + nRowCol := ceil(sqrt(lMosaicSlices)); + lFactorX := (d.xyzDim[1] -(d.xyzDim[1]/nRowCol) )/2.0; + lFactorY := (d.xyzDim[2] -(d.xyzDim[2]/nRowCol) )/2.0; + Q44.matrix[1,4] :=(Q44.matrix[1,1]*lFactorX)+(Q44.matrix[1,2]*lFactorY)+Q44.matrix[1,4]; + Q44.matrix[2,4] :=(Q44.matrix[2,1]*lFactorX)+(Q44.matrix[2,2]*lFactorY)+Q44.matrix[2,4]; + Q44.matrix[3,4] :=(Q44.matrix[3,1]*lFactorX)+(Q44.matrix[3,2]*lFactorY)+Q44.matrix[3,4]; + Q44.size := size3D; + //ReportMatrix('mega',Q44); + for c:=1 to 2 do + for r := 1 to 4 do + Q44.matrix[c,r] := -Q44.matrix[c,r]; + + if lFlipMosaic then begin + det := Diag3D(1,1,-1,1); + Q44 := MultiplyMatrices(Q44,det); + end; + //next we have flipped images on the Y dimension + vO := Vector3D(0,lHdr.dim[2]-1,0); //find coordinate of new origin voxel - located on opposite side of Y-dimension + for r := 1 to 3 do begin + v.vector[r] := 0; + for c :=1 to 4 do + v.vector[r] := v.vector[r] + (Q44.matrix[r,c]*vO.vector[c]); + end; + det := Diag3D(1,-1,1,1); + Q44 := MultiplyMatrices(Q44,det); + Q44.matrix[1,4] := v.x; + Q44.matrix[2,4] := v.y; + Q44.matrix[3,4] := v.z; + + +end; + +procedure dicom_2_nifti(var lDicomData: DicomData; var lHdr: TNiftiHdr ; lMosaicSlices: integer; var lFlipMosaic: boolean); +var + Q,res,diagVox,patient_to_tal,analyze_to_dicom: TMatrix; + lx,ly: integer; + val: double; + dx,dy,dz: single; + lOK: boolean; +begin + lHdr.sform_code := kNIFTI_XFORM_UNKNOWN; + lOK := false; + for lx := 1 to 6 do + if lDicomData.Orient[lx] <> 0 then lOK := true; + if not lOK then exit; + Q := Diag3D(1,1,1,1);//set column 4 and row 4 to zeros, except [4,4] + Q.matrix[1,1] :=lDicomData.Orient[1] ; Q.matrix[1,2] := lDicomData.Orient[2] ; Q.matrix[1,3] := lDicomData.Orient[3] ; //* load Q */ + Q.matrix[2,1] := lDicomData.Orient[4] ; Q.matrix[2,2] := lDicomData.Orient[5] ; Q.matrix[2,3] := lDicomData.Orient[6] ; + //ReportMatrix('bar',Q); + // normalize row 1 + val := Q.matrix[1,1]*Q.matrix[1,1] + Q.matrix[1,2]*Q.matrix[1,2] + Q.matrix[1,3]*Q.matrix[1,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[1,1] := Q.matrix[1,1]* val ; Q.matrix[1,2] := Q.matrix[1,2]* val ; Q.matrix[1,3] := Q.matrix[1,3]* val ; + end else begin + Q.matrix[1,1] := 1.0 ; Q.matrix[1,2] := 0.0 ; Q.matrix[1,3] := 0.0 ; + end; + // normalize row 2 + val := Q.matrix[2,1]*Q.matrix[2,1] + Q.matrix[2,2]*Q.matrix[2,2] + Q.matrix[2,3]*Q.matrix[2,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[2,1] := Q.matrix[2,1]* val ; Q.matrix[2,2] := Q.matrix[2,2]* val ; Q.matrix[2,3] := Q.matrix[2,3]* val ; + end else begin + Q.matrix[2,1] := 0.0 ; Q.matrix[2,2] := 1.0 ; Q.matrix[2,3] := 0.0 ; + end; + //ReportMat33('norm',Q); + //row 3 is cross product of previous rows + Q.matrix[3,1] := Q.matrix[1,2]*Q.matrix[2,3] - Q.matrix[1,3]*Q.matrix[2,2] ; + Q.matrix[3,2] := Q.matrix[1,3]*Q.matrix[2,1] - Q.matrix[1,1]*Q.matrix[2,3] ; + Q.matrix[3,3] := Q.matrix[1,1]*Q.matrix[2,2] - Q.matrix[1,2]*Q.matrix[2,1] ; + res := Diag3D(1,1,1,1); //set forth column/row + //next: transpose matrix + for lx := 1 to 3 do + for ly := 1 to 3 do + res.matrix[lx,ly] := Q.matrix[ly,lx]; + Q := res; + //next if det(orient)<0, orient(:,3) = -orient(:,3); end; + //showmessage(realtostr(getDeterminant(Q),2)); + if getDeterminant(Q) < 0 then begin + Q.matrix[1,3] := -Q.matrix[1,3]; + Q.matrix[2,3] := -Q.matrix[2,3]; + Q.matrix[3,3] := -Q.matrix[3,3]; + end; + //reportMatrix('preScale',Q); + //next scale matrix + diagVox := Diag2D(lDicomData.XYZmm[1],lDicomData.XYZmm[2],lDicomData.XYZmm[3]); + Q.size := size2D; + Q := MultiplyMatrices(Q,diagVox); + //reportMatrix('postScale',Q); + //next - add translations + Q.matrix[1,4] := lDicomData.PatientPosX; + Q.matrix[2,4] := lDicomData.PatientPosY; + Q.matrix[3,4] := lDicomData.PatientPosZ; + //reportMatrix('postOffset',Q); + if (lDICOMdata.SiemensMosaicX > 1) or (lDICOMdata.SiemensMosaicY > 1) then begin + dicom_2_niftiMosaic(Q, lDicomData, lHdr, lMosaicSlices, lFlipMosaic); + + + end else begin + val := lDicomData.XYZdim[2]; + (*if (lDICOMdata.SiemensMosaicX > 1) or (lDICOMdata.SiemensMosaicY > 1) then begin + AdjMosaic(Q,lDICOMdata); + val := lDicomData.XYZdim[2]/lDICOMdata.SiemensMosaicY; + //lFlipMosaic := IsNormalMosaic(lDicomData,lMosaicSlices,lFilename); + end; *) + Q.matrix[4,1] := 0; + Q.matrix[4,2] := 0; + Q.matrix[4,3] := 0; + Q.matrix[4,4] := 1; + Q.size := size3D; + //Q now equals 'dicom_to_patient' in spm_dicom_convert + //result := q; exit; //escape to compare with SPM + //next - convert space + patient_to_tal := diag3D(-1, -1, 1,1); + analyze_to_dicom := Matrix3D ( + 1, 0, 0,-1, + 0,-1, 0, val, + 0, 0, 1,-1, + 0, 0, 0, 1); + //reportMatrix('d2pat',Q); + //reportmatrix('p2tal',patient_to_tal); + //reportMatrix('a2d',analyze_to_dicom); + Q := MultiplyMatrices(patient_to_tal,Q); + //reportMatrix('postTal',Q); + Q := MultiplyMatrices(Q,analyze_to_dicom); + //reportMatrix('mat',Q); + //Q now equals 'mat' in spm_dicom_convert + //subasgn.m in SPM5 translates by one voxel... + analyze_to_dicom := Matrix3D ( + 1, 0, 0,1, + 0,1, 0, 1, + 0, 0,1,1, + 0, 0, 0, 1); + Q := MultiplyMatrices(Q,analyze_to_dicom);//not used for flips + (*if ((lDICOMdata.SiemensMosaicX > 1) or (lDICOMdata.SiemensMosaicY > 1)) and (lFlipMosaic) then begin + + patient_to_tal := diag3D(1, 1, 1,1); + patient_to_tal.matrix[3,4] := 1-lMosaicSlices; + Q := MultiplyMatrices(Q,patient_to_tal); + end else if ((lDICOMdata.SiemensMosaicX > 1) or (lDICOMdata.SiemensMosaicY > 1)) and (getDeterminant(Q) < 0) then begin + //patient_to_tal := diag3D(1, 1, 1,1); + //patient_to_tal.matrix[3,4] := 1-lMosaicSlices; + patient_to_tal := diag3D(1, 1, -1,1); + Q := MultiplyMatrices(Q,patient_to_tal); + end; *) + end; //if mosaic else not mosaic + //if (lDICOMdata.SiemensMosaicX = 1) and (lDICOMdata.SiemensMosaicY = 1) then + //reportmatrix('final',Q); + //mat44_to_quatern(Q); *) + //reportMatrix('nii',Q); + lHdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT; + lHdr.srow_x[0] := Q.matrix[1,1]; + lHdr.srow_x[1] := Q.matrix[1,2]; + lHdr.srow_x[2] := Q.matrix[1,3]; + lHdr.srow_x[3] := Q.matrix[1,4]; + lHdr.srow_y[0] := Q.matrix[2,1]; + lHdr.srow_y[1] := Q.matrix[2,2]; + lHdr.srow_y[2] := Q.matrix[2,3]; + lHdr.srow_y[3] := Q.matrix[2,4]; + lHdr.srow_z[0] := Q.matrix[3,1]; + lHdr.srow_z[1] := Q.matrix[3,2]; + lHdr.srow_z[2] := Q.matrix[3,3]; + lHdr.srow_z[3] := Q.matrix[3,4]; + //finally, create Quat from matrix + lHdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; + nifti_mat44_to_quatern( Q, + lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + dx, dy, dz, lHdr.pixdim[0]{QFac}); + + //msgq(lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d,lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z); +end; + +(*function CountOrders(var lDICOMdata: dicomdata): integer; +//for 4D files, if you have 'M'agnitude and 'Phase' maps in order M M P P M P this will return 1 1 2 2 1 2 +const + kTypes = 10; +var + ltype,i: integer; + noveltype: array [1..kTypes] of boolean; +begin + result := 0; + for i := 1 to kTypes do + noveltype[i] := true; + for i := 1 to lDICOMdata.nOrder do begin + ltype := lDICOMdata.order[i]; + if (ltype < 1) or (lType > kTypes) then + lType := 1; + if (noveltype[ltype])then + inc(result); //we found a new order... + noveltype[ltype] := false; + end; +end;*) + +(*function SortOrders(var lDICOMdata: dicomdata; var lImageOrder: bytep): integer; +//for 4D files, if you have 'M'agnitude and 'Phase' maps in order M M P P M P this will return 1 1 2 2 1 2 +const + kTypes = 10; +var + ltype,i: integer; + noveltype: array [1..kTypes] of boolean; +begin + result := 0; + for i := 1 to kTypes do + noveltype[i] := true; + getmem(lImageOrder,lDICOMdata.nOrder); + for i := 1 to lDICOMdata.nOrder do begin + ltype := lDICOMdata.order[i]; + if (ltype < 1) or (lType > kTypes) then + lType := 1; + lImageOrder^[i] := lType; + if (noveltype[ltype])then + inc(result); //we found a new order... + noveltype[ltype] := false; + end; +end; + +function CountOrders(var lDICOMdata: dicomdata): integer; +var + lImageOrder: bytep; +begin + if (lDICOMdata.nOrder < 1) then + exit; + result := SortOrders(lDICOMdata,lImageOrder); + freemem(lImageOrder); +end; + +function ParseOrder(var lDICOMdataAllTypes,lDICOMdataSelectedType: dicomdata; lSelectedType: integer): integer; +var + lnTypes: integer; + lImageOrder: bytep; +begin + lDICOMdataSelectedType := lDICOMdataAllTypes; + if (lDICOMdataAllTypes.nOrder < 1) then + exit; + lnTypes := SortOrders(lDICOMdataAllTypes,lImageOrder); + if lnTypes <= lSelectedType then begin + TDTIRA = array [1..kMaxDTIDir] of TDTI;//TDICOM;//unsigned 8-bit int + TOrder= array [1..kMaxOrderVal] of byte; + + end; + freemem(lImageOrder); +end; *) + + +///321 +function MultiOrder(var lDICOMdata: dicomdata): integer; +//how many slices are of the same type [magnitude, phase, etc] +//returns 0 if all types are the same +var + i: integer; +begin + result := 0; + if (lDICOMdata.nOrder < 1) then + exit; + if (lDicomData.XYZdim[3] > kMaxOrderVal) then + exit; + result := 0; + for i := 1 to lDICOMdata.nOrder do begin + if lDICOMdata.order[i] = lDICOMdata.order[1] then + inc(result); //count how many have the same order as first... + end; + if result = lDICOMdata.nOrder then + result := 0; //all are like the first +end; + +function CompressMultiOrder(var lDICOMdata: dicomdata): integer; +//convert multiorder so values are 1..n, +//e.g. if the values were 2,3,4 it would be converted to 1..3 +//e.g. if the values are 3,4 it will be converted to 1..2 +var + min,max,i,j: integer; + SlotUsed: boolean; +begin + result := 1; + if (lDICOMdata.nOrder < 1) then + exit; + if (lDicomData.XYZdim[3] > kMaxOrderVal) then + exit; + min := lDICOMdata.order[1]; + for i := 1 to lDICOMdata.nOrder do + if lDICOMdata.order[i] < min then + min := lDICOMdata.order[i]; //count how many have the same order as first... + max := lDICOMdata.order[1]; + for i := 1 to lDICOMdata.nOrder do + if lDICOMdata.order[i] > max then + max := lDICOMdata.order[i]; //count how many have the same order as first... + result := 1; + for j := min to max do begin + SlotUsed := false; + for i := 1 to lDICOMdata.nOrder do begin + if lDICOMdata.order[i] = j then begin + SlotUsed := true; + lDICOMdata.order[i] := result; + end; + end;//for each value + if SLotUsed then + inc(result); + end; + result := result - 1; +end; + +(*procedure msx (a,b,c,d: integer); +begin + msg(inttostr(a)+'x'+inttostr(b)+'x'+inttostr(c)+'x'+inttostr(d)); +end;*) +procedure SwapTimeMultiOrder (var lDICOMdata: dicomdata; var lBuffer: bytep); +//data is stored X,Y,T,Z+some order effect (e.g. magnitude and phase stroed in the same 4D image) - swap to O,X,Y,Z,T +var + Order,nOrders,lSlicesPerOrder,lSlice,l4DBytes,lSliceBytes,lZo,lTo,lZmax,lTmax,lOrderVol:integer; + lTempBuffer: ByteP; +begin + lSlicesPerOrder := MultiOrder(lDICOMdata); + if (lSlicesPerOrder = 0) then + exit; + nOrders := CompressMultiOrder(lDICOMdata); + dcmMsg('Swizzling with multiple ComplexImageComponents: '+inttostr(lSlicesPerOrder)+' slices per order, total '+inttostr(lDicomData.XYZdim[3])+' slices'); + if not lDICOMdata.file4D then + exit; + lTMax := lDicomData.XYZdim[3] div lDICOMdata.SlicesPer3DVol div nOrders; + lZMax := lDICOMdata.SlicesPer3DVol; + l4DBytes := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*lDicomData.XYZdim[3]*trunc(((lDicomData.Allocbits_per_pixel)+7)/8); + lSliceBytes := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*trunc(((lDicomData.Allocbits_per_pixel)+7)/8); + GetMem(lTempBuffer,l4DBytes); + Move(lBuffer^,lTempBuffer^,l4DBytes); //move(src,dest,sz) + fillchar(lBuffer^,l4DBytes,0);//abba + lZo := 0; + lTo := 0; + lOrderVol := 0; + //for lSlice := 1 to lDicomData.XYZdim[3] do + //msg(inttostr(lDICOMdata.order[lSLice])); + for Order := 1 to nOrders do begin + for lSlice := 1 to lDicomData.XYZdim[3] do begin + if lDICOMdata.order[lSLice] = Order then begin + Move(lTempBuffer[((lSlice-1)*lSliceBytes)+1],lBuffer[(lZo*lSliceBytes)+((lOrderVol+lTo)*lZMax*lSliceBytes)+1],lSliceBytes); + inc(lTo); + if lTo >= lTMax then begin + lTo := 0; + inc(lZo); + end; + end; //desired order + end; + lOrderVol := lOrderVol + lTMax; + lZo := 0; + end; + freemem(lTempBuffer); +end; + +procedure SwapTime (var lDICOMdata: dicomdata; var lBuffer: bytep); +//data is stored X,Y,T,Z - swap to X,Y,Z,T +var + lSlice,l4DBytes,lSliceBytes,lZo,lTo,lZmax,lTmax:integer; + lTempBuffer: ByteP; +begin + if lDicomData.XYZdim[4] < 2 then + exit; + if MultiOrder(lDICOMdata) <> 0 then begin + SwapTimeMultiOrder (lDICOMdata,lBuffer); + exit; + end; + dcmMsg('Swizzling: XYTZ -> XYZT'); + if not lDICOMdata.file4D then + exit; + lTMax := lDicomData.XYZdim[3] div lDICOMdata.SlicesPer3DVol; + lZMax := lDICOMdata.SlicesPer3DVol; + l4DBytes := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*lDicomData.XYZdim[3]*trunc(((lDicomData.Allocbits_per_pixel)+7)/8); + lSliceBytes := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*trunc(((lDicomData.Allocbits_per_pixel)+7)/8); + GetMem(lTempBuffer,l4DBytes); + Move(lBuffer^,lTempBuffer^,l4DBytes); //move(src,dest,sz) + lZo := 0; + lTo := 0; + for lSlice := 1 to lDicomData.XYZdim[3] do begin + Move(lTempBuffer[((lSlice-1)*lSliceBytes)+1],lBuffer[(lZo*lSliceBytes)+(lTo*lZMax*lSliceBytes)+1],lSliceBytes); + inc(lTo); + if lTo >= lTMax then begin + lTo := 0; + inc(lZo); + end; + end; + freemem(lTempBuffer); +end; + +procedure FlipTB (var lDICOMdata: dicomdata; var lBuffer: bytep); +var + l16Buf : SmallIntP; + l32Buf : SingleP; + lSwap16: SmallInt; + lSwap32: Single; + lSwap8: byte; + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfY,lDecLineOffset,lLineOffset: integer; +begin + lX := lDicomData.XYZdim[1]; + lY := lDicomData.XYZdim[2]; + lZ := lDicomData.XYZdim[3]; + if lDicomData.SamplesPerPixel = 3 then + lZ := lZ * 3; + if (lY < 2) then exit; + lHlfY := lY div 2; + if lDicomData.Allocbits_per_pixel = 8 then begin + for lZPos := 1 to lZ do begin + lLineOffset := (lZPos-1)*(lX*lY); + lDecLineOffset := lLineOffset+(lX*lY)-lX; + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lSwap8 := lBuffer^[lXPos+lLineOffset]; + lBuffer^[lXPos+lLineOffset] := lBuffer^[lXPos+lDecLineOffset]; + lBuffer^[lXPos+lDecLineOffset] := lSwap8; + end; //for X + lLineOffset := lLineOffset + lX; + lDecLineOffset := lDecLineOffset - lX; + end; //for Y + end; //for Z + end else if lDicomData.Allocbits_per_pixel = 32 then begin + l32Buf := SingleP(lBuffer); + for lZPos := 1 to lZ do begin + lLineOffset := (lZPos-1)*(lX*lY); + lDecLineOffset := lLineOffset+(lX*lY)-lX; + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lSwap32 := l32Buf^[lXPos+lLineOffset]; + l32Buf^[lXPos+lLineOffset] := l32Buf^[lXPos+lDecLineOffset]; + l32Buf^[lXPos+lDecLineOffset] := lSwap32; + end; //for X + lLineOffset := lLineOffset + lX; + lDecLineOffset := lDecLineOffset - lX; + end; //for Y + end; //for Z + end else begin + l16Buf := SmallIntP(lBuffer); + for lZPos := 1 to lZ do begin + lLineOffset := (lZPos-1)*(lX*lY); + lDecLineOffset := lLineOffset+(lX*lY)-lX; + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lSwap16 := l16Buf^[lXPos+lLineOffset]; + l16Buf^[lXPos+lLineOffset] := l16Buf^[lXPos+lDecLineOffset]; + l16Buf^[lXPos+lDecLineOffset] := lSwap16; + end; //for X + lLineOffset := lLineOffset + lX; + lDecLineOffset := lDecLineOffset - lX; + end; //for Y + end; //for Z + end; +end; //proc FlipTB + +procedure MakePackedTriplet (var lBuffer: bytep; var lDicomData: DICOMdata); +//data is saved as RRRR GGGG BBBB save to RGBRGBRGB... +var + lRA: bytep; + lPix,lnPix,lSlice,lI: integer; +begin + if (lDicomData.SamplesPerPixel <> 3) or (lDicomData.XYZdim[1] < 1) or (lDicomData.XYZdim[2] < 1) or (lDicomData.XYZdim[3] < 1) then exit; + lnPix := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]; //*lDicomData.XYZdim[3] + GetMem(lRA,3*lnPix); //*3 as red, green, blue + for lSlice := 1 to lDicomData.XYZdim[3] do begin + lI := 1 + ((lSlice-1)* (3*lnPix)); //data from input slice + for lPix := 1 to lnPix do begin + lRA^[lI] := lBuffer^[lPix]; //red plane + inc(lI); + lRA^[lI] := lBuffer^[lPix+lnPix]; //green plane + inc(lI); + lRA^[lI] := lBuffer^[lPix+lnPix+lnPix]; //blue plane + inc(lI); + end; + Move(lRA^,lBuffer^[1 + ((lSlice-1)* (3*lnPix))],3*lnPix); + end; + Freemem(lRA); +end; + +procedure MakePlanar (var lBuffer: bytep; var lDicomData: DICOMdata); +//data is saved as RGBRGBRGB - convert to RRRR GGGG BBBB +var + lRA: bytep; + lPix,lnPix,lSlice,lI: integer; +begin + if (lDicomData.XYZdim[1] < 1) or (lDicomData.XYZdim[2] < 1) or (lDicomData.XYZdim[3] < 1) then exit; + lnPix := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]; //*lDicomData.XYZdim[3] + GetMem(lRA,3*lnPix); //*3 as red, green, blue + for lSlice := 1 to lDicomData.XYZdim[3] do begin + lI := 1 + ((lSlice-1)* (3*lnPix)); //data from input slice + for lPix := 1 to lnPix do begin + lRA^[lPix] := lBuffer^[lI]; //red plane + inc(lI); + lRA^[lPix+lnPix] := lBuffer^[lI]; //green plane + inc(lI); + lRA^[lPix+lnPix+lnPix] := lBuffer^[lI]; //blue plane + inc(lI); + end; + Move(lRA^,lBuffer^[1 + ((lSlice-1)* (3*lnPix))],3*lnPix); + end; + Freemem(lRA); +end; + +procedure DeMosaic (var lBuffer: bytep;lmosX,lmosY,lSlices: integer; lFlip: boolean; var lDicomData: DICOMdata); +//unMosaic +var + lPos,lH,lW,lnMos,lMos,lMosW,lMosH, lStripBytes,lPanelBytes,lStartOffset: integer; + lTempBuffer: ByteP; +begin + lnMos := lSlices;// lDICOMdata.SiemensMosaicX*lDICOMdata.SiemensMosaicY; + if (lmosX < 2) and (lmosY < 2) then exit; + if ((lmosX*lmosY) < lSlices) then begin + dcmMsg('This '+inttostr(lmosx)+'*'+inttostr(lmosy)+' mosaic can not hold '+inttostr(lSlices)+' slices.'); + exit; + end; + lMosW := lDICOMdata.XYZdim[1] div lmosX; + lMosH := lDICOMdata.XYZdim[2] div lmosY; + lStripBytes := lMosW*trunc(((lDicomData.Allocbits_per_pixel)+7)/8); + lPanelBytes := lDICOMdata.XYZdim[1] *trunc(((lDicomData.Allocbits_per_pixel)+7)/8); + GetMem(lTempBuffer,lPanelBytes*lDICOMdata.XYZdim[2]); + Move(lBuffer^,lTempBuffer^,lPanelBytes*lDICOMdata.XYZdim[2]); + //lImgBytes := (lPanelBytes*lDICOMdata.XYZdim[2]); + lPos := 0; +if lFlip then begin + +dcmmsg('*** WARNING: CSA "ProtocolSliceNumber" SUGGESTS REVERSED SLICE ORDER: SPATIAL AND DTI COORDINATES UNTESTED ****'); +dcmmsg('*** SOLUTION: open sequence on scanner, go to System tab, select Miscellaneous sub-tab, set default image numbering (F>>H, R>>L, A>>P'); +dcmmsg('*** If this is impossible and you wish to use these sequences for DTI please conduct DTI validation described on the dcm2nii web page'); +end; + (* for lMos := lnMos downto 1 do begin + lStartOffset := ((lMos-1) mod lmosX)*lStripBytes+ ( ((lMos-1) div lmosX)* (lPanelBytes*lMosH)); + for lH := 1 to lMosH do begin + for lW := 1 to lStripBytes do begin + inc(lPos); + lBuffer^[lPos] := lTempBuffer^[lStartOffset+lW ]; + end; + //lBuffer^[lPos-1] := 255;//crx + lStartOffset := lStartOffset + lPanelBytes; + end; + end; +end else *)begin + for lMos := 1 to lnMos do begin + lStartOffset := ((lMos-1) mod lmosX)*lStripBytes+ ( ((lMos-1) div lMosX)* (lPanelBytes*lMosH)); + for lH := 1 to lMosH do begin + for lW := 1 to lStripBytes do begin + inc(lPos); + lBuffer^[lPos] := lTempBuffer^[lStartOffset+lW ]; + end; + //lBuffer^[lPos-1] := 255;//crx + lStartOffset := lStartOffset + lPanelBytes; + end; + end; +end; + FreeMem(lTempBuffer); + //FlipTB needs new coordinates + lDicomData.XYZdim[1] := lMosW; + lDicomData.XYZdim[2] := lMosH; + lDicomData.XYZdim[3] := lnMos; + FlipTB (lDICOMdata, lBuffer); +end; + +function UnInterleaved (lVal, ln3D,ln4D: integer;lFLip: boolean): integer; +var + lVol,lSlice,lOut: integer; +begin + lSlice := ((lVal-1) mod ln3D) ; + lVol := ((lVal-1) div ln3D) ; + if lFlip then lSlice := ln3D-lSlice-1; + lOut := (lSlice*ln4D)+lVol; + //if lVol = 1 then Msg(inttostr(lSlice)+' '+inttostr(lVol)+' '+inttostr(lOut)); + result := lOut; +end; + +function UnFlip (lVal, ln3D: integer): integer; +var + lVol: integer; +begin + lVol := ((lVal-1) div ln3D); + result := lVal-((lVol)*ln3d);//{ln3D -} (lVal-((lVol-1)*ln3d)); + result := ((lVol+1)*ln3D) - result; +end; + +function CheckSliceDirection( var lD1,lD2: dicomdata):boolean; +var + lFloat: single; +begin + result := false; + lFloat := (ld2.PatientPosX-ld1.PatientPosX)-(ld2.PatientPosY-ld1.PatientPosY)-(ld2.PatientPosZ-ld1.PatientPosZ); + if lFloat > 0 then + result := true; + //if result then Msg('yikes'+floattostr(ld2.PatientPosX-ld1.PatientPosX)+'y'+floattostr(ld2.PatientPosY-ld1.PatientPosY)+'z'+floattostr(ld2.PatientPosZ-ld1.PatientPosZ) ); +end; + +function Index (lSeries,lFirstDICOM: integer; lInterleaved,lFlip: boolean; var lAHdr: TNIFTIhdr ): integer; +begin + if lInterleaved then + result := UnInterleaved (lSeries, lAHdr.dim[3],lAHdr.dim[4],lFlip) + else if not lFlip then + result := lSeries-1 + else + result := UnFlip (lSeries, lAHdr.dim[3]); + result := result + lFirstDICOM; +end; + +procedure SiemensFlipYBvecs (var lDTIra: TDTIra; nVec: integer); +var + lI: integer; + V: double; +begin + if nVec < 1 then exit; + for lI := 1 to nVec do begin + if lDTIra[lI].v2 <> 0 then //people do not like seeing -0, even though this is a valid ieee value + lDTIra[lI].v2 := -lDTIra[lI].v2; + end; + //next: normalize + for lI := 1 to nVec do begin + + V := sqr(lDTIra[lI].v1)+ sqr(lDTIra[lI].v2)+sqr(lDTIra[lI].v3); + if V = 0 then + V := 1 + else + V := sqrt(V); + + lDTIra[lI].v1 := lDTIra[lI].v1/V; + lDTIra[lI].v2 := lDTIra[lI].v2/V; + lDTIra[lI].v3 := lDTIra[lI].v3/V; + end; + +end; + +procedure GECorrectBvecs (var lDICOMdata:dicomdata; var lDTIra: TDTIra; nVec: integer); +//0018,1312 phase encoding is either in row or column direction +//0043,1039 (or 0043,a039). b value (as the first number in the string). +//0019,10bb (or 0019,a0bb). Phase-gradient diffusion direction +//0019,10bc (or 0019,a0bc). Frequency-gradient diffusion direction +//0019,10bd (or 0019,a0bd). Slice diffusion direction +//If 0018,1312 = Col then X=-x0bb, Y=x0bc, Z=x0bd, +//If 0018,1312 = Row then X=-x0bc, Y=-x0bb, Z=x0bd, +var + lI: integer; + lCol: boolean; + lSwap: double; +begin + if nVec < 1 then exit; + if (length(lDicomData.PatientPos) >= 3) and (lDicomData.PatientPos[1] = 'H') and (lDicomData.PatientPos[2] = 'F') and (lDicomData.PatientPos[3] = 'S') then + else begin + dcmMsg('DTI vector error: Position is not head first supine'); + exit; + end; + if (length(lDicomData.PhaseEncoding) >= 3) and (upcase(lDicomData.PhaseEncoding[1]) = 'C') then + lCol := true + else + lCol := false; + //dcmMsg('>>>>'+lDicomData.PhaseEncoding[1]+lDicomData.PhaseEncoding[2]+lDicomData.PhaseEncoding[3]+'<<<'+inttostr(length(lDicomData.PhaseEncoding))); + for lI := 1 to nVec do begin + lDTIra[lI].v3 := lDTIra[lI].v3; + if (lDTIra[lI].bval <= 0) or ((lDTIra[lI].v1 = 0) and (lDTIra[lI].v2 = 0) and (lDTIra[lI].v3 = 0)) then begin + lDTIra[lI].v1 := 0; + lDTIra[lI].v2 := 0; + lDTIra[lI].v3 := 0; + end else begin //if bval=0 or null vector, else real vector + if lCol then begin + lDTIra[lI].v1 := -lDTIra[lI].v1; + lDTIra[lI].v2 := lDTIra[lI].v2; + end else begin + lSwap := lDTIra[lI].v1; + lDTIra[lI].v1 := -lDTIra[lI].v2; + lDTIra[lI].v2 := -lSwap; + end; + end; //real vector - not 0,0,0 + if (lDTIra[lI].v1 = -0.0) then lDTIra[lI].v1 := 0.0; + if (lDTIra[lI].v2 = -0.0) then lDTIra[lI].v2 := 0.0; + if (lDTIra[lI].v3 = -0.0) then lDTIra[lI].v3 := 0.0; + end;//for each bvec +end; + +(*procedure doBVecs; +var + lDICOMData:dicomdata; + lDTI: TDTI; + +begin + lDICOMData.Orient[1] := 0.99872048491662; + lDICOMData.Orient[2] := -0.0015021527936; + lDICOMData.Orient[3] := -0.0505483584788; + lDICOMData.Orient[4] := -1.12378993e-008; + lDICOMData.Orient[5] := 0.99955873135595; + lDICOMData.Orient[6] := -0.0297042517172; + lDTI.v1 := 0.99899346; + lDTI.v2 := 0.00503525; + lDTI.v3 := -0.00604230; + correctBvecs(lDICOMdata, lDTI); + +end; *) + + + +function MkDICOMDir (var lDICOMdata: DICOMdata; var lOutDir: string): boolean; +var + lBlank,lName: string; + lPrefs: TPrefs; +begin + result := false; + if not direxists(lOutDir) then + exit; + lBlank := ''; + lPrefs.AppendDate := true; + lPrefs.AppendAcqSeries := false; + lPrefs.AppendProtocolName := false; + lPrefs.AppendPatientName := true; + lPrefs.AppendFilename := false; + lName := OutputFilename(lBlank,lDicomData, lPrefs); + if lName = '' then + exit; + lOutDir := lOutDir +lName; + dcmMsg('Creating folder '+lOutDir); + {$I-} + MkDir(lOutDir); + if IOResult <> 0 then begin + //MessageDlg('Cannot create directory', mtWarning, [mbOk], 0) + end; + + {$I+} + + lOutDir := lOutDir + pathdelim; + result := true; +end; + + + +function ImageScalingOrIntensityVaries(var lDICOMra: TDICOMrap; lFirstDICOM, lLastDICOM: integer): boolean; +var + lIndex: integer; +begin + result := false; + if (lFirstDICOM >= lLastDICOM) then exit; //only one image + result := true; + for lIndex := (lFirstDICOM +1) to lLastDICOM do begin + if lDICOMra^[lIndex].IntenIntercept <> lDICOMra^[lFirstDICOM].IntenIntercept then + exit; //1492 + if lDICOMra^[lIndex].IntenScale <> lDICOMra^[lFirstDICOM].IntenScale then + exit; //1492 + if lDICOMra^[lIndex].Allocbits_per_pixel <> lDICOMra^[lFirstDICOM].Allocbits_per_pixel then + exit; + end; + result := false; +end; + +procedure MakeFloat (var lBuffer: bytep; var lDicomData: DICOMdata; var lSliceBytesOut: integer); +//data is saved as RGBRGBRGB - convert to RRRR GGGG BBBB +var + lRA: bytep; + lPix,lnPix,lnBytes: integer; + l8i : byteP; + l16ui : WordP; + l16i: SmallIntP; + l32i: LongIntP; + l32fo, l32f: SingleP; + //lByteSwap: boolean; +begin + if (lDicomData.XYZdim[1] < 1) or (lDicomData.XYZdim[2] < 1) or (lDicomData.XYZdim[3] < 1) then exit; + dcmMsg(' Converting data to 32-bit float to correct for differences slope/intercept/precision: '+chr(9)+realtostr(lDicomData.IntenScale,8)+chr(9)+realtostr(lDicomData.IntenIntercept,8)+chr(9)+inttostr(lDicomData.Allocbits_per_pixel)); + {$IFDEF ENDIAN_BIG} + //lByteSwap := odd(lDICOMdata.little_endian); + {$ELSE} + //lByteSwap := not odd(lDICOMdata.little_endian); + {$ENDIF} + lnPix := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*lDicomData.XYZdim[3]; + //msg(' '+inttostr(lDicomData.XYZdim[1])+' '+inttostr(lDicomData.XYZdim[2])+' '+inttostr(lDicomData.XYZdim[3]) ); + lnBytes := lnPix *trunc(((lDicomData.Allocbits_per_pixel)+7)/8); + GetMem(lRA,lnBytes ); + Move(lBuffer^,lRA^,lnBytes); //move(src,dest,sz) + Freemem(lBuffer); + GetMem(lBuffer,lnPix * 4); //save as 32 bit float: 4 bytes per pixel + l32fo := SingleP(@lBuffer^[1]); + if lDicomData.Allocbits_per_pixel = 8 then begin //8bit - byte swapping is not a problem... + for lPix := 1 to lnPix do + l32fo^[lPix] := lRA^[lPix]*lDicomData.IntenScale + lDicomData.IntenIntercept; + end; //8bit + //next 16 bit + (*if (lDicomData.Allocbits_per_pixel = 16) and (lByteSwap) then begin //UNSWAP 16bit + l16ui := WordP(@lRA^[1]); + + for lPix := 1 to lnPix do + l16ui^[lPix] := swap(l16ui^[lPix]); + end; *)//UNSWAP 16bit + if (lDicomData.Allocbits_per_pixel = 16) and (not lDicomData.SignedData) then begin //16bit UNSIGNED + + l16ui := WordP(@lRA^[1]); + for lPix := 1 to lnPix do + l32fo^[lPix] := l16ui^[lPix]*lDicomData.IntenScale + lDicomData.IntenIntercept; + end; //16bit UNSIGNED + if (lDicomData.Allocbits_per_pixel = 16) and (lDicomData.SignedData) then begin //16bit SIGNED + l16i := SmallIntP(@lRA^[1]); + for lPix := 1 to lnPix do + l32fo^[lPix] := l16i^[lPix]*lDicomData.IntenScale + lDicomData.IntenIntercept; + end; //16bit SIGNED + //NEXT 32bit + (*if (lDicomData.Allocbits_per_pixel = 32) and (lByteSwap) then begin //UNSWAP 32bit + l32i := LongIntP(@lRA^[1]); + for lPix := 1 to lnPix do + pswap4i(l32i^[lPix]); + end; //UNSWAP 32bit *) + if (lDicomData.Allocbits_per_pixel = 32) and (not lDicomData.FloatData) then begin //32bit INTEGER + l32i := LongIntP(@lRA^[1]); + for lPix := 1 to lnPix do + l32fo^[lPix] := l32i^[lPix]*lDicomData.IntenScale + lDicomData.IntenIntercept; + end; //32bit INTEGER + if (lDicomData.Allocbits_per_pixel = 32) and ( lDicomData.FloatData) then begin //32bit FLOAT + l32f := SingleP(@lRA^[1]); + for lPix := 1 to lnPix do + l32fo^[lPix] := l32f^[lPix]*lDicomData.IntenScale + lDicomData.IntenIntercept; + end; //32bit FLOAT + Freemem(lRA); + lDicomData.Allocbits_per_pixel := 32; + lDicomData.FloatData := true; + lDicomData.IntenScale := 1; + lDicomData.IntenIntercept := 0; + lSliceBytesOut := lnPix * 4; +end; + +procedure SaveTextReport(lOutImgName: string; var lDICOM: dicomdata; var lAHdr: TNIFTIhdr ; lDTIdir: integer); +var + lFile : TextFile; + lname,lstr: string; +begin + lname := changefileext(lOutImgName,'.txt'); + AssignFile(lFile, lname); + ReWrite(lFile); + // Write a couple of well known words to this file + lStr := DICOMstr(lDICOM)+kTab+'DimXYZT:'+kTab+inttostr(lAHdr.dim[1])+kTab+inttostr(lAHdr.dim[2])+kTab+inttostr(lAHdr.dim[3])+kTab+inttostr(lAHdr.dim[4]) ; + if lDTIdir > 1 then + lStr := lStr+'DTIdir:'+kTab+inttostr(lDTIdir); + WriteLn(lFile, lStr); + // Close the file + CloseFile(lFile); +end; + +function reportSliceTimes(lSliceTimes: TSliceTimes): integer; +//returns multiband factor +var + i: integer; + s: string; +begin + result := 1; + if length(lSliceTImes) < 1 then exit; + s := ' MosaicRefAcqTimes ('+inttostr(length(lSliceTimes))+' values for Slice Time Correction) '; + for i := 0 to (length(lSliceTimes)-1) do + s := s+kTab+floattostr(lSliceTImes[i]); + dcmmsg(s); + for i := 1 to (length(lSliceTimes)-1) do + if SameValue(lSliceTImes[i], lSliceTImes[0]) then + inc(result); + if (result > 1) then + dcmmsg(' These values suggest a multiband factor of '+inttostr(result)); +end; + + +function padS(ins: string; outl: integer): string; +var + i: integer; +begin + result := ''; + for i := 1 to outl do begin + if i <= length(ins) then + result := result + ins[i] + else + result := result + chr(0); + end; +end; + +procedure SetNiiStr(var lH: TNIFTIhdr; lSdb, lSaux: string); +var + i,l: integer; + s: string; +begin + s := padS (lSdb,18); + for i := 1 to 18 do + lH.db_name[i] := s[i]; + s := padS (lSaux,24); + for i := 1 to 24 do + lH.aux_file[i] := s[i]; +end; + +procedure AddNiiDescrip(var lH: TNIFTIhdr; lS: string); +var + i,l: integer; + s: string; +begin + s := padS (lS,80); + l := 0; + for i := 1 to 80 do + if lH.descrip[i] <> chr(0) then l := i; + if l >= 80 then exit; + for i := 1+l to 80 do + lH.descrip[i] := s[i-l]; +end; + +procedure UnswapEndian (var lImgBuffer: byteP; lBytes, lBitPix: integer); //ensures image data is in native space +//returns data in native endian +//sets 'ByteSwap' flag to false. E.G. a big-endian image will be saved as little-endian on little endian machines +var + lInc,lImgSamples : integer; + l32i : LongIntP; + l16i : SmallIntP; +begin + if lBitPix < 9 then exit; + lImgSamples := lBytes div (lBitPix div 8); + if lImgSamples < 1 then + exit; + case lBitPix of + 16: begin + l16i := SmallIntP(@lImgBuffer^[1]); + for lInc := 1 to lImgSamples do + l16i^[lInc] := Swap(l16i^[lInc]); + end; //l16i + 32: begin + //note: for the purposes of byte swapping, floats and long ints are the same + l32i := LongIntP(@lImgBuffer^[1]); + for lInc := 1 to lImgSamples do + Swap4(l32i^[lInc]); + end;//32i + + end; //case +end; + +function Dicom2NII(var lDICOMra: TDICOMrap; var l4dDTIra: TDTIra; lFirstDICOM, lLastDICOM: integer; var lOutDirOrig: string; var lPrefs: TPrefs; lVols: integer): boolean; +var + lDTIra: TDTIra; + lCSA:TCSA; + lSliceTimes: TSliceTimes; + lPref: TPrefs; + lDTIdir,lRGB: integer; + lVolGb : double; + lAllocSLiceSz, + lStart,lEnd,lmosX,lmosY,lIndex,lSecondDICOM,lSeries,lnSeries,lSliceBytes, + lMosaicSlices,lSliceBytesOut,lvolOffset,lvolOffsetInit,lvolBytesOut,lSliceOrder: integer; + lDX: single; + lDicomImgName,lOutHdrName,lOutImgName,lOutImgNameGZ,lOutDir,lOutDTIname, lStr:string; + lDICOMData:dicomdata; + lReadOK,lFlip,lIntenScaleVaries,lInterleaved,lVolSave : boolean; //,lByteSwap + lAHdr: TNIFTIhdr; + lTextF: TextFile; + lOutF,lInF: File; + lvBuffer,lsBuffer: bytep; + lFlipMosaicMatrix,lFlipMosaic: boolean; +begin + lDicomImgName := lDICOMra^[lFirstDICOM].Filename; + lDicomData := lDICOMra^[lFirstDICOM]; + if lPrefs.DebugMode2 then begin + dcmMsg( DICOMstr(1,lDICOMra,OutputFilename(lDicomImgName,lDICOMra^[lFirstDICOM],lPref))); + dcmMsg(inttostr(lDICOMdata.XYZdim[1])+'x'+inttostr(lDICOMdata.XYZdim[2])+'x'+inttostr(lDICOMdata.XYZdim[3])+'x'+inttostr(lDICOMdata.XYZdim[4])); + result := true; + exit; + end; + result := false; + lSliceOrder := kNIFTI_SLICE_SEQ_UNKNOWN; //unknown + lPref := lPrefs; + CorrectPrefs(lPref); + lmosX := 1; + lmosY := 1; + lSecondDICOM := lFirstDICOM+1; + lFlipMosaicMatrix := false; + lInterleaved := false; + + lnSeries := (lLastDICOM+1) -lFirstDICOM; //e.g. first=10, last=10 means 1 image + if lnSeries < 1 then + exit; + //next if magnitude and phase maps are saved in the same 4D file, extract to separate files... + if (lDICOMra^[lFirstDICOM].file4D) and (MultiOrder(lDICOMra^[lFirstDICOM]) > 0) then + lPref.fourD := false; + + + + if (lDicomData.SamplesPerPixel = 3) then begin + dcmMsg('Warning: RGB to NIfTI conversion poorly tested: '+lDicomImgName); + end; + (*{$IFDEF ENDIAN_BIG} + lByteSwap := odd(lDICOMdata.little_endian); + {$ELSE} + lByteSwap := not odd(lDICOMdata.little_endian); + {$ENDIF} *) + lMosaicSlices := lDicomData.SiemensSlices; + lOutDir := ExtractFileDirWithPathDelim2(lOutDirOrig); + if (lOutDir = '') then begin + lOutDir := ExtractFilePath(lDicomImgName); + end; + if not DirWritePermission(lOutDir) then begin // <- tested with Unix + dcmMsg('Error: output directory is read-only: '+lOutDir); + exit; + end; + if lPref.createoutputfolder then + MkDICOMDir(lDICOMdata,lOutDir); + if not direxists(lOutDir) then begin + dcmMsg('Unable to find output directory '+lOutDir); + lOutDir := ExtractFileDirWithPathDelim2(lDicomImgName) + end; //else directory exists + + + //lOutHdrName :=lOutDir+OutputFilename(lDicomImgName,lDicomData,lPrefs.AppendDate,lPrefs.AppendAcqSeries,lPrefs.AppendProtocolName,lPrefs.AppendPatientName,lPrefs.FourD,lPrefs.AppendFilename)+'.hdr'; + lOutHdrName :=lOutDir+OutputFilename(lDicomImgName,lDicomData,lPref)+'.hdr'; + lOutImgName :=changefileext(lOutHdrName,'.img'); + if lPref.SingleNIIFile then begin + lOutHdrName := changefileext(lOutHdrName,'.nii'); + lOutImgName := lOutHdrName; + end; + if (lPref.SingleNIIFile) and (lPref.GZip) then begin + lOutHdrName := lOutHdrName+'.gz'; + if (not UniqueFileName(lOutHdrName)) then begin + dcmMsg('File already exists '+lOutImgName+' '+lOutHdrName); + exit; + end; + //we now need to remove the .gz - not that unique filename may have appended postfix, e.g. filename.nii.gz -> filenameA.nii.gz + StripGZExt(lOutHdrName); + lOutImgName := lOutHdrName; + end else begin + if (not UniqueFileName(lOutHdrName)) or (not UniqueFileName(lOutImgName)) then begin + dcmMsg('File already exists '+lOutImgName+' '+lOutHdrName); + exit; + end; + end; + dcmMsg(extractfilename(lDicomImgName)+'->'+extractfilename(lOutImgName)); + DICOM2AnzHdr(lAHdr,lPref.Anonymize,lDicomImgName,lDICOMdata); + + if lPrefs.DebugMode2 then begin + dcmMsg('slice/vols/series '+inttostr(lDICOMdata.SlicesPer3DVol )+' '+inttostr(lVols)+' '+inttostr(lnSeries)); + dcmMsg('x/y/z '+inttostr(lDICOMdata.XYZdim[1])+'x'+inttostr(lDICOMdata.XYZdim[2])+'x'+inttostr(lDICOMdata.XYZdim[3])+'x'+inttostr(lDICOMdata.XYZdim[4])); + result := true; + exit; + end; + + if (lVols > 1) and ((lnSeries mod lVols)=0) then + lDICOMdata.SlicesPer3DVol := round(lnSeries/lVols); + lDTIra[1].bval := -1; //not DTI + lDTIdir := 0; + IsSiemensDTI(lDicomData,lDTIra[1], lDicomImgName, lPrefs);//see if this is a Siemens DTI image - mosaics in B13, non-mosaic in B12 + if (lDICOMdata.SiemensMosaicX > 1) or (lDICOMdata.SiemensMosaicY > 1) then begin + lFlipMosaicMatrix := IsNormalMosaic(lDicomData,lMosaicSlices, lDicomImgName); + lAHdr.dim[1] := lDicomData.XYZdim[1] div lDICOMdata.SiemensMosaicX; + lAHdr.dim[2] := lDicomData.XYZdim[2] div lDICOMdata.SiemensMosaicY; + lmosX := lDICOMdata.SiemensMosaicX; + lmosY := lDICOMdata.SiemensMosaicY; + //lSlices := lDICOMdata.SiemensSlices;//(lDicomImgName,'NumberOfImagesInMosaic'); + if lMosaicSlices > 1 then + lAHdr.dim[3] := lMosaicSlices + else + lAHdr.dim[3] := lDICOMdata.SiemensMosaicX *lDICOMdata.SiemensMosaicY; + lAHdr.dim[4] := lnSeries; + if ((lmosX*lmosY) < lAHdr.dim[3]) then begin + dcmMsg('Aborted '+lDicomData.Filename+ ' : This '+inttostr(lmosx)+'*'+inttostr(lmosy)+' mosaic can not hold '+inttostr(lAHdr.dim[3])+' slices.'); + exit; + end; + + end else if lDICOMdata.File4D then begin//(lDicomData.XYZdim[3] > 1) and (lnSeries = 1) and (lDICOMdata.SlicesPer3DVol > 1) and ((lAHdr.dim[3] mod lDICOMdata.SlicesPer3DVol)=0) then begin + lAHdr.dim[4] := lAHdr.dim[3] div lDICOMdata.SlicesPer3DVol; + lAHdr.dim[3] := lDICOMdata.SlicesPer3DVol; + + end else if (lDicomData.XYZdim[3] > 1) then + lAHdr.dim[4] := lnSeries + else begin + if (lDICOMdata.SlicesPer3DVol > 1) and ((lnSeries mod lDICOMdata.SlicesPer3DVol)=0) then begin + lAHdr.dim[3] := lDICOMdata.SlicesPer3DVol; + lAHdr.dim[4] := round(lnSeries / lDICOMdata.SlicesPer3DVol); + if (lnSeries > 1) and (DICOMinterslicedistance( lDICOMra^[lFirstDICOM], lDICOMra^[lSecondDICOM]) < 0.01) then + lInterleaved := true; + end else + lAHdr.dim[3] := lnSeries; + end; + if (lDICOMdata.ManufacturerID = kSiemensID) and (lDicomData.CSASeriesHeaderInfoPos > 0) and (lDicomData.CSASeriesHeaderInfoSz > 0) then begin + lStr := GetCSASeriesHeaderInfo (lDicomImgName, lDicomData.CSASeriesHeaderInfoPos,lDicomData.CSASeriesHeaderInfoSz,lAHdr.dim[3], lSliceOrder); + if (lSliceOrder < kNIFTI_SLICE_SEQ_UNKNOWN) or (lSliceOrder > kNIFTI_SLICE_ALT_DEC2) then lSliceOrder := kNIFTI_SLICE_SEQ_UNKNOWN; + lAHdr.slice_code := lSliceOrder; + lAHdr.dim_info:= 3 shl 4; + lAHdr.slice_start:= 0; + lAHdr.slice_end := lAHdr.dim[3]-1; + if lAHdr.slice_code <> kNIFTI_SLICE_SEQ_UNKNOWN then begin + //read final not first image https://github.com/eauerbach/CMRR-MB/issues/29 + //DecodeCSA2 (lDicomImgName, lDicomData.CSAImageHeaderInfoPos,lDicomData.CSAImageHeaderInfoSz, lCSA, lSliceTimes, lFlippedMosaic); + DecodeCSA2 (lDICOMra^[lLastDICOM].Filename, lDICOMra^[lLastDICOM].CSAImageHeaderInfoPos,lDICOMra^[lLastDICOM].CSAImageHeaderInfoSz, lCSA, lSliceTimes, lFlipMosaic); + reportSliceTimes(lSliceTimes); + SetNiiStr(lAHdr, lStr, lDICOMra^[lLastDICOM].ImageComments); + if (lCSA.PhaseDirectionPositive = 1) then + AddNiiDescrip(lAHdr,';phaseDir=+') + else if (lCSA.PhaseDirectionPositive = 0) then + AddNiiDescrip(lAHdr,';phaseDir=-'); + lSliceTimes := nil; + end; + // + dcmmsg('For slice timing correction: the slice order is '+kSliceOrderStr[lSliceOrder]); + end; + if (lDICOMdata.BandwidthPerPixelPhaseEncode > 0) then begin + //do this AFTER mosaics have reset dim[1] and dim[2] + if (length(lDICOMdata.PhaseEncoding) > 0) and ((lDICOMdata.PhaseEncoding[1]='C') or (lDICOMdata.PhaseEncoding[1]='R')) then begin + //fx( lAHdr.dim[1],lAHdr.dim[2]); + + if (lDICOMdata.PhaseEncoding[1]='C') then begin//columns + lAHdr.pixdim[6] := 1000/lDICOMdata.BandwidthPerPixelPhaseEncode/lAHdr.dim[2]; + lAHdr.slice_duration:= lAHdr.pixdim[6] * lAHdr.dim[2]; + end else begin //rows + lAHdr.pixdim[6] := 1000/lDICOMdata.BandwidthPerPixelPhaseEncode/lAHdr.dim[1]; + lAHdr.slice_duration:= lAHdr.pixdim[6] * lAHdr.dim[1]; + //dcmMsg(inttostr(lAHdr.dim[1])); + end; + AddNiiDescrip(lAHdr,';dwell='+realtostr( lAHdr.pixdim[6],3)); + dcmMsg('Effective echo spacing: '+floattostr( lAHdr.pixdim[6])+'ms, BandwidthPerPixelPhaseEncode: '+floattostr(lDICOMdata.BandwidthPerPixelPhaseEncode)); + end else + dcmMsg('Unable to determine echo spacing: not sure of phase encoding direction'); + end; +lFlip := false; + if lnSeries > 1 then begin//check slice order + lFlip := CheckSliceDirection(lDICOMra^[lFirstDICOM],lDICOMra^[lLastDICOM]); + if lFlip then begin + lDicomImgName := lDICOMra^[lLastDICOM].Filename; + lDICOMdata := lDICOMra^[lLastDICOM]; + end; + end; + + //next compute dx between slices + if (lAHdr.dim[3] > 1) and (lnSeries > 1) and (lDICOMdata.SiemensMosaicX <2) then begin + lDX := abs(DICOMinterslicedistance( lDICOMra^[ Index (1,lFirstDICOM,lInterleaved,lFlip,lAHdr)], lDICOMra^[ Index (2,lFirstDICOM,lInterleaved,lFlip,lAHdr)]) ); + if lDX <> 0 then begin + lDicomData.XYZmm[3] := lDX; + lAHdr.pixdim[3] := lDX; + end; + end; + dicom_2_nifti(lDICOMdata,lAHdr,lMosaicSlices,lFlipMosaicMatrix); + //all slices in a NIFTI image must be of the same precision and have the same scaling intercept and slope - see if this applies + (*lBaseIntenScale := lDICOMdata.IntenScale; + lBaseIntenIntercept := lDICOMdata.IntenIntercept; + lBaseBitDepth := lDicomData.Allocbits_per_pixel; + lIntenScaleVaries := false; + for lSeries := 1 to lnSeries do begin + lIndex := Index (lSeries,lFirstDICOM,lInterleaved,lFlip,lAHdr); + if lDICOMra^[lIndex].IntenIntercept <> lBaseIntenIntercept then + lIntenscaleVaries := true; //1492 + if lDICOMra^[lIndex].IntenScale <> lBaseIntenScale then + lIntenscaleVaries := true; //1492 + if lDICOMra^[lIndex].Allocbits_per_pixel <> lBaseBitDepth then + lIntenscaleVaries := true; + end; //for lnSeries *) + lIntenScaleVaries := ImageScalingOrIntensityVaries(lDICOMra, lFirstDICOM, lLastDICOM); + + (* for lSeries := 1 to lnSeries do begin + lIndex := Index (lSeries,lFirstDICOM,lInterleaved,lFlip,lAHdr); + lDicomData := lDICOMra^[lIndex]; + + msgfx(lSeries, lDICOMdata.DTI[1].v1,lDICOMdata.DTI[1].v2,lDICOMdata.DTI[1].v3); + end; *) + // exit;//get out of here - crucial critical -- last chance before data saved to disk + + if (lAHdr.bitpix = 8) and (lDicomData.SamplesPerPixel = 3) then begin + if (lIntenScaleVaries) then begin + dcmMsg('RGB files can not have varying intensity scales!'); + lIntenScaleVaries := false; + end; + lRGB := 3; + lAHdr.datatype := kDT_RGB; + lAHdr.bitpix := 24; + end else + lRGB := 1; + if (lIntenScaleVaries) then begin + lAHdr.datatype := kDT_FLOAT; + lAHdr.bitpix := 32; + dcmMsg('Warning: images have different precision or intensity scaling - saving as 32-bit float'); + end; + lSliceBytes := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*lDicomData.XYZdim[3]*trunc(((lDicomData.Allocbits_per_pixel)+7)/8)*lRGB; + GetMem(lsBuffer,lSliceBytes); + + lSliceBytesOut :=lAHdr.dim[1]*lAHdr.dim[2]*lAHdr.dim[3]*trunc((lAHdr.bitpix+7)/8)*lRGB; + if lPrefs.DebugMode2 then + dcmMsg(' bytes/bitPix '+inttostr( lSliceBytesOut)+' '+inttostr(lAHdr.bitpix) ); + lVolBytesOut := lSliceBytesOut * lAHdr.dim[4]; + lVolOffset := 1; + lVolGB := (lSliceBytesOut/ 1073741824) * lAHdr.dim[4]; //bytes *1024 (kB) *1024 (Mb) * 1024 (Gb) + //note.nii files are 352bytes larger than calculated by lVolGb... + //Msg(floattostr(lVolGb)+' Gb'); + if lVolGb < 0.95 then + lVolSave := true + else begin + dcmMsg('Very large volume: '+floattostr(lVolGb)+' Gb: slice-by-slice conversion required.'); + if lPref.GZip then begin + lPref.GZip := false; + dcmMsg('Unable to automatically GZip such a large file.'); + end; + lVolSave := false; + end; + if lVolSave then begin //save entire volume + if lPref.SingleNIIFile then begin + lVolOffset := kNIIImgOffset+1;// 353; //first 352 bytes empty + lVolBytesOut := lVolBytesOut + lVolOffset -1; + end else lVolOffset := 1; + GetMem(lvBuffer,lVolBytesOut); + //showmessage(inttostr(lVolBytesOut)); + //we could copy NIfTI header to Buffer, but this would need to be changed for + //4D->3D images or images where we swap 3rd and 4th dimension.... + end else begin //save slice by slice - slower but low RAM usage... + if not SaveHdr (lOutHdrName,lAHdr, false,lPref.SPM2) then begin + dcmMsg('Error saving data - do you have permission and space for '+lOutHdrName+'?'); + exit; + end; + Filemode := 2; + AssignFile(lOutF, lOutImgName); + if lPref.SingleNIIFile then begin + Reset(lOutF,1); + Seek(lOutF,352); + lAHdr.vox_offset := 352; + end else + Rewrite(lOutF,1); + end; //end slice-bylslice + Filemode := 0; //set to read only + lVolOffsetInit := lVolOffset; + for lSeries := 1 to lnSeries do begin + lIndex := Index (lSeries,lFirstDICOM,lInterleaved,lFlip,lAHdr); + lDicomImgName := lDICOMra^[lIndex].Filename; + lDicomData := lDICOMra^[lIndex]; + if (lDICOMdata.ManufacturerID = kPhilipsID) and (lDICOMdata.nDTIdir > 1) and (lAHdr.dim[4] < kMaxDTIDir) and (lDICOMdata.nDTIdir >= lAHdr.dim[4]) then begin // + dcmMsg('4D Philips DTI data '+inttostr(lDICOMdata.nDTIdir)); + for lDTIdir := 1 to lAHdr.dim[4] do begin + lDTIra[lDTIdir].bval := l4dDTIra[lDTIdir].bval; + lDTIra[lDTIdir].v1 := l4dDTIra[lDTIdir].v1; + lDTIra[lDTIdir].v2 := l4dDTIra[lDTIdir].v2; + lDTIra[lDTIdir].v3 := l4dDTIra[lDTIdir].v3; + end; + lDTIdir := lAHdr.dim[4]; + end else if (lDICOMdata.ManufacturerID = kSiemensID) and (lDTIra[1].Bval >= 0) and (lDTIdir < kMaxDTIDir) and ( ((lSeries mod lAHdr.dim[3]) = 1) or((lMosX > 1) or (lMosY > 1))) then begin // + inc(lDTIdir); + IsSiemensDTI(lDicomData,lDTIra[lDTIdir], lDicomImgName,lPrefs); + + end else if (lDICOMdata.nDTIdir = 1) and (lDICOMdata.DTI.Bval >= 0) and (lDTIdir < kMaxDTIDir) and ( (lSeries mod lAHdr.dim[3]) = 1) then begin // + inc(lDTIdir); + lDTIra[lDTIdir].bval := lDICOMdata.DTI.bval; + lDTIra[lDTIdir].v1 := lDICOMdata.DTI.v1; + lDTIra[lDTIdir].v2 := lDICOMdata.DTI.v2; + lDTIra[lDTIdir].v3 := lDICOMdata.DTI.v3; + end; + lReadOK := true; + if (lDicomData.JPEGLosslessCpt) then begin + AssignFile(lInF, lDicomImgName); + Reset(lInF,1); + //lDICOMdata.CompressSz := FileSize(lInF)-lDicomData.CompressOffset; + Filemode := 0; //ReadONly + //lSliceBytesOut := lSliceBytes; + dcmMsg('Decoding lossless '+inttostr(lDICOMdata.XYZdim[1])+'x'+inttostr(lDICOMdata.XYZdim[2])+' JPEG starting from byte '+ inttostr(lDicomData.CompressOffset)+' with '+inttostr(lDICOMdata.CompressSz)+' bytes'); + if ( lDicomData.XYZdim[3] > 1) or ( lDicomData.XYZdim[4] > 1) then + dcmMsg('*Warning: this software will only convert the first slice of this multislice lossless compressed JPEG'); + lAllocSLiceSz := (lDICOMdata.XYZdim[1]*lDICOMdata.XYZdim[2] * lDICOMdata.Allocbits_per_pixel+7) div 8 ; + DecodeJPEG(lInF,SmallIntP0(lsBuffer),ByteP0(lsBuffer),lAllocSliceSz,lDicomData.CompressOffset,lDICOMdata.CompressSz,false); + CloseFile(lInF); + (*FlipTB(lDICOMdata,lsBuffer); + if lVolSave then begin{save entire volume} + Move(lsBuffer^,lvBuffer^[lvolOffset],lSliceBytesOut); + //Msg(inttostr(lSeries)); + lVolOffset := lVolOffset + lSliceBytesOut; + end else begin //save slice-by-slice + Filemode := 2; //read and write + BlockWrite(lOutF, lsBuffer^, lSliceBytesOut); + end;*) + end else if (FSize(lDicomImgName) >= (lSliceBytes+lDicomData.imagestart)) then begin + Filemode := 0; //ReadONly + AssignFile(lInF, lDicomImgName); + Reset(lInF,1); + Seek(lInF,lDicomData.imagestart); + Filemode := 0; //ReadONly + BlockRead(lInF, lsBuffer^, lSliceBytes); + //ShowMsg(inttostr(lsBuffer^[lSliceBytes-1])+' '+inttostr(lsBuffer^[lSliceBytes-2])+' '+inttostr(lsBuffer^[lSliceBytes-3])+' '+inttostr(lsBuffer^[lSliceBytes-4])+' '+inttostr(lsBuffer^[lSliceBytes-6])+' '+inttostr(lsBuffer^[lSliceBytes-7])); + CloseFile(lInF); + (*if (lDICOMdata.file4D) and (lPrefs.Swizzle4D) then + SwapTime(lDICOMdata,lsBuffer);//data is stored X,Y,T,Z - swap to X,Y,Z,T + lSliceBytesOut := lSliceBytes; + if (lDICOMdata.PlanarConfig = 0) and (lDicomData.SamplesPerPixel = 3) then + MakePlanar(lsBuffer,lDICOMdata); + if (lMosX > 1) or (lMosY > 1) then begin + DeMosaic(lsBuffer,lmosX,lmosY,lMosaicSlices,lFlipMosaic,lDICOMdata); + lSliceBytesOut :=lAHdr.dim[1]*lAHdr.dim[2]*lAHdr.dim[3]*trunc(((lDicomData.Allocbits_per_pixel)+7)/8); + end else + FlipTB(lDICOMdata,lsBuffer); + + if lVolSave then begin{save entire volume} + Move(lsBuffer^,lvBuffer^[lvolOffset],lSliceBytesOut); + lVolOffset := lVolOffset + lSliceBytesOut; + end else begin //save slice-by-slice + Filemode := 2; //read and write + BlockWrite(lOutF, lsBuffer^, lSliceBytesOut); + end; *) + end else begin + dcmMsg('Serious error with file '+ extractfilename(lDicomImgName)); + lReadOK := false; + end; //if JPEG else if UNCOMPRESSED else ERROR + if lReadOK then begin + {$IFDEF ENDIAN_BIG} + if odd(lDICOMdata.little_endian) then UnswapEndian (lsBuffer, lSliceBytes, lAHdr.bitpix); + {$ELSE} + if not odd(lDICOMdata.little_endian) then UnswapEndian (lsBuffer, lSliceBytes, lAHdr.bitpix); + {$ENDIF} + + lDicomData.XYZdim[4] := lAHdr.dim[4]; //do this now - depending on slice order DicomData can be first or last volume + if (lDICOMdata.file4D) and (lPrefs.Swizzle4D) then + SwapTime(lDICOMdata,lsBuffer);//data is stored X,Y,T,Z - swap to X,Y,Z,T + lSliceBytesOut := lSliceBytes; + if (lIntenScaleVaries) then begin + + MakeFloat(lsBuffer,lDICOMdata, lSliceBytesOut); + //lByteSwap := false; //Un-swapped during conversion + end; + if (lDICOMdata.PlanarConfig = 0) and (lDicomData.SamplesPerPixel = 3) then + MakePlanar(lsBuffer,lDICOMdata); + if (lMosX > 1) or (lMosY > 1) then begin + DeMosaic(lsBuffer,lmosX,lmosY,lMosaicSlices,lFlipMosaic,lDICOMdata); + lSliceBytesOut :=lAHdr.dim[1]*lAHdr.dim[2]*lAHdr.dim[3]*trunc((lAHdr.bitpix+7)/8); + end else + FlipTB(lDICOMdata,lsBuffer); + //ShowMsg(inttostr(lAHdr.HdrSz)+'x'+inttostr(lDICOMdata.little_endian)+' : '+ inttostr(lsBuffer^[lSliceBytes-1])+' '+inttostr(lsBuffer^[lSliceBytes-2])+' '+inttostr(lsBuffer^[lSliceBytes-3])+' '+inttostr(lsBuffer^[lSliceBytes-4])+' '+inttostr(lsBuffer^[lSliceBytes-6])+' '+inttostr(lsBuffer^[lSliceBytes-7])); + if (not lPrefs.PlanarRGB) then + MakePackedTriplet(lsBuffer,lDICOMdata); + //msg(inttostr(lSliceBytesOut)+ ' '+inttostr(lAHdr.dim[1]*lAHdr.dim[2]*lAHdr.dim[3]*trunc((lAHdr.bitpix+7)/8))); + //lSliceBytesOut :=lAHdr.dim[1]*lAHdr.dim[2]*lAHdr.dim[3]*trunc((lAHdr.bitpix+7)/8); + if lVolSave then begin{save entire volume} + Move(lsBuffer^,lvBuffer^[lvolOffset],lSliceBytesOut); + lVolOffset := lVolOffset + lSliceBytesOut; + end else begin //save slice-by-slice + Filemode := 2; //read and write + BlockWrite(lOutF, lsBuffer^, lSliceBytesOut); + end; + end; //if lReadOK + end; + freemem(lsBuffer); + Filemode := 2; //read and write + lOutImgNameGZ := lOutImgName; + if lPref.TxtReport then + SaveTextReport(lOutImgName, lDICOMdata, lAHdr,lDTIdir); + if lVolSave then begin{save slice-by-slice} + lOutImgNameGZ := SaveNIfTICore (lOutImgName, lvBuffer, lVolOffsetInit, lAHdr, lPref) + end else //data saved slice by slice + CloseFile(lOutF); + //if (lPref.StartClip > 0) or (lPref.EndClip > 0) then + // Clip4D(lOutHdrName, lAHdr, false,lPref.SPM2,lPref.SingleNIIFile,lPref.GZip, true, lPref.StartClip,lPref.EndClip); + + if lDTIdir > 1 then begin + //bvec file + lStart := -1;//ensure this is a DTI image - some scans must have a bvalue > 1 + for lIndex := 1 to lDTIdir do + if lDTIra[lIndex].bval = 0 then + lStart := lIndex; + if lStart < 1 then begin + dcmMsg('* Warning: diffusion acquisition does not have b-0 image'); + PartialAcquisitionError; + end; + lStart := -1;//ensure this is a DTI image - some scans must have a bvalue > 1 + for lIndex := 1 to lDTIdir do + if lDTIra[lIndex].bval > 0 then + lStart := lIndex; + + if lStart > 0 then begin + lStart := 1; + lEnd := lDTIdir; + lOutDTIname := lOutImgName; + dcmMsg('Number of diffusion directions = '+inttostr(lDTIdir)); + if lDicomData.ManufacturerID = kSiemensID then begin + if lDicomData.Vers0018_1020 = 13 then + dcmMsg(' *Warning: some Siemens VB13 set DiffusionGradientDirection incorrectly. Please check manually validate'); + if lDicomData.Vers0018_1020 >= lPrefs.SiemensDTINoAngulationCorrectionIf00181020atleast then begin + dcmMsg('Note: detected Siemens Software version [0018:1020] = '+inttostr(lDicomData.Vers0018_1020) ); + dcmMsg(' -Will use 0019:000E or 0019:100E instead of 0029:1020 if version >= ' +inttostr(lPrefs.SiemensDTIUse0019If00181020atleast)); + dcmMsg(' -Will stack across Acquisitions if version >=' +inttostr(lPrefs.SiemensDTIStackIf00181020atleast)); + dcmMsg(' -No slice angulation correction of vectors if version >=' +inttostr(lPRefs.SiemensDTINoAngulationCorrectionIf00181020atleast)); + dcmMsg(' To adjust, edit '+IniName ); + SiemensFlipYBvecs(lDTIra,lDTIdir) + end else + siemensPhilipsCorrectBvecs(lDicomData,lDTIra,lDTIdir, lFlipMosaicMatrix); + end else if lDicomData.ManufacturerID = kPhilipsID then begin + //-->PhilipsCorrectBvecs(lDicomData,lDTIra,lDTIdir); + siemensPhilipsCorrectBvecs(lDicomData,lDTIra,lDTIdir,false); + //next: philips scans can include DWI images with bval>0 and v1=0,v2=0,v3=0 - we want to exclude these + //for lIndex := lDTIdir downto 1 do + // msg(inttostr(lIndex)+ kTab+floattostr(lDTIra[lIndex].bval)+kTab+floattostr(lDTIra[lIndex].v1)+kTab+floattostr(lDTIra[lIndex].v2)+kTab+floattostr(lDTIra[lIndex].v3)); + for lIndex := lDTIdir downto 1 do + if (lDTIra[lIndex].bval = 0) or (lDTIra[lIndex].v1 <> 0) or (lDTIra[lIndex].v2 <> 0) or (lDTIra[lIndex].v3 <> 0) then + lStart := lIndex; + for lIndex := 1 to lDTIdir do + if (lDTIra[lIndex].bval = 0) or (lDTIra[lIndex].v1 <> 0) or (lDTIra[lIndex].v2 <> 0) or (lDTIra[lIndex].v3 <> 0) then + lEnd := lIndex; + + + if ((lStart >1) or (lEnd < lDTIdir)) and (lStart <= lEnd) then begin + if lVolSave then {save slice-by-slice} + lOutDTIname := SaveNIfTICoreCrop (lOutImgName, lvBuffer, lVolOffsetInit,lStart-1,lDTIdir-lEnd, lAHdr, lPref) + else + lOutDTIname := Clip4D(lOutHdrName, lAHdr, false,lPref, lStart-1,lDTIdir-lEnd); + //lOutDTIname := Clip4D(lOutHdrName, lAHdr, false,lPref.SPM2,lPref.SingleNIIFile,lPref.GZip, false, lStart-1,lDTIdir-lEnd); + //Msg(lOutDTIName); + dcmMsg('Removed DWI from DTI scan - saving volumes '+inttostr(lStart)+'..'+inttostr(lEnd)); + end;//exclude scans + end else if lDicomData.ManufacturerID = kGEID then + GECorrectBvecs(lDicomData,lDTIra,lDTIdir) + else + dcmMsg('WARNING: Unkown manufacturer - DTI BVecs are probably incorrect.');//beta software + if lStart <= lEnd then begin + //create output vectors + if lOutDTIname <> '' then begin //image file created + lOutDTIname := changefileextX(lOutDTIname,'.bvec'); + assignfile(lTextF,lOutDTIname); + Filemode := 0; + rewrite(lTextF); + for lSeries := lStart to lEnd do + Write(lTextF,floattostr(lDTIra[lSeries].v1)+ ' '); + Writeln(lTextF); + for lSeries := lStart to lEnd do + Write(lTextF,floattostr(lDTIra[lSeries].v2)+ ' '); + Writeln(lTextF); + for lSeries := lStart to lEnd do + Write(lTextF,floattostr(lDTIra[lSeries].v3)+ ' '); + Writeln(lTextF); + closefile(lTextF); + //create bvals + lOutDTIname := changefileextX(lOutDTIname,'.bval'); + assignfile(lTextF,lOutDTIname); + Filemode := 0; + rewrite(lTextF); + for lSeries := lStart to lEnd do + Write(lTextF,inttostr(lDTIra[lSeries].bval)+' '); + Writeln(lTextF); + closefile(lTextF); + end;// if lOutDTIname <> '' then begin //image file created + end; //lStart <= lEnd + end; //some bvals > 0 + end; //DTIdir + + if lVolSave then //do this AFTER DTI extraction - allows rapid cropping of Philips DTI + Freemem ( lvBuffer) + else begin + if ((not lPref.FourD) and (lAHdr.dim[4] > 1)) or ((lPref.SingleNIIFile) and (lPref.Gzip)) then begin + ChangeNIfTISubformat(lOutHdrName, lAHdr,lPref) ; + end; + end; //slice-by-slice + (*if lIntenscaleVaries then begin + beep; + Msg('Intensity scale/slope or bit-depth varies across slices: perhaps convert with MRIcro.'); + end;*) + if (lPref.enablereorient) and (lDicomData.XYZdim[2] > lPref.MinReorientMatrix) and (lDicomData.XYZdim[1] > lPref.MinReorientMatrix) and (lAHdr.dim[3] > 64) and (lAHdr.dim[4] < 2) then begin + lOutImgName := Reorient(lOutImgNameGZ,lAHdr,lPref,false,false); + if (lOutImgName <> '') and (lDicomData.TE < 25) and (lDicomData.TE > 0) then //T1 image + CropNIfTI(lOutImgName,lPref); + end; + result := true; + Filemode := 0; //ReadONly + ExitCode := 0; +end; + +end. diff --git a/dcm2nii/convert.ppu b/dcm2nii/convert.ppu new file mode 100644 index 0000000..82241bc Binary files /dev/null and b/dcm2nii/convert.ppu differ diff --git a/dcm2nii/convertsimple.o b/dcm2nii/convertsimple.o new file mode 100644 index 0000000..5e05cb3 Binary files /dev/null and b/dcm2nii/convertsimple.o differ diff --git a/dcm2nii/convertsimple.pas b/dcm2nii/convertsimple.pas new file mode 100755 index 0000000..9a2c454 --- /dev/null +++ b/dcm2nii/convertsimple.pas @@ -0,0 +1,258 @@ +unit convertsimple; +{$H+} +interface +uses +{$IFDEF FPC}gzio2, {$ENDIF} +define_types,SysUtils,dicomtypes,filename,nii_4dto3d,niftiutil,nii_orient, nii_crop,GraphicsMathLibrary,prefs; +//function ConvertSimple2NII ({var} lInFilename, lOutDir: string; var lPrefs: TPrefs): boolean; +function FDF( lFName: string; var lDcm: DicomData {; var lByteSwap: boolean}): boolean; + +implementation +uses dialogsx,dialogs_msg; + +procedure ReadlnX (var F: TextFile; var lResult: string); +//Replicates Readln, but works for Unix files... Delphi 4's readln fails for non-MSDOS EOLs +var + lCh: char; +begin + lResult := ''; + while not Eof(F) do begin + Read(F, lCh); + if (lCh in [#10,#13]) then begin + if lResult <> '' then begin + //Showmessage(lResult); + exit; + end; + end else + lResult := lResult + lCh; + end; +end; //ReadlnX + +function ParseStr(lPattern: string; var lSample: string): integer; +begin + + result := Pos(lPattern,lSample); + + if result < 1 then + exit; + //Msg('*'+lPattern+'*'+inttostr(result)+'*'+lSample+'*'); + result := result+length(lPattern);//end of pattern + lSample := trim(copy(lSample,result,length(lSample)+1-result)); +end; + +procedure ExtractFloats(lSample: string; var V1,V2,V3: double); +var + lCh: char; + lStr: string; + lP,lL,lN: integer; +procedure RetireStr; +begin + if lStr = '' then exit; + inc(lN); + case lN of + 1: V1 := strtofloat(lStr); + 2: V2 := strtofloat(lStr); + 3: V3 := strtofloat(lStr); + else exit; + end; + lStr := ''; +end; +begin + V1:= 1; V2 := 1; V3 := 1; + lL := length(lSample); + if lL < 1 then + exit; + decimalseparator := '.'; + lP := 1; + lN:= 0; + lStr := ''; + while lP <= lL do begin + lCh := lSample[lP]; + if lCh in ['-','.','0'..'9'] then + lStr := lStr + lCh + else + retireStr; + inc(lP); + end; + RetireStr; +end; + +procedure ExtractFloats10x(lSample: string; var V1,V2,V3: double); +//cm to mm +begin + ExtractFloats(lSample, V1,V2,V3); + V1 := V1 * 10; + V2 := V2 * 10; + V3 := V3 * 10; +end; + +procedure ExtractInts(lSample: string; var V1,V2,V3: integer); +var + F1,F2,F3: double; +begin + //Msg('*'+lSample+'*'); + ExtractFloats(lSample, F1,F2,F3); + V1 := round(F1); + V2 := round(F2); + V3 := round(F3); + //dcmMsg(inttostr(V1)+','+inttostr(V2)+','+inttostr(V3)); + +end; + +procedure ReportHeader (lFormatName: string; var lDicomData: dicomdata); +const + kCR = '; '; +begin + dcmMsg (lFormatName + +kCR+ ' Slice Number:'+inttostr(lDicomData.ImageNum) + +kCR+ 'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+ 'XYZ position: ' +floattostr(lDicomData.PatientPosX)+'/'+floattostr(lDicomData.PatientPosY)+'/'+floattostr(lDicomData.PatientPosZ) + +kCR+'Data offset: ' +inttostr(lDicomData.ImageStart) + +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'TR: '+floattostrf(lDicomData.TR,ffFixed,8,2) ); +end; + +function CMFOV2MM( lCMFOV,lMatrix: double): double; +begin + if lMatrix > 0 then + result := lCMFOV*10 / lMatrix; +end; +(*Reads Varian FDF images (FDF = Flexible Data Format). +Varian MRI FDF reader http://www.mathworks.com/matlabcentral/fileexchange/7449 +Multi_FDF_Opener.java - http://rsbweb.nih.gov/ij/plugins/multi-opener.html + char *spatial_rank = "2dfov"; + if 3dfov then matrix will have three elements + if 3dfov then span will have three elements + int bigendian + float matrix[] = {512, 512}; + float bits = 32; + float span[] = {4.000000, 4.000000}; + byte offset of image data is = file.length - xdim*ydim*zdim*bits/8; + Appears only 32-bit float data... *) + + +function Deblank (lInStr: string): string; +var + lLen,lPos: integer; +begin + result := ''; + lLen := length(lInStr); + if lLen < 1 then + exit; + for lPos := 1 to lLen do + if lInStr[lPos] in ['=',',','[',']','+','-','.','\','~','/', '0'..'9','a'..'z','A'..'Z'] then + result := result +lINStr[lPos]; +end; + +function FDF( lFName: string; var lDcm: DicomData): boolean; +//Note - some Varian scanners put in more white space between text than others... +// "float bits=" versus "float bits=" +//Therefore we deblank the data text to remove whitespace +VAR + ltextfile: textfile; + lLine: string; + lFileSz,num: integer; + junk1f,junk2f,junk3f: double; + junk1,junk2: integer; + lDone,lSliceNum: boolean; +begin + result := false; + lFileSz := FSize(lFName); + if lFileSz < 1{not fileexists (lFName)} then begin + dcmMsg('Can not find file '+lFName); + exit; + end; + FileMode := 0; { Set file access to read only } + AssignFile(ltextfile, lFName); + Reset(ltextfile); + lDone := false; + num := 1; + lSliceNum := false; + repeat + readlnx(ltextfile,lLine); + //lLine := trim(lLine);//remove leading/following characters + lLine := deblank(lLine);//remove leading/following characters + //dcmdcmdcmdcmMsg(lLine); + if ParseStr('floatbits=', lLine) > 0 then + ExtractInts(lLine, lDcm.Allocbits_per_pixel ,junk1,junk2); + if ParseStr('intslice_no', lLine) > 0 then begin + lSliceNum := true; + ExtractInts(lLine, lDcm.ImageNum ,junk1,junk2); + end; + if ParseStr('floatlocation[]=', lLine) > 0 then + ExtractFloats10x(lLine, lDcm.PatientPosX,lDcm.PatientPosY,lDcm.PatientPosZ); + if ParseStr('floatmatrix[]=', lLine) > 0 then + ExtractInts(lLine, lDcm.XYZdim[1],lDcm.XYZdim[2],lDcm.XYZdim[3]); + if ParseStr('floatspan[]=', lLine) > 0 then + ExtractFloats(lLine, lDCm.XYZmm[1],lDcm.XYZmm[2],lDcm.XYZmm[3]); + if ParseStr('floatTR=', lLine) > 0 then begin + ExtractFloats(lLine, junk1f,junk2f,junk3f); + lDcm.TR := junk1f/1000; //convert TR in msec to time in sec + end; + {if strmatch('intbigendian', line) then + machineformat = 'ieee-le'; % New Linux-based} + num := num + 1; + if num > 41 then + lDone := true; + until lDone; + if lDcm.Allocbits_per_pixel = 32 then begin + result := true; + lDcm.FloatData := true; + end else begin + dcmMsg('Unsupported datatype: '+inttostr( lDcm.Allocbits_per_pixel)+ 'bits per pixel '+lFName); + end; + if not lSliceNum then begin + ExtractInts(lFName, lDcm.ImageNum ,junk1,junk2); + end; + //next - convert field of view in cm to voxel size in mm... + for num := 1 to 3 do + lDCm.XYZmm[num] := CMFOV2MM( lDCm.XYZmm[num],lDcm.XYZdim[num]); + lDcm.Little_Endian := 0; + lDcm.ImageStart := lFileSz - (lDcm.XYZdim[1]*lDcm.XYZdim[2]*lDcm.XYZdim[3]*(round(lDcm.Allocbits_per_pixel/8))); + if lDcm.ImageStart < 10 then + result := false; + if result then + ReportHeader('Varian FDF',lDcm); + CloseFile(ltextfile); + FileMode := 2; +end; + + +(*function Raw2NIfTI(lHdrName: string; var lHdr: TNIFTIhdr; lPrefs: TPrefs; lByteSwap: boolean): boolean; +//like ChangeNIfTISubformat except we use the passed lHdrdata... +var + lImgBuffer: byteP; + lImgOffset: integer; + lOutImgName: string; + //lByteSwap: boolean; +begin + result := false; + if not NIFTIhdr_LoadImgRaw (false,lHdrName, lHdr, lImgBuffer, lImgOffset,lByteSwap) then exit; + dcmMsg('Converting to NIfTI '+lHdrName); + lOutImgName := ChangeFilePrefix (lHdrName,'c'); + if lPrefs.CustomRename then + CustomFilename(lOutImgName); + if SaveNIfTICore (lOutImgName, lImgBuffer, lImgOffset+1, lHdr, lPrefs,lByteSwap) ='' then exit; + Freemem(lImgBuffer); + result := true; //11/2007 + ExitCode := 0; +end; + + +function ConvertSimple2NII ({var} lInFilename , lOutDir: string; var lPrefs: TPrefs): boolean; +//this is simple, but does not stack 2d slices into 3d volumes... +var + lDcm: DicomData; + lHdr: TNIFTIhdr; + lBigEndian: boolean; +begin + result := false; + NIFTIhdr_ClearHdr(lHdr); + dcmMsg('WARNING: no image orientation matrix for '+lInFilename); + if not FDF (lInFilename,lDcm) then exit; + DICOM2AnzHdr (lHdr, false,lInFilename,lDcm); + //Raw2NIfTI(lInFilename,lHdr,lPrefs,true); +end; *) + +end. \ No newline at end of file diff --git a/dcm2nii/convertsimple.ppu b/dcm2nii/convertsimple.ppu new file mode 100644 index 0000000..16884a9 Binary files /dev/null and b/dcm2nii/convertsimple.ppu differ diff --git a/dcm2nii/csaread.o b/dcm2nii/csaread.o new file mode 100644 index 0000000..dcb0e36 Binary files /dev/null and b/dcm2nii/csaread.o differ diff --git a/dcm2nii/csaread.pas b/dcm2nii/csaread.pas new file mode 100755 index 0000000..e1f4500 --- /dev/null +++ b/dcm2nii/csaread.pas @@ -0,0 +1,405 @@ +unit csaread; +interface +// Extract vital details from the Siemens CSA header that is contained within a DICOM file. +// This is DICOM group:element (0029:1010) [CSA Image Header Info] +// These values are crucial converting 2D mosaics to 3D images and computing DTI vectors +//see http://nipy.sourceforge.net/nibabel/dicom/siemens_csa.html +// This is a port of John Ashburners' spm_dicom_headers.m Matlab code +uses SysUtils, dialogsx, define_types,dialogs_msg, nifti_hdr, nifti_types; +{DEFINE verbose} +{$H+} +type + TBytearray = array of byte; + TSliceTimes = array of single; + TCSA = record + PhaseDirectionPositive: integer; //0 or 1, -1 for unknown + Slices,MosaicX,MosaicY: longword; + BandwidthPerPixelPhaseEncode, + Bvalue,DTIv1,DTIv2,DTIv3, SliceNormV1, SliceNormV2,SliceNormV3: double; + CustomerSeq: string; + //SliceTimes : array of single; + end; + + +function DecodeCSA2 (lFilename: string; lCSAImageHeaderInfoPos, lCSAImageHeaderInfoSz: integer; var lCSA: TCSA; var lSliceTimes: TSliceTimes; var lFlippedMosaic: boolean): boolean; + +function GetCSASeriesHeaderInfo (lFilename: string; lStart, lLength, lnSlices: integer; var lSliceOrder: integer): string; + +function GetCSAImageHeaderInfoDTI (lFilename: string; lStart,lLength: integer; var lBval: integer; var ldti1,ldti2,ldti3: double): boolean; +function GetCSAImageHeaderInfo (lFilename: string; lStart,lLength: integer; var lMosaicSlices,lMosaicX,lMosaicY: integer; var lv1,lv2,lv3: double): boolean; + + +implementation + +function GetCSAImageHeaderInfoDTI (lFilename: string; lStart,lLength: integer; var lBval: integer; var ldti1,ldti2,ldti3: double): boolean; +var + lCSA: TCSA; + lFlippedMosaic: boolean; + lSliceTimes: TSliceTimes ; +begin + //lBval := -1;//imposibble - read error + result := DecodeCSA2 (lFilename, lStart,lLength, lCSA, lSliceTimes, lFlippedMosaic); + lSliceTimes := nil; //free + if not result then exit; + lBval := round(lCSA.bvalue); + ldti1 := lCSA.DTIv1; + ldti2 := lCSA.DTIv2; + ldti3 := lCSA.DTIv3; + if (abs(ldti1) > 0.9) and (abs(ldti2) > 0.9) and (abs(ldti3) > 0.9) then + lBval := 0; //syngo MR 2004A 4VA25A CSA header reports Bval=1000 for B0 images, use vectors to detect if this is a B0 image + +end; + +function GetCSAImageHeaderInfo (lFilename: string; lStart,lLength: integer; var lMosaicSlices,lMosaicX,lMosaicY: integer; var lv1,lv2,lv3: double): boolean; +var + lCSA: TCSA; + lSliceTimes: TSliceTimes; + lFlippedMosaic: boolean; +begin + //lMosaicSlices := -1;//imposibble - read error + result := DecodeCSA2 (lFilename, lStart,lLength, lCSA,lSliceTimes, lFlippedMosaic); + lSliceTimes := nil; //free + if not result then exit; + lMosaicSlices := lCSA.Slices; + lMosaicX := lCSA.MosaicX; + lMosaicY := lCSA.MosaicY; + lv1 := lCSA.SliceNormV1; + lv2 := lCSA.SliceNormV2; + lv3 := lCSA.SliceNormV3; //5/5/2013 +end; + +function DecodeCSA2 (lFilename: string; lCSAImageHeaderInfoPos, lCSAImageHeaderInfoSz: integer; var lCSA: TCSA; var lSliceTimes: TSliceTimes; var lFlippedMosaic: boolean): boolean; +//provided with DICOM file as well as location and size of CSA header, this code returns the Siemens CSA header information + +const + kMaxItem = 1024; // if you only need first 3 values, set to 4 so if an item has 6 values the final ones will overwrite 4th item +type + TCSAtag = record + name : string[64]; + vm: longint; + vr123: string[3]; + vr4: string[1]; + syngodt ,nitems,xx : longint; + end; + TCSAitem = record + xx1, xx2_Len, xx3_77, xx4: longint; // [ x L 77 x] L is length + value: string; + end; +var + lFile : File; + lVers: string; + lData : array of byte; + lnTag,lPos,lI,lT,lIbound: integer; + lTag : TCSAtag; + lItem : array [1..kMaxItem] of TCSAitem; +function SafeStr2Num (lStr: string): boolean; //for some reason, many fMRI images have bvalue = 'X1_01_001 +var + lP,lL: integer; +begin + result := false; + lL := length(lStr); + if lL < 1 then exit; + for lP := 1 to lL do + if not(lStr[lP] in ['+','-','0'..'9','.','e','E']) then + exit; + result := true; +end;//nested func SafeStr2Num +function RightStr2Num (lStr: string): integer; //e.g. Siemens AcquisitionMatrixText "104p*96" -> "96" +var + lL: integer; + lS: string; + lDone: boolean; +begin + result := -1; + lS := ''; + lL := length(lStr); + if lL < 1 then exit; + lDone := false; + while (lL >= 1) and (not lDone) do begin + if (lStr[lL] in ['+','-','0'..'9','.','e','E']) then + lS := lStr[lL]+lS + else if lS <> '' then + lDone := true; + dec(lL); + end; + if lS = '' then exit; + result := strtoint(lS); +end; //nested func RightStr2Num +function LeftStr2Num (lStr: string): integer; //e.g. Siemens AcquisitionMatrixText "104p*96" -> "104" +var + lP,lL: integer; + lS: string; + lDone: boolean; +begin + result := -1; + lS := ''; + lL := length(lStr); + if lL < 1 then exit; + lP := 1; + lDone := false; + while (lP <= lL) and (not lDone) do begin + if (lStr[lP] in ['+','-','0'..'9','.','e','E']) then + lS := lS + lStr[lP] + else if lS <> '' then + lDone := true; + inc(lP); + end; + if lS = '' then exit; + result := strtoint(lS); +end; //nested func LeftStr2Num +function freadStr(len: integer): string; +var + i: integer; +begin + if (len+lPos) >= lCSAImageHeaderInfoSz then + Raise Exception.CreateFmt('csaread: corrupt file ', [lFilename]); + result := ''; + i := 0; + while (i < len) and (lData[i+lPos] <> 0) and (lData[i+lPos] <> $20) do begin + result := result + chr(lData[i+lPos]); + inc(i); + end; + lPos := lPos + len; +end; //nested func freadStr +function freaduint32: longword; overload; //uint32 +begin + if (4+lPos) >= lCSAImageHeaderInfoSz then + Raise Exception.CreateFmt('csaread: corrupt file ', [lFilename]); + result := (lData[lPos+3] shl 24)+(lData[lPos+2] shl 16)+(lData[lPos+1] shl 8)+lData[lPos]; + lPos := lPos + 4; +end;//nested func freaduint32 +function freadint32: longint; overload; //uint32 +begin + if (4+lPos) >= lCSAImageHeaderInfoSz then + Raise Exception.CreateFmt('csaread: corrupt file ', [lFilename]); + result := (lData[lPos+3] shl 24)+(lData[lPos+2] shl 16)+(lData[lPos+1] shl 8)+lData[lPos]; + lPos := lPos + 4; +end;//nested func freadint32 +function freadTag: TCSAtag; +begin + result.name := freadStr(64); + result.vm:= freadint32; + result.vr123:= freadStr(3); + result.vr4:= freadStr(1); + result.syngodt := freadint32; + result.nitems := freadint32; + result.xx := freadint32; +end;//nested func freadTag +function freadItem: TCSAitem; +begin + result.xx1:= freadint32; + result.xx2_Len:= freadint32; + result.xx3_77:= freadint32; + result.xx4:= freadint32; + result.value := freadStr(result.xx2_len); + lPos := lPos + ((4-(result.xx2_len) mod 4 )mod 4) ; +end;//nested func freadItem +begin //main function DecodeCSA2 + lFlippedMosaic := false; + result := false; + lSliceTimes := nil; //clear + lCSA.CustomerSeq := ''; //clear + lCSA.Bvalue := -1; + lCSA.PhaseDirectionPositive := -1; + if (lCSAImageHeaderInfoSz < 1) then + exit; + if FSize(lFilename) <= (lCSAImageHeaderInfoPos+lCSAImageHeaderInfoSz) then + exit; + if lCSAImageHeaderInfoSz < 118 then + exit; //Too short to be a CSA header - Perhaps Philips or GE is using this tag + setlength(lData, lCSAImageHeaderInfoSz); + lPos := 0; + FileMode := fmOpenRead; + AssignFile(lFile, lFilename); + Reset(lFile, 1); // Now we define one record as 1 byte + Seek(lFile, lCSAImageHeaderInfoPos); // Records start from 0 + BlockRead(lFile, lData[0], lCSAImageHeaderInfoSz); + CloseFile(lFile); + lVers := freadStr(4); + if lVers = 'SV10' then begin + //read header + lPos := lPos + 4; //skip 8 bytes of data, spm_dicom_headers refers to these as unused1 and unused2 + lnTag := freaduint32; + if (lnTag < 1) or (lnTag > 1024) then begin + dcmMsg('Error reading CSA header'); + exit; + end; + if (lData[lPos] <> 77) then showmsg('warning: strange CSA2 header'); + lPos := lPos + 4; // skip the four bytes 77 00 00 00 + //read tags + for lT := 1 to lnTag do begin + lTag := freadTag; + if lTag.nitems > 0 then begin + for lI := 1 to lTag.nitems do begin //read items + if lI > kMaxItem then + lIbound := kMaxItem //out of range + else + lIbound := lI; + lItem[lIbound] := freadItem; + end; //for each item + if (lTag.name = 'NumberOfImagesInMosaic') then + lCSA.Slices := round(strtofloat(lItem[1].value)) + else if (lTag.name = 'AcquisitionMatrixText') then begin //'96p*96 -> X= 96 and Y= 96 + lCSA.MosaicX := LeftStr2Num(lItem[1].value); + lCSA.MosaicY := RightStr2Num(lItem[1].value); + end else if (lTag.name = 'B_value') and (SafeStr2Num(lItem[1].value)) then begin + lCSA.Bvalue := strtofloat(lItem[1].value); + //dcmmsg('Bvalue = '+floattostr(lCSA.Bvalue)); + end + else if (lTag.name = 'DiffusionGradientDirection') and (SafeStr2Num(lItem[1].value)) and (SafeStr2Num(lItem[2].value)) and (SafeStr2Num(lItem[3].value)) then begin + lCSA.DTIv1 := strtofloat(lItem[1].value); + lCSA.DTIv2 := strtofloat(lItem[2].value); + lCSA.DTIv3 := strtofloat(lItem[3].value); + end else if (lTag.name = 'SliceNormalVector') and (SafeStr2Num(lItem[1].value)) and (SafeStr2Num(lItem[2].value)) and (SafeStr2Num(lItem[3].value)) then begin + lCSA.SliceNormV1 := strtofloat(lItem[1].value); + lCSA.SliceNormV2 := strtofloat(lItem[2].value); + lCSA.SliceNormV3 := strtofloat(lItem[3].value); + //fx( lCSA.SliceNormV3,1234); + end else if (lTag.name = 'SliceMeasurementDuration') and (SafeStr2Num(lItem[1].value)) then begin + lCSA.BandwidthPerPixelPhaseEncode := strtofloat(lItem[1].value); + {$IFDEF verbose} msg('SliceMeasurementDuration: '+floattostr(lCSA.BandwidthPerPixelPhaseEncode)); {$ENDIF} + end else if (lTag.name = 'BandwidthPerPixelPhaseEncode') and (SafeStr2Num(lItem[1].value)) then begin + lCSA.BandwidthPerPixelPhaseEncode := strtofloat(lItem[1].value); + {$IFDEF verbose} msg('BandwidthPerPixelPhaseEncode: '+floattostr(lCSA.BandwidthPerPixelPhaseEncode)); {$ENDIF} + end else if (lTag.name = 'MosaicRefAcqTimes') and (lTag.nitems > 1) and (SafeStr2Num(lItem[1].value)) then begin + //showmsg(lTag.name+ '-> '+inttostr(lTag.nitems)); + setlength(lSliceTimes,lTag.nitems); + for lI := 1 to lTag.nitems do + if SafeStr2Num(lItem[lI].value) then + lSliceTimes[lI-1] := strtofloat(lItem[lI].value); + end else if (lTag.name = 'ProtocolSliceNumber') and (lTag.nitems > 0) and (SafeStr2Num(lItem[1].value)) then begin + if SafeStr2Num(lItem[1].value) and (strtofloat(lItem[1].value) > 0) then lFlippedMosaic := true; + end else if (lTag.name = 'PhaseEncodingDirectionPositive') and (lTag.nitems > 0) and (SafeStr2Num(lItem[1].value)) then begin + lCSA.PhaseDirectionPositive := round(strtofloat(lItem[1].value)); + end; + + + + // else dcmmsg(lTag.name+ '-> '+inttostr(lTag.nitems)); + // dcmmsg(lTag.name+ '-> '+inttostr(lTag.nitems)); + + (*if (lTag.name = 'EchoLinePosition') and (SafeStr2Num(lItem[1].value)) then begin + lCSA.BandwidthPerPixelPhaseEncode := strtofloat(lItem[1].value); + msg('EchoLinePosition: '+floattostr(lCSA.BandwidthPerPixelPhaseEncode)); + end;*) + if (SafeStr2Num(lItem[1].value)) then begin + lCSA.BandwidthPerPixelPhaseEncode := strtofloat(lItem[1].value); + {$IFDEF verbose} msg(lTag.name+' '+inttostr(lTag.nitems)+' '+floattostr(lCSA.BandwidthPerPixelPhaseEncode)); {$ENDIF} + end; + //if true then begin //(lTag.name = 'sSliceArray.ucMode') then begin + // showmsg(lTag.name+'xxxxxxxxxx'+lItem[1].value); + + // end; ; + + end;//at least one item + end; //for each tag + result := true; + //showmsg('Success DecodeCSA2'); + end else begin + dcmMsg('CSAread Warning: '+ lFilename +' at byte '+inttostr(lCSAImageHeaderInfoPos)+' reports version "'+lVers+'": only "SV10" format is supported: image is either corruprted, very old or new. See if a new version of this software is available.'); + end; + //Showmsg('CSA done, final tag '+lTag.name+' CSA started at '+inttostr(lCSAImageHeaderInfoPos)+' CSA length of '+inttostr(lCSAImageHeaderInfoSz)+' formal CSA ended at @ '+inttostr(lPos)); + lData := nil; +end;// func DecodeCSA2 + +function GetCSASeriesHeaderInfo (lFilename: string; lStart,lLength, lnSlices: integer; var lSliceOrder: integer): string; +var + lData: array of byte; + lFile : File; +function str2str (lStr: string): string; +var + lPos,lOK, lStrLen,lDataLen: integer; + lS: string; +begin + result := ''; //is failure + lStrLen := length(lStr); + lDataLen := lLength-lStrLen-1; //-1 since data must be at least 1 byte + lPos := 1; + lOK := 0; + while lPos < lDataLen do begin + lOK := 0; + while (chr(lData[lPos+lOK]) = lStr[lOK+1]) do begin + inc(lOK); + if (lOK = lStrLen) then begin + lS := '0'; + lPos := lPos + lOK + 1; + while (lPos <= lLength) and (lData[lPos] <> 10) and (lData[lPos] <> ord('"')) do begin // end of line is 0x0A = 10 + if (lData[lPos] <> ord('\')) and (lData[lPos] <> ord('/')) then + result := result + chr(lData[lPos]); + inc(lPos); + end; //while not end of line + exit; + end; //if whole string matches + end; //while character matches + lPos:= lPos + lOK + 1; + end; //while pos in less than data length +end; + +function strValue (lStr: string): integer; +//returns 4 for "sSliceArray.ucMode = 0x4" (0A ends line) +var + lPos,lOK, lStrLen,lDataLen: integer; + lS: string; +begin + result := 0; //is failure + lStrLen := length(lStr); + lDataLen := lLength-lStrLen-1; //-1 since data must be at least 1 byte + lPos := 1; + lOK := 0; + while lPos < lDataLen do begin + lOK := 0; + while (chr(lData[lPos+lOK]) = lStr[lOK+1]) do begin + inc(lOK); + if (lOK = lStrLen) then begin + lS := '0'; + lPos := lPos + lOK + 1; + while (lPos <= lLength) and (lData[lPos] <> 10) do begin // end of line is 0x0A = 10 + if chr(lData[lPos]) in ['0'..'9'] then + lS := lS + chr(lData[lPos]); + inc(lPos); + end; //while not end of line + result := strtoint(lS); + //https://wiki.cimec.unitn.it/tiki-index.php?page=MRIBOLDfMRI + //http://cbs.fas.harvard.edu/node/559#slice_order + case result of + 1: result := kNIFTI_SLICE_SEQ_INC; + 2 : result := kNIFTI_SLICE_SEQ_DEC; + 4: begin + if odd(lnSlices) then + result := kNIFTI_SLICE_ALT_INC + else begin + dcmMsg(' Warning: Siemens interleaved acquisition with an even number of slices. Assume even slices acquired PRIOR to odd slices. https://wiki.cimec.unitn.it/tiki-index.php?page=MRIBOLDfMRI'); + result := kNIFTI_SLICE_ALT_INC2; + end; + end; + else begin + dcmMsg('Warning: Unknown Siemens slice order '+inttostr(result)); + result := 0; + end; + end; //case + exit; + end; //if whole string matches + end; //while character matches + lPos:= lPos + lOK + 1; + end; //while pos in less than data length +end; + +begin + result := ''; + lSliceOrder := 0; + if (lLength < 0) then exit; + SetLength(lData,lLength); + FileMode := fmOpenRead; + AssignFile(lFile, lFilename); + Reset(lFile, 1); // Now we define one record as 1 byte + Seek(lFile, lStart); // Records start from 0 + BlockRead(lFile, lData[0], lLength); + CloseFile(lFile); + lSliceOrder := strValue('sSliceArray.ucMode'); + result := str2str ('CustomerSeq'); + //dcmMsg('*********Got it '+inttostr(lSliceOrder)); + lData := nil; +end; + +end. + diff --git a/dcm2nii/csaread.ppu b/dcm2nii/csaread.ppu new file mode 100644 index 0000000..5e7768e Binary files /dev/null and b/dcm2nii/csaread.ppu differ diff --git a/dcm2nii/dcm2nii b/dcm2nii/dcm2nii new file mode 100755 index 0000000..6637b3d Binary files /dev/null and b/dcm2nii/dcm2nii differ diff --git a/dcm2nii/dcm2nii.app/Contents/Info.plist b/dcm2nii/dcm2nii.app/Contents/Info.plist new file mode 100644 index 0000000..cd065da --- /dev/null +++ b/dcm2nii/dcm2nii.app/Contents/Info.plist @@ -0,0 +1,45 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>CFBundleDevelopmentRegion</key> + <string>English</string> + <key>CFBundleExecutable</key> + <string>dcm2nii</string> + <key>CFBundleName</key> + <string>dcm2nii</string> + <key>CFBundleIdentifier</key> + <string>com.company.dcm2nii</string> + <key>CFBundleInfoDictionaryVersion</key> + <string>6.0</string> + <key>CFBundlePackageType</key> + <string>APPL</string> + <key>CFBundleSignature</key> + <string>dcm2</string> + <key>CFBundleShortVersionString</key> + <string>0.1</string> + <key>CFBundleVersion</key> + <string>1</string> + <key>CSResourcesFileMapped</key> + <true/> + <key>CFBundleDocumentTypes</key> + <array> + <dict> + <key>CFBundleTypeRole</key> + <string>Viewer</string> + <key>CFBundleTypeExtensions</key> + <array> + <string>*</string> + </array> + <key>CFBundleTypeOSTypes</key> + <array> + <string>fold</string> + <string>disk</string> + <string>****</string> + </array> + </dict> + </array> + <key>NSHighResolutionCapable</key> + <true/> +</dict> +</plist> diff --git a/dcm2nii/dcm2nii.app/Contents/MacOS/dcm2nii b/dcm2nii/dcm2nii.app/Contents/MacOS/dcm2nii new file mode 120000 index 0000000..bdcd35a --- /dev/null +++ b/dcm2nii/dcm2nii.app/Contents/MacOS/dcm2nii @@ -0,0 +1 @@ +../../../dcm2nii \ No newline at end of file diff --git a/dcm2nii/dcm2nii.app/Contents/PkgInfo b/dcm2nii/dcm2nii.app/Contents/PkgInfo new file mode 100644 index 0000000..6f749b0 --- /dev/null +++ b/dcm2nii/dcm2nii.app/Contents/PkgInfo @@ -0,0 +1 @@ +APPL???? diff --git a/dcm2nii/dcm2nii.cfg b/dcm2nii/dcm2nii.cfg new file mode 100755 index 0000000..5d9b456 --- /dev/null +++ b/dcm2nii/dcm2nii.cfg @@ -0,0 +1,39 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-LN"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-U"..\common\;..\delphionly\" +-O"..\common\;..\delphionly\" +-I"..\common\;..\delphionly\" +-R"..\common\;..\delphionly\" diff --git a/dcm2nii/dcm2nii.compiled b/dcm2nii/dcm2nii.compiled new file mode 100755 index 0000000..9c54e40 --- /dev/null +++ b/dcm2nii/dcm2nii.compiled @@ -0,0 +1,5 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <Compiler Value="/usr/local/bin/ppcx64" Date="1393445780"/> + <Params Value=" -Px86_64 -MObjFPC -Scgi -O2 -Xs -XX -l -vewnhibq -Fu/Users/rorden/Documents/pas/mricron/common -Fu/Users/rorden/Documents/pas/mricron/dcm2nii/ dcm2nii.lpr"/> +</CONFIG> diff --git a/dcm2nii/dcm2nii.dof b/dcm2nii/dcm2nii.dof new file mode 100755 index 0000000..1026d73 --- /dev/null +++ b/dcm2nii/dcm2nii.dof @@ -0,0 +1,143 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=1 +UnsafeCode=1 +UnsafeCast=1 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath=..\common\;..\delphionly\ +Packages=Vcl40;Vclx40;VclSmp40;Qrpt40;Vcldb40;RxCtl4 +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=0 +MinorVer=9 +Release=0 +Build=1 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName=Chris Rorden +FileDescription=DICOM and PAR/REC converter +FileVersion=0.9.0.1 +InternalName= +LegalCopyright=Copyright © +LegalTrademarks= +OriginalFilename=dcm2nii.exe +ProductName=dcm2nii +ProductVersion=0.0 +Comments= +[HistoryLists\hlUnitAliases] +Count=1 +Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[HistoryLists\hlSearchPath] +Count=2 +Item0=..\common\;..\delphionly\ +Item1=..\common\ diff --git a/dcm2nii/dcm2nii.dpr b/dcm2nii/dcm2nii.dpr new file mode 100755 index 0000000..26dc125 --- /dev/null +++ b/dcm2nii/dcm2nii.dpr @@ -0,0 +1,33 @@ +program dcm2nii; +{$IFDEF FPC} +{$mode objfpc} +{$ELSE} + {$APPTYPE CONSOLE} +{$ENDIF} +{$H+} +uses + {$IFDEF UNIX} + {$IFDEF UseCThreads} cthreads, {$ENDIF} + {$ENDIF} + dialogsx,paramstrs,dicomtypes; +{$IFNDEF UNIX} +{$R *.res} +{$ENDIF} + +begin + ShowMsg(kVers); + kUseDateTimeForID := true; + {$IFNDEF TEST} + ProcessParamStrs; + {$ELSE} + Testdcm2nii; + readln; + {$ENDIF} +end. + + + + + + + diff --git a/dcm2nii/dcm2nii.ico b/dcm2nii/dcm2nii.ico new file mode 100755 index 0000000..f023db2 Binary files /dev/null and b/dcm2nii/dcm2nii.ico differ diff --git a/dcm2nii/dcm2nii.ini b/dcm2nii/dcm2nii.ini new file mode 100755 index 0000000..65f634a --- /dev/null +++ b/dcm2nii/dcm2nii.ini @@ -0,0 +1,50 @@ +[BOOL] +4D=1 +Anonymize=1 +SingleNIIFile=1 +Gzip=1 +SPM2=0 +AppendDate=0 +AppendAcqSeries=1 +AppendProtocolName=1 +AppendPatientName=0 +AppendFilename=0 +EveryFile=1 +ManualNIfTIConv=1 +AnonymizeSourceDICOM=0 +Swizzle4D=1 +Stack3DImagesWithSameAcqNum=0 +RecursiveUseNameAppend=0 +CustomRename=0 +disablereorient=0 +enablereorient=1 +createoutputfolder=0 +CollapseFolders=0 +Verbose=0 +AutoCrop=0 +fourD=1 +PhilipsPrecise=0 +UseGE_0021_104F=0 +DebugMode=0 +UntestedFeatures=0 +OrthoFlipXDim=0 +UINT16toFLOAT32=1 + +[INT] +BeginClip=0 +LastClip=0 +MinReorientMatrix=255 +RecursiveFolderDepth=5 +MaxReorientMatrix=1023 +OutDirMode=0 +IgnoreDTIRotationsIf_0002_0013_atleast=15 +IgnoreDTIRotationsIf_0018_1020_atleast=15 +SiemensDTIUse0019If00181020atleast=15 +SiemensDTINoAngulationCorrectionIf00181020atleast=1000 +SiemensDTIStackIf00181020atleast=15 +usePigz=0 + +[STR] +BackupDir= +OutDir=C:\Users\neuropsych\Documents + diff --git a/dcm2nii/dcm2nii.lpi b/dcm2nii/dcm2nii.lpi new file mode 100755 index 0000000..4a1ffab --- /dev/null +++ b/dcm2nii/dcm2nii.lpi @@ -0,0 +1,408 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <LRSInOutputDirectory Value="False"/> + </Flags> + <MainUnit Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <Units Count="36"> + <Unit0> + <Filename Value="dcm2nii.lpr"/> + <IsPartOfProject Value="True"/> + <TopLine Value="36"/> + <CursorPos X="28" Y="38"/> + <UsageCount Value="122"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit0> + <Unit1> + <Filename Value="convert.pas"/> + <UnitName Value="convert"/> + <EditorIndex Value="2"/> + <TopLine Value="1438"/> + <CursorPos X="3" Y="1440"/> + <UsageCount Value="57"/> + <Loaded Value="True"/> + </Unit1> + <Unit2> + <Filename Value="define_types.pas"/> + <TopLine Value="317"/> + <CursorPos Y="330"/> + <UsageCount Value="57"/> + </Unit2> + <Unit3> + <Filename Value="gzio2.pas"/> + <TopLine Value="1765"/> + <CursorPos X="7" Y="1784"/> + <UsageCount Value="57"/> + </Unit3> + <Unit4> + <Filename Value="dicom.pas"/> + <UnitName Value="dicom"/> + <EditorIndex Value="-1"/> + <CursorPos X="41" Y="2"/> + <UsageCount Value="57"/> + </Unit4> + <Unit5> + <Filename Value="nodialogs.pas"/> + <CursorPos X="10" Y="5"/> + <UsageCount Value="54"/> + </Unit5> + <Unit6> + <Filename Value="lsjpeg.pas"/> + <TopLine Value="393"/> + <CursorPos X="20" Y="518"/> + <UsageCount Value="56"/> + </Unit6> + <Unit7> + <Filename Value="GraphicsMathLibrary.pas"/> + <TopLine Value="61"/> + <CursorPos Y="66"/> + <UsageCount Value="54"/> + </Unit7> + <Unit8> + <Filename Value="sortdicom.pas"/> + <TopLine Value="172"/> + <CursorPos X="24" Y="188"/> + <UsageCount Value="57"/> + </Unit8> + <Unit9> + <Filename Value="filename.pas"/> + <IsPartOfProject Value="True"/> + <UsageCount Value="122"/> + </Unit9> + <Unit10> + <Filename Value="dicomtypes.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="dicomtypes"/> + <EditorIndex Value="4"/> + <TopLine Value="306"/> + <CursorPos X="102" Y="310"/> + <UsageCount Value="122"/> + <Loaded Value="True"/> + </Unit10> + <Unit11> + <Filename Value="parconvert.pas"/> + <UnitName Value="parconvert"/> + <EditorIndex Value="3"/> + <TopLine Value="689"/> + <CursorPos X="28" Y="707"/> + <UsageCount Value="57"/> + <Loaded Value="True"/> + </Unit11> + <Unit12> + <Filename Value="..\..\junk\unit1.pas"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <CursorPos X="36" Y="7"/> + <UsageCount Value="3"/> + </Unit12> + <Unit13> + <Filename Value="nii4Dto3D.pas"/> + <TopLine Value="114"/> + <CursorPos X="53" Y="125"/> + <UsageCount Value="11"/> + </Unit13> + <Unit14> + <Filename Value="dicomfast.pas"/> + <TopLine Value="4"/> + <CursorPos X="6" Y="14"/> + <UsageCount Value="11"/> + </Unit14> + <Unit15> + <Filename Value="dicomcompat.pas"/> + <UnitName Value="dicomcompat"/> + <EditorIndex Value="-1"/> + <TopLine Value="1911"/> + <CursorPos X="71" Y="1911"/> + <UsageCount Value="11"/> + </Unit15> + <Unit16> + <Filename Value="dialogsx.pas"/> + <CursorPos X="10" Y="2"/> + <UsageCount Value="11"/> + </Unit16> + <Unit17> + <Filename Value="nii_4dto3d.pas"/> + <TopLine Value="113"/> + <CursorPos X="53" Y="124"/> + <UsageCount Value="11"/> + </Unit17> + <Unit18> + <Filename Value="nii_orient.pas"/> + <CursorPos X="39" Y="2"/> + <UsageCount Value="11"/> + </Unit18> + <Unit19> + <Filename Value="nii_crop.pas"/> + <CursorPos X="6" Y="2"/> + <UsageCount Value="11"/> + </Unit19> + <Unit20> + <Filename Value="paramstrs.pas"/> + <UnitName Value="paramstrs"/> + <EditorIndex Value="-1"/> + <TopLine Value="178"/> + <CursorPos X="20" Y="182"/> + <UsageCount Value="11"/> + </Unit20> + <Unit21> + <Filename Value="readint.pas"/> + <CursorPos X="13" Y="6"/> + <UsageCount Value="10"/> + </Unit21> + <Unit22> + <Filename Value="userdir.pas"/> + <CursorPos X="31" Y="13"/> + <UsageCount Value="10"/> + </Unit22> + <Unit23> + <Filename Value="..\common\isgui.inc"/> + <EditorIndex Value="1"/> + <CursorPos X="10"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit23> + <Unit24> + <Filename Value="..\common\define_types.pas"/> + <UnitName Value="define_types"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="6"/> + <CursorPos X="61" Y="7"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit24> + <Unit25> + <Filename Value="..\common\gzio2.pas"/> + <UnitName Value="gzio2"/> + <EditorIndex Value="-1"/> + <TopLine Value="20"/> + <CursorPos X="87" Y="33"/> + <UsageCount Value="10"/> + </Unit25> + <Unit26> + <Filename Value="..\common\GraphicsMathLibrary.pas"/> + <TopLine Value="547"/> + <CursorPos X="35" Y="552"/> + <UsageCount Value="10"/> + </Unit26> + <Unit27> + <Filename Value="..\common\dialogsx.pas"/> + <TopLine Value="28"/> + <CursorPos X="16" Y="44"/> + <UsageCount Value="10"/> + </Unit27> + <Unit28> + <Filename Value="prefs.pas"/> + <UnitName Value="prefs"/> + <EditorIndex Value="5"/> + <TopLine Value="9"/> + <CursorPos X="68" Y="21"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit28> + <Unit29> + <Filename Value="..\common\userdir.pas"/> + <UsageCount Value="10"/> + </Unit29> + <Unit30> + <Filename Value="niftiutil.pas"/> + <TopLine Value="250"/> + <CursorPos Y="279"/> + <UsageCount Value="10"/> + </Unit30> + <Unit31> + <Filename Value="gui.pas"/> + <ComponentName Value="MainForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <CursorPos X="13" Y="8"/> + <UsageCount Value="10"/> + </Unit31> + <Unit32> + <Filename Value="..\..\..\..\..\..\usr\local\share\fpcsrc\packages\fv\src\dialogs.pas"/> + <TopLine Value="1025"/> + <CursorPos X="41" Y="1052"/> + <UsageCount Value="10"/> + </Unit32> + <Unit33> + <Filename Value="..\common\dicomhdr.pas"/> + <TopLine Value="18"/> + <CursorPos X="6" Y="33"/> + <UsageCount Value="10"/> + </Unit33> + <Unit34> + <Filename Value="..\common\nifti_hdr.pas"/> + <TopLine Value="1459"/> + <CursorPos X="41" Y="1473"/> + <UsageCount Value="10"/> + </Unit34> + <Unit35> + <Filename Value="..\..\..\..\..\..\usr\local\share\fpcsrc\rtl\objpas\sysutils\finah.inc"/> + <EditorIndex Value="-1"/> + <TopLine Value="15"/> + <CursorPos X="24" Y="25"/> + <UsageCount Value="10"/> + </Unit35> + </Units> + <JumpHistory Count="27" HistoryIndex="26"> + <Position1> + <Filename Value="parconvert.pas"/> + <Caret Line="1199" Column="16" TopLine="1331"/> + </Position1> + <Position2> + <Filename Value="parconvert.pas"/> + <Caret Line="5" Column="11"/> + </Position2> + <Position3> + <Filename Value="parconvert.pas"/> + <Caret Line="438" Column="6" TopLine="422"/> + </Position3> + <Position4> + <Filename Value="parconvert.pas"/> + <Caret Line="506" Column="16" TopLine="490"/> + </Position4> + <Position5> + <Filename Value="parconvert.pas"/> + <Caret Line="507" Column="11" TopLine="491"/> + </Position5> + <Position6> + <Filename Value="parconvert.pas"/> + <Caret Line="508" Column="25" TopLine="492"/> + </Position6> + <Position7> + <Filename Value="parconvert.pas"/> + <Caret Line="511" Column="15" TopLine="495"/> + </Position7> + <Position8> + <Filename Value="parconvert.pas"/> + <Caret Line="517" Column="15" TopLine="501"/> + </Position8> + <Position9> + <Filename Value="parconvert.pas"/> + <Caret Line="431" Column="89" TopLine="427"/> + </Position9> + <Position10> + <Filename Value="parconvert.pas"/> + <Caret Line="707" Column="39" TopLine="691"/> + </Position10> + <Position11> + <Filename Value="dicomtypes.pas"/> + <Caret Line="191" Column="25" TopLine="184"/> + </Position11> + <Position12> + <Filename Value="parconvert.pas"/> + <Caret Line="707" Column="39" TopLine="702"/> + </Position12> + <Position13> + <Filename Value="dicomtypes.pas"/> + <Caret Line="191" Column="25" TopLine="185"/> + </Position13> + <Position14> + <Filename Value="parconvert.pas"/> + <Caret Line="4" Column="121"/> + </Position14> + <Position15> + <Filename Value="parconvert.pas"/> + <Caret Line="387" Column="23" TopLine="370"/> + </Position15> + <Position16> + <Filename Value="parconvert.pas"/> + <Caret Line="476" Column="25" TopLine="460"/> + </Position16> + <Position17> + <Filename Value="parconvert.pas"/> + <Caret Line="513" Column="26" TopLine="497"/> + </Position17> + <Position18> + <Filename Value="parconvert.pas"/> + <Caret Line="644" Column="30" TopLine="628"/> + </Position18> + <Position19> + <Filename Value="parconvert.pas"/> + <Caret Line="731" Column="23" TopLine="715"/> + </Position19> + <Position20> + <Filename Value="parconvert.pas"/> + <Caret Line="820" Column="27" TopLine="804"/> + </Position20> + <Position21> + <Filename Value="parconvert.pas"/> + <Caret Line="831" Column="30" TopLine="815"/> + </Position21> + <Position22> + <Filename Value="parconvert.pas"/> + <Caret Line="1072" Column="14" TopLine="969"/> + </Position22> + <Position23> + <Filename Value="parconvert.pas"/> + <Caret Line="387" Column="108" TopLine="377"/> + </Position23> + <Position24> + <Filename Value="parconvert.pas"/> + <Caret Line="707" Column="28" TopLine="689"/> + </Position24> + <Position25> + <Filename Value="dicomtypes.pas"/> + <Caret Line="191" Column="25" TopLine="181"/> + </Position25> + <Position26> + <Filename Value="prefs.pas"/> + <Caret Line="6" Column="70" TopLine="9"/> + </Position26> + <Position27> + <Filename Value="..\common\define_types.pas"/> + <Caret Line="5" Column="19"/> + </Position27> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <OtherUnitFiles Value="..\common"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <Optimizations> + <OptimizationLevel Value="2"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + <UseLineInfoUnit Value="False"/> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + </Linking> + <Other> + <ConfigFile> + <ConfigFilePath Value=""/> + </ConfigFile> + </Other> + </CompilerOptions> +</CONFIG> diff --git a/dcm2nii/dcm2nii.lpr b/dcm2nii/dcm2nii.lpr new file mode 100755 index 0000000..b4f6ff4 --- /dev/null +++ b/dcm2nii/dcm2nii.lpr @@ -0,0 +1,73 @@ +program dcm2nii; +{$IFDEF FPC} +{$mode objfpc} +{$ELSE} + {$APPTYPE CONSOLE} +{$ENDIF} +{$H+} +uses + {$IFDEF UNIX} + {$IFDEF UseCThreads} cthreads, {$ENDIF} +{$ELSE} + shellAPI, + Windows, + {$ENDIF} + + Classes, + inifiles, + SysUtils, + convert, + define_types, + sortdicom, + dicom, + parconvert, + filename, + dicomtypes, + nii_crop, + nii_4dto3d, + prefs, + dialogsx, + paramstrs; +{$IFNDEF UNIX} +//{$R laz.res} +{$ENDIF} + + +(*var lIn,lOut: string; +Start: dword; +lPrefs: TPrefs; +begin +Start := GetTickCount; + kUseDateTimeForID := true; + SetDefaultPrefs (lPrefs); + lPrefs.Gzip := true; + lPrefs.Anonymize := true; + lPrefs.SingleNIIFile := true; + lPrefs.everyfile := true; + lPrefs.AppendDate := false; + lPrefs.AppendAcqSeries := true; + lPrefs.AppendProtocolName := true; + lPrefs.AppendPatientName := false; + lPrefs.fourD := true; + lPrefs.AppendFilename := true; +lOut := ''; +lIn := 'C:\dti64\rapid\IM_0001.dcm'; + +LoadFileList(lIn,lOut,lPrefs); +Msg('Finished. Elapsed time: '+inttostr(GetTickCount-Start)); + readln; + + end. *) + +begin + ShowMsg(kVers); + kUseDateTimeForID := true; + ProcessParamStrs; +end. + + + + + + + diff --git a/dcm2nii/dcm2nii.o b/dcm2nii/dcm2nii.o new file mode 100644 index 0000000..0ae69af Binary files /dev/null and b/dcm2nii/dcm2nii.o differ diff --git a/dcm2nii/dcm2nii.res b/dcm2nii/dcm2nii.res new file mode 100755 index 0000000..c7fb1f5 Binary files /dev/null and b/dcm2nii/dcm2nii.res differ diff --git a/dcm2nii/dcm2nii48.ico b/dcm2nii/dcm2nii48.ico new file mode 100755 index 0000000..375ec28 Binary files /dev/null and b/dcm2nii/dcm2nii48.ico differ diff --git a/dcm2nii/dcm2niigui b/dcm2nii/dcm2niigui new file mode 100755 index 0000000..ed58f2f Binary files /dev/null and b/dcm2nii/dcm2niigui differ diff --git a/dcm2nii/dcm2niigui.app/Contents/Info.plist b/dcm2nii/dcm2niigui.app/Contents/Info.plist new file mode 100755 index 0000000..cbcd5a7 --- /dev/null +++ b/dcm2nii/dcm2niigui.app/Contents/Info.plist @@ -0,0 +1,45 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>CFBundleDevelopmentRegion</key> + <string>English</string> + <key>CFBundleExecutable</key> + <string>dcm2niigui</string> + <key>CFBundleName</key> + <string>dcm2niigui.exe</string> + <key>CFBundleIdentifier</key> + <string>com.company.dcm2niigui</string> + <key>CFBundleInfoDictionaryVersion</key> + <string>6.0</string> + <key>CFBundlePackageType</key> + <string>APPL</string> + <key>CFBundleSignature</key> + <string>dcm2</string> + <key>CFBundleShortVersionString</key> + <string>0.1</string> + <key>CFBundleVersion</key> + <string>1</string> + <key>CSResourcesFileMapped</key> + <true/> + <key>CFBundleDocumentTypes</key> + <array> + <dict> + <key>CFBundleTypeRole</key> + <string>Viewer</string> + <key>CFBundleTypeExtensions</key> + <array> + <string>*</string> + </array> + <key>CFBundleTypeOSTypes</key> + <array> + <string>fold</string> + <string>disk</string> + <string>****</string> + </array> + </dict> + </array> + <key>NSHighResolutionCapable</key> + <true/> +</dict> +</plist> diff --git a/dcm2nii/dcm2niigui.app/Contents/MacOS/dcm2niigui b/dcm2nii/dcm2niigui.app/Contents/MacOS/dcm2niigui new file mode 120000 index 0000000..eb6cf9b --- /dev/null +++ b/dcm2nii/dcm2niigui.app/Contents/MacOS/dcm2niigui @@ -0,0 +1 @@ +../../../dcm2niigui \ No newline at end of file diff --git a/dcm2nii/dcm2niigui.app/Contents/PkgInfo b/dcm2nii/dcm2niigui.app/Contents/PkgInfo new file mode 100755 index 0000000..6f749b0 --- /dev/null +++ b/dcm2nii/dcm2niigui.app/Contents/PkgInfo @@ -0,0 +1 @@ +APPL???? diff --git a/dcm2nii/dcm2niigui.cfg b/dcm2nii/dcm2niigui.cfg new file mode 100755 index 0000000..240d9f8 --- /dev/null +++ b/dcm2nii/dcm2niigui.cfg @@ -0,0 +1,39 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-LN"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-U"..\common\;C:\pas\d4\RX\Units\;..\delphionly" +-O"..\common\;C:\pas\d4\RX\Units\;..\delphionly" +-I"..\common\;C:\pas\d4\RX\Units\;..\delphionly" +-R"..\common\;C:\pas\d4\RX\Units\;..\delphionly" diff --git a/dcm2nii/dcm2niigui.compiled b/dcm2nii/dcm2niigui.compiled new file mode 100755 index 0000000..46274c9 --- /dev/null +++ b/dcm2nii/dcm2niigui.compiled @@ -0,0 +1,5 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <Compiler Value="/usr/local/bin/ppc386" Date="1393445779"/> + <Params Value=" -MDelphi -Scgi -O1 -Xs -XX -k-framework -kCarbon -k-framework -kOpenGL -k-dylib_file -k/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib -vewnhibq -Fu/Users/rorden/Documents/pas/mricron/common -Fu/Developer/lazarus/lcl/units/i386-darwin/carbon -Fu/Developer/lazarus/lcl/units/i386-darwin -Fu/Developer/lazarus/components/lazutils/lib/i386-darwin -Fu/Developer/lazarus/packager/units/i386-darwin -Fu/Users/rorden/Documents/pas/mricron/dcm2nii/ -dLCL -dLCLcarbon dcm2niigui.lpr"/> +</CONFIG> diff --git a/dcm2nii/dcm2niigui.dof b/dcm2nii/dcm2niigui.dof new file mode 100755 index 0000000..485b1ed --- /dev/null +++ b/dcm2nii/dcm2niigui.dof @@ -0,0 +1,145 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=1 +UnsafeCode=1 +UnsafeCast=1 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath=..\common\;C:\pas\d4\RX\Units\;..\delphionly +Packages=Vcl40;Vclx40;VclSmp40;Qrpt40;Vcldb40;RxCtl4 +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=0 +MinorVer=9 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=0.9.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= +[HistoryLists\hlUnitAliases] +Count=1 +Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[HistoryLists\hlSearchPath] +Count=4 +Item0=..\common\;C:\pas\d4\RX\Units\;..\delphionly +Item1=..\common\;C:\pas\d4\RX\Units\ +Item2=..\common\;C:\pas\d4\RX\Units +Item3=..\common\ diff --git a/dcm2nii/dcm2niigui.dpr b/dcm2nii/dcm2niigui.dpr new file mode 100755 index 0000000..b582288 --- /dev/null +++ b/dcm2nii/dcm2niigui.dpr @@ -0,0 +1,20 @@ +program dcm2niigui; + +uses + Forms, + gui in 'gui.pas' {MainForm}, + pref_form in 'pref_form.pas' {PrefsForm}, + nifti_form in 'nifti_form.pas' {NIfTIform}, + untar in 'untar.pas', + convertsimple in 'convertsimple.pas'; + +{$R *.RES} + +begin + Application.Initialize; + Application.Title := 'dcm2niiGUI'; + Application.CreateForm(TMainForm, MainForm); + Application.CreateForm(TPrefsForm, PrefsForm); + Application.CreateForm(TNIfTIform, NIfTIform); + Application.Run; +end. diff --git a/dcm2nii/dcm2niigui.ico b/dcm2nii/dcm2niigui.ico new file mode 100755 index 0000000..375ec28 Binary files /dev/null and b/dcm2nii/dcm2niigui.ico differ diff --git a/dcm2nii/dcm2niigui.ini b/dcm2nii/dcm2niigui.ini new file mode 100755 index 0000000..80c40a5 --- /dev/null +++ b/dcm2nii/dcm2niigui.ini @@ -0,0 +1,46 @@ +[BOOL] +DebugMode=0 +UntestedFeatures=0 +UINT16toFLOAT32=1 +Verbose=0 +Anonymize=1 +AnonymizeSourceDICOM=0 +AppendAcqSeries=1 +AppendDate=0 +AppendFilename=0 +AppendPatientName=0 +AppendProtocolName=1 +AutoCrop=0 +CollapseFolders=1 +createoutputfolder=0 +CustomRename=0 +enablereorient=1 +OrthoFlipXDim=0 +EveryFile=1 +fourD=1 +Gzip=0 +ManualNIfTIConv=1 +PhilipsPrecise=0 +RecursiveUseNameAppend=0 +SingleNIIFile=1 +SPM2=0 +Stack3DImagesWithSameAcqNum=0 +Swizzle4D=1 +UseGE_0021_104F=0 +TxtReport=0 + +[INT] +BeginClip=0 +LastClip=0 +usePigz=1 +MaxReorientMatrix=1023 +MinReorientMatrix=200 +RecursiveFolderDepth=5 +OutDirMode=0 +SiemensDTIUse0019If00181020atleast=15 +SiemensDTINoAngulationCorrectionIf00181020atleast=1000 +SiemensDTIStackIf00181020atleast=15 + +[STR] +OutDir=C:\Users\neuropsych\Documents + diff --git a/dcm2nii/dcm2niigui.lpi b/dcm2nii/dcm2niigui.lpi new file mode 100755 index 0000000..36bf299 --- /dev/null +++ b/dcm2nii/dcm2niigui.lpi @@ -0,0 +1,423 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <LRSInOutputDirectory Value="False"/> + </Flags> + <MainUnit Value="0"/> + <Title Value="dcm2niigui.exe"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="27"> + <Unit0> + <Filename Value="dcm2niigui.lpr"/> + <IsPartOfProject Value="True"/> + <CursorPos X="2"/> + <UsageCount Value="206"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit0> + <Unit1> + <Filename Value="gui.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MainForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="5"/> + <TopLine Value="387"/> + <CursorPos X="32" Y="398"/> + <UsageCount Value="206"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit1> + <Unit2> + <Filename Value="nifti_form.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="NIfTIForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="66"/> + <CursorPos X="26" Y="73"/> + <UsageCount Value="206"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit2> + <Unit3> + <Filename Value="pref_form.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="PrefsForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <TopLine Value="161"/> + <CursorPos X="26" Y="174"/> + <UsageCount Value="206"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit3> + <Unit4> + <Filename Value="niftiutil.pas"/> + <EditorIndex Value="3"/> + <TopLine Value="320"/> + <CursorPos X="57" Y="343"/> + <UsageCount Value="78"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit4> + <Unit5> + <Filename Value="prefs.pas"/> + <EditorIndex Value="2"/> + <TopLine Value="100"/> + <CursorPos X="17" Y="110"/> + <UsageCount Value="103"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit5> + <Unit6> + <Filename Value="dicomtypes.pas"/> + <EditorIndex Value="10"/> + <TopLine Value="297"/> + <CursorPos X="31" Y="310"/> + <UsageCount Value="104"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit6> + <Unit7> + <Filename Value="..\common\define_types.pas"/> + <EditorIndex Value="8"/> + <CursorPos X="18" Y="2"/> + <UsageCount Value="113"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit7> + <Unit8> + <Filename Value="convert.pas"/> + <TopLine Value="73"/> + <CursorPos X="7" Y="78"/> + <UsageCount Value="115"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit8> + <Unit9> + <Filename Value="..\common\gzio2.pas"/> + <CursorPos X="114"/> + <UsageCount Value="80"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit9> + <Unit10> + <Filename Value="..\common\GraphicsMathLibrary.pas"/> + <TopLine Value="592"/> + <CursorPos X="27" Y="585"/> + <UsageCount Value="111"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit10> + <Unit11> + <Filename Value="..\common\dialogsx.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="74"/> + <CursorPos X="18" Y="86"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit11> + <Unit12> + <Filename Value="dicomcompat.pas"/> + <EditorIndex Value="9"/> + <TopLine Value="6483"/> + <CursorPos X="81" Y="6488"/> + <UsageCount Value="114"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit12> + <Unit13> + <Filename Value="sortdicom.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="330"/> + <CursorPos X="23" Y="351"/> + <UsageCount Value="66"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit13> + <Unit14> + <Filename Value="philips_bvec.pas"/> + <IsPartOfProject Value="True"/> + <CursorPos X="117" Y="248"/> + <UsageCount Value="214"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit14> + <Unit15> + <Filename Value="..\common\isgui.inc"/> + <EditorIndex Value="-1"/> + <CursorPos X="10"/> + <UsageCount Value="11"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit15> + <Unit16> + <Filename Value="csaread.pas"/> + <EditorIndex Value="1"/> + <TopLine Value="233"/> + <CursorPos X="67" Y="239"/> + <UsageCount Value="102"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit16> + <Unit17> + <Filename Value="dialogs_msg.pas"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="-1"/> + <CursorPos X="11" Y="27"/> + <UsageCount Value="208"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit17> + <Unit18> + <Filename Value="..\common\nifti_types.pas"/> + <EditorIndex Value="4"/> + <CursorPos X="9" Y="11"/> + <UsageCount Value="100"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit18> + <Unit19> + <Filename Value="..\common\nifti_foreign.pas"/> + <TopLine Value="416"/> + <CursorPos X="74" Y="419"/> + <UsageCount Value="71"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit19> + <Unit20> + <Filename Value="parconvert.pas"/> + <EditorIndex Value="-1"/> + <CursorPos X="153" Y="4"/> + <UsageCount Value="26"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit20> + <Unit21> + <Filename Value="bvec.pas"/> + <EditorIndex Value="7"/> + <CursorPos X="75" Y="11"/> + <UsageCount Value="44"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit21> + <Unit22> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\customform.inc"/> + <EditorIndex Value="-1"/> + <TopLine Value="2528"/> + <CursorPos Y="2536"/> + <UsageCount Value="25"/> + </Unit22> + <Unit23> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\menuitem.inc"/> + <CursorPos X="50"/> + <UsageCount Value="6"/> + </Unit23> + <Unit24> + <Filename Value="dicom.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="5"/> + <CursorPos X="43" Y="20"/> + <UsageCount Value="25"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit24> + <Unit25> + <Filename Value="paramstrs.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="60"/> + <CursorPos X="10" Y="71"/> + <UsageCount Value="25"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit25> + <Unit26> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\clipbrd.inc"/> + <EditorIndex Value="6"/> + <TopLine Value="51"/> + <CursorPos Y="58"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit26> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="dicomcompat.pas"/> + <Caret Line="3228" Column="52" TopLine="3212"/> + </Position1> + <Position2> + <Filename Value="dicomcompat.pas"/> + <Caret Line="3929" Column="21" TopLine="3913"/> + </Position2> + <Position3> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5972" Column="23" TopLine="5965"/> + </Position3> + <Position4> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5974" Column="26" TopLine="5965"/> + </Position4> + <Position5> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5975" Column="47" TopLine="5965"/> + </Position5> + <Position6> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6097" Column="26" TopLine="6090"/> + </Position6> + <Position7> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6098" Column="47" TopLine="6090"/> + </Position7> + <Position8> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6498" Column="82" TopLine="6482"/> + </Position8> + <Position9> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6499" Column="63" TopLine="6483"/> + </Position9> + <Position10> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6500" Column="122" TopLine="6484"/> + </Position10> + <Position11> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6501" Column="86" TopLine="6485"/> + </Position11> + <Position12> + <Filename Value="dicomcompat.pas"/> + <Caret Line="3228" Column="52" TopLine="3223"/> + </Position12> + <Position13> + <Filename Value="dicomcompat.pas"/> + <Caret Line="3929" Column="21" TopLine="3906"/> + </Position13> + <Position14> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5972" Column="23" TopLine="5961"/> + </Position14> + <Position15> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5974" Column="26" TopLine="5961"/> + </Position15> + <Position16> + <Filename Value="dicomcompat.pas"/> + <Caret Line="5982" Column="29" TopLine="5967"/> + </Position16> + <Position17> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6501" Column="17" TopLine="6483"/> + </Position17> + <Position18> + <Filename Value="dicomtypes.pas"/> + <Caret Line="270" Column="92" TopLine="266"/> + </Position18> + <Position19> + <Filename Value="dicomcompat.pas"/> + <Caret Line="6501" Column="11" TopLine="6483"/> + </Position19> + <Position20> + <Filename Value="dicomtypes.pas"/> + <Caret Line="191" Column="25" TopLine="182"/> + </Position20> + <Position21> + <Filename Value="gui.pas"/> + <Caret Line="4" Column="89"/> + </Position21> + <Position22> + <Filename Value="gui.pas"/> + <Caret Line="492" Column="44" TopLine="488"/> + </Position22> + <Position23> + <Filename Value="gui.pas"/> + <Caret Line="493" Column="44" TopLine="489"/> + </Position23> + <Position24> + <Filename Value="gui.pas"/> + <Caret Line="494" Column="44" TopLine="490"/> + </Position24> + <Position25> + <Filename Value="gui.pas"/> + <Caret Line="18" Column="76" TopLine="17"/> + </Position25> + <Position26> + <Filename Value="gui.pas"/> + <Caret Line="494" Column="47" TopLine="485"/> + </Position26> + <Position27> + <Filename Value="gui.pas"/> + <Caret Line="414" Column="31" TopLine="408"/> + </Position27> + <Position28> + <Filename Value="gui.pas"/> + <Caret Line="82" Column="26" TopLine="71"/> + </Position28> + <Position29> + <Filename Value="gui.pas"/> + <Caret Line="138" Column="26" TopLine="124"/> + </Position29> + <Position30> + <Filename Value="gui.pas"/> + <Caret Line="370" Column="32" TopLine="355"/> + </Position30> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <OtherUnitFiles Value="..\common"/> + <SrcPath Value="C:\lazarus\ideintf"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <SyntaxMode Value="Delphi"/> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + <UseLineInfoUnit Value="False"/> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <WriteFPCLogo Value="False"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="2"> + <Item1> + <Name Value="ECodetoolError"/> + </Item1> + <Item2> + <Name Value="EFOpenError"/> + </Item2> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/dcm2nii/dcm2niigui.lpr b/dcm2nii/dcm2niigui.lpr new file mode 100755 index 0000000..9d3edd5 --- /dev/null +++ b/dcm2nii/dcm2niigui.lpr @@ -0,0 +1,25 @@ +program dcm2niigui; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, gui, nifti_form, pref_form, dialogs_msg; + + + + +//{$R dcm2niigui.res} + +begin + Application.Title:='dcm2niigui.exe'; + Application.Initialize; + Application.CreateForm(TMainForm, MainForm); + Application.CreateForm(TNIfTIForm, NIfTIForm); + Application.CreateForm(TPrefsForm, PrefsForm); + Application.Run; +end. + diff --git a/dcm2nii/dcm2niigui.lrs b/dcm2nii/dcm2niigui.lrs new file mode 100755 index 0000000..8d76aa7 --- /dev/null +++ b/dcm2nii/dcm2niigui.lrs @@ -0,0 +1,732 @@ +LazarusResources.Add('MAINICON','ICO',[ + #0#0#1#0#4#0'00'#0#0#1#0' '#0#168'%'#0#0'F'#0#0#0' '#0#0#1#0' '#0#168#16#0#0 + +#238'%'#0#0#24#24#0#0#1#0' '#0#136#9#0#0#150'6'#0#0#16#16#0#0#1#0' '#0'h'#4#0 + +#0#30'@'#0#0'('#0#0#0'0'#0#0#0'`'#0#0#0#1#0' '#0#0#0#0#0#128'%'#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#138#138#138#0#143#143#143#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#168#168#168#0#185#185#185#0#0#0#0#1#255#255#255#3#14#14#14#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#141#141#141#2#142 + +#142#142#2#145#145#145#2#146#145#145#2#146#146#146#2'~~'#128#2'zz{'#1'{{{'#2 + +'|||'#2'~~'#128#2#127#127#129#2#127#127#127#2#128#128#128#2#128#128#129#2#131 + +#131#131#2#131#131#131#2#133#133#133#2#134#134#134#1'jjj'#2#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#131#131#131#0#173#173#173#0#178#178#178#2#0#0#0#0#0#0#0#0 + +#0#0#0#5#0#0#0#7#0#0#0#6#0#0#0#6#0#0#0#6#0#0#0#6#0#0#0#6#0#0#0#6#0#0#0#8#0#0 + +#0#0#143#143#143#0#145#145#146#0#130#130#130#0#139#138#147#0#153#152#174#0 + +#143#141#177#0#156#154#202#0#161#159#206#0#163#160#209#0#162#159#208#0#153 + +#151#195#0#135#134#166#0'vu'#131#0'mmn'#0'rrq'#0'rrr'#0'ttt'#0'}}}'#0'lll'#0 + +'xxx'#0'888'#0#128#128#128#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#147#147#147#0#0#0#0#0#143#143#143#1#167#167#167#2 + +#144#144#144#0'kkk'#9'zzz'#129#151#151#151#214#166#166#166#216#163#163#163 + +#216#163#163#163#217#162#162#162#217#163#163#163#217#162#162#162#217#162#162 + +#162#216#166#166#166#219#155#155#155#194'sss9rrp!pqm#'#132#130#141'#'#156#155 + +#180'"'#149#147#188#27#156#154#204#25#162#159#211#25#164#162#214#25#164#161 + +#213#25#155#153#199#25#132#131#166#25'ggt'#25'PPK'#25'STG'#25']]Y'#25'bbb'#25 + +'iii'#25'bbb'#27'___'#6#23#23#23#0#130#130#130#0#137#137#137#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#157#157#157#0#156#156#156 + +#0#137#137#137#0#183#183#183#0#175#175#175'H'#154#154#154#210#154#154#154#255 + +#168#168#168#255#176#176#176#255#174#174#174#255#175#175#175#255#175#175#175 + +#255#174#174#174#255#174#174#174#255#174#174#174#255#177#177#177#255#175#175 + +#175#255#155#155#156#253#179#178#183#245#174#174#176#246#164#164#160#246#148 + +#148#133#246#130#131'l'#241'wyY'#240'rtP'#240'stP'#240'xzZ'#240#131#132'l' + +#240#146#147#131#240#161#161#158#240#171#171#175#240#173#173#178#240#168#168 + +#169#240#165#165#163#240#165#165#165#236#167#167#167#241#147#147#147#143#197 + +#197#197#0#174#174#174#1#129#129#129#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#151#151#151#2#146#146#146#0#137#137#137#29#138#138 + +#138#159#157#157#157#255#169#169#169#255#151#151#151#250#170#170#170#253#171 + +#171#171#253#170#170#170#253#171#171#171#253#171#171#171#253#171#171#171#253 + +#171#171#171#253#170#170#170#253#171#171#171#253#171#171#172#252#154#154#147 + +#255#140#142'r'#255'lo;'#255'`d'#22#255'_e'#1#255'ek'#0#255'kq'#0#255'nu'#0 + +#255'mt'#0#255'kq'#0#255'gm'#0#255'ek'#3#255'hm'#24#255'uy='#255#142#143'r' + +#255#167#167#164#255#180#180#187#255#176#176#178#255#175#176#175#255#165#165 + ,#165#239#157#157#157#22'```'#0#128#128#128#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#164#164#164#2#171#171#171#5#149#149#149#205 + +#168#168#168#255#167#167#167#251#164#164#164#252#152#152#152#255#173#173#173 + +#254#171#171#171#254#171#171#171#255#172#172#172#255#172#172#172#255#172#172 + +#172#255#172#172#172#255#171#171#171#254#171#171#169#254#176#176#182#255'hj7' + +#254'X^'#0#253'u|'#0#253#136#144#0#253#145#155#0#253#149#158#0#253#149#158#1 + +#253#149#159#1#253#149#158#1#253#149#159#1#253#149#158#0#253#146#155#0#253 + +#140#149#0#253#129#138#0#253't|'#0#253'qw'#17#253#132#135'S'#253#165#165#161 + +#253#178#178#184#250#172#172#170#255#134#134#133'p'#173#173#173#0#169#169#169 + +#3#170#170#171#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'ppp' + +#0'lll"'#162#162#162#248#166#166#166#252#166#166#166#253#161#161#161#255#154 + +#154#154#254#174#174#174#255#170#170#170#255#172#172#172#255#171#171#171#255 + +#171#171#171#255#171#171#171#255#171#171#171#255#171#171#171#255#171#171#168 + +#255#172#172#182#255#133#138'4'#255#146#156#1#255#149#157#3#255#145#154#0#255 + +#143#152#0#255#143#152#0#255#143#152#0#255#142#151#0#255#143#151#0#255#143 + +#151#0#255#143#152#0#255#143#152#0#255#144#153#0#255#146#156#1#255#148#158#1 + +#255#144#154#0#255#130#139#0#255'x'#127#16#255#143#145'k'#251#177#176#184#254 + +#163#163#163#211#201#202#198#5#169#170#165#1#190#185#230#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#143#143#143#0#131#131#131'J'#163#163 + +#163#254#165#165#165#253#166#166#166#254#158#158#158#254#156#156#156#255#175 + +#175#175#255#171#171#171#255#172#172#172#255#174#174#174#255#175#175#175#255 + +#175#175#175#255#174#174#174#255#172#172#172#255#171#172#169#255#172#171#183 + +#255#140#145';'#255#142#151#0#255#142#151#2#255#143#152#0#255#143#152#0#255 + +#143#152#1#255#144#153#2#255#145#153#2#255#145#154#2#255#145#154#2#255#144 + +#153#2#255#143#152#1#255#143#152#0#255#142#151#0#255#142#151#1#255#143#151#2 + +#255#146#155#4#255#145#154#0#254#129#138#0#254#131#134'>'#252#165#165#169#255 + +'}}'#132'I'#152#148#164#0#149#148#157#2#131#130#137#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#157#157#157#0#144#144#144's'#165#165#165#254#165#165 + +#165#251#167#167#167#255#157#157#157#255#160#160#160#255#174#174#174#255#174 + +#174#174#255#178#178#178#255#179#179#179#255#179#179#179#255#179#179#179#255 + +#179#179#179#255#178#178#178#255#175#175#173#255#174#174#185#255#140#145'A' + +#255#143#153#0#255#144#153#3#255#144#153#1#255#145#154#0#255#143#153#0#255 + +#140#149#0#255#137#147#0#255#137#147#0#255#138#148#0#255#141#151#0#255#145 + +#155#0#255#147#156#0#255#146#155#0#255#145#155#0#255#145#155#0#255#145#154#0 + +#255#144#153#0#255#148#158#0#255#139#149#0#251#131#137'!'#254#146#146#137#178 + +#147#166#155#0#171#175#130#2#0#0#0#0#137#137#137#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#175#175#175#0#147#147#147#154#166#166#166#255#164#164#164#250 + +#167#167#167#254#155#155#155#255#162#162#162#255#178#178#178#255#179#179#179 + +#255#179#179#179#255#179#179#179#255#179#179#179#255#179#179#179#255#179#179 + +#179#255#179#179#179#255#179#179#177#255#181#181#191#255#139#144'G'#255#135 + +#145#0#255#140#149#0#255#140#150#0#255#137#145#0#255#140#147'&'#255#151#155 + +'P'#255#158#161'i'#255#158#160'l'#255#154#157'e'#255#143#148'J'#255#131#138 + +#28#255#129#137#6#255#129#136#18#255#132#139#25#255#131#137#27#255#131#137#30 + +#255#130#137'!'#255#129#136'&'#254#133#138','#254#130#135')'#253'nqF'#249':F' + +'?(dfZ'#0'llf'#5#131#131#131#3#156#156#156#3#131#131#131#2#183#183#183#0#178 + +#178#178#0#0#0#0#0#241#241#241#0#155#155#155#184#166#166#166#255#165#165#165 + +#251#170#170#170#255#156#156#156#255#168#168#168#255#182#182#182#255#178#178 + +#178#255#179#179#179#255#180#180#180#255#179#179#179#255#179#179#179#255#179 + +#179#179#255#179#179#179#255#178#178#178#255#182#182#184#255#141#141#131#255 + +#133#135'j'#255#136#138'd'#255#129#132'T'#255#130#132'r'#255#153#152#160#255 + +#154#153#164#255#159#158#168#255#165#165#174#255#157#156#166#255#151#150#161 + +#255#137#137#143#255'yyv'#255#142#142#146#255#148#148#153#255#148#148#154#255 + +#150#150#158#255#151#151#159#255#152#152#161#254#152#152#162#255#151#150#162 + +#252#153#153#157#254#135#133#135#210#146#145#149#27#165#166#165#0'zzz'#0#163 + +#163#163#0#143#143#143#0#212#212#212#0#203#203#203#0'kkk'#0#250#250#250#4#157 + +#157#157#208#168#168#168#255#171#171#171#252#176#176#176#255#160#160#160#255 + +#170#170#170#255#181#181#181#255#178#178#178#255#180#180#180#255#179#179#179 + +#255#180#180#180#255#180#180#180#255#179#179#179#255#180#180#179#255#178#178 + +#179#255#181#181#181#255#150#150#152#255#152#152#157#255#154#154#161#255#157 + +#156#165#255#151#151#155#255#132#132#131#255#127#127'|'#255#134#134#132#255 + +#136#136#134#255#134#134#132#255#135#135#133#255#127#127'}'#255#151#151#152 + +#255#153#153#153#255#149#149#148#255#146#146#144#255#142#143#141#255#139#139 + +#137#255#135#135#133#255#131#131#130#254#142#142#140#255#142#142#142#252#144 + +#144#144#255'zzz'#195#141#141#141'v'#139#139#139'{'#136#136#136'}wwwN'#174 + ,#174#174#0#196#196#196#1'```'#0#11#11#11'('#157#157#157#226#171#171#171#255 + +#173#173#173#253#175#175#175#255#160#160#160#255#169#169#169#255#181#181#181 + +#255#179#179#179#255#179#179#179#255#180#180#180#255#180#180#180#255#180#180 + +#180#255#180#180#180#255#179#179#180#255#179#179#178#255#182#182#183#255#150 + +#150#150#255#148#148#146#255#155#156#154#255#138#138#135#255'tts'#255#130#130 + +#130#255#140#140#140#255#141#141#141#255#143#143#143#255#146#146#146#255#149 + +#149#149#255#135#135#135#255#127#127#127#255'yyy'#255'zzz'#255'zzz'#255'zzz' + +#255'~~~'#255'www'#255#132#132#132#255#174#174#174#254#170#170#170#255#170 + +#170#170#252#173#173#173#255#172#172#172#255#171#171#171#255#172#172#172#255 + +#153#153#153#224#176#176#176#1#179#179#179#1'eee'#2'qqqT'#162#162#162#236#173 + +#173#173#255#172#172#172#254#176#176#176#255#161#161#161#255#168#168#168#255 + +#182#182#182#255#179#179#179#255#180#180#180#255#180#180#180#255#180#180#180 + +#255#180#180#180#255#180#180#180#255#180#180#180#255#178#178#178#255#183#183 + +#183#255#152#152#152#255#145#145#145#255#152#152#152#255#131#131#131#255#149 + +#149#149#255#154#154#154#255#153#153#153#254#155#155#155#255#154#154#154#254 + +#154#154#154#254#155#155#155#254#136#136#136#254'zzz'#255#134#134#134#254#134 + +#134#134#255#134#134#134#255#135#135#135#255#128#128#128#255#128#128#128#255 + +#165#165#164#255#171#172#170#255#171#171#169#254#171#171#170#255#171#171#170 + +#253#171#171#170#251#171#171#170#249#172#172#171#247#170#170#170#251'xxx'#167 + +'TTT'#0#171#171#171#0'}}}'#127#169#169#169#242#173#173#173#255#173#173#173 + +#253#176#176#176#255#162#162#162#255#167#167#167#255#182#182#182#255#179#179 + +#179#255#180#180#180#255#180#180#180#255#180#180#180#255#180#180#180#255#180 + +#180#180#255#180#180#180#255#178#178#178#255#183#183#183#255#154#154#154#254 + +#145#145#145#255#155#155#155#253#141#141#141#251#154#154#154#251#154#154#154 + +#251#152#152#152#250#152#152#152#250#150#150#150#250#149#149#149#250#149#149 + +#149#251'}}}'#252'rrr'#254'|||'#255'xxx'#254'yyy'#255'sss'#255#130#130#129 + +#255#171#171#172#255#177#177#181#255#174#173#177#255#175#175#179#255#175#175 + +#179#255#175#174#180#255#176#175#179#255#176#176#178#255#174#174#174#255#176 + +#176#175#255#175#175#175#255#145#145#145#190#149#149#149#23#130#130#130#157 + +#171#171#171#246#174#174#174#255#173#173#173#254#176#176#176#255#162#162#162 + +#255#167#167#167#255#182#182#182#255#179#179#179#255#180#180#180#255#180#180 + +#180#255#180#180#180#255#180#180#180#255#180#180#180#255#180#180#180#255#179 + +#179#179#255#181#181#181#254#165#165#165#255#186#186#186#254#199#199#199#255 + +#134#134#134#255'xxx'#255#128#128#128#255'}}}'#255'|||'#255'zzz'#255'zzz'#255 + +'{{{'#255'xxx'#255'ttt'#254'uuu'#254'www'#255'{{{'#255'uuu'#255#152#152#153 + +#255#160#160#156#255#151#153#134#255#154#155#136#255#153#154#134#255#153#154 + +#134#255#153#155#132#254#149#150#130#255#146#146#140#232#150#149#153#212#150 + +#150#153#214#159#159#159#210#158#158#158#227'___Z'#138#138#138#179#171#171 + +#171#249#173#173#173#255#172#172#172#254#175#175#175#255#162#162#162#255#167 + +#167#167#255#181#181#181#255#178#178#179#255#179#179#180#255#179#179#179#255 + +#179#179#179#255#179#179#179#255#179#179#179#255#179#179#179#255#178#178#178 + +#255#182#182#182#255#164#164#164#253#189#189#189#254#164#164#164#237#145#145 + +#145#180#141#141#141#169'nnn'#155'ooo'#142'nnn'#129'jjjtlllgwwwUiii'#134#164 + +#164#164#255#172#172#172#252#174#174#174#254#177#177#177#254#180#180#179#255 + +#185#185#186#255#167#167#162#255#128#136#9#255#137#146#0#255#135#144#0#255 + +#136#144#0#255#138#147#0#250#129#137#0#255'ci'#5#157'fl'#0#5'nu'#0#8#0#0#0#6 + +#0#0#0#5'rrr'#6#140#140#140#183#171#171#171#250#174#174#174#255#175#175#175 + +#254#177#177#177#255#161#161#161#255#168#168#168#255#181#181#179#255#178#178 + +#176#255#179#179#177#255#179#179#177#255#179#179#177#255#179#179#177#255#179 + +#179#177#255#179#179#178#255#179#179#179#255#182#182#182#254#166#166#166#251 + +#181#181#181#255#138#138#138'^'#172#172#172#0#166#166#166#0#136#136#136#0#134 + +#134#134#0#127#127#127#0'www'#0'uuu'#0#206#206#206#0#219#219#219#0#173#173 + +#173#200#197#197#197#254#194#194#194#252#194#194#194#255#193#193#193#255#193 + +#193#192#255#191#191#201#255#142#148'1'#255#144#154#0#255#145#153#1#255#145 + +#154#0#255#144#153#0#252#145#155#0#255#142#151#7#202#141#159#0#0#168#184#0#0 + +'48'#0#0'DDD'#0'^^^'#0#140#140#140#183#172#172#172#250#172#172#172#255#160 + +#160#160#254#170#170#170#255#158#158#158#255#171#171#172#255#184#183#193#255 + +#181#180#191#255#182#181#193#255#181#181#192#255#182#181#192#255#181#181#192 + +#255#181#180#192#255#180#180#185#255#176#177#176#255#176#176#177#253#165#165 + +#165#255#175#175#175#231#30#30#30#16'jjj'#2'kkk'#2#147#147#147#2#128#128#128 + +#3'zzz'#3'uuu'#3'yyy'#3#178#178#178#7#181#181#181#0#149#149#149'n'#188#188 + +#188#255#191#191#191#251#191#191#191#254#191#191#191#255#190#190#188#255#194 + +#193#204#255#148#151'R'#255#139#149#0#255#143#152#2#255#142#151#0#255#143#152 + +#0#253#142#151#0#255#147#155#5#226'VkY'#10#168#173'E'#0#162#168'*'#0#0#0#0#0 + ,#0#0#0#0#138#138#138#179#173#173#173#249#167#167#167#255#148#148#148#254#159 + +#159#159#255#146#146#147#255#154#154#149#255#146#149'X'#255#143#147'P'#255 + +#144#147'O'#255#143#147'M'#255#142#147'K'#255#143#147'K'#255#140#145'D'#255 + +#144#147'p'#255#168#168#173#255#163#163#162#252#178#178#178#254#172#172#172 + +#200#0#0#0#0#245#245#245#0'eee'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'vvv'#0#159 + +#159#159#3#142#142#142#0#137#137#137'I'#187#187#187#255#192#192#192#253#191 + +#191#191#253#191#191#191#255#191#191#189#255#195#194#204#255#150#154']'#255 + +#139#148#0#255#143#152#1#255#143#152#0#255#144#153#0#252#142#151#0#255#146 + +#155#1#232#161#168#29#18#154#164#20#0#162#167'*'#0#0#0#0#0#0#0#0#0#131#131 + +#131#156#173#173#173#246#167#167#167#255#159#159#159#253#178#178#177#255#174 + +#174#176#255#171#171#160#255#143#152#3#255#140#150#0#255#141#151#0#255#141 + +#151#0#255#140#150#0#255#142#151#0#255#138#148#0#255#145#150'G'#255#195#195 + +#206#255#192#193#190#252#196#196#196#255#171#171#171#206#255#255#255#2#0#0#0 + +#0#140#140#140#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#129#129#129#0#158#158#158#3 + +#144#144#144#1#140#140#140'N'#187#187#187#254#192#192#192#253#191#191#191#253 + +#192#192#192#255#190#190#188#255#194#194#204#255#149#153'W'#255#140#149#0#255 + +#144#153#2#255#142#151#0#255#144#153#0#253#143#152#0#255#146#155#2#231#177 + +#184')'#18#157#166#25#0#162#171'*'#0#0#0#0#0#0#0#0#0'{{{y'#172#172#172#241 + +#169#169#169#255#155#155#155#254#175#175#174#255#172#172#173#255#172#173#169 + +#255#147#155#25#255#143#152#2#255#144#153#3#255#144#153#2#255#144#153#2#255 + +#144#152#4#255#142#152#2#255#141#146'3'#255#189#189#198#255#190#190#189#253 + +#193#193#193#254#179#179#179#240'EEE'#27'```'#1'zzz'#0#205#205#205#0#0#0#0#0 + +#0#0#0#0#131#131#131#0'zzz'#0#196#196#196#4#201#201#201#0#154#154#154#129#191 + +#191#191#255#191#191#191#251#191#191#191#254#191#191#191#255#191#191#189#255 + +#191#190#201#255#143#148';'#255#142#152#0#255#143#152#1#255#143#152#0#255#143 + +#152#0#252#142#151#0#255#145#154#4#224'''>'#0#8#162#170':'#0#162#170'*'#0#0#0 + +#0#0#0#0#0#0'^^^J'#167#167#167#235#170#170#170#255#155#155#155#253#175#175 + +#175#255#173#173#171#255#174#174#179#255#152#158'.'#255#141#151#0#255#144#153 + +#1#255#144#153#0#255#144#153#0#255#142#151#0#255#144#154#0#255#135#143#13#255 + +#179#179#177#255#194#194#194#254#192#192#191#250#190#190#190#255#150#150#150 + +'~'#184#184#184#0#183#183#183#5#193#193#193#1'ZZZ'#0'```'#0#158#158#158#0'yy' + +'y'#3#189#189#189#1#191#191#191#13#173#173#173#222#193#193#193#254#191#191 + +#191#252#192#192#192#255#190#190#190#255#193#193#193#255#181#181#183#255#136 + +#143#18#255#144#153#0#255#142#151#0#255#144#153#0#254#142#151#0#251#145#154#4 + +#254#155#163#23#196#142#153#13#0#158#167#11#0#162#171'*'#0#0#0#0#0#0#0#0#0#6 + +#6#6#23#164#164#164#220#172#172#172#255#154#154#154#253#175#175#175#255#173 + +#173#169#255#175#174#184#255#162#167'Z'#255#143#152#0#255#143#152#1#255#143 + +#152#0#255#144#153#0#255#143#152#0#255#144#153#1#255#137#147#0#255#156#159'u' + +#255#195#194#202#254#184#184#181#253#185#185#185#252#177#177#177#245#144#144 + +#144'B'#175#175#175#0#175#175#175#0#139#139#139#3#0#0#0#3#165#165#165#2#187 + +#187#187#0#173#173#173#0#140#140#140#162#181#181#181#255#180#180#180#251#182 + +#182#182#255#187#187#187#254#190#190#188#255#196#196#203#255#159#161#127#255 + +#136#146#0#255#144#153#1#255#143#152#0#255#144#153#0#254#141#150#0#250#155 + +#164#26#254#168#175'4'#150#175#181'7'#0#168#176'-'#2#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#162#162#162#195#174#174#174#255#154#154#154#252#174#174#174#255#172 + +#172#171#255#174#173#181#255#171#173#138#255#150#159#10#255#142#151#0#255#144 + +#153#0#255#144#153#0#255#144#153#0#255#143#152#0#255#144#153#0#255#135#142#29 + +#255#173#172#177#254#180#180#179#255#177#177#177#253#181#181#181#254#170#170 + +#170#242#164#164#164'l'#190#190#190#13#4#4#4#0'###'#0#158#158#158#0#169#169 + +#169'.'#160#160#160#175#183#183#183#255#179#179#179#252#179#179#179#254#179 + +#179#179#254#177#177#177#255#186#186#184#255#184#184#192#255#137#143'#'#255 + +#143#153#0#255#143#152#1#255#144#153#0#254#143#152#0#255#143#151#0#251#162 + +#170'('#255#162#170'-S'#166#173'2'#0#163#171')'#2#0#0#0#0#0#0#0#0#0#0#0#0#198 + +#198#198#0#153#153#153#161#174#174#174#254#154#154#154#250#172#172#172#254 + +#173#173#173#255#173#172#174#255#174#173#172#255#162#169'8'#255#144#153#0#255 + +#143#152#0#255#143#152#0#255#143#152#0#255#142#151#0#255#144#153#1#255#139 + +#148#0#255#137#141'N'#255#181#180#191#254#180#180#177#255#177#177#177#253#182 + +#182#182#255#176#176#176#255#175#175#175#224#166#166#166#174#151#151#151#161 + +#156#156#156#195#172#172#172#249#182#182#182#255#179#179#179#252#179#179#179 + +#255#179#179#179#255#178#178#179#254#179#179#175#255#181#180#193#255#142#146 + +'T'#255#140#149#0#255#144#153#1#255#143#152#0#255#143#152#0#255#142#151#0#252 + +#148#157#10#253#165#172'.'#230#189#194'L'#16#165#173'%'#0#160#167'%'#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#161#161#161#0#147#147#147'v'#174#174#174#254#155#155#155 + +#251#170#170#170#255#174#174#174#255#172#173#171#255#173#173#182#255#171#174 + ,'x'#255#153#162#14#255#142#150#0#255#144#153#0#255#143#152#0#255#143#152#0 + +#255#142#151#0#255#145#154#1#255#135#144#0#255#142#145'c'#255#181#180#192#254 + +#181#181#180#255#178#178#176#254#179#179#179#253#180#180#180#255#181#181#181 + +#255#183#183#183#255#183#183#183#255#181#181#181#255#178#178#178#252#179#179 + +#180#255#179#179#179#254#178#178#176#254#181#181#179#255#182#181#193#255#145 + +#148'h'#255#136#145#0#255#145#154#1#255#143#152#0#255#144#153#0#254#144#153#0 + +#254#141#150#0#251#155#163#27#255#168#175'7'#134#180#187'D'#0#167#175'+'#2 + +#159#167'#'#0#0#0#0#0#0#0#0#0#0#0#0#0#148#148#148#0#133#133#133'H'#172#172 + +#172#255#157#157#157#253#167#167#167#254#175#175#175#255#173#173#172#255#173 + +#172#174#255#173#173#170#255#167#173'B'#255#146#155#4#255#142#151#0#255#144 + +#153#0#255#144#153#0#255#143#152#0#255#142#151#0#255#145#154#1#255#137#145#0 + +#255#140#144'R'#255#172#172#178#254#184#183#190#254#181#181#180#254#179#179 + +#176#252#178#178#176#251#178#178#177#251#178#178#177#251#178#178#177#253#179 + +#179#177#254#179#179#176#254#181#181#179#254#183#183#189#255#173#173#181#255 + +#141#145'X'#255#136#145#0#255#145#154#1#255#143#152#0#255#144#153#0#255#144 + +#153#0#255#142#151#0#252#146#155#5#254#166#174'&'#230#168#176'0'#22#164#172 + +'-'#1#160#167'.'#0#160#168'#'#0#0#0#0#0#0#0#0#0#0#0#0#0']]]'#0'RRR'#28#169 + +#169#169#242#162#162#162#255#161#161#161#253#175#175#175#254#173#173#173#255 + +#173#173#171#255#173#173#179#255#173#174#142#255#161#169'$'#255#143#152#0#255 + +#143#152#0#255#144#153#0#255#144#153#0#255#144#153#0#255#143#152#0#255#145 + +#154#1#255#140#149#0#255#134#140' '#255#152#154'z'#255#172#171#176#255#181 + +#180#191#255#184#183#191#255#184#183#188#255#183#183#187#255#184#183#188#255 + +#184#183#190#255#182#181#191#255#173#172#178#255#152#155#127#255#134#140'%' + +#255#139#149#0#255#145#154#0#255#143#152#0#255#144#153#0#255#144#153#0#255 + +#143#152#0#254#142#151#0#251#152#160#18#255#140#146'6f'#149#157'$'#0#151#158 + +'%'#3#161#168','#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#229#229#229#1#249#249#249 + +#2#162#162#162#204#167#167#167#254#157#157#157#252#176#176#176#255#172#172 + +#172#255#173#174#173#255#172#173#171#255#174#173#181#255#171#175's'#255#157 + +#166#23#255#142#151#0#255#143#152#0#255#144#153#0#255#143#152#0#255#144#153#0 + +#255#143#152#0#255#144#153#1#255#144#153#0#255#136#146#0#255#134#141#27#255 + +#142#146'N'#255#151#153'u'#255#157#159#138#255#160#160#145#255#157#159#139 + +#255#151#153'w'#255#142#146'R'#255#134#141#31#255#136#145#0#255#144#153#0#255 + +#144#153#1#255#143#152#0#255#144#153#0#255#143#152#0#255#143#152#0#254#143 + +#152#1#253#147#157#1#255#152#157'F'#236#175#174'M'#16'nk'#163#0#141#143'h'#1 + +#165#172'-'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#187#187#187#8#193#193#193#0#154 + +#154#154#148#171#171#171#254#153#153#153#250#174#174#174#254#173#173#173#255 + +#174#174#174#255#173#173#173#255#173#173#173#255#173#173#178#255#170#174'h' + +#255#156#164#19#255#142#151#0#255#143#152#0#255#144#153#0#255#144#153#0#255 + +#144#153#0#255#143#152#0#255#143#152#1#255#145#154#1#255#145#154#0#255#141 + +#150#0#255#137#146#0#255#135#143#0#255#134#143#0#255#134#143#0#255#136#145#0 + +#255#140#150#0#255#144#154#0#255#145#154#1#255#143#152#1#255#143#152#0#255 + +#144#153#0#255#143#152#0#254#144#153#0#254#143#152#1#255#141#151#0#249#161 + +#167'J'#252#161#161#167#170#232#231#184#0#213#212#229#1'ty%'#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#151#151#151#9#143#143#143#0#135#135#135'S'#175#175 + +#175#255#159#159#159#251#173#173#173#254#173#173#173#254#173#173#173#254#174 + +#174#174#255#173#173#173#255#173#173#173#255#173#173#178#255#170#174'm'#255 + +#157#165#24#255#143#153#0#255#142#151#0#255#144#153#0#255#144#153#0#255#143 + +#152#0#255#144#153#0#255#143#152#0#255#143#152#1#255#144#153#2#255#145#154#2 + +#255#145#154#0#255#145#155#0#255#145#154#0#255#145#154#1#255#144#153#2#255 + +#143#152#1#255#143#152#0#255#144#153#0#255#144#153#0#254#144#153#0#254#144 + +#153#1#255#142#151#0#254#141#151#0#251#166#171'M'#249#186#185#188#255#140#140 + +#142'V'#154#153#175#0#159#159#158#2'sx'#22#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#135#135#135#3'yyy'#0'rrr'#24#174#174#174#247#171#171#171#255#172#172 + +#172#248#179#179#179#250#173#173#173#251#173#173#173#252#173#173#173#253#172 + +#173#172#253#172#173#172#254#173#173#180#254#171#173#130#254#161#168','#255 + +#147#156#2#254#142#151#0#255#143#152#1#255#144#153#1#255#144#153#0#255#144 + +#153#0#255#144#153#0#255#144#153#0#255#143#152#0#255#143#152#0#255#143#152#0 + +#255#143#152#0#255#143#152#0#255#144#153#0#254#144#153#0#254#144#153#0#254 + +#144#153#0#254#143#152#0#253#143#152#0#250#142#152#0#251#148#157#10#255#169 + +#173'g'#255#181#180#187#255#172#172#173#204#146#147#143#16#132#132'~'#0#137 + +#137#137#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#21#21#21#0#183#183 + +#183#1#156#156#156#0#132#132#132'Q'#161#161#161#215#163#163#163#255#185#185 + +#185#255#182#182#182#255#182#182#182#255#180#180#180#255#178#178#178#255#176 + +#176#176#255#174#175#173#253#174#174#182#251#172#173#161#251#165#170'W'#251 + ,#153#162#21#251#145#154#0#251#142#151#0#252#142#151#0#253#142#151#0#253#143 + +#152#0#253#143#152#0#254#143#152#0#254#144#153#0#254#143#153#0#254#143#152#0 + +#254#143#152#0#254#143#152#0#253#143#152#0#251#143#152#0#251#144#153#0#254 + +#145#154#0#255#148#157#9#255#154#161'4'#255#165#167#142#230#179#178#194#161 + +#209#209#209'J'#197#197#194#6#234#234#235#0#173#173#174#0#140#140#140#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'TTT'#0#191#191#191#0'xxx'#1'aaa'#0 + +#214#214#214#11#130#130#130'k'#157#157#157#152#163#163#163#176#166#166#166 + +#201#170#170#170#225#173#173#173#240#176#176#176#252#176#176#176#255#176#176 + +#174#255#178#178#180#255#180#180#186#255#179#180#158#255#170#175'c'#255#159 + +#167'-'#255#152#161#15#255#148#157#4#255#146#155#0#255#145#154#0#255#144#153 + +#0#255#143#152#0#255#143#152#0#255#144#153#0#255#145#154#0#255#143#152#3#255 + +#147#156#7#255#149#157#11#255#147#155#17#255#145#151'"'#224#139#142'W'#160 + +#132#130#156'T'#144#142#186#19#169#168#183#0#0#0#0#0#187#187#186#0#221#221 + +#221#0#167#167#167#0#136#136#136#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#181#181#181#0'|||'#0'rrr'#2#183#183#183#0#142#142#142#0#192 + +#192#192#0#0#0#0#0#0#0#0#0#0#0#0#8'XXX'#25'lll-'#142#142#142'B'#142#142#143 + +'['#153#153#152't'#152#152#150#139#158#158#166#163#163#162#175#184#165#166 + +#156#200#161#163't'#217#155#159'K'#230#150#157'/'#242#150#157'!'#249#151#159 + +#27#252#153#161#26#255#154#161#27#255#152#160#27#253#151#159#29#242#164#171 + +#28#215#152#159'"'#175#143#150'(w~'#131'.:'#13#0#255#10#255#255#0#0#255#255 + +#186#0#0#0#0#0#193#191#209#2#255#255#255#2#220#220#218#0#230#230#230#0#160 + +#160#160#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#142#142#142#0'xxx'#0#208#208#208#0#135#135#135#3#177#177#177#3#255#255 + +#255#1'???'#0' '#0'nnn'#0#127#127#127#0#147#147#147#0#163#163#163#0#181#181 + +#181#0#0#0#0#0#216#216#236#0#0#0#0#0#0#0#0#0'&'#21#255#7'aU'#255#14'b`'#136 + +#26'opS''x|40'#137#142'79'#139#144':<~'#132'-0y|8'#28#238#240#7#6#181#192#3#0 + +#166#173#26#0#130#136')'#0']Z'#132#0#0#0#255#2'h['#208#2#0#0#0#0#197#195#213 + +#0#242#242#247#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#1#170#170#170#1'www'#2#154#154#154#3#166#166#166#4#180 + +#179#180#4#255#255#255#4#184#185#186#4#255#255#255#2#255#255#230#0'5#'#255#0 + +'H2'#255#0'_Z'#171#0'qrV'#0#127#132'8'#0#140#145'<'#0#143#148'?'#0#133#139'0' + +#0'}'#128'9'#0#243#245#8#0#169#179#3#3#166#174#16#4#132#139'#'#3#0#0#0#1#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#143#149','#1 + +'{'#129')'#2'w{3'#2'{'#127'7'#2#129#135'$'#2#0#0#0#1#253#255#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#255#255#255#255#255#255#0#0#255#255#255#255#255#255#0#0#255#255#255#255 + +#255#255#0#0#255#255#255#255#255#255#0#0#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#0#0#255#255#255#255#255#255#0#0#252#0#127#255#255#255#0#0 + +#248#0#0#0#7#255#0#0#224#0#0#0#7#255#0#0#192#0#0#0#3#255#0#0#192#0#0#0#3#255 + ,#0#0#192#0#0#0#3#255#0#0#128#0#0#0#1#255#0#0#128#0#0#0#1#255#0#0#128#0#0#0#0 + +#255#0#0#128#0#0#0#0#15#0#0#128#0#0#0#0#7#0#0#0#0#0#0#0#3#0#0#0#0#0#0#0#1#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#31#0#0#0#0#15#248#0#31#0#0#0#0#31#248#0#31#0#0#0#0 + +#31#252#0#31#0#0#0#0#31#252#0#31#0#0#0#0#31#248#0#31#0#0#128#0#15#248#0#31#0 + +#0#128#0#15#240#0#31#0#0#128#0#3#224#0#31#0#0#128#0#0#0#0'?'#0#0#128#0#0#0#0 + +'?'#0#0#192#0#0#0#0#127#0#0#192#0#0#0#0#127#0#0#192#0#0#0#0#255#0#0#192#0#0#0 + +#0#255#0#0#192#0#0#0#0#255#0#0#224#0#0#0#1#255#0#0#224#0#0#0#7#255#0#0#248#0 + +#0#0#31#255#0#0#255#248#0#1#255#255#0#0#255#255#255#255#255#255#0#0#255#255 + +#255#255#255#255#0#0#255#255#255#255#255#255#0#0#255#255#255#255#255#255#0#0 + +#255#255#255#255#255#255#0#0#255#255#255#255#255#255#0#0#255#255#255#255#255 + +#255#0#0'('#0#0#0' '#0#0#0'@'#0#0#0#1#0' '#0#0#0#0#0#128#16#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'vvv'#0'{{{'#0'ZZZ'#0#143#143#143#2#148#148#148#2#146#146#146#2 + +#146#146#146#2#146#146#146#2'nnn'#2#0#0#0#0#0#0#0#0'fff'#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#187#187#187#0'[[[' + +#0'{{{'#2'aaa'#0#141#141#141#0#140#140#140#0#141#141#141#0#141#141#141#0#141 + +#141#141#0#139#139#139#0'ccc'#0'aa`'#3'lko'#2#147#148'y'#3'y|O'#3'oq<'#3'uxE' + +#3#139#141'j'#3#165#166#153#3#173#173#173#3#171#171#171#3#172#172#172#3#174 + +#174#174#3#149#149#149#1#164#164#164#0#166#166#166#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#138#138#138#0#161#161#161#1'SSS'#2'ooo'#0'WWW'#10#133#133 + +#133'.'#137#137#137','#135#135#135'-'#135#135#135'-'#135#135#135','#134#134 + +#134',\\Y'#2'YYO'#0'nnj'#0#137#137'y'#0'qrP'#0'fh;'#0'kmE'#0#130#130'k'#0#166 + +#166#169#0#195#193#215#0#193#192#208#0#180#180#182#0#180#180#179#0#151#151 + +#151#0#157#157#157#0#157#157#157#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#141#141#141#1#158#158#158#0#159#159#159#0#135#135#135'O'#146#146#146#214#167 + +#167#167#254#170#170#170#254#169#169#169#255#170#170#170#255#170#170#170#253 + +#172#172#172#255#155#155#157#197#164#164#171#153#159#158#163#156#142#141#137 + +#153'yyj'#146'ss]'#147'wxd'#147#133#133'|'#147#152#152#157#147#166#166#179 + +#147#168#167#176#146#161#161#160#144#158#158#156#147#139#139#139'&'#143#143 + +#143#0#153#153#153#1#143#143#143#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#150#150 + +#150#3#145#145#145#27#163#163#163#164#164#164#164#255#159#159#159#255#172#172 + +#172#254#171#171#171#255#172#172#172#255#172#172#172#255#171#171#170#255#175 + +#175#176#255#155#155#148#255'~'#129'Y'#255'rv*'#255'sx'#21#255'u|'#12#255'v}' + +#8#255'v|'#10#255'v{'#17#255'y~%'#255#131#134'K'#255#152#153#132#255#172#172 + +#176#255#177#177#182#255#157#157#156#156#191#191#191#0#187#187#187#2#151#151 + +#156#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#159#159#159#0#151#151#151#138#164#164 + +#164#255#163#163#163#251#158#158#158#253#173#173#173#254#170#170#170#254#171 + +#171#171#254#171#171#171#254#170#169#167#254#177#176#184#254#137#140'_'#252 + +'u}'#0#251#141#150#0#251#146#156#0#251#148#157#0#251#148#158#0#251#148#158#0 + +#251#147#156#0#251#143#153#0#251#136#145#0#251#127#135#0#251#129#135'%'#249 + +#157#157#137#251#172#171#183#241#160#160#158#20#146#145#153#0#151#150#169#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#201#201#201#0#157#157#157#181#167#167#167#252 + +#161#161#161#251#160#160#160#255#173#173#173#254#173#173#173#255#176#176#176 + +#255#176#176#176#255#173#173#170#255#174#174#184#255#154#157'i'#255#145#155#3 + +#255#145#154#5#255#144#153#0#255#142#151#0#255#140#150#0#255#141#150#0#255 + +#143#152#0#255#145#155#0#255#147#156#0#255#148#157#0#255#144#154#0#254#133 + +#142#0#251#146#150'X'#255#150#150#156'r'#163#164#158#0#166#167#151#3'ttr'#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#244#244#244#5#160#160#160#213#166#166#166#255#160#160 + +#160#253#163#163#163#255#178#178#178#255#178#178#178#255#179#179#179#255#179 + +#179#179#255#178#178#176#255#181#180#189#255#154#156'p'#255#135#145#0#255#140 + +#150#0#255#139#148#5#255#146#153'('#255#151#156'<'#255#149#155';'#255#142#148 + +'"'#255#135#143#6#255#136#144#11#255#136#144#15#255#136#144#19#255#140#147#22 + +#252#133#141#22#254'}'#127'Q'#215'bg;'#2'lpA'#0'vvt'#0'EEE'#0'777'#0#0#0#0#0 + +']]].'#162#162#162#232#169#169#169#255#163#163#163#254#168#168#168#255#181 + +#181#181#255#178#178#178#255#179#179#179#255#179#179#179#255#178#178#178#255 + +#183#183#184#255#158#158#151#255#137#139'l'#255#140#142'e'#255#141#142'}'#255 + +#147#146#152#255#155#155#164#255#154#153#163#255#140#140#144#255#131#131'{' + ,#255#147#147#142#255#147#148#146#255#146#146#146#254#146#145#149#254#144#144 + +#148#252#142#142#140#255'ut~'#149'{z'#136#11#138#138#137#12''''''''#2'LLL'#2 + +#255#255#255#1#133#133#133'`'#164#164#164#244#175#175#175#255#167#167#167#253 + +#170#170#170#255#180#180#180#255#178#178#178#255#180#180#180#255#179#179#179 + +#255#179#179#179#255#182#182#182#255#162#162#163#255#152#152#158#255#150#150 + +#158#255#130#129#133#254#132#132#130#254#137#137#134#254#141#141#138#254#138 + +#138#137#254#136#136#138#254#136#136#137#255#132#132#132#254#133#133#132#255 + +'zzy'#255#143#143#142#254#163#163#163#253#160#160#157#255#164#165#162#224#166 + +#166#166#225#148#148#148#160#197#197#197#0#173#173#173#5#141#141#141#145#169 + +#169#169#249#175#175#175#255#167#167#167#254#169#169#169#255#181#181#181#255 + +#179#179#179#255#179#179#179#255#180#180#180#255#178#178#178#255#182#182#182 + +#254#163#163#162#255#143#143#141#254#140#140#137#251#147#147#146#251#156#156 + +#156#251#155#155#155#251#159#159#159#252#151#151#150#253'yyx'#253#127#127'~' + +#255#127#128#127#254'}}|'#255#139#139#139#254#174#173#176#255#177#176#180#254 + +#176#175#179#252#175#175#179#255#176#175#177#255#171#171#172#255#151#151#153 + +'|'#154#154#154#6#150#150#150#186#172#172#172#251#174#174#174#255#167#167#167 + +#255#168#168#168#255#182#182#182#255#178#178#179#255#179#179#179#255#179#179 + +#179#255#178#178#178#255#181#181#181#255#168#168#168#255#177#177#177#255#154 + +#154#154#255#133#133#133#255#135#135#135#255#132#132#132#255'{{{'#255'vvv' + +#255'rrr'#255'www'#255'www'#255'~~'#127#254#163#163#160#255#161#162#148#254 + +#159#160#147#254#160#161#146#254#157#157#144#253#155#155#155#229#157#157#157 + +#225#154#154#151#236'~~~l'#154#154#154#207#173#173#173#252#176#176#176#255 + +#169#169#169#254#169#169#168#255#182#182#180#255#179#179#177#255#180#180#178 + +#255#180#180#178#255#179#179#178#255#181#181#181#254#172#172#172#254#184#184 + +#184#251#137#137#137#142'mmms|||giiiZ'#182#182#182'K'#182#182#182'B'#161#161 + +#161#212#178#178#178#255#179#179#178#251#186#186#188#255#172#173#163#255#133 + +#141#9#255#138#147#2#254#139#148#2#252#131#139#1#254'ou'#13'Ylr'#6#10'rx'#7 + +#14'lll'#14#155#155#155#210#172#172#172#253#168#168#168#255#162#162#162#255 + +#168#168#170#255#181#180#190#255#178#178#187#255#179#179#188#255#179#178#187 + +#255#178#177#184#255#177#177#176#250#170#170#170#254#168#168#168#188#219#219 + +#219#0#223#223#223#0'555'#0'qqq'#0#183#183#183#0#186#186#186#0#164#164#164'c' + +#192#192#192#255#194#194#193#250#194#194#192#254#190#189#196#255#144#151'"' + +#255#143#153#0#255#144#152#0#250#145#154#0#255#148#157#6'y'#147#156#1#0#146 + +#156#0#0'ppp'#0#155#155#155#203#170#170#170#252#157#157#155#255#161#161#165 + +#254#156#157#135#255#144#150'7'#255#144#150'6'#255#144#150'4'#255#143#149'1' + +#255#145#149'P'#255#174#174#178#249#179#179#178#254#170#170#170#144#196#196 + +#196#4#195#195#195#5#154#154#154#3'~~~'#3#155#155#155#4#155#155#155#2#151#151 + +#151';'#186#186#186#254#191#191#191#252#191#191#189#253#190#190#198#255#145 + +#151'/'#255#141#151#0#254#143#151#1#251#143#152#0#255#146#156#3#136#145#154#0 + +#0#145#154#0#4#0#0#0#0#152#152#152#172#169#169#169#251#163#163#160#255#178 + +#178#185#255#168#169#138#255#141#151#0#255#142#152#0#255#142#151#0#255#142 + +#152#0#255#142#150#25#255#189#189#194#250#195#195#194#255#174#174#173#177#232 + +#232#232#0#211#211#211#3#189#189#189#0#138#138#138#0#178#178#178#3#178#178 + +#178#0#159#159#159'V'#190#190#190#255#191#191#191#250#192#192#191#254#188#187 + +#193#255#142#149#30#255#143#152#0#255#143#152#0#250#143#152#0#254#146#155#6 + +#129#143#153#0#0#144#153#0#4#0#0#0#0#143#143#143'y'#169#169#169#248#161#161 + +#161#255#174#174#177#254#171#171#160#255#146#155#13#255#142#151#2#255#143#152 + +#2#255#144#154#2#255#138#147#5#255#175#176#160#253#195#195#198#252#182#182 + +#181#246#146#146#146'.'#166#166#166#0#185#185#185#0'xxx'#1#209#209#209#0#196 + +#196#196#0#171#171#171#195#188#188#188#254#189#189#188#251#195#195#197#255 + +#176#177#164#255#137#146#3#255#144#153#0#254#142#151#0#251#148#157#11#255#164 + +#171'%_'#161#168'$'#0#159#166#30#3#0#0#0#0'mmm='#168#168#168#236#162#162#162 + +#255#173#173#172#253#175#174#180#255#158#164':'#255#141#151#0#255#144#153#1 + +#255#144#152#2#255#141#150#0#255#149#154'M'#255#183#182#194#252#179#179#174 + +#255#170#170#170#224#180#180#180'G'#180#180#180#5#189#189#189#0#171#171#171 + +'#'#155#155#155#168#179#179#179#255#178#178#178#252#179#179#174#255#190#189 + +#201#254#151#156'O'#255#140#149#0#254#144#153#2#254#142#151#0#254#157#165#30 + +#248#163#168'D%'#177#184'H'#0#165#173','#1#0#0#0#0#225#225#225#10#167#167#167 + +#216#162#162#162#255#172#172#170#253#174#173#182#255#170#172'{'#255#146#156#2 + +#255#142#151#1#255#143#152#0#255#144#153#1#255#136#145#1#254#155#157'~'#255 + +#183#183#193#253#181#181#177#255#173#173#171#255#164#164#164#213#183#183#182 + +#201#175#175#175#243#181#181#181#255#178#178#176#252#179#179#175#255#183#182 + +#194#254#157#159'}'#255#138#147#2#255#144#153#1#255#142#151#0#251#145#154#4 + +#254#163#171'*'#191'|'#130' '#0#162#170'('#1#154#165#0#0#0#0#0#0#221#221#221 + ,#0#165#165#165#181#163#163#163#254#171#171#170#252#173#173#174#254#174#174 + +#174#255#162#168'8'#255#142#151#0#255#143#152#1#255#143#152#0#255#144#153#1 + +#254#137#146#7#254#154#156's'#255#179#178#189#253#184#184#191#253#184#184#185 + +#255#179#179#178#255#182#182#181#255#181#181#181#251#182#182#188#255#179#179 + +#189#254#154#157'u'#254#138#147#7#255#144#153#0#254#143#152#0#254#142#151#0 + +#252#153#161#16#253#163#170'7E'#175#182'8'#0#163#170'('#2#162#171#25#0#0#0#0 + +#0#172#172#172#0#162#162#162#132#163#163#163#254#168#168#168#251#174#174#173 + +#255#173#173#179#255#173#174#146#255#155#163#21#255#141#150#0#255#144#153#1 + +#255#143#152#0#255#144#153#0#255#139#148#0#254#142#148'7'#254#159#161#128#254 + +#170#170#166#252#175#175#179#251#175#174#178#253#170#170#167#254#159#160#129 + +#254#143#148'9'#254#139#148#0#255#144#153#0#255#143#152#0#255#143#152#2#251 + +#144#154#0#254#150#157'('#182#148#157#25#0#166#174#30#1#160#168'%'#0#164#172 + +'%'#0#0#0#0#0#156#156#156#0#150#150#150'I'#165#165#165#254#164#164#164#252 + +#174#174#175#254#173#173#171#254#173#173#181#254#171#175#128#255#152#161#13 + +#255#141#150#0#255#143#152#1#255#144#153#1#255#145#154#1#255#142#152#0#255 + +#138#147#0#255#138#146#12#255#139#146#29#255#139#146#30#255#138#145#13#255 + +#138#147#0#255#142#152#0#254#144#153#1#254#143#152#0#254#143#152#0#253#140 + +#150#0#248#158#164'@'#255#155#155#162'\'#169#170#158#0#166#168#132#3#163#171 + +'0'#0#0#0#0#0#0#0#0#0#154#154#154#0#146#146#146#18#169#169#169#244#170#170 + +#170#255#176#176#176#251#172#172#172#251#172#172#171#251#173#172#183#251#171 + +#174#132#251#154#162#24#252#141#151#0#253#142#151#0#254#143#152#1#254#144#153 + +#1#254#145#154#1#254#144#154#0#255#144#153#0#254#144#153#0#254#144#154#0#254 + +#145#154#0#254#144#152#1#252#143#152#0#251#143#152#0#254#143#153#0#255#164 + +#169'K'#255#178#178#179#242#134#133#145#19#142#141#167#0#158#156#196#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#193#193#193#4#186#186#186#0#165#165#165'g'#158#158#158#236 + +#178#178#178#255#179#179#179#255#177#177#177#255#177#177#175#255#176#175#183 + +#255#175#175#159#255#164#169'N'#255#150#158#13#255#143#153#0#255#143#152#0 + +#254#143#152#0#252#142#152#0#252#142#151#0#252#142#151#0#252#142#152#0#253 + +#143#152#0#255#144#153#0#255#146#155#3#255#147#155#27#255#158#162'd'#217#172 + +#170#188#142#167#167#178'0'#141#141#133#0#160#161#142#0#160#159#181#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0'{{{'#1#151#151#151#0'jjj'#25#150#150#150'L'#152#152 + +#152'f'#168#168#168#129#162#162#162#157#170#170#168#183#170#170#175#205#174 + +#173#182#224#170#172#143#240#161#166'T'#250#152#159'('#255#148#156#19#255#147 + +#156#12#255#148#157#11#255#148#156#11#255#149#157#13#255#149#157#17#241#144 + +#152#21#201#135#141'('#136'y{Y@ljv'#6#173#170#203#0#228#227#231#0#0#0#0#0#155 + +#156#152#0#153#153#153#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#130#130#130#0#166 + +#166#166#2'kkk'#0#166#166#166#0#180#180#180#0#178#178#178#0#251#252#252#0#202 + +#202#199#0#0#0#0#0#18#20#0#8'wr'#188#22#148#144#210'%'#149#149#150'3'#137#141 + +'OC'#140#146'.P'#149#156'-Y'#146#152'+T'#149#155'-<'#136#140':'#25'ruD'#0'y|' + +'('#0'JU'#0#0#138#169#0#0#181#177#215#3#215#215#220#2#247#247#253#0#169#169 + +#169#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#150#150#150#0#165#165#165#0'g' + +'gg'#1#167#167#167#3#184#184#184#3#185#185#185#3#255#255#255#2#200#200#199#1 + +#0#0#0#0#0#0#0#0#135#131#215#0#156#152#213#0#151#150#146#0#149#155'E'#0#148 + +#154'+'#0#157#164'*'#0#153#160')'#0#155#162'.'#0#150#156'5'#0'sv@'#0'x{+'#3 + +#128#136#6#2'tx-'#0#193#191#211#0#218#218#221#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#145#144#147#2#131#130#134#2#149#156'5' + +#3#154#161'"'#3#160#168'"'#3#156#164' '#3#153#160'#'#2#0#0#0#1#0#0#0#0#138 + +#143'&'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#240 + +#0#0#255#192#0#0#127#128#0#0#127#128#0#0'?'#128#0#0'?'#128#0#0#31#0#0#0#3#0#0 + +#0#1#0#0#0#0#0#0'`'#7#0#7#224#7#0#7#240#7#0#7#224#7#0#7#224#7#128#3#192#15 + +#128#0#0#15#128#0#0#31#128#0#0#31#192#0#0#31#192#0#0'?'#192#0#0#127#248#0#3 + +#255#255#254'?'#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255'('#0#0#0#24#0#0#0'0'#0#0#0#1#0' '#0#0#0#0#0'`'#9#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#167#167#167 + +#0#165#165#165#0#0#0#0#1#177#177#177#2#179#179#179#2#179#179#179#2#181#181 + +#181#2#0#0#0#1#193#193#193#0#183#183#183#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'ccc'#0 + +#155#155#155#0#145#145#145#2#129#129#129#0#160#160#160#0#161#161#161#0#161 + +#161#161#0#163#163#163#0#145#145#145#0#164#164#173#0#198#196#225#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#255#0#0#0#0#0#133#133#133#0'{{{'#0'LLL'#0#184#184 + +#184#0#0#0#0#0#0#0#0#0#0#0#0#0#142#142#142#0#163#163#163#0#130#130#130#0'{{{' + +'$'#153#153#153'H'#154#154#154'E'#153#153#153'E'#155#155#155'H'#138#139#138 + +'&'#162#162#170#0#216#213#255#0#0#0#0#0#3','#0#0#0#0#0#0#0#0#0#0'V`'#0#0#0#0 + +#0#0#0#0#0#0#218#218#216#0#238#238#233#0#172#172#172#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#154#154#154#2#162#162#162#11#150#150#150'~'#156#156#156#246#171#171#171 + +#255#171#171#171#255#170#170#170#255#173#173#173#255#163#163#164#247#151#151 + +#144#215#135#137'h'#216'tx;'#212'qu.'#211'uy<'#211#130#133']'#211#151#152#142 + +#211#169#169#179#209#170#169#174#211#147#147#146'1'#152#152#151#0#168#168#168 + +#1#156#157#145#0#0#0#0#0#0#0#0#0#198#198#198#0#157#157#157#171#164#164#164 + +#255#162#162#162#254#172#172#172#252#170#170#170#253#170#170#168#253#175#175 + +#180#252#151#152#131#255'sz'#8#255#130#138#0#255#137#146#0#255#139#148#0#255 + +#137#146#0#255#133#141#0#255#131#138#15#255#139#143'A'#255#163#163#150#255 + +#166#165#175#159#196#196#200#0#187#187#187#2#145#146'x'#0#147#147#147#0#0#0#0 + +#0#204#204#204#13#163#163#163#226#163#163#163#252#162#162#162#252#174#174#174 + +#255#176#176#176#254#175#175#174#254#177#176#185#255#158#160'z'#254#143#153#0 + +#253#147#157#0#253#144#153#0#253#143#153#0#253#144#154#0#253#147#156#0#253 + +#145#155#0#253#139#150#0#251#135#144#0#253#146#150'Z'#243#172#169#213#20#167 + +#166#201#2#150#152#131#4#147#147#147#1#0#0#0#0'wwwC'#164#164#164#239#163#163 + +#163#254#167#167#167#253#180#180#180#254#179#179#179#255#179#179#178#255#183 + +#182#187#255#163#164#146#255#134#140'%'#255#138#144'('#255#146#150'Y'#255#156 + +#158'v'#255#147#150'e'#255#132#136'<'#255#140#144'F'#255#142#146'O'#254#143 + +#148'M'#252#135#138'P'#255'tti'#139'yzh'#0#129#131'g'#0#129#129#129#0#161#161 + +#161#1#145#145#145#127#168#168#168#248#169#169#169#255#171#171#171#254#181 + +#181#181#255#178#178#178#255#178#178#178#255#182#182#181#254#167#167#169#255 + +#147#146#155#254#141#140#149#252#135#134#146#252#144#144#153#252#144#144#154 + +#251#136#135#147#253#141#140#152#255#139#139#150#254#130#129#142#254#149#149 + +#155#254#157#157#156#255#154#154#156#177#154#154#159#164#129#129#129#24#135 + +#135#133#0#151#151#151#179#172#172#172#252#170#170#170#255#170#170#170#254 + +#180#180#180#255#178#178#179#255#178#178#178#255#181#181#182#255#169#169#169 + +#255#149#149#148#255#139#139#138#255#149#149#147#255#148#148#147#255#144#144 + +#142#255'zzx'#255'vvt'#255'ttr'#255#138#138#137#255#175#174#186#255#175#175 + +#187#254#175#174#184#255#175#175#181#255#162#161#169#213#161#161#169','#158 + +#158#158#214#174#174#174#253#171#171#171#255#170#170#170#255#181#181#179#255 + +#179#179#177#255#179#179#178#255#181#181#180#254#175#175#175#255#178#178#178 + +#253#149#149#149#215'zzz'#204#131#131#131#193#151#151#151#177#135#135#135#232 + +#145#145#144#255#150#150#153#253#164#165#154#255#146#151'L'#254#148#153'I' + +#254#142#146'J'#250#127#129'_'#135#127#129'Z'#131'wzMN'#161#161#161#223#171 + +#171#171#254#164#164#164#255#169#168#171#254#180#179#187#255#177#177#185#255 + +#178#177#184#255#177#177#179#251#173#173#172#255#168#168#168#163#190#190#190 + +#0#170#170#170#0#192#192#192#0#187#187#187#0#170#170#170']'#194#194#194#255 + +#198#198#200#252#185#185#181#254#139#148#4#254#141#151#0#253#140#150#0#254 + +#136#144#0'.'#136#145#0#0#139#148#0#0#163#163#163#214#164#164#163#253#163#162 + +#169#255#158#160'}'#255#144#150')'#255#145#151'*'#255#141#148'$'#255#160#162 + +'|'#251#184#183#190#254#170#170#167'n'#183#183#183#0#190#190#190#3#192#192 + +#192#3#164#164#164#4#157#157#157'.'#188#188#188#254#191#192#191#254#188#188 + +#191#253#144#152#29#255#143#152#2#252#144#153#2#254#148#157#5'Q'#146#156#0#3 + +#147#157#0#4#159#159#159#176#165#165#163#252#173#172#181#255#167#170#129#254 + +#141#150#0#255#143#152#0#255#139#149#0#255#158#162'V'#251#198#197#210#255#177 + +#177#172#177#207#207#207#0#204#204#204#0#194#194#194#0#188#188#188#0#167#167 + +#167'n'#189#189#189#255#195#194#197#251#182#182#176#254#140#149#8#254#143#152 + +#0#253#145#154#4#255#160#167#27'>'#154#162#20#0#152#161#14#2#154#154#154'r' + +#164#164#164#247#169#169#171#255#174#174#166#254#148#156#16#255#142#151#2#255 + +#143#153#1#255#142#149#21#254#179#178#182#252#182#182#184#255#157#157#155'|' + +#159#159#159#13#168#168#168#5#170#170#170'O'#176#176#175#240#179#180#176#253 + +#191#190#206#253#161#164'j'#255#139#149#0#253#142#151#0#254#154#163#24#241 + +#153#160'E'#19#178#184'N'#0#171#179'0'#0#148#148#148'+'#164#164#164#234#168 + +#168#166#255#176#175#185#253#163#168'Q'#255#141#151#0#255#144#153#2#255#141 + ,#150#0#255#145#150'C'#254#179#178#191#254#183#183#189#255#175#175#174#232#174 + +#175#173#222#176#176#175#255#181#181#182#255#183#182#197#254#163#164#141#255 + +#139#148#8#255#143#152#0#251#145#154#2#255#161#168'&'#166#137#147#20#0#152 + +#160#27#2#171#178'/'#0#211#211#211#0#163#163#163#205#166#166#165#254#174#174 + +#178#252#174#175#162#254#154#162#25#255#140#150#0#255#145#153#3#254#140#150#0 + +#255#143#149'1'#254#166#167#148#253#178#178#184#255#180#180#190#255#179#179 + +#189#254#173#173#172#254#155#158'i'#255#139#147#6#254#144#153#0#254#141#151#0 + +#252#147#156#8#246#164#173'.%'#162#169')'#0#163#171'%'#1#166#174'%'#0#174#174 + +#174#0#161#161#161#158#165#165#165#254#173#173#171#248#173#172#180#252#172 + +#174#137#253#150#159#11#253#140#150#0#254#144#153#2#254#143#152#0#254#139#148 + +#0#254#143#150' '#253#146#152'7'#252#145#150'0'#254#140#148#16#254#140#149#0 + +#254#144#153#0#252#140#150#0#249#147#156#7#255#159#162'c'#186#177#187'K'#0 + +#171#177'\'#1#164#172')'#0#0#0#0#0#174#174#174#0#167#167#167'P'#168#168#168 + +#255#176#176#176#255#174#175#173#255#175#175#183#255#172#174#143#255#154#162 + +'$'#255#142#152#0#254#142#151#0#253#144#153#0#252#143#152#0#251#142#151#0#251 + +#142#152#0#251#143#153#0#254#144#153#0#255#143#153#1#255#148#156#28#255#170 + +#172#135#239#173#171#196'O'#178#176#196#1#188#189#188#1#163#170'('#0#0#0#0#0 + +#187#187#187#1#163#163#163#1#135#135#135'T'#167#167#167#163#174#174#174#189 + +#170#170#168#213#174#174#182#233#173#173#169#248#166#170'f'#255#153#160'(' + +#255#147#155#13#255#145#154#7#255#146#155#6#255#146#154#7#255#146#155#8#255 + +#143#151#13#233#142#149'('#175#147#150'rb'#151#152#145#24#165#165#171#0#148 + +#149#138#0#188#188#186#0#0#0#0#0#0#0#0#0#190#190#190#0#188#188#188#0#169#169 + +#169#0#186#186#186#0#212#212#213#0#1#1#7#0'y|H'#12#127#127#138#28#170#166#231 + +'.'#161#161#164'A'#152#156'NS'#144#151'&b'#150#157'"k'#146#153'#_'#141#147'$' + +'9'#130#135'('#15'E>'#146#0#182#181#191#0#187#173#255#0#170#169#183#0#160#159 + +#165#0#189#190#184#0#0#0#0#0#0#0#0#0#204#204#204#0#0#0#0#0'uuu'#2#180#180#180 + +#2#207#207#207#1'BBC'#0#142#143#137#0#144#143#152#0#172#169#213#0#166#167#155 + +#0#155#160'B'#0#153#161#30#0#154#162#28#0#151#159#30#0#149#156'#'#0#130#134 + +')'#0'][^'#1'}'#132#22#2'dp'#0#0#195#195#199#0#183#183#185#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#180#180#179 + +#1#188#187#196#2#174#176#138#2#161#169''''#2#152#160#27#3#155#163#23#3#155 + +#164#24#3#159#167#27#2#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#192#0'?'#0#128#0#31#0#128#0#31#0#128#0 + +#15#0#0#0#3#0#0#0#1#0#0#0#1#0#0'<'#7#0#0'>'#3#0#0'<'#7#0#0#28#7#0#128#0#7#0 + +#128#0#15#0#128#0#15#0#128#0#31#0#192#0'?'#0#255#195#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0'('#0#0#0#16#0#0#0' '#0#0#0#1#0' '#0#0#0#0#0'@'#4#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#180#180#180#0#215#215#215#0#0#0#0#6#176#176 + +#176#9#177#177#177#9#170#170#170#7#205#205#206#4#181#182#176#4#148#149#127#3 + +#167#168#165#3#169#169#170#4#0#0#0#3#0#0#0#0#159#159#159#0#152#152#152#0#0#0 + +#0#0#161#161#161#0#172#172#172#1#150#150#150#0#167#167#168#0#167#167#166#0 + +#169#169#174#0#191#189#228#0#156#154#181#0'hf~'#0#141#138#191#0#182#178#255#0 + +#158#158#158#0#138#138#138#0#138#138#136#0#147#147#147#0#0#0#0#0#164#164#164 + +#0#168#168#168#0#147#147#147'F'#164#164#164'd'#164#164#163'd'#161#161#164'T' + +#180#179#203')'#159#157#176'''jh~%'#135#132#176'%'#171#167#233'&'#159#159#172 + +'"~~w'#0#130#132'h'#0#144#147'^'#0#0#0#0#0#152#152#152#17#160#160#160#165#162 + +#162#162#255#171#171#171#255#172#172#174#255#163#163#157#255#135#139'B'#254 + +#131#138#29#253#128#134#13#252#132#138' '#252#143#147'N'#250#163#164#152#248 + +#160#159#166'8'#167#165#186#3#173#173#182#4#0#0#0#0#152#152#152'\'#162#162 + +#162#254#166#166#166#252#176#176#175#250#178#177#183#250#164#165#145#251#136 + +#146#0#254#145#154#0#254#147#155#16#255#142#151#0#255#138#148#0#250#141#148 + +#26#255#143#146'f'#160#153#159'I'#0#149#155'G'#0#251#251#251#2#157#157#157 + +#161#166#166#166#250#172#172#172#254#180#180#180#255#181#181#182#254#172#172 + +#170#255#141#143'q'#253#140#141'}'#252#149#149#149#254#137#138'}'#253#139#140 + +'}'#254#137#138'z'#253#144#145#133#247#146#149'r{'#145#147'oA'#154#154#157#0 + +#163#163#163#212#172#172#172#253#173#173#173#255#180#180#180#254#180#180#180 + +#255#176#176#176#255#153#153#159#255#137#137#140#255#141#141#141#255#129#129 + +#132#255'zz~'#255#141#141#142#254#167#168#161#254#165#165#165#255#158#158#173 + +#228#163#162#157'Z'#167#167#167#235#169#169#168#253#170#170#172#255#178#178 + +#180#255#177#177#179#252#176#176#175#254#167#167#166#159#155#155#153'A'#169 + +#169#169'1'#161#161#158's'#181#181#184#254#178#179#162#251#141#149#13#254#139 + +#148#7#232'{'#129#29'%'#148#155#19#29#163#163#158#225#166#165#174#254#158#161 + ,'o'#255#143#151#29#254#144#151'%'#250#180#180#176#255#177#177#180'U'#193#193 + +#199#0#180#180#179#0#170#170#167')'#194#194#195#255#186#187#179#253#143#151#7 + +#254#144#153#0#244#158#167#12#24#154#163#18#0#160#160#153#173#168#168#175#252 + +#168#170#128#255#142#152#0#255#139#149#0#253#170#172#133#254#183#183#196#207 + +#187#187#186'('#184#184#181#27#172#172#166#176#188#187#200#254#169#171#127 + +#250#139#149#0#254#151#159#17#221#137#144'7'#7#133#142#19#2#153#153#152'a' + +#165#165#165#244#174#174#176#254#154#161'*'#254#141#150#0#255#142#150#23#254 + +#167#169#146#255#175#174#184#247#179#179#189#241#181#180#191#255#167#168#146 + +#254#142#150#18#248#143#152#0#253#154#162#26#133#138#147#10#0#149#158#14#8 + +#163#163#163#18#166#166#164#230#173#173#178#255#172#173#148#253#149#158#18 + +#252#140#150#0#251#140#149#0#248#151#157'>'#253#155#159'U'#254#149#155'8'#248 + +#140#149#0#253#142#152#0#255#152#159'-'#253#164#168#128#23#176#176#138#0#165 + +#169'i'#2#176#176#176#0#153#153#153'~'#170#170#168#232#174#174#180#247#171 + +#173#151#255#156#162';'#255#146#155#12#255#142#152#0#255#142#151#0#255#143 + +#152#0#255#143#152#8#251#150#156'3'#204#166#168#137'k'#180#186#144#0#183#184 + +#142#1#150#167#0#0#255#255#255#1#0#0#0#0'ssw'#14#145#146#134'"'#155#154#173 + +'7'#175#174#189'M'#159#163'Pb'#145#152'"s'#149#156#29'y'#149#156#30'^'#140 + +#146'&+'#143#148';'#0#153#161'('#0'jW='#0#186#187't'#0#143#160#0#0#208#208 + +#208#0'III'#2#0#0#0#0#161#161#154#0#170#168#200#0#179#177#200#0#159#163'T'#0 + +#149#157#17#0#150#158#14#0#148#156#18#0#140#146')'#0#143#147'G'#0#162#168'<' + +#3'}ci'#0#165#173'A'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2#187#187#185#4#183#183 + +#188#6#181#181#169#8#162#168'E'#9#149#157#9#10#148#157#10#10#145#154#1#9#144 + +#151#25#5#151#159#29#0#157#165#28#0#155#160'N'#0#0#0#0#0#0#0#0#0#255#255#0#0 + +#255#255#0#0#227#255#0#0#128#15#0#0#0#7#0#0#0#3#0#0#0#0#0#0#1#131#0#0#1#195#0 + +#0#1#131#0#0#0#3#0#0#128#7#0#0#128#7#0#0#252'?'#0#0#255#255#0#0#255#255#0#0 +]); + diff --git a/dcm2nii/dcm2niigui.manifest b/dcm2nii/dcm2niigui.manifest new file mode 100755 index 0000000..07fb624 --- /dev/null +++ b/dcm2nii/dcm2niigui.manifest @@ -0,0 +1,17 @@ +<?xml version="1.0" encoding="UTF-8" standalone="yes"?> +<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> + <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="CompanyName.ProductName.YourApp" type="win32"/> + <description>Your application description here.</description> + <dependency> + <dependentAssembly> + <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="*" publicKeyToken="6595b64144ccf1df" language="*"/> + </dependentAssembly> + </dependency> + <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3"> + <security> + <requestedPrivileges> + <requestedExecutionLevel level="asInvoker" uiAccess="false"/> + </requestedPrivileges> + </security> + </trustInfo> +</assembly> \ No newline at end of file diff --git a/dcm2nii/dcm2niigui.o b/dcm2nii/dcm2niigui.o new file mode 100644 index 0000000..f8d6c8a Binary files /dev/null and b/dcm2nii/dcm2niigui.o differ diff --git a/dcm2nii/dcm2niigui.or b/dcm2nii/dcm2niigui.or new file mode 100644 index 0000000..420bf77 Binary files /dev/null and b/dcm2nii/dcm2niigui.or differ diff --git a/dcm2nii/dcm2niigui.rc b/dcm2nii/dcm2niigui.rc new file mode 100755 index 0000000..71b1938 --- /dev/null +++ b/dcm2nii/dcm2niigui.rc @@ -0,0 +1,7 @@ +#define RT_MANIFEST 24 +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#define ISOLATIONAWARE_MANIFEST_RESOURCE_ID 2 +#define ISOLATIONAWARE_NOSTATICIMPORT_MANIFEST_RESOURCE_ID 3 + +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "dcm2niigui.manifest" +MAINICON ICON "dcm2niigui.ico" diff --git a/dcm2nii/dcm2niigui.res b/dcm2nii/dcm2niigui.res new file mode 100755 index 0000000..7fb88fb Binary files /dev/null and b/dcm2nii/dcm2niigui.res differ diff --git a/dcm2nii/dialogs_msg.o b/dcm2nii/dialogs_msg.o new file mode 100644 index 0000000..8cf229f Binary files /dev/null and b/dcm2nii/dialogs_msg.o differ diff --git a/dcm2nii/dialogs_msg.pas b/dcm2nii/dialogs_msg.pas new file mode 100755 index 0000000..03656ce --- /dev/null +++ b/dcm2nii/dialogs_msg.pas @@ -0,0 +1,27 @@ +unit dialogs_msg; +{$ifdef fpc}{$mode delphi}{$endif} +{$Include ..\common\isgui.inc} +interface + //this wrapper sends text to the main form memo for GUI applications and to the terminal for console applications +uses + Classes, SysUtils; + +procedure dcmMsg (lStr: string); + +implementation +{$IFDEF GUI} +uses gui; +{$ENDIF} + +procedure dcmMsg (lStr: string); +begin +{$IFDEF GUI} + MainForm.Memo1.Lines.Add(lStr); + MainForm.refresh; +{$ELSE} + writeln(lStr) +{$ENDIF} +end; + +end. + diff --git a/dcm2nii/dialogs_msg.ppu b/dcm2nii/dialogs_msg.ppu new file mode 100644 index 0000000..040daef Binary files /dev/null and b/dcm2nii/dialogs_msg.ppu differ diff --git a/dcm2nii/dicom.o b/dcm2nii/dicom.o new file mode 100644 index 0000000..dc66ed0 Binary files /dev/null and b/dcm2nii/dicom.o differ diff --git a/dcm2nii/dicom.pas b/dcm2nii/dicom.pas new file mode 100755 index 0000000..8089453 --- /dev/null +++ b/dcm2nii/dicom.pas @@ -0,0 +1,32 @@ +unit dicom; +{$H+} +interface +{$DEFINE COMPAT} +uses + dialogsx,prefs,dicomtypes + {$IFDEF COMPAT} +,dicomcompat{,dicomfast}; +{$ELSE} +,dicomfast; +{$ENDIF} +procedure read_dicom_data(lReadJPEGtables,lVerboseRead,lAutoDECAT7,lReadECAToffsetTables,lAutodetectInterfile,lAutoDetectGenesis,lReadColorTables: boolean; var lDICOMdata: DICOMdata; var lDTIra: TDTIRA; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lPrefs: TPrefs); + +implementation + +procedure read_dicom_data(lReadJPEGtables,lVerboseRead,lAutoDECAT7,lReadECAToffsetTables,lAutodetectInterfile,lAutoDetectGenesis,lReadColorTables: boolean; var lDICOMdata: DICOMdata; var lDTIra: TDTIRA; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lPrefs: TPrefs); +begin + lDICOMdata.Filename := lFilename; + lHdrOK := true; + lImageFormatOK:=true; + {$IFDEF COMPAT} + //if not fast_read_dicom_data(lDICOMdata,128, lFileName) then + read_dicom_data_compat(lReadJPEGtables,lVerboseRead,lAutoDECAT7,lReadECAToffsetTables,lAutodetectInterfile,lAutoDetectGenesis,lReadColorTables, lDICOMdata, lDTIra, lHdrOK, lImageFormatOK, lDynStr, lFileName,lPrefs); + {$ELSE} + lHdrOK := fast_read_dicom_data(lDICOMdata,128, lFileName); + {$ENDIF} +end; + +end. + + + diff --git a/dcm2nii/dicom.ppu b/dcm2nii/dicom.ppu new file mode 100644 index 0000000..ba89a37 Binary files /dev/null and b/dcm2nii/dicom.ppu differ diff --git a/dcm2nii/dicomcompat.o b/dcm2nii/dicomcompat.o new file mode 100644 index 0000000..758d26f Binary files /dev/null and b/dcm2nii/dicomcompat.o differ diff --git a/dcm2nii/dicomcompat.pas b/dcm2nii/dicomcompat.pas new file mode 100755 index 0000000..30d176a --- /dev/null +++ b/dcm2nii/dicomcompat.pas @@ -0,0 +1,6577 @@ +unit dicomcompat; +interface +uses +//{$Define Troubleshoot} +{$DEFINE read00189117} //Support Philips shameful DTI usage +{$DEFINE read20011003} //Support Philips Shameful DTI usage + +{$IFDEF FPC} +gzio2, +{$ELSE} +gziod, +{$ENDIF} + + SysUtils,Classes,define_types,filename,dicomtypes,dicomfastread,prefs,convertsimple, csaread,dialogs_msg; +{$H+} +var +kUseDateTimeForID: boolean = false; +procedure read_afni_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lRotation1,lRotation2,lRotation3: integer); +procedure read_ecat_data(var lDICOMdata: DICOMdata;lVerboseRead,lReadECAToffsetTables:boolean; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_siemens_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_ge_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_interfile_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +procedure read_voxbo_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +procedure read_VFF_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +procedure read_picker_data(lVerboseRead: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_tiff_data(var lDICOMdata: DICOMdata; var lReadOffsets,lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_dicom_data_compat(lReadJPEGtables,lVerboseRead,lAutoDECAT7,lReadECAToffsetTables,lAutodetectInterfile,lAutoDetectGenesis,lReadColorTables: boolean; var lDICOMdata: DICOMdata; var lDTIra: TDTIRA; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lPrefs: TPrefs); + +var + gSizeMMWarningShown : boolean = false; + gECATJPEG_table_entries: integer = 0; + gECATJPEG_pos_table,gECATJPEG_size_table : LongIntP; + red_table_size : Integer = 0; + green_table_size : Integer = 0; + blue_table_size : Integer = 0; + red_table : ByteP; + green_table : ByteP; + blue_table : ByteP; +implementation + +uses dialogsx; + +function SecSinceMidnightFloat (lStr: string): double; +var + lNumStr: string; + sec: double; + i,len,dec: integer; +begin + result := 0;//error + + if lStr = '' then + exit; + len := length(lStr); + lNumStr := ''; + for i := 1 to len do begin + if (lStr[i] = '.') or (lStr[i] = ',') then + lStr[i] := DecimalSeparator; //make native format, e.g. in Germany 10,123 whereas in USA 10.123 + if lStr[i] in ['0'..'9',DecimalSeparator] then + lNumStr := lNumStr + lStr[i]; + end; + if lNumStr = '' then + exit; + + //make sure 6 characters before decimal, in case HHMMSS is written HMMSS + dec := length(lNumStr) + 1; + for i := length(lNumStr) downto 1 do + if lNumStr[i] = DecimalSeparator then + dec := i; + if dec > 7 then + exit; //HHMMSS.??? can only have 6 digits before decimal + while dec < 7 do begin + lNumStr := '0'+lNumStr; + inc(dec); + end; + //now in HHMMSS.????? format + len := length(lNumStr); + lStr := lNumStr[1]+lNumStr[2]; //HH + sec := 60 * 60 * strtoint(lStr); //60m/h, 60s/m + lStr := lNumStr[3]+lNumStr[4]; //MM + sec := sec + ( 60 * strtoint(lStr)); //60s/m 1000ms/s + lStr := ''; + for i := 5 to len do //SS.SSSS + lStr := lStr + lNumStr[i]; + sec := sec + ( strtofloat(lStr)); //60s/m 1000ms/s + result := sec; +end; + +function AddIndent(lIndent: integer): string; +var + i: integer; +begin + result := ''; + if lIndent < 1 then + exit; + for i := 1 to lIndent do + result := result +'|'; +end; + +procedure read_ecat_data(var lDICOMdata: DICOMdata;lVerboseRead,lReadECAToffsetTables:boolean; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 121,539; +const + kMaxnSLices = 6000; + kStrSz = 40; +var + lLongRA: LongIntp; + lECAT7sigUpcase,lECAT7sig : array [0..6] of Char; + lParse,lSPos,lFPos{,lScomplement},lF,lS,lYear,lFrames,lVox,lHlfVox,lJ,lPass,lVolume,lNextDirectory,lSlice,lSliceSz,lVoxelType,lPos,lEntry, + lSlicePos,lLongRApos,lLongRAsz,{lSingleRApos,lSingleRAsz,}{lMatri,}lX,lY,lZ,lCacheSz,lImgSz,lSubHeadStart,lMatrixStart,lMatrixEnd,lInt,lInt2,lInt3,lINt4,n,filesz: LongInt; + lPlanes,lGates,lAqcType,lFileType: word; + lXmm,lYmm,lZmm,lCalibrationFactor, lQuantScale: real; + FP: file; + lCreateTable,lSwapBytes,lMR,lECAT6: boolean; +function xWord(lPos: longint): word; +var +s: word; +begin + seek(fp,lPos); + BlockRead(fp, s, 2, n); + if lSwapBytes then + result := swap(s) + else result := s; //assign address of s to inguy +end; + +function swap32i(lPos: longint): Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + if not lSwapBytes then begin + result := inguy^.long; + exit; + end; + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap32i:=outguy.Long; +end; +function StrRead (lPos, lSz: longint) : string; +var + I: integer; + tx : array [1..kStrSz] of Char; +begin + result := ''; + if lSz > kStrSz then exit; + seek(fp, lPos{-1}); + BlockRead(fp, tx, lSz*SizeOf(Char), n); + for I := 1 to (lSz-1) do begin + if tx[I] in [' ','[',']','+','-','.','\','~','/', '0'..'9','a'..'z','A'..'Z'] then + {if (tx[I] <> kCR) and (tx[I] <> UNIXeoln) then} + result := result + tx[I]; + end; +end; +function fswap4r (lPos: longint): single; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(float:single); + end; + swaptypep = ^swaptype; +var + s:single; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + if not lSwapBytes then begin + BlockRead(fp, result, 4, n); + exit; + end; + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + fswap4r:=outguy.float; +end; +function fvax4r (lPos: longint): single; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(float:single); + end; + swaptypep = ^swaptype; +var + s:single; + lT1,lT2 : word; + inguy:swaptypep; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; + if (inguy^.Word1 =0) and (inguy^.Word2 = 0) then begin + result := 0; + exit; + end; + lT1 := inguy^.Word1 and $80FF; + lT2 := ((inguy^.Word1 and $7F00) +$FF00) and $7F00; + inguy^.Word1 := inguy^.Word2; + inguy^.Word2 := (lt1+lT2); + fvax4r:=inguy^.float; +end; +begin + Clear_Dicom_Data(lDicomData); + if gECATJPEG_table_entries <> 0 then begin + freemem (gECATJPEG_pos_table); + freemem (gECATJPEG_size_table); + gECATJPEG_table_entries := 0; + end; + lHdrOK:= false; + lQuantScale:= 1; + lCalibrationFactor := 1; + lLongRASz := 0; + lLongRAPos := 0; + lImageFormatOK := false; + lVolume := 1; + if not fileexists(lFileName) then begin + dcmMsg('Unable to find the image '+lFileName); + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + if filesz < (2048) then begin + dcmMsg('This file is to small to be a ECAT format image.'); + goto 539; + end; + seek(fp, 0); + BlockRead(fp, lECAT7Sig, 6*SizeOf(Char){, n}); + for lInt4 := 0 to (5) do begin + if lECAT7Sig[lInt4] in ['a'..'z','A'..'Z'] then + lECAT7SigUpCase[lInt4] := upcase(lECAT7Sig[lInt4]) + else + lECAT7SigUpCase[lInt4] := ' '; + end; + if (lECAT7SigUpCase[0]='M') and (lECAT7SigUpCase[1]='A') and (lECAT7SigUpCase[2]='T') and (lECAT7SigUpCase[3]='R') and + (lECAT7SigUpCase[4]='I') and (lECAT7SigUpCase[5]='X') then + lECAT6 := false + else + lECAT6 := true; + if lEcat6 then begin + lSwapBytes := false; + lFileType := xWord(27*2); + if lFileType > 255 then lSwapBytes := not lSwapBytes; + lFileType := xWord(27*2); + lAqcType := xWord(175*2); + lPlanes := xWord(188*2); + lFrames := xword(189*2); + lGates := xWord(190*2); + lYear := xWord(70); + if (lPlanes < 1) or (lFrames < 1) or (lGates < 1) then begin + case MsgDlg('Warning: one of the planes/frames/gates values is less than 1 ['+inttostr(lPlanes)+'/'+inttostr(lFrames)+'/'+inttostr(lGates)+']. Is this file really ECAT 6 format? Press abort to cancel conversion. ', + mterror,[mbOK,mbAbort], 0) of + mrAbort: goto 539; + end; //case + end else if (lYear < 1940) or (lYear > 3000) then begin + case MsgDlg('Warning: the year value appears invalid ['+inttostr(lYear)+']. Is this file really ECAT 6 format? Press abort to cancel conversion. ', + mterror,[mbOK,mbAbort], 0) of + mrAbort: goto 539; + end; //case + end; + if lVerboseRead then begin + lDynStr :='ECAT6 data'; + lDynStr :=lDynStr+kCR+('Patient Name:'+StrRead(190,32)); + lDynStr :=lDynStr+kCR+('Patient ID:'+StrRead(174,16)); + lDynStr :=lDynStr+kCR+('Study Desc:'+StrRead(318,32)); + lDynStr := lDynStr+kCR+('Facility: '+StrRead(356,20)); + lDynStr := lDynStr+kCR+('Planes: '+inttostr(lPlanes)); + lDynStr := lDynStr+kCR+('Frames: '+inttostr(lFrames)); + lDynStr := lDynStr+kCR+('Gates: '+inttostr(lGates)); + lDynStr := lDynStr+kCR+('Date DD/MM/YY: '+ inttostr(xWord(66))+'/'+inttostr(xWord(68))+'/'+inttostr(lYear)); + end; {show summary} + end else begin //NOT ECAT6 + lSwapBytes := true; + lFileType := xWord(50); + if lFileType > 255 then lSwapBytes := not lSwapBytes; + lFileType := xWord(50); + lAqcType := xWord(328); + lPlanes := xWord(352); + lFrames := xWord(354); + lGates := xWord(356); + lCalibrationFactor := fswap4r(144); + if {(true) or} (lPlanes < 1) or (lFrames < 1) or (lGates < 1) then begin + case MsgDlg('Warning: on of the planes/frames/gates values is less than 1 ['+inttostr(lPlanes)+'/'+inttostr(lFrames)+'/'+inttostr(lGates)+']. Is this file really ECAT 7 format? Press abort to cancel conversion. ', + mterror,[mbOK,mbAbort], 0) of + mrAbort: goto 539; + end; //case + end; //error + if lVerboseRead then begin + lDynStr := 'ECAT 7 format'; + lDynStr := lDynStr+kCR+('Serial Number:'+StrRead(52,10)); + lDynStr := lDynStr+kCR+('Patient Name:'+StrRead(182,32)); + lDynStr := lDynStr+kCR+('Patient ID:'+StrRead(166,16)); + lDynStr := lDynStr+kCR+('Study Desc:'+StrRead(296,32)); + lDynStr := lDynStr+kCR+('Facility: '+StrRead(332,20)); + lDynStr := lDynStr+kCR+('Scanner: '+inttostr(xWord(48))); + lDynStr := lDynStr+kCR+('Planes: '+inttostr(lPlanes)); + lDynStr := lDynStr+kCR+('Frames: '+inttostr(lFrames)); + lDynStr := lDynStr+kCR+('Gates: '+inttostr(lGates)); + lDynStr := lDynStr+kCR+'Calibration: '+floattostr(lCalibrationFactor); + end; {lShow Summary} + end; //lECAT7 +if lFiletype = 9 then lFiletype := 7; //1364: treat projections as Volume16's +if not (lFileType in [1,2,3,4,7]) then begin + dcmMsg('This software does not recognize the ECAT file type. Selected filetype: '+inttostr(lFileType)); + goto 539; +end; +lVoxelType := 2; +if lFileType = 3 then lVoxelType := 4; +if lVerboseRead then begin + case lFileType of + 1: lDynStr := lDynStr+kCR+('File type: Scan File'); + 2: lDynStr := lDynStr+kCR+('File type: Image File'); //x + 3: lDynStr := lDynStr+kCR+('File type: Attn File'); + 4: lDynStr := lDynStr+kCR+('File type: Norm File'); + 7: lDynStr := lDynStr+kCR+('File type: Volume 16'); //x + end; //lfiletye case + case lAqcType of + 1:lDynStr := lDynStr+kCR+('Acquisition type: Blank'); + 2:lDynStr := lDynStr+kCR+('Acquisition type: Transmission'); + 3:lDynStr := lDynStr+kCR+('Acquisition type: Static Emission'); + 4:lDynStr := lDynStr+kCR+('Acquisition type: Dynamic Emission'); + 5:lDynStr := lDynStr+kCR+('Acquisition type: Gated Emission'); + 6:lDynStr := lDynStr+kCR+('Acquisition type: Transmission Rect'); + 7:lDynStr := lDynStr+kCR+('Acquisition type: Emission Rect'); + 8:lDynStr := lDynStr+kCR+('Acquisition type: Whole Body Transm'); + 9:lDynStr := lDynStr+kCR+('Acquisition type: Whole Body Static'); + else lDynStr := lDynStr+kCR+('Acquisition type: Undefined'); + end; //case AqcType +end; //verbose read +if ((lECAT6) and (lFiletype =2)) or ({(not lECAT6) and} (lFileType=7)) then //Kludge +else begin + dcmMsg('Unusual ECAT filetype. Please contact the author.'); + goto 539; +end; +lHdrOK:= true; +lImageFormatOK := true; +lLongRASz := kMaxnSlices * sizeof(longint); +getmem(lLongRA,lLongRAsz); +lPos := 512; +//lSingleRASz := kMaxnSlices * sizeof(single); +//getmem(lSingleRA,lSingleRAsz); +//lMatri := 0; +lVolume := 1; +lPass := 0; +121: + lEntry := 1; + lInt := swap32i(lPos); + lInt2 := swap32i(lPos+4); + lNextDirectory := lInt2; + while true do begin + inc(lEntry); + lPos := lPos + 16; + lInt := swap32i(lPos); + lInt2 := swap32i(lPos+4); + lInt3 := swap32i(lPos+8); + lInt4 := swap32i(lPos+12); + lInt2 := lInt2 - 1; + lSubHeadStart := lINt2 *512; + lMatrixStart := ((lInt2) * 512)+512 {add subhead sz}; + lMatrixEnd := lInt3 * 512; + if (lInt4 = 1) and (lMatrixStart < FileSz) and (lMatrixEnd <= FileSz) then begin + if (lFileType= 7) {or (lFileType = 4) } or (lFileType = 2) then begin //Volume of 16-bit integers + if lEcat6 then begin + lX := xWord(lSubHeadStart+(66*2)); + lY := xWord(lSubHeadStart+(67*2)); + lZ := 1;//uxWord(lSubHeadStart+8); + lXmm := 10*fvax4r(lSubHeadStart+(92*2));// fswap4r(lSubHeadStart+(92*2)); + lYmm := lXmm;//read32r(lSubHeadStart+(94*2)); + lZmm := 10 * fvax4r(lSubHeadStart+(94*2)); + lCalibrationFactor := fvax4r(lSubHeadStart+(194*2)); + lQuantScale := fvax4r(lSubHeadStart+(86*2)); + if lVerboseRead then + lDynStr := lDynStr+kCR+'Plane '+inttostr(lPass+1)+' Calibration/Scale Factor: '+floattostr(lCalibrationFactor)+'/'+floattostr(lQuantScale); + end else begin + //02 or 07 + lX := xWord(lSubHeadStart+4); + lY := xWord(lSubHeadStart+6); + lZ := xWord(lSubHeadStart+8); + //if lFileType <> 4 then begin + lXmm := 10*fswap4r(lSubHeadStart+34); + lYmm := 10*fswap4r(lSubHeadStart+38); + lZmm := 10*fswap4r(lSubHeadStart+42); + lQuantScale := fswap4r(lSubHeadStart+26); + if lVerboseRead then + lDynStr := lDynStr+kCR+'Volume: '+inttostr(lPass+1)+' Scale Factor: '+floattostr(lQuantScale); + //end; //filetype <> 4 + end; //ecat7 + if true then begin + //FileMode := 2; //set to read/write + inc(lPass); + lImgSz := lX * lY * lZ * lVoxelType; {2 bytes per voxel} + lSliceSz := lX * lY * lVoxelType; + if lZ < 1 then begin + lHdrOK := false; + goto 539; + end; + lSlicePos := lMatrixStart; + if ((lECAT6) and (lPass = 1)) or ( (not lECAT6)) then begin + lDICOMdata.XYZdim[1] := lX; + lDICOMdata.XYZdim[2] := lY; + lDICOMdata.XYZdim[3] := lZ; + lDICOMdata.XYZmm[1] := lXmm; + lDICOMdata.XYZmm[2] := lYmm; + lDICOMdata.XYZmm[3] := lZmm; + case lVoxelType of + 1: begin + dcmMsg('Error: 8-bit data not supported [yet]. Please contact the author.'); + lDicomData.Allocbits_per_pixel := 8; + lHdrOK := false; + goto 539; + end; + 4: begin + dcmMsg('Error: 32-bit data not supported [yet]. Please contact the author.'); + lHdrOK := false; + goto 539; + end; + else begin //16-bit integers + lDicomData.Allocbits_per_pixel := 16; + end; + end; {case lVoxelType} + end else begin //if lECAT6 + if (lDICOMdata.XYZdim[1] <> lX) or (lDICOMdata.XYZdim[2] <> lY) or (lDICOMdata.XYZdim[3] <> lZ) then begin + dcmMsg('Error: different slices in this volume have different slice sizes. Please contact the author.'); + lHdrOK := false; + goto 539; + end; //dimensions have changed + //lSlicePos :=((lMatri-1)*lImgSz); + end; //ECAT6 + lVox := lSliceSz div 2; + lHlfVox := lSliceSz div 4; + for lSlice := 1 to lZ do begin + if (not lECAT6) then + lSlicePos := ((lSlice-1)*lSliceSz)+lMatrixStart; + if lLongRAPos >= kMaxnSLices then begin + lHdrOK := false; + goto 539; + end; + inc(lLongRAPos); + lLongRA^[lLongRAPos] := lSlicePos; + {inc(lSingleRAPos); + if lCalibTableType = 1 then + lSingleRA[lSingleRAPos] := lQuantScale + else + lSingleRA[lSingleRAPos] := lCalibrationFactor *lQuantScale;} + + end; //slice 1..lZ + if not lECAT6 then inc(lVolume); + end; //fileexistsex + end; //correct filetype + end; //matrix start/end within filesz + if (lMatrixStart > FileSz) or (lMatrixEnd >= FileSz) then goto 539; + if ((lEntry mod 32) = 0) then begin + if ((lNextDirectory-1)*512) <= lPos then goto 539; //no more directories + lPos := (lNextDirectory-1)*512; + goto 121; + end; //entry 32 + end ; //while true +539: + CloseFile(fp); + FileMode := 2; //set to read/write + lDicomData.XYZdim[3] := lLongRApos; + if not lECAT6 then dec(lVolume); //ECAT7 increments immediately before exiting loop - once too often + lDicomData.XYZdim[4] :=(lVolume); + if lSwapBytes then + lDicomData.little_endian := 0 + else + lDicomData.little_endian := 1; + if (lLongRApos > 0) and (lHdrOK) then begin + lDicomData.ImageStart := lLongRA^[1]; + lCreateTable := false; + if (lLongRApos > 1) then begin + lFPos := lDICOMdata.ImageStart; + for lS := 2 to lLongRApos do begin + lFPos := lFPos + lSliceSz; + if lFPos <> lLongRA^[lS] then lCreateTable := true; + end; + if (lCreateTable) and (lReadECAToffsetTables) then begin + gECATJPEG_table_entries := lLongRApos; + getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint)); + getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint)); + for lS := 1 to gECATJPEG_table_entries do + gECATJPEG_pos_table^[lS] := lLongRA^[lS] + end else if (lCreateTable) then + lImageFormatOK := false; //slices are offset within this file + end; + if (lVerboseRead) and (lHdrOK) then begin + lDynStr :=lDynStr+kCR+('XYZdim:'+inttostr(lX)+'/'+inttostr(lY)+'/'+inttostr(gECATJPEG_table_entries)); + lDynStr :=lDynStr+kCR+('XYZmm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,7,7)+'/'+floattostrf(lDicomData.XYZmm[2],ffFixed,7,7) + +'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,7,7)); + //xlDynStr :=lDynStr+kCR+('Bits per voxel: '+inttostr(lDicomData.Storedbits_per_pixel)); + lDynStr :=lDynStr+kCR+('Image Start: '+inttostr(lDicomData.ImageStart)); + if lCreateTable then + lDynStr :=lDynStr+kCR+('Note: staggered slice offsets'); + end + end; + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + if lLongRASz > 0 then + freemem(lLongRA); + (*if (lSingleRApos > 0) and (lHdrOK) and (lCalibTableType <> 0) then begin + gECAT_scalefactor_entries := lSingleRApos; + getmem (gECAT_scalefactor_table, gECAT_scalefactor_entries*sizeof(single)); + for lS := 1 to gECAT_scalefactor_entries do + gECAT_scalefactor_table[lS] := lSingleRA[lS]; + end; + if lSingleRASz > 0 then + freemem(lSingleRA);*) +end; + +(*procedure write_slc (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean); +const kMaxRA = 41; + lXra: array [1..kMaxRA] of byte = (7,8,9,21,22,26,27, + 35,36,44,45, + 50,62,66,78, + 81,95, + 97,103,104,105,106,111, + 113,123,127, + 129,139,142, + 146,147,148,149,155,156,157, + 166,167,168,169,170); +var + fp: file; + lX,lClr,lPos,lRApos: integer; + lP: bytep; +procedure WriteString(lStr: string; lCR: boolean); +var + n,lStrLen : Integer; +begin + lStrLen := length(lStr); + for n := 1 to lstrlen do begin + lPos := lPos + 1; + lP[lPos] := ord(lStr[n]); + end; + if lCR then begin + lPos := lPos + 1; + lP[lPos] := ord(kCR); + end; +end; + +begin + lSz := 0; + getmem(lP,2048); + lPos := 0; + WriteString('11111',true); + WriteString(inttostr(pDicomData.XYZdim[1])+' '+inttostr(pDicomData.XYZdim[2])+' '+inttostr(pDicomData.XYZdim[3])+' 8',true); + WriteString(floattostrf(pDicomData.XYZmm[1],ffFixed,7,7)+' '+floattostrf(pDicomData.XYZmm[2],ffFixed,7,7)+' '+floattostrf(pDicomData.XYZmm[3],ffFixed,7,7),true); + WriteString('1 1 0 0',true); //mmunits,MR,original,nocompress + WriteString('16 12 X',false); //icon is 8x8 grid, so 64 bytes for red,green blue + for lClr := 1 to 3 do begin + lRApos := 1; + for lX := 1 to 192 do begin + inc(lPos); + if (lRApos <= kMaxRA) and (lX = lXra[lRApos]) then begin + inc(lRApos); + lP[lPos] := 200; + end else + lP[lPos] := 0; + end; {icongrid 1..192} + end; {RGB} + if lFileName <> '' then begin + AssignFile(fp, lFileName); + Rewrite(fp, 1); + blockwrite(fp,lP^,lPos); + close(fp); + end; + freemem(lP); + lSz := lPos; +end;*) +procedure read_interfile_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +label 333; +const UNIXeoln = chr(10); +var lTmpStr, +lInStr,lUpCaseStr: string; +lHdrEnd,lFloat,lUnsigned: boolean; +lPos,lLen,FileSz,linPos: integer; +fp: file; +lCharRA: bytep; +function readInterFloat:real; +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) and (lInStr[lPos] <> ';') do begin + if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; + try + result := strtofloat(lStr); + except + on EConvertError do begin + dcmMsg('Unable to convert the string '+lStr+' to a number'); + result := 1; + exit; + end; + end; {except} + end; +function readInterStr:string; +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) and (lInStr[lPos] = ' ') do begin + inc(lPos); + end; + While (lPos <= lLen) and (lInStr[lPos] <> ';') do begin + if lInStr[lPos] <> ' ' then //1.39 build 6 + lStr := lStr+upcase(linStr[lPos]); //zebra upcase + inc(lPos); + end; + result := lStr; +end; //interstr func +begin + lHdrOK := false; + lFloat := false; + lUnsigned := false; + lImageFormatOK := true; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + lHdrEnd := false; + //lDicomData.ImageStart := FileSz; + GetMem( lCharRA, FileSz+1 ); + BlockRead(fp, lCharRA^, FileSz, linpos); + if lInPos <> FileSz then dcmMsg('Disk error: Unable to read full input file.'); + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write +repeat + linstr := ''; + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + While (lPos <= lLen) and (lInStr[lPos] <> ';') and (lInStr[lPos] <> '=') and (lUpCaseStr <>'INTERFILE') do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; + inc(lPos); {read equal sign in := statement} + if lUpCaseStr ='INTERFILE' then begin + lHdrOK := true; + lDicomData.little_endian := 0; + end; + if lUpCaseStr ='DATASTARTINGBLOCK'then lDicomData.ImageStart := 2048 * round(readInterFloat); + if lUpCaseStr ='DATAOFFSETINBYTES'then lDicomData.ImageStart := round(readInterFloat); + if (lUpCaseStr ='MATRIXSIZE[1]') or (lUpCaseStr ='MATRIXSIZE[X]') then lDicomData.XYZdim[1] := round(readInterFloat); + if (lUpCaseStr ='MATRIXSIZE[2]')or (lUpCaseStr ='MATRIXSIZE[Y]')then lDicomData.XYZdim[2] := round(readInterFloat); + if (lUpCaseStr ='MATRIXSIZE[3]')or (lUpCaseStr ='MATRIXSIZE[Z]') or (lUpCaseStr ='NUMBEROFSLICES') or (lUpCaseStr ='TOTALNUMBEROFIMAGES') then begin + lDicomData.XYZdim[3] := round(readInterFloat); + end; + if lUpCaseStr ='IMAGEDATABYTEORDER' then begin + if readInterStr = 'LITTLEENDIAN' then lDicomData.little_endian := 1; + end; + if lUpCaseStr ='NUMBERFORMAT' then begin + lTmpStr := readInterStr; + if (lTmpStr = 'ASCII') or (lTmpStr='BIT') then begin + lHdrOK := false; + dcmMsg('This software can not convert '+lTmpStr+' data type.'); + goto 333; + end; + if lTmpStr = 'UNSIGNEDINTEGER' then lUnsigned := true; + if (lTmpStr='FLOAT') or (lTmpStr='SHORTFLOAT') or (lTmpStr='LONGFLOAT') then begin //1395 + lFloat := true; + end; + end; + if lUpCaseStr ='NAMEOFDATAFILE' then lFileName := ExtractFilePath(lFileName)+readInterStr; + if lUpCaseStr ='NUMBEROFBYTESPERPIXEL' then + lDicomData.Allocbits_per_pixel := round(readInterFloat)*8; + if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[1]') or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[X]') then + lDicomData.XYZmm[1] := (readInterFloat); + if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[2]') or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[Y]')then lDicomData.XYZmm[2] := (readInterFloat); + if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[3]')or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[Z]')or (lUpCaseStr ='SLICETHICKNESS')then lDicomData.XYZmm[3] := (readInterFloat); + if (lUpCaseStr ='ENDOFINTERFILE') then lHdrEnd := true; + if not lHdrOK then goto 333; + if lInStr <> '' then + lDynStr := lDynStr + lInStr+kCr; + lHdrOK := true; +until (linPos >= FileSz) or (lHdrEnd){EOF(fp)}; +//xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; +lImageFormatOK := true; +if (not lFLoat) and (lUnsigned) and ((lDicomData.Allocbits_per_pixel = 16)) then begin + dcmMsg('Warning: this Interfile image uses UNSIGNED 16-bit data [values 0..65535]. Analyze specifies SIGNED 16-bit data [-32768..32767]. Some images may not transfer well. [Future versions of MRIcro should fix this].'); + lImageFormatOK := false; +end else if (not lFLoat) and (lDicomData.Allocbits_per_pixel > 16) then begin + dcmMsg('WARNING: The image '+lFileName+' is a '+inttostr(lDicomData.Allocbits_per_pixel)+'-bit integer data type. This software may display this as SIGNED data. Bits per voxel: '+inttostr(lDicomData.Allocbits_per_pixel)); + lImageFormatOK := false; +end else if (lFloat) then begin //zebra change float check + //dcmMsg('WARNING: The image '+lFileName+' uses floating point [real] numbers. The current software can only read integer data type Interfile images.'); + lDicomData.FloatData := true; + //lImageFormatOK := false; +end; +333: +FreeMem( lCharRA); +end; //interfile + + + +//afni start +function ParseFileName (lFilewExt:String): string; +var + lLen,lInc: integer; + lName: String; +begin + lName := ''; + lLen := length(lFilewExt); + lInc := lLen+1; + if lLen > 0 then + repeat + dec(lInc); + until (lFileWExt[lInc] = '.') or (lInc = 1); + if lInc > 1 then + for lLen := 1 to (lInc - 1) do + lName := lName + lFileWExt[lLen] + else + lName := lFilewExt; //no extension + ParseFileName := lName; +end; + +procedure read_afni_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lRotation1,lRotation2,lRotation3: integer); +//label 333; +const UNIXeoln = chr(10); +kTab = ord(chr(9)); +kSpace = ord(' '); +var lTmpStr,lInStr,lUpCaseStr: string; +lHdrEnd: boolean; +lMSBch: char; +lOri : array [1..4] of single; +lTmpInt,lPos,lLen,FileSz,linPos: integer; +fp: file; +lCharRA: bytep; +procedure readAFNIeoln; +begin + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do + inc(linPos); + inc(lInPos); //read EOLN +end; +function readAFNIFloat:real; +var lStr: string; +lCh:char; +begin + lStr := ''; + while (linPos < FileSz) and ((lStr='') or ((lCharRA^[lInPos] <> kTab) and (lCharRA^[lInPos] <> kSpace))) do begin + lCh:= chr(lCharRA^[linPos]); + if lCh in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+lCh; + inc(linPos); + end; + if lStr = '' then exit; + try + result := strtofloat(lStr); + except + on EConvertError do begin + dcmMsg('Unable to convert the string '+lStr+' to a number'); + result := 1; + exit; + end; + end; {except} + end; +begin + lHdrOK := false; + lImageFormatOK := true; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + lTmpStr := string(StrUpper(PChar(ExtractFileExt(lFileName)))); + if lTmpStr <> '.HEAD' then exit; + for lInPos := 1 to 3 do + lOri[lInPos] := -6666; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + lHdrEnd := false; + //lDicomData.ImageStart := FileSz; + GetMem( lCharRA, FileSz+1 ); + BlockRead(fp, lCharRA^, FileSz, linpos); + if lInPos <> FileSz then dcmMsg('Disk error: Unable to read full input file.'); + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write +repeat + linstr := ''; + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + While (lPos <= lLen) do begin + if lInStr[lPos] in ['_','[',']','(',')','/','+','-','=',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; + inc(lPos); {read equal sign in := statement} + if lUpCaseStr ='NAME=DATASET_DIMENSIONS'then begin + lImageFormatOK := true; + lHdrOK := true; + lFileName := parsefilename(lFilename)+'.BRIK'; //always UPPERcase + readAFNIeoln; + lDICOMdata.XYZdim[1] := round(readAFNIFloat); + lDICOMdata.XYZdim[2] := round(readAFNIFloat); + lDICOMdata.XYZdim[3] := round(readAFNIFloat); + //lDicomData.ImageStart := 2048 * round(readInterFloat); + end; + if lUpCaseStr ='NAME=BRICK_FLOAT_FACS'then begin + readAFNIeoln; + lDICOMdata.IntenScale := readAFNIFloat; //1380 read slope of intensity + end; + if lUpCaseStr ='NAME=DATASET_RANK'then begin + readAFNIeoln; + //2nd value is number of volumes + readAFNIFloat; + lDICOMdata.XYZdim[4] := round(readAFNIFloat); + end; + if lUpCaseStr ='NAME=BRICK_TYPES'then begin + readAFNIeoln; + lTmpInt := round(readAFNIFloat); + case lTmpInt of + 0:lDicomData.Allocbits_per_pixel := 8; + 1:begin + lDicomData.Allocbits_per_pixel := 16; + //lDicomData.MaxIntensity := 65535; //Old AFNI were UNSIGNED, new ones are SIGNED??? + end; + 3:begin + lDicomData.Allocbits_per_pixel := 32; + lDicomData.FloatData := true; + end; + else begin + lHdrEnd := true; + dcmMsg('Unsupported AFNI BRICK_TYPES: '+inttostr(lTmpInt)); + end; + + end; //case + {datatype + 0 = byte (unsigned char; 1 byte) + 1 = short (2 bytes, signed) + 3 = float (4 bytes, assumed to be IEEE format) + 5 = complex (8 bytes: real+imaginary parts)} + end; + if lUpCaseStr ='NAME=BYTEORDER_STRING'then begin + readAFNIeoln; + if ((linPos+2) < FileSz) then begin + lMSBch := chr(lCharRA^[linPos+1]); + if lMSBCh = 'L' then lDicomData.Little_Endian := 1; + if lMSBCh = 'M' then begin + lDicomData.Little_Endian := 0; + end; + linPos := lInPos + 2; + end; + //littleendian + end; + if lUpCaseStr ='NAME=ORIGIN'then begin + readAFNIeoln; + lOri[1] := (abs(readAFNIFloat)); + lOri[2] := (abs(readAFNIFloat)); + lOri[3] := (abs(readAFNIFloat)); + //Xori,YOri,ZOri + end; + if lUpCaseStr ='NAME=DELTA'then begin + readAFNIeoln; + lDICOMdata.XYZmm[1] := abs(readAFNIFloat); + lDICOMdata.XYZmm[2] := abs(readAFNIFloat); + lDICOMdata.XYZmm[3] := abs(readAFNIFloat); + + //Xmm,Ymm,Zmm + end; + if lUpCaseStr ='NAME=ORIENT_SPECIFIC'then begin + readAFNIeoln; + lRotation1 := round(readAFNIFloat); + lRotation2 := round(readAFNIFloat); + lRotation3 := round(readAFNIFloat); + end; //ORIENT_SPECIFIC rotation details + if lInStr <> '' then + lDynStr := lDynStr + lInStr+kCr; +until (linPos >= FileSz) or (lHdrEnd){EOF(fp)}; +//xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; +for lInPos := 1 to 3 do begin + if lOri[lInPos] < -6666 then //value not set + lDICOMdata.XYZori[lInPos] := round((1.0+lDICOMdata.XYZdim[lInPos])/2) + else if lDICOMdata.XYZmm[lInPos] <> 0 then + lDICOMdata.XYZori[lInPos] := round(1.5+lOri[lINPos] / lDICOMdata.XYZmm[lInPos]); +end; +// lDicomData.Float := true; +FreeMem( lCharRA); +end; //interfile +//afni end +//voxbo start +procedure read_voxbo_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +label 333; +const UNIXeoln = chr(10); + kTab = chr(9); +var lTmpStr,lInStr,lUpCaseStr: string; +lFileTypeKnown,lHdrEnd,lFloat: boolean; +lStartPos,lPos,lLen,FileSz,linPos: integer; +fp: file; +lCharRA: bytep; +procedure readVBfloats (var lF1,lF2,lF3: double); +// While (lPos <= lLen) and ((lInStr[lPos] = kTab) or (lInStr[lPos] = ' ')) do begin +// inc(lPos); +var //lDigit : boolean; + n,lItemIndex: integer; + lStr,lfStr: string; +begin + lf1 := 1; + lf2 := 1; + lf3 := 1; + n := 0; + for lItemIndex := 1 to 3 do begin + inc(n); + While (lPos <= lLen) and ((lInStr[lPos] = kTab) or (lInStr[lPos] = ' ')) do + inc(lPos); + if lPos > lLen then + exit; + lStr := ''; + repeat + lStr := lStr+upcase(linStr[lPos]); + inc(lPos); + until (lPos > lLen) or (lInStr[lPos] = kTab) or (lInStr[lPos] = ' '); + if lStr <> '' then begin //string to convert + try + case n of + 1: lF1 := strtofloat(lStr); + 2: lF2 := strtofloat(lStr); + 3: lF3 := strtofloat(lStr); + end; + except + on EConvertError do begin + dcmMsg('Unable to convert the string '+lfStr+' to a real number'); + exit; + end; + end; {except} + end; //if string to convert + end; +end; + +procedure readVBints (var lI1,lI2,lI3: integer); +var lF1,lF2,lF3: double; +begin + readVBfloats (lF1,lF2,lF3); + lI1 := round(lF1); + lI2 := round(lF2); + lI3 := round(lF3); +end; +function readVBStr:string; +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) and ((lInStr[lPos] = kTab) or (lInStr[lPos] = ' ')) do begin + inc(lPos); + end; + While (lPos <= lLen) {and (lInStr[lPos] <> ';')} do begin + lStr := lStr+upcase(linStr[lPos]); //zebra upcase + inc(lPos); + end; + result := lStr; +end; //interstr func +begin + lHdrOK := false; + lFloat := false; + lImageFormatOK := true; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + lHdrEnd := false; + //lDicomData.ImageStart := FileSz; + GetMem( lCharRA, FileSz+1 ); + BlockRead(fp, lCharRA^, FileSz, linpos); + if lInPos <> FileSz then dcmMsg('Disk error: Unable to read full input file.'); + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write + lFileTypeKnown := false; +repeat + linstr := ''; + + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + While (lPos <= lLen) and (lInStr[lPos] <> ':') do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-', '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; + inc(lPos); {read equal sign in := statement} + if (lHdrOK) and (not lFileTypeKnown) and (lUpCaseStr = 'CUB1') then + lFileTypeKnown := true; + if (lHdrOK) and (not lFileTypeKnown) then begin + dcmMsg('This software can not read this kind of VoxBo image. (Type:"'+lUpCaseStr+'")'); + lHdrEnd := true; + lHdrOK := false; + end; + if (not lHdrOK) and (lUpCaseStr ='VB98') then begin + lDicomData.little_endian := 0;//all VoxBo files are Big Endian! + lStartPos := linPos; + lFileTypeKnown := true; //test for While Loop + while (linPos < FileSz) and lFileTypeKnown do begin + if (lCharRA^[linPos-1] = $0C) and (lCharRA^[linPos] = $0A) then begin + lFileTypeKnown := false; + lDicomData.ImageStart := linPos; + FileSz := linPos; //size of VoxBo header + end; + inc(linPos); + end; + if lFileTypeKnown then begin //end of file character not found: abort! + dcmMsg('Unable to find the end of the VoxBo header.'); + lHdrEnd := true + end else + lHdrOK := true; + linPos := lStartPos; //now that we have found the header size, we can start from the beginning of the header + end; + if not lHdrOK then lHdrEnd := true; + if (lUpCaseStr ='BYTEORDER') and (readVBStr = 'LSBFIRST') then + lDicomData.little_endian := 1; + if lUpCaseStr ='DATATYPE'then begin + lTmpStr := readVBStr; + if lTmpStr = 'Byte' then + lDicomData.Allocbits_per_pixel := 8 + else if (lTmpStr = 'INTEGER') or (lTmpStr = 'INT16') then + lDicomData.Allocbits_per_pixel := 16 + else if (lTmpStr = 'LONG') or (lTmpStr = 'INT32') then + lDicomData.Allocbits_per_pixel := 32 + else if (lTmpStr = 'FLOAT') then begin + lFloat := true; + lDicomData.Allocbits_per_pixel := 32; + end else if (lTmpStr = 'DOUBLE') then begin + lFloat := true; + lDicomData.Allocbits_per_pixel := 64; + end else begin + dcmMsg('Unknown VoxBo data format: '+lTmpStr); + end; + end; + if lUpCaseStr ='VOXDIMS(XYZ)'then readVBints(lDicomData.XYZdim[1],lDicomData.XYZdim[2],lDicomData.XYZdim[3]); + if (lUpCaseStr ='VOXSIZES(XYZ)') then readVBfloats(lDicomData.XYZmm[1],lDicomData.XYZmm[2],lDicomData.XYZmm[3]); + if (lUpCaseStr ='ORIGIN(XYZ)')then begin + readVBints(lDicomData.XYZori[1],lDicomData.XYZori[2],lDicomData.XYZori[3]); + inc(lDicomData.XYZori[1]);//1393 + inc(lDicomData.XYZori[2]);//1393 + inc(lDicomData.XYZori[3]);//1393 + end; + if not lHdrOK then goto 333; + if lInStr <> '' then + lDynStr := lDynStr + lInStr+kCr; +until (linPos >= FileSz) or (lHdrEnd){EOF(fp)}; +//xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; +//xlDicomData.Rotate180deg := true; +lImageFormatOK := true; +if (lFloat) then begin //zebra change float check + lDicomData.FloatData := true; + //lImageFormatOK := false; +end; +333: +FreeMem( lCharRA); +end; +//voxbo end + +procedure read_vff_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +label 333; +const UNIXeoln = chr(10); +var lInStr,lUpCaseStr: string; +//lHdrEnd: boolean; +lPos,lLen,FileSz,linPos: integer; +lDummy1,lDummy2,lDummy3 : double; +fp: file; +lCharRA: bytep; +procedure readVFFvals (var lFloat1,lFloat2,lFloat3: double); +var lStr: string; + lDouble: DOuble; + lInc: integer; +begin + for lInc := 1 to 3 do begin + lStr := ''; + While (lPos <= lLen) and (lInStr[lPos] = ' ') do begin + inc(lPos); + end; + While (lPos <= lLen) and (lInStr[lPos] <> ';') and (lInStr[lPos] <> ' ') do begin + if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; + if lStr <> '' then begin + try + lDouble := strtofloat(lStr); + except + on EConvertError do begin + dcmMsg('Unable to convert the string '+lStr+' to a number'); + exit; + end; + end; {except} + case lInc of + 2: lFloat2 := lDouble; + 3: lFloat3 := lDouble; + else lFloat1 := lDouble; + end; + end; //lStr <> '' + end; //lInc 1..3 +end; //interstr func +begin + lHdrOK := false; + lImageFormatOK := true; + Clear_Dicom_Data(lDicomData); + lDicomData.little_endian := 0; //big-endian + lDynStr := ''; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + if FileSz > 2047 then FileSz := 2047; + GetMem( lCharRA, FileSz+1 ); + BlockRead(fp, lCharRA^, FileSz, linpos); + if lInPos <> FileSz then dcmMsg('Disk error: Unable to read full input file.'); + lInPos := 1; + while (lCharRA^[lInPos] <> 12) and (lInPos < FileSz) do begin + inc(lInPos); + end; + inc(lInPos); + if (lInPos >= FileSz) or (lInPos < 12) then goto 333; //unable to find + lDynStr := lDynStr + 'Sun VFF Volume File Format'+kCr; + lDicomData.ImageStart := lInPos; + FileSz := lInPos-1; + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write +repeat + linstr := ''; + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + While (lPos <= lLen) and (lInStr[lPos] <> ';') and (lInStr[lPos] <> '=') and (lUpCaseStr <>'NCAA') do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; + inc(lPos); {read equal sign in := statement} + if lUpCaseStr ='NCAA' then begin + lHdrOK := true; + end; + if lUpCaseStr ='BITS' then begin + lDummy1 := 8; + readVFFvals(lDummy1,lDummy2,lDummy3); + lDicomData.Allocbits_per_pixel := round(lDummy1); + end; + if lUpCaseStr ='SIZE' then begin + lDummy1 := 1; lDummy2 := 1; lDummy3 := 1; + readVFFvals(lDummy1,lDummy2,lDummy3); + lDicomData.XYZdim[1] := round(lDummy1); + lDicomData.XYZdim[2] := round(lDummy2); + lDicomData.XYZdim[3] := round(lDummy3); + end; + if lUpCaseStr ='ASPECT' then begin + lDummy1 := 1; lDummy2 := 1; lDummy3 := 1; + readVFFvals(lDummy1,lDummy2,lDummy3); + lDicomData.XYZmm[1] := (lDummy1); + lDicomData.XYZmm[2] := (lDummy2); + lDicomData.XYZmm[3] := (lDummy3); + end; + if not lHdrOK then goto 333; + if lInStr <> '' then + lDynStr := lDynStr + lInStr+kCr; + //lHdrOK := true; +until (linPos >= FileSz); +//xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; +lImageFormatOK := true; +333: +FreeMem( lCharRA); +end; +//******************************************************************** +(*procedure ShellSortItems (first, last: integer; var lPositionRA, lIndexRA: LongintP; var lRepeatedValues: boolean); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n,t, nn, m, lognb2, l, k, j, i: longint; +begin + lRepeatedValues := false; + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do + begin + m := m div 2; + k := last - m; + for j := 1 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (lIndexRA^[lPositionRA^[l]] = lIndexRA^[lPositionRA^[i]]) then begin + lRepeatedValues := true; + exit; + end; + if (lIndexRA^[lPositionRA^[l]] < lIndexRA^[lPositionRA^[i]]) then begin + //swap values for i and l + t := lPositionRA^[i]; + lPositionRA^[i] := lPositionRA^[l]; + lPositionRA^[l] := t; + i := i - m; + if (i >= 1) then + goto 555; + end + end + end +end; //shellsort is fast and requires less memory than quicksort *) + + +(*procedure PAR2DICOMstudyDate(var lDicomData: DICOMdata); +{input: lDicomData.StudyDate = 2002.12.29 / 19:48:58.0000 +output: StudyDate = YYYYMMDD StudyTime= hhmmss } +var + I: integer; + lStr: string; +begin + if length(lDicomData.StudyDate) < 14 then exit; + lStr := ''; + for I := 1 to length(lDicomData.StudyDate) do + if lDicomData.StudyDate[I] in ['0'..'9'] then + lStr := lStr+ lDicomData.StudyDate[I]; + if length(lStr) < 14 then exit; + lDicomData.StudyDate := ''; + for I := 1 to 8 do + lDicomData.StudyDate := lDicomData.StudyDate+lStr[I]; + lDicomData.StudyTime := ''; + for I := 9 to 14 do + lDicomData.StudyTime := lDicomData.StudyTime+lStr[I]; + lDicomData.PatientIDInt := StudySecSince2K(lDicomData.StudyDate,lDicomData.StudyTime); +end; +type tRange = record + Min,Val,Max: double; //some vals are ints, others floats +end; + +procedure read_PAR_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK:boolean; var lDynStr: string;var lFileName: string; lReadOffsetTables: boolean; var lOffset_pos_table: LongIntp; var lOffsetTableEntries: integer; lReadVaryingScaleFactors: boolean; var lVaryingScaleFactors_table,lVaryingIntercept_table: Singlep; var lVaryingScaleFactorsTableEntries,lnum4Ddatasets: integer); +label 333; //1384 now reads up to 8 dimensional data.... +const UNIXeoln = chr(10); + kMaxnSLices = 32000; + kXdim = 1; + kYdim = 2; + kBitsPerVoxel = 3; + kSliceThick = 4; + kSliceGap = 5; + kXmm = 6; + kYmm = 7; + kSlope = 8; + kIntercept = 9; + kCalibratedSlope = 10; //1393 - attempt to use calibrated values + kDynTime = 11; + kSlice = 12; + kEcho = 13; + kDyn = 14; + kCardiac = 15; + kType = 16; + kSequence = 17; + kIndex = 18; + lIsParVers3x: boolean = true; + lRepeatedValues : boolean = false; + lSlicesNotInSequence: boolean = false; + lMaxSlice : integer = 0; +var + lErrorStr,lInStr,lUpCaseStr,lReportedTRStr: string; + lSliceSequenceRA,lSortedSliceSequence: LongintP; + lSliceIndexRA: array [1..kMaxnSlices] of Longint; + lSliceSlopeRA,lSliceInterceptRA,lCalibratedSliceSlopeRA: array [1..kMaxnSlices] of single; + lSliceHeaderRA: array [1..32] of double; + lRangeRA: array [kXdim..kIndex] of tRange; + lMaxIndex,lSliceSz,lSliceInfoCount,lPos,lLen,lFileSz,lHdrPos,linPos,lInc: LongInt; + fp: file; + lCharRA: bytep; + +procedure MinMaxTRange (var lDimension: tRange; lNewVal: double); //nested +begin + lDimension.Val := lNewVal; + if lSliceInfoCount < 2 then begin + lDimension.Min := lDimension.Val; + lDimension.Max := lDimension.Val; + end; + if lNewVal < lDimension.Min then lDimension.Min := lNewVal; + if lNewVal > lDimension.Max then lDimension.Max := lNewVal; +end; //nested InitTRange proc + +function readParStr:string;//nested +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) do begin + if (lStr <> '') or (linStr[lPos]<>' ') then //strip leading spaces + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; //while lPOs < lLen + result := lStr; +end; //nested func ReadParStr +function readParFloat:double;//nested +var lStr: string; +begin + lStr := ''; + result := 1; + While (lPos <= lLen) and ((lStr='') or(lInStr[lPos] <> ' ')) do begin + if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; + if lStr = '' then exit; + try + result := strtofloat(lStr); + except + on EConvertError do begin + dcmMsg('read_PAR_data: Unable to convert the string '+lStr+' to a number'); + result := 1; + exit; + end; + end; {except} +end; //nested func ReadParFloat +begin + //Initialize parameters + lnum4Ddatasets := 1; + lSliceInfoCount := 0; + for lInc := kXdim to kIndex do //initialize all values: important as PAR3 will not explicitly report all + MinMaxTRange(lRangeRA[lInc],0); + lHdrOK := false; + lImageFormatOK := false; + lIsParVers3x := true; + lOffsetTableEntries := 0; + lVaryingScaleFactorsTableEntries := 0; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + //Read text header to buffer (lCharRA) + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + GetMem( lCharRA, lFileSz+1 ); //note: must free dynamic memory: goto 333 if any error + GetMem (lSliceSequenceRA, kMaxnSLices*sizeof(longint)); //note: must free dynamic memory: goto 333 if any error + BlockRead(fp, lCharRA^, lFileSz, lInpos); + if lInPos <> lFileSz then begin + dcmMsg('read_PAR_data: Disk error, unable to read full input file.'); + goto 333; + end; + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write + //Next: read each line of header file... + repeat //for each line in file.... + linstr := ''; + while (linPos < lFileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + if lLen < 1 then + //ignore blank lines + else if (lInStr[1] = '*') and (not lHdrOK) then //# -> comment + //ignore comment lines prior to start of header + else if (lInStr[1] = '#') and (lHdrOK) then //# -> comment + //ignore comment lines + else if (lInStr[1] = '.') or (not lHdrOK) then begin // GENERAL_INFORMATION section (line starts with '.') + //Note we also read in lines that do not have '.' if we have HdrOK=false, this allows us to detect the DATADESCRIPTIONFILE signature + While (lPos <= lLen) and (lInStr[lPos] <> ':') and ((not lHdrOK) or (lInStr[lPos] <> '#')) do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; //while reading line + inc(lPos); {read equal sign in := statement} + lDynStr := lDynStr + lInStr+kCR; + if (not lHdrOK) and (lUpcaseStr = ('DATADESCRIPTIONFILE')) then begin //1389 PAR file + lHdrOK := true; + lDicomData.little_endian := 1; + end; + + + + if (lUpCaseStr ='REPETITIONTIME[MSEC]') then + lDicomData.TR := round(readParFloat); + if (lUpCaseStr ='MAXNUMBEROFSLICES/LOCATIONS') then + lDicomData.XYZdim[3] := round(readParFloat); + if (lUpCaseStr ='SLICETHICKNESS[MM]') then + MinMaxTRange(lRangeRA[kSliceThick],readParFloat); + if (lUpCaseStr ='SLICEGAP[MM]') then + MinMaxTRange(lRangeRA[kSliceGap],readParFloat); + if lUpCaseStr = 'RECONRESOLUTION(XY)' then begin + MinMaxTRange(lRangeRA[kXdim],readParFloat); + MinMaxTRange(lRangeRA[kYdim],readParFloat); + end; + if lUpCaseStr = 'RECONSTRUCTIONNR' then + lDicomData.AcquNum := round(readParFloat); + if lUpCaseStr = 'ACQUISITIONNR' then + lDicomData.SeriesNum := round(readParFloat); + if lUpCaseStr = 'MAXNUMBEROFDYNAMICS' then begin + lDicomData.XYZdim[4] := round(readParFloat); + end; + if lUpCaseStr = 'EXAMINATIONDATE/TIME' then begin + lDicomData.StudyDate := readParStr; + PAR2DICOMstudyDate(lDicomData); + end; + //if lUpCaseStr = 'PROTOCOLNAME' then + // lDicomData.modality := readParStr; + if lUpCaseStr = 'PATIENTNAME' then + lDicomData.PatientName := readParStr; + if lUpCaseStr ='IMAGEPIXELSIZE[8OR16BITS]' then begin + MinMaxTRange(lRangeRA[kBitsPerVoxel],readParFloat); + end; + if not lHdrOK then begin + dcmMsg('read_PAR_data: Error reading header'); + goto 333; + end; + end else begin //SliceInfo: IMAGE_INFORMATION (line does NOT start with '.' or '#') + inc(lSliceInfoCount); + if (lSliceInfoCount < 2) and (lRangeRA[kBitsPerVoxel].val < 1) then //PARvers3 has imagedepth in general header, only in image header for later versions + lIsParVers3x := false; + for lHdrPos := 1 to 26 do + lSliceHeaderRA[lHdrPos] := readparfloat; + //The next few values are in the same location for both PAR3 and PAR4 + MinMaxTRange(lRangeRA[kSlice], round(lSliceHeaderRA[1])); + MinMaxTRange(lRangeRA[kEcho], round(lSliceHeaderRA[2])); + MinMaxTRange(lRangeRA[kDyn], round(lSliceHeaderRA[3])); + MinMaxTRange(lRangeRA[kCardiac], round(lSliceHeaderRA[4])); + MinMaxTRange(lRangeRA[kType], round(lSliceHeaderRA[5])); + MinMaxTRange(lRangeRA[kSequence], round(lSliceHeaderRA[6])); + MinMaxTRange(lRangeRA[kIndex], round(lSliceHeaderRA[7])); + if lIsParVers3x then begin //Read PAR3 data + MinMaxTRange(lRangeRA[kIntercept], lSliceHeaderRA[8]);; //8=intercept in PAR3 + MinMaxTRange(lRangeRA[kSlope],lSliceHeaderRA[9]); //9=slope in PAR3 + MinMaxTRange(lRangeRA[kCalibratedSlope],lSliceHeaderRA[10]); //10=lcalibrated slope in PAR3 1393 - attempt to use calibrated values + MinMaxTRange(lRangeRA[kXmm],lSliceHeaderRA[23]); //23 PIXEL SPACING X in PAR3 + MinMaxTRange(lRangeRA[kYmm],lSliceHeaderRA[24]); //24 PIXEL SPACING Y IN PAR3 + MinMaxTRange(lRangeRA[kDynTime],(lSliceHeaderRA[26])); //26= dyn_scan_begin_time in PAR3 + end else begin //not PAR: assume PAR4 + for lHdrPos := 27 to 32 do + lSliceHeaderRA[lHdrPos] := readparfloat; + MinMaxTRange(lRangeRA[kBitsPerVoxel],lSliceHeaderRA[8]);//8 BITS in PAR4 + MinMaxTRange(lRangeRA[kXdim], lSliceHeaderRA[10]); //10 XDim in PAR4 + MinMaxTRange(lRangeRA[kYdim], lSliceHeaderRA[11]); //11 YDim in PAR4 + MinMaxTRange(lRangeRA[kIntercept],lSliceHeaderRA[12]); //12=intercept in PAR4 + MinMaxTRange(lRangeRA[kSlope],lSliceHeaderRA[13]); //13=lslope in PAR4 + MinMaxTRange(lRangeRA[kCalibratedSlope],lSliceHeaderRA[14]); //14=lcalibrated slope in PAR4 1393 - attempt to use calibrated values + MinMaxTRange(lRangeRA[kSliceThick],lSliceHeaderRA[23]);//23 SLICE THICK in PAR4 + MinMaxTRange(lRangeRA[kSliceGap], lSliceHeaderRA[24]); //24 SLICE GAP in PAR4 + MinMaxTRange(lRangeRA[kXmm],lSliceHeaderRA[29]); //29 PIXEL SPACING X in PAR4 + MinMaxTRange(lRangeRA[kYmm],lSliceHeaderRA[30]); //30 PIXEL SPACING Y in PAR4 + MinMaxTRange(lRangeRA[kDynTime],(lSliceHeaderRA[32]));//32= dyn_scan_begin_time in PAR4 + end; //PAR4 + if lSliceInfoCount < kMaxnSlices then begin + lSliceSequenceRA^[lSliceInfoCount] := ( (round(lRangeRA[kSequence].val)+round(lRangeRA[kType].val)+round(lRangeRA[kCardiac].val+lRangeRA[kEcho].val)) shl 24)+(round(lRangeRA[kDyn].val) shl 10)+round(lRangeRA[kSlice].val); + lSliceSlopeRA [lSliceInfoCount] := lRangeRA[kSlope].Val; + lCalibratedSliceSlopeRA [lSliceInfoCount] := lRangeRA[kCalibratedSlope].Val; + lSliceInterceptRA [lSliceInfoCount] := lRangeRA[kIntercept].val; + lSliceIndexRA[lSliceInfoCount]:= round(lRangeRA[kIndex].val); + end; + end; //SliceInfo Line + until (linPos >= lFileSz);//until done reading entire file... + //describe generic DICOM parameters + lDicomData.XYZdim[1] := round(lRangeRA[kXdim].Val); + lDicomData.XYZdim[2] := round(lRangeRA[kYdim].Val); + lDicomData.XYZdim[3] := 1+round(lRangeRA[kSlice].Max-lRangeRA[kSlice].Min); + if (lSliceInfoCount mod lDicomData.XYZdim[3]) <> 0 then + dcmMsg('read_PAR_data: Total number of slices not divisible by number of slices per volume. Reconstruction error?'); + if lDicomData.XYZdim[3] > 0 then + lDicomData.XYZdim[4] := lSliceInfoCount div lDicomData.XYZdim[3] //nVolumes = nSlices/nSlicePerVol + else + lDicomData.XYZdim[4] := 1; + + lDicomData.XYZmm[1] := lRangeRA[kXmm].Val; + lDicomData.XYZmm[2] := lRangeRA[kYmm].Val; + lDicomData.XYZmm[3] := lRangeRA[kSliceThick].Val+lRangeRA[kSliceGap].Val; + lDicomData.Allocbits_per_pixel := round(lRangeRA[kBitsPerVoxel].Val); + lDicomData.IntenScale := lRangeRA[kSlope].Val; + lDicomData.IntenIntercept := lRangeRA[kIntercept].Val; +if gPARprecise then begin + if (lDicomData.IntenIntercept <> 0) or (lRangeRA[kCalibratedSlope].val = 0) then + dcmMsg('Warning: Unable to save calibrated Philips image intensity (non-zero scaling intercept). Turn off Etc/Options/CalibratedScaling to hide warning.'); + if (lRangeRA[kSlope].min = lRangeRA[kSlope].max) + and (lRangeRA[kIntercept].min = lRangeRA[kIntercept].max) + and (lRangeRA[kCalibratedSlope].min = lRangeRA[kCalibratedSlope].max) + and (lDicomData.IntenIntercept = 0) and (lRangeRA[kCalibratedSlope].val <> 0) then + lDicomData.IntenScale := 1 / lRangeRA[kCalibratedSlope].val; +end; //if PARprecise + //Next: report number of Dynamic scans, this allows people to parse DynScans from Type/Cardiac/Echo/Sequence 4D files + lnum4Ddatasets := (round(lRangeRA[kDyn].Max - lRangeRA[kDyn].Min)+1)*lDicomData.XYZdim[3]; //slices in each dynamic session + if ((lSliceInfoCount mod lnum4Ddatasets) = 0) and ((lSliceInfoCount div lnum4Ddatasets) > 1) then + lnum4Ddatasets := (lSliceInfoCount div lnum4Ddatasets) //infer multiple Type/Cardiac/Echo/Sequence + else + lnum4Ddatasets := 1; + //next: Determine actual interscan interval + if (lDicomData.XYZdim[4] > 1) and ((lRangeRA[kDynTime].max-lRangeRA[kDynTime].min)> 0) {1384} then begin + lReportedTRStr := 'Reported TR: '+floattostrf(lDicomData.TR,ffFixed,8,2)+kCR; + lDicomData.TR := (lRangeRA[kDynTime].max-lRangeRA[kDynTime].min) /(lDicomData.XYZdim[4] - 1)*1000; //infer TR in ms + end else + lReportedTRStr :=''; + //next: report header details + lDynStr := 'Philips PAR/REC Format' //'PAR/REC Format' + +kCR+ 'Patient name:'+lDicomData.PatientName + +kCR+ 'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'Volumes: ' +inttostr(lDicomData.XYZdim[4]) + +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'TR: '+floattostrf(lDicomData.TR,ffFixed,8,2) + +kCR+lReportedTRStr+kCR+lDynStr; + //if we get here, the header is fine, next steps will see if image format is readable... + lHdrOK := true; + if lSliceInfoCount < 1 then + goto 333; + //next: see if slices are in sequence + lSlicesNotInSequence := false; + if lSliceInfoCount > 1 then begin + lMaxSlice := lSliceSequenceRA^[1]; + lMaxIndex := lSliceIndexRA[1]; + lInc := 1; + repeat + inc(lInc); + if lSliceSequenceRA^[lInc] < lMaxSlice then //not in sequence if image has lower slice order than previous image + lSlicesNotInSequence := true + else + lMaxSlice := lSliceSequenceRA^[lInc]; + if lSliceIndexRA[lInc] < lMaxIndex then //not in sequence if image has lower slice index than previous image + lSlicesNotInSequence := true + else + lMaxIndex := lSliceIndexRA[lInc]; + until (lInc = lSliceInfoCount) or (lSlicesNotInSequence); + end; //at least 2 slices + //Next: report any errors + lErrorStr := ''; + if (lSlicesNotInSequence) and (not lReadOffsetTables) then + lErrorStr := lErrorStr + ' Slices not saved sequentially [using MRIcro''s ''Philips PAR to Analyze'' command may solve this]'+kCR; + if lSliceInfoCount > kMaxnSlices then + lErrorStr := lErrorStr + ' Too many slices: >'+inttostr(kMaxnSlices)+kCR; + if (not lReadVaryingScaleFactors) and ( (lRangeRA[kSlope].min <> lRangeRA[kSlope].max) + or (lRangeRA[kIntercept].min <> lRangeRA[kIntercept].max)) then + lErrorStr := lErrorStr + ' Differing intensity slope/intercept [using MRIcro''s ''Philips PAR to Analyze'' command may solve this]'+kCR; + if (lRangeRA[kBitsPerVoxel].min <> lRangeRA[kBitsPerVoxel].max) then //5D file space+time+cardiac + lErrorStr := lErrorStr + ' Differing bits per voxel'+kCR; + //if (lRangeRA^[kCardiac].min <> lRangeRA^[kCardiac].max) then //5D file space+time+cardiac + // lErrorStr := lErrorStr + 'Multiple cardiac timepoints'+kCR; + //if (lRangeRA^[kEcho].min <> lRangeRA^[kEcho].max) then //5D file space+time+echo + // lErrorStr := lErrorStr + 'Multiple echo timepoints'+kCR; + if (lRangeRA[kSliceThick].min <> lRangeRA[kSliceThick].max) or (lRangeRA[kSliceGap].min <> lRangeRA[kSliceGap].max) + or (lRangeRA[kXdim].min <> lRangeRA[kXdim].max) or (lRangeRA[kYDim].min <> lRangeRA[kYDim].max) + or (lRangeRA[kXmm].min <> lRangeRA[kXmm].max) or (lRangeRA[kYmm].min <> lRangeRA[kYmm].max) then + lErrorStr := lErrorStr + ' Multiple/varying slice dimensions'+kCR; + //if any errors were encountered, report them.... + if lErrorStr <> '' then begin + dcmMsg('read_PAR_data: This software can not convert this Philips data:'+kCR+lErrorStr); + goto 333; + end; + //Next sort image indexes here... + if (lSliceInfoCount > 1) and(lSlicesNotInSequence) and ( lReadOffsetTables) then begin //sort image order... + //ShellSort (first, last: integer; var lPositionRA, lIndexLoRA,lIndexHiRA: LongintP; var lRepeatedValues: boolean) + GetMem (lOffset_pos_table, lSliceInfoCount*sizeof(longint)); + for lInc := 1 to lSliceInfoCount do + lOffset_pos_table^[lInc] := lInc; + ShellSortItems (1, lSliceInfoCount,lOffset_pos_table,lSliceSequenceRA, lRepeatedValues); + if lRepeatedValues then begin + dcmMsg('read_PAR_data: fatal error, slices do not appear to have unique indexes [multiple copies of same slice]'); + FreeMem (lOffset_pos_table); + goto 333; + end; + lOffsetTableEntries := lSliceInfoCount; + end; //sort image order... + //Next, generate list of scale slope + if (lSliceInfoCount > 1) and (lReadVaryingScaleFactors) and ( (lRangeRA[kSlope].min <> lRangeRA[kSlope].max) + or (lRangeRA[kIntercept].min <> lRangeRA[kIntercept].max)) then begin {create offset LUT} + lVaryingScaleFactorsTableEntries := lSliceInfoCount; + getmem (lVaryingScaleFactors_table, lVaryingScaleFactorsTableEntries*sizeof(single)); + getmem (lVaryingIntercept_table, lVaryingScaleFactorsTableEntries*sizeof(single)); + if lOffsetTableEntries = lSliceInfoCount then begin //need to sort slices + + for lInc := 1 to lSliceInfoCount do begin + lVaryingScaleFactors_table^[lInc] := lSliceSlopeRA[lOffset_pos_table^[lInc]]; + lVaryingIntercept_table^[lInc] := lSliceInterceptRA[lOffset_pos_table^[lInc]]; +if gPARprecise then begin + if (lVaryingIntercept_table^[lInc] <> 0) or (lCalibratedSliceSlopeRA[lOffset_pos_table^[lInc]]=0) then + dcmMsg('Warning: Unable to save calibrated Philips image intensity (non-zero scaling intercept). Turn off Etc/Options/CalibratedScaling to hide warning.') + else begin + lVaryingScaleFactors_table^[lInc] := 1 / lCalibratedSliceSlopeRA[lOffset_pos_table^[lInc]]; + end; +end; //if PARprecise + + end; + end else begin //if sorted, else unsorted + + for lInc := 1 to lSliceInfoCount do begin + lVaryingScaleFactors_table^[lInc] := lSliceSlopeRA[lInc]; + lVaryingIntercept_table^[lInc] := lSliceInterceptRA[lInc]; +if gPARprecise then begin + if (lVaryingIntercept_table^[lInc] <> 0) or (lCalibratedSliceSlopeRA[lInc]=0) then + dcmMsg('Warning: Unable to save calibrated Philips image intensity (non-zero scaling intercept). Turn off Etc/Options/CalibratedScaling to hide warning.') + else + lVaryingScaleFactors_table^[lInc] := 1 / lCalibratedSliceSlopeRA[lInc]; +end; //if PARprecise + + end; + end; //slices sorted + end;//read scale factors + //Next: now adjust Offsets to point to byte offset instead of slice number + lSliceSz := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*(lDicomData.Allocbits_per_pixel div 8); + if lOffsetTableEntries = lSliceInfoCount then + for lInc := 1 to lSliceInfoCount do + lOffset_pos_table^[lInc] := lSliceSz * (lSliceIndexRA[lOffset_pos_table^[lInc]]); + //report if 5D/6D/7D file is being saved as 4D + if (lRangeRA[kCardiac].min <> lRangeRA[kCardiac].max) + or (lRangeRA[kEcho].min <> lRangeRA[kEcho].max) //5D file space+time+echo + or (lRangeRA[kType].min <> lRangeRA[kType].max) //5D file space+time+echo + or (lRangeRA[kSequence].min <> lRangeRA[kSequence].max) then //5D file space+time+echo + dcmMsg('Warning: note that this image has more than 4 dimensions (multiple Cardiac/Echo/Type/Sequence)'); + //if we get here, the Image Format is OK + lImageFormatOK := true; + lFileName := changefileextX(lFilename,'.rec'); //for Linux: case sensitive extension search '.rec' <> '.REC' + 333: //abort clause: skips lHdrOK and lImageFormatOK + //next: free dynamically allocated memory + FreeMem( lCharRA); + FreeMem (lSliceSequenceRA); +end; *) + +procedure read_ge_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 539; +var + lGap,lSliceThick,lTempFloat: single; + lTemp16,lI: word; + lSeriesOffset,lTemp32,lExamHdr,lImgHdr,lDATFormatOffset,lHdrOffset,lCompress,linitialoffset,n,filesz: LongInt; + tx : array [0..36] of Char; + FP: file; + lGEodd,lGEFlag,{lSpecial,}lMR: boolean; +function GEflag: boolean; +begin + if (tx[0] = 'I') AND (tx[1]= 'M') AND (tx[2] = 'G')AND (tx[3]= 'F') then + result := true + else + result := false; +end; +function swap16i(lPos: longint): word; +var + w : Word; +begin + seek(fp,lPos-2); + BlockRead(fp, W, 2); + result := swap(W); +end; + +function swap32i(lPos: longint): Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap32i:=outguy.Long; +end; +function fswap4r (lPos: longint): single; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(float:single); + end; + swaptypep = ^swaptype; +var + s:single; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + fswap4r:=outguy.float; +end; +begin + lImageFormatOK := true; + lSeriesOffset := 0; + lSLiceThick := 0; + lGap := 0; + lHdrOK := false; + lHdrOffset := 0; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + lDATFormatOffset := 0; + Clear_Dicom_Data(lDicomData); + if filesz < (3240) then begin + dcmMsg('This file is too small to be a Genesis DAT format image.'); + goto 539; + end; + lDynStr:= ''; + //lGEFlag := false; + lInitialOffset := 3228;//3240; + seek(fp, lInitialOffset); + BlockRead(fp, tx, 4*SizeOf(Char), n); + lGEflag := GEFlag; + if not lGEFlag then begin + lInitialOffset := 3240; + seek(fp, lInitialOffset); + BlockRead(fp, tx, 4*SizeOf(Char), n); + lGEflag := GEFlag; + end; + lGEodd := lGEFlag; + if not lGEFlag then begin + lInitialOffset := 0; + seek(fp, lInitialOffset); + BlockRead(fp, tx, 4*SizeOf(Char), n); + if not GEflag then begin {DAT format} + lDynStr := lDynStr+'GE Genesis Signa DAT tape format'+kCR; + seek(fp,114); + BlockRead(fp, tx, 4*SizeOf(Char), n); + lDynStr := lDynStr + 'Suite: '; + for lI := 0 to 3 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + + seek(fp,114+97); + BlockRead(fp, tx, 25*SizeOf(Char), n); + lDynStr := lDynStr + 'Patient Name: '; + for lI := 0 to 24 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + seek(fp,114+84); + BlockRead(fp, tx, 13*SizeOf(Char), n); + lDynStr := lDynStr + 'Patient ID: '; + for lI := 0 to 12 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + seek(fp, 114+305); + BlockRead(fp, tx, 3*SizeOf(Char), n); + if (tx[0]='M') and (tx[1] = 'R') then + lMR := true + else if (tx[0] = 'C') and(tx[1] = 'T') then + lMR := false + else begin + dcmMsg('Is this a Genesis DAT image? The modality is '+tx[0]+tx[1]+tx[3] + +'. Expected ''MR'' or ''CT''.'); + goto 539; + end; + if lMR then + lInitialOffset := 3180 + else + lInitialOffset := 3178; + seek(fp, lInitialOffset); + BlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] <> 'I') OR (tx[1] <> 'M') OR (tx[2] <> 'G') OR (tx[3] <> 'F') then begin + dcmMsg('This image does not have the required label ''IMGF''. This is not a Genesis DAT image.'); + goto 539; + end else + lDicomData.ImageNum := swap16i(2158+12); + lDicomData.XYZmm[3] := fswap4r (2158+26);// slice thickness mm + lDicomData.XYZmm[1] := fswap4r (2158+50);// pixel size- X + lDicomData.XYZmm[2] := fswap4r (2158+54);//pixel size - Y + lSliceThick := lDicomData.XYZmm[3]; + lGap := fswap4r (lHdrOffset+118);//1410 gap thickness mm + if lGap > 0 then + lDicomData.XYZmm[3] := lDicomData.XYZmm[3] + lGap; + lDATFormatOffset := 4; + if lMR then begin + lTemp32 := swap32i(2158+194); + lDynStr := lDynStr +'TR[usec]: '+inttostr(lTemp32) + kCR; + lTemp32 := swap32i(2158+198); + lDynStr := lDynStr +'TInvert[usec]: '+inttostr(lTemp32) + kCR; + lTemp32 := swap32i(2158+202); + lDynStr := lDynStr +'TE[usec]: '+inttostr(lTemp32) + kCR; + lTemp16 := swap16i(2158+210); + lDynStr := lDynStr +'Number of echoes: '+inttostr(lTemp16) + kCR; + lTemp16 := swap16i(2158+212); + lDynStr := lDynStr +'Echo: '+inttostr(lTemp16) + kCR; + + lTempFloat := fswap4r (2158+50); //not sure why I changed this to 50... 218 in Clunie's Description + lDynStr := lDynStr +'NEX: '+floattostr(lTempFloat) + kCR; + + seek(fp,2158+308); + BlockRead(fp, tx, 33*SizeOf(Char), n); + lDynStr := lDynStr + 'Sequence: '; + for lI := 0 to 32 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + + + seek(fp,2158+362); + BlockRead(fp, tx, 17*SizeOf(Char), n); + lDynStr := lDynStr + 'Coil: '; + for lI := 0 to 16 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + + + end; + + end; {DAT format} +end; + lDicomData.ImageStart := lDATFormatOffset+linitialoffset + swap32i(linitialoffset+4);//byte displacement to image data + lDicomData.XYZdim[1] := swap32i(linitialoffset+8); //width + lDicomData.XYZdim[2] := swap32i(linitialoffset+12);//height + lDicomData.Allocbits_per_pixel := swap32i(linitialoffset+16);//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lCompress := swap32i(linitialoffset+20); //compression + lExamHdr := swap32i(linitialoffset+136); + lImgHdr := swap32i(linitialoffset+152); + if (lImgHdr = 0) and (lDicomData.ImageStart = 8432) then begin + lDicomData.ImageNum := swap16i(2310+12); + lDicomData.XYZmm[3] := fswap4r (2310+26);// slice thickness mm + lDicomData.XYZmm[1] := fswap4r (2310+50);// pixel size- X + lDicomData.XYZmm[2] := fswap4r (2310+54);//pixel size - Y + lSliceThick := lDicomData.XYZmm[3]; + lGap := fswap4r (lHdrOffset+118);//1410 gap thickness mm + if lGap > 0 then + lDicomData.XYZmm[3] := lDicomData.XYZmm[3] + lGap; + + end else if {(lSpecial = false) and} (lDATFormatOffset = 0) then begin + lDynStr := lDynStr+'GE Genesis Signa format'+kCR; + if (not lGEodd) and (lExamHdr <> 0) then begin + lHdrOffset := swap32i(linitialoffset+132);//x132- int ptr to exam header + dcmMsg('exam header offset '+inttostr(lHdrOffset)); + //Patient ID + seek(fp,lHdrOffset+84); + BlockRead(fp, tx, 13*SizeOf(Char), n); + lDynStr := lDynStr + 'Patient ID: '; + for lI := 0 to 12 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + //Patient Name + seek(fp,lHdrOffset+97); + BlockRead(fp, tx, 25*SizeOf(Char), n); + lDynStr := lDynStr + 'Patient Name: '; + for lI := 0 to 24 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; +//Patient Age + lI := swap16i(lHdrOffset+122); + lDynStr := lDynStr+'Patient Age: '+inttostr(lI)+kCR; +//Modality: MR or CT + seek(fp,lHdrOffset+305); + BlockRead(fp, tx, 3*SizeOf(Char), n); + lDynStr := lDynStr + 'Type: '; + for lI := 0 to 1 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; +//Read series header + lSeriesOffset := swap32i(linitialoffset+144);//read size of series header: only read if >0 + if lSeriesOffset > 12 then begin + lSeriesOffset := swap32i(linitialoffset+140);//read size of series header: only read if >0 + lI := swap16i(lSeriesOffset+10); + //lDynStr := lDynStr+'Series number: '+inttostr(lI)+kCR; + lDicomData.SeriesNum := lI; + end; + //image data + lHdrOffset := swap32i(linitialoffset+148);//x148- int ptr to image header + end; + if lGEodd then lHdrOffset := 2158+28; + if ((lHdrOffset +58) < FileSz) and (lImgHdr <> 0) then begin + dcmMsg('image header offset '+inttostr(lHdrOffset)); + lDicomData.AcquNum := swap16i(lHdrOffset+12); //note SERIES not IMAGE number, despite what Clunies FAQ says + lDicomData.ImageNum := swap16i(lHdrOffset+14); //this is IMAGEnum + + //lDynStr := lDynStr +'Image number: '+inttostr(lDicomData.ImageNum)+ kCR; + lDicomData.XYZmm[3] := fswap4r (lHdrOffset+26);// slice thickness mm + lDicomData.XYZmm[1] := fswap4r (lHdrOffset+50);// pixel size- X + lDicomData.XYZmm[2] := fswap4r (lHdrOffset+54);//pixel size - Y + lSliceThick := lDicomData.XYZmm[3]; + lGap := fswap4r (lHdrOffset+118);//1410 gap thickness mm + if lGap > 0 then + lDicomData.XYZmm[3] := lDicomData.XYZmm[3] + lGap; + + end; + end; + if (lCompress = 3) or (lCompress = 4) then begin + lImageFormatOK := false;//xlDicomData.GenesisCpt := true; + lDynStr := lDynStr+'Compressed data'+kCR; + end else + ;//xlDicomData.GenesisCpt := false; + if (lCompress = 2) or (lCompress = 4) then begin + lImageFormatOK := false;//xlDicomData.GenesisPackHdr := swap32i(linitialoffset+64); + lDynStr := lDynStr+'Packed data'+kCR; + end else + //xlDicomData.GenesisPackHdr := 0; + lDynStr := lDynStr+'Series Number: '+inttostr(lDicomData.SeriesNum) + +kCR+'Acquisition Number: '+inttostr(lDicomData.AcquNum) + +kCR+'Image Number: '+inttostr(lDicomData.ImageNum) + +kCR+'Slice Thickness/Gap: '+floattostrf(lSliceThick,ffFixed,8,2)+'/'+floattostrf(lGap,ffFixed,8,2) + +kCR+'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + dcmMsg(lDynStr); + lDicomData.Little_Endian := 0; + lHdrOK := true; + 539: + CloseFile(fp); + FileMode := 2; //set to read/write +end;//read_ge + + +//start siemens +procedure read_siemens_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 567; +var + lI: word; + lYear,lMonth,lDay,n,filesz,lFullSz,lMatrixSz,lIHour,lIMin,lISec{,lAHour,lAMin,lASec}: LongInt; + lFlipAngle,lGap,lSliceThick: double; + tx : array [0..26] of Char; + lMagField,lTE,lTR: double; + lInstitution,lName, lID,lMinStr,lSecStr{,lAMinStr,lASecStr}: String; + FP: file; +function swap32i(lPos: longint): Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap32i:=outguy.Long; + //swap32i:=inguy.Long; +end; +function fswap8r (lPos: longint): double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + s:double; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 8, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + fswap8r:=outguy.float; +end; +begin + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if filesz < (6144) then begin + dcmMsg('This file is to small to be a Siemens Magnetom Vision image.'); + goto 567; + end; + seek(fp, 96); + BlockRead(fp, tx, 7*SizeOf(Char), n); + if (tx[0] <> 'S') OR (tx[1] <> 'I') OR (tx[2] <> 'E') OR (tx[3] <> 'M') then begin {manufacturer is not SIEMENS} + dcmMsg('Is this a Siemens Magnetom Vision image [Manufacturer tag should be ''SIEMENS''].'); + goto 567; + end; {manufacturer not siemens} + seek(fp, 105); + BlockRead(fp, Tx, 25*SizeOf(Char), n); + lINstitution := ''; + for lI := 0 to 24 do begin + if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lINstitution := lINstitution + tx[lI]; + end; seek(fp, 768); + BlockRead(fp, Tx, 25*SizeOf(Char), n); + lName := ''; + for lI := 0 to 24 do begin + if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lName := lName + tx[lI]; + end; + seek(fp, 795); + BlockRead(fp, Tx, 12*SizeOf(Char), n); + lID := ''; + for lI := 0 to 11 do begin + if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lID := lID + tx[lI]; + end; + lDicomData.ImageStart := 6144; + lYear := swap32i(0); + lMonth := swap32i(4); + lDay := swap32i(8); + lIHour := swap32i(68); + lIMin := swap32i(72); + lISec := swap32i(76); + lDicomData.XYZmm[3] := fswap8r (1544); + lMagField := fswap8r (2560); + lTR := fswap8r (1560); + lTE := fswap8r (1568); + lDIcomData.AcquNum := swap32i(3212); + lMatrixSz := swap32i(2864); + lDicomData.SiemensSlices := swap32i(4004); //1366 + //lFullSz := swap32i(4008); + //lInterleaveIf4 := swap32i(2888); + lFullSz := (2*lMatrixSz*lMatrixSz);//16bitdata + if ((FileSz - 6144) mod lFullSz) = 0 then begin + case ((FileSz-6144) div lFullSz) of + 4: lFullSz := 2*lMatrixSz; + 9: lFullSz := 3*lMatrixSz; + 16: lFullSz := 4*lMatrixSz; + 25: lFullSz := 5*lMatrixSz; + 36: lFullSz := 6*lMatrixSz; + 49: lFullSz := 7*lMatrixSz; + 64: lFullSz := 8*lMatrixSz; + else lFullSz := lMatrixSz; + end; + end else lFullSz := lMatrixSz; + {3744/3752 are XY FOV in mm!} + lDicomData.XYZdim[1] := lFullSz;//lMatrixSz; //width + lDicomData.XYZdim[2] := lFullSz;//lMatrixSz;//height + {5000/5008 are size in mm, but wrong for mosaics} + if lMatrixSz <> 0 then begin + lDicomData.XYZmm[2] := fswap8r (3744)/lMatrixSz; + lDicomData.XYZmm[1] := fswap8r (3752)/lMatrixSz; + if ((lDicomData.XYZdim[1] mod lMatrixSz)=0) then + lDicomData.SiemensMosaicX := lDicomData.XYZdim[1] div lMatrixSz; + if ((lDicomData.XYZdim[2] mod lMatrixSz)=0) then + lDicomData.SiemensMosaicY := lDicomData.XYZdim[2] div lMatrixSz; + if lDicomData.SiemensMosaicX < 1 then lDicomData.SiemensMosaicX := 1; //1366 + if lDicomData.SiemensMosaicY < 1 then lDicomData.SiemensMosaicY := 1; //1366 + end; + lFlipAngle := fswap8r (2112); //1414 +{ lDicomData.XYZmm[2] := fswap8r (5000); + lDicomData.XYZmm[1] := fswap8r (5008);} + lSliceThick := lDicomData.XYZmm[3]; + lGap := fswap8r (4136); //gap as ratio of slice thickness?!?! + if {lGap > 0} (lGap=-1) or (lGap=-19222) then //1410: exclusion values: do not ask me why 19222: from John Ashburner + else begin + //lDicomData.XYZmm[3] := abs(lDicomData.XYZmm[3] * (1+lGap)); + lGap := lDicomData.XYZmm[3] * (lGap); + lDicomData.XYZmm[3] := abs(lDicomData.XYZmm[3] +lGap); + end; + lDicomData.Allocbits_per_pixel := 16;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + //xlDicomData.GenesisCpt := false; + //xlDicomData.GenesisPackHdr := 0; + lMinStr := inttostr(lIMin); + if length(lMinStr) = 1 then lMinStr := '0'+lMinStr; + lSecStr := inttostr(lISec); + if length(lSecStr) = 1 then lSecStr := '0'+lSecStr; + + + + lDynStr := 'Siemens Magnetom Vision Format'+kCR+'Name: '+lName+kCR+'ID: '+lID+kCR+'Institution: '+lInstitution+kCR+ + 'Study DD/MM/YYYY: '+inttostr(lDay)+'/'+inttostr(lMonth)+'/'+inttostr(lYear)+kCR+ + 'Image Hour/Min/Sec: '+inttostr(lIHour)+':'+lMinStr+':'+lSecStr+kCR+ + //'Acquisition Hour/Min/Sec: '+inttostr(lAHour)+':'+lAMinStr+':'+lASecStr+kCR+ + 'Magnetic Field Strength: '+ floattostrf(lMagField,ffFixed,8,2)+kCR+ + 'Image index: '+inttostr(lDIcomData.AcquNum)+kCR+ + 'Time Repitition/Echo [TR/TE]: '+ floattostrf(lTR,ffFixed,8,2)+'/'+ floattostrf(lTE,ffFixed,8,2)+kCR+ + 'Flip Angle: '+ floattostrf(lFlipAngle,ffFixed,8,2)+kCR+ + 'Slice Thickness/Gap: '+floattostrf(lSliceThick,ffFixed,8,2)+'/'+floattostrf(lGap,ffFixed,8,2)+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3])+kCR+ + 'XY matrix:' +inttostr(lDicomData.SiemensMosaicX)+'/' + +inttostr(lDicomData.SiemensMosaicY)+kCR+ + 'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + lHdrOK := true; + //lDIcomData.AcquNum := 0; +567: +CloseFile(fp); + FileMode := 2; //set to read/write +end; +//end siemens +//begin elscint +procedure read_elscint_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 539; +var + //lExamHdr,lImgHdr,lDATFormatOffset,lHdrOffset, + {lDate,}lI,lCompress,n,filesz: LongInt; + tx : array [0..41] of Char; + FP: file; +function readStr(lPos,lLen: integer): string; +var lStr: string; + lStrInc: integer; +begin + seek(fp,lPos); + BlockRead(fp, tx, lLen, n); + lStr := ''; + for lStrInc := 0 to (lLen-1) do + lStr := lStr + tx[lStrInc]; + result := lStr +end; +function read8ch(lPos: integer): char; +begin + seek(fp,40); + BlockRead(fp, result, 1, n); + //lDicomData.ImageNum := ord(tx[0]); +end; +procedure read16i(lPos: longint; var lVal: integer); +var lInWord: word; +begin + seek(fp,lPos); + BlockRead(fp, lInWord, 2); + lVal := lInWord; +end; +procedure read32i(lPos: longint; var lVal: integer); +var lInINt: integer; +begin + seek(fp,lPos); + BlockRead(fp, lInINt, 4); + lVal :=lInINt; +end; + +begin + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if filesz < (3240) then begin + dcmMsg('This file is too small to be a Elscint format image.'); + goto 539; + end; + lDynStr:= ''; + read16i(0, lI); + if (lI <> 64206) then begin + dcmMsg('Unable to read this file: it does start with the Elscint signature.'); + goto 539; + end; + lDicomdata.little_endian := 1; + lDynStr:= 'Elscint Format'+kCR; + lDynStr := lDynStr+'Patient Name: '+readstr(4,20)+kCR; + lDynStr := lDynStr+'Patient ID: '+readstr(24,13)+kCR; + read16i(38,lDicomData.AcquNum); + lDicomData.ImageNum := ord(read8Ch(40)); + lDynStr := lDynStr+'Doctor & Ward: '+readstr(100,20)+kCR; + lDynStr := lDynStr+'Comments: '+readstr(120,40)+kCR; + if ord(read8Ch(163)) = 1 then + lDynStr := lDynStr + 'Sex: M'+kCR + else + lDynStr := lDynStr + 'Sex: F'+kCR; + read16i(200,lI); + lDicomData.XYZmm[3] := lI * 0.1; + read16i(370,lDicomData.XYZdim[1]); + read16i(372,lDicomData.XYZdim[2]); + read16i(374,lI); + lDicomData.XYZmm[1] := lI / 256; + lDicomData.XYZmm[2] := lDicomData.XYZmm[1]; + lCompress := ord(read8Ch(376)); + //xlDicomData.ElscintCompress := true; + //xread16i(400,lDicomData.WindowWidth); + //x read16i(398,lDicomData.WindowCenter); + case lCompress of + 0: begin + lDynStr := lDynStr + 'Compression: None'+kCR; + //xlDicomData.ElscintCompress := false; + end; + 1: lImageFormatOK := false;//xlDynStr := lDynStr + 'Compression: Old'+kCR; + 2: lImageFormatOK := false;//xlDynStr := lDynStr + 'Compression: 2400 Elite'+kCR; + 22: lImageFormatOK := false;//xlDynStr := lDynStr + 'Compression: Twin'+kCR; + else begin + lImageFormatOK := false;//xlDynStr := lDynStr + 'Compression: Unknown '+inttostr(lCOmpress)+kCR; + //lDicomData.ElscintCompress := false; + end; + end; + //lDicomData.XYZdim[1] := swap32i(linitialoffset+8); //width + //lDicomData.XYZdim[2] := swap32i(linitialoffset+12);//height + lDicomData.ImageStart := 396; + lDicomData.Allocbits_per_pixel := 16; + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + if (lDicomData.XYZdim[1]=160) and (lDicomData.XYZdim[2]= 160) and (FIleSz=52224) then begin + lDicomData.ImageStart := 1024; + lImageFormatOK := true;//x//xlDicomData.ElscintCompress := False; + end; + //lDicomData.XYZmm[3] := fswap4r (2310+26);// slice thickness mm + lDynStr := lDynStr+'Image/Study Number: '+inttostr(lDicomData.ImageNum)+'/'+ inttostr(lDicomData.AcquNum)+kCR + +'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + //x+kCR+'Window Center/Width: '+inttostr(lDicomData.WindowCenter)+'/'+inttostr(lDicomData.WindowWidth) + +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + lHdrOK := true; + lImageFormatOK := true; + 539: + CloseFile(fp); + FileMode := 2; //set to read/write +end; +//end elscint + + + +//start picker +procedure read_picker_data(lVerboseRead: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label 423; +const kPickerHeader =8192; +kRecStart = 280; //is this a constant? +var + lDataStart,lVal,lDBPos,lPos,lRecSz, lNumRecs,lRec,FileSz,n: Longint; + lThkM,lThkN,lSiz: double; + tx : array [0..6] of Char; + FP: file; + lDiskCacheRA: pChar; +function ReadRec(lRecNum: integer): boolean; +var + lNameStr,lValStr: string; + lOffset,lLen,lFPOs,lFEnd: integer; +function ValStrToFloat: double; +var lConvStr: string; + lI: integer; +begin + Result := 0.0; + lLen := Length(lValStr); + if lLen < 1 then exit; + lConvStr := ''; + for lI := 1 to lLen do + if lValStr[lI] in ['0'..'9'] then + lConvStr := lConvStr+ lValStr[lI]; + if Length(lConvStr) < 1 then exit; + Result := strtofloat(lConvStr); +end; +begin + Result := false; + lFPos := ((lRecNum-1) * lRecSz)+ kRecStart; + lFEnd := lFpos + 6; + lNameStr := ''; + for lFPos := lFPos to lFEnd do + if ord(lDiskCacheRA[lFPos]) <> 0 then + lNameStr := lNameStr +lDiskCacheRA[lFPos]; + if (lVerboseRead) or (lNameStr = 'RCNFSIZ') or (lNameStr='SCNTHKM') or (lNameStr='SCNTHKN') then begin + lFPos := ((lRecNum-1) * lRecSz)+ kRecStart+8; + lFEnd := lFPos+1; + lOffset := 0; + for lFPos := lFPos to lFend do + lOffset := ((lOffset)shl 8)+(ord(lDiskCacheRA[lFPos])); + lFPos := ((lRecNum-1) * lRecSz)+ kRecStart+10; + lFEnd := lFPos+1; + lLen := 0; + for lFPos := lFPos to lFend do + lLen := ((lLen)shl 8)+(ord(lDiskCacheRA[lFPos])); + lOffset := lDataStart+lOffset+1; + lFEnd := lOffset+lLen-1; + if (lLen < 1) or (lFEnd > kPickerHeader) then exit; + lValStr := ''; + for lFPos := (lOffset) to lFEnd do begin + lValStr := lValStr+lDiskCacheRA[lFPos]; + end; + if lVerboseRead then lDynStr := lDynStr+kCR+lNameStr+': '+ lValStr; + if (lNameStr = 'RCNFSIZ') then lSiz := ValStrToFloat; + if (lNameStr='SCNTHKM') then lThkM := ValStrToFloat; + if (lNameStr='SCNTHKN') then lThkN := ValStrToFloat; + end; //verboseread, or vital value + result := true; +end; +function FindStr(l1,l2,l3,l4,l5: Char; lReadNum: boolean; var lNum: integer): boolean; +var //lMarker: integer; + lNumStr: String; +begin + Result := false; + repeat + if (lDiskCacheRA[lPos-4]=l1) and (lDiskCacheRA[lPos-3]=l2) + and (lDiskCacheRA[lPos-2]=l3) and (lDiskCacheRA[lPos-1]=l4) + and (lDiskCacheRA[lPos]=l5) then Result := true; + inc (lPos); + until (Result) or (lPos >= kPickerHeader); + if not Result then exit; + if not lReadNum then exit; + Result := false; + lNumStr := ''; + repeat + if (lDiskCacheRA[lPos] in ['0'..'9']) then + lNumStr := lNumStr + lDiskCacheRA[lPos] + else if lNumStr <> '' then Result := true; + inc(lPos); + until (Result) or (lPos = kPickerHeader); + lNum := strtoint(lNumStr); +end; +begin + lSiz := 0.0; + lThkM := 0.0; + lThkN := 0.0; + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if filesz < (kPickerHeader) then begin + dcmMsg('This file is to small to be a Picker image: '+lFileName ); + CloseFile(fp); + FileMode := 2; //set to read/write + exit; + end; + seek(fp, 0); + BlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] <> '*') OR (tx[1] <> '*') OR (tx[2] <> '*') OR (tx[3] <> ' ') then begin {manufacturer is not SIEMENS} + dcmMsg('Is this a Picker image? Expected ''***'' at the start of the file.'+ lFileName); + CloseFile(fp); + FileMode := 2; //set to read/write + exit; + end; {not picker} + if filesz = (kPickerHeader + (1024*1024*2)) then begin + lDICOMdata.XYZdim[1] := 1024; + lDICOMdata.XYZdim[2] := 1024; + lDICOMdata.XYZdim[3] := 1; + lDICOMdata.ImageStart := 8192; + end else + if filesz = (kPickerHeader + (512*512*2)) then begin + lDICOMdata.XYZdim[1] := 512; + lDICOMdata.XYZdim[2] := 512; + lDICOMdata.XYZdim[3] := 1; + lDICOMdata.ImageStart := 8192; + end else + if filesz = (8192 + (256*256*2)) then begin + lDICOMdata.XYZdim[1] := 256; + lDICOMdata.XYZdim[2] := 256; + lDICOMdata.XYZdim[3] := 1; + lDICOMdata.ImageStart := 8192; + end else begin + dcmMsg('This file is the incorrect size to be a Picker image.'); + CloseFile(fp); + FileMode := 2; //set to read/write + exit; + end; + getmem(lDiskCacheRA,kPickerHeader*sizeof(char)); + seek(fp, 0); + BlockRead(fp, lDiskCacheRA, kPickerHeader, n); + lRecSz := 0; + lNumRecs := 0; + lPos := 5; + if not FindStr('d','b','r','e','c',false, lVal) then goto 423; + lDBPos := lPos; + if not FindStr('r','e','c','s','z',true, lRecSz) then goto 423; + lPos := lDBPos; + if not FindStr('n','r','e','c','s',true, lnumRecs) then goto 423; + lPos := kRecStart; // IS THIS A CONSTANT??? + lDataStart :=kRecStart + (lRecSz*lnumRecs)-1; //file starts at 0, so -1 + if (lNumRecs = 0) or (lDataStart> kPickerHeader) then goto 423; + lRec := 0; + lDynStr := 'Picker Format'; + repeat + inc(lRec); + until (not (ReadRec(lRec))) or (lRec >= lnumRecs); + if lSiz <> 0 then begin + lDICOMdata.XYZmm[1] := lSiz/lDICOMdata.XYZdim[1]; + lDICOMdata.XYZmm[2] := lSiz/lDICOMdata.XYZdim[2]; + if lVerboseRead then + lDynStr := lDynStr+kCR+'Voxel Size: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2) + +'x'+ floattostrf(lDicomData.XYZmm[2],ffFixed,8,2); + end; + if (lThkM <> 0) and (lThkN <> 0) then begin + lDICOMdata.XYZmm[3] := lThkN/lThkM; + if lVerboseRead then + lDynStr := lDynStr+kCR+'Slice Thickness: '+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + end; + 423: + freemem(lDiskCacheRA); + lHdrOK := true; + CloseFile(fp); + FileMode := 2; //set to read/write +end; +//end picker + +procedure read_minc_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +var +// lReal: double; + lnOri,lnDim,lStartPosition,nelem0,jj,lDT0,vSizeRA,BeginRA,m,nnelem,nc_type,nc_size,lLen,nelem,j,lFilePosition,lDT,lFileSz,lSignature,lWord: integer; + + lOri: array [1..3] of double; + //tx : array [0..80] of Char; + lVarStr,lStr: string; + FP: file; +function dTypeStr (lV: integer): integer; +begin + case lV of + 1,2: result := 1; + 3: result := 2; //int16 + 4: result := 4; //int32 + 5: result := 4; //single + 6: result := 8; //double + end; +end; //nested fcn dTypeStr + +function read32i: Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lFilePosition); + lFilePosition := lFilePosition + 4; + BlockRead(fp, s, 4); + inguy := @s; //assign address of s to inguy + if lDICOMdata.Little_Endian = 0 then begin + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + end else + outguy.long := inguy^.long; + result:=outguy.Long; +end; + +function read64r (lDataType: integer): Double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(Long:Double); + end; + swaptypep = ^swaptype; +var + s : Double; + inguy:swaptypep; + outguy:swaptype; +begin + result := 1; + if lDataType <> 6 then begin + dcmMsg('Unknown data type: MRIcro is unable to determine the voxel size.'); + exit; + end; + seek(fp,lFilePosition); + lFilePosition := lFilePosition + 8; + BlockRead(fp, s, 8); + inguy := @s; //assign address of s to inguy + if lDICOMdata.Little_Endian = 0 then begin + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + end else + outguy.long := inguy^.long; + result:=outguy.Long; +end; + +function readname: String; +var lI,lLen: integer; + lCh: char; +begin + result := ''; + seek(fp,lFilePosition); + lLen := read32i; + if lLen < 1 then begin + dcmMsg('Terminal error reading netCDF/MINC header (String length < 1)'); + exit; //problem + end; + for lI := 1 to lLen do begin + BlockRead(fp, lCh, 1); + result := result + lCh; + end; + lFilePosition := lFilePosition + (((lLen+3) div 4) * 4); +end; + +begin + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + for lnOri := 1 to 3 do + lOri[lnOri] := 0; + lnOri := 4; + lnDim := 4; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if lFilesz < (77) then exit; //to small to be MINC + + lFilePosition := 0; + lSignature := read32i; + if not (lSignature=1128547841) then begin + CloseFile(fp); + FileMode := 2; //set to read/write + dcmMsg('Problem with MINC signature: '+ inttostr(lSignature)); + exit; + end; + //xlDicomData.Rotate180deg := true; + lWord := read32i;//numrecs + lDT := read32i; + while (lDt=10) or (lDT=11) or (lDT=12) do begin + if lDT = 10 then begin //DT=10, Dimensions + nelem := read32i; + for j := 1 to nelem do begin + lStr := readname; + lLen := read32i; + if lStr = 'xspace' then lDicomData.XYZdim[3] := lLen;//DOES MINC always reverse X and Z? see also XYZmm + if lStr = 'yspace' then lDicomData.XYZdim[2] := lLen; + if lStr = 'zspace' then lDicomData.XYZdim[1] := lLen; + end; //for 1..nelem + lDT := read32i; + end;//DT=10, Dimensions + if lDT = 11 then begin //DT=11, Variables + nelem := read32i; + for j := 1 to nelem do begin + lVarStr := readname; + nnelem := read32i; + for m := 1 to nnelem do + lLen := read32i; + lDT0 := read32i; + if lDT0 = 12 then begin + nelem0 := read32i; + for jj := 1 to nelem0 do begin + lStr := readname; + nc_type := read32i; + nc_size := dTypeStr(nc_Type); + nnelem := read32i; + lStartPosition := lFilePosition; + + if (lStr = 'step') then begin + + if (lVarStr = 'xspace') or (lVarStr = 'yspace') or (lVarStr = 'zspace') then begin + dec(lnDim); + if (lnDim < 4) and (lnDim>0) then + lDicomData.XYZmm[lnDim] := read64r(nc_Type) + end; + + end else if (lStr = 'start') then begin + if (lVarStr = 'xspace') or (lVarStr = 'yspace') or (lVarStr = 'zspace') then begin + dec(lnOri); + if (lnOri < 4) and (lnOri > 0) then + lOri[lnOri] := read64r(nc_Type) + end; + end; + lFilePosition := lStartPosition + ((((nnelem*nc_size)+3) div 4)*4); + + end; + lDT0 := read32i; + if lVarStr = 'image' then begin + case lDT0 of + 1,2: lDicomData.Allocbits_per_pixel := 8; + 3: lDicomData.Allocbits_per_pixel := 16; //int16 + 4: lDicomData.Allocbits_per_pixel := 32; //int32 + 5: lDicomData.Allocbits_per_pixel := 32; //single + 6: lDicomData.Allocbits_per_pixel := 64; //double + end; + if (lDT0 = 5) or (lDT0 = 6) then + lDicomData.FloatData := true; + //xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; + //lImgNC_Type := lDT0; + end; + end; + vSizeRA := read32i; + BeginRA := read32i; + if lVarStr = 'image' then begin + lDICOMdata.ImageStart := BeginRA; + end; + end; //for 1..nelem + lDT := read32i; + end;//DT=11 + if lDT = 12 then begin //DT=12, Attributes + nelem := read32i; + for j := 1 to nelem do begin + lStr := readname; + nc_type := read32i; + nc_size := dTypeStr(nc_Type); + nnelem := read32i; + lFilePosition := lFilePosition + ((((nnelem*nc_size)+3) div 4)*4); + end; //for 1..nelem + lDT := read32i; + end;//DT=12, Dimensions + end; //while DT + + if lOri[1] <> 0 then + lDicomData.XYZori[1] := round((-lOri[1])/lDicomData.XYZmm[1])+1; + if lOri[2] <> 0 then + lDicomData.XYZori[2] := round((-lOri[2])/lDicomData.XYZmm[2])+1; + if lOri[3] <> 0 then + lDicomData.XYZori[3] := round((-lOri[3])/lDicomData.XYZmm[3])+1; + + lDynStr := 'MINC image'+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ origin:' +inttostr(lDicomData.XYZori[1])+'/' + +inttostr(lDicomData.XYZori[2])+'/'+inttostr(lDicomData.XYZori[3]) + +kCR+'XYZ size [mm or micron]:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'Bits per sample/Samples per pixel: '+inttostr( lDICOMdata.Allocbits_per_pixel) + +kCR+'Data offset:' +inttostr(lDicomData.ImageStart); + lHdrOK := true; + lImageFormatOK := true; + CloseFile(fp); + FileMode := 2; //set to read/write +end; //read_minc + + + +//start TIF +procedure read_tiff_data(var lDICOMdata: DICOMdata; var lReadOffsets, lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 566, 564; +const + kMaxnSLices = 6000; +var + lLongRA: LongIntP; + lStackSameDim,lContiguous: boolean; + l1stDicomData: DicomData; + //lDouble : double; + //lXmm,lYmm,lZmm: double; + lSingle: single; + lImageDataEndPosition,lStripPositionOffset,lStripPositionType,lStripPositionItems, + lStripCountOffset,lStripCountType,lStripCountItems, + lItem,lTagItems,lTagItemBytes,lTagPointer,lNumerator, lDenominator, + lImage_File_Directory,lTagType,lVal,lDirOffset,lOffset,lFileSz, + lnDirectories,lDir,lnSlices: Integer; + lTag,lWord,lWord2: word; + FP: file; +(*FUNCTION longint2single ({var} s:longint): single; +//returns true if s is Infinity, NAN or Indeterminate +//4byte IEEE: msb[31] = signbit, bits[23-30] exponent, bits[0..22] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +VAR Overlay: Single ABSOLUTE s; +BEGIN + result := Overlay; +END;*) + +function read64r(lPos: integer):double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; + s: double; +begin + seek(fp,lPos); + BlockRead(fp, s, 8); + inguy := @s; //assign address of s to inguy + if lDICOMdata.Little_Endian = 0{false} then begin + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + end else + outguy.float := inguy^.float; + result:=outguy.float; +end; + +function read32i(lPos: longint): Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4); + inguy := @s; //assign address of s to inguy + if lDICOMdata.Little_Endian = 0 then begin + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + end else + outguy.long := inguy^.long; + result:=outguy.Long; +end; +function read16(lPos: longint): Longint; +var + s : word; +begin + seek(fp,lPos); + BlockRead(fp, s, 2); + if lDICOMdata.Little_Endian = 0 then + result := swap(s) + else + result := s; +end; + +function read8(lPos: longint): Longint; +var + s : byte; +begin + seek(fp,lPos); + BlockRead(fp, s, 1); + result := s; +end; + +function readItem(lItemNum,lTagTypeI,lTagPointerI: integer): integer; +begin + if lTagTypeI= 4 then + result := read32i(lTagPointerI+((lItemNum-1)*4)) + else + result := read16(lTagPointerI+((lItemNum-1)*2)); +end; + +begin + Clear_Dicom_Data(lDicomData); + if gECATJPEG_table_entries <> 0 then begin + freemem (gECATJPEG_pos_table); + freemem (gECATJPEG_size_table); + gECATJPEG_table_entries := 0; + end; + //lXmm := -1; //not read + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + //lLongRASz := kMaxnSlices * sizeof(longint); + getmem(lLongRA,kMaxnSlices*sizeof(longint)); + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + //xlDicomData.PlanarConfig:=0; + if lFilesz < (28) then begin + goto 566; + end; + //TmpStr := string(StrUpper(PChar(ExtractFileExt(lFileName)))); + //if not (TmpStr = '.TIF') or (TmpStr = '.TIFF') then exit; + lWord := read16(0); + if lWord = $4d4d then + lDICOMdata.little_endian := 0 + else if lWord = $4949 then lDICOMdata.little_endian := 1; + lWord2 := read16(2); //bits per pixel + if ((lWord=$4d4d) or (lWord=$4949)) and (lWord2 = $002a) then + else goto 566; + lOffset := read32i(4); + lImage_File_Directory := 0; + lContiguous := true; + lnSlices := 0; + //xlDicomData.SamplesPerPixel := 1; + //START while for each image_file_directory + while (lOffset > 0) and ((lOffset+2+12+4) < lFileSz) do begin + inc(lImage_File_Directory); + lnDirectories := read16(lOffset); + if (lnDirectories < 1) or ((lOffset+2+(12*lnDirectories)+4) > lFileSz) then + goto 566; + for lDir := 1 to lnDirectories do begin + lDirOffset := lOffset+2+((lDir-1)*12); + lTag := read16(lDirOffset); + lTagType := read16(lDirOffset+2); + lTagItems := read32i(lDirOffset+4); + case lTagType of + 1: lVal := 1;//bytes + 3: lVal := 2;//word + 4: lVal := 4;//long + 5: lVal := 8;//rational + else lVal := 1; //CHAR variable length + end; + lTagItemBytes := lVal * lTagItems; + if lTagItemBytes > 4 then + lTagPointer := read32i(lDirOffset+8) + else + lTagPointer := (lDirOffset+8); + case lTagType of + 1: lVal := read8(lDirOffset+8); + 3: lVal := read16(lDirOffset+8); + 4: lVal := read32i(lDirOffset+8); + 5: begin //rational: two longs representing numerator and denominator + lVal := read32i(lDirOffset+8); + lNumerator := read32i(lVal); + lDenominator := read32i(lVal+4); + if lDenominator <> 0 then + lSingle := lNumerator/lDenominator + else + lSingle := 1; + if lSingle <> 0 then + lSingle := 1/lSingle; //Xresolution/Yresolution refer to number of pixels per resolution_unit + if lTag = 282 then lDicomData.XYZmm[1] := lSingle; + if lTag = 283 then lDicomData.XYZmm[2] := lSingle; + end; + else lVal := 0; + end; + case lTag of + //254: ;//NewSubFileType + 256: lDicomData.XYZdim[1] := lVal;//image_width + 257: lDicomData.XYZdim[2] := lVal;//image_height + 258: begin //bits per sample + if lTagItemBytes > 4 then lVal := 8; + //if lVal <> 8 then goto 566; + lDicomData.Allocbits_per_pixel := lVal;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + end; + 259: begin + if lVal <> 1 then begin + dcmMsg('TIFF Read Error: Image data is compressed. Currently only uncompressed data is supported.'); + goto 566; //compressed data + end; + end; + //x262: if lVal = 0 then lDicomdata.monochrome := 1;//invert colors //photometric_interpretation //MinIsWhite,MinIsBlack,Palette + //270: ; //ImageDescription + 273: begin //get offset to data + lStripPositionOffset := lTagPointer; + lStripPositionType := lTagType; + lStripPositionItems := lTagItems; + if (lImage_File_Directory=1) then + lDicomData.ImageStart := readItem(1,lStripPositionType,lStripPositionOffset); + end; //StripOffsets + //274: ; //orientation + 277: begin + //xlDicomData.SamplesPerPixel := lVal; + //if lVal <> 1 then goto 566; //samples per pixel + end; + 279: begin + lStripCountOffset := lTagPointer; + lStripCountType := lTagType; + lStripCountItems := lTagItems; + end; + //278: message('rows:'+inttostr(lVal));//StripByteCount + //279: message('count:'+inttostr(lVal));//StripByteCount + //282 and 283 are rational values and read separately + 284: begin + {xif lVal = 1 then + lDicomData.PlanarConfig:= 0 + else + lDicomData.PlanarConfig:= 1;//planarConfig + } end; + 34412: begin + //Zeiss data header + //0020h float x size of a pixel (µm or s) + //0024h float y size of a pixel (µm or s) + //0028h float z distance in a sequence (µm or s) + {stream.seek((int)position + 40); + VOXELSIZE_X = swap(stream.readDouble()); + stream.seek((int)position + 48); + VOXELSIZE_Y = swap(stream.readDouble()); + stream.seek((int)position + 56); + VOXELSIZE_Z = swap(stream.readDouble());} + lVal := read16(lTagPointer+2); + if lVal = 1024 then begin //LSM510 v2.8 images + lDicomData.XYZmm[1]{lXmm} := read64r(lTagPointer+40)*1000000; + lDicomData.XYZmm[2]{lYmm} := read64r(lTagPointer+48)*1000000; + lDicomData.XYZmm[3]{lZmm} := read64r(lTagPointer+56)*1000000; + end; + //following may work if lVal = 2, different type of LSM file I have not seen + //lXmm := longint2single(read32i(lTagPointer+$0020)); + //lYmm := longint2single(read32i(lTagPointer+$0024)); + //lZmm := longint2single(read32i(lTagPointer+$0028)); + end; + //296: ;//resolutionUnit 1=undefined, 2=inch, 3=centimeter + //320?? + //LEICA: 34412 + //SOFTWARE = 305 + //DATE_TIME = 306 + //ARTIST = 315 + //PREDICTOR = 317 + //COLORMAP = 320 => essntially custom LookUpTable + //EXTRASAMPLES = 338 + //SAMPLEFORMAT = 339 + //JPEGTABLES = 347 + // lDicomData.ImageStart := lVal + //else if lImage_File_Directory = 1 then dcmMsg(inttostr(lTag)+'@'+inttostr(lTagPointer)+' value: '+inttostr(lVal)); + end; //case lTag + end; //For Each Directory in Image_File_Directory + lOffset := read32i(lOffset+2+(12*lnDirectories)); + //NEXT: check that each slice in 3D slice is the same dimension + lStackSameDim := true; + if (lImage_File_Directory=1) then begin + l1stDicomData := lDICOMdata; + lnSlices := 1; //inc(lnSlices); + end else begin + if lDicomData.XYZdim[1] <> l1stDicomData.XYZdim[1] then lStackSameDim := false; + if lDicomData.XYZdim[2] <> l1stDicomData.XYZdim[2] then lStackSameDim := false; + if lDicomData.Allocbits_per_pixel <> l1stDicomData.Allocbits_per_pixel then lStackSameDim := false; + //xif lDicomData.SamplesPerPixel <> l1stDicomData.SamplesPerPixel then lStackSameDim := false; + //xif lDicomData.PlanarConfig <> l1stDicomData.PlanarConfig then lStackSameDim := false; + if not lStackSameDim then begin + //dcmMsg(inttostr(lDicomData.XYZdim[1])+'x'+inttostr(l1stDicomData.XYZdim[1])); + if (lDicomData.XYZdim[1]*lDicomData.XYZdim[2]) > (l1stDicomData.XYZdim[1]*l1stDicomData.XYZdim[2]) then begin + l1stDicomData := lDICOMdata; + lnSlices := 1; + lStackSameDim := true; + end; + //dcmMsg('TIFF Read Error: Different 2D slices in this 3D stack have different dimensions.'); + //goto 566; + end else + inc(lnSlices); //if not samedim + end; //check that each slice is same dimension as 1st + //END check each 2D slice in 3D stack is same dimension + //NEXT: check if image data is contiguous + if (lStripCountItems > 0) and (lStripCountItems = lStripPositionItems) then begin + if (lnSlices=1) then lImageDataEndPosition := lDicomData.ImageStart; + for lItem := 1 to lStripCountItems do begin + lVal := readItem(lItem,lStripPositionType,lStripPositionOffset); + if (lVal <> lImageDataEndPosition) then + lContiguous := false; + //dcmMsg(inttostr(lImage_File_Directory)+'@'+inttostr(lItem)); + lImageDataEndPosition := lImageDataEndPosition+readItem(lItem,lStripCountType,lStripCountOffset); + if not lcontiguous then begin + if (lReadOffsets) and (lStackSameDim) then begin + lLongRA^[lnSlices] := lVal; + end else if (lReadOffsets) then + //not correct size, but do not generate an error as we will read non-contiguous files + else begin + dcmMsg('TIFF Read Error: Image data is not stored contiguously. '+ + 'Solution: convert this image using MRIcro''s ''Convert TIFF/Zeiss to Analyze...'' command [Import menu].'); + goto 564; + end; + end; //if not contiguous + end; //for each item + end;//at least one StripItem} + //END check image data is contiguous + end; //END while each Image_file_directory + lDicomData := l1stDicomData; + lDicomData.XYZdim[3] := lnSlices; + if (lReadOffsets) and (lnSlices > 1) and (not lcontiguous) then begin + gECATJPEG_table_entries := lnSlices; //Offset tables for TIFF + getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint)); + getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint)); + gECATJPEG_pos_table^[1] := l1stDicomData.ImageStart; + for lVal := 2 to gECATJPEG_table_entries do + gECATJPEG_pos_table^[lVal] := lLongRA^[lVal] + end; + lHdrOK := true; +564: + lDynStr := 'TIFF image'+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ size [mm or micron]:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'Bits per sample/Samples per pixel: '+inttostr( lDICOMdata.Allocbits_per_pixel) + +kCR+'Data offset:' +inttostr(lDicomData.ImageStart); + {if lXmm > 0 then + lDynStr := lDynStr +kCR+'Zeiss XYZ mm:'+floattostr(lXmm)+'/' + +floattostr(lYmm)+'/' + +floattostr(lZmm);} +566: + freemem(lLongRA); + CloseFile(fp); + FileMode := 2; //set to read/write +end; + +procedure read_biorad_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +var + lCh: char; + lByte: Byte; + lSpaces,liPos,lFileSz,lWord,lNotes,lStart,lEnd: integer; + tx : array [0..80] of Char; + lInfo,lStr,lTmpStr: string; + FP: file; +procedure read16(lPos: longint; var lVal: integer); +var lInWord: word; +begin + seek(fp,lPos); + BlockRead(fp, lInWord, 2); + lVal := lInWord; +end; +procedure read32(lPos: longint; var lVal: integer); +var lInINt: integer; +begin + seek(fp,lPos); + BlockRead(fp, lInINt, 4); + lVal :=lInINt; +end; + +begin + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if lFilesz < (77) then exit; //to small to be biorad + read16(54,lWord); + if (lWord=12345) then begin + lDicomData.little_endian := 1; + read16(0,lDicomData.XYZdim[1]); + read16(2,lDicomData.XYZdim[2]); + read16(4,lDicomData.XYZdim[3]); + read16(14,lWord);//byte format + if lWord = 1 then + lDicomData.Allocbits_per_pixel := 8 + else + lDicomData.Allocbits_per_pixel := 16;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lDicomData.ImageStart := 76; + read32(10,lNotes); + lStart := (lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*lDicomData.XYZdim[3])+76; + lEnd := lStart + 96; + lDynStr := 'BIORAD PIC image'+kCR; + while (lNotes > 0) and (lFileSz >= lEnd) do begin + read32(lStart+2,lNotes); //final note has bytes 2..5 set to zero + //read16(lStart+10,lNoteType); + //if lNoteType <> 1 then begin //ignore 'LIVE' notes - they do not include calibration info + seek(fp, lStart+16); + BlockRead(fp, tx, 80{, n}); + lStr := ''; + liPos := 0; + repeat + lCh := tx[liPos]; + lByte := ord(lCh); + if (lByte >= 32) and (lByte <= 126) then + lStr := lStr+lCh + else lByte := 0; + inc(liPos); + until (liPos = 80) or (lByte = 0); + if length(lStr) > 6 then begin + lInfo := ''; + for liPos := 1 to 6 do + lInfo := lInfo+upcase(lStr[liPos]); + ltmpstr := ''; + lSpaces := 0; + for liPos := 1 to 80 do begin + if lStr[liPos]=' ' then inc(lSpaces) + else if lSpaces = 3 then + ltmpstr := ltmpstr + lStr[liPos]; + end; + if ltmpstr = '' then {no value to read} + else if lInfo = 'AXIS_2' then + lDicomData.XYZmm[1] := strtofloat(ltmpstr) + else if lInfo = 'AXIS_3' then + lDicomData.XYZmm[2] := strtofloat(ltmpstr) + else if linfo = 'AXIS_4' then + lDicomData.XYZmm[3] := strtofloat(ltmpstr); + lDynStr := lDynStr+lStr+kCR; + end; //Str length > 6 + //end;//notetype + lStart := lEnd; + lEnd := lEnd + 96; + end; //while notes + lHdrOK := true; + //lImageFormatOK := true; + end;//biorad signature + CloseFile(fp); + FileMode := 2; //set to read/write + lDynStr := 'BioRad image'+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ size [mm or micron]:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'Bits per sample/Samples per pixel: '+inttostr( lDICOMdata.Allocbits_per_pixel) + +kCR+'Data offset:' +inttostr(lDicomData.ImageStart); +end; //biorad + +function SiemensVersion (lStr: string): integer; +//Convert tag 0018,1020 from DICOM header to Siemens version number +(*Returned value: system is in 1000s, last two digits are version + syngo MR 2004A 4VA25A //->0011 + Siemens syngo MR 2006T 4VB12T //-> 0012 +MR B13 4VB13A //->0013 +MR.VB15A123 //->0015 +syngo MR B15 //-> 0015 +syngo MR B17 //->0017 B= Trio, Verio, Etc +syngo MR C11 //->1011 C= Chinese C11 ~ B17 +syngo MR D11 //->2011 D= Skyra D11 ~ B17*) +label 999; +var + i,len: integer; +begin + result := 0; + len := length(lStr); + if len < 3 then exit; + for i := 1 to len-1 do + if (upcase(lStr[i]) in ['A'..'Z']) and (lStr[i+1] in ['0'..'9']) then + goto 999; + exit; //not Siemens format +999: + if ( upcase(lStr[i]) = 'A') then begin //A25 + result := 10; + exit; + end; + result := strtoint(lStr[i+1]); + if lStr[i+2] in ['0'..'9'] then + result := (result*10) + strtoint(lStr[i+2]); + result := (100*( ord(upcase(lStr[i]))- ord('B'))) + result; +end; +(* Obsolete - replaced by SiemensVersion +function SiemensBversion (lStr: string): integer; +//'syngo MR B17' returns 17 +//'MR.VB15A123' returns 15 +//'syngo MR B15' returns 15 +//'MR B13 4VB13A' returns 13 +//'syngo MR 2006T 4VB12T' returns 12 +var + Len,P,B: integer; + S: string; +begin + result := 0; + Len := length(lStr); + if Len <2 then exit; + B := 0; + for P := 2 to (Len) do + if (upcase(lStr[P-1])='B') and ( lStr[P] in ['0'..'9']) then + B := P; + if B < 1 then + exit; + S := ''; + while (B<= Len) and (lStr[B] in ['0'..'9']) do begin + S := S + lStr[B]; + inc(B); + end; + if length(S) < 1 then exit; + result := strtoint(S); +end;*) + +(*function Str2IntDig (lStr: string; lDig: integer): integer; +//robust stringtoint that strips out any junk so that "Implementation Version Name=MR.VB15A123" returns 15 +// warning, strips out decimals, so 15.3 will return 153! +//warning also ignores minus sign so -5.21 will return 521! +var + Len,P: integer; + S: string; +begin + result := 0; + Len := length(lStr); + if Len <1 then exit; + S := ''; + for P := 1 to Len do + if (lStr[P] in ['0'..'9']) and (length(S) < lDig) then + S := S + lStr[P]; + if length(S) < 1 then exit; + result := strtoint(S); +end; *) + +function ExpectedDicomBytes (var lDICOMdata: DICOMdata): integer; +begin + if lDicomData.JPEGLosslessCpt then begin + result := 0; //actual compressed size unknown + exit; + end; + result := lDicomdata.XYZdim[1]*lDicomdata.XYZdim[2]*lDicomdata.XYZdim[3]*(lDicomData.Allocbits_per_pixel DIV 8); +end; + +const + kNo =0; + kYes = 1; + kUndefined = 2; + +procedure read_dicom_data_compat(lReadJPEGtables,lVerboseRead,lAutoDECAT7,lReadECAToffsetTables,lAutoDetectInterfile,lAutoDetectGenesis,lReadColorTables: boolean; var lDICOMdata: DICOMdata; var lDTIra: TDTIRA; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lPrefs: TPrefs); +label 666,777; +const + kMaxTextBuf = 50000; //maximum for screen output + kDiskCache = 16384; //size of disk buffer + kNaNsingle : single = 1/0; + +type + dicom_types = (unknown, i8, i16, i32, ui8, ui16, ui32, _string{,_float} ); +var + // lTextF: TextFile; //abba + lDICOMdataBackUp: DICOMdata; + lWord,lWord2,lWord3: word; + lWordRA: Wordp; + lDiskCacheRA: pChar{ByteP}; + lRot1,lRot2,lRot3 : integer;//rotation dummies for AFNI + FP: file; + lT0,lT1,lT2,lT3:byte; + lImagePositionPatientRead, + lResearchMode,lManufacturerIsPhilips,lManufacturerIsBruker,lOsirix0002_0013,lMediface0002_0013,lSiemensMosaic0008_0008,lDICM_at_128, lTextOverFlow,lGenesis,lFirstPass,lrOK,lBig,lBigSet,lGrp,explicitVR,first_one : Boolean; + lSwitchToImplicitAfterGroup0002, lTestError,lByteSwap,lGELX,time_to_quit,lProprietaryImageThumbnail,lFirstFragment,lOldSiemens_IncorrectMosaicMM : Boolean; + group, element, e_len, remaining, tmp : uint32; + tmpstr : kDICOMstr; + lgrpstr,lStr,info,lDummyStr : string; + t : dicom_types; + lUse00189117 : integer; + lfloat1,lfloat2,lfloat3,lThickness: double; + lTempInt,lEchoNum,lnVol,lnSlicePerVol,lJPEGentries,lErr,liPos,lCacheStart,lCachePos,lDiskCacheSz,n, i,value, Ht,Width, + max16,min16,filesz,where,lMatrixSz,lPhaseEncodingSteps,lJunk,lJunk2,lJunk3 : LongInt; + tx : array [0..96] of Char; + l4DDistanceBetweenSliceCenters,lPhilipsScaleSlope: single; + buff: pCHar; + lColorRA: bytep; + lLongRA: Longintp; + lSingleRA,lInterceptRA: Singlep; + //lPapyrusnSlices,lPapyrusSlice : integer; + //lPapyrusZero,lPapyrus : boolean; + {$IFDEF Troubleshoot} + myFile : TextFile; +{$ENDIF Troubleshoot} +procedure ByteSwap (var lInOut: integer); +var lWord: word; +begin + lWord := lInOut; + lWord := swap(lWord); + lInOut := lWord; +end; +procedure dReadCache (lFileStart: integer); +begin + lCacheStart := lFileStart{lCacheStart + lDiskCacheSz};//eliminate old start + if lCacheStart < 0 then lCacheStart := 0; + if lDiskCacheSz > 0 then freemem(lDiskCacheRA); + if (FileSz-(lCacheStart)) < kDiskCache then + lDiskCacheSz := FileSz - (lCacheStart) + else + lDiskCacheSz := kDiskCache; + lCachePos := 0; + if (lDiskCacheSz < 1) then exit{goto 666}; + if (lDiskCacheSz+lCacheStart) > FileSz then exit; + Seek(fp, lCacheStart); + + GetMem(lDiskCacheRA, lDiskCacheSz {bytes}); + BlockRead(fp, lDiskCacheRA^, lDiskCacheSz, n); +end; + +function dFilePos (var lInFP: file): integer; +begin + Result := lCacheStart + lCachePos; +end; +procedure dSeek (var lInFP: file; lPos: integer); +begin + if (lPos >= lCacheStart) and (lPos < (lDiskCacheSz+lCacheStart)) then begin + lCachePos := lPos-lCacheStart; + exit; + end; + dReadCache(lPos); +end; + +procedure dBlockRead (var lInfp: file; lInbuff: pChar; e_len: integer; var n: integer); +var lN: integer; +begin + N := 0; + if e_len < 0 then exit; + for lN := 0 to (e_len-1) do begin + if lCachePos >= lDiskCacheSz then begin + dReadCache(lCacheStart+lDiskCacheSz); + if lDiskCacheSz < 1 then exit; + lCachePos := 0; + end; + N := lN; + lInBuff[N] := lDiskCacheRA[lCachePos]; + inc(lCachePos); + end; +end; +procedure readfloats (var fp: file; remaining: integer; var lOutStr: string; var lf1, lf2: double; var lReadOK: boolean); +var lDigit : boolean; + li,lLen,n: integer; + lfStr: string; +begin + lf1 := 1; + lf2 := 2; + if e_len = 0 then begin + lReadOK := true; + exit; + end; + if (dFilePos(fp) > (filesz-remaining)) or (remaining < 1) then begin + lOutStr := ''; + lReadOK := false; + exit; + end else + lReadOK := true; + lOutStr := ''; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in [{'/','\', delete: rev18}'e','E','+','-','.','0'..'9'] + then lOutStr := lOutStr +(Char(buff[li])) + else begin + lOutStr := lOutStr + ' '; + end; + FreeMem( buff); + lfStr := ''; + lLen := length(lOutStr); + + li := 1; + lDigit := false; + repeat + if (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then + lfStr := lfStr + lOutStr[li]; + if lOutStr[li] in ['0'..'9'] then lDigit := true; + inc(li); + until (li > lLen) or (lDigit); + if not lDigit then exit; + if li <= li then begin + repeat + if not (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then lDigit := false + else begin + if lOutStr[li] = 'E' then lfStr := lfStr+'e' + else + lfStr := lfStr + lOutStr[li]; + end; + inc(li); + until (li > lLen) or (not lDigit); + end; + //QStr(lfStr); + try + lf1 := strtofloat(lfStr); + except + on EConvertError do begin + dcmMsg('Unable to convert the string '+lfStr+' to a real number'); + lf1 := 1; + exit; + end; + end; {except} + lfStr := ''; + if li > llen then exit; + repeat + if (lOutStr[li] in ['+','E','e','.','-','0'..'9']) then begin + if lOutStr[li] = 'E' then lfStr := lfStr+'e' + else + lfStr := lfStr + lOutStr[li]; + end; + if (lOutStr[li] in ['0'..'9']) then lDigit := true; + inc(li); + until (li > lLen) or ((lDigit) and (lOutStr[li]=' ')); //second half: rev18 + if not lDigit then exit; + //QStr(lfStr); + try + lf2 := strtofloat(lfStr); + except + on EConvertError do begin + dcmMsg('Unable to convert the string '+lfStr+' to a real number'); + exit; + end; + end; + +end; + +procedure readfloats3 (var fp: file; remaining: integer; var lOutStr: string; var lf1, lf2,lf3: double; var lReadOK: boolean); +var lDigit : boolean; + lItem,li,lLen,n: integer; + lfTemp: double; + lfStr: string; +begin + lf1 := 0; + lf2 := 0; + lf3 := 0; + lOutStr := ''; + if e_len = 0 then begin + lReadOK := true; + exit; + end; + if (dFilePos(fp) > (filesz-remaining)) or (remaining < 1) then begin + lReadOK := false; + exit; + end else + lReadOK := true; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in [{'/','\', delete: rev18}'e','E','+','-','.','0'..'9'] + then lOutStr := lOutStr +(Char(buff[li])) + else lOutStr := lOutStr + ' '; + FreeMem( buff); + li := 1; + lLen := length(lOutStr); + for lItem := 1 to 3 do begin + if li > llen then exit; + lfStr := ''; + lLen := length(lOutStr); + lDigit := false; + repeat + if (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then + lfStr := lfStr + lOutStr[li]; + if lOutStr[li] in ['0'..'9'] then lDigit := true; + inc(li); + until (li > lLen) or (lDigit); + if not lDigit then exit; + if li <= li then begin + repeat + if not (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then lDigit := false + else begin + if lOutStr[li] = 'E' then lfStr := lfStr+'e' + else + lfStr := lfStr + lOutStr[li]; + end; + inc(li); + until (li > lLen) or (not lDigit); + end; + //QStr(lfStr); + try + lftemp := strtofloat(lfStr); + except + on EConvertError do begin + dcmMsg('Unable to convert the string '+lfStr+' to a real number'); + //lftemp := 0; + exit; + end; + end; {except} + case lItem of + 2: lf2 := lftemp; + 3: lf3 := lftemp; + else lf1 := lftemp; + end; //case of lItem +end; //for each of 3 lItems +end; //readfloats3 + +procedure CheckIntersliceDistance (var lMinDistance: single); +var + lX,lY,lZ,lDx: double; +begin + readfloats3 (fp, remaining, lDummyStr, lX, lY,lZ, lROK); + // fx( lX, lY,lZ,6789); + e_len := 0; + remaining := 0; + //compute Distance between current slice and 1st slice... + lDx := sqrt( sqr(lX-lDicomData.PatientPosX)+sqr(lY-lDicomData.PatientPosY)+sqr(lZ-lDicomData.PatientPosZ)); + if (lDx > 0) and (lMinDistance = kNaNsingle) then //first value + lMinDistance := lDx + else if (lDx > 0) and (lDx < lMinDistance) then //if 0 then this is a repeat, not a new slice + lMinDistance := lDx + else + exit; +end; + +procedure readfloats6 (var fp: file; remaining: integer; var lOutStr: string; var lf1, lf2,lf3,lf4,lf5,lf6: double; var lReadOK: boolean); +var lDigit : boolean; + lItem,li,lLen,n: integer; + lfTemp: single; + lfStr: string; +begin + lf1 := 0; + lf2 := 0; + lf3 := 0; + lf4 := 0; + lf5 := 0; + lf6 := 0; + lOutStr := ''; + if e_len = 0 then begin + lReadOK := true; + exit; + end; + if (dFilePos(fp) > (filesz-remaining)) or (remaining < 1) then begin + lReadOK := false; + exit; + end else + lReadOK := true; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in [{'/','\', delete: rev18}'e','E','+','-','.','0'..'9'] + then lOutStr := lOutStr +(Char(buff[li])) + else lOutStr := lOutStr + ' '; + FreeMem( buff); + li := 1; + lLen := length(lOutStr); + for lItem := 1 to 6 do begin + if li > llen then exit; + lfStr := ''; + lLen := length(lOutStr); + lDigit := false; + repeat + if (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then + lfStr := lfStr + lOutStr[li]; + if lOutStr[li] in ['0'..'9'] then lDigit := true; + inc(li); + until (li > lLen) or (lDigit); + if not lDigit then exit; + if li <= li then begin + repeat + if not (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then lDigit := false + else begin + if lOutStr[li] = 'E' then lfStr := lfStr+'e' + else + lfStr := lfStr + lOutStr[li]; + end; + inc(li); + until (li > lLen) or (not lDigit); + end; + + //QStr(lfStr); + try + lftemp := strtofloat(lfStr); + except + on EConvertError do begin + dcmMsg('Unable to convert the string '+lfStr+' to a real number'); + //lftemp := 0; + exit; + end; + end; {except} + case lItem of + 2: lf2 := lftemp; + 3: lf3 := lftemp; + 4: lf4 := lftemp; + 5: lf5 := lftemp; + 6: lf6 := lftemp; + else lf1 := lftemp; + end; //case of lItem +end; //for each of 3 lItems +end; + +function read16( var fp : File; var lReadOK: boolean ): uint16; +var + t1, t2 : uint8; + n : Integer; +begin +if dFilePos(fp) > (filesz-2) then begin + read16 := 0; + lReadOK := false; + exit; +end else + lReadOK := true; + GetMem( buff, 2); + dBlockRead(fp, buff{^}, 2, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + freemem(buff); + if lDICOMdata.little_endian <> 0 + then Result := (t1 + t2*256) AND $FFFF + else Result := (t1*256 + t2) AND $FFFF; +end; + +function ReadStr(var fp: file; remaining: integer; var lReadOK: boolean; VAR lmaxval:integer) : string; +var lInc, lN,Val,n: integer; + t1, t2 : uint8; + lStr : String; +begin +lMaxVal := 0; +if dFilePos(fp) > (filesz-remaining) then begin + lReadOK := false; + exit; +end else + lReadOK := true; + Result := ''; + lN := remaining div 2; + if lN < 1 then exit; + lStr := ''; + for lInc := 1 to lN do begin + GetMem( buff, 2); + dBlockRead(fp, buff{^}, 2, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + freemem(buff); + if lDICOMdata.little_endian <> 0 then + Val := (t1 + t2*256) AND $FFFF + else + Val := (t1*256 + t2) AND $FFFF; + if lInc < lN then + lStr := lStr + inttostr(Val)+ ', ' + else + lStr := lStr + inttostr(Val); + if Val > lMaxVal then + lMaxVal := Val; + end; + Result := lStr; + if odd(remaining) then begin + getmem(buff,1); + dBlockRead(fp, buff{t1}, SizeOf(uint8), n); + freemem(buff); + end; +end; + +(*function ReadStrABC(var fp: file; remaining: integer; var lReadOK: boolean; VAR lA,lB,lC:integer) : string; +var lInc, lN,Val,n: integer; + t1, t2 : uint8; + lStr : String; +begin +lA := 0; +lB := 0; +lC := 0; +if dFilePos(fp) > (filesz-remaining) then begin + lReadOK := false; + exit; +end else + lReadOK := true; + Result := ''; + lN := remaining div 2; + if lN < 1 then exit; + lStr := ''; + for lInc := 1 to lN do begin + GetMem( buff, 2); + dBlockRead(fp, buff{^}, 2, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + freemem(buff); + if lDICOMdata.little_endian <> 0 then + Val := (t1 + t2*256) AND $FFFF + else + Val := (t1*256 + t2) AND $FFFF; + if lInc < lN then + lStr := lStr + inttostr(Val)+ ', ' + else + lStr := lStr + inttostr(Val); + if lInc = 1 then + lA := Val; + if lInc = 2 then + lB := Val; + if lInc = 3 then + lC := Val; + + + end; + Result := lStr; + if odd(remaining) then begin + getmem(buff,1); + dBlockRead(fp, buff{t1}, SizeOf(uint8), n); + freemem(buff); + end; +end; *) + +function ReadStrHex(var fp: file; remaining: integer; var lReadOK: boolean) : string; +var lInc, lN,Val,n: integer; + t1, t2 : uint8; + lStr : String; +begin +if dFilePos(fp) > (filesz-remaining) then begin + lReadOK := false; + exit; +end else + lReadOK := true; + Result := ''; + lN := remaining div 2; + if lN < 1 then exit; + lStr := ''; + for lInc := 1 to lN do begin + GetMem( buff, 2); + dBlockRead(fp, buff, 2, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + freemem(buff); + if lDICOMdata.little_endian <> 0 then + Val := (t1 + t2*256) AND $FFFF + else + Val := (t1*256 + t2) AND $FFFF; + if lInc < lN then lStr := lStr + 'x'+inttohex(Val,4)+ ', ' + else lStr := lStr + 'x'+inttohex(Val,4); + end; + Result := lStr; + if odd(remaining) then begin + getmem(buff,1); + dBlockRead(fp, {t1}buff, SizeOf(uint8), n); + freemem(buff); + end; +end; +function SomaTomFloat: double; +var lSomaStr: String; +begin + //dSeek(fp,5992); //Slice Thickness from 5790 "SL 3.0" + //dSeek(fp,5841); //Field of View from 5838 "FoV 281" + //dSeek(fp,lPos); + lSomaStr := ''; + tx[0] := 'x'; + while (length(lSomaStr) < 64) and (tx[0] <> chr(0)) and (tx[0] <> '/') do begin + dBlockRead(fp, tx, 1, n); + if tx[0] in ['+','-','.','0'..'9','e','E'] then + lSomaStr := lSomaStr + tx[0]; + end; + if length(lSOmaStr) > 0 then + result := StrToFloat(lSomaStr) + else + result := 0; +end; + +function PGMreadInt: integer; +//reads integer from PGM header, disregards comment lines (which start with '#' symbol); +var lStr: string; + lDigit: boolean; + +begin + Result := 1; + lStr := ''; + repeat + dBlockRead(fp, tx, 1, n); + if tx[0] = '#' then begin //comment + repeat + dBlockRead(fp, tx, 1, n); + until (ord(tx[0]) = $0A) or (dFilePos(fp) > (filesz-4)); //eoln indicates end of comment + end; //finished reading comment + if tx[0] in ['0'..'9'] then begin + lStr := lStr + tx[0]; + lDigit := true; + end else + lDigit := false; + until ((lStr <> '') and (not lDigit)) or (dFilePos(fp) > (filesz-4)); //read digits until you hit whitespace + if lStr <> '' then + Result := strtoint(lStr); + + {lStr := ''; + tx[0] := 'x'; + while (length(lStr) < 64) and (ord(tx[0]) <> $0A) do begin + dBlockRead(fp, tx, 1, n); + if tx[0] in ['#','+','-','.','0'..'9','e','E',' ','a'..'z','A'..'Z'] then + lStr := lStr + tx[0]; + end; + result := lStr; } +end; + +function read32 ( var fp : File; var lReadOK: boolean ): uint32; +var + t1, t2, t3, t4 : byte; + n : Integer; +begin +if dFilePos(fp) > (filesz-4) then begin + Read32 := 0; + lReadOK := false; + exit; +end else + lReadOK := true; + GetMem( buff, 4); + dBlockRead(fp, buff{^}, 4, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + T3 := ord(buff[2]); + T4 := ord(buff[3]); + freemem(buff); + if lDICOMdata.little_endian <> 0 then + Result := t1 + (t2 shl 8) + (t3 shl 16) + (t4 shl 24) + else + Result := t4 + (t3 shl 8) + (t2 shl 16) + (t1 shl 24) + //if lDICOMdata.little_endian <> 0 + //then Result := (t1 + t2*256 + t3*256*256 + t4*256*256*256) AND $FFFFFFFF + //else Result := (t1*256*256*256 + t2*256*256 + t3*256 + t4) AND $FFFFFFFF; +end; + +function read32r ( var fp : File; var lReadOK: boolean ): single; //1382 +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(float:single); + end; + swaptypep = ^swaptype; +var + s:single; + inguy:swaptypep; + outguy:swaptype; +begin + if dFilePos(fp) > (filesz-4) then begin + read32r := 0; + lReadOK := false; + exit; + end else + lReadOK := true; + //GetMem( buff, 8); + dBlockRead(fp, @s, 4, n); + inguy := @s; //assign address of s to inguy + if lDICOMdata.little_endian <> 1 then begin + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + end else + outguy.float := s; //1382 read64 needs to handle little endian in this way as well... + read32r:=outguy.float; +end; + +function read64 ( var fp : File; var lReadOK: boolean ): double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + s:double; + inguy:swaptypep; + outguy:swaptype; +begin + if dFilePos(fp) > (filesz-8) then begin + Read64 := 0; + lReadOK := false; + exit; + end else + lReadOK := true; + //GetMem( buff, 8); + dBlockRead(fp, @s, 8, n); + inguy := @s; //assign address of s to inguy + if lDICOMdata.little_endian <> 1 then begin + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + end else + outguy.float := inguy^.float; //1382 + read64:=outguy.float; +end; + +//magma +function SafeStrToInt(var lInput: string): integer; +var li,lLen: integer; +begin + result := 0; + lLen := length(lInput); + lStr := ''; + if lLen < 1 then exit; + for li := 1 to lLen do + if lInput[li] in ['+','-','0'..'9'] + then lStr := lStr +lInput[li]; + Val(lStr,li,lErr); + if lErr = 0 then + result := lI;//strtoint(lStr); +end; + + +procedure DICOMHeaderStringToInt (var lInput: integer); +var li: integer; +begin + t := _string; + lStr := ''; + if dFilePos(fp) > (filesz-e_len) then exit;//goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in ['+','-','0'..'9'] + then lStr := lStr +(Char(buff[li])); + FreeMem( buff); + Val(lStr,li,lErr); + if lErr = 0 then lInput := li;//strtoint(lStr); + remaining := 0; + tmp := lInput; +end; + +procedure DICOMHeaderString (var lInput: kDICOMStr); +var li,lStartPos: integer; +begin + t := _string; + lStartPos := dFilePos(fp); + lInput := ''; + if e_len < 1 then exit; //DICOM: should always be even + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in ['+','-','/','\',' ','0'..'9','a'..'z','A'..'Z'] then + lInput := lInput +(Char(buff[li])) + else {if (buff[i] = 0) then} + lInput := lInput +' '; + + FreeMem( buff); + dseek(fp, lStartPos); +end; +procedure DICOMHeaderStringTime (var lInput: kDICOMstr); +var li,lStartPos: integer; +begin + t := _string; + lStartPos := dFilePos(fp); + lInput := ''; + if e_len < 1 then exit; //DICOM: should always be even + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in ['+','-','/','\',' ','0'..'9','a'..'z','A'..'Z','.'] then + lInput := lInput +(Char(buff[li])) + else if li <> (e_len-1) then + lInput := lInput +':' + else + lInput := lInput +' '; + + FreeMem( buff); + dseek(fp, lStartPos); +end; +label 1234; +var lIndent: integer; + lprevGroup, lprevElement: uint32; +var lInside00209113, lInside2005140F, lPhilipsWarning: boolean;//philips can list two DIFFERENT spatial positions per slice - ignore the one hidden inside 2005,140FlPrev0020: boolean; +begin + //Init + //for lnVol := 1 to kMaxOrderVal do + // lDICOMdata.OrderSlope[lDICOMdata.nOrder] := 0; //show this was not set + {$IFDEF Troubleshoot} + AssignFile(myFile, '/Users/rorden/Test.txt'); + ReWrite(myFile); +{$ENDIF Troubleshoot} + + lUse00189117 := kUndefined; //Warning each Philips 2D slice can save DTI data once or twice - 0018:9087/0018:9089 and 2001:1003/2001:10B0,10B1,10B2 - this is tricky since Philips files can be 4D + lInside00209113 := false; + lprevGroup := 0; + lprevElement := 0; + lPhilipsWarning := false; + lIndent := 0; + lInside2005140F := false; + lSwitchToImplicitAfterGroup0002 := false; + lGELX := false; + lByteSwap := false; + Clear_Dicom_Data(lDicomData); + Clear_Dicom_Data(lDICOMdataBackUp); + Clear_DTIra(lDTIra); + lDicomData.XYZdim[1] := 1; + lImagePositionPatientRead := false;// for 4D files, we need first volume + l4DDistanceBetweenSliceCenters := kNaNsingle; + lEchoNum := 0; + lThickness := 0; + lTestError := false; + lPhilipsScaleSlope := 0; + lManufacturerIsPhilips := false; + lManufacturerIsBruker := false; + lnVol := 0; + lnSlicePerVol := 0; + lResearchMode := false; + lMatrixSz := 0; + lPhaseEncodingSteps := 0; + lSiemensMosaic0008_0008 := false; + lMediface0002_0013 := false;//false wblate + lOsirix0002_0013 := false; + lOldSiemens_IncorrectMosaicMM := false; + lCacheStart := 0; + lDiskCacheSz := 0; + lDynStr:= ''; + lJPEGEntries := 0; + first_one := true; + info := ''; + lGrp:= false; + lBigSet := false; + lDICM_at_128 := false; //no DICOM signature + lFirstFragment := true; + lTextOverFlow := false; + lImageFormatOK := true; + lHdrOK := false; + //if lverboseRead then dcmMsg('xxx'+lFileName); + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + //if lverboseRead then dcmMsg('zzzzz000000000'); + TmpStr := string(StrUpper(PChar(ExtractFileExt(lFileName)))); + lStr :=''; + if TmpStr = '.FDF' then begin + if FDF( lFileName, lDicomData) then begin + lHdrOK := true; + lImageFormatOK := true; + exit; + end; + end; + if (TmpStr = '.REC') then begin //1417z: check in Unix: character upper/lower case may matter + lStr := changefileext(lFilename,'.par'); + if fileexists(lStr) then + lFilename := lStr + else begin //Linux is case sensitive 1382... + lStr := changefileext(lFilename,'.PAR'); + if fileexists(lStr) then + lFilename := lStr + end; + end; + if (TmpStr = '.BRIK') then begin //1417z: check in Unix: character upper/lower case may matter + lStr := changefileext(lFilename,'.HEAD'); + if fileexists(lStr) then lFilename := lStr; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + if fileSz < 1 then begin + lImageFormatOK := false; + exit; + end; + lDICOMdata.Little_Endian := 1; + if FileSz > 200 then begin + dseek(fp, {0}128); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] = 'D') and (tx[1] = 'I') and (tx[2] = 'C') and (tx[3] = 'M') then + lDICM_at_128 := true; + end;//filesize > 200: check for 'DICM' at byte 128 - DICOM signature + if (lAutoDetectGenesis) and (FileSz > (5820{114+35+4})) then begin + dseek(fp, 0); + if (ord(tx[0])=206) and (ord(tx[1])=250) then begin + //Elscint format signature: check height and width to make sure + + dseek(fp, 370); + group := read16(fp,lrOK);//Width + dseek(fp, 372); + element := read16(fp,lrOK);//Ht + if ((Group=160) or(Group =256) or (Group= 340) or (Group=512) or (group =640)) and + ((element=160) or (element =256) or (element= 340) or (element=512) ) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_elscint_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName); + exit; + end; //confirmed: Elscint + end; + lGenesis := false; + if ((tx[0] <> 'I') OR (tx[1] <> 'M') OR (tx[2] <> 'G') OR (tx[3] <> 'F')) then begin {DAT format} + {if (FileSz > 114+305+4) then begin + dseek(fp, 114+305); + dBlockRead(fp, tx, 3*SizeOf(Char), n); + if ((tx[0]='M') and (tx[1] = 'R')) or ((tx[0] = 'C') and(tx[1] = 'T')) then + lGenesis := true; + end;} + end else + lGenesis := true; + if (not lGenesis) and (FileSz > 3252) then begin + dseek(fp, 3240); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then + lGenesis := true; + if (not lGenesis) then begin + dseek(fp, 3178); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then + lGenesis := true; + end; + if (not lGenesis) then begin + dseek(fp, 3180); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then + lGenesis := true; + end; + if (not lGenesis) then begin //1499K + dseek(fp, 0); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then + lGenesis := true; + end; + + end; + if (not lGenesis) and (FileSz > 3252) then begin + dseek(fp, 3228); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] = 'I') AND (tx[1]= 'M') AND (tx[2] = 'G')AND (tx[3]= 'F') then + lGenesis := true; + end; + if lGenesis then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_ge_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName); + exit; + end; + end; //AutodetectGenesis xxDCIM + + if (lAutoDetectInterfile) and (FileSz > 256) and (not lDICM_at_128) then begin + if Copy(extractfilename(lFileName), 1, 4) = 'COR-' then begin + lStr := extractfiledir(lFilename) + '\COR-.info'; + TmpStr := extractfiledir(lFilename) + '\COR-128'; + if fileexists(lStr) and fileexists(TmpStr) then begin + lFilename := TmpStr; + lDynStr := 'FreeSurfer COR format' + kCR+'Only displaying image 128'+kCR+'Use MRIcro''s Import menu to convert this image'+kCR; + with lDicomData do begin + little_endian := 0; // don't care + ImageStart := 0; + Allocbits_per_pixel := 8; + XYZdim[1] := 256; + XYZdim[2] := 256; + XYZdim[3] := 1; + XYZmm[1] := 1; + XYZmm[2] := 1; + XYZmm[3] := 1; + //xStoredbits_per_pixel:= Allocbits_per_pixel; + END; //WITH + lHdrOK := True; + lImageFormatOK := True; + exit; + end; //COR-.info file exists + end; //if filename is COR- + //start TIF + //TIF IMAGES DO NOT ALWAYS HAVE EXTENSION if (TmpStr = '.TIF') or (TmpStr = '.TIFF') then begin + dseek(fp, 0); + lWord := read16(fp,lrOK); + if lWord = $4d4d then + lDICOMdata.little_endian := 0 + else if lWord = $4949 then lDICOMdata.little_endian := 1; + //dseek(fp, 2); + lWord2 := read16(fp,lrOK); //bits per pixel + if ((lWord=$4d4d) or (lWord=$4949)) and (lWord2 = $002a) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_tiff_data(lDICOMdata, lReadECAToffsetTables, lHdrOK, lImageFormatOK, lDynStr, lFileName); + //if lHdrOk then exit; + exit; + end;//TIF signature + //end; //.TIF extension + //end TIF + //start BMP 1667 + TmpStr := string(StrUpper(PChar(ExtractFileExt(lFileName)))); + if TmpStr = '.BMP' then begin + dseek(fp, 0); + lWord := read16(fp,lrOK); + dseek(fp, 28); + lWord2 := read16(fp,lrOK); //bits per pixel + if (lWord=19778) and (lWord2 = 8) then begin //bitmap signature + dseek(fp, 10); + lDicomData.ImageStart := read32(fp,lrOK);//1078; + dseek(fp, 18); + lDicomData.XYZdim[1] := read32(fp,lrOK); + //dseek(fp, 22); + lDicomData.XYZdim[2] := read32(fp,lrOK); + lDicomData.XYZdim[3] := 1;//read16(fp,lrOK); + lDicomData.Allocbits_per_pixel := 8;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lDynStr := 'BMP format'; + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lHdrOK := true; + lImageFormatOK:= true; + exit; + end;//bmp signature + end; //.BMP extension + //end BMP + if TmpStr = '.VOL' then begin //start SPACE vol format 1382 + dseek(fp, 0); + dBlockRead(fp, tx, 6*SizeOf(Char), n); + if (tx[0] = 'm') and (tx[1] = 'd') and (tx[2] = 'v') and (tx[3] = 'o') and (tx[4] = 'l') and (tx[5] = '1') then begin + lDicomData.ImageStart := read32(fp,lrOK);//1078; + lDICOMdata.little_endian := 1; + lDicomData.XYZdim[1] := read32(fp,lrOK); + lDicomData.XYZdim[2] := read32(fp,lrOK); + lDicomData.XYZdim[3] := read32(fp,lrOK); + lDicomData.XYZmm[1] := read32r(fp,lrOK); + lDicomData.XYZmm[2] := read32r(fp,lrOK); + lDicomData.XYZmm[3] := read32r(fp,lrOK); + lDicomData.Allocbits_per_pixel := 8;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lDynStr := 'Space VOL format'; + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lHdrOK := true; + lImageFormatOK:= true; + exit; + end;//vol signature + end; //.VOL extension + //end space .VOL format + //start DF3 PovRay DF3 density files + if (TmpStr = '.DF3') then begin + dseek(fp, 0); + lWord := swap (read16(fp,lrOK)); + lWord2 := swap (read16(fp,lrOK)); + lWord3 := swap (read16(fp,lrOK)); + //note: I assume all df3 headers are little endian. is this always true? if not, unswapped values could be tested for filesize + lMatrixSz := (lWord*lWord2*lWord3)+6; + if (lMatrixSz=FileSz)then begin //df3 signature + lDicomData.ImageStart := 6;//1078; + lDicomData.XYZdim[1] := lWord; + //dseek(fp, 22); + lDicomData.XYZdim[2] := lWord2; + lDicomData.XYZdim[3] := lWord3; + lDicomData.Allocbits_per_pixel := 8;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lDynStr := 'PovRay DF3 density format'; + lHdrOK := true; + lImageFormatOK:= true; + exit; + end;//df3 signature + end; + //end df3 + + //start .PGM + if (TmpStr = '.PGM') or (TmpStr = '.PPM') then begin + dseek(fp, 0); + lWord := read16(fp,lrOK); + if (lWord=13648){'P5'=1x8BIT GRAYSCALE} or (lWord=13904) {'P6'=3x8bit RGB} then begin //bitmap signature + {repeat + PGMreadStr(lDicomData.XYZdim[1],lDicomData.XYZdim[2]); + until (lDicomData.XYZdim[2] > 0) ;} + lDicomData.XYZdim[1] := PGMreadInt; + lDicomData.XYZdim[2] := PGMreadInt; + PGMreadInt; //read maximum value + + lDicomData.XYZdim[3] := 1;//read16(fp,lrOK); + lDicomData.Allocbits_per_pixel := 8;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lDicomData.ImageStart := dFilepos(fp); + if lWord = 13904 then begin//RGB + //xlDicomData.SamplesPerPixel := 3; + //xlDicomData.PlanarConfig := 0;//RGBRGBRGB..., not RRR..RGGG..GBBB...B + end; + lDynStr:='PGM/PPM format 8-bit grayscale image [data saved in binary, not ASCII format]'; + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lHdrOK := true; + lImageFormatOK:= true; + exit; + end else if (lWord=12880){'P2'=1x8BIT ASCII} or (lWord=13136) {'P3'=3x8bit ASCI} then begin + dcmMsg('Warning: this image appears to be an ASCII ppm/pgm image. This software can only read binary ppm/pgm images'); + end;//pgm/ppm binary signature signature + end; //.PPM/PGM extension + + //end .pgm + + //start BioRadPIC 1667 + if TmpStr = '.PIC' then begin + dseek(fp, 54); + lWord := read16(fp,lrOK); + if (lWord=12345) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_biorad_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName); + exit; + end;//biorad signature + end; //.PIC extension biorad? + //end BIORAD PIC + if TmpStr = '.HEAD' then begin + read_afni_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName,lRot1,lRot2,lRot3); + if (lHdrOK) and (lImageFormatOK) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + exit; + end; + end; + dseek(fp, 0); + dBlockRead(fp, tx, 20*SizeOf(Char), n); + if (tx[0] = 'n') and (tx[1] = 'c') and (tx[2] = 'a') and (tx[3] = 'a') then begin + //SUN Vision File Format = .vff + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_vff_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName); + exit; + end; + liPos := 1; + lStr :=''; + {999 While (liPos <= 20) and (lStr <> 'INTERFILE') do begin + if tx[liPos] in ['i','n','t','e','r', 'f','i','l','e','I','N','T','E','R', 'F','I','L','E'] then + lStr := lStr+upcase(tx[liPos]); + inc(liPos); + end; } + if lStr = 'INTERFILE' then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_interfile_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName); + if lHdrOk then exit; + exit; + end; //'INTERFILE' in first 20 char + end;//detectint + // try DICOM part 10 i.e. a 128 byte file preamble followed by "DICM" + if filesz <= 300 then goto 666; + {begin siemens somatom: DO THIS BEFORE MAGNETOM: BOTH HAVE 'SIEMENS' SIGNATURE, SO CHECK FOR 'SOMATOM'} + if filesz = 530432 then begin + dseek(fp, 281); + dBlockRead(fp, tx, 8*SizeOf(Char), n); + if (tx[0] = 'S') and (tx[1] = 'O') and (tx[2] = 'M') and (tx[3] = 'A') and (tx[4] = 'T') and (tx[5] = 'O') and (tx[6] = 'M') then begin + lDicomData.ImageStart := 6144; + lDicomData.Allocbits_per_pixel := 16; + //xlDicomData.Storedbits_per_pixel := 16; + lDicomData.little_endian := 0; + lDicomData.XYZdim[1] := 512; + lDicomData.XYZdim[2] := 512; + lDicomData.XYZdim[3] := 1; + dSeek(fp,5999); //Study/Image from 5292 "STU/IMA 1070/16" + lDicomData.AcquNum := trunc(SomaTomFloat);//Slice Thickness from 5790 "SL 3.0" + lDicomData.ImageNum := trunc(SomaTomFloat);//Slice Thickness from 5790 "SL 3.0" + dSeek(fp,5792); //Slice Thickness from 5790 "SL 3.0" + lDicomData.XYZmm[3] := SomaTomFloat;//Slice Thickness from 5790 "SL 3.0" + dSeek(fp,5841); //Field of View from 5838 "FoV 281" + lDicomData.XYZmm[1] := SomaTomFloat; //Field of View from 5838 "FoV 281" + lDicomData.XYZmm[2] := lDicomData.XYZmm[1]/lDicomData.XYZdim[2];//do mm[2] first before FOV is overwritten + lDicomData.XYZmm[1] := lDicomData.XYZmm[1]/lDicomData.XYZdim[1]; + if lVerboseRead then + lDynStr := 'Siemens Somatom Format'+kCR+ + 'Image Series/Number: '+inttostr(lDicomData.AcquNum)+'/'+inttostr(lDicomData.ImageNum)+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lImageFormatOK := true; + lHdrOK := true; + exit; + end; //signature found + end; //correctsize for somatom + {end siemens somatom} + +{siemens magnetom} + dseek(fp,96); + dBlockRead(fp, tx, 7*SizeOf(Char), n); + if (tx[0] = 'S') and (tx[1] = 'I') and (tx[2] = 'E') and (tx[3] = 'M') and (tx[4] = 'E') and (tx[5] = 'N') and (tx[6] = 'S') then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_siemens_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName); + exit; + end; + {end siemens magnetom vision} + {siemens somatom plus} + dseek(fp, 0); + dBlockRead(fp, tx, 8*SizeOf(Char), n); + if (tx[0] = 'S') and (tx[1] = 'I') and (tx[2] = 'E') and (tx[3] = 'M') and (tx[4] = 'E') and (tx[5] = 'N') and (tx[6] = 'S') then begin + lDicomData.ImageStart := 8192; + lDicomData.Allocbits_per_pixel := 16; + //xlDicomData.Storedbits_per_pixel := 16; + lDicomData.little_endian := 0; + dseek(fp, 1800); //slice thickness + lDicomData.XYZmm[3] := read64(fp,lrOK); + dseek(fp, 4100); + lDicomData.AcquNum := read32(fp,lrOK); + dseek(fp, 4108); + lDicomData.ImageNum := read32(fp,lrOK); + dseek(fp, 4992); //X FOV + lDicomData.XYZmm[1] := read64(fp,lrOK); + dseek(fp, 5000); //Y FOV + lDicomData.XYZmm[2] := read64(fp,lrOK); + dseek(fp, 5340); + lDicomData.XYZdim[1] := read32(fp,lrOK); + dseek(fp, 5344); + lDicomData.XYZdim[2] := read32(fp,lrOK); + lDicomData.XYZdim[3] := 1; + if lDicomData.XYZdim[1] > 0 then + lDicomData.XYZmm[1] := lDicomData.XYZmm[1]/lDicomData.XYZdim[1]; + if lDicomData.XYZdim[2] > 0 then + lDicomData.XYZmm[2] := lDicomData.XYZmm[2]/lDicomData.XYZdim[2]; + if lVerboseRead then + lDynStr := 'Siemens Somatom Plus Format'+kCR+ + 'Image Series/Number: '+inttostr(lDicomData.AcquNum)+'/'+inttostr(lDicomData.ImageNum)+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lImageFormatOK := true; + lHdrOK := true; + exit; + end; + {end siemens somatom plus } + {picker} + dseek(fp,0); + dBlockRead(fp, tx, 8*SizeOf(Char), n); + if (tx[0]='C') and (tx[1]='D') and (tx[2]='F') and (ord(tx[3]) = 1) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_minc_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName); + exit; + end; + if (lAutoDECAT7) and (tx[0]='M') and (tx[1]='A') and (tx[2]='T') and (tx[3]='R') and (tx[4]='I') and (tx[5]='X') then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_ecat_data(lDICOMdata, lVerboseRead,lReadECAToffsetTables,lHdrOK, lImageFormatOK, lDynStr, lFileName); + exit; + end; + if (tx[0] = '*') AND (tx[1] = '*') AND (tx[2] = '*') AND (tx[3] = ' ') then begin {picker Standard} + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_picker_data(lVerboseRead,lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName); + exit; + end; {not picker standard} + //Start Picker Prism + ljunk := filesz-2048; + lDICOMdata.little_endian := 0; + //start: read x + dseek(fp, 322); + Width := read16(fp,lrOK); + + //start: read y + dseek(fp, 326); + Ht := read16(fp,lrOK); + lMatrixSz := Width * Ht; + + //check if correct filesize for picker prism + if (ord(tx[0]) = 1) and (ord(tx[1])=2) and ((ljunk mod lMatrixSz)=0){128*128*2bytes = 32768} then begin //Picker PRISM + lDicomData.little_endian := 0; + lDicomData.XYZdim[1] := Width; + lDicomData.XYZdim[2] := Ht; + lDicomData.XYZdim[3] := (ljunk div 32768); {128*128*2bytes = 32768} + lDicomData.Allocbits_per_pixel := 16; + //xlDicomData.Storedbits_per_pixel := 16; + lDicomData.ImageStart := 2048; + //start: read slice thicness + dseek(fp,462); + dBlockRead(fp, tx, 12*SizeOf(Char), n); + lStr := ''; + for ljunk := 0 to 11 do + if tx[ljunk] in ['0'..'9','.'] then + lStr := lStr+ tx[ljunk]; + if lStr <> '' then + lDicomData.XYZmm[3] := strtofloat(lStr); + //start: voxel size + dseek(fp,594); + dBlockRead(fp, tx, 12*SizeOf(Char), n); + lStr := ''; + for ljunk := 0 to 11 do + if tx[ljunk] in ['0'..'9','.'] then + lStr := lStr+ tx[ljunk]; + if lStr <> '' then + lDicomData.XYZmm[1] := strtofloat(lStr); + lDicomData.XYZmm[2] := lDicomData.XYZmm[1]; + //end: read voxel sizes + //start: patient name + dseek(fp,26); + dBlockRead(fp, tx, 22*SizeOf(Char), n); + lStr := ''; + ljunk := 0; + while (ljunk < 22) and (ord(tx[ljunk]) <> 0) do begin + lStr := lStr+ tx[ljunk]; + inc(ljunk); + end; + lDicomData.PatientName := lStr; + //start: patient ID + dseek(fp,48); + dBlockRead(fp, tx, 15*SizeOf(Char), n); + lstr := ''; + ljunk := 0; + while (ljunk < 15) and (ord(tx[ljunk]) <> 0) do begin + lstr := lstr+ tx[ljunk]; + inc(ljunk); + end; + //xlDicomData.PatientID := lStr; + //start: scan time + dseek(fp,186); + dBlockRead(fp, tx, 25*SizeOf(Char), n); + lstr := ''; + ljunk := 0; + while (ljunk < 25) and (ord(tx[ljunk]) <> 0) do begin + lstr := lstr+ tx[ljunk]; + inc(ljunk); + end; + //start: scanner type + dseek(fp,2); + dBlockRead(fp, tx, 25*SizeOf(Char), n); + lgrpstr := ''; + ljunk := 0; + while (ljunk < 25) and (ord(tx[ljunk]) <> 0) do begin + lgrpstr := lgrpstr+ tx[ljunk]; + inc(ljunk); + end; + //report results + if lVerboseRead then + lDynStr := 'Picker Format '+lgrpstr+kCR+ + 'Patient Name: '+lDicomData.PatientName+kCR+ + //x'Patient ID: '+lDicomData.PatientID+kCR+ + 'Scan Time: '+lStr+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lImageFormatOK := true; + lHdrOK := true; + exit; + + end; //end Picker PRISM + lMatrixSz := 0; + + lDICOMdata.little_endian := 1; + lBig := false; + dseek(fp, {0}128); + //where := FilePos(fp); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then begin + + //if filesz > 132 then begin + dseek(fp, 0{128}); //skip the preamble - next 4 bytes should be 'DICM' + //where := FilePos(fp); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + //end; + if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then begin + dseek(fp, 0); + group := read16(fp,lrOK); + + if not lrOK then goto 666; + + if group > $0008 then begin + group := swap(group); + lBig := true; + end; + if NOT (group in [$0000, $0001, $0002,$0003, $0004, $0008]) then // one more group added + begin + + goto 666; + end; + dseek(fp, 0); + //dcmMsg('DICM not at 0 or 128: ' +lFilename); + end; + end; //else dcmMsg('DICM at 128{0}');; + time_to_quit := FALSE; + lProprietaryImageThumbnail := false; + explicitVR := false; + tmpstr := ''; + + tmp := 0; + + while NOT time_to_quit do begin + t := unknown; + where := dFilePos(fp); + lFirstPass := true; +777: + group := read16(fp,lrOK); + if (lSwitchToImplicitAfterGroup0002) and (group > 0002) then begin + lSwitchToImplicitAfterGroup0002 := false; + explicitVR := false; + end; + + if not lrOK then goto 666; + if (lFirstPass) and (group = 2048) then begin + if lDicomData.little_endian = 1 then lDicomData.Little_endian := 0 + else lDicomData.little_endian := 1; + dseek(fp,where); + lFirstPass := false; + goto 777; + end; + + element := read16(fp,lrOK); + if not lrOK then goto 666; + e_len:= read32(fp,lrOK); + if not lrOK then goto 666; +lGrpStr := ''; + lt0 := e_len and 255; + lt1 := (e_len shr 8) and 255; + lt2 := (e_len shr 16) and 255; + lt3 := (e_len shr 24) and 255; + if (explicitVR) and (lT0=13) and (lT1=0) and (lT2=0) and (lT3=0) then + e_len := 10; //hack for some GE Dicom images + + + if explicitVR or first_one then begin + if group = $FFFE then else //1384 - ACUSON images switch off ExplicitVR for file image fragments + if ((lT0=kO) and (lT1=kB)) or ((lT0=kU) and (lT1=kN)){<-UN added 11/11/2011} or ((lT0=kO) and (lT1=kW)) or ((lT0=kS) and (lT1=kQ)) {11/11 add UT}or ((lT0=kU) and (lT1=kT)) then begin + lGrpStr := chr(lT0)+chr(lT1); + e_len:= read32(fp,lrOK); + if not lrOK then goto 666; + if first_one then explicitVR := true; + end else if ((lT3=kO) and (lT2=kB)) or ((lT3=kU) and (lT2=kN)){<-UN added 11/11/2011} or((lT3=kO) and (lT2=kW)) or ((lT3=kS) and (lT2=kQ)) or ((lT3=kU) and (lT2=kT))then begin + e_len:= read32(fp,lrOK); + if not lrOK then goto 666; + if first_one then explicitVR := true; + end + else if ( ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS)) + or ((lT0=kA) and (lT1=kT)) or ((lT0=kC) and (lT1=kS)) or ((lT0=kD) and (lT1=kA)) + or ((lT0=kD) and (lT1=kS)) + or ((lT0=kD) and (lT1=kT)) or ((lT0=kF) and (lT1=kL)) or ((lT0=kF) and (lT1=kD)) + or ((lT0=kI) and (lT1=kS)) or ((lT0=kL) and (lT1=kO))or ((lT0=kL) and (lT1=kT)) + or ((lT0=kP) and (lT1=kN)) or ((lT0=kS) and (lT1=kH)) or ((lT0=kS) and (lT1=kL)) + or ((lT0=kS) and (lT1=kS)) or ((lT0=kS) and (lT1=kT)) or ((lT0=kT) and (lT1=kM)) + or ((lT0=kU) and (lT1=kI)) or ((lT0=kU) and (lT1=kL)) or ((lT0=kU) and (lT1=kS)) + or ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS)) ) + then begin + lGrpStr := chr(lT0) + chr(lT1); + if lDicomData.little_endian = 1 then + e_len := (e_len and $ffff0000) shr 16 + else + e_len := swap((e_len and $ffff0000) shr 16); + if first_one then begin + explicitVR := true; + end; + end else if ( + ((lT3=kA) and (lT2=kT)) or ((lT3=kC) and (lT2=kS)) or ((lT3=kD) and (lT2=kA)) + or ((lT3=kD) and (lT2=kS)) + or ((lT3=kD) and (lT2=kT)) or ((lT3=kF) and (lT2=kL)) or ((lT3=kF) and (lT2=kD)) + or ((lT3=kI) and (lT2=kS)) or ((lT3=kL) and (lT2=kO))or ((lT3=kL) and (lT2=kT)) + or ((lT3=kP) and (lT2=kN)) or ((lT3=kS) and (lT2=kH)) or ((lT3=kS) and (lT2=kL)) + or ((lT3=kS) and (lT2=kS)) or ((lT3=kS) and (lT2=kT)) or ((lT3=kT) and (lT2=kM)) + or ((lT3=kU) and (lT2=kI)) or ((lT3=kU) and (lT2=kL)) or ((lT3=kU) and (lT2=kS))) + then begin + if lDicomData.little_endian = 1 then + e_len := (256 * lT0) + lT1 + else + e_len := (lT0) + (256*lT1); + if first_one then begin + explicitVR := true; + end; + end; +end; //not first_one or explicit + + if (first_one) and (lDicomdata.little_endian =0) and (e_len = $04000000) then begin + dcmMsg('Switching to little endian'); + lDicomData.little_endian := 1; + dseek(fp, where); + first_one := false; + goto 777; + end else if (first_one) and (lDicomData.little_endian =1) and (e_len = $04000000) then begin + dcmMsg('Switching to little endian'); + lDicomData.little_endian := 0; + dseek(fp, where); + first_one := false; + goto 777; + end; + + if e_len = ($FFFFFFFF) then begin + e_len := 0; +end; + if lGELX then begin + e_len := e_len and $FFFF; + end; + first_one := false; + remaining := e_len; + info := '?'; + tmpstr := ''; + if (lIndent > 0) and (not ((group= $FFFE) and (element = $E0DD))) and (not lManufacturerIsPhilips) then + //Philips stores slice positioning inside 0020,9113; lice orientation inside 0020,9116 but Siemens stores thumbnails in indented subheadings + goto 1234; + case group of + $0001 : // group for normal reading elscint DICOM + case element of + $0010 : info := 'Name'; + $1001 : info := 'Elscint info'; + end; + $0002 : + case element of + $00 : info := 'File Meta Elements Group Len'; + $01 : info := 'File Meta Info Version'; + $02 : info := 'Media Storage SOP Class UID'; + $03 : info := 'Media Storage SOP Inst UID'; + $10 : begin + //lTransferSyntaxReported := true; + info := 'Transfer Syntax UID'; + TmpStr := ''; + if dFilePos(fp) > (filesz-e_len) then goto 666; + + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for i := 0 to e_len-1 do + if Char(buff[i]) in ['+','-',' ', '0'..'9','a'..'z','A'..'Z'] + then TmpStr := TmpStr +(Char(buff[i])) + else TmpStr := TmpStr +('.'); + FreeMem( buff); + lStr := ''; + //dcmMsg(TmpStr); + if TmpStr = '1.2.840.113619.5.2' then begin + lGELX := true; + LBigSet := true; + lBig := true; + end; + // + if length(TmpStr) < 19 then begin + //12/2010 assume 1.2.840.10008.1.2 + //Raw data, Implicit VR, Little Endian + // explicitVR := false; //china + lSwitchToImplicitAfterGroup0002 := true; + end; + if length(TmpStr) >= 19 then begin + + if TmpStr[19] = '1' then begin + lBigSet:= true; + explicitVR := true; //duran + lBig := false; + end else if TmpStr[19] = '2' then begin + lBigSet:= true; + explicitVR := true; //duran + lBig := true; + end else if TmpStr[19] = '4' then begin + if length(TmpStr) >= 21 then begin + //Dec 2012.... dcm2nii can handle JPEG 123456 + if {not lReadJPEGtables} false then begin + lImageFormatOK := false; + end else begin + + i := strtoint(TmpStr[21]+TmpStr[22]); + if (i <> 57) and (i <> 70) then begin + lImageFormatOK := false; + //lDicomData.JPEGLossyCpt := true + end else begin + + //lImageFormatOK := false;//123456 + lDicomData.JPEGLosslessCpt := true; + end; + end; + end else begin + lImageFormatOK := false; + end; + end else if TmpStr[19] = '5' then begin + lImageFormatOK := false;//xlDicomData.RunLengthEncoding := true; + end else begin + lImageFormatOK := false; + end; + if not lImageFormatOK then + dcmMsg('Unsupported Transfer Syntax '+(TmpStr)+' Solution: use MRIcro'); + + end; {length} + remaining := 0; + e_len := 0; {use tempstr} + end; + $12 : begin + info := 'Implementation Class UID'; + end; + $13 : begin + info := 'Implementation Version Name'; + if e_len > 4 then begin + TmpStr := ''; + DICOMHeaderString(TmpStr); + //lDicomData.ImplementationVersion := Str2Int(TmpStr); + if TmpStr = 'OSIRIX' then + lOsirix0002_0013 := true; + if TmpStr = 'MEDIFACE 1 5' then + lMediface0002_0013 := true; //detect MEDIFACE 1.5 error: error in length of two elements 0008:1111 and 0008:1140 + end; //length > 4 + + + + end; //element 13 + $16 : info := 'Source App Entity Title'; + $100: info := 'Private Info Creator UID'; + $102: info := 'Private Info'; + end; + $0008 : + case element of + $00 : begin + info := 'Identifying Group Length'; + end; + $01 : info := 'Length to End'; + $05 : info := 'Specific Character Set'; + $08 : begin + info := 'Image Type'; + if dFilePos(fp) > (filesz-e_len) then goto 666; + lSiemensMosaic0008_0008:= false; + if (e_len >= 6) then begin //search for 'MOSAIC' + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + i := e_len -6;//MOSAIC + while (i>-1) and (not lSiemensMosaic0008_0008) do begin + if (upcase(Char(buff[i])) = 'M') and (upcase(Char(buff[i+1])) = 'O') + and (upcase(Char(buff[i+2])) = 'S') and (upcase(Char(buff[i+3])) = 'A') + and (upcase(Char(buff[i+4])) = 'I') and (upcase(Char(buff[i+5])) = 'C') + then //strip filler characters: DICOM elements must be padded for even length + lSiemensMosaic0008_0008 := true; + dec(i); + end; + FreeMem( buff); + remaining := 0; + e_len := 0; {use tempstr} + end; + end; + $10 : info := 'Recognition Code'; + $12 : info := 'Instance Creation Date'; + $13 : info := 'Instance Creation Time'; + $14 : info := 'Instance Creator UID'; + $16 : info := 'SOP Class UID'; + $18 : info := 'SOP Instance UID'; + $20 : begin + info := 'Study Date'; + //lDicomData.StudyDatePos := dFilePos(fp); + DICOMHeaderString(lDicomData.StudyDate); + end; + $21 : info := 'Series Date'; + $22 : info := 'Acquisition Date'; + $23 : info := 'Image Date'; + $30 : begin info := 'Study Time'; + DICOMHeaderStringTime(lDicomData.StudyTime); + end; + $31 : info := 'Series Time'; + $32 : begin info := 'Acquisition Time'; + DICOMHeaderStringTime(TmpStr); + lDicomData.SecSinceMidnight := SecSinceMidnightFloat(TmpStr); + + end; + $33 : begin info := 'Image Time'; + //xxDICOMHeaderStringTime(lDicomData.ImgTime); + end; + $40 : info := 'Data Set Type'; + $41 : info := 'Data Set Subtype'; + $50 : begin + //xDICOMHeaderStringtoInt(lDicomData.accession); + info := 'Accession Number'; + end; + + $60 : begin info := 'Modality'; t := _string; end; + $64 : begin info := 'Conversion Type'; t := _string; end; + $70 : begin + info := 'Manufacturer'; + //Only read last word, e.g. 'TYPE\MOSAIC' will be read as 'MOSAIC' + TmpStr := ''; + + if dFilePos(fp) > (filesz-e_len) then goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + i := e_len -1; + while (i>-1) and (Char(buff[i]) in ['a'..'z','A'..'Z',' ']) do begin + if (Char(buff[i])) <> ' ' then //strip filler characters: DICOM elements must be padded for even length + TmpStr := upcase(Char(buff[i]))+TmpStr; + dec(i); + end; + FreeMem( buff); + remaining := 0; + e_len := 0; {use tempstr} + if (length(TmpStr) > 3) and (TmpStr[1]='P') and (TmpStr[2]='H') and (TmpStr[3]='I') then + lManufacturerIsPhilips := true; + if (length(TmpStr) > 3) and (TmpStr[1]='B') and (TmpStr[2]='R') and (TmpStr[3]='U') then + lManufacturerIsBruker := true; + + if lManufacturerIsPhilips then + lDicomData.ManufacturerID := kPhilipsID; + if (length(TmpStr) > 3) and (TmpStr[1]='G') and (TmpStr[2]='E') then + lDicomData.ManufacturerID := kGEID; + if (length(TmpStr) > 3) and (TmpStr[1]='S') and (TmpStr[2]='I') and (TmpStr[3]='E') then + lDicomData.ManufacturerID := kSiemensID; + + end; + $80 : info := 'Institution Name'; + $81 : info := 'City Name'; + $90 : info := 'Referring Physician''s Name'; + $100: info := 'Code Value'; + $102 : begin + info := 'Coding Schema Designator'; + t := _string; + end; + $104: info := 'Code Meaning'; + $1010: info := 'Station Name'; + $1030: begin info := 'Study Description'; t := _string; end; + $103e: begin info := 'Series Description'; t := _string; end; + $1040: info := 'Institutional Dept. Name'; + $1050: info := 'Performing Physician''s Name'; + $1060: info := 'Name Phys(s) Read Study'; + $1070: begin info := 'Operator''s Name'; t := _string; end; + $1080: info := 'Admitting Diagnosis Description'; + $1090: begin info := 'Manufacturer''s Model Name';t := _string; end; + $1111: begin + if lMediface0002_0013 then E_LEN := 8;//+e_len; + end; //ABBA: patches error in DICOM images seen from Sheffield 0002,0013=MEDIFACE.1.5; 0002,0016=PICKER.MR.SCU + $1140: begin + if (lMediface0002_0013) and (E_LEN > 255) then E_LEN := 8; + end; //ABBA: patches error in DICOM images seen from Sheffield 0002,0013=MEDIFACE.1.5; 0002,0016=PICKER.MR.SCU + $2111: info := 'Derivation Description'; + $2120: info := 'Stage Name'; + $2122: begin info := 'Stage Number';t := _string; end; + $2124: begin info := 'Number of Stages';t := _string; end; + $2128: begin info := 'View Number';t := _string; end; + $212A: begin info := 'Number of Views in stage';t := _string; end; + $2204: info := 'Transducer Orientation'; + $9208: begin + info := 'ComplexImageComponent'; + TmpStr := ''; + DICOMHeaderString(TmpStr); + i := 0; + + if length(TmpStr) >= 2 then begin + if (TmpStr[1] = 'M') and (TmpStr[2] = 'A') then + i := 1; //magnitude + if (TmpStr[1] = 'P') and (TmpStr[2] = 'H') then + i := 2; //phase + if (TmpStr[1] = 'R') and (TmpStr[2] = 'E') then + i := 3; //real + if (TmpStr[1] = 'I') and (TmpStr[2] = 'M') then + i := 4; //imaginary + end; + //mixed will be followed by subsequent settings, so do not use it here.... + if (i > 0) and (lDICOMdata.nOrder < kMaxOrderVal) then begin + inc(lDICOMdata.nOrder); + //dcmMsg(TmpStr); + lDICOMdata.order[lDICOMdata.nOrder] := i; + end; +(*[ magnitude * MAGNITUDE +[ phase * PHASE +[ real * REAL +[ imaginary * IMAGINARY +[ mixed * MIXED*) + ///xxx xxx + end; + + end; + $0009: if element = $0010 then begin + + if e_len > 4 then begin + TmpStr := ''; + if dFilePos(fp) > (filesz-e_len) then goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + i := e_len -1; + + while (i>-1) {and (Char(buff[i]) in ['a'..'z','A'..'Z',' '])} do begin + if (Char(buff[i])) in ['a'..'z','A'..'Z'] then //strip filler characters: DICOM elements must be padded for even length + TmpStr := upcase(Char(buff[i]))+TmpStr; + dec(i); + end; + FreeMem( buff); + remaining := 0; + if (Length(TmpStr)>4) and (TmpStr[1]='M') and (TmpStr[2]='E') and (TmpStr[3]='R') and (TmpStr[4]='G') then + lOldSiemens_IncorrectMosaicMM := true; //detect MERGE technologies mosaics + e_len := 0; {use tempstr} + end; + + + end; + $0010 : + case element of + $00 : info := 'Patient Group Length'; + $10 : begin info := 'Patient''s Name'; t := _string; + //xlDicomData.NamePos := dFilePos(fp); + DICOMHeaderString(lDicomData.PatientName); + end; + $20 : begin info := 'Patient ID'; + //xDICOMHeaderString(lDicomData.PatientID); + //xlDicomData.PatientIDInt := safestrtoint(lDicomData.PatientID); + end; + //11/2010 + //$30: info := 'Date of Birth'; //"Age String" type: e.g 067y for 67 years old, 067d for 67 days + $30 : begin info := 'DoB'; t := _string; + //xlDicomData.NamePos := dFilePos(fp); + //lDicomData.PatientDoB := '1111'; + DICOMHeaderString(lDicomData.PatientDoB); + end; + $32 : info := 'Patient Birth Time'; + //$40 : begin info := 'Patient Sex'; t := _string; end; + $40 : begin info := 'Gender'; t := _string; + //xlDicomData.NamePos := dFilePos(fp); + DICOMHeaderString(lDicomData.PatientGender); + end; + + $1000: info := 'Other Patient IDs'; + $1001: info := 'Other Patient Names'; + $1005: info := 'Patient''s Birth Name'; + $1010: begin info := 'Patient Age'; t := _string; end; + $1030: info := 'Patient Weight'; + $21b0: begin + info := 'Additional Patient History'; + DICOMHeaderString(lDicomData.PatientHx); + end ; + $4000: info := 'Patient Comments'; + + end; + $0018 : + case element of + $00 : info := 'Acquisition Group Length'; + $10 : begin info := 'Contrast/Bolus Agent'; t := _string; end; + $15: info := 'Body Part Examined'; + $20 : begin + info := 'Scanning Sequence';t := _string; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDICOMdata.ScanningSequence0018_0020 := TmpStr; + if TmpStr = 'RM' then lResearchMode := true; + end; + $21 : begin info := 'Sequence Variant';t := _string; end; + $22 : info := 'Scan Options'; + $23 : begin info := 'MR Acquisition Type'; t := _string; end; + $24 : info := 'Sequence Name'; + $25 : begin info := 'Angio Flag';t := _string; end; + $30 : info := 'Radionuclide'; + $50 : begin info := 'Slice Thickness'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.XYZmm[3] := lfloat1; + + lThickness := lfloat1;//lDICOMdata.Thickness := lfloat1; //1391b + end; + //$60: begin info := 'KVP [Peak Output, KV]'; t := _string; end; //aqw + $60: begin + info := 'KVP [Peak KV]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDicomData.kV := lFloat1; + end; + + $70: begin t := _string; info := 'Counts Accumulated'; end; + $71: begin t := _string; info := 'Acquisition Condition'; end; + //$80 : begin info := 'Repetition Time'; t := _string; end; //aqw + //$81 : begin info := 'Echo Time'; t := _string; end; //aqw + $80 : begin info := 'Repetition Time [TR, ms]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDicomData.TR := lFloat1; + end; + + $81 : begin + info := 'Echo Time [TE, ms]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDicomData.TE := lFloat1; + end; + $82 : begin t := _string; info := 'Inversion Time';end; + $83 : begin t := _string; info := 'Number of Averages'; end; + $84 : info := 'Imaging Frequency'; + $85 : begin info := 'Imaged Nucleus'; t := _string; end; + $86 : begin info := 'Echo Number';t := _string; + + DICOMHeaderStringToInt(lEchoNum); + //lDICOMdata.Echo := lEchoNum; + + end; +//qq + $87 : begin + info := 'Magnetic Field Strength'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + lDICOMdata.FieldStrength := round(lfloat1); + //xxxdcmMsg(floattostr(lFloat1)); + if not lrOK then goto 666; + e_len := 0; remaining := 0; //1362 some use this for gap size, others for sum of gap and slicethickness! + end; + $88 : begin + info := 'Spacing Between Slices'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; //1362 some use this for gap size, others for sum of gap and slicethickness! + //3333 if (lfloat1 > lDICOMdata.XYZmm[3]) or (lDICOMdata.XYZmm[3]=1) then + //lDICOMdata.XYZmm[3] := lfloat1; + //fx(lDICOMdata.XYZmm[3],lThickness,lfloat1); + if lfloat1 < 0 then + lDICOMdata.XYZmm[3] := lFloat1//does not make sense - found in some eFilm images from Marconi P3000 + else if ( (lThickness/2) > lfloat1 ) then + lDICOMdata.XYZmm[3] := lfloat1+lThickness + else + lDICOMdata.XYZmm[3] := lfloat1;//1392 + //xldicomdata.spacing:=lfloat1; + end; + $89 : begin + // t := _string; + info := 'Number of Phase Encoding Steps'; + //1499c This is a indirect method for detecting SIemens Mosaics: check if image height is evenly divisible by encoding steps + // A real kludge due to Siemens not documenting mosaics explicitly: this workaround may incorrectly think rescaled images are mosaics! + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + lPhaseEncodingSteps := round(lfloat1); + //xxxdcmMsg(floattostr(lFloat1)); + if not lrOK then goto 666; + e_len := 0; remaining := 0; //1362 some use this for gap size, others for sum of gap and slicethickness! + //if (lfloat1 > lDICOMdata.XYZmm[3]) or (lDICOMdata.XYZmm[3]=1) then + //lDICOMdata.XYZmm[3] := lfloat1; + //ldicomdata.spacing:=lfloat1; + + + end; + $90 : info := 'Data collection diameter'; + $91 : begin info := 'Echo Train Length';t := _string; end; + $93: begin info := 'Percent Sampling'; t := _string; end; + $94: begin info := 'Percent Phase Field View'; t := _string; end; + $95 : begin info := 'Pixel Bandwidth'; t := _string; end; + $1000: begin t := _string; info := 'Device Serial Number'; end; + $1004: info := 'Plate ID'; + $1020: begin + info := 'Software Version'; + t := _string; + if e_len > 2 then begin + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.Vers0018_1020 := Siemensversion(TmpStr); + end; + + //showdcmMsg(inttostr(lDicomData.Vers0018_1020)+' '+TmpStr); + end; + $1030: begin + info := 'Protocol Name';t := _string; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.ProtocolName := TmpStr; + AplhaNumericStrDICOM (lDicomData.ProtocolName); + end; + $1040: info := 'Contrast/Bolus Route'; + $1050 : begin + t := _string; info := 'Spatial Resolution'; end; + $1060: info := 'Trigger Time'; + $1062: info := 'Nominal Interval'; + $1063: info := 'Frame Time'; + $1081: info := 'Low R-R Value'; + $1082: info := 'High R-R Value'; + $1083: info := 'Intervals Acquired'; + $1084: info := 'Intervals Rejected'; + $1088: begin info := 'Heart Rate'; t := _string; end; + $1090: begin info := 'Cardiac Number of Images'; t := _string; end; + $1094: begin info := 'Trigger Window';t := _string; end; + $1100: info := 'Reconstruction Diameter'; + $1110: info := 'Distance Source to Detector [mm]'; + $1111: info := 'Distance Source to Patient [mm]'; + $1120: info := 'Gantry/Detector Tilt'; + $1130: info := 'Table Height'; + $1140: info := 'Rotation Direction'; + $1147: info := 'Field of View Shape'; + $1149: begin + t := _string; info := 'Field of View Dimension[s]'; end; + $1150: begin + info := 'Exposure Time [ms]'; + t := _string; + end; + $1151: begin + info := 'X-ray Tube Current [mA]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + //xlDicomData.mA := lFloat1; + end; + + $1152 : info := 'Acquisition Device Processing Description'; + $1155: info := 'Radiation Setting'; + $1160: info := 'Filter Type'; + $1164: info :='Imager Pixel Spacing'; + $1166: info := 'Grid'; + $1170 : info := 'Generator Power'; + $1180 : info := 'Collimator/grid Name'; + $1190 : begin + info := 'Focal Spot[s]'; + t := _string; + end; + $11A0 : begin + info := 'Body Part Thickness'; + t := _string; + end; + $11A2 : info := 'Compression Force'; + $1200 : info := 'Date of Last Calibration'; + $1201 : info := 'Time of Last Calibration'; + $1210: info := 'Convolution Kernel'; + $1250: begin t := _string; info := 'Receiving Coil'; end; + $1251: begin t := _string; info := 'Transmitting Coil'; end; + $1260 : begin + t := _string; info := 'Plate Type'; end; + $1261 : begin + t := _string; info := 'Phosphor Type'; end; + $1310: begin info := 'Acquisition Matrix'; //Siemens Mosaics converted by Merge can report the incorrect mm + + //nji2 + //NOTE: Matrix Information for MERGE converted images. Used Innocently for other uses by Siemens + + if (lOldSiemens_IncorrectMosaicMM) or ((lSiemensMosaic0008_0008) and (lMatrixSz < 1){B13}) then begin + + //TmpStr := ReadStrABC(fp, remaining,lrOK,lA,lB,lC); + + TmpStr := ReadStr(fp, remaining,lrOK,lMatrixSz); + //ss//1362 + //fx(remaining); + (*kEr := true; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + kEr := false; + + lMatrixSz := round(lFloat1); + dcmMsg(TmpStr); + fx(lMatrixSz,lFLoat1,lFloat2,4321);*) + {fx(lA,lB,lC); + lMatrixSz := lB; + lMatrixSzY := lC; } + end else + TmpStr := ReadStr(fp, remaining,lrOK,lJunk);//1362 + + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + $1312: begin + t := _string; info := 'Phase Encoding Direction'; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.PhaseEncoding := TmpStr; + AplhaNumericStrDICOM (lDicomData.PhaseEncoding); + end; + $1314: begin + t := _string; info := 'Flip Angle'; end; + $1315: begin + t := _string;info := 'Variable Flip Angle Flag'; end; + $1316: begin + t := _string;info := 'SAR'; end; + $1400: info := 'Acquisition Device Processing Description'; + $1401: begin info := 'Acquisition Device Processing Code';t := _string; end; + $1402: info := 'Cassette Orientation'; + $1403: info := 'Cassette Size'; + $1404: info := 'Exposures on Plate'; + $1405: begin + info := 'Relative X-Ray Exposure'; + t := _string; + end; + $1500: info := 'Positioner Motion'; + $1508: info := 'Positioner Type'; + $1510: begin + info := 'Positioner Primary Angle'; + t := _string; + end; + $1511: info := 'Positioner Secondary Angle'; + $5020: info := 'Processing Function'; + $5100: begin + t := _string; info := 'Patient Position'; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.PatientPos := TmpStr; + AplhaNumericStrDICOM (lDicomData.PatientPos); + end; + $5101: begin info := 'View Position';t := _string; end; + $6000: begin info := 'Sensitivity'; t := _string; end; + $7004: info := 'Detector Type'; + $7005: begin + info := 'Detector Configuration'; + t := _string; + end; + $7006: info := 'Detector Description'; + $700A: info := 'Detector ID'; + $700C: info := 'Date of Last Detector Calibration'; + $700E: info := 'Date of Last Detector Calibration'; + $7048: info := 'Grid Period'; + $7050: info := 'Filter Material LT'; + $7060: info := 'Exposure Control Mode'; + {$IFDEF read00189117} + $9117 : begin //SQ + //Philips has been inconsistent in reporting DTI tags. This makes archival support difficult + //It is unclear if this is intentional obfustication or simply incompetence, but it does mean + // that this shameful usage results in code that is unintuitive. + //Warning: 0018,9087 is used inconsistently by Philips: sometimes order is 0018,9087;0018,9089 other times 0018,9089;0018,9087 + // sometimes if 0018,9087=0 (e.g. B0 scan, with 0018,9075='NONE/0') then 0018,9089 is not included + //Therefore, we only use this as a last resort! on Philips, prefer to use 2001,1003+ 2005,10b0/2005,10b1/2005,10b2 + + if (lUse00189117 = kUndefined) then + lUse00189117 := kYes; + if (lUse00189117 = kYes) then begin //Overly complicated due to Philips shameful use of these tags + if lDICOMdata.nDTIdir < kMaxDTIdir then //kMaxDTIdir then + inc(lDICOMdata.nDTIdir); + //Philips may not report vectors for B0 images - so we will initialize these values + lDTIra[lDICOMdata.nDTIdir].bval := 0; + lDTIra[lDICOMdata.nDTIdir].v1 := 0; + lDTIra[lDICOMdata.nDTIdir].v2 := 0; + lDTIra[lDICOMdata.nDTIdir].v3 := 0; + end; + end;//9117 + $9087: begin + + if {(lGrpStr = 'FD') and} (lUse00189117 <> kNo) then begin + info := 'Diffusion b-value'; + lDICOMdata.DTI.bval := round(read64 (fp,lrOK)); + if lDICOMdata.nDTIdir < 1 then lDICOMdata.nDTIdir := 1; + lDTIra[lDICOMdata.nDTIdir].bval := lDICOMdata.DTI.bval; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + //if (lDICOMdata.nDTIdir >2) and (lDicomData.ManufacturerID = kPhilipsID) then // 2001,1003 + // dcmMsg('Warning: DTI data extracted from 0018,9087 and 0018,9089. Please inspect resulting bvec files - some Philips systems use these tags erraticly.'); + end; //if lUse00189117 + + end; //9087 b-values + $9089: begin + if (lUse00189117 <> kNo) {lGrpStr = 'FD'} then begin //see lUse00189117 + info := 'Diffusion Gradient vector [x,y,z]'; + //readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + lDICOMdata.DTI.v1 := read64 (fp,lrOK); + if not lrOK then goto 666; + lDICOMdata.DTI.v2 := read64 (fp,lrOK); + if not lrOK then goto 666; + lDICOMdata.DTI.v3 := read64 (fp,lrOK); + if not lrOK then goto 666; + if lDICOMdata.nDTIdir < 1 then lDICOMdata.nDTIdir := 1; + lDTIra[lDICOMdata.nDTIdir].v1 := lDICOMdata.DTI.v1; + lDTIra[lDICOMdata.nDTIdir].v2 := lDICOMdata.DTI.v2; + lDTIra[lDICOMdata.nDTIdir].v3 := lDICOMdata.DTI.v3; + + e_len := 0; remaining := 0; + end; //if true + end; //9089 X/Y/Z diffusion direction + {$ENDIF} // read00189117 + + end; +$0019: begin + (*case element of //1362 +//3/3/2008 this old method for detecting mosaics has a problem - if image is interpolated x2, you will assume a 2x2 mosaic + $1220: begin + info := 'Matrix';t := _string; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; + if lfloat2 > lfloat1 then lfloat1 := lfloat2; + lMatrixSz := round(lfloat1); + //if >32767 then there will be wrap around if read as signed value! + remaining := 0; + end; + $14D4: begin + info := 'Matrix';t := _string; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; + if lfloat2 > lfloat1 then lfloat1 := lfloat2; + lMatrixSz := round(lfloat1); + //if >32767 then there will be wrap around if read as signed value! + remaining := 0; + end; + end; *) //case element + + if lDicomData.ManufacturerID = kSiemensID then begin + case element of //1362 + (* $100A: begin //unsigned short $100A + info := 'Number Of Images in Mosaic'; + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + fx(e_len,tmp,remaining); + + end;*) + $1028: begin //7/2013 + info := 'Siemens BandwidthPerPixelPhaseEncode'; + lDICOMdata.BandwidthPerPixelPhaseEncode := read64 (fp,lrOK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; // BandwidthPerPixelPhaseEncode + $000C,$100C: begin + info := 'Siemens b-value'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + tmpstr := floattostr(lFloat1); + lDICOMdata.DTI.bval := round(lFloat1); + lDICOMdata.SiemensDICOMDTI := true ; + end; // b-values + $000E,$100E: begin + info := 'Siemens Gradient vector [x,y,z]'; + //readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + lDICOMdata.DTI.v1 := read64 (fp,lrOK); + if not lrOK then goto 666; + lDICOMdata.DTI.v2 := read64 (fp,lrOK); + if not lrOK then goto 666; + lDICOMdata.DTI.v3 := read64 (fp,lrOK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; // X/Y/Z diffusion direction + + + end;//Case element + end;//if Siemens + + if lDicomData.ManufacturerID = kGEID then begin + case element of //1362 + $10BB,$a0bb: begin + info := 'GE Gradient vector [x]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.DTI.v1 := lFloat1; + end; // X diffusion direction + $10BC,$A0BC: begin + info := 'GE Gradient vector [y]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.DTI.v2 := lFloat1; + end;//Y diffusion direction + $10BD,$A0BD: begin + info := 'GE Gradient vector [z]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.DTI.v3 := lFloat1; + end;// Z diffusion direction + end;//Case element + // + + end;//if GE + end;//$0019 + + +$0020 : + case element of + $00 : info := 'Relationship Group Length'; + $0d : info := 'Study Instance UID'; + $0e : info := 'Series Instance UID'; + $10 : begin + info := 'Study ID'; + t := _string; + end; + $11 : begin info := 'Series Number'; + DICOMHeaderStringToInt(lDicomData.SeriesNum); + end; + $12 : // begin info := 'Acquisition Number'; t := _string; end; + begin info := 'Acquisition Number'; + DICOMHeaderStringToInt(lDicomData.AcquNum); + end; + + $13 : begin info := 'Image Number'; + DICOMHeaderStringToInt(lTempInt); + if (lDicomData.ImageNum < 2) and (lTempInt >= 0) then + lDicomData.ImageNum := lTempInt; + //March2008 - some Philips data has multiple image numbers... + // 0018,1020,Software Version=1.5.4\1.5.4.3\Gyroscan PMS/DICOM 2.0 MR .Id. datadefs.v 5.27 2004/10/18 06.50 + //dcmMsg(inttostr(lDicomData.ImageNum)+lDicomData.Filename); + end; + $20 : begin info := 'Patient Orientation'; + t := _string; + end; + $30 : info := 'Image Position'; + $32 : begin + info := 'Image Position Patient'; + //June 2009 - for Philips new 4D format we want value from the first slice... + + if lInside2005140F then begin + if not (lPhilipsWarning) then + dcmMsg('*User: check slice thickness. Possible Philips R3.2.2 bug - scanner can report different 0020,0032 values for the same slice.'); + lPhilipsWarning := true; + end else begin + //5/2012: Philips R3.2.2 can save two instances of 0020:0032 for each slice: one from voxel center, one from voxel edge. + + if not lImagePositionPatientRead then begin + readfloats3 (fp, remaining, lDummyStr, lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ, lROK); + //fx( lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ,56789); + if not lrOK then goto 666; + e_len := 0; + remaining := 0; + lImagePositionPatientRead := true; + //we assume Philips reports the slice thickness correctly.... + //an alternative would be to read both 1st and 2nd ImagePositionPatient and + //compute the function DICOMinterslicedistance + end else begin + + CheckIntersliceDistance(l4DDistanceBetweenSliceCenters); + + end; //not 1st read + + end; //if lInside2005140F + //lInside2005140F := false; + end; + $35 : info := 'Image Orientation'; + $37 : begin //nifti + info := 'Image Orientation (Patient)'; + readfloats6 (fp, remaining, lDummyStr, lDicomData.Orient[1], lDicomData.Orient[2],lDicomData.Orient[3],lDicomData.Orient[4], lDicomData.Orient[5],lDicomData.Orient[6], lROK); + if not lrOK then goto 666; + e_len := 0; + remaining := 0; + + end; + $50 : info := 'Location'; + $52 : info := 'Frame of Reference UID'; + $91 : info := 'Echo Train Length'; + $70 : info := 'Image Geometry Type'; + $60 : info := 'Laterality'; + $0105 : begin + //Apr2007 + + DICOMHeaderStringToInt(lnVol); + + //Number of temporal positions=105 + end; + $1001: info := 'Acquisitions in Series'; + $1002: info := 'Images in Acquisition'; + $1020: info := 'Reference'; + $1040: begin info := 'Position Reference'; t := _string; end; + $1041: begin info := 'Slice Location'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + ldicomdata.location:=lfloat1; + end; + $1070: begin + info := 'Other Study Numbers'; + t := _string; + end; + $3401: info := 'Modifying Device ID'; + $3402: info := 'Modified Image ID'; + $3403: info := 'Modified Image Date'; + $3404: info := 'Modifying Device Mfg.'; + $3405: info := 'Modified Image Time'; + $3406: info := 'Modified Image Desc.'; + $4000: begin + info := 'Image Comments'; + DICOMHeaderString(lDicomData.ImageComments); + end; + $5000: info := 'Original Image ID'; + $5002: info := 'Original Image... Nomenclature'; + //$9113: xxxx + end; + $0021:case element of + $104F: begin + info :='GE Locations in acquisition'; + + if lPrefs.UseGE_0021_104F then begin + //June 2009 - Thomas Stephan sent me a GE image where this was set to 2, but should have been 1 + //I hope removing this does not cause problems with other GE images... + if e_len = 2 then begin + lDicomData.SlicesPer3DVol := read16(fp,lrOK); + e_len := 0; remaining := 0; + /// fx(9999, lDicomData.SlicesPer3DVol); + end; + end; //use 0021_104F + end; + + $1341: begin + info :='Siemens Mosaic Slice Count'; + DICOMHeaderStringToInt(lDicomData.SiemensSlices); + + end; + $134F: begin //1366 + info :='Siemens Order of Slices'; + t := _string; + lDICOMdata.SiemensInterleaved := 0; //0=no,1=yes,2=undefined + //look for "INTERLEAVED" + lStr := ''; + if dFilePos(fp) > (filesz-e_len) then goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for i := 0 to e_len-1 do + if Char(buff[i]) in ['?','A'..'Z','a'..'z'] + then lStr := lStr +upcase(Char(buff[i])); + FreeMem( buff); + if(lStr[1]= 'I') then lDICOMdata.SiemensInterleaved := 1; //0=no,1=yes,2=undefined + e_len := 0; + end; + end; +$0028 : begin + case element of + $00 : info := 'Image Presentation Group Length'; + $02 : begin + info := 'Samples Per Pixel'; + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + lDicomData.SamplesPerPixel :=tmp; + if e_len > 255 then begin + explicitVR := true; //kludge: switch between implicit and explicitVR + end; + tmpstr := inttostr(tmp); + e_len := 0; + remaining := 0; + end; + $04 : begin + info := 'Photometric Interpretation'; + TmpStr := ''; + if dFilePos(fp) > (filesz-e_len) then goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for i := 0 to e_len-1 do + if Char(buff[i]) in [{'+','-',' ', }'0'..'9','a'..'z','A'..'Z'] + then TmpStr := TmpStr +(Char(buff[i])); + FreeMem( buff); + (*xif TmpStr = 'MONOCHROME1' then lDicomdata.monochrome := 1 + else if TmpStr = 'MONOCHROME2' then lDicomdata.monochrome := 2 + else if (length(TMpStr)> 0) and (TmpStr[1] = 'Y') then lDICOMdata.monochrome := 4 + else lDICOMdata.monochrome := 3; *) + remaining := 0; + e_len := 0; {use tempstr} + + end; + $05 : info := 'Image Dimensions (ret)'; + $06 : begin + info := 'Planar Configuration'; + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + lDicomData.PlanarConfig :=tmp; + remaining := 0; + end; + + $08 : begin + //if lPapyrusnSlices < 1 then + // if remaining = 2 then begin + // tmp := read16(fp,lrOK); + // + // end else xx + DICOMHeaderStringToInt(lDicomData.XYZdim[3]); + if lDicomData.XYZdim[3] < 1 then lDicomData.XYZdim[3] := 1; + info := 'Number of Frames'; + end; + $09: begin info := 'Frame Increment Pointer'; TmpStr := ReadStrHex(fp, remaining,lrOK); if not lrOK then goto 666; + e_len := 0; remaining := 0; end; + $10 : begin info := 'Rows'; + lDicomData.XYZdim[2] := read16(fp,lrOK); + if not lrOK then goto 666; + tmp := lDicomData.XYZdim[2]; + remaining := 0; + end; + $11 : begin info := 'Columns'; + lDicomData.XYZdim[1] := read16(fp,lrOK); + if not lrOK then goto 666; + tmp := lDicomData.XYZdim[1]; + remaining := 0; + end; + $30 : begin info := 'Pixel Spacing'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + //qq + //row spacing [y], then column spacing [x]: see part 3 of DICOM + e_len := 0; remaining := 0; + lDICOMdata.XYZmm[2] := lfloat1; + lDICOMdata.XYZmm[1] := lfloat2; + end; + $31: info := 'Zoom Factor'; + $32: info := 'Zoom Center'; + $34: begin info :='Pixel Aspect Ratio';t := _string; end; + $40: info := 'Image Format [ret]'; + $50 : info := 'Manipulated Image [ret]'; + $51: info := 'Corrected Image'; + $60: begin info := 'Compression Code [ret]';t := _string; end; + $100: begin info := 'Bits Allocated'; + if remaining = 4 then + tmp := read32(fp,lrOK) + else + tmp := read16(fp,lrOK); + //lWord := read16(fp,lrOK); + //lWord := read16(fp,lrOK); + + if not lrOK then goto 666; + if tmp = 8 then lDicomData.Allocbits_per_pixel := 8 + else if tmp = 12 then lDicomData.Allocbits_per_pixel := 12 + else if tmp = 16 then lDicomData.Allocbits_per_pixel := 16 + else if tmp = 32 then lDicomData.Allocbits_per_pixel := 32 + else if tmp = 24 then begin + //xlDicomData.SamplesPerPixel := 3; + lDicomData.Allocbits_per_pixel := 8 + end else begin + lWord := tmp; + lWord := swap(lWord); + if lWord in [8,12,16,24,32] then begin + lDicomData.Allocbits_per_pixel := tmp; + lByteSwap := true; + end else begin + if lImageFormatOK then + dcmMsg('This software only reads 8, 12, 16, 24 [RGB] and 32 bit DICOM files. This file allocates '+inttostr(tmp)+' bits per voxel.'); + lImageFormatOK := false; + end; + end; + //remaining := 2;//remaining; //1371-> + remaining := 0 + end; + $0101: begin info := 'Bits Stored'; + if remaining = 4 then + tmp := read32(fp,lrOK) + else + tmp := read16(fp,lrOK); + + if not lrOK then goto 666; + + (*if tmp <= 8 then lDicomData.Storedbits_per_pixel := 8 + else if tmp <= 16 then lDicomData.Storedbits_per_pixel := 16 + else if tmp <= 24 then begin + lDicomData.Storedbits_per_pixel := 24; + lDicomData.SamplesPerPixel := 3; + end else begin + lWord := tmp; + lWord := swap(lWord); + if lWord in [8,12,16] then begin + lDicomData.Storedbits_per_pixel := tmp; + lByteSwap := true; + end else begin + if lImageFormatOK then + dcmMsg('This software can only read 8, 12 and 16 bit DICOM files. This file stores '+inttostr(tmp)+' bits per voxel.'); + lDicomData.Storedbits_per_pixel := tmp; + lImageFormatOK := false;{ } + end; + end;*) + remaining := 0; + end; + $0102: begin info := 'High Bit'; + if remaining = 4 then + tmp := read32(fp,lrOK) + else + tmp := read16(fp,lrOK); + if not lrOK then + goto 666; + remaining := 0; + end; + $0103: begin + info := 'Pixel Representation'; + if remaining = 2 then begin + tmp := read16(fp,lrOK); + //1= signed, 0=unsigned... + if tmp = 1 then + lDicomData.SignedData := true; + if tmp = 0 then + lDicomData.SignedData := false; + remaining := 0; + end; + end; + $0104: info := 'Smallest Valid Pixel Value'; + $0105: info := 'Largest Valid Pixel Value'; + $0106: begin + //xlDicomData.MinIntensitySet:= true; + info := 'Smallest Image Pixel Value'; + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + //xlDicomData.Minintensity := tmp; + //if >32767 then there will be wrap around if read as signed value! + remaining := 0; + end; + $0107: begin + info := 'Largest Image Pixel Value'; + if remaining = 4 then + tmp := read32(fp,lrOK) + else + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + //xlDicomData.Maxintensity := tmp; + //if >32767 then there will be wrap around if read as signed value! + remaining := 0; + end; + $120: info := 'Pixel Padding Value'; + $200: info := 'Image Location [ret]'; + $1040: begin t := _string; info := 'Pixel Intensity Relationship'; end; + $1050: begin + info := 'Window Center'; + if e_len > 0 then begin + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + //xlDICOMdata.WindowCenter := round(lfloat1); + end; + end;{float} + $1051: begin info := 'Window Width'; + if e_len > 0 then begin + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; + remaining := 0; + //xlDICOMdata.WindowWidth := round(lfloat1); + end; //ignore empty elements, e.g. LeadTech's image6.dic + end; + $1052: begin t := _string;info :='Rescale Intercept'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.intenIntercept := lfloat1; + //if (lDICOMdata.nOrder > 0) and (lDICOMdata.nOrder < kMaxOrderVal) then + // lDICOMdata.OrderIntercept[lDICOMdata.nOrder] := lfloat1; + end; {float} + + $1053:begin + t := _string; info := 'Rescale Slope'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + if lFloat1 < 0.000000001 then begin + lFLoat1 := 1; //misused in some images, see IMG000025 + end; + lDICOMdata.intenScale := lfloat1; + //if (lDICOMdata.nOrder > 0) and (lDICOMdata.nOrder < kMaxOrderVal) then + // lDICOMdata.OrderSlope[lDICOMdata.nOrder] := lfloat1; + end; {float} + $1054:begin t := _string; info := 'Rescale Type';end; + $1100: info := 'Gray Lookup Table [ret]'; + $1101: begin info := 'Red Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK,lJunk); + if not lrOK then goto 666; +e_len := 0; remaining := 0; end; + $1102: begin info := 'Green Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK,lJunk); + if not lrOK then goto 666; +e_len := 0; remaining := 0; end; + $1103: begin info := 'Blue Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK,lJunk); + if not lrOK then goto 666; +e_len := 0; remaining := 0; end; + $1199: begin + info := 'Palette Color Lookup Table UID'; + end; + $1200: info := 'Gray Lookup Data [ret]'; + $1201, $1202,$1203: begin + case element of + $1201: info := 'Red Table'; {future} + $1202: info := 'Green Table'; {future} + $1203: info := 'Blue Table'; {future} + end; + + if dFilePos(fp) > (filesz-remaining) then + goto 666; + if not lReadColorTables then begin + dSeek(fp, dFilePos(fp) + remaining); + end else begin {load color} + width := remaining div 2; + + if width > 0 then begin + getmem(lWordRA,width*2); + for i := (width) downto 1 do + lWordRA^[i] := read16(fp,lrOK); + //value := 159; + value := lWordRA^[1]; + max16 := value; + min16 := value; + for i := (width) downto 1 do begin + value := lWordRA^[i]; + if value < min16 then min16 := value; + if value > max16 then max16 := value; + end; //width..1 + if max16 - min16 = 0 then + max16 := min16+1; {avoid divide by 0} + if (lDicomData.Allocbits_per_pixel <= 8) and (width > 256) then width := 256; //currently only accepts palettes up to 8-bits + GetMem( lColorRA, width );(**) + for i := width downto 1 do + lColorRA^[i] := (lWordRA^[i] shr 8) {and 255}; + FreeMem( lWordRA ); + case element of + $1201: begin + red_table_size := width; + red_table :=lColorRA;; + end; + $1202: begin + green_table_size := width; + green_table :=lColorRA;; + end; + else {x$1203:} begin + blue_table_size := width; + blue_table :=lColorRA;; + end; {else} + end; {case} + end; //width > 0; + if odd(remaining) then + dSeek(fp, dFilePos(fp) + 1{remaining}); + end; {load color} + tmpstr := 'Custom'; + remaining := 0; + e_len := 0; {show tempstr} + end; + $1221, $1222,$1223: begin + info := 'Color Palette ['+inttostr(dFilePos(fp))+']'; + (*xcase element of + $1221: begin + lDicomData.RLEredOffset:= dFilePos(fp); + lDicomData.RLEredSz:= e_len; + end; + $1222: begin + lDicomData.RLEgreenOffset:= dFilePos(fp); + lDicomData.RLEgreenSz:= e_len; + end; + $1223: begin + lDicomData.RLEblueOffset:= dFilePos(fp); + lDicomData.RLEblueSz:= e_len; + end; + end;*)//Case set offset and length + + tmpstr := inttostr(e_len); + dSeek(fp, dFilePos(fp)+ e_LEN); + e_len := 0; + end; + + $3002: info := 'LUT Descriptor'; + $3003: info := 'LUT Explanation'; + $3006: info := 'LUT Data'; + $3010: begin + info := 'VOI LUT Sequence'; + if (explicitVR) and (lT0=kS) and (lT1=kQ) then + e_len := 8; + end; + end; //case +end; //$0028 + $41: case element of //Papyrus Private Group + $1010: begin + info := 'Papyrus Icon [bytes skipped]'; + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; + end; //element $0041:$1010 + $1015: begin + + info := 'Papyrus Slices'; + (*Papyrus format is buggy - see lsjpeg.pas for details, therefore, I have removed extensive support + if e_len = 2 then begin + lDicomData.XYZdim[3] := read16(fp,lrOK); + if not lrOK then goto 666; + end; + if lDicomData.XYZdim[3] < 1 then lDicomData.XYZdim[3] := 1; + if {(false) and }(lDicomData.XYZdim[3] > 1) and (lReadJPEGtables) and (gECATJPEG_table_entries = 0) then begin + //Papyrus multislice files keep separate DICOM headers for each slice within a DICOM file + lPapyrusnSlices := lDicomData.XYZdim[3]; + lPapyrusSlice := 0; + //lPapyrusData := lDicomData; + gECATJPEG_table_entries := lDICOMdata.XYZDim[3]; + getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint)); + getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint)); + end else + lDicomData.XYZdim[3] := 1; + tmpstr := inttostr(lDicomData.XYZdim[3]); + remaining := 0; + e_len := 0;*) + end; //element $0041:$1015 + $1050: begin + info := 'Papyrus Bizarre Element'; //bizarre osiris problem + if (dfilepos(fp)+e_len)= (filesz) then + e_len := 8; + end; //element $0041:$1050 + end; //group $0041: Papyrus + + $43: begin + + if lDicomData.ManufacturerID = kGEID then begin + case element of + $1039,$A039: begin + // 0043,1039 (or 0043,a039). b value (as the first number in the string). + + info := 'GE Bvalue'; + if e_len > 0 then begin + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.DTI.bval := round(lfloat1); + lDICOMdata.nDTIdir := 1; + end; //e_len>0 + end;//1039 or Ao39 + end;//Case + end; //Manufacturer = GE + end;//$0043 - GE bvalues + + $54: case element of + $0: info := 'Nuclear Acquisition Group Length'; + $11: info := 'Number of Energy Windows'; + $21: info := 'Number of Detectors'; + $51: info := 'Number of Rotations'; + $80: begin info := 'Slice Vector'; TmpStr := ReadStr(fp, remaining,lrOK,lJunk); if not lrOK then goto 666; + e_len := 0; remaining := 0; end; + $81: info := 'Number of Slices'; + $202: info := 'Type of Detector Motion'; + $400: info := 'Image ID'; + + end; + $2010 : + case element of + $0: info := 'Film Box Group Length'; + $100: info := 'Border Density'; + end; + $4000 : info := 'Text'; + $0029 : begin + case element of + $1010: begin + //lSiemensMosaic0029_1010:= true; + if (lDicomData.kV = 0) then begin //Siemens uses 0029:1010 for both CT and MRI, but only MRI is in CSA format + lDicomData.CSAImageHeaderInfoPos := (dFilePos(fp)); + lDicomData.CSAImageHeaderInfoSz := e_len; + end; + info := 'Private Sequence Delimiter ['+inttostr(dFilePos(fp))+']'; + if not lImageFormatOK then + time_to_quit := TRUE; + + //x(lDicomData.RunLengthEncoding) or ( ((lDicomData.JPEGLossycpt) or (lDicomData.JPEGLosslesscpt)) and (gECATJPEG_table_entries >= lDICOMdata.XYZdim[3]))} + + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; {show tempstr} + end; + $1020: begin + if (lDicomData.kV = 0) then begin //Siemens uses 0029:1020 for both CT and MRI, but only MRI is in CSA format + info := 'CSA Series Header Info'; + lDicomData.CSASeriesHeaderInfoPos := (dFilePos(fp)); + lDicomData.CSASeriesHeaderInfoSz := e_len; + //dcmMsg('CSA Series Header Info @ '+Inttostr (dFilePos(fp))+ 'length: '+inttostr(e_len) ); + end; + //(0029, 1020) [CSA Series Header Info] OB: Array of 80248 bytes + end; + $1053: begin + info :='Philips Scale Slope'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lPhilipsScaleSlope := lfloat1; + {if e_len = 4 then begin + lPhilipsScaleSlope := read32r(fp,lrOK); + TmpStr := floattostr(lPhilipsScaleSlope); + t := _string; + + if not lrOK then goto 666; + e_len := 0; + remaining := 0; + end; } + end; + + + else begin + end; + END; + END; //gROUP 0029 + + (* $0045 : begin + case element of + $103B: begin + dcmMsg('0045:103B'); + end; //element $1010 + + end; //CASE...element + end; //group 0045 + *) + $0089 : begin + case element of + $1010: begin + e_len := 0; + lProprietaryImageThumbnail := true; + //lImageFormatOK := false; + end; //element $1010 + $1020: begin + //thoravision files + + if e_len > 12 then + e_len := 0; + //lProprietaryImageThumbnail := true; + //lImageFormatOK := false; + end; //element $1010 + + end; //CASE...element + end; //group 0089 + + $2001 : begin + if lDicomData.ManufacturerID = kPhilipsID then begin + case element of + {$IFDEF read20011003} + $1003: begin //bvalue - see lUse00189117 + //if (lUse00189087 = kUndefined) then + // lUse00189087 := kNo; //see notes for 0018,9087 - shame on Philips! + + if (e_len = 4) {and (lUse00189087 = kNo)} then begin + if (lDICOMdata.nDTIdir < kMaxDTIDir) and (not (lUse00189117 = kYes)) then //see 0018,9117 - Philips' usage shameful + inc(lDICOMdata.nDTIdir); + lUse00189117 := kNo; + lDICOMdata.DTI.bval := round(read32r(fp,lrOK)); + lDTIra[lDICOMdata.nDTIdir].bval := lDICOMdata.DTI.bval; + TmpStr := inttostr(lDICOMdata.DTI.bval); + t := _string; + info :='Philips DTI b-val'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; //e_len = 4 + + end; //element 1003 + {$ENDIF} // read20011003 + $100B: begin + info := 'Philips: slice orientation';t := _string; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.PhilipsSliceOrient := TmpStr; + AplhaNumericStrDICOM (lDicomData.PhilipsSliceOrient); + end;//PhilipsSliceOrient + $1018: begin + if e_len = 4 then begin + info :='number of slices'; + lDicomData.SlicesPer3DVol := read32(fp,lrOK); + //uninterleave data + e_len := 0; remaining := 0; + if lResearchMode then + lDicomData.SeriesNum := lDicomData.SeriesNum + 50; //do not jumble research recons and normal images + end; //e_len = 4 + TmpStr := floattostr(lDicomData.SlicesPer3DVol); + end; //1018 + + $102D: begin + ///Apr2007 + + if e_len = 2 then begin + lnSlicePerVol := read16(fp,lrOK); + e_len := 0; remaining := 0; + end; + //fx(213,lnSlicePerVol); + end; //102D + + $105F: begin //Philips Stack Sequence + + if e_len > 8 then e_len := 8; + end; //105F + end; + end; //if manufacturer = Philips + end; + + //2001,1004) + + $2005 : begin + + + //if lDicomData.ManufacturerID = kPhilipsID then dcmMsg(inttohex(element,4)); + if lDicomData.ManufacturerID = kPhilipsID then begin + case element of + $140F: begin + //lInside2005140F := true; + if (e_len > 8) and (lOsirix0002_0013) then begin + //dcmMsg('WARNING: Images from Osirix which disrupts DICOM tags. Please validate output.'); + e_len := 8; remaining := e_len; //qas 7/2013 + end; + end; + + + $100E: begin + if e_len = 4 then begin + lPhilipsScaleSlope := read32r(fp,lrOK); + TmpStr := floattostr(lPhilipsScaleSlope); + t := _string; + info :='Philips Scale Slope'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + end; //element $1010 + + $1071: begin + + if e_len = 4 then begin + lDicomData.AngulationAP := read32r(fp,lrOK); + TmpStr := floattostr(lDicomData.AngulationAP); + t := _string; + info :='angulation midslice, AP (degrees)'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + end; // Philips AP angulation : -8.74086 + $1072: begin + if e_len = 4 then begin + lDicomData.AngulationFH := read32r(fp,lrOK); + TmpStr := floattostr(lDicomData.AngulationFH); + t := _string; + info :='angulation midslice, FH (degrees)'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + end; // Philips Philips FH angulation : -3.53147 + $1073: begin + if e_len = 4 then begin + lDicomData.AngulationRL := read32r(fp,lrOK); + TmpStr := floattostr(lDicomData.AngulationRL); + t := _string; + info :='angulation midslice, RL (degrees)'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + end; // Philips RL angulation + {$IFDEF read20011003} + $10b0: begin //see lUse00189117 + + if (e_len = 4) and (lUse00189117 = kNo) then begin + lDICOMdata.DTI.v1 := read32r(fp,lrOK); + if lDICOMdata.nDTIdir < 1 then lDICOMdata.nDTIdir := 1; + lDTIra[lDICOMdata.nDTIdir].v1 := lDICOMdata.DTI.v1; + TmpStr := floattostr(lDICOMdata.DTI.v1); + t := _string; + // dcmMsg('zqas '+inttostr(lDICOMdata.nDTIdir)+' b: '+inttostr(lDICOMdata.DTI[lDICOMdata.nDTIdir].bval)+' v1: '+floattostr(lDICOMdata.DTI[lDICOMdata.nDTIdir].v1)); + + info :='Philips Gradient vector [x]'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; //e_len = 4 + end; //element 10b0 + $10b1: begin //see lUse00189117 + if (e_len = 4) and (lUse00189117 = kNo) then begin + lDICOMdata.DTI.v2 := read32r(fp,lrOK); + if (lDICOMdata.nDTIdir < 1) then lDICOMdata.nDTIdir := 1; + lDTIra[lDICOMdata.nDTIdir].v2 := lDICOMdata.DTI.v2; + TmpStr := floattostr(lDICOMdata.DTI.v2); + t := _string; + info :='Philips Gradient vector [y]'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; //e_len = 4 + end; //element 10b1 + $10b2: begin //see lUse00189117 + if (e_len = 4) and (lUse00189117 = kNo) then begin + lDICOMdata.DTI.v3 := read32r(fp,lrOK); + if (lDICOMdata.nDTIdir < 1) then lDICOMdata.nDTIdir := 1; + lDTIra[lDICOMdata.nDTIdir].v3 := lDICOMdata.DTI.v3; + TmpStr := floattostr(lDICOMdata.DTI.v3); + t := _string; + info :='Philips Gradient vector [z]'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; //e_len = 4 + end; //element 10b2 + {$ENDIF} // read20011003} + end; //CASE...element + end; //if Manufacturer = Philips + end; //group 2005 + $5200 : begin + case element of + $9230: begin + if (e_len > 8) and (lDicomData.ManufacturerID = kPhilipsID) and (lOsirix0002_0013) then begin + dcmMsg('WARNING: Images from Osirix which disrupts DICOM tags. PLEASE VALIDATE OUTPUT.'); + e_len := 8; remaining := e_len; //qas 7/2013 + end; + //if (lDicomData.ManufacturerID = kPhilipsID) and (orientation_not_visible( lDICOMdata))then + // read_philips_hidden(lFilename, dFilePos(fp),e_len,lDICOMdata); + end //element 9230 + end; //case element + end; //group 5200 + $5400 : begin + case element of + $0100: begin + //can not convert sound files to images 12/2012 + lImageFormatOK := false; + dcmMsg('Note: the DICOM file '+lFileName+' stores a waveform sequence (e.g. ECG) that will not be converted to an image'); + info :='WaveformSequence'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end //element 0100 + end; //case element + end; //group 5400 + $DDFF : begin + case element of + $00E0: begin + //For papyrus multislice format: if (lPapyrusSlice >= lPapyrusnSlices) then + time_to_quit := TRUE; + end; + end; + end; + $FFFE : begin + case element of + $E000 : begin + //e_len := 0; remaining := e_len; //qas 7/2013 //not sure why? + info := 'Image Fragment ['+inttostr(e_len)+'@'+inttostr(dFilePos(fp))+']'; + dcmMsg( IntToHex(group,4)+','+IntToHex(element,4)+','+Info+'='+lStr+' Offset'+inttostr(dfilepos(fp))+' Length'+inttostr(e_len)); + + inc(lIndent); + lInside00209113 := (lprevGroup = $0020) and (lprevelement = $9113); + lInside2005140F := (lprevGroup = $2005) and (lprevelement = $140F); + // if (lInside00209113) then fx(333); + (*iif lJPEGEntries > 17 then + lTestError := true; + + + if not lProprietaryImageThumbnail then begin + f (lReadJPEGtables) and ((lDICOMdata.RunLengthEncoding) or (lDICOMdata.JPEGLossyCpt) or (lDICOMdata.JPEGLosslessCpt)) and (not lFirstFragment) and (e_len > 1024) {1384} and ( (e_len+dFilePos(fp)) <= FileSz) then begin + //first fragment is the index table, so the previous line skips the first fragment + if (gECATJPEG_table_entries = 0) then begin + gECATJPEG_table_entries := lDICOMdata.XYZDim[3]; + getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint)); + getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint)); + end; + if lJPEGentries < gECATJPEG_table_entries then begin + inc(lJPEGentries); + gECATJPEG_pos_table^[lJPEGEntries] := dFilePos(fp); + gECATJPEG_size_table^[lJPEGEntries] := e_len; + end; + end; + + if (lDICOMdata.CompressOffset =0) and ( (e_len+dFilePos(fp)) <= FileSz) and (e_len > 1024){ALOKA} then begin + lDICOMdata.CompressOffset := dFilePos(fp); + lDICOMdata.CompressSz := e_len; + end; + //if e_len > lDICOMdata.CompressSz then lDICOMdata.CompressSz := e_len; +if (e_len > 1024) and (lDICOMdata.CompressSz=0) then begin //ABBA RLE ALOKA + //Time_To_Quit := true;//ABBA + lDICOMdata.CompressSz := e_len; + lDICOMdata.CompressOffset := dFilePos(fp); +end; + if (lFirstFragment) or ((e_len > lDICOMdata.CompressSz) and not (lDicomData.RunLengthEncoding)) then + lDICOMdata.CompressOffset := dFilePos(fp); + if (e_len > lDICOMdata.CompressSz) and (e_len > 1024){ALOKA} then + lDICOMdata.CompressSz := e_len; + lFirstFragment := false; + lDICOMdataBackUp := lDICOMData; + + if (gECATJPEG_table_entries = 1) then begin //updatex + gECATJPEG_size_table^[1] := lDICOMdata.CompressSz; + gECATJPEG_pos_table^[1] := lDICOMdata.CompressOffset; + end; //updatex + +end; //not proprietaryThumbnail +lProprietaryImageThumbnail := false; //1496 + *) + lFirstFragment := false;//Dec09 + lDICOMdataBackUp := lDICOMData;//Dec09 + + if ((e_len > 1024) and ((lDicomData.JPEGLosslessCpt)) or (e_len >= (lDicomData.XYZdim[1]*lDicomData.XYZdim[2]))){Apr 2011} and (lDicomData.XYZdim[1]> 1) then begin + lDICOMdata.CompressOffset := dFilePos(fp); + lDICOMdata.CompressSz := e_len; + + Time_To_Quit := true; + //dcmMsg('abba'+inttostr(lDICOMdata.CompressOffset)+' '+inttostr(lDICOMdata.CompressSz)); + end; + + + if (dFilePos(fp) + e_len) >= filesz then + Time_To_Quit := true; + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; + end; + + $E0DD : begin + if (lIndent > 0) then dec(lIndent); + lInside00209113 := false; + lInside2005140F := false; + info := 'Sequence Delimiter'; + if (lDICOMdata.XYZdim[1]<lDICOMdataBackUp.XYZdim[1]) then begin + lDICOMData := lDICOMdataBackUp; + dSeek(fp, dFilePos(fp) + e_len); + //lDICOMData := lDICOMdataBackUp; + end else if not lImageFormatOK then begin + //x(lDicomData.RunLengthEncoding) or ( ((lDicomData.JPEGLossycpt) or (lDicomData.JPEGLosslesscpt)) and (gECATJPEG_table_entries >= lDICOMdata.XYZdim[3])) then + time_to_quit := TRUE; + end; + //RLE ABBA + if (e_len = 0) then begin //ALOKA + explicitVR := true; + time_to_quit := FALSE;//RLE16=false + end; + //END + + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; + end; + end; + end; + $FFFC : begin + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; + end; + $72FF : case element of + $1041: time_to_quit := TRUE; + end; //case 72FF + $7FE0 : + case element of + $00 : begin + info := 'Pixel Data Group Length'; + if not lImageFormatOK then time_to_quit := TRUE; + end; + $10 : begin + info := 'Pixel Data'; + TmpStr := inttostr(e_len); + //ShowdcmMsg(inttostr(ExpectedDicomBytes(lDicomData) ) +' '+ inttostr(e_len)); + if ((ExpectedDicomBytes(lDicomData) ) > e_len) or (lDICOMdata.XYZdim[1]<lDICOMdataBackUp.XYZdim[1]) then begin + lDICOMData := lDICOMdataBackUp; + dSeek(fp, dFilePos(fp) + e_len); + //lDICOMData := lDICOMdataBackUp; + end else if {(not lDicomData.RunLengthEncoding) and} (not lDicomData.JPEGLossycpt) and (not lDicomData.JPEGLosslesscpt) then begin + time_to_quit := TRUE; + //xlDicomData.ImageSz := e_len; + + end; + e_len := 0; + + end; + + + end; + else + begin + if (group >= $6000) AND (group <= $601e) AND ((group AND 1) = 0) + then begin + info := 'Overlay'+inttostr(dfilepos(fp))+'x'+inttostr(e_len); + end; + if element = $0000 then info := 'Group Length'; + if element = $4000 then info := 'Comments'; + end; + end; +lStr := ''; + + 1234: + lprevGroup := Group; + lprevElement := element; +if (Time_TO_Quit) and (not lImageFormatOK) then begin + lHdrOK := true; + goto 666; +end; + +//dcmMsg(inttohex(group,4) +':'+inttohex(element,4) +' '+inttostr(e_len)+'@'+ inttostr(dfilepos(fp))); + + if (e_len + dfilepos(fp)) > FileSz then begin//patch for GE files that only fill top 16-bytes w Random data + e_len := e_len and $FFFF; + end; + + if (e_len > 131072) then begin + //goto 666; + end;//zebra + if (NOT time_to_quit) AND (e_len > 0) and (remaining > 0) then begin + if (e_len + dfilepos(fp)) > FileSz then begin + if not lImageFormatOK(*x(lDICOMdata.GenesisCpt) or (lDICOMdata.JPEGlosslessCpt) or (lDICOMdata.JPEGlossyCpt)*) then + lHdrOK := true + else begin + dcmMsg('dcm Error: not a DICOM image: '+lFilename); + {dcmMsg('Diagnostics saved as: c:\dcmcrash.txt'); + //diagnostics + assignfile(lTextF,'c:\dcmcrash.txt'); + Filemode := 0; + rewrite(lTextF); + Write(lTextF,lDynStr); + closefile(lTextF); } + + //dcmMsg(inttohex(group,4) +':'+inttohex(element,4) +' '+inttostr(e_len)+'@'+ inttostr(dfilepos(fp))); + end; + goto 666; + end; + + if e_len > 0 then begin + GetMem( buff, e_len); + dBlockRead(fp, buff, e_len, n); + if lVerboseRead then + case t of + unknown : + case e_len of + 1 : lStr := ( IntToStr(Integer(buff[0]))); + 2 : Begin + if lDicomData.little_endian <> 0 + then i := Integer(buff[0]) + 256*Integer(buff[1]) + else i := Integer(buff[0])*256 + Integer(buff[1]); + lStr :=( IntToStr(i)); + end; + 4 : Begin + if lDicomData.little_endian <> 0 + then i := Integer(buff[0]) + + 256*Integer(buff[1]) + + 256*256*Integer(buff[2]) + + 256*256*256*Integer(buff[3]) + else i := Integer(buff[0])*256*256*256 + + Integer(buff[1])*256*256 + + Integer(buff[2])*256 + + Integer(buff[3]); + lStr := (IntToStr(i)); + end; + else begin + if e_len > 0 then begin + for i := 0 to e_len-1 do begin + if Char(buff[i]) in ['+','-','/','\',' ', '0'..'9','a'..'z','A'..'Z'] then + lStr := lStr+(Char(buff[i])) + else + lStr := lStr+('.'); + end; + end else + lStr := '*NO DATA*'; + end; + end; + + i8, i16, i32, ui8, ui16, ui32, + _string : for i := 0 to e_len-1 do + if Char(buff[i]) in ['+','-','/','\',' ', '0'..'9','a'..'z','A'..'Z'] + then lStr := lStr +(Char(buff[i])) + else lStr := lStr +('.'); + end; + FreeMem(buff); + + end; + end + else if e_len > 0 then lStr := (IntToStr(tmp)) + else begin + lStr := TmpStr; + end; + (*if (lGrp) then if MessageDlg(lStr+'= '+info+' '+IntToHex(where,4)+': ('+IntToHex(group,4)+','+IntToHex(element,4)+')'+IntToStr(e_len)+'. Continue?', + mtConfirmation, [mbYes, mbNo], 0) = mrNo then GOTO 666; + *) + //if (Group > $2005) then + // dcmMsg(info+' '+IntToStr(where)+': ('+IntToHex(group,4)+','+IntToHex(element,4)+')'+IntToStr(e_len)); +{$IFDEF Troubleshoot} +//WriteLn(myFile,IntToHex(group,4)+','+IntToHex(element,4)+','+Info+'='+lStr);//+' Offset'+inttostr(dfilepos(fp))+' Length'+inttostr(e_len)); +// dcmMsg( IntToHex(group,4)+','+IntToHex(element,4)+','+Info+'='+lStr);//+' Offset'+inttostr(dfilepos(fp))+' Length'+inttostr(e_len)); +dcmMsg( IntToHex(group,4)+','+IntToHex(element,4)+','+Info+'='+lStr+' Offset'+inttostr(dfilepos(fp))+' Length'+inttostr(e_len)); + +{$ENDIF Troubleshoot} + + + if lverboseRead then begin +if length(lDynStr) > kMaxTextBuf then begin + if not lTextOverFlow then begin + lDynStr := lDynStr + 'Only showing the first '+inttostr(kMaxTextBuf) +' characters of this LARGE header'; + lTextOverFlow := true; + + end; + //goto 666; +end else + lDynStr := lDynStr+IntToHex(group,4)+','+IntToHex(element,4)+','+Info+'='+lStr+kCR ; + + dcmMsg(AddIndent(lIndent)+IntToHex(group,4)+','+IntToHex(element,4)+','+inttostr(e_len)+'@'+inttostr(dfilepos(fp))+','+Info+'='+lStr); +end; //not verbose read + + end; // end for + + lDicomData.ImageStart := dfilepos(fp); + + if lBigSet then begin + if lBig then lDicomData.little_endian := 0 + else lDicomData.little_endian := 1; + end; + lHdrOK := true; +if lByteSwap then begin + ByteSwap(lDicomdata.XYZdim[1]); + ByteSwap(lDicomdata.XYZdim[2]); + if lDicomdata.XYZdim[3] <> 1 then + ByteSwap(lDicomdata.XYZdim[3]); + //xByteSwap(lDicomdata.SamplesPerPixel); + ByteSwap(lDicomData.Allocbits_per_pixel); + //xByteSwap(lDicomData.Storedbits_per_pixel); +end; + +if (lDICOMdata.ManufacturerID = kPhilipsID) and (l4DDistanceBetweenSliceCenters <> kNaNsingle) then //some 3D and 4D Philips files do not correctly report interslice distance in 0018,0088 and 0018,0050... + lDICOMdata.XYZmm[3] := (l4DDistanceBetweenSliceCenters); +if (lPrefs.PhilipsPrecise) and (lManufacturerIsPhilips) and (lPhilipsScaleSlope <> 0) then begin + //if (true) and (lManufacturerIsPhilips) and (lPhilipsScaleSlope <> 0) then begin //66666666 + //dcmMsg(floattostr(lDICOMdata.IntenScale)+' '+floattostr(lDICOMdata.intenIntercept) +' '+floattostr(lPhilipsScaleSlope)); + PhilipsPrecise (lDicomData.IntenScale, lDICOMdata.intenIntercept,lPhilipsScaleSlope, lDicomData.IntenScale, lDICOMdata.intenIntercept,true); +end; //if PARprecise +if (lDICOMdata.ManufacturerID = kPhilipsID) and (lDICOMdata.nDTIdir > 1) then begin + lGELX := true; + for i := 1 to lDICOMdata.nDTIdir do + if lDTIra[i].bval <> lDICOMdata.DTI.bval then + lGELX := false;//multiple B0 directions + if lGELX then + lDICOMdata.nDTIdir := 1; //only report multiple dti directions if there is variability in the diffusion values + lGELX := false; +end; +if (lMatrixSz > 1) and (lDicomData.CSAImageHeaderInfoPos > 0) and (lDicomData.CSAImageHeaderInfoSz > 0) and + not (((lDicomdata.XYZdim[1] mod lMatrixSz) = 0) and ((lDicomdata.XYZdim[2] mod lMatrixSz) = 0)) then begin + //Slow method for non-square Siemens matrices - 0018:1310 based on phase/freq, so it is easier to read CSA to decode rows/columns + + GetCSAImageHeaderInfo (lFilename, lDicomData.CSAImageHeaderInfoPos ,lDicomData.CSAImageHeaderInfoSz, lTempInt,lDICOMdata.SiemensMosaicX,lDICOMdata.SiemensMosaicY, lfloat1,lfloat2,lfloat3) +end else + if (lMatrixSz > 1) and ((lDicomdata.XYZdim[1] mod lMatrixSz) = 0) and ((lDicomdata.XYZdim[2] mod lMatrixSz) = 0) then begin + + if ((lDicomData.XYZdim[1] mod lMatrixSz)=0) then + lDicomData.SiemensMosaicX := lDicomData.XYZdim[1] div lMatrixSz; + if ((lDicomData.XYZdim[2] mod lMatrixSz)=0) then + lDicomData.SiemensMosaicY := lDicomData.XYZdim[2] div lMatrixSz; + if lDicomData.SiemensMosaicX < 1 then lDicomData.SiemensMosaicX := 1; //1366 + if lDicomData.SiemensMosaicY < 1 then lDicomData.SiemensMosaicY := 1; //1366 + + if lOldSiemens_IncorrectMosaicMM then begin //old formats convert size in mm incorrectly - modern versions are correct and include transfer syntax + lDicomdata.XYZmm[1] := lDicomdata.XYZmm[1] * (lDicomdata.XYZdim[1] div lMatrixSz); + lDicomdata.XYZmm[2] := lDicomdata.XYZmm[2] * (lDicomdata.XYZdim[2] div lMatrixSz); + end; +end else if (lSiemensMosaic0008_0008) and (lPhaseEncodingSteps > 0) and (lPhaseEncodingSteps < lDicomdata.XYZdim[2]) and ((lDicomdata.XYZdim[2] mod lPhaseEncodingSteps) = 0) and ((lDicomdata.XYZdim[2] mod (lDicomdata.XYZdim[2] div lPhaseEncodingSteps)) = 0) then begin + //1499c kludge for detecting new Siemens mosaics: WARNING may cause false positives - Siemens fault not mine! + lDicomData.SiemensMosaicY :=lDicomdata.XYZdim[2] div lPhaseEncodingSteps; + lDicomData.SiemensMosaicX := lDicomData.SiemensMosaicY; //We also need to assume as many mosaic rows as columns, as Siemens does not save the phase encoding lines in the header... +end; + // fx(lnSlicePerVol,lnVol, lDicomData.SlicesPer3DVol,lDicomdata.XYZdim[3] ); +//fx(lnVol,lnSlicePerVol,lDicomData.SlicesPer3DVol,lDicomdata.XYZdim[3]); +//fx(lnSlicePerVol,lDicomData.ManufacturerID,kPhilipsID ); +if (lnSlicePerVol > 0) and (lDicomData.ManufacturerID = kPhilipsID) {and (lnVol > 1)} and (lDicomdata.XYZdim[3] > 1) and (lDicomData.SlicesPer3DVol > 0)and ((lDicomdata.XYZdim[3] mod lDicomData.SlicesPer3DVol) = 0) then begin + lDICOMdata.File4D := true; + lnVol := lDicomdata.XYZdim[3] div lDicomData.SlicesPer3DVol; +end; +if lManufacturerIsBruker then + lDicomData.AcquNum := 1; //Bruker varies this for every image + +if (lEchoNum > 0) and (lEchoNum < 16) then begin + lDicomData.AcquNum := lDicomData.AcquNum + (1000*lEchoNum); +end; + +if lVerboseRead then begin + // lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ + dcmMsg ('DICOM data'); + dcmMsg ('Series/Acquisition/Image/Xpos/YPos/ZPos:'+kTab+inttostr(lDicomData.SeriesNum)+kTab+inttostr(lDicomData.AcquNum)+kTab+inttostr(lDicomData.ImageNum)+kTab+floattostr(lDicomData.PatientPosX)+kTab+floattostr(lDicomData.PatientPosY)+kTab+floattostr(lDicomData.PatientPosZ)); + dcmMsg ('BPP: '+inttostr(lDicomData.Allocbits_per_pixel)); + dcmMsg ('XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) ); + dcmMsg ('XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) ); + dcmMsg ('DTI bvalue:'+ inttostr(lDICOMdata.DTI.bval)); + dcmMsg ('DTI bvec:'+floattostrf(lDicomData.DTI.v1,ffFixed,8,2)+'/'+floattostrf(lDicomData.DTI.v2,ffFixed,8,2)+'/'+floattostrf(lDicomData.DTI.v3,ffFixed,8,2) ); + dcmMsg ('Little-endian:'+inttostr(lDicomData.little_endian)); + dcmMsg('Image start (bytes):'+inttostr(lDicomData.ImageStart)); +end; + //dcmMsg('abba'+inttostr(lDICOMdata.CompressOffset)+' '+inttostr(lDICOMdata.CompressSz)); + 666: + //if not lHdrOk then dcmMsg('zx'+lFilename); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + if not lHdrOK then lImageFormatOK := false; + CloseFile(fp); + FileMode := 2; //set to read/write + //if kUseDateTimeForID then + lDicomData.DateTime := StudyDateTime(lDicomData.StudyDate,lDicomData.StudyTime); + if (lDicomData.SiemensMosaicX > 1) then + lDicomData.AcquNum := 1; +end; + + +end. diff --git a/dcm2nii/dicomcompat.ppu b/dcm2nii/dicomcompat.ppu new file mode 100644 index 0000000..045ebfe Binary files /dev/null and b/dcm2nii/dicomcompat.ppu differ diff --git a/dcm2nii/dicomcompat_28June.pas b/dcm2nii/dicomcompat_28June.pas new file mode 100755 index 0000000..d3ad4e3 --- /dev/null +++ b/dcm2nii/dicomcompat_28June.pas @@ -0,0 +1,6468 @@ +unit dicomcompat; +interface +uses +{$Define NoTroubleshoot} +{$IFDEF FPC} +gzio2, +{$ELSE} +gziod, +{$ENDIF} + + SysUtils,Classes,define_types,filename,dicomtypes,dicomfastread,prefs,convertsimple, csaread; +{$H+} +var +kUseDateTimeForID: boolean = false; +procedure read_afni_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lRotation1,lRotation2,lRotation3: integer); +procedure read_ecat_data(var lDICOMdata: DICOMdata;lVerboseRead,lReadECAToffsetTables:boolean; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_siemens_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_ge_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_interfile_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +procedure read_voxbo_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +procedure read_VFF_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +procedure read_picker_data(lVerboseRead: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_tiff_data(var lDICOMdata: DICOMdata; var lReadOffsets,lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +procedure read_dicom_data_compat(lReadJPEGtables,lVerboseRead,lAutoDECAT7,lReadECAToffsetTables,lAutodetectInterfile,lAutoDetectGenesis,lReadColorTables: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lPrefs: TPrefs); + +var + gSizeMMWarningShown : boolean = false; + gECATJPEG_table_entries: integer = 0; + gECATJPEG_pos_table,gECATJPEG_size_table : LongIntP; + red_table_size : Integer = 0; + green_table_size : Integer = 0; + blue_table_size : Integer = 0; + red_table : ByteP; + green_table : ByteP; + blue_table : ByteP; +implementation + +uses dialogsx; + +function SecSinceMidnightFloat (lStr: string): double; +var + lNumStr: string; + sec: double; + i,len,dec: integer; +begin + result := 0;//error + + if lStr = '' then + exit; + len := length(lStr); + lNumStr := ''; + for i := 1 to len do begin + if (lStr[i] = '.') or (lStr[i] = ',') then + lStr[i] := DecimalSeparator; //make native format, e.g. in Germany 10,123 whereas in USA 10.123 + if lStr[i] in ['0'..'9',DecimalSeparator] then + lNumStr := lNumStr + lStr[i]; + end; + if lNumStr = '' then + exit; + + //make sure 6 characters before decimal, in case HHMMSS is written HMMSS + dec := length(lNumStr) + 1; + for i := length(lNumStr) downto 1 do + if lNumStr[i] = DecimalSeparator then + dec := i; + if dec > 7 then + exit; //HHMMSS.??? can only have 6 digits before decimal + while dec < 7 do begin + lNumStr := '0'+lNumStr; + inc(dec); + end; + //now in HHMMSS.????? format + len := length(lNumStr); + lStr := lNumStr[1]+lNumStr[2]; //HH + sec := 60 * 60 * strtoint(lStr); //60m/h, 60s/m + lStr := lNumStr[3]+lNumStr[4]; //MM + sec := sec + ( 60 * strtoint(lStr)); //60s/m 1000ms/s + lStr := ''; + for i := 5 to len do //SS.SSSS + lStr := lStr + lNumStr[i]; + sec := sec + ( strtofloat(lStr)); //60s/m 1000ms/s + result := sec; +end; + +function AddIndent(lIndent: integer): string; +var + i: integer; +begin + result := ''; + if lIndent < 1 then + exit; + //for i := 1 to lIndent do + result := result +'|'; +end; + +procedure read_ecat_data(var lDICOMdata: DICOMdata;lVerboseRead,lReadECAToffsetTables:boolean; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 121,539; +const + kMaxnSLices = 6000; + kStrSz = 40; +var + lLongRA: LongIntp; + lECAT7sigUpcase,lECAT7sig : array [0..6] of Char; + lParse,lSPos,lFPos{,lScomplement},lF,lS,lYear,lFrames,lVox,lHlfVox,lJ,lPass,lVolume,lNextDirectory,lSlice,lSliceSz,lVoxelType,lPos,lEntry, + lSlicePos,lLongRApos,lLongRAsz,{lSingleRApos,lSingleRAsz,}{lMatri,}lX,lY,lZ,lCacheSz,lImgSz,lSubHeadStart,lMatrixStart,lMatrixEnd,lInt,lInt2,lInt3,lINt4,n,filesz: LongInt; + lPlanes,lGates,lAqcType,lFileType: word; + lXmm,lYmm,lZmm,lCalibrationFactor, lQuantScale: real; + FP: file; + lCreateTable,lSwapBytes,lMR,lECAT6: boolean; +function xWord(lPos: longint): word; +var +s: word; +begin + seek(fp,lPos); + BlockRead(fp, s, 2, n); + if lSwapBytes then + result := swap(s) + else result := s; //assign address of s to inguy +end; + +function swap32i(lPos: longint): Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + if not lSwapBytes then begin + result := inguy^.long; + exit; + end; + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap32i:=outguy.Long; +end; +function StrRead (lPos, lSz: longint) : string; +var + I: integer; + tx : array [1..kStrSz] of Char; +begin + result := ''; + if lSz > kStrSz then exit; + seek(fp, lPos{-1}); + BlockRead(fp, tx, lSz*SizeOf(Char), n); + for I := 1 to (lSz-1) do begin + if tx[I] in [' ','[',']','+','-','.','\','~','/', '0'..'9','a'..'z','A'..'Z'] then + {if (tx[I] <> kCR) and (tx[I] <> UNIXeoln) then} + result := result + tx[I]; + end; +end; +function fswap4r (lPos: longint): single; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(float:single); + end; + swaptypep = ^swaptype; +var + s:single; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + if not lSwapBytes then begin + BlockRead(fp, result, 4, n); + exit; + end; + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + fswap4r:=outguy.float; +end; +function fvax4r (lPos: longint): single; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(float:single); + end; + swaptypep = ^swaptype; +var + s:single; + lT1,lT2 : word; + inguy:swaptypep; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; + if (inguy^.Word1 =0) and (inguy^.Word2 = 0) then begin + result := 0; + exit; + end; + lT1 := inguy^.Word1 and $80FF; + lT2 := ((inguy^.Word1 and $7F00) +$FF00) and $7F00; + inguy^.Word1 := inguy^.Word2; + inguy^.Word2 := (lt1+lT2); + fvax4r:=inguy^.float; +end; +begin + Clear_Dicom_Data(lDicomData); + if gECATJPEG_table_entries <> 0 then begin + freemem (gECATJPEG_pos_table); + freemem (gECATJPEG_size_table); + gECATJPEG_table_entries := 0; + end; + lHdrOK:= false; + lQuantScale:= 1; + lCalibrationFactor := 1; + lLongRASz := 0; + lLongRAPos := 0; + lImageFormatOK := false; + lVolume := 1; + if not fileexists(lFileName) then begin + Msg('Unable to find the image '+lFileName); + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + if filesz < (2048) then begin + Msg('This file is to small to be a ECAT format image.'); + goto 539; + end; + seek(fp, 0); + BlockRead(fp, lECAT7Sig, 6*SizeOf(Char){, n}); + for lInt4 := 0 to (5) do begin + if lECAT7Sig[lInt4] in ['a'..'z','A'..'Z'] then + lECAT7SigUpCase[lInt4] := upcase(lECAT7Sig[lInt4]) + else + lECAT7SigUpCase[lInt4] := ' '; + end; + if (lECAT7SigUpCase[0]='M') and (lECAT7SigUpCase[1]='A') and (lECAT7SigUpCase[2]='T') and (lECAT7SigUpCase[3]='R') and + (lECAT7SigUpCase[4]='I') and (lECAT7SigUpCase[5]='X') then + lECAT6 := false + else + lECAT6 := true; + if lEcat6 then begin + lSwapBytes := false; + lFileType := xWord(27*2); + if lFileType > 255 then lSwapBytes := not lSwapBytes; + lFileType := xWord(27*2); + lAqcType := xWord(175*2); + lPlanes := xWord(188*2); + lFrames := xword(189*2); + lGates := xWord(190*2); + lYear := xWord(70); + if (lPlanes < 1) or (lFrames < 1) or (lGates < 1) then begin + case MsgDlg('Warning: one of the planes/frames/gates values is less than 1 ['+inttostr(lPlanes)+'/'+inttostr(lFrames)+'/'+inttostr(lGates)+']. Is this file really ECAT 6 format? Press abort to cancel conversion. ', + mterror,[mbOK,mbAbort], 0) of + mrAbort: goto 539; + end; //case + end else if (lYear < 1940) or (lYear > 3000) then begin + case MsgDlg('Warning: the year value appears invalid ['+inttostr(lYear)+']. Is this file really ECAT 6 format? Press abort to cancel conversion. ', + mterror,[mbOK,mbAbort], 0) of + mrAbort: goto 539; + end; //case + end; + if lVerboseRead then begin + lDynStr :='ECAT6 data'; + lDynStr :=lDynStr+kCR+('Patient Name:'+StrRead(190,32)); + lDynStr :=lDynStr+kCR+('Patient ID:'+StrRead(174,16)); + lDynStr :=lDynStr+kCR+('Study Desc:'+StrRead(318,32)); + lDynStr := lDynStr+kCR+('Facility: '+StrRead(356,20)); + lDynStr := lDynStr+kCR+('Planes: '+inttostr(lPlanes)); + lDynStr := lDynStr+kCR+('Frames: '+inttostr(lFrames)); + lDynStr := lDynStr+kCR+('Gates: '+inttostr(lGates)); + lDynStr := lDynStr+kCR+('Date DD/MM/YY: '+ inttostr(xWord(66))+'/'+inttostr(xWord(68))+'/'+inttostr(lYear)); + end; {show summary} + end else begin //NOT ECAT6 + lSwapBytes := true; + lFileType := xWord(50); + if lFileType > 255 then lSwapBytes := not lSwapBytes; + lFileType := xWord(50); + lAqcType := xWord(328); + lPlanes := xWord(352); + lFrames := xWord(354); + lGates := xWord(356); + lCalibrationFactor := fswap4r(144); + if {(true) or} (lPlanes < 1) or (lFrames < 1) or (lGates < 1) then begin + case MsgDlg('Warning: on of the planes/frames/gates values is less than 1 ['+inttostr(lPlanes)+'/'+inttostr(lFrames)+'/'+inttostr(lGates)+']. Is this file really ECAT 7 format? Press abort to cancel conversion. ', + mterror,[mbOK,mbAbort], 0) of + mrAbort: goto 539; + end; //case + end; //error + if lVerboseRead then begin + lDynStr := 'ECAT 7 format'; + lDynStr := lDynStr+kCR+('Serial Number:'+StrRead(52,10)); + lDynStr := lDynStr+kCR+('Patient Name:'+StrRead(182,32)); + lDynStr := lDynStr+kCR+('Patient ID:'+StrRead(166,16)); + lDynStr := lDynStr+kCR+('Study Desc:'+StrRead(296,32)); + lDynStr := lDynStr+kCR+('Facility: '+StrRead(332,20)); + lDynStr := lDynStr+kCR+('Scanner: '+inttostr(xWord(48))); + lDynStr := lDynStr+kCR+('Planes: '+inttostr(lPlanes)); + lDynStr := lDynStr+kCR+('Frames: '+inttostr(lFrames)); + lDynStr := lDynStr+kCR+('Gates: '+inttostr(lGates)); + lDynStr := lDynStr+kCR+'Calibration: '+floattostr(lCalibrationFactor); + end; {lShow Summary} + end; //lECAT7 +if lFiletype = 9 then lFiletype := 7; //1364: treat projections as Volume16's +if not (lFileType in [1,2,3,4,7]) then begin + Msg('This software does not recognize the ECAT file type. Selected filetype: '+inttostr(lFileType)); + goto 539; +end; +lVoxelType := 2; +if lFileType = 3 then lVoxelType := 4; +if lVerboseRead then begin + case lFileType of + 1: lDynStr := lDynStr+kCR+('File type: Scan File'); + 2: lDynStr := lDynStr+kCR+('File type: Image File'); //x + 3: lDynStr := lDynStr+kCR+('File type: Attn File'); + 4: lDynStr := lDynStr+kCR+('File type: Norm File'); + 7: lDynStr := lDynStr+kCR+('File type: Volume 16'); //x + end; //lfiletye case + case lAqcType of + 1:lDynStr := lDynStr+kCR+('Acquisition type: Blank'); + 2:lDynStr := lDynStr+kCR+('Acquisition type: Transmission'); + 3:lDynStr := lDynStr+kCR+('Acquisition type: Static Emission'); + 4:lDynStr := lDynStr+kCR+('Acquisition type: Dynamic Emission'); + 5:lDynStr := lDynStr+kCR+('Acquisition type: Gated Emission'); + 6:lDynStr := lDynStr+kCR+('Acquisition type: Transmission Rect'); + 7:lDynStr := lDynStr+kCR+('Acquisition type: Emission Rect'); + 8:lDynStr := lDynStr+kCR+('Acquisition type: Whole Body Transm'); + 9:lDynStr := lDynStr+kCR+('Acquisition type: Whole Body Static'); + else lDynStr := lDynStr+kCR+('Acquisition type: Undefined'); + end; //case AqcType +end; //verbose read +if ((lECAT6) and (lFiletype =2)) or ({(not lECAT6) and} (lFileType=7)) then //Kludge +else begin + Msg('Unusual ECAT filetype. Please contact the author.'); + goto 539; +end; +lHdrOK:= true; +lImageFormatOK := true; +lLongRASz := kMaxnSlices * sizeof(longint); +getmem(lLongRA,lLongRAsz); +lPos := 512; +//lSingleRASz := kMaxnSlices * sizeof(single); +//getmem(lSingleRA,lSingleRAsz); +//lMatri := 0; +lVolume := 1; +lPass := 0; +121: + lEntry := 1; + lInt := swap32i(lPos); + lInt2 := swap32i(lPos+4); + lNextDirectory := lInt2; + while true do begin + inc(lEntry); + lPos := lPos + 16; + lInt := swap32i(lPos); + lInt2 := swap32i(lPos+4); + lInt3 := swap32i(lPos+8); + lInt4 := swap32i(lPos+12); + lInt2 := lInt2 - 1; + lSubHeadStart := lINt2 *512; + lMatrixStart := ((lInt2) * 512)+512 {add subhead sz}; + lMatrixEnd := lInt3 * 512; + if (lInt4 = 1) and (lMatrixStart < FileSz) and (lMatrixEnd <= FileSz) then begin + if (lFileType= 7) {or (lFileType = 4) } or (lFileType = 2) then begin //Volume of 16-bit integers + if lEcat6 then begin + lX := xWord(lSubHeadStart+(66*2)); + lY := xWord(lSubHeadStart+(67*2)); + lZ := 1;//uxWord(lSubHeadStart+8); + lXmm := 10*fvax4r(lSubHeadStart+(92*2));// fswap4r(lSubHeadStart+(92*2)); + lYmm := lXmm;//read32r(lSubHeadStart+(94*2)); + lZmm := 10 * fvax4r(lSubHeadStart+(94*2)); + lCalibrationFactor := fvax4r(lSubHeadStart+(194*2)); + lQuantScale := fvax4r(lSubHeadStart+(86*2)); + if lVerboseRead then + lDynStr := lDynStr+kCR+'Plane '+inttostr(lPass+1)+' Calibration/Scale Factor: '+floattostr(lCalibrationFactor)+'/'+floattostr(lQuantScale); + end else begin + //02 or 07 + lX := xWord(lSubHeadStart+4); + lY := xWord(lSubHeadStart+6); + lZ := xWord(lSubHeadStart+8); + //if lFileType <> 4 then begin + lXmm := 10*fswap4r(lSubHeadStart+34); + lYmm := 10*fswap4r(lSubHeadStart+38); + lZmm := 10*fswap4r(lSubHeadStart+42); + lQuantScale := fswap4r(lSubHeadStart+26); + if lVerboseRead then + lDynStr := lDynStr+kCR+'Volume: '+inttostr(lPass+1)+' Scale Factor: '+floattostr(lQuantScale); + //end; //filetype <> 4 + end; //ecat7 + if true then begin + //FileMode := 2; //set to read/write + inc(lPass); + lImgSz := lX * lY * lZ * lVoxelType; {2 bytes per voxel} + lSliceSz := lX * lY * lVoxelType; + if lZ < 1 then begin + lHdrOK := false; + goto 539; + end; + lSlicePos := lMatrixStart; + if ((lECAT6) and (lPass = 1)) or ( (not lECAT6)) then begin + lDICOMdata.XYZdim[1] := lX; + lDICOMdata.XYZdim[2] := lY; + lDICOMdata.XYZdim[3] := lZ; + lDICOMdata.XYZmm[1] := lXmm; + lDICOMdata.XYZmm[2] := lYmm; + lDICOMdata.XYZmm[3] := lZmm; + case lVoxelType of + 1: begin + Msg('Error: 8-bit data not supported [yet]. Please contact the author.'); + lDicomData.Allocbits_per_pixel := 8; + lHdrOK := false; + goto 539; + end; + 4: begin + Msg('Error: 32-bit data not supported [yet]. Please contact the author.'); + lHdrOK := false; + goto 539; + end; + else begin //16-bit integers + lDicomData.Allocbits_per_pixel := 16; + end; + end; {case lVoxelType} + end else begin //if lECAT6 + if (lDICOMdata.XYZdim[1] <> lX) or (lDICOMdata.XYZdim[2] <> lY) or (lDICOMdata.XYZdim[3] <> lZ) then begin + Msg('Error: different slices in this volume have different slice sizes. Please contact the author.'); + lHdrOK := false; + goto 539; + end; //dimensions have changed + //lSlicePos :=((lMatri-1)*lImgSz); + end; //ECAT6 + lVox := lSliceSz div 2; + lHlfVox := lSliceSz div 4; + for lSlice := 1 to lZ do begin + if (not lECAT6) then + lSlicePos := ((lSlice-1)*lSliceSz)+lMatrixStart; + if lLongRAPos >= kMaxnSLices then begin + lHdrOK := false; + goto 539; + end; + inc(lLongRAPos); + lLongRA^[lLongRAPos] := lSlicePos; + {inc(lSingleRAPos); + if lCalibTableType = 1 then + lSingleRA[lSingleRAPos] := lQuantScale + else + lSingleRA[lSingleRAPos] := lCalibrationFactor *lQuantScale;} + + end; //slice 1..lZ + if not lECAT6 then inc(lVolume); + end; //fileexistsex + end; //correct filetype + end; //matrix start/end within filesz + if (lMatrixStart > FileSz) or (lMatrixEnd >= FileSz) then goto 539; + if ((lEntry mod 32) = 0) then begin + if ((lNextDirectory-1)*512) <= lPos then goto 539; //no more directories + lPos := (lNextDirectory-1)*512; + goto 121; + end; //entry 32 + end ; //while true +539: + CloseFile(fp); + FileMode := 2; //set to read/write + lDicomData.XYZdim[3] := lLongRApos; + if not lECAT6 then dec(lVolume); //ECAT7 increments immediately before exiting loop - once too often + lDicomData.XYZdim[4] :=(lVolume); + if lSwapBytes then + lDicomData.little_endian := 0 + else + lDicomData.little_endian := 1; + if (lLongRApos > 0) and (lHdrOK) then begin + lDicomData.ImageStart := lLongRA^[1]; + lCreateTable := false; + if (lLongRApos > 1) then begin + lFPos := lDICOMdata.ImageStart; + for lS := 2 to lLongRApos do begin + lFPos := lFPos + lSliceSz; + if lFPos <> lLongRA^[lS] then lCreateTable := true; + end; + if (lCreateTable) and (lReadECAToffsetTables) then begin + gECATJPEG_table_entries := lLongRApos; + getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint)); + getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint)); + for lS := 1 to gECATJPEG_table_entries do + gECATJPEG_pos_table^[lS] := lLongRA^[lS] + end else if (lCreateTable) then + lImageFormatOK := false; //slices are offset within this file + end; + if (lVerboseRead) and (lHdrOK) then begin + lDynStr :=lDynStr+kCR+('XYZdim:'+inttostr(lX)+'/'+inttostr(lY)+'/'+inttostr(gECATJPEG_table_entries)); + lDynStr :=lDynStr+kCR+('XYZmm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,7,7)+'/'+floattostrf(lDicomData.XYZmm[2],ffFixed,7,7) + +'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,7,7)); + //xlDynStr :=lDynStr+kCR+('Bits per voxel: '+inttostr(lDicomData.Storedbits_per_pixel)); + lDynStr :=lDynStr+kCR+('Image Start: '+inttostr(lDicomData.ImageStart)); + if lCreateTable then + lDynStr :=lDynStr+kCR+('Note: staggered slice offsets'); + end + end; + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + if lLongRASz > 0 then + freemem(lLongRA); + (*if (lSingleRApos > 0) and (lHdrOK) and (lCalibTableType <> 0) then begin + gECAT_scalefactor_entries := lSingleRApos; + getmem (gECAT_scalefactor_table, gECAT_scalefactor_entries*sizeof(single)); + for lS := 1 to gECAT_scalefactor_entries do + gECAT_scalefactor_table[lS] := lSingleRA[lS]; + end; + if lSingleRASz > 0 then + freemem(lSingleRA);*) +end; + +(*procedure write_slc (lFileName: string; var pDICOMdata: DICOMdata;var lSz: integer; lDICOM3: boolean); +const kMaxRA = 41; + lXra: array [1..kMaxRA] of byte = (7,8,9,21,22,26,27, + 35,36,44,45, + 50,62,66,78, + 81,95, + 97,103,104,105,106,111, + 113,123,127, + 129,139,142, + 146,147,148,149,155,156,157, + 166,167,168,169,170); +var + fp: file; + lX,lClr,lPos,lRApos: integer; + lP: bytep; +procedure WriteString(lStr: string; lCR: boolean); +var + n,lStrLen : Integer; +begin + lStrLen := length(lStr); + for n := 1 to lstrlen do begin + lPos := lPos + 1; + lP[lPos] := ord(lStr[n]); + end; + if lCR then begin + lPos := lPos + 1; + lP[lPos] := ord(kCR); + end; +end; + +begin + lSz := 0; + getmem(lP,2048); + lPos := 0; + WriteString('11111',true); + WriteString(inttostr(pDicomData.XYZdim[1])+' '+inttostr(pDicomData.XYZdim[2])+' '+inttostr(pDicomData.XYZdim[3])+' 8',true); + WriteString(floattostrf(pDicomData.XYZmm[1],ffFixed,7,7)+' '+floattostrf(pDicomData.XYZmm[2],ffFixed,7,7)+' '+floattostrf(pDicomData.XYZmm[3],ffFixed,7,7),true); + WriteString('1 1 0 0',true); //mmunits,MR,original,nocompress + WriteString('16 12 X',false); //icon is 8x8 grid, so 64 bytes for red,green blue + for lClr := 1 to 3 do begin + lRApos := 1; + for lX := 1 to 192 do begin + inc(lPos); + if (lRApos <= kMaxRA) and (lX = lXra[lRApos]) then begin + inc(lRApos); + lP[lPos] := 200; + end else + lP[lPos] := 0; + end; {icongrid 1..192} + end; {RGB} + if lFileName <> '' then begin + AssignFile(fp, lFileName); + Rewrite(fp, 1); + blockwrite(fp,lP^,lPos); + close(fp); + end; + freemem(lP); + lSz := lPos; +end;*) +procedure read_interfile_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +label 333; +const UNIXeoln = chr(10); +var lTmpStr, +lInStr,lUpCaseStr: string; +lHdrEnd,lFloat,lUnsigned: boolean; +lPos,lLen,FileSz,linPos: integer; +fp: file; +lCharRA: bytep; +function readInterFloat:real; +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) and (lInStr[lPos] <> ';') do begin + if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; + try + result := strtofloat(lStr); + except + on EConvertError do begin + Msg('Unable to convert the string '+lStr+' to a number'); + result := 1; + exit; + end; + end; {except} + end; +function readInterStr:string; +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) and (lInStr[lPos] = ' ') do begin + inc(lPos); + end; + While (lPos <= lLen) and (lInStr[lPos] <> ';') do begin + if lInStr[lPos] <> ' ' then //1.39 build 6 + lStr := lStr+upcase(linStr[lPos]); //zebra upcase + inc(lPos); + end; + result := lStr; +end; //interstr func +begin + lHdrOK := false; + lFloat := false; + lUnsigned := false; + lImageFormatOK := true; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + lHdrEnd := false; + //lDicomData.ImageStart := FileSz; + GetMem( lCharRA, FileSz+1 ); + BlockRead(fp, lCharRA^, FileSz, linpos); + if lInPos <> FileSz then Msg('Disk error: Unable to read full input file.'); + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write +repeat + linstr := ''; + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + While (lPos <= lLen) and (lInStr[lPos] <> ';') and (lInStr[lPos] <> '=') and (lUpCaseStr <>'INTERFILE') do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; + inc(lPos); {read equal sign in := statement} + if lUpCaseStr ='INTERFILE' then begin + lHdrOK := true; + lDicomData.little_endian := 0; + end; + if lUpCaseStr ='DATASTARTINGBLOCK'then lDicomData.ImageStart := 2048 * round(readInterFloat); + if lUpCaseStr ='DATAOFFSETINBYTES'then lDicomData.ImageStart := round(readInterFloat); + if (lUpCaseStr ='MATRIXSIZE[1]') or (lUpCaseStr ='MATRIXSIZE[X]') then lDicomData.XYZdim[1] := round(readInterFloat); + if (lUpCaseStr ='MATRIXSIZE[2]')or (lUpCaseStr ='MATRIXSIZE[Y]')then lDicomData.XYZdim[2] := round(readInterFloat); + if (lUpCaseStr ='MATRIXSIZE[3]')or (lUpCaseStr ='MATRIXSIZE[Z]') or (lUpCaseStr ='NUMBEROFSLICES') or (lUpCaseStr ='TOTALNUMBEROFIMAGES') then begin + lDicomData.XYZdim[3] := round(readInterFloat); + end; + if lUpCaseStr ='IMAGEDATABYTEORDER' then begin + if readInterStr = 'LITTLEENDIAN' then lDicomData.little_endian := 1; + end; + if lUpCaseStr ='NUMBERFORMAT' then begin + lTmpStr := readInterStr; + if (lTmpStr = 'ASCII') or (lTmpStr='BIT') then begin + lHdrOK := false; + Msg('This software can not convert '+lTmpStr+' data type.'); + goto 333; + end; + if lTmpStr = 'UNSIGNEDINTEGER' then lUnsigned := true; + if (lTmpStr='FLOAT') or (lTmpStr='SHORTFLOAT') or (lTmpStr='LONGFLOAT') then begin //1395 + lFloat := true; + end; + end; + if lUpCaseStr ='NAMEOFDATAFILE' then lFileName := ExtractFilePath(lFileName)+readInterStr; + if lUpCaseStr ='NUMBEROFBYTESPERPIXEL' then + lDicomData.Allocbits_per_pixel := round(readInterFloat)*8; + if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[1]') or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[X]') then + lDicomData.XYZmm[1] := (readInterFloat); + if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[2]') or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[Y]')then lDicomData.XYZmm[2] := (readInterFloat); + if (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[3]')or (lUpCaseStr ='SCALINGFACTOR(MM/PIXEL)[Z]')or (lUpCaseStr ='SLICETHICKNESS')then lDicomData.XYZmm[3] := (readInterFloat); + if (lUpCaseStr ='ENDOFINTERFILE') then lHdrEnd := true; + if not lHdrOK then goto 333; + if lInStr <> '' then + lDynStr := lDynStr + lInStr+kCr; + lHdrOK := true; +until (linPos >= FileSz) or (lHdrEnd){EOF(fp)}; +//xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; +lImageFormatOK := true; +if (not lFLoat) and (lUnsigned) and ((lDicomData.Allocbits_per_pixel = 16)) then begin + Msg('Warning: this Interfile image uses UNSIGNED 16-bit data [values 0..65535]. Analyze specifies SIGNED 16-bit data [-32768..32767]. Some images may not transfer well. [Future versions of MRIcro should fix this].'); + lImageFormatOK := false; +end else if (not lFLoat) and (lDicomData.Allocbits_per_pixel > 16) then begin + Msg('WARNING: The image '+lFileName+' is a '+inttostr(lDicomData.Allocbits_per_pixel)+'-bit integer data type. This software may display this as SIGNED data. Bits per voxel: '+inttostr(lDicomData.Allocbits_per_pixel)); + lImageFormatOK := false; +end else if (lFloat) then begin //zebra change float check + //Msg('WARNING: The image '+lFileName+' uses floating point [real] numbers. The current software can only read integer data type Interfile images.'); + lDicomData.FloatData := true; + //lImageFormatOK := false; +end; +333: +FreeMem( lCharRA); +end; //interfile + + + +//afni start +function ParseFileName (lFilewExt:String): string; +var + lLen,lInc: integer; + lName: String; +begin + lName := ''; + lLen := length(lFilewExt); + lInc := lLen+1; + if lLen > 0 then + repeat + dec(lInc); + until (lFileWExt[lInc] = '.') or (lInc = 1); + if lInc > 1 then + for lLen := 1 to (lInc - 1) do + lName := lName + lFileWExt[lLen] + else + lName := lFilewExt; //no extension + ParseFileName := lName; +end; + +procedure read_afni_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lRotation1,lRotation2,lRotation3: integer); +//label 333; +const UNIXeoln = chr(10); +kTab = ord(chr(9)); +kSpace = ord(' '); +var lTmpStr,lInStr,lUpCaseStr: string; +lHdrEnd: boolean; +lMSBch: char; +lOri : array [1..4] of single; +lTmpInt,lPos,lLen,FileSz,linPos: integer; +fp: file; +lCharRA: bytep; +procedure readAFNIeoln; +begin + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do + inc(linPos); + inc(lInPos); //read EOLN +end; +function readAFNIFloat:real; +var lStr: string; +lCh:char; +begin + lStr := ''; + while (linPos < FileSz) and ((lStr='') or ((lCharRA^[lInPos] <> kTab) and (lCharRA^[lInPos] <> kSpace))) do begin + lCh:= chr(lCharRA^[linPos]); + if lCh in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+lCh; + inc(linPos); + end; + if lStr = '' then exit; + try + result := strtofloat(lStr); + except + on EConvertError do begin + Msg('Unable to convert the string '+lStr+' to a number'); + result := 1; + exit; + end; + end; {except} + end; +begin + lHdrOK := false; + lImageFormatOK := true; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + lTmpStr := string(StrUpper(PChar(ExtractFileExt(lFileName)))); + if lTmpStr <> '.HEAD' then exit; + for lInPos := 1 to 3 do + lOri[lInPos] := -6666; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + lHdrEnd := false; + //lDicomData.ImageStart := FileSz; + GetMem( lCharRA, FileSz+1 ); + BlockRead(fp, lCharRA^, FileSz, linpos); + if lInPos <> FileSz then Msg('Disk error: Unable to read full input file.'); + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write +repeat + linstr := ''; + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + While (lPos <= lLen) do begin + if lInStr[lPos] in ['_','[',']','(',')','/','+','-','=',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; + inc(lPos); {read equal sign in := statement} + if lUpCaseStr ='NAME=DATASET_DIMENSIONS'then begin + lImageFormatOK := true; + lHdrOK := true; + lFileName := parsefilename(lFilename)+'.BRIK'; //always UPPERcase + readAFNIeoln; + lDICOMdata.XYZdim[1] := round(readAFNIFloat); + lDICOMdata.XYZdim[2] := round(readAFNIFloat); + lDICOMdata.XYZdim[3] := round(readAFNIFloat); + //lDicomData.ImageStart := 2048 * round(readInterFloat); + end; + if lUpCaseStr ='NAME=BRICK_FLOAT_FACS'then begin + readAFNIeoln; + lDICOMdata.IntenScale := readAFNIFloat; //1380 read slope of intensity + end; + if lUpCaseStr ='NAME=DATASET_RANK'then begin + readAFNIeoln; + //2nd value is number of volumes + readAFNIFloat; + lDICOMdata.XYZdim[4] := round(readAFNIFloat); + end; + if lUpCaseStr ='NAME=BRICK_TYPES'then begin + readAFNIeoln; + lTmpInt := round(readAFNIFloat); + case lTmpInt of + 0:lDicomData.Allocbits_per_pixel := 8; + 1:begin + lDicomData.Allocbits_per_pixel := 16; + //lDicomData.MaxIntensity := 65535; //Old AFNI were UNSIGNED, new ones are SIGNED??? + end; + 3:begin + lDicomData.Allocbits_per_pixel := 32; + lDicomData.FloatData := true; + end; + else begin + lHdrEnd := true; + Msg('Unsupported AFNI BRICK_TYPES: '+inttostr(lTmpInt)); + end; + + end; //case + {datatype + 0 = byte (unsigned char; 1 byte) + 1 = short (2 bytes, signed) + 3 = float (4 bytes, assumed to be IEEE format) + 5 = complex (8 bytes: real+imaginary parts)} + end; + if lUpCaseStr ='NAME=BYTEORDER_STRING'then begin + readAFNIeoln; + if ((linPos+2) < FileSz) then begin + lMSBch := chr(lCharRA^[linPos+1]); + if lMSBCh = 'L' then lDicomData.Little_Endian := 1; + if lMSBCh = 'M' then begin + lDicomData.Little_Endian := 0; + end; + linPos := lInPos + 2; + end; + //littleendian + end; + if lUpCaseStr ='NAME=ORIGIN'then begin + readAFNIeoln; + lOri[1] := (abs(readAFNIFloat)); + lOri[2] := (abs(readAFNIFloat)); + lOri[3] := (abs(readAFNIFloat)); + //Xori,YOri,ZOri + end; + if lUpCaseStr ='NAME=DELTA'then begin + readAFNIeoln; + lDICOMdata.XYZmm[1] := abs(readAFNIFloat); + lDICOMdata.XYZmm[2] := abs(readAFNIFloat); + lDICOMdata.XYZmm[3] := abs(readAFNIFloat); + + //Xmm,Ymm,Zmm + end; + if lUpCaseStr ='NAME=ORIENT_SPECIFIC'then begin + readAFNIeoln; + lRotation1 := round(readAFNIFloat); + lRotation2 := round(readAFNIFloat); + lRotation3 := round(readAFNIFloat); + end; //ORIENT_SPECIFIC rotation details + if lInStr <> '' then + lDynStr := lDynStr + lInStr+kCr; +until (linPos >= FileSz) or (lHdrEnd){EOF(fp)}; +//xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; +for lInPos := 1 to 3 do begin + if lOri[lInPos] < -6666 then //value not set + lDICOMdata.XYZori[lInPos] := round((1.0+lDICOMdata.XYZdim[lInPos])/2) + else if lDICOMdata.XYZmm[lInPos] <> 0 then + lDICOMdata.XYZori[lInPos] := round(1.5+lOri[lINPos] / lDICOMdata.XYZmm[lInPos]); +end; +// lDicomData.Float := true; +FreeMem( lCharRA); +end; //interfile +//afni end +//voxbo start +procedure read_voxbo_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +label 333; +const UNIXeoln = chr(10); + kTab = chr(9); +var lTmpStr,lInStr,lUpCaseStr: string; +lFileTypeKnown,lHdrEnd,lFloat: boolean; +lStartPos,lPos,lLen,FileSz,linPos: integer; +fp: file; +lCharRA: bytep; +procedure readVBfloats (var lF1,lF2,lF3: double); +// While (lPos <= lLen) and ((lInStr[lPos] = kTab) or (lInStr[lPos] = ' ')) do begin +// inc(lPos); +var //lDigit : boolean; + n,lItemIndex: integer; + lStr,lfStr: string; +begin + lf1 := 1; + lf2 := 1; + lf3 := 1; + n := 0; + for lItemIndex := 1 to 3 do begin + inc(n); + While (lPos <= lLen) and ((lInStr[lPos] = kTab) or (lInStr[lPos] = ' ')) do + inc(lPos); + if lPos > lLen then + exit; + lStr := ''; + repeat + lStr := lStr+upcase(linStr[lPos]); + inc(lPos); + until (lPos > lLen) or (lInStr[lPos] = kTab) or (lInStr[lPos] = ' '); + if lStr <> '' then begin //string to convert + try + case n of + 1: lF1 := strtofloat(lStr); + 2: lF2 := strtofloat(lStr); + 3: lF3 := strtofloat(lStr); + end; + except + on EConvertError do begin + Msg('Unable to convert the string '+lfStr+' to a real number'); + exit; + end; + end; {except} + end; //if string to convert + end; +end; + +procedure readVBints (var lI1,lI2,lI3: integer); +var lF1,lF2,lF3: double; +begin + readVBfloats (lF1,lF2,lF3); + lI1 := round(lF1); + lI2 := round(lF2); + lI3 := round(lF3); +end; +function readVBStr:string; +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) and ((lInStr[lPos] = kTab) or (lInStr[lPos] = ' ')) do begin + inc(lPos); + end; + While (lPos <= lLen) {and (lInStr[lPos] <> ';')} do begin + lStr := lStr+upcase(linStr[lPos]); //zebra upcase + inc(lPos); + end; + result := lStr; +end; //interstr func +begin + lHdrOK := false; + lFloat := false; + lImageFormatOK := true; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + lHdrEnd := false; + //lDicomData.ImageStart := FileSz; + GetMem( lCharRA, FileSz+1 ); + BlockRead(fp, lCharRA^, FileSz, linpos); + if lInPos <> FileSz then Msg('Disk error: Unable to read full input file.'); + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write + lFileTypeKnown := false; +repeat + linstr := ''; + + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + While (lPos <= lLen) and (lInStr[lPos] <> ':') do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-', '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; + inc(lPos); {read equal sign in := statement} + if (lHdrOK) and (not lFileTypeKnown) and (lUpCaseStr = 'CUB1') then + lFileTypeKnown := true; + if (lHdrOK) and (not lFileTypeKnown) then begin + Msg('This software can not read this kind of VoxBo image. (Type:"'+lUpCaseStr+'")'); + lHdrEnd := true; + lHdrOK := false; + end; + if (not lHdrOK) and (lUpCaseStr ='VB98') then begin + lDicomData.little_endian := 0;//all VoxBo files are Big Endian! + lStartPos := linPos; + lFileTypeKnown := true; //test for While Loop + while (linPos < FileSz) and lFileTypeKnown do begin + if (lCharRA^[linPos-1] = $0C) and (lCharRA^[linPos] = $0A) then begin + lFileTypeKnown := false; + lDicomData.ImageStart := linPos; + FileSz := linPos; //size of VoxBo header + end; + inc(linPos); + end; + if lFileTypeKnown then begin //end of file character not found: abort! + Msg('Unable to find the end of the VoxBo header.'); + lHdrEnd := true + end else + lHdrOK := true; + linPos := lStartPos; //now that we have found the header size, we can start from the beginning of the header + end; + if not lHdrOK then lHdrEnd := true; + if (lUpCaseStr ='BYTEORDER') and (readVBStr = 'LSBFIRST') then + lDicomData.little_endian := 1; + if lUpCaseStr ='DATATYPE'then begin + lTmpStr := readVBStr; + if lTmpStr = 'Byte' then + lDicomData.Allocbits_per_pixel := 8 + else if (lTmpStr = 'INTEGER') or (lTmpStr = 'INT16') then + lDicomData.Allocbits_per_pixel := 16 + else if (lTmpStr = 'LONG') or (lTmpStr = 'INT32') then + lDicomData.Allocbits_per_pixel := 32 + else if (lTmpStr = 'FLOAT') then begin + lFloat := true; + lDicomData.Allocbits_per_pixel := 32; + end else if (lTmpStr = 'DOUBLE') then begin + lFloat := true; + lDicomData.Allocbits_per_pixel := 64; + end else begin + Msg('Unknown VoxBo data format: '+lTmpStr); + end; + end; + if lUpCaseStr ='VOXDIMS(XYZ)'then readVBints(lDicomData.XYZdim[1],lDicomData.XYZdim[2],lDicomData.XYZdim[3]); + if (lUpCaseStr ='VOXSIZES(XYZ)') then readVBfloats(lDicomData.XYZmm[1],lDicomData.XYZmm[2],lDicomData.XYZmm[3]); + if (lUpCaseStr ='ORIGIN(XYZ)')then begin + readVBints(lDicomData.XYZori[1],lDicomData.XYZori[2],lDicomData.XYZori[3]); + inc(lDicomData.XYZori[1]);//1393 + inc(lDicomData.XYZori[2]);//1393 + inc(lDicomData.XYZori[3]);//1393 + end; + if not lHdrOK then goto 333; + if lInStr <> '' then + lDynStr := lDynStr + lInStr+kCr; +until (linPos >= FileSz) or (lHdrEnd){EOF(fp)}; +//xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; +//xlDicomData.Rotate180deg := true; +lImageFormatOK := true; +if (lFloat) then begin //zebra change float check + lDicomData.FloatData := true; + //lImageFormatOK := false; +end; +333: +FreeMem( lCharRA); +end; +//voxbo end + +procedure read_vff_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string); +label 333; +const UNIXeoln = chr(10); +var lInStr,lUpCaseStr: string; +//lHdrEnd: boolean; +lPos,lLen,FileSz,linPos: integer; +lDummy1,lDummy2,lDummy3 : double; +fp: file; +lCharRA: bytep; +procedure readVFFvals (var lFloat1,lFloat2,lFloat3: double); +var lStr: string; + lDouble: DOuble; + lInc: integer; +begin + for lInc := 1 to 3 do begin + lStr := ''; + While (lPos <= lLen) and (lInStr[lPos] = ' ') do begin + inc(lPos); + end; + While (lPos <= lLen) and (lInStr[lPos] <> ';') and (lInStr[lPos] <> ' ') do begin + if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; + if lStr <> '' then begin + try + lDouble := strtofloat(lStr); + except + on EConvertError do begin + Msg('Unable to convert the string '+lStr+' to a number'); + exit; + end; + end; {except} + case lInc of + 2: lFloat2 := lDouble; + 3: lFloat3 := lDouble; + else lFloat1 := lDouble; + end; + end; //lStr <> '' + end; //lInc 1..3 +end; //interstr func +begin + lHdrOK := false; + lImageFormatOK := true; + Clear_Dicom_Data(lDicomData); + lDicomData.little_endian := 0; //big-endian + lDynStr := ''; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FileSz := FileSize(fp); + if FileSz > 2047 then FileSz := 2047; + GetMem( lCharRA, FileSz+1 ); + BlockRead(fp, lCharRA^, FileSz, linpos); + if lInPos <> FileSz then Msg('Disk error: Unable to read full input file.'); + lInPos := 1; + while (lCharRA^[lInPos] <> 12) and (lInPos < FileSz) do begin + inc(lInPos); + end; + inc(lInPos); + if (lInPos >= FileSz) or (lInPos < 12) then goto 333; //unable to find + lDynStr := lDynStr + 'Sun VFF Volume File Format'+kCr; + lDicomData.ImageStart := lInPos; + FileSz := lInPos-1; + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write +repeat + linstr := ''; + while (linPos < FileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + While (lPos <= lLen) and (lInStr[lPos] <> ';') and (lInStr[lPos] <> '=') and (lUpCaseStr <>'NCAA') do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; + inc(lPos); {read equal sign in := statement} + if lUpCaseStr ='NCAA' then begin + lHdrOK := true; + end; + if lUpCaseStr ='BITS' then begin + lDummy1 := 8; + readVFFvals(lDummy1,lDummy2,lDummy3); + lDicomData.Allocbits_per_pixel := round(lDummy1); + end; + if lUpCaseStr ='SIZE' then begin + lDummy1 := 1; lDummy2 := 1; lDummy3 := 1; + readVFFvals(lDummy1,lDummy2,lDummy3); + lDicomData.XYZdim[1] := round(lDummy1); + lDicomData.XYZdim[2] := round(lDummy2); + lDicomData.XYZdim[3] := round(lDummy3); + end; + if lUpCaseStr ='ASPECT' then begin + lDummy1 := 1; lDummy2 := 1; lDummy3 := 1; + readVFFvals(lDummy1,lDummy2,lDummy3); + lDicomData.XYZmm[1] := (lDummy1); + lDicomData.XYZmm[2] := (lDummy2); + lDicomData.XYZmm[3] := (lDummy3); + end; + if not lHdrOK then goto 333; + if lInStr <> '' then + lDynStr := lDynStr + lInStr+kCr; + //lHdrOK := true; +until (linPos >= FileSz); +//xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; +lImageFormatOK := true; +333: +FreeMem( lCharRA); +end; +//******************************************************************** +(*procedure ShellSortItems (first, last: integer; var lPositionRA, lIndexRA: LongintP; var lRepeatedValues: boolean); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n,t, nn, m, lognb2, l, k, j, i: longint; +begin + lRepeatedValues := false; + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do + begin + m := m div 2; + k := last - m; + for j := 1 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (lIndexRA^[lPositionRA^[l]] = lIndexRA^[lPositionRA^[i]]) then begin + lRepeatedValues := true; + exit; + end; + if (lIndexRA^[lPositionRA^[l]] < lIndexRA^[lPositionRA^[i]]) then begin + //swap values for i and l + t := lPositionRA^[i]; + lPositionRA^[i] := lPositionRA^[l]; + lPositionRA^[l] := t; + i := i - m; + if (i >= 1) then + goto 555; + end + end + end +end; //shellsort is fast and requires less memory than quicksort *) + + +(*procedure PAR2DICOMstudyDate(var lDicomData: DICOMdata); +{input: lDicomData.StudyDate = 2002.12.29 / 19:48:58.0000 +output: StudyDate = YYYYMMDD StudyTime= hhmmss } +var + I: integer; + lStr: string; +begin + if length(lDicomData.StudyDate) < 14 then exit; + lStr := ''; + for I := 1 to length(lDicomData.StudyDate) do + if lDicomData.StudyDate[I] in ['0'..'9'] then + lStr := lStr+ lDicomData.StudyDate[I]; + if length(lStr) < 14 then exit; + lDicomData.StudyDate := ''; + for I := 1 to 8 do + lDicomData.StudyDate := lDicomData.StudyDate+lStr[I]; + lDicomData.StudyTime := ''; + for I := 9 to 14 do + lDicomData.StudyTime := lDicomData.StudyTime+lStr[I]; + lDicomData.PatientIDInt := StudySecSince2K(lDicomData.StudyDate,lDicomData.StudyTime); +end; +type tRange = record + Min,Val,Max: double; //some vals are ints, others floats +end; + +procedure read_PAR_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK:boolean; var lDynStr: string;var lFileName: string; lReadOffsetTables: boolean; var lOffset_pos_table: LongIntp; var lOffsetTableEntries: integer; lReadVaryingScaleFactors: boolean; var lVaryingScaleFactors_table,lVaryingIntercept_table: Singlep; var lVaryingScaleFactorsTableEntries,lnum4Ddatasets: integer); +label 333; //1384 now reads up to 8 dimensional data.... +const UNIXeoln = chr(10); + kMaxnSLices = 32000; + kXdim = 1; + kYdim = 2; + kBitsPerVoxel = 3; + kSliceThick = 4; + kSliceGap = 5; + kXmm = 6; + kYmm = 7; + kSlope = 8; + kIntercept = 9; + kCalibratedSlope = 10; //1393 - attempt to use calibrated values + kDynTime = 11; + kSlice = 12; + kEcho = 13; + kDyn = 14; + kCardiac = 15; + kType = 16; + kSequence = 17; + kIndex = 18; + lIsParVers3x: boolean = true; + lRepeatedValues : boolean = false; + lSlicesNotInSequence: boolean = false; + lMaxSlice : integer = 0; +var + lErrorStr,lInStr,lUpCaseStr,lReportedTRStr: string; + lSliceSequenceRA,lSortedSliceSequence: LongintP; + lSliceIndexRA: array [1..kMaxnSlices] of Longint; + lSliceSlopeRA,lSliceInterceptRA,lCalibratedSliceSlopeRA: array [1..kMaxnSlices] of single; + lSliceHeaderRA: array [1..32] of double; + lRangeRA: array [kXdim..kIndex] of tRange; + lMaxIndex,lSliceSz,lSliceInfoCount,lPos,lLen,lFileSz,lHdrPos,linPos,lInc: LongInt; + fp: file; + lCharRA: bytep; + +procedure MinMaxTRange (var lDimension: tRange; lNewVal: double); //nested +begin + lDimension.Val := lNewVal; + if lSliceInfoCount < 2 then begin + lDimension.Min := lDimension.Val; + lDimension.Max := lDimension.Val; + end; + if lNewVal < lDimension.Min then lDimension.Min := lNewVal; + if lNewVal > lDimension.Max then lDimension.Max := lNewVal; +end; //nested InitTRange proc + +function readParStr:string;//nested +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) do begin + if (lStr <> '') or (linStr[lPos]<>' ') then //strip leading spaces + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; //while lPOs < lLen + result := lStr; +end; //nested func ReadParStr +function readParFloat:double;//nested +var lStr: string; +begin + lStr := ''; + result := 1; + While (lPos <= lLen) and ((lStr='') or(lInStr[lPos] <> ' ')) do begin + if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; + if lStr = '' then exit; + try + result := strtofloat(lStr); + except + on EConvertError do begin + Msg('read_PAR_data: Unable to convert the string '+lStr+' to a number'); + result := 1; + exit; + end; + end; {except} +end; //nested func ReadParFloat +begin + //Initialize parameters + lnum4Ddatasets := 1; + lSliceInfoCount := 0; + for lInc := kXdim to kIndex do //initialize all values: important as PAR3 will not explicitly report all + MinMaxTRange(lRangeRA[lInc],0); + lHdrOK := false; + lImageFormatOK := false; + lIsParVers3x := true; + lOffsetTableEntries := 0; + lVaryingScaleFactorsTableEntries := 0; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + //Read text header to buffer (lCharRA) + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + GetMem( lCharRA, lFileSz+1 ); //note: must free dynamic memory: goto 333 if any error + GetMem (lSliceSequenceRA, kMaxnSLices*sizeof(longint)); //note: must free dynamic memory: goto 333 if any error + BlockRead(fp, lCharRA^, lFileSz, lInpos); + if lInPos <> lFileSz then begin + Msg('read_PAR_data: Disk error, unable to read full input file.'); + goto 333; + end; + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write + //Next: read each line of header file... + repeat //for each line in file.... + linstr := ''; + while (linPos < lFileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + if lLen < 1 then + //ignore blank lines + else if (lInStr[1] = '*') and (not lHdrOK) then //# -> comment + //ignore comment lines prior to start of header + else if (lInStr[1] = '#') and (lHdrOK) then //# -> comment + //ignore comment lines + else if (lInStr[1] = '.') or (not lHdrOK) then begin // GENERAL_INFORMATION section (line starts with '.') + //Note we also read in lines that do not have '.' if we have HdrOK=false, this allows us to detect the DATADESCRIPTIONFILE signature + While (lPos <= lLen) and (lInStr[lPos] <> ':') and ((not lHdrOK) or (lInStr[lPos] <> '#')) do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; //while reading line + inc(lPos); {read equal sign in := statement} + lDynStr := lDynStr + lInStr+kCR; + if (not lHdrOK) and (lUpcaseStr = ('DATADESCRIPTIONFILE')) then begin //1389 PAR file + lHdrOK := true; + lDicomData.little_endian := 1; + end; + + + + if (lUpCaseStr ='REPETITIONTIME[MSEC]') then + lDicomData.TR := round(readParFloat); + if (lUpCaseStr ='MAXNUMBEROFSLICES/LOCATIONS') then + lDicomData.XYZdim[3] := round(readParFloat); + if (lUpCaseStr ='SLICETHICKNESS[MM]') then + MinMaxTRange(lRangeRA[kSliceThick],readParFloat); + if (lUpCaseStr ='SLICEGAP[MM]') then + MinMaxTRange(lRangeRA[kSliceGap],readParFloat); + if lUpCaseStr = 'RECONRESOLUTION(XY)' then begin + MinMaxTRange(lRangeRA[kXdim],readParFloat); + MinMaxTRange(lRangeRA[kYdim],readParFloat); + end; + if lUpCaseStr = 'RECONSTRUCTIONNR' then + lDicomData.AcquNum := round(readParFloat); + if lUpCaseStr = 'ACQUISITIONNR' then + lDicomData.SeriesNum := round(readParFloat); + if lUpCaseStr = 'MAXNUMBEROFDYNAMICS' then begin + lDicomData.XYZdim[4] := round(readParFloat); + end; + if lUpCaseStr = 'EXAMINATIONDATE/TIME' then begin + lDicomData.StudyDate := readParStr; + PAR2DICOMstudyDate(lDicomData); + end; + //if lUpCaseStr = 'PROTOCOLNAME' then + // lDicomData.modality := readParStr; + if lUpCaseStr = 'PATIENTNAME' then + lDicomData.PatientName := readParStr; + if lUpCaseStr ='IMAGEPIXELSIZE[8OR16BITS]' then begin + MinMaxTRange(lRangeRA[kBitsPerVoxel],readParFloat); + end; + if not lHdrOK then begin + Msg('read_PAR_data: Error reading header'); + goto 333; + end; + end else begin //SliceInfo: IMAGE_INFORMATION (line does NOT start with '.' or '#') + inc(lSliceInfoCount); + if (lSliceInfoCount < 2) and (lRangeRA[kBitsPerVoxel].val < 1) then //PARvers3 has imagedepth in general header, only in image header for later versions + lIsParVers3x := false; + for lHdrPos := 1 to 26 do + lSliceHeaderRA[lHdrPos] := readparfloat; + //The next few values are in the same location for both PAR3 and PAR4 + MinMaxTRange(lRangeRA[kSlice], round(lSliceHeaderRA[1])); + MinMaxTRange(lRangeRA[kEcho], round(lSliceHeaderRA[2])); + MinMaxTRange(lRangeRA[kDyn], round(lSliceHeaderRA[3])); + MinMaxTRange(lRangeRA[kCardiac], round(lSliceHeaderRA[4])); + MinMaxTRange(lRangeRA[kType], round(lSliceHeaderRA[5])); + MinMaxTRange(lRangeRA[kSequence], round(lSliceHeaderRA[6])); + MinMaxTRange(lRangeRA[kIndex], round(lSliceHeaderRA[7])); + if lIsParVers3x then begin //Read PAR3 data + MinMaxTRange(lRangeRA[kIntercept], lSliceHeaderRA[8]);; //8=intercept in PAR3 + MinMaxTRange(lRangeRA[kSlope],lSliceHeaderRA[9]); //9=slope in PAR3 + MinMaxTRange(lRangeRA[kCalibratedSlope],lSliceHeaderRA[10]); //10=lcalibrated slope in PAR3 1393 - attempt to use calibrated values + MinMaxTRange(lRangeRA[kXmm],lSliceHeaderRA[23]); //23 PIXEL SPACING X in PAR3 + MinMaxTRange(lRangeRA[kYmm],lSliceHeaderRA[24]); //24 PIXEL SPACING Y IN PAR3 + MinMaxTRange(lRangeRA[kDynTime],(lSliceHeaderRA[26])); //26= dyn_scan_begin_time in PAR3 + end else begin //not PAR: assume PAR4 + for lHdrPos := 27 to 32 do + lSliceHeaderRA[lHdrPos] := readparfloat; + MinMaxTRange(lRangeRA[kBitsPerVoxel],lSliceHeaderRA[8]);//8 BITS in PAR4 + MinMaxTRange(lRangeRA[kXdim], lSliceHeaderRA[10]); //10 XDim in PAR4 + MinMaxTRange(lRangeRA[kYdim], lSliceHeaderRA[11]); //11 YDim in PAR4 + MinMaxTRange(lRangeRA[kIntercept],lSliceHeaderRA[12]); //12=intercept in PAR4 + MinMaxTRange(lRangeRA[kSlope],lSliceHeaderRA[13]); //13=lslope in PAR4 + MinMaxTRange(lRangeRA[kCalibratedSlope],lSliceHeaderRA[14]); //14=lcalibrated slope in PAR4 1393 - attempt to use calibrated values + MinMaxTRange(lRangeRA[kSliceThick],lSliceHeaderRA[23]);//23 SLICE THICK in PAR4 + MinMaxTRange(lRangeRA[kSliceGap], lSliceHeaderRA[24]); //24 SLICE GAP in PAR4 + MinMaxTRange(lRangeRA[kXmm],lSliceHeaderRA[29]); //29 PIXEL SPACING X in PAR4 + MinMaxTRange(lRangeRA[kYmm],lSliceHeaderRA[30]); //30 PIXEL SPACING Y in PAR4 + MinMaxTRange(lRangeRA[kDynTime],(lSliceHeaderRA[32]));//32= dyn_scan_begin_time in PAR4 + end; //PAR4 + if lSliceInfoCount < kMaxnSlices then begin + lSliceSequenceRA^[lSliceInfoCount] := ( (round(lRangeRA[kSequence].val)+round(lRangeRA[kType].val)+round(lRangeRA[kCardiac].val+lRangeRA[kEcho].val)) shl 24)+(round(lRangeRA[kDyn].val) shl 10)+round(lRangeRA[kSlice].val); + lSliceSlopeRA [lSliceInfoCount] := lRangeRA[kSlope].Val; + lCalibratedSliceSlopeRA [lSliceInfoCount] := lRangeRA[kCalibratedSlope].Val; + lSliceInterceptRA [lSliceInfoCount] := lRangeRA[kIntercept].val; + lSliceIndexRA[lSliceInfoCount]:= round(lRangeRA[kIndex].val); + end; + end; //SliceInfo Line + until (linPos >= lFileSz);//until done reading entire file... + //describe generic DICOM parameters + lDicomData.XYZdim[1] := round(lRangeRA[kXdim].Val); + lDicomData.XYZdim[2] := round(lRangeRA[kYdim].Val); + lDicomData.XYZdim[3] := 1+round(lRangeRA[kSlice].Max-lRangeRA[kSlice].Min); + if (lSliceInfoCount mod lDicomData.XYZdim[3]) <> 0 then + Msg('read_PAR_data: Total number of slices not divisible by number of slices per volume. Reconstruction error?'); + if lDicomData.XYZdim[3] > 0 then + lDicomData.XYZdim[4] := lSliceInfoCount div lDicomData.XYZdim[3] //nVolumes = nSlices/nSlicePerVol + else + lDicomData.XYZdim[4] := 1; + + lDicomData.XYZmm[1] := lRangeRA[kXmm].Val; + lDicomData.XYZmm[2] := lRangeRA[kYmm].Val; + lDicomData.XYZmm[3] := lRangeRA[kSliceThick].Val+lRangeRA[kSliceGap].Val; + lDicomData.Allocbits_per_pixel := round(lRangeRA[kBitsPerVoxel].Val); + lDicomData.IntenScale := lRangeRA[kSlope].Val; + lDicomData.IntenIntercept := lRangeRA[kIntercept].Val; +if gPARprecise then begin + if (lDicomData.IntenIntercept <> 0) or (lRangeRA[kCalibratedSlope].val = 0) then + Msg('Warning: Unable to save calibrated Philips image intensity (non-zero scaling intercept). Turn off Etc/Options/CalibratedScaling to hide warning.'); + if (lRangeRA[kSlope].min = lRangeRA[kSlope].max) + and (lRangeRA[kIntercept].min = lRangeRA[kIntercept].max) + and (lRangeRA[kCalibratedSlope].min = lRangeRA[kCalibratedSlope].max) + and (lDicomData.IntenIntercept = 0) and (lRangeRA[kCalibratedSlope].val <> 0) then + lDicomData.IntenScale := 1 / lRangeRA[kCalibratedSlope].val; +end; //if PARprecise + //Next: report number of Dynamic scans, this allows people to parse DynScans from Type/Cardiac/Echo/Sequence 4D files + lnum4Ddatasets := (round(lRangeRA[kDyn].Max - lRangeRA[kDyn].Min)+1)*lDicomData.XYZdim[3]; //slices in each dynamic session + if ((lSliceInfoCount mod lnum4Ddatasets) = 0) and ((lSliceInfoCount div lnum4Ddatasets) > 1) then + lnum4Ddatasets := (lSliceInfoCount div lnum4Ddatasets) //infer multiple Type/Cardiac/Echo/Sequence + else + lnum4Ddatasets := 1; + //next: Determine actual interscan interval + if (lDicomData.XYZdim[4] > 1) and ((lRangeRA[kDynTime].max-lRangeRA[kDynTime].min)> 0) {1384} then begin + lReportedTRStr := 'Reported TR: '+floattostrf(lDicomData.TR,ffFixed,8,2)+kCR; + lDicomData.TR := (lRangeRA[kDynTime].max-lRangeRA[kDynTime].min) /(lDicomData.XYZdim[4] - 1)*1000; //infer TR in ms + end else + lReportedTRStr :=''; + //next: report header details + lDynStr := 'Philips PAR/REC Format' //'PAR/REC Format' + +kCR+ 'Patient name:'+lDicomData.PatientName + +kCR+ 'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'Volumes: ' +inttostr(lDicomData.XYZdim[4]) + +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'TR: '+floattostrf(lDicomData.TR,ffFixed,8,2) + +kCR+lReportedTRStr+kCR+lDynStr; + //if we get here, the header is fine, next steps will see if image format is readable... + lHdrOK := true; + if lSliceInfoCount < 1 then + goto 333; + //next: see if slices are in sequence + lSlicesNotInSequence := false; + if lSliceInfoCount > 1 then begin + lMaxSlice := lSliceSequenceRA^[1]; + lMaxIndex := lSliceIndexRA[1]; + lInc := 1; + repeat + inc(lInc); + if lSliceSequenceRA^[lInc] < lMaxSlice then //not in sequence if image has lower slice order than previous image + lSlicesNotInSequence := true + else + lMaxSlice := lSliceSequenceRA^[lInc]; + if lSliceIndexRA[lInc] < lMaxIndex then //not in sequence if image has lower slice index than previous image + lSlicesNotInSequence := true + else + lMaxIndex := lSliceIndexRA[lInc]; + until (lInc = lSliceInfoCount) or (lSlicesNotInSequence); + end; //at least 2 slices + //Next: report any errors + lErrorStr := ''; + if (lSlicesNotInSequence) and (not lReadOffsetTables) then + lErrorStr := lErrorStr + ' Slices not saved sequentially [using MRIcro''s ''Philips PAR to Analyze'' command may solve this]'+kCR; + if lSliceInfoCount > kMaxnSlices then + lErrorStr := lErrorStr + ' Too many slices: >'+inttostr(kMaxnSlices)+kCR; + if (not lReadVaryingScaleFactors) and ( (lRangeRA[kSlope].min <> lRangeRA[kSlope].max) + or (lRangeRA[kIntercept].min <> lRangeRA[kIntercept].max)) then + lErrorStr := lErrorStr + ' Differing intensity slope/intercept [using MRIcro''s ''Philips PAR to Analyze'' command may solve this]'+kCR; + if (lRangeRA[kBitsPerVoxel].min <> lRangeRA[kBitsPerVoxel].max) then //5D file space+time+cardiac + lErrorStr := lErrorStr + ' Differing bits per voxel'+kCR; + //if (lRangeRA^[kCardiac].min <> lRangeRA^[kCardiac].max) then //5D file space+time+cardiac + // lErrorStr := lErrorStr + 'Multiple cardiac timepoints'+kCR; + //if (lRangeRA^[kEcho].min <> lRangeRA^[kEcho].max) then //5D file space+time+echo + // lErrorStr := lErrorStr + 'Multiple echo timepoints'+kCR; + if (lRangeRA[kSliceThick].min <> lRangeRA[kSliceThick].max) or (lRangeRA[kSliceGap].min <> lRangeRA[kSliceGap].max) + or (lRangeRA[kXdim].min <> lRangeRA[kXdim].max) or (lRangeRA[kYDim].min <> lRangeRA[kYDim].max) + or (lRangeRA[kXmm].min <> lRangeRA[kXmm].max) or (lRangeRA[kYmm].min <> lRangeRA[kYmm].max) then + lErrorStr := lErrorStr + ' Multiple/varying slice dimensions'+kCR; + //if any errors were encountered, report them.... + if lErrorStr <> '' then begin + Msg('read_PAR_data: This software can not convert this Philips data:'+kCR+lErrorStr); + goto 333; + end; + //Next sort image indexes here... + if (lSliceInfoCount > 1) and(lSlicesNotInSequence) and ( lReadOffsetTables) then begin //sort image order... + //ShellSort (first, last: integer; var lPositionRA, lIndexLoRA,lIndexHiRA: LongintP; var lRepeatedValues: boolean) + GetMem (lOffset_pos_table, lSliceInfoCount*sizeof(longint)); + for lInc := 1 to lSliceInfoCount do + lOffset_pos_table^[lInc] := lInc; + ShellSortItems (1, lSliceInfoCount,lOffset_pos_table,lSliceSequenceRA, lRepeatedValues); + if lRepeatedValues then begin + Msg('read_PAR_data: fatal error, slices do not appear to have unique indexes [multiple copies of same slice]'); + FreeMem (lOffset_pos_table); + goto 333; + end; + lOffsetTableEntries := lSliceInfoCount; + end; //sort image order... + //Next, generate list of scale slope + if (lSliceInfoCount > 1) and (lReadVaryingScaleFactors) and ( (lRangeRA[kSlope].min <> lRangeRA[kSlope].max) + or (lRangeRA[kIntercept].min <> lRangeRA[kIntercept].max)) then begin {create offset LUT} + lVaryingScaleFactorsTableEntries := lSliceInfoCount; + getmem (lVaryingScaleFactors_table, lVaryingScaleFactorsTableEntries*sizeof(single)); + getmem (lVaryingIntercept_table, lVaryingScaleFactorsTableEntries*sizeof(single)); + if lOffsetTableEntries = lSliceInfoCount then begin //need to sort slices + + for lInc := 1 to lSliceInfoCount do begin + lVaryingScaleFactors_table^[lInc] := lSliceSlopeRA[lOffset_pos_table^[lInc]]; + lVaryingIntercept_table^[lInc] := lSliceInterceptRA[lOffset_pos_table^[lInc]]; +if gPARprecise then begin + if (lVaryingIntercept_table^[lInc] <> 0) or (lCalibratedSliceSlopeRA[lOffset_pos_table^[lInc]]=0) then + Msg('Warning: Unable to save calibrated Philips image intensity (non-zero scaling intercept). Turn off Etc/Options/CalibratedScaling to hide warning.') + else begin + lVaryingScaleFactors_table^[lInc] := 1 / lCalibratedSliceSlopeRA[lOffset_pos_table^[lInc]]; + end; +end; //if PARprecise + + end; + end else begin //if sorted, else unsorted + + for lInc := 1 to lSliceInfoCount do begin + lVaryingScaleFactors_table^[lInc] := lSliceSlopeRA[lInc]; + lVaryingIntercept_table^[lInc] := lSliceInterceptRA[lInc]; +if gPARprecise then begin + if (lVaryingIntercept_table^[lInc] <> 0) or (lCalibratedSliceSlopeRA[lInc]=0) then + Msg('Warning: Unable to save calibrated Philips image intensity (non-zero scaling intercept). Turn off Etc/Options/CalibratedScaling to hide warning.') + else + lVaryingScaleFactors_table^[lInc] := 1 / lCalibratedSliceSlopeRA[lInc]; +end; //if PARprecise + + end; + end; //slices sorted + end;//read scale factors + //Next: now adjust Offsets to point to byte offset instead of slice number + lSliceSz := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*(lDicomData.Allocbits_per_pixel div 8); + if lOffsetTableEntries = lSliceInfoCount then + for lInc := 1 to lSliceInfoCount do + lOffset_pos_table^[lInc] := lSliceSz * (lSliceIndexRA[lOffset_pos_table^[lInc]]); + //report if 5D/6D/7D file is being saved as 4D + if (lRangeRA[kCardiac].min <> lRangeRA[kCardiac].max) + or (lRangeRA[kEcho].min <> lRangeRA[kEcho].max) //5D file space+time+echo + or (lRangeRA[kType].min <> lRangeRA[kType].max) //5D file space+time+echo + or (lRangeRA[kSequence].min <> lRangeRA[kSequence].max) then //5D file space+time+echo + Msg('Warning: note that this image has more than 4 dimensions (multiple Cardiac/Echo/Type/Sequence)'); + //if we get here, the Image Format is OK + lImageFormatOK := true; + lFileName := changefileextX(lFilename,'.rec'); //for Linux: case sensitive extension search '.rec' <> '.REC' + 333: //abort clause: skips lHdrOK and lImageFormatOK + //next: free dynamically allocated memory + FreeMem( lCharRA); + FreeMem (lSliceSequenceRA); +end; *) + +procedure read_ge_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 539; +var + lGap,lSliceThick,lTempFloat: single; + lTemp16,lI: word; + lSeriesOffset,lTemp32,lExamHdr,lImgHdr,lDATFormatOffset,lHdrOffset,lCompress,linitialoffset,n,filesz: LongInt; + tx : array [0..36] of Char; + FP: file; + lGEodd,lGEFlag,{lSpecial,}lMR: boolean; +function GEflag: boolean; +begin + if (tx[0] = 'I') AND (tx[1]= 'M') AND (tx[2] = 'G')AND (tx[3]= 'F') then + result := true + else + result := false; +end; +function swap16i(lPos: longint): word; +var + w : Word; +begin + seek(fp,lPos-2); + BlockRead(fp, W, 2); + result := swap(W); +end; + +function swap32i(lPos: longint): Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap32i:=outguy.Long; +end; +function fswap4r (lPos: longint): single; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(float:single); + end; + swaptypep = ^swaptype; +var + s:single; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + fswap4r:=outguy.float; +end; +begin + lImageFormatOK := true; + lSeriesOffset := 0; + lSLiceThick := 0; + lGap := 0; + lHdrOK := false; + lHdrOffset := 0; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + lDATFormatOffset := 0; + Clear_Dicom_Data(lDicomData); + if filesz < (3240) then begin + Msg('This file is too small to be a Genesis DAT format image.'); + goto 539; + end; + lDynStr:= ''; + //lGEFlag := false; + lInitialOffset := 3228;//3240; + seek(fp, lInitialOffset); + BlockRead(fp, tx, 4*SizeOf(Char), n); + lGEflag := GEFlag; + if not lGEFlag then begin + lInitialOffset := 3240; + seek(fp, lInitialOffset); + BlockRead(fp, tx, 4*SizeOf(Char), n); + lGEflag := GEFlag; + end; + lGEodd := lGEFlag; + if not lGEFlag then begin + lInitialOffset := 0; + seek(fp, lInitialOffset); + BlockRead(fp, tx, 4*SizeOf(Char), n); + if not GEflag then begin {DAT format} + lDynStr := lDynStr+'GE Genesis Signa DAT tape format'+kCR; + seek(fp,114); + BlockRead(fp, tx, 4*SizeOf(Char), n); + lDynStr := lDynStr + 'Suite: '; + for lI := 0 to 3 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + + seek(fp,114+97); + BlockRead(fp, tx, 25*SizeOf(Char), n); + lDynStr := lDynStr + 'Patient Name: '; + for lI := 0 to 24 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + seek(fp,114+84); + BlockRead(fp, tx, 13*SizeOf(Char), n); + lDynStr := lDynStr + 'Patient ID: '; + for lI := 0 to 12 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + seek(fp, 114+305); + BlockRead(fp, tx, 3*SizeOf(Char), n); + if (tx[0]='M') and (tx[1] = 'R') then + lMR := true + else if (tx[0] = 'C') and(tx[1] = 'T') then + lMR := false + else begin + Msg('Is this a Genesis DAT image? The modality is '+tx[0]+tx[1]+tx[3] + +'. Expected ''MR'' or ''CT''.'); + goto 539; + end; + if lMR then + lInitialOffset := 3180 + else + lInitialOffset := 3178; + seek(fp, lInitialOffset); + BlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] <> 'I') OR (tx[1] <> 'M') OR (tx[2] <> 'G') OR (tx[3] <> 'F') then begin + Msg('This image does not have the required label ''IMGF''. This is not a Genesis DAT image.'); + goto 539; + end else + lDicomData.ImageNum := swap16i(2158+12); + lDicomData.XYZmm[3] := fswap4r (2158+26);// slice thickness mm + lDicomData.XYZmm[1] := fswap4r (2158+50);// pixel size- X + lDicomData.XYZmm[2] := fswap4r (2158+54);//pixel size - Y + lSliceThick := lDicomData.XYZmm[3]; + lGap := fswap4r (lHdrOffset+118);//1410 gap thickness mm + if lGap > 0 then + lDicomData.XYZmm[3] := lDicomData.XYZmm[3] + lGap; + lDATFormatOffset := 4; + if lMR then begin + lTemp32 := swap32i(2158+194); + lDynStr := lDynStr +'TR[usec]: '+inttostr(lTemp32) + kCR; + lTemp32 := swap32i(2158+198); + lDynStr := lDynStr +'TInvert[usec]: '+inttostr(lTemp32) + kCR; + lTemp32 := swap32i(2158+202); + lDynStr := lDynStr +'TE[usec]: '+inttostr(lTemp32) + kCR; + lTemp16 := swap16i(2158+210); + lDynStr := lDynStr +'Number of echoes: '+inttostr(lTemp16) + kCR; + lTemp16 := swap16i(2158+212); + lDynStr := lDynStr +'Echo: '+inttostr(lTemp16) + kCR; + + lTempFloat := fswap4r (2158+50); //not sure why I changed this to 50... 218 in Clunie's Description + lDynStr := lDynStr +'NEX: '+floattostr(lTempFloat) + kCR; + + seek(fp,2158+308); + BlockRead(fp, tx, 33*SizeOf(Char), n); + lDynStr := lDynStr + 'Sequence: '; + for lI := 0 to 32 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + + + seek(fp,2158+362); + BlockRead(fp, tx, 17*SizeOf(Char), n); + lDynStr := lDynStr + 'Coil: '; + for lI := 0 to 16 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; + + + end; + + end; {DAT format} +end; + lDicomData.ImageStart := lDATFormatOffset+linitialoffset + swap32i(linitialoffset+4);//byte displacement to image data + lDicomData.XYZdim[1] := swap32i(linitialoffset+8); //width + lDicomData.XYZdim[2] := swap32i(linitialoffset+12);//height + lDicomData.Allocbits_per_pixel := swap32i(linitialoffset+16);//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lCompress := swap32i(linitialoffset+20); //compression + lExamHdr := swap32i(linitialoffset+136); + lImgHdr := swap32i(linitialoffset+152); + if (lImgHdr = 0) and (lDicomData.ImageStart = 8432) then begin + lDicomData.ImageNum := swap16i(2310+12); + lDicomData.XYZmm[3] := fswap4r (2310+26);// slice thickness mm + lDicomData.XYZmm[1] := fswap4r (2310+50);// pixel size- X + lDicomData.XYZmm[2] := fswap4r (2310+54);//pixel size - Y + lSliceThick := lDicomData.XYZmm[3]; + lGap := fswap4r (lHdrOffset+118);//1410 gap thickness mm + if lGap > 0 then + lDicomData.XYZmm[3] := lDicomData.XYZmm[3] + lGap; + + end else if {(lSpecial = false) and} (lDATFormatOffset = 0) then begin + lDynStr := lDynStr+'GE Genesis Signa format'+kCR; + if (not lGEodd) and (lExamHdr <> 0) then begin + lHdrOffset := swap32i(linitialoffset+132);//x132- int ptr to exam heade +//Patient ID + seek(fp,lHdrOffset+84); + BlockRead(fp, tx, 13*SizeOf(Char), n); + lDynStr := lDynStr + 'Patient ID: '; + for lI := 0 to 12 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; +//Patient Name + seek(fp,lHdrOffset+97); + BlockRead(fp, tx, 25*SizeOf(Char), n); + lDynStr := lDynStr + 'Patient Name: '; + for lI := 0 to 24 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; +//Patient Age + lI := swap16i(lHdrOffset+122); + lDynStr := lDynStr+'Patient Age: '+inttostr(lI)+kCR; +//Modality: MR or CT + seek(fp,lHdrOffset+305); + BlockRead(fp, tx, 3*SizeOf(Char), n); + lDynStr := lDynStr + 'Type: '; + for lI := 0 to 1 do + lDynStr := lDynStr + tx[lI]; + lDynStr := lDynStr + kCR; +//Read series header + lSeriesOffset := swap32i(linitialoffset+144);//read size of series header: only read if >0 + if lSeriesOffset > 12 then begin + lSeriesOffset := swap32i(linitialoffset+140);//read size of series header: only read if >0 + lI := swap16i(lSeriesOffset+10); + //lDynStr := lDynStr+'Series number: '+inttostr(lI)+kCR; + lDicomData.SeriesNum := lI; + end; + + +//image data + lHdrOffset := swap32i(linitialoffset+148);//x148- int ptr to image heade + end; + if lGEodd then lHdrOffset := 2158+28; + if ((lHdrOffset +58) < FileSz) and (lImgHdr <> 0) then begin + lDicomData.AcquNum := swap16i(lHdrOffset+12); //note SERIES not IMAGE number, despite what Clunies FAQ says + lDicomData.ImageNum := swap16i(lHdrOffset+14); //this is IMAGEnum + + //lDynStr := lDynStr +'Image number: '+inttostr(lDicomData.ImageNum)+ kCR; + lDicomData.XYZmm[3] := fswap4r (lHdrOffset{linitialoffset+lHdrOffset}+26);// slice thickness mm + lDicomData.XYZmm[1] := fswap4r (lHdrOffset{linitialoffset+lHdrOffset}+50);// pixel size- X + lDicomData.XYZmm[2] := fswap4r (lHdrOffset{linitialoffset+lHdrOffset}+54);//pixel size - Y + lSliceThick := lDicomData.XYZmm[3]; + lGap := fswap4r (lHdrOffset+118);//1410 gap thickness mm + if lGap > 0 then + lDicomData.XYZmm[3] := lDicomData.XYZmm[3] + lGap; + end; + end; + if (lCompress = 3) or (lCompress = 4) then begin + lImageFormatOK := false;//xlDicomData.GenesisCpt := true; + lDynStr := lDynStr+'Compressed data'+kCR; + end else + ;//xlDicomData.GenesisCpt := false; + if (lCompress = 2) or (lCompress = 4) then begin + lImageFormatOK := false;//xlDicomData.GenesisPackHdr := swap32i(linitialoffset+64); + lDynStr := lDynStr+'Packed data'+kCR; + end else + //xlDicomData.GenesisPackHdr := 0; + lDynStr := lDynStr+'Series Number: '+inttostr(lDicomData.SeriesNum) + +kCR+'Acquisition Number: '+inttostr(lDicomData.AcquNum) + +kCR+'Image Number: '+inttostr(lDicomData.ImageNum) + +kCR+'Slice Thickness/Gap: '+floattostrf(lSliceThick,ffFixed,8,2)+'/'+floattostrf(lGap,ffFixed,8,2) + +kCR+'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + lHdrOK := true; + 539: + CloseFile(fp); + FileMode := 2; //set to read/write +end;//read_ge + + +//start siemens +procedure read_siemens_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 567; +var + lI: word; + lYear,lMonth,lDay,n,filesz,lFullSz,lMatrixSz,lIHour,lIMin,lISec{,lAHour,lAMin,lASec}: LongInt; + lFlipAngle,lGap,lSliceThick: double; + tx : array [0..26] of Char; + lMagField,lTE,lTR: double; + lInstitution,lName, lID,lMinStr,lSecStr{,lAMinStr,lASecStr}: String; + FP: file; +function swap32i(lPos: longint): Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap32i:=outguy.Long; + //swap32i:=inguy.Long; +end; +function fswap8r (lPos: longint): double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + s:double; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 8, n); + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + fswap8r:=outguy.float; +end; +begin + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if filesz < (6144) then begin + Msg('This file is to small to be a Siemens Magnetom Vision image.'); + goto 567; + end; + seek(fp, 96); + BlockRead(fp, tx, 7*SizeOf(Char), n); + if (tx[0] <> 'S') OR (tx[1] <> 'I') OR (tx[2] <> 'E') OR (tx[3] <> 'M') then begin {manufacturer is not SIEMENS} + Msg('Is this a Siemens Magnetom Vision image [Manufacturer tag should be ''SIEMENS''].'); + goto 567; + end; {manufacturer not siemens} + seek(fp, 105); + BlockRead(fp, Tx, 25*SizeOf(Char), n); + lINstitution := ''; + for lI := 0 to 24 do begin + if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lINstitution := lINstitution + tx[lI]; + end; seek(fp, 768); + BlockRead(fp, Tx, 25*SizeOf(Char), n); + lName := ''; + for lI := 0 to 24 do begin + if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lName := lName + tx[lI]; + end; + seek(fp, 795); + BlockRead(fp, Tx, 12*SizeOf(Char), n); + lID := ''; + for lI := 0 to 11 do begin + if tx[lI] in ['/','\','a'..'z','A'..'Z',' ','+','-','.',',','0'..'9'] then lID := lID + tx[lI]; + end; + lDicomData.ImageStart := 6144; + lYear := swap32i(0); + lMonth := swap32i(4); + lDay := swap32i(8); + lIHour := swap32i(68); + lIMin := swap32i(72); + lISec := swap32i(76); + lDicomData.XYZmm[3] := fswap8r (1544); + lMagField := fswap8r (2560); + lTR := fswap8r (1560); + lTE := fswap8r (1568); + lDIcomData.AcquNum := swap32i(3212); + lMatrixSz := swap32i(2864); + lDicomData.SiemensSlices := swap32i(4004); //1366 + //lFullSz := swap32i(4008); + //lInterleaveIf4 := swap32i(2888); + lFullSz := (2*lMatrixSz*lMatrixSz);//16bitdata + if ((FileSz - 6144) mod lFullSz) = 0 then begin + case ((FileSz-6144) div lFullSz) of + 4: lFullSz := 2*lMatrixSz; + 9: lFullSz := 3*lMatrixSz; + 16: lFullSz := 4*lMatrixSz; + 25: lFullSz := 5*lMatrixSz; + 36: lFullSz := 6*lMatrixSz; + 49: lFullSz := 7*lMatrixSz; + 64: lFullSz := 8*lMatrixSz; + else lFullSz := lMatrixSz; + end; + end else lFullSz := lMatrixSz; + {3744/3752 are XY FOV in mm!} + lDicomData.XYZdim[1] := lFullSz;//lMatrixSz; //width + lDicomData.XYZdim[2] := lFullSz;//lMatrixSz;//height + {5000/5008 are size in mm, but wrong for mosaics} + if lMatrixSz <> 0 then begin + lDicomData.XYZmm[2] := fswap8r (3744)/lMatrixSz; + lDicomData.XYZmm[1] := fswap8r (3752)/lMatrixSz; + if ((lDicomData.XYZdim[1] mod lMatrixSz)=0) then + lDicomData.SiemensMosaicX := lDicomData.XYZdim[1] div lMatrixSz; + if ((lDicomData.XYZdim[2] mod lMatrixSz)=0) then + lDicomData.SiemensMosaicY := lDicomData.XYZdim[2] div lMatrixSz; + if lDicomData.SiemensMosaicX < 1 then lDicomData.SiemensMosaicX := 1; //1366 + if lDicomData.SiemensMosaicY < 1 then lDicomData.SiemensMosaicY := 1; //1366 + end; + lFlipAngle := fswap8r (2112); //1414 +{ lDicomData.XYZmm[2] := fswap8r (5000); + lDicomData.XYZmm[1] := fswap8r (5008);} + lSliceThick := lDicomData.XYZmm[3]; + lGap := fswap8r (4136); //gap as ratio of slice thickness?!?! + if {lGap > 0} (lGap=-1) or (lGap=-19222) then //1410: exclusion values: do not ask me why 19222: from John Ashburner + else begin + //lDicomData.XYZmm[3] := abs(lDicomData.XYZmm[3] * (1+lGap)); + lGap := lDicomData.XYZmm[3] * (lGap); + lDicomData.XYZmm[3] := abs(lDicomData.XYZmm[3] +lGap); + end; + lDicomData.Allocbits_per_pixel := 16;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + //xlDicomData.GenesisCpt := false; + //xlDicomData.GenesisPackHdr := 0; + lMinStr := inttostr(lIMin); + if length(lMinStr) = 1 then lMinStr := '0'+lMinStr; + lSecStr := inttostr(lISec); + if length(lSecStr) = 1 then lSecStr := '0'+lSecStr; + + + + lDynStr := 'Siemens Magnetom Vision Format'+kCR+'Name: '+lName+kCR+'ID: '+lID+kCR+'Institution: '+lInstitution+kCR+ + 'Study DD/MM/YYYY: '+inttostr(lDay)+'/'+inttostr(lMonth)+'/'+inttostr(lYear)+kCR+ + 'Image Hour/Min/Sec: '+inttostr(lIHour)+':'+lMinStr+':'+lSecStr+kCR+ + //'Acquisition Hour/Min/Sec: '+inttostr(lAHour)+':'+lAMinStr+':'+lASecStr+kCR+ + 'Magnetic Field Strength: '+ floattostrf(lMagField,ffFixed,8,2)+kCR+ + 'Image index: '+inttostr(lDIcomData.AcquNum)+kCR+ + 'Time Repitition/Echo [TR/TE]: '+ floattostrf(lTR,ffFixed,8,2)+'/'+ floattostrf(lTE,ffFixed,8,2)+kCR+ + 'Flip Angle: '+ floattostrf(lFlipAngle,ffFixed,8,2)+kCR+ + 'Slice Thickness/Gap: '+floattostrf(lSliceThick,ffFixed,8,2)+'/'+floattostrf(lGap,ffFixed,8,2)+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3])+kCR+ + 'XY matrix:' +inttostr(lDicomData.SiemensMosaicX)+'/' + +inttostr(lDicomData.SiemensMosaicY)+kCR+ + 'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + lHdrOK := true; + //lDIcomData.AcquNum := 0; +567: +CloseFile(fp); + FileMode := 2; //set to read/write +end; +//end siemens +//begin elscint +procedure read_elscint_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 539; +var + //lExamHdr,lImgHdr,lDATFormatOffset,lHdrOffset, + {lDate,}lI,lCompress,n,filesz: LongInt; + tx : array [0..41] of Char; + FP: file; +function readStr(lPos,lLen: integer): string; +var lStr: string; + lStrInc: integer; +begin + seek(fp,lPos); + BlockRead(fp, tx, lLen, n); + lStr := ''; + for lStrInc := 0 to (lLen-1) do + lStr := lStr + tx[lStrInc]; + result := lStr +end; +function read8ch(lPos: integer): char; +begin + seek(fp,40); + BlockRead(fp, result, 1, n); + //lDicomData.ImageNum := ord(tx[0]); +end; +procedure read16i(lPos: longint; var lVal: integer); +var lInWord: word; +begin + seek(fp,lPos); + BlockRead(fp, lInWord, 2); + lVal := lInWord; +end; +procedure read32i(lPos: longint; var lVal: integer); +var lInINt: integer; +begin + seek(fp,lPos); + BlockRead(fp, lInINt, 4); + lVal :=lInINt; +end; + +begin + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if filesz < (3240) then begin + Msg('This file is too small to be a Elscint format image.'); + goto 539; + end; + lDynStr:= ''; + read16i(0, lI); + if (lI <> 64206) then begin + Msg('Unable to read this file: it does start with the Elscint signature.'); + goto 539; + end; + lDicomdata.little_endian := 1; + lDynStr:= 'Elscint Format'+kCR; + lDynStr := lDynStr+'Patient Name: '+readstr(4,20)+kCR; + lDynStr := lDynStr+'Patient ID: '+readstr(24,13)+kCR; + read16i(38,lDicomData.AcquNum); + lDicomData.ImageNum := ord(read8Ch(40)); + lDynStr := lDynStr+'Doctor & Ward: '+readstr(100,20)+kCR; + lDynStr := lDynStr+'Comments: '+readstr(120,40)+kCR; + if ord(read8Ch(163)) = 1 then + lDynStr := lDynStr + 'Sex: M'+kCR + else + lDynStr := lDynStr + 'Sex: F'+kCR; + read16i(200,lI); + lDicomData.XYZmm[3] := lI * 0.1; + read16i(370,lDicomData.XYZdim[1]); + read16i(372,lDicomData.XYZdim[2]); + read16i(374,lI); + lDicomData.XYZmm[1] := lI / 256; + lDicomData.XYZmm[2] := lDicomData.XYZmm[1]; + lCompress := ord(read8Ch(376)); + //xlDicomData.ElscintCompress := true; + //xread16i(400,lDicomData.WindowWidth); + //x read16i(398,lDicomData.WindowCenter); + case lCompress of + 0: begin + lDynStr := lDynStr + 'Compression: None'+kCR; + //xlDicomData.ElscintCompress := false; + end; + 1: lImageFormatOK := false;//xlDynStr := lDynStr + 'Compression: Old'+kCR; + 2: lImageFormatOK := false;//xlDynStr := lDynStr + 'Compression: 2400 Elite'+kCR; + 22: lImageFormatOK := false;//xlDynStr := lDynStr + 'Compression: Twin'+kCR; + else begin + lImageFormatOK := false;//xlDynStr := lDynStr + 'Compression: Unknown '+inttostr(lCOmpress)+kCR; + //lDicomData.ElscintCompress := false; + end; + end; + //lDicomData.XYZdim[1] := swap32i(linitialoffset+8); //width + //lDicomData.XYZdim[2] := swap32i(linitialoffset+12);//height + lDicomData.ImageStart := 396; + lDicomData.Allocbits_per_pixel := 16; + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + if (lDicomData.XYZdim[1]=160) and (lDicomData.XYZdim[2]= 160) and (FIleSz=52224) then begin + lDicomData.ImageStart := 1024; + lImageFormatOK := true;//x//xlDicomData.ElscintCompress := False; + end; + //lDicomData.XYZmm[3] := fswap4r (2310+26);// slice thickness mm + lDynStr := lDynStr+'Image/Study Number: '+inttostr(lDicomData.ImageNum)+'/'+ inttostr(lDicomData.AcquNum)+kCR + +'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + //x+kCR+'Window Center/Width: '+inttostr(lDicomData.WindowCenter)+'/'+inttostr(lDicomData.WindowWidth) + +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + lHdrOK := true; + lImageFormatOK := true; + 539: + CloseFile(fp); + FileMode := 2; //set to read/write +end; +//end elscint + + + +//start picker +procedure read_picker_data(lVerboseRead: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label 423; +const kPickerHeader =8192; +kRecStart = 280; //is this a constant? +var + lDataStart,lVal,lDBPos,lPos,lRecSz, lNumRecs,lRec,FileSz,n: Longint; + lThkM,lThkN,lSiz: double; + tx : array [0..6] of Char; + FP: file; + lDiskCacheRA: pChar; +function ReadRec(lRecNum: integer): boolean; +var + lNameStr,lValStr: string; + lOffset,lLen,lFPOs,lFEnd: integer; +function ValStrToFloat: double; +var lConvStr: string; + lI: integer; +begin + Result := 0.0; + lLen := Length(lValStr); + if lLen < 1 then exit; + lConvStr := ''; + for lI := 1 to lLen do + if lValStr[lI] in ['0'..'9'] then + lConvStr := lConvStr+ lValStr[lI]; + if Length(lConvStr) < 1 then exit; + Result := strtofloat(lConvStr); +end; +begin + Result := false; + lFPos := ((lRecNum-1) * lRecSz)+ kRecStart; + lFEnd := lFpos + 6; + lNameStr := ''; + for lFPos := lFPos to lFEnd do + if ord(lDiskCacheRA[lFPos]) <> 0 then + lNameStr := lNameStr +lDiskCacheRA[lFPos]; + if (lVerboseRead) or (lNameStr = 'RCNFSIZ') or (lNameStr='SCNTHKM') or (lNameStr='SCNTHKN') then begin + lFPos := ((lRecNum-1) * lRecSz)+ kRecStart+8; + lFEnd := lFPos+1; + lOffset := 0; + for lFPos := lFPos to lFend do + lOffset := ((lOffset)shl 8)+(ord(lDiskCacheRA[lFPos])); + lFPos := ((lRecNum-1) * lRecSz)+ kRecStart+10; + lFEnd := lFPos+1; + lLen := 0; + for lFPos := lFPos to lFend do + lLen := ((lLen)shl 8)+(ord(lDiskCacheRA[lFPos])); + lOffset := lDataStart+lOffset+1; + lFEnd := lOffset+lLen-1; + if (lLen < 1) or (lFEnd > kPickerHeader) then exit; + lValStr := ''; + for lFPos := (lOffset) to lFEnd do begin + lValStr := lValStr+lDiskCacheRA[lFPos]; + end; + if lVerboseRead then lDynStr := lDynStr+kCR+lNameStr+': '+ lValStr; + if (lNameStr = 'RCNFSIZ') then lSiz := ValStrToFloat; + if (lNameStr='SCNTHKM') then lThkM := ValStrToFloat; + if (lNameStr='SCNTHKN') then lThkN := ValStrToFloat; + end; //verboseread, or vital value + result := true; +end; +function FindStr(l1,l2,l3,l4,l5: Char; lReadNum: boolean; var lNum: integer): boolean; +var //lMarker: integer; + lNumStr: String; +begin + Result := false; + repeat + if (lDiskCacheRA[lPos-4]=l1) and (lDiskCacheRA[lPos-3]=l2) + and (lDiskCacheRA[lPos-2]=l3) and (lDiskCacheRA[lPos-1]=l4) + and (lDiskCacheRA[lPos]=l5) then Result := true; + inc (lPos); + until (Result) or (lPos >= kPickerHeader); + if not Result then exit; + if not lReadNum then exit; + Result := false; + lNumStr := ''; + repeat + if (lDiskCacheRA[lPos] in ['0'..'9']) then + lNumStr := lNumStr + lDiskCacheRA[lPos] + else if lNumStr <> '' then Result := true; + inc(lPos); + until (Result) or (lPos = kPickerHeader); + lNum := strtoint(lNumStr); +end; +begin + lSiz := 0.0; + lThkM := 0.0; + lThkN := 0.0; + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if filesz < (kPickerHeader) then begin + Msg('This file is to small to be a Picker image: '+lFileName ); + CloseFile(fp); + FileMode := 2; //set to read/write + exit; + end; + seek(fp, 0); + BlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] <> '*') OR (tx[1] <> '*') OR (tx[2] <> '*') OR (tx[3] <> ' ') then begin {manufacturer is not SIEMENS} + Msg('Is this a Picker image? Expected ''***'' at the start of the file.'+ lFileName); + CloseFile(fp); + FileMode := 2; //set to read/write + exit; + end; {not picker} + if filesz = (kPickerHeader + (1024*1024*2)) then begin + lDICOMdata.XYZdim[1] := 1024; + lDICOMdata.XYZdim[2] := 1024; + lDICOMdata.XYZdim[3] := 1; + lDICOMdata.ImageStart := 8192; + end else + if filesz = (kPickerHeader + (512*512*2)) then begin + lDICOMdata.XYZdim[1] := 512; + lDICOMdata.XYZdim[2] := 512; + lDICOMdata.XYZdim[3] := 1; + lDICOMdata.ImageStart := 8192; + end else + if filesz = (8192 + (256*256*2)) then begin + lDICOMdata.XYZdim[1] := 256; + lDICOMdata.XYZdim[2] := 256; + lDICOMdata.XYZdim[3] := 1; + lDICOMdata.ImageStart := 8192; + end else begin + Msg('This file is the incorrect size to be a Picker image.'); + CloseFile(fp); + FileMode := 2; //set to read/write + exit; + end; + getmem(lDiskCacheRA,kPickerHeader*sizeof(char)); + seek(fp, 0); + BlockRead(fp, lDiskCacheRA, kPickerHeader, n); + lRecSz := 0; + lNumRecs := 0; + lPos := 5; + if not FindStr('d','b','r','e','c',false, lVal) then goto 423; + lDBPos := lPos; + if not FindStr('r','e','c','s','z',true, lRecSz) then goto 423; + lPos := lDBPos; + if not FindStr('n','r','e','c','s',true, lnumRecs) then goto 423; + lPos := kRecStart; // IS THIS A CONSTANT??? + lDataStart :=kRecStart + (lRecSz*lnumRecs)-1; //file starts at 0, so -1 + if (lNumRecs = 0) or (lDataStart> kPickerHeader) then goto 423; + lRec := 0; + lDynStr := 'Picker Format'; + repeat + inc(lRec); + until (not (ReadRec(lRec))) or (lRec >= lnumRecs); + if lSiz <> 0 then begin + lDICOMdata.XYZmm[1] := lSiz/lDICOMdata.XYZdim[1]; + lDICOMdata.XYZmm[2] := lSiz/lDICOMdata.XYZdim[2]; + if lVerboseRead then + lDynStr := lDynStr+kCR+'Voxel Size: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2) + +'x'+ floattostrf(lDicomData.XYZmm[2],ffFixed,8,2); + end; + if (lThkM <> 0) and (lThkN <> 0) then begin + lDICOMdata.XYZmm[3] := lThkN/lThkM; + if lVerboseRead then + lDynStr := lDynStr+kCR+'Slice Thickness: '+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + end; + 423: + freemem(lDiskCacheRA); + lHdrOK := true; + CloseFile(fp); + FileMode := 2; //set to read/write +end; +//end picker + +procedure read_minc_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +var +// lReal: double; + lnOri,lnDim,lStartPosition,nelem0,jj,lDT0,vSizeRA,BeginRA,m,nnelem,nc_type,nc_size,lLen,nelem,j,lFilePosition,lDT,lFileSz,lSignature,lWord: integer; + + lOri: array [1..3] of double; + //tx : array [0..80] of Char; + lVarStr,lStr: string; + FP: file; +function dTypeStr (lV: integer): integer; +begin + case lV of + 1,2: result := 1; + 3: result := 2; //int16 + 4: result := 4; //int32 + 5: result := 4; //single + 6: result := 8; //double + end; +end; //nested fcn dTypeStr + +function read32i: Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lFilePosition); + lFilePosition := lFilePosition + 4; + BlockRead(fp, s, 4); + inguy := @s; //assign address of s to inguy + if lDICOMdata.Little_Endian = 0 then begin + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + end else + outguy.long := inguy^.long; + result:=outguy.Long; +end; + +function read64r (lDataType: integer): Double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(Long:Double); + end; + swaptypep = ^swaptype; +var + s : Double; + inguy:swaptypep; + outguy:swaptype; +begin + result := 1; + if lDataType <> 6 then begin + Msg('Unknown data type: MRIcro is unable to determine the voxel size.'); + exit; + end; + seek(fp,lFilePosition); + lFilePosition := lFilePosition + 8; + BlockRead(fp, s, 8); + inguy := @s; //assign address of s to inguy + if lDICOMdata.Little_Endian = 0 then begin + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + end else + outguy.long := inguy^.long; + result:=outguy.Long; +end; + +function readname: String; +var lI,lLen: integer; + lCh: char; +begin + result := ''; + seek(fp,lFilePosition); + lLen := read32i; + if lLen < 1 then begin + Msg('Terminal error reading netCDF/MINC header (String length < 1)'); + exit; //problem + end; + for lI := 1 to lLen do begin + BlockRead(fp, lCh, 1); + result := result + lCh; + end; + lFilePosition := lFilePosition + (((lLen+3) div 4) * 4); +end; + +begin + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + for lnOri := 1 to 3 do + lOri[lnOri] := 0; + lnOri := 4; + lnDim := 4; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if lFilesz < (77) then exit; //to small to be MINC + + lFilePosition := 0; + lSignature := read32i; + if not (lSignature=1128547841) then begin + CloseFile(fp); + FileMode := 2; //set to read/write + Msg('Problem with MINC signature: '+ inttostr(lSignature)); + exit; + end; + //xlDicomData.Rotate180deg := true; + lWord := read32i;//numrecs + lDT := read32i; + while (lDt=10) or (lDT=11) or (lDT=12) do begin + if lDT = 10 then begin //DT=10, Dimensions + nelem := read32i; + for j := 1 to nelem do begin + lStr := readname; + lLen := read32i; + if lStr = 'xspace' then lDicomData.XYZdim[3] := lLen;//DOES MINC always reverse X and Z? see also XYZmm + if lStr = 'yspace' then lDicomData.XYZdim[2] := lLen; + if lStr = 'zspace' then lDicomData.XYZdim[1] := lLen; + end; //for 1..nelem + lDT := read32i; + end;//DT=10, Dimensions + if lDT = 11 then begin //DT=11, Variables + nelem := read32i; + for j := 1 to nelem do begin + lVarStr := readname; + nnelem := read32i; + for m := 1 to nnelem do + lLen := read32i; + lDT0 := read32i; + if lDT0 = 12 then begin + nelem0 := read32i; + for jj := 1 to nelem0 do begin + lStr := readname; + nc_type := read32i; + nc_size := dTypeStr(nc_Type); + nnelem := read32i; + lStartPosition := lFilePosition; + + if (lStr = 'step') then begin + + if (lVarStr = 'xspace') or (lVarStr = 'yspace') or (lVarStr = 'zspace') then begin + dec(lnDim); + if (lnDim < 4) and (lnDim>0) then + lDicomData.XYZmm[lnDim] := read64r(nc_Type) + end; + + end else if (lStr = 'start') then begin + if (lVarStr = 'xspace') or (lVarStr = 'yspace') or (lVarStr = 'zspace') then begin + dec(lnOri); + if (lnOri < 4) and (lnOri > 0) then + lOri[lnOri] := read64r(nc_Type) + end; + end; + lFilePosition := lStartPosition + ((((nnelem*nc_size)+3) div 4)*4); + + end; + lDT0 := read32i; + if lVarStr = 'image' then begin + case lDT0 of + 1,2: lDicomData.Allocbits_per_pixel := 8; + 3: lDicomData.Allocbits_per_pixel := 16; //int16 + 4: lDicomData.Allocbits_per_pixel := 32; //int32 + 5: lDicomData.Allocbits_per_pixel := 32; //single + 6: lDicomData.Allocbits_per_pixel := 64; //double + end; + if (lDT0 = 5) or (lDT0 = 6) then + lDicomData.FloatData := true; + //xlDicomData.Storedbits_per_pixel := lDicomData.Allocbits_per_pixel; + //lImgNC_Type := lDT0; + end; + end; + vSizeRA := read32i; + BeginRA := read32i; + if lVarStr = 'image' then begin + lDICOMdata.ImageStart := BeginRA; + end; + end; //for 1..nelem + lDT := read32i; + end;//DT=11 + if lDT = 12 then begin //DT=12, Attributes + nelem := read32i; + for j := 1 to nelem do begin + lStr := readname; + nc_type := read32i; + nc_size := dTypeStr(nc_Type); + nnelem := read32i; + lFilePosition := lFilePosition + ((((nnelem*nc_size)+3) div 4)*4); + end; //for 1..nelem + lDT := read32i; + end;//DT=12, Dimensions + end; //while DT + + if lOri[1] <> 0 then + lDicomData.XYZori[1] := round((-lOri[1])/lDicomData.XYZmm[1])+1; + if lOri[2] <> 0 then + lDicomData.XYZori[2] := round((-lOri[2])/lDicomData.XYZmm[2])+1; + if lOri[3] <> 0 then + lDicomData.XYZori[3] := round((-lOri[3])/lDicomData.XYZmm[3])+1; + + lDynStr := 'MINC image'+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ origin:' +inttostr(lDicomData.XYZori[1])+'/' + +inttostr(lDicomData.XYZori[2])+'/'+inttostr(lDicomData.XYZori[3]) + +kCR+'XYZ size [mm or micron]:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'Bits per sample/Samples per pixel: '+inttostr( lDICOMdata.Allocbits_per_pixel) + +kCR+'Data offset:' +inttostr(lDicomData.ImageStart); + lHdrOK := true; + lImageFormatOK := true; + CloseFile(fp); + FileMode := 2; //set to read/write +end; //read_minc + + + +//start TIF +procedure read_tiff_data(var lDICOMdata: DICOMdata; var lReadOffsets, lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +label + 566, 564; +const + kMaxnSLices = 6000; +var + lLongRA: LongIntP; + lStackSameDim,lContiguous: boolean; + l1stDicomData: DicomData; + //lDouble : double; + //lXmm,lYmm,lZmm: double; + lSingle: single; + lImageDataEndPosition,lStripPositionOffset,lStripPositionType,lStripPositionItems, + lStripCountOffset,lStripCountType,lStripCountItems, + lItem,lTagItems,lTagItemBytes,lTagPointer,lNumerator, lDenominator, + lImage_File_Directory,lTagType,lVal,lDirOffset,lOffset,lFileSz, + lnDirectories,lDir,lnSlices: Integer; + lTag,lWord,lWord2: word; + FP: file; +(*FUNCTION longint2single ({var} s:longint): single; +//returns true if s is Infinity, NAN or Indeterminate +//4byte IEEE: msb[31] = signbit, bits[23-30] exponent, bits[0..22] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +VAR Overlay: Single ABSOLUTE s; +BEGIN + result := Overlay; +END;*) + +function read64r(lPos: integer):double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; + s: double; +begin + seek(fp,lPos); + BlockRead(fp, s, 8); + inguy := @s; //assign address of s to inguy + if lDICOMdata.Little_Endian = 0{false} then begin + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + end else + outguy.float := inguy^.float; + result:=outguy.float; +end; + +function read32i(lPos: longint): Longint; +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + s : LongInt; + inguy:swaptypep; + outguy:swaptype; +begin + seek(fp,lPos); + BlockRead(fp, s, 4); + inguy := @s; //assign address of s to inguy + if lDICOMdata.Little_Endian = 0 then begin + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + end else + outguy.long := inguy^.long; + result:=outguy.Long; +end; +function read16(lPos: longint): Longint; +var + s : word; +begin + seek(fp,lPos); + BlockRead(fp, s, 2); + if lDICOMdata.Little_Endian = 0 then + result := swap(s) + else + result := s; +end; + +function read8(lPos: longint): Longint; +var + s : byte; +begin + seek(fp,lPos); + BlockRead(fp, s, 1); + result := s; +end; + +function readItem(lItemNum,lTagTypeI,lTagPointerI: integer): integer; +begin + if lTagTypeI= 4 then + result := read32i(lTagPointerI+((lItemNum-1)*4)) + else + result := read16(lTagPointerI+((lItemNum-1)*2)); +end; + +begin + Clear_Dicom_Data(lDicomData); + if gECATJPEG_table_entries <> 0 then begin + freemem (gECATJPEG_pos_table); + freemem (gECATJPEG_size_table); + gECATJPEG_table_entries := 0; + end; + //lXmm := -1; //not read + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + //lLongRASz := kMaxnSlices * sizeof(longint); + getmem(lLongRA,kMaxnSlices*sizeof(longint)); + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + //xlDicomData.PlanarConfig:=0; + if lFilesz < (28) then begin + goto 566; + end; + //TmpStr := string(StrUpper(PChar(ExtractFileExt(lFileName)))); + //if not (TmpStr = '.TIF') or (TmpStr = '.TIFF') then exit; + lWord := read16(0); + if lWord = $4d4d then + lDICOMdata.little_endian := 0 + else if lWord = $4949 then lDICOMdata.little_endian := 1; + lWord2 := read16(2); //bits per pixel + if ((lWord=$4d4d) or (lWord=$4949)) and (lWord2 = $002a) then + else goto 566; + lOffset := read32i(4); + lImage_File_Directory := 0; + lContiguous := true; + lnSlices := 0; + //xlDicomData.SamplesPerPixel := 1; + //START while for each image_file_directory + while (lOffset > 0) and ((lOffset+2+12+4) < lFileSz) do begin + inc(lImage_File_Directory); + lnDirectories := read16(lOffset); + if (lnDirectories < 1) or ((lOffset+2+(12*lnDirectories)+4) > lFileSz) then + goto 566; + for lDir := 1 to lnDirectories do begin + lDirOffset := lOffset+2+((lDir-1)*12); + lTag := read16(lDirOffset); + lTagType := read16(lDirOffset+2); + lTagItems := read32i(lDirOffset+4); + case lTagType of + 1: lVal := 1;//bytes + 3: lVal := 2;//word + 4: lVal := 4;//long + 5: lVal := 8;//rational + else lVal := 1; //CHAR variable length + end; + lTagItemBytes := lVal * lTagItems; + if lTagItemBytes > 4 then + lTagPointer := read32i(lDirOffset+8) + else + lTagPointer := (lDirOffset+8); + case lTagType of + 1: lVal := read8(lDirOffset+8); + 3: lVal := read16(lDirOffset+8); + 4: lVal := read32i(lDirOffset+8); + 5: begin //rational: two longs representing numerator and denominator + lVal := read32i(lDirOffset+8); + lNumerator := read32i(lVal); + lDenominator := read32i(lVal+4); + if lDenominator <> 0 then + lSingle := lNumerator/lDenominator + else + lSingle := 1; + if lSingle <> 0 then + lSingle := 1/lSingle; //Xresolution/Yresolution refer to number of pixels per resolution_unit + if lTag = 282 then lDicomData.XYZmm[1] := lSingle; + if lTag = 283 then lDicomData.XYZmm[2] := lSingle; + end; + else lVal := 0; + end; + case lTag of + //254: ;//NewSubFileType + 256: lDicomData.XYZdim[1] := lVal;//image_width + 257: lDicomData.XYZdim[2] := lVal;//image_height + 258: begin //bits per sample + if lTagItemBytes > 4 then lVal := 8; + //if lVal <> 8 then goto 566; + lDicomData.Allocbits_per_pixel := lVal;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + end; + 259: begin + if lVal <> 1 then begin + Msg('TIFF Read Error: Image data is compressed. Currently only uncompressed data is supported.'); + goto 566; //compressed data + end; + end; + //x262: if lVal = 0 then lDicomdata.monochrome := 1;//invert colors //photometric_interpretation //MinIsWhite,MinIsBlack,Palette + //270: ; //ImageDescription + 273: begin //get offset to data + lStripPositionOffset := lTagPointer; + lStripPositionType := lTagType; + lStripPositionItems := lTagItems; + if (lImage_File_Directory=1) then + lDicomData.ImageStart := readItem(1,lStripPositionType,lStripPositionOffset); + end; //StripOffsets + //274: ; //orientation + 277: begin + //xlDicomData.SamplesPerPixel := lVal; + //if lVal <> 1 then goto 566; //samples per pixel + end; + 279: begin + lStripCountOffset := lTagPointer; + lStripCountType := lTagType; + lStripCountItems := lTagItems; + end; + //278: message('rows:'+inttostr(lVal));//StripByteCount + //279: message('count:'+inttostr(lVal));//StripByteCount + //282 and 283 are rational values and read separately + 284: begin + {xif lVal = 1 then + lDicomData.PlanarConfig:= 0 + else + lDicomData.PlanarConfig:= 1;//planarConfig + } end; + 34412: begin + //Zeiss data header + //0020h float x size of a pixel (µm or s) + //0024h float y size of a pixel (µm or s) + //0028h float z distance in a sequence (µm or s) + {stream.seek((int)position + 40); + VOXELSIZE_X = swap(stream.readDouble()); + stream.seek((int)position + 48); + VOXELSIZE_Y = swap(stream.readDouble()); + stream.seek((int)position + 56); + VOXELSIZE_Z = swap(stream.readDouble());} + lVal := read16(lTagPointer+2); + if lVal = 1024 then begin //LSM510 v2.8 images + lDicomData.XYZmm[1]{lXmm} := read64r(lTagPointer+40)*1000000; + lDicomData.XYZmm[2]{lYmm} := read64r(lTagPointer+48)*1000000; + lDicomData.XYZmm[3]{lZmm} := read64r(lTagPointer+56)*1000000; + end; + //following may work if lVal = 2, different type of LSM file I have not seen + //lXmm := longint2single(read32i(lTagPointer+$0020)); + //lYmm := longint2single(read32i(lTagPointer+$0024)); + //lZmm := longint2single(read32i(lTagPointer+$0028)); + end; + //296: ;//resolutionUnit 1=undefined, 2=inch, 3=centimeter + //320?? + //LEICA: 34412 + //SOFTWARE = 305 + //DATE_TIME = 306 + //ARTIST = 315 + //PREDICTOR = 317 + //COLORMAP = 320 => essntially custom LookUpTable + //EXTRASAMPLES = 338 + //SAMPLEFORMAT = 339 + //JPEGTABLES = 347 + // lDicomData.ImageStart := lVal + //else if lImage_File_Directory = 1 then Msg(inttostr(lTag)+'@'+inttostr(lTagPointer)+' value: '+inttostr(lVal)); + end; //case lTag + end; //For Each Directory in Image_File_Directory + lOffset := read32i(lOffset+2+(12*lnDirectories)); + //NEXT: check that each slice in 3D slice is the same dimension + lStackSameDim := true; + if (lImage_File_Directory=1) then begin + l1stDicomData := lDICOMdata; + lnSlices := 1; //inc(lnSlices); + end else begin + if lDicomData.XYZdim[1] <> l1stDicomData.XYZdim[1] then lStackSameDim := false; + if lDicomData.XYZdim[2] <> l1stDicomData.XYZdim[2] then lStackSameDim := false; + if lDicomData.Allocbits_per_pixel <> l1stDicomData.Allocbits_per_pixel then lStackSameDim := false; + //xif lDicomData.SamplesPerPixel <> l1stDicomData.SamplesPerPixel then lStackSameDim := false; + //xif lDicomData.PlanarConfig <> l1stDicomData.PlanarConfig then lStackSameDim := false; + if not lStackSameDim then begin + //Msg(inttostr(lDicomData.XYZdim[1])+'x'+inttostr(l1stDicomData.XYZdim[1])); + if (lDicomData.XYZdim[1]*lDicomData.XYZdim[2]) > (l1stDicomData.XYZdim[1]*l1stDicomData.XYZdim[2]) then begin + l1stDicomData := lDICOMdata; + lnSlices := 1; + lStackSameDim := true; + end; + //Msg('TIFF Read Error: Different 2D slices in this 3D stack have different dimensions.'); + //goto 566; + end else + inc(lnSlices); //if not samedim + end; //check that each slice is same dimension as 1st + //END check each 2D slice in 3D stack is same dimension + //NEXT: check if image data is contiguous + if (lStripCountItems > 0) and (lStripCountItems = lStripPositionItems) then begin + if (lnSlices=1) then lImageDataEndPosition := lDicomData.ImageStart; + for lItem := 1 to lStripCountItems do begin + lVal := readItem(lItem,lStripPositionType,lStripPositionOffset); + if (lVal <> lImageDataEndPosition) then + lContiguous := false; + //Msg(inttostr(lImage_File_Directory)+'@'+inttostr(lItem)); + lImageDataEndPosition := lImageDataEndPosition+readItem(lItem,lStripCountType,lStripCountOffset); + if not lcontiguous then begin + if (lReadOffsets) and (lStackSameDim) then begin + lLongRA^[lnSlices] := lVal; + end else if (lReadOffsets) then + //not correct size, but do not generate an error as we will read non-contiguous files + else begin + Msg('TIFF Read Error: Image data is not stored contiguously. '+ + 'Solution: convert this image using MRIcro''s ''Convert TIFF/Zeiss to Analyze...'' command [Import menu].'); + goto 564; + end; + end; //if not contiguous + end; //for each item + end;//at least one StripItem} + //END check image data is contiguous + end; //END while each Image_file_directory + lDicomData := l1stDicomData; + lDicomData.XYZdim[3] := lnSlices; + if (lReadOffsets) and (lnSlices > 1) and (not lcontiguous) then begin + gECATJPEG_table_entries := lnSlices; //Offset tables for TIFF + getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint)); + getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint)); + gECATJPEG_pos_table^[1] := l1stDicomData.ImageStart; + for lVal := 2 to gECATJPEG_table_entries do + gECATJPEG_pos_table^[lVal] := lLongRA^[lVal] + end; + lHdrOK := true; +564: + lDynStr := 'TIFF image'+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ size [mm or micron]:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'Bits per sample/Samples per pixel: '+inttostr( lDICOMdata.Allocbits_per_pixel) + +kCR+'Data offset:' +inttostr(lDicomData.ImageStart); + {if lXmm > 0 then + lDynStr := lDynStr +kCR+'Zeiss XYZ mm:'+floattostr(lXmm)+'/' + +floattostr(lYmm)+'/' + +floattostr(lZmm);} +566: + freemem(lLongRA); + CloseFile(fp); + FileMode := 2; //set to read/write +end; + +procedure read_biorad_data(var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;lFileName: string); +var + lCh: char; + lByte: Byte; + lSpaces,liPos,lFileSz,lWord,lNotes,lStart,lEnd: integer; + tx : array [0..80] of Char; + lInfo,lStr,lTmpStr: string; + FP: file; +procedure read16(lPos: longint; var lVal: integer); +var lInWord: word; +begin + seek(fp,lPos); + BlockRead(fp, lInWord, 2); + lVal := lInWord; +end; +procedure read32(lPos: longint; var lVal: integer); +var lInINt: integer; +begin + seek(fp,lPos); + BlockRead(fp, lInINt, 4); + lVal :=lInINt; +end; + +begin + lImageFormatOK := true; + lHdrOK := false; + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + Clear_Dicom_Data(lDicomData); + if lFilesz < (77) then exit; //to small to be biorad + read16(54,lWord); + if (lWord=12345) then begin + lDicomData.little_endian := 1; + read16(0,lDicomData.XYZdim[1]); + read16(2,lDicomData.XYZdim[2]); + read16(4,lDicomData.XYZdim[3]); + read16(14,lWord);//byte format + if lWord = 1 then + lDicomData.Allocbits_per_pixel := 8 + else + lDicomData.Allocbits_per_pixel := 16;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lDicomData.ImageStart := 76; + read32(10,lNotes); + lStart := (lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*lDicomData.XYZdim[3])+76; + lEnd := lStart + 96; + lDynStr := 'BIORAD PIC image'+kCR; + while (lNotes > 0) and (lFileSz >= lEnd) do begin + read32(lStart+2,lNotes); //final note has bytes 2..5 set to zero + //read16(lStart+10,lNoteType); + //if lNoteType <> 1 then begin //ignore 'LIVE' notes - they do not include calibration info + seek(fp, lStart+16); + BlockRead(fp, tx, 80{, n}); + lStr := ''; + liPos := 0; + repeat + lCh := tx[liPos]; + lByte := ord(lCh); + if (lByte >= 32) and (lByte <= 126) then + lStr := lStr+lCh + else lByte := 0; + inc(liPos); + until (liPos = 80) or (lByte = 0); + if length(lStr) > 6 then begin + lInfo := ''; + for liPos := 1 to 6 do + lInfo := lInfo+upcase(lStr[liPos]); + ltmpstr := ''; + lSpaces := 0; + for liPos := 1 to 80 do begin + if lStr[liPos]=' ' then inc(lSpaces) + else if lSpaces = 3 then + ltmpstr := ltmpstr + lStr[liPos]; + end; + if ltmpstr = '' then {no value to read} + else if lInfo = 'AXIS_2' then + lDicomData.XYZmm[1] := strtofloat(ltmpstr) + else if lInfo = 'AXIS_3' then + lDicomData.XYZmm[2] := strtofloat(ltmpstr) + else if linfo = 'AXIS_4' then + lDicomData.XYZmm[3] := strtofloat(ltmpstr); + lDynStr := lDynStr+lStr+kCR; + end; //Str length > 6 + //end;//notetype + lStart := lEnd; + lEnd := lEnd + 96; + end; //while notes + lHdrOK := true; + //lImageFormatOK := true; + end;//biorad signature + CloseFile(fp); + FileMode := 2; //set to read/write + lDynStr := 'BioRad image'+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ size [mm or micron]:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'Bits per sample/Samples per pixel: '+inttostr( lDICOMdata.Allocbits_per_pixel) + +kCR+'Data offset:' +inttostr(lDicomData.ImageStart); +end; //biorad + +function SiemensVersion (lStr: string): integer; +//Convert tag 0018,1020 from DICOM header to Siemens version number +(*Returned value: system is in 1000s, last two digits are version + Siemens syngo MR 2006T 4VB12T //-> 0012 +MR B13 4VB13A //->0013 +MR.VB15A123 //->0015 +syngo MR B15 //-> 0015 +syngo MR B17 //->0017 B= Trio, Verio, Etc +syngo MR C11 //->1011 C= Chinese C11 ~ B17 +syngo MR D11 //->2011 D= Skyra D11 ~ B17*) +label 999; +var + i,len: integer; +begin + result := 0; + len := length(lStr); + if len < 3 then exit; + for i := 1 to len-1 do + if (upcase(lStr[i]) in ['A'..'Z']) and (lStr[i+1] in ['0'..'9']) then + goto 999; + exit; //not Siemens format +999: + result := strtoint(lStr[i+1]); + if lStr[i+2] in ['0'..'9'] then + result := (result*10) + strtoint(lStr[i+2]); + result := (100*( ord(upcase(lStr[i]))- ord('B'))) + result; +end; +(* Obsolete - replaced by SiemensVersion +function SiemensBversion (lStr: string): integer; +//'syngo MR B17' returns 17 +//'MR.VB15A123' returns 15 +//'syngo MR B15' returns 15 +//'MR B13 4VB13A' returns 13 +//'syngo MR 2006T 4VB12T' returns 12 +var + Len,P,B: integer; + S: string; +begin + result := 0; + Len := length(lStr); + if Len <2 then exit; + B := 0; + for P := 2 to (Len) do + if (upcase(lStr[P-1])='B') and ( lStr[P] in ['0'..'9']) then + B := P; + if B < 1 then + exit; + S := ''; + while (B<= Len) and (lStr[B] in ['0'..'9']) do begin + S := S + lStr[B]; + inc(B); + end; + if length(S) < 1 then exit; + result := strtoint(S); +end;*) + +(*function Str2IntDig (lStr: string; lDig: integer): integer; +//robust stringtoint that strips out any junk so that "Implementation Version Name=MR.VB15A123" returns 15 +// warning, strips out decimals, so 15.3 will return 153! +//warning also ignores minus sign so -5.21 will return 521! +var + Len,P: integer; + S: string; +begin + result := 0; + Len := length(lStr); + if Len <1 then exit; + S := ''; + for P := 1 to Len do + if (lStr[P] in ['0'..'9']) and (length(S) < lDig) then + S := S + lStr[P]; + if length(S) < 1 then exit; + result := strtoint(S); +end; *) + +function ExpectedDicomBytes (var lDICOMdata: DICOMdata): integer; +begin + if lDicomData.JPEGLosslessCpt then begin + result := 0; //actual compressed size unknown + exit; + end; + result := lDicomdata.XYZdim[1]*lDicomdata.XYZdim[2]*lDicomdata.XYZdim[3]*(lDicomData.Allocbits_per_pixel DIV 8); +end; + +procedure read_dicom_data_compat(lReadJPEGtables,lVerboseRead,lAutoDECAT7,lReadECAToffsetTables,lAutoDetectInterfile,lAutoDetectGenesis,lReadColorTables: boolean; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK: boolean; var lDynStr: string;var lFileName: string; var lPrefs: TPrefs); +label 666,777; +const + kMaxTextBuf = 50000; //maximum for screen output + kDiskCache = 16384; //size of disk buffer + kNaNsingle : single = 1/0; + +type + dicom_types = (unknown, i8, i16, i32, ui8, ui16, ui32, _string{,_float} ); +var + // lTextF: TextFile; //abba + lDICOMdataBackUp: DICOMdata; + lWord,lWord2,lWord3: word; + lWordRA: Wordp; + lDiskCacheRA: pChar{ByteP}; + lRot1,lRot2,lRot3 : integer;//rotation dummies for AFNI + FP: file; + lT0,lT1,lT2,lT3:byte; + lImagePositionPatientRead, + lResearchMode,lManufacturerIsPhilips,lManufacturerIsBruker,lMediface0002_0013,lSiemensMosaic0008_0008,lDICM_at_128, lTextOverFlow,lGenesis,lFirstPass,lrOK,lBig,lBigSet,lGrp,explicitVR,first_one : Boolean; + lSwitchToImplicitAfterGroup0002, lTestError,lByteSwap,lGELX,time_to_quit,lProprietaryImageThumbnail,lFirstFragment,lOldSiemens_IncorrectMosaicMM : Boolean; + group, element, e_len, remaining, tmp : uint32; + tmpstr : kDICOMstr; + lgrpstr,lStr,info,lDummyStr : string; + t : dicom_types; + lfloat1,lfloat2,lfloat3,lThickness: double; + lTempInt,lEchoNum,lnVol,lnSlicePerVol,lJPEGentries,lErr,liPos,lCacheStart,lCachePos,lDiskCacheSz,n, i,value, Ht,Width, + max16,min16,filesz,where,lMatrixSz,lPhaseEncodingSteps,lJunk,lJunk2,lJunk3 : LongInt; + tx : array [0..96] of Char; + l4DDistanceBetweenSliceCenters,lPhilipsScaleSlope: single; + buff: pCHar; + lColorRA: bytep; + lLongRA: Longintp; + lSingleRA,lInterceptRA: Singlep; + //lPapyrusnSlices,lPapyrusSlice : integer; + //lPapyrusZero,lPapyrus : boolean; +procedure ByteSwap (var lInOut: integer); +var lWord: word; +begin + lWord := lInOut; + lWord := swap(lWord); + lInOut := lWord; +end; +procedure dReadCache (lFileStart: integer); +begin + lCacheStart := lFileStart{lCacheStart + lDiskCacheSz};//eliminate old start + if lCacheStart < 0 then lCacheStart := 0; + if lDiskCacheSz > 0 then freemem(lDiskCacheRA); + if (FileSz-(lCacheStart)) < kDiskCache then + lDiskCacheSz := FileSz - (lCacheStart) + else + lDiskCacheSz := kDiskCache; + lCachePos := 0; + if (lDiskCacheSz < 1) then exit{goto 666}; + if (lDiskCacheSz+lCacheStart) > FileSz then exit; + Seek(fp, lCacheStart); + + GetMem(lDiskCacheRA, lDiskCacheSz {bytes}); + BlockRead(fp, lDiskCacheRA^, lDiskCacheSz, n); +end; + +function dFilePos (var lInFP: file): integer; +begin + Result := lCacheStart + lCachePos; +end; +procedure dSeek (var lInFP: file; lPos: integer); +begin + if (lPos >= lCacheStart) and (lPos < (lDiskCacheSz+lCacheStart)) then begin + lCachePos := lPos-lCacheStart; + exit; + end; + dReadCache(lPos); +end; + +procedure dBlockRead (var lInfp: file; lInbuff: pChar; e_len: integer; var n: integer); +var lN: integer; +begin + N := 0; + if e_len < 0 then exit; + for lN := 0 to (e_len-1) do begin + if lCachePos >= lDiskCacheSz then begin + dReadCache(lCacheStart+lDiskCacheSz); + if lDiskCacheSz < 1 then exit; + lCachePos := 0; + end; + N := lN; + lInBuff[N] := lDiskCacheRA[lCachePos]; + inc(lCachePos); + end; +end; +procedure readfloats (var fp: file; remaining: integer; var lOutStr: string; var lf1, lf2: double; var lReadOK: boolean); +var lDigit : boolean; + li,lLen,n: integer; + lfStr: string; +begin + lf1 := 1; + lf2 := 2; + if e_len = 0 then begin + lReadOK := true; + exit; + end; + if (dFilePos(fp) > (filesz-remaining)) or (remaining < 1) then begin + lOutStr := ''; + lReadOK := false; + exit; + end else + lReadOK := true; + lOutStr := ''; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in [{'/','\', delete: rev18}'e','E','+','-','.','0'..'9'] + then lOutStr := lOutStr +(Char(buff[li])) + else begin + lOutStr := lOutStr + ' '; + end; + FreeMem( buff); + lfStr := ''; + lLen := length(lOutStr); + + li := 1; + lDigit := false; + repeat + if (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then + lfStr := lfStr + lOutStr[li]; + if lOutStr[li] in ['0'..'9'] then lDigit := true; + inc(li); + until (li > lLen) or (lDigit); + if not lDigit then exit; + if li <= li then begin + repeat + if not (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then lDigit := false + else begin + if lOutStr[li] = 'E' then lfStr := lfStr+'e' + else + lfStr := lfStr + lOutStr[li]; + end; + inc(li); + until (li > lLen) or (not lDigit); + end; + //QStr(lfStr); + try + lf1 := strtofloat(lfStr); + except + on EConvertError do begin + Msg('Unable to convert the string '+lfStr+' to a real number'); + lf1 := 1; + exit; + end; + end; {except} + lfStr := ''; + if li > llen then exit; + repeat + if (lOutStr[li] in ['+','E','e','.','-','0'..'9']) then begin + if lOutStr[li] = 'E' then lfStr := lfStr+'e' + else + lfStr := lfStr + lOutStr[li]; + end; + if (lOutStr[li] in ['0'..'9']) then lDigit := true; + inc(li); + until (li > lLen) or ((lDigit) and (lOutStr[li]=' ')); //second half: rev18 + if not lDigit then exit; + //QStr(lfStr); + try + lf2 := strtofloat(lfStr); + except + on EConvertError do begin + Msg('Unable to convert the string '+lfStr+' to a real number'); + exit; + end; + end; + +end; + +procedure readfloats3 (var fp: file; remaining: integer; var lOutStr: string; var lf1, lf2,lf3: double; var lReadOK: boolean); +var lDigit : boolean; + lItem,li,lLen,n: integer; + lfTemp: double; + lfStr: string; +begin + lf1 := 0; + lf2 := 0; + lf3 := 0; + lOutStr := ''; + if e_len = 0 then begin + lReadOK := true; + exit; + end; + if (dFilePos(fp) > (filesz-remaining)) or (remaining < 1) then begin + lReadOK := false; + exit; + end else + lReadOK := true; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in [{'/','\', delete: rev18}'e','E','+','-','.','0'..'9'] + then lOutStr := lOutStr +(Char(buff[li])) + else lOutStr := lOutStr + ' '; + FreeMem( buff); + li := 1; + lLen := length(lOutStr); + for lItem := 1 to 3 do begin + if li > llen then exit; + lfStr := ''; + lLen := length(lOutStr); + lDigit := false; + repeat + if (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then + lfStr := lfStr + lOutStr[li]; + if lOutStr[li] in ['0'..'9'] then lDigit := true; + inc(li); + until (li > lLen) or (lDigit); + if not lDigit then exit; + if li <= li then begin + repeat + if not (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then lDigit := false + else begin + if lOutStr[li] = 'E' then lfStr := lfStr+'e' + else + lfStr := lfStr + lOutStr[li]; + end; + inc(li); + until (li > lLen) or (not lDigit); + end; + //QStr(lfStr); + try + lftemp := strtofloat(lfStr); + except + on EConvertError do begin + Msg('Unable to convert the string '+lfStr+' to a real number'); + //lftemp := 0; + exit; + end; + end; {except} + case lItem of + 2: lf2 := lftemp; + 3: lf3 := lftemp; + else lf1 := lftemp; + end; //case of lItem +end; //for each of 3 lItems +end; //readfloats3 + +procedure CheckIntersliceDistance (var lMinDistance: single); +var + lX,lY,lZ,lDx: double; +begin + readfloats3 (fp, remaining, lDummyStr, lX, lY,lZ, lROK); + // fx( lX, lY,lZ,6789); + e_len := 0; + remaining := 0; + //compute Distance between current slice and 1st slice... + lDx := sqrt( sqr(lX-lDicomData.PatientPosX)+sqr(lY-lDicomData.PatientPosY)+sqr(lZ-lDicomData.PatientPosZ)); + if (lDx > 0) and (lMinDistance = kNaNsingle) then //first value + lMinDistance := lDx + else if (lDx > 0) and (lDx < lMinDistance) then //if 0 then this is a repeat, not a new slice + lMinDistance := lDx + else + exit; +end; + +procedure readfloats6 (var fp: file; remaining: integer; var lOutStr: string; var lf1, lf2,lf3,lf4,lf5,lf6: double; var lReadOK: boolean); +var lDigit : boolean; + lItem,li,lLen,n: integer; + lfTemp: single; + lfStr: string; +begin + lf1 := 0; + lf2 := 0; + lf3 := 0; + lf4 := 0; + lf5 := 0; + lf6 := 0; + lOutStr := ''; + if e_len = 0 then begin + lReadOK := true; + exit; + end; + if (dFilePos(fp) > (filesz-remaining)) or (remaining < 1) then begin + lReadOK := false; + exit; + end else + lReadOK := true; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in [{'/','\', delete: rev18}'e','E','+','-','.','0'..'9'] + then lOutStr := lOutStr +(Char(buff[li])) + else lOutStr := lOutStr + ' '; + FreeMem( buff); + li := 1; + lLen := length(lOutStr); + for lItem := 1 to 6 do begin + if li > llen then exit; + lfStr := ''; + lLen := length(lOutStr); + lDigit := false; + repeat + if (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then + lfStr := lfStr + lOutStr[li]; + if lOutStr[li] in ['0'..'9'] then lDigit := true; + inc(li); + until (li > lLen) or (lDigit); + if not lDigit then exit; + if li <= li then begin + repeat + if not (lOutStr[li] in ['+','-','e','E','.','0'..'9']) then lDigit := false + else begin + if lOutStr[li] = 'E' then lfStr := lfStr+'e' + else + lfStr := lfStr + lOutStr[li]; + end; + inc(li); + until (li > lLen) or (not lDigit); + end; + + //QStr(lfStr); + try + lftemp := strtofloat(lfStr); + except + on EConvertError do begin + Msg('Unable to convert the string '+lfStr+' to a real number'); + //lftemp := 0; + exit; + end; + end; {except} + case lItem of + 2: lf2 := lftemp; + 3: lf3 := lftemp; + 4: lf4 := lftemp; + 5: lf5 := lftemp; + 6: lf6 := lftemp; + else lf1 := lftemp; + end; //case of lItem +end; //for each of 3 lItems +end; + +function read16( var fp : File; var lReadOK: boolean ): uint16; +var + t1, t2 : uint8; + n : Integer; +begin +if dFilePos(fp) > (filesz-2) then begin + read16 := 0; + lReadOK := false; + exit; +end else + lReadOK := true; + GetMem( buff, 2); + dBlockRead(fp, buff{^}, 2, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + freemem(buff); + if lDICOMdata.little_endian <> 0 + then Result := (t1 + t2*256) AND $FFFF + else Result := (t1*256 + t2) AND $FFFF; +end; + +function ReadStr(var fp: file; remaining: integer; var lReadOK: boolean; VAR lmaxval:integer) : string; +var lInc, lN,Val,n: integer; + t1, t2 : uint8; + lStr : String; +begin +lMaxVal := 0; +if dFilePos(fp) > (filesz-remaining) then begin + lReadOK := false; + exit; +end else + lReadOK := true; + Result := ''; + lN := remaining div 2; + if lN < 1 then exit; + lStr := ''; + for lInc := 1 to lN do begin + GetMem( buff, 2); + dBlockRead(fp, buff{^}, 2, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + freemem(buff); + if lDICOMdata.little_endian <> 0 then + Val := (t1 + t2*256) AND $FFFF + else + Val := (t1*256 + t2) AND $FFFF; + if lInc < lN then + lStr := lStr + inttostr(Val)+ ', ' + else + lStr := lStr + inttostr(Val); + if Val > lMaxVal then + lMaxVal := Val; + end; + Result := lStr; + if odd(remaining) then begin + getmem(buff,1); + dBlockRead(fp, buff{t1}, SizeOf(uint8), n); + freemem(buff); + end; +end; + +(*function ReadStrABC(var fp: file; remaining: integer; var lReadOK: boolean; VAR lA,lB,lC:integer) : string; +var lInc, lN,Val,n: integer; + t1, t2 : uint8; + lStr : String; +begin +lA := 0; +lB := 0; +lC := 0; +if dFilePos(fp) > (filesz-remaining) then begin + lReadOK := false; + exit; +end else + lReadOK := true; + Result := ''; + lN := remaining div 2; + if lN < 1 then exit; + lStr := ''; + for lInc := 1 to lN do begin + GetMem( buff, 2); + dBlockRead(fp, buff{^}, 2, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + freemem(buff); + if lDICOMdata.little_endian <> 0 then + Val := (t1 + t2*256) AND $FFFF + else + Val := (t1*256 + t2) AND $FFFF; + if lInc < lN then + lStr := lStr + inttostr(Val)+ ', ' + else + lStr := lStr + inttostr(Val); + if lInc = 1 then + lA := Val; + if lInc = 2 then + lB := Val; + if lInc = 3 then + lC := Val; + + + end; + Result := lStr; + if odd(remaining) then begin + getmem(buff,1); + dBlockRead(fp, buff{t1}, SizeOf(uint8), n); + freemem(buff); + end; +end; *) + +function ReadStrHex(var fp: file; remaining: integer; var lReadOK: boolean) : string; +var lInc, lN,Val,n: integer; + t1, t2 : uint8; + lStr : String; +begin +if dFilePos(fp) > (filesz-remaining) then begin + lReadOK := false; + exit; +end else + lReadOK := true; + Result := ''; + lN := remaining div 2; + if lN < 1 then exit; + lStr := ''; + for lInc := 1 to lN do begin + GetMem( buff, 2); + dBlockRead(fp, buff, 2, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + freemem(buff); + if lDICOMdata.little_endian <> 0 then + Val := (t1 + t2*256) AND $FFFF + else + Val := (t1*256 + t2) AND $FFFF; + if lInc < lN then lStr := lStr + 'x'+inttohex(Val,4)+ ', ' + else lStr := lStr + 'x'+inttohex(Val,4); + end; + Result := lStr; + if odd(remaining) then begin + getmem(buff,1); + dBlockRead(fp, {t1}buff, SizeOf(uint8), n); + freemem(buff); + end; +end; +function SomaTomFloat: double; +var lSomaStr: String; +begin + //dSeek(fp,5992); //Slice Thickness from 5790 "SL 3.0" + //dSeek(fp,5841); //Field of View from 5838 "FoV 281" + //dSeek(fp,lPos); + lSomaStr := ''; + tx[0] := 'x'; + while (length(lSomaStr) < 64) and (tx[0] <> chr(0)) and (tx[0] <> '/') do begin + dBlockRead(fp, tx, 1, n); + if tx[0] in ['+','-','.','0'..'9','e','E'] then + lSomaStr := lSomaStr + tx[0]; + end; + if length(lSOmaStr) > 0 then + result := StrToFloat(lSomaStr) + else + result := 0; +end; + +function PGMreadInt: integer; +//reads integer from PGM header, disregards comment lines (which start with '#' symbol); +var lStr: string; + lDigit: boolean; + +begin + Result := 1; + lStr := ''; + repeat + dBlockRead(fp, tx, 1, n); + if tx[0] = '#' then begin //comment + repeat + dBlockRead(fp, tx, 1, n); + until (ord(tx[0]) = $0A) or (dFilePos(fp) > (filesz-4)); //eoln indicates end of comment + end; //finished reading comment + if tx[0] in ['0'..'9'] then begin + lStr := lStr + tx[0]; + lDigit := true; + end else + lDigit := false; + until ((lStr <> '') and (not lDigit)) or (dFilePos(fp) > (filesz-4)); //read digits until you hit whitespace + if lStr <> '' then + Result := strtoint(lStr); + + {lStr := ''; + tx[0] := 'x'; + while (length(lStr) < 64) and (ord(tx[0]) <> $0A) do begin + dBlockRead(fp, tx, 1, n); + if tx[0] in ['#','+','-','.','0'..'9','e','E',' ','a'..'z','A'..'Z'] then + lStr := lStr + tx[0]; + end; + result := lStr; } +end; + +function read32 ( var fp : File; var lReadOK: boolean ): uint32; +var + t1, t2, t3, t4 : byte; + n : Integer; +begin +if dFilePos(fp) > (filesz-4) then begin + Read32 := 0; + lReadOK := false; + exit; +end else + lReadOK := true; + GetMem( buff, 4); + dBlockRead(fp, buff{^}, 4, n); + T1 := ord(buff[0]); + T2 := ord(buff[1]); + T3 := ord(buff[2]); + T4 := ord(buff[3]); + freemem(buff); + if lDICOMdata.little_endian <> 0 then + Result := t1 + (t2 shl 8) + (t3 shl 16) + (t4 shl 24) + else + Result := t4 + (t3 shl 8) + (t2 shl 16) + (t1 shl 24) + //if lDICOMdata.little_endian <> 0 + //then Result := (t1 + t2*256 + t3*256*256 + t4*256*256*256) AND $FFFFFFFF + //else Result := (t1*256*256*256 + t2*256*256 + t3*256 + t4) AND $FFFFFFFF; +end; + +function read32r ( var fp : File; var lReadOK: boolean ): single; //1382 +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(float:single); + end; + swaptypep = ^swaptype; +var + s:single; + inguy:swaptypep; + outguy:swaptype; +begin + if dFilePos(fp) > (filesz-4) then begin + read32r := 0; + lReadOK := false; + exit; + end else + lReadOK := true; + //GetMem( buff, 8); + dBlockRead(fp, @s, 4, n); + inguy := @s; //assign address of s to inguy + if lDICOMdata.little_endian <> 1 then begin + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + end else + outguy.float := s; //1382 read64 needs to handle little endian in this way as well... + read32r:=outguy.float; +end; + +function read64 ( var fp : File; var lReadOK: boolean ): double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + s:double; + inguy:swaptypep; + outguy:swaptype; +begin + if dFilePos(fp) > (filesz-8) then begin + Read64 := 0; + lReadOK := false; + exit; + end else + lReadOK := true; + //GetMem( buff, 8); + dBlockRead(fp, @s, 8, n); + inguy := @s; //assign address of s to inguy + if lDICOMdata.little_endian <> 1 then begin + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + end else + outguy.float := inguy^.float; //1382 + read64:=outguy.float; +end; + +//magma +function SafeStrToInt(var lInput: string): integer; +var li,lLen: integer; +begin + result := 0; + lLen := length(lInput); + lStr := ''; + if lLen < 1 then exit; + for li := 1 to lLen do + if lInput[li] in ['+','-','0'..'9'] + then lStr := lStr +lInput[li]; + Val(lStr,li,lErr); + if lErr = 0 then + result := lI;//strtoint(lStr); +end; + + +procedure DICOMHeaderStringToInt (var lInput: integer); +var li: integer; +begin + t := _string; + lStr := ''; + if dFilePos(fp) > (filesz-e_len) then exit;//goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in ['+','-','0'..'9'] + then lStr := lStr +(Char(buff[li])); + FreeMem( buff); + Val(lStr,li,lErr); + if lErr = 0 then lInput := li;//strtoint(lStr); + remaining := 0; + tmp := lInput; +end; + +procedure DICOMHeaderString (var lInput: kDICOMStr); +var li,lStartPos: integer; +begin + t := _string; + lStartPos := dFilePos(fp); + lInput := ''; + if e_len < 1 then exit; //DICOM: should always be even + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in ['+','-','/','\',' ','0'..'9','a'..'z','A'..'Z'] then + lInput := lInput +(Char(buff[li])) + else {if (buff[i] = 0) then} + lInput := lInput +' '; + + FreeMem( buff); + dseek(fp, lStartPos); +end; +procedure DICOMHeaderStringTime (var lInput: kDICOMstr); +var li,lStartPos: integer; +begin + t := _string; + lStartPos := dFilePos(fp); + lInput := ''; + if e_len < 1 then exit; //DICOM: should always be even + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for li := 0 to e_len-1 do + if Char(buff[li]) in ['+','-','/','\',' ','0'..'9','a'..'z','A'..'Z','.'] then + lInput := lInput +(Char(buff[li])) + else if li <> (e_len-1) then + lInput := lInput +':' + else + lInput := lInput +' '; + + FreeMem( buff); + dseek(fp, lStartPos); +end; +label 1234; +var lIndent: integer; + lprevGroup, lprevElement: uint32; +var lInside00209113, lInside2005140F, lPhilipsWarning: boolean;//philips can list two DIFFERENT spatial positions per slice - ignore the one hidden inside 2005,140FlPrev0020: boolean; +begin + //Init + //for lnVol := 1 to kMaxOrderVal do + // lDICOMdata.OrderSlope[lDICOMdata.nOrder] := 0; //show this was not set + lInside00209113 := false; + lprevGroup := 0; + lprevElement := 0; + lPhilipsWarning := false; + lIndent := 0; + lInside2005140F := false; + lSwitchToImplicitAfterGroup0002 := false; + lGELX := false; + lByteSwap := false; + Clear_Dicom_Data(lDicomData); + Clear_Dicom_Data(lDICOMdataBackUp); + lDicomData.XYZdim[1] := 1; + lImagePositionPatientRead := false;// for 4D files, we need first volume + l4DDistanceBetweenSliceCenters := kNaNsingle; + lEchoNum := 0; + lThickness := 0; + lTestError := false; + lPhilipsScaleSlope := 0; + lManufacturerIsPhilips := false; + lManufacturerIsBruker := false; + lnVol := 0; + lnSlicePerVol := 0; + lResearchMode := false; + lMatrixSz := 0; + lPhaseEncodingSteps := 0; + lSiemensMosaic0008_0008 := false; + lMediface0002_0013 := false;//false wblate + lOldSiemens_IncorrectMosaicMM := false; + lCacheStart := 0; + lDiskCacheSz := 0; + lDynStr:= ''; + lJPEGEntries := 0; + first_one := true; + info := ''; + lGrp:= false; + lBigSet := false; + lDICM_at_128 := false; //no DICOM signature + lFirstFragment := true; + lTextOverFlow := false; + lImageFormatOK := true; + lHdrOK := false; + //if lverboseRead then msg('xxx'+lFileName); + if not fileexists(lFileName) then begin + lImageFormatOK := false; + exit; + end; + //if lverboseRead then msg('zzzzz000000000'); + TmpStr := string(StrUpper(PChar(ExtractFileExt(lFileName)))); + lStr :=''; + if TmpStr = '.FDF' then begin + if FDF( lFileName, lDicomData) then begin + lHdrOK := true; + lImageFormatOK := true; + exit; + end; + end; + if (TmpStr = '.REC') then begin //1417z: check in Unix: character upper/lower case may matter + lStr := changefileext(lFilename,'.par'); + if fileexists(lStr) then + lFilename := lStr + else begin //Linux is case sensitive 1382... + lStr := changefileext(lFilename,'.PAR'); + if fileexists(lStr) then + lFilename := lStr + end; + end; + if (TmpStr = '.BRIK') then begin //1417z: check in Unix: character upper/lower case may matter + lStr := changefileext(lFilename,'.HEAD'); + if fileexists(lStr) then lFilename := lStr; + end; + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + FIleSz := FileSize(fp); + if fileSz < 1 then begin + lImageFormatOK := false; + exit; + end; + lDICOMdata.Little_Endian := 1; + if FileSz > 200 then begin + dseek(fp, {0}128); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] = 'D') and (tx[1] = 'I') and (tx[2] = 'C') and (tx[3] = 'M') then + lDICM_at_128 := true; + end;//filesize > 200: check for 'DICM' at byte 128 - DICOM signature + if (lAutoDetectGenesis) and (FileSz > (5820{114+35+4})) then begin + dseek(fp, 0); + if (ord(tx[0])=206) and (ord(tx[1])=250) then begin + //Elscint format signature: check height and width to make sure + + dseek(fp, 370); + group := read16(fp,lrOK);//Width + dseek(fp, 372); + element := read16(fp,lrOK);//Ht + if ((Group=160) or(Group =256) or (Group= 340) or (Group=512) or (group =640)) and + ((element=160) or (element =256) or (element= 340) or (element=512) ) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_elscint_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName); + exit; + end; //confirmed: Elscint + end; + lGenesis := false; + if ((tx[0] <> 'I') OR (tx[1] <> 'M') OR (tx[2] <> 'G') OR (tx[3] <> 'F')) then begin {DAT format} + {if (FileSz > 114+305+4) then begin + dseek(fp, 114+305); + dBlockRead(fp, tx, 3*SizeOf(Char), n); + if ((tx[0]='M') and (tx[1] = 'R')) or ((tx[0] = 'C') and(tx[1] = 'T')) then + lGenesis := true; + end;} + end else + lGenesis := true; + if (not lGenesis) and (FileSz > 3252) then begin + dseek(fp, 3240); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then + lGenesis := true; + if (not lGenesis) then begin + dseek(fp, 3178); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then + lGenesis := true; + end; + if (not lGenesis) then begin + dseek(fp, 3180); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then + lGenesis := true; + end; + if (not lGenesis) then begin //1499K + dseek(fp, 0); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if ((tx[0] = 'I') AND (tx[1] = 'M')AND (tx[2] = 'G') AND (tx[3] = 'F')) then + lGenesis := true; + end; + + end; + if (not lGenesis) and (FileSz > 3252) then begin + dseek(fp, 3228); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] = 'I') AND (tx[1]= 'M') AND (tx[2] = 'G')AND (tx[3]= 'F') then + lGenesis := true; + end; + if lGenesis then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_ge_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName); + exit; + end; + end; //AutodetectGenesis xxDCIM + + if (lAutoDetectInterfile) and (FileSz > 256) and (not lDICM_at_128) then begin + if Copy(extractfilename(lFileName), 1, 4) = 'COR-' then begin + lStr := extractfiledir(lFilename) + '\COR-.info'; + TmpStr := extractfiledir(lFilename) + '\COR-128'; + if fileexists(lStr) and fileexists(TmpStr) then begin + lFilename := TmpStr; + lDynStr := 'FreeSurfer COR format' + kCR+'Only displaying image 128'+kCR+'Use MRIcro''s Import menu to convert this image'+kCR; + with lDicomData do begin + little_endian := 0; // don't care + ImageStart := 0; + Allocbits_per_pixel := 8; + XYZdim[1] := 256; + XYZdim[2] := 256; + XYZdim[3] := 1; + XYZmm[1] := 1; + XYZmm[2] := 1; + XYZmm[3] := 1; + //xStoredbits_per_pixel:= Allocbits_per_pixel; + END; //WITH + lHdrOK := True; + lImageFormatOK := True; + exit; + end; //COR-.info file exists + end; //if filename is COR- + //start TIF + //TIF IMAGES DO NOT ALWAYS HAVE EXTENSION if (TmpStr = '.TIF') or (TmpStr = '.TIFF') then begin + dseek(fp, 0); + lWord := read16(fp,lrOK); + if lWord = $4d4d then + lDICOMdata.little_endian := 0 + else if lWord = $4949 then lDICOMdata.little_endian := 1; + //dseek(fp, 2); + lWord2 := read16(fp,lrOK); //bits per pixel + if ((lWord=$4d4d) or (lWord=$4949)) and (lWord2 = $002a) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_tiff_data(lDICOMdata, lReadECAToffsetTables, lHdrOK, lImageFormatOK, lDynStr, lFileName); + //if lHdrOk then exit; + exit; + end;//TIF signature + //end; //.TIF extension + //end TIF + //start BMP 1667 + TmpStr := string(StrUpper(PChar(ExtractFileExt(lFileName)))); + if TmpStr = '.BMP' then begin + dseek(fp, 0); + lWord := read16(fp,lrOK); + dseek(fp, 28); + lWord2 := read16(fp,lrOK); //bits per pixel + if (lWord=19778) and (lWord2 = 8) then begin //bitmap signature + dseek(fp, 10); + lDicomData.ImageStart := read32(fp,lrOK);//1078; + dseek(fp, 18); + lDicomData.XYZdim[1] := read32(fp,lrOK); + //dseek(fp, 22); + lDicomData.XYZdim[2] := read32(fp,lrOK); + lDicomData.XYZdim[3] := 1;//read16(fp,lrOK); + lDicomData.Allocbits_per_pixel := 8;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lDynStr := 'BMP format'; + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lHdrOK := true; + lImageFormatOK:= true; + exit; + end;//bmp signature + end; //.BMP extension + //end BMP + if TmpStr = '.VOL' then begin //start SPACE vol format 1382 + dseek(fp, 0); + dBlockRead(fp, tx, 6*SizeOf(Char), n); + if (tx[0] = 'm') and (tx[1] = 'd') and (tx[2] = 'v') and (tx[3] = 'o') and (tx[4] = 'l') and (tx[5] = '1') then begin + lDicomData.ImageStart := read32(fp,lrOK);//1078; + lDICOMdata.little_endian := 1; + lDicomData.XYZdim[1] := read32(fp,lrOK); + lDicomData.XYZdim[2] := read32(fp,lrOK); + lDicomData.XYZdim[3] := read32(fp,lrOK); + lDicomData.XYZmm[1] := read32r(fp,lrOK); + lDicomData.XYZmm[2] := read32r(fp,lrOK); + lDicomData.XYZmm[3] := read32r(fp,lrOK); + lDicomData.Allocbits_per_pixel := 8;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lDynStr := 'Space VOL format'; + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lHdrOK := true; + lImageFormatOK:= true; + exit; + end;//vol signature + end; //.VOL extension + //end space .VOL format + //start DF3 PovRay DF3 density files + if (TmpStr = '.DF3') then begin + dseek(fp, 0); + lWord := swap (read16(fp,lrOK)); + lWord2 := swap (read16(fp,lrOK)); + lWord3 := swap (read16(fp,lrOK)); + //note: I assume all df3 headers are little endian. is this always true? if not, unswapped values could be tested for filesize + lMatrixSz := (lWord*lWord2*lWord3)+6; + if (lMatrixSz=FileSz)then begin //df3 signature + lDicomData.ImageStart := 6;//1078; + lDicomData.XYZdim[1] := lWord; + //dseek(fp, 22); + lDicomData.XYZdim[2] := lWord2; + lDicomData.XYZdim[3] := lWord3; + lDicomData.Allocbits_per_pixel := 8;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lDynStr := 'PovRay DF3 density format'; + lHdrOK := true; + lImageFormatOK:= true; + exit; + end;//df3 signature + end; + //end df3 + + //start .PGM + if (TmpStr = '.PGM') or (TmpStr = '.PPM') then begin + dseek(fp, 0); + lWord := read16(fp,lrOK); + if (lWord=13648){'P5'=1x8BIT GRAYSCALE} or (lWord=13904) {'P6'=3x8bit RGB} then begin //bitmap signature + {repeat + PGMreadStr(lDicomData.XYZdim[1],lDicomData.XYZdim[2]); + until (lDicomData.XYZdim[2] > 0) ;} + lDicomData.XYZdim[1] := PGMreadInt; + lDicomData.XYZdim[2] := PGMreadInt; + PGMreadInt; //read maximum value + + lDicomData.XYZdim[3] := 1;//read16(fp,lrOK); + lDicomData.Allocbits_per_pixel := 8;//bits + //xlDicomData.Storedbits_per_pixel:= lDicomData.Allocbits_per_pixel; + lDicomData.ImageStart := dFilepos(fp); + if lWord = 13904 then begin//RGB + //xlDicomData.SamplesPerPixel := 3; + //xlDicomData.PlanarConfig := 0;//RGBRGBRGB..., not RRR..RGGG..GBBB...B + end; + lDynStr:='PGM/PPM format 8-bit grayscale image [data saved in binary, not ASCII format]'; + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lHdrOK := true; + lImageFormatOK:= true; + exit; + end else if (lWord=12880){'P2'=1x8BIT ASCII} or (lWord=13136) {'P3'=3x8bit ASCI} then begin + Msg('Warning: this image appears to be an ASCII ppm/pgm image. This software can only read binary ppm/pgm images'); + end;//pgm/ppm binary signature signature + end; //.PPM/PGM extension + + //end .pgm + + //start BioRadPIC 1667 + if TmpStr = '.PIC' then begin + dseek(fp, 54); + lWord := read16(fp,lrOK); + if (lWord=12345) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_biorad_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName); + exit; + end;//biorad signature + end; //.PIC extension biorad? + //end BIORAD PIC + if TmpStr = '.HEAD' then begin + read_afni_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName,lRot1,lRot2,lRot3); + if (lHdrOK) and (lImageFormatOK) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + exit; + end; + end; + dseek(fp, 0); + dBlockRead(fp, tx, 20*SizeOf(Char), n); + if (tx[0] = 'n') and (tx[1] = 'c') and (tx[2] = 'a') and (tx[3] = 'a') then begin + //SUN Vision File Format = .vff + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_vff_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName); + exit; + end; + liPos := 1; + lStr :=''; + {999 While (liPos <= 20) and (lStr <> 'INTERFILE') do begin + if tx[liPos] in ['i','n','t','e','r', 'f','i','l','e','I','N','T','E','R', 'F','I','L','E'] then + lStr := lStr+upcase(tx[liPos]); + inc(liPos); + end; } + if lStr = 'INTERFILE' then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_interfile_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName); + if lHdrOk then exit; + exit; + end; //'INTERFILE' in first 20 char + end;//detectint + // try DICOM part 10 i.e. a 128 byte file preamble followed by "DICM" + if filesz <= 300 then goto 666; + {begin siemens somatom: DO THIS BEFORE MAGNETOM: BOTH HAVE 'SIEMENS' SIGNATURE, SO CHECK FOR 'SOMATOM'} + if filesz = 530432 then begin + dseek(fp, 281); + dBlockRead(fp, tx, 8*SizeOf(Char), n); + if (tx[0] = 'S') and (tx[1] = 'O') and (tx[2] = 'M') and (tx[3] = 'A') and (tx[4] = 'T') and (tx[5] = 'O') and (tx[6] = 'M') then begin + lDicomData.ImageStart := 6144; + lDicomData.Allocbits_per_pixel := 16; + //xlDicomData.Storedbits_per_pixel := 16; + lDicomData.little_endian := 0; + lDicomData.XYZdim[1] := 512; + lDicomData.XYZdim[2] := 512; + lDicomData.XYZdim[3] := 1; + dSeek(fp,5999); //Study/Image from 5292 "STU/IMA 1070/16" + lDicomData.AcquNum := trunc(SomaTomFloat);//Slice Thickness from 5790 "SL 3.0" + lDicomData.ImageNum := trunc(SomaTomFloat);//Slice Thickness from 5790 "SL 3.0" + dSeek(fp,5792); //Slice Thickness from 5790 "SL 3.0" + lDicomData.XYZmm[3] := SomaTomFloat;//Slice Thickness from 5790 "SL 3.0" + dSeek(fp,5841); //Field of View from 5838 "FoV 281" + lDicomData.XYZmm[1] := SomaTomFloat; //Field of View from 5838 "FoV 281" + lDicomData.XYZmm[2] := lDicomData.XYZmm[1]/lDicomData.XYZdim[2];//do mm[2] first before FOV is overwritten + lDicomData.XYZmm[1] := lDicomData.XYZmm[1]/lDicomData.XYZdim[1]; + if lVerboseRead then + lDynStr := 'Siemens Somatom Format'+kCR+ + 'Image Series/Number: '+inttostr(lDicomData.AcquNum)+'/'+inttostr(lDicomData.ImageNum)+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lImageFormatOK := true; + lHdrOK := true; + exit; + end; //signature found + end; //correctsize for somatom + {end siemens somatom} + +{siemens magnetom} + dseek(fp,96); + dBlockRead(fp, tx, 7*SizeOf(Char), n); + if (tx[0] = 'S') and (tx[1] = 'I') and (tx[2] = 'E') and (tx[3] = 'M') and (tx[4] = 'E') and (tx[5] = 'N') and (tx[6] = 'S') then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_siemens_data(lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName); + exit; + end; + {end siemens magnetom vision} + {siemens somatom plus} + dseek(fp, 0); + dBlockRead(fp, tx, 8*SizeOf(Char), n); + if (tx[0] = 'S') and (tx[1] = 'I') and (tx[2] = 'E') and (tx[3] = 'M') and (tx[4] = 'E') and (tx[5] = 'N') and (tx[6] = 'S') then begin + lDicomData.ImageStart := 8192; + lDicomData.Allocbits_per_pixel := 16; + //xlDicomData.Storedbits_per_pixel := 16; + lDicomData.little_endian := 0; + dseek(fp, 1800); //slice thickness + lDicomData.XYZmm[3] := read64(fp,lrOK); + dseek(fp, 4100); + lDicomData.AcquNum := read32(fp,lrOK); + dseek(fp, 4108); + lDicomData.ImageNum := read32(fp,lrOK); + dseek(fp, 4992); //X FOV + lDicomData.XYZmm[1] := read64(fp,lrOK); + dseek(fp, 5000); //Y FOV + lDicomData.XYZmm[2] := read64(fp,lrOK); + dseek(fp, 5340); + lDicomData.XYZdim[1] := read32(fp,lrOK); + dseek(fp, 5344); + lDicomData.XYZdim[2] := read32(fp,lrOK); + lDicomData.XYZdim[3] := 1; + if lDicomData.XYZdim[1] > 0 then + lDicomData.XYZmm[1] := lDicomData.XYZmm[1]/lDicomData.XYZdim[1]; + if lDicomData.XYZdim[2] > 0 then + lDicomData.XYZmm[2] := lDicomData.XYZmm[2]/lDicomData.XYZdim[2]; + if lVerboseRead then + lDynStr := 'Siemens Somatom Plus Format'+kCR+ + 'Image Series/Number: '+inttostr(lDicomData.AcquNum)+'/'+inttostr(lDicomData.ImageNum)+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lImageFormatOK := true; + lHdrOK := true; + exit; + end; + {end siemens somatom plus } + {picker} + dseek(fp,0); + dBlockRead(fp, tx, 8*SizeOf(Char), n); + if (tx[0]='C') and (tx[1]='D') and (tx[2]='F') and (ord(tx[3]) = 1) then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_minc_data(lDICOMdata, lHdrOK, lImageFormatOK,lDynStr,lFileName); + exit; + end; + if (lAutoDECAT7) and (tx[0]='M') and (tx[1]='A') and (tx[2]='T') and (tx[3]='R') and (tx[4]='I') and (tx[5]='X') then begin + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_ecat_data(lDICOMdata, lVerboseRead,lReadECAToffsetTables,lHdrOK, lImageFormatOK, lDynStr, lFileName); + exit; + end; + if (tx[0] = '*') AND (tx[1] = '*') AND (tx[2] = '*') AND (tx[3] = ' ') then begin {picker Standard} + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + read_picker_data(lVerboseRead,lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName); + exit; + end; {not picker standard} + //Start Picker Prism + ljunk := filesz-2048; + lDICOMdata.little_endian := 0; + //start: read x + dseek(fp, 322); + Width := read16(fp,lrOK); + + //start: read y + dseek(fp, 326); + Ht := read16(fp,lrOK); + lMatrixSz := Width * Ht; + + //check if correct filesize for picker prism + if (ord(tx[0]) = 1) and (ord(tx[1])=2) and ((ljunk mod lMatrixSz)=0){128*128*2bytes = 32768} then begin //Picker PRISM + lDicomData.little_endian := 0; + lDicomData.XYZdim[1] := Width; + lDicomData.XYZdim[2] := Ht; + lDicomData.XYZdim[3] := (ljunk div 32768); {128*128*2bytes = 32768} + lDicomData.Allocbits_per_pixel := 16; + //xlDicomData.Storedbits_per_pixel := 16; + lDicomData.ImageStart := 2048; + //start: read slice thicness + dseek(fp,462); + dBlockRead(fp, tx, 12*SizeOf(Char), n); + lStr := ''; + for ljunk := 0 to 11 do + if tx[ljunk] in ['0'..'9','.'] then + lStr := lStr+ tx[ljunk]; + if lStr <> '' then + lDicomData.XYZmm[3] := strtofloat(lStr); + //start: voxel size + dseek(fp,594); + dBlockRead(fp, tx, 12*SizeOf(Char), n); + lStr := ''; + for ljunk := 0 to 11 do + if tx[ljunk] in ['0'..'9','.'] then + lStr := lStr+ tx[ljunk]; + if lStr <> '' then + lDicomData.XYZmm[1] := strtofloat(lStr); + lDicomData.XYZmm[2] := lDicomData.XYZmm[1]; + //end: read voxel sizes + //start: patient name + dseek(fp,26); + dBlockRead(fp, tx, 22*SizeOf(Char), n); + lStr := ''; + ljunk := 0; + while (ljunk < 22) and (ord(tx[ljunk]) <> 0) do begin + lStr := lStr+ tx[ljunk]; + inc(ljunk); + end; + lDicomData.PatientName := lStr; + //start: patient ID + dseek(fp,48); + dBlockRead(fp, tx, 15*SizeOf(Char), n); + lstr := ''; + ljunk := 0; + while (ljunk < 15) and (ord(tx[ljunk]) <> 0) do begin + lstr := lstr+ tx[ljunk]; + inc(ljunk); + end; + //xlDicomData.PatientID := lStr; + //start: scan time + dseek(fp,186); + dBlockRead(fp, tx, 25*SizeOf(Char), n); + lstr := ''; + ljunk := 0; + while (ljunk < 25) and (ord(tx[ljunk]) <> 0) do begin + lstr := lstr+ tx[ljunk]; + inc(ljunk); + end; + //start: scanner type + dseek(fp,2); + dBlockRead(fp, tx, 25*SizeOf(Char), n); + lgrpstr := ''; + ljunk := 0; + while (ljunk < 25) and (ord(tx[ljunk]) <> 0) do begin + lgrpstr := lgrpstr+ tx[ljunk]; + inc(ljunk); + end; + //report results + if lVerboseRead then + lDynStr := 'Picker Format '+lgrpstr+kCR+ + 'Patient Name: '+lDicomData.PatientName+kCR+ + //x'Patient ID: '+lDicomData.PatientID+kCR+ + 'Scan Time: '+lStr+kCR+ + 'XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/' + +inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2); + CloseFile(fp); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + FileMode := 2; //set to read/write + lImageFormatOK := true; + lHdrOK := true; + exit; + + end; //end Picker PRISM + lMatrixSz := 0; + + lDICOMdata.little_endian := 1; + lBig := false; + dseek(fp, {0}128); + //where := FilePos(fp); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then begin + + //if filesz > 132 then begin + dseek(fp, 0{128}); //skip the preamble - next 4 bytes should be 'DICM' + //where := FilePos(fp); + dBlockRead(fp, tx, 4*SizeOf(Char), n); + //end; + if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then begin + dseek(fp, 0); + group := read16(fp,lrOK); + + if not lrOK then goto 666; + + if group > $0008 then begin + group := swap(group); + lBig := true; + end; + if NOT (group in [$0000, $0001, $0002,$0003, $0004, $0008]) then // one more group added + begin + + goto 666; + end; + dseek(fp, 0); + //Msg('DICM not at 0 or 128: ' +lFilename); + end; + end; //else Msg('DICM at 128{0}');; + time_to_quit := FALSE; + lProprietaryImageThumbnail := false; + explicitVR := false; + tmpstr := ''; + + tmp := 0; + + while NOT time_to_quit do begin + t := unknown; + where := dFilePos(fp); + lFirstPass := true; +777: + group := read16(fp,lrOK); + if (lSwitchToImplicitAfterGroup0002) and (group > 0002) then begin + lSwitchToImplicitAfterGroup0002 := false; + explicitVR := false; + end; + + if not lrOK then goto 666; + if (lFirstPass) and (group = 2048) then begin + if lDicomData.little_endian = 1 then lDicomData.Little_endian := 0 + else lDicomData.little_endian := 1; + dseek(fp,where); + lFirstPass := false; + goto 777; + end; + + element := read16(fp,lrOK); + if not lrOK then goto 666; + e_len:= read32(fp,lrOK); + if not lrOK then goto 666; +lGrpStr := ''; + lt0 := e_len and 255; + lt1 := (e_len shr 8) and 255; + lt2 := (e_len shr 16) and 255; + lt3 := (e_len shr 24) and 255; + if (explicitVR) and (lT0=13) and (lT1=0) and (lT2=0) and (lT3=0) then + e_len := 10; //hack for some GE Dicom images + + + if explicitVR or first_one then begin + if group = $FFFE then else //1384 - ACUSON images switch off ExplicitVR for file image fragments + if ((lT0=kO) and (lT1=kB)) or ((lT0=kU) and (lT1=kN)){<-UN added 11/11/2011} or ((lT0=kO) and (lT1=kW)) or ((lT0=kS) and (lT1=kQ)) {11/11 add UT}or ((lT0=kU) and (lT1=kT)) then begin + lGrpStr := chr(lT0)+chr(lT1); + e_len:= read32(fp,lrOK); + if not lrOK then goto 666; + if first_one then explicitVR := true; + end else if ((lT3=kO) and (lT2=kB)) or ((lT3=kU) and (lT2=kN)){<-UN added 11/11/2011} or((lT3=kO) and (lT2=kW)) or ((lT3=kS) and (lT2=kQ)) or ((lT3=kU) and (lT2=kT))then begin + e_len:= read32(fp,lrOK); + if not lrOK then goto 666; + if first_one then explicitVR := true; + end + else if ( ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS)) + or ((lT0=kA) and (lT1=kT)) or ((lT0=kC) and (lT1=kS)) or ((lT0=kD) and (lT1=kA)) + or ((lT0=kD) and (lT1=kS)) + or ((lT0=kD) and (lT1=kT)) or ((lT0=kF) and (lT1=kL)) or ((lT0=kF) and (lT1=kD)) + or ((lT0=kI) and (lT1=kS)) or ((lT0=kL) and (lT1=kO))or ((lT0=kL) and (lT1=kT)) + or ((lT0=kP) and (lT1=kN)) or ((lT0=kS) and (lT1=kH)) or ((lT0=kS) and (lT1=kL)) + or ((lT0=kS) and (lT1=kS)) or ((lT0=kS) and (lT1=kT)) or ((lT0=kT) and (lT1=kM)) + or ((lT0=kU) and (lT1=kI)) or ((lT0=kU) and (lT1=kL)) or ((lT0=kU) and (lT1=kS)) + or ((lT0=kA) and (lT1=kE)) or ((lT0=kA) and (lT1=kS)) ) + then begin + lGrpStr := chr(lT0) + chr(lT1); + if lDicomData.little_endian = 1 then + e_len := (e_len and $ffff0000) shr 16 + else + e_len := swap((e_len and $ffff0000) shr 16); + if first_one then begin + explicitVR := true; + end; + end else if ( + ((lT3=kA) and (lT2=kT)) or ((lT3=kC) and (lT2=kS)) or ((lT3=kD) and (lT2=kA)) + or ((lT3=kD) and (lT2=kS)) + or ((lT3=kD) and (lT2=kT)) or ((lT3=kF) and (lT2=kL)) or ((lT3=kF) and (lT2=kD)) + or ((lT3=kI) and (lT2=kS)) or ((lT3=kL) and (lT2=kO))or ((lT3=kL) and (lT2=kT)) + or ((lT3=kP) and (lT2=kN)) or ((lT3=kS) and (lT2=kH)) or ((lT3=kS) and (lT2=kL)) + or ((lT3=kS) and (lT2=kS)) or ((lT3=kS) and (lT2=kT)) or ((lT3=kT) and (lT2=kM)) + or ((lT3=kU) and (lT2=kI)) or ((lT3=kU) and (lT2=kL)) or ((lT3=kU) and (lT2=kS))) + then begin + if lDicomData.little_endian = 1 then + e_len := (256 * lT0) + lT1 + else + e_len := (lT0) + (256*lT1); + if first_one then begin + explicitVR := true; + end; + end; +end; //not first_one or explicit + + if (first_one) and (lDicomdata.little_endian =0) and (e_len = $04000000) then begin + Msg('Switching to little endian'); + lDicomData.little_endian := 1; + dseek(fp, where); + first_one := false; + goto 777; + end else if (first_one) and (lDicomData.little_endian =1) and (e_len = $04000000) then begin + Msg('Switching to little endian'); + lDicomData.little_endian := 0; + dseek(fp, where); + first_one := false; + goto 777; + end; + + if e_len = ($FFFFFFFF) then begin + e_len := 0; +end; + if lGELX then begin + e_len := e_len and $FFFF; + end; + first_one := false; + remaining := e_len; + info := '?'; + tmpstr := ''; + //10b1 if (lIndent > 0) and (not ((group= $FFFE) and (element = $E0DD))) and (not lManufacturerIsPhilips) then + // goto 1234; //Philips stores slice positioning inside 0020,9113; lice orientation inside 0020,9116 but Siemens stores thumbnails in indented subheadings + + case group of + $0001 : // group for normal reading elscint DICOM + case element of + $0010 : info := 'Name'; + $1001 : info := 'Elscint info'; + end; + $0002 : + case element of + $00 : info := 'File Meta Elements Group Len'; + $01 : info := 'File Meta Info Version'; + $02 : info := 'Media Storage SOP Class UID'; + $03 : info := 'Media Storage SOP Inst UID'; + $10 : begin + //lTransferSyntaxReported := true; + info := 'Transfer Syntax UID'; + TmpStr := ''; + if dFilePos(fp) > (filesz-e_len) then goto 666; + + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for i := 0 to e_len-1 do + if Char(buff[i]) in ['+','-',' ', '0'..'9','a'..'z','A'..'Z'] + then TmpStr := TmpStr +(Char(buff[i])) + else TmpStr := TmpStr +('.'); + FreeMem( buff); + lStr := ''; + //Msg(TmpStr); + if TmpStr = '1.2.840.113619.5.2' then begin + lGELX := true; + LBigSet := true; + lBig := true; + end; + // + if length(TmpStr) < 19 then begin + //12/2010 assume 1.2.840.10008.1.2 + //Raw data, Implicit VR, Little Endian + // explicitVR := false; //china + lSwitchToImplicitAfterGroup0002 := true; + end; + + if length(TmpStr) >= 19 then begin + + if TmpStr[19] = '1' then begin + lBigSet:= true; + explicitVR := true; //duran + lBig := false; + end else if TmpStr[19] = '2' then begin + lBigSet:= true; + explicitVR := true; //duran + lBig := true; + end else if TmpStr[19] = '4' then begin + if length(TmpStr) >= 21 then begin + //Dec 2012.... dcm2nii can handle JPEG 123456 + if {not lReadJPEGtables} false then begin + lImageFormatOK := false; + end else begin + + i := strtoint(TmpStr[21]+TmpStr[22]); + if (i <> 57) and (i <> 70) then begin + lImageFormatOK := false; + //lDicomData.JPEGLossyCpt := true + end else begin + + //lImageFormatOK := false;//123456 + lDicomData.JPEGLosslessCpt := true; + end; + end; + end else begin + lImageFormatOK := false; + end; + end else if TmpStr[19] = '5' then begin + lImageFormatOK := false;//xlDicomData.RunLengthEncoding := true; + end else begin + lImageFormatOK := false; + end; + if not lImageFormatOK then + Msg('Unsupported Transfer Syntax '+(TmpStr)+' Solution: use MRIcro'); + + end; {length} + remaining := 0; + e_len := 0; {use tempstr} + end; + $12 : begin + info := 'Implementation Class UID'; + end; + $13 : begin + info := 'Implementation Version Name'; + if e_len > 4 then begin + TmpStr := ''; + DICOMHeaderString(TmpStr); + //lDicomData.ImplementationVersion := Str2Int(TmpStr); + if TmpStr = 'MEDIFACE 1 5' then + lMediface0002_0013 := true; //detect MEDIFACE 1.5 error: error in length of two elements 0008:1111 and 0008:1140 + end; //length > 4 + end; //element 13 + $16 : info := 'Source App Entity Title'; + $100: info := 'Private Info Creator UID'; + $102: info := 'Private Info'; + end; + $0008 : + case element of + $00 : begin + info := 'Identifying Group Length'; + end; + $01 : info := 'Length to End'; + $05 : info := 'Specific Character Set'; + $08 : begin + info := 'Image Type'; + if dFilePos(fp) > (filesz-e_len) then goto 666; + lSiemensMosaic0008_0008:= false; + if (e_len >= 6) then begin //search for 'MOSAIC' + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + i := e_len -6;//MOSAIC + while (i>-1) and (not lSiemensMosaic0008_0008) do begin + if (upcase(Char(buff[i])) = 'M') and (upcase(Char(buff[i+1])) = 'O') + and (upcase(Char(buff[i+2])) = 'S') and (upcase(Char(buff[i+3])) = 'A') + and (upcase(Char(buff[i+4])) = 'I') and (upcase(Char(buff[i+5])) = 'C') + then //strip filler characters: DICOM elements must be padded for even length + lSiemensMosaic0008_0008 := true; + dec(i); + end; + FreeMem( buff); + remaining := 0; + e_len := 0; {use tempstr} + end; + end; + $10 : info := 'Recognition Code'; + $12 : info := 'Instance Creation Date'; + $13 : info := 'Instance Creation Time'; + $14 : info := 'Instance Creator UID'; + $16 : info := 'SOP Class UID'; + $18 : info := 'SOP Instance UID'; + $20 : begin + info := 'Study Date'; + //lDicomData.StudyDatePos := dFilePos(fp); + DICOMHeaderString(lDicomData.StudyDate); + end; + $21 : info := 'Series Date'; + $22 : info := 'Acquisition Date'; + $23 : info := 'Image Date'; + $30 : begin info := 'Study Time'; + DICOMHeaderStringTime(lDicomData.StudyTime); + end; + $31 : info := 'Series Time'; + $32 : begin info := 'Acquisition Time'; + DICOMHeaderStringTime(TmpStr); + lDicomData.SecSinceMidnight := SecSinceMidnightFloat(TmpStr); + + end; + $33 : begin info := 'Image Time'; + //xxDICOMHeaderStringTime(lDicomData.ImgTime); + end; + $40 : info := 'Data Set Type'; + $41 : info := 'Data Set Subtype'; + $50 : begin + //xDICOMHeaderStringtoInt(lDicomData.accession); + info := 'Accession Number'; + end; + + $60 : begin info := 'Modality'; t := _string; end; + $64 : begin info := 'Conversion Type'; t := _string; end; + $70 : begin + info := 'Manufacturer'; + //Only read last word, e.g. 'TYPE\MOSAIC' will be read as 'MOSAIC' + TmpStr := ''; + + if dFilePos(fp) > (filesz-e_len) then goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + i := e_len -1; + while (i>-1) and (Char(buff[i]) in ['a'..'z','A'..'Z',' ']) do begin + if (Char(buff[i])) <> ' ' then //strip filler characters: DICOM elements must be padded for even length + TmpStr := upcase(Char(buff[i]))+TmpStr; + dec(i); + end; + FreeMem( buff); + remaining := 0; + e_len := 0; {use tempstr} + if (length(TmpStr) > 3) and (TmpStr[1]='P') and (TmpStr[2]='H') and (TmpStr[3]='I') then + lManufacturerIsPhilips := true; + if (length(TmpStr) > 3) and (TmpStr[1]='B') and (TmpStr[2]='R') and (TmpStr[3]='U') then + lManufacturerIsBruker := true; + + if lManufacturerIsPhilips then + lDicomData.ManufacturerID := kPhilipsID; + + if (length(TmpStr) > 3) and (TmpStr[1]='G') and (TmpStr[2]='E') then + lDicomData.ManufacturerID := kGEID; + if (length(TmpStr) > 3) and (TmpStr[1]='S') and (TmpStr[2]='I') and (TmpStr[3]='E') then + lDicomData.ManufacturerID := kSiemensID; + + end; + $80 : info := 'Institution Name'; + $81 : info := 'City Name'; + $90 : info := 'Referring Physician''s Name'; + $100: info := 'Code Value'; + $102 : begin + info := 'Coding Schema Designator'; + t := _string; + end; + $104: info := 'Code Meaning'; + $1010: info := 'Station Name'; + $1030: begin info := 'Study Description'; t := _string; end; + $103e: begin info := 'Series Description'; t := _string; end; + $1040: info := 'Institutional Dept. Name'; + $1050: info := 'Performing Physician''s Name'; + $1060: info := 'Name Phys(s) Read Study'; + $1070: begin info := 'Operator''s Name'; t := _string; end; + $1080: info := 'Admitting Diagnosis Description'; + $1090: begin info := 'Manufacturer''s Model Name';t := _string; end; + $1111: begin + if lMediface0002_0013 then E_LEN := 8;//+e_len; + end; //ABBA: patches error in DICOM images seen from Sheffield 0002,0013=MEDIFACE.1.5; 0002,0016=PICKER.MR.SCU + $1140: begin + if (lMediface0002_0013) and (E_LEN > 255) then E_LEN := 8; + end; //ABBA: patches error in DICOM images seen from Sheffield 0002,0013=MEDIFACE.1.5; 0002,0016=PICKER.MR.SCU + $2111: info := 'Derivation Description'; + $2120: info := 'Stage Name'; + $2122: begin info := 'Stage Number';t := _string; end; + $2124: begin info := 'Number of Stages';t := _string; end; + $2128: begin info := 'View Number';t := _string; end; + $212A: begin info := 'Number of Views in stage';t := _string; end; + $2204: info := 'Transducer Orientation'; + $9208: begin + info := 'ComplexImageComponent'; + TmpStr := ''; + DICOMHeaderString(TmpStr); + i := 0; + + if length(TmpStr) >= 2 then begin + if (TmpStr[1] = 'M') and (TmpStr[2] = 'A') then + i := 1; //magnitude + if (TmpStr[1] = 'P') and (TmpStr[2] = 'H') then + i := 2; //phase + if (TmpStr[1] = 'R') and (TmpStr[2] = 'E') then + i := 3; //real + if (TmpStr[1] = 'I') and (TmpStr[2] = 'M') then + i := 4; //imaginary + end; + //mixed will be followed by subsequent settings, so do not use it here.... + if (i > 0) and (lDICOMdata.nOrder < kMaxOrderVal) then begin + inc(lDICOMdata.nOrder); + //msg(TmpStr); + lDICOMdata.order[lDICOMdata.nOrder] := i; + end; +(*[ magnitude * MAGNITUDE +[ phase * PHASE +[ real * REAL +[ imaginary * IMAGINARY +[ mixed * MIXED*) + ///xxx xxx + end; + + end; + $0009: if element = $0010 then begin + + if e_len > 4 then begin + TmpStr := ''; + if dFilePos(fp) > (filesz-e_len) then goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + i := e_len -1; + + while (i>-1) {and (Char(buff[i]) in ['a'..'z','A'..'Z',' '])} do begin + if (Char(buff[i])) in ['a'..'z','A'..'Z'] then //strip filler characters: DICOM elements must be padded for even length + TmpStr := upcase(Char(buff[i]))+TmpStr; + dec(i); + end; + FreeMem( buff); + remaining := 0; + if (Length(TmpStr)>4) and (TmpStr[1]='M') and (TmpStr[2]='E') and (TmpStr[3]='R') and (TmpStr[4]='G') then + lOldSiemens_IncorrectMosaicMM := true; //detect MERGE technologies mosaics + e_len := 0; {use tempstr} + end; + + + end; + $0010 : + case element of + $00 : info := 'Patient Group Length'; + $10 : begin info := 'Patient''s Name'; t := _string; + //xlDicomData.NamePos := dFilePos(fp); + DICOMHeaderString(lDicomData.PatientName); + end; + $20 : begin info := 'Patient ID'; + //xDICOMHeaderString(lDicomData.PatientID); + //xlDicomData.PatientIDInt := safestrtoint(lDicomData.PatientID); + end; + //11/2010 + //$30: info := 'Date of Birth'; //"Age String" type: e.g 067y for 67 years old, 067d for 67 days + $30 : begin info := 'DoB'; t := _string; + //xlDicomData.NamePos := dFilePos(fp); + //lDicomData.PatientDoB := '1111'; + DICOMHeaderString(lDicomData.PatientDoB); + end; + $32 : info := 'Patient Birth Time'; + //$40 : begin info := 'Patient Sex'; t := _string; end; + $40 : begin info := 'Gender'; t := _string; + //xlDicomData.NamePos := dFilePos(fp); + DICOMHeaderString(lDicomData.PatientGender); + end; + + $1000: info := 'Other Patient IDs'; + $1001: info := 'Other Patient Names'; + $1005: info := 'Patient''s Birth Name'; + $1010: begin info := 'Patient Age'; t := _string; end; + $1030: info := 'Patient Weight'; + $21b0: info := 'Additional Patient History'; + $4000: info := 'Patient Comments'; + + end; + $0018 : + case element of + $00 : info := 'Acquisition Group Length'; + $10 : begin info := 'Contrast/Bolus Agent'; t := _string; end; + $15: info := 'Body Part Examined'; + $20 : begin + info := 'Scanning Sequence';t := _string; + TmpStr := ''; + DICOMHeaderString(TmpStr); + if TmpStr = 'RM' then lResearchMode := true; + end; + $21 : begin info := 'Sequence Variant';t := _string; end; + $22 : info := 'Scan Options'; + $23 : begin info := 'MR Acquisition Type'; t := _string; end; + $24 : info := 'Sequence Name'; + $25 : begin info := 'Angio Flag';t := _string; end; + $30 : info := 'Radionuclide'; + $50 : begin info := 'Slice Thickness'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.XYZmm[3] := lfloat1; + + lThickness := lfloat1;//lDICOMdata.Thickness := lfloat1; //1391b + end; + //$60: begin info := 'KVP [Peak Output, KV]'; t := _string; end; //aqw + $60: begin + info := 'KVP [Peak KV]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDicomData.kV := lFloat1; + end; + + $70: begin t := _string; info := 'Counts Accumulated'; end; + $71: begin t := _string; info := 'Acquisition Condition'; end; + //$80 : begin info := 'Repetition Time'; t := _string; end; //aqw + //$81 : begin info := 'Echo Time'; t := _string; end; //aqw + $80 : begin info := 'Repetition Time [TR, ms]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDicomData.TR := lFloat1; + end; + + $81 : begin + info := 'Echo Time [TE, ms]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDicomData.TE := lFloat1; + end; + $82 : begin t := _string; info := 'Inversion Time';end; + $83 : begin t := _string; info := 'Number of Averages'; end; + $84 : info := 'Imaging Frequency'; + $85 : begin info := 'Imaged Nucleus'; t := _string; end; + $86 : begin info := 'Echo Number';t := _string; + + DICOMHeaderStringToInt(lEchoNum); + //lDICOMdata.Echo := lEchoNum; + + end; +//qq + $87 : info := 'Magnetic Field Strength'; + $88 : begin + info := 'Spacing Between Slices'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; //1362 some use this for gap size, others for sum of gap and slicethickness! + //3333 if (lfloat1 > lDICOMdata.XYZmm[3]) or (lDICOMdata.XYZmm[3]=1) then + //lDICOMdata.XYZmm[3] := lfloat1; + //fx(lDICOMdata.XYZmm[3],lThickness,lfloat1); + if lfloat1 < 0 then + lDICOMdata.XYZmm[3] := lFloat1//does not make sense - found in some eFilm images from Marconi P3000 + else if ( (lThickness/2) > lfloat1 ) then + lDICOMdata.XYZmm[3] := lfloat1+lThickness + else + lDICOMdata.XYZmm[3] := lfloat1;//1392 + //xldicomdata.spacing:=lfloat1; + end; + $89 : begin + // t := _string; + info := 'Number of Phase Encoding Steps'; + //1499c This is a indirect method for detecting SIemens Mosaics: check if image height is evenly divisible by encoding steps + // A real kludge due to Siemens not documenting mosaics explicitly: this workaround may incorrectly think rescaled images are mosaics! + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + lPhaseEncodingSteps := round(lfloat1); + //xxxMsg(floattostr(lFloat1)); + if not lrOK then goto 666; + e_len := 0; remaining := 0; //1362 some use this for gap size, others for sum of gap and slicethickness! + //if (lfloat1 > lDICOMdata.XYZmm[3]) or (lDICOMdata.XYZmm[3]=1) then + //lDICOMdata.XYZmm[3] := lfloat1; + //ldicomdata.spacing:=lfloat1; + + + end; + $90 : info := 'Data collection diameter'; + $91 : begin info := 'Echo Train Length';t := _string; end; + $93: begin info := 'Percent Sampling'; t := _string; end; + $94: begin info := 'Percent Phase Field View'; t := _string; end; + $95 : begin info := 'Pixel Bandwidth'; t := _string; end; + $1000: begin t := _string; info := 'Device Serial Number'; end; + $1004: info := 'Plate ID'; + $1020: begin + info := 'Software Version'; + t := _string; + if e_len > 2 then begin + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.Vers0018_1020 := Siemensversion(TmpStr); + end; + + //showmsg(inttostr(lDicomData.Vers0018_1020)+' '+TmpStr); + end; + $1030: begin + info := 'Protocol Name';t := _string; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.ProtocolName := TmpStr; + AplhaNumericStrDICOM (lDicomData.ProtocolName); + end; + $1040: info := 'Contrast/Bolus Route'; + $1050 : begin + t := _string; info := 'Spatial Resolution'; end; + $1060: info := 'Trigger Time'; + $1062: info := 'Nominal Interval'; + $1063: info := 'Frame Time'; + $1081: info := 'Low R-R Value'; + $1082: info := 'High R-R Value'; + $1083: info := 'Intervals Acquired'; + $1084: info := 'Intervals Rejected'; + $1088: begin info := 'Heart Rate'; t := _string; end; + $1090: begin info := 'Cardiac Number of Images'; t := _string; end; + $1094: begin info := 'Trigger Window';t := _string; end; + $1100: info := 'Reconstruction Diameter'; + $1110: info := 'Distance Source to Detector [mm]'; + $1111: info := 'Distance Source to Patient [mm]'; + $1120: info := 'Gantry/Detector Tilt'; + $1130: info := 'Table Height'; + $1140: info := 'Rotation Direction'; + $1147: info := 'Field of View Shape'; + $1149: begin + t := _string; info := 'Field of View Dimension[s]'; end; + $1150: begin + info := 'Exposure Time [ms]'; + t := _string; + end; + $1151: begin + info := 'X-ray Tube Current [mA]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + //xlDicomData.mA := lFloat1; + end; + + $1152 : info := 'Acquisition Device Processing Description'; + $1155: info := 'Radiation Setting'; + $1160: info := 'Filter Type'; + $1164: info :='Imager Pixel Spacing'; + $1166: info := 'Grid'; + $1170 : info := 'Generator Power'; + $1180 : info := 'Collimator/grid Name'; + $1190 : begin + info := 'Focal Spot[s]'; + t := _string; + end; + $11A0 : begin + info := 'Body Part Thickness'; + t := _string; + end; + $11A2 : info := 'Compression Force'; + $1200 : info := 'Date of Last Calibration'; + $1201 : info := 'Time of Last Calibration'; + $1210: info := 'Convolution Kernel'; + $1250: begin t := _string; info := 'Receiving Coil'; end; + $1251: begin t := _string; info := 'Transmitting Coil'; end; + $1260 : begin + t := _string; info := 'Plate Type'; end; + $1261 : begin + t := _string; info := 'Phosphor Type'; end; + $1310: begin info := 'Acquisition Matrix'; //Siemens Mosaics converted by Merge can report the incorrect mm + + //nji2 + //NOTE: Matrix Information for MERGE converted images. Used Innocently for other uses by Siemens + + if (lOldSiemens_IncorrectMosaicMM) or ((lSiemensMosaic0008_0008) and (lMatrixSz < 1){B13}) then begin + + //TmpStr := ReadStrABC(fp, remaining,lrOK,lA,lB,lC); + + TmpStr := ReadStr(fp, remaining,lrOK,lMatrixSz); + //ss//1362 + //fx(remaining); + (*kEr := true; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + kEr := false; + + lMatrixSz := round(lFloat1); + msg(TmpStr); + fx(lMatrixSz,lFLoat1,lFloat2,4321);*) + {fx(lA,lB,lC); + lMatrixSz := lB; + lMatrixSzY := lC; } + end else + TmpStr := ReadStr(fp, remaining,lrOK,lJunk);//1362 + + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + $1312: begin + t := _string; info := 'Phase Encoding Direction'; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.PhaseEncoding := TmpStr; + AplhaNumericStrDICOM (lDicomData.PhaseEncoding); + end; + $1314: begin + t := _string; info := 'Flip Angle'; end; + $1315: begin + t := _string;info := 'Variable Flip Angle Flag'; end; + $1316: begin + t := _string;info := 'SAR'; end; + $1400: info := 'Acquisition Device Processing Description'; + $1401: begin info := 'Acquisition Device Processing Code';t := _string; end; + $1402: info := 'Cassette Orientation'; + $1403: info := 'Cassette Size'; + $1404: info := 'Exposures on Plate'; + $1405: begin + info := 'Relative X-Ray Exposure'; + t := _string; + end; + $1500: info := 'Positioner Motion'; + $1508: info := 'Positioner Type'; + $1510: begin + info := 'Positioner Primary Angle'; + t := _string; + end; + $1511: info := 'Positioner Secondary Angle'; + $5020: info := 'Processing Function'; + $5100: begin + t := _string; info := 'Patient Position'; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.PatientPos := TmpStr; + AplhaNumericStrDICOM (lDicomData.PatientPos); + end; + $5101: begin info := 'View Position';t := _string; end; + $6000: begin info := 'Sensitivity'; t := _string; end; + $7004: info := 'Detector Type'; + $7005: begin + info := 'Detector Configuration'; + t := _string; + end; + $7006: info := 'Detector Description'; + $700A: info := 'Detector ID'; + $700C: info := 'Date of Last Detector Calibration'; + $700E: info := 'Date of Last Detector Calibration'; + $7048: info := 'Grid Period'; + $7050: info := 'Filter Material LT'; + $7060: info := 'Exposure Control Mode'; + //$9114: fx(1233); + end; +$0019: begin + (*case element of //1362 +//3/3/2008 this old method for detecting mosaics has a problem - if image is interpolated x2, you will assume a 2x2 mosaic + $1220: begin + info := 'Matrix';t := _string; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; + if lfloat2 > lfloat1 then lfloat1 := lfloat2; + lMatrixSz := round(lfloat1); + //if >32767 then there will be wrap around if read as signed value! + remaining := 0; + end; + $14D4: begin + info := 'Matrix';t := _string; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; + if lfloat2 > lfloat1 then lfloat1 := lfloat2; + lMatrixSz := round(lfloat1); + //if >32767 then there will be wrap around if read as signed value! + remaining := 0; + end; + end; *) //case element + + if lDicomData.ManufacturerID = kSiemensID then begin + case element of //1362 + (*$100A: begin //unsigned short $100A + info := 'Number Of Images in Mosaic'; + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + fx(e_len,tmp,remaining); + + end;*) + $1028: begin //7/2013 + info := 'Siemens BandwidthPerPixelPhaseEncode'; + lDICOMdata.BandwidthPerPixelPhaseEncode := read64 (fp,lrOK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; // b-values + + $000C,$100C: begin + info := 'Siemens b-value'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + tmpstr := floattostr(lFloat1); + lDICOMdata.DTI[1].bval := round(lFloat1); + lDICOMdata.SiemensDICOMDTI := true ; + //msgfx( 777,lDICOMdata.DTI[1].bval,lDICOMdata.DTI[1].bval,lDICOMdata.DTI[1].bval); + end; // b-values + $000E,$100E: begin + info := 'Siemens Gradient vector [x,y,z]'; + //readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + lDICOMdata.DTI[1].v1 := read64 (fp,lrOK); + if not lrOK then goto 666; + lDICOMdata.DTI[1].v2 := read64 (fp,lrOK); + if not lrOK then goto 666; + lDICOMdata.DTI[1].v3 := read64 (fp,lrOK); + if not lrOK then goto 666; + //msgfx( 666,lDICOMdata.DTI[1].v1,lDICOMdata.DTI[1].v2,lDICOMdata.DTI[1].v3); + //readfloats3 (fp, remaining, lDummyStr, lDICOMdata.DTI[1].v1,lDICOMdata.DTI[1].v2,lDICOMdata.DTI[1].v3, lROK); + //ShowMsg(lDummyStr); + //fx(e_len,lDICOMdata.DTI[1].v1,lDICOMdata.DTI[1].v2,lDICOMdata.DTI[1].v3); + + e_len := 0; remaining := 0; + //lDICOMdata.DTI[1].v1 := lFloat1; + end; // X diffusion direction + + + end;//Case element + end;//if Siemens + + if lDicomData.ManufacturerID = kGEID then begin + case element of //1362 + $10BB,$a0bb: begin + info := 'GE Gradient vector [x]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.DTI[1].v1 := lFloat1; + end; // X diffusion direction + $10BC,$A0BC: begin + info := 'GE Gradient vector [y]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.DTI[1].v2 := lFloat1; + end;//Y diffusion direction + $10BD,$A0BD: begin + info := 'GE Gradient vector [z]'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.DTI[1].v3 := lFloat1; + end;// Z diffusion direction + end;//Case element + // + + end;//if GE + end;//$0019 + + +$0020 : + case element of + $00 : info := 'Relationship Group Length'; + $0d : info := 'Study Instance UID'; + $0e : info := 'Series Instance UID'; + $10 : begin + info := 'Study ID'; + t := _string; + end; + $11 : begin info := 'Series Number'; + DICOMHeaderStringToInt(lDicomData.SeriesNum); + end; + $12 : // begin info := 'Acquisition Number'; t := _string; end; + begin info := 'Acquisition Number'; + DICOMHeaderStringToInt(lDicomData.AcquNum); + end; + + $13 : begin info := 'Image Number'; + DICOMHeaderStringToInt(lTempInt); + if (lDicomData.ImageNum < 2) and (lTempInt >= 0) then + lDicomData.ImageNum := lTempInt; + //March2008 - some Philips data has multiple image numbers... + // 0018,1020,Software Version=1.5.4\1.5.4.3\Gyroscan PMS/DICOM 2.0 MR .Id. datadefs.v 5.27 2004/10/18 06.50 + //msg(inttostr(lDicomData.ImageNum)+lDicomData.Filename); + end; + $20 : begin info := 'Patient Orientation'; + t := _string; + end; + $30 : info := 'Image Position'; + $32 : begin + info := 'Image Position Patient'; + //June 2009 - for Philips new 4D format we want value from the first slice... + + if lInside2005140F then begin + if not (lPhilipsWarning) then + Msg('*User: check slice thickness. Possible Philips R3.2.2 bug - scanner can report different 0020,0032 values for the same slice.'); + lPhilipsWarning := true; + end else begin + //5/2012: Philips R3.2.2 can save two instances of 0020:0032 for each slice: one from voxel center, one from voxel edge. + + if not lImagePositionPatientRead then begin + readfloats3 (fp, remaining, lDummyStr, lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ, lROK); + //fx( lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ,56789); + if not lrOK then goto 666; + e_len := 0; + remaining := 0; + lImagePositionPatientRead := true; + //we assume Philips reports the slice thickness correctly.... + //an alternative would be to read both 1st and 2nd ImagePositionPatient and + //compute the function DICOMinterslicedistance + end else begin + + CheckIntersliceDistance(l4DDistanceBetweenSliceCenters); + + end; //not 1st read + + end; //if lInside2005140F + //lInside2005140F := false; + end; + $35 : info := 'Image Orientation'; + $37 : begin //nifti + info := 'Image Orientation (Patient)'; + readfloats6 (fp, remaining, lDummyStr, lDicomData.Orient[1], lDicomData.Orient[2],lDicomData.Orient[3],lDicomData.Orient[4], lDicomData.Orient[5],lDicomData.Orient[6], lROK); + if not lrOK then goto 666; + e_len := 0; + remaining := 0; + + end; + $50 : info := 'Location'; + $52 : info := 'Frame of Reference UID'; + $91 : info := 'Echo Train Length'; + $70 : info := 'Image Geometry Type'; + $60 : info := 'Laterality'; + $0105 : begin + //Apr2007 + + DICOMHeaderStringToInt(lnVol); + + //Number of temporal positions=105 + end; + $1001: info := 'Acquisitions in Series'; + $1002: info := 'Images in Acquisition'; + $1020: info := 'Reference'; + $1040: begin info := 'Position Reference'; t := _string; end; + $1041: begin info := 'Slice Location'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + ldicomdata.location:=lfloat1; + end; + $1070: begin + info := 'Other Study Numbers'; + t := _string; + end; + $3401: info := 'Modifying Device ID'; + $3402: info := 'Modified Image ID'; + $3403: info := 'Modified Image Date'; + $3404: info := 'Modifying Device Mfg.'; + $3405: info := 'Modified Image Time'; + $3406: info := 'Modified Image Desc.'; + $4000: info := 'Image Comments'; + $5000: info := 'Original Image ID'; + $5002: info := 'Original Image... Nomenclature'; + //$9113: xxxx + end; + $0021:case element of + $104F: begin + info :='GE Locations in acquisition'; + + if lPrefs.UseGE_0021_104F then begin + //June 2009 - Thomas Stephan sent me a GE image where this was set to 2, but should have been 1 + //I hope removing this does not cause problems with other GE images... + if e_len = 2 then begin + lDicomData.SlicesPer3DVol := read16(fp,lrOK); + e_len := 0; remaining := 0; + /// fx(9999, lDicomData.SlicesPer3DVol); + end; + end; //use 0021_104F + end; + + $1341: begin + info :='Siemens Mosaic Slice Count'; + DICOMHeaderStringToInt(lDicomData.SiemensSlices); + + end; + $134F: begin //1366 + info :='Siemens Order of Slices'; + t := _string; + lDICOMdata.SiemensInterleaved := 0; //0=no,1=yes,2=undefined + //look for "INTERLEAVED" + lStr := ''; + if dFilePos(fp) > (filesz-e_len) then goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for i := 0 to e_len-1 do + if Char(buff[i]) in ['?','A'..'Z','a'..'z'] + then lStr := lStr +upcase(Char(buff[i])); + FreeMem( buff); + if(lStr[1]= 'I') then lDICOMdata.SiemensInterleaved := 1; //0=no,1=yes,2=undefined + e_len := 0; + end; + end; +$0028 : begin + case element of + $00 : info := 'Image Presentation Group Length'; + $02 : begin + info := 'Samples Per Pixel'; + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + lDicomData.SamplesPerPixel :=tmp; + if e_len > 255 then begin + explicitVR := true; //kludge: switch between implicit and explicitVR + end; + tmpstr := inttostr(tmp); + e_len := 0; + remaining := 0; + end; + $04 : begin + info := 'Photometric Interpretation'; + TmpStr := ''; + if dFilePos(fp) > (filesz-e_len) then goto 666; + GetMem( buff, e_len); + dBlockRead(fp, buff{^}, e_len, n); + for i := 0 to e_len-1 do + if Char(buff[i]) in [{'+','-',' ', }'0'..'9','a'..'z','A'..'Z'] + then TmpStr := TmpStr +(Char(buff[i])); + FreeMem( buff); + (*xif TmpStr = 'MONOCHROME1' then lDicomdata.monochrome := 1 + else if TmpStr = 'MONOCHROME2' then lDicomdata.monochrome := 2 + else if (length(TMpStr)> 0) and (TmpStr[1] = 'Y') then lDICOMdata.monochrome := 4 + else lDICOMdata.monochrome := 3; *) + remaining := 0; + e_len := 0; {use tempstr} + + end; + $05 : info := 'Image Dimensions (ret)'; + $06 : begin + info := 'Planar Configuration'; + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + lDicomData.PlanarConfig :=tmp; + remaining := 0; + end; + + $08 : begin + //if lPapyrusnSlices < 1 then + // if remaining = 2 then begin + // tmp := read16(fp,lrOK); + // + // end else xx + DICOMHeaderStringToInt(lDicomData.XYZdim[3]); + if lDicomData.XYZdim[3] < 1 then lDicomData.XYZdim[3] := 1; + info := 'Number of Frames'; + end; + $09: begin info := 'Frame Increment Pointer'; TmpStr := ReadStrHex(fp, remaining,lrOK); if not lrOK then goto 666; + e_len := 0; remaining := 0; end; + $10 : begin info := 'Rows'; + lDicomData.XYZdim[2] := read16(fp,lrOK); + if not lrOK then goto 666; + tmp := lDicomData.XYZdim[2]; + remaining := 0; + end; + $11 : begin info := 'Columns'; + lDicomData.XYZdim[1] := read16(fp,lrOK); + if not lrOK then goto 666; + tmp := lDicomData.XYZdim[1]; + remaining := 0; + end; + $30 : begin info := 'Pixel Spacing'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + //qq + //row spacing [y], then column spacing [x]: see part 3 of DICOM + e_len := 0; remaining := 0; + lDICOMdata.XYZmm[2] := lfloat1; + lDICOMdata.XYZmm[1] := lfloat2; + end; + $31: info := 'Zoom Factor'; + $32: info := 'Zoom Center'; + $34: begin info :='Pixel Aspect Ratio';t := _string; end; + $40: info := 'Image Format [ret]'; + $50 : info := 'Manipulated Image [ret]'; + $51: info := 'Corrected Image'; + $60: begin info := 'Compression Code [ret]';t := _string; end; + $100: begin info := 'Bits Allocated'; + if remaining = 4 then + tmp := read32(fp,lrOK) + else + tmp := read16(fp,lrOK); + //lWord := read16(fp,lrOK); + //lWord := read16(fp,lrOK); + + if not lrOK then goto 666; + if tmp = 8 then lDicomData.Allocbits_per_pixel := 8 + else if tmp = 12 then lDicomData.Allocbits_per_pixel := 12 + else if tmp = 16 then lDicomData.Allocbits_per_pixel := 16 + else if tmp = 32 then lDicomData.Allocbits_per_pixel := 32 + else if tmp = 24 then begin + //xlDicomData.SamplesPerPixel := 3; + lDicomData.Allocbits_per_pixel := 8 + end else begin + lWord := tmp; + lWord := swap(lWord); + if lWord in [8,12,16,24,32] then begin + lDicomData.Allocbits_per_pixel := tmp; + lByteSwap := true; + end else begin + if lImageFormatOK then + Msg('This software only reads 8, 12, 16, 24 [RGB] and 32 bit DICOM files. This file allocates '+inttostr(tmp)+' bits per voxel.'); + lImageFormatOK := false; + end; + end; + //remaining := 2;//remaining; //1371-> + remaining := 0 + end; + $0101: begin info := 'Bits Stored'; + if remaining = 4 then + tmp := read32(fp,lrOK) + else + tmp := read16(fp,lrOK); + + if not lrOK then goto 666; + + (*if tmp <= 8 then lDicomData.Storedbits_per_pixel := 8 + else if tmp <= 16 then lDicomData.Storedbits_per_pixel := 16 + else if tmp <= 24 then begin + lDicomData.Storedbits_per_pixel := 24; + lDicomData.SamplesPerPixel := 3; + end else begin + lWord := tmp; + lWord := swap(lWord); + if lWord in [8,12,16] then begin + lDicomData.Storedbits_per_pixel := tmp; + lByteSwap := true; + end else begin + if lImageFormatOK then + Msg('This software can only read 8, 12 and 16 bit DICOM files. This file stores '+inttostr(tmp)+' bits per voxel.'); + lDicomData.Storedbits_per_pixel := tmp; + lImageFormatOK := false;{ } + end; + end;*) + remaining := 0; + end; + $0102: begin info := 'High Bit'; + if remaining = 4 then + tmp := read32(fp,lrOK) + else + tmp := read16(fp,lrOK); + if not lrOK then + goto 666; + remaining := 0; + end; + $0103: begin + info := 'Pixel Representation'; + if remaining = 2 then begin + tmp := read16(fp,lrOK); + //1= signed, 0=unsigned... + if tmp = 1 then + lDicomData.SignedData := true; + if tmp = 0 then + lDicomData.SignedData := false; + remaining := 0; + end; + end; + $0104: info := 'Smallest Valid Pixel Value'; + $0105: info := 'Largest Valid Pixel Value'; + $0106: begin + //xlDicomData.MinIntensitySet:= true; + info := 'Smallest Image Pixel Value'; + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + //xlDicomData.Minintensity := tmp; + //if >32767 then there will be wrap around if read as signed value! + remaining := 0; + end; + $0107: begin + info := 'Largest Image Pixel Value'; + if remaining = 4 then + tmp := read32(fp,lrOK) + else + tmp := read16(fp,lrOK); + if not lrOK then goto 666; + //xlDicomData.Maxintensity := tmp; + //if >32767 then there will be wrap around if read as signed value! + remaining := 0; + end; + $120: info := 'Pixel Padding Value'; + $200: info := 'Image Location [ret]'; + $1040: begin t := _string; info := 'Pixel Intensity Relationship'; end; + $1050: begin + info := 'Window Center'; + if e_len > 0 then begin + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + //xlDICOMdata.WindowCenter := round(lfloat1); + end; + end;{float} + $1051: begin info := 'Window Width'; + if e_len > 0 then begin + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; + remaining := 0; + //xlDICOMdata.WindowWidth := round(lfloat1); + end; //ignore empty elements, e.g. LeadTech's image6.dic + end; + $1052: begin t := _string;info :='Rescale Intercept'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.intenIntercept := lfloat1; + //if (lDICOMdata.nOrder > 0) and (lDICOMdata.nOrder < kMaxOrderVal) then + // lDICOMdata.OrderIntercept[lDICOMdata.nOrder] := lfloat1; + end; {float} + + $1053:begin + t := _string; info := 'Rescale Slope'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + if lFloat1 < 0.000000001 then begin + lFLoat1 := 1; //misused in some images, see IMG000025 + end; + lDICOMdata.intenScale := lfloat1; + //if (lDICOMdata.nOrder > 0) and (lDICOMdata.nOrder < kMaxOrderVal) then + // lDICOMdata.OrderSlope[lDICOMdata.nOrder] := lfloat1; + end; {float} + $1054:begin t := _string; info := 'Rescale Type';end; + $1100: info := 'Gray Lookup Table [ret]'; + $1101: begin info := 'Red Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK,lJunk); + if not lrOK then goto 666; +e_len := 0; remaining := 0; end; + $1102: begin info := 'Green Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK,lJunk); + if not lrOK then goto 666; +e_len := 0; remaining := 0; end; + $1103: begin info := 'Blue Palette Descriptor'; TmpStr := ReadStr(fp, remaining,lrOK,lJunk); + if not lrOK then goto 666; +e_len := 0; remaining := 0; end; + $1199: begin + info := 'Palette Color Lookup Table UID'; + end; + $1200: info := 'Gray Lookup Data [ret]'; + $1201, $1202,$1203: begin + case element of + $1201: info := 'Red Table'; {future} + $1202: info := 'Green Table'; {future} + $1203: info := 'Blue Table'; {future} + end; + + if dFilePos(fp) > (filesz-remaining) then + goto 666; + if not lReadColorTables then begin + dSeek(fp, dFilePos(fp) + remaining); + end else begin {load color} + width := remaining div 2; + + if width > 0 then begin + getmem(lWordRA,width*2); + for i := (width) downto 1 do + lWordRA^[i] := read16(fp,lrOK); + //value := 159; + value := lWordRA^[1]; + max16 := value; + min16 := value; + for i := (width) downto 1 do begin + value := lWordRA^[i]; + if value < min16 then min16 := value; + if value > max16 then max16 := value; + end; //width..1 + if max16 - min16 = 0 then + max16 := min16+1; {avoid divide by 0} + if (lDicomData.Allocbits_per_pixel <= 8) and (width > 256) then width := 256; //currently only accepts palettes up to 8-bits + GetMem( lColorRA, width );(**) + for i := width downto 1 do + lColorRA^[i] := (lWordRA^[i] shr 8) {and 255}; + FreeMem( lWordRA ); + case element of + $1201: begin + red_table_size := width; + red_table :=lColorRA;; + end; + $1202: begin + green_table_size := width; + green_table :=lColorRA;; + end; + else {x$1203:} begin + blue_table_size := width; + blue_table :=lColorRA;; + end; {else} + end; {case} + end; //width > 0; + if odd(remaining) then + dSeek(fp, dFilePos(fp) + 1{remaining}); + end; {load color} + tmpstr := 'Custom'; + remaining := 0; + e_len := 0; {show tempstr} + end; + $1221, $1222,$1223: begin + info := 'Color Palette ['+inttostr(dFilePos(fp))+']'; + (*xcase element of + $1221: begin + lDicomData.RLEredOffset:= dFilePos(fp); + lDicomData.RLEredSz:= e_len; + end; + $1222: begin + lDicomData.RLEgreenOffset:= dFilePos(fp); + lDicomData.RLEgreenSz:= e_len; + end; + $1223: begin + lDicomData.RLEblueOffset:= dFilePos(fp); + lDicomData.RLEblueSz:= e_len; + end; + end;*)//Case set offset and length + + tmpstr := inttostr(e_len); + dSeek(fp, dFilePos(fp)+ e_LEN); + e_len := 0; + end; + + $3002: info := 'LUT Descriptor'; + $3003: info := 'LUT Explanation'; + $3006: info := 'LUT Data'; + $3010: begin + info := 'VOI LUT Sequence'; + if (explicitVR) and (lT0=kS) and (lT1=kQ) then + e_len := 8; + end; + end; //case +end; //$0028 + $41: case element of //Papyrus Private Group + $1010: begin + info := 'Papyrus Icon [bytes skipped]'; + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; + end; //element $0041:$1010 + $1015: begin + + info := 'Papyrus Slices'; + (*Papyrus format is buggy - see lsjpeg.pas for details, therefore, I have removed extensive support + if e_len = 2 then begin + lDicomData.XYZdim[3] := read16(fp,lrOK); + if not lrOK then goto 666; + end; + if lDicomData.XYZdim[3] < 1 then lDicomData.XYZdim[3] := 1; + if {(false) and }(lDicomData.XYZdim[3] > 1) and (lReadJPEGtables) and (gECATJPEG_table_entries = 0) then begin + //Papyrus multislice files keep separate DICOM headers for each slice within a DICOM file + lPapyrusnSlices := lDicomData.XYZdim[3]; + lPapyrusSlice := 0; + //lPapyrusData := lDicomData; + gECATJPEG_table_entries := lDICOMdata.XYZDim[3]; + getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint)); + getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint)); + end else + lDicomData.XYZdim[3] := 1; + tmpstr := inttostr(lDicomData.XYZdim[3]); + remaining := 0; + e_len := 0;*) + end; //element $0041:$1015 + $1050: begin + info := 'Papyrus Bizarre Element'; //bizarre osiris problem + if (dfilepos(fp)+e_len)= (filesz) then + e_len := 8; + end; //element $0041:$1050 + end; //group $0041: Papyrus + + $43: begin + + if lDicomData.ManufacturerID = kGEID then begin + case element of + $1039,$A039: begin + // 0043,1039 (or 0043,a039). b value (as the first number in the string). + + info := 'GE Bvalue'; + if e_len > 0 then begin + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lDICOMdata.DTI[1].bval := round(lfloat1); + lDICOMdata.nDTIdir := 1; + end; //e_len>0 + end;//1039 or Ao39 + end;//Case + end; //Manufacturer = GE + end;//$0043 - GE bvalues + + $54: case element of + $0: info := 'Nuclear Acquisition Group Length'; + $11: info := 'Number of Energy Windows'; + $21: info := 'Number of Detectors'; + $51: info := 'Number of Rotations'; + $80: begin info := 'Slice Vector'; TmpStr := ReadStr(fp, remaining,lrOK,lJunk); if not lrOK then goto 666; + e_len := 0; remaining := 0; end; + $81: info := 'Number of Slices'; + $202: info := 'Type of Detector Motion'; + $400: info := 'Image ID'; + + end; + $2010 : + case element of + $0: info := 'Film Box Group Length'; + $100: info := 'Border Density'; + end; + $4000 : info := 'Text'; + $0029 : begin + case element of + $1010: begin + //lSiemensMosaic0029_1010:= true; + if (lDicomData.kV = 0) then begin //Siemens uses 0029:1010 for both CT and MRI, but only MRI is in CSA format + lDicomData.CSAImageHeaderInfoPos := (dFilePos(fp)); + lDicomData.CSAImageHeaderInfoSz := e_len; + end; + info := 'Private Sequence Delimiter ['+inttostr(dFilePos(fp))+']'; + if not lImageFormatOK then + time_to_quit := TRUE; + + //x(lDicomData.RunLengthEncoding) or ( ((lDicomData.JPEGLossycpt) or (lDicomData.JPEGLosslesscpt)) and (gECATJPEG_table_entries >= lDICOMdata.XYZdim[3]))} + + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; {show tempstr} + end; + $1053: begin + info :='Philips Scale Slope'; + readfloats (fp, remaining, lDummyStr, lfloat1, lfloat2, lROK); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + lPhilipsScaleSlope := lfloat1; + {if e_len = 4 then begin + lPhilipsScaleSlope := read32r(fp,lrOK); + TmpStr := floattostr(lPhilipsScaleSlope); + t := _string; + + if not lrOK then goto 666; + e_len := 0; + remaining := 0; + end; } + end; + + + else begin + end; + END; + END; //gROUP 0029 + + (* $0045 : begin + case element of + $103B: begin + msg('0045:103B'); + end; //element $1010 + + end; //CASE...element + end; //group 0045 + *) + $0089 : begin + case element of + $1010: begin + e_len := 0; + lProprietaryImageThumbnail := true; + //lImageFormatOK := false; + end; //element $1010 + $1020: begin + //thoravision files + + if e_len > 12 then + e_len := 0; + //lProprietaryImageThumbnail := true; + //lImageFormatOK := false; + end; //element $1010 + + end; //CASE...element + end; //group 0089 + + $2001 : begin + if lDicomData.ManufacturerID = kPhilipsID then begin + case element of + + $1003: begin //bvalue + if e_len = 4 then begin + if lDICOMdata.nDTIdir < kMaxDTIdir then + inc(lDICOMdata.nDTIdir); + lDICOMdata.DTI[lDICOMdata.nDTIdir].bval := round(read32r(fp,lrOK)); + TmpStr := inttostr(lDICOMdata.DTI[lDICOMdata.nDTIdir].bval); + t := _string; + info :='DTI b-val'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; //e_len = 4 + + end; //element 1003 + $100B: begin + info := 'philips: slice orientation';t := _string; + TmpStr := ''; + DICOMHeaderString(TmpStr); + lDicomData.PhilipsSliceOrient := TmpStr; + AplhaNumericStrDICOM (lDicomData.PhilipsSliceOrient); + end;//PhilipsSliceOrient + $1018: begin + if e_len = 4 then begin + info :='number of slices'; + lDicomData.SlicesPer3DVol := read32(fp,lrOK); + //uninterleave data + e_len := 0; remaining := 0; + if lResearchMode then + lDicomData.SeriesNum := lDicomData.SeriesNum + 50; //do not jumble research recons and normal images + end; //e_len = 4 + TmpStr := floattostr(lDicomData.SlicesPer3DVol); + end; //1018 + + $102D: begin + ///Apr2007 + + if e_len = 2 then begin + lnSlicePerVol := read16(fp,lrOK); + e_len := 0; remaining := 0; + end; + //fx(213,lnSlicePerVol); + end; //102D + + $105F: begin //Philips Stack Sequence + + if e_len > 8 then e_len := 8; + end; //105F + end; + end; //if manufacturer = Philips + end; + + //2001,1004) + + $2005 : begin + + + //if lDicomData.ManufacturerID = kPhilipsID then Msg(inttohex(element,4)); + if lDicomData.ManufacturerID = kPhilipsID then begin + case element of + (* $140F: begin + lInside2005140F := true; + end;*) + $100E: begin + if e_len = 4 then begin + lPhilipsScaleSlope := read32r(fp,lrOK); + TmpStr := floattostr(lPhilipsScaleSlope); + t := _string; + info :='Philips Scale Slope'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + end; //element $1010 + + $1071: begin + + if e_len = 4 then begin + lDicomData.AngulationAP := read32r(fp,lrOK); + TmpStr := floattostr(lDicomData.AngulationAP); + t := _string; + info :='angulation midslice, AP (degrees)'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + end; // Philips AP angulation : -8.74086 + $1072: begin + if e_len = 4 then begin + lDicomData.AngulationFH := read32r(fp,lrOK); + TmpStr := floattostr(lDicomData.AngulationFH); + t := _string; + info :='angulation midslice, FH (degrees)'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + end; // Philips Philips FH angulation : -3.53147 + $1073: begin + if e_len = 4 then begin + lDicomData.AngulationRL := read32r(fp,lrOK); + TmpStr := floattostr(lDicomData.AngulationRL); + t := _string; + info :='angulation midslice, RL (degrees)'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; + end; // Philips RL angulation + $10b0: begin + if e_len = 4 then begin + //msg('2005,10b0 @ '+ inttostr(dFilePos(fp)) +' #'+inttostr(lDICOMdata.nDTIdir)); + lDICOMdata.DTI[lDICOMdata.nDTIdir].v1 := read32r(fp,lrOK); + TmpStr := floattostr(lDICOMdata.DTI[lDICOMdata.nDTIdir].v1); + t := _string; + info :='Philips Gradient vector [x]'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; //e_len = 4 + end; //element 10b0 + $10b1: begin + + if e_len = 4 then begin + + lDICOMdata.DTI[lDICOMdata.nDTIdir].v2 := read32r(fp,lrOK); + TmpStr := floattostr(lDICOMdata.DTI[lDICOMdata.nDTIdir].v2); + t := _string; + info :='Philips Gradient vector [y]'; + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; //e_len = 4 + end; //element 10b1 + $10b2: begin + if e_len = 4 then begin + lDICOMdata.DTI[lDICOMdata.nDTIdir].v3 := read32r(fp,lrOK); + TmpStr := floattostr(lDICOMdata.DTI[lDICOMdata.nDTIdir].v3); + t := _string; + info :='Philips Gradient vector [z]'; + //fx(lDICOMdata.DTI[lDICOMdata.nDTIdir].v1,lDICOMdata.DTI[lDICOMdata.nDTIdir].v2,lDICOMdata.DTI[lDICOMdata.nDTIdir].v3); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end; //e_len = 4 + + + end; //element 10b2 + $140f: begin + //msg('2005:140F@ '+inttostr(dFilePos(fp)) +' len: '+inttostr(e_len) +' '+ chr(lT0)+chr(lT1)); + if (e_len > 8) then begin + e_len := 8; remaining := e_len; //qas 7/2013 + end; + end;//140f + $1455: begin + //msg('2005:1455@ '+inttostr(dFilePos(fp)) +' len: '+inttostr(e_len) +' '+ chr(lT0)+chr(lT1)); + (*if (e_len > 8) then begin + e_len := 8; remaining := e_len; //qas 7/2013 + end; *) + end;//1455 + + end; //CASE...element + end; //if Manufacturer = Philips + end; //group 2005 + $5200 : begin + case element of + $9230: begin + //msg('5200:9230@ '+inttostr(dFilePos(fp))+' e_len '+inttostr(e_len)+' remaining '+inttostr(remaining)); + //lverboseRead := true; //qas + //fx(e_len,678xx9); + if (e_len > 8) then begin + e_len := 8; remaining := e_len; //qas 7/2013 + end; + (* if (lDicomData.ManufacturerID = kPhilipsID) and (orientation_not_visible( lDICOMdata))then + read_philips_hidden(lFilename, dFilePos(fp),e_len,lDICOMdata);*) + end //element 9230 + end; //case element + end; //group 5200 + $5400 : begin + case element of + $0100: begin + //can not convert sound files to images 12/2012 + lImageFormatOK := false; + msg('Note: the DICOM file '+lFileName+' stores a waveform sequence (e.g. ECG) that will not be converted to an image'); + info :='WaveformSequence'; + //fx(lDICOMdata.DTI[lDICOMdata.nDTIdir].v1,lDICOMdata.DTI[lDICOMdata.nDTIdir].v2,lDICOMdata.DTI[lDICOMdata.nDTIdir].v3); + if not lrOK then goto 666; + e_len := 0; remaining := 0; + end //element 0100 + end; //case element + end; //group 5400 + $DDFF : begin + case element of + $00E0: begin + //For papyrus multislice format: if (lPapyrusSlice >= lPapyrusnSlices) then + time_to_quit := TRUE; + end; + end; + end; + $FFFE : begin + case element of + $E000 : begin + //if (lIndent > 3) then lverboseRead := false; //qas + inc(lIndent); + //msg('FFFE:E000@ '+inttostr(dFilePos(fp)) +' len: '+inttostr(e_len) +' '+ chr(lT0)+chr(lT1)); + + e_len := 0; remaining := e_len; //qas 7/2013 + lInside00209113 := (lprevGroup = $0020) and (lprevelement = $9113); + lInside2005140F := (lprevGroup = $2005) and (lprevelement = $140F); + // if (lInside00209113) then fx(333); + (*iif lJPEGEntries > 17 then + lTestError := true; + + + if not lProprietaryImageThumbnail then begin + f (lReadJPEGtables) and ((lDICOMdata.RunLengthEncoding) or (lDICOMdata.JPEGLossyCpt) or (lDICOMdata.JPEGLosslessCpt)) and (not lFirstFragment) and (e_len > 1024) {1384} and ( (e_len+dFilePos(fp)) <= FileSz) then begin + //first fragment is the index table, so the previous line skips the first fragment + if (gECATJPEG_table_entries = 0) then begin + gECATJPEG_table_entries := lDICOMdata.XYZDim[3]; + getmem (gECATJPEG_pos_table, gECATJPEG_table_entries*sizeof(longint)); + getmem (gECATJPEG_size_table, gECATJPEG_table_entries*sizeof(longint)); + end; + if lJPEGentries < gECATJPEG_table_entries then begin + inc(lJPEGentries); + gECATJPEG_pos_table^[lJPEGEntries] := dFilePos(fp); + gECATJPEG_size_table^[lJPEGEntries] := e_len; + end; + end; + + if (lDICOMdata.CompressOffset =0) and ( (e_len+dFilePos(fp)) <= FileSz) and (e_len > 1024){ALOKA} then begin + lDICOMdata.CompressOffset := dFilePos(fp); + lDICOMdata.CompressSz := e_len; + end; + //if e_len > lDICOMdata.CompressSz then lDICOMdata.CompressSz := e_len; +if (e_len > 1024) and (lDICOMdata.CompressSz=0) then begin //ABBA RLE ALOKA + //Time_To_Quit := true;//ABBA + lDICOMdata.CompressSz := e_len; + lDICOMdata.CompressOffset := dFilePos(fp); +end; + if (lFirstFragment) or ((e_len > lDICOMdata.CompressSz) and not (lDicomData.RunLengthEncoding)) then + lDICOMdata.CompressOffset := dFilePos(fp); + if (e_len > lDICOMdata.CompressSz) and (e_len > 1024){ALOKA} then + lDICOMdata.CompressSz := e_len; + lFirstFragment := false; + lDICOMdataBackUp := lDICOMData; + + if (gECATJPEG_table_entries = 1) then begin //updatex + gECATJPEG_size_table^[1] := lDICOMdata.CompressSz; + gECATJPEG_pos_table^[1] := lDICOMdata.CompressOffset; + end; //updatex + +end; //not proprietaryThumbnail +lProprietaryImageThumbnail := false; //1496 + *) + lFirstFragment := false;//Dec09 + lDICOMdataBackUp := lDICOMData;//Dec09 + + if ((e_len > 1024) and ((lDicomData.JPEGLosslessCpt)) or (e_len >= (lDicomData.XYZdim[1]*lDicomData.XYZdim[2]))){Apr 2011} and (lDicomData.XYZdim[1]> 1) then begin + lDICOMdata.CompressOffset := dFilePos(fp); + lDICOMdata.CompressSz := e_len; + + Time_To_Quit := true; + //msg('abba'+inttostr(lDICOMdata.CompressOffset)+' '+inttostr(lDICOMdata.CompressSz)); + end; + info := 'Image Fragment ['+inttostr(dFilePos(fp))+']'; + + if (dFilePos(fp) + e_len) >= filesz then + Time_To_Quit := true; + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; + end; + $E0DD : begin + if (lIndent > 0) then dec(lIndent); + lInside00209113 := false; + lInside2005140F := false; + info := 'Sequence Delimiter'; + if (lDICOMdata.XYZdim[1]<lDICOMdataBackUp.XYZdim[1]) then begin + lDICOMData := lDICOMdataBackUp; + dSeek(fp, dFilePos(fp) + e_len); + //lDICOMData := lDICOMdataBackUp; + end else if not lImageFormatOK then begin + //x(lDicomData.RunLengthEncoding) or ( ((lDicomData.JPEGLossycpt) or (lDicomData.JPEGLosslesscpt)) and (gECATJPEG_table_entries >= lDICOMdata.XYZdim[3])) then + time_to_quit := TRUE; + end; + //RLE ABBA + if (e_len = 0) then begin //ALOKA + explicitVR := true; + time_to_quit := FALSE;//RLE16=false + end; + //END + + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; + end; + end; + end; + $FFFC : begin + dSeek(fp, dFilePos(fp) + e_len); + tmpstr := inttostr(e_len); + remaining := 0; + e_len := 0; + end; + $72FF : case element of + $1041: time_to_quit := TRUE; + end; //case 72FF + $7FE0 : + case element of + $00 : begin + info := 'Pixel Data Group Length'; + if not lImageFormatOK then time_to_quit := TRUE; + end; + $10 : begin + info := 'Pixel Data'; + TmpStr := inttostr(e_len); + //Showmsg(inttostr(ExpectedDicomBytes(lDicomData) ) +' '+ inttostr(e_len)); + if ((ExpectedDicomBytes(lDicomData) ) > e_len) or (lDICOMdata.XYZdim[1]<lDICOMdataBackUp.XYZdim[1]) then begin + lDICOMData := lDICOMdataBackUp; + dSeek(fp, dFilePos(fp) + e_len); + //lDICOMData := lDICOMdataBackUp; + end else if {(not lDicomData.RunLengthEncoding) and} (not lDicomData.JPEGLossycpt) and (not lDicomData.JPEGLosslesscpt) then begin + time_to_quit := TRUE; + //xlDicomData.ImageSz := e_len; + + end; + e_len := 0; + + end; + + + end; + else + begin + if (group >= $6000) AND (group <= $601e) AND ((group AND 1) = 0) + then begin + info := 'Overlay'+inttostr(dfilepos(fp))+'x'+inttostr(e_len); + end; + if element = $0000 then info := 'Group Length'; + if element = $4000 then info := 'Comments'; + end; + end; +lStr := ''; + + 1234: + lprevGroup := Group; + lprevElement := element; +if (Time_TO_Quit) and (not lImageFormatOK) then begin + lHdrOK := true; + goto 666; +end; + +//Msg(inttohex(group,4) +':'+inttohex(element,4) +' '+inttostr(e_len)+'@'+ inttostr(dfilepos(fp))); + + if (e_len + dfilepos(fp)) > FileSz then begin//patch for GE files that only fill top 16-bytes w Random data + e_len := e_len and $FFFF; + end; + + if (e_len > 131072) then begin + //goto 666; + end;//zebra + if (NOT time_to_quit) AND (e_len > 0) and (remaining > 0) then begin + if (e_len + dfilepos(fp)) > FileSz then begin + if not lImageFormatOK(*x(lDICOMdata.GenesisCpt) or (lDICOMdata.JPEGlosslessCpt) or (lDICOMdata.JPEGlossyCpt)*) then + lHdrOK := true + else begin + Msg('dcm Error: not a DICOM image: '+lFilename); + {Msg('Diagnostics saved as: c:\dcmcrash.txt'); + //diagnostics + assignfile(lTextF,'c:\dcmcrash.txt'); + Filemode := 0; + rewrite(lTextF); + Write(lTextF,lDynStr); + closefile(lTextF); } + + //Msg(inttohex(group,4) +':'+inttohex(element,4) +' '+inttostr(e_len)+'@'+ inttostr(dfilepos(fp))); + end; + goto 666; + end; + + if e_len > 0 then begin + GetMem( buff, e_len); + dBlockRead(fp, buff, e_len, n); + if lVerboseRead then + case t of + unknown : + case e_len of + 1 : lStr := ( IntToStr(Integer(buff[0]))); + 2 : Begin + if lDicomData.little_endian <> 0 + then i := Integer(buff[0]) + 256*Integer(buff[1]) + else i := Integer(buff[0])*256 + Integer(buff[1]); + lStr :=( IntToStr(i)); + end; + 4 : Begin + if lDicomData.little_endian <> 0 + then i := Integer(buff[0]) + + 256*Integer(buff[1]) + + 256*256*Integer(buff[2]) + + 256*256*256*Integer(buff[3]) + else i := Integer(buff[0])*256*256*256 + + Integer(buff[1])*256*256 + + Integer(buff[2])*256 + + Integer(buff[3]); + lStr := (IntToStr(i)); + end; + else begin + if e_len > 0 then begin + for i := 0 to e_len-1 do begin + if Char(buff[i]) in ['+','-','/','\',' ', '0'..'9','a'..'z','A'..'Z'] then + lStr := lStr+(Char(buff[i])) + else + lStr := lStr+('.'); + end; + end else + lStr := '*NO DATA*'; + end; + end; + + i8, i16, i32, ui8, ui16, ui32, + _string : for i := 0 to e_len-1 do + if Char(buff[i]) in ['+','-','/','\',' ', '0'..'9','a'..'z','A'..'Z'] + then lStr := lStr +(Char(buff[i])) + else lStr := lStr +('.'); + end; + FreeMem(buff); + + end; + end + else if e_len > 0 then lStr := (IntToStr(tmp)) + else begin + lStr := TmpStr; + end; + (*if (lGrp) then if MessageDlg(lStr+'= '+info+' '+IntToHex(where,4)+': ('+IntToHex(group,4)+','+IntToHex(element,4)+')'+IntToStr(e_len)+'. Continue?', + mtConfirmation, [mbYes, mbNo], 0) = mrNo then GOTO 666; + *) + //if (Group > $2005) then + // msg(info+' '+IntToStr(where)+': ('+IntToHex(group,4)+','+IntToHex(element,4)+')'+IntToStr(e_len)); +{$IFDEF Troubleshoot} + Msg( IntToHex(group,4)+','+IntToHex(element,4)+','+Info+'='+lStr);//+' Offset'+inttostr(dfilepos(fp))+' Length'+inttostr(e_len)); +{$ENDIF Troubleshoot} + + + if lverboseRead then begin +if length(lDynStr) > kMaxTextBuf then begin + if not lTextOverFlow then begin + lDynStr := lDynStr + 'Only showing the first '+inttostr(kMaxTextBuf) +' characters of this LARGE header'; + lTextOverFlow := true; + + end; + //goto 666; +end else + lDynStr := lDynStr+IntToHex(group,4)+','+IntToHex(element,4)+','+Info+'='+lStr+kCR ; + + Msg(AddIndent(lIndent)+IntToHex(group,4)+','+IntToHex(element,4)+','+inttostr(e_len)+'@'+inttostr(dfilepos(fp))+','+Info+'='+lStr); +end; //not verbose read + + end; // end for + + lDicomData.ImageStart := dfilepos(fp); + + if lBigSet then begin + if lBig then lDicomData.little_endian := 0 + else lDicomData.little_endian := 1; + end; + lHdrOK := true; +if lByteSwap then begin + ByteSwap(lDicomdata.XYZdim[1]); + ByteSwap(lDicomdata.XYZdim[2]); + if lDicomdata.XYZdim[3] <> 1 then + ByteSwap(lDicomdata.XYZdim[3]); + //xByteSwap(lDicomdata.SamplesPerPixel); + ByteSwap(lDicomData.Allocbits_per_pixel); + //xByteSwap(lDicomData.Storedbits_per_pixel); +end; + +if (lDICOMdata.ManufacturerID = kPhilipsID) and (l4DDistanceBetweenSliceCenters <> kNaNsingle) then //some 3D and 4D Philips files do not correctly report interslice distance in 0018,0088 and 0018,0050... + lDICOMdata.XYZmm[3] := (l4DDistanceBetweenSliceCenters); +if (lPrefs.PhilipsPrecise) and (lManufacturerIsPhilips) and (lPhilipsScaleSlope <> 0) then begin + PhilipsPrecise (lDicomData.IntenScale, lDICOMdata.intenIntercept,lPhilipsScaleSlope, lDicomData.IntenScale, lDICOMdata.intenIntercept,true); +end; //if PARprecise +if (lDICOMdata.ManufacturerID = kPhilipsID) and (lDICOMdata.nDTIdir > 1) then begin + lGELX := true; + for i := 1 to lDICOMdata.nDTIdir do + if lDICOMdata.DTI[lDICOMdata.nDTIdir].bval <> lDICOMdata.DTI[1].bval then + lGELX := false;//multiple B0 directions + if lGELX then + lDICOMdata.nDTIdir := 1; + lGELX := false; +end; +if (lMatrixSz > 1) and (lDicomData.CSAImageHeaderInfoPos > 0) and (lDicomData.CSAImageHeaderInfoSz > 0) and + not (((lDicomdata.XYZdim[1] mod lMatrixSz) = 0) and ((lDicomdata.XYZdim[2] mod lMatrixSz) = 0)) then begin + //Slow method for non-square Siemens matrices - 0018:1310 based on phase/freq, so it is easier to read CSA to decode rows/columns + + GetCSAImageHeaderInfo (lFilename, lDicomData.CSAImageHeaderInfoPos ,lDicomData.CSAImageHeaderInfoSz, lTempInt,lDICOMdata.SiemensMosaicX,lDICOMdata.SiemensMosaicY, lfloat1,lfloat2,lfloat3) +end else + if (lMatrixSz > 1) and ((lDicomdata.XYZdim[1] mod lMatrixSz) = 0) and ((lDicomdata.XYZdim[2] mod lMatrixSz) = 0) then begin + + if ((lDicomData.XYZdim[1] mod lMatrixSz)=0) then + lDicomData.SiemensMosaicX := lDicomData.XYZdim[1] div lMatrixSz; + if ((lDicomData.XYZdim[2] mod lMatrixSz)=0) then + lDicomData.SiemensMosaicY := lDicomData.XYZdim[2] div lMatrixSz; + if lDicomData.SiemensMosaicX < 1 then lDicomData.SiemensMosaicX := 1; //1366 + if lDicomData.SiemensMosaicY < 1 then lDicomData.SiemensMosaicY := 1; //1366 + + if lOldSiemens_IncorrectMosaicMM then begin //old formats convert size in mm incorrectly - modern versions are correct and include transfer syntax + lDicomdata.XYZmm[1] := lDicomdata.XYZmm[1] * (lDicomdata.XYZdim[1] div lMatrixSz); + lDicomdata.XYZmm[2] := lDicomdata.XYZmm[2] * (lDicomdata.XYZdim[2] div lMatrixSz); + end; +end else if (lSiemensMosaic0008_0008) and (lPhaseEncodingSteps > 0) and (lPhaseEncodingSteps < lDicomdata.XYZdim[2]) and ((lDicomdata.XYZdim[2] mod lPhaseEncodingSteps) = 0) and ((lDicomdata.XYZdim[2] mod (lDicomdata.XYZdim[2] div lPhaseEncodingSteps)) = 0) then begin + //1499c kludge for detecting new Siemens mosaics: WARNING may cause false positives - Siemens fault not mine! + lDicomData.SiemensMosaicY :=lDicomdata.XYZdim[2] div lPhaseEncodingSteps; + lDicomData.SiemensMosaicX := lDicomData.SiemensMosaicY; //We also need to assume as many mosaic rows as columns, as Siemens does not save the phase encoding lines in the header... +end; + // fx(lnSlicePerVol,lnVol, lDicomData.SlicesPer3DVol,lDicomdata.XYZdim[3] ); +//fx(lnVol,lnSlicePerVol,lDicomData.SlicesPer3DVol,lDicomdata.XYZdim[3]); +//fx(lnSlicePerVol,lDicomData.ManufacturerID,kPhilipsID ); +if (lnSlicePerVol > 0) and (lDicomData.ManufacturerID = kPhilipsID) {and (lnVol > 1)} and (lDicomdata.XYZdim[3] > 1) and (lDicomData.SlicesPer3DVol > 0)and ((lDicomdata.XYZdim[3] mod lDicomData.SlicesPer3DVol) = 0) then begin + lDICOMdata.File4D := true; + lnVol := lDicomdata.XYZdim[3] div lDicomData.SlicesPer3DVol; +end; +if lManufacturerIsBruker then + lDicomData.AcquNum := 1; //Bruker varies this for every image + +if (lEchoNum > 0) and (lEchoNum < 16) then begin + lDicomData.AcquNum := lDicomData.AcquNum + (1000*lEchoNum); +end; + +if lVerboseRead then begin + // lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ + Msg ('DICOM data'); + Msg ('Series/Acquisition/Image/Xpos/YPos/ZPos:'+kTab+inttostr(lDicomData.SeriesNum)+kTab+inttostr(lDicomData.AcquNum)+kTab+inttostr(lDicomData.ImageNum)+kTab+floattostr(lDicomData.PatientPosX)+kTab+floattostr(lDicomData.PatientPosY)+kTab+floattostr(lDicomData.PatientPosZ)); + Msg ('BPP: '+inttostr(lDicomData.Allocbits_per_pixel)); + Msg ('XYZ dim:' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) ); + Msg ('XYZ mm:'+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) ); + Msg ('DTI bvalue:'+ inttostr(lDICOMdata.DTI[1].bval)); + Msg ('DTI bvec:'+floattostrf(lDicomData.DTI[1].v1,ffFixed,8,2)+'/'+floattostrf(lDicomData.DTI[1].v2,ffFixed,8,2)+'/'+floattostrf(lDicomData.DTI[1].v3,ffFixed,8,2) ); + end; + //msg('abba'+inttostr(lDICOMdata.CompressOffset)+' '+inttostr(lDICOMdata.CompressSz)); + 666: + //if not lHdrOk then Msg('zx'+lFilename); + if lDiskCacheSz > 0 then + freemem(lDiskCacheRA); + if not lHdrOK then lImageFormatOK := false; + CloseFile(fp); + FileMode := 2; //set to read/write + //if kUseDateTimeForID then + lDicomData.DateTime := StudyDateTime(lDicomData.StudyDate,lDicomData.StudyTime); + if (lDicomData.SiemensMosaicX > 1) then + lDicomData.AcquNum := 1; +end; + + +end. \ No newline at end of file diff --git a/dcm2nii/dicomfast.o b/dcm2nii/dicomfast.o new file mode 100644 index 0000000..4062188 Binary files /dev/null and b/dcm2nii/dicomfast.o differ diff --git a/dcm2nii/dicomfast.pas b/dcm2nii/dicomfast.pas new file mode 100755 index 0000000..234a460 --- /dev/null +++ b/dcm2nii/dicomfast.pas @@ -0,0 +1,512 @@ +unit dicomfast; +{$H+} +//this is x3 faster than the dicomcompat routines, but only works with well-behaved Explicit Little-Endian DICOM +interface +//0008,0070,ManufacturerID +//Next values for Philips +//Philips - must set 2001,105F length to 8 - allows reading of stack sequence +// 2005,1071. Philips AP angulation +// 2005,1072. Philips RL angulation +// 2005,1073. Philips FH angulation +//2001,100B Philips slice orientation (TRANSVERSAL, AXIAL, SAGITTAL) +// Next values for GE +//0019,10bb (or 0019,a0bb)= X diffusion direction +//0019,10bc (or 0019,a0bc)= Y diffusion direction +//0019,10bd (or 0019,a0bd)= Z diffusion direction +//0018,1312 = phase encoding. + + +uses +{$IFNDEF FPC}Controls, {$ENDIF} + SysUtils,define_types,classes,dicomtypes,dialogs_msg; + +function fast_read_dicom_data(var lDICOMdata: DICOMdata; lOffset: integer; var lFileName: string): boolean; //x3 faster! + + +implementation +uses dialogsx; +{$DEFINE ANON} + +function fast_read_dicom_data(var lDICOMdata: DICOMdata; lOffset: integer; var lFileName: string): boolean; +label +999; +const + kMaxBuf = (256*256)-1; //bytes + kMax16bit = (256*256)-1; + kImageType = $0008+($0008 shl 16 ); + kStudyDate = $0008+($0020 shl 16 ); + kSeriesDate = $0008+($0021 shl 16 ); + kAcqDate = $0008+($0022 shl 16 ); + kCreateDate = $0008+($0012 shl 16 ); + kStudyTime = $0008+($0030 shl 16 ); + kPatientName = $0010+($0010 shl 16 ); + {$IFDEF ANON} //position and lengths of tags to anonymize + kPatientID = $0010+($0020 shl 16 ); + kPatientDOB = $0010+($0030 shl 16 ); + kPatientSex = $0010+($0040 shl 16 ); + kPatientAge = $0010+($1010 shl 16 ); + kPatientWt = $0010+($1030 shl 16 ); + {$ENDIF} + kSeq = $0018+($0020 shl 16 ); + kZThick = $0018+($0050 shl 16 ); + kTR = $0018+($0080 shl 16 ); + kTE = $0018+($0081 shl 16 ); + kEchoNum = $0018+($0086 shl 16 ); + kZSpacing = $0018+($0088 shl 16 ); + kProtocolName = $0018+($1030shl 16 ); + kPatientPos = $0018+($5100 shl 16 ); + kSeriesNum = $0020+($0011 shl 16 ); + kAcquNum = $0020+($0012 shl 16 ); + kImageNum = $0020+($0013 shl 16 ); + kOrientation = $0020+($0037 shl 16 ); + kLocation = $0020+($1041 shl 16 ); + kDim3 = $0028+($0008 shl 16 ); + kDim2 = $0028+($0010 shl 16 ); + kDim1 = $0028+($0011 shl 16 ); + kXYSpacing = $0028+($0030 shl 16 ); + kPosition = $0020+($0032 shl 16 ); + knVol = $0020+($0105 shl 16 ); + kAlloc = $0028+($0100 shl 16 ); + kIntercept = $0028+($1052 shl 16 ); + kSlope = $0028+($1053 shl 16 ); + kCSAImageHeaderInfo = $0029+($1010 shl 16 ); + kSlicesPer3DVol = $2001+($1018 shl 16 ); + kTransferSyntax = $0002+($0010 shl 16); + kImageStart = $7FE0+($0010 shl 16 ); + kMaxFloats = 6; +var + vr : array [1..2] of Char; + lFailure: boolean; + lByteRA: Bytep; + lFloatRA: array [1..kMaxFloats] of double; + lBufferSz,lPos,lFileSz,lBuffStart: integer; + lInFile: file; + lBufferError: boolean; +procedure Str2FloatNum ( lStr: string; lnFloats: integer); +var + lFStr: string; + lP,lnF: integer; +begin + if (length(lStr) < 1) or (lnFloats < 1) or (lnFloats > kMaxFloats) then + exit; + for lnF := 1 to lnFloats do + lFloatRA[lnF] := 1; + lStr := lStr + ' '; //terminator + lFStr := ''; + lP := 1; + lnF:= 0; + while lP <= length(lStr) do begin + if lStr[lP] in ['+','-','0'..'9','.','e','E'] then + lFStr := lFStr + lStr[lP] + else if (lFStr <> '') then begin + inc(lnF); + //if lnFloats = 6 then showmessage(lFStr); + try + lFloatRA[lnF] := strtofloat(lFStr); + except on EConvertError do + lFloatRA[lnF] := 1; + end;//except + if lnF = lnFloats then exit; + lFStr := ''; + end; + inc(lP); + end; +end; //function Str2Float + +function GetByte (lFilePos: integer): byte; +var + lBufPos: integer; +begin + //the following error checking slows down reads a lot! + //a simpler alternative would be to make the buffer size the same size as the entire image... + //the current strategy saves memory and is faster for large images with small headers + if lFilepos > lFileSz then begin + lBufferError := true; + result := 0; + exit; + end; + lBufPos := lFilepos - lBuffStart+1; + if (lBufPos > lBufferSz) or (lBufPos < 1) then begin //reload buffer + if (lFilePos < 0) or (lFilePos > lFileSz) then begin + lBuffStart := lFilePos; + lBufPos := 1; + dcmMsg(lFileName); + lFailure := true; + dcmMsg('Error: buffer overrun in DICOM read.'); + exit; + end; + if lFilePos+kMaxBuf > lFileSz then + lBufferSz := lFileSz - (lFilePos) + else + lBufferSz := kMaxBuf; //read remaining + //fx(lFilepos,kMaxBuf); + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lFilePos); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + FileMode := 2; + lBuffStart := lFilePos; + lBufPos := 1; + end; + result := lByteRA^[lBufPos]; +end; + +function ReadInt4: integer; +begin + if lDicomData.little_endian = 0 then + result := GetByte(lPos+3)+(GetByte(lPos+2) shl 8)+(GetByte(lPos+1) shl 16)+(GetByte(lPos) shl 24) + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24); + inc(lPos,4); +end; //function Read4 + +procedure ReadGroupElementLength(var lGroupElement,lLength: integer); +begin + lGroupElement := ReadInt4; + vr[1] := chr(GetByte(lPos)); + vr[2] := chr(GetByte(lPos+1)); + //msg(' '+InttoHex(lGroupElement,8)+' '+inttostr(lLength)+' '+VR+ inttostr(GetByte(lPos+2))); + + if (vr[2] < 'A') then begin //implicit vr with 32-bit length + lLength := ReadInt4; + exit; + end; + //if vr = 'UN' then + if (vr = 'OB') or (vr = 'OW') or (vr = 'SQ') or (vr = 'UN') then begin {explicit VR with 32-bit length} + lPos := lPos + 4; {skip 2 byte string and 2 reserved bytes = 4 bytes = 2 words} + lLength := ReadInt4;//Ord4(buf[lPos]) + $100 * (buf[lPos+1] + $100 * (buf[lPos+2] + $100 * buf[lPos+3])) + end else begin {explicit VR with 16-bit length} + if lDicomData.little_endian = 0 then + lLength := (GetByte(lPos+3))+(GetByte(lPos+2) shl 8) + else + lLength := (GetByte(lPos+2))+(GetByte(lPos+3) shl 8);//GetLength := Ord4(buf[i+2]) + $100 * (buf[i+3]); + lPos := lPos + 4; {skip 2 byte string and 2 length bytes = 4 bytes = 2 words} + end; + // msg(InttoHex(lGroupElement,8)+' '+inttostr(lLength)+' '+VR+ inttostr(GetByte(lPos+2)) + 'x'+inttostr(GetByte(lPos+3)) ); + +end; //procedure ReadGroupElementLength + +function DCMStr(lBytes: integer): string; +var + lC: integer; +begin + result := ''; + if lBytes < 1 then + exit; + for lC := lPos to (lPos+(lBytes-1)) do + result := result + char(GetByte(lC)); + for lC := 1 to lBytes do + if result[lC] in ['+','-','/','\',' ','0'..'9','a'..'z','A'..'Z','.'] then + else + result[lC] := ' '; +end; //function DCMStr + +function DCMStr2Int (lBytes: integer): integer; +var lErr: integer; + lStr: string; +begin + lStr := DCMStr(lBytes); + Val(lStr,result,lErr); +end; //function DCMStr2Int + +procedure DCMStr2FloatNum (lBytes,lnFloats: integer); +begin + Str2FloatNum (DCMStr(lBytes), lnFloats); +end; //function DCMStr2Float + +function DCMStr2Float (lBytes: integer): single; +begin + DCMStr2FloatNum (lBytes,1); + result := lFloatRA[1]; +end; //function DCMStr2Float + +procedure DCMStr2Float2 (lBytes: integer; var lF1,lF2: double); +begin + DCMStr2FloatNum (lBytes,3); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; +end; //function DCMStr2Float2 + +procedure DCMStr2Float3 (lBytes: integer; var lF1,lF2,lF3: double); +begin + DCMStr2FloatNum (lBytes,3); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; + lF3 := lFloatRA[3]; +end; //function DCMStr2Float3 + +procedure DCMStr2Float6 (lBytes: integer; var lF1,lF2,lF3,lF4,lF5,lF6: double); +begin + DCMStr2FloatNum (lBytes,6); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; + lF3 := lFloatRA[3]; + lF4 := lFloatRA[4]; + lF5 := lFloatRA[5]; + lF6 := lFloatRA[6]; +end; //function DCMStr2Float6 + +function DCMint (lBytes: integer): integer; //read 16 bit short integer +begin + if lBytes <= 2 then + result := GetByte(lPos)+(GetByte(lPos+1) shl 8) //shortint vs word? + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24);; //byte order?? +end; //function DCMint + +{$IFDEF ANON} +Type + TPosLen = RECORD //peristimulus plot + Pos,Len: integer; + end; +procedure InitPosLen(var lPL: TPOsLen); +begin + lPL.Pos := 0; + lPL.Len := 0; +end; +procedure SetPosLen(var lPL: TPosLen; lP,lL: integer); +begin + lPL.Pos := lP; + lPL.Len := lL; +end; + +procedure Anonymize(lStr: string; lPL: TPOsLen{lPos,lLen: integer}); +var + lDCMstr: string; + lP,lL: integer; +begin + if ((lPL.Pos+lPL.Len) > lBufferSz) or (lPL.Len < 1) or (lPL.Pos < 1) then + exit; + lDCMStr := ''; + lL := length(lStr); + if lL > lPL.Len then + lL := lPL.Len; + lP := 1; + while lP <= lL do begin + lDCMStr := lDCMStr + lStr[lP]; + inc(lP); + end; + while lP <= lPL.Len do begin //pad string + lDCMStr := lDCMStr + ' '; + inc(lP); + end; + for lP := 1 to lPL.Len do + lByteRA^[lPL.Pos+lP] := Ord(lDCMstr[lP]); + +end; + +(*procedure AnonymizeDate(lStr: string; lPos,lLen: integer); +var + lDCMstr: string; + lP,lL,lDateLen: integer; +begin + Anonymize(lStr, lPos,lLen); + //put 19730316 into date field -Lauterbur paper published in Nature + lDCMstr := '19730316'; + lDateLen := length(lDCMStr); + if ((lPos+lLen) > lBufferSz) or (lLen < lDateLen) or (lPos < 1) then + exit; + for lP := 1 to lDateLen do + lByteRA^[lPos+lP] := Ord(lDCMstr[lP]); + +end;*) + +{$ENDIF} + +var + lTempStr,lStr: string; + lTemp,lGroupElement,lLength,lEchoNum,lnVol: integer; + lResearchMode: boolean; + lThick: double; + {$IFDEF ANON} //position and lengths of tags to anonymize + lCreateDate,lName,lID,lDOB,lSex,lAge,lWt,lStudyDate,lSeriesDate,lAcqDate: TPosLen; + {$ENDIF} +begin //function fast_read_dicom_data + {$IFDEF ANON} //position and lengths of tags to anonymize + InitPosLen(lName); + InitPosLen(lID); + InitPosLen(lDOB); + InitPosLen(lSex); + InitPosLen(lAge); + InitPosLen(lWt); + InitPosLen(lStudyDate); + InitPosLen(lSeriesDate); + InitPosLen(lAcqDate); + InitPosLen(lCreateDate); + {$ENDIF} + lFailure := false; + lnVol := 1; + lEchoNum := 1; + lThick := 0; + clear_dicom_data(lDicomData); + lDicomData.little_endian := 1; + result := false; + lResearchMode := false; + lBufferError := false; + lFileSz := FSize(lFilename); + lBufferSz := lFileSz-lOffset; + if lBufferSz < 512 then begin + //showmessage('Error: File too small '+lFilename); + exit; + end; + if lBufferSz > kMaxBuf then + lBufferSz := kMaxBuf; + GetMem(lByteRA,kMaxBuf); + lBufferSz := lBufferSz; + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lOffset); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + FileMode := 2; + lBuffStart := lOffset; + lPos := lOffset; + if lOffset = 128 then begin //DICOM files start with DICM at 128, Siemens shadow headers do not + if DCMStr(4) <> 'DICM' then begin + dcmMsg(DCMStr(4)+ ' <> DICM'); + FreeMem(lByteRA); + exit; + end; + lPos := lOffset + 4;//DICM read + end;//Offset = 128 + //next check VR + if not( chr(GetByte(lPos+4)) in ['A'..'Z']) or not( chr(GetByte(lPos+5)) in ['A'..'Z']) then + dcmMsg('implicit VR untested'); + //next check Endian + lTemp := lPos; + ReadGroupElementLength(lGroupElement,lLength); + if lLength > kMax16bit then + dcmMsg('ByteSwapped'); + lPos := lTemp; + //end VR check + while (lDICOMData.imagestart = 0) and (not lBufferError) do begin + ReadGroupElementLength(lGroupElement,lLength); + if lFailure then goto 999; + case lGroupElement of + kTransferSyntax: begin + lTempStr := (DCMStr(lLength)); + if (length(lTempStr) >= 19) and (lTempStr[19] = '2') then + lDicomData.little_endian := 0; + end; + kImageType : begin + lTempStr := DCMStr(lLength); + //read last word - ver\mosaic -> MOSAIC + lStr := ''; + lTemp := length(lTempStr); + while (lTemp > 0) and (lTempStr[lTemp] in ['a'..'z','A'..'Z']) do begin + lStr := upcase(lTempStr[lTemp])+lStr; + dec(lTemp); + end; + if lStr = 'MOSAIC' then + lDicomData.SiemensMosaicX := 2; //we need to read numaris for details... + end; + + kStudyTime : lDicomData.StudyTime := DCMStr(lLength); + {$IFDEF ANON} //position and lengths of tags to anonymize + kCreateDate: begin SetPosLen(lCreateDate,lPos,lLength) end; + kSeriesDate: begin SetPosLen(lSeriesDate,lPos,lLength) end; + kAcqDate: begin SetPosLen(lAcqDate,lPos,lLength) end; + kStudyDate: begin SetPosLen(lStudyDate,lPos,lLength) end; + kPatientName : begin SetPosLen(lName,lPos,lLength) end; + kPatientID : begin SetPosLen(lID,lPos,lLength) end; + kPatientDOB : begin SetPosLen(lDOB,lPos,lLength) end; + kPatientSex : begin SetPosLen(lSex,lPos,lLength) end; + kPatientAge : begin SetPosLen(lAge,lPos,lLength) end; + kPatientWt : begin SetPosLen(lWt,lPos,lLength) end; + {$ELSE} + kPatientName : lDicomData.PatientName := DCMStr(lLength); + kStudyDate: lDicomData.StudyDate := DCMStr(lLength); + + {$ENDIF} + kProtocolName : lDicomData.ProtocolName :=DCMStr(lLength); + kPatientPos : lDicomData.PatientPos :=DCMStr(lLength); //should be HFS for Siemens = Head First Supine + kSeriesNum : lDicomData.SeriesNum := DCMStr2Int(lLength); + kAcquNum : lDicomData.AcquNum := DCMStr2Int(lLength); + kSeq: begin + if DCMStr(lLength) = 'RM' then + lResearchMode := True; + end; + kImageNum : lDicomData.ImageNum := DCMStr2Int(lLength); + kDim3 :lDicomData.XYZdim[3] := DCMStr2Int(lLength); + kDim2 : lDicomData.XYZdim[2] := DCMint (lLength); + kDim1 : lDicomData.XYZdim[1] := DCMint (lLength); + kLocation : lDICOMData.Location := DCMStr2Float(lLength); + kAlloc: lDicomData.Allocbits_per_pixel := DCMint (lLength); + kTR : lDicomData.TR := DCMStr2Float(lLength); + kTE: lDicomData.TE := DCMStr2Float(lLength); + kEchoNum: lEchoNum := round (DCMStr2Float(lLength)); + kSlope : lDICOMData.IntenScale := DCMStr2Float(lLength); + kIntercept : lDICOMData.IntenIntercept := DCMStr2Float(lLength); + kOrientation : DCMStr2Float6(lLength, lDicomData.Orient[1], lDicomData.Orient[2],lDicomData.Orient[3],lDicomData.Orient[4], lDicomData.Orient[5],lDicomData.Orient[6]); + kPosition : DCMStr2Float3 (lLength,lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ); + knVol: lnVol := round (DCMStr2Float(lLength)); + kZThick: begin lThick := DCMStr2Float(lLength); lDICOMData.XYZmm[3] := lThick; end;//used differently by manufacturers + kZSpacing: begin lDICOMData.XYZmm[3] := DCMStr2Float(lLength); + if (lThick/2) > lDICOMdata.XYZmm[3] then + lDICOMdata.XYZmm[3] := lDICOMdata.XYZmm[3] + lThick + end; //used different by different manufacturers + kXYSpacing: DCMStr2Float2 (lLength, lDICOMdata.XYZmm[2], lDICOMdata.XYZmm[1]); + kCSAImageHeaderInfo: begin //order ICE,Acq,Num,Vector + lDICOMdata.CSAImageHeaderInfoPos := lPos; + lDICOMdata.CSAImageHeaderInfoSz := lLength; + end; + kSlicesPer3DVol: lDICOMData.SlicesPer3DVol := DCMint (lLength); + kImageStart: lDICOMData.ImageStart := lPos ; //-1 as indexed from 0.. not 1.. + end; //Case lGroupElement + //Msg(VR+inttohex(lGroupElement and kMax16bit,4) +':'+inttohex( lGroupElement shr 16,4)+' '+inttostr(lLength)+'@'+inttostr(lPos) ); + lPos := lPos + (lLength); + end; //while imagestart=0 and not error + //clean up + lDicomData.DateTime := StudyDateTime(lDicomData.StudyDate,lDicomData.StudyTime); + if (lDicomData.SiemensMosaicX > 1) then + lDicomData.AcquNum := 1; + if (lEchoNum > 1) and (lEchoNum < 16) then + lDicomData.AcquNum := lDicomData.AcquNum + (100*lEchoNum); + if lResearchMode then + lDicomData.SeriesNum := lDicomData.SeriesNum + 100; + if (lDICOMData.SlicesPer3DVol > 0) and (lnVol > 1) and (lDicomdata.XYZdim[3] > 1) and (lDicomData.SlicesPer3DVol > 0)and ((lDicomdata.XYZdim[3] mod lDicomData.SlicesPer3DVol) = 0) then + lDICOMdata.File4D := true; + if not lBufferError then + result := true; + FreeMem(lByteRA); + //Remaining portions only if anonymizing + {$IFDEF ANON} + dcmMsg('Anonymizing DICOM '+extractfilename(lFilename)); + lBufferSz := lFileSz; + GetMem(lByteRA,lBufferSz); + //read original + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + //seek(lInFile,1); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + //anonymize... + Anonymize ('ANONYMIZED',lName); + Anonymize ('ANONYMIZED',lID); + Anonymize('19890323',lDOB); //Cold Fusion YYYYMMDD + Anonymize('19890323',lStudyDate); //Cold Fusion YYYYMMDD + Anonymize('19890323',lAcqDate); //Cold Fusion YYYYMMDD + Anonymize('19890323',lSeriesDate); //Cold Fusion YYYYMMDD + Anonymize('19890323',lCreateDate); //Cold Fusion YYYYMMDD + + Anonymize('M',lSex); + Anonymize('18',lAge); + Anonymize('100',lWt); + //write anonymized data... + assignfile(lInFile, lFileName+'.dcm'); + Filemode := 2; //read&write + Rewrite(lInFile,1); + BlockWrite(lInFile, lByteRA^[1],lBufferSz); + CloseFile(lInFile); + //clean up... + 999: + FreeMem(lByteRA); + {$ENDIF} +end; //function fast_read_dicom_data + + +end. \ No newline at end of file diff --git a/dcm2nii/dicomfast.ppu b/dcm2nii/dicomfast.ppu new file mode 100644 index 0000000..df5d03c Binary files /dev/null and b/dcm2nii/dicomfast.ppu differ diff --git a/dcm2nii/dicomfastread.o b/dcm2nii/dicomfastread.o new file mode 100644 index 0000000..6a90931 Binary files /dev/null and b/dcm2nii/dicomfastread.o differ diff --git a/dcm2nii/dicomfastread.pas b/dcm2nii/dicomfastread.pas new file mode 100755 index 0000000..f6d1ca4 --- /dev/null +++ b/dcm2nii/dicomfastread.pas @@ -0,0 +1,560 @@ +unit dicomfastread; +{$H+} +//this is x3 faster than the dicomcompat routines, but only works with well-behaved Explicit Little-Endian DICOM +interface +//0008,0070,ManufacturerID +//Next values for Philips +//Philips - must set 2001,105F length to 8 - allows reading of stack sequence +// 2005,1071. Philips AP angulation +// 2005,1072. Philips RL angulation +// 2005,1073. Philips FH angulation +//2001,100B Philips slice orientation (TRANSVERSAL, AXIAL, SAGITTAL) +// Next values for GE +//0019,10bb (or 0019,a0bb)= X diffusion direction +//0019,10bc (or 0019,a0bc)= Y diffusion direction +//0019,10bd (or 0019,a0bd)= Z diffusion direction +//0018,1312 = phase encoding. + +uses +{$IFNDEF FPC}Controls, {$ENDIF} + SysUtils,define_types,classes,dicomtypes; +function fast_read_dicom_datax(var lDICOMdata: DICOMdata; lOffset,lFileSz: integer; var lFileName: string): boolean; //x3 faster! +procedure read_philips_hidden(var lFilename: string; lOffset,lLength: integer; var lDICOMdata: DICOMdata); +function orientation_not_visible( lDICOMdata: DICOMdata) : boolean; + +implementation +uses dialogsx, dialogs_msg; +{$DEFINE notANON} + +function fast_read_dicom_datax(var lDICOMdata: DICOMdata; lOffset,lFileSz: integer; var lFileName: string): boolean; +const + kMaxBuf = (256*256)-1; //bytes + kMax16bit = (256*256)-1; + kImageType = $00080008; + kStudyDate = $00210008; + kSeriesDate = $00210008; + kAcqDate = $00220008; + kCreateDate = $00120008; + kStudyTime = $00300008; + kPatientName = $00100010; + {$IFDEF ANON} //position and lengths of tags to anonymize + kPatientID = $00200010; + kPatientDOB = $00300010; + kPatientSex = $00400010; + kPatientAge = $10100010; + kPatientWt = $10300010; + {$ENDIF} + kSeq = $00200018; + kZThick = $00500018; + kTR = $00800018; + kTE = $00810018; + kEchoNum = $00860018; + kZSpacing = $00880018; + kProtocolName = $10300018; + kPatientPos = $51000018; + kSeriesNum = $00110020; + kAcquNum = $00120020; + kImageNum = $00130020; + kOrientation = $00370020; + kLocation = $10410020; + kDim3 = $00080028; + kDim2 = $00100028; + kDim1 = $00110028; + kXYSpacing = $00300028; + kPosition = $00320020; + knVol = $01050020; + kAlloc = $01000028; + kIntercept = $10520028; + kSlope = $10530028; + kCSAImageHeaderInfo = $10100029; + kSlicesPer3DVol = $10182001; + kTransferSyntax = $00100002; + kImageStart = $00107FE0; + kPhilipsPhantom1 = $91130020;//$0020+($9113 shl 16 ); + kPhilipsPhantom2 = $91160020; + kPhilipsPhantom3 = $91100028; + kPhilipsDTIv1 = $10b02005; + kPhilipsDTIv2 = $10b12005; + kPhilipsDTIv3 = $10b22005; + + kMaxFloats = 6; +var + vr : array [1..2] of Char; + lByteRA: Bytep; + lFloatRA: array [1..kMaxFloats] of double; + lBufferSz,lPos,lBuffStart: integer; + lInFile: file; + lBufferError: boolean; +procedure Str2FloatNum ( lStr: string; lnFloats: integer); +var + lFStr: string; + lP,lnF: integer; +begin + if (length(lStr) < 1) or (lnFloats < 1) or (lnFloats > kMaxFloats) then + exit; + for lnF := 1 to lnFloats do + lFloatRA[lnF] := 1; + lStr := lStr + ' '; //terminator + lFStr := ''; + lP := 1; + lnF:= 0; + while lP <= length(lStr) do begin + if lStr[lP] in ['+','-','0'..'9','.','e','E'] then + lFStr := lFStr + lStr[lP] + else if (lFStr <> '') then begin + inc(lnF); + //if lnFloats = 6 then showmessage(lFStr); + try + lFloatRA[lnF] := strtofloat(lFStr); + except on EConvertError do + lFloatRA[lnF] := 1; + end;//except + if lnF = lnFloats then exit; + lFStr := ''; + end; + inc(lP); + end; +end; //function Str2Float + +function GetByte (lFilePos: integer): byte; +var + lBufPos: integer; +begin + //the following error checking slows down reads a lot! + //a simpler alternative would be to make the buffer size the same size as the entire image... + //the current strategy saves memory and is faster for large images with small headers + if lFilepos > lFileSz then begin + lBufferError := true; + result := 0; + exit; + end; + lBufPos := lFilepos - lBuffStart+1; + if (lBufPos > lBufferSz) or (lBufPos < 1) then begin //reload buffer + if lFilePos+kMaxBuf > lFileSz then + lBufferSz := lFileSz - (lFilePos) + else + lBufferSz := kMaxBuf; //read remaining + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lFilePos); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + FileMode := 2; + lBuffStart := lFilePos; + lBufPos := 1; + end; + result := lByteRA^[lBufPos]; +end; + +function ReadInt4: int64; +begin + if lDicomData.little_endian = 0 then + result := GetByte(lPos+3)+(GetByte(lPos+2) shl 8)+(GetByte(lPos+1) shl 16)+(GetByte(lPos) shl 24) + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24); + inc(lPos,4); +end; //function Read4 + +function ReadCardinal: int64; +begin + if lDicomData.little_endian = 0 then + result := GetByte(lPos+3)+(GetByte(lPos+2) shl 8)+(GetByte(lPos+1) shl 16)+(GetByte(lPos) shl 24) + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24); + inc(lPos,4); +end; //function Read4 + +procedure ReadGroupElementLength(var lGroupElement: int64; var lLength: integer); +begin + lGroupElement := ReadCardinal; + VR := 'AA'; + vr[1] := chr(GetByte(lPos)); + vr[2] := chr(GetByte(lPos+1)); + if vr[2] < 'A' then begin //implicit vr with 32-bit length + lLength := ReadInt4; + exit; + end; + if (vr = 'OB') or (vr = 'OW') or (vr = 'SQ') then begin {explicit VR with 32-bit length} + lPos := lPos + 4; {skip 2 byte string and 2 reserved bytes = 4 bytes = 2 words} + lLength := ReadInt4;//Ord4(buf[lPos]) + $100 * (buf[lPos+1] + $100 * (buf[lPos+2] + $100 * buf[lPos+3])) + end else begin {explicit VR with 16-bit length} + if lDicomData.little_endian = 0 then + lLength := (GetByte(lPos+3))+(GetByte(lPos+2) shl 8) + else + lLength := (GetByte(lPos+2))+(GetByte(lPos+3) shl 8);//GetLength := Ord4(buf[i+2]) + $100 * (buf[i+3]); + lPos := lPos + 4; {skip 2 byte string and 2 length bytes = 4 bytes = 2 words} + end; + if (lGroupElement = kPhilipsPhantom1) or (lGroupElement = kPhilipsPhantom2) or (lGroupElement = kPhilipsPhantom3) then begin + //crucial Philips values are nested inside this string... + //fx(666); + //kX := true; + lLength := 8; + end; +end; //procedure ReadGroupElementLength + +function DCMStr(lBytes: integer): string; +var + lC: integer; +begin + result := ''; + if lBytes < 1 then + exit; + for lC := lPos to (lPos+(lBytes-1)) do + result := result + char(GetByte(lC)); + for lC := 1 to lBytes do + if result[lC] in ['+','-','/','\',' ','0'..'9','a'..'z','A'..'Z','.'] then + else + result[lC] := ' '; +end; //function DCMStr + +function DCMStr2Int (lBytes: integer): integer; +var lErr: integer; + lStr: string; +begin + lStr := DCMStr(lBytes); + Val(lStr,result,lErr); +end; //function DCMStr2Int + +procedure DCMStr2FloatNum (lBytes,lnFloats: integer); +begin + Str2FloatNum (DCMStr(lBytes), lnFloats); +end; //function DCMStr2Float + +function DCMStr2Float (lBytes: integer): single; +begin + DCMStr2FloatNum (lBytes,1); + result := lFloatRA[1]; +end; //function DCMStr2Float + +procedure DCMStr2Float2 (lBytes: integer; var lF1,lF2: double); +begin + DCMStr2FloatNum (lBytes,3); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; +end; //function DCMStr2Float2 + +procedure DCMStr2Float3 (lBytes: integer; var lF1,lF2,lF3: double); +begin + DCMStr2FloatNum (lBytes,3); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; + lF3 := lFloatRA[3]; +end; //function DCMStr2Float3 + +procedure DCMStr2Float6 (lBytes: integer; var lF1,lF2,lF3,lF4,lF5,lF6: double); +begin + DCMStr2FloatNum (lBytes,6); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; + lF3 := lFloatRA[3]; + lF4 := lFloatRA[4]; + lF5 := lFloatRA[5]; + lF6 := lFloatRA[6]; +end; //function DCMStr2Float6 + +function DCMint (lBytes: integer): integer; //read 16 bit short integer +begin + if lBytes <= 2 then + result := GetByte(lPos)+(GetByte(lPos+1) shl 8) //shortint vs word? + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24);; //byte order?? +end; //function DCMint + +function DCMsingle (lBytes: integer): single; //read 16 bit short integer +type + swaptype = packed record + case byte of + 0:(b0,b1,b2,b3 : word); //word is 16 bit + 1:(float:single); + end; +var + outguy:swaptype; +begin + outguy.b0 := GetByte(lPos); + outguy.b1 := GetByte(lPos+1); + outguy.b2 := GetByte(lPos+2); + outguy.b3 := GetByte(lPos+3); + result:=outguy.float; +end; + +{$IFDEF ANON} +Type + TPosLen = RECORD //peristimulus plot + Pos,Len: integer; + end; +procedure InitPosLen(var lPL: TPOsLen); +begin + lPL.Pos := 0; + lPL.Len := 0; +end; +procedure SetPosLen(var lPL: TPosLen; lP,lL: integer); +begin + lPL.Pos := lP; + lPL.Len := lL; +end; + +procedure Anonymize(lStr: string; lPL: TPOsLen{lPos,lLen: integer}); +var + lDCMstr: string; + lP,lL: integer; +begin + if ((lPL.Pos+lPL.Len) > lBufferSz) or (lPL.Len < 1) or (lPL.Pos < 1) then + exit; + lDCMStr := ''; + lL := length(lStr); + if lL > lPL.Len then + lL := lPL.Len; + lP := 1; + while lP <= lL do begin + lDCMStr := lDCMStr + lStr[lP]; + inc(lP); + end; + while lP <= lPL.Len do begin //pad string + lDCMStr := lDCMStr + ' '; + inc(lP); + end; + for lP := 1 to lPL.Len do + lByteRA^[lPL.Pos+lP] := Ord(lDCMstr[lP]); + +end; + +{$ENDIF} + +var + lTempStr,lStr: string; + lGroupElement: int64; + lTemp,lLength,lEchoNum,lnVol: integer; + lResearchMode: boolean; + lThick: double; + {$IFDEF ANON} //position and lengths of tags to anonymize + lCreateDate,lName,lID,lDOB,lSex,lAge,lWt,lStudyDate,lSeriesDate,lAcqDate: TPosLen; + {$ENDIF} +begin //function fast_read_dicom_data + {$IFDEF ANON} //position and lengths of tags to anonymize + InitPosLen(lName); + InitPosLen(lID); + InitPosLen(lDOB); + InitPosLen(lSex); + InitPosLen(lAge); + InitPosLen(lWt); + InitPosLen(lStudyDate); + InitPosLen(lSeriesDate); + InitPosLen(lAcqDate); + InitPosLen(lCreateDate); + {$ENDIF} + lnVol := 1; + lEchoNum := 1; + lThick := 0; + clear_dicom_data(lDicomData); + lDicomData.little_endian := 1; + result := false; + lResearchMode := false; + lBufferError := false; + if lFileSz < 1 then + lFileSz := FSize(lFilename); + lBufferSz := lFileSz-lOffset; + if lBufferSz < 512 then begin + //showmessage('Error: File too small '+lFilename); + exit; + end; + if lBufferSz > kMaxBuf then + lBufferSz := kMaxBuf; + GetMem(lByteRA,kMaxBuf); + lBufferSz := lBufferSz; + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lOffset); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + FileMode := 2; + lBuffStart := lOffset; + lPos := lOffset; + if lOffset = 128 then begin //DICOM files start with DICM at 128, Siemens shadow headers do not + if DCMStr(4) <> 'DICM' then begin + dcmMsg(DCMStr(4)+ ' <> DICM'); + FreeMem(lByteRA); + exit; + end; + lPos := lOffset + 4;//DICM read + end;//Offset = 128 + //next check VR + if not( chr(GetByte(lPos+4)) in ['A'..'Z']) or not( chr(GetByte(lPos+5)) in ['A'..'Z']) then + dcmMsg('implicit VR untested'); + //next check Endian + lTemp := lPos; + ReadGroupElementLength(lGroupElement,lLength); + if lLength > kMax16bit then + dcmMsg('ByteSwapped'); + lPos := lTemp; + //end VR check + result := true; + while (lDICOMData.imagestart = 0) and (not lBufferError) do begin + ReadGroupElementLength(lGroupElement,lLength); + case lGroupElement of + kTransferSyntax: begin + lTempStr := (DCMStr(lLength)); + if (length(lTempStr) >= 19) and (lTempStr[19] = '2') then + lDicomData.little_endian := 0; + end; + kImageType : begin + lTempStr := DCMStr(lLength); + //read last word - ver\mosaic -> MOSAIC + lStr := ''; + lTemp := length(lTempStr); + while (lTemp > 0) and (lTempStr[lTemp] in ['a'..'z','A'..'Z']) do begin + lStr := upcase(lTempStr[lTemp])+lStr; + dec(lTemp); + end; + if lStr = 'MOSAIC' then + lDicomData.SiemensMosaicX := 2; //we need to read numaris for details... + end; + + kStudyTime : lDicomData.StudyTime := DCMStr(lLength); + {$IFDEF ANON} //position and lengths of tags to anonymize + kCreateDate: begin SetPosLen(lCreateDate,lPos,lLength) end; + kSeriesDate: begin SetPosLen(lSeriesDate,lPos,lLength) end; + kAcqDate: begin SetPosLen(lAcqDate,lPos,lLength) end; + kStudyDate: begin SetPosLen(lStudyDate,lPos,lLength) end; + kPatientName : begin SetPosLen(lName,lPos,lLength) end; + kPatientID : begin SetPosLen(lID,lPos,lLength) end; + kPatientDOB : begin SetPosLen(lDOB,lPos,lLength) end; + kPatientSex : begin SetPosLen(lSex,lPos,lLength) end; + kPatientAge : begin SetPosLen(lAge,lPos,lLength) end; + kPatientWt : begin SetPosLen(lWt,lPos,lLength) end; + {$ELSE} + kPatientName : lDicomData.PatientName := DCMStr(lLength); + kStudyDate: lDicomData.StudyDate := DCMStr(lLength); + + {$ENDIF} + kProtocolName : lDicomData.ProtocolName :=DCMStr(lLength); + kPatientPos : lDicomData.PatientPos :=DCMStr(lLength); //should be HFS for Siemens = Head First Supine + kSeriesNum : lDicomData.SeriesNum := DCMStr2Int(lLength); + kAcquNum : lDicomData.AcquNum := DCMStr2Int(lLength); + kSeq: begin + if DCMStr(lLength) = 'RM' then + lResearchMode := True; + end; + kImageNum : lDicomData.ImageNum := DCMStr2Int(lLength); + kDim3 :lDicomData.XYZdim[3] := DCMStr2Int(lLength); + kDim2 : lDicomData.XYZdim[2] := DCMint (lLength); + + kDim1 : lDicomData.XYZdim[1] := DCMint (lLength); + kLocation : lDICOMData.Location := DCMStr2Float(lLength); + kAlloc: lDicomData.Allocbits_per_pixel := DCMint (lLength); + kTR : lDicomData.TR := DCMStr2Float(lLength); + kTE: lDicomData.TE := DCMStr2Float(lLength); + kEchoNum: lEchoNum := round (DCMStr2Float(lLength)); + kSlope : lDICOMData.IntenScale := DCMStr2Float(lLength); + kIntercept : lDICOMData.IntenIntercept := DCMStr2Float(lLength); + kOrientation : DCMStr2Float6(lLength, lDicomData.Orient[1], lDicomData.Orient[2],lDicomData.Orient[3],lDicomData.Orient[4], lDicomData.Orient[5],lDicomData.Orient[6]); + kPosition : DCMStr2Float3 (lLength,lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ); + knVol: lnVol := round (DCMStr2Float(lLength)); + kZThick: begin lThick := DCMStr2Float(lLength); lDICOMData.XYZmm[3] := lThick; end;//used differently by manufacturers + kZSpacing: begin lDICOMData.XYZmm[3] := DCMStr2Float(lLength); + if (lThick/2) > lDICOMdata.XYZmm[3] then + lDICOMdata.XYZmm[3] := lDICOMdata.XYZmm[3] + lThick + end; //used different by different manufacturers + kXYSpacing: begin + DCMStr2Float2 (lLength, lDICOMdata.XYZmm[2], lDICOMdata.XYZmm[1]); + end; + kCSAImageHeaderInfo: begin //order ICE,Acq,Num,Vector + lDICOMdata.CSAImageHeaderInfoPos := lPos; + lDICOMdata.CSAImageHeaderInfoSz := lLength; + end; + kSlicesPer3DVol: lDICOMData.SlicesPer3DVol := DCMint (lLength); + + kImageStart: lDICOMData.ImageStart := lPos ; //-1 as indexed from 0.. not 1.. + end; //Case lGroupElement + //Msg(VR+inttohex(lGroupElement and kMax16bit,4) +':'+inttohex( lGroupElement shr 16,4)+' '+inttostr(lLength)+'@'+inttostr(lPos) ); + //msg(inttostr(lPos)+' '+inttostr(lLength)); + lPos := lPos + (lLength); + end; //while imagestart=0 and not error + + //clean up + lDicomData.DateTime := StudyDateTime(lDicomData.StudyDate,lDicomData.StudyTime); + if (lDicomData.SiemensMosaicX > 1) then + lDicomData.AcquNum := 1; + if (lEchoNum > 1) and (lEchoNum < 16) then + lDicomData.AcquNum := lDicomData.AcquNum + (100*lEchoNum); + if lResearchMode then + lDicomData.SeriesNum := lDicomData.SeriesNum + 100; + if (lDICOMData.SlicesPer3DVol > 0) and (lnVol > 1) and (lDicomdata.XYZdim[3] > 1) and (lDicomData.SlicesPer3DVol > 0)and ((lDicomdata.XYZdim[3] mod lDicomData.SlicesPer3DVol) = 0) then + lDICOMdata.File4D := true; + if not lBufferError then + result := true; + FreeMem(lByteRA); + //Remaining portions only if anonymizing + {$IFDEF ANON} + Msg('Anonymizing DICOM '+extractfilename(lFilename)); + lBufferSz := lFileSz; + GetMem(lByteRA,lBufferSz); + //read original + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + //seek(lInFile,1); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + //anonymize... + Anonymize ('ANONYMIZED',lName); + Anonymize ('ANONYMIZED',lID); + Anonymize('19890323',lDOB); //Cold Fusion YYYYMMDD + Anonymize('19890323',lStudyDate); //Cold Fusion YYYYMMDD + Anonymize('19890323',lAcqDate); //Cold Fusion YYYYMMDD + Anonymize('19890323',lSeriesDate); //Cold Fusion YYYYMMDD + Anonymize('19890323',lCreateDate); //Cold Fusion YYYYMMDD + + Anonymize('M',lSex); + Anonymize('18',lAge); + Anonymize('100',lWt); + //write anonymized data... + assignfile(lInFile, lFileName+'.dcm'); + Filemode := 2; //read&write + Rewrite(lInFile,1); + BlockWrite(lInFile, lByteRA^[1],lBufferSz); + CloseFile(lInFile); + //clean up... + FreeMem(lByteRA); + {$ENDIF} +end; //function fast_read_dicom_data + +function orientation_not_visible( lDICOMdata: DICOMdata) : boolean; +var + li : integer; + lDICOMdataX: DICOMdata; +begin + result := false; + clear_dicom_data(lDicomDataX); + for li := 1 to 2 do //only XY-direction - as philips reports correct Z in header + if lDICOMdata.XYZmm[li] <> lDICOMdataX.XYZmm[li] then + exit; + for li := 1 to 6 do + if lDicomData.Orient[li] <> lDicomDataX.Orient[li] then + exit; + if lDicomData.PatientPosX <> lDicomDataX.PatientPosX then exit; + if lDicomData.PatientPosY <> lDicomDataX.PatientPosY then exit; + if lDicomData.PatientPosZ <> lDicomDataX.PatientPosZ then exit; + result := true; +end; + + +procedure read_philips_hidden(var lFilename: string; lOffset,lLength: integer; var lDICOMdata: DICOMdata); +var + li : integer; + lDICOMdataX: DICOMdata; +begin + if not fast_read_dicom_datax(lDICOMdataX, lOffset+8, lOffset+lLength, lFileName) then exit; + //fx(lDICOMdataX.XYZmm[1],lDICOMdataX.XYZmm[2]); + for li := 1 to 2 do //only XY-direction - as philips reports correct Z in header + lDICOMdata.XYZmm[li] := lDICOMdataX.XYZmm[li]; + for li := 1 to 6 do + lDicomData.Orient[li] := lDicomDataX.Orient[li]; + lDicomData.PatientPosX := lDicomDataX.PatientPosX; + lDicomData.PatientPosY := lDicomDataX.PatientPosY; + lDicomData.PatientPosZ := lDicomDataX.PatientPosZ; +end; + + +end. \ No newline at end of file diff --git a/dcm2nii/dicomfastread.ppu b/dcm2nii/dicomfastread.ppu new file mode 100644 index 0000000..9c1e186 Binary files /dev/null and b/dcm2nii/dicomfastread.ppu differ diff --git a/dcm2nii/dicomtypes.o b/dcm2nii/dicomtypes.o new file mode 100644 index 0000000..6a61665 Binary files /dev/null and b/dcm2nii/dicomtypes.o differ diff --git a/dcm2nii/dicomtypes.pas b/dcm2nii/dicomtypes.pas new file mode 100755 index 0000000..41dcefc --- /dev/null +++ b/dcm2nii/dicomtypes.pas @@ -0,0 +1,787 @@ +unit dicomtypes; + +{$IFDEF FPC} +{$mode objfpc} +{$ENDIF} +{$H+} +{$Include ..\common\isgui.inc} + +interface +var kUseDateTimeForID: boolean = false; +const + kGEID = 1; + kPhilipsID = 2; + kSiemensID = 3; + kMaxDTIDir = 4096;//Maximum DTI directions + kMaxOrderVal = 1024; +type +TDTI = record + v1,v2,v3: double; //4=volume, eg time: some EC*T7 images + bval: integer +end; + TDTIRA = array [1..kMaxDTIDir] of TDTI;//TDICOM;//unsigned 8-bit int + TOrder= array [1..kMaxOrderVal] of byte; + kDICOMStr = String[128]; + DICOMdata = record + XYZdim: array [1..4] of integer; + XYZori: array [1..3] of integer; + XYZmm: array [1..3] of double; + Orient: array [1..6] of double; + SignedData,SiemensDICOMDTICSA,SiemensDICOMDTI,FloatData,file4D,JPEGLossyCpt,JPEGLosslessCpt: boolean; + SecSinceMidnight,PatientPosX,PatientPosY,PatientPosZ,AngulationAP,AngulationFH,AngulationRL: double; + FieldStrength, BandwidthPerPixelPhaseEncode, kV,TE, TR,IntenScale,IntenIntercept,location{,DTIv1,DTIv2,DTIv3}: single; + {Bval,}SlicesPer3DVol,SiemensInterleaved {0=no,1=yes,2=not defined},SiemensSlices,SiemensMosaicX,SiemensMosaicY, + nOrder,nDTIdir,AcquNum,ImageNum,SeriesNum,ImageStart,little_endian,Allocbits_per_pixel,SamplesPerPixel, + CSAImageHeaderInfoPos,CSAImageHeaderInfoSz, + CSASeriesHeaderInfoPos,CSASeriesHeaderInfoSz,ManufacturerID,PlanarConfig, //ImplementationVersion, + Vers0018_1020, + CompressOffset,CompresssZ: integer; + DateTime: TDateTime; + PatientHx, ImageComments,PatientGender,PatientDoB,PatientPos,PatientName,ProtocolName,StudyDate,StudyTime,PhilipsSliceOrient,ScanningSequence0018_0020 ,PhaseEncoding: kDICOMStr; + Filename: string[255]; + DTI: TDTI;//TDTIRA; + Order: TOrder; //4D datasets + //OrderSlope,OrderIntercept: TOrderScaling; //4D datasets + end;//DICOMdata record + + TDICOMRA = array [1..1] of DicomData;//TDICOM;//unsigned 8-bit int + TDICOMRAp = ^TDICOMRA; +(* TNIFTIhdr = packed record //Next: analyze Format Header structure + HdrSz : longint; //MUST BE 348 + Data_Type: array [1..10] of char; //unused + db_name: array [1..18] of char; //unused + extents: longint; //unused + session_error: smallint; //unused + regular: char; ////unused: in Analyze 7.5 this must be 114 + dim_info: byte; //MRI slice order + dim: array[0..7] of smallint; //Data array dimensions + intent_p1, intent_p2, intent_p3: single; + intent_code: smallint; + datatype: smallint; + bitpix: smallint; + slice_start: smallint; + pixdim: array[0..7]of single; + vox_offset: single; + scl_slope: single;//scaling slope + scl_inter: single;//scaling intercept + slice_end: smallint; + slice_code: byte; //e.g. ascending + xyzt_units: byte; //e.g. mm and sec + cal_max,cal_min: single; //unused + slice_duration: single; //time for one slice + toffset: single; //time axis to shift + glmax, glmin: longint; //UNUSED + descrip: array[1..80] of char; + aux_file: array[1..24] of char; + qform_code, sform_code: smallint; + quatern_b,quatern_c,quatern_d, + qoffset_x,qoffset_y,qoffset_z: single; + srow_x: array[0..3]of single; + srow_y: array[0..3]of single; + srow_z: array[0..3]of single; + intent_name: array[1..16] of char; + magic: longint; + end; //TNIFTIhdr Header Structure + + + const //nifti +kDT_BINARY =1; // binary (1 bit/voxel) +kDT_UNSIGNED_CHAR =2; // unsigned char (8 bits/voxel) +kDT_SIGNED_SHORT =4; // signed short (16 bits/voxel) +kDT_SIGNED_INT =8; // signed int (32 bits/voxel) +kDT_FLOAT =16; // float (32 bits/voxel) +kDT_COMPLEX =32; // complex (64 bits/voxel) +kDT_DOUBLE =64; // double (64 bits/voxel) +kDT_RGB =128; // RGB triple (24 bits/voxel) +kDT_INT8 =256; // signed char (8 bits) +kDT_UINT16 =512; // unsigned short (16 bits) +kDT_UINT32 =768; // unsigned int (32 bits) +kDT_INT64 =1024; // long long (64 bits) +kDT_UINT64 =1280; // unsigned long long (64 bits) +kDT_FLOAT128 =1536; // long double (128 bits) +kDT_COMPLEX128 =1792; // double pair (128 bits) +kDT_COMPLEX256 =2048; // long double pair (256 bits) +// slice_code values + kNIFTI_SLICE_SEQ_UNKNOWN = 0; + kNIFTI_SLICE_SEQ_INC = 1; + kNIFTI_SLICE_SEQ_DEC = 2; + kNIFTI_SLICE_ALT_INC = 3; + kNIFTI_SLICE_ALT_DEC = 4; +//xyzt_units values: note 3bit space and 3bit time packed into single byte + kNIFTI_UNITS_UNKNOWN = 0; + kNIFTI_UNITS_METER = 1; + kNIFTI_UNITS_MM = 2; + kNIFTI_UNITS_MICRON = 3; + kNIFTI_UNITS_SEC = 8; + kNIFTI_UNITS_MSEC = 16; + kNIFTI_UNITS_USEC = 24; + kNIFTI_UNITS_HZ = 32; + kNIFTI_UNITS_PPM = 40; + //qform_code, sform_code values + kNIFTI_XFORM_UNKNOWN = 0; + kNIFTI_XFORM_SCANNER_ANAT = 1;//Scanner-based anatomical coordinates + kNIFTI_XFORM_ALIGNED_ANAT = 2; //Coordinates aligned to another file e.g. EPI coregistered to T1 + kNIFTI_XFORM_TALAIRACH = 3; //Talairach-Tournoux Atlas; (0,0,0)=AC, etc. + kNIFTI_XFORM_MNI_152 = 4; //MNI 152 normalized coordinates + //Magic values + kNIFTI_MAGIC_SEPARATE_HDR = $0031696E;//$6E693100; + kNIFTI_MAGIC_EMBEDDED_HDR = $00312B6E;//$6E2B3100; + //byte-swapped magic values + kswapNIFTI_MAGIC_SEPARATE_HDR = $6E693100; + kswapNIFTI_MAGIC_EMBEDDED_HDR = $6E2B3100; + //Statistics Intention + kNIFTI_INTENT_NONE =0; +kNIFTI_INTENT_CORREL =2; +kNIFTI_INTENT_TTEST =3; +kNIFTI_INTENT_FTEST =4; +kNIFTI_INTENT_ZSCORE =5; +kNIFTI_INTENT_CHISQ =6; +kNIFTI_INTENT_BETA =7; +kNIFTI_INTENT_BINOM =8; +kNIFTI_INTENT_GAMMA =9; +kNIFTI_INTENT_POISSON =10; +kNIFTI_INTENT_NORMAL =11; +kNIFTI_INTENT_FTEST_NONC =12; +kNIFTI_INTENT_CHISQ_NONC =13; +kNIFTI_INTENT_LOGISTIC =14; +kNIFTI_INTENT_LAPLACE =15; +kNIFTI_INTENT_UNIFORM =16; +kNIFTI_INTENT_TTEST_NONC =17; +kNIFTI_INTENT_WEIBULL =18; +kNIFTI_INTENT_CHI =19; +kNIFTI_INTENT_INVGAUSS =20; +kNIFTI_INTENT_EXTVAL =21; +kNIFTI_INTENT_PVAL =22; +NIFTI_INTENT_LOGPVAL =23; +NIFTI_INTENT_LOG10PVAL =24; +kNIFTI_LAST_STATCODE = 24;//kNIFTI_INTENT_PVAL; +kNIFTI_INTENT_ESTIMATE =1001; +kNIFTI_FIRST_NONSTATCODE = kNIFTI_INTENT_ESTIMATE; +kNIFTI_INTENT_LABEL =1002; +kNIFTI_INTENT_NEURONAME =1003; +kNIFTI_INTENT_GENMATRIX =1004; +kNIFTI_INTENT_SYMMATRIX =1005; +kNIFTI_INTENT_DISPVECT =1006; +kNIFTI_INTENT_VECTOR =1007; +kNIFTI_INTENT_POINTSET =1008; +kNIFTI_INTENT_TRIANGLE =1009; +kNIFTI_INTENT_QUATERNION =1010; + *) +const //dicom +kCR = chr (13);//PC EOLN +kA = ord('A'); +kB = ord('B'); +kC = ord('C'); +kD = ord('D'); +kE = ord('E'); +kF = ord('F'); +kH = ord('H'); +kI = ord('I'); +kL = ord('L'); +kM = ord('M'); +kN = ord('N'); +kO = ord('O'); +kP = ord('P'); +kQ = ord('Q'); +kS = ord('S'); +kT = ord('T'); +kU = ord('U'); +kW = ord('W'); + +procedure PhilipsPrecise (lRS, lRI,lSS: single; var lSlope,lIntercept: single; Precise: boolean); +procedure clear_dicom_data (var lDicomdata:Dicomdata); +procedure Clear_DTIra(var lDTIra: TDTIra); +function DICOMinterslicedistance(var lDicomdata1,lDicomdata2:Dicomdata): single;//1392 +function StudyDateTime (lInStudyDate, lInStudyTime: kDICOMStr): TDateTime; +function StudyDateTime2Str (lDateTime: TDateTime):string; +//function GetCSAImageHeaderInfoDTI (lFilename: string; lStart,lLength: integer; var lBval: integer; var ldti1,ldti2,ldti3: double): boolean; +//function GetCSAImageHeaderInfo (lFilename: string; lStart,lLength: integer; var lMosaicSlices,lMosaicX,lMosaicY: integer; var lv1,lv2,lv3: double): boolean; +procedure AplhaNumericStrDICOM (var lStr: kDICOMStr); +procedure PartialAcquisitionError; +function DICOMstr (i: integer; var lDICOMra: TDICOMrap;lOutname:string): string; overload; +function DICOMstr (i: integer; var lDICOMra: TDICOMrap): string; overload; +function DICOMstr (var lDICOM: DICOMdata): string; overload; + + +implementation + +uses dicom,sysutils,define_types,dialogsx,dialogs_msg; + +function YearsOld (lDICOM: DICOMdata): single; +var + dob: TDateTime; + lnoon:string; +begin + result := 0; + if length (lDICOM.PatientDoB) < 8 then + exit; //YYYYMMDD + try + lnoon := '120000'; + dob := StudyDateTime (lDICOM.PatientDoB, lnoon); + result := (lDICOM.DateTime-dob)/365.2425; + except + result := 0; + end; +end; + +function DICOMstr (var lDICOM: DICOMdata): string; overload; +begin + + result := lDICOM.Filename + //ProtocolName,StudyDate,StudyTime,PhilipsSliceOrient,PhaseEncoding: kDICOMStr; + +kTab+'Field Strength:'+kTab+floattostr(lDICOM.fieldStrength) + +kTab+'ProtocolName:'+kTab+ lDICOM.ProtocolName + +kTab+'ScanningSequence00180020:'+kTab+ lDICOM.ScanningSequence0018_0020 + +kTab+'TE:'+kTab+floattostr(lDICOM.TE) + +kTab+'TR:'+kTab+floattostr(lDICOM.TR) + + +kTab+'SeriesNum:'+kTab+inttostr(lDICOM.SeriesNum) + +kTab+'AcquNum:'+kTab+inttostr(lDICOM.AcquNum) + +kTab+'ImageNum:'+kTab+inttostr(lDICOM.ImageNum) + +kTab+'ImageComments:'+kTab+lDICOM.ImageComments + + +kTab+'DateTime:'+kTab+DateTimeToStr(lDICOM.DateTime) + +kTab+'Name:'+kTab+lDICOM.PatientName + +kTab+'PatientHistory:'+kTab+lDICOM.PatientHx + +kTab+'DoB:'+kTab+lDICOM.PatientDoB + +kTab+'Gender:'+kTab+lDICOM.PatientGender + + +kTab+'Age(Years):'+kTab+floattostr(YearsOld(lDICOM)) ; + +end; + +function DICOMstr (i: integer; var lDICOMra: TDICOMrap;lOutname: string): string; overload; +var + lS: string; +begin + result := DICOMstr (lDICOMra^[i]); + if lOutname <> '' then + result := kTab+'SuggestedOutput:'+lOutname; +end; + +(*function DICOMstr (i: integer; var lDICOMra: TDICOMrap;lOutname: string): string; overload; +var + lS: string; +begin + if lOutname <> '' then + lS := kTab+'SuggestedOutput:'+lOutname + else + lS := ''; + + result := lDICOMra^[i].Filename + +kTab+'ImageComments:'+lDICOMra^[i].ImageComments + +kTab+'PatientHistory:'+lDICOMra^[i].PatientHx + + +kTab+'SeriesNum:'+kTab+inttostr(lDICOMra^[i].SeriesNum) + +kTab+'AcquNum:'+inttostr(lDICOMra^[i].AcquNum) + +kTab+'ImageNum:'+inttostr(lDICOMra^[i].ImageNum) + +kTab+'Name:'+lDICOMra^[i].PatientName + +kTab+'DoB:'+lDICOMra^[i].PatientDoB + +kTab+'Gender:'+lDICOMra^[i].PatientGender + +kTab+'DateTime:'+DateTimeToStr(lDICOMra^[i].DateTime) + +kTab+'Age(Years):'+floattostr(YearsOld(lDICOMra^[i])) + + +lS ; + +end; *) + +function DICOMstr (i: integer; var lDICOMra: TDICOMrap): string; overload; +begin + result := DICOMstr (i, lDICOMra,'') +end; + +procedure PartialAcquisitionError; +begin + dcmMsg('* Potential partial acquisition or improper segmentation of files'); + {$IFDEF GUI} + dcmMsg('* Possible solution: check ''Collapse folders'' in Help/Preferences and select directory that contains all images in subfolders'); + {$ELSE} + dcmMsg('* Possible solution: use -c Y and use folder containing subdirectories as input'); + dcmMsg('* or change .ini file to read: CollapseFolders=1'); + {$ENDIF} +end; + +function PhilipsPreciseVal (lPV, lRS, lRI,lSS: single): single; +begin + if (lRS*lSS) = 0 then //avoid divide by zero + result := 0 + else + result := (lPV * lRS + lRI) / (lRS * lSS); +end; + +procedure PhilipsPrecise (lRS, lRI,lSS: single; var lSlope,lIntercept: single; Precise: boolean); +var + l0,l1: single; +begin +//# === PIXEL VALUES ============================================================= +//# PV = pixel value in REC file, FP = floating point value, DV = displayed value on console +//# RS = rescale slope, RI = rescale intercept, SS = scale slope +//# DV = PV * RS + RI FP = DV / (RS * SS) + if not Precise then begin //return DV not FP + lSlope := lRS; + if lSlope = 0 then + lSlope := 1; + lIntercept := lRI; + exit; + end; //if return DV + l0 := PhilipsPreciseVal (0, lRS, lRI,lSS); + l1 := PhilipsPreciseVal (1, lRS, lRI,lSS); + if l0 = l1 then begin + lSlope := 1; + lIntercept := 0; + exit; + end; + lIntercept := l0; + lSlope := l1-l0; + +end; + + +function SecSinceMidnight(H,Min,S: integer): integer; +//86,400 sec per day +begin + // + result := 3600*(H) + 60* Min + S;//H not H-1 as our clock runs from 0..23 not 1..24 +end; + +function BogusDateTime: TDateTime; +begin + result := EncodeDate(1989,3,23) + (SecSinceMidnight(12,0,0) / 86400); +end; + +function EncodeDateTime (Y,M,D,H,Min,S: integer): TDateTime; +begin + + try + result := EncodeDate(Y,M,D) + (SecSinceMidnight(H,Min,S) / 86400); + except //impossible date - set to cold fusion date + result := BogusDateTime; + end; +end; + +procedure DecodeDateTime (lDateTime: TDateTime; var Y,M,D,H,Min,S: word); +var + secs: integer; +begin + try + DecodeDate(lDateTime, Y, M, D); + except //unable to decode date - use cold fusion values + Y := 1989; + M := 3; + D := 23; + end; + Secs := round(Frac(lDateTime)*86400); + S := secs mod 60; + Min := (secs div 60) mod 60; + H := (secs div 3600); +end; + +function StudyDateTime2Str (lDateTime: TDateTime):string; +var + Y,M,D,H,Min,S: word; +begin + DecodeDateTime (lDateTime,Y,M,D,H,Min,S); + result := PadStr (Y, 4)+ PadStr (M, 2)+PadStr (D, 2)+'_'+PadStr (H, 2)+ PadStr (Min, 2)+PadStr (S, 2); +end; + +function StudyDateTime (lInStudyDate, lInStudyTime: kDICOMStr): TDateTime; +var lStr,lStudyDate, lStudyTime: string; + Y,M,D,H,Min,S: integer; +begin + result := 0; + if (length(lInStudyDate) < 8){YYYYMMDD} or (length(lInStudyTime) < 6) {hhmmss} then + exit; + //next compress string, e.g. Elscint saves time as 16:54:21 + lStudyDate :=''; + for S := 1 to length (lInStudyDate) do + if lInStudyDate[S] in ['0'..'9'] then + lStudyDate := lStudyDate + lInStudyDate[S]; + lStudyTime :=''; + for S := 1 to length (lInStudyTime) do + if lInStudyTime[S] in ['0'..'9'] then + lStudyTime := lStudyTime + lInStudyTime[S]; + + if (length(lStudyDate) < 8){YYYYMMDD} or (length(lStudyTime) < 6) {hhmmss} then + exit; + lStr := lStudyDate[1]+lStudyDate[2]+lStudyDate[3]+lStudyDate[4]; + Y := strtoint(lStr); + lStr := lStudyDate[5]+lStudyDate[6]; + M := strtoint(lStr); + lStr := lStudyDate[7]+lStudyDate[8]; + D := strtoint(lStr); + lStr := lStudyTime[1]+lStudyTime[2]; + H := strtoint(lStr); + lStr := lStudyTime[3]+lStudyTime[4]; + Min := strtoint(lStr); + lStr := lStudyTime[5]+lStudyTime[6]; + S := strtoint(lStr); + result := EncodeDateTime (Y,M,D,H,Min,S); +end; + +procedure AplhaNumericStrDICOM (var lStr: kDICOMStr); +var + S: integer; + lOutStr: string; +begin + if length(lStr) < 1 then exit; + lOutStr := ''; + + for S := 1 to length (lStr) do + if lStr[S] in ['0'..'9','A'..'Z','a'..'z'] then + lOutStr := lOutStr+ lStr[S]; + lStr := lOutStr; +end; +(* +function GetCSAImageHeaderInfoRaw (lIsDTI: boolean; lFilename: string; lStart,lLength: integer; var li1,li2,li3: integer; var lf1,lf2,lf3: double): boolean; +//returns true if mosaic +//will return false for non-mosaics - even if the have DTI information! +//valid DTI signified by bval >= 0 +const + kMaxFloats = 6; +var + //lZ: integer; + lByteRA: Bytep; + lNumarisTag: string; + lInFile: file; + lFloatRA: array [1..kMaxFloats] of double; + +function Str2FloatLastNum ( lStr: string): boolean; +var + lFStr: string; + lP: integer; +begin + lFloatRA[1] := 1; + result := false; + if (length(lStr) < 1) then + exit; + lFStr := ''; + lP := length(lStr); + while (lP > 0) and ((lFStr = '') or (lStr[lP] in ['+','-','0'..'9','.','e','E'])) do begin + if lStr[lP] in ['+','-','0'..'9','.','e','E'] then + lFStr := lStr[lP]+lFStr; + dec(lP); + end; + if (lFStr = '') then + exit; + try + lFloatRA[1] := strtofloat(lFStr); + except on EConvertError do + lFloatRA[1] := 1; + end;//except + result := true; +end; //function Str2Float + +function NumarisPos (lStr: string; lStart: integer): integer; //read 16 bit short integer +var + lP,lLen,lMax,lMatch: integer; +begin + result := 0; + lLen := length(lStr); + lMax := lLength-lLen; + if (lStart < 1) or (lMax < 1) or (lLen < 1) then + exit; + for lP := lStart to lMax do begin + lMatch := 0; + while (lMatch < lLen) and (lStr[lMatch+1] = char( lByteRA[lP+lMatch]) ) do + inc(lMatch); + if lMatch = lLen then begin + if (lP < lMax) and (char( lByteRA[lP+lMatch]) = '"') then begin + lMatch := 0;//We want DiffusionGradientDirection, but not "DiffusionGradientDirection" + end else begin + result := lP; + exit; + end; + end; + end; +end; //function NumarisPos + +function Str2FloatNum ( lStr: string; lnFloats: integer): boolean; +var + lFStr: string; + lP,lnF: integer; +begin + result := false; + if (length(lStr) < 1) or (lnFloats < 1) or (lnFloats > kMaxFloats) then + exit; + for lnF := 1 to lnFloats do + lFloatRA[lnF] := 1; + lStr := lStr + ' '; //terminator + lFStr := ''; + lP := 1; + lnF:= 0; + while lP <= length(lStr) do begin + if lStr[lP] in ['+','-','0'..'9','.','e','E'] then + lFStr := lFStr + lStr[lP] + else if (lFStr <> '') then begin + inc(lnF); + try + lFloatRA[lnF] := strtofloat(lFStr); + except on EConvertError do + dcmMsg('Unable to interpret '+lNumarisTag+ ' in '+extractfilename(lFilename)); + end;//except + if lnF = lnFloats then begin + result := true; + exit; + end; + lFStr := ''; + end; + inc(lP); + end; +end; //function Str2Float + +function NumarisStr (lStr,lIDStr: string): string; +var + lP,lI: integer; + lPrevNum : boolean; +begin + result := ''; + lP := NumarisPos(lStr,1); + if lP <1 then exit; + if length(lIDstr) > 0 then begin + lP := NumarisPos(lIDstr,lP); + if lP <1 then exit; + end; + result := ''; + lI := lP + length(lStr); + lPrevNum := false; + While (lI < (lLength)) and (lByteRA^[lI] <> $CD) do begin + if char(lByteRA[lI]) in ['-','0'..'9','.','p','*'] then begin + result := result + char(lByteRA[lI]); + lPrevNum := true; + end else begin + if lPrevNum then result := result + ' '; + lPrevNum := false; + end; + inc(lI); + end; +end; + +function NumarisInt1 (lStr,lIDStr: string; var lI1: integer): boolean; +begin + result := Str2FloatLastNum (NumarisStr(lStr,lIDStr)); + if not result then exit; + lI1 := round(lFloatRA[1] ); +end; + +function NumarisFloat3 (lStr,lIDStr: string; var lF1,lF2,lF3: double): boolean; +begin + //showmessage(lStr+' '+NumarisStr(lStr,lIDStr)); + result := Str2FloatNum (NumarisStr(lStr,lIDStr),3); + if not result then exit; + + lF1 := (lFloatRA[1]); + lF2 := (lFloatRA[2]); + lF3 := (lFloatRA[3]); +end; //function NumarisFloat3 + +function NumarisInt2PStar (lStr,lIDStr: string; var lI1,lI2: integer): boolean; +var + lLen,lPos,lStarPos: integer; + lvStr,lpStarStr: string; +begin //a 96x96 mosaic is usually saved as '64*64', but in B13 you can see '96p*96' or '.95 96p*96' + result := false; + lvStr := NumarisStr(lStr,lIDStr); + lLen := length(lvStr); + if lLen < 4 then exit;//not found + lStarPos := 0; + for lPos := 1 to (lLen-1) do + if (lvStr[lPos] = '*') then + lStarPos := lPos; + if lStarPos = 0 then exit; + lpStarStr := ''; + lPos := lStarPos -1; + while (lPos >= 1) and ((lpStarStr = '') or (lvStr[lPos] in ['0'..'9'])) do begin + lpStarStr := lvStr[lPos] + lpStarStr; + dec(lPos); + end; + lpStarStr := lpStarStr + ' '; + lPos := lStarPos+1; + while (lPos < lLen) and ((lpStarStr = '') or (lvStr[lPos] in ['0'..'9'])) do begin + lpStarStr := lpStarStr+lvStr[lPos]; + inc(lPos); + end; + result := Str2FloatNum (lpStarStr,2); + + if not result then exit; + lI1 := round(lFloatRA[1]); + lI2 := round(lFloatRA[2]); + //dcmMsg(lvStr+' '+floattostr( lI1)+'x'+inttostr(lI2)); +end; + +begin // GetCSAImageHeaderInfoRaw + result := false; + if (lLength < 1) then + exit; + if FSize(lFilename) <= (lStart+lLength) then + exit; + li1 := -1; //impossible - should be >=0 + li2 := 0; + li3 := 0; + lf1 := 0;//impossible, therefore not DTI - should be -1..1 + lf2 := 0;//impossible, therefore not DTI + lf3 := 0;//impossible, therefore not DTI + GetMem(lByteRA,lLength); + AssignFile(lInFile, lFileName); + //dcmMsg('fz '+lFilename); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lStart); + BlockRead(lInFile, lByteRA^[1], lLength); + CloseFile(lInFile); + FileMode := 2; + if lIsDTI then begin + + result := NumarisInt1 ('B_value','IS',li1); + //result := NumarisInt1 ('B_value','LO',li1); + if li1 > 0 then begin + NumarisFloat3('DiffusionGradientDirection','FD',lf1,lf2,lf3); + //vx(lf1,lf2,lf3,123); + end; + end else begin //get mosaic info + //fx(lStart,lLength); + result := NumarisInt1 ('NumberOfImagesInMosaic','US',li1); + if result then begin + NumarisInt2pStar ('AcquisitionMatrixText','SH', li2,li3); + NumarisFloat3('SliceNormalVector','FD',lf1,lf2,lf3); + end; + end; + FreeMem(lByteRA); +end;//GetCSAImageHeaderInfoRaw + +function GetCSAImageHeaderInfoDTI (lFilename: string; lStart,lLength: integer; var lBval: integer; var ldti1,ldti2,ldti3: double): boolean; +var + li2,li3: integer; //not used +begin + result := GetCSAImageHeaderInfoRaw (TRUE,lFilename, lStart,lLength, lBval,li2,li3, ldti1,ldti2,ldti3); +end; + +function GetCSAImageHeaderInfo (lFilename: string; lStart,lLength: integer; var lMosaicSlices,lMosaicX,lMosaicY: integer; var lv1,lv2,lv3: double): boolean; +begin + result := GetCSAImageHeaderInfoRaw (FALSE,lFilename, lStart,lLength, lMosaicSlices,lMosaicX,lMosaicY, lv1,lv2,lv3); +end; *) + +procedure Clear_DTIra(var lDTIra: TDTIra); +var + lI: integer; +begin + for lI := 1 to kMaxDTIDir do + lDTIra[lI].Bval := -1; +end; + +procedure clear_dicom_data (var lDicomdata:Dicomdata); +var + lI: integer; +begin + with lDicomData do begin + lDicomData.CSAImageHeaderInfoPos := 0; + lDicomData.CSAImageHeaderInfoSz := 0; + lDicomData.CSASeriesHeaderInfoPos := 0; + lDicomData.CSASeriesHeaderInfoSz := 0; + for lI := 1 to 6 do + Orient[lI] := 0; + DateTime := BogusDateTime; + ManufacturerID := 0; + kV := 0; + //ImplementationVersion := 0; + Vers0018_1020 := 0; + AngulationFH := 0; + AngulationRL := 0; + AngulationAP := 0; + nDTIdir := 0; + nOrder := 0; + PhilipsSliceOrient := 'NA'; + ScanningSequence0018_0020 := ''; + PhaseEncoding := 'NA'; + PatientPos := 'NA'; + DTI.Bval := -1; + DTI.v1 := 0; + DTI.v2 := 0; + DTI.v3 := 0; + SiemensDICOMDTI := true; + SiemensDICOMDTICSA := false; + file4D := false; + PatientName := 'NO NAME'; + PatientDoB := 'NO DOB'; + PatientGender := 'NA'; + PatientHx := ''; + ImageComments := ''; + //PatientID := 'NO ID'; + StudyDate := ''; + StudyTime := ''; + SecSinceMidnight := 0; + //AcqTime := ''; + //ImgTime := ''; + TR := 0; + TE := 0; + //Echo := 0; + //kV := 0; + //mA := 0; + //Rotate180deg := false; + //MaxIntensity := 0; + //MinIntensity := 0; + //MinIntensitySet := false; + FloatData := false; + ImageNum := -1; + SlicesPer3DVol := 0; + SiemensInterleaved := 2; //0=no,1=yes,2=undefined + SiemensSlices := 0; + SiemensMosaicX := 1; + SiemensMosaicY := 1; + IntenScale := 1; + IntenIntercept := 0; + SeriesNum := 1; + AcquNum := 0; + ImageNum := 1; + //Accession := 1; + PlanarConfig:= 0; //only used in RGB values + //runlengthencoding := false; + //CompressSz := 0; + //CompressOffset := 0; + SamplesPerPixel := 1; + //WindowCenter := 0; + //WindowWidth := 0; + XYZmm[1] := 1; + XYZmm[2] := 1; + XYZmm[3] := 1; + XYZdim[1] := 1; + XYZdim[2] := 1; + XYZdim[3] := 1; + XYZdim[4] := 1; + lDicomData.XYZori[1] := 0; + lDicomData.XYZori[2] := 0; + lDicomData.XYZori[3] := 0; + ImageStart := 0; + Little_Endian := 0; + Allocbits_per_pixel := 16;//bits + //Storedbits_per_pixel:= Allocbits_per_pixel; + //StudyDatePos := 0; + //Spacing:=0; + //Thickness:= 0;//1391 + Location:=0; + //Modality:='MR'; + //ProtocolName := ''; + //serietag:=''; + PatientPosX := 0;//1392 + PatientPosY := 0;//1392 + PatientPosZ := 0;//1392 + JPEGLossyCpt := false; + JPEGLosslessCpt := false; + SignedData := true; + CompressOffset := 0; + CompresssZ := 0; + BandwidthPerPixelPhaseEncode := 0; //7/2013 + FieldStrength := 0; + + end; +end; + +function DICOMinterslicedistance(var lDicomdata1,lDicomdata2:Dicomdata): single;//1392 +begin + result := sqrt(sqr(lDICOMdata1.PatientPosX-lDICOMdata2.PatientPosX) + +sqr(lDICOMdata1.PatientPosY-lDICOMdata2.PatientPosY) + +sqr(lDICOMdata1.PatientPosZ-lDICOMdata2.PatientPosZ)); + +end; + +end. + diff --git a/dcm2nii/dicomtypes.ppu b/dcm2nii/dicomtypes.ppu new file mode 100644 index 0000000..991aae0 Binary files /dev/null and b/dcm2nii/dicomtypes.ppu differ diff --git a/dcm2nii/diskfree.pas b/dcm2nii/diskfree.pas new file mode 100755 index 0000000..e6f612e --- /dev/null +++ b/dcm2nii/diskfree.pas @@ -0,0 +1,352 @@ +unit diskfree; + +{ + Copyright 2001, by Michael Hopper + + This unit provides generic functions for finding the number of bytes and + available bytes for a given drive volume or path. These functions work for + both Linux and Windows systems. + + Note: In the near future, getmntent should be incorporated into the Linux + version of the code rather than reading the /etc/mtab file directly. This + is for future compatibility. +} + +interface + +uses + SysUtils; + +{$IFDEF LINUX} + +{ This function is included (necessary) only in the Linux version because the + Windows version is a little more intuitive, i.e., 1=A:, 2=B:, etc. +} +function GetVolumePath (Volume : integer) : TFileName; +{$ENDIF} + +{ This overloaded function returns the number of available bytes for the + specified path or volume. I've mimicked DiskFree in that Volume=0 indicates + the current directory (or pwd), while values greater than 0 return a value for + the drives A: through Z: on Windows systems. + + For Linux systems, the /etc/mtab file is read, and only those devices mounted + under /dev are alphabetized and included. This means that a value of 1 would + return the free space on /dev/fd0 if a floppy is mounted, or /dev/hda1 if a + floppy is not mounted. Hence the need for the GetVolumePath function to + verify that you're getting the right path. +} +function GetAvailableFreeSpace(path : TFilename) : int64; overload; +function GetAvailableFreeSpace(Volume : byte) : int64; overload; + +{ This overloaded function returns the total number of bytes for the volume or + path specified. Specification of the path or volume follows the same pattern + as for the GetAvailableFreeSpace function. +} +function GetVolumeBytes(path : TFilename) : int64; overload; +function GetVolumeBytes(Volume : byte) : int64; overload; + +implementation + +{$IFDEF MSWINDOWS} +uses + Windows; +{$ENDIF} + +{$IFDEF LINUX} +uses + Classes,libc; + +const + MAX_PATH = 65536; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function oldWindows : boolean; + +{ + Use GetVersionEx windows call as defined in SysUtils and explained in the + Win32 help file to return true if this is a version of Win95 that is pre-OSR2. + Otherwise, return false. +} + +var + MyVersionInfo : _OSVERSIONINFOA; + +begin + +// Get Windows version information +getversionex(MyVersionInfo); + +// Report TRUE only if Platform is Win9x and BuildNumber is < 1000 (pre-OSR2). +with MyVersionInfo do + begin + result := ((dwPlatformID = VER_PLATFORM_WIN32_WINDOWS) and + ((dwBuildNumber and $0000FFFF) < 1000)) + end; +end; +{$ENDIF} + + + +{$IFDEF LINUX} +function GetVolumePath (Volume : integer) : TFileName; + +{ + Return the path of the Volume specified. If Volume = 0, return the present + present working directory. +} + +var + loop : integer; + tempstr : string; + mountedDrives : TStringlist; + + +begin +// return the present working directory if Volume = 0. +if Volume = 0 then + result := getenvironmentvariable('PWD') +else + begin + // Get information about currently mounted drives. + mountedDrives := tstringlist.create; + mountedDrives.LoadFromFile('/etc/mtab'); + + // Alphabetize + mountedDrives.Sort; + + loop := 0; + + // Loop to remove entries that are not drives + while loop < mountedDrives.Count do + begin + if pos('/dev/',mountedDrives.Strings[loop]) <> 1 then + mountedDrives.Delete(loop) + else + inc(loop); + end; + + // If there are not enough mounted drives, then return a null string. + if Volume > mountedDrives.Count then + result := '' + else // parse the entry to return the mounted path. + begin + tempstr := mountedDrives.Strings[Volume-1]; + tempstr := copy(tempstr,pos(' ',tempstr) + 1,length(tempstr)); + tempstr := copy(tempstr,1,pos(' ',tempstr)-1); + result := tempstr; + end; + end; +end; +{$ENDIF} + + + +function CalculateVolumeSpace(path : pchar; var AvailableBytes : int64; var TotalBytes : int64) : boolean; + +{ + This function calculates and returns the number of available bytes and total + bytes for a given path. It also returns a true value if successful, or false + if unsuccessful at determining the correct values. If the function returns + false, then the AvailableBytes and TotalBytes values should be treated as + though they are undefined. +} + +var +{$IFDEF MSWINDOWS} + SectorsPerCluster, + BytesPerSector, + NumberOfFreeClusters, + TotalNumberOfClusters : cardinal; +{$ENDIF} +{$IFDEF LINUX} + myStatFs : Tstatfs; +{$ENDIF} + +begin +{$IFDEF MSWINDOWS} + +// Check for pre-OSR2 Win95 because the GetDiskFreeSpace function was not +// available. +if not oldWindows then + result := GetDiskFreeSpaceEx(path,AvailableBytes,TotalBytes,nil) + +// If pre-OSR2 Win95, then calculate the free space. +else if GetDiskFreeSpace(path,SectorsPerCluster,BytesPerSector,NumberOfFreeClusters,TotalNumberOfClusters) then + begin + result := true; + AvailableBytes := BytesPerSector * SectorsPerCluster * NumberOfFreeClusters; + TotalBytes := BytesPerSector * SectorsPerCluster * TotalNumberOfClusters; + end + +// If unsuccessful at either of the previous attempts, report failure. +else + begin + result := false; + AvailableBytes := -1; + TotalBytes := -1; + end; +{$ENDIF} + +{$IFDEF LINUX} + +// Read information about the volume. +if statfs(path,myStatFS) = 0 then + begin + + // Calculate AvailableBytes and TotalBytes. + AvailableBytes := int64(myStatFs.f_bAvail) * int64(myStatFs.f_bsize); + TotalBytes := int64(myStatFs.f_blocks) * int64(myStatFs.f_bsize); + + // Report success. + result := true; + end + +else // report failure to get information + begin + AvailableBytes := -1; + TotalBytes := -1; + result := false; + end; +{$ENDIF} +end; + + + +function GetAvailableFreeSpace(path : TFilename) : int64; overload; + +{ + Use the CalculateVolumeSpace function to find the free space for the path + specified. +} + +var + TotalBytes : int64; + pathPchar : pchar; + +begin +{$IFDEF MSWINDOWS} +if ByteType(path,1) = mbSingleByte then + getmem(pathPchar,length(path) + 1) +else + getmem(pathPchar,2 * (length(path) + 1)); +strpcopy(pathpchar,path); +if not CalculateVolumeSpace(pathPchar,result,TotalBytes) then + result := -1; +{$ENDIF} + +{$IFDEF LINUX} +getmem(pathPchar,(length(path) + 1) * sizeof(char)); +strpcopy(pathPchar,path); +if not CalculateVolumeSpace(pathPchar,result,TotalBytes) then + result := -1; // stub +{$ENDIF} +end; + + +function GetAvailableFreeSpace(Volume : byte) : int64; overload; + +{ + Use the CalculateVolumeSpace function to find the free space for the Volume + specified. +} + +var + volumePath : array [1..MAX_PATH + 1] of char; + volumePchar : pchar; + TotalSpace : int64; + + +begin +{$IFDEF MSWINDOWS} +volumePchar := @volumePath; +if Volume = 0 then + getcurrentdirectory(MAX_PATH + 1,volumePchar) +else + strPCopy(volumePchar,chr(Volume - 1 + ord('A')) + ':\'); +if not CalculateVolumeSpace(volumePchar, result, TotalSpace) then + result := -1; +{$ENDIF} + +{$IFDEF LINUX} +volumePchar := @volumePath; +if Volume = 0 then + strPCopy(volumePchar,getEnvironmentVariable('PWD')) +else + strPCopy(volumePChar,GetVolumePath(Volume)); +if not CalculateVolumeSpace(volumePchar, result, TotalSpace) then + result := -1; +{$ENDIF} +end; + + + +function GetVolumeBytes(path : TFilename) : int64; overload; + +{ + Use the CalculateVolumeSpace function to find the total space for the path + specified. +} + +var + AvailableBytes : int64; + pathPchar : pchar; + +begin +{$IFDEF MSWINDOWS} +if ByteType(path,1) = mbSingleByte then + getmem(pathPchar,length(path) + 1) +else + getmem(pathPchar,2 * (length(path) + 1)); +strpcopy(pathpchar,path); +if not CalculateVolumeSpace(pathPchar,AvailableBytes,result) then + result := -1; +{$ENDIF} + +{$IFDEF LINUX} +getmem(pathPchar,(length(path) + 1) * sizeof(char)); +strpcopy(pathPchar,path); +if not CalculateVolumeSpace(pathPchar,AvailableBytes, result) then + result := -1; +{$ENDIF} +end; + + + +function GetVolumeBytes(Volume : byte) : int64; overload; + +{ + Use the CalculateVolumeSpace function to find the total space for the Volume + specified. +} + +var + volumePath : array [1..MAX_PATH + 1] of char; + volumePchar : pchar; + AvailableBytes : int64; + + +begin +{$IFDEF MSWINDOWS} +volumePchar := @volumePath; +if Volume = 0 then + getcurrentdirectory(MAX_PATH + 1,volumePchar) +else + strPCopy(volumePchar,chr(Volume - 1 + ord('A')) + ':\'); +if not CalculateVolumeSpace(volumePchar, AvailableBytes, result) then + result := -1; +{$ENDIF} + +{$IFDEF LINUX} +volumePchar := @volumePath; +if Volume = 0 then + strPCopy(volumePchar,getEnvironmentVariable('PWD')) +else + strPCopy(volumePChar,GetVolumePath(Volume)); +if not CalculateVolumeSpace(volumePchar, AvailableBytes, result) then + result := -1; +{$ENDIF} +end; + +end. diff --git a/dcm2nii/extrafpc.cfg b/dcm2nii/extrafpc.cfg new file mode 100755 index 0000000..4c13c40 --- /dev/null +++ b/dcm2nii/extrafpc.cfg @@ -0,0 +1,4 @@ +#IFDEF Darwin +-k-macosx_version_min -k10.4 +-XR/Developer/SDKs/MacOSX10.4u.sdk/ +#ENDIF \ No newline at end of file diff --git a/dcm2nii/filename.o b/dcm2nii/filename.o new file mode 100644 index 0000000..c923cc2 Binary files /dev/null and b/dcm2nii/filename.o differ diff --git a/dcm2nii/filename.pas b/dcm2nii/filename.pas new file mode 100755 index 0000000..e84fdf2 --- /dev/null +++ b/dcm2nii/filename.pas @@ -0,0 +1,200 @@ +unit filename; +{$IFDEF FPC} +{$mode objfpc} +{$ENDIF} +{$H+} + +interface + + +uses +//{$IFNDEF FPC}FileCtrl,{$ENDIF} + Classes, SysUtils,define_types,dicomtypes,prefs; +procedure ExtractFileParts (var lFileName, lNameWOExt,lExt: string); +function ExtractFileDirWithPathDelim2(lInFilename: string): string; +procedure AplhaNumericStr (var lStr: string); +procedure AplhaNumericStrExt (var lStr: string); +function OutputFilename(var lDicomImgName: string; var lDicomData: dicomData; lPrefs: TPrefs): string; +procedure StripNIIVOIExt (var lFilename: string); + +procedure StripGZExt (var lFilename: string); +function FilenameWOExt( lFileName: string): string; +function UpcaseStr(lIn: string): string; + +implementation +uses dialogsx; + + +function UpcaseStr(lIn: string): string; +var lI: integer; +begin + result := lIn; + if length(result) > 0 then + for lI := 1 to length(result) do + result[lI] := upcase(result[lI]); +end; + +function FilenameWOExt( lFileName: string): string; +var lNameWOExt,lExt : string; +begin + ExtractFileParts (lFileName, lNameWOExt,lExt); + result := extractfilename(lNameWOExt); +end; + +procedure AplhaNumericStr (var lStr: string); +var + S: integer; + lOutStr: string; +begin + if length(lStr) < 1 then exit; + lOutStr := ''; + + for S := 1 to length (lStr) do + if lStr[S] in ['0'..'9','A'..'Z','a'..'z'] then + lOutStr := lOutStr+ lStr[S]; + lStr := lOutStr; +end; + +procedure AplhaNumericStrExt (var lStr: string); +var + S: integer; + lOutStr: string; +begin + if length(lStr) < 1 then exit; + lOutStr := ''; + + for S := 1 to length (lStr) do + if lStr[S] in ['0'..'9','A'..'Z','a'..'z','_','-','^'] then + lOutStr := lOutStr+ lStr[S]; + lStr := lOutStr; +end; + +procedure StripNIIVOIExt (var lFilename: string); +var + lStr: string; + lLen,lPos: integer; +begin + lLen := length(lFilename); + if lLen < 8 then exit; + lStr := ''; + for lPos := (lLen-7) to (lLen) do + lStr := lStr +UpCase(lFilename[lPos]); + if lStr <> '.NII.VOI' then exit; + lStr := ''; + for lPos := 1 to (lLen-8) do + lStr := lStr + lFilename[lPos]; + lStr := lStr + '.VOI'; + lFilename := lStr; +end; + +procedure StripGZExt (var lFilename: string); +var + lStr: string; + lLen,lPos: integer; +begin + lLen := length(lFilename); + if lLen < 4 then exit; + lStr := ''; + for lPos := (lLen-2) to (lLen) do + lStr := lStr +UpCase(lFilename[lPos]); + if lStr <> '.GZ' then exit; + //showmessage(lFilename +' ->'+lStr); + lStr := ''; + for lPos := 1 to (lLen-3) do + lStr := lStr + lFilename[lPos]; + lFilename := lStr; + //showmessage(lStr); +end; + +function OutputFilename(var lDicomImgName: string; var lDicomData: dicomData; lPrefs: TPrefs): string; +var lFile,lStr,lStr2,lExt: string; + lAppendDate,lAppendAcqSeries,lAppendProtocolName,lAppendPatientName,lAppendFilename:boolean ; +begin + + lAppendDate := lPrefs.AppendDate; + lAppendAcqSeries := lPrefs.AppendAcqSeries; + lAppendProtocolName := lPrefs.AppendProtocolName; + lAppendPatientName := lPrefs.AppendPatientName; + lAppendFilename := lPrefs.AppendFilename; + if (not lAppendDate) and (not lAppendAcqSeries) and (not lAppendProtocolName) and (not lAppendPatientName) + and (not lAppendFilename) then begin + lAppendDate := true; + lAppendAcqSeries := true; + lAppendProtocolName := true; + end; + lStr := ''; + + if lAppendPatientName then begin + lStr2 := lDicomData.PatientName; + AplhaNumericStrExt(lStr2); + lStr := lStr2+lStr; + end; + if lAppendProtocolName then begin + lStr2 := lDicomData.ProtocolName; + AplhaNumericStrExt(lStr2); + lStr := lStr2+lStr; + end; + if lAppendFilename then begin + lFile := ExtractFilename (lDicomImgName); + ExtractFileParts (lFile, lStr2,lExt); + AplhaNumericStrExt(lStr2); + lStr := lStr2+lStr; + end; + if lAppendAcqSeries then + lStr := lStr+'s'+PadStr(lDicomData.SeriesNum,3)+'a'+PadStr(lDicomData.AcquNum,3); + if lAppendDate then + lStr := StudyDateTime2Str(lDicomData.DateTime)+lStr; + lStr := lPrefs.NameAppend + lStr; + result := lStr; + + + +end; + + + +procedure ExtractFileParts (var lFileName, lNameWOExt,lExt: string); +var lI: integer; +l2ndExt : string; +begin + lNameWOExt := ''; + lExt := ExtractFileExt(lFileName); + if length(lExt) > 0 then + for lI := 1 to length(lExt) do + lExt[lI] := upcase(lExt[lI]); + if (lExt = '.GZ') or (lExt = '.VOI') then begin + lI := length(lFileName) - 6; + if li < 1 then exit; + l2ndExt := upcase(lFileName[lI])+upcase(lFileName[lI+1])+upcase(lFileName[li+2])+upcase(lFileName[li+3]); + if (l2ndExt = '.TAR') or (l2ndExt = '.NII') then + lExt := l2ndExt+lExt; + end; + if length(lExt) >= length (lFilename) then exit; + for lI := 1 to (length(lFilename)-length(lExt)) do + lNameWOExt := lNameWOExt + lFileName[lI]; + //next for Unix do not use UpCase extension + if length(lExt) >= 0 then begin + l2ndExt := ''; + for lI := 1 to (length(lExt)) do + l2ndExt := lFilename[length(lFilename)-lI+1]+l2ndExt; + lExt := l2ndExt; + end; //length > 0 + //showmessage(lNameWOExt+' '+lExt); +end; + +function ExtractFileDirWithPathDelim2(lInFilename: string): string; +//F:\filename.ext -> 'F:\' and F:\dir\filename.ext -> 'F:\dir\' +//Despite documentation, Delphi3's ExtractFileDir does not always retain final pathdelim +//ensures c:\temp is returned c:\temp\ not c:\ +begin + if DirExists(lInFilename) then begin + result :=(lInFilename); + if result[length(result)]<> pathdelim then + result := result + pathdelim; + exit; + end; + result := ExtractFileDirWithPathDelim(lInFilename); +end; + +end. + \ No newline at end of file diff --git a/dcm2nii/filename.ppu b/dcm2nii/filename.ppu new file mode 100644 index 0000000..fe7a35e Binary files /dev/null and b/dcm2nii/filename.ppu differ diff --git a/dcm2nii/gui.dfm b/dcm2nii/gui.dfm new file mode 100755 index 0000000..ebf3d88 Binary files /dev/null and b/dcm2nii/gui.dfm differ diff --git a/dcm2nii/gui.lfm b/dcm2nii/gui.lfm new file mode 100755 index 0000000..28463c8 --- /dev/null +++ b/dcm2nii/gui.lfm @@ -0,0 +1,162 @@ +object MainForm: TMainForm + Left = 532 + Height = 363 + Top = 105 + Width = 598 + ActiveControl = Panel1 + AllowDropFiles = True + BorderWidth = 1 + Caption = 'dcm2nii' + ClientHeight = 363 + ClientWidth = 598 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnDropFiles = FormDropFiles + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.4.2.0' + object Memo1: TMemo + Left = 5 + Height = 321 + Top = 37 + Width = 588 + Align = alClient + BorderSpacing.Left = 4 + BorderSpacing.Top = 2 + BorderSpacing.Right = 4 + BorderSpacing.Bottom = 4 + ScrollBars = ssAutoVertical + TabOrder = 0 + end + object Panel1: TPanel + Left = 1 + Height = 34 + Top = 1 + Width = 596 + Align = alTop + BevelOuter = bvNone + BorderWidth = 2 + BorderStyle = bsSingle + ClientHeight = 34 + ClientWidth = 596 + TabOrder = 1 + object Label1: TLabel + Left = 1 + Height = 26 + Top = 5 + Width = 140 + Alignment = taRightJustify + Anchors = [akLeft] + AutoSize = False + Caption = 'Output Format: ' + ParentColor = False + end + object TypeCombo: TComboBox + Left = 160 + Height = 20 + Top = 3 + Width = 264 + ItemHeight = 0 + Items.Strings = ( + 'SPM2 (3D Anlyze hdr/img)' + 'SPM5 (3D NIfTI hdr/img)' + 'SPM8 (3D NIfTI nii)' + '4D NIfTI hdr/img' + 'FSL/SPM8 (4D NIfTI nii)' + 'Compressed FSL (4D NIfTI nii)' + ) + Style = csDropDownList + TabOrder = 0 + end + end + object OpenHdrDlg: TOpenDialog + FilterIndex = 0 + left = 24 + top = 48 + end + object MainMenu1: TMainMenu + left = 88 + top = 48 + object AppleMenu: TMenuItem + Caption = '' + Visible = False + object ApplePrefs: TMenuItem + Caption = 'Preferences' + OnClick = Preferences1Click + end + end + object File1: TMenuItem + Caption = 'File' + object DICOMtoNIfTI1: TMenuItem + Caption = 'DICOM to NIfTI' + ShortCut = 16452 + OnClick = dcm2niiBtnClick + end + object ModifyNIfTI1: TMenuItem + Caption = 'Modify NIfTI' + OnClick = ModifyNIfTI1Click + end + object NIfTI3D4D1: TMenuItem + Caption = 'NIfTI 3D -> 4D' + OnClick = NIfTI3D4D1Click + end + object AnonymizeDICOM1: TMenuItem + Caption = 'Anonymize DICOM' + OnClick = AnonymizeDICOM1Click + end + object Exit1: TMenuItem + Caption = 'Exit' + OnClick = Exit1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + end + object UntestedMenu: TMenuItem + Caption = 'Untested' + object MirrorXdimension1: TMenuItem + Caption = 'Mirror X-dimension' + OnClick = MirrorXdimension1Click + end + object SumTPM1: TMenuItem + Caption = 'Sum TPM' + OnClick = SumTPM1Click + end + object ExtractDICOMdims1: TMenuItem + Caption = 'Extract DICOM dims' + OnClick = ExtractDICOMdims1Click + end + object ExtractDICOMhdr1: TMenuItem + Caption = 'Extract DICOM header' + OnClick = ExtractDICOMhdr1Click + end + object ExtractNIfTIhdrs1: TMenuItem + Caption = 'Extract NIfTI header' + OnClick = ExtractNIfTIhdrs1Click + end + object HalveMenu1: TMenuItem + Caption = 'Halve dimensions in-plane' + OnClick = HalveMenu1Click + end + end + object Help1: TMenuItem + Caption = 'Help' + object Preferences1: TMenuItem + Caption = 'Preferences' + OnClick = Preferences1Click + end + object About1: TMenuItem + Caption = 'Help' + OnClick = About1Click + end + end + end + object SelectDirectoryDialog1: TSelectDirectoryDialog + left = 472 + end +end diff --git a/dcm2nii/gui.lrs b/dcm2nii/gui.lrs new file mode 100755 index 0000000..51c5481 --- /dev/null +++ b/dcm2nii/gui.lrs @@ -0,0 +1,50 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TMainForm','FORMDATA',[ + 'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3#20#2#6'Height'#3'k'#1#3'Top'#2'i'#5 + +'Width'#3'V'#2#13'ActiveControl'#7#6'Panel1'#14'AllowDropFiles'#9#11'BorderW' + +'idth'#2#1#7'Caption'#6#7'dcm2nii'#12'ClientHeight'#3'k'#1#11'ClientWidth'#3 + +'V'#2#4'Menu'#7#9'MainMenu1'#7'OnClose'#7#9'FormClose'#8'OnCreate'#7#10'Form' + +'Create'#11'OnDropFiles'#7#13'FormDropFiles'#6'OnShow'#7#8'FormShow'#8'Posit' + +'ion'#7#14'poScreenCenter'#10'LCLVersion'#6#7'1.4.2.0'#0#5'TMemo'#5'Memo1'#4 + +'Left'#2#5#6'Height'#3'A'#1#3'Top'#2'%'#5'Width'#3'L'#2#5'Align'#7#8'alClien' + +'t'#18'BorderSpacing.Left'#2#4#17'BorderSpacing.Top'#2#2#19'BorderSpacing.Ri' + +'ght'#2#4#20'BorderSpacing.Bottom'#2#4#10'ScrollBars'#7#14'ssAutoVertical'#8 + +'TabOrder'#2#0#0#0#6'TPanel'#6'Panel1'#4'Left'#2#1#6'Height'#2'"'#3'Top'#2#1 + +#5'Width'#3'T'#2#5'Align'#7#5'alTop'#10'BevelOuter'#7#6'bvNone'#11'BorderWid' + +'th'#2#2#11'BorderStyle'#7#8'bsSingle'#12'ClientHeight'#2'"'#11'ClientWidth' + +#3'T'#2#8'TabOrder'#2#1#0#6'TLabel'#6'Label1'#4'Left'#2#1#6'Height'#2#26#3'T' + +'op'#2#5#5'Width'#3#140#0#9'Alignment'#7#14'taRightJustify'#7'Anchors'#11#6 + +'akLeft'#0#8'AutoSize'#8#7'Caption'#6#16'Output Format: '#11'ParentColor'#8 + +#0#0#9'TComboBox'#9'TypeCombo'#4'Left'#3#160#0#6'Height'#2#20#3'Top'#2#3#5'W' + +'idth'#3#8#1#10'ItemHeight'#2#0#13'Items.Strings'#1#6#24'SPM2 (3D Anlyze hdr' + +'/img)'#6#23'SPM5 (3D NIfTI hdr/img)'#6#19'SPM8 (3D NIfTI nii)'#6#16'4D NIfT' + +'I hdr/img'#6#23'FSL/SPM8 (4D NIfTI nii)'#6#29'Compressed FSL (4D NIfTI nii)' + +#0#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#0#0#0#0#11'TOpenDialog'#10'Op' + +'enHdrDlg'#11'FilterIndex'#2#0#4'left'#2#24#3'top'#2'0'#0#0#9'TMainMenu'#9'M' + +'ainMenu1'#4'left'#2'X'#3'top'#2'0'#0#9'TMenuItem'#9'AppleMenu'#7'Caption'#6 + +#3#239#163#191#7'Visible'#8#0#9'TMenuItem'#10'ApplePrefs'#7'Caption'#6#11'Pr' + +'eferences'#7'OnClick'#7#17'Preferences1Click'#0#0#0#9'TMenuItem'#5'File1'#7 + +'Caption'#6#4'File'#0#9'TMenuItem'#13'DICOMtoNIfTI1'#7'Caption'#6#14'DICOM t' + +'o NIfTI'#8'ShortCut'#3'D@'#7'OnClick'#7#15'dcm2niiBtnClick'#0#0#9'TMenuItem' + +#12'ModifyNIfTI1'#7'Caption'#6#12'Modify NIfTI'#7'OnClick'#7#17'ModifyNIfTI1' + +'Click'#0#0#9'TMenuItem'#10'NIfTI3D4D1'#7'Caption'#6#14'NIfTI 3D -> 4D'#7'On' + +'Click'#7#15'NIfTI3D4D1Click'#0#0#9'TMenuItem'#15'AnonymizeDICOM1'#7'Caption' + +#6#15'Anonymize DICOM'#7'OnClick'#7#20'AnonymizeDICOM1Click'#0#0#9'TMenuItem' + +#5'Exit1'#7'Caption'#6#4'Exit'#7'OnClick'#7#10'Exit1Click'#0#0#0#9'TMenuItem' + +#5'Edit1'#7'Caption'#6#4'Edit'#0#9'TMenuItem'#5'Copy1'#7'Caption'#6#4'Copy'#7 + +'OnClick'#7#10'Copy1Click'#0#0#0#9'TMenuItem'#12'UntestedMenu'#7'Caption'#6#8 + +'Untested'#0#9'TMenuItem'#17'MirrorXdimension1'#7'Caption'#6#18'Mirror X-dim' + +'ension'#7'OnClick'#7#22'MirrorXdimension1Click'#0#0#9'TMenuItem'#7'SumTPM1' + +#7'Caption'#6#7'Sum TPM'#7'OnClick'#7#12'SumTPM1Click'#0#0#9'TMenuItem'#17'E' + +'xtractDICOMdims1'#7'Caption'#6#18'Extract DICOM dims'#7'OnClick'#7#22'Extra' + +'ctDICOMdims1Click'#0#0#9'TMenuItem'#16'ExtractDICOMhdr1'#7'Caption'#6#20'Ex' + +'tract DICOM header'#7'OnClick'#7#21'ExtractDICOMhdr1Click'#0#0#9'TMenuItem' + +#17'ExtractNIfTIhdrs1'#7'Caption'#6#20'Extract NIfTI header'#7'OnClick'#7#22 + +'ExtractNIfTIhdrs1Click'#0#0#9'TMenuItem'#10'HalveMenu1'#7'Caption'#6#25'Hal' + +'ve dimensions in-plane'#7'OnClick'#7#15'HalveMenu1Click'#0#0#0#9'TMenuItem' + +#5'Help1'#7'Caption'#6#4'Help'#0#9'TMenuItem'#12'Preferences1'#7'Caption'#6 + +#11'Preferences'#7'OnClick'#7#17'Preferences1Click'#0#0#9'TMenuItem'#6'About' + +'1'#7'Caption'#6#4'Help'#7'OnClick'#7#11'About1Click'#0#0#0#0#22'TSelectDire' + +'ctoryDialog'#22'SelectDirectoryDialog1'#4'left'#3#216#1#0#0#0 +]); diff --git a/dcm2nii/gui.o b/dcm2nii/gui.o new file mode 100644 index 0000000..a0aa6b9 Binary files /dev/null and b/dcm2nii/gui.o differ diff --git a/dcm2nii/gui.pas b/dcm2nii/gui.pas new file mode 100755 index 0000000..ca3681b --- /dev/null +++ b/dcm2nii/gui.pas @@ -0,0 +1,1178 @@ +unit gui; +{$IFDEF FPC}{$mode objfpc}{$H+}{$ENDIF} +interface +uses + +{$IFDEF FPC}LResources,LCLIntf, {$ELSE} Messages,{$ENDIF} +{$IFNDEF UNIX} Windows,ShellAPI,ShlObj, +{$ELSE} +//BaseUnix, +LCLType, +{$ENDIF} +//Messages, +SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, +//ToolWin, +//ComCtrls, +ExtCtrls, nifti_types, +//IniFiles, +define_types,sortdicom,//dicom, +parconvert, +//filename,convert, nifti_hdr,ConvertSimple, +userdir, paramstrs,nii_math,dicomtypes,nii_crop, +nii_orient, nii_4dto3d,nii_asl,nii_reslice, Menus,nii_3dto4d,prefs, +GraphicsMathLibrary; +{$IFDEF FPC} +type + { TMainForm } + TMainForm = class(TForm) + AppleMenu: TMenuItem; + ApplePrefs: TMenuItem; + SelectDirectoryDialog1: TSelectDirectoryDialog;//<-Lazarus only - does not exist in Delphi 4 + Label1: TLabel; + MainMenu1: TMainMenu; + File1: TMenuItem; + Edit1: TMenuItem; + Help1: TMenuItem; + About1: TMenuItem; + Copy1: TMenuItem; + DICOMtoNIfTI1: TMenuItem; + AnonymizeDICOM1: TMenuItem; + Exit1: TMenuItem; + ExtractDICOMdims1: TMenuItem; + ExtractDICOMhdr1: TMenuItem; + ExtractNIfTIhdrs1: TMenuItem; + SumTPM1: TMenuItem; + MirrorXdimension1: TMenuItem; + UntestedMenu: TMenuItem; + NIfTI3D4D1: TMenuItem; + ModifyNIfTI1: TMenuItem; + Preferences1: TMenuItem; + Memo1: TMemo; + OpenHdrDlg: TOpenDialog; + Panel1: TPanel; + TypeCombo: TComboBox; + ResliceNIfTI1: TMenuItem; + Deletenondcm1: TMenuItem; + HalveMenu1: TMenuItem; + procedure SavePrefs; + procedure ExtractDICOMdims1Click(Sender: TObject); + procedure ExtractDICOMhdr1Click(Sender: TObject); + procedure ExtractNIfTIhdrs1Click(Sender: TObject); + procedure FormClose(Sender: TObject; var vAction: TCloseAction); + procedure FormDropFiles(Sender: TObject; const FileNames: array of String); + procedure HalveMenu1Click(Sender: TObject); + function OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean; + procedure CheckPrefs (var lPrefs: TPrefs; lWrite: boolean); + function ConvertDCM2NII (lFilename: string; var lPrefs: TPrefs): boolean; + procedure FormCreate(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure Preferences1Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure SumTPM1Click(Sender: TObject); + procedure TypeComboChange(Sender: TObject); + procedure AnonymizeDICOM1Click(Sender: TObject); + procedure ModifyNIfTI1Click(Sender: TObject); + procedure NIfTI3D4D1Click(Sender: TObject); + procedure ResliceNIfTI1Click(Sender: TObject); + procedure Deletenondcm1Click(Sender: TObject); + procedure dcm2niiBtnClick(Sender: TObject); + procedure MirrorXdimension1Click(Sender: TObject); + function BrowseDialog(const Title: string): string; + end; +{$ELSE} +type + TMainForm = class(TForm) + Label1: TLabel; + MainMenu1: TMainMenu; + File1: TMenuItem; + Edit1: TMenuItem; + Help1: TMenuItem; + About1: TMenuItem; + Copy1: TMenuItem; + DICOMtoNIfTI1: TMenuItem; + AnonymizeDICOM1: TMenuItem; + Exit1: TMenuItem; + ExtractDICOMdims1: TMenuItem; + ExtractDICOMhdr1: TMenuItem; + ExtractNIfTIhdrs1: TMenuItem; + SumTPM1: TMenuItem; + MirrorXdimension1: TMenuItem; + UntestedMenu: TMenuItem; + NIfTI3D4D1: TMenuItem; + ModifyNIfTI1: TMenuItem; + Preferences1: TMenuItem; + Memo1: TMemo; + OpenHdrDlg: TOpenDialog; + Panel1: TPanel; + TypeCombo: TComboBox; + ResliceNIfTI1: TMenuItem; + Deletenondcm1: TMenuItem; + HalveMenu1: TMenuItem; + procedure SavePrefs; + procedure ExtractDICOMdims1Click(Sender: TObject); + procedure ExtractDICOMhdr1Click(Sender: TObject); + procedure ExtractNIfTIhdrs1Click(Sender: TObject); + procedure FormClose(Sender: TObject; var vAction: TCloseAction); + procedure FormDropFiles(Sender: TObject; const FileNames: array of String); + procedure HalveMenu1Click(Sender: TObject); + function OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean; + procedure CheckPrefs (var lPrefs: TPrefs; lWrite: boolean); + function ConvertDCM2NII (lFilename: string; var lPrefs: TPrefs): boolean; + procedure FormCreate(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure Preferences1Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure SumTPM1Click(Sender: TObject); + procedure TypeComboChange(Sender: TObject); + procedure AnonymizeDICOM1Click(Sender: TObject); + procedure ModifyNIfTI1Click(Sender: TObject); + procedure NIfTI3D4D1Click(Sender: TObject); + procedure ResliceNIfTI1Click(Sender: TObject); + procedure Deletenondcm1Click(Sender: TObject); + procedure dcm2niiBtnClick(Sender: TObject); + procedure MirrorXdimension1Click(Sender: TObject); + function BrowseDialog(const Title: string): string; + private + procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES; //<-Delphi only - does not exist in Lazarus + end; +{$ENDIF} +var + MainForm: TMainForm; + +implementation + +uses untar,pref_form, nifti_form,niftiutil{$IFNDEF UNIX},ActiveX {$ENDIF}; +{$IFNDEF FPC} +{$R *.DFM} +{$R windowsxp.res} +{$ENDIF} + +procedure MsgX (lStr: string); +begin + MainForm.Memo1.Lines.Add(lStr); +end; + +function is4D (var lHdr: TNIFTIhdr): boolean; +begin + if lHdr.dim[4] > 1 then + result := true + else + result := false; +end; +function SelectProcessNIFTI (var lHdr: TNIFTIhdr; var lFilename: string): integer; +begin + result := -1; //returns -1 if error + if is4D(lHdr) then begin + NIfTIForm.Combo3D.visible := false; + NIfTIForm.Combo4D.visible := true; + end else begin + //NIfTIForm.Combo3D.itemIndex := 2; + NIfTIForm.Combo3D.visible := true; + NIfTIForm.Combo4D.visible := false; + end; + NiftiForm.Combo4DChange(nil); + NIftiForm.caption := extractfilename(lFilename); + //next - let user specify task + NiftiForm.showmodal; + if (NiftiForm.ModalResult = mrCancel) then + exit; + if is4D(lHdr) then + result := NiftiForm.Combo4D.ItemIndex + else + result := NiftiForm.Combo3D.ItemIndex; +end; + +procedure ProcessNIfTI(lFilenames : TStrings; lPrefs: TPrefs); +var + l4D, lPrev4D, lByteSwap: boolean; + lINc,lProcess: integer; + lExt,lFilename,lOutname: string; + lHdr: TNIFTIhdr; + lO: TNIIOpts; +begin + if lFilenames.Count < 1 then exit; + lPrev4D := false; //ignored in if statement - set only to avoid compiler warning + lProcess := 0; //always set in if statement - set only to avoid compiler warning + for lInc := 1 to lFilenames.Count do begin + lFilename := lFilenames.Strings[lInc-1]; + lExt := UpCaseExt(lFilename); + if lExt ='.IMG' then + lFilename := changefileext(lFilename,'.hdr'); + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lO) then begin + MsgX('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + l4D := is4D(lHdr); + //choose process + //fx( lFilenames.Count,777); + if (lInc = 1) or (l4D <> lPrev4D) then begin + lProcess := SelectProcessNIFTI(lHdr,lFilename); + if lProcess < 0 then exit; + lPrev4D := l4D; + end; + //next - convert image as specified + SetOutputFormat(NIfTIForm.TypeCombo.ItemIndex,lPrefs); + if l4D then begin + case lProcess of + 0: ChangeNIfTISubformat(lFilename,lHdr,lPrefs); + 1: Reorder4D(lFilename, lHdr, lByteSwap,lPrefs); + 2: Clip4D(lFilename, lHdr, false,lPrefs,NiftiForm.StartEdit.value, NiftiForm.EndEdit.value); + 3: Float32NIfTI(lFilename, lPrefs); + 4: FormulaNIfTI(lFilename,lPrefs, NiftiForm.ScaleEdit.value, NiftiForm.PowerEdit.value); + 5: ASL_subtract(lFilename,false,{subtract} (NiftiForm.AsLCombo.itemIndex ),lPrefs); + 6: CropNIfTIX(lFilename, lPrefs, NiftiForm.EndEdit.value, NiftiForm.StartEdit.value, 0,0,0,0 ); + + else showmessage('Unknown function'); + end; //case combo + end else begin //if 4d else 3d + //Int16LogPtoZNIfTI32Z(lFilename, lPrefs); + case lProcess of + 0: ChangeNIfTISubformat(lFilename,lHdr,lPrefs); + 1: Reorient(lFilename,lHdr, lPrefs,false,false); + 2: begin + lOutname := Reorient(lFilename,lHdr, lPrefs,false,false); + if lOutname <> '' then + CropNIfTI(lOutname,lPrefs); + end;//2 + 3: CropNIfTIX(lFilename, lPrefs, NiftiForm.EndEdit.value, NiftiForm.StartEdit.value, 0,0,0,0 ); + 4: SiemensPhase2RadiansNIfTI(lFilename, lPrefs); + else showmessage('Unknown function'); + + end; //case 3d + end; //if 4d else 3d end + end; //for each image +end; + +procedure PromptOutput (var lPrefs: TPrefs); +begin + if (lPrefs.OutDirMode = kOutDirModePrompt) then + lPrefs.OutDir := GetDirPrompt(lPrefs.OutDir); + //GetDirPrompt(lPrefs.OutDir); +end; + +function TMainForm.ConvertDCM2NII (lFilename: string; var lPrefs: TPrefs): boolean; +//returns true if files treated as DICOM or PAR/REC - these will search entire folder +var + lOutDir,lExt: String; + lStartTime: DWord; + lStrings : TStrings; +begin + {$IFDEF FPC} + DefaultFormatSettings.DecimalSeparator := '.'; + {$ELSE} + DecimalSeparator := '.'; + {$ENDIF} + result := false; + if (not Fileexists(lFilename)) and (not DirExists(lFilename)) then + exit; + PromptOutput ( lPrefs); + result := true; + //3/2011... do not clear here, so we can look across images... Memo1.lines.clear; + MsgX(kVers); + refresh; + Memo1.lines.add('Converting '+lFilename); + lOutDir := extractfiledir(lFilename); + lStartTime := GetTickCount; + if DirExists(lFilename) then begin + RecursiveFolderSearch(lFilename,lFilename,lPrefs,0); + lPrefs.NameAppend := ''; + end else begin + lExt := UpCaseExt(lFilename); + {if (lExt = '.FDF') then + ConvertSimple2NII(lFilename,lOutDir,lPrefs) + else} + if (lExt = '.REC') or (lExt = '.PAR') then begin + LoadFileListPARREC(lFilename,lOutDir,lPrefs) + end else if (lExt = '.TGZ') then + DeTGZ(lFilename,lPrefs) + else if (IsNiftiExt (lFilename)) or (IsVOIExt (lFilename)) then begin + result := false; + lStrings := TStringList.Create; + lStrings.add(lFilename); + ProcessNIfTI(lStrings,lPrefs); + lStrings.Free; + end else begin + if (DirExists(lOutDir)) and (not lPrefs.Verbose) then + RecursiveFolderSearch(lOutDir,lOutDir,lPrefs,0) + else + LoadFileList(lFilename,lOutDir,lPrefs); + lPrefs.NameAppend := ''; + end; + end; + Memo1.lines.add('Conversion completed in '+inttostr(GetTickCount-lStartTime)+' ms'); +end; + +function ShowHeader (lFilename: string): boolean; +var + lPrefs: TPrefs; +begin + PrefsForm.ReadPrefs(lPrefs); + lPrefs.verbose := true; + MainForm.Memo1.lines.add('Location '+lFilename); + result := MainForm.ConvertDCM2NII( lFilename,lPrefs); + +end; + +procedure ProcessFilenames(lFilenames : TStrings; lPrefs: TPrefs); +var + i: integer; + lAllNII: boolean; +begin + if lFilenames.Count < 1 then exit; + MainForm.Memo1.lines.clear; + lAllNii := true; + for i := 0 to (lFilenames.Count-1) do + if (not (IsNiftiExt (lFilenames.Strings[i]))) and (not (IsVOIExt (lFilenames.Strings[i]))) then + lAllNii := false; + if lAllNii then begin + ProcessNiFTI (lFilenames,lPrefs); + exit; + end; + if ssCtrl in KeyDataToShiftState(vk_Shift) then begin + for i := 0 to (lFilenames.Count-1) do + ShowHeader (lFilenames.Strings[i]) + end else + MainForm.ConvertDCM2NII( lFilenames.Strings[0],lPrefs); +end; + +{$IFNDEF FPC}//if delphi + +procedure TMainForm.WMDropFiles(var Msg: TWMDropFiles); +var + CFileName: array[0..MAX_PATH] of Char; + + lInc: integer; + lPrefs: TPrefs; + lStrings: TStrings; +begin + CheckPrefs(lPrefs,False); + //lDone := false; + lInc := 0; + try + lStrings := TStringList.Create; + while (DragQueryFile(Msg.Drop, lInc, CFileName, MAX_PATH) > 0) {and (not lDone)} do begin + lStrings.add(CFilename); + + Msg.Result := 0; + inc(lInc); + end; //while + ProcessFilenames(lStrings,lPrefs); + lStrings.Free; + finally + DragFinish(Msg.Drop); + end; +end; + +function TMainForm.BrowseDialog(const Title: string): string; +var + iFlag: integer; + lpItemID : PItemIDList; + BrowseInfo : TBrowseInfo; + DisplayName : array[0..MAX_PATH] of char; + TempPath : array[0..MAX_PATH] of char; +begin + iFlag := BIF_RETURNONLYFSDIRS; + //iFlag := BIF_BROWSEINCLUDEFILES; + //iFlag := BIF_BROWSEFORCOMPUTER; + //iFlag := BIF_BROWSEFORPRINTER; + Result:=''; + FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); + with BrowseInfo do begin + hwndOwner := Application.Handle; + pszDisplayName := @DisplayName; + lpszTitle := PChar(Title); + ulFlags := iFlag; + end; + lpItemID := SHBrowseForFolder(BrowseInfo); + if lpItemId <> nil then begin + SHGetPathFromIDList(lpItemID, TempPath); + Result := TempPath; + GlobalFreePtr(lpItemID); + end; +end; +{$ELSE} +function TMainForm.BrowseDialog(const Title: string): string; +begin + result := ''; + SelectDirectoryDialog1.title := Title; + if not SelectDirectoryDialog1.execute then exit; + result := SelectDirectoryDialog1.Filename; +end; +{$ENDIF} +procedure TMainForm.dcm2niiBtnClick(Sender: TObject); +var + sTitle,lDirName: string; + lPrefs: TPrefs; +begin + CheckPrefs(lPrefs,False); +// {$IFNDEF UNIX} + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); +// {$ELSE} +// if not OpenDialogExecute('Select DICOM images you wish to convert)',true,false,kAnyFilter) then +// exit; +// lDirName := extractfiledir( OpenHdrDlg.Filename); +// {$ENDIF} + ConvertDCM2NII(lDirName,lPrefs); +end; + + + +procedure TMainForm.CheckPrefs (var lPrefs: TPrefs; lWrite: boolean); +begin + if lWrite then begin + //showmessage('w'); + //options if writing + TypeCombo.ItemIndex := DefaultOutputFormat (lPrefs); + + (* if lPrefs.SPM2 then + TypeCombo.ItemIndex := 0 //SPM2 3D hdr/img analyze + else if not lPrefs.FourD then begin + if not (lPrefs.SingleNIIFile) then + TypeCombo.ItemIndex := 1 //SPM5 3D hdr/img + else + TypeCombo.ItemIndex := 2; //SPM8 3D nii + end else if not lPrefs.SingleNIIFile then + TypeCombo.ItemIndex := 3 //?? 4D hdr/img + else if not lPrefs.GZip then + TypeCombo.ItemIndex := 4 //FSL 4D nii + else + TypeCombo.ItemIndex := 5; //FSL 4D nii.gz *) + exit; + end; + SetDefaultPrefs (lPrefs); + PrefsForm.ReadPrefs(lPrefs); + SetOutputFormat(TypeCombo.ItemIndex,lPrefs); + lPrefs.AnonymizeSourceDICOM := false; +end; + +(*procedure Fz; +var + lPrefs: TPrefs; + lByteSwap: boolean; + lExt,lFilename,lOutname,lNameWOExt: string; + lHdr: TNIFTIhdr; +begin + lFilename := 'C:\dti64\rapid\fz3.nii'; + lFilename := 'C:\t1\mx.nii'; + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lByteSwap) then begin + MsgX('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + MainForm.CheckPrefs(lPrefs,False); + Reorient(lFilename, lHdr,lPrefs,false); +end; *) + +(*procedure Fz; +var + lPrefs: TPrefs; + lF: string; +begin + lF := 'C:\iceland\temp'; + SetDefaultPrefs (lPrefs); + lPrefs.AnonymizeSourceDICOM := true; + MainForm.ConvertDCM2NII(lF,lPrefs); +end;*) + +procedure TMainForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + Exit1.visible := false; + {$ENDIF} + {$IFNDEF UNIX}DragAcceptFiles(Handle, True);{$ENDIF} + {$IFDEF FPC} + DefaultFormatSettings.DecimalSeparator := '.'; + {$ELSE} + DecimalSeparator := '.'; + {$ENDIF} + Application.HintHidePause := 30000; + {$IFDEF Darwin} + AppleMenu.Visible := true; + {$IFNDEF LCLgtk} //for Carbon and Cocoa + DICOMtoNIfTI1.ShortCut := ShortCut(Word('D'), [ssMeta]); + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Preferences1.ShortCut := ShortCut(Word('P'), [ssMeta]); + About1.ShortCut := ShortCut(Word('A'), [ssMeta]); + {$ENDIF}//Carbon + {$ENDIF}//Darwin +end; + + + +procedure TMainForm.Exit1Click(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.Copy1Click(Sender: TObject); +begin + Memo1.SelectAll; + Memo1.CopyToClipboard; +end; + +(*procedure testpermissions; +var + p,n,x,s: string; + +begin + s:= '/usr/lib64/lazarus/cr/'; + inputquery('cap','name',s); + FilenameParts (s,p,n,x); + if DirWritePermission(p) then + showmessage('+'+p+'*'+n+'*'+x) + else + showmessage('-'+p+'*'+n+'*'+x); +end; *) + +(*procedure testpermissions; +var + p,n,x,s: string; + +begin + s:= '/usr/lib64/lazarus/test/dcm2niigui.ini'; + if fpAccess (s,R_OK)=0 then //ensure user has read-access to prefs file... + showmessage('dcm = 0'); + s:= '/usr/lib64/lazarus/test/dcx.ini'; + if fpAccess (s,R_OK)=0 then //ensure user has read-access to prefs file... + showmessage('dcx = 0'); + +end; *) +(*procedure Force32; +var + lPrefs: TPrefs; + lI: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + for lI := 1 to 6 do + NII_force32 ('C:\walker\vois\i'+inttostr(lI)+'.nii','C:\walker\vois\ri'+inttostr(lI)+'.nii',lPrefs); +end;*) + +(*procedure Force32; +var + lPrefs: TPrefs; +begin + PrefsForm.ReadPrefs(lPrefs); + Rescale_4Dtissuemaps ('C:\walker\vois\4Dsri1.nii','C:\walker\vois\TPMQ.nii',lPrefs); +end;*) + +(*procedure Force32; +var + lPrefs: TPrefs; +const + kDir = 'C:\walker\i3\'; + kTemp = kDir + 'TPM3.nii'; + kTempSym = kDir + 'TPM3sym.nii'; +begin +//exit; + PrefsForm.ReadPrefs(lPrefs); + //scale_4Dtissuemaps ('C:\walker\vois\4Dsri1.nii','C:\walker\TPMLo.nii',lPrefs); + //rge4DFiles ('C:\walker\TPMLo.nii','C:\walker\TPMHi.nii','C:\walker\TPMEX.nii',78,lPrefs); + Insert3Din4D (kDir+'m1.nii.gz',kTemp,kTemp,1, lPrefs); + Insert3Din4D (kDir+'m2.nii.gz',kTemp,kTemp,2, lPrefs); + Insert3Din4D (kDir+'m3.nii.gz',kTemp,kTemp,3, lPrefs); + Insert3Din4D (kDir+'m4.nii.gz',kTemp,kTemp,4, lPrefs); + Insert3Din4D (kDir+'m5.nii.gz',kTemp,kTemp,5, lPrefs); + Insert3Din4D (kDir+'m6.nii.gz',kTemp,kTemp,6, lPrefs); + Rescale_4Dtissuemaps(kTemp,kTempSym,lPrefs,true); +end; *) + +(*procedure Force32; +var + lPrefs: TPrefs; +const + kDir = 'C:\walker\i4\'; + kTemp = kDir + 'TPM4.nii'; + kTempSym = kDir + 'TPM4sym.nii'; +begin +//exit; + PrefsForm.ReadPrefs(lPrefs); + //scale_4Dtissuemaps ('C:\walker\vois\4Dsri1.nii','C:\walker\TPMLo.nii',lPrefs); + //rge4DFiles ('C:\walker\TPMLo.nii','C:\walker\TPMHi.nii','C:\walker\TPMEX.nii',78,lPrefs); + Insert3Din4D (kDir+'sm1.nii',kTemp,kTemp,1, lPrefs); + Insert3Din4D (kDir+'sm2.nii',kTemp,kTemp,2, lPrefs); + Insert3Din4D (kDir+'sm3.nii',kTemp,kTemp,3, lPrefs); + Insert3Din4D (kDir+'sm4.nii',kTemp,kTemp,4, lPrefs); + Insert3Din4D (kDir+'sm5.nii',kTemp,kTemp,5, lPrefs); + Insert3Din4D (kDir+'sm6.nii',kTemp,kTemp,6, lPrefs); + Rescale_4Dtissuemaps(kTemp,kTempSym,lPrefs,true); +end; *) +(*procedure Force32; +var + lPrefs: TPrefs; + lMaskName: string; + lHdr: TNIfTIHdr; + lByteSwap, lSaveThresh3D: boolean; + lV: integer; +begin +//exit; + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select the mask image',false,false,kImgFilter) then + exit; + lMaskName := MainForm.OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr (lMaskName, lHdr, lByteSwap) then + exit; + if (lHdr.Dim[4] < 1) then + exit; + lSaveThresh3D := (MessageDlg('Save thresholded images for each individual?',mtCustom,[mbYes,mbNo], 0)=mrYes); + + for lV := 1 to lHdr.Dim[4] do + if MainForm.OpenDialogExecute('Select NIfTI images you wish to mask with volume '+inttostr(lV),true,false,kImgFilter) then + MaskImages(lMaskName, MainForm.OpenHdrDlg.Files,lPrefs,lV, lSaveThresh3D); +end; *) + +(*procedure Force32; +var + lPrefs: TPrefs; + lI: integer; + //lMaskName: string; +begin +//exit; + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select all the c1 (gray matter) images to binarize. The c2 (gray matter),c3,c4,c5,c6 images should be in th same folder.',true,false,kImgFilter) then + exit; + //lMaskName := ('C:\Documents and Settings\chris\Desktop\walkerseg\zero\wc120100128_102305t1saghiress002a1001.nii'); + //Binarize(lMaskName,lPrefs); + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + Binarize(MainForm.OpenHdrDlg.Files[lI],lPrefs); +end; *) + +{$IFNDEF FPC} +procedure MaskVBM; +var + lPrefs: TPrefs; + lI: integer; + lMaskName: string; +begin + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select all TEMPLATE c1 (gray matter) image.',false,false,kImgFilter) then + exit; + lMaskName := MainForm.OpenHdrDlg.Filename; + if not MainForm.OpenDialogExecute('Select all the c1 (gray matter) images to binarize. The c2 (gray matter),c3,c4,c5,c6 images should be in th same folder.',true,false,kImgFilter) then + exit; + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + MaskImgs(lMaskName, MainForm.OpenHdrDlg.Files[lI],lPrefs, 0.02); +end; +{$ENDIF} +{$IFNDEF FPC} +procedure Mask; +var + lPrefs: TPrefs; + lMaskName: string; + lHdr: TNIfTIHdr; + lO: TNIIOpts; + lI,lV: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select the mask image',false,false,kImgFilter) then + exit; + lMaskName := MainForm.OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr (lMaskName, lHdr, lO) then + exit; + lV := 1; + //lSaveThresh3D := (MessageDlg('Save thresholded images for each individual?',mtCustom,[mbYes,mbNo], 0)=mrYes); + //for lV := 1 to lHdr.Dim[4] do + if not MainForm.OpenDialogExecute('Select NIfTI images you wish to mask with volume '+inttostr(lV),true,false,kImgFilter) then + exit; + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + MaskImg(lMaskName, MainForm.OpenHdrDlg.Files[lI], lPrefs, 1); +end; +{$ENDIF} + + +function ExtNIIorIMG(lStr: string): boolean; +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.NII') or (lExt = '.NII.GZ') then + result := true; + if (lExt = '.IMG') {and (FSize(ChangeFileExt(lStr,'.hdr'))> 0)} then + result := true; +end; + +procedure NIIbatch (lDir,lS: string); +begin + with mainform.Memo1.lines do begin + add('subjx = strvcat'+lS+';'); + add('subj = cellstr(subjx);'); + add('dir = '''+lDir+''';'); + add('tic'); + add('for i=1:length(subj)'); + add(' filename = [dir,filesep,subj{i}];'); + add(' nii_16bit(filename);'); + add('end;'); + add('toc'); + end;//with +end;//proc NIIbatch +procedure NII2Mat; +var + str,pre,sTitle,lDirName: string; + lSearchRec: TSearchRec; +begin + {$IFNDEF FPC} + sTitle:='Choose a folder with DICOM images'; + lDirName := MainForm.BrowseDialog(sTitle); + {$ELSE} + if not MainForm.OpenDialogExecute('Select DICOM images you wish to inspect)',true,false,kAnyFilter) then + exit; + lDirName := extractfiledir( MainForm.OpenHdrDlg.Filename); + {$ENDIF} + str := '('; + pre := ''; + +{$IFDEF UNIX} + if FindFirst(lDirName+pathdelim+'*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lDirName+pathdelim+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + //lFilename := ''; + repeat + //lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name = '.') or (lSearchRec.Name = '..') then begin + // + end else if (lSearchRec.Name <> '') and (ExtNIIorIMG(lSearchRec.Name)) and (not DirExists(lSearchRec.Name)) then begin + str := str +pre+ ''''+extractfilename(lSearchRec.Name)+''''; + pre:=',' + end; + //mainform.Memo1.lines.add(lSearchRec.Name); + until (FindNext(lSearchRec) <> 0); + + end; + FindClose(lSearchRec); + str := str + ')'; + if length(str) > 2 then + NIIbatch (lDirName,str)//mainform.Memo1.lines.add(str) + else + mainform.Memo1.lines.add('No NIfTI images found in '+lDirName) + +end; + +(*procedure NII2Mat(lExt: string); +var + str,pre,sTitle,lDirName: string; + lSearchRec: TSearchRec; +begin + {$IFNDEF FPC} + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + {$ELSE} + if not OpenDialogExecute('Select DICOM images you wish to inspect)',true,false,kAnyFilter) then + exit; + lDirName := extractfiledir( OpenHdrDlg.Filename); + {$ENDIF} + str := '('; + pre := ''; + +{$IFDEF UNIX} + if FindFirst(lDirName+pathdelim+'*.img',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lDirName+pathdelim+'*.img',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + //lFilename := ''; + repeat + //lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name = '.') or (lSearchRec.Name = '..') then begin + // + end else if (lSearchRec.Name <> '') and (not DirExists(lSearchRec.Name)) then begin + str := str +pre+ ''''+extractfilename(lSearchRec.Name)+''''; + pre:=',' + end; + //mainform.Memo1.lines.add(lSearchRec.Name); + until (FindNext(lSearchRec) <> 0); + + end; + FindClose(lSearchRec); + str := str + ')'; + mainform.Memo1.lines.add(str); +end; *) + + +(*procedure BenchMarkDicom; +var + lC: Integer; + lS: TDateTime; + var lDICOMdata: DICOMdata; + lHdrOK, lImageFormatOK: boolean; + lDynStr: string;var lFileName: string; + var lPrefs: TPrefs ; +begin + SetDefaultPrefs (lPrefs); +lS := Now; +lFilename := '/Users/rorden/philips/T1_IM_0007'; +for lC := 1 to 100 do + read_dicom_data(true,false,false,false,false,false,false, lDICOMdata, lHdrOK, lImageFormatOK, lDynStr, lFileName, lPrefs); +Showmessage('Milliseconds elapsed '+ FormatDateTime('z', Now-lS) ); +end; *) + +procedure TMainForm.About1Click(Sender: TObject); +//var value: int64; +begin +//fx(VBversion('MR B13 4VB13A')); exit; +//NII2Mat;exit; + //BenchMarkDicom; +{$IFNDEF FPC} + if (ssCtrl in KeyDataToShiftState(vk_Shift)) then begin + Mask; + exit; + end; + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + MaskVBM; + exit; + end; +{$ENDIF} + //force32; + //showmessage(ExtractFileDirWithPathDelim('c:\pas')); + + //testpermissions; + Showmessage(kVers+ kCR+'Fallback ini file: '+ changefileext(paramstr(0),'.ini')); +end; + +procedure TMainForm.Preferences1Click(Sender: TObject); +var + lPrefs: TPrefs; +begin + PrefsForm.ReadPrefs(lPrefs); + PrefsForm.Showmodal; + if (PrefsForm.ModalResult = mrCancel) then + PrefsForm.WritePrefs(lPrefs); +end; + +(*procedure ShowDICOM (var lPrefs: TPrefs); +var +lDICOMdata: DICOMdata; +lHdrOK,lImgOK: boolean; +lDynStr,lFilename: string; + +begin + lFilename := 'c:\i185386.MRDC.94'; + read_dicom_data(true,true{not verbose},true,true,true,true,false, lDICOMdata, lHdrOK, lImgOK, lDynStr,lFileName,lPrefs ); + msgX(lDynStr); +end;*) +procedure TMainForm.FormShow(Sender: TObject); +var + lPrefs: TPrefs; + lIniName: string; +begin + MsgX(kVers); + + SetDefaultPrefs(lPrefs); + lIniName := IniName;//changefileext(paramstr(0),'.ini'); + //showmessage(changefileext(paramstr(0),'.ini')); + (*lReadPrefs := true; + if (ssShift in KeyDataToShiftState(vk_Shift)) then + case MessageDlg('Shift key down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrYes: lReadPrefs := false; + end; //case *) + if not ResetDefaults {lReadPrefs} then begin + {$IFNDEF UNIX} + if (ParamCount > 0) then + ProcessParamStrs + else if fileexists (lIniName) then + IniFile(True,lIniName, lPrefs) + else + IniFile(True,changefileext(paramstr(0),'.ini'), lPrefs); //this allows an administrator to create default startup + //IniFile(True,lIniName, lPrefs); + {$ELSE} + if fileexists (lIniName) then + IniFile(True,lIniName, lPrefs) + else + IniFile(True,changefileext(paramstr(0),'.ini'), lPrefs); //this allows an administrator to create default startup + {$ENDIF} + end; //lReadPrefs + CheckPrefs(lPrefs,True); + PrefsForm.WritePrefs(lPrefs); + NIfTIForm.TypeCombo.ItemIndex := TypeCombo.ItemIndex; + UntestedMenu.visible := lPrefs.UntestedFeatures; + //ConvertDCM2NII('c:\b17\b17\b17.IMA',lPrefs); +end; + + + +procedure TMainForm.TypeComboChange(Sender: TObject); +begin + NIfTIForm.TypeCombo.ItemIndex := TypeCombo.ItemIndex; +end; + +procedure TMainForm.AnonymizeDICOM1Click(Sender: TObject); +var + sTitle,lDirName: string; + lPrefs: TPrefs; +begin + CheckPrefs(lPrefs,False); + lPrefs.AnonymizeSourceDICOM := true; + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + ConvertDCM2NII(lDirName,lPrefs); +end; + +function TMainForm.OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; +var + lNumberofFiles: integer; +begin + OpenHdrDlg.Filter := lFilter;//kAnaHdrFilter;//lFilter; + OpenHdrDlg.FilterIndex := 1; + OpenHdrDlg.Title := lCaption; + if lAllowMultiSelect then + OpenHdrDlg.Options := [ofAllowMultiSelect,ofFileMustExist] + else + OpenHdrDlg.Options := [ofFileMustExist]; + result := OpenHdrDlg.Execute; + if not result then exit; + if lForceMultiSelect then begin + lNumberofFiles:= OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + result := false; + end; + end; +end; + +procedure TMainForm.SavePrefs; +var + lPrefs: TPrefs; + lIniName: string; +begin + lIniName := IniName;//changefileext(paramstr(0),'.ini'); + CheckPrefs(lPrefs,False); + if lPrefs.WritePrefsOnQuit then + IniFile(False,lIniName, lPrefs); +end; + +procedure TMainForm.FormClose(Sender: TObject; var vAction: TCloseAction); +begin + SavePrefs; +end; + + +procedure TMainForm.FormDropFiles(Sender: TObject; + const FileNames: array of String); +var + lI,lN: integer; + lPrefs: TPrefs; + lStrings: TStrings;//lFilename: string; +begin + //lDone := false; + CheckPrefs(lPrefs,False); + lN := length(FileNames); + if lN < 1 then + exit; + lStrings := TStringList.Create; + for lI := 0 to (lN-1) do + lStrings.add(Filenames[lI]); + ProcessFilenames(lStrings,lPrefs); + lStrings.Free; + +end; + +procedure TMainForm.HalveMenu1Click(Sender: TObject); +var + lPrefs: TPrefs; + lI: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select image(s) you wish to LR flip',true,false,kImgFilter) then + exit; + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + ShrinkNII(MainForm.OpenHdrDlg.Files[lI], lPrefs); +end; + +procedure TMainForm.ModifyNIfTI1Click(Sender: TObject); +var + lPrefs: TPrefs; +begin + if not OpenDialogExecute('Select NIfTI images you wish to modify)',true,false,kImgFilter) then + exit; + CheckPrefs(lPrefs,False); + ProcessNIfTI(OpenHdrDlg.Files,lPrefs); +end; //ModifyNIfTI1Click + +procedure TMainForm.NIfTI3D4D1Click(Sender: TObject); +var lStrings: TStringList; + lPrefs: TPrefs; +begin + if not OpenDialogExecute('Select the 3D NIfTI images you wish to stack)',true,false,kImgFilter) then + exit; + lStrings := TStringList.Create; + lStrings.addstrings(OpenHdrDlg.Files); + CheckPrefs(lPrefs,False); + Stack3Dto4D(lStrings, False, lPrefs); + lStrings.Free; +end; + +procedure TMainForm.ResliceNIfTI1Click(Sender: TObject); +var + lDestName,lSourceName,lTargetName: string; + lPos: integer; + lPrefs: TPrefs; +begin + CheckPrefs(lPrefs,False); + Memo1.lines.clear; + refresh; + MsgX(kVers); + MsgX('This function reslices source images to match the dimensions of a target image.'); + MsgX(' Images are assumed to be coregistered.'); + MsgX(' The resulting images will have the orientation, voxel size and bounding box of the target image.'); + MsgX(' Resliced images will be given the prefix ''r''.'); + MsgX(' This function uses trilinear interpolation - there may be some loss of precision.'); + if not OpenDialogExecute('Select target image',true,false,kImgFilter) then + exit; + lTargetName := OpenHdrDlg.Filename; + if not OpenDialogExecute('Select images you wish to reslice to match target)',true,false,kImgFilter) then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lSourceName := OpenHdrDlg.Files[lPos-1]; + lDestName := ChangeFilePrefix (lSourceName,'r'); + MsgX('Reslicing '+lSourceName +' to match dimensions of '+lTargetname+' resliced image = '+lDestName); + Reslice2Targ (lSourceName,lTargetName,lDestName, lPrefs ); + + end; + +end; + + +procedure DelRecursiveFolderSearch (lFolderName: string; lMaxDepth, lDepth: integer); +var + lNewDir,lNewName,lFilename,lExt: String; + lSearchRec: TSearchRec; +begin + lNewDir := lFolderName+PathDelim; +{$IFDEF UNIX} + if FindFirst(lNewDir+'*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + lFilename := ''; + repeat + lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then begin + if DirExists(lNewName) then begin + if lDepth < lMaxDepth then begin + DelRecursiveFolderSearch(lNewName,lMaxDepth,lDepth+1); + end; + //exit;//4/4/2008 + end else + lFilename := lNewname; + end; + if (lFilename <> '') and (not DirExists(lNewName)) then begin + lExt := UpCaseExt(lFilename); + if (lExt <> '.DCM') then begin + msgx('del '+lFilename); + DeleteFile(lFilename); + end; + end; + until (FindNext(lSearchRec) <> 0); + + end; + FindClose(lSearchRec); +end; + + +procedure TMainForm.Deletenondcm1Click(Sender: TObject); +var + sTitle,lDirName: string; +begin + Showmessage('Warning: this command will delete all files that do not have the extension .dcm') ; + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + DelRecursiveFolderSearch(lDirName,32,1); +end; + +procedure TMainForm.MirrorXdimension1Click(Sender: TObject); +//UntestedFeatures +var + lPrefs: TPrefs; + lI: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + if not MainForm.OpenDialogExecute('Select image(s) you wish to LR flip',true,false,kImgFilter) then + exit; + if MainForm.OpenHdrDlg.Files.count < 1 then exit; + for lI := 0 to (MainForm.OpenHdrDlg.Files.count-1) do + LRFlip(MainForm.OpenHdrDlg.Files[lI], lPrefs); +end; + +procedure TMainForm.SumTPM1Click(Sender: TObject); +var + lPrefs: TPrefs; + lI: integer; +begin + PrefsForm.ReadPrefs(lPrefs); + if not OpenDialogExecute('Select TPM to sum)',true,false,kAnyFilter) then + exit; + for lI := 1 to 5 do + SumTPM(OpenHdrDlg.Filename,ChangeFilePrefix (OpenHdrDlg.Filename,'sum'+inttostr(lI)) ,lPrefs,lI); +end; + + +procedure TMainForm.ExtractDICOMdims1Click(Sender: TObject); +var + {$IFNDEF FPC}sTitle,{$ENDIF} + lDirName: string; + lPrefs: TPrefs; +begin + CheckPrefs(lPrefs,False); + lPrefs.DebugMode2 := true; + {$IFNDEF FPC} + sTitle:='Choose a folder with DICOM images'; + lDirName := BrowseDialog(sTitle); + {$ELSE} + if not OpenDialogExecute('Select DICOM images you wish to inspect)',true,false,kAnyFilter) then + exit; + lDirName := extractfiledir( OpenHdrDlg.Filename); + {$ENDIF} + Memo1.lines.Clear; + ConvertDCM2NII(lDirName,lPrefs); +end; + +procedure TMainForm.ExtractDICOMhdr1Click(Sender: TObject); +var + lnVol,lVol: integer; + //lHdrName: string; +begin + if not OpenDialogExecute('Select the 3D NIfTI images to inspect)',true,false,kAnyFilter) then + exit; + lnVol := OpenHdrDlg.Files.count; + Memo1.lines.clear; + for lVol := 1 to lnVol do + ShowHeader (OpenHdrDlg.Files[lVol-1]); +end; + +procedure TMainForm.ExtractNIfTIhdrs1Click(Sender: TObject); +var + lStrings: TStringList; +begin + if not OpenDialogExecute('Select the 3D NIfTI images to inspect)',true,false,kImgFilter) then + exit; + Memo1.lines.clear; + lStrings := TStringList.Create; + lStrings.addstrings(OpenHdrDlg.Files); + ExtractNIFTIHdrs(lStrings); + lStrings.Free; +end; + +{$IFDEF UNIX} +initialization + {$I gui.lrs} +{$ELSE} //not unix: windows +initialization +{$IFDEF FPC} + {$I gui.lrs} + {$ENDIF} + OleInitialize(nil); + +finalization + OleUninitialize +{$ENDIF} +end. + + diff --git a/dcm2nii/gui.ppu b/dcm2nii/gui.ppu new file mode 100644 index 0000000..22494a7 Binary files /dev/null and b/dcm2nii/gui.ppu differ diff --git a/dcm2nii/guii.lrs b/dcm2nii/guii.lrs new file mode 100755 index 0000000..9d2eb5f --- /dev/null +++ b/dcm2nii/guii.lrs @@ -0,0 +1,36 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TMainForm','FORMDATA',[ + 'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3'#'#1#6'Height'#3','#1#3'Top'#3#149#0 + +#5'Width'#3#144#1#18'HorzScrollBar.Page'#3#143#1#18'VertScrollBar.Page'#3#24 + +#1#13'ActiveControl'#7#5'Memo1'#7'Caption'#6#7'dcm2nii'#4'Menu'#7#9'MainMenu' + +'1'#6'OnShow'#7#8'FormShow'#0#8'TToolBar'#8'ToolBar1'#6'Height'#2#26#5'Width' + +#3#144#1#7'Caption'#6#8'ToolBar1'#11'EdgeBorders'#11#0#8'TabOrder'#2#0#0#6'T' + +'Label'#6'Label1'#4'Left'#2#1#6'Height'#2#14#5'Width'#2'O'#9'Alignment'#7#8 + +'taCenter'#7'Caption'#6#15'Output Format: '#5'Color'#7#6'clNone'#11'ParentCo' + +'lor'#8#0#0#9'TComboBox'#9'TypeCombo'#4'Left'#2'P'#6'Height'#2#22#5'Width'#2 + +'d'#16'AutoCompleteText'#11#22'cbactEndOfLineComplete'#20'cbactSearchAscendi' + +'ng'#0#13'Items.Strings'#1#6#24'SPM2 (3D Anlyze hdr/img)'#6#23'SPM5 (3D NIfT' + +'I hdr/img)'#6#16'4D NIfTI hdr/img'#6#18'FSL (4D NIfTI nii)'#6#29'Compressed' + +' FSL (4D NIfTI nii)'#0#9'MaxLength'#2#0#5'Style'#7#14'csDropDownList'#8'Tab' + +'Order'#2#0#0#0#0#5'TMemo'#5'Memo1'#6'Height'#3#255#0#3'Top'#2#26#5'Width'#3 + +#144#1#5'Align'#7#8'alClient'#13'Lines.Strings'#1#6#0#0#8'TabOrder'#2#1#0#0#9 + +'TMainMenu'#9'MainMenu1'#4'left'#2'G'#3'top'#2'<'#0#9'TMenuItem'#8'FileMenu' + +#7'Caption'#6#4'File'#7'OnClick'#7#13'FileMenuClick'#0#9'TMenuItem'#12'Modif' + +'yNifti1'#7'Caption'#6#12'Modify NIfTI'#7'OnClick'#7#17'ModifyNifti1Click'#0 + +#0#9'TMenuItem'#9'MenuItem7'#7'Caption'#6#14'DICOM to NIfTI'#7'OnClick'#7#15 + +'dcm2niiBtnClick'#0#0#9'TMenuItem'#15'AnonymizeDICOM1'#7'Caption'#6#15'Anony' + +'mize DICOM'#7'OnClick'#7#20'AnonymizeDICOM1Click'#0#0#9'TMenuItem'#5'Exit1' + +#7'Caption'#6#4'Exit'#7'OnClick'#7#10'Exit1Click'#0#0#0#9'TMenuItem'#9'MenuI' + +'tem5'#7'Caption'#6#8'EditMenu'#0#9'TMenuItem'#9'MenuItem6'#7'Caption'#6#4'C' + +'opy'#0#0#0#9'TMenuItem'#9'MenuItem2'#7'Caption'#6#4'Edit'#7'OnClick'#7#14'M' + +'enuItem2Click'#0#9'TMenuItem'#5'Copy1'#7'Caption'#6#4'Copy'#8'ShortCut'#3'C' + +'@'#7'OnClick'#7#10'Copy1Click'#0#0#0#9'TMenuItem'#9'MenuItem1'#7'Caption'#6 + +#4'Help'#7'OnClick'#7#14'MenuItem1Click'#0#9'TMenuItem'#9'MenuItem3'#7'Capti' + +'on'#6#11'Preferences'#7'OnClick'#7#17'Preferences1Click'#0#0#9'TMenuItem'#9 + +'MenuItem4'#7'Caption'#6#5'About'#7'OnClick'#7#11'About1Click'#0#0#0#0#22'TS' + +'electDirectoryDialog'#9'DirSelect'#5'Title'#6#16'Select Directory'#11'Filte' + +'rIndex'#2#0#4'left'#2'G'#3'top'#2'`'#0#0#11'TOpenDialog'#10'OpenHdrDlg'#5'T' + +'itle'#6#18'Open existing file'#11'FilterIndex'#2#0#4'left'#2'H'#3'top'#3#128 + +#0#0#0#0 +]); diff --git a/dcm2nii/lsjpeg.o b/dcm2nii/lsjpeg.o new file mode 100644 index 0000000..8a67b55 Binary files /dev/null and b/dcm2nii/lsjpeg.o differ diff --git a/dcm2nii/lsjpeg.pas b/dcm2nii/lsjpeg.pas new file mode 100755 index 0000000..4ec1c1d --- /dev/null +++ b/dcm2nii/lsjpeg.pas @@ -0,0 +1,777 @@ +unit lsjpeg; +{*$DEFINE Stream} +//rev13: changes by CR and JGS +//rev19: uses Lookup table for decoding Huffman table: this doubles the speed +//rev26: fixed memory leak: FreeMem(lRawRA) +interface +{$IFDEF FPC} {$mode delphi}{$H+} {$ENDIF} + +uses +dialogsx,dialogs_msg, + sysutils,define_types,classes; +type + HufRA = record + HufSz,HufCode,HufVal: Integer; + end; +{$IFDEF Stream} + procedure DecodeJPEG(var lStream: TMemoryStream; var lOutSmallRA: SmallIntP0; var lImgRAz: ByteP0;lOutputSz,lCptPosition,lCptSize: integer; lVerbose: boolean); +{$ELSE} + procedure DecodeJPEG(var infp: file; var lOutSmallRA: SmallIntP0; var lImgRAz: ByteP0;lOutputSz,lCptPosition,lCptSize: integer; lVerbose: boolean); +{$ENDIF} +implementation + +{$IFDEF Stream} + procedure DecodeJPEG(var lStream: TMemoryStream; var lOutSmallRA: SmallIntP0; var lImgRAz: ByteP0;lOutputSz,lCptPosition,lCptSize: integer; lVerbose: boolean); +{$ELSE} +procedure DecodeJPEG(var infp: file; var lOutSmallRA: SmallIntP0; var lImgRAz: ByteP0;lOutputSz,lCptPosition,lCptSize: integer; lVerbose: boolean); +{$ENDIF} +const + kmaxFrames = 4; +label + 666 {EOF}, 123 {Freemem}; + var + lRawRA: bytep; + lImgRA: WordP; + lHufVal,lAbba,lOffset,lLineStart,lPredicted,lPredictedG,lPredictedB,lRestartSegmentSz, + lSz,k,Code,Si,lIncX,lIncY,lInc,lPredA,lPredB,lPredC,lCurrentBitPos,btS1,btS2, btMarkerType, + DHTnLi,DHTtcth,SOFprecision,SOSpttrans, SOFnf,SOFarrayPos,SOSns,SOSarrayPos,SOSss,SOSse,SOSahal:integer;//byte; + lHufTable,lnHufTables,{lDecode,}lImgStart,lRawSz,lRawPos,lItems,SOFydim, SOFxdim: integer; + lMaxHufSi,lMaxHufVal: array [1..kmaxFrames] of integer; + DHTLiRA,DHTstartRA: array [1..kmaxFrames,0..31] of integer;//byte; + lBitMask: array [1..17] of integer; + lSSSSszRA: array [1..kMaxFrames,0..17] of byte; + lLookUpRA: array [1..kMaxFrames,0..255] of byte; //lists all possible SSSS with <= 8bits + lHufRA: array [1..kMaxFrames,0..31] of HufRA; + lFrameCount,lSegmentLength,lSegmentEnd,lI: integer; + lImgTypeC3,lHdrOK: boolean; +function ReadBit: integer; //Read the next single bit +begin + result := (lRawRA[lRawPos] shr (7-lCurrentBitPos)) and 1; + lCurrentBitPos := lCurrentBitPos + 1; + if (lCurrentBitPos = 8) then begin + lRawPos := 1+lRawPos; + lCurrentBitPos := 0; + end; +end; //nested proc ReadBit + +(* +START Disabled Procedures +// These functions are not used: these routines have been inlined (following VTune profiling) +// but they are useful utilities if you want to explore Huffman Tables +function ReadBits2_9 ( lNum: integer): integer; //lNum: bits to read, not to exceed 9 +//wo Advance: does not increment the Byte/Bit position. Use AdvanceBitPos to do this +begin + result := lRawRA[lRawPos]; + result := result shl 8 + lRawRA[lRawPos+1]; + //result := result shl 8 + lRawRA[lRawPos+2]; + result := (result shr (16-lCurrentBitPos-lNum)) and lBitMask[lNum]; //lCurrentBitPos is incremented from 1, so -1 + lCurrentBitPos := lCurrentBitPos + lNum; + if (lCurrentBitPos > 7) then begin + lRawPos := lRawPos+(lCurrentBitPos shr 3{div 8}); + lCurrentBitPos := (lCurrentBitPos and 7{mod 8}); + end; +end; +procedure RetractBitPos(lNum: integer); +begin + lCurrentBitPos := lCurrentBitPos - lNum; + while (lCurrentBitPos < 0) do begin + lRawPos := lRawPos - 1; + lCurrentBitPos := lCurrentBitPos + 8; + end; +end; +procedure AdvanceBitPos(lNum: integer); +//Advances Bit/Byte counters +begin + lCurrentBitPos := lCurrentBitPos + lNum; + if (lCurrentBitPos > 7) then begin + lRawPos := lRawPos+(lCurrentBitPos shr 3{div 8}); + lCurrentBitPos := (lCurrentBitPos and 7{mod 8}); + end; +end; +END Disabled Procedures*) + +function ReadBits ( lNum: integer): integer; //lNum: bits to read, not to exceed 16 +begin + result := lRawRA[lRawPos]; + result := result shl 8 + lRawRA[lRawPos+1]; + result := result shl 8 + lRawRA[lRawPos+2]; + result := (result shr (24-lCurrentBitPos-lNum)) and lBitMask[lNum]; //lCurrentBitPos is incremented from 1, so -1 + lCurrentBitPos := lCurrentBitPos + lNum; + if (lCurrentBitPos > 7) then begin + lRawPos := lRawPos+(lCurrentBitPos shr 3{div 8}); + lCurrentBitPos := (lCurrentBitPos and 7{mod 8}); + end; +end; //nested proc ReadBits + +function DecodePixelDifference( lFrame: integer): integer;//Red/Green/Blue each a separate 'Frame': can have unique huffman tables +var + lByte,lHufValSSSS,lInput,lInputbits,lDiff,lI: integer; +begin + // read one byte from the stream, without modifying the pointer + lByte := (lRawRA[lRawPos] shl lCurrentBitPos) + (lRawRA[lRawPos+1] shr (8-lCurrentBitPos)); + lByte := lByte and 255; + lHufValSSSS := lLookUpRA[lFrame,lByte]; + //lLookUpRA: array [1..kMaxFrames,0..255] of byte; //lists all possible SSSS with <= 8bits + if lHufValSSSS < 255 then begin + lCurrentBitPos := lSSSSszRA[lFrame,lHufValSSSS] + lCurrentBitPos; + lRawPos := lRawPos + (lCurrentBitpos shr 3); + lCurrentBitpos := lCurrentBitpos and 7; + //AdvanceBitPos(lSSSSszRA[lFrame,lSSSS]), but inlined; + end else begin //full SSSS is not in the first 8-bits + //if (lByte < 0) or (lByte > 255) then showmessage('yikes: this is impossible'); + lInput := lByte; + lInputBits := 8; + inc(lRawPos); // forward 8 bits = precisely 1 byte + repeat + Inc(lInputBits); + lInput := lInput shl 1 + ReadBit; + if DHTLiRA[lFrame,lInputBits] <> 0 then begin //if any entires with this length + for lI := DHTstartRA[lFrame,lInputBits] to (DHTstartRA[lFrame,lInputBits]+DHTLiRA[lFrame,lInputBits]-1) do begin + if (lInput = lHufRA[lFrame,lI].HufCode) then + lHufValSSSS := lHufRA[lFrame,lI].HufVal; + end; //check each code + end; //if any entires with this length + if (lInputBits >= lMaxHufSi[lFrame]) and (lHufValSSSS > 254) then begin//exhausted options CR: added rev13 + lHufValSSSS := lMaxHufVal[lFrame]; + end; + until (lHufValSSSS < 255){found}; + end; //answer in first 8 bits + //The HufVal is referred to as the SSSS in the Codec, so it is called 'lHufValSSSS' + case lHufValSSSS of + 0: result:= 0; + 1: if ReadBit = 0 then result := -1 else result := 1; + (*BELOW only a tiny bit faster to separate 2..15 into 2..9 and 10..15, requires extra procedure and more + 2..9: begin //see 10..15 for explanation + lDiff := ReadBits2_9(lHufValSSSS); + if (lDiff > (lBitMask[lHufValSSSS-1])) then //add + result := lDiff + else //negation + result := lDiff - lBitMask[lHufValSSSS]; + end; //2..9 *) + 2..15: begin + //Osiris includes extra bits after SSSS=16...a violation of the standard See "TABLE H.2 - Difference categories for lossless Huffman coding" of the codec ITU-T81 + //According to the Codec H.1.2.2 "No extra bits are appended after SSSS = 16 is encoded." + //To patch for Osiris Change case from 2..15 to 2..16 + // This will work for Osiris images, but will break non-Osiris images + lDiff := ReadBits(lHufValSSSS); + if (lDiff > (lBitMask[lHufValSSSS-1])) then //add + result := lDiff + // this is slightly unintuitive: the positive bit is identical to the offset shown in TABLE H.2, a slower but more intuitive way to do this is: + //result := (lDiff and lBitMask[lHufVal-1]) + (1 shl (lHufval-1)); + //where you clip off the sign bit and then SHL appropriately + else //negation + result := lDiff - lBitMask[lHufValSSSS]; + //NEXT to lines are a bit more intuitive: + {lDiff := lBitMask[lHufVal-1]- lDiff; + result := -(lDiff + (1 shl (lHufval-1)));}//negation + end; //10..15 + else {16, not osiris} + result := 32768; + end; //case HuffVal +end; //nested proc DecodePixelDifference + +procedure ReadByte(var lByte: integer); +begin + inc(lRawPos); + lByte := lRawRA[lRawPos]; +end; //nested proc ReadByte + +function ReadWord: word; +var + lbtL1, lbtL2: byte; +begin + inc(lRawPos); + lbtL1 := lRawRA[lRawPos]; + inc(lRawPos); + lbtL2 := lRawRA[lRawPos]; + result := (256 * lbtL1 + lbtL2) +end; //nested proc ReadWord +//NEXT: main procedure + begin + lAbba := 4; + lnHufTables := 0; + lRawSz := lCptSize; + lRawPos := 0; + lRestartSegmentSz := 0; + lImgTypeC3 := false; + SOFxdim:= 1; + if lRawSz < 32 then goto 666; + for lFrameCount := 1 to kMaxFrames do + for lInc := 1 to 16 do + DHTstartRA[lFrameCount,lInc] := 0; + SOFydim := 1; + SOSpttrans := 0; + lHdrOK := false; + SOFnf := 0; + SOSns := 0; + GetMem( lRawRA, lRawSz); +{$IFDEF Stream} + lStream.Seek(lCptPosition, soFromBeginning); + lStream.readBuffer(lRawRA^, lRawSz); +{$ELSE} + Seek(infp,lCptPosition); + BlockRead(infp, lRawRA^, lRawSz); +{$ENDIF} + ReadByte(btS1); + ReadByte(btS1); + repeat + repeat + if lRawPos <= lRawSz then ReadByte(btS1); + if btS1 <> $FF then begin + goto 666; + end; + if lRawPos <= lRawSz then ReadByte( btMarkerType); + case btMarkerType of //only process segments with length fields + $0,$1,$D0..$D7,$FF: btMarkerType := 0; //0&FF = fillers, $1=TEM,$D0..D7=resync + end; + until (lRawPos >= lRawSz) or (btMarkerType <> 0); + lSegmentLength := ReadWord; + lSegmentEnd := lRawPos+(lSegmentLength - 2); + if lSegmentEnd > lRawSz then goto 666; + if (btMarkerType = $C3) then + lImgTypeC3 := true; + if lverbose then dcmMsg( {result+}inttohex(btMarkerType,2){':'+inttostr( lSegmentLength )+'@'+inttostr(positon)+' '}); + case btMarkerType of + $0: ; //filler - ignore + $C0..$C3,$C5..$CB,$CD..$CF: begin //read SOF FrameHeader + ReadByte(SOFprecision); + SOFydim := ReadWord; + SOFxdim:= ReadWord; + ReadByte(SOFnf); + if lverbose then dcmMsg('[precision:'+inttostr(SOFprecision)+' X*Y:'+inttostr(SOFxdim)+'*'+inttostr(SOFydim)+'nFrames:'+inttostr(SOFnf)+'] '); + if (not lImgTypeC3) or ((SOFnf <> 1) and (SOFnf <> 3)) then begin + dcmMsg('Unable to extract this file format.'); + end; + SOFarrayPos := lRawPos; + lRawPos := (lSegmentEnd); + end; //SOF FrameHeader + $C4: begin //DHT Huffman + if lverbose then dcmMsg( 'HuffmanLength'+inttostr(lSegmentLength)+':'); + //if SOFnf <1 then SOFnf := 1; //we may not know SOFnf yet! + lFrameCount := 1; + repeat + ReadByte( DHTtcth); + //showmessage(inttostr(lFrameCount)+'@'+inttostr(DHTtcth and 15)+'x'+inttostr(DHTtcth )); + DHTnLi := 0; + for lInc := 1 to 16 do begin + ReadByte(DHTliRA[lFrameCount,lInc]); + DHTnLi := DHTnLi + DHTliRA[lFrameCount,lInc]; + if DHTliRA[lFrameCount,lInc] <> 0 then lMaxHufSi[lFrameCount] := lInc; + //showmessage(inttostr(DHTliRA[lFrameCount,lInc])+'@'+inttostr(lMaxHufSi)); + end; + if DHTnLi > 17 then begin + dcmMsg('Huffman table corrupted.'); + goto 666; + end; + lIncY := 0; //frequency + + for lInc := 0 to 31 do begin + lHufRA[lFrameCount, lInc].HufVal := -1; + lHufRA[lFrameCount, lInc].HufSz := -1; + lHufRA[lFrameCount, lInc].HufCode := -1; + end; + + for lInc := 1 to 16 do begin //set the huffman size values + if DHTliRA[lFrameCount,lInc]> 0 then begin + DHTstartRA[lFrameCount,lInc] := lIncY+1; + for lIncX := 1 to DHTliRA[lFrameCount,lInc] do begin + inc(lIncY); + ReadByte(btS1); + lHufRA[lFrameCount,lIncY].HufVal := btS1; + lMaxHufVal[lFrameCount] := btS1; + if (btS1 >= 0) and (btS1 <= 16) then + lHufRA[lFrameCount,lIncY].HufSz := lInc + else begin + dcmMsg('Huffman size array corrupted.'); + goto 666; + end; {} + end; + end; //Length of size lInc > 0 + end; + //showmessage('Max bits:'+inttostr(lMaxHufSi)+' SSSS:'+inttostr(lMaxHufVal)); + K := 1; + Code := 0; + Si := lHufRA[lFrameCount,K].HufSz;//HuffSizeRA[1]; + repeat + while (Si = lHufRA[lFrameCount,K].HufSz) do begin + lHufRA[lFrameCount,K].HufCode := Code; + //showmessage('bits: '+inttostr(Si)+' NthEntry:'+inttostr(K)+' Code:'+inttostr(Code)); + Code := Code + 1; + Inc(K); + end; + if K <= DHTnLi then begin + while lHufRA[lFrameCount,K].HufSz > Si do begin + Code := Code Shl 1; + Si := Si + 1; + end; //while Si + end; //K <= 17 + until K > DHTnLi;// JGS added rev13 + inc(lFrameCount); + until (lSegmentEnd-lRawPos) < 18; + lnHufTables := lFrameCount - 1; + //showmessage(inttostr(lnHufTables)); + lRawPos := (lSegmentEnd); + end; //$C4: DHT Huffman + $DD: begin //Define Restart + lRestartSegmentSz := Readword; + lRawPos := (lSegmentEnd); + end; + $DA: begin //read SOS Scan Header + if SOSns > 0 then goto 666; //multiple SOS! + ReadByte(SOSns); + //if Ns = 1 then NOT interleaved, else interleaved: see B.2.3 + SOSarrayPos := lRawPos; + if SOSns > 0 then begin + for lInc := 1 to SOSns do begin + ReadByte( btS1); //component identifier 1=Y,2=Cb,3=Cr,4=I,5=Q + ReadByte(btS2); //horizontal and vertical sampling factors + end; + end; + ReadByte(SOSss); //predictor selection B.3 + ReadByte( SOSse); + ReadByte( SOSahal); //lower 4bits= pointtransform + SOSpttrans := SOSahal and 16; + if lverbose then + dcmMsg('[Predictor: '+inttostr(SOSss)+' PointTransform:'+inttostr(SOSahal)+'] '); + lRawPos := (lSegmentEnd); + end; //$DA SOS - Scan Header + else begin //skip marker segment; + lRawPos := (lSegmentEnd); + end; + end; //case markertype + until (lRawPos >= lRawSz) or (btMarkerType = $DA); {hexDA=Start of scan} + lHdrOK := true; //errors goto label 666, so are NOT OK + lImgStart := lRawPos; +666: + if not lHdrOK then begin + dcmMsg('Unable to read this file - is this really a JPEG image?'); + goto 123; + end; + if (not lImgTypeC3) then + goto 123; //lossless compressed huffman tables + //NEXT: unpad data - delete byte that follows $FF + lINc := lRawPos; + lIncX := lRawPos; + repeat + lRawRA[lIncX] := lRawRA[lInc]; + if lRawRA[lInc] = 255 then begin + if (lRawRA[lInc+1] = $00) then + lInc := lInc+1 + else begin + //showmessage(inttostr(lRawRA[lInc+1])); + if (lRawRA[lInc+1] = $D9) then //end of image + lIncX := -666; //end of padding + end; + end; + inc(lInc); + inc(lIncX); + until lIncX < 0; + //End: Data unpadding + //NEXT: Create Huffman LookupTable. + //We will compute all possible outcomes for an 8-bit value, while less intuitive than + //reading Huffman 1 bit at a time, it doubles the decompression speed + lBitMask[1]:= 1; + lBitMask[2]:= 3; + lBitMask[3]:= 7; + lBitMask[4]:= 15; + lBitMask[5]:= 31; + lBitMask[6]:= 63; + lBitMask[7]:= 127; + lBitMask[8]:= 255; + lBitMask[9]:= 511; + lBitMask[10]:= 1023; + lBitMask[11]:= 2047; + lBitMask[12]:= 4095; + lBitMask[13]:= 8191; + lBitMask[14]:= 16383; + lBitMask[15]:= 32767; + lBitMask[16]:= 65535; + lBitMask[17]:= 131071; //ONLY required for Osiris corrupted images, see DecodePixelDifference for details + //NEXT: some RGB images use only a single Huffman table for all 3 colour planes. In this case, replicate the correct values + if (lnHufTables < SOFnf) then begin //use single Hufman table for each frame + //showmessage('generating tables'+inttostr(SOFnf)); + if lnHufTables < 1 then begin + dcmMsg('Lossless JPEG decoding error: no Huffman tables.'); + goto 123; + end; + for lFrameCount := 2 to SOFnf do begin + for lInc := 1 to 16 do + DHTstartRA[lFrameCount,lInc] := DHTstartRA[1,lInc]; + for lInc := 0 to 31 do begin + lHufRA[lFrameCount,lInc].HufCode := lHufRA[1,lInc].HufCode; + lHufRA[lFrameCount,lInc].HufVal := lHufRA[1,lInc].HufVal; + lHufRA[lFrameCount,lInc].HufSz := lHufRA[1,lInc].HufSz; + DHTliRA[lFrameCount,lInc] := DHTliRA[1,lInc]; + end; //for each table entry + end; //for each frame xx + end;// if lnHufTables < SOFnf + for lFrameCount := 1 to kMaxFrames do + for lInc := 0 to 17 do + lSSSSszRA[lFrameCount,lInc] := 123; //Impossible value for SSSS, suggests 8-bits can not describe answer + for lFrameCount := 1 to kMaxFrames do + for lInc := 0 to 255 do + lLookUpRA[lFrameCount,lInc] := 255; //Impossible value for SSSS, suggests 8-bits can not describe answer + //NEXT fill lookuptable + for lFrameCount := 1 to SOFnf do begin + lIncY := 0; + for lSz := 1 to 8 do begin //set the huffman lookup table for keys with lengths <=8 + if DHTliRA[lFrameCount,lSz]> 0 then begin + for lIncX := 1 to DHTliRA[lFrameCount,lSz] do begin + inc(lIncY); + lHufVal := lHufRA[lFrameCount,lIncY].HufVal; //SSSS + {if (lHufVal < 0) or (lHufVal > 17) then begin + showmessage('Unknown SSSS =' +inttostr(lHufVal)); + lHufVal := 16; + end; } + lSSSSszRA[lFrameCount,lHufVal] := lSz; + k := (lHufRA[lFrameCount,lIncY].HufCode shl (8-lSz )) and 255; //K= most sig bits for hufman table + if lSz < 8 then begin //fill in all possible bits that exceed the huffman table + lInc := lBitMask[8-lSz]; + for lCurrentBitPos := 0 to lInc do begin + lLookUpRA[lFrameCount,k+lCurrentBitPos] := lHufVal; + end; + end else + lLookUpRA[lFrameCount,k] := lHufVal; //SSSS + + {Showmessage('Frame ' + inttostr(lFrameCount) + ' SSSS= '+inttostr(lHufRA[lFrameCount,lIncY].HufVal)+ + ' Size= '+inttostr(lHufRA[1,lIncY].HufSz)+ + ' Code= '+inttostr(lHufRA[1,lIncY].HufCode)+ + ' SHL Code= '+inttostr(k)+ + ' EmptyBits= '+inttostr(lInc)); {} + end; //Set SSSS + end; //Length of size lInc > 0 + end; //for lInc := 1 to 8 + end; //For each frame, e.g. once each for Red/Green/Blue + //Next: uncompress data: different loops for different predictors + SOFxdim:= SOFnf*SOFxdim; + lItems := SOFxdim*SOFydim; + //if lVerbose then showmessage('precision'+inttostr(SOFprecision)); + //for timing, multiple decoding loops lRawAbba := lRawPos;for lLoopsAbba := 1 to 100 do begin lRawPos := lRawAbba; + //if (lRestartSegmentSz > 0) and ((SOFPrecision<> 8) or (SOSss = 7)) then //add restart support if we ever find any samples to test + // showmessage('This image uses restart markers. Please contact the author. Predictor:Precision '+inttostr(SOSss)+':'+inttostr(SOFPrecision)); + inc(lRawPos);//abbax + lCurrentBitPos := 0; //read in a new byte + //lCurrentBitPos := 1; //read in a new byte + lItems := SOFxdim*SOFydim; + lPredicted := 1 shl (SOFPrecision-1-SOSpttrans); + lInc := 0; + if (SOFPrecision<> 8) then begin //start - 16 bit data + lImgRA := @lOutSmallRA[0];{set to 1 for MRIcro, else 0} + FillChar(lImgRA^,lItems*sizeof(word), 0); //zero array + lPredB:= 0; + lPredC := 0; + case SOSss of //predictors 1,2,3 examine single previous pixel, here we set the relative location + 2: lPredA:= SOFxDim-1; //Rb directly above + 3: lPredA:= SOFxDim; //Rc UpperLeft:above and to the left + 4,5: begin + lPredA := 0; + lPredB := SOFxDim-1; //Rb directly above + lPredC:= SOFxDim; //Rc UpperLeft:above and to the left + end; + 6: begin + lPredB := 0; + lPredA := SOFxDim-1; //Rb directly above + lPredC:= SOFxDim; //Rc UpperLeft:above and to the left + end; + else lPredA := 0; //Ra: directly to left + end; //case SOSss: predictor offset + for lIncX := 1 to SOFxdim do begin + inc(lInc); //writenext voxel + if lInc > 1 then lPredicted := lImgRA[lInc-1]; + lImgRA[lInc] := lPredicted+DecodePixelDifference(1); + end; //first line: use prev voxel prediction; + if lRestartSegmentSz = 0 then begin + for lIncY := 2 to SOFyDim do begin + inc(lInc); //write next voxel + lPredicted := lImgRA[lInc-SOFxdim]; + lImgRA[lInc] := lPredicted+DecodePixelDifference(1); + if SOSss = 4 then begin + for lIncX := 2 to SOFxdim do begin + lPredicted := lImgRA[lInc-lPredA]+lImgRA[lInc-lPredB]-lImgRA[lInc-lPredC]; + inc(lInc); //writenext voxel + lImgRA[lInc] := lPredicted+DecodePixelDifference(1); + end; //for lIncX + end else if (SOSss = 5) or (SOSss = 6) then begin + for lIncX := 2 to SOFxdim do begin + lPredicted := lImgRA[lInc-lPredA]+ ((lImgRA[lInc-lPredB]-lImgRA[lInc-lPredC]) shr 1); + inc(lInc); //writenext voxel + lImgRA[lInc] := lPredicted+DecodePixelDifference(1); + end; //for lIncX + end else if SOSss = 7 then begin + for lIncX := 2 to SOFxdim do begin + inc(lInc); //writenext voxel + lPredicted := (lImgRA[lInc-1]+lImgRA[lInc-SOFxdim]) shr 1; + lImgRA[lInc] := lPredicted+DecodePixelDifference(1); + end; //for lIncX + end else begin //SOSss 1,2,3 read single values + for lIncX := 2 to SOFxdim do begin + lPredicted := lImgRA[lInc-lPredA]; + inc(lInc); //writenext voxel + lImgRA[lInc] := lPredicted+DecodePixelDifference(1); + end; //for lIncX + end; //SOSss predictor + + + end; //for lIncY + end {RestartSegmentSz = 0} else begin {restartsegment} + if SOSss > 3 then + dcmMsg('Unusual 16-bit lossless JPEG with restart segments. Please contact the author:'+inttostr(SOSss)); + lSegmentEnd := lRestartSegmentSz; + repeat + if lSegmentEnd > lItems then lSegmentEnd := lItems; + lLineStart := (((lInc div SOFxDim)+1)* SOFxDim){-1}; + if lInc > (SOFxDim+1) then + lPredicted := 1 shl (SOFPrecision-1-SOSpttrans) + else + lPredicted := lImgRA[lInc-SOFxdim]; + + for lInc := lInc to (lSegmentEnd-1) do begin + lImgRA[lInc] := lPredicted+DecodePixelDifference(1); + if lInc+1 = lLineStart then begin//newline + lPredicted := lImgRA[lInc+1-SOFxdim]; + lLineStart := lLineStart + SOFxDim; + end else + lPredicted := lImgRA[lInc-lPredA]; + end; + if (lSegmentEnd+1) < lItems then begin + dec(lRawPos); + repeat + while (lRawRA[lRawPos] <> 255) do + inc(lRawPos); + inc(lRawPos); + until (lRawRA[lRawPos] >= $D0) and (lRawRA[lRawPos] <= $D7); + lCurrentBitPos := 0; //read in a new byte + inc(lRawPos);//abbax + end; + lSegmentEnd := lSegmentEnd + lRestartSegmentSz; + until (lRestartSegmentSz < 1) or ((lSegmentEnd-2) > lItems); + end; //restartsegments + end else if SOFnf = 3 then begin //>8bit data; 8 bit follows + //LOSSLESS JPEG: 7 possible predictors - we will handle all of them + lPredB:= 0; + lPredC := 0; + case SOSss of //predictors 1,2,3 examine single previous pixel, here we set the relative location + 2: lPredA:= SOFxDim-3; //Rb directly above + 3: lPredA:= SOFxDim; //Rc UpperLeft:above and to the left + 5: begin + lPredA := 0; + lPredB := SOFxDim-3; //Rb directly above + lPredC:= SOFxDim; //Rc UpperLeft:above and to the left + end; + 6: begin + lPredB := 0; + lPredA := SOFxDim-3; //Rb directly above + lPredC:= SOFxDim; //Rc UpperLeft:above and to the left + end; + else lPredA := 0; //Ra: directly to left + end; //case SOSss: predictor offset + lPredictedG := lPredicted; + lPredictedB := lPredicted; + lOffset := 0; + lInc := lOffset; + for lIncX := 1 to (SOFxdim div 3) do begin //write first line + //DecodePixelDifference=RED + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); + lPredicted := lImgRAz[lInc]; + inc(lInc); //writenext voxel + //DecodePixelDifference=GREEN + lImgRAz[lInc] := lPredictedG+DecodePixelDifference(2); + lPredictedG := lImgRAz[lInc]; + inc(lInc); //writenext voxel + //DecodePixelDifference=BLUE + lImgRAz[lInc] := lPredictedB+DecodePixelDifference(3); + lPredictedB := lImgRAz[lInc]; + inc(lInc); //writenext voxel + end; //first line: use prev voxel prediction; + if lRestartSegmentSz = 0 then lSegmentEnd := lItems + else lSegmentEnd := lRestartSegmentSz; + repeat + if lSegmentEnd > lItems then lSegmentEnd := lItems; + lLineStart := (((lInc div SOFxDim)+1)* SOFxDim)+lOffset{-1}; + if lInc > (SOFxDim+1) then begin + lPredicted := 1 shl (SOFPrecision-1-SOSpttrans); + lPredictedG := lPredicted; + lPredictedB := lPredicted; + end else begin + lPredicted := lImgRAz[lInc-SOFxdim+lOffset]; + lPredictedG := lImgRAz[1+lInc-SOFxdim+lOffset]; + lPredictedB := lImgRAz[2+lInc-SOFxdim+lOffset]; + end; + if SOSss = 4 then begin //predictor = 4 + //this is a 24-bit image, so for 512-pixel wid image, SOFxdim will be (3*512=) 1536 + while lInc < (lSegmentEnd-1) do begin + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); //RED + inc(lInc); + lImgRAz[lInc] := lPredictedG+DecodePixelDifference(2); //GREEN + inc(lInc); + lImgRAz[lInc] := lPredictedB+DecodePixelDifference(3); //BLUE + inc(lInc); + if lInc = lLineStart then begin//newline + lPredicted := lImgRAz[lInc-SOFxdim]; + lPredictedG := lImgRAz[lInc-SOFxdim+1]; + lPredictedB := lImgRAz[lInc-SOFxdim+2]; + lLineStart := lLineStart + (SOFxDim); + end else begin + lPredicted := lImgRAz[lInc-3]+lImgRAz[lInc-3-(SOFxDim-3)]-lImgRAz[lInc-3-SOFxDim]; + lPredictedG := lImgRAz[lInc-2]+lImgRAz[lInc-2-(SOFxDim-3)]-lImgRAz[lInc-2-SOFxDim]; + lPredictedB := lImgRAz[lInc-1]+lImgRAz[lInc-1-(SOFxDim-3)]-lImgRAz[lInc-1-SOFxDim]; + end; + end; + //xxx + end else if (SOSss = 5) or (SOSss = 6) then begin //predictor = 5 or 6 + //this is a 24-bit image, so for 512-pixel wid image, SOFxdim will be (3*512=) 1536 + while lInc < (lSegmentEnd-1) do begin + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); //RED + inc(lInc); + lImgRAz[lInc] := lPredictedG+DecodePixelDifference(2); //GREEN + inc(lInc); + lImgRAz[lInc] := lPredictedB+DecodePixelDifference(3); //BLUE + inc(lInc); + if lInc = lLineStart then begin//newline + lPredicted := lImgRAz[lInc-SOFxdim]; + lPredictedG := lImgRAz[lInc-SOFxdim+1]; + lPredictedB := lImgRAz[lInc-SOFxdim+2]; + lLineStart := lLineStart + (SOFxDim); + end else begin + lPredicted := lImgRAz[lInc-3-lPredA]+((lImgRAz[lInc-3-lPredB]-lImgRAz[lInc-3-lPredC])shr 1); + lPredictedG := lImgRAz[lInc-2-lPredA]+((lImgRAz[lInc-2-lPredB]-lImgRAz[lInc-2-lPredC])shr 1); + lPredictedB := lImgRAz[lInc-1-lPredA]+((lImgRAz[lInc-1-lPredB]-lImgRAz[lInc-1-lPredC])shr 1); + end; + end; + end else if SOSss = 7 then begin //predictor = 7 + while lInc < (lSegmentEnd-1) do begin + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); //RED + inc(lInc); + lImgRAz[lInc] := lPredictedG+DecodePixelDifference(2); //GREEN + inc(lInc); + lImgRAz[lInc] := lPredictedB+DecodePixelDifference(3); //BLUE + inc(lInc); + if lInc = lLineStart then begin//newline + lPredicted := lImgRAz[lInc-SOFxdim]; + lPredictedG := lImgRAz[lInc-SOFxdim+1]; + lPredictedB := lImgRAz[lInc-SOFxdim+2]; + lLineStart := lLineStart + (SOFxDim); + end else begin + lPredicted := (lImgRAz[lInc-3]+lImgRAz[lInc-3-(SOFxDim-3)])shr 1; + lPredictedG := (lImgRAz[lInc-2]+lImgRAz[lInc-2-(SOFxDim-3)]) shr 1; + lPredictedB := (lImgRAz[lInc-1]+lImgRAz[lInc-1-(SOFxDim-3)]) shr 1; + end; + end; + + end else begin //predictor in range 1,2,3 + //this is a 24-bit image, so for 512-pixel wid image, SOFxdim will be (3*512=) 1536 + while lInc < (lSegmentEnd-1) do begin + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); //RED + inc(lInc); + lImgRAz[lInc] := lPredictedG+DecodePixelDifference(2); //GREEN + inc(lInc); + lImgRAz[lInc] := lPredictedB+DecodePixelDifference(3); //BLUE + inc(lInc); + if lInc = lLineStart then begin//newline + lPredicted := lImgRAz[lInc-SOFxdim]; + lPredictedG := lImgRAz[lInc-SOFxdim+1]; + lPredictedB := lImgRAz[lInc-SOFxdim+2]; + lLineStart := lLineStart + (SOFxDim); + end else begin + lPredicted := lImgRAz[lInc-3-lPredA]; + lPredictedG := lImgRAz[lInc-2-lPredA]; + lPredictedB := lImgRAz[lInc-1-lPredA]; + end; + end; + end; //predictor <> 7 + until (lRestartSegmentSz < 1) or ((lSegmentEnd-2) > lItems); + // end; //8<>15data type + end else begin //previously 12/16/24bit data, 8 bit follows + lInc := 0; + //LOSSLESS JPEG: 7 possible predictors - we will handle all of them + lPredB:= 0; + lPredC := 0; + case SOSss of //predictors 1,2,3 examine single previous pixel, here we set the relative location + 2: lPredA:= SOFxDim-1; //Rb directly above + 3: lPredA:= SOFxDim; //Rc UpperLeft:above and to the left + 5: begin + lPredA := 0; + lPredB := SOFxDim-1; //Rb directly above + lPredC:= SOFxDim; //Rc UpperLeft:above and to the left + end; + 6: begin + lPredB := 0; + lPredA := SOFxDim-1; //Rb directly above + lPredC:= SOFxDim; //Rc UpperLeft:above and to the left + end; + else lPredA := 0; //Ra: directly to left + end; //case SOSss: predictor offset + //lOffset := -1; + for lIncX := 1 to SOFxdim do begin //write first line + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); + inc(lInc); //writenext voxel + lPredicted := lImgRAz[lInc-1]; + end; //first line: use prev voxel prediction; + if lRestartSegmentSz = 0 then lSegmentEnd := lItems + else lSegmentEnd := lRestartSegmentSz; + repeat + if lSegmentEnd > lItems then lSegmentEnd := lItems; + lLineStart := (((lInc div SOFxDim)+1)* SOFxDim){-1}; + if lInc > (SOFxDim+1) then + lPredicted := 1 shl (SOFPrecision-1-SOSpttrans) + else + lPredicted := lImgRAz[lInc-SOFxdim]; + if SOSss = 4 then begin //predictor 4 : ABOVE+LEFT-(UPPERLEFT) + for lInc := lInc to (lSegmentEnd-1) do begin + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); + if lInc+1 = lLineStart then begin//newline + lPredicted := lImgRAz[lInc+1-SOFxdim]; + lLineStart := lLineStart + SOFxDim; + end else + lPredicted := lImgRAz[lInc]+lImgRAz[lInc-(SOFxDim-1)] -lImgRAz[lInc-SOFxDim] ; + end; + + end else if (SOSss = 5) or (SOSss=6) then begin //predictor 5,6 : comparisons + for lInc := lInc to (lSegmentEnd-1) do begin + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); + if lInc+1 = lLineStart then begin//newline + lPredicted := lImgRAz[lInc+1-SOFxdim]; + lLineStart := lLineStart + SOFxDim; + end else + lPredicted := lImgRAz[lInc-lPredA]+((lImgRAz[lInc-lPredB]-lImgRAz[lInc-lPredC]) shr 1) ; + end; + end else if SOSss = 7 then begin //predictor 7: average above and left + for lInc := lInc to (lSegmentEnd-1) do begin + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); + if lInc+1 = lLineStart then begin//newline + lPredicted := lImgRAz[lInc+1-SOFxdim]; + lLineStart := lLineStart + SOFxDim; + end else + lPredA := lImgRAz[lInc]; + lPredB:= lImgRAz[lInc-SOFxDim+1];//correct + lPredicted := (lPredA+lPredB) shr 1; + end; + end else begin //predictor <> 7 : assume SOSss=1: previous + for lInc := lInc to (lSegmentEnd-1) do begin + lImgRAz[lInc] := lPredicted+DecodePixelDifference(1); + if lInc+1 = lLineStart then begin//newline + lPredicted := lImgRAz[lInc+1-SOFxdim]; + lLineStart := lLineStart + SOFxDim; + end else + lPredicted := lImgRAz[lInc-lPredA]; + end; + end; //predictor <> 7 + if (lSegmentEnd+1) < lItems then begin + dec(lRawPos); + repeat + while (lRawRA[lRawPos] <> 255) do + inc(lRawPos); + inc(lRawPos); + until (lRawRA[lRawPos] >= $D0) and (lRawRA[lRawPos] <= $D7); + lCurrentBitPos := 0; //read in a new byte + inc(lRawPos); + //lCurrentBitPos := 9; //read in a new byte + end; + lSegmentEnd := lSegmentEnd + lRestartSegmentSz; + until (lRestartSegmentSz < 1) or ((lSegmentEnd-2) > lItems); + end; //8<>15data type +123: + FreeMem( lRawRA); //release memory buffer +end; + +end. diff --git a/dcm2nii/lsjpeg.ppu b/dcm2nii/lsjpeg.ppu new file mode 100644 index 0000000..8fa1a8b Binary files /dev/null and b/dcm2nii/lsjpeg.ppu differ diff --git a/dcm2nii/nifti_form.dfm b/dcm2nii/nifti_form.dfm new file mode 100755 index 0000000..1ae875c Binary files /dev/null and b/dcm2nii/nifti_form.dfm differ diff --git a/dcm2nii/nifti_form.lfm b/dcm2nii/nifti_form.lfm new file mode 100755 index 0000000..3d4dfc9 --- /dev/null +++ b/dcm2nii/nifti_form.lfm @@ -0,0 +1,229 @@ +object NIfTIForm: TNIfTIForm + Left = 797 + Height = 266 + Top = 32 + Width = 400 + ActiveControl = OKBtn + BiDiMode = bdRightToLeft + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'Convert NIfTI File' + ClientHeight = 266 + ClientWidth = 400 + Constraints.MaxHeight = 266 + Constraints.MaxWidth = 400 + Constraints.MinHeight = 266 + Constraints.MinWidth = 400 + OnCreate = FormCreate + ParentBiDiMode = False + LCLVersion = '1.0.12.0' + object Label1: TLabel + Left = 8 + Height = 17 + Top = 168 + Width = 102 + Alignment = taCenter + Caption = 'Output Format: ' + ParentColor = False + end + object Label4: TLabel + Left = 8 + Height = 17 + Top = 16 + Width = 35 + Alignment = taCenter + Caption = 'Task:' + ParentColor = False + end + object OKBtn: TButton + Left = 200 + Height = 25 + Top = 208 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + ModalResult = 1 + OnClick = OKBtnClick + TabOrder = 0 + end + object CancelBtn: TButton + Left = 104 + Height = 25 + Top = 208 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 1 + end + object TypeCombo: TComboBox + Left = 118 + Height = 20 + Top = 163 + Width = 209 + ItemHeight = 0 + Items.Strings = ( + 'SPM2 (3D Anlyze hdr/img)' + 'SPM5 (3D NIfTI hdr/img)' + 'SPM8 (3D NIfTI nii)' + '4D NIfTI hdr/img' + 'FSL (4D NIfTI nii)' + 'Compressed FSL (4D NIfTI nii)' + 'MRIcron drawing (voi)' + ) + Style = csDropDownList + TabOrder = 2 + end + object Panel1: TPanel + Left = 8 + Height = 103 + Top = 59 + Width = 312 + BevelOuter = bvNone + ClientHeight = 103 + ClientWidth = 312 + TabOrder = 3 + object Label2: TLabel + Left = 8 + Height = 17 + Top = 15 + Width = 190 + Caption = 'Volumes to remove from start' + ParentColor = False + end + object Label3: TLabel + Left = 7 + Height = 17 + Top = 55 + Width = 185 + Caption = 'Volumes to remove from end' + ParentColor = False + end + object StartEdit: TSpinEdit + Left = 224 + Height = 15 + Top = 13 + Width = 74 + MaxValue = 9999999 + TabOrder = 0 + end + object EndEdit: TSpinEdit + Left = 224 + Height = 15 + Top = 53 + Width = 74 + MaxValue = 9999999 + TabOrder = 1 + end + end + object Combo4D: TComboBox + Left = 47 + Height = 20 + Top = 11 + Width = 337 + ItemHeight = 0 + Items.Strings = ( + 'Change format' + 'Flip dimensions 3 and 4' + 'Clip 1st/Last Volumes' + 'Export as 32-bit real' + 'Apply formula' + 'ASL conversion' + ) + OnChange = Combo4DChange + Style = csDropDownList + TabOrder = 4 + end + object Combo3D: TComboBox + Left = 48 + Height = 20 + Top = 11 + Width = 336 + ItemHeight = 0 + Items.Strings = ( + 'Change format' + 'Reorient to orthogonal' + 'Reorient and crop' + ) + Style = csDropDownList + TabOrder = 5 + end + object ASLPanel: TPanel + Left = 40 + Height = 50 + Top = 24 + Width = 275 + BevelOuter = bvNone + ClientHeight = 50 + ClientWidth = 275 + TabOrder = 6 + object ASLCombo: TComboBox + Left = 16 + Height = 20 + Top = 11 + Width = 250 + ItemHeight = 0 + Items.Strings = ( + 'Subtract pairs - first image tagged' + 'Subtract pairs - first image control' + 'Subtract Custom' + 'Add (odd+even) BOLD' + ) + Style = csDropDownList + TabOrder = 0 + end + end + object FormulaPanel: TPanel + Left = 47 + Height = 114 + Top = 56 + Width = 273 + BevelOuter = bvNone + BorderStyle = bsSingle + ClientHeight = 114 + ClientWidth = 273 + TabOrder = 7 + object Label5: TLabel + Left = 31 + Height = 17 + Top = 17 + Width = 33 + Alignment = taCenter + Caption = 'Scale' + ParentColor = False + end + object Label6: TLabel + Left = 31 + Height = 17 + Top = 59 + Width = 39 + Alignment = taCenter + Caption = 'Power' + ParentColor = False + end + object ScaleEdit: TFloatSpinEdit + Left = 127 + Height = 15 + Top = 11 + Width = 130 + DecimalPlaces = 8 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 0 + Value = 1.2E-6 + end + object PowerEdit: TFloatSpinEdit + Left = 127 + Height = 15 + Top = 56 + Width = 130 + DecimalPlaces = 8 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 1 + Value = 1.2E-6 + end + end +end \ No newline at end of file diff --git a/dcm2nii/nifti_form.lrs b/dcm2nii/nifti_form.lrs new file mode 100755 index 0000000..fec7501 --- /dev/null +++ b/dcm2nii/nifti_form.lrs @@ -0,0 +1,63 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TNIfTIForm','FORMDATA',[ + 'TPF0'#10'TNIfTIForm'#9'NIfTIForm'#4'Left'#3#29#3#6'Height'#3#10#1#3'Top'#2' ' + +#5'Width'#3#144#1#13'ActiveControl'#7#5'OKBtn'#8'BiDiMode'#7#13'bdRightToLef' + +'t'#11'BorderIcons'#11#12'biSystemMenu'#0#11'BorderStyle'#7#8'bsDialog'#7'Ca' + +'ption'#6#18'Convert NIfTI File'#12'ClientHeight'#3#10#1#11'ClientWidth'#3 + +#144#1#21'Constraints.MaxHeight'#3#10#1#20'Constraints.MaxWidth'#3#144#1#21 + +'Constraints.MinHeight'#3#10#1#20'Constraints.MinWidth'#3#144#1#8'OnCreate'#7 + +#10'FormCreate'#14'ParentBiDiMode'#8#10'LCLVersion'#6#8'1.0.12.0'#0#6'TLabel' + +#6'Label1'#4'Left'#2#8#6'Height'#2#17#3'Top'#3#168#0#5'Width'#2'f'#9'Alignme' + +'nt'#7#8'taCenter'#7'Caption'#6#15'Output Format: '#11'ParentColor'#8#0#0#6 + +'TLabel'#6'Label4'#4'Left'#2#8#6'Height'#2#17#3'Top'#2#16#5'Width'#2'#'#9'Al' + +'ignment'#7#8'taCenter'#7'Caption'#6#5'Task:'#11'ParentColor'#8#0#0#7'TButto' + +'n'#5'OKBtn'#4'Left'#3#200#0#6'Height'#2#25#3'Top'#3#208#0#5'Width'#2'K'#25 + +'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#2'OK'#11'ModalResult'#2#1#7'OnC' + +'lick'#7#10'OKBtnClick'#8'TabOrder'#2#0#0#0#7'TButton'#9'CancelBtn'#4'Left'#2 + +'h'#6'Height'#2#25#3'Top'#3#208#0#5'Width'#2'K'#25'BorderSpacing.InnerBorder' + +#2#4#7'Caption'#6#6'Cancel'#11'ModalResult'#2#2#8'TabOrder'#2#1#0#0#9'TCombo' + +'Box'#9'TypeCombo'#4'Left'#2'v'#6'Height'#2#20#3'Top'#3#163#0#5'Width'#3#209 + +#0#10'ItemHeight'#2#0#13'Items.Strings'#1#6#24'SPM2 (3D Anlyze hdr/img)'#6#23 + +'SPM5 (3D NIfTI hdr/img)'#6#19'SPM8 (3D NIfTI nii)'#6#16'4D NIfTI hdr/img'#6 + +#18'FSL (4D NIfTI nii)'#6#29'Compressed FSL (4D NIfTI nii)'#6#21'MRIcron dra' + +'wing (voi)'#0#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#2#0#0#6'TPanel'#6 + +'Panel1'#4'Left'#2#8#6'Height'#2'g'#3'Top'#2';'#5'Width'#3'8'#1#10'BevelOute' + +'r'#7#6'bvNone'#12'ClientHeight'#2'g'#11'ClientWidth'#3'8'#1#8'TabOrder'#2#3 + +#0#6'TLabel'#6'Label2'#4'Left'#2#8#6'Height'#2#17#3'Top'#2#15#5'Width'#3#190 + +#0#7'Caption'#6#28'Volumes to remove from start'#11'ParentColor'#8#0#0#6'TLa' + +'bel'#6'Label3'#4'Left'#2#7#6'Height'#2#17#3'Top'#2'7'#5'Width'#3#185#0#7'Ca' + +'ption'#6#26'Volumes to remove from end'#11'ParentColor'#8#0#0#9'TSpinEdit'#9 + +'StartEdit'#4'Left'#3#224#0#6'Height'#2#15#3'Top'#2#13#5'Width'#2'J'#8'MaxVa' + +'lue'#4#127#150#152#0#8'TabOrder'#2#0#0#0#9'TSpinEdit'#7'EndEdit'#4'Left'#3 + +#224#0#6'Height'#2#15#3'Top'#2'5'#5'Width'#2'J'#8'MaxValue'#4#127#150#152#0#8 + +'TabOrder'#2#1#0#0#0#9'TComboBox'#7'Combo4D'#4'Left'#2'/'#6'Height'#2#20#3'T' + +'op'#2#11#5'Width'#3'Q'#1#10'ItemHeight'#2#0#13'Items.Strings'#1#6#13'Change' + +' format'#6#23'Flip dimensions 3 and 4'#6#21'Clip 1st/Last Volumes'#6#21'Exp' + +'ort as 32-bit real'#6#13'Apply formula'#6#14'ASL conversion'#0#8'OnChange'#7 + +#13'Combo4DChange'#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#4#0#0#9'TComb' + +'oBox'#7'Combo3D'#4'Left'#2'0'#6'Height'#2#20#3'Top'#2#11#5'Width'#3'P'#1#10 + +'ItemHeight'#2#0#13'Items.Strings'#1#6#13'Change format'#6#22'Reorient to or' + +'thogonal'#6#17'Reorient and crop'#0#5'Style'#7#14'csDropDownList'#8'TabOrde' + +'r'#2#5#0#0#6'TPanel'#8'ASLPanel'#4'Left'#2'('#6'Height'#2'2'#3'Top'#2#24#5 + +'Width'#3#19#1#10'BevelOuter'#7#6'bvNone'#12'ClientHeight'#2'2'#11'ClientWid' + +'th'#3#19#1#8'TabOrder'#2#6#0#9'TComboBox'#8'ASLCombo'#4'Left'#2#16#6'Height' + +#2#20#3'Top'#2#11#5'Width'#3#250#0#10'ItemHeight'#2#0#13'Items.Strings'#1#6 + +'#Subtract pairs - first image tagged'#6'$Subtract pairs - first image contr' + +'ol'#6#15'Subtract Custom'#6#19'Add (odd+even) BOLD'#0#5'Style'#7#14'csDropD' + +'ownList'#8'TabOrder'#2#0#0#0#0#6'TPanel'#12'FormulaPanel'#4'Left'#2'/'#6'He' + +'ight'#2'r'#3'Top'#2'8'#5'Width'#3#17#1#10'BevelOuter'#7#6'bvNone'#11'Border' + +'Style'#7#8'bsSingle'#12'ClientHeight'#2'r'#11'ClientWidth'#3#17#1#8'TabOrde' + +'r'#2#7#0#6'TLabel'#6'Label5'#4'Left'#2#31#6'Height'#2#17#3'Top'#2#17#5'Widt' + +'h'#2'!'#9'Alignment'#7#8'taCenter'#7'Caption'#6#5'Scale'#11'ParentColor'#8#0 + +#0#6'TLabel'#6'Label6'#4'Left'#2#31#6'Height'#2#17#3'Top'#2';'#5'Width'#2'''' + +#9'Alignment'#7#8'taCenter'#7'Caption'#6#5'Power'#11'ParentColor'#8#0#0#14'T' + +'FloatSpinEdit'#9'ScaleEdit'#4'Left'#2#127#6'Height'#2#15#3'Top'#2#11#5'Widt' + +'h'#3#130#0#13'DecimalPlaces'#2#8#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8 + +'MaxValue'#5#0#0#0#0#0#0#0#200#5'@'#8'MinValue'#5#0#0#0#0#0#0#0#0#0#0#8'TabO' + +'rder'#2#0#5'Value'#5#0#176#27'l'#160#175#15#161#235'?'#0#0#14'TFloatSpinEdi' + +'t'#9'PowerEdit'#4'Left'#2#127#6'Height'#2#15#3'Top'#2'8'#5'Width'#3#130#0#13 + +'DecimalPlaces'#2#8#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0 + +#0#0#0#0#0#200#5'@'#8'MinValue'#5#0#0#0#0#0#0#0#0#0#0#8'TabOrder'#2#1#5'Valu' + +'e'#5#0#176#27'l'#160#175#15#161#235'?'#0#0#0#0 +]); \ No newline at end of file diff --git a/dcm2nii/nifti_form.o b/dcm2nii/nifti_form.o new file mode 100644 index 0000000..d94faa9 Binary files /dev/null and b/dcm2nii/nifti_form.o differ diff --git a/dcm2nii/nifti_form.pas b/dcm2nii/nifti_form.pas new file mode 100755 index 0000000..8c76f10 --- /dev/null +++ b/dcm2nii/nifti_form.pas @@ -0,0 +1,134 @@ +unit nifti_form; + +interface + +uses +{$IFDEF FPC}LResources, +{$ELSE} +RXSpin, +{$ENDIF} +{$IFNDEF UNIX} Windows,{$ENDIF} + Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Spin, ExtCtrls {, Mask}; +{$IFNDEF FPC} +type + TNIfTIform = class(TForm) + ASLCombo: TComboBox; + Combo4D: TComboBox; + Label1: TLabel; + OKBtn: TButton; + CancelBtn: TButton; + Combo3D: TComboBox; + Panel1: TPanel; + FormulaPanel: TPanel; + StartEdit: TSpinEdit; + EndEdit: TSpinEdit; + Label2: TLabel; + Label3: TLabel; + TypeCombo: TComboBox; + Label4: TLabel; + ASLPanel: TPanel; + Label5: TLabel; + ScaleEdit: TRxSpinEdit; + PowerEdit: TRxSpinEdit; + procedure Combo4DChange(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure OKBtnClick(Sender: TObject); + private +{$ELSE} +type + TNIfTIform = class(TForm) + ASLCombo: TComboBox; + Combo4D: TComboBox; + Label1: TLabel; + OKBtn: TButton; + CancelBtn: TButton; + Combo3D: TComboBox; + Panel1: TPanel; + FormulaPanel: TPanel; + StartEdit: TSpinEdit; + EndEdit: TSpinEdit; + Label2: TLabel; + Label3: TLabel; + TypeCombo: TComboBox; + Label4: TLabel; + ASLPanel: TPanel; + Label5: TLabel; + ScaleEdit: TFloatSpinEdit; + PowerEdit: TFloatSpinEdit; + procedure Combo4DChange(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure OKBtnClick(Sender: TObject); + private + +{$ENDIF} +{Delphi... + ScaleEdit: TRxSpinEdit; + PowerEdit: TRxSpinEdit; +Lazarus + ScaleEdit: TFloatSpinEdit; + PowerEdit: TFloatSpinEdit; +} + { Private declarations } + public + { Public declarations } + end; + +var + NIfTIform: TNIfTIform; + +implementation + +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + +procedure TNIfTIform.Combo4DChange(Sender: TObject); +var + lS: string; +begin + lS := ''; + If ((Combo4D.visible) and (Combo4D.ItemIndex = 6)) + or ( (not (Combo4D.visible)) and (Combo3D.ItemIndex = 3)) then begin + Panel1.visible := true; + lS := 'Slices'; + end else If (Combo4D.visible) and (Combo4D.ItemIndex = 2) then begin + Panel1.visible := true; + lS := 'Volumes' + end else + Panel1.visible := false; + if lS <> '' then begin + Label2.Caption := lS+' to remove from start'; + Label3.Caption := lS+' to remove from end'; + + end; + If (Combo4D.visible) and (Combo4D.ItemIndex = 4) then + FormulaPanel.visible := true + else + FormulaPanel.visible := false; + If (Combo4D.visible) and (Combo4D.ItemIndex = 5) then + ASLPanel.visible := true + else + ASLPanel.visible := false; +end; + +procedure TNIfTIform.FormCreate(Sender: TObject); +begin + Combo3D.ItemIndex := 0; + Combo4D.ItemIndex := 0; + ASLCombo.ItemIndex := 0; +end; + +procedure TNIfTIform.OKBtnClick(Sender: TObject); +begin + +end; + +{$IFDEF FPC} + + +initialization + {$I nifti_form.lrs} + {$ENDIF} + +end. diff --git a/dcm2nii/nifti_form.ppu b/dcm2nii/nifti_form.ppu new file mode 100644 index 0000000..55f0256 Binary files /dev/null and b/dcm2nii/nifti_form.ppu differ diff --git a/dcm2nii/niftiutil.o b/dcm2nii/niftiutil.o new file mode 100644 index 0000000..8a8f38d Binary files /dev/null and b/dcm2nii/niftiutil.o differ diff --git a/dcm2nii/niftiutil.pas b/dcm2nii/niftiutil.pas new file mode 100755 index 0000000..75f1e32 --- /dev/null +++ b/dcm2nii/niftiutil.pas @@ -0,0 +1,1785 @@ +unit niftiutil; + {$Include ..\common\isgui.inc} +interface +uses +{$IFDEF FPC} + {$IFDEF GUI}FileUtil, {$ENDIF} //FileUtil requires LResources that requires extra environment variables with tools like matlab +gzio2, process, //FileUtil, +{$ELSE} +gziod, ShellAPI,Windows,Forms, +{$ENDIF} + SysUtils,Classes,define_types,filename,dicomtypes,prefs,dialogs_msg, nifti_foreign, nifti_types; +{$H+} +type + TNIIopts = RECORD //peristimulus plot + bs: boolean; + gzBytes: Int64; // K_gzBytes_headerAndImageCompressed, K_gzBytes_onlyImageCompressed, K_gzBytes_headerAndImageUncompressed= 0; + ImgName: string; + end; + +const + kNIIImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +function MaskImgs(lC1template, lC1source: string; lPrefs: TPrefs ; lThresh: single): string; +function MaskImg(ltemplate, lsource: string; lPrefs: TPrefs; lThresh: single ): string; +function Binarize(lC1Name: string; lPrefs: TPrefs ): string; +function SameHdrDim (lAHdr,lBHdr: TNIFTIhdr; lCheck4D, lCheckDataType: boolean): boolean; +procedure NIFTIhdr_ClearHdr (var lHdr: TNIFTIhdr ); //put sensible default values into header +procedure DICOM2AnzHdr (var lBHdr: TNIFTIhdr; lAnonymize: boolean; var lFilename: string; var lDICOMdata: DicomData); +procedure CustomFilename (var lFilename: string); +function SumTPM (lSrcName,lDestName: string; lPrefs: TPrefs; lTissueTypes2Average: integer):string; +//function SameHdrDim (lAHdr,lBHdr: TNIFTIhdr): boolean; +function SaveHdr (var lFilename: ANSIstring; var lInHdr: TNIFTIhdr ; lSwap,lSPM2:boolean): boolean; +function NIFTIhdr_LoadHdr (var lFilename: string; var lHdr: TNIFTIHdr; var lOpts: TNIIopts): boolean; + +procedure NIFTIhdr_SlicesToCoord (var lHdr: TNIFTIhdr; lXslice,lYslice,lZslice: integer; var lXmm,lYmm,lZmm: single); +function ChangeNIfTISubformat(lHdrName: string; var lHdr: TNIFTIhdr; lPrefs: TPrefs): boolean; +procedure SaveHdrRAM (var lFilename: ANSIstring; var lInHdr,lOutHdr: TNIFTIhdr ; lSwap,lSPM2:boolean); +function SaveNIfTICore (var lOutImgName: string; var lvBuffer: bytep; lVolOffset: integer; var lInHdr: TNIFTIhdr; var lPrefs: TPrefs): string; +function SaveNIfTICoreCrop (var lOutImgName: string; var lvBuffer: bytep; lVolOffset,lStartClip,lEndClip: integer; var lInHdr: TNIFTIhdr; var lPrefs: TPrefs): string; +function NIFTIhdr_LoadImg (var lFilename: string; var lHdr: TNIFTIHdr; var lImgBuffer: byteP; var lImgOffset: integer; var lOpts: TNIIopts): boolean; +//procedure NIFTIhdr_UnswapImg (var lHdr: TNIFTIHdr; var lImgBuffer: byteP; var lImgOffset: integer; var lByteSwap: boolean); //ensures image data is in native space +function NIFTIhdr_LoadImgRaw (LoadHdr: boolean; var lFilename: string; var lHdr: TNIFTIHdr; var lImgBuffer: byteP; var lImgOffset: integer; var lOpts: TNIIopts): boolean; +function NII_force32 (lSrcName,lDestName: string; lPrefs: TPrefs):string; +function Rescale_4Dtissuemaps (lSrcName,lDestName: string; lPrefs: TPrefs; lMakeSym: boolean):string; +function Merge4DFiles (lLowSliceName,lHighSliceName,lDestName: string; lNumberofLowSlicesToCopy: integer; lPrefs: TPrefs):string; +function Insert3Din4D (l3DSliceName,l4DSliceName,lDestName: string; lVol2Copy: integer; lPrefs: TPrefs):string; +function MaskImages(lMaskName: string; lFiles: TStrings; lPrefs: TPrefs; lVol: integer; lSaveThresh: boolean): string; +function NonspatialDimensionsNII (lA: TNIFTIhdr): integer; +implementation +uses dialogsx; + + + +function AddFileNum(lVol,lnVol: integer; var lInName: string): string; +var +lNameWOExt,lExt: string; +begin + ExtractFileParts (lInName, lNameWOExt,lExt); + result := lNameWOExt+'_'+PadStr(lVol,length(inttostr(lnVol))) +lExt; +end; + + +procedure NIFTIhdr_SwapBytes (var lAHdr: TNIFTIhdr ); //Swap Byte order for the Analyze type +var + lInc: integer; +begin + with lAHdr do begin + swap4(hdrsz); + swap4(extents); + session_error := swap(session_error); + for lInc := 0 to 7 do + dim[lInc] := swap(dim[lInc]); + Xswap4r(intent_p1); + Xswap4r(intent_p2); + Xswap4r(intent_p3); + intent_code:= swap(intent_code); + datatype:= swap(datatype); + bitpix := swap(bitpix); + slice_start:= swap(slice_start); + for lInc := 0 to 7 do + Xswap4r(pixdim[linc]); + Xswap4r(vox_offset); + Xswap4r(scl_slope); + Xswap4r(scl_inter); + slice_end := swap(slice_end); + Xswap4r(cal_max); + Xswap4r(cal_min); + Xswap4r(slice_duration); + Xswap4r(toffset); + swap4(glmax); + swap4(glmin); + qform_code := swap(qform_code); + sform_code:= swap(sform_code); + Xswap4r(quatern_b); + Xswap4r(quatern_c); + Xswap4r(quatern_d); + Xswap4r(qoffset_x); + Xswap4r(qoffset_y); + Xswap4r(qoffset_z); + for lInc := 0 to 3 do begin + Xswap4r(srow_x[lInc]); + Xswap4r(srow_y[lInc]); + Xswap4r(srow_z[lInc]); + end; + end; //with NIFTIhdr +end; //proc NIFTIhdr_Swa + +(*procedure TestUINT16 (lval: integer); +//this procedure demonstrates that words and smallints are identical for values 0..32767, so no need to swap if values are in this range +var +l16ui : WordP; +l16i: SmallIntP; +begin + getmem(l16ui,1*sizeof(word)); + l16ui^[1] := lval; + l16i := SmallIntP(@l16ui^[1]); + fx(l16i^[1],l16ui^[1]); + freemem(l16ui); +end;*) + +procedure Uint16 (var lvBuffer: bytep; lVolOffset: integer; var lInHdr: TNIFTIhdr;var lPrefs: TPrefs; var lByteSwap: boolean); +//kDT_UINT16 saves data range 0..65535, but this is an atypical NIfTI format (not included in earlier Analyze format) +// this procedure saves the data as kDT_SIGNED_SHORT 0..36767 +// if data range is <32767 then saved unchanged, if range is >32767, saved as 15-bit (Least Significant bit clipped). +var + lmax,lv,lnv: integer; + lTempB: ByteP; + l16ui : WordP; + //l16i: SmallIntP; + l32f: SingleP; +begin + lnv := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*NonspatialDimensionsNII(lInHdr); + if (lInHdr.datatype <> kDT_UINT16) or (lnv < 1) then + exit; + l16ui := WordP(@lvBuffer^[lVolOffset]); + if lByteSwap then begin + lmax := swap(l16ui^[1]); + for lv := 1 to lnv do + if swap(l16ui^[lv]) > lmax then + lmax := swap(l16ui^[lv]); + + end else begin + lmax := l16ui^[1]; + for lv := 1 to lnv do + if l16ui^[lv] > lmax then + lmax := l16ui^[lv]; + end; + if lmax < 32768 then begin //lossless: unsigned range <32768 (15 bits), so can be stored in signed 16bit + lInHdr.datatype := kDT_SIGNED_SHORT; + dcmMsg(' brightest voxel was '+inttostr(lmax)+': data will be saved as 16-bit signed integer.'); + (*next lines not required, as range 0..32767 is stored identically for WORDS and SMALLINTS, see TestUINT16 + l16i := SmallIntP(@lvBuffer^[lVolOffset]); + for lv := 1 to lnv do + l16i^[lv] := l16ui^[lv]; *) + end else if not lPrefs.UINT16toFLOAT32 then begin + dcmMsg('Warning: unusual NIFTI format UINT16, range: '+inttostr(lMax) ); + dcmMsg(' If you prefer compatibility, edit your preference named UINT16toFLOAT32'); + end else begin + dcmMsg('Warning: for compatibility, converting UINT16->FLOAT32, range: '+inttostr(lMax) ); + dcmMsg(' If you prefer filesize over compatibility, edit your preference named UINT16toFLOAT32'); + lInHdr.datatype := kDT_Float; + lInHdr.bitpix := 32; + lmax := lVolOffset+ (lnv*sizeof(Word)); + GetMem(lTempB,lmax); + if lByteSwap then begin + dcmMsg(' Swapping data to native byte order (Big vs Little Endian)'); + for lv := 1 to lnv do + l16ui^[lv] := swap(l16ui^[lv]); + end; + for lv := 1 to lmax do + lTempB^[lv] := lvBuffer^[lv]; + freemem(lvBuffer); + GetMem(lvBuffer,lVolOffset+ (lnv*sizeof(single))); + for lv := 1 to lVolOffset do //copy header + lvBuffer^[lv] := lTempB^[lv]; + l16ui := WordP(@lTempB^[lVolOffset]); + l32f := SingleP(@lvBuffer^[lVolOffset]); + for lv := 1 to lnv do + l32f^[lv] :=l16ui^[lv]; + Freemem(lTempB); + end;// if range requires conversion to 32-bit float +end; //Uint16 + + +function getPigzNameWithPath: string; +//returns path to pigz executable, e.g. '/Users/rorden/downloads/pigz-master/pigz'; +var + i: integer; + exename: string; + {$IFDEF DARWIN} temp: string;{$ENDIF} +begin + {$IFDEF ENDIAN_BIG} + Msg('pigz not available with PowerPC computers'); + result := ''; + exit; + {$ENDIF} + for i := 1 to 2 do begin + {$IFDEF UNIX} + if i = 1 then + exename := 'pigz' + else + exename := 'pigz_mricron'; + {$IFDEF GUI} + result := FindDefaultExecutablePath(exename); // "which pigz" + if length(result) > 0 then + exit; + {$ELSE} + result := exename; + if fileexists(result) then exit; + result := ExtractFilePath( paramstr(0))+exename; + if fileexists(result) then exit; + result := '/usr/bin/'+exename; + if fileexists(result) then exit; + result := '/usr/local/bin/'+exename; + if fileexists(result) then exit; + {$ENDIF} + {$ELSE} + if i = 1 then + exename := 'pigz.exe' + else + exename := 'pigz_mricron.exe'; + {$ENDIF} + result := ExtractFilePath( paramstr(0))+exename; + if fileexists(result) then exit; + {$IFDEF DARWIN} + temp := result; + result := ExtractFilePath(paramstr(0)); + result := LeftStr(result, Pos((ExtractFileName(paramstr(0))+'.app'), result)-1)+exename; + if fileexists(result) then exit; + {$ENDIF} + end; //for i:= 1 to 2 + + + {$IFDEF DARWIN} + {$IFDEF GUI} + dcmMsg('File compression error: pigz does not exist in you path or '+result+' or '+temp); + {$ELSE} + dcmMsg('File compression error: to use "pigz" place it in the same folder as '+ paramstr(0)); + {$ENDIF} + {$ELSE} + {$IFDEF GUI} + dcmMsg('File compression error: pigz does not exist in you path or '+result); + {$ELSE} + dcmMsg('File compression error: to use "pigz" place it in the same folder as '+ paramstr(0)); + {$ENDIF} + {$ENDIF} + result := ''; +end; + +{$IFDEF FPC} //Freepascal has handy 'Process' for calling console applications +function runPigz(var lImgName : string; processes: integer): boolean; +// abs(processes): 1= default (as many as available, 2..n: use this many processors +// if processes is a NEGATIVE value, application does not wait for Pigz to complete... +var + AProcess: TProcess; + Acmd: string; + AResponse: TStringList; + i: integer; +begin + Acmd := getPigzNameWithPath; //+' -k' //<- to KEEP original + if length(Acmd) < 1 then exit; + //Acmd := Acmd +' -v -k';//verbose, keep files + if abs(processes) > 1 then + Acmd := Acmd + ' -p '+inttostr( abs(processes) ); + Acmd := Acmd +' '+lImgName; + dcmMsg('External compression: '+Acmd); + AProcess := TProcess.Create(nil); + //AProcess.Environment.Add('FSLDIR='/usr/local/fsl/); //optional + AProcess.CommandLine := Acmd; + if (processes > 0) then //wait for pgzip to complete... + AProcess.Options := AProcess.Options + [poWaitOnExit, poStderrToOutPut, poUsePipes] + else //do not wait for pigz + AProcess.Options := AProcess.Options + [poStderrToOutPut, poUsePipes]; + AProcess.Execute; + if (processes > 0) then begin//wait for pgzip to complete... + AResponse := TStringList.Create; + AResponse.LoadFromStream(AProcess.Output); + if AResponse.Count > 0 then + for i := 1 to AResponse.Count do + dcmMsg(' '+AResponse.Strings[i-1]); + AResponse.Free; + end; + AProcess.Free; +end; +{$ELSE} //Delphi does not have 'Process' for calling console applications + +procedure ExecNewProcess(AppName, ACmd : String; WaitUntilDone: boolean); +var + StartInfo : TStartupInfo; + ProcInfo : TProcessInformation; + CreateOK : Boolean; +begin + { fill with known state } + FillChar(StartInfo,SizeOf(TStartupInfo),#0); + FillChar(ProcInfo,SizeOf(TProcessInformation),#0); + StartInfo.cb := SizeOf(TStartupInfo); + CreateOK := CreateProcess(PChar(AppName),Pchar(Acmd), nil, nil,False, + CREATE_NEW_PROCESS_GROUP+NORMAL_PRIORITY_CLASS, + nil, nil, StartInfo, ProcInfo); + { check to see if successful } + if (CreateOK) and (WaitUntilDone) then + WaitForSingleObject(ProcInfo.hProcess, INFINITE); +end; + +function runPigz(var lImgName : string; processes: integer): boolean; +// abs(processes): 1= default (as many as available, 2..n: use this many processors +// if processes is a NEGATIVE value, application does not wait for Pigz to complete... +var + AppName, Acmd: string; +begin + AppName := getPigzNameWithPath; //+' -k' //<- to KEEP original + if length(AppName) < 1 then exit; + Acmd := ''; + //Acmd := Acmd +' -v -k';//verbose, keep files + if abs(processes) > 1 then + Acmd := Acmd + ' -p '+inttostr( abs(processes) ); + Acmd := Acmd +' "'+lImgName+'"'; + dcmMsg('External compression: '+AppName+' '+Acmd); + Acmd := AppName+' '+Acmd; + ExecNewProcess(AppName, ACmd, (processes > 0)); +end; +{$ENDIF} + + +function SaveNIfTICore (var lOutImgName: string; var lvBuffer: bytep; lVolOffset: integer; var lInHdr: TNIFTIhdr; var lPrefs: TPrefs): string; +//image data should start at lVolOffset - this should be AT LEAST kNIIImgOffset (=352) bytes for creating .nii.gz files +//important note - when converting 4D to 3D to .nii format the lvBuffer is changed :: must correct this +var + lPref : TPrefs; + lVol,lVolStart,lVolBytes: integer; + lOutF: File; + lNoGZName,lHdrName,lImgName: string; + l3dHdr,lOutHdr : TNIFTIHdr; + lHdrBupRA: bytep; + lByteSwap: boolean; +begin + lByteSwap := false; + lNoGZName := (lOutImgName); + StripGZExt(lNoGZName); //we want to convert filename.nii.gz -> filename.hdr not -> filename.nii.hdr + StripNIIVOIExt(lNoGZName);//we want to convert filename.nii.voi to filename.hdr + lPref := lPrefs; + CorrectPrefs(lPref); + result := ''; + Uint16 (lvBuffer,lVolOffset, lInHdr,lPrefs,lByteSwap); + if (not lPref.FourD) and (lInHdr.dim[4] > 1) then begin //4D -> 3D + lVolBytes := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*trunc(((lInHdr.bitpix)+7)/8); + lVolStart := lVolOffset; + l3dHdr := lInHdr; + l3dHdr.dim[4] := 1; + for lVol := 1 to lInHdr.dim[4] do begin + //1st - save header + lHdrName := AddFileNum(lVol,lInHdr.dim[4],lNoGZName); + result := SaveNIfTICore (lHdrName, lvBuffer, lVolStart, l3dHdr, lPref); + lVolStart := lVolStart + lVolBytes; + //SaveNiftiCore new filename, new offset + end; //for each vol + exit; + end; //l4Dto3D + Filemode := 2; + lVolBytes := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lInHdr.dim[4]*trunc(((lInHdr.bitpix)+7)/8); + if ((kNIIImgOffset+lVolBytes)> DiskFreeEx(lNoGZName)) then begin + dcmMsg('There is not enough free space on the destination disk to save the data. '+kCR+ + lNoGZName+ kCR+' Bytes Required: '+inttostr(lVolBytes) ); + exit; + end; + + if (lPref.SingleNIIFile) then begin + lVolStart := lVolOffset-kNIIImgOffset; + lVolBytes := lVolBytes + kNIIImgOffset; + if lVolStart < 1 then begin + dcmMsg('SaveNIfTICore Error: '+inttostr(lVolStart)); + exit; + end; + + getmem(lHdrBupRA,kNIIImgOffset); + Move(lvBuffer^[lVolStart],lHdrBupRA^[1],kNIIImgOffset); + //bytes 349,350,351,352 should be set to zero + lVol := 0; + lvBuffer^[kNIIImgOffset-3+lVol] := 0; + lvBuffer^[kNIIImgOffset-2+lVol] := 0; + lvBuffer^[kNIIImgOffset-1+lVol] := 0; + lvBuffer^[kNIIImgOffset+lVol] := 0; + //next - create [potentially byte swapped] header and load into buffer + lImgName := changefileext(lNoGZName,'.nii'); + + SaveHdrRAM (lImgName,lInHdr,lOutHdr, lByteSwap,lPrefs.SPM2); + Move(lOutHdr,lvBuffer^[lVolStart],sizeof(lOutHdr)); //move 348 byte header in place + //finally - write buffer to disk + if (lPrefs.Gzip) and (lPrefs.usePigz <> 0) and (length(getPigzNameWithPath) > 0) then begin + AssignFile(lOutF, lImgName); + Rewrite(lOutF,1); + BlockWrite(lOutF, lvBuffer^[lVolStart], lVolBytes); + CloseFile(lOutF); + runPigz(lImgName, lPrefs.usePigz); + //DeleteFile(lImgName); + end else if lPrefs.Gzip then begin + if lPrefs.VOI then + lImgName := changefileext(lNoGZName,'.voi') + else + lImgName := changefileext(lNoGZName,'.nii.gz'); + dcmMsg('GZip...' + extractfilename(lImgName)); + GZipBuffer(lImgName, @lvBuffer^[lVolStart],lVolBytes,true); + + + end else begin //not .nii.gz -> .nii + dcmMsg('Saving '+lImgName); + AssignFile(lOutF, lImgName); + Rewrite(lOutF,1); + BlockWrite(lOutF, lvBuffer^[lVolStart], lVolBytes); + CloseFile(lOutF); + end; //else no GZip + Move(lHdrBupRA^[1],lvBuffer^[lVolStart],kNIIImgOffset); //replace data overwritten by header - otherwise 4D->3D corrupts lvBuffer + freemem(lHdrBupRA); + end else begin //not .nii -> hdr and img + lHdrName := changefileext(lNoGZName,'.hdr'); + lImgName := changefileext(lNoGZName,'.img'); + //next - create [potentially byte swapped] header and save to disk + if not SaveHdr (lHdrName,lInHdr, lByteSwap,lPrefs.SPM2) then + exit; + //finally - write buffer to disk + AssignFile(lOutF, lImgName); + Rewrite(lOutF,1); + BlockWrite(lOutF, lvBuffer^[lVolOffset], lVolBytes); + CloseFile(lOutF); + end; //else hdr+img + + result := lImgName; +end; + +function SaveNIfTICoreCrop (var lOutImgName: string; var lvBuffer: bytep; lVolOffset,lStartClip,lEndClip: integer; var lInHdr: TNIFTIhdr; var lPrefs: TPrefs): string; +var + lVolStart,lVolBytes: integer; + lClipName: string; + lClipHdr : TNIFTIHdr; +begin + result := ''; + if (lStartClip < 0) or (lEndClip < 0) then + exit; //no negative values + if (lStartClip <= 0) and (lEndClip <= 0) then + exit; //no change + if (lStartClip+lEndClip) >= lInHdr.dim[4] then + exit; //can not remove this many volumes + lVolBytes := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*trunc(((lInHdr.bitpix)+7)/8); + lClipHdr := lInHdr; + lClipHdr.dim[4] := lInHdr.dim[4]-lStartClip-lEndClip; + lVolStart := lVolOffset + (lStartClip*lVolBytes); + lClipName := ChangeFilePrefix (lOutImgName,'x'); + result := SaveNIfTICore (lClipName, lvBuffer, lVolStart, lClipHdr, lPrefs); +end; + +function SubBound (lVal,lMin: integer): integer; +begin + result := lVal; + if result < lMin then + result := lMin; +end; + +function NonspatialDimensionsNII (lA: TNIFTIhdr): integer; +//returns sum of 4th, 5th, 6th and 7th dimension... +begin + result := SubBound(lA.dim[4],1)*SubBound(lA.dim[5],1)*SubBound(lA.dim[6],1)*SubBound(lA.dim[7],1); +end; + +procedure NIFTIhdr_UnswapImgX (var lHdr: TNIFTIHdr; var lImgBuffer: byteP; var lImgOffset: integer; var lByteSwap: boolean); //ensures image data is in native space +//returns data in native endian +//sets 'ByteSwap' flag to false. E.G. a big-endian image will be saved as little-endian on little endian machines +var + lInc,lImgSamples : integer; + //2f : SingleP; + l32i : LongIntP; + l16i : SmallIntP; +begin + if not lByteSwap then exit; + case lHdr.datatype of + kDT_UNSIGNED_CHAR : begin + lByteSwap := false; //single byte data - no need to byte swap... + exit; + end; + kDT_SIGNED_SHORT,kDT_SIGNED_INT,kDT_FLOAT: ;//supported format + else begin + dcmMsg('niftiutil UnSwapImg error: datatype not supported.'); + exit; + end; + end; //case + lImgSamples := lHdr.Dim[1] *lHdr.Dim[2]*lHdr.Dim[3]*NonspatialDimensionsNII(lHdr); + if lImgSamples < 1 then + exit; + case lHdr.datatype of + kDT_SIGNED_SHORT: begin + l16i := SmallIntP(@lImgBuffer^[lImgOffset+1]); + for lInc := 1 to lImgSamples do + l16i^[lInc] := Swap(l16i^[lInc]); + end; //l16i + kDT_SIGNED_INT,kDT_FLOAT: begin + //note: for the purposes of byte swapping, floats and long ints are the same + l32i := LongIntP(@lImgBuffer^[lImgOffset+1]); + for lInc := 1 to lImgSamples do + Swap4(l32i^[lInc]); + end;//32i + (*kDT_FLOAT: begin + l32f := SingleP(@lImgBuffer^[lImgOffset+1]); + for lInc := 1 to lImgSamples do + pswap4r(l32f^[lInc]); //faster as procedure than function see www.optimalcode.com + end; //32f*) + end; //case + lByteSwap := false; +end; + +function NIFTIhdr_LoadImgRaw (LoadHdr: boolean; var lFilename: string; var lHdr: TNIFTIHdr; var lImgBuffer: byteP; var lImgOffset: integer; var lOpts: TNIIopts ): boolean; +//ImgBuffer always offset by kNIIImgOffset- this allows rapid nii.gz creation +//loads img to byteP - if this returns successfully you must freemem(lImgBuffer) +var + lVol,lFileBytes,lImgBytes: integer; + lBuf: ByteP; + lInF: File; +begin + result := false; + if loadHdr then begin + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lOpts) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + end;//if we load the header from disk... + lImgOffset := kNIIImgOffset;// (=352) bytes for creating .nii.gz files + lVol := NonspatialDimensionsNII(lHdr);//lHdr.dim[4]; + if lVol < 1 then + lVol := 1; + lImgBytes := lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3]*lVol*(lHdr.bitpix div 8); + if not fileexists(lOpts.ImgName) then begin + dcmMsg('LoadImg Error: Unable to find '+lOpts.ImgName); + exit; + end; + if (lOpts.gzBytes = K_gzBytes_headerAndImageUncompressed) and (FSize (lOpts.ImgName) < ( lImgBytes+round(lHdr.vox_offset))) then begin + dcmMsg('LoadImg Error: File smaller than expected '+lOpts.ImgName); + exit; + end; + lFileBytes := lImgBytes+ lImgOffset; + GetMem(lImgBuffer,lFileBytes); + if (lOpts.gzBytes <> K_gzBytes_headerAndImageUncompressed) then begin + lBuf := @lImgBuffer^[lImgOffset+1]; + + if lOpts.gzBytes = K_gzBytes_headerAndImageCompressed then + UnGZip (lOpts.ImgName,lBuf, round(lHdr.vox_offset),lImgBytes) + else + UnGZip2 (lOpts.ImgName,lBuf, 0,lImgBytes, round(lHdr.vox_offset)); + end else begin + AssignFile(lInF, lOpts.ImgName); + Reset(lInF,1); + Seek(lInF,round(lHdr.vox_offset)); + Filemode := 0; //ReadONly + BlockRead(lInF, lImgBuffer^[lImgOffset+1],lImgBytes); + CloseFile(lInF); + end; + Filemode := 2; //Read/Write + NIFTIhdr_UnswapImgX(lHdr, lImgBuffer, lImgOffset,lOpts.bs); + result := true; +end; //NIFTIhdr_LoadImgRaw + +function NIFTIhdr_LoadImg (var lFilename: string; var lHdr: TNIFTIHdr; var lImgBuffer: byteP; var lImgOffset: integer; var lOpts: TNIIOpts): boolean; +begin + result := NIFTIhdr_LoadImgRaw (true, lFilename, lHdr, lImgBuffer, lImgOffset, lOpts); +end; +(*function NIFTIhdr_LoadImg (var lFilename: string; var lHdr: TNIFTIHdr; var lImgBuffer: byteP; var lImgOffset: integer; var lByteSwap: boolean): boolean; +//ImgBuffer always offset by kNIIImgOffset- this allows rapid nii.gz creation +//loads img to byteP - if this returns successfully you must freemem(lImgBuffer) +var + lExt,lImgName: string; + lVol,lFileBytes,lImgBytes: integer; + lBuf: ByteP; + lGZin: boolean; + lInF: File; +begin + result := false; + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lByteSwap) then begin + Msg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + lExt := UpCaseExt(lFilename); + lGZin := ExtGZ(lFilename); + if lExt = '.VOI' then + lGZin := true; + lImgOffset := kNIIImgOffset;// (=352) bytes for creating .nii.gz files + lVol := lHdr.dim[4]; + if lVol < 1 then + lVol := 1; + lImgBytes := lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3]*lVol*(lHdr.bitpix div 8); + if lExt ='.HDR' then + lImgName := changefileext(lFilename,'.img') + else + lImgName := lFilename; + if not fileexists(lImgName) then begin + Msg('LoadImg Error: Unable to find '+lImgName); + exit; + end; + if (not lGZin) and (FSize (lImgName) < ( lImgBytes)) then begin + Msg('LoadImg Error: File smaller than expected '+lImgName); + exit; + end; + lFileBytes := lImgBytes+ lImgOffset; + GetMem(lImgBuffer,lFileBytes); + if lGZin then begin + lBuf := @lImgBuffer^[lImgOffset+1]; + UnGZip (lImgName,lBuf, round(lHdr.vox_offset),lImgBytes); + end else begin + AssignFile(lInF, lImgName); + Reset(lInF,1); + Seek(lInF,round(lHdr.vox_offset)); + Filemode := 0; //ReadONly + BlockRead(lInF, lImgBuffer^[lImgOffset+1],lImgBytes); + CloseFile(lInF); + end; + Filemode := 2; //Read/Write + result := true; +end; *) + +procedure CustomFilename (var lFilename: string); +var + lNew,lPath,lName,lExt: string; +begin + if not FilenameParts (lFilename, lPath,lName,lExt) then exit; + lNew := GetStr('Rename '+lName); + if lNew = '' then exit; + lFilename := lPath + lNew + lExt; +end; + +function ChangeNIfTISubformat(lHdrName: string; var lHdr: TNIFTIhdr; lPrefs: TPrefs): boolean; +var + lImgBuffer: byteP; + lImgOffset: integer; + lOutImgName: string; + lOpts: TNIIOpts; +begin + result := false; + if not NIFTIhdr_LoadImg (lHdrName, lHdr, lImgBuffer, lImgOffset,lOpts) then exit; + dcmMsg('Changing subformat of '+lHdrName); + lOutImgName := ChangeFilePrefix (lHdrName,'f'); + if lPrefs.CustomRename then + CustomFilename(lOutImgName); + if SaveNIfTICore (lOutImgName, lImgBuffer, lImgOffset+1, lHdr, lPrefs) ='' then exit; + Freemem(lImgBuffer); + result := true; //11/2007 + ExitCode := 0; +end; + + +procedure NIFTIhdr_SlicesToCoord (var lHdr: TNIFTIhdr; lXslice,lYslice,lZslice: integer; var lXmm,lYmm,lZmm: single); +//ignores origin offset +begin + lXmm := (lHdr.srow_x[0]*lXslice)+ (lHdr.srow_x[1]*lYslice)+(lHdr.srow_x[2]*lzslice); + lYmm := (lHdr.srow_y[0]*lXslice)+ (lHdr.srow_y[1]*lYslice)+(lHdr.srow_y[2]*lzslice); + lZmm := (lHdr.srow_z[0]*lXslice)+ (lHdr.srow_z[1]*lYslice)+(lHdr.srow_z[2]*lzslice); +end; + +function NIFTIhdr_LoadHdr (var lFilename: string; var lHdr: TNIFTIHdr; var lOpts: TNIIOpts): boolean; +var + lHdrFile: file; {lOri: array [1..3] of single;} + lBuff: Bytep; + lReportedSz, lSwappedReportedSz,lHdrSz,lFileSz: Longint; + lForeignSwapEndian: boolean; + lExt: string; //1494 +begin + Result := false; //assume error + lOpts.gzBytes := K_gzBytes_headerAndImageUncompressed; + lForeignSwapEndian := false; + if lFilename = '' then exit; + lOpts.Imgname := lFilename; + lExt := UpCaseExt(lFilename); + if lExt = '.IMG' then + lFilename := changeFileExt(lFilename,'.hdr'); + if (lExt = '.BRIK') or (lExt = '.BRIK.GZ') then + lFilename := changeFileExt(lFilename,'.HEAD'); + lExt := UpCaseExt(lFilename); + if lExt = '.HDR' then + lOpts.Imgname := changeFileExt(lFilename,'.img'); + lHdrSz := sizeof(TniftiHdr); + lFileSz := FSize (lFilename); + if lFileSz = 0 then begin + dcmMsg('Unable to find NIFTI header named '+lFilename); + exit; + end; + if lFileSz < lHdrSz then begin + dcmMsg('Error in reading NIFTI header: NIfTI headers need to be at least '+inttostr(lHdrSz)+ ' bytes: '+lFilename); + exit; + end; + FileMode := 0; { Set file access to read only } + if (lExt = '.MGH') or (lExt = '.MGZ') or (lExt = '.MHD') or (lExt = '.MHA') or (lExt = '.NRRD') or (lExt = '.NHDR') or (lExt = '.HEAD') then begin + lOpts.Imgname := lFilename; //will change header name to image name if required + result := readForeignHeader( lOpts.Imgname, lHdr,lOpts.gzBytes, lForeignSwapEndian); //we currently ignore result! + end else begin //native NIfTI + if (lExt = '.NII.GZ') or (lExt = '.VOI') then begin//1388 + lBuff := @lHdr; + UnGZip(lFileName,lBuff,0,lHdrSz); //1388 + lOpts.gzBytes := K_gzBytes_headerAndImageCompressed; + end else begin //if gzip + {$I-} + AssignFile(lHdrFile, lFileName); + FileMode := 0; { Set file access to read only } + Reset(lHdrFile, 1); + {$I+} + if ioresult <> 0 then begin + dcmMsg('Error in reading NIFTI header.'+inttostr(IOResult)); + FileMode := 2; + exit; + end; + BlockRead(lHdrFile, lHdr, lHdrSz); + CloseFile(lHdrFile); + end; + end;//nifti + FileMode := 2; + if (IOResult <> 0) then exit; + lReportedSz := lHdr.HdrSz; + lSwappedReportedSz := lReportedSz; + swap4(lSwappedReportedSz); + if lReportedSz = lHdrSz then begin + lOpts.bs := false; + end else if lSwappedReportedSz = lHdrSz then begin + lOpts.bs := true; + NIFTIhdr_SwapBytes (lHdr); + end else begin + dcmMsg('Warning: the header file is not in NIfTi format [the first 4 bytes do not have the value 348]. Assuming big-endian data.'); + exit; + end; + if (lHdr.dim[0] > 7) or (lHdr.dim[0] < 1) then begin //only 1..7 dims, so this + dcmMsg('Illegal NIfTI Format Header: this header does not specify 1..7 dimensions.'); + exit; + end; + if lHdr.Dim[4] < 1 then + lHdr.Dim[4] := 1; + if lForeignSwapEndian then + lOpts.bs := true; + + result := true; +end; //func Analyzehdr_LoadHdr + +function SaveHdr (var lFilename: ANSIstring; var lInHdr: TNIFTIhdr ; lSwap,lSPM2:boolean): boolean; +var + lOutHdr: TNIFTIhdr; + lExt: string; + lF: File; + lLong: LongINt; +begin + result := false; + if ((sizeof(TNIFTIhdr ))> DiskFreeEx(lFilename)) then begin + dcmMsg('There is not enough free space on the destination disk to save the header. '+kCR+ + lFileName+ kCR+' Bytes Required: '+inttostr(sizeof(TNIFTIhdr )) ); + exit; + end; + if lInHdr.dim[4] > 1 then begin + lInHdr.dim[0] := 4; + end else begin + lInHdr.dim[0] := 3;//3D july2006 + lInHdr.dim[4] := 1;//3D july2006 + end; + {if Fileexists(lFileName) then begin + Msg('Error: the file '+lFileName+' already exists.'); + exit; + end; } + result := true; + move(lInHdr, lOutHdr, sizeof(lOutHdr)) ; + lExt := UpCaseExt(lFileName); + if (lExt='.IMG') or (lExt ='.HDR') then begin + {$IFDEF obsoleteENDIAN_BIG} //OSX PPC + lOutHdr.magic := kswapNIFTI_MAGIC_SEPARATE_HDR; + {$ELSE} + lOutHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + {$ENDIF} + lOutHdr.vox_offset := 0; + if lSPM2 then begin //SPM2 does not recognize NIfTI - origin values will be wrong + lOutHdr.magic := 0; + lOutHdr.qform_code := 0; + lOutHdr.sform_code:= 0; + lOutHdr.quatern_b := 0; + lOutHdr.quatern_c := 0; + lOutHdr.quatern_d := 0; + lOutHdr.qoffset_x := 0; + lOutHdr.qoffset_y := 0; + lOutHdr.qoffset_z := 0; + end; + end else begin + {$IFDEF obsoleteENDIAN_BIG} //OSX PPC + lOutHdr.magic := kswapNIFTI_MAGIC_EMBEDDED_HDR; + {$ELSE} + lOutHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + {$ENDIF} + lOutHdr.vox_offset := kNIIImgOffset;//352 bytes + end; + {$IFDEF obsoleteENDIAN_BIG} //OSX PPC + if not lSwap then + {$ELSE} + if lSwap then + {$ENDIF} + NIFTIhdr_SwapBytes (lOutHdr);{swap to sun format} + Filemode := 1; //1366 + AssignFile(lF, lFileName); {WIN} + if fileexists(lFilename) then + Reset(lF,1) + else + Rewrite(lF,1); + BlockWrite(lF,lOutHdr, sizeof(TNIFTIhdr )); + if (lExt='.IMG') or (lExt ='.HDR') then begin + end else begin + lLong := 0; + BlockWrite(lF,lLong, 4); + end; + CloseFile(lF); + Filemode := 2; //1366 +end; + +procedure SaveHdrRAM (var lFilename: ANSIstring; var lInHdr,lOutHdr: TNIFTIhdr ; lSwap,lSPM2:boolean); +var + lExt: string; +begin + if lInHdr.dim[4] > 1 then begin + lInHdr.dim[0] := 4; + end else begin + lInHdr.dim[0] := 3;//3D july2006 + lInHdr.dim[4] := 1;//3D july2006 + end; + move(lInHdr, lOutHdr, sizeof(lOutHdr)) ; + lExt := UpCaseExt(lFileName); + if (lExt='.IMG') or (lExt ='.HDR') then begin + {$IFDEF obsoleteENDIAN_BIG} //OSX PPC + lOutHdr.magic := kswapNIFTI_MAGIC_SEPARATE_HDR; + {$ELSE} + lOutHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + {$ENDIF} + lOutHdr.vox_offset := 0; + if lSPM2 then begin //SPM2 does not recognize NIfTI - origin values will be wrong + lOutHdr.magic := 0; + lOutHdr.qform_code := 0; + lOutHdr.sform_code:= 0; + lOutHdr.quatern_b := 0; + lOutHdr.quatern_c := 0; + lOutHdr.quatern_d := 0; + lOutHdr.qoffset_x := 0; + lOutHdr.qoffset_y := 0; + lOutHdr.qoffset_z := 0; + end; + end else begin + {$IFDEF obsoleteENDIAN_BIG} //OSX PPC + lOutHdr.magic := kswapNIFTI_MAGIC_EMBEDDED_HDR; + {$ELSE} + lOutHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + {$ENDIF} + lOutHdr.vox_offset := kNIIImgOffset;//352 bytes + + end; + {$IFDEF obsoleteENDIAN_BIG} //OSX PPC + if not lSwap then + {$ELSE} + if lSwap then + {$ENDIF} + NIFTIhdr_SwapBytes (lOutHdr);{swap to sun format} +end; + +procedure NIFTIhdr_SetIdentityMatrixx (var lHdr: TNIFTIHdr); //create neutral rotation matrix +var lInc: integer; +begin + with lHdr do begin + for lInc := 0 to 3 do + srow_x[lInc] := 0; + for lInc := 0 to 3 do + srow_y[lInc] := 0; + for lInc := 0 to 3 do + srow_z[lInc] := 0; + for lInc := 1 to 16 do + intent_name[lInc] := chr(0); + //next: create identity matrix: if code is switched on there will not be a problem + srow_x[0] := 1; + srow_y[1] := 1; + srow_z[2] := 1; + end; +end; //proc NIFTIhdr_IdentityMatrix + +procedure NIFTIhdr_ClearHdr (var lHdr: TNIFTIhdr ); //put sensible default values into header +var lInc: byte; +begin + with lHdr do begin + {set to 0} + HdrSz := sizeof(TNIFTIhdr); + for lInc := 1 to 10 do + Data_Type[lInc] := chr(0); + for lInc := 1 to 18 do + db_name[lInc] := chr(0); + extents:=0; + session_error:= 0; + regular:='r'; + dim_info:=(0); + dim[0] := 4; + for lInc := 1 to 7 do + dim[lInc] := 0; + intent_p1 := 0; + intent_p2 := 0; + intent_p3 := 0; + intent_code:=0; + datatype:=0 ; + bitpix:=0; + slice_start:=0; + for lInc := 1 to 7 do + pixdim[linc]:= 1.0; + vox_offset:= 0.0; + scl_slope := 1.0; + scl_inter:= 0.0; + slice_end:= 0; + slice_code := 0; + xyzt_units := 10; + cal_max:= 0.0; + cal_min:= 0.0; + slice_duration:=0; + toffset:= 0; + glmax:= 0; + glmin:= 0; + for lInc := 1 to 80 do + descrip[lInc] := chr(0);{80 spaces} + for lInc := 1 to 24 do + aux_file[lInc] := chr(0);{80 spaces} + {below are standard settings which are not 0} + bitpix := 16;//vc16; {8bits per pixel, e.g. unsigned char 136} + DataType := 4;//vc4;{2=unsigned char, 4=16bit int 136} + Dim[0] := 3; + Dim[1] := 256; + Dim[2] := 256; + Dim[3] := 128; + Dim[4] := 1; {n vols} + Dim[5] := 1; + Dim[6] := 1; + Dim[7] := 1; + glMin := 0; + glMax := 255; + qform_code := kNIFTI_XFORM_UNKNOWN; + sform_code:= kNIFTI_XFORM_UNKNOWN; + quatern_b := 0; + quatern_c := 0; + quatern_d := 0; + qoffset_x := 0; + qoffset_y := 0; + qoffset_z := 0; + NIFTIhdr_SetIdentityMatrixx(lHdr); + magic := kNIFTI_MAGIC_SEPARATE_HDR; + end; //with the NIfTI header... +end; //proc NIFTIhdr_ClearHdr + +procedure DICOM2AnzHdr (var lBHdr: TNIFTIhdr; lAnonymize: boolean; var lFilename: string; var lDICOMdata: DicomData); +var lInc,lLen: integer; + lStr: string; +begin + NIFTIhdr_ClearHdr(lBHdr); +if not lAnonymize then begin + //next: put PatientID into patient_ID array + lLen := length(lDICOMdata.ProtocolName); + if lLen > 23 then lLen := 23; //24=size of aux_file + if lLen > 0 then begin + lBHdr.aux_file[1] :='!'; + for lInc := 1 to lLen do + lBHdr.aux_file[lInc+1] := lDICOMdata.ProtocolName[lInc]; + end; + (* lLen := length(lDicomData.PatientID); + if lLen > 10 then lLen := 10; //10=size of patient_ID array + if lLen > 0 then + for lInc := 1 to lLen do + lBHdr.patient_id[lInc] := lDicomData.PatientID[lInc]; *) + + //next: put PatientName into Descrip array + (*lLen := length(lDicomData.PatientName); + if lLen > 80 then lLen := 80; //80=size of descrip array + if lLen > 0 then + for lInc := 1 to lLen do + lBHdr.descrip[lInc] := lDicomData.PatientName[lInc];*) + //next: put StudyDate into exp_date array + (* lLen := length(lDicomData.StudyDate); + if lLen > 10 then lLen := 10; //10=size of exp_date array + if lLen > 0 then + for lInc := 1 to lLen do + lBHdr.exp_date[lInc] := lDicomData.StudyDate[lInc]; *) + //next: put AcqTime into exp_time array + (*lLen := length(lDicomData.AcqTime); + if lLen > 10 then lLen := 10; //10=size of exp_time array + if lLen > 0 then + for lInc := 1 to lLen do + lBHdr.exp_time[lInc] := lDicomData.AcqTime[lInc]; *) + //next: put Modality into generated array + (*lLen := length(lDicomData.modality); + if lLen > 10 then lLen := 10; //10=size of generated array + if lLen > 0 then + for lInc := 1 to lLen do + lBHdr.generated[lInc] := lDicomData.modality[lInc];*) +end; //Not anonymized + //next: put TR into db_Name array + lStr := 'TE='+floattostr(lDicomData.TE) +';sec='+realtostr(lDicomData.SecSinceMidnight,4); + if not lAnonymize then + lStr := lStr+';name='+lDicomData.PatientName[lInc] ; + lLen := length(lStr); + if lLen > 80 then lLen := 80; + for lInc := 1 to lLen do + lBHdr.descrip[lInc] := lStr[lInc];{80 spaces} + lStr := lDicomData.ImageComments; + lLen := length(lStr); + if lLen > 24 then lLen := 24; //10=size of generated array + for lInc := 1 to lLen do + lBHdr.aux_file[lInc] := lStr[lInc];//up to 24 + + if lDICOMdata.XYZdim[4] > 1 then + lBHdr.Dim[0] := 4 //4D Data June 2006 + else + lBHdr.Dim[0] := 3; + lBHdr.Dim[1] := lDICOMdata.XYZdim[1]; + lBHdr.Dim[2] := lDICOMdata.XYZdim[2]; + lBHdr.Dim[3] := lDICOMdata.XYZdim[3]; + lBHdr.Dim[4] := lDICOMdata.XYZdim[4]; + lBHdr.pixdim[1]:= lDICOMdata.XYZmm[1]; + lBHdr.pixdim[2]:= lDICOMdata.XYZmm[2]; + lBHdr.pixdim[3]:= lDICOMdata.XYZmm[3]; + lBHdr.pixdim[4] := lDicomData.TR/1000; //convert MS to second = assumes xyzt = 10 + + lBHdr.pixdim[7] := lDICOMdata.SecSinceMidnight; + if lDICOMdata.IntenScale <> 0 then + lBHdr.scl_slope := lDICOMdata.IntenScale + else + lBHdr.scl_slope := 1; + if not specialsingle(lDICOMdata.IntenIntercept) then + lBHdr.scl_inter := lDICOMdata.IntenIntercept //1406 + else lBHdr.scl_inter := 0; + lBHdr.bitpix := 8; //1360 + lBHdr.datatype := 2; //1360 + if lDicomData.Allocbits_per_pixel <> 8 then begin + if lDicomData.Allocbits_per_pixel = 32 then begin + lBHdr.bitpix := 32; + if lDicomData.FloatData then + lBHdr.datatype := 16 + else + lBHdr.datatype := 8; + end else if lDicomData.Allocbits_per_pixel = 64 then begin + lBHdr.bitpix := 64; + lBHdr.datatype := 64; + end else begin //16bits per pixel + lBHdr.bitpix := 16; + lBHdr.datatype := kDT_SIGNED_SHORT; + if (not lDicomData.SignedData) and (lDicomData.Allocbits_per_pixel = 16) then begin + lBHdr.datatype :=kDT_UINT16; + //Msg('NII convert warning: unusual 16-bit UNsigned data format - may not be correctly recognized by all software.'); + end; + end; + end; +end; //proc DICOM2AnzHdr + +function NII_force32 (lSrcName,lDestName: string; lPrefs: TPrefs):string; +var + lPOs,lSrcOffset,lVol,lVox: integer; + l32f : SingleP; + l32is : LongIntP; + l16is : SmallIntP; + l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned: bytep; + lSrcHdr,lDestHdr: TNIFTIhdr; + lOpts: TNIIOpts; +begin + result := ''; + if not NIFTIhdr_LoadHdr (lSrcname, lSrcHdr, lOpts) then exit; + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR : ; + kDT_SIGNED_SHORT: ; + kDT_SIGNED_INT: ; + kDT_FLOAT: begin + dcmMsg('NII convert to 32-bit float error: datatype already 32-bit float.'); + exit; + end; + else begin + dcmMsg('NII convert to 32-bit float error: datatype not supported.'); + exit; + end; + end; //case + lDestHdr := lSrcHdr; //destination has the comments and voxel BPP of source + //lDestHdr.dim[4] := 1; + lDestHdr.datatype := kDT_FLOAT; + lDestHdr.bitpix := 32; + lVol := lDestHdr.Dim[4]; + lVox := lDestHdr.Dim[1]*lDestHdr.Dim[2]*lDestHdr.Dim[3]*lVol; + //load dataset + if not NIFTIhdr_LoadImg (lSrcName, lSrcHdr, lSrcBuffer, lSrcOffset,lOpts) then exit; + l8is := (@lSrcBuffer^[lSrcOffset+1]); + GetMem(lBuffUnaligned ,(4*lVox) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := Align(lBuffUnaligned,16); // not commented - check this + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lPos := 1; + l32f := SingleP(@lBuffAligned^[kNIIImgOffset+lPos] ); + case lSrcHdr.datatype of + kDT_SIGNED_SHORT: l16is := SmallIntP(l8is ); + kDT_SIGNED_INT:l32is := LongIntP(l8is ); + //kDT_FLOAT: l32fs := SingleP(l8is ); + end; //case + if lSrcHdr.datatype = kDT_UNSIGNED_CHAR then begin + for lPos := 1 to lVox do + l32f^[lPos] := l8is^[lPos]; + end else if lSrcHdr.datatype = kDT_SIGNED_SHORT then begin + for lPos := 1 to lVox do + l32f^[lPos] := l16is^[lPos]; + end else if lSrcHdr.datatype = kDT_SIGNED_INT then begin + for lPos := 1 to lVox do + l32f^[lPos] := l32is^[lPos]; + end; + result := SaveNIfTICore (lDestName, lBuffAligned, kNIIImgOffset+1, lDestHdr, lPrefs); + Freemem(lBuffUnaligned); + Freemem(lSrcBuffer); +end; +procedure MakeSym (var l32f: SingleP; var lHdr: TNIFTIhdr); +var + lHalf,lL,lLines,lH,lX,lOffset: integer; + lV : single; +begin + lX := lHdr.Dim[1]; + lHalf := lX div 2; //we will not touch middle voxel of odd data... + lLines := lHdr.Dim[2]*lHdr.Dim[3]*lHdr.Dim[4]; + if (lHalf < 1) or (lLines < 1) then + exit; + + lOffset := 0; + for lL := 1 to lLines do begin + lOffset := lOffset + lX; + for lH := 1 to lHalf do begin + lV := (l32f^[lOffset+lH] + l32f^[lOffset+lX-lH+1]) / 2; + l32f^[lOffset+lH] := lV; + l32f^[lOffset+lX-lH+1] := lV; + end; + end; +end; + +function Rescale_4Dtissuemaps (lSrcName,lDestName: string; lPrefs: TPrefs; lMakeSym: boolean):string; +//takes 4D image where each volume is 8-bit tissue map, saves as 32-bit float, ensures that no voxel has more than kmax or less than kmin intensity +const + kMaxAllTissues = 0.99; + kMinAllTissues = 0.50; //set to 0 to ignore + //kMax= 0.85; + //kMin = 0.000; +var + lScale,lSum: double; + lV,lPOs,lSrcOffset,lVol,lVox: integer; + l32fs,l32f : SingleP; + l32is : LongIntP; + l16is : SmallIntP; + l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned: bytep; + lSrcHdr,lDestHdr: TNIFTIhdr; + lOpts: TNIIOpts; + lSumName: string; +begin + result := ''; + if not NIFTIhdr_LoadHdr (lSrcname, lSrcHdr, lOpts) then exit; + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR : ; + kDT_SIGNED_SHORT: ; + kDT_SIGNED_INT: ; + kDT_FLOAT: ; + else begin + dcmMsg('NII convert to 32-bit float error: datatype not supported.'); + exit; + end; + end; //case + lDestHdr := lSrcHdr; //destination has the comments and voxel BPP of source + //lDestHdr.dim[4] := 1; + lDestHdr.datatype := kDT_FLOAT; + lDestHdr.bitpix := 32; + lVol := lDestHdr.Dim[4]; + lVox := lDestHdr.Dim[1]*lDestHdr.Dim[2]*lDestHdr.Dim[3]*lVol; + //load dataset + if not NIFTIhdr_LoadImg (lSrcName, lSrcHdr, lSrcBuffer, lSrcOffset,lOPts) then exit; + l8is := (@lSrcBuffer^[lSrcOffset+1]); + GetMem(lBuffUnaligned ,(4*lVox) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := Align(lBuffUnaligned,16); // not commented - check this + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lPos := 1; + l32f := SingleP(@lBuffAligned^[kNIIImgOffset+lPos] ); + case lSrcHdr.datatype of + kDT_SIGNED_SHORT: l16is := SmallIntP(l8is ); + kDT_SIGNED_INT:l32is := LongIntP(l8is ); + kDT_FLOAT: l32fs := SingleP(l8is ); + end; //case + if lSrcHdr.datatype = kDT_UNSIGNED_CHAR then begin + for lPos := 1 to lVox do + l32f^[lPos] := l8is^[lPos]; + end else if lSrcHdr.datatype = kDT_SIGNED_SHORT then begin + for lPos := 1 to lVox do + l32f^[lPos] := l16is^[lPos]; + end else if lSrcHdr.datatype = kDT_SIGNED_INT then begin + for lPos := 1 to lVox do + l32f^[lPos] := l32is^[lPos]; + end else if lSrcHdr.datatype = kDT_FLOAT then begin + for lPos := 1 to lVox do + l32f^[lPos] := l32fs^[lPos]; + end; + if lMakeSym then + MakeSym (l32f,lDestHdr); + + //next - ensure that no voxel has sum probability more than kMaxAllTissues + if lVol > 1 then begin //for 4D data... + lVox := lDestHdr.Dim[1]*lDestHdr.Dim[2]*lDestHdr.Dim[3]; //this will be done in 3D, not 4D + for lPos := 1 to lVox do begin + lSum := 0; + for lV := 1 to lVol do + lSum := lSum+ l32f^[lPos + ((lV-1)*lVox )]; //lookup table could speed this up + if (lSum < kMinAllTissues) and (kMinAllTissues > 0) then begin + lScale := kMinAllTissues-lSum; + //add to 5th volume (soft tissue - non-brain + l32f^[lPos + ((5-1)*lVox )] := lScale + l32f^[lPos + ((5-1)*lVox )]; //lookup table could speed this up + end else if lSum > kMaxAllTissues then begin + lScale := (kMaxAllTissues/lSum); + for lV := 1 to lVol do + l32f^[lPos + ((lV-1)*lVox )] := lScale * l32f^[lPos + ((lV-1)*lVox )]; //lookup table could speed this up + end; + end; //each voxel + end; //4D + + (*lVox := lDestHdr.Dim[1]*lDestHdr.Dim[2]*lDestHdr.Dim[3]*lVol; + //next - ensure no voxel is more than kmax + for lPos := 1 to lVox do + if l32f^[lPos] > kMax then + l32f^[lPos] := kMax; + //next - ensure that no voxel is less than kmin + for lPos := 1 to lVox do + if l32f^[lPos] < kMin then + l32f^[lPos] := kMin; *) + result := SaveNIfTICore (lDestName, lBuffAligned, kNIIImgOffset+1, lDestHdr, lPrefs); + + //optional ... SumMap + if lVol > 1 then begin //for 4D data... + lVox := lDestHdr.Dim[1]*lDestHdr.Dim[2]*lDestHdr.Dim[3]; //this will be done in 3D, not 4D + for lPos := 1 to lVox do begin + lSum := 0; + for lV := 1 to lVol do + lSum := lSum+ l32f^[lPos + ((lV-1)*lVox )]; //lookup table could speed this up + l32f^[lPos ] := lSum; //lookup table could speed this up + end; //each voxel + end; //4D + lDestHdr.Dim[4] := 1; + lSumName := ChangeFilePrefix (lDestName,'sum'); + result := SaveNIfTICore (lSumName, lBuffAligned, kNIIImgOffset+1, lDestHdr, lPrefs); + //... end SumMap + Freemem(lBuffUnaligned); + Freemem(lSrcBuffer); +end; + + +function SumTPM (lSrcName,lDestName: string; lPrefs: TPrefs; lTissueTypes2Average: integer):string; +//Sum of first three tissue types (GM, WM, CSF +var + //lScale,lSum: double; + lPOs,lSrcOffset,lVol,lVox,lnVol: integer; + l32fs,l32f : SingleP; + l32is : LongIntP; + l16is : SmallIntP; + l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned: bytep; + lSrcHdr,lDestHdr: TNIFTIhdr; + lOpts: TNIIOpts; + //lSumName: string; +begin + result := ''; + if not NIFTIhdr_LoadHdr (lSrcname, lSrcHdr, lOpts) then exit; + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_SIGNED_INT,kDT_FLOAT: ; + else begin + dcmMsg('SumTPM error: datatype not supported.'); + exit; + end; + end; //case + lDestHdr := lSrcHdr; //destination has the comments and voxel BPP of source + lDestHdr.datatype := kDT_FLOAT; + lDestHdr.bitpix := 32; + lDestHdr.Dim[4] := 1; + lVox := lDestHdr.Dim[1]*lDestHdr.Dim[2]*lDestHdr.Dim[3]; + //load dataset + if not NIFTIhdr_LoadImg (lSrcName, lSrcHdr, lSrcBuffer, lSrcOffset,lOpts) then exit; + l8is := (@lSrcBuffer^[lSrcOffset+1]); + lnVol := NonspatialDimensionsNII(lSrcHdr); + if lnVol > lTissueTypes2Average then + lnVol := lTissueTypes2Average; + if lnVol < 1 then + exit; + GetMem(lBuffUnaligned ,(4*lVox) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := Align(lBuffUnaligned,16); // not commented - check this + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lPos := 1; + l32f := SingleP(@lBuffAligned^[kNIIImgOffset+lPos] ); + for lPos := 1 to lVox do + l32f^[lPos] := 0; + if lSrcHdr.datatype = kDT_UNSIGNED_CHAR then begin + for lVol := 0 to lnVol -1 do + for lPos := 1 to lVox do + l32f^[lPos] := l32f^[lPos]+l8is^[lPos+(lVol*lVox)]; + end else if lSrcHdr.datatype = kDT_SIGNED_SHORT then begin + l16is := SmallIntP(l8is ); + for lVol := 0 to lnVol -1 do + for lPos := 1 to lVox do + l32f^[lPos] := l32f^[lPos]+l16is^[lPos+(lVol*lVox)]; + end else if lSrcHdr.datatype = kDT_SIGNED_INT then begin + l32is := LongIntP(l8is ); + for lVol := 0 to lnVol -1 do + for lPos := 1 to lVox do + l32f^[lPos] := l32f^[lPos]+l32is^[lPos+(lVol*lVox)]; + end else if lSrcHdr.datatype = kDT_FLOAT then begin + l32fs := SingleP(l8is ); + for lVol := 0 to lnVol -1 do + for lPos := 1 to lVox do + l32f^[lPos] := l32f^[lPos]+l32fs^[lPos+(lVol*lVox)]; + end; + result := SaveNIfTICore (lDestName, lBuffAligned, kNIIImgOffset+1, lDestHdr, lPrefs); + lDestHdr.Dim[4] := 1; + + //result := SaveNIfTICore (lSumName, lBuffAligned, kNIIImgOffset+1, lDestHdr, lPrefs,lByteSwap); + //... end SumMap + Freemem(lBuffUnaligned); + Freemem(lSrcBuffer); +end; + + +function SameHdrDim (lAHdr,lBHdr: TNIFTIhdr; lCheck4D, lCheckDataType: boolean): boolean; +var + i: integer; +begin + result := true; + if (lCheckDataType) and (lAHdr.datatype <> lBHdr.datatype) then + result := false; + for i := 1 to 3 do + if (lAHdr.Dim[i] <> lBHdr.Dim[i]) then + result := false; + for i := 1 to 3 do + if (lAHdr.pixdim[i] <> lBHdr.pixdim[i]) then + result := false; + if lCheck4D then + if (lAHdr.Dim[4] <> lBHdr.Dim[4]) then + result := false; + if not result then begin + //fx(1211); + dcmMsg('Image dimensions or datatype differ'); + end; +end; + +function Merge4DFiles (lLowSliceName,lHighSliceName,lDestName: string; lNumberofLowSlicesToCopy: integer; lPrefs: TPrefs):string; +//takes 4D image where each volume is 8-bit tissue map, saves as 32-bit float, ensures that no voxel has more than kmax or less than kmin intensity +var + lVolOffset,lSliceBytes,lV,lLoOffset,lHiOffset,lVol,lVox: integer; + l8iHi,l8iLo,lLoBuffer,lHiBuffer {,lBuffUnaligned,lBuffAligned}: bytep; + lLoHdr,lHiHdr: TNIFTIhdr; + lOptsLo,lOptsHi: TNIIOpts; + lBPP: integer; +begin + result := ''; + if not NIFTIhdr_LoadHdr (lLowSliceName, lLoHdr, lOptsLo) then exit; + if not NIFTIhdr_LoadHdr (lHighSliceName, lHiHdr, lOptsHi) then exit; + if lNumberofLowSlicesToCopy < 1 then + exit; + if not SameHdrDim(lLoHdr, lHiHdr,true,true) then + exit; + case lLoHdr.datatype of + kDT_UNSIGNED_CHAR : lBPP := 1; + kDT_SIGNED_SHORT: lBPP := 2; + kDT_SIGNED_INT:lBPP := 4; + kDT_FLOAT: lBPP := 4; + else begin + dcmMsg('Merge4DFiles error: datatype not supported.'); + exit; + end; + end; //case + //lDestHdr.dim[4] := 1; + lVol := lHiHdr.Dim[4]; + lSliceBytes:= lHiHdr.Dim[1]*lHiHdr.Dim[2] * lBPP; + //load dataset + if not NIFTIhdr_LoadImg (lLowSliceName, lLoHdr, lLoBuffer, lLoOffset,lOptsLo) then exit; + if not NIFTIhdr_loadImg (lHighSliceName, lhiHdr, lhiBuffer, lhiOffset,lOptsHi) then exit; + l8iLo := (@lLoBuffer^[lLoOffset+1]); + l8iHi := (@lHiBuffer^[lHiOffset+1]); + + for lV := 1 to lVol do begin + lVolOffset := (lV - 1) * (lSliceBytes*lHiHdr.Dim[3]); + for lVox := 1 to (lSliceBytes*lNumberofLowSlicesToCopy) do + l8iHi^[lVox+lVolOffset] := l8iLo^[lVox+lVolOffset]; + end; + result := SaveNIfTICore (lDestName, lhiBuffer, kNIIImgOffset+1, lHiHdr, lPrefs); + Freemem(lhiBuffer); + Freemem(lloBuffer); +end; + +function Insert3Din4D (l3DSliceName,l4DSliceName,lDestName: string; lVol2Copy: integer; lPrefs: TPrefs):string; +//takes 4D image where each volume is 8-bit tissue map, saves as 32-bit float, ensures that no voxel has more than kmax or less than kmin intensity +var + lVolOffset,lVolBytes,l3DOffset,l4DOffset,lVox: integer; + l8i4D,l8i3D,l3DBuffer,l4DBuffer {,lBuffUnaligned,lBuffAligned}: bytep; + l3DHdr,l4DHdr: TNIFTIhdr; + lOpts3D,lOpts4D: TNIIOpts; + lBPP: integer; +begin + result := ''; + if not NIFTIhdr_LoadHdr (l3DSliceName, l3DHdr, lOpts3D) then exit; + if not NIFTIhdr_LoadHdr (l4DSliceName, l4DHdr, lOpts4D) then exit; + if lVol2Copy < 1 then + exit; + if not SameHdrDim(l3DHdr, l4DHdr,false,true) then + exit; + case l3DHdr.datatype of + kDT_UNSIGNED_CHAR : lBPP := 1; + kDT_SIGNED_SHORT: lBPP := 2; + kDT_SIGNED_INT:lBPP := 4; + kDT_FLOAT: lBPP := 4; + else begin + dcmMsg('Merge4DFiles error: datatype not supported.'); + exit; + end; + end; //case + //lDestHdr.dim[4] := 1; + // lVol := l4DHdr.Dim[4]; + lVolBytes:= l4DHdr.Dim[1]*l4DHdr.Dim[2]*l4DHdr.Dim[3]* lBPP; + //load dataset + if not NIFTIhdr_LoadImg (l3DSliceName, l3DHdr, l3DBuffer, l3DOffset,lOpts3D) then exit; + if not NIFTIhdr_loadImg (l4DSliceName, l4DHdr, l4DBuffer, l4DOffset,lOpts4D) then exit; + l8i3D := (@l3DBuffer^[l3DOffset+1]); + l8i4D := (@l4DBuffer^[l4DOffset+1]); + lVolOffset := (lVol2Copy - 1) * (lVolBytes); + for lVox := 1 to (lVolBytes) do + l8i4D^[lVox+lVolOffset] := l8i3D^[lVox]; + result := SaveNIfTICore (lDestName, l4DBuffer, kNIIImgOffset+1, l4DHdr, lPrefs); + Freemem(l4DBuffer); + Freemem(l3DBuffer); +end; + + +function NIFTIhdr_LoadImg8bit (var lSrcName: string; var lSrcHdr: TNIFTIHdr; var lSrcBuffer: bytep; var lSrcOffset: integer; var lOPts: TNIIOPts): boolean; + +begin + result := false; + if not NIFTIhdr_LoadImg (lSrcName, lSrcHdr, lSrcBuffer, lSrcOffset,lOpts) then exit; + if lSrcHdr.datatype <> kDT_UNSIGNED_CHAR then begin + dcmMsg('Only able to read 8-bit data.'); + exit; + end; + //NIFTIhdr_UnswapImg(lSrcHdr, lSrcBuffer, lSrcOffset,lByteSwap);//interpolation requires data is in native endian + result := true; +end; + +function MaskImages(lMaskName: string; lFiles: TStrings; lPrefs: TPrefs; lVol: integer; lSaveThresh: boolean): string; +var + lFileOffset,lMaskOffset,lInc,lVox,lPos,lOK: integer; + lMaskHdr,lFileHdr: TNIFTIHdr; + lMaskOpts,lFileOpts: TNIIOpts; + lFilename: string; + lMaskBuffer,lFileBuffer,l8if: bytep; + l32fm,l32fmean, l32fmeanpre: singlep; +begin + result := ''; + if not NIFTIhdr_LoadHdr (lMaskName, lMaskHdr, lMaskOpts) then exit; + if lMaskHdr.datatype <> kDT_FLOAT then begin + dcmMsg('This function only works with 32-bit float data.'); + exit; + end; + lVox := lMaskHdr.Dim[1]*lMaskHdr.Dim[2]*lMaskHdr.Dim[3]; + if lFiles.Count < 1 then exit; + if not NIFTIhdr_LoadImg (lMaskName, lMaskHdr, lMaskBuffer, lMaskOffset,lMaskOpts) then exit; + l32fm := SingleP(@lMaskBuffer^[lMaskOffset+1+ ((lVol-1)* (lVox*4) )]); + //l32fo := SingleP(@lBuffAligned^[kNIIImgOffset+lPos] ); + GetMem(l32fmean ,(4*lVox)); + for lPos := 1 to lVox do + l32fmean^[lPos] := 0; + GetMem(l32fmeanpre ,(4*lVox)); + for lPos := 1 to lVox do + l32fmeanpre^[lPos] := 0; + lOK := 0; + for lInc := 1 to lFiles.Count do begin + lFilename := lFiles.Strings[lInc-1]; + if not NIFTIhdr_LoadImg8bit (lFileName, lFileHdr, lFilebuffer, lFileOffset,lFileOpts) then begin + dcmMsg('Serious error reading '+lFilename); + exit; + end; + if not (SameHdrDim(lMaskHdr,lFileHdr,false,false)) then + //fx(666) + //msg('This function only works with data with identical dimensions.') + else begin + l8if := (@lFilebuffer^[lFileOffset+1]); + for lPos := 1 to lVox do begin + l32fmeanpre^[lPos] := l32fmeanpre^[lPos] + l8if^[lPos]; + if l32fm^[lPos] = 0 then + l8if^[lPos] := 0 + else + l32fmean^[lPos] := l32fmean^[lPos] + l8if^[lPos]; + end; + lFilename := ChangeFilePrefix (lFilename,'z'); + if lSaveThresh then + result := SaveNIfTICore (lFilename, lFileBuffer, lFileOffset+1, lFileHdr, lPrefs); + inc(lOK); + end; + Freemem(lFilebuffer); + end; + if lOK > 1 then begin + lMaskHdr.dim[4] := 1; //save only one volume + lMaskHdr.scl_slope := lFileHdr.scl_slope; + lMaskHdr.scl_inter := lFileHdr.scl_inter; + + l32fm := SingleP(@lMaskBuffer^[lMaskOffset+1]); + for lPos := 1 to lVox do + l32fm^[lPos] := l32fmean^[lPos]/lOK; + lFilename := ChangeFilePrefix (lMaskName,'mean'+inttostr(lVol)); + result := SaveNIfTICore (lFilename, lMaskBuffer, lMaskOffset+1, lMaskHdr, lPrefs); + for lPos := 1 to lVox do + l32fm^[lPos] := l32fmeanpre^[lPos]/lOK; + lFilename := ChangeFilePrefix (lMaskName,'meanpre'+inttostr(lVol)); + result := SaveNIfTICore (lFilename, lMaskBuffer, lMaskOffset+1, lMaskHdr, lPrefs); + end; + Freemem(l32fmean); + Freemem(lMaskBuffer); +end; + +function lDigitChar (lString: string): integer; +//returns position of first number in filename, e.g. c:\x1xx.nii would return 5, since '1' is 5th char +var + lP, lLen: integer; +begin + result := 0; + lLen := length(lString); + if lLen < 1 then + exit; + for lP := lLen downto 1 do begin + if lString[lP] in ['0'..'9'] then + result := lP; + if lString[lP] in ['/','\'] then + exit; + end; + +end; + +function Binarize(lC1Name: string; lPrefs: TPrefs ): string; +const + kMaps = 5; + kInten: array [1.. kMaps] of integer = ({graymatter}4,{whitematter}5,{csf}3,{bone}2,{soft tissue}1); +var + //lFileOffset,lMaskOffset,lInc,lVox,lPos,lOK: integer; + lHname : array [1..kMaps] of string; + lH: array [1..kMaps] of TNIFTIHdr; + lMax,lMaxV,lV,lVox,lMap,lCharPos: integer; + lHOpts: TNIIOpts; + //lFilename: string; + lHBuffer,lH8i: array [1..kMaps] of bytep; + lHOffset: array [1..kMaps] of integer; + //l32fm,l32fmean, l32fmeanpre: singlep; +begin + result := ''; + lCharPos := lDigitChar (lC1Name); + if lCharPos < 1 then begin + dcmMsg('Error: number should be in filename.'); + exit; + end; + for lMap := 1 to kMaps do begin + lHname[lMap] := lC1Name; + lHname[lMap][lCharPos] := inttostr(lMap)[1]; + if not fileexists(lHname[lMap]) then begin + dcmMsg('Can not find '+lHname[lMap]); + exit; + end; + end; + + for lMap := 1 to kMaps do begin + if not NIFTIhdr_LoadImg8bit (lHname[lMap], lH[lMap], lHBuffer[lMap], lHOffset[lMap],lHOpts) then begin + dcmMsg('Serious error reading '+lHname[lMap]); + exit; + end; + lH8i[lMap] := (@lHBuffer[lMap]^[lHOffset[lMap]+1]); + end; + lVox := lH[1].Dim[1]*lH[1].Dim[2]*lH[1].Dim[3]; + (*for lV := 1 to lVox do begin + lMax := lH8i[4]^[lV] * 2; + if lMax > 1 {255} then lMax := 255; + lH8i[4]^[lV] := 255; + end; *) + for lV := 1 to lVox do begin + lMax := kMaps; + lMaxV := lH8i[kMaps]^[lV]; + for lMap := (kMaps-1) downto 1 do begin + if lH8i[lMap]^[lV] > lMaxV then begin + lMax := lMap; + lMaxV := lH8i[lMap]^[lV]; + end; + end; + lMax := kInten[lMax]; + //if lMax = kMaps then lMax := 0; + if lMaxV < 25 then lMax := 0; + lH8i[1]^[lV] := lMax; + end; + lH[1].dim[4] := 1; //save only one volume + lH[1].scl_slope := 1; + lH[1].scl_inter := 0; + lHname[1][lCharPos] := 'b'; + result := SaveNIfTICore (lHname[1], lHBuffer[1], lHOffset[1]+1, lH[1], lPrefs); + for lMap := 1 to kMaps do + Freemem(lHBuffer[lMap]); +end; + +(*function NIFTIhdr_LoadImgAs32float (var lSrcName: string; var lSrcHdr: TNIFTIHdr; var lSrcBuffer: bytep; var l32f: singlep; var lSrcOffset: integer; var lByteSwap: boolean): boolean; +//function NIFTIhdr_LoadImgAs32float (var lSrcName: string; var lSrcHdr: TNIFTIHdr; {var lSrcBuffer: bytep;} var l32f: singlep; var lSrcOffset: integer; var lByteSwap: boolean): boolean; +var + l32is : LongIntP; + l16is : SmallIntP; + lImgBuffer,l8is: bytep; + lPos,lVox: integer; + //lSrcBuffer: bytep; +begin + result := false; + if not NIFTIhdr_LoadImg (lSrcName, lSrcHdr, lImgBuffer, lSrcOffset,lByteSwap) then exit; + NIFTIhdr_UnswapImg(lSrcHdr, lImgBuffer, lSrcOffset,lByteSwap);//interpolation requires data is in native endian + result := true; + l8is := (@lImgBuffer^[lSrcOffset+1]); + + //GetMem(l32f ,4*lVox ); + case lSrcHdr.datatype of + kDT_SIGNED_SHORT: l16is := SmallIntP(l8is ); + kDT_SIGNED_INT:l32is := LongIntP(l8is ); + kDT_FLOAT: begin l32f := SingleP(l8is ); lSrcBuffer := lImgBuffer; {<- not sure if this works!} exit; end; + end; //case + lVox := lSrcHdr.Dim[1]*lSrcHdr.Dim[2]*lSrcHdr.Dim[3]; + GetMem(lSrcBuffer ,(4*lVox) +lSrcOffset); + l32f := SingleP(@lSrcBuffer^[lSrcOffset+1]); + + if lSrcHdr.datatype = kDT_UNSIGNED_CHAR then + for lPos := 1 to lVox do + l32f^[lPos] := l8is^[lPos] + else if lSrcHdr.datatype = kDT_SIGNED_SHORT then + for lPos := 1 to lVox do + l32f^[lPos] := l16is^[lPos] + else if lSrcHdr.datatype = kDT_SIGNED_INT then + for lPos := 1 to lVox do + l32f^[lPos] := l32is^[lPos]; + result := true; + freemem(lImgBuffer); + lSrcHdr.datatype := kDT_FLOAT; +end; *) + + +function As32 (lSrcName: string; var lSrcHdr:TNIFTIhdr; var l32f: singlep):boolean; +//takes 4D image where each volume is 8-bit tissue map, saves as 32-bit float, ensures that no voxel has more than kmax or less than kmin intensity +var +(* lScale,lSum: double; + lV,lPOs,lSrcOffset,lVol,lVox: integer; + l32fs,l32f : SingleP; + l32is : LongIntP; + l16is : SmallIntP; + l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned: bytep; + lSrcHdr,lDestHdr: TNIFTIhdr; *) + l32is : LongIntP; + l32fs : SingleP; + l16is : SmallIntP; + l8is,lSrcBuffer: bytep; + lSrcOffset,lVox,lPos: integer; + lOpts: TNIIOpts; +begin + result := false; + if not NIFTIhdr_LoadHdr (lSrcname, lSrcHdr, lOpts) then exit; + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR : ; + kDT_SIGNED_SHORT: ; + kDT_SIGNED_INT: ; + kDT_FLOAT: ; + else begin + dcmMsg('NII convert to 32-bit float error: datatype not supported.'); + exit; + end; + end; //case + lVox := lSrcHdr.Dim[1]*lSrcHdr.Dim[2]*lSrcHdr.Dim[3]; + //load dataset + if not NIFTIhdr_LoadImg (lSrcName, lSrcHdr, lSrcBuffer, lSrcOffset,lOpts) then exit; + l8is := (@lSrcBuffer^[lSrcOffset+1]); + GetMem(l32f ,lVox * sizeof(single)); + //lPos := 1; + case lSrcHdr.datatype of + kDT_SIGNED_SHORT: l16is := SmallIntP(l8is ); + kDT_SIGNED_INT:l32is := LongIntP(l8is ); + kDT_FLOAT: l32fs := SingleP(l8is ); + end; //case + if lSrcHdr.datatype = kDT_UNSIGNED_CHAR then begin + for lPos := 1 to lVox do + l32f^[lPos] := l8is^[lPos]; + end else if lSrcHdr.datatype = kDT_SIGNED_SHORT then begin + for lPos := 1 to lVox do + l32f^[lPos] := l16is^[lPos]; + end else if lSrcHdr.datatype = kDT_SIGNED_INT then begin + for lPos := 1 to lVox do + l32f^[lPos] := l32is^[lPos]; + end else if lSrcHdr.datatype = kDT_FLOAT then begin + for lPos := 1 to lVox do + l32f^[lPos] := l32fs^[lPos]; + for lPos := 1 to lVox do + if specialsingle(l32f^[lPos]) then + l32f^[lPos] := 0; + end; + + + freemem(lSrcBuffer); + result := true; + +end; +//function MaskImgs(lC1template, lC1source: string; lPrefs: TPrefs ; lThresh: integer): string; +function MaskImg(ltemplate, lsource: string; lPrefs: TPrefs; lThresh: single ): string; +label + 666; +var + lH,lT: TNIFTIHdr; + lV,lVox,lHOffset: integer; + lHOpts: TNIIOpts; + l32fs : SingleP; + l8is,lHBuffer: bytep; + lOutname: string; +begin + result := ''; + if (not fileexists(lsource)) then begin + dcmMsg('Can not find '+ lsource); + exit; + end; + + if (not fileexists(ltemplate)) then begin + dcmMsg('Can not find '+ ltemplate); + exit; + end; + //if not NIFTIhdr_LoadImgAs32float (lsource, lH, lHBuffer, lHOffset,lHSwap) then begin + if not NIFTIhdr_LoadImg8bit (lsource, lH, lHBuffer, lHOffset,lHOpts) then begin + dcmMsg('Serious error reading '+lsource); + exit; + end; + //function NIFTIhdr_LoadImgAs32float (var lSrcName: string; var lSrcHdr: TNIFTIHdr; var lSrcBuffer: bytep; var l32f: singlep; var lSrcOffset: integer; var lByteSwap: boolean): boolean; + if not As32 (ltemplate, lT, l32fs) then begin + dcmMsg('Serious error reading '+ltemplate); + exit; + end; + lVox := lH.Dim[1]*lH.Dim[2]*lH.Dim[3]; + if not SameHdrDim (lH,lT, false, false) then begin + dcmMsg('Image dimensions do not match: '+ltemplate+' <> '+lsource); + goto 666; + end; + l8is := (@lHBuffer^[lHOffset+1]); + for lV := 1 to lVox do + if (l32fs^[lV] < lThresh) then + l8is^[lV] := 0; + lH.dim[4] := 1; //save only one volume + lH.scl_slope := 1; + lH.scl_inter := 0; + lOutname := ChangeFilePrefix(lsource,'m'); + dcmMsg(lsource +' masked with '+ltemplate +' = '+lOutname); + result := SaveNIfTICore (loutname, lHBuffer, lHOffset+1, lH, lPrefs); +666: + Freemem(l32fs); + Freemem(lHBuffer); +end; + + + +function MaskImgs(lC1template, lC1source: string; lPrefs: TPrefs ; lThresh: single): string; +const + kMaps = 5; +var + lTName,lSName: string; + lMap,lSPos,lTPos: integer; +begin + result := ''; + lSPos := lDigitChar (lC1source); + lTPos := lDigitChar (lC1template); + if (lSPos < 1) or (lTPos < 1) then begin + dcmMsg('Error: number should be in filenames: '+lC1template+' '+ lC1source); + exit; + end; + lSname:= lC1source; + lTname:= lC1template; + + for lMap := 1 to kMaps do begin + lSname[lSPos] := inttostr(lMap)[1]; + lTname[lTPos] := inttostr(lMap)[1]; + //msg(lTName+' '+ lSName); + if ( fileexists(lTName)) and ( fileexists(lSName)) then + result := MaskImg(lTName, lSName, lPrefs, lThresh) ; + end; + dcmMsg('Masking completed'); +end; + + + + +end. + diff --git a/dcm2nii/niftiutil.ppu b/dcm2nii/niftiutil.ppu new file mode 100644 index 0000000..da2765b Binary files /dev/null and b/dcm2nii/niftiutil.ppu differ diff --git a/dcm2nii/nii_3dto4d.o b/dcm2nii/nii_3dto4d.o new file mode 100644 index 0000000..021ef16 Binary files /dev/null and b/dcm2nii/nii_3dto4d.o differ diff --git a/dcm2nii/nii_3dto4d.pas b/dcm2nii/nii_3dto4d.pas new file mode 100755 index 0000000..8ff4074 --- /dev/null +++ b/dcm2nii/nii_3dto4d.pas @@ -0,0 +1,456 @@ +unit nii_3dto4d; +{$H+} + + +interface + +uses +{$IFDEF FPC}gzio2,{$ENDIF} + SysUtils,define_types,dicomtypes,niftiutil,prefs,classes,dialogs_msg, nifti_types; + +function Stack3Dto4D(var lStr: TStringList; lOverwrite: boolean; lPrefs: TPrefs): boolean; +function ExtractNIFTIHdrs(var lStr: TStringList): boolean; + +implementation +uses dialogsx; + +function LeadingZeroFilename (lInX: string): string; +var + lIn: string; + lC,lnPad,lPos,lnDec,lExtPos,lLen: integer; +begin + {$IFDEF Unix} + lIn := lInX; + {$ELSE} + lIn := Lowercase(lInX); + {$ENDIF} + lnPad := 8; + lLen := length(lIn); + result := lIn; + if lLen < 1 then exit; + lExtPos := 1; + while (lExtPos <= lLen) and (lIn[lExtPos] <> '.') do + inc(lExtPos); + if lExtPos <= 1 then + exit; + //lnDec := 0; + lPos := lExtPos -1; + while (lPos > 0) and ( lIn[lPos] in ['0'..'9']) do + dec(lPos); + lnDec := (lExtPos-lPos)-1; + if (lnDec = 0) or (lnDec >= lnPad) then + exit; + result := ''; + if lPos > 0 then + for lC := 1 to lPos do + result := result + lIn[lC]; + for lC := 1 to (lnPad-lnDec) do + result := result + '0'; + for lC := (lPos+1) to lLen do + result := result+lIn[lC]; +end; + +procedure SortStrPadded (var lStr: TStringList); +//file1,file2...file10 not file1,file10..file2 +//may be slow: not a great sorting algorithm +//may be inefficient: not sure if strings are exchanged or only pointers... +var counter, look:integer; temp:Tstrings; +begin + if lStr.Count < 2 then exit; + temp := TStringList.Create; + for counter:=0 to lStr.Count-1 do + temp.Append(LeadingZeroFilename{LowerCase}(lStr[counter])); + for counter:=0 to temp.Count-1 do + for look:=counter+1 to temp.Count-1 do + if temp[look]<temp[counter] then begin + lStr.Exchange(look, counter); + temp.Exchange(look,counter); + end; + temp.Free; +end; + +function PasStr (lStr: string): string; //removes nulls +var + i: integer; + t: string; +begin + result := ''; + for i := 1 to length(lStr) do begin + if (lStr[i] <> kDel) and(lStr[i] <> kTab) and (lStr[i] <> kEsc) and (lStr[i] <> chr(10)) and (lStr[i] <> chr (13)) and (ord(lStr[i]) <> 0) then + result := result + lStr[i]; + end; + result := '"'+result +'"' +end; + +function NIIstr (lFileName: string; lHdr : TNIFTIhdr): string; +begin + result := lFileName + +kTab+'XYZT'+kTab+inttostr(lHdr.Dim[1])+kTab+inttostr(lHdr.Dim[2])+kTab+inttostr(lHdr.Dim[3])+kTab+inttostr(lHdr.Dim[4]) + +kTab+'XYZTmm'+kTab+floattostr(lHdr.PixDim[1])+kTab+floattostr(lHdr.PixDim[2])+kTab+floattostr(lHdr.PixDim[3])+kTab+floattostr(lHdr.PixDim[4]) + +kTab+'Description'+kTab+PasStr(lHdr.descrip) + +kTab+'Data_Type'+kTab+PasStr(lHdr.Data_Type) + +kTab+'db_name'+kTab+PasStr(lHdr.db_name) + +kTab+'aux_file'+kTab+PasStr(lHdr.aux_file) + +kTab+'intent_name'+kTab+PasStr(lHdr.intent_name) + + ; +end; + +function ExtractNIFTIHdrs(var lStr: TStringList): boolean; +var + lHdrName: string; + lHdr : TNIFTIhdr; + lByteSwap: boolean; + lVol,lnVol : integer; + lO: TNIIOpts; +begin + result := false; + lnVol := lStr.Count; + if lnVol < 1 then + exit; + SortStrPadded(lStr); + for lVol := 1 to lnVol do begin + lHdrName := lStr[lVol-1]; + if not NIFTIhdr_LoadHdr (lHdrName, lHdr,lO) then + dcmMsg('Unable to find '+lHdrName) + else + dcmMsg(NIIstr(lHdrName,lHdr)); + + //dcmMsg( inttostr(lVol)+': '+lHdrName); + end; +end; + + +function Stack3Dto4D(var lStr: TStringList; lOverwrite: boolean; lPrefs: TPrefs): boolean; +//function Reorder4D(var lHdrName: string; var lHdr: TNIFTIhdr; lOverwrite: boolean; lPrefs: TPrefs): boolean; +label 123; +var + lOutBuffer,lIBuffer: byteP; + lInOffset,lnVol,l4DVolBytes,l3DVolBytes,lIn3DBytes,l4DBytes,lVol,lInPos,lOutPos,lSlice: integer; + lHdrName,lOutImgName: string; + lHdr1,lHdr2,lOutHdr : TNIFTIhdr; + lO: TNIIOpts; + lPrefs4D: TPrefs; +begin + result := false; + lnVol := lStr.Count; + if lnVol < 2 then begin + dcmMsg('Stack 3D to 4D requires >1 volume'); + exit; + end; + SortStrPadded(lStr); + lHdrName := lStr[0]; + NIFTIhdr_LoadHdr (lHdrName, lHdr1,lO); + for lVol := 1 to lnVol do begin + lHdrName := lStr[lVol-1]; + if not NIFTIhdr_LoadHdr (lHdrName, lHdr2,lO) then begin + dcmMsg('Stack 3D to 4D unable to find '+lHdrName); + exit; + end; + if (lHdr1.dim[4] > 1) then begin + dcmMsg('Stack 3D to 4D aborted, image is already 4D: '+lHdrName ); + exit; + end; + if (lHdr1.dim[1] <> lHdr2.dim[1]) or (lHdr1.dim[2] <> lHdr2.dim[2]) or + (lHdr1.dim[3] <> lHdr2.dim[3]) or (lHdr1.datatype <> lHdr2.datatype) then begin + dcmMsg('Stack 3D to 4D aborted, image dimensions/datatype vary '+lHdrName + ' <> '+lStr[0]); + exit; + end; + //dcmMsg( inttostr(lVol)+': '+lHdrName); + end; + lOutHdr := lHdr1; + lOutHdr.dim[4] := lnVol; + l3DVolBytes := lHdr1.dim[1]*lHdr1.dim[2]*lHdr1.dim[3]*(lHdr1.bitpix div 8); + l4DVolBytes := l3DVolBytes * lnVol; + GetMem(lOutBuffer,l4DVolBytes+kNIIImgOffset); + + dcmMsg('Order in output file:'); + lOutImgName := ChangeFilePrefix (lStr[0],'4D'); + lOutPos := kNIIImgOffset + 1; + for lVol := 1 to lnVol do begin + lHdrName := lStr[lVol-1]; + dcmMsg( inttostr(lVol)+': '+lHdrName); + if not NIFTIhdr_LoadImg (lHdrName, lHdr2, lIBuffer, lInOffset,lO) then begin + dcmMsg('3D -> 4D error loading image '+lHdrName); + goto 123; + end; + Move(lIBuffer^[lInOffset+1],lOutBuffer^[lOutPos],l3DVolBytes); + freemem(lIBuffer); + lOutPos := lOutPos + l3DVolBytes; + end; + lPrefs4D := lPrefs; + lPrefs4D.fourD := true; + dcmMsg('4D image '+lOutImgName); + if SaveNIfTICore (lOutImgName, lOutBuffer, kNIIImgOffset+1, lOutHdr, lPrefs4D) = '' then begin + dcmMsg('3D -> 4D Error'); + goto 123; + end; + + freemem(lOutBuffer); + result := true; + exit; +123: + freemem(lOutBuffer); +end; + + + +(*function Reorder4D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap,lSPM2in,lSingleNIIFile,lGZ,lOverwrite: boolean): boolean; +var + lOutHdr: TNIFTIhdr; + lInName,lImgName: string; + lPos,lSlice,lVol,lInVolBytes,lSliceBytes: integer; + lBuffer: bytep; + lGZi,lSPM2: boolean; + lOutF,lInF: File; +begin + result := false; + lGZi := lGZ; + lSPM2 := lSPM2in; + if lSingleNIIFIle then + lSPM2 := false; + if (lHdr.dim[4] < 2) or (lHdr.dim[3] < 2) then + exit; + lOutHdr := lHdr; + lOutHdr.dim[4] := lHdr.dim[3]; + lOutHdr.dim[3] := lHdr.dim[4]; + lSliceBytes := lHdr.dim[1]*lHdr.dim[2]*(lHdr.bitpix div 8); + lInVolBytes := lSliceBytes*lHdr.dim[3]; + GetMem(lBuffer,lSliceBytes); + if UpCaseExt(lHdrName) ='.HDR' then begin + if lOverwrite then + deletefile(lHdrName); + lInName := changefileext(lHdrName,'.img') + end else begin + lOutHdr.vox_offset := 352; + lInName := lHdrName; + end; + if not fileexists(lInName) then begin + dcmMsg('4Dclip Error: Unable to find '+lInName); + exit; + end; + if FSize (lInName) < ( (lInVolBytes*lHdr.dim[4])+round(lHdr.vox_offset)) then begin + dcmMsg('4Dclip Error: File smaller than expected (can not convert compressed) '+lInName); + exit; + end; + dcmMsg('Reordering image'); + if not lSingleNiiFile then begin + lHdrName := changefileext(lHdrName,'.hdr'); + lImgName := changefileext(lHdrName,'.img'); + lGZi := false; + end else begin + lHdrName := changefileext(lHdrName,'.nii'); + lImgName := changefileext(lHdrName,'.nii'); + end; + if lOverwrite then begin + renamefile(lInName,changefileext(lInName,'.tmp')); + lInName := changefileext(lInName,'.tmp'); + end else begin + lHdrName := ChangeFilePrefixExt (lHdrName,'x'); + lImgName := ChangeFilePrefixExt (lImgName,'x'); + dcmMsg('saving as '+lHdrName); + end; + AssignFile(lInF, lInName); + Reset(lInF,1); + Seek(lInF,round(lHdr.vox_offset)); + SaveHdr (lHdrName,lOutHdr,lByteSwap{ false},lSPM2); + AssignFile(lOutF, lImgName); + if lSingleNIIFile then begin + Reset(lOutF,1); + Seek(lOutF,352); + end else + Rewrite(lOutF,1); + for lVol := 1 to lOutHdr.dim[4] do begin + lPos := ((lVol-1)*lSliceBytes) + round(lHdr.vox_offset); + for lSlice := 1 to lOutHdr.dim[3] do begin + Filemode := 0; //ReadONly + seek(lInF,lPos); + BlockRead(lInF, lBuffer^, lSliceBytes); + Filemode := 2; + BlockWrite(lOutF, lBuffer^, lSliceBytes); + lPos := lPos + lInVolBytes; + end;//for lslice + end; //for lvol + CloseFile(lInF); + CloseFile(lOutF); + Freemem(lBuffer); + if lOverwrite then + DeleteFile(lInName); + if lGZi then + GZipFile(lImgName,lImgName+'.gz',true); + result := true; +end; *) + +(*function Clip4D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap,lSPM2in, lSingleNIIFile,lGZ,lOverwrite: boolean; lStartIn,lEndIn: integer ): string; +var + lOutHdr: TNIFTIhdr; + lInName,lImgName: string; + lVol,lVolBytes,lStart,lEnd: integer; + lBuffer: bytep; + lGZi,lSPM2 : boolean; + lOutF,lInF: File; +begin + result := ''; + lGZi := lGZ; + lSPM2 := lSPM2in; + if lSingleNIIFIle then + lSPM2 := false; + lStart := lStartIn; + if lStart < 0 then + lStart := 0; + lEnd := lEndIn; + if lEnd < 0 then + lEnd := 0; + lOutHdr := lHdr; + lOutHdr.dim[4] := lOutHdr.dim[4]-lStart-lEnd; + if lOutHdr.dim[4] < 1 then + exit; + lVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*(lOutHdr.bitpix div 8); + GetMem(lBuffer,lVolBytes); + if UpCaseExt(lHdrName) ='.HDR' then begin + if lOverwrite then + deletefile(lHdrName); + lInName := changefileext(lHdrName,'.img') + end else begin + lOutHdr.vox_offset := 352; + lInName := lHdrName; + end; + if not fileexists(lInName) then begin + dcmMsg('4Dclip Error: Unable to find '+lInName); + exit; + end; + if FSize (lInName) < ( (lVolBytes*lHdr.dim[4])+round(lHdr.vox_offset)) then begin + dcmMsg('4Dclip Error: File smaller than expected (can not convert compressed) '+lInName); + exit; + end; + if (lStart > 0) or (lEnd > 0) then + dcmMsg('4D clip - removing first '+inttostr(lStart)+' and last '+inttostr(lEnd) +' volumes') + else + dcmMsg('Formatting image'); + if not lSingleNiiFile then begin + lGZi := false; + lHdrName := changefileext(lHdrName,'.hdr'); + lImgName := changefileext(lHdrName,'.img'); + end else begin + lHdrName := changefileext(lHdrName,'.nii'); + lImgName := changefileext(lHdrName,'.nii'); + end; + if lOverwrite then begin + renamefile(lInName,changefileext(lInName,'.tmp')); + lInName := changefileext(lInName,'.tmp'); + end else begin + lHdrName := ChangeFilePrefixExt (lHdrName,'x'); + lImgName := ChangeFilePrefixExt (lImgName,'x'); + dcmMsg('Saving clipped as '+lHdrName); + end; + AssignFile(lInF, lInName); + Reset(lInF,1); + Seek(lInF,round(lHdr.vox_offset)); + SaveHdr (lHdrName,lOutHdr, lByteSwap{false},lSPM2); + AssignFile(lOutF, lImgName); + if lSingleNIIFile then begin + Reset(lOutF,1); + Seek(lOutF,352); + end else + Rewrite(lOutF,1); + for lVol := 1 to (lHdr.dim[4]-lEnd) do begin + //1st - save header + Filemode := 0; //ReadONly + BlockRead(lInF, lBuffer^, lVolBytes); + if (lVol > lStart) then begin + Filemode := 2; + BlockWrite(lOutF, lBuffer^, lVolBytes); + end; + end; + CloseFile(lInF); + CloseFile(lOutF); + Freemem(lBuffer); + if lOverwrite then + DeleteFile(lInName); + if lGZi then begin + lHdrName := lImgName+'.gz'; + GZipFile(lImgName,lHdrName,true); + end; + result := lHdrName; +end; + +function Convert4Dto3D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap, lSPM2in,lSingleNIIFile,lGZ: boolean ): boolean; +var + lOutHdr: TNIFTIhdr; + lOutName,lImgName: string; + lVol,lVolBytes: integer; + lBuffer: bytep; + lSPM2,lGZi: boolean; + lOutF,lInF: File; +begin + result := false; + lSPM2 := lSPM2in; + if lSingleNIIFIle then + lSPM2 := false; + lGZi := lGZ; + if lHdr.dim[4] < 2 then + exit; + lOutHdr := lHdr; + lOutHdr.dim[0] := 3;//3D + lOutHdr.dim[4] := 1; + lVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*(lOutHdr.bitpix div 8); + GetMem(lBuffer,lVolBytes); + //lSingleNIIFile := true; + if UpCaseExt(lHdrName) ='.HDR' then begin + //lSingleNIIFile := false; + lImgName := changefileext(lHdrName,'.img') + end else + lImgName := lHdrName; + if not fileexists(lImgName) then begin + dcmMsg('4D->3D Error: Unable to find '+lImgName); + exit; + end; + if FSize (lImgName) < ( (lVolBytes*lHdr.dim[4])+round(lHdr.vox_offset)) then begin + dcmMsg('4D->3D Error: File smaller than expected (can not convert compressed) '+lImgName); + exit; + end; + //dcmMsg(inttostr(round(lHdr.vox_offset))); + AssignFile(lInF, lImgName); + Reset(lInF,1); + Seek(lInF,round(lHdr.vox_offset)); + if not lSingleNiiFile then begin + lGZi := false; + lHdrName := changefileext(lHdrName,'.hdr'); + lImgName := changefileext(lHdrName,'.img'); + end else begin + lHdrName := changefileext(lHdrName,'.nii'); + lImgName := changefileext(lHdrName,'.nii'); + end; + for lVol := 1 to lHdr.dim[4] do begin + //1st - save header + lOutName := AddFileNum(lVol,lHdr.dim[4],lHdrName); + SaveHdr (lOutName,lOutHdr,lByteSwap {false},lSPM2); + Filemode := 0; //ReadONly + BlockRead(lInF, lBuffer^, lVolBytes); + + lOutName := AddFileNum(lVol,lHdr.dim[4],lImgName); + Filemode := 2; + AssignFile(lOutF, lOutName); + if (lSingleNIIFile) and (not lSPM2) then begin + Reset(lOutF,1); + Seek(lOutF,352); + end else + Rewrite(lOutF,1); + BlockWrite(lOutF, lBuffer^, lVolBytes); + CloseFile(lOutF); + if lGZi then begin + GZipFile(lOutName,lOutName+'.gz',true); + //DeleteFile(lOutName); + end; + end; + CloseFile(lInF); + Freemem(lBuffer); + //if lDeleteOrig then begin + DeleteFile(lHdrName); + if not lSingleNIIFile then + DeleteFile(lImgName); + //end; +end; *) + + +end. \ No newline at end of file diff --git a/dcm2nii/nii_3dto4d.ppu b/dcm2nii/nii_3dto4d.ppu new file mode 100644 index 0000000..bad43b5 Binary files /dev/null and b/dcm2nii/nii_3dto4d.ppu differ diff --git a/dcm2nii/nii_4dto3d.o b/dcm2nii/nii_4dto3d.o new file mode 100644 index 0000000..b59ee28 Binary files /dev/null and b/dcm2nii/nii_4dto3d.o differ diff --git a/dcm2nii/nii_4dto3d.pas b/dcm2nii/nii_4dto3d.pas new file mode 100755 index 0000000..e2ebf44 --- /dev/null +++ b/dcm2nii/nii_4dto3d.pas @@ -0,0 +1,459 @@ +unit nii_4dto3d; +{$H+} + + +interface + +uses +{$IFDEF FPC}gzio2,{$ENDIF} + SysUtils,define_types,dicomtypes,niftiutil,prefs,nii_orient,nii_crop, nifti_types; + +//function Convert4Dto3D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap,lSPM2in,lSingleNIIFile,lGZ :boolean ): boolean; +//function Clip4D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap,lSPM2in,lSingleNIIFile,lGZ,lOverwrite: boolean; lStartIn,lEndIn: integer ): string; +function ModifyAnalyze(lFilename: string; lPrefs: TPrefs): boolean; +function Clip4D(var lHdrName: string; var lHdr: TNIFTIhdr;lOverwrite: boolean; lPrefs: TPrefs; lStartIn,lEndIn: integer): string; +//function Reorder4D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap,lSPM2in,lSingleNIIFile,lGZ,lOverwrite: boolean): boolean; +function Reorder4D(var lHdrName: string; var lHdr: TNIFTIhdr; lOverwrite: boolean; lPrefs: TPrefs): boolean; + +implementation +uses dialogsx,dialogs_msg; + + + + +function ModifyAnalyze(lFilename: string; lPrefs: TPrefs): boolean; +var + lExt,lOutname: string; + lHdr: TNIFTIhdr; + lFormat,lStartIn,lEndIn, lMinStartIn: integer; + lReorder: boolean; + lPref: TPrefs; + lO: TNIIOpts; +begin + lPref := lPrefs; + result := false; + lStartIn := 0; + lEndIn := 0; + lReorder := false; + lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + if lPrefs.AutoCrop then begin + dcmMsg('Autocrop NIfTI/Analyze image '+lFileName); + lOutname := Reorient(lFilename,lHdr, lPrefs,false,false); + if lOutname <> '' then + CropNIfTI(lOutname,lPrefs); + exit; + end; + dcmMsg('Adjusting NIfTI/Analyze image '+lFileName); + if (lHdr.dim[4] > 1) then begin //if 4D input + if (lPrefs.BeginClip > 0) and (lPrefs.BeginClip < lHdr.dim[4]) then begin + lStartIn := lPrefs.BeginClip; + dcmMsg('Warning: removing first '+inttostr(lStartIn) + ' volumes (preference: BeginClip)'); + end; + if (lStartIn <> lPrefs.BeginClip) then + dcmMsg('Warning preference BeginClip is being ignored (not enough volumes)'); + if (lPrefs.LastClip > 0) and ( (lPrefs.LastClip+ lPrefs.BeginClip) < lHdr.dim[4]) then begin + lEndIn := lPrefs.LastClip; + dcmMsg('Warning: removing final '+inttostr(lEndIn) + ' volumes (preference: LastClip)'); + end; + if (lEndIn <> lPrefs.LastClip) then + dcmMsg('Warning preference LastClip is being ignored (not enough volumes)'); + end;//if 4D input + //next - determine output format + if not lPref.ManualNiFtiConv then begin + lReorder := false; + end else begin //manually specify conversion parameters + lFormat := GetInt('Output: 0=spm2,1=spm5,2=spm8,3=hdr4D,4=fsl,5=fsl.gz ', 0,DefaultOutputFormat (lPrefs),5); + SetOutputFormat(lFormat,lPref); //: 0=SPM2,1=SPM5,2=spm8,3=4D hdr/img,4=fsl(default),5=fsl.gz + + +(* if (lFormat <= 0) then + lPref.SPM2 := true + else + lPref.SPM2 := false; + if (lFormat <= 1) then //0,1 = hdr/img pairs + lPref.singleNIIfile := false + else //>1 = .nii + lPref.singleNIIfile := true; + if (lFormat <= 2) then //0,1,2 = 3D output + lPref.fourD := false + else //>2 = 4D + lPref.fourD := true; + if (lFormat >= 4) then + lPref.GZip := true + else + lPref.GZip := false; *) + //next - 4D images: clip ends or flip order + if lHdr.dim[4] > 1 then begin //4D file + if (lHdr.dim[4] > 1) and (lHdr.dim[3] > 1) then begin + dcmMsg(' Enter a value of -1 to flip 3rd and 4th dimensions.'); + lMinStartIn := -1; + end else + lMinStartIn := 0; + lStartIn := GetInt('Enter volumes to remove from start ', lMinStartIn,lStartIn,lHdr.dim[4]); + if lStartIn >= 0 then + lEndIn := GetInt('Enter volumes to remove from end ' ,0,lEndIn,lHdr.dim[4]); + if ((lStartIn < 0) or (lEndIn < 0)) and (lHdr.dim[4] > 1) and (lHdr.dim[3] > 1) then + lReorder := true + else + lReorder := false; + if lHdr.dim[4] <= (lStartIn+lEndIn) then begin + dcmMsg('Clip Analyze aborted: unable to remove this many volumes.'); + exit; + end; + end;(* else begin //not 4D file + l4Dto3D := false; + lStartIn := 0; + lEndIn := 0; + lReorder := false; + end;//if 4D else *) + end; //manual specification of conversion + // + +(* if lExt = '.NII.GZ' then begin + //lTempName := lFilename;//ChangeFilePrefixExt (lFileName,'x'); + ExtractFileParts (lFileName, lNameWOExt,lExt); + lTempName := lNameWOExt+'.nii'; + Gunzip(lFileName,lTempName); + //dcmMsg('Unzip '+lFilename+'->'+lTempName); + lFilename := lTempName; + end else //not gzip + lTempName := ''; *) + //Next create reordered or trimmed image in the correct format + + if lReorder then begin + if not Reorder4D(lFileName, lHdr, false,lPref) then exit; + //if not Reorder4D(lFileName, lHdr, lByteSwap,lSPM2,lSingleFile,lGZ, false) then exit; + end else if (lStartIn=0) and (lEndIn= 0) then begin + if not ChangeNIfTISubformat(lFileName, lHdr,lPref) then begin + dcmMsg('Error changing format!'); + exit; + end; + end else begin + if Clip4D(lFileName, lHdr, false,lPref,lStartIn,lEndIn)='' then exit; + end; + result := true; + +end; + +function Clip4D(var lHdrName: string; var lHdr: TNIFTIhdr;lOverwrite: boolean; lPrefs: TPrefs; lStartIn,lEndIn: integer): string; +var + lImgBuffer: byteP; + lImgOffset: integer; + lOutImgName: string; + lO: TNIIOpts; +begin + result := ''; + if not NIFTIhdr_LoadImg (lHdrName, lHdr, lImgBuffer, lImgOffset,lO) then exit; + dcmMsg('4D Clipping '+lHdrName); + lOutImgName := ChangeFilePrefix (lHdrName,'f'); + result := SaveNIfTICoreCrop (lOutImgName, lImgBuffer, lImgOffset+1,lStartIn,lEndIn, lHdr, lPrefs); + Freemem(lImgBuffer); + +end; + +function Reorder4D(var lHdrName: string; var lHdr: TNIFTIhdr; lOverwrite: boolean; lPrefs: TPrefs): boolean; +var + lInBuffer,lOutBuffer: byteP; + lImgOffset,lSliceBytes,lIn3DBytes,l4DBytes,lVol,lInPos,lOutPos,lSlice: integer; + lOutImgName: string; + lOutHdr : TNIFTIhdr; + lO: TNIIOpts; +begin + result := false; + if not NIFTIhdr_LoadImg (lHdrName, lHdr, lInBuffer, lImgOffset,lO) then exit; + if (lHdr.dim[4] < 2) or (lHdr.dim[3] < 2) then + exit; + if lOverwrite then + lOutImgName := lHdrName + else + lOutImgName := ChangeFilePrefix (lHdrName,'x'); + lOutHdr := lHdr; + lOutHdr.dim[3] := lHdr.dim[4]; + lOutHdr.dim[4] := lHdr.dim[3]; + lSliceBytes := lHdr.dim[1]*lHdr.dim[2]*(lHdr.bitpix div 8); + lIn3DBytes := lSliceBytes*lHdr.dim[3]; + l4DBytes := lIn3DBytes*lHdr.dim[4]; + dcmMsg('Changing order of dimensions 3 and 4 of '+lHdrName); + GetMem(lOutBuffer,l4DBytes+kNIIImgOffset); + lOutPos := kNIIImgOffset + 1; + for lVol := 1 to lOutHdr.dim[4] do begin + lInPos := ((lVol-1)*lSliceBytes) + lImgOffset+1; + for lSlice := 1 to lOutHdr.dim[3] do begin + Move(lInBuffer^[lInPos],lOutBuffer^[lOutPos],lSliceBytes); + lInPos := lInPos + lIn3DBytes; + lOutPos := lOutPos + lSliceBytes; + end;//for lslice + end; //for lvol + dcmMsg(lOutImgName); + if SaveNIfTICore (lOutImgName, lOutBuffer, kNIIImgOffset+1, lOutHdr, lPrefs) = '' then begin + dcmMsg('Reorder Error'); + Freemem(lInBuffer); + Freemem(lOutBuffer); + exit; + end; + result := true; +end; + +(*function Reorder4D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap,lSPM2in,lSingleNIIFile,lGZ,lOverwrite: boolean): boolean; +var + lOutHdr: TNIFTIhdr; + lInName,lImgName: string; + lPos,lSlice,lVol,lInVolBytes,lSliceBytes: integer; + lBuffer: bytep; + lGZi,lSPM2: boolean; + lOutF,lInF: File; +begin + result := false; + lGZi := lGZ; + lSPM2 := lSPM2in; + if lSingleNIIFIle then + lSPM2 := false; + if (lHdr.dim[4] < 2) or (lHdr.dim[3] < 2) then + exit; + lOutHdr := lHdr; + lOutHdr.dim[4] := lHdr.dim[3]; + lOutHdr.dim[3] := lHdr.dim[4]; + lSliceBytes := lHdr.dim[1]*lHdr.dim[2]*(lHdr.bitpix div 8); + lInVolBytes := lSliceBytes*lHdr.dim[3]; + GetMem(lBuffer,lSliceBytes); + if UpCaseExt(lHdrName) ='.HDR' then begin + if lOverwrite then + deletefile(lHdrName); + lInName := changefileext(lHdrName,'.img') + end else begin + lOutHdr.vox_offset := 352; + lInName := lHdrName; + end; + if not fileexists(lInName) then begin + dcmMsg('4Dclip Error: Unable to find '+lInName); + exit; + end; + if FSize (lInName) < ( (lInVolBytes*lHdr.dim[4])+round(lHdr.vox_offset)) then begin + dcmMsg('4Dclip Error: File smaller than expected (can not convert compressed) '+lInName); + exit; + end; + dcmMsg('Reordering image'); + if not lSingleNiiFile then begin + lHdrName := changefileext(lHdrName,'.hdr'); + lImgName := changefileext(lHdrName,'.img'); + lGZi := false; + end else begin + lHdrName := changefileext(lHdrName,'.nii'); + lImgName := changefileext(lHdrName,'.nii'); + end; + if lOverwrite then begin + renamefile(lInName,changefileext(lInName,'.tmp')); + lInName := changefileext(lInName,'.tmp'); + end else begin + lHdrName := ChangeFilePrefixExt (lHdrName,'x'); + lImgName := ChangeFilePrefixExt (lImgName,'x'); + dcmMsg('saving as '+lHdrName); + end; + AssignFile(lInF, lInName); + Reset(lInF,1); + Seek(lInF,round(lHdr.vox_offset)); + SaveHdr (lHdrName,lOutHdr,lByteSwap{ false},lSPM2); + AssignFile(lOutF, lImgName); + if lSingleNIIFile then begin + Reset(lOutF,1); + Seek(lOutF,352); + end else + Rewrite(lOutF,1); + for lVol := 1 to lOutHdr.dim[4] do begin + lPos := ((lVol-1)*lSliceBytes) + round(lHdr.vox_offset); + for lSlice := 1 to lOutHdr.dim[3] do begin + Filemode := 0; //ReadONly + seek(lInF,lPos); + BlockRead(lInF, lBuffer^, lSliceBytes); + Filemode := 2; + BlockWrite(lOutF, lBuffer^, lSliceBytes); + lPos := lPos + lInVolBytes; + end;//for lslice + end; //for lvol + CloseFile(lInF); + CloseFile(lOutF); + Freemem(lBuffer); + if lOverwrite then + DeleteFile(lInName); + if lGZi then + GZipFile(lImgName,lImgName+'.gz',true); + result := true; +end; *) + +(*function Clip4D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap,lSPM2in, lSingleNIIFile,lGZ,lOverwrite: boolean; lStartIn,lEndIn: integer ): string; +var + lOutHdr: TNIFTIhdr; + lInName,lImgName: string; + lVol,lVolBytes,lStart,lEnd: integer; + lBuffer: bytep; + lGZi,lSPM2 : boolean; + lOutF,lInF: File; +begin + result := ''; + lGZi := lGZ; + lSPM2 := lSPM2in; + if lSingleNIIFIle then + lSPM2 := false; + lStart := lStartIn; + if lStart < 0 then + lStart := 0; + lEnd := lEndIn; + if lEnd < 0 then + lEnd := 0; + lOutHdr := lHdr; + lOutHdr.dim[4] := lOutHdr.dim[4]-lStart-lEnd; + if lOutHdr.dim[4] < 1 then + exit; + lVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*(lOutHdr.bitpix div 8); + GetMem(lBuffer,lVolBytes); + if UpCaseExt(lHdrName) ='.HDR' then begin + if lOverwrite then + deletefile(lHdrName); + lInName := changefileext(lHdrName,'.img') + end else begin + lOutHdr.vox_offset := 352; + lInName := lHdrName; + end; + if not fileexists(lInName) then begin + dcmMsg('4Dclip Error: Unable to find '+lInName); + exit; + end; + if FSize (lInName) < ( (lVolBytes*lHdr.dim[4])+round(lHdr.vox_offset)) then begin + dcmMsg('4Dclip Error: File smaller than expected (can not convert compressed) '+lInName); + exit; + end; + if (lStart > 0) or (lEnd > 0) then + dcmMsg('4D clip - removing first '+inttostr(lStart)+' and last '+inttostr(lEnd) +' volumes') + else + dcmMsg('Formatting image'); + if not lSingleNiiFile then begin + lGZi := false; + lHdrName := changefileext(lHdrName,'.hdr'); + lImgName := changefileext(lHdrName,'.img'); + end else begin + lHdrName := changefileext(lHdrName,'.nii'); + lImgName := changefileext(lHdrName,'.nii'); + end; + if lOverwrite then begin + renamefile(lInName,changefileext(lInName,'.tmp')); + lInName := changefileext(lInName,'.tmp'); + end else begin + lHdrName := ChangeFilePrefixExt (lHdrName,'x'); + lImgName := ChangeFilePrefixExt (lImgName,'x'); + dcmMsg('Saving clipped as '+lHdrName); + end; + AssignFile(lInF, lInName); + Reset(lInF,1); + Seek(lInF,round(lHdr.vox_offset)); + SaveHdr (lHdrName,lOutHdr, lByteSwap{false},lSPM2); + AssignFile(lOutF, lImgName); + if lSingleNIIFile then begin + Reset(lOutF,1); + Seek(lOutF,352); + end else + Rewrite(lOutF,1); + for lVol := 1 to (lHdr.dim[4]-lEnd) do begin + //1st - save header + Filemode := 0; //ReadONly + BlockRead(lInF, lBuffer^, lVolBytes); + if (lVol > lStart) then begin + Filemode := 2; + BlockWrite(lOutF, lBuffer^, lVolBytes); + end; + end; + CloseFile(lInF); + CloseFile(lOutF); + Freemem(lBuffer); + if lOverwrite then + DeleteFile(lInName); + if lGZi then begin + lHdrName := lImgName+'.gz'; + GZipFile(lImgName,lHdrName,true); + end; + result := lHdrName; +end; + +function Convert4Dto3D(var lHdrName: string; var lHdr: TNIFTIhdr; lByteSwap, lSPM2in,lSingleNIIFile,lGZ: boolean ): boolean; +var + lOutHdr: TNIFTIhdr; + lOutName,lImgName: string; + lVol,lVolBytes: integer; + lBuffer: bytep; + lSPM2,lGZi: boolean; + lOutF,lInF: File; +begin + result := false; + lSPM2 := lSPM2in; + if lSingleNIIFIle then + lSPM2 := false; + lGZi := lGZ; + if lHdr.dim[4] < 2 then + exit; + lOutHdr := lHdr; + lOutHdr.dim[0] := 3;//3D + lOutHdr.dim[4] := 1; + lVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*(lOutHdr.bitpix div 8); + GetMem(lBuffer,lVolBytes); + //lSingleNIIFile := true; + if UpCaseExt(lHdrName) ='.HDR' then begin + //lSingleNIIFile := false; + lImgName := changefileext(lHdrName,'.img') + end else + lImgName := lHdrName; + if not fileexists(lImgName) then begin + dcmMsg('4D->3D Error: Unable to find '+lImgName); + exit; + end; + if FSize (lImgName) < ( (lVolBytes*lHdr.dim[4])+round(lHdr.vox_offset)) then begin + dcmMsg('4D->3D Error: File smaller than expected (can not convert compressed) '+lImgName); + exit; + end; + //dcmMsg(inttostr(round(lHdr.vox_offset))); + AssignFile(lInF, lImgName); + Reset(lInF,1); + Seek(lInF,round(lHdr.vox_offset)); + if not lSingleNiiFile then begin + lGZi := false; + lHdrName := changefileext(lHdrName,'.hdr'); + lImgName := changefileext(lHdrName,'.img'); + end else begin + lHdrName := changefileext(lHdrName,'.nii'); + lImgName := changefileext(lHdrName,'.nii'); + end; + for lVol := 1 to lHdr.dim[4] do begin + //1st - save header + lOutName := AddFileNum(lVol,lHdr.dim[4],lHdrName); + SaveHdr (lOutName,lOutHdr,lByteSwap {false},lSPM2); + Filemode := 0; //ReadONly + BlockRead(lInF, lBuffer^, lVolBytes); + + lOutName := AddFileNum(lVol,lHdr.dim[4],lImgName); + Filemode := 2; + AssignFile(lOutF, lOutName); + if (lSingleNIIFile) and (not lSPM2) then begin + Reset(lOutF,1); + Seek(lOutF,352); + end else + Rewrite(lOutF,1); + BlockWrite(lOutF, lBuffer^, lVolBytes); + CloseFile(lOutF); + if lGZi then begin + GZipFile(lOutName,lOutName+'.gz',true); + //DeleteFile(lOutName); + end; + end; + CloseFile(lInF); + Freemem(lBuffer); + //if lDeleteOrig then begin + DeleteFile(lHdrName); + if not lSingleNIIFile then + DeleteFile(lImgName); + //end; +end; *) + + +end. \ No newline at end of file diff --git a/dcm2nii/nii_4dto3d.ppu b/dcm2nii/nii_4dto3d.ppu new file mode 100644 index 0000000..7f2a535 Binary files /dev/null and b/dcm2nii/nii_4dto3d.ppu differ diff --git a/dcm2nii/nii_asl.o b/dcm2nii/nii_asl.o new file mode 100644 index 0000000..9ca3af2 Binary files /dev/null and b/dcm2nii/nii_asl.o differ diff --git a/dcm2nii/nii_asl.pas b/dcm2nii/nii_asl.pas new file mode 100755 index 0000000..8d029a0 --- /dev/null +++ b/dcm2nii/nii_asl.pas @@ -0,0 +1,601 @@ +unit nii_asl; +//tools for Arterial spin labeling... +{$H+} + + +interface + +uses +//{$IFDEF FPC}gzio2,{$ENDIF} + SysUtils,define_types,dicomtypes,niftiutil,prefs,dialogs_msg, nifti_types; + +function ASL_subtract(var lHdrName: string; lOverwrite: boolean; lFunction : integer; lPrefs: TPrefs): boolean; +//ASL_subtract(var lHdrName: string; lOverwrite: boolean; lFunction : integer; lPrefs: TPrefs) + +implementation +uses gui,dialogs; + +function Parse (var lNumStr: string; var Val1,Val2: integer): boolean; +var + lS: string; + lLen,lP: integer; +begin + Val1 := 0; + Val2 := 0; + result := false; + lLen := length(lNumStr); + if lLen < 3 then exit; + lS := ''; + lP := 1; + while (lP <= lLen) and (lNumStr[lP] <> ',') do begin + lS := lS + lNumStr[lP]; + inc(lP); + end; + if lS = '' then + exit; + try + Val1 := strtoint(lS); + except + dcmMsg('Error converting text to number '+lS); + end; + //next number + inc(lP); + lS := ''; + while (lP <= lLen) and (lNumStr[lP] <> ',') do begin + lS := lS + lNumStr[lP]; + inc(lP); + end; + if lS = '' then + exit; + try + Val2 := strtoint(lS); + except + dcmMsg('Error converting text to number '+lS); + end; + result := true; +end; + +function readCSV (lFilename: string; var lnObservations: integer; var lPosRA,lNegRA: LongIntp): boolean; +var + lNumStr: string; + F: TextFile; + R,A,B,C: integer; +begin + lnObservations := 0; + result := false; + if not fileexists(lFilename) then exit; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + R := 0; + while (not Eof(F)) do begin + Readln(F,lNumStr); + if Parse(lNumStr,A,B) then + inc(R); + end; + if (R < 1) then begin + dcmMsg('problems reading CSV: must have at least 2 columns and 1 row.'); + exit; + end; + lnObservations := R; + Getmem(lPosRA,lnObservations*sizeof(integer)); + Getmem(lNegRA,lnObservations*sizeof(integer)); + for R := 1 to lnObservations do begin + lPosRA^[R] := -1; + lNegRA^[R] := -1; + end; + //second pass + Reset(F); + C := 0; + while (not Eof(F)) and (C<lnObservations) do begin + Readln(F,lNumStr); + if Parse(lNumStr,A,B ) then begin + inc(C); + lPosRA^[C] := A; + lNegRA^[C] := B; + end; + end; + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; +//start 32-bit float versions +function SaveMean32 (var lHdrName: string;var lInHdr: TNIFTIhdr; lBuffAligned: bytep;lImgBuffer : SingleP ;lPrefs: TPrefs ): string; +var + lOutHdr : TNIFTIhdr; + lOutImgName: string; + lVol,lOutVolOffset,lInc,lImgSamples: integer; + lSum: double; +begin + result := ''; + lOutHdr := lInHdr; + lImgSamples := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]; + if (lImgSamples < 1) or (lInHdr.dim[4] < 1) then + exit; + //next make mean + lOutImgName := ChangeFilePrefix (lHdrName,'mean'); + for lInc := 1 to lImgSamples do begin + lSum := 0; + lOutVolOffset := 0; + for lVol := 1 to lInHdr.dim[4] do begin + lSum := lSum+lImgBuffer^[lOutVolOffset+lInc]; + lOutVolOffset := lOutVolOffset+lImgSamples; + end; + lImgBuffer^[lInc] := (lSum /lOutHdr.dim[4]); + end; + + lOutHdr.dim[4] := 1; + result := SaveNIfTICore (lOutImgName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); +end; //SaveMean32 + + +function ASL_subtract32(var lHdrName: string; lOverwrite: boolean; lFunction : integer; lPrefs: TPrefs): boolean; +//lFunction : +//0 = Subtract (even-odd) +//1= Subtract (odd-even) +//2= Subtract custom +//3= Add (odd+even) BOLD +//4= Parse OddEven aka SplitOddEven +//for odd/even, first scan is odd (1), second scan is even (2) [indexed from 1] +label + 666; +var + lPosRA,lNegRA: LongIntp; + lImgOffset,lVol,lInVolOddOffset,lInVolEvenOffset,lOutVolOffset, + lImgSamples,l4DVox,lInc: integer; + lCSVname,lResultStr,lOutImgName: string; + lInHdr, lOutHdr : TNIFTIhdr; + lO: TNIIOpts; + lSplitOddEven,lCustom,lSubtract,lOddMinusEven: boolean; + lBuffer,lSrcBuffer, lBuffUnaligned,lBuffAligned: bytep; + lOdd,lEven: single; + lOddVol,lEvenVol: integer; + lImgBuffer,l32Buf : SingleP; + //lSum: double; +begin + lSplitOddEven := lFunction = 4; + lCustom := lFunction = 2; + lOddMinusEven := lFunction = 1; + lSubtract := (lFunction <> 3); + result := false; + if not NIFTIhdr_LoadHdr (lHdrName, lInHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lHdrName); + exit; + end; + case lInHdr.datatype of + {kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,}kDT_FLOAT:;//Supported + else begin + dcmMsg('Error with ASL_subtract: image format must be 32-bit floating point values.'); + exit; + end; + end;//case headertype + if (odd(lInHdr.dim[4])) or (lInHdr.dim[4] < 2) then begin + dcmMsg('ASL routines require an even number of volumes'); + exit; + end; + + if not NIFTIhdr_LoadImg (lHdrName, lInHdr, lSrcBuffer, lImgOffset,lO) then exit; + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + l32Buf := SingleP(lBuffer ); + if lOverwrite then + lOutImgName := lHdrName + else begin + if lSplitOddEven then + lOutImgName := ChangeFilePrefix (lHdrName,'odd') + else if lSubtract then begin + if lCustom then + lOutImgName := ChangeFilePrefix (lHdrName,'subc') + else if lOddMinusEven then + lOutImgName := ChangeFilePrefix (lHdrName,'subome') + else + lOutImgName := ChangeFilePrefix (lHdrName,'subemo') + end else + lOutImgName := ChangeFilePrefix (lHdrName,'add'); + end; + lOutHdr := lInHdr; + lOutHdr.dim[4] := lInHdr.dim[4] div 2; + lOutHdr.pixdim[4] := 2 * lInHdr.pixdim[4]; + lImgSamples := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]; + l4DVox := lImgSamples * lOutHdr.dim[4]; + //l3DBytes := l3DVox*(lOutHdr.bitpix div 8); + //l4DBytes := l3DBytes*lOutHdr.dim[4]; + if lCustom then + lResultStr := 'Custom subtraction' + else if lSubtract then begin + if lOddMinusEven then + lResultStr := 'Subtract Odd-Even' + else + lResultStr := 'Subtract Even-Odd'; + end else + lResultStr := 'Add Odd+Even'; + dcmMsg('Computing '+lResultStr+' '+lHdrName); + lResultStr := ''; //assume error + GetMem(lBuffUnaligned ,(sizeof(single)*l4DVox) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := Align(lBuffUnaligned,16); // not commented - check this + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lInc := 1; + lImgBuffer := SingleP(@lBuffAligned^[kNIIImgOffset+lInc]); + + if lSplitOddEven then begin + //compute odd + for lVol := 1 to lOutHdr.dim[4] do begin + lOutVolOffset := (lVol -1) * lImgSamples; + //lInVolEvenOffset := ((lVol*2) -1) * lImgSamples; //second, fourth + lInVolOddOffset := ((lVol*2) -2) * lImgSamples; //first, thired + for lInc := 1 to lImgSamples do begin + lOdd := l32Buf^[lInVolOddOffset+lInc]; + //lEven := l16Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lOdd; + end; //for lImgSamples + end; //for lvol + lresultStr := SaveNIfTICore (lOutImgName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); + lresultStr := SaveMean32 (lOutImgName, lOutHdr, lBuffAligned,lImgBuffer,lPrefs); + //compute even + lOutImgName := ChangeFilePrefix (lHdrName,'even'); + for lVol := 1 to lOutHdr.dim[4] do begin + lOutVolOffset := (lVol -1) * lImgSamples; + lInVolEvenOffset := ((lVol*2) -1) * lImgSamples; //second, fourth + //lInVolOddOffset := ((lVol*2) -2) * lImgSamples; //first, thired + for lInc := 1 to lImgSamples do begin + //lOdd := l16Buf^[lInVolOddOffset+lInc]; + lEven := l32Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lEven; + end; //for lImgSamples + end; //for lvol +end else if lCustom then begin //not lSplitOddEven .. if Custom + dcmMsg('Select a comma separated text file that describes how to subtract images.'); + dcmMsg('For example, to subtract a six volume dataset your file could be:'); + dcmMsg('1,6'); + dcmMsg('2,5'); + dcmMsg('3,4'); + dcmMsg('The first output volume would be the first input volume minus the sixth'); + dcmMsg('The second output volume would be the second input volume minus the fifth'); + dcmMsg('The final output volume would be the third input volume minus the fourth'); + dcmMsg('Your file should have '+inttostr(lOutHdr.dim[4])+' lines, one for each output volume'); + + if not MainForm.OpenDialogExecute('Select NIfTI images you wish to modify)',true,false,kTxtFilter) then + goto 666; + lCSVName := MainForm.OpenHdrDlg.Filename; + //MainForm.BrowseDialog('Choose collapase file + if not readCSV (lCSVname, lVol, lPosRA,lNegRA) then + goto 666; + if lVol < lOutHdr.dim[4] then begin + dcmMsg ('Only found '+inttostr(lVol)+' contrasts in '+ lCSVName+' a total of '+inttostr(lOutHdr.dim[4])+' required'); + freemem(lPosRA); + freemem(lNegRA); + goto 666; + end; + for lVol := 1 to lOutHdr.dim[4] do begin + lOutVolOffset := (lVol -1) * lImgSamples; + lEvenVol := lNegRA^[lVol]; + lOddVol := lPosRA^[lVol]; + if (lEvenVol > 0) and (lOddVol > 0) and (lEvenVol <= lInHdr.dim[4]) and (lOddVol <= lInHdr.dim[4]) then begin + dcmMsg (inttostr(lVol) +' = '+inttostr(lOddVol)+' - '+inttostr(lEvenVol) ); + lInVolEvenOffset := (lEvenVol -1) * lImgSamples; + lInVolOddOffset := (lOddVol -1) * lImgSamples; + for lInc := 1 to lImgSamples do begin + lOdd := l32Buf^[lInVolOddOffset+lInc]; + lEven := l32Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lOdd - lEven; + end; //each voxel in volume + end else begin + dcmMsg('Error: volumes out of range '+inttostr(lVol) +' = '+inttostr(lOddVol)+' - '+inttostr(lEvenVol) ); + end; + end; //for lvol + freemem(lPosRA); + freemem(lNegRA); +end else begin //not custom or lSplitOddEven + for lVol := 1 to lOutHdr.dim[4] do begin + lOutVolOffset := (lVol -1) * lImgSamples; + lInVolEvenOffset := ((lVol*2) -1) * lImgSamples; //second, fourth + lInVolOddOffset := ((lVol*2) -2) * lImgSamples; //first, thired + if lSubtract then begin + if lOddMinusEven then begin + for lInc := 1 to lImgSamples do begin + lOdd := l32Buf^[lInVolOddOffset+lInc]; + lEven := l32Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lOdd - lEven; + end; //for lImgSamples + end else begin //not lOddMinusEven + for lInc := 1 to lImgSamples do begin + lOdd := l32Buf^[lInVolOddOffset+lInc]; + lEven := l32Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lEven-lOdd; + end; //for lImgSamples + end; //if else lOddMinusEven + end else begin //not subtract... add + for lInc := 1 to lImgSamples do begin + lOdd := l32Buf^[lInVolOddOffset+lInc]; + lEven := l32Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lOdd + lEven; + end; //for lImgSamples + end; //add + end; //for lvol +end; + lresultStr := SaveNIfTICore (lOutImgName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); + //next make mean + lresultStr := SaveMean32 (lOutImgName, lOutHdr, lBuffAligned,lImgBuffer,lPrefs); +666: + Freemem(lSrcBuffer); + Freemem(lBuffUnaligned); + if lResultStr = '' then //error - do not report success + exit; + result := true; +end; //ASL_subtract32 +//end 32bit versions + + +function SaveMean (var lHdrName: string;var lInHdr: TNIFTIhdr; lInBuffer : SmallIntP; lPrefs: TPrefs ): string; +var + lOutHdr : TNIFTIhdr; + lOutImgName: string; + lVol,lOutVolOffset,lInc,lImgSamples: integer; + lSum: double; + lBuffUnaligned,lBuffAligned: bytep; + lImgBuffer: Singlep; +begin + result := ''; + lOutHdr := lInHdr; + lImgSamples := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]; + if (lImgSamples < 1) or (lInHdr.dim[4] < 1) then + exit; + GetMem(lBuffUnaligned ,(sizeof(single)*lImgSamples) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := Align(lBuffUnaligned,16); // not commented - check this + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lInc := 1; + lImgBuffer := SingleP(@lBuffAligned^[kNIIImgOffset+lInc]); + //next make mean + lOutImgName := ChangeFilePrefix (lHdrName,'mean'); + for lInc := 1 to lImgSamples do begin + lSum := 0; + lOutVolOffset := 0; + for lVol := 1 to lInHdr.dim[4] do begin + lSum := lSum+lInBuffer^[lOutVolOffset+lInc]; + lOutVolOffset := lOutVolOffset+lImgSamples; + end; + lImgBuffer^[lInc] := (lSum /lOutHdr.dim[4]); + end; + + lOutHdr.dim[4] := 1; + lOutHdr.datatype := kDT_FLOAT; + lOutHdr.bitpix := 32; + result := SaveNIfTICore (lOutImgName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); + freemem( lBuffUnaligned); +end; //SaveMean + +(*function SaveMean (var lHdrName: string;var lInHdr: TNIFTIhdr; lBuffAligned: bytep;lImgBuffer : SmallIntP;lPrefs: TPrefs; lByteSwap:boolean ): string; +var + lOutHdr : TNIFTIhdr; + lOutImgName: string; + lVol,lOutVolOffset,lInc,lImgSamples: integer; + lSum: double; +begin + result := ''; + lOutHdr := lInHdr; + lImgSamples := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]; + if (lImgSamples < 1) or (lInHdr.dim[4] < 1) then + exit; + //next make mean + lOutImgName := ChangeFilePrefix (lHdrName,'mean'); + for lInc := 1 to lImgSamples do begin + lSum := 0; + lOutVolOffset := 0; + for lVol := 1 to lInHdr.dim[4] do begin + lSum := lSum+lImgBuffer^[lOutVolOffset+lInc]; + lOutVolOffset := lOutVolOffset+lImgSamples; + end; + lImgBuffer^[lInc] := round(lSum /lOutHdr.dim[4]); + end; + + lOutHdr.dim[4] := 1; + result := SaveNIfTICore (lOutImgName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs,lByteSwap); +end; //SaveMean*) + +function ASL_subtract(var lHdrName: string; lOverwrite: boolean; lFunction : integer; lPrefs: TPrefs): boolean; +//lFunction : +//0 = Subtract (even-odd) +//1= Subtract (odd-even) +//2= Subtract custom +//3= Add (odd+even) BOLD +//4= Parse OddEven aka SplitOddEven +//for odd/even, first scan is odd (1), second scan is even (2) [indexed from 1] +label + 666; +var + lPosRA,lNegRA: LongIntp; + lImgOffset,lVol,lInVolOddOffset,lInVolEvenOffset,lOutVolOffset, + lOddVol,lEvenVol: integer; + lImgSamples,l4DVox,lInc: integer; + lCSVname,lResultStr,lOutImgName: string; + lInHdr, lOutHdr : TNIFTIhdr; + lO: TNIIOpts; + lSplitOddEven,lCustom,lSubtract,lOddMinusEven: boolean; + lBuffer,lSrcBuffer, lBuffUnaligned,lBuffAligned: bytep; + lOdd,lEven: integer; + lImgBuffer,l16Buf : SmallIntP; + //lSum: double; +begin + lSplitOddEven := lFunction = 4; + lCustom := lFunction = 2; + lOddMinusEven := lFunction = 1; + lSubtract := (lFunction <> 3); + result := false; + if not NIFTIhdr_LoadHdr (lHdrName, lInHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lHdrName); + exit; + end; + case lInHdr.datatype of + {kDT_UNSIGNED_CHAR,}kDT_SIGNED_SHORT{,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT}:;//Supported + kDT_FLOAT: begin + result := ASL_subtract32(lHdrName,lOverwrite,lFunction,lPrefs); + exit; + end;//kDT_FLOAT + else begin + dcmMsg('Error with ASL_subtract: image format must be 16-bit signed integers.'); + exit; + end; + end;//case headertype + if (odd(lInHdr.dim[4])) or (lInHdr.dim[4] < 2) then begin + dcmMsg('ASL routines require an even number of volumes'); + exit; + end; + + if not NIFTIhdr_LoadImg (lHdrName, lInHdr, lSrcBuffer, lImgOffset,lO) then exit; + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + l16Buf := SmallIntP(lBuffer ); + if lOverwrite then + lOutImgName := lHdrName + else begin + if lSplitOddEven then + lOutImgName := ChangeFilePrefix (lHdrName,'odd') + else if lSubtract then begin + if lCustom then + lOutImgName := ChangeFilePrefix (lHdrName,'subc') + else if lOddMinusEven then + lOutImgName := ChangeFilePrefix (lHdrName,'subome') + else + lOutImgName := ChangeFilePrefix (lHdrName,'subemo') + end else + lOutImgName := ChangeFilePrefix (lHdrName,'add'); + end; + lOutHdr := lInHdr; + lOutHdr.dim[4] := lInHdr.dim[4] div 2; + lOutHdr.pixdim[4] := 2 * lInHdr.pixdim[4]; + lImgSamples := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]; + l4DVox := lImgSamples * lOutHdr.dim[4]; + //l3DBytes := l3DVox*(lOutHdr.bitpix div 8); + //l4DBytes := l3DBytes*lOutHdr.dim[4]; + if lCustom then + lResultStr := 'Custom subtraction' + else if lSubtract then begin + if lOddMinusEven then + lResultStr := 'Subtract Odd-Even' + else + lResultStr := 'Subtract Even-Odd'; + end else + lResultStr := 'Add Odd+Even'; + dcmMsg('Computing '+lResultStr+' '+lHdrName); + lResultStr := ''; //assume error + GetMem(lBuffUnaligned ,(sizeof(smallint)*l4DVox) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := Align(lBuffUnaligned,16); // not commented - check this + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lInc := 1; + lImgBuffer := SmallIntP(@lBuffAligned^[kNIIImgOffset+lInc]); +if lSplitOddEven then begin + //compute odd + for lVol := 1 to lOutHdr.dim[4] do begin + lOutVolOffset := (lVol -1) * lImgSamples; + //lInVolEvenOffset := ((lVol*2) -1) * lImgSamples; //second, fourth + lInVolOddOffset := ((lVol*2) -2) * lImgSamples; //first, thired + for lInc := 1 to lImgSamples do begin + lOdd := l16Buf^[lInVolOddOffset+lInc]; + //lEven := l16Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lOdd; + end; //for lImgSamples + end; //for lvol + lresultStr := SaveNIfTICore (lOutImgName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); + lresultStr := SaveMean (lOutImgName, lOutHdr, lImgBuffer,lPrefs); + //compute even + lOutImgName := ChangeFilePrefix (lHdrName,'even'); + for lVol := 1 to lOutHdr.dim[4] do begin + lOutVolOffset := (lVol -1) * lImgSamples; + lInVolEvenOffset := ((lVol*2) -1) * lImgSamples; //second, fourth + //lInVolOddOffset := ((lVol*2) -2) * lImgSamples; //first, thired + for lInc := 1 to lImgSamples do begin + //lOdd := l16Buf^[lInVolOddOffset+lInc]; + lEven := l16Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lEven; + end; //for lImgSamples + end; //for lvol +end else if lCustom then begin //not lSplitOddEven .. if Custom + dcmMsg('Select a comma separated text file that describes how to subtract images.'); + dcmMsg('For example, to subtract a six volume dataset your file could be:'); + dcmMsg('1,6'); + dcmMsg('2,5'); + dcmMsg('3,4'); + dcmMsg('The first output volume would be the first input volume minus the sixth'); + dcmMsg('The second output volume would be the second input volume minus the fifth'); + dcmMsg('The final output volume would be the third input volume minus the fourth'); + dcmMsg('Your file should have '+inttostr(lOutHdr.dim[4])+' lines, one for each output volume'); + + if not MainForm.OpenDialogExecute('Select NIfTI images you wish to modify)',true,false,kTxtFilter) then + goto 666; + lCSVName := MainForm.OpenHdrDlg.Filename; + //MainForm.BrowseDialog('Choose collapase file + if not readCSV (lCSVname, lVol, lPosRA,lNegRA) then + goto 666; + if lVol < lOutHdr.dim[4] then begin + dcmMsg('Only found '+inttostr(lVol)+' contrasts in '+ lCSVName+' a total of '+inttostr(lOutHdr.dim[4])+' required'); + freemem(lPosRA); + freemem(lNegRA); + goto 666; + end; + for lVol := 1 to lOutHdr.dim[4] do begin + lOutVolOffset := (lVol -1) * lImgSamples; + lEvenVol := lNegRA^[lVol]; + lOddVol := lPosRA^[lVol]; + if (lEvenVol > 0) and (lOddVol > 0) and (lEvenVol <= lInHdr.dim[4]) and (lOddVol <= lInHdr.dim[4]) then begin + dcmMsg(inttostr(lVol) +' = '+inttostr(lOddVol)+' - '+inttostr(lEvenVol) ); + lInVolEvenOffset := (lEvenVol -1) * lImgSamples; //second, fourth + lInVolOddOffset := (lOddVol -1) * lImgSamples; //first, thired + for lInc := 1 to lImgSamples do begin + lOdd := l16Buf^[lInVolOddOffset+lInc]; + lEven := l16Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lOdd - lEven; + end; //each voxel in volume + end else begin + dcmMsg('Error: volumes out of range '+inttostr(lVol) +' = '+inttostr(lOddVol)+' - '+inttostr(lEvenVol) ); + end; + end; //for lvol + freemem(lPosRA); + freemem(lNegRA); +end else begin //not custom or lSplitOddEven + for lVol := 1 to lOutHdr.dim[4] do begin + lOutVolOffset := (lVol -1) * lImgSamples; + lInVolEvenOffset := ((lVol*2) -1) * lImgSamples; //second, fourth + lInVolOddOffset := ((lVol*2) -2) * lImgSamples; //first, thired + if lSubtract then begin + if lOddMinusEven then begin + for lInc := 1 to lImgSamples do begin + lOdd := l16Buf^[lInVolOddOffset+lInc]; + lEven := l16Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lOdd - lEven; + end; //for lImgSamples + end else begin //not lOddMinusEven + for lInc := 1 to lImgSamples do begin + lOdd := l16Buf^[lInVolOddOffset+lInc]; + lEven := l16Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lEven-lOdd; + end; //for lImgSamples + end; //if else lOddMinusEven + end else begin //not subtract... add + for lInc := 1 to lImgSamples do begin + lOdd := l16Buf^[lInVolOddOffset+lInc]; + lEven := l16Buf^[lInVolEvenOffset+lInc]; + lImgBuffer^[lOutVolOffset+lInc] := lOdd + lEven; + end; //for lImgSamples + end; //add + end; //for lvol +end; + lresultStr := SaveNIfTICore (lOutImgName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); + //next make mean + lresultStr := SaveMean (lOutImgName, lOutHdr, lImgBuffer,lPrefs); +666: + Freemem(lSrcBuffer); + Freemem(lBuffUnaligned); + if lResultStr = '' then //error - do not report success + exit; + result := true; +end; //ASL_subtract + +end. \ No newline at end of file diff --git a/dcm2nii/nii_asl.ppu b/dcm2nii/nii_asl.ppu new file mode 100644 index 0000000..8d1e991 Binary files /dev/null and b/dcm2nii/nii_asl.ppu differ diff --git a/dcm2nii/nii_crop.o b/dcm2nii/nii_crop.o new file mode 100644 index 0000000..9800f57 Binary files /dev/null and b/dcm2nii/nii_crop.o differ diff --git a/dcm2nii/nii_crop.pas b/dcm2nii/nii_crop.pas new file mode 100755 index 0000000..a013fb8 --- /dev/null +++ b/dcm2nii/nii_crop.pas @@ -0,0 +1,981 @@ +unit nii_crop; +{$H+} +//TO DO: ByteSwap, DataTypes, Orthogonality + +//VENTRAL direction: attempts to remove excess neck ... +//OTHER directions: zeros slices where signal intensity is <5% +//assumes image is oriented in canonical space, e.g. +//closest to rotation matrix [1 0 0; 0 1 0; 0 0 1] +//if your image is not rotated in this manner, use nii_orient first +interface + +uses +{$IFDEF FPC}gzio2,{$ENDIF} +//distr, + SysUtils,define_types,dicomtypes,niftiutil,GraphicsMathLibrary,prefs, nifti_types; +//function Int16LogPtoZNIfTI32Z(lFilename: string; lPrefs: TPrefs): string; +function CropNIfTI(lFilename: string; lPrefs: TPrefs): string;//returns output filename if successful +function Float32NIfTI(lFilename: string; lPrefs: TPrefs): string; +function FormulaNIfTI(lFilename: string; lPrefs: TPrefs; lScale,lPower: double): string; +//function RescaleNIfTI(lFilename: string; lPrefs: TPrefs; lScale: double): string; +function RemoveNIfTIscalefactor(lFilename: string; lPrefs: TPrefs): string; +function CropNIfTIX(lFilename: string; lPrefs: TPrefs; lDorsalCrop, lVentralCrop, lLCrop,lRCrop, lACrop, lPCrop : integer ): string; +function SiemensPhase2RadiansNIfTI(lFilename: string; lPrefs: TPrefs): string; + +implementation +uses dialogsx,math,dialogs_msg; + +function RemoveNIfTIscalefactor(lFilename: string; lPrefs: TPrefs): string; +//rescale data by lScale +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname: string; + l4DBytes,lInOffset,l1: integer; + lInBuffer,lOutBuffer: bytep; + lO: TNIIOpts; +begin + result := ''; + //lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lInHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + dcmMsg('rescaleNIfTI unsupported datatype.'); + exit; + end; + end; + dcmMsg('removing scale factor NIfTI/Analyze image '+lFileName); + lOutHdr := lInHdr; + lOutHdr.scl_slope := 1; + lOutHdr.scl_inter := 0; + l4DBytes := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lInHdr.dim[4]*(lInHdr.bitpix div 8); + if not NIFTIhdr_LoadImg (lFileName, lInHdr, lInBuffer, lInOffset,lO) then exit; + GetMem(lOutBuffer,l4DBytes+kNIIImgOffset); + //lOutPos := kNIIImgOffset + 1; + l1 := 1; + Move(lInBuffer^[lInOffset+l1],lOutBuffer^[kNIIImgOffset + l1],l4DBytes); + lOutname := ChangeFilePrefix (lFileName,'r'); + dcmMsg(lOutName); + if SaveNIfTICore (lOutName, lOutBuffer, kNIIImgOffset+1, lOutHdr, lPrefs) = '' then begin + dcmMsg('Remove scale error'); + Freemem(lInBuffer); + Freemem(lOutBuffer); + exit; + end; + Freemem(lInBuffer); + Freemem(lOutBuffer); + result := lOutname; +end; + +function FormulaNIfTI(lFilename: string; lPrefs: TPrefs; lScale,lPower: double): string; +//apply formula to dataset, then save results as 32-bit float.... +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lAdj: single; + lImgSamples,lInc,lImgOffset,lVol,lnVol,lPos: integer; + lSrcBuffer,lBuffer, lBuffUnaligned,lBuffAligned: bytep; + l32Buf,lImgBuffer: singlep; + l16Buf : SmallIntP; + lByteSwap: boolean; + lO: TNIIOpts; +begin + result := ''; + lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lInHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + dcmMsg('Error with nii_crop: unsupported datatype.'); + exit; + end; + end; + dcmMsg('Applying formula to NIfTI/Analyze image'+lFileName); + lOutHdr := lInHdr; + lOutHdr.datatype := kDT_FLOAT; + lOutHdr.bitpix := 32; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lInHdr.dim[4]; + if not NIFTIhdr_LoadImg (lFileName, lInHdr, lSrcBuffer, lImgOffset,lO) then exit; + //Msg('Automatically Cropping image'); + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + GetMem(lBuffUnaligned ,(sizeof(single)*lImgSamples) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := Align(lBuffUnaligned,16); // not commented - check this + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lInc := 1; + lImgBuffer := SingleP(@lBuffAligned^[kNIIImgOffset+lInc]); + case lInHdr.datatype of + kDT_UNSIGNED_CHAR : begin //8 bit + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := lBuffer^[lInc]; + end; + kDT_SIGNED_SHORT{,kDT_UINT16}: begin //16-bit int + l16Buf := SmallIntP(lBuffer ); + if lByteSwap then begin + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := Swap(l16Buf^[lInc]); + end else begin + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := l16Buf^[lInc]; + end; + end;//16bit + kDT_SIGNED_INT: begin + l32Buf := SingleP(lBuffer ); + if lByteSwap then //unswap and convert integer to float + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := (Swap4r4i(l32Buf^[lInc])) + else //convert integer to float + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := Conv4r4i(l32Buf^[lInc]); + end; //32-bit int + kDT_FLOAT: begin + l32Buf := SingleP(lBuffer); + for lInc := 1 to lImgSamples do + lImgBuffer[lInc] := l32Buf[lInc]; + if lByteSwap then + for lInc := 1 to lImgSamples do + pswap4r(lImgBuffer^[lInc]); //faster as procedure than function see www.optimalcode.com + for lInc := 1 to lImgSamples do + if specialsingle(lImgBuffer^[lInc]) then lImgBuffer^[lInc] := 0.0; + //invert= for lInc := 1 to lImgSamples do l32Buf[lInc] := -l32Buf[lInc]; + end; //32-bit float + else begin + dcmMsg('Serious error: format not supported by Float32.'); + exit; + end; + end; //case + //apply formula + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]; //3D data + lnVol := lInHdr.dim[4]; //4th dimension + lPos := 0; + //fx(lScale,lPower); + for lVol := 1 to lnVol do begin + lAdj := 1/(lScale* Power(lVol,lPower)); + for lInc := 1 to lImgSamples do begin + inc(lPos); + lImgBuffer^[lPos] := lAdj*lImgBuffer^[lPos]; + //lImgBuffer[lPos] := lImgBuffer[lPos] * lScale; + end; + end; + lOutname := ChangeFilePrefix (lFileName,'f'); + result := SaveNIfTICore (lOutName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); + Freemem(lBuffUnaligned); + Freemem(lSrcBuffer); +end; + + +function Float32NIfTI(lFilename: string; lPrefs: TPrefs): string; +//convert any data format as 32-bit float.... +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lImgSamples,lInc,lImgOffset: integer; + lSrcBuffer,lBuffer, lBuffUnaligned,lBuffAligned: bytep; + l32Buf,lImgBuffer: singlep; + l16Buf : SmallIntP; + lO: TNIIOpts; +begin + result := ''; + lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lInHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + if lInHdr.datatype = kDT_FLOAT then begin + dcmMsg('No need to apply Float32 : data is already 32-bit real: '+lFilename); + exit; + end; + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + dcmMsg('Float32 unsupported datatype.'); + exit; + end; + end; + dcmMsg('Converting NIfTI/Analyze image to 32-bit float'+lFileName); + lOutHdr := lInHdr; + lOutHdr.datatype := kDT_FLOAT; + lOutHdr.bitpix := 32; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lInHdr.dim[4]; + if not NIFTIhdr_LoadImg (lFileName, lInHdr, lSrcBuffer, lImgOffset,lO) then exit; + //Msg('Automatically Cropping image'); + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + GetMem(lBuffUnaligned ,(sizeof(single)*lImgSamples) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := align(lBuffUnaligned,16); + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lInc := 1; + lImgBuffer := SingleP(@lBuffAligned^[kNIIImgOffset+lInc]); + case lInHdr.datatype of + kDT_UNSIGNED_CHAR : begin //8 bit + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := lBuffer^[lInc]; + end; + kDT_SIGNED_SHORT{,kDT_UINT16}: begin //16-bit int + l16Buf := SmallIntP(lBuffer ); + + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := l16Buf^[lInc]; + end;//16bit + kDT_SIGNED_INT: begin + + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := Conv4r4i(l32Buf^[lInc]); + end; //32-bit int + kDT_FLOAT: begin + l32Buf := SingleP(lBuffer); + for lInc := 1 to lImgSamples do + lImgBuffer[lInc] := l32Buf[lInc]; + for lInc := 1 to lImgSamples do + if specialsingle(lImgBuffer^[lInc]) then lImgBuffer^[lInc] := 0.0; + //invert= for lInc := 1 to lImgSamples do l32Buf[lInc] := -l32Buf[lInc]; + end; //32-bit float + else begin + dcmMsg('Serious error: format not supported by Float32.'); + exit; + end; + end; //case + lOutname := ChangeFilePrefix (lFileName,'f'); + result := SaveNIfTICore (lOutName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); + Freemem(lBuffUnaligned); + Freemem(lSrcBuffer); +end; + + +(*function LogPtoZ (lLogP: single): single; +var + lD: double; +begin + ///lD := Log10(lLogp); + lD := Power(10,-lLogP); + result := pNormalInv(lD); + //fx(lD,lZ); +end; + +function Int16LogPtoZNIfTI32Z(lFilename: string; lPrefs: TPrefs): string; +//convert any data format as 32-bit float.... +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lImgSamples,lInc,lImgOffset: integer; + lSrcBuffer,lBuffer, lBuffUnaligned,lBuffAligned: bytep; + l32Buf,lImgBuffer: singlep; + l16Buf : SmallIntP; + lByteSwap: boolean; +begin + result := ''; + lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lInHdr, lByteSwap) then begin + Msg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + if lInHdr.datatype = kDT_FLOAT then begin + Msg('No need to apply Float32 : data is already 32-bit real: '+lFilename); + exit; + end; + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + Msg('Float32 unsupported datatype.'); + exit; + end; + end; + Msg('Converting NIfTI/Analyze image to 32-bit float'+lFileName); + lOutHdr := lInHdr; + lOutHdr.datatype := kDT_FLOAT; + lOutHdr.bitpix := 32; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lInHdr.dim[4]; + if not NIFTIhdr_LoadImg (lFileName, lInHdr, lSrcBuffer, lImgOffset,lByteSwap) then exit; + //Msg('Automatically Cropping image'); + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + GetMem(lBuffUnaligned ,(sizeof(single)*lImgSamples) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := align(lBuffUnaligned,16); + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lInc := 1; + lImgBuffer := SingleP(@lBuffAligned^[kNIIImgOffset+lInc]); + lOutHdr.scl_slope := 1; + case lInHdr.datatype of + kDT_SIGNED_SHORT{,kDT_UINT16}: begin //16-bit int + l16Buf := SmallIntP(lBuffer ); + if lByteSwap then begin + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := Swap(l16Buf^[lInc]); + end else begin + for lInc := 1 to lImgSamples do begin + if l16Buf^[lInc] =0 then + lImgBuffer^[lInc] := 0 + else if l16Buf^[lInc] =32767 then + lImgBuffer^[lInc] := 0 + else + lImgBuffer^[lInc] := LogPtoZ(0.01*l16Buf^[lInc]); + end; + end; + end;//16bit + else begin + Msg('Serious error: format not supported by Float32.'); + exit; + end; + end; //case + lOutname := ChangeFilePrefix (lFileName,'f'); + result := SaveNIfTICore (lOutName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs,lByteSwap); + Freemem(lBuffUnaligned); + Freemem(lSrcBuffer); +end;*) + + +procedure SmoothRA (var lRA: Doublep; lItems: integer); +var + lRecip: double; + lTempRA,lTempRAUnaligned: Doublep; + lI: integer; +begin + if lItems < 3 then exit; + GetMem(lTempRAUnaligned,(lItems*sizeof(double))+16); + {$IFDEF FPC} + lTempRA := align(lTempRAUnaligned,16); + {$ELSE} + lTempRA := DoubleP($fffffff0 and (integer(lTempRAUnaligned)+15)); + {$ENDIF} + + for lI := 1 to lItems do + lTempRA^[lI] := lRA^[lI]; + lRecip := 1/3; //multiplies faster than divides + for lI := 2 to (lItems-1) do + lRA^[lI] := (lTempRA^[lI-1]+lTempRA^[lI]+lTempRA^[lI+1])*lRecip; + FreeMem(lTempRAUnaligned); +end; + +function MaxRA (var lRA: Doublep; lStart,lItems: integer): integer; +var + lMax: double; + lI: integer; +begin + result := lStart; + if (lItems < 2) or (lStart >= lItems) or ((lItems-lStart)< 1) then exit; + lMax := lRA^[lStart]; + for lI := lStart to lItems do + if lRA^[lI] > lMax then begin + result := lI; + lMax := lRA^[lI] + end; +end; + +function MinRA (var lRA: Doublep; lStart,lItems: integer): integer; +var + lMin: double; + lI: integer; +begin + result := lStart; + if (lItems < 2) or (lStart >= lItems) or ((lItems-lStart)< 1) then exit; + lMin := lRA^[lStart]; + for lI := lStart to lItems do + if lRA^[lI] < lMin then begin + result := lI; + lMin := lRA^[lI] + end; +end; + + +function FindDVCrop2 (var lHdr: TNIFTIhdr; var lDorsalCrop,lVentralCrop: integer): boolean; +const + kMaxDVmm = 200; +var + lSliceMM: double; +begin + result := false; + if lHdr.pixdim[3] < 0.0001 then + exit; + lSliceMM := lHdr.pixdim[3]* (lHdr.Dim[3]-lDorsalCrop-lVentralCrop); + if lSliceMM > kMaxDVmm then begin //decide how many more ventral slices to remove + lSliceMM := lSliceMM - kMaxDVmm; + lSliceMM := lSliceMM / lHdr.pixdim[3]; + //msg(inttostr(lVentralCrop)); + lVentralCrop := lVentralCrop + round(lSliceMM); + //msg(inttostr(lVentralCrop)); + end; + result := true; +end; + +function FindDVCrop (var lHdr: TNIFTIhdr; var ScrnBuffer: Singlep; var lDorsalCrop,lVentralCrop: integer; lPct: integer): boolean; +var + lSliceMax: double; + lSliceSum,lSliceSumUnaligned: Doublep; + lXY,lZ,lSlices,lSliceSz,lSliceStart,lVentralMaxSlice,lMaxSlice,lMinSlice,lGap: integer; +begin + result := false; + lDorsalCrop := 0; + lVentralCrop := 0; + if (lPct < 1) or (lPct > 100) then + exit; + lSlices := lHdr.dim[3]; + lSliceSz := lHdr.dim[1]*lHdr.dim[2]; + GetMem(lSliceSumUnaligned,(lSlices*sizeof(double))+16); + {$IFDEF FPC} + lSliceSum := align(lSliceSumUnaligned,16); + {$ELSE} + lSliceSum := DoubleP($fffffff0 and (integer(lSliceSumUnaligned)+15)); + {$ENDIF} + lSliceMax := 0; + for lZ := 1 to lSlices do begin + lSliceSum^[lZ] := 0; + lSliceStart := (lZ-1)*lSliceSz; + for lXY := 1 to lSliceSz do + lSliceSum^[lZ] := lSliceSum^[lZ]+ ScrnBuffer^[lXY+lSliceStart]; + if lSliceMax < lSliceSum^[lZ] then + lSliceMax := lSliceSum^[lZ]; + end; //for each slice + if lSliceMax = 0 then begin //no data variance + Freemem(lSliceSumUnaligned); + exit; + end; //VolSum = 0 + //next: normalize so each slice is normalized to brightest axial slice + for lZ := 1 to lSlices do + lSliceSum^[lZ] := lSliceSum^[lZ]/lSliceMax; + result := true; + //next: smooth + SmoothRA(lSliceSum,lSlices); + //next - top cropping - removing slices that are <5% of maximum slice + lZ := lSlices; + while (lZ > 1) and (lSliceSum^[lZ] < (lPct/100)) do + dec(lZ); + lDorsalCrop := lSlices-lZ; + //next findMax + lMaxSlice := MaxRA(lSliceSum,1,lSlices); + //next - ensure there is at least 60mm from max to bottom of an image - enough spine to worry about + lVentralMaxSlice := lMaxSlice-round(60/abs(lHdr.pixdim[3])); + if lVentralMaxSlice < 1 then + exit; + lVentralMaxSlice := MaxRA(lSliceSum,1,lVentralMaxSlice); + //finally: find minima between these two points... + lMinSlice := MinRA(lSliceSum,lVentralMaxSlice,lMaxSlice); + lGap := round((lMaxSlice-lMinSlice)*0.9);//add 40% for cerebellum + if (lMinSlice-lGap) > 1 then begin + result := true; + lVentralCrop := lMinSlice-lGap; + end; + //fx(lVentralCrop,lDorsalCrop); + //next show output... + {TextForm.Memo1.Lines.Clear; + for lZ := 1 to lSlices do + TextForm.Memo1.Lines.add(inttostr(lZ)+','+floattostr(lSliceSum^[lZ])); + TextForm.Show; } + //cleanup + Freemem(lSliceSumUnaligned); + //next - max 200mm from top of head to spinal column.... + + //if (lSliceMM > kMaxDVmm + +end; + +function FindLRCrop (var lHdr: TNIFTIhdr; var ScrnBuffer: Singlep; var lLCrop,lRCrop:integer; lPct,lDCrop,lVCrop: integer): boolean; +//amount of image to crop from left/right for N% signal intensity +var + lSliceMax: double; + lSliceSum,lSliceSumUnaligned: Doublep; + lZmin,lZmax,lX,lY,lZ,lSlices,lSliceSz,lSliceStart: integer; +begin + result := false; + lLCrop := 0; + lRCrop := 0; + if (lPct < 1) or (lPct > 100) then + exit; + lZMin := lVCrop; + lZMax := lHdr.Dim[3]-lDCrop; + SortInt(lZMin,lZMax); + lZMin := Bound(lZMin,1,lHdr.Dim[3]); + lZMax := Bound(lZMax,1,lHdr.Dim[3]); + if lZMin >= lZMax then + exit; + + lSlices := lHdr.Dim[1]; + lSliceSz := lHdr.Dim[1]*lHdr.Dim[2]; + GetMem(lSliceSumUnaligned,(lSlices*sizeof(double))+16); + {$IFDEF FPC} + lSliceSum := align(lSliceSumUnaligned,16); + {$ELSE} + lSliceSum := DoubleP($fffffff0 and (integer(lSliceSumUnaligned)+15)); + {$ENDIF} + lSliceMax := 0; + for lX := 1 to lSlices do begin + lSliceSum^[lX] := 0; + for lZ := {1 to lHdr.Dim[3]} lZMin to lZMax do begin + lSliceStart := lX+ ((lZ-1)*lSliceSz); + for lY := 1 to lHdr.Dim[2] do begin + lSliceSum^[lX] := lSliceSum^[lX]+ ScrnBuffer^[lSliceStart]; + lSliceStart := lSliceStart + lHdr.Dim[1]; + end; + end; + //for lYZ := 1 to lSliceSz do + // lSliceSum^[lZ] := lSliceSum^[lZ]+ gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lXY+lSliceStart]; + if lSliceMax < lSliceSum^[lX] then + lSliceMax := lSliceSum^[lX]; + end; //for each slice + if lSliceMax = 0 then begin //no data variance + Freemem(lSliceSumUnaligned); + exit; + end; //VolSum = 0 + //next: smooth + SmoothRA(lSliceSum,lSlices); + //next: normalize so each slice is normalized to brightest axial slice + for lX := 1 to lSlices do + lSliceSum^[lX] := lSliceSum^[lX]/lSliceMax; + //next - Left cropping- removing slices that are <5% of maximum slice + lX := lSlices; + while (lX > 1) and (lSliceSum^[lX] < (lPct/100)) do + dec(lX); + lRCrop := lSlices-lX; + //next - Left cropping- removing slices that are <5% of maximum slice + lX := 1; + while (lX <= lSlices) and (lSliceSum^[lX] < (lPct/100)) do + inc(lX); + lLCrop := lX-1; + //fx(lLCrop,lRCrop); + result := true; + Freemem(lSliceSumUnaligned); +end; + +function FindAPCrop (var lHdr: TNIFTIhdr; var ScrnBuffer: Singlep; var lACrop,lPCrop: integer; lPct,lDCrop,lVCrop: integer): boolean; +//amount of image to crop from anterior/posterior for 5% signal intensity +var + lSliceMax: double; + lSliceSum,lSliceSumUnaligned: Doublep; + lZMin,lZMax,lX,lY,lZ,lSlices,lSliceSz,lSliceStart: integer; +begin + result := false; + lACrop := 0; + lPCrop := 0; + lZMin := lVCrop; + lZMax := lHdr.Dim[3]-lDCrop; + SortInt(lZMin,lZMax); + lZMin := Bound(lZMin,1,lHdr.Dim[3]); + lZMax := Bound(lZMax,1,lHdr.Dim[3]); + if lZMin >= lZMax then + exit; + if (lPct < 1) or (lPct > 100) then + exit; + lSlices := lHdr.Dim[2]; + lSliceSz := lHdr.Dim[1]*lHdr.Dim[2]; + //lCoroSliceSz := lHdr.Dim[1]*lHdr.Dim[3]; + GetMem(lSliceSumUnaligned,(lSlices*sizeof(double))+16); + {$IFDEF FPC} + lSliceSum := align(lSliceSumUnaligned,16); + {$ELSE} + lSliceSum := DoubleP($fffffff0 and (integer(lSliceSumUnaligned)+15)); + {$ENDIF} + lSliceMax := 0; + for lY := 1 to lSlices do begin + lSliceSum^[lY] := 0; + //lSliceStart := lY; + for lZ := {1 to lHdr.Dim[3]} lZMin to lZMax do begin + lSliceStart := ((lY-1)* lHdr.Dim[1])+ ((lZ-1)*lSliceSz); + //if lSliceStart > (lSliceSz*lHdr.Dim[3]) then + // Msg('xx'); + for lX := 1 to lHdr.Dim[1] do + lSliceSum^[lY] := lSliceSum^[lY]+ ScrnBuffer^[lSliceStart+lX]; + end; //for lZ + //for lYZ := 1 to lSliceSz do + // lSliceSum^[lY] := lSliceSum^[lY]+ gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lXY+lSliceStart]; + if lSliceMax < lSliceSum^[lY] then + lSliceMax := lSliceSum^[lY]; + end; //for each slice + if lSliceMax = 0 then begin //no data variance + Freemem(lSliceSumUnaligned); + exit; + end; //VolSum = 0 + //next: smooth + SmoothRA(lSliceSum,lSlices); + //next: normalize so each slice is normalized to brightest axial slice + for lY := 1 to lSlices do + lSliceSum^[lY] := lSliceSum^[lY]/lSliceMax; + //next - Left cropping- removing slices that are <5% of maximum slice + lY := lSlices; + while (lY > 1) and (lSliceSum^[lY] < (lPct/100)) do + dec(lY); + lACrop := lSlices-lY; + //next - Left cropping- removing slices that are <5% of maximum slice + lY := 1; + while (lY <= lSlices) and (lSliceSum^[lY] < (lPct/100)) do + inc(lY); + lPCrop := lY-1; + result := true; + Freemem(lSliceSumUnaligned); +end; + +function CropNIfTIX(lFilename: string; lPrefs: TPrefs; lDorsalCrop, lVentralCrop, lLCrop,lRCrop, lACrop, lPCrop : integer ): string; +//to do : data swapping (errors on detection and writing zero in reverse order) +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lXmm,lYmm,lZmm: single; + lMat: TMatrix; + lOutPos,//lInc, //lImgSamples, + lX,lY,lZ,lBPP, lB, + lVol, lInVol,lInZOffset,lInYOffset,lInSliceSz,lInXSz,lInPos,lImgOffset: integer; + lSrcBuffer,lBuffer//, lBuffUnaligned + : bytep; + //l32Buf,lImgBuffer: singlep; + //l16Buf : SmallIntP; + //lWordX: Word; + //lSPM2: boolean; + lOutF,lInF: File; + lO: TNIIOpts; +begin + result := ''; + if (lDorsalCrop = 0) and (lVentralCrop = 0) + and (lLCrop = 0) and (lRCrop = 0) + and (lACrop = 0) and (lPCrop = 0) then begin + dcmMsg('Crop slices quitting: no need to delete slices.'); + exit; //25 Sept 2008 + end; + if (lDorsalCrop < 0) or (lVentralCrop < 0) + or (lLCrop < 0) or (lRCrop < 0) + or (lACrop < 0) or (lPCrop < 0) then begin + dcmMsg('Crop slices quitting: negative values should be impossible.'); + exit; + end; + result := ''; + lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lInHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + //Next create reordered or trimmed image in the correct format + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + dcmMsg('Crop 3D unsupported datatype.'); + exit; + end; + end; + dcmMsg('Cropping NIfTI/Analyze image '+lFileName); + lOutHdr := lInHdr; + //lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]; + lBPP := (lInHdr.bitpix div 8); //bytes per pixel + if not NIFTIhdr_LoadImg (lFileName, lInHdr, lSrcBuffer, lImgOffset,lO) then exit; + //dcmMsg('Automatically Cropping image'); + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + //next compute size of cropped volume + lOutHdr.Dim[1] := lInHdr.Dim[1]-lLCrop-lRCrop; + lOutHdr.Dim[2] := lInHdr.Dim[2]-lACrop-lPCrop; + lOutHdr.Dim[3] := lInHdr.Dim[3]-lDorsalCrop-lVentralCrop; + if (lOutHdr.Dim[1] < 1) or (lOutHdr.Dim[2] <12) or (lOutHdr.Dim[3] < 1) then begin + dcmMsg('Requested to crop more slices than available.'); + Freemem(lSrcBuffer); + exit; + end; + //lVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*lBPP; + //next: readjust origin to take into account removed slices + //REQUIRES images to be aligned to nearest orthogonal to canonical space [1 0 0; 0 1 0; 0 0 1] + NIFTIhdr_SlicesToCoord (lInHdr,lLCrop,lPCrop,lVentralCrop, lXmm,lYmm,lZmm); + lOutHdr.srow_x[3] := lInHdr.srow_x[3] + lXmm; + lOutHdr.srow_y[3] := lInHdr.srow_y[3] + lYmm; + lOutHdr.srow_z[3] := lInHdr.srow_z[3] + lZmm; + lMat := Matrix3D ( + lOutHdr.srow_x[0], lOutHdr.srow_x[1], lOutHdr.srow_x[2], lOutHdr.srow_x[3], + lOutHdr.srow_y[0], lOutHdr.srow_y[1], lOutHdr.srow_y[2], lOutHdr.srow_y[3], + lOutHdr.srow_z[0], lOutHdr.srow_z[1], lOutHdr.srow_z[2], lOutHdr.srow_z[3], + 0, 0, 0, 1); + nifti_mat44_to_quatern( lMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + lXmm, lYmm, lZmm, lOutHdr.pixdim[0]{QFac}); + //note we write and read to the same buffer - we will always SHRINK output + //no need to byteswap data - we will save in the save format as stored + + lOutPos := 0; + lInSliceSz := lInHdr.dim[1]*lInHdr.dim[2]*lBPP; + lInXSz := lInHdr.dim[1]*lBPP; + for lVol := 1 to lOutHdr.dim[4] do begin + lInVol := (lVol-1) * (lInSliceSz * lInHdr.dim[3]); + //fx(lInVol,lVol); + for lZ := 1 to lOutHdr.dim[3] do begin + lInZOffset := (lVentralCrop+lZ-1) * lInSliceSz; + for lY := 1 to lOutHdr.dim[2] do begin + lInYOffset := ((lPCrop+lY-1) * lInXSz) + lInZOffset + (lLCrop*lBPP); + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lBPP) + lInYOffset + lB; + lBuffer^[lOutPos] := lBuffer^[lInPos+lInVol]; + end; + end; + end; //for Y + end; //for Z + end; //for Vol + lOutname := ChangeFilePrefix (lFileName,'c'); + result := SaveNIfTICore (lOutName, lSrcBuffer, kNIIImgOffset+1, lOutHdr, lPrefs); + Freemem(lSrcBuffer); +end; + +function CropNIfTI(lFilename: string; lPrefs: TPrefs): string; +//to do : data swapping (errors on detection and writing zero in reverse order) +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lXmm,lYmm,lZmm: single; + lMat: TMatrix; + lOutPos,lImgSamples,lInc, + lX,lY,lZ,lBPP, lB, + lInZOffset,lInYOffset,lInSliceSz,lInXSz,lInPos,lImgOffset: integer; + lSrcBuffer,lBuffer, lBuffUnaligned: bytep; + l32Buf,lImgBuffer: singlep; + l16Buf : SmallIntP; + //lOutF,lInF: File; + lACrop,lPCrop,lDorsalCrop,lVentralCrop,lLCrop,lRCrop: integer; + lO: TNIIOpts; +begin + result := ''; + lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lInHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + if (lInHdr.dim[1] > lPrefs.MaxReorientMatrix) or (lInHdr.dim[2] > lPrefs.MaxReorientMatrix) or(lInHdr.dim[3] > lPrefs.MaxReorientMatrix) then begin + dcmMsg('This image will not be cropped (larger than MaxReorientMatrix= '+inttostr(lPrefs.MaxReorientMatrix)); + exit; + end; + //check orthogonal alignment.... + if lInHdr.dim[4] > 1 then begin + dcmMsg('Only able to Crop 3D images (reorienting 4D could disrupt slice timing and diffusion directions.'); + exit; + end; + //Next create reordered or trimmed image in the correct format + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + dcmMsg('Crop 3D unsupported datatype.'); + exit; + end; + end; + + dcmMsg('Cropping NIfTI/Analyze image '+lFileName); + lOutHdr := lInHdr; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]; + lBPP := (lInHdr.bitpix div 8); //bytes per pixel + //lVolBytes := lImgSamples*lBPP; + if not NIFTIhdr_LoadImg (lFileName, lInHdr, lSrcBuffer, lImgOffset,lO) then exit; + //dcmMsg('Automatically Cropping image'); + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + GetMem(lBuffUnaligned ,(sizeof(single)*lImgSamples) + 16); + {$IFDEF FPC} + lImgBuffer :=align(lBuffUnaligned,16); + {$ELSE} + lImgBuffer := SingleP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + case lInHdr.datatype of + kDT_UNSIGNED_CHAR : begin //8 bit + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := lBuffer^[lInc]; + end; + + kDT_SIGNED_SHORT{,kDT_UINT16}: begin //16-bit int + l16Buf := SmallIntP(lBuffer ); + + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := l16Buf^[lInc]; + + end;//16bit + kDT_SIGNED_INT: begin + l32Buf := SingleP(lBuffer ); + //convert integer to float + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := Conv4r4i(l32Buf^[lInc]); + end; //32-bit int + kDT_FLOAT: begin + l32Buf := SingleP(lBuffer); + for lInc := 1 to lImgSamples do + lImgBuffer[lInc] := l32Buf[lInc]; + for lInc := 1 to lImgSamples do + if specialsingle(lImgBuffer^[lInc]) then lImgBuffer^[lInc] := 0.0; + //invert= for lInc := 1 to lImgSamples do l32Buf[lInc] := -l32Buf[lInc]; + end; //32-bit float + else begin + dcmMsg('Serious error: format not supported by Crop3D.'); + exit; + end; + end; //case + FindDVCrop (lInHdr, lImgBuffer, lDorsalCrop,lVentralCrop, 5); + FindDVCrop2 (lInHdr, lDorsalCrop,lVentralCrop); + FindLRCrop (lInHdr, lImgBuffer, lLCrop,lRCrop,3,lDorsalCrop,lVentralCrop);//3% often sagittal scans near brain + FindAPCrop (lInHdr, lImgBuffer, lACrop,lPCrop, 5,lDorsalCrop,lVentralCrop); + FreeMem(lBuffUnaligned); + if (lDorsalCrop = 0) and (lVentralCrop = 0) + and (lLCrop = 0) and (lRCrop = 0) + and (lACrop = 0) and (lPCrop = 0) then begin + dcmMsg('Crop 3D quitting: no need to delete slices.'); + Freemem(lSrcBuffer); + exit; //25 Sept 2008 + end; + if (lDorsalCrop < 0) or (lVentralCrop < 0) + or (lLCrop < 0) or (lRCrop < 0) + or (lACrop < 0) or (lPCrop < 0) then begin + dcmMsg('Crop 3D quitting: negative values should be impossible.'); + beep; + Freemem(lSrcBuffer); + end; + //next compute size of cropped volume + lOutHdr.Dim[1] := lInHdr.Dim[1]-lLCrop-lRCrop; + lOutHdr.Dim[2] := lInHdr.Dim[2]-lACrop-lPCrop; + lOutHdr.Dim[3] := lInHdr.Dim[3]-lDorsalCrop-lVentralCrop; + //lVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*lBPP; + //next: readjust origin to take into account removed slices + //REQUIRES images to be aligned to nearest orthogonal to canonical space [1 0 0; 0 1 0; 0 0 1] + NIFTIhdr_SlicesToCoord (lInHdr,lLCrop,lPCrop,lVentralCrop, lXmm,lYmm,lZmm); + lOutHdr.srow_x[3] := lInHdr.srow_x[3] + lXmm; + lOutHdr.srow_y[3] := lInHdr.srow_y[3] + lYmm; + lOutHdr.srow_z[3] := lInHdr.srow_z[3] + lZmm; + lMat := Matrix3D ( + lOutHdr.srow_x[0], lOutHdr.srow_x[1], lOutHdr.srow_x[2], lOutHdr.srow_x[3], + lOutHdr.srow_y[0], lOutHdr.srow_y[1], lOutHdr.srow_y[2], lOutHdr.srow_y[3], + lOutHdr.srow_z[0], lOutHdr.srow_z[1], lOutHdr.srow_z[2], lOutHdr.srow_z[3], + 0, 0, 0, 1); + nifti_mat44_to_quatern( lMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + lXmm, lYmm, lZmm, lOutHdr.pixdim[0]{QFac}); + //note we write and read to the same buffer - we will always SHRINK output + //no need to byteswap data - we will save in the save format as stored + + + lOutPos := 0; + lInSliceSz := lInHdr.dim[1]*lInHdr.dim[2]*lBPP; + lInXSz := lInHdr.dim[1]*lBPP; + for lZ := 1 to lOutHdr.dim[3] do begin + lInZOffset := (lVentralCrop+lZ-1) * lInSliceSz; + for lY := 1 to lOutHdr.dim[2] do begin + lInYOffset := ((lPCrop+lY-1) * lInXSz) + lInZOffset + (lLCrop*lBPP); + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lBPP) + lInYOffset + lB; + lBuffer^[lOutPos] := lBuffer^[lInPos]; + end; + end; + end; //for Y + end; //for Z + lOutname := ChangeFilePrefix (lFileName,'c'); + result := SaveNIfTICore (lOutName, lSrcBuffer, kNIIImgOffset+1, lOutHdr, lPrefs); + Freemem(lSrcBuffer); +end; + + +(*function CropNIfTI(lFilename: string; lPrefs: TPrefs): string; +var + + lTempName,lExt,lNameWOExt: string; + lHdr: TNIFTIhdr; + lByteSwap: boolean; +begin + result := ''; + lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lByteSwap) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + //check orthogonal alignment.... + if lHdr.dim[4] > 1 then begin + dcmMsg('Only able to Crop 3D images (reorienting 4D could disrupt slice timing and diffusion directions.'); + exit; + end; + //next - determine output format + + if lExt = '.NII.GZ' then begin + //lTempName := lFilename;//ChangeFilePrefixExt (lFileName,'x'); + ExtractFileParts (lFileName, lNameWOExt,lExt); + lTempName := lNameWOExt+'.nii'; + Gunzip(lFileName,lTempName); + lFilename := lTempName; + end else //not gzip + lTempName := ''; + //Next create reordered or trimmed image in the correct format + result := Crop(lFileName, lHdr,lByteSwap, lPrefs.SPM2,lPrefs.SingleNIIFile, false); + + if (result <> '') and (lPrefs.GZip) then begin + GZipFile(lFileName,lFileName+'.gz',true); + result := result +'.gz'; + end; + + if lTempName <> '' then //delete GZip temp + deletefile(lTempName); +end; *) + +function SiemensPhase2RadiansNIfTI(lFilename: string; lPrefs: TPrefs): string; +//convert any data format as 32-bit float.... +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lMax,lMin,lImgSamples,lInc,lImgOffset: integer; + lSrcBuffer,lBuffer, lBuffUnaligned,lBuffAligned: bytep; + //l32Buf, + lImgBuffer: singlep; + l16Buf : SmallIntP; + lO: TNIIOpts; +begin + result := ''; + lExt := UpCaseExt(lFilename); + if not NIFTIhdr_LoadHdr (lFilename, lInHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + if lInHdr.datatype <> kDT_SIGNED_SHORT then begin + dcmMsg('Unable to run SiemensPhase2Radians : input image must be 16-bit NIfTI image with intensities 0..4096 corresponding to -pi..+pi : '+lFilename); + exit; + end; + //dcmMsg('SiemensPhase2Radians converting 16-bit image (0..4095) to 32-bit float (-pi..+pi).'+lFileName); + lOutHdr := lInHdr; + lOutHdr.datatype := kDT_FLOAT; + lOutHdr.bitpix := 32; + lOutHdr.scl_slope := 1; + lOutHdr.scl_inter := 0; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lInHdr.dim[4]; + if not NIFTIhdr_LoadImg (lFileName, lInHdr, lSrcBuffer, lImgOffset,lO) then exit; + lBuffer := (@lSrcBuffer^[lImgOffset+1]); + GetMem(lBuffUnaligned ,(sizeof(single)*lImgSamples) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := align(lBuffUnaligned,16); + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lInc := 1; + lImgBuffer := SingleP(@lBuffAligned^[kNIIImgOffset+lInc]); + l16Buf := SmallIntP(lBuffer ); + lMax := l16Buf^[1]; + for lInc := 1 to lImgSamples do + if l16Buf^[lInc] > lMax then + lMax := l16Buf^[lInc]; + lMin := l16Buf^[1]; + for lInc := 1 to lImgSamples do + if l16Buf^[lInc] < lMin then + lMin := l16Buf^[lInc]; + if (lMin < 0) or (lMax > 4096) then + dcmMsg('Error: SiemensPhase2Radians expects input data with raw intensity ranging from 0..4096 (corresponding to -pi..+pi) - this image''s intensity is not in these bounds'+lFileName) + else begin + dcmMsg('SiemensPhase2Radians converting 0..4096 to -pi..+pi '+ lFilename); + //Excel formula =((A1-2048)/2048)*PI() + //fx(lMin,lMax); + for lInc := 1 to lImgSamples do + lImgBuffer^[lInc] := ((l16Buf^[lInc]-2048)/2048)*pi; + lOutname := ChangeFilePrefix (lFileName,'rad'); + result := SaveNIfTICore (lOutName, lBuffAligned, kNIIImgOffset+1, lOutHdr, lPrefs); + end; + Freemem(lBuffUnaligned); + Freemem(lSrcBuffer); +end; + + + +end. + \ No newline at end of file diff --git a/dcm2nii/nii_crop.ppu b/dcm2nii/nii_crop.ppu new file mode 100644 index 0000000..9971752 Binary files /dev/null and b/dcm2nii/nii_crop.ppu differ diff --git a/dcm2nii/nii_math.o b/dcm2nii/nii_math.o new file mode 100644 index 0000000..47e54f5 Binary files /dev/null and b/dcm2nii/nii_math.o differ diff --git a/dcm2nii/nii_math.pas b/dcm2nii/nii_math.pas new file mode 100755 index 0000000..c7f7f92 --- /dev/null +++ b/dcm2nii/nii_math.pas @@ -0,0 +1,596 @@ +unit nii_math; + +interface +{$H+} +uses + //nii_types,nii_write, + niftiutil,dicomtypes,prefs, + define_types, sysutils, dialogsx,GraphicsMathLibrary, nifti_types; + +type + TNIFTIimg = record + HdrName: string; + Hdr: TNIFTIhdr; + Opts: TNIIOpts; + //ByteSwap: boolean; + Offset: integer; + Buffer,i8: bytep; + f32: singlep; + i32 : longintP; + i16 : SmallIntP; + end; +function RMS3d (lAName,lBName,lMaskName: string; lMaskThresh: single; lSaveOutput: boolean; lPrefs: TPrefs):double; +function AddSlices (lAName: string; lSlices: integer; lPrefs: TPrefs):boolean; +function ReportMinMax (lAName: string): boolean; +function Hounsfield2NormScale (lAName: string; lPrefs: TPrefs):boolean; +function ShrinkNII (lAName: string; lPrefs: TPrefs): boolean; + +implementation + +procedure CreateNII(var lNII: TNIfTIimg); +begin + lNII.Buffer := nil; +end; + +procedure FreeNII(var lNII: TNIfTIimg); +begin + if lNII.Buffer <> nil then + Freemem(lNII.Buffer); +end; + +function LoadHdrNII(lFilename: string; var lNII: TNIfTIimg): boolean; +begin + result := false; + lNII.HdrName := lFilename; + if not NIFTIhdr_LoadHdr (lNII.HdrName, lNII.Hdr, lNII.Opts) then begin; + ShowMsg('Header load error '+lFilename); + exit; + end; + result := true; +end; + +function SubBound (lVal,lMin: integer): integer; +begin + result := lVal; + if result < lMin then + result := lMin; +end; + +function NonspatialDimensionsNII (lA: TNIFTIimg): integer; +//returns sum of 4th, 5th, 6th and 7th dimension... +begin + result := SubBound(lA.Hdr.dim[4],1)*SubBound(lA.Hdr.dim[5],1)*SubBound(lA.Hdr.dim[6],1)*SubBound(lA.Hdr.dim[7],1); +end; + +function LoadImgNII(lFilename: string; var lNII: TNIfTIimg): boolean; +begin + result := false; + if not LoadHdrNII(lFilename,lNII) then + exit; + if not NIFTIhdr_LoadImgRaw (False,lNII.HdrName, lNII.Hdr, lNII.Buffer, lNII.Offset,lNII.Opts) then begin + ShowMsg('Image load error '+lFilename); + exit; + end; + lNII.f32 := SingleP(@lNII.Buffer^[lNII.Offset+1]); + lNII.i32 := LongintP(@lNII.Buffer^[lNII.Offset+1]); + lNII.i16 := SmallIntP(@lNII.Buffer^[lNII.Offset+1]); + lNII.i8 := ByteP(@lNII.Buffer^[lNII.Offset+1]); + result := true; +end; + +procedure Force3DNII (var lNII: TNIFTIimg); +begin + lNII.Hdr.dim[0] := 3; + lNII.Hdr.dim[4] := 1; + lNII.Hdr.Dim[5] := 1; + lNII.Hdr.Dim[6] := 1; + lNII.Hdr.Dim[7] := 1; +end; + +function CreateEmptyImgNII(lHdr: TNIFTIHdr; var lNII: TNIfTIimg): boolean; +var + lVol,lImgBytes,lFileBytes: integer; +begin + result := false; + //FreeNII ??? + lNII.Hdr := lHdr; + lNII.Offset := kNIIImgOffset;// (=352) bytes for creating .nii.gz files + lVol := NonspatialDimensionsNII(lNiI); + //lVol := lHdr.dim[4]+lHdr.dim[5]+lHdr.dim[6]+lHdr.dim[7]; //crepes + if lVol < 1 then + lVol := 1; + lImgBytes := lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3]*lVol*(lHdr.bitpix div 8); + if lImgBytes < 1 then + exit; + lFileBytes := lImgBytes+ kNIIImgOffset; + GetMem(lNII.Buffer,lFileBytes); + lNII.f32 := SingleP(@lNII.Buffer^[lNII.Offset+1]); + lNII.i32 := LongintP(@lNII.Buffer^[lNII.Offset+1]); + lNII.i16 := SmallIntP(@lNII.Buffer^[lNII.Offset+1]); + lNII.i8 := ByteP(@lNII.Buffer^[lNII.Offset+1]); + result := true; +end; + + +function MinMaxNII(var lNII: TNIfTIimg; lVol: integer; ApplyHdrScaling: boolean; var lMin,lMax: double): boolean; +//returns min and max intensity in as Volume. +//For 4D data, use lVol to specify the volume +// if lVol < 1 then all volumes +var + i,lnVol,lVox,lVoxOffset: integer; +begin + result := false; + if lNII.Buffer = nil then begin + showmsg('MinMax Error: image not loaded.'); + exit;//image not loaded... + end; + lnVol := NonspatialDimensionsNII(lNiI); + lVox := lNII.Hdr.dim[1]*lNII.Hdr.dim[2]*lNII.Hdr.dim[3]; + if (lnVol < 1) or (lVox < 1) then + exit; + lVoxOffset := 0; + if (lVol < 1) or (lVol > lnVol) then + lVox := lVox * lnVol + else + lVoxOffset := (lVol-1)*lVox; + case lNII.Hdr.datatype of + kDT_UNSIGNED_CHAR: begin + lMin := lNII.i8^[lVoxOffset+1]; + lMax := lMin; + for i := 1 to lVox do + if lNII.i8^[lVoxOffset+i] > lMax then + lMax := lNII.i8^[lVoxOffset+i]; + for i := 1 to lVox do + if lNII.i8^[lVoxOffset+i] < lMin then + lMin := lNII.i8^[lVoxOffset+i]; + end;//CHAR + kDT_SIGNED_SHORT: begin + lMin := lNII.i16^[lVoxOffset+1]; + lMax := lMin; + for i := 1 to lVox do + if lNII.i16^[lVoxOffset+i] > lMax then + lMax := lNII.i16^[lVoxOffset+i]; + for i := 1 to lVox do + if lNII.i16^[lVoxOffset+i] < lMin then + lMin := lNII.i16^[lVoxOffset+i]; + end;//kDT_SIGNED_SHORT + kDT_SIGNED_INT: begin + lMin := lNII.i32^[lVoxOffset+1]; + lMax := lMin; + for i := 1 to lVox do + if lNII.i32^[lVoxOffset+i] > lMax then + lMax := lNII.i32^[lVoxOffset+i]; + for i := 1 to lVox do + if lNII.i32^[lVoxOffset+i] < lMin then + lMin := lNII.i32^[lVoxOffset+i]; + end;//kDT_SIGNED_INT + kDT_FLOAT: begin + lMin := lNII.f32^[lVoxOffset+1]; + lMax := lMin; + for i := 1 to lVox do + if lNII.f32^[lVoxOffset+i] > lMax then + lMax := lNII.f32^[lVoxOffset+i]; + for i := 1 to lVox do + if lNII.f32^[lVoxOffset+i] < lMin then + lMin := lNII.f32^[lVoxOffset+i]; + end;//float + end;// datatype + if ApplyHdrScaling then begin + lMin := (lMin * lNII.hdr.scl_slope)+lNII.hdr.scl_inter; + lMax := (lMax * lNII.hdr.scl_slope)+lNII.hdr.scl_inter; + end; + result := true; +end; + +function SameHdrDimNII (lA,lB: TNIFTIimg; lCheck4D, lCheckDataType: boolean): boolean; +begin + result := SameHdrDim (lA.Hdr,lB.Hdr, lCheck4D, lCheckDataType); + if not result then + ShowMsg('Dimensions differ '+lA.Hdrname+' <> '+lB.HdrName); +end; + +function ReportMinMax (lAName: string): boolean; +label + 666; +var + lA: TNIfTIimg; + lMin,lMax: double; +begin + result := false; + CreateNII(lA); + if not LoadImgNII(lAName,lA) then + goto 666; + if not MinMaxNII(lA,0,true,lMin,lMax) then + goto 666; + showmsg(lAName+kTab+'Min'+floattostr(lMin)+kTab+'Max:'+floattostr(lMax)); + result := true; +666: + FreeNII(lA); +end; + +function Hounsfield2NormScale (lAName: string; lPrefs: TPrefs):boolean; +//Hounsfield scaled data in the range +//Air -1000 +//Fat 120 +//Water 0 +//Muscle ~40 +//Contrast +130 +//Bone >400 (typically ~1000) +//problem 1: SPM assume 0 is dark [zero fills edges] - so we need to make minimum 0 +//note the contrast of interest is in the compressed range -100..+200 +//http://en.wikipedia.org/wiki/Hounsfield_units +const + kUninterestingDarkUnits = 900; // e.g. -1000..-100 + kInterestingMidUnits = 300; //e.g. -100..+300 + kScaleRatio = 2;// increase dynamic range of interesting voxels by 3 +label + 666; +var + lA,lOut: TNIfTIimg; + lMin,lMax,lRange: double; + i,lVox: integer; + v16,lExtra,lMin16: SmallInt; + //lPrefs: TPrefs; + lOName: string; +begin + result := false; + CreateNII(lA); + CreateNII(lOut); + if not LoadImgNII(lAName,lA) then + goto 666; + if lA.Hdr.datatype <> kDT_SIGNED_SHORT then begin + showmsg('Hounsfield2NormScale Error: Image datatype must be 16-bit integer : '+lAName); + goto 666; + end; + lVox := lA.Hdr.dim[1]*lA.Hdr.dim[2]*lA.Hdr.dim[3]*NonspatialDimensionsNII(lA); + if lVox < 1 then + goto 666; + if not MinMaxNII(lA,0,false,lMin,lMax) then + goto 666; + lRange := lMax-lMin; + if lRange < 1800 then begin + //note assume integer data type with scaling... + showmsg('Hounsfield2NormScale Error: dark to bright regions of a Hounsfield calibrated CT scan of the brain should exceed 1800 (air=-1000,bone=1000) : '+lAName); + goto 666; + end; + //create output + lOut.Hdr := lA.Hdr; + force3DNII(lOut); + lOut.Hdr.datatype := kDT_SIGNED_SHORT; + lOut.Hdr.scl_slope := 1; + lOut.Hdr.scl_inter := 0; + CreateEmptyImgNII(lOut.Hdr, lOut); + //translate values + lMin16 := round(lMin); + case lA.Hdr.datatype of + kDT_SIGNED_SHORT: begin + for i := 1 to lVox do begin + v16 := lA.i16^[i]-lMin16; + lExtra := v16-kUninterestingDarkUnits; + if lExtra > kInterestingMidUnits then + lExtra := kInterestingMidUnits; + if lExtra > 0 then + lExtra := lExtra*kScaleRatio + else + lExtra := 0; + lOut.i16^[i] := v16+lExtra; + end; + lOut.i16^[1] := 0;//ANTS uses this voxel for background color + end;//kDT_SIGNED_SHORT + else begin + Showmsg('Unsupported datatype'); + end;//float + end;// datatype + //Save data + lOName := ChangeFilePrefix(lAName,'x'); + //SetDefaultPrefs (lPrefs); + //lOName := lAName; + //lPrefs.gzip := true; + SaveNIfTICore (lOName, lOut.Buffer, kNIIImgOffset+1, lOut.Hdr, lPrefs); + result := true; +666: + FreeNII(lA); + FreeNII(lOut); +end; + +function RMS3d (lAName,lBName,lMaskName: string; lMaskThresh: single; lSaveOutput: boolean; lPrefs: TPrefs):double; +//Determines Root Mean Square Error between A and B +// both A and B are 3D images +// Mean for each voxel sqrt(X^2+Y^2+Z^2) +//OPTIONAL: Mask image (set name to '' to ignore) +const +NaN : double = 1/0; +kErrorStr = 'RMS'; +label + 666; +var + lA,lB,lMask,lOut: TNIfTIimg; + lSum,lRMS: double; + lV,lVox,lCount,lMaskCount: integer; + lUseMask: boolean; + //lPrefs: TPrefs; + lOName: string; +begin + result := 0; + lUseMask := false; + CreateNII(lA); + CreateNII(lB); + CreateNII(lMask); + CreateNII(lOut); + if not LoadImgNII(lAName,lA) then + goto 666; + if not LoadImgNII(lBName,lB) then + goto 666; + if not SameHdrDimNII(lA,lB,true,true) then + goto 666; + if NonspatialDimensionsNII(lA) <> 3 then begin + ShowMsg('Image must have 3 volumes [not '+inttostr(NonspatialDimensionsNII(lA))+'] ' +lAName); + goto 666; + end; + lVox := lA.Hdr.Dim[1]*lA.Hdr.Dim[2] * lA.Hdr.Dim[3]; + if lVox < 1 then + goto 666; + case lA.Hdr.datatype of + kDT_FLOAT:;//lBPP := 4; + else begin + ShowMsg(kErrorStr+' datatype not supported.'); + exit; + end; + end; //case + //next lines: mask.... + if (lMaskName <> '') and (not fileexists(lMaskName)) then + ShowMsg(kErrorStr+'unable to find mask '+lMaskName) + else if (lMaskName <> '') and (fileexists(lMaskName)) then begin + lUseMask := true; + if not LoadImgNII(lMaskName,lMask) then + goto 666; + if lMask.Hdr.datatype <> kDT_FLOAT then begin + ShowMsg(kErrorStr+'datatype not supported. '+lMaskName); + goto 666; + end; + if not SameHdrDimNII(lA,lMask,true,true) then + goto 666; + end; //mask + //output + if lSaveOutput then begin + lOut.Hdr := lA.Hdr; + force3DNII(lOut); + lOut.Hdr.datatype := kDT_FLOAT; + CreateEmptyImgNII(lOut.Hdr, lOut); + for lV := 1 to lVox do + lOut.f32^[lV] := 0; + end; + lSum:= 0; + lCount := 0; + lMaskCount := 0; + case lA.Hdr.datatype of + kDT_FLOAT: begin + for lV := 1 to lVox do begin + if (not (lUseMask)) or ((not SpecialSingle(lMask.f32^[lV])) and (lMask.f32^[lV]> lMaskThresh)) then begin + inc(lMaskCount); + if (not SpecialSingle(lA.f32^[lV])) and (not SpecialSingle(lA.f32^[lV+lVox])) and (not SpecialSingle(lA.f32^[lV+lVox+lVox])) + and (not SpecialSingle(lB.f32^[lV])) and (not SpecialSingle(lB.f32^[lV+lVox])) and (not SpecialSingle(lB.f32^[lV+lVox+lVox])) then begin + //if true then begin + inc(lCount); + lRMS := sqrt(sqr(lA.f32^[lV]-lB.f32^[lV])+ sqr(lA.f32^[lV+lVox]-lB.f32^[lV+lVox])+sqr(lA.f32^[lV+lVox+lVox]-lB.f32^[lV+lVox+lVox])); + if (lSaveOutput) then begin + try //switch from double to single precision... + lOut.f32^[lV] := lRMS; + except + lOut.f32^[lV] := NAN; + end; //except + end; + lSum := lSum + lRMS; + end; //not special - i.e. NaN + + end;//in mask + end;//each 3D voxel + end; //kDT_FLOAT + end;//case of datatype + + if lMaskCount = 0 then + ShowMsg(kErrorStr+' No voxels greater than '+floattostr(lMaskThresh)+' in mask '+lMaskName) + else if lCount = 0 then + ShowMsg(kErrorStr+' No valid voxels. All NaN?') + else if lSaveOutput then begin + lOName := ChangeFilePrefix(lAName,'Xrms'); + //SetDefaultPrefs (lPrefs); + SaveNIfTICore (lOName, lOut.Buffer, kNIIImgOffset+1, lOut.Hdr, lPrefs); + end; + if lCount > 0 then + result := lSum/lCount; +666: + FreeNII(lA); + FreeNII(lB); + FreeNII(lMask); + FreeNII(lOut); +end; + +function AddSlices (lAName: string; lSlices: integer; lPrefs: TPrefs):boolean; +const +NaN : double = 1/0; +kErrorStr = 'RMS'; +label + 666; +var + lA,lOut: TNIfTIimg; + lOffset,lV,lS,lI,lVolBytes,lSliceBytes: integer; + //lPrefs: TPrefs; + lOName: string; +begin + result := false; + if lSlices < 1 then + exit; + CreateNII(lA); + CreateNII(lOut); + if not LoadImgNII(lAName,lA) then + goto 666; + lSliceBytes := lA.hdr.dim[1]*lA.hdr.dim[2]*trunc(((lA.Hdr.bitpix)+7)/8); + lVolBytes := lSliceBytes * lA.hdr.dim[3]; + if (lSliceBytes < 1) or (lVolBytes < 1) then + goto 666; + lOut.Hdr := lA.Hdr; + force3DNII(lOut); + lOut.hdr.dim[3] := lOut.hdr.dim[3] + lSlices; + lOut.Hdr.datatype := kDT_FLOAT; + CreateEmptyImgNII(lOut.Hdr, lOut); + lI := 0; + //lOffset := 0; + lOffset := lSliceBytes * 10; + for lS :=1 to lSlices do + for lV := 1 to (lSliceBytes) do begin + inc(lI); + //lOut.i8^[lI] := 0; + lOut.i8^[lI] := lA.i8^[lV+lOffset] + end; + lSliceBytes := lSliceBytes * lSlices; + for lV := 1 to lVolBytes do + lOut.i8^[lV+lSliceBytes] := lA.i8^[lV]; + + //lOffset := 0; + lSliceBytes := lA.hdr.dim[1]*lA.hdr.dim[2]*trunc(((lA.Hdr.bitpix)+7)/8); + lI := 0; + lOffset := lSliceBytes * 10; + for lS :=1 to 18 do + for lV := 1 to (lSliceBytes) do begin + inc(lI); + //lOut.i8^[lI] := 0; + lOut.i8^[lI] := lA.i8^[lV+lOffset] + end; + + lOName := ChangeFilePrefix(lAName,'x'); + //SetDefaultPrefs (lPrefs); + if SaveNIfTICore (lOName, lOut.Buffer, kNIIImgOffset+1, lOut.Hdr, lPrefs) <> '' then + result := true; +666: + FreeNII(lA); + FreeNII(lOut); +end; + +procedure RescaleHdr (var lHdr: TNIFTIHdr; lX,lY,lZ: double); +var + lIn,lScale,lResidualMat: TMatrix; + dx, dy, dz: single; +begin + lIn := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], + 0,0,0,1); + lScale := Matrix3D (lX,0,0,0, + 0,lY,0,0, + 0,0,lZ,0, + 0,0,0,1); + lResidualMat := MultiplyMatrices(lIn,lScale); + lHdr.srow_x[0] := lResidualMat.Matrix[1,1]; + lHdr.srow_x[1] := lResidualMat.Matrix[1,2]; + lHdr.srow_x[2] := lResidualMat.Matrix[1,3]; + lHdr.srow_y[0] := lResidualMat.Matrix[2,1]; + lHdr.srow_y[1] := lResidualMat.Matrix[2,2]; + lHdr.srow_y[2] := lResidualMat.Matrix[2,3]; + lHdr.srow_z[0] := lResidualMat.Matrix[3,1]; + lHdr.srow_z[1] := lResidualMat.Matrix[3,2]; + lHdr.srow_z[2] := lResidualMat.Matrix[3,3]; + lHdr.srow_x[3] := lResidualMat.Matrix[1,4]; + lHdr.srow_y[3] := lResidualMat.Matrix[2,4]; + lHdr.srow_z[3] := lResidualMat.Matrix[3,4]; + nifti_mat44_to_quatern( lResidualMat, + lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + dx, dy, dz,lHdr.pixdim[0] {QFac}); +end; + +function ShrinkNII(lAName: String; lPrefs: TPrefs): boolean; +//Halves X and Y dimensions +label + 666; +var + lOName: string; + lo,li,lx,lyz: integer; + lA,lOut: TNIfTIimg; +begin + result := false; + CreateNII(lA); + CreateNII(lOut); + if not LoadImgNII(lAName,lA) then + goto 666; + if odd(lA.hdr.dim[1]) or odd(lA.hdr.dim[2]) then begin + ShowMsg('ShrinkNII error X and Y must be divisible by 2 '+inttostr(lA.hdr.dim[1])+' '+inttostr(lA.hdr.dim[2])); + goto 666; + end; + case lA.Hdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT , kDT_SIGNED_INT, kDT_FLOAT:;//lBPP := 4; + else begin + ShowMsg('ShrinkNII datatype not supported.'); + exit; + end; + end; //case + + lOut.Hdr := lA.Hdr; + force3DNII(lOut); + lOut.hdr.dim[1] := lOut.hdr.dim[1] div 2; + lOut.hdr.dim[2] := lOut.hdr.dim[2] div 2; + lOut.hdr.pixdim[1] := lOut.hdr.pixdim[1] * 2; + lOut.hdr.pixdim[2] := lOut.hdr.pixdim[2] * 2; + RescaleHdr(lOut.hdr,2,2,1); + CreateEmptyImgNII(lOut.Hdr, lOut); + case lA.Hdr.datatype of + kDT_UNSIGNED_CHAR: begin + li := 1; + lo := 1; + for lyz := 1 to (lOut.hdr.dim[2]*lOut.hdr.dim[3]) do begin + for lx := 1 to lOut.hdr.dim[1] do begin + lOut.i8^[lo] := (lA.i8^[li]+lA.i8^[li+1]+lA.i8^[li]+lA.i8^[li+1]) div 4; + inc(li,2); //skip voxel + inc(lo); + end;//x + inc(li,lA.hdr.dim[1]); //skip line + end;//yz + end;//CHAR + kDT_SIGNED_SHORT: begin + li := 1; + lo := 1; + for lyz := 1 to (lOut.hdr.dim[2]*lOut.hdr.dim[3]) do begin + for lx := 1 to lOut.hdr.dim[1] do begin + lOut.i16^[lo] := (lA.i16^[li]+lA.i16^[li+1]+lA.i16^[li]+lA.i16^[li+1]) div 4; + inc(li,2); //skip voxel + inc(lo); + end;//x + inc(li,lA.hdr.dim[1]); //skip line + end;//yz + end;//kDT_SIGNED_SHORT + kDT_SIGNED_INT: begin + li := 1; + lo := 1; + for lyz := 1 to (lOut.hdr.dim[2]*lOut.hdr.dim[3]) do begin + for lx := 1 to lOut.hdr.dim[1] do begin + lOut.i32^[lo] := (lA.i32^[li]+lA.i32^[li+1]+lA.i32^[li]+lA.i32^[li+1]) div 4; + inc(li,2); //skip voxel + inc(lo); + end;//x + inc(li,lA.hdr.dim[1]); //skip line + end;//yz + end;//kDT_SIGNED_INT + kDT_FLOAT: begin + li := 1; + lo := 1; + for lyz := 1 to (lOut.hdr.dim[2]*lOut.hdr.dim[3]) do begin + for lx := 1 to lOut.hdr.dim[1] do begin + lOut.f32^[lo] := (lA.f32^[li]+lA.f32^[li+1]+lA.f32^[li]+lA.f32^[li+1]) / 4; + inc(li,2); //skip voxel + inc(lo); + end;//x + inc(li,lA.hdr.dim[1]); //skip line + end;//yz + end;//float + end;// datatype + lOName := ChangeFilePrefix(lAName,'d'); + if SaveNIfTICore (lOName, lOut.Buffer, kNIIImgOffset+1, lOut.Hdr, lPrefs) <> '' then + result := true; +666: + FreeNII(lA); + FreeNII(lOut); +end; + + +end. diff --git a/dcm2nii/nii_math.ppu b/dcm2nii/nii_math.ppu new file mode 100644 index 0000000..7f3cdde Binary files /dev/null and b/dcm2nii/nii_math.ppu differ diff --git a/dcm2nii/nii_orient.o b/dcm2nii/nii_orient.o new file mode 100644 index 0000000..7949992 Binary files /dev/null and b/dcm2nii/nii_orient.o differ diff --git a/dcm2nii/nii_orient.pas b/dcm2nii/nii_orient.pas new file mode 100755 index 0000000..38b1a2e --- /dev/null +++ b/dcm2nii/nii_orient.pas @@ -0,0 +1,727 @@ +unit nii_orient; +{$H+} +//reorients a NIfTI image to canonical space ... +//closest to canonical rotation matrix [1 0 0; 0 1 0; 0 0 1] +interface + +uses +{$IFDEF FPC}gzio2,{$ENDIF} + SysUtils,define_types,dicomtypes,niftiutil,GraphicsMathLibrary,prefs,dialogs_msg, nifti_types; + +function Reorient(var lHdrName: string; var lHdr: TNIFTIhdr; lPrefs: TPrefs; lOverwrite,lForce: boolean): string; +//function SuperReorient(var lHdrName: string; lPrefs: TPrefs):string; +function LRFlip(lFilename: string; lPrefs: TPrefs): boolean; + +implementation +uses dialogsx; +(*procedure Mx(var lM: TMatrix); +begin + Msg('=['+ + floattostr(lM.matrix[1,1])+', '+floattostr(lM.matrix[1,2])+', '+floattostr(lM.matrix[1,3])+', '+floattostr(lM.matrix[1,4])+'; '+ + floattostr(lM.matrix[2,1])+', '+floattostr(lM.matrix[2,2])+', '+floattostr(lM.matrix[2,3])+', '+floattostr(lM.matrix[2,4])+'; '+ + floattostr(lM.matrix[3,1])+', '+floattostr(lM.matrix[3,2])+', '+floattostr(lM.matrix[3,3])+', '+floattostr(lM.matrix[3,4])+'; '+ + ' 0, 0, 0, 1]'); +end;*) + + +function NIfTIAlignedM (var lM: TMatrix): boolean; +//check that diagonals are positive and all other cells are zero +//negative diagonals suggests flipping... +//non-negative other cells suggests the image is not pure axial +var + lr,lc: integer; +begin + result := false; + for lr := 1 to 3 do + for lc := 1 to 3 do begin + if (lr = lc) and (lM.matrix[lr,lc] <= 0) then + exit; + if (lr <> lc) and (lM.matrix[lr,lc] <> 0) then + exit; + end; + result := true; +end; + + +function NIfTIAligned (var lHdr: TNIFTIhdr): boolean; +//check that diagonals are positive and all other cells are zero +//negative diagonals suggests flipping... +//non-negative other cells suggests the image is not pure axial +var + lM: TMatrix; +begin + lM := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], + 0,0,0,1); + result := NIfTIAlignedM(lM); +end; + +procedure FromMatrix (M: TMatrix; var m11,m12,m13, m21,m22,m23, + m31,m32,m33: DOUBLE) ; + BEGIN + + m11 := M.Matrix[1,1]; + m12 := M.Matrix[1,2]; + m13 := M.Matrix[1,3]; + m21 := M.Matrix[2,1]; + m22 := M.Matrix[2,2]; + m23 := M.Matrix[2,3]; + m31 := M.Matrix[3,1]; + m32 := M.Matrix[3,2]; + m33 := M.Matrix[3,3]; +END {FromMatrix3D}; + +function nifti_mat44_orthogx( lR :TMatrix; lPrefs: TPrefs): TMatrix; +//returns rotation matrix required to orient image so it is aligned nearest to the identity matrix = +// 1 0 0 0 +// 0 1 0 0 +// 0 0 1 0 +// 0 0 0 1 +//Therefore, image is approximately oriented in space +var + lrow,lcol,lMaxRow,lMaxCol,l2ndMaxRow,l2ndMaxCol,l3rdMaxRow,l3rdMaxCol: integer; + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, val,lAbsmax,lAbs: double; + Q,Flip: TMatrix; //3x3 +begin + // load 3x3 matrix into local variables + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + Q := Matrix2D( r11,r12,r13,r21,r22,r23,r31,r32,r33); + // normalize row 1 + val := Q.matrix[1,1]*Q.matrix[1,1] + Q.matrix[1,2]*Q.matrix[1,2] + Q.matrix[1,3]*Q.matrix[1,3] ; + if( val > 0.0 )then begin + val := 1.0 / sqrt(val) ; + Q.matrix[1,1] := Q.matrix[1,1]*val ; + Q.matrix[1,2] := Q.matrix[1,2]*val ; + Q.matrix[1,3] := Q.matrix[1,3]*val ; + end else begin + Q.matrix[1,1] := 1.0 ; Q.matrix[1,2] := 0.0; Q.matrix[1,3] := 0.0 ; + end; + // normalize row 2 + val := Q.matrix[2,1]*Q.matrix[2,1] + Q.matrix[2,2]*Q.matrix[2,2] + Q.matrix[2,3]*Q.matrix[2,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[2,1] := Q.matrix[2,1]* val ; + Q.matrix[2,2] := Q.matrix[2,2] * val ; + Q.matrix[2,3] := Q.matrix[2,3] * val ; + end else begin + Q.matrix[2,1] := 0.0 ; Q.matrix[2,2] := 1.0 ; Q.matrix[2,3] := 0.0 ; + end; + // normalize row 3 + val := Q.matrix[3,1]*Q.matrix[3,1] + Q.matrix[3,2]*Q.matrix[3,2] + Q.matrix[3,3]*Q.matrix[3,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[3,1] := Q.matrix[3,1] *val ; + Q.matrix[3,2] := Q.matrix[3,2] *val ; + Q.matrix[3,3] := Q.matrix[3,3] *val ; + end else begin + Q.matrix[3,1] := Q.matrix[1,2]*Q.matrix[2,3] - Q.matrix[1,3]*Q.matrix[2,2] ; //* cross */ + Q.matrix[3,2] := Q.matrix[1,3]*Q.matrix[2,1] - Q.matrix[1,1]*Q.matrix[2,3] ; //* product */ + Q.matrix[3,3] := Q.matrix[1,1]*Q.matrix[2,2] - Q.matrix[1,2]*Q.matrix[2,1] ; + end; + //next - find closest orthogonal coordinates - each matrix cell must be 0,-1 or 1 + //First: find axis most aligned to a principal axis + lAbsmax := 0; + lMaxRow := 1; + lMaxCol := 1; + for lrow := 1 to 3 do begin + for lcol := 1 to 3 do begin + lAbs := abs(Q.matrix[lrow,lcol]); + if lAbs > lAbsMax then begin + lAbsmax := lAbs; + lMaxRow := lRow; + lMaxCol := lCol; + end; + end; //for rows + end; //for columns + //Second - find find axis that is 2nd closest to principal axis + lAbsmax := 0; + l2ndMaxRow := 2; + l2ndMaxCol := 2; + for lrow := 1 to 3 do begin + for lcol := 1 to 3 do begin + if (lrow <> lMaxRow) and (lCol <> lMaxCol) then begin + lAbs := abs(Q.matrix[lrow,lcol]); + if lAbs > lAbsMax then begin + lAbsmax := lAbs; + l2ndMaxRow := lRow; + l2ndMaxCol := lCol; + end; //new max + end; //do not check MaxRow/MaxCol + end; //for rows + end; //for columns + //next - no degrees of freedom left: third prinicple axis is the remaining axis + if ((lMaxRow = 1) or (l2ndMaxRow = 1)) and ((lMaxRow = 2) or (l2ndMaxRow = 2)) then + l3rdMaxRow := 3 + else if ((lMaxRow = 1) or (l2ndMaxRow = 1)) and ((lMaxRow = 3) or (l2ndMaxRow = 3)) then + l3rdMaxRow := 2 + else + l3rdMaxRow := 1; + if ((lMaxCol = 1) or (l2ndMaxCol = 1)) and ((lMaxCol = 2) or (l2ndMaxCol = 2)) then + l3rdMaxCol := 3 + else if ((lMaxCol = 1) or (l2ndMaxCol = 1)) and ((lMaxCol = 3) or (l2ndMaxCol = 3)) then + l3rdMaxCol := 2 + else + l3rdMaxCol := 1; + //finally, fill in our rotation matrix + //cells in the canonical rotation transform can only have values 0,1,-1 + result := Matrix3D( 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,1); + + if Q.matrix[lMaxRow,lMaxCol] < 0 then + result.matrix[lMaxRow,lMaxCol] := -1 + else + result.matrix[lMaxRow,lMaxCol] := 1; + + if Q.matrix[l2ndMaxRow,l2ndMaxCol] < 0 then + result.matrix[l2ndMaxRow,l2ndMaxCol] := -1 + else + result.matrix[l2ndMaxRow,l2ndMaxCol] := 1; + + if Q.matrix[l3rdMaxRow,l3rdMaxCol] < 0 then + result.matrix[l3rdMaxRow,l3rdMaxCol] := -1 + else + result.matrix[l3rdMaxRow,l3rdMaxCol] := 1; + if lPrefs.OrthoFlipXDim then begin + Flip := Matrix3D(-1,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,1); + Q := result; + result := multiplymatrices(Flip,Q); + end; +end; + + +FUNCTION QuickInvertMatrix3D (CONST Input:TMatrix): TMatrix; +//http://www.cellperformance.com/articles/2006/06/a_4x4_matrix_inverse_1.html +//Most of the time in the video games, programmers are not doing a standard inverse matrix. +//It is too expensive. Instead, to inverse a matrix, they consider it as orthonormal +//and they just do a 3x3 transpose of the rotation part with a dot product for the translation. +//Sometimes the full inverse algorithm is necessary.... +var + i,j: integer; +begin + result.size := Input.size; + for i := 1 to 3 do + for j := 1 to 3 do + result.matrix[i,j] := input.matrix[j,i]; + //next - fill in edge if 3D + if result.size <> size3D then + exit; //do not fill in final column for 2D matrices + for i := 1 to 3 do + result.matrix[4,i] := 0; + for i := 1 to 3 do + result.matrix[i,4] := 0; + result.matrix[4,4] := 1; +end; + +procedure FindMatrixPt (lX,lY,lZ: single; var lXout,lYOut,lZOut: single; var lMatrix: TMatrix); +begin + lXOut := (lX*lMatrix.matrix[1,1])+(lY*lMatrix.matrix[1,2])+(lZ*lMatrix.matrix[1,3])+lMatrix.matrix[1,4]; + lYOut := (lX*lMatrix.matrix[2,1])+(lY*lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[2,3])+lMatrix.matrix[2,4]; + lZOut := (lX*lMatrix.matrix[3,1])+(lY*lMatrix.matrix[3,2])+(lZ*lMatrix.matrix[3,3])+lMatrix.matrix[3,4]; +end; + +procedure CheckMin(var lX,lY,lZ,lXMin,lYMin,lZMin: single); +begin + if lX < lXMin then lXMin := lX; + if lY < lYMin then lYMin := lY; + if lZ < lZMin then lZMin := lZ; +end; + +procedure Mins (var lMatrix: TMatrix; var lHdr: TNIFTIhdr; var lXMin,lYMin,lZMin: single); +var + lPos,lXc,lYc,lZc: integer; + lx,ly,lz: single; +begin + FindMatrixPt(0,0,0,lX,lY,lZ,lMatrix); + lXMin := lX; + lYMin := lY; + lZMin := lZ; + for lPos := 1 to 7 do begin + if odd(lPos) then + lXc := lHdr.Dim[1]-1 + else + lXc := 0; + if odd(lPos shr 1) then + lYc := lHdr.Dim[2]-1 + else + lYc := 0; + if odd(lPos shr 2) then + lZc := lHdr.Dim[3]-1 + else + lZc := 0; + FindMatrixPt(lXc,lYc,lZc,lX,lY,lZ,lMatrix); + CheckMin(lX,lY,lZ,lXMin,lYMin,lZMin); + end; +end; + +function ReorientCore(var lHdrName: string; lPrefix: string; var lHdr: TNIFTIhdr; lPrefs: TPrefs; lOverwrite,lKeepOrigHdr: boolean; var lInMat,lRotMat: TMatrix): string; +var + lOutHdr: TNIFTIhdr; + lOutName: string; + lResidualMat: TMatrix; + lInMinX,lInMinY,lInMinZ,lOutMinX,lOutMinY,lOutMinZ, + dx, dy, dz, QFac: single; + lStartX,lStartY,lStartZ, + lZ,lY,lX,lB, + lOutZ,lOutY, + lVol,lNumVol,lXInc, lYInc, lZInc,lBPP: integer; + lInPos,lVolBytes,lOutPos,lInOffset: integer; + lBufferIn,lBufferOut,lIBuffer,lOBuffer: bytep; + lOpts: TNIIOpts; + lFlipX,lFlipY,lFlipZ: boolean; + lOutF,lInF: File; +begin + result := ''; + lOutHdr := lHdr; + //Some software uses negative pixdims to represent a spatial flip - now that the image is canonical, all dimensions are positive + lOutHdr.pixdim[1] := abs(lHdr.pixdim[1]); + lOutHdr.pixdim[2] := abs(lHdr.pixdim[2]); + lOutHdr.pixdim[3] := abs(lHdr.pixdim[3]); + //sort out dim1 + lFlipX := false; + if lRotMat.Matrix[1,2] <> 0 then begin + lXinc := lHdr.dim[1]; + lOutHdr.dim[1] := lHdr.dim[2]; + lOutHdr.pixdim[1] := abs(lHdr.pixdim[2]); + if lRotMat.Matrix[1,2] < 0 then lFlipX := true + end else if lRotMat.Matrix[1,3] <> 0 then begin + lXinc := lHdr.dim[1]*lHdr.dim[2]; + lOutHdr.dim[1] := lHdr.dim[3]; + lOutHdr.pixdim[1] := abs(lHdr.pixdim[3]); + if lRotMat.Matrix[1,3] < 0 then lFlipX := true + end else begin + lXinc := 1; + if lRotMat.Matrix[1,1] < 0 then lFlipX := true + end; + //sort out dim2 + lFlipY := false; + if lRotMat.Matrix[2,2] <> 0 then begin + lYinc := lHdr.dim[1]; + //lOutHdr.dim[2] := lHdr.dim[2]; + //lOutHdr.pixdim[2] := lHdr.pixdim[2]; + if lRotMat.Matrix[2,2] < 0 then lFlipY := true + end else if lRotMat.Matrix[2,3] <> 0 then begin + lYinc := lHdr.dim[1]*lHdr.dim[2]; + lOutHdr.dim[2] := lHdr.dim[3]; + lOutHdr.pixdim[2] := abs(lHdr.pixdim[3]); + if lRotMat.Matrix[2,3] < 0 then lFlipY := true + end else begin + lYinc := 1; + lOutHdr.dim[2] := lHdr.dim[1]; + lOutHdr.pixdim[2] := abs(lHdr.pixdim[1]); + if lRotMat.Matrix[2,1] < 0 then lFlipY := true + end; + //sort out dim3 + lFlipZ := false; + if lRotMat.Matrix[3,2] <> 0 then begin + lZinc := lHdr.dim[1]; + lOutHdr.dim[3] := lHdr.dim[2]; + lOutHdr.pixdim[3] := lHdr.pixdim[2]; + if lRotMat.Matrix[3,2] < 0 then lFlipZ := true; + end else if lRotMat.Matrix[3,3] <> 0 then begin + lZinc := lHdr.dim[1]*lHdr.dim[2]; + //lOutHdr.dim[3] := lHdr.dim[3]; + //lOutHdr.pixdim[3] := lHdr.pixdim[3]; + if lRotMat.Matrix[3,3] < 0 then lFlipZ := true; + end else begin + lZinc := 1; + lOutHdr.dim[3] := lHdr.dim[1]; + lOutHdr.pixdim[3] := lHdr.pixdim[1]; + if lRotMat.Matrix[3,1] < 0 then lFlipZ := true; + end; + //details for writing... + lBPP := (lHdr.bitpix div 8); //bytes per pixel + lXinc := lXinc * lBPP; + lYinc := lYinc * lBPP; + lZinc := lZinc * lBPP; + lVolBytes := lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3]*lBPP; + //now write header... + //create Matrix of residual orientation... + lResidualMat := QuickInvertMatrix3D(lRotMat); + //the next steps are inelegant - the translation values are computed by brute force + //at the moment, our lResidualMat looks like this + //lResidualMat = [ 0 -1 0 0; 0 0 1 0; 1 0 0 0; 0 0 0 1]; + //however, it should specify the dimensions in mm of the dimensions that are flipped + //However, note that whenever you reverse the direction of + //voxel coordinates, you need to include the appropriate offset + //in the 'a' matrix. That is: + //lResidualMat = [0 0 1 0; -1 0 0 Nx-1; 0 1 0 0; 0 0 0 1] + //where Nx is the number of voxels in the x direction. + //So, if you took Nx=256, then for your values before, you'd get: + //TransRot = [ 0 -1 0 255; 0 0 1 0; 1 0 0 0; 0 0 0 1]; + //Because we do not do this, we use the function mins to compute the translations... + //I have not implemented refined version yet - require sample volumes to check + //Ensure Nx is voxels not mm, etc.... + //start of kludge + lResidualMat := multiplymatrices(lInMat,lResidualMat); //source + lResidualMat.Matrix[1,4] := 0; + lResidualMat.Matrix[2,4] := 0; + lResidualMat.Matrix[3,4] := 0; + Mins (lInMat, lHdr,lInMinX,lInMinY,lInMinZ); + Mins (lResidualMat, lOutHdr,lOutMinX,lOutMinY,lOutMinZ); + lResidualMat.Matrix[1,4] := lInMinX-lOutMinX; + lResidualMat.Matrix[2,4] := lInMinY-lOutMinY; + lResidualMat.Matrix[3,4] := lInMinZ-lOutMinZ; + //End of kuldge + lOutHdr.srow_x[0] := lResidualMat.Matrix[1,1]; + lOutHdr.srow_x[1] := lResidualMat.Matrix[1,2]; + lOutHdr.srow_x[2] := lResidualMat.Matrix[1,3]; + lOutHdr.srow_y[0] := lResidualMat.Matrix[2,1]; + lOutHdr.srow_y[1] := lResidualMat.Matrix[2,2]; + lOutHdr.srow_y[2] := lResidualMat.Matrix[2,3]; + lOutHdr.srow_z[0] := lResidualMat.Matrix[3,1]; + lOutHdr.srow_z[1] := lResidualMat.Matrix[3,2]; + lOutHdr.srow_z[2] := lResidualMat.Matrix[3,3]; + lOutHdr.srow_x[3] := lResidualMat.Matrix[1,4]; + lOutHdr.srow_y[3] := lResidualMat.Matrix[2,4]; + lOutHdr.srow_z[3] := lResidualMat.Matrix[3,4]; + nifti_mat44_to_quatern( lResidualMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + dx, dy, dz,lOutHdr.pixdim[0] {QFac}); + //read input + if not NIFTIhdr_LoadImg (lHdrName, lHdr, lIBuffer, lInOffset,lOpts) then exit; + + lNumVol := lOutHdr.dim[4]; + if lNumVol < 1 then //hopefully this nevee happens + lNumVol := 1; + GetMem(lOBuffer,lNumVol*lVolBytes+kNIIImgOffset); + lBufferIn := (@liBuffer^[lInOffset+1]); + lOutPos := 0; + lBufferOut := (@loBuffer^[kNIIImgOffset+1+lOutPos]); + if lFlipX then + lXInc := -lXInc; + if lFlipY then + lYInc := -lYInc; + if lFlipZ then + lZInc := -lZInc; + for lVol := 1 to lNumVol do begin + //convert + if lFlipX then + lStartX := (lOutHdr.dim[1]-1)*-lXInc + else + lStartX := 0; + if lFlipY then + lStartX := lStartX + (lOutHdr.dim[2]-1)*-lYInc; + if lFlipZ then + lStartX := lStartX + (lOutHdr.dim[3]-1)*-lZInc; + lStartX := lStartX + ((lVol-1)*lVolBytes); + for lZ := 1 to lOutHdr.dim[3] do begin + lOutZ := lStartX + (lZ-1) * lZInc; + for lY := 1 to lOutHdr.dim[2] do begin + lOutY := ((lY-1) * lYInc) + lOutZ; + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lXInc) + lOutY + lB; + lBufferOut^[lOutPos] := lBufferIn^[lInPos]; + end; + end; + end; //for Y + end; //for Z + end;//For each volume + Freemem(lIBuffer); + if lOverwrite then + lOutName := lHdrName + else + lOutName := ChangeFilePrefix (lHdrName,lPrefix); + dcmMsg('Reorienting as '+lOutName); + if lKeepOrigHdr then + result := SaveNIfTICore (lOutName, lOBuffer, kNIIImgOffset+1, lHdr, lPrefs) + else + result := SaveNIfTICore (lOutName, lOBuffer, kNIIImgOffset+1, lOutHdr, lPrefs); + Freemem(lOBuffer); +end;//ReorientCore + +(*function ReorientCore(var lHdrName: string; lPrefix: string; var lHdr: TNIFTIhdr; lPrefs: TPrefs; lOverwrite: boolean; var lInMat,lRotMat: TMatrix): string; +var + lOutHdr: TNIFTIhdr; + lOutName: string; + lResidualMat: TMatrix; + lInMinX,lInMinY,lInMinZ,lOutMinX,lOutMinY,lOutMinZ, + dx, dy, dz, QFac: single; + lStartX,lStartY,lStartZ, + lZ,lY,lX,lB, + lOutZ,lOutY, + lXInc, lYInc, lZInc,lBPP: integer; + lInPos,lVolBytes,lOutPos,lInOffset: integer; + lBufferIn,lBufferOut,lIBuffer,lOBuffer: bytep; + lByteSwap,lFlipX,lFlipY,lFlipZ: boolean; + lOutF,lInF: File; +begin + result := ''; + lOutHdr := lHdr; + if lOutHdr.dim[4] > 1 then begin + showmessage('Reorient only designed for 3D images.'); + exit; + end; + //Some software uses negative pixdims to represent a spatial flip - now that the image is canonical, all dimensions are positive + lOutHdr.pixdim[1] := abs(lHdr.pixdim[1]); + lOutHdr.pixdim[2] := abs(lHdr.pixdim[2]); + lOutHdr.pixdim[3] := abs(lHdr.pixdim[3]); + //sort out dim1 + lFlipX := false; + if lRotMat.Matrix[1,2] <> 0 then begin + lXinc := lHdr.dim[1]; + lOutHdr.dim[1] := lHdr.dim[2]; + lOutHdr.pixdim[1] := abs(lHdr.pixdim[2]); + if lRotMat.Matrix[1,2] < 0 then lFlipX := true + end else if lRotMat.Matrix[1,3] <> 0 then begin + lXinc := lHdr.dim[1]*lHdr.dim[2]; + lOutHdr.dim[1] := lHdr.dim[3]; + lOutHdr.pixdim[1] := abs(lHdr.pixdim[3]); + if lRotMat.Matrix[1,3] < 0 then lFlipX := true + end else begin + lXinc := 1; + if lRotMat.Matrix[1,1] < 0 then lFlipX := true + end; + //sort out dim2 + lFlipY := false; + if lRotMat.Matrix[2,2] <> 0 then begin + lYinc := lHdr.dim[1]; + //lOutHdr.dim[2] := lHdr.dim[2]; + //lOutHdr.pixdim[2] := lHdr.pixdim[2]; + if lRotMat.Matrix[2,2] < 0 then lFlipY := true + end else if lRotMat.Matrix[2,3] <> 0 then begin + lYinc := lHdr.dim[1]*lHdr.dim[2]; + lOutHdr.dim[2] := lHdr.dim[3]; + lOutHdr.pixdim[2] := abs(lHdr.pixdim[3]); + if lRotMat.Matrix[2,3] < 0 then lFlipY := true + end else begin + lYinc := 1; + lOutHdr.dim[2] := lHdr.dim[1]; + lOutHdr.pixdim[2] := abs(lHdr.pixdim[1]); + if lRotMat.Matrix[2,1] < 0 then lFlipY := true + end; + //sort out dim3 + lFlipZ := false; + if lRotMat.Matrix[3,2] <> 0 then begin + lZinc := lHdr.dim[1]; + lOutHdr.dim[3] := lHdr.dim[2]; + lOutHdr.pixdim[3] := lHdr.pixdim[2]; + if lRotMat.Matrix[3,2] < 0 then lFlipZ := true; + end else if lRotMat.Matrix[3,3] <> 0 then begin + lZinc := lHdr.dim[1]*lHdr.dim[2]; + //lOutHdr.dim[3] := lHdr.dim[3]; + //lOutHdr.pixdim[3] := lHdr.pixdim[3]; + if lRotMat.Matrix[3,3] < 0 then lFlipZ := true; + end else begin + lZinc := 1; + lOutHdr.dim[3] := lHdr.dim[1]; + lOutHdr.pixdim[3] := lHdr.pixdim[1]; + if lRotMat.Matrix[3,1] < 0 then lFlipZ := true; + end; + //details for writing... + lBPP := (lHdr.bitpix div 8); //bytes per pixel + lXinc := lXinc * lBPP; + lYinc := lYinc * lBPP; + lZinc := lZinc * lBPP; + lVolBytes := lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3]*lBPP; + //now write header... + //create Matrix of residual orientation... + lResidualMat := QuickInvertMatrix3D(lRotMat); + //the next steps are inelegant - the translation values are computed by brute force + //at the moment, our lResidualMat looks like this + //lResidualMat = [ 0 -1 0 0; 0 0 1 0; 1 0 0 0; 0 0 0 1]; + //however, it should specify the dimensions in mm of the dimensions that are flipped + //However, note that whenever you reverse the direction of + //voxel coordinates, you need to include the appropriate offset + //in the 'a' matrix. That is: + //lResidualMat = [0 0 1 0; -1 0 0 Nx-1; 0 1 0 0; 0 0 0 1] + //where Nx is the number of voxels in the x direction. + //So, if you took Nx=256, then for your values before, you'd get: + //TransRot = [ 0 -1 0 255; 0 0 1 0; 1 0 0 0; 0 0 0 1]; + //Because we do not do this, we use the function mins to compute the translations... + //I have not implemented refined version yet - require sample volumes to check + //Ensure Nx is voxels not mm, etc.... + //start of kludge + lResidualMat := multiplymatrices(lInMat,lResidualMat); //source + lResidualMat.Matrix[1,4] := 0; + lResidualMat.Matrix[2,4] := 0; + lResidualMat.Matrix[3,4] := 0; + Mins (lInMat, lHdr,lInMinX,lInMinY,lInMinZ); + Mins (lResidualMat, lOutHdr,lOutMinX,lOutMinY,lOutMinZ); + lResidualMat.Matrix[1,4] := lInMinX-lOutMinX; + lResidualMat.Matrix[2,4] := lInMinY-lOutMinY; + lResidualMat.Matrix[3,4] := lInMinZ-lOutMinZ; + //End of kuldge + lOutHdr.srow_x[0] := lResidualMat.Matrix[1,1]; + lOutHdr.srow_x[1] := lResidualMat.Matrix[1,2]; + lOutHdr.srow_x[2] := lResidualMat.Matrix[1,3]; + lOutHdr.srow_y[0] := lResidualMat.Matrix[2,1]; + lOutHdr.srow_y[1] := lResidualMat.Matrix[2,2]; + lOutHdr.srow_y[2] := lResidualMat.Matrix[2,3]; + lOutHdr.srow_z[0] := lResidualMat.Matrix[3,1]; + lOutHdr.srow_z[1] := lResidualMat.Matrix[3,2]; + lOutHdr.srow_z[2] := lResidualMat.Matrix[3,3]; + lOutHdr.srow_x[3] := lResidualMat.Matrix[1,4]; + lOutHdr.srow_y[3] := lResidualMat.Matrix[2,4]; + lOutHdr.srow_z[3] := lResidualMat.Matrix[3,4]; + + nifti_mat44_to_quatern( lResidualMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + dx, dy, dz, QFac); + //read input + if not NIFTIhdr_LoadImg (lHdrName, lHdr, lIBuffer, lInOffset,lByteSwap) then exit; + + GetMem(lOBuffer,lVolBytes+kNIIImgOffset); + lBufferIn := (@liBuffer^[lInOffset+1]); + lOutPos := 0; + lBufferOut := (@loBuffer^[kNIIImgOffset+1+lOutPos]); + //convert + if lFlipX then begin + lStartX := (lOutHdr.dim[1]-1)*lXInc; + lXInc := -lXInc; + end else + lStartX := 0; + if lFlipY then begin + lStartX := lStartX + (lOutHdr.dim[2]-1)*lYInc; + lYInc := -lYInc; + end; + if lFlipZ then begin + lStartX := lStartX + (lOutHdr.dim[3]-1)*lZInc; + lZInc := -lZInc; + end; + + for lZ := 1 to lOutHdr.dim[3] do begin + lOutZ := lStartX + (lZ-1) * lZInc; + for lY := 1 to lOutHdr.dim[2] do begin + lOutY := ((lY-1) * lYInc) + lOutZ; + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lXInc) + lOutY + lB; + lBufferOut^[lOutPos] := lBufferIn^[lInPos]; + end; + end; + end; //for Y + end; //for Z + Freemem(lIBuffer); + if lOverwrite then + lOutName := lHdrName + else + lOutName := ChangeFilePrefix (lHdrName,lPrefix); + Msg('Reorienting as '+lOutName); + result := SaveNIfTICore (lOutName, lOBuffer, kNIIImgOffset+1, lOutHdr, lPrefs,lByteSwap); + Freemem(lOBuffer); +end;//ReorientCore *) + +(*function SuperReorient(var lHdrName: string; {var lHdr: TNIFTIhdr;} lPrefs: TPrefs): string; +//super-reorient generates copies of the source image with different orthogonal rotations +//useful for testing viewing software +var + lRot,lRotMod: integer; + lByteSwap: boolean; + lInMat,lRotMat,lTempMat,lTransformMat,lNormalMat,lFlipMat: TMatrix; + lPrefix: string; + lHdr: TNIFTIhdr; +begin + if not NIFTIhdr_LoadHdr (lHdrName, lHdr, lByteSwap) then begin + Msg('Unable to read as NifTI/Analyze' + lHdrName); + exit; + end; + result := ''; + lInMat := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], + 0,0,0,1); + lNormalMat := nifti_mat44_orthogx(lInMat); + //lRot := 3; begin + for lRot := 1 to 24 do begin + lRotMod := lRot mod 6; + case lRotMod of + 1: lTempMat := Matrix3D(1,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,1); + 2: lTempMat := Matrix3D(1,0,0,0, 0,0,1,0, 0,1,0,0, 0,0,0,1); + 3: lTempMat := Matrix3D(0,1,0,0, 1,0,0,0, 0,0,1,0, 0,0,0,1); + 4: lTempMat := Matrix3D(0,1,0,0, 0,0,1,0, 1,0,0,0, 0,0,0,1); + 5: lTempMat := Matrix3D(0,0,1,0, 1,0,0,0, 0,1,0,0, 0,0,0,1); + else lTempMat := Matrix3D(0,0,1,0, 0,1,0,0, 1,0,0,0, 0,0,0,1); + end; + case lRot of + 1..6: lFlipMat := Eye3D; + 7..12: lFlipMat := Matrix3D(-1,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,1); + 13..18: lFlipMat := Matrix3D(1,0,0,0, 0,-1,0,0, 0,0,1,0, 0,0,0,1); + 19..24: lFlipMat := Matrix3D(1,0,0,0, 0,1,0,0, 0,0,-1,0, 0,0,0,1); + end; + lTransformMat := MultiplyMatrices(lTempMat,lFlipMat); + lRotMat := MultiplyMatrices(lNormalMat,lTransformMat); + lPrefix := floattostr(lTransformMat.Matrix[1,1])+floattostr(lTransformMat.Matrix[1,2])+floattostr(lTransformMat.Matrix[1,3]) + +'_'+floattostr(lTransformMat.Matrix[2,1])+floattostr(lTransformMat.Matrix[2,2])+floattostr(lTransformMat.Matrix[2,3]) + +'_'+floattostr(lTransformMat.Matrix[3,1])+floattostr(lTransformMat.Matrix[3,2])+floattostr(lTransformMat.Matrix[3,3]); + Msg(lPrefix); + result := ReorientCore(lHdrName, lPrefix,lHdr, lPrefs, false, lInMat,lRotMat); + end; +end;//proc SuperReorient +*) + +function Reorient(var lHdrName: string; var lHdr: TNIFTIhdr; lPrefs: TPrefs; lOverwrite,lForce: boolean): string; +//returns output filename if successful +//reslice an image so it is in canonical space +var + lInMat,lRotMat: TMatrix; +begin + result := ''; + if (lHdr.dim[4] > 1) or (lHdr.dim[3] < 2) then begin + dcmMsg('Can only orient 3D images '+inttostr(lHdr.dim[3])+' '+inttostr(lHdr.dim[4])); + exit; + end; + if (lHdr.dim[1] > lPrefs.MaxReorientMatrix) or (lHdr.dim[2] > lPrefs.MaxReorientMatrix) or(lHdr.dim[3] > lPrefs.MaxReorientMatrix) then begin + dcmMsg('This image will not be reoriented (larger than MaxReorientMatrix= '+inttostr(lPrefs.MaxReorientMatrix)); + exit; + end; + lInMat := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], + 0,0,0,1); + if (not lForce) and (NIfTIAlignedM (lInMat)) then begin + result := lHdrName; + dcmMsg('Image is already canonically oriented: '+lHdrName); + exit; + end; + lRotMat := nifti_mat44_orthogx( lInMat,lPrefs); + if NIfTIAlignedM (lRotMat) then begin + result := lHdrName; + dcmMsg('According to header, image is already approximately canonically oriented'); + exit; //already as close as possible + end; + result := ReorientCore(lHdrName, 'o',lHdr, lPrefs, lOverwrite,false, lInMat,lRotMat); +end; + +function LRFlip(lFilename: string; lPrefs: TPrefs): boolean; +//function Reorient(var lHdrName: string; var lHdr: TNIFTIhdr; lPrefs: TPrefs; lOverwrite,lForce: boolean): string; +//returns output filename if successful +//reslice an image so it is in canonical space +var + lHdr: TNIFTIhdr; + lO: TNIIOPts; + lInMat,lRotMat: TMatrix; +begin + result := false; + if not NIFTIhdr_LoadHdr (lFilename, lHdr, lO) then begin + dcmMsg('Unable to read as NifTI/Analyze' + lFilename); + exit; + end; + if (lHdr.dim[1] > lPrefs.MaxReorientMatrix) or (lHdr.dim[2] > lPrefs.MaxReorientMatrix) or(lHdr.dim[3] > lPrefs.MaxReorientMatrix) then begin + dcmMsg('This image will not be reoriented (larger than MaxReorientMatrix= '+inttostr(lPrefs.MaxReorientMatrix)); + exit; + end; + lInMat := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], + 0,0,0,1); + + lRotMat := Matrix3D( + -1,0,0,0, + 0,1,0,0, + 0,0,1,0, + 0,0,0,1); + result := (ReorientCore(lFilename, 'lr',lHdr, lPrefs, false,true, lInMat,lRotMat)<> ''); +end; + + +end. + \ No newline at end of file diff --git a/dcm2nii/nii_orient.ppu b/dcm2nii/nii_orient.ppu new file mode 100644 index 0000000..ecb7dae Binary files /dev/null and b/dcm2nii/nii_orient.ppu differ diff --git a/dcm2nii/nii_reslice.o b/dcm2nii/nii_reslice.o new file mode 100644 index 0000000..19c0bb9 Binary files /dev/null and b/dcm2nii/nii_reslice.o differ diff --git a/dcm2nii/nii_reslice.pas b/dcm2nii/nii_reslice.pas new file mode 100755 index 0000000..ea8b366 --- /dev/null +++ b/dcm2nii/nii_reslice.pas @@ -0,0 +1,448 @@ +unit nii_reslice; +interface +{$H+} +uses + niftiutil,define_types,sysutils,dicomtypes,prefs,dialogs_msg, nifti_types; + +//function ResliceImgNIfTI (lTargetImgName,lSrcImgName,lOutputName: string): boolean; +function Reslice2Targ (lSrcName,lTargetName,lDestName: string; lPrefs: TPrefs):string; + +implementation + +uses GraphicsMathLibrary, dialogsx; + + +function Hdr2Mat (lHdr: TNIFTIhdr): TMatrix; +begin + Result := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], // 3D "graphics" matrix + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], // 3D "graphics" matrix + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); +end; + + +(*procedure ReportMatrix (lM:TMatrix); +const + kCR = chr (13); +begin + showmessage(RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+kCR+ + RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+kCR+ + RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+kCR + +RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6) + ); +end; *) + +(* +procedure SPMmat(var lDestMat: TMatrix); +//SPM matrices are indexed from 1 +//This function is only useful for direct comparisons with SPM +var + lTemp,lVS: TMatrix; +begin + lVS := Matrix3D (1,0,0,-1, + 0,1,0,-1, + 0,0,1,-1, 0,0,0,1);//VoxelShift + lTemp := lDestMat; + lDestMat := MultiplyMatrices(lTemp,lVS); +end;*) + +procedure Coord(var lV: TVector; var lMat: TMatrix); +//transform X Y Z by matrix +var + lXi,lYi,lZi: single; +begin + lXi := lV.x; lYi := lV.y; lZi := lV.z; + lV.x := (lXi*lMat.matrix[1][1]+lYi*lMat.matrix[1][2]+lZi*lMat.matrix[1][3]+lMat.matrix[1][4]); + lV.y := (lXi*lMat.matrix[2][1]+lYi*lMat.matrix[2][2]+lZi*lMat.matrix[2][3]+lMat.matrix[2][4]); + lV.z := (lXi*lMat.matrix[3][1]+lYi*lMat.matrix[3][2]+lZi*lMat.matrix[3][3]+lMat.matrix[3][4]); + +end; + +procedure Transposemat(var lMat: TMatrix); +var + lTemp: TMatrix; + i,j: integer; +begin + lTemp := lMat; + for i := 1 to lMat.size do + for j := 1 to lMat.size do + lMat.matrix[i,j] := lTemp.matrix[j,i]; +end; + +PROCEDURE gaussj(VAR a: TMatrix);//Invert a Matrix - see Numerical Recipes +VAR + big,dum,pivinv: real; + n,i,icol,irow,j,k,l,ll: integer; + indxc,indxr,ipiv: array [1..4] of integer; +BEGIN + icol := 1;//not used - avoids compiler warning + irow := 1;//not used - avoids compiler warning + n := a.size; + FOR j := 1 TO n DO BEGIN + ipiv[j] := 0 + END; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO BEGIN + IF (ipiv[j] <> 1) THEN BEGIN + FOR k := 1 TO n DO BEGIN + IF (ipiv[k] = 0) THEN BEGIN + IF (abs(a.matrix[j,k]) >= big) THEN BEGIN + big := abs(a.matrix[j,k]); + irow := j; + icol := k + END + END ELSE IF (ipiv[k] > 1) THEN BEGIN + writeln('pause 1 in GAUSSJ - singular matrix'); readln + END + END + END + END; + ipiv[icol] := ipiv[icol]+1; + IF (irow <> icol) THEN BEGIN + FOR l := 1 TO n DO BEGIN + dum := a.matrix[irow,l]; + a.matrix[irow,l] := a.matrix[icol,l]; + a.matrix[icol,l] := dum + END; + END; + indxr[i] := irow; + indxc[i] := icol; + IF (a.matrix[icol,icol] = 0.0) THEN BEGIN + dcmMsg('pause 2 in GAUSSJ - singular matrix'); + exit; + END; + pivinv := 1.0/a.matrix[icol,icol]; + a.matrix[icol,icol] := 1.0; + FOR l := 1 TO n DO BEGIN + a.matrix[icol,l] := a.matrix[icol,l]*pivinv + END; + FOR ll := 1 TO n DO BEGIN + IF (ll <> icol) THEN BEGIN + dum := a.matrix[ll,icol]; + a.matrix[ll,icol] := 0.0; + FOR l := 1 TO n DO BEGIN + a.matrix[ll,l] := a.matrix[ll,l]-a.matrix[icol,l]*dum + END; + END + END + END; + FOR l := n DOWNTO 1 DO BEGIN + IF (indxr[l] <> indxc[l]) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a.matrix[k,indxr[l]]; + a.matrix[k,indxr[l]] := a.matrix[k,indxc[l]]; + a.matrix[k,indxc[l]] := dum + END + END + END +END; + +procedure SubVec (var lVx: TVector; lV0: TVector); +begin + lVx.x := lVx.x - lV0.x; + lVx.y := lVx.y - lV0.y; + lVx.z := lVx.z - lV0.z; +end; + +function Voxel2Voxel (var lDestHdr,lSrcHdr: TNIFTIhdr): TMatrix; +//returns matrix for transforming voxels from one image to the other image +//results are in VOXELS not mm +var + lV0,lVx,lVy,lVz: TVector; + lDestMat,lSrcMatInv,lSrcMat: TMatrix; + +begin + //Step 1 - compute source coordinates in mm for 4 voxels + //the first vector is at 0,0,0, with the + //subsequent voxels being left, up or anterior + lDestMat := Hdr2Mat(lDestHdr); + //SPMmat(lDestMat); + lV0 := Vector3D (0,0,0); + lVx := Vector3D (1,0,0); + lVy := Vector3D (0,1,0); + lVz := Vector3D (0,0,1); + Coord(lV0,lDestMat); + Coord(lVx,lDestMat); + Coord(lVy,lDestMat); + Coord(lVz,lDestMat); + lSrcMat := Hdr2Mat(lSrcHdr); + //SPMmat(lSrcMat); + lSrcMatInv := lSrcMat; + gaussj(lSrcMatInv); + //the vectors should be rows not columns.... + //therefore we transpose the matrix + Transposemat(lSrcMatInv); + //the 'transform' multiplies the vector by the matrix + lV0 := Transform (lV0,lSrcMatInv); + lVx := Transform (lVx,lSrcMatInv); + lVy := Transform (lVy,lSrcMatInv); + lVz := Transform (lVz,lSrcMatInv); + //subtract each vector from the origin + // this reveals the voxel-space influence for each dimension + SubVec(lVx,lV0); + SubVec(lVy,lV0); + SubVec(lVz,lV0); + result := Matrix3D(lVx.x,lVy.x,lVz.x,lV0.x, + lVx.y,lVy.y,lVz.y,lV0.y, + lVx.z,lVy.z,lVz.z,lV0.z, 0,0,0,1); +end; + +procedure CopyHdrMat(var lTarg,lDest: TNIfTIHdr); +//destination has dimensions and rotations of destination +var + lI: integer; +begin + //destination will have dimensions of target + lDest.dim[0] := 3; //3D + for lI := 1 to 3 do + lDest.dim[lI] := lTarg.dim[lI]; + lDest.dim[4] := 1; //3D + //destination will have pixdim of target + for lI := 0 to 7 do + lDest.pixdim[lI] := lTarg.pixdim[lI]; + lDest.xyzt_units := lTarg.xyzt_units; //e.g. mm and sec + lDest.qform_code := lTarg.qform_code; + lDest.sform_code := lTarg.sform_code; + lDest.quatern_b := lTarg.quatern_b; + lDest.quatern_c := lTarg.quatern_c; + lDest.quatern_d := lTarg.quatern_d; + lDest.qoffset_x := lTarg.qoffset_x; + lDest.qoffset_y := lTarg.qoffset_y; + lDest.qoffset_z := lTarg.qoffset_z; + for lI := 0 to 3 do begin + lDest.srow_x[lI] := lTarg.srow_x[lI]; + lDest.srow_y[lI] := lTarg.srow_y[lI]; + lDest.srow_z[lI] := lTarg.srow_z[lI]; + end; +end; + +function Reslice2Targ (lSrcName,lTargetName,lDestName: string; lPrefs: TPrefs):string; +var + lPos,lXYs,lXYZs,lXs,lYs,lZs,lXi,lYi,lZi,lX,lY,lZ, + lXo,lYo,lZo,lMinY,lMinZ,lMaxY,lMaxZ,lSrcOffset,lBPP,lXYZ: integer; + lXrM1,lYrM1,lZrM1,lXreal,lYreal,lZreal, + lZx,lZy,lZz,lYx,lYy,lYz, + lInMinX,lInMinY,lInMinZ, lOutMinX,lOutMinY,lOutMinZ: single; + lXx,lXy,lXz: Singlep0; + l32fs,l32f : SingleP; + l32is,l32i : LongIntP; + l16is,l16i : SmallIntP; + l8i,l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned: bytep; + lMat: TMatrix; + lTargHdr,lSrcHdr,lDestHdr: TNIFTIhdr; + lS,lT: TNIIOpts; +begin + result := ''; + if not NIFTIhdr_LoadHdr (lSrcname, lSrcHdr, lS) then exit; + if not NIFTIhdr_LoadHdr (lTargetName, lTargHdr, lT) then exit; + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR : lBPP := 1; + kDT_SIGNED_SHORT: lBPP := 2; + kDT_SIGNED_INT:lBPP := 4; + kDT_FLOAT: lBPP := 4; + else begin + dcmMsg('NII reslice error: datatype not supported.'); + exit; + end; + end; //case + lMat := Voxel2Voxel (lTargHdr,lSrcHdr); + lDestHdr := lSrcHdr; //destination has the comments and voxel BPP of source + CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + lXs := lSrcHdr.Dim[1]; + lYs := lSrcHdr.Dim[2]; + lZs := lSrcHdr.Dim[3]; + + lXYs:=lXs*lYs; //slicesz + lXYZs := lXYs*lZs; + lX := lDestHdr.Dim[1]; + lY := lDestHdr.Dim[2]; + lZ := lDestHdr.Dim[3]; + lDestHdr.Dim[4] := 1; + //load dataset + if not NIFTIhdr_LoadImg (lSrcName, lSrcHdr, lSrcBuffer, lSrcOffset,lS) then exit; + l8is := (@lSrcBuffer^[lSrcOffset+1]); + GetMem(lBuffUnaligned ,(lBPP*lX*lY*lZ) + 16+kNIIImgOffset); + {$IFDEF FPC} + lBuffAligned := Align(lBuffUnaligned,16); // not commented - check this + {$ELSE} + lBuffAligned := ByteP($fffffff0 and (integer(lBuffUnaligned)+15)); + {$ENDIF} + lPos := 1; + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR : l8i := @lBuffAligned^[kNIIImgOffset+lPos]; + kDT_SIGNED_SHORT: l16i := SmallIntP(@lBuffAligned^[kNIIImgOffset+lPos] ); + kDT_SIGNED_INT:l32i := LongIntP(@lBuffAligned^[kNIIImgOffset+lPos] ); + kDT_FLOAT: l32f := SingleP(@lBuffAligned^[kNIIImgOffset+lPos] ); + end; //case + case lSrcHdr.datatype of + //kDT_UNSIGNED_CHAR : l8is := l8is; + kDT_SIGNED_SHORT: l16is := SmallIntP(l8is ); + kDT_SIGNED_INT:l32is := LongIntP(l8is ); + kDT_FLOAT: l32fs := SingleP(l8is ); + end; //case + //next clear image + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR : for lPos := 1 to (lX*lY*lZ) do l8i^[lPos] := 0; + kDT_SIGNED_SHORT: for lPos := 1 to (lX*lY*lZ) do l16i^[lPos] := 0; + kDT_SIGNED_INT:for lPos := 1 to (lX*lY*lZ) do l32i^[lPos] := 0; + kDT_FLOAT: for lPos := 1 to (lX*lY*lZ) do l32f^[lPos] := 0; + end; //case + //now we can apply the transforms... + //build lookup table - speed up inner loop + getmem(lXx, lX*sizeof(single)); + getmem(lXy, lX*sizeof(single)); + getmem(lXz, lX*sizeof(single)); + for lXi := 0 to (lX-1) do begin + lXx^[lXi] := lXi*lMat.matrix[1][1]; + lXy^[lXi] := lXi*lMat.matrix[2][1]; + lXz^[lXi] := lXi*lMat.matrix[3][1]; + end; + //compute trilinear interpolation + lPos := 0; + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + + lXreal := (lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYreal := (lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZreal := (lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXreal >= 0) and (lYreal >= 0{1}) and (lZreal >= 0{1}) and + (lXreal < (lXs -1)) and (lYreal < (lYs -1) ) and (lZreal < (lZs -1)) + then begin + //compute the contribution for each of the 8 source voxels + //nearest to the target + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := lYo*lXs; + lMinZ := lZo*lXYs; + lMaxY := lMinY+lXs; + lMaxZ := lMinZ+lXYs; + inc(lXo);//images incremented from 1 not 0 + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR : begin// l8is := l8is; + l8i^[lPos] := + round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*l8is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l8is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l8is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l8is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l8is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l8is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l8is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l8is^[lXo+1+lMaxY+lMaxZ]) ); + end; + kDT_SIGNED_SHORT: begin + l16i^[lPos] := + round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*l16is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l16is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l16is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l16is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l16is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l16is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l16is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l16is^[lXo+1+lMaxY+lMaxZ]) ); + end; + kDT_SIGNED_INT:begin + l32i^[lPos] := + round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*l32is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l32is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l32is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l32is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l32is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l32is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l32is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l32is^[lXo+1+lMaxY+lMaxZ]) ); + end; + kDT_FLOAT: begin //note - we do not round results - all intensities might be frational... + l32f^[lPos] := + ( + {all min} ( (lXrM1*lYrM1*lZrM1)*l32fs^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l32fs^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l32fs^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l32fs^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l32fs^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l32fs^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l32fs^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l32fs^[lXo+1+lMaxY+lMaxZ]) ); + end; + end; //case + + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z + //release lookup tables + freemem(lXx); + freemem(lXy); + freemem(lXz); + //check to see if image is empty... + lPos := 1; + case lSrcHdr.datatype of + kDT_UNSIGNED_CHAR : while (lPos <= (lX*lY*lZ)) and (l8i^[lPos] = 0) do inc(lPos); + kDT_SIGNED_SHORT: while (lPos <= (lX*lY*lZ)) and (l16i^[lPos] = 0) do inc(lPos); + kDT_SIGNED_INT:while (lPos <= (lX*lY*lZ)) and (l32i^[lPos] = 0) do inc(lPos); + kDT_FLOAT: while (lPos <= (lX*lY*lZ)) and (l32f^[lPos] = 0) do inc(lPos); + end; //case + if lPos <= (lX*lY*lZ) then begin //image not empty + result := SaveNIfTICore (lDestName, lBuffAligned, kNIIImgOffset+1, lDestHdr, lPrefs); + end else begin + dcmMsg('no voxels in output'); + end; + Freemem(lBuffUnaligned); + Freemem(lSrcBuffer); +end; + +(*function ResliceImgNIfTI (lTargetImgName,lSrcImgName,lOutputName: string): boolean; +label + 666; +var + lReslice : boolean; + lDestHdr,lSrcHdr: TMRIcroHdr; + lSrcMat,lDestMat,lSrcMatINv,lDestMatInv,lMat: TMatrix; + lOffX,lOffY,lOffZ: single; + D: double; +begin + result := false; + if not fileexists(lTargetImgName) then exit; + if not fileexists(lSrcImgName) then exit; + ImgForm.CloseImagesClick(nil); + lReslice := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + //if not HdrForm.OpenAndDisplayHdr(lTargetImgName,lDestHdr) then goto 666; + if not NIFTIhdr_LoadHdr(lTargetImgName, lDestHdr) then goto 666; + if not NIFTIhdr_LoadHdr(lSrcImgName, lSrcHdr) then goto 666; + if not ImgForm.OpenAndDisplayImg(lSrcImgName,false) then exit; + if not Qx(lDestHdr,lSrcHdr,lOutputName) then goto 666; + + result := true; +666: + if not result then + showmessage('Error applying transform '+lSrcImgName+'->'+lTargetImgName); + gBGImg.ResliceOnLoad := lReslice; +end; *) + +end. \ No newline at end of file diff --git a/dcm2nii/nii_reslice.ppu b/dcm2nii/nii_reslice.ppu new file mode 100644 index 0000000..7e63ace Binary files /dev/null and b/dcm2nii/nii_reslice.ppu differ diff --git a/dcm2nii/notes.txt b/dcm2nii/notes.txt new file mode 100755 index 0000000..18e8743 --- /dev/null +++ b/dcm2nii/notes.txt @@ -0,0 +1,180 @@ +Siemens DICOM always uses scanner coordinates to specify diffusion directions according to Michael Harms [mharms@conte.wustl.edu] + + +We to specify a custom set of directions using entries in a DiffusionVectors.txt file even for the VB13 and VB17 product ep2d_diff sequence, although I think this capability requires a separately purchased license. (What at one point was probably a WIP-only feature got built into the product sequence already by the time of VB13). + +Within that DiffusionVectors.txt file, one can specify whether the values are interpreted in a "xyz" or "prs" coordinate system. + +>From old WIP_ep2d_diff documentation I have the following: +------ +For the directive CoordinateSystem two different values are allowed: +• "xyz" specifies that this vector set is to be played out in the magnet coordinate system. +• "prs" makes the sequence to use the rotation matrix of the current slice, i.e. the phase-read-slice gradient axis system is used. +------ + +Everyone here at WU that uses custom directions always plays them out in the XYZ coordinate system. HOWEVER, the coordinate system used in playing out the gradients should be irrelevant if one is reading the directions out of the **DICOM**. That is, even if someone specified a custom gradient set to play out in the PRS coordinate system, the directions in the DICOM should still be STORED in the +LPS DICOM coordinate system, meaning that they would still need to be rotated for an oblique acquisition. + +If your Siemen's contact, or your VD11 Skyra user indicates otherwise, then I think I'll pull my hair out!! + + +Hi Chris, Jolinda, + +Ok, you guys are really not going to like me, but now that we seem to be reaching a consensus on the issue of rotation for VB13-VB17, I wanted to make sure you were aware of the issue of possibly incorrect bvecs under VB13, which is a completely orthogonal issue. + +First, I should note that the B_matrix entry in the CSA field of the DICOM is correct for VB13-VB17 (according to Siemens -- see below). +These B_matrix entries include the impact of the imaging gradients on the B matrix. + +Unfortunately, the algorithm that Siemen's used to convert the B_matrix entry into an "equivalent" principle eigendirection yields incorrect results in some instances for VB13. You may have noticed that the 2- norm of DiffusionGradientDirections (thenceforth DGD, as stored in the +DICOM) are not necessarily 1.000 for VB13 data. Both dcm2nii and MRIConvert return directions with a norm of exactly 1.0000, so both programs must be re-norming to exactly 1 behind the scenes as a final step prior to output. + +HOWEVER, norming the magnitude of the direction to 1 is NOT sufficient to recover from the error in Siemen's algorithm. For example, I have a case from a VB13 dataset (using a custom 30 direction set) where the norm for one of the DGD was only 0.16. For that case, I computed the first eigenvector of the B_matrix (using Matlab's 'princomp' function). +The resulting direction (which should be the "correct" one) differed from the DGD entry in the DICOM by 12.5 degrees, which indicates that simply re-norming the reported DGD values to 1.0 is indeed NOT SUFFICIENT to guarantee "correct" bvecs for VB13 data. + +This is a semi-known issue, and is presumably the reason that the DicomToNrrd and Nipy converters include options to re-derive the direction from the B_matrix. + +i.e., +http://mail.scipy.org/pipermail/nipy-devel/2010-September/004768.html + +and this snippet of email passed on to me by Darren Gitelman: + +------- +3) When I corresponded with Mark Scully and Hans Johnson who wrote the dicom2nrrd convertor they suggested that there are standard Siemens tags for the gradients and there are gradients that one obtains from the B matrix. They say the former is wrong. I had written to them that when DTIstudio extracted the gradients from the mosaic image it agreed with dicom2nrrd but only if I did not use the dicom2nrrd option "useBMatrixGradientDirections" which they told me to use. There response was as follows: + + As to DTIstudio agreeing with the output of DicomToNrrd when run + without useBMatrixGradientDirections, I assume DTIstudio is + reading the standard tags for direction? If that's the case, + it's getting the same wrong data as DicomToNrrd gets when it + doesn't use the BMatrix. The whole reason we made it possible + to use the BMatrix to calculate the gradients and B values is + because the standard tags were wrong in a subset of our Siemens + scans. + +-------- + +Unfortunately, I have no idea how frequently the DGD entries may be wrong under VB13, and whether or not custom gradient sets are more likely to be affected by the bug than "built-in" gradient sets. I'm actually going to email Mark and Hans next to see if they have a sense for that. + +Also, I should mention that I was told by Siemen's that the DGD for VB17 are correct, and for VB15 are "correct" up to polarity. Specifically, here is what Stefan Huwer of Siemen's emailed to me regarding this +issue: + +--------- +regarding software versions and issues with the diffusion gradient +direction: + +VB13: B_matrix field correct, diffusion_direction sometimes wrong. +VB15: B_matrix field correct, diffusion_direction correct (up to polarity). +VB17: B_matrix correct, diffusion_direction correct + +-------- + +So, why do I bring this all up? First, you (and others) should be aware of the issue, and perhaps I should make some additions to your Word document to explain the issue. That said, I'm not expecting that either MRIConvert or dcm2nii would be modified to include an option to derive the directions from the B_matrix, as that is a rather major software addition. However, it might be appropriate to include a warning message along the lines of the following for VB13 data: + +"Warning: bvecs are sometimes wrong for VB13 data, due to a bug in the algorithm by which Siemen's converted the B_matrix to a principle eigendirection. The frequency and extent of this problem is unknown at this time". + +And for VB15 data: +"Warning: Polarity of the bvecs may possibly be wrong for VB15 data." + +cheers, +-MH + +-- +Michael Harms, Ph.D. +-------------------------------------------------------------------- +Conte Center for the Neuroscience of Mental Disorders Washington University School of Medicine Department of Psychiatry, Box 8134 +Renard Hospital, Room 6604 Tel: 314-747-6173 +660 South Euclid Ave. Fax: 314-747-2182 +St. Louis, MO 63110 Email: mharms@wustl.edu +-------------------------------------------------------------------- + + +FYI: It sounds like Hans Johnson and Mark Scully (emails in header +below) have probably seen just about every "modern" vendor/software combination possible. So, they might be a resource if you wanted to understand GE and Philips better, although it sounds like they might not have much experience with the oblique acquisition issue. + +cheers, +-MH + +-------- Forwarded Message -------- +From: Johnson, Hans J <hans-johnson@uiowa.edu> +To: Michael Harms <mharms@conte.wustl.edu>, Scully, Mark S <mark- scully@uiowa.edu> +Cc: Joy Matsui <joy-matsui@uiowa.edu> +Subject: Re: DicomToNrrd specifics +Date: Thu, 31 Mar 2011 21:30:26 +0000 +Michael, + +We feel your pain. We are working on a 32 site study, and we see just about every kind of data possible. + +I'm getting this from memory, so take that into consideration. + +I believe that VB13 had 2 gradients incorrect (gradient 14,15 in our 30 direction scan). + +The "useBMatrixGradientDirections" does not take scan obliquenss into account, it simply recomputes the values that should have been in the public dicom tags in the first place. I am saying this without every having dealt with oblique DWI scans. + +==== +Just wait until you get to deal with phillips data :) It is really fun! + + +-- +Hans J. Johnson, Ph.D. +hans-johnson@uiowa.edu +Assistant Professor of Psychiatry +University of Iowa Carver College of Medicine +W278 GH, 200 Hawkins Drive + +Iowa City, Iowa 52242 +Phone: 319-353-8587 + + + + + + + +-----Original Message----- +From: Michael Harms <mharms@conte.wustl.edu> +Date: Thu, 31 Mar 2011 15:29:47 -0500 +To: Mark Scully <mark-scully@uiowa.edu>, Hans Johnson <hans-johnson@uiowa.edu> +Cc: <mharms@conte.wustl.edu> +Subject: DicomToNrrd specifics + + +Hello Mark and Hans, + +I've been conversing with Jolinda Smith (MRIConvert), Chris Rorden +(dcm2nii) and others (Darren Gittelman, Fred Tam) regarding some issues with getting bvecs from Siemens VB13, VB15, and VB17 DICOMs. + +Darren indicated to me that he had the following correspondence with you +previously: + +---------- +3) When I corresponded with Mark Scully and Hans Johnson who wrote the dicom2nrrd convertor they suggested that there are standard Siemens tags for the gradients and there are gradients that one obtains from the B matrix. They say the former is wrong. I had written to them that when DTIstudio extracted the gradients from the mosaic image it agreed with dicom2nrrd but only if I did not use the dicom2nrrd option "useBMatrixGradientDirections" which they told me to use. There response was as follows: + + As to DTIstudio agreeing with the output of DicomToNrrd when run + without useBMatrixGradientDirections, I assume DTIstudio is + reading the standard tags for direction? If that's the case, + it's getting the same wrong data as DicomToNrrd gets when it + doesn't use the BMatrix. The whole reason we made it possible + to use the BMatrix to calculate the gradients and B values is + because the standard tags were wrong in a subset of our Siemens + scans. + +-------- + +It is my understanding, in emails with Stefan Huwer at Siemens, that the issue of possibly incorrect entries in the DiffusionGradientDirection +("DGD") entry in the CSA portion of the Siemen's DICOM, is only for VB13 (although the polarity of the DGD's can be off by 180 degrees for VB15 data). Is that your understanding and experience as well? + +Do you have any empirical sense of the frequency and extent of this problem under VB13? e.g., What percentage of directions are affected on average? And are certain directions consistently affected across different sessions? + +Also, on a different different issue, does DicomToNrrd rotate the DGD entries (or alternatively the B_matrix if using the "useBMatrixGradientDirections" option) for oblique acquisitions for VB13-VB17? + +[I know this latter issue would be easy enough to test, but I've already spent a ton of time on this annoying issue, so I hope you don't mind me just asking you directly, so that I don't have to learn another dicom converter. I'm trying to see if I can't get agreement among various converter developers regarding the necessity of rotating the DGD entries (or B_matrix) for oblique VB13-VB17 acquisitions -- just today I brought Jolinda and Chris around to this position, so I wanted to see what your understanding was of the Siemens/ oblique acquisition/ bvec rotation issue]. + +Thanks! +-MH + +-- +Michael Harms, Ph.D. +-------------------------------------------------------------------- +Conte Center for the Neuroscience of Mental Disorders Washington University School of Medicine Department of Psychiatry, Box 8134 +Renard Hospital, Room 6604 Tel: 314-747-6173 +660 South Euclid Ave. Fax: 314-747-2182 +St. Louis, MO 63110 Email: mharms@wustl.edu +-------------------------------------------------------------------- diff --git a/dcm2nii/paramstrs.o b/dcm2nii/paramstrs.o new file mode 100644 index 0000000..59bb6dc Binary files /dev/null and b/dcm2nii/paramstrs.o differ diff --git a/dcm2nii/paramstrs.pas b/dcm2nii/paramstrs.pas new file mode 100755 index 0000000..517e239 --- /dev/null +++ b/dcm2nii/paramstrs.pas @@ -0,0 +1,398 @@ +unit paramstrs; + {$H+} +interface +uses prefs,define_types,dialogs_msg; +const +kVers = 'Chris Rorden''s dcm2nii :: '+kMRIcronvers; +{$Include ..\common\isgui.inc} +procedure ProcessParamStrs; +// procedure Testdcm2nii; +procedure RecursiveFolderSearch (lFolderName,lOutDir: string; var lPrefs: TPrefs; lDepth: integer); +implementation + +uses +{$IFDEF GUI}gui, {$ELSE} nii_4dto3d,{$ENDIF} + +{$IFNDEF UNIX} + Windows,{$ENDIF} Classes, + SysUtils,sortdicom,dicom,parconvert,filename,dicomtypes,userdir; + +(*procedure RecursiveFolderSearch (lFolderName,lOutDir: string; var lPrefs: TPrefs; lDepth: integer); +var + lNewDir,lNewName,lFilename,lExt: String; + lSearchRec: TSearchRec; +begin + if (lPrefs.CollapseFolders) then begin //Convert all folders in single step... + LoadFileList(lFolderName,lOutDir,lPrefs); + exit; + end; + lNewDir := lFolderName+PathDelim; +{$IFDEF UNIX} + if FindFirst(lNewDir+'*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + lFilename := ''; + repeat + lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then begin + if DirExists(lNewName) then begin + if lDepth < lPrefs.RecursiveFolderDepth then begin + if (lDepth = 0) and (lPrefs.RecursiveUseNameAppend) then begin + lPrefs.NameAppend := extractfilename(lNewName)+'_'; + Msg('recursive base folder '+lPrefs.NameAppend); + end; + RecursiveFolderSearch(lNewName,lOutDir,lPrefs,lDepth+1); + end; + //exit;//4/4/2008 + end else + lFilename := lNewname; + end; + until (FindNext(lSearchRec) <> 0); + if lFilename <> '' then begin + lExt := UpCaseExt(lFilename); + if (lExt = '.REC') or (lExt = '.PAR') then + LoadFileListPARREC(lFilename,lOutDir,lPrefs) + else begin + Msg('recursive conversion '+lFilename); + LoadFileList(lFilename,lOutDir,lPrefs); + end; + end; + end; + FindClose(lSearchRec); +end; *) + +function IsDicom (lFilename: string): boolean; +var + lDICOMdata: DICOMData; + lDynStr: string; + lHdrOK,lImgOK: boolean; + lPrefs: TPrefs; + lDTIra: TDTIRA; +begin + result := false; + read_dicom_data(true,false{not verbose},true,true,true,true,false, lDICOMdata, lDTIra, lHdrOK, lImgOK, lDynStr,lFileName,lPrefs ); + if (lHdrOK) and (lImgOK) then + result := true; +end; + +procedure RecursiveFolderSearch (lFolderName,lOutDir: string; var lPrefs: TPrefs; lDepth: integer); +var + lNewDir,lFilename,lExt: String; + lDirStrings: TStringList; + lSearchRec: TSearchRec; + lI: integer; +begin + if (lPrefs.CollapseFolders) then begin //Convert all folders in single step... + LoadFileList(lFolderName,lOutDir,lPrefs); + exit; + end; + lNewDir := lFolderName+PathDelim; + //first check for deeper folders... + {$IFDEF DEBUG}Msg('---Recursively searching '+lfoldername+' depth = '+inttostr(lDepth)); {$ENDIF} + if lDepth < lPrefs.RecursiveFolderDepth then begin + lDirStrings := TStringList.Create; + {$IFDEF UNIX} + if FindFirst(lNewDir+'*',faDirectory,lSearchRec) = 0 then begin + {$ELSE} + if FindFirst(lNewDir+'*.*',faDirectory,lSearchRec) = 0 then begin + {$ENDIF} + lFilename := ''; + repeat + if (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then begin + lFileName := lNewDir+lSearchRec.Name; + if DirExists(lFileName) then begin + (*if (lDepth = 0) and (lPrefs.RecursiveUseNameAppend) then begin + lPrefs.NameAppend := extractfilename(lSearchRec.Name)+'_'; + Msg('recursive base folder '+lPrefs.NameAppend); + end; *) + lDirStrings.Add(lNewDir+lSearchRec.Name); + end; + end; + until (FindNext(lSearchRec) <> 0); + end; //findfirst + FindClose(lSearchRec); + lDirStrings.Sort; + if lDirStrings.Count > 0 then + for lI := 0 to (lDirStrings.Count-1) do begin + if (lDepth = 0) and (lPrefs.RecursiveUseNameAppend) then begin + lPrefs.NameAppend := extractfilename(lDirStrings[lI])+'_'; + dcmMsg('recursive base folder '+lPrefs.NameAppend); + end; + RecursiveFolderSearch(lDirStrings[lI],lOutDir,lPrefs,lDepth+1); + end; + lDirStrings.free; + end; //lDepth < lPrefs.RecursiveFolderDepth + //next check for files in current folder... + {$IFDEF UNIX} + if FindFirst(lNewDir+'*',faAnyFile-faSysFile-faHidden,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile-faHidden,lSearchRec) = 0 then begin +{$ENDIF} + repeat + lFileName := lNewDir+lSearchRec.Name; + lExt := UpCaseExt(lFilename); + if (lFilename <> '') and (FileExists(lFileName)) and (not DirExists(lFileName)) and (not IsNiftiExt(lExt)) then begin + if (lExt = '.REC') or (lExt = '.PAR') then + LoadFileListPARREC(lFilename,lOutDir,lPrefs) + else if IsDicom (lFilename) then begin + dcmMsg('Looking for DICOM files in folder with '+lFilename); + LoadFileList(lFilename,lOutDir,lPrefs); + end else + lFilename := ''; + end else + lFilename :=''; + until (FindNext(lSearchRec) <> 0) or (lFilename <> ''); + end; //findfirst + FindClose(lSearchRec); +end; //RecursiveFolderSearch + +function Bool2YN (lBool: boolean): char; +begin + if lBool then + result := 'Y' + else + result := 'N'; +end; + +procedure CharBool (lCh: char; var lBool: boolean); +begin + if lCh = 'Y' then + lBool := true; + if lCh = 'N' then + lBool := false; +end; + +procedure ShowHelp (var lIniName: string; lPrefs: TPrefs); +begin + dcmMsg('Either drag and drop or specify command line options:'); + dcmMsg(' '+FilenameWOExt(paramstr(0))+' <options> <sourcenames>'); + dcmMsg('OPTIONS:'); + dcmMsg('-4 Create 4D volumes, else DTI/fMRI saved as many 3D volumes: Y,N = '+Bool2YN(lPrefs.FourD)); + dcmMsg('-3 : Y,N = '+Bool2YN(lPrefs.PlanarRGB)); + dcmMsg('-a Anonymize [remove identifying information]: Y,N = '+Bool2YN(lPrefs.Anonymize)); + dcmMsg('-b Load settings from specified inifile, e.g. ''-b C:\set\t1.ini'' '); + dcmMsg('-c Collapse input folders: Y,N = '+Bool2YN(lPrefs.CollapseFolders)); + dcmMsg('-d Date in filename [filename.dcm -> 20061230122032.nii]: Y,N = '+Bool2YN(lPrefs.AppendDate)); + dcmMsg('-e Events (series/acq) in filename [filename.dcm -> s002a003.nii]: Y,N = '+Bool2YN(lPrefs.AppendAcqSeries)); + dcmMsg('-f Source filename [e.g. filename.par -> filename.nii]: Y,N = '+Bool2YN(lPrefs.AppendFilename)); + dcmMsg('-g Gzip output, filename.nii.gz [ignored if ''-n n'']: Y,N = '+Bool2YN(lPrefs.Gzip)); + dcmMsg('-i ID in filename [filename.dcm -> johndoe.nii]: Y,N = '+Bool2YN(lPrefs.AppendPatientName)); + dcmMsg('-k sKip initial n volumes in fMRI, e.g. ''-k 2'': = '+inttostr(lPrefs.BeginClip)); + dcmMsg('-l pLanar RGB (Y=old Analyze; N=new VTK NIfTI): Y,N = '+Bool2YN(lPrefs.PlanarRGB)); + dcmMsg('-m Manually prompt user to specify output format [NIfTI input only]: Y,N = '+Bool2YN(lPrefs.ManualNIfTIConv)); + dcmMsg('-n Output .nii file [if no, create .hdr/.img pair]: Y,N = '+Bool2YN(lPrefs.SingleNIIFile)); + dcmMsg('-o Output Directory, e.g. ''C:\TEMP'' (if unspecified, source directory is used)'); + dcmMsg('-p Protocol in filename [filename.dcm -> TFE_T1.nii]: Y,N = '+Bool2YN(lPrefs.AppendProtocolName)); + dcmMsg('-r Reorient image to nearest orthogonal: Y,N '); + dcmMsg('-s SPM2/Analyze not SPM5/NIfTI [ignored if ''-n y'']: Y,N = '+Bool2YN(lPrefs.SPM2)); + dcmMsg('-t Text report (patient and scan details): Y,N = '+Bool2YN(lPrefs.txtReport)); + dcmMsg('-v Convert every image in the directory: Y,N = '+Bool2YN(lPrefs.EveryFile)); + dcmMsg('-x Reorient and crop 3D NIfTI images: Y,N = '+Bool2YN(lPrefs.Autocrop)); + dcmMsg(' You can also set defaults by editing '+lIniName); +{$IFDEF UNIX} + dcmMsg('EXAMPLE: '+FilenameWOExt(paramstr(0))+' -a y /Users/Joe/Documents/dcm/IM_0116'); +{$ELSE} + dcmMsg('EXAMPLE: '+FilenameWOExt(paramstr(0))+' -a y -o C:\TEMP C:\DICOM\input1.par C:\input2.par'); + dcmMsg('Hit <Enter> to exit.'); + + {$IFNDEF GUI}{$IFNDEF UNIX}if IsConsole then ReadLn;{$ENDIF}{$ENDIF} + +{$ENDIF} +end; //proc ShowHelp + + (*procedure Testdcm2nii; + var + lIniName : string; + lPrefs: TPrefs; + begin + lIniName := IniName;//DefaultsDir('')+ParseFileName(ExtractFilename(paramstr(0) ) )+'.ini'; + IniFile(True,lIniName, lPrefs); + + ModifyAnalyze('C:\4d\4d.nii', lPrefs) + end; *) + +function CustomIni: boolean; //returns true if user specifies a custom ini file +var + i: integer; + lStr: string; +begin + result := false; + + if (ParamCount < 1) then exit; + for i := 1 to ParamCount do begin + lStr := UpcaseStr(ParamStr(I)); + if (length(lStr)>1) and (lStr[1] = '-') and (lStr[2] = 'B') then + result := true; + end; +end; + + + +procedure ProcessParamStrs; +var + lDir,lStr,lOutDir,lExt: String; + {$IFNDEF UNIX}lStartTime: DWord;{$ENDIF} + lHelpShown,lAbort,lSilent: boolean; + lCommandChar: Char; + lPrefs: TPrefs; + P,I: integer; + lIniName : string; +begin + if (ParamCount > 0) then + ExitCode := 1;//assume error ... will be set to 0 on successful processing of any files... + SetDefaultPrefs (lPrefs); + {$IFDEF FPC} + DefaultFormatSettings.DecimalSeparator := '.'; + {$ELSE} + DecimalSeparator := '.'; + {$ENDIF} + lHelpShown := false; + lAbort := false; + lSilent := false; + if not CustomIni then begin //if the user specifies a custom ini file, do not load the default file.... + lIniName := IniName;//DefaultsDir('')+ParseFileName(ExtractFilename(paramstr(0) ) )+'.ini'; + if fileexists (lIniName) then + IniFile(True,lIniName, lPrefs) + else + IniFile(True,changefileext(paramstr(0),'.init'), lPrefs); //this allows an administrator to create default startup + end; + lOutDir := ''; + //dcm2nii will save nii as default, dcm2niiz will default to gzip, dcm2nii3d will make 3d files.. + lStr := UpcaseStr(FilenameWOExt(paramstr(0))); + I := length(lStr); + if I > 1 then begin + lCommandChar := lStr[I]; + if (lCommandChar = 'G') or (lCommandChar = 'R') then + lPrefs.SingleNIIFile := false + else if (lCommandChar = 'Z') then + lPrefs.Gzip := true; + for P := 1 to I do + if lStr[P] in ['0'..'9'] then + lCommandChar := lStr[P]; + if (lCommandChar = '3') then + lPrefs.FourD := false + end; + //now read filename + lStr := paramstr(0); + lStr := extractfilename(lStr); + lStr := string(StrUpper(PChar(lStr))) ; + if (ParamCount > 0) then begin + I := 0; + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') and (ParamCount > I) then begin //special command + lCommandChar := UpCase(lStr[2]); + inc(I); + lStr := ParamStr(I); + {$IFDEF UNIX} + if (lCommandChar <> 'O') and (lCommandChar <> 'B') then begin + lStr := string(StrUpper(PChar(lStr))) ; //do not upcase paths... + end; + {$ELSE} + lStr := string(StrUpper(PChar(lStr))) ; + {$ENDIF} + case lCommandChar of + '4': CharBool(lStr[1],lPrefs.FourD); + 'A': CharBool(lStr[1],lPrefs.Anonymize); + 'C': CharBool(lStr[1],lPrefs.CollapseFolders); + 'D': CharBool(lStr[1],lPrefs.AppendDate); + 'E': CharBool(lStr[1],lPrefs.AppendAcqSeries); + 'F': CharBool(lStr[1],lPrefs.AppendFilename); + 'G': CharBool(lStr[1],lPrefs.Gzip); + 'I': CharBool(lStr[1],lPrefs.AppendPatientName); + 'K': lPrefs.BeginClip:= strtoint(lStr); + 'L': CharBool(lStr[1],lPrefs.PlanarRGB); + 'M': CharBool(lStr[1],lPrefs.ManualNIfTIConv); + 'N': CharBool(lStr[1],lPrefs.SingleNIIFile); + 'P': CharBool(lStr[1],lPrefs.AppendProtocolName); + 'R': CharBool(lStr[1],lPrefs.enablereorient); + 'S': CharBool(lStr[1],lPrefs.SPM2); + 'T': CharBool(lStr[1],lPrefs.txtReport); + 'V': CharBool(lStr[1],lPrefs.EveryFile); + 'X': CharBool(lStr[1],lPrefs.Autocrop); + 'B': begin //load INI file + lIniName := lStr; + if fileexists(lIniName) then begin + IniFile(True,lIniName, lPrefs); + end else + dcmMsg('0 ERROR: unable to find '+lIniName); + end; + 'O': begin //output directory + lOutDir := ''; + if direxists(lStr) then begin + lOutDir := lStr; + if lOutDir[length(lOutDir)] <> pathdelim then + lOutDir := lOutDir + pathdelim; + end; + end; + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) or (lAbort); + if (not lPrefs.AppendPatientName) and (not lPrefs.AppendProtocolName) and (not lPrefs.AppendAcqSeries) and (not lPrefs.AppendDate) and (not lPrefs.AppendFilename) then begin + lPrefs.AppendPatientName := true; + lPrefs.AppendProtocolName := true; + lPrefs.AppendDate := true; + lPrefs.AppendAcqSeries := true; + end; + if direxists(lStr) then begin + if (lStr[length(lStr)] = PathDelim) and (length(lStr) > 1) then //and + delete(lStr, length(lStr), 1); //delete trialing separator + RecursiveFolderSearch(lStr,lOutDir,lPrefs,0); + lPrefs.NameAppend := ''; + end else if fileexists(lStr) then begin + lDir := ExtractFileDir(lStr); + if lDir = '' then begin //since fileexists, file is in working directory + lDir := GetCurrentDir; + dcmMsg('0 files in working directory '+lDir); + EnsureDirEndsWithPathDelim(lDir); + if fileexists(lDir + lStr) then + lStr := lDir+ lStr; + end; + lExt := UpCaseExt(lStr); + if IsNiftiExt(lStr) then begin +{$IFDEF GUI} + MainForm.ConvertDCM2NII(lStr,lPrefs); + //dcmMsg('Please drag and drop NIfTI images onto dcm2niigui to convert them') +{$ELSE} + ModifyAnalyze(lStr,lPrefs); +{$ENDIF} + end else if (lExt = '.REC') or (lExt = '.PAR') then begin + LoadFileListPARREC(lStr,lOutDir,lPrefs); + if lPrefs.everyfile then + exit; + end else begin + {$IFNDEF UNIX}lStartTime := GetTickCount; {$ENDIF} + if lPrefs.everyfile then + LoadFileList(lStr,lOutDir,lPrefs) + else + LoadParamFileList(lStr,lOutDir,lPrefs,I); + {$IFNDEF UNIX}dcmMsg('Time elapsed '+inttostr( GetTickCount-lStartTime)+'ms'); {$ENDIF} + exit; //only process a single file + end; + end else if not (lSilent) then begin + dcmMsg('0 '+paramstr(0)+' ERROR: unable to find '+lStr); + if not lHelpShown then + Showhelp(lIniName, lPrefs); + lHelpShown := true; + end; + until I >= ParamCount; + end else begin //no parameters passed - show help + ShowHelp(lIniName, lPrefs); + IniFile(False,lIniName, lPrefs);//ensure latest version of preferences file is created... + end;//param count > 0 +end; + +end. + diff --git a/dcm2nii/paramstrs.ppu b/dcm2nii/paramstrs.ppu new file mode 100644 index 0000000..97764b0 Binary files /dev/null and b/dcm2nii/paramstrs.ppu differ diff --git a/dcm2nii/parconvert.o b/dcm2nii/parconvert.o new file mode 100644 index 0000000..0552b5c Binary files /dev/null and b/dcm2nii/parconvert.o differ diff --git a/dcm2nii/parconvert.pas b/dcm2nii/parconvert.pas new file mode 100755 index 0000000..7bbdb41 --- /dev/null +++ b/dcm2nii/parconvert.pas @@ -0,0 +1,1374 @@ +unit parconvert; +{$H+} +interface +uses +{$IFDEF FPC}gzio2, {$ELSE} gziod,{$ENDIF} +math, bvec,define_types,SysUtils,dicom,dicomtypes,filename,nii_4dto3d,niftiutil,nii_orient, nii_crop,GraphicsMathLibrary,prefs,dialogs_msg, nifti_types; + +function LoadFileListPARREC (var lInFilename, lOutDir: string; var lPrefs: TPrefs): boolean; +implementation +uses dialogsx; + + +procedure PAR2DICOMstudyDate(var lDicomData: DICOMdata); +{input: lDicomData.StudyDate = 2002.12.29 / 19:48:58.0000 +output: StudyDate = YYYYMMDD StudyTime= hhmmss } +var + I: integer; + lStr: string; +begin + if length(lDicomData.StudyDate) < 14 then exit; + lStr := ''; + for I := 1 to length(lDicomData.StudyDate) do + if lDicomData.StudyDate[I] in ['0'..'9'] then + lStr := lStr+ lDicomData.StudyDate[I]; + if length(lStr) < 14 then exit; + lDicomData.StudyDate := ''; + for I := 1 to 8 do + lDicomData.StudyDate := lDicomData.StudyDate+lStr[I]; + lDicomData.StudyTime := ''; + for I := 9 to 14 do + lDicomData.StudyTime := lDicomData.StudyTime+lStr[I]; + lDicomData.DateTime := StudyDateTime(lDicomData.StudyDate,lDicomData.StudyTime); +end; + +procedure ShellSortItems (first, last: integer; var lPositionRA: longintp; lIndexRA: int64P; var lRepeatedValues: boolean); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n,t, nn, m, lognb2, l, k, j, i: longint; +begin + lRepeatedValues := false; + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do + begin + m := m div 2; + k := last - m; + for j := 1 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (lIndexRA^[lPositionRA^[l]] = lIndexRA^[lPositionRA^[i]]) then begin + lRepeatedValues := true; + exit; + end; + if (lIndexRA^[lPositionRA^[l]] < lIndexRA^[lPositionRA^[i]]) then begin + //swap values for i and l + t := lPositionRA^[i]; + lPositionRA^[i] := lPositionRA^[l]; + lPositionRA^[l] := t; + i := i - m; + if (i >= 1) then + goto 555; + end + end + end +end; //shellsort is fast and requires less memory than quicksort + +function SinDeg(lDeg: double): double; +begin + result := sin(lDeg*PI/180); +end; + +function CosDeg(lDeg: double): double; +begin + result := Cos(lDeg*PI/180); +end; + + FUNCTION Matrix3DL (CONST m11,m12,m13, m21,m22,m23, + m31,m32,m33: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; + matrix[1,3] := m13; matrix[1,4] := 0; + matrix[2,1] := m21; matrix[2,2] := m22; + matrix[2,3] := m23; matrix[2,4] := 0; + matrix[3,1] := m31; matrix[3,2] := m32; + matrix[3,3] := m33; matrix[3,4] := 0; + matrix[4,1] := 0; matrix[4,2] := 0; + matrix[4,3] := 0; matrix[4,4] := 1; + size := size3D + END + END {Matrix3D}; + // 'Defuzz' is used for comparisons and to avoid propagation of 'fuzzy', + // nearly-zero values. DOUBLE calculations often result in 'fuzzy' values. + // The term 'fuzz' was adapted from the APL language. +(* FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; + BEGIN + IF ABS(x) < fuzz + THEN RESULT := 0.0 + ELSE RESULT := x + END {Defuzz}; + *) + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + VAR + i,j,k: TIndex; + temp : DOUBLE; + BEGIN + RESULT.size := a.size; + IF a.size = b.size + THEN + + FOR i := 1 TO a.size DO + BEGIN + FOR j := 1 TO a.size DO + BEGIN + + temp := 0.0; + FOR k := 1 TO a.size DO + BEGIN + temp := temp + a.matrix[i,k]*b.matrix[k,j]; + END; + RESULT.matrix[i,j] := Defuzz(temp) + END + END + + ELSE dcmMsg('MultiplyMatrices error: '+inttostr(a.size)+' <> '+inttostr(b.size)) + END {MultiplyMatrices}; + + (* function RealToStr(lR: double {was extended}; lDec: integer): string; +begin + RealTOStr := FloatToStrF(lR, ffFixed,7,lDec); +end; + +procedure ReportMatrix (lStr: string;lM:TMatrix); +begin + dcmMsg(lStr); + dcmMsg( RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)); + dcmMsg( RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)); + dcmMsg( RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)); + dcmMsg( RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6)); +end; *) + +FUNCTION Diag3D (CONST m1,m2,m3,m4: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m1; matrix[1,2] := 0; + matrix[1,3] := 0; matrix[1,4] := 0; + + matrix[2,1] := 0; matrix[2,2] := m2; + matrix[2,3] := 0; matrix[2,4] := 0; + + matrix[3,1] := 0; matrix[3,2] := 0; + matrix[3,3] := m3; matrix[3,4] := 0; + + matrix[4,1] := 0; matrix[4,2] := 0; + matrix[4,3] := 0; matrix[4,4] := m4; + size := size3D + END +END {Diag3D}; + +FUNCTION Matrix3D (CONST m11,m12,m13,m14, m21,m22,m23,m24, + m31,m32,m33,m34, m41,m42,m43,m44: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; + matrix[1,3] := m13; matrix[1,4] := m14; + + matrix[2,1] := m21; matrix[2,2] := m22; + matrix[2,3] := m23; matrix[2,4] := m24; + + matrix[3,1] := m31; matrix[3,2] := m32; + matrix[3,3] := m33; matrix[3,4] := m34; + + matrix[4,1] := m41; matrix[4,2] := m42; + matrix[4,3] := m43; matrix[4,4] := m44; + size := size3D + END + END {Matrix3D}; + +function mat44_inverse(var R: Tmatrix ) : TMatrix; +var + r11,r12,r13,r21,r22,r23,r31,r32,r33,v1,v2,v3 , deti : double; + Q: TMatrix; +begin + r11 := R.matrix[1,1]; r12 := R.matrix[1,2]; r13 := R.matrix[1,3]; //* [ r11 r12 r13 v1 ] */ + r21 := R.matrix[2,1]; r22 := R.matrix[2,2]; r23 := R.matrix[2,3]; //* [ r21 r22 r23 v2 ] */ + r31 := R.matrix[3,1]; r32 := R.matrix[3,2]; r33 := R.matrix[3,3]; //* [ r31 r32 r33 v3 ] */ + v1 := R.matrix[1,4]; v2 := R.matrix[2,4]; v3 := R.matrix[3,4]; //* [ 0 0 0 1 ] */ + + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + + if( deti <> 0.0 ) then + deti := 1.0 / deti ; + + Q.matrix[1,1] := deti*( r22*r33-r32*r23) ; + Q.matrix[1,2] := deti*(-r12*r33+r32*r13) ; + Q.matrix[1,3] := deti*( r12*r23-r22*r13) ; + Q.matrix[1,4] := deti*(-r12*r23*v3+r12*v2*r33+r22*r13*v3 + -r22*v1*r33-r32*r13*v2+r32*v1*r23) ; + + Q.matrix[2,1] := deti*(-r21*r33+r31*r23) ; + Q.matrix[2,2] := deti*( r11*r33-r31*r13) ; + Q.matrix[2,3] := deti*(-r11*r23+r21*r13) ; + Q.matrix[2,4] := deti*( r11*r23*v3-r11*v2*r33-r21*r13*v3 + +r21*v1*r33+r31*r13*v2-r31*v1*r23) ; + + Q.matrix[3,1] := deti*( r21*r32-r31*r22) ; + Q.matrix[3,2] := deti*(-r11*r32+r31*r12) ; + Q.matrix[3,3] := deti*( r11*r22-r21*r12) ; + Q.matrix[3,4] := deti*(-r11*r22*v3+r11*r32*v2+r21*r12*v3 + -r21*r32*v1-r31*r12*v2+r31*r22*v1) ; + + Q.matrix[4,1] := 0; Q.matrix[4,2] := 0; Q.matrix[4,3] := 0.0 ; + Q.matrix[4,4] := 1;// (deti == 0.0l) ? 0.0l : 1.0l ; /* failure flag if deti == 0 */ + + result := Q ; +end; + +procedure SetLarger (var lA,lB: double); +begin + if lA > lB then + lB := lA + else + lA := lB; +end; + + +procedure matx(var lNHdr: TNiftiHdr; var lDICOMdata: DICOMdata; b,c,a,{b,c,a,}offa,offb,offc,lx,ly,lz,lAPFOV,lFHFOV,lRLFOV: single; lOrient: integer); +var +lxmm,lymm,lzmm,x,y,z,la,lb,lc: double; +dx,dy,dz: single; + analyze_to_dicom,base,ra,rb,rc,lmm,patient_to_tal,lZm:TMatrix; +begin + lNHdr.sform_code := kNIFTI_XFORM_UNKNOWN; + if (lZ < 1) or (lY < 1) or (lX < 1) then exit; + {a=angle(3,1); + b=angle(1,1); + c=angle(2,1);} + ra := Matrix3DL(1, 0, 0, 0, cos(a*pi/180), -sin(a*pi/180), 0, sin(a*pi/180), cos(a*pi/180)); + rb := Matrix3DL(cos(b*pi/180), 0, sin(b*pi/180), 0, 1, 0, -sin(b*pi/180), 0, cos(b*pi/180)); + rc := Matrix3DL(cos(c*pi/180), -sin(c*pi/180), 0, sin(c*pi/180), cos(c*pi/180), 0, 0, 0, 1); + base.size := size3D; + base := MultiplyMatrices(rb,rc); + base := MultiplyMatrices(ra,base); + if lOrient = 2 then begin //sagittal + //dcmMsg('sag'); + lmm := Matrix3D ( + 0, 0, -1,0, + 1, 0, 0, 0, + 0, -1, 0,0, + 0, 0, 0, 1); + lYmm := lAPFOV /lX; + lZmm := lFHFOV / lY; + //use smallest in plane resolution... + SetLarger (lYmm,lZmm); + lXmm := lRLFOV /lZ; + end else if lOrient = 3 then begin //coronal + //dcmMsg('Coronal'); + lmm := Matrix3D ( + 1, 0, 0,0, + 0,0, 1, 0, + 0, -1, 0,0, + 0, 0, 0, 1); + lXmm := lRLFOV /lX; + lZmm := lFHFOV / lY; + //use smallest in plane resolution... + SetLarger (lXmm,lZmm); + lYmm := lAPFOV /lZ; + + end else begin + //dcmMsg('Axial '+inttostr(lOrient)); + lmm := diag3D(1, 1, 1,1); + lXmm := lRLFOV /lX; + lYmm := lAPFOV /lY; + //use smallest in plane resolution... + SetLarger (lXmm,lYmm); + lZmm := lFHFOV / lZ; + end; + lZm := Matrix3D (lxmm,0,0,0, + 0,lymm,0,0, + 0,0,lZmm,0, + 0,0,0,1); + patient_to_tal := diag3D(-1, -1, 1,1); + analyze_to_dicom := Matrix3D ( + 1, 0, 0,0, + 0,-1, 0,0, + 0, 0, 1,0, + 0, 0, 0, 1); + +//correct- A_tot=patient_to_tal*R_tot*Zm*lmm*analyze_to_dicom; +//wrong - A_tot=patient_to_tal*Zm*R_tot*lmm*analyze_to_dicom; +{ReportMatrix('Rtot',base); +ReportMatrix('zoom',lZm); +ReportMatrix('p2tal',patient_to_tal); +ReportMatrix('lmm',lmm); +ReportMatrix('analyze_to_dicom',analyze_to_dicom);} + + base := MultiplyMatrices(patient_to_tal,base); + base := MultiplyMatrices(base,lZm); + base := MultiplyMatrices(base,lmm);//2/2007 suggested by Bas Neggers + base:= MultiplyMatrices(base,analyze_to_dicom); + + x := (lx-1)/2; + y := (ly-2)/2; + z := (lz-1)/2; + la :=(base.matrix[1,1]*x)+(base.matrix[1,2]*y)+(base.matrix[1,3]*z)+base.matrix[1,4]; + lb :=(base.matrix[2,1]*x)+(base.matrix[2,2]*y)+(base.matrix[2,3]*z)+base.matrix[2,4]; + lc :=(base.matrix[3,1]*x)+(base.matrix[3,2]*y)+(base.matrix[3,3]*z)+base.matrix[3,4]; + base.matrix[1,4] := -la-offa; + base.matrix[2,4] := -lb-offb; + base.matrix[3,4] := -lC+offc; + //ReportMatrix('nifti final',base); + lNHdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT; + lNHdr.srow_x[0] := base.matrix[1,1]; + lNHdr.srow_x[1] := base.matrix[1,2]; + lNHdr.srow_x[2] := base.matrix[1,3]; + lNHdr.srow_x[3] := base.matrix[1,4]; + lNHdr.srow_y[0] := base.matrix[2,1]; + lNHdr.srow_y[1] := base.matrix[2,2]; + lNHdr.srow_y[2] := base.matrix[2,3]; + lNHdr.srow_y[3] := base.matrix[2,4]; + lNHdr.srow_z[0] := base.matrix[3,1]; + lNHdr.srow_z[1] := base.matrix[3,2]; + lNHdr.srow_z[2] := base.matrix[3,3]; + lNHdr.srow_z[3] := base.matrix[3,4]; + lNHdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; + nifti_mat44_to_quatern( base, + lNHdr.quatern_b,lNHdr.quatern_c,lNHdr.quatern_d, + lNHdr.qoffset_x,lNHdr.qoffset_y,lNHdr.qoffset_z, + dx, dy, dz, lNHdr.pixdim[0]{QFac}); + end; + +function DTItextfiles (lImgName: string; lDTIra: TDTIra; lNumDir: integer): boolean; +//create text files that describe output vectors +var + lOutDTIname: string; + lTextF: TextFile; + lSeries,lStart,lEnd: integer; +begin + result := false; + if lImgName = '' then exit; + lStart := 1; + lEnd := lNumDir; + //ensure some variability + lSeries := 1; + while (lSeries <= lEnd) and (lDTIra[1].v1 = lDTIra[lSeries].v1) and (lDTIra[1].bval = lDTIra[lSeries].bval) do + inc(lSeries); + if (lSeries > lEnd) then exit; //no variability in bvec or bval + //create bvec + lOutDTIname := changefileextX(lImgName,'.bvec'); + assignfile(lTextF,lOutDTIname); + Filemode := 0; + rewrite(lTextF); + for lSeries := lStart to lEnd do + Write(lTextF,floattostr(lDTIra[lSeries].v1)+ ' '); + Writeln(lTextF); + for lSeries := lStart to lEnd do + Write(lTextF,floattostr(lDTIra[lSeries].v2)+ ' '); + Writeln(lTextF); + for lSeries := lStart to lEnd do + Write(lTextF,floattostr(lDTIra[lSeries].v3)+ ' '); + Writeln(lTextF); + closefile(lTextF); + //create bval + lOutDTIname := changefileextX(lOutDTIname,'.bval'); + assignfile(lTextF,lOutDTIname); + Filemode := 0; + rewrite(lTextF); + for lSeries := lStart to lEnd do + Write(lTextF,inttostr(lDTIra[lSeries].bval)+' '); + Writeln(lTextF); + closefile(lTextF); + result := true; +end;// funct DTItextfiles + + +procedure read_PAR2NII(var lNHdr: TNIftIHdr; var lDICOMdata: DICOMdata; var lHdrOK, lImageFormatOK,lPrecise:boolean; var lDynStr: string;var lFileName: string; lReadOffsetTables: boolean; var lOffset_pos_table: LongIntp; var lOffsetTableEntries,lRescaleEntries: integer; var lSlopeRA,lInterceptRA: Singlep; var lnum4Ddatasets, lSliceOrient: integer; var lDTIra: TDTIra); +label 333; //1384 now reads up to 8 dimensional data.... +type tRange = record + Min,Val,Max: double; //some vals are ints, others floats +end; +const UNIXeoln = chr(10); + kMaxnSLices = 18000;//delphi 32000 - lazarus fails >15000 + kXdim = 1; + kYdim = 2; + kBitsPerVoxel = 3; + kSliceThick = 4; + kSliceGap = 5; + kXmm = 6; + kYmm = 7; + kRS = 8; + kRI = 9; + kSS = 10; //1393 - attempt to use calibrated values + kDynTime = 11; + kSlice = 12; + kEcho = 13; + kDyn = 14; + kCardiac = 15; + kType = 16; + kSequence = 17; + kASL = 18; + kIndex = 19; + lIsParVers3: boolean = true; + lIsParVers42: boolean = false; + lIsParVers41: boolean = false; + lRepeatedValues : boolean = false; + lSlicesNotInSequence: boolean = false; + lMaxSlice : integer = 0; + lMaxIndex : integer = 0; + lSliceSz: integer = 0; + lMatOrient: boolean = false; + //lOffsetTablesRequired: boolean = false; +var + lDTIraDyn, lDTIraDynUnSorted: array of TDTI; + //lDTIra: TDTIra; + //lHFSStr, + lErrorStr,lInStr,lUpCaseStr,lReportedTRStr: string; + lAPFOV,lFHFOV,lRLFOV, + lScanResX,lScanResY,lAngleA,lAngleB,lAngleC,lOffset1,lOffset2,lOffset3{,lXFOV,lYFOV}: double; + lSliceIndexRAx,lSliceSequenceRA,lSortedSliceSequence: int64P; + //lSliceIndexRA: array [1..kMaxnSlices] of longint; + //lSSx,lRSx,lRIx: array [1..kMaxnSlices] of single; + lSlopeRAx,lInterceptRAx: array [1..kMaxnSlices] of single; + lSliceHeaderRA: array [1..50] of double; + //lRepeatedValues,lSlicesNotInSequence,lIsParVers3: boolean;//,lMissingVolumes,{,lLongRAtooSmall,lMissingVolumes,lConstantScale,lContiguousSlices,} + lRangeRA: array [kXdim..kIndex] of tRange; + lSliceInfoCount,lPos,lLen,lFileSz,lHdrPos,linPos,lInc,lOrient: integer; + fp: file; + lCharRA: bytep; +procedure MinMaxTRange (var lDimension: tRange; lNewVal: double); //nested +begin + lDimension.Val := lNewVal; + if lSliceInfoCount < 2 then begin + lDimension.Min := lDimension.Val; + lDimension.Max := lDimension.Val; + end; + if lNewVal < lDimension.Min then lDimension.Min := lNewVal; + if lNewVal > lDimension.Max then lDimension.Max := lNewVal; +end; //nested InitTRange proc +function readParStr:string;//nested +var lStr: string; +begin + lStr := ''; + While (lPos <= lLen) do begin + if (lStr <> '') or (linStr[lPos]<>' ') then //strip leading spaces + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; //while lPOs < lLen + result := lStr; +end; //nested func ReadParStr +function readParFloat:double;//nested +var lStr: string; +begin + lStr := ''; + result := 1; + While (lPos <= lLen) and ((lStr='') or(lInStr[lPos] <> ' ')) do begin + if lInStr[lPos] in ['+','-','e','E','.','0'..'9'] then + lStr := lStr+(linStr[lPos]); + inc(lPos); + end; + if lStr = '' then exit; + try + result := strtofloat(lStr); + except + on EConvertError do begin + dcmMsg('read_PAR2NII: Unable to convert the string '+lStr+' to a number'); + result := 1; + exit; + end; + end; {except} +end; //nested func ReadParFloat +begin + //Initialize parameters + lOrient := 0; + lAPFOV := 1; + lnum4Ddatasets := 1; + lMatOrient := false; + lIsParVers3 := true; + lIsParVers41 := false; + lIsParVers42 := false; + lSliceInfoCount := 0; + getmem(lSliceIndexRAx, kMaxnSLices* sizeof(int64)); + setlength(lDTIraDyn,kMaxnSLices+1);//+1 since indexed from zero + + for lInc := kXdim to kIndex do //initialize all values: important as PAR3 will not explicitly report all + MinMaxTRange(lRangeRA[lInc],0); + lHdrOK := false; + lImageFormatOK := false; + lRescaleEntries := 0; + lOffsetTableEntries := 0; + Clear_Dicom_Data(lDicomData); + lDynStr := ''; + + //Read text header to buffer (lCharRA) + FileMode := 0; //set to readonly + AssignFile(fp, lFileName); + Reset(fp, 1); + lFileSz := FileSize(fp); + GetMem( lCharRA, lFileSz+1 ); //note: must free dynamic memory: goto 333 if any error + GetMem (lSliceSequenceRA, kMaxnSLices*sizeof(int64)); //note: must free dynamic memory: goto 333 if any error + BlockRead(fp, lCharRA^, lFileSz, lInpos); + if lInPos <> lFileSz then begin + dcmMsg('read_PAR2NII: Disk error, unable to read full input file.'); + goto 333; + end; + linPos := 1; + CloseFile(fp); + FileMode := 2; //set to read/write + //Next: read each line of header file... + + repeat //for each line in file.... + linstr := ''; + while (linPos < lFileSz) and (lCharRA^[linPos] <> ord(kCR)) and (lCharRA^[linPos] <> ord(UNIXeoln)) do begin + lInStr := lInstr + chr(lCharRA^[linPos]); + inc(linPos); + end; + inc(lInPos); //read EOLN + lLen := length(lInStr); + lPos := 1; + lUpcaseStr := ''; + if lLen < 1 then + //ignore blank lines + else if (lInStr[1] = '*') and (not lHdrOK) then //# -> comment + //ignore comment lines prior to start of header + else if (lInStr[1] = '#') and (lHdrOK) then begin//# -> comment ignore UNLESS it reveals version + if (Length(lInStr)> 16) and (lInStr[3] = 'C') and (Copy(lInStr,3,15) = 'CLINICAL TRYOUT') then begin + lUpCaseStr := ''; + lHdrPos := Length(lInStr); + while (lHdrPos > 0) and (UpCase(lInStr[lHdrPos]) <> 'V') do begin + if lInStr[lHdrPos] in ['.', '0'..'9'] then + lUpCaseStr := UpCase(lInStr[lHdrPos])+lUpCaseStr; + dec(lHdrPos); + end; + if lUpCaseStr = '3' then + lIsParVers3 := true + else if lUpCaseStr = '4' then + lIsParVers3 := false + else if lUpCaseStr = '4.1' then begin + lIsParVers3 := false; + lIsParVers41 := true; + dcmMsg('PAR v4.1 not yet fully supported') + end else if lUpCaseStr = '4.2' then begin //11/2007 + lIsParVers3 := false; + lIsParVers41 := true; + lIsParVers42 := true; + //dcmMsg('PAR v4.2 : DTI bval/bvec support still experimental') + end else + dcmMsg('Warning: unknown PAR version '+lUpCaseStr); + + end; + end else if (lInStr[1] = '.') or (not lHdrOK) then begin // GENERAL_INFORMATION section (line starts with '.') + //Note we also read in lines that do not have '.' if we have HdrOK=false, this allows us to detect the DATADESCRIPTIONFILE signature + While (lPos <= lLen) and (lInStr[lPos] <> ':') and ((not lHdrOK) or (lInStr[lPos] <> '#')) do begin + if lInStr[lPos] in ['[',']','(',')','/','+','-',{' ',} '0'..'9','a'..'z','A'..'Z'] then + lUpCaseStr := lUpCaseStr+upcase(linStr[lPos]); + inc(lPos); + end; //while reading line + inc(lPos); {read equal sign in := statement} + lDynStr := lDynStr + lInStr+kCR; + //dcmMsg(inttostr(length(lUpCaseStr))); + if (not lHdrOK) and (lUpcaseStr = ('DATADESCRIPTIONFILE')) then begin //1389 PAR file + lHdrOK := true; + lDicomData.little_endian := 1; + end; + + if (lUpCaseStr ='REPETITIONTIME[MSEC]') or (lUpCaseStr ='REPETITIONTIME[MS]') then + lDicomData.TR := round(readParFloat); + if (lUpCaseStr ='MAXNUMBEROFSLICES/LOCATIONS') then + lDicomData.XYZdim[3] := round(readParFloat); + if (lUpCaseStr ='SLICETHICKNESS[MM]') then + MinMaxTRange(lRangeRA[kSliceThick],readParFloat); + if (lUpCaseStr ='SLICEGAP[MM]') then + MinMaxTRange(lRangeRA[kSliceGap],readParFloat); + if lUpCaseStr = 'FOV(APFHRL)[MM]' then begin + lDicomData.XYZmm[2] := (readParFloat); //AP anterior->posterior + lDicomData.XYZmm[3] := (readParFloat); //FH foot head + lDicomData.XYZmm[1] := (readParFloat); //RL Right-Left + lAPFOV := lDicomData.XYZmm[2]; + lFHFOV := lDicomData.XYZmm[3]; + lRLFOV := lDicomData.XYZmm[1]; + end; + if lUpCaseStr = 'SCANRESOLUTION(XY)' then begin + lScanResX := round(readParFloat); + lScanResY := round(readParFloat); + end; + {if lUpCaseStr = 'SCANPERCENTAGE' then begin + lScanPct := round(readParFloat); + end; } + if lUpCaseStr = 'RECONRESOLUTION(XY)' then begin + MinMaxTRange(lRangeRA[kXdim],readParFloat); + MinMaxTRange(lRangeRA[kYdim],readParFloat); + end; + if lUpCaseStr = 'RECONSTRUCTIONNR' then + lDicomData.AcquNum := round(readParFloat); + if lUpCaseStr = 'ACQUISITIONNR' then + lDicomData.SeriesNum := round(readParFloat); + if lUpCaseStr = 'MAXNUMBEROFDYNAMICS' then begin + lDicomData.XYZdim[4] := round(readParFloat); + end; + if lUpCaseStr = 'EXAMINATIONDATE/TIME' then begin + lDicomData.StudyDate := readParStr; + PAR2DICOMstudyDate(lDicomData); + end; + if (lUpCaseStr ='ANGULATIONMIDSLICE(APFHRL)[DEGR]') then begin + lAngleA := (readParFloat); + lAngleB := (readParFloat); + lAngleC := (readParFloat); + lDicomData.AngulationAP := lAngleA; + lDicomData.AngulationFH := lAngleB; + lDicomData.AngulationRL := lAngleC; + end; + if (lUpCaseStr ='OFFCENTREMIDSLICE(APFHRL)[MM]') then begin + lOffset2 := (readParFloat); + lOffset3 := (readParFloat); + lOffset1 := (readParFloat); + end; + if lUpCaseStr = 'PROTOCOLNAME' then + lDicomData.ProtocolName := readParStr; + if lUpCaseStr = 'PATIENTPOSITION' then begin + lDicomData.PatientPos := UpperCase (readParStr); //upcase + if (lDicomData.PatientPos <> 'HEAD FIRST SUPINE') then + dcmMsg('*WARNING: participant was not head first supine - spatial transforms may be wrong :'+lDicomData.PatientPos) + else + lDicomData.PatientPos := 'HFS'; + + + end; + if lUpCaseStr = 'PATIENTNAME' then + lDicomData.PatientName := readParStr; + if lUpCaseStr ='IMAGEPIXELSIZE[8OR16BITS]' then begin + MinMaxTRange(lRangeRA[kBitsPerVoxel],readParFloat); + end; + if not lHdrOK then begin + dcmMsg('read_PAR2NII: Error reading header'); + goto 333; + end; + end else begin //SliceInfo: IMAGE_INFORMATION (line does NOT start with '.' or '#') + inc(lSliceInfoCount); + if (lSliceInfoCount < 2) and (lRangeRA[kBitsPerVoxel].val < 1) then //PARvers3 has imagedepth in general header, only in image header for later versions + lIsParVers3 := false; + for lHdrPos := 1 to 26 do + lSliceHeaderRA[lHdrPos] := readparfloat; + //The next few values are in the same location for both PAR3 and PAR4 + MinMaxTRange(lRangeRA[kSlice], round(lSliceHeaderRA[1])); + MinMaxTRange(lRangeRA[kEcho], round(lSliceHeaderRA[2])); + MinMaxTRange(lRangeRA[kDyn], round(lSliceHeaderRA[3])); + if not lIsParVers42 then //if 4.2 then we will use combination of Cardiac and ASL for cardiac number + MinMaxTRange(lRangeRA[kCardiac], round(lSliceHeaderRA[4])); + MinMaxTRange(lRangeRA[kType], round(lSliceHeaderRA[5])); + MinMaxTRange(lRangeRA[kSequence], round(lSliceHeaderRA[6])); + MinMaxTRange(lRangeRA[kIndex], round(lSliceHeaderRA[7])); + if lIsParVers3 then begin //Read PAR3 data + MinMaxTRange(lRangeRA[kRI], lSliceHeaderRA[8]);; //8=intercept in PAR3 + MinMaxTRange(lRangeRA[kRS],lSliceHeaderRA[9]); //9=slope in PAR3 + MinMaxTRange(lRangeRA[kSS],lSliceHeaderRA[10]); //10=lcalibrated slope in PAR3 1393 - attempt to use calibrated values + //MinMaxTRange(lRangeRA[kXmm],lSliceHeaderRA[23]); //23 PIXEL SPACING X in PAR3 + //MinMaxTRange(lRangeRA[kYmm],lSliceHeaderRA[24]); //24 PIXEL SPACING Y IN PAR3 + MinMaxTRange(lRangeRA[kDynTime],(lSliceHeaderRA[26])); //26= dyn_scan_begin_time in PAR3 + end else begin //not PAR: assume PAR4 + for lHdrPos := 27 to 32 do + lSliceHeaderRA[lHdrPos] := readparfloat; + MinMaxTRange(lRangeRA[kBitsPerVoxel],lSliceHeaderRA[8]);//8 BITS in PAR4 + MinMaxTRange(lRangeRA[kXdim], lSliceHeaderRA[10]); //10 XDim in PAR4 + MinMaxTRange(lRangeRA[kYdim], lSliceHeaderRA[11]); //11 YDim in PAR4 + MinMaxTRange(lRangeRA[kRI],lSliceHeaderRA[12]); //12=intercept in PAR4 + MinMaxTRange(lRangeRA[kRS],lSliceHeaderRA[13]); //13=lslope in PAR4 + MinMaxTRange(lRangeRA[kSS],lSliceHeaderRA[14]); //14=lcalibrated slope in PAR4 1393 - attempt to use calibrated values + MinMaxTRange(lRangeRA[kDynTime],(lSliceHeaderRA[32]));//32= dyn_scan_begin_time in PAR4 + if lIsParVers41 then begin + for lHdrPos := 33 to 47 do + lSliceHeaderRA[lHdrPos] := readparfloat; + if ({diff}lSliceHeaderRA[34]<> 0) and ({grad}lSliceHeaderRA[43]<> 0) then //DTI scan - treat as dynamics + MinMaxTRange(lRangeRA[kDyn], ({diff}lSliceHeaderRA[34]*100)+ ({gradient}lSliceHeaderRA[43]) ); + if lIsParVers42 then begin + for lHdrPos := 48 to 49 do + lSliceHeaderRA[lHdrPos] := readparfloat; + //fx(lSliceInfoCount,lSliceHeaderRA[46],lSliceHeaderRA[47],lSliceHeaderRA[48]); + lSliceOrient := round(lSliceHeaderRA[26]); + lDTIraDyn[lSliceInfoCount].bval := round(lSliceHeaderRA[34]); + //# diffusion (ap, fh, rl) (3*float) 46=AP=Y,47=FH=Z,48=RL=X + lDTIraDyn[lSliceInfoCount].v1 := lSliceHeaderRA[48]; + lDTIraDyn[lSliceInfoCount].v2 := lSliceHeaderRA[46]; + lDTIraDyn[lSliceInfoCount].v3 := lSliceHeaderRA[47]; + MinMaxTRange(lRangeRA[kCardiac], ({cardiac}lSliceHeaderRA[49]*100)+ ({asl}lSliceHeaderRA[4]) ); + + end; //PAR42 + + end; //PAR41 + end; //PAR4 + if lSliceInfoCount < kMaxnSlices then begin + lSliceSequenceRA^[lSliceInfoCount] := (round(lRangeRA[kSequence].val) shl 48)+(round(lRangeRA[kType].val) shl 40)+(round(lRangeRA[kCardiac].val) shl 32)+(round(lRangeRA[kEcho].val) shl 24)+(round(lRangeRA[kDyn].val) shl 10)+round(lRangeRA[kSlice].val); + (*lRSx [lSliceInfoCount] := lRangeRA[kRS].Val; + lRIx [lSliceInfoCount] := lRangeRA[kRI].val; + lSSx [lSliceInfoCount] := lRangeRA[kSS].Val; + *) + // fx( lRangeRA[kType].val ,lRangeRA[kEcho].val); + PhilipsPrecise (lRangeRA[kRS].Val, lRangeRA[kRI].val,lRangeRA[kSS].Val,lSlopeRAx[lSliceInfoCount],lInterceptRAx[lSliceInfoCount],lPrecise); + lSliceIndexRAx^[lSliceInfoCount]:= round(lRangeRA[kIndex].val); + end; + if (not lMatOrient) and (lSliceHeaderRA[1]=1) and (lSliceHeaderRA[2]=1) {and (lSliceHeaderRA[3]=1)} and (lSliceHeaderRA[4]=1) then begin + lMatOrient := true; + //first slice/echo/-dynamic/cardiac --- take slice position information from this slice... + //par4 - 20,21,22 ; par3 16,17,18 + if lIsParVers3 then + lOrient := round(lSliceHeaderRA[19]) + else + lOrient := round(lSliceHeaderRA[26]); + //# slice orientation ( TRA/SAG/COR ) (integer) + matx(lNHdr,lDicomData,lAngleA,lAngleB,lAngleC,lOffset1,lOffset2,lOffset3, + lRangeRA[kXdim].Val,lRangeRA[kYdim].Val,lDicomData.XYZdim[3], + lAPFOV,lFHFOV,lRLFOV,lOrient); + //procedure mat(b,c,a,offa,offb,offc,lx,ly,lz,lxmm,lymm,lzmm: single); + end; + end; //SliceInfo Line + until (linPos >= lFileSz);//until done reading entire file... + //describe generic DICOM parameters + lDicomData.XYZdim[1] := round(lRangeRA[kXdim].Val); + lDicomData.XYZdim[2] := round(lRangeRA[kYdim].Val); + lDicomData.XYZdim[3] := 1+round(lRangeRA[kSlice].Max-lRangeRA[kSlice].Min); + if (lSliceInfoCount mod lDicomData.XYZdim[3]) <> 0 then + dcmMsg('read_PAR2NII: Total number of slices not divisible by number of slices per volume. Reconstruction error?'); + if lDicomData.XYZdim[3] > 0 then + lDicomData.XYZdim[4] := lSliceInfoCount div lDicomData.XYZdim[3] //nVolumes = nSlices/nSlicePerVol + else + lDicomData.XYZdim[4] := 1; + if lOrient = 2 then begin //sagittal + lDicomData.XYZmm[1] := lAPFOV /lDicomData.XYZdim[1]; + lDicomData.XYZmm[2] := lFHFOV / lDicomData.XYZdim[2]; + lDicomData.XYZmm[3] := lRLFOV /lDicomData.XYZdim[3]; + end else if lOrient = 3 then begin //coronal + lDicomData.XYZmm[1] := lRLFOV /lDicomData.XYZdim[1]; + lDicomData.XYZmm[2] := lFHFOV / lDicomData.XYZdim[2]; + lDicomData.XYZmm[3] := lAPFOV /lDicomData.XYZdim[3]; + end else begin //axial + lDicomData.XYZmm[1] := lRLFOV /lDicomData.XYZdim[1]; + lDicomData.XYZmm[2] := lAPFOV /lDicomData.XYZdim[2]; + lDicomData.XYZmm[3] := lFHFOV / lDicomData.XYZdim[3]; + end; + //use smallest in plane resolution... + SetLarger (lDicomData.XYZmm[1],lDicomData.XYZmm[2]); + lDicomData.Allocbits_per_pixel := round(lRangeRA[kBitsPerVoxel].Val); + lDicomData.IntenScale := lRangeRA[kRS].Val; + lDicomData.IntenIntercept := lRangeRA[kRI].Val; + //Next: report number of Dynamic scans, this allows people to parse DynScans from Type/Cardiac/Echo/Sequence 4D files + lnum4Ddatasets := (round(lRangeRA[kDyn].Max - lRangeRA[kDyn].Min)+1)*lDicomData.XYZdim[3]; //slices in each dynamic session + if ((lSliceInfoCount mod lnum4Ddatasets) = 0) and ((lSliceInfoCount div lnum4Ddatasets) > 1) then + lnum4Ddatasets := (lSliceInfoCount div lnum4Ddatasets) //infer multiple Type/Cardiac/Echo/Sequence + else + lnum4Ddatasets := 1; + //next: Determine actual interscan interval + if (lDicomData.XYZdim[4] > 1) and ((lRangeRA[kDynTime].max-lRangeRA[kDynTime].min)> 0) {1384} then begin + lReportedTRStr := 'Reported TR: '+floattostrf(lDicomData.TR,ffFixed,8,2)+kCR; + lDicomData.TR := (lRangeRA[kDynTime].max-lRangeRA[kDynTime].min) /(lDicomData.XYZdim[4] - 1)*1000; //infer TR in ms + end else + lReportedTRStr :=''; + //next: report header details + lDynStr := 'Philips PAR/REC Format' //'PAR/REC Format' + +kCR+ 'Patient name:'+lDicomData.PatientName + +kCR+ 'XYZ dim: ' +inttostr(lDicomData.XYZdim[1])+'/'+inttostr(lDicomData.XYZdim[2])+'/'+inttostr(lDicomData.XYZdim[3]) + +kCR+'Volumes: ' +inttostr(lDicomData.XYZdim[4]) + +kCR+'XYZ mm: '+floattostrf(lDicomData.XYZmm[1],ffFixed,8,2)+'/' + +floattostrf(lDicomData.XYZmm[2],ffFixed,8,2)+'/'+floattostrf(lDicomData.XYZmm[3],ffFixed,8,2) + +kCR+'TR: '+floattostrf(lDicomData.TR,ffFixed,8,2) + +kCR+lReportedTRStr+kCR+lDynStr; + + //if we get here, the header is fine, next steps will see if image format is readable... + lHdrOK := true; + if lSliceInfoCount < 1 then begin + dcmMsg('No valid images found.') ; + goto 333; + end; + //next: see if slices are in sequence + lSlicesNotInSequence := false; + if lSliceInfoCount > 1 then begin + lMaxSlice := lSliceSequenceRA^[1]; + lMaxIndex := lSliceIndexRAx^[1]; + lInc := 1; + repeat + inc(lInc); + if lSliceSequenceRA^[lInc] < lMaxSlice then //not in sequence if image has lower slice order than previous image + lSlicesNotInSequence := true + else + lMaxSlice := lSliceSequenceRA^[lInc]; + if lSliceIndexRAx^[lInc] < lMaxIndex then //not in sequence if image has lower slice index than previous image + lSlicesNotInSequence := true + else + lMaxIndex := lSliceIndexRAx^[lInc]; + until (lInc = lSliceInfoCount) or (lSlicesNotInSequence); + end; //at least 2 slices + + //Next: report any errors + lErrorStr := ''; + if (lSlicesNotInSequence) and (not lReadOffsetTables) then + lErrorStr := lErrorStr + ' Slices not saved sequentially [using MRIcro''s ''Philips PAR to Analyze'' command may solve this]'+kCR; + if lSliceInfoCount > kMaxnSlices then + lErrorStr := lErrorStr + ' Too many slices: >'+inttostr(kMaxnSlices)+kCR; + if (lRangeRA[kBitsPerVoxel].min <> lRangeRA[kBitsPerVoxel].max) then //5D file space+time+cardiac + lErrorStr := lErrorStr + ' Differing bits per voxel'+kCR; + //if (lRangeRA[kCardiac].min <> lRangeRA[kCardiac].max) then //5D file space+time+cardiac + // lErrorStr := lErrorStr + 'Multiple cardiac timepoints'+kCR; + //if (lRangeRA[kEcho].min <> lRangeRA[kEcho].max) then //5D file space+time+echo + // lErrorStr := lErrorStr + 'Multiple echo timepoints'+kCR; + if (lRangeRA[kSliceThick].min <> lRangeRA[kSliceThick].max) or (lRangeRA[kSliceGap].min <> lRangeRA[kSliceGap].max) + or (lRangeRA[kXdim].min <> lRangeRA[kXdim].max) or (lRangeRA[kYDim].min <> lRangeRA[kYDim].max) + or (lRangeRA[kXmm].min <> lRangeRA[kXmm].max) or (lRangeRA[kYmm].min <> lRangeRA[kYmm].max) then + lErrorStr := lErrorStr + ' Multiple/varying slice dimensions'+kCR; + //if any errors were encountered, report them.... + + if lErrorStr <> '' then begin + dcmMsg('read_PAR2NII: This software can not convert this Philips data:'+kCR+lErrorStr); + goto 333; + end; + //Next sort image indexes here... + if (lSliceInfoCount > 1) and(lSlicesNotInSequence) and ( lReadOffsetTables) then begin //sort image order... + //ShellSort (first, last: integer; var lPositionRA, lIndexLoRA,lIndexHiRA: LongintP; var lRepeatedValues: boolean) + GetMem (lOffset_pos_table, lSliceInfoCount*sizeof(int64)); + for lInc := 1 to lSliceInfoCount do + lOffset_pos_table^[lInc] := lInc; + ShellSortItems (1, lSliceInfoCount,lOffset_pos_table,lSliceSequenceRA, lRepeatedValues); + (* if lRepeatedValues then begin + dcmMsg('read_PAR2NII: fatal error, slices do not appear to have unique indexes [multiple copies of same slice]'); + FreeMem (lOffset_pos_table); + goto 333; + end; *) + lOffsetTableEntries := lSliceInfoCount; + end; //sort image order... + + + //Next, generate list of scale slope + (*lOffsetTablesRequired := false; + if (lSliceInfoCount > 1) and ( (lRangeRA[kSS].min <> lRangeRA[kSS].max) + or (lRangeRA[kRS].min <> lRangeRA[kRS].max) + or (lRangeRA[kRI].min <> lRangeRA[kRI].max)) then + lOffsetTablesRequired := true; + *) + lDicomData.IntenScale := lSlopeRAx[1]; + lDicomData.IntenIntercept := lInterceptRAx[1]; + //PhilipsPrecise (lRSx[lInc], lRIx[lInc],lSSx[lInc], lDicomData.IntenScale,lDicomData.IntenIntercept); + + //if lOffsetTablesRequired then begin + // dcmMsg('Image saved as 32-bit data: varying intensity scaling factors or complicated Pixel to Precise transform'); + + if (lRangeRA[kSS].min = lRangeRA[kSS].max) + and (lRangeRA[kRS].min = lRangeRA[kRS].max) + and (lRangeRA[kRI].min = lRangeRA[kRI].max) then + lRescaleEntries := 0 + else begin + lRescaleEntries := lSliceInfoCount; + getmem (lSlopeRA, lRescaleEntries*sizeof(single)); + getmem (lInterceptRA, lRescaleEntries*sizeof(single)); + if lOffsetTableEntries = lSliceInfoCount then begin //need to sort slices + setlength(lDTIraDynUnSorted,lSliceInfoCount+1);//+1 since indexed from zero + for lInc := 1 to lSliceInfoCount do + lDTIraDynUnSorted[lInc] := lDTIraDyn[lInc]; + for lInc := 1 to lSliceInfoCount do begin + lSlopeRA^[lInc] := lSlopeRAx[lOffset_pos_table^[lInc]]; + lInterceptRA^[lInc] := lInterceptRAx[lOffset_pos_table^[lInc]]; + lDTIraDyn[lInc] := lDTIraDynUnSorted[lOffset_pos_table^[lInc]]; + end; + end else begin //if sorted, else unsorted + for lInc := 1 to lSliceInfoCount do begin + lSlopeRA^[lInc] := lSlopeRAx[lInc]; + lInterceptRA^[lInc] := lInterceptRAx[lInc]; + end; + end; //slices sorted + end;//read scale factors + //Next: now adjust Offsets to point to byte offset instead of slice number + lSliceSz := lDicomData.XYZdim[1]*lDicomData.XYZdim[2]*(lDicomData.Allocbits_per_pixel div 8); + if lOffsetTableEntries = lSliceInfoCount then + for lInc := 1 to lSliceInfoCount do + lOffset_pos_table^[lInc] := lSliceSz * (lSliceIndexRAx^[lOffset_pos_table^[lInc]]); + //report if 5D/6D/7D file is being saved as 4D + if (lRangeRA[kCardiac].min <> lRangeRA[kCardiac].max) + or (lRangeRA[kEcho].min <> lRangeRA[kEcho].max) //5D file space+time+echo + or (lRangeRA[kType].min <> lRangeRA[kType].max) //5D file space+time+echo + or (lRangeRA[kSequence].min <> lRangeRA[kSequence].max) then begin//5D file space+time+echo + dcmMsg('Warning: note that this image has more than 4 dimensions (multiple Cardiac/Echo/Type/Sequence)'); + dcmMsg('Cardiac min..max '+floattostr(lRangeRA[kCardiac].min)+'..'+floattostr(lRangeRA[kCardiac].max) ); + dcmMsg('Echo min..max '+floattostr(lRangeRA[kEcho].min)+'..'+floattostr(lRangeRA[kEcho].max) ); + dcmMsg('Type min..max '+floattostr(lRangeRA[kType].min)+'..'+floattostr(lRangeRA[kType].max) ); + dcmMsg('Sequence min..max '+floattostr(lRangeRA[kSequence].min)+'..'+floattostr(lRangeRA[kSequence].max) ); + + end; + + + //if we get here, the Image Format is OK + lImageFormatOK := true; + lFileName := changefileextX(lFilename,'.rec'); //for Linux: case sensitive extension search '.rec' <> '.REC' + //next save dti b-values + if (lIsParVers42) and (lDicomData.XYZdim[4] <= kMaxDTIDir) and (lDicomData.XYZdim[4] > 1) then begin + + for lInc := 1 to lDicomData.XYZdim[4] do + lDTIra[lInc] := lDTIraDyn[(lDicomData.XYZdim[3]*(lInc-1))+1]; + //see if bval or bvec varies... + lInc := 1; + while (lInc <= lDicomData.XYZdim[4]) and (lDTIra[lInc].bval = lDTIra[1].bval) and (lDTIra[lInc].v1 = lDTIra[1].v1) do + inc(lInc); + //warn if untested orientation + if (lInc <= lDicomData.XYZdim[4]) and (lOrient <> 1) then + dcmMsg('WARNING: DTI vectors only tested for transsaxially oriented Philips data: bvec values may be inaccurate!'); + + (*if (lInc <= lDicomData.XYZdim[4]) then begin//bvec or bval vary + //# slice orientation ( TRA/SAG/COR ) (integer) + if lOrient <> 1 then + dcmMsg('WARNING: DTI vectors only tested for transsaxially oriented Philips data: bvec values may be inaccurate!'); + PhilipsCorrectBvecs(lDICOMdata, lDTIra, lDicomData.XYZdim[4]); + DTItextfiles (lFileName, lDTIra, lDicomData.XYZdim[4]); + end; *) +end else begin + //not DTI data - provide empty bvec/bval file + lDTIra[1].bval := 0; + lDTIra[1].v1 := 0; + lDTIra[1].v2 := 0; + lDTIra[1].v3 := 0; + for lInc := 1 to lDicomData.XYZdim[4] do + lDTIra[lInc] := lDTIra[1]; +end; +333: //abort clause: skips lHdrOK and lImageFormatOK + //next: free dynamically allocated memory + FreeMem( lCharRA); + FreeMem (lSliceSequenceRA); + Freemem(lSliceIndexRAx); +end; + + +(*function StudySecSince2KStr (lInSec: integer): string; +var + days,secs,Y,M,D,H,Min,S, l,n,i,j: integer; +begin + result := 'DateNA';//bogus + days := (lInSec div 86400)+2451547;//+2451547 as we convert to julian + //dcmMsg(inttostr(days)); + //next convert Y,M,D + l := days + 68569; + n := trunc(( 4 * l ) / 146097); + l := trunc(l - ( 146097 * n + 3 ) / 4); + i := trunc(( 4000 * ( l + 1 ) ) / 1461001); + l := trunc(l - ( 1461 * i ) / 4 + 31); + j := trunc(( 80 * l ) / 2447 ); + d := trunc(l - ( 2447 * j ) / 80); + l := trunc(j / 11); + m := j + 2 - ( 12 * l ); + y := 100 * ( n - 49 ) + i + l; + //next convert H,Min,Sec + if lInSec < 0 then begin//date prior to 2000 -saved as negative + secs := (lInSec - ( (lInSec div 86400)*86400)+86400) mod 86400 + end else + secs := lInSec mod 86400; //value 0..86399 + S := secs mod 60; + Min := (secs div 60) mod 60; + H := (secs div 3600)+1; + result := PadStr (Y, 4)+ PadStr (M, 2)+PadStr (D, 2)+'_'+PadStr (H, 2)+ PadStr (Min, 2)+PadStr (S, 2); +end;*) + +function UniqueFileName (var lInStr: string): boolean; +var + lInc: integer; + lPathWName,lExt: string; +begin + result := true; + if not Fileexists(lInStr) then exit; + ExtractFileParts(lInStr,lPathWName,lExt); + lInc := ord('A'); + while (lInc <= ord('Z')) and ( Fileexists(lPathWName+chr(lInc)+lExt)) do + inc(lInc); + if lInc > ord('Z') then + result := false + else + lInStr := lPathWName+chr(lInc)+lExt; +end; + +type +TiVec = array[1..3] of integer; +const + kSliceOrientTra = 1; + kSliceOrientSag = 2; + kSliceOrientCor = 3; + +procedure nifti_mat33_reorder_cols(var m: TMatrix; v: TiVec ) ; +var + inMat : TMatrix; + r,c: integer; +begin + // matlab equivalent ret = m(:, v); where v is 1,2,3 [INDEXED FROM ONE!!!!] + InMat := m; + for r := 1 to 3 do + for c := 1 to 3 do + m.matrix[r,c] := InMat.matrix[r,v[c]]; +//v[c] + +end; //nifti_mat33_reorder_cols() + +procedure computeOrient(var d: dicomdata; lSliceOrients: integer); +var + ang1, ang2,ang3: double; + ca, sa: TVector; + rx,ry,rz,R: TMatrix; + row,col: integer; + ixyz: TiVec; +begin + //see Xiangrui Li 's dicm2nii (also BSD license) + // http://www.mathworks.com/matlabcentral/fileexchange/42997-dicom-to-nifti-converter + // Rotation order and signs are figured out by try and err, not 100% sure + ang1 := d.AngulationRL; + ang2 := d.AngulationAP; + ang3 := d.AngulationFH; + ca := Vector3D(cos(DegToRad(ang1)),cos(DegToRad(ang2)),cos(DegToRad(ang3))); + sa := Vector3D(sin(DegToRad(ang1)),sin(DegToRad(ang2)),sin(DegToRad(ang3))); + + rx := Matrix2D(1.0, 0.0, 0.0, 0.0, ca.vector[1], -sa.vector[1], 0.0, sa.vector[1], ca.vector[1]); + ry := Matrix2D(ca.vector[2], 0.0, sa.vector[2], 0.0, 1.0, 0.0, -sa.vector[2], 0.0, ca.vector[2]); + rz := Matrix2D(ca.vector[3], -sa.vector[3], 0.0, sa.vector[3], ca.vector[3], 0.0, 0.0, 0.0, 1.0); + R := MultiplyMatrices(rx,ry ); + R := MultiplyMatrices(R,rz ); + //ReportMatrix('mult',R); + ixyz[1]:= 1; ixyz[2] := 2; ixyz[3] := 3; //axial slice order ijk = xyz + if (lSliceOrients = kSliceOrientSag) then begin//(d.sliceOrient == kSliceOrientSag) { + ixyz[1]:= 2; ixyz[2] := 3; ixyz[3] := 1; + for row := 1 to 3 do + for col := 1 to 3 do begin + if (col <> 2) then + R.matrix[row,col] := -R.matrix[row,col]; //invert first and final columns + end; + nifti_mat33_reorder_cols(R,ixyz); + end else if (lSliceOrients = kSliceOrientCor) then begin //(d.sliceOrient == kSliceOrientCor) { + ixyz[1]:= 1; ixyz[2] := 3; ixyz[3] := 2; + for row := 1 to 3 do + R.matrix[row,3] := -R.matrix[row,3]; + nifti_mat33_reorder_cols(R,ixyz); + end; + d.orient[1] := R.matrix[1,1]; d.orient[2] := R.matrix[2,1]; d.orient[3] := R.matrix[3,1]; + d.orient[4] := R.matrix[1,2]; d.orient[5] := R.matrix[2,2]; d.orient[6] := R.matrix[3,2]; + //ReportMatrix('x',R); + //dcmmsg(Format('v = %g %g %g %g %g %g', [d.Orient[1], d.Orient[2], d.Orient[3], d.Orient[4], d.Orient[5], d.Orient[6] ])) ; + end; + +function ConvertPhilipsPARtoAnalyze (var lInFilename, lOutDir: string; var lPrefs: TPrefs): boolean; +label + 678; +var + //lVaryingScaleFactorsTableEntries, + lEnd, lLines,lColBytes,lRows,lRowsdiv2,lSwap,lInc,l4Doffset,lcurrent4Dvol,lnum4Ddatasets,lSlicePixelsx, lnSlicesx, + lSliceSzOutx,lSLiceSzx,lRescaleEntries, lPos,lOffsetTableEntries,lSliceOrient: longint; + lOutF,lInF: File; + lNHdr,lAHdr: TNIFTIhdr; + lP,lBuffer : Bytep; + lFileName,lRECFilename,lOutImgName,lOutHdrName,lOutHdrNameGz,lDynStr,lOutDirPath: String; + lDICOMdata: dicomdata; + lScaleFactorVariesInThis4DVolume,lAbort,lHdrOK, lImageFormatOK: boolean; + lSlopeRA,lInterceptRA, + lSingleBuffer: Singlep; + lOffset_pos_table: LongIntp; + lDTIra: TDTIra; +begin + result := false; + lSliceOrient := kSliceOrientTra; + lFileName := lInFilename; + if (lOutDir = '') then + lOutDirPath := ExtractFilePath(lFileName)//ExtractFileDirWithPathDelim(lFilename)//ExtractFilePath(lFileName) + else if not direxists(lOutDir) then begin + dcmMsg('Unable to find output directory '+lOutDir); + lOutDirPath := ExtractFilePath(lFileName) + end else + lOutDirPath := lOutDir; + if (length(lOutDirPath) > 0) and (lOutDirPath[length(lOutDirPath)] <> pathdelim) then + lOutDirPath := lOutDirPath + pathdelim; + lAbort := false; + lRecFilename :=ChangeFileExt(lFileName,'.rec'); + dcmMsg('input name '+ lInFilename); + dcmMsg('input REC name '+lRecFilename); + //Apr08 problems with filenames with . in them lRecFilename :=ExtractFilePath(lFileName)+ParseFileName(ExtractFileName(lFileName))+'.rec'; + if not fileexists(lRecFilename) then //might be Linux: case sensitive extensions + lRecFilename :=ChangeFileExt(lFileName,'.REC'); + // lRecFilename :=ExtractFilePath(lFileName)+ParseFileName(ExtractFileName(lFileName))+'.REC'; + if not fileexists(lRecFilename) then + dcmMsg('Unable to find REC image data file named '+lRecFileName) + else if fileexists(lRecFilename) and fileexists(lFilename) then begin //convert + read_par2NII(lNHdr,lDICOMdata,lHdrOK,lImageFormatOK,lPRefs.PhilipsPrecise, lDynStr,lFileName,true,lOffset_pos_table,lOffsetTableEntries,lRescaleEntries, lSlopeRA,lInterceptRA,lnum4Ddatasets,lSliceOrient,lDTIra); + if (lnum4Ddatasets > 1) and ((lDicomData.XYZdim[4] mod lnum4Ddatasets) = 0) then //break 5D files into separate 4D files + lDicomData.XYZdim[4] := lDicomData.XYZdim[4] div lnum4Ddatasets + else + lnum4Ddatasets := 1; + lRows := lDicomData.XYZdim[2]; + lRowsdiv2 := lRows div 2; + lColBytes := lDicomData.XYZdim[1]*(lDicomData.Allocbits_per_pixel div 8); + lSlicePixelsx := (lDicomData.XYZdim[1]*lDicomData.XYZdim[2]); + lSliceSzx := lSlicePixelsx*(lDicomData.Allocbits_per_pixel div 8); + lnSlicesx := lDicomData.XYZdim[3] * lDicomData.XYZdim[4]; + lcurrent4Dvol := 0; + l4DOffset := 0; + // exit; //crucial critical test exit + if lHdrOK then begin + repeat //for each 4D volume + inc(lcurrent4Dvol); + lOutHdrName :=lOutDirPath+{Pathdelim+}OutputFilename(lRecFilename,lDicomData,lPrefs);//Pathdelim 11/2007 + if lnum4Ddatasets > 1 then begin + l4DOffset := (lcurrent4Dvol-1)* lnSlicesx; + lOutHdrName :=(lOutHdrName)+'x'+inttostr(lcurrent4Dvol)+'.hdr' + end else + lOutHdrName :=(lOutHdrName)+'.hdr'; + lOutImgName :=changefileext(lOutHdrName,'.img'); + if lPrefs.SingleNIIFile then begin + lOutHdrName := changefileext(lOutHdrName,'.nii'); + lOutImgName := lOutHdrName; + end; + if (lPrefs.SingleNIIFile) and (lPrefs.GZip) then begin + lOutHdrNameGz := lOutHdrName+'.gz'; + if (not UniqueFileName(lOutHdrNameGz)) then begin + dcmMsg('File already exists '+lOutImgName+' '+lOutHdrNameGz); + exit; + end; + + //we now need to remove the .gz - not that unique filename may have appended postfix, e.g. filename.nii.gz -> filenameA.nii.gz + //StripGZExt(lOutHdrName); + lOutImgName := lOutHdrName; + end else begin + if (not UniqueFileName(lOutHdrName)) or (not UniqueFileName(lOutImgName)) then begin + dcmMsg('File already exists '+lOutImgName+' '+lOutHdrName); + exit; + end; + end; + dcmMsg(lFileName+' -> '+ lOutImgName); + //exit; //trap + if (lDicomData.XYZdim[4] > 5) then begin //if 4D: save DTI data + lInc := 1; + while (lInc <= lDicomData.XYZdim[4]) and (lDTIra[lInc].bval = lDTIra[1].bval) and (lDTIra[lInc].v1 = lDTIra[1].v1) do + inc(lInc); + lEnd := 0; + if (lInc <= lDicomData.XYZdim[4]) then begin//bvec or bval vary + for linc := 1 to lDicomData.XYZdim[4] do + if (lDTIra[lInc].bval = 0) or (lDTIra[lInc].v1 <> 0) or (lDTIra[lInc].v2 <> 0) or (lDTIra[lInc].v3 <> 0) then + lEnd := lInc; + if (lEnd = (lDicomData.XYZdim[4]-1)) then begin + dcmMsg('Warning: final volume is computed ADC and will not be converted (as it would disrupt processing). You can re-create a better ADC image after eddy current correction.'); + lDicomData.XYZdim[4] := lEnd; + end; + computeOrient(lDICOMData,lSliceOrient); + siemensPhilipsCorrectBvecs(lDICOMdata, lDTIra, lDicomData.XYZdim[4], false); + DTItextfiles (lOutImgName, lDTIra, lDicomData.XYZdim[4]); + end; + end; //if 4D: save DTI data + + {$IFDEF LINUX} + //perhaps the file is .REC, not .rec + if (lSliceSzx * lnSLicesx) > FSize(lFileName) then + lRecFilename := changefileext(lFileName,'.REC'); + {$ENDIF} + if (lSliceSzx * lnSLicesx) > FSize(lRecFilename) then begin + + dcmMsg('Conversion error: the REC file '+lRecFilename+ ' is not as large as described by the PAR file X*Y*Z*T*BytesPerPixel=' + + inttostr(lDicomData.XYZdim[1])+'*'+inttostr(lDicomData.XYZdim[2])+'*'+inttostr(lDicomData.XYZdim[3])+'*'+inttostr(lDicomData.XYZdim[4])+'*'+inttostr(lDicomData.Allocbits_per_pixel div 8) + +' = '+ inttostr(lSliceSzx* lnSLicesx)+' <> '+inttostr(FSize(lFileName)) ); + {$IFDEF LINUX} + dcmMsg(' Suggestion: in UNIX .REC and .rec are different files - check file extension' ); + {$ENDIF} + lAbort := true; + end else if ((sizeof(TNIFTIhdr)+(lSliceSzx*lnSlicesx))> DiskFreeEx(lOutImgName)) then begin + dcmMsg('There is not enough free space on the destination disk to save the converted image. '+kCR+ + lOutImgName+ kCR+' Bytes Required: '+inttostr(sizeof(TNIFTIhdr)+(lSliceSzx*lnSlicesx)) ); + lAbort := true; + end else if fileexists(lOutHdrName) or fileexists(lOutImgName) then + dcmMsg('Unable to convert images: file already exists named: '+lOutHdrName) + else if (not lHdrOK) then + dcmMsg('Problem with header...') + else if (not lImageFormatOK) then + dcmMsg('Problem with image...') + + else if (lHdrOK) and (lImageFormatOK) and (lDicomData.XYZdim[3] > 0) and (lSliceSzx > 0) then begin + DICOM2AnzHdr(lAHdr,lPrefs.Anonymize,lFilename,lDICOMdata); + lSliceSzOutx := lSliceSzx; + lScaleFactorVariesInThis4DVolume := false; + //check if 4D scale slope changes for this 4D dataset... + if lRescaleEntries > 0 then begin + lAHdr.scl_slope := lSlopeRA^[l4DOffset+1]; + lAHdr.scl_inter := lInterceptRA^[l4DOffset+1]; + + if lRescaleEntries > 0 then begin + for lInc := 1 to lnSlicesx do begin + if lAHdr.scl_slope <> lSlopeRA^[l4DOffset+lInc] then + lScaleFactorVariesInThis4DVolume := true; + if lAHdr.scl_inter <> lInterceptRA^[l4DOffset+lInc] then + lScaleFactorVariesInThis4DVolume := true; + end; + end; + if lScaleFactorVariesInThis4DVolume then begin + lAHdr.bitpix := 32; + lAHdr.DataType := 16; + lAHdr.scl_slope := 1; + lAHdr.scl_inter := 0; + lSliceSzOutx := lSlicePixelsx*sizeof(single); + end; + end; + //end of 4D scale factor variation... + lAHdr.sform_code := lNHdr.sform_code; + lAHdr.srow_x[0] := lNHdr.srow_x[0]; + lAHdr.srow_x[1] := lNHdr.srow_x[1]; + lAHdr.srow_x[2] := lNHdr.srow_x[2]; + lAHdr.srow_x[3] := lNHdr.srow_x[3]; + lAHdr.srow_y[0] := lNHdr.srow_y[0]; + lAHdr.srow_y[1] := lNHdr.srow_y[1]; + lAHdr.srow_y[2] := lNHdr.srow_y[2]; + lAHdr.srow_y[3] := lNHdr.srow_y[3]; + lAHdr.srow_z[0] := lNHdr.srow_z[0]; + lAHdr.srow_z[1] := lNHdr.srow_z[1]; + lAHdr.srow_z[2] := lNHdr.srow_z[2]; + lAHdr.srow_z[3] := lNHdr.srow_z[3]; + lAHdr.qform_code := lNHdr.qform_code; + lAHdr.quatern_b := lNHdr.quatern_b; + lAHdr.quatern_c := lNHdr.quatern_c; + lAHdr.quatern_d := lNHdr.quatern_d; + lAHdr.qoffset_x := lNHdr.qoffset_x; + lAHdr.qoffset_y := lNHdr.qoffset_y; + lAHdr.qoffset_z := lNHdr.qoffset_z; + lAHdr.pixdim[0] := lNHdr.pixdim[0]; + {$IFDEF ENDIAN_BIG} + if SaveHdr (lOutHdrName,lAHdr, true,lPrefs.SPM2) then begin + {$ELSE} + if SaveHdr (lOutHdrName,lAHdr, false,lPrefs.SPM2) then begin + {$ENDIF} + Filemode := 2;//1385: read-write + AssignFile(lOutF, lOutImgName); + if lPrefs.SingleNIIFile then begin + Reset(lOutF,1); + Seek(lOutF,352); + lAHdr.vox_offset := 352; + end else + Rewrite(lOutF,1); //setting block size only about 12% speed increase: HD cache must help + Filemode := 0;//1385: read-only + AssignFile(lInF, lRecFilename); + Reset(lInF,lSliceSzx); + GetMem(lBuffer,lSliceSzx); + if lScaleFactorVariesInThis4DVolume then + GetMem(lSingleBuffer,lSliceSzOutx); + for lInc := 1 to lnSlicesx do begin + //application.ProcessMessages; + if lOffsetTableEntries > 1 then //data not contiguous + Seek(lInF, (lOffset_pos_table^[lInc+l4DOffset] div lSliceSzx)) + else + Seek(lInF, (l4DOffset+lInc-1)); + Filemode := 0; //ReadONly + BlockRead(lInF, lBuffer^, 1); + Filemode := 2; //read and write + GetMem ( lP , lColBytes); + for lLines := 1 to lRowsdiv2 do begin + Move(lBuffer[((lLines-1)*lColBytes)+1],lP^,lColBytes); + Move(lBuffer[(( lRows-lLines)*lColBytes)+1],lBuffer[((lLines-1)*lColBytes)+1],lColBytes); + Move(lP^,lBuffer[(( lRows-lLines)*lColBytes)+1],lColBytes); + end; + FreeMem(lP); + if lScaleFactorVariesInThis4DVolume then begin + if lDicomData.Allocbits_per_pixel = 8 then begin + for lLines := 1 to lSlicePixelsx do + lSingleBuffer^[lLines] := lBuffer^[lLines]*lSlopeRA^[l4DOffset+lInc]+lInterceptRA^[l4DOffset+lInc]; + end else if lDicomData.Allocbits_per_pixel = 16 then begin + lPos := 1; + for lLines := 1 to lSlicePixelsx do begin + lSingleBuffer^[lLines] := lBuffer^[lLines]*lSlopeRA^[l4DOffset+lInc]+lInterceptRA^[l4DOffset+lInc]; + //lSingleBuffer^[lLines] := lBuffer^[lPos]*lRS+lRI; + inc(lPos,2); + end; + end else + dcmMsg('Error: can only convert 8/16bit PAR/REC files with varying scaling values.'); + BlockWrite(lOutF, lSingleBuffer^, lSliceSzOutx); + end else + BlockWrite(lOutF, lBuffer^, lSliceSzOutx); + end; + CloseFile(lOutF); + CloseFile(lInF); + freemem(lBuffer); + if lScaleFactorVariesInThis4DVolume then + FreeMem(lSingleBuffer); + end else + lAbort := true; //save header failed: probably read only disk, or less than 348 bytes: do not force inidividual to see message for each file + //if (lPrefs.StartClip > 0) or (lPrefs.EndClip > 0) then + // Clip4D(lOutHdrName, lAHdr, false,lPrefs.SPM2,lPrefs.SingleNIIFile,lPrefs.GZip,true, lPrefs.StartClip,lPrefs.EndClip); + (*if (not lPrefs.FourD) and (lAHdr.dim[4] > 1) then begin + Convert4Dto3D(lOutImgName, lAHdr, false,lPrefs.SPM2,lPrefs.SingleNIIFile, lPrefs.Gzip); + end else*) + if lPrefs.SingleNIIFile and lPrefs.Gzip then + GZipFile(lOutImgName,lOutImgName+'.gz',true) + else if ((not lPrefs.FourD) and (lAHdr.dim[4] > 1)) {or ((lPrefs.SingleNIIFile) and (lPrefs.Gzip))} then + if ChangeNIfTISubformat(lOutImgName, lAHdr,lPrefs) then begin + deleteFile(lOutImgName);//11/2007 : delete original + end; + end; //file OK + + + until (lcurrent4Dvol>=lnum4Ddatasets) or (lAbort); //for each 4D dataset + end; //lHdrOK + if lOffsetTableEntries > 0 then begin + freemem (lOffset_pos_table); + lOffsetTableEntries := 0; + end; //slice offset table filled + if lRescaleEntries > 0 then begin + freemem ( lSlopeRA); + freemem (lInterceptRA); + end; //slice offset table filled +end; //REC exists + if lAbort then goto 678; + result := true; + ExitCode := 0; + if (lDicomData.XYZdim[2] > lPrefs.MinReorientMatrix) and (lDicomData.XYZdim[1] > lPrefs.MinReorientMatrix) and (lAHdr.dim[4] < 2) then begin + lOutImgName := Reorient(lOutImgName,lAHdr,lPrefs,false,false); + if (lOutImgName <> '') {success}and (lDicomData.TE < 25) then //T1 image + CropNIfTI(lOutImgName,lPrefs); + end; + + 678: + Filemode := 2; //1385 +end; + +function LoadFileListPARREC (var lInFilename, lOutDir: string; var lPrefs: TPrefs): boolean; +var + lFilePath,lMaskExt,lPARname,lOutDirName: String; + lError: boolean; + lSearchRec: TSearchRec; +begin + lOutDirName := lOutDir; + if (lPrefs.OutDirMode <> kOutDirModeInput) and (DirExists(lPrefs.OutDir)) then begin + //For kOutDirModePrompt one should set OutDir before getting here + //This is required so recursive searches do not repetitively prompt the user... + lOutDirName := lPrefs.OutDir; + end; //1/2010 + lOutDirName := ExtractFileDirWithPathDelim(lOutDirName); + if not DirWritePermission(lOutDirName) then begin // <- tested with Unix + dcmMsg('Error: output directory is read-only: '+lOutDirName); + exit; + end; + lError := false; + if lPrefs.EveryFile = true then begin + lFilePath := ExtractFileDirWithPathDelim(lInFilename); + {$IFDEF Linux} + lMaskExt := '*'; + {$ELSE} + lMaskExt := '*.*'; + {$ENDIF} + Filemode := 0; //readonly + if FindFirst(lFilePath{+PathDelim}+lMaskExt, faAnyFile-faSysFile-faDirectory, lSearchRec) = 0 then begin + repeat + if UpCaseExt(lSearchRec.Name) = '.PAR' then begin + lPARname := (lFilePath+lSearchRec.Name); + result := ConvertPhilipsPARtoAnalyze(lPARname, lOutDirName, lPrefs); + if not result then + lError := true; + end; + until (FindNext(lSearchRec) <> 0); + end else + dcmMsg( 'Error: Unable to find PAR files in '+lFilePath{+PathDelim}+lMaskExt); //some files found + SysUtils.FindClose(lSearchRec); + Filemode := 2; + end else begin + if FileExists(lInFilename) then begin + lError := ConvertPhilipsPARtoAnalyze(lInFilename, lOutDirName, lPrefs); + end else + dcmMsg( 'Unable to find PAR file named '+lInFilename); //some files found + end; + if lError then + result := false //at least one error + else + result := true; +end; + +end. + diff --git a/dcm2nii/parconvert.ppu b/dcm2nii/parconvert.ppu new file mode 100644 index 0000000..6be0589 Binary files /dev/null and b/dcm2nii/parconvert.ppu differ diff --git a/dcm2nii/philips_bvec_old.pas b/dcm2nii/philips_bvec_old.pas new file mode 100755 index 0000000..4189b0b --- /dev/null +++ b/dcm2nii/philips_bvec_old.pas @@ -0,0 +1,252 @@ +unit philips_bvec; +{$ifdef fpc}{$mode delphi}{$endif} +{$H+} +interface +uses + //StrUtils, + Classes, SysUtils, define_types, dicomtypes, dialogsx,GraphicsMathLibrary,dialogs_msg; +//{$DEFINE VERBOSE_BVEC} + + +procedure PhilipsCorrectBvecs(var lDICOMdata:dicomdata; var lDTIra: TDTIRA; nVec: integer); + +implementation + +procedure ReportMatrix(s: string; q: TMatrix); +begin + dcmmsg(s+Format('=[ %g %g %g %g; %g %g %g %g; %g %g %g %g; 0 0 0 1]', [ + q.matrix[1,1],q.matrix[1,2],q.matrix[1,3],q.matrix[1,4] , + q.matrix[2,1],q.matrix[2,2],q.matrix[2,3],q.matrix[2,4] , + q.matrix[3,1],q.matrix[3,2],q.matrix[3,3],q.matrix[3,4]])); +end; + + +//Next routines for PhilipsBVec + FUNCTION Vector2D (CONST xValue, yValue, zValue: DOUBLE): TVector; + BEGIN + WITH RESULT DO + BEGIN + x := xValue; + y := yValue; + z := zValue; + size := size2D + END + END; //Vector2D + + // Assume vector contains 'extra' homogeneous coordinate -- ignore it. + procedure NormalizeVector2D(var u: TVector); + var + lSum: double; + BEGIN + lSum := sqrt((u.x*u.x)+(u.y*u.y)+(u.z*u.z)); + if lSum <> 0 then + u := Vector2D( u.x/lSum, + u.y/lSum, + u.z/lSum) + END; //NormalizeVector2D + +FUNCTION revMat (CONST Input:TMatrix): TMatrix;//Transpose Matrix +var + i,j: integer; +begin + result.size := Input.size; + for i := 1 to Input.size do + for j := 1 to Input.size do + result.matrix[i,j] := input.matrix[j,i]; +end; + + + FUNCTION VecMatMult (CONST u: TVector; CONST a: TMatrix): TVector; + VAR + i,k : TIndex; + temp: DOUBLE; + BEGIN + RESULT.size := a.size; + IF a.size = u.size + THEN BEGIN + FOR i := 1 TO a.size DO + BEGIN + temp := 0.0; + FOR k := 1 TO a.size DO + BEGIN + temp := temp + u.vector[k]*a.matrix[i,k]; + END; + RESULT.vector[i] := Defuzz(temp) + END; + END + ELSE raise EMatrixError.Create('VecMatMult error') + END;//VecMatMult + + +procedure PhilipsCorrectBvecs(var lDICOMdata:dicomdata; var lDTIra: TDTIRA; nVec: integer); +//Test lIn.x := 0.499997615814209; lIn.y := 0.499997615814209; lIn.z := 0.707110166549683; +//Philips DICOM data stored in patient (LPH) space, regardless of settings in Philips user interface +//algorithm inspired by CATNAP http://godzilla.kennedykrieger.org/~jfarrell/software_web.htm +//http://iacl.ece.jhu.edu/~bennett/catnap/catnap.shtml +//0018,5100. patient orientation - 'HFS' +//2001,100B Philips slice orientation (TRANSVERSAL, AXIAL, SAGITTAL) +//2005,1071. Philips AP angulation : -8.74086 +//2005,1072. Philips FH angulation : -3.53147 +//2005,1073. Philips RL angulation -0.387372 +(* 3/2008: updated to correct for a bug in the Johns Hopkins code: +% July 20, 2007 | I corrected a small bug with the rotation matrices for +% slice angulation. I had multiplied 3 matrices in the incorrect order. + +% A colleague (Harsh Agarwal) pointed this out while aligning different +% MRI contrasts using the angulation parameters and the transformation +% matrices given in the Philips document. +%I originally had Tang = Tfh*Tap*Trl +% which is now Tang = Trl*Tap*Tfh; +%I originally had rev_Tang = rev_Trl*rev_Tap*rev_Tfh; +%which is now rev_Tang = rev_Tfh*rev_Tap*rev_Trl; +% I double checked the Philips code and this seems to be correct now. +% I also double checked the impact on fiber tracking. The fiber tracking +% looks good in both instances (even though the gradient tables are +% slightly different). If 2 angulation values are zero (i.e. [AP,FH,RL] += +% [0,0,20], then the old and new equations give the same result. Only +if +% two or more elements are non zero is the result different. I did some +% testing with very large angulations of 20 degrees [20,20,0], [20,0,20] + +% and [0,20,20]and found that the fiber tracking results were almost +% indistinguishable. THIS FIX ONLY affects yes overplus and +% user-defined gradient tables. No overplus tables are not subject to +% slice angulation changes +*) + +var + lIn,lOut: TVector; + ltpp,lrev_tpp,ltpom,lrev_tpom,ltpo,lrev_tpo,ltrl,ltap,ltfh, + lmtemp1,lmtemp2 ,ltang,lrev_tang, + lrev_trl, lrev_tap, lrev_tfh, + lrev_tsom,ldtiextra: TMatrix; + lI: Integer; + lap,lfh,lrl: double; +begin + + if nVec < 1 then exit; + //require HFS - head first supine. See Catnap for alternate body orientations + // and (lDicomData.PatientPos[1] = 'H') and (lDicomData.PatientPos[2] = 'F') and (lDicomData.PatientPos[3] = 'S') then + if (length(lDicomData.PatientPos) < 3) then begin + //HFS = head-first supine + dcmMsg('DTI vector error: Position is not head first supine'); + exit; + end; + if (lDicomData.PatientPos[1] = 'F') and (lDicomData.PatientPos[2] = 'F') then begin//strcmpi(patient_position,'ff') + ltpp := Matrix2D (0,-1,0, -1,0,0, 0,0,1); + //rev_Tpp = [0,-1,0;-1,0,0;0,0,-1]; + end else if (lDicomData.PatientPos[1] = 'H') and (lDicomData.PatientPos[2] = 'F') then begin//strcmpi(patient_position,'hf') + ltpp := Matrix2D (0,1,0,-1,0,0, 0,0,-1); + //rev_Tpp = [0,-1,0;1,0,0;0,0,-1]; + end else begin + dcmMsg('DTI vector error: images must be HF or FF (head or feet first) '+lDicomData.PatientPos); + exit; + end; + lrev_tpp := revMat(ltpp); + +(* http://www.dabsoft.ch/dicom/3/C.7.3.1.1.2/ +see matlab code http://godzilla.kennedykrieger.org/~jfarrell/software_web.htm#PARtoNRRD +HFP = Head First-Prone +HFS = Head First-Supine +HFDR = Head First-Decubitus Right +HFDL = Head First-Decubitus Left +FFDR = Feet First-Decubitus Right +FFDL = Feet First-Decubitus Left +FFP = Feet First-Prone +FFS = Feet First-Supine +*) + if lDicomData.PatientPos[3] = 'S' then begin//supine + ltpo := Matrix2D (1,0,0, 0,1,0, 0,0,1); + //rev_Tpo = [1,0,0;0,1,0;0,0,1]; + end else if lDicomData.PatientPos[3] = 'P' then begin //prone + ltpo := Matrix2D (-1,0,0, 0,-1,0, 0,0,1); + //rev_Tpo = [-1,0,0;0,-1,0;0,0,1]; + end else if (length(lDicomData.PatientPos) > 3) and (lDicomData.PatientPos[3] = 'D') and (lDicomData.PatientPos[4] = 'R') then begin //rd + ltpo := Matrix2D (0,-1,0, 1,0,0, 0,0,1); + //rev_Tpo = [0,1,0;-1,0,0;0,0,1]; + end else if (length(lDicomData.PatientPos) > 3) and (lDicomData.PatientPos[3] = 'D') and (lDicomData.PatientPos[4] = 'L') then begin //ld + ltpo := Matrix2D (0,1,0, -1,0,0, 0,0,1); + //rev_Tpo = [0,-1,0;1,0,0;0,0,1]; + end else begin + dcmMsg('DTI vector error: Position is not HFS,HFP,HFDR,HFDL,FFS,FFP,FFDR, or FFDL: '+lDicomData.PatientPos); + exit; + end; + lrev_tpo := revMat(ltpo); + dcmMsg('Reorienting vectors for patient position ('+lDicomData.PatientPos+'). Please validate if you conduct DTI processing.'); + + (* + //Assume supine + ltpo := Matrix2D (1,0,0, 0,1,0, 0,0,1 ); + lrev_tpo := revMat(ltpo); + //Assume head first + ltpp := Matrix2D (0,1,0, -1,0,0, 0,0,-1); + lrev_tpp := revMat(ltpp); *) + ltpom := MultiplyMatrices( ltpo, ltpp); + lrev_tpom := MultiplyMatrices( lrev_tpp,lrev_tpo ); + lap := lDicomData.AngulationAP * PI /180; + lfh := lDicomData.AngulationFH * PI /180; + lrl := lDicomData.AngulationRL * PI /180; + {$IFDEF VERBOSE_BVEC} + dcmmsg('ap/fh/rl'+kTab+floattostr(lDicomData.AngulationAP)+kTab+floattostr(lDicomData.AngulationFH)+kTab+floattostr(lDicomData.AngulationRL)); + for lI := 1 to nVec do + dcmmsg(inttostr(lI)+ kTab+floattostr(lDTIra[lI].bval)+kTab+floattostr(lDTIra[lI].v1)+kTab+floattostr(lDTIra[lI].v2)+kTab+floattostr(lDTIra[lI].v3)); + + {$ENDIF} + //lAP:=-0.152557; lFH:=-0.0616358; lRL := -0.00676092; + //dcmmsg('ap/fh/rl'+kTab+floattostr(lap)+kTab+floattostr(lfh)+kTab+floattostr(lrl)); + + ltrl := Matrix2D (1,0,0, 0,cos(lrl),-sin(lrl), 0,sin(lrl),cos(lrl)); + ltap := Matrix2D (cos(lap),0,sin(lap), 0,1,0, -sin(lap),0,cos(lap)); + ltfh := Matrix2D (cos(lfh),-sin(lfh),0, sin(lfh),cos(lfh),0, 0,0,1); + lrev_trl := revMat(ltrl); + lrev_tap := revMat(ltap); + lrev_tfh := revMat(ltfh); + lmtemp1 := MultiplyMatrices( ltrl, ltap ); + + ltang := MultiplyMatrices( lmtemp1, ltfh ); + lmtemp1 := MultiplyMatrices( lrev_tfh, lrev_tap ); + lrev_tang := MultiplyMatrices( lmtemp1, lrev_trl ); + + if (lDicomData.PhilipsSliceOrient[1] = 'S') then //SAGITTAL + lrev_tsom := Matrix2D (0,0,1, 0,-1,0, -1,0,0 ) + else if (lDicomData.PhilipsSliceOrient[1] = 'C') then //CORONAL + lrev_tsom := Matrix2D (0,0,1, -1,0,0, 0,1,0 ) + else //TRANSVERSAL = AXIAL + lrev_tsom := Matrix2D (0,-1,0, -1,0,0, 0,0,1 ); + ldtiextra := Matrix2D (0,-1,0, -1,0,0, 0,0,1 ); + lmtemp2 := MultiplyMatrices( ldtiextra, lrev_tsom ); + lmtemp1 := MultiplyMatrices (lmtemp2, lrev_tang); + ReportMatrix('lmtemp1',lmtemp1); + + for lI := 1 to nVec do begin + {$IFDEF VERBOSE_BVEC} + //dcmmsg(realtostr(lDTIra[lI].v1,5)+kTab+realtostr(lDTIra[lI].v2,5)+kTab+realtostr(lDTIra[lI].v3,5) ); + + {$ENDIF} + if (lDTIra[lI].bval <= 0) or ((lDTIra[lI].v1 = 0) and (lDTIra[lI].v2 = 0) and (lDTIra[lI].v3 = 0)) then begin + lDTIra[lI].v1 := 0; + lDTIra[lI].v2 := 0; + lDTIra[lI].v3 := 0; + end else begin + //lIn := Vector2D(0.7071, -0.7071, -0.0000); + lIn := Vector2D(-lDTIra[lI].v1,-lDTIra[lI].v2,-lDTIra[lI].v3); + NormalizeVector2D(lIn); + lout := VecMatMult (lin,lmtemp1); + NormalizeVector(lout); + lDTIra[lI].v1 := lOut.x; + lDTIra[lI].v2 := lOut.y; + {2014: dcm2nii flips physically images in AP direction, so do not change sign + if lOut.y = 0 then + lDTIra[lI].v2 := lOut.y //people dislike seeing -0 + else + lDTIra[lI].v2 := -lOut.y; //flip Y component + } + lDTIra[lI].v3 := lOut.z; + end; + end; //for each vector + dcmmsg('Note: dcm2nii since 2014 flips sign of DTI y-component for FSL tools. Please validate for yur system.'); +end; + +end. + diff --git a/dcm2nii/pref_form.dfm b/dcm2nii/pref_form.dfm new file mode 100755 index 0000000..7bf0b0c Binary files /dev/null and b/dcm2nii/pref_form.dfm differ diff --git a/dcm2nii/pref_form.lfm b/dcm2nii/pref_form.lfm new file mode 100755 index 0000000..918de0e --- /dev/null +++ b/dcm2nii/pref_form.lfm @@ -0,0 +1,197 @@ +object PrefsForm: TPrefsForm + Left = 466 + Height = 332 + Top = 176 + Width = 600 + HorzScrollBar.Page = 463 + VertScrollBar.Page = 323 + ActiveControl = DateCheck + BorderIcons = [biSystemMenu] + Caption = 'Preferences' + ClientHeight = 332 + ClientWidth = 600 + Constraints.MaxHeight = 332 + Constraints.MaxWidth = 600 + Constraints.MinHeight = 332 + Constraints.MinWidth = 600 + Position = poDesktopCenter + LCLVersion = '1.0.12.0' + object Label1: TLabel + Left = 112 + Height = 17 + Top = 200 + Width = 188 + Caption = 'Recursive folder search depth' + ParentColor = False + end + object OutDirLabel: TLabel + Left = 16 + Height = 17 + Top = 264 + Width = 19 + Caption = 'c:\' + ParentColor = False + end + object FilenameBox: TGroupBox + Left = 8 + Height = 176 + Top = 8 + Width = 232 + Caption = 'Output Filename' + ClientHeight = 154 + ClientWidth = 224 + TabOrder = 0 + object DateCheck: TCheckBox + Left = 22 + Height = 18 + Top = 8 + Width = 124 + Caption = 'Acquisition Date' + OnChange = FilenameChecks + TabOrder = 0 + end + object InputNameCheck: TCheckBox + Left = 22 + Height = 18 + Top = 33 + Width = 114 + Caption = 'Input Filename' + OnChange = FilenameChecks + TabOrder = 1 + end + object ProtocolCheck: TCheckBox + Left = 22 + Height = 18 + Top = 57 + Width = 113 + Caption = 'Protocol Name' + OnChange = FilenameChecks + TabOrder = 2 + end + object PatientNameCheck: TCheckBox + Left = 22 + Height = 18 + Top = 81 + Width = 104 + Caption = 'Patient Name' + OnChange = FilenameChecks + TabOrder = 3 + end + object SeriesCheck: TCheckBox + Left = 22 + Height = 18 + Top = 105 + Width = 131 + Caption = 'Acquisition Series' + OnChange = FilenameChecks + TabOrder = 4 + end + end + object OKbtn: TButton + Left = 488 + Height = 25 + Top = 288 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + ModalResult = 1 + TabOrder = 1 + end + object CancelBtn: TButton + Left = 400 + Height = 25 + Top = 288 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 2 + end + object NotAnonymizeCheck: TCheckBox + Left = 248 + Height = 18 + Top = 24 + Width = 233 + Caption = 'Save patient name in NIfTI header' + TabOrder = 3 + end + object ReorientCheck: TCheckBox + Left = 248 + Height = 18 + Top = 88 + Width = 336 + Caption = 'Reorient large images to nearest orthogonal plane' + TabOrder = 4 + end + object RecursiveSpin: TSpinEdit + Left = 16 + Height = 16 + Top = 200 + Width = 77 + MaxValue = 10 + TabOrder = 5 + end + object OutputCombo: TComboBox + Left = 16 + Height = 20 + Top = 232 + Width = 296 + ItemHeight = 0 + Items.Strings = ( + 'Save to source folder' + 'Prompt user for output folder' + 'Always save to...' + ) + OnChange = OutputComboChange + OnMouseUp = OutputComboMouseUp + Style = csDropDownList + TabOrder = 6 + end + object CollapseCheck: TCheckBox + Left = 248 + Height = 18 + Hint = 'Sort images regardless of source directory. Slower, required if series segmented across folders' + Top = 120 + Width = 121 + Caption = 'Collapse folders' + TabOrder = 7 + end + object Stack3DImagesWithSameAcqNum: TCheckBox + Left = 248 + Height = 18 + Hint = 'Sort images regardless of source directory. Slower, required if series segmented across folders' + Top = 152 + Width = 314 + Caption = 'Stack 3D images with same acquistion number' + TabOrder = 8 + end + object TextEditorBtn: TButton + Left = 8 + Height = 25 + Top = 288 + Width = 123 + BorderSpacing.InnerBorder = 4 + Caption = 'Text Edit' + OnClick = TextEditorBtnClick + TabOrder = 9 + end + object WritePrefsOnQuit: TCheckBox + Left = 390 + Height = 18 + Top = 120 + Width = 138 + Caption = 'Write prefs on quit' + Checked = True + State = cbChecked + TabOrder = 10 + Visible = False + end + object TxtReportCheck: TCheckBox + Left = 248 + Height = 18 + Top = 56 + Width = 282 + Caption = 'Save text report (scan and patient details)' + TabOrder = 11 + end +end diff --git a/dcm2nii/pref_form.lrs b/dcm2nii/pref_form.lrs new file mode 100755 index 0000000..273f533 --- /dev/null +++ b/dcm2nii/pref_form.lrs @@ -0,0 +1,59 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TPrefsForm','FORMDATA',[ + 'TPF0'#10'TPrefsForm'#9'PrefsForm'#4'Left'#3#210#1#6'Height'#3'L'#1#3'Top'#3 + +#176#0#5'Width'#3'X'#2#18'HorzScrollBar.Page'#3#207#1#18'VertScrollBar.Page' + +#3'C'#1#13'ActiveControl'#7#9'DateCheck'#11'BorderIcons'#11#12'biSystemMenu' + +#0#7'Caption'#6#11'Preferences'#12'ClientHeight'#3'L'#1#11'ClientWidth'#3'X' + +#2#21'Constraints.MaxHeight'#3'L'#1#20'Constraints.MaxWidth'#3'X'#2#21'Const' + +'raints.MinHeight'#3'L'#1#20'Constraints.MinWidth'#3'X'#2#8'Position'#7#15'p' + +'oDesktopCenter'#10'LCLVersion'#6#8'1.0.12.0'#0#6'TLabel'#6'Label1'#4'Left'#2 + +'p'#6'Height'#2#17#3'Top'#3#200#0#5'Width'#3#188#0#7'Caption'#6#29'Recursive' + +' folder search depth'#11'ParentColor'#8#0#0#6'TLabel'#11'OutDirLabel'#4'Lef' + +'t'#2#16#6'Height'#2#17#3'Top'#3#8#1#5'Width'#2#19#7'Caption'#6#3'c:\'#11'Pa' + +'rentColor'#8#0#0#9'TGroupBox'#11'FilenameBox'#4'Left'#2#8#6'Height'#3#176#0 + +#3'Top'#2#8#5'Width'#3#232#0#7'Caption'#6#15'Output Filename'#12'ClientHeigh' + +'t'#3#154#0#11'ClientWidth'#3#224#0#8'TabOrder'#2#0#0#9'TCheckBox'#9'DateChe' + +'ck'#4'Left'#2#22#6'Height'#2#18#3'Top'#2#8#5'Width'#2'|'#7'Caption'#6#16'Ac' + +'quisition Date'#8'OnChange'#7#14'FilenameChecks'#8'TabOrder'#2#0#0#0#9'TChe' + +'ckBox'#14'InputNameCheck'#4'Left'#2#22#6'Height'#2#18#3'Top'#2'!'#5'Width'#2 + +'r'#7'Caption'#6#14'Input Filename'#8'OnChange'#7#14'FilenameChecks'#8'TabOr' + +'der'#2#1#0#0#9'TCheckBox'#13'ProtocolCheck'#4'Left'#2#22#6'Height'#2#18#3'T' + +'op'#2'9'#5'Width'#2'q'#7'Caption'#6#13'Protocol Name'#8'OnChange'#7#14'File' + +'nameChecks'#8'TabOrder'#2#2#0#0#9'TCheckBox'#16'PatientNameCheck'#4'Left'#2 + +#22#6'Height'#2#18#3'Top'#2'Q'#5'Width'#2'h'#7'Caption'#6#12'Patient Name'#8 + +'OnChange'#7#14'FilenameChecks'#8'TabOrder'#2#3#0#0#9'TCheckBox'#11'SeriesCh' + +'eck'#4'Left'#2#22#6'Height'#2#18#3'Top'#2'i'#5'Width'#3#131#0#7'Caption'#6 + +#18'Acquisition Series'#8'OnChange'#7#14'FilenameChecks'#8'TabOrder'#2#4#0#0 + +#0#7'TButton'#5'OKbtn'#4'Left'#3#232#1#6'Height'#2#25#3'Top'#3' '#1#5'Width' + +#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#2'OK'#11'ModalResult'#2 + +#1#8'TabOrder'#2#1#0#0#7'TButton'#9'CancelBtn'#4'Left'#3#144#1#6'Height'#2#25 + +#3'Top'#3' '#1#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#6 + +'Cancel'#11'ModalResult'#2#2#8'TabOrder'#2#2#0#0#9'TCheckBox'#17'NotAnonymiz' + +'eCheck'#4'Left'#3#248#0#6'Height'#2#18#3'Top'#2#24#5'Width'#3#233#0#7'Capti' + +'on'#6'!Save patient name in NIfTI header'#8'TabOrder'#2#3#0#0#9'TCheckBox' + +#13'ReorientCheck'#4'Left'#3#248#0#6'Height'#2#18#3'Top'#2'X'#5'Width'#3'P'#1 + +#7'Caption'#6'1Reorient large images to nearest orthogonal plane'#8'TabOrder' + +#2#4#0#0#9'TSpinEdit'#13'RecursiveSpin'#4'Left'#2#16#6'Height'#2#16#3'Top'#3 + +#200#0#5'Width'#2'M'#8'MaxValue'#2#10#8'TabOrder'#2#5#0#0#9'TComboBox'#11'Ou' + +'tputCombo'#4'Left'#2#16#6'Height'#2#20#3'Top'#3#232#0#5'Width'#3'('#1#10'It' + +'emHeight'#2#0#13'Items.Strings'#1#6#21'Save to source folder'#6#29'Prompt u' + +'ser for output folder'#6#17'Always save to...'#0#8'OnChange'#7#17'OutputCom' + +'boChange'#9'OnMouseUp'#7#18'OutputComboMouseUp'#5'Style'#7#14'csDropDownLis' + +'t'#8'TabOrder'#2#6#0#0#9'TCheckBox'#13'CollapseCheck'#4'Left'#3#248#0#6'Hei' + +'ght'#2#18#4'Hint'#6'_Sort images regardless of source directory. Slower, re' + +'quired if series segmented across folders'#3'Top'#2'x'#5'Width'#2'y'#7'Capt' + +'ion'#6#16'Collapse folders'#8'TabOrder'#2#7#0#0#9'TCheckBox'#27'Stack3DImag' + +'esWithSameAcqNum'#4'Left'#3#248#0#6'Height'#2#18#4'Hint'#6'_Sort images reg' + +'ardless of source directory. Slower, required if series segmented across fo' + +'lders'#3'Top'#3#152#0#5'Width'#3':'#1#7'Caption'#6'+Stack 3D images with sa' + +'me acquistion number'#8'TabOrder'#2#8#0#0#7'TButton'#13'TextEditorBtn'#4'Le' + +'ft'#2#8#6'Height'#2#25#3'Top'#3' '#1#5'Width'#2'{'#25'BorderSpacing.InnerBo' + +'rder'#2#4#7'Caption'#6#9'Text Edit'#7'OnClick'#7#18'TextEditorBtnClick'#8'T' + +'abOrder'#2#9#0#0#9'TCheckBox'#16'WritePrefsOnQuit'#4'Left'#3#134#1#6'Height' + +#2#18#3'Top'#2'x'#5'Width'#3#138#0#7'Caption'#6#19'Write prefs on quit'#7'Ch' + +'ecked'#9#5'State'#7#9'cbChecked'#8'TabOrder'#2#10#7'Visible'#8#0#0#9'TCheck' + +'Box'#14'TxtReportCheck'#4'Left'#3#248#0#6'Height'#2#18#3'Top'#2'8'#5'Width' + +#3#26#1#7'Caption'#6'+Save text report (scan and patient details)'#8'TabOrde' + +'r'#2#11#0#0#0 +]); diff --git a/dcm2nii/pref_form.o b/dcm2nii/pref_form.o new file mode 100644 index 0000000..b5ae597 Binary files /dev/null and b/dcm2nii/pref_form.o differ diff --git a/dcm2nii/pref_form.pas b/dcm2nii/pref_form.pas new file mode 100755 index 0000000..7a514b8 --- /dev/null +++ b/dcm2nii/pref_form.pas @@ -0,0 +1,199 @@ +unit pref_form; + +interface + +uses + +{$IFDEF FPC}LResources,{$ENDIF} + {$IFDEF UNIX}Process, {$ELSE}ShellApi, Windows,{$ENDIF} +//Messages, +SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls,filename,define_types,dicomtypes,prefs, Spin, Buttons; + +type +{$H+} + { TPrefsForm } + TPrefsForm = class(TForm) + // TxtReportCheck: TCheckBox; + // WritePrefsOnQuit: TCheckBox; + // TextEditorBtn: TButton; + Stack3DImagesWithSameAcqNum: TCheckBox; + OutputCombo: TComboBox; + FilenameBox: TGroupBox; + DateCheck: TCheckBox; + OutDirLabel: TLabel; + CollapseCheck: TCheckBox; + SeriesCheck: TCheckBox; + ProtocolCheck: TCheckBox; + PatientNameCheck: TCheckBox; + InputNameCheck: TCheckBox; + NotAnonymizeCheck: TCheckBox; + ReorientCheck: TCheckBox; + OKBtn: TButton; + CancelBtn: TButton; + RecursiveSpin: TSpinEdit; + Label1: TLabel; + TextEditorBtn: TButton; + WritePrefsOnQuit: TCheckBox; + TxtReportCheck: TCheckBox; + //Stack3DImagesWithSameAcqNum: TCheckBox; + //CollapseCheck: TCheckBox; + procedure FilenameChecks(Sender: TObject); + procedure OutputComboMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure ReadPrefs(var lPrefs: TPrefs); + procedure TextEditorBtnClick(Sender: TObject); + procedure WritePrefs(var lPrefs: TPrefs); + procedure SetOutDirLabel; + procedure OutputComboChange(Sender: TObject); + procedure SetOutput; + private + { Private declarations } + public + { Public declarations } + end; + +var + PrefsForm: TPrefsForm; + +implementation +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} +uses gui,userdir; +var + gPrefs: TPrefs; +procedure TPrefsForm.SetOutDirLabel; +begin + OutDirLabel.visible := (OutputCombo.ItemIndex = kOutDirModeOutDir); +end; + +procedure TPrefsForm.WritePrefs(var lPrefs: TPrefs); +begin + gPrefs := lPrefs; + Stack3DImagesWithSameAcqNum.Checked := lPrefs.Stack3DImagesWithSameAcqNum; + DateCheck.Checked := lPrefs.AppendDate; + SeriesCheck.Checked := lPrefs.AppendAcqSeries; + ProtocolCheck.Checked := lPrefs.AppendProtocolName; + PatientNameCheck.Checked := lPrefs.AppendPatientName; + InputNameCheck.checked := lPrefs.AppendFilename; + CollapseCheck.checked := lPrefs.CollapseFolders; + ReorientCheck.Checked := (lPrefs.MinReorientMatrix < 32000); + NotAnonymizeCheck.Checked := not lPrefs.Anonymize; + TxtReportCheck.Checked := lPrefs.TxtReport; + RecursiveSpin.Value := lPrefs.RecursiveFolderDepth; + OutDirLabel.Caption := lPrefs.OutDir; + if (lPrefs.OutDirMode < 0) or (lPrefs.OutDirMode >= OutputCombo.Items.count) then + lPrefs.OutDirMode := 0; + OutputCombo.ItemIndex := lPrefs.OutDirMode; + SetOutDirLabel; +end; + +procedure TPrefsForm.ReadPrefs(var lPrefs: TPrefs); +begin + lPrefs := gPrefs; + lPrefs.Stack3DImagesWithSameAcqNum := Stack3DImagesWithSameAcqNum.checked; + lPrefs.AppendDate := DateCheck.Checked; + lPrefs.AppendAcqSeries := SeriesCheck.Checked; + lPrefs.AppendProtocolName := ProtocolCheck.Checked; + lPrefs.AppendPatientName := PatientNameCheck.Checked; + lPrefs.AppendFilename := InputNameCheck.checked; + //lPrefs.SaveToBaseFolder := SaveToBaseFolderCheck.Checked; + lPrefs.CollapseFolders := CollapseCheck.checked; + if ReorientCheck.Checked then begin + if lPrefs.MinReorientMatrix = MaxInt then + lPrefs.MinReorientMatrix := kMinReorientMatrix + end else + lPrefs.MinReorientMatrix := MaxInt; + lPrefs.Anonymize := not NotAnonymizeCheck.Checked; + lPrefs.TxtReport:= TxtReportCheck.Checked; + lPrefs.RecursiveFolderDepth := RecursiveSpin.Value; + lPrefs.OutDir := OutDirLabel.Caption; + lPrefs.OutDirMode := OutputCombo.ItemIndex; + lPrefs.WritePrefsOnQuit := WritePrefsOnQuit.Checked; +end; + + +procedure TPrefsForm.TextEditorBtnClick(Sender: TObject); +{$IFDEF UNIX} +var + AProcess: TProcess; +begin + Showmessage('Preferences will be opened in a text editor. The program '+ExtractFilename(paramstr(0))+' will now quit, so that the file will not be overwritten.'); + MainForm.SavePrefs; + AProcess := TProcess.Create(nil); + {$IFDEF UNIX} + {$IFDEF Darwin} + AProcess.CommandLine := 'open -a TextEdit '+IniName; + {$ELSE} + AProcess.CommandLine := 'open -a gedit '+IniName; + {$ENDIF} + {$ELSE} + AProcess.CommandLine := 'notepad '+IniName; + {$ENDIF} + //AProcess.Options := AProcess.Options + [poWaitOnExit]; + AProcess.Execute; + AProcess.Free; + WritePrefsOnQuit.checked := false; + MainForm.close; +end; +{$ELSE} //ShellExecute(Handle,'open', 'c:\windows\notepad.exe','c:\SomeText.txt', nil, SW_SHOWNORMAL) ; +begin + Showmessage('Preferences will be opened in a text editor. The program '+ExtractFilename(paramstr(0))+' will now quit, so that the file will not be overwritten.'); + MainForm.SavePrefs; + ShellExecute(Handle,'open', 'notepad.exe',PAnsiChar(AnsiString(IniName)), nil, SW_SHOWNORMAL) ; + WritePrefsOnQuit.checked := false; + MainForm.close; +end; +{$ENDIF} + +procedure TPrefsForm.FilenameChecks(Sender: TObject); +var + lDICOMImgName: string; + lDicomData: DICOMdata; + lPrefs: TPrefs; +begin + Clear_Dicom_Data(lDicomData); + SetDefaultPrefs (lPrefs); + ReadPrefs(lPrefs); + clear_dicom_data(lDicomData); + lDICOMImgName:= 'IM60'; + lDicomData.PatientName := 'JOHN_DOE'; + lDicomData.ProtocolName := 'T1'; + //FilenameBox.Caption := 'Output Filename ('+ OutputFilename(lDicomImgName,lDicomData,lPrefs.AppendDate,lPrefs.AppendAcqSeries,lPrefs.AppendProtocolName,lPrefs.AppendPatientName,lPrefs.FourD,lPrefs.AppendFilename)+')'; + Caption := 'Output: '+ OutputFilename(lDicomImgName,lDicomData,lPrefs); +end; + + + +procedure TPrefsForm.SetOutput; +begin + SetOutDirLabel; + if not (OutputCombo.ItemIndex = kOutDirModeOutDir) then + exit; + OutDirLabel.Caption := GetDirPrompt(OutDirLabel.Caption); +end; + +procedure TPrefsForm.OutputComboMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +//for OSX +begin + {$IFDEF Darwin} + SetOutput; + {$ENDIF} +end; + +procedure TPrefsForm.OutputComboChange(Sender: TObject); +//for all OSes except OSX... +begin +{$IFNDEF Darwin} + SetOutput; +{$ENDIF} +end; + +initialization +{$IFDEF FPC} + {$I pref_form.lrs} + {$ENDIF} + +end. \ No newline at end of file diff --git a/dcm2nii/pref_form.ppu b/dcm2nii/pref_form.ppu new file mode 100644 index 0000000..aff3bbd Binary files /dev/null and b/dcm2nii/pref_form.ppu differ diff --git a/dcm2nii/prefs.o b/dcm2nii/prefs.o new file mode 100644 index 0000000..480e9e2 Binary files /dev/null and b/dcm2nii/prefs.o differ diff --git a/dcm2nii/prefs.pas b/dcm2nii/prefs.pas new file mode 100755 index 0000000..bf13dc3 --- /dev/null +++ b/dcm2nii/prefs.pas @@ -0,0 +1,270 @@ +unit prefs; +{$H+} +{$Include ..\common\isgui.inc} +interface +uses + {$IFDEF FPC} + {$IFDEF UNIX} BaseUnix,{$ENDIF} + {$IFDEF GUI}LResources, {$ENDIF} + + {$ELSE} + SelectFolder, +{$ENDIF} + inifiles, define_types,SysUtils, userdir, dialogsx, dialogs_msg; + +type + TPrefs = record + WritePrefsOnQuit,OrthoFlipXDim,RecursiveUseNameAppend,AnonymizeSourceDICOM, ManualNIfTIConv,Anonymize, + SingleNIIFile,Gzip,SPM2,VOI,enablereorient,createoutputfolder, + AppendDate,AppendAcqSeries,AppendProtocolName,AppendPatientName,AppendFilename, + everyfile,fourD,Swizzle4D,Stack3DImagesWithSameAcqNum,customRename, + CollapseFolders,AutoCrop, UseGE_0021_104F, PhilipsPrecise,Verbose, PlanarRGB, + DebugMode,DebugMode2,UntestedFeatures,UINT16toFLOAT32, TxtReport: boolean; + + BeginClip, LastClip,SiemensDTIUse0019If00181020atleast, + SiemensDTINoAngulationCorrectionIf00181020atleast, + SiemensDTIStackIf00181020atleast, + OutDirMode, MinReorientMatrix,MaxReorientMatrix,RecursiveFolderDepth,usePigz + : integer; + OutDir, BackupDir,NameAppend: string; + end; +const + kOutDirModeInput = 0;//save output files to source folder + kOutDirModePrompt = 1;//prompt user to specify location of output dir + kOutDirModeOutDir = 2;//save output to lPrefs.OutDir + kMinReorientMatrix = 200; //reorient images with matrices > this value +procedure SetOutputFormat (lItemIndex: integer; var lPrefs: TPrefs); +procedure SetDefaultPrefs (var lPrefs: TPrefs); +procedure CorrectPrefs (var lPrefs: TPrefs); //ensures only usable file types are created +function IniFile(lRead: boolean; lFilename: string; var lPrefs: TPrefs): boolean; +function DefaultOutputFormat (lPrefs: TPrefs): integer; + +implementation + +function DefaultOutputFormat (lPrefs: TPrefs): integer; +begin + if lPrefs.SPM2 then + result := 0 //SPM2 3D hdr/img analyze + else if not lPrefs.FourD then begin + if not (lPrefs.SingleNIIFile) then + result := 1 //SPM5 3D hdr/img + else + result:= 2; //SPM8 3D nii + end else if not lPrefs.SingleNIIFile then + result := 3 //?? 4D hdr/img + else if not lPrefs.GZip then + result := 4 //FSL 4D nii + else + result := 5; //FSL 4D nii.gz +end; + +procedure SetOutputFormat (lItemIndex: integer; var lPrefs: TPrefs); +//SetOutputFormat(n,lPrefs) : 0=SPM2,1=SPM5,2=spm8,3=4D hdr/img,4=fsl(default),5=fsl.gz, 6=.voi +begin + //next: options for reading; + lPrefs.VOI := false; + lPrefs.SPM2 := false; + lPrefs.fourD := true; + lPrefs.SingleNIIFile := true; + lPrefs.GZip := false; + case lItemIndex of + 0: begin//spm2 + lPrefs.SPM2 := true; + lPrefs.fourD := false; + lPrefs.SingleNIIFile := false; + end; + 1: begin//spm5 + lPrefs.fourD := false; + lPrefs.SingleNIIFile := false; + end; + 2: begin//spm8 + lPrefs.fourD := false; + end; + 3: lPrefs.SingleNIIFile := false;//4D Hdr/Img + 5: lPrefs.GZip := true;//FSL compressed + 6: begin //VOI + lPrefs.GZip := true;//FSL compressed + lPrefs.VOI := true; + end; + end;//case +end; + +procedure CorrectPrefs (var lPrefs: TPrefs); //ensures only usable file types are created +begin + if lPrefs.SingleNIIFile then + lPrefs.SPM2 := false; //SPM2 only reads .hdr/.img - loses NIfTI information + if not lPrefs.SingleNIIFile then + lPrefs.Gzip := false; //nii.gz is OK, but img.gz is not +end; + +procedure SetDefaultPrefs (var lPrefs: TPrefs); +begin + with lPrefs do begin + OutDirMode := kOutDirModeInput; + SiemensDTIUse0019If00181020atleast := 15; + SiemensDTINoAngulationCorrectionIf00181020atleast := 1000; + SiemensDTIStackIf00181020atleast := 15; + //IgnoreDTIRotationsIf_0002_0013_atleast := 15; + VOI := false; + OutDir := UserDataFolder; + PhilipsPrecise := false; + UseGE_0021_104F := false; + CollapseFolders := true; + AutoCrop := false; //for dcm2nii - reorient and crop 3D nifti input images... + CustomRename := false; + createoutputfolder := false; + Stack3DImagesWithSameAcqNum := false; + RecursiveUseNameAppend := false;//changes paramstrs.pas recursive search to add top level folder name + DebugMode := false; + DebugMode2 := false; + UntestedFeatures := false; + TxtReport := false; + PlanarRGB := false; + Verbose := false; + SingleNIIFile := true; + Gzip := true; + OrthoFlipXDim := false; + SPM2 := false; + Anonymize := true; + AppendDate := true; + AppendAcqSeries := true; + AppendProtocolName := true; + AppendPatientName := false; + AppendFilename := false; + EveryFile:=true; + FourD := true; + enablereorient := true; + ManualNIfTIConv := true; + AnonymizeSourceDICOM := false; + Swizzle4D := true; + RecursiveFolderDepth := 5; + MinReorientMatrix := kMinReorientMatrix; + MaxReorientMatrix := 1023; + NameAppend := ''; + BackupDir := ''; + WritePrefsOnQuit := true; + UINT16toFLOAT32 := true; + BeginClip := 0; + LastClip := 0; + usePigz := 0; + end; +end; + +procedure IniInt(lRead: boolean; lIniFile: TCustomIniFile; lIdent: string; var lValue: integer); +//read or write an integer value to the initialization file +var + lStr: string; +begin + if not lRead then begin + lIniFile.WriteString('INT',lIdent,IntToStr(lValue)); + exit; + end; + lStr := lIniFile.ReadString('INT',lIdent, ''); + if length(lStr) > 0 then + lValue := StrToInt(lStr); +end; //IniInt + +procedure IniBool(lRead: boolean; lIniFile: TCustomIniFile; lIdent: string; var lValue: boolean); +//read or write a boolean value to the initialization file +var + lStr: string; +begin + if not lRead then begin + lIniFile.WriteString('BOOL',lIdent,Bool2Char(lValue)); + exit; + end; + lStr := lIniFile.ReadString('BOOL',lIdent, ''); + if length(lStr) > 0 then + lValue := Char2Bool(lStr[1]); +end; //IniBool + +procedure IniStr(lRead: boolean; lIniFile: TCustomIniFile; lIdent: string; var lValue: string); +//read or write a string value to the initialization file +begin + if not lRead then begin + lIniFile.WriteString('STR',lIdent,lValue); + exit; + end; + lValue := lIniFile.ReadString('STR',lIdent, ''); +end; //IniStr + +function IniFile(lRead: boolean; lFilename: string; var lPrefs: TPrefs): boolean; +//Read or write initialization variables to disk +var + lIniFile: TMemIniFile; +begin + result := false; + if (lRead) and (not Fileexists(lFilename)) then + exit; + {$IFDEF UNIX} //Uses BaseUnix; + if (lRead) and (fpAccess (lFilename,R_OK)<>0) then begin//ensure user has read-access to prefs file... + dcmMsg('Unable to load preferences: no write access for '+lFilename); + exit; + end; + {$ENDIF} + if (lRead) then begin + Filemode := 0; //Readonly + dcmMsg('reading preferences file '+lFilename); + end else + Filemode := 2; //Read-Write + //lIniFile := TIniFile.Create(lFilename); + lIniFile := TMemIniFile.Create(lFilename); + IniBool(lRead,lIniFile,'DebugMode',lPrefs.DebugMode); + IniBool(lRead,lIniFile,'UntestedFeatures',lPrefs.UntestedFeatures); + IniBool(lRead,lIniFile,'TxtReport',lPrefs.TxtReport); + IniBool(lRead,lIniFile,'UINT16toFLOAT32',lPrefs.UINT16toFLOAT32); + IniBool(lRead,lIniFile,'PlanarRGB',lPrefs.PlanarRGB); + IniBool(lRead,lIniFile,'Verbose',lPrefs.Verbose); + IniBool(lRead,lIniFile,'Anonymize',lPrefs.Anonymize); + IniBool(lRead,lIniFile, 'AnonymizeSourceDICOM',lPrefs.AnonymizeSourceDICOM); + IniBool(lRead,lIniFile,'AppendAcqSeries',lPrefs.AppendAcqSeries); + IniBool(lRead,lIniFile,'AppendDate',lPrefs.AppendDate); + IniBool(lRead,lIniFile,'AppendFilename',lPrefs.AppendFilename); + IniBool(lRead,lIniFile,'AppendPatientName',lPrefs.AppendPatientName); + IniBool(lRead,lIniFile,'AppendProtocolName',lPrefs.AppendProtocolName); + IniBool(lRead,lIniFile,'AutoCrop',lPrefs.AutoCrop); + IniBool(lRead,lIniFile,'CollapseFolders',lPrefs.CollapseFolders); + IniBool(lRead,lIniFile,'createoutputfolder',lPrefs.createoutputfolder); + IniBool(lRead,lIniFile,'CustomRename',lPrefs.CustomRename); + IniBool(lRead,lIniFile,'enablereorient',lPrefs.enablereorient); + IniBool(lRead,lIniFile,'OrthoFlipXDim',lPrefs.OrthoFlipXDim); + IniBool(lRead,lIniFile,'EveryFile',lPrefs.EveryFile); + IniBool(lRead,lIniFile,'fourD',lPrefs.fourD); + IniBool(lRead,lIniFile,'Gzip',lPrefs.Gzip); + IniBool(lRead,lIniFile,'ManualNIfTIConv',lPrefs.ManualNIfTIConv); + IniBool(lRead,lIniFile,'PhilipsPrecise',lPrefs.PhilipsPrecise); + IniBool(lRead,lIniFile,'RecursiveUseNameAppend',lPrefs.RecursiveUseNameAppend); + IniBool(lRead,lIniFile,'SingleNIIFile',lPrefs.SingleNIIFile); + IniBool(lRead,lIniFile,'SPM2',lPrefs.SPM2); + IniBool(lRead,lIniFile,'Stack3DImagesWithSameAcqNum',lPrefs.Stack3DImagesWithSameAcqNum); + IniBool(lRead,lIniFile,'Swizzle4D',lPrefs.Swizzle4D); + IniBool(lRead,lIniFile,'UseGE_0021_104F',lPrefs.UseGE_0021_104F); + + IniInt(lRead,lIniFile,'BeginClip',lPrefs.BeginClip); + IniInt(lRead,lIniFile,'LastClip',lPrefs.LastClip); + IniInt(lRead,lIniFile,'usePigz',lPrefs.usePigz); + IniInt(lRead,lIniFile,'MaxReorientMatrix',lPrefs.MaxReorientMatrix); + IniInt(lRead,lIniFile,'MinReorientMatrix',lPrefs.MinReorientMatrix); + IniInt(lRead,lIniFile,'RecursiveFolderDepth',lPrefs.RecursiveFolderDepth); + IniInt(lRead,lIniFile,'OutDirMode',lPrefs.OutDirMode); + + IniInt(lRead,lIniFile,'SiemensDTIUse0019If00181020atleast',lPrefs.SiemensDTIUse0019If00181020atleast); + IniInt(lRead,lIniFile,'SiemensDTINoAngulationCorrectionIf00181020atleast',lPrefs.SiemensDTINoAngulationCorrectionIf00181020atleast); + IniInt(lRead,lIniFile,'SiemensDTIStackIf00181020atleast',lPrefs.SiemensDTIStackIf00181020atleast); + lPrefs.BackupDir := lIniFile.ReadString('STR','BackupDir',lPrefs.BackupDir); + IniStr(lRead,lIniFile,'OutDir',lPrefs.OutDir); + if (lPrefs.OutDirMode < kOutDirModeInput) or (lPrefs.OutDirMode > kOutDirModeOutDir) then + lPrefs.OutDirMode := kOutDirModeOutDir; + if (lRead) and (not(DirExists(lPrefs.OutDir))) then + lPrefs.OutDir := UserDataFolder; + if not lRead then + lIniFile.UpdateFile; + lIniFile.Free; + if (lRead) then + Filemode := 2; //Read-write +end; + +end. + + + diff --git a/dcm2nii/prefs.ppu b/dcm2nii/prefs.ppu new file mode 100644 index 0000000..ba56343 Binary files /dev/null and b/dcm2nii/prefs.ppu differ diff --git a/dcm2nii/readint.dfm b/dcm2nii/readint.dfm new file mode 100755 index 0000000..6dc59bd Binary files /dev/null and b/dcm2nii/readint.dfm differ diff --git a/dcm2nii/readint.lrs b/dcm2nii/readint.lrs new file mode 100755 index 0000000..feb8ee0 --- /dev/null +++ b/dcm2nii/readint.lrs @@ -0,0 +1,14 @@ +LazarusResources.Add('TReadIntForm','FORMDATA',[ + 'TPF0'#12'TReadIntForm'#11'ReadIntForm'#4'Left'#3'2'#1#6'Height'#2'P'#3'Top'#3 + +'*'#2#5'Width'#3#213#1#18'HorzScrollBar.Page'#3#212#1#18'VertScrollBar.Page' + +#2'O'#13'ActiveControl'#7#11'ReadIntEdit'#11'BorderStyle'#7#8'bsDialog'#7'Ca' + +'ption'#6#16'Integer required'#11'Font.Height'#2#245#9'Font.Name'#6#13'MS Sa' + +'ns Serif'#8'OnCreate'#7#10'FormCreate'#8'Position'#7#14'poScreenCenter'#0#6 + +'TLabel'#12'ReadIntLabel'#4'Left'#2#16#6'Height'#2#14#3'Top'#2#12#5'Width'#3 + +'P'#1#9'Alignment'#7#14'taRightJustify'#8'AutoSize'#8#7'Caption'#6#14'Enter ' + +'a number'#5'Color'#7#6'clNone'#11'ParentColor'#8#0#0#9'TSpinEdit'#11'ReadIn' + +'tEdit'#4'Left'#3'h'#1#6'Height'#2#22#3'Top'#2#12#5'Width'#2']'#8'MaxValue'#2 + +#0#8'TabOrder'#2#0#0#0#7'TButton'#5'OKBtn'#4'Left'#3'p'#1#6'Height'#2#25#3'T' + +'op'#2','#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#2'OK' + +#7'OnClick'#7#10'OKBtnClick'#8'TabOrder'#2#1#0#0#0 +]); diff --git a/dcm2nii/readint.o b/dcm2nii/readint.o new file mode 100644 index 0000000..797d54c Binary files /dev/null and b/dcm2nii/readint.o differ diff --git a/dcm2nii/readint.pas b/dcm2nii/readint.pas new file mode 100755 index 0000000..c6e1391 --- /dev/null +++ b/dcm2nii/readint.pas @@ -0,0 +1,54 @@ +unit readint; + +interface + +uses +{$IFDEF FPC}LResources,Buttons,{$ENDIF} +{$IFNDEF UNIX} Windows,{$ENDIF} + Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Spin,define_types; + +type + TReadIntForm = class(TForm) + ReadIntEdit: TSpinEdit; + ReadIntLabel: TLabel; + OKBtn: TButton; + function GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + procedure OKBtnClick(Sender: TObject); + private + { Private declarations } + public + + { Public declarations } + end; +const + gPassname: kStr20='NIH'; +var + ReadIntForm: TReadIntForm; + +implementation + +{$IFNDEF FPC}{$R *.DFM} {$ENDIF} + + function TReadIntForm.GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + begin + //result := lDefault; + ReadIntLabel.caption := lStr+' ['+inttostr(lMin)+'..'+inttostr(lMax)+']'; + ReadIntEdit.MinValue := lMin; + ReadIntEdit.MaxValue := lMax; + ReadIntEdit.Value := lDefault; + ReadIntForm.ShowModal; + result := ReadIntEdit.Value; + end; + +procedure TReadIntForm.OKBtnClick(Sender: TObject); +begin + ReadIntForm.ModalResult := mrOK; +end; + +{$IFDEF FPC} +initialization + {$I readint.lrs} + {$ENDIF} + +end. diff --git a/dcm2nii/readint.ppu b/dcm2nii/readint.ppu new file mode 100644 index 0000000..a9e0d6b Binary files /dev/null and b/dcm2nii/readint.ppu differ diff --git a/dcm2nii/sortdicom.o b/dcm2nii/sortdicom.o new file mode 100644 index 0000000..6551fe8 Binary files /dev/null and b/dcm2nii/sortdicom.o differ diff --git a/dcm2nii/sortdicom.pas b/dcm2nii/sortdicom.pas new file mode 100755 index 0000000..b0d5b98 --- /dev/null +++ b/dcm2nii/sortdicom.pas @@ -0,0 +1,508 @@ +unit sortdicom; +{$H+} +{$Include ..\common\isgui.inc} + +interface +uses + SysUtils,define_types,classes,dicom,dicomtypes,convert,dicomfast,prefs,userdir,dialogs_msg; + + +function LoadFileList (var lInFilename, lOutDirname: string; var lPrefs: TPrefs):boolean; +function LoadParamFileList (var lInFilename, lOutDirname: string; var lPrefs: TPrefs; lParamNum: integer): boolean; + +implementation + +uses dialogsx; + +function IsRepeat (var lD1,lD2: DicomData) : boolean; +begin + if (lD1.ImageNum = lD2.ImageNum) and + (lD1.AcquNum = lD2.AcquNum) and + (lD1.SeriesNum = lD2.SeriesNum) and + (lD1.DateTime = lD2.DateTime) then + result := true + else + result := false; +end; + +function IsEqualDT (lI1,lI2: TDateTime; var l1LessThan2: boolean): boolean; +begin + if lI1 = lI2 then + result := true + else + result := false; + if lI1 < lI2 then + l1LessThan2 := true + else + l1LessThan2 := false; +end; + +function IsEqual (lI1,lI2: integer; var l1LessThan2: boolean): boolean; +begin + if lI1 = lI2 then + result := true + else + result := false; + if lI1 < lI2 then + l1LessThan2 := true + else + l1LessThan2 := false; +end; + +function D1LessThanD2 (var lD1,lD2: DicomData) : boolean; +begin + if not IsEqualDT (lD1.DateTime, lD2.DateTime, result) then + exit; + //only get here if lD1.DataTime = lD2.DateTime + if not IsEqual (lD1.SeriesNum, lD2.SeriesNum, result) then + exit; + //only get here if lD1.SeriesNum = lD2.SeriesNum + if not IsEqual (lD1.AcquNum, lD2.AcquNum, result) then + exit; + //only get here if lD1.AcquNum = lD2.AcquNum + if not IsEqual (lD1.ImageNum, lD2.ImageNum, result) then + exit; + //only get here if lD1.ImageNum = lD2.ImageNum +end; + + + +procedure ReportError (l,i: integer; var lDICOMra: TDICOMrap); +begin +//Msg('Error: these files have the same index '+ lDICOMra^[lPositionRA^[l]].Filename+' = '+lDICOMra^[lPositionRA^[i]].Filename); + dcmMsg('Error: these files have the same index '+ DICOMstr(l,lDICOMra)+' = '+DICOMstr(i,lDICOMra)); +end; + +procedure ShellSortDCM (var Items: integer; var lDICOMra: TDICOMrap; var lRepeatedValues: boolean); +//Shell sort /- see 'Numerical Recipes in C' for similar sorts: less memory intensive than recursive quicksort +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + inputItems,n,t, nn, m, lognb2, l, k, j, i: longint; + lPositionRA,lPositionRA2: LongintP; + lTempDICOMra: TDICOMrap; + +begin + inputItems := Items; + lRepeatedValues := false; + if Items < 2 then + exit; + Getmem(lPositionRA,Items*sizeof(LongInt)); + for i := 1 to items do + lPositionRA^[i] := i; + n := (Items ); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := Items; + for nn := 1 to lognb2 do + begin + m := m div 2; + k := Items - m; + for j := 1 to k do begin + i := j; + 555: + l := i + m; + + if //identical refs + {(lDICOMra^[lPositionRA^[l]].ImageNum = lDICOMra^[lPositionRA^[i]].ImageNum) and + (lDICOMra^[lPositionRA^[l]].AcquNum = lDICOMra^[lPositionRA^[i]].AcquNum) and + (lDICOMra^[lPositionRA^[l]].SeriesNum = lDICOMra^[lPositionRA^[i]].SeriesNum) and + (lDICOMra^[lPositionRA^[l]].DateTime = lDICOMra^[lPositionRA^[i]].DateTime)} +IsRepeat(lDICOMra^[lPositionRA^[l]], lDICOMra^[lPositionRA^[i]]) + then begin + lRepeatedValues := true; + ReportError(lPositionRA^[l],lPositionRA^[i],lDICOMra); + //Msg('Error: these files have the same index '+ lDICOMra^[lPositionRA^[l]].Filename+' = '+lDICOMra^[lPositionRA^[i]].Filename); + + end else + if D1LessThanD2 (lDICOMra^[lPositionRA^[l]],lDICOMra^[lPositionRA^[i]]) + then begin + //swap values for i and l + t := lPositionRA^[i]; + lPositionRA^[i] := lPositionRA^[l]; + lPositionRA^[l] := t; + i := i - m; + if (i >= 1) then + goto 555; + end + end + end; + //next - remove any repeated values + + if lRepeatedValues then begin + Getmem(lPositionRA2,Items*sizeof(LongInt)); + k := 1; + lPositionRA2^[1] := lPositionRA^[1]; + for i := 2 to Items do begin + if not IsRepeat(lDICOMra^[lPositionRA^[i-1]],lDICOMra^[lPositionRA^[i]]) then begin + inc(k); + lPositionRA2^[k] := lPositionRA^[i]; + end; + end; + Items := k; + for i := 1 to Items do + lPositionRA^[i] := lPositionRA2^[i]; + Freemem(lPositionRA2); + end; + //Next - created sorted lists based on pointers... + //... a quicker way would be to return the pointers, but this is still pretty fast... + //... a lower memory solution would be to swap items inside lDICOMra + Getmem(lTempDICOMra,InputItems*sizeof(DicomData)); + for I := 1 to InputItems do + lTempDICOMra^[I] := lDICOMra^[I]; + if InputItems <> Items then begin + Freemem(lDICOMra); + Getmem(lDICOMra,Items*sizeof({TDICOM}DicomData)); + end; + for I := 1 to Items do + lDICOMra^[I] := lTempDICOMra^[lPositionRA^[I]]; + Freemem(lTempDICOMra); + //finally, cleanup + Freemem(lPositionRA); +end; //ShellSortDCM + +const +kTolerance = 0.0000095; //assume files are from different series if their orientation differs by more than this value +//unfortunately, GE images have a rounding error, so nearby slices often have different values... + +function SameIDSeriesAcqXYZ( var ld1,ld2: DicomData{TDICOM};var lPrefs: TPrefs): boolean; +var + lStack: boolean; + lI: integer; +begin + result := false; + if (ld1.file4D) then //if previous file is a 4D image, we should convert it separately + exit; + if (ld1.DateTime = ld2.DateTime) and(ld1.SeriesNum = ld2.SeriesNum) {and (ld1.acquNum = ld2.acquNum)} + and(ld1.XYZdim[1] = ld2.XYZdim[1]) and(ld1.XYZdim[2] = ld2.XYZdim[2]) and(ld1.XYZdim[3] = ld2.XYZdim[3]) then + //result := true + else + exit; + lStack := lPrefs.Stack3DImagesWithSameAcqNum; + if (ld1.Vers0018_1020 >= lPrefs.SiemensDTIStackIf00181020atleast) then + lStack := true; //recent Siemens scanners will have different NEx saved as different images and different directions saved as different images + if (not lStack) and (ld1.acquNum <> ld2.acquNum) then begin + dcmMsg('Images not stacked because acquisition number changes. If you want to stack these images set Stack3DImagesWithSameAcqNum=1 in your ini file.'); + exit; + end; + (*if (ld1.PatientIDInt = ld2.PatientIDInt) and(ld1.SeriesNum = ld2.SeriesNum) and (ld1.acquNum = ld2.acquNum) + and(ld1.XYZdim[1] = ld2.XYZdim[1]) and(ld1.XYZdim[2] = ld2.XYZdim[2]) and(ld1.XYZdim[3] = ld2.XYZdim[3]) then + //result := true + else + exit;*) + for lI := 1 to 6 do begin + //if (ld1.orient[lI] <> ld2.orient[lI]) then + if abs (ld1.orient[lI] - ld2.orient[lI]) > kTolerance then + exit; + end; + (*if (ld1.IntenScale <> ld2.IntenScale) or (ld1.IntenIntercept <> ld2.IntenIntercept) then begin//if previous file is a 4D image, we should convert it separately + msg('Warning: unable to stack images because intensity scaling varies. Names: '+ld1.Filename+' '+ld2.filename+' Slopes: '+floattostr(ld1.IntenScale)+' '+floattostr(ld2.IntenScale)+' Intercepts: '+floattostr(ld1.IntenIntercept)+' '+floattostr(ld2.IntenIntercept)); + exit; + end; *) + result := true; +end; + +function ProcessSingleFolderDCM (var lInFilename: string; var lStringList : TStringList): boolean; +//assumes lStringList is already created and will be freed later... +var + lSearchRec: TSearchRec; + lPrev,lFilename,lFilepath,lMaskExt,lExt: string; +begin + result := false; + lFilePath := ExtractFileDirWithPathDelim(lInFilename); + lExt := string(StrUpper(PChar(ExtractFileExt(lInFilename)))); //.head + if (lExt = '.PAR') or (lExt = '.REC') {or (lExt = '.HDR') or (lExt = '.IMG')or (lExt = '.HEAD') or (lExt = '.BRIK')} then + {$IFDEF Unix} + lMaskExt := '*'+ExtractFileExt(lInFilename) //Linux is case sensitive, these extensions are used by paired files: only read one of pair + else + lMaskExt := '*'; + {$ELSE} + lMaskExt := '*'+lExt //these extensions are used by paired files: only read one of pair + else + lMaskExt := '*.*'; + {$ENDIF} + //Msg('yyy'+lFilePath+'::'+lMaskExt); + lPrev := '.'; + Filemode := 0; //readonly + if FindFirst(lFilePath{+PathDelim}+lMaskExt, faAnyFile-faSysFile-faDirectory, lSearchRec) = 0 then begin + repeat + if (length(lSearchRec.Name) < 1) then + //do nothing + lFilename := '' + {$IFDEF Unix} +//next two lines would not recognize filename that starts with dor, e.g. \home\cr\.filename.ima +// else if (lSearchRec.Name[1] = '.') then +// lFilename := '' + else if (lSearchRec.Name = '..') then + lFilename := '' + else if (lSearchRec.Name = '.') then + lFilename := '' + {$ENDIF} + else begin + lFilename := lFilePath+lSearchRec.Name; + + if (lFilename = '') or (length (lFilename) > 255) then begin + dcmMsg('Unable to convert images where the file path and name exceed 255 characters.'); + dcmMsg('Solution: put images in a folder with a shorter path.'); + dcmMsg(lFilename); + end else if (lFilename <> lPrev) then begin + lStringList.Add(lFileName); + //if lFilename = lPrev then + // msg(lPrev); + lPrev := lFilename; + // msg(lFilePath+lMaskExt+' ->'+lSearchRec.Name+'z'+inttostr(lStringList.count)); + + end; + end; + until (FindNext(lSearchRec) <> 0); + end; //some files found + // msg('xxxx'+inttostr( lStringList.Count)); + + SysUtils.FindClose(lSearchRec); + Filemode := 2; //readonly + result := true; +end; //ProcessSingleFolder + +procedure ProcessRecursiveFolder (var lFolderNameIn: string; var lStringList : TStringList; lDepth: integer; var lPrefs: TPrefs); +var + len: integer; + lFolderName,lNewDir,lNewName,lFilename,lExt: String; + lSearchRec: TSearchRec; +begin + lFolderName := lFolderNameIn; + if not DirExists (lFolderName) then begin + lFolderName := ExtractFileDir(lFolderName); + end; + if (length(lFolderName) > 1) and (lFolderName[length(lFolderName)] <> PathDelim) then + lNewDir := lFolderName+PathDelim; + if DirExists (lNewDir) then begin +{$IFDEF UNIX} + if FindFirst(lNewDir+'*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + lFilename := ''; + repeat + lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name <> '.') and (lSearchRec.Name <> '..') then begin + if DirExists(lNewName) then begin + if lDepth < lPrefs.RecursiveFolderDepth then begin + ProcessRecursiveFolder (lNewName, lStringList, lDepth+1, lPrefs); + end; + //exit;//4/4/2008 + end else + lFilename := lNewname; + end; + until (FindNext(lSearchRec) <> 0); + end else begin //if directory exists... else we were passed a filename + lFilename := lFolderName; + end; + if lFilename = '' then + exit; + //Msg('xxxx '+ lFilename); + if lFilename <> '' then begin + ProcessSingleFolderDCM (lFilename, lStringList); + end; + end; + FindClose(lSearchRec); + +end; + + +function LoadFileListInner (var lOutDirname: string; var lPrefs: TPrefs; var lStringList : TStringList): boolean; +var + lPrevDICOM,lDicomData: DicomData; + lDICOMra, lDICOMra4D: TDICOMrap; + lnumEchos,lRepeatLocations,lStartImg,lValidItems, lItems,lInc: integer; + lError,lRepeatedValues,lHdrOK,lImgOK, l4dDTI: boolean; + lDTIra: TDTIRA; + lFilename,lDynStr: string; +begin + result := false; + lItems := lStringList.Count; + if lItems < 1 then begin + lStringList.Free; + exit; + end; + Filemode := 2; + dcmMsg('Validating '+inttostr(lItems)+' potential DICOM images.'); + l4dDTI := false; + //START ANON + if lPrefs.AnonymizeSourceDICOM then begin + for lInc := 1 to lItems do begin + lFilename := lStringList.Strings[lInc-1]; + fast_read_dicom_data(lDICOMdata, 128, lFileName); //x3 faster! + end; + lStringList.Free; + result := true; + Exit; + end; //if anonymizeSourceDICOM + //END ANON + getmem(lDICOMra,lItems*sizeof(DicomData)); + lValidItems := 0; + for lInc := 1 to lItems do begin + lFilename := lStringList.Strings[lInc-1]; + + read_dicom_data(true,false{not verbose},true,true,true,true,false, lDICOMdata, lDTIra, lHdrOK, lImgOK, lDynStr,lFileName,lPrefs ); + if (lHdrOK) and (lImgOK) then begin //valid file + if lDICOMdata.nDTIdir > 1 then begin + //showmsg('oh dear'+inttostr(lDICOMdata.nDTIdir)); + l4dDTI := true; + dcmMsg('Converting 4D '); + getmem(lDICOMra4D,sizeof(DicomData)); + lDICOMra4D^[1] := lDicomData; + result := Dicom2NII(lDICOMra4D,lDTIra, 1,1,lOutDirname,lPrefs,0); + freemem(lDICOMra4D); + end else begin + inc(lValidItems); + lDICOMra^[lValidItems] := lDicomData; + end + end; //if image is OK + end; //for each item + lStringList.Free; + if lValidItems = 0 then begin + if not l4dDTI then //do not generate warning if we processed 4D data... + dcmMsg('Unable to find any DICOM files in the path '+lFileName); + freemem(lDICOMra); + exit; + end; + dcmMsg('Found '+inttostr(lValidItems)+' DICOM images.'); + + ShellSortDCM (lValidItems,lDICOMra,lRepeatedValues); + + if lRepeatedValues then begin //separate into series + dcmMsg('Warning: repeated image indexes in the path '+lFileName); + //freemem(lDICOMra); + //exit; + end; + if lPrefs.DebugMode then begin + for lInc := 1 to lValidItems do + dcmMsg( DICOMstr(lInc,lDICOMra)); + exit; + end; + lStartImg := 1; + lRepeatLocations := 0; + lnumEchos := 1; + lPrevDICOM := lDICOMra^[1]; + for lInc := 1 to lValidItems do begin + //msg(lDICOMra^[lInc].Filename+','+floattostr(lDICOMra^[lInc].PatientPosX)+','+floattostr(lDICOMra^[lInc].PatientPosY)+','+floattostr(lDICOMra^[lInc].PatientPosZ) ); + + if (lInc > 1) and (not SameIDSeriesAcqXYZ (lPrevDICOM ,lDICOMra^[lInc],lPrefs)) then begin + //SameIDSeriesAcqXYZ2 (lPrevDICOM ,lDICOMra^[lInc]); + if (lRepeatLocations < 2) and (lnumEchos > 1) then + lRepeatLocations := lnumEchos; + dcmMsg('Converting '+inttostr(lInc-1)+'/'+inttostr(lValidItems)+' volumes: '+inttostr(lRepeatLocations)); + result := Dicom2NII(lDICOMra,lDTIra,lStartImg,lInc-1,lOutDirname,lPrefs,lRepeatLocations); + if not result then + lError := true; + lPrevDICOM := lDICOMra^[lInc]; + lStartImg := lInc; + lRepeatLocations := 1; + end else if //(lDICOMra^[lInc].location = lPrevDICOM.Location) and + (lDICOMra^[lInc].PatientPosX = lPrevDICOM.PatientPosX) and + (lDICOMra^[lInc].PatientPosY = lPrevDICOM.PatientPosY) and + (lDICOMra^[lInc].PatientPosZ = lPrevDICOM.PatientPosZ) then begin + //fx(lDICOMra^[lInc].PatientPosZ , lPrevDICOM.PatientPosZ ); + //fx(666,lRepeatLocations,lDICOMra^[lInc].location, lPrevDICOM.Location); + inc(lRepeatLocations); + end else if (lInc > 1) and ( (lDICOMra^[lInc].AcquNum) > (lDICOMra^[lInc-1].AcquNum+999)) then //we increment acquisition number by 1000 to denote new echo + inc(lnumEchos); + end; //for each valid + if (lRepeatLocations < 2) and (lnumEchos > 1) then + lRepeatLocations := lnumEchos; + //fx(lPrevDICOM.PatientPosX, lPrevDICOM.PatientPosY, lPrevDICOM.PatientPosZ ); + //Msg( inttostr(lValidItems-lStartImg+1)+' '+ inttostr(lRepeatLocations)); + //fx(lRepeatLocations); + if (((lValidItems-lStartImg+1) mod lRepeatLocations) <> 0) then begin + dcmMsg('*Warning: Number of images in series ('+inttostr(lValidItems-lStartImg+1)+') not divisible by number of volumes ('+inttostr(lRepeatLocations)+')'); + dcmMsg('* Perhaps the selected folder only has some of the images'); + PartialAcquisitionError; + + end; + if (lPrevDICOM.SlicesPer3DVol > 0) and (not lPrevDICOM.file4D) and ((lValidItems div lRepeatLocations) <> lPrevDICOM.SlicesPer3DVol) then begin + dcmMsg('Warning: Number of slices per volume ('+inttostr((lValidItems div lRepeatLocations))+')appears different than reported in DICOM header ('+inttostr(lPrevDICOM.SlicesPer3DVol)+')'); + dcmMsg(' Perhaps the selected folder only has some of the images'); + end; + + dcmMsg('Converting '+inttostr(lValidItems)+'/'+inttostr(lValidItems)+' volumes: '+inttostr(lRepeatLocations)); + Dicom2NII(lDICOMra,lDTIra, lStartImg,lValidItems,lOutDirname,lPrefs,lRepeatLocations); + if lError then + result := false //at least one error + else + result := true; + freemem(lDICOMra); +end; + +function ReportDICOMHeader (var lInFilename: string; var lPrefs: TPRefs): boolean; +var + lDicomData: DicomData; + lDynStr: string; + lHdrOK,lImgOK: boolean; + lDTIra: TDTIRA; +begin + read_dicom_data(false,true,false,false,false,false,false, lDICOMdata, lDTIra, lHdrOK, lImgOK, lDynStr,lInFileName,lPrefs ); + result := lHdrOK; +end; + + + +function LoadFileList (var lInFilename, lOutDirname: string; var lPrefs: TPrefs): boolean; +var + lStringList : TStringList; +begin + result := false; + if lPrefs.Verbose then begin + //msg(lInFilename); + result := ReportDICOMHeader (lInFilename, lPrefs); + exit; + end; + lStringList := TStringList.Create; + if (lPrefs.OutDirMode <> kOutDirModeInput) and (DirExists(lPrefs.OutDir)) then begin + //For kOutDirModePrompt one should set OutDir before getting here + //This is required so recursive searches do not repetitively prompt the user... + lOutDirName := lPrefs.OutDir; + end; //1/2010 + if lOutDirName = '' then begin + if DirExists (lInFilename) then + lOutDirName := lInFilename + else + lOutDirName := extractfiledir(lInFilename); + end; + if not(DirExists(lOutDirName)) then + lOutDirName := UserDataFolder; + if lPrefs.CollapseFolders then begin + dcmMsg('Data will be exported to '+lOutDirname); + ProcessRecursiveFolder (lInFilename, lStringList, 0, lPrefs); + result := true; + end else + result := ProcessSingleFolderDCM (lInFilename, lStringList); + if (not result) or (lStringList.Count < 1) then begin + dcmMsg('+Unable to find any images in the path '+lInFilename); + lStringList.Free; + end else + result := LoadFileListInner (lOutDirName, lPrefs,lStringList) +end; + + +function LoadParamFileList (var lInFilename, lOutDirname: string; var lPrefs: TPrefs; lParamNum: integer): boolean; +var + lStringList : TStringList; + lI : integer; +begin + result := false; + if lPrefs.Verbose then begin + result := ReportDICOMHeader (lInFilename, lPrefs); + exit; + end; + lStringList := TStringList.Create; + lStringList.Add(lInFilename); + if ((lParamNum) < ParamCount) then + for lI := (lParamNum+1) to ParamCount do + lStringList.Add(Paramstr(lI)); + dcmMsg('Only converting files explicitly specified'); + result := LoadFileListInner (lOutDirName, lPrefs,lStringList) +end; + +end. diff --git a/dcm2nii/sortdicom.ppu b/dcm2nii/sortdicom.ppu new file mode 100644 index 0000000..8e634f7 Binary files /dev/null and b/dcm2nii/sortdicom.ppu differ diff --git a/dcm2nii/untar.o b/dcm2nii/untar.o new file mode 100644 index 0000000..fc22dfc Binary files /dev/null and b/dcm2nii/untar.o differ diff --git a/dcm2nii/untar.pas b/dcm2nii/untar.pas new file mode 100755 index 0000000..bb2a9a1 --- /dev/null +++ b/dcm2nii/untar.pas @@ -0,0 +1,357 @@ +unit untar; + +interface +{$IFDEF FPC}{$mode delphi}{$H+}{$ENDIF} +uses +{$IFDEF FPC} +gzio2, +{$ELSE} +gziod, +{$ENDIF} +define_types,SysUtils,LibTar, dialogs_msg, +gzio,dialogsx,prefs,sortdicom,classes; + +function DeTGZ (lFilename: string; lPrefs: TPrefs): boolean; +function isTGZ (var lStr: string): boolean; + +implementation + +function isTGZ (var lStr: string): boolean; +var lExt: string; +begin + lExt := extractfileext(lStr); + lExt := UpperCase(lExt); + if (lExt='.TGZ') then + Result := true + else + Result := false; +end; + +(*procedure Extract (var lTarFile: string; lOverwrite: boolean); //extract target +VAR + TA : TTarArchive; + DirRec : TTarDirRec; + lPos,lLen,lnumFilesTotal,lnumFilesCompleted,lPct: longint; + lStr,lOutDir,lLocalDir,lFileName,lNewDir,lTarName : String; +begin + lOutDir := extractfiledir(lTarFile); + //next Count files for progress bar.... + lnumFilesTotal := 0; + TA := TTarArchive.Create (lTarFile); + TRY + TA.Reset; + TA.SetFilePos (0); + TA.FindNext (DirRec); + repeat + inc(lnumFilesTotal); + until not TA.FindNext (DirRec); + + FINALLY + TA.Free; + END; + //finished counting files + //next: extract files... + lnumFilesCompleted := 0; + //FProgress := 0; + TA := TTarArchive.Create (lTarFile); + TRY + TA.Reset; + TA.SetFilePos (0); + TA.FindNext (DirRec); + repeat + inc(lNumFilesCompleted); + {lPct := round(lNumFilesCOmpleted/lNumfilesTotal*100); + if lPct > FProgress then begin //only update progress bar 100 times: do not waste time updating screen + FProgress := lPct; + DoOnProgress; + end;} + if DirRec.Name <> '' then begin + //Screen.Cursor := crHourGlass; + TRY + //filename change '/' to '\' + lTarName := ''; + lLen := length(DirRec.name); + for lPos := 1 to lLen do begin + if (DirRec.Name[lPos]='/') or (DirRec.Name[lPos]='\') then + lTarName := lTarName + pathdelim//'\' + else if (DirRec.Name[lPos]=':') then + + else + lTarName := lTarName + DirRec.Name[lPos]; + end; + lFilename := lOutDir+pathdelim+lTarName; + lLocalDir := extractfiledir(lFileName); + if (DirExists(lLocalDir)) then begin + {lProceed := mrYes; + if Fileexists(lFileName) then begin + if (gmrOverwrite = mrYes) or (gmrOverwrite = mrNo) then begin + OverwriteForm.Label1.caption := 'Warning: the file '+lFilename+' already exists.'; + gmrOverwrite := OverwriteForm.Showmodal; + end; + lProceed := gmrOverwrite; + end; } + if lOverwrite{(lProceed = mrYes) or (lProceed = mrYesToAll)} then begin + if (length(lFilename)>2) and ((lFilename[length(lFilename)] = '\') or (lFilename[length(lFilename)] = '/')) then begin + lLen := length(lFilename)-1; + lStr := lFilename; + lFilename := ''; + for lPos := 1 to lLen do + lFilename := lFilename+lStr[lPos]; + if not direxists(lFilename) then begin + mkdir (lFilename); + end; + end else + TA.ReadFile (lFileName); + end; //proceed + end else begin + lLen := length(lTarName); + lPos := 1; + if (lLen >= 1) and ((lTarName[1] = '\') or (lTarName[1] = '/')) then inc(lPos); + lNewDir := lOutDir+pathdelim; + while lPos <= lLen do begin + if (lTarName[lPos] = '\') or (lTarName[lPos] = '/') then begin + //showmessage('creating directory:'+lNewDir); + if not direxists(lNewDir) then + mkdir(lNewDir); + lNewDir := lNewDir + pathdelim; + end else + lNewDir := lNewDir + lTarName[lPos]; + inc(lPos); + end; + if (lFileName[length(lFileName)] <> '/') and(lFileName[length(lFileName)] <> '\') and (DirExists(lLocalDir)) and (not Fileexists(lFileName)) then begin + TA.ReadFile (lFileName) + end; + end; + FINALLY + //Screen.Cursor := crDefault; + END; + end; + until not TA.FindNext (DirRec); + FINALLY + TA.Free; + END; +end;*) + +procedure Extract (var lTarFile: string; lOverwrite: boolean); //extract target +VAR + TA : TTarArchive; + DirRec : TTarDirRec; + lPos,lLen,lnumFilesTotal,lnumFilesCompleted,lPct: longint; + lStr,lOutDir,lLocalDir,lFileName,lNewDir,lTarName : String; +begin + lOutDir := extractfiledir(lTarFile); + //next Count files for progress bar.... + lnumFilesTotal := 0; + TA := TTarArchive.Create (lTarFile); + TRY + TA.Reset; + TA.SetFilePos (0); + TA.FindNext (DirRec); + repeat + inc(lnumFilesTotal); + until not TA.FindNext (DirRec); + + FINALLY + TA.Free; + END; + //finished counting files + //next: extract files... + lnumFilesCompleted := 0; + //FProgress := 0; + TA := TTarArchive.Create (lTarFile); + TRY + TA.Reset; + TA.SetFilePos (0); + TA.FindNext (DirRec); + repeat + inc(lNumFilesCompleted); + {lPct := round(lNumFilesCOmpleted/lNumfilesTotal*100); + if lPct > FProgress then begin //only update progress bar 100 times: do not waste time updating screen + FProgress := lPct; + DoOnProgress; + end;} + if DirRec.Name <> '' then begin + //Screen.Cursor := crHourGlass; + TRY + //filename change '/' to '\' + lTarName := ''; + lLen := length(DirRec.name); + for lPos := 1 to lLen do begin + if (DirRec.Name[lPos]='/') or (DirRec.Name[lPos]='\') then + lTarName := lTarName + pathdelim//'\' + else if (DirRec.Name[lPos]=':') then + + else + lTarName := lTarName + DirRec.Name[lPos]; + end; + lFilename := lOutDir+pathdelim+lTarName; + lLocalDir := extractfiledir(lFileName); + if (DirExists(lLocalDir)) then begin + (*lProceed := mrYes; + if Fileexists(lFileName) then begin + if (gmrOverwrite = mrYes) or (gmrOverwrite = mrNo) then begin + OverwriteForm.Label1.caption := 'Warning: the file '+lFilename+' already exists.'; + gmrOverwrite := OverwriteForm.Showmodal; + end; + lProceed := gmrOverwrite; + end; *) + if lOverwrite{(lProceed = mrYes) or (lProceed = mrYesToAll)} then begin + if (length(lFilename)>2) and (lFilename[length(lFilename)] = pathdelim) then begin + lLen := length(lFilename)-1; + lStr := lFilename; + lFilename := ''; + for lPos := 1 to lLen do + lFilename := lFilename+lStr[lPos]; + if not direxists(lFilename) then begin + mkdir (lFilename); + end; + end else + TA.ReadFile (lFileName); + end; //proceed + end else begin + lLen := length(lTarName); + lPos := 1; + if (lLen >= 1) and (lTarName[1] = pathdelim) then inc(lPos); + lNewDir := lOutDir+pathdelim; + while lPos <= lLen do begin + if (lTarName[lPos] = pathdelim) then begin + //showmessage('creating directory:'+lNewDir); + if not direxists(lNewDir) then + mkdir(lNewDir); + lNewDir := lNewDir + pathdelim; + end else + lNewDir := lNewDir + lTarName[lPos]; + inc(lPos); + end; + if (lFileName[length(lFileName)] <> pathdelim) and (DirExists(lLocalDir)) and (not Fileexists(lFileName)) then begin + TA.ReadFile (lFileName) + end; + end; + FINALLY + //Screen.Cursor := crDefault; + END; + end; + until not TA.FindNext (DirRec); + FINALLY + TA.Free; + END; +end; + + +function FindFile (lDir: String): string; +//lDir should include pathdelim, e.g. c:\folder\ +var lSearchRec: TSearchRec; +begin + result := ''; + if FindFirst(lDir+'*', faAnyFile-faSysFile-faDirectory, lSearchRec) = 0 then + result := lDir +lSearchRec.Name; + FindClose(lSearchRec); +end; + +procedure DeleteTreeX (const Path : string; recursive : boolean); +var + Result : integer; + SearchRec : TSearchRec; +begin + Result := FindFirst(Path + '*', faAnyFile-faDirectory , SearchRec); + while Result = 0 do + begin + if not DeleteFile (Path + SearchRec.name) then + begin + FileSetAttr (Path + SearchRec.name, 0); { reset all flags } + DeleteFile (Path + SearchRec.name); + end; + Result := FindNext(SearchRec); + end; + FindClose(SearchRec); + if not recursive then + exit; + Result := FindFirst(Path + '*.*', faDirectory, SearchRec); + while Result = 0 do + begin + if (SearchRec.name <> '.') and (SearchRec.name <> '..') then + begin + FileSetAttr (Path + SearchRec.name, faDirectory); + DeleteTreeX (Path + SearchRec.name + '\', TRUE); + RmDir (Path + SearchRec.name); + end; + Result := FindNext(SearchRec); + end; + FindClose(SearchRec); +end; + +Procedure copyfile( Const sourcefilename, targetfilename: String ); +Var + S, T: TFileStream; +Begin + S := TFileStream.Create( sourcefilename, fmOpenRead ); + try + T := TFileStream.Create( targetfilename, fmOpenWrite or fmCreate ); + try + T.CopyFrom(S, S.Size ) ; + finally + T.Free; + end; + finally + S.Free; + end; +End; + +procedure CopyDir ( lSourceDir,lDestDir: string); +var + Result : integer; + SearchRec : TSearchRec; + lSrc,lDest: string; +begin + Result := FindFirst(lSourceDir + '*', faAnyFile-faDirectory , SearchRec); + while Result = 0 do begin + lSrc := lSourceDir + SearchRec.name; + lDest := lDestDir + SearchRec.Name; + copyfile(lSrc,lDest); + Result := FindNext(SearchRec); + end; + FindClose(SearchRec); +end; + +function DeTGZ (lFilename: string; lPrefs: TPrefs): boolean; +var + lPath,lName,lExt,lOutPath,lTempDir,lTarName,lDicomName: string; +begin + result := false; + if (not fileexists(lFilename)) or (not isTGZ(lFilename)) then + exit; + FilenameParts (lFilename , lPath,lName,lExt); + + lOutPath := lPath+lName; + if direxists(lOutPath) then begin + dcmMsg('Unable to extract TGZ file - folder exists '+lOutpath); + exit; + end; + MkDir(lOutPath); + lTempDir := lOutPath+pathdelim+'temp'; + MkDir(lTempDir); + lTarName := lTempDir+Pathdelim+lName+'.tar'; + UnGZipFile (lFilename,lTarName); //unzip + Extract (lTarName,true); + deletefile(lTarName); + //now convert files to NIFTI + lDICOMName := FindFile(lTempDir+Pathdelim); + if (lDICOMName = '') or (not fileexists(lDICOMname)) then + exit; + LoadFileList(lDICOMName,lOutPath,lPrefs); + + DeleteTreeX(lTempDir+Pathdelim, true); + RmDir(lTempDir); + if (lPrefs.BackupDir <> '') and (DirExists(lPrefs.BackupDir)) then begin + lTempDir := lPrefs.BackupDir; + if lTempDir[length(lTempDir)] <> pathdelim then + lTempDir := lTempDir + pathdelim; + dcmMsg('Copying to backup folder named '+lTempDir); + CopyDir(lOutPath+pathdelim, lTempDir); + dcmMsg('Backup completed'); + end; + //Extract (lFilename,true); + result := true; +end; + +end. \ No newline at end of file diff --git a/dcm2nii/untar.ppu b/dcm2nii/untar.ppu new file mode 100644 index 0000000..c02c479 Binary files /dev/null and b/dcm2nii/untar.ppu differ diff --git a/dcm2nii/userdir.o b/dcm2nii/userdir.o new file mode 100644 index 0000000..3bf1618 Binary files /dev/null and b/dcm2nii/userdir.o differ diff --git a/dcm2nii/userdir.pas b/dcm2nii/userdir.pas new file mode 100755 index 0000000..a76fc83 --- /dev/null +++ b/dcm2nii/userdir.pas @@ -0,0 +1,220 @@ +unit userdir; +//returns directory where user has read/write permissions... +{$IFDEF FPC} {$mode delphi}{$H+} {$ENDIF} +interface +//returns number of cores: a computer with two dual cores will report 4 +function IniName: string; +function DefaultsDir (lSubFolder: string): string; +function UserDataFolder: string; //uses shlobj + +implementation +{$Include ..\common\isgui.inc} + +{$IFDEF UNIX} +uses Process, SysUtils,classes,IniFiles, +{$IFDEF GUI}dialogs;{$ELSE} dialogsx;{$ENDIF} + +function UserDataFolder: string; +begin + result :=expandfilename('~/'); +end; + + +function FileNameNoExt (lFilewExt:String): string; +//remove final extension +var + lLen,lInc: integer; + lName: String; +begin + lName := ''; + lLen := length(lFilewExt); + lInc := lLen+1; + if lLen > 0 then begin + repeat + dec(lInc); + until (lFileWExt[lInc] = '.') or (lInc = 1); + end; + if lInc > 1 then + for lLen := 1 to (lInc - 1) do + lName := lName + lFileWExt[lLen] + else + lName := lFilewExt; //no extension + Result := lName; +end; + +function DefaultsDir (lSubFolder: string): string; +//for Linux: DefaultsDir is ~/appname/SubFolder/, e.g. /home/username/mricron/subfolder/ +//Note: Final character is pathdelim +const + pathdelim = '/'; +var + lBaseDir: string; +begin + lBaseDir := GetEnvironmentVariable ('HOME')+pathdelim+'.'+ FileNameNoExt(ExtractFilename(paramstr(0) ) ); + if not DirectoryExists(lBaseDir) then begin + {$I-} + MkDir(lBaseDir); + if IOResult <> 0 then begin + //Msg('Unable to create new folder '+lBaseDir); + end; + {$I+} + end; + lBaseDir := lBaseDir+pathdelim; + if lSubFolder <> '' then begin + lBaseDir := lBaseDir + lSubFolder; + if not DirectoryExists(lBaseDir) then begin + {$I-} + MkDir(lBaseDir); + if IOResult <> 0 then begin + //you may want to show an error, e.g. showmessage('Unable to create new folder '+lBaseDir); + exit; + end; + {$I+} + end; + result := lBaseDir + pathdelim; + end else + result := lBaseDir; +end; + +function IniName: string; +begin + result := DefaultsDir('')+FileNameNoExt(extractfilename(paramstr(0)))+'.ini'; +end; +{$ELSE} //If UNIX ELSE NOT Unix +uses + SysUtils, Windows,shlobj; + +//for administrators, we can write to folder with executable, otherwise we will save data to the user's AppDataFolder +function AppDataFolder: string; //uses shlobj +{$IFDEF FPC} const CSIDL_APPDATA = 26; {$ENDIF} +var + Path : pchar; + idList : PItemIDList; +begin + GetMem(Path, MAX_PATH); + SHGetSpecialFolderLocation(0, CSIDL_APPDATA , idList); + SHGetPathFromIDList(idList, Path); + Result := string(Path); + FreeMem(Path); +end; + +function UserDataFolder: string; //uses shlobj +var + PIDL : PItemIDList; + Folder : array[0..MAX_PATH] of Char; + const CSIDL_PERSONAL = $0005; +begin +SHGetSpecialFolderLocation(0, CSIDL_PERSONAL, PIDL); +SHGetPathFromIDList(PIDL, Folder); +result :=Folder; +end; + +(*function UserDataFolder: string; //uses shlobj +var + Path : pchar; + idList : PItemIDList; +begin + GetMem(Path, MAX_PATH); + SHGetSpecialFolderLocation(0, csidl_Personal , idList); + SHGetPathFromIDList(idList, Path); + Result := string(Path); + FreeMem(Path); +end; *) + +function IsAdmin: Boolean; +const + SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = + (Value: (0, 0, 0, 0, 0, 5)); + SECURITY_BUILTIN_DOMAIN_RID = $00000020; + DOMAIN_ALIAS_RID_ADMINS = $00000220; +var + hAccessToken: THandle; + ptgGroups: PTokenGroups; + dwInfoBufferSize: DWORD; + psidAdministrators: PSID; + x: Integer; + bSuccess: BOOL; + LastError: integer; +begin + + if Win32Platform <> VER_PLATFORM_WIN32_NT then + begin + Result := True; + exit; + end; + + Result := False; + bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, + hAccessToken); + if not bSuccess then + begin + if GetLastError = ERROR_NO_TOKEN then + bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, + hAccessToken); + end; + if bSuccess then + begin + GetMem(ptgGroups, 1024); + {$IFDEF FPC} + bSuccess := GetTokenInformation(hAccessToken, TokenGroups, + ptgGroups, 1024, @dwInfoBufferSize); + {$ELSE} + bSuccess := GetTokenInformation(hAccessToken, TokenGroups, + ptgGroups, 1024, dwInfoBufferSize); + {$ENDIF} + LastError := GetLastError; + if not bSuccess then begin + //you may want to show an error message.. + //showmessage(format('GetLastError %d',[LastError])); + end; + CloseHandle(hAccessToken); + if bSuccess then + begin + AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, + SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, + 0, 0, 0, 0, 0, 0, psidAdministrators); + {$R-} + for x := 0 to ptgGroups.GroupCount - 1 do + if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then + begin + Result := True; + break; + end; + {$R+} + FreeSid(psidAdministrators); + end; + FreeMem(ptgGroups); + end; +end; + + +function IniName: string; +//only administrators can write to c:\program files -use AppDataFolder for non-Administrators +begin + if isAdmin then + result := changefileext(paramstr(0),'.ini') + else + result := AppDataFolder+'\'+changefileext(extractfilename(paramstr(0)),'.ini'); +end; + +function DefaultsDir (lSubFolder: string): string; +const + pathdelim = '\'; +//for Administrators: DefaultsDir is in the location of the executable, e.g. c:\program files\mricron\subfolder\ +//for non-Administrators, the AppDataFolder is returned +//Note: Final character is pathdelim +begin + result := extractfilepath(IniName); + if length(result) < 1 then exit; + if result[length(result)] <> pathdelim then + result := result + pathdelim; + if lSubFolder = '' then + exit; + result := result + lSubFolder; + if result[length(result)] <> pathdelim then + result := result + pathdelim; + +end; +{$ENDIF} + +end. diff --git a/dcm2nii/userdir.ppu b/dcm2nii/userdir.ppu new file mode 100644 index 0000000..86d59e5 Binary files /dev/null and b/dcm2nii/userdir.ppu differ diff --git a/dcm2nii/windowsxp.res b/dcm2nii/windowsxp.res new file mode 100755 index 0000000..5f33505 Binary files /dev/null and b/dcm2nii/windowsxp.res differ diff --git a/dcm2nii/zconf.inc b/dcm2nii/zconf.inc new file mode 100755 index 0000000..0f9e451 --- /dev/null +++ b/dcm2nii/zconf.inc @@ -0,0 +1,24 @@ +{ -------------------------------------------------------------------- } + +{$DEFINE MAX_MATCH_IS_258} + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{- $DEFINE MAXSEG_64K} +{$IFNDEF WIN32} + {$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } +{$ENDIF} + +{$UNDEF DYNAMIC_CRC_TABLE} +{$UNDEF FASTEST} +{$define patch112} { apply patch from the zlib home page } +{ -------------------------------------------------------------------- } +{$IFDEF FPC} + {$DEFINE Use32} + {$UNDEF DPMI} + {$UNDEF MSDOS} + {$UNDEF UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } + {$UNDEF MAXSEG_64K} +{$ENDIF} + diff --git a/delphionly/ADLER.PAS b/delphionly/ADLER.PAS new file mode 100755 index 0000000..c68e656 --- /dev/null +++ b/delphionly/ADLER.PAS @@ -0,0 +1,114 @@ +Unit Adler; + +{ + adler32.c -- compute the Adler-32 checksum of a data stream + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil; + +function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; + +{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and + return the updated checksum. If buf is NIL, this function returns + the required initial value for the checksum. + An Adler-32 checksum is almost as reliable as a CRC32 but can be computed + much faster. Usage example: + + var + adler : uLong; + begin + adler := adler32(0, Z_NULL, 0); + + while (read_buffer(buffer, length) <> EOF) do + adler := adler32(adler, buffer, length); + + if (adler <> original_adler) then + error(); + end; +} + +implementation + +const + BASE = uLong(65521); { largest prime smaller than 65536 } + {NMAX = 5552; original code with unsigned 32 bit integer } + { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 } + NMAX = 3854; { code with signed 32 bit integer } + { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 } + { The penalty is the time loss in the extra MOD-calls. } + + +{ ========================================================================= } + +function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; +var + s1, s2 : uLong; + k : int; +begin + s1 := adler and $ffff; + s2 := (adler shr 16) and $ffff; + + if not Assigned(buf) then + begin + adler32 := uLong(1); + exit; + end; + + while (len > 0) do + begin + if len < NMAX then + k := len + else + k := NMAX; + Dec(len, k); + { + while (k >= 16) do + begin + DO16(buf); + Inc(buf, 16); + Dec(k, 16); + end; + if (k <> 0) then + repeat + Inc(s1, buf^); + Inc(puf); + Inc(s2, s1); + Dec(k); + until (k = 0); + } + while (k > 0) do + begin + Inc(s1, buf^); + Inc(s2, s1); + Inc(buf); + Dec(k); + end; + s1 := s1 mod BASE; + s2 := s2 mod BASE; + end; + adler32 := (s2 shl 16) or s1; +end; + +{ +#define DO1(buf,i) + begin + Inc(s1, buf[i]); + Inc(s2, s1); + end; +#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1); +#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2); +#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4); +#define DO16(buf) DO8(buf,0); DO8(buf,8); +} +end. + diff --git a/delphionly/CRC.PAS b/delphionly/CRC.PAS new file mode 100755 index 0000000..e20608c --- /dev/null +++ b/delphionly/CRC.PAS @@ -0,0 +1,237 @@ +Unit Crc; + +{ + crc32.c -- compute the CRC-32 of a data stream + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil, zlib; + + +function crc32(crc : uLong; buf : pBytef; len : uInt) : uLong; + +{ Update a running crc with the bytes buf[0..len-1] and return the updated + crc. If buf is NULL, this function returns the required initial value + for the crc. Pre- and post-conditioning (one's complement) is performed + within this function so it shouldn't be done by the application. + Usage example: + + var + crc : uLong; + begin + crc := crc32(0, Z_NULL, 0); + + while (read_buffer(buffer, length) <> EOF) do + crc := crc32(crc, buffer, length); + + if (crc <> original_crc) then error(); + end; + +} + +function get_crc_table : puLong; { can be used by asm versions of crc32() } + + +implementation + +{$IFDEF DYNAMIC_CRC_TABLE} + +{local} +const + crc_table_empty : boolean = TRUE; +{local} +var + crc_table : array[0..256-1] of uLongf; + + +{ + Generate a table for a byte-wise 32-bit CRC calculation on the polynomial: + x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1. + + Polynomials over GF(2) are represented in binary, one bit per coefficient, + with the lowest powers in the most significant bit. Then adding polynomials + is just exclusive-or, and multiplying a polynomial by x is a right shift by + one. If we call the above polynomial p, and represent a byte as the + polynomial q, also with the lowest power in the most significant bit (so the + byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p, + where a mod b means the remainder after dividing a by b. + + This calculation is done using the shift-register method of multiplying and + taking the remainder. The register is initialized to zero, and for each + incoming bit, x^32 is added mod p to the register if the bit is a one (where + x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by + x (which is shifting right by one and adding x^32 mod p if the bit shifted + out is a one). We start with the highest power (least significant bit) of + q and repeat for all eight bits of q. + + The table is simply the CRC of all possible eight bit values. This is all + the information needed to generate CRC's on data a byte at a time for all + combinations of CRC register values and incoming bytes. +} +{local} +procedure make_crc_table; +var + c : uLong; + n,k : int; + poly : uLong; { polynomial exclusive-or pattern } + +const + { terms of polynomial defining this crc (except x^32): } + p: array [0..13] of Byte = (0,1,2,4,5,7,8,10,11,12,16,22,23,26); + +begin + { make exclusive-or pattern from polynomial ($EDB88320) } + poly := Long(0); + for n := 0 to (sizeof(p) div sizeof(Byte))-1 do + poly := poly or (Long(1) shl (31 - p[n])); + + for n := 0 to 255 do + begin + c := uLong(n); + for k := 0 to 7 do + begin + if (c and 1) <> 0 then + c := poly xor (c shr 1) + else + c := (c shr 1); + end; + crc_table[n] := c; + end; + crc_table_empty := FALSE; +end; + +{$ELSE} + +{ ======================================================================== + Table of CRC-32's of all single-byte values (made by make_crc_table) } + +{local} +const + crc_table : array[0..256-1] of uLongf = ( + $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, + $706af48f, $e963a535, $9e6495a3, $0edb8832, $79dcb8a4, + $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, + $90bf1d91, $1db71064, $6ab020f2, $f3b97148, $84be41de, + $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7, $136c9856, + $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, + $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, + $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, + $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, + $45df5c75, $dcd60dcf, $abd13d59, $26d930ac, $51de003a, + $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, + $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924, + $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, + $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, + $9fbfe4a5, $e8b8d433, $7807c9a2, $0f00f934, $9609a88e, + $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01, + $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, + $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950, + $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, + $fbd44c65, $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, + $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, $4369e96a, + $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, + $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa, $be0b1010, + $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f, + $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, + $2eb40d81, $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, + $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, + $73dc1683, $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, + $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, $f00f9344, + $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, + $196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, + $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, + $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, + $a6bc5767, $3fb506dd, $48b2364b, $d80d2bda, $af0a1b4c, + $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, + $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236, + $cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, + $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, + $2cd99e8b, $5bdeae1d, $9b64c2b0, $ec63f226, $756aa39c, + $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713, + $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, + $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242, + $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, + $18b74777, $88085ae6, $ff0f6a70, $66063bca, $11010b5c, + $8f659eff, $f862ae69, $616bffd3, $166ccf45, $a00ae278, + $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, + $4969474d, $3e6e77db, $aed16a4a, $d9d65adc, $40df0b66, + $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9, + $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, + $cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8, + $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, + $2d02ef8d); + +{$ENDIF} + +{ ========================================================================= + This function can be used by asm versions of crc32() } + +function get_crc_table : {const} puLong; +begin +{$ifdef DYNAMIC_CRC_TABLE} + if (crc_table_empty) then + make_crc_table; +{$endif} + get_crc_table := {const} puLong(@crc_table); +end; + +{ ========================================================================= } + +function crc32 (crc : uLong; buf : pBytef; len : uInt): uLong; +begin + if (buf = Z_NULL) then + crc32 := Long(0) + else + begin + +{$IFDEF DYNAMIC_CRC_TABLE} + if crc_table_empty then + make_crc_table; +{$ENDIF} + + crc := crc xor uLong($ffffffff); + while (len >= 8) do + begin + {DO8(buf)} + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + + Dec(len, 8); + end; + if (len <> 0) then + repeat + {DO1(buf)} + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + + Dec(len); + until (len = 0); + crc32 := crc xor uLong($ffffffff); + end; +end; + + +end. \ No newline at end of file diff --git a/delphionly/InfCodes.pas b/delphionly/InfCodes.pas new file mode 100755 index 0000000..7efc590 --- /dev/null +++ b/delphionly/InfCodes.pas @@ -0,0 +1,576 @@ +Unit InfCodes; + +{ infcodes.c -- process literals and length/distance pairs + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + {$IFDEF DEBUG} + strutils, + {$ENDIF} + zutil, zlib; + +function inflate_codes_new (bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var z : z_stream): pInflate_codes_state; + +function inflate_codes(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; + +procedure inflate_codes_free(c : pInflate_codes_state; + var z : z_stream); + +implementation + +uses + infutil, inffast; + + +function inflate_codes_new (bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var z : z_stream): pInflate_codes_state; +var + c : pInflate_codes_state; +begin + c := pInflate_codes_state( ZALLOC(z,1,sizeof(inflate_codes_state)) ); + if (c <> Z_NULL) then + begin + c^.mode := START; + c^.lbits := Byte(bl); + c^.dbits := Byte(bd); + c^.ltree := tl; + c^.dtree := td; + {$IFDEF DEBUG} + Tracev('inflate: codes new'); + {$ENDIF} + end; + inflate_codes_new := c; +end; + + +function inflate_codes(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; +var + j : uInt; { temporary storage } + t : pInflate_huft; { temporary pointer } + e : uInt; { extra bits or operation } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } + f : pBytef; { pointer to copy strings from } +var + c : pInflate_codes_state; +begin + c := s.sub.decode.codes; { codes state } + + { copy input/output information to locals } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + { process input and output based on current state } + while True do + case (c^.mode) of + { waiting for "i:"=input, "o:"=output, "x:"=nothing } + START: { x: set up for LEN } + begin +{$ifndef SLOW} + if (m >= 258) and (n >= 10) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + r := inflate_fast(c^.lbits, c^.dbits, c^.ltree, c^.dtree, s, z); + {LOAD} + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + if (r <> Z_OK) then + begin + if (r = Z_STREAM_END) then + c^.mode := WASH + else + c^.mode := BADCODE; + continue; { break for switch-statement in C } + end; + end; +{$endif} { not SLOW } + c^.sub.code.need := c^.lbits; + c^.sub.code.tree := c^.ltree; + c^.mode := LEN; { falltrough } + end; + LEN: { i: get length/literal/eob next } + begin + j := c^.sub.code.need; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + t := c^.sub.code.tree; + Inc(t, uInt(b) and inflate_mask[j]); + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + e := uInt(t^.exop); + if (e = 0) then { literal } + begin + c^.sub.lit := t^.base; + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: literal '+char(t^.base)) + else + Tracevv('inflate: literal '+IntToStr(t^.base)); + {$ENDIF} + c^.mode := LIT; + continue; { break switch statement } + end; + if (e and 16 <> 0) then { length } + begin + c^.sub.copy.get := e and 15; + c^.len := t^.base; + c^.mode := LENEXT; + continue; { break C-switch statement } + end; + if (e and 64 = 0) then { next table } + begin + c^.sub.code.need := e; + c^.sub.code.tree := @huft_ptr(t)^[t^.base]; + continue; { break C-switch statement } + end; + if (e and 32 <> 0) then { end of block } + begin + {$IFDEF DEBUG} + Tracevv('inflate: end of block'); + {$ENDIF} + c^.mode := WASH; + continue; { break C-switch statement } + end; + c^.mode := BADCODE; { invalid code } + z.msg := 'invalid literal/length code'; + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + LENEXT: { i: getting length extra (have base) } + begin + j := c^.sub.copy.get; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + Inc(c^.len, uInt(b and inflate_mask[j])); + {DUMPBITS(j);} + b := b shr j; + Dec(k, j); + + c^.sub.code.need := c^.dbits; + c^.sub.code.tree := c^.dtree; + {$IFDEF DEBUG} + Tracevv('inflate: length '+IntToStr(c^.len)); + {$ENDIF} + c^.mode := DIST; + { falltrough } + end; + DIST: { i: get distance next } + begin + j := c^.sub.code.need; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + t := @huft_ptr(c^.sub.code.tree)^[uInt(b) and inflate_mask[j]]; + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + e := uInt(t^.exop); + if (e and 16 <> 0) then { distance } + begin + c^.sub.copy.get := e and 15; + c^.sub.copy.dist := t^.base; + c^.mode := DISTEXT; + continue; { break C-switch statement } + end; + if (e and 64 = 0) then { next table } + begin + c^.sub.code.need := e; + c^.sub.code.tree := @huft_ptr(t)^[t^.base]; + continue; { break C-switch statement } + end; + c^.mode := BADCODE; { invalid code } + z.msg := 'invalid distance code'; + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + DISTEXT: { i: getting distance extra } + begin + j := c^.sub.copy.get; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + Inc(c^.sub.copy.dist, uInt(b) and inflate_mask[j]); + {DUMPBITS(j);} + b := b shr j; + Dec(k, j); + {$IFDEF DEBUG} + Tracevv('inflate: distance '+ IntToStr(c^.sub.copy.dist)); + {$ENDIF} + c^.mode := COPYZ; + { falltrough } + end; + COPYZ: { o: copying bytes in window, waiting for space } + begin + f := q; + Dec(f, c^.sub.copy.dist); + if (uInt(ptr2int(q) - ptr2int(s.window)) < c^.sub.copy.dist) then + begin + f := s.zend; + Dec(f, c^.sub.copy.dist - uInt(ptr2int(q) - ptr2int(s.window))); + end; + + while (c^.len <> 0) do + begin + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + {OUTBYTE( *f++)} + q^ := f^; + Inc(q); + Inc(f); + Dec(m); + + if (f = s.zend) then + f := s.window; + Dec(c^.len); + end; + c^.mode := START; + { C-switch break; not needed } + end; + LIT: { o: got literal, waiting for output space } + begin + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + {OUTBYTE(c^.sub.lit);} + q^ := c^.sub.lit; + Inc(q); + Dec(m); + + c^.mode := START; + {break;} + end; + WASH: { o: got eob, possibly more output } + begin + {$ifdef patch112} + if (k > 7) then { return unused byte, if any } + begin + {$IFDEF DEBUG} + Assert(k < 16, 'inflate_codes grabbed too many bytes'); + {$ENDIF} + Dec(k, 8); + Inc(n); + Dec(p); { can always return one } + end; + {$endif} + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + if (s.read <> s.write) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + c^.mode := ZEND; + { falltrough } + end; + + ZEND: + begin + r := Z_STREAM_END; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + BADCODE: { x: got error } + begin + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + else + begin + r := Z_STREAM_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; +{NEED_DUMMY_RETURN - Delphi2+ dumb compilers complain without this } + inflate_codes := Z_STREAM_ERROR; +end; + + +procedure inflate_codes_free(c : pInflate_codes_state; + var z : z_stream); +begin + ZFREE(z, c); + {$IFDEF DEBUG} + Tracev('inflate: codes free'); + {$ENDIF} +end; + +end. \ No newline at end of file diff --git a/delphionly/ZCONF.INC b/delphionly/ZCONF.INC new file mode 100755 index 0000000..c7bd86b --- /dev/null +++ b/delphionly/ZCONF.INC @@ -0,0 +1,32 @@ +{ -------------------------------------------------------------------- } + +{$DEFINE MAX_MATCH_IS_258} + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{- $DEFINE MAXSEG_64K} +{$IFDEF VER70} + {$DEFINE MAXSEG_64K} +{$ENDIF} +{$IFNDEF WIN32} + {$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } +{$ENDIF} + +{$UNDEF DYNAMIC_CRC_TABLE} +{$UNDEF FASTEST} +{$define patch112} { apply patch from the zlib home page } +{ -------------------------------------------------------------------- } +{$IFDEF WIN32} + {$DEFINE Delphi32} + {- $DEFINE Delphi5} { keep compiler quiet } +{$ENDIF} + +{$IFDEF FPC} + {$DEFINE Use32} + {$UNDEF DPMI} + {$UNDEF MSDOS} + {$UNDEF UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } + {$UNDEF MAXSEG_64K} + {$UNDEF Delphi32} +{$ENDIF} diff --git a/delphionly/ZINFLATE.PAS b/delphionly/ZINFLATE.PAS new file mode 100755 index 0000000..07935b4 --- /dev/null +++ b/delphionly/ZINFLATE.PAS @@ -0,0 +1,750 @@ +Unit zInflate; + +{ inflate.c -- zlib interface to inflate modules + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil, zlib, infblock, infutil; + +function inflateInit(var z : z_stream) : int; + +{ Initializes the internal stream state for decompression. The fields + zalloc, zfree and opaque must be initialized before by the caller. If + zalloc and zfree are set to Z_NULL, inflateInit updates them to use default + allocation functions. + + inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_VERSION_ERROR if the zlib library version is incompatible + with the version assumed by the caller. msg is set to null if there is no + error message. inflateInit does not perform any decompression: this will be + done by inflate(). } + + + +function inflateInit_(z : z_streamp; + const version : string; + stream_size : int) : int; + + +function inflateInit2_(var z: z_stream; + w : int; + const version : string; + stream_size : int) : int; + +function inflateInit2(var z: z_stream; + windowBits : int) : int; + +{ + This is another version of inflateInit with an extra parameter. The + fields next_in, avail_in, zalloc, zfree and opaque must be initialized + before by the caller. + + The windowBits parameter is the base two logarithm of the maximum window + size (the size of the history buffer). It should be in the range 8..15 for + this version of the library. The default value is 15 if inflateInit is used + instead. If a compressed stream with a larger window size is given as + input, inflate() will return with the error code Z_DATA_ERROR instead of + trying to allocate a larger window. + + inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough + memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative + memLevel). msg is set to null if there is no error message. inflateInit2 + does not perform any decompression apart from reading the zlib header if + present: this will be done by inflate(). (So next_in and avail_in may be + modified, but next_out and avail_out are unchanged.) +} + + + +function inflateEnd(var z : z_stream) : int; + +{ + All dynamically allocated data structures for this stream are freed. + This function discards any unprocessed input and does not flush any + pending output. + + inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state + was inconsistent. In the error case, msg may be set but then points to a + static string (which must not be deallocated). +} + +function inflateReset(var z : z_stream) : int; + +{ + This function is equivalent to inflateEnd followed by inflateInit, + but does not free and reallocate all the internal decompression state. + The stream will keep attributes that may have been set by inflateInit2. + + inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source + stream state was inconsistent (such as zalloc or state being NULL). +} + + +function inflate(var z : z_stream; + f : int) : int; +{ + inflate decompresses as much data as possible, and stops when the input + buffer becomes empty or the output buffer becomes full. It may introduce + some output latency (reading input without producing any output) + except when forced to flush. + + The detailed semantics are as follows. inflate performs one or both of the + following actions: + + - Decompress more input starting at next_in and update next_in and avail_in + accordingly. If not all input can be processed (because there is not + enough room in the output buffer), next_in is updated and processing + will resume at this point for the next call of inflate(). + + - Provide more output starting at next_out and update next_out and avail_out + accordingly. inflate() provides as much output as possible, until there + is no more input data or no more space in the output buffer (see below + about the flush parameter). + + Before the call of inflate(), the application should ensure that at least + one of the actions is possible, by providing more input and/or consuming + more output, and updating the next_* and avail_* values accordingly. + The application can consume the uncompressed output when it wants, for + example when the output buffer is full (avail_out == 0), or after each + call of inflate(). If inflate returns Z_OK and with zero avail_out, it + must be called again after making room in the output buffer because there + might be more output pending. + + If the parameter flush is set to Z_SYNC_FLUSH, inflate flushes as much + output as possible to the output buffer. The flushing behavior of inflate is + not specified for values of the flush parameter other than Z_SYNC_FLUSH + and Z_FINISH, but the current implementation actually flushes as much output + as possible anyway. + + inflate() should normally be called until it returns Z_STREAM_END or an + error. However if all decompression is to be performed in a single step + (a single call of inflate), the parameter flush should be set to + Z_FINISH. In this case all pending input is processed and all pending + output is flushed; avail_out must be large enough to hold all the + uncompressed data. (The size of the uncompressed data may have been saved + by the compressor for this purpose.) The next operation on this stream must + be inflateEnd to deallocate the decompression state. The use of Z_FINISH + is never required, but can be used to inform inflate that a faster routine + may be used for the single inflate() call. + + If a preset dictionary is needed at this point (see inflateSetDictionary + below), inflate sets strm-adler to the adler32 checksum of the + dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise + it sets strm->adler to the adler32 checksum of all output produced + so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or + an error code as described below. At the end of the stream, inflate() + checks that its computed adler32 checksum is equal to that saved by the + compressor and returns Z_STREAM_END only if the checksum is correct. + + inflate() returns Z_OK if some progress has been made (more input processed + or more output produced), Z_STREAM_END if the end of the compressed data has + been reached and all uncompressed output has been produced, Z_NEED_DICT if a + preset dictionary is needed at this point, Z_DATA_ERROR if the input data was + corrupted (input stream not conforming to the zlib format or incorrect + adler32 checksum), Z_STREAM_ERROR if the stream structure was inconsistent + (for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not + enough memory, Z_BUF_ERROR if no progress is possible or if there was not + enough room in the output buffer when Z_FINISH is used. In the Z_DATA_ERROR + case, the application may then call inflateSync to look for a good + compression block. +} + + +function inflateSetDictionary(var z : z_stream; + dictionary : pBytef; {const array of byte} + dictLength : uInt) : int; + +{ + Initializes the decompression dictionary from the given uncompressed byte + sequence. This function must be called immediately after a call of inflate + if this call returned Z_NEED_DICT. The dictionary chosen by the compressor + can be determined from the Adler32 value returned by this call of + inflate. The compressor and decompressor must use exactly the same + dictionary (see deflateSetDictionary). + + inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a + parameter is invalid (such as NULL dictionary) or the stream state is + inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the + expected one (incorrect Adler32 value). inflateSetDictionary does not + perform any decompression: this will be done by subsequent calls of + inflate(). +} + +function inflateSync(var z : z_stream) : int; + +{ + Skips invalid compressed data until a full flush point (see above the + description of deflate with Z_FULL_FLUSH) can be found, or until all + available input is skipped. No output is provided. + + inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR + if no more input was provided, Z_DATA_ERROR if no flush point has been found, + or Z_STREAM_ERROR if the stream structure was inconsistent. In the success + case, the application may save the current current value of total_in which + indicates where valid compressed data was found. In the error case, the + application may repeatedly call inflateSync, providing more input each time, + until success or end of the input data. +} + + +function inflateSyncPoint(var z : z_stream) : int; + + +implementation + +uses + adler; + +function inflateReset(var z : z_stream) : int; +begin + if (z.state = Z_NULL) then + begin + inflateReset := Z_STREAM_ERROR; + exit; + end; + z.total_out := 0; + z.total_in := 0; + z.msg := ''; + if z.state^.nowrap then + z.state^.mode := BLOCKS + else + z.state^.mode := METHOD; + inflate_blocks_reset(z.state^.blocks^, z, Z_NULL); + {$IFDEF DEBUG} + Tracev('inflate: reset'); + {$ENDIF} + inflateReset := Z_OK; +end; + + +function inflateEnd(var z : z_stream) : int; +begin + if (z.state = Z_NULL) or not Assigned(z.zfree) then + begin + inflateEnd := Z_STREAM_ERROR; + exit; + end; + if (z.state^.blocks <> Z_NULL) then + inflate_blocks_free(z.state^.blocks, z); + ZFREE(z, z.state); + z.state := Z_NULL; + {$IFDEF DEBUG} + Tracev('inflate: end'); + {$ENDIF} + inflateEnd := Z_OK; +end; + + +function inflateInit2_(var z: z_stream; + w : int; + const version : string; + stream_size : int) : int; +begin + if (version = '') or (version[1] <> ZLIB_VERSION[1]) or + (stream_size <> sizeof(z_stream)) then + begin + inflateInit2_ := Z_VERSION_ERROR; + exit; + end; + { initialize state } + { SetLength(strm.msg, 255); } + z.msg := ''; + if not Assigned(z.zalloc) then + begin + {$IFDEF FPC} z.zalloc := @zcalloc; {$ELSE} + z.zalloc := zcalloc; + {$endif} + z.opaque := voidpf(0); + end; + if not Assigned(z.zfree) then + {$IFDEF FPC} z.zfree := @zcfree; {$ELSE} + z.zfree := zcfree; + {$ENDIF} + + z.state := pInternal_state( ZALLOC(z,1,sizeof(internal_state)) ); + if (z.state = Z_NULL) then + begin + inflateInit2_ := Z_MEM_ERROR; + exit; + end; + + z.state^.blocks := Z_NULL; + + { handle undocumented nowrap option (no zlib header or check) } + z.state^.nowrap := FALSE; + if (w < 0) then + begin + w := - w; + z.state^.nowrap := TRUE; + end; + + { set window size } + if (w < 8) or (w > 15) then + begin + inflateEnd(z); + inflateInit2_ := Z_STREAM_ERROR; + exit; + end; + z.state^.wbits := uInt(w); + + { create inflate_blocks state } + if z.state^.nowrap then + z.state^.blocks := inflate_blocks_new(z, NIL, uInt(1) shl w) + else + {$IFDEF FPC} + z.state^.blocks := inflate_blocks_new(z, @adler32, uInt(1) shl w); + {$ELSE} + z.state^.blocks := inflate_blocks_new(z, adler32, uInt(1) shl w); + {$ENDIF} + if (z.state^.blocks = Z_NULL) then + begin + inflateEnd(z); + inflateInit2_ := Z_MEM_ERROR; + exit; + end; + {$IFDEF DEBUG} + Tracev('inflate: allocated'); + {$ENDIF} + { reset state } + inflateReset(z); + inflateInit2_ := Z_OK; +end; + +function inflateInit2(var z: z_stream; windowBits : int) : int; +begin + inflateInit2 := inflateInit2_(z, windowBits, ZLIB_VERSION, sizeof(z_stream)); +end; + + +function inflateInit(var z : z_stream) : int; +{ inflateInit is a macro to allow checking the zlib version + and the compiler's view of z_stream: } +begin + inflateInit := inflateInit2_(z, DEF_WBITS, ZLIB_VERSION, sizeof(z_stream)); +end; + +function inflateInit_(z : z_streamp; + const version : string; + stream_size : int) : int; +begin + { initialize state } + if (z = Z_NULL) then + inflateInit_ := Z_STREAM_ERROR + else + inflateInit_ := inflateInit2_(z^, DEF_WBITS, version, stream_size); +end; + +function inflate(var z : z_stream; + f : int) : int; +var + r : int; + b : uInt; +begin + if (z.state = Z_NULL) or (z.next_in = Z_NULL) then + begin + inflate := Z_STREAM_ERROR; + exit; + end; + if f = Z_FINISH then + f := Z_BUF_ERROR + else + f := Z_OK; + r := Z_BUF_ERROR; + while True do + case (z.state^.mode) of + BLOCKS: + begin + r := inflate_blocks(z.state^.blocks^, z, r); + if (r = Z_DATA_ERROR) then + begin + z.state^.mode := BAD; + z.state^.sub.marker := 0; { can try inflateSync } + continue; { break C-switch } + end; + if (r = Z_OK) then + r := f; + if (r <> Z_STREAM_END) then + begin + inflate := r; + exit; + end; + r := f; + inflate_blocks_reset(z.state^.blocks^, z, @z.state^.sub.check.was); + if (z.state^.nowrap) then + begin + z.state^.mode := DONE; + continue; { break C-switch } + end; + z.state^.mode := CHECK4; { falltrough } + end; + CHECK4: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.check.need := uLong(z.next_in^) shl 24; + Inc(z.next_in); + + z.state^.mode := CHECK3; { falltrough } + end; + CHECK3: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16); + Inc(z.next_in); + + z.state^.mode := CHECK2; { falltrough } + end; + CHECK2: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8); + Inc(z.next_in); + + z.state^.mode := CHECK1; { falltrough } + end; + CHECK1: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) );} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) ); + Inc(z.next_in); + + + if (z.state^.sub.check.was <> z.state^.sub.check.need) then + begin + z.state^.mode := BAD; + z.msg := 'incorrect data check'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + {$IFDEF DEBUG} + Tracev('inflate: zlib check ok'); + {$ENDIF} + z.state^.mode := DONE; { falltrough } + end; + DONE: + begin + inflate := Z_STREAM_END; + exit; + end; + METHOD: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; {} + + {z.state^.sub.method := NEXTBYTE(z);} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.method := z.next_in^; + Inc(z.next_in); + + if ((z.state^.sub.method and $0f) <> Z_DEFLATED) then + begin + z.state^.mode := BAD; + z.msg := 'unknown compression method'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + if ((z.state^.sub.method shr 4) + 8 > z.state^.wbits) then + begin + z.state^.mode := BAD; + z.msg := 'invalid window size'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + z.state^.mode := FLAG; + { fall trough } + end; + FLAG: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; {} + {b := NEXTBYTE(z);} + Dec(z.avail_in); + Inc(z.total_in); + b := z.next_in^; + Inc(z.next_in); + + if (((z.state^.sub.method shl 8) + b) mod 31) <> 0 then {% mod ?} + begin + z.state^.mode := BAD; + z.msg := 'incorrect header check'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + {$IFDEF DEBUG} + Tracev('inflate: zlib header ok'); + {$ENDIF} + if ((b and PRESET_DICT) = 0) then + begin + z.state^.mode := BLOCKS; + continue; { break C-switch } + end; + z.state^.mode := DICT4; + { falltrough } + end; + DICT4: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.check.need := uLong(z.next_in^) shl 24; + Inc(z.next_in); + + z.state^.mode := DICT3; { falltrough } + end; + DICT3: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16); + Inc(z.next_in); + + z.state^.mode := DICT2; { falltrough } + end; + DICT2: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8); + Inc(z.next_in); + + z.state^.mode := DICT1; { falltrough } + end; + DICT1: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + { r := f; --- wird niemals benutzt } + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) );} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) ); + Inc(z.next_in); + + z.adler := z.state^.sub.check.need; + z.state^.mode := DICT0; + inflate := Z_NEED_DICT; + exit; + end; + DICT0: + begin + z.state^.mode := BAD; + z.msg := 'need dictionary'; + z.state^.sub.marker := 0; { can try inflateSync } + inflate := Z_STREAM_ERROR; + exit; + end; + BAD: + begin + inflate := Z_DATA_ERROR; + exit; + end; + else + begin + inflate := Z_STREAM_ERROR; + exit; + end; + end; +{$ifdef NEED_DUMMY_result} + result := Z_STREAM_ERROR; { Some dumb compilers complain without this } +{$endif} +end; + +function inflateSetDictionary(var z : z_stream; + dictionary : pBytef; {const array of byte} + dictLength : uInt) : int; +var + length : uInt; +begin + length := dictLength; + + if (z.state = Z_NULL) or (z.state^.mode <> DICT0) then + begin + inflateSetDictionary := Z_STREAM_ERROR; + exit; + end; + if (adler32(Long(1), dictionary, dictLength) <> z.adler) then + begin + inflateSetDictionary := Z_DATA_ERROR; + exit; + end; + z.adler := Long(1); + + if (length >= (uInt(1) shl z.state^.wbits)) then + begin + length := (1 shl z.state^.wbits)-1; + Inc( dictionary, dictLength - length); + end; + inflate_set_dictionary(z.state^.blocks^, dictionary^, length); + z.state^.mode := BLOCKS; + inflateSetDictionary := Z_OK; +end; + + +function inflateSync(var z : z_stream) : int; +const + mark : packed array[0..3] of byte = (0, 0, $ff, $ff); +var + n : uInt; { number of bytes to look at } + p : pBytef; { pointer to bytes } + m : uInt; { number of marker bytes found in a row } + r, w : uLong; { temporaries to save total_in and total_out } +begin + { set up } + if (z.state = Z_NULL) then + begin + inflateSync := Z_STREAM_ERROR; + exit; + end; + if (z.state^.mode <> BAD) then + begin + z.state^.mode := BAD; + z.state^.sub.marker := 0; + end; + n := z.avail_in; + if (n = 0) then + begin + inflateSync := Z_BUF_ERROR; + exit; + end; + p := z.next_in; + m := z.state^.sub.marker; + + { search } + while (n <> 0) and (m < 4) do + begin + if (p^ = mark[m]) then + Inc(m) + else + if (p^ <> 0) then + m := 0 + else + m := 4 - m; + Inc(p); + Dec(n); + end; + + { restore } + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + z.avail_in := n; + z.state^.sub.marker := m; + + + { return no joy or set up to restart on a new block } + if (m <> 4) then + begin + inflateSync := Z_DATA_ERROR; + exit; + end; + r := z.total_in; + w := z.total_out; + inflateReset(z); + z.total_in := r; + z.total_out := w; + z.state^.mode := BLOCKS; + inflateSync := Z_OK; +end; + + +{ + returns true if inflate is currently at the end of a block generated + by Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP + implementation to provide an additional safety check. PPP uses Z_SYNC_FLUSH + but removes the length bytes of the resulting empty stored block. When + decompressing, PPP checks that at the end of input packet, inflate is + waiting for these length bytes. +} + +function inflateSyncPoint(var z : z_stream) : int; +begin + if (z.state = Z_NULL) or (z.state^.blocks = Z_NULL) then + begin + inflateSyncPoint := Z_STREAM_ERROR; + exit; + end; + inflateSyncPoint := inflate_blocks_sync_point(z.state^.blocks^); +end; + +end. diff --git a/delphionly/Zdeflate.pas b/delphionly/Zdeflate.pas new file mode 100755 index 0000000..34fb8ab --- /dev/null +++ b/delphionly/Zdeflate.pas @@ -0,0 +1,2133 @@ +Unit zDeflate; + +{ Orginal: deflate.h -- internal compression state + deflate.c -- compress data using the deflation algorithm + Copyright (C) 1995-1996 Jean-loup Gailly. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + + +{ ALGORITHM + + The "deflation" process depends on being able to identify portions + of the input text which are identical to earlier input (within a + sliding window trailing behind the input currently being processed). + + The most straightforward technique turns out to be the fastest for + most input files: try all possible matches and select the longest. + The key feature of this algorithm is that insertions into the string + dictionary are very simple and thus fast, and deletions are avoided + completely. Insertions are performed at each input character, whereas + string matches are performed only when the previous match ends. So it + is preferable to spend more time in matches to allow very fast string + insertions and avoid deletions. The matching algorithm for small + strings is inspired from that of Rabin & Karp. A brute force approach + is used to find longer strings when a small match has been found. + A similar algorithm is used in comic (by Jan-Mark Wams) and freeze + (by Leonid Broukhis). + A previous version of this file used a more sophisticated algorithm + (by Fiala and Greene) which is guaranteed to run in linear amortized + time, but has a larger average cost, uses more memory and is patented. + However the F&G algorithm may be faster for some highly redundant + files if the parameter max_chain_length (described below) is too large. + + ACKNOWLEDGEMENTS + + The idea of lazy evaluation of matches is due to Jan-Mark Wams, and + I found it in 'freeze' written by Leonid Broukhis. + Thanks to many people for bug reports and testing. + + REFERENCES + + Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". + Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc + + A description of the Rabin and Karp algorithm is given in the book + "Algorithms" by R. Sedgewick, Addison-Wesley, p252. + + Fiala,E.R., and Greene,D.H. + Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595} + +{ $Id: deflate.c,v 1.14 1996/07/02 12:40:55 me Exp $ } + +interface + +{$I zconf.inc} + +uses + zutil, zlib; + + +function deflateInit_(strm : z_streamp; + level : int; + const version : string; + stream_size : int) : int; + + +function deflateInit (var strm : z_stream; level : int) : int; + +{ Initializes the internal stream state for compression. The fields + zalloc, zfree and opaque must be initialized before by the caller. + If zalloc and zfree are set to Z_NULL, deflateInit updates them to + use default allocation functions. + + The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9: + 1 gives best speed, 9 gives best compression, 0 gives no compression at + all (the input data is simply copied a block at a time). + Z_DEFAULT_COMPRESSION requests a default compromise between speed and + compression (currently equivalent to level 6). + + deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_STREAM_ERROR if level is not a valid compression level, + Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible + with the version assumed by the caller (ZLIB_VERSION). + msg is set to null if there is no error message. deflateInit does not + perform any compression: this will be done by deflate(). } + + +{EXPORT} +function deflate (var strm : z_stream; flush : int) : int; + +{ Performs one or both of the following actions: + + - Compress more input starting at next_in and update next_in and avail_in + accordingly. If not all input can be processed (because there is not + enough room in the output buffer), next_in and avail_in are updated and + processing will resume at this point for the next call of deflate(). + + - Provide more output starting at next_out and update next_out and avail_out + accordingly. This action is forced if the parameter flush is non zero. + Forcing flush frequently degrades the compression ratio, so this parameter + should be set only when necessary (in interactive applications). + Some output may be provided even if flush is not set. + + Before the call of deflate(), the application should ensure that at least + one of the actions is possible, by providing more input and/or consuming + more output, and updating avail_in or avail_out accordingly; avail_out + should never be zero before the call. The application can consume the + compressed output when it wants, for example when the output buffer is full + (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK + and with zero avail_out, it must be called again after making room in the + output buffer because there might be more output pending. + + If the parameter flush is set to Z_PARTIAL_FLUSH, the current compression + block is terminated and flushed to the output buffer so that the + decompressor can get all input data available so far. For method 9, a future + variant on method 8, the current block will be flushed but not terminated. + Z_SYNC_FLUSH has the same effect as partial flush except that the compressed + output is byte aligned (the compressor can clear its internal bit buffer) + and the current block is always terminated; this can be useful if the + compressor has to be restarted from scratch after an interruption (in which + case the internal state of the compressor may be lost). + If flush is set to Z_FULL_FLUSH, the compression block is terminated, a + special marker is output and the compression dictionary is discarded; this + is useful to allow the decompressor to synchronize if one compressed block + has been damaged (see inflateSync below). Flushing degrades compression and + so should be used only when necessary. Using Z_FULL_FLUSH too often can + seriously degrade the compression. If deflate returns with avail_out == 0, + this function must be called again with the same value of the flush + parameter and more output space (updated avail_out), until the flush is + complete (deflate returns with non-zero avail_out). + + If the parameter flush is set to Z_FINISH, all pending input is processed, + all pending output is flushed and deflate returns with Z_STREAM_END if there + was enough output space; if deflate returns with Z_OK, this function must be + called again with Z_FINISH and more output space (updated avail_out) but no + more input data, until it returns with Z_STREAM_END or an error. After + deflate has returned Z_STREAM_END, the only possible operations on the + stream are deflateReset or deflateEnd. + + Z_FINISH can be used immediately after deflateInit if all the compression + is to be done in a single step. In this case, avail_out must be at least + 0.1% larger than avail_in plus 12 bytes. If deflate does not return + Z_STREAM_END, then it must be called again as described above. + + deflate() may update data_type if it can make a good guess about + the input data type (Z_ASCII or Z_BINARY). In doubt, the data is considered + binary. This field is only for information purposes and does not affect + the compression algorithm in any manner. + + deflate() returns Z_OK if some progress has been made (more input + processed or more output produced), Z_STREAM_END if all input has been + consumed and all output has been produced (only when flush is set to + Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example + if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible. } + + +function deflateEnd (var strm : z_stream) : int; + +{ All dynamically allocated data structures for this stream are freed. + This function discards any unprocessed input and does not flush any + pending output. + + deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the + stream state was inconsistent, Z_DATA_ERROR if the stream was freed + prematurely (some input or output was discarded). In the error case, + msg may be set but then points to a static string (which must not be + deallocated). } + + + + + { Advanced functions } + +{ The following functions are needed only in some special applications. } + + +{EXPORT} +function deflateInit2 (var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int) : int; + +{ This is another version of deflateInit with more compression options. The + fields next_in, zalloc, zfree and opaque must be initialized before by + the caller. + + The method parameter is the compression method. It must be Z_DEFLATED in + this version of the library. (Method 9 will allow a 64K history buffer and + partial block flushes.) + + The windowBits parameter is the base two logarithm of the window size + (the size of the history buffer). It should be in the range 8..15 for this + version of the library (the value 16 will be allowed for method 9). Larger + values of this parameter result in better compression at the expense of + memory usage. The default value is 15 if deflateInit is used instead. + + The memLevel parameter specifies how much memory should be allocated + for the internal compression state. memLevel=1 uses minimum memory but + is slow and reduces compression ratio; memLevel=9 uses maximum memory + for optimal speed. The default value is 8. See zconf.h for total memory + usage as a function of windowBits and memLevel. + + The strategy parameter is used to tune the compression algorithm. Use the + value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a + filter (or predictor), or Z_HUFFMAN_ONLY to force Huffman encoding only (no + string match). Filtered data consists mostly of small values with a + somewhat random distribution. In this case, the compression algorithm is + tuned to compress them better. The effect of Z_FILTERED is to force more + Huffman coding and less string matching; it is somewhat intermediate + between Z_DEFAULT and Z_HUFFMAN_ONLY. The strategy parameter only affects + the compression ratio but not the correctness of the compressed output even + if it is not set appropriately. + + If next_in is not null, the library will use this buffer to hold also + some history information; the buffer must either hold the entire input + data, or have at least 1<<(windowBits+1) bytes and be writable. If next_in + is null, the library will allocate its own history buffer (and leave next_in + null). next_out need not be provided here but must be provided by the + application for the next call of deflate(). + + If the history buffer is provided by the application, next_in must + must never be changed by the application since the compressor maintains + information inside this buffer from call to call; the application + must provide more input only by increasing avail_in. next_in is always + reset by the library in this case. + + deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was + not enough memory, Z_STREAM_ERROR if a parameter is invalid (such as + an invalid method). msg is set to null if there is no error message. + deflateInit2 does not perform any compression: this will be done by + deflate(). } + + +{EXPORT} +function deflateSetDictionary (var strm : z_stream; + dictionary : pBytef; {const bytes} + dictLength : uint) : int; + +{ Initializes the compression dictionary (history buffer) from the given + byte sequence without producing any compressed output. This function must + be called immediately after deflateInit or deflateInit2, before any call + of deflate. The compressor and decompressor must use exactly the same + dictionary (see inflateSetDictionary). + The dictionary should consist of strings (byte sequences) that are likely + to be encountered later in the data to be compressed, with the most commonly + used strings preferably put towards the end of the dictionary. Using a + dictionary is most useful when the data to be compressed is short and + can be predicted with good accuracy; the data can then be compressed better + than with the default empty dictionary. In this version of the library, + only the last 32K bytes of the dictionary are used. + Upon return of this function, strm->adler is set to the Adler32 value + of the dictionary; the decompressor may later use this value to determine + which dictionary has been used by the compressor. (The Adler32 value + applies to the whole dictionary even if only a subset of the dictionary is + actually used by the compressor.) + + deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a + parameter is invalid (such as NULL dictionary) or the stream state + is inconsistent (for example if deflate has already been called for this + stream). deflateSetDictionary does not perform any compression: this will + be done by deflate(). } + +{EXPORT} +function deflateCopy (dest : z_streamp; + source : z_streamp) : int; + +{ Sets the destination stream as a complete copy of the source stream. If + the source stream is using an application-supplied history buffer, a new + buffer is allocated for the destination stream. The compressed output + buffer is always application-supplied. It's the responsibility of the + application to provide the correct values of next_out and avail_out for the + next call of deflate. + + This function can be useful when several compression strategies will be + tried, for example when there are several ways of pre-processing the input + data with a filter. The streams that will be discarded should then be freed + by calling deflateEnd. Note that deflateCopy duplicates the internal + compression state which can be quite large, so this strategy is slow and + can consume lots of memory. + + deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_STREAM_ERROR if the source stream state was inconsistent + (such as zalloc being NULL). msg is left unchanged in both source and + destination. } + +{EXPORT} +function deflateReset (var strm : z_stream) : int; + +{ This function is equivalent to deflateEnd followed by deflateInit, + but does not free and reallocate all the internal compression state. + The stream will keep the same compression level and any other attributes + that may have been set by deflateInit2. + + deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source + stream state was inconsistent (such as zalloc or state being NIL). } + + +{EXPORT} +function deflateParams (var strm : z_stream; level : int; strategy : int) : int; + +{ Dynamically update the compression level and compression strategy. + This can be used to switch between compression and straight copy of + the input data, or to switch to a different kind of input data requiring + a different strategy. If the compression level is changed, the input + available so far is compressed with the old level (and may be flushed); + the new level will take effect only at the next call of deflate(). + + Before the call of deflateParams, the stream state must be set as for + a call of deflate(), since the currently available input may have to + be compressed and flushed. In particular, strm->avail_out must be non-zero. + + deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source + stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR + if strm->avail_out was zero. } + + +const + deflate_copyright : string = ' deflate 1.1.2 Copyright 1995-1998 Jean-loup Gailly '; + +{ If you use the zlib library in a product, an acknowledgment is welcome + in the documentation of your product. If for some reason you cannot + include such an acknowledgment, I would appreciate that you keep this + copyright string in the executable of your product. } + +implementation + +uses + trees, adler; + +{ =========================================================================== + Function prototypes. } + +type + block_state = ( + need_more, { block not completed, need more input or more output } + block_done, { block flush performed } + finish_started, { finish started, need only more output at next deflate } + finish_done); { finish done, accept no more input or output } + +{ Compression function. Returns the block state after the call. } +type + compress_func = function(var s : deflate_state; flush : int) : block_state; + +{local} +procedure fill_window(var s : deflate_state); forward; +{local} +function deflate_stored(var s : deflate_state; flush : int) : block_state; far; forward; +{local} +function deflate_fast(var s : deflate_state; flush : int) : block_state; far; forward; +{local} +function deflate_slow(var s : deflate_state; flush : int) : block_state; far; forward; +{local} +procedure lm_init(var s : deflate_state); forward; + +{local} +procedure putShortMSB(var s : deflate_state; b : uInt); forward; +{local} +procedure flush_pending (var strm : z_stream); forward; +{local} +function read_buf(strm : z_streamp; + buf : pBytef; + size : unsigned) : int; forward; +{$ifdef ASMV} +procedure match_init; { asm code initialization } +function longest_match(var deflate_state; cur_match : IPos) : uInt; forward; +{$else} +{local} +function longest_match(var s : deflate_state; cur_match : IPos) : uInt; + forward; +{$endif} + +{$ifdef DEBUG} +{local} +procedure check_match(var s : deflate_state; + start, match : IPos; + length : int); forward; +{$endif} + +{ ========================================================================== + local data } + +const + ZNIL = 0; +{ Tail of hash chains } + +const + TOO_FAR = 4096; +{ Matches of length 3 are discarded if their distance exceeds TOO_FAR } + +const + MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1); +{ Minimum amount of lookahead, except at the end of the input file. + See deflate.c for comments about the MIN_MATCH+1. } + +{macro MAX_DIST(var s : deflate_state) : uInt; +begin + MAX_DIST := (s.w_size - MIN_LOOKAHEAD); +end; + In order to simplify the code, particularly on 16 bit machines, match + distances are limited to MAX_DIST instead of WSIZE. } + + +{ Values for max_lazy_match, good_match and max_chain_length, depending on + the desired pack level (0..9). The values given below have been tuned to + exclude worst case performance for pathological files. Better values may be + found for specific files. } + +type + config = record + good_length : ush; { reduce lazy search above this match length } + max_lazy : ush; { do not perform lazy search above this match length } + nice_length : ush; { quit search above this match length } + max_chain : ush; + func : compress_func; + end; + +{local} +const + configuration_table : array[0..10-1] of config = ( +{ good lazy nice chain } +{0} (good_length:0; max_lazy:0; nice_length:0; max_chain:0; func:deflate_stored), { store only } +{1} (good_length:4; max_lazy:4; nice_length:8; max_chain:4; func:deflate_fast), { maximum speed, no lazy matches } +{2} (good_length:4; max_lazy:5; nice_length:16; max_chain:8; func:deflate_fast), +{3} (good_length:4; max_lazy:6; nice_length:32; max_chain:32; func:deflate_fast), + +{4} (good_length:4; max_lazy:4; nice_length:16; max_chain:16; func:deflate_slow), { lazy matches } +{5} (good_length:8; max_lazy:16; nice_length:32; max_chain:32; func:deflate_slow), +{6} (good_length:8; max_lazy:16; nice_length:128; max_chain:128; func:deflate_slow), +{7} (good_length:8; max_lazy:32; nice_length:128; max_chain:256; func:deflate_slow), +{8} (good_length:32; max_lazy:128; nice_length:258; max_chain:1024; func:deflate_slow), +{9} (good_length:32; max_lazy:258; nice_length:258; max_chain:4096; func:deflate_slow)); { maximum compression } + +{ Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4 + For deflate_fast() (levels <= 3) good is ignored and lazy has a different + meaning. } + +const + EQUAL = 0; +{ result of memcmp for equal strings } + +{ ========================================================================== + Update a hash value with the given input byte + IN assertion: all calls to to UPDATE_HASH are made with consecutive + input characters, so that a running hash key can be computed from the + previous key instead of complete recalculation each time. + +macro UPDATE_HASH(s,h,c) + h := (( (h) shl s^.hash_shift) xor (c)) and s^.hash_mask; +} + +{ =========================================================================== + Insert string str in the dictionary and set match_head to the previous head + of the hash chain (the most recent string with same hash key). Return + the previous length of the hash chain. + If this file is compiled with -DFASTEST, the compression level is forced + to 1, and no hash chains are maintained. + IN assertion: all calls to to INSERT_STRING are made with consecutive + input characters and the first MIN_MATCH bytes of str are valid + (except for the last MIN_MATCH-1 bytes of the input file). } + +procedure INSERT_STRING(var s : deflate_state; + str : uInt; + var match_head : IPos); +begin +{$ifdef FASTEST} + {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])} + s.ins_h := ((s.ins_h shl s.hash_shift) xor + (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask; + match_head := s.head[s.ins_h] + s.head[s.ins_h] := Pos(str); +{$else} + {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])} + s.ins_h := ((s.ins_h shl s.hash_shift) xor + (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask; + + match_head := s.head^[s.ins_h]; + s.prev^[(str) and s.w_mask] := match_head; + s.head^[s.ins_h] := Pos(str); +{$endif} +end; + +{ ========================================================================= + Initialize the hash table (avoiding 64K overflow for 16 bit systems). + prev[] will be initialized on the fly. + +macro CLEAR_HASH(s) + s^.head[s^.hash_size-1] := ZNIL; + zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0])); +} + +{ ======================================================================== } + +function deflateInit2_(var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int; + const version : string; + stream_size : int) : int; +var + s : deflate_state_ptr; + noheader : int; + + overlay : pushfArray; + { We overlay pending_buf and d_buf+l_buf. This works since the average + output size for (length,distance) codes is <= 24 bits. } +begin + noheader := 0; + if (version = '') or (version[1] <> ZLIB_VERSION[1]) or + (stream_size <> sizeof(z_stream)) then + begin + deflateInit2_ := Z_VERSION_ERROR; + exit; + end; + { + if (strm = Z_NULL) then + begin + deflateInit2_ := Z_STREAM_ERROR; + exit; + end; + } + { SetLength(strm.msg, 255); } + strm.msg := ''; + if not Assigned(strm.zalloc) then + begin + {$IFDEF FPC} strm.zalloc := @zcalloc; {$ELSE} + strm.zalloc := zcalloc; + {$ENDIF} + strm.opaque := voidpf(0); + end; + if not Assigned(strm.zfree) then + {$IFDEF FPC} strm.zfree := @zcfree; {$ELSE} + strm.zfree := zcfree; + {$ENDIF} + + if (level = Z_DEFAULT_COMPRESSION) then + level := 6; +{$ifdef FASTEST} + level := 1; +{$endif} + + if (windowBits < 0) then { undocumented feature: suppress zlib header } + begin + noheader := 1; + windowBits := -windowBits; + end; + if (memLevel < 1) or (memLevel > MAX_MEM_LEVEL) or (method <> Z_DEFLATED) + or (windowBits < 8) or (windowBits > 15) or (level < 0) + or (level > 9) or (strategy < 0) or (strategy > Z_HUFFMAN_ONLY) then + begin + deflateInit2_ := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr (ZALLOC(strm, 1, sizeof(deflate_state))); + if (s = Z_NULL) then + begin + deflateInit2_ := Z_MEM_ERROR; + exit; + end; + strm.state := pInternal_state(s); + s^.strm := @strm; + + s^.noheader := noheader; + s^.w_bits := windowBits; + s^.w_size := 1 shl s^.w_bits; + s^.w_mask := s^.w_size - 1; + + s^.hash_bits := memLevel + 7; + s^.hash_size := 1 shl s^.hash_bits; + s^.hash_mask := s^.hash_size - 1; + s^.hash_shift := ((s^.hash_bits+MIN_MATCH-1) div MIN_MATCH); + + s^.window := pzByteArray (ZALLOC(strm, s^.w_size, 2*sizeof(Byte))); + s^.prev := pzPosfArray (ZALLOC(strm, s^.w_size, sizeof(Pos))); + s^.head := pzPosfArray (ZALLOC(strm, s^.hash_size, sizeof(Pos))); + + s^.lit_bufsize := 1 shl (memLevel + 6); { 16K elements by default } + + overlay := pushfArray (ZALLOC(strm, s^.lit_bufsize, sizeof(ush)+2)); + s^.pending_buf := pzByteArray (overlay); + s^.pending_buf_size := ulg(s^.lit_bufsize) * (sizeof(ush)+Long(2)); + + if (s^.window = Z_NULL) or (s^.prev = Z_NULL) or (s^.head = Z_NULL) + or (s^.pending_buf = Z_NULL) then + begin + {ERR_MSG(Z_MEM_ERROR);} + strm.msg := z_errmsg[z_errbase-Z_MEM_ERROR]; + deflateEnd (strm); + deflateInit2_ := Z_MEM_ERROR; + exit; + end; + s^.d_buf := pushfArray( @overlay^[s^.lit_bufsize div sizeof(ush)] ); + s^.l_buf := puchfArray( @s^.pending_buf^[(1+sizeof(ush))*s^.lit_bufsize] ); + + s^.level := level; + s^.strategy := strategy; + s^.method := Byte(method); + + deflateInit2_ := deflateReset(strm); +end; + +{ ========================================================================= } + +function deflateInit2(var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int) : int; +{ a macro } +begin + deflateInit2 := deflateInit2_(strm, level, method, windowBits, + memLevel, strategy, ZLIB_VERSION, sizeof(z_stream)); +end; + +{ ========================================================================= } + +function deflateInit_(strm : z_streamp; + level : int; + const version : string; + stream_size : int) : int; +begin + if (strm = Z_NULL) then + deflateInit_ := Z_STREAM_ERROR + else + deflateInit_ := deflateInit2_(strm^, level, Z_DEFLATED, MAX_WBITS, + DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, version, stream_size); + { To do: ignore strm^.next_in if we use it as window } +end; + +{ ========================================================================= } + +function deflateInit(var strm : z_stream; level : int) : int; +{ deflateInit is a macro to allow checking the zlib version + and the compiler's view of z_stream: } +begin + deflateInit := deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS, + DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(z_stream)); +end; + +{ ======================================================================== } +function deflateSetDictionary (var strm : z_stream; + dictionary : pBytef; + dictLength : uInt) : int; +var + s : deflate_state_ptr; + length : uInt; + n : uInt; + hash_head : IPos; +var + MAX_DIST : uInt; {macro} +begin + length := dictLength; + hash_head := 0; + + if {(@strm = Z_NULL) or} + (strm.state = Z_NULL) or (dictionary = Z_NULL) + or (deflate_state_ptr(strm.state)^.status <> INIT_STATE) then + begin + deflateSetDictionary := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + strm.adler := adler32(strm.adler, dictionary, dictLength); + + if (length < MIN_MATCH) then + begin + deflateSetDictionary := Z_OK; + exit; + end; + MAX_DIST := (s^.w_size - MIN_LOOKAHEAD); + if (length > MAX_DIST) then + begin + length := MAX_DIST; +{$ifndef USE_DICT_HEAD} + Inc(dictionary, dictLength - length); { use the tail of the dictionary } +{$endif} + end; + + zmemcpy( pBytef(s^.window), dictionary, length); + s^.strstart := length; + s^.block_start := long(length); + + { Insert all strings in the hash table (except for the last two bytes). + s^.lookahead stays null, so s^.ins_h will be recomputed at the next + call of fill_window. } + + s^.ins_h := s^.window^[0]; + {UPDATE_HASH(s, s^.ins_h, s^.window[1]);} + s^.ins_h := ((s^.ins_h shl s^.hash_shift) xor (s^.window^[1])) + and s^.hash_mask; + + for n := 0 to length - MIN_MATCH do + begin + INSERT_STRING(s^, n, hash_head); + end; + {if (hash_head <> 0) then + hash_head := 0; - to make compiler happy } + deflateSetDictionary := Z_OK; +end; + +{ ======================================================================== } +function deflateReset (var strm : z_stream) : int; +var + s : deflate_state_ptr; +begin + if {(@strm = Z_NULL) or} + (strm.state = Z_NULL) + or (not Assigned(strm.zalloc)) or (not Assigned(strm.zfree)) then + begin + deflateReset := Z_STREAM_ERROR; + exit; + end; + + strm.total_out := 0; + strm.total_in := 0; + strm.msg := ''; { use zfree if we ever allocate msg dynamically } + strm.data_type := Z_UNKNOWN; + + s := deflate_state_ptr(strm.state); + s^.pending := 0; + s^.pending_out := pBytef(s^.pending_buf); + + if (s^.noheader < 0) then + begin + s^.noheader := 0; { was set to -1 by deflate(..., Z_FINISH); } + end; + if s^.noheader <> 0 then + s^.status := BUSY_STATE + else + s^.status := INIT_STATE; + strm.adler := 1; + s^.last_flush := Z_NO_FLUSH; + + _tr_init(s^); + lm_init(s^); + + deflateReset := Z_OK; +end; + +{ ======================================================================== } +function deflateParams(var strm : z_stream; + level : int; + strategy : int) : int; +var + s : deflate_state_ptr; + func : compress_func; + err : int; +begin + err := Z_OK; + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then + begin + deflateParams := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + + if (level = Z_DEFAULT_COMPRESSION) then + begin + level := 6; + end; + if (level < 0) or (level > 9) or (strategy < 0) + or (strategy > Z_HUFFMAN_ONLY) then + begin + deflateParams := Z_STREAM_ERROR; + exit; + end; + func := configuration_table[s^.level].func; + + if (@func <> @configuration_table[level].func) + and (strm.total_in <> 0) then + begin + { Flush the last buffer: } + err := deflate(strm, Z_PARTIAL_FLUSH); + end; + if (s^.level <> level) then + begin + s^.level := level; + s^.max_lazy_match := configuration_table[level].max_lazy; + s^.good_match := configuration_table[level].good_length; + s^.nice_match := configuration_table[level].nice_length; + s^.max_chain_length := configuration_table[level].max_chain; + end; + s^.strategy := strategy; + deflateParams := err; +end; + +{ ========================================================================= + Put a short in the pending buffer. The 16-bit value is put in MSB order. + IN assertion: the stream state is correct and there is enough room in + pending_buf. } + +{local} +procedure putShortMSB (var s : deflate_state; b : uInt); +begin + s.pending_buf^[s.pending] := Byte(b shr 8); + Inc(s.pending); + s.pending_buf^[s.pending] := Byte(b and $ff); + Inc(s.pending); +end; + +{ ========================================================================= + Flush as much pending output as possible. All deflate() output goes + through this function so some applications may wish to modify it + to avoid allocating a large strm^.next_out buffer and copying into it. + (See also read_buf()). } + +{local} +procedure flush_pending(var strm : z_stream); +var + len : unsigned; + s : deflate_state_ptr; +begin + s := deflate_state_ptr(strm.state); + len := s^.pending; + + if (len > strm.avail_out) then + len := strm.avail_out; + if (len = 0) then + exit; + + zmemcpy(strm.next_out, s^.pending_out, len); + Inc(strm.next_out, len); + Inc(s^.pending_out, len); + Inc(strm.total_out, len); + Dec(strm.avail_out, len); + Dec(s^.pending, len); + if (s^.pending = 0) then + begin + s^.pending_out := pBytef(s^.pending_buf); + end; +end; + +{ ========================================================================= } +function deflate (var strm : z_stream; flush : int) : int; +var + old_flush : int; { value of flush param for previous deflate call } + s : deflate_state_ptr; +var + header : uInt; + level_flags : uInt; +var + bstate : block_state; +begin + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) + or (flush > Z_FINISH) or (flush < 0) then + begin + deflate := Z_STREAM_ERROR; + exit; + end; + s := deflate_state_ptr(strm.state); + + if (strm.next_out = Z_NULL) or + ((strm.next_in = Z_NULL) and (strm.avail_in <> 0)) or + ((s^.status = FINISH_STATE) and (flush <> Z_FINISH)) then + begin + {ERR_RETURN(strm^, Z_STREAM_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_STREAM_ERROR]; + deflate := Z_STREAM_ERROR; + exit; + end; + if (strm.avail_out = 0) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + s^.strm := @strm; { just in case } + old_flush := s^.last_flush; + s^.last_flush := flush; + + { Write the zlib header } + if (s^.status = INIT_STATE) then + begin + + header := (Z_DEFLATED + ((s^.w_bits-8) shl 4)) shl 8; + level_flags := (s^.level-1) shr 1; + + if (level_flags > 3) then + level_flags := 3; + header := header or (level_flags shl 6); + if (s^.strstart <> 0) then + header := header or PRESET_DICT; + Inc(header, 31 - (header mod 31)); + + s^.status := BUSY_STATE; + putShortMSB(s^, header); + + { Save the adler32 of the preset dictionary: } + if (s^.strstart <> 0) then + begin + putShortMSB(s^, uInt(strm.adler shr 16)); + putShortMSB(s^, uInt(strm.adler and $ffff)); + end; + strm.adler := long(1); + end; + + { Flush as much pending output as possible } + if (s^.pending <> 0) then + begin + flush_pending(strm); + if (strm.avail_out = 0) then + begin + { Since avail_out is 0, deflate will be called again with + more output space, but possibly with both pending and + avail_in equal to zero. There won't be anything to do, + but this is not an error situation so make sure we + return OK instead of BUF_ERROR at next call of deflate: } + + s^.last_flush := -1; + deflate := Z_OK; + exit; + end; + + { Make sure there is something to do and avoid duplicate consecutive + flushes. For repeated and useless calls with Z_FINISH, we keep + returning Z_STREAM_END instead of Z_BUFF_ERROR. } + + end + else + if (strm.avail_in = 0) and (flush <= old_flush) + and (flush <> Z_FINISH) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + { User must not provide more input after the first FINISH: } + if (s^.status = FINISH_STATE) and (strm.avail_in <> 0) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + { Start a new block or continue the current one. } + if (strm.avail_in <> 0) or (s^.lookahead <> 0) + or ((flush <> Z_NO_FLUSH) and (s^.status <> FINISH_STATE)) then + begin + bstate := configuration_table[s^.level].func(s^, flush); + + if (bstate = finish_started) or (bstate = finish_done) then + s^.status := FINISH_STATE; + + if (bstate = need_more) or (bstate = finish_started) then + begin + if (strm.avail_out = 0) then + s^.last_flush := -1; { avoid BUF_ERROR next call, see above } + + deflate := Z_OK; + exit; + { If flush != Z_NO_FLUSH && avail_out == 0, the next call + of deflate should use the same flush parameter to make sure + that the flush is complete. So we don't have to output an + empty block here, this will be done at next call. This also + ensures that for a very small output buffer, we emit at most + one empty block. } + end; + if (bstate = block_done) then + begin + if (flush = Z_PARTIAL_FLUSH) then + _tr_align(s^) + else + begin { FULL_FLUSH or SYNC_FLUSH } + _tr_stored_block(s^, pcharf(NIL), Long(0), FALSE); + { For a full flush, this empty block will be recognized + as a special marker by inflate_sync(). } + + if (flush = Z_FULL_FLUSH) then + begin + {macro CLEAR_HASH(s);} { forget history } + s^.head^[s^.hash_size-1] := ZNIL; + zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0])); + end; + end; + + flush_pending(strm); + if (strm.avail_out = 0) then + begin + s^.last_flush := -1; { avoid BUF_ERROR at next call, see above } + deflate := Z_OK; + exit; + end; + + end; + end; + {$IFDEF DEBUG} + Assert(strm.avail_out > 0, 'bug2'); + {$ENDIF} + if (flush <> Z_FINISH) then + begin + deflate := Z_OK; + exit; + end; + + if (s^.noheader <> 0) then + begin + deflate := Z_STREAM_END; + exit; + end; + + { Write the zlib trailer (adler32) } + putShortMSB(s^, uInt(strm.adler shr 16)); + putShortMSB(s^, uInt(strm.adler and $ffff)); + flush_pending(strm); + { If avail_out is zero, the application will call deflate again + to flush the rest. } + + s^.noheader := -1; { write the trailer only once! } + if s^.pending <> 0 then + deflate := Z_OK + else + deflate := Z_STREAM_END; +end; + +{ ========================================================================= } +function deflateEnd (var strm : z_stream) : int; +var + status : int; + s : deflate_state_ptr; +begin + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then + begin + deflateEnd := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + status := s^.status; + if (status <> INIT_STATE) and (status <> BUSY_STATE) and + (status <> FINISH_STATE) then + begin + deflateEnd := Z_STREAM_ERROR; + exit; + end; + + { Deallocate in reverse order of allocations: } + TRY_FREE(strm, s^.pending_buf); + TRY_FREE(strm, s^.head); + TRY_FREE(strm, s^.prev); + TRY_FREE(strm, s^.window); + + ZFREE(strm, s); + strm.state := Z_NULL; + + if status = BUSY_STATE then + deflateEnd := Z_DATA_ERROR + else + deflateEnd := Z_OK; +end; + +{ ========================================================================= + Copy the source state to the destination state. + To simplify the source, this is not supported for 16-bit MSDOS (which + doesn't have enough memory anyway to duplicate compression states). } + + +{ ========================================================================= } +function deflateCopy (dest, source : z_streamp) : int; +{$ifndef MAXSEG_64K} +var + ds : deflate_state_ptr; + ss : deflate_state_ptr; + overlay : pushfArray; +{$endif} +begin +{$ifdef MAXSEG_64K} + deflateCopy := Z_STREAM_ERROR; + exit; +{$else} + + if (source = Z_NULL) or (dest = Z_NULL) or (source^.state = Z_NULL) then + begin + deflateCopy := Z_STREAM_ERROR; + exit; + end; + ss := deflate_state_ptr(source^.state); + dest^ := source^; + + ds := deflate_state_ptr( ZALLOC(dest^, 1, sizeof(deflate_state)) ); + if (ds = Z_NULL) then + begin + deflateCopy := Z_MEM_ERROR; + exit; + end; + dest^.state := pInternal_state(ds); + ds^ := ss^; + ds^.strm := dest; + + ds^.window := pzByteArray ( ZALLOC(dest^, ds^.w_size, 2*sizeof(Byte)) ); + ds^.prev := pzPosfArray ( ZALLOC(dest^, ds^.w_size, sizeof(Pos)) ); + ds^.head := pzPosfArray ( ZALLOC(dest^, ds^.hash_size, sizeof(Pos)) ); + overlay := pushfArray ( ZALLOC(dest^, ds^.lit_bufsize, sizeof(ush)+2) ); + ds^.pending_buf := pzByteArray ( overlay ); + + if (ds^.window = Z_NULL) or (ds^.prev = Z_NULL) or (ds^.head = Z_NULL) + or (ds^.pending_buf = Z_NULL) then + begin + deflateEnd (dest^); + deflateCopy := Z_MEM_ERROR; + exit; + end; + { following zmemcpy do not work for 16-bit MSDOS } + zmemcpy(pBytef(ds^.window), pBytef(ss^.window), ds^.w_size * 2 * sizeof(Byte)); + zmemcpy(pBytef(ds^.prev), pBytef(ss^.prev), ds^.w_size * sizeof(Pos)); + zmemcpy(pBytef(ds^.head), pBytef(ss^.head), ds^.hash_size * sizeof(Pos)); + zmemcpy(pBytef(ds^.pending_buf), pBytef(ss^.pending_buf), uInt(ds^.pending_buf_size)); + + ds^.pending_out := @ds^.pending_buf^[ptr2int(ss^.pending_out) - ptr2int(ss^.pending_buf)]; + ds^.d_buf := pushfArray (@overlay^[ds^.lit_bufsize div sizeof(ush)] ); + ds^.l_buf := puchfArray (@ds^.pending_buf^[(1+sizeof(ush))*ds^.lit_bufsize]); + + ds^.l_desc.dyn_tree := tree_ptr(@ds^.dyn_ltree); + ds^.d_desc.dyn_tree := tree_ptr(@ds^.dyn_dtree); + ds^.bl_desc.dyn_tree := tree_ptr(@ds^.bl_tree); + + deflateCopy := Z_OK; +{$endif} +end; + + +{ =========================================================================== + Read a new buffer from the current input stream, update the adler32 + and total number of bytes read. All deflate() input goes through + this function so some applications may wish to modify it to avoid + allocating a large strm^.next_in buffer and copying from it. + (See also flush_pending()). } + +{local} +function read_buf(strm : z_streamp; buf : pBytef; size : unsigned) : int; +var + len : unsigned; +begin + len := strm^.avail_in; + + if (len > size) then + len := size; + if (len = 0) then + begin + read_buf := 0; + exit; + end; + + Dec(strm^.avail_in, len); + + if deflate_state_ptr(strm^.state)^.noheader = 0 then + begin + strm^.adler := adler32(strm^.adler, strm^.next_in, len); + end; + zmemcpy(buf, strm^.next_in, len); + Inc(strm^.next_in, len); + Inc(strm^.total_in, len); + + read_buf := int(len); +end; + +{ =========================================================================== + Initialize the "longest match" routines for a new zlib stream } + +{local} +procedure lm_init (var s : deflate_state); +begin + s.window_size := ulg( uLong(2)*s.w_size); + + {macro CLEAR_HASH(s);} + s.head^[s.hash_size-1] := ZNIL; + zmemzero(pBytef(s.head), unsigned(s.hash_size-1)*sizeof(s.head^[0])); + + { Set the default configuration parameters: } + + s.max_lazy_match := configuration_table[s.level].max_lazy; + s.good_match := configuration_table[s.level].good_length; + s.nice_match := configuration_table[s.level].nice_length; + s.max_chain_length := configuration_table[s.level].max_chain; + + s.strstart := 0; + s.block_start := long(0); + s.lookahead := 0; + s.prev_length := MIN_MATCH-1; + s.match_length := MIN_MATCH-1; + s.match_available := FALSE; + s.ins_h := 0; +{$ifdef ASMV} + match_init; { initialize the asm code } +{$endif} +end; + +{ =========================================================================== + Set match_start to the longest match starting at the given string and + return its length. Matches shorter or equal to prev_length are discarded, + in which case the result is equal to prev_length and match_start is + garbage. + IN assertions: cur_match is the head of the hash chain for the current + string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1 + OUT assertion: the match length is not greater than s^.lookahead. } + + +{$ifndef ASMV} +{ For 80x86 and 680x0, an optimized version will be provided in match.asm or + match.S. The code will be functionally equivalent. } + +{$ifndef FASTEST} + +{local} +function longest_match(var s : deflate_state; + cur_match : IPos { current match } + ) : uInt; +label + nextstep; +var + chain_length : unsigned; { max hash chain length } + {register} scan : pBytef; { current string } + {register} match : pBytef; { matched string } + {register} len : int; { length of current match } + best_len : int; { best match length so far } + nice_match : int; { stop if match long enough } + limit : IPos; + + prev : pzPosfArray; + wmask : uInt; +{$ifdef UNALIGNED_OK} + {register} strend : pBytef; + {register} scan_start : ush; + {register} scan_end : ush; +{$else} + {register} strend : pBytef; + {register} scan_end1 : Byte; + {register} scan_end : Byte; +{$endif} +var + MAX_DIST : uInt; +begin + chain_length := s.max_chain_length; { max hash chain length } + scan := @(s.window^[s.strstart]); + best_len := s.prev_length; { best match length so far } + nice_match := s.nice_match; { stop if match long enough } + + + MAX_DIST := s.w_size - MIN_LOOKAHEAD; +{In order to simplify the code, particularly on 16 bit machines, match +distances are limited to MAX_DIST instead of WSIZE. } + + if s.strstart > IPos(MAX_DIST) then + limit := s.strstart - IPos(MAX_DIST) + else + limit := ZNIL; + { Stop when cur_match becomes <= limit. To simplify the code, + we prevent matches with the string of window index 0. } + + prev := s.prev; + wmask := s.w_mask; + +{$ifdef UNALIGNED_OK} + { Compare two bytes at a time. Note: this is not always beneficial. + Try with and without -DUNALIGNED_OK to check. } + + strend := pBytef(@(s.window^[s.strstart + MAX_MATCH - 1])); + scan_start := pushf(scan)^; + scan_end := pushfArray(scan)^[best_len-1]; { fix } +{$else} + strend := pBytef(@(s.window^[s.strstart + MAX_MATCH])); + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + scan_end1 := pzByteArray(scan)^[best_len-1]; + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + scan_end := pzByteArray(scan)^[best_len]; +{$endif} + + { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. + It is easy to get rid of this optimization if necessary. } + {$IFDEF DEBUG} + Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever'); + {$ENDIF} + { Do not waste too much time if we already have a good match: } + if (s.prev_length >= s.good_match) then + begin + chain_length := chain_length shr 2; + end; + + { Do not look for matches beyond the end of the input. This is necessary + to make deflate deterministic. } + + if (uInt(nice_match) > s.lookahead) then + nice_match := s.lookahead; + {$IFDEF DEBUG} + Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead'); + {$ENDIF} + repeat + {$IFDEF DEBUG} + Assert(cur_match < s.strstart, 'no future'); + {$ENDIF} + match := @(s.window^[cur_match]); + + { Skip to next match if the match length cannot increase + or if the match length is less than 2: } + +{$undef DO_UNALIGNED_OK} +{$ifdef UNALIGNED_OK} + {$ifdef MAX_MATCH_IS_258} + {$define DO_UNALIGNED_OK} + {$endif} +{$endif} + +{$ifdef DO_UNALIGNED_OK} + { This code assumes sizeof(unsigned short) = 2. Do not use + UNALIGNED_OK if your compiler uses a different size. } + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (pushfArray(match)^[best_len-1] <> scan_end) or + (pushf(match)^ <> scan_start) then + goto nextstep; {continue;} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + + { It is not necessary to compare scan[2] and match[2] since they are + always equal when the other bytes match, given that the hash keys + are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at + strstart+3, +5, ... up to strstart+257. We check for insufficient + lookahead only every 4th comparison; the 128th check will be made + at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is + necessary to put more guard bytes at the end of the window, or + to check more often for insufficient lookahead. } + {$IFDEF DEBUG} + Assert(pzByteArray(scan)^[2] = pzByteArray(match)^[2], 'scan[2]?'); + {$ENDIF} + Inc(scan); + Inc(match); + + repeat + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + until (ptr2int(scan) >= ptr2int(strend)); + { The funny "do while" generates better code on most compilers } + + { Here, scan <= window+strstart+257 } + {$IFDEF DEBUG} + {$ifopt R+} {$define RangeCheck} {$endif} {$R-} + Assert(ptr2int(scan) <= + ptr2int(@(s.window^[unsigned(s.window_size-1)])), + 'wild scan'); + {$ifdef RangeCheck} {$R+} {$undef RangeCheck} {$endif} + {$ENDIF} + if (scan^ = match^) then + Inc(scan); + + len := (MAX_MATCH - 1) - int(ptr2int(strend)) + int(ptr2int(scan)); + scan := strend; + Dec(scan, (MAX_MATCH-1)); + +{$else} { UNALIGNED_OK } + + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (pzByteArray(match)^[best_len] <> scan_end) or + (pzByteArray(match)^[best_len-1] <> scan_end1) or + (match^ <> scan^) then + goto nextstep; {continue;} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + Inc(match); + if (match^ <> pzByteArray(scan)^[1]) then + goto nextstep; {continue;} + + { The check at best_len-1 can be removed because it will be made + again later. (This heuristic is not always a win.) + It is not necessary to compare scan[2] and match[2] since they + are always equal when the other bytes match, given that + the hash keys are equal and that HASH_BITS >= 8. } + + Inc(scan, 2); + Inc(match); + {$IFDEF DEBUG} + Assert( scan^ = match^, 'match[2]?'); + {$ENDIF} + { We check for insufficient lookahead only every 8th comparison; + the 256th check will be made at strstart+258. } + + repeat + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + until (ptr2int(scan) >= ptr2int(strend)); + + {$IFDEF DEBUG} + Assert(ptr2int(scan) <= + ptr2int(@(s.window^[unsigned(s.window_size-1)])), + 'wild scan'); + {$ENDIF} + + len := MAX_MATCH - int(ptr2int(strend) - ptr2int(scan)); + scan := strend; + Dec(scan, MAX_MATCH); + +{$endif} { UNALIGNED_OK } + + if (len > best_len) then + begin + s.match_start := cur_match; + best_len := len; + if (len >= nice_match) then + break; + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} +{$ifdef UNALIGNED_OK} + scan_end := pzByteArray(scan)^[best_len-1]; +{$else} + scan_end1 := pzByteArray(scan)^[best_len-1]; + scan_end := pzByteArray(scan)^[best_len]; +{$endif} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + end; + nextstep: + cur_match := prev^[cur_match and wmask]; + Dec(chain_length); + until (cur_match <= limit) or (chain_length = 0); + + if (uInt(best_len) <= s.lookahead) then + longest_match := uInt(best_len) + else + longest_match := s.lookahead; +end; +{$endif} { ASMV } + +{$else} { FASTEST } +{ --------------------------------------------------------------------------- + Optimized version for level = 1 only } + +{local} +function longest_match(var s : deflate_state; + cur_match : IPos { current match } + ) : uInt; +var + {register} scan : pBytef; { current string } + {register} match : pBytef; { matched string } + {register} len : int; { length of current match } + {register} strend : pBytef; +begin + scan := @s.window^[s.strstart]; + strend := @s.window^[s.strstart + MAX_MATCH]; + + + { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. + It is easy to get rid of this optimization if necessary. } + {$IFDEF DEBUG} + Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever'); + + Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead'); + + Assert(cur_match < s.strstart, 'no future'); + {$ENDIF} + match := s.window + cur_match; + + { Return failure if the match length is less than 2: } + + if (match[0] <> scan[0]) or (match[1] <> scan[1]) then + begin + longest_match := MIN_MATCH-1; + exit; + end; + + { The check at best_len-1 can be removed because it will be made + again later. (This heuristic is not always a win.) + It is not necessary to compare scan[2] and match[2] since they + are always equal when the other bytes match, given that + the hash keys are equal and that HASH_BITS >= 8. } + + scan += 2, match += 2; + Assert(scan^ = match^, 'match[2]?'); + + { We check for insufficient lookahead only every 8th comparison; + the 256th check will be made at strstart+258. } + + repeat + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + until (ptr2int(scan) >= ptr2int(strend)); + + Assert(scan <= s.window+unsigned(s.window_size-1), 'wild scan'); + + len := MAX_MATCH - int(strend - scan); + + if (len < MIN_MATCH) then + begin + return := MIN_MATCH - 1; + exit; + end; + + s.match_start := cur_match; + if len <= s.lookahead then + longest_match := len + else + longest_match := s.lookahead; +end; +{$endif} { FASTEST } + +{$ifdef DEBUG} +{ =========================================================================== + Check that the match at match_start is indeed a match. } + +{local} +procedure check_match(var s : deflate_state; + start, match : IPos; + length : int); +begin + exit; + { check that the match is indeed a match } + if (zmemcmp(pBytef(@s.window^[match]), + pBytef(@s.window^[start]), length) <> EQUAL) then + begin + WriteLn(' start ',start,', match ',match ,' length ', length); + repeat + Write(char(s.window^[match]), char(s.window^[start])); + Inc(match); + Inc(start); + Dec(length); + Until (length = 0); + z_error('invalid match'); + end; + if (z_verbose > 1) then + begin + Write('\\[',start-match,',',length,']'); + repeat + Write(char(s.window^[start])); + Inc(start); + Dec(length); + Until (length = 0); + end; +end; +{$endif} + +{ =========================================================================== + Fill the window when the lookahead becomes insufficient. + Updates strstart and lookahead. + + IN assertion: lookahead < MIN_LOOKAHEAD + OUT assertions: strstart <= window_size-MIN_LOOKAHEAD + At least one byte has been read, or avail_in = 0; reads are + performed for at least two bytes (required for the zip translate_eol + option -- not supported here). } + +{local} +procedure fill_window(var s : deflate_state); +var + {register} n, m : unsigned; + {register} p : pPosf; + more : unsigned; { Amount of free space at the end of the window. } + wsize : uInt; +begin + wsize := s.w_size; + repeat + more := unsigned(s.window_size -ulg(s.lookahead) -ulg(s.strstart)); + + { Deal with !@#$% 64K limit: } + if (more = 0) and (s.strstart = 0) and (s.lookahead = 0) then + more := wsize + else + if (more = unsigned(-1)) then + begin + { Very unlikely, but possible on 16 bit machine if strstart = 0 + and lookahead = 1 (input done one byte at time) } + Dec(more); + + { If the window is almost full and there is insufficient lookahead, + move the upper half to the lower one to make room in the upper half.} + end + else + if (s.strstart >= wsize+ {MAX_DIST}(wsize-MIN_LOOKAHEAD)) then + begin + zmemcpy( pBytef(s.window), pBytef(@(s.window^[wsize])), + unsigned(wsize)); + Dec(s.match_start, wsize); + Dec(s.strstart, wsize); { we now have strstart >= MAX_DIST } + Dec(s.block_start, long(wsize)); + + { Slide the hash table (could be avoided with 32 bit values + at the expense of memory usage). We slide even when level = 0 + to keep the hash table consistent if we switch back to level > 0 + later. (Using level 0 permanently is not an optimal usage of + zlib, so we don't care about this pathological case.) } + + n := s.hash_size; + p := @s.head^[n]; + repeat + Dec(p); + m := p^; + if (m >= wsize) then + p^ := Pos(m-wsize) + else + p^ := Pos(ZNIL); + Dec(n); + Until (n=0); + + n := wsize; +{$ifndef FASTEST} + p := @s.prev^[n]; + repeat + Dec(p); + m := p^; + if (m >= wsize) then + p^ := Pos(m-wsize) + else + p^:= Pos(ZNIL); + { If n is not on any hash chain, prev^[n] is garbage but + its value will never be used. } + Dec(n); + Until (n=0); +{$endif} + Inc(more, wsize); + end; + if (s.strm^.avail_in = 0) then + exit; + + {* If there was no sliding: + * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 && + * more == window_size - lookahead - strstart + * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1) + * => more >= window_size - 2*WSIZE + 2 + * In the BIG_MEM or MMAP case (not yet supported), + * window_size == input_size + MIN_LOOKAHEAD && + * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD. + * Otherwise, window_size == 2*WSIZE so more >= 2. + * If there was sliding, more >= WSIZE. So in all cases, more >= 2. } + + {$IFDEF DEBUG} + Assert(more >= 2, 'more < 2'); + {$ENDIF} + + n := read_buf(s.strm, pBytef(@(s.window^[s.strstart + s.lookahead])), + more); + Inc(s.lookahead, n); + + { Initialize the hash value now that we have some input: } + if (s.lookahead >= MIN_MATCH) then + begin + s.ins_h := s.window^[s.strstart]; + {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);} + s.ins_h := ((s.ins_h shl s.hash_shift) xor s.window^[s.strstart+1]) + and s.hash_mask; +{$ifdef MIN_MATCH <> 3} + Call UPDATE_HASH() MIN_MATCH-3 more times +{$endif} + end; + { If the whole input has less than MIN_MATCH bytes, ins_h is garbage, + but this is not important since only literal bytes will be emitted. } + + until (s.lookahead >= MIN_LOOKAHEAD) or (s.strm^.avail_in = 0); +end; + +{ =========================================================================== + Flush the current block, with given end-of-file flag. + IN assertion: strstart is set to the end of the current match. } + +procedure FLUSH_BLOCK_ONLY(var s : deflate_state; eof : boolean); {macro} +begin + if (s.block_start >= Long(0)) then + _tr_flush_block(s, pcharf(@s.window^[unsigned(s.block_start)]), + ulg(long(s.strstart) - s.block_start), eof) + else + _tr_flush_block(s, pcharf(Z_NULL), + ulg(long(s.strstart) - s.block_start), eof); + + s.block_start := s.strstart; + flush_pending(s.strm^); + {$IFDEF DEBUG} + Tracev('[FLUSH]'); + {$ENDIF} +end; + +{ Same but force premature exit if necessary. +macro FLUSH_BLOCK(var s : deflate_state; eof : boolean) : boolean; +var + result : block_state; +begin + FLUSH_BLOCK_ONLY(s, eof); + if (s.strm^.avail_out = 0) then + begin + if eof then + result := finish_started + else + result := need_more; + exit; + end; +end; +} + +{ =========================================================================== + Copy without compression as much as possible from the input stream, return + the current block state. + This function does not insert new strings in the dictionary since + uncompressible data is probably not useful. This function is used + only for the level=0 compression option. + NOTE: this function should be optimized to avoid extra copying from + window to pending_buf. } + + +{local} +function deflate_stored(var s : deflate_state; flush : int) : block_state; +{ Stored blocks are limited to 0xffff bytes, pending_buf is limited + to pending_buf_size, and each stored block has a 5 byte header: } +var + max_block_size : ulg; + max_start : ulg; +begin + max_block_size := $ffff; + if (max_block_size > s.pending_buf_size - 5) then + max_block_size := s.pending_buf_size - 5; + + { Copy as much as possible from input to output: } + while TRUE do + begin + { Fill the window as much as possible: } + if (s.lookahead <= 1) then + begin + {$IFDEF DEBUG} + Assert( (s.strstart < s.w_size + {MAX_DIST}s.w_size-MIN_LOOKAHEAD) or + (s.block_start >= long(s.w_size)), 'slide too late'); + {$ENDIF} + fill_window(s); + if (s.lookahead = 0) and (flush = Z_NO_FLUSH) then + begin + deflate_stored := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + {$IFDEF DEBUG} + Assert(s.block_start >= long(0), 'block gone'); + {$ENDIF} + Inc(s.strstart, s.lookahead); + s.lookahead := 0; + + { Emit a stored block if pending_buf will be full: } + max_start := s.block_start + max_block_size; + if (s.strstart = 0) or (ulg(s.strstart) >= max_start) then + begin + { strstart = 0 is possible when wraparound on 16-bit machine } + {$WARNINGS OFF} + s.lookahead := uInt(s.strstart - max_start); + {$WARNINGS ON} + s.strstart := uInt(max_start); + {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_stored := need_more; + exit; + end; + end; + + { Flush if we may have to slide, otherwise block_start may become + negative and the data will be gone: } + + if (s.strstart - uInt(s.block_start) >= {MAX_DIST} + s.w_size-MIN_LOOKAHEAD) then + begin + {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_stored := need_more; + exit; + end; + end; + end; + + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_stored := finish_started + else + deflate_stored := need_more; + exit; + end; + + if flush = Z_FINISH then + deflate_stored := finish_done + else + deflate_stored := block_done; +end; + +{ =========================================================================== + Compress as much as possible from the input stream, return the current + block state. + This function does not perform lazy evaluation of matches and inserts + new strings in the dictionary only for unmatched strings or for short + matches. It is used only for the fast compression options. } + +{local} +function deflate_fast(var s : deflate_state; flush : int) : block_state; +var + hash_head : IPos; { head of the hash chain } + bflush : boolean; { set if current block must be flushed } +begin + hash_head := ZNIL; + while TRUE do + begin + { Make sure that we always have enough lookahead, except + at the end of the input file. We need MAX_MATCH bytes + for the next match, plus MIN_MATCH bytes to insert the + string following the next match. } + + if (s.lookahead < MIN_LOOKAHEAD) then + begin + fill_window(s); + if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then + begin + deflate_fast := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + + + { Insert the string window[strstart .. strstart+2] in the + dictionary, and set hash_head to the head of the hash chain: } + + if (s.lookahead >= MIN_MATCH) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + + { Find the longest match, discarding those <= prev_length. + At this point we have always match_length < MIN_MATCH } + if (hash_head <> ZNIL) and + (s.strstart - hash_head <= (s.w_size-MIN_LOOKAHEAD){MAX_DIST}) then + begin + { To simplify the code, we prevent matches with the string + of window index 0 (in particular we have to avoid a match + of the string with itself at the start of the input file). } + if (s.strategy <> Z_HUFFMAN_ONLY) then + begin + s.match_length := longest_match (s, hash_head); + end; + { longest_match() sets match_start } + end; + if (s.match_length >= MIN_MATCH) then + begin + {$IFDEF DEBUG} + check_match(s, s.strstart, s.match_start, s.match_length); + {$ENDIF} + + {_tr_tally_dist(s, s.strstart - s.match_start, + s.match_length - MIN_MATCH, bflush);} + bflush := _tr_tally(s, s.strstart - s.match_start, + s.match_length - MIN_MATCH); + + Dec(s.lookahead, s.match_length); + + { Insert new strings in the hash table only if the match length + is not too large. This saves time but degrades compression. } + +{$ifndef FASTEST} + if (s.match_length <= s.max_insert_length) + and (s.lookahead >= MIN_MATCH) then + begin + Dec(s.match_length); { string at strstart already in hash table } + repeat + Inc(s.strstart); + INSERT_STRING(s, s.strstart, hash_head); + { strstart never exceeds WSIZE-MAX_MATCH, so there are + always MIN_MATCH bytes ahead. } + Dec(s.match_length); + until (s.match_length = 0); + Inc(s.strstart); + end + else +{$endif} + + begin + Inc(s.strstart, s.match_length); + s.match_length := 0; + s.ins_h := s.window^[s.strstart]; + {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);} + s.ins_h := (( s.ins_h shl s.hash_shift) xor + s.window^[s.strstart+1]) and s.hash_mask; +if MIN_MATCH <> 3 then { the linker removes this } +begin + {Call UPDATE_HASH() MIN_MATCH-3 more times} +end; + + { If lookahead < MIN_MATCH, ins_h is garbage, but it does not + matter since it will be recomputed at next deflate call. } + + end; + end + else + begin + { No match, output a literal byte } + {$IFDEF DEBUG} + Tracevv(char(s.window^[s.strstart])); + {$ENDIF} + {_tr_tally_lit (s, 0, s.window^[s.strstart], bflush);} + bflush := _tr_tally (s, 0, s.window^[s.strstart]); + + Dec(s.lookahead); + Inc(s.strstart); + end; + if bflush then + begin {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_fast := need_more; + exit; + end; + end; + end; + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_fast := finish_started + else + deflate_fast := need_more; + exit; + end; + + if flush = Z_FINISH then + deflate_fast := finish_done + else + deflate_fast := block_done; +end; + +{ =========================================================================== + Same as above, but achieves better compression. We use a lazy + evaluation for matches: a match is finally adopted only if there is + no better match at the next window position. } + +{local} +function deflate_slow(var s : deflate_state; flush : int) : block_state; +var + hash_head : IPos; { head of hash chain } + bflush : boolean; { set if current block must be flushed } +var + max_insert : uInt; +begin + hash_head := ZNIL; + + { Process the input block. } + while TRUE do + begin + { Make sure that we always have enough lookahead, except + at the end of the input file. We need MAX_MATCH bytes + for the next match, plus MIN_MATCH bytes to insert the + string following the next match. } + + if (s.lookahead < MIN_LOOKAHEAD) then + begin + fill_window(s); + if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then + begin + deflate_slow := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + + { Insert the string window[strstart .. strstart+2] in the + dictionary, and set hash_head to the head of the hash chain: } + + if (s.lookahead >= MIN_MATCH) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + + { Find the longest match, discarding those <= prev_length. } + + s.prev_length := s.match_length; + s.prev_match := s.match_start; + s.match_length := MIN_MATCH-1; + + if (hash_head <> ZNIL) and (s.prev_length < s.max_lazy_match) and + (s.strstart - hash_head <= {MAX_DIST}(s.w_size-MIN_LOOKAHEAD)) then + begin + { To simplify the code, we prevent matches with the string + of window index 0 (in particular we have to avoid a match + of the string with itself at the start of the input file). } + + if (s.strategy <> Z_HUFFMAN_ONLY) then + begin + s.match_length := longest_match (s, hash_head); + end; + { longest_match() sets match_start } + + if (s.match_length <= 5) and ((s.strategy = Z_FILTERED) or + ((s.match_length = MIN_MATCH) and + (s.strstart - s.match_start > TOO_FAR))) then + begin + { If prev_match is also MIN_MATCH, match_start is garbage + but we will ignore the current match anyway. } + + s.match_length := MIN_MATCH-1; + end; + end; + { If there was a match at the previous step and the current + match is not better, output the previous match: } + + if (s.prev_length >= MIN_MATCH) + and (s.match_length <= s.prev_length) then + begin + max_insert := s.strstart + s.lookahead - MIN_MATCH; + { Do not insert strings in hash table beyond this. } + {$ifdef DEBUG} + check_match(s, s.strstart-1, s.prev_match, s.prev_length); + {$endif} + + {_tr_tally_dist(s, s->strstart -1 - s->prev_match, + s->prev_length - MIN_MATCH, bflush);} + bflush := _tr_tally(s, s.strstart -1 - s.prev_match, + s.prev_length - MIN_MATCH); + + { Insert in hash table all strings up to the end of the match. + strstart-1 and strstart are already inserted. If there is not + enough lookahead, the last two strings are not inserted in + the hash table. } + + Dec(s.lookahead, s.prev_length-1); + Dec(s.prev_length, 2); + repeat + Inc(s.strstart); + if (s.strstart <= max_insert) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + Dec(s.prev_length); + until (s.prev_length = 0); + s.match_available := FALSE; + s.match_length := MIN_MATCH-1; + Inc(s.strstart); + + if (bflush) then {FLUSH_BLOCK(s, FALSE);} + begin + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_slow := need_more; + exit; + end; + end; + end + else + if (s.match_available) then + begin + { If there was no match at the previous position, output a + single literal. If there was a match but the current match + is longer, truncate the previous match to a single literal. } + {$IFDEF DEBUG} + Tracevv(char(s.window^[s.strstart-1])); + {$ENDIF} + bflush := _tr_tally (s, 0, s.window^[s.strstart-1]); + + if bflush then + begin + FLUSH_BLOCK_ONLY(s, FALSE); + end; + Inc(s.strstart); + Dec(s.lookahead); + if (s.strm^.avail_out = 0) then + begin + deflate_slow := need_more; + exit; + end; + end + else + begin + { There is no previous match to compare with, wait for + the next step to decide. } + + s.match_available := TRUE; + Inc(s.strstart); + Dec(s.lookahead); + end; + end; + + {$IFDEF DEBUG} + Assert (flush <> Z_NO_FLUSH, 'no flush?'); + {$ENDIF} + if (s.match_available) then + begin + {$IFDEF DEBUG} + Tracevv(char(s.window^[s.strstart-1])); + bflush := + {$ENDIF} + _tr_tally (s, 0, s.window^[s.strstart-1]); + s.match_available := FALSE; + end; + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_slow := finish_started + else + deflate_slow := need_more; + exit; + end; + if flush = Z_FINISH then + deflate_slow := finish_done + else + deflate_slow := block_done; +end; + +end. \ No newline at end of file diff --git a/delphionly/Zlib.pas b/delphionly/Zlib.pas new file mode 100755 index 0000000..b8316e8 --- /dev/null +++ b/delphionly/Zlib.pas @@ -0,0 +1,523 @@ +Unit Zlib; + + +{ Original: + zlib.h -- interface of the 'zlib' general purpose compression library + version 1.1.0, Feb 24th, 1998 + + Copyright (C) 1995-1998 Jean-loup Gailly and Mark Adler + + This software is provided 'as-is', without any express or implied + warranty. In no event will the authors be held liable for any damages + arising from the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + 3. This notice may not be removed or altered from any source distribution. + + Jean-loup Gailly Mark Adler + jloup@gzip.org madler@alumni.caltech.edu + + + The data format used by the zlib library is described by RFCs (Request for + Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt + (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). + + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil; + +{ zconf.h -- configuration of the zlib compression library } +{ zutil.c -- target dependent utility functions for the compression library } + +{ The 'zlib' compression library provides in-memory compression and + decompression functions, including integrity checks of the uncompressed + data. This version of the library supports only one compression method + (deflation) but other algorithms will be added later and will have the same + stream interface. + + Compression can be done in a single step if the buffers are large + enough (for example if an input file is mmap'ed), or can be done by + repeated calls of the compression function. In the latter case, the + application must provide more input and/or consume the output + (providing more output space) before each call. + + The library also supports reading and writing files in gzip (.gz) format + with an interface similar to that of stdio. + + The library does not install any signal handler. The decoder checks + the consistency of the compressed data, so the library should never + crash even in case of corrupted input. } + + + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{ Maximum value for memLevel in deflateInit2 } +{$ifdef MAXSEG_64K} + {$IFDEF VER70} + const + MAX_MEM_LEVEL = 7; + DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel } + {$ELSE} + const + MAX_MEM_LEVEL = 8; + DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel } + {$ENDIF} +{$else} +const + MAX_MEM_LEVEL = 9; + DEF_MEM_LEVEL = 8; { if MAX_MEM_LEVEL > 8 } +{$endif} + +{ Maximum value for windowBits in deflateInit2 and inflateInit2 } +const +{$IFDEF VER70} + MAX_WBITS = 14; { 32K LZ77 window } +{$ELSE} + MAX_WBITS = 15; { 32K LZ77 window } +{$ENDIF} + +{ default windowBits for decompression. MAX_WBITS is for compression only } +const + DEF_WBITS = MAX_WBITS; + +{ The memory requirements for deflate are (in bytes): + 1 shl (windowBits+2) + 1 shl (memLevel+9) + that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) + plus a few kilobytes for small objects. For example, if you want to reduce + the default memory requirements from 256K to 128K, compile with + DMAX_WBITS=14 DMAX_MEM_LEVEL=7 + Of course this will generally degrade compression (there's no free lunch). + + The memory requirements for inflate are (in bytes) 1 shl windowBits + that is, 32K for windowBits=15 (default value) plus a few kilobytes + for small objects. } + + +{ Huffman code lookup table entry--this entry is four bytes for machines + that have 16-bit pointers (e.g. PC's in the small or medium model). } + +type + pInflate_huft = ^inflate_huft; + inflate_huft = Record + Exop, { number of extra bits or operation } + bits : Byte; { number of bits in this code or subcode } + {pad : uInt;} { pad structure to a power of 2 (4 bytes for } + { 16-bit, 8 bytes for 32-bit int's) } + base : uInt; { literal, length base, or distance base } + { or table offset } + End; + +type + huft_field = Array[0..(MaxMemBlock div SizeOf(inflate_huft))-1] of inflate_huft; + huft_ptr = ^huft_field; +type + ppInflate_huft = ^pInflate_huft; + +type + inflate_codes_mode = ( { waiting for "i:"=input, "o:"=output, "x:"=nothing } + START, { x: set up for LEN } + LEN, { i: get length/literal/eob next } + LENEXT, { i: getting length extra (have base) } + DIST, { i: get distance next } + DISTEXT, { i: getting distance extra } + COPYZ, { o: copying bytes in window, waiting for space } + LIT, { o: got literal, waiting for output space } + WASH, { o: got eob, possibly still output waiting } + ZEND, { x: got eob and all data flushed } + BADCODE); { x: got error } + +{ inflate codes private state } +type + pInflate_codes_state = ^inflate_codes_state; + inflate_codes_state = record + + mode : inflate_codes_mode; { current inflate_codes mode } + + { mode dependent information } + len : uInt; + sub : record { submode } + Case Byte of + 0:(code : record { if LEN or DIST, where in tree } + tree : pInflate_huft; { pointer into tree } + need : uInt; { bits needed } + end); + 1:(lit : uInt); { if LIT, literal } + 2:(copy: record { if EXT or COPY, where and how much } + get : uInt; { bits to get for extra } + dist : uInt; { distance back to copy from } + end); + end; + + { mode independent information } + lbits : Byte; { ltree bits decoded per branch } + dbits : Byte; { dtree bits decoder per branch } + ltree : pInflate_huft; { literal/length/eob tree } + dtree : pInflate_huft; { distance tree } + end; + +type + check_func = function(check : uLong; + buf : pBytef; + {const buf : array of byte;} + len : uInt) : uLong; +type + inflate_block_mode = + (ZTYPE, { get type bits (3, including end bit) } + LENS, { get lengths for stored } + STORED, { processing stored block } + TABLE, { get table lengths } + BTREE, { get bit lengths tree for a dynamic block } + DTREE, { get length, distance trees for a dynamic block } + CODES, { processing fixed or dynamic block } + DRY, { output remaining window bytes } + BLKDONE, { finished last block, done } + BLKBAD); { got a data error--stuck here } + +type + pInflate_blocks_state = ^inflate_blocks_state; + +{ inflate blocks semi-private state } + inflate_blocks_state = record + + mode : inflate_block_mode; { current inflate_block mode } + + { mode dependent information } + sub : record { submode } + case Byte of + 0:(left : uInt); { if STORED, bytes left to copy } + 1:(trees : record { if DTREE, decoding info for trees } + table : uInt; { table lengths (14 bits) } + index : uInt; { index into blens (or border) } + blens : PuIntArray; { bit lengths of codes } + bb : uInt; { bit length tree depth } + tb : pInflate_huft; { bit length decoding tree } + end); + 2:(decode : record { if CODES, current state } + tl : pInflate_huft; + td : pInflate_huft; { trees to free } + codes : pInflate_codes_state; + end); + end; + last : boolean; { true if this block is the last block } + + { mode independent information } + bitk : uInt; { bits in bit buffer } + bitb : uLong; { bit buffer } + hufts : huft_ptr; {pInflate_huft;} { single malloc for tree space } + window : pBytef; { sliding window } + zend : pBytef; { one byte after sliding window } + read : pBytef; { window read pointer } + write : pBytef; { window write pointer } + checkfn : check_func; { check function } + check : uLong; { check on output } + end; + +type + inflate_mode = ( + METHOD, { waiting for method byte } + FLAG, { waiting for flag byte } + DICT4, { four dictionary check bytes to go } + DICT3, { three dictionary check bytes to go } + DICT2, { two dictionary check bytes to go } + DICT1, { one dictionary check byte to go } + DICT0, { waiting for inflateSetDictionary } + BLOCKS, { decompressing blocks } + CHECK4, { four check bytes to go } + CHECK3, { three check bytes to go } + CHECK2, { two check bytes to go } + CHECK1, { one check byte to go } + DONE, { finished check, done } + BAD); { got an error--stay here } + +{ inflate private state } +type + pInternal_state = ^internal_state; { or point to a deflate_state record } + internal_state = record + + mode : inflate_mode; { current inflate mode } + + { mode dependent information } + sub : record { submode } + case byte of + 0:(method : uInt); { if FLAGS, method byte } + 1:(check : record { if CHECK, check values to compare } + was : uLong; { computed check value } + need : uLong; { stream check value } + end); + 2:(marker : uInt); { if BAD, inflateSync's marker bytes count } + end; + + { mode independent information } + nowrap : boolean; { flag for no wrapper } + wbits : uInt; { log2(window size) (8..15, defaults to 15) } + blocks : pInflate_blocks_state; { current inflate_blocks state } + end; + +type + alloc_func = function(opaque : voidpf; items : uInt; size : uInt) : voidpf; + free_func = procedure(opaque : voidpf; address : voidpf); + +type + z_streamp = ^z_stream; + z_stream = record + next_in : pBytef; { next input byte } + avail_in : uInt; { number of bytes available at next_in } + total_in : uLong; { total nb of input bytes read so far } + + next_out : pBytef; { next output byte should be put there } + avail_out : uInt; { remaining free space at next_out } + total_out : uLong; { total nb of bytes output so far } + + msg : string[255]; { last error message, '' if no error } + state : pInternal_state; { not visible by applications } + + zalloc : alloc_func; { used to allocate the internal state } + zfree : free_func; { used to free the internal state } + opaque : voidpf; { private data object passed to zalloc and zfree } + + data_type : int; { best guess about the data type: ascii or binary } + adler : uLong; { adler32 value of the uncompressed data } + reserved : uLong; { reserved for future use } + end; + + +{ The application must update next_in and avail_in when avail_in has + dropped to zero. It must update next_out and avail_out when avail_out + has dropped to zero. The application must initialize zalloc, zfree and + opaque before calling the init function. All other fields are set by the + compression library and must not be updated by the application. + + The opaque value provided by the application will be passed as the first + parameter for calls of zalloc and zfree. This can be useful for custom + memory management. The compression library attaches no meaning to the + opaque value. + + zalloc must return Z_NULL if there is not enough memory for the object. + On 16-bit systems, the functions zalloc and zfree must be able to allocate + exactly 65536 bytes, but will not be required to allocate more than this + if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, + pointers returned by zalloc for objects of exactly 65536 bytes *must* + have their offset normalized to zero. The default allocation function + provided by this library ensures this (see zutil.c). To reduce memory + requirements and avoid any allocation of 64K objects, at the expense of + compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h). + + The fields total_in and total_out can be used for statistics or + progress reports. After compression, total_in holds the total size of + the uncompressed data and may be saved for use in the decompressor + (particularly if the decompressor wants to decompress everything in + a single step). } + +const { constants } + Z_NO_FLUSH = 0; + Z_PARTIAL_FLUSH = 1; + Z_SYNC_FLUSH = 2; + Z_FULL_FLUSH = 3; + Z_FINISH = 4; +{ Allowed flush values; see deflate() below for details } + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = (-1); + Z_STREAM_ERROR = (-2); + Z_DATA_ERROR = (-3); + Z_MEM_ERROR = (-4); + Z_BUF_ERROR = (-5); + Z_VERSION_ERROR = (-6); +{ Return codes for the compression/decompression functions. Negative + values are errors, positive values are used for special but normal events.} + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = (-1); +{ compression levels } + + Z_FILTERED = 1; + Z_HUFFMAN_ONLY = 2; + Z_DEFAULT_STRATEGY = 0; +{ compression strategy; see deflateInit2() below for details } + + Z_BINARY = 0; + Z_ASCII = 1; + Z_UNKNOWN = 2; +{ Possible values of the data_type field } + + Z_DEFLATED = 8; +{ The deflate compression method (the only one supported in this version) } + + Z_NULL = NIL; { for initializing zalloc, zfree, opaque } + + {$IFDEF GZIO} +var + errno : int; + {$ENDIF} + + { common constants } + + +{ The three kinds of block type } +const + STORED_BLOCK = 0; + STATIC_TREES = 1; + DYN_TREES = 2; +{ The minimum and maximum match lengths } +const + MIN_MATCH = 3; +{$ifdef MAX_MATCH_IS_258} + MAX_MATCH = 258; +{$else} + MAX_MATCH = ??; { deliberate syntax error } +{$endif} + +const + PRESET_DICT = $20; { preset dictionary flag in zlib header } + + + {$IFDEF DEBUG} +// procedure Assert(cond : boolean; msg : string); + {$ENDIF} + + procedure Trace(x : string); + procedure Tracev(x : string); + procedure Tracevv(x : string); + procedure Tracevvv(x : string); + procedure Tracec(c : boolean; x : string); + procedure Tracecv(c : boolean; x : string); + +function zlibVersion : string; +{ The application can compare zlibVersion and ZLIB_VERSION for consistency. + If the first character differs, the library code actually used is + not compatible with the zlib.h header file used by the application. + This check is automatically made by deflateInit and inflateInit. } + +function zError(err : int) : string; + +function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; + +procedure ZFREE (var strm : z_stream; ptr : voidpf); + +procedure TRY_FREE (var strm : z_stream; ptr : voidpf); + +const + ZLIB_VERSION : string[10] = '1.1.2'; + +const + z_errbase = Z_NEED_DICT; + z_errmsg : Array[0..9] of string[21] = { indexed by 2-zlib_error } + ('need dictionary', { Z_NEED_DICT 2 } + 'stream end', { Z_STREAM_END 1 } + '', { Z_OK 0 } + 'file error', { Z_ERRNO (-1) } + 'stream error', { Z_STREAM_ERROR (-2) } + 'data error', { Z_DATA_ERROR (-3) } + 'insufficient memory', { Z_MEM_ERROR (-4) } + 'buffer error', { Z_BUF_ERROR (-5) } + 'incompatible version',{ Z_VERSION_ERROR (-6) } + ''); +const + z_verbose : int = 1; + +{$IFDEF DEBUG} +procedure z_error (m : string); +{$ENDIF} + +implementation + +function zError(err : int) : string; +begin + zError := z_errmsg[Z_NEED_DICT-err]; +end; + +function zlibVersion : string; +begin + zlibVersion := ZLIB_VERSION; +end; + +//procedure z_error (m : string); +//begin +// WriteLn(output, m); +// Write('Zlib - Halt...'); +// ReadLn; +// Halt(1); +//end; + +//procedure Assert(cond : boolean; msg : string); +//begin +// if not cond then +// z_error(msg); +//end; + +procedure Trace(x : string); +begin + WriteLn(x); +end; + +procedure Tracev(x : string); +begin + if (z_verbose>0) then + WriteLn(x); +end; + +procedure Tracevv(x : string); +begin + if (z_verbose>1) then + WriteLn(x); +end; + +procedure Tracevvv(x : string); +begin + if (z_verbose>2) then + WriteLn(x); +end; + +procedure Tracec(c : boolean; x : string); +begin + if (z_verbose>0) and (c) then + WriteLn(x); +end; + +procedure Tracecv(c : boolean; x : string); +begin + if (z_verbose>1) and c then + WriteLn(x); +end; + +function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; +begin + ZALLOC := strm.zalloc(strm.opaque, items, size); +end; + +procedure ZFREE (var strm : z_stream; ptr : voidpf); +begin + strm.zfree(strm.opaque, ptr); +end; + +procedure TRY_FREE (var strm : z_stream; ptr : voidpf); +begin + {if @strm <> Z_NULL then} + strm.zfree(strm.opaque, ptr); +end; + +end. \ No newline at end of file diff --git a/delphionly/gzio.pas b/delphionly/gzio.pas new file mode 100755 index 0000000..1196c28 --- /dev/null +++ b/delphionly/gzio.pas @@ -0,0 +1,1378 @@ +Unit gzIO; +// Z_BUFSIZE = 16384 size does not appear to make much difference with 2007 systems +{ + Pascal unit based on gzio.c -- IO on .gz files + Copyright (C) 1995-1998 zJean-loup Gailly. + + Define NO_DEFLATE to compile this file without the compression code + + Pascal tranlastion based on code contributed by Francisco Javier Crespo + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + SysUtils, + zutil, zlib, crc, zdeflate, zinflate, Windows; + +type gzFile = voidp; +type z_off_t = long; + +function gzopenZskip(sourceFilename:string; mode:string; flags:uInt; skipBytes: int64) : gzFile; + +function gzopenZ (SourceFilename:string; mode:string; flags:uInt) : gzFile; //note: sourcefilename without '.gz' if writing, e.g. name file that exists +function gzread (f:gzFile; buf:voidp; len:uInt) : int; +function gzgetc (f:gzfile) : int; +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +{$ifndef NO_DEFLATE} +function gzwrite (f:gzFile; buf:voidp; len:uInt) : int; +function gzputc (f:gzfile; c:char) : int; +function gzputs (f:gzfile; s:PChar) : int; +function gzflush (f:gzFile; flush:int) : int; + {$ifdef GZ_FORMAT_STRING} + function gzprintf (zfile : gzFile; + const format : string; + a : array of int); { doesn't compile } + {$endif} +{$endif} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +function gztell (f:gzfile) : z_off_t; +function gzclose (f:gzFile) : int; +function gzerror (f:gzFile; var errnum:Int) : string; + +const + SEEK_SET {: z_off_t} = 0; { seek from beginning of file } + SEEK_CUR {: z_off_t} = 1; { seek from current position } + SEEK_END {: z_off_t} = 2; +const + Z_EOF = -1; { same value as in STDIO.H } + Z_BUFSIZE = 16384; + { Z_PRINTF_BUFSIZE = 4096; } + + + gz_magic : array[0..1] of byte = ($1F, $8B); { gzip magic header } + + { gzip flag byte } + + ASCII_FLAG = $01; { bit 0 set: file probably ascii text } + HEAD_CRC = $02; { bit 1 set: header CRC present } + EXTRA_FIELD = $04; { bit 2 set: extra field present } + ORIG_NAME = $08; { bit 3 set: original file name present } + COMMENT_ = $10; { bit 4 set: file comment present } + RESERVED = $E0; { bits 5..7: reserved } + +type gz_stream = record + stream : z_stream; + z_err : int; { error code for last stream operation } + z_eof : boolean; { set if end of input file } + gzfile : file; { .gz file } + inbuf : pBytef; { input buffer } + outbuf : pBytef; { output buffer } + crc : uLong; { crc32 of uncompressed data } + msg : string[79]; { error message - limit 79 chars } + path : string[255]; { path name for debugging only - limit 79 chars } + //Change by Chris Rorden: short path clips filename, it is clearly not only for debugging + //Previous line was originally + //path : string[79]; + + transparent : boolean; { true if input file is not a .gz file } + mode : char; { 'w' or 'r' } + startpos : long; { start of compressed data in file (header skipped) } +end; + +type gz_streamp = ^gz_stream; + +implementation + + +function destroyS (var s:gz_streamp) : int; forward; +procedure check_header(s:gz_streamp); forward; + + +{ GZOPEN ==================================================================== + + Opens a gzip (.gz) file for reading or writing. As Pascal does not use + file descriptors, the code has been changed to accept only path names. + + The mode parameter defaults to BINARY read or write operations ('r' or 'w') + but can also include a compression level ('w9') or a strategy: Z_FILTERED + as in 'w6f' or Z_HUFFMAN_ONLY as in 'w1h'. (See the description of + deflateInit2 for more information about the strategy parameter.) + + gzopen can be used to open a file which is not in gzip format; in this + case, gzread will directly read from the file without decompression. + + gzopen returns NIL if the file could not be opened (non-zero IOResult) + or if there was insufficient memory to allocate the (de)compression state + (zlib error is Z_MEM_ERROR). + + Vincent: + Added argument 'flags' to the original Zlib files. +============================================================================} +function gzopenZskip(sourceFilename:string; mode:string; flags:uInt; skipBytes: int64) : gzFile; + +var + + i : uInt; + err,level,strategy : int; { compression strategy } + s : gz_streamp; + path: string; +{$IFDEF MSDOS} + attr : word; { file attributes } +{$ENDIF} +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} +begin + path := sourceFilename; + if (path='') or (mode='') then begin + result := Z_NULL; + exit; + end; + if length(path) > 240 then begin + Path := ExtractShortPathName(Path); + if (length(path) > 240) or (length(path) < 1) then begin + //Showmessage('Unable to GZip this file: path name is too long'); + result := Z_NULL; + exit; + end; + end; + //showmessage(path+'@'+inttostr(length(path))); + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + result := Z_NULL; + exit; + end; + if (path='') then begin + // Showmessage('Error with path'); + result := Z_NULL; + exit; + end; + //showmessage('gzOpenCompleted'); + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + s^.stream.zalloc := NIL; { (alloc_func)0 } + s^.stream.zfree := NIL; { (free_func)0 } + s^.stream.opaque := NIL; { (voidpf)0 } + s^.stream.next_in := Z_NULL; + s^.stream.next_out := Z_NULL; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := Z_NULL; + s^.outbuf := Z_NULL; + s^.crc := crc32(0, Z_NULL, 0); + s^.msg := ''; + s^.transparent := false; + + //showmessage(s^.path+inttostr(length(path))); + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + //if (s^.mode='w') then begin path := path+'.gz'; end; + s^.path := path; { limit to 255 chars } + if (s^.mode=chr(0)) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = Z_NULL) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = Z_NULL) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + Assign (s^.gzfile, s^.path); + {$ifdef MSDOS} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + if {(not FileExists(s^.path)) and} (s^.mode='w') then + // Vincent: changed IF because I don't want old data behind my + // new made .gz-file + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := flags; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := LONG(10); +{$ENDIF} + end else begin + + if skipBytes > 0 then + Seek (s^.gzfile,skipBytes); + check_header(s); { skip the .gz header } + {$WARNINGS OFF} { combining signed and unsigned types } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + {$WARNINGS ON} + end; + result := gzFile(s); +end; + +function gzopenZ(sourceFilename:string; mode:string; flags:uInt) : gzFile; +begin + result := gzopenZskip(sourceFilename, mode, flags, 0); +end; + +(*function gzopenZ(sourceFilename:string; mode:string; flags:uInt) : gzFile; + +var + + i : uInt; + err,level,strategy : int; { compression strategy } + s : gz_streamp; + path: string; +{$IFDEF MSDOS} + attr : word; { file attributes } +{$ENDIF} + +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} + +begin + path := sourceFilename; + if (path='') or (mode='') then begin + result := Z_NULL; + exit; + end; + if length(path) > 240 then begin + Path := ExtractShortPathName(Path); + if (length(path) > 240) or (length(path) < 1) then begin + MessageBox(0,'GZ Error','GZ Error: path name is too long ',MB_OK or MB_ICONERROR); + //Showmessage('Unable to GZip this file: path name is too long'); + result := Z_NULL; + exit; + end; + end; + //showmessage(path+'@'+inttostr(length(path))); + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + result := Z_NULL; + exit; + end; + if (path='') then begin + //Showmessage('Error with path'); + MessageBox(0,'GZ Error','GZ Error: path error.',MB_OK or MB_ICONERROR); + result := Z_NULL; + exit; + end; + //showmessage('gzOpenCompleted'); + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + s^.stream.zalloc := NIL; { (alloc_func)0 } + s^.stream.zfree := NIL; { (free_func)0 } + s^.stream.opaque := NIL; { (voidpf)0 } + s^.stream.next_in := Z_NULL; + s^.stream.next_out := Z_NULL; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := Z_NULL; + s^.outbuf := Z_NULL; + s^.crc := crc32(0, Z_NULL, 0); + s^.msg := ''; + s^.transparent := false; + + //showmessage(s^.path+inttostr(length(path))); + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + //if (s^.mode='w') then begin path := path+'.gz'; end; + s^.path := path; { limit to 255 chars } + if (s^.mode=chr(0)) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = Z_NULL) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = Z_NULL) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + Assign (s^.gzfile, s^.path); + {$ifdef MSDOS} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + if {(not FileExists(s^.path)) and} (s^.mode='w') then + // Vincent: changed IF because I don't want old data behind my + // new made .gz-file + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := flags; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := LONG(10); +{$ENDIF} + end + else begin + check_header(s); { skip the .gz header } + {$WARNINGS OFF} { combining signed and unsigned types } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + {$WARNINGS ON} + end; + result := gzFile(s); +end; *) + + +{ GZSETPARAMS =============================================================== + + Update the compression level and strategy. + +============================================================================} + +//function gzsetparams (f:gzfile; level:int; strategy:int) : int; + +//var + +// s : gz_streamp; +// written: integer; + +//begin + +// s := gz_streamp(f); + +// if (s = NIL) or (s^.mode <> 'w') then begin +// gzsetparams := Z_STREAM_ERROR; +// exit; +// end; + + { Make room to allow flushing } +// if (s^.stream.avail_out = 0) then begin +// s^.stream.next_out := s^.outbuf; +// blockwrite(s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); +// if (written <> Z_BUFSIZE) then s^.z_err := Z_ERRNO; +// s^.stream.avail_out := Z_BUFSIZE; +// end; + +// gzsetparams := deflateParams (s^.stream, level, strategy); +//end; + + +{ GET_BYTE ================================================================== + + Read a byte from a gz_stream. Updates next_in and avail_in. + Returns EOF for end of file. + IN assertion: the stream s has been sucessfully opened for reading. + +============================================================================} + +function get_byte (s:gz_streamp) : int; + +begin + + if (s^.z_eof = true) then begin + get_byte := Z_EOF; + exit; + end; + + if (s^.stream.avail_in = 0) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then s^.z_err := Z_ERRNO; + get_byte := Z_EOF; + exit; + end; + s^.stream.next_in := s^.inbuf; + end; + + Dec(s^.stream.avail_in); + get_byte := s^.stream.next_in^; + Inc(s^.stream.next_in); + +end; + + +{ GETLONG =================================================================== + + Reads a Longint in LSB order from the given gz_stream. + +============================================================================} +{ +function getLong (s:gz_streamp) : uLong; +var + x : array [0..3] of byte; + i : byte; + c : int; + n1 : longint; + n2 : longint; +begin + + for i:=0 to 3 do begin + c := get_byte(s); + if (c = Z_EOF) then s^.z_err := Z_DATA_ERROR; + x[i] := (c and $FF) + end; + n1 := (ush(x[3] shl 8)) or x[2]; + n2 := (ush(x[1] shl 8)) or x[0]; + getlong := (n1 shl 16) or n2; +end; +} +function getLong(s : gz_streamp) : uLong; +var + x : packed array [0..3] of byte; + c : int; +begin + { x := uLong(get_byte(s)); - you can't do this with TP, no unsigned long } + { the following assumes a little endian machine and TP } + x[0] := Byte(get_byte(s)); + x[1] := Byte(get_byte(s)); + x[2] := Byte(get_byte(s)); + c := get_byte(s); + x[3] := Byte(c); + if (c = Z_EOF) then + s^.z_err := Z_DATA_ERROR; + GetLong := uLong(longint(x)); +end; + + +{ CHECK_HEADER ============================================================== + + Check the gzip header of a gz_stream opened for reading. + Set the stream mode to transparent if the gzip magic header is not present. + Set s^.err to Z_DATA_ERROR if the magic header is present but the rest of + the header is incorrect. + + IN assertion: the stream s has already been created sucessfully; + s^.stream.avail_in is zero for the first time, but may be non-zero + for concatenated .gz files + +============================================================================} + +procedure check_header (s:gz_streamp); + +var + + method : int; { method byte } + flags : int; { flags byte } + len : uInt; + c : int; + +begin + + { Check the gzip magic header } + for len := 0 to 1 do begin + c := get_byte(s); + if (c <> gz_magic[len]) then begin + if (len <> 0) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + end; + if (c <> Z_EOF) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + s^.transparent := TRUE; + end; + if (s^.stream.avail_in <> 0) then s^.z_err := Z_OK + else s^.z_err := Z_STREAM_END; + exit; + end; + end; + + method := get_byte(s); + flags := get_byte(s); + if (method <> Z_DEFLATED) or ((flags and RESERVED) <> 0) then begin + s^.z_err := Z_DATA_ERROR; + exit; + end; + + for len := 0 to 5 do get_byte(s); { Discard time, xflags and OS code } + + if ((flags and EXTRA_FIELD) <> 0) then begin { skip the extra field } + len := uInt(get_byte(s)); + len := len + (uInt(get_byte(s)) shr 8); + { len is garbage if EOF but the loop below will quit anyway } + while (len <> 0) and (get_byte(s) <> Z_EOF) do Dec(len); + end; + + if ((flags and ORIG_NAME) <> 0) then begin { skip the original file name } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and COMMENT_) <> 0) then begin { skip the .gz file comment } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and HEAD_CRC) <> 0) then begin { skip the header crc } + get_byte(s); + get_byte(s); + end; + + if (s^.z_eof = true) then + s^.z_err := Z_DATA_ERROR + else + s^.z_err := Z_OK; + +end; + + +{ DESTROY =================================================================== + + Cleanup then free the given gz_stream. Return a zlib error code. + Try freeing in the reverse order of allocations. + +============================================================================} + +function destroyS (var s:gz_streamp) : int; + +begin + + destroyS := Z_OK; + + if not Assigned (s) then begin + destroyS := Z_STREAM_ERROR; + exit; + end; + + if (s^.stream.state <> NIL) then begin + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + destroyS := Z_STREAM_ERROR; +{$ELSE} + destroyS := deflateEnd(s^.stream); +{$ENDIF} + end + else if (s^.mode = 'r') then begin + destroyS := inflateEnd(s^.stream); + end; + end; + + if (s^.path <> '') then begin + {$I-} + close(s^.gzfile); + {$I+} + if (IOResult <> 0) then destroyS := Z_ERRNO; + end; + + if (s^.z_err < 0) then destroyS := s^.z_err; + + if Assigned (s^.inbuf) then + FreeMem(s^.inbuf, Z_BUFSIZE); + if Assigned (s^.outbuf) then + FreeMem(s^.outbuf, Z_BUFSIZE); + FreeMem(s, sizeof(gz_stream)); + +end; + + +{ GZREAD ==================================================================== + + Reads the given number of uncompressed bytes from the compressed file. + If the input file was not in gzip format, gzread copies the given number + of bytes into the buffer. + + gzread returns the number of uncompressed bytes actually read + (0 for end of file, -1 for error). + +============================================================================} + +function gzread (f:gzFile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + start : pBytef; + next_out : pBytef; + n : uInt; + crclen : uInt; { Buffer length to update CRC32 } + filecrc : uLong; { CRC32 stored in GZIP'ed file } + filelen : uLong; { Total lenght of uncompressed file } + bytes : integer; { bytes actually read in I/O blockread } + total_in : uLong; + total_out : uLong; + +begin + + s := gz_streamp(f); + start := pBytef(buf); { starting point for crc computation } + + if (s = NIL) or (s^.mode <> 'r') then begin + gzread := Z_STREAM_ERROR; + exit; + end; + + if (s^.z_err = Z_DATA_ERROR) or (s^.z_err = Z_ERRNO) then begin + gzread := -1; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then begin + gzread := 0; { EOF } + exit; + end; + + s^.stream.next_out := pBytef(buf); + s^.stream.avail_out := len; + + while (s^.stream.avail_out <> 0) do begin + + if (s^.transparent = true) then begin + { Copy first the lookahead bytes: } + n := s^.stream.avail_in; + if (n > s^.stream.avail_out) then n := s^.stream.avail_out; + if (n > 0) then begin + zmemcpy(s^.stream.next_out, s^.stream.next_in, n); + inc (s^.stream.next_out, n); + inc (s^.stream.next_in, n); + dec (s^.stream.avail_out, n); + dec (s^.stream.avail_in, n); + end; + if (s^.stream.avail_out > 0) then begin + blockread (s^.gzfile, s^.stream.next_out^, s^.stream.avail_out, bytes); + dec (s^.stream.avail_out, uInt(bytes)); + end; + dec (len, s^.stream.avail_out); + inc (s^.stream.total_in, uLong(len)); + inc (s^.stream.total_out, uLong(len)); + gzread := int(len); + exit; + end; { IF transparent } + + if (s^.stream.avail_in = 0) and (s^.z_eof = false) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then begin + s^.z_err := Z_ERRNO; + break; + end; + end; + s^.stream.next_in := s^.inbuf; + end; + + s^.z_err := inflate(s^.stream, Z_NO_FLUSH); + + if (s^.z_err = Z_STREAM_END) then begin + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + { Check CRC and original size } + s^.crc := crc32(s^.crc, start, crclen); + start := s^.stream.next_out; + + filecrc := getLong (s); + filelen := getLong (s); + + if (s^.crc <> filecrc) or (s^.stream.total_out <> filelen) + then s^.z_err := Z_DATA_ERROR + else begin + { Check for concatenated .gz files: } + check_header(s); + if (s^.z_err = Z_OK) then begin + total_in := s^.stream.total_in; + total_out := s^.stream.total_out; + + inflateReset (s^.stream); + s^.stream.total_in := total_in; + s^.stream.total_out := total_out; + s^.crc := crc32 (0, Z_NULL, 0); + end; + end; {IF-THEN-ELSE} + end; + + if (s^.z_err <> Z_OK) or (s^.z_eof = true) then break; + + end; {WHILE} + + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + s^.crc := crc32 (s^.crc, start, crclen); + + gzread := int(len - s^.stream.avail_out); + +end; + + +{ GZGETC ==================================================================== + + Reads one byte from the compressed file. + gzgetc returns this byte or -1 in case of end of file or error. + +============================================================================} + +function gzgetc (f:gzfile) : int; + +var c:byte; + +begin + + if (gzread (f,@c,1) = 1) then gzgetc := c else gzgetc := -1; + +end; + + +{ GZGETS ==================================================================== + + Reads bytes from the compressed file until len-1 characters are read, + or a newline character is read and transferred to buf, or an end-of-file + condition is encountered. The string is then Null-terminated. + + gzgets returns buf, or Z_NULL in case of error. + The current implementation is not optimized at all. + +============================================================================} + +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +var + + b : PChar; { start of buffer } + bytes : Int; { number of bytes read by gzread } + gzchar : char; { char read by gzread } + +begin + + if (buf = Z_NULL) or (len <= 0) then begin + gzgets := Z_NULL; + exit; + end; + + b := buf; + repeat + dec (len); + bytes := gzread (f, buf, 1); + gzchar := buf^; + inc (buf); + until (len = 0) or (bytes <> 1) or (gzchar = Chr(13)); + + buf^ := Chr(0); + if (b = buf) and (len > 0) then gzgets := Z_NULL else gzgets := b; + +end; + + +{$IFNDEF NO_DEFLATE} + +{ GZWRITE =================================================================== + + Writes the given number of uncompressed bytes into the compressed file. + gzwrite returns the number of uncompressed bytes actually written + (0 in case of error). + +============================================================================} + +function gzwrite (f:gzfile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + written : integer; + +begin + + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + gzwrite := Z_STREAM_ERROR; + exit; + end; + + s^.stream.next_in := pBytef(buf); + s^.stream.avail_in := len; + + while (s^.stream.avail_in <> 0) do begin + + if (s^.stream.avail_out = 0) then begin + s^.stream.next_out := s^.outbuf; + blockwrite (s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); + if (written <> Z_BUFSIZE) then begin + s^.z_err := Z_ERRNO; + break; + end; + s^.stream.avail_out := Z_BUFSIZE; + end; + + s^.z_err := deflate(s^.stream, Z_NO_FLUSH); + if (s^.z_err <> Z_OK) then break; + + end; {WHILE} + + s^.crc := crc32(s^.crc, buf, len); + gzwrite := int(len - s^.stream.avail_in); + +end; + + +{ =========================================================================== + Converts, formats, and writes the args to the compressed file under + control of the format string, as in fprintf. gzprintf returns the number of + uncompressed bytes actually written (0 in case of error). +} + +{$IFDEF GZ_FORMAT_STRING} +function gzprintf (zfile : gzFile; + const format : string; + a : array of int) : int; +var + buf : array[0..Z_PRINTF_BUFSIZE-1] of char; + len : int; +begin +{$ifdef HAS_snprintf} + snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$else} + sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$endif} + len := strlen(buf); { old sprintf doesn't return the nb of bytes written } + if (len <= 0) return 0; + + gzprintf := gzwrite(file, buf, len); +end; +{$ENDIF} + + +{ GZPUTC ==================================================================== + + Writes c, converted to an unsigned char, into the compressed file. + gzputc returns the value that was written, or -1 in case of error. + +============================================================================} + +function gzputc (f:gzfile; c:char) : int; +begin + if (gzwrite (f,@c,1) = 1) then + {$IFDEF FPC} + gzputc := int(ord(c)) + {$ELSE} + gzputc := int(c) + {$ENDIF} + else + gzputc := -1; +end; + + +{ GZPUTS ==================================================================== + + Writes the given null-terminated string to the compressed file, excluding + the terminating null character. + gzputs returns the number of characters written, or -1 in case of error. + +============================================================================} + +function gzputs (f:gzfile; s:PChar) : int; +begin + gzputs := gzwrite (f, voidp(s), strlen(s)); +end; + + +{ DO_FLUSH ================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + +============================================================================} + +function do_flush (f:gzfile; flush:int) : int; +var + len : uInt; + done : boolean; + s : gz_streamp; + written : integer; +begin + done := false; + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + do_flush := Z_STREAM_ERROR; + exit; + end; + + s^.stream.avail_in := 0; { should be zero already anyway } + + while true do begin + + len := Z_BUFSIZE - s^.stream.avail_out; + + if (len <> 0) then begin + {$I-} + blockwrite(s^.gzfile, s^.outbuf^, len, written); + {$I+} + {$WARNINGS OFF} {Comparing signed and unsigned types} + if (written <> len) then begin + {$WARNINGS ON} + s^.z_err := Z_ERRNO; + do_flush := Z_ERRNO; + exit; + end; + s^.stream.next_out := s^.outbuf; + s^.stream.avail_out := Z_BUFSIZE; + end; + + if (done = true) then break; + s^.z_err := deflate(s^.stream, flush); + + { Ignore the second of two consecutive flushes: } + if (len = 0) and (s^.z_err = Z_BUF_ERROR) then s^.z_err := Z_OK; + + { deflate has finished flushing only when it hasn't used up + all the available space in the output buffer: } + + done := (s^.stream.avail_out <> 0) or (s^.z_err = Z_STREAM_END); + if (s^.z_err <> Z_OK) and (s^.z_err <> Z_STREAM_END) then break; + + end; {WHILE} + + if (s^.z_err = Z_STREAM_END) then do_flush:=Z_OK else do_flush:=s^.z_err; +end; + +{ GZFLUSH =================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + + The return value is the zlib error number (see function gzerror below). + gzflush returns Z_OK if the flush parameter is Z_FINISH and all output + could be flushed. + + gzflush should be called only when strictly necessary because it can + degrade compression. + +============================================================================} + +function gzflush (f:gzfile; flush:int) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + err := do_flush (f, flush); + + if (err <> 0) then begin + gzflush := err; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then gzflush := Z_OK else gzflush := s^.z_err; +end; + +{$ENDIF} (* NO DEFLATE *) + + +{ GZREWIND ================================================================== + + Rewinds input file. + +============================================================================} + +function gzrewind (f:gzFile) : int; +var + s:gz_streamp; +begin + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'r') then begin + gzrewind := -1; + exit; + end; + + s^.z_err := Z_OK; + s^.z_eof := false; + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + + if (s^.startpos = 0) then begin { not a compressed file } + {$I-} + seek (s^.gzfile, 0); + {$I+} + gzrewind := 0; + exit; + end; + + inflateReset(s^.stream); + {$I-} + seek (s^.gzfile, s^.startpos); + {$I+} + gzrewind := int(IOResult); + exit; +end; + + +{ GZSEEK ==================================================================== + + Sets the starting position for the next gzread or gzwrite on the given + compressed file. The offset represents a number of bytes from the beginning + of the uncompressed stream. + + gzseek returns the resulting offset, or -1 in case of error. + SEEK_END is not implemented, returns error. + In this version of the library, gzseek can be extremely slow. + +============================================================================} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +var + s : gz_streamp; + size : uInt; +begin + s := gz_streamp(f); + + if (s = NIL) or (whence = SEEK_END) or (s^.z_err = Z_ERRNO) + or (s^.z_err = Z_DATA_ERROR) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzseek := z_off_t(-1); + exit; +{$ELSE} + if (whence = SEEK_SET) then dec(offset, s^.stream.total_out); + if (offset < 0) then begin; + gzseek := z_off_t(-1); + exit; + end; + + { At this point, offset is the number of zero bytes to write. } + if (s^.inbuf = Z_NULL) then begin + GetMem (s^.inbuf, Z_BUFSIZE); + zmemzero(s^.inbuf, Z_BUFSIZE); + end; + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := uInt(offset); + + size := gzwrite(f, s^.inbuf, size); + if (size = 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + dec (offset,size); + end; + + gzseek := z_off_t(s^.stream.total_in); + exit; +{$ENDIF} + end; + { Rest of function is for reading only } + + { compute absolute position } + if (whence = SEEK_CUR) then inc (offset, s^.stream.total_out); + if (offset < 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.transparent = true) then begin + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + {$I-} + seek (s^.gzfile, offset); + {$I+} + if (IOResult <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + s^.stream.total_in := uLong(offset); + s^.stream.total_out := uLong(offset); + gzseek := z_off_t(offset); + exit; + end; + + { For a negative seek, rewind and use positive seek } + if (uLong(offset) >= s^.stream.total_out) + then dec (offset, s^.stream.total_out) + else if (gzrewind(f) <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + { offset is now the number of bytes to skip. } + + if (offset <> 0) and (s^.outbuf = Z_NULL) + then GetMem (s^.outbuf, Z_BUFSIZE); + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := int(offset); + + size := gzread (f, s^.outbuf, size); + if (size <= 0) then begin + gzseek := z_off_t(-1); + exit; + end; + dec(offset, size); + end; + + gzseek := z_off_t(s^.stream.total_out); +end; + + +{ GZTELL ==================================================================== + + Returns the starting position for the next gzread or gzwrite on the + given compressed file. This position represents a number of bytes in the + uncompressed data stream. + +============================================================================} + +function gztell (f:gzfile) : z_off_t; +begin + gztell := gzseek (f, 0, SEEK_CUR); +end; + + +{ GZEOF ===================================================================== + + Returns TRUE when EOF has previously been detected reading the given + input stream, otherwise FALSE. + +============================================================================} + +//function gzeof (f:gzfile) : boolean; +//var +// s:gz_streamp; +//begin +// s := gz_streamp(f); + +// if (s=NIL) or (s^.mode<>'r') then +// gzeof := false +// else +// gzeof := s^.z_eof; +//end; + + +{ PUTLONG =================================================================== + + Outputs a Longint in LSB order to the given file + +============================================================================} + +procedure putLong (var f:file; x:uLong); +var + n : int; + c : byte; +begin + for n:=0 to 3 do begin + c := x and $FF; + blockwrite (f, c, 1); + x := x shr 8; + end; +end; + + +{ GZCLOSE =================================================================== + + Flushes all pending output if necessary, closes the compressed file + and deallocates all the (de)compression state. + + The return value is the zlib error number (see function gzerror below). + +============================================================================} + +function gzclose (f:gzFile) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + gzclose := Z_STREAM_ERROR; + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzclose := Z_STREAM_ERROR; + exit; +{$ELSE} + err := do_flush (f, Z_FINISH); + if (err <> Z_OK) then begin + gzclose := destroyS (gz_streamp(f)); + exit; + end; + + putLong (s^.gzfile, s^.crc); + putLong (s^.gzfile, s^.stream.total_in); +{$ENDIF} + end; + + gzclose := destroyS (gz_streamp(f)); +end; + + +{ GZERROR =================================================================== + + Returns the error message for the last error which occured on the + given compressed file. errnum is set to zlib error number. If an + error occured in the file system and not in the compression library, + errnum is set to Z_ERRNO and the application may consult errno + to get the exact error code. + +============================================================================} + +function gzerror (f:gzfile; var errnum:int) : string; +var + m : string; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + errnum := Z_STREAM_ERROR; + gzerror := zError(Z_STREAM_ERROR); + end; + + errnum := s^.z_err; + if (errnum = Z_OK) then begin + gzerror := zError(Z_OK); + exit; + end; + + m := s^.stream.msg; + if (errnum = Z_ERRNO) then m := ''; + if (m = '') then m := zError(s^.z_err); + + s^.msg := s^.path+': '+m; + gzerror := s^.msg; +end; + +end. \ No newline at end of file diff --git a/delphionly/infblock.pas b/delphionly/infblock.pas new file mode 100755 index 0000000..70e90f1 --- /dev/null +++ b/delphionly/infblock.pas @@ -0,0 +1,951 @@ +Unit InfBlock; + +{ infblock.h and + infblock.c -- interpret and process block types to last block + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + {$IFDEF DEBUG} + strutils, + {$ENDIF} + zutil, zlib; + +function inflate_blocks_new(var z : z_stream; + c : check_func; { check function } + w : uInt { window size } + ) : pInflate_blocks_state; + +function inflate_blocks (var s : inflate_blocks_state; + var z : z_stream; + r : int { initial return code } + ) : int; + +procedure inflate_blocks_reset (var s : inflate_blocks_state; + var z : z_stream; + c : puLong); { check value on output } + + +function inflate_blocks_free(s : pInflate_blocks_state; + var z : z_stream) : int; + +procedure inflate_set_dictionary(var s : inflate_blocks_state; + const d : array of byte; { dictionary } + n : uInt); { dictionary length } + +function inflate_blocks_sync_point(var s : inflate_blocks_state) : int; + +implementation + +uses + infcodes, inftrees, infutil; + +{ Tables for deflate from PKZIP's appnote.txt. } +Const + border : Array [0..18] Of Word { Order of the bit length code lengths } + = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); + +{ Notes beyond the 1.93a appnote.txt: + + 1. Distance pointers never point before the beginning of the output + stream. + 2. Distance pointers can point back across blocks, up to 32k away. + 3. There is an implied maximum of 7 bits for the bit length table and + 15 bits for the actual data. + 4. If only one code exists, then it is encoded using one bit. (Zero + would be more efficient, but perhaps a little confusing.) If two + codes exist, they are coded using one bit each (0 and 1). + 5. There is no way of sending zero distance codes--a dummy must be + sent if there are none. (History: a pre 2.0 version of PKZIP would + store blocks with no distance codes, but this was discovered to be + too harsh a criterion.) Valid only for 1.93a. 2.04c does allow + zero distance codes, which is sent as one code of zero bits in + length. + 6. There are up to 286 literal/length codes. Code 256 represents the + end-of-block. Note however that the static length tree defines + 288 codes just to fill out the Huffman codes. Codes 286 and 287 + cannot be used though, since there is no length base or extra bits + defined for them. Similarily, there are up to 30 distance codes. + However, static trees define 32 codes (all 5 bits) to fill out the + Huffman codes, but the last two had better not show up in the data. + 7. Unzip can check dynamic Huffman blocks for complete code sets. + The exception is that a single code would not be complete (see #4). + 8. The five bits following the block type is really the number of + literal codes sent minus 257. + 9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits + (1+6+6). Therefore, to output three times the length, you output + three codes (1+1+1), whereas to output four times the same length, + you only need two codes (1+3). Hmm. + 10. In the tree reconstruction algorithm, Code = Code + Increment + only if BitLength(i) is not zero. (Pretty obvious.) + 11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19) + 12. Note: length code 284 can represent 227-258, but length code 285 + really is 258. The last length deserves its own, short code + since it gets used a lot in very redundant files. The length + 258 is special since 258 - 3 (the min match length) is 255. + 13. The literal/length and distance code bit lengths are read as a + single stream of lengths. It is possible (and advantageous) for + a repeat code (16, 17, or 18) to go across the boundary between + the two sets of lengths. } + + +procedure inflate_blocks_reset (var s : inflate_blocks_state; + var z : z_stream; + c : puLong); { check value on output } +begin + if (c <> Z_NULL) then + c^ := s.check; + if (s.mode = BTREE) or (s.mode = DTREE) then + ZFREE(z, s.sub.trees.blens); + if (s.mode = CODES) then + inflate_codes_free(s.sub.decode.codes, z); + + s.mode := ZTYPE; + s.bitk := 0; + s.bitb := 0; + + s.write := s.window; + s.read := s.window; + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(uLong(0), pBytef(NIL), 0); + z.adler := s.check; + end; + {$IFDEF DEBUG} + Tracev('inflate: blocks reset'); + {$ENDIF} +end; + + +function inflate_blocks_new(var z : z_stream; + c : check_func; { check function } + w : uInt { window size } + ) : pInflate_blocks_state; +var + s : pInflate_blocks_state; +begin + s := pInflate_blocks_state( ZALLOC(z,1, sizeof(inflate_blocks_state)) ); + if (s = Z_NULL) then + begin + inflate_blocks_new := s; + exit; + end; + s^.hufts := huft_ptr( ZALLOC(z, sizeof(inflate_huft), MANY) ); + + if (s^.hufts = Z_NULL) then + begin + ZFREE(z, s); + inflate_blocks_new := Z_NULL; + exit; + end; + + s^.window := pBytef( ZALLOC(z, 1, w) ); + if (s^.window = Z_NULL) then + begin + ZFREE(z, s^.hufts); + ZFREE(z, s); + inflate_blocks_new := Z_NULL; + exit; + end; + s^.zend := s^.window; + Inc(s^.zend, w); + s^.checkfn := c; + s^.mode := ZTYPE; + {$IFDEF DEBUG} + Tracev('inflate: blocks allocated'); + {$ENDIF} + inflate_blocks_reset(s^, z, Z_NULL); + inflate_blocks_new := s; +end; + + +function inflate_blocks (var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; { initial return code } +label + start_btree, start_dtree, + start_blkdone, start_dry, + start_codes; + +var + t : uInt; { temporary storage } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } +{ fixed code blocks } +var + bl, bd : uInt; + tl, td : pInflate_huft; +var + h : pInflate_huft; + i, j, c : uInt; +var + cs : pInflate_codes_state; +begin + { copy input/output information to locals } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + +{ decompress an inflated block } + + + { process input based on current state } + while True do + Case s.mode of + ZTYPE: + begin + {NEEDBITS(3);} + while (k < 3) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := uInt(b) and 7; + s.last := boolean(t and 1); + case (t shr 1) of + 0: { stored } + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: stored block (last)') + else + Tracev('inflate: stored block'); + {$ENDIF} + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + t := k and 7; { go to byte boundary } + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + s.mode := LENS; { get length of stored block } + end; + 1: { fixed } + begin + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: fixed codes blocks (last)') + else + Tracev('inflate: fixed codes blocks'); + {$ENDIF} + inflate_trees_fixed(bl, bd, tl, td, z); + s.sub.decode.codes := inflate_codes_new(bl, bd, tl, td, z); + if (s.sub.decode.codes = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := CODES; + end; + 2: { dynamic } + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: dynamic codes block (last)') + else + Tracev('inflate: dynamic codes block'); + {$ENDIF} + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := TABLE; + end; + 3: + begin { illegal } + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := BLKBAD; + z.msg := 'invalid block type'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + end; + LENS: + begin + {NEEDBITS(32);} + while (k < 32) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + if (((not b) shr 16) and $ffff) <> (b and $ffff) then + begin + s.mode := BLKBAD; + z.msg := 'invalid stored block lengths'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.left := uInt(b) and $ffff; + k := 0; + b := 0; { dump bits } + {$IFDEF DEBUG} + Tracev('inflate: stored length '+IntToStr(s.sub.left)); + {$ENDIF} + if s.sub.left <> 0 then + s.mode := STORED + else + if s.last then + s.mode := DRY + else + s.mode := ZTYPE; + end; + STORED: + begin + if (n = 0) then + begin + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + t := s.sub.left; + if (t > n) then + t := n; + if (t > m) then + t := m; + zmemcpy(q, p, t); + Inc(p, t); Dec(n, t); + Inc(q, t); Dec(m, t); + Dec(s.sub.left, t); + if (s.sub.left = 0) then + begin + {$IFDEF DEBUG} + if (ptr2int(q) >= ptr2int(s.read)) then + Tracev('inflate: stored end '+ + IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out') + else + Tracev('inflate: stored end '+ + IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) + + ptr2int(q) - ptr2int(s.window)) + ' total out'); + {$ENDIF} + if s.last then + s.mode := DRY + else + s.mode := ZTYPE; + end; + end; + TABLE: + begin + {NEEDBITS(14);} + while (k < 14) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := uInt(b) and $3fff; + s.sub.trees.table := t; + {$ifndef PKZIP_BUG_WORKAROUND} + if ((t and $1f) > 29) or (((t shr 5) and $1f) > 29) then + begin + s.mode := BLKBAD; + z.msg := 'too many length or distance symbols'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {$endif} + t := 258 + (t and $1f) + ((t shr 5) and $1f); + s.sub.trees.blens := puIntArray( ZALLOC(z, t, sizeof(uInt)) ); + if (s.sub.trees.blens = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {DUMPBITS(14);} + b := b shr 14; + Dec(k, 14); + + s.sub.trees.index := 0; + {$IFDEF DEBUG} + Tracev('inflate: table sizes ok'); + {$ENDIF} + s.mode := BTREE; + { fall trough case is handled by the while } + { try GOTO for speed - Nomssi } + goto start_btree; + end; + BTREE: + begin + start_btree: + while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do + begin + {NEEDBITS(3);} + while (k < 3) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + s.sub.trees.blens^[border[s.sub.trees.index]] := uInt(b) and 7; + Inc(s.sub.trees.index); + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + end; + while (s.sub.trees.index < 19) do + begin + s.sub.trees.blens^[border[s.sub.trees.index]] := 0; + Inc(s.sub.trees.index); + end; + s.sub.trees.bb := 7; + t := inflate_trees_bits(s.sub.trees.blens^, s.sub.trees.bb, + s.sub.trees.tb, s.hufts^, z); + if (t <> Z_OK) then + begin + ZFREE(z, s.sub.trees.blens); + r := t; + if (r = Z_DATA_ERROR) then + s.mode := BLKBAD; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.trees.index := 0; + {$IFDEF DEBUG} + Tracev('inflate: bits tree ok'); + {$ENDIF} + s.mode := DTREE; + { fall through again } + goto start_dtree; + end; + DTREE: + begin + start_dtree: + while TRUE do + begin + t := s.sub.trees.table; + if not (s.sub.trees.index < 258 + + (t and $1f) + ((t shr 5) and $1f)) then + break; + t := s.sub.trees.bb; + {NEEDBITS(t);} + while (k < t) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + h := s.sub.trees.tb; + Inc(h, uInt(b) and inflate_mask[t]); + t := h^.Bits; + c := h^.Base; + + if (c < 16) then + begin + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + s.sub.trees.blens^[s.sub.trees.index] := c; + Inc(s.sub.trees.index); + end + else { c = 16..18 } + begin + if c = 18 then + begin + i := 7; + j := 11; + end + else + begin + i := c - 14; + j := 3; + end; + {NEEDBITS(t + i);} + while (k < t + i) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + Inc(j, uInt(b) and inflate_mask[i]); + {DUMPBITS(i);} + b := b shr i; + Dec(k, i); + + i := s.sub.trees.index; + t := s.sub.trees.table; + if (i + j > 258 + (t and $1f) + ((t shr 5) and $1f)) or + ((c = 16) and (i < 1)) then + begin + ZFREE(z, s.sub.trees.blens); + s.mode := BLKBAD; + z.msg := 'invalid bit length repeat'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + if c = 16 then + c := s.sub.trees.blens^[i - 1] + else + c := 0; + repeat + s.sub.trees.blens^[i] := c; + Inc(i); + Dec(j); + until (j=0); + s.sub.trees.index := i; + end; + end; { while } + s.sub.trees.tb := Z_NULL; + begin + bl := 9; { must be <= 9 for lookahead assumptions } + bd := 6; { must be <= 9 for lookahead assumptions } + t := s.sub.trees.table; + t := inflate_trees_dynamic(257 + (t and $1f), + 1 + ((t shr 5) and $1f), + s.sub.trees.blens^, bl, bd, tl, td, s.hufts^, z); + ZFREE(z, s.sub.trees.blens); + if (t <> Z_OK) then + begin + if (t = uInt(Z_DATA_ERROR)) then + s.mode := BLKBAD; + r := t; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {$IFDEF DEBUG} + Tracev('inflate: trees ok'); + {$ENDIF} + { c renamed to cs } + cs := inflate_codes_new(bl, bd, tl, td, z); + if (cs = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.decode.codes := cs; + end; + s.mode := CODES; + { yet another falltrough } + goto start_codes; + end; + CODES: + begin + start_codes: + { update pointers } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + r := inflate_codes(s, z, r); + if (r <> Z_STREAM_END) then + begin + inflate_blocks := inflate_flush(s, z, r); + exit; + end; + r := Z_OK; + inflate_codes_free(s.sub.decode.codes, z); + { load local pointers } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + {$IFDEF DEBUG} + if (ptr2int(q) >= ptr2int(s.read)) then + Tracev('inflate: codes end '+ + IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out') + else + Tracev('inflate: codes end '+ + IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) + + ptr2int(q) - ptr2int(s.window)) + ' total out'); + {$ENDIF} + if (not s.last) then + begin + s.mode := ZTYPE; + continue; { break for switch statement in C-code } + end; + {$ifndef patch112} + if (k > 7) then { return unused byte, if any } + begin + {$IFDEF DEBUG} + Assert(k < 16, 'inflate_codes grabbed too many bytes'); + {$ENDIF} + Dec(k, 8); + Inc(n); + Dec(p); { can always return one } + end; + {$endif} + s.mode := DRY; + { another falltrough } + goto start_dry; + end; + DRY: + begin + start_dry: + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + + { not needed anymore, we are done: + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + } + + if (s.read <> s.write) then + begin + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.mode := BLKDONE; + goto start_blkdone; + end; + BLKDONE: + begin + start_blkdone: + r := Z_STREAM_END; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + BLKBAD: + begin + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + else + begin + r := Z_STREAM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; { Case s.mode of } + +end; + + +function inflate_blocks_free(s : pInflate_blocks_state; + var z : z_stream) : int; +begin + inflate_blocks_reset(s^, z, Z_NULL); + ZFREE(z, s^.window); + ZFREE(z, s^.hufts); + ZFREE(z, s); + {$IFDEF DEBUG} + Trace('inflate: blocks freed'); + {$ENDIF} + inflate_blocks_free := Z_OK; +end; + + +procedure inflate_set_dictionary(var s : inflate_blocks_state; + const d : array of byte; { dictionary } + n : uInt); { dictionary length } +begin + zmemcpy(s.window, pBytef(@d), n); + s.write := s.window; + Inc(s.write, n); + s.read := s.write; +end; + + +{ Returns true if inflate is currently at the end of a block generated + by Z_SYNC_FLUSH or Z_FULL_FLUSH. + IN assertion: s <> Z_NULL } + +function inflate_blocks_sync_point(var s : inflate_blocks_state) : int; +begin + inflate_blocks_sync_point := int(s.mode = LENS); +end; + +end. \ No newline at end of file diff --git a/delphionly/inffast.pas b/delphionly/inffast.pas new file mode 100755 index 0000000..668f71b --- /dev/null +++ b/delphionly/inffast.pas @@ -0,0 +1,318 @@ +Unit InfFast; + +{ + inffast.h and + inffast.c -- process literals and length/distance pairs fast + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + + +interface + +{$I zconf.inc} + +uses + {$ifdef DEBUG} + strutils, + {$ENDIF} + zutil, zlib; + +function inflate_fast( bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var s : inflate_blocks_state; + var z : z_stream) : int; + + +implementation + +uses + infutil; + + +{ Called with number of bytes left to write in window at least 258 + (the maximum string length) and number of input bytes available + at least ten. The ten bytes are six bytes for the longest length/ + distance pair plus four bytes for overloading the bit buffer. } + +function inflate_fast( bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var s : inflate_blocks_state; + var z : z_stream) : int; + +var + t : pInflate_huft; { temporary pointer } + e : uInt; { extra bits or operation } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } + ml : uInt; { mask for literal/length tree } + md : uInt; { mask for distance tree } + c : uInt; { bytes to copy } + d : uInt; { distance back to copy from } + r : pBytef; { copy source pointer } +begin + { load input, output, bit values (macro LOAD) } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + { initialize masks } + ml := inflate_mask[bl]; + md := inflate_mask[bd]; + + { do until not enough input or output space for fast loop } + repeat { assume called with (m >= 258) and (n >= 10) } + { get literal/length code } + {GRABBITS(20);} { max bits for literal/length code } + while (k < 20) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := @(huft_ptr(tl)^[uInt(b) and ml]); + + e := t^.exop; + if (e = 0) then + begin + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: * literal '+char(t^.base)) + else + Tracevv('inflate: * literal '+ IntToStr(t^.base)); + {$ENDIF} + q^ := Byte(t^.base); + Inc(q); + Dec(m); + continue; + end; + repeat + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + if (e and 16 <> 0) then + begin + { get extra bits for length } + e := e and 15; + c := t^.base + (uInt(b) and inflate_mask[e]); + {DUMPBITS(e);} + b := b shr e; + Dec(k, e); + {$IFDEF DEBUG} + Tracevv('inflate: * length ' + IntToStr(c)); + {$ENDIF} + { decode distance base of block to copy } + {GRABBITS(15);} { max bits for distance code } + while (k < 15) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := @huft_ptr(td)^[uInt(b) and md]; + e := t^.exop; + repeat + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + if (e and 16 <> 0) then + begin + { get extra bits to add to distance base } + e := e and 15; + {GRABBITS(e);} { get extra bits (up to 13) } + while (k < e) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + d := t^.base + (uInt(b) and inflate_mask[e]); + {DUMPBITS(e);} + b := b shr e; + Dec(k, e); + + {$IFDEF DEBUG} + Tracevv('inflate: * distance '+IntToStr(d)); + {$ENDIF} + { do the copy } + Dec(m, c); + if (uInt(ptr2int(q) - ptr2int(s.window)) >= d) then { offset before dest } + begin { just copy } + r := q; + Dec(r, d); + q^ := r^; Inc(q); Inc(r); Dec(c); { minimum count is three, } + q^ := r^; Inc(q); Inc(r); Dec(c); { so unroll loop a little } + end + else { else offset after destination } + begin + e := d - uInt(ptr2int(q) - ptr2int(s.window)); { bytes from offset to end } + r := s.zend; + Dec(r, e); { pointer to offset } + if (c > e) then { if source crosses, } + begin + Dec(c, e); { copy to end of window } + repeat + q^ := r^; + Inc(q); + Inc(r); + Dec(e); + until (e=0); + r := s.window; { copy rest from start of window } + end; + end; + repeat { copy all or what's left } + q^ := r^; + Inc(q); + Inc(r); + Dec(c); + until (c = 0); + break; + end + else + if (e and 64 = 0) then + begin + Inc(t, t^.base + (uInt(b) and inflate_mask[e])); + e := t^.exop; + end + else + begin + z.msg := 'invalid distance code'; + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + inflate_fast := Z_DATA_ERROR; + exit; + end; + until FALSE; + break; + end; + if (e and 64 = 0) then + begin + {t += t->base; + e = (t += ((uInt)b & inflate_mask[e]))->exop;} + + Inc(t, t^.base + (uInt(b) and inflate_mask[e])); + e := t^.exop; + if (e = 0) then + begin + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: * literal '+char(t^.base)) + else + Tracevv('inflate: * literal '+IntToStr(t^.base)); + {$ENDIF} + q^ := Byte(t^.base); + Inc(q); + Dec(m); + break; + end; + end + else + if (e and 32 <> 0) then + begin + {$IFDEF DEBUG} + Tracevv('inflate: * end of block'); + {$ENDIF} + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_STREAM_END; + exit; + end + else + begin + z.msg := 'invalid literal/length code'; + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_DATA_ERROR; + exit; + end; + until FALSE; + until (m < 258) or (n < 10); + + { not enough input or output--restore pointers and return } + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_OK; +end; + +end. \ No newline at end of file diff --git a/delphionly/inftrees.pas b/delphionly/inftrees.pas new file mode 100755 index 0000000..817005a --- /dev/null +++ b/delphionly/inftrees.pas @@ -0,0 +1,782 @@ +Unit InfTrees; + +{ inftrees.h -- header to use inftrees.c + inftrees.c -- generate Huffman trees for efficient decoding + Copyright (C) 1995-1998 Mark Adler + + WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +Interface + +{$I zconf.inc} + +uses + zutil, zlib; + + +{ Maximum size of dynamic tree. The maximum found in a long but non- + exhaustive search was 1004 huft structures (850 for length/literals + and 154 for distances, the latter actually the result of an + exhaustive search). The actual maximum is not known, but the + value below is more than safe. } +const + MANY = 1440; + + +{$ifdef DEBUG} +var + inflate_hufts : uInt; +{$endif} + +function inflate_trees_bits( + var c : array of uIntf; { 19 code lengths } + var bb : uIntf; { bits tree desired/actual depth } + var tb : pinflate_huft; { bits tree result } + var hp : array of Inflate_huft; { space for trees } + var z : z_stream { for messages } + ) : int; + +function inflate_trees_dynamic( + nl : uInt; { number of literal/length codes } + nd : uInt; { number of distance codes } + var c : Array of uIntf; { that many (total) code lengths } + var bl : uIntf; { literal desired/actual bit depth } + var bd : uIntf; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var hp : array of Inflate_huft; { space for trees } +var z : z_stream { for messages } + ) : int; + +function inflate_trees_fixed ( + var bl : uInt; { literal desired/actual bit depth } + var bd : uInt; { distance desired/actual bit depth } + var tl : pInflate_huft; { literal/length tree result } + var td : pInflate_huft; { distance tree result } + var z : z_stream { for memory allocation } + ) : int; + + +implementation + +const + inflate_copyright = 'inflate 1.1.2 Copyright 1995-1998 Mark Adler'; + +{ + If you use the zlib library in a product, an acknowledgment is welcome + in the documentation of your product. If for some reason you cannot + include such an acknowledgment, I would appreciate that you keep this + copyright string in the executable of your product. +} + + +const +{ Tables for deflate from PKZIP's appnote.txt. } + cplens : Array [0..30] Of uInt { Copy lengths for literal codes 257..285 } + = (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, + 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0); + { actually lengths - 2; also see note #13 above about 258 } + + invalid_code = 112; + + cplext : Array [0..30] Of uInt { Extra bits for literal codes 257..285 } + = (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, + 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid_code, invalid_code); + + cpdist : Array [0..29] Of uInt { Copy offsets for distance codes 0..29 } + = (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, + 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, + 8193, 12289, 16385, 24577); + + cpdext : Array [0..29] Of uInt { Extra bits for distance codes } + = (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, + 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, + 12, 12, 13, 13); + +{ Huffman code decoding is performed using a multi-level table lookup. + The fastest way to decode is to simply build a lookup table whose + size is determined by the longest code. However, the time it takes + to build this table can also be a factor if the data being decoded + is not very long. The most common codes are necessarily the + shortest codes, so those codes dominate the decoding time, and hence + the speed. The idea is you can have a shorter table that decodes the + shorter, more probable codes, and then point to subsidiary tables for + the longer codes. The time it costs to decode the longer codes is + then traded against the time it takes to make longer tables. + + This results of this trade are in the variables lbits and dbits + below. lbits is the number of bits the first level table for literal/ + length codes can decode in one step, and dbits is the same thing for + the distance codes. Subsequent tables are also less than or equal to + those sizes. These values may be adjusted either when all of the + codes are shorter than that, in which case the longest code length in + bits is used, or when the shortest code is *longer* than the requested + table size, in which case the length of the shortest code in bits is + used. + + There are two different values for the two tables, since they code a + different number of possibilities each. The literal/length table + codes 286 possible values, or in a flat code, a little over eight + bits. The distance table codes 30 possible values, or a little less + than five bits, flat. The optimum values for speed end up being + about one bit more than those, so lbits is 8+1 and dbits is 5+1. + The optimum values may differ though from machine to machine, and + possibly even between compilers. Your mileage may vary. } + + +{ If BMAX needs to be larger than 16, then h and x[] should be uLong. } +const + BMAX = 15; { maximum bit length of any code } + +{$DEFINE USE_PTR} + +function huft_build( +var b : array of uIntf; { code lengths in bits (all assumed <= BMAX) } + n : uInt; { number of codes (assumed <= N_MAX) } + s : uInt; { number of simple-valued codes (0..s-1) } +const d : array of uIntf; { list of base values for non-simple codes } +{ array of word } +const e : array of uIntf; { list of extra bits for non-simple codes } +{ array of byte } + t : ppInflate_huft; { result: starting table } +var m : uIntf; { maximum lookup bits, returns actual } +var hp : array of inflate_huft; { space for trees } +var hn : uInt; { hufts used in space } +var v : array of uIntf { working area: values in order of bit length } + ) : int; +{ Given a list of code lengths and a maximum table size, make a set of + tables to decode that set of codes. Return Z_OK on success, Z_BUF_ERROR + if the given code set is incomplete (the tables are still built in this + case), Z_DATA_ERROR if the input is invalid (an over-subscribed set of + lengths), or Z_MEM_ERROR if not enough memory. } +Var + a : uInt; { counter for codes of length k } + c : Array [0..BMAX] Of uInt; { bit length count table } + f : uInt; { i repeats in table every f entries } + g : int; { maximum code length } + h : int; { table level } + i : uInt; {register} { counter, current code } + j : uInt; {register} { counter } + k : Int; {register} { number of bits in current code } + l : int; { bits per table (returned in m) } + mask : uInt; { (1 shl w) - 1, to avoid cc -O bug on HP } + p : ^uIntf; {register} { pointer into c[], b[], or v[] } + q : pInflate_huft; { points to current table } + r : inflate_huft; { table entry for structure assignment } + u : Array [0..BMAX-1] Of pInflate_huft; { table stack } + w : int; {register} { bits before this table = (l*h) } + x : Array [0..BMAX] Of uInt; { bit offsets, then code stack } + {$IFDEF USE_PTR} + xp : puIntf; { pointer into x } + {$ELSE} + xp : uInt; + {$ENDIF} + y : int; { number of dummy codes added } + z : uInt; { number of entries in current table } +Begin + { Generate counts for each bit length } + FillChar(c,SizeOf(c),0) ; { clear c[] } + + for i := 0 to n-1 do + Inc (c[b[i]]); { assume all entries <= BMAX } + + If (c[0] = n) Then { null input--all zero length codes } + Begin + t^ := pInflate_huft(NIL); + m := 0 ; + huft_build := Z_OK ; + Exit; + End ; + + { Find minimum and maximum length, bound [m] by those } + l := m; + for j:=1 To BMAX do + if (c[j] <> 0) then + break; + k := j ; { minimum code length } + if (uInt(l) < j) then + l := j; + for i := BMAX downto 1 do + if (c[i] <> 0) then + break ; + g := i ; { maximum code length } + if (uInt(l) > i) then + l := i; + m := l; + + { Adjust last length count to fill out codes, if needed } + y := 1 shl j ; + while (j < i) do + begin + Dec(y, c[j]) ; + if (y < 0) then + begin + huft_build := Z_DATA_ERROR; { bad input: more codes than bits } + exit; + end ; + Inc(j) ; + y := y shl 1 + end; + Dec (y, c[i]) ; + if (y < 0) then + begin + huft_build := Z_DATA_ERROR; { bad input: more codes than bits } + exit; + end; + Inc(c[i], y); + + { Generate starting offsets into the value table FOR each length } + {$IFDEF USE_PTR} + x[1] := 0; + j := 0; + + p := @c[1]; + xp := @x[2]; + + dec(i); { note that i = g from above } + WHILE (i > 0) DO + BEGIN + inc(j, p^); + xp^ := j; + inc(p); + inc(xp); + dec(i); + END; + {$ELSE} + x[1] := 0; + j := 0 ; + for i := 1 to g do + begin + x[i] := j; + Inc(j, c[i]); + end; + {$ENDIF} + + { Make a table of values in order of bit lengths } + for i := 0 to n-1 do + begin + j := b[i]; + if (j <> 0) then + begin + v[ x[j] ] := i; + Inc(x[j]); + end; + end; + n := x[g]; { set n to length of v } + + { Generate the Huffman codes and for each, make the table entries } + i := 0 ; + x[0] := 0 ; { first Huffman code is zero } + p := Addr(v) ; { grab values in bit order } + h := -1 ; { no tables yet--level -1 } + w := -l ; { bits decoded = (l*h) } + + u[0] := pInflate_huft(NIL); { just to keep compilers happy } + q := pInflate_huft(NIL); { ditto } + z := 0 ; { ditto } + + { go through the bit lengths (k already is bits in shortest code) } + while (k <= g) Do + begin + a := c[k] ; + while (a<>0) Do + begin + Dec (a) ; + { here i is the Huffman code of length k bits for value p^ } + { make tables up to required level } + while (k > w + l) do + begin + + Inc (h) ; + Inc (w, l); { add bits already decoded } + { previous table always l bits } + { compute minimum size table less than or equal to l bits } + + { table size upper limit } + z := g - w; + If (z > uInt(l)) Then + z := l; + + { try a k-w bit table } + j := k - w; + f := 1 shl j; + if (f > a+1) Then { too few codes for k-w bit table } + begin + Dec(f, a+1); { deduct codes from patterns left } + {$IFDEF USE_PTR} + xp := Addr(c[k]); + + if (j < z) then + begin + Inc(j); + while (j < z) do + begin { try smaller tables up to z bits } + f := f shl 1; + Inc (xp) ; + If (f <= xp^) Then + break; { enough codes to use up j bits } + Dec(f, xp^); { else deduct codes from patterns } + Inc(j); + end; + end; + {$ELSE} + xp := k; + + if (j < z) then + begin + Inc (j) ; + While (j < z) Do + begin { try smaller tables up to z bits } + f := f * 2; + Inc (xp) ; + if (f <= c[xp]) then + Break ; { enough codes to use up j bits } + Dec (f, c[xp]) ; { else deduct codes from patterns } + Inc (j); + end; + end; + {$ENDIF} + end; + + z := 1 shl j; { table entries for j-bit table } + + { allocate new table } + if (hn + z > MANY) then { (note: doesn't matter for fixed) } + begin + huft_build := Z_MEM_ERROR; { not enough memory } + exit; + end; + + q := @hp[hn]; + u[h] := q; + Inc(hn, z); + + { connect to last table, if there is one } + if (h <> 0) then + begin + x[h] := i; { save pattern for backing up } + r.bits := Byte(l); { bits to dump before this table } + r.exop := Byte(j); { bits in this table } + j := i shr (w - l); + {r.base := uInt( q - u[h-1] -j);} { offset to this table } + r.base := (ptr2int(q) - ptr2int(u[h-1]) ) div sizeof(q^) - j; + huft_Ptr(u[h-1])^[j] := r; { connect to last table } + end + else + t^ := q; { first table is returned result } + end; + + { set up table entry in r } + r.bits := Byte(k - w); + + { C-code: if (p >= v + n) - see ZUTIL.PAS for comments } + + if ptr2int(p)>=ptr2int(@(v[n])) then { also works under DPMI ?? } + r.exop := 128 + 64 { out of values--invalid code } + else + if (p^ < s) then + begin + if (p^ < 256) then { 256 is end-of-block code } + r.exop := 0 + Else + r.exop := 32 + 64; { EOB_code; } + r.base := p^; { simple code is just the value } + Inc(p); + end + Else + begin + r.exop := Byte(e[p^-s] + 16 + 64); { non-simple--look up in lists } + r.base := d[p^-s]; + Inc (p); + end ; + + { fill code-like entries with r } + f := 1 shl (k - w); + j := i shr w; + while (j < z) do + begin + huft_Ptr(q)^[j] := r; + Inc(j, f); + end; + + { backwards increment the k-bit code i } + j := 1 shl (k-1) ; + while (i and j) <> 0 do + begin + i := i xor j; { bitwise exclusive or } + j := j shr 1 + end ; + i := i xor j; + + { backup over finished tables } + mask := (1 shl w) - 1; { needed on HP, cc -O bug } + while ((i and mask) <> x[h]) do + begin + Dec(h); { don't need to update q } + Dec(w, l); + mask := (1 shl w) - 1; + end; + + end; + + Inc(k); + end; + + { Return Z_BUF_ERROR if we were given an incomplete table } + if (y <> 0) And (g <> 1) then + huft_build := Z_BUF_ERROR + else + huft_build := Z_OK; +end; { huft_build} + + +function inflate_trees_bits( + var c : array of uIntf; { 19 code lengths } + var bb : uIntf; { bits tree desired/actual depth } + var tb : pinflate_huft; { bits tree result } + var hp : array of Inflate_huft; { space for trees } + var z : z_stream { for messages } + ) : int; +var + r : int; + hn : uInt; { hufts used in space } + v : PuIntArray; { work area for huft_build } +begin + hn := 0; + v := PuIntArray( ZALLOC(z, 19, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + inflate_trees_bits := Z_MEM_ERROR; + exit; + end; + + r := huft_build(c, 19, 19, cplens, cplext, + {puIntf(Z_NULL), puIntf(Z_NULL),} + @tb, bb, hp, hn, v^); + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed dynamic bit lengths tree' + else + if (r = Z_BUF_ERROR) or (bb = 0) then + begin + z.msg := 'incomplete dynamic bit lengths tree'; + r := Z_DATA_ERROR; + end; + ZFREE(z, v); + inflate_trees_bits := r; +end; + + +function inflate_trees_dynamic( + nl : uInt; { number of literal/length codes } + nd : uInt; { number of distance codes } + var c : Array of uIntf; { that many (total) code lengths } + var bl : uIntf; { literal desired/actual bit depth } + var bd : uIntf; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var hp : array of Inflate_huft; { space for trees } +var z : z_stream { for messages } + ) : int; +var + r : int; + hn : uInt; { hufts used in space } + v : PuIntArray; { work area for huft_build } +begin + hn := 0; + { allocate work area } + v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + inflate_trees_dynamic := Z_MEM_ERROR; + exit; + end; + + { build literal/length tree } + r := huft_build(c, nl, 257, cplens, cplext, @tl, bl, hp, hn, v^); + if (r <> Z_OK) or (bl = 0) then + begin + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed literal/length tree' + else + if (r <> Z_MEM_ERROR) then + begin + z.msg := 'incomplete literal/length tree'; + r := Z_DATA_ERROR; + end; + + ZFREE(z, v); + inflate_trees_dynamic := r; + exit; + end; + + { build distance tree } + r := huft_build(puIntArray(@c[nl])^, nd, 0, + cpdist, cpdext, @td, bd, hp, hn, v^); + if (r <> Z_OK) or ((bd = 0) and (nl > 257)) then + begin + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed literal/length tree' + else + if (r = Z_BUF_ERROR) then + begin +{$ifdef PKZIP_BUG_WORKAROUND} + r := Z_OK; + end; +{$else} + z.msg := 'incomplete literal/length tree'; + r := Z_DATA_ERROR; + end + else + if (r <> Z_MEM_ERROR) then + begin + z.msg := 'empty distance tree with lengths'; + r := Z_DATA_ERROR; + end; + ZFREE(z, v); + inflate_trees_dynamic := r; + exit; +{$endif} + end; + + { done } + ZFREE(z, v); + inflate_trees_dynamic := Z_OK; +end; + +{$UNDEF BUILDFIXED} + +{ build fixed tables only once--keep them here } +{$IFNDEF BUILDFIXED} +{ locals } +const + FIXEDH = 544; { number of hufts used by fixed tables } + +var + fixed_built : Boolean = false; +var + fixed_mem : array[0..FIXEDH-1] of inflate_huft; + fixed_bl : uInt; + fixed_bd : uInt; + fixed_tl : pInflate_huft; + fixed_td : pInflate_huft; + +{$ELSE} + +{ inffixed.h -- table for decoding fixed codes } + +{local} +const + fixed_bl = uInt(9); +{local} +const + fixed_bd = uInt(5); +{local} +const + fixed_tl : array [0..288-1] of inflate_huft = ( + Exop, { number of extra bits or operation } + bits : Byte; { number of bits in this code or subcode } + {pad : uInt;} { pad structure to a power of 2 (4 bytes for } + { 16-bit, 8 bytes for 32-bit int's) } + base : uInt; { literal, length base, or distance base } + { or table offset } + + ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), ((82,7),31), + ((0,8),112), ((0,8),48), ((0,9),192), ((80,7),10), ((0,8),96), + ((0,8),32), ((0,9),160), ((0,8),0), ((0,8),128), ((0,8),64), + ((0,9),224), ((80,7),6), ((0,8),88), ((0,8),24), ((0,9),144), + ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),208), ((81,7),17), + ((0,8),104), ((0,8),40), ((0,9),176), ((0,8),8), ((0,8),136), + ((0,8),72), ((0,9),240), ((80,7),4), ((0,8),84), ((0,8),20), + ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), ((0,9),200), + ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),168), ((0,8),4), + ((0,8),132), ((0,8),68), ((0,9),232), ((80,7),8), ((0,8),92), + ((0,8),28), ((0,9),152), ((84,7),83), ((0,8),124), ((0,8),60), + ((0,9),216), ((82,7),23), ((0,8),108), ((0,8),44), ((0,9),184), + ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),248), ((80,7),3), + ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), ((0,8),114), + ((0,8),50), ((0,9),196), ((81,7),11), ((0,8),98), ((0,8),34), + ((0,9),164), ((0,8),2), ((0,8),130), ((0,8),66), ((0,9),228), + ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),148), ((84,7),67), + ((0,8),122), ((0,8),58), ((0,9),212), ((82,7),19), ((0,8),106), + ((0,8),42), ((0,9),180), ((0,8),10), ((0,8),138), ((0,8),74), + ((0,9),244), ((80,7),5), ((0,8),86), ((0,8),22), ((192,8),0), + ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),204), ((81,7),15), + ((0,8),102), ((0,8),38), ((0,9),172), ((0,8),6), ((0,8),134), + ((0,8),70), ((0,9),236), ((80,7),9), ((0,8),94), ((0,8),30), + ((0,9),156), ((84,7),99), ((0,8),126), ((0,8),62), ((0,9),220), + ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),188), ((0,8),14), + ((0,8),142), ((0,8),78), ((0,9),252), ((96,7),256), ((0,8),81), + ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), ((0,8),49), + ((0,9),194), ((80,7),10), ((0,8),97), ((0,8),33), ((0,9),162), + ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),226), ((80,7),6), + ((0,8),89), ((0,8),25), ((0,9),146), ((83,7),59), ((0,8),121), + ((0,8),57), ((0,9),210), ((81,7),17), ((0,8),105), ((0,8),41), + ((0,9),178), ((0,8),9), ((0,8),137), ((0,8),73), ((0,9),242), + ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), ((83,7),43), + ((0,8),117), ((0,8),53), ((0,9),202), ((81,7),13), ((0,8),101), + ((0,8),37), ((0,9),170), ((0,8),5), ((0,8),133), ((0,8),69), + ((0,9),234), ((80,7),8), ((0,8),93), ((0,8),29), ((0,9),154), + ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),218), ((82,7),23), + ((0,8),109), ((0,8),45), ((0,9),186), ((0,8),13), ((0,8),141), + ((0,8),77), ((0,9),250), ((80,7),3), ((0,8),83), ((0,8),19), + ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), ((0,9),198), + ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),166), ((0,8),3), + ((0,8),131), ((0,8),67), ((0,9),230), ((80,7),7), ((0,8),91), + ((0,8),27), ((0,9),150), ((84,7),67), ((0,8),123), ((0,8),59), + ((0,9),214), ((82,7),19), ((0,8),107), ((0,8),43), ((0,9),182), + ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),246), ((80,7),5), + ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), ((0,8),119), + ((0,8),55), ((0,9),206), ((81,7),15), ((0,8),103), ((0,8),39), + ((0,9),174), ((0,8),7), ((0,8),135), ((0,8),71), ((0,9),238), + ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),158), ((84,7),99), + ((0,8),127), ((0,8),63), ((0,9),222), ((82,7),27), ((0,8),111), + ((0,8),47), ((0,9),190), ((0,8),15), ((0,8),143), ((0,8),79), + ((0,9),254), ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), + ((82,7),31), ((0,8),112), ((0,8),48), ((0,9),193), ((80,7),10), + ((0,8),96), ((0,8),32), ((0,9),161), ((0,8),0), ((0,8),128), + ((0,8),64), ((0,9),225), ((80,7),6), ((0,8),88), ((0,8),24), + ((0,9),145), ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),209), + ((81,7),17), ((0,8),104), ((0,8),40), ((0,9),177), ((0,8),8), + ((0,8),136), ((0,8),72), ((0,9),241), ((80,7),4), ((0,8),84), + ((0,8),20), ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), + ((0,9),201), ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),169), + ((0,8),4), ((0,8),132), ((0,8),68), ((0,9),233), ((80,7),8), + ((0,8),92), ((0,8),28), ((0,9),153), ((84,7),83), ((0,8),124), + ((0,8),60), ((0,9),217), ((82,7),23), ((0,8),108), ((0,8),44), + ((0,9),185), ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),249), + ((80,7),3), ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), + ((0,8),114), ((0,8),50), ((0,9),197), ((81,7),11), ((0,8),98), + ((0,8),34), ((0,9),165), ((0,8),2), ((0,8),130), ((0,8),66), + ((0,9),229), ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),149), + ((84,7),67), ((0,8),122), ((0,8),58), ((0,9),213), ((82,7),19), + ((0,8),106), ((0,8),42), ((0,9),181), ((0,8),10), ((0,8),138), + ((0,8),74), ((0,9),245), ((80,7),5), ((0,8),86), ((0,8),22), + ((192,8),0), ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),205), + ((81,7),15), ((0,8),102), ((0,8),38), ((0,9),173), ((0,8),6), + ((0,8),134), ((0,8),70), ((0,9),237), ((80,7),9), ((0,8),94), + ((0,8),30), ((0,9),157), ((84,7),99), ((0,8),126), ((0,8),62), + ((0,9),221), ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),189), + ((0,8),14), ((0,8),142), ((0,8),78), ((0,9),253), ((96,7),256), + ((0,8),81), ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), + ((0,8),49), ((0,9),195), ((80,7),10), ((0,8),97), ((0,8),33), + ((0,9),163), ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),227), + ((80,7),6), ((0,8),89), ((0,8),25), ((0,9),147), ((83,7),59), + ((0,8),121), ((0,8),57), ((0,9),211), ((81,7),17), ((0,8),105), + ((0,8),41), ((0,9),179), ((0,8),9), ((0,8),137), ((0,8),73), + ((0,9),243), ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), + ((83,7),43), ((0,8),117), ((0,8),53), ((0,9),203), ((81,7),13), + ((0,8),101), ((0,8),37), ((0,9),171), ((0,8),5), ((0,8),133), + ((0,8),69), ((0,9),235), ((80,7),8), ((0,8),93), ((0,8),29), + ((0,9),155), ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),219), + ((82,7),23), ((0,8),109), ((0,8),45), ((0,9),187), ((0,8),13), + ((0,8),141), ((0,8),77), ((0,9),251), ((80,7),3), ((0,8),83), + ((0,8),19), ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), + ((0,9),199), ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),167), + ((0,8),3), ((0,8),131), ((0,8),67), ((0,9),231), ((80,7),7), + ((0,8),91), ((0,8),27), ((0,9),151), ((84,7),67), ((0,8),123), + ((0,8),59), ((0,9),215), ((82,7),19), ((0,8),107), ((0,8),43), + ((0,9),183), ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),247), + ((80,7),5), ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), + ((0,8),119), ((0,8),55), ((0,9),207), ((81,7),15), ((0,8),103), + ((0,8),39), ((0,9),175), ((0,8),7), ((0,8),135), ((0,8),71), + ((0,9),239), ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),159), + ((84,7),99), ((0,8),127), ((0,8),63), ((0,9),223), ((82,7),27), + ((0,8),111), ((0,8),47), ((0,9),191), ((0,8),15), ((0,8),143), + ((0,8),79), ((0,9),255) + ); + +{local} +const + fixed_td : array[0..32-1] of inflate_huft = ( +(Exop:80;bits:5;base:1), (Exop:87;bits:5;base:257), (Exop:83;bits:5;base:17), +(Exop:91;bits:5;base:4097), (Exop:81;bits:5;base), (Exop:89;bits:5;base:1025), +(Exop:85;bits:5;base:65), (Exop:93;bits:5;base:16385), (Exop:80;bits:5;base:3), +(Exop:88;bits:5;base:513), (Exop:84;bits:5;base:33), (Exop:92;bits:5;base:8193), +(Exop:82;bits:5;base:9), (Exop:90;bits:5;base:2049), (Exop:86;bits:5;base:129), +(Exop:192;bits:5;base:24577), (Exop:80;bits:5;base:2), (Exop:87;bits:5;base:385), +(Exop:83;bits:5;base:25), (Exop:91;bits:5;base:6145), (Exop:81;bits:5;base:7), +(Exop:89;bits:5;base:1537), (Exop:85;bits:5;base:97), (Exop:93;bits:5;base:24577), +(Exop:80;bits:5;base:4), (Exop:88;bits:5;base:769), (Exop:84;bits:5;base:49), +(Exop:92;bits:5;base:12289), (Exop:82;bits:5;base:13), (Exop:90;bits:5;base:3073), +(Exop:86;bits:5;base:193), (Exop:192;bits:5;base:24577) + ); +{$ENDIF} + +function inflate_trees_fixed( +var bl : uInt; { literal desired/actual bit depth } +var bd : uInt; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var z : z_stream { for memory allocation } + ) : int; +type + pFixed_table = ^fixed_table; + fixed_table = array[0..288-1] of uIntf; +var + k : int; { temporary variable } + c : pFixed_table; { length list for huft_build } + v : PuIntArray; { work area for huft_build } +var + f : uInt; { number of hufts used in fixed_mem } +begin + { build fixed tables if not already (multiple overlapped executions ok) } + if not fixed_built then + begin + f := 0; + + { allocate memory } + c := pFixed_table( ZALLOC(z, 288, sizeof(uInt)) ); + if (c = Z_NULL) then + begin + inflate_trees_fixed := Z_MEM_ERROR; + exit; + end; + v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + ZFREE(z, c); + inflate_trees_fixed := Z_MEM_ERROR; + exit; + end; + + { literal table } + for k := 0 to Pred(144) do + c^[k] := 8; + for k := 144 to Pred(256) do + c^[k] := 9; + for k := 256 to Pred(280) do + c^[k] := 7; + for k := 280 to Pred(288) do + c^[k] := 8; + fixed_bl := 9; + huft_build(c^, 288, 257, cplens, cplext, @fixed_tl, fixed_bl, + fixed_mem, f, v^); + + { distance table } + for k := 0 to Pred(30) do + c^[k] := 5; + fixed_bd := 5; + huft_build(c^, 30, 0, cpdist, cpdext, @fixed_td, fixed_bd, + fixed_mem, f, v^); + + { done } + ZFREE(z, v); + ZFREE(z, c); + fixed_built := True; + end; + bl := fixed_bl; + bd := fixed_bd; + tl := fixed_tl; + td := fixed_td; + inflate_trees_fixed := Z_OK; +end; { inflate_trees_fixed } + + +end. \ No newline at end of file diff --git a/delphionly/infutil.pas b/delphionly/infutil.pas new file mode 100755 index 0000000..e5c0858 --- /dev/null +++ b/delphionly/infutil.pas @@ -0,0 +1,222 @@ +Unit infutil; + +{ types and macros common to blocks and codes + Copyright (C) 1995-1998 Mark Adler + + WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil, zlib; + +{ copy as much as possible from the sliding window to the output area } +function inflate_flush(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; + +{ And'ing with mask[n] masks the lower n bits } +const + inflate_mask : array[0..17-1] of uInt = ( + $0000, + $0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff, + $01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff); + +{procedure GRABBITS(j : int);} +{procedure DUMPBITS(j : int);} +{procedure NEEDBITS(j : int);} + +implementation + +{ macros for bit input with no checking and for returning unused bytes } +//procedure GRABBITS(j : int); +//begin + {while (k < j) do + begin + Dec(z^.avail_in); + Inc(z^.total_in); + b := b or (uLong(z^.next_in^) shl k); + Inc(z^.next_in); + Inc(k, 8); + end;} +//end; + +//procedure DUMPBITS(j : int); +//begin + {b := b shr j; + Dec(k, j);} +//end; + +//procedure NEEDBITS(j : int); +//begin + (* + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); + z.next_in := p; + s.write := q; + result := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + *) +//end; + +//procedure NEEDOUT; +//begin + (* + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); + z.next_in := p; + s.write := q; + result := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + *) +//end; + +{ copy as much as possible from the sliding window to the output area } +function inflate_flush(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; +var + n : uInt; + p : pBytef; + q : pBytef; +begin + { local copies of source and destination pointers } + p := z.next_out; + q := s.read; + + { compute number of bytes to copy as far as end of window } + if ptr2int(q) <= ptr2int(s.write) then + n := uInt(ptr2int(s.write) - ptr2int(q)) + else + n := uInt(ptr2int(s.zend) - ptr2int(q)); + if (n > z.avail_out) then + n := z.avail_out; + if (n <> 0) and (r = Z_BUF_ERROR) then + r := Z_OK; + + { update counters } + Dec(z.avail_out, n); + Inc(z.total_out, n); + + + { update check information } + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(s.check, q, n); + z.adler := s.check; + end; + + { copy as far as end of window } + zmemcpy(p, q, n); + Inc(p, n); + Inc(q, n); + + { see if more to copy at beginning of window } + if (q = s.zend) then + begin + { wrap pointers } + q := s.window; + if (s.write = s.zend) then + s.write := s.window; + + { compute bytes to copy } + n := uInt(ptr2int(s.write) - ptr2int(q)); + if (n > z.avail_out) then + n := z.avail_out; + if (n <> 0) and (r = Z_BUF_ERROR) then + r := Z_OK; + + { update counters } + Dec( z.avail_out, n); + Inc( z.total_out, n); + + { update check information } + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(s.check, q, n); + z.adler := s.check; + end; + + { copy } + zmemcpy(p, q, n); + Inc(p, n); + Inc(q, n); + end; + + + { update pointers } + z.next_out := p; + s.read := q; + + { done } + inflate_flush := r; +end; + +end. diff --git a/delphionly/trees.pas b/delphionly/trees.pas new file mode 100755 index 0000000..0d1cc42 --- /dev/null +++ b/delphionly/trees.pas @@ -0,0 +1,2249 @@ +Unit trees; + +{$T-} +{$define ORG_DEBUG} +{ + trees.c -- output deflated data using Huffman coding + Copyright (C) 1995-1998 Jean-loup Gailly + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +{ + * ALGORITHM + * + * The "deflation" process uses several Huffman trees. The more + * common source values are represented by shorter bit sequences. + * + * Each code tree is stored in a compressed form which is itself + * a Huffman encoding of the lengths of all the code strings (in + * ascending order by source values). The actual code strings are + * reconstructed from the lengths in the inflate process, as described + * in the deflate specification. + * + * REFERENCES + * + * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". + * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc + * + * Storer, James A. + * Data Compression: Methods and Theory, pp. 49-50. + * Computer Science Press, 1988. ISBN 0-7167-8156-5. + * + * Sedgewick, R. + * Algorithms, p290. + * Addison-Wesley, 1983. ISBN 0-201-06672-6. + } + +interface + +{$I zconf.inc} + +uses + {$ifdef DEBUG} + strutils, + {$ENDIF} + zutil, zlib; + +{ =========================================================================== + Internal compression state. } + +const + LENGTH_CODES = 29; +{ number of length codes, not counting the special END_BLOCK code } + + LITERALS = 256; +{ number of literal bytes 0..255 } + + L_CODES = (LITERALS+1+LENGTH_CODES); +{ number of Literal or Length codes, including the END_BLOCK code } + + D_CODES = 30; +{ number of distance codes } + + BL_CODES = 19; +{ number of codes used to transfer the bit lengths } + + HEAP_SIZE = (2*L_CODES+1); +{ maximum heap size } + + MAX_BITS = 15; +{ All codes must not exceed MAX_BITS bits } + +const + INIT_STATE = 42; + BUSY_STATE = 113; + FINISH_STATE = 666; +{ Stream status } + + +{ Data structure describing a single value and its code string. } +type + ct_data_ptr = ^ct_data; + ct_data = record + fc : record + case byte of + 0:(freq : ush); { frequency count } + 1:(code : ush); { bit string } + end; + dl : record + case byte of + 0:(dad : ush); { father node in Huffman tree } + 1:(len : ush); { length of bit string } + end; + end; + +{ Freq = fc.freq + Code = fc.code + Dad = dl.dad + Len = dl.len } + +type + ltree_type = array[0..HEAP_SIZE-1] of ct_data; { literal and length tree } + dtree_type = array[0..2*D_CODES+1-1] of ct_data; { distance tree } + htree_type = array[0..2*BL_CODES+1-1] of ct_data; { Huffman tree for bit lengths } + { generic tree type } + tree_type = array[0..(MaxMemBlock div SizeOf(ct_data))-1] of ct_data; + + tree_ptr = ^tree_type; + ltree_ptr = ^ltree_type; + dtree_ptr = ^dtree_type; + htree_ptr = ^htree_type; + + +type + static_tree_desc_ptr = ^static_tree_desc; + static_tree_desc = + record + {const} static_tree : tree_ptr; { static tree or NIL } + {const} extra_bits : pzIntfArray; { extra bits for each code or NIL } + extra_base : int; { base index for extra_bits } + elems : int; { max number of elements in the tree } + max_length : int; { max bit length for the codes } + end; + + tree_desc_ptr = ^tree_desc; + tree_desc = record + dyn_tree : tree_ptr; { the dynamic tree } + max_code : int; { largest code with non zero frequency } + stat_desc : static_tree_desc_ptr; { the corresponding static tree } + end; + +type + Pos = ush; + Posf = Pos; {FAR} + IPos = uInt; + + pPosf = ^Posf; + + zPosfArray = array[0..(MaxMemBlock div SizeOf(Posf))-1] of Posf; + pzPosfArray = ^zPosfArray; + +{ A Pos is an index in the character window. We use short instead of int to + save space in the various tables. IPos is used only for parameter passing.} + +type + deflate_state_ptr = ^deflate_state; + deflate_state = record + strm : z_streamp; { pointer back to this zlib stream } + status : int; { as the name implies } + pending_buf : pzByteArray; { output still pending } + pending_buf_size : ulg; { size of pending_buf } + pending_out : pBytef; { next pending byte to output to the stream } + pending : int; { nb of bytes in the pending buffer } + noheader : int; { suppress zlib header and adler32 } + data_type : Byte; { UNKNOWN, BINARY or ASCII } + method : Byte; { STORED (for zip only) or DEFLATED } + last_flush : int; { value of flush param for previous deflate call } + + { used by deflate.pas: } + + w_size : uInt; { LZ77 window size (32K by default) } + w_bits : uInt; { log2(w_size) (8..16) } + w_mask : uInt; { w_size - 1 } + + window : pzByteArray; + { Sliding window. Input bytes are read into the second half of the window, + and move to the first half later to keep a dictionary of at least wSize + bytes. With this organization, matches are limited to a distance of + wSize-MAX_MATCH bytes, but this ensures that IO is always + performed with a length multiple of the block size. Also, it limits + the window size to 64K, which is quite useful on MSDOS. + To do: use the user input buffer as sliding window. } + + window_size : ulg; + { Actual size of window: 2*wSize, except when the user input buffer + is directly used as sliding window. } + + prev : pzPosfArray; + { Link to older string with same hash index. To limit the size of this + array to 64K, this link is maintained only for the last 32K strings. + An index in this array is thus a window index modulo 32K. } + + head : pzPosfArray; { Heads of the hash chains or NIL. } + + ins_h : uInt; { hash index of string to be inserted } + hash_size : uInt; { number of elements in hash table } + hash_bits : uInt; { log2(hash_size) } + hash_mask : uInt; { hash_size-1 } + + hash_shift : uInt; + { Number of bits by which ins_h must be shifted at each input + step. It must be such that after MIN_MATCH steps, the oldest + byte no longer takes part in the hash key, that is: + hash_shift * MIN_MATCH >= hash_bits } + + block_start : long; + { Window position at the beginning of the current output block. Gets + negative when the window is moved backwards. } + + match_length : uInt; { length of best match } + prev_match : IPos; { previous match } + match_available : boolean; { set if previous match exists } + strstart : uInt; { start of string to insert } + match_start : uInt; { start of matching string } + lookahead : uInt; { number of valid bytes ahead in window } + + prev_length : uInt; + { Length of the best match at previous step. Matches not greater than this + are discarded. This is used in the lazy match evaluation. } + + max_chain_length : uInt; + { To speed up deflation, hash chains are never searched beyond this + length. A higher limit improves compression ratio but degrades the + speed. } + + { moved to the end because Borland Pascal won't accept the following: + max_lazy_match : uInt; + max_insert_length : uInt absolute max_lazy_match; + } + + level : int; { compression level (1..9) } + strategy : int; { favor or force Huffman coding} + + good_match : uInt; + { Use a faster search when the previous match is longer than this } + + nice_match : int; { Stop searching when current match exceeds this } + + { used by trees.pas: } + { Didn't use ct_data typedef below to supress compiler warning } + dyn_ltree : ltree_type; { literal and length tree } + dyn_dtree : dtree_type; { distance tree } + bl_tree : htree_type; { Huffman tree for bit lengths } + + l_desc : tree_desc; { desc. for literal tree } + d_desc : tree_desc; { desc. for distance tree } + bl_desc : tree_desc; { desc. for bit length tree } + + bl_count : array[0..MAX_BITS+1-1] of ush; + { number of codes at each bit length for an optimal tree } + + heap : array[0..2*L_CODES+1-1] of int; { heap used to build the Huffman trees } + heap_len : int; { number of elements in the heap } + heap_max : int; { element of largest frequency } + { The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used. + The same heap array is used to build all trees. } + + depth : array[0..2*L_CODES+1-1] of uch; + { Depth of each subtree used as tie breaker for trees of equal frequency } + + + l_buf : puchfArray; { buffer for literals or lengths } + + lit_bufsize : uInt; + { Size of match buffer for literals/lengths. There are 4 reasons for + limiting lit_bufsize to 64K: + - frequencies can be kept in 16 bit counters + - if compression is not successful for the first block, all input + data is still in the window so we can still emit a stored block even + when input comes from standard input. (This can also be done for + all blocks if lit_bufsize is not greater than 32K.) + - if compression is not successful for a file smaller than 64K, we can + even emit a stored file instead of a stored block (saving 5 bytes). + This is applicable only for zip (not gzip or zlib). + - creating new Huffman trees less frequently may not provide fast + adaptation to changes in the input data statistics. (Take for + example a binary file with poorly compressible code followed by + a highly compressible string table.) Smaller buffer sizes give + fast adaptation but have of course the overhead of transmitting + trees more frequently. + - I can't count above 4 } + + + last_lit : uInt; { running index in l_buf } + + d_buf : pushfArray; + { Buffer for distances. To simplify the code, d_buf and l_buf have + the same number of elements. To use different lengths, an extra flag + array would be necessary. } + + opt_len : ulg; { bit length of current block with optimal trees } + static_len : ulg; { bit length of current block with static trees } + compressed_len : ulg; { total bit length of compressed file } + matches : uInt; { number of string matches in current block } + last_eob_len : int; { bit length of EOB code for last block } + +{$ifdef DEBUG} + bits_sent : ulg; { bit length of the compressed data } +{$endif} + + bi_buf : ush; + { Output buffer. bits are inserted starting at the bottom (least + significant bits). } + + bi_valid : int; + { Number of valid bits in bi_buf. All bits above the last valid bit + are always zero. } + + case byte of + 0:(max_lazy_match : uInt); + { Attempt to find a better match only when the current match is strictly + smaller than this value. This mechanism is used only for compression + levels >= 4. } + + 1:(max_insert_length : uInt); + { Insert new strings in the hash table only if the match length is not + greater than this length. This saves time but degrades compression. + max_insert_length is used only for compression levels <= 3. } + end; + +procedure _tr_init (var s : deflate_state); + +function _tr_tally (var s : deflate_state; + dist : unsigned; + lc : unsigned) : boolean; + +function _tr_flush_block (var s : deflate_state; + buf : pcharf; + stored_len : ulg; + eof : boolean) : ulg; + +procedure _tr_align(var s : deflate_state); + +procedure _tr_stored_block(var s : deflate_state; + buf : pcharf; + stored_len : ulg; + eof : boolean); + +implementation + +{ #define GEN_TREES_H } + +{$ifndef GEN_TREES_H} +{ header created automatically with -DGEN_TREES_H } + +const + DIST_CODE_LEN = 512; { see definition of array dist_code below } + +{ The static literal tree. Since the bit lengths are imposed, there is no + need for the L_CODES extra codes used during heap construction. However + The codes 286 and 287 are needed to build a canonical tree (see _tr_init + below). } +var + static_ltree : array[0..L_CODES+2-1] of ct_data = ( +{ fc:(freq, code) dl:(dad,len) } +(fc:(freq: 12);dl:(len: 8)), (fc:(freq:140);dl:(len: 8)), (fc:(freq: 76);dl:(len: 8)), +(fc:(freq:204);dl:(len: 8)), (fc:(freq: 44);dl:(len: 8)), (fc:(freq:172);dl:(len: 8)), +(fc:(freq:108);dl:(len: 8)), (fc:(freq:236);dl:(len: 8)), (fc:(freq: 28);dl:(len: 8)), +(fc:(freq:156);dl:(len: 8)), (fc:(freq: 92);dl:(len: 8)), (fc:(freq:220);dl:(len: 8)), +(fc:(freq: 60);dl:(len: 8)), (fc:(freq:188);dl:(len: 8)), (fc:(freq:124);dl:(len: 8)), +(fc:(freq:252);dl:(len: 8)), (fc:(freq: 2);dl:(len: 8)), (fc:(freq:130);dl:(len: 8)), +(fc:(freq: 66);dl:(len: 8)), (fc:(freq:194);dl:(len: 8)), (fc:(freq: 34);dl:(len: 8)), +(fc:(freq:162);dl:(len: 8)), (fc:(freq: 98);dl:(len: 8)), (fc:(freq:226);dl:(len: 8)), +(fc:(freq: 18);dl:(len: 8)), (fc:(freq:146);dl:(len: 8)), (fc:(freq: 82);dl:(len: 8)), +(fc:(freq:210);dl:(len: 8)), (fc:(freq: 50);dl:(len: 8)), (fc:(freq:178);dl:(len: 8)), +(fc:(freq:114);dl:(len: 8)), (fc:(freq:242);dl:(len: 8)), (fc:(freq: 10);dl:(len: 8)), +(fc:(freq:138);dl:(len: 8)), (fc:(freq: 74);dl:(len: 8)), (fc:(freq:202);dl:(len: 8)), +(fc:(freq: 42);dl:(len: 8)), (fc:(freq:170);dl:(len: 8)), (fc:(freq:106);dl:(len: 8)), +(fc:(freq:234);dl:(len: 8)), (fc:(freq: 26);dl:(len: 8)), (fc:(freq:154);dl:(len: 8)), +(fc:(freq: 90);dl:(len: 8)), (fc:(freq:218);dl:(len: 8)), (fc:(freq: 58);dl:(len: 8)), +(fc:(freq:186);dl:(len: 8)), (fc:(freq:122);dl:(len: 8)), (fc:(freq:250);dl:(len: 8)), +(fc:(freq: 6);dl:(len: 8)), (fc:(freq:134);dl:(len: 8)), (fc:(freq: 70);dl:(len: 8)), +(fc:(freq:198);dl:(len: 8)), (fc:(freq: 38);dl:(len: 8)), (fc:(freq:166);dl:(len: 8)), +(fc:(freq:102);dl:(len: 8)), (fc:(freq:230);dl:(len: 8)), (fc:(freq: 22);dl:(len: 8)), +(fc:(freq:150);dl:(len: 8)), (fc:(freq: 86);dl:(len: 8)), (fc:(freq:214);dl:(len: 8)), +(fc:(freq: 54);dl:(len: 8)), (fc:(freq:182);dl:(len: 8)), (fc:(freq:118);dl:(len: 8)), +(fc:(freq:246);dl:(len: 8)), (fc:(freq: 14);dl:(len: 8)), (fc:(freq:142);dl:(len: 8)), +(fc:(freq: 78);dl:(len: 8)), (fc:(freq:206);dl:(len: 8)), (fc:(freq: 46);dl:(len: 8)), +(fc:(freq:174);dl:(len: 8)), (fc:(freq:110);dl:(len: 8)), (fc:(freq:238);dl:(len: 8)), +(fc:(freq: 30);dl:(len: 8)), (fc:(freq:158);dl:(len: 8)), (fc:(freq: 94);dl:(len: 8)), +(fc:(freq:222);dl:(len: 8)), (fc:(freq: 62);dl:(len: 8)), (fc:(freq:190);dl:(len: 8)), +(fc:(freq:126);dl:(len: 8)), (fc:(freq:254);dl:(len: 8)), (fc:(freq: 1);dl:(len: 8)), +(fc:(freq:129);dl:(len: 8)), (fc:(freq: 65);dl:(len: 8)), (fc:(freq:193);dl:(len: 8)), +(fc:(freq: 33);dl:(len: 8)), (fc:(freq:161);dl:(len: 8)), (fc:(freq: 97);dl:(len: 8)), +(fc:(freq:225);dl:(len: 8)), (fc:(freq: 17);dl:(len: 8)), (fc:(freq:145);dl:(len: 8)), +(fc:(freq: 81);dl:(len: 8)), (fc:(freq:209);dl:(len: 8)), (fc:(freq: 49);dl:(len: 8)), +(fc:(freq:177);dl:(len: 8)), (fc:(freq:113);dl:(len: 8)), (fc:(freq:241);dl:(len: 8)), +(fc:(freq: 9);dl:(len: 8)), (fc:(freq:137);dl:(len: 8)), (fc:(freq: 73);dl:(len: 8)), +(fc:(freq:201);dl:(len: 8)), (fc:(freq: 41);dl:(len: 8)), (fc:(freq:169);dl:(len: 8)), +(fc:(freq:105);dl:(len: 8)), (fc:(freq:233);dl:(len: 8)), (fc:(freq: 25);dl:(len: 8)), +(fc:(freq:153);dl:(len: 8)), (fc:(freq: 89);dl:(len: 8)), (fc:(freq:217);dl:(len: 8)), +(fc:(freq: 57);dl:(len: 8)), (fc:(freq:185);dl:(len: 8)), (fc:(freq:121);dl:(len: 8)), +(fc:(freq:249);dl:(len: 8)), (fc:(freq: 5);dl:(len: 8)), (fc:(freq:133);dl:(len: 8)), +(fc:(freq: 69);dl:(len: 8)), (fc:(freq:197);dl:(len: 8)), (fc:(freq: 37);dl:(len: 8)), +(fc:(freq:165);dl:(len: 8)), (fc:(freq:101);dl:(len: 8)), (fc:(freq:229);dl:(len: 8)), +(fc:(freq: 21);dl:(len: 8)), (fc:(freq:149);dl:(len: 8)), (fc:(freq: 85);dl:(len: 8)), +(fc:(freq:213);dl:(len: 8)), (fc:(freq: 53);dl:(len: 8)), (fc:(freq:181);dl:(len: 8)), +(fc:(freq:117);dl:(len: 8)), (fc:(freq:245);dl:(len: 8)), (fc:(freq: 13);dl:(len: 8)), +(fc:(freq:141);dl:(len: 8)), (fc:(freq: 77);dl:(len: 8)), (fc:(freq:205);dl:(len: 8)), +(fc:(freq: 45);dl:(len: 8)), (fc:(freq:173);dl:(len: 8)), (fc:(freq:109);dl:(len: 8)), +(fc:(freq:237);dl:(len: 8)), (fc:(freq: 29);dl:(len: 8)), (fc:(freq:157);dl:(len: 8)), +(fc:(freq: 93);dl:(len: 8)), (fc:(freq:221);dl:(len: 8)), (fc:(freq: 61);dl:(len: 8)), +(fc:(freq:189);dl:(len: 8)), (fc:(freq:125);dl:(len: 8)), (fc:(freq:253);dl:(len: 8)), +(fc:(freq: 19);dl:(len: 9)), (fc:(freq:275);dl:(len: 9)), (fc:(freq:147);dl:(len: 9)), +(fc:(freq:403);dl:(len: 9)), (fc:(freq: 83);dl:(len: 9)), (fc:(freq:339);dl:(len: 9)), +(fc:(freq:211);dl:(len: 9)), (fc:(freq:467);dl:(len: 9)), (fc:(freq: 51);dl:(len: 9)), +(fc:(freq:307);dl:(len: 9)), (fc:(freq:179);dl:(len: 9)), (fc:(freq:435);dl:(len: 9)), +(fc:(freq:115);dl:(len: 9)), (fc:(freq:371);dl:(len: 9)), (fc:(freq:243);dl:(len: 9)), +(fc:(freq:499);dl:(len: 9)), (fc:(freq: 11);dl:(len: 9)), (fc:(freq:267);dl:(len: 9)), +(fc:(freq:139);dl:(len: 9)), (fc:(freq:395);dl:(len: 9)), (fc:(freq: 75);dl:(len: 9)), +(fc:(freq:331);dl:(len: 9)), (fc:(freq:203);dl:(len: 9)), (fc:(freq:459);dl:(len: 9)), +(fc:(freq: 43);dl:(len: 9)), (fc:(freq:299);dl:(len: 9)), (fc:(freq:171);dl:(len: 9)), +(fc:(freq:427);dl:(len: 9)), (fc:(freq:107);dl:(len: 9)), (fc:(freq:363);dl:(len: 9)), +(fc:(freq:235);dl:(len: 9)), (fc:(freq:491);dl:(len: 9)), (fc:(freq: 27);dl:(len: 9)), +(fc:(freq:283);dl:(len: 9)), (fc:(freq:155);dl:(len: 9)), (fc:(freq:411);dl:(len: 9)), +(fc:(freq: 91);dl:(len: 9)), (fc:(freq:347);dl:(len: 9)), (fc:(freq:219);dl:(len: 9)), +(fc:(freq:475);dl:(len: 9)), (fc:(freq: 59);dl:(len: 9)), (fc:(freq:315);dl:(len: 9)), +(fc:(freq:187);dl:(len: 9)), (fc:(freq:443);dl:(len: 9)), (fc:(freq:123);dl:(len: 9)), +(fc:(freq:379);dl:(len: 9)), (fc:(freq:251);dl:(len: 9)), (fc:(freq:507);dl:(len: 9)), +(fc:(freq: 7);dl:(len: 9)), (fc:(freq:263);dl:(len: 9)), (fc:(freq:135);dl:(len: 9)), +(fc:(freq:391);dl:(len: 9)), (fc:(freq: 71);dl:(len: 9)), (fc:(freq:327);dl:(len: 9)), +(fc:(freq:199);dl:(len: 9)), (fc:(freq:455);dl:(len: 9)), (fc:(freq: 39);dl:(len: 9)), +(fc:(freq:295);dl:(len: 9)), (fc:(freq:167);dl:(len: 9)), (fc:(freq:423);dl:(len: 9)), +(fc:(freq:103);dl:(len: 9)), (fc:(freq:359);dl:(len: 9)), (fc:(freq:231);dl:(len: 9)), +(fc:(freq:487);dl:(len: 9)), (fc:(freq: 23);dl:(len: 9)), (fc:(freq:279);dl:(len: 9)), +(fc:(freq:151);dl:(len: 9)), (fc:(freq:407);dl:(len: 9)), (fc:(freq: 87);dl:(len: 9)), +(fc:(freq:343);dl:(len: 9)), (fc:(freq:215);dl:(len: 9)), (fc:(freq:471);dl:(len: 9)), +(fc:(freq: 55);dl:(len: 9)), (fc:(freq:311);dl:(len: 9)), (fc:(freq:183);dl:(len: 9)), +(fc:(freq:439);dl:(len: 9)), (fc:(freq:119);dl:(len: 9)), (fc:(freq:375);dl:(len: 9)), +(fc:(freq:247);dl:(len: 9)), (fc:(freq:503);dl:(len: 9)), (fc:(freq: 15);dl:(len: 9)), +(fc:(freq:271);dl:(len: 9)), (fc:(freq:143);dl:(len: 9)), (fc:(freq:399);dl:(len: 9)), +(fc:(freq: 79);dl:(len: 9)), (fc:(freq:335);dl:(len: 9)), (fc:(freq:207);dl:(len: 9)), +(fc:(freq:463);dl:(len: 9)), (fc:(freq: 47);dl:(len: 9)), (fc:(freq:303);dl:(len: 9)), +(fc:(freq:175);dl:(len: 9)), (fc:(freq:431);dl:(len: 9)), (fc:(freq:111);dl:(len: 9)), +(fc:(freq:367);dl:(len: 9)), (fc:(freq:239);dl:(len: 9)), (fc:(freq:495);dl:(len: 9)), +(fc:(freq: 31);dl:(len: 9)), (fc:(freq:287);dl:(len: 9)), (fc:(freq:159);dl:(len: 9)), +(fc:(freq:415);dl:(len: 9)), (fc:(freq: 95);dl:(len: 9)), (fc:(freq:351);dl:(len: 9)), +(fc:(freq:223);dl:(len: 9)), (fc:(freq:479);dl:(len: 9)), (fc:(freq: 63);dl:(len: 9)), +(fc:(freq:319);dl:(len: 9)), (fc:(freq:191);dl:(len: 9)), (fc:(freq:447);dl:(len: 9)), +(fc:(freq:127);dl:(len: 9)), (fc:(freq:383);dl:(len: 9)), (fc:(freq:255);dl:(len: 9)), +(fc:(freq:511);dl:(len: 9)), (fc:(freq: 0);dl:(len: 7)), (fc:(freq: 64);dl:(len: 7)), +(fc:(freq: 32);dl:(len: 7)), (fc:(freq: 96);dl:(len: 7)), (fc:(freq: 16);dl:(len: 7)), +(fc:(freq: 80);dl:(len: 7)), (fc:(freq: 48);dl:(len: 7)), (fc:(freq:112);dl:(len: 7)), +(fc:(freq: 8);dl:(len: 7)), (fc:(freq: 72);dl:(len: 7)), (fc:(freq: 40);dl:(len: 7)), +(fc:(freq:104);dl:(len: 7)), (fc:(freq: 24);dl:(len: 7)), (fc:(freq: 88);dl:(len: 7)), +(fc:(freq: 56);dl:(len: 7)), (fc:(freq:120);dl:(len: 7)), (fc:(freq: 4);dl:(len: 7)), +(fc:(freq: 68);dl:(len: 7)), (fc:(freq: 36);dl:(len: 7)), (fc:(freq:100);dl:(len: 7)), +(fc:(freq: 20);dl:(len: 7)), (fc:(freq: 84);dl:(len: 7)), (fc:(freq: 52);dl:(len: 7)), +(fc:(freq:116);dl:(len: 7)), (fc:(freq: 3);dl:(len: 8)), (fc:(freq:131);dl:(len: 8)), +(fc:(freq: 67);dl:(len: 8)), (fc:(freq:195);dl:(len: 8)), (fc:(freq: 35);dl:(len: 8)), +(fc:(freq:163);dl:(len: 8)), (fc:(freq: 99);dl:(len: 8)), (fc:(freq:227);dl:(len: 8)) +); + + +{ The static distance tree. (Actually a trivial tree since all lens use + 5 bits.) } + static_dtree : array[0..D_CODES-1] of ct_data = ( +(fc:(freq: 0); dl:(len:5)), (fc:(freq:16); dl:(len:5)), (fc:(freq: 8); dl:(len:5)), +(fc:(freq:24); dl:(len:5)), (fc:(freq: 4); dl:(len:5)), (fc:(freq:20); dl:(len:5)), +(fc:(freq:12); dl:(len:5)), (fc:(freq:28); dl:(len:5)), (fc:(freq: 2); dl:(len:5)), +(fc:(freq:18); dl:(len:5)), (fc:(freq:10); dl:(len:5)), (fc:(freq:26); dl:(len:5)), +(fc:(freq: 6); dl:(len:5)), (fc:(freq:22); dl:(len:5)), (fc:(freq:14); dl:(len:5)), +(fc:(freq:30); dl:(len:5)), (fc:(freq: 1); dl:(len:5)), (fc:(freq:17); dl:(len:5)), +(fc:(freq: 9); dl:(len:5)), (fc:(freq:25); dl:(len:5)), (fc:(freq: 5); dl:(len:5)), +(fc:(freq:21); dl:(len:5)), (fc:(freq:13); dl:(len:5)), (fc:(freq:29); dl:(len:5)), +(fc:(freq: 3); dl:(len:5)), (fc:(freq:19); dl:(len:5)), (fc:(freq:11); dl:(len:5)), +(fc:(freq:27); dl:(len:5)), (fc:(freq: 7); dl:(len:5)), (fc:(freq:23); dl:(len:5)) +); + +{ Distance codes. The first 256 values correspond to the distances + 3 .. 258, the last 256 values correspond to the top 8 bits of + the 15 bit distances. } + _dist_code : array[0..DIST_CODE_LEN-1] of uch = ( + 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, + 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10, +10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, +11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, +12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13, +13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, +13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17, +18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22, +23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29 +); + +{ length code for each normalized match length (0 == MIN_MATCH) } + _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch = ( + 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12, +13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16, +17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, +19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, +21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22, +22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23, +23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, +25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28 +); + + +{ First normalized length for each code (0 = MIN_MATCH) } + base_length : array[0..LENGTH_CODES-1] of int = ( +0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56, +64, 80, 96, 112, 128, 160, 192, 224, 0 +); + + +{ First normalized distance for each code (0 = distance of 1) } + base_dist : array[0..D_CODES-1] of int = ( + 0, 1, 2, 3, 4, 6, 8, 12, 16, 24, + 32, 48, 64, 96, 128, 192, 256, 384, 512, 768, + 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576 +); +{$endif} + +{ Output a byte on the stream. + IN assertion: there is enough room in pending_buf. +macro put_byte(s, c) +begin + s^.pending_buf^[s^.pending] := (c); + Inc(s^.pending); +end +} + +const + MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1); +{ Minimum amount of lookahead, except at the end of the input file. + See deflate.c for comments about the MIN_MATCH+1. } + +{macro d_code(dist) + if (dist) < 256 then + := _dist_code[dist] + else + := _dist_code[256+((dist) shr 7)]); + Mapping from a distance to a distance code. dist is the distance - 1 and + must not have side effects. _dist_code[256] and _dist_code[257] are never + used. } + +{$ifndef ORG_DEBUG} +{ Inline versions of _tr_tally for speed: } + +#if defined(GEN_TREES_H) || !defined(STDC) + extern uch _length_code[]; + extern uch _dist_code[]; +#else + extern const uch _length_code[]; + extern const uch _dist_code[]; +#endif + +macro _tr_tally_lit(s, c, flush) +var + cc : uch; +begin + cc := (c); + s^.d_buf[s^.last_lit] := 0; + s^.l_buf[s^.last_lit] := cc; + Inc(s^.last_lit); + Inc(s^.dyn_ltree[cc].fc.Freq); + flush := (s^.last_lit = s^.lit_bufsize-1); +end; + +macro _tr_tally_dist(s, distance, length, flush) \ +var + len : uch; + dist : ush; +begin + len := (length); + dist := (distance); + s^.d_buf[s^.last_lit] := dist; + s^.l_buf[s^.last_lit] = len; + Inc(s^.last_lit); + Dec(dist); + Inc(s^.dyn_ltree[_length_code[len]+LITERALS+1].fc.Freq); + Inc(s^.dyn_dtree[d_code(dist)].Freq); + flush := (s^.last_lit = s^.lit_bufsize-1); +end; + +{$endif} + +{ =========================================================================== + Constants } + +const + MAX_BL_BITS = 7; +{ Bit length codes must not exceed MAX_BL_BITS bits } + +const + END_BLOCK = 256; +{ end of block literal code } + +const + REP_3_6 = 16; +{ repeat previous bit length 3-6 times (2 bits of repeat count) } + +const + REPZ_3_10 = 17; +{ repeat a zero length 3-10 times (3 bits of repeat count) } + +const + REPZ_11_138 = 18; +{ repeat a zero length 11-138 times (7 bits of repeat count) } + +{local} +const + extra_lbits : array[0..LENGTH_CODES-1] of int + { extra bits for each length code } + = (0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0); + +{local} +const + extra_dbits : array[0..D_CODES-1] of int + { extra bits for each distance code } + = (0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13); + +{local} +const + extra_blbits : array[0..BL_CODES-1] of int { extra bits for each bit length code } + = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7); + +{local} +const + bl_order : array[0..BL_CODES-1] of uch + = (16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15); +{ The lengths of the bit length codes are sent in order of decreasing + probability, to avoid transmitting the lengths for unused bit length codes. + } + +const + Buf_size = (8 * 2*sizeof(char)); +{ Number of bits used within bi_buf. (bi_buf might be implemented on + more than 16 bits on some systems.) } + +{ =========================================================================== + Local data. These are initialized only once. } + + +{$ifdef GEN_TREES_H)} +{ non ANSI compilers may not accept trees.h } + +const + DIST_CODE_LEN = 512; { see definition of array dist_code below } + +{local} +var + static_ltree : array[0..L_CODES+2-1] of ct_data; +{ The static literal tree. Since the bit lengths are imposed, there is no + need for the L_CODES extra codes used during heap construction. However + The codes 286 and 287 are needed to build a canonical tree (see _tr_init + below). } + +{local} + static_dtree : array[0..D_CODES-1] of ct_data; +{ The static distance tree. (Actually a trivial tree since all codes use + 5 bits.) } + + _dist_code : array[0..DIST_CODE_LEN-1] of uch; +{ Distance codes. The first 256 values correspond to the distances + 3 .. 258, the last 256 values correspond to the top 8 bits of + the 15 bit distances. } + + _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch; +{ length code for each normalized match length (0 == MIN_MATCH) } + +{local} + base_length : array[0..LENGTH_CODES-1] of int; +{ First normalized length for each code (0 = MIN_MATCH) } + +{local} + base_dist : array[0..D_CODES-1] of int; +{ First normalized distance for each code (0 = distance of 1) } + +{$endif} { GEN_TREES_H } + +{local} +const + static_l_desc : static_tree_desc = + (static_tree: {tree_ptr}(@(static_ltree)); { pointer to array of ct_data } + extra_bits: {pzIntfArray}(@(extra_lbits)); { pointer to array of int } + extra_base: LITERALS+1; + elems: L_CODES; + max_length: MAX_BITS); + +{local} +const + static_d_desc : static_tree_desc = + (static_tree: {tree_ptr}(@(static_dtree)); + extra_bits: {pzIntfArray}(@(extra_dbits)); + extra_base : 0; + elems: D_CODES; + max_length: MAX_BITS); + +{local} +const + static_bl_desc : static_tree_desc = + (static_tree: {tree_ptr}(NIL); + extra_bits: {pzIntfArray}@(extra_blbits); + extra_base : 0; + elems: BL_CODES; + max_length: MAX_BL_BITS); + +(* =========================================================================== + Local (static) routines in this file. } + +procedure tr_static_init; +procedure init_block(var deflate_state); +procedure pqdownheap(var s : deflate_state; + var tree : ct_data; + k : int); +procedure gen_bitlen(var s : deflate_state; + var desc : tree_desc); +procedure gen_codes(var tree : ct_data; + max_code : int; + bl_count : pushf); +procedure build_tree(var s : deflate_state; + var desc : tree_desc); +procedure scan_tree(var s : deflate_state; + var tree : ct_data; + max_code : int); +procedure send_tree(var s : deflate_state; + var tree : ct_data; + max_code : int); +function build_bl_tree(var deflate_state) : int; +procedure send_all_trees(var deflate_state; + lcodes : int; + dcodes : int; + blcodes : int); +procedure compress_block(var s : deflate_state; + var ltree : ct_data; + var dtree : ct_data); +procedure set_data_type(var s : deflate_state); +function bi_reverse(value : unsigned; + length : int) : unsigned; +procedure bi_windup(var deflate_state); +procedure bi_flush(var deflate_state); +procedure copy_block(var deflate_state; + buf : pcharf; + len : unsigned; + header : int); +*) + +{$ifdef GEN_TREES_H} +{local} +procedure gen_trees_header; +{$endif} + +(* +{ =========================================================================== + Output a short LSB first on the stream. + IN assertion: there is enough room in pendingBuf. } + +macro put_short(s, w) +begin + {put_byte(s, (uch)((w) & 0xff));} + s.pending_buf^[s.pending] := uch((w) and $ff); + Inc(s.pending); + + {put_byte(s, (uch)((ush)(w) >> 8));} + s.pending_buf^[s.pending] := uch(ush(w) shr 8);; + Inc(s.pending); +end +*) + +{ =========================================================================== + Send a value on a given number of bits. + IN assertion: length <= 16 and value fits in length bits. } + +{$ifdef ORG_DEBUG} + +{local} +procedure send_bits(var s : deflate_state; + value : int; { value to send } + length : int); { number of bits } +begin + {$ifdef DEBUG} + Tracevv(' l '+IntToStr(length)+ ' v '+IntToStr(value)); + Assert((length > 0) and (length <= 15), 'invalid length'); + Inc(s.bits_sent, ulg(length)); + {$ENDIF} + + { If not enough room in bi_buf, use (valid) bits from bi_buf and + (16 - bi_valid) bits from value, leaving (width - (16-bi_valid)) + unused bits in value. } + {$IFOPT Q+} {$Q-} {$DEFINE NoOverflowCheck} {$ENDIF} + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (s.bi_valid > int(Buf_size) - length) then + begin + s.bi_buf := s.bi_buf or int(value shl s.bi_valid); + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s.bi_buf := ush(value) shr (Buf_size - s.bi_valid); + Inc(s.bi_valid, length - Buf_size); + end + else + begin + s.bi_buf := s.bi_buf or int(value shl s.bi_valid); + Inc(s.bi_valid, length); + end; + {$IFDEF NoOverflowCheck} {$Q+} {$UNDEF NoOverflowCheck} {$ENDIF} + {$IFDEF NoRangeCheck} {$Q+} {$UNDEF NoRangeCheck} {$ENDIF} +end; + +{$else} { !DEBUG } + + +macro send_code(s, c, tree) +begin + send_bits(s, tree[c].Code, tree[c].Len); + { Send a code of the given tree. c and tree must not have side effects } +end + +macro send_bits(s, value, length) \ +begin int len := length;\ + if (s^.bi_valid > (int)Buf_size - len) begin\ + int val := value;\ + s^.bi_buf |= (val << s^.bi_valid);\ + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s^.bi_buf := (ush)val >> (Buf_size - s^.bi_valid);\ + s^.bi_valid += len - Buf_size;\ + end else begin\ + s^.bi_buf |= (value) << s^.bi_valid;\ + s^.bi_valid += len;\ + end\ +end; +{$endif} { DEBUG } + +{ =========================================================================== + Reverse the first len bits of a code, using straightforward code (a faster + method would use a table) + IN assertion: 1 <= len <= 15 } + +{local} +function bi_reverse(code : unsigned; { the value to invert } + len : int) : unsigned; { its bit length } + +var + res : unsigned; {register} +begin + res := 0; + repeat + res := res or (code and 1); + code := code shr 1; + res := res shl 1; + Dec(len); + until (len <= 0); + bi_reverse := res shr 1; +end; + +{ =========================================================================== + Generate the codes for a given tree and bit counts (which need not be + optimal). + IN assertion: the array bl_count contains the bit length statistics for + the given tree and the field len is set for all tree elements. + OUT assertion: the field code is set for all tree elements of non + zero code length. } + +{local} +procedure gen_codes(tree : tree_ptr; { the tree to decorate } + max_code : int; { largest code with non zero frequency } + var bl_count : array of ushf); { number of codes at each bit length } + +var + next_code : array[0..MAX_BITS+1-1] of ush; { next code value for each bit length } + code : ush; { running code value } + bits : int; { bit index } + n : int; { code index } +var + len : int; +begin + code := 0; + + { The distribution counts are first used to generate the code values + without bit reversal. } + + for bits := 1 to MAX_BITS do + begin + code := ((code + bl_count[bits-1]) shl 1); + next_code[bits] := code; + end; + { Check that the bit counts in bl_count are consistent. The last code + must be all ones. } + + {$IFDEF DEBUG} + Assert (code + bl_count[MAX_BITS]-1 = (1 shl MAX_BITS)-1, + 'inconsistent bit counts'); + Tracev(#13'gen_codes: max_code '+IntToStr(max_code)); + {$ENDIF} + + for n := 0 to max_code do + begin + len := tree^[n].dl.Len; + if (len = 0) then + continue; + { Now reverse the bits } + tree^[n].fc.Code := bi_reverse(next_code[len], len); + Inc(next_code[len]); + {$ifdef DEBUG} + if (n>31) and (n<128) then + Tracecv(tree <> tree_ptr(@static_ltree), + (^M'n #'+IntToStr(n)+' '+char(n)+' l '+IntToStr(len)+' c '+ + IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')')) + else + Tracecv(tree <> tree_ptr(@static_ltree), + (^M'n #'+IntToStr(n)+' l '+IntToStr(len)+' c '+ + IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')')); + {$ENDIF} + end; +end; + +{ =========================================================================== + Genererate the file trees.h describing the static trees. } +{$ifdef GEN_TREES_H} + +macro SEPARATOR(i, last, width) + if (i) = (last) then + ( ^M');'^M^M + else \ + if (i) mod (width) = (width)-1 then + ','^M + else + ', ' + +procedure gen_trees_header; +var + header : system.text; + i : int; +begin + system.assign(header, 'trees.inc'); + {$I-} + ReWrite(header); + {$I+} + Assert (IOresult <> 0, 'Can''t open trees.h'); + WriteLn(header, + '{ header created automatically with -DGEN_TREES_H }'^M); + + WriteLn(header, 'local const ct_data static_ltree[L_CODES+2] := ('); + for i := 0 to L_CODES+2-1 do + begin + WriteLn(header, '((%3u),(%3u))%s', static_ltree[i].Code, + static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5)); + end; + + WriteLn(header, 'local const ct_data static_dtree[D_CODES] := ('); + for i := 0 to D_CODES-1 do + begin + WriteLn(header, '((%2u),(%2u))%s', static_dtree[i].Code, + static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5)); + end; + + WriteLn(header, 'const uch _dist_code[DIST_CODE_LEN] := ('); + for i := 0 to DIST_CODE_LEN-1 do + begin + WriteLn(header, '%2u%s', _dist_code[i], + SEPARATOR(i, DIST_CODE_LEN-1, 20)); + end; + + WriteLn(header, 'const uch _length_code[MAX_MATCH-MIN_MATCH+1]= ('); + for i := 0 to MAX_MATCH-MIN_MATCH+1-1 do + begin + WriteLn(header, '%2u%s', _length_code[i], + SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20)); + end; + + WriteLn(header, 'local const int base_length[LENGTH_CODES] := ('); + for i := 0 to LENGTH_CODES-1 do + begin + WriteLn(header, '%1u%s', base_length[i], + SEPARATOR(i, LENGTH_CODES-1, 20)); + end; + + WriteLn(header, 'local const int base_dist[D_CODES] := ('); + for i := 0 to D_CODES-1 do + begin + WriteLn(header, '%5u%s', base_dist[i], + SEPARATOR(i, D_CODES-1, 10)); + end; + + close(header); +end; +{$endif} { GEN_TREES_H } + + +{ =========================================================================== + Initialize the various 'constant' tables. } + +{local} +procedure tr_static_init; + +{$ifdef GEN_TREES_H} +const + static_init_done : boolean = FALSE; +var + n : int; { iterates over tree elements } + bits : int; { bit counter } + length : int; { length value } + code : int; { code value } + dist : int; { distance index } + bl_count : array[0..MAX_BITS+1-1] of ush; + { number of codes at each bit length for an optimal tree } +begin + if (static_init_done) then + exit; + + { Initialize the mapping length (0..255) -> length code (0..28) } + length := 0; + for code := 0 to LENGTH_CODES-1-1 do + begin + base_length[code] := length; + for n := 0 to (1 shl extra_lbits[code])-1 do + begin + _length_code[length] := uch(code); + Inc(length); + end; + end; + Assert (length = 256, 'tr_static_init: length <> 256'); + { Note that the length 255 (match length 258) can be represented + in two different ways: code 284 + 5 bits or code 285, so we + overwrite length_code[255] to use the best encoding: } + + _length_code[length-1] := uch(code); + + { Initialize the mapping dist (0..32K) -> dist code (0..29) } + dist := 0; + for code := 0 to 16-1 do + begin + base_dist[code] := dist; + for n := 0 to (1 shl extra_dbits[code])-1 do + begin + _dist_code[dist] := uch(code); + Inc(dist); + end; + end; + Assert (dist = 256, 'tr_static_init: dist <> 256'); + dist := dist shr 7; { from now on, all distances are divided by 128 } + for code := 16 to D_CODES-1 do + begin + base_dist[code] := dist shl 7; + for n := 0 to (1 shl (extra_dbits[code]-7))-1 do + begin + _dist_code[256 + dist] := uch(code); + Inc(dist); + end; + end; + Assert (dist = 256, 'tr_static_init: 256+dist <> 512'); + + { Construct the codes of the static literal tree } + for bits := 0 to MAX_BITS do + bl_count[bits] := 0; + n := 0; + while (n <= 143) do + begin + static_ltree[n].dl.Len := 8; + Inc(n); + Inc(bl_count[8]); + end; + while (n <= 255) do + begin + static_ltree[n].dl.Len := 9; + Inc(n); + Inc(bl_count[9]); + end; + while (n <= 279) do + begin + static_ltree[n].dl.Len := 7; + Inc(n); + Inc(bl_count[7]); + end; + while (n <= 287) do + begin + static_ltree[n].dl.Len := 8; + Inc(n); + Inc(bl_count[8]); + end; + + { Codes 286 and 287 do not exist, but we must include them in the + tree construction to get a canonical Huffman tree (longest code + all ones) } + + gen_codes(tree_ptr(@static_ltree), L_CODES+1, bl_count); + + { The static distance tree is trivial: } + for n := 0 to D_CODES-1 do + begin + static_dtree[n].dl.Len := 5; + static_dtree[n].fc.Code := bi_reverse(unsigned(n), 5); + end; + static_init_done := TRUE; + + gen_trees_header; { save to include file } +{$else} +begin +{$endif} { GEN_TREES_H) } +end; + +{ =========================================================================== + Initialize a new block. } +{local} + +procedure init_block(var s : deflate_state); +var + n : int; { iterates over tree elements } +begin + { Initialize the trees. } + for n := 0 to L_CODES-1 do + s.dyn_ltree[n].fc.Freq := 0; + for n := 0 to D_CODES-1 do + s.dyn_dtree[n].fc.Freq := 0; + for n := 0 to BL_CODES-1 do + s.bl_tree[n].fc.Freq := 0; + + s.dyn_ltree[END_BLOCK].fc.Freq := 1; + s.static_len := Long(0); + s.opt_len := Long(0); + s.matches := 0; + s.last_lit := 0; +end; + +const + SMALLEST = 1; +{ Index within the heap array of least frequent node in the Huffman tree } + +{ =========================================================================== + Initialize the tree data structures for a new zlib stream. } +procedure _tr_init(var s : deflate_state); +begin + tr_static_init; + + s.compressed_len := Long(0); + + s.l_desc.dyn_tree := tree_ptr(@s.dyn_ltree); + s.l_desc.stat_desc := @static_l_desc; + + s.d_desc.dyn_tree := tree_ptr(@s.dyn_dtree); + s.d_desc.stat_desc := @static_d_desc; + + s.bl_desc.dyn_tree := tree_ptr(@s.bl_tree); + s.bl_desc.stat_desc := @static_bl_desc; + + s.bi_buf := 0; + s.bi_valid := 0; + s.last_eob_len := 8; { enough lookahead for inflate } +{$ifdef DEBUG} + s.bits_sent := Long(0); +{$endif} + + { Initialize the first block of the first file: } + init_block(s); +end; + +{ =========================================================================== + Remove the smallest element from the heap and recreate the heap with + one less element. Updates heap and heap_len. + +macro pqremove(s, tree, top) +begin + top := s.heap[SMALLEST]; + s.heap[SMALLEST] := s.heap[s.heap_len]; + Dec(s.heap_len); + pqdownheap(s, tree, SMALLEST); +end +} + +{ =========================================================================== + Compares to subtrees, using the tree depth as tie breaker when + the subtrees have equal frequency. This minimizes the worst case length. + +macro smaller(tree, n, m, depth) + ( (tree[n].Freq < tree[m].Freq) or + ((tree[n].Freq = tree[m].Freq) and (depth[n] <= depth[m])) ) +} + +{ =========================================================================== + Restore the heap property by moving down the tree starting at node k, + exchanging a node with the smallest of its two sons if necessary, stopping + when the heap property is re-established (each father smaller than its + two sons). } +{local} + +procedure pqdownheap(var s : deflate_state; + var tree : tree_type; { the tree to restore } + k : int); { node to move down } +var + v : int; + j : int; +begin + v := s.heap[k]; + j := k shl 1; { left son of k } + while (j <= s.heap_len) do + begin + { Set j to the smallest of the two sons: } + if (j < s.heap_len) and + {smaller(tree, s.heap[j+1], s.heap[j], s.depth)} + ( (tree[s.heap[j+1]].fc.Freq < tree[s.heap[j]].fc.Freq) or + ((tree[s.heap[j+1]].fc.Freq = tree[s.heap[j]].fc.Freq) and + (s.depth[s.heap[j+1]] <= s.depth[s.heap[j]])) ) then + begin + Inc(j); + end; + { Exit if v is smaller than both sons } + if {(smaller(tree, v, s.heap[j], s.depth))} + ( (tree[v].fc.Freq < tree[s.heap[j]].fc.Freq) or + ((tree[v].fc.Freq = tree[s.heap[j]].fc.Freq) and + (s.depth[v] <= s.depth[s.heap[j]])) ) then + break; + { Exchange v with the smallest son } + s.heap[k] := s.heap[j]; + k := j; + + { And continue down the tree, setting j to the left son of k } + j := j shl 1; + end; + s.heap[k] := v; +end; + +{ =========================================================================== + Compute the optimal bit lengths for a tree and update the total bit length + for the current block. + IN assertion: the fields freq and dad are set, heap[heap_max] and + above are the tree nodes sorted by increasing frequency. + OUT assertions: the field len is set to the optimal bit length, the + array bl_count contains the frequencies for each bit length. + The length opt_len is updated; static_len is also updated if stree is + not null. } + +{local} +procedure gen_bitlen(var s : deflate_state; + var desc : tree_desc); { the tree descriptor } +var + tree : tree_ptr; + max_code : int; + stree : tree_ptr; {const} + extra : pzIntfArray; {const} + base : int; + max_length : int; + h : int; { heap index } + n, m : int; { iterate over the tree elements } + bits : int; { bit length } + xbits : int; { extra bits } + f : ush; { frequency } + overflow : int; { number of elements with bit length too large } +begin + tree := desc.dyn_tree; + max_code := desc.max_code; + stree := desc.stat_desc^.static_tree; + extra := desc.stat_desc^.extra_bits; + base := desc.stat_desc^.extra_base; + max_length := desc.stat_desc^.max_length; + overflow := 0; + + for bits := 0 to MAX_BITS do + s.bl_count[bits] := 0; + + { In a first pass, compute the optimal bit lengths (which may + overflow in the case of the bit length tree). } + + tree^[s.heap[s.heap_max]].dl.Len := 0; { root of the heap } + + for h := s.heap_max+1 to HEAP_SIZE-1 do + begin + n := s.heap[h]; + bits := tree^[tree^[n].dl.Dad].dl.Len + 1; + if (bits > max_length) then + begin + bits := max_length; + Inc(overflow); + end; + tree^[n].dl.Len := ush(bits); + { We overwrite tree[n].dl.Dad which is no longer needed } + + if (n > max_code) then + continue; { not a leaf node } + + Inc(s.bl_count[bits]); + xbits := 0; + if (n >= base) then + xbits := extra^[n-base]; + f := tree^[n].fc.Freq; + Inc(s.opt_len, ulg(f) * (bits + xbits)); + if (stree <> NIL) then + Inc(s.static_len, ulg(f) * (stree^[n].dl.Len + xbits)); + end; + if (overflow = 0) then + exit; + {$ifdef DEBUG} + Tracev(^M'bit length overflow'); + {$endif} + { This happens for example on obj2 and pic of the Calgary corpus } + + { Find the first bit length which could increase: } + repeat + bits := max_length-1; + while (s.bl_count[bits] = 0) do + Dec(bits); + Dec(s.bl_count[bits]); { move one leaf down the tree } + Inc(s.bl_count[bits+1], 2); { move one overflow item as its brother } + Dec(s.bl_count[max_length]); + { The brother of the overflow item also moves one step up, + but this does not affect bl_count[max_length] } + + Dec(overflow, 2); + until (overflow <= 0); + + { Now recompute all bit lengths, scanning in increasing frequency. + h is still equal to HEAP_SIZE. (It is simpler to reconstruct all + lengths instead of fixing only the wrong ones. This idea is taken + from 'ar' written by Haruhiko Okumura.) } + h := HEAP_SIZE; { Delphi3: compiler warning w/o this } + for bits := max_length downto 1 do + begin + n := s.bl_count[bits]; + while (n <> 0) do + begin + Dec(h); + m := s.heap[h]; + if (m > max_code) then + continue; + if (tree^[m].dl.Len <> unsigned(bits)) then + begin + {$ifdef DEBUG} + Trace('code '+IntToStr(m)+' bits '+IntToStr(tree^[m].dl.Len) + +'.'+IntToStr(bits)); + {$ENDIF} + Inc(s.opt_len, (long(bits) - long(tree^[m].dl.Len)) + * long(tree^[m].fc.Freq) ); + tree^[m].dl.Len := ush(bits); + end; + Dec(n); + end; + end; +end; + +{ =========================================================================== + Construct one Huffman tree and assigns the code bit strings and lengths. + Update the total bit length for the current block. + IN assertion: the field freq is set for all tree elements. + OUT assertions: the fields len and code are set to the optimal bit length + and corresponding code. The length opt_len is updated; static_len is + also updated if stree is not null. The field max_code is set. } + +{local} +procedure build_tree(var s : deflate_state; + var desc : tree_desc); { the tree descriptor } + +var + tree : tree_ptr; + stree : tree_ptr; {const} + elems : int; + n, m : int; { iterate over heap elements } + max_code : int; { largest code with non zero frequency } + node : int; { new node being created } +begin + tree := desc.dyn_tree; + stree := desc.stat_desc^.static_tree; + elems := desc.stat_desc^.elems; + max_code := -1; + + { Construct the initial heap, with least frequent element in + heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1]. + heap[0] is not used. } + s.heap_len := 0; + s.heap_max := HEAP_SIZE; + + for n := 0 to elems-1 do + begin + if (tree^[n].fc.Freq <> 0) then + begin + max_code := n; + Inc(s.heap_len); + s.heap[s.heap_len] := n; + s.depth[n] := 0; + end + else + begin + tree^[n].dl.Len := 0; + end; + end; + + { The pkzip format requires that at least one distance code exists, + and that at least one bit should be sent even if there is only one + possible code. So to avoid special checks later on we force at least + two codes of non zero frequency. } + + while (s.heap_len < 2) do + begin + Inc(s.heap_len); + if (max_code < 2) then + begin + Inc(max_code); + s.heap[s.heap_len] := max_code; + node := max_code; + end + else + begin + s.heap[s.heap_len] := 0; + node := 0; + end; + tree^[node].fc.Freq := 1; + s.depth[node] := 0; + Dec(s.opt_len); + if (stree <> NIL) then + Dec(s.static_len, stree^[node].dl.Len); + { node is 0 or 1 so it does not have extra bits } + end; + desc.max_code := max_code; + + { The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree, + establish sub-heaps of increasing lengths: } + + for n := s.heap_len div 2 downto 1 do + pqdownheap(s, tree^, n); + + { Construct the Huffman tree by repeatedly combining the least two + frequent nodes. } + + node := elems; { next internal node of the tree } + repeat + {pqremove(s, tree, n);} { n := node of least frequency } + n := s.heap[SMALLEST]; + s.heap[SMALLEST] := s.heap[s.heap_len]; + Dec(s.heap_len); + pqdownheap(s, tree^, SMALLEST); + + m := s.heap[SMALLEST]; { m := node of next least frequency } + + Dec(s.heap_max); + s.heap[s.heap_max] := n; { keep the nodes sorted by frequency } + Dec(s.heap_max); + s.heap[s.heap_max] := m; + + { Create a new node father of n and m } + tree^[node].fc.Freq := tree^[n].fc.Freq + tree^[m].fc.Freq; + { maximum } + if (s.depth[n] >= s.depth[m]) then + s.depth[node] := uch (s.depth[n] + 1) + else + s.depth[node] := uch (s.depth[m] + 1); + + tree^[m].dl.Dad := ush(node); + tree^[n].dl.Dad := ush(node); +{$ifdef DUMP_BL_TREE} + if (tree = tree_ptr(@s.bl_tree)) then + begin + WriteLn(#13'node ',node,'(',tree^[node].fc.Freq,') sons ',n, + '(',tree^[n].fc.Freq,') ', m, '(',tree^[m].fc.Freq,')'); + end; +{$endif} + { and insert the new node in the heap } + s.heap[SMALLEST] := node; + Inc(node); + pqdownheap(s, tree^, SMALLEST); + + until (s.heap_len < 2); + + Dec(s.heap_max); + s.heap[s.heap_max] := s.heap[SMALLEST]; + + { At this point, the fields freq and dad are set. We can now + generate the bit lengths. } + + gen_bitlen(s, desc); + + { The field len is now set, we can generate the bit codes } + gen_codes (tree, max_code, s.bl_count); +end; + +{ =========================================================================== + Scan a literal or distance tree to determine the frequencies of the codes + in the bit length tree. } + +{local} +procedure scan_tree(var s : deflate_state; + var tree : array of ct_data; { the tree to be scanned } + max_code : int); { and its largest code of non zero frequency } +var + n : int; { iterates over all tree elements } + prevlen : int; { last emitted length } + curlen : int; { length of current code } + nextlen : int; { length of next code } + count : int; { repeat count of the current code } + max_count : int; { max repeat count } + min_count : int; { min repeat count } +begin + prevlen := -1; + nextlen := tree[0].dl.Len; + count := 0; + max_count := 7; + min_count := 4; + + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end; + tree[max_code+1].dl.Len := ush($ffff); { guard } + + for n := 0 to max_code do + begin + curlen := nextlen; + nextlen := tree[n+1].dl.Len; + Inc(count); + if (count < max_count) and (curlen = nextlen) then + continue + else + if (count < min_count) then + Inc(s.bl_tree[curlen].fc.Freq, count) + else + if (curlen <> 0) then + begin + if (curlen <> prevlen) then + Inc(s.bl_tree[curlen].fc.Freq); + Inc(s.bl_tree[REP_3_6].fc.Freq); + end + else + if (count <= 10) then + Inc(s.bl_tree[REPZ_3_10].fc.Freq) + else + Inc(s.bl_tree[REPZ_11_138].fc.Freq); + + count := 0; + prevlen := curlen; + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end + else + if (curlen = nextlen) then + begin + max_count := 6; + min_count := 3; + end + else + begin + max_count := 7; + min_count := 4; + end; + end; +end; + +{ =========================================================================== + Send a literal or distance tree in compressed form, using the codes in + bl_tree. } + +{local} +procedure send_tree(var s : deflate_state; + var tree : array of ct_data; { the tree to be scanned } + max_code : int); { and its largest code of non zero frequency } + +var + n : int; { iterates over all tree elements } + prevlen : int; { last emitted length } + curlen : int; { length of current code } + nextlen : int; { length of next code } + count : int; { repeat count of the current code } + max_count : int; { max repeat count } + min_count : int; { min repeat count } +begin + prevlen := -1; + nextlen := tree[0].dl.Len; + count := 0; + max_count := 7; + min_count := 4; + + { tree[max_code+1].dl.Len := -1; } { guard already set } + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end; + + for n := 0 to max_code do + begin + curlen := nextlen; + nextlen := tree[n+1].dl.Len; + Inc(count); + if (count < max_count) and (curlen = nextlen) then + continue + else + if (count < min_count) then + begin + repeat + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(curlen)); + {$ENDIF} + send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len); + Dec(count); + until (count = 0); + end + else + if (curlen <> 0) then + begin + if (curlen <> prevlen) then + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(curlen)); + {$ENDIF} + send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len); + Dec(count); + end; + {$IFDEF DEBUG} + Assert((count >= 3) and (count <= 6), ' 3_6?'); + {$ENDIF} + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REP_3_6)); + {$ENDIF} + send_bits(s, s.bl_tree[REP_3_6].fc.Code, s.bl_tree[REP_3_6].dl.Len); + send_bits(s, count-3, 2); + end + else + if (count <= 10) then + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REPZ_3_10)); + {$ENDIF} + send_bits(s, s.bl_tree[REPZ_3_10].fc.Code, s.bl_tree[REPZ_3_10].dl.Len); + send_bits(s, count-3, 3); + end + else + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REPZ_11_138)); + {$ENDIF} + send_bits(s, s.bl_tree[REPZ_11_138].fc.Code, s.bl_tree[REPZ_11_138].dl.Len); + send_bits(s, count-11, 7); + end; + count := 0; + prevlen := curlen; + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end + else + if (curlen = nextlen) then + begin + max_count := 6; + min_count := 3; + end + else + begin + max_count := 7; + min_count := 4; + end; + end; +end; + +{ =========================================================================== + Construct the Huffman tree for the bit lengths and return the index in + bl_order of the last bit length code to send. } + +{local} +function build_bl_tree(var s : deflate_state) : int; +var + max_blindex : int; { index of last bit length code of non zero freq } +begin + { Determine the bit length frequencies for literal and distance trees } + scan_tree(s, s.dyn_ltree, s.l_desc.max_code); + scan_tree(s, s.dyn_dtree, s.d_desc.max_code); + + { Build the bit length tree: } + build_tree(s, s.bl_desc); + { opt_len now includes the length of the tree representations, except + the lengths of the bit lengths codes and the 5+5+4 bits for the counts. } + + { Determine the number of bit length codes to send. The pkzip format + requires that at least 4 bit length codes be sent. (appnote.txt says + 3 but the actual value used is 4.) } + + for max_blindex := BL_CODES-1 downto 3 do + begin + if (s.bl_tree[bl_order[max_blindex]].dl.Len <> 0) then + break; + end; + { Update opt_len to include the bit length tree and counts } + Inc(s.opt_len, 3*(max_blindex+1) + 5+5+4); + {$ifdef DEBUG} + Tracev(^M'dyn trees: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + + build_bl_tree := max_blindex; +end; + +{ =========================================================================== + Send the header for a block using dynamic Huffman trees: the counts, the + lengths of the bit length codes, the literal tree and the distance tree. + IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. } + +{local} +procedure send_all_trees(var s : deflate_state; + lcodes : int; + dcodes : int; + blcodes : int); { number of codes for each tree } +var + rank : int; { index in bl_order } +begin + {$IFDEF DEBUG} + Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4), + 'not enough codes'); + Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES) + and (blcodes <= BL_CODES), 'too many codes'); + Tracev(^M'bl counts: '); + {$ENDIF} + send_bits(s, lcodes-257, 5); { not +255 as stated in appnote.txt } + send_bits(s, dcodes-1, 5); + send_bits(s, blcodes-4, 4); { not -3 as stated in appnote.txt } + for rank := 0 to blcodes-1 do + begin + {$ifdef DEBUG} + Tracev(^M'bl code '+IntToStr(bl_order[rank])); + {$ENDIF} + send_bits(s, s.bl_tree[bl_order[rank]].dl.Len, 3); + end; + {$ifdef DEBUG} + Tracev(^M'bl tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} + + send_tree(s, s.dyn_ltree, lcodes-1); { literal tree } + {$ifdef DEBUG} + Tracev(^M'lit tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} + + send_tree(s, s.dyn_dtree, dcodes-1); { distance tree } + {$ifdef DEBUG} + Tracev(^M'dist tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} +end; + +{ =========================================================================== + Flush the bit buffer and align the output on a byte boundary } + +{local} +procedure bi_windup(var s : deflate_state); +begin + if (s.bi_valid > 8) then + begin + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + end + else + if (s.bi_valid > 0) then + begin + {put_byte(s, (Byte)s^.bi_buf);} + s.pending_buf^[s.pending] := Byte(s.bi_buf); + Inc(s.pending); + end; + s.bi_buf := 0; + s.bi_valid := 0; +{$ifdef DEBUG} + s.bits_sent := (s.bits_sent+7) and (not 7); +{$endif} +end; + +{ =========================================================================== + Copy a stored block, storing first the length and its + one's complement if requested. } + +{local} +procedure copy_block(var s : deflate_state; + buf : pcharf; { the input data } + len : unsigned; { its length } + header : boolean); { true if block header must be written } +begin + bi_windup(s); { align on byte boundary } + s.last_eob_len := 8; { enough lookahead for inflate } + + if (header) then + begin + {put_short(s, (ush)len);} + s.pending_buf^[s.pending] := uch(ush(len) and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(len) shr 8);; + Inc(s.pending); + {put_short(s, (ush)~len);} + s.pending_buf^[s.pending] := uch(ush(not len) and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(not len) shr 8);; + Inc(s.pending); + +{$ifdef DEBUG} + Inc(s.bits_sent, 2*16); +{$endif} + end; +{$ifdef DEBUG} + Inc(s.bits_sent, ulg(len shl 3)); +{$endif} + while (len <> 0) do + begin + Dec(len); + {put_byte(s, *buf++);} + s.pending_buf^[s.pending] := buf^; + Inc(buf); + Inc(s.pending); + end; +end; + + +{ =========================================================================== + Send a stored block } + +procedure _tr_stored_block(var s : deflate_state; + buf : pcharf; { input block } + stored_len : ulg; { length of input block } + eof : boolean); { true if this is the last block for a file } + +begin + send_bits(s, (STORED_BLOCK shl 1)+ord(eof), 3); { send block type } + s.compressed_len := (s.compressed_len + 3 + 7) and ulg(not Long(7)); + Inc(s.compressed_len, (stored_len + 4) shl 3); + + copy_block(s, buf, unsigned(stored_len), TRUE); { with header } +end; + +{ =========================================================================== + Flush the bit buffer, keeping at most 7 bits in it. } + +{local} +procedure bi_flush(var s : deflate_state); +begin + if (s.bi_valid = 16) then + begin + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s.bi_buf := 0; + s.bi_valid := 0; + end + else + if (s.bi_valid >= 8) then + begin + {put_byte(s, (Byte)s^.bi_buf);} + s.pending_buf^[s.pending] := Byte(s.bi_buf); + Inc(s.pending); + + s.bi_buf := s.bi_buf shr 8; + Dec(s.bi_valid, 8); + end; +end; + + +{ =========================================================================== + Send one empty static block to give enough lookahead for inflate. + This takes 10 bits, of which 7 may remain in the bit buffer. + The current inflate code requires 9 bits of lookahead. If the + last two codes for the previous block (real code plus EOB) were coded + on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode + the last real code. In this case we send two empty static blocks instead + of one. (There are no problems if the previous block is stored or fixed.) + To simplify the code, we assume the worst case of last real code encoded + on one bit only. } + +procedure _tr_align(var s : deflate_state); +begin + send_bits(s, STATIC_TREES shl 1, 3); + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len); + Inc(s.compressed_len, Long(10)); { 3 for block type, 7 for EOB } + bi_flush(s); + { Of the 10 bits for the empty block, we have already sent + (10 - bi_valid) bits. The lookahead for the last real code (before + the EOB of the previous block) was thus at least one plus the length + of the EOB plus what we have just sent of the empty static block. } + if (1 + s.last_eob_len + 10 - s.bi_valid < 9) then + begin + send_bits(s, STATIC_TREES shl 1, 3); + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len); + Inc(s.compressed_len, Long(10)); + bi_flush(s); + end; + s.last_eob_len := 7; +end; + +{ =========================================================================== + Set the data type to ASCII or BINARY, using a crude approximation: + binary if more than 20% of the bytes are <= 6 or >= 128, ascii otherwise. + IN assertion: the fields freq of dyn_ltree are set and the total of all + frequencies does not exceed 64K (to fit in an int on 16 bit machines). } + +{local} +procedure set_data_type(var s : deflate_state); +var + n : int; + ascii_freq : unsigned; + bin_freq : unsigned; +begin + n := 0; + ascii_freq := 0; + bin_freq := 0; + + while (n < 7) do + begin + Inc(bin_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + while (n < 128) do + begin + Inc(ascii_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + while (n < LITERALS) do + begin + Inc(bin_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + if (bin_freq > (ascii_freq shr 2)) then + s.data_type := Byte(Z_BINARY) + else + s.data_type := Byte(Z_ASCII); +end; + +{ =========================================================================== + Send the block data compressed using the given Huffman trees } + +{local} +procedure compress_block(var s : deflate_state; + var ltree : array of ct_data; { literal tree } + var dtree : array of ct_data); { distance tree } +var + dist : unsigned; { distance of matched string } + lc : int; { match length or unmatched char (if dist == 0) } + lx : unsigned; { running index in l_buf } + code : unsigned; { the code to send } + extra : int; { number of extra bits to send } +begin + lx := 0; + if (s.last_lit <> 0) then + repeat + dist := s.d_buf^[lx]; + lc := s.l_buf^[lx]; + Inc(lx); + if (dist = 0) then + begin + { send a literal byte } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(lc)); + Tracecv((lc > 31) and (lc < 128), ' '+char(lc)+' '); + {$ENDIF} + send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len); + end + else + begin + { Here, lc is the match length - MIN_MATCH } + code := _length_code[lc]; + { send the length code } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(code+LITERALS+1)); + {$ENDIF} + send_bits(s, ltree[code+LITERALS+1].fc.Code, ltree[code+LITERALS+1].dl.Len); + extra := extra_lbits[code]; + if (extra <> 0) then + begin + Dec(lc, base_length[code]); + send_bits(s, lc, extra); { send the extra length bits } + end; + Dec(dist); { dist is now the match distance - 1 } + {code := d_code(dist);} + if (dist < 256) then + code := _dist_code[dist] + else + code := _dist_code[256+(dist shr 7)]; + + {$IFDEF DEBUG} + Assert (code < D_CODES, 'bad d_code'); + {$ENDIF} + + { send the distance code } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(code)); + {$ENDIF} + send_bits(s, dtree[code].fc.Code, dtree[code].dl.Len); + extra := extra_dbits[code]; + if (extra <> 0) then + begin + Dec(dist, base_dist[code]); + send_bits(s, dist, extra); { send the extra distance bits } + end; + end; { literal or match pair ? } + + { Check that the overlay between pending_buf and d_buf+l_buf is ok: } + {$IFDEF DEBUG} + Assert(s.pending < s.lit_bufsize + 2*lx, 'pendingBuf overflow'); + {$ENDIF} + until (lx >= s.last_lit); + + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, ltree[END_BLOCK].fc.Code, ltree[END_BLOCK].dl.Len); + s.last_eob_len := ltree[END_BLOCK].dl.Len; +end; + + +{ =========================================================================== + Determine the best encoding for the current block: dynamic trees, static + trees or store, and output the encoded block to the zip file. This function + returns the total compressed length for the file so far. } + +function _tr_flush_block (var s : deflate_state; + buf : pcharf; { input block, or NULL if too old } + stored_len : ulg; { length of input block } + eof : boolean) : ulg; { true if this is the last block for a file } +var + opt_lenb, static_lenb : ulg; { opt_len and static_len in bytes } + max_blindex : int; { index of last bit length code of non zero freq } +begin + max_blindex := 0; + + { Build the Huffman trees unless a stored block is forced } + if (s.level > 0) then + begin + { Check if the file is ascii or binary } + if (s.data_type = Z_UNKNOWN) then + set_data_type(s); + + { Construct the literal and distance trees } + build_tree(s, s.l_desc); + {$ifdef DEBUG} + Tracev(^M'lit data: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + + build_tree(s, s.d_desc); + {$ifdef DEBUG} + Tracev(^M'dist data: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + { At this point, opt_len and static_len are the total bit lengths of + the compressed block data, excluding the tree representations. } + + { Build the bit length tree for the above two trees, and get the index + in bl_order of the last bit length code to send. } + max_blindex := build_bl_tree(s); + + { Determine the best encoding. Compute first the block length in bytes} + opt_lenb := (s.opt_len+3+7) shr 3; + static_lenb := (s.static_len+3+7) shr 3; + + {$ifdef DEBUG} + Tracev(^M'opt %lu(%lu) stat %lu(%lu) stored %lu lit %u '+ + '{opt_lenb, s.opt_len, static_lenb, s.static_len, stored_len,'+ + 's.last_lit}'); + {$ENDIF} + + if (static_lenb <= opt_lenb) then + opt_lenb := static_lenb; + + end + else + begin + {$IFDEF DEBUG} + Assert(buf <> pcharf(NIL), 'lost buf'); + {$ENDIF} + static_lenb := stored_len + 5; + opt_lenb := static_lenb; { force a stored block } + end; + + { If compression failed and this is the first and last block, + and if the .zip file can be seeked (to rewrite the local header), + the whole file is transformed into a stored file: } + +{$ifdef STORED_FILE_OK} +{$ifdef FORCE_STORED_FILE} + if eof and (s.compressed_len = Long(0)) then + begin { force stored file } +{$else} + if (stored_len <= opt_lenb) and eof and (s.compressed_len=Long(0)) + and seekable()) do + begin +{$endif} + { Since LIT_BUFSIZE <= 2*WSIZE, the input data must be there: } + if (buf = pcharf(0)) then + error ('block vanished'); + + copy_block(buf, unsigned(stored_len), 0); { without header } + s.compressed_len := stored_len shl 3; + s.method := STORED; + end + else +{$endif} { STORED_FILE_OK } + +{$ifdef FORCE_STORED} + if (buf <> pchar(0)) then + begin { force stored block } +{$else} + if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then + begin + { 4: two words for the lengths } +{$endif} + { The test buf <> NULL is only necessary if LIT_BUFSIZE > WSIZE. + Otherwise we can't have processed more than WSIZE input bytes since + the last block flush, because compression would have been + successful. If LIT_BUFSIZE <= WSIZE, it is never too late to + transform a block into a stored block. } + + _tr_stored_block(s, buf, stored_len, eof); + +{$ifdef FORCE_STATIC} + end + else + if (static_lenb >= 0) then + begin { force static trees } +{$else} + end + else + if (static_lenb = opt_lenb) then + begin +{$endif} + send_bits(s, (STATIC_TREES shl 1)+ord(eof), 3); + compress_block(s, static_ltree, static_dtree); + Inc(s.compressed_len, 3 + s.static_len); + end + else + begin + send_bits(s, (DYN_TREES shl 1)+ord(eof), 3); + send_all_trees(s, s.l_desc.max_code+1, s.d_desc.max_code+1, + max_blindex+1); + compress_block(s, s.dyn_ltree, s.dyn_dtree); + Inc(s.compressed_len, 3 + s.opt_len); + end; + {$ifdef DEBUG} + Assert (s.compressed_len = s.bits_sent, 'bad compressed size'); + {$ENDIF} + init_block(s); + + if (eof) then + begin + bi_windup(s); + Inc(s.compressed_len, 7); { align on byte boundary } + end; + {$ifdef DEBUG} + Tracev(#13'comprlen %lu(%lu) {s.compressed_len shr 3,'+ + 's.compressed_len-7*ord(eof)}'); + {$ENDIF} + + _tr_flush_block := s.compressed_len shr 3; +end; + + +{ =========================================================================== + Save the match info and tally the frequency counts. Return true if + the current block must be flushed. } + +function _tr_tally (var s : deflate_state; + dist : unsigned; { distance of matched string } + lc : unsigned) : boolean; { match length-MIN_MATCH or unmatched char (if dist=0) } +var + {$IFDEF DEBUG} + MAX_DIST : ush; + {$ENDIF} + code : ush; +{$ifdef TRUNCATE_BLOCK} +var + out_length : ulg; + in_length : ulg; + dcode : int; +{$endif} +begin + s.d_buf^[s.last_lit] := ush(dist); + s.l_buf^[s.last_lit] := uch(lc); + Inc(s.last_lit); + if (dist = 0) then + begin + { lc is the unmatched char } + Inc(s.dyn_ltree[lc].fc.Freq); + end + else + begin + Inc(s.matches); + { Here, lc is the match length - MIN_MATCH } + Dec(dist); { dist := match distance - 1 } + + {macro d_code(dist)} + if (dist) < 256 then + code := _dist_code[dist] + else + code := _dist_code[256+(dist shr 7)]; + {$IFDEF DEBUG} +{macro MAX_DIST(s) <=> ((s)^.w_size-MIN_LOOKAHEAD) + In order to simplify the code, particularly on 16 bit machines, match + distances are limited to MAX_DIST instead of WSIZE. } + MAX_DIST := ush(s.w_size-MIN_LOOKAHEAD); + Assert((dist < ush(MAX_DIST)) and + (ush(lc) <= ush(MAX_MATCH-MIN_MATCH)) and + (ush(code) < ush(D_CODES)), '_tr_tally: bad match'); + {$ENDIF} + Inc(s.dyn_ltree[_length_code[lc]+LITERALS+1].fc.Freq); + {s.dyn_dtree[d_code(dist)].Freq++;} + Inc(s.dyn_dtree[code].fc.Freq); + end; + +{$ifdef TRUNCATE_BLOCK} + { Try to guess if it is profitable to stop the current block here } + if (s.last_lit and $1fff = 0) and (s.level > 2) then + begin + { Compute an upper bound for the compressed length } + out_length := ulg(s.last_lit)*Long(8); + in_length := ulg(long(s.strstart) - s.block_start); + for dcode := 0 to D_CODES-1 do + begin + Inc(out_length, ulg(s.dyn_dtree[dcode].fc.Freq * + (Long(5)+extra_dbits[dcode])) ); + end; + out_length := out_length shr 3; + {$ifdef DEBUG} + Tracev(^M'last_lit %u, in %ld, out ~%ld(%ld%%) '); + { s.last_lit, in_length, out_length, + Long(100) - out_length*Long(100) div in_length)); } + {$ENDIF} + if (s.matches < s.last_lit div 2) and (out_length < in_length div 2) then + begin + _tr_tally := TRUE; + exit; + end; + end; +{$endif} + _tr_tally := (s.last_lit = s.lit_bufsize-1); + { We avoid equality with lit_bufsize because of wraparound at 64K + on 16 bit machines and because stored blocks are restricted to + 64K-1 bytes. } +end; + +end. \ No newline at end of file diff --git a/delphionly/zutil.pas b/delphionly/zutil.pas new file mode 100755 index 0000000..cd44dd2 --- /dev/null +++ b/delphionly/zutil.pas @@ -0,0 +1,546 @@ +Unit ZUtil; + +{ + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +{ Type declarations } + +type + {Byte = usigned char; 8 bits} + Bytef = byte; + charf = byte; + +{$IFDEF FPC} + int = longint; +{$ELSE} + int = integer; +{$ENDIF} + + intf = int; +{$IFDEF MSDOS} + uInt = Word; +{$ELSE} + {$IFDEF FPC} + uInt = longint; { 16 bits or more } + {$INFO Cardinal} + {$ELSE} + uInt = cardinal; { 16 bits or more } + {$ENDIF} +{$ENDIF} + uIntf = uInt; + + Long = longint; +{$ifdef Delphi5} + uLong = Cardinal; +{$else} +// uLong = LongInt; { 32 bits or more } + uLong = LongInt{LongWord}; { DelphiGzip: LongInt is Signed, longword not } +{$endif} + uLongf = uLong; + + voidp = pointer; + voidpf = voidp; + pBytef = ^Bytef; + pIntf = ^intf; + puIntf = ^uIntf; + puLong = ^uLongf; + + ptr2int = uInt; +{ a pointer to integer casting is used to do pointer arithmetic. + ptr2int must be an integer type and sizeof(ptr2int) must be less + than sizeof(pointer) - Nomssi } + +const + {$IFDEF MAXSEG_64K} + MaxMemBlock = $FFFF; + {$ELSE} + MaxMemBlock = MaxInt; + {$ENDIF} + +type + zByteArray = array[0..(MaxMemBlock div SizeOf(Bytef))-1] of Bytef; + pzByteArray = ^zByteArray; +type + zIntfArray = array[0..(MaxMemBlock div SizeOf(Intf))-1] of Intf; + pzIntfArray = ^zIntfArray; +type + zuIntArray = array[0..(MaxMemBlock div SizeOf(uInt))-1] of uInt; + PuIntArray = ^zuIntArray; + +{ Type declarations - only for deflate } + +type + uch = Byte; + uchf = uch; { FAR } + ush = Word; + ushf = ush; + ulg = LongInt; + + unsigned = uInt; + + pcharf = ^charf; + puchf = ^uchf; + pushf = ^ushf; + +type + zuchfArray = zByteArray; + puchfArray = ^zuchfArray; +type + zushfArray = array[0..(MaxMemBlock div SizeOf(ushf))-1] of ushf; + pushfArray = ^zushfArray; + +procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt); +function zmemcmp(s1p, s2p : pBytef; len : uInt) : int; +procedure zmemzero(destp : pBytef; len : uInt); +procedure zcfree(opaque : voidpf; ptr : voidpf); +function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf; + +implementation + +{$ifdef ver80} + {$define Delphi16} +{$endif} +{$ifdef ver70} + {$define HugeMem} +{$endif} +{$ifdef ver60} + {$define HugeMem} +{$endif} + +{$IFDEF CALLDOS} +uses + WinDos; +{$ENDIF} +{$IFDEF Delphi16} +uses + WinTypes, + WinProcs; +{$ENDIF} +{$IFNDEF FPC} + {$IFDEF DPMI} + uses + WinAPI; + {$ENDIF} +{$ENDIF} + +{$IFDEF CALLDOS} +{ reduce your application memory footprint with $M before using this } +function dosAlloc (Size : Longint) : Pointer; +var + regs: TRegisters; +begin + regs.bx := (Size + 15) div 16; { number of 16-bytes-paragraphs } + regs.ah := $48; { Allocate memory block } + msdos(regs); + if regs.Flags and FCarry <> 0 then + DosAlloc := NIL + else + DosAlloc := Ptr(regs.ax, 0); +end; + + +function dosFree(P : pointer) : boolean; +var + regs: TRegisters; +begin + dosFree := FALSE; + regs.bx := Seg(P^); { segment } + if Ofs(P) <> 0 then + exit; + regs.ah := $49; { Free memory block } + msdos(regs); + dosFree := (regs.Flags and FCarry = 0); +end; +{$ENDIF} + +type + LH = record + L, H : word; + end; + +{$IFDEF HugeMem} + {$define HEAP_LIST} +{$endif} + +{$IFDEF HEAP_LIST} {--- to avoid Mark and Release --- } +const + MaxAllocEntries = 50; +type + TMemRec = record + orgvalue, + value : pointer; + size: longint; + end; +const + allocatedCount : 0..MaxAllocEntries = 0; +var + allocatedList : array[0..MaxAllocEntries-1] of TMemRec; + + function NewAllocation(ptr0, ptr : pointer; memsize : longint) : boolean; + begin + if (allocatedCount < MaxAllocEntries) and (ptr0 <> NIL) then + begin + with allocatedList[allocatedCount] do + begin + orgvalue := ptr0; + value := ptr; + size := memsize; + end; + Inc(allocatedCount); { we don't check for duplicate } + NewAllocation := TRUE; + end + else + NewAllocation := FALSE; + end; +{$ENDIF} + +{$IFDEF HugeMem} + +{ The code below is extremely version specific to the TP 6/7 heap manager!!} +type + PFreeRec = ^TFreeRec; + TFreeRec = record + next: PFreeRec; + size: Pointer; + end; +type + HugePtr = voidpf; + + + procedure IncPtr(var p:pointer;count:word); + { Increments pointer } + begin + inc(LH(p).L,count); + if LH(p).L < count then + inc(LH(p).H,SelectorInc); { $1000 } + end; + + procedure DecPtr(var p:pointer;count:word); + { decrements pointer } + begin + if count > LH(p).L then + dec(LH(p).H,SelectorInc); + dec(LH(p).L,Count); + end; + + procedure IncPtrLong(var p:pointer;count:longint); + { Increments pointer; assumes count > 0 } + begin + inc(LH(p).H,SelectorInc*LH(count).H); + inc(LH(p).L,LH(Count).L); + if LH(p).L < LH(count).L then + inc(LH(p).H,SelectorInc); + end; + + procedure DecPtrLong(var p:pointer;count:longint); + { Decrements pointer; assumes count > 0 } + begin + if LH(count).L > LH(p).L then + dec(LH(p).H,SelectorInc); + dec(LH(p).L,LH(Count).L); + dec(LH(p).H,SelectorInc*LH(Count).H); + end; + { The next section is for real mode only } + +function Normalized(p : pointer) : pointer; +var + count : word; +begin + count := LH(p).L and $FFF0; + Normalized := Ptr(LH(p).H + (count shr 4), LH(p).L and $F); +end; + +procedure FreeHuge(var p:HugePtr; size : longint); +const + blocksize = $FFF0; +var + block : word; +begin + while size > 0 do + begin + { block := minimum(size, blocksize); } + if size > blocksize then + block := blocksize + else + block := size; + + dec(size,block); + freemem(p,block); + IncPtr(p,block); { we may get ptr($xxxx, $fff8) and 31 bytes left } + p := Normalized(p); { to free, so we must normalize } + end; +end; + +function FreeMemHuge(ptr : pointer) : boolean; +var + i : integer; { -1..MaxAllocEntries } +begin + FreeMemHuge := FALSE; + i := allocatedCount - 1; + while (i >= 0) do + begin + if (ptr = allocatedList[i].value) then + begin + with allocatedList[i] do + FreeHuge(orgvalue, size); + + Move(allocatedList[i+1], allocatedList[i], + SizeOf(TMemRec)*(allocatedCount - 1 - i)); + Dec(allocatedCount); + FreeMemHuge := TRUE; + break; + end; + Dec(i); + end; +end; + +procedure GetMemHuge(var p:HugePtr;memsize:Longint); +const + blocksize = $FFF0; +var + size : longint; + prev,free : PFreeRec; + save,temp : pointer; + block : word; +begin + p := NIL; + { Handle the easy cases first } + if memsize > maxavail then + exit + else + if memsize <= blocksize then + begin + getmem(p, memsize); + if not NewAllocation(p, p, memsize) then + begin + FreeMem(p, memsize); + p := NIL; + end; + end + else + begin + size := memsize + 15; + + { Find the block that has enough space } + prev := PFreeRec(@freeList); + free := prev^.next; + while (free <> heapptr) and (ptr2int(free^.size) < size) do + begin + prev := free; + free := prev^.next; + end; + + { Now free points to a region with enough space; make it the first one and + multiple allocations will be contiguous. } + + save := freelist; + freelist := free; + { In TP 6, this works; check against other heap managers } + while size > 0 do + begin + { block := minimum(size, blocksize); } + if size > blocksize then + block := blocksize + else + block := size; + dec(size,block); + getmem(temp,block); + end; + + { We've got what we want now; just sort things out and restore the + free list to normal } + + p := free; + if prev^.next <> freelist then + begin + prev^.next := freelist; + freelist := save; + end; + + if (p <> NIL) then + begin + { return pointer with 0 offset } + temp := p; + if Ofs(p^)<>0 Then + p := Ptr(Seg(p^)+1,0); { hack } + if not NewAllocation(temp, p, memsize + 15) then + begin + FreeHuge(temp, size); + p := NIL; + end; + end; + + end; +end; + +{$ENDIF} + +procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt); +begin + Move(sourcep^, destp^, len); +end; + +function zmemcmp(s1p, s2p : pBytef; len : uInt) : int; +var + j : uInt; + source, + dest : pBytef; +begin + source := s1p; + dest := s2p; + for j := 0 to pred(len) do + begin + if (source^ <> dest^) then + begin + zmemcmp := 2*Ord(source^ > dest^)-1; + exit; + end; + Inc(source); + Inc(dest); + end; + zmemcmp := 0; +end; + +procedure zmemzero(destp : pBytef; len : uInt); +begin + FillChar(destp^, len, 0); +end; + +procedure zcfree(opaque : voidpf; ptr : voidpf); +{$ifdef Delphi16} +var + Handle : THandle; +{$endif} +{$IFDEF FPC} +var + memsize : uint; +{$ENDIF} +begin + {$IFDEF DPMI} + {h :=} GlobalFreePtr(ptr); + {$ELSE} + {$IFDEF CALL_DOS} + dosFree(ptr); + {$ELSE} + {$ifdef HugeMem} + FreeMemHuge(ptr); + {$else} + {$ifdef Delphi16} + Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) } + GlobalUnLock(Handle); + GlobalFree(Handle); + {$else} + {$IFDEF FPC} + Dec(puIntf(ptr)); + memsize := puIntf(ptr)^; + FreeMem(ptr, memsize+SizeOf(uInt)); + {$ELSE} + FreeMem(ptr); { Delphi 2,3,4 } + {$ENDIF} + {$endif} + {$endif} + {$ENDIF} + {$ENDIF} +end; + +function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf; +var + p : voidpf; + memsize : uLong; +{$ifdef Delphi16} + handle : THandle; +{$endif} +begin + memsize := uLong(items) * size; + {$IFDEF DPMI} + p := GlobalAllocPtr(gmem_moveable, memsize); + {$ELSE} + {$IFDEF CALLDOS} + p := dosAlloc(memsize); + {$ELSE} + {$ifdef HugeMem} + GetMemHuge(p, memsize); + {$else} + {$ifdef Delphi16} + Handle := GlobalAlloc(HeapAllocFlags, memsize); + p := GlobalLock(Handle); + {$else} + {$IFDEF FPC} + GetMem(p, memsize+SizeOf(uInt)); + puIntf(p)^:= memsize; + Inc(puIntf(p)); + {$ELSE} + GetMem(p, memsize); { Delphi: p := AllocMem(memsize); } + {$ENDIF} + {$endif} + {$endif} + {$ENDIF} + {$ENDIF} + zcalloc := p; +end; + +{$WARNINGS OFF} +end. + +{ edited from a SWAG posting: + +In Turbo Pascal 6, the heap is the memory allocated when using the Procedures 'New' and +'GetMem'. The heap starts at the address location pointed to by 'Heaporg' and +grows to higher addresses as more memory is allocated. The top of the heap, +the first address of allocatable memory space above the allocated memory +space, is pointed to by 'HeapPtr'. + +Memory is deallocated by the Procedures 'Dispose' and 'FreeMem'. As memory +blocks are deallocated more memory becomes available, but..... When a block +of memory, which is not the top-most block in the heap is deallocated, a gap +in the heap will appear. to keep track of these gaps Turbo Pascal maintains +a so called free list. + +The Function 'MaxAvail' holds the size of the largest contiguous free block +_in_ the heap. The Function 'MemAvail' holds the sum of all free blocks in +the heap. + +TP6.0 keeps track of the free blocks by writing a 'free list Record' to the +first eight Bytes of the freed memory block! A (TP6.0) free-list Record +contains two four Byte Pointers of which the first one points to the next +free memory block, the second Pointer is not a Real Pointer but contains the +size of the memory block. + +Summary + +TP6.0 maintains a linked list with block sizes and Pointers to the _next_ +free block. An extra heap Variable 'Heapend' designate the end of the heap. +When 'HeapPtr' and 'FreeList' have the same value, the free list is empty. + + + TP6.0 Heapend + ÚÄÄÄÄÄÄÄÄÄ¿ <ÄÄÄÄ + ³ ³ + ³ ³ + ³ ³ + ³ ³ + ³ ³ + ³ ³ + ³ ³ + ³ ³ HeapPtr + ÚÄ>ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ + ³ ³ ³ + ³ ÃÄÄÄÄÄÄÄÄÄ´ + ÀÄij Free ³ + ÚÄ>ÃÄÄÄÄÄÄÄÄÄ´ + ³ ³ ³ + ³ ÃÄÄÄÄÄÄÄÄÄ´ + ÀÄij Free ³ FreeList + ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ + ³ ³ Heaporg + ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ + + +} +{$WARNINGS ON} diff --git a/drop.patch b/drop.patch new file mode 100755 index 0000000..b394fec --- /dev/null +++ b/drop.patch @@ -0,0 +1,75 @@ +diff -uwNr --exclude=.svn --exclude=Makefile --exclude=Makefile.fpc --exclude=Makefile.compiled --exclude='*.rst' --exclude='*.po' lazarus/lcl/interfaces/carbon/carbonobject.inc lazarus.w/lcl/interfaces/carbon/carbonobject.inc +--- lazarus/lcl/interfaces/carbon/carbonobject.inc 2013-11-16 10:59:07.000000000 +0000 +++ lazarus.w/lcl/interfaces/carbon/carbonobject.inc 2013-11-16 22:03:34.000000000 +0000 +@@ -449,6 +449,62 @@ + end; + + {------------------------------------------------------------------------------ + Name: CarbonApp_DragReceive + Handles dropping files on application + ------------------------------------------------------------------------------} +function CarbonApp_DragReceive(theWindow: WindowRef; handlerRefCon: UnivPtr; theDrag: DragRef): OSErr; {$IFDEF darwin}mwpascal;{$ENDIF} +var + theItemRef: DragItemRef; + theFlavorData: HFSFlavor; + theDataSize: Size; + theFilename: pchar; + theFileRef: FSRef; + numItems: UInt16; + Files: array of string; + itemNum: UInt16; +begin + SetLength(Files, 0); + + numItems := 0; + + if CountDragItems(theDrag, numItems) <> noErr then exit; + + if numItems > 0 then + for itemNum := 1 to numItems do + begin + if GetDragItemReferenceNumber(theDrag, itemNum, theItemRef) <> noErr then continue; + theDataSize := sizeof(theFlavorData); + if GetFlavorData(theDrag, theItemRef, kDragFlavorTypeHFS, @theFlavorData, theDataSize, 0) <> noErr then continue; + + FSpMakeFSRef(theFlavorData.fileSpec, theFileRef); + + theFilename := stralloc(1024); //PATH_MAX = 1024 + + FSRefMakePath(theFileRef, theFilename, StrBufSize(theFilename)); + + try + SetLength(Files, Length(Files) + 1); + Files[High(Files)] := theFilename; + finally + StrDispose(theFilename); + end; + end; + + if Length(Files) > 0 then + begin + if Application <> nil then + begin + if Application.MainForm <> nil then + Application.MainForm.IntfDropFiles(Files); + + Application.IntfDropFiles(Files); + end; + end; + + Result := noErr; +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_Quit + Handles application quit + ------------------------------------------------------------------------------} +@@ -1213,6 +1269,8 @@ + InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_LazWake), + 1, @TmpSpec, nil, @FAEventHandlerRef[5]); + + InstallReceiveHandler(@CarbonApp_DragReceive, nil, nil); + + FOpenEventHandlerUPP := NewAEEventHandlerUPP(AEEventHandlerProcPtr(@CarbonApp_Open)); + FQuitEventHandlerUPP := NewAEEventHandlerUPP(AEEventHandlerProcPtr(@CarbonApp_Quit)); + OSError( diff --git a/drop_patch.txt b/drop_patch.txt new file mode 100755 index 0000000..56d4705 --- /dev/null +++ b/drop_patch.txt @@ -0,0 +1,1620 @@ +{%MainUnit carbonint.pas} + +{****************************************************************************** + All utility method implementations of the TCarbonWidgetSet class are here. + + + ****************************************************************************** + Implementation + ****************************************************************************** + + ***************************************************************************** + This file is part of the Lazarus Component Library (LCL) + + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** +} + +{ TCarbonWidgetSet } + +{ + This event handler will fix the focus indication in AXApplication for + standard controls where it gets it wrong. Necessary to support accessibility + for TMemo / TEdit for example +} +function AppAccessibilityEventHandler(inHandlerCallRef: EventHandlerCallRef; + inEvent: EventRef; + {%H-}inUserData: Pointer): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +var + lAXRole, lInputStr: CFStringRef; + lInputAXObject: AXUIElementRef; + EventKind: UInt32; + lInputPasStr: string; + lElement, lElement2: AXUIElementRef; + lAXArray: CFMutableArrayRef; +begin + Result := CallNextEventHandler(inHandlerCallRef, inEvent); + + GetEventParameter(inEvent, kEventParamAccessibleObject, + typeCFTypeRef, nil, SizeOf(AXUIElementRef), nil, @lInputAXObject); + + EventKind := GetEventKind(inEvent); + case EventKind of + kEventAccessibleGetNamedAttribute: + begin + GetEventParameter(inEvent, kEventParamAccessibleAttributeName, + typeCFStringRef, nil, SizeOf(CFStringRef), nil, @lInputStr); + + lInputPasStr := CFStringToStr(lInputStr); + + if lInputPasStr = 'AXFocusedUIElement' then + begin + // First interfere only if the element returned is in our black list + // for example: memo border + GetEventParameter(inEvent, kEventParamAccessibleAttributeValue, + typeCFTypeRef, nil, SizeOf(AXUIElementRef), nil, @lElement); + + AXUIElementCopyAttributeValue(lElement, CFSTR('AXRoleDescription'), lAXRole{%H-}); + lInputPasStr := CFStringToStr(lAXRole); + if lInputPasStr = 'memoborder' then + begin + AXUIElementCopyAttributeValue(lElement, CFSTR('AXChildren'), lAXArray{%H-}); + lElement2 := CFArrayGetValueAtIndex(lAXArray, 0); + SetEventParameter(inEvent, kEventParamAccessibleAttributeValue, typeCFTypeRef, + SizeOf(AXUIElementRef), @lElement2); + + Result := noErr; + Exit; + end; + end; + end; // kEventAccessibleGetNamedAttribute + end; // case EventKind of +end; + +{ +The only drawback to making your own event loop dispatching calls in the main +application thread is that you won't get the standard application event handler +installed. Specifically, the RunApplicationEventLoop function installs handlers +to do the following: +* Allow clicks in the menu bar to begin menu tracking +* Dispatch Apple events by calling AEProcessAppleEvent +* Respond to quit Apple events by quitting RunApplicationEventLoop. + +One way to work around this limitation is by creating a dummy custom event +handler. When you are ready to process events, create the dummy event yourself, +post it to the queue and then call RunApplicationEventLoop (to install the +standard application event handler). The dummy event handler can then process +the events manually. For an example of using this method, see Technical +Q&A 1061 in Developer Documentation Technical Q&As. + +} + +// From: Technical Q&A 1061 in Developer Documentation Technical Q&As +// MWE: modified to fit the LCL, but the basic idea comes from Q&A 1061 + +function QuitEventHandler(inHandlerCallRef: EventHandlerCallRef; + inEvent: EventRef; + {%H-}inUserData: Pointer): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} + // This event handler is used to override the kEventClassApplication + // kEventAppQuit event while inside our event loop (EventLoopEventHandler). + // It simply calls through to the next handler and, if that handler returns + // noErr (indicating that the application is doing to quit), it sets + // a Boolean to tell our event loop to quit as well. + // MWE: in our case, terminates the app also +begin + Result := CallNextEventHandler(inHandlerCallRef, inEvent); + if Result <> noErr then Exit; + + if (Widgetset <> nil) and TCarbonWidgetSet(Widgetset).FTerminating then Exit; + + TCarbonWidgetSet(Widgetset).FTerminating := True; + + if Application = nil then Exit; + Application.Terminate; +end; + + +function EventLoopEventHandler({%H-}inHandlerCallRef: EventHandlerCallRef; + {%H-}inEvent: EventRef; + inUserData: Pointer): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} + // This code contains the standard Carbon event dispatch loop, + // as per "Inside Macintosh: Handling Carbon Events", Listing 3-10, + // except: + // + // o this loop supports yielding to cooperative threads based on the + // application maintaining the gNumberOfRunningThreads global + // variable, and + // + // o it also works around a problem with the Inside Macintosh code + // which unexpectedly quits when run on traditional Mac OS 9. + // + // See RunApplicationEventLoopWithCooperativeThreadSupport for + // an explanation of why this is inside a Carbon event handler. + // + // The code in Inside Mac has a problem in that it quits the + // event loop when ReceiveNextEvent returns an error. This is + // wrong because ReceiveNextEvent can return eventLoopQuitErr + // when you call WakeUpProcess on traditional Mac OS. So, rather + // than relying on an error from ReceiveNextEvent, this routine tracks + // whether the application is really quitting by installing a + // customer handler for the kEventClassApplication/kEventAppQuit + // Carbon event. All the custom handler does is call through + // to the previous handler and, if it returns noErr (which indicates + // the application is quitting, it sets quitNow so that our event + // loop quits. + // + // Note that this approach continues to support QuitApplicationEventLoop, + // which is a simple wrapper that just posts a kEventClassApplication/ + // kEventAppQuit event to the event loop. + +var + QuitUPP: EventHandlerUPP; + QuitHandler: EventHandlerRef; + TmpSpec: EventTypeSpec; + Loop: TApplicationMainLoop = nil; +begin + // Get our TApplicationMainLoop + Result := noErr; + if (not Assigned(inUserData)) or TCarbonWidgetSet(inUserData).FUserTerm then Exit; + Loop := TCarbonWidgetSet(inUserData).FAppLoop; + if not Assigned(Loop) then Exit; + + // Install our override on the kEventClassApplication, kEventAppQuit event. + QuitUPP := NewEventHandlerUPP(EventHandlerProcPtr(Pointer(@QuitEventHandler))); + //todo: raise exception ?? + if QuitUPP = nil then Exit; + + try + TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppQuit); + if not InstallApplicationEventHandler(QuitUPP, 1, @TmpSpec, nil, @QuitHandler) then Exit; + try + // Run our event loop until quitNow is set. + Loop; + finally + MacOSAll.RemoveEventHandler(QuitHandler); + end; + finally + DisposeEventHandlerUPP(QuitUPP); + end; + +(* + theTarget := GetEventDispatcherTarget; + repeat + if MNumberOfRunningThreads = 0 + then timeToWaitForEvent := kEventDurationForever + else timeToWaitForEvent := kEventDurationNoWait; + + Result := ReceiveNextEvent(0, nil, timeToWaitForEvent, true, theEvent); + if Result = noErr + then begin + SendEventToEventTarget(theEvent, theTarget); + ReleaseEvent(theEvent); + end; + if MNumberOfRunningThreads > 0 + then YieldToAnyThread; + until quitNow; +*) +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_CommandProcess + Handles main menu and context menus commands + ------------------------------------------------------------------------------} +function CarbonApp_CommandProcess(ANextHandler: EventHandlerCallRef; + AEvent: EventRef; + {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +var + Command: HICommandExtended; + CarbonMenu: TCarbonMenu; + Msg: TLMessage; + S: LongWord; + AllowMenu: Boolean; + Focused: HWND; + HotChar: Char; +const SName = 'CarbonApp_CommandProcess'; +begin + {$IFDEF VerboseAppEvent} + DebugLn('CarbonApp_CommandProcess'); + {$ENDIF} + + if not OSError( + GetEventParameter(AEvent, kEventParamDirectObject, + typeHICommand, nil, SizeOf(HICommand), nil, @Command), + SName, 'GetEventParameter') then + begin + {$IFDEF VerboseMenu} + DebugLn('CarbonApp_CommandProcess MenuRef: ' + DbgS(Command.menuRef) + + ' Item: ' + DbgS(Command.menuItemIndex) + ' CommandID: ' + DbgS(Command.commandID) + + ' Attrs: ' + DbgS(Command.attributes)); + {$ENDIF} + + // check command and send "click" message to menu item + if (Command.commandID = MENU_FOURCC) and + (Command.attributes and kHICommandFromMenu > 0) and + (Command.menuRef <> nil) then + begin + if not OSError(GetMenuItemProperty(Command.menuRef, Command.menuItemIndex, + LAZARUS_FOURCC, WIDGETINFO_FOURCC, SizeOf(TCarbonMenu), S{%H-}, @CarbonMenu), + SName, 'GetMenuItemProperty') then + begin + {$IFDEF VerboseMenu} + DebugLn('CarbonApp_CommandProcess CarbonMenu: ' + DbgS(CarbonMenu)); + {$ENDIF} + if CarbonMenu <> nil then + begin + Hotchar:=CarbonMenu.GetShortCutKey; + { CommandProcess is fired before a keyboard event } + { we must check if the control has default system handlers on the hot-key used } + { if so, CommandProcess is not processed, and the key values event are sent } + { to the control by the system. } + { } + { Another possible solution of the problem, is to Post another custom event } + { to the loop, and report LCL about Menu pressed after the event arrives, } + { though it might seem, like interface is lagging } + if (CarbonMenu.Parent.Dismissed<>kHIMenuDismissedBySelection) and (HotChar<>#0) then + begin + AllowMenu := True; + Focused:=GetFocus; + if (Focused<>0) and (TObject(Focused) is TCarbonControl) then + begin + TCarbonControl(Focused).AllowMenuProcess(HotChar, GetCarbonShiftState, AllowMenu); + if not AllowMenu then + begin + Result:=eventNotHandledErr; + CarbonMenu.Parent.Dismissed:=0; + Exit; + end; + end; + end; + + if CarbonMenu.Parent.Dismissed=kHIMenuDismissedBySelection then begin + FillChar(Msg{%H-}, SizeOf(Msg), 0); + Msg.msg := LM_ACTIVATE; + CarbonMenu.LCLMenuItem.Dispatch(Msg); + if assigned(CarbonMenu.Parent) then // if parent not closed + CarbonMenu.Parent.Dismissed:=0; + Result := noErr; + Exit; + end else + Result:=CallNextEventHandler(ANextHandler, AEvent); + + end; + end; + end; + end; + + Result := CallNextEventHandler(ANextHandler, AEvent); +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_Shown + Handles application show + ------------------------------------------------------------------------------} +function CarbonApp_Shown(ANextHandler: EventHandlerCallRef; + AEvent: EventRef; + {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +begin + {$IFDEF VerboseAppEvent} + DebugLn('CarbonApp_Shown'); + {$ENDIF} + + Result := CallNextEventHandler(ANextHandler, AEvent); + + Application.IntfAppRestore; +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_Hidden + Handles application hide + ------------------------------------------------------------------------------} +function CarbonApp_Hidden(ANextHandler: EventHandlerCallRef; + AEvent: EventRef; + {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +begin + {$IFDEF VerboseAppEvent} + DebugLn('CarbonApp_Hidden'); + {$ENDIF} + + Result := CallNextEventHandler(ANextHandler, AEvent); + + Application.IntfAppMinimize; +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_Deactivated + Handles application deactivation + ------------------------------------------------------------------------------} +function CarbonApp_Deactivated(ANextHandler: EventHandlerCallRef; + AEvent: EventRef; + {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +begin + {$IFDEF VerboseAppEvent} + DebugLn('CarbonApp_Deactivate'); + {$ENDIF} + + Result := CallNextEventHandler(ANextHandler, AEvent); + + Application.IntfAppDeactivate; +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_Activated + Handles application activation + ------------------------------------------------------------------------------} +function CarbonApp_Activated(ANextHandler: EventHandlerCallRef; + AEvent: EventRef; + {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +begin + {$IFDEF VerboseAppEvent} + DebugLn('CarbonApp_Activate'); + {$ENDIF} + + Result := CallNextEventHandler(ANextHandler, AEvent); + + Application.IntfAppActivate; +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_Activated + Handles application activation + ------------------------------------------------------------------------------} +function CarbonApp_LazWake(ANextHandler: EventHandlerCallRef; + AEvent: EventRef; + {%H-}AWidget: TCarbonWidget): OSStatus; {$IFDEF darwin}mwpascal;{$ENDIF} +begin + {$IFDEF VerboseAppEvent} + DebugLn('CarbonApp_LazWake'); + {$ENDIF} + + Result := CallNextEventHandler(ANextHandler, AEvent); + + if IsMultiThread then + begin + // a thread is waiting -> synchronize + CheckSynchronize; + end; +end; + + +{------------------------------------------------------------------------------ + Name: CarbonApp_Open + Handles application open + ------------------------------------------------------------------------------} +function CarbonApp_Open(var AEvent: AppleEvent; var {%H-}Reply: AppleEvent; + {%H-}Data: SInt32): OSErr; {$IFDEF darwin}mwpascal;{$ENDIF} +var + DocList: AEDescList; + FileCount: Integer; + FileIdx: Integer; + Keyword: AEKeyword; + FileDesc: AEDesc; + FileRef: FSRef; + FileURL: CFURLRef; + FileCFStr: CFStringRef; + Files: Array of String; +const + SName = 'OpenDocEventHandler'; +begin + {$IFDEF VerboseAppEvent} + DebugLn('CarbonApp_Open'); + {$ENDIF} + + if OSError(AEGetParamDesc(AEvent, keyDirectObject, typeAEList, DocList{%H-}), + SName, 'AEGetParamDesc') then Exit; + + try + if OSError(AECountItems(DocList, FileCount{%H-}), SName, 'AECountItems') then Exit; + + + SetLength(Files, 0); + + for FileIdx := 1 to FileCount do + begin + if OSError(AEGetNthDesc(DocList, FileIdx, typeFSRef, @Keyword, FileDesc{%H-}), + SName, 'AEGetNthDesc') then Continue; + + if OSError(AEGetDescData(FileDesc, @FileRef, SizeOf(FSRef)), + SName, 'AEGetDescData') then Continue; + + if OSError(AEDisposeDesc(FileDesc), + SName, 'AEDisposeDesc') then Continue; + + FileURL := CFURLCreateFromFSRef(kCFAllocatorDefault, FileRef); + FileCFStr := CFURLCopyFileSystemPath(FileURL, kCFURLPOSIXPathStyle); + try + SetLength(Files, Length(Files) + 1); + Files[High(Files)] := CFStringToStr(FileCFStr); + finally + FreeCFString(FileURL); + FreeCFString(FileCFStr); + end; + end; + + if Length(Files) > 0 then + begin + if Application <> nil then + begin + if Application.MainForm <> nil then + Application.MainForm.IntfDropFiles(Files); + + Application.IntfDropFiles(Files); + end; + end; + finally + AEDisposeDesc(DocList); + end; + + Result := noErr; +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_DragReceive + Handles dropping files on application + ------------------------------------------------------------------------------} +function CarbonApp_DragReceive(theWindow: WindowRef; handlerRefCon: UnivPtr; theDrag: DragRef): OSErr; {$IFDEF darwin}mwpascal;{$ENDIF} +var + theItemRef: DragItemRef; + theFlavorData: HFSFlavor; + theDataSize: Size; + theFilename: pchar; + theFileRef: FSRef; + numItems: UInt16; + Files: array of string; + itemNum: UInt16; +begin + SetLength(Files, 0); + + numItems := 0; + + if CountDragItems(theDrag, numItems) <> noErr then exit; + + if numItems > 0 then + for itemNum := 1 to numItems do + begin + if GetDragItemReferenceNumber(theDrag, itemNum, theItemRef) <> noErr then continue; + theDataSize := sizeof(theFlavorData); + if GetFlavorData(theDrag, theItemRef, kDragFlavorTypeHFS, @theFlavorData, theDataSize, 0) <> noErr then continue; + + FSpMakeFSRef(theFlavorData.fileSpec, theFileRef); + + theFilename := stralloc(1024); //PATH_MAX = 1024 + + FSRefMakePath(theFileRef, theFilename, StrBufSize(theFilename)); + + try + SetLength(Files, Length(Files) + 1); + Files[High(Files)] := theFilename; + finally + StrDispose(theFilename); + end; + end; + + if Length(Files) > 0 then + begin + if Application <> nil then + begin + if Application.MainForm <> nil then + Application.MainForm.IntfDropFiles(Files); + + Application.IntfDropFiles(Files); + end; + end; + + Result := noErr; +end; + +{------------------------------------------------------------------------------ + Name: CarbonApp_Quit + Handles application quit + ------------------------------------------------------------------------------} +function CarbonApp_Quit(var {%H-}AEvent: AppleEvent; var {%H-}Reply: AppleEvent; + {%H-}Data: SInt32): OSErr; {$IFDEF darwin}mwpascal;{$ENDIF} +begin + {$IFDEF VerboseAppEvent} + DebugLn('CarbonApp_Quit'); + {$ENDIF} + + if (Application <> nil) and (Application.MainForm <> nil) then + begin + Application.MainForm.Close; + end; + + Result := noErr; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppInit + Params: ScreenInfo + + Initialize Carbon Widget Set + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppInit(var ScreenInfo: TScreenInfo); +var + ScreenDC: HDC; +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppInit'); + {$ENDIF} + + WakeMainThread := @OnWakeMainThread; + + // fill the screen info + ScreenDC := GetDC(0); + try + ScreenInfo.PixelsPerInchX := GetDeviceCaps(ScreenDC, LOGPIXELSX); + ScreenInfo.PixelsPerInchY := GetDeviceCaps(ScreenDC, LOGPIXELSY); + ScreenInfo.ColorDepth := GetDeviceCaps(ScreenDC, BITSPIXEL); + finally + ReleaseDC(0, ScreenDC); + end; + + fMainEventQueue:=GetMainEventQueue; + + +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppRun + Params: ALoop + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppRun(const ALoop: TApplicationMainLoop); + // A reimplementation of RunApplicationEventLoop that supports + // yielding time to cooperative threads. It relies on the + // rest of your application to maintain a global variable, + // gNumberOfRunningThreads, that reflects the number of threads + // that are ready to run. +var + DummyEvent: EventRef; + EventSpec: EventTypeSpec; + EventLoopUPP, AccessibilityUPP: EventHandlerUPP; + EventLoopHandler, AccessibilityHandle: EventHandlerRef; +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppRun'); + {$ENDIF} + FAppLoop:=ALoop; + DummyEvent := nil; + + // Accessibility for AXApplication + AccessibilityUPP := NewEventHandlerUPP(EventHandlerProcPtr(Pointer(@AppAccessibilityEventHandler))); + EventSpec := MakeEventSpec(kEventClassAccessibility, kEventAccessibleGetNamedAttribute); + InstallApplicationEventHandler(AccessibilityUPP, 1, @EventSpec, Self, @AccessibilityHandle); + + // Create a UPP for EventLoopEventHandler and QuitEventHandler + + EventLoopUPP := NewEventHandlerUPP(EventHandlerProcPtr( + Pointer(@EventLoopEventHandler))); + if EventLoopUPP = nil then + RaiseGDBException('TCarbonWidgetSet.InitMainLoop no eventhandler'); + + // Install EventLoopEventHandler, create a dummy event and post it, + // and then call RunApplicationEventLoop. The rationale for this + // is as follows: We want to unravel RunApplicationEventLoop so + // that we can can yield to cooperative threads. In fact, the + // core code for RunApplicationEventLoop is pretty easy (you + // can see it above in EventLoopEventHandler). However, if you + // just execute this code you miss out on all the standard event + // handlers. These are relatively easy to reproduce (handling + // the quit event and so on), but doing so is a pain because + // a) it requires a bunch boilerplate code, and b) if Apple + // extends the list of standard event handlers, your application + // wouldn't benefit. So, we execute our event loop from within + // a Carbon event handler that we cause to be executed by + // explicitly posting an event to our event loop. Thus, the + // standard event handlers are installed while our event loop runs. + + EventSpec := MakeEventSpec(LCLCarbonEventClass, LCLCarbonEventKindMain); + if not InstallApplicationEventHandler(EventLoopUPP, 1, @EventSpec, Self, + @EventLoopHandler) then Exit; + try + if CreateEvent(nil, EventSpec.eventClass, EventSpec.eventKind, 0, + kEventAttributeNone, DummyEvent) <> noErr + then + RaiseGDBException('TCarbonWidgetSet.InitMainLoop create first dummy event failed'); + + try + {if SetEventParameter(DummyEvent, MakeFourCC('Loop'), + MakeFourCC('TAML'), SizeOf(ALoop), + @ALoop) <> noErr + then + RaiseGDBException('TCarbonWidgetSet.InitMainLoop setparam to first event failed');} + + //DebuglnThrea dLog('TCarbonWidgetSet.AppRun '+dbgs(GetMainEventQueue)); + if PostEventToQueue(FMainEventQueue, DummyEvent, + kEventPriorityHigh) <> noErr + then + RaiseGDBException('TCarbonWidgetSet.AppRun post dummy event failed'); + finally + ReleaseEvent(DummyEvent); + end; + + SignalFirstAppEvent; + if not FUserTerm then + begin + RunApplicationEventLoop; + end; + FAppStdEvents:=True; + + finally + MacOSAll.RemoveEventHandler(EventLoopHandler); + DisposeEventHandlerUPP(EventLoopUPP); + end; + + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppRun END'); + {$ENDIF} +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppProcessMessages + + Handle all pending messages + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppProcessMessages; +var + Target: EventTargetRef; + Event: EventRef; + CurEventClass: TEventInt; + CurEventKind: TEventInt; +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppProcessMessages'); + {$ENDIF} + + if not FAppStdEvents then InstallStandardEventHandler(GetApplicationEventTarget); + + Target := GetEventDispatcherTarget; + CurEventClass.Chars[4] := #0; + CurEventKind.Chars[4] := #0; + repeat + FreePendingWidgets; + if ReceiveNextEvent(0, nil, kEventDurationNoWait, True, + Event{%H-}) <> noErr then Break; + + CurEventClass.Int := GetEventClass(Event); + CurEventKind.Int := GetEventKind(Event); + + {$IFDEF DebugEventLoop} + DebugLn('EventClass: "',CurEventClass.Chars,'" EventKind: ',IntToStr(CurEventKind.Int)); + {$ENDIF} + + if CurEventClass.Chars = LCLCarbonEventClass then + begin + // internal carbon intf message + {$IFDEF DebugEventLoop} + DebugLn('EventKind: ',CurEventKind.Chars); + {$ENDIF} + if (CurEventKind.Chars = LCLCarbonEventKindUser) then + begin + end; + end; + + SendEventToEventTarget(Event, Target); + ReleaseEvent(Event); + + if Clipboard <> nil then + if Clipboard.OwnerShips > 0 then Clipboard.CheckOwnerShip; + + until Application.Terminated; + + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppProcessMessages END'); + {$ENDIF} +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppWaitMessage + + Passes execution control to Carbon + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppWaitMessage; +var + Event: EventRef; +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppWaitMessage'); + {$ENDIF} + + // Simply wait forever for the next event. + // Don't pull it, so we can handle it later. + OSError(ReceiveNextEvent(0, nil, kEventDurationForever, False, Event{%H-}), + Self, 'AppWaitMessage', 'ReceiveNextEvent'); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.Create + + Constructor for the class + ------------------------------------------------------------------------------} +constructor TCarbonWidgetSet.Create; +begin + CarbonWidgetSet := Self; + inherited Create; + FTerminating := False; + fMenuEnabled := True; + + FTimerMap := TMap.Create(its4, SizeOf(TWSTimerProc)); + FCurrentCursor := 0; + FMainMenu := 0; + FCaptureWidget := 0; + + RegisterEvents; + + { if using Cocoa, we need an autorelease pool + and we also need to initialize NSApplication } + {$ifdef CarbonUseCocoa} + pool := NSAutoreleasePool.Create; + + NSApplicationLoad(); + {$endif} +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.Destroy + + Destructor for the class + ------------------------------------------------------------------------------} +destructor TCarbonWidgetSet.Destroy; +begin + CaretWidgetSetReleased; + + FreeAndNil(FTimerMap); + DisposeAEEventHandlerUPP(FOpenEventHandlerUPP); + DisposeAEEventHandlerUPP(FQuitEventHandlerUPP); + + inherited Destroy; + CarbonWidgetSet := nil; + + // if using Cocoa, release autorelease the pool + {$ifdef CarbonUseCocoa} + if pool <> nil then pool.Free; + {$endif} +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.RawImage_DescriptionFromCarbonBitmap + + Creates a rawimage description for a carbonbitmap + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.RawImage_DescriptionFromCarbonBitmap(out ADesc: TRawImageDescription; ABitmap: TCarbonBitmap): Boolean; +var + Prec, Shift, BPR: Byte; + AlphaInfo: CGImageAlphaInfo; +begin + ADesc.Init; + + case ABitmap.BitmapType of + cbtMono, cbtGray: ADesc.Format := ricfGray; + else + ADesc.Format := ricfRGBA; + end; + + ADesc.Width := CGImageGetWidth(ABitmap.CGImage); + ADesc.Height := CGImageGetHeight(ABitmap.CGImage); + + //ADesc.PaletteColorCount := 0; + + ADesc.BitOrder := riboReversedBits; + ADesc.ByteOrder := riboMSBFirst; + + BPR := CGImageGetBytesPerRow(ABitmap.CGImage) and $FF; + if BPR and $F = 0 then ADesc.LineEnd := rileDQWordBoundary // 128bit aligned + else if BPR and $7 = 0 then ADesc.LineEnd := rileQWordBoundary // 64bit aligned + else if BPR and $3 = 0 then ADesc.LineEnd := rileWordBoundary // 32bit aligned + else if BPR and $1 = 0 then ADesc.LineEnd := rileByteBoundary // 8bit aligned + else ADesc.LineEnd := rileTight; + + ADesc.LineOrder := riloTopToBottom; + ADesc.BitsPerPixel := CGImageGetBitsPerPixel(ABitmap.CGImage); + + ADesc.MaskBitOrder := riboReversedBits; + ADesc.MaskBitsPerPixel := 1; + ADesc.MaskLineEnd := rileByteBoundary; + // ADesc.MaskShift := 0; + + Prec := CGImageGetBitsPerComponent(ABitmap.CGImage) and $FF; + AlphaInfo := CGImageGetAlphaInfo(ABitmap.CGImage); + + if AlphaInfo <> kCGImageAlphaOnly + then begin + ADesc.RedPrec := Prec; + ADesc.GreenPrec := Prec; + ADesc.BluePrec := Prec; + end; + + // gray or mono + if ADesc.Format = ricfGray then begin + ADesc.Depth := 1; + Exit; + end; + + // alpha + case AlphaInfo of + kCGImageAlphaNone, + kCGImageAlphaNoneSkipLast, + kCGImageAlphaNoneSkipFirst: begin + ADesc.Depth := Prec * 3; + // ADesc.AlphaPrec := 0; + end; + else + ADesc.Depth := Prec * 4; + ADesc.AlphaPrec := Prec; + end; + + case AlphaInfo of + kCGImageAlphaNone, + kCGImageAlphaNoneSkipLast: begin + // RGBx + Shift := 32 - Prec; + ADesc.RedShift := Shift; + Dec(Shift, Prec); + ADesc.GreenShift := Shift; + Dec(Shift, Prec); + ADesc.BlueShift := Shift; + end; + kCGImageAlphaNoneSkipFirst: begin + // xRGB + Shift := 0; + ADesc.BlueShift := Shift; + Inc(Shift, Prec); + ADesc.GreenShift := Shift; + Inc(Shift, Prec); + ADesc.RedShift := Shift; + end; + kCGImageAlphaPremultipliedFirst, + kCGImageAlphaFirst: begin + // ARGB + Shift := 32 - Prec; + ADesc.AlphaShift := Shift; + Dec(Shift, Prec); + ADesc.RedShift := Shift; + Dec(Shift, Prec); + ADesc.GreenShift := Shift; + Dec(Shift, Prec); + ADesc.BlueShift := Shift; + end; + kCGImageAlphaPremultipliedLast, + kCGImageAlphaLast: begin + // RGBA + Shift := 32 - Prec; + ADesc.RedShift := Shift; + Dec(Shift, Prec); + ADesc.GreenShift := Shift; + Dec(Shift, Prec); + ADesc.BlueShift := Shift; + Dec(Shift, Prec); + ADesc.AlphaShift := Shift; + end; + kCGImageAlphaOnly: begin + // A + //ADesc.AlphaShift := 0; + end; + end; + + Result := True; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.RawImage_FromCarbonBitmap + + Creates a rawimage description for a carbonbitmap + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.RawImage_FromCarbonBitmap(out ARawImage: TRawImage; ABitmap, AMask: TCarbonBitmap; ARect: PRect = nil): Boolean; +var Width, Height: Integer; + R: TRect; + WorkData: PByte = nil; + MaskData: PByte = nil; + MaskDataSize, WorkDataSize: PtrUInt; + + function CreateSub(ARect: TRect; ABmp: TCarbonBitMap; BitsPerPixel: Integer; var ImageDataSize: PtrUInt): PByte; + var FullImageData, BytePtr: PByte; + SubImageBytesPerRow, DataSize: PtrUInt; + ShiftBits, RowCnt, RowByteCnt: Integer; + begin + + SubImageBytesPerRow := (((ARect.Right - ARect.Left) * BitsPerPixel) + 7) div 8; + if (BitsPerPixel > 1) then + SubImageBytesPerRow := ((((Arect.Right - ARect.Left) * (BitsPerPixel div 8)) + $F) and not PtrUInt($F)); + DataSize := SubImageBytesPerRow {%H-}* (ARect.Bottom - ARect.Top); + Result := System.GetMem(DataSize); + if (Result = nil) then RaiseMemoryAllocationError; + + BytePtr := Result; + ShiftBits := (ARect.Left * BitsPerPixel) mod 8; + FullImageData := ABmp.Data + ((ARect.Left * BitsPerPixel) div 8); + + For RowCnt := 0 to ((ARect.Bottom - ARect.Top) - 1) do begin + For RowByteCnt := 0 to (SubImageBytesPerRow - 1) do begin + BytePtr^ := (Byte((PByte(FullImageData + RowByteCnt)^ Shl ShiftBits)) or + (PByte(FullImageData + RowByteCnt + 1)^ Shr (8 - ShiftBits))); + Inc(BytePtr); + end; + Inc(FullImageData, ABmp.BytesPerRow); + end; + ImageDataSize := DataSize; + end; + +begin + Result := False; + + FillChar(ARawImage{%H-}, SizeOf(ARawImage), 0); + ARawImage.Init; + RawImage_DescriptionFromCarbonBitmap(ARawImage.Description, ABitmap); + + if ARect = nil + then begin + Width := ABitmap.Width; + Height := ABitmap.Height; + end + else begin + R := ARect^; + Width := R.Right - R.Left; + Height := R.Bottom - R.Top; + end; + + if Width > ABitmap.Width then + Width := ABitmap.Width; + + if Height > ABitmap.Height then + Height := ABitmap.Height; + + if (Width = ABitmap.Width) and (Height = ABitmap.Height) + then begin + WorkData := ABitmap.Data; + WorkDataSize := ABitmap.DataSize; + if AMask <> nil then begin + MaskData := AMask.Data; + MaskDataSize := AMask.DataSize; + end; + end + else begin + WorkData := CreateSub(R, ABitmap, ARawImage.Description.BitsPerPixel, WorkDataSize); + if AMask <> nil then + MaskData := CreateSub(R, AMask, 1, MaskDataSize); + end; + + ARawImage.Description.Width := Width; + ARawImage.Description.Height := Height; + + ARawImage.DataSize := WorkDataSize; + ReAllocMem(ARawImage.Data, ARawImage.DataSize); + if ARawImage.DataSize > 0 then + System.Move(WorkData^, ARawImage.Data^, ARawImage.DataSize); + + if (WorkData <> ABitmap.Data) then + FreeMem(WorkData); + + Result := True; + + if AMask = nil then + begin + ARawImage.Description.MaskBitsPerPixel := 0; + Exit; + end; + + if AMask.Depth > 1 + then begin + DebugLn('[WARNING] RawImage_FromCarbonBitmap: AMask.Depth > 1'); + Exit; + end; + + ARawImage.Description.MaskBitsPerPixel := 1; + ARawImage.Description.MaskShift := 0; + ARawImage.Description.MaskLineEnd := rileByteBoundary; + ARawImage.Description.MaskBitOrder := riboReversedBits; + + ARawImage.MaskSize := MaskDataSize; + ReAllocMem(ARawImage.Mask, ARawImage.MaskSize); + if ARawImage.MaskSize > 0 then + System.Move(MaskData^, ARawImage.Mask^, ARawImage.MaskSize); + + if (MaskData <> AMask.Data) then + FreeMem(MaskData); + +end; + +function TCarbonWidgetSet.RawImage_DescriptionToBitmapType( + ADesc: TRawImageDescription; + out bmpType: TCarbonBitmapType): Boolean; +begin + Result := False; + + if ADesc.Format = ricfGray + then + begin + if ADesc.Depth = 1 then bmpType := cbtMono + else bmpType := cbtGray; + end + else if ADesc.Depth = 1 + then bmpType := cbtMono + else if ADesc.AlphaPrec <> 0 + then begin + if ADesc.ByteOrder = riboMSBFirst + then begin + if (ADesc.AlphaShift = 24) + and (ADesc.RedShift = 16) + and (ADesc.GreenShift = 8 ) + and (ADesc.BlueShift = 0 ) + then bmpType := cbtARGB + else + if (ADesc.AlphaShift = 0) + and (ADesc.RedShift = 24) + and (ADesc.GreenShift = 16 ) + and (ADesc.BlueShift = 8 ) + then bmpType := cbtRGBA + else + if (ADesc.AlphaShift = 0 ) + and (ADesc.RedShift = 8 ) + and (ADesc.GreenShift = 16) + and (ADesc.BlueShift = 24) + then bmpType := cbtBGRA + else Exit; + end + else begin + if (ADesc.AlphaShift = 24) + and (ADesc.RedShift = 16) + and (ADesc.GreenShift = 8 ) + and (ADesc.BlueShift = 0 ) + then bmpType := cbtBGRA + else + if (ADesc.AlphaShift = 0 ) + and (ADesc.RedShift = 8 ) + and (ADesc.GreenShift = 16) + and (ADesc.BlueShift = 24) + then bmpType := cbtARGB + else + if (ADesc.AlphaShift = 24 ) + and (ADesc.RedShift = 0 ) + and (ADesc.GreenShift = 8) + and (ADesc.BlueShift = 16) + then bmpType := cbtRGBA + else Exit; + end; + end + else begin + bmpType := cbtRGB; + end; + + Result := True; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.GetImagePixelData + + Used by RawImage_FromDevice. Copies the data from a CGImageRef into a local + buffer. + + The buffer is created using GetMem, and the caller is responsible for using + FreeMem to free the returned pointer. + + This function throws exceptions in case of errors and may return a nil pointer. + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.GetImagePixelData(AImage: CGImageRef; out bitmapByteCount: PtrUInt): Pointer; +var + bitmapData: Pointer; + context: CGContextRef = nil; + colorSpace: CGColorSpaceRef; + bitmapBytesPerRow, pixelsWide, pixelsHigh: PtrUInt; + imageRect: CGRect; +begin + Result := nil; + + // Get image width, height. The entire image is used. + pixelsWide := CGImageGetWidth(AImage); + pixelsHigh := CGImageGetHeight(AImage); + imageRect.origin.x := 0.0; + imageRect.origin.y := 0.0; + imageRect.size.width := pixelsWide; + imageRect.size.height := pixelsHigh; + + // The target format is fixed in ARGB, DQWord alignment, with 32-bits depth and + // 8-bits per channel, the default image format on the LCL + bitmapBytesPerRow := ((pixelsWide * 4) + $F) and not PtrUInt($F); + bitmapByteCount := (bitmapBytesPerRow * pixelsHigh); + + // Use the generic RGB color space. + colorSpace := CGColorSpaceCreateWithName(kCGColorSpaceGenericRGB); + if (colorSpace = nil) then RaiseColorSpaceError; + + // Allocate memory for image data. This is the destination in memory + // where any drawing to the bitmap context will be rendered. + bitmapData := System.GetMem( bitmapByteCount ); + if (bitmapData = nil) then RaiseMemoryAllocationError; + + { Creates the bitmap context. + + Regardless of what the source image format is, it will be converted + over to the format specified here by CGBitmapContextCreate. } + context := CGBitmapContextCreate(bitmapData, + pixelsWide, + pixelsHigh, + 8, // bits per component + bitmapBytesPerRow, + colorSpace, + kCGImageAlphaNoneSkipFirst); // The function fails with kCGImageAlphaFirst + if (context = nil) then + begin + System.FreeMem(bitmapData); + RaiseContextCreationError; + end; + + // Draw the image to the bitmap context. Once we draw, the memory + // allocated for the context for rendering will then contain the + // raw image data in the specified color space. + CGContextDrawImage(context, imageRect, AImage); + + // Now we can get a pointer to the image data associated with the context. + // ToDo: Verify if we should copy this data to a new buffer + Result := CGBitmapContextGetData(context); + + { Clean-up } + CGColorSpaceRelease(colorSpace); + CGContextRelease(context); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.CreateThemeServices + Returns: Theme Services object for Carbon interface + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.CreateThemeServices: TThemeServices; +begin + Result := TCarbonThemeServices.Create; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.PassCmdLineOptions + + Not used + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.PassCmdLineOptions; +begin + inherited PassCmdLineOptions; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.SendCheckSynchronizeMessage + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.SendCheckSynchronizeMessage; +var + EventSpec: EventTypeSpec; + DummyEvent: EventRef; +begin + if FMainEventQueue=nil then + begin + //DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage FMainEventQueue=nil'); + exit; + end; + + {$IFDEF VerboseObject} + DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage START'); + {$ENDIF} + + EventSpec := MakeEventSpec(LCLCarbonEventClass,LCLCarbonEventKindWake); + DummyEvent:=nil; + try + if CreateEvent(nil, EventSpec.eventClass, EventSpec.eventKind, + 0{GetCurrentEventTime}, kEventAttributeNone, DummyEvent) <> noErr then + begin + {$IFDEF VerboseObject} + DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage Create event FAILED'); + {$ENDIF} + Exit; + end; + + {$IFDEF VerboseObject} + DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage GetMainEventQueue='+dbgs(GetMainEventQueue)); + {$ENDIF} + + if PostEventToQueue(FMainEventQueue, DummyEvent, + kEventPriorityHigh) <> noErr then + begin + {$IFDEF VerboseObject} + DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage Post event FAILED'); + {$ENDIF} + Exit; + end; + finally + if DummyEvent <> nil then ReleaseEvent(DummyEvent); + end; + + {$IFDEF VerboseObject} + DebugLnThreadLog('TCarbonWidgetSet.SendCheckSynchronizeMessage END'); + {$ENDIF} +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.OnWakeMainThread + Params: Sender + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.OnWakeMainThread(Sender: TObject); +begin + // the code below would start waiting on the first app event to arrive. + // however, if fAppLoop has not been initialized and we're in the main thread + // we shouldn't wait for it, since signal is given from the main thread. + if (GetThreadID=MainThreadID) and (not Assigned(fAppLoop)) then Exit; + + // wait infinite for the first (dummy) event sent to the main event queue + WaitFirstAppEvent; + SendCheckSynchronizeMessage; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.RegisterEvents + Registers events for Carbon application + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.RegisterEvents; +var + TmpSpec: EventTypeSpec; +const + SName = 'RegisterEvents'; +begin + //DebugLn('TCarbonWidgetSet.RegisterEvents'); + TmpSpec := MakeEventSpec(kEventClassCommand, kEventCommandProcess); + InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_CommandProcess), + 1, @TmpSpec, nil, @FAEventHandlerRef[0]); + + TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppShown); + InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_Shown), + 1, @TmpSpec, nil, @FAEventHandlerRef[1]); + + TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppHidden); + InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_Hidden), + 1, @TmpSpec, nil, @FAEventHandlerRef[2]); + + TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppDeactivated); + InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_Deactivated), + 1, @TmpSpec, nil, @FAEventHandlerRef[3]); + + TmpSpec := MakeEventSpec(kEventClassApplication, kEventAppActivated); + InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_Activated), + 1, @TmpSpec, nil, @FAEventHandlerRef[4]); + + TmpSpec := MakeEventSpec(LCLCarbonEventClass, LCLCarbonEventKindWake); + InstallApplicationEventHandler(RegisterEventHandler(@CarbonApp_LazWake), + 1, @TmpSpec, nil, @FAEventHandlerRef[5]); + + InstallReceiveHandler(@CarbonApp_DragReceive, nil, nil); + + FOpenEventHandlerUPP := NewAEEventHandlerUPP(AEEventHandlerProcPtr(@CarbonApp_Open)); + FQuitEventHandlerUPP := NewAEEventHandlerUPP(AEEventHandlerProcPtr(@CarbonApp_Quit)); + OSError( + AEInstallEventHandler(kCoreEventClass, kAEOpenDocuments, FOpenEventHandlerUPP, 0, False), + Self, SName, 'AEInstallEventHandler'); + OSError( + AEInstallEventHandler(kCoreEventClass, kAEOpenContents, FOpenEventHandlerUPP, 0, False), + Self, SName, 'AEInstallEventHandler'); + OSError( + AEInstallEventHandler(kCoreEventClass, kAEQuitApplication, FQuitEventHandlerUPP, 0, False), + Self, SName, 'AEInstallEventHandler'); +end; + + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppTerminate + + Tells Carbon to halt the application + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppTerminate; +var i:integer; +const + SName = 'AppTerminate'; +begin + if FTerminating then Exit; + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppTerminate'); + {$ENDIF} + FUserTerm:=True; + QuitApplicationEventLoop; + for i:=Low(FAEventHandlerRef) to High(FAEventHandlerRef) do + OSError(MacOSALL.RemoveEventHandler(FAEventHandlerRef[i]), + TClass(Self), SName, 'RemoveEventHandler'); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppMinimize + + Minimizes the whole application to the taskbar + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppMinimize; +var + Proc: ProcessSerialNumber; +const + SName = 'AppMinimize'; +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppMinimize'); + {$ENDIF} + + // hide process + if OSError(GetCurrentProcess(Proc{%H-}), Self, SName, SGetCurrentProc) then Exit; + OSError(ShowHideProcess(Proc, False), Self, SName, SShowHideProc); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppRestore + + Restores the whole minimized application from the taskbar + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppRestore; +var + Proc: ProcessSerialNumber; +const + SName = 'AppRestore'; +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppRestore'); + {$ENDIF} + + // show process + if OSError(GetCurrentProcess(Proc{%H-}), Self, SName, SGetCurrentProc) then Exit; + OSError(ShowHideProcess(Proc, True), Self, SName, SShowHideProc); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppBringToFront + + Brings the entire application on top of all other non-topmost programs + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppBringToFront; +var + Proc: ProcessSerialNumber; +const SName = 'AppBringToFront'; +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.AppBringToFront'); + {$ENDIF} + + (* + According to Carbon Development Tips & Tricks: + 34. How do I bring all my windows to the front? + *) + + if OSError(GetCurrentProcess(Proc{%H-}), Self, SName, SGetCurrentProc) then Exit; + OSError(SetFrontProcess(Proc), Self, SName, 'SetFrontProcess'); +end; + +procedure TCarbonWidgetSet.AppSetIcon(const Small, Big: HICON); +begin + if Big <> 0 then + SetApplicationDockTileImage(TCarbonBitmap(Big).CGImage) + else + RestoreApplicationDockTileImage; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.AppSetTitle + Params: ATitle - New application title + + Changes the application title + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.AppSetTitle(const ATitle: string); +begin + // not supported +end; + +function TCarbonWidgetSet.GetLCLCapability(ACapability: TLCLCapability): PtrUInt; +begin + case ACapability of + lcCanDrawOutsideOnPaint, + lcNeedMininimizeAppWithMainForm, + lcApplicationTitle, + lcFormIcon, + lcReceivesLMClearCutCopyPasteReliably: + Result := LCL_CAPABILITY_NO; + lcAntialiasingEnabledByDefault: + Result := LCL_CAPABILITY_YES; + lcAccessibilitySupport: Result := LCL_CAPABILITY_YES; + else + Result := inherited; + end; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.LCLPlatform + Returns: lpCarbon - enum value for Carbon widgetset + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.LCLPlatform: TLCLPlatform; +begin + Result:= lpCarbon; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.DCGetPixel + Params: CanvasHandle - Canvas handle to get color from + X, Y - Position + Returns: Color of the specified pixel on the canvas + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.DCGetPixel(CanvasHandle: HDC; X, Y: integer + ): TGraphicsColor; +begin + Result := clNone; + + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.DCGetPixel DC: ' + DbgS(CanvasHandle) + ' X: ' + DbgS(X) + ' Y: ' + DbgS(Y)); + {$ENDIF} + + if not CheckDC(CanvasHandle, 'DCGetPixel') then Exit; + + Result := TCarbonDeviceContext(CanvasHandle).GetPixel(X, Y); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.DCSetPixel + Params: CanvasHandle - Canvas handle to get color from + X, Y - Position + AColor - New color for specified position + + Sets the color of the specified pixel on the canvas + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.DCSetPixel(CanvasHandle: HDC; X, Y: integer; + AColor: TGraphicsColor); +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.DCSetPixel DC: ' + DbgS(CanvasHandle) + ' X: ' + DbgS(X) + ' Y: ' + DbgS(Y) + 'Color: ' + DbgS(AColor)); + {$ENDIF} + + if not CheckDC(CanvasHandle, 'DCSetPixel') then Exit; + + TCarbonDeviceContext(CanvasHandle).SetPixel(X, Y, AColor); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.DCReDraw + Params: CanvasHandle - Canvas handle to redraw + + Redraws (the window of) a canvas + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.DCRedraw(CanvasHandle: HDC); +begin + {$IFDEF VerboseObject} + DebugLn('TCarbonWidgetSet.DCRedraw DC: ' + DbgS(CanvasHandle)); + {$ENDIF} + + if not CheckDC(CanvasHandle, 'DCRedraw') then Exit; + + CGContextFlush(TCarbonContext(CanvasHandle).CGContext); +end; + +procedure TCarbonWidgetSet.DCSetAntialiasing(CanvasHandle: HDC; + AEnabled: Boolean); +begin + if not CheckDC(CanvasHandle, 'DCSetAntialiasing') then Exit; + + TCarbonDeviceContext(CanvasHandle).SetAntialiasing(AEnabled); +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.SetDesigning + Params: AComponent - Component to set designing + + Not implemented! + ------------------------------------------------------------------------------} +procedure TCarbonWidgetSet.SetDesigning(AComponent: TComponent); +begin + +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.IsHelpKey + Params: Key - + Shift - + Returns: If the specified key is determined to show help in Carbon + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.IsHelpKey(Key: Word; Shift: TShiftState): Boolean; +begin + Result := False; // help key is Cmd + ?, will be called directly on key press +end; + +{------------------------------------------------------------------------------ + Method: TimerCallback + Params: inTimer - Timer reference + inUserData - User data passed when installing timer + + Calls the timer function associated with specified timer + ------------------------------------------------------------------------------} +procedure TimerCallback(inTimer: EventLoopTimerRef; {%H-}inUserData: UnivPtr); +var + TimerFunc: TWSTimerProc; +begin + {$IFDEF VerboseTimer} + DebugLn('TimerCallback'); + {$ENDIF} + + if CarbonWidgetSet = nil then Exit; + if CarbonWidgetSet.FTimerMap.GetData(inTimer, TimerFunc) then + begin + {$IFDEF VerboseTimer} + DebugLn('TimerCallback Timer instaÃ¥led, calling func.'); + {$ENDIF} + + TimerFunc; + end; +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.CreateTimer + Params: Interval - New timer interval + TimerFunc - New timer callback + Returns: A Timer id + + Creates new timer with specified interval and callback function + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.CreateTimer(Interval: integer; TimerFunc: TWSTimerProc): THandle; +var + Timer: EventLoopTimerRef; +begin + {$IFDEF VerboseTimer} + DebugLn('TCarbonWidgetSet.CreateTimer Interval: ' + DbgS(Interval)); + {$ENDIF} + Result := 0; + + if (Interval > 0) and (TimerFunc <> nil) then + begin + if OSError(InstallEventLoopTimer(GetMainEventLoop, + Interval / 1000, Interval / 1000, // converts msec -> sec + EventLoopTimerUPP(@TimerCallback), nil, Timer{%H-}), Self, + 'CreateTimer', 'InstallEventLoopTimer') then Exit; + + FTimerMap.Add(Timer, TimerFunc); + Result := {%H-}THandle(Timer) + end; + + {$IFDEF VerboseTimer} + DebugLn('TCarbonWidgetSet.CreateTimer Result: ' + DbgS(Result)); + {$ENDIF} +end; + +{------------------------------------------------------------------------------ + Method: TCarbonWidgetSet.Destroy + Params: TimerHandle - Timer id to destroy + Returns: If the function succeeds + + Destroys specified timer + ------------------------------------------------------------------------------} +function TCarbonWidgetSet.DestroyTimer(TimerHandle: THandle): boolean; +begin + {$IFDEF VerboseTimer} + DebugLn('TCarbonWidgetSet.DestroyTimer Handle: ' + DbgS(TimerHandle)); + {$ENDIF} + + Result := FTimerMap.Delete(TimerHandle); + + if Result then // valid timer + OSError(RemoveEventLoopTimer({%H-}EventLoopTimerRef(TimerHandle)), Self, + 'DestroyTimer', 'RemoveEventLoopTimer'); +end; + +function TCarbonWidgetSet.PrepareUserEvent(Handle: HWND; Msg: Cardinal; + wParam: WParam; lParam: LParam; out Target: EventTargetRef): EventRef; +var + EventSpec: EventTypeSpec; + AMessage: TLMessage; + Widget: TCarbonWidget; +begin + Result := nil; + if FMainEventQueue = nil then Exit; + + Widget := TCarbonWidget(Handle); + + if Widget is TCarbonControl then + Target := GetControlEventTarget(Widget.Widget) + else + if Widget is TCarbonWindow then + Target := GetWindowEventTarget(TCarbonWindow(Widget).Window) + else + Exit; + + EventSpec := MakeEventSpec(LCLCarbonEventClass, LCLCarbonEventKindUser); + if CreateEvent(nil, EventSpec.eventClass, EventSpec.eventKind, + 0, kEventAttributeUserEvent, Result) <> noErr then + Exit; + + AMessage.Msg := Msg; + AMessage.LParam := lParam; + AMessage.WParam := wParam; + AMessage.Result := 0; + SetEventParameter(Result, MakeFourCC('wmsg'), + MakeFourCC('wmsg'), SizeOf(TLMessage), + @AMessage); +end; diff --git a/example/attention.nii.gz b/example/attention.nii.gz new file mode 100755 index 0000000..9944ff9 Binary files /dev/null and b/example/attention.nii.gz differ diff --git a/example/clipnearr.ini b/example/clipnearr.ini new file mode 100755 index 0000000..2cf4c76 --- /dev/null +++ b/example/clipnearr.ini @@ -0,0 +1,23 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +ShowCutout=0 +FlipLR=0 +[INT] +OverlayFromBGSurface=1 +BGNearClip=56 +OverlayNearClip=0 +Azimuth=110 +Elevation=30 +BGSurface=25 +OverlaySurface=1 +BGDepth=12 +OverlayDepth=8 +CutoutBias=3 +CutoutLo1=96 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=87 +CutoutHi3=181 diff --git a/example/cut2.ini b/example/cut2.ini new file mode 100755 index 0000000..057946f --- /dev/null +++ b/example/cut2.ini @@ -0,0 +1,23 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +ShowCutout=0 +FlipLR=0 +[INT] +OverlayFromBGSurface=2 +BGNearClip=72 +OverlayNearClip=0 +Azimuth=70 +Elevation=25 +BGSurface=25 +OverlaySurface=0 +BGDepth=12 +OverlayDepth=12 +CutoutBias=3 +CutoutLo1=96 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=87 +CutoutHi3=181 diff --git a/example/cutr.ini b/example/cutr.ini new file mode 100755 index 0000000..1399986 --- /dev/null +++ b/example/cutr.ini @@ -0,0 +1,23 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +OverlayFromBGSurface=1 +ShowCutout=1 +FlipLR=0 +[INT] +BGNearClip=0 +OverlayNearClip=0 +Azimuth=110 +Elevation=45 +BGSurface=25 +OverlaySurface=1 +BGDepth=12 +OverlayDepth=8 +CutoutLo1=96 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=87 +CutoutHi3=181 +CutoutBias=3 diff --git a/example/dataset/1.voi b/example/dataset/1.voi new file mode 100755 index 0000000..7dc146e Binary files /dev/null and b/example/dataset/1.voi differ diff --git a/example/dataset/10.voi b/example/dataset/10.voi new file mode 100755 index 0000000..ad58885 Binary files /dev/null and b/example/dataset/10.voi differ diff --git a/example/dataset/11.voi b/example/dataset/11.voi new file mode 100755 index 0000000..4f19fcd Binary files /dev/null and b/example/dataset/11.voi differ diff --git a/example/dataset/12.voi b/example/dataset/12.voi new file mode 100755 index 0000000..ca6ced7 Binary files /dev/null and b/example/dataset/12.voi differ diff --git a/example/dataset/13.voi b/example/dataset/13.voi new file mode 100755 index 0000000..96b7f62 Binary files /dev/null and b/example/dataset/13.voi differ diff --git a/example/dataset/14.voi b/example/dataset/14.voi new file mode 100755 index 0000000..e251e58 Binary files /dev/null and b/example/dataset/14.voi differ diff --git a/example/dataset/15.voi b/example/dataset/15.voi new file mode 100755 index 0000000..1c21281 Binary files /dev/null and b/example/dataset/15.voi differ diff --git a/example/dataset/16.voi b/example/dataset/16.voi new file mode 100755 index 0000000..0ec93c6 Binary files /dev/null and b/example/dataset/16.voi differ diff --git a/example/dataset/17.voi b/example/dataset/17.voi new file mode 100755 index 0000000..91f803d Binary files /dev/null and b/example/dataset/17.voi differ diff --git a/example/dataset/18.voi b/example/dataset/18.voi new file mode 100755 index 0000000..61bb0b0 Binary files /dev/null and b/example/dataset/18.voi differ diff --git a/example/dataset/19.voi b/example/dataset/19.voi new file mode 100755 index 0000000..8ddcb8e Binary files /dev/null and b/example/dataset/19.voi differ diff --git a/example/dataset/2.voi b/example/dataset/2.voi new file mode 100755 index 0000000..214c659 Binary files /dev/null and b/example/dataset/2.voi differ diff --git a/example/dataset/20.voi b/example/dataset/20.voi new file mode 100755 index 0000000..11604b5 Binary files /dev/null and b/example/dataset/20.voi differ diff --git a/example/dataset/21.voi b/example/dataset/21.voi new file mode 100755 index 0000000..05b12bd Binary files /dev/null and b/example/dataset/21.voi differ diff --git a/example/dataset/22.voi b/example/dataset/22.voi new file mode 100755 index 0000000..61bac92 Binary files /dev/null and b/example/dataset/22.voi differ diff --git a/example/dataset/23.voi b/example/dataset/23.voi new file mode 100755 index 0000000..0de2a4a Binary files /dev/null and b/example/dataset/23.voi differ diff --git a/example/dataset/24.voi b/example/dataset/24.voi new file mode 100755 index 0000000..0ef1a6b Binary files /dev/null and b/example/dataset/24.voi differ diff --git a/example/dataset/3.voi b/example/dataset/3.voi new file mode 100755 index 0000000..17d2444 Binary files /dev/null and b/example/dataset/3.voi differ diff --git a/example/dataset/4.voi b/example/dataset/4.voi new file mode 100755 index 0000000..ceff169 Binary files /dev/null and b/example/dataset/4.voi differ diff --git a/example/dataset/5.voi b/example/dataset/5.voi new file mode 100755 index 0000000..8837530 Binary files /dev/null and b/example/dataset/5.voi differ diff --git a/example/dataset/6.voi b/example/dataset/6.voi new file mode 100755 index 0000000..b50c1da Binary files /dev/null and b/example/dataset/6.voi differ diff --git a/example/dataset/7.voi b/example/dataset/7.voi new file mode 100755 index 0000000..0f62865 Binary files /dev/null and b/example/dataset/7.voi differ diff --git a/example/dataset/8.voi b/example/dataset/8.voi new file mode 100755 index 0000000..0da9a51 Binary files /dev/null and b/example/dataset/8.voi differ diff --git a/example/dataset/9.voi b/example/dataset/9.voi new file mode 100755 index 0000000..d0b1ef4 Binary files /dev/null and b/example/dataset/9.voi differ diff --git a/example/dataset/binomial.val b/example/dataset/binomial.val new file mode 100755 index 0000000..8b0ee6c --- /dev/null +++ b/example/dataset/binomial.val @@ -0,0 +1,29 @@ +#Version:0 +#Covary Volume 0 +#Template C:\template.img +#CritPct 16 +ImageName Cancel +1.voi 0 +2.voi 0 +3.voi 0 +4.voi 0 +5.voi 0 +6.voi 0 +7.voi 0 +8.voi 0 +9.voi 0 +10.voi 0 +11.voi 0 +12.voi 0 +13.voi 1 +14.voi 1 +15.voi 1 +16.voi 1 +17.voi 1 +18.voi 1 +19.voi 1 +20.voi 1 +21.voi 1 +22.voi 1 +23.voi 1 +24.voi 1 \ No newline at end of file diff --git a/example/dataset/continuous.val b/example/dataset/continuous.val new file mode 100755 index 0000000..87252bf --- /dev/null +++ b/example/dataset/continuous.val @@ -0,0 +1,29 @@ +#Version:0 +#Covary Volume 0 +#Template C:\template.img +#CritPct 16 +ImageName Cancel +1.voi 2 +2.voi 44 +3.voi 22 +4.voi 24 +5.voi 23 +6.voi 22 +7.voi 18 +8.voi 12 +9.voi 15 +10.voi 41 +11.voi 32 +12.voi 22 +13.voi 60 +14.voi 58 +15.voi 57 +16.voi 57 +17.voi 55 +18.voi 56 +19.voi 60 +20.voi 59 +21.voi 57 +22.voi 58 +23.voi 56 +24.voi 57 \ No newline at end of file diff --git a/example/fmri2r.ini b/example/fmri2r.ini new file mode 100755 index 0000000..f5831d5 --- /dev/null +++ b/example/fmri2r.ini @@ -0,0 +1,24 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +OverlayFromBGSurface=0 +ShowCutout=0 +FlipLR=0 +[INT] +BGNearClip=0 +OverlayNearClip=0 +Azimuth=110 +Elevation=45 +BGSurface=25 +OverlaySurface=1 +BGDepth=8 +OverlayDepth=8 +CutoutLo1=90 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=90 +CutoutHi3=181 +OverlayFromBGSurface=0 +CutoutBias=4 diff --git a/example/fmri3r.ini b/example/fmri3r.ini new file mode 100755 index 0000000..389a715 --- /dev/null +++ b/example/fmri3r.ini @@ -0,0 +1,22 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +OverlayFromBGSurface=1 +ShowCutout=0 +FlipLR=0 +[INT] +BGNearClip=0 +OverlayNearClip=0 +Azimuth=80 +Elevation=45 +BGSurface=25 +OverlaySurface=1 +BGDepth=8 +OverlayDepth=8 +CutoutLo1=90 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=90 +CutoutHi3=181 diff --git a/example/fmrir.ini b/example/fmrir.ini new file mode 100755 index 0000000..fe5a2d4 --- /dev/null +++ b/example/fmrir.ini @@ -0,0 +1,22 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=0 +Trilinear=0 +OverlayFromBGSurface=1 +ShowCutout=0 +FlipLR=0 +[INT] +BGNearClip=0 +OverlayNearClip=0 +Azimuth=80 +Elevation=45 +BGSurface=51 +OverlaySurface=1 +BGDepth=8 +OverlayDepth=12 +CutoutLo1=90 +CutoutHi1=181 +CutoutLo2=108 +CutoutHi2=217 +CutoutLo3=90 +CutoutHi3=181 diff --git a/example/lesionm.ini b/example/lesionm.ini new file mode 100755 index 0000000..bafe2be --- /dev/null +++ b/example/lesionm.ini @@ -0,0 +1,8 @@ +[STR] +Slices=82,92,102,112,122,132 +[BOOL] +OrthoView=1 +SliceLabel=1 +[INT] +Orient=1 +OverslicePct=-35 diff --git a/example/saccades.nii.gz b/example/saccades.nii.gz new file mode 100755 index 0000000..66d166e Binary files /dev/null and b/example/saccades.nii.gz differ diff --git a/extrafpc.cfg b/extrafpc.cfg new file mode 100755 index 0000000..4c13c40 --- /dev/null +++ b/extrafpc.cfg @@ -0,0 +1,4 @@ +#IFDEF Darwin +-k-macosx_version_min -k10.4 +-XR/Developer/SDKs/MacOSX10.4u.sdk/ +#ENDIF \ No newline at end of file diff --git a/fastsmooth.pas b/fastsmooth.pas new file mode 100755 index 0000000..73bd1d1 --- /dev/null +++ b/fastsmooth.pas @@ -0,0 +1,405 @@ +unit fastsmooth; + +{$mode delphi} + +interface + +uses + // LCLIntf,//<- only for gettickcount + Classes, SysUtils, define_types, otsuml; + procedure DilateSphere (var lImg: Bytep; lXi,lYi,lZi: integer; lVoxDistance: single; lChange: byte ); +procedure SmoothFWHM2Vox (var lImg: Bytep; lXi,lYi,lZi: integer); +procedure Dilate (var lImg: Bytep; lXi,lYi,lZi,lCycles: integer; lChange: byte ); +procedure PreserveLargestCluster (var lImg: Bytep; lXi,lYi,lZi: integer; lClusterValue,ValueForSmallClusters: byte ); + procedure MaskBackground (var lImg: Bytep; lXi,lYi,lZi,lOtsuLevels: integer; lDilateVox: single; lOneContiguousObject: boolean ); +implementation + +procedure MaskBackground (var lImg: Bytep; lXi,lYi,lZi,lOtsuLevels: integer; lDilateVox: single; lOneContiguousObject: boolean ); +var + lMask: ByteP; + lX,lY,lZ,lV,lXYZ: integer; +begin + lXYZ := lXi * lYi * lZi; + if (lXi < 3) or (lYi < 3) or (lZi < 1) then + exit; + getmem(lMask, lXYZ); + Move(lImg^[1], lMask^[1],lXYZ); + SmoothFWHM2Vox(lMask, lXi,lYi,lZi); + ApplyOtsuBinary (lMask, lXYZ,lOtsuLevels); + //Dilate (lMask, lXi,lYi,lZi,5,255 ); + + if lOneContiguousObject then begin + PreserveLargestCluster (lMask, lXi,lYi,lZi,255,0 ); //only preserve largest single object + if lDilateVox >= 1 then + DilateSphere (lMask, lXi,lYi,lZi,lDilateVox,255 ); + end else begin + if lDilateVox >= 1 then + DilateSphere (lMask, lXi,lYi,lZi,lDilateVox,255 ); + PreserveLargestCluster (lMask, lXi,lYi,lZi,0,255 ); //only erase outside air + end; + lV:=0; + for lZ := 1 to lZi do + for lY := 1 to lYi do + for lX := 1 to lXi do begin + inc(lV); + if (lMask^[lV] = 0) or (lX=1) or (lX=lXi) or (lY=1) or (lY=lYi) or (lZ=1) or (lZ=lZi) then + lImg^[lV] := 0; + + end; + freemem(lMask); +end; + +(*procedure MaskBackground (var lImg: Bytep; lXi,lYi,lZi: integer); +var + lMask: ByteP; + lX,lXYZ: integer; +begin + lXYZ := lXi * lYi * lZi; + if (lXi < 3) or (lYi < 3) or (lZi < 1) then + exit; + getmem(lMask, lXYZ); + Move(lImg^[1], lMask^[1],lXYZ); + SmoothFWHM2Vox(lMask, lXi,lYi,lZi); + ApplyOtsuBinary (lMask, lXYZ); + //Dilate (lMask, lXi,lYi,lZi,5,255 ); + DilateSphere (lMask, lXi,lYi,lZi,5,255 ); + PreserveLargestCluster (lMask, lXi,lYi,lZi,0,255 ); + for lX := 1 to lXYZ do + if lMask^[lX] = 0 then + lImg^[lX] := 0; + freemem(lMask); +end;*) + +procedure CountClusterSize (var lImg: Bytep; var lClusterBuff: longintp; lXi,lYi,lZi: integer; lClusterValue: byte); +//Given volume lImg, will generate volume lCount with number of connected voxels with value lCluster +var + lStart: DWord; + lTopSlice,lInc,lXY,lXYZ,lClusterSign,lQTail,lQHead,lQSz,lClusterSz,lClusterFillValue: integer; + lQra: LongIntP; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; //nested incQra +procedure Check(lPixel: integer); + begin + if (lClusterBuff^[lPixel]=lClusterSign) then begin//add item + incQra(lQHead,lQSz); + inc(lClusterSz); + lClusterBuff^[lPixel] := lClusterFillValue; + lQra^[lQHead] := lPixel; + end; +end;//nested Check +PROCEDURE RetirePixel; //FIFO cleanup , 1410: added 18-voxel check +var + lVal: integer; +BEGIN + lVal := lQra^[lQTail]; + + if (lVal < lTopSlice) and (lVal > lXY) then begin + (* //next code avoids left-right and anterior-posterior wrapping... + if lVal = 0 then begin + //should never happen: unmarked voxel = increment lQTail so not infinite loop + incQra(lQTail,lQSz); //done with this pixel + exit; + end; + lXpos := lVal mod lXi; + if lXpos = 0 then lXPos := lXi; + + lYpos := (1+((lVal-1) div lXi)) mod lYi; + if lYPos = 0 then lYPos := lYi; + + lZpos := ((lVal-1) div lXY)+1; + if (lXPos <= 1) or (lXPos >= lXi) or + (lYPos <= 1) or (lYPos >= lYi) or + (lZPos <= 1) or (lZPos >= lZi) then + // retire and exit +else begin *) + + Check(lVal-1); //left + Check(lVal+1); //right + Check(lVal-lXi); //up + Check(lVal+lXi); //down + Check(lVal-lXY); //up + Check(lVal+lXY); //down +(* //check plane above + lValX := lVal + lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check plane below + lValX := lVal - lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check diagonals of current plane + Check(lVal-lXDimM-1); //up, left + Check(lVal-lXDimM+1); //up, right + + Check(lVal+lXDimM-1); //down, left + Check(lVal+lXDimM+1); //down, right *) +end;{} //not edge + incQra(lQTail,lQSz); //done with this pixel +END; +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +//var lI: integer; +begin + (*if (lClusterBuff^[lPt]<>lClusterSign) then exit;*) + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +procedure SelectClusters (lSign: integer); +var lInc,lV: integer; +begin + for lInc := 1 to lXYZ do begin + if lClusterBuff^[lInc] = lSign then begin + // measure size of the cluster and fill it with kFillValue + lClusterSz := 0; + lClusterSign := lSign; + lClusterFillValue := kFillValue; + FillStart(lInc); + // now fill the cluster with its size (=1 if the voxel was isolated) + if lClusterSz > 1 then begin + for lV := 1 to lXYZ do + if lClusterBuff^[lV] = kFillValue then + lClusterBuff^[lV] := lClusterSz; + end else + lClusterBuff^[lInc] := 1; //fill all voxels in cluster with size of voxel + end;//target color + end; //for each voxel +end; //nested SelectClusters +begin //proc CountClusterSize + if (lXi < 5) or (lYi < 5) or (lZi < 3) then exit; + lXY := lXi*lYi; //offset one slice + lTopSlice := (lZi-1) * lXY; + lXYZ :=lXY*lZi; + lQSz := (lXYZ div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + for lInc := 1 to lXYZ do begin + if lImg^[lInc] = lClusterValue then + lClusterBuff^[lInc] := -1 //target voxel - will be part of a cluster of size 1..XYZ + else + lClusterBuff^[lInc] := 0;//not a target, not part of a cluser, size = 0 + end; + //lStart := GetTickCount; + SelectClusters(-1); //for each voxel with intensity=-1, change value to number of connected voxels in cluster + //fx(GetTickCount-lStart); + //we did not fill bottom slice... + for lInc := 1 to lXY do + if lImg^[lInc] = lClusterValue then + lClusterBuff^[lInc] := lClusterBuff^[lInc+lXY]; + //we did not fill top slice + for lInc := (lTopSlice+1) to (lTopSlice+lXY) do + if lImg^[lInc] = lClusterValue then + lClusterBuff^[lInc] := lClusterBuff^[lInc-lXY]; + + Freemem(lQra); +end; //proc CountClusterSize + +procedure PreserveLargestCluster (var lImg: Bytep; lXi,lYi,lZi: integer; lClusterValue,ValueForSmallClusters: byte ); +var + lC,lXYZ,lX: integer; + lTemp: longintp; +begin + if (lXi < 5) or (lYi < 5) or (lZi < 1) then exit; + lXYZ :=lXi*lYi*lZi; + //ensure at least some voxels exist with clusterValue + lC := 0; + for lX := 1 to lXYZ do + if lImg^[lX] = lClusterValue then inc (lC); + if lC < 2 then + exit;//e.g. if lC = 1 then only a single voxel, which is in fact largest cluster + getmem(lTemp,lXYZ*sizeof(longint)); + CountClusterSize(lImg,lTemp,lXi,lYi,lZi,lClusterValue); + lC := 0; + for lX := 1 to lXYZ do + if lTemp^[lX] > lC then lC := lTemp^[lX]; + if ValueForSmallClusters = 0 then begin + for lX := 1 to lXYZ do + if (lTemp^[lX] >= 0) and (lTemp^[lX] < lC) then //cluster, but not biggest one... + lImg^[lX] := ValueForSmallClusters; + end else for lX := 1 to lXYZ do + if (lTemp^[lX] > 0) and (lTemp^[lX] < lC) then //cluster, but not biggest one... + lImg^[lX] := ValueForSmallClusters; + + freemem(lTemp); + +end; + +procedure Dilate (var lImg: Bytep; lXi,lYi,lZi,lCycles: integer; lChange: byte ); +//Dilates Diamonds - neighbor coefficient = 0 +//Dilate if Change=1 then all voxels where intensity <> 1 but where any neighbors = 1 will become 1 +//Erode if Change=0 then all voxels where intensity <>0 but where any neighbors = 0 will become 0 +//step is repeated for lCycles +var + lC,lX,lY,lZ, lXY,lXYZ,lPos,lOffset,lN: integer; + lTemp: bytep; +begin + if (lXi < 5) or (lYi < 5) or (lZi < 1) then exit; + lXY := lXi*lYi; //offset one slice + lXYZ :=lXY*lZi; + getmem(lTemp,lXYZ); + for lC := 1 to lCycles do begin + Move(lImg^[1], lTemp^[1],lXYZ); + for lZ := 1 to lZi do begin + for lY := 1 to lYi do begin + lOffset := ((lY-1)*lXi) + ((lZ-1) * lXY); + for lX := 1 to lXi do begin + lPos := lOffset + lX; + if (lTemp^[lPos] <> lChange) then begin + if (lX>1) and (lTemp^[lPos-1] = lChange) then lImg^[lPos] := lChange; + if (lX<lXi) and (lTemp^[lPos+1] = lChange) then lImg^[lPos] := lChange; + if (lY>1) and (lTemp^[lPos-lXi] = lChange) then lImg^[lPos] := lChange; + if (lY<lYi) and (lTemp^[lPos+lXi] = lChange) then lImg^[lPos] := lChange; + if (lZ>1) and (lTemp^[lPos-lXY] = lChange) then lImg^[lPos] := lChange; + if (lZ<lZi) and (lTemp^[lPos+lXY] = lChange) then lImg^[lPos] := lChange; + end; //voxel <> lChange + end; + end;//Y + end; //Z + end; + freemem(lTemp); +end; + +procedure SmoothFWHM2Vox (var lImg: Bytep; lXi,lYi,lZi: integer); +const + k0=240;//weight of center voxel + k1=120;//weight of nearest neighbors + k2=15;//weight of subsequent neighbors + kTot=k0+k1+k1+k2+k2; //weight of center plus all neighbors within 2 voxels + kWid = 2; //we will look +/- 2 voxels from center +var + lyPos,lPos,lWSum,lX,lY,lZ,lXi2,lXY,lXY2: integer; + lTemp: bytep; +begin + if (lXi < 5) or (lYi < 5) then exit; + lXY := lXi*lYi; //offset one slice + lXY2 := lXY * 2; //offset two slices + lXi2 := lXi*2;//offset to voxel two lines above or below + getmem(lTemp,lXi*lYi*lZi*sizeof(byte)); + for lPos := 1 to (lXi*lYi*lZi) do + lTemp^[lPos] := lImg^[lPos]; + //smooth horizontally + for lZ := 1 to lZi do begin + for lY := (1) to (lYi) do begin + lyPos := ((lY-1)*lXi) + ((lZ-1)*lXY) ; + for lX := (1+kWid) to (lXi-kWid) do begin + lPos := lyPos + lX; + lWSum := lImg^[lPos-2]*k2+lImg^[lPos-1]*k1 + +lImg^[lPos]*k0 + +lImg^[lPos+1]*k1+lImg^[lPos+2]*k2; + lTemp^[lPos] := lWSum div kTot; + end; {lX} + end; {lY} + end; //lZi + //smooth vertically + + for lPos := 1 to (lXi*lYi*lZi) do + lImg^[lPos] := lTemp^[lPos];//fill in sides + for lZ := 1 to lZi do begin + for lX := (1) to (lXi) do begin + for lY := (1+kWid) to (lYi-kWid) do begin + lPos := ((lY-1)*lXi) + lX + ((lZ-1)*lXY) ; + lWSum := lTemp^[lPos-lXi2]*k2+lTemp^[lPos-lXi]*k1 + +lTemp^[lPos]*k0 + +lTemp^[lPos+lXi]*k1+lTemp^[lPos+lXi2]*k2; + lImg^[lPos] := lWSum div kTot; + end; {lX} + end; //lY + end; //lZ + //if 3rd dimension.... + if lZi >= 5 then begin + //smooth across slices + for lPos := 1 to (lXi*lYi*lZi) do + lTemp^[lPos] := lImg^[lPos]; //fill in sides + for lZ := (1+kWid) to (lZi-kWid) do begin + for lY := (1) to (lYi) do begin + lyPos := ((lY-1)*lXi) + ((lZ-1)*lXY) ; + for lX := (1) to (lXi) do begin + lPos := lyPos + lX; + lWSum := lImg^[lPos-lXY2]*k2+lImg^[lPos-lXY]*k1 + +lImg^[lPos]*k0 + +lImg^[lPos+lXY]*k1+lImg^[lPos+lXY2]*k2; + lTemp^[lPos] := lWSum div kTot; + end; {lX} + end; {lY} + end; //lZi + for lPos := 1 to (lXi*lYi*lZi) do + lImg^[lPos] := lTemp^[lPos]; + end; //at least 5 slices... + //free memory + freemem(lTemp); +end; + +procedure DilateSphere (var lImg: Bytep; lXi,lYi,lZi: integer; lVoxDistance: single; lChange: byte ); +//INPUT: Img is array of bytes 1..XYZ that represents 3D volume, lXi,lYi,lZi are number of voxels in each dimension +// lVoxDistance is search radius (in voxels) +// lChange is the intensity to be changed - if background color: erosion, if foreground color: dilation +//OUTPUT: Eroded/Dilated Img +var + lDxI,lXY,lXYZ,lZ,lY,lX, lVoxOK,lPos: integer; + lDx: single; + lSearch: array of integer; + lTemp: bytep; +function HasNeighbor (lVox: integer): boolean; +var + s,t: integer; +begin + result := true; + for s := 0 to (lVoxOK-1) do begin + t := lVox +lSearch[s]; + if (t > 0) and (t <= lXYZ) and (lTemp^[t] = lChange) then + exit; + end; + result := false; +end; //nested HasNeighbor +begin //proc DilateSphere + if lVoxDistance < 1 then exit; + if lVoxDistance = 1 then begin //much faster to use classic neighbor dilation + Dilate(lImg,Lxi,lYi,lZi,1,lChange); + exit; + end; + if (lXi < 3) or (lYi < 3) or (lZi < 3) then + exit; + lXY := lXi*lYi; //voxels per slice + lXYZ := lXY*lZi; //voxels per volume + //next: make 1D array of all voxels within search sphere: store offset from center + lDxI := trunc(lVoxDistance); //no voxel will be searched further than DxI from center + setlength(lSearch,((lDxI *2)+1)*((lDxI *2)+1)*((lDxI *2)+1) ); + lVoxOK := 0; + for lZ := -lDxI to lDxI do + for lY := -lDxI to lDxI do + for lX := -lDxI to lDxI do begin + lDx := sqrt( sqr(lX)+ sqr(lY)+ sqr(lZ) ); + if (lDx < lVoxDistance) and (lDx > 0) then begin + lSearch[lVoxOK] := lX + (lY*lXi)+(lZ * lXY); //offset to center + inc(lVoxOK); + end; //in range, not center + end; //lX + getmem(lTemp, lXYZ);//we need a temporary buffer, as we will be dilating the original image + Move(lImg^[1], lTemp^[1],lXYZ); + lPos := 0; + for lX := 1 to lXYZ do begin + inc(lPos); + if (lTemp^[lPos] <> lChange) and HasNeighbor(lPos) then + lImg^[lPos] := lChange; + end; //for X, each voxel + freemem(lTemp); //free temporary buffer + lSearch := nil; //free 1D search space +end; //proc DilateSphere + +end. + diff --git a/fdr.pas b/fdr.pas new file mode 100755 index 0000000..086ea44 --- /dev/null +++ b/fdr.pas @@ -0,0 +1,78 @@ +unit fdr; +interface + +uses define_types; +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +procedure qsort(lower, upper : integer; var Data:SingleP); +implementation + +procedure qsort(lower, upper : integer; var Data:SingleP); +//40ms - very recursive... +var + left, right : integer; + pivot,lswap: single; +begin + pivot:=Data^[(lower+upper) div 2]; + left:=lower; + right:=upper; + while left<=right do begin + while Data^[left] < pivot do left:=left+1; { Parting for left } + while Data^[right] > pivot do right:=right-1;{ Parting for right} + if left<=right then begin { Validate the change } + lswap := Data^[left]; + Data^[left] := Data^[right]; + Data^[right] := lswap; + left:=left+1; + right:=right-1; + end; //validate + end;//while left <=right + if right>lower then qsort(lower,right,Data); { Sort the LEFT part } + if upper>left then qsort(left ,upper,data); { Sort the RIGHT part } +end; + +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +var + lInc: integer; + lrPs,Qs: SingleP; +begin + //rank Pvalues + //ShaQuickSort(lnTests,Singlep0(Ps[1])); + qSort(1,lnTests,Ps); + //qcksrt(1,lnTests,Ps); + GetMem(Qs,lnTests*sizeof(single)); + //next findcrit FDR05 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lFDR05 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR05 := Ps^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lFDR01 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR01 := Ps^[lInc]; + //reverse + GetMem(lrPs,lnTests*sizeof(single)); + for lInc := 1 to lnTests do + lrPs^[lInc] := 1- Ps^[lnTests-lInc+1]; + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lnegFDR05 := 0; + for lInc := 1 to lnTests do + if lrPs^[lInc] <= Qs^[lInc] then + lnegFDR05 := lrPs^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lnegFDR01 := 0; + for lInc := 1 to lnTests do + if lrPs^[lInc] <= Qs^[lInc] then + lnegFDR01 := lrPs^[lInc]; + FreeMem(lrPs); + Freemem(Qs); +end; + +end. diff --git a/fpc-res.res b/fpc-res.res new file mode 100755 index 0000000..55de182 Binary files /dev/null and b/fpc-res.res differ diff --git a/fpmath/changes.txt b/fpmath/changes.txt new file mode 100755 index 0000000..ef2a3cd --- /dev/null +++ b/fpmath/changes.txt @@ -0,0 +1,24 @@ +Version 0.50 +------------ + +* Added a compilation script for Linux (fpcompil.sh) + +* A graphic library (tpgraph) has been added, with two versions: one for Delphi, one for the Graph unit. The Linux version requires SVGAlib installed and functional. + +* With FPC, the libraries are now compiled in Delphi mode (option -Mdelphi) to ensure that the Integer type is 32 bits. The calling programs should be compiled with the same option (modify the FPC configuration file if necessary). + +* The number of points which can be handled by the FFT procedures has been increased (up to 2^26 in double precision) + +* More statistical methods in the main library : + + - Comparison of means and variances + - Analysis of variance + - Non-parametric tests (Wilcoxon, Mann-Whitney, Kruskal-Wallis) + - Histograms + - Comparison of distributions (Khi-2 and Woolf tests) + - Linear, multilinear and nonlinear regressions + - Monte-Carlo simulation of the distribution of regression parameters + - Principal component analysis + +* Added some string functions + diff --git a/fpmath/demo/curfit/mcsim.pas b/fpmath/demo/curfit/mcsim.pas new file mode 100755 index 0000000..a66a08a --- /dev/null +++ b/fpmath/demo/curfit/mcsim.pas @@ -0,0 +1,170 @@ +{ ****************************************************************** + Monte-Carlo simulation of the statistical distribution + of the regression parameters for the exponential model: + Y = B(1) * Exp(- B(2) * X) + ****************************************************************** } + +program mcsim; + +uses + tpmath, tpgraph; + +const + FuncName = 'Y = B(1) * Exp(- B(2) * X)'; + +const + NCycles = 10; { Number of cycles } + MaxSim = 1000; { Max nb of simulations at each cycle } + SavedSim = 1000; { Nb of simulations to be saved } + MCFile = 'mcsim.txt'; { File for storing simulation results } + +const + N = 10; { Number of points } + FirstPar = 1; { Index of first fitted parameter } + LastPar = 2; { Index of last fitted parameter } + +{ Data } +const + X : array[1..N] of Float = ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10); + Y : array[1..N] of Float = (416, 319, 244, 188, 144, 113, 85, 66, 50, 41); + +function RegFunc(X : Float; B : PVector) : Float; +begin + RegFunc := B^[1] * Exp(- B^[2] * X); +end; + +procedure WriteResults(B : PVector; V : PMatrix); +{ ------------------------------------------------------------------ + Writes results to screen + ------------------------------------------------------------------ } + +var + Line1, + Line2 : String; { Separating lines } + SB : Float; { Standard deviations of parameters } + I : Integer; { Loop variable } + +begin + Line1 := StrChar(73, '-'); + Line2 := StrChar(73, '='); + + WriteLn(Line2); + WriteLn('Monte-Carlo simulation : ', FuncName); + WriteLn(Line1); + + WriteLn('Parameter Est.value Std.dev. '); + + WriteLn(Line1); + + for I := FirstPar to LastPar do + begin + SB := Sqrt(V^[I]^[I]); + WriteLn('B(', I:1, ')', B^[I]:17:8, SB:17:8); + end; + + WriteLn(Line2); +end; + +procedure PlotGraph(B1, B2 : PVector); +{ ------------------------------------------------------------------ + Plots simulation results + ------------------------------------------------------------------ } + +var + Xmin, Xmax, Xstep : Float; { Ox scale } + Ymin, Ymax, Ystep : Float; { Oy scale } + +begin + if not InitGraphics(9, 2, 'c:\tp\bgi') then { 640x480 16 color } + begin + Writeln('Unable to set graphic mode'); + Exit; + end; + + SetWindow(15, 85, 15, 85, True); + + AutoScale(B1, 1, SavedSim, LinScale, Xmin, Xmax, Xstep); + AutoScale(B2, 1, SavedSim, LinScale, Ymin, Ymax, Ystep); + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetGraphTitle('Monte-Carlo simulation : ' + FuncName); + SetOxTitle('B(1)'); + SetOyTitle('B(2)'); + + SetFormat(10, 4, False, False); + + PlotOxAxis; + PlotOyAxis; + + WriteGraphTitle; + + SetClipping(True); + + SetLineParam(1, 0, 0, 0); { Don't connect points } + PlotCurve(B1, B2, 1, SavedSim, 1); + + Readln; + + LeaveGraphics; +end; + +var + XX, YY : PVector; { Data } + B : PVector; { Regression parameters } + V : PMatrix; { Variance-covariance matrix } + B1, B2 : PVector; { Simulated parameters } + F : Text; { Output file } + Iter : Integer; { Iteration number } + I : Integer; { Loop variable } + +begin + DimVector(XX, N); + DimVector(YY, N); + DimVector(B, LastPar); + DimMatrix(V, LastPar, LastPar); + DimVector(B1, SavedSim); + DimVector(B2, SavedSim); + + { Read data } + for I := 1 to N do + begin + XX^[I] := X[I]; + YY^[I] := Y[I]; + end; + + { Initialize parameters } + SetParamBounds(1, 100, 1000); + SetParamBounds(2, 0.1, 1); + + { Set Metropolis-Hastings parameters } + InitMHParams(NCycles, MaxSim, SavedSim); + + { Set output file and numeric format } + SetMCFile(MCFile); + SetFormat(10, 4, False, True); + + { Perform simulation } + SimFit({$IFDEF FPC}@{$ENDIF}RegFunc, XX, YY, 1, N, B, FirstPar, LastPar, V); + + { Retrieve simulation results into vectors B1 and B2 } + Assign(F, MCFile); + Reset(F); + for I := 1 to SavedSim do + ReadLn(F, Iter, B1^[I], B2^[I]); + Close(F); + + { Write results } + WriteResults(B, V); + + { Plot curve } + PlotGraph(B1, B2); + + DelVector(XX, N); + DelVector(YY, N); + DelVector(B, LastPar); + DelMatrix(V, LastPar, LastPar); + DelVector(B1, SavedSim); + DelVector(B2, SavedSim); +end. diff --git a/fpmath/demo/curfit/pcatest.pas b/fpmath/demo/curfit/pcatest.pas new file mode 100755 index 0000000..337097b --- /dev/null +++ b/fpmath/demo/curfit/pcatest.pas @@ -0,0 +1,133 @@ +{ ****************************************************************** + Correlation and principal component analysis + ****************************************************************** + Example taken from: + P. DAGNELIE, Analyse statistique a plusieurs variables, + Presses Agronomiques de Gembloux, Belgique, 1982 + ****************************************************************** } + +program pcatest; + +uses + tpmath; + +const + N = 11; { Number of observations } + Nvar = 4; { Number of variables } + +{ Data } +const X : array[1..N, 1..Nvar] of Float = +(( 87.9, 19.6, 1 , 1661), + ( 89.9, 15.2, 90.1, 968), + (153 , 19.7, 56.6, 1353), + (132.1, 17 , 91 , 1293), + ( 88.8, 18.3, 93.7, 1153), + (220.9, 17.8, 106.9, 1286), + (117.7, 17.8, 65.5, 1104), + (109 , 18.3, 41.8, 1574), + (156.1, 17.8, 57.4, 1222), + (181.5, 16.8, 140.6, 902), + (181.4, 17 , 74.3, 1150)); + +var + XX : PMatrix; { Data } + M : PVector; { Mean vector } + V : PMatrix; { Variance-covariance matrix } + R : PMatrix; { Correlation matrix } + S : PVector; { Standard deviations } + Lambda : PVector; { Eigenvalues of correlation matrix } + C : PMatrix; { Eigenvectors of correlation matrix } + Rc : PMatrix; { Correlation factors/variables } + Z : PMatrix; { Scaled variables } + F : PMatrix; { Principal factors } + I, J : Integer; { Loop variables } + +procedure PrintMatrix(Title : String; A : PMatrix; Ub1, Ub2 : Integer); +{ ------------------------------------------------------------------ + Print matrix A[1..Ub1, 1..Ub2] + ------------------------------------------------------------------ } +var + I, J : Integer; +begin + Writeln; Writeln(Title); Writeln; + + for I := 1 to Ub1 do + begin + for J := 1 to Ub2 do + Write(A^[I]^[J]:12:4); + Writeln; + end; +end; + +procedure PrintVector(Title : String; B : PVector; Ub : Integer); +{ ------------------------------------------------------------------ + Print vector B[1..Ub] + ------------------------------------------------------------------ } +var + I : Integer; +begin + Writeln; Writeln(Title); Writeln; + + for I := 1 to Ub do + Writeln(B^[I]:12:4); +end; + +begin + DimMatrix(XX, N, Nvar); + DimVector(M, Nvar); + DimMatrix(V, Nvar, Nvar); + DimMatrix(R, Nvar, Nvar); + DimVector(S, Nvar); + DimVector(Lambda, Nvar); + DimMatrix(C, Nvar, Nvar); + DimMatrix(Rc, Nvar, Nvar); + DimMatrix(Z, N, Nvar); + DimMatrix(F, N, Nvar); + + { Read data } + for I := 1 to N do + for J := 1 to Nvar do + XX^[I]^[J] := X[I,J]; + + { Compute mean vector } + VecMean(XX, 1, N, Nvar, M); + + { Compute variance-covariance matrix } + MatVarCov(XX, 1, N, Nvar, M, V); + + { Compute correlation matrix } + MatCorrel(V, Nvar, R); + + { Display results } + Writeln; + PrintVector('Mean vector', M, Nvar); + PrintMatrix('Variance-covariance matrix', V, Nvar, Nvar); + PrintMatrix('Correlation matrix', R, Nvar, Nvar); + + { Compute standard deviations } + VecSD(XX, 1, N, Nvar, M, S); + + { Scale variables } + ScaleVar(XX, 1, N, Nvar, M, S, Z); + + { Perform principal component analysis + The original matrix R is destroyed } + PCA(R, Nvar, 1000, 1.0E-10, Lambda, C, Rc); + + if MathErr = MatNonConv then + begin + Writeln('Non-convergence of eigenvalue computation'); + Exit; + end; + + { Compute principal factors } + PrinFac(Z, 1, N, Nvar, C, F); + + { Display results } + Writeln; + PrintVector('Eigenvalues of correlation matrix', Lambda, Nvar); + PrintMatrix('Eigenvectors (columns) of correlation matrix', C, Nvar, Nvar); + PrintMatrix('Correlations between factors (columns) and variables (lines)', Rc, Nvar, Nvar); + PrintMatrix('Principal factors', F, N, Nvar); +end. + diff --git a/fpmath/demo/curfit/reglin.pas b/fpmath/demo/curfit/reglin.pas new file mode 100755 index 0000000..db62b0c --- /dev/null +++ b/fpmath/demo/curfit/reglin.pas @@ -0,0 +1,188 @@ +{ ****************************************************************** + This program performs a least squares fit of a straight line: + Y = B(0) + B(1) * X + ****************************************************************** } + +program reglin; + +uses + tpmath, tpgraph; + +const + N = 5; { Number of points } + Alpha = 0.05; { Significance level } + +{ Data } +const + X : array[1..N] of Float = (10, 20, 30, 40, 50); + Y : array[1..N] of Float = ( 0.1865, 0.3616, 0.537, 0.7359, 0.9238); + +var + B : PVector; { Regression parameters } + +function PltFunc(X : Float) : Float; +{ ------------------------------------------------------------------ + Function to be plotted + ------------------------------------------------------------------ } + +begin + PltFunc := B^[0] + B^[1] * X +end; + +procedure WriteResults(X, Y, Ycalc, B : PVector; + V : PMatrix; + Test : TRegTest; + Tc, Fc : Float); +{ ------------------------------------------------------------------ + Writes results to screen + ------------------------------------------------------------------ } + +var + Line1, + Line2 : String; { Separating lines } + Delta : Float; { Residual } + Sr : Float; { Residual standard deviation } + SB : Float; { Standard deviations of parameters } + I : Integer; { Loop variable } + +begin + Line1 := StrChar(73, '-'); + Line2 := StrChar(73, '='); + + WriteLn(Line2); + WriteLn('Linear regression: Y = B(0) + B(1) * X'); + WriteLn(Line1); + + WriteLn('Parameter Est.value Std.dev. ', + (100 * (1 - Alpha)):2:0, '% Confidence Interval'); + + WriteLn(Line1); + + for I := 0 to 1 do + begin + SB := Sqrt(V^[I]^[I]); + WriteLn('B(', I:1, ')', B^[I]:17:8, SB:17:8, + (B^[I] - Tc * SB):17:8, ';', (B^[I] + Tc * SB):17:8); + end; + + WriteLn(Line1); + + WriteLn('Number of observations : n = ', N:5); + + with Test do + begin + Sr := Sqrt(Vr); + WriteLn('Residual error : s = ', Sr:10:4); + WriteLn('Coefficient of correlation : r = ', (Sgn(B^[1]) * Sqrt(R2)):10:4); + WriteLn('Coefficient of determination : r2 = ', R2:10:4); + WriteLn('Adjusted coeff. of determination : r2a = ', R2a:10:4); + WriteLn('Variance ratio (explained/resid.) : F(', Nu1:3, ', ', Nu2:3, ') = ', F:10:4); + WriteLn('Critical variance ratio : F(p = ', (1 - Alpha):4:2, ') = ', Fc:10:4); + end; + + WriteLn(Line1); + WriteLn(' i Y obs. Y calc. Residual Std.dev. Std.res.'); + WriteLn(Line1); + + for I := 1 to N do + begin + Delta := Y^[I] - Ycalc^[I]; + WriteLn(I:3, Y^[I]:14:4, Ycalc^[I]:14:4, Delta:14:4, Sr:14:4, (Delta / Sr):14:4); + end; + + WriteLn(Line2); +end; + +procedure PlotGraph(X, Y, B : PVector); +{ ------------------------------------------------------------------ + Plots histogram and normal curve + ------------------------------------------------------------------ } + +var + Xmin, Xmax, Xstep : Float; { Ox scale } + Ymin, Ymax, Ystep : Float; { Oy scale } + +begin + if not InitGraphics(9, 2, 'c:\tp\bgi') then { 640x480 16 color } + begin + Writeln('Unable to set graphic mode'); + Exit; + end; + + SetWindow(15, 85, 15, 85, True); + + AutoScale(X, 1, N, LinScale, Xmin, Xmax, Xstep); + AutoScale(Y, 1, N, LinScale, Ymin, Ymax, Ystep); + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetGraphTitle('Linear Regression'); + SetOxTitle('X'); + SetOyTitle('Y'); + + PlotOxAxis; + PlotOyAxis; + + WriteGraphTitle; + + SetClipping(True); + + SetLineParam(1, 0, 0, 0); { Don't connect points } + PlotCurve(X, Y, 1, N, 1); + + PlotFunc({$IFDEF FPC}@{$ENDIF}PltFunc, Xmin, Xmax, 2); + + Readln; + + LeaveGraphics; +end; + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + XX, YY : PVector; { Data } + Ycalc : PVector; { Computed Y values } + V : PMatrix; { Variance-covariance matrix } + Test : TRegTest; { Statistical tests } + Tc : Float; { Critical t value } + Fc : Float; { Critical F value } + I : Integer; { Loop variable } + +begin + { Dimension arrays } + DimVector(XX, N); + DimVector(YY, N); + DimVector(Ycalc, N); + DimVector(B, 1); + DimMatrix(V, 1, 1); + + { Read data } + for I := 1 to N do + begin + XX^[I] := X[I]; + YY^[I] := Y[I]; + end; + + { Perform regression } + LinFit(XX, YY, 1, N, B, V); + + { Compute predicted Y values } + for I := 1 to N do + Ycalc^[I] := B^[0] + B^[1] * XX^[I]; + + { Update variance-covariance matrix and compute statistical tests } + RegTest(YY, Ycalc, 1, N, V, 0, 1, Test); + + { Compute Student's t and Snedecor's F } + Tc := InvStudent(N - 2, 1 - 0.5 * Alpha); + Fc := InvSnedecor(1, N - 2, 1 - Alpha); + + { Write results } + WriteResults(XX, YY, Ycalc, B, V, Test, Tc, Fc); + + { Plot curve } + PlotGraph(XX, YY, B); +end. diff --git a/fpmath/demo/curfit/regmult.pas b/fpmath/demo/curfit/regmult.pas new file mode 100755 index 0000000..e057c87 --- /dev/null +++ b/fpmath/demo/curfit/regmult.pas @@ -0,0 +1,244 @@ +{ ****************************************************************** + This program performs a multiple linear least squares fit: + Y = B(0) + B(1) * X1 + B(2) * X2 + ... + ****************************************************************** } + +program regmult; + +uses + tpmath, tpgraph; + +const + N = 23; { Number of observations } + Nvar = 4; { Number of independent variables } + Alpha = 0.05; { Significance level } + ConsTerm = True; { Include a constant term B(0) } + +{ Data } +const X : array[1..N, 1..Nvar] of Float = +((-0.27, 7.327, 0, 0), + (-0.55, 7.4 , 0, 0), + (-0.53, 7.74 , 0, 0), + (-0.57, 7.95 , 0, 0), + (-0.87, 7.9 , 0, 0), + (-1.36, 7.931, 0, 0), + (-0.39, 6.849, 0, 0), + (-0.66, 7.508, 0, 0), + (-0.33, 7.419, 0, 0), + (-1.7 , 7.496, 0, 0), + (-0.68, 7.027, 0, 0), + (-0.79, 8.15 , 0, 0), + (-0.82, 8.822, 0, 0), + (-0.66, 8.334, 0, 0), + ( 0.02, 7.421, 0, 0), + ( 0.06, 7.862, 1, 0), + (-0.3 , 8.483, 1, 0), + ( 0.07, 9.82 , 0, 0), + ( 0 , 7.641, 1, 0), + (-0.8 , 7.601, 0, 1), + (-1.05, 7.565, 0, 1), + (-0.35, 7.993, 0, 0), + (-0.11, 7.13 , 0, 0)); + +const Y : array[1..N] of Float = +(3.21, + 3.94, + 3.66, + 3.99, + 4.06, + 4.09, + 3.36, + 3.92, + 3.58, + 4.26, + 3.06, + 4.13, + 4.27, + 4.36, + 3.72, + 3.89, + 4.39, + 3.92, + 3.89, + 5.1 , + 5.14, + 3.68, + 3.7); + +{ ****************************************************************** + Subprograms + ****************************************************************** } + +procedure WriteResults(Y, Ycalc : PVector; + B : PVector; + V : PMatrix; + Test : TRegTest; + Tc, Fc : Float); +{ ------------------------------------------------------------------ + Writes results to screen + ------------------------------------------------------------------ } + +var + Line1, + Line2 : String; { Separating lines } + Delta : Float; { Residual } + Sr : Float; { Residual standard deviation } + SB : Float; { Standard deviations of parameters } + Lb : Integer; { Index of first parameter } + I : Integer; { Loop variable } + +begin + Line1 := StrChar(73, '-'); + Line2 := StrChar(73, '='); + + WriteLn(Line2); + Write('Multiple linear regression: Y = '); + if ConsTerm then Write('B(0) + '); + WriteLn('B(1) * X1 + B(2) * X2 + ...'); + WriteLn(Line1); + + WriteLn('Parameter Est.value Std.dev. ', + (100 * (1 - Alpha)):2:0, '% Confidence Interval'); + + WriteLn(Line1); + + if ConsTerm then Lb := 0 else Lb := 1; + + for I := Lb to Nvar do + begin + SB := Sqrt(V^[I]^[I]); + WriteLn('B(', I:1, ')', B^[I]:17:8, SB:17:8, + (B^[I] - Tc * SB):17:8, ';', (B^[I] + Tc * SB):17:8); + end; + + WriteLn(Line1); + + WriteLn('Number of observations : n = ', N:5); + + with Test do + begin + Sr := Sqrt(Vr); + WriteLn('Residual error : s = ', Sr:10:4); + WriteLn('Coefficient of correlation : r = ', (Sgn(B^[1]) * Sqrt(R2)):10:4); + WriteLn('Coefficient of determination : r2 = ', R2:10:4); + WriteLn('Adjusted coeff. of determination : r2a = ', R2a:10:4); + WriteLn('Variance ratio (explained/resid.) : F(', Nu1:3, ', ', Nu2:3, ') = ', F:10:4); + WriteLn('Critical variance ratio : F(p = ', (1 - Alpha):4:2, ') = ', Fc:10:4); + end; + + WriteLn(Line1); + WriteLn(' i Y obs. Y calc. Residual Std.dev. Std.res.'); + WriteLn(Line1); + + for I := 1 to N do + begin + Delta := Y^[I] - Ycalc^[I]; + WriteLn(I:3, Y^[I]:14:4, Ycalc^[I]:14:4, Delta:14:4, Sr:14:4, (Delta / Sr):14:4); + end; + + WriteLn(Line2); +end; + +procedure PlotGraph(Y, Ycalc : PVector); +{ ------------------------------------------------------------------ + Plots observed vs calculated Y values + ------------------------------------------------------------------ } + +var + Xmin, Xmax, Xstep : Float; { Ox scale } + Ymin, Ymax, Ystep : Float; { Oy scale } + +begin + if not InitGraphics(9, 2, 'c:\tp\bgi') then { 640x480 16 color } + begin + Writeln('Unable to set graphic mode'); + Exit; + end; + + SetWindow(15, 85, 15, 85, True); + + AutoScale(Y, 1, N, LinScale, Xmin, Xmax, Xstep); + AutoScale(Ycalc, 1, N, LinScale, Ymin, Ymax, Ystep); + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetGraphTitle('Multiple Linear Regression'); + SetOxTitle('Y obs.'); + SetOyTitle('Y calc.'); + + PlotOxAxis; + PlotOyAxis; + + WriteGraphTitle; + + SetClipping(True); + + SetLineParam(1, 0, 0, 0); { Don't connect points } + PlotCurve(Y, Ycalc, 1, N, 1); + + Readln; + + LeaveGraphics; +end; + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + XX : PMatrix; { Independent variables } + YY : PVector; { Dependent variable } + Ycalc : PVector; { Computed Y values } + B : PVector; { Fitted parameters } + V : PMatrix; { Variance-covariance matrix } + Test : TRegTest; { Statistical tests } + Tc : Float; { Critical t value } + Fc : Float; { Critical F value } + Lb : Integer; { Index of first parameter } + I, J : Integer; { Loop variable } + +begin + { Dimension arrays } + DimMatrix(XX, N, Nvar); + DimVector(YY, N); + DimVector(Ycalc, N); + DimVector(B, Nvar); + DimMatrix(V, Nvar, Nvar); + + { Read data } + for I := 1 to N do + begin + for J := 1 to Nvar do + XX^[I]^[J] := X[I,J]; + YY^[I] := Y[I]; + end; + + { Perform regression } + { MulFit(XX, YY, 1, N, Nvar, ConsTerm, B, V); } + SVDFit(XX, YY, 1, N, Nvar, ConsTerm, 1.0E-8, B, V); + + { Compute predicted Y values } + for I := 1 to N do + begin + if ConsTerm then Ycalc^[I] := B^[0] else Ycalc^[I] := 0.0; + for J := 1 to Nvar do + Ycalc^[I] := Ycalc^[I] + B^[J] * XX^[I]^[J]; + end; + + { Update variance-covariance matrix and compute statistical tests } + if ConsTerm then Lb := 0 else Lb := 1; + RegTest(YY, Ycalc, 1, N, V, Lb, Nvar, Test); + + { Compute Student's t and Snedecor's F } + Tc := InvStudent(Test.Nu2, 1 - 0.5 * Alpha); + Fc := InvSnedecor(Test.Nu1, Test.Nu2, 1 - Alpha); + + { Write results } + WriteResults(YY, Ycalc, B, V, Test, Tc, Fc); + + Readln; + + { Plot curve } + PlotGraph(YY, Ycalc); +end. diff --git a/fpmath/demo/curfit/regnlin.pas b/fpmath/demo/curfit/regnlin.pas new file mode 100755 index 0000000..bafafb2 --- /dev/null +++ b/fpmath/demo/curfit/regnlin.pas @@ -0,0 +1,264 @@ +{ ****************************************************************** + Nonlinear regression + ****************************************************************** } + +program regnlin; + +uses + tpmath, tpgraph; + +const + FuncName = 'Y = B(1) * Exp(- B(2) * X)'; + + N = 10; { Number of points } + FirstPar = 1; { Index of first fitted parameter } + LastPar = 2; { Index of last fitted parameter } + MaxIter = 1000; { Max. number of iterations } + Tol = 1.0E-3; { Required precision } + Alpha = 0.05; { Significance level } + +{ Data } +const + X : array[1..N] of Float = ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10); + Y : array[1..N] of Float = (416, 319, 244, 188, 144, 113, 85, 66, 50, 41); + +var + B : PVector; { Regression parameters } + +procedure ApproxFit(B : PVector); +{ ------------------------------------------------------------------ + Approximate fit of the exponential model by weighted linear + regression: Ln(Y) = Ln(B(1)) - B(2) * X + ------------------------------------------------------------------ } + +var + P : Integer; { Nb. of points for linear reg. } + K : Integer; { Loop variable } + X1, Y1 : PVector; { Transformed coordinates } + S1 : PVector; { Standard deviations } + A : PVector; { Linear regression param. Y = A^[0] + A^[1] * X } + V : PMatrix; { Variance-covariance matrix } + +begin + P := 0; { Count the number of points } + for K := 1 to N do { which can be transformed } + if Y[K] > 0.0 then Inc(P); + + DimVector(X1, P); + DimVector(Y1, P); + DimVector(S1, P); + + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + for K := 1 to N do + if Y[K] > 0.0 then + begin + Inc(P); + X1^[P] := X[K]; + Y1^[P] := Ln(Y[K]); + S1^[P] := 1.0 / Y[K]; + end; + + WLinFit(X1, Y1, S1, 1, P, A, V); + + if MathErr = MatOk then + begin + B^[1] := Exp(A^[0]); + B^[2] := - A^[1]; + end; + + DelVector(A, 1); + DelMatrix(V, 1, 1); +end; + +function RegFunc(X : Float; B : PVector) : Float; +begin + RegFunc := B^[1] * Exp(- B^[2] * X); +end; + +procedure DerivProc(X, Y : Float; B, D : PVector); +begin + D^[1] := Exp(- B^[2] * X); + D^[2] := - B^[1] * X * D^[1]; +end; + +procedure WriteResults(X, Y, Ycalc, B : PVector; + V : PMatrix; + Test : TRegTest; + Tc, Fc : Float); +{ ------------------------------------------------------------------ + Writes results to screen + ------------------------------------------------------------------ } + +var + Line1, + Line2 : String; { Separating lines } + Delta : Float; { Residual } + Sr : Float; { Residual standard deviation } + SB : Float; { Standard deviations of parameters } + I : Integer; { Loop variable } + +begin + Line1 := StrChar(73, '-'); + Line2 := StrChar(73, '='); + + WriteLn(Line2); + WriteLn('Nonlinear regression: ', FuncName); + WriteLn(Line1); + + WriteLn('Parameter Est.value Std.dev. ', + (100 * (1 - Alpha)):2:0, '% Confidence Interval'); + + WriteLn(Line1); + + for I := FirstPar to LastPar do + begin + SB := Sqrt(V^[I]^[I]); + WriteLn('B(', I:1, ')', B^[I]:17:8, SB:17:8, + (B^[I] - Tc * SB):17:8, ';', (B^[I] + Tc * SB):17:8); + end; + + WriteLn(Line1); + + WriteLn('Number of observations : n = ', N:5); + + with Test do + begin + Sr := Sqrt(Vr); + WriteLn('Residual error : s = ', Sr:10:4); + + if R2 <= 1.0 then + begin + WriteLn('Coefficient of correlation : r = ', (Sqrt(R2)):10:4); + WriteLn('Coefficient of determination : r2 = ', R2:10:4); + WriteLn('Adjusted coeff. of determination : r2a = ', R2a:10:4); + end; + + WriteLn('Variance ratio (explained/resid.) : F(', Nu1:3, ', ', Nu2:3, ') = ', F:10:4); + WriteLn('Critical variance ratio : F(p = ', (1 - Alpha):4:2, ') = ', Fc:10:4); + end; + + WriteLn(Line1); + WriteLn(' i Y obs. Y calc. Residual Std.dev. Std.res.'); + WriteLn(Line1); + + for I := 1 to N do + begin + Delta := Y^[I] - Ycalc^[I]; + WriteLn(I:3, Y^[I]:14:4, Ycalc^[I]:14:4, Delta:14:4, Sr:14:4, (Delta / Sr):14:4); + end; + + WriteLn(Line2); +end; + +function PltFunc(X : Float) : Float; +{ ------------------------------------------------------------------ + Function to be plotted + ------------------------------------------------------------------ } +begin + PltFunc := RegFunc(X, B); +end; + +procedure PlotGraph(X, Y, B : PVector); +{ ------------------------------------------------------------------ + Plots points and fitted curve + ------------------------------------------------------------------ } + +var + Xmin, Xmax, Xstep : Float; { Ox scale } + Ymin, Ymax, Ystep : Float; { Oy scale } + +begin + if not InitGraphics(9, 2, 'c:\tp\bgi') then { 640x480 16 color } + begin + Writeln('Unable to set graphic mode'); + Exit; + end; + + SetWindow(15, 85, 15, 85, True); + + AutoScale(X, 1, N, LinScale, Xmin, Xmax, Xstep); + AutoScale(Y, 1, N, LinScale, Ymin, Ymax, Ystep); + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetGraphTitle('Polynomial Regression'); + SetOxTitle('X'); + SetOyTitle('Y'); + + PlotOxAxis; + PlotOyAxis; + + WriteGraphTitle; + + SetClipping(True); + + SetLineParam(1, 0, 0, 0); { Don't connect points } + PlotCurve(X, Y, 1, N, 1); + + PlotFunc({$IFDEF FPC}@{$ENDIF}PltFunc, Xmin, Xmax, 2); + + Readln; + + LeaveGraphics; +end; + +var + XX, YY : PVector; { Data } + Ycalc : PVector; { Computed Y values } + V : PMatrix; { Variance-covariance matrix } + Test : TRegTest; { Statistical tests } + Tc : Float; { Critical t value } + Fc : Float; { Critical F value } + I : Integer; { Loop variable } + +begin + DimVector(XX, N); + DimVector(YY, N); + DimVector(Ycalc, N); + DimVector(B, LastPar); + DimMatrix(V, LastPar, LastPar); + + { Read data } + for I := 1 to N do + begin + XX^[I] := X[I]; + YY^[I] := Y[I]; + end; + + ApproxFit(B); + + NLFit({$IFDEF FPC}@{$ENDIF}RegFunc, {$IFDEF FPC}@{$ENDIF}DerivProc, + XX, YY, 1, N, MaxIter, Tol, B, FirstPar, LastPar, V); + + if MathErr = MatOk then + begin + { Compute predicted Y values } + for I := 1 to N do + Ycalc^[I] := RegFunc(XX^[I], B); + + { Update variance-covariance matrix and compute statistical tests } + RegTest(YY, Ycalc, 1, N, V, FirstPar, LastPar, Test); + + { Compute Student's t and Snedecor's F } + Tc := InvStudent(Test.Nu2, 1 - 0.5 * Alpha); + Fc := InvSnedecor(Test.Nu1, Test.Nu2, 1 - Alpha); + + { Write results } + WriteResults(XX, YY, Ycalc, B, V, Test, Tc, Fc); + + { Plot curve } + PlotGraph(XX, YY, B); + end + else + Writeln('Unable to fit curve!'); + + DelVector(XX, N); + DelVector(YY, N); + DelVector(Ycalc, N); + DelVector(B, LastPar); + DelMatrix(V, LastPar, LastPar); +end. diff --git a/fpmath/demo/curfit/regpoly.pas b/fpmath/demo/curfit/regpoly.pas new file mode 100755 index 0000000..e4d32f3 --- /dev/null +++ b/fpmath/demo/curfit/regpoly.pas @@ -0,0 +1,194 @@ +{ ****************************************************************** + This program performs a least squares fit of a polynomial: + Y = B(0) + B(1) * X + B(2) * Xý + ... + ****************************************************************** } + +program regpoly; + +uses + tpmath, tpgraph; + +const + N = 12; { Number of points } + Deg = 2; { Degree of polynomial } + Alpha = 0.05; { Significance level } + +{ Data } +const + X : array[1..N] of Float = + (0, 0.0136, 0.023, 0.0352, 0.048, 0.075, + 0.1067, 0.1374, 0.1734, 0.2139, 0.2594, 0.3113); + + Y : array[1..N] of Float = + (3.97, 4.03, 4.1, 4.2, 4.28, 4.47, + 4.66, 4.83, 4.99, 5.12, 5.25, 5.37); + +var + B : PVector; { Regression parameters } + +function PltFunc(X : Float) : Float; +{ ------------------------------------------------------------------ + Function to be plotted + ------------------------------------------------------------------ } + +begin + PltFunc := Poly(X, B, Deg); +end; + +procedure WriteResults(X, Y, Ycalc, B : PVector; + V : PMatrix; + Test : TRegTest; + Tc, Fc : Float); +{ ------------------------------------------------------------------ + Writes results to screen + ------------------------------------------------------------------ } + +var + Line1, + Line2 : String; { Separating lines } + Delta : Float; { Residual } + Sr : Float; { Residual standard deviation } + SB : Float; { Standard deviations of parameters } + I : Integer; { Loop variable } + +begin + Line1 := StrChar(73, '-'); + Line2 := StrChar(73, '='); + + WriteLn(Line2); + WriteLn('Polynomial regression: Y = B(0) + B(1) * X + B(2) * Xý + ...'); + WriteLn(Line1); + + WriteLn('Parameter Est.value Std.dev. ', + (100 * (1 - Alpha)):2:0, '% Confidence Interval'); + + WriteLn(Line1); + + for I := 0 to Deg do + begin + SB := Sqrt(V^[I]^[I]); + WriteLn('B(', I:1, ')', B^[I]:17:8, SB:17:8, + (B^[I] - Tc * SB):17:8, ';', (B^[I] + Tc * SB):17:8); + end; + + WriteLn(Line1); + + WriteLn('Number of observations : n = ', N:5); + + with Test do + begin + Sr := Sqrt(Vr); + WriteLn('Residual error : s = ', Sr:10:4); + WriteLn('Coefficient of correlation : r = ', (Sqrt(R2)):10:4); + WriteLn('Coefficient of determination : r2 = ', R2:10:4); + WriteLn('Adjusted coeff. of determination : r2a = ', R2a:10:4); + WriteLn('Variance ratio (explained/resid.) : F(', Nu1:3, ', ', Nu2:3, ') = ', F:10:4); + WriteLn('Critical variance ratio : F(p = ', (1 - Alpha):4:2, ') = ', Fc:10:4); + end; + + WriteLn(Line1); + WriteLn(' i Y obs. Y calc. Residual Std.dev. Std.res.'); + WriteLn(Line1); + + for I := 1 to N do + begin + Delta := Y^[I] - Ycalc^[I]; + WriteLn(I:3, Y^[I]:14:4, Ycalc^[I]:14:4, Delta:14:4, Sr:14:4, (Delta / Sr):14:4); + end; + + WriteLn(Line2); +end; + +procedure PlotGraph(X, Y, B : PVector); +{ ------------------------------------------------------------------ + Plots points and fitted curve + ------------------------------------------------------------------ } + +var + Xmin, Xmax, Xstep : Float; { Ox scale } + Ymin, Ymax, Ystep : Float; { Oy scale } + +begin + if not InitGraphics(9, 2, 'c:\tp\bgi') then { 640x480 16 color } + begin + Writeln('Unable to set graphic mode'); + Exit; + end; + + SetWindow(15, 85, 15, 85, True); + + AutoScale(X, 1, N, LinScale, Xmin, Xmax, Xstep); + AutoScale(Y, 1, N, LinScale, Ymin, Ymax, Ystep); + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetGraphTitle('Polynomial Regression'); + SetOxTitle('X'); + SetOyTitle('Y'); + + PlotOxAxis; + PlotOyAxis; + + WriteGraphTitle; + + SetClipping(True); + + SetLineParam(1, 0, 0, 0); { Don't connect points } + PlotCurve(X, Y, 1, N, 1); + + PlotFunc({$IFDEF FPC}@{$ENDIF}PltFunc, Xmin, Xmax, 2); + + Readln; + + LeaveGraphics; +end; + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + XX, YY : PVector; { Data } + Ycalc : PVector; { Computed Y values } + V : PMatrix; { Variance-covariance matrix } + Test : TRegTest; { Statistical tests } + Tc : Float; { Critical t value } + Fc : Float; { Critical F value } + I : Integer; { Loop variable } + +begin + { Dimension arrays } + DimVector(XX, N); + DimVector(YY, N); + DimVector(Ycalc, N); + DimVector(B, Deg); + DimMatrix(V, Deg, Deg); + + { Read data } + for I := 1 to N do + begin + XX^[I] := X[I]; + YY^[I] := Y[I]; + end; + + { Perform regression } + PolFit(XX, YY, 1, N, Deg, B, V); + + { Compute predicted Y values } + for I := 1 to N do + Ycalc^[I] := Poly(XX^[I], B, Deg); + + { Update variance-covariance matrix and compute statistical tests } + RegTest(YY, Ycalc, 1, N, V, 0, Deg, Test); + + { Compute Student's t and Snedecor's F } + Tc := InvStudent(Test.Nu2, 1 - 0.5 * Alpha); + Fc := InvSnedecor(Test.Nu1, Test.Nu2, 1 - Alpha); + + { Write results } + WriteResults(XX, YY, Ycalc, B, V, Test, Tc, Fc); + + { Plot curve } + PlotGraph(XX, YY, B); +end. diff --git a/fpmath/demo/curfit/wreglin.pas b/fpmath/demo/curfit/wreglin.pas new file mode 100755 index 0000000..1cd9cbf --- /dev/null +++ b/fpmath/demo/curfit/wreglin.pas @@ -0,0 +1,198 @@ +{ ****************************************************************** + This program performs a weighted least squares fit + of a straight line: + Y = B(0) + B(1) * X + ****************************************************************** } + +program wreglin; + +uses + tpmath, tpgraph; + +const + N = 6; { Number of points } + Alpha = 0.05; { Significance level } + +{ Data (S = standard deviations of observed Y values) } +const + X : array[1..N] of Float = (3.195, 3.247, 3.3, 3.356, 3.413, 3.472); + Y : array[1..N] of Float = (1.8, 1.61, 1.38, 0.98, 0.81, 0.56); + S : array[1..N] of Float = (0.03, 0.03, 0.02, 0.03, 0.01, 0.06); + +var + B : PVector; { Regression parameters } + +function PltFunc(X : Float) : Float; +{ ------------------------------------------------------------------ + Function to be plotted + ------------------------------------------------------------------ } + +begin + PltFunc := B^[0] + B^[1] * X +end; + +procedure WriteResults(X, Y, S, Ycalc, B : PVector; + V : PMatrix; + Test : TRegTest; + Tc, Fc : Float); +{ ------------------------------------------------------------------ + Writes results to screen + ------------------------------------------------------------------ } + +var + Line1, + Line2 : String; { Separating lines } + Delta : Float; { Residual } + Sr : Float; { Residual standard deviation } + SB : Float; { Standard deviations of parameters } + I : Integer; { Loop variable } + +begin + Line1 := StrChar(73, '-'); + Line2 := StrChar(73, '='); + + WriteLn(Line2); + WriteLn('Linear regression: Y = B(0) + B(1) * X'); + WriteLn(Line1); + + WriteLn('Parameter Est.value Std.dev. ', + (100 * (1 - Alpha)):2:0, '% Confidence Interval'); + + WriteLn(Line1); + + for I := 0 to 1 do + begin + SB := Sqrt(V^[I]^[I]); + WriteLn('B(', I:1, ')', B^[I]:17:8, SB:17:8, + (B^[I] - Tc * SB):17:8, ';', (B^[I] + Tc * SB):17:8); + end; + + WriteLn(Line1); + + WriteLn('Number of observations : n = ', N:5); + + with Test do + begin + Sr := Sqrt(Vr); + WriteLn('Residual error : s = ', Sr:10:4); + WriteLn('Coefficient of correlation : r = ', (Sgn(B^[1]) * Sqrt(R2)):10:4); + WriteLn('Coefficient of determination : r2 = ', R2:10:4); + WriteLn('Adjusted coeff. of determination : r2a = ', R2a:10:4); + WriteLn('Variance ratio (explained/resid.) : F(', Nu1:3, ', ', Nu2:3, ') = ', F:10:4); + WriteLn('Critical variance ratio : F(p = ', (1 - Alpha):4:2, ') = ', Fc:10:4); + end; + + WriteLn(Line1); + WriteLn(' i Y obs. Y calc. Residual Std.dev. Std.res.'); + WriteLn(Line1); + + for I := 1 to N do + begin + Delta := Y^[I] - Ycalc^[I]; + WriteLn(I:3, Y^[I]:14:4, Ycalc^[I]:14:4, Delta:14:4, + S^[I]:14:4, (Delta / S^[I]):14:4); + end; + + WriteLn(Line2); +end; + +procedure PlotGraph(X, Y, S, B : PVector); +{ ------------------------------------------------------------------ + Plots histogram and normal curve + ------------------------------------------------------------------ } + +var + Xmin, Xmax, Xstep : Float; { Ox scale } + Ymin, Ymax, Ystep : Float; { Oy scale } + +begin + if not InitGraphics(9, 2, 'c:\tp\bgi') then { 640x480 16 color } + begin + Writeln('Unable to set graphic mode'); + Exit; + end; + + SetWindow(15, 85, 15, 85, True); + + AutoScale(X, 1, N, LinScale, Xmin, Xmax, Xstep); + AutoScale(Y, 1, N, LinScale, Ymin, Ymax, Ystep); + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetGraphTitle('Weighted Linear Regression'); + SetOxTitle('X'); + SetOyTitle('Y'); + + PlotOxAxis; + PlotOyAxis; + + WriteGraphTitle; + + SetClipping(True); + + SetPointParam(1, 1, 3, 12); + SetLineParam(1, 0, 0, 12); { Don't connect points } + + PlotCurveWithErrorBars(X, Y, S, 1, 1, N, 1); + + PlotFunc({$IFDEF FPC}@{$ENDIF}PltFunc, Xmin, Xmax, 1); + + Readln; + + LeaveGraphics; +end; + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + XX, YY : PVector; { Data } + SS : PVector; { Standard deviations of observed Y values } + Ycalc : PVector; { Computed Y values } + V : PMatrix; { Variance-covariance matrix } + Test : TRegTest; { Statistical tests } + Tc : Float; { Critical t value } + Fc : Float; { Critical F value } + I : Integer; { Loop variable } + +begin + { Dimension arrays } + DimVector(XX, N); + DimVector(YY, N); + DimVector(SS, N); + DimVector(Ycalc, N); + DimVector(B, 1); + DimMatrix(V, 1, 1); + + { Read data } + for I := 1 to N do + begin + XX^[I] := X[I]; + YY^[I] := Y[I]; + SS^[I] := S[I]; + end; + + { Perform regression } + WLinFit(XX, YY, SS, 1, N, B, V); + + { Compute predicted Y values } + for I := 1 to N do + Ycalc^[I] := B^[0] + B^[1] * XX^[I]; + + { Update variance-covariance matrix and compute statistical tests } + WRegTest(YY, Ycalc, SS, 1, N, V, 0, 1, Test); + + { Compute Student's t and Snedecor's F } + Tc := InvStudent(N - 2, 1 - 0.5 * Alpha); + Fc := InvSnedecor(1, N - 2, 1 - Alpha); + + { Write results } + WriteResults(XX, YY, SS, Ycalc, B, V, Test, Tc, Fc); + + Readln; + + { Plot curve } + PlotGraph(XX, YY, SS, B); +end. diff --git a/fpmath/demo/equation/numjac.inc b/fpmath/demo/equation/numjac.inc new file mode 100755 index 0000000..2840ebf --- /dev/null +++ b/fpmath/demo/equation/numjac.inc @@ -0,0 +1,61 @@ +{ ****************************************************************** + Numerical jacobian + ****************************************************************** } + +procedure Jacobian(X : PVector; D : PMatrix); +const + EtaMin = 1E-6; { Relative increment used to compute derivatives } +var + I, J : Integer; + R, Temp : Float; + Eta : Float; + Delta : PVector; { Increment } + Xminus : PVector; { X - Delta } + Xplus : PVector; { X + Delta } + Fminus : PVector; { F(X - Delta) } + Fplus : PVector; { F(X + Delta) } + +begin + DimVector(Delta, Nvar); + DimVector(Xminus, Nvar); + DimVector(Xplus, Nvar); + DimVector(Fminus, Nvar); + DimVector(Fplus, Nvar); + + Eta := Sqrt(MachEp); + if Eta < EtaMin then Eta := EtaMin; + + for I := 1 to Nvar do + begin + if X^[I] <> 0 then + Delta^[I] := Eta * Abs(X^[I]) + else + Delta^[I] := Eta; + Xplus^[I] := X^[I] + Delta^[I]; + Xminus^[I] := X^[I] - Delta^[I] + end; + + for J := 1 to Nvar do + begin + Temp := X^[J]; + + X^[J] := Xminus^[J]; + Equations(X, Fminus); + + X^[J] := Xplus^[J]; + Equations(X, Fplus); + + R := 1.0 / (2.0 * Delta^[J]); + + for I := 1 to Nvar do + D^[I]^[J] := R * (Fplus^[I] - Fminus^[I]); + + X^[J] := Temp; + end; + + DelVector(Delta, Nvar); + DelVector(Xminus, Nvar); + DelVector(Xplus, Nvar); + DelVector(Fminus, Nvar); + DelVector(Fplus, Nvar); +end; diff --git a/fpmath/demo/equation/testbis.pas b/fpmath/demo/equation/testbis.pas new file mode 100755 index 0000000..103b7c4 --- /dev/null +++ b/fpmath/demo/equation/testbis.pas @@ -0,0 +1,67 @@ +{ ****************************************************************** + Solution to a nonlinear equation by the bisection method. + + Example: + + F(X) = X * Ln(X) - 1 = 0 + + True Solution is X = 1.763222834... + ****************************************************************** } + +program testbis; + +uses + tpmath; + +{ ****************************************************************** + Define the function + ****************************************************************** } + +function Func(X : Float) : Float; +begin + Func := X * Ln(X) - 1 +end; + +{ ****************************************************************** + Define number of iterations and precision + ****************************************************************** } + +const + MaxIter = 1000; { Max number of iterations } + Tol = 1E-6; { Required precision } + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + F, X, Y : Float; + +begin + { Give two starting points near the root } + X := 1; + Y := 2; + + {$IFDEF FPC} + Bisect(@Func, X, Y, MaxIter, Tol, F); + {$ELSE} + Bisect(Func, X, Y, MaxIter, Tol, F); + {$ENDIF} + + if MathErr = OptNonConv then + begin + writeln('Non-convergence!'); + halt; + end; + + writeln; + writeln('Solution to nonlinear equation (Bisection method)'); + writeln('-------------------------------------------------'); + writeln; + + writeln('Root: ', X:12:6); + writeln; + writeln('Function value:', F:12:6); + writeln; +end. + diff --git a/fpmath/demo/equation/testbrdn.pas b/fpmath/demo/equation/testbrdn.pas new file mode 100755 index 0000000..10fd5b0 --- /dev/null +++ b/fpmath/demo/equation/testbrdn.pas @@ -0,0 +1,93 @@ +{ ****************************************************************** + Solution to a system of nonlinear equations by Broyden's method. + + Example (from Numerical Recipes Example Book): + + F(X, Y) = X^2 + Y^2 - 2 = 0 + G(X, Y) = EXP(X - 1) + Y^3 - 2 = 0 + + ( 2 * X 2 * Y ) + Jacobian: D = ( ) + ( EXP(X - 1) 3 * Y^2 ) + + True Solution is at (1, 1) + ****************************************************************** } + +program testbrdn; + +uses + tpmath; + +{ ****************************************************************** + Define the system of equations to be solved + ****************************************************************** } + +procedure Equations(X, F : PVector); +var + X1p2, X2p2, X2p3 : Float; +begin + X1p2 := X^[1] * X^[1]; + X2p2 := X^[2] * X^[2]; + X2p3 := X^[2] * X2p2; + + F^[1] := X1p2 + X2p2 - 2; + F^[2] := Exp(X^[1] - 1) + X2p3 - 2; +end; + +{ ****************************************************************** + Define number of variables, number of iterations, and precision + ****************************************************************** } + +const + Nvar = 2; { Number of variables } + MaxIter = 1000; { Max number of iterations } + Tol = 1.0E-6; { Required precision (must be > Sqrt(MachEp)) } + +var + X, F : PVector; { Variables: X^[1] = X, X^[2] = Y } + I : Integer; { Loop variable } + +{ ****************************************************************** + Main program + ****************************************************************** } + +begin + DimVector(X, Nvar); + DimVector(F, Nvar); + +{ Define starting point } + X^[1] := 2; + X^[2] := 0.5; + + {$IFDEF FPC} + Broyden(@Equations, X, F, 1, Nvar, MaxIter, Tol); + {$ELSE} + Broyden(Equations, X, F, 1, Nvar, MaxIter, Tol); + {$ENDIF} + + if MathErr = OptNonConv then + begin + writeln('Non-convergence!'); + halt; + end; + + writeln; + writeln('Solution to nonlinear equation system (Broyden''s method)'); + writeln('--------------------------------------------------------'); + writeln; + writeln('Solution vector:'); + writeln; + + for I := 1 to Nvar do + writeln('X(', I, ') = ', X^[I]:10:6); + + writeln; + writeln('Function values:'); + writeln; + + for I := 1 to Nvar do + writeln('F(', I, ') = ', F^[I]:10:6); + + writeln; +end. + diff --git a/fpmath/demo/equation/testnr.pas b/fpmath/demo/equation/testnr.pas new file mode 100755 index 0000000..26f5718 --- /dev/null +++ b/fpmath/demo/equation/testnr.pas @@ -0,0 +1,118 @@ +{ ****************************************************************** + Solution to a system of nonlinear equations by the Newton-Raphson + method. + + Example (from Numerical Recipes Example Book): + + F(X, Y) = X^2 + Y^2 - 2 = 0 + G(X, Y) = EXP(X - 1) + Y^3 - 2 = 0 + + ( 2 * X 2 * Y ) + Jacobian: D = ( ) + ( EXP(X - 1) 3 * Y^2 ) + + True Solution is at (1, 1) + ****************************************************************** } + +program testnr; + +uses + tpmath; + +{ ****************************************************************** + Define number of variables, number of iterations, and precision + ****************************************************************** } + +const + Nvar = 2; { Number of variables } + MaxIter = 1000; { Max number of iterations } + Tol = 1.0E-6; { Required precision (must be > Sqrt(MachEp)) } + +{ ****************************************************************** + Define the system of equations to be solved + ****************************************************************** } + +procedure Equations (X, F : PVector); +var + X1p2, X2p2, X2p3 : Float; +begin + X1p2 := X^[1] * X^[1]; + X2p2 := X^[2] * X^[2]; + X2p3 := X^[2] * X2p2; + + F^[1] := X1p2 + X2p2 - 2; + F^[2] := Exp(X^[1] - 1) + X2p3 - 2; +end; + +{ ****************************************************************** + Define the subroutine which computes the jacobian of the system. + It is recommended to use analytical derivatives whenever possible. + Otherwise you can use the alternative code provided in numjac.inc + ****************************************************************** } + +procedure Jacobian(X : PVector; D : PMatrix); +begin + D^[1]^[1] := 2 * X^[1]; + D^[1]^[2] := 2 * X^[2]; + D^[2]^[1] := Exp(X^[1] - 1); + D^[2]^[2] := 3 * X^[2] * X^[2]; +end; + +{ ****************************************************************** + Alternative code if the analytical derivatives are not available + ****************************************************************** } + +(* + +{$i numjac.inc} + +*) + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + X, F : PVector; { Variables: X^[1] = X, X^[2] = Y } + I : Integer; { Loop variable } + +begin + DimVector(X, Nvar); + DimVector(F, Nvar); + + { Define starting point } + X^[1] := 2; + X^[2] := 0.5; + + {$IFDEF FPC} + NewtEqs(@Equations, @Jacobian, X, F, 1, Nvar, MaxIter, Tol); + {$ELSE} + NewtEqs(Equations, Jacobian, X, F, 1, Nvar, MaxIter, Tol); + {$ENDIF} + + if MathErr = OptNonConv then + begin + writeln('Non-convergence!'); + halt; + end; + + writeln; + writeln('Solution to nonlinear equation system (Newton-Raphson method)'); + writeln('-------------------------------------------------------------'); + writeln; + writeln('Solution vector:'); + writeln; + + for I := 1 to Nvar do + writeln('X(', I, ') = ', X^[I]:10:6); + + writeln; + writeln('Function values:'); + writeln; + + for I := 1 to Nvar do + writeln('F(', I, ') = ', F^[I]:10:6); + + writeln; +end. + diff --git a/fpmath/demo/equation/testnr1.pas b/fpmath/demo/equation/testnr1.pas new file mode 100755 index 0000000..06c3da4 --- /dev/null +++ b/fpmath/demo/equation/testnr1.pas @@ -0,0 +1,80 @@ +{ ****************************************************************** + Solution to a nonlinear equation by the Newton-Raphson method. + + Example: + + F(X) = X * Ln(X) - 1 = 0 + + Derivative: F'(X) = Ln(X) + 1 + + True Solution is X = 1.763222834... + ****************************************************************** } + +program testnr1; + +uses + tpmath; + +{ ****************************************************************** + Define the function and its derivative + ****************************************************************** } + +function Func(X : Float) : Float; +begin + Func := X * Ln(X) - 1 +end; + +function Deriv(X : Float) : Float; +begin + Deriv := Ln(X) + 1 +end; + +{ ****************************************************************** + Define number of iterations and precision + ****************************************************************** } + +const + MaxIter = 1000; { Max number of iterations } + Tol = 1E-6; { Required precision } + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + F, X : Float; + +begin + { Define a starting point near the root } + X := 1; + + {$IFDEF FPC} + NewtEq(@Func, @Deriv, X, MaxIter, Tol, F); + {$ELSE} + NewtEq(Func, Deriv, X, MaxIter, Tol, F); + {$ENDIF} + + case MathErr of + OptNonConv : + begin + writeln('Non-convergence!'); + halt; + end; + OptSing : + begin + writeln('Null derivative!'); + halt; + end; + end; + + writeln; + writeln('Solution to nonlinear equation (Newton-Raphson method)'); + writeln('------------------------------------------------------'); + writeln; + + writeln('Root: ', X:12:6); + writeln; + writeln('Function value:', F:12:6); + writeln; +end. + diff --git a/fpmath/demo/equation/testsec.pas b/fpmath/demo/equation/testsec.pas new file mode 100755 index 0000000..aa1f273 --- /dev/null +++ b/fpmath/demo/equation/testsec.pas @@ -0,0 +1,67 @@ +{ ****************************************************************** + Solution to a nonlinear equation by the secant method. + + Example: + + F(X) = X * Ln(X) - 1 = 0 + + True Solution is X = 1.763222834... + ****************************************************************** } + +program testsec; + +uses + tpmath; + +{ ****************************************************************** + Define the function + ****************************************************************** } + +function Func(X : Float) : Float; +begin + Func := X * Ln(X) - 1 +end; + +{ ****************************************************************** + Define number of iterations and precision + ****************************************************************** } + +const + MaxIter = 1000; { Max number of iterations } + Tol = 1E-6; { Required precision } + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + F, X, Y : Float; + +begin + { Give two starting points near the root } + X := 1; + Y := 2; + + {$IFDEF FPC} + Secant(@Func, X, Y, MaxIter, Tol, F); + {$ELSE} + Secant(Func, X, Y, MaxIter, Tol, F); + {$ENDIF} + + if MathErr = OptNonConv then + begin + writeln('Non-convergence!'); + halt; + end; + + writeln; + writeln('Solution to nonlinear equation (Secant method)'); + writeln('----------------------------------------------'); + writeln; + + writeln('Root: ', X:12:6); + writeln; + writeln('Function value:', F:12:6); + writeln; +end. + diff --git a/fpmath/demo/fmath/contour.pas b/fpmath/demo/fmath/contour.pas new file mode 100755 index 0000000..071df8a --- /dev/null +++ b/fpmath/demo/fmath/contour.pas @@ -0,0 +1,131 @@ +{ ****************************************************************** + Contour plot of a two-dimensional function + ****************************************************************** } + +program contour; + +uses + tpmath, tpgraph; + +{ ****************************************************************** + Define here the function to be plotted + ****************************************************************** } + +const + FuncName = 'Sin(Sqrt(X^2 + Y^2)) + 0.5 / Sqrt((X + 3.05)^2 + Y^2)'; + +const + Xmin = - TwoPi; Xmax = TwoPi; Xstep = Pi; { Ox scale } + Ymin = - TwoPi; Ymax = TwoPi; Ystep = Pi; { Oy scale } + +const + NpX = 60; NpY = 60; { Number of grid points } + +const + Nc = 30; { Number of contours } + +function Func(X, Y : Float) : Float; + +const + C = 3.05; + +var + X2, Y2, Xc, Xc2 : Float; + +begin + X2 := X * X; + Y2 := Y * Y; + Xc := X + C; + Xc2 := Xc * Xc; + + Func := Sin(Sqrt(X2 + Y2)) + 0.5 / Sqrt(Xc2 + Y2) +end; + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + Dx, Dy : Float; { Increments of X and Y } + Fmin, Fmax : Float; { Min. and max. function values } + H : Float; { Increment for levels } + X, Y : PVector; { Point coordinates } + Z : PVector; { Contour array } + F : PMatrix; { Function values } + I, J : Integer; { Loop variables } + +begin + { Initialize graphics } + + if not InitGraphics(9, 2, { 640x480 16 color } + 'c:\tp\bgi') then Exit; + + { Set graphic area so that it will look approximately square } + + SetWindow(24, 76, 15, 85, True); + + { Dimension arrays } + + DimVector(X, NpX); + DimVector(Y, NpY); + + DimVector(Z, Nc - 1); + + DimMatrix(F, NpX, NpY); + + { Set scales and plot axes } + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + PlotOxAxis; + PlotOyAxis; + + PlotGrid(BothGrid); + + SetGraphTitle(FuncName); + WriteGraphTitle; + + { Generate grid points } + + Dx := (Xmax - Xmin) / NpX; + Dy := (Ymax - Ymin) / NpY; + + X^[0] := Xmin; + for I := 1 to NpX do + X^[I] := X^[I - 1] + Dx; + + Y^[0] := Ymin; + for J := 1 to NpY do + Y^[J] := Y^[J - 1] + Dy; + + { Compute function values } + + Fmin := Func(Xmin, Ymin); + Fmax := Fmin; + + for I := 0 to NpX do + for J := 0 to NpY do + begin + F^[I]^[J] := Func(X^[I], Y^[J]); + if F^[I]^[J] < Fmin then + Fmin := F^[I]^[J] + else if F^[I]^[J] > Fmax then + Fmax := F^[I]^[J]; + end; + + { Define levels } + + H := (Fmax - Fmin) / (Nc + 1); + + for I := 0 to Nc - 1 do + Z^[I] := Fmin + (I + 1) * H; + + { Plot contour } + + ConRec(NpX, NpY, Nc, X, Y, Z, F); + + ReadLn; + + LeaveGraphics; +end. diff --git a/fpmath/demo/fmath/plot.pas b/fpmath/demo/fmath/plot.pas new file mode 100755 index 0000000..1ae8f0b --- /dev/null +++ b/fpmath/demo/fmath/plot.pas @@ -0,0 +1,68 @@ +{ ****************************************************************** + This program plots a function in either linear or logarithmic + coordinates. + ****************************************************************** } + +program plot; + +uses + tpmath, tpgraph; + +function Func(X : Float) : Float; +{ Square root function (becomes linear in log-log coordinates) } +begin + Func := Sqrt(X) +end; + +begin +{ Plot in linear coordinates, using default parameter values } + + if not InitGraphics(9, 2, { 640x480 16 color } + 'c:\tp\bgi') then Exit; + + SetWindow(15, 85, 15, 85, True); + + PlotOxAxis; + PlotOyAxis; + + PlotGrid(BothGrid); + + SetGraphTitle('SQUARE ROOT FUNCTION IN LINEAR COORDINATES'); + + WriteGraphTitle; + + SetClipping(True); + + PlotFunc({$IFDEF FPC}@{$ENDIF}Func, 0.0, 1.0, 1); + + ReadLn; + + LeaveGraphics; + +{ Plot in logarithmic coordinates } + + if not InitGraphics(9, 2, { 640x480 16 color } + 'c:\tp\bgi') then Exit; + + SetWindow(15, 85, 15, 85, True); + + SetOxScale(LogScale, 0.01, 100, 1); + SetOyScale(LogScale, 0.1, 10, 1); + + PlotOxAxis; + PlotOyAxis; + + PlotGrid(BothGrid); + + SetGraphTitle('SQUARE ROOT FUNCTION IN LOGARITHMIC COORDINATES'); + + WriteGraphTitle; + + SetClipping(True); + + PlotFunc({$IFDEF FPC}@{$ENDIF}Func, 0.01, 100, 2); + + ReadLn; + + LeaveGraphics; +end. diff --git a/fpmath/demo/fmath/specfunc.pas b/fpmath/demo/fmath/specfunc.pas new file mode 100755 index 0000000..b41442c --- /dev/null +++ b/fpmath/demo/fmath/specfunc.pas @@ -0,0 +1,272 @@ +{ ****************************************************************** + This programs tests the accuracy of the special functions. + The data file SPECFUNC.DAT has been modified from the + 'Numerical Recipes' example file. + ****************************************************************** } + +program specfunc; + +uses + crt, tpmath; + +const + FileName = 'specfunc.dat'; + Blank = ' '; + + procedure Pause; + var + Ch : Char; + begin + Writeln; + Write('Press a key to continue'); + Ch := ReadKey; + Writeln; + Writeln; + end; + + procedure Test_Fact; + var + I, M, N : Integer; + Y, Ref, R : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'N-factorial'; + ReadLn(F, M); + WriteLn(' X Fact(N) Reference Rel.Error'); + WriteLn('------------------------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, N, Ref); + Y := Fact(N); + R := (Y - Ref) / Ref; + WriteLn(N:4, Blank, Y:26, Blank, Ref:26, Blank, R:10); + end; + Close(F); + Pause; + end; + + procedure Test_Binomial; + var + I, M, N, K : Integer; + Y, Ref, R : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'Binomial Coefficients'; + ReadLn(F, M); + WriteLn(' N K Binomial(N, K) Reference Rel.Error'); + WriteLn('---------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, N, K, Ref); + Y := Binomial(N, K); + R := (Y - Ref) / Ref; + WriteLn(N:2, K:5, ' ', Y:13:0, ' ', Ref:13:0, ' ', R:10); + end; + Close(F); + Pause; + end; + + procedure Test_Gamma; + var + I, M : Integer; + X, Y, Ref, R : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'Gamma Function'; + ReadLn(F, M); + WriteLn(' X Gamma(X) Reference Rel.Error'); + WriteLn('------------------------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, X, Ref); + Y := Gamma(X); { To test Gamma } + { Y := SgnGamma(X) * Exp(LnGamma(X)); } { To test LnGamma } + R := (Y - Ref) / Ref; + WriteLn(X:4:1, Blank, Y:26, Blank, Ref:26, Blank, R:10); + end; + Close(F); + Pause; + end; + + procedure Test_IGamma; + var + I, M : Integer; + A, X, Y, R, Ref : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'Incomplete Gamma Function'; + ReadLn(F, M); + WriteLn(' A X IGamma(A, X) Reference Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, A, X, Ref); + Y := IGamma(A, X); + R := (Y - Ref) / Ref; + WriteLn(A:4:1, X:12:8, Y:26, Ref:26, ' ', R:10); + end; + Close(F); + Pause; + end; + + procedure Test_Beta; + var + I, M : Integer; + X, Y, Z, R, Ref : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'Beta Function'; + ReadLn(F, M); + WriteLn(' X Y Beta(X, Y) Reference Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, X, Y, Ref); + Z := Beta(X, Y); + R := (Z - Ref) / Ref; + WriteLn(X:4:1, ' ', Y:4:1, ' ', Z:26, ' ', Ref:26, ' ', R:10); + end; + Close(F); + Pause; + end; + + procedure Test_IBeta; + var + I, M : Integer; + A, B, X, Y, R, Ref : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'Incomplete Beta Function'; + ReadLn(F, M); + WriteLn(' A B X IBeta(A, B, X) Reference Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, A, B, X, Ref); + Y := IBeta(A, B, X); + R := (Y - Ref) / Ref; + WriteLn(A:4:1, ' ', B:4:1, ' ', X:4:2, ' ', Y:26, ' ', Ref:26, ' ', R:10); + end; + Close(F); + Pause; + end; + + procedure Test_Erf; + var + I, M : Integer; + X, Y, R, Ref : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'Error Function'; + ReadLn(F, M); + WriteLn(' X Erf(X) Reference Rel.Error'); + WriteLn('------------------------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, X, Ref); + Y := Erf(X); + R := (Y - Ref) / Ref; + WriteLn(X:4:1, Blank, Y:26, Blank, Ref:26, Blank, R:10); + end; + Close(F); + Pause; + end; + + procedure Test_DiGamma; + var + I, M : Integer; + X, Y, Ref, R : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'DiGamma Function'; + ReadLn(F, M); + WriteLn(' X DiGamma(X) Reference Rel.Error'); + WriteLn('------------------------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, X, Ref); + Y := DiGamma(X); + R := (Y - Ref) / Ref; + WriteLn(X:6:2, Blank, Y:25, Blank, Ref:25, Blank, R:10); + end; + Close(F); + Pause; + end; + + procedure Test_TriGamma; + var + I, M : Integer; + X, Y, Ref, R : Float; + F : Text; + S : String; + begin + Assign(F, FileName); + Reset(F); + repeat + ReadLn(F, S); + until S = 'TriGamma Function'; + ReadLn(F, M); + WriteLn(' X TriGamma(X) Reference Rel.Error'); + WriteLn('------------------------------------------------------------------------------'); + for I := 1 to M do + begin + ReadLn(F, X, Ref); + Y := TriGamma(X); + R := (Y - Ref) / Ref; + WriteLn(X:6:2, Blank, Y:25, Blank, Ref:25, Blank, R:10); + end; + Close(F); + Pause; + end; + +begin + Test_Fact; + Test_Binomial; + Test_Gamma; + Test_IGamma; + Test_Beta; + Test_IBeta; + Test_Erf; + Test_DiGamma; + Test_TriGamma; +end. diff --git a/fpmath/demo/fmath/speed.pas b/fpmath/demo/fmath/speed.pas new file mode 100755 index 0000000..971363d --- /dev/null +++ b/fpmath/demo/fmath/speed.pas @@ -0,0 +1,157 @@ +{ ****************************************************************** + This program measures the execution times of several standard + mathematical functions, as well as some additional functions + provided in TPMATH + + The results are stored in the output file SPEED.OUT + + The execution time of each function takes into account the + computation of random arguments. This corresponds to the + execution time of the function Random + ****************************************************************** } + +program Speed; + +uses + dos, tpmath; + +const + NFUNC = 29; { Number of functions } + NMAX = 10000000; { Number of evaluations for each function } + +const + FuncName : array[1..NFUNC] of String[8] = + ('Ln ', + 'Log10 ', + 'Log2 ', + 'Exp ', + 'Exp10 ', + 'Exp2 ', + 'Power ', + 'Sin ', + 'Cos ', + 'Tan ', + 'ArcSin ', + 'ArcCos ', + 'ArcTan ', + 'ArcTan2 ', + 'Sinh ', + 'Cosh ', + 'Tanh ', + 'ArcSinh ', + 'ArcCosh ', + 'ArcTanh ', + 'Gamma ', + 'DiGamma ', + 'TriGamma', + 'IGamma ', + 'Beta ', + 'IBeta ', + 'Erf ', + 'Erfc ', + 'Random '); + +var + F : Text; { Output file } + N : Byte; { Function index } + T : Float; { Time } + +function Time : Float; +{ Returns time in seconds } +var + H, M, S, C : Word; +begin + GetTime(H, M, S, C); + Time := 3600.0 * H + 60.0 * M + S + 0.01 * C; +end; + +function TimeToEval(N : Byte) : Float; +{ Returns time to evaluate NMAX functions } +var + I : LongInt; + T0, Y : Float; +begin + T0 := Time; + case N of + 1 : for I := 1 to NMAX do + Y := Ln(Random); + 2 : for I := 1 to NMAX do + Y := Log10(Random); + 3 : for I := 1 to NMAX do + Y := Log2(Random); + 4 : for I := 1 to NMAX do + Y := Exp(Random); + 5 : for I := 1 to NMAX do + Y := Exp10(Random); + 6 : for I := 1 to NMAX do + Y := Exp2(Random); + 7 : for I := 1 to NMAX do + Y := Power(Random, 0.5); + 8 : for I := 1 to NMAX do + Y := Sin(Random); + 9 : for I := 1 to NMAX do + Y := Cos(Random); + 10 : for I := 1 to NMAX do + Y := Tan(Random); + 11 : for I := 1 to NMAX do + Y := ArcSin(Random); + 12 : for I := 1 to NMAX do + Y := ArcCos(Random); + 13 : for I := 1 to NMAX do + Y := ArcTan(Random); + 14 : for I := 1 to NMAX do + Y := ArcTan2(Random, 0.5); + 15 : for I := 1 to NMAX do + Y := Sinh(Random); + 16 : for I := 1 to NMAX do + Y := Cosh(Random); + 17 : for I := 1 to NMAX do + Y := Tanh(Random); + 18 : for I := 1 to NMAX do + Y := ArcSinh(Random); + 19 : for I := 1 to NMAX do + Y := ArcCosh(Random + 1.0); + 20 : for I := 1 to NMAX do + Y := ArcTanh(Random); + 21 : for I := 1 to NMAX do + Y := Gamma(Random); + 22 : for I := 1 to NMAX do + Y := DiGamma(Random); + 23 : for I := 1 to NMAX do + Y := TriGamma(Random); + 24 : for I := 1 to NMAX do + Y := IGamma(Random, 0.5); + 25 : for I := 1 to NMAX do + Y := Beta(Random, 0.5); + 26 : for I := 1 to NMAX do + Y := IBeta(Random, 0.5, 0.5); + 27 : for I := 1 to NMAX do + Y := Erf(Random); + 28 : for I := 1 to NMAX do + Y := Erfc(Random); + 29 : for I := 1 to NMAX do + Y := Random; + end; + TimeToEval := Time - T0; +end; + +begin + { Open output file } + Assign(F, 'speed.out'); + Rewrite(F); + + Writeln; + Writeln('Time in seconds to evaluate ', NMAX, ' functions'); + Writeln(F, 'Time in seconds to evaluate ', NMAX, ' functions'); + Writeln; + Writeln(F); + + for N := 1 to NFUNC do + begin + T := TimeToEval(N); + Writeln(FuncName[N], T:6:2); + Writeln(F, FuncName[N], T:8:2); + end; + + Close(F); +end. diff --git a/fpmath/demo/fmath/testfunc.pas b/fpmath/demo/fmath/testfunc.pas new file mode 100755 index 0000000..15c0a1f --- /dev/null +++ b/fpmath/demo/fmath/testfunc.pas @@ -0,0 +1,256 @@ +{ ****************************************************************** + This program tests the accuracy of the elementary functions. + For each function, 20 random arguments are picked, then the + function is computed, the reciprocal function is applied to + the result, and the relative error between this last result + and the original argument is computed. + ****************************************************************** } + +program testfunc; + +uses + crt, tpmath; + +const + NARG = 20; { Number of arguments } + BLANK = ' '; { Separator } + +type + TVector = array[1..NARG] of Float; + +var + X, Y : TVector; { Random arguments } + + procedure Pause; + var + Ch : Char; + begin + Writeln; + Write('Press a key to continue'); + Ch := ReadKey; + Writeln; + Writeln; + end; + + procedure RanArgs(var X : TVector; Xmin, Xmax : Float); + { Fills a table of random arguments between Xmin and Xmax, + rounded to 4 decimal places and sorted in increasing order. } + var + I, J, K : integer; + A : Float; + begin + for I := 1 to NARG do + begin + A := (Xmax - Xmin) * Random + Xmin; + if Abs(A) < 1.0E-4 then A := Sgn(A) * 1.0E-4; + X[I] := Int(10000 * A) / 10000; + end; + + { Insertion sort } + for I := 1 to Pred(NARG) do + begin + K := I; + A := X[I]; + for J := Succ(I) to NARG do + if X[J] < A then + begin + K := J; + A := X[J]; + end; + FSwap(X[I], X[K]); + end; + end; + + procedure Test_Exp; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, -10, 10); + WriteLn(' X Y = Expo(X) X = Log(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Expo(X[I]); + T := Log(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + + procedure Test_Exp10; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, -5, 5); + WriteLn(' X Y = Exp10(X) X = Log10(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Exp10(X[I]); + T := Log10(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + + procedure Test_Exp2; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, -15, 15); + WriteLn(' X Y = Exp2(X) X = Log2(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Exp2(X[I]); + T := Log2(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + + procedure Test_Power; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, 0, 10); + RanArgs(Y, -5, 5); + WriteLn(' X Y Z = Power(X, Y) Y = Log(Z, X) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Power(X[I], Y[I]); { X^Y } + T := LogA(Z, X[I]); { Log(X^Y, X) = Y } + R := (Y[I] - T) / Y[I]; + WriteLn(X[I]:6:4, Y[I]:8:4, ' ', Z:26, ' ', T:26, ' ', R:10); + end; + Pause; + end; + + procedure Test_Sin; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, -PiDiv2, PiDiv2); + WriteLn(' X Y = Sin(X) X = ArcSin(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Sin(X[I]); + T := ArcSin(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + + procedure Test_Cos; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, 0, PI); + WriteLn(' X Y = Cos(X) X = ArcCos(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Cos(X[I]); + T := ArcCos(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + + procedure Test_Tan; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, -PiDiv2, PiDiv2); + WriteLn(' X Y = Tan(X) X = ArcTan(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Tan(X[I]); + T := ArcTan(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + + procedure Test_Sinh; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, 0, 5); + WriteLn(' X Y = Sinh(X) X = ArcSinh(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Sinh(X[I]); + T := ArcSinh(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + + procedure Test_Cosh; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, 0, 5); + WriteLn(' X Y = Cosh(X) X = ArcCosh(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Cosh(X[I]); + T := ArcCosh(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + + procedure Test_Tanh; + var + I : Integer; + Z, T, R : Float; + begin + RanArgs(X, -5, 5); + WriteLn(' X Y = Tanh(X) X = ArcTanh(Y) Rel.Error'); + WriteLn('-------------------------------------------------------------------------------'); + for I := 1 to NARG do + begin + Z := Tanh(X[I]); + T := ArcTanh(Z); + R := (X[I] - T) / X[I]; + WriteLn(X[I]:8:4, BLANK, Z:26, BLANK, T:26, BLANK, R:10); + end; + Pause; + end; + +begin + Test_Exp; + Test_Exp10; + Test_Exp2; + Test_Power; + Test_Sin; + Test_Cos; + Test_Tan; + Test_Sinh; + Test_Cosh; + Test_Tanh; +end. diff --git a/fpmath/demo/fmath/testmach.pas b/fpmath/demo/fmath/testmach.pas new file mode 100755 index 0000000..6fd508f --- /dev/null +++ b/fpmath/demo/fmath/testmach.pas @@ -0,0 +1,65 @@ +{ ****************************************************************** + This program displays the floating point type and the machine- + dependent constants. + ****************************************************************** } + +program testmach; + +uses + tpmath; + +var + N : Byte; + +begin + writeln; + writeln('Integer type = Integer (', sizeof(Integer), ' bytes)'); + writeln('Long Integer type = LongInt (', sizeof(LongInt), ' bytes)'); + + N := sizeof(Float); + write('Floating point type = '); + if N = sizeof(Single) then + write('Single') + else if N = sizeof(Double) then + write('Double') + else if N = sizeof(Extended) then + write('Extended') + else + write('Real'); + + writeln(' (', N, ' bytes)'); + + writeln('Complex type = Complex (', sizeof(Complex), ' bytes)'); + + writeln; + writeln('MachEp = ', MachEp); + + writeln; + writeln('MinNum = ', MinNum); + writeln('Exp(MinLog) = ', Exp(MinLog)); + + writeln; + writeln('MinLog = ', MinLog); + writeln('Ln(MinNum) = ', Ln(MinNum)); + + writeln; + writeln('MaxNum = ', MaxNum); + writeln('Exp(MaxLog) = ', Exp(MaxLog)); + + writeln; + writeln('MaxLog = ', MaxLog); + writeln('Ln(MaxNum) = ', Ln(MaxNum)); + + writeln; + writeln('MaxFac = ', MaxFac); + writeln('Fact(MaxFac) = ', Fact(MaxFac)); + + writeln; + writeln('MaxGam = ', MaxGam); + writeln('Gamma(MaxGam) = ', Gamma(MaxGam)); + + writeln; + writeln('MaxLgm = ', MaxLgm); + writeln('LnGamma(MaxLgm) = ', LnGamma(MaxLgm)); +end. + diff --git a/fpmath/demo/fmath/testw.pas b/fpmath/demo/fmath/testw.pas new file mode 100755 index 0000000..b6fe574 --- /dev/null +++ b/fpmath/demo/fmath/testw.pas @@ -0,0 +1,390 @@ +{ ****************************************************************** + Test of Lamberts's function + This program has been translated from a FORTRAN program + written by Barry et al. (http://www.netlib.org/toms/743) + ****************************************************************** } + +uses + tpmath; + +{ Upper branch, X given as offset from -1/e } +const DX1 : array[1..68] of Float = + (1.E-40, 2.E-40, 3.E-40, 4.E-40, 5.E-40, 6.E-40, 7.E-40, 8.E-40, + 9.E-40, 1.E-39, 1.E-30, 2.E-30, 3.E-30, 4.E-30, 5.E-30, 6.E-30, + 7.E-30, 8.E-30, 9.E-30, 1.E-29, 1.E-20, 2.E-20, 3.E-20, 4.E-20, + 5.E-20, 6.E-20, 7.E-20, 8.E-20, 9.E-20, 1.E-19, 1.E-10, 2.E-10, + 3.E-10, 4.E-10, 5.E-10, 6.E-10, 7.E-10, 8.E-10, 9.E-10, 1.E-9, 1.E-5, + 2.E-5, 3.E-5, 4.E-5, 5.E-5, 6.E-5, 7.E-5, 8.E-5, 9.E-5, 1.E-4, 2.E-4, + 3.E-4, 4.E-4, 5.E-4, 6.E-4, 7.E-4, 8.E-4, 9.E-4, 1.E-3, 2.E-3, 3.E-3, + 4.E-3, 5.E-3, 6.E-3, 7.E-3, 8.E-3, 9.E-3, 1.E-2); + +const WP1 : array[1..68] of Float = + (- 0.9999999999999999999766835601840287579665, + - 0.9999999999999999999670255745859974370634, + - 0.9999999999999999999596147415871158855702, + - 0.9999999999999999999533671203680575159335, + - 0.9999999999999999999478628555782056161596, + - 0.9999999999999999999428866198325571498809, + - 0.9999999999999999999383104987875354650364, + - 0.9999999999999999999340511491719948741275, + - 0.9999999999999999999300506805520862739007, + - 0.9999999999999999999262669432552936235556, + - 0.9999999999999976683560184028776088243496, + - 0.9999999999999967025574585997473306784697, + - 0.9999999999999959614741587115939935280812, + - 0.9999999999999953367120368057588420244704, + - 0.9999999999999947862855578205706768098859, + - 0.9999999999999942886619832557258611080314, + - 0.9999999999999938310498787535591888253966, + - 0.999999999999993405114917199501910108482, + - 0.9999999999999930050680552086436996003626, + - 0.9999999999999926266943255293804772564852, + - 0.9999999997668356018584094585181033975713, + - 0.9999999996702557458962181283375794922681, + - 0.9999999995961474159255244922555603070484, + - 0.9999999995336712037530626747373742782638, + - 0.9999999994786285558726655558473617503914, + - 0.9999999994288661984343027719079710168757, + - 0.9999999993831049880022078023099082447845, + - 0.9999999993405114918649237720678678043098, + - 0.9999999993005068056839596486461928553989, + - 0.9999999992626694327341550240404575805522, + - 0.9999766837414008807143234266407434345965, + - 0.9999670259370180970391011806287847685011, + - 0.9999596152852334187587360603177913882165, + - 0.9999533678452277190993205651165793258207, + - 0.9999478637616504968301143759542621752943, + - 0.9999428877071168268324462680980110604599, + - 0.999938311767283189655618359697592754013, + - 0.999934052598878483932035240348113191731, + - 0.9999300523114688962155368933174163936848, + - 0.9999262687553819399632780281900349826094, + - 0.9926447551971221136721993073029112268763, + - 0.9896086425917686478635208903220735023288, + - 0.9872831094708759013315476674998231771112, + - 0.9853253899681719161468126266199947992874, + - 0.9836027178149637071691226667555243369797, + - 0.9820470029764667038452666345865058694192, + - 0.9806177971936827573257045283891513709368, + - 0.97928874641099293421931043027104578327, + - 0.9780415451927629881943028498821429186059, + - 0.9768628655744219140604871252425961901255, + - 0.967382626983074241885253344632666448927, + - 0.9601485420712594199373375259293860324633, + - 0.9540768694875733222057908617314370634111, + - 0.9487478690765183543410579996573536771348, + - 0.9439462911219380338176477772712853402016, + - 0.9395442782590063946376623684916441100361, + - 0.9354585313336439336066341889767099608018, + - 0.9316311953818583253420613278986500351794, + - 0.9280201500545670487600430252549212247489, + - 0.8991857663963733198571950343133631348347, + - 0.8774287170665477623395641312875506084256, + - 0.8593275036837387237312746018678000939451, + - 0.8435580020488052057849697812109882706542, + - 0.8294416857114015557682843481727604063558, + - 0.8165758053803078481644781849709953302847, + - 0.8046981564792468915744561969751509934994, + - 0.7936267540949175059651534957734689407879, + - 0.7832291989812967764330746819464532478021); + +{ Upper branch, X close to 0 } +const X2 : array[1..20] of Float = + (1.E-9, 2.E-9, 3.E-9, 4.E-9, 5.E-9, 6.E-9, 7.E-9, 8.E-9, 9.E-9, 1.E-8, + 1.E-2, 2.E-2, 3.E-2, 4.E-2, 5.E-2, 6.E-2, 7.E-2, 8.E-2, 9.E-2, 1.E-1); + +const WP2 : array[1..40] of Float = + (9.999999990000000014999999973333333385417E-10, + 1.9999999960000000119999999573333335E-9, + 2.999999991000000040499999784000001265625E-9, + 3.999999984000000095999999317333338666667E-9, + 4.999999975000000187499998333333349609375E-9, + 5.999999964000000323999996544000040499999E-9, + 6.99999995100000051449999359733342086979E-9, + 7.999999936000000767999989077333503999997E-9, + 8.999999919000001093499982504000307546869E-9, + 9.999999900000001499999973333333854166656E-9, + 9.901473843595011885336326816570107953628E-3, + 1.961158933740562729168248268298370977812E-2, + 2.913845916787001265458568152535395243296E-2, + 3.848966594197856933287598180923987047561E-2, + 4.767230860012937472638890051416087074706E-2, + 5.669304377414432493107872588796066666126E-2, + 6.555812274442272075701853672870305774479E-2, + 7.427342455278083997072135190143718509109E-2, + 8.284448574644162210327285639805993759142E-2, + 9.127652716086226429989572142317956865312E-2, + - 1.000000001000000001500000002666666671875E-9, + - 2.000000004000000012000000042666666833333E-9, + - 3.000000009000000040500000216000001265625E-9, + - 4.000000016000000096000000682666672E-9, + - 5.000000025000000187500001666666682942709E-9, + - 6.000000036000000324000003456000040500001E-9, + - 7.000000049000000514500006402666754203126E-9, + - 8.000000064000000768000010922666837333336E-9, + - 9.000000081000001093500017496000307546881E-9, + - 1.000000010000000150000002666666718750001E-8, + - 1.010152719853875327292018767138623973671E-2, + - 2.041244405580766725973605390749548004159E-2, + - 3.094279498284817939791038065611524917276E-2, + - 4.170340843648447389872733812553976786256E-2, + - 5.270598355154634795995650617915721289428E-2, + - 6.396318935617251019529498180168867456393E-2, + - 7.548877886579220591933915955796681153525E-2, + - 8.729772086157992404091975866027313992649E-2, + - 9.940635280454481474353567186786621057821E-2, + - 1.118325591589629648335694568202658422726E-1); + +{ Other results } +const X3 : array[1..10] of Float = + (1.E1, 1.E2, 1.E3, 1.E4, 1.E5, 1.E6, 1.E7, 1.E8, 1.E9, 1.E10); + +const WP3 : array[1..10] of Float = + (1.745528002740699383074301264875389911535, + 3.385630140290050184888244364529726867492, + 5.249602852401596227126056319697306282521, + 7.231846038093372706475618500141253883968, + 9.284571428622108983205132234759581939317, + 11.38335808614005262200015678158500428903, + 13.5143440103060912090067238511621580283, + 15.66899671545096218719628189389457073619, + 17.84172596742146918254060066535711011039, + 20.02868541330495078123430607181488729749); + +{ Lower branch, X close to -1/e } +const WM1 : array[1..68] of Float = + (- 1.000000000000000000023316439815971242034, + - 1.000000000000000000032974425414002562937, + - 1.000000000000000000040385258412884114431, + - 1.000000000000000000046632879631942484068, + - 1.000000000000000000052137144421794383842, + - 1.000000000000000000057113380167442850121, + - 1.000000000000000000061689501212464534966, + - 1.000000000000000000065948850828005125875, + - 1.000000000000000000069949319447913726103, + - 1.000000000000000000073733056744706376448, + - 1.000000000000002331643981597126015551422, + - 1.000000000000003297442541400259918073073, + - 1.000000000000004038525841288416879599233, + - 1.000000000000004663287963194255655478615, + - 1.00000000000000521371444217944744506897, + - 1.000000000000005711338016744295885146596, + - 1.000000000000006168950121246466181805002, + - 1.000000000000006594885082800527084897688, + - 1.000000000000006994931944791388919781579, + - 1.000000000000007373305674470655766501228, + - 1.000000000233164398177834299194683872234, + - 1.000000000329744254176269387087995047343, + - 1.00000000040385258418320678088280150237, + - 1.000000000466328796391912356113774800963, + - 1.000000000521371444308553232716574598644, + - 1.00000000057113380178315977436875260197, + - 1.000000000616895012251498501679602643872, + - 1.000000000659488508425026289634430354159, + - 1.000000000699493194642234170768892572882, + - 1.000000000737330567628282553087415117543, + - 1.000023316621036696460620295453277856456, + - 1.000032974787857057404928311684626421503, + - 1.000040385802079313048521250390482335902, + - 1.00004663360452259016530661221213359488, + - 1.0000521380505373899860247162705706318, + - 1.000057114467508637629346787348726350223, + - 1.000061690769779852545970707346938004879, + - 1.000065950300622136103491886720203687457, + - 1.00006995095046930174807034225078340539, + - 1.000073734868993836022551364404248563489, + - 1.007391489031309264813153180819941418531, + - 1.010463846806564696239430620915659099361, + - 1.012825626038880105597738761474228363542, + - 1.014819592594577564927398399257428492725, + - 1.016578512742400177512255407989807698099, + - 1.018170476517182636083407324035097024753, + - 1.019635932177973215702948823070039007361, + - 1.021001233780440980009663527189756124983, + - 1.022284686760270309618528459224732558767, + - 1.023499619082082348038906498637836105447, + - 1.033342436522109918536891072083243897233, + - 1.040939194524944844012076988438386306843, + - 1.047373634492196231421755878017895964061, + - 1.053065496629607111615572634090884988897, + - 1.058230030703619902820337106917657189605, + - 1.06299509412938704964298950857825124135, + - 1.067443986111355120560366087010834293872, + - 1.071634561663924136735470389832541413862, + - 1.07560894118662498941494486924522316597, + - 1.108081880631165502564629660944418191031, + - 1.133487001006868638317076487349933855181, + - 1.155245851821528613609784258821055266176, + - 1.174682608817289477552149783867901714817, + - 1.192475850408615960644596781702366026321, + - 1.209028378276581220769059281765172085749, + - 1.224602449817731587352403997390766826335, + - 1.239380103200799714836392811991400433357, + - 1.253493791367214516100457405907304877145); + +{ Lower branch, X close to 0 } +const WM2 : array[1..68] of Float = + (- 96.67475603368003636615083422832414231073, + - 95.97433737593292677679699834708774152264, + - 95.56459382507349364043974513871359837914, + - 95.27386489130628866261760496192716897551, + - 95.0483515329550645558378163981346085731, + - 94.86408948075132603599669916724611501067, + - 94.70829516116125928735505687861553800851, + - 94.57333777268864473984718625104978190798, + - 94.45429521137271454134108055166168787618, + - 94.34780665137385269060032461028588648619, + - 73.37311031382297679706747875812087452918, + - 72.67033891766978907253811160121558649554, + - 72.25920015786413889986246462168541066725, + - 71.9674726772681844325410195162521230103, + - 71.74117979478106456261839111929684980709, + - 71.55627755942675731851469544735603279342, + - 71.39993966508440988906136771384270319452, + - 71.26450969134836299738230265916604879247, + - 71.14504894849287026061378869987876478469, + - 71.03818524971357411174259539994036186653, + - 49.96298427667447244531514297262540669957, + - 49.25557728489066973476436802404294348267, + - 48.84167348449764278180827692232244878061, + - 48.54795966722336777861228992424053274064, + - 48.32011181512544381639923088992262632623, + - 48.13392971864323755677656581326964166718, + - 47.97650308277095858785998266172487372203, + - 47.84012504158555569017852884133421231303, + - 47.71982419568730714141619502661365943996, + - 47.61220592218922310708330388890925734186, + - 26.29523881924692569411012882185491823773, + - 25.57429135222126159950976461862116397347, + - 25.15218334705420805339928870686463192335, + - 24.85251554543232259250342343156454440592, + - 24.61997095867949438248843689371454503831, + - 24.42989922074834124324823589226341161866, + - 24.26914663885402405126372567664280388966, + - 24.12985944288624210229238972590881794092, + - 24.00697058168597098928369714836882130512, + - 23.8970195845316574350263109196222825525, + - 14.16360081581018300910955630361089957762, + - 13.41624453595298662833544556875899262976, + - 12.97753279184081358418630625949303360266, + - 12.66551396826200331850774017793451747947, + - 12.42304039760186078066171146072124458063, + - 12.22461776385387453853455424320739669321, + - 12.05663003490708840623665404674007291018, + - 11.91094134143842011964821167497982287763, + - 11.78229922740701885487699061601349928173, + - 11.66711453256635441837882744697047370583, + - 10.90655739570090676132157335673785028979, + - 10.45921112040100393534625826514848865968, + - 10.14059243262036578763968437893562720385, + - 9.892699522704254067620287857665824159861, + - 9.689637966382397752838283301312347921626, + - 9.517569762038614935107630230444563521109, + - 9.368222172408836799233763466046500781388, + - 9.236251966692597369166416348621131600216, + - 9.11800647040274012125833718204681427427, + - 8.335081377982507150789361715143483020265, + - 7.872521380098708883395239767904984410792, + - 7.541940416432904084217222998374802941589, + - 7.283997135099081646930521042317118095276, + - 7.072162048994701667487346245044653243434, + - 6.892241486671583156187212318718730022068, + - 6.735741661607793269808533725369490789074, + - 6.597171733627119347342347717832724288261, + - 6.472775124394004694741057892724488037104); + +var + I, NDT : Integer; + W : Float; + + function NDigits(W_appr : Float; W_exact : Float) : Integer; + { Returns the number of correct digits found in W_appr } + begin + if W_appr = W_exact then + NDigits := NDT + else + NDigits := Round(Log10(Abs(W_exact / (W_appr - W_exact))) + 0.5); + end; + + procedure PrintTitle(Msg : String; Offset : Boolean); + { Prints the title for a group of results } + var + I : Integer; + S : String; + begin + WriteLn; + WriteLn(Msg); + for I := 1 to Length(Msg) do + Write('-'); + WriteLn; WriteLn; + if Offset then + S := ' Offset X' + else + S := ' X '; + WriteLn(S, ' W(X) (appr) W(X) (exact) Digits correct'); + end; + + procedure PrintResult(X, W_appr : Float; W_exact : Float); + { Prints one line of results } + begin + WriteLn(X:17, ' ', W_appr:17, ' ', W_exact:17, ' ', + NDigits(W_appr, W_exact):9); + end; + +begin + NDT := Round(0.5 - Log10(MachEp)); + + WriteLn('Lambert''s W-function'); + PrintTitle('Upper branch results for X near -1/e', True); + + for I := 1 to 68 do + begin + { Check whether underflow occurs } + if DX1[I] = 0.0 then + W := LambertW(- Exp(- 1.0), True, False) + else + W := LambertW(DX1[I], True, True); + + PrintResult(DX1[I], W, WP1[I]); + end; + + PrintTitle('Upper branch results for X near 0', False); + + for I := 1 to 20 do + begin + W := LambertW(X2[I], True, False); + PrintResult(X2[I], W, WP2[I]); + end; + + for I := 1 to 20 do + begin + W := LambertW(- X2[I], True, False); + PrintResult(- X2[I], W, WP2[20 + I]); + end; + + PrintTitle('Other upper branch results', False); + + for I := 1 to 10 do + begin + W := LambertW(X3[I], True, False); + PrintResult(X3[I], W, WP3[I]); + end; + + PrintTitle('Lower branch results for X near -1/e', True); + + for I := 1 to 68 do + begin + W := LambertW(DX1[I], False, True); + PrintResult(DX1[I], W, WM1[I]); + end; + + PrintTitle('Lower branch results for X near 0', False); + + for I := 1 to 68 do + { Check for underflow } + if DX1[I] >= 0.0 then + begin + W := LambertW(- DX1[I], False, False); + PrintResult(- DX1[I], W, WM2[I]); + end; +end. diff --git a/fpmath/demo/fourier/testfft.pas b/fpmath/demo/fourier/testfft.pas new file mode 100755 index 0000000..98c2abf --- /dev/null +++ b/fpmath/demo/fourier/testfft.pas @@ -0,0 +1,254 @@ +{ ****************************************************************** + Fast Fourier Transform (modified from Pascal program by Don Cross) + ****************************************************************** + The program generates a time signal consisting of a large 200 Hz + sine wave added to a small 2000 Hz cosine wave, which is graphed + on the screen (Press a key after you are done viewing each graph) + + Next, it performs the FFT and graphs the resulting complex + frequency samples. + + Then, it filters out all frequency components above 1000 Hz in + the transformed data. + + Finally, it performs the inverse transform to get a filtered + time signal back, and graphs the result. + + In addition, the program compares the FFT with the direct + computation, on a set of random data. + + Results are stored in the output file fftout.txt + ****************************************************************** } + +program testfft; + +uses + tpmath, tpgraph; + +const + PathToBGI = 'c:\tp\bgi'; { Change as necessary } + + function F(T : Float) : Float; + begin + F := Sin(200 * 2 * PI * T) + 0.2 * Cos(2000 * 2 * PI * T); + end; + +const + NumSamples = 512; { Buffer size (power of 2) } + SamplingRate = 22050; { Sampling rate (Hz) } + MaxIndex = NumSamples - 1; { Max. array index } + MidIndex = NumSamples div 2; + DT = 1 / SamplingRate; { Time unit (s) } + DF = SamplingRate / NumSamples; { Frequency unit (Hz) } + +var + InArray, OutArray : PCompVector; + T, Freq : PVector; + OutputListingFile : Text; + I, FreqIndex, SymIndex : LongInt; + + procedure Test_CalcFrequency; + var + Z : Complex; + I : Integer; + begin + { Fill input buffers with random data } + for I := 0 to MaxIndex do + begin + InArray^[I].X := Random(10000); + InArray^[I].Y := Random(10000); + end; + + WriteLn(OutputListingFile); + WriteLn(OutputListingFile, '*** Testing procedure CalcFrequency ***'); + WriteLn(OutputListingFile); + + FFT(NumSamples, InArray, OutArray); + for I := 0 to MaxIndex do + begin + CalcFrequency(NumSamples, I, InArray, Z); + WriteLn(OutputListingFile, I:4, + OutArray^[I].X:15:6, Z.X:15:6, + OutArray^[I].Y:20:6, Z.Y:15:6); + end; + end; + + procedure ListData(DataArray : PCompVector; Comment : String); + var + I : LongInt; + begin + WriteLn(OutputListingFile, '*** ', Comment, ' ***'); + WriteLn(OutputListingFile); + WriteLn(OutputListingFile, 'index':20, 'real':20, 'imag':20); + for I := 1 to NumSamples do + begin + WriteLn(OutputListingFile, I:20, + DataArray^[I].X:20:5, DataArray^[I].Y:20:5); + end; + + WriteLn(OutputListingFile); + WriteLn(OutputListingFile, '------------------------------------------------------------------------'); + WriteLn(OutputListingFile); + end; + +procedure PlotData(T : PVector; Z : PCompVector; Title : String); +var + X : PVector; { Real part of Z } + Xmin, Xmax, Xstep : Float; { Ox scale } + Ymin, Ymax, Ystep : Float; { Oy scale } + I : Integer; { Loop variable } +begin + if not InitGraphics(9, 2, PathToBGI) then + begin + Writeln('Unable to set graphic mode!'); + Exit; + end; + + SetWindow(15, 85, 15, 85, True); + + DimVector(X, MaxIndex); + + for I := 0 to MaxIndex do + X^[I] := Z^[I].X; + + AutoScale(T, 0, MaxIndex, LinScale, Xmin, Xmax, Xstep); + AutoScale(X, 0, MaxIndex, LinScale, Ymin, Ymax, Ystep); + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetOxTitle('Time (s)'); + SetOyTitle('Amplitude'); + SetGraphTitle(Title); + + { Set point type to 0 so that only lines will be plotted } + SetPointParam(1, 0, 1, 1); + + PlotOxAxis; + PlotOyAxis; + + PlotGrid(BothGrid); + + WriteGraphTitle; + + PlotCurve(T, X, 0, MaxIndex, 1); + + ReadLn; + + LeaveGraphics; +end; + +procedure PlotFFT(Freq : PVector; Z : PCompVector; Title : String); +var + Fq : PVector; { Frequency } + X : PVector; { Real part of FFT } + Y : PVector; { Imag. part of FFT } + + Xmin, Xmax, Xstep : Float; { Ox scale } + Yr_min, Yr_max, Yr_step : Float; { Oy scale (real part) } + Yi_min, Yi_max, Yi_step : Float; { Oy scale (imag. part) } + Ymin, Ymax, Ystep : Float; { Oy scale (global) } + I : Integer; { Loop variable } +begin + DimVector(Fq, MidIndex); { Frequency } + DimVector(X, MidIndex); { Real part of FFT } + DimVector(Y, MidIndex); { Imag. part of FFT } + + if not InitGraphics(9, 2, PathToBGI) then + begin + Writeln('Unable to set graphic mode!'); + Exit; + end; + + SetWindow(15, 80, 15, 85, True); + + for I := 0 TO MidIndex do + begin + Fq^[I] := Freq^[I]; + X^[I] := Z^[I].X; + Y^[I] := Z^[I].Y; + end; + + AutoScale(Fq, 0, MidIndex, LinScale, Xmin, Xmax, Xstep); + AutoScale(X, 0, MidIndex, LinScale, Yr_min, Yr_max, Yr_step); + AutoScale(Y, 0, MidIndex, LinScale, Yi_min, Yi_max, Yi_step); + + Ymin := FMin(Yr_min, Yi_min); + Ymax := FMax(Yr_max, Yi_max); + Ystep := FMin(Yr_step, Yi_step); + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetOxTitle('Frequency (Hz)'); + SetOyTitle('FFT'); + + SetPointParam(1, 0, 1, 1); { Set point type to 0 so that } + SetPointParam(2, 0, 1, 1); { only lines will be plotted. } + + SetCurvLegend(1, 'Real'); + SetCurvLegend(2, 'Imag.'); + + PlotOxAxis; + PlotOyAxis; + + PlotGrid(BothGrid); + + WriteLegend(2, False, True); + + PlotCurve(Fq, X, 0, MidIndex, 1); + PlotCurve(Fq, Y, 0, MidIndex, 2); + + ReadLn; + + LeaveGraphics; +end; + +begin + DimCompVector(InArray, MaxIndex); + DimCompVector(OutArray, MaxIndex); + DimVector(T, MaxIndex); + DimVector(Freq, MaxIndex); + + Assign(OutputListingFile, 'fftout.txt'); + Rewrite(OutputListingFile); + + for I := 0 to MaxIndex do + begin + T^[I] := I * DT; + Freq^[I] := I * DF; + InArray^[I].X := F(T^[I]); + InArray^[I].Y := 0.0; + end; + + ListData(InArray, 'Time domain data before transform'); + PlotData(T, InArray, 'Original signal'); + + FFT(NumSamples, InArray, OutArray); + PlotFFT(Freq, OutArray, 'Fourier Transform'); + + ListData(OutArray, 'Frequency domain data after transform'); + + { Filter out everything above 1000 Hz (low-pass) } + FreqIndex := Trunc(1000.0 / DF); + SymIndex := NumSamples - FreqIndex; + + for I := 0 to MaxIndex do + begin + if ((I > FreqIndex) and (I < MidIndex)) or + ((I >= MidIndex) and (I < SymIndex)) then + begin + OutArray^[I].X := 0.0; + OutArray^[I].Y := 0.0; + end; + end; + + IFFT(NumSamples, OutArray, InArray); + + ListData(InArray, 'Time domain data after inverse transform'); + PlotData(T, InArray, 'Filtered signal'); + + Test_CalcFrequency; + + Close(OutputListingFile); +end. diff --git a/fpmath/demo/integral/conv.pas b/fpmath/demo/integral/conv.pas new file mode 100755 index 0000000..31e3e4f --- /dev/null +++ b/fpmath/demo/integral/conv.pas @@ -0,0 +1,65 @@ +{ ****************************************************************** + This program computes the convolution product H of two functions + F and G by the Gauss-Legendre method. The result is compared with + the analytical solution. + + The example functions are: + + F(x) = x * exp(-x) + G(x) = exp(-2 * x) + + The analytical solution is: + + H(x) = (F * G)(x) = (x - 1) * exp(-x) + exp(-2 * x) + ****************************************************************** } + +program Conv; + +uses + tpmath; + +function F(X : Float) : Float; +begin + F := X * Exp(-X); +end; + +function G(X : Float) : Float; +begin + G := Exp(- 2 * X); +end; + +function H(X : Float) : Float; +var + E : Float; +begin + E := Exp(-X); + H := ((X - 1) + E) * E; +end; + +const + N = 10; + +var + X, Y : array[0..N] of Float; + I : Integer; + +begin + X[0] := 0.0; + Y[0] := 0.0; + + for I := 1 to N do + begin + X[I] := 0.1 * I; + {$IFDEF FPC} + Y[I] := Convol(@F, @G, X[I]); + {$ELSE} + Y[I] := Convol(F, G, X[I]); + {$ENDIF} + end; + + WriteLn(' X Convol Exact'); + WriteLn('------------------------------'); + + for I := 0 to N do + WriteLn(X[I]:10:4, Y[I]:10:4, H(X[I]):10:4); +end. diff --git a/fpmath/demo/integral/gauss.pas b/fpmath/demo/integral/gauss.pas new file mode 100755 index 0000000..331973d --- /dev/null +++ b/fpmath/demo/integral/gauss.pas @@ -0,0 +1,59 @@ +{ ****************************************************************** + This program computes an integral by the Gauss-Legendre method. + The result is compared with the analytical solution. + + The example function is: + + F(x) = x * exp(-x) + + The analytical solution is: + + (x + G(x) = | F(t) dt = 1 - (x + 1) * exp(-x) + )0 + ****************************************************************** } + +program Gauss; + +uses + tpmath; + +function F(X : Float) : Float; +{ Function to integrate } +begin + F := X * Exp(-X); +end; + +function G(X : Float) : Float; +{ Integral } +begin + G := 1 - (X + 1) * Exp(-X); +end; + +const + N = 10; + +var + X, Y : array[0..N] of Float; + I : Integer; + +begin + X[0] := 0.0; + Y[0] := 0.0; + + for I := 1 to N do + begin + X[I] := I; + {$IFDEF FPC} + Y[I] := GausLeg0(@F, X[I]); + {$ELSE} + Y[I] := GausLeg0(F, X[I]); { or GausLeg(F, 0, X[I]) } + {$ENDIF} + end; + + WriteLn(' X GausLeg Exact'); + WriteLn('------------------------------'); + + for I := 0 to N do + WriteLn(X[I]:10:4, Y[I]:10:4, G(X[I]):10:4); +end. diff --git a/fpmath/demo/integral/test_rkf.pas b/fpmath/demo/integral/test_rkf.pas new file mode 100755 index 0000000..7847232 --- /dev/null +++ b/fpmath/demo/integral/test_rkf.pas @@ -0,0 +1,273 @@ +{ ****************************************************************** + Integrate a System of Ordinary Differential Equations By the + Runge-Kutta-Fehlberg method (double precision) + ----------------------------------------------------------------- + REFERENCE: H A Watts and L F Shampine, + Sandia Laboratories, + Albuquerque, New Mexico. + ----------------------------------------------------------------- + + Basic Release 1.1 By J-P Moreau, Paris. + TPMath adaptation by J. Debord + + Release 1.1: added test #3. + ****************************************************************** } + +program test_rkf; + +uses + crt, tpmath; + +procedure DiffEq1(T : Float; Y, Yp : PVector); +{ Differential equation for Test 1 } +begin + Yp^[1] := 0.25 * Y^[1] * (1 - Y^[1] / 20); +end; + +function Yexact1(T : Float) : Float; +{ Exact solution of the ODE for Test 1 } +begin + Yexact1 := 20 / (1 + 19 * Exp(- 0.25 * T)); +end; + +procedure DiffEq2(T : Float; Y, Yp : PVector); +{ Differential equations for Test 2 } +begin + Yp^[1] := Y^[2]; + Yp^[2] := - Y^[1]; +end; + +procedure Yexact2(T : Float; var Y1, Y2 : Float); +{ Exact solution of the ODE's for Test 2 } +begin + Y1 := Cos(T); + Y2 := - Sin(T); +end; + +procedure DiffEq3(T : Float; Y, Yp : PVector); +{ Differential equations for Test 3 } +begin + Yp^[1] := Y^[2]; + Yp^[2] := Y^[3]; + Yp^[3] := Y^[4]; + Yp^[4] := Y^[5]; + Yp^[5] := (45 * Y^[3] * Y^[4] * Y^[5] - 40 * Y^[4] * Sqr(Y^[4])) / (9 * Sqr(Y^[3])); +end; + +var { Global variables used by all test procedures } + Neqn : Integer; { Number of equations } + Y, Yp : PVector; { Functions and derivatives } + Tstart, Tstop : Float; { Integration interval } + Nstep : Integer; { Number of steps } + StepSize : Float; { Step size } + AbsErr, RelErr : Float; { Abs. and relative errors } + Flag : Integer; { Error flag } + T, Tout : Float; { Integration times } + I : Integer; { Loop variable } + +procedure Test1; +var + Yc : Float; { Exact solution } +begin + Neqn := 1; + + DimVector(Y, Neqn); + DimVector(Yp, Neqn); + + Y^[1] := 1; { Initial condition } + + Tstart := 0; + Tstop := 20; + Nstep := 5; + + StepSize := (Tstop - Tstart) / Nstep; + + AbsErr := 1.0E-6; + RelErr := 1.0E-6; + + Flag := 1; + + T := Tstart; + + WriteLn; + WriteLn('TEST01'); + WriteLn('Solve a scalar equation:'); + WriteLn; + WriteLn(' Y'' = 0.25 * Y * ( 1 - Y / 20 )'); + WriteLn; + + WriteLn(' T Y Y exact Error'); + WriteLn; + + Yc := Yexact1(T); + + WriteLn(T:5:2, Y^[1]:14:4, Yc:14:4, (Y^[1] - Yc):14:4); + + for I := 1 to Nstep do + begin + Tout := T + StepSize; + + {$IFDEF FPC} + RKF45(@DiffEq1, Neqn, Y, Yp, T, Tout, RelErr, AbsErr, Flag); + {$ELSE} + RKF45(DiffEq1, Neqn, Y, Yp, T, Tout, RelErr, AbsErr, Flag); + {$ENDIF} + + Yc := Yexact1(Tout); + + WriteLn(T:5:2, Y^[1]:14:4, Yc:14:4, (Y^[1] - Yc):14:4); + + T := Tout; + end; + + DelVector(Y, Neqn); + DelVector(Yp, Neqn); +end; + +procedure Test2; +var + Yc1, Yc2 : Float; { Exact solution } +begin + Neqn := 2; + + DimVector(Y, Neqn); + DimVector(Yp, Neqn); + + Y^[1] := 1; { Initial conditions } + Y^[2] := 0; + + Tstart := 0; + Tstop := 2 * Pi; + Nstep := 12; + + StepSize := (Tstop - Tstart) / Nstep; + + AbsErr := 1.0E-6; + RelErr := 1.0E-6; + + Flag := 1; + + T := Tstart; + + WriteLn; + WriteLn('TEST02'); + WriteLn('Solve a vector equation:'); + WriteLn; + WriteLn(' Y''(1) = Y(2)'); + WriteLn(' Y''(2) = - Y(1)'); + WriteLn; + + WriteLn(' T Y1 Y1 exact Y2 Y2 exact'); + WriteLn; + + Yexact2(T, Yc1, Yc2); + + WriteLn(T:5:2, Y^[1]:14:4, Yc1:14:4, Y^[2]:14:4, Yc2:14:4); + + for I := 1 to Nstep do + begin + Tout := T + StepSize; + + {$IFDEF FPC} + RKF45(@DiffEq2, Neqn, Y, Yp, T, Tout, RelErr, AbsErr, Flag); + {$ELSE} + RKF45(DiffEq2, Neqn, Y, Yp, T, Tout, RelErr, AbsErr, Flag); + {$ENDIF} + + Yexact2(Tout, Yc1, Yc2); + + WriteLn(T:5:2, Y^[1]:14:4, Yc1:14:4, Y^[2]:14:4, Yc2:14:4); + + T := Tout; + end; + + DelVector(Y, Neqn); + DelVector(Yp, Neqn); +end; + +procedure Test3; +begin + Neqn := 5; + + DimVector(Y, Neqn); + DimVector(Yp, Neqn); + + Y^[1] := 1; { Initial conditions } + Y^[2] := 1; + Y^[3] := 1; + Y^[4] := 1; + Y^[5] := 1; + + Tstart := 0; + Tstop := 1.5; + Nstep := 11; + + StepSize := (Tstop - Tstart) / Nstep; + + AbsErr := 1.0E-6; + RelErr := 1.0E-6; + + Flag := 1; + + T := Tstart; + + WriteLn; + WriteLn('TEST03'); + WriteLn('Solve a vector equation:'); + WriteLn; + WriteLn(' Y''(1) = Y(2)'); + WriteLn(' Y''(2) = Y(3)'); + WriteLn(' Y''(3) = Y(4)'); + WriteLn(' Y''(4) = Y(5)'); + WriteLn(' Y''(5) = (45 * Y(3) * Y(4) * Y(5) - 40 * Y(4)^3) / (9 * Y(3)^2)'); + + WriteLn; + WriteLn(' T Y1 Y2 Y3 Y4 Y5'); + WriteLn; + + WriteLn(T:5:2, Y^[1]:14:4, Y^[2]:14:4, Y^[3]:14:4, Y^[4]:14:4, Y^[5]:14:4); + + for I := 1 to Nstep do + begin + Tout := T + StepSize; + + {$IFDEF FPC} + RKF45(@DiffEq3, Neqn, Y, Yp, T, Tout, RelErr, AbsErr, Flag); + {$ELSE} + RKF45(DiffEq3, Neqn, Y, Yp, T, Tout, RelErr, AbsErr, Flag); + {$ENDIF} + + WriteLn(T:5:2, Y^[1]:14:4, Y^[2]:14:4, Y^[3]:14:4, Y^[4]:14:4, Y^[5]:14:4); + + T := Tout; + end; + + DelVector(Y, Neqn); + DelVector(Yp, Neqn); +end; + +procedure Pause; +var + Ch : Char; +begin + Writeln; + Write('Press a key to continue'); + Ch := ReadKey; + Writeln; + Writeln; +end; + +begin + WriteLn; + WriteLn('PROGRAM TEST_RKF'); + WriteLn('Demonstrate the RKF45 ODE integrator.'); + + Test1; + Pause; + + Test2; + Pause; + + Test3; + Pause; +end. diff --git a/fpmath/demo/integral/trap.pas b/fpmath/demo/integral/trap.pas new file mode 100755 index 0000000..41c6769 --- /dev/null +++ b/fpmath/demo/integral/trap.pas @@ -0,0 +1,50 @@ +{ ****************************************************************** + This program computes the area under an experimental curve + by the trapezoidal rule. The result is compared with the + exact value. + + Data are generated with the function exp(-x) for x = 0..1 + + The exact integral is: + + (1 + | exp(-x) dx = 1 - exp(-1) ~ 0.6321 + )0 + ****************************************************************** } + +program Trap; + +uses + tpmath; + +const + N = 10; + +var + X, Y : PVector; + I : Integer; + +begin + DimVector(X, N); + DimVector(Y, N); + + for I := 0 to N do + begin + X^[I] := 0.1 * I; + Y^[I] := Exp(- X^[I]); + end; + + WriteLn(' X Y'); + WriteLn('--------------------'); + + for I := 0 to N do + WriteLn(X^[I]:10:4, Y^[I]:10:4); + + WriteLn('--------------------'); + + WriteLn; + WriteLn('Area under curve:'); + WriteLn; + WriteLn('TrapInt: ', TrapInt(X, Y, N):10:4); + WriteLn('Exact : ', 1.0 - Exp(- 1.0):10:4); +end. diff --git a/fpmath/demo/matrices/cholesk.pas b/fpmath/demo/matrices/cholesk.pas new file mode 100755 index 0000000..734f3ba --- /dev/null +++ b/fpmath/demo/matrices/cholesk.pas @@ -0,0 +1,100 @@ +{ ****************************************************************** + This program computes the Cholesky factorization of a symmetric + positive definite matrix. The matrix is stored in a data file with + the following structure : + + Line 1 : dimension of the matrix (N) + Lines 2 to (N + 1) : matrix + + The file MATRIX4.DAT is an example data file with N = 3 + ****************************************************************** } + +program cholesk; + +uses + tpmath; + +var + A, L : PMatrix; { Matrix and its Cholesky factor } + B : PMatrix; { Product L * L' } + N : Integer; { Dimension of matrix } + +procedure ReadMatrix(FileName : String; var A : PMatrix; + var N : Integer); +{ ------------------------------------------------------------------ + Reads matrix from file. Note that A is passed as a VAR parameter + because it is dimensioned inside the procedure. + ------------------------------------------------------------------ } +var + F : Text; { Data file } + I, J : Integer; { Loop variables } +begin + Assign(F, FileName); + Reset(F); + Read(F, N); + DimMatrix(A, N, N); + for I := 1 to N do + for J := 1 to N do + Read(F, A^[I]^[J]); + Close(F); +end; + +procedure WriteMatrix(Title : String; A : PMatrix; N : Integer); +{ ------------------------------------------------------------------ + Writes matrix on screen + ------------------------------------------------------------------ } +var + I, J : Integer; +begin + WriteLn(#10, Title, ' :', #10); + for I := 1 to N do + begin + for J := 1 to N do + Write(A^[I]^[J]:12:6); + WriteLn; + end; +end; + +procedure MulMat(L : PMatrix; N : Integer; B : PMatrix); +{ ------------------------------------------------------------------ + Computes the product B = L * L' + ------------------------------------------------------------------ } +var + I, J, K : Integer; + M : Float; +begin + for I := 1 to N do + for J := 1 to I do + begin + M := 0.0; + for K := 1 to J do + M := M + L^[I]^[K] * L^[J]^[K]; + B^[I]^[J] := M; + if I <> J then + B^[J]^[I] := M; + end; +end; + +begin + { Read matrix A from file } + ReadMatrix('matrix4.dat', A, N); + WriteMatrix('Original matrix', A, N); + + { Dimension other matrices } + DimMatrix(L, N, N); + DimMatrix(B, N, N); + + { Perform Cholesky factorization, then compute the product L * L' + which must be equal to the original matrix } + Cholesky(A, L, 1, N); + + case MathErr of + MatOk : begin + WriteMatrix('Cholesky factor (L)', L, N); + MulMat(L, N, B); + WriteMatrix('Product L * L''', B, N); + end; + MatNotPD : Write('Matrix not positive definite'); + end; + WriteLn; +end. diff --git a/fpmath/demo/matrices/detinv.pas b/fpmath/demo/matrices/detinv.pas new file mode 100755 index 0000000..5cbaa47 --- /dev/null +++ b/fpmath/demo/matrices/detinv.pas @@ -0,0 +1,92 @@ +{ ****************************************************************** + This program computes the determinant and inverse of a square + matrix. The matrix is stored in a data file with the following + structure : + + Line 1 : dimension of the matrix (N) + Lines 2 to (N + 1) : matrix + + The file MATRIX1.DAT is an example data file with N = 4 + ****************************************************************** } + +program detinv; + +uses + tpmath; + +procedure WriteMatrix(Title : String; + A : PMatrix; + N : Integer); +{ ------------------------------------------------------------------ + Writes a matrix + ------------------------------------------------------------------ } +var + I, J : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + begin + for J := 1 to N do + Write(A^[I]^[J]:12:6); + WriteLn; + end; + WriteLn; +end; + +procedure WriteMatrixDet(Title : String; + A : PMatrix; + N : Integer; + D : Float); +{ ------------------------------------------------------------------ + Writes a matrix and its determinant + ------------------------------------------------------------------ } +begin + WriteLn('Determinant = ', D:12:6); + WriteLn; + WriteMatrix(Title, A, N); +end; + +var + F : Text; { Data file } + N : Integer; { Size of matrix } + A : PMatrix; { Matrix } + D1, D2 : Float; { Determinants } + I, J : Integer; { Loop variable } + +begin + { Read matrix from file } + Assign(F, 'matrix1.dat'); + Reset(F); + Read(F, N); + + DimMatrix(A, N, N); + + for I := 1 to N do + for J := 1 to N do + Read(F, A^[I]^[J]); + + Close(F); + + { Write matrix } + WriteMatrix('Original matrix', A, N); + + { Compute inverse matrix and determinant } + GaussJordan(A, 1, N, N, D1); + case MathErr of + MatOk : + begin + WriteMatrixDet('Inverse matrix', A, N, D1); + { Reinvert matrix. D2 = 1/D1 } + GaussJordan(A, 1, N, N, D2); + if MathErr = MatOk then + WriteMatrixDet('Reinverted inverse matrix', A, N, D2); + WriteLn('Product of determinants = ', (D1 * D2):12:6); + end; + MatSing : + Write('Singular matrix!'); + MatErrDim : + Write('Non-compatible dimensions!'); + end; +end. + diff --git a/fpmath/demo/matrices/eigensym.pas b/fpmath/demo/matrices/eigensym.pas new file mode 100755 index 0000000..3fe4631 --- /dev/null +++ b/fpmath/demo/matrices/eigensym.pas @@ -0,0 +1,123 @@ +{ ****************************************************************** + This program computes the eigenvalues and eigenvectors of a + symmetric matrix by the iterative method of Jacobi. The method + is demonstrated with Hilbert matrices. These matrices are + ill-conditioned (i.e. the ratio of the lowest to the highest + eigenvalue is very low). + + The Jacobi method applies a series of rotations to the original + matrix in order to transform it into a diagonal matrix. The diagonal + terms of this matrix are the eigenvalues. The product of the rotation + matrices gives the eigenvectors. The original matrix is destroyed + during the process. + + The parameter Tol defines the tolerance with which an off-diagonal + element of the transformed matrix is considered zero (expressed as + a fraction of the sum of squared diagonal terms). The parameter + MaxIter defines the maximal number of iterations allowed. These two + values are linked, i.e. decreasing Tol may need increasing MaxIter + to avoid non-convergence of the Jacobi procedure. + ****************************************************************** } + +program eigensym; + +uses + tpmath; + +const + MaxIter = 1000; { Maximum number of iterations } + Tol = 1.0E-8; { Required precision } + +var + N : Integer; { Size of matrix } + A : PMatrix; { Matrix } + Lambda : PVector; { Eigenvalues } + V : PMatrix; { Eigenvectors } + + procedure Hilbert(A : PMatrix; N : Integer); +{ ------------------------------------------------------------------ + Generates the Hilbert matrix of order N + + ( 1 1/2 1/3 1/4 ... 1/N ) + ( 1/2 1/3 1/4 1/5 ... 1/(N+1) ) + A = ( 1/3 1/4 1/5 1/6 ... 1/(N+2) ) + ( ........................................... ) + ( 1/N 1/(N+1) 1/(N+2) 1/(N+3) ... 1/(2N-1) ) + + ------------------------------------------------------------------ } + var + I, J : Integer; + begin + { First row of matrix } + A^[1]^[1] := 1.0; + for J := 2 to N do + A^[1]^[J] := 1.0 / J; + + for I := 2 to N do + begin + { Last column of matrix } + A^[I]^[N] := 1.0 / (N + I - 1); + { Fill matrix } + for J := 1 to N - 1 do + A^[I]^[J] := A^[I - 1]^[J + 1]; + end; + end; + + procedure WriteResults(N : Integer; V : PMatrix; Lambda : PVector); +{ ------------------------------------------------------------------ + Outputs results to screen + ------------------------------------------------------------------ } + var + I, J : Integer; + Ch : Char; + begin + WriteLn; + WriteLn('Eigenvalues :'); + WriteLn; + for I := 1 to N do + WriteLn(Lambda^[I]:26); + + if N < 8 then + begin + WriteLn; WriteLn('Eigenvectors (columns) :'); WriteLn; + for I := 1 to N do + begin + for J := 1 to N do + Write(V^[I]^[J]:10:6); + WriteLn; + end; + end; + end; + +begin + repeat + WriteLn; + Write('Order of Hilbert matrix (1 to end) : '); + ReadLn(N); + + if N > 1 then + begin + { Allocate vectors and matrices } + DimMatrix(A, N, N); + DimMatrix(V, N, N); + DimVector(Lambda, N); + + { Generate Hilbert matrix of order N } + Hilbert(A, N); + + { Compute eigenvalues and eigenvectors } + Jacobi(A, 1, N, MaxIter, Tol, Lambda, V); + + case MathErr of + MatOk : WriteResults(N, V, Lambda); + MatNonConv : WriteLn('Too many iterations!'); + end; + + { Deallocate vectors and matrices so that they + may be redimensioned at the next iteration } + DelMatrix(A, N, N); + DelMatrix(V, N, N); + DelVector(Lambda, N); + end; + until N < 2; +end. diff --git a/fpmath/demo/matrices/eigenval.pas b/fpmath/demo/matrices/eigenval.pas new file mode 100755 index 0000000..ae15487 --- /dev/null +++ b/fpmath/demo/matrices/eigenval.pas @@ -0,0 +1,105 @@ +{ ****************************************************************** + This program computes the eigenvalues of a general square matrix + (see EIGENSYM.PAS for a symmetric matrix). The matrix is stored in + a data file with the following structure : + + Line 1 : dimension of the matrix (N) + Lines 2 to (N + 1) : matrix + + The file MATRIX1.DAT is an example data file with N = 4 + ****************************************************************** } + +program eigenval; + +uses + tpmath; + +var + A : PMatrix; { Matrix } + N : Integer; { Dimension of matrix } + Lambda : PCompVector; { Eigenvalues } + I : Integer; { Loop variable } + ErrCode : Integer; { Error code } + + procedure ReadMatrix(FileName : String; var A : PMatrix; + var N : Integer); +{ ---------------------------------------------------------------------- + Reads matrix from file. Note that A is passed as a VAR parameter + because it is dimensioned inside the procedure. + ---------------------------------------------------------------------- } + var + F : Text; { Data file } + I, J : Integer; { Loop variable } + begin + Assign(F, FileName); + Reset(F); + Read(F, N); + DimMatrix(A, N, N); + for I := 1 to N do + for J := 1 to N do + Read(F, A^[I]^[J]); + Close(F); + end; + + procedure WriteMatrix(Title : String; A : PMatrix; N : Integer); +{ ---------------------------------------------------------------------- + Writes matrix on screen + ---------------------------------------------------------------------- } + var + I, J : Integer; + begin + WriteLn; + WriteLn(Title, ':'); + WriteLn; + for I := 1 to N do + begin + for J := 1 to N do + Write(A^[I]^[J]:12:6); + WriteLn; + end; + WriteLn; + end; + + procedure WriteEigenValue(Lambda : PCompVector; I : Integer); +{ ---------------------------------------------------------------------- + Writes the I-th eigenvalue + ---------------------------------------------------------------------- } + begin + if Lambda^[I].Y = 0.0 then + WriteLn(Lambda^[I].X:12:6) + else + begin + Write(Lambda^[I].X:12:6); + if Lambda^[I].Y > 0.0 then Write(' + ') else Write(' - '); + WriteLn(Abs(Lambda^[I].Y):12:6, ' * i'); + end; + end; + +begin + { Read matrix from file } + ReadMatrix('matrix1.dat', A, N); + WriteMatrix('Original matrix', A, N); + + { Dimension the vector containing the eigenvalues } + DimCompVector(Lambda, N); + + { Compute eigenvalues } + EigenVals(A, 1, N, Lambda); + + ErrCode := MathErr; + + if ErrCode = 0 then + begin + WriteLn('Eigenvalues:'); + WriteLn; + for I := 1 to N do + WriteEigenValue(Lambda, I); + end + else + begin + WriteLn('Unable to find eigenvalues Lambda[1] to Lambda[', -ErrCode, ']'); + WriteLn('Eigenvalues Lambda[', 1 - ErrCode, '] to Lambda[', N, ']:'); + for I := 1 - ErrCode to N do + WriteEigenValue(Lambda, I); + end; +end. diff --git a/fpmath/demo/matrices/eigenvec.pas b/fpmath/demo/matrices/eigenvec.pas new file mode 100755 index 0000000..3adbac9 --- /dev/null +++ b/fpmath/demo/matrices/eigenvec.pas @@ -0,0 +1,118 @@ +{ ********************************************************************** + This program computes the eigenvalues and eigenvectors of a + general square matrix. + + The matrix is stored in a data file with the following structure : + + Line 1 : dimension of the matrix (N) + Lines 2 to (N + 1) : matrix + + The file MATRIX1.DAT is an example data file with N = 4. + ********************************************************************** } + +program eigenvec; + +uses + tpmath; + +var + A : PMatrix; { Matrix } + N : Integer; { Dimension of matrix } + Lambda : PCompVector; { Eigenvalues } + V : PMatrix; { Eigenvectors } + I : Integer; { Loop variable } + ErrCode : Integer; { Error code } + + procedure ReadMatrix(FileName : String; var A : PMatrix; var N : Integer); +{ ---------------------------------------------------------------------- + Reads matrix from file. Note that A is passed as a VAR parameter + because it is dimensioned inside the procedure. + ---------------------------------------------------------------------- } + var + F : Text; { Data file } + I, J : Integer; { Loop variable } + begin + Assign(F, FileName); + Reset(F); + Read(F, N); + DimMatrix(A, N, N); + for I := 1 to N do + for J := 1 to N do + Read(F, A^[I]^[J]); + Close(F); + end; + + procedure WriteNumber(Re, Im : Float); +{ ---------------------------------------------------------------------- + Writes a real or complex number + ---------------------------------------------------------------------- } + begin + Write(Re:12:6); + if Im = 0.0 then + WriteLn + else if Im > 0.0 then + WriteLn(' + ', Im:12:6, ' * i') + else + WriteLn(' - ', -Im:12:6, ' * i') + end; + + procedure WriteEigenValue(Lambda : PCompVector; I : Integer); +{ ---------------------------------------------------------------------- + Writes the I-th eigenvalue + ---------------------------------------------------------------------- } + begin + WriteLn; Write('Eigenvalue: '); + WriteNumber(Lambda^[I].X, Lambda^[I].Y); + end; + + procedure WriteEigenVector(Lambda : PCompVector; + V : PMatrix; N, I : Integer); +{ ---------------------------------------------------------------------- + Writes the I-th eigenvector + ---------------------------------------------------------------------- } + var + K : Integer; + begin + WriteLn; WriteLn('Eigenvector: '); WriteLn; + if Lambda^[I].Y = 0.0 then + { Eigenvector is in column I of V } + for K := 1 to N do + WriteNumber(V^[K]^[I], 0.0) + else if Lambda^[I].Y > 0.0 then + { Real and imag. parts of eigenvector are in columns I and (I+1) } + for K := 1 to N do + WriteNumber(V^[K]^[I], V^[K]^[I+1]) + else + { Conjugate of eigenvector is in columns (I-1) and I } + for K := 1 to N do + WriteNumber(V^[K]^[I-1], - V^[K]^[I]); + end; + +begin + ReadMatrix('matrix1.dat', A, N); + + DimCompVector(Lambda, N); + DimMatrix(V, N, N); + + { Compute eigenvalues and eigenvectors (A is destroyed) } + EigenVect(A, 1, N, Lambda, V); + + { Display results } + if MathErr = 0 then + for I := 1 to N do + begin + WriteEigenValue(Lambda, I); + WriteEigenVector(Lambda, V, N, I); + WriteLn; Write('Press <Enter> to continue...'); + ReadLn; + end + else + begin + WriteLn('Unable to find eigenvalues Lambda[1] to Lambda[', -ErrCode, ']'); + WriteLn('Eigenvalues Lambda[', 1 - ErrCode, '] to Lambda[', N, ']:'); + for I := 1 - ErrCode to N do + WriteEigenValue(Lambda, I); + end; + +end. + diff --git a/fpmath/demo/matrices/hilbert.pas b/fpmath/demo/matrices/hilbert.pas new file mode 100755 index 0000000..284e825 --- /dev/null +++ b/fpmath/demo/matrices/hilbert.pas @@ -0,0 +1,146 @@ +{ ****************************************************************** + This program solves a system of linear equations, of the form + AX = B, by the method of Gauss-Jordan. The method is demonstrated + by solving a series of Hilbert systems of increasing order. + Hilbert systems have ill-conditioned matrices (i.e. with + determinants close to zero), so that the matrix is considered + singular for an order which depends on the numerical precision + of the software. + + The type of real numbers is defined by the compiler directives + (see UTYPES.PAS for details). The constant MachEp (defined in + UTYPES.PAS) sets the numerical precision which can be obtained + with each type. When the determinant falls below this value the + matrix is considered singular. + ****************************************************************** } + +program hilbert; + +uses + tpmath; + +procedure HilbertSystem(N : Integer; var A : PMatrix); +{ ------------------------------------------------------------------ + Generates the Hilbert system of order N + + A[1..N, 1..N] = system matrix : + + ( 1 1/2 1/3 1/4 ... 1/N ) + ( 1/2 1/3 1/4 1/5 ... 1/(N+1) ) + A = ( 1/3 1/4 1/5 1/6 ... 1/(N+2) ) + ( ........................................... ) + ( 1/N 1/(N+1) 1/(N+2) 1/(N+3) ... 1/(2N-1) ) + + A[1..N, N+1] = vector of constant terms : + + N + A[i, N+1] = Sum A[i,j] + j=1 + + The solution vector is X = [1 1 1 ... 1] + ------------------------------------------------------------------ } +var + I, J, M : Integer; + Sum : Float; +begin + { First row of matrix } + A^[1]^[1] := 1.0; + for J := 2 to N do + A^[1]^[J] := 1.0 / J; + + for I := 2 to N do + begin + { N-th column of matrix } + A^[I]^[N] := 1.0 / (N + I - 1); + { Fill matrix } + for J := 1 to N - 1 do + A^[I]^[J] := A^[I - 1]^[J + 1]; + end; + + { Last column = Constant vector } + M := N + 1; + for I := 1 to N do + begin + Sum := 0.0; + for J := 1 to N do + Sum := Sum + A^[I]^[J]; + A^[I]^[M] := Sum; + end; +end; + +procedure WriteHilbertMatrix(N : Integer; A : PMatrix); +var + I, J, M : Integer; +begin + WriteLn('System matrix and constant vector :'); + WriteLn; + M := N + 1; + for I := 1 to N do + begin + for J := 1 to M do + Write(A^[I]^[J]:10:6); + WriteLn; + end; + WriteLn; +end; + +procedure WriteSolution(ErrCode, N : Integer; A : PMatrix; D : Float); +var + I, M : Integer; +begin + if ErrCode = MatSing then + WriteLn('Determinant <', D:10, ' ==> Quasi-Singular Matrix !') + else + begin + WriteLn('Solution vector :'); + WriteLn; + M := N + 1; + for I := 1 to N do + WriteLn(A^[I]^[M]:10:6); + WriteLn; + WriteLn('Determinant : ', D:10); + end; + WriteLn; + Write('Press <Enter> ...'); + ReadLn; +end; + +var + N : Integer; { Order of the system } + M : Integer; { N + 1 } + ErrCode : Integer; { Error code } + A : PMatrix; { System matrix } + D : Float; { Determinant } + +begin + { Initialize } + N := 1; + ErrCode := 0; + + { Main loop } + while ErrCode = 0 do + begin + { Set system order } + Inc(N); + M := N + 1; + + { Allocate matrix } + DimMatrix(A, N, M); + + { Generate Hilbert system of order N } + HilbertSystem(N, A); + WriteLn; WriteLn('HILBERT SYSTEM OF ORDER ', N); WriteLn; + if N < 7 then WriteHilbertMatrix(N, A); + + { Solve Hilbert system } + GaussJordan(A, 1, N, M, D); + ErrCode := MathErr; + + { Write solution } + WriteSolution(ErrCode, N, A, D); + + { Deallocate matrix so that it may be + redimensioned at the next iteration } + DelMatrix(A, N, M); + end; +end. diff --git a/fpmath/demo/matrices/lineq1.pas b/fpmath/demo/matrices/lineq1.pas new file mode 100755 index 0000000..d416a40 --- /dev/null +++ b/fpmath/demo/matrices/lineq1.pas @@ -0,0 +1,90 @@ +{ ****************************************************************** + This program solves a system of linear equations (A * X = B) with + a single constant vector by the Gauss-Jordan method. The system is + stored in a data file with the following structure : + + Line 1 : dimension of the matrix (N) + Following lines : first N columns = matrix + last column = constant vector + + The file MATRIX3.DAT is an example data file with N = 4 + ****************************************************************** } + +program lineq1; + +uses + tpmath; + +procedure WriteMatrix(Title : String; + A : PMatrix; + N : Integer); +var + I, J : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + begin + for J := 1 to N do + Write(A^[I]^[J]:12:6); + WriteLn; + end; + WriteLn; +end; + +procedure WriteVector(Title : String; + V : PVector; + N : Integer); +var + I : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + WriteLn(V^[I]:12:6); + WriteLn; +end; + +var + N : Integer; { Matrix dimension } + A : PMatrix; { System matrix } + B : PVector; { Constant vector } + D : Float; { Determinant } + F : Text; { Data file } + I, J : Integer; { Loop variables } + +begin + { Read matrix from file } + Assign(F, 'matrix3.dat'); + Reset(F); + Read(F, N); + + DimMatrix(A, N, N); + DimVector(B, N); + + for I := 1 to N do + begin + for J := 1 to N do + Read(F, A^[I]^[J]); + Read(F, B^[I]); + end; + + Close(F); + + { Read and display data } + WriteMatrix('System matrix', A, N); + WriteVector('Constant vector', B, N); + + { Solve system } + LinEq(A, B, 1, N, D); + + { Write results } + case MathErr of + MatOk : begin + WriteMatrix('Inverse matrix', A, N); + WriteVector('Solution vector', B, N); + WriteLn('Determinant = ', D:12:6); + end; + MatSing : WriteLn('Singular matrix!'); + end; +end. diff --git a/fpmath/demo/matrices/lineqm.pas b/fpmath/demo/matrices/lineqm.pas new file mode 100755 index 0000000..5eeafd6 --- /dev/null +++ b/fpmath/demo/matrices/lineqm.pas @@ -0,0 +1,78 @@ +{ ****************************************************************** + This program solves a system of linear equations (A * X = B) with + several constant vectors by the Gauss-Jordan method. The system is + stored in a data file with the following structure : + + Line 1 : size of matrix (N) and number of constant vectors (P) + + Following lines : first N columns = matrix + other columns = constant vectors + + The file MATRIX2.DAT is an example data file with N = 4 and P = 5 + ****************************************************************** } + +program lineqm; + +uses + tpmath; + +procedure WriteMatrix(Title : String; + A : PMatrix; + N : Integer; + Col1, Col2 : Integer); +{ ------------------------------------------------------------------ + Writes a matrix from Col1 to Col2 + ------------------------------------------------------------------ } +var + I, J : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + begin + for J := Col1 to Col2 do + Write(A^[I]^[J]:12:6); + WriteLn; + end; + WriteLn; +end; + +var + A : PMatrix; { System matrix } + N, M : Integer; { Matrix dimensions } + D : Float; { Determinant } + F : Text; { Data file } + I, J : Integer; { Loop variables } + +begin + { Read matrix from file } + Assign(F, 'matrix2.dat'); + Reset(F); + Read(F, N, M); + + DimMatrix(A, N, M); + + for I := 1 to N do + for J := 1 to M do + Read(F, A^[I]^[J]); + + Close(F); + + { Read and display data } + WriteMatrix('System matrix', A, N, 1, N); + WriteMatrix('Constant vectors', A, N, N + 1, M); + + { Solve system } + GaussJordan(A, 1, N, M, D); + + { Write results } + case MathErr of + MatOk : begin + WriteMatrix('Inverse matrix', A, N, 1, N); + WriteMatrix('Solution vectors', A, N, N + 1, M); + WriteLn('Determinant = ', D:12:6); + end; + MatSing : WriteLn('Singular matrix!'); + MatErrDim : WriteLn('Non-compatible dimensions!'); + end; +end. diff --git a/fpmath/demo/matrices/test_lu.pas b/fpmath/demo/matrices/test_lu.pas new file mode 100755 index 0000000..16b4f52 --- /dev/null +++ b/fpmath/demo/matrices/test_lu.pas @@ -0,0 +1,93 @@ +{ ****************************************************************** + This program solves a system of linear equations (A * X = B) with + a single constant vector by the LU decomposition method. The system + is stored in a data file with the following structure : + + Line 1 : dimension of the matrix (N) + Following lines : first N columns = matrix + last column = constant vector + + The file MATRIX3.DAT is an example data file with N = 4 + ****************************************************************** } + +program test_lu; + +uses + tpmath; + +procedure WriteMatrix(Title : String; + A : PMatrix; + N : Integer); +var + I, J : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + begin + for J := 1 to N do + Write(A^[I]^[J]:12:6); + WriteLn; + end; + WriteLn; +end; + +procedure WriteVector(Title : String; + V : PVector; + N : Integer); +var + I : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + WriteLn(V^[I]:12:6); + WriteLn; +end; + +var + N : Integer; { Matrix dimension } + A : PMatrix; { System matrix } + B : PVector; { Constant vector } + X : PVector; { Solution vector } + F : Text; { Data file } + I, J : Integer; { Loop variables } + +begin + { Read matrix from file } + Assign(F, 'matrix3.dat'); + Reset(F); + Read(F, N); + + DimMatrix(A, N, N); + DimVector(B, N); + + for I := 1 to N do + begin + for J := 1 to N do + Read(F, A^[I]^[J]); + Read(F, B^[I]); + end; + + Close(F); + + { Read and display data } + WriteMatrix('System matrix', A, N); + WriteVector('Constant vector', B, N); + + { Perform LU decomposition of A. If successful, solve system } + + LU_Decomp(A, 1, N); + + if MathErr = MatSing then + begin + WriteLn('Singular matrix!'); + Halt; + end; + + DimVector(X, N); + + LU_Solve(A, B, 1, N, X); + + WriteVector('Solution vector', X, N); +end. diff --git a/fpmath/demo/matrices/test_qr.pas b/fpmath/demo/matrices/test_qr.pas new file mode 100755 index 0000000..2fdcac6 --- /dev/null +++ b/fpmath/demo/matrices/test_qr.pas @@ -0,0 +1,96 @@ +{ ****************************************************************** + This program solves a system of linear equations (A * X = B) with + a single constant vector by the QR decomposition method. The system + is stored in a data file with the following structure : + + Line 1 : dimension of the matrix (N) + Following lines : first N columns = matrix + last column = constant vector + + The file MATRIX3.DAT is an example data file with N = 4 + ****************************************************************** } + +program test_qr; + +uses + tpmath; + +procedure WriteMatrix(Title : String; + A : PMatrix; + N : Integer); +var + I, J : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + begin + for J := 1 to N do + Write(A^[I]^[J]:12:6); + WriteLn; + end; + WriteLn; +end; + +procedure WriteVector(Title : String; + V : PVector; + N : Integer); +var + I : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + WriteLn(V^[I]:12:6); + WriteLn; +end; + +var + N : Integer; { Matrix dimension } + A : PMatrix; { System matrix } + B : PVector; { Constant vector } + R : PMatrix; { matrix from QR decomp. } + X : PVector; { Solution vector } + F : Text; { Data file } + I, J : Integer; { Loop variables } + +begin + { Read matrix from file } + Assign(F, 'matrix3.dat'); + Reset(F); + Read(F, N); + + DimMatrix(A, N, N); + DimVector(B, N); + + for I := 1 to N do + begin + for J := 1 to N do + Read(F, A^[I]^[J]); + Read(F, B^[I]); + end; + + Close(F); + + { Read and display data } + WriteMatrix('System matrix', A, N); + WriteVector('Constant vector', B, N); + + { Perform QR decomposition of A. If successful, solve system } + + DimMatrix(R, N, N); + + QR_Decomp(A, 1, N, N, R); + + if MathErr = MatSing then + begin + WriteLn('Singular matrix!'); + Halt; + end; + + DimVector(X, N); + + QR_Solve(A, R, B, 1, N, N, X); + + WriteVector('Solution vector', X, N); +end. diff --git a/fpmath/demo/matrices/test_svd.pas b/fpmath/demo/matrices/test_svd.pas new file mode 100755 index 0000000..5b05ee1 --- /dev/null +++ b/fpmath/demo/matrices/test_svd.pas @@ -0,0 +1,98 @@ +{ ****************************************************************** + This program solves a system of linear equations (A * X = B) with + a single constant vector by singular value decomposition. The + system is stored in a data file with the following structure : + + Line 1 : dimension of the matrix (N) + Following lines : first N columns = matrix + last column = constant vector + + The file MATRIX3.DAT is an example data file with N = 4 + ****************************************************************** } + +program test_svd; + +uses + tpmath; + +procedure WriteMatrix(Title : String; + A : PMatrix; + N : Integer); +var + I, J : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + begin + for J := 1 to N do + Write(A^[I]^[J]:12:6); + WriteLn; + end; + WriteLn; +end; + +procedure WriteVector(Title : String; + V : PVector; + N : Integer); +var + I : Integer; +begin + WriteLn(Title, ' :'); + WriteLn; + for I := 1 to N do + WriteLn(V^[I]:12:6); + WriteLn; +end; + +var + N : Integer; { Matrix dimension } + A : PMatrix; { System matrix } + B : PVector; { Constant vector } + S : PVector; { Singular values } + V : PMatrix; { Matrix from SVD } + X : PVector; { Solution vector } + F : Text; { Data file } + I, J : Integer; { Loop variables } + +begin + { Read matrix from file } + Assign(F, 'matrix3.dat'); + Reset(F); + Read(F, N); + + DimMatrix(A, N, N); + DimVector(B, N); + + for I := 1 to N do + begin + for J := 1 to N do + Read(F, A^[I]^[J]); + Read(F, B^[I]); + end; + + Close(F); + + { Read and display data } + WriteMatrix('System matrix', A, N); + WriteVector('Constant vector', B, N); + + { Perform SV decomposition of A. If successful, solve system } + + DimVector(S, N); + DimMatrix(V, N, N); + + SV_Decomp(A, 1, N, N, S, V); + + if MathErr = MatNonConv then + begin + WriteLn('Non-convergence!'); + Halt; + end; + + DimVector(X, N); + + SV_Solve(A, S, V, B, 1, N, N, X); + + WriteVector('Solution vector', X, N); +end. diff --git a/fpmath/demo/optim/minline.pas b/fpmath/demo/optim/minline.pas new file mode 100755 index 0000000..e3d94e8 --- /dev/null +++ b/fpmath/demo/optim/minline.pas @@ -0,0 +1,91 @@ +{ ****************************************************************** + Minimization of a function of several variables along a line + + Example taken from "Numerical Recipes": + + Func = (X(1)-1)^2 + (X(2)-1)^2 + (X(3)-1)^2 + + The minimum is F = 0 at (1, 1, 1), i. e. for a step R = 1 from + X = (0, 0, 0) in the direction DeltaX = (1, 1, 1) + + The program tries a series of directions: + + ( Sqrt(2) * Cos [(Pi / 2) * (I / 10)] ) + DeltaX = ( Sqrt(2) * Sin [(Pi / 2) * (I / 10)] ) + ( 1 ) + + For each pass, the location of the minimum, and the value of the + function at the minimum, are printed. The minimum is at I = 5 + ****************************************************************** } + +program minline; + +uses + tpmath; + +const + Nvar = 3; { Number of variables } + MaxIter = 1000; { Max number of iterations } + Tol = 1.0E-7; { Required precision } + PiDiv20 = 0.1570796326794897; { Pi / 20 } + +var + X : PVector; { Starting point } + DeltaX : PVector; { Search direction } + R : Float; { Initial step } + F_min : Float; { Function value at minimum } + I : Integer; { Loop variable } + Z : Float; { Auxiliary variable } + +function Func(X : PVector) : Float; +{ Function to be minimized } +begin + Func := Sqr(X^[1] - 1.0) + Sqr(X^[2] - 1.0) + Sqr(X^[3] - 1.0); +end; + +procedure PrintResult(I : Integer; X : PVector; F_min : Float); +var + J : Integer; +begin + Write(I:3); + + for J := 1 to Nvar do + Write(X^[J]:12:6); + + WriteLn(' ', F_min); +end; + +begin + WriteLn; + WriteLn(' I X(1) X(2) X(3) Fmin'); + WriteLn('------------------------------------------------------------------'); + + DimVector(X, Nvar); + DimVector(DeltaX, Nvar); + + for I := 0 to 10 do + begin + X^[1] := 0.0; + X^[2] := 0.0; + X^[3] := 0.0; + + Z := I * PiDiv20; + + DeltaX^[1] := Sqrt2 * Cos(Z); + DeltaX^[2] := Sqrt2 * Sin(Z); + DeltaX^[3] := 1.0; + + R := 0.1; + + {$IFDEF FPC} + LinMin(@Func, X, DeltaX, 1, Nvar, R, MaxIter, Tol, F_min); + {$ELSE} + LinMin(Func, X, DeltaX, 1, Nvar, R, MaxIter, Tol, F_min); + {$ENDIF} + + if MathErr = OptOk then + PrintResult(I, X, F_min) + else + WriteLn('Non-convergence!'); + end; +end. diff --git a/fpmath/demo/optim/numgrad.inc b/fpmath/demo/optim/numgrad.inc new file mode 100755 index 0000000..3e69217 --- /dev/null +++ b/fpmath/demo/optim/numgrad.inc @@ -0,0 +1,42 @@ +{ ****************************************************************** + Numerical gradient + ****************************************************************** } + +procedure Gradient(X, G : PVector); + +const + Eta = 1.0E-4; { Relative increment } + +var + I : Integer; { Loop variable } + Temp : Float; { Temporary variable } + Delta : Float; { Increment } + Xm : Float; { X - Delta } + Xp : Float; { X + Delta } + Fm : Float; { F(X - Delta) } + Fp : Float; { F(X + Delta) } + +begin + for I := 1 to Nvar do + begin + if X^[I] <> 0.0 then + Delta := Eta * Abs(X^[I]) + else + Delta := Eta; + + Xp := X^[I] + Delta; + Xm := X^[I] - Delta; + + Temp := X^[I]; + + X^[I] := Xm; + Fm := Func(X); + + X^[I] := Xp; + Fp := Func(X); + + G^[I] := (Fp - Fm) / (2.0 * Delta); + + X^[I] := Temp + end; +end; diff --git a/fpmath/demo/optim/numhess.inc b/fpmath/demo/optim/numhess.inc new file mode 100755 index 0000000..a692163 --- /dev/null +++ b/fpmath/demo/optim/numhess.inc @@ -0,0 +1,72 @@ +{ ****************************************************************** + Numerical hessian and gradient + ****************************************************************** } + +procedure HessGrad(X, G : PVector; H : PMatrix); + +const + Eta = 1.0E-6; { Relative increment } + +var + Delta, Xminus, Xplus, Fminus, Fplus : PVector; + Temp1, Temp2, F, F2plus : Float; + I, J : Integer; + +begin + DimVector(Delta, Nvar); { Increments } + DimVector(Xminus, Nvar); { X - Delta } + DimVector(Xplus, Nvar); { X + Delta } + DimVector(Fminus, Nvar); { F(X - Delta) } + DimVector(Fplus, Nvar); { F(X + Delta) } + + F := Func(X); + + for I := 1 to Nvar do + begin + if X^[I] <> 0.0 then + Delta^[I] := Eta * Abs(X^[I]) + else + Delta^[I] := Eta; + Xplus^[I] := X^[I] + Delta^[I]; + Xminus^[I] := X^[I] - Delta^[I]; + end; + + for I := 1 to Nvar do + begin + Temp1 := X^[I]; + X^[I] := Xminus^[I]; + Fminus^[I] := Func(X); + X^[I] := Xplus^[I]; + Fplus^[I] := Func(X); + X^[I] := Temp1; + end; + + for I := 1 to Nvar do + begin + G^[I] := (Fplus^[I] - Fminus^[I]) / (2.0 * Delta^[I]); + H^[I]^[I] := (Fplus^[I] + Fminus^[I] - 2.0 * F) / Sqr(Delta^[I]); + end; + + for I := 1 to Pred(Nvar) do + begin + Temp1 := X^[I]; + X^[I] := Xplus^[I]; + for J := Succ(I) to Nvar do + begin + Temp2 := X^[J]; + X^[J] := Xplus^[J]; + F2plus := Func(X); + H^[I]^[J] := (F2plus - Fplus^[I] - Fplus^[J] + F) / (Delta^[I] * Delta^[J]); + H^[J]^[I] := H^[I]^[J]; + X^[J] := Temp2; + end; + X^[I] := Temp1; + end; + + DelVector(Delta, Nvar); + DelVector(Xminus, Nvar); + DelVector(Xplus, Nvar); + DelVector(Fminus, Nvar); + DelVector(Fplus, Nvar); +end; + diff --git a/fpmath/demo/optim/testbfgs.pas b/fpmath/demo/optim/testbfgs.pas new file mode 100755 index 0000000..9333968 --- /dev/null +++ b/fpmath/demo/optim/testbfgs.pas @@ -0,0 +1,141 @@ +{ ****************************************************************** + Minimization of a function of several variables by the Broyden- + Fletcher-Goldfarb-Shanno (BFGS) method. + + Example: Rosenbrock's function: + + F(X, Y) = 100 * (Y - X^2)^2 + (1 - X)^2 + + ( -400 * (Y - X^2) * X - 2 + 2 * X ) + Gradient: G = ( ) + ( 200 * Y - 200 * X^2 ) + + ( 1200 * X^2 - 400 * Y + 2 -400 * X ) + Hessian: H = ( ) + ( -400 * X 200 ) + + True minimum is at (1, 1), F = 0 + + The inverse hessian at the minimum is: + + ( 1/2 1 ) + ( 1 401/200 ) + + Ref: H. Rosenbrock, Comput. J., 1960, 3, 175 + ****************************************************************** } + +program testbfgs; + +uses + tpmath; + +{ ------------------------------------------------------------------ + Define number of variables, number of iterations, and precision + ------------------------------------------------------------------ } + +const + Nvar = 2; { Number of variables } + MaxIter = 1000; { Max number of iterations } + Tol = 1.0E-6; { Required precision } + +{ ------------------------------------------------------------------ + Define the function to be minimized + ------------------------------------------------------------------ } + +function Func(X : PVector) : Float; +begin + Func := 100.0 * Sqr(X^[2] - Sqr(X^[1])) + Sqr(1.0 - X^[1]); +end; + +{ ------------------------------------------------------------------ + Define the subroutine which computes the gradient of the function. + It is recommended to use analytical derivatives whenever possible. + Otherwise you can use the alternative code provided in numgrad.inc + ------------------------------------------------------------------ } + +procedure Gradient(X, G : PVector); +var + A, B : Float; +begin + A := X^[2] - Sqr(X^[1]); + B := 1.0 - X^[1]; + + G^[1] := - 400.0 * X^[1] * A - 2.0 * B; + G^[2] := 200.0 * A; +end; + + +{ ------------------------------------------------------------------ + Alternative code when analytical derivatives are not available + ------------------------------------------------------------------ } + +(* + +{$i numgrad.inc} + +*) + +{ ------------------------------------------------------------------ + Main program + ------------------------------------------------------------------ } + +var + X : PVector; { Variables: X^[1] = X, X^[2] = Y } + G : PVector; { Gradient vector } + H_inv : PMatrix; { Inverse Hessian matrix } + F_min : Float; { Function value at minimum } + I, J : Integer; { Loop variables } + +begin + DimVector(X, Nvar); + DimVector(G, Nvar); + DimMatrix(H_inv, Nvar, Nvar); + + X^[1] := 2.0; + X^[2] := 2.0; + + { Save BFGS iterations in a file } + SaveBFGS('bfgs.txt'); + + { Perform minimization } + + {$IFDEF FPC} + BFGS(@Func, @Gradient, X, 1, Nvar, MaxIter, Tol, F_min, G, H_inv); + {$ELSE} + BFGS(Func, Gradient, X, 1, Nvar, MaxIter, Tol, F_min, G, H_inv); + {$ENDIF} + + if MathErr = OptNonConv then + begin + Write('Non-convergence!'); + Halt; + end; + + WriteLn('Minimization of Rosenbrock''s function (BFGS method)'); + WriteLn('----------------------------------------------------'); + WriteLn; + + WriteLn('Coordinates of minimum:'); WriteLn; + + for I := 1 to Nvar do + WriteLn(X^[I]:12:6); + + WriteLn; WriteLn('Function value:'); WriteLn; + + WriteLn('Fmin = ', F_min); + + WriteLn; WriteLn('Gradient:'); WriteLn; + + for I := 1 to Nvar do + WriteLn(G^[I]:12:6); + + WriteLn; WriteLn('Inverse Hessian matrix:'); WriteLn; + + for I := 1 to Nvar do + begin + for J := 1 to Nvar do + Write(H_inv^[I]^[J]:12:6); + WriteLn; + end; + +end. diff --git a/fpmath/demo/optim/testmarq.pas b/fpmath/demo/optim/testmarq.pas new file mode 100755 index 0000000..9fa1843 --- /dev/null +++ b/fpmath/demo/optim/testmarq.pas @@ -0,0 +1,176 @@ +{ ****************************************************************** + Minimization of a function of several variables by Marquardt's + method. + + Example: Rosenbrock's function: + + F(X, Y) = 100 * (Y - X^2)^2 + (1 - X)^2 + + ( -400 * (Y - X^2) * X - 2 + 2 * X ) + Gradient: G = ( ) + ( 200 * Y - 200 * X^2 ) + + ( 1200 * X^2 - 400 * Y + 2 -400 * X ) + Hessian: H = ( ) + ( -400 * X 200 ) + + Det(H) = 80000 * (X^2 - Y) + 400 + + True minimum is at (1, 1), F = 0 + + The inverse hessian at the minimum is: + + ( 1/2 1 ) + ( 1 401/200 ) + + Ref: H. Rosenbrock, Comput. J., 1960, 3, 175 + ****************************************************************** } + +program testmarq; + +uses + tpmath; + +{ ------------------------------------------------------------------ + Define number of variables, number of iterations, and precision + ------------------------------------------------------------------ } + +const + Nvar = 2; { Number of variables } + MaxIter = 1000; { Max number of iterations } + Tol = 1.0E-6; { Required precision } + +{ ------------------------------------------------------------------ + Define the function to be minimized + ------------------------------------------------------------------ } + +function Func(X : PVector) : Float; +begin + Func := 100.0 * Sqr(X^[2] - Sqr(X^[1])) + Sqr(1.0 - X^[1]); +end; + +{ ------------------------------------------------------------------ + Define the subroutine which computes the gradient and hessian of + the function. It is recommended to use analytical derivatives + whenever possible. Otherwise you can use the alternative code + provided in numhess.inc + ------------------------------------------------------------------ } + +procedure HessGrad(X, G : PVector; H : PMatrix); +var + A, B, C : Float; +begin + C := Sqr(X^[1]); + A := X^[2] - C; + B := 1.0 - X^[1]; + + G^[1] := - 400.0 * X^[1] * A - 2.0 * B; + G^[2] := 200.0 * A; + + H^[1]^[1] := 1200.0 * C - 400.0 * X^[2] + 2; + H^[1]^[2] := - 400.0 * X^[1]; + H^[2]^[1] := H^[1]^[2]; + H^[2]^[2] := 200.0; +end; + +{ ------------------------------------------------------------------ + Alternative code when analytical derivatives are not available + ------------------------------------------------------------------ } + +(* + +{$i numhess.inc} + +*) + +{ ------------------------------------------------------------------ + Main program + ------------------------------------------------------------------ } + +var + X : PVector; { Variables: X^[1] = X, X^[2] = Y } + G : PVector; { Gradient vector } + H_inv : PMatrix; { Inverse Hessian matrix } + F_min : Float; { Function value at minimum } + Det : Float; { Determinant of hessian } + I, J : Integer; { Loop variables } + +begin + DimVector(X, Nvar); + DimVector(G, Nvar); + DimMatrix(H_inv, Nvar, Nvar); + + X^[1] := 2.0; + X^[2] := 2.0; + + { Save Marquardt iterations in a file } + SaveMarquardt('marquard.txt'); + + { Perform minimization } + + {$IFDEF FPC} + Marquardt(@Func, @HessGrad, X, 1, Nvar, MaxIter, Tol, F_min, G, H_inv, Det); + {$ELSE} + Marquardt(Func, HessGrad, X, 1, Nvar, MaxIter, Tol, F_min, G, H_inv, Det); + {$ENDIF} + + { It may be useful to perform one Newton iteration at the end of + Marquardt's algorithm, to ensure that the Marquardt parameter + Lambda has been effectively set to zero. } + + {$IFDEF FPC} + Newton(@Func, @HessGrad, X, 1, Nvar, 1, Tol, F_min, G, H_inv, Det); + {$ELSE} + Newton(Func, HessGrad, X, 1, Nvar, 1, Tol, F_min, G, H_inv, Det); + {$ENDIF} + + case MathErr of + OptNonConv : + begin + Write('Non-convergence!'); + Halt; + end; + OptSing : + begin + Write('Singular Hessian matrix!'); + Halt; + end; + OptBigLambda : + begin + Write('Too high Marquardt parameter!'); + Halt; + end; + + end; + + WriteLn('Minimization of Rosenbrock''s function (Marquardt''s method)'); + WriteLn('----------------------------------------------------------'); + WriteLn; + + WriteLn('Coordinates of minimum:'); WriteLn; + + for I := 1 to Nvar do + WriteLn(X^[I]:12:6); + + WriteLn; WriteLn('Function value:'); WriteLn; + + WriteLn('Fmin = ', F_min); + + WriteLn; WriteLn('Gradient:'); WriteLn; + + for I := 1 to Nvar do + WriteLn(G^[I]:12:6); + + WriteLn; WriteLn('Inverse Hessian matrix:'); WriteLn; + + for I := 1 to Nvar do + begin + for J := 1 to Nvar do + Write(H_inv^[I]^[J]:12:6); + WriteLn; + end; + + WriteLn; WriteLn('Determinant of Hessian:'); WriteLn; + + WriteLn(Det:12:6); +end. diff --git a/fpmath/demo/optim/testnewt.pas b/fpmath/demo/optim/testnewt.pas new file mode 100755 index 0000000..1288dd2 --- /dev/null +++ b/fpmath/demo/optim/testnewt.pas @@ -0,0 +1,160 @@ +{ ****************************************************************** + Minimization of a function of several variables by the Newton- + Raphson method. + + Example: Rosenbrock's function: + + F(X, Y) = 100 * (Y - X^2)^2 + (1 - X)^2 + + ( -400 * (Y - X^2) * X - 2 + 2 * X ) + Gradient: G = ( ) + ( 200 * Y - 200 * X^2 ) + + ( 1200 * X^2 - 400 * Y + 2 -400 * X ) + Hessian: H = ( ) + ( -400 * X 200 ) + + Det(H) = 80000 * (X^2 - Y) + 400 + + True minimum is at (1, 1), F = 0 + + The inverse hessian at the minimum is: + + ( 1/2 1 ) + ( 1 401/200 ) + + Ref: H. Rosenbrock, Comput. J., 1960, 3, 175 + ****************************************************************** } + +program testnewt; + +uses + tpmath; + +{ ------------------------------------------------------------------ + Define number of variables, number of iterations, and precision + ------------------------------------------------------------------ } + +const + Nvar = 2; { Number of variables } + MaxIter = 1000; { Max number of iterations } + Tol = 1.0E-6; { Required precision } + +{ ------------------------------------------------------------------ + Define the function to be minimized + ------------------------------------------------------------------ } + +function Func(X : PVector) : Float; +begin + Func := 100.0 * Sqr(X^[2] - Sqr(X^[1])) + Sqr(1.0 - X^[1]); +end; + +{ ------------------------------------------------------------------ + Define the subroutine which computes the gradient and hessian of + the function. It is recommended to use analytical derivatives + whenever possible. Otherwise you can use the alternative code + provided in numhess.inc + ------------------------------------------------------------------ } + +procedure HessGrad(X, G : PVector; H : PMatrix); +var + A, B, C : Float; +begin + C := Sqr(X^[1]); + A := X^[2] - C; + B := 1.0 - X^[1]; + + G^[1] := - 400.0 * X^[1] * A - 2.0 * B; + G^[2] := 200.0 * A; + + H^[1]^[1] := 1200.0 * C - 400.0 * X^[2] + 2; + H^[1]^[2] := - 400.0 * X^[1]; + H^[2]^[1] := H^[1]^[2]; + H^[2]^[2] := 200.0; +end; + +{ ------------------------------------------------------------------ + Alternative code when analytical derivatives are not available + ------------------------------------------------------------------ } + +(* + +{$i numhess.inc} + +*) + +{ ------------------------------------------------------------------ + Main program + ------------------------------------------------------------------ } + +var + X : PVector; { Variables: X^[1] = X, X^[2] = Y } + G : PVector; { Gradient vector } + H_inv : PMatrix; { Inverse Hessian matrix } + F_min : Float; { Function value at minimum } + Det : Float; { Determinant of hessian } + I, J : Integer; { Loop variables } + +begin + DimVector(X, Nvar); + DimVector(G, Nvar); + DimMatrix(H_inv, Nvar, Nvar); + + X^[1] := 2.0; + X^[2] := 2.0; + + { Save Newton-Raphson iterations in a file } + SaveNewton('newton.txt'); + + { Perform minimization } + + {$IFDEF FPC} + Newton(@Func, @HessGrad, X, 1, Nvar, MaxIter, Tol, F_min, G, H_inv, Det); + {$ELSE} + Newton(Func, HessGrad, X, 1, Nvar, MaxIter, Tol, F_min, G, H_inv, Det); + {$ENDIF} + + case MathErr of + OptNonConv : + begin + Write('Non-convergence!'); + Halt; + end; + OptSing : + begin + Write('Singular Hessian matrix!'); + Halt; + end; + end; + + WriteLn('Minimization of Rosenbrock''s function (Newton-Raphson method)'); + WriteLn('--------------------------------------------------------------'); + WriteLn; + + WriteLn('Coordinates of minimum:'); WriteLn; + + for I := 1 to Nvar do + WriteLn(X^[I]:12:6); + + WriteLn; WriteLn('Function value:'); WriteLn; + + WriteLn('Fmin = ', F_min); + + WriteLn; WriteLn('Gradient:'); WriteLn; + + for I := 1 to Nvar do + WriteLn(G^[I]:12:6); + + WriteLn; WriteLn('Inverse Hessian matrix:'); WriteLn; + + for I := 1 to Nvar do + begin + for J := 1 to Nvar do + Write(H_inv^[I]^[J]:12:6); + WriteLn; + end; + + WriteLn; WriteLn('Determinant of Hessian:'); WriteLn; + + WriteLn(Det:12:6); +end. diff --git a/fpmath/demo/optim/testsimp.pas b/fpmath/demo/optim/testsimp.pas new file mode 100755 index 0000000..23cb4cc --- /dev/null +++ b/fpmath/demo/optim/testsimp.pas @@ -0,0 +1,82 @@ +{ ****************************************************************** + Minimization of a function of several variables by simplex method. + + Example: Rosenbrock's function: + + F(X, Y) = 100 * (Y - X^2)^2 + (1 - X)^2 + + True minimum is at (1, 1), F = 0 + + Ref: H. Rosenbrock, Comput. J., 1960, 3, 175 + ****************************************************************** } + +program testsimp; + +uses + tpmath; + +{ ------------------------------------------------------------------ + Define number of variables, number of iterations, and precision + ------------------------------------------------------------------ } + +const + Nvar = 2; { Number of variables } + MaxIter = 1000; { Max number of iterations } + Tol = 1.0E-6; { Required precision } + +{ ------------------------------------------------------------------ + Define the function to be minimized + ------------------------------------------------------------------ } + +function Func(X : PVector) : Float; +begin + Func := 100.0 * Sqr(X^[2] - Sqr(X^[1])) + Sqr(1.0 - X^[1]); +end; + +{ ------------------------------------------------------------------ + Main program + ------------------------------------------------------------------ } + +var + X : PVector; { Variables: X^[1] = X, X^[2] = Y } + Fmin : Float; { Function value at minimum } + I : Integer; { Loop variable } + +begin + DimVector(X, Nvar); + + X^[1] := 2.0; + X^[2] := 2.0; + + { Save Simplex iterations in a file } + SaveSimplex('simplex.txt'); + + { Perform minimization } + + {$IFDEF FPC} + Simplex(@Func, X, 1, Nvar, MaxIter, Tol, Fmin); + {$ELSE} + Simplex(Func, X, 1, Nvar, MaxIter, Tol, Fmin); + {$ENDIF} + + if MathErr = OptNonConv then + begin + Write('Non-convergence!'); + Halt; + end; + + WriteLn('Minimization of Rosenbrock''s function (simplex method)'); + WriteLn('------------------------------------------------------'); + WriteLn; + + WriteLn('Coordinates of minimum:'); WriteLn; + + for I := 1 to Nvar do + WriteLn('X(', I, ') = ', X^[I]:12:6); + + WriteLn; + WriteLn('Function value:'); + WriteLn; + + WriteLn('Fmin = ', Fmin); +end. diff --git a/fpmath/demo/polynom/evalfrac.pas b/fpmath/demo/polynom/evalfrac.pas new file mode 100755 index 0000000..d8cea3d --- /dev/null +++ b/fpmath/demo/polynom/evalfrac.pas @@ -0,0 +1,56 @@ +{ ****************************************************************** + This program evaluates a rational fraction + + 1 + X + 2*X^2 + 3*X^3 + 4*X^4 + Example fraction is F(X) = ------------------------------- + 1 + 2*X - 3*X^2 + 4*X^3 - 5*X^4 + + ****************************************************************** } + +program evalfrac; + +uses + tpmath; + +var + Coef : PVector; + Deg1, Deg2 : Integer; + X, Y : Float; + +begin + +{ ------------------------------------------------------------------ + Define fraction here, in the form: + + Coef(0) + Coef(1) * X + ... + Coef(Deg1) * X^Deg1 + F(X) = ----------------------------------------------------- + 1 + Coef(Deg1+1) * X + ... + Coef(Deg1+Deg2) * X^Deg2 + + Note that the first coefficient of the denominator must be 1 + ------------------------------------------------------------------ } + + Deg1 := 4; + Deg2 := 4; + + DimVector(Coef, Deg1 + Deg2); + + Coef^[0] := 1; + Coef^[1] := 1; + Coef^[2] := 2; + Coef^[3] := 3; + Coef^[4] := 4; + Coef^[5] := 2; + Coef^[6] := -3; + Coef^[7] := 4; + Coef^[8] := -5; + +{ ------------------------------------------------------------------ } + + repeat + Write('X = '); + ReadLn(X); + Y := RFrac(X, Coef, Deg1, Deg2); + WriteLn('F(X) = ', Y:12:6); + until X = 0; + +end. diff --git a/fpmath/demo/polynom/evalpoly.pas b/fpmath/demo/polynom/evalpoly.pas new file mode 100755 index 0000000..d84a876 --- /dev/null +++ b/fpmath/demo/polynom/evalpoly.pas @@ -0,0 +1,43 @@ +{ ****************************************************************** + This program evaluates a polynomial + + Example polynomial is P(X) = 1 + X + 2*X^2 + 3*X^3 + 4*X^4 + ****************************************************************** } + +program evalpoly; + +uses + tpmath; + +var + Coef : PVector; + Deg : Integer; + X, Y : Float; + +begin + +{ ------------------------------------------------------------------ + Define polynomial here, in the form: + Coef(0) + Coef(1) * X + Coef(2) * X^2 + ... + Coef(Deg) * X^Deg + ------------------------------------------------------------------ } + + Deg := 4; + + DimVector(Coef, Deg); + + Coef^[0] := 1; + Coef^[1] := 1; + Coef^[2] := 2; + Coef^[3] := 3; + Coef^[4] := 4; + +{ ------------------------------------------------------------------ } + + repeat + Write('X = '); + ReadLn(X); + Y := Poly(X, Coef, Deg); + WriteLn('P(X) = ', Y:12:6); + until X = 0; + +end. diff --git a/fpmath/demo/polynom/polyroot.pas b/fpmath/demo/polynom/polyroot.pas new file mode 100755 index 0000000..9642972 --- /dev/null +++ b/fpmath/demo/polynom/polyroot.pas @@ -0,0 +1,116 @@ +{ ****************************************************************** + This program solves a polynomial equation + + Analytical solutions are used up to degree 4, then the polynomial + is solved by the method of the companion matrix. + + The example polynomial is: + + 720 - 1764 * X + 1624 * X^2 - 735 * X^3 + + 175 * X^4 - 21 * X^5 + X^6 + + The roots are: X = 1, 2 ... 6 + ****************************************************************** } + +program polyroot; + +uses + tpmath; + +var + Coef : PVector; + Z : PCompVector; + Deg, I, J, Nc, Nr : Integer; + +begin + +{ ------------------------------------------------------------------ + Define polynomial here, in the form: + Coef(0) + Coef(1) * X + Coef(2) * X^2 + ... + Coef(Deg) * X^Deg + ------------------------------------------------------------------ } + + Deg := 6; + + DimVector(Coef, Deg); + DimCompVector(Z, Deg); + + Coef^[0] := 720; + Coef^[1] := -1764; + Coef^[2] := 1624; + Coef^[3] := -735; + Coef^[4] := 175; + Coef^[5] := -21; + Coef^[6] := 1; + +{ ------------------------------------------------------------------ } + + Writeln; + Writeln('Polynomial:'); + Writeln; + + for I := 0 to Deg do + if Coef^[I] <> 0 then + begin + if Coef^[I] > 0 then Write(' + '); + if Coef^[I] < 0 then Write(' - '); + Write(Abs(Coef^[I]):12:6, ' '); + if I > 0 then Write('X'); + if I > 1 then Write('^', I); + Writeln; + end; + + Writeln; + Writeln; + + { Solve polynomial. Nr is the number of real roots } + case Deg of + 1 : Nr := RootPol1(Coef^[0], Coef^[1], Z^[1].X); + 2 : Nr := RootPol2(Coef, Z); + 3 : Nr := RootPol3(Coef, Z); + 4 : Nr := RootPol4(Coef, Z); + otherwise + Nr := RootPol(Coef, Deg, Z); + end; + + { Case when an error occurs } + if Nr < 0 then + begin + Writeln('Error during root evaluation !'); + Halt; + end; + + { Set the small imaginary parts to zero (optional) } + Nr := SetRealRoots(Deg, Z, 1.0E-8); + + { Sort roots: first real roots, in ascending order, + then complex roots (unordered) } + SortRoots(Deg, Z); + + { Print real roots } + if Nr > 0 then + begin + Writeln(Nr, ' real root(s):'); + Writeln; + + for I := 1 to Nr do + Writeln('X[', I, '] = ', Z^[I].X:12:6); + + Writeln; + end; + + { Print complex roots } + Nc := Deg - Nr; + if Nc > 0 then + begin + Writeln(Nc, ' complex roots:'); + Writeln; + + for I := 1 to Nc do + begin + J := I + Nr; + Write('X[', J, '] = ', Z^[J].X:12:6); + if Z^[J].Y > 0.0 then Write(' + ') else Write(' - '); + Writeln(Abs(Z^[J].Y):12:6, ' * i'); + end; + end; +end. diff --git a/fpmath/demo/proba/binom.pas b/fpmath/demo/proba/binom.pas new file mode 100755 index 0000000..56b4df9 --- /dev/null +++ b/fpmath/demo/proba/binom.pas @@ -0,0 +1,36 @@ +{ ****************************************************************** + This program computes the binomial distribution B(N,P). + For each value of K (K = 0..N), the probability Prob(X = K) + is computed from function PBinom. The cumulative probability + Prob(X <= K) is computed either by direct summation or by a + call to function FBinom. + ****************************************************************** } + +program Binom; + +uses + tpmath; + +const + N = 10; { Number of repetitions } + P = 0.4; { Probability of success } + +var + K : Integer; + PK, S : Float; + +begin + WriteLn; + WriteLn('Binomial distribution: N = ', N:3, ', P = ', P:6:4); + WriteLn; + WriteLn(' K Prob(K) Sum FBinom'); + WriteLn('-----------------------------------'); + + S := 0.0; + for K := 0 to N do + begin + PK := PBinom(N, P, K); + S := S + PK; + WriteLn(K:2, PK:11:4, S:11:4, FBinom(N, P, K):11:4); + end; +end. diff --git a/fpmath/demo/random/mt.txt b/fpmath/demo/random/mt.txt new file mode 100755 index 0000000..418cfdf --- /dev/null +++ b/fpmath/demo/random/mt.txt @@ -0,0 +1,403 @@ +1000 outputs of IRanGen + 1067595299 955945823 477289528 -187748513 -65990820 + -950634582 -939387601 227628506 810200273 -1703677129 + -1734706621 -1052231088 646746669 1479517882 -49495023 + 1143372638 -431296802 -1073945326 1773610557 1138697238 + 1421897700 1269916527 -1435033255 1764463362 -420075249 + -329647375 72549643 -1910978366 -1694748603 -1057474916 + -1502065820 725331109 605841842 271258942 715137098 + -996967760 1322965544 -65388187 1395091102 -559269576 + 2101727825 -564679552 -1344532966 1661921839 -1399387714 + -1924455817 1004092106 -2047870615 2111242379 -1057622033 + -212542537 219785033 -1840927407 -585384325 835606218 + -1883017413 -1559762266 756421180 -2119757592 1873865952 + -1532433059 -133159442 -943867956 181129879 -1025075400 + 776029799 -2076805317 -1293221500 1866825872 2133627728 + 34862734 1191934573 -1192655942 -1378449533 1012402762 + -2110135979 -37567847 -1395470158 -476872234 -1264210562 + 1282161629 420003642 -1968545819 -1553511579 1278020671 + -550787675 271777016 -1668637278 -1734403305 -1238989596 + -61439730 1228397661 -699387974 1077915006 -1899035398 + 1851927286 -1281283790 1999971931 -1288078334 1049781534 + 1488758959 -803191066 104418065 -1846699999 -1219353181 + -422634696 891912190 -358419537 -2025786333 -1661512212 + 1047636807 -1690354919 -1585661567 1952216715 207593580 + -1445069262 670771757 -2084496188 467711165 263046873 + -725299381 1042291111 -431450217 1464270005 -1536645944 + -504167480 -1993688572 -1188685866 7974801 -1502505660 + 555991332 621766759 1322453093 853629228 686962251 + 1455120532 957753161 1802033300 1021534190 -808919985 + 1902128914 -593829240 -118542633 1795608698 560858864 + -557214542 -1153796298 1553553385 -927160022 711546358 + -1819841793 262969859 251416325 -1314890302 1806565895 + 969527843 -765640123 -1558624256 -1307770562 1649016367 + -2088791485 -1246792495 -632463743 -1156115684 -1634823492 + 1663017612 1816683231 411916003 -407505982 -1947923217 + 1015311755 1203592432 -2124019530 -1725546580 813872093 + 1105387678 1431142475 220570551 -51334581 -115375441 + -1687498165 -1204354055 282341803 1734241730 1391822177 + 1001254810 827927915 1886687171 -359869949 -1663178582 + -389804030 110554195 -1847011650 -577764321 -990174221 + -555352817 -1235839828 953919171 -1704843582 1132511021 + -499373617 -1506936867 982155079 -822617740 859942552 + -1613959905 -1995343243 647443547 233600422 608168955 + -605639843 1849778220 1608438222 -326808939 -1601989520 + -1443094724 246750393 -712148668 -965314987 -258600386 + 1012970930 950780808 -335198552 -1756417251 191422718 + -1636824921 -1018598285 -1367229812 1234200027 1920815603 + -758892607 1535612501 -2110825225 -1018012242 428488088 + -1916555312 -235197746 -381222555 -1562828050 64369859 + -539297222 842839565 -1475072830 -1880248323 1010060670 + 1839715346 -1884656160 152774329 -809957816 -192865784 + -1442242992 879944024 1785007662 -1546682833 1354768064 + -1027182560 -2025839579 -1293726535 -1115170533 895723219 + 865924942 -3396359 89355264 1471026971 -180786551 + -1093027545 -1427490297 -1834101236 -691092725 -2056086864 + -986551128 2072246611 -1539313457 -521230048 1709066580 + -12235829 -1548797126 -1462398966 433439009 -1119188564 + 26248366 -1743584495 183214346 -401627780 1928168445 + 1337157619 -865870742 -1019796396 1782047316 -30563540 + 1876594403 -5307724 -1071132402 1728705513 -226722562 + -1427127009 1147798696 302879820 1730407747 1923824407 + 1180597908 1569786639 198796327 560793173 2107345620 + -1588976980 -846195190 -616593141 758635715 884524671 + 486356516 1774865603 -413741070 -1659753689 1181121587 + 1508809820 -1115979055 1594193633 1235154121 326117244 + -1990935871 937054774 -1607551351 -1102577956 2003740439 + 1823766188 -1535423894 10067710 1533252662 -162472312 + 82378136 420615890 -827404133 541562091 -759017432 + -2017648099 -964144443 -1079313122 -181135317 -89970305 + -2132718963 -1039873774 -2075878387 -1316688259 255818579 + -1435618668 -1197686985 -1725246173 1861951120 -1387887217 + -1575500130 998319094 -1773032169 -1890841958 259456032 + 2086860995 1839848496 1893547357 -1766969771 1489393124 + -1434111947 76448234 -2030033261 744914583 -1708176037 + 1385380501 66529922 1819103258 1899300332 2098173828 + 1793831094 276463159 360132945 -116755238 595015228 + 177071838 -1494887006 1573557746 1548998935 378454223 + 1460534296 1116274283 -1182582233 -585205500 827999348 + -714924449 1913901014 614021289 -16439273 1905177404 + 45407939 -996784062 1184848810 -650040966 -371331837 + 1627046213 -617090537 969772772 1160524753 1522441192 + 452369933 1527502551 832490847 1003299676 1071381111 + -1403711820 973747308 -208070188 1847554542 -399315698 + -2067146957 1621250941 -1413622605 -711401475 -784562798 + 849362119 862871471 797858058 -1427192364 -1473684684 + -1022564150 -296987391 209178708 1805135652 6783381 + -1471605873 792580494 -31217526 776439581 -496773473 + -1441523202 -1565459822 1071873341 1329010206 1289336450 + -967286538 2011491779 80157208 922428856 1158943220 + 1667230961 -1833944476 -1686122137 387516115 -949615386 + 1495629111 -196813139 -1138317683 -769268697 -160059259 + 446713264 2137537399 -677563784 813966752 1157943946 + -560274331 1680301658 -1114568823 -785112585 -2066852684 + 1008102291 486805123 863791847 -1105842006 1050308116 + -517625770 -3240795 844061465 1347461791 -1468485715 + 745465012 2055805750 -34757821 -1908274199 -1314320555 + 447229436 2077782664 1232942813 -271964564 1399011509 + -1154397447 -1715058074 -500109825 900758066 -1407767613 + 1720257997 -927472365 -1626046067 955539029 -476240864 + 1105704962 -405760041 -2017597989 -1548482791 1761846513 + -1881050512 -1609840211 -54709353 1166726899 -79751581 + -1212875229 -334505350 1663304043 2087473241 -132377310 + -1787656518 1579665506 767234210 970676017 492207530 + 1441679602 1314785090 -1032764726 -877875554 1561989210 + -1283560516 1146609202 -1032646256 1374872171 1634688712 + 1280458888 -2064943314 419323804 -1032067496 39783310 + 1641619040 1700368658 -2087020668 -1723666357 -1870887530 + 780290914 -1579772200 -904009601 163151474 -1985432754 + 1860018424 555755123 280320104 1604831083 -1581944913 + 1728987441 -655011794 623065489 -466336349 -19488246 + -778619913 -1951016101 -1864289540 635534992 -426267547 + 808442435 -1224323227 -12801293 2093181383 2023555632 + 1568662086 -872594676 -160444946 -1277987753 -1035647062 + -1406936567 -1109713420 -36187653 1267304371 1022517473 + 815943045 929020012 -1299716278 -923684000 -686938247 + 2018485115 122123397 -1484298146 1411365618 1238391329 + 1186786476 -1138998205 -2052025986 1765554882 279121160 + -15128781 1641578514 -498643281 13351065 103516986 + 1609694427 551411743 -1801195687 1316337047 -362316440 + -105267093 463397996 -1357232230 1855616529 -1668119306 + 55091862 -471616085 753448970 -249921796 1274127772 + 1124182256 92039808 2126345552 425973257 386287896 + -1705097105 1987762798 -210140323 -2122510611 -928383841 + -692000643 -1916163761 -1393202863 -578038290 -584808296 + -1641518141 -825224666 -1198522820 -362402643 -1699709863 + 318974657 -1148764812 853571438 144400272 -526558455 + 782634401 -2133858293 570039522 1886241521 14249488 + -2064163068 1604941699 -366253961 -373024787 -2139160404 + 134366254 430507376 1924011722 276713377 196481886 + -680156304 1610021185 1785757066 851346168 -533818653 + -1376131654 -930544911 -1282682830 -559008445 -1651813404 + -516359065 1164289832 205853021 -1418855065 -791569014 + -1216570295 -822929375 1748894853 -1554105821 316056182 + 1660426908 168885906 956005527 -310612507 566521563 + 1001109523 1216710575 -1342682539 -460534215 -452358995 + -1827614888 -320526032 -1038365551 1409353924 1329904859 + -1987407003 -1169749417 -672047112 -462181612 -412601345 + -1986430181 -1635812268 1450441945 -762709693 -1108643102 + 1225603425 1124246549 175808705 -1285824977 -1498257137 + -642977189 160762750 1902254979 1698648476 1134980669 + 497144426 -992277961 -237481666 -691436533 -207714709 + 427812652 286876201 823134128 1627554964 -549402969 + -1705741204 -92942802 62878473 -1019381402 -307843232 + -1503190137 1916869511 -1709105391 1375038919 1403421920 + 60249114 -483096846 -1273469287 -1681974094 528933105 + -1537605975 -953564332 -1673105596 273128190 -279715118 + -1200186294 1621621288 -1957356119 1796718448 1258965619 + -53054156 2138560392 -1272777073 -120786372 450094611 + -1020242716 617150026 -1590306631 1469700689 1341616587 + 356715071 1188789960 -2016098161 1766569160 -1499070661 + 57824704 -1401470916 1235723989 1630694347 -367006774 + 428891364 1814070806 -2006967509 -169026112 -326863407 + -746243246 1025597707 1404281500 2002212197 92429143 + -1981023352 -1891881216 -1288786662 -732985532 1671860914 + 1768520622 1803542985 844848113 -1288827375 1410888995 + 1157749833 2125704913 1789979528 1799263423 741157179 + -1889104987 767040434 -1639725906 -631547117 -2122958200 + -1783036109 1680542666 231857466 1154981000 157168255 + 1454112128 -789095197 1929775046 -1985544946 2143329496 + -1334250394 407610648 -1356859167 -1713217697 538837155 + -1952338429 430543915 740188568 1937713272 -979752164 + 2085587024 -264201609 766054429 -777325457 689721775 + 1294158986 1753287754 -92365948 1974852792 33459103 + -726879761 -1150289861 1686130825 -160024283 -1289228861 + -695673910 426570142 754104406 -634074732 1964545167 + 829466833 821587464 1746693036 1006492428 1595312919 + 1256599985 1024482560 1897312280 -1392064095 691790057 + 1037515867 -1118136088 1968401055 -2121460472 1089055278 + 1748401123 -1353587214 968412354 1818753861 -1321766430 + -419015522 1119354008 -306363157 1647155589 -2062516470 + -808909285 -639183253 -535708834 847163678 1082052057 + 989516446 -1423425541 -1098656226 -365004218 658187585 + -630022655 -2119818126 -2091258149 -1538952607 -1838493377 + -404699906 1293787864 -1464619312 -1235686365 -136164776 + 1561677400 -1708396358 783570352 1355506163 31495586 + -505529953 -954417867 2092501630 896419368 671715824 + -764517215 -691413158 1055991716 -852659077 1499434728 + -1164678823 -655460296 17769680 -2035225876 487032199 + -67823894 -601196040 1880482820 -370156500 381462353 + -277111305 -1842932353 -1558286463 -2085100911 2128986379 + 437874044 595759426 641721026 1636065708 -395830363 + 629879088 -703792790 351984326 -1656183752 -1946523015 + -1953362636 2123933692 143443325 1525942256 364660499 + 599149312 939093251 1523003209 106601097 376589484 + 1346282236 1297387043 764598052 -553749185 933457002 + 1886424424 -1075336280 525405256 -1280731677 323149677 + 2038881721 -194838253 -1443252195 -1310939218 1888574695 + 2014194741 -779773416 -114393766 -833142933 -1652971799 + -1115737051 -1392672313 -2077646840 -254115141 1784656905 + -983060365 87498458 -1541995478 -1659492999 -1463751930 + -612736190 -1374923403 -522037592 -1478592352 309949752 + -1911208442 154870719 385111597 1191604312 1840700563 + 872191186 -1369418595 1310412747 2102066999 1504727249 + -720668546 1191230036 -964392030 -1114675199 -755619575 + 681369118 -989841544 -646733699 950049240 -121709603 + 1760124957 512151405 681175196 580563018 1169662867 + -279933742 -1607186195 699691603 -1621473108 1137221356 + 123599888 472658308 1053598179 1012713758 -813902453 + -535506283 -313509340 -464379634 1877191791 -643970560 + 988064871 -779505696 -205890064 -2069819848 1249609188 + -1651815433 -398763161 -1877971395 1397735321 -834941650 + +1000 outputs of RanGen2 + 0.26275443 0.49000644 0.48670464 0.60143112 0.77933125 + 0.19867227 0.44218740 0.53427201 0.28842173 0.78180608 + 0.42179002 0.70785655 0.04534773 0.19644020 0.88107718 + 0.73978165 0.15286910 0.57514568 0.72765211 0.44872929 + 0.24557914 0.12664415 0.04708246 0.40959343 0.92043116 + 0.36334511 0.69189126 0.64718544 0.20259889 0.13426346 + 0.27408121 0.54531601 0.54605807 0.38595519 0.19398270 + 0.55377184 0.11711170 0.55565708 0.60133577 0.91500776 + 0.41810699 0.72320679 0.73353705 0.42871862 0.48897234 + 0.69786706 0.30558809 0.56961067 0.05840445 0.40479405 + 0.13288060 0.45009721 0.04948447 0.70645042 0.95000959 + 0.37050869 0.20806991 0.69406895 0.29286390 0.99332866 + 0.28483914 0.25145146 0.62341941 0.92030252 0.66728160 + 0.09906494 0.87575460 0.47815160 0.89815952 0.93595080 + 0.54952478 0.83917805 0.26509902 0.11034321 0.40654701 + 0.42915732 0.35365931 0.68812377 0.15913428 0.78814566 + 0.09476081 0.77835931 0.10722542 0.18310435 0.19387186 + 0.53699800 0.15897714 0.67527003 0.52889304 0.36777366 + 0.62352068 0.41439461 0.82022990 0.94445731 0.84903686 + 0.24639273 0.15918367 0.42492794 0.81872642 0.27749724 + 0.35413832 0.26385624 0.82744211 0.41326300 0.77458185 + 0.72190155 0.69865383 0.81227402 0.35321225 0.34243342 + 0.28544200 0.21854080 0.42503892 0.32703064 0.38306297 + 0.97284073 0.20059042 0.98003761 0.88671694 0.10465770 + 0.91747204 0.97163243 0.22750808 0.15830223 0.60955369 + 0.14215401 0.73456345 0.45944940 0.22822249 0.90888451 + 0.19980355 0.76677428 0.07333635 0.89791582 0.35377858 + 0.26962816 0.22004885 0.40903087 0.01376506 0.87732665 + 0.62691640 0.21249738 0.31217908 0.87037313 0.82772374 + 0.64238259 0.55614811 0.24363008 0.89773267 0.44859135 + 0.81452454 0.61730313 0.12962618 0.83334237 0.95547255 + 0.60089665 0.06550662 0.10539371 0.66027624 0.63245301 + 0.10959939 0.54671662 0.49356286 0.07660859 0.90269560 + 0.95274629 0.56699735 0.35064246 0.37742744 0.04508392 + 0.37242982 0.79321385 0.17660627 0.18230715 0.29052073 + 0.98592054 0.75186266 0.43769755 0.78565487 0.97219067 + 0.49054882 0.63155240 0.97110470 0.48556600 0.34397623 + 0.62875246 0.40953202 0.99129015 0.73792727 0.29481194 + 0.94337770 0.46564297 0.17749118 0.05684872 0.77286897 + 0.29538393 0.11965356 0.72487929 0.52226018 0.99248200 + 0.92247006 0.41797788 0.49250134 0.73449967 0.02531508 + 0.60246337 0.28685622 0.84310922 0.39892996 0.90454552 + 0.18608407 0.80752487 0.33601319 0.04956031 0.13777550 + 0.32199797 0.74890696 0.98801123 0.98661910 0.01223987 + 0.82969635 0.81075073 0.71393155 0.23453207 0.65565705 + 0.08584522 0.78976728 0.47621478 0.11498701 0.73891470 + 0.78518540 0.96809591 0.68371914 0.87597910 0.63492176 + 0.16849449 0.32811466 0.06240330 0.87548956 0.77562998 + 0.77521910 0.24096121 0.27176757 0.63748143 0.49747138 + 0.42504502 0.59175241 0.71389176 0.71766512 0.81183245 + 0.73271221 0.71207367 0.07903312 0.27523344 0.63242613 + 0.81037988 0.51204835 0.21652949 0.34487594 0.64982178 + 0.07423142 0.95677888 0.98420169 0.03465428 0.02667473 + 0.96880526 0.99849733 0.55670710 0.29022476 0.53872047 + 0.71697212 0.70443086 0.78949326 0.31678186 0.37629474 + 0.42297064 0.77373097 0.34625273 0.01505586 0.50582792 + 0.83295971 0.41848412 0.42537226 0.41760033 0.57541125 + 0.21745848 0.11158698 0.50941650 0.53135554 0.21527471 + 0.74821915 0.13636652 0.36159918 0.76450229 0.10160194 + 0.85557725 0.74477500 0.57186456 0.01757096 0.12120362 + 0.47981062 0.19954667 0.71065616 0.63382753 0.77693186 + 0.09644095 0.21500764 0.54110751 0.45730081 0.41600724 + 0.97704678 0.76183479 0.84706971 0.57545431 0.79398385 + 0.43236070 0.10486023 0.98015011 0.58870451 0.95548581 + 0.41872718 0.88142712 0.60668643 0.51397541 0.54520355 + 0.43822273 0.68011940 0.07577277 0.41427606 0.80911399 + 0.45853475 0.73611214 0.19619891 0.19601980 0.26765372 + 0.08515930 0.99479057 0.61288752 0.47187699 0.82095365 + 0.07563608 0.90760618 0.28703383 0.93261152 0.40877651 + 0.34686346 0.60599030 0.22872803 0.69315490 0.16152912 + 0.60210518 0.56257876 0.97950688 0.97062066 0.22701157 + 0.98915116 0.16110261 0.10170685 0.74516994 0.62726050 + 0.53451185 0.40864994 0.33494878 0.44800035 0.41035206 + 0.64480751 0.38458997 0.03498312 0.65963215 0.05378627 + 0.85171349 0.78719791 0.59097957 0.50667896 0.82309622 + 0.37561479 0.92534520 0.41748977 0.23908457 0.91793223 + 0.49279792 0.37908370 0.78458072 0.09132853 0.48672190 + 0.78547393 0.59452165 0.39910674 0.03681109 0.87931425 + 0.12683489 0.06609740 0.74801549 0.02948179 0.48328855 + 0.16403523 0.05523786 0.25886666 0.34784685 0.36829981 + 0.21448906 0.34670080 0.93922919 0.70771016 0.14157936 + 0.75664246 0.23055695 0.36395782 0.15852932 0.49061803 + 0.90280575 0.89146298 0.57291005 0.47200603 0.70555729 + 0.09616495 0.58138254 0.95796388 0.83681125 0.83989127 + 0.68717090 0.03545811 0.10550838 0.36520709 0.84290701 + 0.22743276 0.23023855 0.84195926 0.15019733 0.52765254 + 0.22575740 0.82709576 0.53420866 0.76061893 0.06997511 + 0.78439072 0.34422744 0.27637570 0.05982168 0.56720327 + 0.08449067 0.21657369 0.65819609 0.08042821 0.57947911 + 0.90193792 0.61376012 0.38762938 0.17532159 0.21223735 + 0.77829114 0.54806073 0.71144026 0.08830274 0.54140071 + 0.93215628 0.62952729 0.44668759 0.37391019 0.48382450 + 0.77750768 0.40849647 0.40962737 0.09269720 0.46102026 + 0.99544979 0.82007095 0.12585546 0.53119821 0.35953001 + 0.72017528 0.55834068 0.30731217 0.03799961 0.24166948 + 0.27426600 0.93938444 0.04862081 0.08575513 0.65886492 + 0.23214332 0.61649057 0.27463977 0.35788827 0.67061997 + 0.16838056 0.46076133 0.57949296 0.18521946 0.39986254 + 0.55667410 0.62741385 0.33470977 0.13969104 0.96612929 + 0.60200126 0.51194925 0.60476340 0.40285217 0.81221221 + 0.82980614 0.96041971 0.02024973 0.55425470 0.78330912 + 0.10426543 0.50598243 0.47244013 0.71135841 0.28561597 + 0.28428734 0.13422849 0.82909934 0.94771136 0.77380750 + 0.64966697 0.68156268 0.15686758 0.78726350 0.47074787 + 0.13676171 0.46649494 0.74526295 0.58297372 0.04257548 + 0.53166785 0.83735355 0.65946671 0.52102971 0.96228045 + 0.61892296 0.83408336 0.79875681 0.79847692 0.23767569 + 0.52080745 0.12980060 0.58082293 0.72993106 0.75031439 + 0.37787525 0.95150053 0.63673441 0.13407612 0.47907688 + 0.02241942 0.00580158 0.56273902 0.55270283 0.27031811 + 0.55113352 0.74393329 0.25036441 0.87436336 0.72877652 + 0.09975358 0.35707591 0.38691457 0.35547165 0.86641027 + 0.08720133 0.95462835 0.59243817 0.82981586 0.57820411 + 0.75421519 0.86004706 0.10092307 0.96192412 0.86758683 + 0.48424170 0.58019934 0.18594024 0.95826386 0.79962317 + 0.29365413 0.39231296 0.99478547 0.37645944 0.73590734 + 0.78106737 0.25026285 0.58136314 0.29582424 0.26010628 + 0.32792971 0.77947652 0.22482861 0.32191216 0.96171689 + 0.29189752 0.46043686 0.01609668 0.38995725 0.78998963 + 0.05191845 0.53934737 0.33033700 0.99553013 0.48009549 + 0.69017594 0.48347750 0.83452066 0.37144372 0.22106301 + 0.21272114 0.21465963 0.38361677 0.35571283 0.23782329 + 0.70920458 0.84855153 0.96766817 0.52780062 0.24898344 + 0.53680650 0.94866557 0.27426312 0.41025891 0.75195236 + 0.37319953 0.13265037 0.75552148 0.77422476 0.45217406 + 0.89281839 0.16441573 0.59158900 0.44515992 0.57800798 + 0.52507888 0.89901462 0.67382573 0.62141278 0.35502334 + 0.69902911 0.52160210 0.94460522 0.64688742 0.18020336 + 0.21323733 0.10922473 0.45400380 0.49611159 0.40897777 + 0.91073520 0.16206647 0.82064685 0.12805003 0.00677209 + 0.02690101 0.37473387 0.23918362 0.89826974 0.93683919 + 0.30459118 0.82422684 0.51958019 0.45319576 0.48326137 + 0.33931735 0.19060863 0.83671416 0.18062550 0.15152380 + 0.83392969 0.53451730 0.45227244 0.18200635 0.35074171 + 0.14721009 0.01234433 0.23402047 0.50969637 0.43835057 + 0.30803854 0.81485260 0.70089527 0.51323282 0.09933780 + 0.81584602 0.70209563 0.83754800 0.18604181 0.74443049 + 0.69952227 0.28162632 0.60336988 0.61360736 0.73536740 + 0.73262256 0.17803776 0.98749791 0.24658435 0.42156640 + 0.06706407 0.86683221 0.49157136 0.73421374 0.95183767 + 0.41609720 0.35573315 0.87706276 0.27042618 0.80891908 + 0.90709595 0.56944866 0.11342849 0.38817388 0.08734506 + 0.48711323 0.64744128 0.13242656 0.37704136 0.18347125 + 0.34446569 0.93265239 0.75146321 0.54130111 0.84259839 + 0.42697368 0.90878778 0.06990338 0.26204273 0.69820348 + 0.16314909 0.52482844 0.56669207 0.00205581 0.76084093 + 0.15139159 0.91650223 0.59733904 0.06344203 0.12651696 + 0.17332139 0.08037374 0.97258086 0.71010758 0.55713135 + 0.39390629 0.60781246 0.82037450 0.57628388 0.84227964 + 0.92190597 0.08201860 0.27363549 0.99595133 0.36031236 + 0.33906769 0.31098161 0.76694195 0.64215941 0.38210306 + 0.03634237 0.62090720 0.32480459 0.25930318 0.81847147 + 0.42768077 0.51037616 0.06201727 0.38107122 0.85925856 + 0.35860762 0.11109408 0.20408301 0.08434977 0.42192494 + 0.12667915 0.25988365 0.56858761 0.86156496 0.08057195 + 0.63636150 0.07719713 0.09340255 0.13530602 0.72976282 + 0.21915530 0.91162531 0.13979565 0.59931342 0.29344045 + 0.60893790 0.34450224 0.73122236 0.49485593 0.23637397 + 0.67276368 0.63357764 0.24965804 0.14991737 0.11990341 + 0.91523170 0.55878239 0.55687301 0.55497131 0.92868366 + 0.92571090 0.75810502 0.39642955 0.80439758 0.89310223 + 0.61357431 0.54288255 0.73397550 0.61200634 0.35621396 + 0.39733974 0.87508865 0.92077265 0.18597384 0.22781399 + 0.69296476 0.11699087 0.81667128 0.17756410 0.50177323 + 0.55725176 0.29474693 0.68885238 0.56724856 0.18193156 + 0.92202167 0.72082041 0.78554673 0.14995708 0.37851940 + 0.79124547 0.11009521 0.37374537 0.55743712 0.19902994 + 0.31925115 0.95653873 0.87236821 0.81118709 0.02734307 + 0.89672836 0.88185294 0.80163915 0.67374510 0.54913278 + 0.40404879 0.75742801 0.08266467 0.47663209 0.29823377 + 0.86437958 0.65206043 0.76529938 0.72690047 0.55839021 + 0.34721160 0.68622435 0.87809403 0.05706977 0.99828704 + 0.97659049 0.74289680 0.38477595 0.57807463 0.06245739 + 0.23490635 0.71099431 0.63164942 0.25840044 0.16877037 + 0.78988183 0.94046090 0.74967434 0.30048356 0.76029740 + 0.80416821 0.14151867 0.02067892 0.62880774 0.35465381 + 0.52690525 0.69149288 0.99630295 0.29682619 0.93566145 + 0.50288078 0.31484193 0.53763639 0.18529083 0.51339574 + 0.88405386 0.80537067 0.72994703 0.94000045 0.77217985 + 0.03831243 0.52870435 0.36282045 0.11831306 0.59164956 + 0.75609707 0.57445781 0.22185784 0.40058883 0.80070608 + 0.44476583 0.06822213 0.71933909 0.46772793 0.30063440 + 0.76307906 0.81183306 0.66501252 0.05436179 0.18562285 + 0.73829083 0.36511559 0.07868991 0.31888344 0.70126869 + 0.43172350 0.16028129 0.71786948 0.28515828 0.60262106 + 0.85390326 0.29303876 0.13427924 0.40479631 0.81024934 + 0.10635447 0.06198079 0.13573813 0.41854197 0.49701497 + 0.33085849 0.81692291 0.51925964 0.47446405 0.48751283 + 0.10944293 0.63751018 0.19519957 0.18956636 0.06969015 + 0.96440193 0.38341765 0.86754434 0.39223647 0.89786427 + 0.35055280 0.62749961 0.29452122 0.39449784 0.64567830 + 0.95716830 0.24822309 0.78200437 0.92546044 0.67464886 + 0.18308746 0.15496587 0.02935411 0.62736159 0.11523955 + 0.31590528 0.13107864 0.89786553 0.70102294 0.03292914 + 0.25485590 0.09847044 0.82861691 0.62125866 0.08917183 + 0.57638293 0.36845380 0.79192617 0.53989733 0.02180460 + 0.82503407 0.14071852 0.19516575 0.24254998 0.04587026 + 0.98713246 0.82920155 0.58719954 0.13497059 0.04328459 + 0.14178757 0.95583809 0.20694291 0.35212760 0.36074305 + 0.83163422 0.35739792 0.09908488 0.24566046 0.22157152 diff --git a/fpmath/demo/random/randfile.pas b/fpmath/demo/random/randfile.pas new file mode 100755 index 0000000..b103c5c --- /dev/null +++ b/fpmath/demo/random/randfile.pas @@ -0,0 +1,42 @@ +{ ****************************************************************** + This program generates a binary file of random numbers, + to be used with Marsaglia's DIEHARD battery of tests + (http://stat.fsu.edu/pub/diehard/) + ****************************************************************** } + +program randfile; + +uses + tpmath; + +const + N = 3000000; { Generate N numbers } + +var + I, R : LongInt; + F : file of LongInt; + +begin + { Select a generator } + + SetRNG(RNG_MWC); { or SetRNG(RNG_MT) or SetRNG(RNG_UVAG) } + + { Initialize the selected generator with the built-in generator } + + Randomize; + + InitGen(Trunc(Random * 2147483647)); + + { Create file } + + Assign(F, 'random.dat'); + Rewrite(F); + + for I := 1 to N do + begin + R := IRanGen; + Write(F, R); + end; + + Close(F); +end. diff --git a/fpmath/demo/random/ranmul.pas b/fpmath/demo/random/ranmul.pas new file mode 100755 index 0000000..73358ed --- /dev/null +++ b/fpmath/demo/random/ranmul.pas @@ -0,0 +1,106 @@ +{ ****************************************************************** + This program simulates a multinormal distribution. The mean vector + and the variance-covariance matrix are stored in a data file with + the following structure: + + Line 1 : Name of distribution. + Line 2 : Size of distribution (N), e.g. 2 for binormal + Line 3 to (N + 2) : Means and standard deviations. + Next lines : Correlation coefficients, in + lower triangular matrix form. + + The file RANMUL.DAT is an example data file. + + The results are stored in an output file + (one random vector by line) + ****************************************************************** } + +program ranmul; + +uses + tpmath; + +const + NSIM = 100; { Number of simulations } + +var + Name : String; { Name of distribution } + N : Integer; { Size of distribution } + M : PVector; { Mean vector } + V : PMatrix; { Variance-covariance matrix } + L : PMatrix; { Cholesky factor of V } + X : PVector; { Random vector } + F : Text; { Output file } + I, J : Integer; { Loop variables } + + procedure ReadParam(FileName : String; var Name : String; var N : Integer; + var M : PVector; var V : PMatrix); + var + F : Text; { Data file } + I, J : Integer; { Loop variables } + S : PVector; { Standard deviations } + R : Float; { Correlation coefficient } + begin + Assign(F, FileName); + Reset(F); + + Readln(F, Name); + Readln(F, N); + + DimVector(M, N); + DimVector(S, N); + DimMatrix(V, N, N); + + { Read means and standard deviations. Compute variances } + for I := 1 to N do + begin + Read(F, M^[I], S^[I]); + V^[I]^[I] := Sqr(S^[I]); + end; + + { Read correlation coefficients and compute covariances } + for I := 2 to N do + for J := 1 to Pred(I) do + begin + Read(F, R); + V^[I]^[J] := R * S^[I] * S^[J]; + V^[J]^[I] := V^[I]^[J]; + end; + + Close(F); + DelVector(S, N); + end; + +begin + ReadParam('ranmul.dat', Name, N, M, V); + + DimVector(X, N); + DimMatrix(L, N, N); + + { Perform Cholesky decomposition of variance-covariance matrix } + + Cholesky(V, L, 1, N); + if MathErr = MatNotPD then + begin + WriteLn('Variance-covariance matrix is not positive definite.'); + Exit; + end; + + SetRNG(RNG_MT); + + Assign(F, 'ranmul.out'); + Rewrite(F); + + for I := 1 to NSIM do + begin + { Pick random vector } + RanMult(M, L, 1, N, X); + + { Output result to file } + for J := 1 to N do + Write(F, X^[J]:12:6); + Writeln(F); + end; + Close(F); +end. + diff --git a/fpmath/demo/random/ranmull.pas b/fpmath/demo/random/ranmull.pas new file mode 100755 index 0000000..b31f9b9 --- /dev/null +++ b/fpmath/demo/random/ranmull.pas @@ -0,0 +1,123 @@ +{ ****************************************************************** + This program simulates a multi-lognormal distribution. The mean + vector and variance-covariance matrix are stored in a data file + with the following structure: + + Line 1 : Name of distribution. + Line 2 : Size of distribution (N), e.g. 2 for bi-lognormal + Line 3 to (N + 2) : Means and standard deviations. + Next lines : Correlation coefficients, in + lower triangular matrix form. + + The file RANMULL.DAT is an example data file. + + The results are stored in an output file + (one random vector by line) + ****************************************************************** } + +program ranmull; + +uses + tpmath; + +const + NSIM = 400; { Number of simulations } + +var + Name : String; { Name of distribution } + N : Integer; { Dimension of distribution } + M : PVector; { Mean vector of original lognormal distribution } + V : PMatrix; { Variance-covariance matrix of original lognormal dist. } + M0 : PVector; { Mean vector of auxiliary normal dist. } + V0 : PMatrix; { Variance-covariance matrix of auxiliary normal dist. } + L : PMatrix; { Cholesky factor of V0 } + Z : PVector; { Random vector from the auxiliary normal dist. } + X : PVector; { Random vector from the original lognormal dist. } + F : Text; { Output file } + I, J : Integer; { Loop variables } + + procedure ReadParam(FileName : String; var Name : String; var N : Integer; + var M : PVector; var V : PMatrix); + var + F : Text; { Data file } + I, J : Integer; { Loop variables } + S : PVector; { Standard deviations } + R : Float; { Correlation coefficient } + begin + Assign(F, FileName); + Reset(F); + + Readln(F, Name); + Readln(F, N); + + DimVector(M, N); + DimVector(S, N); + DimMatrix(V, N, N); + + { Read means and standard deviations. Compute variances } + for I := 1 to N do + begin + Read(F, M^[I], S^[I]); + V^[I]^[I] := Sqr(S^[I]); + end; + + { Read correlation coefficients and compute covariances } + for I := 2 to N do + for J := 1 to Pred(I) do + begin + Read(F, R); + V^[I]^[J] := R * S^[I] * S^[J]; + V^[J]^[I] := V^[I]^[J]; + end; + + Close(F); + DelVector(S, N); + end; + +begin + { Read parameters of log-normal distribution LN(M, V) } + ReadParam('ranmull.dat', Name, N, M, V); + + DimVector(X, N); + DimVector(Z, N); + DimVector(M0, N); + DimMatrix(V0, N, N); + DimMatrix(L, N, N); + + { Define auxiliary normal distribution N(M0, V0) } + for I := 1 to N do + begin + for J := 1 to N do + V0^[I]^[J] := Ln(V^[I]^[J] / (M^[I] * M^[J]) + 1.0); + M0^[I] := Ln(M^[I]) - 0.5 * V0^[I]^[I]; + end; + + { Perform Cholesky decomposition of variance-covariance matrix } + Cholesky(V0, L, 1, N); + if MathErr = MatNotPD then + begin + WriteLn('Variance-covariance matrix is not positive definite.'); + Exit; + end; + + SetRNG(RNG_MT); + + Assign(F, 'ranmull.out'); + Rewrite(F); + + for I := 1 to NSIM do + begin + { Pick random vector from auxiliary normal distribution } + RanMult(M0, L, 1, N, Z); + + { Convert to lognormal } + for J := 1 to N do + X^[J] := Exp(Z^[J]); + + { Output result to file } + for J := 1 to N do + Write(F, X^[J]:12:6); + Writeln(F); + end; + Close(F); +end. diff --git a/fpmath/demo/random/test_ga.pas b/fpmath/demo/random/test_ga.pas new file mode 100755 index 0000000..4344b6a --- /dev/null +++ b/fpmath/demo/random/test_ga.pas @@ -0,0 +1,255 @@ +{ ****************************************************************** + Optimization by Genetic Algorithm + ****************************************************************** } + +program test_ga; + +uses + tpmath; + +function Func1(X : PVector) : Float; +{ ------------------------------------------------------------------ + Example taken from 'Numerical Recipes' + True minimum is at (-2.0, +/-0.89442719) + ------------------------------------------------------------------ } + var + A, AA, B, BB : Float; + begin + A := Sqr(X^[2]) * (3.0 - X^[1]) - Sqr(X^[1]) * (3.0 + X^[1]); + B := 2.0 + X^[1]; + AA := Sqr(A); + BB := Sqr(B); + Func1 := 10.0 * AA + BB / (1.0 + BB); + end; + +function Func2(X : PVector) : Float; +{ ------------------------------------------------------------------ + Example taken from 'Numerical Recipes' + True minimum is at (0, 0, 0, 0), F = 1.0 + ------------------------------------------------------------------ } + const + Nvar = 4; + Rad = 0.3; + Aug = 2.0; + Wid : array[1..Nvar] of Float = (1.0, 3.0, 10.0, 30.0); + var + J : Integer; + Q, R, Rad2, Sumd, Sumr : Float; + begin + Sumd := 0.0; + Sumr := 0.0; + Rad2 := Sqr(Rad); + for J := 1 to Nvar do + begin + Q := X^[J] * Wid[J]; + if Q >= 0 then R := Int(Q + 0.5) else R := Int(Q - 0.5); + Sumr := Sumr + Sqr(Q); + Sumd := Sumd + Sqr(Q - R); + end; + if Sumd > Rad2 then + Func2 := 1.0 + Sumr * (1.0 + Aug) + else + Func2 := 1.0 + Sumr * (1.0 + Aug * Sumd / Rad2); + end; + +function Func3(X : PVector) : Float; +{ ------------------------------------------------------------------ + Rosenbrock function. + + True minimum is at (1, 1), F = 0 + + Ref: H. Rosenbrock, Comput. J., 1960, 3, 175 + ------------------------------------------------------------------ } + begin + Func3 := 100.0 * Sqr(X^[2] - Sqr(X^[1])) + Sqr(1.0 - X^[1]); + end; + +function Func4(X : PVector) : Float; +{ ------------------------------------------------------------------ + Powell function. + + True minimum is at (0, 0, 0, 0), F = 0 + + Ref: M.J.D. Powell, Comput. J., 1962, 5, 147 + ------------------------------------------------------------------ } + begin + Func4 := Sqr(X^[1] + 10.0 * X^[2]) + 5.0 * Sqr(X^[3] - X^[4]) + + Sqr(Sqr(X^[2] - 2.0 * X^[3])) + 10.0 * Sqr(Sqr(X^[1] - X^[4])); + end; + +function Func5(X : PVector) : Float; +{ ------------------------------------------------------------------ + Another Powell function. + + Multiple minima at x1 = x2 = x3 = +/- Sqrt(4*n+1), n integer, F = -3 + + Ref: M.J.D. Powell, Comput. J., 1964, 7, 155 + + NB: The original reference maximizes F. Here we shall minimize -F. + ------------------------------------------------------------------ } + begin + Func5 := - 1.0 / (1.0 + Sqr(X^[1] - X^[2])) - Sin(PiDiv2 * X^[2] * X^[3]) + - Expo(- Sqr((X^[1] + X^[3]) / X^[2] - 2.0)); + end; + +function Func6(X : PVector) : Float; +{ ------------------------------------------------------------------ + Fletcher & Powell function. + + True minimum is at (1, 0, 0), F = 0 + + Ref: R. Fletcher & M.J.D. Powell, Comput. J., 1964, 7, 155 + ------------------------------------------------------------------ } + var + R, Theta : Float; + begin + R := Pythag(X^[1], X^[2]); + Theta := ArcTan2(X^[2], X^[1]) / TwoPi; + Func6 := 100.0 * (Sqr(X^[3] - 10.0 * Theta) + Sqr(R - 1.0)) + Sqr(X^[3]); + end; + +function Func7(X : PVector) : Float; +{ ------------------------------------------------------------------ + Colville function (Extension of Rosenbrock function) + + True minimum is at (1, 1, 1, 1), F = 0 + + Ref: R. J. Van Iwaarden, PhD Thesis, U. Denver, 1996 + ------------------------------------------------------------------ } + begin + Func7 := 100.0 * Sqr(X^[2] - Sqr(X^[1])) + Sqr(1.0 - X^[1]) + + 90.0 * Sqr(X^[4] - Sqr(X^[3])) + Sqr(1.0 - X^[3]) + + 10.1 * ((Sqr(X^[2] - 1.0) + Sqr(X^[4] - 1.0))) + + 19.8 * (X^[2] - 1.0) * (X^[4] - 1.0); + end; + +function Func8(X : PVector) : Float; +{ ------------------------------------------------------------------ + Griewank function. + + True minimum is at (0, 0), F = 0 + + Ref: R. J. Van Iwaarden, PhD Thesis, U. Denver, 1996 + ------------------------------------------------------------------ } + begin + Func8 := (Sqr(X^[1]) + Sqr(X^[2])) / 200.0 + - Cos(X^[1]) * Cos(X^[2] / Sqrt2) + 1.0; + end; + +function Func9(X : PVector) : Float; +{ ------------------------------------------------------------------ + Chichinadze function. + + True minimum is at (5.90133, 0.5), F = -43.3159 + + Ref: R. J. Van Iwaarden, PhD Thesis, U. Denver, 1996 + ------------------------------------------------------------------ } + const + FivePi = 15.707963267948966193; { 5 * Pi } + InvSqrt5 = 0.44721359549995793928; { 1 / Sqrt(5) } + begin + Func9 := X^[1] * (X^[1] - 12.0) + 11.0 + + 10.0 * Cos(PIDIV2 * X^[1]) + 8.0 * Sin(FivePi * X^[1]) + - InvSqrt5 * Expo(- 0.5 * Sqr(X^[2] - 0.5)); + end; + +function Func10(X : PVector) : Float; +{ ------------------------------------------------------------------ + Rastrigin function. + + True minimum is at (0, 0), F = -2 + + Ref: R. J. Van Iwaarden, PhD Thesis, U. Denver, 1996 + ------------------------------------------------------------------ } + begin + Func10 := Sqr(X^[1]) + Sqr(X^[2]) - Cos(12.0 * X^[1]) - Cos(18.0 * X^[2]); + end; + +procedure Pause; + begin + WriteLn; + Write('Press <Enter> to continue'); + ReadLn; + WriteLn; + end; + +const + NFunc = 10; { Number of functions } + MaxNvar = 4; { Maximum number of variables } + +const + FuncName : array[1..NFunc] of String[70] = + ('Numerical Recipes Example 1: Minimum at (-2.0, +/-0.89442719), F = 0 ', + 'Numerical Recipes Example 2: Minimum at (0, 0, 0, 0), F = 1 ', + 'Rosenbrock function: Minimum at (1, 1), F = 0 ', + 'Powell function: Minimum at (0, 0, 0, 0), F = 0 ', + 'Another Powell function: Minimum at x1=x2=x3= +/- Sqrt(4*n+1), F = -3', + 'Fletcher & Powell function: Minimum at (1, 0, 0), F = 0 ', + 'Colville function: Minimum at (1, 1, 1, 1), F = 0 ', + 'Griewank function: Minimum at (0, 0), F = 0 ', + 'Chichinadze function: Minimum at (5.90133, 0.5), F = -43.3159 ', + 'Rastrigin function: Minimum at (0, 0), F = -2 '); + +const + Nvar : array[1..NFunc] of Integer = + (2, 4, 2, 4, 3, 3, 4, 2, 2, 2); { Number of variables } + +var + Func : array[1..NFunc] of TFuncNVar; { Functions } + X, Xmin, Xmax : PVector; { Variables and limit values } + F_min : Float; { Function value at minimum } + I, J : Integer; { Loop variables } + +begin + WriteLn; + + { Initialize function array } + Func[ 1] := {$IFDEF FPC}@{$ENDIF}Func1; + Func[ 2] := {$IFDEF FPC}@{$ENDIF}Func2; + Func[ 3] := {$IFDEF FPC}@{$ENDIF}Func3; + Func[ 4] := {$IFDEF FPC}@{$ENDIF}Func4; + Func[ 5] := {$IFDEF FPC}@{$ENDIF}Func5; + Func[ 6] := {$IFDEF FPC}@{$ENDIF}Func6; + Func[ 7] := {$IFDEF FPC}@{$ENDIF}Func7; + Func[ 8] := {$IFDEF FPC}@{$ENDIF}Func8; + Func[ 9] := {$IFDEF FPC}@{$ENDIF}Func9; + Func[10] := {$IFDEF FPC}@{$ENDIF}Func10; + + { Allocate arrays } + DimVector(X, MaxNvar); + DimVector(Xmin, MaxNvar); + DimVector(Xmax, MaxNvar); + + { Select random number generator } + SetRNG(RNG_MT); + + for I := 1 to NFunc do + begin + { Initialize limits } + for J := 1 to Nvar[I] do + begin + Xmin^[J] := - 10.0; + Xmax^[J] := 10.0; + end; + + { Approximate global minimum with genetic algorithm } + GA_CreateLogFile('genalg.txt'); + GenAlg(Func[I], X, Xmin, Xmax, 1, Nvar[I], F_min); + + { Display results } + Writeln(FuncName[I]); + Writeln; + for J := 1 to Nvar[I] do + Writeln('X(', J, ') = ', X^[J]:12:6); + Writeln; + Writeln('F = ', F_min:10); + Writeln; + Pause; + end; + + { Deallocate arrays } + DelVector(X, MaxNvar); + DelVector(Xmin, MaxNvar); + DelVector(Xmax, MaxNvar); +end. + diff --git a/fpmath/demo/random/test_sa.pas b/fpmath/demo/random/test_sa.pas new file mode 100755 index 0000000..b97ade6 --- /dev/null +++ b/fpmath/demo/random/test_sa.pas @@ -0,0 +1,256 @@ +{ ****************************************************************** + Optimization by Simulated Annealing + ****************************************************************** } + +program test_sa; + +uses + tpmath; + +function Func1(X : PVector) : Float; +{ ------------------------------------------------------------------ + Example taken from 'Numerical Recipes' + True minimum is at (-2.0, +/-0.89442719) + ------------------------------------------------------------------ } + var + A, AA, B, BB : Float; + begin + A := Sqr(X^[2]) * (3.0 - X^[1]) - Sqr(X^[1]) * (3.0 + X^[1]); + B := 2.0 + X^[1]; + AA := Sqr(A); + BB := Sqr(B); + Func1 := 10.0 * AA + BB / (1.0 + BB); + end; + +function Func2(X : PVector) : Float; +{ ------------------------------------------------------------------ + Example taken from 'Numerical Recipes' + True minimum is at (0, 0, 0, 0), F = 1.0 + ------------------------------------------------------------------ } + const + Nvar = 4; + Rad = 0.3; + Aug = 2.0; + Wid : array[1..Nvar] of Float = (1.0, 3.0, 10.0, 30.0); + var + J : Integer; + Q, R, Rad2, Sumd, Sumr : Float; + begin + Sumd := 0.0; + Sumr := 0.0; + Rad2 := Sqr(Rad); + for J := 1 to Nvar do + begin + Q := X^[J] * Wid[J]; + if Q >= 0 then R := Int(Q + 0.5) else R := Int(Q - 0.5); + Sumr := Sumr + Sqr(Q); + Sumd := Sumd + Sqr(Q - R); + end; + if Sumd > Rad2 then + Func2 := 1.0 + Sumr * (1.0 + Aug) + else + Func2 := 1.0 + Sumr * (1.0 + Aug * Sumd / Rad2); + end; + +function Func3(X : PVector) : Float; +{ ------------------------------------------------------------------ + Rosenbrock function. + + True minimum is at (1, 1), F = 0 + + Ref: H. Rosenbrock, Comput. J., 1960, 3, 175 + ------------------------------------------------------------------ } + begin + Func3 := 100.0 * Sqr(X^[2] - Sqr(X^[1])) + Sqr(1.0 - X^[1]); + end; + +function Func4(X : PVector) : Float; +{ ------------------------------------------------------------------ + Powell function. + + True minimum is at (0, 0, 0, 0), F = 0 + + Ref: M.J.D. Powell, Comput. J., 1962, 5, 147 + ------------------------------------------------------------------ } + begin + Func4 := Sqr(X^[1] + 10.0 * X^[2]) + 5.0 * Sqr(X^[3] - X^[4]) + + Sqr(Sqr(X^[2] - 2.0 * X^[3])) + 10.0 * Sqr(Sqr(X^[1] - X^[4])); + end; + +function Func5(X : PVector) : Float; +{ ------------------------------------------------------------------ + Another Powell function. + + Multiple minima at x1 = x2 = x3 = +/- Sqrt(4*n+1), n integer, F = -3 + + Ref: M.J.D. Powell, Comput. J., 1964, 7, 155 + + NB: The original reference maximizes F. Here we shall minimize -F. + ------------------------------------------------------------------ } + begin + Func5 := - 1.0 / (1.0 + Sqr(X^[1] - X^[2])) - Sin(PiDiv2 * X^[2] * X^[3]) + - Expo(- Sqr((X^[1] + X^[3]) / X^[2] - 2.0)); + end; + +function Func6(X : PVector) : Float; +{ ------------------------------------------------------------------ + Fletcher & Powell function. + + True minimum is at (1, 0, 0), F = 0 + + Ref: R. Fletcher & M.J.D. Powell, Comput. J., 1964, 7, 155 + ------------------------------------------------------------------ } + var + R, Theta : Float; + begin + R := Pythag(X^[1], X^[2]); + Theta := ArcTan2(X^[2], X^[1]) / TwoPi; + Func6 := 100.0 * (Sqr(X^[3] - 10.0 * Theta) + Sqr(R - 1.0)) + Sqr(X^[3]); + end; + +function Func7(X : PVector) : Float; +{ ------------------------------------------------------------------ + Colville function (Extension of Rosenbrock function) + + True minimum is at (1, 1, 1, 1), F = 0 + + Ref: R. J. Van Iwaarden, PhD Thesis, U. Denver, 1996 + ------------------------------------------------------------------ } + begin + Func7 := 100.0 * Sqr(X^[2] - Sqr(X^[1])) + Sqr(1.0 - X^[1]) + + 90.0 * Sqr(X^[4] - Sqr(X^[3])) + Sqr(1.0 - X^[3]) + + 10.1 * ((Sqr(X^[2] - 1.0) + Sqr(X^[4] - 1.0))) + + 19.8 * (X^[2] - 1.0) * (X^[4] - 1.0); + end; + +function Func8(X : PVector) : Float; +{ ------------------------------------------------------------------ + Griewank function. + + True minimum is at (0, 0), F = 0 + + Ref: R. J. Van Iwaarden, PhD Thesis, U. Denver, 1996 + ------------------------------------------------------------------ } + begin + Func8 := (Sqr(X^[1]) + Sqr(X^[2])) / 200.0 + - Cos(X^[1]) * Cos(X^[2] / Sqrt2) + 1.0; + end; + +function Func9(X : PVector) : Float; +{ ------------------------------------------------------------------ + Chichinadze function. + + True minimum is at (5.90133, 0.5), F = -43.3159 + + Ref: R. J. Van Iwaarden, PhD Thesis, U. Denver, 1996 + ------------------------------------------------------------------ } + const + FivePi = 15.707963267948966193; { 5 * Pi } + InvSqrt5 = 0.44721359549995793928; { 1 / Sqrt(5) } + begin + Func9 := X^[1] * (X^[1] - 12.0) + 11.0 + + 10.0 * Cos(PIDIV2 * X^[1]) + 8.0 * Sin(FivePi * X^[1]) + - InvSqrt5 * Expo(- 0.5 * Sqr(X^[2] - 0.5)); + end; + +function Func10(X : PVector) : Float; +{ ------------------------------------------------------------------ + Rastrigin function. + + True minimum is at (0, 0), F = -2 + + Ref: R. J. Van Iwaarden, PhD Thesis, U. Denver, 1996 + ------------------------------------------------------------------ } + begin + Func10 := Sqr(X^[1]) + Sqr(X^[2]) - Cos(12.0 * X^[1]) - Cos(18.0 * X^[2]); + end; + +procedure Pause; + begin + WriteLn; + Write('Press <Enter> to continue'); + ReadLn; + WriteLn; + end; + +const + NFunc = 10; { Number of functions } + MaxNvar = 4; { Maximum number of variables } + +const + FuncName : array[1..NFunc] of String[70] = + ('Numerical Recipes Example 1: Minimum at (-2.0, +/-0.89442719), F = 0 ', + 'Numerical Recipes Example 2: Minimum at (0, 0, 0, 0), F = 1 ', + 'Rosenbrock function: Minimum at (1, 1), F = 0 ', + 'Powell function: Minimum at (0, 0, 0, 0), F = 0 ', + 'Another Powell function: Minimum at x1=x2=x3= +/- Sqrt(4*n+1), F = -3', + 'Fletcher & Powell function: Minimum at (1, 0, 0), F = 0 ', + 'Colville function: Minimum at (1, 1, 1, 1), F = 0 ', + 'Griewank function: Minimum at (0, 0), F = 0 ', + 'Chichinadze function: Minimum at (5.90133, 0.5), F = -43.3159 ', + 'Rastrigin function: Minimum at (0, 0), F = -2 '); + +const + Nvar : array[1..NFunc] of Integer = + (2, 4, 2, 4, 3, 3, 4, 2, 2, 2); { Number of variables } + +var + Func : array[1..NFunc] of TFuncNVar; { Functions } + X, Xmin, Xmax : PVector; { Variables and limit values } + F_min : Float; { Function value at minimum } + I, J : Integer; { Loop variables } + +begin + WriteLn; + + { Initialize function array } + Func[ 1] := {$IFDEF FPC}@{$ENDIF}Func1; + Func[ 2] := {$IFDEF FPC}@{$ENDIF}Func2; + Func[ 3] := {$IFDEF FPC}@{$ENDIF}Func3; + Func[ 4] := {$IFDEF FPC}@{$ENDIF}Func4; + Func[ 5] := {$IFDEF FPC}@{$ENDIF}Func5; + Func[ 6] := {$IFDEF FPC}@{$ENDIF}Func6; + Func[ 7] := {$IFDEF FPC}@{$ENDIF}Func7; + Func[ 8] := {$IFDEF FPC}@{$ENDIF}Func8; + Func[ 9] := {$IFDEF FPC}@{$ENDIF}Func9; + Func[10] := {$IFDEF FPC}@{$ENDIF}Func10; + + { Allocate arrays } + DimVector(X, MaxNvar); + DimVector(Xmin, MaxNvar); + DimVector(Xmax, MaxNvar); + + { Select random number generator } + SetRNG(RNG_MT); + + for I := 1 to NFunc do + begin + { Initialize limits and pick starting point } + for J := 1 to Nvar[I] do + begin + Xmin^[J] := - 10.0; + Xmax^[J] := 10.0; + X^[J] := Xmin^[J] + RanGen3 * (Xmax^[J] - Xmin^[J]); + end; + + { Approximate global minimum with simulated annealing } + SA_CreateLogFile('simann.txt'); + SimAnn(Func[I], X, Xmin, Xmax, 1, Nvar[I], F_min); + + { Display results } + Writeln(FuncName[I]); + Writeln; + for J := 1 to Nvar[I] do + Writeln('X(', J, ') = ', X^[J]:12:6); + Writeln; + Writeln('F = ', F_min:10); + Writeln; + Pause; + end; + + { Deallocate arrays } + DelVector(X, MaxNvar); + DelVector(Xmin, MaxNvar); + DelVector(Xmax, MaxNvar); +end. + diff --git a/fpmath/demo/random/testmcmc.pas b/fpmath/demo/random/testmcmc.pas new file mode 100755 index 0000000..2e93916 --- /dev/null +++ b/fpmath/demo/random/testmcmc.pas @@ -0,0 +1,247 @@ +{ ****************************************************************** + This program simulates a multinormal distribution by Markov Chain + Monte Carlo (MCMC) using the Hastings-Metropolis algorithm. + + Although MCMC is best used when there is no direct way to simulate + the distribution, it is used here for demonstration purposes since + its results can be compared to those of the direct method (program + RANMUL.PAS). + + The pdf P(X) of the multinormal distribution is such that: + + P(X) = C * Exp(- F(X) / T) + + where F(X) = (X - M)' * V^(-1) * (X - M) + + C = 1/sqrt(|V| * (2*Pi)^N) + + T = 2 + + M is the mean vector and V the variance-covariance matrix of + the distribution. N is the dimension of the distribution. + + The constant C is not used in the simulation. + + The mean vector and variance-covariance matrix are stored in a data + file with the following structure: + + Line 1 : Title of study + Line 2 : Number of variables (N), e.g. 2 for binormal + Line 3 to (N + 2) : Means and standard deviations + Next lines : Correlation coefficients, in + lower triangular matrix form + + The file TESTMCMC.DAT is an example data file. + + The results are stored in the output file TESTMCMC.TXT + ****************************************************************** } + +program testmcmc; + +uses + tpmath; + +const + Temp = 2.0; { Temperature } + NCycles = 10; { Number of cycles } + MaxSim = 1000; { Max nb of simulations } + SavedSim = 1000; { Nb of saved simulations } +var + Title : String; { Title of study } + N : Integer; { Number of variables } + M : PVector; { Mean vector of original distribution } + V : PMatrix; { Variance-covariance matrix of original distribution } + V_inv : PMatrix; { Inverse variance-covariance matrix } + Xmat : PMatrix; { Matrix of simulated vectors } + Msim : PVector; { Mean of simulated distribution } + Vsim : PMatrix; { Variance-covariance matrix of simulated distrib. } + X_min : PVector; { Coordinates of the minimum of F(X) + = mode of simulated distribution } + F_min : Float; { Value of F(X) at minimum } + I : Integer; { Loop variable } + + function ReadParam(FileName : String; var Title : String; + var N : Integer; var M : PVector; + var V, V_inv : PMatrix) : Integer; + var + F : Text; { Data file } + I, J : Integer; { Loop variables } + S : PVector; { Standard deviations } + R : Float; { Correlation coefficient } + Det : Float; { Determinant of var-cov. matrix } + begin + Assign(F, FileName); + Reset(F); + + Readln(F, Title); + Readln(F, N); + + DimVector(M, N); + DimVector(S, N); + DimMatrix(V, N, N); + DimMatrix(V_inv, N, N); + + { Read means and standard deviations. Compute variances } + for I := 1 to N do + begin + Read(F, M^[I], S^[I]); + V^[I]^[I] := Sqr(S^[I]); + end; + + { Read correlation coefficients and compute covariances } + for I := 2 to N do + for J := 1 to Pred(I) do + begin + Read(F, R); + V^[I]^[J] := R * S^[I] * S^[J]; + V^[J]^[I] := V^[I]^[J]; + end; + + { Initialize inverse var-cov. matrix } + for I := 1 to N do + for J := 1 to N do + V_inv^[I]^[J] := V^[I]^[J]; + + { Compute the inverse of the variance-covariance matrix } + GaussJordan(V_inv, 1, N, N, Det); + ReadParam := MathErr; + + Close(F); + DelVector(S, N); + end; + + function ObjFunc(X : PVector) : Float; + { Computes the function F(X) } + var + Sum1, Sum2 : Float; + I, J : Integer; + D : PVector; + begin + DimVector(D, N); + + for I := 1 to N do + D^[I] := X^[I] - M^[I]; + + Sum1 := 0.0; + for I := 1 to N do + Sum1 := Sum1 + V_inv^[I]^[I] * Sqr(D^[I]); + + Sum2 := 0.0; + for I := 2 to N do + for J := 1 to Pred(I) do + Sum2 := Sum2 + V_inv^[I]^[J] * D^[I] * D^[J]; + + ObjFunc := Sum1 + 2.0 * Sum2; + + DelVector(D, N); + end; + + procedure WriteResults(Title : String; M : PVector; + V : PMatrix; N : Integer); + var + I, J : Integer; + S : PVector; + R : Float; + begin + WriteLn; + WriteLn(Title); + WriteLn; + + WriteLn(' Mean S.D.'); + WriteLn('--------------------'); + + DimVector(S, N); + for I := 1 to N do + begin + S^[I] := Sqrt(V^[I]^[I]); + Writeln(M^[I]:10:4, S^[I]:10:4); + end; + + WriteLn; + WriteLn('Correlation matrix:'); + WriteLn; + + for I := 2 to N do + begin + for J := 1 to Pred(I) do + begin + R := V^[I]^[J] / (S^[I] * S^[J]); + Write(R:10:4); + end; + WriteLn; + end; + + DelVector(S, N); + end; + + procedure WriteOutputFile(Title : String; Xmat : PMatrix; N : Integer); + var + F : Text; + I, J : Integer; + begin + Assign(F, 'testmcmc.txt'); + Rewrite(F); + + WriteLn(F, Title); + Write(F, ' Iter'); + for I := 1 to N do + Write(F, ' X', I); + WriteLn(F); + + for I := 1 to SavedSim do + begin + Write(F, I:5); + for J := 1 to N do + Write(F, Xmat^[I]^[J]:10:4); + WriteLn(F); + end; + + Close(F); + end; + +begin + if ReadParam('testmcmc.dat', Title, N, M, V, V_inv) = MatSing then + begin + WriteLn('Variance-covariance matrix is singular!'); + Exit; + end; + + DimVector(Msim, N); + DimVector(X_min, N); + DimMatrix(Vsim, N, N); + DimMatrix(Xmat, SavedSim, N); + + { Select random number generator } + SetRNG(RNG_MT); + + { Initialize Metropolis-Hastings parameters } + InitMHParams(NCycles, MaxSim, SavedSim); + + { Initialize the mean vector and the variance-covariance matrix. + For the sake of demonstration we start at a distance from the + true mean and with enhanced standard deviations. } + for I := 1 to N do + begin + Msim^[I] := 3.0 * M^[I]; + Vsim^[I]^[I] := 10.0 * V^[I]^[I]; + end; + + { Perform Metropolis-Hastings simulations } + Write('Running. Please wait...'); + + {$IFDEF FPC} + Hastings(@ObjFunc, Temp, Msim, Vsim, 1, N, Xmat, X_min, F_min); + {$ELSE} + Hastings(ObjFunc, Temp, Msim, Vsim, 1, N, Xmat, X_min, F_min); + {$ENDIF} + + if MathErr = MatOk then + begin + WriteResults('Original distribution', M, V, N); + WriteResults('Simulated distribution', Msim, Vsim, N); + WriteOutputFile(Title, Xmat, N); + end + else + WriteLn('Variance-covariance matrix is not positive definite!'); +end. + diff --git a/fpmath/demo/random/testmt.pas b/fpmath/demo/random/testmt.pas new file mode 100755 index 0000000..be1d10c --- /dev/null +++ b/fpmath/demo/random/testmt.pas @@ -0,0 +1,40 @@ +{ ****************************************************************** + Test of 'Mersenne Twister' random number generator + + This program prints 1000 random numbers, computed with the default + initialization. + + The output of this program should be similar to file mt.txt + ****************************************************************** } + +program testmt; + +uses + tpmath; + +var + I : Word; + R : LongInt; + X : Float; + +begin + SetRNG(RNG_MT); + + Writeln('1000 outputs of IRanGen'); + for I := 1 to 1000 do + begin + R := IRanGen; + Write(R:15); + if i mod 5 = 0 then Writeln; + end; + + Writeln; + + Writeln('1000 outputs of RanGen2'); + for I := 1 to 1000 do + begin + X := RanGen2; + Write(X:15:8); + if i mod 5 = 0 then Writeln; + end; +end. diff --git a/fpmath/demo/random/testmwc.pas b/fpmath/demo/random/testmwc.pas new file mode 100755 index 0000000..26da8ea --- /dev/null +++ b/fpmath/demo/random/testmwc.pas @@ -0,0 +1,41 @@ +{ ****************************************************************** + This program picks 20000 random numbers and displays the next 6, + together with the correct values obtained with the default + initialization, + ****************************************************************** } + +program testmwc; + +uses + tpmath; + +const + Correct : array[1..6] of LongInt = + (921625997, 1094293978, 115775252, 499820504, -1929018715, 2008943384); + +var + I, R : LongInt; + +begin + WriteLn; + Writeln(' Test of Marsaglia random number generator'); + WriteLn('---------------------------------------------'); + WriteLn(' Correct Actual'); + WriteLn('---------------------------------------------'); + + SetRNG(RNG_MWC); + + { Pick 20000 random numbers } + for I := 1 to 20000 do + R := IRanGen; + + { Display 6 more numbers with correct values } + for I := 1 to 6 do + begin + R := IRanGen; + Write(' ', Correct[I]:12, ' ', R:12, ' '); + if Correct[I] = R then WriteLn('OK') else WriteLn('BAD'); + end; + WriteLn('---------------------------------------------'); +end. + diff --git a/fpmath/demo/random/testnorm.pas b/fpmath/demo/random/testnorm.pas new file mode 100755 index 0000000..5cf2b38 --- /dev/null +++ b/fpmath/demo/random/testnorm.pas @@ -0,0 +1,59 @@ +{ ****************************************************************** + Test of Gaussian random number generator. + + This program picks a random sample of size N from a gaussian + distribution with known mean and standard deviation (SD), + estimates mean and SD from the sample, and computes a 95% + confidence interval (CI) for the mean (i.e. an interval which + has a probability of 0.95 to include the true mean). + ****************************************************************** } + +program testnorm; + +uses + tpmath; + +const + Mu = 10.0; { Mean of Gaussian distribution } + Sigma = 2.0; { Standard deviation of Gaussian distribution } + N = 100; { Sample size, must be > 30 } + +var + X : PVector; { Sample values } + M, S : Float; { Sample mean & SD } + Delta : Float; { Half-width of CI } + M1, M2 : Float; { Bounds of CI } + I : Integer; { Loop variable } + +begin + { Select generator } + SetRNG(RNG_MT); + + { Dimension array } + DimVector(X, N); + + { Pick sample values } + for I := 1 to N do + X^[I] := RanGauss(Mu, Sigma); + + { Estimate mean and SD from sample } + M := Mean(X, 1, N); + S := StDev(X, 1, N, M); + + { Compute 95% CI, assuming that the sample mean is normally distributed. + This requires N > 30 } + Delta := 1.96 * S / Sqrt(N); + M1 := M - Delta; + M2 := M + Delta; + + { Output results } + WriteLn; + WriteLn('Population mean = ', Mu:10:4); + WriteLn('Population SD = ', Sigma:10:4); + WriteLn; + WriteLn('Sample size = ', N:10); + WriteLn('Sample mean = ', M:10:4); + WriteLn('Sample SD = ', S:10:4); + WriteLn; + WriteLn('95% CI of mean = [', M1:10:4, ' , ', M2:10:4, ' ]'); +end. diff --git a/fpmath/demo/random/testuvag.pas b/fpmath/demo/random/testuvag.pas new file mode 100755 index 0000000..24b79fc --- /dev/null +++ b/fpmath/demo/random/testuvag.pas @@ -0,0 +1,28 @@ +{ ****************************************************************** + Test of UVAG random number generator + + By Alex Hay (zenjew@hotmail.com) - Adapted to TPMath by Jean Debord + + This program prints 1000 random integers, computed with the default + initialization. The results should be identical to file uvag.txt + ****************************************************************** } + +program testuvag; + +uses + tpmath; + +var + I : Word; + R : LongInt; + +begin + SetRNG(RNG_UVAG); + + for I := 1 to 1000 do + begin + R := IRanGen; + Write(R:15); + if I mod 5 = 0 then Writeln; + end; +end. \ No newline at end of file diff --git a/fpmath/demo/random/uvag.txt b/fpmath/demo/random/uvag.txt new file mode 100755 index 0000000..821e4f1 --- /dev/null +++ b/fpmath/demo/random/uvag.txt @@ -0,0 +1,200 @@ + -288735372 620066422 656890996 -31851389 1960508036 + 142009603 514143789 -2107429 -1800308481 -1699363169 + -473591232 -1142621326 154424346 -1287193680 1349464577 + 239283230 1482739267 -721447336 452726661 1190579380 + 1061062035 -595641077 -304148196 -415579904 -539666927 + 1183284213 1846533827 201571164 991854444 -1675521421 + -529758722 -1230516873 1704416205 198057673 -1440946268 + -735980797 1316647170 -1391191317 -1067744741 -1032529872 + -620835366 -983514451 2018396996 -2034650915 -1728612224 + -2087518792 1047315075 -1661175699 606270917 599792862 + -1155696013 1373801371 1341489397 1213013460 1957654746 + 1324879829 486952443 129185128 -1441796891 -843247627 + -1719945220 1803471696 829708139 222383317 1808509301 + -853315928 -285646612 -912041675 -1400134876 825667450 + -1184359389 -2096678096 227908829 -1875037756 4880470 + -1960619431 -555914813 711233684 -2045466546 1116199672 + -1379723962 -150209393 -1656464527 -122298017 -1854592656 + 398306950 1025572712 -463682770 1884188205 1699211440 + 287432606 824753486 793190871 -1236043946 877298131 + -1209186320 1098626160 -1996769672 733685717 1263724751 + 345824283 -1371811506 334864953 -301385731 2117607145 + 1980024672 -1761004932 -1009340651 -795564227 -839464173 + -460549772 -1091231482 1411746307 -157364707 207814538 + 1469977152 1311856649 -551792972 -988393891 -177744120 + 1970403618 -625101041 -1648045207 -1147942676 -2036954510 + -1570931231 -1812700193 1926460581 -691540555 -1819682029 + 524015611 -2104354266 -1279382817 -966894581 916830708 + -730042271 246591917 2027350344 2103431032 239761354 + -503941472 -1226362160 -194807956 1206365081 -1171396889 + -2030305542 -1912994125 1076603123 -571684124 1683030600 + 1479829785 292315932 151631996 532630254 565759005 + 1445481255 -1370876035 -1631616894 -1073060616 1972891037 + 1026765709 -1766892525 -1276701738 608262742 -532435141 + 105986270 1489654911 -2008345045 -1761975366 1710148380 + 791971501 -74351180 -1201637460 -1719340969 653084543 + -1704791604 -468487310 264509028 -648601297 833978407 + 1445768319 -1553948802 364591000 -1146792420 -2053874503 + 1122008201 800670383 -1171230071 1516221383 656015272 + -1687686577 -2118886633 -153582857 -212011848 1143249825 + 1138401598 -1690770090 -169665677 1660293526 -1941100619 + -525686554 -686193863 -1145263617 -858672548 -1116075358 + -2112839759 -96149114 -116213079 -976128984 1154075891 + -151460575 380997851 -845520140 -548611611 -221798104 + -1670114199 705953218 1451024764 1741369042 1121446700 + 2114494846 -907385263 -725195957 -1501072527 346696914 + -272846653 -1458803631 -203591881 -2051099036 1506460382 + 1220467922 -789423106 -2088642632 163609642 895960252 + 624873685 -1476472110 -2045031283 414287886 922784909 + -1001151947 993443876 -648140640 1863775843 -1430569005 + 296184476 -1785050085 1001575270 1491387579 -313875606 + -317114224 -144416139 -804261194 1721043347 1379987718 + 2011312066 310231304 -1404618654 878719444 969099703 + -6259379 -392535674 -813652784 829700038 47278448 + -326560214 1389219422 479017699 -2096240325 -2107510534 + -468914511 549726930 -1797228833 -354255985 -1679078112 + 1015478129 1513252749 648743528 -507776129 -1373421990 + 1536853107 -2136185919 1073564532 -971787099 -1644464676 + 1001196039 -1139652458 1977383651 -500707270 1977863040 + -1182048097 1050509454 261063644 -646536167 1845375305 + -2075760651 -2134830657 559086437 -1920916880 1108217264 + -1303344417 1313330933 810264880 1617291142 1588450014 + 1638208978 -1678035851 20735793 1922392122 766498476 + -628336586 -1931571809 1070182646 539295203 -77303240 + -1062206291 -815659296 642858463 -1564401841 1693354483 + -119038851 505898400 26893749 1229469233 -992077540 + 73792687 -1629700080 1862688891 1692926058 -496425499 + 1930363654 1739072114 -2112224176 -2081058605 -1261955521 + 1265545702 -674273574 423183479 1290018708 174643922 + 1925848100 650573107 -1896364029 631822359 -505018595 + 741166988 -1012429724 1372237482 556357222 1919740706 + 1195929823 1088624422 -780026592 391212263 767591743 + -2130908724 409183169 755421029 370129504 -1042177494 + 47470940 -512419292 -435389645 -239454897 -747764412 + -1149290964 1377568767 -402338121 -1283680893 1617681905 + 1323062083 1045438658 -833979730 -848837187 -236202105 + -1083952578 -1032843187 844605233 1740319857 -1467633379 + -202767622 297349724 995456928 -483699586 -183814681 + -1178193042 1643961390 -1904319395 1925813970 -623170367 + 1281845654 2090486514 498640814 1528374584 -321189249 + 1712769522 1220770986 768359781 -1737608102 -1059667296 + 396152911 384609001 1515904513 -727336111 -239401145 + 1369007555 1975007171 445177800 398357064 -583597928 + 777848781 1717936091 -570496436 -70846443 947955548 + 46347263 991488182 43807586 1525521920 2112423297 + 1684033995 691940980 75403362 559249853 -1818890395 + 1937148483 -1698923369 -1628293907 -521130158 -1669694349 + 2072066787 -689735173 -462217765 -436500564 1448674617 + 708815457 276974596 128565484 -517541441 1134632930 + 572564855 563218040 845966542 -1411393523 2068644189 + -929380457 1299365428 -618075493 1593687175 -362638885 + -2103566098 1205724624 -2112871834 624359981 1662649652 + -2124090629 68618021 -140387383 562056607 700832514 + -483420660 -1638545074 -184416649 -953831404 -1418830961 + 1966653283 423685103 -121850745 1289463846 945638183 + -176827274 -328112515 -2061502918 -36510912 -406073931 + -699003804 508097093 -2013907353 -1120890986 -1152849456 + -64499667 -1123377695 -894830483 -1652523801 -1247783846 + 938173020 -782666036 1956439682 464462946 463926335 + 1108215496 -1700738890 -2060973749 -1175133378 1612989163 + -664249015 -388410720 -1899286742 -451286784 -1246398986 + 21744235 -1190315140 -1401706999 -193707251 -1680503662 + -786879084 2140460492 296982879 1296409748 269426123 + -2108789129 -1846477855 1793294379 1984697040 116852423 + 463959881 -1629418155 -2050836562 317441466 336252298 + -662299334 37148973 -1412498465 1006940595 -1592299550 + 898976211 2073790717 671787146 284696264 -1527011806 + -269932338 -1873441998 -400310276 1589231802 -534386007 + 348198448 -740573593 690202301 2092534986 1478153732 + -259964356 -1921932283 1378541637 336429563 446648007 + -460986266 -474704507 1068350388 1379007427 1517627109 + 817030745 -214787708 -241539116 1979044039 714802948 + -1924623800 -884139943 181932989 -165166908 -501192599 + 204023654 1617367879 296229267 -1366015201 834005536 + 218737559 -1746057008 -667074756 -1229346604 -1297248966 + 297245887 118256395 1750304735 1142050580 -818318606 + -2062777110 -904382335 -914412840 2130115925 1123659329 + 2098909546 1239591451 -97415983 111215982 -1672125691 + 1745767432 1206851028 1603053288 -1754148309 476467421 + 2089714779 -2081313555 -1111278941 -178113523 -1298327028 + 579123468 -1272559359 -1943341691 -992342863 1433207397 + 1951611946 4458856 -112553341 -1494041532 1280132921 + -1523731343 860413728 -1881316020 656274218 1572926550 + -1043416953 -315246948 1379508738 487653694 -1996179289 + -1054827185 1977121579 -2120809547 -1864051860 157853526 + -423886524 673009031 2071856129 517213242 743998567 + -1363590650 1557755491 -412461491 -1287958028 -306707148 + -686320291 -1718255644 -1136252181 1170908620 354010745 + 445994535 1913695283 -2061259919 -342427826 -1224463269 + -957823506 196874980 -1713839257 -1405331539 1803021848 + 724420502 -596818689 1627671298 1311688183 -605517998 + -727608897 -56370696 -1345120059 808964889 -742685804 + -1945068769 -1020718703 -1248792458 915346937 -768546174 + -1654130764 1006418503 -838445526 814930115 1461562745 + 159529326 1841010426 615615431 -483528979 1444495304 + -308900524 -1939040239 508870608 -1185103901 -1914425497 + 1047937085 1716261027 1489601276 -405758984 1712111738 + 797820894 -1688459927 221302447 -168451944 -61008423 + 847205349 2113627624 -294371799 836644534 -879017244 + -290318383 -1288399303 -895317506 398687353 421658866 + 392954924 1432542478 597556241 -1563847741 1138567872 + -717532251 1583956231 1704081383 -520554691 -2131789457 + -315630686 -1821760216 161487479 -1663882590 -81428261 + -1712744840 1996414338 1768016572 -1191594058 -2111928371 + 1398652166 1761627480 -1086656569 -2106938168 -231248450 + -1250023093 -1164689520 946813613 323879141 1827625687 + 1441839283 -2000678279 2021564504 -1802749610 1558803466 + 405093965 365824595 -531369512 236499435 -547282729 + 1059519473 -1408059403 -1534062784 -534947961 1152631423 + -1546553973 1564834664 -794739748 -1862204009 -1376307474 + 1899329506 1805148048 -369475545 -51683124 741054608 + -1944037904 -70085625 1429253285 -1265108978 2096049050 + 938874601 504128047 -1361434271 -878176241 -1983144695 + 12694607 1085842058 1761023085 1891906455 -700070075 + -1494321608 1077887658 -1154291222 -513930985 436710108 + -1172936535 616964638 -1845809059 -1580114985 1250822018 + 1526165025 -233611615 -1063642878 206585756 -1707856509 + -1045388699 -1792246825 -161500439 -1162996637 -239120663 + 815750133 649143338 2016789549 53857292 -71607210 + -1246901786 -919847814 261169813 -1128909900 647067783 + -1924588499 -297345559 -1808702977 1146307685 -1870242467 + -1786068073 -110172858 -121913045 431354937 427779812 + -1935661126 842575577 472009169 -1134863367 229275880 + -1613540432 1038151936 1222805411 -1466303263 -2027126958 + -2093281523 -1032176149 713884405 -2024726944 1304795426 + 2048767157 546538749 1467109427 563081653 -757380599 + -1268261014 1816271768 -814583207 -173646936 -506534256 + 1811873879 -1715861511 821968907 690960778 1647615630 + -1380428702 -1896005516 1000080132 -1231342034 -1676355183 + -995332844 1859288459 356775040 -1946007768 -34556198 + 1804883435 1914771257 -255383375 -677373545 -345092455 + 1739232610 -1763693808 1912105039 -2077629754 1855925921 + -406044369 2083996910 -1688761543 1961888473 -1281633016 + -57082173 -1600609424 1041421096 1113495327 1058943810 + -127131775 2010447518 319830015 -1817119139 -1622986330 + 1099837547 1139995390 1310788984 280812824 -540253497 + -1735808016 994144858 -1995322262 -1136023221 -304140801 + 1950219379 1622879261 1743530114 -868377628 1660967106 + -931336758 2066444568 -1071548773 -354376061 1130687511 + 916779115 826389072 533499496 -397031301 -1821872343 + -1282265802 -501744021 462371713 1017215681 -293509836 + 369635180 -505064016 1782325845 -82648393 1476348876 + -1776648624 -1463155351 537414725 472446392 -920081454 + 160329326 -217624425 460567517 -2106903657 893040801 + -261574330 -2021691090 1011659446 -2051336950 376946871 + 980297599 2134799092 471343393 399318000 366024363 + -119294618 -522287216 1174578148 1912896242 1258321310 + 2138688869 2018206354 -55329963 -1642821413 -20651690 + -902840145 833589275 1577797242 679072635 -1942177513 + 320222042 1195288052 1023449756 1604196330 -1855553974 + -1949781618 -817719276 -1700406885 889310621 -1471514790 + 1020532847 -629718887 -1271695514 -1937554670 461788560 + 2102950303 -416406808 1078631989 1020004754 -562950235 + 475670268 -753909113 1909254476 -1100846535 -1501356576 + 1618057522 180360050 -1631962502 -1033699393 -1300167011 + -1700565497 1161903681 -704031236 -1389582985 1913949679 + 1254539014 -1021216717 868637461 838550529 1272905945 + 538234140 417057615 -1031775561 -482070700 2049949948 + -83768074 -877837254 -853095341 768678214 -1451589078 + 316521498 1520723031 794057489 818766015 461978832 + 353837892 1305938893 -173485360 2145076917 -619730459 diff --git a/fpmath/demo/stat/av1.pas b/fpmath/demo/stat/av1.pas new file mode 100755 index 0000000..e2e4f8b --- /dev/null +++ b/fpmath/demo/stat/av1.pas @@ -0,0 +1,123 @@ +{ ****************************************************************** + One-way analysis of variance + ****************************************************************** } + +program av1; + +uses + tpmath; + +const + Nsamples = 5; { Number of samples } + Nmax = 12; { Max. number of observations per sample } + Alpha = 0.05; { Significance level } + Prob = 1.0 - Alpha; { Probability } + +{ Sample matrix (one sample per column) } +const + A : array[1..Nmax, 1..Nsamples] of Float = +((7.2, 4.9, 10.4, 4.6, 6.1), + (4.3, 4.8, 4.6, 5.6, 11.4), + (5.5, 4.7, 8.4, 8.3, 8.2), + (4.6, 5.4, 6.1, 6.9, 5.7), + (4.7, 4.7, 8.1, 4.5, 6.6), + (5.5, 4.7, 5.4, 4.7, 6.6), + (6.6, 6.2, 6.7, 6.7, 6.3), + (5.3, 5.6, 7.5, 4.8, 5.9), + (5.4, 3.2, 6.4, 5.0, 5.8), + (3.9, 6.1, 5.6, 5.0, 4.8), + (5.5, 6.7, 6.3, 5.3, 9.1), + (2.7, 5.5, 7.7, 7.8, 13.2)); + +var + X : PVector; { Sample } + Z : PMatrix; { Sample matrix } + N : PIntVector; { Sizes } + M : PVector; { Means } + S : PVector; { Standard dev. } + + V_f, V_r, F : Float; { Variances and variance ratio } + Khi2 : Float; { Bartlett's khi-2 } + H : Float; { Kruskal-Wallis H } + Fc, K2c : Float; { Critical values } + + DoF_f, DoF_r, DoF : Integer; { Degrees of freedom } + J : Integer; { Loop variable } + +procedure GetSample(J : Integer; X : PVector); +{ Get sample J from matrix A into vector X } +var + I : Integer; +begin + for I := 1 to Nmax do + X^[I] := A[I, J]; +end; + +procedure GetSampleMatrix(Z : PMatrix); +{ Get sample matrix into Z } +var + I, J : Integer; +begin + for I := 1 to Nmax do + for J := 1 to Nsamples do + Z^[I]^[J] := A[I, J]; +end; + +begin + { Dimension arrays } + DimVector(X, Nmax); { Sample } + DimMatrix(Z, Nmax, Nsamples); { Sample matrix } + DimIntVector(N, Nsamples); { Sizes } + DimVector(M, Nsamples); { Means } + DimVector(S, Nsamples); { Standard dev. } + + { Compute sizes, means and SD's } + for J := 1 to Nsamples do + begin + GetSample(J, X); + N^[J] := Nmax; + M^[J] := Mean(X, 1, N^[J]); + S^[J] := StDev(X, 1, N^[J], M^[J]); + end; + + { Compare means and variances (parametric tests) } + AnOVa1(Nsamples, N, M, S, V_f, V_r, F, DoF_f, DoF_r); + Bartlett(Nsamples, N, S, Khi2, DoF); + + { Compare means (non-parametric test) } + GetSampleMatrix(Z); + Kruskal_Wallis(Nsamples, N, Z, H, DoF); + + { Compute critical values } + Fc := InvSnedecor(DoF_f, DoF_r, Prob); + K2c := InvKhi2(DoF, Prob); + + Writeln('Sample Mean St.Dev.'); + Writeln('---------------------------'); + + for J := 1 to Nsamples do + Writeln(J:6, M^[J]:10:4, S^[J]:10:4); + + Writeln; + + Writeln('Comparison of means (One-way analysis of variance):'); + Writeln; + Writeln('Factorial variance = ', V_f:10:4, ' (', DoF_f, ' DoF)'); + Writeln('Residual variance = ', V_r:10:4, ' (', DoF_r, ' DoF)'); + Writeln('Variance ratio = ', F:10:4); + Writeln('Critical value (p = ', Alpha:4:2, ') = ', Fc:10:4); + + Writeln; + + Writeln('Comparison of variances:'); + Writeln; + Writeln('Bartlett''s Khi-2 = ', Khi2:10:4, ' (', DoF, ' DoF)'); + Writeln('Critical value (p = ', Alpha:4:2, ') = ', K2c:10:4); + + Writeln; + + Writeln('Comparison of means (Non-parametric test):'); + Writeln; + Writeln('Kruskal-Wallis H = ', H:10:4, ' (', DoF, ' DoF)'); + Writeln('Critical value (p = ', Alpha:4:2, ') = ', K2c:10:4); +end. diff --git a/fpmath/demo/stat/av2.pas b/fpmath/demo/stat/av2.pas new file mode 100755 index 0000000..88a9f46 --- /dev/null +++ b/fpmath/demo/stat/av2.pas @@ -0,0 +1,81 @@ +{ ****************************************************************** + Two-way analysis of variance (several observations per sample) + ****************************************************************** } + +program av2; + +uses + tpmath; + +const + NA = 2; { Number of modalities of factor A } + NB = 2; { Number of modalities of factor B } + N = 12; { Number of observations for each sample } + Alpha = 0.05; { Significance level } + Prob = 1.0 - Alpha; { Probability } + +{ The samples are stored in a 3D array Z, such that + Z[I, J, K] contains the K-th observation for the + I-th modality of factor A and the J-th modality of factor B } + +const + Z : array[1..NA, 1..NB, 1..N] of Float = +(((4.9, 2.9, 2.7, 3.9, 4.6, 3.3, 5.9, 4.8, 4.1, 3.5, 7.2, 6.1), + (2.1, 2.2, 1.1, 2.9, 5.0, 3.5, 2.4, 4.4, 2.1, 3.0, 3.9, 5.6)), + ((4.5, 6.9, 4.0, 5.4, 1.9, 3.6, 4.8, 3.3, 7.5, 5.8, 4.4, 6.0), + (2.4, 3.6, 4.8, 3.9, 5.5, 5.0, 6.8, 2.2, 3.1, 5.0, 4.1, 4.7))); + +var + X : PVector; { Sample } + M, S : PMatrix; { Means and SD } + V : PVector; { Variances (A, B, interaction, residual) } + DoF : PIntVector; { Degrees of freedom (A, B, interaction, residual) } + F : PVector; { Variance ratios (A, B, interaction) } + Fc : PVector; { Critical values } + I, J : Integer; { Loop variables } + +procedure GetSample(I, J : Integer; X : PVector); +{ Get sample [I,J] from array Z into vector X } +var + K : Integer; +begin + for K := 1 to N do + X^[K] := Z[I, J, K]; +end; + +begin + DimVector(X, N); + DimMatrix(M, NA, NB); + DimMatrix(S, NA, NB); + + DimVector(V, 4); + DimIntVector(DoF, 4); + DimVector(F, 3); + DimVector(Fc, 3); + + { Compute means and SD's } + for I := 1 to NA do + for J := 1 to NB do + begin + GetSample(I, J, X); + M^[I]^[J] := Mean(X, 1, N); + S^[I]^[J] := StDev(X, 1, N, M^[I]^[J]); + end; + + { Compare means } + AnOVa2(NA, NB, N, M, S, V, F, DoF); + + { Compute critical values } + for I := 1 to 3 do + Fc^[I] := InvSnedecor(DoF^[I], DoF^[4], Prob); + + { Print results } + WriteLn('Two-way ANOVA'); + WriteLn; + WriteLn('Source Variance D.o.F. F F(p = ', Alpha:4:2, ')'); + WriteLn('--------------------------------------------------------'); + WriteLn('Factor A ', V^[1]:10:4, DoF^[1]:10, F^[1]:10:4, Fc^[1]:10:4); + WriteLn('Factor B ', V^[2]:10:4, DoF^[2]:10, F^[2]:10:4, Fc^[2]:10:4); + WriteLn('Interaction ', V^[3]:10:4, DoF^[3]:10, F^[3]:10:4, Fc^[3]:10:4); + WriteLn('Residual ', V^[4]:10:4, DoF^[4]:10); +end. diff --git a/fpmath/demo/stat/av2a.pas b/fpmath/demo/stat/av2a.pas new file mode 100755 index 0000000..181a8ab --- /dev/null +++ b/fpmath/demo/stat/av2a.pas @@ -0,0 +1,69 @@ +{ ****************************************************************** + Two-way analysis of variance (one observation per sample) + ****************************************************************** } + +program av2a; + +uses + tpmath; + +const + NA = 3; { Number of modalities of factor A } + NB = 4; { Number of modalities of factor B } + Alpha = 0.05; { Significance level } + Prob = 1.0 - Alpha; { Probability } + +{ The samples are stored in a matrix Z, such that + Z[I, J] contains the observation for the I-th + modality of factor A and the J-th modality of factor B } + +const + Z : array[1..NA, 1..NB] of Float = +((2, 1, 3, 1), + (3, 2, 3, 2), + (3, 4, 5, 3)); + +var + M : PMatrix; { Means } + S : PMatrix; { Standard deviations } + + { Note: The S matrix does not need to be dimensioned if there is + only one observation per sample. However, it must be declared. } + + V : PVector; { Variances (A, B, interaction) } + DoF : PIntVector; { Degrees of freedom (A, B, interaction) } + F : PVector; { Variance ratios (A, B) } + Fc : PVector; { Critical values } + I, J : Integer; { Loop variables } + +begin + DimMatrix(M, NA, NB); { Means } + DimMatrix(S, NA, NB); { Standard deviations } + DimVector(V, 3); { Variances (A, B, interaction) } + DimIntVector(DoF, 3); { Degrees of freedom (A, B, interaction) } + DimVector(F, 2); { Variance ratios (A, B) } + DimVector(Fc, 2); { Critical values } + + { Compare means. The matrix of means is equal to the data matrix. + The matrix of standard deviations will be ignored. } + + for I := 1 to NA do + for J := 1 to NB do + M^[I]^[J] := Z[I,J]; + + AnOVa2(NA, NB, 1, M, S, V, F, DoF); + + { Compute critical values } + for I := 1 to 2 do + Fc^[I] := InvSnedecor(DoF^[I], DoF^[3], Prob); + + { Print results } + WriteLn('Two-way ANOVA'); + WriteLn; + WriteLn('Source Variance D.o.F. F F(p = ', Alpha:4:2, ')'); + WriteLn('--------------------------------------------------------'); + WriteLn('Factor A ', V^[1]:10:4, DoF^[1]:10, F^[1]:10:4, Fc^[1]:10:4); + WriteLn('Factor B ', V^[2]:10:4, DoF^[2]:10, F^[2]:10:4, Fc^[2]:10:4); + WriteLn('Interaction ', V^[3]:10:4, DoF^[3]:10); +end. + diff --git a/fpmath/demo/stat/histo.pas b/fpmath/demo/stat/histo.pas new file mode 100755 index 0000000..e8d5f39 --- /dev/null +++ b/fpmath/demo/stat/histo.pas @@ -0,0 +1,230 @@ +{ ****************************************************************** + Statistical distribution and Histogram + ****************************************************************** } + +program histo; + +uses + tpmath, tpgraph; + +const + N = 30; { Number of values } + Alpha = 0.05; { Significance level } + +{ Hemoglobin concentrations in men } +const HbM : array[1..N] of Float = +(141, 144, 146, 148, 149, 150, 150, 151, 153, 153, + 153, 154, 155, 156, 156, 160, 160, 160, 163, 164, + 164, 165, 166, 168, 168, 170, 172, 172, 176, 179); + +var + M, S : Float; { Mean and standard deviation } + +function PltFunc(X : Float) : Float; +{ ------------------------------------------------------------------ + Function to be plotted (density of normal distribution) + ------------------------------------------------------------------ } + +begin + PltFunc := DNorm((X - M) / S) / S; +end; + +procedure WriteResults(C : PStatClassVector; + Ncls : Integer; + Calc : PVector; + Khi2, G : Float; + DoF : Integer; + K2c : Float); +{ ------------------------------------------------------------------ + Writes results to screen + ------------------------------------------------------------------ } + +const + Line1 = '-----------------------------'; + +var + Sum : Float; + I : Integer; + +begin + Writeln('Statistical distribution'); + + Writeln(Line1); + Writeln(' Inf Sup N Ncalc'); + Writeln(Line1); + + Sum := 0.0; + for I := 1 to Ncls do + begin + Writeln(C^[I].Inf:8:0, C^[I].Sup:7:0, C^[I].N:7, Calc^[I]:7:2); + Sum := Sum + Calc^[I]; + end; + + Writeln(Line1); + Writeln('Total ', N:5, Sum:7:2); + Writeln(Line1); + + Writeln; + Writeln('Comparison with normal distribution:'); + Writeln; + + Writeln('Pearson''s Khi-2 = ', Khi2:10:4, ' (', DoF, ' DoF)'); + Writeln('Woolf''s G = ', G:10:4, ' (', DoF, ' DoF)'); + Writeln('Critical value (p = ', Alpha:4:2, ') = ', K2c:10:4); +end; + +procedure PlotGraph(C : PStatClassVector; + Ncls : Integer; + Xmin , Xmax, Xstep : Float); +{ ------------------------------------------------------------------ + Plots histogram and normal curve + ------------------------------------------------------------------ } + +var + Ymin, Ymax, Ystep : Float; { Oy scale } + Npts : Integer; { Number of points } + X, Y : PVector; { Point coordinates } + I, J : Integer; { Loop variables } + +begin + if not InitGraphics(9, 2, 'c:\tp\bgi') then { 640x480 16 color } + begin + Writeln('Unable to set graphic mode'); + Exit; + end; + + SetWindow(15, 85, 15, 85, True); + + { The histogram is plotted as a continuous curve. + Each bar of the histogram is defined by 4 points } + + Npts := 4 * Ncls; + + DimVector(X, Npts); + DimVector(Y, Npts); + + for I := 1 to Ncls do + with C^[I] do + begin + J := 4 * (I - 1) + 1; X^[J] := Inf; { Y^[J] := 0 } + Inc(J); X^[J] := Inf; Y^[J] := D; + Inc(J); X^[J] := Sup; Y^[J] := D; + Inc(J); X^[J] := Sup; { Y^[J] := 0 } + end; + + { Set scale on Oy, making sure that it starts from 0 } + + AutoScale(Y, 1, Ncls, LinScale, Ymin, Ymax, Ystep); + + if Ymin <> 0.0 then Ymin := 0.0; + Ymax := Ymax + Ystep; + + SetOxScale(LinScale, Xmin, Xmax, Xstep); + SetOyScale(LinScale, Ymin, Ymax, Ystep); + + SetGraphTitle('Statistical Distribution'); + SetOxTitle('X'); + SetOyTitle('Frequency Density'); + + PlotOxAxis; + PlotOyAxis; + + WriteGraphTitle; + + SetClipping(True); + + { Plot histogram and normal curve } + + SetPointParam(1, 0, 0, 0); { Don't show points on histogram } + SetLineParam(1, 1, 3, 1); { Use thick lines } + + PlotCurve(X, Y, 1, Npts, 1); + + PlotFunc({$IFDEF FPC}@{$ENDIF}PltFunc, Xmin, Xmax, 2); + + DelVector(X, Npts); + DelVector(Y, Npts); + + Readln; + + LeaveGraphics; +end; + +{ ****************************************************************** + Main program + ****************************************************************** } + +var + X : PVector; { Data } + C : PStatClassVector; { Statistical classes } + Ncls : Integer; { Number of classes } + Obs : PIntVector; { Observed frequencies } + Calc : PVector; { Calculated frequencies } + Khi2 : Float; { Pearson's Khi-2 } + G : Float; { Woolf's G } + K2c : Float; { Theoretical Khi-2 } + DoF : Integer; { Degrees of freedom } + T : Float; { Standard normal variable } + F0, F : Float; { Cumulative probability } + XMin, + XMax, + XStep : Float; { Scale on Ox } + I : Integer; { Loop variable } + +begin + { Read data } + DimVector(X, N); + for I := 1 to N do + X^[I] := HbM[I]; + + { Sort data if necessary } + { QSort(X, 1, N); } + + { Compute an appropriate interval for the set of values } + Interval(X^[1], X^[N], 5, 10, XMin, XMax, XStep); + + { Compute number of classes and dimension arrays } + Ncls := Round((Xmax - Xmin) / XStep); + + DimStatClassVector(C, Ncls); + DimIntVector(Obs, Ncls); + DimVector(Calc, Ncls); + + { Compute distribution } + Distrib(X, 1, N, Xmin, Xmax, XStep, C); + + { Compute mean and S.D. } + M := Mean(X, 1, N); + S := StDev(X, 1, N, M); + + { Compute theoretical values } + F0 := 0.0; + for I := 1 to Ncls do + begin + if I = Ncls then + F := 1.0 + else + begin + T := (C^[I].Sup - M) / S; + F := FNorm(T); + end; + Calc^[I] := N * (F - F0); + Obs^[I] := C^[I].N; + F0 := F; + end; + + { Perform Khi-2 and Woolf tests } + Khi2_Conform(Ncls, 2, Obs, Calc, Khi2, DoF); + Woolf_Conform(Ncls, 2, Obs, Calc, G, DoF); + + { Compute critical value } + K2c := InvKhi2(DoF, 1.0 - Alpha); + + { Print results } + WriteResults(C, Ncls, Calc, Khi2, G, DoF, K2c); + + Readln; + + { Plot histogram } + PlotGraph(C, Ncls, Xmin - Xstep, Xmax + Xstep, Xstep); +end. diff --git a/fpmath/demo/stat/khi2.pas b/fpmath/demo/stat/khi2.pas new file mode 100755 index 0000000..4884bbc --- /dev/null +++ b/fpmath/demo/stat/khi2.pas @@ -0,0 +1,112 @@ +{ ****************************************************************** + Khi-2 and Woolf's tests + ****************************************************************** } + +program khi2; + +uses + tpmath; + +const + Alpha = 0.05; { Significance level } + +var + K2, K2c, G : Float; + DoF : Integer; + +{ ------------------------------------------------------------------ + Data for the conformity test + ------------------------------------------------------------------ } + +const + N = 4; + + Obs : array[1..N] of Integer = (104, 76, 18, 2); + Calc : array[1..N] of Float = ( 94, 86, 14, 6); + +{ ------------------------------------------------------------------ + Data for the independence test + ------------------------------------------------------------------ } + +const + Nr = 2; Nc = 3; { Number of rows and columns } + + T : array[1..Nr, 1..Nc] of Integer = { Contingency table } + ((280, 210, 110), + (220, 90, 90)); + +{ ------------------------------------------------------------------ + Procedures for reading data + ------------------------------------------------------------------ } + +procedure GetDataConf(O : PIntVector; C : PVector); +{ Get data for conformity test } +var + I : Integer; +begin + for I := 1 to N do + begin + O^[I] := Obs[I]; + C^[I] := Calc[I]; + end; +end; + +procedure GetDataInd(A : PIntMatrix); +{ Get data for independence test } +var + I, J : Integer; +begin + for I := 1 to Nr do + for J := 1 to Nc do + A^[I]^[J] := T[I,J]; +end; + +{ ------------------------------------------------------------------ + Main program + ------------------------------------------------------------------ } + +var + O : PIntVector; + C : PVector; + A : PIntMatrix; + +begin + DimIntVector(O, N); + DimVector(C, N); + DimIntMatrix(A, Nr, Nc); + + GetDataConf(O, C); + GetDataInd(A); + + { Tests for conformity } + + Khi2_Conform(N, 0, O, C, K2, DoF); + Woolf_Conform(N, 0, O, C, G, DoF); + + K2c := InvKhi2(DoF, 1.0 - Alpha); + + WriteLn('Comparison of two distributions:'); + + WriteLn; + + WriteLn('Pearson''s Khi-2 = ', K2:10:4, ' (', DoF, ' DoF)'); + WriteLn('Woolf''s G = ', G:10:4, ' (', DoF, ' DoF)'); + WriteLn('Critical value (p = ', Alpha:5:3, ') = ', K2c:10:4); + + WriteLn; + WriteLn; + + { Tests for independence } + + Khi2_Indep(Nr, Nc, A, K2, DoF); + Woolf_Indep(Nr, Nc, A, G, DoF); + + K2c := InvKhi2(DoF, 1.0 - Alpha); + + WriteLn('Analysis of contingency table:'); + WriteLn; + + WriteLn('Pearson''s Khi-2 = ', K2:10:4, ' (', DoF, ' DoF)'); + WriteLn('Woolf''s G = ', G:10:4, ' (', DoF, ' DoF)'); + WriteLn('Critical value (p = ', Alpha:5:3, ') = ', K2c:10:4); +end. \ No newline at end of file diff --git a/fpmath/demo/stat/stat.pas b/fpmath/demo/stat/stat.pas new file mode 100755 index 0000000..30742cd --- /dev/null +++ b/fpmath/demo/stat/stat.pas @@ -0,0 +1,118 @@ +{ ****************************************************************** + Statistics: Concentration of hemoglobin in blood (mg/L) in men + and women. + ****************************************************************** } + +program stat; + +uses + tpmath; + +const + N = 30; { Number of values } + Alpha = 0.05; { Significance level } + +{ Concentrations in men } +const HbM : array[1..N] of Float = +(141, 144, 146, 148, 149, 150, 150, 151, 153, 153, + 153, 154, 155, 156, 156, 160, 160, 160, 163, 164, + 164, 165, 166, 168, 168, 170, 172, 172, 176, 179); + +{ Concentrations in women } +const HbW : array[1..N] of Float = +(105, 110, 112, 112, 118, 119, 120, 120, 125, 126, + 127, 128, 130, 132, 133, 134, 135, 138, 138, 138, + 138, 142, 145, 148, 148, 150, 151, 154, 154, 158); + +var + XX, YY : PVector; { Data } + MM, MW, SM, SW : Float; { Means and standard deviations } + SkM, SkW, KM, KW : Float; { Skewness and kurtosis } + T, F : Float; { Student's t and Snedecor's F } + U, Eps : Float; { Mann-Whitney's U and assoc. standard normal } + DoF, DoF1, DoF2 : Integer; { Degrees of freedom } + Tc, Fc, Ec : Float; { Critical values } + P : Float; { Probability } + +procedure GetData(XX, YY : PVector); +{ Get data into arrays } +var + I : Integer; +begin + for I := 1 to N do + begin + XX^[I] := HbM[I]; + YY^[I] := HbW[I]; + end; +end; + +begin + DimVector(XX, N); + DimVector(YY, N); + + GetData(XX, YY); + + { Compute statistical parameters } + + MM := Mean(XX, 1, N); + MW := Mean(YY, 1, N); + + SM := StDev(XX, 1, N, MM); + SW := StDev(YY, 1, N, MW); + + SkM := Skewness(XX, 1, N, MM, SM); + SkW := Skewness(YY, 1, N, MW, SW); + + KM := Kurtosis(XX, 1, N, MM, SM); + KW := Kurtosis(YY, 1, N, MW, SW); + + { Compare means and variances (parametric tests) } + + StudIndep(N, N, MM, MW, SM, SW, T, DoF); + Snedecor(N, N, SM, SW, F, DoF1, DoF2); + + { Compare means (non-parametric test) } + + Mann_Whitney(N, N, XX, YY, U, Eps); + + { Compute critical values } + + P := 1.0 - 0.5 * Alpha; + + Tc := InvStudent(DoF, P); + Fc := InvSnedecor(DoF1, DoF2, P); + Ec := InvNorm(P); + + WriteLn('Hemoglobin in blood'); + WriteLn; + WriteLn(' Men Women'); + WriteLn; + WriteLn('Mean : ', MM:10:4, MW:10:4); + WriteLn('St. dev. : ', SM:10:4, SW:10:4); + WriteLn('Skewness : ', SkM:10:4, SkW:10:4); + WriteLn('Kurtosis : ', KM:10:4, KW:10:4); + + WriteLn; + + WriteLn('Comparison of means (parametric test):'); + WriteLn; + WriteLn('Student''s t = ', T:10:4, ' (', DoF, ' DoF)'); + WriteLn('Critical value (p = ', Alpha:5:3, ') = ', Tc:10:4); + + WriteLn; + + WriteLn('Comparison of variances:'); + WriteLn; + WriteLn('Snedecor''s F = ', F:10:4, ' (', DoF1, ' and ', DoF2, ' DoF)'); + WriteLn('Critical value (p = ', Alpha:5:3, ') = ', Fc:10:4); + + WriteLn; + + WriteLn('Comparison of means (non-parametric test):'); + WriteLn; + WriteLn('Mann-Whitney U = ', U:10:4); + WriteLn('Associated standard normal = ', Eps:10:4); + WriteLn('Critical value (p = ', Alpha:5:3, ') = ', Ec:10:4); + + WriteLn; +end. diff --git a/fpmath/demo/stat/student.pas b/fpmath/demo/stat/student.pas new file mode 100755 index 0000000..698077a --- /dev/null +++ b/fpmath/demo/stat/student.pas @@ -0,0 +1,93 @@ +{ ****************************************************************** + Comparison of means for paired samples + ****************************************************************** } + +program student; + +uses + tpmath; + +const + N = 12; { Number of values } + Alpha = 0.05; { Significance level } + +{ First sample } +const X : array[1..N] of Float = +(9.2, 10, 9, 9.4, 10.1, 9.5, 10, 10.3, 10.2, 10.2, 9.8, 10.1); + +{ Second sample } +const Y : array[1..N] of Float = +(9.5, 9, 8.8, 9.5, 9.1, 10, 10.1, 9.3, 9, 9.7, 9.1, 9.3); + +var + XX, YY : PVector; { Data } + MX, MY : Float; { Means } + SX, SY : Float; { Standard deviations } + T : Float; { Student's t } + WT, Eps : Float; { Wilcoxon's T and assoc. standard normal } + Nd : Integer; { Number of nonzero differences } + DoF : Integer; { Degrees of freedom } + P : Float; { Probability } + Tc, Ec : Float; { Critical values } + +procedure GetData(XX, YY : PVector); +{ Get data into arrays } +var + I : Integer; +begin + for I := 1 to N do + begin + XX^[I] := X[I]; + YY^[I] := Y[I]; + end; +end; + +begin + DimVector(XX, N); + DimVector(YY, N); + + GetData(XX, YY); + + { Compute statistical parameters } + + MX := Mean(XX, 1, N); + MY := Mean(YY, 1, N); + + SX := StDev(XX, 1, N, MX); + SY := StDev(YY, 1, N, MY); + + { Compare means (parametric test) } + + StudPaired(XX, YY, 1, N, T, DoF); + + { Compare means (non-parametric test) } + + Wilcoxon(XX, YY, 1, N, Nd, WT, Eps); + + { Compute critical values } + + P := 1.0 - 0.5 * Alpha; + + Tc := InvStudent(DoF, P); + Ec := InvNorm(P); + + WriteLn(' X Y'); + WriteLn; + WriteLn('Mean :', MX:10:4, MY:10:4); + WriteLn('St. dev. :', SX:10:4, SY:10:4); + + WriteLn; + + WriteLn('Comparison of means (paired samples, parametric test)'); + WriteLn; + WriteLn('Student''s t = ', T:10:4, ' (', DoF, ' DoF)'); + WriteLn('Critical value (p = ', Alpha:5:3, ') = ', Tc:10:4); + + WriteLn; + + WriteLn('Comparison of means (paired samples, non-parametric test)'); + WriteLn; + WriteLn('Wilcoxon''s T = ', WT:10:4); + WriteLn('Associated standard normal = ', Eps:10:4); + WriteLn('Critical value (p = ', Alpha:5:3, ') = ', Ec:10:4); +end. \ No newline at end of file diff --git a/fpmath/dll/dcompil.bat b/fpmath/dll/dcompil.bat new file mode 100755 index 0000000..7050c03 --- /dev/null +++ b/fpmath/dll/dcompil.bat @@ -0,0 +1,6 @@ +dcc32 tpmath.dpr -U..\units -DDELPHI -$J+ +dcc32 tpmath.pas -I..\units -DDELPHI + +dcc32 tpgraph.dpr -U..\units -DDELPHI -$J+ +dcc32 tpgraph.pas -I..\units -DDELPHI + diff --git a/fpmath/dll/fpcompil.bat b/fpmath/dll/fpcompil.bat new file mode 100755 index 0000000..b910712 --- /dev/null +++ b/fpmath/dll/fpcompil.bat @@ -0,0 +1,5 @@ +fpc tpmath.dpr -Fu..\units -Mdelphi +fpc tpmath.pas -Fi..\units -Mdelphi + +fpc tpgraph.dpr -Fu..\units -Mdelphi +fpc tpgraph.pas -Fi..\units -Mdelphi diff --git a/fpmath/dll/fpcompil.sh b/fpmath/dll/fpcompil.sh new file mode 100755 index 0000000..c4f9041 --- /dev/null +++ b/fpmath/dll/fpcompil.sh @@ -0,0 +1,5 @@ +fpc tpmath.dpr -Fu../units -Mdelphi +fpc tpmath.dpr -Fi../units -Mdelphi + +fpc tpgraph.dpr -Fu../units -Mdelphi +fpc tpgraph.dpr -Fi../units -Mdelphi \ No newline at end of file diff --git a/fpmath/dll/tpgraph.dpr b/fpmath/dll/tpgraph.dpr new file mode 100755 index 0000000..bcb9830 --- /dev/null +++ b/fpmath/dll/tpgraph.dpr @@ -0,0 +1,49 @@ +library tpgraph; + +uses +{$IFDEF DELPHI} + uwinplot; +{$ELSE} + uplot; +{$ENDIF} + +exports + InitGraphics, { Initializes the graphic } + SetWindow, { Sets the graphic window } + AutoScale, { Automatic scale determination } + SetOxScale, { Sets the scale on the Ox axis } + SetOyScale, { Sets the scale on the Oy axis } + SetGraphTitle, { Sets the graph title } + SetOxTitle, { Sets the title for the Ox axis } + SetOyTitle, { Sets the title for the Oy axis } +{$IFNDEF DELPHI} + SetTitleFont, { Sets the font for the main graph title } + SetOxFont, { Sets the font for the Ox axis } + SetOyFont, { Sets the font for the Oy axis } + SetLgdFont, { Sets the font for the legends } + SetClipping, { Limits the graphic to the current viewport } +{$ENDIF} + PlotOxAxis, { Plots the X axis } + PlotOyAxis, { Plots the Y axis } + WriteGraphTitle, { Writes title of graph } + PlotGrid, { Plots a grid on the graph } + SetMaxCurv, { Sets maximum number of curves } + SetPointParam, { Sets point parameters } + SetLineParam, { Sets line parameters } + SetCurvLegend, { Sets curve legend } + SetCurvStep, { Sets curve step } + PlotPoint, { Plots a point } + PlotCurve, { Plots a curve } + PlotCurveWithErrorBars, { Plots a curve with error bars } + PlotFunc, { Plots a function } + WriteLegend, { Writes the legends for the plotted curves } + ConRec, { Contour plot } + Xpixel, { Converts user abscissa X to screen coordinate } + Ypixel, { Converts user ordinate Y to screen coordinate } + Xuser, { Converts screen coordinate X to user abscissa } + Yuser, { Converts screen coordinate Y to user ordinate } + LeaveGraphics; { Quits the graphic mode } + +begin +end. + diff --git a/fpmath/dll/tpgraph.pas b/fpmath/dll/tpgraph.pas new file mode 100755 index 0000000..4d8df96 --- /dev/null +++ b/fpmath/dll/tpgraph.pas @@ -0,0 +1,179 @@ +{ ****************************************************************** + Unit TPGRAPH - Interface for TPGRAPH.DLL + ****************************************************************** } + +unit tpgraph; + +interface + +uses + tpmath {$IFDEF DELPHI}, Graphics{$ENDIF}; + +function InitGraphics +{$IFDEF DELPHI} +(Canvas : TCanvas; Width, Height : Integer) : Boolean; +{$ELSE} +(Pilot, Mode : Integer; BGIPath : String) : Boolean; +{$ENDIF} +external 'tpgraph'; +{ Enters graphic mode } + +procedure SetWindow({$IFDEF DELPHI}Canvas : TCanvas;{$ENDIF} + X1, X2, Y1, Y2 : Integer; GraphBorder : Boolean); +external 'tpgraph'; +{ Sets the graphic window } + +procedure AutoScale(X : PVector; + Lb, Ub : Integer; + Scale : TScale; + var XMin, XMax, XStep : Float); +external 'tpgraph'; +{ Finds an appropriate scale for plotting the data in X[Lb..Ub] } + +procedure SetOxScale(Scale : TScale; + OxMin, OxMax, OxStep : Float); +external 'tpgraph'; +{ Sets the scale on the Ox axis } + +procedure SetOyScale(Scale : TScale; + OyMin, OyMax, OyStep : Float); +external 'tpgraph'; +{ Sets the scale on the Oy axis } + +procedure SetGraphTitle(Title : String); external 'tpgraph'; +{ Sets the title for the graph } + +procedure SetOxTitle(Title : String); external 'tpgraph'; +{ Sets the title for the Ox axis } + +procedure SetOyTitle(Title : String); external 'tpgraph'; +{ Sets the title for the Oy axis } + +{$IFNDEF DELPHI} + +procedure SetTitleFont(FontIndex, Width, Height : Integer); +external 'tpgraph'; +{ Sets the font for the main graph title } + +procedure SetOxFont(FontIndex, Width, Height : Integer); +external 'tpgraph'; +{ Sets the font for the Ox axis (title and labels) } + +procedure SetOyFont(FontIndex, Width, Height : Integer); +external 'tpgraph'; +{ Sets the font for the Oy axis (title and labels) } + +procedure SetLgdFont(FontIndex, Width, Height : Integer); +external 'tpgraph'; +{ Sets the font for the legends } + +procedure SetClipping(Clip : Boolean); +external 'tpgraph'; +{ Determines whether drawings are clipped at the current viewport + boundaries, according to the value of the Boolean parameter Clip } + +{$ENDIF} + +procedure PlotOxAxis{$IFDEF DELPHI}(Canvas : TCanvas){$ENDIF}; +external 'tpgraph'; +{ Plots the horizontal axis } + +procedure PlotOyAxis{$IFDEF DELPHI}(Canvas : TCanvas){$ENDIF}; +external 'tpgraph'; +{ Plots the vertical axis } + +procedure PlotGrid({$IFDEF DELPHI}Canvas : TCanvas;{$ENDIF} Grid : TGrid); +external 'tpgraph'; +{ Plots a grid on the graph } + +procedure WriteGraphTitle{$IFDEF DELPHI}(Canvas : TCanvas){$ENDIF}; +external 'tpgraph'; +{ Writes the title of the graph } + +procedure SetMaxCurv(NCurv : Byte); external 'tpgraph'; +{ Sets the maximum number of curves and re-initializes their parameters } + +procedure SetPointParam +{$IFDEF DELPHI} +(CurvIndex, Symbol, Size : Integer; Color : TColor); +{$ELSE} +(CurvIndex, Symbol, Size, Color : Integer); +{$ENDIF} +external 'tpgraph'; +{ Sets the point parameters for curve # CurvIndex } + +procedure SetLineParam +{$IFDEF DELPHI} +(CurvIndex : Integer; Style : TPenStyle; Width : Integer; Color : TColor); +{$ELSE} +(CurvIndex, Style, Width, Color : Integer); +{$ENDIF} +external 'tpgraph'; +{ Sets the line parameters for curve # CurvIndex } + +procedure SetCurvLegend(CurvIndex : Integer; Legend : String); +external 'tpgraph'; +{ Sets the legend for curve # CurvIndex } + +procedure SetCurvStep(CurvIndex, Step : Integer); +external 'tpgraph'; +{ Sets the step for curve # CurvIndex } + +procedure PlotPoint({$IFDEF DELPHI}Canvas : TCanvas;{$ENDIF} + X, Y : Float; + CurvIndex : Integer); +external 'tpgraph'; +{ Plots a point on the screen } + +procedure PlotCurve({$IFDEF DELPHI}Canvas : TCanvas;{$ENDIF} + X, Y : PVector; + Lb, Ub, CurvIndex : Integer); +external 'tpgraph'; +{ Plots a curve } + +procedure PlotCurveWithErrorBars({$IFDEF DELPHI}Canvas : TCanvas;{$ENDIF} + X, Y, S : PVector; + Ns, Lb, Ub, CurvIndex : Integer); +external 'tpgraph'; +{ Plots a curve with error bars } + +procedure PlotFunc({$IFDEF DELPHI}Canvas : TCanvas;{$ENDIF} + Func : TFunc; + Xmin, Xmax : Float; + {$IFDEF DELPHI}Npt : Integer;{$ENDIF} + CurvIndex : Integer); +external 'tpgraph'; +{ Plots a function } + +procedure WriteLegend({$IFDEF DELPHI}Canvas : TCanvas;{$ENDIF} + NCurv : Integer; + ShowPoints, ShowLines : Boolean); +external 'tpgraph'; +{ Writes the legends for the plotted curves } + +procedure ConRec({$IFDEF DELPHI}Canvas : TCanvas;{$ENDIF} + Nx, Ny, Nc : Integer; + X, Y, Z : PVector; + F : PMatrix); +external 'tpgraph'; +{ Contour plot } + +function Xpixel(X : Float) : Integer; external 'tpgraph'; +{ Converts user abscissa X to screen coordinate } + +function Ypixel(Y : Float) : Integer; external 'tpgraph'; +{ Converts user ordinate Y to screen coordinate } + +function Xuser(X : Integer) : Float; external 'tpgraph'; +{ Converts screen coordinate X to user abscissa } + +function Yuser(Y : Integer) : Float; external 'tpgraph'; +{ Converts screen coordinate Y to user ordinate } + +procedure LeaveGraphics; external 'tpgraph'; +{ Quits graphic mode } + +implementation + +end. + diff --git a/fpmath/dll/tpmath.dpr b/fpmath/dll/tpmath.dpr new file mode 100755 index 0000000..e6f6bb8 --- /dev/null +++ b/fpmath/dll/tpmath.dpr @@ -0,0 +1,268 @@ +library tpmath; + +uses + utypes, uminmax, uround, umath, utrigo, uhyper, ugamma, + udigamma, uigamma, ubeta, uibeta, ulambert, ufact, ubinom, + upoidist, uexpdist, unormal, ugamdist, uibtdist, uigmdist, uinvnorm, + uinvgam, uinvbeta, ugausjor, ulineq, ucholesk, ulu, uqr, + usvd, ueigval, ueigvec, ujacobi, uminbrak, ugoldsrc, ulinmin, + unewton, umarq, ubfgs, usimplex, ubisect, unewteq, usecant, + unewteqs, ubroyden, upolynom, urtpol1, urtpol2, urtpol3, urtpol4, + urootpol, upolutil, utrapint, ugausleg, urkf, ufft, urandom, + uranmwc, uranmt, uranuvag, urangaus, uranmult, umcmc, usimann, + ugenalg, umeansd, ucorrel, uqsort, umedian, uskew, uinterv, + ustudind, ustdpair, uanova1, uanova2, usnedeco, ubartlet, ukhi2, + uwoolf, unonpar, udistrib, ulinfit, upolfit, umulfit, usvdfit, + unlfit, uregtest, upca, ustrings; + +exports + SetErrCode, { Sets error code } + DefaultVal, { Sets error code and default function value } + MathErr, { Returns the error code } + SetAutoInit, { Sets automatic array initialization } + DimVector, { Allocates a real vector } + DimIntVector, { Allocates an integer vector } + DimCompVector, { Allocates a complex vector } + DimBoolVector, { Allocates a boolean vector } + DimStrVector, { Allocates a string vector } + DimMatrix, { Allocates a real matrix } + DimIntMatrix, { Allocates an integer matrix } + DimCompMatrix, { Allocates a complex matrix } + DimBoolMatrix, { Allocates a boolean matrix } + DimStrMatrix, { Allocates a string matrix } + DelVector, { Deallocates a real vector } + DelIntVector, { Deallocates an integer vector } + DelCompVector, { Deallocates a complex vector } + DelBoolVector, { Deallocates a boolean vector } + DelStrVector, { Deallocates a string vector } + DelMatrix, { Deallocates a real matrix } + DelIntMatrix, { Deallocates an integer matrix } + DelCompMatrix, { Deallocates a complex matrix } + DelBoolMatrix, { Deallocates a boolean matrix } + DelStrMatrix, { Deallocates a string matrix } + FMin, { Minimum of 2 reals } + FMax, { Maximum of 2 reals } + IMin, { Minimum of 2 integers } + IMax, { Maximum of 2 integers } + Sgn, { Sign, Sgn(0) = 1 } + Sgn0, { Sign, Sgn(0) = 0 } + DSgn, { DSgn(A, B) = Sgn(B) * |A| } + FSwap, { Exchanges 2 reals } + ISwap, { Exchanges 2 integers } + RoundN, { Rounds a number to N decimal places } + Ceil, { Ceiling function } + Floor, { Floor function } + Expo, { Exponential (with bound checking) } + Exp2, { Exponential, base 2 } + Exp10, { Exponential, base 10 } + Log, { Natural log (with bound checking) } + Log2, { Log, base 2 } + Log10, { Log, base 10 } + LogA, { Log, base A } + IntPower, { Power (integer exponent) } + Power, { Power (real exponent) } + Pythag, { Sqrt(X^2 + Y^2) } + FixAngle, { Set argument in -Pi..Pi } + Tan, { Tangent } + ArcSin, { Arc sinus } + ArcCos, { Arc cosinus } + ArcTan2, { Angle (Ox, OM) with M(X,Y) } + Sinh, { Hyperbolic sine } + Cosh, { Hyperbolic cosine } + Tanh, { Hyperbolic tangent } + ArcSinh, { Inverse hyperbolic sine } + ArcCosh, { Inverse hyperbolic cosine } + ArcTanh, { Inverse hyperbolic tangent } + SinhCosh, { Sinh and Cosh } + Gamma, { Gamma function } + LnGamma, { Logarithm of Gamma function } + SgnGamma, { Sign of Gamma function } + Stirling, { Stirling's formula for Gamma } + StirLog, { Stirling's formula for LnGamma } + DiGamma, { DiGamma function } + TriGamma, { TriGamma function } + IGamma, { Incomplete Gamma function } + JGamma, { Complement of incomplete Gamma function } + Erf, { Error function } + Erfc, { Complement of error function } + Beta, { Beta function } + IBeta, { Incomplete Beta function } + LambertW, { Lambert's W-function } + Fact, { Factorial } + Binomial, { Binomial coefficient } + PBinom, { Probability of binomial distribution } + PPoisson, { Probability of Poisson distribution } + DExpo, { Density of exponential distribution } + FExpo, { Cumulative prob. of exponential dist. } + DNorm, { Density of standard normal distribution } + DBeta, { Density of Beta distribution } + DGamma, { Density of Gamma distribution } + DKhi2, { Density of Khi-2 distribution } + DStudent, { Density of Student's distribution } + DSnedecor, { Density of Fisher-Snedecor distribution } + FBeta, { Cumulative prob. of Beta distribution } + FBinom, { Cumulative prob. of Binomial distribution } + FStudent, { Cumulative prob. of Student's distribution } + PStudent, { Prob(|t| > X) for Student's distribution } + FSnedecor, { Cumulative prob. of Fisher-Snedecor distribution } + PSnedecor, { Prob(F > X) for Fisher-Snedecor distribution } + FGamma, { Cumulative prob. of Gamma distribution } + FPoisson, { Cumulative prob. of Poisson distribution } + FNorm, { Cumulative prob. of standard normal distribution } + PNorm, { Prob(|U| > X) for standard normal distribution } + FKhi2, { Cumulative prob. of Khi-2 distribution } + PKhi2, { Prob(Khi2 > X) for Khi-2 distribution } + InvNorm, { Inverse of normal distribution } + InvGamma, { Inverse of incomplete Gamma function } + InvKhi2, { Inverse of khi-2 distribution } + InvBeta, { Inverse of incomplete Beta function } + InvStudent, { Inverse of Student's t-distribution } + InvSnedecor, { Inverse of Snedecor's F-distribution } + GaussJordan, { Linear equation system (Gauss-Jordan method) } + LinEq, { Linear equation system (Gauss-Jordan method) } + Cholesky, { Cholesky factorization } + LU_Decomp, { LU decomposition } + LU_Solve, { Linear equation system (LU method) } + QR_Decomp, { QR decomposition } + QR_Solve, { Linear equation system (QR method) } + SV_Decomp, { Singular value decomposition } + SV_Solve, { Linear equation system (SVD method) } + SV_SetZero, { Set lowest singular values to zero } + SV_Approx, { Matrix approximation from SVD } + EigenVals, { Eigenvalues of a general square matrix } + EigenVect, { Eigenvalues and eigenvectors of a general square matrix } + Jacobi, { Eigenvalues and eigenvectors of a symmetric matrix } + MinBrack, { Brackets the minimum of a function } + GoldSearch, { Minimization of a function of one variable (golden search) } + LinMin, { Minimization of a function of several variables along a line } + Newton, { Minimization of a function of several var. (Newton's method) } + SaveNewton, { Save Newton iterations in a file } + Marquardt, { Minimization of a function of several var. (Marquardt's method) } + SaveMarquardt, { Save Marquardt iterations in a file } + BFGS, { Minimization of a function of several var. (BFGS method) } + SaveBFGS, { Save BFGS iterations in a file } + Simplex, { Minimization of a function of several variables (Simplex) } + SaveSimplex, { Save Simplex iterations in a file } + RootBrack, { Brackets solution of equation } + Bisect, { Nonlinear equation (bisection method) } + NewtEq, { Nonlinear equation (Newton-Raphson method) } + Secant, { Nonlinear equation (secant method) } + NewtEqs, { Nonlinear equation system (Newton-Raphson method) } + Broyden, { Nonlinear equation system (Broyden's method) } + Poly, { Evaluates a polynomial } + RFrac, { Evaluates a rational fraction } + RootPol1, { Root of linear equation } + RootPol2, { Roots of quadratic equation } + RootPol3, { Roots of cubic equation } + RootPol4, { Roots of quartic equation } + RootPol, { Roots of polynomial from companion matrix } + SetRealRoots, { Set the imaginary part of a root to zero } + SortRoots, { Sorts the roots of a polynomial } + TrapInt, { Integration by trapezoidal rule } + GausLeg, { Gauss-Legendre integration } + GausLeg0, { Gauss-Legendre integration (lower bound=0) } + Convol, { Convolution product } + RKF45, { Integration of a system of differential equations } + FFT, { Fast Fourier Transform } + IFFT, { Inverse Fast Fourier Transform } + FFT_Integer, { Fast Fourier Transform for integer data } + FFT_Integer_Cleanup, { Clear memory after a call to FFT_Integer } + CalcFrequency, { Direct computation of Fourier Transform } + SetRNG, { Select random number generator } + InitGen, { Initialize random number generator } + IRanGen, { 32-bit random integer in [-2^31 .. 2^31 - 1] } + IRanGen31, { 31-bit random integer in [0 .. 2^31 - 1] } + RanGen1, { 32-bit random real in [0,1] } + RanGen2, { 32-bit random real in [0,1) } + RanGen3, { 32-bit random real in (0,1) } + RanGen53, { 53-bit random real in [0,1) } + InitMWC, { Initialize Multiply-With-Carry generator } + IRanMWC, { 32-bit random integer from MWC generator } + InitMT, { Initialize Mersenne Twister generator with a seed } + InitMTbyArray, { Initialize MT generator with an array } + IRanMT, { 32-bit random integer from MT generator } + InitUVAG, { Initialize UVAG generator with a seed } + InitUVAGbyString, { Initialize UVAG generator with a string } + IRanUVAG, { 32-bit random integer from UVAG generator } + RanGaussStd, { Random number from standard normal distribution } + RanGauss, { Random number from normal distribution } + RanMult, { Random vector from multinormal distrib. (correlated) } + RanMultIndep, { Random vector from multinormal distrib. (uncorrelated) } + InitMHParams, { Initialize Metropolis-Hastings parameters } + GetMHParams, { Returns Metropolis-Hastings parameters } + Hastings, { Simulation of a p.d.f. by Metropolis-Hastings } + InitSAParams, { Initialize Simulated Annealing parameters } + SA_CreateLogFile, { Initialize log file for Simulated Annealing } + SimAnn, { Minimization of a function of several var. by Simulated Annealing } + InitGAParams, { Initialize Genetic Algorithm parameters } + GA_CreateLogFile, { Initialize log file for Genetic Algorithm } + GenAlg, { Minimization of a function of several var. by Genetic Algorithm } + Mean, { Sample mean } + Median, { Sample median } + StDev, { Standard deviation estimated from sample } + StDevP, { Standard deviation of population } + Correl, { Correlation coefficient } + Skewness, { Sample skewness } + Kurtosis, { Sample kurtosis } + QSort, { Quick sort (ascending order) } + DQSort, { Quick sort (descending order) } + Interval, { Determines an interval for a set of values } + StudIndep, { Student t-test for independent samples } + StudPaired, { Student t-test for paired samples } + AnOVa1, { One-way analysis of variance } + AnOVa2, { Two-way analysis of variance } + Snedecor, { Comparison of two variances } + Bartlett, { Comparison of several variances } + Khi2_Conform, { Khi-2 test for conformity } + Khi2_Indep, { Khi-2 test for independence } + Woolf_Conform, { Woolf's test for conformity } + Woolf_Indep, { Woolf's test for independence } + Mann_Whitney, { Mann-Whitney test } + Wilcoxon, { Wilcoxon test } + Kruskal_Wallis, { Kruskal-Wallis test } + DimStatClassVector, { Allocates an array of statistical classes } + DelStatClassVector, { Deallocates an array of statistical classes } + Distrib, { Distributes an array into statistical classes } + LinFit, { Linear regression } + WLinFit, { Weighted linear regression } + PolFit, { Polynomial regression } + WPolFit, { Weighted polynomial regression } + MulFit, { Multiple linear regression by Gauss-Jordan method } + WMulFit, { Weighted multiple linear regression by Gauss-Jordan method } + SVDFit, { Multiple linear regression by SVD method } + WSVDFit, { Weighted multiple linear regression by SVD method } + SetOptAlgo, { Selects optimization algorithm for nonlinear regression } + SetMaxParam, { Sets the maximal number of regression parameters } + SetParamBounds, { Sets the bounds on a regression parameter } + NLFit, { Nonlinear regression } + WNLFit, { Weighted nonlinear regression } + SetMCFile, { Set file for saving MCMC simulations } + SimFit, { Simulation of unweighted nonlinear regression by MCMC } + WSimFit, { Simulation of weighted nonlinear regression by MCMC } + RegTest, { Test of unweighted regression } + WRegTest, { Test of weighted regression } + VecMean, { Computes mean vector } + VecSD, { Computes vector of standard deviations } + MatVarCov, { Computes variance-covariance matrix } + MatCorrel, { Computes correlation matrix } + PCA, { Principal component analysis of correlation matrix } + ScaleVar, { Scales a set of variables } + PrinFac, { Computes principal factors } + LTrim, { Remove leading blanks } + RTrim, { Remove trailing blanks } + Trim, { Remove leading and trailing blanks } + StrChar, { Generate string by repeating a character } + RFill, { Complete string with trailing blanks } + LFill, { Complete string with leading blanks } + CFill, { Center string } + Replace, { Replace a character } + Extract, { Extract field from string } + Parse, { Parse string into several fields } + SetFormat, { Set numeric format } + FloatStr, { Convert real number to string } + IntStr, { Convert integer to string } + CompStr; { Convert complex number to string } + +begin +end. + diff --git a/fpmath/dll/tpmath.pas b/fpmath/dll/tpmath.pas new file mode 100755 index 0000000..320324e --- /dev/null +++ b/fpmath/dll/tpmath.pas @@ -0,0 +1,1164 @@ +{ ****************************************************************** + Unit TPMATH - Interface for TPMATH.DLL + ****************************************************************** } + +unit tpmath; + +interface + +{ ------------------------------------------------------------------ + Types and constants + ------------------------------------------------------------------ } + +{$i types.inc} + +{ ------------------------------------------------------------------ + Error handling + ------------------------------------------------------------------ } + +procedure SetErrCode(ErrCode : Integer); external 'tpmath'; +{ Sets the error code } + +function DefaultVal(ErrCode : Integer; DefVal : Float) : Float; external 'tpmath'; +{ Sets error code and default function value } + +function MathErr : Integer; external 'tpmath'; +{ Returns the error code } + +{ ------------------------------------------------------------------ + Dynamic arrays + ------------------------------------------------------------------ } + +procedure SetAutoInit(AutoInit : Boolean); external 'tpmath'; +{ Sets the auto-initialization of arrays } + +procedure DimVector(var V : PVector; Ub : Integer); external 'tpmath'; +{ Creates floating point vector V[0..Ub] } + +procedure DimIntVector(var V : PIntVector; Ub : Integer); external 'tpmath'; +{ Creates integer vector V[0..Ub] } + +procedure DimCompVector(var V : PCompVector; Ub : Integer); external 'tpmath'; +{ Creates complex vector V[0..Ub] } + +procedure DimBoolVector(var V : PBoolVector; Ub : Integer); external 'tpmath'; +{ Creates boolean vector V[0..Ub] } + +procedure DimStrVector(var V : PStrVector; Ub : Integer); external 'tpmath'; +{ Creates string vector V[0..Ub] } + +procedure DimMatrix(var A : PMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Creates floating point matrix A[0..Ub1, 0..Ub2] } + +procedure DimIntMatrix(var A : PIntMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Creates integer matrix A[0..Ub1, 0..Ub2] } + +procedure DimCompMatrix(var A : PCompMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Creates complex matrix A[0..Ub1, 0..Ub2] } + +procedure DimBoolMatrix(var A : PBoolMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Creates boolean matrix A[0..Ub1, 0..Ub2] } + +procedure DimStrMatrix(var A : PStrMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Creates string matrix A[0..Ub1, 0..Ub2] } + +procedure DelVector(var V : PVector; Ub : Integer); external 'tpmath'; +{ Deletes floating point vector V[0..Ub] } + +procedure DelIntVector(var V : PIntVector; Ub : Integer); external 'tpmath'; +{ Deletes integer vector V[0..Ub] } + +procedure DelCompVector(var V : PCompVector; Ub : Integer); external 'tpmath'; +{ Deletes complex vector V[0..Ub] } + +procedure DelBoolVector(var V : PBoolVector; Ub : Integer); external 'tpmath'; +{ Deletes boolean vector V[0..Ub] } + +procedure DelStrVector(var V : PStrVector; Ub : Integer); external 'tpmath'; +{ Deletes string vector V[0..Ub] } + +procedure DelMatrix(var A : PMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Deletes floating point matrix A[0..Ub1, 0..Ub2] } + +procedure DelIntMatrix(var A : PIntMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Deletes integer matrix A[0..Ub1, 0..Ub2] } + +procedure DelCompMatrix(var A : PCompMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Deletes complex matrix A[0..Ub1, 0..Ub2] } + +procedure DelBoolMatrix(var A : PBoolMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Deletes boolean matrix A[0..Ub1, 0..Ub2] } + +procedure DelStrMatrix(var A : PStrMatrix; Ub1, Ub2 : Integer); external 'tpmath'; +{ Deletes string matrix A[0..Ub1, 0..Ub2] } + +{ ------------------------------------------------------------------ + Minimum, maximum, sign and exchange + ------------------------------------------------------------------ } + +function FMin(X, Y : Float) : Float; external 'tpmath'; +{ Minimum of 2 reals } + +function FMax(X, Y : Float) : Float; external 'tpmath'; +{ Maximum of 2 reals } + +function IMin(X, Y : Integer) : Integer; external 'tpmath'; +{ Minimum of 2 integers } + +function IMax(X, Y : Integer) : Integer; external 'tpmath'; +{ Maximum of 2 integers } + +function Sgn(X : Float) : Integer; external 'tpmath'; +{ Sign (returns 1 if X = 0) } + +function Sgn0(X : Float) : Integer; external 'tpmath'; +{ Sign (returns 0 if X = 0) } + +function DSgn(A, B : Float) : Float; external 'tpmath'; +{ Sgn(B) * |A| } + +procedure FSwap(var X, Y : Float); external 'tpmath'; +{ Exchange 2 reals } + +procedure ISwap(var X, Y : Integer); external 'tpmath'; +{ Exchange 2 integers } + +{ ------------------------------------------------------------------ + Rounding functions + ------------------------------------------------------------------ } + +function RoundN(X : Float; N : Integer) : Float; external 'tpmath'; +{ Rounds X to N decimal places } + +function Ceil(X : Float) : Integer; external 'tpmath'; +{ Ceiling function } + +function Floor(X : Float) : Integer; external 'tpmath'; +{ Floor function } + +{ ------------------------------------------------------------------ + Logarithms, exponentials and power + ------------------------------------------------------------------ } + +function Expo(X : Float) : Float; external 'tpmath'; +{ Exponential } + +function Exp2(X : Float) : Float; external 'tpmath'; +{ 2^X } + +function Exp10(X : Float) : Float; external 'tpmath'; +{ 10^X } + +function Log(X : Float) : Float; external 'tpmath'; +{ Natural log } + +function Log2(X : Float) : Float; external 'tpmath'; +{ Log, base 2 } + +function Log10(X : Float) : Float; external 'tpmath'; +{ Decimal log } + +function LogA(X, A : Float) : Float; external 'tpmath'; +{ Log, base A } + +function IntPower(X : Float; N : Integer) : Float; external 'tpmath'; +{ X^N } + +function Power(X, Y : Float) : Float; external 'tpmath'; +{ X^Y, X >= 0 } + +{ ------------------------------------------------------------------ + Trigonometric functions + ------------------------------------------------------------------ } + +function Pythag(X, Y : Float) : Float; external 'tpmath'; +{ Sqrt(X^2 + Y^2) } + +function FixAngle(Theta : Float) : Float; external 'tpmath'; +{ Set Theta in -Pi..Pi } + +function Tan(X : Float) : Float; external 'tpmath'; +{ Tangent } + +function ArcSin(X : Float) : Float; external 'tpmath'; +{ Arc sinus } + +function ArcCos(X : Float) : Float; external 'tpmath'; +{ Arc cosinus } + +function ArcTan2(Y, X : Float) : Float; external 'tpmath'; +{ Angle (Ox, OM) with M(X,Y) } + +{ ------------------------------------------------------------------ + Hyperbolic functions + ------------------------------------------------------------------ } + +function Sinh(X : Float) : Float; external 'tpmath'; +{ Hyperbolic sine } + +function Cosh(X : Float) : Float; external 'tpmath'; +{ Hyperbolic cosine } + +function Tanh(X : Float) : Float; external 'tpmath'; +{ Hyperbolic tangent } + +function ArcSinh(X : Float) : Float; external 'tpmath'; +{ Inverse hyperbolic sine } + +function ArcCosh(X : Float) : Float; external 'tpmath'; +{ Inverse hyperbolic cosine } + +function ArcTanh(X : Float) : Float; external 'tpmath'; +{ Inverse hyperbolic tangent } + +procedure SinhCosh(X : Float; var SinhX, CoshX : Float); external 'tpmath'; +{ Sinh & Cosh } + +{ ------------------------------------------------------------------ + Gamma function and related functions + ------------------------------------------------------------------ } + +function Fact(N : Integer) : Float; external 'tpmath'; +{ Factorial } + +function SgnGamma(X : Float) : Integer; external 'tpmath'; +{ Sign of Gamma function } + +function Gamma(X : Float) : Float; external 'tpmath'; +{ Gamma function } + +function LnGamma(X : Float) : Float; external 'tpmath'; +{ Logarithm of Gamma function } + +function Stirling(X : Float) : Float; external 'tpmath'; +{ Stirling's formula for the Gamma function } + +function StirLog(X : Float) : Float; external 'tpmath'; +{ Approximate Ln(Gamma) by Stirling's formula, for X >= 13 } + +function DiGamma(X : Float ) : Float; external 'tpmath'; +{ Digamma function } + +function TriGamma(X : Float ) : Float; external 'tpmath'; +{ Trigamma function } + +function IGamma(A, X : Float) : Float; external 'tpmath'; +{ Incomplete Gamma function} + +function JGamma(A, X : Float) : Float; external 'tpmath'; +{ Complement of incomplete Gamma function } + +function InvGamma(A, P : Float) : Float; external 'tpmath'; +{ Inverse of incomplete Gamma function } + +function Erf(X : Float) : Float; external 'tpmath'; +{ Error function } + +function Erfc(X : Float) : Float; external 'tpmath'; +{ Complement of error function } + +{ ------------------------------------------------------------------ + Beta function and related functions + ------------------------------------------------------------------ } + +function Beta(X, Y : Float) : Float; external 'tpmath'; +{ Beta function } + +function IBeta(A, B, X : Float) : Float; external 'tpmath'; +{ Incomplete Beta function } + +function InvBeta(A, B, Y : Float) : Float; external 'tpmath'; +{ Inverse of incomplete Beta function } + +{ ------------------------------------------------------------------ + Lambert's function + ------------------------------------------------------------------ } + +function LambertW(X : Float; UBranch, Offset : Boolean) : Float; external 'tpmath'; + +{ ------------------------------------------------------------------ + Binomial distribution + ------------------------------------------------------------------ } + +function Binomial(N, K : Integer) : Float; external 'tpmath'; +{ Binomial coefficient C(N,K) } + +function PBinom(N : Integer; P : Float; K : Integer) : Float; external 'tpmath'; +{ Probability of binomial distribution } + +function FBinom(N : Integer; P : Float; K : Integer) : Float; external 'tpmath'; +{ Cumulative probability for binomial distrib. } + +{ ------------------------------------------------------------------ + Poisson distribution + ------------------------------------------------------------------ } + +function PPoisson(Mu : Float; K : Integer) : Float; external 'tpmath'; +{ Probability of Poisson distribution } + +function FPoisson(Mu : Float; K : Integer) : Float; external 'tpmath'; +{ Cumulative probability for Poisson distrib. } + +{ ------------------------------------------------------------------ + Exponential distribution + ------------------------------------------------------------------ } + +function DExpo(A, X : Float) : Float; external 'tpmath'; +{ Density of exponential distribution with parameter A } + +function FExpo(A, X : Float) : Float; external 'tpmath'; +{ Cumulative probability function for exponential dist. with parameter A } + +{ ------------------------------------------------------------------ + Standard normal distribution + ------------------------------------------------------------------ } + +function DNorm(X : Float) : Float; external 'tpmath'; +{ Density of standard normal distribution } + +function FNorm(X : Float) : Float; external 'tpmath'; +{ Cumulative probability for standard normal distrib. } + +function PNorm(X : Float) : Float; external 'tpmath'; +{ Prob(|U| > X) for standard normal distrib. } + +function InvNorm(P : Float) : Float; external 'tpmath'; +{ Inverse of standard normal distribution } + +{ ------------------------------------------------------------------ + Student's distribution + ------------------------------------------------------------------ } + +function DStudent(Nu : Integer; X : Float) : Float; external 'tpmath'; +{ Density of Student distribution with Nu d.o.f. } + +function FStudent(Nu : Integer; X : Float) : Float; external 'tpmath'; +{ Cumulative probability for Student distrib. with Nu d.o.f. } + +function PStudent(Nu : Integer; X : Float) : Float; external 'tpmath'; +{ Prob(|t| > X) for Student distrib. with Nu d.o.f. } + +function InvStudent(Nu : Integer; P : Float) : Float; external 'tpmath'; +{ Inverse of Student's t-distribution function } + +{ ------------------------------------------------------------------ + Khi-2 distribution + ------------------------------------------------------------------ } + +function DKhi2(Nu : Integer; X : Float) : Float; external 'tpmath'; +{ Density of Khi-2 distribution with Nu d.o.f. } + +function FKhi2(Nu : Integer; X : Float) : Float; external 'tpmath'; +{ Cumulative prob. for Khi-2 distrib. with Nu d.o.f. } + +function PKhi2(Nu : Integer; X : Float) : Float; external 'tpmath'; +{ Prob(Khi2 > X) for Khi-2 distrib. with Nu d.o.f. } + +function InvKhi2(Nu : Integer; P : Float) : Float; external 'tpmath'; +{ Inverse of Khi-2 distribution function } + +{ ------------------------------------------------------------------ + Fisher-Snedecor distribution + ------------------------------------------------------------------ } + +function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; external 'tpmath'; +{ Density of Fisher-Snedecor distribution with Nu1 and Nu2 d.o.f. } + +function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; external 'tpmath'; +{ Cumulative prob. for Fisher-Snedecor distrib. with Nu1 and Nu2 d.o.f. } + +function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; external 'tpmath'; +{ Prob(F > X) for Fisher-Snedecor distrib. with Nu1 and Nu2 d.o.f. } + +function InvSnedecor(Nu1, Nu2 : Integer; P : Float) : Float; external 'tpmath'; +{ Inverse of Snedecor's F-distribution function } + +{ ------------------------------------------------------------------ + Beta distribution + ------------------------------------------------------------------ } + +function DBeta(A, B, X : Float) : Float; external 'tpmath'; +{ Density of Beta distribution with parameters A and B } + +function FBeta(A, B, X : Float) : Float; external 'tpmath'; +{ Cumulative probability for Beta distrib. with param. A and B } + +{ ------------------------------------------------------------------ + Gamma distribution + ------------------------------------------------------------------ } + +function DGamma(A, B, X : Float) : Float; external 'tpmath'; +{ Density of Gamma distribution with parameters A and B } + +function FGamma(A, B, X : Float) : Float; external 'tpmath'; +{ Cumulative probability for Gamma distrib. with param. A and B } + +{ ------------------------------------------------------------------ + Matrices and linear equations + ------------------------------------------------------------------ } + +procedure GaussJordan(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + var Det : Float); external 'tpmath'; +{ Transforms a matrix according to the Gauss-Jordan method } + +procedure LinEq(A : PMatrix; + B : PVector; + Lb, Ub : Integer; + var Det : Float); external 'tpmath'; +{ Solves a linear system according to the Gauss-Jordan method } + +procedure Cholesky(A, L : PMatrix; Lb, Ub : Integer); external 'tpmath'; +{ Cholesky factorization of a positive definite symmetric matrix } + +procedure LU_Decomp(A : PMatrix; Lb, Ub : Integer); external 'tpmath'; +{ LU decomposition } + +procedure LU_Solve(A : PMatrix; + B : PVector; + Lb, Ub : Integer; + X : PVector); external 'tpmath'; +{ Solution of linear system from LU decomposition } + +procedure QR_Decomp(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + R : PMatrix); external 'tpmath'; +{ QR decomposition } + +procedure QR_Solve(Q, R : PMatrix; + B : PVector; + Lb, Ub1, Ub2 : Integer; + X : PVector); external 'tpmath'; +{ Solution of linear system from QR decomposition } + +procedure SV_Decomp(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + S : PVector; + V : PMatrix); external 'tpmath'; +{ Singular value decomposition } + +procedure SV_SetZero(S : PVector; + Lb, Ub : Integer; + Tol : Float); external 'tpmath'; +{ Set lowest singular values to zero } + +procedure SV_Solve(U : PMatrix; + S : PVector; + V : PMatrix; + B : PVector; + Lb, Ub1, Ub2 : Integer; + X : PVector); external 'tpmath'; +{ Solution of linear system from SVD } + +procedure SV_Approx(U : PMatrix; + S : PVector; + V : PMatrix; + Lb, Ub1, Ub2 : Integer; + A : PMatrix); external 'tpmath'; +{ Matrix approximation from SVD } + +procedure EigenVals(A : PMatrix; + Lb, Ub : Integer; + Lambda : PCompVector); external 'tpmath'; +{ Eigenvalues of a general square matrix } + +procedure EigenVect(A : PMatrix; + Lb, Ub : Integer; + Lambda : PCompVector; + V : PMatrix); external 'tpmath'; +{ Eigenvalues and eigenvectors of a general square matrix } + +procedure Jacobi(A : PMatrix; + Lb, Ub, MaxIter : Integer; + Tol : Float; + Lambda : PVector; + V : PMatrix); external 'tpmath'; +{ Eigenvalues and eigenvectors of a symmetric matrix } + +{ ------------------------------------------------------------------ + Optimization + ------------------------------------------------------------------ } + +procedure MinBrack(Func : TFunc; + var A, B, C, Fa, Fb, Fc : Float); external 'tpmath'; +{ Brackets a minimum of a function } + +procedure GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float); external 'tpmath'; +{ Minimization of a function of one variable (golden search) } + +procedure LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lb, Ub : Integer; + var R : Float; + MaxIter : Integer; + Tol : Float; + var F_min : Float); external 'tpmath'; +{ Minimization of a function of several variables along a line } + +procedure Newton(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix; + var Det : Float); external 'tpmath'; +{ Minimization of a function of several variables (Newton's method) } + +procedure SaveNewton(FileName : string); external 'tpmath'; +{ Save Newton iterations in a file } + +procedure Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix; + var Det : Float); external 'tpmath'; +{ Minimization of a function of several variables (Marquardt's method) } + +procedure SaveMarquardt(FileName : string); external 'tpmath'; +{ Save Marquardt iterations in a file } + +procedure BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix); external 'tpmath'; +{ Minimization of a function of several variables (BFGS method) } + +procedure SaveBFGS(FileName : string); external 'tpmath'; +{ Save BFGS iterations in a file } + +procedure Simplex(Func : TFuncNVar; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float); external 'tpmath'; +{ Minimization of a function of several variables (Simplex) } + +procedure SaveSimplex(FileName : string); external 'tpmath'; +{ Save Simplex iterations in a file } + +{ ------------------------------------------------------------------ + Nonlinear equations + ------------------------------------------------------------------ } + +procedure RootBrack(Func : TFunc; + var X, Y, FX, FY : Float); external 'tpmath'; +{ Brackets a root of function Func between X and Y } + +procedure Bisect(Func : TFunc; + var X, Y : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); external 'tpmath'; +{ Bisection method } + +procedure Secant(Func : TFunc; + var X, Y : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); external 'tpmath'; +{ Secant method } + +procedure NewtEq(Func, Deriv : TFunc; + var X : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); external 'tpmath'; +{ Newton-Raphson method for a single nonlinear equation } + +procedure NewtEqs(Equations : TEquations; + Jacobian : TJacobian; + X, F : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float); external 'tpmath'; +{ Newton-Raphson method for a system of nonlinear equations } + +procedure Broyden(Equations : TEquations; + X, F : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float); external 'tpmath'; +{ Broyden's method for a system of nonlinear equations } + +{ ------------------------------------------------------------------ + Polynomials and rational fractions + ------------------------------------------------------------------ } + +function Poly(X : Float; + Coef : PVector; + Deg : Integer) : Float; external 'tpmath'; +{ Evaluates a polynomial } + +function RFrac(X : Float; + Coef : PVector; + Deg1, Deg2 : Integer) : Float; external 'tpmath'; +{ Evaluates a rational fraction } + +function RootPol1(A, B : Float; + var X : Float) : Integer; external 'tpmath'; +{ Solves the linear equation A + B * X = 0 } + +function RootPol2(Coef : PVector; + Z : PCompVector) : Integer; external 'tpmath'; +{ Solves a quadratic equation } + +function RootPol3(Coef : PVector; + Z : PCompVector) : Integer; external 'tpmath'; +{ Solves a cubic equation } + +function RootPol4(Coef : PVector; + Z : PCompVector) : Integer; external 'tpmath'; +{ Solves a quartic equation } + +function RootPol(Coef : PVector; + Deg : Integer; + Z : PCompVector) : Integer; external 'tpmath'; +{ Solves a polynomial equation } + +function SetRealRoots(Deg : Integer; + Z : PCompVector; + Tol : Float) : Integer; external 'tpmath'; +{ Set the imaginary part of a root to zero } + +procedure SortRoots(Deg : Integer; + Z : PCompVector); external 'tpmath'; +{ Sorts the roots of a polynomial } + +{ ------------------------------------------------------------------ + Numerical integration and differential equations + ------------------------------------------------------------------ } + +function TrapInt(X, Y : PVector; N : Integer) : Float; external 'tpmath'; +{ Integration by trapezoidal rule } + +function GausLeg(Func : TFunc; A, B : Float) : Float; external 'tpmath'; +{ Integral from A to B } + +function GausLeg0(Func : TFunc; B : Float) : Float; external 'tpmath'; +{ Integral from 0 to B } + +function Convol(Func1, Func2 : TFunc; T : Float) : Float; external 'tpmath'; +{ Convolution product at time T } + +procedure RKF45(F : TDiffEqs; + Neqn : Integer; + Y, Yp : PVector; + var T : Float; + Tout, RelErr, AbsErr : Float; + var Flag : Integer); external 'tpmath'; +{ Integration of a system of differential equations } + +{ ------------------------------------------------------------------ + Fast Fourier Transform + ------------------------------------------------------------------ } + +procedure FFT(NumSamples : LongInt; + InArray, OutArray : PCompVector); external 'tpmath'; +{ Fast Fourier Transform } + +procedure IFFT(NumSamples : LongInt; + InArray, OutArray : PCompVector); external 'tpmath'; +{ Inverse Fast Fourier Transform } + +procedure FFT_Integer(NumSamples : LongInt; + RealIn, ImagIn : PIntVector; + OutArray : PCompVector); external 'tpmath'; +{ Fast Fourier Transform for integer data } + +procedure FFT_Integer_Cleanup; external 'tpmath'; +{ Clear memory after a call to FFT_Integer } + +procedure CalcFrequency(NumSamples, + FrequencyIndex : LongInt; + InArray : PCompVector; + var FFT : Complex); external 'tpmath'; +{ Direct computation of Fourier transform } + +{ ------------------------------------------------------------------ + Random numbers + ------------------------------------------------------------------ } + +procedure SetRNG(RNG : RNG_Type); external 'tpmath'; +{ Select generator } + +procedure InitGen(Seed : LongInt); external 'tpmath'; +{ Initialize generator } + +function IRanGen : LongInt; external 'tpmath'; +{ 32-bit random integer in [-2^31 .. 2^31 - 1] } + +function IRanGen31 : LongInt; external 'tpmath'; +{ 31-bit random integer in [0 .. 2^31 - 1] } + +function RanGen1 : Float; external 'tpmath'; +{ 32-bit random real in [0,1] } + +function RanGen2 : Float; external 'tpmath'; +{ 32-bit random real in [0,1) } + +function RanGen3 : Float; external 'tpmath'; +{ 32-bit random real in (0,1) } + +function RanGen53 : Float; external 'tpmath'; +{ 53-bit random real in [0,1) } + +procedure InitMWC(Seed : LongInt); external 'tpmath'; +{ Initializes the 'Multiply with carry' random number generator } + +function IRanMWC : LongInt; external 'tpmath'; +{ Returns a 32 bit random number in [-2^31 ; 2^31-1] } + +procedure InitMT(Seed : LongInt); external 'tpmath'; +{ Initializes Mersenne Twister generator with a seed } + +procedure InitMTbyArray(InitKey : array of LongInt; KeyLength : Word); external 'tpmath'; +{ Initialize MT generator with an array InitKey[0..(KeyLength - 1)] } + +function IRanMT : LongInt; external 'tpmath'; +{ Random integer from MT generator } + +procedure InitUVAGbyString(KeyPhrase : string); external 'tpmath'; +{ Initializes the UVAG generator with a string } + +procedure InitUVAG(Seed : LongInt); external 'tpmath'; +{ Initializes the UVAG generator with an integer } + +function IRanUVAG : LongInt; external 'tpmath'; +{ Random integer from UVAG generator } + +function RanGaussStd : Float; external 'tpmath'; +{ Random number from standard normal distribution } + +function RanGauss(Mu, Sigma : Float) : Float; external 'tpmath'; +{ Random number from normal distrib. with mean Mu and S. D. Sigma } + +procedure RanMult(M : PVector; + L : PMatrix; + Lb, Ub : Integer; + X : PVector); external 'tpmath'; +{ Random vector from multinormal distribution (correlated) } + +procedure RanMultIndep(M, S : PVector; + Lb, Ub : Integer; + X : PVector); external 'tpmath'; +{ Random vector from multinormal distribution (uncorrelated) } + +procedure InitMHParams(NCycles, MaxSim, SavedSim : Integer); external 'tpmath'; +{ Initializes Metropolis-Hastings parameters } + +procedure GetMHParams(var NCycles, MaxSim, SavedSim : Integer); external 'tpmath'; +{ Returns Metropolis-Hastings parameters } + +procedure Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lb, Ub : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float); external 'tpmath'; +{ Simulation of a probability density function by Metropolis-Hastings } + +procedure InitSAParams(NT, NS, NCycles : Integer; RT : Float); external 'tpmath'; +{ Initializes Simulated Annealing parameters } + +procedure SA_CreateLogFile(FileName : String); external 'tpmath'; +{ Initializes log file } + +procedure SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lb, Ub : Integer; + var F_min : Float); external 'tpmath'; +{ Minimization of a function of several var. by simulated annealing } + +procedure InitGAParams(NP, NG : Integer; SR, MR, HR : Float); external 'tpmath'; +{ Initializes Genetic Algorithm parameters } + +procedure GA_CreateLogFile(FileName : String); external 'tpmath'; +{ Initializes log file } + +procedure GenAlg(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lb, Ub : Integer; + var F_min : Float); external 'tpmath'; +{ Minimization of a function of several var. by genetic algorithm } + +{ ------------------------------------------------------------------ + Statistics + ------------------------------------------------------------------ } + +function Mean(X : PVector; Lb, Ub : Integer) : Float; external 'tpmath'; +{ Mean of sample X } + +function Median(X : PVector; Lb, Ub : Integer; Sorted : Boolean) : Float; external 'tpmath'; +{ Median of sample X } + +function StDev(X : PVector; Lb, Ub : Integer; M : Float) : Float; external 'tpmath'; +{ Standard deviation estimated from sample X } + +function StDevP(X : PVector; Lb, Ub : Integer; M : Float) : Float; external 'tpmath'; +{ Standard deviation of population } + +function Correl(X, Y : PVector; Lb, Ub : Integer) : Float; external 'tpmath'; +{ Correlation coefficient } + +function Skewness(X : PVector; Lb, Ub : Integer; M, Sigma : Float) : Float; external 'tpmath'; +{ Skewness of sample X } + +function Kurtosis(X : PVector; Lb, Ub : Integer; M, Sigma : Float) : Float; external 'tpmath'; +{ Kurtosis of sample X } + +procedure QSort(X : PVector; Lb, Ub : Integer); external 'tpmath'; +{ Quick sort (ascending order) } + +procedure DQSort(X : PVector; Lb, Ub : Integer); external 'tpmath'; +{ Quick sort (descending order) } + +procedure Interval(X1, X2 : Float; + MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); external 'tpmath'; +{ Determines an interval for a set of values } + +procedure StudIndep(N1, N2 : Integer; + M1, M2, S1, S2 : Float; + var T : Float; + var DoF : Integer); external 'tpmath'; +{ Student t-test for independent samples } + +procedure StudPaired(X, Y : PVector; + Lb, Ub : Integer; + var T : Float; + var DoF : Integer); external 'tpmath'; +{ Student t-test for paired samples } + +procedure AnOVa1(Ns : Integer; + N : PIntVector; + M, S : PVector; + var V_f, V_r, F : Float; + var DoF_f, DoF_r : Integer); external 'tpmath'; +{ One-way analysis of variance } + +procedure AnOVa2(NA, NB, Nobs : Integer; + M, S : PMatrix; + V, F : PVector; + DoF : PIntVector); external 'tpmath'; +{ Two-way analysis of variance } + +procedure Snedecor(N1, N2 : Integer; + S1, S2 : Float; + var F : Float; + var DoF1, DoF2 : Integer); external 'tpmath'; +{ Snedecor's F-test (comparison of two variances) } + +procedure Bartlett(Ns : Integer; + N : PIntVector; + S : PVector; + var Khi2 : Float; + var DoF : Integer); external 'tpmath'; +{ Bartlett's test (comparison of several variances) } + +procedure Mann_Whitney(N1, N2 : Integer; + X1, X2 : PVector; + var U, Eps : Float); external 'tpmath'; +{ Mann-Whitney test} + +procedure Wilcoxon(X, Y : PVector; + Lb, Ub : Integer; + var Ndiff : Integer; + var T, Eps : Float); external 'tpmath'; +{ Wilcoxon test } + +procedure Kruskal_Wallis(Ns : Integer; + N : PIntVector; + X : PMatrix; + var H : Float; + var DoF : Integer); external 'tpmath'; +{ Kruskal-Wallis test } + +procedure Khi2_Conform(N_cls : Integer; + N_estim : Integer; + Obs : PIntVector; + Calc : PVector; + var Khi2 : Float; + var DoF : Integer); external 'tpmath'; +{ Khi-2 test for conformity } + +procedure Khi2_Indep(N_lin : Integer; + N_col : Integer; + Obs : PIntMatrix; + var Khi2 : Float; + var DoF : Integer); external 'tpmath'; +{ Khi-2 test for independence } + +procedure Woolf_Conform(N_cls : Integer; + N_estim : Integer; + Obs : PIntVector; + Calc : PVector; + var G : Float; + var DoF : Integer); external 'tpmath'; +{ Woolf's test for conformity } + +procedure Woolf_Indep(N_lin : Integer; + N_col : Integer; + Obs : PIntMatrix; + var G : Float; + var DoF : Integer); external 'tpmath'; +{ Woolf's test for independence } + +procedure DimStatClassVector(var C : PStatClassVector; + Ub : Integer); external 'tpmath'; +{ Allocates an array of statistical classes: C[0..Ub] } + +procedure DelStatClassVector(var C : PStatClassVector; + Ub : Integer); external 'tpmath'; +{ Deallocates an array of statistical classes: C[0..Ub] } + +procedure Distrib(X : PVector; + Lb, Ub : Integer; + A, B, H : Float; + C : PStatClassVector); external 'tpmath'; +{ Distributes an array X[Lb..Ub] into statistical classes } + +{ ------------------------------------------------------------------ + Curve fit + ------------------------------------------------------------------ } + +procedure LinFit(X, Y : PVector; + Lb, Ub : Integer; + B : PVector; + V : PMatrix); external 'tpmath'; +{ Linear regression : Y = B(0) + B(1) * X } + +procedure WLinFit(X, Y, S : PVector; + Lb, Ub : Integer; + B : PVector; + V : PMatrix); external 'tpmath'; +{ Weighted linear regression : Y = B(0) + B(1) * X } + +procedure PolFit(X, Y : PVector; + Lb, Ub, Deg : Integer; + B : PVector; + V : PMatrix); external 'tpmath'; +{ Linear regression : Y = B(0) + B(1) * X + B(2) * X² + ...} + +procedure WPolFit(X, Y, S : PVector; + Lb, Ub, Deg : Integer; + B : PVector; + V : PMatrix); external 'tpmath'; +{ Weighted linear regression : Y = B(0) + B(1) * X + B(2) * X² + ...} + +procedure MulFit(X : PMatrix; + Y : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + B : PVector; + V : PMatrix); external 'tpmath'; +{ Multiple linear regression by Gauss-Jordan method } + +procedure WMulFit(X : PMatrix; + Y, S : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + B : PVector; + V : PMatrix); external 'tpmath'; +{ Weighted multiple linear regression by Gauss-Jordan method } + +procedure SVDFit(X : PMatrix; + Y : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + SVDTol : Float; + B : PVector; + V : PMatrix); external 'tpmath'; +{ Multiple linear regression by SVD method } + +procedure WSVDFit(X : PMatrix; + Y, S : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + SVDTol : Float; + B : PVector; + V : PMatrix); external 'tpmath'; +{ Weighted multiple linear regression by SVD method } + +procedure SetOptAlgo(Algo : TOptAlgo); external 'tpmath'; +{ Sets the optimization algorithm for nonlinear regression } + +procedure SetMaxParam(N : Byte); external 'tpmath'; +{ Sets the maximum number of regression parameters for nonlinear regression } + +procedure SetParamBounds(I : Byte; ParamMin, ParamMax : Float); external 'tpmath'; +{ Sets the bounds on the I-th regression parameter } + +procedure NLFit(RegFunc : TRegFunc; + DerivProc : TDerivProc; + X, Y : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); external 'tpmath'; +{ Unweighted nonlinear regression } + +procedure WNLFit(RegFunc : TRegFunc; + DerivProc : TDerivProc; + X, Y, S : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); external 'tpmath'; +{ Weighted nonlinear regression } + +procedure SetMCFile(FileName : String); external 'tpmath'; +{ Set file for saving MCMC simulations } + +procedure SimFit(RegFunc : TRegFunc; + X, Y : PVector; + Lb, Ub : Integer; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); external 'tpmath'; +{ Simulation of unweighted nonlinear regression by MCMC } + +procedure WSimFit(RegFunc : TRegFunc; + X, Y, S : PVector; + Lb, Ub : Integer; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); external 'tpmath'; +{ Simulation of weighted nonlinear regression by MCMC } + +procedure RegTest(Y, Ycalc : PVector; + LbY, UbY : Integer; + V : PMatrix; + LbV, UbV : Integer; + var Test : TRegTest); external 'tpmath'; +{ Test of unweighted regression } + +procedure WRegTest(Y, Ycalc, S : PVector; + LbY, UbY : Integer; + V : PMatrix; + LbV, UbV : Integer; + var Test : TRegTest); external 'tpmath'; +{ Test of weighted regression } + +{ ------------------------------------------------------------------ + Principal component analysis + ------------------------------------------------------------------ } + +procedure VecMean(X : PMatrix; + Lb, Ub, Nvar : Integer; + M : PVector); external 'tpmath'; +{ Computes the mean vector M from matrix X } + +procedure VecSD(X : PMatrix; + Lb, Ub, Nvar : Integer; + M, S : PVector); external 'tpmath'; +{ Computes the vector of standard deviations S from matrix X } + +procedure MatVarCov(X : PMatrix; + Lb, Ub, Nvar : Integer; + M : PVector; + V : PMatrix); external 'tpmath'; +{ Computes the variance-covariance matrix V from matrix X } + +procedure MatCorrel(V : PMatrix; + Nvar : Integer; + R : PMatrix); external 'tpmath'; +{ Computes the correlation matrix R from the var-cov matrix V } + +procedure PCA(R : PMatrix; + Nvar : Integer; + MaxIter : Integer; + Tol : Float; + Lambda : PVector; + C, Rc : PMatrix); external 'tpmath'; +{ Performs a principal component analysis of the correlation matrix R } + +procedure ScaleVar(X : PMatrix; + Lb, Ub, Nvar : Integer; + M, S : PVector; + Z : PMatrix); external 'tpmath'; +{ Scales a set of variables by subtracting means and dividing by SD's } + +procedure PrinFac(Z : PMatrix; + Lb, Ub, Nvar : Integer; + C, F : PMatrix); external 'tpmath'; +{ Computes principal factors } + +{ ------------------------------------------------------------------ + Strings + ------------------------------------------------------------------ } + +function LTrim(S : String) : String; external 'tpmath'; +{ Removes leading blanks } + +function RTrim(S : String) : String; external 'tpmath'; +{ Removes trailing blanks } + +function Trim(S : String) : String; external 'tpmath'; +{ Removes leading and trailing blanks } + +function StrChar(N : Byte; C : Char) : String; external 'tpmath'; +{ Returns a string made of character C repeated N times } + +function RFill(S : String; L : Byte) : String; external 'tpmath'; +{ Completes string S with trailing blanks for a total length L } + +function LFill(S : String; L : Byte) : String; external 'tpmath'; +{ Completes string S with leading blanks for a total length L } + +function CFill(S : String; L : Byte) : String; external 'tpmath'; +{ Centers string S on a total length L } + +function Replace(S : String; C1, C2 : Char) : String; external 'tpmath'; +{ Replaces in string S all the occurences of C1 by C2 } + +function Extract(S : String; var Index : Byte; Delim : Char) : String; external 'tpmath'; +{ Extracts a field from a string } + +procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); external 'tpmath'; +{ Parses a string into its constitutive fields } + +procedure SetFormat(NumLength, MaxDec : Integer; + FloatPoint, NSZero : Boolean); external 'tpmath'; +{ Sets the numeric format } + +function FloatStr(X : Float) : String; external 'tpmath'; +{ Converts a real to a string according to the numeric format } + +function IntStr(N : LongInt) : String; external 'tpmath'; +{ Converts an integer to a string } + +function CompStr(Z : Complex) : String; external 'tpmath'; +{ Converts a complex number to a string } + +implementation + +end. + diff --git a/fpmath/filelist.txt b/fpmath/filelist.txt new file mode 100755 index 0000000..b2c78dc --- /dev/null +++ b/fpmath/filelist.txt @@ -0,0 +1,291 @@ +Unit Routines Description +----------------------------------------------------------------------- +utypes SetErrCode Sets error code +* DefaultVal Sets error code and default function value +* MathErr Returns the error code +* SetAutoInit Sets the auto-initialization of arrays +* DimVector Allocates a real vector +* DimIntVector Allocates an integer vector +* DimCompVector Allocates a complex vector +* DimBoolVector Allocates a boolean vector +* DimStrVector Allocates a string vector +* DimMatrix Allocates a real matrix +* DimIntMatrix Allocates an integer matrix +* DimCompMatrix Allocates a complex matrix +* DimBoolMatrix Allocates a boolean matrix +* DimStrMatrix Allocates a string matrix +* DelVector Deallocates a real vector +* DelIntVector Deallocates an integer vector +* DelCompVector Deallocates a complex vector +* DelBoolVector Deallocates a boolean vector +* DelStrVector Deallocates a string vector +* DelMatrix Deallocates a real matrix +* DelIntMatrix Deallocates an integer matrix +* DelCompMatrix Deallocates a complex matrix +* DelBoolMatrix Deallocates a boolean matrix +* DelStrMatrix Deallocates a string matrix +uminmax FMin Minimum of 2 reals +* FMax Maximum of 2 reals +* IMin Minimum of 2 integers +* IMax Maximum of 2 integers +* Sgn Sign, Sgn(0) = 1 +* Sgn0 Sign, Sgn(0) = 0 +* DSgn DSgn(A, B) = Sgn(B) * |A| +* FSwap Exchanges 2 reals +* ISwap Exchanges 2 integers +uround RoundN Rounds a number to N decimal places +* Ceil Ceiling function +* Floor Floor function +umath Expo Exponential (with bound checking) +* Exp2 Exponential, base 2 +* Exp10 Exponential, base 10 +* Log Natural log (with bound checking) +* Log2 Log, base 2 +* Log10 Log, base 10 +* LogA Log, base A +* IntPower Power (integer exponent) +* Power Power (real exponent) +utrigo Pythag Sqrt(X^2 + Y^2) +* FixAngle Set argument in -Pi..Pi +* Tan Tangent +* ArcSin Arc sinus +* ArcCos Arc cosinus +* ArcTan2 Angle (Ox, OM) with M(X,Y) +uhyper Sinh Hyperbolic sine +* Cosh Hyperbolic cosine +* Tanh Hyperbolic tangent +* ArcSinh Inverse hyperbolic sine +* ArcCosh Inverse hyperbolic cosine +* ArcTanh Inverse hyperbolic tangent +* SinhCosh Sinh and Cosh +upolev PolEvl Polynomial evaluation (coeff. of x^n <> 1) +* P1Evl Polynomial evaluation (coeff. of x^n = 1) +ugamma Gamma Gamma function +* LnGamma Logarithm of Gamma function +* SgnGamma Sign of Gamma function +* Stirling Stirling's formula for Gamma +* StirLog Stirling's formula for LnGamma +udigamma DiGamma DiGamma function +* TriGamma TriGamma function +uigamma IGamma Incomplete Gamma function +* JGamma Complement of incomplete Gamma function +* Erf Error function +* Erfc Complement of error function +ubeta Beta Beta function +uibeta IBeta Incomplete Beta function +ulambert LambertW Lambert's W-function +ufact Fact Factorial +ubinom Binomial Binomial coefficient +* PBinom Probability of binomial distribution +upoidist PPoisson Probability of Poisson distribution +uexpdist DExpo Density of exponential distribution +* FExpo Cumulative prob. of exponential dist. +unormal DNorm Density of standard normal distribution +ugamdist DBeta Density of Beta distribution +* DGamma Density of Gamma distribution +* DKhi2 Density of Khi-2 distribution +* DStudent Density of Student's distribution +* DSnedecor Density of Fisher-Snedecor distribution +uibtdist FBeta Cumulative prob. of Beta distribution +* FBinom Cumulative prob. of Binomial distribution +* FStudent Cumulative prob. of Student's distribution +* PStudent Prob(|t| > X) for Student's distribution +* FSnedecor Cumulative prob. of Fisher-Snedecor distribution +* PSnedecor Prob(F > X) for Fisher-Snedecor distribution +uigmdist FGamma Cumulative prob. of Gamma distribution +* FPoisson Cumulative prob. of Poisson distribution +* FNorm Cumulative prob. of standard normal distribution +* PNorm Prob(|U| > X) for standard normal distribution +* FKhi2 Cumulative prob. of Khi-2 distribution +* PKhi2 Prob(Khi2 > X) for Khi-2 distribution +uinvnorm InvNorm Inverse of normal distribution +uinvgam InvGamma Inverse of incomplete Gamma function +* InvKhi2 Inverse of khi-2 distribution +uinvbeta InvBeta Inverse of incomplete Beta function +* InvStudent Inverse of Student's t-distribution +* InvSnedecor Inverse of Snedecor's F-distribution +ucompvec CompVec Comparison of two vectors +ugausjor GaussJordan Linear equation system (Gauss-Jordan method) +ulineq LinEq Linear equation system (Gauss-Jordan method) +ucholesk Cholesky Cholesky factorization +ulu LU_Decomp LU decomposition +* LU_Solve Solves a system of equations after LU decomposition +uqr QR_Decomp QR decomposition +* QR_Solve Solves a system of equations after QR decomposition +usvd SV_Decomp Singular value decomposition +* SV_Solve Solves a system of equations after SV decomposition +* SV_SetZero Sets the lowest singular values to zero +* SV_Approx Approximates a matrix from its SV decomposition +ubalance Balance Balances a matrix and tries to isolate eigenvalues +ubalbak BalBak Back transformation of eigenvectors +uelmhes ElmHes Reduction of a square matrix to upper Hessenberg form +ueltran Eltran Save transformations used by ElmHes +uhqr Hqr Eigenvalues of a real upper Hessenberg matrix by the QR method +uhqr2 Hqr2 Eigenvalues and eigenvectors of a real upper Hessenberg matrix +ueigval EigenVals Eigenvalues of a general square matrix +ueigvec EigenVect Eigenvalues and eigenvectors of a general square matrix +ujacobi Jacobi Eigenvalues and eigenvectors of a symmetric matrix +uminbrak MinBrack Brackets a minimum of a function +ugoldsrc GoldSearch Minimization of a function of 1 variable (Golden Search method) +ulinmin LinMin Minimization of a function of several variables along a line +unewton Newton Minimization of a function of several var. (Newton's method) +* SaveNewton Save Newton iterations in a file +umarq Marquardt Minimization of a function of several var. (Marquardt's method) +* SaveMarquardt Save Marquardt iterations in a file +ubfgs BFGS Minimization of a function of several var. (BFGS method) +* SaveBFGS Save BFGS iterations in a file +usimplex Simplex Minimization of a function of several var. (simplex method) +* SaveSimplex Save simplex iterations in a file +ulinminq LinMinEq Minimization of a sum of squared functions along a line +ubisect RootBrack Brackets solution of equation +* Bisect Nonlinear equation (bisection method) +unewteq NewtEq Nonlinear equation (Newton-Raphson method) +usecant Secant Nonlinear equation (secant method) +unewteqs NewtEqs Nonlinear equation system (Newton-Raphson method) +ubroyden Broyden Nonlinear equation system (Broyden's method) +upolynom Poly Evaluates a polynomial +* RFrac Evaluates a rational fraction +urtpol1 RootPol1 Root of linear equation +urtpol2 RootPol2 Roots of quadratic equation +urtpol3 RootPol3 Roots of cubic equation +urtpol4 RootPol4 Roots of quartic equation +urootpol RootPol Roots of polynomial from companion matrix +upolutil SetRealRoots Set the imaginary part of a root to zero +* SortRoots Sorts the roots of a polynomial +utrapint TrapInt Integration by trapezoidal rule +ugausleg GausLeg Gauss-Legendre integration +* GausLeg0 Gauss-Legendre integration (lower bound=0) +* Convol Convolution product +urkf RKF45 Integration of a system of differential equations +ufft FFT Fast Fourier Transform +* IFFT Inverse Fast Fourier Transform +* FFT_Integer Fast Fourier Transform for integer data +* FFT_Integer_Cleanup Clear memory after a call to FFT_Integer +* CalcFrequency Direct computation of Fourier Transform +urandom SetRNG Select random number generator +* InitGen Initialize random number generator +* IRanGen 32-bit random integer in [-2^31 .. 2^31 - 1] +* IRanGen31 31-bit random integer in [0 .. 2^31 - 1] +* RanGen1 32-bit random real in [0,1] +* RanGen2 32-bit random real in [0,1) +* RanGen3 32-bit random real in (0,1) +* RanGen53 53-bit random real in [0,1) +uranmwc InitMWC Initialize Multiply-With-Carry generator +* IRanMWC 32-bit random integer from MWC generator +uranmt InitMT Initialize Mersenne Twister generator with a seed +* InitMTbyArray Initialize MT generator with an array +* IRanMT 32-bit random integer from MT generator +uranuvag InitUVAG Initialize UVAG generator with a seed +* InitUVAGbyString Initialize UVAG generator with a string +* IRanUVAG 32-bit random integer from UVAG generator +urangaus RanGaussStd Random number from standard normal distribution +* RanGauss Random number from normal distribution +uranmult RanMult Random vector from multinormal distrib. (correlated) +* RanMultIndep Random vector from multinormal distrib. (uncorrelated) +umcmc InitMHParams Initialize Metropolis-Hastings parameters +* GetMHParams Returns Metropolis-Hastings parameters +* Hastings Simulation of a p.d.f. by Metropolis-Hastings +usimann InitSAParams Initialize Simulated Annealing parameters +* SA_CreateLogFile Initialize log file for Simulated Annealing +* SimAnn Minimization of a function of several var. by Simulated Annealing +ugenalg InitGAParams Initialize Genetic Algorithm parameters +* GA_CreateLogFile Initialize log file for Genetic Algorithm +* GenAlg Minimization of a function of several var. by Genetic Algorithm +umeansd Mean Sample mean +* StDev Standard deviation estimated from sample +* StDevP Standard deviation of population +ucorrel Correl Correlation coefficient +umedian Median Sample median +uskew Skewness Sample skewness +* Kurtosis Sample kurtosis +uqsort QSort Quick sort (ascending order) +* DQSort Quick sort (descending order) +uinterv Interval Determines an interval for a set of values +ustudind StudIndep Student t-test for independent samples +ustdpair StudPaired Student t-test for paired samples +uanova1 AnOVa1 One-way analysis of variance +uanova2 AnOVa2 Two-way analysis of variance +usnedeco Snedecor Comparison of two variances +ubartlet Bartlett Comparison of several variances +ukhi2 Khi2_Conform Khi-2 test for conformity +* Khi2_Indep Khi-2 test for independence +uwoolf Woolf_Conform Woolf's test for conformity +* Woolf_Indep Woolf's test for independence +unonpar Mann_Whitney Mann-Whitney test +* Wilcoxon Wilcoxon test +* Kruskal_Wallis Kruskal-Wallis test +udistrib DimStatClassVector Allocates an array of statistical classes +* DelStatClassVector Deallocates an array of statistical classes +* Distrib Distributes an array into statistical classes +ulinfit LinFit Linear regression +* WLinFit Weighted linear regression +upolfit PolFit Polynomial regression +* WPolFit Weighted polynomial regression +umulfit MulFit Multiple regression (Gauss-Jordan method) +* WMulFit Weighted multiple regression (Gauss-Jordan method) +usvdfit SVDFit Multiple regression (SVD method) +* WSVDFit Weighted multiple regression (SVD method) +unlfit SetOptAlgo Selects optimization algorithm for nonlinear regression +* SetMaxParam Sets the maximal number of regression parameters +* SetParamBounds Sets the bounds on a regression parameter +* SetMCFile Set file for saving MCMC simulations +* NLFit Nonlinear regression +* WNLFit Weighted nonlinear regression +* SimFit Simulation of unweighted nonlinear regression by MCMC +* WSimFit Simulation of weighted nonlinear regression by MCMC +uregtest RegTest Test of unweighted regression +* WRegTest Test of weighted regression +upca VecMean Computes mean vector } +* VecSD Computes vector of standard deviations } +* MatVarCov Computes variance-covariance matrix } +* MatCorrel Computes correlation matrix } +* PCA Principal component analysis of correlation matrix } +* ScaleVar Scales a set of variables } +* PrinFac Computes principal factors } +ustrings LTrim Remove leading blanks +* RTrim Remove trailing blanks +* Trim Remove leading and trailing blanks +* StrChar Generate string by repeating a character +* RFill Complete string with trailing blanks +* LFill Complete string with leading blanks +* CFill Center string +* Replace Replace a character +* Extract Extract field from string +* Parse Parse string into several fields +* SetFormat Set numeric format +* FloatStr Convert real number to string +* IntStr Convert integer to string +* CompStr Convert complex number to string +uplot InitGraphics Initializes the graphic +* SetWindow Sets the graphic window +* AutoScale Automatic scale determination +* SetOxScale Sets the scale on the Ox axis +* SetOyScale Sets the scale on the Oy axis +* SetGraphTitle Sets the graph title +* SetOxTitle Sets the title for the Ox axis +* SetOyTitle Sets the title for the Oy axis +* SetTitleFont Sets the font for the main graph title +* SetOxFont Sets the font for the Ox axis +* SetOyFont Sets the font for the Oy axis +* SetLgdFont Sets the font for the legends +* PlotOxAxis Plots the Ox axis +* PlotOyAxis Plots the Oy axis +* WriteGraphTitle Writes title of graph +* PlotGrid Plots a grid on the graph +* SetClipping Limits the graphic to the current viewport +* SetMaxCurv Sets maximum number of curves +* SetPointParam Sets point parameters +* SetLineParam Sets line parameters +* SetCurvLegend Sets curve legend +* SetCurvStep Sets curve step +* PlotPoint Plots a point +* PlotCurve Plots a curve +* PlotCurveWithErrorBars Plots a curve with error bars +* PlotFunc Plots a function +* WriteLegend Writes the legends for the plotted curves +* ConRec Contour plot +* Xpixel Converts user abscissa X to screen coordinate +* Ypixel Converts user ordinate Y to screen coordinate +* Xuser Converts screen coordinate X to user abscissa +* Yuser Converts screen coordinate Y to user ordinate +* LeaveGraphics Quits the graphic mode diff --git a/fpmath/lgpl.txt b/fpmath/lgpl.txt new file mode 100755 index 0000000..cbee875 --- /dev/null +++ b/fpmath/lgpl.txt @@ -0,0 +1,504 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + <one line to give the library's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + <signature of Ty Coon>, 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/fpmath/regmult.o b/fpmath/regmult.o new file mode 100644 index 0000000..8ffed55 Binary files /dev/null and b/fpmath/regmult.o differ diff --git a/fpmath/regmult.pas b/fpmath/regmult.pas new file mode 100755 index 0000000..bde42cf --- /dev/null +++ b/fpmath/regmult.pas @@ -0,0 +1,162 @@ +{ ********************************************************************** + * Program REGMULT.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This program performs a weighted multiple linear least squares fit : + + y = b0 + b1 * x1 + b2 * x2 + ... + + The following parameters are passed on the command line : + + 1st parameter = name of input file (default extension = .DAT) + 2nd parameter = 1 if the equation includes a constant term b0 + + Input files are ASCII files with the following structure : + + Line 1 : Title of study + Line 2 : Number of variables (must be >= 2 here !) + Next lines : Names of variables x1, x2, ..., y + Next line : Number of observations (must be > number of variables !) + + The next lines contain the coordinates (x1, x2, ..., y) of the + observations (1 observation by line). The coordinates must be + separated by spaces or tabulations. + + The file INHIB.DAT is an example of data relating the inhibition of an + enzyme to the physico-chemical properties of the inhibitors (J. DEBORD, + P. N'DIAYE, J. C. BOLLINGER et al, J. Enzyme Inhib., 1997, 12, 13-26). + The program parameters are : INHIB 1 + + The program may be executed from Turbo Pascal's integrated environment, + in which case the parameters are entered through the "Parameters" option + of the menu, or from DOS (after compilation into an executable file), + in which case the parameters are entered on the command line (e.g. + REGMULT INHIB 1). + ********************************************************************** } + +unit regmult; +interface +uses + SysUtils,utypes,umulfit,classes,define_types,dialogs; + +function MultipleRegressionVec (lnObservations,lnFactors: integer; var X: PMatrix; var Y: PVector; var lOutT,lOutSlope: DoubleP0): boolean; +function MultipleRegression (lnObservations,lnFactors: integer; var X: PMatrix; + var lImgIntensity: DoubleP0; var lOutT: DoubleP0): boolean; +implementation + +uses usvdfit,uregtest; + +(*procedure WriteResults(NVar: integer; var lOutT,lOutSlope: DoubleP0); +var + I: integer; + lStr: string; +begin + for I := 0 to Nvar do begin + lStr := floattostr(lOutT^[I]) +' '+floattostr(lOutSlope[I]); + Form1.memo1.lines.add(lStr); + end; +end; *) + + + +function MultipleRegressionVec (lnObservations,lnFactors: integer; + var X: PMatrix; var Y: PVector; var lOutT,lOutSlope: DoubleP0): boolean; +var + //lmax,lmin: float; + XX : PMatrix; { Independent variables } + //YY : PVector; { Dependent variable } + Ycalc : PVector; { Computed Y values } + B : PVector; { Fitted parameters } + V : PMatrix; { Variance-covariance matrix } + Test : TRegTest; { Statistical tests } + lVar : Float; { Variance for t value } + Lb,I, J : Integer; { Loop variable } + ConsTerm : boolean; { Include a constant term B(0) } +begin + result := false; + ConsTerm := true; + { Dimension arrays } + DimMatrix(XX, lnObservations, lnFactors); + //DimVector(YY, lnObservations); + DimVector(Ycalc, lnObservations); + DimVector(B, lnFactors); + DimMatrix(V, lnFactors, lnFactors); + { Read data } + for I := 1 to lnObservations do begin + for J := 1 to lnFactors do begin + XX^[I]^[J] := X^[J]^[I];//Designed to be compatible with old versions of fpmath + end; + + end; + + (* lmin := X^[1]^[1]; + lmax := X^[1]^[1]; + for I := 1 to lnFactors do begin + for J := 1 to lnObservations do begin + if X^[I]^[J] > lmax then + lMax := X^[I]^[J]; + if X^[I]^[J] < lmin then + lMin := X^[I]^[J]; + end; + end; + fx(lmin,lmax);*) + + { Perform regression } + // MulFit(XX, Y, 1, lnObservations, lnFactors, ConsTerm, B, V); + SVDFit(XX, Y, 1, lnObservations, lnFactors, ConsTerm, 1.0E-8, B, V); + { Compute predicted Y values } + for I := 1 to lnObservations do begin + if ConsTerm then Ycalc^[I] := B^[0] else Ycalc^[I] := 0.0; + for J := 1 to lnFactors do + Ycalc^[I] := Ycalc^[I] + B^[J] * XX^[I]^[J]; + end; + { Update variance-covariance matrix and compute statistical tests } + if ConsTerm then Lb := 0 else Lb := 1; + RegTest(Y, Ycalc, 1, lnObservations, V, Lb, lnFactors, Test); + //output Slopes + for I := 0 to (lnFactors-1) do + lOutSlope^[I] := B^[I+1];//first parameter is global fit + lOutSlope^[lnFactors] := B^[0];//global fit + //T scores + for I := 0 to (lnFactors-1) do begin + + lVar :=Sqrt(V^[I+1]^[I+1]); + //fx(lVar,B^[I+1]); + if lVar <> 0 then + lOutT^[I] := B^[I+1] / lVar + else + lOutT^[I] := 0; + end; + lvar := Sqrt(V^[0]^[0]); + if lvar <> 0 then + lOutT^[lnFactors] := B^[0]/ lvar //global fit + else + lOutT^[lnFactors] := 0; + //cleanup + DelMatrix(XX, lnObservations, lnFactors); + //DelVector(YY, lnObservations); + DelVector(Ycalc, lnObservations); + DelVector(B, lnFactors); + DelMatrix(V, lnFactors,lnFactors); + result := true; +end; + +function MultipleRegression (lnObservations,lnFactors: integer; var X: PMatrix; + var lImgIntensity: DoubleP0; var lOutT: DoubleP0): boolean; +var + I: integer; + Y : PVector; { Dependent variable } + lOutSlope: DoubleP0; +begin + DimVector(Y, lnObservations); + Getmem(lOutSlope,(lnObservations+1)*sizeof(double)); + { Read data } + for I := 1 to lnObservations do + Y^[I] := lImgIntensity^[I-1]; + result := MultipleRegressionVec (lnObservations,lnFactors,X, Y, lOutT,lOutSlope); + Freemem(lOutslope); + DelVector(Y,lnObservations); +end; + +end. diff --git a/fpmath/regmult.ppu b/fpmath/regmult.ppu new file mode 100644 index 0000000..f6a7463 Binary files /dev/null and b/fpmath/regmult.ppu differ diff --git a/fpmath/tpmath.pdf b/fpmath/tpmath.pdf new file mode 100755 index 0000000..b380e29 Binary files /dev/null and b/fpmath/tpmath.pdf differ diff --git a/fpmath/tpmath.txt b/fpmath/tpmath.txt new file mode 100755 index 0000000..f726987 --- /dev/null +++ b/fpmath/tpmath.txt @@ -0,0 +1,88 @@ +****************************************************************************** +* * +* TPMATH * +* * +* MATHEMATICAL LIBRARY FOR PASCAL COMPILERS * +* * +* Version 0.50 (December 2007) * +* * +****************************************************************************** + + + + AUTHOR : Dr Jean DEBORD + + Laboratoire de Pharmacologie, Faculte de Medecine + 2 Rue du Docteur Marcland, 87025 Limoges (France) + debord.jean@orange.fr + jean.debord@unilim.fr + + +****************************************************************************** + This library is distributed under the terms of the GNU Lesser General Public + License (LGPL). See file LGPL.TXT for details. +****************************************************************************** + + +INTRODUCTION +============ + +TPMath is a mathematical library for Pascal compilers. +It is entirely written in Pascal and does not depend on external libraries. +TPMath provides routines and demo programs for numerical analysis, including +mathematical functions, probabilities, matrices, optimization, linear and nonlinear +equations, integration, Fast Fourier Transform, random numbers, statistics and graphics. + + +CONTENTS +======== + +Main directory +-------------- + +TPMATH.TXT : This file +LGPL.TXT : License +TPMATH.PDF : Documentation of TPMath in PDF format + +DLL directory +------------- + +Source files of the library. + +UNITS directory +--------------- + +Source files of individual units. + +DEMO directory +-------------- + +Source of demo programs. + + +SYSTEM REQUIREMENTS +=================== + +* PC computer with Windows or Linux +* Delphi (32 bits) or Free Pascal. +* Should also work (with some restrictions) with Turbo Pascal, Delphi 16 bits or GNU Pascal + + +INSTALLATION AND COMPILATION +============================ + +See the instructions in file TPMATH.PDF (chapter 1) + + +WEB LINKS +========= + +TPMath web page: +http://www.unilim.fr/pages_perso/jean.debord/tpmath/tpmath.htm + +SourceForge project page: +http://sourceforge.net/projects/tpmath/ + +Mailing list: +http://groups.yahoo.com/group/tpmathlib/ + diff --git a/fpmath/types.inc b/fpmath/types.inc new file mode 100755 index 0000000..b4cf147 --- /dev/null +++ b/fpmath/types.inc @@ -0,0 +1,271 @@ +{ ------------------------------------------------------------------ + Floating point type (Default = Double) + ------------------------------------------------------------------ } + +{$IFDEF SINGLEREAL} + type Float = Single; +{$ELSE} +{$IFDEF EXTENDEDREAL} + type Float = Extended; +{$ELSE} + {$DEFINE DOUBLEREAL} + type Float = Double; +{$ENDIF} +{$ENDIF} + +{ ------------------------------------------------------------------ + Mathematical constants + ------------------------------------------------------------------ } + +const + Pi = 3.14159265358979323846; { Pi } + Ln2 = 0.69314718055994530942; { Ln(2) } + Ln10 = 2.30258509299404568402; { Ln(10) } + LnPi = 1.14472988584940017414; { Ln(Pi) } + InvLn2 = 1.44269504088896340736; { 1/Ln(2) } + InvLn10 = 0.43429448190325182765; { 1/Ln(10) } + TwoPi = 6.28318530717958647693; { 2*Pi } + PiDiv2 = 1.57079632679489661923; { Pi/2 } + SqrtPi = 1.77245385090551602730; { Sqrt(Pi) } + Sqrt2Pi = 2.50662827463100050242; { Sqrt(2*Pi) } + InvSqrt2Pi = 0.39894228040143267794; { 1/Sqrt(2*Pi) } + LnSqrt2Pi = 0.91893853320467274178; { Ln(Sqrt(2*Pi)) } + Ln2PiDiv2 = 0.91893853320467274178; { Ln(2*Pi)/2 } + Sqrt2 = 1.41421356237309504880; { Sqrt(2) } + Sqrt2Div2 = 0.70710678118654752440; { Sqrt(2)/2 } + Gold = 1.61803398874989484821; { Golden Mean = (1 + Sqrt(5))/2 } + CGold = 0.38196601125010515179; { 2 - GOLD } + +{ ------------------------------------------------------------------ + Machine-dependent constants + ------------------------------------------------------------------ } + +{$IFDEF SINGLEREAL} +const + MachEp = 1.192093E-7; { Floating point precision: 2^(-23) } + MaxNum = 3.402823E+38; { Max. floating point number: 2^128 } + MinNum = 1.175495E-38; { Min. floating point number: 2^(-126) } + MaxLog = 88.72283; { Max. argument for Exp = Ln(MaxNum) } + MinLog = -87.33655; { Min. argument for Exp = Ln(MinNum) } + MaxFac = 33; { Max. argument for Factorial } + MaxGam = 34.648; { Max. argument for Gamma } + MaxLgm = 1.0383E+36; { Max. argument for LnGamma } +{$ENDIF} + +{$IFDEF DOUBLEREAL} +const + MachEp = 2.220446049250313E-16; { 2^(-52) } + MaxNum = 1.797693134862315E+308; { 2^1024 } + MinNum = 2.225073858507202E-308; { 2^(-1022) } + MaxLog = 709.7827128933840; + MinLog = -708.3964185322641; + MaxFac = 170; + MaxGam = 171.624376956302; + MaxLgm = 2.556348E+305; +{$ENDIF} + +{$IFDEF EXTENDEDREAL} +const + MachEp = 1.08420217248550444E-19; { 2^(-63) } + MaxNum = 5.9486574767861588254E+4931; { 2^16383 } + MinNum = 6.7242062862241870125E-4932; { 2^(-16381) } + MaxLog = 11355.830259113584004; + MinLog = -11354.443964752464114; + + MaxFac = 1754; + MaxGam = 1755.455; + MaxLgm = 1.04848146839019521E+4928; +{$ENDIF} + +{ ------------------------------------------------------------------ + Error codes for mathematical functions + ------------------------------------------------------------------ } + +const + FOk = 0; { No error } + FDomain = - 1; { Argument domain error } + FSing = - 2; { Function singularity } + FOverflow = - 3; { Overflow range error } + FUnderflow = - 4; { Underflow range error } + FTLoss = - 5; { Total loss of precision } + FPLoss = - 6; { Partial loss of precision } + +{ ------------------------------------------------------------------ + Error codes for matrix computations + ------------------------------------------------------------------ } + +const + MatOk = 0; { No error } + MatNonConv = -1; { Non-convergence } + MatSing = -2; { Quasi-singular matrix } + MatErrDim = -3; { Non-compatible dimensions } + MatNotPD = -4; { Matrix not positive definite } + +{ ------------------------------------------------------------------ + Error codes for optimization and nonlinear equations + ------------------------------------------------------------------ } + +const + OptOk = 0; { No error } + OptNonConv = -1; { Non-convergence } + OptSing = -2; { Quasi-singular hessian matrix } + OptBigLambda = -5; { Too high Marquardt parameter } + +{ ------------------------------------------------------------------ + Error codes for nonlinear regression + ------------------------------------------------------------------ } + +const + NLMaxPar = -6; { Max. number of parameters exceeded } + +{ ------------------------------------------------------------------ + Complex numbers + ------------------------------------------------------------------ } + +type Complex = record + X, Y : Float; +end; + +{ ------------------------------------------------------------------ + Vectors and matrices. + ------------------------------------------------------------------ } + +const { Maximal array size } +{$IFDEF _16BIT} + MaxSize = 65536; { 64 kilobytes : 2^16 } +{$ELSE} + MaxSize = 2147483648; { 2 gigabytes : 2^31 } +{$ENDIF} + + FltSize = SizeOf(Float); + CompSize = SizeOf(Complex); + IntSize = SizeOf(Integer); + BoolSize = SizeOf(Boolean); + StrSize = SizeOf(String); + PtrSize = SizeOf(Pointer); + + MAX_FLT = Trunc(MaxSize / FltSize) - 2; + MAX_COMP = Trunc(MaxSize / CompSize) - 2; + MAX_INT = Trunc(MaxSize / IntSize) - 2; + MAX_BOOL = Trunc(MaxSize / BoolSize) - 2; + MAX_STR = Trunc(MaxSize / StrSize) - 2; + MAX_VEC = Trunc(MaxSize / PtrSize) - 2; + +type + TVector = array[0..MAX_FLT] of Float; + TIntVector = array[0..MAX_INT] of Integer; + TCompVector = array[0..MAX_COMP] of Complex; + TBoolVector = array[0..MAX_BOOL] of Boolean; + TStrVector = array[0..MAX_STR] of String; + + PVector = ^TVector; + PIntVector = ^TIntVector; + PBoolVector = ^TBoolVector; + PCompVector = ^TCompVector; + PStrVector = ^TStrVector; + +type + XTMatrix = array[0..MAX_VEC] of PVector; + TIntMatrix = array[0..MAX_VEC] of PIntVector; + TBoolMatrix = array[0..MAX_VEC] of PBoolVector; + TCompMatrix = array[0..MAX_VEC] of PCompVector; + TStrMatrix = array[0..MAX_VEC] of PStrVector; + + PMatrix = ^XTMatrix; + PIntMatrix = ^TIntMatrix; + PBoolMatrix = ^TBoolMatrix; + PCompMatrix = ^TCompMatrix; + PStrMatrix = ^TStrMatrix; + +{ ------------------------------------------------------------------ + Functional types + ------------------------------------------------------------------ } + +{ Function of one variable } +type TFunc = function(X : Float) : Float; + +{ Function of several variables } +type TFuncNVar = function(X : PVector) : Float; + +{ Nonlinear equation system } +type TEquations = procedure(X, F : PVector); + +{ Differential equation system } +type TDiffEqs = procedure(X : Float; Y, Yp : PVector); + +{ Jacobian } +type TJacobian = procedure(X : PVector; D : PMatrix); + +{ Gradient } +type TGradient = procedure(X, G : PVector); + +{ Hessian and Gradient } +type THessGrad = procedure(X, G : PVector; H : PMatrix); + +{ ------------------------------------------------------------------ + Random number generators + ------------------------------------------------------------------ } + +type RNG_Type = + (RNG_MWC, { Multiply-With-Carry } + RNG_MT, { Mersenne Twister } + RNG_UVAG); { Universal Virtual Array Generator } + +{ ------------------------------------------------------------------ + Statistics + ------------------------------------------------------------------ } + +type StatClass = record { Statistical class } + Inf : Float; { Lower bound } + Sup : Float; { Upper bound } + N : Integer; { Number of values } + F : Float; { Frequency } + D : Float; { Density } +end; + +const + MAX_CLS = 1000; { Max. number of statistical classes } + +type + TStatClassVector = array[0..MAX_CLS] of StatClass; + PStatClassVector = ^TStatClassVector; + +{ ------------------------------------------------------------------ + Curve fit + ------------------------------------------------------------------ } + +type + TRegTest = record { Test of regression } + Vr : Float; { Residual variance } + R2 : Float; { Coefficient of determination } + R2a : Float; { Adjusted coeff. of determination } + F : Float; { Variance ratio (explained/residual) } + Nu1, Nu2 : Integer; { Degrees of freedom } + end; + +{ Optimization algorithms for nonlinear regression } +type + TOptAlgo = ( + NL_MARQ, { Marquardt algorithm } + NL_SIMP, { Simplex algorithm } + NL_BFGS, { BFGS algorithm } + NL_SA, { Simulated annealing } + NL_GA); { Genetic algorithm } + +{ Regression function } +type + TRegFunc = function(X : Float; B : PVector) : Float; + +{ Procedure to compute the derivatives of the regression function + with respect to the regression parameters } +type + TDerivProc = procedure(X, Y : Float; B, D : PVector); + +{ ------------------------------------------------------------------ + Graphics + ------------------------------------------------------------------ } + +type + Str30 = String[30]; + TScale = (LinScale, LogScale); + TGrid = (NoGrid, HorizGrid, VertiGrid, BothGrid); diff --git a/fpmath/uanova1.pas b/fpmath/uanova1.pas new file mode 100755 index 0000000..893fc86 --- /dev/null +++ b/fpmath/uanova1.pas @@ -0,0 +1,81 @@ +{ ****************************************************************** + One-way analysis of variance + ****************************************************************** } + +unit uanova1; + +interface + +uses + utypes; + +procedure AnOVa1(Ns : Integer; + N : PIntVector; + M, S : PVector; + var V_f, V_r, F : Float; + var DoF_f, DoF_r : Integer); +{ ------------------------------------------------------------------ + Input parameters : Ns = number of samples + N = samples sizes + M = samples means + S = samples SD's (computed with StDev) + Output parameters: V_f, V_r = variances (factorial, residual) + F = ratio Vf / Vr + DoF_f, DoF_r = degrees of freedom + ------------------------------------------------------------------ } + +implementation + +procedure AnOVa1(Ns : Integer; + N : PIntVector; + M, S : PVector; + var V_f, V_r, F : Float; + var DoF_f, DoF_r : Integer); +var + I, Nt : Integer; + Xbar : Float; { Global mean } + SSf, SSr : Float; { Sum of squares } + D : Float; { Difference of means } + +begin + if Ns < 2 then + begin + SetErrCode(MatErrDim); + Exit + end; + + Nt := 0; + for I := 1 to Ns do + Nt := Nt + N^[I]; + + if Nt <= Ns then + begin + SetErrCode(MatErrDim); + Exit; + end; + + SetErrCode(MatOk); + + Xbar := 0.0; + for I := 1 to Ns do + Xbar := Xbar + N^[I] * M^[I]; + + Xbar := Xbar / Nt; + + SSf := 0.0; + SSr := 0.0; + for I := 1 to Ns do + begin + D := M^[I] - Xbar; + SSf := SSf + N^[I] * Sqr(D); + SSr := SSr + (N^[I] - 1) * Sqr(S^[I]); + end; + + DoF_f := Ns - 1; + DoF_r := Nt - Ns; + V_f := SSf / DoF_f; + V_r := SSr / DoF_r; + F := V_f / V_r; +end; + +end. \ No newline at end of file diff --git a/fpmath/uanova2.pas b/fpmath/uanova2.pas new file mode 100755 index 0000000..7450512 --- /dev/null +++ b/fpmath/uanova2.pas @@ -0,0 +1,149 @@ +{ ****************************************************************** + Two-way analysis of variance + ****************************************************************** } + +unit uanova2; + +interface + +uses + utypes; + +procedure AnOVa2(NA, NB, Nobs : Integer; + M, S : PMatrix; + V, F : PVector; + DoF : PIntVector); +{ ------------------------------------------------------------------ + Input parameters : NA = number of modalities for factor A + NB = number of modalities for factor B + Nobs = number of observations for each sample + M = matrix of means + (factor A as lines, factor B as columns) + S = matrix of standard deviations + Output parameters: V = variances + (factor A, factor B, interaction, residual) + F = variance ratios + (factor A, factor B, interaction) + DoF = degrees of freedom + (factor A, factor B, interaction, residual) + ------------------------------------------------------------------ } + +implementation + +procedure AnOVa2(NA, NB, Nobs : Integer; + M, S : PMatrix; + V, F : PVector; + DoF : PIntVector); + +var + I, J, P : Integer; + Xbar : Float; { Global mean } + D : Float; { Difference of means } + Sum : Float; { Intermediate sum } + ML, MC : PVector; { Line and columns means } + SS : PVector; { Sum of squares } + +begin + if (NA < 2) or (NB < 2) or (Nobs < 1) then + begin + SetErrCode(MatErrDim); + Exit + end; + + DimVector(ML, NA); + DimVector(MC, NB); + DimVector(SS, 3); + + SetErrCode(MatOk); + + { Line means } + for I := 1 to NA do + begin + Sum := 0.0; + for J := 1 to NB do + Sum := Sum + M^[I]^[J]; + ML^[I] := Sum / NB; + end; + + { Column means } + for J := 1 to NB do + begin + Sum := 0.0; + for I := 1 to NA do + Sum := Sum + M^[I]^[J]; + MC^[J] := Sum / NA; + end; + + { Global mean } + Sum := 0.0; + for I := 1 to NA do + Sum := Sum + ML^[I]; + + Xbar := Sum / NA; + + { Residual variance } + if Nobs = 1 then + V^[4] := 0.0 + else + begin + Sum := 0.0; + for I := 1 to NA do + for J := 1 to NB do + Sum := Sum + Sqr(S^[I]^[J]); + P := NA * NB; + DoF^[4] := P * (Nobs - 1); + V^[4] := Sum / P; + end; + + { Factorial sum of squares } + Sum := 0.0; + for I := 1 to NA do + for J := 1 to NB do + begin + D := M^[I]^[J] - Xbar; + Sum := Sum + Sqr(D) + end; + SS^[0] := Nobs * Sum; + + { Factorial variance (factor A) } + Sum := 0.0; + for I := 1 to NA do + begin + D := ML^[I] - Xbar; + Sum := Sum + Sqr(D) + end; + SS^[1] := NB * Nobs * Sum; + DoF^[1] := NA - 1; + V^[1] := SS^[1] / DoF^[1]; + + { Factorial variance (factor B) } + Sum := 0.0; + for J := 1 to NB do + begin + D := MC^[J] - Xbar; + Sum := Sum + Sqr(D) + end; + SS^[2] := NA * Nobs * Sum; + DoF^[2] := NB - 1; + V^[2] := SS^[2] / DoF^[2]; + + { Factorial variance (interaction) } + SS^[3] := SS^[0] - SS^[1] - SS^[2]; + DoF^[3] := DoF^[1] * DoF^[2]; + V^[3] := SS^[3] / DoF^[3]; + + { Variance ratios } + if Nobs = 1 then + begin + F^[1] := V^[1] / V^[3]; + F^[2] := V^[2] / V^[3] + end + else + begin + F^[1] := V^[1] / V^[4]; + F^[2] := V^[2] / V^[4]; + F^[3] := V^[3] / V^[4]; + end; +end; + +end. \ No newline at end of file diff --git a/fpmath/ubalance.pas b/fpmath/ubalance.pas new file mode 100755 index 0000000..5621eea --- /dev/null +++ b/fpmath/ubalance.pas @@ -0,0 +1,194 @@ +{ ****************************************************************** + Balances a matrix and tries to isolate eigenvalues + ****************************************************************** } + +unit ubalance; + +interface + +uses + utypes; + +procedure Balance( A : PMatrix; + Lb, Ub : Integer; + var I_low, I_igh : Integer; + Scale : PVector); + +implementation + +procedure Balance( A : PMatrix; + Lb, Ub : Integer; + var I_low, I_igh : Integer; + Scale : PVector); +{ ------------------------------------------------------------------ + This procedure is a translation of the EISPACK procedure Balanc. + + This procedure balances a real matrix and isolates eigenvalues + whenever possible. + + On input: + + A contains the input matrix to be balanced. + + Lb, Ub are the lowest and highest indices of the elements of A. + + On output: + + A contains the balanced matrix. + + I_low and I_igh are two integers such that A[i,j] + is equal to zero if + (1) i is greater than j and + (2) j=Lb,...,I_low-1 or i=I_igh+1,...,Ub. + + Scale contains information determining the permutations + and scaling factors used. + + Suppose that the principal submatrix in rows I_low through I_igh + has been balanced, that P[j] denotes the index interchanged + with j during the permutation step, and that the elements + of the diagonal matrix used are denoted by D[i,j]. then + Scale[j] = P[j], for j = Lb,...,I_low-1 + = D[j,j], j = I_low,...,I_igh + = P[j] j = I_igh+1,...,Ub. + the order in which the interchanges are made is + Ub to I_igh+1, then Lb to I_low-1. + + Note that Lb is returned for I_igh if I_igh is < Lb formally + ------------------------------------------------------------------ } + + const + RADIX = 2; { Base used in floating number representation } + + var + I, J, M : Integer; + C, F, G, R, S, B2 : Float; + Flag, Found, Conv : Boolean; + + procedure Exchange; + { Row and column exchange } + var + I : Integer; + begin + Scale^[M] := J; + if J = M then Exit; + + for I := Lb to I_igh do + begin + F := A^[I]^[J]; + A^[I]^[J] := A^[I]^[M]; + A^[I]^[M] := F; + end; + + for I := I_low to Ub do + begin + F := A^[J]^[I]; + A^[J]^[I] := A^[M]^[I]; + A^[M]^[I] := F; + end; + end; + + begin + B2 := RADIX * RADIX; + I_low := Lb; + I_igh := Ub; + + { Search for rows isolating an eigenvalue and push them down } + repeat + J := I_igh; + repeat + I := Lb; + repeat + Flag := (I <> J) and (A^[J]^[I] <> 0.0); + I := I + 1; + until Flag or (I > I_igh); + Found := not Flag; + if Found then + begin + M := I_igh; + Exchange; + I_igh := I_igh - 1; + end; + J := J - 1; + until Found or (J < Lb); + until (not Found) or (I_igh < Lb); + + if I_igh < Lb then I_igh := Lb; + if I_igh = Lb then Exit; + + { Search for columns isolating an eigenvalue and push them left } + repeat + J := I_low; + repeat + I := I_low; + repeat + Flag := (I <> J) and (A^[I]^[J] <> 0.0); + I := I + 1; + until Flag or (I > I_igh); + Found := not Flag; + if Found then + begin + M := I_low; + Exchange; + I_low := I_low + 1; + end; + J := J + 1; + until Found or (J > I_igh); + until (not Found); + + { Now balance the submatrix in rows I_low to I_igh } + for I := I_low to I_igh do + Scale^[I] := 1.0; + + { Iterative loop for norm reduction } + repeat + Conv := True; + + for I := I_low to I_igh do + begin + C := 0.0; + R := 0.0; + + for J := I_low to I_igh do + if J <> I then + begin + C := C + Abs(A^[J]^[I]); + R := R + Abs(A^[I]^[J]); + end; + + { Guard against zero C or R due to underflow } + if (C <> 0.0) and (R <> 0.0) then + begin + G := R / RADIX; + F := 1.0; + S := C + R; + + while C < G do + begin + F := F * RADIX; + C := C * B2; + end; + + G := R * RADIX; + + while C >= G do + begin + F := F / RADIX; + C := C / B2; + end; + + { Now balance } + if (C + R) / F < 0.95 * S then + begin + G := 1.0 / F; + Scale^[I] := Scale^[I] * F; + Conv := False; + for J := I_low to Ub do A^[I]^[J] := A^[I]^[J] * G; + for J := Lb to I_igh do A^[J]^[I] := A^[J]^[I] * F; + end; + end; + end; + until Conv; + end; + +end. diff --git a/fpmath/ubalbak.pas b/fpmath/ubalbak.pas new file mode 100755 index 0000000..40d0501 --- /dev/null +++ b/fpmath/ubalbak.pas @@ -0,0 +1,91 @@ +{ ****************************************************************** + Back transformation of eigenvectors + ****************************************************************** } + +unit ubalbak; + +interface + +uses + utypes; + +procedure BalBak(Z : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + Scale : PVector; + M : Integer); + +implementation + +procedure BalBak(Z : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + Scale : PVector; + M : Integer); +{ ------------------------------------------------------------------ + This procedure is a translation of the EISPACK subroutine Balbak + + This procedure forms the eigenvectors of a real general matrix + by back transforming those of the corresponding balanced matrix + determined by Balance. + + On input: + + Z contains the real and imaginary parts of the eigenvectors + to be back transformed. + + Lb, Ub are the lowest and highest indices + of the elements of Z + + I_low and I_igh are integers determined by Balance. + + Scale contains information determining the permutations + and scaling factors used by Balance. + + M is the index of the latest column of Z to be back transformed. + + On output: + + Z contains the real and imaginary parts of the transformed + eigenvectors in its columns Lb..M + ------------------------------------------------------------------ } + var + I, J, K : Integer; + S : Float; + begin + if M < Lb then Exit; + + if I_igh <> I_low then + for I := I_low to I_igh do + begin + S := Scale^[I]; + { Left hand eigenvectors are back transformed if the + foregoing statement is replaced by S := 1.0 / Scale^[I] } + for J := Lb to M do + Z^[I]^[J] := Z^[I]^[J] * S; + end; + + for I := (I_low - 1) downto Lb do + begin + K := Round(Scale^[I]); + if K <> I then + for J := Lb to M do + begin + S := Z^[I]^[J]; + Z^[I]^[J] := Z^[K]^[J]; + Z^[K]^[J] := S; + end; + end; + + for I := (I_igh + 1) to Ub do + begin + K := Round(Scale^[I]); + if K <> I then + for J := Lb to M do + begin + S := Z^[I]^[J]; + Z^[I]^[J] := Z^[K]^[J]; + Z^[K]^[J] := S; + end; + end; + end; + +end. diff --git a/fpmath/ubartlet.pas b/fpmath/ubartlet.pas new file mode 100755 index 0000000..44d1be1 --- /dev/null +++ b/fpmath/ubartlet.pas @@ -0,0 +1,76 @@ +{ ****************************************************************** + Bartlett's test (comparison of several variances) + ****************************************************************** } + +unit ubartlet; + +interface + +uses + utypes; + +procedure Bartlett(Ns : Integer; + N : PIntVector; + S : PVector; + var Khi2 : Float; + var DoF : Integer); +{ ------------------------------------------------------------------ + Input parameters : Ns = number of samples + N = samples sizes + S = samples SD's (computed with StDev) + Output parameters: Khi2 = Bartlett's khi-2 + DoF = degrees of freedom + ------------------------------------------------------------------ } + +implementation + +procedure Bartlett(Ns : Integer; + N : PIntVector; + S : PVector; + var Khi2 : Float; + var DoF : Integer); + +var + I, Nt, N1, DoF_r : Integer; + SSr, Vr, Vi, SumLog, SumInv : Float; + +begin + if Ns < 2 then + begin + SetErrCode(MatErrDim); + Exit + end; + + Nt := 0; + for I := 1 to Ns do + Nt := Nt + N^[I]; + + if Nt <= Ns then + begin + SetErrCode(MatErrDim); + Exit; + end; + + SetErrCode(MatOk); + + SSr := 0.0; + SumLog := 0.0; + SumInv := 0.0; + + for I := 1 to Ns do + begin + N1 := N^[I] - 1; + Vi := Sqr(S^[I]); + SSr := SSr + N1 * Vi; + SumLog := SumLog + N1 * Ln(Vi); + SumInv := SumInv + 1 / N1; + end; + + DoF := Ns - 1; + DoF_r := Nt - Ns; + Vr := SSr / DoF_r; + Khi2 := (DoF_r * Ln(Vr) - SumLog) / + (1.0 + (SumInv - 1.0 / DoF_r) / (3.0 * DoF)); +end; + +end. \ No newline at end of file diff --git a/fpmath/ubeta.pas b/fpmath/ubeta.pas new file mode 100755 index 0000000..39bdaf9 --- /dev/null +++ b/fpmath/ubeta.pas @@ -0,0 +1,50 @@ +{ ****************************************************************** + Beta function + ****************************************************************** } + +unit ubeta; + +interface + +uses + utypes, ugamma; + +function Beta(X, Y : Float) : Float; + +implementation + + function Beta(X, Y : Float) : Float; + { Computes Beta(X, Y) = Gamma(X) * Gamma(Y) / Gamma(X + Y) } + var + Lx, Ly, Lxy : Float; + SgnBeta : Integer; + begin + SetErrCode(FOk); + + SgnBeta := SgnGamma(X) * SgnGamma(Y) * SgnGamma(X + Y); + + Lxy := LnGamma(X + Y); + if MathErr <> FOk then + begin + Beta := 0.0; + Exit; + end; + + Lx := LnGamma(X); + if MathErr <> FOk then + begin + Beta := SgnBeta * MaxNum; + Exit; + end; + + Ly := LnGamma(Y); + if MathErr <> FOk then + begin + Beta := SgnBeta * MaxNum; + Exit; + end; + + Beta := SgnBeta * Exp(Lx + Ly - Lxy); + end; + +end. \ No newline at end of file diff --git a/fpmath/ubfgs.pas b/fpmath/ubfgs.pas new file mode 100755 index 0000000..f924cbc --- /dev/null +++ b/fpmath/ubfgs.pas @@ -0,0 +1,260 @@ +{ ****************************************************************** + Minimization of a function of several variables by the + Broyden-Fletcher-Goldfarb-Shanno (BFGS) method + ****************************************************************** } + +unit ubfgs; + +interface + +uses + utypes, ulinmin, ucompvec; + +procedure SaveBFGS(FileName : string); +{ ------------------------------------------------------------------ + Save BFGS iterations in a file + ------------------------------------------------------------------ } + +procedure BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix); +{ ------------------------------------------------------------------ + Minimization of a function of several variables by the + Broyden-Fletcher-Goldfarb-Shanno method + ------------------------------------------------------------------ + Input parameters : Func = objective function + Gradient = procedure to compute gradient + X = initial minimum coordinates + Lb, Ub = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + G = gradient vector + H_inv = inverse hessian matrix + ------------------------------------------------------------------ + Possible results : OptOk + OptNonConv + ---------------------------------------------------------------------- } + +implementation + +const + WriteLogFile : Boolean = False; + +var + LogFile : Text; + +procedure SaveBFGS(FileName : string); + begin + Assign(LogFile, FileName); + Rewrite(LogFile); + WriteLogFile := True; + end; + +procedure BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix); + var + I, J, Iter : Integer; + A, DeltaXmax, Gmax, P1, P2, R, R1, R2 : Float; + OldX, DeltaX, dX, OldG, dG, HdG, R1dX, R2HdG, U, P2U : PVector; + + procedure Init; + { Initializes Function, Gradient and Inverse Hessian } + var + I, J : Integer; + begin + { Initialize function } + F_min := Func(X); + + { Initialize gradient } + Gradient(X, G); + + { Initialize inverse hessian to unit matrix } + for I := Lb to Ub do + begin + H_inv^[I]^[I] := 1.0; + for J := I + 1 to Ub do + begin + H_inv^[I]^[J] := 0.0; + H_inv^[J]^[I] := 0.0; + end; + end; + end; + + procedure Terminate(ErrCode : Integer); + { Set error code and deallocate arrays } + begin + DelVector(OldX, Ub); + DelVector(DeltaX, Ub); + DelVector(dX, Ub); + DelVector(OldG, Ub); + DelVector(dG, Ub); + DelVector(HdG, Ub); + DelVector(R1dX, Ub); + DelVector(R2HdG, Ub); + DelVector(U, Ub); + DelVector(P2U, Ub); + + SetErrCode(ErrCode); + + if WriteLogFile then + Close(LogFile); + end; + + begin + DimVector(OldX, Ub); + DimVector(DeltaX, Ub); + DimVector(dX, Ub); + DimVector(OldG, Ub); + DimVector(dG, Ub); + DimVector(HdG, Ub); + DimVector(R1dX, Ub); + DimVector(R2HdG, Ub); + DimVector(U, Ub); + DimVector(P2U, Ub); + + Init; + + if MaxIter < 1 then + begin + Terminate(OptOk); + Exit; + end; + + if WriteLogFile then + begin + WriteLn(LogFile, 'BFGS'); + WriteLn(LogFile, 'Iter F'); + end; + + { Compute max. gradient component } + Gmax := Abs(G^[Lb]); + for I := Lb + 1 to Ub do + begin + A := Abs(G^[I]); + if A > Gmax then Gmax := A; + end; + + { Quit if gradient is already small } + if Gmax < MachEp then + begin + Terminate(OptOk); + Exit; + end; + + { Initialize search direction } + for I := Lb to Ub do + DeltaX^[I] := - G^[I]; + + Iter := 0; + + repeat + { Prepare next iteration } + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12); + + Iter := Iter + 1; + if Iter > MaxIter then + begin + Terminate(OptNonConv); + Exit; + end; + + { Normalize search direction to avoid excessive displacements } + DeltaXmax := Abs(DeltaX^[Lb]); + for I := Lb + 1 to Ub do + begin + A := Abs(DeltaX^[I]); + if A > DeltaXmax then DeltaXmax := A; + end; + if DeltaXmax > 1.0 then + for I := Lb to Ub do + DeltaX^[I] := DeltaX^[I] / DeltaXmax; + + { Save old parameters and gradient } + for I := Lb to Ub do + begin + OldX^[I] := X^[I]; + OldG^[I] := G^[I]; + end; + + { Minimize along the direction specified by DeltaX } + R := 1.0; + LinMin(Func, X, DeltaX, Lb, Ub, R, 10, 0.01, F_min); + + { Compute new gradient } + Gradient(X, G); + + { Compute differences between two successive estimations + of parameter vector and gradient vector } + for I := Lb to Ub do + begin + dX^[I] := X^[I] - OldX^[I]; + dG^[I] := G^[I] - OldG^[I]; + end; + + { Multiply by inverse hessian } + for I := Lb to Ub do + begin + HdG^[I] := 0.0; + for J := Lb to Ub do + HdG^[I] := HdG^[I] + H_inv^[I]^[J] * dG^[J]; + end; + + { Scalar products in denominator of BFGS formula } + P1 := 0.0; P2 := 0.0; + for I := Lb to Ub do + begin + P1 := P1 + dX^[I] * dG^[I]; + P2 := P2 + dG^[I] * HdG^[I]; + end; + + if (P1 = 0.0) or (P2 = 0.0) then Exit; + + { Inverses of scalar products } + R1 := 1.0 / P1; R2 := 1.0 / P2; + + { Compute BFGS correction terms } + for I := Lb to Ub do + begin + R1dX^[I] := R1 * dX^[I]; + R2HdG^[I] := R2 * HdG^[I]; + U^[I] := R1dX^[I] - R2HdG^[I]; + P2U^[I] := P2 * U^[I]; + end; + + { Update inverse hessian } + for I := Lb to Ub do + for J := Lb to Ub do + H_inv^[I]^[J] := H_inv^[I]^[J] + R1dX^[I] * dX^[J] + - R2HdG^[I] * HdG^[J] + P2U^[I] * U^[J]; + + { Update search direction } + for I := Lb to Ub do + begin + DeltaX^[I] := 0.0; + for J := Lb to Ub do + DeltaX^[I] := DeltaX^[I] - H_inv^[I]^[J] * G^[J]; + end; + until CompVec(X, OldX, Lb, Ub, Tol); + + Terminate(OptOk); + end; + +end. + diff --git a/fpmath/ubinom.pas b/fpmath/ubinom.pas new file mode 100755 index 0000000..a32e5c2 --- /dev/null +++ b/fpmath/ubinom.pas @@ -0,0 +1,56 @@ +{ ****************************************************************** + Binomial distribution + ****************************************************************** } + +unit ubinom; + +interface + +uses + utypes, umath; + +function Binomial(N, K : Integer) : Float; +{ Binomial coefficient C(N,K) } + +function PBinom(N : Integer; P : Float; K : Integer) : Float; +{ Probability of binomial distribution } + +implementation + + function Binomial(N, K : Integer) : Float; + var + I, N1 : Integer; + Prod : Float; + begin + SetErrCode(FOk); + if K < 0 then + Binomial := 0.0 + else if (K = 0) or (K = N) then + Binomial := 1.0 + else if (K = 1) or (K = N - 1) then + Binomial := N + else + begin + if K > N - K then K := N - K; + N1 := Succ(N); + Prod := N; + for I := 2 to K do + Prod := Prod * ((N1 - I) / I); + Binomial := Int(0.5 + Prod); + end; + end; + + function PBinom(N : Integer; P : Float; K : Integer) : Float; + begin + SetErrCode(FOk); + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + PBinom := DefaultVal(FDomain, 0.0) + else if K = 0 then + PBinom := Power(1.0 - P, N) + else if K = N then + PBinom := Power(P, N) + else + PBinom := Binomial(N, K) * Power(P, K) * Power(1.0 - P, N - K); + end; + +end. \ No newline at end of file diff --git a/fpmath/ubisect.pas b/fpmath/ubisect.pas new file mode 100755 index 0000000..cb7a4b1 --- /dev/null +++ b/fpmath/ubisect.pas @@ -0,0 +1,97 @@ +{ ****************************************************************** + Bisection method for nonlinear equation + ****************************************************************** } + +unit ubisect; + +interface + +uses + utypes; + +procedure RootBrack(Func : TFunc; + var X, Y, FX, FY : Float); +{ ------------------------------------------------------------------ + Expands the interval [X,Y] until it contains a root of Func, + i. e. Func(X) and Func(Y) have opposite signs. The corresponding + function values are returned in FX and FY. + ------------------------------------------------------------------ } + +procedure Bisect (Func : TFunc; + var X, Y : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); + +implementation + +procedure RootBrack(Func : TFunc; + var X, Y, FX, FY : Float); + +begin + FX := Func(X); + FY := Func(Y); + + while FX * FY > 0 do + if Abs(FX) < Abs(FY) then + begin + X := X + Gold * (X - Y); + FX := Func(X) + end + else + begin + Y := Y + Gold * (Y - X); + FY := Func(Y) + end; +end; + +procedure Bisect (Func : TFunc; + var X, Y : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); + +var + Iter : Integer; + G, Z, FZ : Float; + +begin + Iter := 0; + SetErrCode(OptOk); + + F := Func(X); + + if MaxIter < 1 then Exit; + + G := Func(Y); + + if F * G >= 0 then RootBrack(Func, X, Y, F, G); + + repeat + Iter := Iter + 1; + if Iter > MaxIter then + begin + SetErrCode(OptNonConv); + Exit; + end; + + Z := 0.5 * (X + Y); + FZ := Func(Z); + + if F * FZ > 0 then + begin + X := Z; + F := FZ; + end + else + begin + Y := Z; + G := FZ; + end; + until Abs(X - Y) < Tol * (Abs(X) + Abs(Y)); + + X := 0.5 * (X + Y); + F := Func(X); +end; + +end. \ No newline at end of file diff --git a/fpmath/ubroyden.pas b/fpmath/ubroyden.pas new file mode 100755 index 0000000..796a89d --- /dev/null +++ b/fpmath/ubroyden.pas @@ -0,0 +1,201 @@ +{ ****************************************************************** + Broyden method for system of nonlinear equations + ****************************************************************** } + +unit ubroyden; + +interface + +uses + utypes, ulinminq, ucompvec; + +procedure Broyden(Equations : TEquations; + X, F : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float); +{ ------------------------------------------------------------------ + Solves a system of nonlinear equations by Broyden's method + ------------------------------------------------------------------ + Input parameters : Equations = subroutine to compute equations + X = initial roots + Lb, Ub = bounds of X + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : X = refined roots + F = function values + ------------------------------------------------------------------ + Possible results : OptOk = no error + OptNonConv = non-convergence + ------------------------------------------------------------------ } + +implementation + +procedure Broyden(Equations : TEquations; + X, F : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float); + +var + I, J, K, Iter : Integer; + A, DeltaXmax, Fmax, P, Q, R, S : Float; + Conv : Boolean; + OldX, DeltaX, dX, OldF, dF, DdF : PVector; + Dinv : PMatrix; + + procedure Terminate(ErrCode : Integer); + { Set error code and deallocate arrays } + begin + DelVector(OldX, Ub); + DelVector(DeltaX, Ub); + DelVector(dX, Ub); + DelVector(OldF, Ub); + DelVector(dF, Ub); + DelVector(DdF, Ub); + DelMatrix(Dinv, Ub, Ub); + SetErrCode(ErrCode); + end; + +begin + { Initialize function vector } + Equations(X, F); + + { Quit if no iteration required } + if MaxIter < 1 then + begin + SetErrCode(OptOk); + Exit; + end; + + { Dimension arrays } + DimVector(OldX, Ub); + DimVector(DeltaX, Ub); + DimVector(dX, Ub); + DimVector(OldF, Ub); + DimVector(dF, Ub); + DimVector(DdF, Ub); + DimMatrix(Dinv, Ub, Ub); + + { Initialize inverse jacobian to unit matrix } + for I := Lb to Ub do + begin + Dinv^[I]^[I] := 1.0; + for J := I + 1 to Ub do + begin + Dinv^[I]^[J] := 0.0; + Dinv^[J]^[I] := 0.0 + end; + end; + + Iter := 0; + + { Compute max. function component } + Fmax := Abs(F^[Lb]); + for I := Lb + 1 to Ub do + begin + A := Abs(F^[I]); + if A > Fmax then Fmax := A; + end; + + { Quit if function vector is already small } + if Fmax < MachEp then + begin + Terminate(OptOk); + Exit; + end; + + { Initialize search direction } + for I := Lb to Ub do + DeltaX^[I] := - F^[I]; + + repeat + { Prepare next iteration } + Iter := Iter + 1; + if Iter > MaxIter then + begin + Terminate(OptNonConv); + Exit; + end; + + { Normalize search direction to avoid excessive displacements } + DeltaXmax := Abs(DeltaX^[Lb]); + for I := Lb + 1 to Ub do + begin + A := Abs(DeltaX^[I]); + if A > DeltaXmax then DeltaXmax := A; + end; + + if DeltaXmax > 1.0 then + for I := Lb to Ub do + DeltaX^[I] := DeltaX^[I] / DeltaXmax; + + { Save old parameters and functions } + for I := Lb to Ub do + begin + OldX^[I] := X^[I]; + OldF^[I] := F^[I]; + end; + + { Minimize along the direction specified by DeltaX, + with initial step R = 1, and compute new function } + R := 1.0; + LinMinEq(Equations, X, DeltaX, F, Lb, Ub, R, 10, 0.01); + Equations(X, F); + + { Compute differences between two successive + estimations of parameter vector and function vector } + for I := Lb to Ub do + begin + dX^[I] := X^[I] - OldX^[I]; + dF^[I] := F^[I] - OldF^[I]; + end; + + { Multiply by inverse jacobian } + for I := Lb to Ub do + begin + DdF^[I] := 0.0; + for J := Lb to Ub do + DdF^[I] := DdF^[I] + Dinv^[I]^[J] * dF^[J]; + end; + + { Scalar product in denominator of Broyden formula } + P := 0.0; + for I := Lb to Ub do + P := P + dX^[I] * DdF^[I]; + + if P = 0.0 then Exit; + + { Inverse of scalar product } + Q := 1.0 / P; + + { Update inverse jacobian } + for I := Lb to Ub do + begin + A := (dX^[I] - DdF^[I]) * Q; + for J := Lb to Ub do + begin + S := 0.0; + for K := Lb to Ub do + S := S + dX^[K] * Dinv^[K]^[J]; + Dinv^[I]^[J] := Dinv^[I]^[J] + A * S; + end; + end; + + { Update search direction } + for I := Lb to Ub do + begin + DeltaX^[I] := 0.0; + for J := Lb to Ub do + DeltaX^[I] := DeltaX^[I] - Dinv^[I]^[J] * F^[J]; + end; + + { Test for convergence } + Conv := CompVec(X, OldX, Lb, Ub, Tol); + until Conv; + + Terminate(OptOk); +end; + +end. \ No newline at end of file diff --git a/fpmath/ucholesk.pas b/fpmath/ucholesk.pas new file mode 100755 index 0000000..31363bf --- /dev/null +++ b/fpmath/ucholesk.pas @@ -0,0 +1,55 @@ +{ ****************************************************************** + Cholesky factorization of a positive definite symmetric matrix + ****************************************************************** } + +unit ucholesk; + +interface + +uses + utypes; + +procedure Cholesky(A, L : PMatrix; Lb, Ub : Integer); +{ ------------------------------------------------------------------ + Cholesky decomposition. Factors the symmetric positive definite + matrix A as a product L * L' where L is a lower triangular matrix. + This procedure may be used as a test of positive definiteness. + ------------------------------------------------------------------ + Possible results : MatOk : No error + MatNotPD : Matrix not positive definite + ------------------------------------------------------------------ } + +implementation + +procedure Cholesky(A, L : PMatrix; Lb, Ub : Integer); +var + I, J, K : Integer; + Sum : Float; +begin + for K := Lb to Ub do + begin + Sum := A^[K]^[K]; + for J := Lb to K - 1 do + Sum := Sum - Sqr(L^[K]^[J]); + + if Sum <= 0.0 then + begin + SetErrCode(MatNotPD); + Exit + end; + + L^[K]^[K] := Sqrt(Sum); + for I := K + 1 to Ub do + begin + Sum := A^[I]^[K]; + for J := Lb to K - 1 do + Sum := Sum - L^[I]^[J] * L^[K]^[J]; + L^[I]^[K] := Sum / L^[K]^[K]; + L^[K]^[I] := 0.0; + end; + end; + + SetErrCode(MatOk); +end; + +end. diff --git a/fpmath/ucompvec.pas b/fpmath/ucompvec.pas new file mode 100755 index 0000000..a88c69d --- /dev/null +++ b/fpmath/ucompvec.pas @@ -0,0 +1,45 @@ +{ ****************************************************************** + Comparison of two vectors + ****************************************************************** } + +unit ucompvec; + +interface + +uses + utypes; + +function CompVec(X, Xref : PVector; + Lb, Ub : Integer; + Tol : Float) : Boolean; +{ ------------------------------------------------------------------ + Checks if each component of vector X is within a fraction Tol of + the corresponding component of the reference vector Xref. In this + case, the function returns True, otherwise it returns False + ------------------------------------------------------------------ } + +implementation + +function CompVec(X, Xref : PVector; + Lb, Ub : Integer; + Tol : Float) : Boolean; +var + I : Integer; + Ok : Boolean; + ITol : Float; + +begin + I := Lb; + Ok := True; + + repeat + ITol := Tol * Abs(Xref^[I]); + if ITol < MachEp then ITol := MachEp; + Ok := Ok and (Abs(X^[I] - Xref^[I]) < ITol); + I := I + 1; + until (not Ok) or (I > Ub); + + CompVec := Ok; +end; + +end. \ No newline at end of file diff --git a/fpmath/ucorrel.pas b/fpmath/ucorrel.pas new file mode 100755 index 0000000..7aaa211 --- /dev/null +++ b/fpmath/ucorrel.pas @@ -0,0 +1,53 @@ +{ ****************************************************************** + Correlation coefficient + ****************************************************************** } + +unit ucorrel; + +interface + +uses + utypes; + +function Correl(X, Y : PVector; Lb, Ub : Integer) : Float; +{ Correlation coefficient between samples X and Y } + +implementation + +function Correl(X, Y : PVector; Lb, Ub : Integer) : Float; +var + SX, SY, Xbar, Ybar, DX, DY, SSX, SSY, SP : Float; + N, I : Integer; +begin + N := Ub - Lb + 1; + + SX := 0.0; + SY := 0.0; + + for I := Lb to Ub do + begin + SX := SX + X^[I]; + SY := SY + Y^[I]; + end; + + Xbar := SX / N; + Ybar := SY / N; + + SSX := 0.0; + SSY := 0.0; + SP := 0.0; + + for I := Lb to Ub do + begin + DX := X^[I] - Xbar; + DY := Y^[I] - Ybar; + + SSX := SSX + DX * DX; + SSY := SSY + DY * DY; + SP := SP + DX * DY; + end; + + Correl := SP / Sqrt(SSX * SSY); +end; + +end. \ No newline at end of file diff --git a/fpmath/udigamma.pas b/fpmath/udigamma.pas new file mode 100755 index 0000000..5175756 --- /dev/null +++ b/fpmath/udigamma.pas @@ -0,0 +1,170 @@ +{ ****************************************************************** + DiGamma and TriGamma functions. + Contributed by Philip Fletcher (FLETCHP@WESTAT.com) + ****************************************************************** } + +unit udigamma; + +interface + +uses + utypes; + +function DiGamma(X : Float ) : Float; +function TriGamma(X : Float ) : Float; + +implementation + +function DiGamma(X : Float ) : Float; +{ ------------------------------------------------------------------ + + Digamma calculates the Digamma or Psi function = + d ( LOG ( GAMMA ( X ) ) ) / dX + + + Reference: + + J Bernardo, + Psi ( Digamma ) Function, + Algorithm AS 103, + Applied Statistics, + Volume 25, Number 3, pages 315-317, 1976. + + Modified: + + 03 January 2000 + + Parameters: + + Input, real X, the argument of the Digamma function. + 0 < X. + + Output, real Digamma, the value of the Digamma function at X. + ------------------------------------------------------------------ } + +const + c = 20 ; + d1 = -0.57721566490153286061; { DiGamma(1) } + s = 0.00001 ; + + { Sterling coefficient S(n) = B(n) / 2n + where B(n) = Bernoulli number } + +const + S2 = 0.08333333333333333333 ; { B(2)/2 } + S4 = -0.83333333333333333333E-2 ; { B(4)/4 } + S6 = 0.39682539682539682541E-2 ; { B(6)/6 } + S8 = -0.41666666666666666666E-2 ; { B(8)/8 } + S10 = 0.75757575757575757576E-2 ; { B(10)/10 } + S12 = -0.21092796092796092796E-1 ; { B(12)/12 } + S14 = 0.83333333333333333335E-1 ; { B(14)/14 } + S16 = -0.44325980392156862745 ; { B(16)/16 } + +var + dg, p, r, y : Float ; + +begin + if X <= 0.0 then + begin + DiGamma := DefaultVal(FSing, MaxNum); + Exit; + end; + + SetErrCode(FOk); + + if X = 1.0 then + begin + DiGamma := D1; + Exit; + end; + + { Use approximation if argument <= S } + + if X <= s then + dg := d1 - 1.0 / x + else + { Reduce the argument to dg(X + N) where (X + N) >= C } + begin + dg := 0.0; + y := x ; + + while y < c do + begin + dg := dg - 1.0 / y; + y := y + 1.0; + end ; + + { Use Stirling's (actually de Moivre's) expansion if argument > C } + + r := 1.0 / sqr ( y ) ; + p := (((((((S16 * r + S14) * r + S12) * r + S10) * r + S8) * r + + S6) * r + S4) * r + S2) * r ; + dg := dg + ln ( y ) - 0.5 / y - p ; + end ; + + DiGamma := dg ; +end ; + +function TriGamma(X : Float) : Float; +{ ------------------------------------------------------------------ + Trigamma calculates the Trigamma or Psi Prime function = + d**2 ( LOG ( GAMMA ( X ) ) ) / dX**2 + + + Reference: + + Algorithm As121 Appl. Statist. (1978) vol 27, no. 1 + ******************************************************************** } + +const + a = 1.0E-4 ; + b = 20 ; + zero = 0 ; + one = 1 ; + half = 0.5 ; + + { Bernoulli numbers } + +const + B2 = 0.1666666666666667 ; + B4 = -3.333333333333333E-002 ; + B6 = 2.380952380952381E-002 ; + B8 = -3.333333333333333E-002 ; + B10 = 7.575757575757576E-002 ; + B12 = -0.2531135531135531 ; + +var + y, z, Res : Float ; + +begin + if X <= 0.0 then + begin + TriGamma := DefaultVal(FSing, MaxNum); + Exit; + end; + + SetErrCode(FOk); + + Res := 0 ; + z := x ; + + if z <= a then { Use small value approximation } + begin + TriGamma := one / sqr ( z ) ; + Exit ; + end ; + + while z < b do { Increase argument to (x+i) >= b } + begin + Res := Res + one / sqr ( z ) ; + z := z + one ; + end ; + + { Apply asymptotic formula where argument >= b } + y := one / sqr ( z ) ; + Res := Res + Half * y + (One + y * (B2 + y * (B4 + y * (B6 + y * + (B8 + y* (B10 + y * B12)))))) / z; + TriGamma := Res; +end ; + +end. \ No newline at end of file diff --git a/fpmath/udistrib.pas b/fpmath/udistrib.pas new file mode 100755 index 0000000..1376620 --- /dev/null +++ b/fpmath/udistrib.pas @@ -0,0 +1,119 @@ +{ ****************************************************************** + Statistical distribution + ****************************************************************** } + +unit udistrib; + +interface + +uses + utypes; + +procedure DimStatClassVector(var C : PStatClassVector; Ub : Integer); +{ ------------------------------------------------------------------ + Allocates an array of statistical classes: C[0..Ub] + ------------------------------------------------------------------ } + +procedure DelStatClassVector(var C : PStatClassVector; Ub : Integer); +{ ------------------------------------------------------------------ + Deallocates an array of statistical classes: C[0..Ub] + ------------------------------------------------------------------ } + +procedure Distrib(X : PVector; + Lb, Ub : Integer; + A, B, H : Float; + C : PStatClassVector); +{ ------------------------------------------------------------------ + Distributes the values of array X[Lb..Ub] into M classes with + equal width H, according to the following scheme: + + C[1] C[2] C[M] + ]-------]-------].......]-------]-------] + A A+H A+2H B + + such that B = A + M * H + ------------------------------------------------------------------ } + +implementation + +procedure DimStatClassVector(var C : PStatClassVector; Ub : Integer); +var + I : Integer; +begin + { Check bounds } + if (Ub < 0) or (Ub > MAX_CLS) then + begin + C := nil; + Exit; + end; + + { Allocate vector } + GetMem(C, (Ub + 1) * SizeOf(StatClass)); + if C = nil then Exit; + + { Initialize vector } + for I := 0 to Ub do + with C^[I] do + begin + Inf := 0.0; + Sup := 0.0; + N := 0; + F := 0.0; + D := 0.0; + end; +end; + +procedure DelStatClassVector(var C : PStatClassVector; Ub : Integer); +begin + if C <> nil then + begin + FreeMem(C, (Ub + 1) * SizeOf(StatClass)); + C := nil; + end; +end; + +function NumCls(X, A, H : Float) : Integer; +{ Returns the index of the class containing X + A is the lower bound of the first class + H is the class width } +var + Y : Float; + I : Integer; +begin + Y := (X - A) / H; + I := Trunc(Y); + if Y <> I then Inc(I); + NumCls := I; +end; + +procedure Distrib(X : PVector; + Lb, Ub : Integer; + A, B, H : Float; + C : PStatClassVector); +var + I, K, M, Nt : Integer; +begin + M := Round((B - A) / H); + + for K := 1 to M do + C^[K].N := 0; + + for I := Lb to Ub do + begin + K := NumCls(X^[I], A, H); + Inc(C^[K].N); + end; + + Nt := Ub - Lb + 1; + + for K := 1 to M do + with C^[K] do + begin + Inf := A + (K - 1) * H; + Sup := Inf + H; + F := N / Nt; + D := F / H; + end; +end; + +end. \ No newline at end of file diff --git a/fpmath/ueigval.pas b/fpmath/ueigval.pas new file mode 100755 index 0000000..1cca61d --- /dev/null +++ b/fpmath/ueigval.pas @@ -0,0 +1,37 @@ +{ ****************************************************************** + Eigenvalues of a general square matrix + ****************************************************************** } + +unit ueigval; + +interface + +uses + utypes, ubalance, uelmhes, uhqr; + +procedure EigenVals(A : PMatrix; + Lb, Ub : Integer; + Lambda : PCompVector); + +implementation + +procedure EigenVals(A : PMatrix; + Lb, Ub : Integer; + Lambda : PCompVector); + var + I_low, I_igh : Integer; + Scale : PVector; + I_int : PIntVector; + begin + DimVector(Scale, Ub); + DimIntVector(I_Int, Ub); + + Balance(A, Lb, Ub, I_low, I_igh, Scale); + ElmHes(A, Lb, Ub, I_low, I_igh, I_int); + Hqr(A, Lb, Ub, I_low, I_igh, Lambda); + + DelVector(Scale, Ub); + DelIntVector(I_Int, Ub); + end; + +end. diff --git a/fpmath/ueigvec.pas b/fpmath/ueigvec.pas new file mode 100755 index 0000000..f2b9dfb --- /dev/null +++ b/fpmath/ueigvec.pas @@ -0,0 +1,43 @@ +{ ****************************************************************** + Eigenvalues and eigenvectors of a general square matrix + ****************************************************************** } + +unit ueigvec; + +interface + +uses + utypes, ubalance, uelmhes, ueltran, uhqr2, ubalbak; + +procedure EigenVect(A : PMatrix; + Lb, Ub : Integer; + Lambda : PCompVector; + V : PMatrix); + +implementation + +procedure EigenVect(A : PMatrix; + Lb, Ub : Integer; + Lambda : PCompVector; + V : PMatrix); + var + I_low, I_igh : Integer; + Scale : PVector; + I_Int : PIntVector; + begin + DimVector(Scale, Ub); + DimIntVector(I_Int, Ub); + + Balance(A, Lb, Ub, I_low, I_igh, Scale); + ElmHes(A, Lb, Ub, I_low, I_igh, I_int); + Eltran(A, Lb, Ub, I_low, I_igh, I_int, V); + Hqr2(A, Lb, Ub, I_low, I_igh, Lambda, V); + + if MathErr = 0 then + BalBak(V, Lb, Ub, I_low, I_igh, Scale, Ub); + + DelVector(Scale, Ub); + DelIntVector(I_Int, Ub); + end; + +end. diff --git a/fpmath/uelmhes.pas b/fpmath/uelmhes.pas new file mode 100755 index 0000000..7bebbcb --- /dev/null +++ b/fpmath/uelmhes.pas @@ -0,0 +1,110 @@ +{ ****************************************************************** + Reduction of a square matrix to upper Hessenberg form + ****************************************************************** } + +unit uelmhes; + +interface + +uses + utypes; + +procedure ElmHes(A : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + I_int : PIntVector); + +implementation + +procedure ElmHes(A : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + I_int : PIntVector); +{ ------------------------------------------------------------------ + This procedure is a translation of the EISPACK subroutine Elmhes + + Given a real general matrix, this procedure reduces a submatrix + situated in rows and columns I_low through I_igh to upper + Hessenberg form by stabilized elementary similarity transformations. + + On input: + + A contains the input matrix. + + Lb, Ub are the lowest and highest indices + of the elements of A. + + I_low and I_igh are integers determined by the balancing procedure + Balance. If Balance has not been used, set I_low = Lb, I_igh = Ub. + + On output: + + A contains the Hessenberg matrix. The multipliers which were used + in the reduction are stored in the remaining triangle under the + Hessenberg matrix. + + I_int contains information on the rows and columns interchanged + in the reduction. Only elements I_low through I_igh are used. + ------------------------------------------------------------------ } + + var + I, J, M, La, Kp1, Mm1, Mp1 : Integer; + X, Y : Float; + + begin + La := I_igh - 1; + Kp1 := I_low + 1; + if La < Kp1 then Exit; + + for M := Kp1 to La do + begin + Mm1 := M - 1; + X := 0.0; + I := M; + + for J := M to I_igh do + if Abs(A^[J]^[Mm1]) > Abs(X) then + begin + X := A^[J]^[Mm1]; + I := J; + end; + + I_int^[M] := I; + + { Interchange rows and columns of A } + if I <> M then + begin + for J := Mm1 to Ub do + begin + Y := A^[I]^[J]; + A^[I]^[J] := A^[M]^[J]; + A^[M]^[J] := Y; + end; + + for J := Lb to I_igh do + begin + Y := A^[J]^[I]; + A^[J]^[I] := A^[J]^[M]; + A^[J]^[M] := Y; + end; + end; + + if X <> 0.0 then + begin + Mp1 := M + 1; + for I := Mp1 to I_igh do + begin + Y := A^[I]^[Mm1]; + if Y <> 0.0 then + begin + Y := Y / X; + A^[I]^[Mm1] := Y; + for J := M to Ub do + A^[I]^[J] := A^[I]^[J] - Y * A^[M]^[J]; + for J := Lb to I_igh do + A^[J]^[M] := A^[J]^[M] + Y * A^[J]^[I]; + end; + end; + end; + end; + end; + +end. diff --git a/fpmath/ueltran.pas b/fpmath/ueltran.pas new file mode 100755 index 0000000..8e094f2 --- /dev/null +++ b/fpmath/ueltran.pas @@ -0,0 +1,79 @@ +{ ****************************************************************** + Save transformations used by ElmHes + ****************************************************************** } + +unit ueltran; + +interface + +uses + utypes; + +procedure Eltran(A : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + I_int : PIntVector; + Z : PMatrix); + +implementation + +procedure Eltran(A : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + I_int : PIntVector; + Z : PMatrix); +{ ------------------------------------------------------------------ + This procedure is a translation of the EISPACK subroutine Eltran. + + This procedure accumulates the stabilized elementary similarity + transformations used in the reduction of a real general matrix + to upper Hessenberg form by Elmhes. + + On input: + + A contains the multipliers which were used in the reduction + by Elmhes in its lower triangle below the subdiagonal. + + Lb, Ub are the lowest and highest indices + of the elements of A + + I_low and I_igh are integers determined by the balancing procedure + Balance. If Balance has not been used, set I_low=Lb, I_igh=Ub. + + I_int contains information on the rows and columns interchanged in + the reduction by Elmhes. Only elements I_low through I_igh are used. + + On output: + + Z contains the transformation matrix produced in the reduction by + Elmhes. + ------------------------------------------------------------------ } + + var + I, J, Mp, Mp1 : Integer; + + begin + { Initialize Z to identity matrix } + for I := Lb to Ub do + for J := Lb to Ub do + if I = J then Z^[I]^[J] := 1.0 else Z^[I]^[J] := 0.0; + + if I_igh < I_low then Exit; + + for Mp := I_igh - 1 downto I_low + 1 do + begin + Mp1 := Mp + 1; + for I := Mp1 to I_igh do + Z^[I]^[Mp] := A^[I]^[Mp - 1]; + I := I_int^[Mp]; + if I <> Mp then + begin + for J := Mp to I_igh do + begin + Z^[Mp]^[J] := Z^[I]^[J]; + Z^[I]^[J] := 0.0; + end; + Z^[I]^[Mp] := 1.0; + end; + end; + end; + +end. diff --git a/fpmath/uexpdist.pas b/fpmath/uexpdist.pas new file mode 100755 index 0000000..b942b43 --- /dev/null +++ b/fpmath/uexpdist.pas @@ -0,0 +1,64 @@ +{ ****************************************************************** + Exponential distribution + ****************************************************************** } + +unit uexpdist; + +interface + +uses + utypes; + +function DExpo(A, X : Float) : Float; +{ Density of exponential distribution with parameter A } + +function FExpo(A, X : Float) : Float; +{ Cumulative probability function for exponential dist. with parameter A } + +implementation + +function DExpo(A, X : Float) : Float; +var + Y : Float; +begin + if (A <= 0.0) or (X < 0.0) then + begin + DExpo := DefaultVal(FDomain, 0.0); + Exit; + end; + + Y := - A * X; + + if Y < MinLog then + begin + DExpo := DefaultVal(FUnderflow, 0.0); + Exit; + end; + + SetErrCode(FOk); + DExpo := A * Exp(Y); +end; + +function FExpo(A, X : Float) : Float; +var + Y : Float; +begin + if (A <= 0.0) or (X < 0.0) then + begin + FExpo := DefaultVal(FDomain, 0.0); + Exit; + end; + + Y := - A * X; + + if Y < MinLog then + begin + FExpo := DefaultVal(FUnderflow, 1.0); + Exit; + end; + + SetErrCode(FOk); + FExpo := 1.0 - Exp(Y); +end; + +end. \ No newline at end of file diff --git a/fpmath/ufact.pas b/fpmath/ufact.pas new file mode 100755 index 0000000..120621c --- /dev/null +++ b/fpmath/ufact.pas @@ -0,0 +1,68 @@ +{ ****************************************************************** + Factorial + ****************************************************************** } + +unit ufact; + +interface + +uses + utypes, ugamma; + +function Fact(N : Integer) : Float; + +implementation + +const + NFact = 33; + + FactArray : array[0..NFact] of Float = + (1.0, + 1.0, + 2.0, + 6.0, + 24.0, + 120.0, + 720.0, + 5040.0, + 40320.0, + 362880.0, + 3628800.0, + 39916800.0, + 479001600.0, + 6227020800.0, + 87178291200.0, + 1307674368000.0, + 20922789888000.0, + 355687428096000.0, + 6402373705728000.0, + 121645100408832000.0, + 2432902008176640000.0, + 51090942171709440000.0, + 1124000727777607680000.0, + 25852016738884976640000.0, + 620448401733239439360000.0, + 15511210043330985984000000.0, + 403291461126605635584000000.0, + 10888869450418352160768000000.0, + 304888344611713860501504000000.0, + 8841761993739701954543616000000.0, + 265252859812191058636308480000000.0, + 8222838654177922817725562880000000.0, + 263130836933693530167218012160000000.0, + 8683317618811886495518194401280000000.0); + + function Fact(N : Integer) : Float; + begin + SetErrCode(FOk); + if N < 0 then + Fact := DefaultVal(FDomain, 1.0) + else if N > MaxFac then + Fact := DefaultVal(FOverflow, MaxNum) + else if N <= NFact then + Fact := FactArray[N] + else + Fact := Gamma(N + 1); + end; + +end. \ No newline at end of file diff --git a/fpmath/ufft.pas b/fpmath/ufft.pas new file mode 100755 index 0000000..10c1cc0 --- /dev/null +++ b/fpmath/ufft.pas @@ -0,0 +1,325 @@ +(*========================================================================== + + fourier.pas - Don Cross <dcross@intersrv.com> + + Modified by Jean Debord <JDebord@compuserve.com> for use with TP Math. + + This is a Turbo Pascal Unit for calculating the Fast Fourier Transform + (FFT) and the Inverse Fast Fourier Transform (IFFT). + Visit the following URL for the latest version of this code. + This page also has a C/C++ version, and a brief discussion of the + theory behind the FFT algorithm. + + http://www.intersrv.com/~dcross/fft.html#pascal + + Revision history [most recent first]: + +2007 December 10 [Jean Debord] + Increased the theoretical number of points to about 2^26 + for a 32-bit compiler. The exact exponent is returned by + function MaxPower. + +2007 January 4 [Jean Debord] + Modified for new TPMath version. Renamed as ufft.pas + Now uses complex arrays. + +1996 December 11 [Don Cross] + Improved documentation of the procedure CalcFrequency. + Fixed some messed up comments in procedure IFFT. + +1996 December 6 [Don Cross] + Made procedure 'fft_integer' more efficient when buffer size changes + in successive calls: the buffer is now only resized when the input + has more samples, not a differing number of samples. + Also changed the way 'fft_integer_cleanup' works so that it is + more "bullet-proof". + +1996 December 4 [Don Cross] + Adding the procedure 'CalcFrequency', which calculates the FFT + at a specific frequency index p=0..n-1, instead of the whole + FFT. This is O(n^2) instead of O(n*log(n)). + +1996 November 30 [Don Cross] + Adding a routine to allow FFT of an input array of integers. + It is called 'fft_integer'. + +1996 November 18 [Don Cross] + Added some comments. + +1996 November 17 [Don Cross] + Wrote and debugged first version. + +==========================================================================*) + +unit ufft; + +interface + +uses + utypes, umath; + +(*--------------------------------------------------------------------------- + procedure FFT + + Calculates the Fast Fourier Transform of the array of complex + numbers represented by 'InArray' to produce the output complex + numbers in 'OutArray'. +---------------------------------------------------------------------------*) +procedure FFT(NumSamples : LongInt; + InArray, OutArray : PCompVector); + +(*--------------------------------------------------------------------------- + procedure IFFT + + Calculates the Inverse Fast Fourier Transform of the array of + complex numbers represented by 'InArray' to produce the output + complex numbers in 'OutArray'. +---------------------------------------------------------------------------*) +procedure IFFT(NumSamples : LongInt; + InArray, OutArray : PCompVector); + +(*--------------------------------------------------------------------------- + procedure FFT_Integer + + Same as procedure FFT, but uses Integer input arrays instead of + double. Make sure you call FFT_Integer_Cleanup after the last + time you call FFT_Integer to free up memory it allocates. +---------------------------------------------------------------------------*) +procedure FFT_Integer(NumSamples : LongInt; + RealIn, ImagIn : PIntVector; + OutArray : PCompVector); + +(*-------------------------------------------------------------------------- + procedure FFT_Integer_Cleanup + + If you call the procedure 'FFT_Integer', you must call + 'FFT_Integer_Cleanup' after the last time you call 'FFT_Integer' + in order to free up dynamic memory. +--------------------------------------------------------------------------*) +procedure FFT_Integer_Cleanup; + +(*-------------------------------------------------------------------------- + procedure CalcFrequency + + This procedure calculates the complex frequency sample at a given + index directly. Use this instead of 'FFT' when you only need one + or two frequency samples, not the whole spectrum. + + It is also useful for calculating the Discrete Fourier Transform (DFT) + of a number of data which is not an integer power of 2. For example, + you could calculate the DFT of 100 points instead of rounding up to + 128 and padding the extra 28 array slots with zeroes. +--------------------------------------------------------------------------*) +procedure CalcFrequency(NumSamples, FrequencyIndex : LongInt; + InArray : PCompVector; + var FT : Complex); + +implementation + +const + TempArraySize : Integer = 0; { Flag that buffer Temp is not allocated } + +var + Temp : PCompVector; + + function MaxPower : LongInt; + var + M : Float; + begin + M := MAX_COMP; + MaxPower := Trunc(Log2(M)); + end; + + function IsPowerOfTwo(X : LongInt) : Boolean; + var + I, Y : LongInt; + begin + Y := 2; + for I := 1 to MaxPower do + begin + if X = Y then + begin + IsPowerOfTwo := True; + Exit; + end; + Y := Y shl 1; + end; + IsPowerOfTwo := False; + end; + + function NumberOfBitsNeeded(PowerOfTwo : LongInt) : Integer; + var + I : Integer; + begin + for I := 0 to MaxPower do + begin + if (PowerOfTwo and (1 shl I)) <> 0 then + begin + NumberOfBitsNeeded := I; + Exit; + end; + end; + end; + + function ReverseBits(Index, NumBits : LongInt) : Integer; + var + I, Rev : Integer; + begin + Rev := 0; + for I := 0 to NumBits - 1 do + begin + Rev := (Rev shl 1) or (Index and 1); + Index := Index shr 1; + end; + ReverseBits := Rev; + end; + + procedure FourierTransform(AngleNumerator : Float; + NumSamples : LongInt; + InArray, OutArray : PCompVector); + var + NumBits, I, J, K, N, BlockSize, BlockEnd : LongInt; + Delta_angle, Delta_ar, Alpha, Beta, Tr, Ti, Ar, Ai : Float; + begin + if not IsPowerOfTwo(NumSamples) or (NumSamples < 2) then + begin + SetErrCode(-1); + Exit; + end; + + SetErrCode(0); + + NumBits := NumberOfBitsNeeded(NumSamples); + for I := 0 to NumSamples - 1 do + begin + J := ReverseBits(I, NumBits); + OutArray^[J].X := InArray^[I].X; + OutArray^[J].Y := InArray^[I].Y; + end; + + BlockEnd := 1; + BlockSize := 2; + while BlockSize <= NumSamples do + begin + Delta_angle := AngleNumerator / BlockSize; + Alpha := Sin(0.5 * Delta_angle); + Alpha := 2.0 * Alpha * Alpha; + Beta := Sin(Delta_angle); + + I := 0; + while I < NumSamples do + begin + Ar := 1.0; (* cos(0) *) + Ai := 0.0; (* sin(0) *) + + J := I; + for N := 0 to BlockEnd - 1 do + begin + K := J + BlockEnd; + Tr := Ar * OutArray^[K].X - Ai * OutArray^[K].Y; + Ti := Ar * OutArray^[K].Y + Ai * OutArray^[K].X; + OutArray^[K].X := OutArray^[J].X - Tr; + OutArray^[K].Y := OutArray^[J].Y - Ti; + OutArray^[J].X := OutArray^[J].X + Tr; + OutArray^[J].Y := OutArray^[J].Y + Ti; + Delta_ar := Alpha * Ar + Beta * Ai; + Ai := Ai - (Alpha * Ai - Beta * Ar); + Ar := Ar - Delta_ar; + Inc(J); + end; + + I := I + BlockSize; + end; + + BlockEnd := BlockSize; + BlockSize := BlockSize shl 1; + end; + end; + + procedure FFT(NumSamples : LongInt; + InArray, OutArray : PCompVector); + begin + FourierTransform(2 * PI, NumSamples, InArray, OutArray); + end; + + procedure IFFT(NumSamples : LongInt; + InArray, OutArray : PCompVector); + var + I : Integer; + begin + FourierTransform(- 2 * PI, NumSamples, InArray, OutArray); + if MathErr <> 0 then Exit; + + { Normalize the resulting time samples } + for I := 0 to NumSamples - 1 do + begin + OutArray^[I].X := OutArray^[I].X / NumSamples; + OutArray^[I].Y := OutArray^[I].Y / NumSamples; + end; + end; + + procedure FFT_Integer(NumSamples : LongInt; + RealIn, ImagIn : PIntVector; + OutArray : PCompVector); + var + I : Integer; + begin + if NumSamples > TempArraySize then + begin + FFT_Integer_Cleanup; { free up memory in case we already have some } + DimCompVector(Temp, NumSamples); + TempArraySize := NumSamples; + end; + + for I := 0 to NumSamples - 1 do + begin + Temp^[I].X := RealIn^[I]; + Temp^[I].Y := ImagIn^[I]; + end; + + FourierTransform(2 * PI, NumSamples, Temp, OutArray); + end; + + procedure FFT_Integer_Cleanup; + begin + if TempArraySize > 0 then + begin + DelCompVector(Temp, TempArraySize); + TempArraySize := 0; + end; + end; + + procedure CalcFrequency(NumSamples, FrequencyIndex : LongInt; + InArray : PCompVector; + var FT : Complex); + var + K : Integer; + Cos1, Cos2, Cos3 : Float; + Sin1, Sin2, Sin3 : Float; + Theta, Beta : Float; + begin + FT.X := 0.0; + FT.Y := 0.0; + Theta := 2 * PI * FrequencyIndex / NumSamples; + Sin1 := Sin(- 2 * Theta); + Sin2 := Sin(- Theta); + Cos1 := Cos(- 2 * Theta); + Cos2 := Cos(- Theta); + Beta := 2 * Cos2; + for K := 0 to NumSamples - 1 do + begin + { Update trig values } + Sin3 := Beta * Sin2 - Sin1; + Sin1 := Sin2; + Sin2 := Sin3; + + Cos3 := Beta * Cos2 - Cos1; + Cos1 := Cos2; + Cos2 := Cos3; + + FT.X := FT.X + InArray^[K].X * Cos3 - InArray^[K].Y * Sin3; + FT.Y := FT.Y + InArray^[K].Y * Cos3 + InArray^[K].X * Sin3; + end; + end; + +end. diff --git a/fpmath/ugamdist.pas b/fpmath/ugamdist.pas new file mode 100755 index 0000000..078a0a8 --- /dev/null +++ b/fpmath/ugamdist.pas @@ -0,0 +1,145 @@ +{ ****************************************************************** + Probability functions related to the Gamma function + ****************************************************************** } + +unit ugamdist; + +interface + +uses + utypes, ugamma; + +function DBeta(A, B, X : Float) : Float; +{ Density of Beta distribution with parameters A and B } + +function DGamma(A, B, X : Float) : Float; +{ Density of Gamma distribution with parameters A and B } + +function DKhi2(Nu : Integer; X : Float) : Float; +{ Density of Khi-2 distribution with Nu d.o.f. } + +function DStudent(Nu : Integer; X : Float) : Float; +{ Density of Student distribution with Nu d.o.f. } + +function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; +{ Density of Fisher-Snedecor distribution with Nu1 and Nu2 d.o.f. } + +implementation + +function DBeta(A, B, X : Float) : Float; +var + L : Float; +begin + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + begin + DBeta := DefaultVal(FDomain, 0.0); + Exit; + end; + + if X = 0.0 then + begin + if A < 1.0 then + DBeta := DefaultVal(FSing, MaxNum) + else + DBeta := DefaultVal(FOk, 0.0); + Exit; + end; + + if X = 1.0 then + begin + if B < 1.0 then + DBeta := DefaultVal(FSing, MaxNum) + else + DBeta := DefaultVal(FOk, 0.0); + Exit; + end; + + L := LnGamma(A + B) - LnGamma(A) - LnGamma(B) + + (A - 1.0) * Ln(X) + (B - 1.0) * Ln(1.0 - X); + + if L < MinLog then + DBeta := DefaultVal(FUnderflow, 0.0) + else + DBeta := DefaultVal(FOk, Exp(L)); +end; + +function DGamma(A, B, X : Float) : Float; +var + L : Float; +begin + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) then + begin + DGamma := DefaultVal(FDomain, 0.0); + Exit; + end; + + if X = 0.0 then + begin + if A < 1.0 then + DGamma := DefaultVal(FSing, MaxNum) + else if A = 1.0 then + DGamma := DefaultVal(FOk, B) + else + DGamma := DefaultVal(FOk, 0.0); + Exit; + end; + + L := A * Ln(B) - LnGamma(A) + (A - 1.0) * Ln(X) - B * X; + + if L < MinLog then + DGamma := DefaultVal(FUnderflow, 0.0) + else + DGamma := DefaultVal(FOk, Exp(L)); +end; + +function DKhi2(Nu : Integer; X : Float) : Float; +begin + DKhi2 := DGamma(0.5 * Nu, 0.5, X) +end; + +function DStudent(Nu : Integer; X : Float) : Float; +var + L, P, Q : Float; +begin + if Nu < 1 then + begin + DStudent := DefaultVal(FDomain, 0.0); + Exit; + end; + + P := 0.5 * (Nu + 1); + Q := 0.5 * Nu; + + L := LnGamma(P) - LnGamma(Q) - 0.5 * Ln(Nu * Pi) - + P * Ln(1.0 + X * X / Nu); + + if L < MinLog then + DStudent := DefaultVal(FUnderflow, 0.0) + else + DStudent := DefaultVal(FOk, Exp(L)); +end; + +function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; +var + L, P1, P2, R, S : Float; +begin + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + begin + DSnedecor := DefaultVal(FDomain, 0.0); + Exit; + end; + + R := Nu1 / Nu2; + P1 := 0.5 * Nu1; + P2 := 0.5 * Nu2; + S := P1 + P2; + L := LnGamma(S) - LnGamma(P1) - LnGamma(P2) + + P1 * Ln(R) + (P1 - 1.0) * Ln(X) - S * Ln(1.0 + R * X); + + if L < MinLog then + DSnedecor := DefaultVal(FUnderflow, 0.0) + else + DSnedecor := DefaultVal(FOk, Exp(L)); +end; + +end. \ No newline at end of file diff --git a/fpmath/ugamma.pas b/fpmath/ugamma.pas new file mode 100755 index 0000000..1c57981 --- /dev/null +++ b/fpmath/ugamma.pas @@ -0,0 +1,344 @@ +{ ****************************************************************** + Gamma function and related functions. + Translated from C code in Cephes library (http://www.moshier.net) + ****************************************************************** } + +unit ugamma; + +interface + +uses + utypes, upolev; + +function SgnGamma(X : Float) : Integer; +{ Sign of Gamma function } + +function Stirling(X : Float) : Float; +{ Stirling's formula for the Gamma function } + +function StirLog(X : Float) : Float; +{ Approximate Ln(Gamma) by Stirling's formula, for X >= 13 } + +function Gamma(X : Float) : Float; +{ Gamma function } + +function LnGamma(X : Float) : Float; +{ Logarithm of Gamma function } + +implementation + + function SgnGamma(X : Float) : Integer; + begin + if X > 0.0 then + SgnGamma := 1 + else if Odd(Trunc(Abs(X))) then + SgnGamma := 1 + else + SgnGamma := - 1; + end; + + function Stirling(X : Float) : Float; + { Stirling's formula for the gamma function + Gamma(x) = Sqrt(2*Pi) x^(x-.5) exp(-x) (1 + 1/x P(1/x)) + where P(x) is a polynomial } + const + STIR : TabCoef = ( + 7.147391378143610789273E-4, + - 2.363848809501759061727E-5, + - 5.950237554056330156018E-4, + 6.989332260623193171870E-5, + 7.840334842744753003862E-4, + - 2.294719747873185405699E-4, + - 2.681327161876304418288E-3, + 3.472222222230075327854E-3, + 8.333333333333331800504E-2, + 0); + + var + W, P : Float; + begin + W := 1.0 / X; + if X > 1024.0 then + begin + P := 6.97281375836585777429E-5 * W + 7.84039221720066627474E-4; + P := P * W - 2.29472093621399176955E-4; + P := P * W - 2.68132716049382716049E-3; + P := P * W + 3.47222222222222222222E-3; + P := P * W + 8.33333333333333333333E-2; + end + else + P := PolEvl(W, STIR, 8); + Stirling := Sqrt2Pi * Exp((X - 0.5) * Ln(X) - X) * (1.0 + W * P); + end; + + function GamSmall(X1, Z : Float) : Float; + { Gamma function for small values of the argument } + const + S : TabCoef = ( + - 1.193945051381510095614E-3, + 7.220599478036909672331E-3, + - 9.622023360406271645744E-3, + - 4.219773360705915470089E-2, + 1.665386113720805206758E-1, + - 4.200263503403344054473E-2, + - 6.558780715202540684668E-1, + 5.772156649015328608253E-1, + 1.000000000000000000000E0, + 0); + + SN : TabCoef = ( + 1.133374167243894382010E-3, + 7.220837261893170325704E-3, + 9.621911155035976733706E-3, + - 4.219773343731191721664E-2, + - 1.665386113944413519335E-1, + - 4.200263503402112910504E-2, + 6.558780715202536547116E-1, + 5.772156649015328608727E-1, + - 1.000000000000000000000E0, + 0); + + var + P : Float; + begin + if X1 = 0.0 then + begin + GamSmall := DefaultVal(FSing, MaxNum); + Exit; + end; + if X1 < 0.0 then + begin + X1 := - X1; + P := PolEvl(X1, SN, 8); + end + else + P := PolEvl(X1, S, 8); + GamSmall := Z / (X1 * P); + end; + + function StirLog(X : Float) : Float; + { Approximate Ln(Gamma) by Stirling's formula, for X >= 13 } + const + P : TabCoef = ( + 4.885026142432270781165E-3, + - 1.880801938119376907179E-3, + 8.412723297322498080632E-4, + - 5.952345851765688514613E-4, + 7.936507795855070755671E-4, + - 2.777777777750349603440E-3, + 8.333333333333331447505E-2, + 0, 0, 0); + + var + Q, W : Float; + begin + Q := Ln(X) * (X - 0.5) - X; + Q := Q + LnSqrt2Pi; + if X > 1.0E+10 then + StirLog := Q + else + begin + W := 1.0 / Sqr(X); + StirLog := Q + PolEvl(W, P, 6) / X; + end; + end; + + function Gamma(X : Float) : Float; + const + P : TabCoef = ( + 4.212760487471622013093E-5, + 4.542931960608009155600E-4, + 4.092666828394035500949E-3, + 2.385363243461108252554E-2, + 1.113062816019361559013E-1, + 3.629515436640239168939E-1, + 8.378004301573126728826E-1, + 1.000000000000000000009E0, + 0, 0); + + Q : TabCoef = ( + - 1.397148517476170440917E-5, + 2.346584059160635244282E-4, + - 1.237799246653152231188E-3, + - 7.955933682494738320586E-4, + 2.773706565840072979165E-2, + - 4.633887671244534213831E-2, + - 2.243510905670329164562E-1, + 4.150160950588455434583E-1, + 9.999999999999999999908E-1, + 0); + + var + SgnGam, N : Integer; + A, X1, Z : Float; + begin + SetErrCode(FOk); + SgnGam := SgnGamma(X); + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + Gamma := DefaultVal(FSing, SgnGam * MaxNum); + Exit; + end; + + if X > MaxGam then + begin + Gamma := DefaultVal(FOverflow, MaxNum); + Exit; + end; + + A := Abs(X); + if A > 13.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := A - N; + end; + Z := Abs(A * Sin(Pi * Z)) * Stirling(A); + if Z <= Pi / MaxNum then + begin + Gamma := DefaultVal(FOverflow, SgnGam * MaxNum); + Exit; + end; + Z := PI / Z; + end + else + Z := Stirling(X); + Gamma := SgnGam * Z; + end + else + begin + Z := 1.0; + X1 := X; + while X1 >= 3.0 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < - 0.03125 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if X1 <= 0.03125 then + Gamma := GamSmall(X1, Z) + else + begin + while X1 < 2.0 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if (X1 = 2.0) or (X1 = 3.0) then + Gamma := Z + else + begin + X1 := X1 - 2.0; + Gamma := Z * PolEvl(X1, P, 7) / PolEvl(X1, Q, 8); + end; + end; + end; + end; + + function LnGamma(X : Float) : Float; + const + P : TabCoef = ( + - 2.163690827643812857640E3, + - 8.723871522843511459790E4, + - 1.104326814691464261197E6, + - 6.111225012005214299996E6, + - 1.625568062543700591014E7, + - 2.003937418103815175475E7, + - 8.875666783650703802159E6, + 0, 0, 0); + + Q : TabCoef = ( + - 5.139481484435370143617E2, + - 3.403570840534304670537E4, + - 6.227441164066219501697E5, + - 4.814940379411882186630E6, + - 1.785433287045078156959E7, + - 3.138646407656182662088E7, + - 2.099336717757895876142E7, + 0, 0, 0); + + var + N : Integer; + A, X1, Z : Float; + begin + SetErrCode(FOk); + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + LnGamma := DefaultVal(FSing, MaxNum); + Exit; + end; + + if X > MaxLgm then + begin + LnGamma := DefaultVal(FOverflow, MaxNum); + Exit; + end; + + A := Abs(X); + if A > 34.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := N - A; + end; + Z := A * Sin(Pi * Z); + if Z = 0.0 then + begin + LnGamma := DefaultVal(FOverflow, MaxNum); + Exit; + end; + Z := LnPi - Ln(Z) - StirLog(A); + end + else + Z := StirLog(X); + LnGamma := Z; + end + else if X < 13.0 then + begin + Z := 1.0; + X1 := X; + while X1 >= 3 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < 2.0 do + begin + if Abs(X1) <= 0.03125 then + begin + LnGamma := Ln(Abs(GamSmall(X1, Z))); + Exit; + end; + Z := Z / X1; + X1 := X1 + 1.0; + end; + if Z < 0.0 then Z := - Z; + if X1 = 2.0 then + LnGamma := Ln(Z) + else + begin + X1 := X1 - 2.0; + LnGamma := X1 * PolEvl(X1, P, 6) / P1Evl(X1, Q, 7) + Ln(Z); + end; + end + else + LnGamma := StirLog(X); + end; + +end. \ No newline at end of file diff --git a/fpmath/ugausjor.pas b/fpmath/ugausjor.pas new file mode 100755 index 0000000..062bd83 --- /dev/null +++ b/fpmath/ugausjor.pas @@ -0,0 +1,159 @@ +{ ****************************************************************** + Solution of a system of linear equations by Gauss-Jordan method + ****************************************************************** } + +unit ugausjor; + +interface + +uses + utypes, uminmax; + +procedure GaussJordan(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + var Det : Float); +{ ------------------------------------------------------------------ + Transforms a matrix according to the Gauss-Jordan method + ------------------------------------------------------------------ + Input parameters : A = system matrix + Lb = lower matrix bound in both dim. + Ub1, Ub2 = upper matrix bounds + ------------------------------------------------------------------ + Output parameters: A = transformed matrix + Det = determinant of A + ------------------------------------------------------------------ + Possible results : MatOk : No error + MatErrDim : Non-compatible dimensions + MatSing : Singular matrix + ------------------------------------------------------------------ } + +implementation + +procedure GaussJordan(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + var Det : Float); +var + Pvt : Float; { Pivot } + Ik, Jk : Integer; { Pivot's row and column } + I, J, K : Integer; { Loop variables } + T : Float; { Temporary variable } + PRow, PCol : PIntVector; { Stores pivot's row and column } + MCol : PVector; { Stores a column of matrix A } + + procedure Terminate(ErrCode : Integer); + { Set error code and deallocate arrays } + begin + DelIntVector(PRow, Ub1); + DelIntVector(PCol, Ub1); + DelVector(MCol, Ub1); + SetErrCode(ErrCode); + end; + +begin + if Ub1 > Ub2 then + begin + SetErrCode(MatErrDim); + Exit + end; + + DimIntVector(PRow, Ub1); + DimIntVector(PCol, Ub1); + DimVector(MCol, Ub1); + + Det := 1.0; + + K := Lb; + while K <= Ub1 do + begin + { Search for largest pivot in submatrix A[K..Ub1, K..Ub1] } + Pvt := A^[K]^[K]; + Ik := K; + Jk := K; + for I := K to Ub1 do + for J := K to Ub1 do + if Abs(A^[I]^[J]) > Abs(Pvt) then + begin + Pvt := A^[I]^[J]; + Ik := I; + Jk := J; + end; + + { Store pivot's position } + PRow^[K] := Ik; + PCol^[K] := Jk; + + { Update determinant } + Det := Det * Pvt; + if Ik <> K then Det := - Det; + if Jk <> K then Det := - Det; + + { Too weak pivot ==> quasi-singular matrix } + if Abs(Pvt) < MachEp then + begin + Terminate(MatSing); + Exit + end; + + { Exchange current row (K) with pivot row (Ik) } + if Ik <> K then + for J := Lb to Ub2 do + FSwap(A^[Ik]^[J], A^[K]^[J]); + + { Exchange current column (K) with pivot column (Jk) } + if Jk <> K then + for I := Lb to Ub1 do + FSwap(A^[I]^[Jk], A^[I]^[K]); + + { Store column K of matrix A into MCol + and set this column to zero } + for I := Lb to Ub1 do + if I <> K then + begin + MCol^[I] := A^[I]^[K]; + A^[I]^[K] := 0.0; + end + else + begin + MCol^[I] := 0.0; + A^[I]^[K] := 1.0; + end; + + { Transform pivot row } + T := 1.0 / Pvt; + for J := Lb to Ub2 do + A^[K]^[J] := T * A^[K]^[J]; + + { Transform other rows } + for I := Lb to Ub1 do + if I <> K then + begin + T := MCol^[I]; + for J := Lb to Ub2 do + A^[I]^[J] := A^[I]^[J] - T * A^[K]^[J]; + end; + + Inc(K); + end; + + { Exchange lines of inverse matrix } + for I := Ub1 downto Lb do + begin + Ik := PCol^[I]; + if Ik <> I then + for J := Lb to Ub2 do + FSwap(A^[I]^[J], A^[Ik]^[J]); + end; + + { Exchange columns of inverse matrix } + for J := Ub1 downto Lb do + begin + Jk := PRow^[J]; + if Jk <> J then + for I := Lb to Ub1 do + FSwap(A^[I]^[J], A^[I]^[Jk]); + end; + + Terminate(MatOk); +end; + +end. diff --git a/fpmath/ugausleg.pas b/fpmath/ugausleg.pas new file mode 100755 index 0000000..30bdc2b --- /dev/null +++ b/fpmath/ugausleg.pas @@ -0,0 +1,120 @@ +{ ****************************************************************** + Gauss-Legendre integration + ****************************************************************** } + +unit ugausleg; + +interface + +uses + utypes; + +function GausLeg(Func : TFunc; A, B : Float) : Float; +{ Integral from A to B } + +function GausLeg0(Func : TFunc; B : Float) : Float; +{ Integral from 0 to B } + +function Convol(Func1, Func2 : TFunc; T : Float) : Float; +{ Convolution product at time T } + +implementation + +const Npts = 8; { Number of points / 2 } + +const Root : array[1..Npts] of Float = + (0.0950125098376370440185, + 0.281603550778258913230, + 0.458016777657227386342, + 0.617876244402643748447, + 0.755404408355003033895, + 0.865631202387831743880, + 0.944575023073232576078, + 0.989400934991649932596); + +const Weight : array[1..Npts] of Float = + (0.189450610455068496285, + 0.182603415044923588867, + 0.169156519395002538189, + 0.149595988816576732081, + 0.124628971255533872052, + 0.095158511682492784810, + 0.062253523938647892863, + 0.027152459411754094852); + +function GausLeg(Func : TFunc; A, B : Float) : Float; +{ ------------------------------------------------------------------ + Computes the integral of function Func from A to B + by the Gauss-Legendre method + ------------------------------------------------------------------ } + +var + P, Q, Sum, X, Y : Float; + I : Integer; + +begin + P := 0.5 * (B + A); + Q := 0.5 * (B - A); + + Sum := 0.0; + for I := 1 to Npts do + begin + X := Q * Root[I]; + Y := Func(P + X) + Func(P - X); + Sum := Sum + Weight[I] * Y; + end; + + GausLeg := Q * Sum; +end; + +function GausLeg0(Func : TFunc; B : Float) : Float; +{ ------------------------------------------------------------------ + Computes the integral of function Func from 0 to B + by the Gauss-Legendre method + ------------------------------------------------------------------ } + +var + P, Sum, X, Y : Float; + I : Integer; + +begin + P := 0.5 * B; + + Sum := 0; + for I := 1 to Npts do + begin + X := P * Root[I]; + Y := Func(P + X) + Func(P - X); + Sum := Sum + Weight[I] * Y; + end; + + GausLeg0 := P * Sum; +end; + +function Convol(Func1, Func2 : TFunc; T : Float) : Float; +{ ------------------------------------------------------------------ + Computes the convolution product of two functions Func1 and Func2 + at time T by the Gauss-Legendre method + ------------------------------------------------------------------ } + +var + P, PpX, PmX, Sum, X, Y : Float; + I : Integer; + +begin + P := 0.5 * T; + + Sum := 0.0; + for I := 1 to Npts do + begin + X := P * Root[I]; + PpX := P + X; + PmX := P - X; + Y := Func1(T - PpX) * Func2(PpX) + Func1(T - PmX) * Func2(PmX); + Sum := Sum + Weight[I] * Y; + end; + + Convol := P * Sum; +end; + +end. \ No newline at end of file diff --git a/fpmath/ugenalg.pas b/fpmath/ugenalg.pas new file mode 100755 index 0000000..b90132b --- /dev/null +++ b/fpmath/ugenalg.pas @@ -0,0 +1,331 @@ +{ ****************************************************************** + Optimization by Genetic Algorithm + ****************************************************************** + Ref.: E. Perrin, A. Mandrille, M. Oumoun, C. Fonteix & I. Marc + Optimisation globale par strategie d'evolution + Technique utilisant la genetique des individus diploides + Recherche operationnelle / Operations Research + 1997, 31, 161-201 + Thanks to Magali Camut for her contribution + ****************************************************************** } + +unit ugenalg; + +interface + +uses + utypes, uminmax, urandom; + +procedure InitGAParams(NP, NG : Integer; SR, MR, HR : Float); +{ ------------------------------------------------------------------ + Initialize Genetic Algorithm parameters + ------------------------------------------------------------------ + NP : Population size + NG : Max number of generations + SR : Survival rate + MR : Mutation rate + HR : Proportion of homozygotes + ------------------------------------------------------------------ } + +procedure GA_CreateLogFile(LogFileName : String); +{ ------------------------------------------------------------------ + Initialize log file + ------------------------------------------------------------------ } + +procedure GenAlg(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lb, Ub : Integer; + var F_min : Float); +{ ------------------------------------------------------------------ + Minimization of a function of several variables + by genetic algorithm + ------------------------------------------------------------------ + Input parameters : Func = objective function to be minimized + X = initial minimum coordinates + Xmin = minimum value of X + Xmax = maximum value of X + Lb, Ub = + ------------------------------------------------------------------ + Output parameters: X = refined minimum coordinates + F_min = function value at minimum + ------------------------------------------------------------------ } + +implementation + +const + GA_NP : Integer = 200; { Population size } + GA_NG : Integer = 40; { Max number of generations } + GA_SR : Float = 0.6; { Survival rate } + GA_MR : Float = 0.1; { Mutation rate } + GA_HR : Float = 0.5; { Proportion of homozygotes } + + WriteLogFile : Boolean = False; + +var + LogFile : Text; + +procedure InitGAParams(NP, NG : Integer; SR, MR, HR : Float); +begin + if NP > 0 then GA_NP := NP; + if NG > 0 then GA_NG := NG; + + if (SR > 0.0) and (SR < 1.0) then GA_SR := SR; + if (MR > 0.0) and (MR < 1.0) then GA_MR := MR; + if (HR > 0.0) and (HR < 1.0) then GA_HR := HR; +end; + +procedure GA_CreateLogFile(LogFileName : String); +begin + Assign(LogFile, LogFileName); + Rewrite(LogFile); + Writeln(LogFile, 'Genetic Algorithm'); + Writeln(LogFile, ' Iter F '); + WriteLogFile := True; +end; + +procedure Mutate(I : Integer; + C1, C2, D, P : PMatrix; + Xmin, Range : PVector; + Lb, Ub : Integer); +{ ------------------------------------------------------------------ + Mutate individual I + ------------------------------------------------------------------ } +var + J : Integer; +begin + for J := Lb to Ub do + begin + C1^[I]^[J] := Xmin^[J] + RanGen3 * Range^[J]; + C2^[I]^[J] := Xmin^[J] + RanGen3 * Range^[J]; + D^[I]^[J] := RanGen3; + P^[I]^[J] := D^[I]^[J] * C1^[I]^[J] + (1.0 - D^[I]^[J]) * C2^[I]^[J]; + end; +end; + +procedure Cross(I1, I2, I : Integer; + C1, C2, D, P : PMatrix; + Lb, Ub : Integer); +{ ------------------------------------------------------------------ + Cross two individuals I1 and I2 --> new individual I + ------------------------------------------------------------------ } +var + J, K : Integer; +begin + for J := Lb to Ub do + begin + if RanGen3 < 0.5 then K := I1 else K := I2; + C1^[I]^[J] := C1^[K]^[J]; + + if RanGen3 < 0.5 then K := I1 else K := I2; + C2^[I]^[J] := C2^[K]^[J]; + + D^[I]^[J] := RanGen3; + + P^[I]^[J] := D^[I]^[J] * C1^[I]^[J] + (1.0 - D^[I]^[J]) * C2^[I]^[J]; + end; +end; + +procedure Homozygote(I : Integer; + C1, C2, P : PMatrix; + Lb, Ub : Integer); +{ ------------------------------------------------------------------ + Make individual I homozygous + ------------------------------------------------------------------ } +var + J : Integer; +begin + for J := Lb to Ub do + begin + C1^[I]^[J] := P^[I]^[J]; + C2^[I]^[J] := P^[I]^[J]; + end; +end; + +function GA_Func(Func : TFuncNVar; + I : Integer; + P : PMatrix; + Lb, Ub : Integer) : Float; +{ ------------------------------------------------------------------ + Computes objective function for individual I + ------------------------------------------------------------------ } +var + J : Integer; + X : PVector; +begin + DimVector(X, Ub); + + for J := Lb to Ub do + X^[J] := P^[I]^[J]; + + GA_Func := Func(X); + + DelVector(X, Ub); +end; + +procedure CompFunc(Func : TFuncNVar; + X : PVector; + C1, C2, D, P : PMatrix; + F : PVector; + Lb, Ub : Integer; + var Iter : Integer; + var F_min : Float); +{ ------------------------------------------------------------------ + Computes function values + ------------------------------------------------------------------ } +var + I, J, K : Integer; + A : Float; +begin + { Compute function values } + for I := 1 to GA_NP do + F^[I] := GA_Func(Func, I, P, Lb, Ub); + + { Sort population according to function values } + for I := 1 to GA_NP - 1 do + begin + K := I; + A := F^[I]; + + for J := I + 1 to GA_NP do + if F^[J] < A then + begin + K := J; + A := F^[J]; + end; + + FSwap(F^[I], F^[K]); + + for J := Lb to Ub do + begin + FSwap(C1^[I]^[J], C1^[K]^[J]); + FSwap(C2^[I]^[J], C2^[K]^[J]); + FSwap(D^[I]^[J], D^[K]^[J]); + FSwap(P^[I]^[J], P^[K]^[J]); + end; + end; + + { Update log file if necessary } + if WriteLogFile then + Writeln(LogFile, Iter:5, F^[1]:12); + + { Update minimum } + if F^[1] < F_min then + begin + F_min := F^[1]; + for J := Lb to Ub do + X^[J] := P^[1]^[J]; + end; + + Inc(Iter); +end; + +procedure GenPop(Func : TFuncNVar; + NS : Integer; + C1, C2, D, P : PMatrix; + F, Xmin, Range : PVector; + Lb, Ub : Integer); +{ ------------------------------------------------------------------ + Generates new population + ------------------------------------------------------------------ } +var + I, I1, I2 : Integer; + F0 : Float; +begin + for I := NS + 1 to GA_NP do + begin + I1 := Trunc(RanGen3 * NS) + 1; + + repeat + I2 := Trunc(RanGen3 * NS) + 1 + until I2 <> I1; + + F0 := FMax(F^[I1], F^[I2]); + + repeat + Cross(I1, I2, I, C1, C2, D, P, Lb, Ub); + until GA_Func(Func, I, P, Lb, Ub) <= F0; + end; + + for I := 1 to GA_NP do + begin + if RanGen3 < GA_MR then + Mutate(I, C1, C2, D, P, Xmin, Range, Lb, Ub); + if RanGen3 < GA_HR then + Homozygote(I, C1, C2, P, Lb, Ub); + end; +end; + +procedure GenAlg(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lb, Ub : Integer; + var F_min : Float); +{ ------------------------------------------------------------------ + Minimization of a function of several variables + by genetic algorithm + ------------------------------------------------------------------ + Input parameters : Func = objective function to be minimized + X = initial minimum coordinates + Xmin = minimum value of X + Xmax = maximum value of X + Lb, Ub = + ------------------------------------------------------------------ + Output parameters: X = refined minimum coordinates + F_min = function value at minimum + ------------------------------------------------------------------ } +var + I, NS, Iter : Integer; + C1, C2, D, P : PMatrix; + Range, F : PVector; + +begin + SetErrCode(OptOk); + + { Initialize the random number generator + using the standard generator } + Randomize; + InitGen(Trunc(Random * 1.0E+8)); + + { Dimension arrays } + DimMatrix(C1, GA_NP, Ub); + DimMatrix(C2, GA_NP, Ub); + DimMatrix(D, GA_NP, Ub); + DimMatrix(P, GA_NP, Ub); + + DimVector(F, GA_NP); + DimVector(Range, Ub); + + for I := Lb to Ub do + Range^[I] := Xmax^[I] - Xmin^[I]; + + NS := Trunc(GA_NP * GA_SR); { Number of survivors } + + Iter := 0; + F_min := MaxNum; + + for I := 1 to GA_NP do + Mutate(I, C1, C2, D, P, Xmin, Range, Lb, Ub); + + CompFunc(Func, X, C1, C2, D, P, F, Lb, Ub, Iter, F_min); + + for I := 1 to GA_NG do + begin + GenPop(Func, NS, C1, C2, D, P, F, Xmin, Range, Lb, Ub); + CompFunc(Func, X, C1, C2, D, P, F, Lb, Ub, Iter, F_min); + end; + + if WriteLogFile then + begin + Close(LogFile); + WriteLogFile := False; + end; + + DelMatrix(C1, GA_NP, Ub); + DelMatrix(C2, GA_NP, Ub); + DelMatrix(D, GA_NP, Ub); + DelMatrix(P, GA_NP, Ub); + + DelVector(F, GA_NP); + DelVector(Range, Ub); +end; + +end. diff --git a/fpmath/ugoldsrc.pas b/fpmath/ugoldsrc.pas new file mode 100755 index 0000000..5dec36f --- /dev/null +++ b/fpmath/ugoldsrc.pas @@ -0,0 +1,107 @@ +{ ****************************************************************** + Minimization of a function of one variable by Golden Search method + ****************************************************************** } + +unit ugoldsrc; + +interface + +uses + utypes, uminbrak; + +procedure GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float); +{ ------------------------------------------------------------------ + Performs a golden search for the minimum of function Func + ------------------------------------------------------------------ + Input parameters : + Func = objective function + A, B = two points near the minimum + MaxIter = maximum number of iterations + Tol = required precision (should not be less than + the square root of the machine precision) + ------------------------------------------------------------------ + Output parameters : Xmin, Ymin = coordinates of minimum + ------------------------------------------------------------------ + Possible results : OptOk + OptNonConv + ------------------------------------------------------------------ } + +implementation + +procedure GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float); + var + C, Fa, Fb, Fc, F1, F2, MinTol, X0, X1, X2, X3 : Float; + Iter : Integer; + + begin + MinTol := Sqrt(MachEp); + if Tol < MinTol then Tol := MinTol; + + MinBrack(Func, A, B, C, Fa, Fb, Fc); + + X0 := A; + X3 := C; + + if (C - B) > (B - A) then + begin + X1 := B; + X2 := B + CGold * (C - B); + F1 := Fb; + F2 := Func(X2); + end + else + begin + X1 := B - CGold * (B - A); + X2 := B; + F1 := Func(X1); + F2 := Fb; + end; + + Iter := 0; + + while (Iter <= MaxIter) and (Abs(X3 - X0) > Tol * (Abs(X1) + Abs(X2))) do + if F2 < F1 then + begin + X0 := X1; + X1 := X2; + F1 := F2; + X2 := X1 + CGold * (X3 - X1); + F2 := Func(X2); + Inc(Iter); + end + else + begin + X3 := X2; + X2 := X1; + F2 := F1; + X1 := X2 - CGold * (X2 - X0); + F1 := Func(X1); + Inc(Iter); + end; + + if F1 < F2 then + begin + Xmin := X1; + Ymin := F1; + end + else + begin + Xmin := X2; + Ymin := F2; + end; + + if Iter > MaxIter then + SetErrCode(OptNonConv) + else + SetErrCode(OptOk); + end; + +end. diff --git a/fpmath/uhqr.pas b/fpmath/uhqr.pas new file mode 100755 index 0000000..383a328 --- /dev/null +++ b/fpmath/uhqr.pas @@ -0,0 +1,272 @@ +{ ****************************************************************** + Eigenvalues of a real upper Hessenberg matrix by the QR method + ****************************************************************** } + +unit uhqr; + +interface + +uses + utypes, uminmax; + +procedure Hqr(H : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + Lambda : PCompVector); + +implementation + +procedure Hqr(H : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + Lambda : PCompVector); +{ ------------------------------------------------------------------ + This function is a translation of the EISPACK subroutine hqr. + + This function finds the eigenvalues of a real upper Hessenberg + matrix by the QR method. + + On input: + + H contains the upper Hessenberg matrix. + + Lb, Ub are the lowest and highest indices + of the elements of H + + I_low and I_igh are integers determined by the balancing subroutine + Balance. If Balance has not been used, set I_low = Lb, I_igh = Ub + + On output: + + H has been destroyed. + + Wr and Wi contain the real and imaginary parts, respectively, of + the eigenvalues. The eigenvalues are unordered except that complex + conjugate pairs of values appear consecutively with the eigenvalue + having the positive imaginary part first. + + The function returns an error code: + zero for normal return, + -j if the limit of 30*N iterations is exhausted + while the j-th eigenvalue is being sought. + (N being the size of the matrix). The eigenvalues + should be correct for indices j+1,...,Ub. + ------------------------------------------------------------------ + Note: This is a crude translation. Many of the original goto's + have been kept ! + ------------------------------------------------------------------ } + + var + I, J, K, L, M, N, En, Na, Itn, Its, Mp2, Enm2 : Integer; + P, Q, R, S, T, W, X, Y, Z, Norm, Tst1, Tst2 : Float; + NotLas : Boolean; + + label + 60, 70, 100, 130, 150, 170, 225, 260, 270, 280, 320, 330; + + begin + { Store roots isolated by Balance and compute matrix norm } + K := Lb; + Norm := 0.0; + for I := Lb to Ub do + begin + for J := K to Ub do + Norm := Norm + Abs(H^[I]^[J]); + K := I; + if (I < I_low) or (I > I_igh) then + begin + Lambda^[I].X := H^[I]^[I]; + Lambda^[I].Y := 0.0; + end; + end; + + N := Ub - Lb + 1; + Itn := 30 * N; + En := I_igh; + T := 0.0; + +60: { Search for next eigenvalues } + if En < I_low then + begin + SetErrCode(0); + Exit; + end; + + Its := 0; + Na := En - 1; + Enm2 := Na - 1; + +70: { Look for single small sub-diagonal element } + for L := En downto I_low do + begin + if L = I_low then goto 100; + S := Abs(H^[L - 1]^[L - 1]) + Abs(H^[L]^[L]); + if S = 0.0 then S := Norm; + Tst1 := S; + Tst2 := Tst1 + Abs(H^[L]^[L - 1]); + if Tst2 = Tst1 then goto 100; + end; + +100: { Form shift } + X := H^[En]^[En]; + if L = En then goto 270; + Y := H^[Na]^[Na]; + W := H^[En]^[Na] * H^[Na]^[En]; + if L = Na then goto 280; + + if Itn = 0 then + begin + { Set error -- all eigenvalues have not + converged after 30*N iterations } + SetErrCode(- En); + Exit; + end; + + if (Its <> 10) and (Its <> 20) then goto 130; + + { Form exceptional shift } + T := T + X; + + for I := I_low to En do + H^[I]^[I] := H^[I]^[I] - X; + + S := Abs(H^[En]^[Na]) + Abs(H^[Na]^[Enm2]); + X := 0.75 * S; + Y := X; + W := - 0.4375 * S * S; + +130: + Its := Its + 1; + Itn := Itn - 1; + + { Look for two consecutive small sub-diagonal elements } + for M := Enm2 downto L do + begin + Z := H^[M]^[M]; + R := X - Z; + S := Y - Z; + P := (R * S - W) / H^[M + 1]^[M] + H^[M]^[M + 1]; + Q := H^[M + 1]^[M + 1] - Z - R - S; + R := H^[M + 2]^[M + 1]; + S := Abs(P) + Abs(Q) + Abs(R); + P := P / S; + Q := Q / S; + R := R / S; + if M = L then goto 150; + Tst1 := Abs(P) * (Abs(H^[M - 1]^[M - 1]) + Abs(Z) + Abs(H^[M + 1]^[M + 1])); + Tst2 := Tst1 + Abs(H^[M]^[M - 1]) * (Abs(Q) + Abs(R)); + if Tst2 = Tst1 then goto 150; + end; + +150: + Mp2 := M + 2; + + for I := Mp2 to En do + begin + H^[I]^[I - 2] := 0.0; + if I <> Mp2 then H^[I]^[I - 3] := 0.0; + end; + + { Double QR step involving rows L to En and columns M to En } + for K := M to Na do + begin + NotLas := (K <> Na); + if (K = M) then goto 170; + P := H^[K]^[K - 1]; + Q := H^[K + 1]^[K - 1]; + R := 0.0; + if NotLas then R := H^[K + 2]^[K - 1]; + X := Abs(P) + Abs(Q) + Abs(R); + if X = 0.0 then goto 260; + P := P / X; + Q := Q / X; + R := R / X; +170: S := DSgn(Sqrt(P * P + Q * Q + R * R), P); + if K <> M then + H^[K]^[K - 1] := - S * X + else if L <> M then + H^[K]^[K - 1] := - H^[K]^[K - 1]; + P := P + S; + X := P / S; + Y := Q / S; + Z := R / S; + Q := Q / P; + R := R / P; + if NotLas then goto 225; + + { Row modification } + for J := K to En do + begin + P := H^[K]^[J] + Q * H^[K + 1]^[J]; + H^[K]^[J] := H^[K]^[J] - P * X; + H^[K + 1]^[J] := H^[K + 1]^[J] - P * Y; + end; + + J := Imin(En, K + 3); + + { Column modification } + for I := L to J do + begin + P := X * H^[I]^[K] + Y * H^[I]^[K + 1]; + H^[I]^[K] := H^[I]^[K] - P; + H^[I]^[K + 1] := H^[I]^[K + 1] - P * Q; + end; + goto 260; + +225: + { Row modification } + for J := K to En do + begin + P := H^[K]^[J] + Q * H^[K + 1]^[J] + R * H^[K + 2]^[J]; + H^[K]^[J] := H^[K]^[J] - P * X; + H^[K + 1]^[J] := H^[K + 1]^[J] - P * Y; + H^[K + 2]^[J] := H^[K + 2]^[J] - P * Z; + end; + + J := Imin(En, K + 3); + + { Column modification } + for I := L to J do + begin + P := X * H^[I]^[K] + Y * H^[I]^[K + 1] + Z * H^[I]^[K + 2]; + H^[I]^[K] := H^[I]^[K] - P; + H^[I]^[K + 1] := H^[I]^[K + 1] - P * Q; + H^[I]^[K + 2] := H^[I]^[K + 2] - P * R; + end; + +260: end; + + goto 70; + +270: { One root found } + Lambda^[En].X := X + T; + Lambda^[En].Y := 0.0; + En := Na; + goto 60; + +280: { Two roots found } + P := 0.5 * (Y - X); + Q := P * P + W; + Z := Sqrt(Abs(Q)); + X := X + T; + if Q < 0.0 then goto 320; + + { Real pair } + Z := P + DSgn(Z, P); + Lambda^[Na].X := X + Z; + Lambda^[En].X := Lambda^[Na].X; + if Z <> 0.0 then Lambda^[En].X := X - W / Z; + Lambda^[Na].Y := 0.0; + Lambda^[En].Y := 0.0; + goto 330; + +320: { Complex pair } + Lambda^[Na].X := X + P; + Lambda^[En].X := X + P; + Lambda^[Na].Y := Z; + Lambda^[En].Y := - Z; + +330: + En := Enm2; + goto 60; + end; + +end. diff --git a/fpmath/uhqr2.pas b/fpmath/uhqr2.pas new file mode 100755 index 0000000..63d4357 --- /dev/null +++ b/fpmath/uhqr2.pas @@ -0,0 +1,521 @@ +{ ****************************************************************** + Eigenvalues and eigenvectors of a real upper Hessenberg matrix + ****************************************************************** } + +unit uhqr2; + +interface + +uses + utypes, uminmax; + +procedure Hqr2(H : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + Lambda : PCompVector; + Z : PMatrix); + +implementation + +procedure Hqr2(H : PMatrix; + Lb, Ub, I_low, I_igh : Integer; + Lambda : PCompVector; + Z : PMatrix); +{ ------------------------------------------------------------------ + This function is a translation of the EISPACK subroutine hqr2 + + This procedure finds the eigenvalues and eigenvectors of a real + upper Hessenberg matrix by the QR method. + + On input: + + H contains the upper Hessenberg matrix. + + Lb, Ub are the lowest and highest indices + of the elements of H + + I_low and I_igh are integers determined by the balancing subroutine + Balance. If Balance has not been used, set I_low=Lb, I_igh=Ub + + Z contains the transformation matrix produced by Eltran after the + reduction by Elmhes, or by Ortran after the reduction by Orthes, if + performed. If the eigenvectors of the Hessenberg matrix are desired, + Z must contain the identity matrix. + + On output: + + H has been destroyed. + + Wr and Wi contain the real and imaginary parts, respectively, of + the eigenvalues. The eigenvalues are unordered except that complex + conjugate pairs of values appear consecutively with the eigenvalue + having the positive imaginary part first. + + Z contains the real and imaginary parts of the eigenvectors. If the + i-th eigenvalue is real, the i-th column of Z contains its eigenvector. + If the i-th eigenvalue is complex with positive imaginary part, the i-th + and (i+1)-th columns of Z contain the real and imaginary parts of its + eigenvector. The eigenvectors are unnormalized. If an error exit is made, + none of the eigenvectors has been found. + + The function returns an error code: + zero for normal return, + -j if the limit of 30*N iterations is exhausted + while the j-th eigenvalue is being sought + (N being the size of the matrix). The eigenvalues + should be correct for indices j+1,...,Ub. + ------------------------------------------------------------------ + Note: This is a crude translation. Many of the original goto's + have been kept ! + ------------------------------------------------------------------ } + + procedure Cdiv(Ar, Ai, Br, Bi : Float; var Cr, Ci : Float); + { Complex division, (Cr,Ci) = (Ar,Ai)/(Br,Bi) } + var + S, Ars, Ais, Brs, Bis : Float; + begin + S := Abs(Br) + Abs(Bi); + Ars := Ar / S; + Ais := Ai / S; + Brs := Br / S; + Bis := Bi / S; + S := Sqr(Brs) + Sqr(Bis); + Cr := (Ars * Brs + Ais * Bis) / S; + Ci := (Ais * Brs - Ars * Bis) / S; + end; + + var + I, J, K, L, M, N, En, Na, Itn, Its, Mp2, Enm2 : Integer; + P, Q, R, S, T, W, X, Y, Ra, Sa, Vi, Vr, Zz, Norm, Tst1, Tst2 : Float; + NotLas : Boolean; + + label + 60, 70, 100, 130, 150, 170, 225, 260, 270, 280, 320, 330, 340, + 600, 630, 635, 640, 680, 700, 710, 770, 780, 790, 795, 800; + + begin + { Store roots isolated by Balance and compute matrix norm } + K := Lb; + Norm := 0.0; + for I := Lb to Ub do + begin + for J := K to Ub do + Norm := Norm + Abs(H^[I]^[J]); + K := I; + if (I < I_low) or (I > I_igh) then + begin + Lambda^[I].X := H^[I]^[I]; + Lambda^[I].Y := 0.0; + end; + end; + + N := Ub - Lb + 1; + Itn := 30 * N; + En := I_igh; + T := 0.0; + +60: { Search for next eigenvalues } + if En < I_low then goto 340; + Its := 0; + Na := En - 1; + Enm2 := Na - 1; + +70: { Look for single small sub-diagonal element } + for L := En downto I_low do + begin + if L = I_low then goto 100; + S := Abs(H^[L - 1]^[L - 1]) + Abs(H^[L]^[L]); + if S = 0.0 then S := Norm; + Tst1 := S; + Tst2 := Tst1 + Abs(H^[L]^[L - 1]); + if Tst2 = Tst1 then goto 100; + end; + +100: { Form shift } + X := H^[En]^[En]; + if L = En then goto 270; + Y := H^[Na]^[Na]; + W := H^[En]^[Na] * H^[Na]^[En]; + if L = Na then goto 280; + + if Itn = 0 then + begin + { Set error -- all eigenvalues have not + converged after 30*N iterations } + SetErrCode(- En); + Exit; + end; + + if (Its <> 10) and (Its <> 20) then goto 130; + + { Form exceptional shift } + T := T + X; + + for I := I_low to En do + H^[I]^[I] := H^[I]^[I] - X; + + S := Abs(H^[En]^[Na]) + Abs(H^[Na]^[Enm2]); + X := 0.75 * S; + Y := X; + W := - 0.4375 * S * S; + +130: + Its := Its + 1; + Itn := Itn - 1; + + { Look for two consecutive small sub-diagonal elements } + for M := Enm2 downto L do + begin + Zz := H^[M]^[M]; + R := X - Zz; + S := Y - Zz; + P := (R * S - W) / H^[M + 1]^[M] + H^[M]^[M + 1]; + Q := H^[M + 1]^[M + 1] - Zz - R - S; + R := H^[M + 2]^[M + 1]; + S := Abs(P) + Abs(Q) + Abs(R); + P := P / S; + Q := Q / S; + R := R / S; + if M = L then goto 150; + Tst1 := Abs(P) * (Abs(H^[M - 1]^[M - 1]) + Abs(Zz) + Abs(H^[M + 1]^[M + 1])); + Tst2 := Tst1 + Abs(H^[M]^[M - 1]) * (Abs(Q) + Abs(R)); + if Tst2 = Tst1 then goto 150; + end; + +150: + Mp2 := M + 2; + + for I := Mp2 to En do + begin + H^[I]^[I - 2] := 0.0; + if I <> Mp2 then H^[I]^[I - 3] := 0.0; + end; + + { Double QR step involving rows L to En and columns M to En } + for K := M to Na do + begin + NotLas := (K <> Na); + if (K = M) then goto 170; + P := H^[K]^[K - 1]; + Q := H^[K + 1]^[K - 1]; + R := 0.0; + if NotLas then R := H^[K + 2]^[K - 1]; + X := Abs(P) + Abs(Q) + Abs(R); + if X = 0.0 then goto 260; + P := P / X; + Q := Q / X; + R := R / X; +170: S := DSgn(Sqrt(P * P + Q * Q + R * R), P); + if K <> M then + H^[K]^[K - 1] := - S * X + else if L <> M then + H^[K]^[K - 1] := - H^[K]^[K - 1]; + P := P + S; + X := P / S; + Y := Q / S; + Zz := R / S; + Q := Q / P; + R := R / P; + if NotLas then goto 225; + + { Row modification } + for J := K to Ub do + begin + P := H^[K]^[J] + Q * H^[K + 1]^[J]; + H^[K]^[J] := H^[K]^[J] - P * X; + H^[K + 1]^[J] := H^[K + 1]^[J] - P * Y; + end; + + J := Imin(En, K + 3); + + { Column modification } + for I := Lb to J do + begin + P := X * H^[I]^[K] + Y * H^[I]^[K + 1]; + H^[I]^[K] := H^[I]^[K] - P; + H^[I]^[K + 1] := H^[I]^[K + 1] - P * Q; + end; + + { Accumulate transformations } + for I := I_low to I_igh do + begin + P := X * Z^[I]^[K] + Y * Z^[I]^[K + 1]; + Z^[I]^[K] := Z^[I]^[K] - P; + Z^[I]^[K + 1] := Z^[I]^[K + 1] - P * Q; + end; + goto 260; + +225: + { Row modification } + for J := K to Ub do + begin + P := H^[K]^[J] + Q * H^[K + 1]^[J] + R * H^[K + 2]^[J]; + H^[K]^[J] := H^[K]^[J] - P * X; + H^[K + 1]^[J] := H^[K + 1]^[J] - P * Y; + H^[K + 2]^[J] := H^[K + 2]^[J] - P * Zz; + end; + + J := Imin(En, K + 3); + + { Column modification } + for I := Lb to J do + begin + P := X * H^[I]^[K] + Y * H^[I]^[K + 1] + Zz * H^[I]^[K + 2]; + H^[I]^[K] := H^[I]^[K] - P; + H^[I]^[K + 1] := H^[I]^[K + 1] - P * Q; + H^[I]^[K + 2] := H^[I]^[K + 2] - P * R; + end; + + { Accumulate transformations } + for I := I_low to I_igh do + begin + P := X * Z^[I]^[K] + Y * Z^[I]^[K + 1] + Zz * Z^[I]^[K + 2]; + Z^[I]^[K] := Z^[I]^[K] - P; + Z^[I]^[K + 1] := Z^[I]^[K + 1] - P * Q; + Z^[I]^[K + 2] := Z^[I]^[K + 2] - P * R; + end; + +260: end; + + goto 70; + +270: { One root found } + H^[En]^[En] := X + T; + Lambda^[En].X := H^[En]^[En]; + Lambda^[En].Y := 0.0; + En := Na; + goto 60; + +280: { Two roots found } + P := 0.5 * (Y - X); + Q := P * P + W; + Zz := Sqrt(Abs(Q)); + H^[En]^[En] := X + T; + X := H^[En]^[En]; + H^[Na]^[Na] := Y + T; + if Q < 0.0 then goto 320; + + { Real pair } + Zz := P + DSgn(Zz, P); + Lambda^[Na].X := X + Zz; + Lambda^[En].X := Lambda^[Na].X; + if Zz <> 0.0 then Lambda^[En].X := X - W / Zz; + Lambda^[Na].Y := 0.0; + Lambda^[En].Y := 0.0; + X := H^[En]^[Na]; + S := Abs(X) + Abs(Zz); + P := X / S; + Q := Zz / S; + R := Sqrt(P * P + Q * Q); + P := P / R; + Q := Q / R; + + { Row modification } + for J := Na to Ub do + begin + Zz := H^[Na]^[J]; + H^[Na]^[J] := Q * Zz + P * H^[En]^[J]; + H^[En]^[J] := Q * H^[En]^[J] - P * Zz; + end; + + { Column modification } + for I := Lb to En do + begin + Zz := H^[I]^[Na]; + H^[I]^[Na] := Q * Zz + P * H^[I]^[En]; + H^[I]^[En] := Q * H^[I]^[En] - P * Zz; + end; + + { Accumulate transformations } + for I := I_low to I_igh do + begin + Zz := Z^[I]^[Na]; + Z^[I]^[Na] := Q * Zz + P * Z^[I]^[En]; + Z^[I]^[En] := Q * Z^[I]^[En] - P * Zz; + end; + + goto 330; + +320: { Complex pair } + Lambda^[Na].X := X + P; + Lambda^[En].X := Lambda^[Na].X; + Lambda^[Na].Y := Zz; + Lambda^[En].Y := - Zz; + +330: + En := Enm2; + goto 60; + +340: + if Norm = 0.0 then Exit; + + { All roots found. Backsubstitute to find + vectors of upper triangular form } + for En := Ub downto Lb do + begin + P := Lambda^[En].X; + Q := Lambda^[En].Y; + Na := En - 1; + if Q < 0.0 then + goto 710 + else if Q = 0.0 then + goto 600 + else + goto 800; + +600: { Real vector } + M := En; + H^[En]^[En] := 1.0; + if Na < Lb then goto 800; + + for I := Na downto Lb do + begin + W := H^[I]^[I] - P; + R := 0.0; + + for J := M to En do + R := R + H^[I]^[J] * H^[J]^[En]; + + if Lambda^[I].Y >= 0.0 then goto 630; + Zz := W; + S := R; + goto 700; +630: M := I; + if Lambda^[I].Y <> 0.0 then goto 640; + T := W; + if T <> 0.0 then goto 635; + Tst1 := Norm; + T := Tst1; + repeat + T := 0.01 * T; + Tst2 := Norm + T; + until Tst2 <= Tst1; +635: H^[I]^[En] := - R / T; + goto 680; + +640: { Solve real equations } + X := H^[I]^[I + 1]; + Y := H^[I + 1]^[I]; + Q := Sqr(Lambda^[I].X - P) + Sqr(Lambda^[I].Y); + T := (X * S - Zz * R) / Q; + H^[I]^[En] := T; + if Abs(X) > Abs(Zz) then + H^[I + 1]^[En] := (- R - W * T) / X + else + H^[I + 1]^[En] := (- S - Y * T) / Zz; + +680: { Overflow control } + T := Abs(H^[I]^[En]); + if T = 0.0 then goto 700; + Tst1 := T; + Tst2 := Tst1 + 1.0 / Tst1; + if Tst2 > Tst1 then goto 700; + for J := I to En do + H^[J]^[En] := H^[J]^[En] / T; +700: end; + { End real vector } + goto 800; + + { Complex vector } +710: M := Na; + + { Last vector component chosen imaginary so that + eigenvector matrix is triangular } + if Abs(H^[En]^[Na]) > Abs(H^[Na]^[En]) then + begin + H^[Na]^[Na] := Q / H^[En]^[Na]; + H^[Na]^[En] := - (H^[En]^[En] - P) / H^[En]^[Na]; + end + else + Cdiv(0.0, - H^[Na]^[En], H^[Na]^[Na] - P, Q, H^[Na]^[Na], H^[Na]^[En]); + + H^[En]^[Na] := 0.0; + H^[En]^[En] := 1.0; + Enm2 := Na - 1; + if Enm2 < Lb then goto 800; + + for I := Enm2 downto Lb do + begin + W := H^[I]^[I] - P; + Ra := 0.0; + Sa := 0.0; + + for J := M to En do + begin + Ra := Ra + H^[I]^[J] * H^[J]^[Na]; + Sa := Sa + H^[I]^[J] * H^[J]^[En]; + end; + + if Lambda^[I].Y >= 0.0 then goto 770; + Zz := W; + R := Ra; + S := Sa; + goto 795; +770: M := I; + if Lambda^[I].Y <> 0.0 then goto 780; + Cdiv(- Ra, - Sa, W, Q, H^[I]^[Na], H^[I]^[En]); + goto 790; + + { Solve complex equations } +780: X := H^[I]^[I + 1]; + Y := H^[I + 1]^[I]; + Vr := Sqr(Lambda^[I].X - P) + Sqr(Lambda^[I].Y) - Sqr(Q); + Vi := (Lambda^[I].X - P) * 2.0 * Q; + if (Vr = 0.0) and (Vi = 0.0) then + begin + Tst1 := Norm * (Abs(W) + Abs(Q) + Abs(X) + Abs(Y) + Abs(Zz)); + Vr := Tst1; + repeat + Vr := 0.01 * Vr; + Tst2 := Tst1 + Vr; + until Tst2 <= Tst1; + end; + Cdiv(X * R - Zz * Ra + Q * Sa, X * S - Zz * Sa - Q * Ra, Vr, Vi, H^[I]^[Na], H^[I]^[En]); + if Abs(X) > Abs(Zz) + Abs(Q) then + begin + H^[I + 1]^[Na] := (- Ra - W * H^[I]^[Na] + Q * H^[I]^[En]) / X; + H^[I + 1]^[En] := (- Sa - W * H^[I]^[En] - Q * H^[I]^[Na]) / X; + end + else + Cdiv(- R - Y * H^[I]^[Na], - S - Y * H^[I]^[En], Zz, Q, H^[I + 1]^[Na], H^[I + 1]^[En]); + +790: { Overflow control } + T := FMax(Abs(H^[I]^[Na]), Abs(H^[I]^[En])); + if T = 0.0 then goto 795; + Tst1 := T; + Tst2 := Tst1 + 1.0 / Tst1; + if Tst2 > Tst1 then goto 795; + for J := I to En do + begin + H^[J]^[Na] := H^[J]^[Na] / T; + H^[J]^[En] := H^[J]^[En] / T; + end; + +795: end; + { End complex vector } +800: end; + + { End back substitution. + Vectors of isolated roots } + for I := Lb to Ub do + if (I < I_low) or (I > I_igh) then + for J := I to Ub do + Z^[I]^[J] := H^[I]^[J]; + + { Multiply by transformation matrix to give + vectors of original full matrix. } + for J := Ub downto I_low do + begin + M := Imin(J, I_igh); + for I := I_low to I_igh do + begin + Zz := 0.0; + for K := I_low to M do + Zz := Zz + Z^[I]^[K] * H^[K]^[J]; + Z^[I]^[J] := Zz; + end; + end; + + SetErrCode(0); + end; + +end. diff --git a/fpmath/uhyper.pas b/fpmath/uhyper.pas new file mode 100755 index 0000000..a9f1705 --- /dev/null +++ b/fpmath/uhyper.pas @@ -0,0 +1,104 @@ +{ ****************************************************************** + Hyperbolic functions + ****************************************************************** } + +unit uhyper; + +interface + +uses + utypes, uminmax; + +function Sinh(X : Float) : Float; { Hyperbolic sine } +function Cosh(X : Float) : Float; { Hyperbolic cosine } +function Tanh(X : Float) : Float; { Hyperbolic tangent } +function ArcSinh(X : Float) : Float; { Inverse hyperbolic sine } +function ArcCosh(X : Float) : Float; { Inverse hyperbolic cosine } +function ArcTanh(X : Float) : Float; { Inverse hyperbolic tangent } + +procedure SinhCosh(X : Float; var SinhX, CoshX : Float); { Sinh & Cosh } + +implementation + + function Sinh(X : Float) : Float; + var + ExpX : Float; + begin + if (X < MinLog) or (X > MaxLog) then + Sinh := DefaultVal(FOverflow, Sgn(X) * MaxNum) + else + begin + ExpX := Exp(X); + Sinh := 0.5 * (ExpX - 1.0 / ExpX); + SetErrCode(FOk); + end; + end; + + function Cosh(X : Float) : Float; + var + ExpX : Float; + begin + if (X < MinLog) or (X > MaxLog) then + Cosh := DefaultVal(FOverflow, MaxNum) + else + begin + ExpX := Exp(X); + Cosh := 0.5 * (ExpX + 1.0 / ExpX); + SetErrCode(FOk); + end; + end; + + procedure SinhCosh(X : Float; var SinhX, CoshX : Float); + var + ExpX, ExpMinusX : Float; + begin + if (X < MinLog) or (X > MaxLog) then + begin + CoshX := DefaultVal(FOverflow, MaxNum); + SinhX := Sgn(X) * CoshX; + end + else + begin + ExpX := Exp(X); + ExpMinusX := 1.0 / ExpX; + SinhX := 0.5 * (ExpX - ExpMinusX); + CoshX := 0.5 * (ExpX + ExpMinusX); + SetErrCode(FOk); + end; + end; + + function Tanh(X : Float) : Float; + var + SinhX, CoshX : Float; + begin + SinhCosh(X, SinhX, CoshX); + Tanh := SinhX / CoshX; + end; + + function ArcSinh(X : Float) : Float; + begin + SetErrCode(FOk); + ArcSinh := Ln(X + Sqrt(Sqr(X) + 1.0)); + end; + + function ArcCosh(X : Float) : Float; + begin + SetErrCode(FOk); + if X < 1.0 then + ArcCosh := DefaultVal(FDomain, 0.0) + else + ArcCosh := Ln(X + Sqrt(Sqr(X) - 1.0)); + end; + + function ArcTanh(X : Float) : Float; + begin + SetErrCode(FOk); + if (X < - 1.0) or (X > 1.0) then + ArcTanh := DefaultVal(FDomain, Sgn(X) * MaxNum) + else if (X = - 1.0) or (X = 1.0) then + ArcTanh := Sgn(X) * DefaultVal(FSing, Sgn(X) * MaxNum) + else + ArcTanh := 0.5 * Ln((1.0 + X) / (1.0 - X)); + end; + +end. \ No newline at end of file diff --git a/fpmath/uibeta.pas b/fpmath/uibeta.pas new file mode 100755 index 0000000..880a787 --- /dev/null +++ b/fpmath/uibeta.pas @@ -0,0 +1,342 @@ +{ ****************************************************************** + Incomplete Beta function. + Translated from C code in Cephes library (http://www.moshier.net) + ****************************************************************** } + +unit uibeta; + +interface + +uses + utypes, umath, ugamma; + +function IBeta(A, B, X : Float) : Float; +{ Incomplete Beta function} + +implementation + +const + Big = 1.0 / MachEp; + + function PSeries(A, B, X : Float) : Float; + { Power series for incomplete beta integral. Use when B*X is small } + var + S, T, U, V, T1, Z, Ai : Float; + N : Integer; + begin + Ai := 1.0 / A; + U := (1.0 - B) * X; + V := U / (A + 1.0); + T1 := V; + T := U; + N := 2; + S := 0.0; + Z := MachEp * Ai; + while Abs(V) > Z do + begin + U := (N - B) * X / N; + T := T * U; + V := T / (A + N); + S := S + V; + N := N + 1; + end; + S := S + T1; + S := S + Ai; + + U := A * Ln(X); + if (A + B < MaxGam) and (Abs(U) < MaxLog) then + begin + T := Gamma(A + B) / (Gamma(A) * Gamma(B)); + S := S * T * Power(X, A); + end + else + begin + T := LnGamma(A + B) - LnGamma(A) - LnGamma(B) + U + Ln(S); + if T < MinLog then + S := 0.0 + else + S := Exp(T); + end; + PSeries := S; + end; + + function CFrac1(A, B, X : Float) : Float; + { Continued fraction expansion #1 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := A + B; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := B - 1.0; + K7 := K4; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MachEp; + + repeat + Xk := - (X * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (X * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 + 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 - 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > Big then + begin + Pkm2 := Pkm2 * MachEp; + Pkm1 := Pkm1 * MachEp; + Qkm2 := Qkm2 * MachEp; + Qkm1 := Qkm1 * MachEp; + end; + + if (Abs(Qk) < MachEp) or (Abs(Pk) < MachEp) then + begin + Pkm2 := Pkm2 * Big; + Pkm1 := Pkm1 * Big; + Qkm2 := Qkm2 * Big; + Qkm1 := Qkm1 * Big; + end; + N := N + 1; + until N > 400; + SetErrCode(FPLoss); + +CDone: + CFrac1 := Ans; + end; + + function CFrac2(A, B, X : Float) : Float; + { Continued fraction expansion #2 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Z, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := B - 1.0; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := A + B; + K7 := A + 1.0; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Z := X / (1.0 - X); + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MachEp; + + repeat + Xk := - (Z * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (Z * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 - 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 + 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > Big then + begin + Pkm2 := Pkm2 * MachEp; + Pkm1 := Pkm1 * MachEp; + Qkm2 := Qkm2 * MachEp; + Qkm1 := Qkm1 * MachEp; + end; + + if (Abs(Qk) < MachEp) or (Abs(Pk) < MachEp) then + begin + Pkm2 := Pkm2 * Big; + Pkm1 := Pkm1 * Big; + Qkm2 := Qkm2 * Big; + Qkm1 := Qkm1 * Big; + end; + N := N + 1; + until N > 400; + SetErrCode(FPLoss); + +CDone: + CFrac2 := Ans; + end; + + function IBeta(A, B, X : Float) : Float; + var + A1, B1, X1, T, W, Xc, Y : Float; + Flag : Boolean; + label + Done; + begin + SetErrCode(FOk); + + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) then + begin + IBeta := DefaultVal(FDomain, 0.0); + Exit; + end; + + if X > 1.0 then + begin + IBeta := DefaultVal(FDomain, 1.0); + Exit; + end; + + if (X = 0.0) or (X = 1.0) then + begin + IBeta := X; + Exit; + end; + + Flag := False; + if (B * X <= 1.0) and (X <= 0.95) then + begin + T := PSeries(A, B, X); + goto Done; + end; + + W := 1.0 - X; + + { Reverse a and b if x is greater than the mean. } + if X > A / (A + B) then + begin + Flag := True; + A1 := B; + B1 := A; + Xc := X; + X1 := W; + end + else + begin + A1 := A; + B1 := B; + Xc := W; + X1 := X; + end; + + if Flag and (B1 * X1 <= 1.0) and (X1 <= 0.95) then + begin + T := PSeries(A1, B1, X1); + goto Done; + end; + + { Choose expansion for optimal convergence } + Y := X1 * (A1 + B1 - 2.0) - (A1 - 1.0); + if Y < 0.0 then + W := CFrac1(A1, B1, X1) + else + W := CFrac2(A1, B1, X1) / Xc; + + { Multiply w by the factor + a b _ _ _ + x (1-x) | (a+b) / ( a | (a) | (b) ) } + + Y := A1 * Ln(X1); + T := B1 * Ln(Xc); + if (A1 + B1 < MaxGam) and (Abs(Y) < MaxLog) and (Abs(T) < MaxLog) then + begin + T := Power(Xc, B1) ; + T := T * Power(X1, A1); + T := T / A1; + T := T * W; + T := T * Gamma(A1 + B1) / (Gamma(A1) * Gamma(B1)); + end + else + begin + { Resort to logarithms } + Y := Y + T + LnGamma(A1 + B1) - LnGamma(A1) - LnGamma(B1) + Ln(W / A1); + if Y < MinLog then + T := 0.0 + else + T := Exp(Y); + end; + +Done: + if Flag then + if T <= MachEp then + T := 1.0 - MachEp + else + T := 1.0 - T; + + IBeta := T; + end; + +end. \ No newline at end of file diff --git a/fpmath/uibtdist.pas b/fpmath/uibtdist.pas new file mode 100755 index 0000000..4fa5d8a --- /dev/null +++ b/fpmath/uibtdist.pas @@ -0,0 +1,88 @@ +{ ****************************************************************** + Probability functions related to the incomplete Beta function + ****************************************************************** } + +unit uibtdist; + +interface + +uses + utypes, umath, uibeta; + +function FBeta(A, B, X : Float) : Float; +{ Cumulative probability for Beta distrib. with param. A and B } + +function FBinom(N : Integer; P : Float; K : Integer) : Float; +{ Cumulative probability for binomial distrib. } + +function FStudent(Nu : Integer; X : Float) : Float; +{ Cumulative probability for Student distrib. with Nu d.o.f. } + +function PStudent(Nu : Integer; X : Float) : Float; +{ Prob(|t| > X) for Student distrib. with Nu d.o.f. } + +function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; +{ Cumulative prob. for Fisher-Snedecor distrib. with Nu1 and Nu2 d.o.f. } + +function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; +{ Prob(F > X) for Fisher-Snedecor distrib. with Nu1 and Nu2 d.o.f. } + +implementation + +function FBeta(A, B, X : Float) : Float; +begin + FBeta := IBeta(A, B, X); +end; + +function FBinom(N : Integer; P : Float; K : Integer) : Float; +begin + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + FBinom := DefaultVal(FDomain, 0.0) + else if K = 0 then + FBinom := DefaultVal(FOk, Power(1.0 - P, N)) + else if K = N then + FBinom := DefaultVal(FOk, 1.0) + else + FBinom := 1.0 - IBeta(K + 1, N - K, P); +end; + +function FStudent(Nu : Integer; X : Float) : Float; +var + F : Float; +begin + if Nu < 1 then + FStudent := DefaultVal(FDomain, 0.0) + else if X = 0 then + FStudent := DefaultVal(FOk, 0.5) + else + begin + F := 0.5 * IBeta(0.5 * Nu, 0.5, Nu / (Nu + X * X)); + if X < 0.0 then FStudent := F else FStudent := 1.0 - F; + end; +end; + +function PStudent(Nu : Integer; X : Float) : Float; +begin + if Nu < 1 then + PStudent := DefaultVal(FDomain, 0.0) + else + PStudent := IBeta(0.5 * Nu, 0.5, Nu / (Nu + X * X)); +end; + +function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; +begin + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0) then + FSnedecor := DefaultVal(FDomain, 0.0) + else + FSnedecor := 1.0 - IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); +end; + +function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; +begin + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0) then + PSnedecor := DefaultVal(FDomain, 0.0) + else + PSnedecor := IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); +end; + +end. \ No newline at end of file diff --git a/fpmath/uigamma.pas b/fpmath/uigamma.pas new file mode 100755 index 0000000..41abaf8 --- /dev/null +++ b/fpmath/uigamma.pas @@ -0,0 +1,157 @@ +{ ****************************************************************** + Incomplete Gamma function and related functions. + Translated from C code in Cephes library (http://www.moshier.net) + ****************************************************************** } + +unit uigamma; + +interface + +uses + utypes, ugamma; + +function IGamma(A, X : Float) : Float; +{ Incomplete Gamma function} + +function JGamma(A, X : Float) : Float; +{ Complement of incomplete Gamma function } + +function Erf(X : Float) : Float; +{ Error function } + +function Erfc(X : Float) : Float; +{ Complement of error function } + +implementation + + function IGamma(A, X : Float) : Float; + var + Ans, Ax, C, R : Float; + begin + SetErrCode(FOk); + + if (X <= 0.0) or (A <= 0.0) then + begin + IGamma := 0.0; + Exit; + end; + + if (X > 1.0) and (X > A) then + begin + IGamma := 1.0 - JGamma(A, X); + Exit; + end; + + Ax := A * Ln(X) - X - LnGamma(A); + + if Ax < MinLog then + begin + IGamma := DefaultVal(FUnderflow, 0.0); + Exit; + end; + + Ax := Exp(Ax); + + { Power series } + R := A; + C := 1.0; + Ans := 1.0; + + repeat + R := R + 1.0; + C := C * X / R; + Ans := Ans + C; + until C / Ans <= MachEp; + + IGamma := Ans * Ax / A; + end; + + function JGamma(A, X : Float) : Float; + const + Big = 1.0 / MachEp; + var + Ans, C, Yc, Ax, Y, Z, R, T, + Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2 : Float; + begin + SetErrCode(FOk); + + if (X <= 0.0) or (A <= 0.0) then + begin + JGamma := 1.0; + Exit; + end; + + if (X < 1.0) or (X < A) then + begin + JGamma := 1.0 - IGamma(A, X); + Exit; + end; + + Ax := A * Ln(X) - X - LnGamma(A); + + if Ax < MinLog then + begin + JGamma := DefaultVal(FUnderflow, 0.0); + Exit; + end; + + Ax := Exp(Ax); + + { Continued fraction } + Y := 1.0 - A; + Z := X + Y + 1.0; + C := 0.0; + Pkm2 := 1.0; + Qkm2 := X; + Pkm1 := X + 1.0; + Qkm1 := Z * X; + Ans := Pkm1 / Qkm1; + + repeat + C := C + 1.0; + Y := Y + 1.0; + Z := Z + 2.0; + Yc := Y * C; + Pk := Pkm1 * Z - Pkm2 * Yc; + Qk := Qkm1 * Z - Qkm2 * Yc; + if Qk <> 0.0 then + begin + R := Pk / Qk; + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + if Abs(Pk) > Big then + begin + Pkm2 := Pkm2 * MachEp; + Pkm1 := Pkm1 * MachEp; + Qkm2 := Qkm2 * MachEp; + Qkm1 := Qkm1 * MachEp; + end; + until T <= MachEp; + + JGamma := Ans * Ax; + end; + + function Erf(X : Float) : Float; + begin + if X < 0.0 then + Erf := - IGamma(0.5, Sqr(X)) + else + Erf := IGamma(0.5, Sqr(X)); + end; + + function Erfc(X : Float) : Float; + begin + if X < 0.0 then + Erfc := 1.0 + IGamma(0.5, Sqr(X)) + else + Erfc := JGamma(0.5, Sqr(X)); + end; + +end. \ No newline at end of file diff --git a/fpmath/uigmdist.pas b/fpmath/uigmdist.pas new file mode 100755 index 0000000..95258b7 --- /dev/null +++ b/fpmath/uigmdist.pas @@ -0,0 +1,84 @@ +{ ****************************************************************** + Probability functions related to the incomplete Gamma function + ****************************************************************** } + +unit uigmdist; + +interface + +uses + utypes, uigamma; + +function FGamma(A, B, X : Float) : Float; +{ Cumulative probability for Gamma distrib. with param. A and B } + +function FPoisson(Mu : Float; K : Integer) : Float; +{ Cumulative probability for Poisson distrib. } + +function FNorm(X : Float) : Float; +{ Cumulative probability for standard normal distrib. } + +function PNorm(X : Float) : Float; +{ Prob(|U| > X) for standard normal distrib. } + +function FKhi2(Nu : Integer; X : Float) : Float; +{ Cumulative prob. for khi-2 distrib. with Nu d.o.f. } + +function PKhi2(Nu : Integer; X : Float) : Float; +{ Prob(Khi2 > X) for khi-2 distrib. with Nu d.o.f. } + +implementation + +function FGamma(A, B, X : Float) : Float; +begin + FGamma := IGamma(A, B * X); +end; + +function FPoisson(Mu : Float; K : Integer) : Float; +begin + if (Mu <= 0.0) or (K < 0) then + FPoisson := DefaultVal(FDomain, 0.0) + else if K = 0 then + if (- Mu) < MinLog then + FPoisson := DefaultVal(FUnderflow, 0.0) + else + FPoisson := DefaultVal(FOk, Exp(- Mu)) + else + FPoisson := 1.0 - IGamma(K + 1, Mu); +end; + +function FNorm(X : Float) : Float; +begin + FNorm := 0.5 * (1.0 + Erf(X * Sqrt2div2)); +end; + +function PNorm(X : Float) : Float; +var + A : Float; +begin + A := Abs(X); + if A = 0.0 then + PNorm := DefaultVal(FOk, 1.0) + else if A < 1.0 then + PNorm := 1.0 - Erf(A * Sqrt2div2) + else + PNorm := Erfc(A * Sqrt2div2); +end; + +function FKhi2(Nu : Integer; X : Float) : Float; +begin + if (Nu < 1) or (X <= 0) then + FKhi2 := DefaultVal(FDomain, 0.0) + else + FKhi2 := IGamma(0.5 * Nu, 0.5 * X); +end; + +function PKhi2(Nu : Integer; X : Float) : Float; +begin + if (Nu < 1) or (X <= 0) then + PKhi2 := DefaultVal(FDomain, 0.0) + else + PKhi2 := 1.0 - IGamma(0.5 * Nu, 0.5 * X); +end; + +end. \ No newline at end of file diff --git a/fpmath/uinterv.pas b/fpmath/uinterv.pas new file mode 100755 index 0000000..888d0b0 --- /dev/null +++ b/fpmath/uinterv.pas @@ -0,0 +1,53 @@ +{ ****************************************************************** + Compute an appropriate interval for a set of values + ****************************************************************** } + +unit uinterv; + +interface + +uses + utypes, umath; + +procedure Interval(X1, X2 : Float; + MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); +{ ------------------------------------------------------------------ + Determines an interval [Min, Max] including the values from X1 + to X2, and a subdivision Step of this interval + ------------------------------------------------------------------ + Input parameters : X1, X2 = min. & max. values to be included + MinDiv = minimum nb of subdivisions + MaxDiv = maximum nb of subdivisions + ------------------------------------------------------------------ + Output parameters : Min, Max, Step + ------------------------------------------------------------------ } + +implementation + +procedure Interval(X1, X2 : Float; + MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); + + var + H, R, K : Float; + begin + if X1 >= X2 then Exit; + H := X2 - X1; + R := Int(Log10(H)); + if H < 1.0 then R := R - 1.0; + Step := Exp10(R); + + repeat + K := Int(H / Step); + if K < MinDiv then Step := 0.5 * Step; + if K > MaxDiv then Step := 2.0 * Step; + until (K >= MinDiv) and (K <= MaxDiv); + + Min := Step * Int(X1 / Step); + Max := Step * Int(X2 / Step); + while Min > X1 do Min := Min - Step; + while Max < X2 do Max := Max + Step; + end; + +end. diff --git a/fpmath/uinvbeta.pas b/fpmath/uinvbeta.pas new file mode 100755 index 0000000..ff1bdba --- /dev/null +++ b/fpmath/uinvbeta.pas @@ -0,0 +1,365 @@ +{ ****************************************************************** + Inverses of incomplete Beta function, Student and F-distributions + Translated from C code in Cephes library (http://www.moshier.net) + ****************************************************************** } + +unit uinvbeta; + +interface + +uses + utypes, ugamma, uibeta, uinvnorm; + +function InvBeta(A, B, Y : Float) : Float; +{ ------------------------------------------------------------------ + Inverse of incomplete Beta function. + Given P, the function finds X such that IBeta(A, B, X) = Y + ------------------------------------------------------------------ } + +function InvStudent(Nu : Integer; P : Float) : Float; +{ ------------------------------------------------------------------ + Inverse of Student's t-distribution function + Given probability P, finds the argument X such that + FStudent(Nu, X) = P + ------------------------------------------------------------------ } + +function InvSnedecor(Nu1, Nu2 : Integer; P : Float) : Float; +{ ------------------------------------------------------------------ + Inverse of Snedecor's F-distribution function + Given probability P, finds the argument X such that + FSnedecor(Nu1, Nu2, X) = P + ------------------------------------------------------------------ } + + +implementation + +function InvBeta(A, B, Y : Float) : Float; + +var + a1, b1, y0, y1, d, x, x0, x1 : Float; + lgm, yp, di, dithresh, yl, yh, xt : Float; + i, rflg, ndir, nflg : Integer; + +label + ihalve, newt, under, noconv, done; + +begin + SetErrCode(FOk); + + if Y <= 0 then + begin + InvBeta := 0.0; + Exit; + end; + + if Y >= 1 then + begin + InvBeta := 1.0; + Exit; + end; + + x0 := 0.0; + yl := 0.0; + x1 := 1.0; + yh := 1.0; + nflg := 0; + + if (A <= 1) or (B <= 1) then + begin + dithresh := 1e-6; + rflg := 0; + a1 := A; + b1 := B; + y0 := Y; + x := a1 / (a1 + b1); + y1 := IBeta(a1, b1, x); + goto ihalve + end + else + dithresh := 1e-4; + +{ approximation to inverse function } + + yp := - InvNorm(Y); + + if Y > 0.5 then + begin + rflg := 1; + a1 := B; + b1 := A; + y0 := 1.0 - Y; + yp := -yp; + end + else + begin + rflg := 0; + a1 := A; + b1 := B; + y0 := Y; + end; + + lgm := (yp * yp - 3.0) / 6.0; + x := 2.0 / (1.0 / (2.0 * a1 - 1.0) + 1.0 / (2.0 * b1 - 1.0)); + d := yp * Sqrt(x + lgm) / x + - (1.0 / (2.0 * b1 - 1.0) - 1.0 / (2.0 * a1 - 1.0)) + * (lgm + 5.0 / 6.0 - 2.0 / (3.0 * x)); + d := 2.0 * d; + + if d < MinLog then goto under; + + x := a1 / (a1 + b1 * Exp(d)); + y1 := IBeta(a1, b1, x); + yp := (y1 - y0) / y0; + + if Abs(yp) < 0.2 then goto newt; + +{ Resort to interval halving if not close enough } + +ihalve: + + ndir := 0; + di := 0.5; + + for i := 0 to 99 do + begin + if i <> 0 then + begin + x := x0 + di * (x1 - x0); + if x = 1.0 then x := 1.0 - MachEp; + if x = 0.0 then + begin + di := 0.5; + x := x0 + di * (x1 - x0); + if x = 0.0 then goto under + end; + y1 := IBeta(a1, b1, x); + yp := (x1 - x0) / (x1 + x0); + if abs(yp) < dithresh then goto newt; + yp := (y1 - y0) / y0; + if abs(yp) < dithresh then goto newt; + end; + if y1 < y0 then + begin + x0 := x; + yl := y1; + if ndir < 0 then + begin + ndir := 0; + di := 0.5; + end + else if ndir > 3 then + di := 1.0 - Sqr(1.0 - di) + else if ndir > 1 then + di := 0.5 * di + 0.5 + else + di := (y0 - y1) / (yh - yl); + ndir := ndir + 1; + if x0 > 0.75 then + begin + if rflg = 1 then + begin + rflg := 0; + a1 := A; + b1 := B; + y0 := Y; + end + else + begin + rflg := 1; + a1 := B; + b1 := A; + y0 := 1.0 - Y; + end; + x := 1.0 - x; + y1 := IBeta(a1, b1, x); + x0 := 0.0; + yl := 0.0; + x1 := 1.0; + yh := 1.0; + goto ihalve + end + end + else + begin + x1 := x; + if (rflg = 1) and (x1 < MachEp) then + begin + x := 0.0; + goto done + end; + yh := y1; + if ndir > 0 then + begin + ndir := 0; + di := 0.5 + end + else if ndir < -3 then + di := di * di + else if ndir < -1 then + di := 0.5 * di + else + di := (y1 - y0) / (yh - yl); + ndir := ndir - 1; + end; + end; + + SetErrCode(FPLoss); + + if x0 >= 1.0 then + begin + x := 1.0 - MachEp; + goto done + end; + + if x <= 0.0 then + begin +under: + SetErrCode(FUnderflow); + x := 0.0; + goto done; + end; + +newt: + + if nflg = 1 then goto done; + + nflg := 1; + lgm := LnGamma(a1 + b1) - LnGamma(a1) - LnGamma(b1); + + for i := 0 to 7 do + begin + { Compute the function at this point } + if i <> 0 then y1 := IBeta(a1, b1, x); + if y1 < yl then + begin + x := x0; + y1 := yl + end + else if y1 > yh then + begin + x := x1; + y1 := yh + end + else if y1 < y0 then + begin + x0 := x; + yl := y1 + end + else + begin + x1 := x; + yh := y1 + end; + + if (x = 1.0) or (x = 0.0) then goto noconv; + + { Compute the derivative of the function at this point } + d := (a1 - 1.0) * Ln(x) + (b1 - 1.0) * Ln(1 - x) + lgm; + if d < MinLog then goto done; + if d > MaxLog then goto noconv; + d := exp(d); + + { Compute the step to the next approximation of x } + d := (y1 - y0) / d; + xt := x - d; + if xt <= x0 then + begin + y1 := (x - x0) / (x1 - x0); + xt := x0 + 0.5 * y1 * (x - x0); + if xt <= 0.0 then goto noconv; + end; + if xt >= x1 then + begin + y1 := (x1 - x) / (x1 - x0); + xt := x1 - 0.5 * y1 * (x1 - x); + if xt >= 1.0 then goto noconv; + end; + x := xt; + if abs(d / x) < 128.0 * MachEp then goto done + end; + +noconv: + { Did not converge } + dithresh := 256.0 * MachEp; + goto ihalve; + +done: + + if rflg = 1 then + if x <= MachEp then x := 1.0 - MachEp else x := 1.0 - x; + + InvBeta := x; +end; + +function InvStudent(Nu : Integer; P : Float) : Float; +var + t, rk, z : Float; + rflg : Integer; +begin + if (Nu < 1) or (P < 0.0) or (P > 1.0) then + begin + InvStudent := DefaultVal(FDomain, 0.0); + Exit; + end; + + if P = 0.5 then + begin + SetErrCode(FOk); + InvStudent := 0.0; + Exit; + end; + + rk := Nu; + + if (P > 0.25) and (P < 0.75) then + begin + z := 1.0 - 2.0 * P; + z := InvBeta(0.5, 0.5 * rk, Abs(z)); + t := Sqrt(rk * z / (1 - z)); + if P < 0.5 then t := -t; + InvStudent := t; + Exit; + end; + + if P < 0.5 then + begin + z := P; + rflg := -1 + end + else + begin + z := 1.0 - P; + rflg := 1 + end; + + z := InvBeta(0.5 * rk, 0.5, 2 * z); + + if MaxNum * z < rk then + begin + InvStudent := rflg * MaxNum; + Exit; + end; + + t := Sqrt(rk / z - rk); + InvStudent := rflg * t; +end; + +function InvSnedecor(Nu1, Nu2 : Integer; P : Float) : Float; +var + w : Float; +begin + if (Nu1 < 1) or (Nu2 < 1) or (P < 0.0) or (P > 1.0) then + begin + InvSnedecor := DefaultVal(FDomain, 0.0); + Exit; + end; + + w := InvBeta(0.5 * Nu2, 0.5 * Nu1, 1.0 - P); + InvSnedecor := (Nu2 - Nu2 * w) / (Nu1 * w); +end; + +end. + + + + diff --git a/fpmath/uinvgam.pas b/fpmath/uinvgam.pas new file mode 100755 index 0000000..b0c9dab --- /dev/null +++ b/fpmath/uinvgam.pas @@ -0,0 +1,180 @@ +{ ****************************************************************** + Inverses of incomplete Gamma function and Khi-2 distribution + Translated from C code in Cephes library (http://www.moshier.net) + ****************************************************************** } + +unit uinvgam; + +interface + +uses + utypes, ugamma, uigamma, uinvnorm; + +function InvGamma(A, P : Float) : Float; +{ ------------------------------------------------------------------ + Given P, the function finds X such that + + IGamma(A, X) = P + + It is best valid in the right-hand tail of the distribution, P > 0.5 + ------------------------------------------------------------------ } + +function InvKhi2(Nu : Integer; P : Float) : Float; +{ ------------------------------------------------------------------ + Inverse of Khi-2 distribution function + + Returns the argument, X, for which the area under the Khi-2 + probability density function (integrated from 0 to X) + is equal to P. + ------------------------------------------------------------------ } + +implementation + +function InvGamma(A, P : Float) : Float; + +var + x0, x1, x, Y, yl, yh, y1, d, lgm, dithresh : Float; + i, ndir : Integer; + +label + ihalve, cont, cont1, done; + +begin + if P > 0.5 then SetErrCode(FPLoss) else SetErrCode(FOk); + + Y := 1.0 - P; + + { Bound the solution } + x0 := MaxNum; + yl := 0.0; + x1 := 0.0; + yh := 1.0; + dithresh := 5 * MachEp; + + { Approximation to inverse function } + d := 1.0 / (9.0 * a); + y1 := 1.0 - d - InvNorm(Y) * sqrt(d); + x := a * y1 * y1 * y1; + + lgm := LnGamma(a); + + for i := 0 to 9 do + begin + if (x > x0) or (x < x1) then goto ihalve; + y1 := JGamma(a, x); + if (y1 < yl) or (y1 > yh) then goto ihalve; + if y1 < Y then + begin + x0 := x; + yl := y1 + end + else + begin + x1 := x; + yh := y1 + end; + + { Compute the derivative of the function at this point } + d := (a - 1) * Ln(x) - x - lgm; + if d < MinLog then goto ihalve; + d := -exp(d); + + { Compute the step to the next approximation of x } + d := (y1 - Y) / d; + if abs(d / x) < MachEp then goto done; + x := x - d; + end; + + { Resort to interval halving if Newton iteration did not converge } +ihalve: + + d := 0.0625; + if x0 = MaxNum then + begin + if x <= 0 then x := 1; + while x0 = MaxNum do + begin + x := (1 + d) * x; + y1 := JGamma(a, x); + if y1 < Y then + begin + x0 := x; + yl := y1; + goto cont + end; + d := d + d + end + end; + +cont: + d := 0.5; + ndir := 0; + + for i := 0 to 399 do + begin + x := x1 + d * (x0 - x1); + y1 := JGamma(a, x); + lgm := (x0 - x1) / (x1 + x0); + if abs(lgm) < dithresh then goto cont1; + lgm := (y1 - Y) / Y; + if abs(lgm) < dithresh then goto cont1; + if x <= 0 then goto cont1; + if y1 >= Y then + begin + x1 := x; + yh := y1; + if ndir < 0 then + begin + ndir := 0; + d := 0.5 + end + else if ndir > 1 then + d := 0.5 * d + 0.5 + else + d := (Y - yl) / (yh - yl); + ndir := ndir + 1; + end + else + begin + x0 := x; + yl := y1; + if ndir > 0 then + begin + ndir := 0; + d := 0.5 + end + else if ndir < -1 then + d := 0.5 * d + else + d := (Y - yl) / (yh - yl); + ndir := ndir - 1; + end; + end; + +cont1: + if x = 0 then SetErrCode(FUnderflow); + +done: + InvGamma := x +end; + +function InvKhi2(Nu : Integer; P : Float) : Float; +{ ------------------------------------------------------------------ + Inverse of Khi-2 distribution function + + Returns the argument, X, for which the area under the Khi-2 + probability density function (integrated from 0 to X) + is equal to P. + ------------------------------------------------------------------ } +begin + if (P < 0.0) or (P > 1.0) or (Nu < 1) then + InvKhi2 := DefaultVal(FDomain, 0.0) + else + InvKhi2 := 2.0 * InvGamma(0.5 * Nu, P); +end; + +end. + + + + diff --git a/fpmath/uinvnorm.pas b/fpmath/uinvnorm.pas new file mode 100755 index 0000000..bd1f2b7 --- /dev/null +++ b/fpmath/uinvnorm.pas @@ -0,0 +1,155 @@ +{ ****************************************************************** + Inverse of Normal distribution function + Translated from C code in Cephes library (http://www.moshier.net) + ****************************************************************** } + +unit uinvnorm; + +interface + +uses + utypes, uminmax, upolev; + +function InvNorm(P : Float) : Float; +{ ------------------------------------------------------------------ + Inverse of Normal distribution function + + Returns the argument, X, for which the area under the Gaussian + probability density function (integrated from minus infinity to X) + is equal to P. + ------------------------------------------------------------------ } + +implementation + + function InvNorm(P : Float) : Float; + const + P0 : TabCoef = ( + 8.779679420055069160496E-3, + - 7.649544967784380691785E-1, + 2.971493676711545292135E0, + - 4.144980036933753828858E0, + 2.765359913000830285937E0, + - 9.570456817794268907847E-1, + 1.659219375097958322098E-1, + - 1.140013969885358273307E-2, + 0, 0); + + Q0 : TabCoef = ( + - 5.303846964603721860329E0, + 9.908875375256718220854E0, + - 9.031318655459381388888E0, + 4.496118508523213950686E0, + - 1.250016921424819972516E0, + 1.823840725000038842075E-1, + - 1.088633151006419263153E-2, + 0, 0, 0); + + P1 : TabCoef = ( + 4.302849750435552180717E0, + 4.360209451837096682600E1, + 9.454613328844768318162E1, + 9.336735653151873871756E1, + 5.305046472191852391737E1, + 1.775851836288460008093E1, + 3.640308340137013109859E0, + 3.691354900171224122390E-1, + 1.403530274998072987187E-2, + 1.377145111380960566197E-4); + + Q1 : TabCoef = ( + 2.001425109170530136741E1, + 7.079893963891488254284E1, + 8.033277265194672063478E1, + 5.034715121553662712917E1, + 1.779820137342627204153E1, + 3.845554944954699547539E0, + 3.993627390181238962857E-1, + 1.526870689522191191380E-2, + 1.498700676286675466900E-4, + 0); + + P2 : TabCoef = ( + 3.244525725312906932464E0, + 6.856256488128415760904E0, + 3.765479340423144482796E0, + 1.240893301734538935324E0, + 1.740282292791367834724E-1, + 9.082834200993107441750E-3, + 1.617870121822776093899E-4, + 7.377405643054504178605E-7, + 0, 0); + + Q2 : TabCoef = ( + 6.021509481727510630722E0, + 3.528463857156936773982E0, + 1.289185315656302878699E0, + 1.874290142615703609510E-1, + 9.867655920899636109122E-3, + 1.760452434084258930442E-4, + 8.028288500688538331773E-7, + 0, 0, 0); + + P3 : TabCoef = ( + 2.020331091302772535752E0, + 2.133020661587413053144E0, + 2.114822217898707063183E-1, + - 6.500909615246067985872E-3, + - 7.279315200737344309241E-4, + - 1.275404675610280787619E-5, + - 6.433966387613344714022E-8, + - 7.772828380948163386917E-11, + 0, 0); + + Q3 : TabCoef = ( + 2.278210997153449199574E0, + 2.345321838870438196534E-1, + - 6.916708899719964982855E-3, + - 7.908542088737858288849E-4, + - 1.387652389480217178984E-5, + - 7.001476867559193780666E-8, + - 8.458494263787680376729E-11, + 0, 0, 0); + + var + X, Y, Z, Y2, X0, X1 : Float; + Code : Integer; + begin + if (P <= 0.0) or (P >= 1.0) then + begin + InvNorm := DefaultVal(FDomain, Sgn(P) * MaxNum); + Exit; + end; + + Code := 1; + Y := P; + if Y > (1.0 - 0.13533528323661269189) then { 0.135... = exp(-2) } + begin + Y := 1.0 - Y; + Code := 0; + end; + if Y > 0.13533528323661269189 then + begin + Y := Y - 0.5; + Y2 := Y * Y; + X := Y + Y * (Y2 * PolEvl(Y2, P0, 7) / P1Evl(Y2, Q0, 7)); + X := X * Sqrt2Pi; + InvNorm := X; + Exit; + end; + + X := Sqrt(- 2.0 * Ln(Y)); + X0 := X - Ln(X) / X; + Z := 1.0 / X; + if X < 8.0 then + X1 := Z * PolEvl(Z, P1, 9) / P1Evl(Z, Q1, 9) + else if X < 32.0 then + X1 := Z * PolEvl(Z, P2, 7) / P1Evl(Z, Q2, 7) + else + X1 := Z * PolEvl(Z, P3, 7) / P1Evl(Z, Q3, 7); + X := X0 - X1; + if Code <> 0 then + X := - X; + InvNorm := X; + end; + +end. \ No newline at end of file diff --git a/fpmath/ujacobi.pas b/fpmath/ujacobi.pas new file mode 100755 index 0000000..c5a33ea --- /dev/null +++ b/fpmath/ujacobi.pas @@ -0,0 +1,179 @@ +{ ****************************************************************** + Eigenvalues and eigenvectors of a symmetric matrix + ****************************************************************** } + +unit ujacobi; + +interface + +uses + utypes, uminmax, utrigo; + +procedure Jacobi(A : PMatrix; + Lb, Ub, MaxIter : Integer; + Tol : Float; + Lambda : PVector; + V : PMatrix); +{ ------------------------------------------------------------------ + Eigenvalues and eigenvectors of a symmetric matrix by the + iterative method of Jacobi + ------------------------------------------------------------------ + Input parameters : A = matrix + Lb = index of first matrix element + Ub = index of last matrix element + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : Lambda = eigenvalues in decreasing order + V = matrix of eigenvectors (columns) + ------------------------------------------------------------------ + Possible results : MatOk + MatNonConv + ------------------------------------------------------------------ + The eigenvectors are normalized, with their first component > 0 + This procedure destroys the original matrix A + ------------------------------------------------------------------ } + +implementation + +procedure Jacobi(A : PMatrix; + Lb, Ub, MaxIter : Integer; + Tol : Float; + Lambda : PVector; + V : PMatrix); + + var + I, J, K, Im, Jm, Iter : Integer; + B, C, C2, Na, Nd, P, Q, S, S2, R, T : Float; + + begin + Iter := 0; + Na := 0.0; + Nd := 0.0; + R := 0.0; + + for I := Lb to Ub do + begin + V^[I]^[I] := 1.0; + Nd := Nd + Sqr(A^[I]^[I]); + if I <> Ub then + for J := Succ(I) to Ub do + begin + R := R + Sqr(A^[I]^[J]); + V^[I]^[J] := 0.0; + V^[J]^[I] := 0.0; + end; + end; + + Na := Nd + 2.0 * R; + + repeat + R := 0.0; + for I := Lb to Pred(Ub) do + for J := Succ(I) to Ub do + begin + T := Abs(A^[I]^[J]); + if T > R then + begin + R := T; + Im := I; + Jm := J; + end; + end; + + B := A^[Im]^[Im] - A^[Jm]^[Jm]; + + if B = 0 then + begin + C := Sqrt2div2; + S := C * Sgn(A^[Im]^[Jm]); + end + else + begin + P := 2.0 * A^[Im]^[Jm] * Sgn(B); + Q := Abs(B); + R := Pythag(P, Q); + C := Sqrt(0.5 * (1.0 + Q / R)); + S := 0.5 * P / (R * C); + end; + + for K := Lb to Ub do + begin + R := V^[K]^[Im]; + V^[K]^[Im] := C * R + S * V^[K]^[Jm]; + V^[K]^[Jm] := C * V^[K]^[Jm] - S * R; + end; + + if Im <> Lb then + for K := Lb to Pred(Im) do + begin + R := A^[K]^[Im]; + A^[K]^[Im] := C * R + S * A^[K]^[Jm]; + A^[K]^[Jm] := C * A^[K]^[Jm] - S * R; + end; + + if Jm <> Succ(Im) then + for K := Succ(Im) to Pred(Jm) do + begin + R := A^[Im]^[K]; + A^[Im]^[K] := C * R + S * A^[K]^[Jm]; + A^[K]^[Jm] := C * A^[K]^[Jm] - S * R; + end; + + if Jm <> Ub then + for K := Succ(Jm) to Ub do + begin + R := A^[Im]^[K]; + A^[Im]^[K] := C * R + S * A^[Jm]^[K]; + A^[Jm]^[K] := C * A^[Jm]^[K] - S * R; + end; + + Nd := Nd + 2.0 * Sqr(A^[Im]^[Jm]); + + C2 := Sqr(C); + S2 := Sqr(S); + P := 2.0 * S * C * A^[Im]^[Jm]; + R := A^[Im]^[Im]; + A^[Im]^[Im] := C2 * R + S2 * A^[Jm]^[Jm] + P; + A^[Jm]^[Jm] := S2 * R + C2 * A^[Jm]^[Jm] - P; + A^[Im]^[Jm] := 0.0; + + Inc(Iter); + if Iter > MaxIter then + begin + SetErrCode(MatNonConv); + Exit; + end; + until Abs(1.0 - Na / Nd) < Tol; + + { The diagonal terms of the transformed matrix are the eigenvalues } + for I := Lb to Ub do + Lambda^[I] := A^[I]^[I]; + + { Sort eigenvalues and eigenvectors } + for I := Lb to Pred(Ub) do + begin + K := I; + R := Lambda^[I]; + for J := Succ(I) to Ub do + if Lambda^[J] > R then + begin + K := J; + R := Lambda^[J]; + end; + + FSwap(Lambda^[I], Lambda^[K]); + for J := Lb to Ub do + FSwap(V^[J]^[I], V^[J]^[K]); + end; + + { Make sure that the first component of each eigenvector is > 0 } + for J := Lb to Ub do + if V^[Lb]^[J] < 0.0 then + for I := Lb to Ub do + V^[I]^[J] := - V^[I]^[J]; + + SetErrCode(MatOk); + end; + +end. diff --git a/fpmath/ukhi2.pas b/fpmath/ukhi2.pas new file mode 100755 index 0000000..e3a7ffb --- /dev/null +++ b/fpmath/ukhi2.pas @@ -0,0 +1,97 @@ +{ ****************************************************************** + Khi-2 test + ****************************************************************** } + +unit ukhi2; + +interface + +uses + utypes; + +procedure Khi2_Conform(N_cls : Integer; + N_estim : Integer; + Obs : PIntVector; + Calc : PVector; + var Khi2 : Float; + var DoF : Integer); +{ ------------------------------------------------------------------ + Khi-2 test for conformity + ------------------------------------------------------------------ } + +procedure Khi2_Indep(N_lin : Integer; + N_col : Integer; + Obs : PIntMatrix; + var Khi2 : Float; + var DoF : Integer); +{ ------------------------------------------------------------------ + Khi-2 test for independence + ------------------------------------------------------------------ } + +implementation + +procedure Khi2_Conform(N_cls : Integer; + N_estim : Integer; + Obs : PIntVector; + Calc : PVector; + var Khi2 : Float; + var DoF : Integer); + +var + I : Integer; + +begin + Khi2 := 0.0; + + for I := 1 to N_cls do + Khi2 := Khi2 + Sqr(Obs^[I] - Calc^[I]) / Calc^[I]; + + DoF := N_cls - N_estim - 1; +end; + +procedure Khi2_Indep(N_lin : Integer; + N_col : Integer; + Obs : PIntMatrix; + var Khi2 : Float; + var DoF : Integer); + +var + SumLin, SumCol : PIntVector; + Sum : Integer; + Prob, Calc : Float; + I, J : Integer; + +begin + DimIntVector(SumLin, N_lin); + DimIntVector(SumCol, N_col); + + for I := 1 to N_lin do + for J := 1 to N_col do + SumLin^[I] := SumLin^[I] + Obs^[I]^[J]; + + for J := 1 to N_col do + for I := 1 to N_lin do + SumCol^[J] := SumCol^[J] + Obs^[I]^[J]; + + Sum := 0; + for I := 1 to N_lin do + Sum := Sum + SumLin^[I]; + + Khi2 := 0.0; + for I := 1 to N_lin do + begin + Prob := SumLin^[I] / Sum; + for J := 1 to N_col do + begin + Calc := SumCol^[J] * Prob; + Khi2 := Khi2 + Sqr(Obs^[I]^[J] - Calc) / Calc; + end; + end; + + DoF := Pred(N_lin) * Pred(N_col); + + DelIntVector(SumLin, N_lin); + DelIntVector(SumCol, N_col); +end; + +end. \ No newline at end of file diff --git a/fpmath/ulambert.pas b/fpmath/ulambert.pas new file mode 100755 index 0000000..53a8a8a --- /dev/null +++ b/fpmath/ulambert.pas @@ -0,0 +1,171 @@ +{ ****************************************************************** + Lambert's function + Translated from Fortran code by Barry et al. + (http://www.netlib.org/toms/743) + ****************************************************************** } + +unit ulambert; + +interface + +uses + utypes, umath; + +function LambertW(X : Float; UBranch, Offset : Boolean) : Float; +{ ---------------------------------------------------------------------- + Lambert's W function: Y = W(X) ==> X = Y * Exp(Y) X >= -1/e + ---------------------------------------------------------------------- + X = Argument + UBranch = TRUE for computing the upper branch (X >= -1/e, W(X) >= -1) + FALSE for computing the lower branch (-1/e <= X < 0, W(X) <= -1) + Offset = TRUE for computing W(X - 1/e), X >= 0 + FALSE for computing W(X) + ---------------------------------------------------------------------- } + +implementation + +{$IFDEF SINGLEREAL} +const + NBITS = 23; { MachEp = 2^(-NBITS) } + X0 = 0.03507693900966790567; { MachEp^(1/6) / 2 } + X1 = -0.30212011943278473033; { - Exp(-1) * (1 - 17 * MachEp^(2/7) } +{$ELSE} +{$IFDEF EXTENDEDREAL} +const + NBITS = 63; + X0 = 0.0003452669830012439084; + X1 = -0.36785558424357094358; +{$ELSE} +const + NBITS = 52; + X0 = 0.001230391650287962075; + X1 = -0.36766871970031223379; +{$ENDIF} +{$ENDIF} + +const + EM = -0.36787944117144232160; { - Exp(-1) } + EM9 = -0.0001234098040866795495; { - Exp(-9) } + C13 = 1.0 / 3.0; + C23 = 2.0 * C13; + EM2 = 2.0 / EM; + D12 = - EM2; + AN3 = 8.0 / 3.0; + AN4 = 135.0 / 83.0; + AN5 = 166.0 / 39.0; + AN6 = 3167.0 / 3549.0; + S21 = 2.0 * Sqrt2 - 3.0; + S22 = 4.0 - 3.0 * Sqrt2; + S23 = Sqrt2 - 2.0; + + + function LambertW(X : Float; UBranch, Offset : Boolean) : Float; + var + I, NITER : Integer; + AN2, DELX, ETA, RETA, T, TEMP, TEMP2, TS, WAPR, XX, ZL, ZN : Float; + + begin + SetErrCode(FOk); + + if Offset then + begin + DELX := X; + if DELX < 0.0 then + begin + LambertW := DefaultVal(FDomain, 0.0); + Exit; + end; + XX := X + EM; + end + else + begin + if X < EM then + begin + LambertW := DefaultVal(FDomain, 0.0); + Exit; + end; + + if X = EM then + begin + LambertW := - 1.0; + Exit; + end; + + XX := X; + DELX := XX - EM; + end; + + if UBranch then + begin + if Abs(XX) <= X0 then + begin + LambertW := XX / (1.0 + XX / (1.0 + XX / (2.0 + XX / (0.6 + 0.34 * XX)))); + Exit; + end; + + if XX <= X1 then + begin + RETA := Sqrt(D12 * DELX); + LambertW := RETA / (1.0 + RETA / (3.0 + RETA / (RETA / (AN4 + + RETA / (RETA * AN6 + AN5)) + AN3))) - 1.0; + Exit; + end; + + if XX <= 20.0 then + begin + RETA := Sqrt2 * Sqrt(1.0 - XX / EM); + AN2 := 4.612634277343749 * Sqrt(Sqrt(RETA + 1.09556884765625)); + WAPR := RETA / (1.0 + RETA / (3.0 + (S21 * AN2 + S22) * RETA / (S23 * (AN2 + RETA)))) - 1.0; + end + else + begin + ZL := Ln(XX); + WAPR := Ln(XX / Ln(XX / Power(ZL, Exp(- 1.124491989777808 / (0.4225028202459761 + ZL))))); + end + end + else + begin + if XX >= 0.0 then + begin + LambertW := DefaultVal(FDomain, 0.0); + Exit; + end; + + if XX <= X1 then + begin + RETA := Sqrt(D12 * DELX); + LambertW := RETA / (RETA / (3.0 + RETA / (RETA / (AN4 + + RETA / (RETA * AN6 - AN5)) - AN3)) - 1.0) - 1.0; + Exit; + end; + + ZL := Ln(- XX); + + if XX <= EM9 then + begin + T := - 1.0 - ZL; + TS := Sqrt(T); + WAPR := ZL - (2.0 * TS) / (SQRT2 + (C13 - T / (2.7E2 + TS * 127.0471381349219)) * TS); + end + else + begin + ETA := 2.0 - EM2 * XX; + WAPR := Ln(XX / Ln(- XX / ((1.0 - 0.5043921323068457 * (ZL + 1.0)) * (Sqrt(ETA) + ETA / 3.0) + 1.0))); + end + end; + + if NBITS < 56 then NITER := 1 else NITER := 2; + + for I := 1 to NITER do + begin + ZN := Ln(XX / WAPR) - WAPR; + TEMP := 1.0 + WAPR; + TEMP2 := TEMP + C23 * ZN; + TEMP2 := 2.0 * TEMP * TEMP2; + WAPR := WAPR * (1.0 + (ZN / TEMP) * (TEMP2 - ZN) / (TEMP2 - 2.0 * ZN)); + end; + + LambertW := WAPR; + end; + +end. diff --git a/fpmath/ulineq.o b/fpmath/ulineq.o new file mode 100644 index 0000000..748b8c9 Binary files /dev/null and b/fpmath/ulineq.o differ diff --git a/fpmath/ulineq.pas b/fpmath/ulineq.pas new file mode 100755 index 0000000..09482d8 --- /dev/null +++ b/fpmath/ulineq.pas @@ -0,0 +1,163 @@ +{ ****************************************************************** + Solution of a system of linear equations with a single + constant vector by Gauss-Jordan method + ****************************************************************** } + +unit ulineq; + +interface + +uses + utypes, uminmax; + +procedure LinEq(A : PMatrix; + B : PVector; + Lb, Ub : Integer; + var Det : Float); +{ ------------------------------------------------------------------ + Solves a linear system according to the Gauss-Jordan method + ------------------------------------------------------------------ + Input parameters : A = system matrix + B = constant vector + Lb, Ub = lower and upper array bounds + ------------------------------------------------------------------ + Output parameters : A = inverse matrix + B = solution vector + Det = determinant of A + ------------------------------------------------------------------ + Possible results : MatOk : No error + MatSing : Singular matrix + ------------------------------------------------------------------ } + +implementation + +procedure LinEq(A : PMatrix; + B : PVector; + Lb, Ub : Integer; + var Det : Float); +var + Pvt : Float; { Pivot } + Ik, Jk : Integer; { Pivot's row and column } + I, J, K : Integer; { Loop variables } + T : Float; { Temporary variable } + PRow, PCol : PIntVector; { Stores pivot's row and column } + MCol : PVector; { Stores a column of matrix A } + + procedure Terminate(ErrCode : Integer); + { Set error code and deallocate arrays } + begin + DelIntVector(PRow, Ub); + DelIntVector(PCol, Ub); + DelVector(MCol, Ub); + SetErrCode(ErrCode); + end; + +begin + DimIntVector(PRow, Ub); + DimIntVector(PCol, Ub); + DimVector(MCol, Ub); + + Det := 1.0; + + K := Lb; + while K <= Ub do + begin + { Search for largest pivot in submatrix + A[K..Ub, K..Ub] } + Pvt := A^[K]^[K]; + Ik := K; + Jk := K; + for I := K to Ub do + for J := K to Ub do + if Abs(A^[I]^[J]) > Abs(Pvt) then + begin + Pvt := A^[I]^[J]; + Ik := I; + Jk := J; + end; + + { Store pivot's position } + PRow^[K] := Ik; + PCol^[K] := Jk; + + { Update determinant } + Det := Det * Pvt; + if Ik <> K then Det := - Det; + if Jk <> K then Det := - Det; + + { Too weak pivot ==> quasi-singular matrix } + if Abs(Pvt) < MachEp then + begin + Terminate(MatSing); + Exit + end; + + { Exchange current row (K) with pivot row (Ik) } + if Ik <> K then + begin + for J := Lb to Ub do + FSwap(A^[Ik]^[J], A^[K]^[J]); + FSwap(B^[Ik], B^[K]); + end; + + { Exchange current column (K) with pivot column (Jk) } + if Jk <> K then + for I := Lb to Ub do + FSwap(A^[I]^[Jk], A^[I]^[K]); + + { Store column K of matrix A into MCol + and set this column to zero } + for I := Lb to Ub do + if I <> K then + begin + MCol^[I] := A^[I]^[K]; + A^[I]^[K] := 0.0; + end + else + begin + MCol^[I] := 0.0; + A^[I]^[K] := 1.0; + end; + + { Transform pivot row } + T := 1.0 / Pvt; + for J := Lb to Ub do + A^[K]^[J] := T * A^[K]^[J]; + B^[K] := T * B^[K]; + + { Transform other rows } + for I := Lb to Ub do + if I <> K then + begin + T := MCol^[I]; + for J := Lb to Ub do + A^[I]^[J] := A^[I]^[J] - T * A^[K]^[J]; + B^[I] := B^[I] - T * B^[K]; + end; + + Inc(K); + end; + + { Exchange lines of inverse matrix and solution vector } + for I := Ub downto Lb do + begin + Ik := PCol^[I]; + if Ik <> I then + for J := Lb to Ub do + FSwap(A^[I]^[J], A^[Ik]^[J]); + FSwap(B^[I], B^[Ik]); + end; + + { Exchange columns of inverse matrix } + for J := Ub downto Lb do + begin + Jk := PRow^[J]; + if Jk <> J then + for I := Lb to Ub do + FSwap(A^[I]^[J], A^[I]^[Jk]); + end; + + Terminate(MatOk); +end; + +end. diff --git a/fpmath/ulineq.ppu b/fpmath/ulineq.ppu new file mode 100644 index 0000000..df403a1 Binary files /dev/null and b/fpmath/ulineq.ppu differ diff --git a/fpmath/ulinfit.pas b/fpmath/ulinfit.pas new file mode 100755 index 0000000..8571521 --- /dev/null +++ b/fpmath/ulinfit.pas @@ -0,0 +1,136 @@ +{ ****************************************************************** + Linear regression : Y = B(0) + B(1) * X + ****************************************************************** } + +unit ulinfit; + +interface + +uses + utypes; + +procedure LinFit(X, Y : PVector; + Lb, Ub : Integer; + B : PVector; + V : PMatrix); +{ ------------------------------------------------------------------ + Unweighted linear regression + ------------------------------------------------------------------ + Input parameters: X, Y = point coordinates + Lb, Ub = array bounds + Output parameters: B = regression parameters + V = inverse matrix + ------------------------------------------------------------------ } + +procedure WLinFit(X, Y, S : PVector; + Lb, Ub : Integer; + B : PVector; + V : PMatrix); +{ ------------------------------------------------------------------ + Weighted linear regression + ------------------------------------------------------------------ + Additional input parameter: + S = standard deviations of observations + ------------------------------------------------------------------ } + +implementation + +procedure LinFit(X, Y : PVector; + Lb, Ub : Integer; + B : PVector; + V : PMatrix); + + var + SX, SY, SX2, SXY, D : Float; + K, N : Integer; + + begin + N := Ub - Lb + 1; + + SX := 0.0; + SY := 0.0; + SX2 := 0.0; + SXY := 0.0; + + for K := Lb to Ub do + begin + SX := SX + X^[K]; + SY := SY + Y^[K]; + SX2 := SX2 + Sqr(X^[K]); + SXY := SXY + X^[K] * Y^[K]; + end; + + D := N * SX2 - Sqr(SX); + + if D <= 0.0 then + begin + SetErrCode(MatSing); + Exit; + end; + + SetErrCode(MatOk); + + V^[0]^[0] := SX2 / D; + V^[0]^[1] := - SX / D; + V^[1]^[0] := V^[0]^[1]; + V^[1]^[1] := N / D; + + B^[0] := V^[0]^[0] * SY + V^[0]^[1] * SXY; + B^[1] := V^[1]^[0] * SY + V^[1]^[1] * SXY; + end; + +procedure WLinFit(X, Y, S : PVector; + Lb, Ub : Integer; + B : PVector; + V : PMatrix); + + var + W, WX, SW, SWX, SWY, SWX2, SWXY, D : Float; + K : Integer; + + begin + SW := 0.0; + SWX := 0.0; + SWY := 0.0; + SWX2 := 0.0; + SWXY := 0.0; + + for K := Lb to Ub do + begin + if S^[K] <= 0.0 then + begin + SetErrCode(MatSing); + Exit; + end; + + W := 1.0 / Sqr(S^[K]); + WX := W * X^[K]; + + SW := SW + W; + SWX := SWX + WX; + SWY := SWY + W * Y^[K]; + SWX2 := SWX2 + WX * X^[K]; + SWXY := SWXY + WX * Y^[K]; + end; + + D := SW * SWX2 - Sqr(SWX); + + if D <= 0.0 then + begin + SetErrCode(MatSing); + Exit; + end; + + SetErrCode(MatOk); + + V^[0]^[0] := SWX2 / D; + V^[0]^[1] := - SWX / D; + V^[1]^[0] := V^[0]^[1]; + V^[1]^[1] := SW / D; + + B^[0] := V^[0]^[0] * SWY + V^[0]^[1] * SWXY; + B^[1] := V^[1]^[0] * SWY + V^[1]^[1] * SWXY; + end; + +end. + diff --git a/fpmath/ulinmin.pas b/fpmath/ulinmin.pas new file mode 100755 index 0000000..34b2486 --- /dev/null +++ b/fpmath/ulinmin.pas @@ -0,0 +1,198 @@ +{ ****************************************************************** + Minimization of a function of several variables along a line + ****************************************************************** } + +unit ulinmin; + +interface + +uses + utypes, uminmax; + +procedure LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lb, Ub : Integer; + var R : Float; + MaxIter : Integer; + Tol : Float; + var F_min : Float); +{ ------------------------------------------------------------------ + Minimizes function Func from point X in the direction specified by + DeltaX + ------------------------------------------------------------------ + Input parameters : Func = objective function + X = initial minimum coordinates + DeltaX = direction in which minimum is searched + Lb, Ub = indices of first and last variables + R = initial step, in fraction of |DeltaX| + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : X = refined minimum coordinates + R = step corresponding to the minimum + F_min = function value at minimum + ------------------------------------------------------------------ + Possible results : OptOk + OptNonConv + ------------------------------------------------------------------ } + +implementation + +procedure LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lb, Ub : Integer; + var R : Float; + MaxIter : Integer; + Tol : Float; + var F_min : Float); + +var + A, B, C : Float; + Fa, Fb, Fc, F1, F2 : Float; + MinTol, Norm : Float; + R0, R1, R2, R3 : Float; + I, Iter : Integer; + P : PVector; + +begin + MinTol := Sqrt(MachEp); + if Tol < MinTol then Tol := MinTol; + + if R < 0.0 then R := 1.0; + + Norm := 0.0; + for I := Lb to Ub do + Norm := Norm + Sqr(DeltaX^[I]); + Norm := Sqrt(Norm); + + A := 0; B := R * Norm; + + DimVector(P, Ub); + + { Bracket the minimum (see procedure MinBrack in unit UMINBRAK) } + + for I := Lb to Ub do + P^[I] := X^[I]; + + Fa := Func(P); + + for I := Lb to Ub do + P^[I] := X^[I] + B * DeltaX^[I]; + + Fb := Func(P); + + if Fb > Fa then + begin + FSwap(A, B); + FSwap(Fa, Fb); + end; + + C := B + Gold * (B - A); + + for I := Lb to Ub do + P^[I] := X^[I] + C * DeltaX^[I]; + + Fc := Func(P); + + while Fc < Fb do + begin + A := B; + B := C; + Fa := Fb; + Fb := Fc; + C := B + Gold * (B - A); + + for I := Lb to Ub do + P^[I] := X^[I] + C * DeltaX^[I]; + + Fc := Func(P); + end; + + if A > C then + begin + FSwap(A, C); + FSwap(Fa, Fc); + end; + + { Refine the minimum (see procedure GoldSearch in unit UGOLDSRC) } + + R0 := A; R3 := C; + + if (C - B) > (B - A) then + begin + R1 := B; + R2 := B + CGold * (C - B); + F1 := Fb; + + for I := Lb to Ub do + P^[I] := X^[I] + R2 * DeltaX^[I]; + + F2 := Func(P); + end + else + begin + R1 := B - CGold * (B - A); + R2 := B; + + for I := Lb to Ub do + P^[I] := X^[I] + R1 * DeltaX^[I]; + + F1 := Func(P); + F2 := Fb; + end; + + Iter := 0; + + while (Iter <= MaxIter) and (Abs(R3 - R0) > Tol * (Abs(R1) + Abs(R2))) do + begin + if F2 < F1 then + begin + R0 := R1; + R1 := R2; + F1 := F2; + R2 := R1 + CGold * (R3 - R1); + + for I := Lb to Ub do + P^[I] := X^[I] + R2 * DeltaX^[I]; + + F2 := Func(P); + end + else + begin + R3 := R2; + R2 := R1; + F2 := F1; + R1 := R2 - CGold * (R2 - R0); + + for I := Lb to Ub do + P^[I] := X^[I] + R1 * DeltaX^[I]; + + F1 := Func(P); + end; + + Iter := Iter + 1; + end; + + if F1 < F2 then + begin + R := R1; + F_min := F1; + end + else + begin + R := R2; + F_min := F2; + end; + + for I := Lb to Ub do + X^[I] := X^[I] + R * DeltaX^[I]; + + if Iter > MaxIter then + SetErrCode(OptNonConv) + else + SetErrCode(OptOk); + + DelVector(P, Ub); +end; + +end. diff --git a/fpmath/ulinminq.pas b/fpmath/ulinminq.pas new file mode 100755 index 0000000..3476242 --- /dev/null +++ b/fpmath/ulinminq.pas @@ -0,0 +1,209 @@ +{ ****************************************************************** + Minimization of a sum of squared functions along a line + (Used internally by equation solvers) + ****************************************************************** } + +unit ulinminq; + +interface + +uses + utypes; + +procedure LinMinEq(Equations : TEquations; + X, DeltaX, F : PVector; + Lb, Ub : Integer; + R : Float; + MaxIter : Integer; + Tol : Float); +{ ------------------------------------------------------------------ + Minimizes a sum of squared functions from point X in the direction + specified by DeltaX, using golden search as the minimization algo. + ------------------------------------------------------------------ + Input parameters : SysFunc = system of functions + X = starting point + DeltaX = search direction + Lb, Ub = bounds of X + R = initial step, in fraction of |DeltaX| + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters: X = refined minimum coordinates + F = function values at minimum + R = step corresponding to the minimum + ------------------------------------------------------------------ + Possible results : OptOk = no error + OptNonConv = non-convergence + ------------------------------------------------------------------ } + +implementation + +procedure LinMinEq(Equations : TEquations; + X, DeltaX, F : PVector; + Lb, Ub : Integer; + R : Float; + MaxIter : Integer; + Tol : Float); + +var + I, Iter : Integer; + A, B, C, Fa, Fb, Fc : Float; + R0, R1, R2, R3, F1, F2 : Float; + MinTol, Norm : Float; + P : PVector; + + procedure Swap2(var A, B, Fa, Fb : Float); + { Exchanges A <--> B, Fa <--> Fb } + var + Temp : Float; + begin + Temp := A; + A := B; + B := Temp; + Temp := Fa; + Fa := Fb; + Fb := Temp; + end; + + function SumSqrFn : Float; + { Computes the sum of squared functions F(i)^2 at point P } + var + Sum : Float; + I : Integer; + begin + Equations(P, F); + + Sum := 0.0; + for I := Lb to Ub do + Sum := Sum + Sqr(F^[I]); + + SumSqrFn := Sum; + end; + +begin + DimVector(P, Ub); + + MinTol := Sqrt(MachEp); + if Tol < MinTol then Tol := MinTol; + if R <= 0.0 then R := 1.0; + + Norm := 0.0; + for I := Lb to Ub do + Norm := Norm + Sqr(DeltaX^[I]); + Norm := Sqrt(Norm); + + { Bracket the minimum } + + A := 0.0; B := R * Norm; + + for I := Lb to Ub do + P^[I] := X^[I]; + + Fa := SumSqrFn; + + for I := Lb to Ub do + P^[I] := X^[I] + B * DeltaX^[I]; + + Fb := SumSqrFn; + + if Fb > Fa then Swap2(A, B, Fa, Fb); + + C := B + Gold * (B - A); + + for I := Lb to Ub do + P^[I] := X^[I] + C * DeltaX^[I]; + + Fc := SumSqrFn; + + while Fc < Fb do + begin + A := B; + B := C; + Fa := Fb; + Fb := Fc; + C := B + Gold * (B - A); + + for I := Lb to Ub do + P^[I] := X^[I] + C * DeltaX^[I]; + + Fc := SumSqrFn; + end; + + if A > C then Swap2(A, C, Fa, Fc); + + { Refine the minimum } + + R0 := A; R3 := C; + + if (C - B) > (B - A) then + begin + R1 := B; + R2 := B + CGold * (C - B); + F1 := Fb; + + for I := Lb to Ub do + P^[I] := X^[I] + R2 * DeltaX^[I]; + + F2 := SumSqrFn; + end + else + begin + R1 := B - CGold * (B - A); + R2 := B; + + for I := Lb to Ub do + P^[I] := X^[I] + R1 * DeltaX^[I]; + + F1 := SumSqrFn; + F2 := Fb; + end; + + Iter := 0; + + while (Iter <= MaxIter) and (Abs(R3 - R0) > Tol * (Abs(R1) + Abs(R2))) do + begin + if F2 < F1 then + begin + R0 := R1; + R1 := R2; + F1 := F2; + R2 := R1 + CGold * (R3 - R1); + + for I := Lb to Ub do + P^[I] := X^[I] + R2 * DeltaX^[I]; + + F2 := SumSqrFn; + end + else + begin + R3 := R2; + R2 := R1; + F2 := F1; + R1 := R2 - CGold * (R2 - R0); + + for I := Lb to Ub do + P^[I] := X^[I] + R1 * DeltaX^[I]; + + F1 := SumSqrFn + end; + + Iter := Iter + 1; + end; + + if F1 < F2 then R := R1 else R := R2; + + for I := Lb to Ub do + X^[I] := X^[I] + R * DeltaX^[I]; + + Equations(X, F); + + if Iter > MaxIter then + SetErrCode(OptNonConv) + else + SetErrCode(OptOk); + + DelVector(P, Ub); +end; + +end. + diff --git a/fpmath/ulu.pas b/fpmath/ulu.pas new file mode 100755 index 0000000..c4a5f70 --- /dev/null +++ b/fpmath/ulu.pas @@ -0,0 +1,159 @@ +{ ****************************************************************** + LU decomposition + ****************************************************************** } + +unit ulu; + +interface + +uses + utypes, uminmax; + +procedure LU_Decomp(A : PMatrix; Lb, Ub : Integer); +{ ---------------------------------------------------------------------- + LU decomposition. Factors the square matrix A as a product L * U, + where L is a lower triangular matrix (with unit diagonal terms) and U + is an upper triangular matrix. This routine is used in conjunction + with LU_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lb = index of first matrix element + Ub = index of last matrix element + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of L and U + ---------------------------------------------------------------------- + Possible results : MatOk + MatSing + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure LU_Solve(A : PMatrix; B : PVector; Lb, Ub : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations whose matrix has been transformed by + LU_Decomp + ---------------------------------------------------------------------- + Input parameters : A = result from LU_Decomp + B = constant vector + Lb, Ub = as in LU_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + ---------------------------------------------------------------------- } + +implementation + +const + InitDim : Integer = 0; { Initial vector size } + Index : PIntVector = nil; { Records the row permutations } + +procedure LU_Decomp(A : PMatrix; Lb, Ub : Integer); + var + I, Imax, J, K : Integer; + Pvt, T, Sum : Float; + V : PVector; + begin + { Reallocate Index if necessary} + if Ub > InitDim then + begin + DelIntVector(Index, InitDim); + DimIntVector(Index, Ub); + InitDim := Ub; + end; + + DimVector(V, Ub); + + for I := Lb to Ub do + begin + Pvt := 0.0; + for J := Lb to Ub do + if Abs(A^[I]^[J]) > Pvt then + Pvt := Abs(A^[I]^[J]); + if Pvt < MachEp then + begin + DelVector(V, Ub); + SetErrCode(MatSing); + Exit; + end; + V^[I] := 1.0 / Pvt; + end; + + for J := Lb to Ub do + begin + for I := Lb to Pred(J) do + begin + Sum := A^[I]^[J]; + for K := Lb to Pred(I) do + Sum := Sum - A^[I]^[K] * A^[K]^[J]; + A^[I]^[J] := Sum; + end; + Imax := 0; + Pvt := 0.0; + for I := J to Ub do + begin + Sum := A^[I]^[J]; + for K := Lb to Pred(J) do + Sum := Sum - A^[I]^[K] * A^[K]^[J]; + A^[I]^[J] := Sum; + T := V^[I] * Abs(Sum); + if T > Pvt then + begin + Pvt := T; + Imax := I; + end; + end; + if J <> Imax then + begin + for K := Lb to Ub do + FSwap(A^[Imax]^[K], A^[J]^[K]); + V^[Imax] := V^[J]; + end; + Index^[J] := Imax; + if A^[J]^[J] = 0.0 then + A^[J]^[J] := MachEp; + if J <> Ub then + begin + T := 1.0 / A^[J]^[J]; + for I := Succ(J) to Ub do + A^[I]^[J] := A^[I]^[J] * T; + end; + end; + + DelVector(V, Ub); + SetErrCode(MatOk); + end; + +procedure LU_Solve(A : PMatrix; B : PVector; Lb, Ub : Integer; + X : PVector); + var + I, Ip, J, K : Integer; + Sum : Float; + begin + for I := Lb to Ub do + X^[I] := B^[I]; + + K := Pred(Lb); + for I := Lb to Ub do + begin + Ip := Index^[I]; + Sum := X^[Ip]; + X^[Ip] := X^[I]; + if K >= Lb then + for J := K to Pred(I) do + Sum := Sum - A^[I]^[J] * X^[J] + else if Sum <> 0.0 then + K := I; + X^[I] := Sum; + end; + + for I := Ub downto Lb do + begin + Sum := X^[I]; + if I < Ub then + for J := Succ(I) to Ub do + Sum := Sum - A^[I]^[J] * X^[J]; + X^[I] := Sum / A^[I]^[I]; + end; + end; + +end. \ No newline at end of file diff --git a/fpmath/umarq.pas b/fpmath/umarq.pas new file mode 100755 index 0000000..e970177 --- /dev/null +++ b/fpmath/umarq.pas @@ -0,0 +1,230 @@ +{ ****************************************************************** + Minimization of a function of several variables by Marquardt's + method + ****************************************************************** } + +unit umarq; + +interface + +uses + utypes, ugausjor, ulinmin, ucompvec; + +procedure SaveMarquardt(FileName : string); +{ ------------------------------------------------------------------ + Save Marquardt iterations in a file + ------------------------------------------------------------------ } + +procedure Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix; + var Det : Float); +{ ------------------------------------------------------------------ + Minimization of a function of several variables by Marquardt's + method + ------------------------------------------------------------------ + Input parameters : Func = objective function + HessGrad = procedure to compute hessian and gradient + X = initial minimum coordinates + Lb, Ub = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + G = gradient vector + H_inv = inverse hessian matrix + Det = determinant of hessian + ------------------------------------------------------------------ + Possible results : OptOk = no error + OptNonConv = non-convergence + OptSing = singular hessian matrix + OptBigLambda = too high Marquardt parameter Lambda + ---------------------------------------------------------------------- } + +implementation + +const + WriteLogFile : Boolean = False; + +var + LogFile : Text; + +procedure SaveMarquardt(FileName : string); + begin + Assign(LogFile, FileName); + Rewrite(LogFile); + WriteLogFile := True; + end; + +procedure Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix; + var Det : Float); + + const + Lambda0 = 1.0E-2; { Initial lambda value } + LambdaMax = 1.0E+3; { Highest lambda value } + FTol = 1.0E-10; { Tolerance on function decrease } + + var + Ub1, I, J, Iter : Integer; + F1, R : Float; + OldX, DeltaX : PVector; + A, H : PMatrix; + Lambda : Float; + LambdaOk : Boolean; + + procedure SolveSystem(Lambda : Float); + { Solve the system of linear equations : + + H' * DeltaX = -G + + where H' is the modified hessian matrix (diagonal terms + multiplied by (1 + Lambda)), and G is the gradient vector, + for a given value of Marquardt's Lambda parameter. + + The whole system is stored in a matrix A = [H'|G] + which is transformed by the Gauss-jordan method. + The inverse hessian matrix H_inv is then retrieved + from the transformed matrix. } + + var + Lambda1 : Float; + I, J : Integer; + begin + if Lambda > 0.0 then + begin + Lambda1 := 1.0 + Lambda; + for I := Lb to Ub do + A^[I]^[I] := Lambda1 * H^[I]^[I]; + end; + + GaussJordan(A, Lb, Ub, Ub1, Det); + + if MathErr = MatOk then + for I := Lb to Ub do + for J := Lb to Ub do + H_inv^[I]^[J] := A^[I]^[J]; + end; + + procedure Terminate(ErrCode : Integer); + { Set error code and deallocate arrays } + begin + DelVector(OldX, Ub); + DelVector(DeltaX, Ub); + DelMatrix(A, Ub, Ub1); + DelMatrix(H, Ub, Ub); + + SetErrCode(ErrCode); + + if WriteLogFile then + Close(LogFile); + end; + + begin + Ub1 := Ub + 1; + + DimVector(OldX, Ub); + DimVector(DeltaX, Ub); + DimMatrix(A, Ub, Ub1); + DimMatrix(H, Ub, Ub); + + if WriteLogFile then + begin + WriteLn(LogFile, 'Marquardt'); + WriteLn(LogFile, 'Iter F Lambda'); + end; + + Iter := 0; + Lambda := Lambda0; + F_min := Func(X); + + repeat + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12, ' ', Lambda:12); + + { Save old parameters } + for I := Lb to Ub do + OldX^[I] := X^[I]; + + { Compute Gradient and Hessian } + HessGrad(X, G, H); + for I := Lb to Ub do + begin + for J := Lb to Ub do + A^[I]^[J] := H^[I]^[J]; + A^[I]^[Ub1] := - G^[I]; + end; + + if MaxIter < 1 then + begin + SolveSystem(0.0); + if MathErr = MatOk then + Terminate(OptOk) + else + Terminate(OptSing); + Exit; + end; + + { Prepare next iteration } + Iter := Iter + 1; + if Iter > MaxIter then + begin + Terminate(OptNonConv); + Exit; + end; + + repeat + SolveSystem(Lambda); + + if MathErr <> MatOk then + begin + Terminate(OptSing); + Exit; + end; + + { Initialize parameters and search direction } + for I := Lb to Ub do + begin + X^[I] := OldX^[I]; + DeltaX^[I] := A^[I]^[Ub1]; + end; + + { Minimize along the direction specified by DeltaX } + { using an initial step of 0.1 * |DeltaX| } + R := 0.1; + LinMin(Func, X, DeltaX, Lb, Ub, R, 10, 0.01, F1); + + { Check that the function has decreased, otherwise } + { increase Lambda, without exceeding LambdaMax } + LambdaOk := (F1 - F_min) < F_min * FTol; + if not LambdaOk then Lambda := 10.0 * Lambda; + if Lambda > LambdaMax then + begin + Terminate(OptBigLambda); + Exit; + end; + until LambdaOk; + + Lambda := 0.1 * Lambda; + F_min := F1; + until CompVec(X, OldX, Lb, Ub, Tol); + + Terminate(OptOk); + end; + +end. + diff --git a/fpmath/umath.pas b/fpmath/umath.pas new file mode 100755 index 0000000..6e2bc68 --- /dev/null +++ b/fpmath/umath.pas @@ -0,0 +1,209 @@ +{ ****************************************************************** + Logarithms, exponentials and power + ****************************************************************** } + +unit umath; + +interface + +uses + utypes, uminmax; + +function Expo(X : Float) : Float; { Exponential } +function Exp2(X : Float) : Float; { 2^X } +function Exp10(X : Float) : Float; { 10^X } +function Log(X : Float) : Float; { Natural log } +function Log2(X : Float) : Float; { Log, base 2 } +function Log10(X : Float) : Float; { Decimal log } +function LogA(X, A : Float) : Float; { Log, base A } +function IntPower(X : Float; N : Integer) : Float; { X^N } +function Power(X, Y : Float) : Float; { X^Y, X >= 0 } + +implementation + + function Expo(X : Float) : Float; + begin + SetErrCode(FOk); + if X < MinLog then + Expo := DefaultVal(FUnderflow, 0.0) + else if X > MaxLog then + Expo := DefaultVal(FOverflow, MaxNum) + else + Expo := Exp(X); + end; + + function Exp2(X : Float) : Float; + var + XLn2 : Float; + begin + SetErrCode(FOk); + XLn2 := X * Ln2; + if XLn2 < MinLog then + Exp2 := DefaultVal(FUnderflow, 0.0) + else if XLn2 > MaxLog then + Exp2 := DefaultVal(FOverflow, MaxNum) + else + Exp2 := Exp(XLn2); + end; + + function Exp10(X : Float) : Float; + var + XLn10 : Float; + begin + SetErrCode(FOk); + XLn10 := X * Ln10; + if XLn10 < MinLog then + Exp10 := DefaultVal(FUnderflow, 0.0) + else if XLn10 > MaxLog then + Exp10 := DefaultVal(FOverflow, MaxNum) + else + Exp10 := Exp(XLn10); + end; + + function Log(X : Float) : Float; + begin + SetErrCode(FOk); + if X < 0.0 then + Log := DefaultVal(FDomain, - MaxNum) + else if X = 0.0 then + Log := DefaultVal(FSing, - MaxNum) + else + Log := Ln(X); + end; + + function Log10(X : Float) : Float; + begin + SetErrCode(FOk); + if X < 0.0 then + Log10 := DefaultVal(FDomain, - MaxNum) + else if X = 0.0 then + Log10 := DefaultVal(FSing, - MaxNum) + else + Log10 := Ln(X) * InvLn10; + end; + + function Log2(X : Float) : Float; + begin + SetErrCode(FOk); + if X < 0.0 then + Log2 := DefaultVal(FDomain, - MaxNum) + else if X = 0.0 then + Log2 := DefaultVal(FSing, - MaxNum) + else + Log2 := Ln(X) * InvLn2; + end; + + function LogA(X, A : Float) : Float; + var + Y : Float; + begin + Y := Log(X); + if MathErr = FOk then + if A = 1.0 then + Y := DefaultVal(FSing, Sgn(Y) * MaxNum) + else + Y := Y / Log(A); + LogA := Y; + end; + +{ ---------------------------------------------------------------------- + Power functions. + + Thanks to Volker Walter <vw@metrohm.ch> + for suggesting improvements to Power and IntPower + ---------------------------------------------------------------------- } + + function PowerTests(X, Y : Float; var Res : Float) : Boolean; + { Tests the cases X=0, Y=0 and Y=1. Returns X^Y in Res } + begin + if X = 0.0 then + begin + PowerTests := True; + if Y = 0.0 then { 0^0 = lim X^X = 1 } + Res := 1.0 { X->0 } + else if Y > 0.0 then + Res := 0.0 { 0^Y = 0 } + else + Res := DefaultVal(FSing, MaxNum); + end + else if Y = 0.0 then + begin + Res := 1.0; { X^0 = 1 } + PowerTests := True; + end + else if Y = 1.0 then + begin + Res := X; { X^1 = X } + PowerTests := True; + end + else + PowerTests := False; + end; + + function IntPower(X : Float; N : Integer) : Float; + { Computes X^N by repeated multiplications } + const + InverseMaxNum = 1.0 / MaxNum; + var + T : Float; + M : Integer; + Invert : Boolean; + begin + if PowerTests(X, N, T) then + begin + IntPower := T; + Exit; + end; + + Invert := (N < 0); { Test if inverting is needed } + if 1.0 < Abs(X) then { Test for 0 ..|x| .. 1 } + begin + X := 1.0 / X; + Invert := not Invert; + end; + + { Legendre's algorithm for + minimizing the number of multiplications } + T := 1.0; M := Abs(N); + while 0 < M do + begin + if Odd(M) then T := T * X; + X := Sqr(X); + M := M div 2; + end; + + if Invert then + if Abs(T) < InverseMaxNum then { Only here overflow } + T := DefaultVal(FOverflow, Sgn(T) * MaxNum) + else + T := 1.0 / T; + + IntPower := T; + end; + + function Power(X, Y : Float) : Float; + { Computes X^Y = Exp(Y * Ln(X)), for X > 0 + Resorts to IntPower if Y is integer } + var + Res : Float; + YLnX : Float; + begin + if PowerTests(X, Y, Res) then + Power := Res + else if (Abs(Y) < MaxInt) and (Trunc(Y) = Y) then { Integer exponent } + Power := IntPower(X, Trunc(Y)) + else if X <= 0.0 then + Power := DefaultVal(FDomain, 0.0) + else + begin + YLnX := Y * Ln(X); + if YLnX < MinLog then + Power := DefaultVal(FUnderflow, 0.0) + else if YLnX > MaxLog then + Power := DefaultVal(FOverflow, MaxNum) + else + Power := Exp(YLnX); + end; + end; + +end. \ No newline at end of file diff --git a/fpmath/umcmc.pas b/fpmath/umcmc.pas new file mode 100755 index 0000000..f5fb739 --- /dev/null +++ b/fpmath/umcmc.pas @@ -0,0 +1,279 @@ +{ ****************************************************************** + Simulation by Markov Chain Monte Carlo (MCMC) with the + Metropolis-Hastings algorithm. + + This algorithm simulates the probability density function (pdf) of + a vector X. The pdf P(X) is written as: + + P(X) = C * Exp(- F(X) / T) + + Simulating P by the Metropolis-Hastings algorithm is equivalent to + minimizing F by simulated annealing at the constant temperature T. + The constant C is not used in the simulation. + + The series of random vectors generated during the annealing step + constitutes a Markov chain which tends towards the pdf to be + simulated. + + It is possible to run several cycles of the algorithm. + The variance-covariance matrix of the simulated distribution is + re-evaluated at the end of each cycle and used for the next cycle. + ****************************************************************** } + +unit umcmc; + +interface + +uses + utypes, ucholesk, urandom, uranmult; + +procedure InitMHParams(NCycles, MaxSim, SavedSim : Integer); +{ ------------------------------------------------------------------ + Initializes Metropolis-Hastings parameters + ------------------------------------------------------------------ } + +procedure GetMHParams(var NCycles, MaxSim, SavedSim : Integer); +{ ------------------------------------------------------------------ + Returns Metropolis-Hastings parameters + ------------------------------------------------------------------ } + +procedure Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lb, Ub : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float); +{ ------------------------------------------------------------------ + Simulation of a probability density function by the + Metropolis-Hastings algorithm + ------------------------------------------------------------------ + Input parameters : Func = Function such that the pdf is + P(X) = C * Exp(- Func(X) / T) + T = Temperature + X = Initial mean vector + V = Initial variance-covariance matrix + Lb, Ub = Indices of first and last variables + ------------------------------------------------------------------ + Output parameters : Xmat = Matrix of simulated vectors, stored + row-wise, i.e. + Xmat[1..MH_SavedSim, Lb..Ub] + X = Mean of distribution + V = Variance-covariance matrix of distribution + X_min = Coordinates of minimum of F(X) + (mode of the distribution) + F_min = Value of F(X) at minimum + ------------------------------------------------------------------ + Possible results : MatOk : No error + MatNotPD : The variance-covariance matrix + is not positive definite + ------------------------------------------------------------------ } + +implementation + +const + MH_NCycles : Integer = 10; { Number of cycles } + MH_MaxSim : Integer = 1000; { Max nb of simulations at each cycle } + MH_SavedSim : Integer = 1000; { Nb of simulations to be saved } + + procedure InitMHParams(NCycles, MaxSim, SavedSim : Integer); + begin + if NCycles > 0 then MH_NCycles := NCycles; + if MaxSim > 0 then MH_MaxSim := MaxSim; + if (SavedSim > 0) and (SavedSim <= MaxSim) then + MH_SavedSim := SavedSim; + end; + + procedure GetMHParams(var NCycles, MaxSim, SavedSim : Integer); + begin + NCycles := MH_NCycles; + MaxSim := MH_MaxSim; + SavedSim := MH_SavedSim; + end; + + procedure CalcSD(V : PMatrix; + S : PVector; + Lb, Ub : Integer); +{ ------------------------------------------------------------------ + Computes the standard deviations for independent random numbers + from the variance-covariance matrix. + ------------------------------------------------------------------ } + var + I, ErrCode : Integer; + begin + I := Lb; + ErrCode := MatOk; + repeat + if V^[I]^[I] > 0.0 then + S^[I] := Sqrt(V^[I]^[I]) + else + ErrCode := MatNotPD; + Inc(I); + until (ErrCode <> MatOk) or (I > Ub); + SetErrCode(ErrCode); + end; + + function Accept(DeltaF, T : Float) : Boolean; +{ ------------------------------------------------------------------ + Checks if a variation DeltaF of the function at temperature T is + acceptable. + ------------------------------------------------------------------ } + var + X : Float; + begin + if DeltaF < 0.0 then + begin + Accept := True; + Exit; + end; + + X := DeltaF / T; + + if X >= MaxLog then { Exp(- X) ~ 0 } + Accept := False + else + Accept := (Exp(- X) > RanGen3); + end; + + procedure HastingsCycle(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lb, Ub : Integer; + Indep : Boolean; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float); +{ ------------------------------------------------------------------ + Performs one cycle of the Metropolis-Hastings algorithm + ------------------------------------------------------------------ } + var + F, F1 : Float; { Function values } + DeltaF : Float; { Variation of function } + Sum : Float; { Statistical sum } + X1 : PVector; { New coordinates } + L : PMatrix; { Standard dev. or Cholesky factor } + S : PVector; { Standard deviations } + I, J, K : Integer; { Loop variables } + Iter : Integer; { Iteration count } + FirstSavedSim : Integer; { Index of first simulation to be saved } + begin + { Dimension arrays } + DimVector(S, Ub); + DimVector(X1, Ub); + DimMatrix(L, Ub, Ub); + + { Compute SD's or Cholesky factor } + if Indep then + CalcSD(V, S, Lb, Ub) + else + Cholesky(V, L, Lb, Ub); + + if MathErr = MatNotPD then Exit; + + { Compute initial function value } + F := Func(X); + + { Perform MH_MaxSim simulations at constant temperature } + FirstSavedSim := MH_MaxSim - MH_SavedSim + 1; + Iter := 1; + K := 1; + + repeat + { Generate new vector } + if Indep then + RanMultIndep(X, S, Lb, Ub, X1) + else + RanMult(X, L, Lb, Ub, X1); + + { Compute new function value } + F1 := Func(X1); + DeltaF := F1 - F; + + { Check for acceptance } + if Accept(DeltaF, T) then + begin + Write('.'); { Only for command-line programs } + + for I := Lb to Ub do + X^[I] := X1^[I]; + + if Iter >= FirstSavedSim then + begin + { Save simulated vector into line K of matrix Xmat } + for I := Lb to Ub do + Xmat^[K]^[I] := X1^[I]; + Inc(K); + end; + + if F1 < F_min then + begin + { Update minimum } + for I := Lb to Ub do + X_min^[I] := X1^[I]; + F_min := F1; + end; + + F := F1; + Inc(Iter); + end; + until Iter > MH_MaxSim; + + { Update mean vector } + for I := Lb to Ub do + begin + Sum := 0.0; + for K := 1 to MH_SavedSim do + Sum := Sum + Xmat^[K]^[I]; + X^[I] := Sum / MH_SavedSim; + end; + + { Update variance-covariance matrix } + for I := Lb to Ub do + for J := I to Ub do + begin + Sum := 0.0; + for K := 1 to MH_SavedSim do + Sum := Sum + (Xmat^[K]^[I] - X^[I]) * (Xmat^[K]^[J] - X^[J]); + V^[I]^[J] := Sum / MH_SavedSim; + end; + + for I := Succ(Lb) to Ub do + for J := Lb to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + + DelVector(S, Ub); + DelVector(X1, Ub); + DelMatrix(L, Ub, Ub); + end; + + procedure Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lb, Ub : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float); + var + K : Integer; + Indep : Boolean; + begin + { Initialize the Marsaglia random number generator + using the standard Pascal generator } + Randomize; + InitGen(Trunc(Random * 1.0E+8)); + + K := 1; + Indep := True; + F_min := MaxNum; + + repeat + HastingsCycle(Func, T, X, V, Lb, Ub, Indep, Xmat, X_min, F_min); + Indep := False; + Inc(K); + until (MathErr <> MatOk) or (K > MH_NCycles); + end; + +end. \ No newline at end of file diff --git a/fpmath/umeansd.o b/fpmath/umeansd.o new file mode 100644 index 0000000..77c742c Binary files /dev/null and b/fpmath/umeansd.o differ diff --git a/fpmath/umeansd.pas b/fpmath/umeansd.pas new file mode 100755 index 0000000..a196420 --- /dev/null +++ b/fpmath/umeansd.pas @@ -0,0 +1,78 @@ +{ ****************************************************************** + Mean and standard deviations + ****************************************************************** } + +unit umeansd; + +interface + +uses + utypes; + +function Mean(X : PVector; Lb, Ub : Integer) : Float; +{ Mean of sample X } + +function StDev(X : PVector; Lb, Ub : Integer; M : Float) : Float; +{ Standard deviation estimated from sample X } + +function StDevP(X : PVector; Lb, Ub : Integer; M : Float) : Float; +{ Standard deviation of population } + +implementation + +function Mean(X : PVector; Lb, Ub : Integer) : Float; +var + SX : Float; + I : Integer; +begin + SX := 0.0; + + for I := Lb to Ub do + SX := SX + X^[I]; + + Mean := SX / (Ub - Lb + 1); +end; + +function StDev(X : PVector; Lb, Ub : Integer; M : Float) : Float; +var + D, SD, SD2, V : Float; + I, N : Integer; +begin + N := Ub - Lb + 1; + + SD := 0.0; { Sum of deviations (used to reduce roundoff error) } + SD2 := 0.0; { Sum of squared deviations } + + for I := Lb to Ub do + begin + D := X^[I] - M; + SD := SD + D; + SD2 := SD2 + Sqr(D) + end; + + V := (SD2 - Sqr(SD) / N) / (N - 1); { Variance } + StDev := Sqrt(V); +end; + +function StDevP(X : PVector; Lb, Ub : Integer; M : Float) : Float; +var + D, SD, SD2, V : Float; + I, N : Integer; +begin + N := Ub - Lb + 1; + + SD := 0.0; { Sum of deviations (used to reduce roundoff error) } + SD2 := 0.0; { Sum of squared deviations } + + for I := Lb to Ub do + begin + D := X^[I] - M; + SD := SD + D; + SD2 := SD2 + Sqr(D) + end; + + V := (SD2 - Sqr(SD) / N) / N; { Variance } + StDevP := Sqrt(V); +end; + +end. diff --git a/fpmath/umeansd.ppu b/fpmath/umeansd.ppu new file mode 100644 index 0000000..2b3d9f9 Binary files /dev/null and b/fpmath/umeansd.ppu differ diff --git a/fpmath/umedian.pas b/fpmath/umedian.pas new file mode 100755 index 0000000..982c03b --- /dev/null +++ b/fpmath/umedian.pas @@ -0,0 +1,37 @@ +{ ****************************************************************** + Median + ****************************************************************** } + +unit umedian; + +interface + +uses + utypes, uqsort; + +function Median(X : PVector; Lb, Ub : Integer; Sorted : Boolean) : Float; +{ ------------------------------------------------------------------ + Sorts vector X in ascending order (if it's not sorted already) + and returns its median value + ------------------------------------------------------------------ } + +implementation + +function Median(X : PVector; Lb, Ub : Integer; Sorted : Boolean) : Float; + var + N, N2 : Integer; + begin + N := Ub - Lb + 1; + N2 := N div 2 + Lb - 1; + + if not Sorted then + QSort(X, Lb, Ub); + + if Odd(N) then + Median := X^[N2 + 1] + else + Median := 0.5 * (X^[N2] + X^[N2 + 1]); + end; + +end. + diff --git a/fpmath/uminbrak.pas b/fpmath/uminbrak.pas new file mode 100755 index 0000000..4b1762a --- /dev/null +++ b/fpmath/uminbrak.pas @@ -0,0 +1,61 @@ +{ ****************************************************************** + Brackets a minimum of a function + ****************************************************************** } + +unit uminbrak; + +interface + +uses + utypes, uminmax; + +procedure MinBrack(Func : TFunc; var A, B, C, Fa, Fb, Fc : Float); + +implementation + +procedure MinBrack(Func : TFunc; var A, B, C, Fa, Fb, Fc : Float); +{ ------------------------------------------------------------------ + Given two points (A, B) this procedure finds a triplet (A, B, C) + such that: + + 1) A < B < C + 2) A, B, C are within the golden ratio + 3) Func(B) < Func(A) and Func(B) < Func(C). + + The corresponding function values are returned in Fa, Fb, Fc + ------------------------------------------------------------------ } + + begin + if A > B then + FSwap(A, B); + + Fa := Func(A); + Fb := Func(B); + + if Fb > Fa then + begin + FSwap(A, B); + FSwap(Fa, Fb); + end; + + C := B + GOLD * (B - A); + Fc := Func(C); + + while Fc < Fb do + begin + A := B; + B := C; + Fa := Fb; + Fb := Fc; + C := B + GOLD * (B - A); + Fc := Func(C); + end; + + if A > C then + begin + FSwap(A, C); + FSwap(Fa, Fc); + end; + end; + +end. diff --git a/fpmath/uminmax.o b/fpmath/uminmax.o new file mode 100644 index 0000000..9c9b193 Binary files /dev/null and b/fpmath/uminmax.o differ diff --git a/fpmath/uminmax.pas b/fpmath/uminmax.pas new file mode 100755 index 0000000..a4d3c2d --- /dev/null +++ b/fpmath/uminmax.pas @@ -0,0 +1,98 @@ +{ ****************************************************************** + Minimum, maximum, sign and exchange + ****************************************************************** } + +unit uminmax; + +interface + +uses + utypes; + +function FMin(X, Y : Float) : Float; { Minimum of 2 reals } +function FMax(X, Y : Float) : Float; { Maximum of 2 reals } +function IMin(X, Y : Integer) : Integer; { Minimum of 2 integers } +function IMax(X, Y : Integer) : Integer; { Maximum of 2 integers } +function Sgn(X : Float) : Integer; { Sign (returns 1 if X = 0) } +function Sgn0(X : Float) : Integer; { Sign (returns 0 if X = 0) } +function DSgn(A, B : Float) : Float; { Sgn(B) * |A| } + +procedure FSwap(var X, Y : Float); { Exchange 2 reals } +procedure ISwap(var X, Y : Integer); { Exchange 2 integers } + +implementation + + function FMin(X, Y : Float) : Float; + begin + if X <= Y then + FMin := X + else + FMin := Y; + end; + + function FMax(X, Y : Float) : Float; + begin + if X >= Y then + FMax := X + else + FMax := Y; + end; + + function IMin(X, Y : Integer) : Integer; + begin + if X <= Y then + IMin := X + else + IMin := Y; + end; + + function IMax(X, Y : Integer) : Integer; + begin + if X >= Y then + IMax := X + else + IMax := Y; + end; + + function Sgn(X : Float) : Integer; + begin + if X >= 0.0 then + Sgn := 1 + else + Sgn := - 1; + end; + + function Sgn0(X : Float) : Integer; + begin + if X > 0.0 then + Sgn0 := 1 + else if X = 0.0 then + Sgn0 := 0 + else + Sgn0 := - 1; + end; + + function DSgn(A, B : Float) : Float; + begin + if B < 0.0 then DSgn := - Abs(A) else DSgn := Abs(A) + end; + + procedure FSwap(var X, Y : Float); + var + Temp : Float; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + procedure ISwap(var X, Y : Integer); + var + Temp : Integer; + begin + Temp := X; + X := Y; + Y := Temp; + end; + +end. diff --git a/fpmath/uminmax.ppu b/fpmath/uminmax.ppu new file mode 100644 index 0000000..5bd9c68 Binary files /dev/null and b/fpmath/uminmax.ppu differ diff --git a/fpmath/umulfit.o b/fpmath/umulfit.o new file mode 100644 index 0000000..c1d8def Binary files /dev/null and b/fpmath/umulfit.o differ diff --git a/fpmath/umulfit.pas b/fpmath/umulfit.pas new file mode 100755 index 0000000..ac4e669 --- /dev/null +++ b/fpmath/umulfit.pas @@ -0,0 +1,183 @@ +{ ****************************************************************** + Multiple linear regression (Gauss-Jordan method) + ****************************************************************** } + +unit umulfit; + +interface + +uses + utypes, ulineq; + + +procedure MulFit(X : PMatrix; + Y : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + B : PVector; + V : PMatrix); +{ ------------------------------------------------------------------ + Multiple linear regression: Y = B(0) + B(1) * X + B(2) * X2 + ... + ------------------------------------------------------------------ + Input parameters: X = matrix of independent variables + Y = vector of dependent variable + Lb, Ub = array bounds + Nvar = number of independent variables + ConsTerm = presence of constant term B(0) + Output parameters: B = regression parameters + V = inverse matrix + ------------------------------------------------------------------ } + +procedure WMulFit(X : PMatrix; + Y, S : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + B : PVector; + V : PMatrix); +{ ---------------------------------------------------------------------- + Weighted multiple linear regression + ---------------------------------------------------------------------- + S = standard deviations of observations + Other parameters as in MulFit + ---------------------------------------------------------------------- } + +implementation + +procedure MulFit(X : PMatrix; + Y : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + B : PVector; + V : PMatrix); + + var + Lb1 : Integer; { Index of first param. (0 if cst term, 1 otherwise) } + I, J, K : Integer; { Loop variables } + Det : Float; { Determinant } + + begin + if Ub - Lb < Nvar then + begin + SetErrCode(MatErrDim); + Exit; + end; + + { Initialize } + for I := 0 to Nvar do + begin + for J := 0 to Nvar do + V^[I]^[J] := 0.0; + B^[I] := 0.0; + end; + + { If constant term, set line 0 and column 0 of matrix V } + if ConsTerm then + begin + V^[0]^[0] := Int(Ub - Lb + 1); + for K := Lb to Ub do + begin + for J := 1 to Nvar do + V^[0]^[J] := V^[0]^[J] + X^[K]^[J]; + B^[0] := B^[0] + Y^[K]; + end; + for J := 1 to Nvar do + V^[J]^[0] := V^[0]^[J]; + end; + + { Set other elements of V } + for K := Lb to Ub do + for I := 1 to Nvar do + begin + for J := I to Nvar do + V^[I]^[J] := V^[I]^[J] + X^[K]^[I] * X^[K]^[J]; + B^[I] := B^[I] + X^[K]^[I] * Y^[K]; + end; + + { Fill in symmetric matrix } + for I := 2 to Nvar do + for J := 1 to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + + { Solve normal equations } + if ConsTerm then Lb1 := 0 else Lb1 := 1; + LinEq(V, B, Lb1, Nvar, Det); + end; + +procedure WMulFit(X : PMatrix; + Y, S : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + B : PVector; + V : PMatrix); + + var + Lb1 : Integer; { Index of first param. (0 if cst term, 1 otherwise) } + I, J, K : Integer; { Loop variables } + W : PVector; { Vector of weights } + WX : Float; { W * X } + Det : Float; { Determinant } + + begin + if Ub - Lb < Nvar then + begin + SetErrCode(MatErrDim); + Exit; + end; + + for K := Lb to Ub do + if S^[K] <= 0.0 then + begin + SetErrCode(MatSing); + Exit; + end; + + DimVector(W, Ub); + + for K := Lb to Ub do + W^[K] := 1.0 / Sqr(S^[K]); + + { Initialize } + for I := 0 to Nvar do + begin + for J := 0 to Nvar do + V^[I]^[J] := 0.0; + B^[I] := 0.0; + end; + + { If constant term, set line 0 and column 0 of matrix V } + if ConsTerm then + begin + for K := Lb to Ub do + begin + V^[0]^[0] := V^[0]^[0] + W^[K]; + for J := 1 to Nvar do + V^[0]^[J] := V^[0]^[J] + W^[K] * X^[K]^[J]; + B^[0] := B^[0] + W^[K] * Y^[K]; + end; + for J := 1 to Nvar do + V^[J]^[0] := V^[0]^[J]; + end; + + { Set other elements of V } + for K := Lb to Ub do + for I := 1 to Nvar do + begin + WX := W^[K] * X^[K]^[I]; + for J := I to Nvar do + V^[I]^[J] := V^[I]^[J] + WX * X^[K]^[J]; + B^[I] := B^[I] + WX * Y^[K]; + end; + + { Fill in symmetric matrix } + for I := 2 to Nvar do + for J := 1 to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + + { Solve normal equations } + if ConsTerm then Lb1 := 0 else Lb1 := 1; + LinEq(V, B, Lb1, Nvar, Det); + + DelVector(W, Ub); + end; + +end. \ No newline at end of file diff --git a/fpmath/umulfit.ppu b/fpmath/umulfit.ppu new file mode 100644 index 0000000..598f94e Binary files /dev/null and b/fpmath/umulfit.ppu differ diff --git a/fpmath/unewteq.pas b/fpmath/unewteq.pas new file mode 100755 index 0000000..060e0ae --- /dev/null +++ b/fpmath/unewteq.pas @@ -0,0 +1,84 @@ +{ ****************************************************************** + Newton-Raphson solver for nonlinear equation + ****************************************************************** } + +unit unewteq; + +interface + +uses + utypes; + +procedure NewtEq (Func, Deriv : TFunc; + var X : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); +{ ------------------------------------------------------------------ + Solves a nonlinear equation by Newton's method + ------------------------------------------------------------------ + Input parameters : Func = function to be solved + Deriv = derivative + X = initial root + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : X = refined root + F = function value + ------------------------------------------------------------------ + Possible results : OptOk = no error + OptNonConv = non-convergence + OptSing = singularity (null derivative) + ------------------------------------------------------------------ } + +implementation + +procedure NewtEq (Func, Deriv : TFunc; + var X : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); + +var + Iter : Integer; { Iteration count } + OldX : Float; { Old root } + D : Float; { Derivative } + Xtol : Float; { Tolerance } + +begin + Iter := 0; + SetErrCode(OptOk); + + F := Func(X); + + if MaxIter < 1 then Exit; + + repeat + { Compute derivative } + D := Deriv(X); + + if D = 0.0 then + begin + SetErrCode(OptSing); + Exit; + end; + + { Prepare next iteration } + Iter := Iter + 1; + if Iter > MaxIter then + begin + SetErrCode(OptNonConv); + Exit; + end; + + { Save current root and compute new one } + OldX := X; + X := X - F / D; + F := Func(X); + + Xtol := Tol * Abs(X); + if Xtol < MachEp then Xtol := MachEp; + until Abs(OldX - X) < Xtol; +end; + +end. \ No newline at end of file diff --git a/fpmath/unewteqs.pas b/fpmath/unewteqs.pas new file mode 100755 index 0000000..a9e81fb --- /dev/null +++ b/fpmath/unewteqs.pas @@ -0,0 +1,120 @@ +{ ****************************************************************** + Newton-Raphson solver for system of nonlinear equations + ****************************************************************** } + +unit unewteqs; + +interface + +uses + utypes, ulineq, ulinminq, ucompvec; + +procedure NewtEqs(Equations : TEquations; + Jacobian : TJacobian; + X, F : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float); +{ ------------------------------------------------------------------ + Solves a system of nonlinear equations by Newton's method + ------------------------------------------------------------------ + Input parameters : Equations = subroutine to compute equations + Jacobian = subroutine to compute Jacobian + X = initial root + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : X = refined root + F = function values + ------------------------------------------------------------------ + Possible results : OptOk = no error + OptNonConv = non-convergence + OptSing = singular jacobian matrix + ------------------------------------------------------------------ } + +implementation + +procedure NewtEqs(Equations : TEquations; + Jacobian : TJacobian; + X, F : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float); + +var + I : Integer; { Loop variables } + R : Float; { Step for line minimization } + Det : Float; { Determinant of Jacobian } + Iter : Integer; { Iteration count } + Conv : Boolean; { Test convergence } + OldX : PVector; { Old parameters } + DeltaX : PVector; { New search direction } + D : PMatrix; { Jacobian matrix } + + procedure Terminate(ErrCode : Integer); + { Set error code and deallocate arrays } + begin + DelVector(OldX, Ub); + DelVector(DeltaX, Ub); + DelMatrix(D, Ub, Ub); + SetErrCode(ErrCode); + end; + +begin + { Initialize function vector } + Equations(X, F); + + { Quit if no iteration required } + if MaxIter < 1 then + begin + SetErrCode(OptOk); + Exit; + end; + + { Dimension arrays } + DimVector(OldX, Ub); + DimVector(DeltaX, Ub); + DimMatrix(D, Ub, Ub); + + Iter := 0; + + repeat + { Compute Jacobian } + Jacobian(X, D); + + { Solve linear system } + LinEq(D, F, Lb, Ub, Det); + if MathErr <> MatOk then + begin + Terminate(OptSing); + Exit; + end; + + { Prepare next iteration } + Iter := Iter + 1; + if Iter > MaxIter then + begin + Terminate(OptNonConv); + Exit; + end; + + { Save current parameters and initialize the direction search } + for I := Lb to Ub do + begin + OldX^[I] := X^[I]; + DeltaX^[I] := - F^[I]; + end; + + { Minimize in the direction specified by DeltaX, + using an initial step of 0.1 } + R := 0.1; + LinMinEq(Equations, X, DeltaX, F, Lb, Ub, R, 10, 0.01); + + { Test for convergence } + Conv := CompVec(X, OldX, Lb, Ub, Tol); + until Conv; + + Terminate(OptOk); +end; + +end. \ No newline at end of file diff --git a/fpmath/unewton.pas b/fpmath/unewton.pas new file mode 100755 index 0000000..a7e5e5c --- /dev/null +++ b/fpmath/unewton.pas @@ -0,0 +1,179 @@ +{ ****************************************************************** + Minimization of a function of several variables by the + Newton-Raphson method + ****************************************************************** } + +unit unewton; + +interface + +uses + utypes, ulineq, ulinmin, ucompvec; + +procedure SaveNewton(FileName : string); +{ ------------------------------------------------------------------ + Save Newton-Raphson iterations in a file + ------------------------------------------------------------------ } + +procedure Newton(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix; + var Det : Float); +{ ------------------------------------------------------------------ + Minimization of a function of several variables by the + Newton-Raphson method + ------------------------------------------------------------------ + Input parameters : Func = objective function + Gradient = procedure to compute gradient + X = initial minimum coordinates + Lb, Ub = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + G = gradient vector + H_inv = inverse hessian matrix + Det = determinant of hessian + ------------------------------------------------------------------ + Possible results : OptOk = no error + OptNonConv = non-convergence + OptSing = singular hessian matrix + ---------------------------------------------------------------------- } + +implementation + +const + WriteLogFile : Boolean = False; + +var + LogFile : Text; + +procedure SaveNewton(FileName : string); + begin + Assign(LogFile, FileName); + Rewrite(LogFile); + WriteLogFile := True; + end; + +procedure Newton(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + G : PVector; + H_inv : PMatrix; + var Det : Float); + + var + I, Iter : Integer; + R : Float; + OldX, DeltaX : PVector; + + procedure Init; + { Initializes variables } + var + I : Integer; + begin + { Initialize function } + F_min := Func(X); + + { Initialize gradient and hessian (stored in H_inv) } + HessGrad(X, G, H_inv); + + { Initialize search direction } + for I := Lb to Ub do + DeltaX^[I] := - G^[I]; + + { Solve system } + LinEq(H_inv, DeltaX, Lb, Ub, Det); + end; + + procedure Terminate(ErrCode : Integer); + { Set error code and deallocate arrays } + begin + DelVector(OldX, Ub); + DelVector(DeltaX, Ub); + + SetErrCode(ErrCode); + + if WriteLogFile then + Close(LogFile); + end; + + begin + DimVector(OldX, Ub); + DimVector(DeltaX, Ub); + + Init; + + if MathErr <> MatOk then + begin + Terminate(OptSing); + Exit; + end; + + if MaxIter < 1 then + begin + Terminate(OptOk); + Exit; + end; + + if WriteLogFile then + begin + WriteLn(LogFile, 'Newton-Raphson'); + WriteLn(LogFile, 'Iter F'); + end; + + Iter := 0; + + repeat + { Prepare next iteration } + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12); + + Iter := Iter + 1; + if Iter > MaxIter then + begin + Terminate(OptNonConv); + Exit; + end; + + { Save old parameters } + for I := Lb to Ub do + OldX^[I] := X^[I]; + + { Minimize along the direction specified by DeltaX } + R := 0.1; + LinMin(Func, X, DeltaX, Lb, Ub, R, 10, 0.01, F_min); + + { Compute new gradient and hessian } + HessGrad(X, G, H_inv); + + { Initialize search direction } + for I := Lb to Ub do + DeltaX^[I] := - G^[I]; + + { Solve system } + LinEq(H_inv, DeltaX, Lb, Ub, Det); + + if MathErr <> MatOk then + begin + Terminate(OptSing); + Exit; + end; + until CompVec(X, OldX, Lb, Ub, Tol); + + Terminate(OptOk); + end; + +end. + diff --git a/fpmath/unlfit.pas b/fpmath/unlfit.pas new file mode 100755 index 0000000..1668f47 --- /dev/null +++ b/fpmath/unlfit.pas @@ -0,0 +1,616 @@ +{ ****************************************************************** + Nonlinear regression + ****************************************************************** } + +unit unlfit; + +interface + +uses + utypes, ugausjor, umarq, ubfgs, usimplex, + usimann, ugenalg, umcmc, ustrings; + +procedure SetOptAlgo(Algo : TOptAlgo); +{ ---------------------------------------------------------------------- + Sets the optimization algorithm according to Algo, which must be + NL_MARQ, NL_SIMP, NL_BFGS, NL_SA, NL_GA. Default is NL_MARQ + ---------------------------------------------------------------------- } + +procedure SetMaxParam(N : Byte); +{ ---------------------------------------------------------------------- + Sets the maximum number of regression parameters + ---------------------------------------------------------------------- } + +procedure SetParamBounds(I : Byte; ParamMin, ParamMax : Float); +{ ---------------------------------------------------------------------- + Sets the bounds on the I-th regression parameter + ---------------------------------------------------------------------- } + +procedure NLFit(RegFunc : TRegFunc; + DerivProc : TDerivProc; + X, Y : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); +{ ------------------------------------------------------------------ + Unweighted nonlinear regression + ------------------------------------------------------------------ + Input parameters: RegFunc = regression function + DerivProc = procedure to compute derivatives + X, Y = point coordinates + Lb, Ub = array bounds + MaxIter = max. number of iterations + Tol = tolerance on parameters + B = initial parameter values + FirstPar = index of first regression parameter + LasttPar = index of last regression parameter + Output parameters: B = fitted regression parameters + V = inverse matrix + ------------------------------------------------------------------ } + +procedure WNLFit(RegFunc : TRegFunc; + DerivProc : TDerivProc; + X, Y, S : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); +{ ---------------------------------------------------------------------- + Weighted nonlinear regression + ---------------------------------------------------------------------- + S = standard deviations of observations + Other parameters as in NLFit + ---------------------------------------------------------------------- } + +procedure SetMCFile(FileName : String); +{ ---------------------------------------------------------------------- + Set file for saving MCMC simulations + ---------------------------------------------------------------------- } + +procedure SimFit(RegFunc : TRegFunc; + X, Y : PVector; + Lb, Ub : Integer; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); +{ ------------------------------------------------------------------ + Simulation of unweighted nonlinear regression by MCMC + ------------------------------------------------------------------ } + +procedure WSimFit(RegFunc : TRegFunc; + X, Y, S : PVector; + Lb, Ub : Integer; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); +{ ---------------------------------------------------------------------- + Simulation of weighted nonlinear regression by MCMC + ------------------------------------------------------------------ } + + +implementation + +type + TRegMode = (UNWEIGHTED, WEIGHTED); + +const + MAX_BOUND = 1.0E+6; { Default parameter bound } + MAX_FUNC = 1.0E+30; { Max. value for objective function + (used to prevent overflow) } +const + MaxParam : Byte = 10; { Max. index of fitted parameter } + OptAlgo : TOptAlgo = NL_MARQ; { Optimization algorithm } + MCFile : String = 'mcmc.txt'; { File for saving MCMC simulations } + +{ Global variables used by the nonlinear regression routines } +const + gLb : Integer = 0; { Index of first point } + gUb : Integer = 0; { Index of last point } + gX : PVector = nil; { X coordinates } + gY : PVector = nil; { Y coordinates } + gW : PVector = nil; { Weights } + gYcalc : PVector = nil; { Estimated Y values } + gR : PVector = nil; { Residuals (Y - Ycalc) } + gFirstPar : Integer = 0; { Index of first fitted parameter } + gLastPar : Integer = 0; { Index of last fitted parameter } + gBmin : PVector = nil; { Lower bounds on parameters } + gBmax : PVector = nil; { Higher bounds on parameters } + gD : PVector = nil; { Derivatives of regression function } + +var + gRegFunc : TRegFunc; { Regression function } + gDerivProc : TDerivProc; { Derivation procedure } + + procedure SetOptAlgo(Algo : TOptAlgo); + begin + OptAlgo := Algo; + end; + + procedure SetMaxParam(N : Byte); + begin + if N < 1 then Exit; + + DelVector(gBmin, MaxParam); + DelVector(gBmax, MaxParam); + + DimVector(gBmin, N); + DimVector(gBmax, N); + + MaxParam := N; + end; + + procedure SetParamBounds(I : Byte; ParamMin, ParamMax : Float); + begin + if gBmin = nil then + DimVector(gBmin, MaxParam); + + if gBmax = nil then + DimVector(gBmax, MaxParam); + + if (I < 0) or (I > MaxParam) or (ParamMin >= ParamMax) then Exit; + + gBmin^[I] := ParamMin; + gBmax^[I] := ParamMax; + end; + + procedure SetGlobalVar(Mode : TRegMode; + RegFunc : TRegFunc; + DerivProc : TDerivProc; + X, Y, S : PVector; + Lb, Ub : Integer; + FirstPar, + LastPar : Integer); + + { Checks the data and sets the global variables } + + var + I, Npar, Npts : Integer; + + begin + if LastPar > MaxParam then + begin + SetErrCode(NLMaxPar); + Exit; + end; + + Npts := Ub - Lb + 1; { Number of points } + Npar := LastPar - FirstPar + 1; { Number of parameters } + + if Npts <= Npar then + begin + SetErrCode(MatErrDim); + Exit; + end; + + if Mode = WEIGHTED then + for I := Lb to Ub do + if S^[I] <= 0.0 then + begin + SetErrCode(MatSing); + Exit; + end; + + DelVector(gX, gUb); + DelVector(gY, gUb); + DelVector(gW, gUb); + DelVector(gYcalc, gUb); + DelVector(gR, gUb); + + DimVector(gX, Ub); + DimVector(gY, Ub); + DimVector(gW, Ub); + DimVector(gYcalc, Ub); + DimVector(gR, Ub); + + for I := Lb to Ub do + begin + gX^[I] := X^[I]; + gY^[I] := Y^[I]; + end; + + if Mode = WEIGHTED then + for I := Lb to Ub do + gW^[I] := 1.0 / Sqr(S^[I]); + + if gBmin = nil then + DimVector(gBmin, MaxParam); + + if gBmax = nil then + DimVector(gBmax, MaxParam); + + for I := FirstPar to LastPar do + if gBmin^[I] >= gBmax^[I] then + begin + gBmin^[I] := - MAX_BOUND; + gBmax^[I] := MAX_BOUND; + end; + + DelVector(gD, gLastPar); + DimVector(gD, LastPar); + + gLb := Lb; + gUb := Ub; + + gFirstPar := FirstPar; + gLastPar := LastPar; + + gRegFunc := RegFunc; + gDerivProc := DerivProc; + + SetErrCode(MatOk); + end; + + function OutOfBounds(B : PVector) : Boolean; + { Check if the parameters are inside the bounds } + var + I : Integer; + OoB : Boolean; + begin + I := gFirstPar; + repeat + OoB := (B^[I] < gBmin^[I]) or (B^[I] > gBmax^[I]); + Inc(I); + until OoB or (I > gLastPar); + OutOfBounds := OoB; + end; + + function OLS_ObjFunc(B : PVector) : Float; + { Objective function for unweighted nonlinear regression } + var + K : Integer; + S : Float; + begin + if OutOfBounds(B) then + begin + OLS_ObjFunc := MAX_FUNC; + Exit; + end; + + S := 0.0; + K := gLb; + + repeat + gYcalc^[K] := gRegFunc(gX^[K], B); + gR^[K] := gY^[K] - gYcalc^[K]; + S := S + Sqr(gR^[K]); + Inc(K); + until (K > gUb) or (S > MAX_FUNC); + + if S > MAX_FUNC then S := MAX_FUNC; + OLS_ObjFunc := S; + end; + + procedure OLS_Gradient(B, G : PVector); + { Gradient for unweighted nonlinear regression } + var + I, K : Integer; { Loop variables } + begin + { Initialization } + for I := gFirstPar to gLastPar do + G^[I] := 0.0; + + { Compute Gradient } + for K := gLb to gUb do + begin + gDerivProc(gX^[K], gYcalc^[K], B, gD); + for I := gFirstPar to gLastPar do + G^[I] := G^[I] - gD^[I] * gR^[K]; + end; + + for I := gFirstPar to gLastPar do + G^[I] := 2.0 * G^[I]; + end; + + procedure OLS_HessGrad(B, G : PVector; H : PMatrix); + { Gradient and Hessian for unweighted nonlinear regression } + var + I, J, K : Integer; { Loop variables } + begin + { Initializations } + for I := gFirstPar to gLastPar do + begin + G^[I] := 0.0; + for J := I to gLastPar do + H^[I]^[J] := 0.0; + end; + + { Compute Gradient & Hessian } + for K := gLb to gUb do + begin + gDerivProc(gX^[K], gYcalc^[K], B, gD); + for I := gFirstPar to gLastPar do + begin + G^[I] := G^[I] - gD^[I] * gR^[K]; + for J := I to gLastPar do + H^[I]^[J] := H^[I]^[J] + gD^[I] * gD^[J]; + end; + end; + + { Fill in symmetric matrix } + for I := Succ(gFirstPar) to gLastPar do + for J := gFirstPar to Pred(I) do + H^[I]^[J] := H^[J]^[I]; + end; + + function WLS_ObjFunc(B : PVector) : Float; + { Objective function for weighted nonlinear regression } + var + K : Integer; + S : Float; + begin + if OutOfBounds(B) then + begin + WLS_ObjFunc := MAX_FUNC; + Exit; + end; + + S := 0.0; + K := gLb; + + repeat + gYcalc^[K] := gRegFunc(gX^[K], B); + gR^[K] := gY^[K] - gYcalc^[K]; + S := S + gW^[K] * Sqr(gR^[K]); + Inc(K); + until (K > gUb) or (S > MAX_FUNC); + + if S > MAX_FUNC then S := MAX_FUNC; + WLS_ObjFunc := S; + end; + + procedure WLS_Gradient(B, G : PVector); + { Gradient for weighted nonlinear regression } + var + I, K : Integer; { Loop variables } + WR : Float; { Weighted residual } + begin + { Initialization } + for I := gFirstPar to gLastPar do + G^[I] := 0.0; + + { Compute Gradient } + for K := gLb to gUb do + begin + WR := gW^[K] * gR^[K]; + gDerivProc(gX^[K], gYcalc^[K], B, gD); + for I := gFirstPar to gLastPar do + G^[I] := G^[I] - gD^[I] * WR; + end; + + for I := gFirstPar to gLastPar do + G^[I] := 2.0 * G^[I]; + end; + + procedure WLS_HessGrad(B, G : PVector; H : PMatrix); + { Gradient and Hessian for weighted nonlinear regression } + var + I, J, K : Integer; { Loop variables } + WR, WD : Float; { Weighted residual and derivative } + begin + { Initializations } + for I := gFirstPar to gLastPar do + begin + G^[I] := 0.0; + for J := I to gLastPar do + H^[I]^[J] := 0.0; + end; + + { Compute Gradient & Hessian } + for K := gLb to gUb do + begin + WR := gW^[K] * gR^[K]; + gDerivProc(gX^[K], gYcalc^[K], B, gD); + for I := gFirstPar to gLastPar do + begin + G^[I] := G^[I] - gD^[I] * WR; + WD := gW^[K] * gD^[I]; + for J := I to gLastPar do + H^[I]^[J] := H^[I]^[J] + WD * gD^[J]; + end; + end; + + { Fill in symmetric matrix } + for I := Succ(gFirstPar) to gLastPar do + for J := gFirstPar to Pred(I) do + H^[I]^[J] := H^[J]^[I]; + end; + + procedure GenNLFit(Mode : TRegMode; + RegFunc : TRegFunc; + DerivProc : TDerivProc; + X, Y, S : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); + { -------------------------------------------------------------------- + General nonlinear regression routine + -------------------------------------------------------------------- } + var + F_min : Float; { Value of objective function at minimum } + G : PVector; { Gradient vector } + Det : Float; { Determinant of Hessian matrix } + ObjFunc : TFuncNVar; { Objective function } + GradProc : TGradient; { Procedure to compute gradient } + HessProc : THessGrad; { Procedure to compute gradient and hessian } + + begin + SetGlobalVar(Mode, RegFunc, DerivProc, X, Y, S, + Lb, Ub, FirstPar, LastPar); + + if MathErr <> MatOk then Exit; + + if Mode = UNWEIGHTED then + begin + ObjFunc := {$IFDEF FPC}@{$ENDIF}OLS_ObjFunc; + GradProc := {$IFDEF FPC}@{$ENDIF}OLS_Gradient; + HessProc := {$IFDEF FPC}@{$ENDIF}OLS_HessGrad; + end + else + begin + ObjFunc := {$IFDEF FPC}@{$ENDIF}WLS_ObjFunc; + GradProc := {$IFDEF FPC}@{$ENDIF}WLS_Gradient; + HessProc := {$IFDEF FPC}@{$ENDIF}WLS_HessGrad; + end; + + DimVector(G, LastPar); + + case OptAlgo of + NL_MARQ : Marquardt(ObjFunc, HessProc, B, FirstPar, LastPar, + MaxIter, Tol, F_min, G, V, Det); + NL_SIMP : Simplex(ObjFunc, B, FirstPar, LastPar, + MaxIter, Tol, F_min); + NL_BFGS : BFGS(ObjFunc, GradProc, B, FirstPar, LastPar, + MaxIter, Tol, F_min, G, V); + NL_SA : SimAnn(ObjFunc, B, gBmin, gBmax, FirstPar, LastPar, F_min); + NL_GA : GenAlg(ObjFunc, B, gBmin, gBmax, FirstPar, LastPar, F_min); + end; + + if (OptAlgo <> NL_MARQ) and (MathErr = MatOk) then + begin + { Compute the Hessian matrix and its inverse } + HessProc(B, G, V); + GaussJordan(V, FirstPar, LastPar, LastPar, Det); + end; + + DelVector(G, LastPar); + end; + + procedure NLFit(RegFunc : TRegFunc; + DerivProc : TDerivProc; + X, Y : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); + begin + GenNLFit(UNWEIGHTED, RegFunc, DerivProc, X, Y, nil, Lb, Ub, + MaxIter, Tol, B, FirstPar, LastPar, V); + end; + + procedure WNLFit(RegFunc : TRegFunc; + DerivProc : TDerivProc; + X, Y, S : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); + begin + GenNLFit(WEIGHTED, RegFunc, DerivProc, X, Y, S, Lb, Ub, + MaxIter, Tol, B, FirstPar, LastPar, V); + end; + + procedure SetMCFile(FileName : String); + begin + MCFile := FileName; + end; + + procedure GenSimFit(Mode : TRegMode; + RegFunc : TRegFunc; + X, Y, S : PVector; + Lb, Ub : Integer; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); + var + ObjFunc : TFuncNVar; { Objective function } + NCycles, + MaxSim, + SavedSim : Integer; { Metropolis-Hastings parameters } + Xmat : PMatrix; { Matrix of simulated parameters } + F_min : Float; { Value of objective function at minimum } + B_min : PVector; { Parameter values at minimum } + R : Float; { Range of parameter values } + I, J : Integer; { Loop variables } + F : Text; { File for storing MCMC simulations } + + begin + SetGlobalVar(Mode, RegFunc, nil, X, Y, S, + Lb, Ub, FirstPar, LastPar); + + if MathErr <> MatOk then Exit; + + { Initialize variance-covariance matrix } + for I := FirstPar to LastPar do + begin + R := gBmax^[I] - gBmin^[I]; + B^[I] := gBmin^[I] + 0.5 * R; + for J := FirstPar to LastPar do + if I = J then + { The parameter range is assumed to cover 6 SD's } + V^[I]^[J] := R * R / 36.0 + else + V^[I]^[J] := 0.0; + end; + + if Mode = UNWEIGHTED then + ObjFunc := {$IFDEF FPC}@{$ENDIF}OLS_ObjFunc + else + ObjFunc := {$IFDEF FPC}@{$ENDIF}WLS_ObjFunc; + + GetMHParams(NCycles, MaxSim, SavedSim); + + DimMatrix(Xmat, SavedSim, LastPar); + DimVector(B_min, LastPar); + + Hastings(ObjFunc, 2.0, B, V, FirstPar, LastPar, Xmat, B_min, F_min); + + if MathErr = MatOk then { Save simulations } + begin + Assign(F, MCFile); + Rewrite(F); + for I := 1 to SavedSim do + begin + Write(F, IntStr(I)); + for J := FirstPar to LastPar do + Write(F, FloatStr(Xmat^[I]^[J])); + Writeln(F); + end; + Close(F); + end; + + DelMatrix(Xmat, SavedSim, LastPar); + end; + + procedure SimFit(RegFunc : TRegFunc; + X, Y : PVector; + Lb, Ub : Integer; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); + begin + GenSimFit(UNWEIGHTED, RegFunc, X, Y, nil, Lb, Ub, B, FirstPar, LastPar, V); + end; + + procedure WSimFit(RegFunc : TRegFunc; + X, Y, S : PVector; + Lb, Ub : Integer; + B : PVector; + FirstPar, + LastPar : Integer; + V : PMatrix); + begin + GenSimFit(WEIGHTED, RegFunc, X, Y, S, Lb, Ub, B, FirstPar, LastPar, V); + end; + +end. diff --git a/fpmath/unonpar.pas b/fpmath/unonpar.pas new file mode 100755 index 0000000..94d0c9c --- /dev/null +++ b/fpmath/unonpar.pas @@ -0,0 +1,216 @@ +{ ****************************************************************** + Non-parametric tests + ****************************************************************** } + +unit unonpar; + +interface + +uses + utypes; + +procedure Mann_Whitney(N1, N2 : Integer; + X1, X2 : PVector; + var U, Eps : Float); +{ ------------------------------------------------------------------ + Mann-Whitney test + ------------------------------------------------------------------ } + +procedure Wilcoxon(X, Y : PVector; + Lb, Ub : Integer; + var Ndiff : Integer; + var T, Eps : Float); +{ ------------------------------------------------------------------ + Wilcoxon test + ------------------------------------------------------------------ } + +procedure Kruskal_Wallis(Ns : Integer; + N : PIntVector; + X : PMatrix; + var H : Float; + var DoF : Integer); +{ ------------------------------------------------------------------ + Kruskal-Wallis test + ------------------------------------------------------------------ } + +implementation + +procedure Ranks(Ns : Integer; + N : PIntVector; + X : PMatrix; + Sr : PVector; + var Corr : Float); +{ ------------------------------------------------------------------ + Compute ranks for non-parametric tests + ------------------------------------------------------------------ + Sr = sum of ranks for each sample + Corr = correction for ties = Sum k(k^2 - 1) k = nb of ties + ------------------------------------------------------------------ } + +var + I, J, I1, J1, NI, NE : Integer; + Y, Z, R : Float; + +begin + if Ns < 2 then + begin + SetErrCode(MatErrDim); + Exit + end; + + SetErrCode(MatOk); + Corr := 0.0; + + for I := 1 to Ns do + Sr^[I] := 0; + + for I := 1 to Ns do + for J := 1 to N^[I] do + begin + Y := X^[J]^[I]; + NE := 0; { Nb of values = Y } + NI := 0; { Nb of values < Y } + for I1 := 1 to Ns do + for J1 := 1 to N^[I1] do + begin + Z := X^[J1]^[I1]; + if Z < Y then Inc(NI) else if Z = Y then Inc(NE); + end; + R := NI + Succ(NE) / 2; { Mean rank of Y } + Sr^[I] := Sr^[I] + R; { Sum of ranks for sample I } + if NE > 1 then + Corr := Corr + NE * (Sqr(NE) - 1); + end; +end; + +procedure Mann_Whitney(N1, N2 : Integer; + X1, X2 : PVector; + var U, Eps : Float); + +var + Nmax, I : Integer; + N : PIntVector; + X : PMatrix; + Sr : PVector; + Sum, Prod, Corr : Float; + U1, U2, MU, VU : Float; + +begin + if N1 > N2 then Nmax := N1 else Nmax := N2; + + DimIntVector(N, 2); + DimVector(Sr, 2); + DimMatrix(X, Nmax, 2); + + N^[1] := N1; + N^[2] := N2; + + for I := 1 to N1 do { Copy X1 into first column of X } + X^[I]^[1] := X1^[I]; + + for I := 1 to N2 do { Copy X2 into second column of X } + X^[I]^[2] := X2^[I]; + + Ranks(2, N, X, Sr, Corr); + + Sum := N1 + N2; + Prod := N1 * N2; + + U1 := Prod + N1 * (N1 + 1) / 2 - Sr^[1]; + U2 := Prod + N2 * (N2 + 1) / 2 - Sr^[2]; + + if U1 > U2 then U := U2 else U := U1; + + MU := Prod / 2; + VU := Prod * ((Sum + 1) - Corr / Sum / (Sum - 1)) / 12; + + Eps := (U - MU) / Sqrt(VU); + + DelIntVector(N, 2); + DelVector(Sr, 2); + DelMatrix(X, Nmax, 2); +end; + +procedure Wilcoxon(X, Y : PVector; + Lb, Ub : Integer; + var Ndiff : Integer; + var T, Eps : Float); + +var + J, J1, J2, N : Integer; + Diff, MT, VT, Corr : Float; + D : PMatrix; + ND : PIntVector; + Sr : PVector; + +begin + N := Ub - Lb + 1; + + DimMatrix(D, N, 2); + DimIntVector(ND, 2); + DimVector(Sr, 2); + + J1 := 0; J2 := 0; + for J := Lb to Ub do + begin + Diff := X^[J] - Y^[J]; + if Diff < 0 then + begin + Inc(J1); + D^[J1]^[1] := Abs(Diff); { Negative difference } + end + else if Diff > 0 then + begin + Inc(J2); + D^[J2]^[2] := Diff; { Positive difference } + end; + end; + + ND^[1] := J1; { Nb of negative differences } + ND^[2] := J2; { Nb of positive differences } + Ndiff := J1 + J2; { Nb of non-null differences } + + Ranks(2, ND, D, Sr, Corr); + + if Sr^[1] > Sr^[2] then T := Sr^[2] else T := Sr^[1]; + + MT := N * (N + 1) / 4; + VT := MT * (2 * N + 1) / 6 - Corr / 48; + Eps := (T - MT) / Sqrt(VT); + + DelMatrix(D, N, 2); + DelIntVector(ND, 2); + DelVector(Sr, 2); +end; + +procedure Kruskal_Wallis(Ns : Integer; + N : PIntVector; + X : PMatrix; + var H : Float; + var DoF : Integer); + +var + I, NT : Integer; + S, Corr : Float; + Sr : PVector; + +begin + DimVector(Sr, Ns); + + Ranks(Ns, N, X, Sr, Corr); + + S := 0.0; NT := 0; + for I := 1 to Ns do + begin + S := S + Sqr(Sr^[I]) / N^[I]; + NT := NT + N^[I]; + end; + + H := 12 * S / NT / (NT + 1) - 3 * (NT + 1); + H := H / (1 - Corr / NT / (Sqr(NT) - 1)); + DoF := Pred(Ns); + + DelVector(Sr, Ns); +end; + +end. \ No newline at end of file diff --git a/fpmath/unormal.pas b/fpmath/unormal.pas new file mode 100755 index 0000000..42884b1 --- /dev/null +++ b/fpmath/unormal.pas @@ -0,0 +1,31 @@ +{ ****************************************************************** + Density of standard normal distribution + ****************************************************************** } + +unit unormal; + +interface + +uses + utypes; + +function DNorm(X : Float) : Float; +{ Density of standard normal distribution } + +implementation + +function DNorm(X : Float) : Float; +var + Y : Float; +begin + Y := - 0.5 * X * X; + if Y < MinLog then + DNorm := DefaultVal(FUnderflow, 0.0) + else + begin + SetErrCode(FOk); + DNorm := InvSqrt2Pi * Exp(Y); + end; +end; + +end. \ No newline at end of file diff --git a/fpmath/upca.pas b/fpmath/upca.pas new file mode 100755 index 0000000..7f3eab6 --- /dev/null +++ b/fpmath/upca.pas @@ -0,0 +1,234 @@ +{ ****************************************************************** + Principal component analysis + ****************************************************************** } + +unit upca; + +interface + +uses + utypes, ujacobi; + +procedure VecMean(X : PMatrix; + Lb, Ub, Nvar : Integer; + M : PVector); +{ ---------------------------------------------------------------------- + Computes the mean vector (M) from matrix X + ---------------------------------------------------------------------- + Input : X[Lb..Ub, 1..Nvar] = matrix of variables + Output : M[1..Nvar] = mean vector + ---------------------------------------------------------------------- } + +procedure VecSD(X : PMatrix; + Lb, Ub, Nvar : Integer; + M, S : PVector); +{ ---------------------------------------------------------------------- + Computes the vector of standard deviations (S) from matrix X + ---------------------------------------------------------------------- + Input : X, Lb, Ub, Nvar, M + Output : S[1..Nvar] + ---------------------------------------------------------------------- } + +procedure MatVarCov(X : PMatrix; + Lb, Ub, Nvar : Integer; + M : PVector; + V : PMatrix); +{ ---------------------------------------------------------------------- + Computes the variance-covariance matrix (V) from matrix X + + Input : X, Lb, Ub, Nvar, M + Output : V[1..Nvar, 1..Nvar] + ---------------------------------------------------------------------- } + +procedure MatCorrel(V : PMatrix; + Nvar : Integer; + R : PMatrix); +{ ---------------------------------------------------------------------- + Computes the correlation matrix (R) from the variance-covariance + matrix (V) + + Input : V, Nvar + Output : R[1..Nvar, 1..Nvar] + ---------------------------------------------------------------------- } + +procedure PCA(R : PMatrix; + Nvar : Integer; + MaxIter : Integer; + Tol : Float; + Lambda : PVector; + C, Rc : PMatrix); +{ ---------------------------------------------------------------------- + Performs a principal component analysis of the correlation matrix R + ---------------------------------------------------------------------- + Input : R[1..Nvar] = Correlation matrix + MaxIter = Max. number of iterations + Tol = Required precision + Output : Lambda[1..Nvar] = Eigenvalues of the correlation matrix + (in descending order) + C[1..Nvar, 1..Nvar] = Eigenvectors of the correlation matrix + (stored as columns) + Rc[1..Nvar, 1..Nvar] = Correlations between principal factors + and variables (Rc^[I]^[J] is the + correlation coefficient between + variable I and factor J) + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix R + ---------------------------------------------------------------------- } + +procedure ScaleVar(X : PMatrix; + Lb, Ub, Nvar : Integer; + M, S : PVector; + Z : PMatrix); +{ ---------------------------------------------------------------------- + Scales a set of variables by subtracting means and dividing by SD's + ---------------------------------------------------------------------- + Input : X, Lb, Ub, Nvar, M, S + Output : Z[Lb..Ub, 1..Nvar] = matrix of scaled variables + ---------------------------------------------------------------------- } + +procedure PrinFac(Z : PMatrix; + Lb, Ub, Nvar : Integer; + C, F : PMatrix); +{ ---------------------------------------------------------------------- + Computes principal factors + ---------------------------------------------------------------------- + Input : Z[Lb..Ub, 1..Nvar] = matrix of scaled variables + C[1..Nvar, 1..Nvar] = matrix of eigenvectors from PCA + Output : F[Lb..Ub, 1..Nvar] = matrix of principal factors + ---------------------------------------------------------------------- } + +implementation + +procedure VecMean(X : PMatrix; + Lb, Ub, Nvar : Integer; + M : PVector); +var + I, K, Nobs : Integer; + Sum : Float; + +begin + Nobs := Ub - Lb + 1; + for I := 1 to Nvar do + begin + Sum := 0.0; + for K := Lb to Ub do + Sum := Sum + X^[K]^[I]; + M^[I] := Sum / Nobs; + end; +end; + +procedure VecSD(X : PMatrix; + Lb, Ub, Nvar : Integer; + M, S : PVector); +var + I, K, Nobs : Integer; + Sum : Float; +begin + Nobs := Ub - Lb + 1; + for I := 1 to Nvar do + begin + Sum := 0.0; + for K := Lb to Ub do + Sum := Sum + Sqr(X^[K]^[I] - M^[I]); + S^[I] := Sqrt(Sum / Nobs); + end; +end; + +procedure MatVarCov(X : PMatrix; + Lb, Ub, Nvar : Integer; + M : PVector; + V : PMatrix); +var + I, J, K, Nobs : Integer; + Sum : Float; +begin + Nobs := Ub - Lb + 1; + + for I := 1 to Nvar do + for J := I to Nvar do + begin + Sum := 0.0; + for K := Lb to Ub do + Sum := Sum + (X^[K]^[I] - M^[I]) * (X^[K]^[J] - M^[J]); + V^[I]^[J] := Sum / Nobs; + end; + + for I := 2 to Nvar do + for J := 1 to Pred(I) do + V^[I]^[J] := V^[J]^[I]; +end; + +procedure MatCorrel(V : PMatrix; + Nvar : Integer; + R : PMatrix); +var + I, J : Integer; + P : Float; +begin + for I := 1 to Nvar do + begin + R^[I]^[I] := 1.0; + for J := Succ(I) to Nvar do + begin + P := V^[I]^[I] * V^[J]^[J]; + if P > 0.0 then + R^[I]^[J] := V^[I]^[J] / Sqrt(P) + else + R^[I]^[J] := 0.0; + R^[J]^[I] := R^[I]^[J]; + end; + end; +end; + +procedure PCA(R : PMatrix; + Nvar : Integer; + MaxIter : Integer; + Tol : Float; + Lambda : PVector; + C, Rc : PMatrix); +var + I, J : Integer; + Rac : Float; +begin + { Compute eigenvalues and eigenvectors of correlation matrix } + Jacobi(R, 1, Nvar, MaxIter, Tol, Lambda, C); + + if MathErr <> MatOk then Exit; + + { Compute correlations between principal factors and reduced variables } + for J := 1 to Nvar do + begin + Rac := Sqrt(Lambda^[J]); + for I := 1 to Nvar do + Rc^[I]^[J] := C^[I]^[J] * Rac; + end; +end; + +procedure ScaleVar(X : PMatrix; + Lb, Ub, Nvar : Integer; + M, S : PVector; + Z : PMatrix); +var + I, J : Integer; +begin + for I := Lb to Ub do + for J := 1 to Nvar do + Z^[I]^[J] := (X^[I]^[J] - M^[J]) / S^[J]; +end; + +procedure PrinFac(Z : PMatrix; + Lb, Ub, Nvar : Integer; + C, F : PMatrix); +var + I, J, K : Integer; +begin + for I := Lb to Ub do + for J := 1 to Nvar do + begin + F^[I]^[J] := 0.0; + for K := 1 to Nvar do + F^[I]^[J] := F^[I]^[J] + Z^[I]^[K] * C^[K]^[J]; + end; +end; + +end. \ No newline at end of file diff --git a/fpmath/uplot.pas b/fpmath/uplot.pas new file mode 100755 index 0000000..9b59712 --- /dev/null +++ b/fpmath/uplot.pas @@ -0,0 +1,1249 @@ +{ ****************************************************************** + Plotting routines for TP/FPC/GPC (based on the Graph unit) + ****************************************************************** } + +unit uplot; + +interface + +uses + graph, utypes, umath, uround, uinterv, ustrings; + +function InitGraphics(Pilot, Mode : Integer; BGIPath : String) : Boolean; +{ ------------------------------------------------------------------ + Enters graphic mode + ------------------------------------------------------------------ } + +procedure SetWindow(X1, X2, Y1, Y2 : Integer; GraphBorder : Boolean); +{ ------------------------------------------------------------------ + Sets the graphic window + + X1, X2, Y1, Y2 : Window coordinates in % of maximum + GraphBorder : Flag for drawing the window border + ------------------------------------------------------------------ } + +procedure AutoScale(X : PVector; Lb, Ub : Integer; Scale : TScale; + var XMin, XMax, XStep : Float); +{ ------------------------------------------------------------------ + Finds an appropriate scale for plotting the data in X[Lb..Ub] + ------------------------------------------------------------------ } + +procedure SetOxScale(Scale : TScale; OxMin, OxMax, OxStep : Float); +{ ------------------------------------------------------------------ + Sets the scale on the Ox axis + ------------------------------------------------------------------ } + +procedure SetOyScale(Scale : TScale; OyMin, OyMax, OyStep : Float); +{ ------------------------------------------------------------------ + Sets the scale on the Oy axis + ------------------------------------------------------------------ } + +procedure SetGraphTitle(Title : String); +{ ------------------------------------------------------------------ + Sets the title for the graph + ------------------------------------------------------------------ } + +procedure SetOxTitle(Title : String); +{ ------------------------------------------------------------------ + Sets the title for the Ox axis + ------------------------------------------------------------------ } + +procedure SetOyTitle(Title : String); +{ ------------------------------------------------------------------ + Sets the title for the Oy axis + ------------------------------------------------------------------ } + +procedure SetTitleFont(FontIndex, Width, Height : Integer); +{ ------------------------------------------------------------------ + Sets the font for the main graph title + ------------------------------------------------------------------ } + +procedure SetOxFont(FontIndex, Width, Height : Integer); +{ ------------------------------------------------------------------ + Sets the font for the Ox axis (title and labels) + ------------------------------------------------------------------ } + +procedure SetOyFont(FontIndex, Width, Height : Integer); +{ ------------------------------------------------------------------ + Sets the font for the Oy axis (title and labels) + ------------------------------------------------------------------ } + +procedure SetLgdFont(FontIndex, Width, Height : Integer); +{ ------------------------------------------------------------------ + Sets the font for the legends + ------------------------------------------------------------------ } + +procedure PlotOxAxis; +{ ------------------------------------------------------------------ + Plots the horizontal axis + ------------------------------------------------------------------ } + +procedure PlotOyAxis; +{ ------------------------------------------------------------------ + Plots the vertical axis + ------------------------------------------------------------------ } + +procedure PlotGrid(Grid : TGrid); +{ ------------------------------------------------------------------ + Plots a grid on the graph + ------------------------------------------------------------------ } + +procedure WriteGraphTitle; +{ ------------------------------------------------------------------ + Writes the title of the graph + ------------------------------------------------------------------ } + +procedure SetClipping(Clip : Boolean); +{ ------------------------------------------------------------------ + Determines whether drawings are clipped at the current viewport + boundaries, according to the value of the Boolean parameter Clip + ------------------------------------------------------------------ } + +procedure SetMaxCurv(NCurv : Byte); +{ ------------------------------------------------------------------ + Sets the maximum number of curves and re-initializes their + parameters + ------------------------------------------------------------------ } + +procedure SetPointParam(CurvIndex, Symbol, Size, Color : Integer); +{ ------------------------------------------------------------------ + Sets the point parameters for curve # CurvIndex + ------------------------------------------------------------------ } + +procedure SetLineParam(CurvIndex, Style, Width, Color : Integer); +{ ------------------------------------------------------------------ + Sets the line parameters for curve # CurvIndex + ------------------------------------------------------------------ } + +procedure SetCurvLegend(CurvIndex : Integer; Legend : String); +{ ------------------------------------------------------------------ + Sets the legend for curve # CurvIndex + ------------------------------------------------------------------ } + +procedure SetCurvStep(CurvIndex, Step : Integer); +{ ------------------------------------------------------------------ + Sets the step for curve # CurvIndex + ------------------------------------------------------------------ } + +procedure PlotPoint(Xp, Yp, CurvIndex : Integer); +{ ------------------------------------------------------------------ + Plots a point on the screen + ------------------------------------------------------------------ + Input parameters : Xp, Yp = point coordinates in pixels + CurvIndex = index of curve parameters + (Symbol, Size, Color) + ------------------------------------------------------------------ } + +procedure PlotCurve(X, Y : PVector; Lb, Ub, CurvIndex : Integer); +{ ------------------------------------------------------------------ + Plots a curve + ------------------------------------------------------------------ + Input parameters : X, Y = point coordinates + Lb, Ub = indices of first and last points + CurvIndex = index of curve parameters + ------------------------------------------------------------------ } + +procedure PlotCurveWithErrorBars(X, Y, S : PVector; + Ns, Lb, Ub, CurvIndex : Integer); +{ ------------------------------------------------------------------ + Plots a curve with error bars + ------------------------------------------------------------------ + Input parameters : X, Y = point coordinates + S = errors + Lb, Ub = indices of first and last points + CurvIndex = index of curve parameters + ------------------------------------------------------------------ } + +procedure PlotFunc(Func : TFunc; X1, X2 : Float; CurvIndex : Integer); +{ ------------------------------------------------------------------ + Plots a function + ------------------------------------------------------------------ + Input parameters: + Func = function to be plotted + X1, X2 = abscissae of 1st and last point to plot + CurvIndex = index of curve parameters (Width, Style, Color) + ------------------------------------------------------------------ + The function must be programmed as : + function Func(X : Float) : Float; + ------------------------------------------------------------------ } + +procedure WriteLegend(NCurv : Integer; ShowPoints, ShowLines : Boolean); +{ ------------------------------------------------------------------ + Writes the legends for the plotted curves + ------------------------------------------------------------------ + NCurv : number of curves (1 to MaxCurv) + ShowPoints : for displaying points + ShowLines : for displaying lines + ------------------------------------------------------------------ } + +procedure ConRec(Nx, Ny, Nc : Integer; + X, Y, Z : PVector; + F : PMatrix); +{ ------------------------------------------------------------------ + Contour plot + Adapted from Paul Bourke, Byte, June 1987 + http://astronomy.swin.edu.au/~pbourke/projection/conrec/ + ------------------------------------------------------------------ + Input parameters: + Nx, Ny = number of steps on Ox and Oy + Nc = number of contour levels + X[0..Nx], Y[0..Ny] = point coordinates in pixels + Z[0..(Nc - 1)] = contour levels in increasing order + F[0..Nx, 0..Ny] = function values, such that F[I,J] is the + function value at (X[I], Y[I]) + ------------------------------------------------------------------ } + +function Xpixel(X : Float) : Integer; +{ ------------------------------------------------------------------ + Converts user abscissa X to screen coordinate + ------------------------------------------------------------------ } + +function Ypixel(Y : Float) : Integer; +{ ------------------------------------------------------------------ + Converts user ordinate Y to screen coordinate + ------------------------------------------------------------------ } + +function Xuser(X : Integer) : Float; +{ ------------------------------------------------------------------ + Converts screen coordinate X to user abscissa + ------------------------------------------------------------------ } + +function Yuser(Y : Integer) : Float; +{ ------------------------------------------------------------------ + Converts screen coordinate Y to user ordinate + ------------------------------------------------------------------ } + +procedure LeaveGraphics; +{ ------------------------------------------------------------------ + Quits graphic mode + ------------------------------------------------------------------ } + + +implementation + +const + MaxSymbol = 9; { Max. number of symbols for plotting curves } + MaxCurvColor = 9; { Max. number of colors for curves } + Eps = 1.0E-10; { Lower limit for an axis label } + + CurvColor : array[1..MaxCurvColor] of Integer = + (12, { LightRed } + 14, { Yellow } + 10, { LightGreen } + 9, { LightBlue } + 11, { LightCyan } + 13, { LightMagenta } + 4, { Red } + 2, { Green } + 1 { Blue }); + +type + TAxis = record { Coordinate axis } + Scale : TScale; + Min : Float; + Max : Float; + Step : Float; + end; + + TFont = record { Font for titles and legends } + Index : Integer; + Width : Integer; + Height : Integer; + end; + + TPointParam = record { Point parameters } + Symbol : Integer; { Symbol: 0: point (.) } + Size : Integer; { 1: solid circle 2: open circle } + Color : Integer; { 3: solid square 4: open square } + end; { 5: solid triangle 6: open triangle } + { 7: plus (+) 8: multiply (x) } + { 9: star (* ) } + + TLineParam = record { Line parameters } + Style : Integer; { 0: none, 1: solid, 2: dotted, 3: centered, 4: dashed } + Width : Integer; { 1: normal, 3: thick } + Color : Integer; + end; + + TCurvParam = record { Curve parameters } + PointParam : TPointParam; + LineParam : TLineParam; + Legend : Str30; { Legend of curve } + Step : Integer; { Plot 1 point every Step points } + end; + + TCurvParamVector = array[1..255] of TCurvParam; + PCurvParamVector = ^TCurvParamVector; + +var + Xwin1, Xwin2, Ywin1, Ywin2 : Integer; + XminPixel, XmaxPixel : Integer; + YminPixel, YmaxPixel : Integer; + FactX, FactY : Float; + XAxis, YAxis : TAxis; + GraphTitle, XTitle, YTitle : String; + TitleFont, XFont, YFont, LgdFont : TFont; + MaxCurv : Integer; + CurvParam : PCurvParamVector; + +procedure DimCurvParamVector(var CurvParam : PCurvParamVector; Ub : Byte); +var + I : Integer; +begin + { Allocate vector } + GetMem(CurvParam, Ub * SizeOf(TCurvParam)); + if CurvParam = nil then Exit; + + MaxCurv := Ub; + + { Initialize curve parameters } + for I := 1 to Ub do + with CurvParam^[I] do + begin + PointParam.Symbol := (I - 1) mod MaxSymbol + 1; + PointParam.Size := 2; + PointParam.Color := CurvColor[(I - 1) mod MaxCurvColor + 1]; + Legend := 'Curve ' + LTrim(IntStr(I)); + LineParam.Width := 1; + LineParam.Style := 1; + LineParam.Color := PointParam.Color; + Step := 1; + end; +end; + +procedure DelCurvParamVector(var CurvParam : PCurvParamVector; Ub : Byte); +begin + if CurvParam <> nil then + begin + FreeMem(CurvParam, Ub * SizeOf(TCurvParam)); + CurvParam := nil; + MaxCurv := 0; + end; +end; + +function InitGraphics(Pilot, Mode : Integer; BGIPath : String) : Boolean; +var + P, M : {$IFDEF FPC}Smallint{$ELSE}Integer{$ENDIF}; +begin + P := Pilot; + M := Mode; + + InitGraph(P, M, BGIPath); + + if GraphResult <> 0 then + begin + InitGraphics := False; + Exit; + end; + + InitGraphics := True; + + MaxCurv := MaxSymbol; + DimCurvParamVector(CurvParam, MaxCurv); + + { Obtain info about current mode } + XminPixel := 0; XmaxPixel := GetMaxX; + YminPixel := 0; YmaxPixel := GetMaxY; +end; + +procedure SetWindow(X1, X2, Y1, Y2 : Integer; GraphBorder : Boolean); +var + R : Float; +begin + if (X1 >= 0) and (X2 <= 100) and (X1 < X2) then + begin + Xwin1 := X1; + Xwin2 := X2; + R := 0.01 * GetMaxX; + XminPixel := Round(X1 * R); + XmaxPixel := Round(X2 * R); + end; + + if (Y1 >= 0) and (Y2 <= 100) and (Y1 < Y2) then + begin + Ywin1 := Y1; + Ywin2 := Y2; + R := 0.01 * GetMaxY; + YminPixel := Round(Y1 * R); + YmaxPixel := Round(Y2 * R); + end; + + XAxis.Scale := LinScale; + XAxis.Min := 0.0; + XAxis.Max := 1.0; + XAxis.Step := 0.2; + + YAxis.Scale := LinScale; + YAxis.Min := 0.0; + YAxis.Max := 1.0; + YAxis.Step := 0.2; + + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); + + XTitle := 'X'; + XFont.Index := 2; + XFont.Width := 150; + XFont.Height := 150; + + YTitle := 'Y'; + YFont.Index := 2; + YFont.Width := 150; + YFont.Height := 150; + + GraphTitle := ''; + TitleFont.Index := 2; + TitleFont.Width := 175; + TitleFont.Height := 175; + + LgdFont.Index := 2; + LgdFont.Width := 150; + LgdFont.Height := 150; + + if GraphBorder then + Rectangle(XminPixel, YminPixel, XmaxPixel, YmaxPixel); +end; + +procedure AutoScale(X : PVector; Lb, Ub : Integer; Scale : TScale; + var XMin, XMax, XStep : Float); +var + I : Integer; + X1, X2 : Float; +begin + { Minimum and maximum of X } + + X1 := X^[Lb]; + X2 := X1; + for I := Lb to Ub do + if X^[I] < X1 then + X1 := X^[I] + else if X^[I] > X2 then + X2 := X^[I]; + + { Linear scale } + + if Scale = LinScale then + begin + Interval(X1, X2, 2, 6, XMin, XMax, XStep); + Exit; + end; + + { Logarithmic scale } + + XMin := 1.0E-3; + XMax := 1.0E+3; + XStep := 10.0; + + if X1 <= 0.0 then Exit; + + XMin := Int(Log10(X1)); if X1 < 1.0 then XMin := XMin - 1.0; + XMax := Int(Log10(X2)); if X2 > 1.0 then XMax := XMax + 1.0; + XMin := Exp10(XMin); + XMax := Exp10(XMax); +end; + +procedure SetOxScale(Scale : TScale; OxMin, OxMax, OxStep : Float); +begin + XAxis.Scale := Scale; + case Scale of + LinScale : + begin + if OxMin < OxMax then + begin + XAxis.Min := OxMin; + XAxis.Max := OxMax; + end; + if OxStep > 0.0 then XAxis.Step := OxStep; + end; + LogScale : + begin + if (OxMin > 0.0) and (OxMin < OxMax) then + begin + XAxis.Min := Floor(Log10(OxMin)); + XAxis.Max := Ceil(Log10(OxMax)); + end; + XAxis.Step := 1.0; + end; + end; + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); +end; + +procedure SetOyScale(Scale : TScale; OyMin, OyMax, OyStep : Float); +begin + YAxis.Scale := Scale; + case Scale of + LinScale : + begin + if OyMin < OyMax then + begin + YAxis.Min := OyMin; + YAxis.Max := OyMax; + end; + if OyStep > 0.0 then YAxis.Step := OyStep; + end; + LogScale : + begin + if (OyMin > 0.0) and (OyMin < OyMax) then + begin + YAxis.Min := Floor(Log10(OyMin)); + YAxis.Max := Ceil(Log10(OyMax)); + end; + YAxis.Step := 1.0; + end; + end; + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); +end; + +procedure SetGraphTitle(Title : String); +begin + GraphTitle := Title; +end; + +procedure SetOxTitle(Title : String); +begin + XTitle := Title; +end; + +procedure SetOyTitle(Title : String); +begin + YTitle := Title; +end; + +procedure SetFont(Select, Index, Width, Height : Integer); +var + Font : TFont; +begin + if Index in [0..10] then Font.Index := Index; + if Width > 0 then Font.Width := Width; + if Height > 0 then Font.Height := Height; + + case Select of + 0 : TitleFont := Font; + 1 : XFont := Font; + 2 : YFont := Font; + 3 : LgdFont := Font; + end; +end; + +procedure SetTitleFont(FontIndex, Width, Height : Integer); +begin + SetFont(0, FontIndex, Width, Height); +end; + +procedure SetOxFont(FontIndex, Width, Height : Integer); +begin + SetFont(1, FontIndex, Width, Height); +end; + +procedure SetOyFont(FontIndex, Width, Height : Integer); +begin + SetFont(2, FontIndex, Width, Height); +end; + +procedure SetLgdFont(FontIndex, Width, Height : Integer); +begin + SetFont(3, FontIndex, Width, Height); +end; + +function Xpixel(X : Float) : Integer; +var + P : Float; +begin + P := FactX * (X - XAxis.Min); + if Abs(P) > 30000 then + Xpixel := 30000 + else + Xpixel := Round(P) + XminPixel; +end; + +function Ypixel(Y : Float) : Integer; +var + P : Float; +begin + P := FactY * (YAxis.Max - Y); + if Abs(P) > 30000 then + Ypixel := 30000 + else + Ypixel := Round(P) + YminPixel; +end; + +function Xuser(X : Integer) : Float; +begin + Xuser := XAxis.Min + (X - XminPixel) / FactX; +end; + +function Yuser(Y : Integer) : Float; +begin + Yuser := YAxis.Max - (Y - YminPixel) / FactY; +end; + +procedure PlotOxAxis; +var + W, X, Z : Float; + N, I, J : Integer; +begin + Line(XminPixel, YmaxPixel, XmaxPixel, YmaxPixel); + + SetTextStyle(XFont.Index, HorizDir, 1); + SetUserCharSize(XFont.Width, 100, XFont.Height, 100); + SetTextJustify(CenterText, TopText); + + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + X := XAxis.Min; { Tick mark position } + + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LinScale) and (Abs(X) < Eps) then X := 0.0; + + MoveTo(Xpixel(X), YmaxPixel); + LineRel(0, 5); { Plot tick mark } + + if XAxis.Scale = LinScale then Z := X else Z := Exp10(X); + OutText(Trim(FloatStr(Z))); + + if (XAxis.Scale = LogScale) and (I < N) then + for J := 2 to 9 do { Plot minor divisions } + begin { on logarithmic scale } + W := X + Log10(J); + MoveTo(Xpixel(W), YmaxPixel); + LineRel(0, 3); + end; + + X := X + XAxis.Step; + end; + + if XTitle <> '' then { Plot axis title } + OutTextXY((XminPixel + XmaxPixel) div 2, + YmaxPixel + GetMaxY div 12, XTitle); +end; + +procedure PlotOyAxis; +var + W, Y, Z : Float; + N, I, J : Integer; +begin + Line(XminPixel, YminPixel, XminPixel, YmaxPixel); + + SetTextStyle(YFont.Index, HorizDir, 1); + SetUserCharSize(YFont.Width, 100, YFont.Height, 100); + SetTextJustify(RightText, CenterText); + + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); + Y := YAxis.Min; + + for I := 0 to N do + begin + if (YAxis.Scale = LinScale) and (Abs(Y) < Eps) then Y := 0.0; + + MoveTo(XminPixel, Ypixel(Y)); + LineRel(- 5, 0); + MoveRel(- 2, - 2); + + if YAxis.Scale = LinScale then Z := Y else Z := Exp10(Y); + OutText(Trim(FloatStr(Z))); + + if (YAxis.Scale = LogScale) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + MoveTo(XminPixel, Ypixel(W)); + LineRel(- 3, 0); + end; + + Y := Y + YAxis.Step; + end; + + if YTitle <> '' then + begin + SetTextStyle(YFont.Index, VertDir, 1); + SetUserCharSize(YFont.Width, 100, YFont.Height, 100); + OutTextXY(XminPixel - GetMaxX div 8, + (YminPixel + YmaxPixel) div 2, YTitle); + end; +end; + +procedure PlotGrid(Grid : TGrid); +var + X, Y : Float; + I, N, Xp, Yp : Integer; +begin + SetLineStyle(DottedLn, 0, NormWidth); + + if Grid in [HorizGrid, BothGrid] then { Horizontal lines } + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yp := Ypixel(Y); + Line(XminPixel, Yp, XmaxPixel, Yp); + end; + end; + + if Grid in [VertiGrid, BothGrid] then { Vertical lines } + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xp := Xpixel(X); + Line(Xp, YminPixel, Xp, YmaxPixel); + end; + end; + + SetLineStyle(SolidLn, 0, NormWidth); +end; + +procedure WriteGraphTitle; +begin + if GraphTitle = '' then Exit; + + SetTextStyle(TitleFont.Index, HorizDir, 1); + SetUserCharSize(TitleFont.Width, 100, TitleFont.Height, 100); + SetTextJustify(CenterText, TopText); + + OutTextXY((XminPixel + XmaxPixel) div 2, + YminPixel - GetMaxY div 10, + GraphTitle); +end; + +procedure SetClipping(Clip : Boolean); +begin + if XminPixel = 0 then + begin + XminPixel := Round(Xwin1 / 100 * GetMaxX); + YminPixel := Round(Ywin1 / 100 * GetMaxY); + XmaxPixel := Round(Xwin2 / 100 * GetMaxX); + YmaxPixel := Round(Ywin2 / 100 * GetMaxY); + end; + + SetViewPort(XminPixel, YminPixel, XmaxPixel, YmaxPixel, Clip); + + XmaxPixel := XmaxPixel - XminPixel; XminPixel := 0; + YmaxPixel := YmaxPixel - YminPixel; YminPixel := 0; +end; + +procedure SetMaxCurv(NCurv : Byte); +begin + if NCurv < 1 then Exit; + DelCurvParamVector(CurvParam, MaxCurv); + MaxCurv := NCurv; + DimCurvParamVector(CurvParam, MaxCurv); +end; + +procedure SetPointParam(CurvIndex, Symbol, Size, Color : Integer); +begin + if (CurvIndex < 1) or (CurvIndex > MaxCurv) then Exit; + + if (Symbol >= 0) and (Symbol <= MaxSymbol) then + CurvParam^[CurvIndex].PointParam.Symbol := Symbol; + + if Size > 0 then + CurvParam^[CurvIndex].PointParam.Size := Size; + + if (Color >= 0) and (Color <= GetMaxColor) then + CurvParam^[CurvIndex].PointParam.Color := Color; +end; + +procedure SetLineParam(CurvIndex, Style, Width, Color : Integer); +begin + if (CurvIndex < 1) or (CurvIndex > MaxCurv) then Exit; + + if (Style >= 0) and (Style <= 4) then + CurvParam^[CurvIndex].LineParam.Style := Style; + + if (Width = 1) or (Width = 3) then + CurvParam^[CurvIndex].LineParam.Width := Width; + + if (Color >= 0) and (Color <= GetMaxColor) then + CurvParam^[CurvIndex].LineParam.Color := Color; +end; + +procedure SetCurvLegend(CurvIndex : Integer; Legend : String); +begin + if (CurvIndex >= 1) and (CurvIndex <= MaxCurv) then + CurvParam^[CurvIndex].Legend := Legend; +end; + +procedure SetCurvStep(CurvIndex, Step : Integer); +begin + if (CurvIndex >= 1) and (CurvIndex <= MaxCurv) and (Step > 0) then + CurvParam^[CurvIndex].Step := Step; +end; + +procedure PlotPoint(Xp, Yp, CurvIndex : Integer); +var + Xasp, Yasp : {$IFDEF __GPC__}Integer{$ELSE}Word{$ENDIF}; + Size : Integer; + Xp1, Xp2 : Word; + Yp1, Yp2 : Word; + Dx, Dy : Word; + R : Float; + Triangle : array[1..4] of PointType; + Square : array[1..5] of PointType; +begin + GetAspectRatio(Xasp, Yasp); + + Size := CurvParam^[CurvIndex].PointParam.Size; + + R := 0.0001 * Size; + + Dx := Round(R * Yasp); + Dy := Round(R * Xasp); + + Xp1 := Xp - Size; + Xp2 := Xp + Size; + Yp1 := Yp - Size; + Yp2 := Yp + Size; + + if CurvParam^[CurvIndex].PointParam.Symbol in [3, 4] then + begin + Square[1].X := Xp1; Square[1].Y := Yp1; + Square[2].X := Xp1; Square[2].Y := Yp2; + Square[3].X := Xp2; Square[3].Y := Yp2; + Square[4].X := Xp2; Square[4].Y := Yp1; + Square[5].X := Xp1; Square[5].Y := Yp1; + end; + + if CurvParam^[CurvIndex].PointParam.Symbol in [5, 6] then + begin + Triangle[1].X := Xp; Triangle[1].Y := Yp1; + Triangle[2].X := Xp2; Triangle[2].Y := Yp2; + Triangle[3].X := Xp1; Triangle[3].Y := Yp2; + Triangle[4].X := Xp; Triangle[4].Y := Yp1; + end; + + MoveTo(Xp, Yp); + SetColor(CurvParam^[CurvIndex].PointParam.Color); + SetFillStyle(SolidFill, CurvParam^[CurvIndex].PointParam.Color); + + case CurvParam^[CurvIndex].PointParam.Symbol of + 0 : PutPixel(Xp, Yp, GetColor); { . } + 1 : PieSlice(Xp, Yp, 0, 360, Dx); { Solid circle } + 2 : Ellipse(Xp, Yp, 0, 360, Dx, Dy); { Open circle } + 3 : FillPoly(5, Square); { Solid square } + 4 : DrawPoly(5, Square); { Open square } + 5 : FillPoly(4, Triangle); { Solid triangle } + 6 : DrawPoly(4, Triangle); { Open triangle } + 7 : begin { + } + Line(Xp, Yp1, Xp, Yp2); + Line(Xp1, Yp, Xp2, Yp); + end; + 8 : begin { x } + Line(Xp1, Yp1, Xp2, Yp2); + Line(Xp1, Yp2, Xp2, Yp1); + end; + 9 : begin + Line(Xp, Yp1, Xp, Yp2); { * } + Line(Xp1, Yp, Xp2, Yp); + Line(Xp1, Yp1, Xp2, Yp2); + Line(Xp1, Yp2, Xp2, Yp1); + end; + end; +end; + +procedure PlotCurve(X, Y : PVector; Lb, Ub, CurvIndex : Integer); +var + XI, YI : Float; + I, Xp, Yp : Integer; + Connect : Boolean; +begin + Connect := CurvParam^[CurvIndex].LineParam.Style > 0; + + if Connect then + SetLineStyle(Pred(CurvParam^[CurvIndex].LineParam.Style), + 0, CurvParam^[CurvIndex].LineParam.Width); + + I := Lb; + + repeat + XI := X^[I]; if XAxis.Scale = LogScale then XI := Log10(XI); + YI := Y^[I]; if YAxis.Scale = LogScale then YI := Log10(YI); + + Xp := Xpixel(XI); + Yp := Ypixel(YI); + + if Connect then + begin + SetColor(CurvParam^[CurvIndex].LineParam.Color); + if I = Lb then MoveTo(Xp, Yp) else LineTo(Xp, Yp); + end; + + PlotPoint(Xp, Yp, CurvIndex); + + I := I + CurvParam^[CurvIndex].Step; + until I > Ub; +end; + +procedure PlotCurveWithErrorBars(X, Y, S : PVector; + Ns, Lb, Ub, CurvIndex : Integer); +var + Delta, XI, YI, Y1, Y2 : Float; + I, Xp, Yp, Yp1, Yp2 : Integer; + Connect : Boolean; +begin + Connect := CurvParam^[CurvIndex].LineParam.Style > 0; + + SetColor(CurvParam^[CurvIndex].LineParam.Color); + + I := Lb; + + repeat + XI := X^[I]; if XAxis.Scale = LogScale then XI := Log10(XI); + YI := Y^[I]; if YAxis.Scale = LogScale then YI := Log10(YI); + + Xp := Xpixel(XI); Yp := Ypixel(YI); + + PlotPoint(Xp, Yp, CurvIndex); + + if S^[I] > 0 then + begin + Delta := Ns * S^[I]; + + Y1 := Y^[I] - Delta; if YAxis.Scale = LogScale then Y1 := Log10(Y1); + Y2 := Y^[I] + Delta; if YAxis.Scale = LogScale then Y2 := Log10(Y2); + + Yp1 := Ypixel(Y1); + Yp2 := Ypixel(Y2); + + SetColor(CurvParam^[CurvIndex].LineParam.Color); + SetLineStyle(SolidLn, 0, CurvParam^[CurvIndex].LineParam.Width); + + Line(Xp - 5, Yp1, Xp + 5, Yp1); + Line(Xp - 5, Yp2, Xp + 5, Yp2); + Line(Xp, Yp1, Xp, Yp2); + end; + + if Connect then + begin + SetLineStyle(Pred(CurvParam^[CurvIndex].LineParam.Style), + 0, CurvParam^[CurvIndex].LineParam.Width); + if I = Lb then MoveTo(Xp, Yp) else LineTo(Xp, Yp); + end; + + I := I + CurvParam^[CurvIndex].Step; + + until I > Ub; +end; + +procedure PlotFunc(Func : TFunc; X1, X2 : Float; CurvIndex : Integer); +var + X, Y, H : Float; + I, Npt, Xp, Yp : Integer; +begin + if X1 >= X2 then Exit; + + if XAxis.Scale = LogScale then + begin + X1 := Log10(X1); + X2 := Log10(X2); + end; + + SetColor(CurvParam^[CurvIndex].LineParam.Color); + SetLineStyle(Pred(CurvParam^[CurvIndex].LineParam.Style), 0, + CurvParam^[CurvIndex].LineParam.Width); + + { Nb of points to be plotted = number of pixels between X1 and X2 } + Npt := Xpixel(X2) - Xpixel(X1); + + H := (X2 - X1) / Npt; + + X := X1; + for I := 0 to Npt do + begin + if XAxis.Scale = LinScale then Y := Func(X) else Y := Func(Exp10(X)); + + if MathErr = FOk then + begin + if YAxis.Scale = LogScale then Y := Log10(Y); + Xp := Xpixel(X); + Yp := Ypixel(Y); + if I = 0 then MoveTo(Xp, Yp) else LineTo(Xp, Yp); + end; + + X := X + H; + end; +end; + +procedure WriteLegend(NCurv : Integer; ShowPoints, ShowLines : Boolean); + +var + CharHeight, I, L, Lmax : Integer; + N, Nmax, Xp, Xl, Yp : Integer; +begin + SetTextStyle(LgdFont.Index, HorizDir, 1); + SetUserCharSize(LgdFont.Width, 100, LgdFont.Height, 100); + SetTextJustify(LeftText, CenterText); + + N := 0; { Nb of legends to be plotted } + Lmax := 0; { Length of the longest legend } + + for I := 1 to NCurv do + if CurvParam^[I].Legend <> '' then + begin + Inc(N); + L := TextWidth(CurvParam^[I].Legend); + if L > Lmax then Lmax := L; + end; + + if (N = 0) or (Lmax = 0) then Exit; + + { Character height } + CharHeight := TextHeight('M') + 3; + + { Max. number of legends which may be plotted } + Nmax := Round((YmaxPixel - YminPixel) / CharHeight) - 1; + if N > Nmax then N := Nmax; + + { Draw rectangle around the legends } + Rectangle(XmaxPixel + Round(0.02 * GetMaxX), YminPixel, + XmaxPixel + Round(0.12 * GetMaxX) + Lmax, + YminPixel + (N + 1) * CharHeight); + + L := Round(0.02 * GetMaxX); { Half-length of line } + Xp := XmaxPixel + 3 * L; { Position of symbol } + Xl := XmaxPixel + 5 * L; { Position of legend } + + if NCurv <= Nmax then N := NCurv else N := Nmax; + + for I := 1 to N do + begin + Yp := YminPixel + I * CharHeight; + + if ShowLines and (CurvParam^[I].LineParam.Style > 0) then + begin + SetLineStyle(Pred(CurvParam^[I].LineParam.Style), + 0, CurvParam^[I].LineParam.Width); + SetColor(CurvParam^[I].LineParam.Color); + Line(Xp - L, Yp, Xp + L, Yp); + end; + + if ShowPoints then + PlotPoint(Xp, Yp, I); + + OutTextXY(Xl, Yp, CurvParam^[I].Legend); + end; +end; + +procedure ConRec(Nx, Ny, Nc : Integer; + X, Y, Z : PVector; + F : PMatrix); + +const + { Mapping from vertex numbers to X offsets } + Im : array[0..3] of Integer = (0, 1, 1, 0); + + { Mapping from vertex numbers to Y offsets } + Jm : array[0..3] of Integer = (0, 0, 1, 1); + + { Case switch table } + CasTab : array[0..2, 0..2, 0..2] of Integer = + (((0,0,8), (0,2,5), (7,6,9)), + ((0,3,4), (1,3,1), (4,3,0)), + ((9,6,7), (5,2,0), (8,0,0))); + +var + I, J, K, M, M1, M2, M3 : Integer; + X1, X2, Y1, Y2 : Float; + Fmin, Fmax : Float; + Xp, Yp : PIntVector; + PrmErr : Boolean; + +var + H : array[0..4] of Float; { Relative heights of the box above contour } + Ish : array[0..4] of Integer; { Sign of H() } + Xh : array[0..4] of Integer; { X coordinates of box } + Yh : array[0..4] of Integer; { Y coordinates of box } + +label + Case0, NoneInTri, NoneInBox; + +begin + { Check the input parameters for validity } + + PrmErr := False; + SetErrCode(MatOk); + + if (Nx <= 0) or (Ny <= 0) or (Nc <= 0) then PrmErr := True; + + for K := 1 to Nc - 1 do + if Z^[K] <= Z^[K - 1] then PrmErr := True; + + if PrmErr then + begin + SetErrCode(MatErrDim); + Exit; + end; + + { Convert user coordinates to pixels } + + DimIntVector(Xp, Nx); + DimIntVector(Yp, Ny); + + for I := 0 to Nx do + Xp^[I] := Xpixel(X^[I]); + + for J := 0 to Ny do + Yp^[J] := Ypixel(Y^[J]); + + { Scan the array, top down, left to right } + + for J := Ny - 1 downto 0 do + begin + for I := 0 to Nx - 1 do + begin + { Find the lowest vertex } + if F^[I]^[J] < F^[I]^[J + 1] then + Fmin := F^[I]^[J] + else + Fmin := F^[I]^[J + 1]; + + if F^[I + 1]^[J] < Fmin then + Fmin := F^[I + 1]^[J]; + + if F^[I + 1]^[J + 1] < Fmin then + Fmin := F^[I + 1]^[J + 1]; + + { Find the highest vertex } + if F^[I]^[J] > F^[I]^[J + 1] then + Fmax := F^[I]^[J] + else + Fmax := F^[I]^[J + 1]; + + if F^[I + 1]^[J] > Fmax then + Fmax := F^[I + 1]^[J]; + + if F^[I + 1]^[J + 1] > Fmax then + Fmax := F^[I + 1]^[J + 1]; + + if (Fmax < Z^[0]) or (Fmin > Z^[Nc - 1]) then + goto NoneInBox; + + { Draw each contour within this box } + for K := 0 to Nc - 1 do + begin + if (Z^[K] < Fmin) or (Z^[K] > Fmax) then + goto NoneInTri; + + for M := 4 downto 0 do + begin + if M > 0 then + begin + H[M] := F^[I + Im[M - 1]]^[J + Jm[M - 1]] - Z^[K]; + Xh[M] := Xp^[I + Im[M - 1]]; + Yh[M] := Yp^[J + Jm[M - 1]]; + end; + + if M = 0 then + begin + H[0] := (H[1] + H[2] + H[3] + H[4]) / 4; + Xh[0] := (Xp^[I] + Xp^[I + 1]) div 2; + Yh[0] := (Yp^[J] + Yp^[J + 1]) div 2; + end; + + if H[M] > 0 then Ish[M] := 2; + if H[M] < 0 then Ish[M] := 0; + if H[M] = 0 then Ish[M] := 1; + end; { next M } + + { Scan each triangle in the box } + for M := 1 to 4 do + begin + M1 := M; M2 := 0; M3 := M + 1; + if M3 = 5 then M3 := 1; + + case CasTab[Ish[M1], Ish[M2], Ish[M3]] of + 0 : + goto Case0; + + { Line between vertices M1 and M2 } + 1 : begin + X1 := Xh[M1]; + Y1 := Yh[M1]; + X2 := Xh[M2]; + Y2 := Yh[M2]; + end; + + { Line between vertices M2 and M3 } + 2 : begin + X1 := Xh[M2]; + Y1 := Yh[M2]; + X2 := Xh[M3]; + Y2 := Yh[M3]; + end; + + { Line between vertices M3 and M1 } + 3 : begin + X1 := Xh[M3]; + Y1 := Yh[M3]; + X2 := Xh[M1]; + Y2 := Yh[M1]; + end; + + { Line between vertex M1 and side M2-M3 } + 4 : begin + X1 := Xh[M1]; + Y1 := Yh[M1]; + X2 := (H[M3] * Xh[M2] - H[M2] * Xh[M3]) / (H[M3] - H[M2]); + Y2 := (H[M3] * Yh[M2] - H[M2] * Yh[M3]) / (H[M3] - H[M2]); + end; + + { Line between vertex M2 and side M3-M1 } + 5 : begin + X1 := Xh[M2]; + Y1 := Yh[M2]; + X2 := (H[M1] * Xh[M3] - H[M3] * Xh[M1]) / (H[M1] - H[M3]); + Y2 := (H[M1] * Yh[M3] - H[M3] * Yh[M1]) / (H[M1] - H[M3]); + end; + + { Line between vertex M3 and side M1-M2 } + 6 : begin + X1 := Xh[M3]; + Y1 := Yh[M3]; + X2 := (H[M2] * Xh[M1] - H[M1] * Xh[M2]) / (H[M2] - H[M1]); + Y2 := (H[M2] * Yh[M1] - H[M1] * Yh[M2]) / (H[M2] - H[M1]); + end; + + { Line between sides M1-M2 and M2-M3 } + 7 : begin + X1 := (H[M2] * Xh[M1] - H[M1] * Xh[M2]) / (H[M2] - H[M1]); + Y1 := (H[M2] * Yh[M1] - H[M1] * Yh[M2]) / (H[M2] - H[M1]); + X2 := (H[M3] * Xh[M2] - H[M2] * Xh[M3]) / (H[M3] - H[M2]); + Y2 := (H[M3] * Yh[M2] - H[M2] * Yh[M3]) / (H[M3] - H[M2]); + end; + + { Line between sides M2-M3 and M3-M1 } + 8 : begin + X1 := (H[M3] * Xh[M2] - H[M2] * Xh[M3]) / (H[M3] - H[M2]); + Y1 := (H[M3] * Yh[M2] - H[M2] * Yh[M3]) / (H[M3] - H[M2]); + X2 := (H[M1] * Xh[M3] - H[M3] * Xh[M1]) / (H[M1] - H[M3]); + Y2 := (H[M1] * Yh[M3] - H[M3] * Yh[M1]) / (H[M1] - H[M3]); + end; + + { Line between sides M3-M1 and M1-M2 } + 9 : begin + X1 := (H[M1] * Xh[M3] - H[M3] * Xh[M1]) / (H[M1] - H[M3]); + Y1 := (H[M1] * Yh[M3] - H[M3] * Yh[M1]) / (H[M1] - H[M3]); + X2 := (H[M2] * Xh[M1] - H[M1] * Xh[M2]) / (H[M2] - H[M1]); + Y2 := (H[M2] * Yh[M1] - H[M1] * Yh[M2]) / (H[M2] - H[M1]); + end; + end; { case } + + SetColor(CurvParam^[K mod MaxCurv + 1].LineParam.Color); + Line(Trunc(X1), Trunc(Y1), Trunc(X2), Trunc(Y2)); +Case0: + end; { next M } +NoneInTri: + end; { next K } +NoneInBox: + end; { next I } + end; { next J } +end; + +procedure LeaveGraphics; +begin + DelCurvParamVector(CurvParam, MaxCurv); + CloseGraph; +end; + +end. diff --git a/fpmath/upoidist.pas b/fpmath/upoidist.pas new file mode 100755 index 0000000..963db33 --- /dev/null +++ b/fpmath/upoidist.pas @@ -0,0 +1,38 @@ +{ ****************************************************************** + Poisson distribution + ****************************************************************** } + +unit upoidist; + +interface + +uses + utypes; + +function PPoisson(Mu : Float; K : Integer) : Float; +{ Probability of Poisson distrib. } + +implementation + +function PPoisson(Mu : Float; K : Integer) : Float; +var + P : Float; + I : Integer; +begin + if (Mu <= 0.0) or (K < 0) then + PPoisson := DefaultVal(FDomain, 0.0) + else if (- Mu) < MinLog then + PPoisson := DefaultVal(FUnderflow, 0.0) + else if K = 0 then + PPoisson := DefaultVal(FOk, Exp(- Mu)) + else + begin + P := Mu; + for I := 2 to K do { P = Mu^K / K! } + P := P * Mu / I; + PPoisson := Exp(- Mu) * P; + SetErrCode(FOk); + end; +end; + +end. \ No newline at end of file diff --git a/fpmath/upolev.pas b/fpmath/upolev.pas new file mode 100755 index 0000000..6696473 --- /dev/null +++ b/fpmath/upolev.pas @@ -0,0 +1,64 @@ +{ ****************************************************************** + Polynomial evaluations for special functions. + Translated from C code in Cephes library (http://www.moshier.net) + ****************************************************************** } + +unit upolev; + +interface + +uses + utypes; + +type + TabCoef = array[0..9] of Float; + +function PolEvl(var X : Float; Coef : TabCoef; N : Integer) : Float; + +function P1Evl(var X : Float; Coef : TabCoef; N : Integer) : Float; + +implementation + + function PolEvl(var X : Float; Coef : TabCoef; N : Integer) : Float; +{ ------------------------------------------------------------------ + Evaluates polynomial of degree N: + + 2 N + y = C + C x + C x +...+ C x + 0 1 2 N + + Coefficients are stored in reverse order: + + Coef[0] = C , ..., Coef[N] = C + N 0 + + The function P1Evl() assumes that Coef[N] = 1.0 and is + omitted from the array. Its calling arguments are + otherwise the same as PolEvl(). + ------------------------------------------------------------------ } + var + Ans : Float; + I : Integer; + begin + Ans := Coef[0]; + for I := 1 to N do + Ans := Ans * X + Coef[I]; + PolEvl := Ans; + end; + + function P1Evl(var X : Float; Coef : TabCoef; N : Integer) : Float; +{ ------------------------------------------------------------------ + Evaluate polynomial when coefficient of X is 1.0. + Otherwise same as PolEvl. + ------------------------------------------------------------------ } + var + Ans : Float; + I : Integer; + begin + Ans := X + Coef[0]; + for I := 1 to N - 1 do + Ans := Ans * X + Coef[I]; + P1Evl := Ans; + end; + +end. \ No newline at end of file diff --git a/fpmath/upolfit.pas b/fpmath/upolfit.pas new file mode 100755 index 0000000..1b365d2 --- /dev/null +++ b/fpmath/upolfit.pas @@ -0,0 +1,163 @@ +{ ****************************************************************** + Polynomial regression : Y = B(0) + B(1) * X + B(2) * X^2 + ... + ****************************************************************** } + +unit upolfit; + +interface + +uses + utypes, ulineq; + +procedure PolFit(X, Y : PVector; + Lb, Ub, Deg : Integer; + B : PVector; + V : PMatrix); +{ ------------------------------------------------------------------ + Unweighted polynomial regression + ------------------------------------------------------------------ + Input parameters: X, Y = point coordinates + Lb, Ub = array bounds + Deg = degree of polynomial + Output parameters: B = regression parameters + V = inverse matrix + ------------------------------------------------------------------ } + +procedure WPolFit(X, Y, S : PVector; + Lb, Ub, Deg : Integer; + B : PVector; + V : PMatrix); +{ ------------------------------------------------------------------ + Weighted polynomial regression + ------------------------------------------------------------------ + Additional input parameter: + S = standard deviations of observations + ------------------------------------------------------------------ } + +implementation + +procedure PolFit(X, Y : PVector; + Lb, Ub, Deg : Integer; + B : PVector; + V : PMatrix); +var + I, I1, J, K, D1 : Integer; + XI, Det : Float; + +begin + if Ub - Lb < Deg then + begin + SetErrCode(MatErrDim); + Exit; + end; + + { Initialize } + for I := 0 to Deg do + begin + for J := 0 to Deg do + V^[I]^[J] := 0.0; + B^[I] := 0.0; + end; + + V^[0]^[0] := Ub - Lb + 1; + + for K := Lb to Ub do + begin + XI := X^[K]; { x^i } + B^[0] := B^[0] + Y^[K]; + V^[0]^[1] := V^[0]^[1] + XI; + B^[1] := B^[1] + XI * Y^[K]; + + for I := 2 to Deg do + begin + XI := XI * X^[K]; + V^[0]^[I] := V^[0]^[I] + XI; { First line of matrix: 1 --> x^d } + B^[I] := B^[I] + XI * Y^[K]; { Constant vector: y --> x^d.y } + end; + + for I := 1 to Deg do + begin + XI := XI * X^[K]; + V^[I]^[Deg] := V^[I]^[Deg] + XI; { Last col. of matrix: x^d --> x^2d } + end; + end; + + { Fill lower matrix } + D1 := Deg - 1; + for I := 1 to Deg do + begin + I1 := I - 1; + for J := 0 to D1 do + V^[I]^[J] := V^[I1]^[J + 1]; + end; + + { Solve system } + LinEq(V, B, 0, Deg, Det); +end; + +procedure WPolFit(X, Y, S : PVector; + Lb, Ub, Deg : Integer; + B : PVector; + V : PMatrix); +var + I, I1, J, K, D1 : Integer; + W, WXI, Det : Float; + +begin + if Ub - Lb < Deg then + begin + SetErrCode(MatErrDim); + Exit; + end; + + { Initialize } + for I := 0 to Deg do + begin + for J := 0 to Deg do + V^[I]^[J] := 0.0; + B^[I] := 0.0; + end; + + for K := Lb to Ub do + begin + if S^[K] <= 0.0 then + begin + SetErrCode(MatSing); + Exit; + end; + + W := 1.0 / Sqr(S^[K]); + WXI := W * X^[K]; { w.x^i } + V^[0]^[0] := V^[0]^[0] + W; + B^[0] := B^[0] + W * Y^[K]; + V^[0]^[1] := V^[0]^[1] + WXI; + B^[1] := B^[1] + WXI * Y^[K]; + + for I := 2 to Deg do + begin + WXI := WXI * X^[K]; + V^[0]^[I] := V^[0]^[I] + WXI; { First line of matrix: w --> w.x^d } + B^[I] := B^[I] + WXI * Y^[K]; { Constant vector: w.y --> w.x^d.y } + end; + + for I := 1 to Deg do + begin + WXI := WXI * X^[K]; + V^[I]^[Deg] := V^[I]^[Deg] + WXI; { Last col. of matrix: w.x^d --> w.x^2d } + end; + end; + + { Fill lower matrix } + D1 := Deg - 1; + for I := 1 to Deg do + begin + I1 := I - 1; + for J := 0 to D1 do + V^[I]^[J] := V^[I1]^[J + 1]; + end; + + { Solve system } + LinEq(V, B, 0, Deg, Det); +end; + +end. diff --git a/fpmath/upolutil.pas b/fpmath/upolutil.pas new file mode 100755 index 0000000..a43f8b6 --- /dev/null +++ b/fpmath/upolutil.pas @@ -0,0 +1,122 @@ +{ ****************************************************************** + Utility functions to handle roots of polynomials + ****************************************************************** } + +unit upolutil; + +interface + +uses + utypes, uminmax; + +function SetRealRoots(Deg : Integer; Z : PCompVector; Tol : Float) : Integer; +{ ------------------------------------------------------------------ + Set the imaginary part of a root to zero if it is less than a + fraction Tol of its real part. This root is therefore considered + real. The function returns the total number of real roots. + ------------------------------------------------------------------ } + +procedure SortRoots(Deg : Integer; Z : PCompVector); +{ ------------------------------------------------------------------ + Sort roots so that: + + (1) The Nr real roots are stored in elements [1..Nr] of vector Z, + in increasing order. + + (2) The complex roots are stored in elements [(Nr + 1)..Deg] of + vector Z and are unordered. + ------------------------------------------------------------------ } + +implementation + +function SetRealRoots(Deg : Integer; Z : PCompVector; Tol : Float) : Integer; +var + I, N : Integer; +begin + for I := 1 to Deg do + if (Z^[I].Y <> 0.0) and (Abs(Z^[I].Y) < Tol * Abs(Z^[I].X)) then + Z^[I].Y := 0.0; + + { Count real roots } + N := 0; + for I := 1 to Deg do + if Z^[I].Y = 0.0 then + Inc(N); + + SetRealRoots := N; +end; + +procedure SortRoots(Deg : Integer; Z : PCompVector); +var + I, J, K, Nr, Nc : Integer; + R, X, Y : PVector; + + procedure Sort(X : PVector; N : Integer); + { Sort vector X (insertion sort) } + var + I, J, K : Integer; + A : Float; + begin + for I := 1 to Pred(N) do + begin + K := I; + A := X^[I]; + for J := Succ(I) to N do + if X^[J] < A then + begin + K := J; + A := X^[J]; + end; + FSwap(X^[I], X^[K]); + end; + end; + +begin + { Count real and complex roots } + Nr := 0; Nc := 0; + for I := 1 to Deg do + if Z^[I].Y = 0.0 then Inc(Nr) else Inc(Nc); + + DimVector(R, Nr); + DimVector(X, Nc); + DimVector(Y, Nc); + + { Store real roots in R and complex roots in (X,Y) } + J := 0; K := 0; + for I := 1 to Deg do + if Z^[I].Y = 0.0 then + begin + Inc(J); + R^[J] := Z^[I].X; + end + else + begin + Inc(K); + X^[K] := Z^[I].X; + Y^[K] := Z^[I].Y; + end; + + { Sort vector R (insertion sort) } + if Nr > 0 then Sort(R, Nr); + + { Transfer real roots into elements 1..Nr } + for I := 1 to Nr do + begin + Z^[I].X := R^[I]; + Z^[I].Y := 0.0; + end; + + { Transfer complex roots into elements (Nr+1)..Deg } + for I := 1 to Nc do + begin + J := I + Nr; + Z^[J].X := X^[I]; + Z^[J].Y := Y^[I]; + end; + + DelVector(R, Nr); + DelVector(X, Nc); + DelVector(Y, Nc); +end; + +end. diff --git a/fpmath/upolynom.pas b/fpmath/upolynom.pas new file mode 100755 index 0000000..afad3e7 --- /dev/null +++ b/fpmath/upolynom.pas @@ -0,0 +1,55 @@ +{ ****************************************************************** + Polynomials and rational fractions + ****************************************************************** } + +unit upolynom; + +interface + +uses + utypes; + +function Poly(X : Float; Coef : PVector; Deg : Integer) : Float; +{ ------------------------------------------------------------------ + Evaluates the polynomial : + P(X) = Coef[0] + Coef[1] * X + Coef[2] * X^2 + ... + + Coef[Deg] * X^Deg + ------------------------------------------------------------------ } + +function RFrac(X : Float; Coef : PVector; Deg1, Deg2 : Integer) : Float; +{ ------------------------------------------------------------------ + Evaluates the rational fraction : + + Coef[0] + Coef[1] * X + ... + Coef[Deg1] * X^Deg1 + F(X) = ----------------------------------------------------- + 1 + Coef[Deg1+1] * X + ... + Coef[Deg1+Deg2] * X^Deg2 + ------------------------------------------------------------------ } + +implementation + +function Poly(X : Float; Coef : PVector; Deg : Integer) : Float; +var + I : Integer; + P : Float; +begin + P := Coef^[Deg]; + for I := Pred(Deg) downto 0 do + P := P * X + Coef^[I]; + Poly := P; +end; + +function RFrac(X : Float; Coef : PVector; Deg1, Deg2 : Integer) : Float; +var + I : Integer; + P, Q : Float; +begin + P := Coef^[Deg1]; + for I := Pred(Deg1) downto 0 do + P := P * X + Coef^[I]; + Q := 0.0; + for I := (Deg1 + Deg2) downto Succ(Deg1) do + Q := (Q + Coef^[I]) * X; + RFrac := P / (1.0 + Q); +end; + +end. diff --git a/fpmath/uqr.pas b/fpmath/uqr.pas new file mode 100755 index 0000000..3af7ef9 --- /dev/null +++ b/fpmath/uqr.pas @@ -0,0 +1,134 @@ +{ ****************************************************************** + QR decomposition + + Ref.: 'Matrix Computations' by Golub & Van Loan + Pascal implementation contributed by Mark Vaughan + ****************************************************************** } + +unit uqr; + +interface + +uses + utypes; + +procedure QR_Decomp(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + R : PMatrix); +{ ------------------------------------------------------------------ + QR decomposition. Factors the matrix A (n x m, with n >= m) as a + product Q * R where Q is a (n x m) column-orthogonal matrix, and R + a (m x m) upper triangular matrix. This routine is used in + conjunction with QR_Solve to solve a system of equations. + ------------------------------------------------------------------ + Input parameters : A = matrix + Lb = index of first matrix element + Ub1 = index of last matrix element in 1st dim. + Ub2 = index of last matrix element in 2nd dim. + ------------------------------------------------------------------ + Output parameter : A = contains the elements of Q + R = upper triangular matrix + ------------------------------------------------------------------ + Possible results : MatOk + MatErrDim + MatSing + ------------------------------------------------------------------ + NB : This procedure destroys the original matrix A + ------------------------------------------------------------------ } + +procedure QR_Solve(Q, R : PMatrix; + B : PVector; + Lb, Ub1, Ub2 : Integer; + X : PVector); +{ ------------------------------------------------------------------ + Solves a system of equations by the QR decomposition, + after the matrix has been transformed by QR_Decomp. + ------------------------------------------------------------------ + Input parameters : Q, R = matrices from QR_Decomp + B = constant vector + Lb, Ub1, Ub2 = as in QR_Decomp + ------------------------------------------------------------------ + Output parameter : X = solution vector + ------------------------------------------------------------------ } + +implementation + +procedure QR_Decomp(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + R : PMatrix); + var + I, J, K : Integer; + Sum : Float; + begin + if Ub2 > Ub1 then + begin + SetErrCode(MatErrDim); + Exit + end; + + for K := Lb to Ub2 do + begin + { Compute the "k"th diagonal entry in R } + Sum := 0.0; + for I := Lb to Ub1 do + Sum := Sum + Sqr(A^[I]^[K]); + + if Sum = 0.0 then + begin + SetErrCode(MatSing); + Exit; + end; + + R^[K]^[K] := Sqrt(Sum); + + { Divide the entries in the "k"th column of A by the computed "k"th } + { diagonal element of R. this begins the process of overwriting A } + { with Q . . . } + for I := Lb to Ub1 do + A^[I]^[K] := A^[I]^[K] / R^[K]^[K]; + + for J := (K + 1) to Ub2 do + begin + { Complete the remainder of the row entries in R } + Sum := 0.0; + for I := Lb to Ub1 do + Sum := Sum + A^[I]^[K] * A^[I]^[J]; + R^[K]^[J] := Sum; + + { Update the column entries of the Q/A matrix } + for I := Lb to Ub1 do + A^[I]^[J] := A^[I]^[J] - A^[I]^[K] * R^[K]^[J]; + end; + end; + + SetErrCode(MatOk); + end; + +procedure QR_Solve(Q, R : PMatrix; + B : PVector; + Lb, Ub1, Ub2 : Integer; + X : PVector); + var + I, J : Integer; + Sum : Float; + begin + { Form Q'B and store the result in X } + for J := Lb to Ub2 do + begin + X^[J] := 0.0; + for I := Lb to Ub1 do + X^[J] := X^[J] + Q^[I]^[J] * B^[I]; + end; + + { Update X with the solution vector } + X^[Ub2] := X^[Ub2] / R^[Ub2]^[Ub2]; + for I := (Ub2 - 1) downto Lb do + begin + Sum := 0.0; + for J := (I + 1) to Ub2 do + Sum := Sum + R^[I]^[J] * X^[J]; + X^[I] := (X^[I] - Sum) / R^[I]^[I]; + end; + end; + +end. \ No newline at end of file diff --git a/fpmath/uqsort.pas b/fpmath/uqsort.pas new file mode 100755 index 0000000..1a810e0 --- /dev/null +++ b/fpmath/uqsort.pas @@ -0,0 +1,81 @@ +{ ****************************************************************** + Quick sort + ****************************************************************** } + +unit uqsort; + +interface + +uses + utypes; + +procedure QSort(X : PVector; Lb, Ub : Integer); +{ ------------------------------------------------------------------ + Sorts the elements of vector X in increasing order (quick sort) + ------------------------------------------------------------------ } + +procedure DQSort(X : PVector; Lb, Ub : Integer); +{ ------------------------------------------------------------------ + Sorts the elements of vector X in decreasing order (quick sort) + ------------------------------------------------------------------ } + +implementation + +procedure QSort(X : PVector; Lb, Ub : Integer); +{ Quick sort in ascending order - Adapted from Borland's BP7 demo } + + procedure Sort(L, R : Integer); + var + I, J : Integer; + U, V : Float; + begin + I := L; + J := R; + U := X^[(L + R) div 2]; + repeat + while X^[I] < U do I := I + 1; + while U < X^[J] do J := J - 1; + if I <= J then + begin + V := X^[I]; X^[I] := X^[J]; X^[J] := V; + I := I + 1; J := J - 1; + end; + until I > J; + if L < J then Sort(L, J); + if I < R then Sort(I, R); + end; + +begin + Sort(Lb, Ub); +end; + +procedure DQSort(X : PVector; Lb, Ub : Integer); +{ Quick sort in descending order - Adapted from Borland's BP7 demo } + + procedure Sort(L, R : Integer); + var + I, J : Integer; + U, V : Float; + begin + I := L; + J := R; + U := X^[(L + R) div 2]; + repeat + while X^[I] > U do I := I + 1; + while U > X^[J] do J := J - 1; + if I <= J then + begin + V := X^[I]; X^[I] := X^[J]; X^[J] := V; + I := I + 1; J := J - 1; + end; + until I > J; + if L < J then Sort(L, J); + if I < R then Sort(I, R); + end; + +begin + Sort(Lb, Ub); +end; + +end. + diff --git a/fpmath/urandom.pas b/fpmath/urandom.pas new file mode 100755 index 0000000..c48445f --- /dev/null +++ b/fpmath/urandom.pas @@ -0,0 +1,113 @@ +{ ****************************************************************** + Random number generators + ****************************************************************** } + +unit urandom; + +interface + +uses + utypes, uranmwc, uranmt, uranuvag; + +procedure SetRNG(RNG : RNG_Type); +{ Select generator and set default initialization } + +procedure InitGen(Seed : LongInt); +{ Initialize generator } + +function IRanGen : LongInt; +{ 32-bit random integer in [-2^31 .. 2^31 - 1] } + +function IRanGen31 : LongInt; +{ 31-bit random integer in [0 .. 2^31 - 1] } + +function RanGen1 : Float; +{ 32-bit random real in [0,1] } + +function RanGen2 : Float; +{ 32-bit random real in [0,1) } + +function RanGen3 : Float; +{ 32-bit random real in (0,1) } + +function RanGen53 : Float; +{ 53-bit random real in [0,1) } + +implementation + +const + Z = 1.0 / 4294967296.0; { 1 / 2^32 } + Z1 = 1.0 / 4294967295.0; { 1 / (2^32 - 1) } + Z2 = 1.0 / 9007199254740992.0; + +var + gRNG : RNG_Type; + +procedure SetRNG(RNG : RNG_Type); +var + InitMT : MTKeyArray; +begin + gRNG := RNG; + case gRNG of + RNG_MWC : InitMWC(118105245); + RNG_MT : begin + InitMT[0] := $123; + InitMT[1] := $234; + InitMT[2] := $345; + InitMT[3] := $456; + InitMTbyArray(InitMT, 4); + end; + RNG_UVAG : InitUVAGbyString('abcd'); + end; +end; + +procedure InitGen(Seed : LongInt); +begin + case gRNG of + RNG_MWC : InitMWC(Seed); + RNG_MT : InitMT(Seed); + RNG_UVAG : InitUVAG(Seed); + end; +end; + +function IRanGen : LongInt; +begin + case gRNG of + RNG_MWC : IRanGen := IRanMWC; + RNG_MT : IRanGen := IRanMT; + RNG_UVAG : IRanGen := IRanUVAG; + end; +end; + +function IRanGen31 : LongInt; +begin + IRanGen31 := IRanGen shr 1; +end; + +function RanGen1 : Float; +begin + RanGen1 := (IRanGen + 2147483648.0) * Z1 +end; + +function RanGen2 : Float; +begin + RanGen2 := (IRanGen + 2147483648.0) * Z +end; + +function RanGen3 : Float; +begin + RanGen3 := (IRanGen + 2147483648.5) * Z +end; + +function RanGen53 : Float; +var + A, B : LongInt; +begin + A := IRanGen shr 5; + B := IRanGen shr 6; + + RanGen53 := (A * 67108864.0 + B) * Z2; +end; + +end. + \ No newline at end of file diff --git a/fpmath/urangaus.pas b/fpmath/urangaus.pas new file mode 100755 index 0000000..f4b44b4 --- /dev/null +++ b/fpmath/urangaus.pas @@ -0,0 +1,51 @@ +{ ****************************************************************** + Gaussian random numbers + ****************************************************************** } + +unit urangaus; + +interface + +uses + utypes, urandom; + +function RanGaussStd : Float; +{ ------------------------------------------------------------------ + Computes 2 random numbers from the standard normal distribution, + returns one and saves the other for the next call + ------------------------------------------------------------------ } + +function RanGauss(Mu, Sigma : Float) : Float; +{ ------------------------------------------------------------------ + Returns a random number from a Gaussian distribution + with mean Mu and standard deviation Sigma + ------------------------------------------------------------------ } + +implementation + +const + GaussSave : Float = 0.0; { Saves a Gaussian number } + GaussNew : Boolean = True; { Flags a new calculation } + +function RanGaussStd : Float; +var + R, Theta : Float; +begin + if GaussNew then + begin + R := Sqrt(-2.0 * Ln(RanGen3)); + Theta := TwoPi * RanGen3; + RanGaussStd := R * Cos(Theta); { Return 1st number } + GaussSave := R * Sin(Theta); { Save 2nd number } + end + else + RanGaussStd := GaussSave; { Return saved number } + GaussNew := not GaussNew; +end; + +function RanGauss(Mu, Sigma : Float) : Float; +begin + RanGauss := Mu + Sigma * RanGaussStd; +end; + +end. \ No newline at end of file diff --git a/fpmath/uranmt.pas b/fpmath/uranmt.pas new file mode 100755 index 0000000..e23d799 --- /dev/null +++ b/fpmath/uranmt.pas @@ -0,0 +1,179 @@ +{ ****************************************************************** + Mersenne Twister Random Number Generator + ****************************************************************** + + A C-program for MT19937, with initialization improved 2002/1/26. + Coded by Takuji Nishimura and Makoto Matsumoto. + + Adapted for TPMath by Jean Debord - Feb. 2007 + + Before using, initialize the state by using init_genrand(seed) + or init_by_array(init_key, key_length) (respectively InitMT and + InitMTbyArray in the TPMath version) + + Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. The names of its contributors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR + CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + Any feedback is very welcome. + http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html + email: m-mat @ math.sci.hiroshima-u.ac.jp (remove space) + ****************************************************************** } + +unit uranmt; + +interface + +type + MTKeyArray = array[0..623] of LongInt; + +procedure InitMT(Seed : LongInt); +{ Initializes MT generator with a seed } + +procedure InitMTbyArray(InitKey : MTKeyArray; KeyLength : Word); +{ Initialize MT generator with an array InitKey[0..(KeyLength - 1)] } + +function IRanMT : LongInt; +{ Generates a Random number on [-2^31 .. 2^31 - 1] interval } + +implementation + +const + N = 624; + M = 397; + MATRIX_A = $9908b0df; { constant vector a } + UPPER_MASK = $80000000; { most significant w-r bits } + LOWER_MASK = $7fffffff; { least significant r bits } + + mag01 : array[0..1] of LongInt = (0, MATRIX_A); + +var + mt : MTKeyArray; { the array for the state vector } + mti : Word; { mti == N+1 means mt[N] is not initialized } + +procedure InitMT(Seed : LongInt); +var + i : Word; +begin + mt[0] := Seed and $ffffffff; + for i := 1 to N-1 do + begin + mt[i] := (1812433253 * (mt[i-1] Xor (mt[i-1] shr 30)) + i); + { See Knuth TAOCP Vol2. 3rd Ed. P.106 For multiplier. + In the previous versions, MSBs of the seed affect + only MSBs of the array mt[]. + 2002/01/09 modified by Makoto Matsumoto } + mt[i] := mt[i] and $ffffffff; + { For >32 Bit machines } + end; + mti := N; +end; + +procedure InitMTbyArray(InitKey : MTKeyArray; KeyLength : Word); +var + i, j, k, k1 : Word; +begin + InitMT(19650218); + + i := 1; + j := 0; + + if N > KeyLength then k1 := N else k1 := KeyLength; + + for k := k1 downto 1 do + begin + mt[i] := (mt[i] Xor ((mt[i-1] Xor (mt[i-1] shr 30)) * 1664525)) + InitKey[j] + j; { non linear } + mt[i] := mt[i] and $ffffffff; { for WORDSIZE > 32 machines } + i := i + 1; + j := j + 1; + if i >= N then + begin + mt[0] := mt[N-1]; + i := 1; + end; + if j >= KeyLength then j := 0; + end; + + for k := N-1 downto 1 do + begin + mt[i] := (mt[i] Xor ((mt[i-1] Xor (mt[i-1] shr 30)) * 1566083941)) - i; { non linear } + mt[i] := mt[i] and $ffffffff; { for WORDSIZE > 32 machines } + i := i + 1; + if i >= N then + begin + mt[0] := mt[N-1]; + i := 1; + end; + end; + + mt[0] := $80000000; { MSB is 1; assuring non-zero initial array } +end; + +function IRanMT : LongInt; +var + y : LongInt; + k : Word; +begin + if mti >= N then { generate N words at one Time } + begin + { If IRanMT() has not been called, a default initial seed is used } + if mti = N + 1 then InitMT(5489); + + for k := 0 to (N-M)-1 do + begin + y := (mt[k] and UPPER_MASK) or (mt[k+1] and LOWER_MASK); + mt[k] := mt[k+M] xor (y shr 1) xor mag01[y and $1]; + end; + + for k := (N-M) to (N-2) do + begin + y := (mt[k] and UPPER_MASK) or (mt[k+1] and LOWER_MASK); + mt[k] := mt[k - (N - M)] xor (y shr 1) xor mag01[y and $1]; + end; + + y := (mt[N-1] and UPPER_MASK) or (mt[0] and LOWER_MASK); + mt[N-1] := mt[M-1] xor (y shr 1) xor mag01[y and $1]; + + mti := 0; + end; + + y := mt[mti]; + mti := mti + 1; + + { Tempering } + y := y xor (y shr 11); + y := y xor ((y shl 7) and $9d2c5680); + y := y xor ((y shl 15) and $efc60000); + y := y xor (y shr 18); + + IRanMT := y +end; + +end. + \ No newline at end of file diff --git a/fpmath/uranmult.pas b/fpmath/uranmult.pas new file mode 100755 index 0000000..06794c6 --- /dev/null +++ b/fpmath/uranmult.pas @@ -0,0 +1,67 @@ +{ ****************************************************************** + Multinormal distribution + ****************************************************************** } + +unit uranmult; + +interface + +uses + utypes, urangaus; + +procedure RanMult(M : PVector; + L : PMatrix; + Lb, Ub : Integer; + X : PVector); +{ ------------------------------------------------------------------ + Generates a random vector X from a multinormal distribution. + M is the mean vector, L is the Cholesky factor (lower triangular) + of the variance-covariance matrix. + ------------------------------------------------------------------ } + +procedure RanMultIndep(M, S : PVector; + Lb, Ub : Integer; + X : PVector); +{ ------------------------------------------------------------------ + Generates a random vector X from a multinormal distribution with + uncorrelated variables. M is the mean vector, S is the vector + of standard deviations. + ------------------------------------------------------------------ } + +implementation + +procedure RanMult(M : PVector; + L : PMatrix; + Lb, Ub : Integer; + X : PVector); +var + I, J : Integer; + U : PVector; +begin + { Form a vector U of independent standard normal variates } + DimVector(U, Ub); + for I := Lb to Ub do + U^[I] := RanGaussStd; + + { Form X = M + L * U, which follows the multinormal distribution } + for I := Lb to Ub do + begin + X^[I] := M^[I]; + for J := Lb to I do + X^[I] := X^[I] + L^[I]^[J] * U^[J] + end; + + DelVector(U, Ub); +end; + +procedure RanMultIndep(M, S : PVector; + Lb, Ub : Integer; + X : PVector); +var + I : Integer; +begin + for I := Lb to Ub do + X^[I] := RanGauss(M^[I], S^[I]) +end; + +end. diff --git a/fpmath/uranmwc.pas b/fpmath/uranmwc.pas new file mode 100755 index 0000000..98e13c0 --- /dev/null +++ b/fpmath/uranmwc.pas @@ -0,0 +1,47 @@ +{ ****************************************************************** + Marsaglia's Multiply-With-Carry random number generator + ****************************************************************** } + +unit uranmwc; + +interface + +procedure InitMWC(Seed : LongInt); +{ ------------------------------------------------------------------ + Initializes the 'Multiply with carry' random number generator. + ------------------------------------------------------------------ } + +function IRanMWC : LongInt; +{ ------------------------------------------------------------------ + Returns a 32 bit random number in [-2^31 ; 2^31-1] + ------------------------------------------------------------------ } + +implementation + +var + X1, X2 : LongInt; { Uniform random integers } + C1, C2 : LongInt; { Carries } + +procedure InitMWC(Seed : LongInt); +begin + X1 := Seed shr 16; + X2 := Seed and 65535; + C1 := 0; + C2 := 0; +end; + +function IRanMWC : LongInt; +var + Y1, Y2 : LongInt; +begin + Y1 := 18000 * X1 + C1; + X1 := Y1 and 65535; + C1 := Y1 shr 16; + Y2 := 30903 * X2 + C2; + X2 := Y2 and 65535; + C2 := Y2 shr 16; + IRanMWC := (X1 shl 16) + (X2 and 65535); +end; + +end. + diff --git a/fpmath/uranuvag.pas b/fpmath/uranuvag.pas new file mode 100755 index 0000000..b62ff38 --- /dev/null +++ b/fpmath/uranuvag.pas @@ -0,0 +1,100 @@ +{ ****************************************************************** + UVAG The Universal Virtual Array Generator + by Alex Hay zenjew@hotmail.com + Adapted to TPMath by Jean Debord + ****************************************************************** + In practice, Cardinal (6-7 times the output of Word) is the + IntType of choice, but to demonstrate UVAG's scalability here, + IntType can be defined as any integer data type. IRanUVAG globally + provides (as rndint) an effectively infinite sequence of IntTypes, + uniformly distributed (0, 2^(8*sizeof(IntType))-1). Output (bps) + is dependent solely on IntSize=sizeof(IntType) and CPU speed. UVAG + cycles at twice the speed of the 64-bit Mersenne Twister in a tenth + the memory, tests well in DIEHARD, ENT and NIST and has a huge period. + It is suitable for cryptographic purposes in that state(n) is not + determinable from state(n+1). Most attractive is that it uses integers + of any size and requires an array of only 255 + sizeof(IntType) bytes. + Thus it is easily adapted to 128 bits and beyond with negligible + memory increase. Lastly, seeding is easy. From near zero entropy + (s[]=0, rndint > 0), UVAG bootstraps itself to full entropy in under + 300 cycles. Very robust, no bad seeds. + ****************************************************************** } + +unit uranuvag; + +interface + +type + IntType = LongInt; + +procedure InitUVAGbyString(KeyPhrase : string); +{ Initializes the generator with a string } + +procedure InitUVAG(Seed : IntType); +{ Initializes the generator with an integer } + +function IRanUVAG : IntType; +{ Returns a 32-bit random integer } + +implementation + +const + IntSize = SizeOf(IntType); + +type + TByteArray = array[0..(255 + IntSize)] of Byte; + +var + s : TByteArray; + sp : ^IntType; { Pointer to random IntType somewhere in s } + sindex : Byte; + rndint : IntType; + +procedure InitUVAGbyString(KeyPhrase : string); +var + i, kindex, lk : Word; + temp, tot : Byte; +begin + lk := Length(KeyPhrase); + kindex := 1; + tot := 0; + + { Initialize array } + for i := 0 to 255 do + s[i] := i; + for i := 256 to (255 + IntSize) do + s[i] := i - 256; + + { Shuffle array on keyphrase } + for i := 0 to (255 + IntSize) do + begin + tot := tot + Ord(KeyPhrase[kindex]); + temp := s[i]; + s[i] := s[tot]; + s[tot] := temp; + kindex := kindex + 1; + if kindex > lk then kindex := 1; { wrap around key } + end; + + sindex := s[0]; + rndint := 0 +end; + +procedure InitUVAG(Seed : IntType); +var + S : string; +begin + Str(Seed, S); + InitUVAGbyString(S); +end; + +function IRanUVAG : IntType; +begin + sindex := sindex + 1; + sp := @s[s[sindex]]; + sp^ := sp^ + rndint; + rndint := rndint + sp^; + IRanUVAG := rndint +end; + +end. diff --git a/fpmath/uregtest.o b/fpmath/uregtest.o new file mode 100644 index 0000000..8de0603 Binary files /dev/null and b/fpmath/uregtest.o differ diff --git a/fpmath/uregtest.pas b/fpmath/uregtest.pas new file mode 100755 index 0000000..bef1216 --- /dev/null +++ b/fpmath/uregtest.pas @@ -0,0 +1,199 @@ +{ ****************************************************************** + Test of regression + ****************************************************************** } + +unit uregtest; + +interface + +uses + utypes, umeansd; + +procedure RegTest(Y, Ycalc : PVector; + LbY, UbY : Integer; + V : PMatrix; + LbV, UbV : Integer; + var Test : TRegTest); +{ ------------------------------------------------------------------ + Test of unweighted regression + ------------------------------------------------------------------ + Input parameters: Y, Ycalc = observed and calculated Y values + LbY, UbY = bounds of Y and Ycalc + V = inverse matrix + LbV, UbV = bounds of V + Output parameters: V = variance-covariance matrix + Test = test results + ------------------------------------------------------------------ } + +procedure WRegTest(Y, Ycalc, S : PVector; + LbY, UbY : Integer; + V : PMatrix; + LbV, UbV : Integer; + var Test : TRegTest); +{ ------------------------------------------------------------------ + Test of weighted regression + ------------------------------------------------------------------ + Additional input parameter: + S = standard deviations of observations + ------------------------------------------------------------------ } + +implementation + +procedure RegTest(Y, Ycalc : PVector; + LbY, UbY : Integer; + V : PMatrix; + LbV, UbV : Integer; + var Test : TRegTest); + + var + Ybar : Float; { Average Y value } + D : Float; { Difference } + SSt : Float; { Total sum of squares } + SSe : Float; { Explained sum of squares } + SSr : Float; { Residual sum of squares } + Nobs : Integer; { Number of observations } + Npar : Integer; { Number of fitted parameters } + I, J, K : Integer; { Loop variables } + + begin + Nobs := UbY - LbY + 1; + Npar := UbV - LbV + 1; + + if Nobs <= Npar then + begin + SetErrCode(MatSing); + Exit; + end; + + SetErrCode(MatOk); + + Ybar := Mean(Y, LbY, UbY); + + SSt := 0.0; + SSe := 0.0; + SSr := 0.0; + + for K := LbY to UbY do + begin + D := Y^[K] - Ybar; + SSt := SSt + Sqr(D); + D := Ycalc^[K] - Ybar; + SSe := SSe + Sqr(D); + D := Y^[K] - Ycalc^[K]; + SSr := SSr + Sqr(D); + end; + + with Test do + begin + Nu1 := Npar - 1; + Nu2 := Nobs - Npar; + R2 := SSe / SSt; + R2a := 1.0 - (1.0 - R2) * (Nobs - 1) / Nu2; + Vr := SSr / Nu2; + + if Vr = 0.0 then + F := MaxNum + else + F := (SSe / Nu1) / Vr; + end; + + { Compute variance-covariance matrix } + for I := LbV to UbV do + for J := I to UbV do + V^[I]^[J] := V^[I]^[J] * Test.Vr; + for I := Succ(LbV) to UbV do + for J := LbV to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + end; + +procedure WRegTest(Y, Ycalc, S : PVector; + LbY, UbY : Integer; + V : PMatrix; + LbV, UbV : Integer; + var Test : TRegTest); + + var + Ybar : Float; { Average Y value } + D : Float; { Difference } + SW, SWY : Float; { Statistical sums } + SSt : Float; { Total sum of squares } + SSe : Float; { Explained sum of squares } + SSr : Float; { Residual sum of squares } + Nobs : Integer; { Number of observations } + Npar : Integer; { Number of fitted parameters } + I, J, K : Integer; { Loop variables } + W : PVector; { Weights } + + begin + Nobs := UbY - LbY + 1; + Npar := UbV - LbV + 1; + + if Nobs <= Npar then + begin + SetErrCode(MatSing); + Exit; + end; + + DimVector(W, UbY); + + SW := 0.0; + SWY := 0.0; + + for K := LbY to UbY do + begin + if S^[K] <= 0.0 then + begin + SetErrCode(MatSing); + DelVector(W, UbY); + Exit; + end; + + W^[K] := 1.0 / Sqr(S^[K]); + + SW := SW + W^[K]; + SWY := SWY + W^[K] * Y^[K]; + end; + + Ybar := SWY / SW; + + SetErrCode(MatOk); + + SSt := 0.0; + SSe := 0.0; + SSr := 0.0; + + for K := LbY to UbY do + begin + D := Y^[K] - Ybar; + SSt := SSt + W^[K] * Sqr(D); + D := Ycalc^[K] - Ybar; + SSe := SSe + W^[K] * Sqr(D); + D := Y^[K] - Ycalc^[K]; + SSr := SSr + W^[K] * Sqr(D); + end; + + with Test do + begin + Nu1 := Npar - 1; + Nu2 := Nobs - Npar; + R2 := SSe / SSt; + R2a := 1.0 - (1.0 - R2) * (Nobs - 1) / Nu2; + Vr := SSr / Nu2; + + if Vr = 0.0 then + F := MaxNum + else + F := (SSe / Nu1) / Vr; + end; + + { Compute variance-covariance matrix } + for I := LbV to UbV do + for J := I to UbV do + V^[I]^[J] := V^[I]^[J] * Test.Vr; + for I := Succ(LbV) to UbV do + for J := LbV to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + end; + +end. + diff --git a/fpmath/uregtest.ppu b/fpmath/uregtest.ppu new file mode 100644 index 0000000..cf5cbd7 Binary files /dev/null and b/fpmath/uregtest.ppu differ diff --git a/fpmath/urkf.pas b/fpmath/urkf.pas new file mode 100755 index 0000000..61841f5 --- /dev/null +++ b/fpmath/urkf.pas @@ -0,0 +1,723 @@ +{ ****************************************************************** + Numerical integration of a system of differential equations + by the Runge-Kutta-Fehlberg (RKF) method. + + Adapted from a Fortran-90 program available at: + http://www.csit.fsu.edu/~burkardt/f_src/rkf45/rkf45.f90 + ****************************************************************** } + +unit urkf; + +interface + +uses + utypes, uminmax; + +procedure RKF45(F : TDiffEqs; + Neqn : Integer; + Y, Yp : PVector; + var T : Float; + Tout, RelErr, AbsErr : Float; + var Flag : Integer); + +implementation + +const + maxeqn : Integer = 0; + flag_save : Integer = -1000; + init : Integer = -1000; + kflag : Integer = -1000; + kop : Integer = -1; + nfe : Integer = -1; + relerr_save : Float = -1.0; + abserr_save : Float = -1.0; + h : Float = -1.0; + f1 : PVector = nil; + f2 : PVector = nil; + f3 : PVector = nil; + f4 : PVector = nil; + f5 : PVector = nil; + +procedure Fehl(F : TDiffEqs; + Neqn : Integer; + Y : PVector; + T, H : Float; + Yp, F1, F2, F3, F4, F5, S : PVector); +{ ------------------------------------------------------------------ + + Fehl takes one Fehlberg fourth-fifth order step (double precision). + + Discussion: + + This routine integrates a system of Neqn first order ordinary + differential equations of the form + dY(i)/dT = F(T,Y(1:Neqn)) + where the initial values Y and the initial derivatives + YP are specified at the starting point T. + + The routine advances the solution over the fixed step H and returns + the fifth order (sixth order accurate locally) solution + approximation at T+H in array S. + + The formulas have been grouped to control loss of significance. + The routine should be called with an H not smaller than 13 units of + roundoff in T so that the various independent arguments can be + distinguished. + + Modified: + + 27 March 2004 + + Author: + + H A Watts and L F Shampine, + Sandia Laboratories, + Albuquerque, New Mexico. + + Reference: + + E. Fehlberg, + Low-order Classical Runge-Kutta Formulas with Stepsize Control, + NASA Technical Report R-315. + + L F Shampine, H A Watts, S Davenport, + Solving Non-stiff Ordinary Differential Equations - The State of the Art, + SIAM Review, + Volume 18, pages 376-411, 1976. + + Parameters: + + Input, external F, a user-supplied subroutine to evaluate the + derivatives Y'(T), of the form: + + procedure(X : Float; Y, D : PVector); + + Input, Neqn, the number of equations to be integrated. + + Input, Y(Neqn), the current value of the + dependent variable. + + Input, T, the current value of the independent + variable. + + Input, H, the step size to take. + + Input, YP(Neqn), the current value of the + derivative of the dependent variable. + + Output, F1(Neqn), F2(Neqn), F3(Neqn), F4(Neqn), F5(Neqn), + derivative values needed for the computation. + + Output, S(Neqn), the estimate of the solution at T+H. + ------------------------------------------------------------------ } + +const + C1 = 3.0 / 32.0; + C2 = 3.0 / 8.0; + C3 = 1.0 / 2197.0; + C4 = 12.0 / 13.0; + C5 = 1.0 / 4104.0; + C6 = 1.0 / 20520.0; + C7 = 1.0 / 7618050.0; + +var + ch : Float; + i : Integer; + +begin + ch := 0.25 * h; + + for i := 1 to neqn do + f5^[i] := y^[i] + ch * yp^[i]; + + f(t + ch, f5, f1); + + ch := C1 * h; + + for i := 1 to neqn do + f5^[i] := y^[i] + ch * (yp^[i] + 3.0 * f1^[i]); + + f(t + C2 * h, f5, f2); + + ch := C3 * h; + + for i := 1 to neqn do + f5^[i] := y^[i] + ch * (1932.0 * yp^[i] + + (7296.0 * f2^[i] - 7200.0 * f1^[i])); + + f(t + C4 * h, f5, f3); + + ch := C5 * h; + + for i := 1 to neqn do + f5^[i] := y^[i] + ch * ((8341.0 * yp^[i] - 845.0 * f3^[i]) + + (29440.0 * f2^[i] - 32832.0 * f1^[i])); + + f(t + h, f5, f4); + + ch := C6 * h; + + for i := 1 to neqn do + f1^[i] := y^[i] + ch * ((-6080.0 * yp^[i] + + (9295.0 * f3^[i] - 5643.0 * f4^[i])) + + (41040.0 * f1^[i] - 28352.0 * f2^[i])); + + f(t + 0.5 * h, f1, f5); + +{ Ready to compute the approximate solution at T+H. } + + ch := C7 * h; + + for i := 1 to neqn do + s^[i] := y^[i] + ch * ((902880.0 * yp^[i] + + (3855735.0 * f3^[i] - 1371249.0 * f4^[i])) + + (3953664.0 * f2^[i] + 277020.0 * f5^[i])); + +end; + +procedure ReDim_Arrays(neqn : Integer); +{ Redimensions global arrays if necessary } +begin + DelVector(f1, maxeqn); + DelVector(f2, maxeqn); + DelVector(f3, maxeqn); + DelVector(f4, maxeqn); + DelVector(f5, maxeqn); + + maxeqn := neqn; + + DimVector(f1, maxeqn); + DimVector(f2, maxeqn); + DimVector(f3, maxeqn); + DimVector(f4, maxeqn); + DimVector(f5, maxeqn); +end; + +procedure RKF45(F : TDiffEqs; + Neqn : Integer; + Y, Yp : PVector; + var T : Float; + Tout, RelErr, AbsErr : Float; + var Flag : Integer); +{ ------------------------------------------------------------------ + + RKF45 carries out the Runge-Kutta-Fehlberg method (double precision). + + + Discussion: + + This routine is primarily designed to solve non-stiff and mildly stiff + differential equations when derivative evaluations are inexpensive. + It should generally not be used when the user is demanding + high accuracy. + + This routine integrates a system of Neqn first-order ordinary + differential equations of the form: + + dY(i)/dT = F(T,Y(1),Y(2),...,Y(Neqn)) + + where the Y(1:Neqn) are given at T. + + Typically the subroutine is used to integrate from T to TOUT but it + can be used as a one-step integrator to advance the solution a + single step in the direction of TOUT. On return, the parameters in + the call list are set for continuing the integration. The user has + only to call again (and perhaps define a new value for TOUT). + + Before the first call, the user must + + * supply the subroutine F(T,Y,YP) to evaluate the right hand side; + and declare F in an EXTERNAL statement; + + * initialize the parameters: + Neqn, Y(1:Neqn), T, TOUT, RELERR, ABSERR, FLAG. + In particular, T should initially be the starting point for integration, + Y should be the value of the initial conditions, and FLAG should + normally be +1. + + Normally, the user only sets the value of FLAG before the first call, and + thereafter, the program manages the value. On the first call, FLAG should + normally be +1 (or -1 for single step mode.) On normal return, FLAG will + have been reset by the program to the value of 2 (or -2 in single + step mode), and the user can continue to call the routine with that + value of FLAG. + + (When the input magnitude of FLAG is 1, this indicates to the program + that it is necessary to do some initialization work. An input magnitude + of 2 lets the program know that that initialization can be skipped, + and that useful information was computed earlier.) + + The routine returns with all the information needed to continue + the integration. If the integration reached TOUT, the user need only + define a new TOUT and call again. In the one-step integrator + mode, returning with FLAG = -2, the user must keep in mind that + each step taken is in the direction of the current TOUT. Upon + reaching TOUT, indicated by the output value of FLAG switching to 2, + the user must define a new TOUT and reset FLAG to -2 to continue + in the one-step integrator mode. + + In some cases, an error or difficulty occurs during a call. In that case, + the output value of FLAG is used to indicate that there is a problem + that the user must address. These values include: + + * 3, integration was not completed because the input value of RELERR, the + relative error tolerance, was too small. RELERR has been increased + appropriately for continuing. If the user accepts the output value of + RELERR, then simply reset FLAG to 2 and continue. + + * 4, integration was not completed because more than MAXNFE derivative + evaluations were needed. This is approximately (MAXNFE/6) steps. + The user may continue by simply calling again. The function counter + will be reset to 0, and another MAXNFE function evaluations are allowed. + + * 5, integration was not completed because the solution vanished, + making a pure relative error test impossible. The user must use + a non-zero ABSERR to continue. Using the one-step integration mode + for one step is a good way to proceed. + + * 6, integration was not completed because the requested accuracy + could not be achieved, even using the smallest allowable stepsize. + The user must increase the error tolerances ABSERR or RELERR before + continuing. It is also necessary to reset FLAG to 2 (or -2 when + the one-step integration mode is being used). The occurrence of + FLAG = 6 indicates a trouble spot. The solution is changing + rapidly, or a singularity may be present. It often is inadvisable + to continue. + + * 7, it is likely that this routine is inefficient for solving + this problem. Too much output is restricting the natural stepsize + choice. The user should use the one-step integration mode with + the stepsize determined by the code. If the user insists upon + continuing the integration, reset FLAG to 2 before calling + again. Otherwise, execution will be terminated. + + * 8, invalid input parameters, indicates one of the following: + Neqn <= 0; + T = TOUT and |FLAG| /= 1; + RELERR < 0 or ABSERR < 0; + FLAG == 0 or FLAG < -2 or 8 < FLAG. + + Modified: + + 27 March 2004 + + Author: + + H A Watts and L F Shampine, + Sandia Laboratories, + Albuquerque, New Mexico. + + Reference: + + E. Fehlberg, + Low-order Classical Runge-Kutta Formulas with Stepsize Control, + NASA Technical Report R-315. + + L F Shampine, H A Watts, S Davenport, + Solving Non-stiff Ordinary Differential Equations - The State of the Art, + SIAM Review, + Volume 18, pages 376-411, 1976. + + Parameters: + + Input, external F, a user-supplied subroutine to evaluate the + derivatives Y (T), of the form: + + sub f ( t as double, y() as double, yp() as double ) + + Input, Neqn, the number of equations to be integrated. + + Input/output, Y(Neqn), the current solution vector at T. + + Input/output, YP(Neqn), the current value of the + derivative of the dependent variable. The user should not set or alter + this information + + Input/output, T, the current value of the independent + variable. + + Input, TOUT, the output point at which solution is + desired. TOUT = T is allowed on the first call only, in which case + the routine returns with FLAG = 2 if continuation is possible. + + Input, RELERR, ABSERR, the relative and absolute + error tolerances for the local error test. At each step the code + requires: + abs ( local error ) <= RELERR * abs ( Y ) + ABSERR + for each component of the local error and the solution vector Y. + RELERR cannot be "too small". If the routine believes RELERR has been + set too small, it will reset RELERR to an acceptable value and return + immediately for user action. + + Input/output, FLAG, indicator for status of integration. + On the first call, set FLAG to +1 for normal use, or to -1 for single + step mode. On return, a value of 2 or -2 indicates normal progress, + while any other value indicates a problem that should be addressed. + ------------------------------------------------------------------ } + +const + remin = 1.0E-12; + maxnfe = 3000; + +var + k, mflag : Integer; + ae, dt, ee, eeoet, esttol, et : Float; + hmin, relerr_min, s, scale, tol, toln, ypk : Float; + hfaild, outp : Boolean; + +label + Cont, Done; + +begin +{ Check the input parameters. } + + if (neqn < 1) or (relerr < 0) or (abserr < 0) or + ((flag = 0) or (flag > 8) or (flag < -2)) then + begin + flag := 8; + exit; + end; + + mflag := abs(flag); + +{ Is this a continuation call? } + + if mflag <> 1 then + begin + if (t = tout) and (kflag <> 3) then + begin + flag := 8; + exit; + end; + + if mflag = 2 then + begin + if kflag = 3 then + begin + flag := flag_save; + mflag := abs(flag) + end + else if init = 0 then + flag := flag_save + else if kflag = 4 then + nfe := 0 + else if (kflag = 5) and (abserr = 0) then + exit + else if (kflag = 6) and (relerr <= relerr_save) and (abserr <= abserr_save) then + exit; + end + else { FLAG = 3, 4, 5, 6, 7 or 8. } + begin + if flag = 3 then + begin + flag := flag_save; + if kflag = 3 then mflag := abs(flag) + end + else if flag = 4 then + begin + nfe := 0; + flag := flag_save; + if kflag = 3 then mflag := abs(flag) + end + else if (flag = 5) and (abserr > 0) then + begin + flag := flag_save; + if kflag = 3 then mflag := abs(flag) + end + else { Integration cannot be continued because the user did not } + exit; { respond to the instructions pertaining to FLAG = 5,6,7,8 } + end; + end; + +{ Save the input value of FLAG. } +{ Set the continuation flag KFLAG for subsequent input checking. } + + flag_save := flag; + kflag := 0; + +{ Save RELERR and ABSERR for checking input on subsequent calls. } + + relerr_save := relerr; + abserr_save := abserr; + +{ Restrict the relative error tolerance to be at least + + 2 * EPS + REMIN + + to avoid limiting precision difficulties arising from impossible + accuracy requests. } + + relerr_min := 2 * MachEp + remin; + +{ Is the relative error tolerance too small? } + + if relerr < relerr_min then + begin + relerr := relerr_min; + flag := 3; + kflag := 3; + exit + end; + + dt := tout - t; + +{ Initialization: + + Set the initialization completion indicator, INIT; + set the indicator for too many output points, KOP; + evaluate the initial derivatives; + set the counter for function evaluations, NFE; + estimate the starting stepsize. } + + if mflag = 1 then + begin + init := 0; + kop := 0; + f(t, y, yp); + nfe := 1; + if t = tout then + begin + flag := 2; + exit; + end; + end; + + if init = 0 then + begin + init := 1; + h := abs(dt); + toln := 0; + + for k := 1 to neqn do + begin + tol := relerr * abs (y^[k]) + abserr; + if tol > 0 then + begin + toln := tol; + ypk := abs(yp^[k]); + if tol < ypk * h * h * h * h * h then + h := Exp(0.2 * Ln(tol / ypk)); + end + end; + + if toln <= 0 then h := 0; + + h := FMax(h, 26 * MachEp * FMax(abs(t), abs(dt))); + flag_save := sgn(flag) * 2 + end; + +{ Set the stepsize for integration in the direction from T to TOUT. } + + h := sgn(dt) * abs(h); + +{ Test to see if too may output points are being requested. } + + if 2 * abs(dt) <= abs(h) then kop := kop + 1; + +{ Unnecessary frequency of output. } + + if kop = 100 then + begin + kop := 0; + flag := 7; + exit + end; + +{ If we are too close to the output point, then simply extrapolate and return. } + + if abs(dt) <= 26 * MachEp * abs(t) then + begin + t := tout; + for k := 1 to neqn do + y^[k] := y^[k] + dt * yp^[k]; + f(t, y, yp); + nfe := nfe + 1; + flag := 2; + exit + end; + +{ Initialize the output point indicator. } + + outp := False; + +{ To avoid premature underflow in the error tolerance function, + scale the error tolerances. } + + scale := 2 / relerr; + ae := scale * abserr; + +{ Redimension global arrays if necessary } + + if neqn > maxeqn then ReDim_Arrays(neqn); + +{ Step by step integration. } + + repeat + + hfaild := False; + +{ Set the smallest allowable stepsize. } + + hmin := 26 * MachEp * abs(t); + +{ Adjust the stepsize if necessary to hit the output point. + + Look ahead two steps to avoid drastic changes in the stepsize and + thus lessen the impact of output points on the code. } + + dt := tout - t; + + if 2.0 * abs(h) > abs(dt) then + begin + + { Will the next successful step complete the integration to the output point? } + + if abs(dt) <= abs(h) then + begin + outp := True; + h := dt + end + else + h := 0.5 * dt; + end; + +{ Here begins the core integrator for taking a single step. + + The tolerances have been scaled to avoid premature underflow in + computing the error tolerance function ET. + To avoid problems with zero crossings, relative error is measured + using the average of the magnitudes of the solution at the + beginning and end of a step. + The error estimate formula has been grouped to control loss of + significance. + + To distinguish the various arguments, H is not permitted + to become smaller than 26 units of roundoff in T. + Practical limits on the change in the stepsize are enforced to + smooth the stepsize selection process and to avoid excessive + chattering on problems having discontinuities. + To prevent unnecessary failures, the code uses 9/10 the stepsize + it estimates will succeed. + + After a step failure, the stepsize is not allowed to increase for + the next attempted step. This makes the code more efficient on + problems having discontinuities and more effective in general + since local extrapolation is being used and extra caution seems + warranted. + + Test the number of derivative function evaluations. + If okay, try to advance the integration from T to T+H. } + + repeat + +{ Have we done too much work? } + + if maxnfe < nfe then + begin + flag := 4; + kflag := 4; + exit + end; + +{ Advance an approximate solution over one step of length H. } + + Fehl(f, neqn, y, t, h, yp, f1, f2, f3, f4, f5, f1); + nfe := nfe + 5; + +{ Compute and test allowable tolerances versus local error estimates + and remove scaling of tolerances. The relative error is + measured with respect to the average of the magnitudes of the + solution at the beginning and end of the step. } + + eeoet := 0; + + for k := 1 to neqn do + begin + et := abs(y^[k]) + abs(f1^[k]) + ae; + + if et <= 0 then + begin + flag := 5; + exit + end; + + ee := abs((-2090.0 * yp^[k] + (21970.0 * f3^[k] - 15048.0 * f4^[k])) + + (22528.0 * f2^[k] - 27360.0 * f5^[k])); + + eeoet := FMax(eeoet, ee / et); + end; + + esttol := abs(h) * eeoet * scale / 752400.0; + + if esttol <= 1 then goto Cont; + +{ Unsuccessful step. Reduce the stepsize, try again. + The decrease is limited to a factor of 1/10. } + + hfaild := True; + outp := False; + + if esttol < 59049.0 then + s := 0.9 / Exp(0.2 * Ln(esttol)) + else + s := 0.1; + + h := s * h; + + if abs(h) < hmin then + begin + flag := 6; + kflag := 6; + exit; + end; + + until False; + +{ We exited the loop because we took a successful step. + Store the solution for T+H, and evaluate the derivative there. } + +Cont: + + t := t + h; + for k := 1 to neqn do + y^[k] := f1^[k]; + f(t, y, yp); + nfe := nfe + 1; + +{ Choose the next stepsize. The increase is limited to a factor of 5. + If the step failed, the next stepsize is not allowed to increase. } + + if 0.0001889568 < esttol then + s := 0.9 / Exp(0.2 * Ln(esttol)) + else + s := 5.0; + + if hfaild then s := FMin(s, 1.0); + + h := sgn(h) * FMax(s * abs(h), hmin); + +{ End of core integrator + + Should we take another step? } + + if outp then + begin + t := tout; + flag := 2; + exit + end; + + if flag <= 0 then goto Done; + + until False; + +{ One step integration mode. } + +Done: + + flag := -2; + +end; + +end. + diff --git a/fpmath/urootpol.pas b/fpmath/urootpol.pas new file mode 100755 index 0000000..e6b5098 --- /dev/null +++ b/fpmath/urootpol.pas @@ -0,0 +1,63 @@ +{ ****************************************************************** + Roots of a polynomial from the companion matrix + ****************************************************************** } + +unit urootpol; + +interface + +uses + utypes, ubalance, uhqr; + +function RootPol(Coef : PVector; Deg : Integer; Z : PCompVector) : Integer; +{ ------------------------------------------------------------------ + Solves the polynomial equation: + Coef(0) + Coef(1) * Z + Coef(2) * Z^2 + ... + + Coef(Deg) * Z^Deg = 0 + ------------------------------------------------------------------ } + +implementation + +function RootPol(Coef : PVector; Deg : Integer; Z : PCompVector) : Integer; + +var + Lo, Hi : Integer; { Used by Balance } + I, J : Integer; { Loop variables } + Nr : Integer; { Number of real roots } + A : PMatrix; { Companion matrix } + Scale : PVector; { Used by Balance } + +begin + { Dimension arrays } + DimMatrix(A, Deg, Deg); + DimVector(Scale, Deg); + + { Set up the companion matrix } + for J := 1 to Deg do + A^[1]^[J] := - Coef^[Deg - J] / Coef^[Deg]; + + + for I := 2 to Deg do + for J := 1 to Deg do + if I - 1 = J then A^[I]^[J] := 1.0 else A^[I]^[J] := 0.0; + + { The roots of the polynomial are the + eigenvalues of the companion matrix } + Balance(A, 1, Deg, Lo, Hi, Scale); + Hqr(A, 1, Deg, Lo, Hi, Z); + + if MathErr <> 0 then + begin + RootPol := MathErr; + Exit; + end; + + { Count real roots } + Nr := 0; + for I := 1 to Deg do + if Z^[I].Y = 0.0 then Nr := Nr + 1; + + RootPol := Nr +end; + +end. \ No newline at end of file diff --git a/fpmath/uround.pas b/fpmath/uround.pas new file mode 100755 index 0000000..9906e52 --- /dev/null +++ b/fpmath/uround.pas @@ -0,0 +1,55 @@ +{ ****************************************************************** + Rounding functions + Based on FreeBASIC version contributed by R. Keeling + ****************************************************************** } + +unit uround; + +interface + +uses + utypes, uminmax, umath; + +function RoundN(X : Float; N : Integer) : Float; +{ Rounds X to N decimal places } + +function Ceil(X : Float) : Integer; +{ Ceiling function } + +function Floor(X : Float) : Integer; +{ Floor function } + +implementation + +function RoundN (X : Float; N : Integer) : Float; +const + MaxRoundPlaces = 18; +var + ReturnAnswer, Dec_Place : Float; + I : Integer; +begin + if (N >= 0) and (N < MaxRoundPlaces) then I := N else I := 0; + Dec_Place := Exp10(I); + ReturnAnswer := Int((Abs(X) * Dec_Place) + 0.5); + RoundN := Sgn(X) * ReturnAnswer / Dec_Place; +end; + +function Ceil(X : Float) : Integer; +var + ReturnAnswer : Integer; +begin + ReturnAnswer := Trunc(X); + if ReturnAnswer < X then ReturnAnswer := ReturnAnswer + 1; + Ceil := ReturnAnswer; +end; + +function Floor(X : Float) : Integer; +var + ReturnAnswer : Integer; +begin + ReturnAnswer := Trunc(X); + if ReturnAnswer > X then ReturnAnswer := ReturnAnswer - 1; + Floor := ReturnAnswer; +end; + +end. \ No newline at end of file diff --git a/fpmath/urtpol1.pas b/fpmath/urtpol1.pas new file mode 100755 index 0000000..7caadb5 --- /dev/null +++ b/fpmath/urtpol1.pas @@ -0,0 +1,39 @@ +{ ****************************************************************** + Linear equation + ****************************************************************** } + +unit urtpol1; + +interface + +uses + utypes; + +function RootPol1(A, B : Float; var X : Float) : Integer; +{ ------------------------------------------------------------------ + Solves the linear equation A + B * X = 0 + Returns 1 if no error (B <> 0) + -1 if X is undetermined (A = B = 0) + -2 if no solution (A <> 0, B = 0) + ------------------------------------------------------------------ } + +implementation + +function RootPol1(A, B : Float; var X : Float) : Integer; +begin + X := 0.0; + + if B <> 0.0 then + begin + if A <> 0.0 then X := - A / B; + RootPol1 := 1; + Exit; + end; + + if A = 0.0 then { 0 + 0X = 0 } + RootPol1 := - 1 + else { A + 0X = 0 } + RootPol1 := - 2; +end; + +end. diff --git a/fpmath/urtpol2.pas b/fpmath/urtpol2.pas new file mode 100755 index 0000000..041cb69 --- /dev/null +++ b/fpmath/urtpol2.pas @@ -0,0 +1,84 @@ +{ ****************************************************************** + Quadratic equation + ****************************************************************** } + +unit urtpol2; + +interface + +uses + utypes, urtpol1; + +function RootPol2(Coef : PVector; Z : PCompVector) : Integer; +{ ------------------------------------------------------------------ + Solves the quadratic equation: + Coef^[0] + Coef^[1] * X + Coef^[2] * X^2 = 0 + ------------------------------------------------------------------ } + +implementation + +function RootPol2(Coef : PVector; Z : PCompVector) : Integer; +var + Delta, F, Q : Float; + +begin + Z^[1].X := 0.0; Z^[1].Y := 0.0; + Z^[2].X := 0.0; Z^[2].Y := 0.0; + + if Coef^[2] = 0.0 then + begin + RootPol2 := RootPol1(Coef^[0], Coef^[1], Z^[1].X); + Exit; + end; + + if Coef^[0] = 0.0 then + begin + { 0 is root. Eq. becomes linear } + if RootPol1(Coef^[1], Coef^[2], Z^[1].X) = 1 then + { Linear eq. has 1 solution } + RootPol2 := 2 + else + { Linear eq. is undetermined or impossible } + RootPol2 := 1; + Exit; + end; + + Delta := Sqr(Coef^[1]) - 4.0 * Coef^[0] * Coef^[2]; + + { 2 real roots } + if Delta > 0.0 then + begin + RootPol2 := 2; + + { Algorithm for minimizing roundoff errors } + { See `Numerical Recipes' } + if Coef^[1] >= 0.0 then + Q := - 0.5 * (Coef^[1] + Sqrt(Delta)) + else + Q := - 0.5 * (Coef^[1] - Sqrt(Delta)); + + Z^[1].X := Q / Coef^[2]; + Z^[2].X := Coef^[0] / Q; + + Exit; + end; + + { Double real root } + if Delta = 0.0 then + begin + RootPol2 := 2; + Z^[1].X := - 0.5 * Coef^[1] / Coef^[2]; + Z^[2].X := Z^[1].X; + Exit; + end; + + { 2 complex roots } + RootPol2 := 0; + F := 0.5 / Coef^[2]; + Z^[1].X := - F * Coef^[1]; + Z^[1].Y := Abs(F) * Sqrt(- Delta); + Z^[2].X := Z^[1].X; + Z^[2].Y := - Z^[1].Y; +end; + +end. diff --git a/fpmath/urtpol3.pas b/fpmath/urtpol3.pas new file mode 100755 index 0000000..1f14361 --- /dev/null +++ b/fpmath/urtpol3.pas @@ -0,0 +1,106 @@ +{ ****************************************************************** + Cubic equation + ****************************************************************** } + +unit urtpol3; + +interface + +uses + utypes, urtpol2; + +function RootPol3(Coef : PVector; Z : PCompVector) : Integer; +{ ------------------------------------------------------------------ + Solves the cubic equation: + Coef^[0] + Coef^[1] * X + Coef^[2] * X^2 + Coef^[3] * X^3 = 0 + ------------------------------------------------------------------ } + +implementation + +function RootPol3(Coef : PVector; Z : PCompVector) : Integer; +const + OneThird = 0.333333333333333333; { 1 / 3 } + TwoPiDiv3 = 2.09439510239319549; { 2 Pi / 3 } + Sqrt3Div2 = 0.866025403784438647; { Sqrt(3) / 2 } + +var + A, AA, B, C : Float; + Q, QQQ, R, RR : Float; + S, T, U : Float; + I : Integer; + Cf : PVector; + +begin + for I := 1 to 3 do + begin + Z^[I].X := 0.0; + Z^[I].Y := 0.0; + end; + + if Coef^[3] = 0.0 then + begin + RootPol3 := RootPol2(Coef, Z); + Exit; + end; + + if Coef^[0] = 0.0 then + begin + DimVector(Cf, 2); + + { 0 is root. Equation becomes quadratic } + Cf^[0] := Coef^[1]; Cf^[1] := Coef^[2]; Cf^[2] := Coef^[3]; + + { Solve quadratic equation } + RootPol3 := RootPol2(Cf, Z) + 1; + + DelVector(Cf, 2); + Exit; + end; + + if Coef^[3] = 1.0 then + begin + A := Coef^[2] * OneThird; + B := Coef^[1]; + C := Coef^[0]; + end + else + begin + A := Coef^[2] / Coef^[3] * OneThird; + B := Coef^[1] / Coef^[3]; + C := Coef^[0] / Coef^[3]; + end; + + AA := A * A; + + Q := AA - OneThird * B; + R := A * (AA - 0.5 * B) + 0.5 * C; + RR := Sqr(R); QQQ := Q * Sqr(Q); + + if RR < QQQ then { 3 real roots } + begin + RootPol3 := 3; + S := Sqrt(Q); + T := R / (Q * S); + T := PiDiv2 - ArcTan(T / Sqrt(1.0 - T * T)); { ArcCos(T) } + T := OneThird * T; + S := - 2.0 * S; + Z^[1].X := S * Cos(T) - A; + Z^[2].X := S * Cos(T + TwoPiDiv3) - A; + Z^[3].X := S * Cos(T - TwoPiDiv3) - A; + end + else { 1 real root } + begin + RootPol3 := 1; + S := Abs(R) + Sqrt(RR - QQQ); + if S > 0.0 then S := Exp(OneThird * Ln(S)); + if R > 0.0 then S := - S; + if S = 0.0 then T := 0.0 else T := Q / S; + U := S + T; + Z^[1].X := U - A; { Real root } + Z^[2].X := - 0.5 * U - A; + Z^[2].Y := Sqrt3Div2 * Abs(S - T); + Z^[3].X := Z^[2].X; Z^[3].Y := - Z^[2].Y; + end; +end; + +end. diff --git a/fpmath/urtpol4.pas b/fpmath/urtpol4.pas new file mode 100755 index 0000000..596b805 --- /dev/null +++ b/fpmath/urtpol4.pas @@ -0,0 +1,146 @@ +{ ****************************************************************** + Quartic equation + ****************************************************************** } + +unit urtpol4; + +interface + +uses + utypes, urtpol2, urtpol3; + +function RootPol4(Coef : PVector; Z : PCompVector) : Integer; +{ ------------------------------------------------------------------ + Solves the quartic equation: + Coef^[0] + Coef^[1] * X + Coef^[2] * X^2 + Coef^[3] * X^3 + + Coef^[4] * X^4 = 0 + ------------------------------------------------------------------ } + +implementation + +function RootPol4(Coef : PVector; Z : PCompVector) : Integer; +var + A, AA, B, C, D : Float; + Q , R , S : Float; + K , KK, L, M : Float; + I, N1, N2 : Integer; + Cf : PVector; + Z1, Z2 : PCompVector; + + function HighestRealRoot(Deg : Integer; Z : PCompVector) : Float; + { Find the highest real root among the roots of a polynomial } + var + I : Integer; + R : Float; + begin + R := - MaxNum; + for I := 1 to Deg do + if (Z^[I].Y = 0.0) and (Z^[I].X > R) then + R := Z^[I].X; + HighestRealRoot := R; + end; + +begin + for I := 1 to 4 do + begin + Z^[I].X := 0.0; + Z^[I].Y := 0.0; + end; + + if Coef^[4] = 0 then + begin + RootPol4 := RootPol3(Coef, Z); + Exit; + end; + + DimVector(Cf, 3); + + if Coef^[0] = 0.0 then + begin + { 0 is root. Equation becomes cubic } + Cf^[0] := Coef^[1]; Cf^[1] := Coef^[2]; Cf^[2] := Coef^[3]; + + { Solve cubic equation } + RootPol4 := RootPol3(Cf, Z) + 1; + + DelVector(Cf, 3); + Exit; + end; + + if Coef^[4] = 1.0 then + begin + A := Coef^[3] * 0.25; + B := Coef^[2]; + C := Coef^[1]; + D := Coef^[0]; + end + else + begin + A := Coef^[3] / Coef^[4] * 0.25; + B := Coef^[2] / Coef^[4]; + C := Coef^[1] / Coef^[4]; + D := Coef^[0] / Coef^[4]; + end; + + AA := A * A; + + Q := B - 6.0 * AA; + R := C + A * (8.0 * AA - 2.0 * B); + S := D - A * C + AA * (B - 3.0 * AA); + + { Compute coefficients of cubic equation } + Cf^[3] := 1.0; + Cf^[2] := 0.5 * Q; + Cf^[1] := 0.25 * (Sqr(Cf^[2]) - S); + + { Solve cubic equation and set KK = highest real root } + if (R = 0.0) and (Cf^[1] < 0.0) then + begin + { Eq. becomes quadratic with 2 real roots } + Cf^[0] := Cf^[1]; Cf^[1] := Cf^[2]; Cf^[2] := 1.0; + N1 := RootPol2(Cf, Z); + KK := HighestRealRoot(2, Z); + end + else + begin + Cf^[0] := - 0.015625 * Sqr(R); + N1 := RootPol3(Cf, Z); + KK := HighestRealRoot(3, Z); + end; + + K := Sqrt(KK); + if K = 0.0 then + R := Sqrt(Sqr(Q) - 4.0 * S) + else + begin + Q := Q + 4.0 * KK; + R := 0.5 * R / K; + end; + + L := 0.5 * (Q - R); + M := 0.5 * (Q + R); + + { Solve quadratic equation: Y^2 + 2KY + L = 0 } + DimCompVector(Z1, 2); + Cf^[0] := L; Cf^[1] := 2.0 * K; Cf^[2] := 1.0; + N1 := RootPol2(Cf, Z1); + + { Solve quadratic equation: Z^2 - 2KZ + M = 0 } + DimCompVector(Z2, 2); + Cf^[0] := M; Cf^[1] := -Cf^[1]; + N2 := RootPol2(Cf, Z2); + + { Transfer roots into vectors Xr and Xi } + Z^[1].X := Z1^[1].X - A; Z^[1].Y := Z1^[1].Y; + Z^[2].X := Z1^[2].X - A; Z^[2].Y := Z1^[2].Y; + Z^[3].X := Z2^[1].X - A; Z^[3].Y := Z2^[1].Y; + Z^[4].X := Z2^[2].X - A; Z^[4].Y := Z2^[2].Y; + + RootPol4 := N1 + N2; + + DelVector(Cf, 3); + DelCompVector(Z1, 2); + DelCompVector(Z2, 2); +end; + +end. diff --git a/fpmath/usecant.pas b/fpmath/usecant.pas new file mode 100755 index 0000000..6ebdf13 --- /dev/null +++ b/fpmath/usecant.pas @@ -0,0 +1,59 @@ +{ ****************************************************************** + Secant method for nonlinear equation + ****************************************************************** } + +unit usecant; + +interface + +uses + utypes; + +procedure Secant (Func : TFunc; + var X, Y : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); + +implementation + +procedure Secant (Func : TFunc; + var X, Y : Float; + MaxIter : Integer; + Tol : Float; + var F : Float); + +var + Iter : Integer; + G, Z : Float; + +begin + Iter := 0; + SetErrCode(OptOk); + + repeat + F := Func(X); + + if MaxIter < 1 then Exit; + + G := Func(Y); + + Iter := Iter + 1; + + if (F = G) or (Iter > MaxIter) then + begin + SetErrCode(OptNonConv); + Exit; + end; + + Z := (X * G - Y * F) / (G - F); + + X := Y; + Y := Z; + until Abs(X - Y) < Tol * (Abs(X) + Abs(Y)); + + X := 0.5 * (X + Y); + F := Func(X); +end; + +end. \ No newline at end of file diff --git a/fpmath/usimann.pas b/fpmath/usimann.pas new file mode 100755 index 0000000..fac88a7 --- /dev/null +++ b/fpmath/usimann.pas @@ -0,0 +1,308 @@ +{ ****************************************************************** + Optimization by Simulated Annealing + ****************************************************************** + Adapted from Fortran program SIMANN by Bill Goffe: + http://www.netlib.org/opt/simann.f + ****************************************************************** } + +unit usimann; + +interface + +uses + utypes, urandom, umedian; + +procedure InitSAParams(NT, NS, NCycles : Integer; RT : Float); +{ ------------------------------------------------------------------ + Initialize simulated annealing parameters + ------------------------------------------------------------------ + NT : Number of loops at constant temperature + NS : Number of loops before step adjustment + NCycles : Number of cycles + RT : Temperature reduction factor + ------------------------------------------------------------------ } + +procedure SA_CreateLogFile(FileName : String); +{ ------------------------------------------------------------------ + Initialize log file + ------------------------------------------------------------------ } + +procedure SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lb, Ub : Integer; + var F_min : Float); +{ ------------------------------------------------------------------ + Minimization of a function of several var. by simulated annealing + ------------------------------------------------------------------ + Input parameters : Func = objective function to be minimized + X = initial minimum coordinates + Xmin = minimum value of X + Xmax = maximum value of X + Lb, Ub = indices of first and last variables + ------------------------------------------------------------------ + Output parameter : X = refined minimum coordinates + F_min = function value at minimum + ------------------------------------------------------------------ } + +implementation + +{ Log file headers } +const + Hdr1 = 'Simulated annealing: Cycle '; + Hdr2 = 'Iter T F Inc Acc'; + +const + SA_NT : Integer = 5; { Number of loops at constant temperature } + SA_NS : Integer = 15; { Number of loops before step adjustment } + SA_RT : Float = 0.9; { Temperature reduction factor } + SA_NCycles : Integer = 1; { Number of cycles } + WriteLogFile : Boolean = False; + +var + LogFile : Text; + + procedure InitSAParams(NT, NS, NCycles : Integer; RT : Float); + begin + if NT > 0 then SA_NT := NT; + if NS > 0 then SA_NS := NS; + if NCycles > 1 then SA_NCycles := NCycles; + if (RT > 0.0) and (RT < 1.0) then SA_RT := RT; + end; + + procedure SA_CreateLogFile(FileName : String); + begin + Assign(LogFile, FileName); + Rewrite(LogFile); + WriteLogFile := True; + end; + + function InitTemp(Func : TFuncNVar; + X, Xmin, Range : PVector; + Lb, Ub : Integer) : Float; +{ ------------------------------------------------------------------ + Computes the initial temperature so that the probability + of accepting an increase of the function is about 0.5 + ------------------------------------------------------------------ } + const + N_EVAL = 50; { Number of function evaluations } + var + F, F1 : Float; { Function values } + DeltaF : PVector; { Function increases } + N_inc : Integer; { Number of function increases } + I : Integer; { Index of function evaluation } + K : Integer; { Index of parameter } + begin + DimVector(DeltaF, N_EVAL); + + N_inc := 0; + F := Func(X); + + { Compute N_EVAL function values, changing each parameter in turn } + K := Lb; + for I := 1 to N_EVAL do + begin + X^[K] := Xmin^[K] + RanGen3 * Range^[K]; + F1 := Func(X); + if F1 > F then + begin + Inc(N_inc); + DeltaF^[N_inc] := F1 - F; + end; + F := F1; + Inc(K); + if K > Ub then K := Lb; + end; + + { The median M of these N_inc increases has a probability of 1/2. + From Boltzmann's formula: Exp(-M/T) = 1/2 ==> T = M / Ln(2) } + if N_inc > 0 then + InitTemp := Median(DeltaF, 1, N_inc, False) * InvLn2 + else + InitTemp := 1.0; + + DelVector(DeltaF, N_EVAL); + end; + + function Accept(DeltaF, T : Float; + var N_inc, N_acc : Integer) : Boolean; +{ ---------------------------------------------------------------------- + Checks if a variation DeltaF of the function at temperature T is + acceptable. Updates the counters N_inc (number of increases of the + function) and N_acc (number of accepted increases). + ---------------------------------------------------------------------- } + var + X : Float; + begin + if DeltaF < 0.0 then + begin + Accept := True; + Exit; + end; + + Inc(N_inc); + X := DeltaF / T; + + if X > MaxLog then { Exp(- X) ~ 0 } + begin + Accept := False; + Exit; + end; + + if Exp(- X) > RanGen3 then + begin + Accept := True; + Inc(N_acc); + end + else + Accept := False; + end; + + procedure SimAnnCycle(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lb, Ub : Integer; + var F_min : Float); +{ ------------------------------------------------------------------ + Performs one cycle of simulated annealing + ------------------------------------------------------------------ } + const + SFact = 2.0; { Factor for step reduction } + MinTemp = 1.0E-30; { Min. temperature } + MinFunc = 1.0E-30; { Min. function value } + var + I, Iter, J, K, N_inc, N_acc : Integer; + F, F1, DeltaF, Ratio, T, OldX : Float; + Range, DeltaX, Xopt : PVector; + Nacc : PIntVector; + begin + DimVector(Range, Ub); + DimVector(DeltaX, Ub); + DimVector(Xopt, Ub); + DimIntVector(Nacc, Ub); + + { Determine parameter range, step and optimum } + for K := Lb to Ub do + begin + Range^[K] := Xmax^[K] - Xmin^[K]; + DeltaX^[K] := 0.5 * Range^[K]; + Xopt^[K] := X^[K]; + end; + + { Initialize function values } + F := Func(X); + F_min := F; + + { Initialize temperature and iteration count } + T := InitTemp(Func, X, Xmin, Range, Lb, Ub); + Iter := 0; + + repeat + N_inc := 0; + N_acc := 0; + + { Perform SA_NT evaluations at constant temperature } + for I := 1 to SA_NT do + begin + for J := 1 to SA_NS do + for K := Lb to Ub do + begin + { Save current parameter value } + OldX := X^[K]; + + { Pick new value, keeping it within Range } + X^[K] := X^[K] + (2.0 * RanGen3 - 1.0) * DeltaX^[K]; + if (X^[K] < Xmin^[K]) or (X^[K] > Xmax^[K]) then + X^[K] := Xmin^[K] + RanGen3 * Range^[K]; + + { Compute new function value } + F1 := Func(X); + DeltaF := F1 - F; + + { Check for acceptance } + if Accept(DeltaF, T, N_inc, N_acc) then + begin + Inc(Nacc^[K]); + F := F1; + end + else + { Restore parameter value } + X^[K] := OldX; + + { Update minimum if necessary } + if F < F_min then + begin + Xopt^[K] := X^[K]; + F_min := F; + end; + end; + + { Ajust step length to maintain an acceptance + ratio of about 50% for each parameter } + for K := Lb to Ub do + begin + Ratio := Nacc^[K] / SA_NS; + if Ratio > 0.6 then + begin + { Increase step length, keeping it within Range } + DeltaX^[K] := DeltaX^[K] * (1.0 + ((Ratio - 0.6) / 0.4) * SFact); + if DeltaX^[K] > Range^[K] then DeltaX^[K] := Range^[K]; + end + else if Ratio < 0.4 then + { Reduce step length } + DeltaX^[K] := DeltaX^[K] / (1.0 + ((0.4 - Ratio) / 0.4) * SFact); + + { Restore counter } + Nacc^[K] := 0; + end; + end; + + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', T:12, ' ', F:12, N_inc:6, N_acc:6); + + { Update temperature and iteration count } + T := T * SA_RT; + Inc(Iter); + until (N_acc = 0) or (T < MinTemp) or (Abs(F_min) < MinFunc); + + for K := Lb to Ub do + X^[K] := Xopt^[K]; + + DelVector(Range, Ub); + DelVector(DeltaX, Ub); + DelVector(Xopt, Ub); + DelIntVector(Nacc, Ub); + end; + + procedure SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lb, Ub : Integer; + var F_min : Float); + var + Cycle : Integer; + begin + SetErrCode(OptOk); + + { Initialize the random number generator + using the standard Pascal generator } + Randomize; + InitGen(Trunc(Random * 1.0E+8)); + + for Cycle := 1 to SA_NCycles do + begin + if WriteLogFile then + begin + WriteLn(LogFile, Hdr1, Cycle); + WriteLn(LogFile); + WriteLn(LogFile, Hdr2); + end; + + SimAnnCycle(Func, X, Xmin, Xmax, Lb, Ub, F_min); + end; + + if WriteLogFile then + begin + Close(LogFile); + WriteLogFile := False; + end; + end; + +end. diff --git a/fpmath/usimplex.pas b/fpmath/usimplex.pas new file mode 100755 index 0000000..4442582 --- /dev/null +++ b/fpmath/usimplex.pas @@ -0,0 +1,234 @@ +{ ****************************************************************** + Function minimization by the simplex method + ****************************************************************** } + +unit usimplex; + +interface + +uses + utypes; + +procedure SaveSimplex(FileName : string); +{ ------------------------------------------------------------------ + Opens a file to save the Simplex iterations + ------------------------------------------------------------------ } + +procedure Simplex(Func : TFuncNVar; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float); +{ ------------------------------------------------------------------ + Minimization of a function of several variables by the + simplex method of Nelder and Mead + ------------------------------------------------------------------ + Input parameters : Func = objective function + X = initial minimum coordinates + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ------------------------------------------------------------------ + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + ------------------------------------------------------------------ + The function MathErr returns one of the following codes: + + OptOk = no error + OptNonConv = non-convergence + ------------------------------------------------------------------ } + +implementation + +const + WriteLogFile : Boolean = False; + +var + LogFile : Text; + +procedure SaveSimplex(FileName : string); +begin + Assign(LogFile, FileName); + Rewrite(LogFile); + WriteLogFile := True; +end; + +procedure Simplex(Func : TFuncNVar; + X : PVector; + Lb, Ub : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float); + const + Step = 1.50; { Step used to construct the initial simplex } + var + P : PMatrix; { Simplex coordinates } + F : PVector; { Function values } + Pbar : PVector; { Centroid coordinates } + Pstar, P2star : PVector; { New vertices } + Ystar, Y2star : Float; { New function values } + F0 : Float; { Function value at minimum } + N : Integer; { Number of parameters } + M : Integer; { Index of last vertex } + L, H : Integer; { Vertices with lowest & highest F values } + I, J : Integer; { Loop variables } + Iter : Integer; { Iteration count } + Corr, MaxCorr : Float; { Corrections } + Sum : Float; + Flag : Boolean; + + + procedure UpdateSimplex(Y : Float; Q : PVector); + { Update "worst" vertex and function value } + var + J : Integer; + begin + F^[H] := Y; + for J := Lb to Ub do + P^[H]^[J] := Q^[J]; + end; + + begin + { Quit if no iteration required } + if MaxIter < 1 then + begin + F_min := Func(X); + SetErrCode(OptOk); + Exit; + end; + + if WriteLogFile then + begin + WriteLn(LogFile, 'Simplex'); + WriteLn(LogFile, 'Iter F'); + end; + + N := Ub - Lb + 1; + M := Ub + 1; + + DimMatrix(P, M, Ub); + DimVector(F, M); + DimVector(Pbar, Ub); + DimVector(Pstar, Ub); + DimVector(P2star, Ub); + + Iter := 1; + F0 := MaxNum; + + { Construct initial simplex } + for I := Lb to M do + for J := Lb to Ub do + P^[I]^[J] := X^[J]; + for I := Lb to Ub do + P^[I]^[I] := P^[I]^[I] * Step; + + { Evaluate function at each vertex } + for I := Lb to M do + F^[I] := Func(P^[I]); + + repeat + { Find vertices (L,H) having the lowest and highest + function values, i.e. "best" and "worst" vertices } + L := Lb; + H := Lb; + for I := Lb + 1 to M do + if F^[I] < F^[L] then + L := I + else if F^[I] > F^[H] then + H := I; + if F^[L] < F0 then + F0 := F^[L]; + + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F0:12); + + { Find centroid of points other than P(H) } + for J := Lb to Ub do + begin + Sum := 0.0; + for I := Lb to M do + if I <> H then Sum := Sum + P^[I]^[J]; + Pbar^[J] := Sum / N; + end; + + { Reflect worst vertex through centroid } + for J := Lb to Ub do + Pstar^[J] := 2.0 * Pbar^[J] - P^[H]^[J]; + Ystar := Func(Pstar); + + { If reflection successful, try extension } + if Ystar < F^[L] then + begin + for J := Lb to Ub do + P2star^[J] := 3.0 * Pstar^[J] - 2.0 * Pbar^[J]; + Y2star := Func(P2star); + + { Retain extension or contraction } + if Y2star < F^[L] then + UpdateSimplex(Y2star, P2star) + else + UpdateSimplex(Ystar, Pstar); + end + else + begin + I := Lb; + Flag := False; + repeat + if (I <> H) and (F^[I] > Ystar) then Flag := True; + Inc(I); + until Flag or (I > M); + if Flag then + UpdateSimplex(Ystar, Pstar) + else + begin + { Contraction on the reflection side of the centroid } + if Ystar <= F^[H] then + UpdateSimplex(Ystar, Pstar); + + { Contraction on the opposite side of the centroid } + for J := Lb to Ub do + P2star^[J] := 0.5 * (P^[H]^[J] + Pbar^[J]); + Y2star := Func(P2star); + if Y2star <= F^[H] then + UpdateSimplex(Y2star, P2star) + else + { Contract whole simplex } + for I := Lb to M do + for J := Lb to Ub do + P^[I]^[J] := 0.5 * (P^[I]^[J] + P^[L]^[J]); + end; + end; + + { Test convergence } + MaxCorr := 0.0; + for J := Lb to Ub do + begin + Corr := Abs(P^[H]^[J] - P^[L]^[J]); + if Corr > MaxCorr then MaxCorr := Corr; + end; + Inc(Iter); + until (MaxCorr < Tol) or (Iter > MaxIter); + + for J := Lb to Ub do + X^[J] := P^[L]^[J]; + F_min := F^[L]; + + DelMatrix(P, M, Ub); + DelVector(F, M); + DelVector(Pbar, Ub); + DelVector(Pstar, Ub); + DelVector(P2star, Ub); + + if WriteLogFile then + Close(LogFile); + + if Iter > MaxIter then + SetErrCode(OptNonConv) + else + SetErrCode(OptOk); + end; + +end. + diff --git a/fpmath/uskew.pas b/fpmath/uskew.pas new file mode 100755 index 0000000..5f8ec4f --- /dev/null +++ b/fpmath/uskew.pas @@ -0,0 +1,46 @@ +{ ****************************************************************** + Skewness and kurtosis + ****************************************************************** } + +unit uskew; + +interface + +uses + utypes; + +function Skewness(X : PVector; Lb, Ub : Integer; M, Sigma : Float) : Float; + +function Kurtosis(X : PVector; Lb, Ub : Integer; M, Sigma : Float) : Float; + +implementation + +function Skewness(X : PVector; Lb, Ub : Integer; M, Sigma : Float) : Float; + var + S, T : Float; + I : Integer; + begin + S := 0.0; + for I := Lb to Ub do + begin + T := (X^[I] - M) / Sigma; + S := S + T * Sqr(T); + end; + Skewness := S / (Ub - Lb + 1); + end; + +function Kurtosis(X : PVector; Lb, Ub : Integer; M, Sigma : Float) : Float; + var + S, T : Float; + I : Integer; + begin + S := 0.0; + for I := Lb to Ub do + begin + T := (X^[I] - M) / Sigma; + S := S + Sqr(Sqr(T)); + end; + Kurtosis := S / (Ub - Lb + 1) - 3.0; + end; + +end. diff --git a/fpmath/usnedeco.pas b/fpmath/usnedeco.pas new file mode 100755 index 0000000..f8b23f5 --- /dev/null +++ b/fpmath/usnedeco.pas @@ -0,0 +1,53 @@ +{ ****************************************************************** + Snedecor's F-test (comparison of two variances) + ****************************************************************** } + +unit usnedeco; + +interface + +uses + utypes; + +procedure Snedecor(N1, N2 : Integer; + S1, S2 : Float; + var F : Float; + var DoF1, DoF2 : Integer); +{ ------------------------------------------------------------------ + Snedecor's F-test (comparison of two variances) + ------------------------------------------------------------------ + Input parameters : N1, N2 = samples sizes + S1, S2 = samples SD's (computed with StDev) + Output parameters: F = Snedecor's F + DoF1, DoF2 = degrees of freedom + ------------------------------------------------------------------ } + +implementation + +procedure Snedecor(N1, N2 : Integer; + S1, S2 : Float; + var F : Float; + var DoF1, DoF2 : Integer); + +var + V1, V2 : Float; { Sample variances } + +begin + V1 := Sqr(S1); + V2 := Sqr(S2); + + if V1 > V2 then + begin + F := V1 / V2; + DoF1 := N1 - 1; + DoF2 := N2 - 1; + end + else + begin + F := V2 / V1; + DoF1 := N2 - 1; + DoF2 := N1 - 1; + end; +end; + +end. \ No newline at end of file diff --git a/fpmath/ustdpair.pas b/fpmath/ustdpair.pas new file mode 100755 index 0000000..a60b870 --- /dev/null +++ b/fpmath/ustdpair.pas @@ -0,0 +1,60 @@ +{ ****************************************************************** + Student t-test for paired samples + ****************************************************************** } + +unit ustdpair; + +interface + +uses + utypes, uminmax, umeansd; + +procedure StudPaired(X, Y : PVector; + Lb, Ub : Integer; + var T : Float; + var DoF : Integer); +{ ------------------------------------------------------------------ + Student t-test for paired samples + ------------------------------------------------------------------ + Input parameters : X, Y = samples + Lb, Ub = lower and upper bounds + Output parameters: T = Student's t + DoF = degrees of freedom + ------------------------------------------------------------------ } + +implementation + +procedure StudPaired(X, Y : PVector; + Lb, Ub : Integer; + var T : Float; + var DoF : Integer); + +var + D : PVector; { Differences between samples } + MD, SD : Float; { Mean & std.dev. of differences } + N : Integer; { Sample size } + I : Integer; { Loop variable } + +begin + DimVector(D, Ub); + + for I := Lb to Ub do + D^[I] := X^[I] - Y^[I]; + + MD := Mean(D, Lb, Ub); + SD := StDev(D, Lb, Ub, MD); + + if SD = 0.0 then + begin + T := Sgn(MD) * MaxNum; + SetErrCode(FSing); + end; + + DoF := Ub - Lb; { N - 1 } + N := DoF + 1; + T := MD * Sqrt(N) / SD; + + DelVector(D, Ub); +end; + +end. \ No newline at end of file diff --git a/fpmath/ustrings.pas b/fpmath/ustrings.pas new file mode 100755 index 0000000..ff71c74 --- /dev/null +++ b/fpmath/ustrings.pas @@ -0,0 +1,312 @@ +{ ****************************************************************** + Pascal string routines + ****************************************************************** } + +unit ustrings; + +interface + +uses + utypes; + +function LTrim(S : String) : String; +{ ------------------------------------------------------------------ + Removes leading blanks + ------------------------------------------------------------------ } + +function RTrim(S : String) : String; +{ ------------------------------------------------------------------ + Removes trailing blanks + ------------------------------------------------------------------ } + +function Trim(S : String) : String; +{ ------------------------------------------------------------------ + Removes leading and trailing blanks + ------------------------------------------------------------------ } + +function StrChar(N : Byte; C : Char) : String; +{ ------------------------------------------------------------------ + Returns a string made of character C repeated N times + ------------------------------------------------------------------ } + +function RFill(S : String; L : Byte) : String; +{ ------------------------------------------------------------------ + Completes string S with trailing blanks for a total length L + ------------------------------------------------------------------ } + +function LFill(S : String; L : Byte) : String; +{ ------------------------------------------------------------------ + Completes string S with leading blanks for a total length L + ------------------------------------------------------------------ } + +function CFill(S : String; L : Byte) : String; +{ ------------------------------------------------------------------ + Completes string S with leading blanks + to center the string on a total length L + ------------------------------------------------------------------ } + +function Replace(S : String; C1, C2 : Char) : String; +{ ------------------------------------------------------------------ + Replaces in string S all the occurences + of character C1 by character C2 + ------------------------------------------------------------------ } + +function Extract(S : String; var Index : Byte; Delim : Char) : String; +{ ------------------------------------------------------------------ + Extracts a field from a string. Index is the position of the first + character of the field. Delim is the character used to separate + fields (e.g. blank, comma or tabulation). Blanks immediately + following Delim are ignored. Index is updated to the position of + the next field. + ------------------------------------------------------------------ } + +procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); +{ ------------------------------------------------------------------ + Parses a string into its constitutive fields. Delim is the field + separator. The number of fields is returned in N. The fields are + returned in Field^[0]..Field^[N - 1]. Field must be dimensioned in + the calling program. + ------------------------------------------------------------------ } + +procedure SetFormat(NumLength, MaxDec : Integer; + FloatPoint, NSZero : Boolean); +{ ------------------------------------------------------------------ + Sets the numeric format + + NumLength = Length of numeric field + MaxDec = Max. number of decimal places + FloatPoint = True for floating point notation + NSZero = True to write non significant zero's + ------------------------------------------------------------------ } + +function FloatStr(X : Float) : String; +{ ------------------------------------------------------------------ + Converts a real to a string according to the numeric format + ------------------------------------------------------------------ } + +function IntStr(N : LongInt) : String; +{ ------------------------------------------------------------------ + Converts an integer to a string + ------------------------------------------------------------------ } + +function CompStr(Z : Complex) : String; +{ ------------------------------------------------------------------ + Converts a complex number to a string + ------------------------------------------------------------------ } + +implementation + +const + gNumLength : Integer = 10; + gMaxDec : Integer = 4; + gFloatPoint : Boolean = False; + gNSZero : Boolean = False; + + function LTrim(S : String) : String; + begin + if S <> '' then + repeat + if S[1] = ' ' then Delete(S, 1, 1); + until S[1] <> ' '; + LTrim := S; + end; + + function RTrim(S : String) : String; + var + L1 : Byte; + begin + if S <> '' then + repeat + L1 := Length(S); + if S[L1] = ' ' then Delete(S, L1, 1); + until S[L1] <> ' '; + RTrim := S; + end; + + function Trim(S : String) : String; + begin + Trim := LTrim(RTrim(S)); + end; + + function StrChar(N : Byte; C : Char) : String; + var + I : Byte; + S : String; + begin + S := ''; + for I := 1 to N do + S := S + C; + StrChar := S; + end; + + function RFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + RFill := S + else + RFill := S + StrChar(L - L1, ' '); + end; + + function LFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + LFill := S + else + LFill := StrChar(L - L1, ' ') + S; + end; + + function CFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + CFill := S + else + CFill := StrChar((L - L1) div 2, ' ') + S; + end; + + function Replace(S : String; C1, C2 : Char) : String; + var + S1 : String; + K : Byte; + begin + S1 := S; + K := Pos(C1, S1); + while K > 0 do + begin + S1[K] := C2; + K := Pos(C1, S1); + end; + Replace := S1; + end; + + function Extract(S : String; var Index : Byte; Delim : Char) : String; + var + I, L : Byte; + begin + I := Index; + L := Length(S); + + { Search for Delim } + while (I <= L) and (S[I] <> Delim) do + Inc(I); + + { Extract field } + if I = Index then + Extract := '' + else + Extract := Copy(S, Index, I - Index); + + { Skip blanks after Delim } + repeat + Inc(I); + until (I > L) or (S[I] <> ' '); + + { Update Index } + Index := I; + end; + + procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); + var + I, Index, L : Byte; + begin + I := 0; + Index := 1; + L := Length(S); + repeat + Field^[I] := Extract(S, Index, Delim); + Inc(I); + until Index > L; + N := I; + end; + + procedure SetFormat(NumLength, MaxDec : Integer; + FloatPoint, NSZero : Boolean); + begin + if (NumLength >= 1) and (NumLength <= 80) then gNumLength := NumLength; + if (MaxDec >= 0) and (MaxDec <= 20) then gMaxDec := MaxDec; + + gFloatPoint := FloatPoint; + gNSZero := NSZero; + end; + + function RemZero(S : String) : String; + var + I : Integer; + S1, S2 : String; + C : Char; + begin + I := Pos('.', S); + + if I = 0 then + begin + RemZero := S; + Exit + end; + + I := Pos('E', S); + if I = 0 then I := Pos('e', S); + + if I > 0 then + begin + S1 := Copy(S, 1, I - 1); + S2 := Copy(S, I, Length(S) - I + 1) + end + else + begin + S1 := S; + S2 := '' + end; + + repeat + I := Length(S1); + C := S1[I]; + if (C = '0') or (C = '.') then S1 := Copy(S1, 1, I - 1) + until C <> '0'; + + RemZero := S1 + S2 + end; + + function FloatStr(X : Float) : String; + var + S : String; + begin + if gFloatPoint then + begin + Str(X:Pred(gNumLength), S); + S := ' ' + S; + end + else + Str(X:gNumLength:gMaxDec, S); + + if not gNSZero then + S := RemZero(S); + + FloatStr := S; + end; + + function IntStr(N : LongInt) : String; + var + S : String; + begin + Str(N:(gNumLength - gMaxDec - 1), S); + IntStr := S; + end; + + function CompStr(Z : Complex) : String; + var + S : String; + begin + if Z.Y >= 0.0 then S := ' + ' else S := ' - '; + CompStr := FloatStr(Z.X) + S + FloatStr(Abs(Z.Y)) + ' * i'; + end; + +end. + diff --git a/fpmath/ustudind.pas b/fpmath/ustudind.pas new file mode 100755 index 0000000..b03a6bf --- /dev/null +++ b/fpmath/ustudind.pas @@ -0,0 +1,52 @@ +{ ****************************************************************** + Student t-test for independent samples + ****************************************************************** } + +unit ustudind; + +interface + +uses + utypes; + +procedure StudIndep(N1, N2 : Integer; + M1, M2, S1, S2 : Float; + var T : Float; + var DoF : Integer); +{ ------------------------------------------------------------------ + Student t-test for independent samples + ------------------------------------------------------------------ + Input parameters : N1, N2 = samples sizes + M1, M2 = samples means + S1, S2 = samples SD's (computed with StDev) + Output parameters: T = Student's t + DoF = degrees of freedom + ------------------------------------------------------------------ } + +implementation + +procedure StudIndep(N1, N2 : Integer; + M1, M2, S1, S2 : Float; + var T : Float; + var DoF : Integer); + +var + V1, V2 : Float; { Sample variances } + VarCom : Float; { Estimate of common variance } + +begin + V1 := Sqr(S1); + V2 := Sqr(S2); + + DoF := N1 + N2 - 2; + + if (N1 >= 30) and (N2 >= 30) then + T := (M1 - M2) / Sqrt(V1 / N1 + V2 / N2) + else + begin + VarCom := ((N1 - 1) * V1 + (N2 - 1) * V2) / DoF; + T := (M1 - M2) / Sqrt(VarCom / N1 + VarCom / N2); + end; +end; + +end. \ No newline at end of file diff --git a/fpmath/usvd.o b/fpmath/usvd.o new file mode 100644 index 0000000..6ee454f Binary files /dev/null and b/fpmath/usvd.o differ diff --git a/fpmath/usvd.pas b/fpmath/usvd.pas new file mode 100755 index 0000000..fb7967e --- /dev/null +++ b/fpmath/usvd.pas @@ -0,0 +1,485 @@ +{ ****************************************************************** + Singular value decomposition + ****************************************************************** } + +unit usvd; + +interface + +uses + utypes, uminmax, utrigo; + +procedure SV_Decomp(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + S : PVector; + V : PMatrix); +{ ------------------------------------------------------------------ + Singular value decomposition. Factors the matrix A (n x m, with + n >= m) as a product U * S * V' where U is a (n x m) column- + orthogonal matrix, S a (m x m) diagonal matrix with elements >= 0 + (the singular values) and V a (m x m) orthogonal matrix. This + routine is used in conjunction with SV_Solve to solve a system of + equations. + ------------------------------------------------------------------ + Input parameters : A = matrix + Lb = index of first matrix element + Ub1 = index of last matrix element in 1st dim. + Ub2 = index of last matrix element in 2nd dim. + ------------------------------------------------------------------ + Output parameter : A = contains the elements of U + S = vector of singular values + V = orthogonal matrix + ------------------------------------------------------------------ + Possible results : + MatOk : No error + MatNonConv : Non-convergence + MatErrDim : Non-compatible dimensions (n < m) + ------------------------------------------------------------------ + NB : This procedure destroys the original matrix A + ------------------------------------------------------------------ } + +procedure SV_SetZero(S : PVector; + Lb, Ub : Integer; + Tol : Float); +{ ------------------------------------------------------------------ + Sets the singular values to zero if they are lower than a + specified threshold. + ------------------------------------------------------------------ + Input parameters : S = vector of singular values + Tol = relative tolerance + Threshold value will be Tol * Max(S) + Lb = index of first vector element + Ub = index of last vector element + ------------------------------------------------------------------ + Output parameter : S = modified singular values + ------------------------------------------------------------------ } + +procedure SV_Solve(U : PMatrix; + S : PVector; + V : PMatrix; + B : PVector; + Lb, Ub1, Ub2 : Integer; + X : PVector); +{ ------------------------------------------------------------------ + Solves a system of equations by singular value decomposition, + after the matrix has been transformed by SV_Decomp, and the lowest + singular values have been set to zero by SV_SetZero. + ------------------------------------------------------------------ + Input parameters : U, S, V = vector and matrices + from SV_Decomp + B = constant vector + Lb, Ub1, Ub2 = as in SV_Decomp + ------------------------------------------------------------------ + Output parameter : X = solution vector + = V * Diag(1/s(i)) * U' * B, for s(i) <> 0 + ------------------------------------------------------------------ } + +procedure SV_Approx(U : PMatrix; + S : PVector; + V : PMatrix; + Lb, Ub1, Ub2 : Integer; + A : PMatrix); +{ ------------------------------------------------------------------ + Approximates a matrix A by the product USV', after the lowest + singular values have been set to zero by SV_SetZero. + ------------------------------------------------------------------ + Input parameters : U, S, V = vector and matrices + from SV_Decomp + Lb, Ub1, Ub2 = as in SV_Decomp + ------------------------------------------------------------------ + Output parameter : A = approximated matrix + ------------------------------------------------------------------ } + + +implementation + +procedure SV_Decomp(A : PMatrix; + Lb, Ub1, Ub2 : Integer; + S : PVector; + V : PMatrix); +{ ---------------------------------------------------------------------- + This procedure is a translation of the EISPACK subroutine SVD + + This procedure determines the singular value decomposition A = U.S.V' + of a real M by N rectangular matrix. Householder bidiagonalization and + a variant of the QR algorithm are used. + ---------------------------------------------------------------------- + This is a crude translation. Many of the original goto's + have been kept! + ---------------------------------------------------------------------- } + + var + I, J, K, L, I1, K1, L1, Mn, Its : Integer; + C, F, G, H, T, X, Y, Z, Tst1, Tst2, Scale : Float; + R : PVector; + + label + 190, 210, 270, 290, 360, 390, 430, 460, + 475, 490, 520, 540, 565, 580, 650, 700; + + begin + if Ub2 > Ub1 then + begin + SetErrCode(MatErrDim); + Exit + end; + + DimVector(R, Ub2); + + Scale := 0.0; + G := 0.0; + X := 0.0; + + { Householder reduction to bidiagonal form } + for I := Lb to Ub2 do + begin + L := I + 1; + R^[I] := Scale * G; + G := 0.0; + T := 0.0; + Scale := 0.0; + if I > Ub1 then goto 210; + + for K := I to Ub1 do + Scale := Scale + Abs(A^[K]^[I]); + + if Scale = 0.0 then goto 210; + + for K := I to Ub1 do + begin + A^[K]^[I] := A^[K]^[I] / Scale; + T := T + Sqr(A^[K]^[I]); + end; + + F := A^[I]^[I]; + G := - DSgn(Sqrt(T), F); + H := F * G - T; + A^[I]^[I] := F - G; + if I = Ub2 then goto 190; + + for J := L to Ub2 do + begin + T := 0.0; + for K := I to Ub1 do + T := T + A^[K]^[I] * A^[K]^[J]; + F := T / H; + for K := I to Ub1 do + A^[K]^[J] := A^[K]^[J] + F * A^[K]^[I]; + end; + +190: for K := I to Ub1 do + A^[K]^[I] := Scale * A^[K]^[I]; + +210: S^[I] := Scale * G; + G := 0.0; + T := 0.0; + Scale := 0.0; + if (I > Ub1) or (I = Ub2) then goto 290; + + for K := L to Ub2 do + Scale := Scale + Abs(A^[I]^[K]); + + if Scale = 0.0 then goto 290; + + for K := L to Ub2 do + begin + A^[I]^[K] := A^[I]^[K] / Scale; + T := T + Sqr(A^[I]^[K]); + end; + + F := A^[I]^[L]; + G := - DSgn(Sqrt(T), F); + H := F * G - T; + A^[I]^[L] := F - G; + + for K := L to Ub2 do + R^[K] := A^[I]^[K] / H; + + if I = Ub1 then goto 270; + + for J := L to Ub1 do + begin + T := 0.0; + for K := L to Ub2 do + T := T + A^[J]^[K] * A^[I]^[K]; + for K := L to Ub2 do + A^[J]^[K] := A^[J]^[K] + T * R^[K]; + end; + +270: for K := L to Ub2 do + A^[I]^[K] := Scale * A^[I]^[K]; + +290: X := FMax(X, Abs(S^[I]) + Abs(R^[I])); + end; + + { Accumulation of right-hand transformations } + for I := Ub2 downto Lb do + begin + if I = Ub2 then goto 390; + if G = 0.0 then goto 360; + + for J := L to Ub2 do + { Double division avoids possible underflow } + V^[J]^[I] := (A^[I]^[J] / A^[I]^[L]) / G; + + for J := L to Ub2 do + begin + T := 0.0; + for K := L to Ub2 do + T := T + A^[I]^[K] * V^[K]^[J]; + for K := L to Ub2 do + V^[K]^[J] := V^[K]^[J] + T * V^[K]^[I]; + end; + +360: for J := L to Ub2 do + begin + V^[I]^[J] := 0.0; + V^[J]^[I] := 0.0; + end; + +390: V^[I]^[I] := 1.0; + G := R^[I]; + L := I; + end; + + + { Accumulation of left-hand transformations } + Mn := IMin(Ub1, Ub2); + + for I := Mn downto Lb do + begin + L := I + 1; + G := S^[I]; + if I = Ub2 then goto 430; + + for J := L to Ub2 do + A^[I]^[J] := 0.0; + +430: if G = 0.0 then goto 475; + if I = Mn then goto 460; + + for J := L to Ub2 do + begin + T := 0.0; + + for K := L to Ub1 do + T := T + A^[K]^[I] * A^[K]^[J]; + + { Double division avoids possible underflow } + F := (T / A^[I]^[I]) / G; + + for K := I to Ub1 do + A^[K]^[J] := A^[K]^[J] + F * A^[K]^[I]; + end; + +460: for J := I to Ub1 do + A^[J]^[I] := A^[J]^[I] / G; + + goto 490; + +475: for J := I to Ub1 do + A^[J]^[I] := 0.0; + +490: A^[I]^[I] := A^[I]^[I] + 1.0; + end; + + { Diagonalization of the bidiagonal form } + Tst1 := X; + for K := Ub2 downto Lb do + begin + K1 := K - 1; + Its := 0; + +520: { Test for splitting } + for L := K downto Lb do + begin + L1 := L - 1; + Tst2 := Tst1 + Abs(R^[L]); + if Tst2 = Tst1 then goto 565; + { R^[Lb] is always zero, so there is no exit + through the bottom of the loop } + Tst2 := Tst1 + Abs(S^[L1]); + if Tst2 = Tst1 then goto 540; + end; + +540: { Cancellation of R^[L] if L greater than 1 } + C := 0.0; + T := 1.0; + + for I := L to K do + begin + F := T * R^[I]; + R^[I] := C * R^[I]; + Tst2 := Tst1 + Abs(F); + if Tst2 = Tst1 then goto 565; + G := S^[I]; + H := Pythag(F, G); + S^[I] := H; + C := G / H; + T := - F / H; + + for J := Lb to Ub1 do + begin + Y := A^[J]^[L1]; + Z := A^[J]^[I]; + A^[J]^[L1] := Y * C + Z * T; + A^[J]^[I] := - Y * T + Z * C; + end; + end; + +565: { Test for convergence } + Z := S^[K]; + if L = K then goto 650; + + if Its = 30 then + begin + SetErrCode(MatNonConv); + DelVector(R, Ub2); + Exit; + end; + + { Shift from bottom 2 by 2 minor } + Its := Its + 1; + X := S^[L]; + Y := S^[K1]; + G := R^[K1]; + H := R^[K]; + F := 0.5 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y); + G := Pythag(F, 1.0); + F := X - (Z / X) * Z + (H / X) * (Y / (F + DSgn(G, F)) - H); + + { Next QR transformation } + C := 1.0; + T := 1.0; + + for I1 := L to K1 do + begin + I := I1 + 1; + G := R^[I]; + Y := S^[I]; + H := T * G; + G := C * G; + Z := Pythag(F, H); + R^[I1] := Z; + C := F / Z; + T := H / Z; + F := X * C + G * T; + G := - X * T + G * C; + H := Y * T; + Y := Y * C; + + for J := Lb to Ub2 do + begin + X := V^[J]^[I1]; + Z := V^[J]^[I]; + V^[J]^[I1] := X * C + Z * T; + V^[J]^[I] := - X * T + Z * C; + end; + + Z := Pythag(F, H); + S^[I1] := Z; + { Rotation can be arbitrary if Z is zero } + if Z = 0.0 then goto 580; + C := F / Z; + T := H / Z; +580: F := C * G + T * Y; + X := - T * G + C * Y; + + for J := Lb to Ub1 do + begin + Y := A^[J]^[I1]; + Z := A^[J]^[I]; + A^[J]^[I1] := Y * C + Z * T; + A^[J]^[I] := - Y * T + Z * C; + end; + end; + + R^[L] := 0.0; + R^[K] := F; + S^[K] := X; + goto 520; + +650: { Convergence } + if Z >= 0.0 then goto 700; + + { S^[K] is made non-negative } + S^[K] := - Z; + + for J := Lb to Ub2 do + V^[J]^[K] := - V^[J]^[K]; +700: end; + + DelVector(R, Ub2); + SetErrCode(MatOk); + end; + +procedure SV_SetZero(S : PVector; + Lb, Ub : Integer; + Tol : Float); + var + Threshold : Float; + I : Integer; + begin + Threshold := S^[Lb]; + for I := Lb + 1 to Ub do + if S^[I] > Threshold then Threshold := S^[I]; + Threshold := Tol * Threshold; + for I := Lb to Ub do + if S^[I] < Threshold then S^[I] := 0.0; + end; + +procedure SV_Solve(U : PMatrix; + S : PVector; + V : PMatrix; + B : PVector; + Lb, Ub1, Ub2 : Integer; + X : PVector); + var + I, J, K : Integer; + Sum : Float; + Tmp : PVector; + begin + DimVector(Tmp, Ub2); + + for J := Lb to Ub2 do + begin + Sum := 0.0; + if S^[J] > 0.0 then + begin + for I := Lb to Ub1 do + Sum := Sum + U^[I]^[J] * B^[I]; + Sum := Sum / S^[J]; + end; + Tmp^[J] := Sum; + end; + + for J := Lb to Ub2 do + begin + Sum := 0.0; + for K := Lb to Ub2 do + Sum := Sum + V^[J]^[K] * Tmp^[K]; + X^[J] := Sum; + end; + + DelVector(Tmp, Ub2); + end; + +procedure SV_Approx(U : PMatrix; + S : PVector; + V : PMatrix; + Lb, Ub1, Ub2 : Integer; + A : PMatrix); + var + I, J, K : Integer; + begin + for I := Lb to Ub1 do + for J := Lb to Ub2 do + begin + A^[I]^[J] := 0.0; + for K := Lb to Ub2 do + if S^[K] > 0.0 then + A^[I]^[J] := A^[I]^[J] + U^[I]^[K] * V^[J]^[K]; + end; + end; + +end. diff --git a/fpmath/usvd.ppu b/fpmath/usvd.ppu new file mode 100644 index 0000000..9478fe5 Binary files /dev/null and b/fpmath/usvd.ppu differ diff --git a/fpmath/usvdfit.o b/fpmath/usvdfit.o new file mode 100644 index 0000000..9437985 Binary files /dev/null and b/fpmath/usvdfit.o differ diff --git a/fpmath/usvdfit.pas b/fpmath/usvdfit.pas new file mode 100755 index 0000000..06f4537 --- /dev/null +++ b/fpmath/usvdfit.pas @@ -0,0 +1,200 @@ +{ ****************************************************************** + Multiple linear regression (Singular Value Decomposition) + ****************************************************************** } + +unit usvdfit; + +interface + +uses + utypes, usvd; + +procedure SVDFit(X : PMatrix; + Y : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + SVDTol : Float; + B : PVector; + V : PMatrix); +{ ------------------------------------------------------------------ + Multiple linear regression: Y = B(0) + B(1) * X + B(2) * X2 + ... + ------------------------------------------------------------------ + Input parameters: X = matrix of independent variables + Y = vector of dependent variable + Lb, Ub = array bounds + Nvar = number of independent variables + ConsTerm = presence of constant term B(0) + Output parameters: B = regression parameters + V = inverse matrix + ------------------------------------------------------------------ } + +procedure WSVDFit(X : PMatrix; + Y, S : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + SVDTol : Float; + B : PVector; + V : PMatrix); +{ ---------------------------------------------------------------------- + Weighted multiple linear regression + ---------------------------------------------------------------------- + S = standard deviations of observations + Other parameters as in SVDFit + ---------------------------------------------------------------------- } + +implementation + + type + TRegMode = (UNWEIGHTED, WEIGHTED); + + procedure GenSVDFit(Mode : TRegMode; + X : PMatrix; + Y, S : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + SVDTol : Float; + B : PVector; + V : PMatrix); +{ ---------------------------------------------------------------------- + General multiple linear regression routine (SVD algorithm) + ---------------------------------------------------------------------- } + var + U : PMatrix; { Matrix of independent variables for SVD } + Z : PVector; { Vector of dependent variables for SVD } + S1 : PVector; { Singular values } + S2inv : PVector; { Inverses of squared singular values } + V1 : PMatrix; { Orthogonal matrix from SVD } + LbU : Integer; { Lower bound of U matrix in both dim. } + UbU : Integer; { Upper bound of U matrix in 1st dim. } + I, J, K : Integer; { Loop variables } + Sigma : Float; { Square root of weight } + Sum : Float; { Element of variance-covariance matrix } + + begin + if Ub - Lb < Nvar then + begin + SetErrCode(MatErrDim); + Exit; + end; + + if Mode = WEIGHTED then + for K := Lb to Ub do + if S^[K] <= 0.0 then + begin + SetErrCode(MatSing); + Exit; + end; + + { ---------------------------------------------------------- + Prepare arrays for SVD : + If constant term, use U[0..(N - Lb), 0..Nvar] + and Z[0..(N - Lb)] + else use U[1..(N - Lb + 1), 1..Nvar] + and Z[1..(N - Lb + 1)] + since the lower bounds of U for the SVD routine must be + the same in both dimensions + ---------------------------------------------------------- } + + if ConsTerm then + begin + LbU := 0; + UbU := Ub - Lb; + end + else + begin + LbU := 1; + UbU := Ub - Lb + 1; + end; + + { Dimension arrays } + DimMatrix(U, UbU, Nvar); + DimVector(Z, UbU); + DimVector(S1, Nvar); + DimVector(S2inv, Nvar); + DimMatrix(V1, Nvar, Nvar); + + if Mode = UNWEIGHTED then + for I := LbU to UbU do + begin + K := I - LbU + Lb; + Z^[I] := Y^[K]; + if ConsTerm then + U^[I]^[0] := 1.0; + for J := 1 to Nvar do + U^[I]^[J] := X^[K]^[J]; + end + else + for I := LbU to UbU do + begin + K := I - LbU + Lb; + Sigma := 1.0 / S^[K]; + Z^[I] := Y^[K] * Sigma; + if ConsTerm then + U^[I]^[0] := Sigma; + for J := 1 to Nvar do + U^[I]^[J] := X^[K]^[J] * Sigma; + end; + + { Perform singular value decomposition } + SV_Decomp(U, LbU, UbU, Nvar, S1, V1); + + if MathErr = MatOk then + begin + { Set the lowest singular values to zero } + SV_SetZero(S1, LbU, Nvar, SVDTol); + + { Solve the system } + SV_Solve(U, S1, V1, Z, LbU, UbU, Nvar, B); + + { Compute variance-covariance matrix } + for I := LbU to Nvar do + if S1^[I] > 0.0 then + S2inv^[I] := 1.0 / Sqr(S1^[I]) + else + S2inv^[I] := 0.0; + for I := LbU to Nvar do + for J := LbU to I do + begin + Sum := 0.0; + for K := LbU to Nvar do + Sum := Sum + V1^[I]^[K] * V1^[J]^[K] * S2inv^[K]; + V^[I]^[J] := Sum; + V^[J]^[I] := Sum; + end; + end; + + DelMatrix(U, UbU, Nvar); + DelVector(Z, UbU); + DelVector(S1, Nvar); + DelVector(S2inv, Nvar); + DelMatrix(V1, Nvar, Nvar); + end; + +procedure SVDFit(X : PMatrix; + Y : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + SVDTol : Float; + B : PVector; + V : PMatrix); + + var + S : PVector; + begin + S := nil; + GenSVDFit(UNWEIGHTED, X, Y, S, Lb, Ub, Nvar, ConsTerm, SVDTol, B, V); + end; + +procedure WSVDFit(X : PMatrix; + Y, S : PVector; + Lb, Ub, Nvar : Integer; + ConsTerm : Boolean; + SVDTol : Float; + B : PVector; + V : PMatrix); + + begin + GenSVDFit(WEIGHTED, X, Y, S, Lb, Ub, Nvar, ConsTerm, SVDTol, B, V); + end; + +end. \ No newline at end of file diff --git a/fpmath/usvdfit.ppu b/fpmath/usvdfit.ppu new file mode 100644 index 0000000..e5402a1 Binary files /dev/null and b/fpmath/usvdfit.ppu differ diff --git a/fpmath/utrapint.pas b/fpmath/utrapint.pas new file mode 100755 index 0000000..cdc967c --- /dev/null +++ b/fpmath/utrapint.pas @@ -0,0 +1,31 @@ +{ ****************************************************************** + Trapezoidal integration + ****************************************************************** } + +unit utrapint; + +interface + +uses + utypes; + +function TrapInt(X, Y : PVector; N : Integer) : Float; +{ Integration by trapezoidal rule, from (X^[0], Y^[0]) to (X^[N], Y^[N]) } + +implementation + +function TrapInt(X, Y : PVector; N : Integer) : Float; + var + Sum : Float; + I, J : Integer; + begin + Sum := 0.0; + for I := 0 to Pred(N) do + begin + J := Succ(I); + Sum := Sum + 0.5 * (X^[J] - X^[I]) * (Y^[J] + Y^[I]); + end; + TrapInt := Sum; + end; + +end. \ No newline at end of file diff --git a/fpmath/utrigo.o b/fpmath/utrigo.o new file mode 100644 index 0000000..9fd77f4 Binary files /dev/null and b/fpmath/utrigo.o differ diff --git a/fpmath/utrigo.pas b/fpmath/utrigo.pas new file mode 100755 index 0000000..8d56be2 --- /dev/null +++ b/fpmath/utrigo.pas @@ -0,0 +1,113 @@ +{ ****************************************************************** + Trigonometric functions + ****************************************************************** } + +unit utrigo; + +interface + +uses + utypes, uminmax; + +function Pythag(X, Y : Float) : Float; { Sqrt(X^2 + Y^2) } +function FixAngle(Theta : Float) : Float; { Set Theta in -Pi..Pi } +function Tan(X : Float) : Float; { Tangent } +function ArcSin(X : Float) : Float; { Arc sinus } +function ArcCos(X : Float) : Float; { Arc cosinus } +function ArcTan2(Y, X : Float) : Float; { Angle (Ox, OM) with M(X,Y) } + +implementation + + function Pythag(X, Y : Float) : Float; + { Computes Sqrt(X^2 + Y^2) without destructive underflow or overflow } + var + AbsX, AbsY : Float; + begin + SetErrCode(FOk); + AbsX := Abs(X); + AbsY := Abs(Y); + if AbsX > AbsY then + Pythag := AbsX * Sqrt(1.0 + Sqr(AbsY / AbsX)) + else if AbsY = 0.0 then + Pythag := 0.0 + else + Pythag := AbsY * Sqrt(1.0 + Sqr(AbsX / AbsY)); + end; + + function FixAngle(Theta : Float) : Float; + begin + SetErrCode(FOk); + while Theta > Pi do + Theta := Theta - TwoPi; + while Theta <= - PI do + Theta := Theta + TwoPi; + FixAngle := Theta; + end; + + function Tan(X : Float) : Float; + var + SinX, CosX : Float; + begin + SetErrCode(FOk); + SinX := Sin(X); + CosX := Cos(X); + if CosX = 0.0 then + Tan := DefaultVal(FSing, Sgn(SinX) * MaxNum) + else + Tan := SinX / CosX; + end; + + function ArcSin(X : Float) : Float; + begin + SetErrCode(FOk); + if (X < - 1.0) or (X > 1.0) then + ArcSin := DefaultVal(FDomain, 0.0) + else if X = 1.0 then + ArcSin := PiDiv2 + else if X = - 1.0 then + ArcSin := - PiDiv2 + else + ArcSin := ArcTan(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcCos(X : Float) : Float; + begin + SetErrCode(FOk); + if (X < - 1.0) or (X > 1.0) then + ArcCos := DefaultVal(FDomain, 0.0) + else if X = 1.0 then + ArcCos := 0.0 + else if X = - 1.0 then + ArcCos := Pi + else + ArcCos := PiDiv2 - ArcTan(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcTan2(Y, X : Float) : Float; + var + Theta : Float; + begin + SetErrCode(FOk); + if X = 0.0 then + if Y = 0.0 then + ArcTan2 := 0.0 + else if Y > 0.0 then + ArcTan2 := PiDiv2 + else + ArcTan2 := - PiDiv2 + else + begin + { 4th/1st quadrant -Pi/2..Pi/2 } + Theta := ArcTan(Y / X); + + { 2nd/3rd quadrants } + if X < 0.0 then + if Y >= 0.0 then + Theta := Theta + Pi { 2nd quadrant: Pi/2..Pi } + else + Theta := Theta - Pi; { 3rd quadrant: -Pi..-Pi/2 } + ArcTan2 := Theta; + end; + end; + +end. \ No newline at end of file diff --git a/fpmath/utrigo.ppu b/fpmath/utrigo.ppu new file mode 100644 index 0000000..bef5fc0 Binary files /dev/null and b/fpmath/utrigo.ppu differ diff --git a/fpmath/utypes.o b/fpmath/utypes.o new file mode 100644 index 0000000..5ae8cb1 Binary files /dev/null and b/fpmath/utypes.o differ diff --git a/fpmath/utypes.pas b/fpmath/utypes.pas new file mode 100755 index 0000000..7e263d8 --- /dev/null +++ b/fpmath/utypes.pas @@ -0,0 +1,542 @@ +{ ****************************************************************** + Types and constants - Error handling - Dynamic arrays + ****************************************************************** + The default real type is DOUBLE (8-byte real). + Other types may be selected by defining the symbols: + + SINGLEREAL (Single precision, 4 bytes) + EXTENDEDREAL (Extended precision, 12 bytes) + ****************************************************************** } + +unit utypes; + +interface + +{$i types.inc} +{$ifdef fpc} {$mode delphi} {$endif} + +{ ------------------------------------------------------------------ + Error handling + ------------------------------------------------------------------ } + +procedure SetErrCode(ErrCode : Integer); +{ Sets the error code } + +function DefaultVal(ErrCode : Integer; DefVal : Float) : Float; +{ Sets error code and default function value } + +function MathErr : Integer; +{ Returns the error code } + +{ ------------------------------------------------------------------ + Dynamic arrays + ------------------------------------------------------------------ } + +procedure SetAutoInit(AutoInit : Boolean); +{ Sets the auto-initialization of arrays } + +procedure DimVector(var V : PVector; Ub : Integer); +{ Creates floating point vector V[0..Ub] } + +procedure DimIntVector(var V : PIntVector; Ub : Integer); +{ Creates integer vector V[0..Ub] } + +procedure DimCompVector(var V : PCompVector; Ub : Integer); +{ Creates complex vector V[0..Ub] } + +procedure DimBoolVector(var V : PBoolVector; Ub : Integer); +{ Creates boolean vector V[0..Ub] } + +procedure DimStrVector(var V : PStrVector; Ub : Integer); +{ Creates string vector V[0..Ub] } + +procedure DimMatrix(var A : PMatrix; Ub1, Ub2 : Integer); +{ Creates floating point matrix A[0..Ub1, 0..Ub2] } + +procedure DimIntMatrix(var A : PIntMatrix; Ub1, Ub2 : Integer); +{ Creates integer matrix A[0..Ub1, 0..Ub2] } + +procedure DimCompMatrix(var A : PCompMatrix; Ub1, Ub2 : Integer); +{ Creates complex matrix A[0..Ub1, 0..Ub2] } + +procedure DimBoolMatrix(var A : PBoolMatrix; Ub1, Ub2 : Integer); +{ Creates boolean matrix A[0..Ub1, 0..Ub2] } + +procedure DimStrMatrix(var A : PStrMatrix; Ub1, Ub2 : Integer); +{ Creates string matrix A[0..Ub1, 0..Ub2] } + +procedure DelVector(var V : PVector; Ub : Integer); +{ Deletes floating point vector V[0..Ub] } + +procedure DelIntVector(var V : PIntVector; Ub : Integer); +{ Deletes integer vector V[0..Ub] } + +procedure DelCompVector(var V : PCompVector; Ub : Integer); +{ Deletes complex vector V[0..Ub] } + +procedure DelBoolVector(var V : PBoolVector; Ub : Integer); +{ Deletes boolean vector V[0..Ub] } + +procedure DelStrVector(var V : PStrVector; Ub : Integer); +{ Deletes string vector V[0..Ub] } + +procedure DelMatrix(var A : PMatrix; Ub1, Ub2 : Integer); +{ Deletes floating point matrix A[0..Ub1, 0..Ub2] } + +procedure DelIntMatrix(var A : PIntMatrix; Ub1, Ub2 : Integer); +{ Deletes integer matrix A[0..Ub1, 0..Ub2] } + +procedure DelCompMatrix(var A : PCompMatrix; Ub1, Ub2 : Integer); +{ Deletes complex matrix A[0..Ub1, 0..Ub2] } + +procedure DelBoolMatrix(var A : PBoolMatrix; Ub1, Ub2 : Integer); +{ Deletes boolean matrix A[0..Ub1, 0..Ub2] } + +procedure DelStrMatrix(var A : PStrMatrix; Ub1, Ub2 : Integer); +{ Deletes string matrix A[0..Ub1, 0..Ub2] } + +implementation + +const + gAutoInit : Boolean = True; + +var + gErrCode : Integer; + +procedure SetErrCode(ErrCode : Integer); +begin + gErrCode := ErrCode; +end; + +function DefaultVal(ErrCode : Integer; DefVal : Float) : Float; +begin + SetErrCode(ErrCode); + DefaultVal := DefVal; +end; + +function MathErr : Integer; +begin + MathErr := gErrCode; +end; + +procedure SetAutoInit(AutoInit : Boolean); +begin + gAutoInit := AutoInit; +end; + +procedure DimVector(var V : PVector; Ub : Integer); +var + I : Integer; +begin + { Check bounds } + if (Ub < 0) or (Ub > MAX_FLT) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, (Ub + 1) * FltSize); + if V = nil then Exit; + + { Initialize vector } + if gAutoInit then + for I := 0 to Ub do + V^[I] := 0.0; +end; + +procedure DimIntVector(var V : PIntVector; Ub : Integer); +var + I : Integer; +begin + { Check bounds } + if (Ub < 0) or (Ub > MAX_INT) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, (Ub + 1) * IntSize); + if V = nil then Exit; + + { Initialize vector } + if gAutoInit then + for I := 0 to Ub do + V^[I] := 0; +end; + +procedure DimCompVector(var V : PCompVector; Ub : Integer); +var + I : Integer; +begin + { Check bounds } + if (Ub < 0) or (Ub > MAX_COMP) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, (Ub + 1) * CompSize); + if V = nil then Exit; + + { Initialize vector } + if gAutoInit then + for I := 0 to Ub do + begin + V^[I].X := 0.0; + V^[I].Y := 0.0; + end; +end; + +procedure DimBoolVector(var V : PBoolVector; Ub : Integer); +var + I : Integer; +begin + { Check bounds } + if (Ub < 0) or (Ub > MAX_BOOL) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, (Ub + 1) * BoolSize); + if V = nil then Exit; + + { Initialize vector } + if gAutoInit then + for I := 0 to Ub do + V^[I] := False; +end; + +procedure DimStrVector(var V : PStrVector; Ub : Integer); +var + I : Integer; +begin + { Check bounds } + if (Ub < 0) or (Ub > MAX_STR) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, (Ub + 1) * StrSize); + if V = nil then Exit; + + { Initialize vector } + if gAutoInit then + for I := 0 to Ub do + V^[I] := ''; +end; + +procedure DimMatrix(var A : PMatrix; Ub1, Ub2 : Integer); +var + I, J : Integer; + RowSize : Word; +begin + if (Ub1 < 0) or (Ub1 > MAX_VEC) or (Ub2 < 0) or (Ub2 > MAX_FLT) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, (Ub1 + 1) * PtrSize); + if A = nil then Exit; + + { Size of a row } + RowSize := (Ub2 + 1) * FltSize; + + { Allocate each row } + for I := 0 to Ub1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + if gAutoInit then + for I := 0 to Ub1 do + for J := 0 to Ub2 do + A^[I]^[J] := 0.0; +end; + +procedure DimIntMatrix(var A : PIntMatrix; Ub1, Ub2 : Integer); +var + I, J : Integer; + RowSize : Word; +begin + { Check bounds } + if (Ub1 < 0) or (Ub1 > MAX_VEC) or (Ub2 < 0) or (Ub2 > MAX_INT) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, (Ub1 + 1) * PtrSize); + if A = nil then Exit; + + { Size of a row } + RowSize := (Ub2 + 1) * IntSize; + + { Allocate each row } + for I := 0 to Ub1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + if gAutoInit then + for I := 0 to Ub1 do + for J := 0 to Ub2 do + A^[I]^[J] := 0; +end; + +procedure DimCompMatrix(var A : PCompMatrix; Ub1, Ub2 : Integer); +var + I, J : Integer; + RowSize : Word; +begin + { Check bounds } + if (Ub1 < 0) or (Ub1 > MAX_VEC) or (Ub2 < 0) or (Ub2 > MAX_COMP) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, (Ub1 + 1) * PtrSize); + if A = nil then Exit; + + { Size of a row } + RowSize := (Ub2 + 1) * CompSize; + + { Allocate each row } + for I := 0 to Ub1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + if gAutoInit then + for I := 0 to Ub1 do + for J := 0 to Ub2 do + begin + A^[I]^[J].X := 0.0; + A^[I]^[J].Y := 0.0; + end; +end; + +procedure DimBoolMatrix(var A : PBoolMatrix; Ub1, Ub2 : Integer); +var + I, J : Integer; + RowSize : Word; +begin + { Check bounds } + if (Ub1 < 0) or (Ub1 > MAX_VEC) or (Ub2 < 0) or (Ub2 > MAX_BOOL) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, (Ub1 + 1) * PtrSize); + if A = nil then Exit; + + { Size of a row } + RowSize := (Ub2 + 1) * BoolSize; + + { Allocate each row } + for I := 0 to Ub1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + if gAutoInit then + for I := 0 to Ub1 do + for J := 0 to Ub2 do + A^[I]^[J] := False; +end; + +procedure DimStrMatrix(var A : PStrMatrix; Ub1, Ub2 : Integer); +var + I, J : Integer; + RowSize : Word; +begin + { Check bounds } + if (Ub1 < 0) or (Ub1 > MAX_VEC) or (Ub2 < 0) or (Ub2 > MAX_STR) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, (Ub1 + 1) * PtrSize); + if A = nil then Exit; + + { Size of a row } + RowSize := (Ub2 + 1) * StrSize; + + { Allocate each row } + for I := 0 to Ub1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + if gAutoInit then + for I := 0 to Ub1 do + for J := 0 to Ub2 do + A^[I]^[J] := ''; +end; + +procedure DelVector(var V : PVector; Ub : Integer); +begin + if V <> nil then + begin + FreeMem(V, (Ub + 1) * FltSize); + V := nil; + end; +end; + +procedure DelIntVector(var V : PIntVector; Ub : Integer); +begin + if V <> nil then + begin + FreeMem(V, (Ub + 1) * IntSize); + V := nil; + end; +end; + +procedure DelCompVector(var V : PCompVector; Ub : Integer); +begin + if V <> nil then + begin + FreeMem(V, (Ub + 1) * CompSize); + V := nil; + end; +end; + +procedure DelBoolVector(var V : PBoolVector; Ub : Integer); +begin + if V <> nil then + begin + FreeMem(V, (Ub + 1) * BoolSize); + V := nil; + end; +end; + +procedure DelStrVector(var V : PStrVector; Ub : Integer); +begin + if V <> nil then + begin + FreeMem(V, (Ub + 1) * StrSize); + V := nil; + end; +end; + +procedure DelMatrix(var A : PMatrix; Ub1, Ub2 : Integer); +var + I : Integer; + RowSize : Word; +begin + if A <> nil then + begin + RowSize := (Ub2 + 1) * FltSize; + for I := Ub1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, (Ub1 + 1) * PtrSize); + A := nil; + end; +end; + +procedure DelIntMatrix(var A : PIntMatrix; Ub1, Ub2 : Integer); +var + I : Integer; + RowSize : Word; +begin + if A <> nil then + begin + RowSize := (Ub2 + 1) * IntSize; + for I := Ub1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, (Ub1 + 1) * PtrSize); + A := nil; + end; +end; + +procedure DelCompMatrix(var A : PCompMatrix; Ub1, Ub2 : Integer); +var + I : Integer; + RowSize : Word; +begin + if A <> nil then + begin + RowSize := (Ub2 + 1) * CompSize; + for I := Ub1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, (Ub1 + 1) * PtrSize); + A := nil; + end; +end; + +procedure DelBoolMatrix(var A : PBoolMatrix; Ub1, Ub2 : Integer); +var + I : Integer; + RowSize : Word; +begin + if A <> nil then + begin + RowSize := (Ub2 + 1) * BoolSize; + for I := Ub1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, (Ub1 + 1) * PtrSize); + A := nil; + end; +end; + +procedure DelStrMatrix(var A : PStrMatrix; Ub1, Ub2 : Integer); +var + I : Integer; + RowSize : Word; +begin + if A <> nil then + begin + RowSize := (Ub2 + 1) * StrSize; + for I := Ub1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, (Ub1 + 1) * PtrSize); + A := nil; + end; +end; + +end. diff --git a/fpmath/utypes.ppu b/fpmath/utypes.ppu new file mode 100644 index 0000000..93c0143 Binary files /dev/null and b/fpmath/utypes.ppu differ diff --git a/fpmath/uwinplot.pas b/fpmath/uwinplot.pas new file mode 100755 index 0000000..4747dd4 --- /dev/null +++ b/fpmath/uwinplot.pas @@ -0,0 +1,1314 @@ +{ ****************************************************************** + Plotting routines for Delphi + ****************************************************************** } + +unit uwinplot; + +interface + +uses + Classes, Graphics, + utypes, umath, uround, uinterv, ustrings; + +function InitGraphics(Canvas : TCanvas; Width, Height : Integer) : Boolean; + +{ ------------------------------------------------------------------ + Enters graphic mode. + ------------------------------------------------------------------ + The parameters Width and Height refer to the object on which the + graphic is plotted. + + Examples: + + To draw on a TImage object: + InitGraph(Image1.Canvas, Image1.Width, Image1.Height) + + To print the graphic: + InitGraph(Printer.Canvas, Printer.PageWidth, Printer.PageHeight) + ------------------------------------------------------------------ } + +procedure SetWindow(Canvas : TCanvas; + X1, X2, Y1, Y2 : Integer; + GraphBorder : Boolean); +{ ------------------------------------------------------------------ + Sets the graphic window + + X1, X2, Y1, Y2 : Window coordinates in % of maximum + GraphBorder : Flag for drawing the window border + ------------------------------------------------------------------ } + +procedure AutoScale(X : PVector; + Lb, Ub : Integer; + Scale : TScale; + var XMin, XMax, XStep : Float); +{ ------------------------------------------------------------------ + Finds an appropriate scale for plotting the data in X[Lb..Ub] + ------------------------------------------------------------------ } + +procedure SetOxScale(Scale : TScale; + OxMin, OxMax, OxStep : Float); +{ ------------------------------------------------------------------ + Sets the scale on the Ox axis + ------------------------------------------------------------------ } + +procedure SetOyScale(Scale : TScale; + OyMin, OyMax, OyStep : Float); +{ ------------------------------------------------------------------ + Sets the scale on the Oy axis + ------------------------------------------------------------------ } + +procedure SetGraphTitle(Title : String); +{ ------------------------------------------------------------------ + Sets the title for the graph + ------------------------------------------------------------------ } + +procedure SetOxTitle(Title : String); +{ ------------------------------------------------------------------ + Sets the title for the Ox axis + ------------------------------------------------------------------ } + +procedure SetOyTitle(Title : String); +{ ------------------------------------------------------------------ + Sets the title for the Oy axis + ------------------------------------------------------------------ } + +procedure PlotOxAxis(Canvas : TCanvas); +{ ------------------------------------------------------------------ + Plots the horizontal axis + ------------------------------------------------------------------ } + +procedure PlotOyAxis(Canvas : TCanvas); +{ ------------------------------------------------------------------ + Plots the vertical axis + ------------------------------------------------------------------ } + +procedure PlotGrid(Canvas : TCanvas; Grid : TGrid); +{ ------------------------------------------------------------------ + Plots a grid on the graph + ------------------------------------------------------------------ } + +procedure WriteGraphTitle(Canvas : TCanvas); +{ ------------------------------------------------------------------ + Writes the title of the graph + ------------------------------------------------------------------ } + +procedure SetMaxCurv(NCurv : Byte); +{ ------------------------------------------------------------------ + Sets the maximum number of curves and re-initializes their + parameters + ------------------------------------------------------------------ } + +procedure SetPointParam(CurvIndex, Symbol, Size : Integer; + Color : TColor); +{ ------------------------------------------------------------------ + Sets the point parameters for curve # CurvIndex + ------------------------------------------------------------------ } + +procedure SetLineParam(CurvIndex : Integer; + Style : TPenStyle; + Width : Integer; + Color : TColor); +{ ------------------------------------------------------------------ + Sets the line parameters for curve # CurvIndex + ------------------------------------------------------------------ } + +procedure SetCurvLegend(CurvIndex : Integer; Legend : String); +{ ------------------------------------------------------------------ + Sets the legend for curve # CurvIndex + ------------------------------------------------------------------ } + +procedure SetCurvStep(CurvIndex, Step : Integer); +{ ------------------------------------------------------------------ + Sets the step for curve # CurvIndex + ------------------------------------------------------------------ } + +procedure PlotPoint(Canvas : TCanvas; + X, Y : Float; + CurvIndex : Integer); +{ ------------------------------------------------------------------ + Plots a point on the screen + ------------------------------------------------------------------ + Input parameters : X, Y = point coordinates + CurvIndex = index of curve parameters + (Symbol, Size, Color) + ------------------------------------------------------------------ } + +procedure PlotCurve(Canvas : TCanvas; + X, Y : PVector; + Lb, Ub, + CurvIndex : Integer); +{ ------------------------------------------------------------------ + Plots a curve + ------------------------------------------------------------------ + Input parameters : X, Y = point coordinates + Lb, Ub = indices of first and last points + CurvIndex = index of curve parameters + ------------------------------------------------------------------ } + +procedure PlotCurveWithErrorBars(Canvas : TCanvas; + X, Y, S : PVector; + Ns, Lb, Ub, + CurvIndex : Integer); +{ ------------------------------------------------------------------ + Plots a curve with error bars + ------------------------------------------------------------------ + Input parameters : X, Y = point coordinates + S = errors + Ns = number of SD to be plotted + Lb, Ub = indices of first and last points + CurvIndex = index of curve parameters + ------------------------------------------------------------------ } + +procedure PlotFunc(Canvas : TCanvas; + Func : TFunc; + Xmin, Xmax : Float; + Npt, + CurvIndex : Integer); +{ ------------------------------------------------------------------ + Plots a function + ------------------------------------------------------------------ + Input parameters: + Func = function to be plotted + Xmin, Xmax = abscissae of 1st and last point to plot + Npt = number of points + CurvIndex = index of curve parameters (Width, Style, Color) + ------------------------------------------------------------------ + The function must be programmed as : + function Func(X : Float) : Float; + ------------------------------------------------------------------ } + +procedure WriteLegend(Canvas : TCanvas; + NCurv : Integer; + ShowPoints, + ShowLines : Boolean); +{ ------------------------------------------------------------------ + Writes the legends for the plotted curves + ------------------------------------------------------------------ + NCurv : number of curves (1 to MaxCurv) + ShowPoints : for displaying points + ShowLines : for displaying lines + ------------------------------------------------------------------ } + +procedure ConRec(Canvas : TCanvas; + Nx, Ny, Nc : Integer; + X, Y, Z : PVector; + F : PMatrix); +{ ------------------------------------------------------------------ + Contour plot + Adapted from Paul Bourke, Byte, June 1987 + http://astronomy.swin.edu.au/~pbourke/projection/conrec/ + ------------------------------------------------------------------ + Input parameters: + Nx, Ny = number of steps on Ox and Oy + Nc = number of contour levels + X[0..Nx], Y[0..Ny] = point coordinates in pixels + Z[0..(Nc - 1)] = contour levels in increasing order + F[0..Nx, 0..Ny] = function values, such that F[I,J] is the + function value at (X[I], Y[I]) + ------------------------------------------------------------------ } + +function Xpixel(X : Float) : Integer; +{ ------------------------------------------------------------------ + Converts user abscissa X to screen coordinate + ------------------------------------------------------------------ } + +function Ypixel(Y : Float) : Integer; +{ ------------------------------------------------------------------ + Converts user ordinate Y to screen coordinate + ------------------------------------------------------------------ } + +function Xuser(X : Integer) : Float; +{ ------------------------------------------------------------------ + Converts screen coordinate X to user abscissa + ------------------------------------------------------------------ } + +function Yuser(Y : Integer) : Float; +{ ------------------------------------------------------------------ + Converts screen coordinate Y to user ordinate + ------------------------------------------------------------------ } + +procedure LeaveGraphics; +{ ------------------------------------------------------------------ + Quits graphic mode + ------------------------------------------------------------------ } + + +implementation + +const + MaxSymbol = 9; { Max. number of symbols for plotting curves } + MaxCurvColor = 9; { Max. number of colors for curves } + Eps = 1.0E-10; { Lower limit for an axis label } + MaxColor = $02FFFFFF; { Max. color value for Delphi } + +const + CurvColor : array[1..MaxCurvColor] of TColor = + (clRed, + clGreen, + clBlue, + clFuchsia, + clAqua, + clLime, + clNavy, + clOlive, + clPurple); + +type + TAxis = record { Coordinate axis } + Scale : TScale; + Min : Float; + Max : Float; + Step : Float; + end; + + TPointParam = record { Point parameters } + Symbol : Integer; { Symbol: 0: point (.) } + Size : Integer; { 1: solid circle 2: open circle } + Color : TColor; { 3: solid square 4: open square } + end; { 5: solid triangle 6: open triangle } + { 7: plus (+) 8: multiply (x) } + { 9: star (* ) } + + TLineParam = record { Line parameters } + Style : TPenStyle; + Width : Integer; + Color : TColor; + end; + + TCurvParam = record { Curve parameters } + PointParam : TPointParam; + LineParam : TLineParam; + Legend : Str30; { Legend of curve } + Step : Integer; { Plot 1 point every Step points } + end; + + TCurvParamVector = array[1..255] of TCurvParam; + PCurvParamVector = ^TCurvParamVector; + +var + Xwin1, Xwin2, Ywin1, Ywin2 : Integer; + XminPixel, XmaxPixel : Integer; + YminPixel, YmaxPixel : Integer; + FactX, FactY : Float; + XAxis, YAxis : TAxis; + GraphTitle, XTitle, YTitle : String; + MaxCurv : Integer; + CurvParam : PCurvParamVector; + GraphWidth, GraphHeight : Integer; + SymbolSizeUnit : Integer; + PenWidth : Integer; + PenStyle : TPenStyle; + PenColor, BrushColor : TColor; + BrushStyle : TBrushStyle; + +procedure DimCurvParamVector(var CurvParam : PCurvParamVector; Ub : Byte); +var + I : Integer; +begin + { Allocate vector } + GetMem(CurvParam, Ub * SizeOf(TCurvParam)); + if CurvParam = nil then Exit; + + MaxCurv := Ub; + + { Initialize curve parameters } + for I := 1 to Ub do + with CurvParam^[I] do + begin + PointParam.Symbol := (I - 1) mod MaxSymbol + 1; + PointParam.Size := 2; + PointParam.Color := CurvColor[(I - 1) mod MaxCurvColor + 1]; + Legend := 'Curve ' + LTrim(IntStr(I)); + LineParam.Width := 1; + LineParam.Style := psSolid; + LineParam.Color := PointParam.Color; + Step := 1; + end; +end; + +procedure DelCurvParamVector(var CurvParam : PCurvParamVector; Ub : Byte); +begin + if CurvParam <> nil then + begin + FreeMem(CurvParam, Ub * SizeOf(TCurvParam)); + CurvParam := nil; + MaxCurv := 0; + end; +end; + +function InitGraphics(Canvas : TCanvas; Width, Height : Integer) : Boolean; +begin + GraphWidth := Width; + GraphHeight := Height; + SymbolSizeUnit := GraphWidth div 250; + + XmaxPixel := Width; + YmaxPixel := Height; + + XminPixel := 0; + YminPixel := 0; + + XTitle := 'X'; + YTitle := 'Y'; + GraphTitle := ''; + + MaxCurv := MaxSymbol; + DimCurvParamVector(CurvParam, MaxCurv); + + InitGraphics := True; +end; + +procedure SetWindow(Canvas : TCanvas; + X1, X2, Y1, Y2 : Integer; + GraphBorder : Boolean); +var + R : Float; +begin + if (X1 >= 0) and (X2 <= 100) and (X1 < X2) then + begin + Xwin1 := X1; + Xwin2 := X2; + R := 0.01 * GraphWidth; + XminPixel := Round(X1 * R); + XmaxPixel := Round(X2 * R); + end; + + if (Y1 >= 0) and (Y2 <= 100) and (Y1 < Y2) then + begin + Ywin1 := Y1; + Ywin2 := Y2; + R := 0.01 * GraphHeight; + YminPixel := Round(Y1 * R); + YmaxPixel := Round(Y2 * R); + end; + + XAxis.Scale := LinScale; + XAxis.Min := 0.0; + XAxis.Max := 1.0; + XAxis.Step := 0.2; + + YAxis.Scale := LinScale; + YAxis.Min := 0.0; + YAxis.Max := 1.0; + YAxis.Step := 0.2; + + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); + + if GraphBorder then + Canvas.Rectangle(XminPixel, YminPixel, Succ(XmaxPixel), Succ(YmaxPixel)); +end; + +procedure AutoScale(X : PVector; Lb, Ub : Integer; Scale : TScale; + var XMin, XMax, XStep : Float); +var + I : Integer; + X1, X2 : Float; +begin + { Minimum and maximum of X } + + X1 := X^[Lb]; + X2 := X1; + for I := Lb to Ub do + if X^[I] < X1 then + X1 := X^[I] + else if X^[I] > X2 then + X2 := X^[I]; + + { Linear scale } + + if Scale = LinScale then + begin + Interval(X1, X2, 2, 6, XMin, XMax, XStep); + Exit; + end; + + { Logarithmic scale } + + XMin := 1.0E-3; + XMax := 1.0E+3; + XStep := 10.0; + + if X1 <= 0.0 then Exit; + + XMin := Int(Log10(X1)); if X1 < 1.0 then XMin := XMin - 1.0; + XMax := Int(Log10(X2)); if X2 > 1.0 then XMax := XMax + 1.0; + XMin := Exp10(XMin); + XMax := Exp10(XMax); +end; + +procedure SetOxScale(Scale : TScale; OxMin, OxMax, OxStep : Float); +begin + XAxis.Scale := Scale; + case Scale of + LinScale : + begin + if OxMin < OxMax then + begin + XAxis.Min := OxMin; + XAxis.Max := OxMax; + end; + if OxStep > 0.0 then XAxis.Step := OxStep; + end; + LogScale : + begin + if (OxMin > 0.0) and (OxMin < OxMax) then + begin + XAxis.Min := Floor(Log10(OxMin)); + XAxis.Max := Ceil(Log10(OxMax)); + end; + XAxis.Step := 1.0; + end; + end; + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); +end; + +procedure SetOyScale(Scale : TScale; OyMin, OyMax, OyStep : Float); +begin + YAxis.Scale := Scale; + case Scale of + LinScale : + begin + if OyMin < OyMax then + begin + YAxis.Min := OyMin; + YAxis.Max := OyMax; + end; + if OyStep > 0.0 then YAxis.Step := OyStep; + end; + LogScale : + begin + if (OyMin > 0.0) and (OyMin < OyMax) then + begin + YAxis.Min := Floor(Log10(OyMin)); + YAxis.Max := Ceil(Log10(OyMax)); + end; + YAxis.Step := 1.0; + end; + end; + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); +end; + +function Xpixel(X : Float) : Integer; +var + P : Float; +begin + P := FactX * (X - XAxis.Min); + if Abs(P) > 30000 then + Xpixel := 30000 + else + Xpixel := Round(P) + XminPixel; +end; + +function Ypixel(Y : Float) : Integer; +var + P : Float; +begin + P := FactY * (YAxis.Max - Y); + if Abs(P) > 30000 then + Ypixel := 30000 + else + Ypixel := Round(P) + YminPixel; +end; + +function Xuser(X : Integer) : Float; +begin + Xuser := XAxis.Min + (X - XminPixel) / FactX; +end; + +function Yuser(Y : Integer) : Float; +begin + Yuser := YAxis.Max - (Y - YminPixel) / FactY; +end; + +procedure SetGraphTitle(Title : String); +begin + GraphTitle := Title; +end; + +procedure SetOxTitle(Title : String); +begin + XTitle := Title; +end; + +procedure SetOyTitle(Title : String); +begin + YTitle := Title; +end; + +procedure PlotLine(Canvas : TCanvas; X1, Y1, X2, Y2 : Integer); +begin + Canvas.MoveTo(X1, Y1); + Canvas.LineTo(X2, Y2); +end; + +procedure PlotOxAxis(Canvas : TCanvas); +var + W, X, Z : Float; + Wp, Xp, Yp1, Yp2 : Integer; + N, I, J : Integer; + TickLength : Integer; + MinorTickLength : Integer; + XLabel : String; +begin + TickLength := Canvas.TextHeight('M') div 2; + MinorTickLength := Round(0.67 * TickLength); + + PlotLine(Canvas, XminPixel, YmaxPixel, XmaxPixel, YmaxPixel); + + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + X := XAxis.Min; { Tick mark position } + + Yp1 := YmaxPixel + TickLength; { End of tick mark } + Yp2 := YmaxPixel + MinorTickLength; { End of minor tick mark (log scale) } + + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LinScale) and (Abs(X) < Eps) then X := 0.0; + + Xp := Xpixel(X); + + PlotLine(Canvas, Xp, YmaxPixel, Xp, Yp1); + + if XAxis.Scale = LinScale then Z := X else Z := Exp10(X); + + XLabel := Trim(FloatStr(Z)); + + Canvas.TextOut(Xp - Canvas.TextWidth(XLabel) div 2, Yp1, XLabel); + + { Plot minor divisions on logarithmic scale } + + if (XAxis.Scale = LogScale) and (I < N) then + for J := 2 to 9 do + begin + W := X + Log10(J); + Wp := Xpixel(W); + PlotLine(Canvas, Wp, YmaxPixel, Wp, Yp2); + end; + + X := X + XAxis.Step; + end; + + { Write axis title } + + if XTitle <> '' then + Canvas.TextOut(XminPixel + (XmaxPixel - XminPixel - + Canvas.TextWidth(XTitle)) div 2, + YmaxPixel + 4 * TickLength, XTitle); +end; + +procedure PlotOyAxis(Canvas : TCanvas); +var + W, Y, Z : Float; + Wp, Xp1, Xp2, Yp : Integer; + N, I, J : Integer; + TickLength : Integer; + MinorTickLength : Integer; + Yoffset : Integer; + YLabel : String; +begin + TickLength := Canvas.TextWidth('M') div 2; + MinorTickLength := Round(0.67 * TickLength); + Yoffset := Canvas.TextHeight('M') div 2; + + PlotLine(Canvas, XminPixel, YminPixel, XminPixel, YmaxPixel); + + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); + Y := YAxis.Min; + + Xp1 := XminPixel - TickLength; + Xp2 := XminPixel - MinorTickLength; + + for I := 0 to N do + begin + if (YAxis.Scale = LinScale) and (Abs(Y) < Eps) then Y := 0.0; + + Yp := Ypixel(Y); + + PlotLine(Canvas, XminPixel, Yp, Xp1, Yp); + + if YAxis.Scale = LinScale then Z := Y else Z := Exp10(Y); + + YLabel := Trim(FloatStr(Z)); + + Canvas.TextOut(Xp1 - Canvas.TextWidth(YLabel), Yp - Yoffset, YLabel); + + if (YAxis.Scale = LogScale) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + Wp := Ypixel(W); + PlotLine(Canvas, XminPixel, Wp, Xp2, Wp); + end; + + Y := Y + YAxis.Step; + end; + + if YTitle <> '' then + Canvas.TextOut(XminPixel, YminPixel - 3 * Yoffset, YTitle); +end; + +procedure PlotGrid(Canvas : TCanvas; Grid : TGrid); +var + X, Y : Float; + I, N, Xp, Yp : Integer; + +var + PenStyle : TpenStyle; + +begin + PenStyle := Canvas.Pen.Style; + Canvas.Pen.Style := psDot; + + if Grid in [HorizGrid, BothGrid] then { Horizontal lines } + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yp := Ypixel(Y); + PlotLine(Canvas, XminPixel, Yp, XmaxPixel, Yp); + end; + end; + + if Grid in [VertiGrid, BothGrid] then { Vertical lines } + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xp := Xpixel(X); + PlotLine(Canvas, Xp, YminPixel, Xp, YmaxPixel); + end; + end; + + Canvas.Pen.Style := PenStyle; +end; + +procedure WriteGraphTitle(Canvas : TCanvas); +begin + if GraphTitle <> '' then + with Canvas do + TextOut((XminPixel + XmaxPixel - TextWidth(GraphTitle)) div 2, + YminPixel - 2 * TextHeight(GraphTitle), GraphTitle); +end; + +procedure SetMaxCurv(NCurv : Byte); +begin + if NCurv < 1 then Exit; + DelCurvParamVector(CurvParam, MaxCurv); + MaxCurv := NCurv; + DimCurvParamVector(CurvParam, MaxCurv); +end; + +procedure SetPointParam(CurvIndex, Symbol, Size : Integer; + Color : TColor); +begin + if (CurvIndex < 1) or (CurvIndex > MaxCurv) then Exit; + + if (Symbol >= 0) and (Symbol <= MaxSymbol) then + CurvParam^[CurvIndex].PointParam.Symbol := Symbol; + + if Size > 0 then + CurvParam^[CurvIndex].PointParam.Size := Size; + + if (Color >= 0) and (Color <= MaxColor) then + CurvParam^[CurvIndex].PointParam.Color := Color; +end; + +procedure SetLineParam(CurvIndex : Integer; + Style : TPenStyle; + Width : Integer; + Color : TColor); + +begin + if (CurvIndex < 1) or (CurvIndex > MaxCurv) then Exit; + + CurvParam^[CurvIndex].LineParam.Style := Style; + + if Width > 0 then + CurvParam^[CurvIndex].LineParam.Width := Width; + + if (Color >= 0) and (Color <= MaxColor) then + CurvParam^[CurvIndex].LineParam.Color := Color; +end; + +procedure SetCurvLegend(CurvIndex : Integer; Legend : String); +begin + if (CurvIndex >= 1) and (CurvIndex <= MaxCurv) then + CurvParam^[CurvIndex].Legend := Legend; +end; + +procedure SetCurvStep(CurvIndex, Step : Integer); +begin + if (CurvIndex >= 1) and (CurvIndex <= MaxCurv) and (Step > 0) then + CurvParam^[CurvIndex].Step := Step; +end; + +function XOutOfBounds(X : Integer) : Boolean; +{ Checks if an absissa is outside the graphic bounds } +begin + XOutOfBounds := (X < XminPixel) or (X > XmaxPixel); +end; + +function YOutOfBounds(Y : Integer) : Boolean; +{ Checks if an ordinate is outside the graphic bounds } +begin + YOutOfBounds := (Y < YminPixel) or (Y > YmaxPixel); +end; + +function CheckPoint(X, Y : Float; + var Xp, Yp : Integer) : Boolean; +{ Computes the pixel coordinates of a point and + checks if it is enclosed within the graph limits } +begin + Xp := Xpixel(X); + Yp := Ypixel(Y); + CheckPoint := not(XOutOfBounds(Xp) or YOutOfBounds(Yp)); +end; + +procedure PlotSymbol(Canvas : TCanvas; + Xp, Yp, + CurvIndex : Integer); +var + Xp1, Xp2, Yp1, Yp2, Size : Integer; +begin + Size := CurvParam^[CurvIndex].PointParam.Size * SymbolSizeUnit; + + Xp1 := Xp - Size; + Yp1 := Yp - Size; + Xp2 := Xp + Size + 1; + Yp2 := Yp + Size + 1; + + with Canvas do + case CurvParam^[CurvIndex].PointParam.Symbol of + 0 : Pixels[Xp, Yp] := Brush.Color; + 1, 2 : Ellipse(Xp1, Yp1, Xp2, Yp2); { Circle } + 3, 4 : Rectangle(Xp1, Yp1, Xp2, Yp2); { Square } + 5, 6 : Polygon([Point(Xp1, Yp2 - 1), + Point(Xp2, Yp2 - 1), + Point(Xp, Yp1 - 1)]); { Triangle } + 7 : begin { + } + PlotLine(Canvas, Xp, Yp1, Xp, Yp2); + PlotLine(Canvas, Xp1, Yp, Xp2, Yp); + end; + 8 : begin { x } + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + PlotLine(Canvas, Xp1, Yp2 - 1, Xp2, Yp1 - 1); + end; + 9 : begin { * } + PlotLine(Canvas, Xp, Yp1, Xp, Yp2); + PlotLine(Canvas, Xp1, Yp, Xp2, Yp); + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + PlotLine(Canvas, Xp1, Yp2 - 1, Xp2, Yp1 - 1); + end; + end; +end; + +procedure SetGraphSettings(Canvas : TCanvas; CurvIndex : Integer); +{ Saves the current graphic properties of the Canvas + and sets them to the values of curve # CurvIndex } +begin + PenColor := Canvas.Pen.Color; + PenStyle := Canvas.Pen.Style; + PenWidth := Canvas.Pen.Width; + BrushColor := Canvas.Brush.Color; + BrushStyle := Canvas.Brush.Style; + + Canvas.Pen.Color := CurvParam^[CurvIndex].LineParam.Color; + Canvas.Pen.Style := CurvParam^[CurvIndex].LineParam.Style; + Canvas.Pen.Width := CurvParam^[CurvIndex].LineParam.Width; + Canvas.Brush.Color := CurvParam^[CurvIndex].PointParam.Color; + + if CurvParam^[CurvIndex].PointParam.Symbol in [0, 1, 3, 5] then + Canvas.Brush.Style := bsSolid + else + Canvas.Brush.Style := bsClear; +end; + +procedure RestoreGraphSettings(Canvas : TCanvas); +begin + Canvas.Pen.Color := PenColor; + Canvas.Pen.Style := PenStyle; + Canvas.Pen.Width := PenWidth; + Canvas.Brush.Color := BrushColor; + Canvas.Brush.Style := BrushStyle; +end; + +procedure PlotPoint(Canvas : TCanvas; + X, Y : Float; + CurvIndex : Integer); +var + Xp, Yp : Integer; +begin + if XAxis.Scale = LogScale then X := Log10(X); + if YAxis.Scale = LogScale then Y := Log10(Y); + + if not CheckPoint(X, Y, Xp, Yp) then Exit; + + SetGraphSettings(Canvas, CurvIndex); + PlotSymbol(Canvas, Xp, Yp, CurvIndex); + RestoreGraphSettings(Canvas); +end; + +procedure PlotErrorBar(Canvas : TCanvas; + Y, S : Float; + Ns, + Xp, Yp, Size : Integer); +{ Plots an error bar with the current canvas settings } +var + Delta, Y1 : Float; + Yp1 : Integer; + PenStyle : TPenStyle; +begin + Size := Size * SymbolSizeUnit; + PenStyle := Canvas.Pen.Style; + Canvas.Pen.Style := psSolid; + + Delta := Ns * S; + Y1 := Y - Delta; + if YAxis.Scale = LogScale then Y1 := Log10(Y1); + Yp1 := Ypixel(Y1); + + if Yp1 <= YmaxPixel then + begin + PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1); + PlotLine(Canvas, Xp, Yp, Xp, Yp1); + end + else + PlotLine(Canvas, Xp, Yp, Xp, YmaxPixel); + + Y1 := Y + Delta; + if YAxis.Scale = LogScale then Y1 := Log10(Y1); + Yp1 := Ypixel(Y1); + + if Yp1 >= YminPixel then + begin + PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1); + PlotLine(Canvas, Xp, Yp, Xp, Yp1); + end + else + PlotLine(Canvas, Xp, Yp, Xp, YminPixel); + + Canvas.Pen.Style := PenStyle; +end; + +procedure GenPlotCurve(Canvas : TCanvas; + X, Y, S : PVector; + Ns, + Lb, Ub, + CurvIndex : Integer; + ErrorBars : Boolean); +{ General curve plotting routine } +var + X1, Y1, X2, Y2 : Float; + Xp1, Yp1, Xp2, Yp2 : Integer; + I : Integer; + Flag1, Flag2 : Boolean; +begin + SetGraphSettings(Canvas, CurvIndex); + + { Plot first point } + + X1 := X^[Lb]; if XAxis.Scale = LogScale then X1 := Log10(X1); + Y1 := Y^[Lb]; if YAxis.Scale = LogScale then Y1 := Log10(Y1); + + Flag1 := CheckPoint(X1, Y1, Xp1, Yp1); + + if Flag1 then + begin + PlotSymbol(Canvas, Xp1, Yp1, CurvIndex); + if ErrorBars and (S^[Lb] > 0.0) then + PlotErrorBar(Canvas, Y^[Lb], S^[Lb], Ns, Xp1, Yp1, CurvIndex); + end; + + { Plot other points and connect them by lines if necessary } + + I := Lb + CurvParam^[CurvIndex].Step; + + while I <= Ub do + begin + X2 := X^[I]; if XAxis.Scale = LogScale then X2 := Log10(X2); + Y2 := Y^[I]; if YAxis.Scale = LogScale then Y2 := Log10(Y2); + + Flag2 := CheckPoint(X2, Y2, Xp2, Yp2); + + if Flag2 then + begin + PlotSymbol(Canvas, Xp2, Yp2, CurvIndex); + if ErrorBars and (S^[I] > 0.0) then + PlotErrorBar(Canvas, Y^[I], S^[I], Ns, Xp2, Yp2, CurvIndex); + if (CurvParam^[CurvIndex].LineParam.Style <> psClear) and Flag1 then + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + end; + + Xp1 := Xp2; + Yp1 := Yp2; + Flag1 := Flag2; + Inc(I, CurvParam^[CurvIndex].Step); + end; + + RestoreGraphSettings(Canvas); +end; + +procedure PlotCurve(Canvas : TCanvas; + X, Y : PVector; + Lb, Ub : Integer; + CurvIndex : Integer); +begin + GenPlotCurve(Canvas, X, Y, nil, 0, Lb, Ub, CurvIndex, False); +end; + +procedure PlotCurveWithErrorBars(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lb, Ub : Integer; + CurvIndex : Integer); +begin + GenPlotCurve(Canvas, X, Y, S, Ns, Lb, Ub, CurvIndex, True); +end; + +procedure PlotFunc(Canvas : TCanvas; + Func : TFunc; + Xmin, Xmax : Float; + Npt : Integer; + CurvIndex : Integer); +var + X1, Y1, X2, Y2, H : Float; + Xp1, Yp1, Xp2, Yp2 : Integer; + Flag1, Flag2 : Boolean; + I : Integer; +begin + if (Npt < 2) or (CurvParam^[CurvIndex].LineParam.Style = psClear) then Exit; + + if Xmin >= Xmax then + begin + Xmin := XAxis.Min; + Xmax := XAxis.Max; + end; + + H := (Xmax - Xmin) / Npt; + + SetGraphSettings(Canvas, CurvIndex); + + { Check first point } + X1 := Xmin; + if XAxis.Scale = LinScale then + Y1 := Func(X1) + else + Y1 := Func(Exp10(X1)); + + if YAxis.Scale = LogScale then Y1 := Log10(Y1); + Flag1 := CheckPoint(X1, Y1, Xp1, Yp1); + + { Check other points and plot lines if possible } + for I := 1 to Npt do + begin + X2 := X1 + H; + if XAxis.Scale = LinScale then + Y2 := Func(X2) + else + Y2 := Func(Exp10(X2)); + + if YAxis.Scale = LogScale then Y2 := Log10(Y2); + + Flag2 := CheckPoint(X2, Y2, Xp2, Yp2); + + if Flag1 and Flag2 then + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + + X1 := X2; + Xp1 := Xp2; + Yp1 := Yp2; + Flag1 := Flag2; + end; + + RestoreGraphSettings(Canvas); +end; + +procedure WriteLegend(Canvas : TCanvas; + NCurv : Integer; + ShowPoints, + ShowLines : Boolean); + +var + CharHeight, I, L, Lmax : Integer; + N, Nmax, Xp, Xl, Y : Integer; +begin + N := 0; { Nb of legends to be plotted } + Lmax := 0; { Length of the longest legend } + + for I := 1 to NCurv do + if CurvParam^[I].Legend <> '' then + begin + Inc(N); + L := Canvas.TextWidth(CurvParam^[I].Legend); + if L > Lmax then Lmax := L; + end; + + if (N = 0) or (Lmax = 0) then Exit; + + { Character height } + CharHeight := Canvas.TextHeight('M'); + + { Max. number of legends which may be plotted } + Nmax := Round((YmaxPixel - YminPixel) / CharHeight) - 1; + if N > Nmax then N := Nmax; + + { Draw rectangle around the legends } + Canvas.Rectangle(XmaxPixel + Round(0.02 * GraphWidth), YminPixel, + XmaxPixel + Round(0.12 * GraphWidth) + Lmax, + YminPixel + (N + 1) * CharHeight); + + L := Round(0.02 * GraphWidth); { Half-length of line } + Xp := XmaxPixel + 3 * L; { Position of symbol } + Xl := XmaxPixel + 5 * L; { Position of legend } + + if NCurv <= Nmax then N := NCurv else N := Nmax; + + for I := 1 to N do + with Canvas do + begin + SetGraphSettings(Canvas, I); + + { Plot point and line } + Y := YminPixel + I * CharHeight; + if ShowPoints then + PlotSymbol(Canvas, Xp, Y, I); + if ShowLines then + PlotLine(Canvas, Xp - L, Y, Xp + L, Y); + + { Write legend } + Brush.Style := bsClear; + Canvas.TextOut(Xl, Y - CharHeight div 2, CurvParam^[I].Legend); + end; + + RestoreGraphSettings(Canvas); +end; + +procedure ConRec(Canvas : TCanvas; + Nx, Ny, Nc : Integer; + X, Y, Z : PVector; + F : PMatrix); + +const + { Mapping from vertex numbers to X offsets } + Im : array[0..3] of Integer = (0, 1, 1, 0); + + { Mapping from vertex numbers to Y offsets } + Jm : array[0..3] of Integer = (0, 0, 1, 1); + + { Case switch table } + CasTab : array[0..2, 0..2, 0..2] of Integer = + (((0,0,8), (0,2,5), (7,6,9)), + ((0,3,4), (1,3,1), (4,3,0)), + ((9,6,7), (5,2,0), (8,0,0))); + +var + I, J, K, M, M1, M2, M3 : Integer; + X1, X2, Y1, Y2 : Float; + Fmin, Fmax : Float; + Xp, Yp : PIntVector; + PrmErr : Boolean; + +var + H : array[0..4] of Float; { Relative heights of the box above contour } + Ish : array[0..4] of Integer; { Sign of H() } + Xh : array[0..4] of Integer; { X coordinates of box } + Yh : array[0..4] of Integer; { Y coordinates of box } + +label + Case0, NoneInTri, NoneInBox; + +begin + { Check the input parameters for validity } + + PrmErr := False; + SetErrCode(MatOk); + + if (Nx <= 0) or (Ny <= 0) or (Nc <= 0) then PrmErr := True; + + for K := 1 to Nc - 1 do + if Z^[K] <= Z^[K - 1] then PrmErr := True; + + if PrmErr then + begin + SetErrCode(MatErrDim); + Exit; + end; + + { Convert user coordinates to pixels } + + DimIntVector(Xp, Nx); + DimIntVector(Yp, Ny); + + for I := 0 to Nx do + Xp^[I] := Xpixel(X^[I]); + + for J := 0 to Ny do + Yp^[J] := Ypixel(Y^[J]); + + { Scan the array, top down, left to right } + + for J := Ny - 1 downto 0 do + begin + for I := 0 to Nx - 1 do + begin + { Find the lowest vertex } + if F^[I]^[J] < F^[I]^[J + 1] then + Fmin := F^[I]^[J] + else + Fmin := F^[I]^[J + 1]; + + if F^[I + 1]^[J] < Fmin then + Fmin := F^[I + 1]^[J]; + + if F^[I + 1]^[J + 1] < Fmin then + Fmin := F^[I + 1]^[J + 1]; + + { Find the highest vertex } + if F^[I]^[J] > F^[I]^[J + 1] then + Fmax := F^[I]^[J] + else + Fmax := F^[I]^[J + 1]; + + if F^[I + 1]^[J] > Fmax then + Fmax := F^[I + 1]^[J]; + + if F^[I + 1]^[J + 1] > Fmax then + Fmax := F^[I + 1]^[J + 1]; + + if (Fmax < Z^[0]) or (Fmin > Z^[Nc - 1]) then + goto NoneInBox; + + { Draw each contour within this box } + for K := 0 to Nc - 1 do + begin + if (Z^[K] < Fmin) or (Z^[K] > Fmax) then + goto NoneInTri; + + for M := 4 downto 0 do + begin + if M > 0 then + begin + H[M] := F^[I + Im[M - 1]]^[J + Jm[M - 1]] - Z^[K]; + Xh[M] := Xp^[I + Im[M - 1]]; + Yh[M] := Yp^[J + Jm[M - 1]]; + end; + + if M = 0 then + begin + H[0] := (H[1] + H[2] + H[3] + H[4]) / 4; + Xh[0] := (Xp^[I] + Xp^[I + 1]) div 2; + Yh[0] := (Yp^[J] + Yp^[J + 1]) div 2; + end; + + if H[M] > 0 then Ish[M] := 2; + if H[M] < 0 then Ish[M] := 0; + if H[M] = 0 then Ish[M] := 1; + end; { next M } + + { Scan each triangle in the box } + X1 := 0.0; + X2 := 0.0; + Y1 := 0.0; + Y2 := 0.0; + for M := 1 to 4 do + begin + M1 := M; M2 := 0; M3 := M + 1; + if M3 = 5 then M3 := 1; + + case CasTab[Ish[M1], Ish[M2], Ish[M3]] of + 0 : + goto Case0; + + { Line between vertices M1 and M2 } + 1 : begin + X1 := Xh[M1]; + Y1 := Yh[M1]; + X2 := Xh[M2]; + Y2 := Yh[M2]; + end; + + { Line between vertices M2 and M3 } + 2 : begin + X1 := Xh[M2]; + Y1 := Yh[M2]; + X2 := Xh[M3]; + Y2 := Yh[M3]; + end; + + { Line between vertices M3 and M1 } + 3 : begin + X1 := Xh[M3]; + Y1 := Yh[M3]; + X2 := Xh[M1]; + Y2 := Yh[M1]; + end; + + { Line between vertex M1 and side M2-M3 } + 4 : begin + X1 := Xh[M1]; + Y1 := Yh[M1]; + X2 := (H[M3] * Xh[M2] - H[M2] * Xh[M3]) / (H[M3] - H[M2]); + Y2 := (H[M3] * Yh[M2] - H[M2] * Yh[M3]) / (H[M3] - H[M2]); + end; + + { Line between vertex M2 and side M3-M1 } + 5 : begin + X1 := Xh[M2]; + Y1 := Yh[M2]; + X2 := (H[M1] * Xh[M3] - H[M3] * Xh[M1]) / (H[M1] - H[M3]); + Y2 := (H[M1] * Yh[M3] - H[M3] * Yh[M1]) / (H[M1] - H[M3]); + end; + + { Line between vertex M3 and side M1-M2 } + 6 : begin + X1 := Xh[M3]; + Y1 := Yh[M3]; + X2 := (H[M2] * Xh[M1] - H[M1] * Xh[M2]) / (H[M2] - H[M1]); + Y2 := (H[M2] * Yh[M1] - H[M1] * Yh[M2]) / (H[M2] - H[M1]); + end; + + { Line between sides M1-M2 and M2-M3 } + 7 : begin + X1 := (H[M2] * Xh[M1] - H[M1] * Xh[M2]) / (H[M2] - H[M1]); + Y1 := (H[M2] * Yh[M1] - H[M1] * Yh[M2]) / (H[M2] - H[M1]); + X2 := (H[M3] * Xh[M2] - H[M2] * Xh[M3]) / (H[M3] - H[M2]); + Y2 := (H[M3] * Yh[M2] - H[M2] * Yh[M3]) / (H[M3] - H[M2]); + end; + + { Line between sides M2-M3 and M3-M1 } + 8 : begin + X1 := (H[M3] * Xh[M2] - H[M2] * Xh[M3]) / (H[M3] - H[M2]); + Y1 := (H[M3] * Yh[M2] - H[M2] * Yh[M3]) / (H[M3] - H[M2]); + X2 := (H[M1] * Xh[M3] - H[M3] * Xh[M1]) / (H[M1] - H[M3]); + Y2 := (H[M1] * Yh[M3] - H[M3] * Yh[M1]) / (H[M1] - H[M3]); + end; + + { Line between sides M3-M1 and M1-M2 } + 9 : begin + X1 := (H[M1] * Xh[M3] - H[M3] * Xh[M1]) / (H[M1] - H[M3]); + Y1 := (H[M1] * Yh[M3] - H[M3] * Yh[M1]) / (H[M1] - H[M3]); + X2 := (H[M2] * Xh[M1] - H[M1] * Xh[M2]) / (H[M2] - H[M1]); + Y2 := (H[M2] * Yh[M1] - H[M1] * Yh[M2]) / (H[M2] - H[M1]); + end; + end; { case } + + Canvas.Pen.Color := CurvParam^[K mod MaxCurv + 1].LineParam.Color; + PlotLine(Canvas, Trunc(X1), Trunc(Y1), Trunc(X2), Trunc(Y2)); +Case0: + end; { next M } +NoneInTri: + end; { next K } +NoneInBox: + end; { next I } + end; { next J } +end; + +procedure LeaveGraphics; +begin + DelCurvParamVector(CurvParam, MaxCurv); +end; + +end. diff --git a/fpmath/uwoolf.pas b/fpmath/uwoolf.pas new file mode 100755 index 0000000..e1a6427 --- /dev/null +++ b/fpmath/uwoolf.pas @@ -0,0 +1,117 @@ +{ ****************************************************************** + Woolf test + ****************************************************************** } + +unit uwoolf; + +interface + +uses + utypes; + +procedure Woolf_Conform(N_cls : Integer; + N_estim : Integer; + Obs : PIntVector; + Calc : PVector; + var G : Float; + var DoF : Integer); +{ ------------------------------------------------------------------ + Woolf test for conformity + ------------------------------------------------------------------ } + +procedure Woolf_Indep(N_lin : Integer; + N_col : Integer; + Obs : PIntMatrix; + var G : Float; + var DoF : Integer); +{ ------------------------------------------------------------------ + Woolf test for independence + ------------------------------------------------------------------ } + +implementation + +procedure Woolf_Conform(N_cls : Integer; + N_estim : Integer; + Obs : PIntVector; + Calc : PVector; + var G : Float; + var DoF : Integer); + +var + I : Integer; + +begin + for I := 1 to N_cls do + if (Obs^[I] <= 0) or (Calc^[I] <= 0.0) then + begin + SetErrCode(FSing); + Exit + end; + + SetErrCode(FOk); + + G := 0.0; + for I := 1 to N_cls do + G := G + Obs^[I] * Ln(Obs^[I] / Calc^[I]); + + G := 2.0 * G; + DoF := N_cls - N_estim - 1; +end; + +procedure Woolf_Indep(N_lin : Integer; + N_col : Integer; + Obs : PIntMatrix; + var G : Float; + var DoF : Integer); + +var + SumLin, SumCol : PIntVector; + Sum : Integer; + Prob, Calc : Float; + I, J : Integer; + +begin + for I := 1 to N_lin do + for J := 1 to N_col do + if Obs^[I]^[J] <= 0 then + begin + SetErrCode(FSing); + Exit + end; + + SetErrCode(FOk); + + DimIntVector(SumLin, N_lin); + DimIntVector(SumCol, N_col); + + for I := 1 to N_lin do + for J := 1 to N_col do + SumLin^[I] := SumLin^[I] + Obs^[I]^[J]; + + for J := 1 to N_col do + for I := 1 to N_lin do + SumCol^[J] := SumCol^[J] + Obs^[I]^[J]; + + Sum := 0; + for I := 1 to N_lin do + Sum := Sum + SumLin^[I]; + + G := 0.0; + for I := 1 to N_lin do + begin + Prob := SumLin^[I] / Sum; + for J := 1 to N_col do + begin + Calc := SumCol^[J] * Prob; + G := G + Obs^[I]^[J] * Ln(Obs^[I]^[J] / Calc); + end; + end; + + G := 2.0 * G; + DoF := Pred(N_lin) * Pred(N_col); + + DelIntVector(SumLin, N_lin); + DelIntVector(SumCol, N_col); +end; + +end. \ No newline at end of file diff --git a/fx8.pas b/fx8.pas new file mode 100755 index 0000000..df610cc --- /dev/null +++ b/fx8.pas @@ -0,0 +1,609 @@ +unit fx8; +{$DEFINE VFLIP} +{$mode objfpc}{$H+} + +interface + +uses + SysUtils, define_types, Classes,dialogs{, Graphics, Controls, Forms, Dialogs,Menus,ComCtrls, ExtCtrls}; +type + Tfx8 = RECORD + + Width,Height,X,Y,PenThick: integer; + Img: Bytep; + end; +procedure CreateFX8(var lFX8: Tfx8); +procedure DefineFX8(var lFX8: Tfx8; lWid,lHt: integer); +procedure DefineBuffFX8(var lFX8: Tfx8; lWid,lHt: integer; lBuff: ByteP); +procedure CopyFX8(var lFX8src, lFX8dest: Tfx8); +procedure RectangleFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +procedure FillRectFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +procedure EllipseFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +procedure FillEllipseFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +procedure MoveToFX8(var lFX8: Tfx8; lXin,lYin: integer); +procedure LineToFX8(var lFX8: Tfx8; lXin,lYin: integer; lClr: byte); overload; +procedure LineToFX8(var lFX8: Tfx8; lXin,lYin: integer; lClr, lLineThick: byte); overload; +procedure FloodFillFX8 (var lFX8: Tfx8; lXin, lYin: Integer; lBoundClr,lWriteClr: byte; lfsSurface: boolean); +procedure FreeFX8(var lFX8: Tfx8); + + + +implementation +uses nifti_img_view; + +function FX8x( lXin: integer): integer; +begin + result := lXin ; +end; + +function FX8y(var lFX8: Tfx8; lYin: integer): integer; +begin + {$IFDEF VFLIP} + result := lFX8.Height- lYin + 1; + {$ELSE} + result := lYin; + {$ENDIF} +end; + +procedure sortLTRB(var lXoutLow,lYOutLow,lXoutHi,lYOutHi: integer); //left<right, top<bottom +var lXin1,lYin1,lXin2,lYin2: integer; +begin + lXin1 := lXoutLow; + lYin1 := lYOutLow; + lXin2 := lXoutHi; + lYin2 := lYOutHi; + if lXIn1 < lXin2 then begin + lXoutLow := lXIn1; + lXOutHi := lXIn2; + end else begin + lXoutLow := lXIn2; + lXOutHi := lXIn1; + end; + if lYIn1 < lYin2 then begin + lYoutLow := lYIn1; + lYOutHi := lYIn2; + end else begin + lYoutLow := lYIn2; + lYOutHi := lYIn1; + end; +end; //sortLTRB + +procedure Bound(var lX,lY: integer; var lFX8: TFX8); +begin + if lX < 1 then + lX := 1; + if lX > lFX8.width then + lX := lFX8.width; + if lY < 1 then + lY := 1; + if lY > lFX8.height then + lY := lFX8.height; + +end; + +procedure boundrect(var lL,lT,lR,lB: integer; var lFX8: TFX8); +begin + sortLTRB(lL,lT,lR,lB); + bound(lL,lT,lFX8); + bound(lR,lB,lFX8); +end; + +procedure MoveToFX8(var lFX8: Tfx8; lXin,lYin: integer); +var + lX,lY: integer; +begin + lX := FX8x(lXin); lY := FX8y(lFX8, lYin); + bound(lX,lY,lFX8); + lFX8.X := lX; + lFX8.Y := lY; +end; + +procedure HorLine(var lFX8: Tfx8; x1,x2,y: integer; lClr: byte); +var + x,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lStart := (y -1)* lFX8.Width; + if x1 < x2 then begin + for x := x1 to x2 do + lFX8.Img^[lStart+x] := lClr; + end else + for x := x2 to x1 do + lFX8.Img^[lStart+x] := lClr; +end; + + +function isOutOfBounds(var lFX8: Tfx8; var x,y:integer): boolean; +var + iy: integer; +begin + iy := y; + x := FX8x(x); y := FX8y(lFX8, y); + + if (x < 0) or (y < 0) or (x > lFX8.Width) or (y > lFX8.Height) then begin + imgform.StatusLabel.caption := inttostr(iy)+'pixel error '+inttostr(x)+'x'+inttostr(y)+' '+inttostr(lFX8.Width)+'x'+inttostr(lFX8.Height); + result := true; + exit; + + end; + result := false; +end; + +function getpixel(var lFX8: Tfx8; x,y: integer): byte; +begin + result := lFX8.Img^[(Y -1)* lFX8.Width+x]; +end; + +procedure putpixel(var lFX8: Tfx8; x,y: integer; lClr: byte); +begin + if (x < 1) or (y < 1) or (x > lFX8.width) or (y > lFX8.height) then + exit; //putwidepixel and puttallpixel can have x < 1, x > width, etc... + lFX8.Img^[(Y -1)* lFX8.Width+x] := lClr; +end; + +procedure putwidepixel(var lFX8: Tfx8; x,y: integer; lClr, lLineThick: byte); +var lBar: integer; +begin + putpixel(lFX8,x,y,lClr); + if lLineThick < 2 then exit; + for lBar := 1 to ((lLineThick-1) div 2) do begin + putpixel(lFX8,x-lBar,y,lClr); + putpixel(lFX8,x+lBar,y,lClr); + end; +end; + +procedure puttallpixel(var lFX8: Tfx8; x,y: integer; lClr, lLineThick: byte); +var lBar: integer; +begin + putpixel(lFX8,x,y,lClr); + if lLineThick < 2 then exit; + for lBar := 1 to ((lLineThick-1) div 2) do begin + putpixel(lFX8,x,y-lBar,lClr); + putpixel(lFX8,x,y+lBar,lClr); + end; +end; + +procedure LineToFX8(var lFX8: Tfx8; lXin,lYin: integer; lClr, lLineThick: byte) ; overload; +var + lSlope: single; + lX2,lY2,lX1,lY1,lP,lCol,lStart,lX,lY: integer; +begin + lX1 := lFX8.X; + lY1 := lFX8.Y; + lX2 := FX8x(lXin); lY2 := FX8y(lFX8, lYin); + Bound(lX2,lY2,lFX8); + lFX8.X := lX2; + lFX8.Y := lY2; + //next: endpoints - required if no line + lFX8.Img^[(lY1 -1)* lFX8.Width+lX1] := lClr; + lFX8.Img^[(lY2 -1)* lFX8.Width+lX2] := lClr; + if (lX1 = lX2) and (lY1 = lY2) then + exit; + if abs(lY1-lY2) > abs(lX1-lX2) then begin //mostly vertical + if lY1 > lY2 then begin + lSlope := (lX1-lX2) /(lY1-lY2); + for lY := lY2 to lY1 do + putwidepixel(lFX8,lX2+round(lSlope*(lY-lY2)),lY, lClr, lLineThick); + //lFX8.Img^[((lY -1)* lFX8.Width)+lX2+round(lSlope*(lY-lY2))] := lClr; + end else begin + lSlope := (lX2-lX1) /(lY2-lY1); + for lY := lY1 to lY2 do + putwidepixel(lFX8,lX1+round(lSlope*(lY-lY1)),lY, lClr, lLineThick); + //lFX8.Img^[((lY -1)* lFX8.Width)+lX1+round(lSlope*(lY-lY1))] := lClr; + end; + end else begin //mostly horizontal - primary change in X + if lX1 > lX2 then begin + lSlope := (lY1-lY2) /(lX1-lX2); + for lX := lX2 to lX1 do + puttallpixel(lFX8,lX,lY2+round(lSlope*(lX-lX2) ) , lClr, lLineThick); + //lFX8.Img^[((lY2+round(lSlope*(lX-lX2) ) -1)* lFX8.Width)+lX] := lClr; + end else begin + lSlope := (lY2-lY1) /(lX2-lX1); + for lX := lX1 to lX2 do + puttallpixel(lFX8,lX,lY1+round(lSlope*(lX-lX1) ) , lClr, lLineThick); + //lFX8.Img^[((lY1+round(lSlope*(lX-lX1) ) -1)* lFX8.Width)+lX] := lClr; + end; + end; +end; + +procedure LineToFX8(var lFX8: Tfx8; lXin,lYin: integer; lClr: byte); overload; +//for speed: lSingle could use integer math +var + lSlope: single; + lX2,lY2,lX1,lY1,lX,lY: integer; +begin + if lFX8.PenThick > 2 then begin + LineToFX8(lFX8,lXin,lYin, lClr,lFX8.PenThick); + exit; + end; + lX1 := lFX8.X; + lY1 := lFX8.Y; + lX2 := FX8x(lXin); lY2 := FX8y(lFX8, lYin); + Bound(lX2,lY2,lFX8); + lFX8.X := lX2; + lFX8.Y := lY2; + //next: endpoints - required if no line + lFX8.Img^[(lY1 -1)* lFX8.Width+lX1] := lClr; + lFX8.Img^[(lY2 -1)* lFX8.Width+lX2] := lClr; + if (lX1 = lX2) and (lY1 = lY2) then + exit; + if abs(lY1-lY2) > abs(lX1-lX2) then begin //mostly vertical + if lY1 > lY2 then begin + lSlope := (lX1-lX2) /(lY1-lY2); + for lY := lY2 to lY1 do + lFX8.Img^[((lY -1)* lFX8.Width)+lX2+round(lSlope*(lY-lY2))] := lClr; + end else begin + lSlope := (lX2-lX1) /(lY2-lY1); + for lY := lY1 to lY2 do + lFX8.Img^[((lY -1)* lFX8.Width)+lX1+round(lSlope*(lY-lY1))] := lClr; + end; + end else begin //mostly horizontal - primary change in X + if lX1 > lX2 then begin + lSlope := (lY1-lY2) /(lX1-lX2); + for lX := lX2 to lX1 do + lFX8.Img^[((lY2+round(lSlope*(lX-lX2) ) -1)* lFX8.Width)+lX] := lClr; + end else begin + lSlope := (lY2-lY1) /(lX2-lX1); + for lX := lX1 to lX2 do + lFX8.Img^[((lY1+round(lSlope*(lX-lX1) ) -1)* lFX8.Width)+lX] := lClr; + end; + end; +end; + +Procedure FillEllipseDefault(var lFX8: Tfx8; X,Y: smallint;XRadius: word; + YRadius:word; lClr: byte); + Const ConvFac = Pi/180.0; + + var + j, Delta, DeltaEnd: single; + NumOfPixels: longint; + TempTerm: single; + xtemp, ytemp, xp, yp, xm, ym, xnext, ynext, + plxpyp, plxmyp, plxpym, plxmym: smallint; + BackupColor, TmpAngle, OldLineWidth: word; + Begin + + If xradius = 0 then inc(xradius); + if yradius = 0 then inc(yradius); + { check for an ellipse with negligable x and y radius } + If (xradius <= 1) and (yradius <= 1) then begin + putpixel(lFX8, x,y, lClr); + exit; + end; + { approximate the number of pixels required by using the circumference } + { equation of an ellipse. } + { Changed this formula a it (trial and error), but the net result is that } + { less pixels have to be calculated now } + NumOfPixels:=Round(Sqrt(3)*sqrt(sqr(XRadius)+sqr(YRadius))); + { Calculate the angle precision required } + Delta := 90.0 / NumOfPixels; + { for restoring after PatternLine } + + { removed from inner loop to make faster } + { Always just go over the first 90 degrees. Could be optimized a } + { bit if StAngle and EndAngle lie in the same quadrant, left as an } + { exercise for the reader :) (JM) } + j := 0; + { calculate stop position, go 1 further than 90 because otherwise } + { 1 pixel is sometimes not drawn (JM) } + DeltaEnd := 91; + { Calculate points } + xnext := XRadius; + ynext := 0; + Repeat + xtemp := xnext; + ytemp := ynext; + { this is used by both sin and cos } + TempTerm := (j+Delta)*ConvFac; + { Calculate points } + xnext := round(XRadius*Cos(TempTerm)); + ynext := round(YRadius*Sin(TempTerm+Pi)); + xp := x + xtemp; + xm := x - xtemp; + yp := y + ytemp; + ym := y - ytemp; + plxpyp := maxsmallint; + plxmyp := -maxsmallint-1; + plxpym := maxsmallint; + plxmym := -maxsmallint-1; + plxpyp := xp; + PutPixel(lFX8,xp,yp,lClr); + plxmyp := xm; + PutPixel(lFX8,xm,yp,lClr); + plxmym := xm; + PutPixel(lFX8,xm,ym,lClr); + plxpym := xp; + PutPixel(lFX8,xp,ym,lClr); + If (ynext <> ytemp) and + (xp - xm >= 1) then + begin + //CurrentColor := FillSettings.Color; + HorLine(lFX8,plxmyp+1,plxpyp-1,yp,lClr); + HorLine(lFX8,plxmym+1,plxpym-1,ym,lClr); + //CurrentColor := BackupColor;*) + end; + j:=j+Delta; + Until j > (DeltaEnd); + end; + + Procedure EllipseDefault(var lFX8: Tfx8; X,Y: smallint;XRadius: word; + YRadius:word; lClr: byte); + Const ConvFac = Pi/180.0; + + var + j, Delta, DeltaEnd: single; + NumOfPixels: longint; + TempTerm: single; + xtemp, ytemp, xp, yp, xm, ym, xnext, ynext, + plxpyp, plxmyp, plxpym, plxmym: smallint; + BackupColor, TmpAngle, OldLineWidth: word; + Begin + + If xradius = 0 then inc(xradius); + if yradius = 0 then inc(yradius); + { check for an ellipse with negligable x and y radius } + If (xradius <= 1) and (yradius <= 1) then begin + putpixel(lFX8, x,y, lClr); + exit; + end; + { approximate the number of pixels required by using the circumference } + { equation of an ellipse. } + { Changed this formula a it (trial and error), but the net result is that } + { less pixels have to be calculated now } + NumOfPixels:=Round(Sqrt(3)*sqrt(sqr(XRadius)+sqr(YRadius))); + { Calculate the angle precision required } + Delta := 90.0 / NumOfPixels; + { for restoring after PatternLine } + + { removed from inner loop to make faster } + { Always just go over the first 90 degrees. Could be optimized a } + { bit if StAngle and EndAngle lie in the same quadrant, left as an } + { exercise for the reader :) (JM) } + j := 0; + { calculate stop position, go 1 further than 90 because otherwise } + { 1 pixel is sometimes not drawn (JM) } + DeltaEnd := 91; + { Calculate points } + xnext := XRadius; + ynext := 0; + Repeat + xtemp := xnext; + ytemp := ynext; + { this is used by both sin and cos } + TempTerm := (j+Delta)*ConvFac; + { Calculate points } + xnext := round(XRadius*Cos(TempTerm)); + ynext := round(YRadius*Sin(TempTerm+Pi)); + xp := x + xtemp; + xm := x - xtemp; + yp := y + ytemp; + ym := y - ytemp; + PutPixel(lFX8,xp,yp,lClr); + PutPixel(lFX8,xm,yp,lClr); + PutPixel(lFX8,xm,ym,lClr); + PutPixel(lFX8,xp,ym,lClr); + j:=j+Delta; + Until j > (DeltaEnd); + end; + + +procedure EllipseFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +var + lL,lT,lR,lB,lP,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lL := FX8x(lLin); lB := FX8y(lFX8, lBin); + lR := FX8x(lRin); lT := FX8y(lFX8, lTin); + + BoundRect(lL,lT,lR,lB,lFX8); + EllipseDefault(lFX8, (lL+lR) shr 1,(lT+lB) shr 1, (lR-lL) shr 1, (lB-lT) shr 1,lClr); +end; + +procedure FillEllipseFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +var + lL,lT,lR,lB,lP,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lL := FX8x(lLin); lB := FX8y(lFX8, lBin); + lR := FX8x(lRin); lT := FX8y(lFX8, lTin); + + BoundRect(lL,lT,lR,lB,lFX8); + FillEllipseDefault(lFX8, (lL+lR) shr 1,(lT+lB) shr 1, (lR-lL) shr 1, (lB-lT) shr 1,lClr); +end; + +procedure RectangleFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +var + lL,lT,lR,lB,lP,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lL := FX8x(lLin); lB := FX8y(lFX8, lBin); + lR := FX8x(lRin); lT := FX8y(lFX8, lTin); + + BoundRect(lL,lT,lR,lB,lFX8); + //top line + lStart := (lT -1)* lFX8.Width; + for lP := lL to lR do + lFX8.Img^[lStart+lP] := lClr; + //bottom line + lStart := (lB -1)* lFX8.Width; + for lP := lL to lR do + lFX8.Img^[lStart+lP] := lClr; + //left and right lines + lStart := (lT -1)* lFX8.Width; + for lP := lT to lB do begin + lFX8.Img^[lStart+lL] := lClr; + lFX8.Img^[lStart+lR] := lClr; + lStart := lStart + lFX8.Width; + end; +end; + +procedure FillRectFX8(var lFX8: Tfx8; lLin,lTin,lRin,lBin: integer; lClr: byte); +var + lL,lT,lR,lB,lRow,lCol,lStart: integer; +begin + if lFX8.img = nil then exit; //not defined + lL := FX8x(lLin); lB := FX8y(lFX8, lBin); + lR := FX8x(lRin); lT := FX8y(lFX8, lTin); + + BoundRect(lL,lT,lR,lB,lFX8); + lStart := (lT -1)* lFX8.Width; + for lRow := lT to lB do begin + for lCol := lL to lR do + lFX8.Img^[lStart+lCol] := lClr; + lStart := lStart + lFX8.Width; + end; +end; + +procedure DefineFX8(var lFX8: Tfx8; lWid,lHt: integer); +begin + if (lFX8.img = nil) or (lWid <> lFX8.Width) or (lHt <> lFX8.Height) then begin + if lFX8.img <> nil then + freemem(lFX8.Img); + Getmem(lFX8.img, lWid*lHt); + lFX8.Height := lHt; + lFX8.Width := lWid; + end; + fillchar(lFX8.Img^,lWid*lHt,0); + lFX8.X := 1; + lFX8.Y := 1; +end; + +procedure DefineBuffFX8(var lFX8: Tfx8; lWid,lHt: integer; lBuff: ByteP); +begin + if lBuff = nil then exit; + DefineFX8(lFX8, lWid,lHt); + Move(lBuff^,lFX8.Img^,lWid*lHt); +end; + +procedure CopyFX8(var lFX8src, lFX8dest: Tfx8); +begin + if (lFX8src.Img = nil) then + exit; + DefineFX8(lFX8dest, lFX8src.Width,lFX8src.Height); + Move(lFX8src.Img^,lFX8dest.Img^,lFX8src.Width*lFX8src.Height); +end; + +procedure FloodFillFX8 (var lFX8: Tfx8; lXin, lYin: Integer; lBoundClr,lWriteClr: byte; lfsSurface: boolean); +//Written by Chris Rorden +//A simple first-in-first-out circular buffer (the queue) for flood-filling contiguous voxels. +//This algorithm avoids stack problems associated simple recursive algorithms +//http://steve.hollasch.net/cgindex/polygons/floodfill.html +const + kFill = 0; //pixels we will want to flood fill + kFillable = 128; //voxels we might flood fill + kUnfillable = 255; //voxels we can not flood fill +var + lWid,lHt,lQSz,lQHead,lQTail: integer; + lQRA: LongIntP; + lMaskRA: ByteP; +procedure IncQra(var lVal, lQSz: integer);//nested inside FloodFill +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; //nested Proc IncQra +function Pos2XY (lPos: integer): TPoint; +begin + result.X := ((lPos-1) mod lWid)+1; //horizontal position + result.Y := ((lPos-1) div lWid)+1; //vertical position +end; //nested Proc Pos2XY +procedure TestPixel(lPos: integer); +begin + if (lMaskRA^[lPos]=kFillable) then begin + lMaskRA^[lPos] := kFill; + lQra^[lQHead] := lPos; + incQra(lQHead,lQSz); + end; +end; //nested Proc TestPixel +procedure RetirePixel; //nested inside FloodFill +var + lVal: integer; + lXY : TPoint; +begin + lVal := lQra^[lQTail]; + lXY := Pos2XY(lVal); + if lXY.Y > 1 then + TestPixel (lVal-lWid);//pixel above + if lXY.Y < lHt then + TestPixel (lVal+lWid);//pixel below + if lXY.X > 1 then + TestPixel (lVal-1); //pixel to left + if lXY.X < lWid then + TestPixel (lVal+1); //pixel to right + incQra(lQTail,lQSz); //done with this pixel +end; //nested proc RetirePixel +const + kIndex0or1 = 0; +var + lTargetColorVal,lDefaultVal: byte; + lX,lY,lPos,x,y: integer; +begin //FloodFill + X := lXin; Y := lYin; + if isOutOfBounds(lFX8, X,Y) then exit; + //lX := FX8x(lXin); lY := FX8y(lFX8, lYin); + // imgform.StatusLabel.caption := 'pixel error '+inttostr(X)+'x'+inttostr(Y); + //exit; + if lfsSurface then begin + if getpixel(lFX8, x,y) <> lBoundClr then exit; + lTargetColorVal := kFillable; + lDefaultVal := kUnfillable; + end else begin //fsBorder + //fill non-target color with brush - bounded by target-color + if getpixel(lFX8, x,y) = lBoundClr then exit; + lTargetColorVal := kUnfillable; + lDefaultVal := kFillable; + end; + lHt := lFX8.Height; + lWid := lFX8.Width; + lQSz := lHt * lWid; + //Qsz should be more than the most possible simultaneously active pixels + //Worst case scenario is a click at the center of a 3x3 image: all 9 pixels will be active simultaneously + //for larger images, only a tiny fraction of pixels will be active at one instance. + //perhaps lQSz = ((lHt*lWid) div 4) + 32; would be safe and more memory efficient + if (lHt < 1) or (lWid < 1) then exit; + getmem(lQra,lQSz*sizeof(longint)); //very wasteful - + getmem(lMaskRA,lHt*lWid*sizeof(byte)); + for lPos := 1 to (lHt*lWid) do + if lFX8.Img^[lPos] = lBoundClr then + lMaskRA^[lPos] := lTargetColorVal //assume all voxels are non targets + else + lMaskRA^[lPos] := lDefaultVal; //assume all voxels are non targets + + lQHead := 2; + lQTail := 1; + lQra^[lQTail] := (((Y-1) * lWid)+X+kIndex0or1); //NOTE: both X and Y start from 0 not 1 + lMaskRA^[lQra^[lQTail]] := kFill; + RetirePixel; + {for lPos := 1 to 100 do + RetirePixel;} + while lQHead <> lQTail do + RetirePixel; + + lPos := 0; + + for lY := 0 to (lHt-1) do + for lX := 0 to (lWid-1) do begin + lPos := lPos + 1; + if lMaskRA^[lPos] = kFill then + lFX8.Img^[lPos] := lWriteClr; + end; + freemem(lMaskRA); + freemem(lQra); +end;// proc FloodFill + + +procedure CreateFX8(var lFX8: Tfx8); +begin + lFX8.Img := nil; +end; + +procedure FreeFX8(var lFX8: Tfx8); +begin + if lFX8.Img <> nil then + Freemem(lFX8.Img); + lFX8.Img := nil; +end; + + +end. + diff --git a/graphx.lfm b/graphx.lfm new file mode 100755 index 0000000..44a37d2 --- /dev/null +++ b/graphx.lfm @@ -0,0 +1,287 @@ +object Graph4DForm: TGraph4DForm + Left = 486 + Height = 429 + Top = 156 + Width = 1097 + ActiveControl = TREdit + Caption = '4D Timeline Viewer' + ClientHeight = 410 + ClientWidth = 1097 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnResize = FormResize + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '0.9.29' + object Image1: TImage + Left = 0 + Height = 354 + Top = 36 + Width = 1097 + Align = alClient + end + object FourDBar: TPanel + Left = 0 + Height = 36 + Top = 0 + Width = 1097 + Align = alTop + BevelOuter = bvNone + ClientHeight = 36 + ClientWidth = 1097 + TabOrder = 0 + object OpenDataBtn: TSpeedButton + Left = 11 + Height = 25 + Top = 7 + Width = 95 + Caption = 'Open Data' + Color = clBtnFace + NumGlyphs = 0 + OnClick = OpenDataClick + end + object RefreshBtn: TSpeedButton + Left = 112 + Height = 30 + Top = 4 + Width = 30 + Color = clBtnFace + Glyph.Data = { + D6080000424DD608000000000000360000002800000018000000170000000100 + 200000000000A008000064000000640000000000000000000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF2F0000 + FF9C0000FFB90000FFCA0000FFBF0000FF0CFFFFFF00FFFFFF00FFFFFF000000 + FF0DFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF320000FFA40000FFF00000 + FFFF0000FFFF0000FFBE0000FF190000FF160000FF6A0000FF990000FFC20000 + FF69FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000FF630000FFE50000FFFF0000FFFF0000 + FFFF0000FFE40000FF080000FF0F0000FFE00000FFFF0000FFFC0000FF61FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF000000FF010000FF880000FFF40000FFFF0000FFFF0000FFFF0000 + FFFF0000FFEE0000FF18FFFFFF000000FF910000FFFF0000FFE60000FFF60000 + FFA70000FF28FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF000000FF970000FFFE0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFCC0000FF60FFFFFF00FFFFFF000000FF180000FFE70000FF420000FF940000 + FFF20000FFEA0000FF900000FF10FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF000000FF650000FFF80000FFFF0000FFFF0000FFFF0000FFDE0000FF7F0000 + FF06FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FFA20000FF20FFFFFF000000 + FF470000FFCB0000FFFF0000FFDA0000FF50FFFFFF00FFFFFF00FFFFFF000000 + FF2F0000FFE20000FFFF0000FFFF0000FFFC0000FFA70000FF17FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF0F0000FF06FFFFFF00FFFF + FF000000FF090000FFAB0000FFFF0000FFE40000FF42FFFFFF00FFFFFF000000 + FFB60000FFFF0000FFFF0000FFEE0000FF7DFFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF000000FF0C0000FFC50000FFFF0000FFCE0000FF060000FF260000 + FFF20000FFFF0000FFF50000FF66FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000000FF2B0000FFE10000FFFF0000FF7A0000FF840000 + FFFF0000FFFF0000FF87FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000FFAF0000FFFF0000FFA20000FFC30000 + FFFF0000FFD70000FF03FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000FF8E0000FFFF0000FFB50000FFC90000 + FFFF0000FF99FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000FF990000FFFF0000FFC90000FFB50000 + FFFF0000FF8EFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000000FF030000FFD70000FFFF0000FFC30000FFA20000 + FFFF0000FFAFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000000FF870000FFFF0000FFFF0000FF840000FF7A0000 + FFFF0000FFE10000FF2BFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF000000FF660000FFF50000FFFF0000FFF20000FF260000FF060000 + FFCE0000FFFF0000FFC50000FF0CFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF000000FF7D0000FFEE0000FFFF0000FFFF0000FFB6FFFFFF00FFFFFF000000 + FF420000FFE40000FFFF0000FFAB0000FF09FFFFFF00FFFFFF000000FF060000 + FF0FFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF170000 + FFA70000FFFC0000FFFF0000FFFF0000FFE20000FF2FFFFFFF00FFFFFF00FFFF + FF000000FF500000FFDA0000FFFF0000FFCB0000FF47FFFFFF000000FF200000 + FFA3FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF060000FF7F0000FFDE0000 + FFFF0000FFFF0000FFFF0000FFF80000FF65FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF000000FF100000FF900000FFEA0000FFF20000FF940000FF420000 + FFE70000FF18FFFFFF00FFFFFF000000FF600000FFCC0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFE0000FF97FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000FF280000FFA70000FFF60000FFE60000 + FFFF0000FF91FFFFFF000000FF180000FFEE0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFF40000FF880000FF01FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF610000FFFC0000 + FFFF0000FFE00000FF0F0000FF080000FFE40000FFFF0000FFFF0000FFFF0000 + FFE50000FF63FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF690000FFC20000FF990000 + FF6A0000FF160000FF190000FFBE0000FFFF0000FFFF0000FFF00000FFA40000 + FF32FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000 + 0040000007BE000000AB00000028FFFFFF000000FF0DFFFFFF00FFFFFF00FFFF + FF000000FF0C0000FFBF0000FFCA0000FFB90000FF9C0000FF2FFFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 + } + NumGlyphs = 0 + OnClick = RefreshBtnClick + OnMouseDown = RefreshBtnMouseDown + end + object TRLabel: TLabel + Left = 152 + Height = 14 + Top = 15 + Width = 41 + Caption = 'TR (sec)' + ParentColor = False + end + object PlotBtn: TSpeedButton + Left = 488 + Height = 25 + Top = 7 + Width = 63 + Caption = 'Plot' + Color = clBtnFace + NumGlyphs = 0 + OnClick = PSPlotClick + end + object TextBtn: TSpeedButton + Left = 560 + Height = 25 + Top = 7 + Width = 80 + Caption = 'Text' + Color = clBtnFace + NumGlyphs = 0 + OnClick = PSTextClick + end + object TREdit: TFloatSpinEdit + Left = 240 + Height = 21 + Top = 9 + Width = 82 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 100000000 + MinValue = 0 + TabOrder = 0 + Value = 0 + end + object HSpeedDrop: TComboBox + Left = 352 + Height = 21 + Top = 5 + Width = 120 + ItemHeight = 13 + Items.Strings = ( + 'To Fit' + 'x1' + 'x2' + 'x3' + 'x4' + 'x5' + 'x6' + 'x7' + 'x8' + 'x9' + 'x10' + ) + OnChange = TrackBar1Change + Style = csDropDownList + TabOrder = 1 + end + object MinEdit: TFloatSpinEdit + Left = 656 + Height = 21 + Top = 6 + Width = 82 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 2 + Value = 0 + end + object MaxEdit: TFloatSpinEdit + Left = 768 + Height = 21 + Top = 6 + Width = 82 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 3 + Value = 0 + end + object TrackBar1: TTrackBar + Left = 864 + Height = 29 + Top = 4 + Width = 204 + OnChange = TrackBar1Change + Position = 0 + TabOrder = 4 + Visible = False + end + end + object StatusBar1: TStatusBar + Left = 0 + Height = 20 + Top = 390 + Width = 1097 + Panels = < + item + Width = 250 + end + item + Width = 50 + end> + SimplePanel = False + end + object MainMenu1: TMainMenu + left = 14 + top = 5 + object MenuItem1: TMenuItem + Caption = 'File' + object OpenMenu: TMenuItem + Caption = 'Open data' + ShortCut = 16463 + OnClick = OpenDataClick + end + object FFTMenu: TMenuItem + Caption = 'Power spectrum' + Visible = False + OnClick = FFTitemClick + end + object SaveMenu: TMenuItem + Caption = 'Save as bitmap' + OnClick = SaveasEMF1Click + end + object Extract4Drois: TMenuItem + Caption = 'Create resting state ROIs' + OnClick = Extract4DroisClick + end + object BatchMenu: TMenuItem + Caption = 'Batch process data' + OnClick = Batchdata1Click + end + object FSLBatchMenu: TMenuItem + Caption = 'FSL batch process' + OnClick = FSLbatch1Click + end + object CloseMenu: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Closewindow1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object CopyMenu: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + end + end + object SelectDirectoryDialog1: TSelectDirectoryDialog + left = 184 + end +end diff --git a/graphx.lrs b/graphx.lrs new file mode 100644 index 0000000..fde686d --- /dev/null +++ b/graphx.lrs @@ -0,0 +1,149 @@ +LazarusResources.Add('TGraph4DForm','FORMDATA',[ + 'TPF0'#12'TGraph4DForm'#11'Graph4DForm'#4'Left'#3#230#1#6'Height'#3#173#1#3'T' + +'op'#3#156#0#5'Width'#3'I'#4#13'ActiveControl'#7#6'TREdit'#7'Caption'#6#18'4' + +'D Timeline Viewer'#12'ClientHeight'#3#154#1#11'ClientWidth'#3'I'#4#4'Menu'#7 + +#9'MainMenu1'#7'OnClose'#7#9'FormClose'#8'OnCreate'#7#10'FormCreate'#8'OnRes' + +'ize'#7#10'FormResize'#6'OnShow'#7#8'FormShow'#8'Position'#7#14'poScreenCent' + +'er'#10'LCLVersion'#6#6'0.9.29'#0#6'TImage'#6'Image1'#4'Left'#2#0#6'Height'#3 + +'b'#1#3'Top'#2'$'#5'Width'#3'I'#4#5'Align'#7#8'alClient'#0#0#6'TPanel'#8'Fou' + +'rDBar'#4'Left'#2#0#6'Height'#2'$'#3'Top'#2#0#5'Width'#3'I'#4#5'Align'#7#5'a' + +'lTop'#10'BevelOuter'#7#6'bvNone'#12'ClientHeight'#2'$'#11'ClientWidth'#3'I' + +#4#8'TabOrder'#2#0#0#12'TSpeedButton'#11'OpenDataBtn'#4'Left'#2#11#6'Height' + +#2#25#3'Top'#2#7#5'Width'#2'_'#7'Caption'#6#9'Open Data'#5'Color'#7#9'clBtnF' + +'ace'#9'NumGlyphs'#2#0#7'OnClick'#7#13'OpenDataClick'#0#0#12'TSpeedButton'#10 + +'RefreshBtn'#4'Left'#2'p'#6'Height'#2#30#3'Top'#2#4#5'Width'#2#30#5'Color'#7 + +#9'clBtnFace'#10'Glyph.Data'#10#218#8#0#0#214#8#0#0'BM'#214#8#0#0#0#0#0#0'6' + +#0#0#0'('#0#0#0#24#0#0#0#23#0#0#0#1#0' '#0#0#0#0#0#160#8#0#0'd'#0#0#0'd'#0#0 + +#0#0#0#0#0#0#0#0#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255'/'#0#0#255 + +#156#0#0#255#185#0#0#255#202#0#0#255#191#0#0#255#12#255#255#255#0#255#255#255 + +#0#255#255#255#0#0#0#255#13#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255'2'#0#0#255#164#0#0#255#240 + +#0#0#255#255#0#0#255#255#0#0#255#190#0#0#255#25#0#0#255#22#0#0#255'j'#0#0#255 + +#153#0#0#255#194#0#0#255'i'#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#0#0#255'c'#0#0#255#229#0#0#255#255#0#0#255#255#0 + +#0#255#255#0#0#255#228#0#0#255#8#0#0#255#15#0#0#255#224#0#0#255#255#0#0#255 + +#252#0#0#255'a'#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#0#0#255#1#0#0#255#136#0#0#255#244#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#238#0#0#255#24#255#255#255#0#0#0#255#145#0#0#255#255#0#0 + +#255#230#0#0#255#246#0#0#255#167#0#0#255'('#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#0#0#255#151#0#0#255#254#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255 + +#255#0#0#255#204#0#0#255'`'#255#255#255#0#255#255#255#0#0#0#255#24#0#0#255 + +#231#0#0#255'B'#0#0#255#148#0#0#255#242#0#0#255#234#0#0#255#144#0#0#255#16 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0 + +#255'e'#0#0#255#248#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#222#0#0#255 + +#127#0#0#255#6#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0 + +#255#162#0#0#255' '#255#255#255#0#0#0#255'G'#0#0#255#203#0#0#255#255#0#0#255 + +#218#0#0#255'P'#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255'/'#0#0#255 + +#226#0#0#255#255#0#0#255#255#0#0#255#252#0#0#255#167#0#0#255#23#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0 + +#255#15#0#0#255#6#255#255#255#0#255#255#255#0#0#0#255#9#0#0#255#171#0#0#255 + +#255#0#0#255#228#0#0#255'B'#255#255#255#0#255#255#255#0#0#0#255#182#0#0#255 + +#255#0#0#255#255#0#0#255#238#0#0#255'}'#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0 + +#255#12#0#0#255#197#0#0#255#255#0#0#255#206#0#0#255#6#0#0#255'&'#0#0#255#242 + +#0#0#255#255#0#0#255#245#0#0#255'f'#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#0#0#255'+'#0#0#255#225#0#0#255#255#0#0#255'z'#0#0#255 + +#132#0#0#255#255#0#0#255#255#0#0#255#135#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255#175#0#0#255#255 + +#0#0#255#162#0#0#255#195#0#0#255#255#0#0#255#215#0#0#255#3#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0 + +#255#142#0#0#255#255#0#0#255#181#0#0#255#201#0#0#255#255#0#0#255#153#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + ,#255#0#255#255#255#0#0#0#255#153#0#0#255#255#0#0#255#201#0#0#255#181#0#0#255 + +#255#0#0#255#142#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#0#0#255#3#0#0#255#215#0#0#255#255#0#0#255#195#0 + +#0#255#162#0#0#255#255#0#0#255#175#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255#135#0#0#255#255#0#0 + +#255#255#0#0#255#132#0#0#255'z'#0#0#255#255#0#0#255#225#0#0#255'+'#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255'f'#0#0#255#245#0 + +#0#255#255#0#0#255#242#0#0#255'&'#0#0#255#6#0#0#255#206#0#0#255#255#0#0#255 + +#197#0#0#255#12#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255'}'#0#0#255#238#0#0 + +#255#255#0#0#255#255#0#0#255#182#255#255#255#0#255#255#255#0#0#0#255'B'#0#0 + +#255#228#0#0#255#255#0#0#255#171#0#0#255#9#255#255#255#0#255#255#255#0#0#0 + +#255#6#0#0#255#15#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#0#0#255#23#0#0#255#167#0#0#255#252#0#0#255#255#0#0 + +#255#255#0#0#255#226#0#0#255'/'#255#255#255#0#255#255#255#0#255#255#255#0#0#0 + +#255'P'#0#0#255#218#0#0#255#255#0#0#255#203#0#0#255'G'#255#255#255#0#0#0#255 + +' '#0#0#255#163#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0 + +#255#6#0#0#255#127#0#0#255#222#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255 + +#248#0#0#255'e'#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#0#0#255#16#0#0#255#144#0#0#255#234#0#0#255#242#0#0#255#148#0#0#255 + +'B'#0#0#255#231#0#0#255#24#255#255#255#0#255#255#255#0#0#0#255'`'#0#0#255#204 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#254#0#0#255#151#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#0#0#255'('#0#0#255#167#0#0#255#246#0#0#255 + +#230#0#0#255#255#0#0#255#145#255#255#255#0#0#0#255#24#0#0#255#238#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#244#0#0#255#136#0#0#255#1#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255'a'#0#0 + +#255#252#0#0#255#255#0#0#255#224#0#0#255#15#0#0#255#8#0#0#255#228#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#229#0#0#255'c'#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255 + +#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0#255'i'#0#0#255#194#0 + +#0#255#153#0#0#255'j'#0#0#255#22#0#0#255#25#0#0#255#190#0#0#255#255#0#0#255 + +#255#0#0#255#240#0#0#255#164#0#0#255'2'#255#255#255#0#255#255#255#0#255#255 + +#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#0#0#0'@'#0#0#7 + +#190#0#0#0#171#0#0#0'('#255#255#255#0#0#0#255#13#255#255#255#0#255#255#255#0 + +#255#255#255#0#0#0#255#12#0#0#255#191#0#0#255#202#0#0#255#185#0#0#255#156#0#0 + +#255'/'#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0#255#255#255#0 + +#255#255#255#0#255#255#255#0#255#255#255#0#9'NumGlyphs'#2#0#7'OnClick'#7#15 + +'RefreshBtnClick'#11'OnMouseDown'#7#19'RefreshBtnMouseDown'#0#0#6'TLabel'#7 + +'TRLabel'#4'Left'#3#152#0#6'Height'#2#14#3'Top'#2#15#5'Width'#2')'#7'Caption' + +#6#8'TR (sec)'#11'ParentColor'#8#0#0#12'TSpeedButton'#7'PlotBtn'#4'Left'#3 + +#232#1#6'Height'#2#25#3'Top'#2#7#5'Width'#2'?'#7'Caption'#6#4'Plot'#5'Color' + +#7#9'clBtnFace'#9'NumGlyphs'#2#0#7'OnClick'#7#11'PSPlotClick'#0#0#12'TSpeedB' + +'utton'#7'TextBtn'#4'Left'#3'0'#2#6'Height'#2#25#3'Top'#2#7#5'Width'#2'P'#7 + +'Caption'#6#4'Text'#5'Color'#7#9'clBtnFace'#9'NumGlyphs'#2#0#7'OnClick'#7#11 + +'PSTextClick'#0#0#14'TFloatSpinEdit'#6'TREdit'#4'Left'#3#240#0#6'Height'#2#21 + +#3'Top'#2#9#5'Width'#2'R'#13'DecimalPlaces'#2#4#9'Increment'#2#1#8'MaxValue' + +#4#0#225#245#5#8'MinValue'#2#0#8'TabOrder'#2#0#5'Value'#2#0#0#0#9'TComboBox' + +#10'HSpeedDrop'#4'Left'#3'`'#1#6'Height'#2#21#3'Top'#2#5#5'Width'#2'x'#10'It' + +'emHeight'#2#13#13'Items.Strings'#1#6#6'To Fit'#6#2'x1'#6#2'x2'#6#2'x3'#6#2 + +'x4'#6#2'x5'#6#2'x6'#6#2'x7'#6#2'x8'#6#2'x9'#6#3'x10'#0#8'OnChange'#7#15'Tra' + +'ckBar1Change'#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#1#0#0#14'TFloatSp' + +'inEdit'#7'MinEdit'#4'Left'#3#144#2#6'Height'#2#21#3'Top'#2#6#5'Width'#2'R' + +#13'DecimalPlaces'#2#4#9'Increment'#2#1#8'MaxValue'#2'd'#8'MinValue'#2#0#8'T' + +'abOrder'#2#2#5'Value'#2#0#0#0#14'TFloatSpinEdit'#7'MaxEdit'#4'Left'#3#0#3#6 + +'Height'#2#21#3'Top'#2#6#5'Width'#2'R'#13'DecimalPlaces'#2#4#9'Increment'#2#1 + ,#8'MaxValue'#2'd'#8'MinValue'#2#0#8'TabOrder'#2#3#5'Value'#2#0#0#0#9'TTrackB' + +'ar'#9'TrackBar1'#4'Left'#3'`'#3#6'Height'#2#29#3'Top'#2#4#5'Width'#3#204#0#8 + +'OnChange'#7#15'TrackBar1Change'#8'Position'#2#0#8'TabOrder'#2#4#7'Visible'#8 + +#0#0#0#10'TStatusBar'#10'StatusBar1'#4'Left'#2#0#6'Height'#2#20#3'Top'#3#134 + +#1#5'Width'#3'I'#4#6'Panels'#14#1#5'Width'#3#250#0#0#1#5'Width'#2'2'#0#0#11 + +'SimplePanel'#8#0#0#9'TMainMenu'#9'MainMenu1'#4'left'#2#14#3'top'#2#5#0#9'TM' + +'enuItem'#9'MenuItem1'#7'Caption'#6#4'File'#0#9'TMenuItem'#8'OpenMenu'#7'Cap' + +'tion'#6#9'Open data'#8'ShortCut'#3'O@'#7'OnClick'#7#13'OpenDataClick'#0#0#9 + +'TMenuItem'#7'FFTMenu'#7'Caption'#6#14'Power spectrum'#7'Visible'#8#7'OnClic' + +'k'#7#12'FFTitemClick'#0#0#9'TMenuItem'#8'SaveMenu'#7'Caption'#6#14'Save as ' + +'bitmap'#7'OnClick'#7#15'SaveasEMF1Click'#0#0#9'TMenuItem'#13'Extract4Drois' + +#7'Caption'#6#25'Create resting state ROIs'#7'OnClick'#7#18'Extract4DroisCli' + +'ck'#0#0#9'TMenuItem'#9'BatchMenu'#7'Caption'#6#18'Batch process data'#7'OnC' + +'lick'#7#15'Batchdata1Click'#0#0#9'TMenuItem'#12'FSLBatchMenu'#7'Caption'#6 + +#17'FSL batch process'#7'OnClick'#7#14'FSLbatch1Click'#0#0#9'TMenuItem'#9'Cl' + +'oseMenu'#7'Caption'#6#12'Close window'#8'ShortCut'#3'W@'#7'OnClick'#7#17'Cl' + +'osewindow1Click'#0#0#0#9'TMenuItem'#5'Edit1'#7'Caption'#6#4'Edit'#0#9'TMenu' + +'Item'#8'CopyMenu'#7'Caption'#6#4'Copy'#7'OnClick'#7#10'Copy1Click'#0#0#0#0 + +#22'TSelectDirectoryDialog'#22'SelectDirectoryDialog1'#4'left'#3#184#0#0#0#0 +]); diff --git a/graphx.pas b/graphx.pas new file mode 100755 index 0000000..5580e6d --- /dev/null +++ b/graphx.pas @@ -0,0 +1,1094 @@ +unit graphx; +{$IFDEF FPC} +{$mode objfpc}{$H+} +{$ENDIF} + +interface +{$DEFINE noFFTs} +uses +{$IFDEF FFTs} + FFTs, +{$ENDIF} +{$IFDEF FPC} +LResources, +Spin, +{$ELSE} +ShlObj,Windows,RXSpin, +{$ENDIF} + Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Buttons, ToolWin, ComCtrls,define_types, ExtCtrls,Text, StdCtrls, + perisettings, Menus,ClipBrd,metagraph,periplot,userdir; + +Type + + { TGraph4DForm } + + TGraph4DForm = class(TForm) + Image1: TImage; + MainMenu1: TMainMenu; + MenuItem1: TMenuItem; + Edit1: TMenuItem; + CopyMenu: TMenuItem; + CloseMenu: TMenuItem; + FSLBatchMenu: TMenuItem; + FFTMenu: TMenuItem; + Extract4Drois: TMenuItem; + BatchMenu: TMenuItem; + SaveMenu: TMenuItem; + OpenMenu: TMenuItem; + MinEdit: TFloatSpinEdit; + MaxEdit: TFloatSpinEdit; + HSpeedDrop: TComboBox; + PlotBtn: TSpeedButton; + TextBtn: TSpeedButton; + SelectDirectoryDialog1: TSelectDirectoryDialog; + StatusBar1: TStatusBar; + TrackBar1: TTrackBar; + TREdit: TFloatSpinEdit; + FourDBar: TPanel; + TRLabel: TLabel; + OpenDataBtn: TSpeedButton; + RefreshBtn: TSpeedButton; + + + //procedure Plot4DFFT(lStartSample: integer); + //function XL: boolean; + procedure FormShow(Sender: TObject); + function ReadGraf(lFilename: string; lBatch,lTRcritical: boolean): boolean; + procedure FormCreate(Sender: TObject); + procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); + procedure Plot4DTrace(lStartSample: integer); + procedure TextBtnClick(Sender: TObject); + procedure TrackBar1Change(Sender: TObject); + procedure OpenDataClick(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure PSPlotClick(Sender: TObject); + procedure PSTextClick(Sender: TObject); + //procedure rfx; + procedure Copy1Click(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure SaveasEMF1Click(Sender: TObject); + procedure FFTitemClick(Sender: TObject); + procedure RefreshBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Extract4DroisClick(Sender: TObject); + procedure Batchdata1Click(Sender: TObject); + procedure RefreshBtnClick(Sender: TObject); + procedure FSLbatch1Click(Sender: TObject); + procedure FSLtest1Click(Sender: TObject); + + private + + public + { Public declarations } + end; + +var + Graph4DForm: TGraph4DForm; + +implementation + +uses + nifti_img_view, nifti_img,nifti_hdr, nifti_hdr_view,periutils, reslice_fsl; +const + //kMaxCond = 6; + kMaxLines = kMaxCond* knMaxOverlay; + //kClrRA: array [1..kMaxCond] of TColor = (clRed,clBlue,clGreen,clTeal,clAqua,clSilver); + //kPenStyleRA: array[1..kVOIOverlayNum] of TPenStyle = (psDot,psDot,psDash,psDashDot,psDashDotDot);//abba + //kPenStyleRA: array[1..kVOIOverlayNum] of TPenStyle = (psSolid,psDot,psDash,psDashDot,psDashDotDot); + +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} +var + g4DHdr: TMRIcroHdr; + g4Ddata: T4DTrace; + + +(*procedure PrepPlot(var lImage: TMetafileCanvas; lL,lT,lR,lB,lWid,lHt,lFontSize: integer); +begin + lImage.Font.Name := 'Arial'; + lImage.Font.Size := 12; + + lImage.pen.color := clBlack; + lImage.Font.color := clBlack; + lImage.Brush.Style := bsSolid; + lImage.Brush.color := clWhite; + lImage.Rectangle(1,1,lWid,lHt); + lImage.Rectangle(lL,lT,lR,lB); +end; *) + + +{$IFDEF FFTs} +procedure ROI2FFT (var l4DHdr: TMRIcroHdr; lROInum: integer; var lFFTLines: SingleP); +var + + lVolSz,lnVol,lVol,lVox,lCount,lVolOffset,lnFFTOut,lP: integer; + l16Buf : SmallIntP; + lFFT,lFFTOut,l32Buf : SingleP; + lFFTsum: doubleP; +begin + lnVol := l4DHdr.NIFTIhdr.dim[4]; + if lnVol < 5 then + exit; + lVolSz :=l4DHdr.NIFTIhdr.dim[1]*l4DHdr.NIFTIhdr.dim[2]*l4DHdr.NIFTIhdr.dim[3]; + Getmem(lFFT,(lnVol) * Sizeof(Single)); + lnFFTout := ((lnVol) div 2)-1 ; + Getmem(lFFTout,(lnFFTout) * Sizeof(Single)); + Getmem(lFFTsum,(lnFFTout) * Sizeof(double)); + for lP := 1 to lnFFTout do + lFFTSum[lP] := 0; + + for lP := 1 to lnFFTout do + lFFTout[lP] := 0; + lVolOffset := lVolSz; + //next - compute sum of signal - unrolled loops for each datatype + lCount := 0; + if (l4DHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(l4DHdr.ImgBuffer ); + for lVox := 1 to lVolSz do begin + if gMRIcroOverlay[lROInum].ScrnBuffer[lVox] > 0 then begin + for lVol := 1 to lnVol do + lFFT[lVol] := l32Buf[lVox+((lVol-1)*lVolOffset)]; + FFTPower(lFFT,lFFTout,lnVol); + for lP := 1 to lnFFTout do + lFFTSum[lP] := lFFTSum[lP]+lFFTout[lP]; + inc(lCount); + end; //part of ROI + end; //for each vox + end else if (l4DHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(l4DHdr.ImgBuffer ); + for lVox := 1 to lVolSz do begin + if gMRIcroOverlay[lROInum].ScrnBuffer[lVox] > 0 then begin + for lVol := 1 to lnVol do + lFFT[lVol] := l16Buf[lVox+((lVol-1)*lVolOffset)]; + FFTPower(lFFT,lFFTout,lnVol); + //FFTPower(lFFT,lFFx,lnVol); + for lP := 1 to lnFFTout do + lFFTSum[lP] := lFFTSum[lP]+lFFTout[lP]; + inc(lCount); + end; //part of ROI + end; //for each vox + end else if l4DHdr.ImgBufferBPP = 1 then begin + for lVox := 1 to lVolSz do begin + if gMRIcroOverlay[lROInum].ScrnBuffer[lVox] > 0 then begin + for lVol := 1 to lnVol do + lFFT[lVol] := l4DHdr.ImgBuffer[lVox+((lVol-1)*lVolOffset)]; + FFTPower(lFFT,lFFTout,lnVol); + for lP := 1 to lnFFTout do + lFFTSum[lP] := lFFTSum[lP]+lFFTout[lP]; + inc(lCount); + end; //part of ROI + end; //for each vox + end else + showmessage('Serious error: unknown data size!'); + //now compute mean signal + if lCount > 0 then begin + for lP := 1 to lnFFTout do + lFFTSum[lP] := lFFTSum[lP] / lCount; + for lP := 1 to lnFFTout do + if specialdouble(lFFTSum[lP]) then + lFFTSum[lP] := 0; + end; + for lP := 1 to lnFFTout do + lFFTLines[lP] := lFFTSum[lP]; + freemem(lFFT); + freemem(lFFTout); + freemem(lFFTsum); +end; + +procedure Plot4DFFT(lStartSample: integer); +var + //lDataOut: SingleP; + lLines,N,I: Integer; + l4DTrace: T4DTrace; +begin + if (g4dData.lines[1].events < 5) then exit; + lLines := 1; + for I := 2 to kMaxLines do + if g4dData.lines[I].events =g4dData.lines[1].events then + inc(lLines); + N := g4dData.lines[1].events; + N := (N div 2)-1; + Create4DTrace ( l4DTrace); + Init4DTrace(N,lLines,l4DTrace,false); + lLines := 0; + for I := 1 to kMaxLines do + if g4dData.lines[I].events =g4dData.lines[1].events then begin + inc(lLines); + l4DTrace.lines[lLines].eLabel := ROIoverlayNameShort(0);// g4dData.lines[I].eLabel; + N := g4dData.lines[I].events; + FFTPower(g4dData.lines[I].EventRA,l4DTrace.lines[lLines].EventRA,N); + end; //events[i] = events[1] + MinMax4DTrace(l4dtrace); + l4dtrace.HorzMin := 0; + //range will be 0.. 1/TR*Nyquist Sec/Cycle + if Graph4DForm.TREdit.value = 0 then + l4dtrace.HorzWidPerBin := (0.5)/(l4dTrace.lines[1].events-1) + else + l4dtrace.HorzWidPerBin := ((1/Graph4DForm.TREdit.value)*0.5)/(l4dTrace.lines[1].events-1); + CorePlot4DTrace(l4Dtrace,Graph4DForm.Image1,lStartSample,Graph4DForm.HSpeedDrop.ItemIndex,-1,Graph4DForm.TREdit.value,Graph4DForm.MinEdit.value,Graph4DForm.MaxEdit.value,false); + Close4DTrace(l4Dtrace,true); +end; + + +procedure FFT4ROI (var l4DHdr: TMRIcroHdr); +var + l4DTrace: T4DTrace; + lnROI,lROI,lnVol,lnFFTOut: integer; +begin + lnVol := l4DHdr.NIFTIhdr.dim[4]; + if lnVol < 5 then + exit; + lnROI := numROI; + if lnROI < 1 then begin + Plot4DFFT(1); + exit; + end; + Create4DTrace ( l4DTrace); + lnFFTout := (lnVol div 2) -1; + Init4DTrace(lnFFTout,lnROI,l4DTrace,false); + for lROI := 1 to lnROI do begin + ROI2FFT(l4DHdr,ROIoverlayNum(lROI),l4DTrace.Lines[lROI].EventRA); + l4DTrace.Lines[lROI].elabel := ROIoverlayNameShort(lROI); + end; + MinMax4DTrace(l4dtrace); + l4dtrace.HorzMin := 0; + //range will be 0.. 1/TR*Nyquist Sec/Cycle + if Graph4DForm.TREdit.value = 0 then + l4dtrace.HorzWidPerBin := (0.5)/(l4dTrace.lines[1].events-1) + else + l4dtrace.HorzWidPerBin := ((1/Graph4DForm.TREdit.value)*0.5)/(l4dTrace.lines[1].events-1); + CorePlot4DTrace(l4Dtrace,Graph4DForm.Image1,1,Graph4DForm.HSpeedDrop.ItemIndex,-1,Graph4DForm.TREdit.value,Graph4DForm.MinEdit.value,Graph4DForm.MaxEdit.value,false); + Close4DTrace(l4Dtrace,true); +end; +{$ENDIF} + +procedure TGraph4DForm.Plot4DTrace(lStartSample: integer); +begin + + + g4Ddata.HorzWidPerBin := TREdit.value; + CorePlot4DTrace(g4Ddata,Image1,lStartSample,HSpeedDrop.ItemIndex,-1,TREdit.value,MinEdit.value,MaxEdit.value,false); + //StatusBar1.Panels[1].Text := 'Offset:'+inttostr(lStartSample); + //ShowLegend(g4Ddata,Image1, 50,5); +end; + +procedure TGraph4DForm.TextBtnClick(Sender: TObject); +begin + +end; + + + +procedure TextToTrace (var l4DTrace: T4DTrace); +var + lStr: string; + lCond, lnCond,lE: integer; +begin + lncond := 0; + for lCond := 1 to kMaxCond do + if l4DTrace.Lines[lCond].Events > 0 then + inc(lnCond); + if lncond = 0 then + exit; + for lCond := 1 to kMaxCond do begin + if l4DTrace.Lines[lCond].Events > 0 then begin + lStr := gMRIcroOverlay[kBGOverlayNum].HdrFileName+kTextSep+l4DTrace.Lines[lCond].ELabel; + for lE := 1 to l4DTrace.Lines[lCond].Events do + lStr := lStr + kTextSep+ realtostr(l4DTrace.Lines[lCond].EventRA^[lE],4) ; + TextForm.MemoT.lines.add(lStr); + + end; + end; +end; + +function TGraph4DForm.ReadGraf(lFilename: string; lBatch,lTRcritical: boolean): boolean; +label + 666; +var + lnVol: integer; + lReslice : boolean; +begin + ImgForm.CloseImagesClick(nil); + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + result := false; + if not fileexists(lFilename) then exit; + Graph4DForm.Caption := 'Viewing: '+lFilename; + lReslice := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + gBGImg.Prompt4DVolume := false; + //if not lBatch then begin //12/2007 + ImgForm.OpenAndDisplayImg(lFilename,True); + lnVol := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[4]; + if (lnVol < 2) then begin + showmessage('You need to open a 4D image.'); + goto 666; + end; + if not HdrForm.OpenAndDisplayHdr(lFilename,g4DHdr) then goto 666; + if not OpenImg(gBGImg,g4DHdr,false,false,false,false,true {4D!}) then goto 666; + TrackBar1.Max := lnVol; + if gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.PixDim[4] = 0 then begin + beep; + ImgForm.StatusLabel.caption := 'Assuming TR = '+floattostr(TREdit.value); + end else + TREdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.PixDim[4];//TR + if (TREdit.value = 0) and (lTRcritical) then + showmessage('Please set the TR value [in seconds]'); + result := true; +666: + gBGImg.ResliceOnLoad := lReslice; + gBGImg.Prompt4DVolume := true; +end; + +procedure TGraph4DForm.FormShow(Sender: TObject); +begin +end; +(*{x$IFDEF FFTs} +procedure TGraph4DForm.FormShow(Sender: TObject); +var + lFilename: string; +begin + //abba + lFilename := 'C:\cygwin\home\mscae\20061220_140508\'; + //ReadCond(lFilename+'puls.txt',g4Ddata,1); + //ReadCond(lFilename+'resp.txt',g4Ddata,2); + HdrForm.OpenHdrDlg.Filename := lFilename+'rachris.nii.gz'; + ReadGraf(HdrForm.OpenHdrDlg.Filename ); + ImgForm.XViewEdit. value := 43; + ImgForm.YViewEdit. value := 37; + ImgForm.ZViewEdit. value := 22; + PSForm.BinWidthEdit.value := 0.1; + PSForm.PreBinEdit.value := 5; + PSForm.PostBinEdit.value := 5; + lFilename := 'C:\cygwin\home\mscae\20061220_140508\ravoi.voi'; + //ImgForm.OverlayOpenCore ( lFilename, kBGOverlayNum+1); + + RefreshBtnClick(nil); +end; +{x$ELSE} //no FFT + +procedure TGraph4DForm.FormShow(Sender: TObject); +var + lFilename: string; + //lReslice : boolean; +begin + //lReslice :=gReslice; + //gReslice := false; + ReadCond(extractfiledir(paramstr(0))+'\L_Tap.txt',g4Ddata,1); + ReadCond(extractfiledir(paramstr(0))+'\R_Tap.txt',g4Ddata,2); + HdrForm.OpenHdrDlg.Filename := extractfiledir(paramstr(0))+'\filtered_func_data.nii.gz'; + ReadGraf(HdrForm.OpenHdrDlg.Filename ); + ImgForm.XViewEdit. value := 42; + ImgForm.YViewEdit. value := 29; + ImgForm.ZViewEdit. value := 28; + + lFilename := extractfiledir(paramstr(0))+'\Left.voi'; + ImgForm.OverlayOpenCore ( lFilename, kBGOverlayNum+1); + //VR( lFilename, 1); + //ImgForm.OpenVOICore(lFilename); + lFilename := extractfiledir(paramstr(0))+'\Right.voi'; + ImgForm.OverlayOpenCore ( lFilename,kBGOverlayNum+2); + //VR(lFilename,2); + RefreshBtnClick(nil); + //gReslice := lReslice; +end; +{x$ENDIF} +*) + + +procedure TGraph4DForm.FormCreate(Sender: TObject); +begin + {$IFNDEF FPC} + gWmf := TMetafile.Create; + gWmf.Enhanced := True; + {$ENDIF} + Create4DTrace(g4Ddata); + Graph4DForm.DoubleBuffered := true; + HSpeedDrop.ItemIndex := 0; + InitImgMemory(g4DHdr); +end; + +procedure TGraph4DForm.FormClose(Sender: TObject; var CloseAction: TCloseAction); +begin + + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + //gWmf.Free; +end; + +procedure TGraph4DForm.TrackBar1Change(Sender: TObject); +begin + Trackbar1.visible := (HSpeedDrop.ItemIndex > 0); + Plot4DTrace(TrackBar1.position); +end; + +{$DEFINE notTest4D} +procedure TGraph4DForm.OpenDataClick(Sender: TObject); +var + lI,lCnt: integer; + lStr: string; +begin + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); +{$IFDEF Test4D} + if not ReadGraf('C:\tx\20091006\fsl\filtered_func_data.nii.gz',false,true) then exit; + ReadCond('C:\tx\20091006\fsl\timing.txt',g4Ddata,1); + //ReadCond('C:\fatigue\TD\b.txt',g4Ddata,2); + PSPlotClick(nil); + exit; + + if not ReadGraf('C:\fatigue\perisample\filtered_func_data.nii.gz',false,true) then exit; + ReadCond('C:\fatigue\perisample\L_Tap.txt',g4Ddata,1); + ReadCond('C:\fatigue\perisample\R_Tap.txt',g4Ddata,2); + lI := 1; + lStr := 'C:\fatigue\perisample\left.voi'; + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + PSPlotClick(nil); + exit; +{$ENDIF} + if not OpenDialogExecute(kImgFilter,'Select 4D image',false) then exit; + if not ReadGraf(HdrForm.OpenHdrDlg.Filename,false,true) then exit; + ImgForm.XViewEdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1] div 2; + ImgForm.YViewEdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2] div 2; + ImgForm.ZViewEdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3] div 2; + if OpenDialogExecute(kTxtFilter,'Select 3-column event onset time files [optional]',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > 0 then begin + lCnt := HdrForm.OpenHdrDlg.Files.Count; + if lCnt > kMaxCond then begin + showmessage('Can only load '+inttostr(kMaxCond)+'conditions'); + lCnt := kMaxCond; + end; + for lI := 1 to lCnt do + ReadCond(HdrForm.OpenHdrDlg.Files[lI-1],g4Ddata,lI); + end;//if count > 1 + end; //if opendialog + if OpenDialogExecute(kImgPlusVOIFilter,'Select regions of interest',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > 0 then begin + lCnt := HdrForm.OpenHdrDlg.Files.Count; + //Apr07 + if lCnt > (knMaxOverlay-2) then begin + showmessage('Can only load '+inttostr(knMaxOverlay-2)+'conditions'); + lCnt := knMaxOverlay; + end; + for lI := 1 to lCnt do begin + lStr := HdrForm.OpenHdrDlg.Files[lI-1]; + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + end; + end;//if count > 1 + end; //if opendialog + RefreshBtnMouseDown(nil,mbleft,[],1,1); + +end; + +procedure TGraph4DForm.FormResize(Sender: TObject); +begin + if not Graph4DForm.visible then + exit; + GraphResize(Image1); + Plot4DTrace(TrackBar1.position); +end; + +procedure TGraph4DForm.PSPlotClick(Sender: TObject); +var +lPSPlot: TPSPlot; +{var +lTRSec,lBinWidthSec: single; lnNegBins,lnPosBins: integer; lSliceTime, +lSavePSVol,lTextOutput,lGraphOutput,lBaselineCorrect,lPctSignal, +lRemoveRegressorVariability,lTemporalDeriv,lPlotModel: boolean; } +begin + if NCond ( g4Ddata) < 1 then begin + RefreshBtnMouseDown(nil,mbleft,[],1,1); + exit; + end; + lPSPlot.TRSec := TREdit.value; + if not PSForm.GetPeriSettings(lPSPlot) then + exit; + lPSPlot.TextOutput := false; + lPSPlot.GraphOutput := true; + lPSPlot.batch := false; + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot); +end; + +procedure TGraph4DForm.PSTextClick(Sender: TObject); +var lPSPlot: TPSPlot; +begin + if NCond ( g4Ddata) < 1 then begin + RefreshBtnMouseDown(nil,mbleft,[],1,1); + TextForm.MemoT.Lines.Clear;//prepare to report results + TextToTrace (g4Ddata); + TextForm.show; + exit; + end; + lPSPlot.TRSec := TREdit.value; + if not PSForm.GetPeriSettings(lPSPlot) then + exit; + lPSPlot.TextOutput := true; + lPSPlot.GraphOutput := true; + lPSPlot.batch := false; + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot); +end; + +procedure TGraph4DForm.Copy1Click(Sender: TObject); +{$IFDEF FPC} +begin + if (Image1.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to generate an image before you can copy it to the clipboard.'); + exit; + end; + Image1.Picture.Bitmap.SaveToClipboardFormat(2); +end; + +{$ELSE} +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; +begin + if gWMF.Empty then begin + showmessage('Please Open a dataset first.'); + exit; + end; + gWmf.SaveToClipboardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); +end; +{$ENDIF} + + +procedure TGraph4DForm.FormDestroy(Sender: TObject); +begin +//gWmf.Free; +end; + +procedure TGraph4DForm.Closewindow1Click(Sender: TObject); +begin + Graph4DForm.Close; +end; + +procedure TGraph4DForm.SaveasEMF1Click(Sender: TObject); +begin + {$IFDEF FPC} + SaveImgAsPNGBMP (Image1); + {$ELSE} + if gWMF.Empty then begin + showmessage('Please Open a dataset first.'); + exit; + end; + ImgForm.SaveDialog1.Filter := 'Enhanced Metafile|*.emf'; + ImgForm.SaveDialog1.DefaultExt := '*.emf'; + if not ImgForm.SaveDialog1.Execute then exit; + gWmf.SaveToFile (ChangeFileExt(ImgForm.SaveDialog1.FileName,'.emf')); + {$ENDIF} +end; + +procedure TGraph4DForm.FFTitemClick(Sender: TObject); +begin +{$IFDEF FFTs} + FFT4ROI (g4DHdr); + exit; +{$ENDIF} +showmessage('FFT not included with this build.'); +end; + +procedure TGraph4DForm.RefreshBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + if (g4DHdr.ImgBufferItems = 0) then begin + showmessage('You must first load 4D data [Press the ''Open Data'' button.'); + exit; + end; + ConvertToTrace(g4DHdr,g4Ddata,ImgForm.XViewEdit.value,ImgForm.YViewEdit.value,ImgForm.ZViewEdit.value); + Plot4DTrace(TrackBar1.position); +end; + +procedure TGraph4DForm.Extract4DroisClick(Sender: TObject); +const + kMin8bit = 0; + kMax8bit = 255; +var + lROInum,lVol,lnVol,lPos,lROI,lVolSz,lVolOffset: integer; + lStr: string; + SumRA : array [kMin8bit..kMax8bit] of double; + nRA : array [kMin8bit..kMax8bit] of longint; + l16Buf : SmallIntP; + l32Buf : SingleP; + lOutStr: string; +begin + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + if not OpenDialogExecute(kImgFilter,'Select 4D image',false) then exit; + if not ReadGraf(HdrForm.OpenHdrDlg.Filename,false,true) then exit; + ImgForm.XViewEdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1] div 2; + ImgForm.YViewEdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2] div 2; + ImgForm.ZViewEdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3] div 2; + lVolSz := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1]*gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]*gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3]; + if not OpenDialogExecute(kImgPlusVOIFilter,'Select regions of interest',false) then + exit; + lROInum := 1+kBGOverlayNum; + lStr := HdrForm.OpenHdrDlg.Filename; + ImgForm.OverlayOpenCore(lStr,lROInum); + if gMRIcroOverlay[lROInum].ImgBufferBPP <> 1 then begin + showmessage('Overlay must be 8-bit image'); + exit; + end; + if (gMRIcroOverlay[lROInum].ImgBufferItems <> lVolSz) or (lVOlSz < 1) then begin + showmessage('Overlay must have identical dimensions as 4D image'); + exit; + end; + lnVol := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[4]; + if lnVol < 2 then begin + showmessage('Requires 4D data'); + exit; + end; + if (g4DHdr.ImgBufferItems <> ({lnVol*}lVolSz)) then begin + showmessage('4D image not loaded correctly '+inttostr(g4DHdr.ImgBufferItems)+' <> '+inttostr(lVolSz)); + exit; + end; + TextForm.MemoT.Lines.Clear;//prepare to report results + //count frequency of each column... + for lPos := kMin8Bit to kMax8bit do + nRA[lPos] := 0; + for lPos := 1 to lVolSz do begin + lROI := gMRIcroOverlay[lROInum].ImgBuffer^[lPos]; //ROI must be 8-bit! + nRA[lROI] := nRA[lROI] + 1; + end; + //report detected ROI volumes + lOutStr := 'vol'; + for lROI := kMin8Bit to kMax8bit do + if nRA[lROI] > 0 then + lOutStr := lOutStr+kTextSep+inttostr(nRA[lROI]); + TextForm.MemoT.lines.add(lOutStr); + //report detected ROIs [column labels] + lOutStr := 'ROI'; + for lROI := kMin8Bit to kMax8bit do + if nRA[lROI] > 0 then + lOutStr := lOutStr+kTextSep+inttostr(lROI); + TextForm.MemoT.lines.add(lOutStr); + //compute mean intensity for each ROI at each timepoint + l32Buf := SingleP(g4DHdr.ImgBuffer); + l16Buf := SmallIntP(g4DHdr.ImgBuffer); + for lVol := 1 to lnVol do begin + lVolOffset := (lVol-1)*lVolSz; + for lPos := kMin8Bit to kMax8bit do //initialize all ROIs for this volume + SumRA[lPos] := 0; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + for lPos := 1 to lVolSz do begin + lROI := gMRIcroOverlay[lROInum].ImgBuffer^[lPos]; //ROI must be 8-bit! + SumRA[lROI] := SumRA[lROI] + l32Buf^[lPos+lVolOffset]; + end; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + for lPos := 1 to lVolSz do begin + lROI := g4DHdr.ImgBuffer^[lPos]; //ROI must be 8-bit! + SumRA[lROI] := SumRA[lROI] + l16Buf^[lPos+lVolOffset]; + end; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then begin + for lPos := 1 to lVolSz do begin + lROI := gMRIcroOverlay[lROInum].ImgBuffer^[lPos]; //ROI must be 8-bit! + SumRA[lROI] := SumRA[lROI] + gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos+lVolOffset]; + end; + end else begin + showmessage('Serious error: unsupported datatype!'); + exit; + end; + lOutStr := inttostr(lvol); + for lROI := kMin8Bit to kMax8bit do + if nRA[lROI] > 0 then + lOutStr := lOutStr+kTextSep+realtostr(SumRA[lROI]/nRA[lROI],4); + TextForm.MemoT.lines.add(lOutStr); + end; //for each volume + TextForm.show; + RefreshBtnMouseDown(nil,mbleft,[],1,1); +end; + +procedure TGraph4DForm.Batchdata1Click(Sender: TObject); +label + 111; +var + lStr: string; + l4D,lVectors,lVOI: TStringList; + lPSPlot: TPSPlot; + lImg,lI: integer; + (*lTRSec,lBinWidthSec: single; + lI,lImg,lnNegBins,lnPosBins: integer; + lSliceTime,lSavePSVol,lTextOutput,lGraphOutput,lBaselineCorrect,lPctSignal, + lRemoveRegressorVariability,lTemporalDeriv,lPlotModel: boolean; *) +begin + ImgForm.CloseImagesClick(nil); + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + if not OpenDialogExecute(kImgFilter,'Select 4D images',true) then exit; + l4D := TStringList.Create; + lVectors := TStringList.Create;//empty + lVOI := TStringList.Create; + l4D.AddStrings(HdrForm.OpenHdrDlg.Files); + if OpenDialogExecute(kTxtFilter,'Select 3-column event onset time files',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > kMaxCond then begin + showmessage('Can only load '+inttostr(kMaxCond)+'conditions'); + goto 111; + end; + lVectors.AddStrings(HdrForm.OpenHdrDlg.Files); + end; + if not OpenDialogExecute(kImgPlusVOIFilter,'Select region[s] of interest',true) then + goto 111; + if HdrForm.OpenHdrDlg.Files.Count > (knMaxOverlay-2) then begin + showmessage('Can only load '+inttostr(knMaxOverlay-2)+'conditions'); + goto 111; + end; + lVOI.AddStrings(HdrForm.OpenHdrDlg.Files); + if not ReadGraf(l4D[0],false, (lVectors.count > 0) ) then + goto 111; //read first dataset to set TR! + //get plot settings.... + lPSPlot.TRSec := TREdit.value; + if lVectors.count > 0 then + if not PSForm.GetPeriSettings(lPSPlot) then + goto 111; + lPSPlot.TextOutput := true; + lPSPlot.GraphOutput := false; + lPSPlot.Batch := true; + TextForm.MemoT.Lines.Clear;//prepare to report results + for lImg := 1 to l4D.Count do begin + //showmessage(l4D[lImg-1]); + if lImg > 1 then begin//we have already read 1st img + Refresh; + Close4DTrace(g4Ddata,true); + ImgForm.CloseImagesClick(nil); + FreeImgMemory(g4DHdr); + if not ReadGraf(l4D[lImg-1],true,(lVectors.count > 0)) then + goto 111; //read first dataset to set TR! + end; //all except 1st image + if lVectors.count > 0 then begin + for lI := 1 to lVectors.count do + ReadCond(lVectors[lI-1],g4Ddata,lI); + end;//vectors > 0 + if lVOI.count > 0 then begin + for lI := 1 to lVOI.count do begin + lStr := lVOI[lI-1]; + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + end;//for each VOI + end; //VOI > 0 + if lVectors.Count > 0 then + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot) + else begin + // RefreshBtnMouseDown(nil,mbleft,[],1,1); + ConvertToTrace(g4DHdr,g4Ddata,ImgForm.XViewEdit.value,ImgForm.YViewEdit.value,ImgForm.ZViewEdit.value); + TextToTrace (g4Ddata); + RegressTrace(g4Ddata); + end; + end; + TextForm.show; + 111: + lVOI.Free; + lVectors.Free; + l4D.Free; +end; + +procedure TGraph4DForm.RefreshBtnClick(Sender: TObject); +begin + RefreshBtnMouseDown(nil,mbleft,[],1,1); +end; + + + + + +function ResliceFSLVOIs(var lFeatDirs,lVOI: TStringList): boolean; +//uses reslice +var + lDir,lV: integer; + lMatName,lFuncName,lReslicedVOIName:string; +begin + result := false; + if lFeatDirs.count < 1 then exit; + if lVOI.count < 1 then exit; + for lDir := 1 to (lFeatDirs.Count) do begin + lMatName := FSLMatName (lFeatDirs[lDir-1]); + lFuncName := FSLFuncName (lFeatDirs[lDir-1]); + for lV := 1 to lVOI.Count do begin + lReslicedVOIName := FSLReslicedVOIName (lFeatDirs[lDir-1], lVOI[lV-1]); + if not ResliceImg (lFuncName,lVOI[lV-1],lMatName,lReslicedVOIName) then begin + Showmessage('graphx reslice FSL failed.'); + exit; + end; + end;//for each VOI + end;//for each Dir + result := true; +end; +{$DEFINE notTEST} +function FindFEATFolders (var lFeatDirs:TStringList): boolean; +var + lDir,lFeatPath: string; + lSearchRec: TSearchRec; +begin + result := false; + {$IFDEF TEST} + lDir := 'C:\cygwin\home\express'; + {$ELSE} + //lDir := 'C:\cygwin\home\express'; + //lDir := SelectDirectory('Choose root folder that contains .feat folders', BIF_RETURNONLYFSDIRS); + LDir := UserDataFolder; + lDir := GetDirPrompt (lDir); + {$ENDIF} + if lDir = '' then exit; + lFeatDirs := TStringList.Create; + if FindFirst(lDir+pathdelim+'*'+'.feat', faAnyFile, lSearchRec) = 0 then begin + repeat + if (faDirectory and lSearchRec.attr) = faDirectory then begin + lFeatPath := lDir+pathdelim+lSearchRec.Name; + if Fileexists(FSLMatName(lFeatPath)) and Fileexists(FSLFuncName(lFeatPath)) then + lFeatDirs.Add(lFeatPath) + else + Showmessage('Can not find '+FSLMatName(lFeatPath) +' or '+FSLFuncName(lFeatPath) ); + end; + until (FindNext(lSearchRec) <> 0); + end; + FindClose(lSearchRec); + if lFeatDirs.Count < 1 then begin + Showmessage('Unable to find any feat dirs in path '+lDir); + lFeatDirs.free; + exit; + end; + result := true; +end; + + +procedure TGraph4DForm.FSLbatch1Click(Sender: TObject); +label + 111; +var + lStr: string; + lFeatDirs,lVectors,lVOI: TStringList; + //lTRSec,lBinWidthSec: single; + lI,lImg: integer; + lUseFSLEVs: Boolean; + lPSPlot: TPSPlot; + {lSliceTime,lSavePSVol,lTextOutput,lBaselineCorrect,lPctSignal, + lRemoveRegressorVariability,lTemporalDeriv,lUseFSLEVs,lPlotModel: boolean; } +begin + ImgForm.CloseImagesClick(nil); + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + if not FindFEATFolders (lFeatDirs) then + exit; + lVectors := TStringList.Create;//empty + lVOI := TStringList.Create; + {$IFDEF TEST} + lUseFSLEVs := false; +lFeatDirs.AddStrings(lFeatDirs); +lFeatDirs.AddStrings(lFeatDirs); +lFeatDirs.AddStrings(lFeatDirs); +lFeatDirs.AddStrings(lFeatDirs); +lFeatDirs.AddStrings(lFeatDirs); + lVectors.Add('C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\custom_timing_files\ev1.txt'); + lVectors.Add('C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\custom_timing_files\ev2.txt'); + lVectors.Add('C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\custom_timing_files\ev3.txt'); + lVOI.Add('C:\fatigue\v1.nii.gz'); + lVOI.Add('C:\fatigue\v2.nii.gz'); + {$ELSE} + FSLEVNames (lFeatDirs[0], lVectors); + lUseFSLEVs := false; + if lVectors.count > 0 then + lUseFSLEVs := OKMsg('Use event vectors from the .FEAT'+pathdelim+'custom_timing_files folder?'); //shows dialog with OK/Cancel returns true if user presses OK + if not lUseFSLEVs then begin + lVectors.clear; + if OpenDialogExecute(kTxtFilter,'Select 3-column event onset time files',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > kMaxCond then begin + showmessage('Can only load '+inttostr(kMaxCond)+'conditions'); + goto 111; + end; + lVectors.AddStrings(HdrForm.OpenHdrDlg.Files); + end; + end; //manually select EVs + + if not OpenDialogExecute(kImgPlusVOIFilter,'Select volume[s] of interest [2mm MNI space]',true) then + goto 111; + if HdrForm.OpenHdrDlg.Files.Count > (knMaxOverlay-2) then begin + showmessage('Can only load '+inttostr(knMaxOverlay-2)+'conditions'); + goto 111; + end; + lVOI.AddStrings(HdrForm.OpenHdrDlg.Files); + {$ENDIF} + if not ResliceFSLVOIs(lFeatDirs,lVOI) then begin + showmessage('Unable to reslice VOIs!'); + goto 111; + end; + lPSPlot.TextOutput := true; + lPSPlot.GraphOutput := false; + TextForm.MemoT.Lines.Clear;//prepare to report results + + + if not ReadGraf(FSLFuncName (lFeatDirs[0]),false, (lVectors.count > 0) ) then + goto 111; //read first dataset to set TR! + //la1 := (FreeRAM); + //get plot settings.... + lPSPlot.TRSec := TREdit.value; + if lVectors.count > 0 then + if not PSForm.GetPeriSettings(lPSPlot) then + goto 111; + + for lImg := 1 to lFeatDirs.Count do begin + if lImg > 1 then begin//we have already read 1st img + Refresh; + Application.processmessages; + Close4DTrace(g4Ddata,true); + ImgForm.CloseImagesClick(nil); + FreeImgMemory(g4DHdr); + //Textform.memo1.lines.add(inttostr(FreeRAM));//rascal + if not ReadGraf(FSLFuncName (lFeatDirs[lImg-1]),true,(lVectors.count > 0)) then goto 111; //read first dataset to set TR! + if lUseFSLEVs then + FSLEVNames (lFeatDirs[lImg-1], lVectors) + end; //all except 1st image + if lVectors.count > 0 then begin + for lI := 1 to lVectors.count do + ReadCond(lVectors[lI-1],g4Ddata,lI); + end;//vectors > 0 + if lVOI.count > 0 then begin + for lI := 1 to lVOI.count do begin + lStr := FSLReslicedVOIName (lFeatDirs[lImg-1], lVOI[lI-1]); + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + end;//for each VOI + end; //VOI > 0 + + if lVectors.Count > 0 then begin + if lImg = lFeatDirs.Count then + lPSPlot.GraphOutput := true; + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot) + end else begin + ConvertToTrace(g4DHdr,g4Ddata,ImgForm.XViewEdit.value,ImgForm.YViewEdit.value,ImgForm.ZViewEdit.value); + TextToTrace (g4Ddata); + RegressTrace(g4Ddata); + end; + end; + TextForm.show; + 111: + lVOI.Free; + lVectors.Free; + lFeatDirs.free; +end; + +{$DEFINE TEST} +procedure TGraph4DForm.FSLtest1Click(Sender: TObject); +label + 111; +var + lStr: string; + lFeatDirs,lVectors,lVOI: TStringList; + lI,lImg: integer; + lUseFSLEVs: Boolean; + lPSPlot: TPSPlot; + {lSliceTime,lSavePSVol,lTextOutput,lBaselineCorrect,lPctSignal, + lRemoveRegressorVariability,lTemporalDeriv,lUseFSLEVs,lPlotModel: boolean; } +begin + ImgForm.CloseImagesClick(nil); + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + //x if not FindFEATFolders (lFeatDirs) then + //x exit; + lVectors := TStringList.Create;//empty + lVOI := TStringList.Create; + {$IFDEF TEST} + + lFeatDirs := TStringList.Create; + for lI := 1 to 100 do + lFeatDirs.Add('C:\mri\fds.feat'); + + {lUseFSLEVs := true; + FSLEVNames (lFeatDirs[0], lVectors); + } + lUseFSLEVs := false; + lVectors.Add('C:\mri\fds.feat\custom_timing_files\ev1.txt'); + lVectors.Add('C:\mri\fds.feat\custom_timing_files\ev2.txt'); + //lVectors.Add('C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\custom_timing_files\ev3.txt'); + lVOI.Add('C:\mri\left.voi'); + lVOI.Add('C:\mri\right.voi'); + lVOI.Add('C:\mri\v1.voi'); + {$ELSE} + FSLEVNames (lFeatDirs[0], lVectors); + lUseFSLEVs := false; + if lVectors.count > 0 then + lUseFSLEVs := OKMsg('Use event vectors from the .FEAT'+pathdelim+'custom_timing_files folder?'); //shows dialog with OK/Cancel returns true if user presses OK + if not lUseFSLEVs then begin + lVectors.clear; + if OpenDialogExecute(kTxtFilter,'Select 3-column event onset time files',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > kMaxCond then begin + showmessage('Can only load '+inttostr(kMaxCond)+'conditions'); + goto 111; + end; + lVectors.AddStrings(HdrForm.OpenHdrDlg.Files); + end; + end; //manually select EVs + + if not OpenDialogExecute(kImgPlusVOIFilter,'Select volume[s] of interest [2mm MNI space]',true) then + goto 111; + if HdrForm.OpenHdrDlg.Files.Count > (knMaxOverlay-2) then begin + showmessage('Can only load '+inttostr(knMaxOverlay-2)+'conditions'); + goto 111; + end; + lVOI.AddStrings(HdrForm.OpenHdrDlg.Files); + {$ENDIF} + if not ResliceFSLVOIs(lFeatDirs,lVOI) then begin + showmessage('Unable to reslice VOIs!'); + goto 111; + end; + lPSPlot.TextOutput := true; + lPSPlot.GraphOutput := false; + TextForm.MemoT.Lines.Clear;//prepare to report results + + + if not ReadGraf(FSLFuncName (lFeatDirs[0]),false, (lVectors.count > 0) ) then + goto 111; //read first dataset to set TR! + //la1 := (FreeRAM); + //get plot settings.... + lPSPlot.TRSec := TREdit.value; + if lVectors.count > 0 then + if not PSForm.GetPeriSettings(lPSPlot) then + goto 111; + + for lImg := 1 to lFeatDirs.Count do begin + if lImg > 1 then begin//we have already read 1st img + Refresh; + Application.processmessages; + Close4DTrace(g4Ddata,true); + ImgForm.CloseImagesClick(nil); + FreeImgMemory(g4DHdr); + //Textform.memo1.lines.add(inttostr(FreeRAM));//rascal + if not ReadGraf(FSLFuncName (lFeatDirs[lImg-1]),true,(lVectors.count > 0)) then goto 111; //read first dataset to set TR! + if lUseFSLEVs then + FSLEVNames (lFeatDirs[lImg-1], lVectors) + end; //all except 1st image + if lVectors.count > 0 then begin + for lI := 1 to lVectors.count do + ReadCond(lVectors[lI-1],g4Ddata,lI); + end;//vectors > 0 + if lVOI.count > 0 then begin + for lI := 1 to lVOI.count do begin + lStr := FSLReslicedVOIName (lFeatDirs[lImg-1], lVOI[lI-1]); + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + end;//for each VOI + end; //VOI > 0 + + if lVectors.Count > 0 then begin + if lImg = lFeatDirs.Count then + lPSPlot.GraphOutput := true; + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot) + end else begin + ConvertToTrace(g4DHdr,g4Ddata,ImgForm.XViewEdit.value,ImgForm.YViewEdit.value,ImgForm.ZViewEdit.value); + TextToTrace (g4Ddata); + RegressTrace(g4Ddata); + end; + end; + TextForm.show; + 111: + lVOI.Free; + lVectors.Free; + lFeatDirs.free; + showmessage('done'); +end; //test + +initialization +{$IFDEF FPC} + {$I graphx.lrs} +{$ENDIF} + +end. diff --git a/gzio20.pas b/gzio20.pas new file mode 100755 index 0000000..76d85b8 --- /dev/null +++ b/gzio20.pas @@ -0,0 +1,1426 @@ +Unit gzio2; + +{ + Pascal unit based on gzio.c -- IO on .gz files + Copyright (C) 1995-1998 Jean-loup Gailly. + + Define NO_DEFLATE to compile this file without the compression code + + Pascal tranlastion based on code contributed by Francisco Javier Crespo + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + {$ifdef MSDOS} + dos, strings, + {$else} + SysUtils, + {$endif} + zutil, zbase, gzcrc, zdeflate, zinflate, define_types,dialogs; + +type gzFile = voidp; +type z_off_t = long; + +procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +procedure UnGZip (var lInFname: string; var lBuf: ByteP; lOffset,lMaxSz: integer); //unzip +procedure UnGZipCore (var infile : gzFile; var lBuf: ByteP; lReadBytes: integer; lWrite: boolean); + +function gzopen (path:ansistring; mode:string) : gzFile; +function gzsetparams (f:gzfile; level:int; strategy:int) : int; +function gzread (f:gzFile; buf:voidp; len:uInt) : int; +function gzgetc (f:gzfile) : int; +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +{$ifndef NO_DEFLATE} +function gzwrite (f:gzFile; buf:voidp; len:uInt) : int; +function gzputc (f:gzfile; c:char) : int; +function gzputs (f:gzfile; s:PChar) : int; +function gzflush (f:gzFile; flush:int) : int; + {$ifdef GZ_FORMAT_STRING} + function gzprintf (zfile : gzFile; + const format : string; + a : array of int); { doesn't compile } + {$endif} +{$endif} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +function gzrewind (f:gzFile) : int; +function gztell (f:gzfile) : z_off_t; +function gzeof (f:gzfile) : boolean; +function gzclose (f:gzFile) : int; +function gzerror (f:gzFile; var errnum:Int) : string; + +const + SEEK_SET {: z_off_t} = 0; { seek from beginning of file } + SEEK_CUR {: z_off_t} = 1; { seek from current position } + SEEK_END {: z_off_t} = 2; + +implementation + +const + Z_EOF = -1; { same value as in STDIO.H } + Z_BUFSIZE = 16384; + { Z_PRINTF_BUFSIZE = 4096; } + + + gz_magic : array[0..1] of byte = ($1F, $8B); { gzip magic header } + + { gzip flag byte } + + ASCII_FLAG = $01; { bit 0 set: file probably ascii text } + HEAD_CRC = $02; { bit 1 set: header CRC present } + EXTRA_FIELD = $04; { bit 2 set: extra field present } + ORIG_NAME = $08; { bit 3 set: original file name present } + COMMENT = $10; { bit 4 set: file comment present } + RESERVED = $E0; { bits 5..7: reserved } + +type gz_stream = record + stream : z_stream; + z_err : int; { error code for last stream operation } + z_eof : boolean; { set if end of input file } + gzfile : file; { .gz file } + inbuf : pBytef; { input buffer } + outbuf : pBytef; { output buffer } + crc : uLong; { crc32 of uncompressed data } + msg, { error message - limit 79 chars } + path : string[79];//: ansistring; { path name for debugging only - limit 79 chars } + transparent : boolean; { true if input file is not a .gz file } + mode : char; { 'w' or 'r' } + startpos : long; { start of compressed data in file (header skipped) } +end; + +type gz_streamp = ^gz_stream; + +function destroy (var s:gz_streamp) : int; forward; +procedure check_header(s:gz_streamp); forward; + + + + + + +{ GZOPEN ==================================================================== + + Opens a gzip (.gz) file for reading or writing. As Pascal does not use + file descriptors, the code has been changed to accept only path names. + + The mode parameter defaults to BINARY read or write operations ('r' or 'w') + but can also include a compression level ('w9') or a strategy: Z_FILTERED + as in 'w6f' or Z_HUFFMAN_ONLY as in 'w1h'. (See the description of + deflateInit2 for more information about the strategy parameter.) + + gzopen can be used to open a file which is not in gzip format; in this + case, gzread will directly read from the file without decompression. + + gzopen returns NIL if the file could not be opened (non-zero IOResult) + or if there was insufficient memory to allocate the (de)compression state + (zlib error is Z_MEM_ERROR). + +============================================================================} + +function gzopen (path:ansistring; mode:string) : gzFile; + +var + + i : uInt; + err : int; + level : int; { compression level } + strategy : int; { compression strategy } + s : gz_streamp; +{$IFDEF MSDOS} + attr : word; { file attributes } +{$ENDIF} + +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} + +begin + + if (path='') or (mode='') then begin + gzopen := Z_NULL; + exit; + end; + + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + gzopen := Z_NULL; + exit; + end; + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + + s^.stream.zalloc := NIL; { (alloc_func)0 } + s^.stream.zfree := NIL; { (free_func)0 } + s^.stream.opaque := NIL; { (voidpf)0 } + s^.stream.next_in := Z_NULL; + s^.stream.next_out := Z_NULL; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := Z_NULL; + s^.outbuf := Z_NULL; + s^.crc := crc32(0, Z_NULL, 0); + s^.msg := ''; + s^.transparent := false; + + s^.path := path; { limit to 255 chars } + + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + if (s^.mode=chr(0)) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = Z_NULL) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = Z_NULL) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + Assign (s^.gzfile, s^.path); + {$ifdef MSDOS} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + if (not FileExists(s^.path)) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := 0; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := LONG(10); +{$ENDIF} + end + else begin + check_header(s); { skip the .gz header } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + end; + + gzopen := gzFile(s); +end; + + +{ GZSETPARAMS =============================================================== + + Update the compression level and strategy. + +============================================================================} + +function gzsetparams (f:gzfile; level:int; strategy:int) : int; + +var + + s : gz_streamp; + written: integer; + +begin + + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + gzsetparams := Z_STREAM_ERROR; + exit; + end; + + { Make room to allow flushing } + if (s^.stream.avail_out = 0) then begin + s^.stream.next_out := s^.outbuf; + blockwrite(s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); + if (written <> Z_BUFSIZE) then s^.z_err := Z_ERRNO; + s^.stream.avail_out := Z_BUFSIZE; + end; + + gzsetparams := deflateParams (s^.stream, level, strategy); +end; + + +{ GET_BYTE ================================================================== + + Read a byte from a gz_stream. Updates next_in and avail_in. + Returns EOF for end of file. + IN assertion: the stream s has been sucessfully opened for reading. + +============================================================================} + +function get_byte (s:gz_streamp) : int; + +begin + + if (s^.z_eof = true) then begin + get_byte := Z_EOF; + exit; + end; + + if (s^.stream.avail_in = 0) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, Int(s^.stream.avail_in)); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then s^.z_err := Z_ERRNO; + get_byte := Z_EOF; + exit; + end; + s^.stream.next_in := s^.inbuf; + end; + + Dec(s^.stream.avail_in); + get_byte := s^.stream.next_in^; + Inc(s^.stream.next_in); + +end; + + +{ GETLONG =================================================================== + + Reads a Longint in LSB order from the given gz_stream. + +============================================================================} +{ +function getLong (s:gz_streamp) : uLong; +var + x : array [0..3] of byte; + i : byte; + c : int; + n1 : longint; + n2 : longint; +begin + + for i:=0 to 3 do begin + c := get_byte(s); + if (c = Z_EOF) then s^.z_err := Z_DATA_ERROR; + x[i] := (c and $FF) + end; + n1 := (ush(x[3] shl 8)) or x[2]; + n2 := (ush(x[1] shl 8)) or x[0]; + getlong := (n1 shl 16) or n2; +end; +} +function getLong(s : gz_streamp) : uLong; +var + x : packed array [0..3] of byte; + c : int; +begin + { x := uLong(get_byte(s)); - you can't do this with TP, no unsigned long } + { the following assumes a little endian machine and TP } + x[0] := Byte(get_byte(s)); + x[1] := Byte(get_byte(s)); + x[2] := Byte(get_byte(s)); + c := get_byte(s); + x[3] := Byte(c); + if (c = Z_EOF) then + s^.z_err := Z_DATA_ERROR; + GetLong := uLong(longint(x)); +end; + + +{ CHECK_HEADER ============================================================== + + Check the gzip header of a gz_stream opened for reading. + Set the stream mode to transparent if the gzip magic header is not present. + Set s^.err to Z_DATA_ERROR if the magic header is present but the rest of + the header is incorrect. + + IN assertion: the stream s has already been created sucessfully; + s^.stream.avail_in is zero for the first time, but may be non-zero + for concatenated .gz files + +============================================================================} + +procedure check_header (s:gz_streamp); + +var + + method : int; { method byte } + flags : int; { flags byte } + len : uInt; + c : int; + +begin + + { Check the gzip magic header } + for len := 0 to 1 do begin + c := get_byte(s); + if (c <> gz_magic[len]) then begin + if (len <> 0) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + end; + if (c <> Z_EOF) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + s^.transparent := TRUE; + end; + if (s^.stream.avail_in <> 0) then s^.z_err := Z_OK + else s^.z_err := Z_STREAM_END; + exit; + end; + end; + + method := get_byte(s); + flags := get_byte(s); + if (method <> Z_DEFLATED) or ((flags and RESERVED) <> 0) then begin + s^.z_err := Z_DATA_ERROR; + exit; + end; + + for len := 0 to 5 do get_byte(s); { Discard time, xflags and OS code } + + if ((flags and EXTRA_FIELD) <> 0) then begin { skip the extra field } + len := uInt(get_byte(s)); + len := len + (uInt(get_byte(s)) shr 8); + { len is garbage if EOF but the loop below will quit anyway } + while (len <> 0) and (get_byte(s) <> Z_EOF) do Dec(len); + end; + + if ((flags and ORIG_NAME) <> 0) then begin { skip the original file name } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and COMMENT) <> 0) then begin { skip the .gz file comment } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and HEAD_CRC) <> 0) then begin { skip the header crc } + get_byte(s); + get_byte(s); + end; + + if (s^.z_eof = true) then + s^.z_err := Z_DATA_ERROR + else + s^.z_err := Z_OK; + +end; + + +{ DESTROY =================================================================== + + Cleanup then free the given gz_stream. Return a zlib error code. + Try freeing in the reverse order of allocations. + +============================================================================} + +function destroy (var s:gz_streamp) : int; + +begin + + destroy := Z_OK; + + if not Assigned (s) then begin + destroy := Z_STREAM_ERROR; + exit; + end; + + if (s^.stream.state <> NIL) then begin + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + destroy := Z_STREAM_ERROR; +{$ELSE} + destroy := deflateEnd(s^.stream); +{$ENDIF} + end + else if (s^.mode = 'r') then begin + destroy := inflateEnd(s^.stream); + end; + end; + + if (s^.path <> '') then begin + {$I-} + close(s^.gzfile); + {$I+} + if (IOResult <> 0) then destroy := Z_ERRNO; + end; + + if (s^.z_err < 0) then destroy := s^.z_err; + + if Assigned (s^.inbuf) then + FreeMem(s^.inbuf, Z_BUFSIZE); + if Assigned (s^.outbuf) then + FreeMem(s^.outbuf, Z_BUFSIZE); + FreeMem(s, sizeof(gz_stream)); + +end; + + +{ GZREAD ==================================================================== + + Reads the given number of uncompressed bytes from the compressed file. + If the input file was not in gzip format, gzread copies the given number + of bytes into the buffer. + + gzread returns the number of uncompressed bytes actually read + (0 for end of file, -1 for error). + +============================================================================} + +function gzread (f:gzFile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + start : pBytef; + next_out : pBytef; + n : uInt; + crclen : uInt; { Buffer length to update CRC32 } + filecrc : uLong; { CRC32 stored in GZIP'ed file } + filelen : uLong; { Total lenght of uncompressed file } + bytes : integer; { bytes actually read in I/O blockread } + total_in : uLong; + total_out : uLong; + +begin + + s := gz_streamp(f); + start := pBytef(buf); { starting point for crc computation } + + if (s = NIL) or (s^.mode <> 'r') then begin + gzread := Z_STREAM_ERROR; + exit; + end; + + if (s^.z_err = Z_DATA_ERROR) or (s^.z_err = Z_ERRNO) then begin + gzread := -1; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then begin + gzread := 0; { EOF } + exit; + end; + + s^.stream.next_out := pBytef(buf); + s^.stream.avail_out := len; + + while (s^.stream.avail_out <> 0) do begin + + if (s^.transparent = true) then begin + { Copy first the lookahead bytes: } + n := s^.stream.avail_in; + if (n > s^.stream.avail_out) then n := s^.stream.avail_out; + if (n > 0) then begin + zmemcpy(s^.stream.next_out, s^.stream.next_in, n); + inc (s^.stream.next_out, n); + inc (s^.stream.next_in, n); + dec (s^.stream.avail_out, n); + dec (s^.stream.avail_in, n); + end; + if (s^.stream.avail_out > 0) then begin + blockread (s^.gzfile, s^.stream.next_out^, s^.stream.avail_out, bytes); + dec (s^.stream.avail_out, uInt(bytes)); + end; + dec (len, s^.stream.avail_out); + inc (s^.stream.total_in, uLong(len)); + inc (s^.stream.total_out, uLong(len)); + gzread := int(len); + exit; + end; { IF transparent } + + if (s^.stream.avail_in = 0) and (s^.z_eof = false) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, Int(s^.stream.avail_in)); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then begin + s^.z_err := Z_ERRNO; + break; + end; + end; + s^.stream.next_in := s^.inbuf; + end; + + s^.z_err := inflate(s^.stream, Z_NO_FLUSH); + + if (s^.z_err = Z_STREAM_END) then begin + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + { Check CRC and original size } + s^.crc := crc32(s^.crc, start, crclen); + start := s^.stream.next_out; + + filecrc := getLong (s); + filelen := getLong (s); + + if (s^.crc <> filecrc) or (s^.stream.total_out <> filelen) + then s^.z_err := Z_DATA_ERROR + else begin + { Check for concatenated .gz files: } + check_header(s); + if (s^.z_err = Z_OK) then begin + total_in := s^.stream.total_in; + total_out := s^.stream.total_out; + + inflateReset (s^.stream); + s^.stream.total_in := total_in; + s^.stream.total_out := total_out; + s^.crc := crc32 (0, Z_NULL, 0); + end; + end; {IF-THEN-ELSE} + end; + + if (s^.z_err <> Z_OK) or (s^.z_eof = true) then break; + + end; {WHILE} + + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + s^.crc := crc32 (s^.crc, start, crclen); + + gzread := int(len - s^.stream.avail_out); + +end; + + +{ GZGETC ==================================================================== + + Reads one byte from the compressed file. + gzgetc returns this byte or -1 in case of end of file or error. + +============================================================================} + +function gzgetc (f:gzfile) : int; + +var c:byte; + +begin + + if (gzread (f,@c,1) = 1) then gzgetc := c else gzgetc := -1; + +end; + + +{ GZGETS ==================================================================== + + Reads bytes from the compressed file until len-1 characters are read, + or a newline character is read and transferred to buf, or an end-of-file + condition is encountered. The string is then Null-terminated. + + gzgets returns buf, or Z_NULL in case of error. + The current implementation is not optimized at all. + +============================================================================} + +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +var + + b : PChar; { start of buffer } + bytes : Int; { number of bytes read by gzread } + gzchar : char; { char read by gzread } + +begin + + if (buf = Z_NULL) or (len <= 0) then begin + gzgets := Z_NULL; + exit; + end; + + b := buf; + repeat + dec (len); + bytes := gzread (f, buf, 1); + gzchar := buf^; + inc (buf); + until (len = 0) or (bytes <> 1) or (gzchar = Chr(13)); + + buf^ := Chr(0); + if (b = buf) and (len > 0) then gzgets := Z_NULL else gzgets := b; + +end; + + +{$IFNDEF NO_DEFLATE} + +{ GZWRITE =================================================================== + + Writes the given number of uncompressed bytes into the compressed file. + gzwrite returns the number of uncompressed bytes actually written + (0 in case of error). + +============================================================================} + +function gzwrite (f:gzfile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + written : integer; + +begin + + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + gzwrite := Z_STREAM_ERROR; + exit; + end; + + s^.stream.next_in := pBytef(buf); + s^.stream.avail_in := len; + + while (s^.stream.avail_in <> 0) do begin + + if (s^.stream.avail_out = 0) then begin + s^.stream.next_out := s^.outbuf; + blockwrite (s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); + if (written <> Z_BUFSIZE) then begin + s^.z_err := Z_ERRNO; + break; + end; + s^.stream.avail_out := Z_BUFSIZE; + end; + + s^.z_err := deflate(s^.stream, Z_NO_FLUSH); + if (s^.z_err <> Z_OK) then break; + + end; {WHILE} + + s^.crc := crc32(s^.crc, buf, len); + gzwrite := int(len - s^.stream.avail_in); + +end; + + +{ =========================================================================== + Converts, formats, and writes the args to the compressed file under + control of the format string, as in fprintf. gzprintf returns the number of + uncompressed bytes actually written (0 in case of error). +} + +{$IFDEF GZ_FORMAT_STRING} +function gzprintf (zfile : gzFile; + const format : string; + a : array of int) : int; +var + buf : array[0..Z_PRINTF_BUFSIZE-1] of char; + len : int; +begin +{$ifdef HAS_snprintf} + snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$else} + sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$endif} + len := strlen(buf); { old sprintf doesn't return the nb of bytes written } + if (len <= 0) return 0; + + gzprintf := gzwrite(file, buf, len); +end; +{$ENDIF} + + +{ GZPUTC ==================================================================== + + Writes c, converted to an unsigned char, into the compressed file. + gzputc returns the value that was written, or -1 in case of error. + +============================================================================} + +function gzputc (f:gzfile; c:char) : int; +begin + if (gzwrite (f,@c,1) = 1) then + {$IFDEF FPC} + gzputc := int(ord(c)) + {$ELSE} + gzputc := int(c) + {$ENDIF} + else + gzputc := -1; +end; + + +{ GZPUTS ==================================================================== + + Writes the given null-terminated string to the compressed file, excluding + the terminating null character. + gzputs returns the number of characters written, or -1 in case of error. + +============================================================================} + +function gzputs (f:gzfile; s:PChar) : int; +begin + gzputs := gzwrite (f, voidp(s), strlen(s)); +end; + + +{ DO_FLUSH ================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + +============================================================================} + +function do_flush (f:gzfile; flush:int) : int; +var + len : uInt; + done : boolean; + s : gz_streamp; + written : integer; +begin + done := false; + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + do_flush := Z_STREAM_ERROR; + exit; + end; + + s^.stream.avail_in := 0; { should be zero already anyway } + + while true do begin + + len := Z_BUFSIZE - s^.stream.avail_out; + + if (len <> 0) then begin + {$I-} + blockwrite(s^.gzfile, s^.outbuf^, len, written); + {$I+} + if (written <> len) then begin + s^.z_err := Z_ERRNO; + do_flush := Z_ERRNO; + exit; + end; + s^.stream.next_out := s^.outbuf; + s^.stream.avail_out := Z_BUFSIZE; + end; + + if (done = true) then break; + s^.z_err := deflate(s^.stream, flush); + + { Ignore the second of two consecutive flushes: } + if (len = 0) and (s^.z_err = Z_BUF_ERROR) then s^.z_err := Z_OK; + + { deflate has finished flushing only when it hasn't used up + all the available space in the output buffer: } + + done := (s^.stream.avail_out <> 0) or (s^.z_err = Z_STREAM_END); + if (s^.z_err <> Z_OK) and (s^.z_err <> Z_STREAM_END) then break; + + end; {WHILE} + + if (s^.z_err = Z_STREAM_END) then do_flush:=Z_OK else do_flush:=s^.z_err; +end; + +{ GZFLUSH =================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + + The return value is the zlib error number (see function gzerror below). + gzflush returns Z_OK if the flush parameter is Z_FINISH and all output + could be flushed. + + gzflush should be called only when strictly necessary because it can + degrade compression. + +============================================================================} + +function gzflush (f:gzfile; flush:int) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + err := do_flush (f, flush); + + if (err <> 0) then begin + gzflush := err; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then gzflush := Z_OK else gzflush := s^.z_err; +end; + +{$ENDIF} (* NO DEFLATE *) + + +{ GZREWIND ================================================================== + + Rewinds input file. + +============================================================================} + +function gzrewind (f:gzFile) : int; +var + s:gz_streamp; +begin + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'r') then begin + gzrewind := -1; + exit; + end; + + s^.z_err := Z_OK; + s^.z_eof := false; + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + + if (s^.startpos = 0) then begin { not a compressed file } + {$I-} + seek (s^.gzfile, 0); + {$I+} + gzrewind := 0; + exit; + end; + + inflateReset(s^.stream); + {$I-} + seek (s^.gzfile, s^.startpos); + {$I+} + gzrewind := int(IOResult); + exit; +end; + + +{ GZSEEK ==================================================================== + + Sets the starting position for the next gzread or gzwrite on the given + compressed file. The offset represents a number of bytes from the beginning + of the uncompressed stream. + + gzseek returns the resulting offset, or -1 in case of error. + SEEK_END is not implemented, returns error. + In this version of the library, gzseek can be extremely slow. + +============================================================================} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +var + s : gz_streamp; + size : uInt; +begin + s := gz_streamp(f); + + if (s = NIL) or (whence = SEEK_END) or (s^.z_err = Z_ERRNO) + or (s^.z_err = Z_DATA_ERROR) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzseek := z_off_t(-1); + exit; +{$ELSE} + if (whence = SEEK_SET) then dec(offset, s^.stream.total_out); + if (offset < 0) then begin; + gzseek := z_off_t(-1); + exit; + end; + + { At this point, offset is the number of zero bytes to write. } + if (s^.inbuf = Z_NULL) then begin + GetMem (s^.inbuf, Z_BUFSIZE); + zmemzero(s^.inbuf, Z_BUFSIZE); + end; + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := uInt(offset); + + size := gzwrite(f, s^.inbuf, size); + if (size = 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + dec (offset,size); + end; + + gzseek := z_off_t(s^.stream.total_in); + exit; +{$ENDIF} + end; + { Rest of function is for reading only } + + { compute absolute position } + if (whence = SEEK_CUR) then inc (offset, s^.stream.total_out); + if (offset < 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.transparent = true) then begin + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + {$I-} + seek (s^.gzfile, offset); + {$I+} + if (IOResult <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + s^.stream.total_in := uLong(offset); + s^.stream.total_out := uLong(offset); + gzseek := z_off_t(offset); + exit; + end; + + { For a negative seek, rewind and use positive seek } + if (uLong(offset) >= s^.stream.total_out) + then dec (offset, s^.stream.total_out) + else if (gzrewind(f) <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + { offset is now the number of bytes to skip. } + + if (offset <> 0) and (s^.outbuf = Z_NULL) + then GetMem (s^.outbuf, Z_BUFSIZE); + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := int(offset); + + size := gzread (f, s^.outbuf, size); + if (size <= 0) then begin + gzseek := z_off_t(-1); + exit; + end; + dec(offset, size); + end; + + gzseek := z_off_t(s^.stream.total_out); +end; + + +{ GZTELL ==================================================================== + + Returns the starting position for the next gzread or gzwrite on the + given compressed file. This position represents a number of bytes in the + uncompressed data stream. + +============================================================================} + +function gztell (f:gzfile) : z_off_t; +begin + gztell := gzseek (f, 0, SEEK_CUR); +end; + + +{ GZEOF ===================================================================== + + Returns TRUE when EOF has previously been detected reading the given + input stream, otherwise FALSE. + +============================================================================} + +function gzeof (f:gzfile) : boolean; +var + s:gz_streamp; +begin + s := gz_streamp(f); + + if (s=NIL) or (s^.mode<>'r') then + gzeof := false + else + gzeof := s^.z_eof; +end; + + +{ PUTLONG =================================================================== + + Outputs a Longint in LSB order to the given file + +============================================================================} + +procedure putLong (var f:file; x:uLong); +var + n : int; + c : byte; +begin + for n:=0 to 3 do begin + c := x and $FF; + blockwrite (f, c, 1); + x := x shr 8; + end; +end; + + +{ GZCLOSE =================================================================== + + Flushes all pending output if necessary, closes the compressed file + and deallocates all the (de)compression state. + + The return value is the zlib error number (see function gzerror below). + +============================================================================} + +function gzclose (f:gzFile) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + gzclose := Z_STREAM_ERROR; + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzclose := Z_STREAM_ERROR; + exit; +{$ELSE} + err := do_flush (f, Z_FINISH); + if (err <> Z_OK) then begin + gzclose := destroy (gz_streamp(f)); + exit; + end; + + putLong (s^.gzfile, s^.crc); + putLong (s^.gzfile, s^.stream.total_in); +{$ENDIF} + end; + + gzclose := destroy (gz_streamp(f)); +end; + + +{ GZERROR =================================================================== + + Returns the error message for the last error which occured on the + given compressed file. errnum is set to zlib error number. If an + error occured in the file system and not in the compression library, + errnum is set to Z_ERRNO and the application may consult errno + to get the exact error code. + +============================================================================} + +function gzerror (f:gzfile; var errnum:int) : string; +var + m : string; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + errnum := Z_STREAM_ERROR; + gzerror := zError(Z_STREAM_ERROR); + end; + + errnum := s^.z_err; + if (errnum = Z_OK) then begin + gzerror := zError(Z_OK); + exit; + end; + + m := s^.stream.msg; + if (errnum = Z_ERRNO) then m := ''; + if (m = '') then m := zError(s^.z_err); + + s^.msg := s^.path+': '+m; + gzerror := s^.msg; +end; + +procedure UnGZip (var lInFname: string; var lBuf: ByteP; lOffset,lMaxSz: integer); //unzip +const +BUFLEN = 16384; +var + infile : gzFile; + lFname : ansistring; + lbufsz,len,lI : integer; + written : integer; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } +begin + lFName := lInFName; + //filemode := 1; + //if lFName = 'z' then + //showmessage('unzip'); + //ImgForm.Caption := 'gz'; + //ReadIntForm.GetInt('Multi-volume file, please select volume to view.',1,1,3); + //infile := gzopenZ (lFName, 'r', 0); + infile := gzopen (lFName, 'r'); + written := 0; + if lOffset > 0 then begin + Len := lOffset div BUFLEN; + if Len > 0 then + for lI := 1 to Len do + gzread (infile, @buf, BUFLEN {1388}); + Len := lOffset mod BUFLEN; + gzread (infile, @buf, Len); + end; + lbufsz := BUFLEN; + if lMaxSz < BUFLEN then + lbufsz := lMaxSz; + while true do begin + len := gzread (infile, @buf, lbufsz); + if (len < 0) then begin + break + end; + if (len = 0) + then break; + if (Written+len) > lMaxSz then begin + break; + end; + Move(buf,lbuf^[Written+1],len); + Written := Written + len; + end; {WHILE} + gzclose (infile); + //filemode := 2; +end; + + +procedure UnGZipCore (var infile : gzFile; var lBuf: ByteP; lReadBytes: integer; lWrite: boolean); +const + BUFLEN = 16384; +var + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } + len,lI,written : integer; +begin + written := 0; + if lReadBytes < 1 then exit; + Len := lReadBytes div BUFLEN; + if Len > 0 then + for lI := 1 to Len do begin + gzread (infile, @buf, BUFLEN {1388}); + if lWrite then + Move(buf,lbuf[Written+1],BUFLEN); + Written := Written + BUFLEN; + end; + Len := lReadBytes mod BUFLEN; + if Len = 0 then exit; + gzread (infile, @buf, Len); + if lWrite then + Move(buf,lbuf[Written+1],len); +end; //ungzipCore + +function gz_compress (var infile:file; outfile:gzFile): integer; +var + len : cardinal; + ioerr : integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + fsize, lensize : DWord; +begin + errorcode := 0; + //Progress := 0; + fsize := FileSize(infile); + lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + {$I-}blockread (infile, buf, Z_BUFSIZE, len);{$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + errorcode := 1; + break + end; + if (len = 0) then break; + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + end; + closeFile (infile); + if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3; + gz_compress := errorcode; +end; // proc gz_compress + +procedure GZipFile(lSrcName,lDestName: String); +var + FGzipFilename : string; + FGzipComments : string; + outmode : string; + s,FFileDestination : string; + infile : file; + outfile : gzFile; + FCompressionLevel{,errorcode} : integer; + flags : Integer; + stream : gz_streamp; + //p : PChar; + ioerr : integer; +begin +//FGzipHeader := [zFilename]; +FGzipFilename:= lSrcName; +FGzipComments := ''; + FCompressionLevel := 6; +//MainForm.ProgressBar1.position :=1; +//Gzip (lFile,lMulti); + FFileDestination := lDestName; + //result := 2; //return error if user aborts +(* if fileexists(FFileDestination) then begin + case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + mrAbort: exit; + end; + end;*) + AssignFile (infile, lSrcName); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + // Showmessage('Can''t open: '+lSrcName); + //errorcode := 1 + end + else begin + outmode := 'w '; + //s := IntToStr(FCompressionLevel); + outmode[2] := '6';//s[1]; + outmode[3] := ' '; + (*case FCompressionType of + Standard : outmode[3] := ' '; + HuffmanOnly : outmode[3] := 'h'; + Filtered : outmode[3] := 'f'; + end;*) + + //flags := 0; + //if (zfilename in FGzipHeader) then + flags := ORIG_NAME; + //if (comment in FGzipHeader) then flags := flags + COMMENT_; + outfile := gzopen (lSrcName, outmode); + if (outfile = NIL) then begin + //Showmessage('Can''t open: '+lSrcName); + close( infile); + exit; + end + else begin + { if flags are set then write them } + stream := gz_streamp(outfile); + if {(zfilename in FGzipHeader)} true then begin + s := lSrcName;//999 ExtractFilename(lSrcName); + //p := PChar(s); + blockWrite( stream^.gzfile, {p[0]}s, length(s)+1); + stream^.startpos := stream^.startpos + length(s) + 1 + end; + gz_compress(infile, outfile); + end + end; +end; + +procedure file_compress2 (filename,outname:string); +var + infile : file; + outfile : gzFile; + ioerr : integer; + mode : string; +begin + mode := 'w6 '; + Assign (infile, filename); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + writeln ('open error: ',ioerr); + halt(1); + end; + outfile := gzopen (outname, mode); + if (outfile = NIL) then begin + //999 showmessage(' can''t gzopen '+outname); + halt(1); + end; + + gz_compress(infile, outfile); + erase (infile); +end; + + +procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +var + lTempName: string; + lFdata: file; +begin + (*if lOverwritewarn and fileexists(FFileDestination) then begin + case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + mrAbort: exit; + end; + end; //if overwrite *) + lTempName := changefileext(FFileDestination,'.tmp'); + assignfile(lFdata,lTempName ); + filemode := 2; + rewrite(lFdata,1); + BlockWrite(lFdata,lxInBuffer^,lInSize); + closefile(lFdata); + file_compress2 (lTempName,FFileDestination ); + + //GZipFile(lTempName,FFileDestination); + //deletefile(lTempname); +end;//GZipBuffer + +end. diff --git a/histoform.lfm b/histoform.lfm new file mode 100755 index 0000000..4a8aa11 --- /dev/null +++ b/histoform.lfm @@ -0,0 +1,61 @@ +object HistogramForm: THistogramForm + Left = 889 + Height = 336 + Top = 234 + Width = 465 + Caption = 'Histogram' + ClientHeight = 336 + ClientWidth = 465 + Font.Height = -11 + Menu = MainMenu1 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '1.5' + object HistoPanel: TScrollBox + Left = 0 + Height = 336 + Top = 0 + Width = 465 + HorzScrollBar.Page = 90 + VertScrollBar.Page = 90 + Align = alClient + ClientHeight = 321 + ClientWidth = 450 + TabOrder = 0 + object HistoImage: TImage + Cursor = crCross + Left = 0 + Height = 321 + Top = 0 + Width = 450 + Align = alClient + AutoSize = True + Center = True + end + end + object MainMenu1: TMainMenu + left = 113 + top = 51 + object File1: TMenuItem + Caption = 'File' + object Saveasbitmap1: TMenuItem + Caption = 'Save as bitmap...' + ShortCut = 16467 + OnClick = Saveasbitmap1Click + end + object Closewindow1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Closewindow1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + ShortCut = 16451 + OnClick = Copy1Click + end + end + end +end diff --git a/histoform.lrs b/histoform.lrs new file mode 100644 index 0000000..1c25121 --- /dev/null +++ b/histoform.lrs @@ -0,0 +1,20 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('THistogramForm','FORMDATA',[ + 'TPF0'#14'THistogramForm'#13'HistogramForm'#4'Left'#3'y'#3#6'Height'#3'P'#1#3 + +'Top'#3#234#0#5'Width'#3#209#1#7'Caption'#6#9'Histogram'#12'ClientHeight'#3 + +'P'#1#11'ClientWidth'#3#209#1#11'Font.Height'#2#245#4'Menu'#7#9'MainMenu1'#8 + +'OnCreate'#7#10'FormCreate'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6 + +#3'1.5'#0#10'TScrollBox'#10'HistoPanel'#4'Left'#2#0#6'Height'#3'P'#1#3'Top'#2 + +#0#5'Width'#3#209#1#18'HorzScrollBar.Page'#2'Z'#18'VertScrollBar.Page'#2'Z'#5 + +'Align'#7#8'alClient'#12'ClientHeight'#3'A'#1#11'ClientWidth'#3#194#1#8'TabO' + +'rder'#2#0#0#6'TImage'#10'HistoImage'#6'Cursor'#7#7'crCross'#4'Left'#2#0#6'H' + +'eight'#3'A'#1#3'Top'#2#0#5'Width'#3#194#1#5'Align'#7#8'alClient'#8'AutoSize' + +#9#6'Center'#9#0#0#0#9'TMainMenu'#9'MainMenu1'#4'left'#2'q'#3'top'#2'3'#0#9 + +'TMenuItem'#5'File1'#7'Caption'#6#4'File'#0#9'TMenuItem'#13'Saveasbitmap1'#7 + +'Caption'#6#17'Save as bitmap...'#8'ShortCut'#3'S@'#7'OnClick'#7#18'Saveasbi' + +'tmap1Click'#0#0#9'TMenuItem'#12'Closewindow1'#7'Caption'#6#12'Close window' + +#8'ShortCut'#3'W@'#7'OnClick'#7#17'Closewindow1Click'#0#0#0#9'TMenuItem'#5'E' + +'dit1'#7'Caption'#6#4'Edit'#0#9'TMenuItem'#5'Copy1'#7'Caption'#6#4'Copy'#8'S' + +'hortCut'#3'C@'#7'OnClick'#7#10'Copy1Click'#0#0#0#0#0 +]); diff --git a/histoform.pas b/histoform.pas new file mode 100755 index 0000000..5e9c4c7 --- /dev/null +++ b/histoform.pas @@ -0,0 +1,99 @@ +unit histoform; + +interface + +uses +{$IFNDEF Unix} Windows,{$ENDIF} + + {$IFDEF FPC} LResources,{$ENDIF} + Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Menus, ExtCtrls,ClipBrd; + +type + + { THistogramForm } + + THistogramForm = class(TForm) + HistoPanel: TScrollBox; + HistoImage: TImage; + MainMenu1: TMainMenu; + File1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Saveasbitmap1: TMenuItem; + Closewindow1: TMenuItem; + procedure Copy1Click(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure Saveasbitmap1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + HistogramForm: THistogramForm; + +implementation +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} +uses nifti_img; + +procedure THistogramForm.Copy1Click(Sender: TObject); +{$IFDEF FPC} +begin + if (HistoImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + HistoImage.Picture.Bitmap.SaveToClipboardFormat(2); +end; +{$ELSE} +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (HistoImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + HistoImage.Picture.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData) +end; +{$ENDIF} + + +procedure THistogramForm.Closewindow1Click(Sender: TObject); +begin + HistogramForm.Close; +end; + +procedure THistogramForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Saveasbitmap1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Closewindow1.ShortCut := ShortCut(Word('W'), [ssMeta]); + {$ENDIF} + {$ENDIF} +end; + +procedure THistogramForm.Saveasbitmap1Click(Sender: TObject); +begin +{$IFNDEF FPC} + SaveImgAsPNGBMP (HistoImage); +{$ELSE} + SaveImgAsPNGBMP (HistoImage); +{$ENDIF} +end; + + {$IFDEF FPC} +initialization + {$I histoform.lrs} +{$ENDIF} + +end. diff --git a/hrf.pas b/hrf.pas new file mode 100755 index 0000000..2a9ebc4 --- /dev/null +++ b/hrf.pas @@ -0,0 +1,166 @@ +unit hrf; + +interface +uses + define_types, utypes,metagraph; +const + kHRFdur = 24000; //ms for 'full' HRF - window size for HRF +function CreateHRF (lTRsec: double; var lKernelBins: integer; lDefaultsStatsFmriT: integer; var lHRFra, lTDra: doublep): boolean; + +function ConvolveTimeCourse(var lTimeCourse: PMatrix; var lKernel: doublep; var l4DTrace: T4DTrace; +lCond,lCondOut,lnVol,lKernelBins,lDefaultsStatsFmriT,lDefaultsStatsFmriT0: integer; + lTRSec: single; lSliceTime: boolean): boolean; + + +implementation +uses math {power}, ugamma {gamma},sysutils,dialogs; + +const + kHRFkernelSec = 32; + //kDefaultsStatsFmriT = 16; //each TR is supersampled at 16x resolution + + +//from SPM's hrf.m +function spm_Gpdf(x,h,l: double): double; +//emulates spm_Gpdf +begin + result := power(l,h)*power(x,(h-1))* exp(-l*x); + result := result / gamma(h); +end; + +function fHRF (u,dt: double): double; +//emulates spm_hrf.m +const + //TR = 1; + p1= 6; //delay of response + p2=16;//delay of undershoot (relative to onset) + p3=1; //dispersion of response + p4=1; //dispersion of undershoot + p5=6; //ratio of response to undershoot + p7=kHRFkernelSec;//length of kernel (seconds) +begin + if u <= 0 then + result := 0 + else + result := spm_Gpdf(u,p1/p3,dt/p3) - spm_Gpdf(u,p2/p4,dt/p4)/p5; +end; + +function CreateHRF (lTRsec: double; var lKernelBins: integer; lDefaultsStatsFmriT: integer; var lHRFra, lTDra: doublep): boolean; +//NOTE: if this returns TRUE, you MUST freemem lHRFra, lTDra +//returns lHRFra and lTDra with lBins of data - equal to 32sec convolution kernel for +//hemodynamic response (HRF) and the HRF's temporal derivative +var + lDT,lSum,l1sec: double; + lI: integer; +begin + result := false; + if lDefaultsStatsFmriT < 1 then exit; + lDT := (lTRsec / lDefaultsStatsFmriT); //DeltaTime - width of each sample in sec + lKernelBins := round ( kHRFkernelSec / lDT); + if lKernelBins < 1 then + exit; + getmem(lHRFra,lKernelBins*sizeof(double)); + //generate whole HRF kernel + for lI := 1 to lKernelBins do + lHRFra^[lI] := fHRF (lI-1,lDT); + //find sum + lSum := 0; + for lI := 1 to lKernelBins do + lSum := lSum + lHRFra^[lI]; + //normalize - so sum = 1 + for lI := 1 to lKernelBins do + lHRFra^[lI] := lHRFra^[lI]/lsum; + //next temporal derivative + getmem(ltdra,lKernelBins*sizeof(double)); + l1sec := 1/lDT; + for lI := 1 to lKernelBins do + ltdra^[lI] := fHRF((lI-1)-l1sec,lDT); //tdHRF (lI-1,lDT); + //find sum + lSum := 0; + for lI := 1 to lKernelBins do + lSum := lSum + ltdra^[lI]; + //normalize - so sum = 1 + for lI := 1 to lKernelBins do + ltdra^[lI] := ltdra^[lI]/lsum; + //temporal derivative is difference between normalized TD and normalized HRF + for lI := 1 to lKernelBins do + ltdra^[lI] := lHRFra^[lI]- ltdra^[lI]; + result := true; +end; + +function Convolve(var lTimeCoursePrecise,lKernel: doublep; lEventBin,lnVolPrecise,lKernelBins: integer): boolean; +var + lVol,lStart,lEnd: integer; +begin + result := false; + if (lEventBin > lnVolPrecise) then exit; //event too late to influence timecourse + if ((lEventBin+lKernelBins)< 1) then exit;//event too early to influence timecourse + lStart := lEventBin; + if lStart < 1 then + lStart := 1; + lEnd := (lEventBin+lKernelBins-1); + if lEnd > lnVolPrecise then + lEnd := lnVolPrecise; + //lOffset := lEventBin; + for lVol := lStart to lEnd do begin + lTimeCoursePrecise^[lVol] := lTimeCoursePrecise^[lVol] + lKernel^[lVol -lEventBin+1]; + end; + result := true; +end; + +function ConvolveTimeCourse(var lTimeCourse: PMatrix; var lKernel: doublep; var l4DTrace: T4DTrace; lCond,lCondOut, lnVol,lKernelBins,lDefaultsStatsFmriT,lDefaultsStatsFmriT0: integer; + lTRSec: single; lSliceTime: boolean): boolean; +var + lnVolPrecise,lEvent,lVol,lVolx,lEventBin,lEventEnd: integer; + lDT: double; + lTimeCoursePrecise: doublep;//supersampled by kDefaultsStatsFmriT + lAllEvents: boolean; +begin + result := false; + if (l4DTrace.Conditions[lCond].Events < 1) or (lnVol < 1) or (lTRSec <= 0) then exit; + lnVolPrecise := lnVol * lDefaultsStatsFmriT; + getmem(lTimeCoursePrecise,lnVolPrecise * sizeof(double)); + for lVol := 1 to lnVolPrecise do + lTimeCoursePrecise^[lVol] := 0; + lDT := (lTRsec / lDefaultsStatsFmriT); //DeltaTime - width of each sample in sec + //spm_fmri_design + //X is supersampled at 16 times (fMRI_T) the number of volumes - with (32 bin offset) + //k = SPM.nscan(s); + //X = X([0:(k - 1)]*fMRI_T + fMRI_T0 + 32,:); + for lEvent := 1 to l4DTrace.Conditions[lCond].Events do begin + + lEventBin := round((l4DTrace.Conditions[lCond].EventRA^[lEvent])/lDT); + //incorrect: same dur will have different number of bins due to rounding: + //lEventEnd := round((l4DTrace.Conditions[lCond].EventRA^[lEvent]+l4DTrace.Conditions[lCond].DurRA^[lEvent])/lDT); + //correct: all stimuli of same duration will have identical number of bins + lEventEnd := lEventBin+round(l4DTrace.Conditions[lCond].DurRA^[lEvent]/lDT); + //if lEvent = 1 then fx(lEventBin,lEventEnd,l4DTrace.Conditions[lCond].DurRA^[lEvent]); + repeat + if (lEventBin > 0) and (lEventBin <= lnVolPrecise) then + Convolve(lTimeCoursePrecise,lKernel,lEventBin,lnVolPrecise,lKernelBins); + inc(lEventBin); + until lEventBin > lEventEnd; + end; //for each event + //output - scaled by reciprocal of DT: e.g. if TR=2, DT=0.125, Scale = 8 + //if TR=2.2, DT=0.1375 Scale = 7.2727 + //this linear scaling does not change any effects - it simply clones SPM2 + lAllEvents := true; + for lEvent := 1 to l4DTrace.Conditions[lCond].Events do + if l4DTrace.Conditions[lCond].DurRA^[lEvent] > lDT then + lAllEvents := false; + if lAllEvents then + lDT := 1/lDT + else + lDT := 1; + lVolx := lDefaultsStatsFmriT0; + for lVol := 1 to lnVol do begin + if (lVolx > 0) and (lVolx < lnVolPrecise) then + lTimeCourse^[lCondOut]^[lVol] := lDT * lTimeCoursePrecise^[lVolx]; + inc(lVolx,lDefaultsStatsFmriT); + end; + + freemem(lTimeCoursePrecise); + result := true; +end;//func ConvolveTimeCourse + +end. diff --git a/html/bat.html b/html/bat.html new file mode 100755 index 0000000..5c41c7a --- /dev/null +++ b/html/bat.html @@ -0,0 +1,233 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"> +<html> +<head> + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"> + <meta name="GENERATOR" content="Microsoft FrontPage Express 2.0"> + <title>MRIcron Batch File Page + + + + + + + + + + + +
MRIcron Advanced Settings
+ +

Advanced Options

+ +

Command line options   Usage: mricron BackgroundImageFilename [options]

+ +

If you launch MRIcron from the command line you can (optionally) +include default parameters to specify desired settings. Nice examples +of these commands are the batch files that are created in the same +folder as the mricron.exe program (you need to include the 'Tutorials' +when you install mricron). For example, lets look at simple batch file:
+   start /MAX mricron .\templates\ch2bet.nii.gz -c -0 -l 20 -h 140
+The terms 'start /MAX mricron' are standard parts of a Windows batch +file. This launches MRIcron and ensures that the main window is +maximized to fill the entire screen. You could run this from a batch +script (a text file with the name '.bat') or from the command line +(e.g. choose Start/Run and type 'cmd' to start the Windows command +line). Note that this script will only work from the folder where +MRIcron is stored. Otherwise, the script will need to specify the +location of the software:
+   start /MAX c:\mricron\mricron c:\mricron\templates\ch2bet.nii.gz -c -0 -l 20 -h 140 x
+Note that after the program name the script specifies the background +image that is to be loaded, in this cas the image ch2bet.nii.gz. After +this, you can optinally specify additional settings. For example, the +"-c -0" sets the image to have a grayscale color scheme. While "-l 20 +-h 140" sets the image brightness to be set for the range 20..140 (e.g. +voxels with values less than 20 will appear black, voxels greater than +140 will be white, and intermediate values will be linearly scaled for +this range). Finally, the 'X' command adjusts the adjusts the +proportions of the sagittal, coronal and axial panels so that each of +these views will be shown at a similar scale.
+ This next example shows how you can load an overlay on top of another image:
+   start mricron .\templates\ch2.nii.gz -c -0 -l 20 -h 140 -o .\templates\ch2bet.nii.gz -c -1 10 -h 130
+Note how this script uses some parameters multiple times - the first +set of -c-l-h parameters refer to the background image (ch2), while the +second set refer to the overlay image (ch2bet). The parameters that can +be adjusted for each image are noted with an asterix in the table below +(-c, -l, -h, -z).

+ +

Here is a complete list of the parameters you can specify

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
ParameterNotes 
-b <%> Sets transparency of overlays on background. +Supported values are -1,0,20,40,50,60,80,100. A value of -1 signifies +additive color blending. 
-c <LUT name>Specify color lookup table. "-c bone" will load +bone.lut. You can also specify the index number of the LUT by using the +prefix "-". For example, "-c -1" will load the red color scheme, while +"-c -0" will load the grayscale color scheme.*
-dDefaults will be saved when the user quits. 
-fLoads image 'flat': the NIfTI orientation matrix is ignored. +This is the same effect as editing the .ini file and setting 'Reslice=0'
-hSets maximum value for image intensity scaling. For +example a Z-score statistical map loaded with "-l 1.96 -h 4" will show +values near 1.96 as maximal dark and values near 4 as maximal bright. +See also -l and -z*
-lSets minimum value for image intensity scaling. see -h*
-mWill show a multi-slice view using default multislice settings. 
-m <INI name>Will show a multi-slice view using the settings for +the file <INI name>. For example "-m c:\mymulti.ini". Multislice +settings files can be created by selecting File/SaveSettings in the +multislice window. 
-o <overlay name>Will load overlay <overlay name>. For example "-o c:\statmap.hdr". 
-rWill show a rendering using default rendering settings. 
-r <INI name>Will show a rendering using the settings for the file +<INI name>. For example "-r c:\myrender.ini". Rendering settings +files can be created by selecting File/SaveSettings in the render +window. 
-s <v>Settings smoothing. <v> should be a value 0..3. +If <v> is odd (1 or 3) then bilinear smoothing is applied to +images (otherwise, nearest neighbor is used). If <v> is 2 or 3 +then overlays will be scaled using trilinear interpolation (otherwise, +nearest neighbor is used). 
-t <%>Sets transparency of overlays with respect to other +overlays. Supported values are -1,0,20,40,50,60,80,100. A value of -1 +signifies additive color blending. 
-v <drawing name>Will load volume of interest <drawing name>. For example "-o c:\lesion.voi". 
-xMain window will be maximized to fill entire screen. The size of +each view (sagittal, coronal and axial) will be proportionally scaled. 
-zImage color scaling will be from zero. For example a Z-score +statistical map loaded with "-l 1.96 -h 4 -z" will hide values below +1.96, but will show values near 1.96 as a medium intensity and values +near 4 as maximal bright. See also -h*
+ +

Default Settings

+

You can adjust many of MRIcron's settings by choosing Help/Preferences. A window will appear that allows you to edit many of the values from your mricron.ini file. The window is shown below, and the mricron.ini settings are described in the table below.

+ +

overlay panel

+ + +

MRIcron remembers users preferences. Three standard .INI format text +files are automatically generated: mricron.ini, \render\default.ini, +and \multislice\default.ini. The file mricron.ini saves general +settings, while the other files store values specific to the rendering +and multislice views respectively. The user can save custom multislice +and rendering settings by opening up the render (or multislice view) +and creating their desired settings and then choosing +File\SaveSettings. Deleting the ini files will return the software to +its factory settings.

+ +

The mricron.ini file has a few values that can not be adjusted from +the program, but can be changed by editing the file with a text editor. +Here is a complete list of the parameters you can specify

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
ParameterNotes
file0...file5=Stores the five most recently viewed images. These will appear in the File/OpenRecent submenu.
reslice=If 1, image will be spatially oriented using the NIfTI transforms, similar to SPM5. If 0, images will be shown as saved to disk (like SPM2 and FSLview). Reslice=1 requires more memory, but hopefully avoids left-right confusions.
ShowDraw=If 1, the 'Draw' menu and drawing tools will be visible.
Smooth=If 1, resliced images will use the slow but relatively precise trilinear interpolation
XBar=If 1, cross-hairs will mark the currently selected voxel.
OverlaySmooth=If 1, overlays will be scaled to background image using smooth trilinear interpolation. If 0, overlays will use nearest neighbor (and the edges may appear jagged).
LRMirror=If 1, images with NIfTI orientation parameters will appear in radiological convention (with left on the right). If 0, images will be in neurological convention (with left on the left).
Yoke=If 1, images in multiple instances of MRIcron will show the same location - changing the selected voxel in one instance will cahange the view in other instances.
MaxDim=If an image is larger than this value in any dimension, the image will be rescaled so that this is the largest dimension. This minimizes memory consumption. For example, if this is set to 256 and you open an image with 512x512x300 voxels, it will be displayed as 256x256x150voxels.
Zoom=Default image scaling. Zero specifies that the image is strecthed to fit the window, 1 for best integer fit to window (e.g. if a 235% scaling is possible, the image will be scaled 200%), 2 for 100%, 3 for 200%, etc.
LUT=Selected color scheme. E.G. if 24, then the 24th color scheme is used.
XBarGap=Empty gap between crosshairs. If 7, then 7 pixels separate crosshairs.
XBarThick=Width of crosshairs.
XBarClr=Color of crosshairs. This is a 24-bit value, with top 8 bytes representing blue, middle 8 representing blue and least significant 8 representing red. So a value of 255 would be a bright, pure red.
VOIClr=Color of volume of interest drawing. Same values as XBarClr.
BGTransPct=Transparency of overlays on background (in percent). 0 for opaque overlays, 50 for a translucent overlay (50% each) and 100 for a completely transparent overlay. -1 specificies additive combination.
OverlayTransPct=Transparency of overlays relative to each other. Same values as BGTransPct
MaxThreads=Maximum number of CPU cores used for rendering. If set to 5, only five cores will be used regardless of the number of CPUs. Higher numbers lead to faster rendering, but can slow other applications. For systems with more than two cores, a good value is the number of cores minus one. For example, with a quad-CPU machine, set this to 3. If you have fewer CPUs than MaxThreads, MRIcron will use all of your available CPUs (e.g. threads will equal the number of CPUs), offering optimal speed.
SigDigits=Number of digits shown after decimal place. Influences the voxel intensity value shown in the bottom-left status label.
TabletPressure=Only used when using a Tablet device (e.g. Wacom tablet or a Tablet PC which pressure sensitive stylus). Threshold for transitioning between a thin (1 voxel) and thick (3 voxel) pen - if pen pressure is double this threshold, a five pixel line will be drawn.. Tablet stylus pressure will range from 0..100. If set to 100, the pen will always draw a thin line, regardless of pressure. If set to 30, light pressure (<30%) will create a thin line, medium pressure (30..60%) will lead to a 3-voxel line and heavy pressure (>60%) will causes a very thick line (5 pixels wide).
TabletErasePressure=Pressure threshold for stylus eraser on Tablet systems. Same comments as TabletPressure.
LesionSmooth=Smoothing Full Width Half Maximum (in mm) This is used by the Draw Menu's "Create SPM5 mask" function.
+
+ + + + + + + +
logo
+ + diff --git a/html/dcm2nii.html b/html/dcm2nii.html new file mode 100755 index 0000000..307006a --- /dev/null +++ b/html/dcm2nii.html @@ -0,0 +1,1109 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + dcm2nii DICOM to NIfTI image conversion + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
dcm2nii DICOM to NIfTI conversion
+ + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
 Introduction + + + + + +

Important note: dcm2nii +is still beta software - please carefully monitor the output from this +software. In particular, be aware of potential left-right flipping. +This has only been tested with Philips Intera DICOM, Siemens Trio DICOM +and Philips Intera PAR/REC images. This software is provided under the BSD license.

+ + + + + + + + + + +

DCM2NII attempts to convert images from the proprietary +scanner format to the NIfTI format used by FSL, SPM5, MRIcron and many +other brain imaging tools. NIfTI is a modern incarnation of the Analyze +format, but includes important information like the orientation of the +image. DCM2NII is a stand-alone program that is distributed with +MRIcron. It is natively compiled for Windows, Linux x86, Mac OSX PPC +and Mac OSX x86.

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
The NIfTI image format +standard was designed for scientific analysis of brain images. The +format is simple, compact and versatile. The images can be stored as a +pair of files (hdr/img, compliant with most Analyze format viewers), or +a single file (nii). Programs like FSL and MRIcron can also read +compressed (nii.gz) images. One nice feature about NIfTI is that the +format attempts to keep spatial orientation information. Therefore, +NIfTI software that can read the spatial information (MRIcron and SPM5) +should reduce your chance of making left-right errors. Also, software +like SPM5 will tend to be more accurate at coregistering images, as all +the images from an individual can use the scanner position as a +beginning estimate for alignment. For example, here are two scans from +the same individual (the sagittal T1 is shown in grayscale, and the +coronal FLAIR is shown in reds). Note that the scans were acquired with +different orientations (with the FLAIR along the axis of the +hippocampus), however MRIcron shows the image orientation correctly.NIfTI image transform
+ + + + +
+ + + + + + + + + + + +
    + + + + + + + + + + +
+ + + + + + + + + + + +

Installation

+ + + + + + + + + + + +
    + + + + + +
  1. Follow the instructions to install MRIcron on your hard disk - this should create a program named dcm2nii.exe (Windows) or dcm2nii (Unix).
    2. + + + + + +
  2. Double click on dcm2nii.exe - a file named +dcm2nii.ini will be created. If you are using Windows, this file is in +the same folder as dcm2nii. If you are using Unix (Linux, OSX) then +this file is created in your home directory.
    3. + + + + + +
  3. Open dcm2nii.ini with a text editor (double click on the file). You will be able to adjust the settings:
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    TextDescription
    [BOOL]
    AnonymizeSourceDICOM=0If '=1' then dcm2nii will +create anonymized copies of DICOM images (remove name, DOB, patient ID, +sex). No other conversion will occur.
    ManualNIfTIConv=1If '=1' then dcm2nii will +prompt user to describe output subformat for every NIfTI image dragged +onto the program. Otherwise, subformat will be based on $D, +SingleNIIFile,SPM2 settings.
    4D=1If '=1' then dcm2nii will generate 4D files (FSL style), otherwise output will be 3D (SPM style).
    Anonymize=1 If '=1' then patient name will not be copied to NIfTI header.
    SingleNIIFile=1If '=1' then dcm2nii will create .nii files (FSL style), otherwise .hdr/.img pairs will be created (SPM style)
    Gzip=0If '=1' then dcm2nii will create compressed .nii.gz files (FSL style).
    SPM2=0If '=1' then dcm2nii will create Analyze images (SPM2 style), otherwise headers will be in NIfTI (SPM5/FSL).
    AppendDate=1If '=1' then output filename will include date of study.
    AppendAcqSeries=1If '=1' then output filename will include acquisition number.
    AppendProtocolName=1 If '=1' then output filename will include protocol name.
    AppendPatientName=0 If '=1' then output filename will include patient name.
    AppendFilename=0If '=1' then output filename will include source filename.
    EveryFile=1If '=1' then all .par/.rec files in the source folder will be converted, otherwise only the file specified will be converted
    [INT]
    BeginClip=0 Specifies number of volumes to be removed from the beginning of a 4D acquisition (e.g. avoid T1 effects)
    LastClip=0Specifies number of volumes +to be removed from the end of a 4D acquisition (e.g. fMRI scanning +continued after behavioral paradigm ended).
    MinReorientMatrix=255Images with a larger matrix size than this value will be reoriented to canonical space (see below).
    + +
    + + + + + + +

    + + +
    + + + + + +
    4. + + + + + + + + + + +
      + + + + +
    + + + + + +
  4. With each option listed under the heading [BOOL], add +a '1' for yes and a '0' for no. For +example, if you want to have images saved as .hdr/.img pairs, set +SingleNIIFile to 0. If you want to save images a single .nii files, set +this to 1. The append options adjust the output filenames. For example, +if you had both AppendDate and AppendProtocolName set to 1, the +converted images would have names such as 20060331_123456anat1x1x1.nii +if the data session was acquired on 31 March 2006 at 12:34:56 and the +protocol was called 'anat1x1x1'. The last two values (listed under the +heading [INT]) except integer values - for example if you set +'LastClip=8' then the last 8 volumes of every 4-dimensional dataset +will not be saved (e.g. if you had an fMRI dataset with 120 volumes, +only the first 111 volumes would be converted). A fuller description of +these options is in the gray box below.
    + + + + + +
    5. + + + + + + + + + + +
+ + + + + + + + + + +

Running DCM2NII

+ + + + +

There are two ways to run dcm2nii

+ + + + +
    + + +
  1. You can either drag and drop files onto the program - this will convert the images using the +values in your dcm2nii.ini file (see above).
    2. + + +
  2. You can +launch dcm2nii from the command line, specifying specifically the +options to use.
    3. + + + +
+ + + + +

To use dcm2nii by dragging and dropping:

+ + + + + + + + + + + +
    + + + + + +
  1. Place all the DICOM (or Philips PAR/REC) images you wish to convert into a folder where you have write access.
    2. + + + + + +
  2. Drag and drop one of the images onto dcm2nii. 
    3. + + + + + +
  3. You can now vew the images with MRIcron, SPM5, FSL, or other Analyze/NIfTI viewers.
    4. + + + + + + + + + + +
+ + +To see your options for running dcm2nii from the command line, simply +execute the program without specifying any files (e.g. just double +click on the program to launch it). The available options will the be +written to the screen:
+ + + + + + +
dcm2nii 12 May 2007 by Chris Rorden
+ +Either drag and drop or specify command line options:
+ + dcm2nii
+ +OPTIONS:
+ + -a Anonymize [remove identifying information]: Y,N
+ +   default: Y
+ + -b Clip beginning volumes from 4D file: 0..1000
+ +   default: 0
+ + -d Date in filename [filename.dcm -> 20061230122032.nii]: Y,N
+ +   default: N
+ + -e events (series/acq) in filename [filename.dcm -> s002a003.nii]: Y,N
+ +   default: Y
+ + -f Source filename [e.g. filename.par -> filename.nii]: Y,N
+ +   default: N
+ + -g gzip output, filename.nii.gz [ignored if '-n n']: Y,N
+ +   default: Y
+ + -i ID in filename [filename.dcm -> johndoe.nii]: Y,N
+ +   default: N
+ + -l Clip last volumes from 4D file: 0..1000
+ +   default: 0
+ + -n output .nii file [if no, create .hdr/.img pair]: Y,N
+ +   default: Y
+ + -o Output Directory, e.g. 'C:\TEMP'
+ +   default: source directory
+ + -p Protocol in filename [filename.dcm -> TFE_T1.nii]: Y,N
+ +   default: Y
+ + -s SPM2/Analyze not SPM5/NIfTI [ignored if '-n y']: Y,N
+ +   default: N
+ + -v Convert every PAR file in the directory: Y,N
+ +   default: Y
+ +HINTS
+ +   the combination '-d n -p n -i n -e n' will be ignored.
+ +  You can also set defaults by editing C:\lazarus\mricron\dcm2nii\dcm2nii.ini
+ +EXAMPLE: dcm2nii -a y -o C:\TEMP C:\DICOM\input1.par C:\input2.par
+
+
+ +

Reorienting to canonical space

+ +The NIfTI format stores spatial transforms so that software can determine the oreintation of the image. This means that MRIcron can display the image with an intuitive orientation. However, many programs ignore these transforms, and display the images as they are saved to disk (e.g. FSLview, MRIcro) - this means that a sagittally acquired scan appears very differently from an axially acquired scan. In fact, the three spatial dimensions (left-right, anterior-posterior, superior-inferior) can be saved in 48 different orthogonal orientations. The drawing below shows just three of these possible orientations. + Orthogonal orientations
+ You can set dcm2nii to reorient all images so they are all aligned to the nearest orthogonal direction to 'canonical space' (i.e. as close as possible to the rotation matrix [1 0 0; 0 1 0; 0 0 1]). This means programs like FSLview and MRIcro will display the images in a sensible orientation, regardless of the acquisition. The NIfTI transform codes the residual oblique orientations, so no information is lost in this tranformation. However, you will only want to orient anatomical scans to canonical space - reorienting fMRI data can disrupt slice timing correction (as the software assumes that the slice order of the stored data is correlated with the time of acquisition). Reorienting can also disrupt analysis of the DTI data (as the diffusion directions are not adjusted for the change in image orientation). Therefore, the "MinReorientMatrix" allows you to adjust which images will be reoriented - a value of 255 ensures that T1/T2 scans (typically with a 256x256 matrix) are reoriented, while fMRI (~64x64) and DTI (~128x128) scans are not. If you do not want any scans reoriented, reset this to a very large value (e.g. 5000). +
+
+ After reorienting, dcm2nii will attempt to 'autocrop' T1-weighted anatomical images (images with a Echo Time [TE] of less than 20ms). A new copy of the image is created with the prefix 'c' that attempts to remove excess air surrounding the individual as well as parts of the neck below the cerebellum. This excess neck can disrupt normalization of images (as the template images do not have similar neck regions). This new image has a slightly different NIfTI transform - the origin is adjusted to compensate for the removed portions of the image. The image below shows a T1-weighted scan before and after cropping. +
+ Orthogonal orientations
+As a final note, reorienting images is useful if you want to create masks for an image to use with SPM or FSL. These programs require that the mask image has precisely the same dimensions as the image it is designed to mask. In these cases, you can not apply the precise spatial transforms to an image (as the oblique orientation corrections means that the resulting drawing will have different dimensions than the original image. Therefore, you will want to draw a mask on on a image that has not used the fine spatial transforms. You can use MRIcro or FSLview to do this (as they ignore these transforms). If yu use MRIcron, select Help/Preferences and uncheck the 'Reorient (reslice) images when loading' option - this will ensure that the raw image is loaded. Regardless of which software you use, having a canonically aligned image will mean that the image will be displayed in a sensible manner. +
+

Diffusion data

+Diffusion sequences are sensitive to the random spontaneous motion of water molecules. This movement is anisotropic in fiber bundles - in other words it preferentially moves up and down the fibers whereas motion across the fiber is constrained. Diffusion tensor imaging (DTI) use different gradient directions so that different images are sensitive to specific directions. In order to process this data with medINRIA or FSL, you need to extract the diffusion direction information as well as the images. For these images, dcm2niigui will attempt to generate .bvec and .bval text files. This information is extracted from the DICOM header (for Siemens data the software attempts to read the "B_value" and "DiffusionGradientDirection" fields from the CSA header). + +

NIfTI Sub-Formats

+ +SPM5 and FSL both support NIfTI format images. However, by default +these programs assume your data is in slightly different formats. Most +SPM5 users generate a single 3D volume for each timepoint, and each +image is saved as both a .hdr and .img file (separating the header +information from the raw image data). On the other hand, by default FSL +uses a single 4D dataset, with all the data stored in a single .nii +file (this single file contains both the header and raw image data). To +save disk space, FSL saved these files as compressed gzipped files +(.nii.gz). Therefore, you may want to convert your DICOM data to a +different NIfTI sub-format depending on how you want to process and +analyze your data. You should adjust dcm2nii's settings depending on +which software you will use for post-processing. Here are some general +guidelines:
+ + + + +
    + + +
  1. FSL/MRIcron: compressed NIfTI (.nii.gz) - SingleNIIFile=1; Gzip=1; SPM2=0
    2. + + +
  2. Recent software (SPM5/Voxbo/FSL/MRIcron): NIfTI (.nii) - SingleNIIFile=1; Gzip=0; SPM2=0
    3. + + +
  3. Legacy software (SPM2/Analyze/MRIcro): analyze (.hdr/.img) - SingleNIIFile=0; Gzip=0; SPM2=1
    4. + + + + + +
+ + + + + +

Converting between NIfTI Sub-Formats

+ + + +FSL includes the avwsplit and avwmerge +tools for converting between 3D and 4D NIfTI images. This is useful, as +FSL likes 4D images while SPM likes 3D images. The latest versions of +dcm2nii (since May 2007) can also help you convert between NIfTI +subformats. Specifically, if you drag and drop a NIfTI image (.nii, +.nii.gz, or .hdr/.img subformats) onto dcm2nii it will ask how you want +the data converted. You can convert these files to SPM2 (analyze 3D +hdr/img), SPM5 (3D hdr/img), 3D nii, 4D nii, and FSL (NIfTI 4D nii.gz). +If ManualNIfTIConv=1 then the user will be prompted for every file to +specify the output format, while if this value is ManualNIfTIConv=0 +then the files will be converted automatically using the sub-formant +specified in the dcm2nii.ini file. Note that this software will both +change subformat and/or convert 4D files to 3D files. However, it does +not convert 3D files to 4D files (use avwmerge for this).
+ +

Anonymizing DICOM images

+ +This software can also 'anonymize' DICOM data - protecting the participants private information. There are a number of free as well as professional programs that can help anonymize DICOM data. My favorite is the free +uniPACS viewer can strip all the private tags from a DICOM file (choose File/BatchFileExport and select 'Anonymize' from the file menu). However, it is worth mentioning that some DICOM images store important data in the 'private' tags - for example, Siemens data includes information about the number of slices in a mosaic as well as DICOM diffusion directions. Therefore, use these 'strong' anonymizers with caution. In contrast, dcm2nii provides a 'weak' anonymization: it only anonymizes the patients name (0010:0010), ID (0010:0020), date of birth (0010:0030), +sex (0010:0040), age (0010:1010) and weight (0010:1030). The name is replaced with the number of seconds that elapsed between the study time and January 1, 2000 (ensuring that data from different individuals will not be confused). In theory, the participant can still be identified by study time (if you know when people received scans), and some manufacturers may store personal information in other parts of the DICOM file. To use dcm2nii's DICOM anonymizer, simply edit the dcm2nii file to read "AnonymizeSourceDICOM=1". Then just drag and drop DICOM files on the program - an anonymized file will be created (with the same name as the original image, but with the extension '.dcm' appended at the end). Note that in this mode the software will not convert the DICOM files to the NIfTI format. You may want to keep two copies of dcm2nii with different filenames (and hence different .ini files) - for example you could call one 'dcmanon' and another 'dcm2nii' so that one copy generates anonymized files and the other converts files.
+ + +

dcm2niiGUI

+I find dcm2nii very easy to use - just drop the images that you wish to convert onto the program's icon. However, some people prefer programs with a graphical user interface. The Windows distribution of MRIcron includes my dcm2niigui program - which is simply a version of dcm2nii with a graphical interface. Just launch the program, then drag and drop the images you wish to convert. The 'Output format' pulldown menu determines whether the images will be saved in SPM or FSL style NIfTI format. You can also choose help/preferences to more advanced options. In addition, you can use the File/AnonymizeDICOM command to strip personal details from DICOM images. Finally, you can use the File/ModifyNIfTI command to change existing NIfTI images - this command guides you through selecting the images and then choosing how you want to modify the images (remove volumes, changing subformat, reorienting, or changing the order of the 3rd and fourth dimension).
+ + dcm2niigui
+ +

Performance

+ +Converting DICOM images is fast compared to the other processing stages common to neuroimaging. However, several people have asked me how to improve dcm2nii's performance. I have tried to design this software to be quick - it attempts to minimize the amount of time writing to disk (by using a large amount of RAM). The table below shows the time required to process a standard neuroimaging dataset (1060 DICOM images [325Mb] with 792 fMRI volumes [36 slices, saved as mosaics], one T1 weighted anatomical scan and a field map). This dataset is typical for a one hour scanning session. The table below shows the time (in seconds) for dcm2nii (and SPM5) to convert these images. The 'GZ' cells reflect times for creating FSL style compressed .nii.gz images, while the other cells report times for creating SPM5 style .hdr/.img pairs. In brief, creating uncompressed images is generally constrained by disk speeds, while creating compressed images is limited by your processing power.
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
SetupeSataInternal HDUSB HDGZ eSataGZ Internal HDGZ USB HD
dcm2nii 2166Mhz CoreDuo Laptop12
+ 		2041707073
SPM5 2166Mhz CoreDuo Laptop94138165---
dcm2nii 667Mhz G4 Laptop-41--229-
+ + +

Sample Datasets

+ + + +Here are some sample images that help show whether images are converted with the correct image orientation:
+ + + + +
    + + +
  1. GE DICOM dataset. +Twelve 4D EPI series, each with five volumes: s26692 axial ascending +sequentia, s26693: axial ascending interleaved, s26694: axial +descending sequentia, s26695: axial descending interleaved, s26696: +sagittal right to left sequential, s26697: sagittal right to left +interleaved, s26698: sagittal left to right sequential, s26699 sagittal +left to right interleaved, s26700: coronal P to A sequential, s26701: +coronal P to A interleaved, s26702: coronal A to P sequential, s26703: +EPI, coronal A to P interleaved. A water filled fiduical marker is +placed over the right temple of the participant. Data were acquired on +a GE-SignaHD-Excite scanner at 3 Tesla using an 8 Channel Brain Array +Coil. The first volume of each series has been marked with a '1' on the +image. (LMU Grosshadern)
    2. + + +
  2. Philips DICOM dataset. +Six 4D EPI volumes, each with two volumes: sagittal, coronal and axial +each with both 'ascending' and 'descending' slice order. The white line +added at the bottom should be shorter on the earlier volumes. (MUSC +Center for Advanced Imaging Research)
    3. + + +
  3. Philips PAR/REC dataset. +Five 4D EPI volumes - same raw data as Philips DICOM dataset, but only +a single axial volume is included.(MUSC Center for Advanced Imaging +Research)
    4. + + +
  4. Siemens Trio B12 DICOM dataset. +Six 4D EPI volumes, each with two volumes: sagittal, coronal and axial +each with both 'ascending' and 'descending' slice order. A saline bag +is placed near the participant's left temple. (USC McCausland Center)
    5. + + +
  5. Siemens Trio B13 DICOM DTI dataset. +From May-2007, dcm2nii attempts to generate FSL and medINRIA compatible +descriptions of the B-values (bval) and Diffusion Gradient Directions +(bvec). For instructions on using FSL and medINRIA, see my DTI page. +These sample images were simply designed to validate dcm2nii's +conversion: these protocols are not appropriate for any other use (our standard protocol is described here). +This large (33Mb) file includes four 20 direction EPI datasets: the +first two are true axial (aligned to scanner bore, not the +participant's head) and are identical except that the phase direction +is Anterior-Posterior in the first and Right-Left in second. The third +volume is identical to the second except that the imaging plane has +been rotated: a pitch and yaw have been applied. The final scan is a +coronal scan,also taken in plane with the scanner's bore with pahse +encoding in the right-left direction. The file also includes a matlab +function (dtivecs.m) that illustrates dcm2nii's calculation for +correcting the diffusion directions for the imaging plane, using +suggestions from dicom2ana (see below) and Paul Morgan. (USC McCausland +Center)
    6. + + + + + +
+ + + + + +

Alternatives

+ + + +Each manufacturer has interpretted the DICOM data standard a bit +differently. Therefore, you may want to test several programs to see +which one is best suited for your data
+ + + + + + +
    + + + +
  1. LONI Debabeler is +a Java applet that can run on just about any computer. It can also read +a number of medical imaging formats. Another nice feature is that it +reorients the raw data to be approximately aligned with the nearest +orthogonal orientation (i.e. coronal and sagittal scans are resliced +along the axial plane).
    2. + + + +
  2. SPM5 includes a DICOM to NIfTI covnerter that works particularly well for Siemens data (requires Matlab).
    3. + + + +
  3. dicom2nifti is a matlab script for converting DICOM to NIfTI (requires Matlab and the Matlab Image Processing Toolbox). + [an alternative version is described here.] +
    4. + + + +
  4. xmedcon offers limited NIfTI writing support for many image formats. It uses the niftilib tools, which look very useful.
    5. + + + +
  5. MRIconvert is a popular converter for Windows and Linux.
    6. + + + +
  6. dinifti looks useful.
    7. + + + +
  7. Here is a script that uses dicom2 and FSL to convert DICOM images to NIfTI.
    8. + + + +
  8. XMedCon +includes the ability to convert between Acr/Nema 2.0, Analyze (SPM), +Concorde/µPET, DICOM 3.0, CTI ECAT 6/7, NIfTI-1, InterFile3.3 and +PNG or Gif87a/89a formats, as well as an elegant image viewer.
    9. + + + + + +
+ + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + +
logo
+ + + + + + diff --git a/html/images/48x36.gif b/html/images/48x36.gif new file mode 100755 index 0000000..6ad9867 Binary files /dev/null and b/html/images/48x36.gif differ diff --git a/html/images/autocrop.jpg b/html/images/autocrop.jpg new file mode 100755 index 0000000..8792297 Binary files /dev/null and b/html/images/autocrop.jpg differ diff --git a/html/images/dcm2niigui.gif b/html/images/dcm2niigui.gif new file mode 100755 index 0000000..42918a5 Binary files /dev/null and b/html/images/dcm2niigui.gif differ diff --git a/html/images/design.gif b/html/images/design.gif new file mode 100755 index 0000000..8e50ca8 Binary files /dev/null and b/html/images/design.gif differ diff --git a/html/images/draw/3dfill.png b/html/images/draw/3dfill.png new file mode 100755 index 0000000..9a26bbd Binary files /dev/null and b/html/images/draw/3dfill.png differ diff --git a/html/images/draw/circle.png b/html/images/draw/circle.png new file mode 100755 index 0000000..df7ffa2 Binary files /dev/null and b/html/images/draw/circle.png differ diff --git a/html/images/draw/closedpen.png b/html/images/draw/closedpen.png new file mode 100755 index 0000000..802330a Binary files /dev/null and b/html/images/draw/closedpen.png differ diff --git a/html/images/draw/fill.png b/html/images/draw/fill.png new file mode 100755 index 0000000..9d4e195 Binary files /dev/null and b/html/images/draw/fill.png differ diff --git a/html/images/draw/pen.png b/html/images/draw/pen.png new file mode 100755 index 0000000..6569ac6 Binary files /dev/null and b/html/images/draw/pen.png differ diff --git a/html/images/examplefmri.jpg b/html/images/examplefmri.jpg new file mode 100755 index 0000000..be26935 Binary files /dev/null and b/html/images/examplefmri.jpg differ diff --git a/html/images/examplefmri_multi.jpg b/html/images/examplefmri_multi.jpg new file mode 100755 index 0000000..8b9f250 Binary files /dev/null and b/html/images/examplefmri_multi.jpg differ diff --git a/html/images/icon.png b/html/images/icon.png new file mode 100755 index 0000000..2cbc48d Binary files /dev/null and b/html/images/icon.png differ diff --git a/html/images/layers.gif b/html/images/layers.gif new file mode 100755 index 0000000..1caa07d Binary files /dev/null and b/html/images/layers.gif differ diff --git a/html/images/lazarus.gif b/html/images/lazarus.gif new file mode 100755 index 0000000..e505720 Binary files /dev/null and b/html/images/lazarus.gif differ diff --git a/html/images/lesionsum.jpg b/html/images/lesionsum.jpg new file mode 100755 index 0000000..7d6e1ea Binary files /dev/null and b/html/images/lesionsum.jpg differ diff --git a/html/images/lieber.gif b/html/images/lieber.gif new file mode 100755 index 0000000..0e17416 Binary files /dev/null and b/html/images/lieber.gif differ diff --git a/html/images/main.jpg b/html/images/main.jpg new file mode 100755 index 0000000..8e4ed9e Binary files /dev/null and b/html/images/main.jpg differ diff --git a/html/images/meld.jpg b/html/images/meld.jpg new file mode 100755 index 0000000..ee5e42c Binary files /dev/null and b/html/images/meld.jpg differ diff --git a/html/images/nifti.jpg b/html/images/nifti.jpg new file mode 100755 index 0000000..4631f47 Binary files /dev/null and b/html/images/nifti.jpg differ diff --git a/html/images/npm.gif b/html/images/npm.gif new file mode 100755 index 0000000..8911641 Binary files /dev/null and b/html/images/npm.gif differ diff --git a/html/images/patient9.jpg b/html/images/patient9.jpg new file mode 100755 index 0000000..ba7fa0c Binary files /dev/null and b/html/images/patient9.jpg differ diff --git a/html/images/prefs.gif b/html/images/prefs.gif new file mode 100755 index 0000000..b9d5853 Binary files /dev/null and b/html/images/prefs.gif differ diff --git a/html/images/renderAAL.gif b/html/images/renderAAL.gif new file mode 100755 index 0000000..27bbe1e Binary files /dev/null and b/html/images/renderAAL.gif differ diff --git a/html/images/results.jpg b/html/images/results.jpg new file mode 100755 index 0000000..c606e28 Binary files /dev/null and b/html/images/results.jpg differ diff --git a/html/images/space.gif b/html/images/space.gif new file mode 100755 index 0000000..2877e12 Binary files /dev/null and b/html/images/space.gif differ diff --git a/html/images/splash.jpg b/html/images/splash.jpg new file mode 100755 index 0000000..a8d2b96 Binary files /dev/null and b/html/images/splash.jpg differ diff --git a/html/images/threshold.gif b/html/images/threshold.gif new file mode 100755 index 0000000..c588c4e Binary files /dev/null and b/html/images/threshold.gif differ diff --git a/html/images/transparency.gif b/html/images/transparency.gif new file mode 100755 index 0000000..4acd965 Binary files /dev/null and b/html/images/transparency.gif differ diff --git a/html/images/val.gif b/html/images/val.gif new file mode 100755 index 0000000..9b60e5e Binary files /dev/null and b/html/images/val.gif differ diff --git a/html/images/zhistogram.gif b/html/images/zhistogram.gif new file mode 100755 index 0000000..f34fa42 Binary files /dev/null and b/html/images/zhistogram.gif differ diff --git a/html/index.html b/html/index.html new file mode 100755 index 0000000..f5369b2 --- /dev/null +++ b/html/index.html @@ -0,0 +1,189 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + MRIcron Index Page + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
MRIcron Index
+ + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + splash screen
+ + + + + + + + + + + + + + + + + + + + + +
logo
+ + + + + diff --git a/html/install.html b/html/install.html new file mode 100755 index 0000000..cbaabdd --- /dev/null +++ b/html/install.html @@ -0,0 +1,472 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + MRIcron Installation Page + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
MRIcron Installation
+ + + + + + + + +

Introduction

+ +MRIcron can run on Windows, Macintosh OSX and Linux computers. Because Macintosh and Linux builds require a beta-release compiler, installation on these operating systems may be somewhat +tricky. This software is covered under a variation of the BSD license. In theory, +this software should work well on any of these platforms with recent hardware. +However, currently Windows offers the optimal platform for four reasons: +
    +
  • Graphics are more fluid in the Windows version: uses direct Windows API routines.
    • +
  • Rendering is faster with the Windows version if you are using a multi-CPU system: Windows version multi-threads rendering, so rendering is twice as fast on a dual-core system.
    • +
  • Windows version recognizes tablets, making it easier to draw volumes of interest (as it can detect stylus pressure, and can detect whether you are using the stylus tip or eraser).
    • +
  • Windows version is the most popular, so it has received the most testing from users.
    • +
+Hopefully, MRIcron should offer reasonable performance on any modern machine. There are a few ways to increase the performance of MRIcron, though these techniques necessarily reduce the quality of the images. +
    +
  • In the main MRIcron window, make sure that the option '2D smooth all' in the 'View' menu is unchecked. This displays images with the rapid nearest-neighbor interpolation instead of the much slower bilinear interpolation.
    • +
  • In the rendering window, make sure that the option 'Precise interpolation' in the 'View' menu is unchecked. This generates 3D renderings using nearest-neighbor interpolation instead of the slower trilinear interpolation. Renderings are typically three times faster.
    • +
  • In the rendering window, you may want to turn off the 'Smooth background' option in the 'View' menu. This displays the raw rendering, instead of applying a 2D blur to the image. Note that this change has much less influence on rendering times than the 'precise interpolation' option (as the precise interpolation is done in all 3 dimensions, while the smooth is only computed in 2 dimensions).
    • +
+ + + + + + + + + +
License
Chris Rorden's MRIcron, copyright 2007, all rights reserved.
+
+Redistribution and use in binary forms, with or without modification, +are permitted provided inclusion of the copyright notice, this +list of conditions and the following disclaimer is provided with the +distribution. Neither the name of the copyright owner nor the name of +this project (MRIcron) may be used to endorse or promote products +derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+

+ + + +

Windows

+ +
    + +
  1. Download the installer.
    2. + +
  2. Unzip and run the installer (double click on the .zip file and run the program InstallMR.exe).
    3. + +
  3. By default, the installer places the programs in C:\program +files\mricron, simply double click on mricron.exe to run the software.
    4. + +
  4. You may also double-click on the .bat files, which load example +images, for example 'examplefmri.bat' shows two statistical maps on top +of a high resolution anatomical scan.
    5. + + +
  5. Note: The file dcm2nii.exe is compressed using UPX, which can lead some virus software to generate false alarms (AntiVir PE Premium). This software is generated on a computer that always has the latest update's for Trend Micro's OfficeScan virus detection software.
    6. + +
+ +

Linux x86 32bit If +anyone finds an easier way to distribute this software for Linux, +please contact me. I am still finding it tricky to develop a universal +protocol for dealing with the dependencies of different distributions. +
 NoteThe Linux-native version of MRIcron was created using a beta release compiler. In many cases the best solution is to run the Windows-native version of MRIcron using Wine or a virtualized Windows environment (e.g. VMware player, QEMU or Xen).

+ +

    + +
  1. Download the software.
    2. + +
  2. Unzip the software (for modern Linux systems, right click on the file mricronlx.zip and choose to 'extract here').
    3. + +
  3. Open a terminal window.
    4. + +
  4. Change to the folder where you installed mricron, e.g. cd ~/mricron
    5. + +
  5. Launch mricron by typing ./mricron (note you must be in the same folder as the mricron executable.
    6. + +
  6. You can also run the example .bat files, for example ./xfmri.bat +shows two statistical maps on top of a high resolution anatomical scan.
    7. + + +
      + +
    1. In case you receive error messages, check if all the dependencies of the program are installed. In particular, you need
      2. + + +
        + +
      1. GTK 1.2 (this is called GTK+ by some distributions, and gtk by others)
        2. + +
      2. libgdk_lixbuf2.0
        3. + + +
      + +
    2. You can see a complete list of .so files needed by the software using the command:
      + +  ldd ./mricron
      3. + +
    3. In case you cannot run the program and it displays a message +saying it cannot find one of these libraries (you must run the program +from the command line to see error messages), you need to download and +install a package for the necessary library: + +
        + + +
          + +
        • On RPM-based distributions you can find packages here: http://rpm.pbone.net/
          • + +
        • On Debian-based distributions you can find packages here: http://www.debian.org/distrib/packages
          + +
          • + + +
        + + +
      + +
      4. + + +
    + +
+ +

Macintosh PowerPC +
 NoteThe Macintosh:PPC -native version of MRIcron was created using a beta release compiler. In many cases the best solution is to run the Windows-native version of MRIcron using VirtualPC.

+ +

    + +
  1. Download the software.
    2. + +
  2. Unzip the software (double click on the .zip file - a new folder called mricron will be created).
    3. + +
  3. You will need to install X11. 
    4. + + +
      + +
    1. Check to see if X11 is in the applications\utilities folder.
      2. + +
    2. If X11 is not installed:
      3. + + +
        + +
      1. OSX 10.4 user can install X11 by using the DVD installer disk
        2. + +
      2. Alternatively, download and run the X11 installer distributed by Apple.
        3. + + +
      + + +
    + +
  4. Download and install the correct version of fink +for your version of OS X and let it download and install the additional +29 GTK and related packages needed. Here's the required command for my +software (all on one line): 
    5. + + +
      + +
    • sudo fink install gdk-pixbuf gtk+ gtk+-data gtk+-shlibs gtk-doc-1.2-13 gtkglarea gtk-engines
      • + + +
    + +
  5. Launch X11 (double click on the X11 icon in the applications\utilitiesfolder). 
    6. + +
  6. Launch an X11 terminal  (from the keyboard, type Apple-N). From the terminal you can do the following
    7. + + +
      + +
    1. Change to the folder where you installed mricron, e.g. cd ~/Documents/mricron
      2. + +
    2. Launch mricron by typing ./mricron (note you must be in the same folder as the mricron executable.
      3. + +
    3. You can also run the example .bat files, for example +./xfmri.bat shows two statistical maps on top of a high resolution +anatomical scan.
      4. + + +
    + +
+ + + +

Macintosh Intel +
 NoteThe Macintosh:Intel -native version of MRIcron was created using a beta release compiler. In many cases the best solution is to run the Windows-native version of MRIcron using VMware Fusion or +Parallels Desktop for Mac. +.

+ +

    + +
  1. Download the software.
    2. + +
  2. Unzip the software (double click on the .zip file - a new folder called mricron will be created).
    3. + +
  3. You will need to install X11. 
    4. + + +
      + +
    1. Check to see if X11 is in the applications\utilities folder.
      2. + +
    2. If X11 is not installed:
      3. + + +
        + +
      1. OSX 10.4 user can install X11 by using the DVD installer disk
        2. + +
      2. Alternatively, download and run the X11 installer distributed by Apple.
        3. + + +
      + + +
    + +
  4. Download and install the correct version of fink +for your version of OS X and let it download and install the additional +29 GTK and related packages needed. Here's the required command for my +software (all on one line): 
    5. + + +
      + +
    • sudo fink install gdk-pixbuf gtk+ gtk+-data gtk+-shlibs gtk-doc-1.2-13 gtkglarea gtk-engines
      • + + +
    + +
  5. Launch X11 (double click on the X11 icon in the applications\utilitiesfolder). 
    6. + +
  6. Launch an X11 terminal  (from the keyboard, type Apple-N). From the terminal you can do the following
    7. + + +
      + +
    1. Change to the folder where you installed mricron, e.g. cd ~/Documents/mricron
      2. + +
    2. Launch mricron by typing ./mricron (note you must be in the same folder as the mricron executable.
      3. + +
    3. You can also run the example .bat files, for example +./xfmri.bat shows two statistical maps on top of a high resolution +anatomical scan.
      4. + + +
    + +
+ + +
+ +Linux x86 64bit While the x86-32bit version may run, in theory it should be possible to create a 64-bit native version by recompiling the source code. +
 NoteThe Linux-native version of MRIcron was created using a beta release compiler. In many cases the best solution is to run the Windows-native version of MRIcron using Wine or a virtualized Windows environment (e.g. VMware player, QEMU or Xen).

+ +

    + + + +
  1. Install the compiler. To compile this software, you will need a build of Lazarus created on +or after May 1, 2006. This software requires some recent patches that +are not available on the current stable release. To get the latest +developmental snapshot of Lazarus, click here.
    2. + + + +
  2. Get the source code. The source code is available here. The source +file includes sample images in the Templates and Example folders. To +test this software, compile mricron.lpr. Next use the File/templates +menu to open sample images. Alternatively, after compiling the +software, you can click on the included .bat files to see sample +renderings.
    3. + + +
  3. Linux users:You need to have write access to the folder where you +run MRIcron (it will want to create .ini files) I suggest placing this +software in your home directory.
    4. + + + + +
+ + + + + + + + + + + + + + + + +
logo +    + + Lazarus +
+ + + + + + diff --git a/html/main.html b/html/main.html new file mode 100755 index 0000000..301287b --- /dev/null +++ b/html/main.html @@ -0,0 +1,300 @@ + + + + + + + + + + + + + + + + + + MRIcron Introduction Page + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
MRIcron Introduction
+ + + +

Main Window

+ + + +

I have tried to make the MRIcron main window as useful but simple as +possible. While the options may appear confusing at first, I hope over +time the software feels intuitive. A sample window is shown below. You +can get a similar view by launching the software, choosing +File/OpenTemplates/ch2bet to load the background image (shown as a +grayscale brain) and then choosing Overlay/Add and opening the image +\Template\attention.

+ + + +

the controls on the tool bar offer quick access to the main tools +for brain imaging. The X/Y/Z numbers set the slice to view (X refers to +Left/Right, Y to anterior/posterior and Z to superior/inferior). +Adjusting these values will change the sagittal, coronal and axial +slice displayed. The next item is the zoom-factor. Here images are +scaled 'to fit' - e.g. each view of the brain is strecthed to fill its +panel optimally. Alternatively, you could choose x1 (100%), x2 (200%) +or x3 (300%) zoom factors. The next series of buttons refer to the +active layer (more on layers in the next section). In the example +below, the currently active layer is image 'attention', and this image +is being shown as a red gradient with a minimum value of 1.96 to 4. In +this example, attention is a statistical Z-score map that has been +placed on top of the background image of a brain. Statistical values +less than 1.96 are not shown, with the darkest value set to 4.

+ + + + + + + + + + + + + + + + + + + + + +
main mricron view
+ +This +image shows a sample rendering. You can view a similar image by +running the fmri.bat file that is included with MRIcron. 
+ +
+ + + + + + + +

Layers

+ + +

When you use the File menu's Open command (Open, Open recent and +Open Templates) you are selecting a background image. What makes +MRIcron powerful is its ability to load multiple layers of images. To +add additional images on top of your background, simply choose 'Add' +from the 'Overlay' menu. For example, launch MRIcron and choose +'File\Open templates\ch2bet', then choose 'Overlay/Add' and select the +'attention.nii.gz' image from the 'Example' folder that (typically, +this folder is installed in C:\program files\mricron\examples). Now you +should see a brain activation statistical map on top of the background +anatomical image. Note that overlay images are scaled to map on top of +the background image. You can adjust the appearance of each layer by +using the layer panel:

+ + +

overlay panel

+ + +

Note that you can click on the leftmost button in the overlay panel to +select between the open layers - for example the image above shows +settings for the 'Background' image, as well as the overlay image named +'saccades'. Note that the image intensity range for the background is +from 45 to 120, using a grayscale color scheme. This means that values +of 45 or lower will appear as complete black, and 120 and above will be +white, with intermediate intensities appearing as a corresponding gray +value. There is also an icon with a color scale and the number zero: +this allows you to have the color range set from zero, even if your +threshold is greater than zero: for example our statistical map +'saccades' is set to show values from 2.3 to 6: values less than 2.3 +will not be shown. However, since the 'color range from zero' button is +depressed, a T-score of 2.3 will appear as a dark red (as 2.3 is part +way between 0 and 6) instead of a black (if the color range was from +2.3 to 6).

+ +

MRIcron allows you to choose different color schemes for each layer. In the example above, the Background image is shown using the +'grayscale' black-and-white colorscheme, while the saccade overlay uses the Red color scheme. You can increase or decrease the +colorschemes available by adding or removing files from the 'LUT' folder (this 'look up table' folder is located in the same path as MRIcron). +This folder typically contains several *.lut files, with each file storing a different color scheme. For example, the blackbdy.lut' file describes a color scheme that goes from black to orange to yellow and finally white. MRIcron's *.lut files are interchangeable with the *.lut files used by ImageJ, XMedCon, MRIcro. You can copy *.lut files from these programs to MRIcron's LUT folder. Furthermore, you can create your own *.LUT files using ImageJ's LUT panel plugin, ImageJ's LUT Editor or my own LUTmaker.

+ + +

Note that the 'Overlay' menu also allows you to modify how layers +appear. For example, on image 'A' below, I have selected +Overlay/TransparencyOnBackground/0%[Opaque], while for image B, I have +set the transparency to 50%. Also note that you can load multiple +overlays simultaneously. For example, images C and D below show the +'attention'  and  'saccades' files both overlayed on top of +ch2bet - with attention shown in green and the saccades shown as red. +For image C, I have set the Overlay/TransparencyOnOtherOverlays/50%, +while for Figure D this has been set to 'Additive' (so regions with +both red and green appear yellow).

+ + +

Transparency

+ +

Render Window +

+ + + + + + + + + + + + + + + + + + + + + + + +
+ +

From MRIcron's main window you can select Window/Render to +view a volume rendering of your data. You can change the vieiwing angle +of the image by adjusting the Aizmuth and Elevation values. The +Background menu allows you to adjust therendering of the background +image, while the background menu allows you to determine how overlays +will appear. Of critical importance, the Overlay/SearchDepth will +adjust whether the rendering shows superficial overlays (e.g. a +settings of 4 will only look within the first 4 voxels of the +background image [e.g. within the first 4mm if your background image +hasa 1mm resoultion), while a setting of 'infinite' will show an +overlay regardless of its depth. Also criticial is the +Background/BehindOverlay menu item - if checked, the software will only +start looking for overlays that exist behind the surface of the +background. On the other hand, if this value, overlays will not be +constrained by the background image (e.g. you will be able to view an +overlay that is closer than the background). You can save your +preferred settings by selecting File/SaveSettings. This information +will be saved in the 'render' folder, and you will be able to select +them by choosing File/OpenSettings.

+ + +

+ +

+ +
+ + 		example fmri
+ + + + + This +image shows a sample rendering. You can view this image by +running the fmri.bat file that is included with MRIcron. 
+ +
+ +

+ + + Multislice Window +

+ +

From MRIcron's main window you can select Window/Multislice to +see the multislice window. You will then be shown a series of slices of +the currently open volumes. Within the Multislice form you can use the +View meanu to adjust settings - e.g. to select whether you want to see +sagittal, coronal or axial images, and to choose the desired slices and +overlap between neighboring slices. You can also choose +File/SaveSettings to save your favorite views (previous sets will be +listed under File/OpenSettings).

+ + + + + + + + + + + + + + + + + + + + + + + + + +
This image shows a sample multslice image. You can view this image by running the fmri.bat +file that is included with MRIcron. After MRIcron loads, choose +Window/Multislice. Note you can adjust the amount of overlap between +slices, as well as slice orientation. Forthermore, you can choose which +slices to display.
+ + 		multislice
+ +
+ +
+ + + + + + + +
logo
+
+ +

 

+ + + + diff --git a/html/peri/images/eventtime.png b/html/peri/images/eventtime.png new file mode 100755 index 0000000..79c5d52 Binary files /dev/null and b/html/peri/images/eventtime.png differ diff --git a/html/peri/images/icon.png b/html/peri/images/icon.png new file mode 100755 index 0000000..2cbc48d Binary files /dev/null and b/html/peri/images/icon.png differ diff --git a/html/peri/images/meld.jpg b/html/peri/images/meld.jpg new file mode 100755 index 0000000..ee5e42c Binary files /dev/null and b/html/peri/images/meld.jpg differ diff --git a/html/peri/images/periset.png b/html/peri/images/periset.png new file mode 100755 index 0000000..0d19fc9 Binary files /dev/null and b/html/peri/images/periset.png differ diff --git a/html/peri/images/peristimulusplot.png b/html/peri/images/peristimulusplot.png new file mode 100755 index 0000000..6878407 Binary files /dev/null and b/html/peri/images/peristimulusplot.png differ diff --git a/html/peri/images/perivol.png b/html/peri/images/perivol.png new file mode 100755 index 0000000..e340f46 Binary files /dev/null and b/html/peri/images/perivol.png differ diff --git a/html/peri/images/timeline.png b/html/peri/images/timeline.png new file mode 100755 index 0000000..a0da8f8 Binary files /dev/null and b/html/peri/images/timeline.png differ diff --git a/html/peri/index.html b/html/peri/index.html new file mode 100755 index 0000000..52aefac --- /dev/null +++ b/html/peri/index.html @@ -0,0 +1,181 @@ + + + + + + + + + + + + + + + + + + MRIcron Peristimulus Plots + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Peristimulus Plots
+ + + +

Introduction

+ +SPM and FSL are powerful tools for analyzing fMRI data. However, the +statistical maps most people generate with these tools can be difficult +to interpret. Generating peristimulus plots can allow you to get a +better idea of what your data actually looks like, and can help you +determine if a region shows an increased amplitude of activity or a more +sustained response to a stimuli. To generate peristimulus plots you +will need:
+
    +
  1. MRIcron developmental release.
    2. +
  2. A 4D fMRI dataset (typically motion corrected and smoothed)
    3. +
  3. A FSL format 3-column text file for each condition you wish to analyze.
    4. +
  4. Optional: regions of interest for specific brain regions.
    5. +
+You can also click here to download a sample data set (14mb).
+

Basic Usage

+Here are step-by-step instructions
+
    +
  1. launching MRIcron. Then choose '4D traces' from the View menu.
    2. +
  2. Press the 'Open Data' button.
    3. +
      +
    • You will be asked to load a sample dataset, choose filtered_func_data.nii.gz
      • +
    • Optional: You will be asked to load event onset files, choose both L_Tap.txt and R_Tap.txt
      • +
    • Optional: You will be +asked whether you want to load any regions of interest. These can be +hdr/img; nii; or voi files (note you have to pull down the file-type +menu to select voi files). Select L.voi and R.voi
      • +
    +
  3. MRIcron will now display a timeline for your data. If you have +loaded multiple regions, a separate line displays each ROI. If you have +not selected any ROIs, you will be shown the currently selected voxel - +use MRIcron's main window to select a voxel you want to view and then +press the red refresh button in the timeline window to see the +timeiline for this voxel. Note that if you have loaded any event +onsets, each condition is shown as a unique color of vertical stripes - +for example in the example left hand taps are shown as red bars and +right taps are shown as green bars. Note with the example datasets that +left taps are followed by increases in signal for the right ROI, while +right taps are followed by increasing signal in the left hemisphere.
    + Timeline
    4. +
  4. Before generating peristimulus plots, make sure that the TR is +accurately set. Our sample data has a TR of 3 seconds, and this is +correctly reported in the image file, so MRIcron correctly reports a TR +of 3 seconds. If your TR is incorrect, the events will not be correctly +aligned with your images.
    5. +
  5. Press the 'Plot' button to generate phase-locked peristimulus +plot. You will want to check the settings for your peristimulus plot
    6. +
      +
    1. The bin width sets the resolution for plot - smaller bins are +more precise but noiser. By default, the bin width is set to your TR, +in our example 3 seconds.
      2. +
    2. The pre-stimulus bins sets the number of baseline bins. In our example we are setting 4 bins (12 seconds).
      3. +
    3. The number of post-stimulus bins plot signal changes after an +event has been presented. Remember that fMRI signals are sluggish, and +take 5-6 seconds to peak. For the example, set this to 14 (42 seconds).
      4. +
    4. If you slice time corrected your data, check the appropriate +box. Event times will be adjusted for the acquisition of the +middle-slice in your volume (e.g. all of your onsets will be adjusted +by 0.5 TR).
      5. +
    5. The save peristimulus volume button allows you to save a +separate 3D dataset for each time bin. This is an advanced feature we +will discuss later.
      + Settings
      6. +
    +
  6. MRIcron generates a peristimulus plot. Different colors are used +for the different conditions, while different line styles are used for +the different regions of interest. For our example, note that the right +hemisphere shows a response for left but not right taps, while the +reverse is true for the left hemisphere. The peak amplitude is about 1% +signal change. While this effect sounds small, note that we are +averaging over a large number of voxels which in this case were +selected baseed solely on anatomy, rather than post-hoc selecting the +single most active voxel. Also note that the error bars are rather +small.
    7. +
+periplot
+
+

Advanced Usage

+
    +
  • For statisitcal analysis, you will want the precise values for +the effect sizes and standard errors. If you press the 'text' button +instead of the plot button, you will be shown the precise values - save +these as a .csv (comma separated values) format file to open them and +generate nice graphs with Excel or other software.
    • +
  • You can save peristimulus volumes to see precisely what is +happening for each voxel at a given time point. The image below shows +the 8th time bin for both the left and right movement conditions. Note the +bright contralateral signal.
    + PeriVolume
    • +
  • When generating peristimulus plots, you have an option of choosing whether your data has been slice time corrected or not. This will influence how the event times are interpretted. Without STC, my software assumes that the event times are relative to the first slice of the first volume. On the other hand, if STC is checked, all times are relative to the acquisition of the middle slice of the first volume. The image below illustrates this (assuming a 2 second TR): without STC, the first event occurs at 0.5sec, and the second event occurs at 6 seconds. With STC, the first event occurs at -0.5s, and the second event occurs at 5s. Sparse acquisition is useful for auditory studies (as stimuli can be presented while the scanner is silent, and we can then observe the sluggish consequences of this). However, most sparse studies will not yield good peristimulus plots (good plots will required jittered stimulus-scan intervals). In any case, for sparse imaging I suggest making sure STC is NOT selected, and having the origin for event times to be the acquisition of the irst slice. Note that my software does not adjust for differences in slice time acquisition within a volume. The whole 3D volume is assumed to have been collected at a single instant. Therefore, (for axial acquisitions) signals from the cerebellum will appear to have a different lag than signals from the top of the brain. If you want to make comparisons between different brain areas, you may want to slice time correct your data before generating peristimulus plots.
    + PeriVolume
    • +
+
+Notes
+
+My software gives you a direct view into how your data looks. Also note +that a single timepoint can be averaged into a number of bins (e.g. if +the events occur rapidly, one scan could show a timepoint which is +after a previous event but before one or more others). Furthermore, my +software does not attempt to remove data from other conditions. An +alternative approach is to fit each condition and then plot the data +having regressed out the variability explained by other conditions. A +nice implementation of this alternative approach is described here.
+ +
+ + + + + + + + + + + + + + + + + + + +
logo
+ + + + diff --git a/html/source.html b/html/source.html new file mode 100755 index 0000000..51678fc --- /dev/null +++ b/html/source.html @@ -0,0 +1,188 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + MRIcron Source Code Page + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
MRIcron source code
+ + + + + + + + +

Introduction

+ + + + + +

MRIcron is written in Pascal, and can be compiled using Borland's +Delphi or the open source Lazarus (Freepascal) software. MRIcron is open source, using the BSD license. Lazarus offers +several advantages - it is free, comes complete with all the components +required by MRIcron, and offers the potential to easily create native +binary code for Windows, Linux, and OSX. However, Lazarus is still beta +software. 

+ + +
    + + +
  1. Install the compiler. To compile this software, you will need a build of Lazarus created on +or after May 1, 2006. This software requires some recent patches that +are not available on the current stable release. To get the latest +developmental snapshot of Lazarus, click here. There are still a few features that do not work correctly on the Lazarus versions of MRIcron. These are described here.
    2. + + +
  2. Get the source code. The source code is available here. The source +file includes sample images in the Templates and Example folders. To +test this software, compile mricron.lpr. Next use the File/templates +menu to open sample images. Alternatively, after compiling the +software, you can click on the included .bat files to see sample +renderings.
    3. +
  3. The Lazarus version of this software still has a few bugs. For more details, click here.
    4. + + +
+ + + + + + + + + + + + + + + + + + + + + +
logo   Lazarus
+ + + + + + + diff --git a/html/stats.html b/html/stats.html new file mode 100755 index 0000000..019e44a --- /dev/null +++ b/html/stats.html @@ -0,0 +1,1259 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + MRIcron Statistics Page + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
MRIcron Statistical Analysis Tutorial
+ + + + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
 Introduction + + + + + +

Important note: By +default, MRIcron has the lesion drawing tools switched off. To turn on the lesion +drawing features of MRIcron, select Help/Preferences and make sure the "Show drawing menu and tools" checkbox is selected.

+ +

MRIcron is designed to relate lesion location to behavioral +performance. For example, it can help identify brain regions that are +crucial to language production. To conduct an analysis, we will need to +conduct four steps:

+
    +
  1. Lesion Mapping: For each individual, we need to map the extent of brain injury.
    2. +
  2. Specify design: We need to design our experiment, creating a +spreadsheet that links each individual's lesion map to their performance
    3. +
  3. Compute results: We need to conduct a voxelwise statistical analysis.
    4. +
  4. Viewing results: We need to interpret the results.
    5. +
+ + + +This tutorial guides you through a lesion data analysis.
+ +
    +
  1. A copy of MRIcron: the version will include a folder named 'example\lesions' with the sample dataset described here.
    2. +
  2. A copy of NPM for Windows
    3. +
+In this tutorial, I assume the lesion maps and design file are in the folder c:\dataset, but you can extract the files +anywhere. Note that by default these are usually installed to c:\program files\mricron\example\lesions. The sample dataset includes simulated lesion maps for 23 +patients. This folder also includes .val files that report the +performance +of these patients on a letter cancellation task.  In this task, +patients are asked to mark each occurence of the letter 'A' on a piece +of paper that was cluttered with letters. A perfect score on this task +is 60 (when all the A's are detected). The file continuous.val lists +each patient's +performance on this task (a score of 2..60), while the file +binomial.val lists performance on this task as binary: patients missing +more than 4 items are listed as having failed this task (0), while +patients who missed 4 or fewer items are listed as having passed this +task (1). We have included both binomial and continuous values to +illustrate the statistical analyses available with MRIcron.
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Right: A sample lesion map (9.voi) overlayed ontop +of the ch2 template showing injury to the left temporal lobe. To view +this map, launch MRIcron and choose File/Template/Ch2, then choose +Overlay/Add... and choose the image 9.voi included with the sample +dataset. patient 9 lesion
+
+ + + +

Lesion Mapping

+ + + + + + + + + + + +

MRIcron provides simple tools for drawing a region of brain +injury. However, it is crucial that all of our lesion maps are drawn +with the same image dimensions and orientation. Therefore, we should +either draw all the lesions on a standard template (e.g. +File/OpenTemplates/CH2), or we need to first normalize all the scans so +they are coregistered and then open each scan using File/Open.

+ + + + + + + + + + +
    + + + + + +
  1. Launch MRIcron and open your scan (File/Open or File/OpenTemplate)
    2. + + + + + +
  2. Select your drawing tool (these are listed at the bottom of the Draw menu, e.g. the 'Pen' tool).
    3. + + + + + +
  3. Draw your region - for example if you use the 'Autoclose Pen' +tool, simply click and draw the border of the brain injury. To fill in +an enclosed region, simply shift+click in the center of the region. To +erase part of your drawing, hold down the Shift key.
    4. + + + + + +
  4. Repeat step 3 for all slices where a lesion is present (e.g. you +can adjust the X,Y,Z numbers that appear on the top left to select the +desired slice. Note you can also use a mouse scroll-wheel to select +slices.
    5. + + + + + +
  5. When you are done drawing the region of brain injury, choose Draw/SaveVOI to save a copy of the lesion map.
    6. + + + + + +
  6. Repeat steps 1-5 for each individual, save the lesion maps from all the individuals in a single folder.
    7. + + + + + + + + + + +
+ + + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
pen toolclosed pen toolfill toolcircle tool3D fill tool
Pen ToolClosed Pen ToolFill ToolCircle Tool3D Fill Tool
Left clickDraw lineDraw closed lineFill regionDraw ellipse see web page
Shift+ left clickErase lineErase closed lineErase regionErase ellipse
Ctrl+ left clickDraw thick lineDraw thick closed line3D Bubble FillDraw rectangle
Ctrl+shift+ left clickErase thick lineErase thick closed lineErase 3D regionErase rectangle
right clickFill regionFill regionFill region-
Shift+ right clickErase regionErase regionErase region-
Alt+ left clickChange viewChange viewChange viewChange viewChange view
+ + + + + + + + + + + + + + + + +

Specify the Design

+ + + +Lets famialize ourselves with the dataset we will analyze. + + + +
    + + + +
  1. Launch NPM and open the design window +(VLSM/Design...). A speadsheet will appear. Select File/Open +and view the file continuous.val. Each row shows +the performance of each patient, for example the patient 1 +identified 2 items, while patient 2 detected 44 items. Note that with +this software higher scores reflect better +performance. If you have binomial data (where performance falls into +two discrete categoris), you should denote the presence of a deficit +with a 0 and healthy performance with a one. Note that the filename +listed in the left column and the performance in the right column +always correspond to the same patient.
    + + + + + Design
    +
    2. + + + + + + +
  2. We need to first describe the lesion maps and name the behavioral +performance measures. Select View/Design to bring up the description +window.
    + + + + + design 
    + + + + + + + + + + + + + +
      + + + + + + +
    1. Predictors: shows the number of behavioral measures - here we are only examining the letter cancelation performance..
      2. + + + + + + +
    2. Predictor names: for each predictor, insert an easy to remember name, e.g. 'cancel' for our letter finding task.
      3. + + + + + + + + + +
    3. You can select the file names of your lesion maps by +pressing the 'Select Images' button to select the lesion maps from +all your participants. You should select all the images simultaneously, +and all the images should be placed in a single folder (e.g. your +lesion maps might be C:\dataset\1.voi, C:\dataset\2.voi, etc). The lesion +images can be in MRIcron VOI, NIfTI .nii, compressed NIfTI .nii.gz or +Analyze (.hdr/.img) format. If you do select images, make sure the +filenames match the patient performance, as noted in step 1. 
      4. + + + + + + +
    4. You can also set an a priori minimum lesion density threshold. For +example, setting a value of 10% when you analyze 22 people means that +statistics will only be computed for voxels damaged in more than 2 +people. A large number for this threshold can increase your statistical +power, as you will only compute statistics for voxels that are commonly +injured. However, larger values will fail to detect rarely damaged +regions that are reliable predictors of deficit. Note that this value +is based on the total incidence of lesions in a voxel, regardless of +behavioral performance.
      5. + + + + + + +
    + + + +
    3. + + + + + + +
+ + + + + + + + + + + + + +

Compute results

+ + + + + + + + + + + + + +

Next, we we compute our statistical results. You can conduct +some statistics by choosing items in the Draw/Statistics menu of +MRIcron. However, here we describe using some of the new features in +NPM that are not yet available in MRIcron - specifically, NPM can +conduct permutation thresholding and the Brunner and Munzel test. To +conduct these statistics, +you need to download and install npm.exe - this only works on the +Windows operating system.

+ + + + + + + + + + + + +
    + + + + + + +
  1. First go to the 'Options' menu and set the permutations to None. +Permutation thresholding can be useful, but it will take at least 1000 +times longer than a normal False-Discovery Rate corrected threshold, +and is typically less sensitive. Therfore, for you first glance at your +data, turn this feature off.
    2. + + + +
  2. For analyzing the continuous data:
    3. + + + + + + +
      + + + +
    1. Go to 'Option' menu and click 'Tests' - make sure the 'Brunner Munzel' is checked and the t-test is unchecked. +Our data is not normally distributed, so we will use a non-parametric +test (using the permuted Brunner Munzel rank order statistic).
      2. + + + +
    2. Click the VLSM/BinaryImagesContinuousGroups command. Select the continuous.val file.
      3. + + + + + + +
    + + + + + + +
  3. For analyzing the binomial data:
    4. + + + + + + +
      + + + +
    1. Click the VLSM/BinaryImagesBinaryGroups command. Select +the binomial.val file. This will use the Liebermeister measure (a more +sensitive binomial test than Chi-Squared or Fisher's Exact test, see Seneta and Phipps, 2001; Phipps, 2003).
      + Comparison +
      2. + + + + + + +
    + + + +
  4. NPM will now compute the requested tests. It will create +overlap images of all your patients (e.g. sum.nii.gz) and a statistical +map (BM.nii.gz for continuous data, L.nii.gz for binomial data).
    + + + + + NPM
    5. + + + + + + +
+ + + + + + +

Viewing results

+ + + + + + + + + + + + + +

We can open up the statistical maps generated and place them +on top of an anatomical scan. If your lesion maps were aligned to +stereotaxic MNI space, you can open them on top of one of the standard +templates (File/OpenTemplates/ch2). Here is a quick guide:

+ + + + + + + + + + + + +
    + + + + + + +
  1. Launch MRIcron and choose File/OpenTemplates/ch2bet as our background image
    2. + + + + + + +
  2. Choose Overlay/Add and choose the statistical map created in the previous step (e.g. C:\dataset\binL.nii.gz).
    3. + + + + + + +
  3. When MRIcron detects a statistical map, it calculates the +p-values +for each test in order to determine the false discover rate (FDR) +threshold - e.g. how much robust signal is present in your data. +MRIcron displays a histogram of the Z-scores. Note in the example +below, most of the data has positive Z scores suggesting a robust +signal (if our data was merely noise, we should see a bell-shaped +distribution with a mean of 0, instead the mean Z score is around 2).
    + + + + + + + Histogram
    + + + + +
    4. + + + + + + +
  4. Next, MRIcron displays the overlay. Note at the bottom of the +screen the software reports the critical values: the p05/p01 values +correspond to uncorrected p<0.05 and p<0.01 values that are very +liberal (these tests will make many false alarms, e.g. here we have +conducted 16082 tests, so p05 should result in many false positives). +The fwe05 and fwe01 values correspond to the Bonferroni-corrected +values: this test is very conservative, and you will often fail to +detect real effects. The FDR05 and FDR01 results reflect the False +Discover Rate - e.g. a FDR05 should show around 20 real activations for +every false positive. Note that when there is very little or no signal, +FDR is as conservative as Bonferroni, but it is adaptive to the actual +signal in your dataset. Note that you can select the image thresholding +and cutoff for your overlay. Note that by default, +my software loads statistical maps with thresholds from FDR05 to FDR01, +unless there is insufficient signal, in which case it uses the +uncorrected 0.05...0.01 values. Also note that the current overlay is +set to appear in a monochromatic red color scheme.
    + + + + + + + lesion stats
    +The image below shows how changing a threshold can change the +appearance of a statistical overlay. Consider the raw statitical map +shown in the left panel, while the middle panel has been thresholded to +only show voxels with Z-scores greater than 2.5 (with three regions +surviving this threshold), the right panel shows a more conservative +threshold of Z>4.5 - with only a single peak surviving.
    + + + Thresholding
    5. + + + + + + + + + + +
  5. We can repeat steps 2..4 to load multiple overlays, to compare +different statistical tests. For example, clicking on the +'tutorialfmri.bat' icon will launch MRIcron and load to overlapping +regions of interest. By using the Overlay/TransparencyOnOtherOverlays +command we can view both of these overlays simultaneously.
    6. + + + + + + +
+ + + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
logo
+ + + + + + + + + diff --git a/html/tutorial/images/design.gif b/html/tutorial/images/design.gif new file mode 100755 index 0000000..62f8154 Binary files /dev/null and b/html/tutorial/images/design.gif differ diff --git a/html/tutorial/images/icon.png b/html/tutorial/images/icon.png new file mode 100755 index 0000000..2cbc48d Binary files /dev/null and b/html/tutorial/images/icon.png differ diff --git a/html/tutorial/images/lesionsum.jpg b/html/tutorial/images/lesionsum.jpg new file mode 100755 index 0000000..7d6e1ea Binary files /dev/null and b/html/tutorial/images/lesionsum.jpg differ diff --git a/html/tutorial/images/lieber.gif b/html/tutorial/images/lieber.gif new file mode 100755 index 0000000..0e17416 Binary files /dev/null and b/html/tutorial/images/lieber.gif differ diff --git a/html/tutorial/images/meld.jpg b/html/tutorial/images/meld.jpg new file mode 100755 index 0000000..ee5e42c Binary files /dev/null and b/html/tutorial/images/meld.jpg differ diff --git a/html/tutorial/images/npm.gif b/html/tutorial/images/npm.gif new file mode 100755 index 0000000..8911641 Binary files /dev/null and b/html/tutorial/images/npm.gif differ diff --git a/html/tutorial/images/patient9.jpg b/html/tutorial/images/patient9.jpg new file mode 100755 index 0000000..ba7fa0c Binary files /dev/null and b/html/tutorial/images/patient9.jpg differ diff --git a/html/tutorial/images/results.jpg b/html/tutorial/images/results.jpg new file mode 100755 index 0000000..c606e28 Binary files /dev/null and b/html/tutorial/images/results.jpg differ diff --git a/html/tutorial/images/threshold.gif b/html/tutorial/images/threshold.gif new file mode 100755 index 0000000..c588c4e Binary files /dev/null and b/html/tutorial/images/threshold.gif differ diff --git a/html/tutorial/images/val.gif b/html/tutorial/images/val.gif new file mode 100755 index 0000000..9b60e5e Binary files /dev/null and b/html/tutorial/images/val.gif differ diff --git a/html/tutorial/images/zhistogram.gif b/html/tutorial/images/zhistogram.gif new file mode 100755 index 0000000..f34fa42 Binary files /dev/null and b/html/tutorial/images/zhistogram.gif differ diff --git a/iconfinal.ico b/iconfinal.ico new file mode 100755 index 0000000..14b256a Binary files /dev/null and b/iconfinal.ico differ diff --git a/icons/dcm2niigui.png b/icons/dcm2niigui.png new file mode 100755 index 0000000..17636d6 Binary files /dev/null and b/icons/dcm2niigui.png differ diff --git a/icons/mricrogl.png b/icons/mricrogl.png new file mode 100755 index 0000000..f71a33d Binary files /dev/null and b/icons/mricrogl.png differ diff --git a/icons/mricron.png b/icons/mricron.png new file mode 100755 index 0000000..8f06ea9 Binary files /dev/null and b/icons/mricron.png differ diff --git a/icons/npm.png b/icons/npm.png new file mode 100755 index 0000000..a3743ca Binary files /dev/null and b/icons/npm.png differ diff --git a/imgutil.pas b/imgutil.pas new file mode 100755 index 0000000..50d2b45 --- /dev/null +++ b/imgutil.pas @@ -0,0 +1,85 @@ +unit imgutil; +{$H+} +interface + +function UnscaledMean (lOverlayNum: integer): double; +function ScaledMean (lOverlayNum: integer): double; +procedure BatchChangeInterceptSoVOIEqualsZero; + + +implementation +uses text,nifti_hdr,nifti_hdr_view,define_types,nifti_img, nifti_img_view, nifti_types; + + +function UnscaledMean (lOverlayNum: integer): double; +//kVOIOverlayNum +var + lROIVol,lInc: integer; + lROISum: double; +begin //proc ShowDescript + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lROIVol := 0; + lROISum := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lROISum := lROISum + RawBGIntensity(lInc); + inc(lROIVol); + end; + end; //for each voxel + if lROIVol > 0 then + result := lROISum/lROIVol; +end; + +function ScaledMean (lOverlayNum: integer): double; +begin + result := UnscaledMean(lOverlayNum); + result := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],result); +end; + +procedure BatchChangeInterceptSoVOIEqualsZero; +var + lInc,lNumberofFiles,lMinClusterSz: integer; + lZeroHdr : TNIfTIHdr; + lFilename,lVOIname:string; + lPref: boolean; + lMean: double; +begin + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + + if not OpenDialogExecute(kImgPlusVOIFilter,'Select volume of interest',false) then exit; + lVOIName := HdrForm.OpenHdrDlg.FileName; + if not OpenDialogExecute(kImgFilter,'Select perfusion images',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.MemoT.Lines.Clear; + lPref := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + ImgForm.OpenAndDisplayImg(lFilename,false); + ImgForm.OverlayOpenCore ( lVOIname, kVOIOverlayNum); + lMean := UnscaledMean(kVOIOverlayNum); + lZeroHdr := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr; + if lZeroHdr.scl_slope <> 1 then + TextForm.MemoT.Lines.Add(lFilename+' Scale slope is not 1, please contact Chris Rorden ') + else if lMean <> 0 then begin + TextForm.MemoT.Lines.Add(lFilename+kTextSep+realtostr(lMean,5)); + lZeroHdr.scl_inter := lZeroHdr.scl_inter - lMean; + lFilename := changefileprefix(lFilename,'z'); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,lZeroHdr) + end else + TextForm.MemoT.Lines.Add(lFilename+' UNCHANGED (mean of VOI is already zero) '); + + //FindClustersText(gMRIcroOverlay[kBGOverlayNum], lThresh,lMinClusterSz); + end;//lLoop + gBGImg.ResliceOnLoad := lPref; + TextForm.Show; +end; + + +end. \ No newline at end of file diff --git a/isthreaded.inc b/isthreaded.inc new file mode 100755 index 0000000..8f3d853 --- /dev/null +++ b/isthreaded.inc @@ -0,0 +1,22 @@ +//x86-64 GTK2 crashes with progress bars +//GTK2 crashes with threading + + +{$IFDEF LCLgtk2} + {$ifndef cpux86_64} + {$DEFINE SHOWPROG}//SHOWPROG =ShowProgressBar + {$ENDIF} +{$ELSE} + {$DEFINE SHOWPROG}//SHOWPROG =ShowProgressBar +{$ENDIF} +{$IFDEF UNIX} //Windows is always threaded + {$IFDEF LCLCocoa} //for Carbon or Cocoa + {$DEFINE NoThreads}//NoThreads - single threaded execution + {$ENDIF} + + {$IFDEF LCLgtk2} + {$DEFINE NoThreads}//NoThreads - single threaded execution + //GTK2 does not allow threading + {$ENDIF} +{$ENDIF} + diff --git a/landmarks.lfm b/landmarks.lfm new file mode 100755 index 0000000..66cc680 --- /dev/null +++ b/landmarks.lfm @@ -0,0 +1,79 @@ +object AnatForm: TAnatForm + Left = 595 + Height = 27 + Top = 394 + Width = 438 + BorderStyle = bsDialog + Caption = 'Landmarks' + ClientHeight = 27 + ClientWidth = 438 + Constraints.MaxHeight = 27 + Constraints.MaxWidth = 438 + Constraints.MinHeight = 27 + Constraints.MinWidth = 438 + Font.Height = -11 + FormStyle = fsStayOnTop + Position = poScreenCenter + LCLVersion = '1.4.2.0' + object ToolBar1: TToolBar + Left = 0 + Height = 29 + Top = 0 + Width = 438 + ButtonHeight = 21 + Caption = 'ToolBar1' + ParentFont = False + TabOrder = 0 + object OpenBtn: TSpeedButton + Left = 1 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Open' + OnClick = OpenBtnClick + end + object SaveBtn: TSpeedButton + Left = 57 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Save' + OnClick = SaveBtnClick + end + object ComboBox1: TComboBox + Left = 113 + Height = 20 + Top = 2 + Width = 145 + DropDownCount = 24 + ItemHeight = 0 + OnChange = ComboBox1Change + Style = csDropDownList + TabOrder = 0 + end + object AddBtn: TSpeedButton + Left = 258 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Add' + OnClick = AddBtnClick + end + object UpdateBtn: TSpeedButton + Left = 314 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Update' + OnClick = UpdateBtnClick + end + object DeleteBtn: TSpeedButton + Left = 370 + Height = 21 + Top = 2 + Width = 56 + Caption = 'Delete' + OnClick = DeleteBtnClick + end + end +end diff --git a/landmarks.lrs b/landmarks.lrs new file mode 100644 index 0000000..be3a565 --- /dev/null +++ b/landmarks.lrs @@ -0,0 +1,22 @@ +LazarusResources.Add('TAnatForm','FORMDATA',[ + 'TPF0'#9'TAnatForm'#8'AnatForm'#4'Left'#3'S'#2#6'Height'#2#27#3'Top'#3#138#1#5 + +'Width'#3#182#1#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#9'Landmarks'#12'C' + +'lientHeight'#2#27#11'ClientWidth'#3#182#1#21'Constraints.MaxHeight'#2#27#20 + +'Constraints.MaxWidth'#3#182#1#21'Constraints.MinHeight'#2#27#20'Constraints' + +'.MinWidth'#3#182#1#11'Font.Height'#2#245#9'FormStyle'#7#11'fsStayOnTop'#8'P' + +'osition'#7#14'poScreenCenter'#10'LCLVersion'#6#7'1.4.2.0'#0#8'TToolBar'#8'T' + +'oolBar1'#4'Left'#2#0#6'Height'#2#29#3'Top'#2#0#5'Width'#3#182#1#12'ButtonHe' + +'ight'#2#21#7'Caption'#6#8'ToolBar1'#10'ParentFont'#8#8'TabOrder'#2#0#0#12'T' + +'SpeedButton'#7'OpenBtn'#4'Left'#2#1#6'Height'#2#21#3'Top'#2#2#5'Width'#2'8' + +#7'Caption'#6#4'Open'#7'OnClick'#7#12'OpenBtnClick'#0#0#12'TSpeedButton'#7'S' + +'aveBtn'#4'Left'#2'9'#6'Height'#2#21#3'Top'#2#2#5'Width'#2'8'#7'Caption'#6#4 + +'Save'#7'OnClick'#7#12'SaveBtnClick'#0#0#9'TComboBox'#9'ComboBox1'#4'Left'#2 + +'q'#6'Height'#2#20#3'Top'#2#2#5'Width'#3#145#0#13'DropDownCount'#2#24#10'Ite' + +'mHeight'#2#0#8'OnChange'#7#15'ComboBox1Change'#5'Style'#7#14'csDropDownList' + +#8'TabOrder'#2#0#0#0#12'TSpeedButton'#6'AddBtn'#4'Left'#3#2#1#6'Height'#2#21 + +#3'Top'#2#2#5'Width'#2'8'#7'Caption'#6#3'Add'#7'OnClick'#7#11'AddBtnClick'#0 + +#0#12'TSpeedButton'#9'UpdateBtn'#4'Left'#3':'#1#6'Height'#2#21#3'Top'#2#2#5 + +'Width'#2'8'#7'Caption'#6#6'Update'#7'OnClick'#7#14'UpdateBtnClick'#0#0#12'T' + +'SpeedButton'#9'DeleteBtn'#4'Left'#3'r'#1#6'Height'#2#21#3'Top'#2#2#5'Width' + +#2'8'#7'Caption'#6#6'Delete'#7'OnClick'#7#14'DeleteBtnClick'#0#0#0#0 +]); diff --git a/landmarks.pas b/landmarks.pas new file mode 100755 index 0000000..136839e --- /dev/null +++ b/landmarks.pas @@ -0,0 +1,254 @@ +unit landmarks; + +interface +{$H+} + + +uses + {$IFDEF Win32} + Windows, Messages, +{$ELSE} + LMessages, LCLType, +{$ENDIF} + {$IFDEF FPC}LResources, {$ENDIF} + SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, Buttons, ToolWin, ComCtrls; + +type + TAnatForm = class(TForm) + ToolBar1: TToolBar; + SaveBtn: TSpeedButton; + AddBtn: TSpeedButton; + ComboBox1: TComboBox; + UpdateBtn: TSpeedButton; + OpenBtn: TSpeedButton; + DeleteBtn: TSpeedButton; + procedure SaveBtnClick(Sender: TObject); + procedure AddBtnClick(Sender: TObject); + procedure ComboBox1Change(Sender: TObject); + procedure UpdateCombo; + procedure OpenBtnClick(Sender: TObject); + procedure Update(lIndex: integer); + procedure UpdateBtnClick(Sender: TObject); + procedure DeleteBtnClick(Sender: TObject); + procedure OpenAnat(lFilename: string); + procedure CloseAnat; + private + { Private declarations } + public + { Public declarations } + end; + +var + AnatForm: TAnatForm; + +implementation + +uses nifti_img_view, nifti_img, nifti_hdr_view, define_types; + {$IFNDEF FPC} //Delphi +{$R *.dfm} +{$ENDIF} +type + TLandmark = record + Name: string; + X,Y,Z: single; + end; + TLandmarkRA = array of TLandmark; +const +kAnatFilter = 'AnatomyFile|*.anat'; +var + gLandmarks: TLandmarkRA; +procedure TAnatForm.CloseAnat; +begin + if length(gLandmarks) < 1 then + exit; + SetLength(gLandmarks,0); + UpdateCombo; +end; + +procedure TAnatForm.SaveBtnClick(Sender: TObject); +const + kSep = chr(9); +var + i: integer; + lF: TextFile; +begin + if length(gLandmarks) < 1 then begin + showmessage('No landmarks open - either open a file or create new landmarks'); + exit; + end; + ImgForm.SaveDialog1.Filter := kAnatFilter; + ImgForm.SaveDialog1.DefaultExt := '.anat'; + ImgForm.SaveDialog1.Filename := ChangeFileExt(ImgForm.SaveDialog1.Filename, ImgForm.SaveDialog1.DefaultExt); //10102006 + if not ImgForm.SaveDialog1.Execute then exit; + Filemode := 0; + AssignFile(lF, ImgForm.SaveDialog1.Filename); + rewrite(lF); + for i := 0 to length(gLandmarks)-1 do + Writeln(lF, gLandmarks[i].Name+kSep+floattostr(gLandmarks[i].X)+kSep+floattostr(gLandmarks[i].Y)+kSep+floattostr(gLandmarks[i].Z) ); + CloseFile(lF); + +end; + +procedure TAnatForm.UpdateCombo; +var + i: integer; +begin +//xxx + ComboBox1.Items.Clear; + if length(gLandmarks) < 1 then + exit; + for i := 0 to length(gLandmarks)-1 do + ComboBox1.Items.Add(gLandmarks[i].Name); + ComboBox1.ItemIndex := length(gLandmarks)-1; + ComboBox1Change(nil); +end; + + +procedure TAnatForm.AddBtnClick(Sender: TObject); +var + s: string; + i: integer; + lOK: boolean; +begin + i := length(gLandmarks)+1; + s := 'A'+inttostr(i); + lOK := InputQuery('Enter a name', 'region name', s); + if not lOK then + exit; + setlength(gLandmarks,i); + gLandmarks[i-1].Name := s; + Update(i-1); + UpdateCombo; +end; + +(* + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + *) +procedure SetLandmark(index: integer);//indexed from 0 +var +//lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if (index < 0) or (index >= length(gLandmarks)) then + exit; + MMToImgCoord(lX,lY,lZ,gLandmarks[index].X,gLandmarks[index].Y,gLandmarks[index].Z); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + ImgForm.XViewEditChange(nil); +end; + +procedure TAnatForm.ComboBox1Change(Sender: TObject); +begin + SetLandmark(ComboBox1.ItemIndex); +end; + +function NextTab(lStr: string; var lP: integer): string; +//reports text prior to comma... +var + len: integer; +begin + result := ''; + len := length(lStr); + if len < lP then exit; + repeat + if (lStr[lP] = chr(9){','}) then begin + lP := lP + 1; + exit; + end; + //if lStr[lP] <> ' ' then + result := result + lStr[lP]; + lP := lP + 1; + until (lP > len); +end; + +procedure TAnatForm.OpenAnat(lFilename: string); +var + st: string; + sl: TStringList; + n, line, col : integer; +begin + if not Fileexists(lFilename) then begin + CloseAnat; + exit; + end; + //will load the TAB delimited TXT here + sl := TStringList.Create; + try + //load the tab delimited txt file + sl.LoadFromFile(lFilename) ; + //for each tab delimited line + n := 0; + setlength(gLandmarks,sl.Count); + for line := 0 to sl.Count-1 do begin + st := sl[line]; + col := 1; + if (NextTab(st,col) <> '') and (NextTab(st,col) <> '') and(NextTab(st,col) <> '') and(NextTab(st,col) <> '') then begin + inc(n); + col := 1; + gLandmarks[line].Name := NextTab(st,col); + gLandmarks[line].X := strtofloat(NextTab(st,col)); + gLandmarks[line].Y := strtofloat(NextTab(st,col)); + gLandmarks[line].Z := strtofloat(NextTab(st,col)); + end; + end; + setlength(gLandmarks,n); + finally + sl.Free; + end; + UpdateCombo; + AnatForm.show; +end; + + +procedure TAnatForm.OpenBtnClick(Sender: TObject); +begin + if not OpenDialogExecute(kAnatFilter,'Select background image',false) then exit; + OpenAnat(HdrForm.OpenHdrDlg.Filename) ; +end; + +procedure TAnatForm.Update(lIndex: integer); +var + X,Y,Z: integer; +begin + if lIndex >= Length(gLandmarks) then + exit; + X := round(ImgForm.XViewEdit.value); + Y := round(ImgForm.YViewEdit.value); + Z := round(ImgForm.ZViewEdit.value); + ImgCoordToMM(X,Y,Z, gLandmarks[lIndex].X,gLandmarks[lIndex].Y,gLandmarks[lIndex].Z); + ComboBox1Change(nil); +end; + +procedure TAnatForm.UpdateBtnClick(Sender: TObject); +begin + Update(ComboBox1.ItemIndex); + +end; + +procedure TAnatForm.DeleteBtnClick(Sender: TObject); +var + p,i,l: integer; +begin + l := Length(gLandmarks); + i := ComboBox1.ItemIndex; + if (l < 1) or (i >= l) or (i < 0) then + exit; + if i < (l-1) then + for p := i+1 to l-1 do + gLandmarks[p-1] := gLandmarks[p]; + SetLength(gLandmarks,l-1); + UpdateCombo; +end; + +initialization +{$IFDEF FPC} +{$I landmarks.lrs} +{$ENDIF} + +end. + diff --git a/lib/i386-darwin/shit.compiled b/lib/i386-darwin/shit.compiled new file mode 100644 index 0000000..264ad63 --- /dev/null +++ b/lib/i386-darwin/shit.compiled @@ -0,0 +1,5 @@ + + + + + diff --git a/lib/i386-darwin/shit.o b/lib/i386-darwin/shit.o new file mode 100644 index 0000000..2227973 Binary files /dev/null and b/lib/i386-darwin/shit.o differ diff --git a/lib/i386-darwin/shit.or b/lib/i386-darwin/shit.or new file mode 100644 index 0000000..4d3ab9a Binary files /dev/null and b/lib/i386-darwin/shit.or differ diff --git a/lib/i386-darwin/shit.res b/lib/i386-darwin/shit.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/lib/i386-darwin/shit.res differ diff --git a/lib/i386-darwin/shitu.lfm b/lib/i386-darwin/shitu.lfm new file mode 100644 index 0000000..e3b46e6 --- /dev/null +++ b/lib/i386-darwin/shitu.lfm @@ -0,0 +1,107 @@ +object Form1: TForm1 + Left = 563 + Height = 595 + Top = 152 + Width = 1157 + Caption = 'Form1' + ClientHeight = 595 + ClientWidth = 1157 + Color = clWindow + Menu = MainMenu1 + OnCreate = FormCreate + OnDropFiles = FormDropFiles + OnResize = FormResize + LCLVersion = '1.4.2.0' + object Label1: TLabel + Left = 48 + Height = 16 + Top = 24 + Width = 42 + Caption = 'Label1' + ParentColor = False + end + object Button1: TButton + Left = 208 + Height = 25 + Top = 32 + Width = 75 + Caption = 'Button1' + OnClick = Button1Click + TabOrder = 0 + end + object ComboBox1: TComboBox + Left = 135 + Height = 21 + Top = 112 + Width = 100 + ItemHeight = 0 + Items.Strings = ( + '1' + '2' + '3' + ) + OnChange = ComboBox1Change + TabOrder = 1 + Text = 'ComboBox1' + end + object SpinEdit1: TSpinEdit + Left = 16 + Height = 16 + Top = 69 + Width = 175 + MinValue = 1 + OnChange = SpinEdit1Change + TabOrder = 2 + Value = 2 + end + object SpeedButton1: TSpeedButton + Left = 405 + Height = 102 + Top = 52 + Width = 111 + Caption = '1' + Flat = True + end + object SpeedButton2: TSpeedButton + Left = 528 + Height = 102 + Top = 52 + Width = 111 + Caption = '2' + end + object SpeedButton3: TSpeedButton + Left = 440 + Height = 103 + Top = 176 + Width = 151 + Color = 15758710 + end + object Image1: TImage + Left = 47 + Height = 274 + Top = 180 + Width = 322 + OnMouseDown = Image1MouseDown + OnMouseMove = Image1MouseMove + end + object MainMenu1: TMainMenu + left = 322 + top = 84 + object MenuItem1: TMenuItem + Caption = '' + object MenuItem2: TMenuItem + Caption = 'Preferences' + OnClick = MenuItem2Click + end + end + end + object SelectDirectoryDialog1: TSelectDirectoryDialog + left = 76 + top = 117 + end + object OpenDialog1: TOpenDialog + OnSelectionChange = OpenDialog1SelectionChange + left = 125 + top = 13 + end +end diff --git a/lib/i386-darwin/shitu.o b/lib/i386-darwin/shitu.o new file mode 100644 index 0000000..7fe8f72 Binary files /dev/null and b/lib/i386-darwin/shitu.o differ diff --git a/lib/i386-darwin/shitu.ppu b/lib/i386-darwin/shitu.ppu new file mode 100644 index 0000000..1dc1372 Binary files /dev/null and b/lib/i386-darwin/shitu.ppu differ diff --git a/license.txt b/license.txt new file mode 100755 index 0000000..72c6622 --- /dev/null +++ b/license.txt @@ -0,0 +1,17 @@ +MRIcron uses the BSD license. For details see + http://www.answers.com/topic/bsd-and-gpl-licensing +or + http://en.wikipedia.org/wiki/BSD_and_GPL_licensing + +MRIcron medical viewer +Copyright (c) 2006 Chris Rorden +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. +Neither the names of the copyright owners nor the names of this project (MRIcron) may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/lut/16.lut b/lut/16.lut new file mode 100755 index 0000000..91accec Binary files /dev/null and b/lut/16.lut differ diff --git a/lut/1hot.lut b/lut/1hot.lut new file mode 100755 index 0000000..7e4f94a Binary files /dev/null and b/lut/1hot.lut differ diff --git a/lut/2winter.lut b/lut/2winter.lut new file mode 100755 index 0000000..2ef40be Binary files /dev/null and b/lut/2winter.lut differ diff --git a/lut/3warm.lut b/lut/3warm.lut new file mode 100755 index 0000000..f408534 Binary files /dev/null and b/lut/3warm.lut differ diff --git a/lut/4cool.lut b/lut/4cool.lut new file mode 100755 index 0000000..04d2184 Binary files /dev/null and b/lut/4cool.lut differ diff --git a/lut/5redyell.lut b/lut/5redyell.lut new file mode 100755 index 0000000..9809f89 Binary files /dev/null and b/lut/5redyell.lut differ diff --git a/lut/6bluegrn.lut b/lut/6bluegrn.lut new file mode 100755 index 0000000..020fad8 Binary files /dev/null and b/lut/6bluegrn.lut differ diff --git a/lut/GE_color.lut b/lut/GE_color.lut new file mode 100755 index 0000000..ca04dd5 Binary files /dev/null and b/lut/GE_color.lut differ diff --git a/lut/HOTIRON.lut b/lut/HOTIRON.lut new file mode 100755 index 0000000..8728e7f Binary files /dev/null and b/lut/HOTIRON.lut differ diff --git a/lut/NIH.lut b/lut/NIH.lut new file mode 100755 index 0000000..94ebbe0 Binary files /dev/null and b/lut/NIH.lut differ diff --git a/lut/NIH_fire.lut b/lut/NIH_fire.lut new file mode 100755 index 0000000..976a88d Binary files /dev/null and b/lut/NIH_fire.lut differ diff --git a/lut/NIH_ice.lut b/lut/NIH_ice.lut new file mode 100755 index 0000000..302afc6 Binary files /dev/null and b/lut/NIH_ice.lut differ diff --git a/lut/Rainramp.lut b/lut/Rainramp.lut new file mode 100755 index 0000000..47e19fd Binary files /dev/null and b/lut/Rainramp.lut differ diff --git a/lut/actc.lut b/lut/actc.lut new file mode 100755 index 0000000..8067a51 Binary files /dev/null and b/lut/actc.lut differ diff --git a/lut/blackbdy.lut b/lut/blackbdy.lut new file mode 100755 index 0000000..3722fdb Binary files /dev/null and b/lut/blackbdy.lut differ diff --git a/lut/blue_otto.lut b/lut/blue_otto.lut new file mode 100755 index 0000000..fd38d69 --- /dev/null +++ b/lut/blue_otto.lut @@ -0,0 +1,257 @@ +* s=byte index red green blue +S 0 0 0 0 +S 1 0 0 128 +S 2 0 0 128 +S 3 0 0 128 +S 4 0 0 128 +S 5 0 0 128 +S 6 0 0 128 +S 7 0 0 128 +S 8 0 0 128 +S 9 0 0 128 +S 10 0 0 128 +S 11 0 0 128 +S 12 0 0 128 +S 13 0 0 128 +S 14 0 0 128 +S 15 0 0 128 +S 16 0 0 128 +S 17 0 0 128 +S 18 0 0 128 +S 19 0 0 128 +S 20 0 0 128 +S 21 0 0 128 +S 22 0 0 128 +S 23 0 0 128 +S 24 0 0 128 +S 25 0 0 128 +S 26 0 0 128 +S 27 0 0 128 +S 28 0 0 128 +S 29 0 0 128 +S 30 0 0 128 +S 31 0 0 128 +S 32 0 0 128 +S 33 0 0 128 +S 34 0 0 128 +S 35 0 0 128 +S 36 0 0 128 +S 37 0 0 128 +S 38 0 0 128 +S 39 0 0 128 +S 40 0 0 128 +S 41 0 0 128 +S 42 0 0 128 +S 43 0 0 128 +S 44 0 0 128 +S 45 0 0 128 +S 46 0 0 128 +S 47 0 0 128 +S 48 0 0 128 +S 49 0 0 128 +S 50 0 0 128 +S 51 32 0 192 +S 52 32 0 192 +S 53 32 0 192 +S 54 32 0 192 +S 55 32 0 192 +S 56 32 0 192 +S 57 32 0 192 +S 58 32 0 192 +S 59 32 0 192 +S 60 32 0 192 +S 61 32 0 192 +S 62 32 0 192 +S 63 32 0 192 +S 64 32 0 192 +S 65 32 0 192 +S 66 32 0 192 +S 67 32 0 192 +S 68 32 0 192 +S 69 32 0 192 +S 70 32 0 192 +S 71 32 0 192 +S 72 32 0 192 +S 73 32 0 192 +S 74 32 0 192 +S 75 32 0 192 +S 76 32 0 192 +S 77 32 0 192 +S 78 32 0 192 +S 79 32 0 192 +S 80 32 0 192 +S 81 32 0 192 +S 82 32 0 192 +S 83 32 0 192 +S 84 32 0 192 +S 85 32 0 192 +S 86 32 0 192 +S 87 32 0 192 +S 88 32 0 192 +S 89 32 0 192 +S 90 32 0 192 +S 91 32 0 192 +S 92 32 0 192 +S 93 32 0 192 +S 94 32 0 192 +S 95 32 0 192 +S 96 32 0 192 +S 97 32 0 192 +S 98 32 0 192 +S 99 32 0 192 +S 100 32 0 192 +S 101 32 0 192 +S 102 0 168 190 +S 103 0 168 190 +S 104 0 168 190 +S 105 0 168 190 +S 106 0 168 190 +S 107 0 168 190 +S 108 0 168 190 +S 109 0 168 190 +S 110 0 168 190 +S 111 0 168 190 +S 112 0 168 190 +S 113 0 168 190 +S 114 0 168 190 +S 115 0 168 190 +S 116 0 168 190 +S 117 0 168 190 +S 118 0 168 190 +S 119 0 168 190 +S 120 0 168 190 +S 121 0 168 190 +S 122 0 168 190 +S 123 0 168 190 +S 124 0 168 190 +S 125 0 168 190 +S 126 0 168 190 +S 127 0 168 190 +S 128 0 168 190 +S 129 0 168 190 +S 130 0 168 190 +S 131 0 168 190 +S 132 0 168 190 +S 133 0 168 190 +S 134 0 168 190 +S 135 0 168 190 +S 136 0 168 190 +S 137 0 168 190 +S 138 0 168 190 +S 139 0 168 190 +S 140 0 168 190 +S 141 0 168 190 +S 142 0 168 190 +S 143 0 168 190 +S 144 0 168 190 +S 145 0 168 190 +S 146 0 168 190 +S 147 0 168 190 +S 148 0 168 190 +S 149 0 168 190 +S 150 0 168 190 +S 151 0 168 190 +S 152 0 168 190 +S 153 127 255 255 +S 154 127 255 255 +S 155 127 255 255 +S 156 127 255 255 +S 157 127 255 255 +S 158 127 255 255 +S 159 127 255 255 +S 160 127 255 255 +S 161 127 255 255 +S 162 127 255 255 +S 163 127 255 255 +S 164 127 255 255 +S 165 127 255 255 +S 166 127 255 255 +S 167 127 255 255 +S 168 127 255 255 +S 169 127 255 255 +S 170 127 255 255 +S 171 127 255 255 +S 172 127 255 255 +S 173 127 255 255 +S 174 127 255 255 +S 175 127 255 255 +S 176 127 255 255 +S 177 127 255 255 +S 178 127 255 255 +S 179 127 255 255 +S 180 127 255 255 +S 181 127 255 255 +S 182 127 255 255 +S 183 127 255 255 +S 184 127 255 255 +S 185 127 255 255 +S 186 127 255 255 +S 187 127 255 255 +S 188 127 255 255 +S 189 127 255 255 +S 190 127 255 255 +S 191 127 255 255 +S 192 127 255 255 +S 193 127 255 255 +S 194 127 255 255 +S 195 127 255 255 +S 196 127 255 255 +S 197 127 255 255 +S 198 127 255 255 +S 199 127 255 255 +S 200 127 255 255 +S 201 127 255 255 +S 202 127 255 255 +S 203 127 255 255 +S 204 127 255 255 +S 205 220 255 255 +S 206 220 255 255 +S 207 220 255 255 +S 208 220 255 255 +S 209 220 255 255 +S 210 220 255 255 +S 211 220 255 255 +S 212 220 255 255 +S 213 220 255 255 +S 214 220 255 255 +S 215 220 255 255 +S 216 220 255 255 +S 217 220 255 255 +S 218 220 255 255 +S 219 220 255 255 +S 220 220 255 255 +S 221 220 255 255 +S 222 220 255 255 +S 223 220 255 255 +S 224 220 255 255 +S 225 220 255 255 +S 226 220 255 255 +S 227 220 255 255 +S 228 220 255 255 +S 229 220 255 255 +S 230 220 255 255 +S 231 220 255 255 +S 232 220 255 255 +S 233 220 255 255 +S 234 220 255 255 +S 235 220 255 255 +S 236 220 255 255 +S 237 220 255 255 +S 238 220 255 255 +S 239 220 255 255 +S 240 220 255 255 +S 241 220 255 255 +S 242 220 255 255 +S 243 220 255 255 +S 244 220 255 255 +S 245 220 255 255 +S 246 220 255 255 +S 247 220 255 255 +S 248 220 255 255 +S 249 220 255 255 +S 250 220 255 255 +S 251 220 255 255 +S 252 220 255 255 +S 253 220 255 255 +S 254 220 255 255 +S 255 220 255 255 diff --git a/lut/bluegray.lut b/lut/bluegray.lut new file mode 100755 index 0000000..2abf989 Binary files /dev/null and b/lut/bluegray.lut differ diff --git a/lut/bone.lut b/lut/bone.lut new file mode 100755 index 0000000..ea6ff74 Binary files /dev/null and b/lut/bone.lut differ diff --git a/lut/cardiac.lut b/lut/cardiac.lut new file mode 100755 index 0000000..3b72b95 Binary files /dev/null and b/lut/cardiac.lut differ diff --git a/lut/cortex.lut b/lut/cortex.lut new file mode 100755 index 0000000..f19bd7e --- /dev/null +++ b/lut/cortex.lut @@ -0,0 +1,5 @@ + +  !#$%'()+,./0234679:;=>?ABDEFHIKLMOPQSTVWXZ[\^_abcefhijlmnpqstuwxy{|~€‚ƒ„†‡‰Š‹Ž‘’”•–˜™›œŸ ¡£¤¦§¨ª«­®¯±²³µ¶¸¹º¼½¾ÀÁÃÄÅÇÈÉËÌÎÏÐÒÓÕÖ×ÙÚÛÝÞàáâäåæèéëìíïðòóôö÷øúûýþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ +  !"#$$%&'()*+,--./01234556789:;<==>?@ABCDEEFGHIJKLMMNOPQRSTUUVWXYZ[\]]^_`abcdeefghijklmmnopqrstuuvwxyz{|}}~€‚ƒ„…††‡ˆ‰Š‹ŒŽŽ‘’“”•––—˜™š›œžžŸ ¡¢£¤¥¦¦§¨©ª«¬­®®¯°±²³´µ¶¶·¸¹º»¼½¾¾¿ÀÁÂÃÄÅÆÆÇÈÉÊËÌÍÎÎÏÐÑÒÓÔÕÖÖ×ØÙÚÛÜÝàãæëðõúÿ + +  !""#$$%&&'(()**+,--.//01123345567789::;<<=>>?@@ABBCDDEFGGHIIJKKLMMNOOPQRRSTTUVVWXXYZZ[\\]^__`aabccdeefgghiijkllmnnoppqrrsttuvvwxyyz{{|}}~€‚ƒ„„…††‡ˆˆ‰ŠŠ‹ŒŒŽŽ‘‘’““”••–——˜™™š››œžžŸ ¡¢£¤¦ª¯´¹¾ÃÈÍÒÒ×Üáæëðõÿ \ No newline at end of file diff --git a/lut/flow.lut b/lut/flow.lut new file mode 100755 index 0000000..2b6eb3e Binary files /dev/null and b/lut/flow.lut differ diff --git a/lut/french.lut b/lut/french.lut new file mode 100755 index 0000000..150528a Binary files /dev/null and b/lut/french.lut differ diff --git a/lut/gold.lut b/lut/gold.lut new file mode 100755 index 0000000..4f4dfe2 Binary files /dev/null and b/lut/gold.lut differ diff --git a/lut/gooch.lut b/lut/gooch.lut new file mode 100755 index 0000000..be336d9 Binary files /dev/null and b/lut/gooch.lut differ diff --git a/lut/greengray.lut b/lut/greengray.lut new file mode 100755 index 0000000..e77808b Binary files /dev/null and b/lut/greengray.lut differ diff --git a/lut/overlay_classic.lut b/lut/overlay_classic.lut new file mode 100755 index 0000000..6d5add9 --- /dev/null +++ b/lut/overlay_classic.lut @@ -0,0 +1,257 @@ +* s=byte index red green blue +S 0 0 0 0 +S 1 250 0 255 +S 2 245 0 255 +S 3 240 0 255 +S 4 235 0 255 +S 5 230 0 255 +S 6 224 0 255 +S 7 219 0 255 +S 8 214 0 255 +S 9 209 0 255 +S 10 204 0 255 +S 11 199 0 255 +S 12 194 0 255 +S 13 189 0 255 +S 14 184 0 255 +S 15 179 0 255 +S 16 173 0 255 +S 17 168 0 255 +S 18 163 0 255 +S 19 158 0 255 +S 20 153 0 255 +S 21 148 0 255 +S 22 143 0 255 +S 23 138 0 255 +S 24 133 0 255 +S 25 128 0 255 +S 26 122 0 255 +S 27 117 0 255 +S 28 112 0 255 +S 29 107 0 255 +S 30 102 0 255 +S 31 97 0 255 +S 32 92 0 255 +S 33 87 0 255 +S 34 82 0 255 +S 35 77 0 255 +S 36 71 0 255 +S 37 66 0 255 +S 38 61 0 255 +S 39 56 0 255 +S 40 51 0 255 +S 41 46 0 255 +S 42 41 0 255 +S 43 36 0 255 +S 44 31 0 255 +S 45 26 0 255 +S 46 20 0 255 +S 47 15 0 255 +S 48 10 0 255 +S 49 5 0 255 +S 50 0 5 255 +S 51 0 10 255 +S 52 0 15 255 +S 53 0 20 255 +S 54 0 26 255 +S 55 0 31 255 +S 56 0 36 255 +S 57 0 41 255 +S 58 0 46 255 +S 59 0 51 255 +S 60 0 56 255 +S 61 0 61 255 +S 62 0 66 255 +S 63 0 71 255 +S 64 0 77 255 +S 65 0 82 255 +S 66 0 87 255 +S 67 0 92 255 +S 68 0 97 255 +S 69 0 102 255 +S 70 0 107 255 +S 71 0 112 255 +S 72 0 117 255 +S 73 0 122 255 +S 74 0 128 255 +S 75 0 133 255 +S 76 0 138 255 +S 77 0 143 255 +S 78 0 148 255 +S 79 0 153 255 +S 80 0 158 255 +S 81 0 163 255 +S 82 0 168 255 +S 83 0 173 255 +S 84 0 179 255 +S 85 0 184 255 +S 86 0 189 255 +S 87 0 194 255 +S 88 0 199 255 +S 89 0 204 255 +S 90 0 209 255 +S 91 0 214 255 +S 92 0 219 255 +S 93 0 224 255 +S 94 0 230 255 +S 95 0 235 255 +S 96 0 240 255 +S 97 0 245 255 +S 98 0 250 255 +S 99 0 255 255 +S 100 0 255 250 +S 101 0 255 245 +S 102 0 255 240 +S 103 0 255 235 +S 104 0 255 229 +S 105 0 255 224 +S 106 0 255 219 +S 107 0 255 214 +S 108 0 255 209 +S 109 0 255 204 +S 110 0 255 199 +S 111 0 255 194 +S 112 0 255 189 +S 113 0 255 184 +S 114 0 255 178 +S 115 0 255 173 +S 116 0 255 168 +S 117 0 255 163 +S 118 0 255 158 +S 119 0 255 153 +S 120 0 255 148 +S 121 0 255 143 +S 122 0 255 138 +S 123 0 255 133 +S 124 0 255 127 +S 125 0 255 122 +S 126 0 255 117 +S 127 0 255 112 +S 128 0 255 107 +S 129 0 255 102 +S 130 0 255 97 +S 131 0 255 92 +S 132 0 255 87 +S 133 0 255 82 +S 134 0 255 76 +S 135 0 255 71 +S 136 0 255 66 +S 137 0 255 61 +S 138 0 255 56 +S 139 0 255 51 +S 140 0 255 46 +S 141 0 255 41 +S 142 0 255 36 +S 143 0 255 31 +S 144 0 255 25 +S 145 0 255 20 +S 146 0 255 15 +S 147 0 255 10 +S 148 0 255 5 +S 149 0 255 0 +S 150 5 255 0 +S 151 10 255 0 +S 152 15 255 0 +S 153 20 255 0 +S 154 26 255 0 +S 155 31 255 0 +S 156 36 255 0 +S 157 41 255 0 +S 158 46 255 0 +S 159 51 255 0 +S 160 56 255 0 +S 161 61 255 0 +S 162 66 255 0 +S 163 71 255 0 +S 164 77 255 0 +S 165 82 255 0 +S 166 87 255 0 +S 167 92 255 0 +S 168 97 255 0 +S 169 102 255 0 +S 170 107 255 0 +S 171 112 255 0 +S 172 117 255 0 +S 173 122 255 0 +S 174 128 255 0 +S 175 133 255 0 +S 176 138 255 0 +S 177 143 255 0 +S 178 148 255 0 +S 179 153 255 0 +S 180 158 255 0 +S 181 163 255 0 +S 182 168 255 0 +S 183 173 255 0 +S 184 179 255 0 +S 185 184 255 0 +S 186 189 255 0 +S 187 194 255 0 +S 188 199 255 0 +S 189 204 255 0 +S 190 209 255 0 +S 191 214 255 0 +S 192 219 255 0 +S 193 224 255 0 +S 194 230 255 0 +S 195 235 255 0 +S 196 240 255 0 +S 197 245 255 0 +S 198 250 255 0 +S 199 255 255 0 +S 200 255 250 0 +S 201 255 245 0 +S 202 255 240 0 +S 203 255 235 0 +S 204 255 229 0 +S 205 255 224 0 +S 206 255 219 0 +S 207 255 214 0 +S 208 255 209 0 +S 209 255 204 0 +S 210 255 199 0 +S 211 255 194 0 +S 212 255 189 0 +S 213 255 184 0 +S 214 255 178 0 +S 215 255 173 0 +S 216 255 168 0 +S 217 255 163 0 +S 218 255 158 0 +S 219 255 153 0 +S 220 255 148 0 +S 221 255 143 0 +S 222 255 138 0 +S 223 255 133 0 +S 224 255 127 0 +S 225 255 122 0 +S 226 255 117 0 +S 227 255 112 0 +S 228 255 107 0 +S 229 255 102 0 +S 230 255 97 0 +S 231 255 92 0 +S 232 255 87 0 +S 233 255 82 0 +S 234 255 76 0 +S 235 255 71 0 +S 236 255 66 0 +S 237 255 61 0 +S 238 255 56 0 +S 239 255 51 0 +S 240 255 46 0 +S 241 255 41 0 +S 242 255 36 0 +S 243 255 31 0 +S 244 255 25 0 +S 245 255 20 0 +S 246 255 15 0 +S 247 255 10 0 +S 248 255 5 0 +S 249 255 0 0 +S 250 255 0 3 +S 251 255 0 5 +S 252 255 0 8 +S 253 255 0 10 +S 254 255 0 13 +S 255 255 0 16 diff --git a/lut/pink.lut b/lut/pink.lut new file mode 100755 index 0000000..b614ea5 Binary files /dev/null and b/lut/pink.lut differ diff --git a/lut/pink_old.lut b/lut/pink_old.lut new file mode 100755 index 0000000..d87bf6b Binary files /dev/null and b/lut/pink_old.lut differ diff --git a/lut/red_otto.lut b/lut/red_otto.lut new file mode 100755 index 0000000..358622e --- /dev/null +++ b/lut/red_otto.lut @@ -0,0 +1,257 @@ +* s=byte index red green blue +S 0 0 0 0 +S 1 128 0 0 +S 2 128 0 0 +S 3 128 0 0 +S 4 128 0 0 +S 5 128 0 0 +S 6 128 0 0 +S 7 128 0 0 +S 8 128 0 0 +S 9 128 0 0 +S 10 128 0 0 +S 11 128 0 0 +S 12 128 0 0 +S 13 128 0 0 +S 14 128 0 0 +S 15 128 0 0 +S 16 128 0 0 +S 17 128 0 0 +S 18 128 0 0 +S 19 128 0 0 +S 20 128 0 0 +S 21 128 0 0 +S 22 128 0 0 +S 23 128 0 0 +S 24 128 0 0 +S 25 128 0 0 +S 26 128 0 0 +S 27 128 0 0 +S 28 128 0 0 +S 29 128 0 0 +S 30 128 0 0 +S 31 128 0 0 +S 32 128 0 0 +S 33 128 0 0 +S 34 128 0 0 +S 35 128 0 0 +S 36 128 0 0 +S 37 128 0 0 +S 38 128 0 0 +S 39 128 0 0 +S 40 128 0 0 +S 41 128 0 0 +S 42 128 0 0 +S 43 128 0 0 +S 44 128 0 0 +S 45 128 0 0 +S 46 128 0 0 +S 47 128 0 0 +S 48 128 0 0 +S 49 128 0 0 +S 50 128 0 0 +S 51 192 0 32 +S 52 192 0 32 +S 53 192 0 32 +S 54 192 0 32 +S 55 192 0 32 +S 56 192 0 32 +S 57 192 0 32 +S 58 192 0 32 +S 59 192 0 32 +S 60 192 0 32 +S 61 192 0 32 +S 62 192 0 32 +S 63 192 0 32 +S 64 192 0 32 +S 65 192 0 32 +S 66 192 0 32 +S 67 192 0 32 +S 68 192 0 32 +S 69 192 0 32 +S 70 192 0 32 +S 71 192 0 32 +S 72 192 0 32 +S 73 192 0 32 +S 74 192 0 32 +S 75 192 0 32 +S 76 192 0 32 +S 77 192 0 32 +S 78 192 0 32 +S 79 192 0 32 +S 80 192 0 32 +S 81 192 0 32 +S 82 192 0 32 +S 83 192 0 32 +S 84 192 0 32 +S 85 192 0 32 +S 86 192 0 32 +S 87 192 0 32 +S 88 192 0 32 +S 89 192 0 32 +S 90 192 0 32 +S 91 192 0 32 +S 92 192 0 32 +S 93 192 0 32 +S 94 192 0 32 +S 95 192 0 32 +S 96 192 0 32 +S 97 192 0 32 +S 98 192 0 32 +S 99 192 0 32 +S 100 192 0 32 +S 101 192 0 32 +S 102 255 179 0 +S 103 255 179 0 +S 104 255 179 0 +S 105 255 179 0 +S 106 255 179 0 +S 107 255 179 0 +S 108 255 179 0 +S 109 255 179 0 +S 110 255 179 0 +S 111 255 179 0 +S 112 255 179 0 +S 113 255 179 0 +S 114 255 179 0 +S 115 255 179 0 +S 116 255 179 0 +S 117 255 179 0 +S 118 255 179 0 +S 119 255 179 0 +S 120 255 179 0 +S 121 255 179 0 +S 122 255 179 0 +S 123 255 179 0 +S 124 255 179 0 +S 125 255 179 0 +S 126 255 179 0 +S 127 255 179 0 +S 128 255 179 0 +S 129 255 179 0 +S 130 255 179 0 +S 131 255 179 0 +S 132 255 179 0 +S 133 255 179 0 +S 134 255 179 0 +S 135 255 179 0 +S 136 255 179 0 +S 137 255 179 0 +S 138 255 179 0 +S 139 255 179 0 +S 140 255 179 0 +S 141 255 179 0 +S 142 255 179 0 +S 143 255 179 0 +S 144 255 179 0 +S 145 255 179 0 +S 146 255 179 0 +S 147 255 179 0 +S 148 255 179 0 +S 149 255 179 0 +S 150 255 179 0 +S 151 255 179 0 +S 152 255 235 97 +S 153 255 235 97 +S 154 255 235 97 +S 155 255 235 97 +S 156 255 235 97 +S 157 255 235 97 +S 158 255 235 97 +S 159 255 235 97 +S 160 255 235 97 +S 161 255 235 97 +S 162 255 235 97 +S 163 255 235 97 +S 164 255 235 97 +S 165 255 235 97 +S 166 255 235 97 +S 167 255 235 97 +S 168 255 235 97 +S 169 255 235 97 +S 170 255 235 97 +S 171 255 235 97 +S 172 255 235 97 +S 173 255 235 97 +S 174 255 235 97 +S 175 255 235 97 +S 176 255 235 97 +S 177 255 235 97 +S 178 255 235 97 +S 179 255 235 97 +S 180 255 235 97 +S 181 255 235 97 +S 182 255 235 97 +S 183 255 235 97 +S 184 255 235 97 +S 185 255 235 97 +S 186 255 235 97 +S 187 255 235 97 +S 188 255 235 97 +S 189 255 235 97 +S 190 255 235 97 +S 191 255 235 97 +S 192 255 235 97 +S 193 255 235 97 +S 194 255 235 97 +S 195 255 235 97 +S 196 255 235 97 +S 197 255 235 97 +S 198 255 235 97 +S 199 255 235 97 +S 200 255 235 97 +S 201 255 235 97 +S 202 255 235 97 +S 203 255 235 97 +S 204 255 235 97 +S 205 255 255 200 +S 206 255 255 200 +S 207 255 255 200 +S 208 255 255 200 +S 209 255 255 200 +S 210 255 255 200 +S 211 255 255 200 +S 212 255 255 200 +S 213 255 255 200 +S 214 255 255 200 +S 215 255 255 200 +S 216 255 255 200 +S 217 255 255 200 +S 218 255 255 200 +S 219 255 255 200 +S 220 255 255 200 +S 221 255 255 200 +S 222 255 255 200 +S 223 255 255 200 +S 224 255 255 200 +S 225 255 255 200 +S 226 255 255 200 +S 227 255 255 200 +S 228 255 255 200 +S 229 255 255 200 +S 230 255 255 200 +S 231 255 255 200 +S 232 255 255 200 +S 233 255 255 200 +S 234 255 255 200 +S 235 255 255 200 +S 236 255 255 200 +S 237 255 255 200 +S 238 255 255 200 +S 239 255 255 200 +S 240 255 255 200 +S 241 255 255 200 +S 242 255 255 200 +S 243 255 255 200 +S 244 255 255 200 +S 245 255 255 200 +S 246 255 255 200 +S 247 255 255 200 +S 248 255 255 200 +S 249 255 255 200 +S 250 255 255 200 +S 251 255 255 200 +S 252 255 255 200 +S 253 255 255 200 +S 254 255 255 200 +S 255 255 255 200 \ No newline at end of file diff --git a/lut/spectrum.lut b/lut/spectrum.lut new file mode 100755 index 0000000..f77a7d5 Binary files /dev/null and b/lut/spectrum.lut differ diff --git a/lut/surface.lut b/lut/surface.lut new file mode 100755 index 0000000..68b28d9 --- /dev/null +++ b/lut/surface.lut @@ -0,0 +1,5 @@ + + !"$%&()+,./124578:;=>@ACDFGIJKMNPQSTVWYZ\]_`bcefhiklnoprsuvxy{|~‚„…‡ˆŠ‹Ž‘“”•—˜š›ž ¡£¤¦§©ª¬­¯°²³µ¶¸¹º¼½¿ÀÂÃÅÆÈÉËÌÎÏÑÒÔÕ×ØÚÛÝÞßáâäåçèêëíîðñóôö÷ùúüýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ +  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«¬­®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿÿ + +  !"##$%&&'(()*++,-../01123345667899:;<<=>??@AABCDDEFGGHIJJKLLMNOOPQRRSTUUVWXXYZZ[\]]^_``abccdeefghhijkklmnnopqqrsstuvvwxyyz{||}~~€‚ƒ„„…†‡‡ˆ‰ŠŠ‹ŒŒŽ‘’’“”••–——˜™šš›œžŸ  ¡¢££¤¥¥¦§¨¨©ª««¬­®®¯°´¹¾ÃÈÍÒ×Üáæëðõúüÿ \ No newline at end of file diff --git a/lut/x_hot.lut b/lut/x_hot.lut new file mode 100755 index 0000000..291ee87 Binary files /dev/null and b/lut/x_hot.lut differ diff --git a/lut/x_rain.lut b/lut/x_rain.lut new file mode 100755 index 0000000..94ae461 Binary files /dev/null and b/lut/x_rain.lut differ diff --git a/manifest.res b/manifest.res new file mode 100755 index 0000000..82d429d Binary files /dev/null and b/manifest.res differ diff --git a/metagraph.pas b/metagraph.pas new file mode 100755 index 0000000..4ac4cfc --- /dev/null +++ b/metagraph.pas @@ -0,0 +1,690 @@ +unit metagraph; +interface + +uses + {$IFNDEF Unix}Windows, Messages, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Buttons, ToolWin, ComCtrls,define_types, ExtCtrls, StdCtrls, Menus,ClipBrd; + +const + kMaxCond = 6; + knMaxRow = 20; //Niftiimgvie + kMaxLines = kMaxCond* knMaxRow; + kClrRA: array [1..kMaxCond] of TColor = (clRed,clGreen,clBlue,clTeal,clAqua,clSilver); + kPenStyleRA: array[1..knMaxRow] of TPenStyle = (psSolid,psDot,psDash,psDashDot,psDashDotDot,psSolid,psDot,psDash,psDashDot,psDashDotDot, + psSolid,psDot,psDash,psDashDot,psDashDotDot,psSolid,psDot,psDash,psDashDot,psDashDotDot); +type + TEventOnset = RECORD + Events: integer; + ELabel: string[16]; + EventRA,DurRA: SingleP; + END; + + T4DTrace = RECORD + //Title: string[16]; + //Samples: integer; + HorzMin,HorzWidPerBin,SampleMin,SampleMax,SamplePlotMin,SamplePlotMax + {SampleMean,SampleSD,SampleSE,SampleVar}: Double; + //SampleRA: SingleP; + Lines: array [1..kMaxLines] of TEventOnset; + Conditions: array [1..kMaxLines] of TEventOnset; + //DurationRA: array [1..kMaxLines] of SingleP; + END; +procedure Create4DTrace (var l4DTrace: T4DTrace); +procedure Init4DTrace(lnSample,lnLines: integer; var l4DTrace: T4DTrace; lErrorBars: boolean); +procedure Close4DTrace (var l4DTrace: T4DTrace; lCloseCond: boolean); +procedure MinMax4DTrace(var l4DTrace: T4DTrace); +procedure CorePlot4DTrace(var l4DTrace: T4DTrace; lImage: TImage; lStartSample,HSpeed,lnColors: integer;lTR,lVertMin,lVertMax: single; lErrorBars: boolean); +procedure GraphResize(lImage: TImage); +procedure CloseCond (var l4DTrace: T4DTrace; lCond: integer); +procedure InitCond (var l4DTrace: T4DTrace; lCond, lnEvents: integer); + + +{$IFNDEF FPC} var gWmf: TMetafile; {$ENDIF} +implementation + +procedure GraphResize(lImage: TImage); +var + TempBitmap: TBitmap; + lx,ly: integer; +begin + + lx := lImage.Width; + ly := lImage.Height; + if (lx < 1) or (ly < 1) then exit; + TempBitmap := TBitmap.Create; + TempBitmap.Width := lx; + TempBitmap.Height := ly; + //Draw32Bitmap(TempBitmap.Canvas.Handle, lx, ly,lBuff {Self}); + lImage.Picture.Bitmap := TempBitmap; + lImage.Width := lx;//delphi + lImage.Height := ly;//delphi + TempBitmap.Free; +end; + +function RealToStr(lR: double {was extended}; lDec: integer): string; +begin + if lR > 99999 then + RealTOStr := FloatToStrF(lR, ffExponent ,lDec,7) + else + RealTOStr := FloatToStrF(lR, ffFixed,7,lDec); +end; + +procedure Create4DTrace (var l4DTrace: T4DTrace); +var + lLine: integer; +begin + with l4DTrace do begin + for lLine := 1 to kMaxLines do begin + Lines[lLine].events := 0; + Lines[lLine].elabel := ''; + Conditions[lLine].events := 0; + Conditions[lLine].elabel := ''; + + end; + end; //with trace +end; + +procedure Init4DTrace(lnSample,lnLines: integer; var l4DTrace: T4DTrace; lErrorBars: boolean); +var + lLine: integer; +begin + Close4DTrace(l4DTrace,lErrorBars); + if (lnSample < 1) or (lnLines < 1) then + exit; + with l4DTrace do begin + HorzMin := 0; + HorzWidPerBin := 1; + for lLine := 1 to lnLines do begin + //getmem(DurationRA[lLine],lnSample*sizeof(single)); + //fx(lLine,lnSample); + + getmem(Lines[lLine].EventRA,lnSample*sizeof(single)); + Lines[lLine].events := lnSample; + if lErrorBars then begin + getmem(Conditions[lLine].EventRA,lnSample*sizeof(single)); + getmem(Conditions[lLine].DurRA,lnSample*sizeof(single)); + Conditions[lLine].events := lnSample; + end; + end; //for each line + end; //with trace +end; + +procedure Close4DTrace (var l4DTrace: T4DTrace; lCloseCond: boolean); +var + lLine: integer; +begin + with l4DTrace do begin + for lLine := 1 to kMaxLines do begin + if Lines[lLine].events > 0 then begin + + freemem(Lines[lLine].EventRA); + end; + Lines[lLine].events := 0; + if lCloseCond then begin + if Conditions[lLine].events > 0 then begin + freemem(Conditions[lLine].EventRA); + freemem(Conditions[lLine].DurRA); //1/1/2008 + end; + Conditions[lLine].events := 0; + end; + end; //for each Line + end; //with trace +end; + +procedure CloseCond (var l4DTrace: T4DTrace; lCond: integer); +begin + if (lCond < 1) or (lCond > kMaxLines) then + exit; + if l4DTrace.Conditions[lCond].events > 0 then begin + freemem(l4DTrace.Conditions[lCond].EventRA); + freemem(l4DTrace.Conditions[lCond].DurRA); + end; + l4DTrace.Conditions[lCond].events := 0; +end; + +procedure InitCond (var l4DTrace: T4DTrace; lCond, lnEvents: integer); +begin + if (lCond < 1) or (lCond > kMaxLines) then + exit; + CloseCond (l4DTrace, lCond); + if lnEvents > 0 then begin + getmem(l4DTrace.Conditions[lCond].EventRA, lnEvents * sizeof(single)); + //getmem(l4DTrace.DurationRA[lCond],lnEvents*sizeof(single)); + getmem(l4DTrace.Conditions[lCond].DurRA,lnEvents*sizeof(single)); + //fx(lLine,lnSample); + end; + l4DTrace.Conditions[lCond].events := lnEvents; +end; + +procedure MinMax4DTrace(var l4DTrace: T4DTrace); +var lPos,lLine: integer; +l1stLine :boolean; +begin + l1stLine := true; + with l4DTrace do begin + for lLine := 1 to kMaxLines do begin + if Lines[lLine].events > 0 then begin + if l1stLine then begin + SampleMin := Lines[lLine].EventRA^[1]; + SampleMax:= Lines[lLine].EventRA^[1]; + end; + l1stLine := false; + + for lPos := 1 to Lines[lLine].events do begin + if Lines[lLine].EventRA^[lPos] > SampleMax then + SampleMax := Lines[lLine].EventRA^[lPos]; + if Lines[lLine].EventRA^[lPos] < SampleMin then + SampleMin := Lines[lLine].EventRA^[lPos]; + end; //for each event + end; //if events > 0 + end; //for each line + SamplePlotMin := SampleMin-0.1*abs(SampleMax-SampleMin); + SamplePlotMax := SampleMax+0.1*abs(SampleMax-SampleMin); + end; //with trace +end; + +{$IFDEF FPC} +procedure HText(lImage: TImage; lX,lY,lDec: integer; lVal: single); +{$ELSE} +procedure HText(lImage: TMetafileCanvas; lX,lY,lDec: integer; lVal: single); +{$ENDIF} +var + lStr: string; +begin + if lDec >= 0 then + lStr := realtostr(round(lVal),0) + else + lStr := realtostr(lVal,abs(lDec)); +{$IFDEF FPC} + lImage.Canvas.TextOut(lX-(lImage.Canvas.TextWidth(lStr) shr 1),lY,lStr); +{$ELSE} + lImage.TextOut(lX-(lImage.TextWidth(lStr) shr 1),lY,lStr); +{$ENDIF} +end; + +{$IFDEF FPC} +procedure VText(lImage: TImage; lX,lY,lDec: integer; lVal: single); +{$ELSE} +procedure VText(lImage: TMetafileCanvas; lX,lY,lDec: integer; lVal: single); +{$ENDIF} +var + lStr: string; +begin + if lDec >= 0 then + lStr := realtostr(round(lVal),0) + else + lStr := realtostr(lVal,abs(lDec)); +{$IFDEF FPC} + lImage.Canvas.TextOut(lX-lImage.Canvas.TextWidth(lStr) ,lY,lStr); +{$ELSE} + lImage.TextOut(lX-lImage.TextWidth(lStr) ,lY,lStr); +{$ENDIF} + +end; + +{$IFDEF FPC} +procedure VTextLeftJustified(lImage: TIMage; lX,lY,lDec: integer; lVal: single); +{$ELSE} +procedure VTextLeftJustified(lImage: TMetafileCanvas; lX,lY,lDec: integer; lVal: single); +{$ENDIF} +var + lStr: string; +begin + if lDec >= 0 then + lStr := inttostr(round(lVal)) + else + lStr := realtostr(lVal,abs(lDec)); +{$IFDEF FPC} + lImage.Canvas.TextOut(lX ,lY,lStr); +{$ELSE} + lImage.TextOut(lX ,lY,lStr); +{$ENDIF} + +end; + +{$IFDEF FPC} +procedure ShowRange(lImage: TImage; lMin,lMax: single; lL,lT,lR,lB,lPosition: integer); +{$ELSE} +procedure ShowRange(lImage: TMetafileCanvas; lMin,lMax: single; lL,lT,lR,lB,lPosition: integer); +{$ENDIF} +//position 1=L,2=T,3=R,4=B +var + lRangeR,lRange,lD,lV: double; + lDecimals,lPos,lLo,lHi,lHPos,lOffset : integer; +begin +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + Font.color := clBlack; + lRange := abs(lMax-lMin); + lRangeR := lRange; + lDecimals := 0; + lD := 1; + if lRangeR = 0 then + exit; + while lRangeR > 10 do begin//get range 1..10 + lRangeR := lRangeR / 10; + inc(lDecimals); + lD := lD * 10; + end; + while lRangeR < 1 do begin//get range 1..10 + lRangeR := lRangeR * 10; + dec(lDecimals); + lD := lD / 10; + end; + lLo := round((lMin + (lD/2)) / lD); + lHi := trunc((lMax + (lD/20) ) / lD);//2007 + //lHi := trunc((lMax ) / lD); + if lHi <= (lLo+2) then begin + lD := lD /2; + if lDecimals <= 0 then + dec(lDecimals) + else + inc(lDecimals); + lLo := round((lMin + (lD/2)) / lD); + lHi := trunc((lMax + (lD/20) ) / lD);//2007 + end; + if (lPosition = 2{T}) or (lPosition = 4{B}) then begin + lOffset := TextHeight('0'); + for lPos := lLo to lHi do begin + lV := lPos * lD; + lHPos := lL+ round( ((lV-lMin) / lRange)* abs(lR-lL)); + if (lPosition = 2{T}) then + HText(lImage, lHPos,lT- lOffset,lDecimals,lV) + else + HText(lImage, lHPos,lB+1,lDecimals,lV); + end; + end else if (lPosition = 1{L}) or (lPosition = 3{R}) then begin //vertical values + lOffset := TextHeight('0') div 2; //2007 + for lPos := lLo to lHi do begin + lV := lPos * lD; + {lHPos := lB- round( ((lV-lMin) / lRange)* abs(lT-lB)); + lImage.MoveTo(1,lHPos); + lImage.LineTo(1000,lHPos);} + lHPos := lB- round( ((lV-lMin) / lRange)* abs(lT-lB))-lOffset; + + if (lPosition = 1{L}) then + VText(lImage, lL-1,lHPos,lDecimals,lV) + else + VTextLeftJustified(lImage, lR+1,lHPos,lDecimals,lV); + end; + + end; //if vertical + end; //with limage +end; + +{$IFDEF FPC} +function ShowLegend(var l4DTrace: T4DTrace; lImage: TImage; lL,lT: integer): integer; +{$ELSE} +function ShowLegend(var l4DTrace: T4DTrace; lImage: TMetafileCanvas; lL,lT: integer): integer; +{$ENDIF} +var + lC,lLegendLeft: integer; +begin +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + lLegendLeft := lL; + font.color := clBlack; + for lC := 1 to kMaxCond do begin + //lImage.canvas.pen.color := kClrRA[lC]; + font.color := kClrRA[lC] ; + if (l4DTrace.Conditions[lC].events > 0) then begin + TextOut(lLegendLeft,lT,l4DTrace.Conditions[lC].ELabel); + lLegendLeft := lLegendLeft + TextWidth(l4DTrace.Conditions[lC].ELabel)+5; + end; //for each tevent + end; //if cond has events + result := lLegendLeft; +end; //with limage +end; //for each cond + +function n4DTrace(var l4DTrace: T4DTrace;var lSamples: integer; lErrorBars: boolean): integer; +var lLine: integer; +l1stLine :boolean; +begin + lSamples:= 0; + result := 0; + l1stLine := true; + with l4DTrace do begin + for lLine := 1 to kMaxLines do begin + if Lines[lLine].events > 0 then begin + if l1stLine then + lSamples := Lines[lLine].events; + l1stLine := false; + if (lErrorBars) and (Lines[lLine].events <> lSamples) then + exit; //all lines must have same number of samples + inc(result); + end; //if events > 0 + end; //for each line + end; //with trace +end; + +{$IFDEF FPC} +function SetColorStyle (lImage: TImage; lLine,lnColors: integer): TPenStyle; +{$ELSE} +function SetColorStyle (lImage: TMetafileCanvas; lLine,lnColors: integer): TPenStyle; +{$ENDIF} +var + lC: integer; +begin +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + if lnColors < 1 then begin + pen.color := clBlack;//clRed + pen.style := kPenStyleRA[lLine]; + result := kPenStyleRA[lLine]; + exit; + end; + lC := lLine mod lnColors; + if lC = 0 then + lC := lnColors; + pen.color := kClrRA[lC]; + lC := ((lLine-1) div lnColors)+1; + pen.style := kPenStyleRA[lC]; + result := kPenStyleRA[lC]; +end; //with lImage. +end; + +{$IFDEF FPC} +procedure ShowLineLegend(var l4DTrace: T4DTrace; lImage: TImage; lL, lT,lnLines,lnColors: integer); +{$ELSE} +procedure ShowLineLegend(var l4DTrace: T4DTrace; lImage: TMetafileCanvas; lL, lT,lnLines,lnColors: integer); +{$ENDIF} +var + lLineTop,lStyle,lnStyles,lLegendLeft: integer; +begin + if lnColors < 1 then + lnStyles := lnLines + else + lnStyles := lnLines div lnColors; + if lnStyles < 1 then + lnStyles := 1; +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + + font.color := clBlack; + pen.color := clBlack; + lLegendLeft := lL; + lLineTop := lT+(TextHeight('X') div 2); + for lStyle := 1 to lnStyles do begin + pen.style := kPenStyleRA[lStyle]; + MoveTo(lLegendLeft,lLineTop); + lLegendLeft := lLegendLeft +40; + LineTo(lLegendLeft,lLineTop); + lLegendLeft := lLegendLeft + 2; + TextOut(lLegendLeft,lT,l4DTrace.Lines[lStyle].ELabel); + lLegendLeft := lLegendLeft + TextWidth(l4DTrace.Lines[lStyle].ELabel)+5; + end; + pen.style := psSolid; +end;//with lImage. +end; + +{$IFDEF FPC} +procedure ShowPlot(var l4DTrace: T4DTrace; lImage: TImage; lL,lT,lR,lB,lStartSample,lHSpeedIn,lScalePos,lnColors: integer; lSecPerSample,lVertMin,lVertMax: single; lShowHRange,lErrorBars: boolean); +{$ELSE} +procedure ShowPlot(var l4DTrace: T4DTrace; lImage: TMetafileCanvas; lL,lT,lR,lB,lStartSample,lHSpeedIn,lScalePos,lnColors: integer; lSecPerSample,lVertMin,lVertMax: single; lShowHRange,lErrorBars: boolean); +{$ENDIF} +const + kMinMax = 0; + k2SD = 1; + k12bit = 2; + kMaxPt = 16000; +type + TPtRA= array [1..kMaxPt] of TPoint; +var + lnPt,lnLines,lLine,lnSamples,lC,lStartSamp,lEndSamp,lEndPix,lPos,lI: integer; + lVert,lHorz,lVMax,lVMin,lScale,lHSpeed: single; + lPenStyle: TPenStyle; + lPtRA: TPtRA; +begin + lnLines := n4DTrace(l4DTrace,lnSamples,lErrorBars); + if (lnLines < 1) or (lnSamples < 2) or (lB <= lT) then exit; + lStartSamp := lStartSample; + if (lStartSamp > lnSamples) then + exit; + if lStartSamp < 1 then + lStartSamp := 1; + lHSpeed := lHSpeedIn; + if lHSpeed < 1 then begin + lStartSamp := 1; + lHSpeed := (lnSamples-1)/(lR-lL); + end; +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + lEndSamp := trunc(lStartSamp + ((lR-lL)*lHSpeed))+1; + ShowRange(lImage, l4DTrace.HorzMin+((lStartSamp-1)*l4DTrace.HorzWidPerBin),l4DTrace.HorzMin+((lEndSamp-1)*l4DTrace.HorzWidPerBin),lL,lT,lR,lB,4); + if lShowHRange then + ShowRange(lImage, l4DTrace.HorzMin+((lStartSamp-1)*l4DTrace.HorzWidPerBin),l4DTrace.HorzMin+((lEndSamp-1)*l4DTrace.HorzWidPerBin),lL,lT,lR,lB,4); + + lI := ShowLegend(l4DTrace,lImage, lL,5); + ShowLineLegend(l4DTrace, lImage, lI+10, 5,lnLines,lnColors); + //next show event onsets + if not lErrorBars then + for lC := 1 to kMaxCond do begin + pen.color := kClrRA[lC]; + if (l4DTrace.Conditions[lC].events > 0) and (lSecPerSample > 0) then begin + //canvas.TextOut(lLegendLeft,lT-canvas.TextHeight('X')-2,l4DTrace.Conditions[lC].ELabel); + //lLegendLeft := lLegendLeft + canvas.TextWidth(l4DTrace.Conditions[lC].ELabel)+5; + for lPos := 1 to l4DTrace.Conditions[lC].events do begin + lHorz := l4DTrace.Conditions[lC].EventRA^[lPos] / lSecPerSample; + if (lHorz < lEndSamp) and (lHorz > lStartSamp) then begin + lVert := ((lHorz - lStartSamp) / lHSpeed)+lL; + moveto(round(lVert),lT); + lineto(round(lVert),lB); + end; //if event in range + end; //for each tevent + end; //if cond has events + end; //for each cond + if (lEndSamp > lnSamples) then begin + lEndSamp := lnSamples; + lEndPix := lL+trunc((lnSamples-lStartSamp) / lHSpeed); + end else + lEndPix := lR; + lVMax := lVertMax; + lVMin := lVertMin; + if (lVMax <= lVMin) then begin + lVMax := l4DTrace.SamplePlotMax; + lVMin := l4DTrace.SamplePlotMin; + end; + if (lVMax < l4DTrace.SampleMin) or (lVMin > l4DTrace.SampleMax) then begin + lVMax := l4DTrace.SamplePlotMax; + lVMin := l4DTrace.SamplePlotMin; + end; + + ShowRange(lImage,lVMin,lVMax,lL,lT,lR,lB,lScalePos); + moveto(lL,lT); + if lVMax <= lVMin then + lScale := 1 + else + lScale := (lB-lT)/ (lVMax-lVMin); + if lHSpeed < 1 then begin + //lHSpeed := (l4DTrace.Samples-1)/(lR-lL); + for lLine := 1 to lnLines do begin + lPenStyle := SetColorStyle (lImage, lLine,lnColors); + lnPt := 0; + for lPos := lStartSamp to lEndSamp do begin + lVert := l4DTrace.Lines[lLine].EventRA^[lPos]; + if lVert > lVMax then + lVert := lVMax + else if lVert < lVMin then + lVert := lVMin; + lVert := round((lVert-lVMin)*lScale); + lVert := lB-lVert; + lHorz := lL+round((lPos-lStartSamp)/lHSpeed); + inc(lnPt); + if lnPt < kMaxPt then + lPtRA[lnPt] := Point(round(lHorz),round(lVert)); + if lErrorBars then begin + pen.style := psSolid; + moveto(round(lHorz),round(lVert-(l4DTrace.Conditions[lLine].EventRA^[lPos]*lScale))); + lineto(round(lHorz) ,round(lVert+(l4DTrace.Conditions[lLine].EventRA^[lPos]*lScale))); + moveto(round(lHorz) ,round(lVert)); + pen.style := lPenStyle; + end; + end; //for lPos + if lnPt > kMaxPt then + lnPt := kMaxPt; + if lnPt > 0 then + PolyLine( Slice(lPtRA, lnPt)); + + end; //for each line + end else begin //HSpeed >=1 so every pixel unique + for lLine := 1 to lnLines do begin + lPenStyle := SetColorStyle (lImage, lLine,lnColors); + lI := lStartSamp; + lnPt := 0; + for lPos := lL to lEndPix do begin + lVert := l4DTrace.Lines[lLine].EventRA^[lI]; + if lVert > lVMax then + lVert := lVMax + else if lVert < lVMin then + lVert := lVMin; + lVert := round((lVert-lVMin)*lScale); + //lVert := lVert + lT; + lVert := lB-lVert; + inc(lnPt); + if lnPt < kMaxPt then + lPtRA[lnPt] := Point(lPos,round(lVert)); + + if lErrorBars then begin + pen.style := psSolid; + moveto(lPos,round(lVert-(l4DTrace.Conditions[lLine].EventRA^[lPos]*lScale))); + lineto(lPos ,round(lVert+(l4DTrace.Conditions[lLine].EventRA^[lPos]*lScale))); + moveto(lPos ,round(lVert)); + pen.style := lPenStyle; + end; + lI := round( lStartSamp+((lPos-lL)*lHSpeed) ); + if lI < 1 then + lI := 1; + if lI > lEndSamp then + lI := lEndSamp; + end; //for lPos + if lnPt > kMaxPt then + lnPt := kMaxPt; + if lnPt > 0 then + PolyLine( Slice(lPtRA, lnPt)) + + end; //for each line + end; //hspeed >= 1 + pen.style := psSolid; +end;//with .lImage +end; + + + +procedure DrawBMP( lx, ly: integer; {lBuff: RGBQuadp;} var lImage: TImage); +var + TempBitmap: TBitmap; +begin + TempBitmap := TBitmap.Create; + TempBitmap.Width := lx; + TempBitmap.Height := ly; + //Draw32Bitmap(TempBitmap.Canvas.Handle, lx, ly,lBuff {Self}); + lImage.Picture.Bitmap := TempBitmap; + lImage.Width := lx;//delphi + lImage.Height := ly;//delphi + TempBitmap.Free; +end; + + + {$IFDEF FPC} +procedure PrepPlot(var lImage: TIMage; lL,lT,lR,lB,lWid,lHt,lFontSize: integer); +{$ELSE} +procedure PrepPlot(var lImage: TMetafileCanvas; lL,lT,lR,lB,lWid,lHt,lFontSize: integer); +{$ENDIF} +begin +{$IFDEF FPC} + with lImage.Canvas do begin +{$ELSE} + with lImage do begin +{$ENDIF} + Font.Name := 'Arial'; + Font.Size := 12; + pen.color := clBlack; + Font.color := clBlack; + Brush.Style := bsSolid; + Brush.color := clWhite; + Rectangle(1,1,lWid,lHt); + Rectangle(lL,lT,lR,lB); + end; +end; + +procedure CorePlot4DTrace(var l4DTrace: T4DTrace; lImage: TImage; lStartSample,HSpeed,lnColors: integer;lTR,lVertMin,lVertMax: single; lErrorBars: boolean); +var + lWid,lHt,lBorder,lL,lT,lR,lB,lFontSize: integer; +{$IFDEF FPC} + //WmfCanvas: TCanvas; + +{$ELSE} + WmfCanvas: TMetafileCanvas; +{$ENDIF} +begin + lWid := lImage.Width; + lHt := lImage.Height; + lFontSize := 12; + lBorder := lFontSize * 4; + if (lWid <= (2*lBorder)) or (lHt <= (2*lBorder)) then + exit; + + lL := round(1.3*lBorder); + lT :=lFontSize*2; + lR := lWid - lBorder; + lB := lHt-(lFontSize*2); +{$IFDEF FPC} + //WmfCanvas := TCanvas.Create; + PrepPlot(lImage,lL,lT,lR,lB,lWid,lHt,lFontSize); + ShowPlot(l4DTrace,lImage,lL,lT,lR,lB,lStartSample,HSpeed,1,lnColors, lTR,lVertMin,lVertMax,true,lErrorBars); +//abba lImage.Canvas.Draw (0, 0, WmfCanvas); + //WmfCanvas.Free; +{$ELSE} + gWmf.clear; + gWmf.Width := lWid; + gWmf.Height := lHt; + WmfCanvas := TMetafileCanvas.CreateWithComment(gWmf, 0, 'mricron', 'plot metafile'); + try + PrepPlot(WmfCanvas,lL,lT,lR,lB,lWid,lHt,lFontSize); + ShowPlot(l4DTrace,WmfCanvas,lL,lT,lR,lB,lStartSample,HSpeed,1,lnColors, lTR,lVertMin,lVertMax,true,lErrorBars); + finally + WmfCanvas.Free; + end;//finally + lImage.Canvas.Draw (0, 0, gWmf); +{$ENDIF} +end; + + +initialization +begin +{$IFDEF FPC} +{$ELSE} + gWmf := TMetafile.Create; + gWmf.Enhanced := True; +{$ENDIF} + // Create4DTrace(g4Ddata); +end; + +finalization +begin + //Close4DTrace(g4Ddata); +{$IFDEF FPC} +{$ELSE} + gWmf.free; +{$ENDIF} + +end; + + +end. diff --git a/mini.bmp b/mini.bmp new file mode 100755 index 0000000..275400e Binary files /dev/null and b/mini.bmp differ diff --git a/mni.lfm b/mni.lfm new file mode 100755 index 0000000..600b947 --- /dev/null +++ b/mni.lfm @@ -0,0 +1,51 @@ +object MNIForm: TMNIForm + Left = 444 + Height = 32 + Top = 300 + Width = 264 + HorzScrollBar.Page = 263 + VertScrollBar.Page = 53 + ActiveControl = XEdit + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'MNI position' + ClientHeight = 32 + ClientWidth = 264 + Constraints.MaxHeight = 32 + Constraints.MaxWidth = 264 + Constraints.MinHeight = 32 + Constraints.MinWidth = 264 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '0.9.29' + object XEdit: TSpinEdit + Left = 16 + Height = 21 + Top = 4 + Width = 66 + MaxValue = 200 + MinValue = -200 + OnChange = XEditChange + TabOrder = 0 + end + object YEdit: TSpinEdit + Left = 96 + Height = 21 + Top = 4 + Width = 66 + MaxValue = 200 + MinValue = -200 + OnChange = XEditChange + TabOrder = 1 + end + object ZEdit: TSpinEdit + Left = 176 + Height = 21 + Top = 4 + Width = 66 + MaxValue = 200 + MinValue = -200 + OnChange = XEditChange + TabOrder = 2 + end +end diff --git a/mni.lrs b/mni.lrs new file mode 100644 index 0000000..8fb4ee3 --- /dev/null +++ b/mni.lrs @@ -0,0 +1,16 @@ +LazarusResources.Add('TMNIForm','FORMDATA',[ + 'TPF0'#8'TMNIForm'#7'MNIForm'#4'Left'#3#188#1#6'Height'#2' '#3'Top'#3','#1#5 + +'Width'#3#8#1#18'HorzScrollBar.Page'#3#7#1#18'VertScrollBar.Page'#2'5'#13'Ac' + +'tiveControl'#7#5'XEdit'#11'BorderIcons'#11#12'biSystemMenu'#0#11'BorderStyl' + +'e'#7#8'bsDialog'#7'Caption'#6#12'MNI position'#12'ClientHeight'#2' '#11'Cli' + +'entWidth'#3#8#1#21'Constraints.MaxHeight'#2' '#20'Constraints.MaxWidth'#3#8 + +#1#21'Constraints.MinHeight'#2' '#20'Constraints.MinWidth'#3#8#1#8'OnCreate' + +#7#10'FormCreate'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#6'0.9.29' + +#0#9'TSpinEdit'#5'XEdit'#4'Left'#2#16#6'Height'#2#21#3'Top'#2#4#5'Width'#2'B' + +#8'MaxValue'#3#200#0#8'MinValue'#3'8'#255#8'OnChange'#7#11'XEditChange'#8'Ta' + +'bOrder'#2#0#0#0#9'TSpinEdit'#5'YEdit'#4'Left'#2'`'#6'Height'#2#21#3'Top'#2#4 + +#5'Width'#2'B'#8'MaxValue'#3#200#0#8'MinValue'#3'8'#255#8'OnChange'#7#11'XEd' + +'itChange'#8'TabOrder'#2#1#0#0#9'TSpinEdit'#5'ZEdit'#4'Left'#3#176#0#6'Heigh' + +'t'#2#21#3'Top'#2#4#5'Width'#2'B'#8'MaxValue'#3#200#0#8'MinValue'#3'8'#255#8 + +'OnChange'#7#11'XEditChange'#8'TabOrder'#2#2#0#0#0 +]); diff --git a/mni.pas b/mni.pas new file mode 100755 index 0000000..415a79b --- /dev/null +++ b/mni.pas @@ -0,0 +1,60 @@ +unit mni; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Spin; + +type + + { TMNIForm } + + TMNIForm = class(TForm) + XEdit: TSpinEdit; + YEdit: TSpinEdit; + ZEdit: TSpinEdit; + procedure FormCreate(Sender: TObject); + procedure XEditChange(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + MNIForm: TMNIForm; + +implementation +uses define_types, nifti_img,nifti_img_view; +{ TMNIForm } + +procedure TMNIForm.XEditChange(Sender: TObject); + var +lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if not MNIForm.visible then exit; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + lXmm:=XEdit.value; + lYmm:=YEdit.value; + lZmm:=ZEdit.value; + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + ImgForm.XViewEditChange(nil); +end; + +procedure TMNIForm.FormCreate(Sender: TObject); +begin + +end; + +initialization + {$I mni.lrs} + +end. + diff --git a/mricron.app/Contents/Info.plist b/mricron.app/Contents/Info.plist new file mode 100644 index 0000000..270fff7 --- /dev/null +++ b/mricron.app/Contents/Info.plist @@ -0,0 +1,45 @@ + + + + + CFBundleDevelopmentRegion + English + CFBundleExecutable + mricron + CFBundleName + MRIcron + CFBundleIdentifier + com.company.mricron + CFBundleInfoDictionaryVersion + 6.0 + CFBundlePackageType + APPL + CFBundleSignature + mric + CFBundleShortVersionString + 0.1 + CFBundleVersion + 1 + CSResourcesFileMapped + + CFBundleDocumentTypes + + + CFBundleTypeRole + Viewer + CFBundleTypeExtensions + + * + + CFBundleTypeOSTypes + + fold + disk + **** + + + + NSHighResolutionCapable + + + diff --git a/mricron.app/Contents/MacOS/mricron b/mricron.app/Contents/MacOS/mricron new file mode 120000 index 0000000..36c5b68 --- /dev/null +++ b/mricron.app/Contents/MacOS/mricron @@ -0,0 +1 @@ +../../../mricron \ No newline at end of file diff --git a/mricron.app/Contents/PkgInfo b/mricron.app/Contents/PkgInfo new file mode 100644 index 0000000..6f749b0 --- /dev/null +++ b/mricron.app/Contents/PkgInfo @@ -0,0 +1 @@ +APPL???? diff --git a/mricron.compiled b/mricron.compiled new file mode 100755 index 0000000..fa33ab8 --- /dev/null +++ b/mricron.compiled @@ -0,0 +1,5 @@ + + + + + diff --git a/mricron.ico b/mricron.ico new file mode 100755 index 0000000..14b256a Binary files /dev/null and b/mricron.ico differ diff --git a/mricron.ini b/mricron.ini new file mode 100755 index 0000000..63c025f --- /dev/null +++ b/mricron.ini @@ -0,0 +1,55 @@ +[MRU] +file1=C:\mricrogl\ch256.nii.gz +file0=C:\mricrogl\ch256.nii.gz +file2=C:\pas\mricron\templates\ch2bet.nii.gz +file3=C:\mricrogl\visiblehuman.nii.gz +file4= +file5= +file6= +file7= +file8= +file9= +file10= +file11= +file12= + +[STR] +FSLBASE=/usr/local/fsl +FSLOUTPUTTYPE=FSLOUTPUTTYPE=NIFTI_GZ + +[BOOL] +Reslice=0 +ResliceOrtho=1 +ShowDraw=1 +ThinPen=1 +Smooth2D=1 +XBar=1 +OverlaySmooth=0 +LRmirror=0 +Yoke=1 +SingleRow=1 +FlipAx=0 +FlipSag=0 + +[INT] +FontSize=12 +MaxDim=384 +LicenseID=0 +Zoom=4 +LUT=0 +XBarGap=7 +XBarThick=1 +XBarClr=16711808 +VOIClr=255 +BGTransPct=20 +OverlayTransPct=20 +MaxThreads=2 +LesionSmooth=3 +SigDigits=5 +ImageSeparation=0 +SPMDefaultsStatsFmriT=16 +SPMDefaultsStatsFmriT0=1 +LesionDilate=0 +SaveImgFilter=0 +SaveVoiFilter=0 +PlanarRGB=2 diff --git a/mricron.lpi b/mricron.lpi new file mode 100755 index 0000000..b956649 --- /dev/null +++ b/mricron.lpi @@ -0,0 +1,708 @@ + + + + + + + + + + + + <Icon Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="FCL"/> + <MinVersion Major="1" Valid="True"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="53"> + <Unit0> + <Filename Value="mricron.lpr"/> + <IsPartOfProject Value="True"/> + <WindowIndex Value="1"/> + <CursorPos X="129" Y="3"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit0> + <Unit1> + <Filename Value="nifti_hdr_view.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="HdrForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="5"/> + <WindowIndex Value="1"/> + <TopLine Value="150"/> + <CursorPos X="57" Y="165"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit1> + <Unit2> + <Filename Value="define_types.pas"/> + <TopLine Value="410"/> + <CursorPos X="23" Y="420"/> + <UsageCount Value="74"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit2> + <Unit3> + <Filename Value="about.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="AboutForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="19"/> + <CursorPos X="65" Y="40"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit3> + <Unit4> + <Filename Value="text.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="TextForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="36"/> + <CursorPos Y="61"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit4> + <Unit5> + <Filename Value="render.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="RenderForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="527"/> + <CursorPos X="76" Y="534"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit5> + <Unit6> + <Filename Value="ROIfilt.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="FilterROIform"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <CursorPos X="58" Y="13"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit6> + <Unit7> + <Filename Value="nifti_img_view.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ImgForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="1"/> + <WindowIndex Value="1"/> + <TopLine Value="569"/> + <CursorPos X="39" Y="584"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit7> + <Unit8> + <Filename Value="nifti_img.pas"/> + <EditorIndex Value="2"/> + <WindowIndex Value="1"/> + <TopLine Value="30"/> + <CursorPos X="20" Y="46"/> + <UsageCount Value="100"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit8> + <Unit9> + <Filename Value="cutout.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="CutoutForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="161"/> + <CursorPos X="29" Y="166"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit9> + <Unit10> + <Filename Value="MultiSlice.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MultiSliceForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="430"/> + <CursorPos X="28" Y="452"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit10> + <Unit11> + <Filename Value="autoroi.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="AutoROIForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="534"/> + <CursorPos X="68" Y="537"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit11> + <Unit12> + <Filename Value="spread.pas"/> + <ComponentName Value="SpreadForm"/> + <HasResources Value="True"/> + <TopLine Value="83"/> + <CursorPos X="47" Y="93"/> + <UsageCount Value="173"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit12> + <Unit13> + <Filename Value="design.pas"/> + <ComponentName Value="DesignForm"/> + <HasResources Value="True"/> + <CursorPos X="45" Y="167"/> + <UsageCount Value="173"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit13> + <Unit14> + <Filename Value="histoform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="HistogramForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="6"/> + <CursorPos X="105" Y="19"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit14> + <Unit15> + <Filename Value="logistic.pas"/> + <TopLine Value="1075"/> + <CursorPos Y="1100"/> + <UsageCount Value="3"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit15> + <Unit16> + <Filename Value="ReadInt.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ReadIntForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <WindowIndex Value="1"/> + <CursorPos X="77" Y="2"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit16> + <Unit17> + <Filename Value="nifti_hdr.pas"/> + <TopLine Value="172"/> + <CursorPos X="5" Y="188"/> + <UsageCount Value="66"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit17> + <Unit18> + <Filename Value="gzio2.pas"/> + <TopLine Value="278"/> + <CursorPos X="11" Y="282"/> + <UsageCount Value="18"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit18> + <Unit19> + <Filename Value="cropedges.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="CropEdgeForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="CropEdges"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="81"/> + <CursorPos X="3" Y="83"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit19> + <Unit20> + <Filename Value="bet.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="BETForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="6"/> + <WindowIndex Value="1"/> + <TopLine Value="65"/> + <CursorPos X="28" Y="95"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit20> + <Unit21> + <Filename Value="mni.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MNIForm"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="20"/> + <CursorPos X="3" Y="53"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit21> + <Unit22> + <Filename Value="ugraphics.pas"/> + <CursorPos X="15"/> + <UsageCount Value="66"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit22> + <Unit23> + <Filename Value="fx8.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="549"/> + <CursorPos X="24" Y="552"/> + <UsageCount Value="22"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit23> + <Unit24> + <Filename Value="voismooth.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="voismoothform"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="385"/> + <CursorPos X="36" Y="391"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit24> + <Unit25> + <Filename Value="prefs.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="PrefForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="3"/> + <WindowIndex Value="1"/> + <TopLine Value="46"/> + <CursorPos X="55" Y="77"/> + <UsageCount Value="200"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit25> + <Unit26> + <Filename Value="perisettings.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="PSForm"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="81"/> + <CursorPos X="38" Y="96"/> + <UsageCount Value="224"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit26> + <Unit27> + <Filename Value="graphx.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Graph4DForm"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="1043"/> + <CursorPos X="29" Y="1055"/> + <UsageCount Value="224"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit27> + <Unit28> + <Filename Value="render_composite.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="184"/> + <CursorPos X="80" Y="193"/> + <UsageCount Value="56"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit28> + <Unit29> + <Filename Value="ReadFloat.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ReadFloatForm"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="38"/> + <CursorPos X="38" Y="53"/> + <UsageCount Value="201"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit29> + <Unit30> + <Filename Value="common\nifti_hdr.pas"/> + <EditorIndex Value="7"/> + <WindowIndex Value="1"/> + <TopLine Value="639"/> + <CursorPos X="29" Y="645"/> + <UsageCount Value="59"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit30> + <Unit31> + <Filename Value="common\define_types.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="28"/> + <CursorPos X="69" Y="32"/> + <UsageCount Value="100"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit31> + <Unit32> + <Filename Value="common\dicomhdr.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="402"/> + <CursorPos X="26" Y="415"/> + <UsageCount Value="32"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit32> + <Unit33> + <Filename Value="landmarks.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="AnatForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="166"/> + <CursorPos X="50" Y="175"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit33> + <Unit34> + <Filename Value="batchstatselect.pas"/> + <IsPartOfProject Value="True"/> + <CursorPos X="43" Y="6"/> + <UsageCount Value="201"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit34> + <Unit35> + <Filename Value="otsu2.pas"/> + <IsPartOfProject Value="True"/> + <CursorPos X="13" Y="98"/> + <UsageCount Value="210"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit35> + <Unit36> + <Filename Value="fastsmooth.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="16"/> + <CursorPos X="17" Y="28"/> + <UsageCount Value="210"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit36> + <Unit37> + <Filename Value="common\gzio2.pas"/> + <TopLine Value="111"/> + <CursorPos X="81" Y="119"/> + <UsageCount Value="21"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit37> + <Unit38> + <Filename Value="nii_label.pas"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="122"/> + <CursorPos X="55" Y="128"/> + <UsageCount Value="200"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit38> + <Unit39> + <Filename Value="common\nifti_types.pas"/> + <EditorIndex Value="4"/> + <WindowIndex Value="1"/> + <TopLine Value="135"/> + <CursorPos X="67" Y="146"/> + <UsageCount Value="73"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit39> + <Unit40> + <Filename Value="common\nifti_foreign.pas"/> + <WindowIndex Value="1"/> + <TopLine Value="886"/> + <CursorPos X="7" Y="886"/> + <UsageCount Value="21"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit40> + <Unit41> + <Filename Value="C:\usr\local\share\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/> + <TopLine Value="157"/> + <CursorPos X="38" Y="170"/> + <UsageCount Value="6"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit41> + <Unit42> + <Filename Value="C:\Developer\lazarus\lcl\include\customform.inc"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="2527"/> + <CursorPos Y="2536"/> + <UsageCount Value="12"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit42> + <Unit43> + <Filename Value="C:\Developer\lazarus\components\lazutils\ttgload.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="119"/> + <CursorPos X="77" Y="125"/> + <UsageCount Value="2"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit43> + <Unit44> + <Filename Value="isthreaded.inc"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <CursorPos X="18" Y="17"/> + <UsageCount Value="56"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit44> + <Unit45> + <Filename Value="..\..\..\..\..\Developer\lazarus\lcl\interfaces\cocoa\cocoawsstdctrls.pp"/> + <UnitName Value="CocoaWSStdCtrls"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="256"/> + <CursorPos X="32" Y="272"/> + <UsageCount Value="55"/> + </Unit45> + <Unit46> + <Filename Value="..\..\..\..\..\Developer\lazarus\lcl\interfaces\cocoa\cocoaint.pas"/> + <UnitName Value="CocoaInt"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="165"/> + <CursorPos X="42" Y="176"/> + <UsageCount Value="55"/> + </Unit46> + <Unit47> + <Filename Value="..\..\..\Desktop\c4\unit1.pas"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <UsageCount Value="36"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit47> + <Unit48> + <Filename Value="..\..\..\..\..\Developer\lazarus\lcl\lclintf.pas"/> + <UnitName Value="LCLIntf"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="60"/> + <CursorPos X="10" Y="72"/> + <UsageCount Value="6"/> + </Unit48> + <Unit49> + <Filename Value="..\..\..\..\..\Developer\lazarus\lcl\interfaces\cocoa\cocoawsmenus.pas"/> + <UnitName Value="CocoaWSMenus"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="46"/> + <CursorPos X="20" Y="56"/> + <UsageCount Value="10"/> + </Unit49> + <Unit50> + <Filename Value="..\raycast\shaderu.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="113"/> + <CursorPos X="19" Y="127"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit50> + <Unit51> + <Filename Value="..\raycast\shaderui.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="277"/> + <CursorPos X="24" Y="300"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit51> + <Unit52> + <Filename Value="reslice_img.pas"/> + <EditorIndex Value="-1"/> + <WindowIndex Value="1"/> + <TopLine Value="329"/> + <CursorPos X="5" Y="333"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit52> + </Units> + <JumpHistory Count="23" HistoryIndex="22"> + <Position1> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="594" Column="71" TopLine="569"/> + </Position1> + <Position2> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="731" Column="80" TopLine="706"/> + </Position2> + <Position3> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="732" Column="52" TopLine="707"/> + </Position3> + <Position4> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="1754" Column="16" TopLine="1729"/> + </Position4> + <Position5> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="3157" Column="22" TopLine="3130"/> + </Position5> + <Position6> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="3134" Column="71" TopLine="3129"/> + </Position6> + <Position7> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="584" Column="55" TopLine="569"/> + </Position7> + <Position8> + <Filename Value="nifti_img.pas"/> + <Caret Line="46" Column="20" TopLine="30"/> + </Position8> + <Position9> + <Filename Value="nifti_img.pas"/> + <Caret Line="2432" Column="16" TopLine="2407"/> + </Position9> + <Position10> + <Filename Value="nifti_img.pas"/> + <Caret Line="34" Column="66" TopLine="30"/> + </Position10> + <Position11> + <Filename Value="nifti_img.pas"/> + <Caret Line="46" Column="20" TopLine="30"/> + </Position11> + <Position12> + <Filename Value="nifti_img.pas"/> + <Caret Line="2432" Column="16" TopLine="2407"/> + </Position12> + <Position13> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="572" Column="49" TopLine="569"/> + </Position13> + <Position14> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="584" Column="55" TopLine="569"/> + </Position14> + <Position15> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="716" Column="72" TopLine="691"/> + </Position15> + <Position16> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="584" Column="55" TopLine="569"/> + </Position16> + <Position17> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="716" Column="17" TopLine="691"/> + </Position17> + <Position18> + <Filename Value="bet.pas"/> + <Caret Line="56" Column="97" TopLine="51"/> + </Position18> + <Position19> + <Filename Value="bet.pas"/> + <Caret Line="69" Column="35" TopLine="51"/> + </Position19> + <Position20> + <Filename Value="bet.pas"/> + <Caret Line="70" Column="100" TopLine="51"/> + </Position20> + <Position21> + <Filename Value="bet.pas"/> + <Caret Line="72" Column="118" TopLine="51"/> + </Position21> + <Position22> + <Filename Value="bet.pas"/> + <Caret Line="81" Column="44" TopLine="51"/> + </Position22> + <Position23> + <Filename Value="nifti_img_view.pas"/> + <Caret Line="716" Column="73" TopLine="691"/> + </Position23> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="mricron"/> + </Target> + <SearchPaths> + <Libraries Value="rgb;fpmath"/> + <OtherUnitFiles Value="rgb;fpmath;common"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <SyntaxMode Value="Delphi"/> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <SmartLinkUnit Value="True"/> + <Optimizations> + <OptimizationLevel Value="2"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <WriteFPCLogo Value="False"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="2"> + <Item1> + <Name Value="ECodetoolError"/> + </Item1> + <Item2> + <Name Value="EFOpenError"/> + </Item2> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/mricron.lpr b/mricron.lpr new file mode 100755 index 0000000..d67beed --- /dev/null +++ b/mricron.lpr @@ -0,0 +1,55 @@ +program mricron; + +{$mode objfpc}{$H+} +uses + {$IFDEF UNIX} + cthreads, + {$ENDIF} + Interfaces, + Forms, nifti_img_view, nifti_hdr_view, + about, Text, ReadInt, histoform, autoroi, ROIfilt, render, + MultiSlice, CropEdges, bet, mni, + voismooth, prefs, perisettings, graphx, cutout, ReadFloat, landmarks, +batchstatselect, nii_label; +{$IFNDEF UNIX} + {$IFDEF FPC} + {$R manifest.res} +{$ELSE} + {$R *.res}//windows icon + {$ENDIF} +{$ELSE} + {$R *.res} +{$ENDIF} + + + +{$IFDEF WINDOWS}{$R mricron.rc}{$ENDIF} + +begin + Application.Title:='MRIcron'; + //Application.Title:='MRIcron'; + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TImgForm, ImgForm); + Application.CreateForm(THdrForm, HdrForm); + Application.CreateForm(TAnatForm, AnatForm); + Application.CreateForm(TAboutForm, AboutForm); + Application.CreateForm(TTextForm, TextForm); + Application.CreateForm(TReadIntForm, ReadIntForm); + Application.CreateForm(TAutoROIForm, AutoROIForm); + Application.CreateForm(THistogramForm, HistogramForm); + Application.CreateForm(TFilterROIform, FilterROIform); + Application.CreateForm(TMultiSliceForm, MultiSliceForm); + Application.CreateForm(TRenderForm, RenderForm); + Application.CreateForm(TCropEdgeForm, CropEdgeForm); + Application.CreateForm(TBETForm, BETForm); + Application.CreateForm(TMNIForm, MNIForm); + Application.CreateForm(Tvoismoothform, voismoothform); + Application.CreateForm(TPrefForm, PrefForm); + Application.CreateForm(TPSForm, PSForm); + Application.CreateForm(TGraph4DForm, Graph4DForm); + Application.CreateForm(TCutoutForm, CutoutForm); + Application.CreateForm(TReadFloatForm, ReadFloatForm); + Application.Run; +end. + diff --git a/mricron.or b/mricron.or new file mode 100755 index 0000000..a1359d5 Binary files /dev/null and b/mricron.or differ diff --git a/mricron.rc b/mricron.rc new file mode 100755 index 0000000..dbf5b64 --- /dev/null +++ b/mricron.rc @@ -0,0 +1 @@ +MAINICON ICON "mricron.ico" diff --git a/mricron.res b/mricron.res new file mode 100755 index 0000000..d9c8b12 Binary files /dev/null and b/mricron.res differ diff --git a/mricron.svg b/mricron.svg new file mode 100755 index 0000000..9cafd4e --- /dev/null +++ b/mricron.svg @@ -0,0 +1,385 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> + +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:xlink="http://www.w3.org/1999/xlink" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + width="48" + height="48" + id="svg7854" + sodipodi:version="0.32" + inkscape:version="0.91 r13725" + version="1.0" + sodipodi:docname="mricron.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape" + sodipodi:modified="true"> + <defs + id="defs7856"> + <linearGradient + inkscape:collect="always" + id="linearGradient4394"> + <stop + style="stop-color:#000000;stop-opacity:0.435" + offset="0" + id="stop4396" /> + <stop + style="stop-color:#000000;stop-opacity:0;" + offset="1" + id="stop4398" /> + </linearGradient> + <linearGradient + inkscape:collect="always" + id="linearGradient4354"> + <stop + style="stop-color:#ffffff;stop-opacity:1;" + offset="0" + id="stop4356" /> + <stop + style="stop-color:#ffffff;stop-opacity:0;" + offset="1" + id="stop4358" /> + </linearGradient> + <linearGradient + id="linearGradient5656"> + <stop + style="stop-color:#4e83c7;stop-opacity:1;" + offset="0" + id="stop5658" /> + <stop + id="stop5665" + offset="0.24324325" + style="stop-color:#4573a9;stop-opacity:1;" /> + <stop + style="stop-color:#729fcf;stop-opacity:1" + offset="1" + id="stop5660" /> + </linearGradient> + <linearGradient + id="linearGradient5785"> + <stop + style="stop-color:#f1f1f0;stop-opacity:1;" + offset="0" + id="stop5787" /> + <stop + style="stop-color:#555753;stop-opacity:1;" + offset="1" + id="stop5789" /> + </linearGradient> + <linearGradient + id="linearGradient5737"> + <stop + style="stop-color:#babdb6;stop-opacity:1;" + offset="0" + id="stop5739" /> + <stop + style="stop-color:#dddedb;stop-opacity:1;" + offset="1" + id="stop5741" /> + </linearGradient> + <linearGradient + id="linearGradient5660"> + <stop + style="stop-color:#cbcbcb;stop-opacity:1;" + offset="0" + id="stop5662" /> + <stop + style="stop-color:#9f9f9f;stop-opacity:1;" + offset="1" + id="stop5664" /> + </linearGradient> + <linearGradient + id="linearGradient5633"> + <stop + style="stop-color:#f8f8f8;stop-opacity:1;" + offset="0" + id="stop5635" /> + <stop + style="stop-color:#c7c7c1;stop-opacity:1;" + offset="1" + id="stop5637" /> + </linearGradient> + <linearGradient + id="linearGradient5611"> + <stop + style="stop-color:#5e5e5e;stop-opacity:1;" + offset="0" + id="stop5613" /> + <stop + style="stop-color:#929292;stop-opacity:1;" + offset="1" + id="stop5615" /> + </linearGradient> + <linearGradient + id="linearGradient6842"> + <stop + style="stop-color:#d8d9d7;stop-opacity:1;" + offset="0" + id="stop6844" /> + <stop + style="stop-color:#7c7f79;stop-opacity:1;" + offset="1" + id="stop6846" /> + </linearGradient> + <linearGradient + id="linearGradient6832"> + <stop + style="stop-color:#555753;stop-opacity:1;" + offset="0" + id="stop6834" /> + <stop + style="stop-color:#838680;stop-opacity:1;" + offset="1" + id="stop6836" /> + </linearGradient> + <linearGradient + id="linearGradient5048"> + <stop + style="stop-color:black;stop-opacity:0;" + offset="0" + id="stop5050" /> + <stop + id="stop5056" + offset="0.5" + style="stop-color:black;stop-opacity:1;" /> + <stop + style="stop-color:black;stop-opacity:0;" + offset="1" + id="stop5052" /> + </linearGradient> + <linearGradient + id="linearGradient5534"> + <stop + style="stop-color:#888a85;stop-opacity:1;" + offset="0" + id="stop5536" /> + <stop + style="stop-color:#6b6d68;stop-opacity:1;" + offset="1" + id="stop5538" /> + </linearGradient> + <linearGradient + id="linearGradient5491"> + <stop + style="stop-color:#959792;stop-opacity:1;" + offset="0" + id="stop5493" /> + <stop + id="stop5501" + offset="0.25" + style="stop-color:#838681;stop-opacity:1;" /> + <stop + id="stop5499" + offset="0.62437075" + style="stop-color:#abaca9;stop-opacity:1;" /> + <stop + style="stop-color:#ffffff;stop-opacity:1;" + offset="0.79695714" + id="stop5771" /> + <stop + style="stop-color:#90928d;stop-opacity:1;" + offset="1" + id="stop5495" /> + </linearGradient> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient4354" + id="linearGradient4362" + x1="2.409353" + y1="41.205883" + x2="14.761571" + y2="52.297657" + gradientUnits="userSpaceOnUse" + gradientTransform="translate(1.0733974,-30.532195)" /> + <filter + inkscape:collect="always" + style="color-interpolation-filters:sRGB" + id="filter4384" + x="-0.031723187" + width="1.0634464" + y="-0.033106322" + height="1.0662126"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="0.25338816" + id="feGaussianBlur4386" /> + </filter> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient4354" + id="linearGradient4390" + gradientUnits="userSpaceOnUse" + gradientTransform="translate(24.449609,-28.027601)" + x1="0.50109082" + y1="39.416885" + x2="14.761571" + y2="52.297657" /> + <linearGradient + inkscape:collect="always" + xlink:href="#linearGradient4394" + id="linearGradient4400" + x1="20.166977" + y1="39.440014" + x2="21.908278" + y2="31.926226" + gradientUnits="userSpaceOnUse" /> + <filter + inkscape:collect="always" + style="color-interpolation-filters:sRGB" + id="filter4426" + x="-0.023200853" + width="1.0464017" + y="-0.093794747" + height="1.1875895"> + <feGaussianBlur + inkscape:collect="always" + stdDeviation="0.32121219" + id="feGaussianBlur4428" /> + </filter> + </defs> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#e0e0e0" + borderopacity="1" + gridtolerance="10000" + guidetolerance="10" + objecttolerance="10" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="18.940727" + inkscape:cx="16.316749" + inkscape:cy="23.750033" + inkscape:document-units="px" + inkscape:current-layer="layer1" + width="48px" + height="48px" + inkscape:showpageshadow="false" + inkscape:window-width="1315" + inkscape:window-height="855" + inkscape:window-x="51" + inkscape:window-y="0" + showgrid="false" + inkscape:window-maximized="0" /> + <metadata + id="metadata7859"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + <dc:creator> + <cc:Agent> + <dc:title>Jakub Steiner</dc:title> + </cc:Agent> + </dc:creator> + <dc:source>http://jimmac.musichall.cz</dc:source> + <cc:license + rdf:resource="http://creativecommons.org/licenses/GPL/2.0/" /> + <dc:title /> + <dc:subject> + <rdf:Bag> + <rdf:li>file</rdf:li> + <rdf:li>roller</rdf:li> + <rdf:li>compressed</rdf:li> + <rdf:li>handler</rdf:li> + <rdf:li>unzip</rdf:li> + <rdf:li>tar</rdf:li> + <rdf:li>archive</rdf:li> + <rdf:li>extract</rdf:li> + <rdf:li>compress</rdf:li> + </rdf:Bag> + </dc:subject> + </cc:Work> + <cc:License + rdf:about="http://creativecommons.org/licenses/GPL/2.0/"> + <cc:permits + rdf:resource="http://web.resource.org/cc/Reproduction" /> + <cc:permits + rdf:resource="http://web.resource.org/cc/Distribution" /> + <cc:requires + rdf:resource="http://web.resource.org/cc/Notice" /> + <cc:permits + rdf:resource="http://web.resource.org/cc/DerivativeWorks" /> + <cc:requires + rdf:resource="http://web.resource.org/cc/ShareAlike" /> + <cc:requires + rdf:resource="http://web.resource.org/cc/SourceCode" /> + </cc:License> + </rdf:RDF> + </metadata> + <g + inkscape:label="Layer 1" + inkscape:groupmode="layer" + id="layer1"> + <path + style="fill:#00ff00;fill-rule:evenodd;stroke:none;stroke-width:0.1;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 19.36248,27.78998 C 16.04189,31.427681 5.2246074,35.713102 1.1712911,29.772202 -2.8820251,23.831303 14.213173,4.7794813 20.608451,7.5547859 27.003729,10.330091 22.683069,24.152279 19.36248,27.78998 Z" + id="path4290" + inkscape:connector-curvature="0" + sodipodi:nodetypes="zzzz" /> + <path + sodipodi:nodetypes="zzzz" + inkscape:connector-curvature="0" + id="path4292" + d="M 22.747548,31.589241 C 29.972181,33.244719 44.693509,37.943103 47.08553,29.607017 49.477551,21.270931 37.20011,7.5050377 26.236269,7.307008 15.272427,7.1089783 15.522914,29.933763 22.747548,31.589241 Z" + style="fill:#0000ff;fill-rule:evenodd;stroke:none;stroke-width:0.1;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" /> + <path + style="fill:#ff0000;fill-rule:evenodd;stroke:none;stroke-width:0.1;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 34.97866,39.022578 C 31.737081,42.893297 25.277632,37.8873 17.924041,36.605939 10.57045,35.324579 3.1106701,37.572879 2.2511337,32.415167 1.3915973,27.257454 11.970424,22.702081 23.764914,25.890349 35.559402,29.078617 38.22024,35.151859 34.97866,39.022578 Z" + id="path4294" + inkscape:connector-curvature="0" + sodipodi:nodetypes="zszzz" /> + <path + inkscape:connector-curvature="0" + style="fill:#ffff00;fill-rule:evenodd;stroke:#ffff00;stroke-width:0.15;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="M 15.305878,24.83951 C 8.3585391,24.995756 3.0516554,27.738135 2.2976218,31.023573 6.9475777,35.010171 16.313899,31.129349 19.363023,27.789038 19.90089,27.199806 20.461487,26.324358 21.00204,25.290929 19.028892,24.947315 17.10958,24.798944 15.305878,24.83951 Z" + id="path4303" /> + <path + inkscape:connector-curvature="0" + style="fill:#00ffff;fill-rule:evenodd;stroke:#00ffff;stroke-width:0.15;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="m 22.112032,8.5884096 c -4.946279,3.5926764 -5.583249,13.8962914 -3.004865,19.4492924 0.08246,-0.08267 0.18088,-0.166528 0.255856,-0.248664 3.014611,-3.302502 6.85242,-14.996466 2.749009,-19.2006284 z" + id="path4315" /> + <path + inkscape:connector-curvature="0" + style="fill:#ff00ff;fill-rule:evenodd;stroke:#ff00ff;stroke-width:0.15;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="m 18.095285,24.931324 c 0.743729,3.42171 2.337518,6.128185 4.651578,6.658437 3.44274,0.788881 8.583211,2.254445 13.285273,2.685562 -0.885201,-3.085966 -4.675991,-6.333532 -12.26762,-8.38569 -1.940466,-0.524543 -3.840101,-0.821171 -5.669231,-0.958309 z" + id="path4341" /> + <path + inkscape:connector-curvature="0" + style="fill:#ffffff;fill-rule:evenodd;stroke:#ffffff;stroke-width:0.2;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" + d="m 18.095285,24.931324 c 0.245994,1.131755 0.583892,2.184627 1.011882,3.106378 0.08246,-0.08267 0.18088,-0.166528 0.255856,-0.248664 0.537867,-0.589232 1.098464,-1.46468 1.639017,-2.498109 -0.98686,-0.171857 -1.955889,-0.288314 -2.906755,-0.359605 z" + id="path4327" /> + <path + style="opacity:0.88599997;fill:url(#linearGradient4362);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:0.1;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter4384)" + d="M 1.9082621,26.054985 C -0.31628501,26.289148 5.1236978,17.822924 7.8715814,14.486145 11.947737,11.208801 18.055536,5.7286299 20.275286,8.4035599 22.495036,11.07849 10.922118,12.492958 8.348647,15.678809 5.2956305,18.802337 4.1328094,25.820822 1.9082621,26.054985 Z" + id="path4352" + inkscape:connector-curvature="0" + sodipodi:nodetypes="zczcz" + transform="matrix(0.98494932,0,0,0.97935065,0.00838411,0.85115692)" /> + <path + sodipodi:nodetypes="zczcz" + inkscape:connector-curvature="0" + id="path4388" + d="m 23.853277,29.990776 c -4.967674,-1.3163 2.857637,-10.736655 5.60552,-14.073434 4.076156,-3.277344 14.477545,-7.8033844 17.53216,-4.055057 3.054615,3.748328 -12.692627,3.135267 -15.266098,6.321118 -3.053017,3.123528 -2.903908,13.123673 -7.871582,11.807373 z" + style="opacity:0.88599997;fill:url(#linearGradient4390);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:0.1;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter4384)" + transform="matrix(-0.98494932,0,0,0.97935065,68.37471,-2.1857371)" /> + <path + sodipodi:nodetypes="csccc" + inkscape:connector-curvature="0" + id="path4392" + d="M 35.504645,38.976255 C 32.213532,42.928587 25.655379,37.81704 18.18942,36.508662 10.723461,35.200285 3.149691,37.49599 2.2770203,32.229529 c 6.2833125,2.60512 4.7393531,-1.092171 16.7140697,2.163321 11.974716,3.255492 14.318414,1.346671 16.513555,4.583405 z" + style="fill:url(#linearGradient4400);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:0.1;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;filter:url(#filter4426)" + transform="matrix(0.98494932,0,0,0.97935065,0.00838411,0.85115692)" /> + </g> + <g + inkscape:groupmode="layer" + id="layer2" + inkscape:label="Layer 2" /> +</svg> diff --git a/multislice/default.ini b/multislice/default.ini new file mode 100755 index 0000000..ca065c1 --- /dev/null +++ b/multislice/default.ini @@ -0,0 +1,10 @@ +[STR] +Slices=24,28,62,82,92,102 + +[BOOL] +OrthoView=1 +SliceLabel=1 + +[INT] +Orient=3 +OverslicePct=0 diff --git a/neurodebian.txt b/neurodebian.txt new file mode 100755 index 0000000..5be8bf0 --- /dev/null +++ b/neurodebian.txt @@ -0,0 +1,2 @@ +This project is described by BSD license - please see the file license.txt. This was written by Chris Rorden, with the exceptions of DiskSpaceKludge and GraphicsMathLibrary: The author of those units gave written permission to distribute this file under the same licensing terms as MRICRON. + diff --git a/nifti_hdr_view.lfm b/nifti_hdr_view.lfm new file mode 100755 index 0000000..c80b3b6 --- /dev/null +++ b/nifti_hdr_view.lfm @@ -0,0 +1,1410 @@ +object HdrForm: THdrForm + Left = 607 + Height = 383 + Top = 155 + Width = 560 + ActiveControl = PageControl1 + Caption = 'NIfTI Header Information' + ClientHeight = 383 + ClientWidth = 560 + Menu = MainMenu1 + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object PageControl1: TPageControl + Left = 4 + Height = 360 + Top = 4 + Width = 552 + ActivePage = TabRequired + Align = alClient + BorderSpacing.Left = 2 + BorderSpacing.Top = 2 + BorderSpacing.Right = 2 + BorderSpacing.Bottom = 2 + BorderSpacing.Around = 2 + TabIndex = 0 + TabOrder = 0 + OnChange = PageControl1Change + object TabRequired: TTabSheet + Caption = 'Dimensions' + ClientHeight = 321 + ClientWidth = 546 + OnContextPopup = TabRequiredContextPopup + object Label21: TLabel + Left = 6 + Height = 16 + Top = 6 + Width = 79 + Caption = 'Header Type' + ParentColor = False + end + object Label1: TLabel + Left = 14 + Height = 16 + Top = 35 + Width = 268 + Caption = 'Dimension Length Spacing Unit' + ParentColor = False + end + object Label2: TLabel + Left = 16 + Height = 16 + Top = 67 + Width = 44 + Caption = 'I Space' + ParentColor = False + end + object Label3: TLabel + Left = 16 + Height = 16 + Top = 97 + Width = 44 + Caption = 'J Space' + ParentColor = False + end + object Label4: TLabel + Left = 16 + Height = 16 + Top = 131 + Width = 49 + Caption = 'K Space' + ParentColor = False + end + object Label8: TLabel + Left = 6 + Height = 16 + Top = 297 + Width = 29 + Caption = 'Data' + ParentColor = False + end + object Label7: TLabel + Left = 294 + Height = 16 + Top = 235 + Width = 38 + Caption = 'Offset' + ParentColor = False + end + object Label44: TLabel + Left = 16 + Height = 16 + Top = 166 + Width = 31 + Caption = 'Time' + ParentColor = False + end + object Label29: TLabel + Left = 16 + Height = 16 + Top = 198 + Width = 51 + Caption = '5th Dim' + ParentColor = False + end + object Label41: TLabel + Left = 16 + Height = 16 + Top = 230 + Width = 51 + Caption = '6th Dim' + ParentColor = False + end + object Label42: TLabel + Left = 16 + Height = 16 + Top = 265 + Width = 51 + Caption = '7th Dim' + ParentColor = False + end + object HeaderMagicDrop: TComboBox + Left = 108 + Height = 20 + Top = 2 + Width = 239 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'ni1: NIfTI separate file (hdr+.img)' + 'n+1: NIfTI embedded (.nii)' + 'ni2: NIfTI2 separate file (hdr+.img)' + 'n+2: NIfTI2 embedded (.nii)' + ) + OnSelect = HeaderMagicDropSelect + Style = csDropDownList + TabOrder = 15 + end + object Endian: TComboBox + Left = 231 + Height = 20 + Top = 291 + Width = 210 + ItemHeight = 0 + Items.Strings = ( + 'Native Endian' + 'Swapped Endian' + ) + Style = csDropDownList + TabOrder = 16 + end + object fTypeDrop: TComboBox + Left = 56 + Height = 20 + Top = 291 + Width = 152 + DropDownCount = 20 + ItemHeight = 0 + Items.Strings = ( + 'binary' + '8-bit S' + '8-bit int U*' + '16-bit int S*' + '16-bit int U' + '32-bit int S*' + '32-bit int U' + '64-bit int S' + '64-bit int U' + '32-bit real*' + '64-bit real*' + '128-bit real' + '24-bit rgb' + '64-bit com' + '128-bit complex' + '256-bit complex' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 17 + end + object xyzt_sizeDrop: TComboBox + Left = 262 + Height = 20 + Top = 87 + Width = 128 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'Meter' + 'Millimeter' + 'Micrometer' + 'Micron' + ) + Style = csDropDownList + TabOrder = 18 + end + object xyzt_timeDrop: TComboBox + Left = 262 + Height = 20 + Top = 157 + Width = 128 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'Second' + 'Millisecond' + 'Microsecond' + 'Hertzsecond' + 'Part ' + 'Part per million' + ) + Style = csDropDownList + TabOrder = 19 + end + object Xdim: TSpinEdit + Left = 80 + Height = 16 + Top = 59 + Width = 74 + MaxValue = 9999 + MinValue = 1 + OnExit = ImageSzChange + TabOrder = 0 + Value = 2 + end + object Ydim: TSpinEdit + Left = 80 + Height = 16 + Top = 89 + Width = 74 + MaxValue = 9999 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 1 + Value = 2 + end + object Zdim: TSpinEdit + Left = 80 + Height = 16 + Top = 123 + Width = 74 + MaxValue = 9999 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 2 + Value = 1 + end + object Xmm: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 59 + Width = 74 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 10 + Value = 0 + end + object Ymm: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 89 + Width = 74 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 11 + Value = 0 + end + object Zmm: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 123 + Width = 74 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 12 + Value = 0 + end + object OffsetEdit: TSpinEdit + Left = 342 + Height = 16 + Top = 230 + Width = 94 + MaxValue = 999999 + OnExit = ImageSzChange + TabOrder = 14 + Value = 1 + end + object TDim: TSpinEdit + Left = 80 + Height = 16 + Top = 157 + Width = 74 + MaxValue = 9999 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 3 + Value = 1 + end + object TSec: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 157 + Width = 74 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 13 + Value = 0 + end + object Dim5Edit: TSpinEdit + Left = 80 + Height = 16 + Top = 191 + Width = 74 + MaxValue = 35000 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 4 + Value = 1 + end + object Dim6Edit: TSpinEdit + Left = 80 + Height = 16 + Top = 223 + Width = 74 + MaxValue = 35000 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 5 + Value = 1 + end + object Dim7Edit: TSpinEdit + Left = 80 + Height = 16 + Top = 258 + Width = 74 + MaxValue = 35000 + MinValue = 1 + OnChange = ImageSzChange + OnExit = ImageSzChange + TabOrder = 9 + Value = 1 + end + object PixDim5: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 191 + Width = 74 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 6 + Value = 0 + end + object PixDim6: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 223 + Width = 74 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 7 + Value = 0 + end + object PixDim7: TFloatSpinEdit + Left = 164 + Height = 16 + Top = 258 + Width = 74 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 8 + Value = 0 + end + end + object TabSheet4: TTabSheet + Caption = 'Reorient' + ClientHeight = 329 + ClientWidth = 528 + object Label24: TLabel + Left = 10 + Height = 18 + Top = 184 + Width = 9 + Caption = 'X' + ParentColor = False + end + object Label36: TLabel + Left = 10 + Height = 18 + Top = 218 + Width = 9 + Caption = 'Y' + ParentColor = False + end + object Label37: TLabel + Left = 10 + Height = 18 + Top = 251 + Width = 8 + Caption = 'Z' + ParentColor = False + end + object Label39: TLabel + Left = 10 + Height = 18 + Top = 123 + Width = 61 + Caption = 'Q Offsets' + ParentColor = False + end + object Label40: TLabel + Left = 10 + Height = 18 + Top = 86 + Width = 76 + Caption = 'Quaternions' + ParentColor = False + end + object Label46: TLabel + Left = 10 + Height = 18 + Top = 46 + Width = 109 + Caption = 'qFactor [1 or -1]' + ParentColor = False + end + object Label38: TLabel + Left = 4 + Height = 18 + Top = 9 + Width = 150 + Caption = 'Quaternion parameters ' + ParentColor = False + end + object Label47: TLabel + Left = 4 + Height = 18 + Top = 157 + Width = 118 + Caption = 'Affine parameters ' + ParentColor = False + end + object QFormDrop: TComboBox + Left = 150 + Height = 20 + Top = 5 + Width = 260 + ItemHeight = 0 + Items.Strings = ( + 'None' + 'Scanner Position' + 'Coregistrationon' + 'Normalized Tal' + 'Normalzied mni152ach' + 'Normalzied mni152' + ) + OnSelect = HeaderMagicDropSelect + Style = csDropDownList + TabOrder = 19 + end + object SFormDrop: TComboBox + Left = 145 + Height = 20 + Top = 150 + Width = 204 + ItemHeight = 0 + Items.Strings = ( + 'None' + 'Scanner Position' + 'Coregistrationon' + 'Normalized Tal' + 'Normalzied mni152ach' + 'Normalzied mni152' + ) + OnSelect = HeaderMagicDropSelect + Style = csDropDownList + TabOrder = 20 + end + object srow_x0Edit: TFloatSpinEdit + Left = 34 + Height = 16 + Top = 188 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 7 + Value = 1 + end + object srow_x1Edit: TFloatSpinEdit + Left = 142 + Height = 16 + Top = 188 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 8 + Value = 1 + end + object srow_x2Edit: TFloatSpinEdit + Left = 254 + Height = 16 + Top = 188 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 9 + Value = 1 + end + object srow_y0Edit: TFloatSpinEdit + Left = 34 + Height = 16 + Top = 222 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 11 + Value = 1 + end + object srow_y1Edit: TFloatSpinEdit + Left = 142 + Height = 16 + Top = 222 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 12 + Value = 1 + end + object srow_y2Edit: TFloatSpinEdit + Left = 254 + Height = 16 + Top = 222 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 13 + Value = 1 + end + object srow_z0Edit: TFloatSpinEdit + Left = 34 + Height = 16 + Top = 255 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 15 + Value = 1 + end + object srow_z1Edit: TFloatSpinEdit + Left = 142 + Height = 16 + Top = 255 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 16 + Value = 1 + end + object srow_z2Edit: TFloatSpinEdit + Left = 254 + Height = 16 + Top = 255 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 17 + Value = 1 + end + object srow_x3Edit: TFloatSpinEdit + Left = 366 + Height = 16 + Top = 188 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 10 + Value = 1 + end + object srow_y3Edit: TFloatSpinEdit + Left = 366 + Height = 16 + Top = 222 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 14 + Value = 1 + end + object srow_z3Edit: TFloatSpinEdit + Left = 366 + Height = 16 + Top = 255 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 9999 + MinValue = -9999 + TabOrder = 18 + Value = 1 + end + object quatern_bEdit: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 84 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 1 + Value = 1 + end + object quatern_cEdit: TFloatSpinEdit + Left = 212 + Height = 16 + Top = 84 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 2 + Value = 1 + end + object quatern_dEdit: TFloatSpinEdit + Left = 332 + Height = 16 + Top = 84 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 3 + Value = 1 + end + object qoffset_xEdit: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 117 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 4 + Value = 1 + end + object qoffset_yEdit: TFloatSpinEdit + Left = 212 + Height = 16 + Top = 117 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 5 + Value = 1 + end + object qoffset_zEdit: TFloatSpinEdit + Left = 332 + Height = 16 + Top = 117 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 6 + Value = 1 + end + object QFacEdit: TFloatSpinEdit + Left = 140 + Height = 16 + Top = 46 + Width = 100 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 1 + MinValue = -1 + TabOrder = 0 + Value = 1 + end + end + object TabSheet3: TTabSheet + Caption = 'Image Intensity' + ClientHeight = 321 + ClientWidth = 546 + object Label12: TLabel + Left = 24 + Height = 16 + Top = 163 + Width = 62 + Caption = 'Maximum' + ParentColor = False + end + object Label13: TLabel + Left = 24 + Height = 16 + Top = 129 + Width = 59 + Caption = 'Minimum' + ParentColor = False + end + object Label23: TLabel + Left = 24 + Height = 16 + Top = 28 + Width = 34 + Caption = 'Slope' + ParentColor = False + end + object Label22: TLabel + Left = 24 + Height = 16 + Top = 64 + Width = 56 + Caption = 'Intercept' + ParentColor = False + end + object Label30: TLabel + Left = 6 + Height = 16 + Top = 4 + Width = 118 + Caption = 'Calibration Scaling' + ParentColor = False + end + object Label33: TLabel + Left = 6 + Height = 16 + Top = 103 + Width = 199 + Caption = 'Display Range (calibrated units)' + ParentColor = False + end + object cmax: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 165 + Width = 110 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 3 + Value = 0 + end + object cmin: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 129 + Width = 110 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 2 + Value = 0 + end + object Scale: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 28 + Width = 110 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 0 + Value = 0 + end + object Intercept: TFloatSpinEdit + Left = 94 + Height = 16 + Top = 64 + Width = 110 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 1 + Value = 0 + end + end + object TabSheet1: TTabSheet + Caption = 'Statistics' + ClientHeight = 321 + ClientWidth = 546 + object Label35: TLabel + Left = 8 + Height = 16 + Top = 14 + Width = 57 + Caption = 'Intention' + ParentColor = False + end + object Label25: TLabel + Left = 24 + Height = 16 + Top = 46 + Width = 76 + Caption = 'Parameter 1' + ParentColor = False + end + object Label27: TLabel + Left = 24 + Height = 16 + Top = 83 + Width = 76 + Caption = 'Parameter 2' + ParentColor = False + end + object Label28: TLabel + Left = 24 + Height = 16 + Top = 118 + Width = 76 + Caption = 'Parameter 3' + ParentColor = False + end + object IntentCodeDrop: TComboBox + Left = 76 + Height = 20 + Top = 8 + Width = 218 + DropDownCount = 44 + ItemHeight = 0 + Items.Strings = ( + 'Not statistics' + 'Correlation coefficient ' + 'T-testation coefficient ' + 'F-test' + 'Z-score' + 'Chi-squared' + 'Beta distribution' + 'Binomial distribution' + 'Gamma distribution' + 'Poisson distribution' + 'Normal distribution' + 'Noncentral F statistic' + 'Noncentral chi-squared' + 'Logistic distributiond statistic' + 'Laplace distribution' + 'Uniform distribution' + 'Noncentral t statistic' + 'Weibull distribution' + 'Chi distribution' + 'Inverse Gaussian ' + 'Extreme value type I' + 'p-value value type I' + 'ln(p-value)' + 'log10(p-value)' + 'Estimate' + 'Labels' + 'NeuroN' + 'Generic M' + 'Symmetric Matrix' + 'Displacement Field/Vector' + 'Vectorcement Field/Vector' + 'Points' + 'Triangle (mesh)' + 'Quaternion' + '' + '' + '' + ) + Style = csDropDownList + TabOrder = 3 + end + object intent_p1Edit: TFloatSpinEdit + Left = 110 + Height = 16 + Top = 46 + Width = 138 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 0 + Value = 0 + end + object intent_p2Edit: TFloatSpinEdit + Left = 110 + Height = 16 + Top = 83 + Width = 138 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 1 + Value = 0 + end + object intent_p3Edit: TFloatSpinEdit + Left = 110 + Height = 16 + Top = 119 + Width = 138 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 99999999 + MinValue = -99999999 + TabOrder = 2 + Value = 0 + end + object EcodeLabel: TLabel + Left = 8 + Height = 16 + Top = 144 + Width = 72 + Caption = 'ECode Text' + ParentColor = False + end + object EcodeMemo: TMemo + Left = 0 + Height = 194 + Top = 127 + Width = 546 + Align = alBottom + ScrollBars = ssVertical + TabOrder = 4 + end + object NoECodeLabel: TLabel + Left = 24 + Height = 16 + Top = 192 + Width = 158 + Caption = 'No ECode Text In Header' + ParentColor = False + end + end + object TabSheet2: TTabSheet + Caption = 'fMRI' + ClientHeight = 356 + ClientWidth = 528 + object Label11: TLabel + Left = 12 + Height = 17 + Top = 145 + Width = 68 + Caption = 'Slice Order' + ParentColor = False + end + object Label16: TLabel + Left = 12 + Height = 17 + Top = 8 + Width = 74 + Caption = 'Time Offset' + ParentColor = False + end + object Label17: TLabel + Left = 14 + Height = 17 + Top = 39 + Width = 85 + Caption = 'Slice duration' + ParentColor = False + end + object Label32: TLabel + Left = 12 + Height = 17 + Top = 74 + Width = 65 + Caption = 'Slice Start' + ParentColor = False + end + object Label20: TLabel + Left = 12 + Height = 17 + Top = 105 + Width = 56 + Caption = 'Slice End' + ParentColor = False + end + object Label31: TLabel + Left = 12 + Height = 17 + Top = 178 + Width = 133 + Caption = 'Frequency Dimension' + ParentColor = False + end + object Label43: TLabel + Left = 12 + Height = 17 + Top = 214 + Width = 105 + Caption = 'Phase Dimension' + ParentColor = False + end + object Label45: TLabel + Left = 12 + Height = 17 + Top = 250 + Width = 97 + Caption = 'Slice Dimension' + ParentColor = False + end + object SliceCodeDrop: TComboBox + Left = 87 + Height = 20 + Top = 137 + Width = 274 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'Sequential Increasing (1 2 3 4)' + 'Sequential Decreasing (4 3 2 1)' + 'Interleaved Increasing (1 3 2 4)' + 'Interleaved Decreasing (4 2 3 1)' + 'Interleaved Increasing2 (2 4 1 3)' + 'Interleaved Decreasing2 (3 1 4 2)' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 4 + end + object FreqDimDrop: TComboBox + Left = 146 + Height = 20 + Top = 174 + Width = 215 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'I' + 'J' + 'K' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 5 + end + object PhaseDimDrop: TComboBox + Left = 146 + Height = 20 + Top = 210 + Width = 215 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'I' + 'J' + 'K' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 6 + end + object SliceDimDrop: TComboBox + Left = 146 + Height = 20 + Top = 246 + Width = 215 + ItemHeight = 0 + Items.Strings = ( + 'Unknown' + 'I' + 'J' + 'K' + ) + OnSelect = ImageSzChange + Style = csDropDownList + TabOrder = 7 + end + object slice_startEdit: TSpinEdit + Left = 120 + Height = 16 + Top = 73 + Width = 112 + TabOrder = 2 + Value = 1 + end + object Slice_durationEdit: TFloatSpinEdit + Left = 120 + Height = 16 + Top = 38 + Width = 112 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 1 + Value = 1 + end + object toffsetEdit: TFloatSpinEdit + Left = 120 + Height = 16 + Top = 7 + Width = 112 + DecimalPlaces = 5 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 0 + Value = 1 + end + object slice_endEdit: TSpinEdit + Left = 120 + Height = 16 + Top = 104 + Width = 112 + TabOrder = 3 + Value = 1 + end + end + object TabUnused: TTabSheet + Caption = 'Optional' + ClientHeight = 337 + ClientWidth = 738 + object Label34: TLabel + Left = 3 + Height = 16 + Top = 43 + Width = 64 + Caption = 'Data Type' + ParentColor = False + end + object Label5: TLabel + Left = 3 + Height = 16 + Top = 8 + Width = 57 + Caption = 'Intention' + ParentColor = False + end + object Label6: TLabel + Left = 268 + Height = 16 + Top = 116 + Width = 47 + Caption = 'Extents' + ParentColor = False + end + object Label9: TLabel + Left = 268 + Height = 16 + Top = 76 + Width = 76 + Caption = 'Sesion Error' + ParentColor = False + end + object Label10: TLabel + Left = 268 + Height = 16 + Top = 148 + Width = 85 + Caption = 'Regular [114]' + ParentColor = False + end + object Label14: TLabel + Left = 268 + Height = 16 + Top = 8 + Width = 37 + Caption = 'G Min' + ParentColor = False + end + object Label15: TLabel + Left = 268 + Height = 16 + Top = 43 + Width = 40 + Caption = 'G Max' + ParentColor = False + end + object Label18: TLabel + Left = 3 + Height = 16 + Top = 148 + Width = 51 + Caption = 'Aux File' + ParentColor = False + end + object Label19: TLabel + Left = 3 + Height = 16 + Top = 111 + Width = 57 + Caption = 'DB Name' + ParentColor = False + end + object Label26: TLabel + Left = 3 + Height = 16 + Top = 76 + Width = 36 + Caption = 'Notes' + ParentColor = False + end + object intent_nameEdit: TEdit + Left = 76 + Height = 22 + Top = 6 + Width = 152 + MaxLength = 16 + TabOrder = 0 + Text = 'intent_name' + end + object data_typeEdit: TEdit + Left = 76 + Height = 22 + Top = 41 + Width = 152 + MaxLength = 10 + TabOrder = 1 + Text = 'data_type' + end + object CommentEdit: TEdit + Left = 76 + Height = 22 + Top = 74 + Width = 152 + MaxLength = 80 + TabOrder = 2 + Text = 'CommentEdit' + end + object db_: TEdit + Left = 76 + Height = 22 + Top = 109 + Width = 152 + MaxLength = 18 + TabOrder = 3 + Text = 'db_' + end + object aux: TEdit + Left = 76 + Height = 22 + Top = 148 + Width = 152 + MaxLength = 24 + TabOrder = 4 + Text = 'aux' + end + object gmax: TSpinEdit + Left = 366 + Height = 16 + Top = 44 + Width = 66 + TabOrder = 6 + Value = 1 + end + object gmin: TSpinEdit + Left = 366 + Height = 16 + Top = 9 + Width = 66 + TabOrder = 5 + Value = 1 + end + object ses: TSpinEdit + Left = 366 + Height = 16 + Top = 77 + Width = 66 + TabOrder = 7 + Value = 1 + end + object ext: TSpinEdit + Left = 366 + Height = 16 + Top = 117 + Width = 66 + TabOrder = 8 + Value = 1 + end + object reg: TSpinEdit + Left = 366 + Height = 16 + Top = 151 + Width = 66 + MaxValue = 255 + TabOrder = 9 + Value = 1 + end + end + end + object StatusBar1: TStatusBar + Left = 0 + Height = 15 + Top = 368 + Width = 560 + AutoSize = False + Constraints.MaxHeight = 15 + Panels = < + item + Width = 140 + end + item + Width = 50 + end> + SimplePanel = False + end + object MainMenu1: TMainMenu + left = 424 + top = 72 + object File1: TMenuItem + Caption = '&File' + object Open1: TMenuItem + Caption = 'Open header' + ShortCut = 16463 + OnClick = Open1Click + end + object Save1: TMenuItem + Caption = 'Save header' + ShortCut = 16467 + OnClick = Save1Click + end + object Exit1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Exit1Click + end + end + object Page1: TMenuItem + Caption = '&Tab' + object Dimensions1: TMenuItem + Caption = 'Dimensions' + ShortCut = 16449 + OnClick = TabMenuClick + end + object Rotations1: TMenuItem + Tag = 1 + Caption = 'Reorient' + ShortCut = 16450 + OnClick = TabMenuClick + end + object ImageIntensity1: TMenuItem + Tag = 2 + Caption = 'Image Intensity' + ShortCut = 16457 + OnClick = TabMenuClick + end + object Statistics1: TMenuItem + Tag = 3 + Caption = 'Statistics' + ShortCut = 16452 + OnClick = TabMenuClick + end + object FunctionalMRI1: TMenuItem + Tag = 4 + Caption = 'Functional MRI' + ShortCut = 16453 + OnClick = TabMenuClick + end + object Optional1: TMenuItem + Tag = 5 + Caption = 'Optional' + ShortCut = 16454 + OnClick = TabMenuClick + end + end + end + object OpenHdrDlg: TOpenDialog + FilterIndex = 0 + Options = [ofFileMustExist] + left = 456 + top = 72 + end + object SaveHdrDlg: TSaveDialog + OnClose = SaveHdrDlgClose + Width = 52 + Filter = 'NIfTI embedded header (*.nii)|*.nii|NIfTI separate header (*.hdr)|*.hdr' + FilterIndex = 0 + left = 496 + top = 72 + end +end diff --git a/nifti_hdr_view.lrs b/nifti_hdr_view.lrs new file mode 100644 index 0000000..81bee08 --- /dev/null +++ b/nifti_hdr_view.lrs @@ -0,0 +1,364 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('THdrForm','FORMDATA',[ + 'TPF0'#8'THdrForm'#7'HdrForm'#4'Left'#3'_'#2#6'Height'#3#162#1#3'Top'#3#155#0 + +#5'Width'#3#30#2#13'ActiveControl'#7#12'PageControl1'#7'Caption'#6#24'NIfTI ' + +'Header Information'#12'ClientHeight'#3#162#1#11'ClientWidth'#3#30#2#21'Cons' + +'traints.MaxHeight'#3#162#1#20'Constraints.MaxWidth'#3#30#2#21'Constraints.M' + +'inHeight'#3#162#1#20'Constraints.MinWidth'#3#30#2#4'Menu'#7#9'MainMenu1'#8 + +'OnCreate'#7#10'FormCreate'#6'OnShow'#7#8'FormShow'#8'Position'#7#14'poScree' + +'nCenter'#10'LCLVersion'#6#3'1.5'#0#12'TPageControl'#12'PageControl1'#4'Left' + +#2#4#6'Height'#3#139#1#3'Top'#2#4#5'Width'#3#22#2#10'ActivePage'#7#11'TabReq' + +'uired'#5'Align'#7#8'alClient'#18'BorderSpacing.Left'#2#2#17'BorderSpacing.T' + +'op'#2#2#19'BorderSpacing.Right'#2#2#20'BorderSpacing.Bottom'#2#2#20'BorderS' + +'pacing.Around'#2#2#8'TabIndex'#2#0#8'TabOrder'#2#0#0#9'TTabSheet'#11'TabReq' + +'uired'#7'Caption'#6#10'Dimensions'#12'ClientHeight'#3'd'#1#11'ClientWidth'#3 + +#16#2#0#6'TLabel'#7'Label21'#4'Left'#2#6#6'Height'#2#16#3'Top'#2#6#5'Width'#2 + +'O'#7'Caption'#6#11'Header Type'#11'ParentColor'#8#0#0#6'TLabel'#6'Label1'#4 + +'Left'#2#14#6'Height'#2#16#3'Top'#2'#'#5'Width'#3#12#1#7'Caption'#6'.Dimensi' + +'on Length Spacing Unit'#9'Font.Name'#6#7'Default'#11'Paren' + +'tColor'#8#10'ParentFont'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2#16#6'Height'#2 + +#16#3'Top'#2'C'#5'Width'#2','#7'Caption'#6#7'I Space'#11'ParentColor'#8#0#0#6 + +'TLabel'#6'Label3'#4'Left'#2#16#6'Height'#2#16#3'Top'#2'a'#5'Width'#2','#7'C' + +'aption'#6#7'J Space'#11'ParentColor'#8#0#0#6'TLabel'#6'Label4'#4'Left'#2#16 + +#6'Height'#2#16#3'Top'#3#131#0#5'Width'#2'1'#7'Caption'#6#7'K Space'#11'Pare' + +'ntColor'#8#0#0#6'TLabel'#6'Label8'#4'Left'#2#6#6'Height'#2#16#3'Top'#3')'#1 + +#5'Width'#2#29#7'Caption'#6#4'Data'#11'ParentColor'#8#0#0#6'TLabel'#6'Label7' + +#4'Left'#3'&'#1#6'Height'#2#16#3'Top'#3#235#0#5'Width'#2'&'#7'Caption'#6#6'O' + +'ffset'#11'ParentColor'#8#0#0#6'TLabel'#7'Label44'#4'Left'#2#16#6'Height'#2 + +#16#3'Top'#3#166#0#5'Width'#2#31#7'Caption'#6#4'Time'#11'ParentColor'#8#0#0#6 + +'TLabel'#7'Label29'#4'Left'#2#16#6'Height'#2#16#3'Top'#3#198#0#5'Width'#2'3' + +#7'Caption'#6#7'5th Dim'#11'ParentColor'#8#0#0#6'TLabel'#7'Label41'#4'Left'#2 + +#16#6'Height'#2#16#3'Top'#3#230#0#5'Width'#2'3'#7'Caption'#6#7'6th Dim'#11'P' + +'arentColor'#8#0#0#6'TLabel'#7'Label42'#4'Left'#2#16#6'Height'#2#16#3'Top'#3 + +#9#1#5'Width'#2'3'#7'Caption'#6#7'7th Dim'#11'ParentColor'#8#0#0#9'TComboBox' + +#15'HeaderMagicDrop'#4'Left'#2'l'#6'Height'#2#20#3'Top'#2#2#5'Width'#3#239#0 + +#10'ItemHeight'#2#0#13'Items.Strings'#1#6#7'Unknown'#6'#ni1: NIfTI separate ' + +'file (hdr+.img)'#6#28'n+1: NIfTI embedded (.nii)'#6'$ni2: NIfTI2 separate' + +' file (hdr+.img)'#6#29'n+2: NIfTI2 embedded (.nii)'#0#8'OnSelect'#7#21'He' + +'aderMagicDropSelect'#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#15#0#0#9'T' + +'ComboBox'#6'Endian'#4'Left'#3#231#0#6'Height'#2#20#3'Top'#3'#'#1#5'Width'#3 + +#210#0#10'ItemHeight'#2#0#13'Items.Strings'#1#6#13'Native Endian'#6#14'Swapp' + +'ed Endian'#0#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#16#0#0#9'TComboBox' + +#9'fTypeDrop'#4'Left'#2'8'#6'Height'#2#20#3'Top'#3'#'#1#5'Width'#3#152#0#13 + +'DropDownCount'#2#20#10'ItemHeight'#2#0#13'Items.Strings'#1#6#6'binary'#6#7 + +'8-bit S'#6#12'8-bit int U*'#6#13'16-bit int S*'#6#12'16-bit int U'#6#13'32-' + +'bit int S*'#6#12'32-bit int U'#6#12'64-bit int S'#6#12'64-bit int U'#6#12'3' + +'2-bit real*'#6#12'64-bit real*'#6#12'128-bit real'#6#10'24-bit rgb'#6#10'64' + +'-bit com'#6#15'128-bit complex'#6#15'256-bit complex'#0#8'OnSelect'#7#13'Im' + +'ageSzChange'#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#17#0#0#9'TComboBox' + +#13'xyzt_sizeDrop'#4'Left'#3#6#1#6'Height'#2#20#3'Top'#2'W'#5'Width'#3#128#0 + +#10'ItemHeight'#2#0#13'Items.Strings'#1#6#7'Unknown'#6#5'Meter'#6#10'Millime' + +'ter'#6#10'Micrometer'#6#6'Micron'#0#5'Style'#7#14'csDropDownList'#8'TabOrde' + +'r'#2#18#0#0#9'TComboBox'#13'xyzt_timeDrop'#4'Left'#3#6#1#6'Height'#2#20#3'T' + +'op'#3#157#0#5'Width'#3#128#0#10'ItemHeight'#2#0#13'Items.Strings'#1#6#7'Unk' + +'nown'#6#6'Second'#6#11'Millisecond'#6#11'Microsecond'#6#11'Hertzsecond'#6#5 + +'Part '#6#16'Part per million'#0#5'Style'#7#14'csDropDownList'#8'TabOrder'#2 + +#19#0#0#9'TSpinEdit'#4'Xdim'#4'Left'#2'P'#6'Height'#2#16#3'Top'#2';'#5'Width' + +#2'J'#8'MaxValue'#3#15''''#8'MinValue'#2#1#6'OnExit'#7#13'ImageSzChange'#8'T' + +'abOrder'#2#0#5'Value'#2#2#0#0#9'TSpinEdit'#4'Ydim'#4'Left'#2'P'#6'Height'#2 + +#16#3'Top'#2'Y'#5'Width'#2'J'#8'MaxValue'#3#15''''#8'MinValue'#2#1#8'OnChang' + +'e'#7#13'ImageSzChange'#6'OnExit'#7#13'ImageSzChange'#8'TabOrder'#2#1#5'Valu' + +'e'#2#2#0#0#9'TSpinEdit'#4'Zdim'#4'Left'#2'P'#6'Height'#2#16#3'Top'#2'{'#5'W' + +'idth'#2'J'#8'MaxValue'#3#15''''#8'MinValue'#2#1#8'OnChange'#7#13'ImageSzCha' + +'nge'#6'OnExit'#7#13'ImageSzChange'#8'TabOrder'#2#2#5'Value'#2#1#0#0#14'TFlo' + +'atSpinEdit'#3'Xmm'#4'Left'#3#164#0#6'Height'#2#16#3'Top'#2';'#5'Width'#2'J' + +#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#224#31#188#190 + +#25'@'#8'MinValue'#5#0#0#0#0#224#31#188#190#25#192#8'TabOrder'#2#10#5'Value' + ,#5#0#0#0#0#0#0#0#0#0#0#0#0#14'TFloatSpinEdit'#3'Ymm'#4'Left'#3#164#0#6'Heigh' + +'t'#2#16#3'Top'#2'Y'#5'Width'#2'J'#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8 + +'MaxValue'#5#0#0#0#0#224#31#188#190#25'@'#8'MinValue'#5#0#0#0#0#224#31#188 + +#190#25#192#8'TabOrder'#2#11#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0#14'TFloatSpi' + +'nEdit'#3'Zmm'#4'Left'#3#164#0#6'Height'#2#16#3'Top'#2'{'#5'Width'#2'J'#9'In' + +'crement'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#224#31#188#190#25 + +'@'#8'MinValue'#5#0#0#0#0#224#31#188#190#25#192#8'TabOrder'#2#12#5'Value'#5#0 + +#0#0#0#0#0#0#0#0#0#0#0#9'TSpinEdit'#10'OffsetEdit'#4'Left'#3'V'#1#6'Height'#2 + +#16#3'Top'#3#230#0#5'Width'#2'^'#8'MaxValue'#4'?B'#15#0#6'OnExit'#7#13'Image' + +'SzChange'#8'TabOrder'#2#14#5'Value'#2#1#0#0#9'TSpinEdit'#4'TDim'#4'Left'#2 + +'P'#6'Height'#2#16#3'Top'#3#157#0#5'Width'#2'J'#8'MaxValue'#3#15''''#8'MinVa' + +'lue'#2#1#8'OnChange'#7#13'ImageSzChange'#6'OnExit'#7#13'ImageSzChange'#8'Ta' + +'bOrder'#2#3#5'Value'#2#1#0#0#14'TFloatSpinEdit'#4'TSec'#4'Left'#3#164#0#6'H' + +'eight'#2#16#3'Top'#3#157#0#5'Width'#2'J'#13'DecimalPlaces'#2#4#9'Increment' + +#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#224#31#188#190#25'@'#8'Min' + +'Value'#5#0#0#0#0#224#31#188#190#25#192#8'TabOrder'#2#13#5'Value'#5#0#0#0#0#0 + +#0#0#0#0#0#0#0#9'TSpinEdit'#8'Dim5Edit'#4'Left'#2'P'#6'Height'#2#16#3'Top'#3 + +#191#0#5'Width'#2'J'#8'MaxValue'#4#184#136#0#0#8'MinValue'#2#1#8'OnChange'#7 + +#13'ImageSzChange'#6'OnExit'#7#13'ImageSzChange'#8'TabOrder'#2#4#5'Value'#2#1 + +#0#0#9'TSpinEdit'#8'Dim6Edit'#4'Left'#2'P'#6'Height'#2#16#3'Top'#3#223#0#5'W' + +'idth'#2'J'#8'MaxValue'#4#184#136#0#0#8'MinValue'#2#1#8'OnChange'#7#13'Image' + +'SzChange'#6'OnExit'#7#13'ImageSzChange'#8'TabOrder'#2#5#5'Value'#2#1#0#0#9 + +'TSpinEdit'#8'Dim7Edit'#4'Left'#2'P'#6'Height'#2#16#3'Top'#3#2#1#5'Width'#2 + +'J'#8'MaxValue'#4#184#136#0#0#8'MinValue'#2#1#8'OnChange'#7#13'ImageSzChange' + +#6'OnExit'#7#13'ImageSzChange'#8'TabOrder'#2#9#5'Value'#2#1#0#0#14'TFloatSpi' + +'nEdit'#7'PixDim5'#4'Left'#3#164#0#6'Height'#2#16#3'Top'#3#191#0#5'Width'#2 + +'J'#13'DecimalPlaces'#2#4#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue' + +#5#0#0#0#0#224#31#188#190#25'@'#8'MinValue'#5#0#0#0#0#224#31#188#190#25#192#8 + +'TabOrder'#2#6#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0#14'TFloatSpinEdit'#7'PixDi' + +'m6'#4'Left'#3#164#0#6'Height'#2#16#3'Top'#3#223#0#5'Width'#2'J'#13'DecimalP' + +'laces'#2#4#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#224 + +#31#188#190#25'@'#8'MinValue'#5#0#0#0#0#224#31#188#190#25#192#8'TabOrder'#2#7 + +#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0#14'TFloatSpinEdit'#7'PixDim7'#4'Left'#3 + +#164#0#6'Height'#2#16#3'Top'#3#2#1#5'Width'#2'J'#13'DecimalPlaces'#2#4#9'Inc' + +'rement'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#224#31#188#190#25 + +'@'#8'MinValue'#5#0#0#0#0#224#31#188#190#25#192#8'TabOrder'#2#8#5'Value'#5#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#9'TTabSheet'#9'TabSheet4'#7'Caption'#6#8'Reorient' + +#12'ClientHeight'#3'I'#1#11'ClientWidth'#3#16#2#0#6'TLabel'#7'Label24'#4'Lef' + +'t'#2#10#6'Height'#2#18#3'Top'#3#184#0#5'Width'#2#9#7'Caption'#6#1'X'#11'Par' + +'entColor'#8#0#0#6'TLabel'#7'Label36'#4'Left'#2#10#6'Height'#2#18#3'Top'#3 + +#218#0#5'Width'#2#9#7'Caption'#6#1'Y'#11'ParentColor'#8#0#0#6'TLabel'#7'Labe' + +'l37'#4'Left'#2#10#6'Height'#2#18#3'Top'#3#251#0#5'Width'#2#8#7'Caption'#6#1 + +'Z'#11'ParentColor'#8#0#0#6'TLabel'#7'Label39'#4'Left'#2#10#6'Height'#2#18#3 + +'Top'#2'{'#5'Width'#2'='#7'Caption'#6#9'Q Offsets'#11'ParentColor'#8#0#0#6'T' + +'Label'#7'Label40'#4'Left'#2#10#6'Height'#2#18#3'Top'#2'V'#5'Width'#2'L'#7'C' + +'aption'#6#11'Quaternions'#11'ParentColor'#8#0#0#6'TLabel'#7'Label46'#4'Left' + +#2#10#6'Height'#2#18#3'Top'#2'.'#5'Width'#2'm'#7'Caption'#6#17'qFactor [1 or' + +' -1]'#11'ParentColor'#8#0#0#6'TLabel'#7'Label38'#4'Left'#2#4#6'Height'#2#18 + +#3'Top'#2#9#5'Width'#3#150#0#7'Caption'#6#22'Quaternion parameters '#11'Pare' + +'ntColor'#8#0#0#6'TLabel'#7'Label47'#4'Left'#2#4#6'Height'#2#18#3'Top'#3#157 + +#0#5'Width'#2'v'#7'Caption'#6#18'Affine parameters '#11'ParentColor'#8#0#0#9 + +'TComboBox'#9'QFormDrop'#4'Left'#3#150#0#6'Height'#2#20#3'Top'#2#5#5'Width'#3 + +#4#1#10'ItemHeight'#2#0#13'Items.Strings'#1#6#4'None'#6#16'Scanner Position' + +#6#16'Coregistrationon'#6#14'Normalized Tal'#6#20'Normalzied mni152ach'#6#17 + +'Normalzied mni152'#0#8'OnSelect'#7#21'HeaderMagicDropSelect'#5'Style'#7#14 + +'csDropDownList'#8'TabOrder'#2#19#0#0#9'TComboBox'#9'SFormDrop'#4'Left'#3#145 + +#0#6'Height'#2#20#3'Top'#3#150#0#5'Width'#3#204#0#10'ItemHeight'#2#0#13'Item' + +'s.Strings'#1#6#4'None'#6#16'Scanner Position'#6#16'Coregistrationon'#6#14'N' + +'ormalized Tal'#6#20'Normalzied mni152ach'#6#17'Normalzied mni152'#0#8'OnSel' + +'ect'#7#21'HeaderMagicDropSelect'#5'Style'#7#14'csDropDownList'#8'TabOrder'#2 + +#20#0#0#14'TFloatSpinEdit'#11'srow_x0Edit'#4'Left'#2'"'#6'Height'#2#16#3'Top' + +#3#188#0#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128 + +#255'?'#8'MaxValue'#5#0#0#0#0#0#0'<'#156#12'@'#8'MinValue'#5#0#0#0#0#0#0'<' + +#156#12#192#8'TabOrder'#2#7#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloa' + ,'tSpinEdit'#11'srow_x1Edit'#4'Left'#3#142#0#6'Height'#2#16#3'Top'#3#188#0#5 + +'Width'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8 + +'MaxValue'#5#0#0#0#0#0#0'<'#156#12'@'#8'MinValue'#5#0#0#0#0#0#0'<'#156#12#192 + +#8'TabOrder'#2#8#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit' + +#11'srow_x2Edit'#4'Left'#3#254#0#6'Height'#2#16#3'Top'#3#188#0#5'Width'#2'd' + +#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5 + +#0#0#0#0#0#0'<'#156#12'@'#8'MinValue'#5#0#0#0#0#0#0'<'#156#12#192#8'TabOrder' + +#2#9#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#11'srow_y0Ed' + +'it'#4'Left'#2'"'#6'Height'#2#16#3'Top'#3#222#0#5'Width'#2'd'#13'DecimalPlac' + +'es'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0'<' + +#156#12'@'#8'MinValue'#5#0#0#0#0#0#0'<'#156#12#192#8'TabOrder'#2#11#5'Value' + +#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#11'srow_y1Edit'#4'Left'#3 + +#142#0#6'Height'#2#16#3'Top'#3#222#0#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'I' + +'ncrement'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0'<'#156#12'@' + +#8'MinValue'#5#0#0#0#0#0#0'<'#156#12#192#8'TabOrder'#2#12#5'Value'#5#0#0#0#0 + +#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#11'srow_y2Edit'#4'Left'#3#254#0#6'H' + +'eight'#2#16#3'Top'#3#222#0#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'Increment' + +#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0'<'#156#12'@'#8'MinValu' + +'e'#5#0#0#0#0#0#0'<'#156#12#192#8'TabOrder'#2#13#5'Value'#5#0#0#0#0#0#0#0#128 + +#255'?'#0#0#14'TFloatSpinEdit'#11'srow_z0Edit'#4'Left'#2'"'#6'Height'#2#16#3 + +'Top'#3#255#0#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0 + +#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0'<'#156#12'@'#8'MinValue'#5#0#0#0#0#0 + +#0'<'#156#12#192#8'TabOrder'#2#15#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14 + +'TFloatSpinEdit'#11'srow_z1Edit'#4'Left'#3#142#0#6'Height'#2#16#3'Top'#3#255 + +#0#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255 + +'?'#8'MaxValue'#5#0#0#0#0#0#0'<'#156#12'@'#8'MinValue'#5#0#0#0#0#0#0'<'#156 + +#12#192#8'TabOrder'#2#16#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSp' + +'inEdit'#11'srow_z2Edit'#4'Left'#3#254#0#6'Height'#2#16#3'Top'#3#255#0#5'Wid' + +'th'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'Ma' + +'xValue'#5#0#0#0#0#0#0'<'#156#12'@'#8'MinValue'#5#0#0#0#0#0#0'<'#156#12#192#8 + +'TabOrder'#2#17#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#11 + +'srow_x3Edit'#4'Left'#3'n'#1#6'Height'#2#16#3'Top'#3#188#0#5'Width'#2'd'#13 + +'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0 + +#0#0#0#0'<'#156#12'@'#8'MinValue'#5#0#0#0#0#0#0'<'#156#12#192#8'TabOrder'#2 + +#10#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#11'srow_y3Edi' + +'t'#4'Left'#3'n'#1#6'Height'#2#16#3'Top'#3#222#0#5'Width'#2'd'#13'DecimalPla' + +'ces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0 + +'<'#156#12'@'#8'MinValue'#5#0#0#0#0#0#0'<'#156#12#192#8'TabOrder'#2#14#5'Val' + +'ue'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#11'srow_z3Edit'#4'Lef' + +'t'#3'n'#1#6'Height'#2#16#3'Top'#3#255#0#5'Width'#2'd'#13'DecimalPlaces'#2#5 + +#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0'<'#156#12 + +'@'#8'MinValue'#5#0#0#0#0#0#0'<'#156#12#192#8'TabOrder'#2#18#5'Value'#5#0#0#0 + +#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#13'quatern_bEdit'#4'Left'#2'^'#6 + +'Height'#2#16#3'Top'#2'T'#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5 + +#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0#0#200#5'@'#8'MinValue'#5 + +#0#0#0#0#0#0#0#0#0#0#8'TabOrder'#2#1#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0 + +#14'TFloatSpinEdit'#13'quatern_cEdit'#4'Left'#3#212#0#6'Height'#2#16#3'Top'#2 + +'T'#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255 + +'?'#8'MaxValue'#5#0#0#0#0#0#0#0#200#5'@'#8'MinValue'#5#0#0#0#0#0#0#0#0#0#0#8 + +'TabOrder'#2#2#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#13 + +'quatern_dEdit'#4'Left'#3'L'#1#6'Height'#2#16#3'Top'#2'T'#5'Width'#2'd'#13'D' + +'ecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0 + +#0#0#0#0#0#200#5'@'#8'MinValue'#5#0#0#0#0#0#0#0#0#0#0#8'TabOrder'#2#3#5'Valu' + +'e'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#13'qoffset_xEdit'#4'Le' + +'ft'#2'^'#6'Height'#2#16#3'Top'#2'u'#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'I' + +'ncrement'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0#0#200#5'@'#8 + +'MinValue'#5#0#0#0#0#0#0#0#0#0#0#8'TabOrder'#2#4#5'Value'#5#0#0#0#0#0#0#0#128 + +#255'?'#0#0#14'TFloatSpinEdit'#13'qoffset_yEdit'#4'Left'#3#212#0#6'Height'#2 + +#16#3'Top'#2'u'#5'Width'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0 + +#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0#0#200#5'@'#8'MinValue'#5#0#0#0#0#0 + +#0#0#0#0#0#8'TabOrder'#2#5#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloat' + +'SpinEdit'#13'qoffset_zEdit'#4'Left'#3'L'#1#6'Height'#2#16#3'Top'#2'u'#5'Wid' + +'th'#2'd'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'Ma' + +'xValue'#5#0#0#0#0#0#0#0#200#5'@'#8'MinValue'#5#0#0#0#0#0#0#0#0#0#0#8'TabOrd' + ,'er'#2#6#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpinEdit'#8'QFacEd' + +'it'#4'Left'#3#140#0#6'Height'#2#16#3'Top'#2'.'#5'Width'#2'd'#13'DecimalPlac' + +'es'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0#0 + +#128#255'?'#8'MinValue'#5#0#0#0#0#0#0#0#128#255#191#8'TabOrder'#2#0#5'Value' + +#5#0#0#0#0#0#0#0#128#255'?'#0#0#0#9'TTabSheet'#9'TabSheet3'#7'Caption'#6#15 + +'Image Intensity'#12'ClientHeight'#3'd'#1#11'ClientWidth'#3#16#2#0#6'TLabel' + +#7'Label12'#4'Left'#2#24#6'Height'#2#17#3'Top'#3#163#0#5'Width'#2':'#7'Capti' + +'on'#6#7'Maximum'#11'ParentColor'#8#0#0#6'TLabel'#7'Label13'#4'Left'#2#24#6 + +'Height'#2#17#3'Top'#3#129#0#5'Width'#2'7'#7'Caption'#6#7'Minimum'#11'Parent' + +'Color'#8#0#0#6'TLabel'#7'Label23'#4'Left'#2#24#6'Height'#2#17#3'Top'#2#28#5 + +'Width'#2'"'#7'Caption'#6#5'Slope'#11'ParentColor'#8#0#0#6'TLabel'#7'Label22' + +#4'Left'#2#24#6'Height'#2#17#3'Top'#2'@'#5'Width'#2'9'#7'Caption'#6#9'Interc' + +'ept'#11'ParentColor'#8#0#0#6'TLabel'#7'Label30'#4'Left'#2#6#6'Height'#2#17#3 + +'Top'#2#4#5'Width'#2'r'#7'Caption'#6#19'Calibration Scaling'#11'ParentColor' + +#8#0#0#6'TLabel'#7'Label33'#4'Left'#2#6#6'Height'#2#17#3'Top'#2'g'#5'Width'#3 + +#199#0#7'Caption'#6' Display Range (calibrated units)'#11'ParentColor'#8#0#0 + +#14'TFloatSpinEdit'#4'cmax'#4'Left'#2'^'#6'Height'#2#16#3'Top'#3#165#0#5'Wid' + +'th'#2'n'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'Ma' + +'xValue'#5#0#0#0#0#224#31#188#190#25'@'#8'MinValue'#5#0#0#0#0#224#31#188#190 + +#25#192#8'TabOrder'#2#3#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0#14'TFloatSpinEdit' + +#4'cmin'#4'Left'#2'^'#6'Height'#2#16#3'Top'#3#129#0#5'Width'#2'n'#13'Decimal' + +'Places'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0 + +#224#31#188#190#25'@'#8'MinValue'#5#0#0#0#0#224#31#188#190#25#192#8'TabOrder' + +#2#2#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0#14'TFloatSpinEdit'#5'Scale'#4'Left'#2 + +'^'#6'Height'#2#16#3'Top'#2#28#5'Width'#2'n'#13'DecimalPlaces'#2#5#9'Increme' + +'nt'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#224#31#188#190#25'@'#8 + +'MinValue'#5#0#0#0#0#224#31#188#190#25#192#8'TabOrder'#2#0#5'Value'#5#0#0#0#0 + +#0#0#0#0#0#0#0#0#14'TFloatSpinEdit'#9'Intercept'#4'Left'#2'^'#6'Height'#2#16 + +#3'Top'#2'@'#5'Width'#2'n'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0 + +#128#255'?'#8'MaxValue'#5#0#0#0#0#224#31#188#190#25'@'#8'MinValue'#5#0#0#0#0 + +#224#31#188#190#25#192#8'TabOrder'#2#1#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0#0#9 + +'TTabSheet'#9'TabSheet1'#7'Caption'#6#10'Statistics'#12'ClientHeight'#3'd'#1 + +#11'ClientWidth'#3#16#2#0#6'TLabel'#7'Label35'#4'Left'#2#8#6'Height'#2#17#3 + +'Top'#2#14#5'Width'#2'8'#7'Caption'#6#9'Intention'#11'ParentColor'#8#0#0#6'T' + +'Label'#7'Label25'#4'Left'#2#24#6'Height'#2#17#3'Top'#2'.'#5'Width'#2'M'#7'C' + +'aption'#6#11'Parameter 1'#11'ParentColor'#8#0#0#6'TLabel'#7'Label27'#4'Left' + +#2#24#6'Height'#2#17#3'Top'#2'S'#5'Width'#2'M'#7'Caption'#6#11'Parameter 2' + +#11'ParentColor'#8#0#0#6'TLabel'#7'Label28'#4'Left'#2#24#6'Height'#2#17#3'To' + +'p'#2'v'#5'Width'#2'M'#7'Caption'#6#11'Parameter 3'#11'ParentColor'#8#0#0#9 + +'TComboBox'#14'IntentCodeDrop'#4'Left'#2'L'#6'Height'#2#20#3'Top'#2#8#5'Widt' + +'h'#3#218#0#13'DropDownCount'#2','#10'ItemHeight'#2#0#13'Items.Strings'#1#6 + +#14'Not statistics'#6#24'Correlation coefficient '#6#24'T-testation coeffici' + +'ent '#6#6'F-test'#6#7'Z-score'#6#11'Chi-squared'#6#11'Beta distri'#6#21'Bin' + +'omial distribution'#6#18'Gamma distribution'#6#18'Gamma distribution'#6#19 + +'Normal distribution'#6#22'Noncentral F statistic'#6#22'Noncentral chi-squar' + +'ed'#6' Logistic distributiond statistic'#6#20'Laplace distribution'#6#20'Un' + +'iform distribution'#6#22'Noncentral t statistic'#6#20'Weibull distribution' + +#6#16'Chi distribution'#6#17'Inverse Gaussian '#6#20'Extreme value type I'#6 + +#20'p-value value type I'#6#11'ln(p-value)'#6#14'log10(p-value)'#6#8'Estimat' + +'e'#6#6'Labels'#6#6'NeuroN'#6#9'Generic M'#6#16'Symmetric Matrix'#6#25'Displ' + +'acement Field/Vector'#6#25'Vectorcement Field/Vector'#6#6'Points'#6#15'Tria' + +'ngle (mesh)'#6#10'Quaternion'#6#0#0#5'Style'#7#14'csDropDownList'#8'TabOrde' + +'r'#2#3#0#0#14'TFloatSpinEdit'#13'intent_p1Edit'#4'Left'#2'n'#6'Height'#2#16 + +#3'Top'#2'.'#5'Width'#3#138#0#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0 + +#0#0#128#255'?'#8'MaxValue'#5#0#0#0#0#224#31#188#190#25'@'#8'MinValue'#5#0#0 + +#0#0#224#31#188#190#25#192#8'TabOrder'#2#0#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0 + +#14'TFloatSpinEdit'#13'intent_p2Edit'#4'Left'#2'n'#6'Height'#2#16#3'Top'#2'S' + +#5'Width'#3#138#0#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255 + +'?'#8'MaxValue'#5#0#0#0#0#224#31#188#190#25'@'#8'MinValue'#5#0#0#0#0#224#31 + +#188#190#25#192#8'TabOrder'#2#1#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0#14'TFloat' + +'SpinEdit'#13'intent_p3Edit'#4'Left'#2'n'#6'Height'#2#16#3'Top'#2'w'#5'Width' + +#3#138#0#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'Max' + +'Value'#5#0#0#0#0#224#31#188#190#25'@'#8'MinValue'#5#0#0#0#0#224#31#188#190 + +#25#192#8'TabOrder'#2#2#5'Value'#5#0#0#0#0#0#0#0#0#0#0#0#0#6'TLabel'#10'Ecod' + ,'eLabel'#4'Left'#2#8#6'Height'#2#17#3'Top'#3#144#0#5'Width'#2'H'#7'Caption'#6 + +#10'ECode Text'#11'ParentColor'#8#0#0#5'TMemo'#9'EcodeMemo'#4'Left'#2#0#6'He' + +'ight'#3#194#0#3'Top'#3#162#0#5'Width'#3#16#2#5'Align'#7#8'alBottom'#10'Scro' + +'llBars'#7#10'ssVertical'#8'TabOrder'#2#4#0#0#6'TLabel'#12'NoECodeLabel'#4'L' + +'eft'#2#24#6'Height'#2#17#3'Top'#3#192#0#5'Width'#3#157#0#7'Caption'#6#23'No' + +' ECode Text In Header'#11'ParentColor'#8#0#0#0#9'TTabSheet'#9'TabSheet2'#7 + +'Caption'#6#4'fMRI'#12'ClientHeight'#3'd'#1#11'ClientWidth'#3#16#2#0#6'TLabe' + +'l'#7'Label11'#4'Left'#2#12#6'Height'#2#17#3'Top'#3#145#0#5'Width'#2'D'#7'Ca' + +'ption'#6#11'Slice Order'#11'ParentColor'#8#0#0#6'TLabel'#7'Label16'#4'Left' + +#2#12#6'Height'#2#17#3'Top'#2#8#5'Width'#2'J'#7'Caption'#6#11'Time Offset'#11 + +'ParentColor'#8#0#0#6'TLabel'#7'Label17'#4'Left'#2#14#6'Height'#2#17#3'Top'#2 + +''''#5'Width'#2'U'#7'Caption'#6#14'Slice duration'#11'ParentColor'#8#0#0#6'T' + +'Label'#7'Label32'#4'Left'#2#12#6'Height'#2#17#3'Top'#2'J'#5'Width'#2'A'#7'C' + +'aption'#6#11'Slice Start'#11'ParentColor'#8#0#0#6'TLabel'#7'Label20'#4'Left' + +#2#12#6'Height'#2#17#3'Top'#2'i'#5'Width'#2'8'#7'Caption'#6#9'Slice End'#11 + +'ParentColor'#8#0#0#6'TLabel'#7'Label31'#4'Left'#2#12#6'Height'#2#17#3'Top'#3 + +#178#0#5'Width'#3#133#0#7'Caption'#6#19'Frequency Dimension'#11'ParentColor' + +#8#0#0#6'TLabel'#7'Label43'#4'Left'#2#12#6'Height'#2#17#3'Top'#3#214#0#5'Wid' + +'th'#2'i'#7'Caption'#6#15'Phase Dimension'#11'ParentColor'#8#0#0#6'TLabel'#7 + +'Label45'#4'Left'#2#12#6'Height'#2#17#3'Top'#3#250#0#5'Width'#2'a'#7'Caption' + +#6#15'Slice Dimension'#11'ParentColor'#8#0#0#9'TComboBox'#13'SliceCodeDrop'#4 + +'Left'#2'W'#6'Height'#2#20#3'Top'#3#137#0#5'Width'#3#18#1#10'ItemHeight'#2#0 + +#13'Items.Strings'#1#6#7'Unknown'#6#31'Sequential Increasing (1 2 3 4)'#6#31 + +'Sequential Decreasing (4 3 2 1)'#6' Interleaved Increasing (1 3 2 4)'#6' In' + +'terleaved Decreasing (4 2 3 1)'#6'!Interleaved Increasing2 (2 4 1 3)'#6'!In' + +'terleaved Decreasing2 (3 1 4 2)'#0#8'OnSelect'#7#13'ImageSzChange'#5'Style' + +#7#14'csDropDownList'#8'TabOrder'#2#4#0#0#9'TComboBox'#11'FreqDimDrop'#4'Lef' + +'t'#3#146#0#6'Height'#2#20#3'Top'#3#174#0#5'Width'#3#215#0#10'ItemHeight'#2#0 + +#13'Items.Strings'#1#6#7'Unknown'#6#1'I'#6#1'J'#6#1'K'#0#8'OnSelect'#7#13'Im' + +'ageSzChange'#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#5#0#0#9'TComboBox' + +#12'PhaseDimDrop'#4'Left'#3#146#0#6'Height'#2#20#3'Top'#3#210#0#5'Width'#3 + +#215#0#10'ItemHeight'#2#0#13'Items.Strings'#1#6#7'Unknown'#6#1'I'#6#1'J'#6#1 + +'K'#0#8'OnSelect'#7#13'ImageSzChange'#5'Style'#7#14'csDropDownList'#8'TabOrd' + +'er'#2#6#0#0#9'TComboBox'#12'SliceDimDrop'#4'Left'#3#146#0#6'Height'#2#20#3 + +'Top'#3#246#0#5'Width'#3#215#0#10'ItemHeight'#2#0#13'Items.Strings'#1#6#7'Un' + +'known'#6#1'I'#6#1'J'#6#1'K'#0#8'OnSelect'#7#13'ImageSzChange'#5'Style'#7#14 + +'csDropDownList'#8'TabOrder'#2#7#0#0#9'TSpinEdit'#15'slice_startEdit'#4'Left' + +#2'x'#6'Height'#2#16#3'Top'#2'I'#5'Width'#2'p'#8'TabOrder'#2#2#5'Value'#2#1#0 + +#0#14'TFloatSpinEdit'#18'Slice_durationEdit'#4'Left'#2'x'#6'Height'#2#16#3'T' + +'op'#2'&'#5'Width'#2'p'#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0 + +#128#255'?'#8'MaxValue'#5#0#0#0#0#0#0#0#200#5'@'#8'MinValue'#5#0#0#0#0#0#0#0 + +#0#0#0#8'TabOrder'#2#1#5'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#14'TFloatSpin' + +'Edit'#11'toffsetEdit'#4'Left'#2'x'#6'Height'#2#16#3'Top'#2#7#5'Width'#2'p' + +#13'DecimalPlaces'#2#5#9'Increment'#5#0#0#0#0#0#0#0#128#255'?'#8'MaxValue'#5 + +#0#0#0#0#0#0#0#200#5'@'#8'MinValue'#5#0#0#0#0#0#0#0#0#0#0#8'TabOrder'#2#0#5 + +'Value'#5#0#0#0#0#0#0#0#128#255'?'#0#0#9'TSpinEdit'#13'slice_endEdit'#4'Left' + +#2'x'#6'Height'#2#16#3'Top'#2'h'#5'Width'#2'p'#8'TabOrder'#2#3#5'Value'#2#1#0 + +#0#0#9'TTabSheet'#9'TabUnused'#7'Caption'#6#8'Optional'#12'ClientHeight'#3'd' + +#1#11'ClientWidth'#3#16#2#0#6'TLabel'#7'Label34'#4'Left'#2#3#6'Height'#2#17#3 + +'Top'#2'+'#5'Width'#2'A'#7'Caption'#6#9'Data Type'#11'ParentColor'#8#0#0#6'T' + +'Label'#6'Label5'#4'Left'#2#3#6'Height'#2#17#3'Top'#2#8#5'Width'#2'8'#7'Capt' + +'ion'#6#9'Intention'#11'ParentColor'#8#0#0#6'TLabel'#6'Label6'#4'Left'#3#12#1 + +#6'Height'#2#17#3'Top'#2't'#5'Width'#2'0'#7'Caption'#6#7'Extents'#11'ParentC' + +'olor'#8#0#0#6'TLabel'#6'Label9'#4'Left'#3#12#1#6'Height'#2#17#3'Top'#2'L'#5 + +'Width'#2'K'#7'Caption'#6#12'Sesion Error'#11'ParentColor'#8#0#0#6'TLabel'#7 + +'Label10'#4'Left'#3#12#1#6'Height'#2#17#3'Top'#3#148#0#5'Width'#2'X'#7'Capti' + +'on'#6#13'Regular [114]'#11'ParentColor'#8#0#0#6'TLabel'#7'Label14'#4'Left'#3 + +#12#1#6'Height'#2#17#3'Top'#2#8#5'Width'#2'"'#7'Caption'#6#5'G Min'#11'Paren' + +'tColor'#8#0#0#6'TLabel'#7'Label15'#4'Left'#3#12#1#6'Height'#2#17#3'Top'#2'+' + +#5'Width'#2'%'#7'Caption'#6#5'G Max'#11'ParentColor'#8#0#0#6'TLabel'#7'Label' + +'18'#4'Left'#2#3#6'Height'#2#17#3'Top'#3#148#0#5'Width'#2'1'#7'Caption'#6#8 + +'Aux File'#11'ParentColor'#8#0#0#6'TLabel'#7'Label19'#4'Left'#2#3#6'Height'#2 + +#17#3'Top'#2'o'#5'Width'#2'9'#7'Caption'#6#7'DB Name'#11'ParentColor'#8#0#0#6 + +'TLabel'#7'Label26'#4'Left'#2#3#6'Height'#2#17#3'Top'#2'L'#5'Width'#2'%'#7'C' + ,'aption'#6#5'Notes'#11'ParentColor'#8#0#0#5'TEdit'#15'intent_nameEdit'#4'Lef' + +'t'#2'L'#6'Height'#2#22#3'Top'#2#6#5'Width'#3#152#0#9'MaxLength'#2#16#8'TabO' + +'rder'#2#0#4'Text'#6#11'intent_name'#0#0#5'TEdit'#13'data_typeEdit'#4'Left'#2 + +'L'#6'Height'#2#22#3'Top'#2')'#5'Width'#3#152#0#9'MaxLength'#2#10#8'TabOrder' + +#2#1#4'Text'#6#9'data_type'#0#0#5'TEdit'#11'CommentEdit'#4'Left'#2'L'#6'Heig' + +'ht'#2#22#3'Top'#2'J'#5'Width'#3#152#0#9'MaxLength'#2'P'#8'TabOrder'#2#2#4'T' + +'ext'#6#11'CommentEdit'#0#0#5'TEdit'#3'db_'#4'Left'#2'L'#6'Height'#2#22#3'To' + +'p'#2'm'#5'Width'#3#152#0#9'MaxLength'#2#18#8'TabOrder'#2#3#4'Text'#6#3'db_' + +#0#0#5'TEdit'#3'aux'#4'Left'#2'L'#6'Height'#2#22#3'Top'#3#148#0#5'Width'#3 + +#152#0#9'MaxLength'#2#24#8'TabOrder'#2#4#4'Text'#6#3'aux'#0#0#9'TSpinEdit'#4 + +'gmax'#4'Left'#3'n'#1#6'Height'#2#16#3'Top'#2','#5'Width'#2'B'#8'TabOrder'#2 + +#6#5'Value'#2#1#0#0#9'TSpinEdit'#4'gmin'#4'Left'#3'n'#1#6'Height'#2#16#3'Top' + +#2#9#5'Width'#2'B'#8'TabOrder'#2#5#5'Value'#2#1#0#0#9'TSpinEdit'#3'ses'#4'Le' + +'ft'#3'n'#1#6'Height'#2#16#3'Top'#2'M'#5'Width'#2'B'#8'TabOrder'#2#7#5'Value' + +#2#1#0#0#9'TSpinEdit'#3'ext'#4'Left'#3'n'#1#6'Height'#2#16#3'Top'#2'u'#5'Wid' + +'th'#2'B'#8'TabOrder'#2#8#5'Value'#2#1#0#0#9'TSpinEdit'#3'reg'#4'Left'#3'n'#1 + +#6'Height'#2#16#3'Top'#3#151#0#5'Width'#2'B'#8'MaxValue'#3#255#0#8'TabOrder' + +#2#9#5'Value'#2#1#0#0#0#0#10'TStatusBar'#10'StatusBar1'#4'Left'#2#0#6'Height' + +#2#15#3'Top'#3#147#1#5'Width'#3#30#2#6'Panels'#14#1#5'Width'#3#140#0#0#1#5'W' + +'idth'#2'2'#0#0#11'SimplePanel'#8#0#0#9'TMainMenu'#9'MainMenu1'#4'left'#3#168 + +#1#3'top'#2'H'#0#9'TMenuItem'#5'File1'#7'Caption'#6#5'&File'#0#9'TMenuItem'#5 + +'Open1'#7'Caption'#6#11'Open header'#8'ShortCut'#3'O@'#7'OnClick'#7#10'Open1' + +'Click'#0#0#9'TMenuItem'#5'Save1'#7'Caption'#6#11'Save header'#8'ShortCut'#3 + +'S@'#7'OnClick'#7#10'Save1Click'#0#0#9'TMenuItem'#5'Exit1'#7'Caption'#6#12'C' + +'lose window'#8'ShortCut'#3'W@'#7'OnClick'#7#10'Exit1Click'#0#0#0#9'TMenuIte' + +'m'#5'Page1'#7'Caption'#6#4'&Tab'#0#9'TMenuItem'#11'Dimensions1'#7'Caption'#6 + +#10'Dimensions'#8'ShortCut'#3'A@'#7'OnClick'#7#12'TabMenuClick'#0#0#9'TMenuI' + +'tem'#10'Rotations1'#3'Tag'#2#1#7'Caption'#6#8'Reorient'#8'ShortCut'#3'B@'#7 + +'OnClick'#7#12'TabMenuClick'#0#0#9'TMenuItem'#15'ImageIntensity1'#3'Tag'#2#2 + +#7'Caption'#6#15'Image Intensity'#8'ShortCut'#3'I@'#7'OnClick'#7#12'TabMenuC' + +'lick'#0#0#9'TMenuItem'#11'Statistics1'#3'Tag'#2#3#7'Caption'#6#10'Statistic' + +'s'#8'ShortCut'#3'D@'#7'OnClick'#7#12'TabMenuClick'#0#0#9'TMenuItem'#14'Func' + +'tionalMRI1'#3'Tag'#2#4#7'Caption'#6#14'Functional MRI'#8'ShortCut'#3'E@'#7 + +'OnClick'#7#12'TabMenuClick'#0#0#9'TMenuItem'#9'Optional1'#3'Tag'#2#5#7'Capt' + +'ion'#6#8'Optional'#8'ShortCut'#3'F@'#7'OnClick'#7#12'TabMenuClick'#0#0#0#0 + +#11'TOpenDialog'#10'OpenHdrDlg'#11'FilterIndex'#2#0#7'Options'#11#15'ofFileM' + +'ustExist'#0#4'left'#3#200#1#3'top'#2'H'#0#0#11'TSaveDialog'#10'SaveHdrDlg'#7 + +'OnClose'#7#15'SaveHdrDlgClose'#5'Width'#2'4'#6'Filter'#6'GNIfTI embedded he' + +'ader (*.nii)|*.nii|NIfTI separate header (*.hdr)|*.hdr'#11'FilterIndex'#2#0 + +#4'left'#3#240#1#3'top'#2'H'#0#0#0 +]); diff --git a/nifti_hdr_view.pas b/nifti_hdr_view.pas new file mode 100755 index 0000000..ae3843a --- /dev/null +++ b/nifti_hdr_view.pas @@ -0,0 +1,753 @@ +unit nifti_hdr_view; +interface +{$H+} +{$MODE DELPHI} +uses +{$IFNDEF FPC} + RXSpin,capmenu, +{$ELSE} +LResources, Spin, + +{$ENDIF} +{$IFNDEF Unix} ShellAPI, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, nifti_hdr, Menus, ComCtrls, Buttons, define_types, nifti_types; +type + { THdrForm } + THdrForm = class(TForm) + EcodeLabel: TLabel; + EcodeMemo: TMemo; + NoECodeLabel: TLabel; + Ymm: TFloatSpinEdit; + MainMenu1: TMainMenu; + File1: TMenuItem; + Open1: TMenuItem; + Exit1: TMenuItem; + Save1: TMenuItem; + OpenHdrDlg: TOpenDialog; + SaveHdrDlg: TSaveDialog; + PageControl1: TPageControl; + TabRequired: TTabSheet; + TabUnused: TTabSheet; + intent_nameEdit: TEdit; + data_typeEdit: TEdit; + CommentEdit: TEdit; + db_: TEdit; + aux: TEdit; + gmax: TSpinEdit; + gmin: TSpinEdit; + ses: TSpinEdit; + ext: TSpinEdit; + reg: TSpinEdit; + Label34: TLabel; + Label5: TLabel; + Label6: TLabel; + Label9: TLabel; + Label10: TLabel; + Label14: TLabel; + Label15: TLabel; + Label18: TLabel; + Label19: TLabel; + Label26: TLabel; + HeaderMagicDrop: TComboBox; + Label21: TLabel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + Label8: TLabel; + Label7: TLabel; + Endian: TComboBox; + fTypeDrop: TComboBox; + Label44: TLabel; + xyzt_sizeDrop: TComboBox; + xyzt_timeDrop: TComboBox; + Xdim: TSpinEdit; + Ydim: TSpinEdit; + Zdim: TSpinEdit; + Zmm: TFloatSpinEdit; + OffsetEdit: TSpinEdit; + TDim: TSpinEdit; + Xmm: TFloatSpinEdit; + TSec: TFloatSpinEdit; + StatusBar1: TStatusBar; + Label29: TLabel; + Dim5Edit: TSpinEdit; + TabSheet1: TTabSheet; + Label35: TLabel; + IntentCodeDrop: TComboBox; + intent_p1Edit: TFloatSpinEdit; + intent_p2Edit: TFloatSpinEdit; + intent_p3Edit: TFloatSpinEdit; + Label25: TLabel; + Label27: TLabel; + Label28: TLabel; + TabSheet2: TTabSheet; + Label11: TLabel; + Label16: TLabel; + Label17: TLabel; + Label32: TLabel; + slice_startEdit: TSpinEdit; + Slice_durationEdit: TFloatSpinEdit; + toffsetEdit: TFloatSpinEdit; + TabSheet3: TTabSheet; + cmax: TFloatSpinEdit; + cmin: TFloatSpinEdit; + Label12: TLabel; + Label13: TLabel; + Scale: TFloatSpinEdit; + Label23: TLabel; + Intercept: TFloatSpinEdit; + Label22: TLabel; + Label30: TLabel; + Label33: TLabel; + Page1: TMenuItem; + Dimensions1: TMenuItem; + ImageIntensity1: TMenuItem; + Statistics1: TMenuItem; + FunctionalMRI1: TMenuItem; + Optional1: TMenuItem; + TabSheet4: TTabSheet; + Rotations1: TMenuItem; + srow_x0Edit: TFloatSpinEdit; + srow_x1Edit: TFloatSpinEdit; + srow_x2Edit: TFloatSpinEdit; + Label24: TLabel; + Label36: TLabel; + Label37: TLabel; + srow_y0Edit: TFloatSpinEdit; + srow_y1Edit: TFloatSpinEdit; + srow_y2Edit: TFloatSpinEdit; + srow_z0Edit: TFloatSpinEdit; + srow_z1Edit: TFloatSpinEdit; + srow_z2Edit: TFloatSpinEdit; + srow_x3Edit: TFloatSpinEdit; + srow_y3Edit: TFloatSpinEdit; + srow_z3Edit: TFloatSpinEdit; + quatern_bEdit: TFloatSpinEdit; + quatern_cEdit: TFloatSpinEdit; + quatern_dEdit: TFloatSpinEdit; + qoffset_xEdit: TFloatSpinEdit; + qoffset_yEdit: TFloatSpinEdit; + qoffset_zEdit: TFloatSpinEdit; + Label39: TLabel; + Label40: TLabel; + Label41: TLabel; + Dim6Edit: TSpinEdit; + Label42: TLabel; + Dim7Edit: TSpinEdit; + PixDim5: TFloatSpinEdit; + PixDim6: TFloatSpinEdit; + PixDim7: TFloatSpinEdit; + SliceCodeDrop: TComboBox; + Label20: TLabel; + slice_endEdit: TSpinEdit; + FreqDimDrop: TComboBox; + PhaseDimDrop: TComboBox; + SliceDimDrop: TComboBox; + Label31: TLabel; + Label43: TLabel; + Label45: TLabel; + QFacEdit: TFloatSpinEdit; + Label46: TLabel; + QFormDrop: TComboBox; + SFormDrop: TComboBox; + Label38: TLabel; + Label47: TLabel; + procedure FormShow(Sender: TObject); + procedure PageControl1Change(Sender: TObject); + procedure SaveHdrDlgClose(Sender: TObject); + procedure TabRequiredContextPopup(Sender: TObject; MousePos: TPoint; + var Handled: Boolean); + procedure WriteHdrForm (var lHdr: TMRIcroHdr); + procedure ReadHdrDimensionsOnly (var lHdr: TMRIcroHdr); //reads only size dimensions: useful for computing estimated filesize + procedure ReadHdrForm (var lHdr: TMRIcroHdr); //reads entire header + procedure Open1Click(Sender: TObject); + procedure Save1Click(Sender: TObject); + procedure TabMenuClick(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure ImageSzChange(Sender: TObject); + procedure HeaderMagicDropSelect(Sender: TObject); + function OpenAndDisplayHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + private + { Private declarations } +{$IFNDEF FPC} procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES; +{$ENDIF} + public + { Public declarations } + end; + function OpenDialogExecute (lFilter,lCaption: string; lAllowMultiSelect: boolean): boolean; + +var + HdrForm: THdrForm; + +implementation + +uses nifti_img_view, render,nifti_img; +{$IFDEF FPC} +{$R *.lfm} +{$ELSE} +{$R *.DFM} +{$ENDIF} + +function OpenDialogExecute (lFilter,lCaption: string; lAllowMultiSelect: boolean): boolean; +begin + HdrForm.OpenHdrDlg.Filter := lFilter; + HdrForm.OpenHdrDlg.FilterIndex := 1; + HdrForm.OpenHdrDlg.Title := lCaption; + if lAllowMultiSelect then + HdrForm.OpenHdrDlg.Options := [ofAllowMultiSelect,ofFileMustExist]; + result := HdrForm.OpenHdrDlg.Execute; + HdrForm.OpenHdrDlg.Options := [ofFileMustExist]; +end; + +function DropItem2DataType(lItemIndex: integer): integer; //returns NIfTI datatype number +begin + case lItemIndex of + 0: result :=1; //binary + 1 : result := 256; //8-bit S + 2 : result := 2; //8-bit int U* + 3 : result := 4; //16-bit int S* + 4 : result := 512; //16-bit int U + 5 : result := 8; //32-bit int S* + 6 : result := 768; //32-bit int U + 7: result := 1024; //64-bit int S + 8: result := 1280; //64-bit int U + 9: result := 16; //32-bit real* + 10: result := 64; //64-bit real* + 11: result := 1536; //128-bit real + 12: result := 128; //24-bit rgb + 13: result := 32; //64-bit complex + 14: result := 1792; //128-bit complex + 15: result := 2048; //256-bit complex + else + result := 0; + end; //case +end; //func DropItem2DataType + +function DataType2DropItem (lDataType: smallint): integer; +begin + case lDataType of + 1: result := 0; //binary + 256: result := 1; //8-bit S + 2: result := 2; //8-bit int U* + 4: result := 3; //16-bit int S* + 512: result := 4; //16-bit int U + 8: result := 5; //32-bit int S* + 768: result := 6; //32-bit int U + 1024: result := 7; //64-bit int S + 1280: result := 8; //64-bit int U + 16: result := 9; //32-bit real* + 64: result := 10; //64-bit real* + 1536: result := 11; //128-bit real + 128: result := 12; //24-bit rgb + 32: result := 13; //64-bit complex + 1792: result := 14; //128-bit complex + 2048: result := 15; //256-bit complex + else + result := 0; + end; //case +end; //func DataType2DropItem + +function DataType2BitsPerVoxel (lDataType: smallint): integer; +begin + case lDataType of + 1: result := 1; //binary + 256: result := 8; //8-bit S + 2: result := 8; //8-bit int U* + 4: result := 16; //16-bit int S* + 512: result := 16; //16-bit int U + 8: result := 32; //32-bit int S* + 768: result := 32; //32-bit int U + 1024: result := 64; //64-bit int S + 1280: result := 64; //64-bit int U + 16: result := 32; //32-bit real* + 64: result := 64; //64-bit real* + 1536: result := 128; //128-bit real + 128: result := 24; //24-bit rgb + 32: result := 64; //64-bit complex + 1792: result := 128; //128-bit complex + 2048: result := 256; //256-bit complex + else + result := 0; + end; //case +end; //func DataType2BitsPerVoxel + +function time_units2DropItem (lxyzt_units: byte): integer; +var lxyzt_unitsClipped: byte; +begin + lxyzt_unitsClipped := lxyzt_units and 56; + case lxyzt_unitsClipped of + kNIFTI_UNITS_SEC : result := 1;//= 8; + kNIFTI_UNITS_MSEC : result := 2;//= 16; + kNIFTI_UNITS_USEC : result := 3;//= 24; + kNIFTI_UNITS_HZ : result := 4;//= 32; + kNIFTI_UNITS_PPM : result := 5;//= 40; + else result := 0; //unknown + end; //case +end; //func time_units2DropItem + +function DropItem2time_units (lDropItemIndex: byte): integer; //convert ComboBox index to NIFTI time units +begin + case lDropItemIndex of + 1: result := kNIFTI_UNITS_SEC; + 2: result := kNIFTI_UNITS_MSEC; + 3: result := kNIFTI_UNITS_USEC; + 4: result := kNIFTI_UNITS_HZ; + 5: result := kNIFTI_UNITS_PPM; + else result := 0; //unknown + end; //case +end; //func DropItem2time_units + +procedure THdrForm.WriteHdrForm (var lHdr: TMRIcroHdr); //writes a header to the various controls +var //lCStr: string[80]; + lInc: Integer; + s: string; +begin + with lHdr.NIFTIhdr do begin + //numDimEdit.value := dim[0]; + XDim.Value := dim[1]; + YDim.Value := dim[2]; + ZDim.Value := dim[3]; + TDim.Value := dim[4]; + Dim5Edit.value := dim[5]; + Dim6Edit.value := dim[6]; + Dim7Edit.value := dim[7]; + Xmm.Value := pixdim[1]; + Ymm.Value := pixdim[2]; + Zmm.Value := pixdim[3]; + TSec.Value := pixdim[4]; + PixDim5.value := pixdim[5]; + PixDim6.value := pixdim[6]; + PixDim7.value := pixdim[7]; + OffsetEdit.value := round(vox_offset); + Scale.value := scl_slope; + Intercept.value := scl_inter; + {$IFNDEF FPC} + fTypeDrop.SetItemIndex( DataType2DropItem( datatype)); + if lHdr.NativeEndian then + Endian.SetItemIndex(0) + else + Endian.SetItemIndex(1); + //caption := inttohex(Magic); + if Magic = kNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.SetItemIndex(2) + else if Magic = kNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.SetItemIndex(1) + else if Magic = kswapNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.SetItemIndex(2) + else if Magic = kswapNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.SetItemIndex(1) + else + HeaderMagicDrop.SetItemIndex(0); + xyzt_sizeDrop.SetItemIndex(xyzt_units and 3); + xyzt_timeDrop.SetItemIndex(time_units2DropItem(xyzt_units)); + {$ELSE} + fTypeDrop.ItemIndex := ( DataType2DropItem( datatype)); + if lHdr.DiskDataNativeEndian then + Endian.ItemIndex:=(0) + else + Endian.ItemIndex:=(1); + if Magic = kNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.ItemIndex:=(2) + else if Magic = kNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.ItemIndex:=(1) + else if Magic = kswapNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.ItemIndex:=(2) + else if Magic = kswapNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.ItemIndex:=(1) + else + HeaderMagicDrop.ItemIndex:=(0); + xyzt_sizeDrop.ItemIndex:=(xyzt_units and 3); + xyzt_timeDrop.ItemIndex:=(time_units2DropItem(xyzt_units)); + {$ENDIF} + + CommentEdit.text := descrip; + data_typeEdit.text := data_type; + db_.text := db_name; + aux.text := aux_file; + intent_nameEdit.text := intent_name; + ext.value := extents; + lInc := intent_code; + if (intent_code > 1) and (intent_code <= kNIFTI_LAST_STATCODE) then + lInc := lInc - 1 //intent_codes start from 2 not 1 + else if intent_code >= kNIFTI_FIRST_NONSTATCODE then //remove gap in numbers that follow final statcode + lInc := (intent_code - kNIFTI_FIRST_NONSTATCODE)+kNIFTI_LAST_STATCODE + else begin + lInc := 0; //unknown + end; + {$IFNDEF FPC} + IntentCodeDrop .SetItemIndex(lInc); + SliceCodeDrop.SetItemIndex(slice_code); + FreqDimDrop.SetItemIndex(dim_info and 3); + PhaseDimDrop.SetItemIndex((dim_info shr 2) and 3); + SliceDimDrop.SetItemIndex((dim_info shr 4) and 3); + {$ELSE} + IntentCodeDrop.ItemIndex:=lInc; + SliceCodeDrop.ItemIndex:=(slice_code); + FreqDimDrop.ItemIndex:=(dim_info and 3); + PhaseDimDrop.ItemIndex:=((dim_info shr 2) and 3); + SliceDimDrop.ItemIndex:=((dim_info shr 4) and 3); + {$ENDIF} + intent_p1Edit.value := intent_p1; + intent_p2Edit.value := intent_p2; + intent_p3Edit.value := intent_p3; + ses.value := session_error; + reg.value := ord(regular); + slice_startEdit.value := slice_start; + slice_endEdit.value := slice_end; + cmax.value := cal_max; + cmin.value := cal_min; + slice_durationEdit.value := slice_duration; + toffsetEdit.value := toffset; + gmax.value := glmax; + gmin.value := glmin; + //Next: 3D orientation rotations + QFacEdit.value := pixdim[0]; + {$IFNDEF FPC} + QFormDrop.SetItemIndex(qform_code); + SFormDrop.SetItemIndex(sform_code); + {$ELSE} + QFormDrop.ItemIndex:= (qform_code); + SFormDrop.ItemIndex :=(sform_code); + {$ENDIF} + + quatern_bEdit.value := quatern_b; + quatern_cEdit.value := quatern_c; + quatern_dEdit.value := quatern_d; + qoffset_xEdit.value := qoffset_x; + qoffset_yEdit.value := qoffset_y; + qoffset_zEdit.value := qoffset_z; + srow_x0Edit.value := srow_x[0];//12 affine matrix values + srow_x1Edit.value := srow_x[1]; + srow_x2Edit.value := srow_x[2]; + srow_x3Edit.value := srow_x[3]; + srow_y0Edit.value := srow_y[0]; + srow_y1Edit.value := srow_y[1]; + srow_y2Edit.value := srow_y[2]; + srow_y3Edit.value := srow_y[3]; + srow_z0Edit.value := srow_z[0]; + srow_z1Edit.value := srow_z[1]; + srow_z2Edit.value := srow_z[2]; + srow_z3Edit.value := srow_z[3]; + //Finally... check values + HeaderMagicDropSelect(nil); //disable or enable offset based on image format + //showmessage(lHdr.ECodeText); + if length(lHdr.ECodeText) > 0 then begin + s := lHdr.ECodeText; + s := StringReplace(s, chr (0), '',[rfReplaceAll, rfIgnoreCase]); + s := AdjustLineBreaks(s);//, tlbsLF); + EcodeMemo.Lines.Text:= s; + EcodeMemo.Visible := true; + end else + EcodeMemo.Visible := false; + + end; //with lHdr +end; + +(*procedure ApplySaveDlgFilter (lSaveDlg: TSaveDialog); +var + lLen,lPos,lPipes,lPipesReq: integer; + lExt: string; +begin + lPipesReq := (lSaveDlg.FilterIndex * 2)-1; + if lPipesReq < 1 then exit; + lLen := length(lSaveDlg.Filter); + lPos := 1; + lPipes := 0; + while (lPos < lLen) and (lPipes < lPipesReq) do begin + if lSaveDlg.Filter[lPos] = '|' then + inc(lPipes); + inc(lPos); + end; + if (lPos >= lLen) or (lPipes < lPipesReq) then + exit; + lExt := ''; + while (lPos <= lLen) and (lSaveDlg.Filter[lPos] <> '|') do begin + if lSaveDlg.Filter[lPos] <> '*' then + lExt := lExt + lSaveDlg.Filter[lPos]; + inc(lPos); + end; + if lExt <> '' then + lSaveDlg.Filename := ChangeFileExt(lSaveDlg.Filename,lExt); +end; *) + +procedure THdrForm.SaveHdrDlgClose(Sender: TObject); +begin + //ApplySaveDlgFilter(SaveHdrDlg); +end; + + + +procedure THdrForm.TabRequiredContextPopup(Sender: TObject; MousePos: TPoint; + var Handled: Boolean); +begin + +end; + +procedure THdrForm.FormShow(Sender: TObject); +begin + // ImgForm.OnLaunch; +end; + + +procedure THdrForm.PageControl1Change(Sender: TObject); +begin + +end; + +procedure THdrForm.ReadHdrDimensionsOnly (var lHdr: TMRIcroHdr); //reads only size dimensions: useful for computing estimated filesize +var + lInc: Integer; +begin + with lHdr.NIFTIhdr do begin + dim[1] := round(XDim.Value); + dim[2] := round(YDim.Value); + dim[3] := round(ZDim.Value); + dim[4] := round(TDim.Value); + dim[5] := round(Dim5Edit.value); + dim[6] := round(Dim6Edit.value); + dim[7] := round(Dim7Edit.value); + //Next: compute Dim[0]: compute number of dimensions by finding largest dimension with at least two samples + lInc := 7; + while dim[lInc] < 2 do + dec(lInc); + Dim[0] := lInc; //comp + //showmessage(inttostr(Dim[0])); + vox_offset := OffsetEdit.value; + DataType := DropItem2DataType(FTypeDrop.ItemIndex); + bitpix := DataType2BitsPerVoxel(DataType); + if Endian.ItemIndex = 0 then + lHdr.DiskDataNativeEndian := true + else + lHdr.DiskDataNativeEndian := false; + end; //with NIfTIhdr +end; //proc ReadHdrDimensionsOnly + +procedure THdrForm.ReadHdrForm (var lHdr: TMRIcroHdr); //read the values the user has entered +var + lInc: Integer; +begin + NIFTIhdr_ClearHdr(lHdr); //important: reset values like first 4 bytes = 348 + ReadHdrDimensionsOnly(lHdr); + //StatusBar1.Panels[0].text := 'ImageData (bytes)= '+inttostr(ComputeImageDataBytes(lHdr)); + with lHdr.NIFTIhdr do begin + pixdim[1] := Xmm.Value; + pixdim[2] := Ymm.Value; + pixdim[3] := Zmm.Value; + pixdim[4] := TSec.Value; + pixdim[5] := PixDim5.Value; + pixdim[6] := PixDim6.Value; + pixdim[7] := PixDim7.Value; + scl_slope := Scale.value; + scl_inter := Intercept.value; + if HeaderMagicDrop.ItemIndex = 2 then + Magic := kNIFTI_MAGIC_EMBEDDED_HDR + else if HeaderMagicDrop.ItemIndex = 1 then + Magic := kNIFTI_MAGIC_SEPARATE_HDR + else + Magic := 0; //not saed as NIFTI + for lInc := 1 to 80 do + descrip[lInc] := chr(0); + for lInc := 1 to length(CommentEdit.text) do + descrip[lInc] := CommentEdit.text[lInc]; + for lInc := 1 to 10 do + data_type[lInc] := chr(0); + for lInc := 1 to length(data_typeEdit.text) do + data_type[lInc] := data_typeEdit.text[lInc]; + for lInc := 1 to 18 do + db_name[lInc] := chr(0); + for lInc := 1 to length(db_.text) do + db_name[lInc] := db_.text[lInc]; + for lInc := 1 to 24 do + aux_file[lInc] := chr(0); + for lInc := 1 to length(aux.text) do + aux_file[lInc] := aux.text[lInc]; + for lInc := 1 to 16 do + intent_name[lInc] := chr(0); + for lInc := 1 to length(intent_nameEdit.text) do + intent_name[lInc] := intent_nameEdit.text[lInc]; + xyzt_units := xyzt_sizeDrop.ItemIndex; + xyzt_units := xyzt_units+ (DropItem2time_units(xyzt_timeDrop.ItemIndex)); + lInc := IntentCodeDrop.ItemIndex; + if (lInc > 0) and (lInc < kNIFTI_LAST_STATCODE) then + lInc := lInc + 1 //intent_codes start from 2 not 1 + else if (lInc >= kNIFTI_LAST_STATCODE) then //add gap in numbers between last stat code and misc codes + lInc := (lInc - kNIFTI_LAST_STATCODE)+kNIFTI_FIRST_NONSTATCODE + else + lInc := 0; //unknown + intent_code := lInc; + intent_p1 := intent_p1Edit.value; + intent_p2 := intent_p2Edit.value; + intent_p3 := intent_p3Edit.value; + extents:= round(ext.value); + session_error := round(ses.value); + regular := chr(round(reg.value)); + dim_Info := FreqDimDrop.ItemIndex+(PhaseDimDrop.ItemIndex shl 2)+(SliceDimDrop.ItemIndex shl 4); + slice_start := round(slice_startEdit.value); + slice_end := round(slice_endEdit.value); + slice_code := SliceCodeDrop.ItemIndex; + Slice_duration := (Slice_DurationEdit.value); + toffset := (toffsetEdit.value); + cal_max := cmax.value; + cal_min := cmin.value; + glmax := round(gmax.value); + glmin := round(gmin.value); + //Next: 3D orientation rotations + pixdim[0] := QFacEdit.value; + qform_code := QFormDrop.ItemIndex; + quatern_b := quatern_bEdit.value; + quatern_c := quatern_cEdit.value; + quatern_d := quatern_dEdit.value; + qoffset_x := qoffset_xEdit.value; + qoffset_y := qoffset_yEdit.value; + qoffset_z := qoffset_zEdit.value; + sform_code := SFormDrop.ItemIndex; + srow_x[0] := srow_x0Edit.value;//12 affine matrix values + srow_x[1] := srow_x1Edit.value; + srow_x[2] := srow_x2Edit.value; + srow_x[3] := srow_x3Edit.value; + srow_y[0] := srow_y0Edit.value; + srow_y[1] := srow_y1Edit.value; + srow_y[2] := srow_y2Edit.value; + srow_y[3] := srow_y3Edit.value; + srow_z[0] := srow_z0Edit.value; + srow_z[1] := srow_z1Edit.value; + srow_z[2] := srow_z2Edit.value; + srow_z[3] := srow_z3Edit.value; + end; //with lHdr + //zero_intercept := intercept.value; +end; + +function THdrForm.OpenAndDisplayHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +var lFileDir: string; +begin + FreeImgMemory(lHdr); + result := false; + NIFTIhdr_ClearHdr(lHdr); + if not NIFTIhdr_LoadHdr(lFilename, lHdr) then exit; + WriteHdrForm (lHdr); + lFileDir := extractfiledir(lFilename); + if lFileDir <> gTemplateDir then + OpenHdrDlg.InitialDir := lFileDir; + SaveHdrDlg.InitialDir := lFileDir; + //999 ImgForm.SaveDialog1.InitialDir := lFileDir; + SaveHdrDlg.FileName := lFilename; //make this default file to write + StatusBar1.Panels[1].text := lFilename; + StatusBar1.Panels[0].text := 'Img= '+inttostr(ComputeImageDataBytes(lHdr)); + result := true; +end; + +procedure THdrForm.Open1Click(Sender: TObject); +var lHdr: TMRIcroHdr; + lFilename: string; +begin + //NIfTI (*.hdr;*.nii)|*.hdr; *.nii; *.nii.gz|NIfTI separate header (*.hdr)|*.hdr|NIfTI embedded header|*.nii|NIfTI compressed|*.nii.gz + //if not OpenHdrDlg.Execute then exit; + if not OpenDialogExecute(kImgFilter,'Select header',false) then exit; + lFilename := OpenHdrDlg.Filename; + OpenAndDisplayHdr(lFilename,lHdr); +end; + +procedure THdrForm.Save1Click(Sender: TObject); +var lHdr: TMRIcroHdr; + lFilename: string; +begin + NIFTIhdr_ClearHdr(lHdr); + if not SaveHdrDlg.Execute then exit; + lFilename := SaveHdrDlg.Filename; + OpenHdrDlg.InitialDir := extractfiledir(lFilename); + //999 ImgForm.SaveDialog1.InitialDir := extractfiledir(lFilename); + ReadHdrForm (lHdr); + if not NIFTIhdr_SaveHdr (lFilename, lHdr,true) then exit; + OpenHdrDlg.FileName := lFilename; //make this default file to open + StatusBar1.Panels[1].text := 'wrote: '+lFilename; +end; + +procedure THdrForm.TabMenuClick(Sender: TObject); +begin + PageControl1.ActivePage := PageControl1.Pages[(Sender as TMenuItem).Tag]; +end; + +procedure THdrForm.Exit1Click(Sender: TObject); //Quit the program or form +begin + Close; +end; + + {$IFNDEF FPC} +procedure THdrForm.WMDropFiles(var Msg: TWMDropFiles); //implement drag and drop +//NOTE: requires 'ShellAPI' in uses clause +var lHdr: TMRIcroHdr; + CFileName: array[0..MAX_PATH] of Char; + lFilename: string; +begin + try + if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then + begin + lFilename := CFilename; + OpenAndDisplayHdr(lFileName, lHdr); + Msg.Result := 0; + end; + finally + DragFinish(Msg.Drop); + end; +end; + {$ENDIF} + +procedure THdrForm.FormCreate(Sender: TObject); +var lHdr: TMRIcroHdr; +begin + //DecimalSeparator := '.'; //important for reading DICOM data: e.g. Germans write '12,00' but DICOM is '12.00' + {$IFNDEF Unix} DragAcceptFiles(Handle, True); //engage drag and drop + {$ENDIF} + NIFTIhdr_ClearHdr(lHdr); + HdrForm.WriteHdrForm (lHdr); //show default header + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Open1.ShortCut := ShortCut(Word('O'), [ssMeta]); + Save1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Exit1.ShortCut := ShortCut(Word('W'), [ssMeta]); + Dimensions1.ShortCut := ShortCut(Word('A'), [ssMeta]); + Rotations1.ShortCut := ShortCut(Word('B'), [ssMeta]); + ImageIntensity1.ShortCut := ShortCut(Word('I'), [ssMeta]); + Statistics1.ShortCut := ShortCut(Word('D'), [ssMeta]); + FunctionalMRI1.ShortCut := ShortCut(Word('E'), [ssMeta]); + Optional1.ShortCut := ShortCut(Word('F'), [ssMeta]); + {$ENDIF} + {$ENDIF} +end; + +procedure THdrForm.ImageSzChange(Sender: TObject); //report size of image data +var + lHdr: TMRIcroHdr; +begin + NIFTIhdr_ClearHdr(lHdr); //important: reset values like first 4 bytes = 348 + ReadHdrDimensionsOnly(lHdr); + StatusBar1.Panels[0].text := 'Img= '+inttostr(ComputeImageDataBytes(lHdr)); +end; + +procedure THdrForm.HeaderMagicDropSelect(Sender: TObject); +var lHdrIndex: integer; +begin + lHdrIndex := HeaderMagicDrop.ItemIndex; //0=unkown, 1=nifti hdr+img, 2=nifti .nii embedded + if lHdrIndex = 1 then begin//nifti hdr+img, offset must be = 0 + OffsetEdit.MinValue := 0; + OffsetEdit.Enabled := false; + OffsetEdit.value := 0; + end else if lHdrIndex = 2 then begin//embedded header, offset must be at least 348 + OffsetEdit.Enabled := true; + if OffsetEdit.value < sizeof(TNIFTIHdr) then + OffsetEdit.value := sizeof(TNIFTIHdr); + OffsetEdit.MinValue := sizeof(TNIFTIHdr); + end else begin //no embedded header... therefore offset can be zero + OffsetEdit.MinValue := 0; + OffsetEdit.Enabled := true; + + if OffsetEdit.value = sizeof(TNIFTIHdr) then + OffsetEdit.value := 0; + end; +end; + + +end. diff --git a/nifti_img.pas b/nifti_img.pas new file mode 100755 index 0000000..a4729dc --- /dev/null +++ b/nifti_img.pas @@ -0,0 +1,5933 @@ +unit nifti_img; +interface +uses +{$H+} +{$IFNDEF FPC} +RXSpin,capmenu,PNGImage,SSE,ShellAPI,Spin, +{$ENDIF} +{$IFNDEF Unix} Windows, +{$ELSE} + //RGBGraphics,rgbroutines, +{$ENDIF} +nifti_types, +SysUtils, Classes, Graphics, Controls, Forms, Dialogs, GraphType, + Menus, ExtCtrls, NIFTI_hdr,nii_label, +Math,ClipBrd,define_types, + GraphicsMathLibrary,Distr,Stat,ReadInt,gzio2; +const + kMultiView = 0; + kAxView0 = 1; + kSagView0 = 2; + kCoroView0 = 3; + kAxViewOnly = -1; + kSagViewOnly = -2; + kCoroViewOnly = -3; + kMaxLabel = 255; +Type + + TBGImg = record //Next: analyze Format Header structure + ScrnDim: array [1..3] of smallint; + ScrnMM,ScrnOri: array [1..3] of single; + XViewCenter,YViewCenter,ZViewCenter: single; + SliceView,SPMDefaultsStatsFmriT,SPMDefaultsStatsFmriT0, + MaxDim,LicenseID,XBarGap,XBarThick,VOIUndoSlice,VOIUndoOrient,VOIUndoVolItems, + RenderDepthBufferItems,VOIInvZoom,ZoomPct,BGTransPct,OverlayTransPct, PlanarRGB, + ImageSeparation,RenderDim,SigDig,LesionSmooth,LesionDilate,FontSize, SaveImgFilter, SaveVoiFilter: integer; + //ResizeBeforeRescale - 0=intensity rescale, then resize; 1= nearest neighbor resize, then rescale;1=trilinear resize, then rescale;12:47 PM 7/13/2006 + UseReorientHdr,XBarVisible,ThinPen,Mirror,OverlaySmooth,VOIchanged,VOImirrored, + SaveDefaultIni,KnownAlignment,Resliced, + FlipAx,FlipSag,SingleRow,ResliceOnLoad,Prompt4DVolume,OrthoReslice, ShowDraw: boolean; + MinChar,MaxChar: array [1..3] of char; //May07 + StretchQuality : TStretchQuality; + VOIClr,XBarClr: TColor; + BackupLUT: TLUT; + //LabelStr20 : Array[0..kMaxLabel] of kstr50; + LabelRA: TStrRA; + {FSLDIR,}FSLBASE,FSLOUTPUTTYPE{,FSLBETEXE}: kStr255; + InvMat: TMatrix; + ReorientHdr: TNIFTIHdr; + //Cutout: TCutout; + VOIUndoVol: bytep; + RenderDepthBuffer: SmallIntp; + end; //TNIFTIhdr Header Structure + procedure CreateAnaRGB; + function SlicesToImgPos(lX,lY,lZ: integer): integer; + procedure ImgPosToSlices(lPos: integer; var lX,lY,lZ: integer); +procedure DrawBMP( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +procedure IntenBar (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer {1=Left,2=Top,3=right,4=bottom}; lMin,lMax: single); +procedure Balance (var lHdr: TMRIcroHdr); +function ImgVaries ( var lHdr: TMRIcroHdr): boolean; +function OpenImg(var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground,lVOILoadAsBinary,lNoScaling8bit,lResliceIn,l4D: boolean): boolean; +procedure InitImgMemory(var lHdr: TMRIcroHdr); +procedure FreeImgMemory(var lHdr: TMRIcroHdr); +procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +//procedure RescaleImgIntensity(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr ); + procedure RescaleImgIntensity(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lLayer: integer ); +procedure LoadColorScheme(lStr: string; var lHdr: TMRIcroHdr); +procedure LoadMonochromeLUT (var lLUT: integer; var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); //lLUT: 0=gray,1=red,2=green,3=blue +procedure FilterLUT (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lMin, lMax: integer); //lLUT: 0=gray,1=red,2=green,3=blue +function Raw2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +function Scaled2RawIntensity (lHdr: TMRIcroHdr; lScaled: single): single; +procedure AlphaBlend32(lBGQuad,lOverlayQuad : RGBQuadp; lBG0Clr,lOverlay0Clr: DWord; lSlicePixels, lOverlayTransPct: integer); // 630 +procedure SetBGImgDefaults (var lBGImg: TBGImg); +function MaxDim (lX,lY,lZ: integer): integer; //returns largest of 3 +procedure DrawHistogram (var lHdr: TMRIcroHdr; var lImage: TImage); +function MirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +procedure MirrorScrnBuffer(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr ); +procedure SetSubmenuWithTag (var lRootMenu: TMenuItem; lTag: Integer); +procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +procedure SaveAsVOIorNIFTI (var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; DefaultFormatVOI: boolean; var lNiftiHdr: TNIFTIHdr; lDefFilename: string); +function Scrn2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +procedure ScaleScrn2BMP (var lX, lY: integer;lImage: TImage); +procedure DrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +function ImageZoomPct( var lImage: TImage): integer; +procedure ScaleBMP2Draw (var InvZoomShl10,lX, lY,lPanel: integer; lImage: TImage); +function ComputeInvZoomShl10(lSelectedImageNum: integer; var lImage: TImage): integer; +function ComputeZoomPct(lSelectedImageNum: integer; var lImage: TImage): integer; +function SelectedImageNum: Integer; +procedure EnsureVOIOpen; +procedure FreeUndoVol; +procedure CreateUndoVol; +procedure UndoVolVOI; +function IsVOIOpen: boolean; +//procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +procedure SaveImgAsPNGBMP (lImage: TImage); +procedure RefreshImages; +procedure DrawAxial (lSlice,lMultiSlice: integer); +procedure DrawSag(lSlice,lMultiSlice: integer); +procedure DrawCor(lSlice,lMultiSlice: integer); +procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +procedure ImgCoordToMM(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +procedure MMToImgCoord(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +//function DimToMM (lIn, lDim: integer): integer; +function DimToMM (lX,lY,lZ, lDim: integer): integer; +function DimToMMx (lDim: integer): integer; +procedure ImgPosToMM(lPos: integer; var lXmm,lYmm,lZmm: single); +procedure MakeStatHdr (var lBGHdr,lStatHdr: TMRIcroHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +function CenterOfMass (lOverlay: integer; var lX,lY,lZ: double): integer; +procedure TextReportHisto (var lHdr: TMRIcroHdr); +function TColor2TRGBQuad(lColor: TColor): TRGBQuad; +function TRGBQuad2DWord (lLUT: TRGBQuad): DWord; +procedure ReturnMinMax (var lHdr: TMRIcroHdr; var lMin,lMax: single; var lFiltMin8bit, lFiltMax8bit: integer); +function RawBGIntensity(lPos: integer): single; + +//procedure FreeImgMemory(var lHdr: TMRIcroHdr); + + +const +gSelectedImageNum :integer= 1; +//gTripleZoom100: integer = 1; +//gImgSpacing: integer = 1; +implementation + +uses nifti_img_view,MultiSlice,histoform,text, ortho_reorient, reslice_img; + +function RawBGIntensity(lPos: integer): single; +var + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + result := 0; + if (lPos > gMRIcroOverlay[kBGOverlayNum].ImgBufferItems) or (lPos < 1) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l32Buf^[lPos]; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l16Buf^[lPos]; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then + result := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos] + else begin + showmessage('Unknown Background Buffer Bytes Per Pixel'); + exit; + end; +end; + +function TRGBQuad2DWord (lLUT: TRGBQuad): DWord; +var + inguy : ^DWord; +begin + inguy := @lLUT; + result := inguy^; +end; + +function TRGBQuad2TColor (lLUT: TRGBQuad): TColor; +begin + result := (lLUT.rgbred)+(lLUT.rgbgreen shl 8)+(lLUT.rgbblue shl 16); +end; + +function TColor2TRGBQuad(lColor: TColor): TRGBQuad; +begin + result.rgbRed := (lColor and 255) ; + result.rgbGreen := (lColor shr 8) and 255 ;// and 65280; + result.rgbBlue := ((lColor shr 16) and 255) ;//and 16711680; + result.rgbReserved := kLUTalpha; +end; + +procedure InitImgMemory(var lHdr: TMRIcroHdr); +begin + with lHdr do begin + RenderBufferItems := 0; + ScrnBufferItems := 0; + ImgBufferItems := 0; + end; +end; + + + + +function CenterOfMass (lOverlay: integer; var lX,lY,lZ: double): integer; +//result is volume in voxels - 0 = no volume or error +var + lXpos,lYpos,lZpos,lInc: integer; + +begin + result := 0; + lX := 0; + lY := 0; + lZ := 0; + //fx((gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1]*gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2]* gMRIcroOverlay[lOverlay].NIFTIhdr.dim[3]), gMRIcroOverlay[lOverlay].ScrnBufferItems); + + if (gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1]*gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2]* gMRIcroOverlay[lOverlay].NIFTIhdr.dim[3]) <> gMRIcroOverlay[lOverlay].ScrnBufferItems then + exit; + //fx(999); + lInc := 0; + for lZpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[3] do begin + for lYpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2] do begin + for lXpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1] do begin + inc(lInc); + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lInc] > 0 then begin + inc(result); + lX := lX + lXpos; + lY := lY + lYpos; + lZ := lZ + lZpos; + end; + end; //lX + end;//Y + end;//Z + //fx(lX,lY,lZ); + if result > 0 then begin + lX := lX / result; + lY := lY / result; + lZ := lZ / result; + end; + //lARDistance := round(sqrt( sqr(lRX-lAX)+sqr(lRY-lAY)+sqr(lRZ-lAZ))); //<- pythagorean theorem for dx +end; + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TMRIcroHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +//lIntent kNIFTI_INTENT_CHISQ lIntent_p1 = DOF +//lIntent kNIFTI_INTENT_ZSCORE no params +//lIntent kNIFTI_INTENT_TTEST lIntent_p1 = DOF +var lIntentNameLen,lPos: integer; +begin + with lStatHdr do begin + move(lBGHdr.niftiHdr,lStatHdr.niftiHdr,sizeof(TniftiHdr)); + ImgBufferBPP := 1; + ImgBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + NIFTIhdr.scl_slope:= 1; + NIFTIhdr.scl_inter:= 0; + NIFTIhdr.glmin := round(lMinIntensity); + NIFTIhdr.glmax := round(lMaxIntensity); + AutoBalMinUnscaled := lMinIntensity; + AutoBalMaxUnscaled := lMaxIntensity; + WindowScaledMin := lMinIntensity; + WindowScaledMax := lMaxIntensity; + GlMinUnscaledS := lMinIntensity; + GlMaxUnscaledS := lMaxIntensity; + HdrFileName := extractfilepath(HdrFilename)+'stat.nii.gz'; + ImgFileName := HdrFileName; + NIFTIhdr.intent_code := lIntent_Code;// kNIFTI_INTENT_ESTIMATE; + NIFTIhdr.intent_p1 := lIntent_p1; + NIFTIhdr.intent_p2 := lIntent_p2; + NIFTIhdr.intent_p3 := lIntent_p3; + lIntentNameLen := length(lIntentName); + if lIntentNameLen > sizeof(NIFTIhdr.intent_name) then + lIntentNameLen := sizeof(NIFTIhdr.intent_name); + if lIntentNameLen > 0 then + for lPos := 1 to lIntentNameLen do + NIFTIhdr.intent_name[lPos] := lIntentName[lPos]; + end; +end; + +procedure MMToImgCoord(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +var + lXx,lYy,lZz: single; +begin + if (not gBGImg.Resliced) and ( gMRIcroOverlay[kBGOverlayNum].NIfTItransform) then begin//vcx + //mirror + lxx := lXmm; + lyy := lYmm; + lzz := lZmm; + mm2Voxel (lxx,lyy,lzz, gBGImg.InvMat); + if gBGImg.Mirror then + lXx := gBGImg.ScrnDim[1]-lXx; + lX := round(lxx); + ly := round(lyy); + lz := round(lzz); + exit; + end; + + if gBGImg.Mirror then + lX := round((gBGImg.ScrnDim[1]-gBGImg.ScrnOri[1]+1)-(lXmm/gBGImg.ScrnMM[1])) + else + lX := round((lXmm/gBGImg.ScrnMM[1])+gBGImg.ScrnOri[1]); + lY := round((lYmm/gBGImg.ScrnMM[2])+gBGImg.ScrnOri[2]); + lZ := round((lZmm/gBGImg.ScrnMM[3])+gBGImg.ScrnOri[3]); + if lX < 1 then lX := 1; + if lY < 1 then lY := 1; + if lZ < 1 then lZ := 1; + if lX > gBGImg.ScrnDim[1] then lX := gBGImg.ScrnDim[1]; + if lY > gBGImg.ScrnDim[2] then lY := gBGImg.ScrnDim[2]; + if lZ > gBGImg.ScrnDim[3] then lZ := gBGImg.ScrnDim[3]; +end; + +(*2008 +procedure MMToImgCoord(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +begin + lX := round((lXmm/gBGImg.ScrnMM[1])+gBGImg.ScrnOri[1]); + lY := round((lYmm/gBGImg.ScrnMM[2])+gBGImg.ScrnOri[2]); + lZ := round((lZmm/gBGImg.ScrnMM[3])+gBGImg.ScrnOri[3]); + if lX < 1 then lX := 1; + if lY < 1 then lY := 1; + if lZ < 1 then lZ := 1; + if lX > gBGImg.ScrnDim[1] then lX := gBGImg.ScrnDim[1]; + if lY > gBGImg.ScrnDim[2] then lY := gBGImg.ScrnDim[2]; + if lZ > gBGImg.ScrnDim[3] then lZ := gBGImg.ScrnDim[3]; +end; *) + +(*procedure ImgCoordToMM(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +begin + lXmm := ((lX)-gBGImg.ScrnOri[1])*gBGImg.ScrnMM[1]; + lYmm := ((lY)-gBGImg.ScrnOri[2])*gBGImg.ScrnMM[2]; + lZmm := ((lZ)-gBGImg.ScrnOri[3])*gBGImg.ScrnMM[3]; +end; *) + +procedure ImgCoordToMM(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +begin + if (not gBGImg.Resliced) and ( gMRIcroOverlay[kBGOverlayNum].NIfTItransform) then begin//vcx + //mirror + lXmm := lX; + if gBGImg.Mirror then + lXmm := gBGImg.ScrnDim[1]-lXmm; + lYmm := lY; + lZmm := lZ; + Voxel2mm (lxmm,lymm,lzmm, gMRIcroOverlay[kBGOverlayNum].NIftiHdr); + exit; + end; +if gBGImg.Mirror then lXmm := ((gBGImg.ScrnDim[1]-lX+1)-gBGImg.ScrnOri[1])*gBGImg.ScrnMM[1] else + + lXmm := ((lX)-gBGImg.ScrnOri[1])*gBGImg.ScrnMM[1]; + lYmm := ((lY)-gBGImg.ScrnOri[2])*gBGImg.ScrnMM[2]; + lZmm := ((lZ)-gBGImg.ScrnOri[3])*gBGImg.ScrnMM[3]; +end; + +function XPos(lPos,XDim: integer): integer; //given 1D array return 3D column +begin + result := lPos mod XDim; + if result = 0 then + result := XDim; +end; + +function ZPos(lPos, XDimTimesYDim: integer): integer; //given 1D array return 3D slice +begin + result := lPos div XDimTimesYDim; + if (lPos mod XDimTimesYDim) <> 0 then + inc(result); +end; + +function YPos(lPos, XDim,YDim: integer): integer; //given 1D array return 3D row +var + lSlicePos: integer; +begin + //first - eliminate slice offset + result := ZPos(lPos,XDim*YDim); + lSlicePos := lPos - ((result-1)*(XDim*YDim)); + //now find row + result :=lSlicePos div XDim; + if (lSlicePos mod XDim) <> 0 then + inc(result); +end; + +(*function XPos(lPos,XDim: integer): integer; //given 1D array return 3D column +begin + result := lPos mod XDim; + if result = 0 then + result := XDim; +end; + +function ZPos(lPos, XDimTimesYDim: integer): integer; //given 1D array return 3D slice +begin + result := lPos div XDimTimesYDim; + if (lPos mod XDimTimesYDim) <> 0 then + inc(result); +end; + +function YPos(lPos, XDim,YDim: integer): integer; //given 1D array return 3D row +var + lSlicePos: integer; +begin + //first - eliminate slice offset + result := ZPos(lPos,XDim*YDim); + lSlicePos := lPos - ((result-1)*(XDim*YDim)); + //now find row + result :=lSlicePos div XDim; + if (lSlicePos mod XDim) <> 0 then + inc(result); +end; *) + +function SlicesToImgPos(lX,lY,lZ: integer): integer; +begin + result := lX + ((lY-1) * gBGImg.ScrnDim[1])+ ((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); +end; +procedure ImgPosToSlices(lPos: integer; var lX,lY,lZ: integer); +begin + lX := XPos(lPos,gBGImg.ScrnDim[1]); + lY := YPos(lPos,gBGImg.ScrnDim[1],gBGImg.ScrnDim[2]); + lZ := ZPos(lPos,gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); +end; + + +procedure ImgPosToMM(lPos: integer; var lXmm,lYmm,lZmm: single); +var lX,lY,lZ: integer; +begin + lX := XPos(lPos,gBGImg.ScrnDim[1]); + lY := YPos(lPos,gBGImg.ScrnDim[1],gBGImg.ScrnDim[2]); + lZ := ZPos(lPos,gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + ImgCoordToMM(lX,lY,lZ, lXmm,lYmm,lZmm); +//xxx lPos := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); +end; + +(*function DimToMM (lIn, lDim: integer): integer; +var + lX,lY,lZ: integer; + lXmm,lYmm,lZmm: single; +begin + + lX := lIn; + lY := lIn; + lZ := lIn; + //if lDim = 2 then imgform.caption := inttostr(lY)+'-'; + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + case lDim of + 3: result := round(lZmm); + 2: result := round(lYmm); + else result := round(lXmm); + end; //case + //imgform.caption := floattostr(lYmm); +end; //DimToMM *) +function DimToMM (lX,lY,lZ, lDim: integer): integer; +//Sept2008 - X/Y/Z required for rotated images +var + lXi,lYi,lZi: integer; + lXmm,lYmm,lZmm: single; +begin + lXi := lX; + lYi := lY; + lZi := lZ; + ImgCoordToMM(lXi,lYi,lZi,lXmm,lYmm,lZmm); + //imgform.Caption := floattostr(lxmm)+' '+floattostr(lymm)+' '+floattostr(lzmm)+' 666'; + case lDim of + 3: result := round(lZmm); + 2: result := round(lYmm); + else result := round(lXmm); + end //case +end; //DimToMM + +function DimToMMx (lDim: integer): integer; +var + lX,lY,lZ: integer; +begin + lX := round(ImgForm.XViewEdit.value); + lY := round(ImgForm.YViewEdit.value); + lZ := round(ImgForm.ZViewEdit.value); + result := DimToMM(lX,lY,lZ,lDim); +end; //DimToMM + + +procedure DrawTextLabel(var lImage: TImage; lOutStr: string; lXCenterIn,lXWidthIn: integer); +var + lXWidth,lXCenter: integer; +begin + lXWidth := lXWidthIn; + lXCenter:= lXCenterIn; + if lXWidth < 1 then begin + lXWidth := lImage.Picture.Bitmap.Width; + end; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + {$IFDEF Darwin} + lImage.Canvas.Font.Name := 'Helvetica'; + + {$ELSE} + lImage.Canvas.Font.Name := 'Arial'; + {$ENDIF} + lImage.Canvas.Font.Size := gBGImg.FontSize; + (*if lXWidth < 100 then + lImage.Canvas.Font.Size := 12 + else if lXWidth < 200 then + lImage.Canvas.Font.Size := 14 + else + lImage.Canvas.Font.Size := 18; *) + //lImage.Canvas.Font.Size := 18; + if lXCenterIn < 1 then + lImage.canvas.TextOut(2,1,lOutStr) + else if lXCenterIn = MaxInt then + lImage.canvas.TextOut((lXWidth div 2)-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) + else + lImage.canvas.TextOut(lXCenter-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) +end; + +procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +begin + DrawTextLabel(lImage,inttostr(lValue),lXCenterIn,lXWidthIn); +end; + +procedure DrawTextLabelV(var lImage: TImage; lOutStr: string); +var + lYHt: integer; +begin + lYHt := lImage.Picture.Bitmap.Height; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + lImage.canvas.TextOut(2,(lYHt div 2)-round(0.5*lImage.Canvas.TextHeight('X')),lOutStr) +end; + +(*procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +var + lOutStr: string; + lXWidth,lXCenter: integer; +begin + lXWidth := lXWidthIn; + lXCenter:= lXCenterIn; + if lXWidth < 1 then begin + lXWidth := lImage.Picture.Bitmap.Width; + end; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + if lXWidth < 100 then + lImage.Canvas.Font.Size := 9 + else if lXWidth < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14; + lOutStr := inttostr(lValue); + if lXCenterIn < 1 then + lImage.canvas.TextOut(2,1,lOutStr) + else if lXCenterIn = MaxInt then + lImage.canvas.TextOut((lXWidth div 2)-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) + else + lImage.canvas.TextOut(lXCenter-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) +end;*) + + + {$IFNDEF FPC} +procedure PasteDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lImage: TImage; lXOffset: integer); +var + sbBits : PByteArray; + lPGWid,lPGHt,nBytesInImage: integer; + lBMP: TBitmap; + lSrcRect,lDestRect: TRect; +begin + if lXOffset < 1 then begin + showmessage('Error with paste dimension - XOffset is <1!'); + exit; + end; + lPGWid := lInPGWid; + lPGHt := lInPGHt; + lBMP := TBitmap.Create; + TRY + lBMP.PixelFormat := pf32bit; + lBMP.Width := lPGwid; + lBMP.Height := lPGHt; + sbBits := lBmp.ScanLine[lPGHt-1]; + nBytesInImage := lPGWid*lPGHt * 4; + CopyMemory(Pointer(sbBits),Pointer(lBuff),nBytesInImage); + lImage.Canvas.CopyMode := cmSrcCopy; + lSrcRect := Rect(0,0,lBMP.Width,lBMP.Height); + lDestRect := Rect(lXOffset,0,lXOffset+lBMP.Width,lBMP.Height); + lImage.Canvas.CopyRect(lDestRect,lBMP.Canvas,lSrcRect); + FINALLY + lBMP.Free; + END; //try..finally +end; //proc PasteDimension32 + {$ELSE} +//PasteDimension32 FPC +procedure PasteDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; lXOffset: integer); +var + lRowStart,x, y,lPos: Integer; +begin + if lBuff = nil then exit; + lPos := 0; + for y:= (lInPGHt-1) downto 0 do begin + lRowStart := (y * gMultiWid)+lXOffset; + for x:=0 to lInPGWid-1 do begin + //dec(lPos); + inc(lPos); + gMultiBuff^[lRowStart+x] := lBuff^[lPos]; + end; + end; +end; + {$ENDIF} + +procedure CreateSag(var lHdr: TMRIcroHdr; lX,lXOffset,lY,lZ,lXYSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + //lLongBuff: LongIntp; + lPixel,lYPos,lZPos,lZOffset,lYOffset: integer; +begin + lSrc := lHdr.ScrnBuffer; + lPixel := 0; + // lLongBuff := LongIntp(lQuadP); + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + lQuadP^[lPixel] := lHdr.LUT[lSrc^[lZOffset+lYOffset+lXOffset]]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z +end; //CreateSag + + +procedure MirrorSlice (lY,lX: integer; lImage: RGBQuadp); +var + lRowData: RGBQuadp; + lXi,lYi,lHalfX,lRowBytes,lTop: integer; +begin + if lX < 2 then exit; + lRowBytes := lX * 4; + getmem(lRowData,lRowBytes); + lHalfX := lX div 2; + lTop := 1; + for lYi := 1 to lY do begin + Move(lImage^[lTop],lRowData^[1],lRowBytes); + for lXi := 1 to lX do + lImage^[lTop+lXi-1] := lRowData^[lX - lXi + 1]; + lTop := lTop + lX; + end; + freemem(lRowData); +end; + +procedure DrawSag (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lOverlay,lnOverlay,lXOffset, lX,lY,lZ,lXYSliceSz,lYZSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lXOffset := round(lSlice); + lXYSliceSz := (lX*lY); + lYZSliceSz := (lY*lZ); + if (lXOffset > lX) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lXOffset < 1 {999+}) or (lXYSliceSz < 1) then + exit; + if (lZ < 2) then begin + SetDimension32(1,1, nil, gBGImg, ImgForm.PGImageSag, ImgForm.TriplePanel); + exit; + end; + GetMem ( lBGQuadP , lYZSliceSz*4); + CreateSag(gMRIcroOverlay[kBGOverlayNum], lX,lXOffset,lY,lZ,lXYSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +lBG0Clr:= TRGBQuad2DWord(gMRIcroOverlay[kBGOverlayNum].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lYZSliceSz*4); + lBG0Clr:= TRGBQuad2DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateSag(gMRIcroOverlay[lOverlay], lX,lXOffset,lY,lZ,lXYSliceSz, lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lYZSliceSz*4); + CreateSag(gMRIcroOverlay[lOverlay], lX,lXOffset,lY,lZ,lXYSliceSz, l2ndOverlayQuadP); + lOverlay0Clr:= TRGBQuad2DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lYZSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible [no alpha] DWord(lHdr.LUTinvisible); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lYZSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + if gBGImg.FlipSag then + MirrorSlice (lZ,lY, lBGQuadP); + if lMultiSlice >= 0 then + PasteDimension32(lZ,lY, lBGQuadP,lMultiSlice)//, MultiSliceForm.MultiImage,lMultiSlice) + else begin + SetDimension32(lZ,lY, lBGQuadP, gBGImg, ImgForm.PGImageSag, ImgForm.TriplePanel); + FreeMem ( lBGQuadP); + if gBGImg.XBarVisible then begin + + if gBGImg.FlipSag then + DrawXBar ( round(lY-gBGImg.YViewCenter), round(gBGImg.ZViewCenter),ImgForm.PGImageSag) + else + DrawXBar ( round(gBGImg.YViewCenter), round({lZ-}gBGImg.ZViewCenter),ImgForm.PGImageSag); + DrawLabel(ImgForm.PGImageSag, DimToMMx(1),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageSag,gBGImg.MaxChar[3]{'S'},MaxInt,-1); + if gBGImg.FlipSag then + DrawTextLabelV(ImgForm.PGImageSag,gBGImg.MaxChar[2]) + else + DrawTextLabelV(ImgForm.PGImageSag,gBGImg.MinChar[2]{'P'}); + end; + end; //XBars + end; //draw +end; + +procedure CreateCor(var lHdr: TMRIcroHdr; lX,lYOffset,lZ,lXYSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + lPixel,lXPos,lZPos,lZOffset: integer; +begin + lSrc := lHdr.ScrnBuffer; + lPixel := 0; + //fx(lYOffset); + for lZPos := 1 to (lZ) do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + lQuadP^[lPixel]:=lHdr.LUT[lSrc^[lZOffset+lYOffset+lXPos]];//+1 Mac??? + + end; //for each Y + end; //for each Z + {$IFDEF ENDIAN_BIG} + lPixel := random(255); + //fixes strange PPC compiler bug where lS value in DrawCor is corrupted + //bug only seen in Lazarus IDE + {$ENDIF} +end; + +procedure DrawCor (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lOverlay,lnOverlay, lYOffset, lX,lY,lZ,lS,lXYSliceSz,lXZSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lS := round(lSlice); + lXYSliceSz := (lX*lY); + lXZSliceSz := (lX*lZ); + lYOffset := (lX) * (lS-1); + if (lS > lY) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 1 {999+}) or (lXYSliceSz < 1) then + exit; + if (lZ < 2) then begin + SetDimension32(1,1, nil, gBGImg, ImgForm.PGImageSag, ImgForm.TriplePanel); + //these do not work when image is stretched + //ImgForm.PGImage3.Width := 1; + //ImgForm.PGImage3.Height := 1; + exit; + end; + + GetMem ( lBGQuadP , (lXZSliceSz*4)); +//imgform.caption := inttostr(lS)+'x666'; + CreateCor(gMRIcroOverlay[kBGOverlayNum], lX,lYOffset,lZ,lXYSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +//imgform.caption := inttostr(lS)+'x666'; +lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lXZSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateCor(gMRIcroOverlay[lOverlay], lX,lYOffset,lZ,lXYSliceSz, lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lXZSliceSz*4); + CreateCor(gMRIcroOverlay[lOverlay], lX,lYOffset,lZ,lXYSliceSz, l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lXZSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUTinvisible); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lXZSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + if lMultiSlice >= 0 then + PasteDimension32(lZ,lX, lBGQuadP,lMultiSlice)// MultiSliceForm.MultiImage,lMultiSlice) + else begin + SetDimension32(lZ,lX, lBGQuadP, gBGImg,ImgForm.PGImageCor, ImgForm.TriplePanel); + if {ImgForm.XBarBtn.Down}gBGImg.XBarVisible then begin + DrawXBar ( round(gBGImg.XViewCenter), round({lZ-}gBGImg.ZViewCenter),ImgForm.PGImageCor); + DrawLabel(ImgForm.PGImageCor, DimToMMx(2),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageCor,gBGImg.MaxChar[3]{'S'},MaxInt,-1); + if gBGImg.Mirror then + DrawTextLabelV(ImgForm.PGImageCor,gBGImg.MaxChar[1]{'R'}) + else + DrawTextLabelV(ImgForm.PGImageCor,gBGImg.MinChar[1]{'L'}); + end; + + end; //XBar + end; + FreeMem ( lBGQuadP); +end; + +procedure CreateAxial(var lHdr: TMRIcroHdr; lStart,lSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + lPixel: integer; +begin + lSrc := lHdr.ScrnBuffer; + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:=lHdr.LUT[lSrc^[lStart+lPixel]]; + //abba lQuadP^[200]:=lHdr.LUT[255]; +end; + +procedure FlipSlice (lY,lX: integer; lImage: RGBQuadp); +var + lRowData: RGBQuadp; + lYi,lHalfY,lRowBytes,lTop,lBottom: integer; +begin + if lY < 2 then exit; + lRowBytes := lX * 4; + getmem(lRowData,lRowBytes); + lHalfY := lY div 2; + lTop := 1; + lBottom := ((lY-1)*lX)+1; + for lYi := 1 to lHalfY do begin + Move(lImage^[lTop],lRowData^[1],lRowBytes); + Move(lImage^[lBottom],lImage^[lTop],lRowBytes); + Move(lRowData^[1],lImage^[lBottom],lRowBytes); + lTop := lTop + lX; + lBottom := lBottom - lX; + end; + freemem(lRowData); +end; + + +procedure DrawAxial (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lnOverlay,lOverlay, lX,lY,lS,lStart,lSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lS := round(lSlice{ImgForm.ZViewEdit.value}); + lSliceSz := (lX * lY{*lByte}); + lStart := lX*lY*(lS-1); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 0) or (lX < 2) or (lStart < 0) or (lSliceSz < 1) or ((lStart+lSliceSz-1) > gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then + exit; + GetMem ( lBGQuadP, lSliceSz*4); + CreateAxial(gMRIcroOverlay[kBGOverlayNum], lStart,lSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + if gBGImg.FlipAx then + FlipSlice (lY,lX, lBGQuadP); + if lMultiSlice >= 0 then + PasteDimension32(lY,lX, lBGQuadP, lMultislice)//MultiSliceForm.MultiImage,lMultiSlice) + else begin + SetDimension32(lY,lX, lBGQuadP, gBGImg, ImgForm.PGImageAx, ImgForm.TriplePanel); + if {ImgForm.XBarBtn.Down}gBGImg.XBarVisible then begin + if gBGImg.FlipAx then + lS := round(lY-gBGImg.YViewCenter) + else + lS := round(gBGImg.YViewCenter); + DrawXBar ( round(gBGImg.XViewCenter), lS{round(gBGImg.YViewCenter)},ImgForm.PGImageAx); + DrawLabel(ImgForm.PGImageAx, DimToMMx(3),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageAx,gBGImg.MaxChar[2]{'A'},MaxInt,-1); + if gBGImg.Mirror then + DrawTextLabelV(ImgForm.PGImageAx,gBGImg.MaxChar[1]{'R'}) + else + DrawTextLabelV(ImgForm.PGImageAx,gBGImg.MinChar[1]{'L'}); + end; + end; //XBar + + end; + FreeMem ( lBGQuadP); +end; //DrawAxial + +procedure DrawAxialCore (lSlice: integer; var lBGQuadP: RGBQuadp); +var + lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lnOverlay,lOverlay, lX,lY,lS,lStart,lSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lS := round(lSlice{ImgForm.ZViewEdit.value}); + lSliceSz := (lX * lY{*lByte}); + lStart := lX*lY*(lS-1); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 0) or (lX < 2) or (lStart < 0) or (lSliceSz < 1) or ((lStart+lSliceSz-1) > gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then + exit; + CreateAxial(gMRIcroOverlay[kBGOverlayNum], lStart,lSliceSz, lBGQuadP); + //next: overlays + lnOverlay := 0; + lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... + for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded + end; //for knOverlay..1 + //Finally: draw overlays on BG + if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); + end; +end; //DrawAxialCore + +procedure SegmentRGBplanes (lSlice,lXVox,lYVox: integer; var lSliceQuadP: RGBQuadp; var lImg3: bytep; isPlanarRGB: boolean); +//analyze RGB saves data as red, green blue planes +var + lLineOffset,lHalfX,lX,lY,lPos,lOutStart,lSliceVox: integer; + lTempQuadP: TRGBQuad; + +begin + lSliceVox := lXVox*lYVox; + if lSliceVox < 1 then exit; + if (ImgForm.FlipLRmenu.checked) and (lXVox > 1) then begin + lHalfX := lXVox div 2; + lLineOffset := 0; + for lY := 1 to lYVox do begin + for lX := 1 to lHalfX do begin + lTempQuadP := lSliceQuadP^[lX+lLineOffset]; + lSliceQuadP^[lX+lLineOffset] := lSliceQuadP^[1+lXVox-lX+lLineOffset]; + lSliceQuadP^[1+lXVox-lX+lLineOffset] := lTempQuadP; + end; //for X + lLineOffset := lLineOffset + lXVox; + end;//lY + + end; //mirror + if isPlanarRGB then begin + // + lOutStart := (lSlice-1)*lSliceVox*3; + for lPos := 1 to lSliceVox do begin + lImg3^[lPos+lOutStart] := lSliceQuadP^[lPos].rgbRed; + lImg3^[lPos+lOutStart+lSliceVox] := lSliceQuadP^[lPos].rgbGreen; + lImg3^[lPos+lOutStart+lSliceVox+lSliceVox] := lSliceQuadP^[lPos].rgbBlue; + end; + end else begin + lOutStart := (lSlice-1)*lSliceVox*3; + for lPos := 1 to lSliceVox do begin + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbRed; + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbGreen; + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbBlue; + end; + + end; + +end; + +procedure CreateAnaRGB; +var + lFilename: string; + lImg3: bytep; + lSliceQuadP: RGBQuadp; + lVolVox,lX,lY,lZ,lI,lnSlice: integer; + isPlanarRGB : boolean; +begin + ImgForm.SaveDialog1.Filter := 'NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.nii)|*.nii|NIfTI (.hdr/.img)|*.hdr|Volume of Interest(.voi)|*.voi|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.DefaultExt := '.hdr'; + ImgForm.SaveDialog1.Filename := ChangeFileExt(ImgForm.SaveDialog1.Filename, ImgForm.SaveDialog1.DefaultExt); //10102006 + if not ImgForm.SaveDialog1.Execute then exit; + isPlanarRGB := false; + case MessageDlg('Save as modern NIfTI style (RGBRGB..)? Press cancel for Analyze style (RR..RGG..GBB..B)?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: isPlanarRGB := true; + end; //case + + lFilename := ImgForm.SaveDialog1.Filename; + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lVolVox := lX*lY*lZ ; + if DiskFreeEx(lFilename) < (lVolVox*3) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; + + getmem(lImg3, lVolVox* 3) ; + //for Sag + lnSlice := lZ; + //fx(lX,lY,lZ); + getmem(lSliceQuadP, lX*lY* sizeof(TRGBQuad)) ; + for lI := 1 to lnSlice do begin //[1+ ((lI-1)*lSliceBytes)] + + DrawAxialCore (lI,lSliceQuadP ); + //SegmentRGBplanes (lI,lX,lY,lSliceQuadP,lImg3, gGBImg.isPlanarRGB); + SegmentRGBplanes (lI,lX,lY,lSliceQuadP,lImg3, isPlanarRGB); + end; + freemem(lSliceQuadP); + //output data + SaveAsVOIorNIFTIcore (lFilename, lImg3, lVolVox, 3,1, gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + freemem(lImg3); +end; + +procedure ComputeTripleZoom; +//computes axial, coronal and sagittal zoom +//values are SHL 10, so a 1% signal change will be 1024 +//this preserves precision (though at the moment we round to nearest 1%) +label 543,641; +//const +// kSHval = 1 shl 10; +procedure SetPct(lAfrac,lCfrac,lSfrac: single); +begin + ImgForm.PGImageAx.Tag := trunc(lAfrac*100); + ImgForm.PGImageCor.Tag := trunc(lCfrac*100) ; + ImgForm.PGImageSag.Tag := trunc(lSfrac*100) ; +end; +var + lHpanel,lWpanel,lH,lW: integer; + lPrimaryZoom,l2ndZoom,lZoomw,lZoomh: single; +begin + SetPct(1,1,1); + lHpanel := ImgForm.TriplePanel.ClientHeight-1; + lWpanel := ImgForm.TriplePanel.ClientWidth-1; + //gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + if gBGImg.ZoomPct > 0 then begin + SetPct(gBGImg.ZoomPct/100,gBGImg.ZoomPct/100,gBGImg.ZoomPct/100); + lPrimaryZoom := ImgForm.PGImageAx.Tag/100; + if abs(gBGImg.SliceView) <> kSagView0 then + lW := gBGImg.ScrnDim[1] //Axial and Coronal width is X + else + lW := gBGImg.ScrnDim[2]; //Sagittal width is Y + goto 543; + exit; + end; + if (abs(gBGImg.SliceView) = kAxView0) or(abs(gBGImg.SliceView) = kCoroView0) or(abs(gBGImg.SliceView) = kSagView0) then begin //only show a single slice + if abs(gBGImg.SliceView) <> kAxView0 then + lH := gBGImg.ScrnDim[3] //Coronal and Sagitall height is Z + else + lH := gBGImg.ScrnDim[2]; //Axial height is Y + + if abs(gBGImg.SliceView) <> kSagView0 then + lW := gBGImg.ScrnDim[1] //Axial and Coronal width is X + else + lW := gBGImg.ScrnDim[2]; //Sagittal width is Y + lH := lH+1; + lW := lW + 1; + end else if gBGImg.SingleRow then begin //show 3 slices in row + lW := gBGImg.ScrnDim[2]+gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1]; + lWpanel := lWpanel-2- (2*gBGImg.ImageSeparation); + if gBGImg.ScrnDim[2]>gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2]+1 + else + lH := gBGImg.ScrnDim[3]+1 + end else begin //show three slices, 2 in top row, one in bottom + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2]+4; + lWpanel := lWpanel - 1 - gBGImg.ImageSeparation; + lH := gBGImg.ScrnDim[3]+gBGImg.ScrnDim[2]+4; + lHpanel := lHpanel - 1 - gBGImg.ImageSeparation; + end; + + if (lW<1) or (lH < 1) or (lHpanel < 1) or (lWpanel < 1) then + exit; + lZoomw := lWpanel/ lW; + lZoomh := lHpanel/ lH; + if lZoomw < lZoomh then + lPrimaryZoom := lZoomw + else + lPrimaryZoom := lZoomh; + if (gBGImg.ZoomPct = 0) then begin//nearest integer + lPrimaryZoom := trunc(lPrimaryZoom); + if lPrimaryZoom < 1 then + lPrimaryZoom := 1; + end; + SetPct(lPrimaryZoom,lPrimaryZoom,lPrimaryZoom); +543: //for single slice views, set residual ... + if gBGImg.SliceView = kMultiView then + exit;//All orientations use primary zoom + if gBGImg.SliceView < 0 then begin + l2ndZoom := 0; + goto 641; + end; + lWpanel := lWpanel-2- (2*gBGImg.ImageSeparation); //see if we can fit in two more images horizontally + //note all images are currently set to primary zooom, so we will read PGImageAx + lWpanel := lWPanel - round(lW*lPrimaryZoom); + l2ndZoom := 0; + if lWpanel < 3 then goto 641; + if (abs(gBGImg.SliceView) = kAxView0) then + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2] //CorX + SagY + else if (abs(gBGImg.SliceView) = kCoroView0) then + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2] //AxX + SagY + else //(gBGImg.SliceView = kSagView) + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1];//AxX+CorX + if lW < 1 then //avoid div0 + lZoomw := 0 + else + lZoomw := lWpanel/ lW; + if gBGImg.ScrnDim[2] > gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2] + else + lH := gBGImg.ScrnDim[3]; + if lH < 1 then //avoid div0 + lZoomh := 0 + else + lZoomh := lHpanel/ lH; + if lZoomw < lZoomh then + l2ndZoom := lZoomw + else + l2ndZoom := lZoomh; +641: + if (abs(gBGImg.SliceView) = kAxView0) then + SetPct(lPrimaryZoom,l2ndZoom,l2ndZoom) + else if (abs(gBGImg.SliceView) = kCoroView0) then + SetPct(l2ndZoom,lPrimaryZoom,l2ndZoom) + else //(gBGImg.SliceView = kSagView) + SetPct(l2ndZoom,l2ndZoom,lPrimaryZoom); + +end; + +(*function ComputeTripleZoom : single; +var + lHc,lWc,lH,lW: integer; + lZw,lZh: single; +begin + result := 1; + lHc := ImgForm.TriplePanel.ClientHeight-1; + lWc := ImgForm.TriplePanel.ClientWidth-1; + //gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + if gBGImg.ZoomPct > 0 then begin + result := gBGImg.ZoomPct / 100; + exit; + end; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + case gBGImg.SliceView of + kSagView: lH := gBGImg.ScrnDim[3]; + kCoroView: lH := gBGImg.ScrnDim[3]; + else lH := gBGImg.ScrnDim[2]; + end;//case + case gBGImg.SliceView of + kSagView: lW := gBGImg.ScrnDim[2]; + kCoroView: lW := gBGImg.ScrnDim[1]; + else lW := gBGImg.ScrnDim[1]; + end;//case + lH := lH+1; + lW := lW + 1; + + end else if gBGImg.SingleRow then begin //show 3 slices in row + lW := gBGImg.ScrnDim[2]+gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1]; + lWc := lWc-2- (2*gBGImg.ImageSeparation); + if gBGImg.ScrnDim[2]>gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2]+1 + else + lH := gBGImg.ScrnDim[3]+1 + end else begin //show three slices, 2 in top row, one in bottom + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2]+4; + lWc := lWc - 1 - gBGImg.ImageSeparation; + lH := gBGImg.ScrnDim[3]+gBGImg.ScrnDim[2]+4; + lHc := lHc - 1 - gBGImg.ImageSeparation; + + end; + if (lW<1) or (lH < 1) or (lHc < 1) or (lWc < 1) then + exit; + lZw := lWc/ lW; + lZh := lHc/ lH; + if lZw < lZh then + result := lZw + else + result := lZh; + if (gBGImg.ZoomPct = 0) then begin//nearest integer + result := trunc(result); + if result < 1 then + result := 1; + end; +end; *) + +procedure ImageLT (lLScroll,lTScroll,lL,lT: integer; var lImage: TImage); +begin + //if (lImage.Left = lL) and (lImage.Top = lT) then + // exit; ImgForm.Caption := 'a'+inttostr(lL)+'x'+inttostr(lT)+'debug'+inttostr(lImage.Left)+'x'+inttostr(lImage.Top); + //if lImage.Left <> lL then + lImage.Left := lL-lLScroll; + //if lImage.Top <> lT then + lImage.Top := lT-lTScroll; +end; + +procedure RefreshImages; +var + lL,lT: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + ImgForm.PGImageAx.Width := 0; + ImgForm.PGImageSag.Width := 0; + ImgForm.PGImageCor.Width := 0; + exit; + end; + {$IFDEF FPC} + lL := 0; + lT := 0; + {$ELSE} + lL := imgForm.Triplepanel.HorzScrollBar.Position; + lT := imgForm.Triplepanel.VertScrollBar.Position; + {$ENDIF} + //imgform.Caption := inttostr(lL)+'x'+inttostr(lT); + ComputeTripleZoom; + ImgForm.PGImageAx.visible := ImgForm.PGImageAx.tag <> 0; + ImgForm.PGImageCor.visible := ImgForm.PGImageCor.tag <> 0; + ImgForm.PGImageSag.visible := ImgForm.PGImageSag.tag <> 0; + if (gBGImg.SliceView = kMultiView) and (not gBGImg.SingleRow) then begin + //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageSag); + end else begin + //Sag is left-most + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + //Next is coronal... + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + //Axial is rightmost + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1,1,ImgForm.PGImageAx); + end; +(* //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end; + + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if (gBGImg.SliceView = kAxView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageAx); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kCoroView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kSagView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := true; + end; + end else if gBGImg.SingleRow then begin + //Sag is left-most + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + //Next is coronal... + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + //Axial is rightmost + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1,1,ImgForm.PGImageAx); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end else begin + //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end; *) + DrawAxial(round(gBGImg.ZViewCenter),-1); + DrawSag (round(gBGImg.XViewCenter),-1); + DrawCor (round(gBGImg.YViewCenter),-1); +end; //RefreshImages + +(*procedure RefreshImages; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + ImgForm.PGImageAx.Width := 0; + ImgForm.PGImageSag.Width := 0; + ImgForm.PGImageCor.Width := 0; + exit; + end; + gTripleZoom100 := trunc(100*ComputeTripleZoom); + if gTripleZoom100 < 1 then + gTripleZOom100 := 1; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if (gBGImg.SliceView = kAxView) then begin + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kCoroView) then begin + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kSagView) then begin + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := true; + end; + end else if gBGImg.SingleRow then begin + ImgForm.PGImageCor.Left := round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1; + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end else begin + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.Top := round(gBGImg.ScrnDim[3]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + + end; + DrawAxial(round(gBGImg.ZViewCenter),-1); + DrawSag (round(gBGImg.XViewCenter),-1); + DrawCor (round(gBGImg.YViewCenter),-1); +end; //RefreshImages +*) +(*function ComputeTripleZoom : single; +var + lHc,lWc,lH,lW: integer; + lZw,lZh: single; +begin + result := 1; + lHc := ImgForm.TriplePanel.ClientHeight-1; + lWc := ImgForm.TriplePanel.ClientWidth-1; + //gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + if gBGImg.ZoomPct > 0 then begin + result := gBGImg.ZoomPct / 100; + exit; + end; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + case gBGImg.SliceView of + kSagView: lH := gBGImg.ScrnDim[3]; + kCoroView: lH := gBGImg.ScrnDim[3]; + else lH := gBGImg.ScrnDim[2]; + end;//case + case gBGImg.SliceView of + kSagView: lW := gBGImg.ScrnDim[2]; + kCoroView: lW := gBGImg.ScrnDim[1]; + else lW := gBGImg.ScrnDim[1]; + end;//case + lH := lH+1; + lW := lW + 1; + + end else if gBGImg.SingleRow then begin //show 3 slices in row + lW := gBGImg.ScrnDim[2]+gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1]; + lWc := lWc-4; + if gBGImg.ScrnDim[2]>gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2]+1 + else + lH := gBGImg.ScrnDim[3]+1 + end else begin //show three slices, 2 in top row, one in bottom + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2]+4; + lWc := lWc - 2; + lH := gBGImg.ScrnDim[3]+gBGImg.ScrnDim[2]+4; + lHc := lHc - 2; + + end; + if (lW<1) or (lH < 1) or (lHc < 1) or (lWc < 1) then + exit; + lZw := lWc/ lW; + lZh := lHc/ lH; + if lZw < lZh then + result := lZw + else + result := lZh; + if (gBGImg.ZoomPct = 0) then begin//nearest integer + result := trunc(result); + if result < 1 then + result := 1; + end; +end; + +procedure RefreshImages; +//var +// lZoom: single; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + ImgForm.PGImageAx.Width := 0; + ImgForm.PGImageSag.Width := 0; + ImgForm.PGImageCor.Width := 0; + //yui + exit; + end; + gTripleZoom100 := trunc(100*ComputeTripleZoom); + if gTripleZoom100 < 1 then + gTripleZOom100 := 1; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if (gBGImg.SliceView = kAxView) then begin + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kCoroView) then begin + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kSagView) then begin + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := true; + end; + end else if gBGImg.SingleRow then begin + ImgForm.PGImageCor.Left := round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+2; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+3; + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end else begin + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+2; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.Top := round(gBGImg.ScrnDim[3]*gTripleZoom100/100)+2; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + + end; + DrawAxial(round(gBGImg.ZViewCenter),-1); + DrawSag (round(gBGImg.XViewCenter),-1); + DrawCor (round(gBGImg.YViewCenter),-1); +end; //RefreshImages + *) + {$IFNDEF FPC} +function PNGFilterSize(lFilter: integer; lImage: TImage): integer; +var + lStream: TMemoryStream; + lPNGFilters : TEncodeFilterSet; +begin + result := 0; + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + lStream := TMemoryStream.Create; + try + with TPNGImage.Create do begin + //gPNGSaveFilters := []; + case lFilter of + 1: lPNGFilters := [efSub]; + 2: lPNGFilters := [efUp]; + 3: lPNGFilters := [efAverage]; + 4: lPNGFilters := [efPaeth];//Include(SaveFilters, efPaeth); + else lPNGFilters := [efNone];//[efNone,efSub,efUp,efAverage,efPaeth]; + end; + Filter := lPNGFilters; + //filters(efNone, efSub, efUp, efAverage, efPaeth); + Assign(lImage.Picture.Graphic); + SaveToStream(lStream); + result := (lStream.Size); + end; + finally + lStream.Free; + end; //Stream TRY..FINALLY +end; + +procedure SaveImgAsPNGBMP (lImage: TImage); +var + lPNGFilter,lMinFilter,lMinFilterSz,lFilter,lSz: integer; + lPNGFilters : TEncodeFilterSet; +begin + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + lPNGFilter := 5; + if lPNGFilter = 5 then begin //find PNG filter for smallest filesize + lMinFilter := 0; + lMinFilterSz := PNGFilterSize(0,lImage); + for lFilter := 1 to 4 do begin + Application.ProcessMessages; + lSz := PNGFilterSize(lFilter,lImage); + if lSz < lMinFilterSz then begin + lMinFilter := lFilter; + lMinFilterSz := lSz; + end; + end; //Filter 1..4 try each filter + end else + lMinFilter := lPNGFilter; //if look for smallest filter + case lMinFilter of + 1: lPNGFilters := [efSub]; + 2: lPNGFilters := [efUp]; + 3: lPNGFilters := [efAverage]; + 4: lPNGFilters := [efPaeth];//Include(SaveFilters, efPaeth); + else lPNGFilters := [efNone];//[efNone,efSub,efUp,efAverage,efPaeth]; + end; + with TPNGImage.Create do begin + //filters(efNone, efSub, efUp, efAverage, efPaeth); + Filter := lPNGFilters; + Assign(lImage.Picture.Bitmap); + SaveToFile(ChangeFileExt(ImgForm.SaveDialog1.FileName,'.png')); + free; + end; +end; + {$ELSE} + procedure SaveImgAsPNGCore (lImage: TBitmap; lFilename: string); + var + PNG: TPortableNetworkGraphic; + begin + if (lImage = nil) then begin + Showmessage('No image found to save.'); + exit; + end; + PNG := TPortableNetworkGraphic.Create; + try + PNG.Assign(lImage); //Convert data into png + PNG.SaveToFile(ChangeFileExt(lFilename,'.png')); + finally + PNG.Free; + end + end; + +procedure SaveImgAsPNGBMP (lImage: TImage); +begin + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + {$IFDEF ENDIAN_BIG} + ImgForm.SaveDialog1.Filter := 'PNG (*.png)|*.png;Bitmap|*.xpm'; + ImgForm.SaveDialog1.DefaultExt := '.png'; + {$ELSE} + ImgForm.SaveDialog1.Filter := 'PNG (*.png)|*.png;Bitmap|*.bmp'; + ImgForm.SaveDialog1.DefaultExt := '.png'; + {$ENDIF} + if not ImgForm.SaveDialog1.Execute then exit; + //showmessage(ImgForm.SaveDialog1.FileName); + if upcaseext(ImgForm.SaveDialog1.Filename)='.BMP' then + lImage.Picture.Bitmap.SaveToFile(ImgForm.SaveDialog1.Filename) + else + SaveImgAsPNGCore(lImage.Picture.Bitmap,ImgForm.SaveDialog1.Filename); +end; + {$ENDIF} + +(*procedure SaveImgAsBMP (lImage: TImage); +begin + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + ImgForm.SaveDialog1.Filter := 'Bitmap|*.bmp'; + ImgForm.SaveDialog1.DefaultExt := '*.bmp'; + if not ImgForm.SaveDialog1.Execute then exit; + lImage.Picture.Bitmap.SaveToFile(ImgForm.SaveDialog1.Filename); +end;*) + + +procedure UndoVolVOI; +var lTempBuf: ByteP; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems < 1 then exit; + if gBGImg.VOIUndoVolItems <> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then exit; + GetMem(lTempBuf,gBGImg.VOIUndoVolItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lTempBuf^,gBGImg.VOIUndoVolItems); + Move(gBGImg.VOIUndoVol^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVolItems); + Move(lTempBuf^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + FreeMem(lTempBuf); + +end; + +procedure FreeUndoVol; +begin + if gBGImg.VOIUndoVolItems > 0 then + freemem(gBGImg.VOIUndoVol); + gBGImg.VOIUndoVolItems := 0; + if gBGImg.RenderDepthBufferItems > 0 then + freemem(gBGImg.RenderDepthBuffer); + gBGImg.RenderDepthBufferItems := 0; +end; + +procedure CreateUndoVol; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems < 1 then exit; + gBGImg.VOIUndoSlice := 1; + gBGImg.VOIUndoOrient := 4; + if gBGImg.VOIUndoVolItems <> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then begin + FreeUndoVol; + gBGImg.VOIUndoVolItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + getmem(gBGImg.VOIUndoVol,gBGImg.VOIUndoVolItems); + end; + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); +end; + +function IsVOIOpen: boolean; +begin + result := false; + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems = gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) + and (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0) then + result := true; +end; + +function SameAsBG(var lBGImg: TBGImg; var lHdr: TMRIcroHdr): boolean; +var + lMatrixBG: TMatrix; + i, j: Integer; +begin + result := false; + for i := 1 to 3 do //999 + if lHdr.NIFTIhdr.dim[i] <>lBGImg.ScrnDim[i] then //999 + exit; //999 + lMatrixBG := Matrix3D ( lBGImg.Scrnmm[1],0,0,-lBGImg.Scrnmm[1]*(lBGImg.ScrnOri[1]-1), + 0,lBGImg.Scrnmm[2],0,-lBGImg.Scrnmm[2]*(lBGImg.ScrnOri[2]-1), + 0,0,lBGImg.Scrnmm[3],-lBGImg.Scrnmm[3]*(lBGImg.ScrnOri[3]-1), + 0,0,0,1); + for i := 1 to 3 do + for j := 1 to 4 do begin + if lMatrixBG.matrix[i,j] <> lHdr.Mat.matrix[i,j] then exit; + end; + //showmessage('same'); + //for i := 1 to 3 do if (lBGIMg.ScrnDim[i])<>lHdr.NIFTIhdr.dim[i] then exit; + result := true; +end; + +procedure EnsureVOIOpen; +var lMaxi: integer; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems = gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then exit; + //showmessage(inttostr(gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems)); + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + Freemem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer); + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[1] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[2] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[3] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[1] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[1]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[2] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[2]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[3] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[3]; + gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + + gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + Getmem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + fillchar(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,0); + lMaxI := maxint; + LoadMonochromeLUT(lMaxi,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + if (gBGImg.Resliced) and (not SameAsBG(gBGImg,gMRIcroOverlay[kBGOverlayNum])) then //fv + showmessage('Warning: you are about to draw a region of interest on an resliced image, which can problems with SPM and FSL. Solution: choose Help/Preferences and uncheck ''Reorient images when loading'', then reload your image.'); +end; + +function SelectedImageNum: Integer; +begin + result := gSelectedImageNum; + if (result < 1) or (result > 3) then + result := 1; +{ with ImgForm do begin + if TriplePanel.BorderStyle = bsSingle then + result := 3 + else if TriplePanel.BorderStyle = bsSingle then + result := 2 + else + result := 1 + end;} //with ImgForm +end;//SelectedImageNum + + +function ComputeInvZoomShl10(lSelectedImageNum: integer; var lImage: TImage): integer; +const + kSHval = 1 shl 10; +var lPGWid,lImgWid: integer; +begin + result := kSHval;//100% + lPGWid := lImage.Picture.Bitmap.Width; + if lImage.Tag > 0 then begin + result := round((100/lImage.Tag)*kShVal); + exit; + end; + if lSelectedImageNum = 2 then + lImgWid := gBGImg.ScrnDim[2] //Sag - horizontal is Y + else + lImgWid := gBGImg.ScrnDim[1]; //cor and ax - horizontal is X + If (lPGWid < 1) or (lImgWid < 1) then exit; + result := round(lImgWid/lPGWid* kShVal); +end; + +function ComputeZoomPct(lSelectedImageNum: integer; var lImage: TImage): integer; +var lPGWid,lImgWid: integer; +begin + result := 100;//100% + lPGWid := lImage.Picture.Bitmap.Width; + if lImage.Tag > 0 then begin + result := lImage.Tag; + exit; + end; + if lSelectedImageNum = 2 then + lImgWid := gBGImg.ScrnDim[2] //Sag - horizontal is Y + else + lImgWid := gBGImg.ScrnDim[1]; //cor and ax - horizontal is X + If (lPGWid < 1) or (lImgWid < 1) then exit; + result := round(lPGWid/lImgWid* 100); +end; //ComputeZoomPct + +procedure ScaleScrn2BMP (var lX, lY: integer;lImage: TImage); +var lScale: single; +begin + if (lImage.Height = 0) or (lImage.Width = 0) then exit; + lScale := lImage.Picture.Bitmap.Height /lImage.Height; + lX := round(lX * lScale); + lY := round(lY * lScale); +end; + +procedure ScaleBMP2Draw (var InvZoomShl10,lX, lY, lPanel: integer; lImage: TImage); +var + pxHt, pxWid : integer; + begin + {$IFDEF Darwin} + //please check if next line required for this OS! 8/8/2014 + {$ENDIF} + lX := lX + 1; + lY := lY + 1; + if lPanel = 2 then + pxWid := gBGImg.ScrnDim[2] + else + pxWid := gBGImg.ScrnDim[1]; + if lPanel = 1 then + pxHt := gBGImg.ScrnDim[2] + else + pxHt := gBGImg.ScrnDim[3]; + //imgForm.statusLabel.caption := inttostr(lPanel)+' '+inttostr(lX)+' '+inttostr(ceil(lX * (pxWid/lImage.Width))); + lX := ceil(lX * (pxWid/lImage.Width)); + lY := ceil(lY * (pxHt/lImage.Height)); + //if (gBGImg.FlipSag) and (lPanel = 2) then + // lX := (lImage.Width-lX) + 1; + if (gBGImg.FlipAx) and (lPanel = 1) then + lY := (lImage.Height-lY) + 1; + + end; + +(*procedure ScaleBMP2DrawOld (var InvZoomShl10,lX, lY, lPanel: integer; lImage: TImage); +var + pxHt, pxWid : integer; +begin + //lScaleShl10 := ComputeInvZoomShl10(SelectedImageNum,lImage); + //ImgForm.StatusLabel.Caption := inttostr(InvZoomShl10); + {$IFDEF Darwin} + please check if next line required for this OS! 8/8/2014 + {$ENDIF} + lX := lX + 1; + //imgForm.statusLabel.caption := inttostr(lPanel)+' '+inttostr(lX)+' '+inttostr(lY); + if (gBGImg.FlipSag) and (lPanel = 2) then + lX := ((lImage.Width-lX) * InvZoomShl10) shr 10 + else if (lX < 1) then + lX := 0 + else + lX := (lX * InvZoomShl10) shr 10; + if (gBGImg.FlipAx) and (lPanel = 1) then + lY := ((lImage.Height-lY) * InvZoomShl10) shr 10 + else if (lY < 1) then + lY := 0 + else + lY := (lY * InvZoomShl10) shr 10; +end; *) + +function ImageZoomPct( var lImage: TImage): integer; +begin + result := ComputeZoomPct(SelectedImageNum,lImage); +end; + +procedure DrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +var lL,lT,lW,lH,lZoomPct: integer; +lOffset: single; +begin + lZoomPct := ImageZoomPct(lImage); + //amx - must match XYscrn2Img and DrawXBar + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + //lL := lHorPos-1; + if lZoomPct > 100 then lOffset := 0.5 else + lOffset := 0; + lL := ceil((lHorPos-lOffset) * lZoomPct/100)-1;// div 100; //-1 as indexed from zero, 0.5 for middle of slice + lT := lH-ceil((lVerPos-lOffset) * lZoomPct/100.0);// div 100; + //ImgForm.Caption := inttostr(lZoomPct); + //lL := (lHorPos * lZoomPct) div 100; + //lT := (lVerPos * lZoomPct) div 100; + + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + //lImage.Canvas.Pen.Color:=$03FF0000; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + //next horizontal lines + lImage.Canvas.MoveTo(0,lT); + lImage.Canvas.LineTo(lL-gBGImg.XBarGap,lT); + lImage.Canvas.MoveTo(lL+gBGImg.XBarGap,lT); + lImage.Canvas.LineTo(lW,lT); + //next vertical lines + lImage.Canvas.MoveTo(lL,0); + lImage.Canvas.LineTo(lL,lT-gBGImg.XBarGap); + lImage.Canvas.MoveTo(lL,lT+gBGImg.XBarGap); + lImage.Canvas.LineTo(lL,lH); +end; //Proc DrawXBar + +function Scrn2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +var lRange,lMin,lMax: single; +begin + lMin := lHdr.WindowScaledMin; + lMax := lHdr.WindowScaledMax; + if lMin > lMax then begin + lRange := lMin; + lMin := lMax; + lMax := lRange; + end; + lRange := lMax - lMin; + result := lMin+(lRaw/255*lRange); +end; + +procedure SaveMRIcroROI (lFilename: string); +const + kMax12bit = 4095; + kMax16bit = (256*256)-1; + kMax20bit = (16*256*256)-1; + k20v16bit = kMax20bit - kMax16bit; + kMaxRuns = 10000; + kMaxFile = 65536; +var lFilePos,lZPos,lZ,lSliceSz,lSliceOffset,lPrevVoxel,lVoxel,lRun,lnRuns,lSlicePos: integer; + lRunStartRA,lRunLengthRA : array [1..kMaxRuns] of longint; + lOutputRA: array [1..kMaxFile] of word; + lF: File; + lBigFormat: boolean; +begin + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + if lSliceSz > 65535 then + lBigFormat := true + else + lBigFormat := false; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems<> (lSLiceSz*lZ) then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + lSliceOffset := 0; + lFilePos := 0; + for lZPos := 1 to lZ do begin + lnRuns := 0; + lPrevVoxel := 0; + for lSlicePos := 1 to lSliceSz do begin + lVoxel := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lSlicePos+lSliceOffset]; + if lVoxel > 1 then lVoxel := 1; + if lVoxel <> lPrevVoxel then begin //start or end run + lPrevVoxel := lVoxel; + if lnRuns = kMaxRuns then + Showmessage('Error: To many runs...') + else if lVoxel = 1 then begin //start new run + inc(lnRuns); + lRunStartRA[lnRuns] := lSlicePos; + + end else begin + lRunLengthRA[lnRuns] := lSlicePos-lRunStartRA[lnRuns]; + end; + end; //if start or end + if (lVoxel > 0) and ((lSlicePos-lRunStartRA[lnRuns])>4090) then begin //end this run, begin new + lRunLengthRA[lnRuns] := lSlicePos-lRunStartRA[lnRuns]+1; + lPrevVoxel := 0; + end; //run >4090 + end; //for each voxel in slice + if lPrevVoxel = 1 then + lRunLengthRA[lnRuns] := lSliceSz-lRunStartRA[lnRuns]+1; + lSliceOffset := lSliceOffset+lSliceSz; + if lnRuns > 0 then begin + inc(lFilePos); + lOutputRA[lFilePos] := lZPos; //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := 2*(lnRuns+1); //words to store this slice: 2 per run, plus 2 for slice number and size + if lBigFormat then begin + for lRun := 1 to lnRuns do begin + inc(lFilePos); + lOutputRA[lFilePos] := (lRunStartRA[lRun] and kMax16bit); //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := (lRunLengthRA[lRun] and kMax12bit)+ ((lRunStartRA[lRun] and k20v16bit)shr 4) ; //record slice number + end; + end else begin + for lRun := 1 to lnRuns do begin + inc(lFilePos); + lOutputRA[lFilePos] := lRunStartRA[lRun]; //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := lRunLengthRA[lRun]; //record slice number + end;//for each run + end; //small format + end; //if data on this slice + end; //for lZ + if lFilePos = 0 then begin + Showmessage('No VOIs detected - unable to create blank MRIcro ROI.'); + exit; + end; + if lBigFormat then + lOutputRA[1] := lOutputRA[1]+ 32768; //set MSB to 1 to denote this file uses 12/20 bytes + Filemode := 1; + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lFilePos*2); + BlockWrite(lF,lOutputRA, 1 {, NumWritten}); + CloseFile(lF); + Filemode := 2; +end; + +procedure SaveAsVOIorNIFTIinnercore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... + kImgOffset2 = 480; //header is 348 bytes, but 352 is divisible by 8... + lNII2 = false; +var + lHdr: TNIFTIhdr; + lBuff: ByteP; + lF: File; + lXmm,lYmm,lZmm: single; + lUnCompressedFilename,lExt: string; + lImgOffset,lC,lFSize: integer; + lMat: TMatrix; +begin + lExt := UpCaseExt(lFileName); + move(lNiftiHdr,lHdr,sizeof(lHdr)); + if (lExt='.VOI') then begin + lHdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.intent_name[1] := 'B';//Binary + lHdr.scl_slope := 1/kVOI8bit; + lHdr.scl_inter := 0; + end; + if lnVol > 1 then begin + lHdr.dim[0] := 4;//3D july2006 + lHdr.dim[4] := lnVol;//3D july2006 + end else begin + lHdr.dim[0] := 3;//3D july2006 + lHdr.dim[4] := 1;//3D july2006 + end; + //if not (lImgBufferItems = (lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3])) then begin //july2006 + //below - images are repositioned to match background + if gBGImg.Resliced then begin + lHdr.dim[1] := gBGImg.ScrnDim[1]; + lHdr.dim[2] := gBGImg.ScrnDim[2]; + lHdr.dim[3] := gBGImg.ScrnDim[3]; + lHdr.pixdim[1] := gBGImg.ScrnMM[1]; //Apr07 + lHdr.pixdim[2] := gBGImg.ScrnMM[2]; //Apr07 + lHdr.pixdim[3] := gBGImg.ScrnMM[3]; //Apr07 + lHdr.sform_code :=kNIFTI_XFORM_SCANNER_ANAT; //10102006 + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + + lHdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; //May07 + lMat:= Matrix3D ( gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3], + 0,0,0,1); + nifti_mat44_to_quatern( lMat,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lXmm,lYmm,lZmm,lHdr.pixdim[0]); + end else begin + //Apr07 - for unresliced data, use raw header for data + end; + case lImgBufferBPP of + 4: begin + {lSingleRA := SingleP(lImgBuffer); + for lPos := 1 to 4 do + fx(22,lSingleRA^[lPos]);} + lHdr.bitpix := 32; + lHdr.datatype := kDT_FLOAT;//note 32-bit integers saved internally as 32-bit float + end; + 3: begin + lHdr.bitpix := 24; + lHdr.datatype := kDT_RGB; + end; + + 2: begin + lHdr.bitpix := 16; + lHdr.datatype := kDT_SIGNED_SHORT; + end; + 1: begin + lHdr.bitpix := 8; + lHdr.datatype := kDT_UNSIGNED_CHAR; + //lHdr.scl_inter := lHdr.WindowScaledMin; + //lHdr.scl_slope := (lHdr.WindowScaledMax-lHdr.WindowScaledMin) /255; + end; + else begin + showmessage('Error: Unsupported bytes per voxel: '+inttostr(lImgBufferBPP)); + exit; + end; + end; + if (lExt='.IMG') or (lExt ='.HDR') then begin + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + lHdr.vox_offset := 0; + Filemode := 1; + //next write header data as .hdr + lFilename := changeFileExt(lFilename,'.hdr'); + AssignFile(lF, lFileName); + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lHdr, 1); + CloseFile(lF); + //next write image data as .img + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lImgBufferItems*lImgBufferBPP); + BlockWrite(lF,lImgBuffer^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //separate header + + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lImgOffset := kImgOffset; + lHdr.vox_offset := lImgOffset;//352 bytes + lFSize := lImgOffset+(lImgBufferItems*lImgBufferBPP); + getmem(lBuff,lFSize); + + move(lHdr,lBuff^,sizeof(lHdr)); + //Next: NIfTI 1.1 requires bytes 349..352 set to zero when no XML information + + lC := lImgOffset; + lBuff^[lC-3] := 0; + lBuff^[lC-2] := 0; + lBuff^[lC-1] := 0; + lBuff^[lC] := 0; + lC := lImgOffset+1; + //move(lImgBuffer^[1],lBuff[lC],lImgBufferItems*lImgBufferBPP); + + move(lImgBuffer^,lBuff^[lC],lImgBufferItems*lImgBufferBPP); + if (lExt='.NII') then begin + Filemode := 1; + AssignFile(lF, lFileName); + Rewrite(lF,lFSize); + BlockWrite(lF,lBuff^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //uncompressed + lUnCompressedFilename := changefileextx(lFilename,'.nii'); + GZipBuffer(lUnCompressedFilename,lFilename,lBuff,lFSize,false); + freemem(lBuff); +end; + +procedure SaveAsVOIorNIFTIcoreOrtho (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +var + lISize: integer; + lTempHdr: TMRIcroHdr; +begin + if not gBGImg.UseReorientHdr then + exit; + lTempHdr.NIFTIhdr := lNIftIHdr; + lISize := (lImgBufferItems*lImgBufferBPP); + GetMem(lTempHdr.ImgBufferUnaligned ,lISize + 16); + {$IFDEF FPC} + lTempHdr.ImgBuffer := align(lTempHdr.ImgBufferUnaligned,16); + {$ELSE} + lTempHdr.ImgBuffer := ByteP($fffffff0 and (integer(lTempHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + lTempHdr.ImgBufferItems := lImgBufferItems; + lTempHdr.ImgBufferBPP := lImgBufferBPP; + move(lImgBuffer^,lTempHdr.ImgBuffer^,lISize); + + Reslice_Img_To_Unaligned (gBGImg.ReorientHdr, lTempHdr ,true); + SaveAsVOIorNIFTIinnercore (lFilename, lTempHdr.ImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lTempHdr.NIFTIhdr); + //restore orientation + //12/2010 remove this line - we changed TMPHdr lNiftiHdr := lTempHdr.NIFtiHdr; + //reslease memory + FreeMem(lTempHdr.ImgBufferUnaligned); +end; + +procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +begin + //10/2007 - scl_slope; + //lExt := UpCaseExt(lFileName); + if DiskFreeEx(lFilename) < (kImgOffset+(lImgBufferItems*lImgBufferBPP)) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; + if FileExistsEX(lFileName) then begin + case MessageDlg('Overwrite the file named '+lFileName+'?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; //file exists + if not gBGImg.UseReorientHdr then + SaveAsVOIorNIFTIinnercore (lFilename, lImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lNiftiHdr) + else + SaveAsVOIorNIFTIcoreOrtho (lFilename, lImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lNiftiHdr); +end; + +(*procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +var + lHdr: TNIFTIhdr; + lBuff: ByteP; + lMat: TMatrix; + lXmm,lYmm,lZmm: single; + lF: File; + lUnCompressedFilename,lExt: string; + lC,lFSize: integer; +begin + lExt := UpCaseExt(lFileName); + if DiskFreeEx(lFilename) < (kImgOffset+(lImgBufferItems*lImgBufferBPP)) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; + if FileExistsEX(lFileName) then begin + case MessageDlg('Overwrite the file named '+lFileName+'?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + end; //file exists + move(lNiftiHdr,lHdr,sizeof(lHdr)); + if (lExt='.VOI') then begin + lHdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.intent_name[1] := 'B';//Binary + lHdr.scl_slope := 1/kVOI8bit; + lHdr.scl_inter := 0; + end; + if lnVol > 1 then begin + lHdr.dim[0] := 4;//3D july2006 + lHdr.dim[4] := lnVol;//3D july2006 + end else begin + lHdr.dim[0] := 3;//3D july2006 + lHdr.dim[4] := 1;//3D july2006 + end; + //if not (lImgBufferItems = (lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3])) then begin //july2006 + //below - images are repositioned to match background + if gBGImg.Resliced then begin + lHdr.dim[1] := gBGImg.ScrnDim[1]; + lHdr.dim[2] := gBGImg.ScrnDim[2]; + lHdr.dim[3] := gBGImg.ScrnDim[3]; + lHdr.pixdim[1] := gBGImg.ScrnMM[1]; //Apr07 + lHdr.pixdim[2] := gBGImg.ScrnMM[2]; //Apr07 + lHdr.pixdim[3] := gBGImg.ScrnMM[3]; //Apr07 + lHdr.sform_code :=kNIFTI_XFORM_SCANNER_ANAT; //10102006 + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + + lHdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; //May07 + lMat:= Matrix3D ( gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3], + 0,0,0,1); + nifti_mat44_to_quatern( lMat,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lXmm,lYmm,lZmm,lHdr.pixdim[0]); + end else begin + //Apr07 - for unresliced data, use raw header for data + end; + case lImgBufferBPP of + 4: begin + {lSingleRA := SingleP(lImgBuffer); + for lPos := 1 to 4 do + fx(22,lSingleRA^[lPos]);} + lHdr.bitpix := 32; + lHdr.datatype := kDT_FLOAT;//note 32-bit integers saved internally as 32-bit float + end; + 3: begin + lHdr.bitpix := 24; + lHdr.datatype := kDT_RGB; + end; + + 2: begin + lHdr.bitpix := 16; + lHdr.datatype := kDT_SIGNED_SHORT; + end; + 1: begin + lHdr.bitpix := 8; + lHdr.datatype := kDT_UNSIGNED_CHAR; + //lHdr.scl_inter := lHdr.WindowScaledMin; + //lHdr.scl_slope := (lHdr.WindowScaledMax-lHdr.WindowScaledMin) /255; + end; + else begin + showmessage('Error: Unsupported bytes per voxel: '+inttostr(lImgBufferBPP)); + exit; + end; + end; + if (lExt='.IMG') or (lExt ='.HDR') then begin + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + lHdr.vox_offset := 0; + Filemode := 1; + //next write header data as .hdr + lFilename := changeFileExt(lFilename,'.hdr'); + AssignFile(lF, lFileName); + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lHdr, 1); + CloseFile(lF); + //next write image data as .img + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lImgBufferItems*lImgBufferBPP); + BlockWrite(lF,lImgBuffer^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //separate header + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lHdr.vox_offset := kImgOffset;//352 bytes + lFSize := kImgOffset+(lImgBufferItems*lImgBufferBPP); + getmem(lBuff,lFSize); + move(lHdr,lBuff^,sizeof(lHdr)); + //Next: NIfTI 1.1 requires bytes 349..352 set to zero when no XML information + lC := kImgOffset; + lBuff^[lC-3] := 0; + lBuff^[lC-2] := 0; + lBuff^[lC-1] := 0; + lBuff^[lC] := 0; + lC := kImgOffset+1; + //move(lImgBuffer^[1],lBuff[lC],lImgBufferItems*lImgBufferBPP); + + move(lImgBuffer^,lBuff^[lC],lImgBufferItems*lImgBufferBPP); + if (lExt='.NII') then begin + Filemode := 1; + AssignFile(lF, lFileName); + Rewrite(lF,lFSize); + BlockWrite(lF,lBuff^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //uncompressed + lUnCompressedFilename := changefileext(lFilename,'.nii'); + GZipBuffer(lUnCompressedFilename,lFilename,lBuff,lFSize,false); + freemem(lBuff); +end;*) + +{$IFDEF FPC} +// http://bugs.freepascal.org/view.php?id=7797 +function GetExtensionFromFilterAtIndex(Filter: String; Index: Integer): String; +var + p, pipe: Integer; +begin + Result := ''; + if Index < 1 then Exit; + p := 0; + pipe := 0; + while (p < Length(Filter)) do begin + Inc(p); + if Filter[p] = '|' then Inc(pipe); + if (pipe = 2 * (Index - 1)) then break; + end; + if (p = length(Filter)) then exit; + System.Delete(Filter,1,p); + p := Pos('|',Filter); + if (p = 0) then exit; + System.Delete(Filter,1,p); + Filter := Copy(Filter,1,MaxInt); + p := Pos(';',Filter); + pipe := Pos('|',Filter); + if (pipe < p) or (p = 0) then p := pipe; + if (p > 0) then System.Delete(Filter,p,Length(Filter) - p +1); + Filter := StringReplace(Filter, '*', '',[rfReplaceAll, rfIgnoreCase]); + if (Pos('?',Filter) > 0) {or (Pos('*',Filter) > 0)} then exit; + Result := Filter; +end; +{$ENDIF} + +procedure SaveAsVOIorNIFTI (var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; DefaultFormatVOI: boolean; var lNiftiHdr: TNIFTIHdr; lDefFilename: string); +var + lFileName,lExt: string; +begin + if DefaultFormatVOI then begin + ImgForm.SaveDialog1.Filter := 'Volume of Interest(.voi)|*.voi|NIfTI (.nii)|*.nii|NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.hdr/.img)|*.hdr|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.FilterIndex:= gBGImg.SaveVoiFilter; //+1since default added + ImgForm.SaveDialog1.Filename := changefileext(ImgForm.SaveDialog1.Filename,'.voi');//10/10/06 + ImgForm.SaveDialog1.DefaultExt := '.voi'; + end else begin + ImgForm.SaveDialog1.Filter := 'NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.nii)|*.nii|NIfTI (.hdr/.img)|*.hdr|Volume of Interest(.voi)|*.voi|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.Filename := changefileext(ImgForm.SaveDialog1.Filename,'.nii.gz');//10/10/06 + ImgForm.SaveDialog1.FilterIndex:= gBGImg.SaveImgFilter; //8/8/2014 removed +1 new behavior with new lazarus 1.2+1since default added + ImgForm.SaveDialog1.DefaultExt := '.nii.gz'; + end; + if lDefFilename <> '' then + ImgForm.SaveDialog1.Filename := ParseFilename(lDefFilename); + if not ImgForm.SaveDialog1.Execute then exit; + if DefaultFormatVOI then + gBGImg.SaveVoiFilter := ImgForm.SaveDialog1.FilterIndex + else + gBGImg.SaveImgFilter := ImgForm.SaveDialog1.FilterIndex; + lFileName := ImgForm.SaveDialog1.Filename; + {$IFDEF FPC} //recent versions of Lazarus (1.2) do handle this, but will put .gz not .nii.gz + if ImgForm.SaveDialog1.filterIndex > 0 then begin + {$IFNDEF Darwin} + // check next line in each OS + {$ENDIF} + lExt := GetExtensionFromFilterAtIndex(ImgForm.SaveDialog1.Filter,ImgForm.SaveDialog1.FilterIndex); //8/8/2014 check on OSX 10.4 + lFilename := ChangeFileExtX(lFilename,lExt); + end; + {$ENDIF} + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if (lExt='.ROI') then begin + Showmessage('Note that the MRIcro ROI format does not save image dimensions. You may want to save a copy as VOI format.'); + SaveMRIcroROI (lFileName); + exit; + end; + SaveAsVOIorNIFTIcore (lFilename,lImgBuffer, lImgBufferItems, lImgBufferBPP,lnVol,lNiftiHdr); +end; + +procedure SetSubmenuWithTag (var lRootMenu: TMenuItem; lTag: Integer); +var + lCount,lSubMenu: integer; +begin + lCount := lRootMenu.Count; + if lCount < 1 then exit; + for lSubMenu := (lCount-1) downto 0 do + if lRootmenu.Items[lSubmenu].Tag = lTag then begin + lRootmenu.Items[lSubmenu].Checked := true; + exit + end; + //will exit unless tag not found: default select 1st item + lRootmenu.Items[0].Checked := true; + //While Recent1.Count > 0 do Recent1.Items[0].Free; +end; + +function MaxDim (lX,lY,lZ: integer): integer; //returns largest of 3 +begin + result := lX; + if lY > result then + result := lY; + if lZ > result then + result := lZ; +end; +procedure SetBGImgDefaults (var lBGImg: TBGImg); +begin + with lBGImg do begin + FlipAx := false; + FlipSag := false; + SaveImgFilter := 0; + SaveVoiFilter := 0; + + OverlayTransPct := -1; + FontSize := 12; + BGTransPct := 0; + LicenseID := 0; + ShowDraw := false; + ResliceOnLoad := false; + OrthoReslice := true; + Prompt4DVolume := true; + MaxDim := 384; + XBarGap := 7; + XBarThick := 3; + XBarClr := clBlue; + VOIClr := 255;//clRed; + VOIInvZoom := 1 shl 10; //1024 = 100% + LesionSmooth := 3;//3mm smoothing + LesionDilate := 8; + VOIUndoSlice := 0; + VOIUndoOrient := 0; + VOIChanged := false; + VOImirrored := false; + VOIUndoVolItems := 0; + RenderDepthBufferItems := 0; + SigDig := 5; + ImageSeparation := 0; + SliceView := 0;//multiple slices + SPMDefaultsStatsFmriT := 16; + SingleRow := false; + SPMDefaultsStatsFmriT0 := 1; + SaveDefaultIni := true; + ThinPen := true; + PlanarRGB := 2; + XBarVisible := true; + OverlaySmooth := true; + //FSLDIR := 'FSLDIR=/usr/local/fsl'; + FSLBASE := '/usr/local/fsl'; + //FSLBETEXE := '/usr/local/fsl/bin/bet'; + FSLOUTPUTTYPE := 'FSLOUTPUTTYPE=NIFTI_GZ'; + //AutoFill := false; + KnownAlignment := false; + StretchQuality := sqHigh; + end; +end; + +procedure AlphaBlend32(lBGQuad,lOverlayQuad : RGBQuadp; lBG0Clr,lOverlay0Clr: DWord; lSlicePixels, lOverlayTransPct: integer); // 630 +var + lBGwt,lOverlaywt,lPixel,lPos:integer; + lBGp,lOverlayP: ByteP; + lBGDWordp,lOverlayDWordp : DWordp; +begin +//note Here we blend the RGBA values - in fact we only need to blend RGB +//however, the position of Alpha varies between OSX ARGB and Linux/Windows RGBA +//this routine would be ~25% faster if we use a compiler-switch for the OS, +//but I do not want to do this until the Compiler code settles a bit more... + lBGp := ByteP(lBGQuad); + lOverlayP := ByteP(lOverlayQuad); + lOverlayDWordp := DWordp(lOverlayQuad); + lBGDWordp := DWordp(lBGQuad); + //next: transparency weighting + lBGwt := round((lOverlayTransPct)/100 * 1024); + lOverlaywt := round((100-lOverlayTransPct)/100 * 1024); + //next redraw each pixel + lPos := 1; + if lOverlayTransPct > -1 then begin + for lPixel := 1 to lSlicePixels do begin + if lOverlayDWordp^[lPixel] = lOverlay0Clr then + inc(lPos,4) + else if lBGDWordp^[lPixel] = lBG0Clr then begin + lBGDWordp^[lPixel] := lOverlayDWordp^[lPixel]; + inc(lPos,4); + end else begin + lBGp^[lPos] := (lBGp^[lPos]*lBGwt+lOverlayP^[lPos]*lOverlaywt) shr 10; + inc(lPos); + lBGp^[lPos] := (lBGp^[lPos]*lBGwt+lOverlayP^[lPos]*lOverlaywt) shr 10; + inc(lPos); + lBGp^[lPos] := (lBGp^[lPos]*lBGwt+lOverlayP^[lPos]*lOverlaywt) shr 10; + inc(lPos); + lBGp^[lPos] := (lBGp^[lPos]*lBGwt+lOverlayP^[lPos]*lOverlaywt) shr 10; + inc(lPos); + end; + end; + end else begin + for lPixel := 1 to lSlicePixels do begin + if lOverlayDWordp^[lPixel] = lOverlay0Clr then + inc(lPos,4) + else if lBGDWordp^[lPixel] = lBG0Clr then begin + lBGDWordp^[lPixel] := lOverlayDWordp^[lPixel]; + inc(lPos,4); + end else begin + if lOverlayP^[lPos] > lBGp^[lPos] then lBGp^[lPos] := lOverlayP^[lPos]; + inc(lPos); + if lOverlayP^[lPos] > lBGp^[lPos] then lBGp^[lPos] := lOverlayP^[lPos]; + inc(lPos); + if lOverlayP^[lPos] > lBGp^[lPos] then lBGp^[lPos] := lOverlayP^[lPos]; + inc(lPos); + if lOverlayP^[lPos] > lBGp^[lPos] then lBGp^[lPos] := lOverlayP^[lPos]; + inc(lPos); + end; + end; + end; +end; + +function Raw2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +begin + if lHdr.NIFTIhdr.scl_slope = 0 then + result := lRaw+lHdr.NIFTIhdr.scl_inter + else + result := (lRaw * lHdr.NIFTIhdr.scl_slope)+lHdr.NIFTIhdr.scl_inter; +end; + +function Scaled2RawIntensity (lHdr: TMRIcroHdr; lScaled: single): single; +begin + if lHdr.NIFTIhdr.scl_slope = 0 then + result := (lScaled)-lHdr.NIFTIhdr.scl_inter + else + result := (lScaled-lHdr.NIFTIhdr.scl_inter) / lHdr.NIFTIhdr.scl_slope; +end; + +procedure FilterLUT (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lMin, lMax: integer); //lLUT: 0=gray,1=red,2=green,3=blue +var + lInc: integer; + lRGB : TRGBQuad; +begin + for lInc := 0 to 255 do + lHdr.LUT[lInc] := lBackgroundImg.BackupLUT[lInc]; + if (lMin < 0) or (lMin > 255) or (lMax < 0) or (lMax > 255) then + exit; + if lMin > lMax then begin + lInc := lMin; + lMin := lMax; + lMax := lInc; + end; //swap lMin/lMax + lRGB.rgbRed := (lBackgroundImg.XBarClr and 255) ; + lRGB.rgbGreen := ((lBackgroundImg.XBarClr shr 8) and 255) ;// and 65280; + lRGB.rgbBlue := ((lBackgroundImg.XBarClr shr 16) and 255) ;//and 16711680; + lRGB.rgbReserved := kLUTalpha; + for lInc := lMin to lMax do + lHdr.LUT[lInc] := lRGB; +//z +end; + +procedure LoadLabelsOld(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); +var lLUTname: string; + lInc: integer; + lTextFile: TextFile; + lStr1: string; + lCh: char; +begin + SetLength(lBackgroundImg.LabelRA,kMaxLabel+1); //+1 as indexed from 0 + for lInc := 0 to High(lBackgroundImg.LabelRA) do + lBackgroundImg.LabelRA[lInc] := inttostr(lInc); + lLUTname := changefileext(lHdr.HdrFileName,'.txt'); + if not Fileexists(lLUTname) then begin + lLUTname := ParseFileName(lHdr.HdrFileName)+'.txt'; //file.nii.gz -> file.txt + if not Fileexists(lLUTname) then + exit; + end; + assignfile(lTextFile,lLUTname); + lHdr.UsesLabels := true; + Filemode := 0; + reset(lTextFile); + while not EOF(lTextFile) do begin + lStr1 := ''; + repeat + read(lTextFile,lCh); + if (lCh >= '0') and (lCh <= '9') then + lStr1 := lStr1 + lCh; + until (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) or (((lCh=kTab)or (lCh=' ')) and (length(lStr1)>0)); + if (length(lStr1) > 0) and (not EOF(lTextFile)) then begin + linc := strtoint(lStr1); + if (lInc >= 0) and (lInc <= kMaxLabel) then begin + lStr1 := ''; + repeat + read(lTextFile,lCh); + if (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab) or (lCh=' ')} then + else + lStr1 := lStr1 + lCh; + until (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab)or (lCh=' ')}; + //showmessage(inttostr(lInc)+'x'+lStr1); + lBackgroundImg.LabelRA[lInc] := lStr1; + end; + + end; + end; + CloseFile(lTextFile); + Filemode := 2; +end; + +procedure LoadLabelLUT(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr {; isBackground: boolean}); +var lLUTname: string; +(* lInc: integer; + lTextFile: TextFile; + lStr1: string; + lCh: char; *) +begin + lLUTname := changefileext(lHdr.HdrFileName,'.lut'); + if Fileexists(lLUTname) then begin + lHdr.UsesCustomPalette := true; + LoadColorScheme(lLUTname,lHdr); + + end; + //if isBackground then begin + LoadLabelsOld(lBackgroundImg,lHdr); + lHdr.UsesLabels := true; + //end; +end; + +procedure LoadMonochromeLUT (var lLUT: integer; var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); //lLUT: 0=gray,1=red,2=green,3=blue +var + lR,lG,lB,lInc: integer; +begin + for lInc := 0 to 255 do + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + + case lLUT of + 1: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := 0; + end;//red + 2: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := lInc; + end;//blue + 3: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := 0; + end;//green + 4: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := lInc; + end;//r+b=violet + 5: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := 0; + end;//red + green = yellow + 6: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := lINc; + end;//green+blue = cyan + maxint: begin// + //showmessage(inttostr(lBackgroundImg.VOIClr)+' '+'r'+inttostr(lR)+'g'+inttostr(lG)+'b'+inttostr(lB)); + lHdr.LUT[0].rgbRed := 0; + lHdr.LUT[0].rgbGreen := 0; + lHdr.LUT[0].rgbBlue := 0; + + lR := (lBackgroundImg.VOIClr and 255) ; + lG := ((lBackgroundImg.VOIClr shr 8) and 255) ;// and 65280; + lB:= ((lBackgroundImg.VOIClr shr 16) and 255) ;//and 16711680; + for lInc := 1 to kVOI8bit do begin + lHdr.LUT[lInc].rgbRed := round((lInc*lR) div kVOI8bit); + lHdr.LUT[lInc].rgbGreen := round((lInc*lG) div kVOI8bit); + lHdr.LUT[lInc].rgbBlue := round((lInc*lB) div kVOI8bit); + end;//green+blue = cyan + end; + else begin + lLUT := 0; + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := lInc; + end;//for gray + end//else... gray + end; + + + lHdr.LUTinvisible := (lHdr.LUT[0]); +end; + +procedure LUTbias (var lHdr: TMRIcroHdr); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick +Graphics Gems IV, p379-382, April 1994 } +var + lIndex,lBias: integer; + lA,lT: single; + lLUT: TLUT; +begin +//if gBias = 0.5 then exit; + lA := 0.2; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lBias := round(255*(lt/((1/la-2)*(1-lt)+1)) ); + lLUT[lIndex] := lHdr.LUT[(lBias)]; + //lHdr.LUT[lIndex].rgbReserved := kLUTalpha; + end; + for lIndex := 1 to 254 do + lHdr.LUT[lIndex] := lLUT[lIndex]; +end; + +procedure LoadColorScheme(lStr: string; var lHdr: TMRIcroHdr); +const UNIXeoln = chr(10); +var + lF: textfile; + lBuff: bytep0; + lFData: file; + lCh: char; + lNumStr: String; + lZ : integer; + lByte,lIndex: byte; + //lType, + lIndx,lLong,lR,lG: boolean; +procedure ResetBools; //nested +begin + //lType := false; + lIndx := false; + lR := false; + lG := false; + lNumStr := ''; +end; //nested proc ResetBools +begin //proc LoadColorScheme + if not fileexistsex(lStr) then exit; + lZ := FSize(lStr); + if (lZ =768) or (lZ = 800) or (lZ=970) then begin + //binary LUT + assignfile(lFdata,lStr); + Filemode := 0; + reset(lFdata,1); + seek(lFData,lZ-768); + GetMem( lBuff, 768); + BlockRead(lFdata, lBuff^, 768); + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := lBuff^[lZ]; + lHdr.LUT[lZ].rgbGreen := lBuff^[lZ+256]; + lHdr.LUT[lZ].rgbBlue := lBuff^[lZ+512]; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + closefile(lFdata); + Filemode := 2; + + freemem(lBuff); + //LUTBIas (lHdr); + lHdr.LUTinvisible := (lHdr.LUT[0]); + exit; + end; + //Text LUT + assignfile(lF,lStr); + Filemode := 0; + reset(lF); + lLong := false; + lIndex := 0; + ResetBools; + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := 0; + lHdr.LUT[lZ].rgbGreen := 0; + lHdr.LUT[lZ].rgbBlue := 0; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + while not EOF(lF) do begin + read(lF,lCh); + if lCh = '*' then //comment character + while (not EOF(lF)) and (lCh <> kCR) and (lCh <> UNIXeoln) do + read(lF,lCh); + if (lCh = 'L') or (lCh = 'l') then begin + //lType := true; + lLong := true; + end; //'l' + if (lCh = 's') or (lCh = 'S') then begin + //lType := true; + lLong := false; + end; //'s' + if lCh in ['0'..'9'] then + lNumStr := lNumStr + lCh; + if ((not(lCh in ['0'..'9'])) or (EOF(lF)) ) and (length(lNumStr) > 0) then begin //not a number = space??? try to read number string + if not lIndx then begin + lIndex := strtoint(lNumStr); + lIndx := true; + end else begin //not index + if lLong then + lByte := trunc(strtoint(lNumStr) / 256) + else + lByte := strtoint(lNumStr); + if not lR then begin + lHdr.LUT[lIndex].rgbRed := lByte; + lR := true; + end else if not lG then begin + lHdr.LUT[lIndex].rgbGreen := lByte; + lG := true; + end else {final value is blue} begin + lHdr.LUT[lIndex].rgbBlue := lByte; + ResetBools; + end; + end; + lNumStr := ''; + end; + end; //not eof + CloseFile(lF); + Filemode := 2; + //LUTBIas (lHdr); + lHdr.LUTinvisible := (lHdr.LUT[0]); +end; //Proc LoadColorScheme + +procedure FreeImgMemory(var lHdr: TMRIcroHdr); +begin + with lHdr do begin + if ScrnBufferItems > 0 then freemem(ScrnBuffer); + if ImgBufferItems > 0 then freemem(ImgBufferUnaligned); + if RenderBufferItems > 0 then freemem(RenderBuffer); + RenderBufferItems := 0; + ScrnBufferItems := 0; + ImgBufferItems := 0; + end; +end; + +procedure DrawFrame (var lImage: TImage; lL,lT,lR,lB: integer); +begin +lImage.Canvas.Brush.Style := bsSolid; + lImage.canvas.pen.color := clWhite; + + lImage.canvas.pen.color := clSilver; + + lImage.Canvas.Rectangle(lL,lT,lR,lB); + lImage.canvas.pen.color := clBlack; + lImage.Canvas.Rectangle(lL+1,lT+1,lR-1,lB-1); +end; + +procedure IntenLabel (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer;lMinIn,lMaxIn: single); +//special: if lMin=lMax, assumes current window values +var + lDesiredSteps,lPower,lTxtWid,lTxtTop,lPGWid,lPGHt,lBarTop,lBarLeft,lBarLength,lBarBorder,lBarThick: integer; + lMin,lMax,l1stStep,lRange,lStepSize,lStepPos: single; + lSteps,lStep,lDecimals,lStepPosScrn: integer; +begin + lMin := lMinIn; + lMax := lMaxIn; + lBarBorder := 6; + lBarThick := 10; + lPGWid := lImage.Width; + lPGHt := lImage.Height; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + //lImage.canvas.font.Color := clWhite;//gXBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + (*if lPGWid < 100 then + lImage.Canvas.Font.Size := 9 + else if lPGWid < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14;*) + lImage.Canvas.Font.Size := gBGImg.FontSize; + lTxtTop := lPGHt - ( lBarBorder +(lImage.Canvas.TextHeight('X') div 2)); + //next: compute increment + lDesiredSteps := 4; + if lMin=lMax then begin + + lMin := lHdr.WindowScaledMin; + lMax := lHdr.WindowScaledMax; + SortSingle(lMin,lMax); + if (lHdr.WindowScaledMin <= 0) and (lHdr.WindowScaledMax <= 0) then begin + if (lHdr.LutFromZero) then + lMax := 0; + lStepPos := lMin; + lMin := lMax; + lMax := lStepPos; + end else + if (lHdr.LutFromZero) and (lMin > 0) then + lMin := 0; + end; //lMinIn=lMaxIn + if lMin = lMax then exit; + //showmessage(realtostr(lMin,4)+' '+realtostr(lMax,4)); + lRange := abs(lMax - lMin); + //if lRange = 0 then exit; + if lRange < 0.000001 then exit; + lStepSize := lRange / lDesiredSteps; + lPower := 0; + while lStepSize >= 10 do begin + lStepSize := lStepSize/10; + inc(lPower); + end; + while lStepSize < 1 do begin + lStepSize := lStepSize * 10; + dec(lPower); + end; + lStepSize := round(lStepSize) *Power(10,lPower); + if lPower < 0 then + lDecimals := abs(lPower) + else + lDecimals := 0; + if lMin > lMax then begin // inverted + l1stStep := trunc((lMax) / lStepSize)*lStepSize; + if l1stStep < (lMax) then l1stStep := l1stStep+lStepSize; + lSteps := trunc( abs((lMin+0.0001)-l1stStep) / lStepSize)+1; + end else begin + l1stStep := trunc((lMin) / lStepSize)*lStepSize; + if l1stStep < (lMin) then l1stStep := l1stStep+lStepSize; + lSteps := trunc( abs((lMax+0.0001)-l1stStep) / lStepSize)+1; + end; + if not odd(lLTRB) then begin //vertical + if lLTRB > 2 then //right + lBarLeft := lPGWid - (lBarThick+lBarBorder+3) + else //if right else LEFT + lBarLeft := (lBarThick+lBarBorder+3); + lBarLength := lPGHt - (lBarBorder+lBarBorder+2); + for lStep := 1 to lSteps do begin + lStepPos := l1stStep+((lStep-1)*lStepSize); + lStepPosScrn := round( abs(lStepPos-lMin)/lRange*lBarLength); + if lLTRB > 2 then //right - align text for width + lImage.canvas.TextOut(lBarLeft-(lImage.Canvas.TextWidth(realtostr(lStepPos,lDecimals))),lTxtTop-lStepPosScrn,realtostr(lStepPos,lDecimals)) + else + lImage.canvas.TextOut(lBarLeft,lTxtTop-lStepPosScrn,realtostr(lStepPos,lDecimals)); + end; + end else begin //if vert else HORIZ + lBarLength := lPGWid - (lBarBorder+lBarBorder+2); + if lLTRB > 2 then //bottom + lBarTop := lPGHt - (lBarThick+lBarBorder+lImage.Canvas.TextHeight('X')+1 ) + else //top + lBarTop := lBarThick+lBarBorder+1; + for lStep := 1 to lSteps do begin + lStepPos := l1stStep+((lStep-1)*lStepSize); + lStepPosScrn := round(abs(lStepPos-lMin)/lRange*lBarLength); + //lStepPosScrn := 15*lStep; + lTxtWid := lImage.Canvas.TextWidth(realtostr(lStepPos,lDecimals)); + lImage.canvas.TextOut(lBarBorder+lStepPosScrn-(lTxtWid div 2),lBarTop,realtostr(lStepPos,lDecimals)); + end; + end;//if vert else HORIZ +end; + +procedure IntenBar (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer; lMin,lMax: single); +var lPGHt, lPGWid,lClr,lStripe,lBarBorder,lnStripes,lHorBarTop,lVerBarLeft,lBarThick: integer; +begin + //if lMin = lMax then + lBarBorder := 6; + lBarThick := 10; + lPGWid := lImage.Width; + lPGHt := lImage.Height; + lHorBarTop := lBarBorder; + lVerBarLeft := lBarBorder; + lImage.canvas.pen.width := 1; + if not odd(lLTRB) then begin + //vertical + if lLTRB > 2 then //right + lVerBarLeft := lPGWid - (lBarThick+lBarBorder); + lnStripes := lPGHt - (lBarBorder+lBarBorder+2); + + if lnStripes < 1 then exit; + {$IFNDEF FPC} + DrawFrame(lImage, lVerBarLeft-2, lBarBorder-2,lVerBarLeft+lBarThick+2, lBarBorder+lnStripes+3); + {$ELSE} + DrawFrame(lImage, lVerBarLeft-2, lBarBorder-2,lVerBarLeft+lBarThick+2, lBarBorder+lnStripes+2); + lBarBorder := lBarBorder; lBarThick := lBarThick +1; {$ENDIF} + for lStripe := 0 to lnStripes do begin + lClr := round(((lnStripes- lStripe) / lnStripes)*255); + lImage.canvas.pen.color := TRGBQuad2TColor(lHdr.LUT[lClr]); + lImage.canvas.moveto(lVerBarLeft, lBarBorder+lStripe); + lImage.canvas.lineto(lVerBarLeft+lBarThick,lBarBorder+lStripe); + end; //draw each stripe + end else begin //LTRB + //Horizontal + if lLTRB > 2 then //bottom + lHorBarTop := lPGHt - (lBarThick+lBarBorder)-1; + lnStripes := lPGWid - (lBarBorder+lBarBorder+1); + {$IFNDEF FPC} + DrawFrame(lImage,lBarBorder+1, lHorBarTop-2, lBarBorder+lnStripes+3,lHorBarTop+lBarThick+2); + {$ELSE} + DrawFrame(lImage,lBarBorder, lHorBarTop-2, lBarBorder+lnStripes+4,lHorBarTop+lBarThick+2); + lBarBorder := lBarBorder+2; lBarThick := lBarThick +1; {$ENDIF} + + if lnStripes < 1 then exit; + for lStripe := 0 to lnStripes do begin + lClr := round((lStripe / lnStripes)*255); + + {$IFNDEF FPC} +lImage.canvas.pen.color := lHdr.LUT[lClr].rgbRed+(lHdr.LUT[lClr].rgbGreen shl 8)+(lHdr.LUT[lClr].rgbBlue shl 16); + {$ELSE}lImage.canvas.pen.Color := TRGBQuad2TColor(lHdr.LUT[lClr]);{$ENDIF} + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop+lBarThick); + end; //draw each stripe + end; //if horizontal + IntenLabel(lImage,lHdr,lLTRB,lMin,lMax); +end; + +//procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +(*procedure DrawBMPZoom( lx, ly, lZoomPct: integer; lBuff: RGBQuadp; var lImage: TImage); +var + x, y,lYPos,lPos,lImgSz,lOutX,lOutY: Integer; + lRatio,lRatioRecip: single; + TempBitmap: TBitmap; + lLongBuff: LongIntp; + lXlut: LongIntp0; +begin + if lZoomPct > 1 then + lRatio := lZoomPct/100 + else + lRatio := 1; + lRatioRecip := 1/lRatio;//e.g. 200% -> ratio = 2, recip = 0.5 + lImgSz := lx * ly; + TempBitmap := TBitmap.Create; + lLongBuff := LongIntp(lBuff); + lOutX := round(lx*lRatio); + lOutY := round(ly*lRatio); + TempBitmap.Width := lOutX; + TempBitmap.Height := lOutY; + //TempBitmap.PixelFormat := pf32bit ; + TempBitmap.Transparent := False; + if lBuff <> nil then begin + getmem(lXlut,lOutX*sizeof(longint)); + for x:=0 to lOutx-1 do + lXlut^[x] := trunc((x+lRatio)*lRatioRecip); //find col + for y:= (lOutY-1) downto 0 do begin + lYPos := trunc((lOutY-y-0.5)*lRatioRecip) * lx; //find row + for x:=0 to lOutx-1 do begin + lPos := lXlut^[x] + lYPos; + if (lPos > 0) and (lPos <= lImgSz) then + TempBitmap.Canvas.Pixels[x,y] := lLongBuff^[lPos]; + end; //for x + end;//for y + freemem(lXlut); + end; //if Buff<> nil + lImage.Picture.Bitmap := TempBitmap; + TempBitmap.Free; +end;*) + + + (*getmem(lTBuff,lInPGHt*lInPGWid*4); + lLen := lInPGWid*4; + lSrc := 1; + lDest := ((lInPGHt-1)*lInPGWid)+1; + for lY := 1 to lInPGHt do begin + //Move(Pointer(lBuff^[lSrc]),Pointer(lTBuff^[lDest]),lLen); + Move(lBuff^[lSrc],lTBuff^[lDest],lLen); + lSrc := lSrc + lInPGWid; + lDest := lDest - lInPGWid; + end; *) +(*procedure DrawBMP( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +var + DestPtr: PInteger; + row, i: integer; + bmp: TBitmap; +begin + bmp := TBitmap.Create; + bmp.Width:=lx; + bmp.Height:=ly; + bmp.PixelFormat := pf32bit; //if pf32bit the background color is wrong, e.g. when alpha = 0 + if lBuff = nil then exit; + //lImage.Picture.Bitmap.BeginUpdate(False); + DestPtr := PInteger(bmp.RawImage.Data); + if bmp.RawImage.Description.BytesPerLine = (lx * 4) then + Move(lBuff^, DestPtr^, lx * ly * 4) + else begin + i := 1; + for row:=0 to ly-1 do begin + Move(lBuff^[i], DestPtr^, lx * 4); + Inc(PByte(DestPtr),bmp.RawImage.Description.BytesPerLine); + inc(i, lx); + end; + end; + //lImage.Picture.Bitmap.EndUpdate(False); + lImage.Picture.Bitmap := bmp; + bmp.free; +end; *) +(*UPSIDE DOWN! +procedure DrawBMP( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +var + DestPtr: PInteger; + row, i: integer; +begin + lImage.Picture.Bitmap.Width:=lx; + lImage.Picture.Bitmap.Height:=ly; + lImage.Picture.Bitmap.PixelFormat := pf32bit; //if pf32bit the background color is wrong, e.g. when alpha = 0 + if lBuff = nil then exit; + lImage.Picture.Bitmap.BeginUpdate(False); + DestPtr := PInteger(lImage.Picture.Bitmap.RawImage.Data); + if lImage.Picture.Bitmap.RawImage.Description.BytesPerLine = (lx * 4) then + Move(lBuff^, DestPtr^, lx * ly * 4) + else begin + i := 1; + for row:=0 to ly-1 do begin + Move(lBuff^[i], DestPtr^, lx * 4); + Inc(PByte(DestPtr), lImage.Picture.Bitmap.RawImage.Description.BytesPerLine); //Bmp.RawImage.Description.BytesPerLine + inc(i, lx); + end; + end; + lImage.Picture.Bitmap.EndUpdate(False); +end; *) + + +procedure DrawBMP( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +var + DestPtr: PInteger; + row, i: integer; +begin + lImage.Picture.Bitmap.Width:=lx; + lImage.Picture.Bitmap.Height:=ly; + lImage.Picture.Bitmap.PixelFormat := pf32bit; //if pf32bit the background color is wrong, e.g. when alpha = 0 + if lBuff = nil then exit; + lImage.Picture.Bitmap.BeginUpdate(False); + i := 1; + for row:= ly-1 downto 0 do begin + DestPtr := PInteger(lImage.Picture.Bitmap.RawImage.GetLineStart(row)); + Move(lBuff^[i], DestPtr^, lx * 4); + inc(i, lx); + end; + lImage.Picture.Bitmap.EndUpdate(False); +end; + +procedure DrawBMPZoomNN(lSrcHt,lSrcWid: integer; lZoomFrac: single; var lRGBBuff: RGBQuadp; var lImage: TImage); +//Nearest Neighbor Stretch +var + lBuff,lInBuff,lXBuff: LongintP; + lOutRGBBuff: RGBQuadp; + lOutWid,lOutHt,lPos,x,y, lRowPos: integer; + fp, z: single; +begin + lOutwid := round(lSrcWid*lZoomFrac); + lOutHt := round(lSrcHt*lZoomFrac); + if (lOutwid < 2) or (lOutHt < 2) then exit; + z := (1/lZoomFrac)-eps; + lInBuff:= LongIntP(lRGBBuff); + getmem(lBuff, lOutHt*lOutWid * 4); + getmem(lXBuff, lOutWid*sizeof(longint)); + for x := 1 to lOutWid do begin + fp := x * z; + if fp < 1 then + fp := 1; + if fp > lSrcWid then + fp := lSrcWid; + lXBuff^[x] := ceil(fp); + end; + //imgForm.StatusLabel.Caption := floattostr(lZoomFrac); + lPos := 1; + for y:= 1 to lOutHt do begin + fp := y * z; + if fp < 1 then + fp := 1; + if fp > lSrcHt then + fp := lSrcHt; + lRowPos:= lSrcWid * (ceil(fp)-1) ; + + for x := 1 to lOutWid do begin + lBuff^[lPos] := lInBuff^[lRowPos+lXBuff^[x]]; + inc(lPos); + end; + + end;//for each line + freemem(lxBuff); + lOutRGBBuff := RGBQuadp(@lBuff[1]); + DrawBMP( lOutWid, lOutHt, lOutRGBBuff, lImage); + freemem(lBuff); +end; + +function mixColor(XloYlo, XloYhi, XhiYlo, XhiYhi: byte; Xfrac, Yfrac: integer): byte; +var + XfracInv, YfracInv: integer; +begin + YfracInv := 1024 - Yfrac; + XfracInv := 1024 - Xfrac; + result :=( (XloYlo*XfracInv*YfracInv) + + (XloYhi*XfracInv*Yfrac) + + (XhiYlo*Xfrac*YfracInv) + + (XhiYhi*Xfrac*Yfrac)) shr 20; +(* result :=( (XloYlo*Xfrac*Yfrac) + + (XloYhi*Xfrac*YfracInv) + + (XhiYlo*XfracInv*Yfrac) + + (XhiYhi*XfracInv*YfracInv)) shr 10; *) +end; + +function mixRGB( XloYlo, XloYhi, XhiYlo, XhiYhi: TRGBquad; Xfrac, Yfrac: integer): TRGBquad; +begin + result.rgbreserved:= kLUTalpha; + result.rgbRed:= mixColor(XloYlo.rgbRed, XloYhi.rgbRed, XhiYlo.rgbRed, XhiYhi.rgbRed, Xfrac, Yfrac); + result.rgbGreen:= mixColor(XloYlo.rgbGreen, XloYhi.rgbGreen, XhiYlo.rgbGreen, XhiYhi.rgbGreen, Xfrac, Yfrac); + result.rgbBlue:= mixColor(XloYlo.rgbBlue, XloYhi.rgbBlue, XhiYlo.rgbBlue, XhiYhi.rgbBlue, Xfrac, Yfrac); +end; + +(*procedure DrawBMPZoomLin(lSrcHt,lSrcWid: integer; lZoomFrac: single; var lInBuff: RGBQuadp; var lImage: TImage); +//About half the speed of the integer version +const + kBitShift = 10; //integer division 1024 = 1 +var + lOutBuff: RGBQuadp; + lOutWid,lOutHt: integer; + lXlo,lXhi,lXfrac,lYlo,lYhi,lYfrac: array of integer; + mx, x,y, bitShift, i: integer; + lFrac, lZoomReciprocal: single; +begin + lOutwid := round(lSrcWid*lZoomFrac); + lOutHt := round(lSrcHt*lZoomFrac); + if (lOutwid < 2) or (lOutHt < 2) or (lZoomFrac <= 0) then exit; + lZoomReciprocal := 1/lZoomFrac; + setlength(lYlo, lOutHt); + setlength(lYhi, lOutHt); + setlength(lYfrac, lOutHt); + bitShift := 1 shl kBitShift; + mx := (lSrcHt -1) * lSrcWid; + for y := 0 to lOutHt -1 do begin + lFrac := (y * lZoomReciprocal) - 0.5; + if lFrac < 0 then lFrac := 0; + lYfrac[y] := round(frac(lFrac) * bitshift); + lYlo[y] := trunc(lFrac); + lYlo[y] := lYlo[y] * lSrcWid; + lYhi[y] := lYlo[y] + lSrcWid; + if (lYhi[y] > mx) then + lYhi[y] := mx; + end; + setlength(lXlo, lOutWid); + setlength(lXhi, lOutWid); + setlength(lXfrac, lOutWid); + mx := lSrcWid; //no -1: indexed from 1 not 0 + for x := 0 to lOutWid -1 do begin + lFrac := (x * lZoomReciprocal) - 0.5; + if lFrac < 0 then lFrac := 0; + lXlo[x] := trunc(lFrac)+1; + lXhi[x] := lXlo[x] + 1; + if (lXhi[x] > mx) then + lXhi[x] := mx; + lXfrac[x] := round(frac(lFrac) * bitshift); + end; + getmem(lOutBuff, lOutHt*lOutWid*4); + i := 0; + for y:=0 to lOutHt-1 do begin + for x:=0 to lOutWid-1 do begin + i := i + 1; //indexex from 1; + lOutBuff[i] := mixRGB(lInBuff[lXlo[x]+lYlo[y]], lInBuff[lXlo[x]+lYhi[y]], lInBuff[lXhi[x]+lYlo[y]], lInBuff[lXhi[x]+lYhi[y]], lXfrac[x], lYfrac[y]) ; + end;//for x : columns + end; //for y : slices + DrawBMP( lOutWid, lOutHt, lOutBuff, lImage); + freemem(lOutBuff); +end;*) + +procedure DrawBMPZoomLin(lSrcHt,lSrcWid: integer; lZoomFrac: single; var lRGBBuff: RGBQuadp; var lImage: TImage); +//Stretch bitmap with bilinear interpolation +var + lInBuff,lBuff: ByteP; + lOutRGBBuff: RGBQuadp; + lOutWid,lOutHt: integer; + lSrcWidx4, lPos,xPmax, xP,yP,yP2,xP2,z, z2,iz2,w1,w2,w3,w4,lTopPos,lBotPos, + lINSz,x,y, t: integer; +begin + lInBuff:= ByteP(lRGBBuff); + lOutwid := round(lSrcWid*lZoomFrac); + lOutHt := round(lSrcHt*lZoomFrac); + if (lOutwid < 2) or (lOutHt < 2) then exit; + xP2:=((lSrcWid)shl 15)div (lOutWid ); +imgform.StatusLabel.Caption := inttostr(xP2); + yP2:=((lSrcHt) shl 15)div (lOutHt); + lPos := 1; + getmem(lBuff, lOutHt*lOutWid*4); + lInSz := lSrcWid *lSrcHt * 4; //32bytesperpixel + lSrcWidx4 := lSrcWid * 4; + yP:= -16384+ (yP2 shr 1); + //imgform.statuslabel.caption := inttostr(yP2)+' '+inttostr(lSrcWid)+'->'+inttostr(lOutWid); + xPmax := ((lSrcWid - 1) * 32768)-1; + for y:=0 to lOutHt-1 do begin + xP:= -16384+ (xP2 shr 1); //16384, e.g. 0.5 voxel + if yP <= 0 then begin + lTopPos := 0; + lBotPos := 0; + end else begin + lTopPos := lSrcWid * (yP shr 15) *4; //top row + lBotPos := lTopPos+lSrcWidx4; + end; + if lBotPos >= lInSz then lBotPos := lBotPos - lSrcWidx4; + if lTopPos >= lInSz then lTopPos := lTopPos - lSrcWidx4; + z2:=yP and $7FFF; + iz2:=$8000-z2; + for x:=0 to lOutWid-1 do begin + t:= ((xP shr 15) * 4); + if (xP > xPmax) then begin + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); //reds + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + end else if (xP < 0) and ((lBotPos+4) < lInSz) then begin + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reds + lBuff^[lPos] :=(lInBuff^[lTopPos+2]*iz2+lInBuff^[lBotPos+2]*z2)shr 15; inc(lPos); //greens + lBuff^[lPos] :=(lInBuff^[lTopPos+3]*iz2+lInBuff^[lBotPos+3]*z2)shr 15; inc(lPos); //greens + lBuff^[lPos] :=(lInBuff^[lTopPos+4]*iz2+lInBuff^[lBotPos+4]*z2)shr 15; inc(lPos); //greens + (* + if ((lBotPos+t+8) > lInSz) or ((lTopPos+t) < 0) then begin + if (xP < 0) and ((lBotPos+4) < lInSz) then begin + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reds + lBuff^[lPos] :=(lInBuff^[lTopPos+2]*iz2+lInBuff^[lBotPos+2]*z2)shr 15; inc(lPos); //greens + lBuff^[lPos] :=(lInBuff^[lTopPos+3]*iz2+lInBuff^[lBotPos+3]*z2)shr 15; inc(lPos); //greens + lBuff^[lPos] :=(lInBuff^[lTopPos+4]*iz2+lInBuff^[lBotPos+4]*z2)shr 15; inc(lPos); //greens + + end else if (lPos > 4) then begin + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reds + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + lBuff^[lPos] :=lBuff^[lPos-4]; inc(lPos); + + end else begin + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reds + lBuff^[lPos] :=0; inc(lPos); //greens + lBuff^[lPos] :=0; inc(lPos); //blues + lBuff^[lPos] :=kLUTalpha; inc(lPos); //reserved + end; *) + end else begin + z:=xP and $7FFF; + w2:=(z*iz2)shr 15; + w1:=iz2-w2; + w4:=(z*z2)shr 15; + w3:=z2-w4; + {$IFDEF Darwin} + //(lInBuff^[lTopPos+t+1]*w1+lInBuff^[lTopPos+t+5]*w2+lInBuff^[lBotPos+t+1]*w3+lInBuff^[lBotPos+t+5]*w4)shr 15; + //ALPHA + lBuff^[lPos] := kLUTalpha ; + inc(lPos); + //RED + lBuff^[lPos] := (lInBuff^[lTopPos+t+2]*w1+lInBuff^[lTopPos+t+6]*w2+lInBuff^[lBotPos+t+2]*w3+lInBuff^[lBotPos+t+6]*w4)shr 15; ;// + inc(lPos); + //GREEN + lBuff^[lPos] :=(lInBuff^[lTopPos+t+3]*w1+lInBuff^[lTopPos+t+7]*w2+lInBuff^[lBotPos+t+3]*w3+lInBuff^[lBotPos+t+7]*w4)shr 15; + inc(lPos); + //BLUE + lBuff^[lPos] :=(lInBuff^[lTopPos+t+4]*w1+lInBuff^[lTopPos+t+8]*w2+lInBuff^[lBotPos+t+4]*w3+lInBuff^[lBotPos+t+8]*w4)shr 15; + inc(lPos); + {$ELSE} + lBuff^[lPos] :=(lInBuff^[lTopPos+t+1]*w1+lInBuff^[lTopPos+t+5]*w2+lInBuff^[lBotPos+t+1]*w3+lInBuff^[lBotPos+t+5]*w4)shr 15; + inc(lPos); //red + lBuff^[lPos] :=(lInBuff^[lTopPos+t+2]*w1+lInBuff^[lTopPos+t+6]*w2+lInBuff^[lBotPos+t+2]*w3+lInBuff^[lBotPos+t+6]*w4)shr 15; + inc(lPos); //green + lBuff^[lPos] :=(lInBuff^[lTopPos+t+3]*w1+lInBuff^[lTopPos+t+7]*w2+lInBuff^[lBotPos+t+3]*w3+lInBuff^[lBotPos+t+7]*w4)shr 15; + inc(lPos); //blue + lBuff^[lPos] :=kLUTalpha; + inc(lPos); //reserved lPos := lPos + 4; + {$ENDIF} + end; + Inc(xP,xP2); + end; //inner loop + Inc(yP,yP2); + end; + lOutRGBBuff := RGBQuadp(@lBuff[1]); + DrawBMP( lOutWid, lOutHt, lOutRGBBuff, lImage); + freemem(lBuff); +end; + +(*procedure DrawBMPZoomLin(lSrcHt,lSrcWid: integer; lZoomFrac: single; var lRGBBuff: RGBQuadp; var lImage: TImage); +//Stretch bitmap with bilinear interpolation +var + lInBuff,lBuff: ByteP; + lOutRGBBuff: RGBQuadp; + lOutWid,lOutHt: integer; + lSrcWidx4, lPos,xP,yP,yP2,xP2,z, z2,iz2,w1,w2,w3,w4,lTopPos,lBotPos, + lINSz,x,y, t: integer; +begin + lInBuff:= ByteP(lRGBBuff); + lOutwid := round(lSrcWid*lZoomFrac); + lOutHt := round(lSrcHt*lZoomFrac); + if (lOutwid < 2) or (lOutHt < 2) then exit; + xP2:=((lSrcWid)shl 15)div (lOutWid ); + yP2:=((lSrcHt) shl 15)div (lOutHt); + lPos := 1; + getmem(lBuff, lOutHt*lOutWid*4); + lInSz := lSrcWid *lSrcHt * 4; //32bytesperpixel + lSrcWidx4 := lSrcWid * 4; + yP:= -16384+ (yP2 shr 1); + //imgform.statuslabel.caption := inttostr(yP2)+' '+inttostr(lSrcWid)+'->'+inttostr(lOutWid); + + for y:=0 to lOutHt-1 do begin + xP:= -16384+ (xP2 shr 1); //16384, e.g. 0.5 voxel + if yP <= 0 then begin + lTopPos := 0; + lBotPos := 0; + end else begin + lTopPos := lSrcWid * (yP shr 15) *4; //top row + lBotPos := lTopPos+lSrcWidx4; + //if (yP shr 16) < lSrcHt then + //inc(lBotPos, lSrcWidx4) //bottom column + end; + if lBotPos >= lInSz then lBotPos := lBotPos - lSrcWidx4; + if lTopPos >= lInSz then lTopPos := lTopPos - lSrcWidx4; + z2:=yP and $7FFF; + iz2:=$8000-z2; + for x:=0 to lOutWid-1 do begin + t:= ((xP shr 15) * 4); + if ((lBotPos+t+8) > lInSz) or ((lTopPos+t) < 0) then begin + lBuff^[lPos] :=0; inc(lPos); //reds + lBuff^[lPos] :=0; inc(lPos); //greens + lBuff^[lPos] :=0; inc(lPos); //blues + lBuff^[lPos] :=0; inc(lPos); //reserved + end else begin + z:=xP and $7FFF; + w2:=(z*iz2)shr 15; + w1:=iz2-w2; + w4:=(z*z2)shr 15; + w3:=z2-w4; +//burp ScaleStretch 10/2009 + {$IFDEF Darwin} + //(lInBuff^[lTopPos+t+1]*w1+lInBuff^[lTopPos+t+5]*w2+lInBuff^[lBotPos+t+1]*w3+lInBuff^[lBotPos+t+5]*w4)shr 15; + //ALPHA + lBuff^[lPos] := kLUTalpha ; + inc(lPos); + //RED + lBuff^[lPos] := (lInBuff^[lTopPos+t+2]*w1+lInBuff^[lTopPos+t+6]*w2+lInBuff^[lBotPos+t+2]*w3+lInBuff^[lBotPos+t+6]*w4)shr 15; ;// + inc(lPos); + //GREEN + lBuff^[lPos] :=(lInBuff^[lTopPos+t+3]*w1+lInBuff^[lTopPos+t+7]*w2+lInBuff^[lBotPos+t+3]*w3+lInBuff^[lBotPos+t+7]*w4)shr 15; + inc(lPos); + //BLUE + lBuff^[lPos] :=(lInBuff^[lTopPos+t+4]*w1+lInBuff^[lTopPos+t+8]*w2+lInBuff^[lBotPos+t+4]*w3+lInBuff^[lBotPos+t+8]*w4)shr 15; + inc(lPos); + {$ELSE} + lBuff^[lPos] :=(lInBuff^[lTopPos+t+1]*w1+lInBuff^[lTopPos+t+5]*w2+lInBuff^[lBotPos+t+1]*w3+lInBuff^[lBotPos+t+5]*w4)shr 15; + inc(lPos); //red + lBuff^[lPos] :=(lInBuff^[lTopPos+t+2]*w1+lInBuff^[lTopPos+t+6]*w2+lInBuff^[lBotPos+t+2]*w3+lInBuff^[lBotPos+t+6]*w4)shr 15; + inc(lPos); //green + lBuff^[lPos] :=(lInBuff^[lTopPos+t+3]*w1+lInBuff^[lTopPos+t+7]*w2+lInBuff^[lBotPos+t+3]*w3+lInBuff^[lBotPos+t+7]*w4)shr 15; + inc(lPos); //blue + lBuff^[lPos] :=kLUTalpha; + inc(lPos); //reserved lPos := lPos + 4; + {$ENDIF} + end; + Inc(xP,xP2); + end; //inner loop + Inc(yP,yP2); + end; + lOutRGBBuff := RGBQuadp(@lBuff[1]); + DrawBMP( lOutWid, lOutHt, lOutRGBBuff, lImage); + freemem(lBuff); +end; +*) +procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +var + lZoom,lZoomY,lZoomX: integer; + // lStartTime: DWord; i: integer; + lTBuff: RGBQuadp; +begin + //first, compute zoom + if (lPanel = nil) then + lImage.Tag := 100 + else if (lPanel.Tag < 1) then begin//autosize + lZoomY := round(100*(lPanel.Height-8)/lInPGHt); + lZoomX := round(100*(lPanel.Width-8)/lInPGWid); + if lZoomX < lZoomY then + lZoom := lZoomX + else + lZoom := lZoomY; + if lZoom < 1 then //nearest integer e.g. 100% or 200%, not 148% + lZoom := 100; + lImage.Tag := lZoom; + end; + if (lImage.Tag < 1) then + lImage.Tag := 100 ; + + //next draw bitmap + if lBuff = nil then begin + getmem(lTBuff,lInPGHt*lInPGWid*4); + Fillchar(lTBuff^,lInPGHt*lInPGWid*4,0); //set all to zero + DrawBMP( lInPGWid, lInPGHt, lTBuff, lImage); + freemem(lTBuff); + end else if (lImage.Tag = 100) or (lPanel = nil) then begin + DrawBMP( lInPGWid, lInPGHt, lBuff, lImage); + end else begin //not 100% + lZoom := lImage.Tag; + if lZoom = 100 then + DrawBMP( lInPGWid, lInPGHt, lBuff, lImage) + else begin + //lStartTime := GetTickCount; + //for i := 1 to 20 do begin + if gBGImg.StretchQuality = sqHigh then //bilinear smoothed zoom + DrawBMPZoomLin(lInPGHt,lInPGWid,lZoom/100,lBuff, lImage) + else //nearest neighbor + DrawBMPZoomNN(lInPGHt,lInPGWid,lZoom/100,lBuff, lImage); + //end; + //ImgForm.StatusLabel.Caption := inttostr(GetTickCount - lStartTime); + end; + lImage.Tag := lZoom; + end; +end; + +procedure FindImgMinMax8 (var lHdr: TMRIcroHdr; var lMini,lMaxi: integer); +var + lInc: integer; +begin + if (lHdr.ImgBufferBPP <> 1) or (lHdr.ImgBufferItems < 1) then exit; + lMini := lHdr.ImgBuffer^[1]; + lMaxi := lHdr.ImgBuffer^[1]; + for lInc := 1 to lHdr.ImgBufferItems do begin + if lHdr.ImgBuffer^[lInc] > lMaxi then lMaxi := lHdr.ImgBuffer^[lInc]; + if lHdr.ImgBuffer^[lInc] < lMini then lMini := lHdr.ImgBuffer^[lInc]; + end; +end; //FindImgMinMax8 + +procedure FindImgMinMax16 (var lHdr: TMRIcroHdr; var lMini,lMaxi: integer); +//very fast routine for finding brightest and darkest intensity... +var + lImgSamples,lInc,lFinalVal: integer; + l16Buf: SmallIntP; +begin + if (lHdr.ImgBufferBPP <> 2) or (lHdr.ImgBufferItems < 1) then exit; + lImgSamples := lHdr.ImgBufferItems; + lInc:=1; + l16Buf := SmallIntP(lHdr.ImgBuffer ); + lMaxI := l16Buf^[lImgSamples]; + lMinI := lMaxi; + lFinalVal := lMaxi; + l16Buf^[lImgSamples]:=32767; // set last value to the maximum integer value + while true do // no check here at all now + begin + while (lMaxI>l16Buf^[lInc]) and (l16Buf^[lInc] >= lMini) do // stop for a >= value + inc(lInc); + if lInc=lImgSamples then begin + l16Buf^[lImgSamples]:=lFinalVal; + exit; // check to see if new max is actually end of data + end; + if l16Buf^[lInc] >lMaxi then + lMaxI:=l16Buf^[lInc]; + if l16Buf^[lInc] < lMini then + lMini:=l16Buf^[lInc]; + inc(lInc); + end; +end; //FindImgMinMax16 + +procedure FindImgMinMax32 (var lHdr: TMRIcroHdr; var lMin,lMax: single); +var + lInc: integer; + l32Buf : SingleP; +begin + if (lHdr.ImgBufferBPP <> 4) or (lHdr.ImgBufferItems < 2) then exit; + l32Buf := SingleP(lHdr.ImgBuffer ); + //if specialsingle(lHdr.MRIcroHdr.gMultiBuf[1]) then lHdr.MRIcroHdr.gMultiBuf[1] := 0.0; + lMin := l32Buf^[1]; + lMax := l32Buf^[1]; + for lInc := 2 to lHdr.ImgBufferItems do begin + if (l32Buf^[lInc] > lMax) then lMax := l32Buf^[lInc]; + if (l32Buf^[lInc] < lMin) then lMin := l32Buf^[lInc]; + end; +end; //FindImgMinMax32 + +function ImgVaries ( var lHdr: TMRIcroHdr): boolean; +var + lF: single; + lI,lPos: integer; + l32Buf : SingleP; + l16Buf : SmallIntP; + +begin + result := false; + if lHdr.ImgBufferItems = 2 then exit; + result := true; //assume variance... + if lHdr.ImgBufferBPP = 4 then begin //32bit + l32Buf := SingleP(lHdr.ImgBuffer ); + lF := l32Buf^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if l32Buf^[lPos] <> lF then + exit; + end else if lHdr.ImgBufferBPP = 2 then begin //if 16bit ints + l16Buf := SmallIntP(lHdr.ImgBuffer ); + lI := l16Buf^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if l16Buf^[lPos] <> lI then + exit; + end else if lHdr.ImgBufferBPP = 1 then begin //if 16bit ints + lI := lHdr.ImgBuffer^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if lHdr.ImgBuffer^[lPos] <> lI then + exit; + end else + showmessage('ImgVaries error: Unsupported format'); + result := false; //entire image has no variability... +end; + +procedure CreateHisto (var lHdr: TMRIcroHdr; var lHisto: HistoRA); +var + lModShl10,lMinI,lC: integer; + lMod,lRng: double {was extended}; + l32Buf : SingleP; + l16Buf : SmallIntP; +begin + if lHdr.ImgBufferItems = 0 then exit; + for lC := 0 to kHistoBins do + lHisto[lC] := 0; + if lHdr.ImgBufferBPP = 4 then begin //32bit + l32Buf := SingleP(lHdr.ImgBuffer ); + lRng := lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS; + if lRng > 0 then + lMod := (kHistoBins)/lRng + else + lMod := 0; + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[round((l32Buf^[lC]-lHdr.GlMinUnscaledS)*lMod)]); + end else {if lHdr.g16Sz >= lHdr.ScrnBufferSz then}begin //<>32bit.. integer + lMinI := round(lHdr.GlMinUnscaledS); + lRng := lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS; + if lRng > 0 then + lMod := (kHistoBins)/lRng + else + lMod := 0; + lModShl10 := trunc(lMod * 1024); + if lHdr.ImgBufferBPP = 2 then begin //if 16bit ints + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[((l16Buf^[lC]-lMinI)*lModShl10)shr 10]) + end else //else 8 bit data + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[((lHdr.ImgBuffer^[lC]-lMinI)*lModShl10)shr 10]); + end; //not 32bit +end; + +function BinCenter (lBin: integer; var lHdr: TMRIcroHdr): single; +begin + result := (lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS)/(kHistoBins-1); //range div bins + result := (lBin * result)+ lHdr.GlMinUnscaledS+ (0.5*result); + +end; + +procedure TextReportHisto (var lHdr: TMRIcroHdr); +var + lC: integer; + var lHisto: HistoRA; +begin + CreateHisto (lHdr, lHisto); + TextForm.MemoT.Lines.Clear; + TextForm.MemoT.Lines.add('#Histogram summary ~ Approximate Values'); + TextForm.MemoT.Lines.add('#Image intensity range: '+realtostr(lHdr.GlMinUnscaledS,3)+'..'+realtostr(lHdr.GlMaxUnscaledS,3)); + TextForm.MemoT.Lines.add('#BinNumber'+kTextSep+'BinCenter'+kTextSep+'BinCount'); + for lC := 0 to kHistoBins do + TextForm.MemoT.Lines.Add( inttostr(lC) + kTextSep +realtostr(BinCenter(lC,lHdr),3) +kTextSep+ inttostr(lHisto[lC]) ); + TextForm.Show; + +end; + +procedure DrawHistogram (var lHdr: TMRIcroHdr; var lImage: TImage); +var lPGHt, lPGWid,lIntenBarHt,lStripe,lBarBorder,lnStripes,lHorBarTop,lBarHt, + l005Pct,ln005Pct,l02Pct,ln02Pct,l0005Pct,ln0005Pct,l001Pct,ln001Pct,l01Pct,ln01Pct,lMaxFreq,lMaxBarHt,lHistoPos,lPrevHistoPos,lFreq,lPos,lTotFreq: integer; + lPct: double; + lHisto: HistoRA; +begin + lPGWid := lImage.Width; + lPGHt := lImage.Height; + SetDimension32(lPGHt,lPGWid,nil,gBGImg,lImage,nil); + lImage.Canvas.Font.Name := 'Arial'; + (*if lPGWid < 100 then + lImage.Canvas.Font.Size := 9 + else if lPGWid < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14;*) + lImage.Canvas.Font.Size := gBGImg.FontSize; + CreateHisto (lHdr, lHisto); + lBarBorder := 6; + lIntenBarHt := 14; + DrawFrame(lImage, 0, 0,lPGWid,lPGHt); + lHorBarTop := lPGHt - lBarBorder-lIntenBarHt-lImage.Canvas.TextHeight('X'); + lMaxBarHt := lHorBarTop - lBarBorder- lBarBorder- lBarBorder; + lMaxFreq := 0; + lnStripes := lPGWid - (lBarBorder+lBarBorder+1); + if gBGImg.XBarClr = clWhite then + lImage.canvas.pen.color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.pen.color := gBGImg.XBarClr;//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + lImage.Canvas.Font.Color := lImage.canvas.pen.color; + lImage.Canvas.Brush.Style := bsSolid; + lImage.Canvas.Pen.Width := 1; + lImage.Canvas.Pen.Style := psDot; + lImage.canvas.moveto(lBarBorder,lHorBarTop-lMaxBarHt-1); + lImage.canvas.lineto(lPGWid-lBarBorder,lHorBarTop-lMaxBarHt-1); + lImage.Canvas.Brush.Style := bsClear; + if (lnStripes < 1) then exit; + //Next: compute scale find freq in graph - not same as image, as with large graphs bars resampled + lPrevHistoPos := 0; + lTotFreq := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + for lPos := lPrevHistoPos to lHistoPos do + lTotFreq := lTotFreq+lHisto[lPos]; + lPrevHistoPos := lHistoPos+1; + end; + ln02Pct := 0; + ln01Pct := 0; + ln005Pct := 0; + ln001Pct := 0; + ln0005Pct := 0; + l02Pct := round(lTotFreq/50); + l01Pct := round(lTotFreq/100); + l005Pct := round(lTotFreq/200); + l001Pct := round(lTotFreq/1000); + l0005Pct := round(lTotFreq/2000); + lPrevHistoPos := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + lFreq := 0; + for lPos := lPrevHistoPos to lHistoPos do + lFreq := lFreq+lHisto[lPos]; + if lFreq > lMaxFreq then + lMaxFreq := lFreq; + if lFreq > l02Pct then + inc(ln02Pct); + if lFreq > l01Pct then + inc(ln01Pct); + if lFreq > l005Pct then + inc(ln005Pct); + if lFreq > l001Pct then + inc(ln001Pct); + if lFreq > l0005Pct then + inc(ln0005Pct); + //lTotFreq := lTotFreq + lFreq; + lPrevHistoPos := lHistoPos+1; + end; + lImage.Canvas.Pen.Style := psSolid; + if ln02Pct > 5 then + lPct := 5 + else if ln01Pct > 5 then + lPct := 2 + else if ln005Pct > 5 then + lPct := 1 + else if ln001Pct > 4 then + lPct := 0.5 + else if ln0005Pct > 4 then + lPct := 0.01 + else + lPct := 0.05; + lMaxFreq :=round( lTotFreq * (lPct/100)); + if (lMaxFreq = 0) then exit; + //Next: draw bars + lImage.canvas.TextOut(lPGWid div 2,lHorBarTop-lMaxBarHt-1-6,' '+floattostr(lPct)+'% '); + lImage.Canvas.Brush.Style := bsClear; + lPrevHistoPos := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + lFreq := 0; + for lPos := lPrevHistoPos to lHistoPos do + lFreq := lFreq+lHisto[lPos]; + if lFreq > lMaxFreq then begin + lFreq := lMaxFreq; + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-8); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-6); + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-4); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-2); + end; + lBarHt := round(lFreq/lMaxFreq*lMaxBarHt); + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lBarHt); + lPrevHistoPos := lHistoPos+1; + end; //draw each stripe + intenBar(lImage,lHdr,3,Raw2ScaledIntensity(lHdr,lHdr.GlMinUnScaledS),Raw2ScaledIntensity(lHdr,lHdr.GlMaxUnscaledS)); +end; + +procedure Balance (var lHdr: TMRIcroHdr); +var + lPct,lNum,lC: integer; + lHisto: HistoRA; + lBlackAUtoBal,lWhiteAutoBal: integer; +begin //dsa + if lHdr.ImgBufferItems = 0 then exit; + CreateHisto (lHdr, lHisto); + lPct := (lHdr.ImgBufferItems *2) div 100; + lNum := 0; + lC := kHistoBins; + repeat + lNum := lNum + lHisto[lC]; + dec(lC); + until (lC = 0) or (lNum >= lPct); + if (lNum >= lPct) and (lC > 0) then + lWHiteAUtoBal:= lC + else begin + lC := kHistoBins; + repeat + lNum := lHisto[lC]; + dec(lC); + until (lC = 0) or (lNum > 0); + if lC = 0 then + lWHiteAUtoBal := kHistoBins + else + lWHiteAUtoBal := lC; + end; + lNum := 0; + lC := 0; + repeat + lNum := lNum + lHisto[lC]; + inc(lC); + until (lC >= kHistoBins) or (lNum >= lPct); + if (lNum >= lPct) and (lC < kHistoBins) and (lC >2) then + lBlackAutoBal := lC + else + lBlackAutoBal := 2; + if (lWHiteAUtoBal-lBlackAutoBal) < (kHistoBins/20) then begin //5% of range.. + lBlackAutoBal := 2; + lWHiteAUtoBal := kHistoBins; + end; + lHdr.AutoBalMaxUnscaled := ((lWhiteAutoBal/kHistoBins)*(lHdr.GlMaxUnscaledS-lHdr.GlMinUnscaledS))+lHdr.GlMinUnscaledS; + lHdr.AutoBalMinUnscaled := ((lBlackAutoBal/kHistoBins)*(lHdr.GlMaxUnscaledS-lHdr.GlMinUnscaledS))+lHdr.GlMinUnscaledS; + //only apply rounding if there is a large difference - e.g. if range is 0..1 then rounding will hurt + if (lHdr.ImgBufferBPP < 4) and ((lHdr.AutoBalMaxUnscaled-lHdr.AutoBalMinUnscaled) > 50) then begin //round integer values + lHdr.AutoBalMinUnscaled := round(lHdr.AutoBalMinUnscaled); + lHdr.AutoBalMaxUnscaled := round(lHdr.AutoBalMaxUnscaled); + end; +end; //proc Balance + +procedure ReturnMinMax (var lHdr: TMRIcroHdr; var lMin,lMax: single; var lFiltMin8bit, lFiltMax8bit: integer); +var + lSwap,lMinS,lMaxS {,lHalfBit}: single; +begin + lFiltMin8bit := 0; + lFiltMax8bit := 255; + lMinS := lHdr.WindowScaledMin; + lMaxS := lHdr.WindowScaledMax; + if lMinS > lMaxS then begin //swap + lSwap := lMinS; + lMinS := lMaxS; + lMaxS := lSwap; + end;//swap + lMin := (Scaled2RawIntensity(lHdr, lMinS)); + lMax := (Scaled2RawIntensity(lHdr, lMaxS)); + //if lMin = lMax then exit; + if (lHdr.LutFromZero) then begin + if (lMinS > 0) and (lMaxS <> 0) then begin + //lMin := Scaled2RawIntensity(lHdr, 0); + lFiltMin8bit := round(lMinS/lMaxS*255); + //lMinS := - lHalfBit;//0; + lHdr.Zero8Bit := 0; + end else if (lMaxS < 0) and (lMinS <> 0) then begin + //lMax := Scaled2RawIntensity(lHdr, -0.000001); + lFiltMax8bit := 255-round(lMaxS/lMinS*255); + //lMaxS := lHalfBit; //0; + //lFiltMax8bit := (Scaled2RawIntensity(lHdr, lHdr.WindowScaledMax)); + end; //> 0 + end; //LUTfrom Zero + lHdr.Zero8Bit := lMinS; + lHdr.Slope8bit := (lMaxS-lMinS)/255; +end; //ReturnMinMax + + +procedure FilterScrnImg (var lHdr: TMRIcroHdr); +var + lInc,lItems,lFiltMin8bit,lFiltMax8bit: integer; + lMinS,lMaxS,lScale: single; +begin + ReturnMinMax(lHdr,lMinS,lMaxS,lFiltMin8bit,lFiltMax8bit); + lItems :=lHdr.ScrnBufferItems; + if lItems < 1 then exit; +if lFiltMax8Bit < 255 then begin + lFiltMin8bit := 255-lFiltMax8bit; + lFiltMax8Bit := 255; +end; + lScale := (lFiltMax8bit-lFiltMin8bit)/255; + if (lFiltMin8bit > 0) or (lFiltMax8bit < 255) then + for lInc := 1 to lItems do + if lHdr.ScrnBuffer^[lInc] <> 0 then + lHdr.ScrnBuffer^[lInc] := lFiltMin8bit+round(lHdr.ScrnBuffer^[lInc]*lScale); +end; //FilterScrnImg + +procedure RescaleImgIntensity8(var lHdr: TMRIcroHdr ); +var lRng: single; + lLUTra: array[0..255] of byte; + lMax,lMin,lSwap,lMod: single; + lFiltMin8bit,lFiltMax8bit,lInc: integer; +begin + if (lHdr.ImgBufferItems < 2) or (lHdr.ImgBufferBPP <> 1) then + exit; + if (lHdr.UsesCustomPaletteRandomRainbow) then begin + createLutLabel (lHdr.LUT, abs(lHdr.WindowScaledMax-lHdr.WindowScaledMin)/100); + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := lHdr.ImgBuffer^[lInc]; + (* l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := ((l16Buf^[lInc]-1) mod 100)+1; + *) + exit; + end; + + ReturnMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + + lRng := (lMax - lMin); + if lRng <> 0 then + lMod := abs({trunc}(((254)/lRng))) + else + lMod := 0; + if lMin > lMax then begin //maw + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + for lInc := 0 to 255 do begin + if lInc < lMin then + lLUTra[lInc] := 0 + else if lInc >= lMax then + lLUTra[lInc] := 255 + else + lLUTra[lInc] := trunc(((lInc-lMin)*lMod)+1); + end; //fill LUT + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 0 to 255 do + lLUTra[lInc] := 255-lLUTra[lInc]; + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := lLUTra[lHdr.ImgBuffer^[lInc]]; +end;//proc RescaleImgIntensity8 + +procedure ReturnMinMaxInt (var lHdr: TMRIcroHdr; var lMin,lMax, lFiltMin8bit, lFiltMax8bit: integer); +var + lMinS,lMaxS: single; +begin + ReturnMinMax (lHdr, lMinS,lMaxS,lFiltMin8bit, lFiltMax8bit); + lMin := round(lMinS); + lMax := round(lMaxS); +end; + +procedure RescaleImgIntensity16(var lHdr: TMRIcroHdr ); +var lRng: single; + lBuff: bytep0; + l16Buf : SmallIntP; + lFiltMin8bit,lFiltMax8bit,lRngi,lMin16Val,lMax,lMin,lSwap,lModShl10,lInc,lInt: integer; +begin + if (lHdr.ImgBufferBPP <> 2) or (lHdr.ImgBufferItems < 2) then exit; + if (lHdr.UsesCustomPaletteRandomRainbow) then begin + createLutLabel (lHdr.LUT, abs(lHdr.WindowScaledMax-lHdr.WindowScaledMin)/100); + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := ((l16Buf^[lInc]-1) mod 100)+1; + exit; + end; + ReturnMinMaxInt (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + lRng := lMax - lMin; + if lRng <> 0 then + lModShl10 := abs( trunc(((254)/lRng)* 1024)) + else + lModShl10 := 0; + if lMin > lMax then begin + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + lMin16Val := trunc(lHdr.GlMinUnscaledS); + lRngi := (1+ trunc(lHdr.GlMaxUnscaledS))-lMin16Val; + getmem(lBuff, lRngi+1); //+1 if the only values are 0,1,2 the range is 2, but there are 3 values! + for lInc := 0 to (lRngi) do begin //build lookup table + lInt := lInc+lMin16Val; + if lInt >= lMax then + lBuff^[lInc] := (255) + else if lInt < lMin then + lBuff^[lInc] := 0 + else + lBuff^[lInc] := (((lInt-lMin)*lModShl10) shr 10)+1 ; + //lBuff[lInc] := (((lInt-lMin)*lModShl10) shr 10) ; + end; //build lookup table + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 0 to lRngi do + lBuff^[lInc] := 255-lBuff^[lInc]; + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lInc := 1 to lHdr.ImgBufferItems do + lHdr.ScrnBuffer^[lInc] := lBuff^[l16Buf^[lInc]-lMin16Val] ; + freemem(lBuff); //release lookup table +end;//proc RescaleImgIntensity16; + +procedure RescaleImgIntensity32(var lHdr: TMRIcroHdr ); +var lRng: double; +lMod,lMax,lMin,lSwap: single {was extended}; + lInc,lItems,lFiltMin8bit,lFiltMax8bit: integer; + l32Buf : SingleP; +begin + lItems := lHdr.ImgBufferItems ; + //fx(lItems,777); + if (lHdr.ImgBufferBPP <> 4) or (lItems< 2) then exit; + l32Buf := SingleP(lHdr.ImgBuffer ); + //fx(lHdr.WindowScaledMin , lHdr.WindowScaledMax); + ReturnMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); //qaz + lRng := (lMax - lMin); + if lRng <> 0 then + lMod := abs(254/lRng) + else begin //June 2007 - binary contrast + for lInc := 1 to lItems do begin + if l32Buf^[lInc] >= lMax then + lHdr.ScrnBuffer^[lInc] := 255 + else //if l32Buf[lInc] < lMin then + lHdr.ScrnBuffer^[lInc] := 0; + end; + exit; + end; + (*if lRng <> 0 then + lMod := abs(254/lRng) + else + lMod := 0;*) + if lMin > lMax then begin + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + lMin := lMin - abs(lRng/255);//lMod; + //showmessage(realtostr(lMin,3)+' '+realtostr(lMax,3)); + begin//not SSE + for lInc := 1 to lItems do begin + if l32Buf^[lInc] > lMax then + lHdr.ScrnBuffer^[lInc] := 255 + else if l32Buf^[lInc] < lMin then + lHdr.ScrnBuffer^[lInc] := 0 //alfa + else begin + lHdr.ScrnBuffer^[lInc] := round ((l32Buf^[lInc]-lMin)*lMod); + end; + end; //for each voxel + end; // SSE-vs-x87 choice + //next - flip intensity range OPTIONAL + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 1 to lItems do + lHdr.ScrnBuffer^[lInc] := 255-lHdr.ScrnBuffer^[lInc]; +end; //RescaleImgIntensity32 + +function MirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfX,lLineOffset: integer; + lTemp32: single; + lTemp16: SmallInt; + lTemp: byte; + l32: SingleP; + l16: SmallIntP; +begin + result := false; + lX := lHdr.NIFTIhdr.Dim[1]; + lY := lHdr.NIFTIhdr.Dim[2]; + lZ := lHdr.NIFTIhdr.Dim[3]; + if lHdr.NIFTIhdr.Dim[4] > 1 then begin + Showmessage('Can not mirror 4D data : '+lHdr.HdrFileName); + exit; + end; + if (lHdr.ImgBufferItems < (lX*lY*lZ)) or (lX < 2) then begin + Showmessage('Unsupported filetype : '+lHdr.HdrFileName); + exit; + end; + lHlfX := lX div 2; + lLineOffset := 0; + //for each datatype... + if lHdr.ImgBufferBPP = 4 then begin + l32 := SingleP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp32 := l32^[lXPos+lLineOffset]; + l32^[lXPos+lLineOffset] := l32^[1+lX-lXPos+lLineOffset]; + l32^[1+lX-lXPos+lLineOffset] := lTemp32; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 2 then begin + l16 := SmallIntP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp16 := l16^[lXPos+lLineOffset]; + l16^[lXPos+lLineOffset] := l16^[1+lX-lXPos+lLineOffset]; + l16^[1+lX-lXPos+lLineOffset] := lTemp16; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 1 then begin + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp := lHdr.ImgBuffer^[lXPos+lLineOffset]; + lHdr.ImgBuffer^[lXPos+lLineOffset] := lHdr.ImgBuffer^[1+lX-lXPos+lLineOffset]; + lHdr.ImgBuffer^[1+lX-lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); + result := true; +end; //proc MirrorImgBuffer + +procedure MirrorScrnBuffer(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr ); +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfX,lLineOffset: integer; + lTemp: byte; +begin + lX := lBackgroundImg.ScrnDim[1]; + lY := lBackgroundImg.ScrnDim[2]; + lZ := lBackgroundImg.ScrnDim[3]; + if (lHdr.ScrnBufferItems < (lX*lY*lZ)) or (lX < 2) then exit; + lHlfX := lX div 2; + lLineOffset := 0; + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp := lHdr.ScrnBuffer^[lXPos+lLineOffset]; + lHdr.ScrnBuffer^[lXPos+lLineOffset] := lHdr.ScrnBuffer^[1+lX-lXPos+lLineOffset]; + lHdr.ScrnBuffer^[1+lX-lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z +end; //proc MirrorImScrnBuffer + +procedure FindMatrixPt (lX,lY,lZ: single; var lXout,lYOut,lZOut: single; var lMatrix: TMatrix); +begin + lXOut := (lX*lMatrix.matrix[1,1])+(lY*lMatrix.matrix[1,2])+(lZ*lMatrix.matrix[1,3])+lMatrix.matrix[1,4]; + lYOut := (lX*lMatrix.matrix[2,1])+(lY*lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[2,3])+lMatrix.matrix[2,4]; + lZOut := (lX*lMatrix.matrix[3,1])+(lY*lMatrix.matrix[3,2])+(lZ*lMatrix.matrix[3,3])+lMatrix.matrix[3,4]; +end; + +procedure CheckMaxMin(var lX,lY,lZ,lXMax,lYMax,lZMax,lXMin,lYMin,lZMin: single); +begin + if lX > lXMax then lXMax := lX; + if lY > lYMax then lYMax := lY; + if lZ > lZMax then lZMax := lZ; + if lX < lXMin then lXMin := lX; + if lY < lYMin then lYMin := lY; + if lZ < lZMin then lZMin := lZ; +end; + +function FindOriMM (lX1,lY1,lZ1,lX2,lY2,lZ2: integer; var lMatrix: TMatrix): single; +var + lXdx,lYdx,lZdx,lXmm1,lYmm1,lZmm1,lXmm2,lYmm2,lZmm2: single; +begin + FindMatrixPt(lX1,lY1,lZ1,lXmm1,lYmm1,lZmm1,lMatrix); + FindMatrixPt(lX2,lY2,lZ2,lXmm2,lYmm2,lZmm2,lMatrix); + lXdx := abs(lXmm1-lXmm2); + lYdx := abs(lYmm1-lYmm2); + lZdx := abs(lZmm1-lZmm2); + if (lXdx > lYdx) and (lXdx > lZdx) then begin //X greatest + result := lXmm1; + end else if (lYdx > lZdx) then begin //Y greatest + result := lYmm1; + end else begin //Z greatest + result := lZmm1; + end; + result := -(result); +end; + +procedure FindMatrixBounds (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; lReslice: boolean); +label 121; +var + lMatrix: TMatrix; + lPos,lPass: integer; + lXc,lYc,lZc,lXmin,lXMax,lYMin,lYMax,lZMin,lZMax,lX,lY,lZ,lmmMin,lDimMMMax: single; +begin + if not lReslice then begin //Dec06 + lBGImg.ScrnDim[1] := lHdr.NIFTIhdr.Dim[1];//+0.5 Dec06 + lBGImg.ScrnDim[2] := lHdr.NIFTIhdr.Dim[2];//+0.5 Dec06 + lBGImg.ScrnDim[3] := lHdr.NIFTIhdr.Dim[3];//+0.5 Dec06 + lBGImg.ScrnMM[1] := lHdr.NIFTIhdr.pixdim[1]; + lBGImg.ScrnMM[2] := lHdr.NIFTIhdr.pixdim[2]; + lBGImg.ScrnMM[3] := lHdr.NIFTIhdr.pixdim[3]; + //Sept07 -estimate origin + lBGImg.ScrnOri[1] := lBGImg.ScrnDim[1] div 2; + lBGImg.ScrnOri[2] := lBGImg.ScrnDim[2] div 2; + lBGImg.ScrnOri[3] := lBGImg.ScrnDim[3] div 2; + if lHdr.NIfTItransform then begin + lBGImg.ScrnOri[1] := 0; + lBGImg.ScrnOri[2] := 0; + lBGImg.ScrnOri[3] := 0; + mm2Voxel (lBGImg.ScrnOri[1],lBGImg.ScrnOri[2],lBGImg.ScrnOri[3], lBGImg.invMat);//vcx +(* lMatrix := lHdr.Mat; + if lBGImg.ScrnMM[1] <> 0 then + lBGImg.ScrnOri[1] := 1+FindOriMM (0,0,0,lBGImg.ScrnDim[1]-1,0,0, lMatrix)/lBGImg.ScrnMM[1]; + if lBGImg.ScrnMM[2] <> 0 then + lBGImg.ScrnOri[2] := 1+FindOriMM (0,0,0,0,lBGImg.ScrnDim[2]-1,0, lMatrix)/lBGImg.ScrnMM[2]; + if lBGImg.ScrnMM[3] <> 0 then + lBGImg.ScrnOri[3] := 1+FindOriMM (0,0,0,0,0,lBGImg.ScrnDim[3]-1, lMatrix)/lBGImg.ScrnMM[3]; + *) + end; + //end estimate origin + //fx(lBGImg.ScrnOri[1],lBGImg.ScrnMM[1],lBGImg.ScrnOri[3],1112); + exit; + end; + lPass := 0; + if (abs(lHdr.Mat.matrix[1,4]) > maxInt) or (abs(lHdr.Mat.matrix[2,4]) > MaxInt) or (abs(lHdr.Mat.matrix[3,4]) > maxint) then begin + showmessage('Error: the origin is not plausible.'); + lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; + + end; +121: + inc(lPass); + lMatrix := lHdr.Mat; + FindMatrixPt(0,0,0,lX,lY,lZ,lMatrix); + lXMax := lX; + lYMax := lY; + lZMax := lZ; + lXMin := lX; + lYMin := lY; + lZMin := lZ; + for lPos := 1 to 7 do begin + if odd(lPos) then + lXc := lHdr.NIFTIhdr.Dim[1]-1 + else + lXc := 0; + if odd(lPos shr 1) then + lYc := lHdr.NIFTIhdr.Dim[2]-1 + else + lYc := 0; + if odd(lPos shr 2) then + lZc := lHdr.NIFTIhdr.Dim[3]-1 + else + lZc := 0; + //showmessage(floattostr(lXc)+' '+floattostr(lYc)+' '+floattostr(lZc) ); + FindMatrixPt(lXc,lYc,lZc,lX,lY,lZ,lMatrix); + CheckMaxMin(lX,lY,lZ,lXMax,lYMax,lZMax,lXMin,lYMin,lZMin); + end; + //fx(lXMax,lXMin,lZMax,lZMin); + //next find min MM + //fx(lZMin,lZMax); + lmmMin := abs(lHdr.NIFTIhdr.pixdim[1]); + if abs(lHdr.NIFTIhdr.pixdim[2]) < lmmMin then lmmMin := abs(lHdr.NIFTIhdr.pixdim[2]); + if abs(lHdr.NIFTIhdr.pixdim[3]) < lmmMin then lmmMin := abs(lHdr.NIFTIhdr.pixdim[3]); + if lmmMin = 0 then lmmMin := 1; + //next find max Dim + lDimMMMax := abs(lXMax-lXMin); + if abs(lYMax-lYMin) > lDimMMMax then lDimMMMax := abs(lYMax-lYMin); + if abs(lZMax-lZMin) > lDimMMMax then lDimMMMax := abs(lZMax-lZMin); + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scalled by smallest mm, try largest mm + lmmMin := lHdr.NIFTIhdr.pixdim[1]; + if lHdr.NIFTIhdr.pixdim[2] > lmmMin then lmmMin := lHdr.NIFTIhdr.pixdim[2]; + if lHdr.NIFTIhdr.pixdim[3] > lmmMin then lmmMin := lHdr.NIFTIhdr.pixdim[3]; + if lmmMin = 0 then lmmMin := 1; + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scalled by largest mm, try isotropic 1mm + lmmMin := 1; + end; + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scaled by 1mm, find optimal scaling factor + lmmMin := lDimMMMax/gBGImg.MaxDim; + Showmessage('Maximum dimension is >'+inttostr(gBGImg.MaxDim)+' voxels. Therefore the image will resolution will be reduced. If you have a fast computer, you may consider increasing the ''MaxDim'' value saved in the mricron.ini file.'); + //showmessage('Warning: having to downsample this large image - you may wish to view this image with MRIcro.'); + end; + //showmessage( floattostr(lmmMin)); + //lmmMin := 3.5;// + end; + lBGImg.ScrnDim[1] := 1+trunc(0.5+((lXMax-lXMin)/lmmMin));//+0.5 May06 + lBGImg.ScrnDim[2] := 1+trunc(0.5+((lYMax-lYMin)/lmmMin));//+0.5 May06 + lBGImg.ScrnDim[3] := 1+trunc(0.5+((lZMax-lZMin)/lmmMin));//+0.5 May06 + //fx(lBGImg.ScrnDim[3],lmmMin); + lBGImg.ScrnMM[1] := lmmMin; + lBGImg.ScrnMM[2] := lmmMin; + lBGImg.ScrnMM[3] := lmmMin; + //fx(lBGImg.ScrnDim[1],lBGImg.ScrnDim[2],lBGImg.ScrnDim[3]); + //showmessage(floattostr(lZMin)+'...'+floattostr(lZMax)+' '+floattostr((lZMin)/lmmMin)); + lBGImg.ScrnOri[1] := -(((lXMin)/lmmMin))+1; + lBGImg.ScrnOri[2] := -(((lYMin)/lmmMin))+1; + lBGImg.ScrnOri[3] := -(((lZMin)/lmmMin))+1; + + //fx(lBGImg.ScrnOri[1],lBGImg.ScrnOri[2],lBGImg.ScrnOri[3]); + if (lXMin > 0) and (lYMin > 0) and (lZMin > 0) and (lPass <= 2) then begin + lHdr.Mat.matrix[1,4] := -lHdr.Mat.matrix[1,4]; + lHdr.Mat.matrix[2,4] := -lHdr.Mat.matrix[2,4]; + lHdr.Mat.matrix[3,4] := -lHdr.Mat.matrix[3,4]; + {lHdr.NIFTIhdr.srow_x[3] := -lHdr.NIFTIhdr.srow_x[3]; + lHdr.NIFTIhdr.srow_y[3] := -lHdr.NIFTIhdr.srow_y[3]; + lHdr.NIFTIhdr.srow_z[3] := -lHdr.NIFTIhdr.srow_z[3];} + {lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; } + if lPass = 1 then begin + Showmessage('The origin is not in the image... check your transformation matrix - will attempt to invert offsets'); + goto 121; + end else if lPass = 2 then begin + lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; + Showmessage('The origin is not in the image... check your transformation matrix - will attempt to zero offsets'); + goto 121; + end else + showmessage('The origin is not in the image... unable to correct.'); + end; +end; + + +function mat44_inverse(var R: Tmatrix ) : TMatrix; +var + r11,r12,r13,r21,r22,r23,r31,r32,r33,v1,v2,v3 , deti : double; + Q: TMatrix; +begin + r11 := R.matrix[1,1]; r12 := R.matrix[1,2]; r13 := R.matrix[1,3]; //* [ r11 r12 r13 v1 ] */ + r21 := R.matrix[2,1]; r22 := R.matrix[2,2]; r23 := R.matrix[2,3]; //* [ r21 r22 r23 v2 ] */ + r31 := R.matrix[3,1]; r32 := R.matrix[3,2]; r33 := R.matrix[3,3]; //* [ r31 r32 r33 v3 ] */ + v1 := R.matrix[1,4]; v2 := R.matrix[2,4]; v3 := R.matrix[3,4]; //* [ 0 0 0 1 ] */ + + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + + if( deti <> 0.0 ) then + deti := 1.0 / deti ; + + Q.matrix[1,1] := deti*( r22*r33-r32*r23) ; + Q.matrix[1,2] := deti*(-r12*r33+r32*r13) ; + Q.matrix[1,3] := deti*( r12*r23-r22*r13) ; + Q.matrix[1,4] := deti*(-r12*r23*v3+r12*v2*r33+r22*r13*v3 + -r22*v1*r33-r32*r13*v2+r32*v1*r23) ; + + Q.matrix[2,1] := deti*(-r21*r33+r31*r23) ; + Q.matrix[2,2] := deti*( r11*r33-r31*r13) ; + Q.matrix[2,3] := deti*(-r11*r23+r21*r13) ; + Q.matrix[2,4] := deti*( r11*r23*v3-r11*v2*r33-r21*r13*v3 + +r21*v1*r33+r31*r13*v2-r31*v1*r23) ; + + Q.matrix[3,1] := deti*( r21*r32-r31*r22) ; + Q.matrix[3,2] := deti*(-r11*r32+r31*r12) ; + Q.matrix[3,3] := deti*( r11*r22-r21*r12) ; + Q.matrix[3,4] := deti*(-r11*r22*v3+r11*r32*v2+r21*r12*v3 + -r21*r32*v1-r31*r12*v2+r31*r22*v1) ; + + Q.matrix[4,1] := 0; Q.matrix[4,2] := 0; Q.matrix[4,3] := 0.0 ; + Q.matrix[4,4] := 1;// (deti == 0.0l) ? 0.0l : 1.0l ; /* failure flag if deti == 0 */ + + result := Q ; +end; + +function TestSameOrtho(var lHdr: TMRIcroHdr): boolean; +var + lRow,lCol: integer; +begin + result := false; + for lRow := 1 to 3 do + for lCol := 1 to 3 do + if (lRow=lCol) then begin + if lHdr.Mat.Matrix[lRow,lCol] <= 0 then + exit; + end else + if lHdr.Mat.Matrix[lRow,lCol] <> 0 then + exit; + result := true; +end; + +function OrthoReslice (var lBGImg: TBGImg; var lHdr: TMRIcroHdr): boolean; +label + 666; +Type + TXImg = record //Next: analyze Format Header structure + rDim: array [1..3] of integer; + rOri,rMM: array [1..3] of single; + rSliceSz: integer; + end; //TNIFTIhdr Header Structure +var + //lStartTime,lEndTime: DWord; + lIn,lOut: TXImg; + lBuffIn,lBuffOut,lBuffOutUnaligned: Bytep; + lBuffIn16,lBuffOut16 : SmallIntP; + lBuffIn32,lBuffOut32 : SingleP; + lX,lY,lZ,lI,lPos,lOutVolItems,lInZPos,lInYPos,lOutZPos,lOutYPos,lInZPosHi,lInYPosHi: integer; + lXmodLo,lXmodHi,lYmodLo,lYmodHi,lZmodLo,lZmodHi: single; + lScale,lFloatPos: single; + lMin,lMax: array [1..3] of integer; + lLUTra: array [1..3] of LongIntp; + lLUTmodRA: array [1..3] of Singlep; +begin + result := false; + // if lHdr.ImgBufferBPP = 4 then exit; + if not TestSameOrtho(lHdr) then exit; + //if lHdr.ImgBufferBPP <> 1 then exit; + //lStartTime := GetTickCount; + for lI := 1 to 3 do begin + lIn.rDim[lI] := lHdr.NIFTIhdr.dim[lI]; + lIn.rMM[lI] := lHdr.NIFTIhdr.pixdim[lI]; + lIn.rOri[lI] := (abs(lHdr.Mat.Matrix[lI,4]))/abs(lHdr.NIFTIhdr.pixdim[lI])+1;//May07 + end; + lIn.rSliceSz := lIn.rDim[1]*lIn.rDim[2]; + //Output to background size + for lI := 1 to 3 do begin + lOut.rDim[lI] := lBGImg.ScrnDim[lI]; + lOut.rMM[lI] := lBGImg.ScrnMM[lI]; + lOut.rOri[lI] := lBGImg.ScrnOri[lI]; +// fx(lOut.rDim[lI],lOut.rMM[lI],lOut.rOri[lI]); + end; + lOut.rSliceSz := lOut.rDim[1]*lOut.rDim[2]; + lOutVolItems := lOut.rSliceSz * lOut.rDim[3]; //InVolSz! + //find bounding box for overlay, and create lookup tables + for lI := 1 to 3 do begin + lScale := lOut.rMM[lI] / lIn.rMM[lI]; + getmem(lLUTra[lI],lOut.rDim[lI]*4); + getmem(lLUTmodra[lI],lOut.rDim[lI]*4); + lMin[lI] := maxint; + lMax[lI] := -1; + for lPos := 1 to lOut.rDim[lI] do begin + if lBGImg.OverlaySmooth then begin + lFloatPos := ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] {-0.5}; + lLUTra[lI]^[lPos] := trunc ( lFloatPos ); + lLUTmodra[lI]^[lPos] := ( frac (lFloatPos )); + end else begin + lLUTra[lI]^[lPos] := round ( ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] ); + lLUTmodra[lI]^[lPos] :=0;//not used + end; + if (lLUTra[lI]^[lPos] > 0) and (lMin[lI]=MaxInt) then + lMin[lI] := lPos; + if (lLUTra[lI]^[lPos] < lIn.rDim[lI]) {danger! <=} then + lMax[lI] := lPos; + end; + end; + //for lI := 1 to 3 do fx( lOut.rMM[lI],lIn.rMM[lI]); + for lI := 1 to 3 do + if lMin[lI] > lMax[lI] then begin + showmessage ('Unusual rotation matrix - consider viewing with MRIcro.');//goto 345; //do after previous loop so we are sure all buffers used + goto 666; + end; + lMax[1] := lMax[1] -1;{-1 as we do not want to sample past edge} + ImgForm.ProgressBar1.Min := lMin[3]; + ImgForm.ProgressBar1.Max := lMax[3]; + //next - core + + if lHdr.ImgBufferBPP = 4 then begin //next- 32 bit + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + //svn lBuffOut32 := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + lBuffOut32 := Align(lBuffOutUnaligned, 16); + for lX := 1 to lOutVolItems do + lBuffOut32^[lX] := 0; //set all to zero + //fx(lOutVolItems,lHdr.ImgBufferItems); + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3]^[lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3]^[lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2]^[lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2]^[lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1]^[lX]; + lXModLo := 1 - lXmodHi; + lBuffOut32^[lOutZPos+lOutYPos+lX] := ( + lBuffIn32^[lInZPos+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn32^[lInZPos+lInYPos+lLUTra[1]^[lX]+1]*lXModHi*lYModLo*lZModLo + + lBuffIn32^[lInZPos+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn32^[lInZPos+lInYPosHi+lLUTra[1]^[lX]+1]*lXModHi*lYModHi*lZModLo + + lBuffIn32^[lInZPosHi+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn32^[lInZPosHi+lInYPos+lLUTra[1]^[lX]+1]*lXModHi*lYModLo*lZModHi + + lBuffIn32^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn32^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX]+1]*lXModHi*lYModHi*lZModHi) ; + end; //for X + end; //for Y + end; //for Z + + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + //svn lHdr.ImgBuffer := ByteP ($fffffff0 and (integer(lHdr.ImgBufferUnaligned )+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut32^,lHdr.ImgBuffer^,lOutVolItems*sizeof(Single));//source/dest + //678 winOnly-> CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut32),(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin //next- 16 bit + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + //svn lBuffOut16 := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + lBuffOut16 := align(lBuffOutUnaligned, 16); + for lX := 1 to lOutVolItems do + lBuffOut16^[lX] := 0; //set all to zero + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3]^[lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3]^[lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2]^[lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2]^[lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1]^[lX]; + lXModLo := 1 - lXmodHi; + lBuffOut16^[lOutZPos+lOutYPos+lX] := round( + lBuffIn16^[lInZPos+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn16^[lInZPos+lInYPos+lLUTra[1]^[lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn16^[lInZPos+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn16^[lInZPos+lInYPosHi+lLUTra[1]^[lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn16^[lInZPosHi+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn16^[lInZPosHi+lInYPos+lLUTra[1]^[lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn16^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn16^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX+1]]*lXModHi*lYModHi*lZModHi) ; + end; //for X + end; //for Y + end; //for Z + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + //lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); + lHdr.ImgBufferItems := lOutVolItems; + Move((lBuffOut16^),(lHdr.ImgBuffer^),lOutVolItems*sizeof(SmallInt));//source/dest + //678 winOnly-> CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut16),(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin //next- 8 bit + lBuffIn := lHdr.ImgBuffer; + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + //for lI := 1 to lOutVolItems do lBuffOut[lI] := 0; //set all to zero + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3]^[lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3]^[lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2]^[lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2]^[lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1]^[lX]; + lXModLo := 1 - lXmodHi; + lBuffOut^[lOutZPos+lOutYPos+lX] := round( + lBuffIn^[lInZPos+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn^[lInZPos+lInYPos+lLUTra[1]^[lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn^[lInZPos+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn^[lInZPos+lInYPosHi+lLUTra[1]^[lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn^[lInZPosHi+lInYPos+lLUTra[1]^[lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn^[lInZPosHi+lInYPos+lLUTra[1]^[lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn^[lInZPosHi+lInYPosHi+lLUTra[1]^[lX+1]]*lXModHi*lYModHi*lZModHi); + end; //for X + end; //for Y + end; //for Z + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + //svn lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut^,lHdr.ImgBuffer^,lOutVolItems);//source/dest + //678winonly-> CopyMemory((lHdr.ImgBuffer),(lBuffOut),lOutVolItems); + FreeMem(lBuffOut); + end else + Showmessage('Unsupported BPP '+inttostr(lHdr.ImgBufferBPP)); + ImgForm.ProgressBar1.Position := lMin[3]; + result := true; + +666: + for lI := 1 to 3 do begin + freemem(lLUTra[lI]); + freemem(lLUTmodra[lI]); + end; + //Output dimensions: size of background image + //lEndTime := GetTickCount; + //ImgForm.Label1.caption :=('update(ms): '+inttostr(lEndTime-lStartTime)); +end; //procedure OrthogonalResliceImg + +procedure fSwap(var lX,lY: single); +var + lSwap: single; +begin + lSwap := lX; + lX := lY; + lY := lSwap; +end; + +procedure ResliceScrnImg (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; lTrilinearSmooth: boolean); var + lOverlap: boolean; + lMinY,lMinZ,lMaxY,lMaxZ: integer; //<- used by trilinear + lXreal,lYreal,lZreal,lXrM1,lYrM1,lZrM1, //<- used by trilinear + lZr,lYr,lXr,lZx,lZy,lZz,lYx,lYy,lYz: single;//lSwap + lZ,lY,lX,lOutVolItems,lInVolItems, + lXdimIn,lYDimIn,lZDimIn,lInSliceSz, + lOutPos,lOutDimX,lOutDimY,lOutDimZ,lXo,lYo,lZo: integer;//lSrcPos + lXxp,lXyp,lXzp: Pointer; + lXxra,lXyra,lXzra : SingleP; + lMatrix,lMatrixBG: TMatrix; + lBuffIn,lBuffOut,lBuffOutUnaligned: Bytep; + lBuffIn16,lBuffOut16 : SmallIntP;//16bit + lBuffIn32,lBuffOut32: SingleP; + begin + if SameAsBG(lBGImg,lHdr) then exit; + if not lBGImg.Resliced then begin //2008 + Reslice_Img_To_Unaligned (gMRIcroOverlay[kBGOverlayNum].NIftiHdr, lHdr, lBGImg.OverlaySmooth); + exit; + end; + //if lTrilinearSmooth then showmessage('ts') else showmessage('nn'); + if OrthoReslice(lBGImg,lHdr) then exit; + lOverlap := false; + lMatrix := lHdr.Mat; + lMatrix := mat44_inverse(lMatrix); + lMatrixBG := Matrix3D ( lBGImg.Scrnmm[1],0,0,0, + 0,lBGImg.Scrnmm[2],0,0, + 0,0,lBGImg.Scrnmm[3],0, + 0,0,0,1); + lMatrix.size := size3D; + lMatrix := MultiplyMatrices(lMatrix,lMatrixBG); + lXdimIn := lHdr.NiftiHdr.dim[1]; + lYdimIn := lHdr.NiftiHdr.dim[2]; + lZDimIn := lHdr.NiftiHdr.dim[3]; + lInSliceSz := lHdr.NiftiHdr.dim[1]*lHdr.NiftiHdr.dim[2]; + lInVolItems := lInSliceSz*lHdr.NiftiHdr.dim[3]; + if (lHdr.ImgBufferItems < lInVolItems) then + exit; + lBuffIn := lHdr.ImgBuffer; + lOutDimX := lBGImg.ScrnDim[1]; + lOutDimY := lBGImg.ScrnDim[2]; + lOutDimZ := lBGImg.ScrnDim[3]; + //lOutSliceSz := lOutDimX*lOutDimY; + lOutVolItems := lBGImg.ScrnDim[1]*lBGImg.ScrnDim[2]*lBGImg.ScrnDim[3]; + lOutPos := 0; + //start look up table... + GetMem(lXxp, (sizeof(single)* lOutDimX)+16); + GetMem(lXyp, (sizeof(single)* lOutDimX)+16); + GetMem(lXzp, (sizeof(single)* lOutDimX)+16); + lXxRA := align(lXxp, 16); //SingleP($fffffff0 and (integer(lXxP)+15)); //data aligned to quad-word boundary + lXyRA := align(lXyp, 16);//SingleP($fffffff0 and (integer(lXyP)+15)); //quad-word boundary + lXzRA := align(lXzp, 16);//SingleP($fffffff0 and (integer(lXzP)+15)); //quad-word boundary + + for lX := 1 to lOutDimX do begin + lXr := lX-(lBGImg.ScrnOri[1]);//* lBGImg.ScrnMM[1]) ; + //lXr := lX; + lXxRA^[lX] := lXr*lMatrix.matrix[1,1]+1; + lXyRA^[lX] := lXr*lMatrix.matrix[2,1]+1; + lXzRA^[lX] := lXr*lMatrix.matrix[3,1]+1; + end; + + //end look up table +if lTrilinearSmooth then begin //smooth data + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + lBuffOut32 := align(lBuffOutUnaligned, 16); //SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut32^[lX] := 0; //set all to zero + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA^[lX]+lYx+lZx; + lYreal := lXyRA^[lX]+lYy+lZy; + lZreal := lXzRA^[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lMaxY := ((lYo)*lXdimIn); + lMaxZ := ((lZo)*lInSliceSz); + lOverlap := true; + lBuffOut32^[lOutPos] := ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn32^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn32^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn32^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn32^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn32^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn32^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn32^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn32^[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 32 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16);//ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut32^,lHdr.ImgBuffer^,lOutVolItems*sizeof(Single));//source/dest + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + lBuffOut16 := align(lBuffOutUnaligned, 16); //SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut16^[lX] := 0; //set all to zero + //core 16 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA^[lX]+lYx+lZx; + lYreal := lXyRA^[lX]+lYy+lZy; + lZreal := lXzRA^[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lXrM1 := 1-lXreal; + lYreal := lYreal-lYo; + lYrM1 := 1-lYreal; + lZreal := lZreal-lZo; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMaxY := lMinY+lXdimIn; + lMinZ := ((lZo-1)*lInSliceSz); + lMaxZ := lMinZ+lInSliceSz; + lOverlap := true; + lBuffOut16^[lOutPos] := round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn16^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn16^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn16^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn16^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn16^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn16^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn16^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn16^[lXo+1+lMaxY+lMaxZ]) ); (**) + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 16 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); //ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut16^,lHdr.ImgBuffer^,lOutVolItems*sizeof(SmallInt));//source/dest + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA^[lX]+lYx+lZx; + lYreal := lXyRA^[lX]+lYy+lZy; + lZreal := lXzRA^[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lMaxY := ((lYo)*lXdimIn); + lMaxZ := ((lZo)*lInSliceSz); + lOverlap := true; + lBuffOut^[lOutPos] := round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn^[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); //ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut^,lHdr.ImgBuffer^,lOutVolItems);//source/dest + FreeMem(lBuffOut); + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); +end else begin //not trilinear - use nearest neighbor + //start nearest neighbor + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + lBuffOut32 := align(lBuffOutUnaligned, 16);//SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut32^[lX] := 0; //set all to zero + //core 32 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA^[lX]+lYx+lZx); + lYo := round(lXyRA^[lX]+lYy+lZy); + lZo := round(lXzRA^[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lOverlap := true; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lBuffOut32^[lOutPos] := lBuffIn32^[lXo+lMinY+lMinZ]; + end; + end; //for X + end; //for OutY + end; //for OutZ + //core 32 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16);//ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut32^,lHdr.ImgBuffer^,lOutVolItems*sizeof(Single));//source/dest + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + lBuffOut16 := align(lBuffOutUnaligned, 16);//SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut16^[lX] := 0; //set all to zero + //core 16 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA^[lX]+lYx+lZx); + lYo := round(lXyRA^[lX]+lYy+lZy); + lZo := round(lXzRA^[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lOverlap := true; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lBuffOut16^[lOutPos] := lBuffIn16^[lXo+lMinY+lMinZ]//lBuffIn16[lXo+lYo+lZo]; xxxx + + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 16 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16);// ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut16^,lHdr.ImgBuffer^,lOutVolItems*sizeof(SmallInt));//source/dest + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA^[lX]+lYx+lZx); + lYo := round(lXyRA^[lX]+lYy+lZy); + lZo := round(lXzRA^[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lOverlap := true; + lBuffOut^[lOutPos] := lBuffIn^[lXo+lMinY+lMinZ]; + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16);//ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + Move(lBuffOut^,lHdr.ImgBuffer^,lOutVolItems);//source/dest + FreeMem(lBuffOut); + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); //end nearest neighbor +end; //end if trilinear else nearest neighbor +if not lOverlap then + showmessage('No overlap between image and background bounding box - check the transfomation matrices.'); + FreeMem(lXxp); + FreeMem(lXyp); + FreeMem(lXzp); +end; //ResliceScrnImg + + +procedure InvertScrnBuffer(var lHdr: TMRIcroHdr); +var lPos: integer; +begin + if lHdr.ScrnBufferItems < 1 then exit; + lHdr.Zero8Bit := lHdr.Zero8Bit+(255*lHdr.Slope8bit); + lHdr.Slope8bit := -lHdr.Slope8bit; + for lPos := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lPos] := 255- lHdr.ScrnBuffer^[lPos]; + {lMin := 255; + for lPos := 1 to lHdr.ScrnBufferItems do + if lMin > lHdr.ScrnBuffer[lPos] then lMin := lHdr.ScrnBuffer[lPos]; + } + //showmessage('inv'+inttostr(lMin)); +end; + +const + kMin8bit = 1; + +procedure RescaleImgIntensity(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lLayer: integer ); +var + lImgSamples: integer; + //lFiltMin8bit,lFiltMax8bit: integer; + //lMin,lMax: single; +begin + lImgSamples := round(ComputeImageDataBytes8bpp(lHdr)); + if (lHdr.ImgBufferItems = 0) and (lHdr.ScrnBufferItems > 0) then begin //image buffer loaded - not VOIs have screen but not img buffers + if lBackgroundImg.VOImirrored then + MirrorScrnBuffer(lBackgroundImg,lHdr); + lBackgroundImg.VOImirrored := false; + exit; + end; + if lHdr.ImgBufferItems<>lHdr.ScrnBufferItems then begin + if lHdr.ScrnBufferItems > 0 then + freemem(lHdr.ScrnBuffer); + lHdr.ScrnBufferItems := lHdr.ImgBufferItems; + GetMem(lHdr.ScrnBuffer ,lHdr.ScrnBufferItems); + end; + if lHdr.ImgBufferItems = 0 then + exit; //2/2010 + if (lHdr.UsesCustomPalette) and (not lHdr.UsesCustomPaletteRandomRainbow) then begin //2014 + lHdr.WindowScaledMin := kMin8bit; + lHdr.WindowScaledMax := 255; + end; + + if lImgSamples < 1 then + exit; + if (lHdr.ImgBufferBPP = 4) then + RescaleImgIntensity32(lHdr) + else if (lHdr.ImgBufferBPP = 2) then + RescaleImgIntensity16(LHdr) + else if lHdr.ImgBufferBPP = 1 then + RescaleImgIntensity8(lHdr) + else begin + showmessage(inttostr(lHdr.ImgBufferItems)+'Unknown Image Buffer Bytes Per Pixel: '+inttostr(lHdr.ImgBufferBPP)+' : '+lHdr.HdrFileName); + exit; + end; + + //if not lHdr.SameDimsAsBG then OrthogonalResliceScrnImg (lBackgroundImg, lHdr); + //ReturnRawMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + if (lLayer <> kBGOverlayNum) and ((lHdr.WindowScaledMin <= 0) and (lHdr.WindowScaledMax <= 0)) then + InvertScrnBuffer(lHdr); + FilterScrnImg (lHdr);//,lFiltMin8bit,lFiltMax8bit); + + if lBackgroundImg.Mirror then + MirrorScrnBuffer(lBackgroundImg,lHdr); +end; //RescaleImgIntensity32 + +function PtoLog10 ( lIn: double): double; //in= pvalue <=1 +begin + //result := -log(abs(lIn),10) + result := -log((lIn),10) +end; + +function Log10toP (lIn: double): double; +begin + //result := log((lIn),10) + result := 1/power(10,lIn); //requires Math unit +end; + +procedure ComputeFDR (var lInHdr: TMRIcroHdr; var lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01: single); +//(lImg2Load.NIFTIhdr.intent_code,round(lImg2Load.NIFTIhdr.intent_p1),lImg2Load.ImgBufferItems,lImg2Load.ImgBufferBPP,lImg2Load.ImgBuffer,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); +//procedure ComputeFDR(lStatIntent,lDF,lImgSamples,lImgBPP: integer; l32Buf:SingleP; var lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01: single); +//StatIntents in kNIFTI_INTENT_CHISQ, kNIFTI_INTENT_ZSCORE,kNIFTI_INTENT_TTEST +//Note DF meaningless for ZScore +label 555; +var + lPs: SingleP; //array of tests + lStr: string; + lStatIntent,lImgSamples,lnTests,lInc,lDF: integer; + lPrevP,lP,lFDR05p, lFDR01p,lnegFDR05p, lnegFDR01p,lnegFDR05, lnegFDR01 : double; + l32Buf : SingleP; +begin + + lStatIntent := lInHdr.NIFTIhdr.intent_code; + lDF := round(lInHdr.NIFTIhdr.intent_p1); + if ((lStatIntent = kNIFTI_INTENT_CHISQ) or (lStatIntent = kNIFTI_INTENT_TTEST)) and (lDF <= 1) then //May07 + lDF := ReadIntForm.GetInt('Please specify degrees of freedom for '+extractfilename(lInHdr.HdrFileName),1,16,32000); + lImgSamples := lInHdr.ImgBufferItems; + if (lImgSamples < 1) then exit; + ImgForm.StatusLabel.Caption := 'Computing FDR rates...'; + ImgForm.refresh; + //next: count number of tests [we could just rely on value lChiSamples to us, but perhaps value in intention is not correct + lnTests := 0; + + l32Buf := SingleP(lInHdr.ImgBuffer ); + for lInc := 1 to lImgSamples do + if l32Buf^[lInc] <> 0 then + inc(lnTests); + + if lnTests < 1 then exit; + GetMem(lPs,lnTests*sizeof(single)); + //for lInc := 1 to lnTests do lPs[lInc] := 1; + //next - place Pvalues in array, as computing P is slow, we remember last Pvalue + lPrevP := 0; + lnTests := 0; + lP := 1; //never used + //lStartTime := GetTickCount; + for lInc := 1 to lImgSamples do + if l32Buf^[lInc] <> 0 then begin + inc(lnTests); + if l32Buf^[lInc] <> lPrevP then + case lStatIntent of + kNIFTI_INTENT_TTEST: lP := pTdistr(lDF,l32Buf^[lInc]);//slow!! 110ms + kNIFTI_INTENT_ZSCORE: lP := pNormal(l32Buf^[lInc]);//slow!! 94ms + kNIFTI_INTENT_PVAL: lP := l32Buf^[lInc]; + NIFTI_INTENT_LOG10PVAL: lP := Log10toP(l32Buf^[lInc]); + else {kNIFTI_INTENT_CHISQ:}begin + if l32Buf^[lInc] < 0 then //MRIcro saves negative Chi + lP := 0.6 + else + lP := pChi2(lDF,l32Buf^[lInc]);//slow! 47ms + end; + end; + lPs^[lnTests] := lP; + lPrevP := l32Buf^[lInc]; + end; //Chi <> 0 + //ImgForm.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); + + + //EstimateFDR(lnTests, lPs, lFDR05p, lFDR01p); + EstimateFDR2(lnTests, lPs, lFDR05p, lFDR01p,lnegFDR05p, lnegFDR01p); + //lStartTime := GetTickCount; + //next histogram! + (*for lInc := 1 to lnTests do + lPs^[lInc] := pNormalInvQuickApprox(lPs^[lInc]); //slow!!!!!!!!! >5100ms + lHdr.ImgBufferBPP := 4; + lHdr.ImgBufferItems :=lnTests; + lHdr.GlMaxUnscaledS :=lPs^[1]; + lHdr.GlMinUnscaledS := lPs^[lnTests]; + lHdr.ImgBuffer :=bytep(lPs); + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; + lInc := 0;//B&W + LoadMonochromeLUT(lInc,gBGImg,lHdr); + DrawHistogram(lHdr,HistogramForm.HistoImage); + HistogramForm.Caption := 'Z Histogram'+realtostr(lHdr.GlMinUnscaledS,6)+'..'+realtostr(lHdr.GlMaxUnscaledS,6); + HistogramForm.show; + ImgForm.PGImageCor.refresh; + //ImgForm.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); + //showmessage('Z Histogram'+realtostr(lHdr.GlMinUnscaledS,6)+'..'+realtostr(lHdr.GlMaxUnscaledS,6)); + //end histogram *) +555: + + FreeMem(lPs); + case lStatIntent of + kNIFTI_INTENT_CHISQ:begin + lP05:= pChi2Inv(lDF,0.05); + lP01 := pChi2Inv(lDF,0.01); + lFWE05 := pChi2Inv(lDF,0.05/lnTests); + lFWE01 := pChi2Inv(lDF,0.01/lnTests); + lFDR05 := pChi2Inv(lDF,lFDR05p); + lFDR01 := pChi2Inv(lDF,lFDR01p); + lnegFDR05 := pChi2Inv(lDF,lnegFDR05p); + lnegFDR01 := pChi2Inv(lDF,lnegFDR01p); + lStr := 'X DF='+inttostr(lDF); + end; + kNIFTI_INTENT_ZSCORE: begin + lP05:= pNormalInv(0.05); + lP01 := pNormalInv(0.01); + lFWE05 := pNormalInv(0.05/lnTests); + lFWE01 := pNormalInv(0.01/lnTests); + lFDR05 := pNormalInv(lFDR05p); + lFDR01 := pNormalInv(lFDR01p); + lnegFDR05 := pNormalInv(lnegFDR05p); + lnegFDR01 := pNormalInv(lnegFDR01p); + lStr := 'Z'; + end; + kNIFTI_INTENT_TTEST: begin + lP05:= pTdistrInv(lDF,0.05); + lP01 := pTdistrInv(lDF,0.01); + lFWE05 := pTdistrInv(lDF,0.05/lnTests); + lFWE01 := pTdistrInv(lDF,0.01/lnTests); + lFDR05 := pTdistrInv(lDF,lFDR05p); + lFDR01 := pTdistrInv(lDF,lFDR01p); + lnegFDR05 := pTdistrInv(lDF,lnegFDR05p); + lnegFDR01 := pTdistrInv(lDF,lnegFDR01p); + lStr := 't DF='+inttostr(lDF); + + end; + kNIFTI_INTENT_PVAL:begin + lP05:= (0.05); + lP01 := (0.01); + lFWE05 := (0.05/lnTests); + lFWE01 := (0.01/lnTests); + lFDR05 := (lFDR05p); + lFDR01 := (lFDR01p); + lnegFDR05 := (lnegFDR05p); + lnegFDR01 := (lnegFDR01p); + lStr := 'p'; + end; + NIFTI_INTENT_LOG10PVAL: begin + lP05:= PtoLog10(0.05); + lP01 := PtoLog10(0.01); + lFWE05 := PtoLog10(0.05/lnTests); + lFWE01 := PtoLog10(0.01/lnTests); + lFDR05 := PtoLog10(lFDR05p); + lFDR01 := PtoLog10(lFDR01p); + lnegFDR05 := PtoLog10(lnegFDR05p); + lnegFDR01 := PtoLog10(lnegFDR01p); + + lStr := 'log10p'; + end; + else + Showmessage('Error: unknown stats intent'); + end; //case + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lFDR05 < lFWE05) then + lFDR05 := lFWE05; + end else if (lFDR05 > lFWE05) then + lFDR05 := lFWE05; + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lFDR01 < lFWE01) then + lFDR01 := lFWE01; + end else if (lFDR01 > lFWE01) then + lFDR01 := lFWE01; + + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lnegFDR05 > -lFWE05) then + lnegFDR05 := -lFWE05; + if (lnegFDR01 > -lFWE01) then + lnegFDR01 := -lFWE01; + end else begin + if (lnegFDR05 < -lFWE05) then + lnegFDR05 := -lFWE05; + if (lnegFDR01 < -lFWE01) then + lnegFDR01 := -lFWE01; + end; + ImgForm.StatusLabel.Caption := lStr+' Tests='+inttostr(lnTests)+' p05='+realtostr(lP05,4)+ ' p01='+realtostr(lP01,4)+' fwe05='+realtostr(lFWE05,4)+ ' fwe01='+realtostr(lFWE01,4) + +' fdr05='+realtostr(lFDR05,4)+' fdr01='+realtostr(lFDR01,4) + +' -fdr05='+realtostr(lnegFDR05,4)+' -fdr01='+realtostr(lnegFDR01,4) ; +end; + +function MakeSameOrtho(var lBGImg: TBGImg; var lHdr: TMRIcroHdr):boolean; +//this function disables reslicing - images will be shown unrotated and unscaled... +var + lRow: integer; +begin + result := false; + for lRow := 1 to 3 do begin + //lHdr.NIFTIhdr.pixdim[lRow] := 1; //Apr07 + if lHdr.NIFTIhdr.dim[lRow] <>lBGImg.ScrnDim[lRow] then + exit; + end; + lHdr.Mat:= Matrix3D ( lBGImg.Scrnmm[1],0,0,-lBGImg.Scrnmm[1]*(lBGImg.ScrnOri[1]-1), + 0,lBGImg.Scrnmm[2],0,-lBGImg.Scrnmm[2]*(lBGImg.ScrnOri[2]-1), + 0,0,lBGImg.Scrnmm[3],-lBGImg.Scrnmm[3]*(lBGImg.ScrnOri[3]-1), + 0,0,0,1); + result := true; +end; + +procedure FindAlignment (var lBGImg: TBGImg; var lHdr: TMRIcroHdr); +//identifies spatial position of low X,Y,Z voxels : A/P/L/R/S/I +var + lDim: integer; + lXMid,lYMid,lZMid,laX,laY,laZ,lX,lY,lZ,lX2,lY2,lZ2: single; + lMatrix: TMatrix; +begin + lBGImg.KnownAlignment := false; + if not IsNifTiMagic (lHdr.NIFTIHdr) then + exit; //Analyze format: spatial coordinates are amibguous + if (lHdr.NIFTIhdr.sform_code <= 0) and (lHdr.NIFTIhdr.qform_code <= 0) then + exit; //NIfTI format with unspecified coordinates + lBGImg.KnownAlignment := true; + if (lBGImg.Resliced) and (lHdr.NIFTIhdr.sform_code > 0) then begin + lBGImg.MinChar[1] := 'L'; + lBGImg.MaxChar[1] := 'R'; + lBGImg.MinChar[2] := 'P'; + lBGImg.MaxChar[2] := 'A'; + lBGImg.MinChar[3] := 'I'; + lBGImg.MaxChar[3] := 'S'; + exit; + end; + if (not gBGImg.OrthoReslice) then begin + lBGImg.MinChar[1] := ' '; + lBGImg.MaxChar[1] := ' '; + lBGImg.MinChar[2] := ' '; + lBGImg.MaxChar[2] := ' '; + lBGImg.MinChar[3] := ' '; + lBGImg.MaxChar[3] := ' '; + exit; + end; + //there are two approaches to solve this - a more elegant solution is to find the nearest orthogonal aligment + //the method below is simpler, but might give unusual results if the field of view in one dimension is much larger than another + lMatrix := lHdr.Mat; + lXMid := lHdr.NIFTIhdr.Dim[1] div 2; + lYMid := lHdr.NIFTIhdr.Dim[2] div 2; + lZMid := lHdr.NIFTIhdr.Dim[3] div 2; + for lDim := 1 to 3 do begin + if lDim = 1 then begin + FindMatrixPt(0,lYMid,lZMid,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid*2,lYMid,lZMid,lX2,lY2,lZ2,lMatrix); + end else if lDim = 2 then begin + FindMatrixPt(lXMid,0,lZMid,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid,lYMid*2,lZMid,lX2,lY2,lZ2,lMatrix); + end else begin //lDim=3 + FindMatrixPt(lXMid,lYMid,0,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid,lYMid,lZMid*2,lX2,lY2,lZ2,lMatrix); + end; + lX := lX-lX2; laX := abs(lX); + lY := lY-lY2; laY := abs(lY); + lZ := lZ-lZ2; laZ := abs(lZ); + if (laX > laY) and (laX > laZ) then begin + if lX < 0 then begin + lBGImg.MinChar[lDim] := 'L'; + lBGImg.MaxChar[lDim] := 'R'; + end else begin + lBGImg.MinChar[lDim] := 'R'; + lBGImg.MaxChar[lDim] := 'L'; + end; + end else if (laY > laZ) then begin + if lY < 0 then begin + lBGImg.MinChar[lDIm] := 'P'; + lBGImg.MaxChar[lDim] := 'A'; + end else begin + lBGImg.MinChar[lDim] := 'A'; + lBGImg.MaxChar[lDim] := 'P'; + end; + end else if (laZ > laX) then begin + if lZ < 0 then begin + lBGImg.MinChar[lDim] := 'I'; + lBGImg.MaxChar[lDim] := 'S'; + end else begin + lBGImg.MinChar[lDim] := 'S'; + lBGImg.MaxChar[lDim] := 'I'; + end; + end else begin //all dims are equal + lBGImg.MinChar[lDim] := '?'; + lBGImg.MaxChar[lDim] := '?'; + end; + end;//for each dim + +end; //proc FindAlignment + +function DICOMMirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfY,lLineOffset,lLineOffsetIn: integer; + lTemp32: single; + lTemp16: SmallInt; + lTemp: byte; + l32: SingleP; + l16: SmallIntP; +begin + result := false; + lX := lHdr.NIFTIhdr.Dim[1]; + lY := lHdr.NIFTIhdr.Dim[2]; + lZ := lHdr.NIFTIhdr.Dim[3]; + if lHdr.NIFTIhdr.Dim[4] > 1 then begin + Showmessage('Can not mirror 4D data : '+lHdr.HdrFileName); + exit; + end; + if (lHdr.ImgBufferItems < (lX*lY*lZ)) or (lX < 2) then begin + Showmessage('Unsupported filetype : '+lHdr.HdrFileName); + exit; + end; + lHlfY := lY div 2; + lLineOffset := 0; + + //for each datatype... + if lHdr.ImgBufferBPP = 4 then begin + l32 := SingleP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp32 := l32^[lXPos+lLineOffsetIn]; + l32^[lXPos+lLineOffsetIn] := l32^[lXPos+lLineOffset]; + l32^[lXPos+lLineOffset] := lTemp32; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + + end else if lHdr.ImgBufferBPP = 2 then begin + l16 := SmallIntP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp16 := l16^[lXPos+lLineOffsetIn]; + l16^[lXPos+lLineOffsetIn] := l16^[lXPos+lLineOffset]; + l16^[lXPos+lLineOffset] := lTemp16; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 1 then begin + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp := lHdr.ImgBuffer^[lXPos+lLineOffsetIn]; + lHdr.ImgBuffer^[lXPos+lLineOffsetIn] := lHdr.ImgBuffer^[lXPos+lLineOffset]; + lHdr.ImgBuffer^[lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); + result := true; +end; //proc DICOMMirrorImgBuffer + +function isPlanarImg( rawRGB: bytep; lX, lY, lZ: integer): boolean ; +var + pos, posEnd, incPlanar, incPacked, byteSlice: integer; + dxPlanar, dxPacked: double; +begin + //determine if RGB image is PACKED TRIPLETS (RGBRGBRGB...) or planar (RR..RGG..GBB..B) + //assumes strong correlation between voxel and neighbor on next line + result := false; + if (lY < 2) then exit; //requires at least 2 rows of data + incPlanar := lX; //increment next row of PLANAR image + incPacked := lX * 3; //increment next row of PACKED image + byteSlice := incPacked * lY; //bytes per 3D slice of RGB data + dxPlanar := 0.0;//difference in PLANAR + dxPacked := 0.0;//difference in PACKED + pos := ((lZ div 2) * byteSlice)+1; //offset to middle slice for 3D data + posEnd := pos + byteSlice - incPacked; + while (pos <= posEnd) do begin + dxPlanar := dxPlanar + abs(rawRGB[pos]-rawRGB[pos+incPlanar]); + dxPacked := dxPacked + abs(rawRGB[pos]-rawRGB[pos+incPacked]); + pos := pos + 1; + end; + result := (dxPlanar < dxPacked); +end; + +function ParseRGB (var lHdr: TMRIcroHdr): boolean;//RGB +//red green blue saved as contiguous planes... +var + lInSlice,lOutSlice,lZ,lSliceSz,lSliceVox,lInPos,lOutPos: integer; + isPlanarRGB: boolean; + lP: bytep; +begin + result := false; + lSliceSz := lHdr.NIFTIhdr.Dim[1]*lHdr.NIFTIhdr.Dim[2]; + lZ := lSliceSz * 3 * lHdr.NIFTIhdr.Dim[3]; + if lZ < 1 then exit; + getmem( lP,lZ); + Move(lHdr.ImgBuffer^,lP^,lZ); + freemem(lHdr.ImgBufferUnaligned); + lZ := lSliceSz * lHdr.NIFTIhdr.Dim[3]; + GetMem(lHdr.ImgBufferUnaligned ,lZ+16); + //lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned,16); + if gBGImg.PlanarRGB = 0 then + isPlanarRGB := false + else if gBGImg.PlanarRGB = 1 then + isPlanarRGB := true + else + isPlanarRGB := isPlanarImg(lP, lHdr.NIFTIhdr.Dim[1], lHdr.NIFTIhdr.Dim[2], lHdr.NIFTIhdr.Dim[3]); + if isPlanarRGB then begin + if (lHdr.Index mod 3) = 1 then //green + lInSlice := lSliceSz + else if (lHdr.Index mod 3) = 2 then//blue + lInSlice := lSliceSz+lSliceSz + else + lInSlice := 0; + lOutSlice := 0; + for lZ := 1 to lHdr.NIFTIhdr.Dim[3] do begin + for lSliceVox := 1 to lSliceSz do begin + lHdr.ImgBuffer^[lSliceVox+lOutSlice] := lP^[lSliceVox+lInSlice]; + end; + inc(lOutSlice,lSliceSz); + inc(lInSlice,lSliceSz+lSliceSz+lSliceSz); + end; + end else begin + if (lHdr.Index mod 3) = 1 then //green + lInPos := 2 + else if (lHdr.Index mod 3) = 2 then//blue + lInPos := 3 + else + lInPos := 1; + for lOutPos := 1 to lZ do begin + lHdr.ImgBuffer^[lOutPos] := lP^[lInPos]; + lInPos := lInPos + 3; + end; + end; + freemem(lP); + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := 0; + lHdr.LUT[lZ].rgbGreen := 0; + lHdr.LUT[lZ].rgbBlue := 0; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + if (lHdr.Index mod 3) = 1 then begin//green + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbGreen := lZ; + end else if (lHdr.Index mod 3) = 2 then begin //blue + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbBlue := lZ; + end else begin + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbRed := lZ; + end; + result := true; +end; + +(*function ParseRGB (var lHdr: TMRIcroHdr): boolean;//RGB +//red green blue saved as contiguous planes... +var + lInSlice,lOutSlice,lZ,lSliceSz,lSliceVox: integer; + lP: bytep; +begin + result := false; + lSliceSz := lHdr.NIFTIhdr.Dim[1]*lHdr.NIFTIhdr.Dim[2]; + lZ := lSliceSz * 3 * lHdr.NIFTIhdr.Dim[3]; + if lZ < 1 then exit; + getmem( lP,lZ); + Move(lHdr.ImgBuffer^,lP^,lZ); + freemem(lHdr.ImgBufferUnaligned); + lZ := lSliceSz * lHdr.NIFTIhdr.Dim[3]; + GetMem(lHdr.ImgBufferUnaligned ,lZ+16); + {$IFDEF FPC} + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned,16); + {$ELSE} + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + if (lHdr.Index mod 3) = 1 then //green + lInSlice := lSliceSz + else if (lHdr.Index mod 3) = 2 then//blue + lInSlice := lSliceSz+lSliceSz + else + lInSlice := 0; + + lOutSlice := 0; + for lZ := 1 to lHdr.NIFTIhdr.Dim[3] do begin + for lSliceVox := 1 to lSliceSz do begin + lHdr.ImgBuffer^[lSliceVox+lOutSlice] := lP^[lSliceVox+lInSlice]; + end; + inc(lOutSlice,lSliceSz); + inc(lInSlice,lSliceSz+lSliceSz+lSliceSz); + end; + freemem(lP); + if (lHdr.Index mod 3) = 1 then //green + lZ := 3 + else if (lHdr.Index mod 3) = 2 then //blue + lZ := 2 + else //red + lZ := 1; + + LoadMonochromeLUT (lZ, gBGImg, lHdr) ; + result := true; +end; *) + +procedure NonReslicedGB (var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr);//vcx +begin + if lImg2Load.NIfTItransform then + lBackgroundImg.InvMat := Hdr2InvMat (lImg2Load.NIftiHdr,lImg2Load.NIfTItransform ); + FindMatrixBounds(lBackgroundImg,lImg2Load,false); + FindAlignment(lBackgroundImg,lImg2Load); + MakeSameOrtho(lBackgroundImg,lImg2Load); +end; + +procedure ReorientToNearestOrtho (var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground: boolean); +//only apply this to the background image - other routines will reorient overlays +begin + lBackgroundImg.ReorientHdr := lImg2Load.NIFTIhdr;//vcx + if not OrthoReorientCore(lImg2Load,false) then exit;//no change + if not lLoadBackground then exit; //no change in bounding box + lBackgroundImg.UseReorientHdr := true; + NonReslicedGB(lBackgroundImg,lImg2Load); +end; + +function OpenImg(var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground,lVOILoadAsBinary,lNoScaling8bit,lResliceIn,l4D: boolean): boolean; +//lReslice: use orientation matrix to transform image -> do not use if l4D = true +//l4D: load all slices of a 4D volume +label +456; +var + lReslice,lSwap: boolean; + lWordX: word; + lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01:single; + lMinI,lMaxI,lInc: integer; + lMultiImgSzOff,lMultiImgSz,lOffset, + lVol,lnVol,lFileSz,lDataType,lFSz,lImgSamples: Int64; //,lRow + lP: Bytep; + lFName,lParseName: String; + F: file; + l16Buf : SmallIntP; + l32Buf,l32TempBuf : SingleP; + l64Buf : DoubleP; +begin + lReslice := lResliceIn; + if lLoadBackground then begin + lBackgroundImg.LabelRA := nil; + ImgForm.CloseImagesClick(nil); + end; + result := false; + FreeImgMemory(lImg2Load); + if not lImg2Load.DiskDataNativeEndian then + lSwap := true + else + lSwap := false; + if lLoadBackground then begin + lBackgroundImg.UseReorientHdr := false;//vcx + if(lImg2Load.NIFTIhdr.Dim[3] = 1) then + lReslice := false; + lBackgroundImg.Resliced := lReslice; + if not lReslice then + NonReslicedGB(lBackgroundImg,lImg2Load); + FindMatrixBounds(lBackgroundImg,lImg2Load,lReslice); + if (gBGImg.ScrnDim[1] < 2) or (gBGImg.ScrnDim[2] < 2) or (gBGImg.ScrnDim[3] < 1) then begin + Showmessage('Error: this does not appear to be a valid 2D or 3D image.'); + exit; + end; + if (gBGImg.ScrnDim[3] = 1) then begin + lBackgroundImg.Resliced := false; + //showmessage('x'); + end; + FindAlignment(lBackgroundImg,lImg2Load); + end; + + if (not IsNifTiMagic(lImg2Load.niftiHdr)) or (lImg2Load.NIFTIhdr.sform_code < 1) or (lImg2Load.NIFTIhdr.sform_code > 10) then + lBackgroundImg.KnownAlignment := false; + if not lReslice then begin + if lLoadBackground then begin + //MakeSameOrtho(lBackgroundImg,lImg2Load); + FindMatrixBounds(lBackgroundImg,lImg2Load,false); + FindAlignment(lBackgroundImg,lImg2Load); + MakeSameOrtho(lBackgroundImg,lImg2Load); + end; + end; //no reslice... + lDataType := lImg2Load.NIFTIhdr.datatype; + lFName := lImg2Load.ImgFileName; + lMultiImgSz := ComputeImageDataBytes(lImg2Load); + if (lMultiImgSz < 1) then begin + Showmessage('Unable to load this image (to large or corrupt)'); + end; + lOffset := round(lImg2Load.NIFTIhdr.vox_offset); + lMultiImgSzOff := lMultiImgSz + abs(lOffset); + if lImg2Load.NIFTIhdr.dim[4] < 1 then //June2009 - prevent error if 3D image sets field to zero instead of one + lImg2Load.NIFTIhdr.dim[4] := 1; + if lImg2Load.NIFTIhdr.dim[5] < 1 then //June2009 - prevent error if DTI image sets field to zero instead of one + lImg2Load.NIFTIhdr.dim[5] := 1; + lnVol := lImg2Load.NIFTIhdr.dim[4]*lImg2Load.NIFTIhdr.dim[5];//June2009 - for DTI data where direction is 5th dimension + if lMultiImgSz < 1 then exit; + lFSz := FSize(lFName); + + + if (lFSz = 0) then + Showmessage('Unable to find the image file '+lFName); + + lVol := 1; + if lnVol > 1 then begin + if lOffset < 0 then + lFileSz := lMultiImgSzOff * lnVol + else + lFileSz := (lnVol * lMultiImgSz) + lOffset; + lVol := 1; //alpha + if {not l4D} lBackgroundImg.Prompt4DVolume then begin + lVol := ReadIntForm.GetInt('Multi-volume file, please select volume to view.',1,1,lnVol); + application.processmessages; + end; + end else + lFileSz := lMultiImgSzOff; + if ((lFileSz) > lFSz) and (lImg2Load.gzBytesX = K_gzBytes_headerAndImageUncompressed) then begin + ShowMessage('Error: This image file is smaller than described in header.'+ + ' Expected: '+inttostr(lFileSz)+' Selected:'+inttostr(lFSz)+ ' '+lFname); + exit; + end; + {$I-} + AssignFile(F, lFName); + FileMode := 0; { Set file access to read only } + Reset(F, 1); + if (lImg2Load.gzBytesX <> K_gzBytes_headerAndImageUncompressed) then begin //deal with compressed data + if (lImg2Load.gzBytesX = K_gzBytes_headerAndImageCompressed) then begin + if lOffset < 0 then + lOffset := abs(lOffset) + (lMultiImgSzOff *(lVol-1)) + else + lOffset := lOffset + (lMultiImgSz *(lVol-1)); + end else + lOffset := (lMultiImgSz *(lVol-1));//header UNCOMPRESSED! + end else if lOffset < 0 then + Seek (F,abs(lOffset) + (lMultiImgSzOff *(lVol-1)) ) + else + Seek (F,lOffset + (lMultiImgSz *(lVol-1)) ); + + case lDataType of + kDT_SIGNED_SHORT,kDT_UINT16: lImg2Load.ImgBufferBPP := 2; + kDT_SIGNED_INT,kDT_FLOAT: lImg2Load.ImgBufferBPP := 4; + kDT_DOUBLE: lImg2Load.ImgBufferBPP := 8; + kDT_UNSIGNED_CHAR : lImg2Load.ImgBufferBPP := 1; + kDT_RGB: lImg2Load.ImgBufferBPP := 1;//rgb + else begin + showmessage('Unable to read this image format '+inttostr(lDataType)); + goto 456; + end; + end; + //Next get memory + lImgSamples := round(ComputeImageDataBytes8bpp(lImg2Load)); + if lImgSamples < 1 then exit; + lImg2Load.ImgBufferItems := lImgSamples; + lMultiImgSz := (lImgSamples * lImg2Load.ImgBufferBPP); + if lDataType = kDT_RGB then + lMultiImgSz := lMultiImgSz * 3;//RGB + if l4D then begin + lMultiImgSz := lMultiImgSz * lnVol; + lImgSamples := lImgSamples * lnVol; //Apr07 + end; + if lMultiImgSz > freeRam then begin + Showmessage('Unable to load image: not enough RAM.'); + goto 456; + //exit; + end; + try + GetMem(lImg2Load.ImgBufferUnaligned ,lMultiImgSz+16); + except + showmessage('Load Image Error: System memory exhausted.'); + freemem(lImg2Load.ImgBufferUnaligned); + //do goto 456 + exit; + end; + lImg2Load.ImgBuffer := align(lImg2Load.ImgBufferUnaligned, 16); + //Next Load Image + if (lImg2Load.gzBytesX <> K_gzBytes_headerAndImageUncompressed) then begin + lP := ByteP(lImg2Load.ImgBuffer); + if lImg2Load.gzBytesX = K_gzBytes_headerAndImageCompressed then + UnGZip(lFName,lP,lOffset,lMultiImgSz) + else + UnGZip2 (lFName,lP,lOffset,lMultiImgSz, round(lImg2Load.NIFTIhdr.vox_offset)); //unzip + end else + BlockRead(F,lImg2Load.ImgBuffer^,lMultiImgSz); + if IOResult <> 0 then + ShowMessage('Open image file error: '+inttostr(IOResult)); + //Next: prepare image : byte swap, check for special.. + case lDataType of + kDT_RGB: ParseRGB(lImg2Load);//RGB + kDT_SIGNED_SHORT,kDT_UINT16: begin //16-bit int + l16Buf := SmallIntP(lImg2Load.ImgBuffer ); + if lSwap then + for lInc := 1 to lImgSamples do begin + l16Buf^[lInc] := Swap2(l16Buf^[lInc]); + end; + + if (kDT_UINT16=lDataType ) then begin //avoid wrap around if read as signed value + for lInc := 1 to lImgSamples do begin + lWordX := word(l16Buf^[lInc]); + l16Buf^[lInc] := lWordX shr 1; + end; //for + end; //if kDT_UINT16 + end; //16-bit + kDT_SIGNED_INT: begin + l32Buf := SingleP(lImg2Load.ImgBuffer ); + if lSwap then //unswap and convert integer to float + for lInc := 1 to lImgSamples do + l32Buf^[lInc] := (Swap4r4i(l32Buf^[lInc])) + else //convert integer to float + for lInc := 1 to lImgSamples do + l32Buf^[lInc] := Conv4r4i(l32Buf^[lInc]); + end; //32-bit int + kDT_FLOAT: begin + l32Buf := SingleP(lImg2Load.ImgBuffer ); + if lSwap then + for lInc := 1 to lImgSamples do begin + pswap4r(l32Buf^[lInc]) //faster as procedure than function see www.optimalcode.com + end; + for lInc := 1 to lImgSamples do + if specialsingle(l32Buf^[lInc]) then l32Buf^[lInc] := 0.0; + //thresh= for lInc := 1 to lImgSamples do if l32Buf[lInc] < 2.300611 then l32Buf[lInc] := 0.0; + + //invert= for lInc := 1 to lImgSamples do l32Buf[lInc] := -l32Buf[lInc]; + end; //32-bit float + kDT_DOUBLE: begin + l64Buf := DoubleP(lImg2Load.ImgBuffer ); + lImg2Load.ImgBufferBPP := 4; //we will save as 32-bit + lMultiImgSz := (lImgSamples * lImg2Load.ImgBufferBPP); + if l4D then begin + lMultiImgSz := lMultiImgSz * lnVol; + lImgSamples := lImgSamples * lnVol; //Apr07 + end; + try + GetMem(l32TempBuf ,lMultiImgSz+16); + except + showmessage('64-bit Image Error: System memory exhausted.'); + freemem(l32TempBuf); + freemem(lImg2Load.ImgBufferUnaligned); + exit; + end; + if lSwap then begin + for lInc := 1 to lImgSamples do begin + try + l32TempBuf^[lInc] := Swap64r(l64Buf^[lInc]) + except + l32TempBuf^[lInc] := 0; + end; //except + end; //for + end else begin + for lInc := 1 to lImgSamples do begin + try + l32TempBuf^[lInc] := l64Buf^[lInc] + except + l32TempBuf^[lInc] := 0; + end; //except + end; //for + end; //not swap + //now copy from temp buffer to longer-term buffer + freemem(lImg2Load.ImgBufferUnaligned); + try + GetMem(lImg2Load.ImgBufferUnaligned ,lMultiImgSz+16); + except + showmessage('Load Image Error: System memory exhausted.'); + freemem(lImg2Load.ImgBufferUnaligned); + exit; + end; + {$IFDEF FPC} + lImg2Load.ImgBuffer := Align(lImg2Load.ImgBufferUnaligned, 16); + {$ELSE} + lImg2Load.ImgBuffer := ByteP($fffffff0 and (integer(lImg2Load.ImgBufferUnaligned)+15)); + {$ENDIF} + l32Buf := SingleP(lImg2Load.ImgBuffer ); + Move(l32TempBuf^,l32Buf^,lMultiImgSz); + freemem(l32TempBuf); + for lInc := 1 to lImgSamples do + if specialsingle(l32Buf^[lInc]) then l32Buf^[lInc] := 0.0; + //for lInc := 1 to lImgSamples do + // if specialsingle(l32Buf^[lInc]) then l32Buf^[lInc] := 0.0; + end; //64-bit float + kDT_UNSIGNED_CHAR : ; + //else will be aborted at previous case + end;//case lDataType of + if (lDataType = kDT_RGB) then + //do not transform + else if lImg2Load.NIFTIhdr.magic = kNIFTI_MAGIC_DCM then + DICOMMirrorImgBuffer(lImg2Load) + else if (lLoadBackground) and (not lReslice) and (lBackgroundImg.KnownAlignment) and (lBackgroundImg.OrthoReslice) then + ReorientToNearestOrtho(lBackgroundImg,lImg2Load,lLoadBackground) + else if (l4D) and (not lReslice) and (lBackgroundImg.KnownAlignment) and (lBackgroundImg.OrthoReslice) then + OrthoReorientCore(lImg2Load,true); + //next correct image size + if lImg2Load.NIFTIhdr.scl_slope = 0 then + lImg2Load.NIFTIhdr.scl_slope := 1; + if (lLoadBackground) and (not l4D) then + ResliceScrnImg ( lBackgroundImg,lImg2Load,true) + else if not l4D then + ResliceScrnImg ( lBackgroundImg,lImg2Load,lBackgroundImg.OverlaySmooth); //12 April 2009 - allow nearest neighbor + //Next: find min/max - better after reslicing incase we have padded zeros at the edges and zero < min + case lImg2Load.ImgBufferBPP of + 1: begin + FindImgMinMax8 (lImg2Load, lMini,lMaxi); + lImg2Load.GlMaxUnscaledS := lMaxI; + lImg2Load.GlMinUnscaledS := lMinI;; + end; + 2: begin + FindImgMinMax16 (lImg2Load, lMini,lMaxi); + lImg2Load.GlMaxUnscaledS := lMaxI; + lImg2Load.GlMinUnscaledS := lMinI;; + end; + 4: + FindImgMinMax32 (lImg2Load,lImg2Load.GlMinUnscaledS,lImg2Load.GlMaxUnscaledS); + else Showmessage('OpenImg and LoadImg error'); + end; //case ImgBufferBPP + + balance(lImg2Load); //preparecontrast autobalance + lImg2Load.WindowScaledMin := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMinUnscaled); + lImg2Load.WindowScaledMax := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMaxUnscaled); + if (lVOILoadAsBinary) then begin + lImg2Load.WindowScaledMin := kMin8bit;//MAW + lImg2Load.WindowScaledMax := kVOI8bit; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + end else if lDataType = kDT_RGB then begin//RGB + lImg2Load.UsesCustomPalette := true; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lNoScaling8bit) and (lImg2Load.ImgBufferBPP = 1) then begin + lImg2Load.UsesCustomPalette := false; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_ESTIMATE) and (lImg2Load.NIFTIhdr.intent_name[1] = '%') then begin + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 100;//lImg2Load.GlMaxUnscaledS; + lImg2Load.LutFromZero := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if ( (lImg2Load.NIFTIhdr.intent_code = NIFTI_INTENT_LOG10PVAL) or (lImg2Load.NIFTIhdr.intent_code =kNIFTI_INTENT_PVAL) or (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_ZSCORE) or ((lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_TTEST) or (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_CHISQ))) and (lImg2Load.ImgBufferBPP = 4) and (not l4D) then begin + //ComputeFDR(lImg2Load.NIFTIhdr.intent_code,round(lImg2Load.NIFTIhdr.intent_p1),lImg2Load.ImgBufferItems,lImg2Load.ImgBufferBPP,lImg2Load.ImgBuffer,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); + ComputeFDR(lImg2Load,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); + + if (Raw2ScaledIntensity(lImg2Load,lImg2Load.GlMaxUnscaledS)> lFDR05) and (lFDR05 > 0) then begin + lImg2Load.WindowScaledMin := lFDR05; //0.001 xxx + if lFDR01 > 0 then + lImg2Load.WindowScaledMax := lFDR01 + else + lImg2Load.WindowScaledMax := 2*lFDR05; //0.000001 + end else begin + lImg2Load.WindowScaledMin := lP05; //0.001 xxx + lImg2Load.WindowScaledMax := lP01; //0.000001 + end; + if (lImg2Load.WindowScaledMax < 0.00001) and (lImg2Load.WindowScaledMin < 0.00001) then begin + lImg2Load.WindowScaledMax := 5; + lImg2Load.WindowScaledMin := 0; + end; + lImg2Load.LutFromZero := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) and (lImg2Load.ImgBufferBPP = 1) and (lImg2Load.NIFTIhdr.regular = char(98)) then begin + //createLutLabel (lImg2Load, 1.0); + LoadLabelLUT(lBackgroundImg,lImg2Load); + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.UsesCustomPalette := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) and ((lImg2Load.ImgBufferBPP = 1) or (lImg2Load.ImgBufferBPP = 2)) then begin + + createLutLabel (lImg2Load.LUT, 1.0); + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := 0;//kMin8bit; + lImg2Load.WindowScaledMax := 100;//255; + lImg2Load.UsesCustomPalette := true; + lImg2Load.UsesCustomPaletteRandomRainbow := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + if {lLoadBackground} true then begin + if (( lImg2Load.NIFTIhdr.vox_offset- lImg2Load.NIFTIhdr.HdrSz) > 128) then + LoadLabels(lImg2Load.HdrFileName,lBackgroundImg.LabelRA, lImg2Load.NIFTIhdr.HdrSz, round( lImg2Load.NIFTIhdr.vox_offset)) + else + LoadLabelsTxt(lImg2Load.HdrFileName, lBackgroundImg.LabelRA); + if (High(lBackgroundImg.LabelRA) < 1) and (lImg2Load.ImgBufferBPP = 1) then + LoadLabelsOld(lBackgroundImg,lImg2Load); + if High(lBackgroundImg.LabelRA) > 0 then + lImg2Load.UsesLabels := true; + //showmessage(inttostr(High(lBackgroundImg.LabelRA) )+'xxx'); + end + //ImgForm.Help1.caption := 'imaw'+realtostr(lImg2Load.WindowScaledMin,4);//maw + end else begin + if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then begin//>only called when BPP <> 1 + LoadLabelLUT(lBackgroundImg,lImg2Load); + end; + lImg2Load.UsesCustomPalette := false; + lImg2Load.WindowScaledMin := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMinUnscaled); + lImg2Load.WindowScaledMax := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMaxUnscaled); + + end; + lParseName := parsefilename(extractfilename(lImg2Load.HdrFileName)); + if (lParsename = 'ch2bet') or (lParseName = 'ch2better') then begin + lImg2Load.WindowScaledMin := 45; + lImg2Load.WindowScaledMax := 120; + + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end; + if lParseName = 'ch2' then begin + lImg2Load.WindowScaledMin := 30; + lImg2Load.WindowScaledMax := 120; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end; + //Next: create screen buffer [scaled to background] + //if not l4D then //12/2007: do not create screen buffer for 4D load! saves memory and time + // RescaleImgIntensity (lBackgroundImg,lImg2Load); + if not l4D then begin//12/2007: do not create screen buffer for 4D load! saves memory and time + if lLoadBackground then + RescaleImgIntensity (lBackgroundImg,lImg2Load,kBGOverlayNum) + else + RescaleImgIntensity (lBackgroundImg,lImg2Load,kVOIOverlayNum); + end; + if (lVOILoadAsBinary) and (lImg2Load.ScrnBufferItems> 0) then begin + if lImg2Load.NIFTIhdr.intent_name[1] = 'I' then //indexed + showmessage('Indexed drawing - assuming drawing is binary. You may want to upgrade this software.'); + gBGImg.VOIchanged := false; + for lInc := 1 to lImg2Load.ScrnBufferItems do + if lImg2Load.ScrnBuffer^[lInc] > 1 then + lImg2Load.ScrnBuffer^[lInc] := kVOI8bit; + lMaxI := maxint; + LoadMonochromeLUT(lMaxi,lBackgroundImg,lImg2Load); + if lImg2Load.ImgBufferItems > 1 then + freemem(lImg2Load.ImgBufferUnaligned); + lImg2Load.ImgBufferItems := 0; + end else begin + ImgForm.LayerDropSelect(nil); + ImgForm.LUTdropSelect(nil); + end; + result := true; +456: + CloseFile(F); + {$I+} + FileMode := 2; +end; //proc OpenImg + +end. diff --git a/nifti_img_view.lfm b/nifti_img_view.lfm new file mode 100755 index 0000000..0319287 --- /dev/null +++ b/nifti_img_view.lfm @@ -0,0 +1,1609 @@ +object ImgForm: TImgForm + Left = 250 + Height = 469 + Top = 173 + Width = 1025 + ActiveControl = ControlPanel + AllowDropFiles = True + Caption = 'MRIcroN' + ClientHeight = 469 + ClientWidth = 1025 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnDestroy = FormDestroy + OnDropFiles = FormDropFiles + OnKeyDown = FormKeyDown + OnKeyPress = FormKeyPress + OnResize = FormResize + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object ControlPanel: TPanel + Left = 0 + Height = 40 + Top = 0 + Width = 1025 + Align = alTop + BevelOuter = bvNone + ClientHeight = 40 + ClientWidth = 1025 + ParentColor = False + ParentShowHint = False + ShowHint = True + TabOrder = 0 + OnDblClick = ControlPanelDblClick + object LabelX: TLabel + Left = 6 + Height = 16 + Top = 12 + Width = 8 + Caption = 'X' + ParentColor = False + end + object LabelY: TLabel + Left = 81 + Height = 16 + Top = 12 + Width = 8 + Caption = 'Y' + ParentColor = False + end + object LabelZ: TLabel + Left = 153 + Height = 16 + Top = 12 + Width = 8 + Caption = 'Z' + ParentColor = False + end + object HideROIBtn: TSpeedButton + Left = 808 + Height = 30 + Hint = 'Briefly hide VOIs and Overlays' + Top = 4 + Width = 30 + Glyph.Data = { + 36060000424D3606000000000000360000002800000010000000180000000100 + 2000000000000006000064000000640000000000000000000000FFFFFF00FFFF + FF00FFFFFF00C61C1D25C000007F8C4545BCB70B0BCBBF0101E8C00000F6C000 + 00DBC00000BDC00000A0C0000082C0000063C0000024FFFFFF00FFFFFF00D65D + 5F3CCF4142C4C82525FF8D4C4CFF47A0A0FF42A8A8FF983535FFC00000FFC000 + 00FFC00000FFC00000FF9A3333FFC00000FFC00000FFC00000C5DE828486D866 + 67FDD14A4BFFCA2D2EFFAB3030FF30BFBFFF30BFBFFF854F4FFFC00000FFC000 + 00FFBF0101FF7E5858FF3EADADFF519494FFAF1616FFC0000095E08A8DBBDA6E + 70FFD35253FFCC3536FFAB393AFF8C4646FF7A5E5EFFBF0101FFC00000FFC000 + 00FFC00000FF854F4FFF30BFBFFF37B6B6FFA62222FFC000003EE2939557DB77 + 78FFD55A5CFFCE3E3FFFB63636FFC10505FFBB0707FFC00000FFC00000FFC000 + 00FFB21212FF973737FF6F6C6CFF933C3CFFBA0808E5C0000001E49B9E07DD7F + 81ECD26768FFA26F70FF4BB0B0FF746F6FFFB80A0AFFC00000FFBB0606FFA327 + 27FF4E9797FF7E5757FFB80B0BFFBD0404FFC000008FFFFFFF00FFFFFF00DF87 + 8990D96B6CFF729FA0FF33CCCCFF49A9A9FFBD0404FFC00000FFC00000FF5F81 + 81FF30BFBFFF4C9A9AFFBF0101FFC00000FFC0000038FFFFFF00FFFFFF00E190 + 922CDB7375FF889394FF54AFAFFF85696AFFAF1818FFC00000FFC00000FF7268 + 68FF45A3A3FF776161FFAF1616FFC00000E0FFFFFF00FFFFFF00FFFFFF00FFFF + FF00DD7B7DC9D65F61FFB95758FFC82828FFC20A0AFFC00000FFC00000FFC000 + 00FFA62222FFBF0101FFC00000FFC0000089FFFFFF00FFFFFF00FFFFFF00FFFF + FF00DF848665AC8788FFD14B4DFFCB2F30FFC41313FFC00000FFC00000FFA820 + 20FFC00000FFC00000FFC00000FFC0000032FFFFFF00FFFFFF00FFFFFF00FFFF + FF00E18C8E0D4CCDCEFB62AFB0FFC73C3DFFC61B1BFFC00000FF943A3AFF4E97 + 97FF637C7CFFA62222FFC00000DAFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF005AC8C8CC4DC4C5FFC44A4BFFC82324FFC10707FF8E4343FF30BF + BFFF33BBBBFFAC1A1AFFC0000083FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF005ACCCD6BBB787AFFCB4D4EFFCA2C2CFFC30F0FFF904040FF637B + 7BFF726767FFA91E1EFFC000002CFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF0000FFFF03D96C6ED6D25052FFC93738FFC51818FFC00000FFBD04 + 04FFB41010FFC00000D4FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00DB757772D4595AFF957273FF945959FFA62525FFC000 + 00FFC00000FFC000007DFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00DD7D7F159F898AFB37CDCEFF32C9C9FF9A3E3EFFC000 + 00FFC00000FFC0000026FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00B08587B642C7C7FF42BCBCFF836263FFC000 + 00FFC00000CEFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00CE7A7B4AD1585AFF9A6B6BFFC61D1DFFC000 + 00FFC0000077FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00DC7A7C02D65D5FE1CF4142FFB6393AFFC209 + 09FFC0000021FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00D8666780AA6B6CFF5AA1A2FF845E + 5ED7FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00DA6E701F9F7C7DFD33CDCDFF6886 + 879AFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00948D8ECA689E9EFE8A67 + 6727FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00D7636455D04648C2FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00D96B6D06D24F5057FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 + } + OnMouseDown = HideROIBtnMouseDown + OnMouseUp = HideROIBtnMouseUp + end + object XBarBtn: TSpeedButton + Left = 838 + Height = 30 + Hint = 'Toggle Crosshairs'#13#10'right-click to change gap size'#13#10'right+ctrl click to change color'#13#10'right+alt click to change thickness'#13#10'right+shift to reposition origin'#13#10'right+ctrl+alt to adjust font size' + Top = 4 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C00000FF0000FF0000FFC0C0C0 + C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 + C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C00000FF00 + 00FF0000FFC0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 + C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 + C0C0C0C00000FF0000FF0000FFC0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0 + C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF + 0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0C0C0C000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00 + 00FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF00C0C0C0C0C0C0 + C0C0C000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF000000FF0000FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C0C0C0C0C0C0C0C0C000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 321 + OnClick = XBarBtnClick + OnMouseDown = XBarBtnMouseDown + ShowHint = True + ParentShowHint = False + end + object LayerPanel: TPanel + Left = 304 + Height = 36 + Top = 2 + Width = 500 + ClientHeight = 36 + ClientWidth = 500 + ParentColor = False + TabOrder = 5 + object AutoContrastBtn: TSpeedButton + Left = 121 + Height = 28 + Hint = 'Autocontrast' + Top = 3 + Width = 28 + Glyph.Data = { + D6080000424DD608000000000000360000002800000018000000170000000100 + 200000000000A008000064000000640000000000000000000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0000000022191919632E2E + 2EA53F3F3FC2525252D74F4F4FD53C3C3CC02D2D2D9F1111115F0000001AFFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000000C2E2E2EA8777777E8C6C6C6FEF4F4 + F4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0F0F0FF181818FF313030F22A28 + 289D00000005FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF0023232353454545DADCDCDCFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF1B1616FF1A1010FF271A + 1AFF322828EA231E1E3BFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF003030309E969696F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFAFAFF2C2020FF2F1C1CFF3A23 + 23FF3E2525FF5A4545F840363685FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF0024242459909090F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFFFFF5F5FF3A2828FF422828FF5131 + 31FF573434FF4F2F2FFF594040F82B1F1F3DFFFFFF00FFFFFF00FFFFFF000000 + 00164A4A4ADFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFCFFFFF3F3FF422D2DFF4E2F2FFF643C + 3CFF704343FF613A3AFF4B2D2DFF483636E8110A0A0AFFFFFF00FFFFFF003030 + 30C2E8E8E8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFBFAFAFFFDFD + FDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCFCFFFFF2F2FF432D2DFF4F2F2FFF663D + 3DFF754646FF633B3BFF4C2E2EFF422E2EFF3A3131AEFFFFFF000000002D8B8B + 8BEEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF3F0EFFF826868FFF4F2 + F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFFFFF5F5FF3C2929FF452929FF5533 + 33FF5C3737FF533232FF422828FF2D1B1BFF3C3333F20000000921212172CFCF + CFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE8DFDFFF835E5DFF633E3EFFF4F2 + F2FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9F9FF2F2121FF331F1FFF3F26 + 26FF432828FF3D2525FF301D1DFF1F1313FF201C1CFE0303033C313131B1FBFB + FBFFFFFFFFFFFFFFFFFFFFFFFFFFDECCCBFF8D5D5CFF7A4D4CFF6B4342FF7457 + 56FF685150FF5C4848FF4F4040FF433838FF363030FF150D0DFF1E1212FF2717 + 17FF291919FF261717FF1C1111FF0E0808FF020202FF2525258A454545CAFFFF + FFFFFFFFFFFFFFFEFEFFD7B7B6FF9F6564FF905B5AFF815250FF734847FF643F + 3EFF553535FF462C2BFF372322FF281919FF1A1010FF0B0707FF070404FF0E08 + 08FF100A0AFF0D0808FF050303FF000000FF000000FF272727C7545454DBFFFF + FFFFFFFFFFFFE3C0BFFFB67371FFA76968FF98605EFF895655FF7A4D4CFF6B44 + 43FF5D3A39FF4E3130FF3F2827FF301E1EFF211515FF130C0BFF040202FF0000 + 00FF000000FF000000FF000000FF000000FF000000FF2B2B2BDB454545CAFFFF + FFFFFFFFFFFFFEFCFBFFD4A6A6FFAF6E6DFFA06563FF915B5AFF825251FF7349 + 48FF643F3EFF563635FF472D2CFF382323FF291A19FF1A1010FF0C0707FF0000 + 00FF000000FF000000FF000000FF000000FF000000FF272727C7313131B1FBFB + FBFFFFFFFFFFFFFFFFFFFFFEFEFFDAB8B7FFA76A68FF99605FFF8A5756FF7B4D + 4CFF6C4443FF5D3B3AFF4F3231FF402828FF311F1EFF221515FF130C0CFF0403 + 03FF000000FF000000FF000000FF000000FF020202FF2525258921212172CFCF + CFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE2CACAFFA26968FF925C5AFFE1D6 + D5FFF6F4F4FFF5F3F3FFF4F2F2FFF4F2F2FFF3F1F1FF362727FF1B1111FF0C08 + 07FF000000FF000000FF000000FF000000FF161616FE0303033C0000002D8B8B + 8BEEFFFFFFFFFFFEFEFFFFFEFEFFFFFEFEFFFFFFFFFFEADBDBFFA16D6BFFE9DF + DFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF3E2C2CFF231615FF140C + 0CFF050303FF000000FF000000FF000000FF2A2A2AF100000009FFFFFF003A35 + 35C4EAE2E2FFFFF7F7FFFFF7F7FFFFF8F8FFFFF8F8FFFFF8F8FFF3E5E5FFF3ED + EDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF453131FF2B1B1AFF1C11 + 11FF0D0808FF000000FF000000FF131313FF272727A9FFFFFF00FFFFFF002818 + 181A645656E3FFF1F1FFFFF1F1FFFFF1F1FFFFF2F2FFFFF2F2FFFFF2F2FFFFF3 + F3FFFFF8F8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF4C3635FF32201FFF2516 + 16FF1C1111FF130C0CFF110A0AFF2B2626E500000009FFFFFF00FFFFFF00FFFF + FF004F3B3B66A69292F3FFEBEBFFFFEBEBFFFFECECFFFFECECFFFFECECFFFFED + EDFFFFEDEDFFFFF0F0FFFFFBFBFFFFFCFCFFFFFBFBFF604140FF503231FF4C2F + 2FFF412828FF331F1FFF423434F718141439FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00594545ABB19797F4FFE5E5FFFFE6E6FFFFE6E6FFFFE6E6FFFFE7 + E7FFFFE7E7FFFFE7E7FFFFE7E7FFFFE7E7FFFFE7E7FF805353FF6C4242FF603B + 3BFF543433FF654D4DF83A323283FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF0063464668846161E5E6C8C8FFFFE0E0FFFFE0E0FFFFE0 + E0FFFFE1E1FFFFE1E1FFFFE1E1FFFFE1E1FFFFE1E1FF8F5C5CFF7E4D4DFF764B + 4AFF634545EC3328283FFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF009A5D5D1D715050BDAA8484F0DAB6B6FEF8D3 + D3FFFFDBDBFFFFDBDBFFFFDBDBFFFFDBDBFFF5D2D2FFA06969FF906565F56146 + 46AA40272707FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF004429292C754D4D837C56 + 56BE8C6363D79D7171E7986E6EE5865F5FD4775353B75B3C3C720B07071BFFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 + } + OnClick = AutoContrastBtnClick + end + object LutFromZeroBtn: TSpeedButton + Left = 439 + Height = 28 + Hint = 'Color range from zero' + Top = 4 + Width = 28 + AllowAllUp = True + Glyph.Data = { + AE060000424DAE06000000000000360000002800000018000000170000000100 + 180000000000780600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000000000000000000000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000000000000000000000000000000000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000000000000000FF000000000000 + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00000000000000 + 00FF0000000000000000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000000000000000FF0000000000000000FF0000FF00000000000000000000 + 00000000000000FF0000FF0000FF0000FF0000FF0000FF0000FF000000000000 + 0000000000000000000000000000000000FF0000000000000000FF0000FF0000 + 000000000000000000000000000000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF000000000000000000000000000000000000000000000000000000000000 + 0000FF0000FF0000000000000000000000000000000000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000000000000000000000000000000000FF00000000 + 00000000000000FF0000FF0000FF0000FF0000000000000000000000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000000000000000000000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00000000000000 + 00000000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000 + 0000000000000000FF0000FF0000FF000000FF00FF0000FF0000FF0000FF0000 + FF0000FF0000000000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000000000FF0000FF0000FF0000FF000000FF00FF0000FF + 0000FF0000FF0000FF0000FF0000000000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000000000FF0000FF00808080808080 + 0000FF8080808080808080808080808080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080808080808080 + 80808080800000000000000A08080E0808140C0C190F0F1E1212231414281717 + 2C1A1A311D1D3620203923233A25253A27273A29293A2B2B3A2D2D3A30300000 + 000000000000008080808080800000000000002C1A1A4428285935356F424284 + 4F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBE + FFC6C6FFD7D7FFE0E0FFFFFF0000008080808080800000000000002E1B1B4428 + 285935356F4242844F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FF + ACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF000000808080808080000000 + 0000002E1B1B4428285935356F4242844F4F9A5C5CB06969C57676DA8383F190 + 90FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF00000080 + 80808080800000000000002E1B1B4428285935356F4242844F4F9A5C5CB06969 + C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0 + E0FFFFFF0000008080808080800000000000002E1B1B4428285935356F424284 + 4F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBE + FFC6C6FFD7D7FFE0E0FFFFFF0000008080808080800000000000002E1B1B4428 + 285935356F4242844F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FF + ACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF000000808080808080000000 + 0000002E1B1B4428285935356F4242844F4F9A5C5CB06969C57676DA8383F190 + 90FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF00000080 + 8080808080000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000080808080808080808080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080808080808080 + 808080808080808080808080808080808080 + } + GroupIndex = 194 + OnClick = LutFromZeroBtnClick + end + object ColorBarBtn: TSpeedButton + Left = 467 + Height = 28 + Hint = 'Draw color range ' + Top = 4 + Width = 28 + Glyph.Data = { + 96030000424D96030000000000003600000028000000180000000C0000000100 + 180000000000600300006400000064000000000000000000000000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF00808080808080808080808080808080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080808080808080 + 808080808080808080808080800000000000000A08080E0808140C0C190F0F1E + 12122314142817172C1A1A311D1D3620203923233A25253A27273A29293A2B2B + 3A2D2D3A30300000000000000000008080808080800000000000002C1A1A4428 + 285935356F4242844F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FF + ACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF000000808080808080000000 + 0000002E1B1B4428285935356F4242844F4F9A5C5CB06969C57676DA8383F190 + 90FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF00000080 + 80808080800000000000002E1B1B4428285935356F4242844F4F9A5C5CB06969 + C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0 + E0FFFFFF0000008080808080800000000000002E1B1B4428285935356F424284 + 4F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBE + FFC6C6FFD7D7FFE0E0FFFFFF0000008080808080800000000000002E1B1B4428 + 285935356F4242844F4F9A5C5CB06969C57676DA8383F19090FE9B9BFFA4A4FF + ACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF000000808080808080000000 + 0000002E1B1B4428285935356F4242844F4F9A5C5CB06969C57676DA8383F190 + 90FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0E0FFFFFF00000080 + 80808080800000000000002E1B1B4428285935356F4242844F4F9A5C5CB06969 + C57676DA8383F19090FE9B9BFFA4A4FFACACFFB5B5FFBEBEFFC6C6FFD7D7FFE0 + E0FFFFFF00000080808080808000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000008080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080808080808080 + 8080808080808080808080808080808080808080808080808080 + } + OnMouseDown = ColorBarBtnMouseDown + end + object LayerDrop: TComboBox + Left = 4 + Height = 20 + Top = 4 + Width = 116 + ItemHeight = 0 + ItemIndex = 0 + Items.Strings = ( + 'Background Layer' + ) + OnChange = LayerDropChange + OnSelect = LayerDropSelect + ParentShowHint = False + ShowHint = True + Style = csDropDownList + TabOrder = 0 + Text = 'Background Layer' + end + object MinWindowEdit: TFloatSpinEdit + Left = 153 + Height = 16 + Top = 4 + Width = 88 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 9999999 + MinValue = -9999999 + OnChange = MinContrastWindowEditChange + TabOrder = 1 + Value = 1 + end + object MaxWindowEdit: TFloatSpinEdit + Left = 245 + Height = 16 + Top = 4 + Width = 88 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 9999999 + MinValue = -9999999 + OnChange = MaxContrastWindowEditChange + TabOrder = 2 + Value = 1 + end + object LUTdrop: TComboBox + Left = 340 + Height = 20 + Top = 5 + Width = 100 + DropDownCount = 66 + ItemHeight = 0 + OnChange = LUTdropChange + OnSelect = LUTdropSelect + ParentShowHint = False + ShowHint = True + Style = csDropDownList + TabOrder = 3 + end + end + object ZoomDrop: TComboBox + Left = 225 + Height = 20 + Top = 8 + Width = 79 + DropDownCount = 12 + ItemHeight = 0 + Items.Strings = ( + 'To Fit' + 'To Int' + 'x1' + 'x2' + 'x3' + 'x4' + 'x5' + 'x6' + 'x7' + 'x8' + 'x9' + ) + OnChange = ZoomDropChange + OnSelect = ZoomDropSelect + ParentShowHint = False + ShowHint = True + Style = csDropDownList + TabOrder = 4 + end + object XViewEdit: TSpinEdit + Left = 24 + Height = 16 + Top = 12 + Width = 52 + MinValue = 1 + OnChange = XViewEditChange + TabOrder = 0 + Value = 100 + end + object YViewEdit: TSpinEdit + Left = 97 + Height = 16 + Top = 12 + Width = 52 + MinValue = 1 + OnChange = XViewEditChange + TabOrder = 1 + Value = 32 + end + object ZViewEdit: TSpinEdit + Left = 169 + Height = 16 + Top = 12 + Width = 52 + MinValue = 1 + OnChange = XViewEditChange + TabOrder = 2 + Value = 14 + end + object ToolPanel: TPanel + Left = 872 + Height = 32 + Top = 4 + Width = 165 + BevelOuter = bvNone + ClientHeight = 32 + ClientWidth = 165 + TabOrder = 3 + Visible = False + object PenBtn: TSpeedButton + Left = 0 + Height = 30 + Hint = 'Pen Tool' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF00C9C9CCBABAD0B1B1D2B0B0D2B4B4D1BCBCCFC6C6CD00FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF00CACACCA4A4D57B7BDF3434F13333F23333F23333F13535F1 + 3737F04343ED5656E96F6FE28B8BDBADADD3C8C8CC00FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF00A0A0D62F2FF31717F89797D83A3AF03333F233 + 33F23333F23333F23333F23333F23333F23333F23333F23333F14141EE7575E0 + B8B8D000FF0000FF0000FF0000FF0000FF00ABABD36262FB4C4CFF1414F9C7C7 + CCC2C2CEAFAFD3A1A1D69A9AD89494D98C8CDB8282DE7878E06D6DE35C5CE742 + 42EE3333F13333F23D3DEEBABACF00FF0000FF0000FF0000FF007F7FE3B3B3FF + 3C3CFF0000FE9494D900FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF00C9C9CC8E8EDA3333F23333F2A5A5D500FF0000FF0000FF0000 + FF009F9FDB9898FF3535FF0000FF3F3FEE00FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF00CBCBCC6060E53333F25353E9C9C9CC00FF + 0000FF0000FF0000FF00CACACC7676E41A1AFB2E2EF2A8A8D400FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF009A9AD73333F13C3CEF + B5B5D100FF0000FF0000FF0000FF0000FF00CCCCCCA9A9A93B3B435B5B5DB9B9 + B900FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00CACACC4D + 4DEA3434F19999D800FF0000FF0000FF0000FF0000FF0000FF00CCCCCC404040 + 0E0E0E0000001C1C1CB4B4B400FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF00B8B8D03434F15C5CE7CBCBCC00FF0000FF0000FF0000FF0000FF0000 + FF00CBCBCB44444450505000000000000062626200FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF00C5C5CD4747EC4A4AEBBCBCCF00FF0000FF0000FF + 0000FF0000FF0000FF00CBCBCB4646465F5F5F0000000000003F3F3F00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00B1B1D24949EB4141ED + 9797D8CBCBCC00FF0000FF0000FF0000FF0000FF004949496565650000000000 + 0030303000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C4C4CD7A7ADF3737F05D5DE7B5B5D100FF0000FF0000FF0000FF00505050 + 69696900000000000024242400FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF00CBCBCCB2B2D25B5BE73A3AEF8B8BDBCACACC00 + FF0000FF006969695B5B5B0000000000001D1D1D00FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00CACACC9797 + D83E3EEE7B7BDFCBCBCC00FF009191915050500101010000001B1B1B00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF00CBCBCC7B7BDF3B3BEFC2C2CD00FF00BBBBBB3A3A3A0A0A0A0000 + 0018181800FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF00CBCBCCB6B6D16C6CE35353E9A9A9D400FF0000FF00CACACA + 323232171717000000101010CBCBCB00FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF00CBCBCCAEAED36969E46262E59F9FD6CACACC00FF0000 + FF0000FF0000FF004B4B4B1515150000000B0B0BC6C6C600FF0000FF0000FF00 + 00FF0000FF0000FF0000FF00CACACCA0A0D66E6EE27A7ADFB5B5D1CBCBCC00FF + 0000FF0000FF0000FF0000FF0000FF00858585020202000000050505BBBBBB00 + FF0000FF0000FF0000FF0000FF0000FF00C4C4CD9595D8A5A5D5C8C8CC00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00BFBFBF0808080000 + 00000000A3A3A300FF0000FF0000FF0000FF0000FF0000FF00CBCBCC00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF004A4A4A00000000000084848400FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF00A6A6A603030300000065656500FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0041414100000046464600 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00AAAA + AA05050525252500FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 44 + OnClick = PenBtnClick + end + object ClosedPenBtn: TSpeedButton + Left = 30 + Height = 30 + Hint = 'Autoclose Pen' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF00C9C9CCBABAD0B1B1D2B0B0D2B4B4D1BCBCCFC6C6CD00FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF00CACACCA4A4D57B7BDF3434F13333F23333F23333F13535F1 + 3737F04343ED5656E96F6FE28B8BDBADADD3C8C8CC00FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF00A0A0D62F2FF31717F89797D83A3AF03333F233 + 33F23333F23333F23333F23333F23333F23333F23333F23333F14141EE7575E0 + B8B8D000FF0000FF0000FF0000FF0000FF00ABABD36262FB4C4CFF1414F9C7C7 + CCC2C2CEAFAFD3A1A1D69A9AD89494D98C8CDB8282DE7878E06D6DE35C5CE742 + 42EE3333F13333F23D3DEEBABACF00FF0000FF0000FF0000FF007F7FE3B3B3FF + 3C3CFF0000FE9494D900FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF00C9C9CC8E8EDA3333F23333F2A5A5D500FF0000FF0000FF0000 + FF009F9FDB9898FF3535FF0000FF3F3FEE00FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF00CBCBCC6060E53333F25353E9C9C9CC00FF + 0000FF0000FF0000FF00CACACC7676E41A1AFB2E2EF2A8A8D400FF0000FF00FF + 0000FF000000FF0000FF0000FF0000FF0000FF0000FF009A9AD73333F13C3CEF + B5B5D100FF0000FF0000FF0000FF0000FF00CCCCCCA9A9A93B3B435B5B5DB9B9 + B900FF00FF0000FF0000FF0000FF000000FF0000FF0000FF0000FF00CACACC4D + 4DEA3434F19999D800FF0000FF0000FF0000FF0000FF0000FF00CCCCCC404040 + 0E0E0E0000001C1C1CB4B4B4FF0000FF0000FF0000FF000000FF0000FF0000FF + 0000FF00B8B8D03434F15C5CE7CBCBCC00FF0000FF0000FF0000FF0000FF0000 + FF00CBCBCB44444450505000000000000062626200FF00FF0000FF000000FF00 + 00FF0000FF0000FF0000FF00C5C5CD4747EC4A4AEBBCBCCF00FF0000FF0000FF + 0000FF0000FF0000FF00CBCBCB4646465F5F5F0000000000003F3F3F00FF0000 + FF0000FF0000FF00FF0000FF000000FF0000FF0000FF00B1B1D24949EB4141ED + 9797D8CBCBCC00FF0000FF0000FF0000FF0000FF004949496565650000000000 + 0030303000FF0000FF0000FF00FF0000FF0000FF0000FF000000FF0000FF0000 + FF00C4C4CD7A7ADF3737F05D5DE7B5B5D100FF0000FF0000FF0000FF00505050 + 69696900000000000024242400FF0000FF0000FF00FF0000FF0000FF0000FF00 + 0000FF0000FF0000FF0000FF00CBCBCCB2B2D25B5BE73A3AEF8B8BDBCACACC00 + FF0000FF006969695B5B5B0000000000001D1D1D00FF0000FF0000FF0000FF00 + FF0000FF000000FF0000FF0000FF0000FF0000FF0000FF0000FF00CACACC9797 + D83E3EEE7B7BDFCBCBCC00FF009191915050500101010000001B1B1B00FF0000 + FF0000FF0000FF0000FF0000FF0000FF00FF0000FF000000FF0000FF0000FF00 + 00FF0000FF00CBCBCC7B7BDF3B3BEFC2C2CD00FF00BBBBBB3A3A3A0A0A0A0000 + 0018181800FF0000FF0000FF0000FF0000FF0000FF00FF0000FF0000FF0000FF + 000000FF0000FF00CBCBCCB6B6D16C6CE35353E9A9A9D400FF0000FF00CACACA + 323232171717000000101010CBCBCB00FF0000FF0000FF0000FF0000FF00FF00 + 00FF0000FF0000FF0000CBCBCCAEAED36969E46262E59F9FD6CACACC00FF0000 + FF0000FF0000FF004B4B4B1515150000000B0B0BC6C6C600FF0000FF0000FF00 + 00FF0000FF0000FF00FF0000FF0000A0A0D66E6EE27A7ADFB5B5D1CBCBCC00FF + 0000FF0000FF0000FF0000FF0000FF00858585020202000000050505BBBBBB00 + FF0000FF0000FF0000FF0000FF0000FF00C4C4CD9595D8A5A5D5C8C8CC00FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00BFBFBF0808080000 + 00000000A3A3A300FF0000FF0000FF0000FF0000FF0000FF00CBCBCC00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF004A4A4A00000000000084848400FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF00A6A6A603030300000065656500FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0041414100000046464600 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00AAAA + AA05050525252500FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 44 + OnClick = PenBtnClick + end + object FillBtn: TSpeedButton + Left = 60 + Height = 30 + Hint = 'Fill tool' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF00CBCBCCC5C5CDB2B2D29B9BD89090DA8585DD7C7CDF8181DE8989 + DC9292DAA7A7D5C1C1CECBCBCC00FF0000FF0000FF0000FF0000FF0000FF0000 + FF00CACACCADADD37979E04646ED1F1FF70808FC0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0606FD2D2DF37777E0C6C6CD00FF0000FF + 0000FF0000FF0000FF002E2EF20101FE0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 4242EDCBCBCC00FF0000FF0000FF0000FF001919F80000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FE19 + 19F85050EAA2A2D6CBCBCC00FF0000FF0000FF0000FF0000FF00C1C1CE5D5DE6 + 0303FE0000FF0707FD1717F92727F43636F14343ED5151EA5F5FE76C6CE38181 + DE9C9CD7B7B7D0A8A8AB5F5F5F959595CACACA00FF0000FF0000FF0000FF0000 + FF0000FF00C9C9CC2D2DF2A0A0D6C4C4CDCACACCCBCBCC00FF0000FF0000FF00 + 00FF0000FF0000FF00C7C7C7696969463536B78A8B755B5C393737A8A8A800FF + 0000FF0000FF0000FF0000FF009191D93939F000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF00CBCBCBA1A1A1353030956D6EFABABCFDC1C3FCC7C9 + DCB3B54138398A8A8ACBCBCB00FF0000FF00CBCBCC3535F06060E600FF0000FF + 0000FF0000FF0000FF0000FF0000FF00C3C3C35D5D5D503939E0A1A2FDBABBFD + C0C1FCC5C7FCCBCDFCD0D2F2CED04F46468F8F8F00FF0000FF00ABABD30101FE + 7676E000FF0000FF0000FF0000FF0000FF00CBCBCB969696352D2DA67273FCB2 + B3FDB8B9FDBEBFFDC3C5FCC9CBFCCED0FCD4D6FCD9DCEED3D63A3637B4B4B400 + FF007272E10000FF7D7DDF00FF0000FF0000FF0000FF00BCBCBC515151604040 + E99D9EFDB1B2FDB6B8FDBCBDFDC1C3FCC7C9FCCCCEFCD2D4FCD7DAFBDDDFFBE2 + E5C5B6B8484848CBCBCB4949EB0000FF7070E200FF0000FF00CACACA89898938 + 2B2BB67676FDA9A9FDAEAFFDB4B5FDBABBFDBFC1FCC5C7FCCACCFCD0D2FCD5D8 + FCDBDDFBE0E3FBE6E9FBEBEF595556A8A8A84E4EEA0000FF4A4AEB00FF00B5B5 + B5474545704646EF9999FEA7A8FDADAEFDB2B3FDB8B9FDBEBFFDC3C5FCC9CBFC + CED0FCD4D6FCD9DCFBDFE1FBE4E7FBE9EDFBEFF3B2AEB06363639696D80202FE + 0B0BFB68688A0F0F16694040F29999FEA5A6FEABACFDB0B1FDB6B7FDBCBDFDC1 + C3FCC7C8FCCCCEFCD2D4FCD7DAFCDDDFFBE2E5FBE7EBFBEDF1F7EFF34F4E4F97 + 9797CBCBCC8F8FDA3131F00202E50303EC0A0A98241939A46D6EFCADAEFDB4B5 + FDB9BBFDBFC1FCC5C6FCCACCFCD0D2FCD5D8FCDBDDFBE0E3FBE6E9FBEBEEFAF1 + F4787577727272CBCBCB00FF0000FF00C7C7C837363CCEC8F10202FE0303F60D + 0D7B5E4346F2B0B1FDBDBEFDC3C4FCC8CAFCCED0FCD3D6FCD9DBFBDEE1FBE4E7 + FBE9EDFBEFF2A6A2A44E4E4ECACACA00FF0000FF0000FF0000FF006A6A6A9F9C + 995250FB0000FF0000FE0706B8362937E0ABACFCC6C8FCCCCEFCD1D4FCD7D9FC + DCDFFBE2E5FBE7EBFBEDF0CDC6C9383738C3C3C300FF0000FF0000FF0000FF00 + 00FF00C3C3C3373636C4BFDC1312FD0000FF0000FF0807D8272039E0B4B6FCD0 + D2FCD5D7FCDADDFBE0E3FBE5E9FBEBEEE7DEE1373636B3B3B300FF0000FF0000 + FF0000FF0000FF0000FF0000FF00A2A2A2454443A7A4EE0504FE0000FF0000FF + 0505DA2A233AE2BEC0FCD9DBFBDEE1FBE3E6FBE9ECF5E9ED4B494A99999900FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0088888852504F95 + 92F00303FE0000FF0000FF0707D33B333EF3D5D7FBE2E4FBE7EAFAECF0736F70 + 76767600FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF008383835452519591EF0808FE0000FF0000FF0B0BAA736769FBE5E8FB + EBEEA1999C525252CACACA00FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF00868686444241A4A1DB1D1CFD0000FF0000 + FE100F58CFC1C4C8BEC13A3A3AC4C4C400FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00A4A4A4363535 + A7A3AF7673F91817FE2F2ECB545051373536B5B5B500FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF00BDBDBD545454555352BBB7BADAD5D70D0C0C9C9C9C00FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF00CBCBCBAAAAAA5E5E5E4545458B8B8B00 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 44 + OnClick = PenBtnClick + end + object EllipseBtn: TSpeedButton + Left = 90 + Height = 30 + Hint = 'Ellipse Tool' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + F6060000424DF606000000000000360000002800000018000000180000000100 + 180000000000C00600000000000000000000000000000000000000FF0000FF00 + 00FF0000FF0000FF0000FF00C9C9CCA7A7D48E8EDB9595D9B8B8D000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF00CACACC8181DE1C1CF70505FD1313F90D0DFB + 0505FD3D3DEFABABD300FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF00CACACC5151E90D0DFB7171E2B9 + B9D0A0A0D6C8C8CCA5A5D54545ED0C0CFB9696D800FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF006D6DE31313 + F9AAAAD3B3B3D14343F31A1AF7CBCBCC00FF00CBCBCC6D6DE20E0EFAB2B2D100 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + B9B9D00B0BFB8F8FDACBCBCC6D6DF07474FF0C0CFBC4C4CD00FF0000FF00CACA + CC3F3FEE4B4BEB00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF007A7AE02525F4CACACCCACACC9696F76161FF0000FF7A7ADF + 00FF0000FF0000FF009F9FD60707FCC4C4CD00FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF004F4FEA5959E800FF0000FF009898DE33 + 33FD0B0BFB9090DA00FF0000FF0000FF0000FF000000FF4343ED00FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF004343ED6767E400FF + 0000FF00C9C9C9575778636377C4C4C400FF000000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF00FF0000FF0000FF0000FF00 + 5454E95252E900FF0000FF00969696141414000000323232C7C7C70000FF00FF + 00C4C4CD0707FCA6A6D400FF0000FF0000FF0000FF0000FF000000FF00FF0000 + FF0000FF0000FF008282DE1D1DF6C9C9CC00FF00808080636363000000000000 + 9999990000FF00FF009090DA0E0EFAC8C8CC00FF0000FF0000FF0000FF0000FF + 000000FF00FF0000FF0000FF0000FF00BFBFCE1010FA8181DE00FF0086868669 + 69690000000000007E7E7E0000FF3E3EEF2B2BF35E5EE600FF0000FF0000FF00 + 00FF0000FF0000FF000000FF00FF0000FF0000FF0000FF0000FF007E7EDE0C0C + FB9999D89898985F5F5F0202020000007272720000FF0303FD1D1DF7BEBECE00 + FF0000FF0000FF0000FF0000FF0000FF000000FF00FF0000FF0000FF0000FF00 + 00FF00CBCBCC6666E40707FC3232CA4D4D4D03030300000039396E0000FF1C1C + F7AEAED200FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00FF0000 + FF0000FF0000FF0000FF0000FF00CBCBCC9797D84343EC3F3F4C0D0D0D000000 + 0C0C720000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 000000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00CACACA4E + 4E4E2828280000002B2B2B0000FF00FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF000000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF005353532B2B2B0000002121210000FF00FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF000000FF00FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF006565653333330000001E1E1E0000FF00FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF000000FF00FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF007D7D7D363636000000 + 1C1C1C0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00A5 + A5A522222200000014141400FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF00C9C9C91818180000000E0E0EC7C7C700FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF00454545000000020202BBBBBB00FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF008C8C8C000000 + 000000A1A1A100FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000 + FF00C8C8C81C1C1C00000083838300FF0000FF0000FF0000FF0000FF0000FF00 + 00FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF + 0000FF0000FF0000FF0000FF0078787800000065656500FF0000FF0000FF0000 + FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF0000FF00 + } + GroupIndex = 44 + OnClick = PenBtnClick + end + object Fill3DBtn: TSpeedButton + Left = 120 + Height = 30 + Hint = 'Create VOI based on background intensity' + Top = 0 + Width = 30 + AllowAllUp = True + Glyph.Data = { + D6080000424DD608000000000000360000002800000018000000170000000100 + 200000000000A008000064000000640000000000000000000000FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000FF1C0000FF510000 + FF830000FFB50000FFE70000FFE70000FFB50000FF830000FF510204FF1CFFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000000FF0B0000FF8D0000FFFC0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0102FFFF0A11FFFF121CFFFC1725 + FF8D1A2AFF0BFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000000FF460000FFDF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0305FFFF0E17FFFF1827FFFF2134FFFF273E + FFFF2B44FFDF2B45FF46FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF000000FF870000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0D15FFFF1A29FFFF253CFFFF2F4BFFFF3757 + FFFF3B5FFFFF3C60FFFF395BFF87FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF000000FF4A0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF080CFFFF1623FFFF2439FFFF314EFFFF3D60FFFF4670 + FFFF4C79FFFF4D7AFFFF4974FFFF4167FF4AFFFFFF00FFFFFF00FFFFFF000000 + FF160000FFE90000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0D16FFFF1D2EFFFF2C46FFFF3A5DFFFF4872FFFF5485 + FFFF5C93FFFF5E95FFFF588CFFFF4D7BFFE94066FF16FFFFFF00FFFFFF000000 + FFB40000FFFF0000FFFF0000DAFF0000B9FF0000A0FF0000B8FF0000DEFF0000 + FDFF0000FFFF0102FFFF111BFDFF1927BFFF253ABFFF304CBFFF3C5FBFFF4670 + BFFF5688CCFF649FE7FF649EFEFF5689FFFF4771FFB4FFFFFF000000FF2A0000 + FFFF0000E0FF000045FF000000FF000000FF000000FF000000FF000000FF0000 + 39FF0000DEFF0203FFFF111CF5FF000000FF000000FF000000FF000000FF0000 + 00FF000000FF000000FF0E1723FF345396FF4974FFFF395AFF2A0000FF600000 + FEFF00003DFF000000FF000000FF00007BFF0000ECFF00008DFF000000FF0000 + 00FF000033FF0001FFFF0F19F5FF000000FF000000FF000000FF111C39FF1F32 + 56FF152133FF000000FF000000FF000000FF253C8AFF3656FF600000FF960000 + FFFF0000FDFF0000E7FF0000CDFF0000FAFF0000FFFF0000DEFF000000FF0000 + 00FF000001FF0000F2FF0C13F5FF000000FF000000FF000000FF2A429AFF5180 + FFFF588CFFFF253A68FF000000FF000000FF050713FF304CFF960000FFCB0000 + FFFF0000FFFF0000FFFF0000FFFF0000BBFF00006BFF000027FF000000FF0000 + 00FF00006AFF0000FFFF060AF5FF000000FF000000FF000000FF22379AFF426A + FFFF4872FFFF314EABFF000000FF000000FF000000FF2135D9D10000FFF20000 + FFFF0000FFFF0000FFFF0000FFFF0000AAFF000003FF000000FF000000FF0000 + 7EFF0000FFFF0000FFFF0000F5FF000000FF000000FF000000FF1B2A9AFF3351 + FFFF3758FFFF1F318BFF000000FF000000FF000000FF1927E2F30000FFC80000 + FFFF0000F8FF0000D9FF0000B8FF0000F6FF0000ECFF00003EFF000000FF0000 + 00FF0000AEFF0000FFFF0000F5FF000000FF000000FF000000FF121C9AFF2338 + FFFF2135D9FF080C32FF000000FF000000FF03051EFF0F19FFC80000FF920000 + FFFF000085FF000000FF000000FF00005DFF0000ADFF00002FFF000000FF0000 + 00FF0000BCFF0000FFFF0000F5FF000000FF000000FF000000FF010218FF0203 + 16FF000000FF000000FF000000FF000002FF070BB4FF0203FF920000FF5C0000 + FFFF0000FFFF00007BFF00000FFF000000FF000000FF000000FF00000FFF0000 + 7DFF0000FFFF0000FFFF0000F5FF000000FF000000FF000000FF000000FF0000 + 00FF000003FF01011FFF01024EFF0001CEFF0000FFFF0000FF5C0000FF250000 + FFFF0007FFFF000FFFFF0010FAFF000EE1FF000BD5FF0005E6FF0000FBFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000EFFF0000EFFF0000EFFF0000EFFF0000 + EFFF0000FBFF0000FFFF0000FFFF0000FFFF0000FFFF0000FF25FFFFFF00001C + FFB5001DFFFF001DFFFF001CFFFF001CFFFF001BFFFF001BFFFF0017FFFF000A + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFA4FFFFFF00FFFFFF000032 + FF170026FFE80023FFFF0023FFFF0022FFFF0021FFFF0020FFFF0020FFFF001F + FFFF0017FFFF0004FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0001 + FFFF0007FFFF000EFFFF0012FFFF0014FFE60021FF16FFFFFF00FFFFFF00FFFF + FF000034FF55002BFFFD002AFFFF0029FFFF0028FFFF0027FFFF0026FFFF0025 + FFFF0025FFFF0023FFFF0010FFFF0008FFFF000BFFFF000EFFFF0016FFFF001E + FFFF001FFFFF001EFFFF001EFFFD0020FF4FFFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00002CFF880031FFFD0030FFFF002FFFFF002EFFFF002EFFFF002C + FFFF002CFFFF002BFFFF002AFFFF002AFFFF0028FFFF0028FFFF0027FFFF0026 + FFFF0025FFFF0025FFFD0022FF87FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF000041FF4A003DFFDE0037FFFF0036FFFF0035FFFF0035 + FFFF0033FFFF0032FFFF0032FFFF0031FFFF0030FFFF002FFFFF002EFFFF002E + FFFF0030FFDD0031FF47FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF000093FF110042FF93003EFFF9003DFFFF003C + FFFF003BFFFF003BFFFF003AFFFF0038FFFF0038FFFF0037FFFF0035FFF9003A + FF92007BFF0EFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000055FF12005BFF5B004F + FF8E004AFFB90046FFDF0046FFDF0048FFBA004CFF8E0051FF590045FF10FFFF + FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 + } + GroupIndex = 44 + OnClick = Fill3DBtnClick + end + end + end + object MagPanel: TPanel + Left = 0 + Height = 18 + Top = 451 + Width = 1025 + Align = alBottom + BevelOuter = bvNone + ClientHeight = 18 + ClientWidth = 1025 + TabOrder = 1 + object StatusLabel: TLabel + Left = 2 + Height = 16 + Top = 2 + Width = 133 + Caption = ' No Images Loaded ' + ParentColor = False + end + object ProgressBar1: TProgressBar + Left = 875 + Height = 18 + Top = 0 + Width = 150 + Align = alRight + Anchors = [akRight, akBottom] + BorderWidth = 1 + TabOrder = 0 + end + end + object Panel1: TPanel + Left = 0 + Height = 411 + Top = 40 + Width = 1025 + Align = alClient + BevelOuter = bvNone + ClientHeight = 411 + ClientWidth = 1025 + TabOrder = 2 + object TriplePanel: TScrollBox + Tag = 666 + Left = 0 + Height = 411 + Top = 0 + Width = 1025 + HorzScrollBar.Page = 775 + VertScrollBar.Page = 250 + Align = alClient + ClientHeight = 396 + ClientWidth = 1010 + Constraints.MinWidth = 5 + Color = clBlack + ParentColor = False + TabOrder = 0 + OnClick = ImgPanelClick + object PGImageCor: TImage + Tag = 2 + Cursor = crCross + Left = 1 + Height = 12 + Top = 1 + Width = 12 + AutoSize = True + OnDblClick = PGImageCorDblClick + OnMouseDown = PGImageMouseDown + OnMouseMove = PGImageMouseMove + OnMouseUp = PGImageMouseUp + Stretch = True + end + object PGImageSag: TImage + Tag = 3 + Cursor = crCross + Left = 323 + Height = 12 + Top = 110 + Width = 12 + AutoSize = True + OnDblClick = PGImageCorDblClick + OnMouseDown = PGImageMouseDown + OnMouseMove = PGImageMouseMove + OnMouseUp = PGImageMouseUp + Stretch = True + end + object PGImageAx: TImage + Tag = 1 + Cursor = crCross + Left = 763 + Height = 12 + Top = 238 + Width = 12 + AutoSize = True + OnDblClick = PGImageCorDblClick + OnMouseDown = PGImageMouseDown + OnMouseMove = PGImageMouseMove + OnMouseUp = PGImageMouseUp + Stretch = True + end + end + end + object MainMenu1: TMainMenu + left = 112 + top = 212 + object AppleMenu: TMenuItem + Caption = '' + Visible = False + object MenuItem3: TMenuItem + Caption = 'Preferences' + OnClick = Preferences1Click + end + end + object File1: TMenuItem + Caption = '&File' + object NewWindow1: TMenuItem + Caption = 'New window' + Visible = False + OnClick = NewWindow1Click + end + object Open1: TMenuItem + Caption = '&Open' + ShortCut = 16463 + OnClick = Open1Click + end + object Recent1: TMenuItem + Caption = 'Open &recent' + end + object Templates1: TMenuItem + Caption = 'Open &templates' + end + object CloseImages: TMenuItem + Caption = '&Close images' + OnClick = CloseImagesClick + end + object SaveasNIfTI1: TMenuItem + Caption = 'Save as NIfTI...' + ShortCut = 49235 + OnClick = SaveasNIfTI1Click + end + object Saveaspicture1: TMenuItem + Caption = '&Save as bitmap' + ShortCut = 16467 + OnClick = Saveaspicture1Click + end + object Exit1: TMenuItem + Caption = 'E&xit' + OnClick = Exit1Click + end + end + object Edit1: TMenuItem + Caption = '&Edit' + object Copy1: TMenuItem + Caption = 'Copy' + ShortCut = 16451 + OnClick = Copy1Click + end + object Paste1: TMenuItem + Caption = 'Paste' + ShortCut = 16470 + OnClick = Paste1Click + end + object Undo1: TMenuItem + Caption = 'Undo' + ShortCut = 16474 + OnClick = Undo1Click + end + end + object OverlayMenu: TMenuItem + Caption = '&Overlay' + object OverlayOpen: TMenuItem + Caption = 'Add' + ShortCut = 16449 + OnClick = OverlayOpenClick + end + object CloseOverlayImg: TMenuItem + Caption = 'Close overlays' + OnClick = CloseOverlayImgClick + end + object BGTransPctMenu: TMenuItem + Caption = 'Transparency on background' + object BGtrans0: TMenuItem + Caption = '0% opaque' + Checked = True + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans20: TMenuItem + Tag = 20 + Caption = '20%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans40: TMenuItem + Tag = 40 + Caption = '40%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans50: TMenuItem + Tag = 50 + Caption = '50%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans60: TMenuItem + Tag = 60 + Caption = '60%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans80: TMenuItem + Tag = 80 + Caption = '80%' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGtrans100: TMenuItem + Tag = 100 + Caption = '100% transparent' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + object BGAdditive: TMenuItem + Tag = -1 + Caption = 'Additive' + GroupIndex = 251 + RadioItem = True + OnClick = BGtrans100Click + end + end + object OverlayTransPctMenu: TMenuItem + Caption = 'Transparency on other overlays' + object N0opaque1: TMenuItem + Caption = '0% opaque' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N201: TMenuItem + Tag = 20 + Caption = '20%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N401: TMenuItem + Tag = 40 + Caption = '40%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N501: TMenuItem + Tag = 50 + Caption = '50%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N601: TMenuItem + Tag = 60 + Caption = '60%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N801: TMenuItem + Tag = 80 + Caption = '80%' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object N100transparent1: TMenuItem + Tag = 100 + Caption = '100% transparent' + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + object OverlayAdditive: TMenuItem + Tag = -1 + Caption = 'Additive' + Checked = True + GroupIndex = 253 + RadioItem = True + OnClick = OverlayTransClick + end + end + object LayerMenu: TMenuItem + Caption = 'Layer color' + Visible = False + object Noneopen1: TMenuItem + Caption = 'None open' + end + end + object Layerrange1: TMenuItem + Caption = 'Layer intensity' + Visible = False + object Noneopen2: TMenuItem + Caption = 'None open' + end + end + end + object DrawMenu: TMenuItem + Caption = '&Draw' + object HideDrawMenuItem: TMenuItem + Caption = 'Hide drawing tools' + OnClick = ToggleDrawMenu + end + object OpenVOI: TMenuItem + Caption = 'Open VOI...' + OnClick = OpenVOIClick + end + object SaveVOI: TMenuItem + Caption = 'Save VOI...' + OnClick = SaveVOIClick + end + object CloseVOI: TMenuItem + Caption = 'Close VOI...' + OnClick = CloseVOIClick + end + object VOIColor: TMenuItem + Caption = 'VOI color...' + OnClick = VOIColorClick + end + object Applyintensityfiltertovolume1: TMenuItem + Caption = 'Intensity filter...' + ShortCut = 16454 + OnClick = Applyintensityfiltertovolume1Click + end + object SmoothVOI1: TMenuItem + Caption = 'Smooth VOI...' + OnClick = SmoothVOI1Click + end + object MaskimagewithVOI1: TMenuItem + Caption = 'Mask image with VOI' + object VOImaskDelete: TMenuItem + Caption = 'Delete regions with VOI' + OnClick = VOImaskClick + end + object VOImaskPreserve: TMenuItem + Tag = 1 + Caption = 'Preserve regions with VOI' + OnClick = VOImaskClick + end + end + object Overlaycomparisons1: TMenuItem + Caption = 'Overlay comparisons' + object IntersectionmutualtoVOIandoverlays1: TMenuItem + Caption = 'Intersection [VOI and overlays]' + OnClick = ROIcomparisonClick + end + object UnionVOIoroverlays1: TMenuItem + Tag = 1 + Caption = 'Union [VOI or overlays]' + OnClick = ROIcomparisonClick + end + object MaskVOIbutnotoverlays1: TMenuItem + Tag = 2 + Caption = 'Mask [VOI but not overlays]' + OnClick = ROIcomparisonClick + end + end + object Statistics1: TMenuItem + Caption = 'Statistics' + object Beta1: TMenuItem + Caption = 'Create overlap images' + OnClick = CreateOverlap + end + object Chisquare1: TMenuItem + Caption = 'Subtraction Plots' + OnClick = Chisquare1Click + end + object BatchROImean1: TMenuItem + Caption = 'Batch descriptives' + OnClick = BatchROImean1Click + end + object Batchprobmaps1: TMenuItem + Caption = 'Batch prob maps' + OnClick = Batchprobmaps1Click + end + object Batchclusterprobmaps1Batchclusterprobmaps1Click: TMenuItem + Caption = 'Batch cluster prob maps' + OnClick = Batchclusterprobmaps1Batchclusterprobmaps1ClickClick + end + end + object Convert1: TMenuItem + Caption = 'Convert' + object ROIVOI1: TMenuItem + Caption = 'ROI -> VOI' + OnClick = ROIVOI1Click + end + object VOI2NII: TMenuItem + Caption = 'VOI -> NII' + OnClick = VOI2NIIClick + end + object NIIVOI: TMenuItem + Caption = 'NII -> VOI' + OnClick = NIIVOIClick + end + end + object Nudge1: TMenuItem + Caption = 'Nudge' + object Up1: TMenuItem + Caption = 'Left' + OnClick = Up1Click + end + object Left1: TMenuItem + Tag = 1 + Caption = 'Right' + OnClick = Up1Click + end + object LeftX1: TMenuItem + Tag = 2 + Caption = 'Posterior' + OnClick = Up1Click + end + object RightX1: TMenuItem + Tag = 3 + Caption = 'Anterior' + OnClick = Up1Click + end + object Posterior1: TMenuItem + Tag = 4 + Caption = 'Inferior' + OnClick = Up1Click + end + object Posterior2: TMenuItem + Tag = 5 + Caption = 'Superior' + OnClick = Up1Click + end + end + object n5: TMenuItem + Caption = 'Advanced' + object RescaleMenu: TMenuItem + Caption = 'Phase to rad/S' + OnClick = RescaleMenuClick + end + object BrainExtraction1: TMenuItem + Caption = 'Brain extraction' + OnClick = BETmenuClick + end + object CropEdges1: TMenuItem + Caption = 'Crop edges' + OnClick = CropMenuClick + end + object Brainmask1: TMenuItem + Caption = 'Brain mask ' + OnClick = BrainMask1Click + end + object GenerateSPM5maskslesions1: TMenuItem + Caption = 'Create SPM5 mask' + OnClick = GenerateSPM5maskslesions1Click + end + object LRFlip1: TMenuItem + Caption = 'LR Flip' + OnClick = MirrorNII1Click + end + object ApplyClusterThreshold1: TMenuItem + Caption = 'Apply cluster threshold' + OnClick = ApplyClusterThreshold1Click + end + object ExportasRGBAnalyzeimage1: TMenuItem + Caption = 'Export as RGB image' + OnClick = ExportasRGBAnalyzeimage1Click + end + object Resliceimage1: TMenuItem + Caption = 'Reslice images' + OnClick = Resliceimage1Click + end + object AdjustimagessoVOIintensityiszero1: TMenuItem + Caption = 'Adjust images so VOI intensity is zero' + OnClick = AdjustimagessoVOIintensityiszero1Click + end + object Extract1: TMenuItem + Caption = 'Extract objects' + OnClick = Extract1Click + end + end + object DescriptiveMenuItem: TMenuItem + Caption = 'Descriptive' + OnClick = DescriptiveMenuItemClick + end + object N1: TMenuItem + Caption = '-' + end + object Pen1: TMenuItem + Tag = 2 + Caption = 'Pen' + ShortCut = 112 + OnClick = ToolSelectClick + end + object Penautoclose1: TMenuItem + Tag = 3 + Caption = 'Autoclose pen' + ShortCut = 113 + OnClick = ToolSelectClick + end + object CircleSquare1: TMenuItem + Tag = 4 + Caption = 'Fill' + ShortCut = 114 + OnClick = ToolSelectClick + end + object Circle2: TMenuItem + Tag = 5 + Caption = 'Circle' + ShortCut = 115 + OnClick = ToolSelectClick + end + object Circle1: TMenuItem + Tag = 6 + Caption = 'Deselect tools' + ShortCut = 116 + OnClick = ToolSelectClick + end + end + object DrawHiddenMenu: TMenuItem + Caption = 'Draw' + Visible = False + object MenuItem2: TMenuItem + Caption = 'Show drawing tools' + OnClick = ToggleDrawMenu + end + end + object Controls1: TMenuItem + Caption = '&View' + object Display2: TMenuItem + Tag = 2 + Caption = 'Display' + object Axial1: TMenuItem + Tag = 1 + AutoCheck = True + Caption = 'Axial' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Coronal1: TMenuItem + Tag = 3 + AutoCheck = True + Caption = 'Coronal' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Sagittal1: TMenuItem + Tag = 2 + AutoCheck = True + Caption = 'Sagittal' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Multiple1: TMenuItem + AutoCheck = True + Caption = 'Multiple' + Checked = True + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Axial2: TMenuItem + Tag = -1 + AutoCheck = True + Caption = 'Axial only' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Coronal2: TMenuItem + Tag = -3 + AutoCheck = True + Caption = 'Coronal only' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + object Sagittal2: TMenuItem + Tag = -2 + AutoCheck = True + Caption = 'Sagittal only' + GroupIndex = 234 + RadioItem = True + OnClick = Sagittal1Click + end + end + object N3: TMenuItem + Caption = '-' + end + object Quicksmooth1: TMenuItem + Caption = '3D Smooth background' + OnClick = Quicksmooth1Click + end + object OverlaySmoothMenu: TMenuItem + Caption = '3D Smooth overlays' + OnClick = OverlaySmoothMenuClick + end + object Menu2DSmooth: TMenuItem + Caption = '2D Smooth all' + Checked = True + OnClick = Menu2DSmoothClick + end + object N4: TMenuItem + Caption = '-' + end + object FlipLRmenu: TMenuItem + Caption = 'Flip L/R' + OnClick = FlipLRmenuClick + end + object YokeMenu: TMenuItem + Caption = 'Yoke' + ShortCut = 16473 + OnClick = YokeMenuClick + end + object N2: TMenuItem + Caption = '-' + end + object MagnifyMenuItem: TMenuItem + Caption = 'Magnify' + OnClick = MagnifyMenuItemClick + end + object Crosshair1: TMenuItem + Caption = 'Crosshair' + OnClick = ToolSelectClick + end + object MenuItem1: TMenuItem + Caption = '-' + end + object MNIMenu: TMenuItem + Caption = 'MNI coordinates' + OnClick = MNIMenuClick + end + object Landmarks1: TMenuItem + Caption = 'Landmarks' + OnClick = Landmarks1Click + end + end + object Display1: TMenuItem + Caption = 'Window' + object ShowRender: TMenuItem + Caption = 'Render' + ShortCut = 16466 + OnClick = ShowRenderClick + end + object ShowMultislice: TMenuItem + Caption = 'Multislice' + ShortCut = 16461 + OnClick = ShowMultisliceClick + end + object HistoMenu: TMenuItem + Caption = 'Histogram' + ShortCut = 16456 + OnClick = HistoMenuClick + end + object N4DTraces1: TMenuItem + Caption = '4D Traces' + ShortCut = 16452 + OnClick = N4DTraces1Click + end + object Header1: TMenuItem + Caption = 'Information' + ShortCut = 16457 + OnClick = Header1Click + end + end + object Help1: TMenuItem + Caption = '&Help' + object Preferences1: TMenuItem + Caption = 'Preferences...' + OnClick = Preferences1Click + end + object About1: TMenuItem + Caption = 'About' + OnClick = About1Click + end + end + end + object SaveDialog1: TSaveDialog + OnClose = SaveDialog1Close + FilterIndex = 0 + left = 40 + top = 104 + end + object ColorDialog1: TColorDialog + Color = clBlack + CustomColors.Strings = ( + 'ColorA=000000' + 'ColorB=000080' + 'ColorC=008000' + 'ColorD=008080' + 'ColorE=800000' + 'ColorF=800080' + 'ColorG=808000' + 'ColorH=808080' + 'ColorI=C0C0C0' + 'ColorJ=0000FF' + 'ColorK=00FF00' + 'ColorL=00FFFF' + 'ColorM=FF0000' + 'ColorN=FF00FF' + 'ColorO=FFFF00' + 'ColorP=FFFFFF' + 'ColorQ=C0DCC0' + 'ColorR=F0CAA6' + 'ColorS=F0FBFF' + 'ColorT=A4A0A0' + ) + left = 50 + top = 212 + end + object RefreshImagesTimer: TTimer + Enabled = False + Interval = 20 + OnTimer = RefreshImagesTimerTimer + left = 82 + top = 212 + end + object RescaleImagesTimer: TTimer + Enabled = False + Interval = 50 + OnTimer = RescaleImagesTimerTimer + left = 178 + top = 212 + end + object YokeTimer: TTimer + Enabled = False + Interval = 200 + OnTimer = YokeTimerTimer + left = 280 + top = 264 + end +end diff --git a/nifti_img_view.pas b/nifti_img_view.pas new file mode 100755 index 0000000..b4aa2d2 --- /dev/null +++ b/nifti_img_view.pas @@ -0,0 +1,5178 @@ +unit nifti_img_view; + {$mode delphi} +interface +{$IFDEF UNIX} + {$IFNDEF ENDIAN_BIG}{$DEFINE COMPILEYOKE}{$ENDIF} //not supported on PPC +{$ENDIF} +uses +{$H+} +{$IFDEF Darwin}Process,{$ENDIF} //CarbonOpenDoc, +{$IFDEF Unix} + lclintf,LCLType,//gettickcount ,LMessages +{$ELSE} + Windows,ShellAPI, +{$ENDIF} +{$IFDEF COMPILEYOKE} +yokesharemem, +{$ENDIF} + +LResources, fx8, cpucount, SysUtils, Classes, Graphics, Controls, Forms, +Dialogs, Menus, ComCtrls, ExtCtrls, StdCtrls, GraphicsMathLibrary, ClipBrd, +define_types, Spin, Buttons, nifti_hdr, nifti_hdr_view, nifti_img, voismooth, +IniFiles, ReadInt, stat, Distr, bet, mni, prefs, CropEdges,nifti_types, +userdir, graphx, GraphType, IntfGraphics, landmarks,fastsmooth, nii_label;//registry + + +type + + { TImgForm } + + TImgForm = class(TForm) + AutoContrastBtn: TSpeedButton; + ColorBarBtn: TSpeedButton; + LayerDrop: TComboBox; + LUTdrop: TComboBox; + LutFromZeroBtn: TSpeedButton; + MainMenu1: TMainMenu; + File1: TMenuItem; +MaxWindowEdit: TFloatSpinEdit; +MenuItem1: TMenuItem; +HistoMenu: TMenuItem; +Header1: TMenuItem; +ApplyClusterThreshold1: TMenuItem; +LRFlip1: TMenuItem; +ExportasRGBAnalyzeimage1: TMenuItem; +BatchROImean1: TMenuItem; +Batchprobmaps1: TMenuItem; +Batchclusterprobmaps1Batchclusterprobmaps1Click: TMenuItem; +Axial1: TMenuItem; +Coronal1: TMenuItem; +Axial2: TMenuItem; +Coronal2: TMenuItem; +Landmarks1: TMenuItem; +Extract1: TMenuItem; +HideDrawMenuItem: TMenuItem; +DrawHiddenMenu: TMenuItem; +MenuItem2: TMenuItem; +AppleMenu: TMenuItem; +MenuItem3: TMenuItem; +NewWindow1: TMenuItem; +Sagittal2: TMenuItem; +Sagittal1: TMenuItem; +Multiple1: TMenuItem; +PGImageAx: TImage; +PGImageSag: TImage; +Resliceimage1: TMenuItem; +AdjustimagessoVOIintensityiszero1: TMenuItem; +Brainmask1: TMenuItem; +GenerateSPM5maskslesions1: TMenuItem; +RescaleMenu: TMenuItem; +BrainExtraction1: TMenuItem; +CropEdges1: TMenuItem; +NIIVOI: TMenuItem; +MinWindowEdit: TFloatSpinEdit; +N4DTraces1: TMenuItem; +LayerPanel: TPanel; +n5: TMenuItem; +Preferences1: TMenuItem; +Display2: TMenuItem; +MNIMenu: TMenuItem; + Open1: TMenuItem; + CloseImages: TMenuItem; + Exit1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Help1: TMenuItem; + About1: TMenuItem; + ControlPanel: TPanel; + Crosshair1: TMenuItem; + Pen1: TMenuItem; + Penautoclose1: TMenuItem; + CircleSquare1: TMenuItem; + YokeTimer: TTimer; + XViewEdit: TSpinEdit; + YViewEdit: TSpinEdit; + ZViewEdit: TSpinEdit; + MagPanel: TPanel; + ProgressBar1: TProgressBar; + StatusLabel: TLabel; + LabelX: TLabel; + LabelY: TLabel; + LabelZ: TLabel; + Templates1: TMenuItem; + Recent1: TMenuItem; + Controls1: TMenuItem; + ZoomDrop: TComboBox; + Panel1: TPanel; + Saveaspicture1: TMenuItem; + SaveDialog1: TSaveDialog; + ColorDialog1: TColorDialog; + RefreshImagesTimer: TTimer; + MagnifyMenuItem: TMenuItem; + OverlayMenu: TMenuItem; + OverlayOpen: TMenuItem; + LayerMenu: TMenuItem; + Noneopen1: TMenuItem; + OverlaySmoothMenu: TMenuItem; + CloseOverlayImg: TMenuItem; + BGTransPctMenu: TMenuItem; + OverlayTransPctMenu: TMenuItem; + BGtrans0: TMenuItem; + BGtrans20: TMenuItem; + BGtrans40: TMenuItem; + BGtrans50: TMenuItem; + BGtrans60: TMenuItem; + BGtrans80: TMenuItem; + BGtrans100: TMenuItem; + N0opaque1: TMenuItem; + N201: TMenuItem; + N401: TMenuItem; + N501: TMenuItem; + N601: TMenuItem; + N801: TMenuItem; + N100transparent1: TMenuItem; + Layerrange1: TMenuItem; + Noneopen2: TMenuItem; + BGAdditive: TMenuItem; + OverlayAdditive: TMenuItem; + ShowRender: TMenuItem; + DrawMenu: TMenuItem; + OpenVOI: TMenuItem; + SaveVOI: TMenuItem; + CloseVOI: TMenuItem; + VOIColor: TMenuItem; + TriplePanel: TScrollBox; + PGImageCor: TImage; + Undo1: TMenuItem; + Paste1: TMenuItem; + Applyintensityfiltertovolume1: TMenuItem; + Quicksmooth1: TMenuItem; + MaskimagewithVOI1: TMenuItem; + VOImaskDelete: TMenuItem; + VOImaskPreserve: TMenuItem; + SaveasNIfTI1: TMenuItem; + Circle1: TMenuItem; + Overlaycomparisons1: TMenuItem; + IntersectionmutualtoVOIandoverlays1: TMenuItem; + UnionVOIoroverlays1: TMenuItem; + MaskVOIbutnotoverlays1: TMenuItem; + RescaleImagesTimer: TTimer; + SmoothVOI1: TMenuItem; + Circle2: TMenuItem; + Beta1: TMenuItem; + Chisquare1: TMenuItem; + Convert1: TMenuItem; + ROIVOI1: TMenuItem; + Statistics1: TMenuItem; + ShowMultislice: TMenuItem; + DescriptiveMenuItem: TMenuItem; + N1: TMenuItem; + HideROIBtn: TSpeedButton; + XBarBtn: TSpeedButton; + ToolPanel: TPanel; + PenBtn: TSpeedButton; + ClosedPenBtn: TSpeedButton; + FillBtn: TSpeedButton; + EllipseBtn: TSpeedButton; + Fill3DBtn: TSpeedButton; + N2: TMenuItem; + Display1: TMenuItem; + N3: TMenuItem; + FlipLRmenu: TMenuItem; + N4: TMenuItem; + Menu2DSmooth: TMenuItem; + VOI2NII: TMenuItem; + Nudge1: TMenuItem; + Up1: TMenuItem; + Left1: TMenuItem; + LeftX1: TMenuItem; + RightX1: TMenuItem; + Posterior1: TMenuItem; + Posterior2: TMenuItem; + YokeMenu: TMenuItem; + procedure Extract1Click(Sender: TObject); + procedure NewWindow1Click(Sender: TObject); + procedure ToggleDrawMenu(Sender: TObject); + procedure SaveVOIcore(lPromptFilename: boolean); +procedure FormOpenFileMethod(const FileName : string); + +procedure Landmarks1Click(Sender: TObject); +procedure SetIniMenus; +procedure Batchclusterprobmaps1Batchclusterprobmaps1ClickClick(Sender: TObject); +procedure Batchprobmaps1Click(Sender: TObject); +procedure BatchROImean1Click(Sender: TObject); +procedure BrainMask1Click(Sender: TObject); +procedure ControlPanelDragDrop(Sender, Source: TObject; X, Y: Integer); +procedure GenerateSPM5maskslesions1Click(Sender: TObject); +procedure LoadOverlay (lFilename: string); +procedure LoadOverlayIncludingRGB (lFilename: string); +procedure ApplyClusterThreshold1Click(Sender: TObject); +procedure BETmenuClick(Sender: TObject); +procedure C(Sender: TObject); +procedure CropMenuClick(Sender: TObject); +procedure ExportasRGBAnalyzeimage1Click(Sender: TObject); +procedure FormDropFiles(Sender: TObject; const FileNames: array of String); +//procedure DropFilesOSX(Sender: TObject; const FileNames: array of String); +procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +procedure FormKeyPress(Sender: TObject; var Key: char); +procedure Header1Click(Sender: TObject); +procedure HistoMenuClick(Sender: TObject); +procedure LayerDropChange(Sender: TObject); +procedure LUTdropChange(Sender: TObject); +procedure AdjustimagessoVOIintensityiszero1Click(Sender: TObject); +procedure MirrorNII1Click(Sender: TObject); +procedure MNIMenuClick(Sender: TObject); +procedure N4DTraces1Click(Sender: TObject); +procedure NIIVOIClick(Sender: TObject); +procedure PGImageCorDblClick(Sender: TObject); +procedure Preferences1Click(Sender: TObject); +procedure RescaleMenuClick(Sender: TObject); +procedure Resliceimage1Click(Sender: TObject); +procedure SaveasNIfTI1Click(Sender: TObject); +procedure SaveDialog1Close(Sender: TObject); +procedure UpdateColorSchemes; + procedure UpdateTemplates; + procedure UpdateMRU; + procedure UpdateStatusLabel; + procedure Exit1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure DisplayHdrClick(Sender: TObject); + procedure Open1Click(Sender: TObject); + procedure ToolSelectClick(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + function OpenAndDisplayImg(var lFilename: string; lAdd2MRU: boolean): boolean; + procedure OpenTemplateMRU(Sender: TObject); + procedure XViewEditChange(Sender: TObject); + procedure ReadIniFile; //read init file values + procedure WriteIniFile; + {$IFNDEF FPC} + procedure FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} + procedure FormClose(Sender: TObject); + + {$ENDIF} + procedure MagnifyTimerTimer(Sender: TObject); + procedure MagnifyPanelResize(Sender: TObject); + procedure PGImageMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); + procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure PGImageMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure PGImageMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure LUTdropLoad(var lLayer: integer); + procedure LUTdropSelect(Sender: TObject); + procedure ZoomDropChange(Sender: TObject); + procedure ZoomDropSelect(Sender: TObject); + procedure ColorBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Saveaspicture1Click(Sender: TObject); + procedure XBarBtnClick(Sender: TObject); + procedure XBarBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure XBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure AutoContrastBtnClick(Sender: TObject); + procedure RefreshImagesTimerTimer(Sender: TObject); + procedure MinContrastWindowEditChange(Sender: TObject); + procedure ImgPanelClick(Sender: TObject); + procedure MagnifyMenuItemClick(Sender: TObject); + procedure CloseImagesClick(Sender: TObject); + procedure UpdateLayerMenu; + procedure OverlayOpenCore (var lFilename: string; lOverlayNum: integer); + procedure OverlayOpenClick(Sender: TObject); + procedure CloseOverlayImgClick(Sender: TObject); + procedure BGtrans100Click(Sender: TObject); + procedure OverlayTransClick(Sender: TObject); + procedure LayerDropSelect(Sender: TObject); + procedure OverlaySmoothMenuClick(Sender: TObject); + procedure MaxContrastWindowEditChange(Sender: TObject); + procedure ShowRenderClick(Sender: TObject); + procedure PenBtnClick(Sender: TObject); + procedure OpenVOIClick(Sender: TObject); + procedure OpenVOICore(var lFilename : string); + procedure SaveVOIClick(Sender: TObject); + procedure VOIColorClick(Sender: TObject); + procedure CloseVOIClick(Sender: TObject); + procedure SetDimension8(lInPGHt,lInPGWid:integer; lBuff: ByteP; lUndoOnly: boolean); + procedure Undo1Click(Sender: TObject); + procedure Paste1Click(Sender: TObject); + procedure HideROIBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure HideROIBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure XBarColor; + procedure Applyintensityfiltertovolume1Click(Sender: TObject); + procedure Quicksmooth1Click(Sender: TObject); + procedure VOImaskClick(Sender: TObject); + procedure Sagittal1Click(Sender: TObject); + procedure ROIcomparisonClick(Sender: TObject); + procedure RescaleImagesTimerTimer(Sender: TObject); + procedure Fill3DBtnClick(Sender: TObject); + procedure SmoothVOI1Click(Sender: TObject); + procedure CreateOverlap(Sender: TObject); + procedure Chisquare1Click(Sender: TObject); + procedure ROIVOI1Click(Sender: TObject); + procedure LUTinvertBtnClick(Sender: TObject); + procedure LutFromZeroBtnClick(Sender: TObject); + procedure ShowMultisliceClick(Sender: TObject); + procedure DescriptiveMenuItemClick(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure OnLaunch; + procedure FlipLRmenuClick(Sender: TObject); + procedure Menu2DSmoothClick(Sender: TObject); + procedure VALclick(Sender: TObject); + procedure VOI2NIIClick(Sender: TObject); + procedure TtoP1Click(Sender: TObject); + procedure DesignVALClick(Sender: TObject); + procedure Up1Click(Sender: TObject); + procedure SetShareMem (lXmm,lYmm,lZmm: single); + procedure CreateShareMem; + procedure CloseShareMem; + procedure YokeTimerTimer(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure YokeMenuClick(Sender: TObject); + procedure DefaultControlPanel; + procedure ControlPanelDblClick(Sender: TObject); + procedure ResizeControlPanel (lRows: integer); + procedure SaveOrCopyImages(lCopy: boolean); + function ImgIntensityString(var lHdr: TMRIcroHdr; lVox: integer): string; overload; + function ImgIntensityString(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): string; overload; + private + { Private declarations } + +{$IFDEF FPC} function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;MousePos: TPoint): Boolean; override;{$ENDIF} + public + + + { Public declarations } +public + //procedure WMSysCommand (var Msg: TWMSysCommand) ; message WM_SYSCOMMAND; + published + property OnMouseWheel; + end; + +const + kYokeItems= 12; + knMRU = 12;//max items in most recently used list + knMaxOverlay = 20; + kVOIOverlayNum = knMaxOverlay; + kBGOverlayNum = 0; + knAutoLUT = 7; + kVOIFilter = 'Volume of interest (*.voi)|*.voi|MRIcro ROI (*.roi)|*.roi|'+kImgFilter; +var + gYoke: boolean = false; + ImgForm: TImgForm; + gBGImg: TBGImg; + gMRIcroOverlay: array [0..knMaxOverlay] of TMRIcroHdr; + gColorSchemeDir,gTemplateDir: String; + gMRUstr: array [0..knMRU] of String; //most recently used files + gMouseDownX,gMouseDownY: integer; + gSelectOrigin: TPoint; + gSelectRect: TRect; + gOrigBGTransPct : integer= 50; + //gMaxCPUThreads : integer = 8; + gnCPUThreads : integer = 1; + gUndoImg,gDrawImg: Tfx8; + +Type + SingleArr = Array[1..kYokeItems] Of Single; + SingleArrPtr = ^SingleArr; + +implementation + +uses statclustertable,batch,imgutil, reslice_fsl,render,ROIfilt,autoroi, MultiSlice, Text, histoform, + about,clustering,ReadFloat; + +{$IFDEF FPC} +{$R *.lfm} +{$ELSE} +{$R *.DFM} +{$ENDIF} +procedure TImgForm.XBarColor; +begin + ColorDialog1.Color := gBGImg.XBarClr; + if not ColorDialog1.Execute then exit; + gBGImg.XBarClr := ColorDialog1.Color; + RefreshImagesTimer.Enabled := true; + exit; +end; + + +procedure DecViewEdit(var lEdit: TSpinEdit); +begin + if lEdit.Value > 1 then + lEdit.value := lEdit.value -1 + else + lEdit.Value := lEdit.MaxValue; + {$IFDEF FPC} ImgForm.XViewEditChange(nil); {$ENDIF} +end; //DecViewEdit + +procedure IncViewEdit(var lEdit: TSpinEdit); +begin + if lEdit.Value < lEdit.MaxValue then + lEdit.value := lEdit.value +1 + else + lEdit.Value := 1; + {$IFDEF FPC} ImgForm.XViewEditChange(nil); {$ENDIF} +end; //IncViewEdit + + +function TImgForm.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; + MousePos: TPoint): Boolean; +begin + if WheelDelta = 0 then exit; + Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos); + //ImgForm.Caption := inttostr(random(888)); + //... actions after a possible OnMouseWheel[Down|Up] + //ImgForm.Caption := inttostr(WheelDelta)+' '+inttostr(random(888))+' '+inttostr(MousePos.X); + if WheelDelta < 0 then begin + Case SelectedImageNum of + 3: DecViewEdit(YViewEdit); + 2: DecViewEdit(XViewEdit); + else DecViewEdit(ZViewEdit); + end; + end else begin + Case SelectedImageNum of + 3: IncViewEdit(YViewEdit); + 2: IncViewEdit(XViewEdit); + else IncViewEdit(ZViewEdit); + end; + end; +end; + + + +procedure TImgForm.CloseShareMem; +begin +{$IFDEF COMPILEYOKE} +YokeTimer.Enabled := false; + CloseSharedMem; +{$ENDIF} +end; + +procedure TImgForm.SetShareMem (lXmm,lYmm,lZmm: single); +begin +{$IFDEF COMPILEYOKE} + if not gYoke then + exit; + SetShareFloats(lXmm,lYmm,lZmm); + +{$ENDIF} +end; + +procedure TImgForm.CreateShareMem; +begin + {$IFDEF COMPILEYOKE} + CreateSharedMem(self); + SetShareMem (0,0,0); + YokeTimer.Enabled := gYoke; + {$ENDIF} +end; + +procedure TImgForm.YokeTimerTimer(Sender: TObject); +var + lX,lY,lZ: integer; + lXmm,lYmm,lZmm: single; +begin + if not gYoke then + YokeTimer.Enabled := false; + {$IFDEF COMPILEYOKE} + //labelx.caption := inttostr(random(888)); + if not gYoke then + exit; + //LabelX.caption := inttostr(random(888)); + if not GetShareFloats(lXmm,lYmm,lZmm) then + exit; + //LabelY.caption := inttostr(random(888)); + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> XViewEdit.value then XViewEdit.value := lX; + if lY <> YViewEdit.value then YViewEdit.value := lY; + if lZ <> ZViewEdit.value then ZViewEdit.value := lZ; + XViewEditChange(nil); + + {$ENDIF} +end; + +(*var +lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if not gYoke then begin + YokeTimer.Enabled := false; + exit; + end; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; +{$IFDEF FPC} + {$IFDEF COMPILEYOKE} + lXmm:=gShareIntBuf^[1]; + lYmm:=gShareIntBuf^[2]; + lZmm:=gShareIntBuf^[3]; + {$ELSE} + YokeTimer.Enabled := false; + exit; + {$ENDIF} + +{$ELSE} + EMemMap.EnterCriticalSection; + Try + lXmm:=SingleArrPtr(EMemMap.MemMap)^[1]; + lYmm:=SingleArrPtr(EMemMap.MemMap)^[2]; + lZmm:=SingleArrPtr(EMemMap.MemMap)^[3]; + Finally + EMemMap.LeaveCriticalSection; + end; +{$ENDIF} + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> XViewEdit.value then XViewEdit.value := lX; + if lY <> YViewEdit.value then YViewEdit.value := lY; + if lZ <> ZViewEdit.value then ZViewEdit.value := lZ; + YokeTimer.Enabled := false; +end; *) + +{$IFNDEF FPC} +procedure TImgForm.WMSysCommand; +begin + if (Msg.CmdType = SC_MINIMIZE) then + Application.Minimize + else + DefaultHandler(Msg) ; + if (Msg.CmdType = SC_MAXIMIZE) then RefreshImagesTimer.enabled := true; +end; +{$ENDIF} + +function SelectedImagePanel: TScrollBox; +begin + case SelectedImageNum of + 3: result := ImgForm.TriplePanel; + 2: result := ImgForm.TriplePanel; + else result := ImgForm.TriplePanel; + end; +end; + +function DrawToolSelected: boolean; +begin + if ( ImgForm.PenBtn.Down) or ( ImgForm.ClosedPenBtn.Down) or (ImgForm.FillBtn.Down) or (ImgForm.EllipseBtn.Down) then + result := true + else + result := false; +end; + +procedure TImgForm.WriteIniFile; +var + lInc: integer; + lIni: string; + lIniFile: TIniFile; +begin + lIni:= IniName; + if (DiskFreeEx(lIni) < 1) or (not gBGIMg.SaveDefaultIni) then + exit; + //lIniFile := TIniFile.Create(changefileext(paramstr(0),'.ini')); + lIniFile := TIniFile.Create(lIni);//DefaultsDir('')+ParseFileName(extractfilename(paramstr(0)))+'.ini'); + //recent files + lIniFile.WriteString('MRU', 'file0', gMRIcroOverlay[kBGOverlayNum].HdrFilename); + for lInc := 1 to knMRU do + lIniFile.WriteString('MRU', 'file'+inttostr(lInc), gMRUstr[lINc]); + //STR + //lIniFile.WriteString('STR', 'FSLDIR',gBGImg.FSLDIR); + //lIniFile.WriteString('STR', 'FSLBETEXE',gBGImg.FSLBETEXE); + lIniFile.WriteString('STR', 'FSLBASE',gBGImg.FSLBASE); + lIniFile.WriteString('STR', 'FSLOUTPUTTYPE',gBGImg.FSLOUTPUTTYPE); + //Booleans + lIniFile.WriteString('BOOL', 'Reslice',Bool2Char(gBGImg.ResliceOnLoad)); + lIniFile.WriteString('BOOL', 'ResliceOrtho',Bool2Char(gBGImg.OrthoReslice)); + lIniFile.WriteString('BOOL', 'ShowDraw',Bool2Char(gBGImg.ShowDraw)); + lIniFile.WriteString('BOOL', 'ThinPen',Bool2Char(gBGImg.ThinPen)); + + lIniFile.WriteString('BOOL', 'Smooth2D',Bool2Char(Menu2DSmooth.checked)); + lIniFile.WriteString('BOOL', 'XBar',Bool2Char(XBarBtn.Down)); + lIniFile.WriteString('BOOL', 'OverlaySmooth',Bool2Char(OverlaySmoothMenu.Checked)); + lIniFile.WriteString('BOOL', 'LRmirror',Bool2Char(gBGImg.Mirror)); + lIniFile.WriteString('BOOL', 'Yoke',Bool2Char(gYoke)); + lIniFile.WriteString('BOOL', 'SingleRow',Bool2Char(gBGImg.SingleRow)); + lIniFile.WriteString('BOOL', 'FlipAx',Bool2Char(gBGImg.FlipAx)); + lIniFile.WriteString('BOOL', 'FlipSag',Bool2Char(gBGImg.FlipSag)); + YokeTimer.Enabled := gYoke; + //Integers + //lIniFile.WriteString('INT', 'ResizeBeforeRescale',IntToStr(gBGImg.ResizeBeforeRescale)); + lIniFile.WriteString('INT', 'FontSize',IntToStr(gBGImg.FontSize)); + lIniFile.WriteString('INT', 'SaveImgFilter',IntToStr(gBGImg.SaveImgFilter)); + lIniFile.WriteString('INT', 'SaveVoiFilter',IntToStr(gBGImg.SaveVoiFilter)); + lIniFile.WriteString('INT', 'PlanarRGB',IntToStr(gBGImg.PlanarRGB)); + + lIniFile.WriteString('INT', 'MaxDim',IntToStr(gBGImg.MaxDim)); + lIniFile.WriteString('INT', 'LicenseID',IntToStr(gBGImg.LicenseID)); + lIniFile.WriteString('INT', 'Zoom',IntToStr(ZoomDrop.ItemIndex)); + lIniFile.WriteString('INT', 'LUT',IntToStr(gMRIcroOverlay[kBGOverlayNum].LUTindex)); + lIniFile.WriteString('INT', 'XBarGap',IntToStr(gBGImg.XBarGap)); + lIniFile.WriteString('INT', 'XBarThick',IntToStr(gBGImg.XBarThick)); + lIniFile.WriteString('INT', 'XBarClr',IntToStr(gBGIMg.XBarClr)); + lIniFile.WriteString('INT', 'VOIClr',IntToStr(gBGIMg.VOIClr)); + if (gBGImg.BGTransPct < 0) or (gBGImg.BGTransPct > 90) then + gBGImg.BGTransPct := 20; //additive or transparent values can confuse users + if (gBGImg.OverlayTransPct < 0) or (gBGImg.OverlayTransPct > 90) then + gBGImg.OverlayTransPct := 20; //additive or transparent values can confuse users + lIniFile.WriteString('INT', 'BGTransPct',IntToStr(gBGImg.BGTransPct)); + lIniFile.WriteString('INT', 'OverlayTransPct',IntToStr(gBGImg.OverlayTransPct)); + lIniFile.WriteString('INT','MaxThreads',IntToStr(gnCPUThreads)); + + lIniFile.WriteString('INT', 'LesionDilate',IntToStr(gBGImg.LesionDilate)); + lIniFile.WriteString('INT', 'LesionSmooth',IntToStr(gBGImg.LesionSmooth)); +// {$ELSE} +// lIniFile.WriteString('INT', 'MaxThreads',IntToStr(gMaxCPUThreads)); +// {$ENDIF} + lIniFile.WriteString('INT', 'SigDigits',IntToStr(gBGImg.SigDig)); + lIniFile.WriteString('INT', 'ImageSeparation',IntToStr(gBGImg.ImageSeparation)); + + + lIniFile.WriteString('INT', 'SPMDefaultsStatsFmriT',IntToStr(gBGImg.SPMDefaultsStatsFmriT)); + lIniFile.WriteString('INT', 'SPMDefaultsStatsFmriT0',IntToStr(gBGImg.SPMDefaultsStatsFmriT0)); + + lIniFile.Free; +end; +(* +function registerfiletype(inft,inkey,desc,icon:string): boolean; +var myreg : treginifile; + ct : integer; + ft,key: string; +begin + result := true; + ft := inft; + key := inkey; + ct := pos('.',ft); + while ct > 0 do begin + delete(ft,ct,1); + ct := pos('.',ft); + end; + if (ft = '') or (Application.ExeName = '') then exit; //not a valid file-ext or ass. app + ft := '.'+ft; + myreg := treginifile.create(''); + try + myreg.rootkey := hkey_classes_root; // where all file-types are described + if key = '' then key := copy(ft,2,maxint)+'_auto_file'; // if no key-name is given, create one + myreg.writestring(ft,'',key); // set a pointer to the description-key + myreg.writestring(key,'',desc); // write the description + myreg.writestring(key+'\DefaultIcon','',icon); // write the def-icon if given + myreg.writestring(key+'\shell\open\command','',Application.ExeName+' %1'); //association + except + result := false; + showmessage('Only administrators can change file associations. You are currently logged in as a restricted user.'); + end; + myreg.free; +end; *) + +procedure WriteIni2Form (lBGImg: TBGImg); +begin + ImgForm.ToolPanel.Visible := lBGImg.ShowDraw; + ImgForm.DrawMenu.Visible := lBGImg.ShowDraw; + ImgForm.DrawHiddenMenu.Visible := not lBGImg.ShowDraw; +end; + +procedure TImgForm.SetIniMenus; +begin + XBarBtn.Down := gBGImg.XBarVisible; + YokeMenu.Checked := gYoke; + if (gBGImg.StretchQuality = sqLow) then + Menu2DSmooth.checked := false + else begin + Menu2DSmooth.checked := true; + gBGImg.StretchQuality := sqHigh; + end; + //Menu2DSmoothClick(nil);//set quality +end; + +procedure TImgForm.ReadIniFile; +var + lInc,lFilenum: integer; + lFilename: string; + lIniFile: TIniFile; +begin + //lFilename := changefileext(paramstr(0),'.ini'); + + lFilename := ininame;//DefaultsDir('')+ParseFileName(extractfilename(paramstr(0)))+'.ini'; + if not FileexistsEx(lFilename) then begin + //DrawMenu.Visible := ToolPanel.visible; + WriteIni2Form(gBGImg); + exit; + end; + lIniFile := TIniFile.Create(lFilename); + gMRUstr[0] := lIniFile.ReadString('MRU', 'file0', '');//file0 - last file viewed + lFileNum := 0; + for lInc := 1 to knMRU do begin + lFilename := lIniFile.ReadString('MRU', 'file'+inttostr(lInc), ''); + if (length(lFilename) > 0) and (fileexistsex(lFilename)) then begin + Inc(lFileNum); + gMRUstr[lFileNum] := lFilename; + end; + end; + gBGImg.FSLOUTPUTTYPE := lIniFile.ReadString('STR', 'FSLOUTPUTTYPE', gBGImg.FSLOUTPUTTYPE); + //gBGImg.FSLDIR := lIniFile.ReadString('STR', 'FSLDIR', gBGImg.FSLDIR); + //gBGImg.FSLBETEXE := lIniFile.ReadString('STR', 'FSLBETEXE', gBGImg.FSLBETEXE); + gBGImg.FSLBASE := lIniFile.ReadString('STR', 'FSLBASE', gBGImg.FSLBASE); + + gBGImg.ResliceOnLoad := IniBool(lIniFile,'Reslice',gBGImg.ResliceOnLoad); + gBGImg.OrthoReslice := IniBool(lIniFile,'ResliceOrtho',gBGImg.OrthoReslice); + gBGImg.ThinPen := IniBool(lIniFile, 'ThinPen',True); + + gBGImg.ShowDraw := IniBool(lIniFile, 'ShowDraw',gBGImg.ShowDraw); + WriteIni2Form(gBGImg); + if IniBool(lIniFile,'Smooth2D',Menu2DSmooth.checked) then + gBGImg.StretchQuality := sqHigh + else + gBGImg.StretchQuality := sqLow; + //Menu2DSmooth.checked := IniBool(lIniFile,'Smooth2D',Menu2DSmooth.checked); + Menu2DSmoothClick(nil);//set quality + gBGImg.XBarVisible := IniBool(lIniFile,'XBar',XBarBtn.Down); + gBGImg.OverlaySmooth := IniBool(lIniFile,'OverlaySmooth',gBGImg.OverlaySmooth); + OverlaySmoothMenu.Checked := gBGImg.OverlaySmooth; + gBGImg.Mirror := IniBool(lIniFile,'LRmirror',gBGImg.Mirror); + FlipLRmenu.Checked := gBGImg.Mirror; + gYoke := IniBool(lIniFile,'Yoke',gYoke); + gBGImg.SingleRow := IniBool(lIniFile,'SingleRow',gBGImg.SingleRow); + gBGImg.FlipAx := IniBool(lIniFile,'FlipAx',gBGImg.FlipAx); + gBGImg.FlipSag := IniBool(lIniFile,'FlipSag',gBGImg.FlipSag); + gBGImg.MaxDim := IniInt(lIniFile,'MaxDim',gBGImg.MaxDim); + gBGImg.PlanarRGB := IniInt(lIniFile,'PlanarRGB',gBGImg.PlanarRGB); + + gBGImg.LicenseID := IniInt(lIniFile,'LicenseID',gBGImg.LicenseID); +{$IFNDEF FPC} + ZoomDrop.SetItemIndex(IniInt(lIniFile,'Zoom',ZoomDrop.ItemIndex)); + LUTDrop.SetItemIndex(IniInt(lIniFile,'LUT',LUTDrop.ItemIndex)); +{$ELSE} + ZoomDrop.ItemIndex := (IniInt(lIniFile,'Zoom',ZoomDrop.ItemIndex)); + LUTDrop.ItemIndex:= (IniInt(lIniFile,'LUT',LUTDrop.ItemIndex)); +{$ENDIF} + gBGImg.XBarGap := IniInt(lIniFile,'XBarGap',gBGImg.XBarGap); + gBGImg.XBarThick := IniInt(lIniFile,'XBarThick',gBGImg.XBarThick); + gBGImg.XBarClr := IniInt(lIniFile,'XBarClr',gBGImg.XBarClr); + gBGImg.VOIClr := IniInt(lIniFile,'VOIClr',gBGImg.VOIClr); + gBGImg.BGTransPct := IniInt(lIniFile,'BGTransPct',gBGImg.BGTransPct); + gBGImg.OverlayTransPct := IniInt(lIniFile,'OverlayTransPct',gBGImg.OverlayTransPct); + gnCPUThreads := IniInt(lIniFile,'MaxThreads',gnCPUThreads); + gBGImg.SigDig := IniInt(lIniFile,'SigDigits',gBGImg.SigDig); + gBGImg.ImageSeparation := IniInt(lIniFile,'ImageSeparation',gBGImg.ImageSeparation); + gBGImg.FontSize := IniInt(lIniFile,'FontSize',gBGImg.FontSize); + gBGImg.SaveImgFilter := IniInt(lIniFile,'SaveImgFilter',gBGImg.SaveImgFilter); + gBGImg.SaveVoiFilter := IniInt(lIniFile,'SaveVoiFilter',gBGImg.SaveVoiFilter); + gBGImg.SPMDefaultsStatsFmriT := IniInt(lIniFile,'SPMDefaultsStatsFmriT',gBGImg.SPMDefaultsStatsFmriT); + gBGImg.SPMDefaultsStatsFmriT0 := IniInt(lIniFile,'SPMDefaultsStatsFmriT0',gBGImg.SPMDefaultsStatsFmriT0); + gBGImg.LesionSmooth := IniInt(lIniFile,'LesionSmooth',gBGImg.LesionSmooth); + gBGImg.LesionDilate := IniInt(lIniFile,'LesionDilate',gBGImg.LesionDilate); + + + + SetSubmenuWithTag(BGTransPctMenu, gBGImg.BGTransPct); + SetSubmenuWithTag(OverlayTransPctMenu, gBGImg.OverlayTransPct); + lIniFile.Free; + +end; //ReadIniFile + +//lStrings := TStringList.Create; + + +procedure TImgForm.UpdateColorSchemes; +var + lSearchRec: TSearchRec; + lStrings : TStringList; +begin + LUTdrop.Items.Clear; + LUTdrop.Items.Add('Grayscale'); + LUTdrop.Items.Add('Red'); + LUTdrop.Items.Add('Blue'); + LUTdrop.Items.Add('Green'); + LUTdrop.Items.Add('Violet [r+b]'); + LUTdrop.Items.Add('Yellow [r+g]'); + LUTdrop.Items.Add('Cyan [g+b]'); + lStrings := TStringList.Create; + if FindFirst(gColorSchemeDir+pathdelim+'*.lut', faAnyFile, lSearchRec) = 0 then + repeat + lStrings.Add(ParseFileName(ExtractFileName(lSearchRec.Name))); + //LUTdrop.Items.Add(ParseFileName(ExtractFileName(lSearchRec.Name))); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); + lStrings.Sort; + LUTdrop.Items.AddStrings(lStrings); + lStrings.Free; + //LUTDrop.DropDownCount := 66;//LUTDrop.Items.Count; +end;//UpdateColorSchemes + +(*procedure TImgForm.UpdateColorSchemes; +var + lSearchRec: TSearchRec; +begin + LUTdrop.Items.Clear; + LUTdrop.Items.Add('Grayscale'); + LUTdrop.Items.Add('Red'); + LUTdrop.Items.Add('Blue'); + LUTdrop.Items.Add('Green'); + LUTdrop.Items.Add('Violet [r+b]'); + LUTdrop.Items.Add('Yellow [r+g]'); + LUTdrop.Items.Add('Cyan [g+b]'); + if FindFirst(gColorSchemeDir+pathdelim+'*.lut', faAnyFile, lSearchRec) = 0 then + repeat + LUTdrop.Items.Add(ParseFileName(ExtractFileName(lSearchRec.Name))); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); + xxx + //LUTDrop.DropDownCount := 66;//LUTDrop.Items.Count; +end;//UpdateColorSchemes +*) + +procedure TImgForm.BETmenuClick(Sender: TObject); +begin + BetForm.show; +end; + +procedure TImgForm.ApplyClusterThreshold1Click(Sender: TObject); +var + lNumberofFiles,lC,lClusterSz: integer; + lThresh: double; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + lClusterSz := ReadIntForm.GetInt('Minimum cluster size [in voxels]: ', 1,32,9999); + lThresh := ReadFloatForm.GetFloat('Include voxels with an intensity above: ', 0,2,9999); + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + //lFilename := changefileextX(lFilename,'I'+inttostr(round(lThresh))+'C'+inttostr(lClusterSz)+'.nii.gz'); + lFilename := changefileprefix(lFilename,'I'+inttostr(round(lThresh))+'C'+inttostr(lClusterSz)); + if ClusterFilterScrnImg (gMRIcroOverlay[kBGOverlayNum],lClusterSz,lThresh ) then + if ImgVaries(gMRIcroOverlay[kBGOverlayNum]) then + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr) + else + showmessage('No clusters survive filter '+ HdrForm.OpenHdrDlg.Files[lC-1]); + ProgressBar1.Position := lC; + end; + if fileexistsEX(lFilename) then + ImgForm.OpenAndDisplayImg(lFilename,True); + ProgressBar1.Position := 0; +end; + +procedure TImgForm.C(Sender: TObject); +begin + +end; + +procedure TImgForm.CropMenuClick(Sender: TObject); +begin + CropEdgeForm.Show; +end; + +procedure TImgForm.ExportasRGBAnalyzeimage1Click(Sender: TObject); +var + lFlip: boolean; +begin + lFlip := gBGImg.Mirror; + gBGImg.Mirror := true; + CreateAnaRGB; + gBGImg.Mirror := lFlip; +end; + +procedure TImgForm.FormDropFiles(Sender: TObject; const FileNames: array of String); +var + lFilename: string; +begin + if length(FileNames) < 1 then + exit; + lFilename := Filenames[0]; + OpenAndDisplayImg(lFilename,true); +end; + +procedure TImgForm.FormKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + //ImgForm.caption := inttostr(Key); + if (XViewEdit.focused) or (YViewEdit.focused) or (ZViewEdit.focused) or (MinWindowEdit.focused) or (MaxWindowEdit.focused) then + exit; + Case Key of + 36: DecViewEdit(YViewEdit); + 35: IncViewEdit(YViewEdit); + 37: DecViewEdit(XViewEdit); + 38: IncViewEdit(ZViewEdit); + 39: IncViewEdit(XViewEdit); + 40: DecViewEdit(ZViewEdit); + + end; //case Key + (* if WheelDelta < 0 then begin + Case SelectedImageNum of + 3: DecViewEdit(YViewEdit); + 2: DecViewEdit(XViewEdit); + else DecViewEdit(ZViewEdit); + end; + end else begin + Case SelectedImageNum of + 3: IncViewEdit(YViewEdit); + 2: IncViewEdit(XViewEdit); + else IncViewEdit(ZViewEdit); + end; + end;*) +end; + +procedure TImgForm.FormKeyPress(Sender: TObject; var Key: char); +begin + //imgform.caption := 'zzz'; +end; + + + +procedure TImgForm.Header1Click(Sender: TObject); +begin + DisplayHdrClick(nil); +end; + + +function ActiveLayer:integer; +begin + result := ImgForm.LayerDrop.ItemIndex; + if result < 0 then + result := 0; +end; + +{$DEFINE noTEST} + +{$IFDEF TEST} +procedure DrawBMP2( lx, ly: integer; var lBuff: RGBQuadp; var lImage: TImage); +//uses GraphType, IntfGraphics +var + IntfImage: TLazIntfImage; + ScanLineImage: TLazIntfImage; + ImgFormatDescription: TRawImageDescription; + lBitmap: TBitmap; +begin + lBitmap:=TBitmap.Create; + ScanLineImage:=TLazIntfImage.Create(0,0); + ImgFormatDescription.Init_BPP32_B8G8R8_BIO_TTB(lx,ly); + ScanLineImage.DataDescription:=ImgFormatDescription; + // call the pf24bit specific drawing function + Move(lBuff^[1],PByte(ScanLineImage.GetDataLineStart(0))[1],lx*ly*sizeof(TRGBquad) ); + lBitmap.Width:=ScanLineImage.Width; + lBitmap.Height:=ScanLineImage.Height; + IntfImage:=lBitmap.CreateIntfImage; + // convert the content from the very specific to the current format + IntfImage.CopyPixels(ScanLineImage); + lBitmap.LoadFromIntfImage(IntfImage); + ScanLineImage.Free; + IntfImage.Free; + lImage.Picture.Bitmap := lBitmap; + lBitmap.Free; +end; + +procedure FZ; +var + l2Time,lTime: DWord; + y,x,lx, ly, lpos: integer; + lBuff: RGBQuadp ; +begin + lx := 320; + ly := 320; + getmem(lBuff,(lx*ly)*sizeof( TRGBquad)); + lpos := 0; + for y := 1 to ly do begin + for x := 1 to lx do begin + inc(lpos); + lBuff^[lpos].rgbblue := (y mod 255); + lBuff^[lpos].rgbgreen :=(y mod 255); + lBuff^[lpos].rgbred := (x mod 255) ; + lBuff^[lpos].rgbreserved := 0; + end; + end; + l2Time := GetTickCount; + for y := 1 to 100 do + DrawBMP2( lx, ly, lBuff,HistogramForm.HistoImage{lImage}); + l2Time := GetTickCount - l2Time; + lTime := GetTickCount; + for y := 1 to 100 do + DrawBMP( lx, ly, lBuff,HistogramForm.HistoImage{lImage}); + lTime := GetTickCount - lTime; + HistogramForm.Caption := inttostr(lTime)+' '+inttostr(l2Time); + freemem(lBuff); +end; +{$ENDIF} + +procedure TImgForm.HistoMenuClick(Sender: TObject); +VAR + lLayer: integer; +begin + {$IFDEF TEST} + FZ; + {$ELSE} + lLayer := ActiveLayer; + DrawHistogram(gMRIcroOverlay[lLayer],HistogramForm.HistoImage{lImage}); + HistogramForm.Caption := 'Histogram: '+extractfilename(gMRIcroOverlay[lLayer].HdrFileName); + {$ENDIF} + HistogramForm.show; + //HistogramForm.BringToFront; +end; + + + +procedure TImgForm.MNIMenuClick(Sender: TObject); +begin + MNIForm.show; + //MNIForm.BringToFront; + +end; + +procedure TImgForm.N4DTraces1Click(Sender: TObject); +begin + Graph4DForm.show; + //Graph4DForm.BringToFront; +end; + +procedure TImgForm.NIIVOIClick(Sender: TObject); + var + lNumberofFiles,lC: integer; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter {10/2007},'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileextx(lFilename,'.voi'); ////Xversion 10/2007 - removes .nii.gz not just gz + //SaveAsVOIorNIFTIcore (lFilename, lByteP, lVoxels, 1, gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; + +end; + + +procedure TImgForm.PGImageCorDblClick(Sender: TObject); +begin + if Graph4DForm.visible then + Graph4DForm.RefreshBtn.click; +end; + +procedure TImgForm.Preferences1Click(Sender: TObject); +begin + PrefForm.ShowModal; +end; + +function RescaleImg( lRescaleIntercept,lRescaleSlope: double): boolean; +var + //lRow,lNumberofFiles,lX,lY,lZ: integer; + //lFilename: string; + lHdr:TMRIcroHdr; + lImgSamples,lInc,lBPP: integer; + l32Buf,lo32Buf : SingleP; + l16Buf : SmallIntP; +begin + //note ignores input slope/intercept scaling values + result := false; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + if ((gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2] * gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then begin + showmessage('Unable to rescale.'); + exit; + end; + lBPP := gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP;//check if BitsPerPixel is supported + if (lBPP <> 4) and (lBPP <> 2) and (lBPP <> 1) then begin + showmessage('RescaleImg Error: Unsupported BPP: '+inttostr(lBPP)); + exit; + end; + lImgSamples := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lHdr,0{min}, 0{max},0{p1},0{p2},0{p3},kNIFTI_INTENT_NONE,floattostr(lRescaleSlope) ); + GetMem(lHdr.ImgBufferUnaligned ,(lImgSamples*4)+16); + //svn lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBuffer := align(lHdr.ImgBufferUnaligned, 16); + lo32Buf := SingleP( lHdr.ImgBuffer ); + if lBPP = 4 then begin + l32Buf := SingleP( gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lInc := 1 to lImgSamples do + lo32Buf^[lInc] := (l32Buf^[lInc]+lRescaleIntercept) * lRescaleSlope; + end else if lBPP = 2 then begin //lBPP=4 else + l16Buf := SmallIntP( gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lInc := 1 to lImgSamples do + lo32Buf^[lInc] := (l16Buf^[lInc]+lRescaleIntercept) * lRescaleSlope; + end else if lBPP = 1 then begin //lBPP=2 else + for lInc := 1 to lImgSamples do + lo32Buf^[lInc] := (gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lInc]+lRescaleIntercept) * lRescaleSlope; + end;//lBPP = 1 + SaveAsVOIorNIFTI(bytep(lo32Buf),lImgSamples,4,1,false,lHdr.NiftiHdr,'rscl'+extractfilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename)); + //SaveAsVOIorNIFTI(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); + FreeMem(lHdr.ImgBufferUnaligned); + //lFilename := 'c:\striped2.hdr'; + //SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + result := true; +end; + + +procedure TImgForm.RescaleMenuClick(Sender: TObject); +var ldTE,lScale,lTE1,lTE2: double; + //lStr: string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + if gBGImg.Resliced then begin + if not HdrForm.OpenAndDisplayHdr(gMRIcroOverlay[kBGOverlayNum].HdrFileName,gMRIcroOverlay[kBGOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false) then exit; + end; + if (gMRIcroOverlay[kBGOverlayNum].GlMinUnscaledS < 0) or (gMRIcroOverlay[kBGOverlayNum].GlMaxUnscaledS > 4096) then begin + showmessage('Error: you need to load a Siemens format Phase map with raw values in the range 0..4096'); + exit; + end; + lTE1 := ReadFloatForm.GetFloat('Please enter the first TE (ms) used for phasemap. ', 0,5.19,9999); + lTE2 := ReadFloatForm.GetFloat('Please enter the second TE (ms) used for phasemap. ', 0,7.65,9999); + + (*lStr := floattostr(5.19); //use floattostr for local decimal separator + if not InputQuery('TEs used to create phasemap','Please enter the first TE in ms', lStr) then + exit; + try + lTE1 := strtofloat(lStr); + except + showmessage('Unable to convert the string '+lStr+' to a number'); + exit; + end; + lStr := floattostr(7.65); + if not InputQuery('TEs used to create phasemap','Please enter the second TE in ms', lStr) then + exit; + try + lTE2 := strtofloat(lStr); + except + showmessage('Unable to convert the string '+lStr+' to a number'); + exit; + end;*) + if lTE1 = lTE2 then begin + showmessage('In order to compute Rad/S the two TEs must be different.'); + exit; + end; + //fx(lTE1,lTE2); + //exit; +//the fieldmap is simply a phase +//difference image and is not scaled to any particular units. In Siemens +//phase images the data goes from 0 to 4095 with 0 being -pi radians, 2048 +//is 0 radians, and 4095 is just short of +pi radians. + //So, to get units of radians/s you would need to know the difference in + //echo times (dTE) in units of s (not ms). You would then take + //(x-2048)(2pi/4096)/dTE +//Note ignore original intercept and scale values + //ldTE := abs(5.19 - 7.65)/1000; // div 1000 to scale ms to sec + ldTE := abs(lTE1 - lTE2)/1000; // div 1000 to scale ms to sec + lScale := (2*pi/4096)/ldTE; + //showmessage(floattostr(lScale)); + rescaleImg(-2048,lScale); +end; + +procedure TImgForm.Resliceimage1Click(Sender: TObject); +begin + ResliceFSL; +end; + +procedure TImgForm.SaveasNIfTI1Click(Sender: TObject); + var + lLayer: integer; +begin + //if not SaveDialog2.Execute then exit; + lLayer := ActiveLayer; + if gMRIcroOverlay[lLayer].ImgBufferItems=0 then begin + Showmessage('You must load an image [File/Open] before you can save the image.'); + exit; + end; + if (not IsNifTiMagic(gMRIcroOverlay[lLayer].niftiHdr)) then + Showmessage('Warning: image will be saved with NIfTI spatial transform - ensure this image matches the orientation of the template images.'); + SaveAsVOIorNIFTI(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); +end; + +procedure ApplySaveDlgFilter (lSaveDlg: TSaveDialog); +var + lLen,lPos,lPipes,lPipesReq: integer; + lExt,lName: string; +begin + lPipesReq := (lSaveDlg.FilterIndex * 2)-1; + if lPipesReq < 1 then exit; + lLen := length(lSaveDlg.Filter); + lPos := 1; + lPipes := 0; + while (lPos < lLen) and (lPipes < lPipesReq) do begin + if lSaveDlg.Filter[lPos] = '|' then + inc(lPipes); + inc(lPos); + end; + if (lPos >= lLen) or (lPipes < lPipesReq) then + exit; + lExt := ''; + while (lPos <= lLen) and (lSaveDlg.Filter[lPos] <> '|') do begin + if lSaveDlg.Filter[lPos] <> '*' then + lExt := lExt + lSaveDlg.Filter[lPos]; + inc(lPos); + end; + lName := lSaveDlg.Filename; + if lExt <> '' then + lSaveDlg.Filename := ChangeFileExtX(lName,lExt); +end; + + + +procedure TImgForm.SaveDialog1Close(Sender: TObject); +begin + ApplySaveDlgFilter(SaveDialog1); +end; + + +procedure Add2MRU (var lNewFilename: string); //add new file to most-recent list +var + lStr: string; + lPos,lN : integer; +begin + //first, increase position of all old MRUs + lN := 0; //Number of MRU files + for lPos := 1 to (knMRU) do begin//first, eliminate duplicates + lStr := gMRUstr[lPos]; + if (lStr <> '') and (lStr <> lNewFileName) then begin + inc(lN); + gMRUstr[lN] := lStr; + end; //keep in MRU list + end; //for each MRU + //next, increment positions + if lN >= knMRU then + lN := knMRU - 1; + for lPos := lN downto 1 do + gMRUstr[lPos+1] := gMRUstr[lPos]; + if (lN+2) < (knMRU) then //+1 as we have added a file + for lPos := (lN+2) to knMRU do + gMRUstr[lPos] := ''; + gMRUstr[1] := lNewFilename; + ImgForm.UpdateMRU; + ImgForm.SaveDialog1.FileName := lNewFilename; +end;//Add2MRU + +procedure TImgForm.UpdateMRU;//most-recently-used menu +var + NewItem: TMenuItem; + lPos: integer; +begin + While Recent1.Count < knMRU do begin + NewItem := TMenuItem.Create(Self); + Recent1.Add(NewItem); + end; + for lPos := 1 to knMRU do begin//for each MRU + Recent1.Items[lPos-1].Visible:=gMRUstr[lPos] <> ''; + Recent1.Items[lPos-1].Caption :=ExtractFileName(gMRUstr[lPos]); + Recent1.Items[lPos-1].Tag := lPos; + Recent1.Items[lPos-1].onclick := OpenTemplateMRU; + {$IFDEF Darwin} + Recent1.Items[lPos-1].ShortCut := ShortCut(Word('1')+ord(lPos-1), [ssMeta]); + {$ELSE} + Recent1.Items[lPos-1].ShortCut := ShortCut(Word('1')+ord(lPos-1), [ssCtrl]); + {$ENDIF} + end;//for each MRU +end; //UpdateMRU + +procedure TImgForm.UpdateTemplates; +var + NewItem: TMenuItem; + lN : integer; + lFName : String; + lSearchRec: TSearchRec; +begin + While Templates1.Count < knMRU do begin + NewItem := TMenuItem.Create(Self); + Templates1.Add(NewItem); + end; + lN := 0; + if FindFirst(gTemplateDir+pathdelim+'*.*', faAnyFile, lSearchRec) = 0 then begin + repeat + lFName := lSearchRec.Name; + + if IsNIfTIHdrExt (lFName) then begin + Templates1.Items[lN].Caption :=ExtractFileName(lFName);//(ParseFileName(ExtractFileName(lFName))); + Templates1.Items[lN].Tag := 0; + Templates1.Items[lN].visible := true; + Templates1.Items[lN].onclick := OpenTemplateMRU; + {$IFDEF Darwin} + Templates1.Items[lN].ShortCut := ShortCut(Word('1')+ord(lN), [ssMeta, ssAlt]); + {$ELSE} + Templates1.Items[lN].ShortCut := ShortCut(Word('1')+ord(lN), [ssCtrl, ssShift]); + {$ENDIF} + inc(lN); + end; + until (FindNext(lSearchRec) <> 0) or (lN >= knMRU); + end;// else + if (lN = 0) then ImgForm.Caption :=('Unable to find any files in the folder '+gTemplateDir+pathdelim); + + while lN < knMRU do begin + Templates1.Items[lN].visible := false; + inc(lN); + end; + FindClose(lSearchRec); +end;//UpdateTemplates + +(*NOT OSX 10.7 friendly... procedure TImgForm.UpdateMRU;//most-recently-used menu +var + NewItem: TMenuItem; + lPos,lN : integer; +begin + //Recent1.Clear; + //While Recent1.Count > 1 do Recent1.Delete(0); + // While Recent1.Count > 0 do Recent1.Items[0].Free; + lN := 0; + for lPos := 1 to knMRU do begin//for each MRU + if gMRUstr[lPos] <> '' then begin + inc(lN); + NewItem := TMenuItem.Create(Self); + NewItem.Caption :=ExtractFileName(gMRUstr[lPos]);//(ParseFileName(ExtractFileName(lFName))); + NewItem.Tag := lN; + {$IFDEF FPC} + NewItem.onclick := OpenTemplateMRU; //Lazarus + {$ELSE} + NewItem.onclick := OpenTemplateMRU; + {$ENDIF} + NewItem.ShortCut := ShortCut(Word('1')+ord(lN-1), [ssCtrl]); + Recent1.Add(NewItem); + end;//if mru exists + end;//for each MRU +end; //UpdateMRU + +procedure TImgForm.UpdateTemplates; +var + NewItem: TMenuItem; + lN : integer; + lFName : String; + lSearchRec: TSearchRec; +begin + While Templates1.Count > 0 do Templates1.Items[0].Free; + lN := 0; + if FindFirst(gTemplateDir+pathdelim+'*.*', faAnyFile, lSearchRec) = 0 then begin + repeat + lFName := lSearchRec.Name; + if IsNIfTIHdrExt (lFName) then begin + inc(lN); + NewItem := TMenuItem.Create(Self); + NewItem.Caption :=ExtractFileName(lFName);//(ParseFileName(ExtractFileName(lFName))); + NewItem.Tag := 0; + {$IFDEF FPC} + NewItem.onclick := OpenTemplateMRU; //Lazarus + {$ELSE} + NewItem.onclick := OpenTemplateMRU; + {$ENDIF} + if (lN+knMRU) <= 9 then + NewItem.ShortCut := ShortCut(Word('1')+knMRU+ord(lN-1), [ssCtrl]); + Templates1.Add(NewItem); + end; + until (FindNext(lSearchRec) <> 0) + end; + FindClose(lSearchRec); +end;//UpdateTemplates *) + +procedure TImgForm.OpenTemplateMRU(Sender: TObject);//open template or MRU +//Templates have tag set to 0, Most-Recently-Used items have tag set to position in gMRUstr +var + lFilename: string; +begin + if sender = nil then begin + //autolaunch with last image, or last template image in list + lFilename := gMRUstr[0]; + if (lFilename = '') or (not FileExistsEX(lFilename)) then begin + if Templates1.Count > 0 then + Templates1.Items[Templates1.Count-1].click; + exit; + end; + OpenAndDisplayImg(lFilename,true); //open but do not add templates to MRU + end else if (Sender as TMenuItem).tag = 0 then begin + lFilename := gTemplateDir+pathdelim+(Sender as TMenuItem).caption ;//+ '.hdr'; + OpenAndDisplayImg(lFilename,false); //open but do not add templates to MRU + end else if (Sender as TMenuItem).tag <= knMRU then begin + lFilename := gMRUstr[(Sender as TMenuItem).tag]; + OpenAndDisplayImg(lFilename,true); + end else + Showmessage('OpenTemplateMRU error.'); +end; + +function TImgForm.OpenAndDisplayImg(var lFilename: string; lAdd2MRU: boolean): boolean; +var + lVal: integer; +begin + Result := false; + + if (FSize(lFilename)) < 348 then exit; //to small to be a header or DICOM image + + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kBGOverlayNum]) then exit; + + + //if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + // if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,not gBGImg.ResliceOnLoad,false) then exit + //end else + if (ssCtrl in KeyDataToShiftState(vk_Shift)) and (gBGIMg.OrthoReslice) then begin + gBGIMg.OrthoReslice := false; + OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false); + gBGIMg.OrthoReslice := true; + end else if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,not gBGImg.ResliceOnLoad,false) then exit + end else + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,gBGImg.ResliceOnLoad,false) then exit; + + XViewEdit.MaxValue := gBGImg.ScrnDim[1];//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1]; + YViewEdit.MaxValue := gBGImg.ScrnDim[2];//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]; + ZViewEdit.MaxValue :=gBGImg.ScrnDim[3];// gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3]; + (*XViewEdit.Value := round(gBGImg.ScrnOri[1]);//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1] div 2; + YViewEdit.Value := round(gBGImg.ScrnOri[2]);//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]div 2; + lVal := round(gBGImg.ScrnOri[3]); + if lVal < 1 then + lVal := 1; + ZViewEdit.Value := lVal;//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3] div 2;*) + + XViewEdit.Value := Bound ( round(gBGImg.ScrnOri[1]),1,round(XViewEdit.MaxValue)); + YViewEdit.Value := Bound ( round(gBGImg.ScrnOri[2]),1,round(YViewEdit.MaxValue)); + ZViewEdit.Value := Bound ( round(gBGImg.ScrnOri[3]),1,round(ZViewEdit.MaxValue)); + //ImgForm.Caption := extractfilename(paramstr(0))+' - '+lFilename; + StatusLabel.caption := 'opened: '+lFilename; + + Result := true; + //LayerDrop.ItemIndex := 0; + //LayerDropSelect(nil); + if lAdd2MRU then Add2MRU(lFilename); + if gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.datatype = kDT_RGB then begin //RGB + //we have loaded the first [red] plane - now load green and blue... + OverlayOpenCore(lFilename,1); + OverlayOpenCore(lFilename,2); + //must use additive blending + //gBGImg.BGTransPct := -1; + //gBGImg.OverlayTransPct := -1; + OverlayAdditive.Click; + BGAdditive.Click; + end; + {$IFDEF FPC} + XViewEditChange(nil); + {$ENDIF} + //showmessage(lFilename+' 666 '+ChangeFileext(lFilename,'.anat')); + AnatForm.OpenAnat( ChangeFileextx(lFilename,'.anat')); +end; //OpenAndDisplayImg + +{$IFNDEF FPC} +procedure TImgForm.WMDropFiles(var Msg: TWMDropFiles); //implement drag and drop +var + CFileName: array[0..MAX_PATH] of Char; + lFilename: string; +begin + try + if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then + begin + lFilename := CFilename; + OpenAndDisplayImg(lFilename,true); + Msg.Result := 0; + end; + finally + DragFinish(Msg.Drop); + end; +end; +{$ENDIF} + +procedure TImgForm.Exit1Click(Sender: TObject); +begin + ImgForm.Close; +end; + +function XToStr(lR: extended; lDec: integer): string; +begin + result := FloatToStrF(lR, ffFixed,7,lDec); +end; + +procedure TImgForm.DisplayHdrClick(Sender: TObject); +var + lLayer:integer; +begin + lLayer := ActiveLayer; + HdrForm.SaveHdrDlg.Filename := gMRIcroOverlay[lLayer].HdrFilename; + HdrForm.WriteHdrForm (gMRIcroOverlay[lLayer]); + HdrForm.Show; + //HdrForm.BringToFront; + //HdrForm.BringToFront; +end; + +procedure TImgForm.Open1Click(Sender: TObject); +var + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilterPlusAny,'Select background image',false) then exit; + lFilename := HdrForm.OpenHdrDlg.Filename; + OpenAndDisplayImg(lFilename,True); +end; + +procedure TImgForm.ToolSelectClick(Sender: TObject); +begin + if (not ToolPanel.Visible) and ((Sender as TMenuItem).Tag > 0) then exit; //tools disabled + case (Sender as TMenuItem).Tag of + 0: begin + XBarBtn.Down := not XBarBtn.Down; + {$IFDEF Darwin} XBarbtnClick(nil); exit;{$ENDIF} + end; + 2: PenBtn.Down := true; + 3: ClosedPenBtn.Down := true; + 4: FillBtn.Down := true; + 5: EllipseBtn.Down := true; + 6: begin + PenBtn.Down := false; + ClosedPenBtn.Down := false; + FillBtn.Down := false; + EllipseBtn.Down := false; + end; + end; //case + RefreshImagesTimer.Enabled := true; +end; + +function SelectedImage: TImage; +begin + case SelectedImageNum of + kSagView0: result := ImgForm.PGImageSag; + kCoroView0: result := ImgForm.PGImageCor; + else + result := ImgForm.PGImageAx; + end; +end; + +procedure TImgForm.SetDimension8(lInPGHt,lInPGWid:integer; lBuff: ByteP; lUndoOnly: boolean); +begin + DefineBuffFX8(gDrawImg, lInPGWid,lInPGHt,lBuff); + DefineBuffFX8(gUndoImg, lInPGWid,lInPGHt,lBuff); + +end; + +procedure WriteAxialVOI (lUndoOnly: boolean); +var lX,lY,lSliceOffset,lSliceSz,lSlicePos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lSliceSz := lX*lY; + if lSliceSz < 1 then exit; + lSliceOffset := (ImgForm.ZViewEdit.Value-1)*lX*lY; + gBGImg.VOIUndoSlice := ImgForm.ZViewEdit.Value; + getmem(lInBuff,lSliceSz); + for lSlicePos := 1 to lSliceSz do + lInBuff^[lSlicePos] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lSliceOffset+lSlicePos]; + ImgForm.SetDimension8(lY,lX, lInBuff,lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteCorVOI (lUndoOnly: boolean); +var lX,lY,lZ,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lXPos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lYOffset := (lX) * (round(ImgForm.YViewEdit.Value)-1); + gBGImg.VOIUndoSlice := ImgForm.YViewEdit.Value; + lXYSliceSz := (lX*lY); + getmem(lInBuff,lZ*lX); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + lInBuff^[lPixel] := + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lZOffset+lYOffset+lXPos]; + end; //for each Y + end; //for each Z + ImgForm.SetDimension8(lZ,lX, lInBuff,lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteSagVOI (lUndoOnly: boolean); +var lX,lY,lZ,lXOffset,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lYPos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lXYSliceSz := lX*lY; + lXOffset := round(ImgForm.XViewEdit.Value); + //dec(lXOffset);//999+8 + gBGImg.VOIUndoSlice := ImgForm.XViewEdit.Value; + getmem(lInBuff,lZ*lY); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + lInBuff^[lPixel] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lZOffset+lYOffset+lXOffset]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z + ImgForm.SetDimension8(lZ,lY, lInBuff, lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteUndoVOI(lPanel: integer;lUndoOnly: boolean); +begin + EnsureVOIOPen; + case lPanel of + 3: WriteCorVOI(lUndoOnly); + 2: WriteSagVOI(lUndoOnly); + else WriteAxialVOI(lUndoOnly); + end; + gBGImg.VOIchanged := true; + if gBGImg.VOIUndoOrient = 4 then + FreeUndoVol; //release 3D undo buffer when creating 2D buffer + gBGImg.VOIUndoOrient := lPanel; +end; + +procedure TImgForm.FormOpenFileMethod(const FileName : string); +var + lFilename: string; +begin + lFilename := Filename; + OpenAndDisplayImg(lFilename,true); +end; + +procedure TImgForm.Landmarks1Click(Sender: TObject); +begin + //Graph4DForm.show; + AnatForm.show; +end; + +procedure TImgForm.FormCreate(Sender: TObject); +var + lInc: longint; +begin + Application.ShowButtonGlyphs := sbgNever; + KeyPreview := true; + + {$IFDEF Darwin} + //InitOpenDocHandler;//allows files to be associated... + {$IFNDEF LCLgtk} //for Carbon or Cocoa + AppleMenu.Visible:= true; + NewWindow1.Visible := true; + Open1.ShortCut := ShortCut(Word('O'), [ssMeta]); + SaveasNIfTI1.ShortCut := ShortCut(Word('S'), [ssMeta,ssAlt]); + Saveaspicture1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Paste1.ShortCut := ShortCut(Word('V'), [ssMeta]); + Undo1.ShortCut := ShortCut(Word('Z'), [ssMeta]); + OverlayOpen.ShortCut := ShortCut(Word('A'), [ssMeta]); + Applyintensityfiltertovolume1.ShortCut := ShortCut(Word('F'), [ssMeta]); + HistoMenu.ShortCut := ShortCut(Word('H'), [ssMeta]); + ShowRender.ShortCut := ShortCut(Word('R'), [ssMeta]); + ShowMultislice.ShortCut := ShortCut(Word('M'), [ssMeta]); + N4DTraces1.ShortCut := ShortCut(Word('D'), [ssMeta]); + Header1.ShortCut := ShortCut(Word('I'), [ssMeta]); + YokeMenu.ShortCut := ShortCut(Word('Y'), [ssMeta]); + // OnDropFiles := OnDropFiles; + + {$ENDIF} + {$ENDIF} +{$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Exit1.visible := false;//with OSX users quit from application menu + {$ENDIF} + {$ENDIF} + CreateFX8(gUndoImg); + CreateFX8(gDrawImg); + TriplePanel.OnMouseWheelDown:= FormMouseWheelDown; + TriplePanel.OnMouseWheelUp:= FormMouseWheelUp; + TriplePanel.OnMouseWheelDown:= FormMouseWheelDown; + TriplePanel.OnMouseWheelUp:= FormMouseWheelUp; + TriplePanel.OnMouseWheelDown:= FormMouseWheelDown; + TriplePanel.OnMouseWheelUp:= FormMouseWheelUp; + randomize; + gnCPUThreads := GetLogicalCpuCount; + gMouseDownX := -1; + ImgForm.Caption := extractfilename(paramstr(0)); + ImgForm.DoubleBuffered := true; + TriplePanel.DoubleBuffered := true; + TriplePanel.DoubleBuffered := true; + TriplePanel.DoubleBuffered := true; + for lInc := 0 to knMaxOverlay do begin + FreeImgMemory(gMRIcroOverlay[lInc]); + NIFTIhdr_ClearHdr(gMRIcroOverlay[lInc]); + gMRIcroOverlay[lInc].ScrnBufferItems := 0; + gMRIcroOverlay[lInc].ImgBufferItems := 0; + if lInc < knAutoLUT then + gMRIcroOverlay[lInc].LUTindex := lInc + else + gMRIcroOverlay[lInc].LUTindex := lInc;//B&W + LoadMonochromeLUT(gMRIcroOverlay[lInc].LUTindex,gBGImg,gMRIcroOverlay[lInc]); + end; + lInc:=maxint; + LoadMonochromeLUT(lInc,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + SetBGImgDefaults(gBGImg); + CloseImagesClick(nil); + gColorSchemeDir := extractfilepath(paramstr(0))+'lut'; + {$IFNDEF Unix} DragAcceptFiles(Handle, True); //engage drag and drop + {$ENDIF} + UpdateColorSchemes; + {$IFNDEF FPC} + LUTdrop.SetItemIndex(0); + Zoomdrop.SetItemIndex(0); + LayerDrop.SetItemIndex(0); + {$ELSE} + Application.OnDropFiles := FormDropFiles; + LUTdrop.ItemIndex:=(0); + Zoomdrop.ItemIndex:=(0); + LayerDrop.ItemIndex:=(0); + MagnifyMenuItem.visible := false; + {$IFNDEF COMPILEYOKE} + YokeMenu.visible := false; + {$ENDIF} +{$ENDIF} + gTemplateDir := extractfilepath(paramstr(0))+'templates'; + UpdateTemplates; + + for lInc := 1 to knMRU do + gMRUstr[lInc] := ''; + + (*if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + case MessageDlg('Shift key down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrNo: ReadIniFile; + end; //case + + end else*) + + if ResetDefaults then + DrawMenu.Visible := ToolPanel.visible + else + ReadIniFile; + + SetIniMenus; + UpdateMRU; + DefaultControlPanel; + OverlaySmoothMenuClick(nil); + LUTDrop.OnSelect(nil); + ZoomDrop.OnSelect(nil); + CreateShareMem; + if YokeMenu.checked then YokeTimer.enabled := true; + //gBGIMg.SaveDefaultIni := true; +end; + +function ImgIntensity(var lHdr: TMRIcroHdr; lPos: integer): single; overload; +var + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + + result := 0; + if (lPos > lHdr.ImgBufferItems) or (lPos < 1) then exit; + if (lHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(lHdr.ImgBuffer ); + result := l32Buf^[lPos]; + end else if (lHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(lHdr.ImgBuffer ); + result := l16Buf^[lPos]; + end else if lHdr.ImgBufferBPP = 1 then + result := lHdr.ImgBuffer^[lPos] + else begin + showmessage('Unknown Image Buffer Bytes Per Pixel: '+inttostr(lHdr.ImgBufferBPP)+' '+lHdr.HdrFileName); + exit; + end; + result := Raw2ScaledIntensity (lHdr,result); +end; + +function ImgIntensity(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): single; overload; +var + lPos: integer; +begin + lPos := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + result := ImgIntensity(lHdr,lPos); +end; + +function TImgForm.ImgIntensityString(var lHdr: TMRIcroHdr; lVox: integer): string; overload; +var + lV: integer; +begin + if (lVox > lHdr.ImgBufferItems) or (lVox < 1) then exit; + if lHdr.UsesLabels then begin + lV := round(ImgIntensity(lHdr,lVox)); + if lV <= High(gBGImg.LabelRA) then + result := gBGImg.LabelRA[lV]; + exit; + end; + if (not lHdr.UsesCustomPalette) or (lHdr.NIFTIhdr.datatype = kDT_RGB) then begin + result := realtostr(ImgIntensity(lHdr,lVox),gBGImg.SigDig); + exit; + end; +end; + +function TImgForm.ImgIntensityString(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): string; overload; +var + lVox: integer; +begin + lVox := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + result := ImgIntensityString(lHdr,lVox); +end; + +procedure TImgForm.UpdateStatusLabel; +var + lX,lY,lZ,lOverlay,lLen: integer; + lXmm,lYmm,lZmm: single; + lIntenStr : string; +begin + + lX := XviewEdit.value; + lY := YviewEdit.value; + lZ := ZviewEdit.value; + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + + lIntenStr := ''; +//StatusLabel.Caption := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0); +//lIntenStr := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr;; + +//StatusLabel.Caption := lIntenStr; +//StatusLabel.Caption := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr; +//crash! + for lOverlay := kBGOverlayNum to (kVOIOverlayNum-1) do + if gMRIcroOverlay[lOverlay].ImgBufferItems > 0 then + lIntenStr := lIntenStr + ImgIntensityString(gMRIcroOverlay[lOverlay],lX,lY,lZ)+', '; + lLen := length (lIntenstr); + if lLen > 2 then + lIntenStr[lLen-1] := ' '; + //StatusLabel.Caption := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr; + Caption :=realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr; + SetShareMem (lXmm,lYmm,lZmm); +end; + +procedure TImgForm.XViewEditChange(Sender: TObject); +begin + gBGImg.XViewCenter := XviewEdit.value; + gBGImg.YViewCenter := YviewEdit.value; + gBGImg.ZViewCenter := ZviewEdit.value; + RefreshImagesTimer.Enabled := true; + //UpdateStatusLabel; //caused crash! - only with refreshimagestimes +end; + + {$IFNDEF FPC} +procedure TImgForm.FormClose(Sender: TObject; var Action: TCloseAction); + {$ELSE} +procedure TImgForm.FormClose(Sender: TObject); + {$ENDIF} +begin + + WriteIniFile; + CloseImagesClick(nil); + FreeFX8(gDrawImg); + FreeFX8(gUndoImg); +end; + +procedure TImgForm.MagnifyTimerTimer(Sender: TObject); + {$IFDEF FPC} + begin +// MagnifyTimer.Enabled := false; + end; + {$ELSE} + var + Srect,Drect,PosForme,ImgForme:TRect; + lZoomSlider,iWidth,iHeight,DmX,DmY:Integer; + iTmpX,iTmpY:Real; + C:TCanvas; + hDesktop: Hwnd; + Kursor:TPoint; +begin + + MagnifyTimer.Enabled := false; + lZoomSlider := 2; + If not IsIconic(Application.Handle) then begin + hDesktop:= GetDesktopWindow; + GetCursorPos(Kursor); + ImgForme := Rect(ImgForm.Left+ImgForm.TriplePanel.Left,ImgForm.Top+ImgForm.TriplePanel.Top,ImgForm.Left+ImgForm.Width,ImgForm.Top+ImgForm.Height); + PosForme:=Rect(MagnifyPanel.Left,MagnifyPanel.Top,MagnifyPanel.Left+MagnifyPanel.Width,MagnifyPanel.Top+MagnifyPanel.Height); + if true then begin + iWidth:=MagnifyImage.Width; + iHeight:=MagnifyImage.Height; + if iHeight < 6 then exit; + Drect:=Rect(0,0,iWidth,iHeight); + iTmpX:=iWidth / (lZoomSlider*4);//(Slider.Position * 4); + iTmpY:=iHeight / (lZoomSlider*4);//(Slider.Position * 4); + Srect:=Rect(Kursor.x,Kursor.y,Kursor.x,Kursor.y); + InflateRect(Srect,Round(iTmpX),Round(iTmpY)); + If Srect.Left<0 then OffsetRect(Srect,-Srect.Left,0); + If Srect.Top<0 then OffsetRect(Srect,0,-Srect.Top); + If Srect.Right>Screen.Width then OffsetRect(Srect,-(Srect.Right-Screen.Width),0); + If Srect.Bottom>Screen.Height then OffsetRect(Srect,0,-(Srect.Bottom-Screen.Height)); + C:=TCanvas.Create; + try + C.Handle:=GetDC(GetDesktopWindow); + SetStretchBltMode(C.Handle,COLORONCOLOR); + //SetStretchBltMode(C.Handle, STRETCH_DELETESCANS); + //SetStretchBltMode(C.Handle,{BILINEAR}TransparencyEdit.value); + MagnifyImage.Canvas.CopyRect(Drect,C,Srect); + finally + ReleaseDC(hDesktop, C.Handle); + C.Free; + end; + If True then begin // show crosshair + MagnifyImage.Canvas.Pen.Color := gBGIMg.XBarClr; + with MagnifyImage.Canvas do begin + DmX:=lZoomSlider * 2 * (Kursor.X-Srect.Left); + DmY:=lZoomSlider * 2 * (Kursor.Y-Srect.Top); + MoveTo(1,DmY); // - + LineTo(iWidth,DmY); // - + MoveTo(DmX,1); // | + LineTo(DmX,iHeight); // | + end; // with MagnifyImage.Canvas + end; // show crosshair + Application.ProcessMessages; + end // Cursor not inside form + end; // IsIconic +end; //magnify image + {$ENDIF} + +procedure TImgForm.MagnifyPanelResize(Sender: TObject); +begin +(* MagnifyImage.Picture:=nil; + if MagnifyPanel.Width < MagnifyPanel.Constraints.MinWidth then + MagnifyPanel.Width := MagnifyPanel.Constraints.MinWidth; + *) +end; //Proc MagnifyPanelResize + +procedure SelectPanel (lPanelNumber: integer); +begin +gSelectedImageNum := lPanelNumber; +end; //Proc SelectPanel + +procedure ShowFocusRect(lInRect: TRect); +var LImage: TImage; +begin + lImage := SelectedImage; + lImage.Canvas.DrawFocusRect(lInRect); +end; //proc ShowFocusRect + +procedure XYscrn2Img (lImage: TIMage;lPanel,lXinRaw,lYinRaw: integer; var lXout,lYOut,lZOut: integer); +var + lYin,lXin,lZoom : integer; + lOffset: single; +begin + //amx - must match XYscrn2Img and DrawXBar - e.g. +0.5 for middle of zoomed slice + lZoom := ImageZoomPct(lImage); + if lZoom = 0 then lZoom := 100; + if lZoom > 100 then lOffset := 0.5 else + lOffset := 0; + lXIn := lXinRaw + 1; //index from 0 + lYin := lImage.Height-lYinRaw; + case lPanel of + 2: begin + if gBGImg.FlipSag then + lXin := lImage.Width-lXinRaw; + lXOut := ImgForm.XViewEdit.value; + lYOut := round((lXin*100) / lZoom +lOffset); + lZOut := round((lYin*100) / lZoom +lOffset); + end; + 3: begin + lXOut := round((lXin*100) / lZoom +lOffset); + lYOut := ImgForm.YViewEdit.value; + lZOut := round((lYin*100) / lZoom +lOffset); + + end; + else begin + if gBGImg.FlipAx then + lYin := lYinRaw; + lXOut := round((lXin*100) / lZoom +lOffset); + lYOut := round((lYin*100) / lZoom +lOffset); + lZOut := ImgForm.ZViewEdit.value; + end; //else + end;//case lPanel + //ImgForm.Caption := inttostr(lXOut)+' '+inttostr(lYOut)+' '+Inttostr(lZOut); +end; //proc XYscrn2Img + +procedure AdjustContrastRectangle (lImage: TImage); +var + lXpos,lYPos,lXOut,lYOut,lZOut,lPanel,lLayer: integer; + lMinInten,lMaxInten,lVal: single; +begin + lPanel := SelectedImageNum; + lLayer := ActiveLayer; + XYscrn2Img (lImage,lPanel,gSelectRect.Left,gSelectRect.Top, lXout,lYOut,lZOut); + lMinInten := ImgIntensity(gMRIcroOverlay[lLayer],lXout,lYOut,lZOut); + lMaxInten := lMinInten; + for lYpos := gSelectRect.Top to gSelectRect.Bottom do begin + for lXpos := gSelectRect.Left to gSelectRect.Right do begin + XYscrn2Img (lImage,lPanel,lXpos,lYPos, lXout,lYOut,lZOut); + // lVox := lXout + ((lYout-1)*gBGImg.ScrnDim[1])+((lZout-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + // lVal := ImgIntensity(gMRIcroOverlay[lLayer],lVox); + lVal:= ImgIntensity(gMRIcroOverlay[lLayer],lXout,lYOut,lZOut); + if lVal < lMinInten then lMinInten := lVal; + + if lVal > lMaxInten then lMaxInten := lVal; + end; //for PGX each column + end; //for PGY2 - each row + //ImgForm.StatusLabel.caption := (RealToStr(lMinInten,4))+'..'+({x} RealToStr(lMaxInten,4))+'bexx'+ inttostr(lXout)+'x'+inttostr(lYOut)+'x'+inttostr(lZOut)+' '+inttostr(ActiveLayer); + + // ImgForm.StatusLabel.caption := 'bexx'+ inttostr(gSelectRect.Top)+'..'+inttostr(gSelectRect.Bottom)+' -> '+inttostr(gSelectRect.Left)+'..'+inttostr(gSelectRect.Right); + ImgForm.StatusLabel.caption := 'Intensity range '+(RealToStr(lMinInten,4))+'..'+({x} RealToStr(lMaxInten,4)); + if lMinInten = lMaxInten then exit; //no range + ImgForm.MinWindowEdit.value := lMinInten; + ImgForm.MaxWindowEdit.value := lMaxInten; + {$IFDEF FPC} ImgForm.MinContrastWindowEditChange(nil); {$ENDIF} +end; + +procedure sortLTRB(var lXoutLow,lYOutLow,lXoutHi,lYOutHi: integer); //left<right, top<bottom +var lXin1,lYin1,lXin2,lYin2: integer; +begin + lXin1 := lXoutLow; + lYin1 := lYOutLow; + lXin2 := lXoutHi; + lYin2 := lYOutHi; + if lXIn1 < lXin2 then begin + lXoutLow := lXIn1; + lXOutHi := lXIn2; + end else begin + lXoutLow := lXIn2; + lXOutHi := lXIn1; + end; + if lYIn1 < lYin2 then begin + lYoutLow := lYIn1; + lYOutHi := lYIn2; + end else begin + lYoutLow := lYIn2; + lYOutHi := lYIn1; + end; +end; //sortLTRB + +procedure DrawEllipse (lImage: TImage;lRect: TRect; lShift: TShiftState; lPanel: integer); +var + i: integer; +begin + ScaleBMP2Draw(gBGImg.VOIInvZoom, lRect.Left,lRect.Top,lPanel,Limage); + ScaleBMP2Draw(gBGImg.VOIInvZoom, lRect.Right,lRect.Bottom,lPanel,lImage); + if ssShift in lShift then + i := 0 + else + i := kVOI8bit; + if (ssCtrl in lShift) then + FillRectFX8(gDrawImg,lRect.Left,lRect.Top,lRect.Right,lRect.Bottom,i) + else + FillEllipseFX8(gDrawImg,lRect.Left,lRect.Top,lRect.Right,lRect.Bottom,i); +end; //DrawEllipse + + +procedure TImgForm.PGImageMouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer); +var lZoom,lPanel,lX, lY,lXout,lYOut,lZOut,lBasePenThick,lX2, lY2: integer; + lImage: TImage; +begin + //ImgForm.GetFocus := true; + gSelectOrigin.X := -1; + + lX := X; lY := Y; + lImage := Sender as TImage; + if lImage.Name = PGImageCor.Name {'PGImageCor'} then lPanel := kCoroView0 + else if lImage.Name = PGImageSag.Name {'PGImageSag'} then lPanel := kSagView0 + else lPanel := kAxView0; + + + //lImage.Canvas.Pen.Width := 1; + // lImage.Canvas.Pen.Color :=gBGImg.VOIClr; + SelectPanel(lPanel); + gBGImg.VOIInvZoom := ComputeInvZoomShl10(lPanel,lImage); + if DrawToolSelected then begin //paint tool + WriteUndoVOI(lPanel,false); + if (ssShift in Shift) then begin //erase + lImage.Canvas.Brush.Color:=clBlack; + lImage.Canvas.Pen.Color := clBlack; + end else begin + lImage.Canvas.Brush.Color:=gBGImg.VOIClr; + lImage.Canvas.Pen.Color := gBGImg.VOIClr; + end; + if gBGImg.ThinPen then + lBasePenThick := 1 + else begin //adjust pen thickness for zoom level + if gBGImg.ZoomPct < 100 then begin + lZoom := ComputeZoomPct(lPanel,lImage); + if lZoom = 100 then + lBasePenThick := 1 + else + lBasePenThick := round((ComputeZoomPct(lPanel,lImage)+50) / 100); + end else if gBGImg.ZoomPct > 100 then + lBasePenThick := gBGImg.ZoomPct div 100 + else + lBasePenThick := 1; + end; //if not thinpen + if (ssCtrl in Shift) then begin + lImage.Canvas.Pen.Width := lBasePenThick*3; + gDrawImg.PenThick := 3; + end else begin + lImage.Canvas.Pen.Width := lBasePenThick; + gDrawImg.PenThick := 1; + end; + end; //paint tool selected + //lImage.Canvas.Pen.Width := 1;//abba + if (FillBtn.Down) and (ssCtrl in Shift) then begin //3D fill + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + XViewEdit.value := lXOut; + YViewEdit.value := lYOut; + ZViewEdit.value := lZOut; + if (ssShift in Shift) then //erase + ROICluster(gBGImg.ScrnDim[1], gBGImg.ScrnDim[2], gBGImg.ScrnDim[3],XViewEdit.value,YViewEdit.value,ZViewEdit.value,true) + else //draw + ROICluster(gBGImg.ScrnDim[1], gBGImg.ScrnDim[2], gBGImg.ScrnDim[3],XViewEdit.value,YViewEdit.value,ZViewEdit.value,false); + exit; + end; //end 3D fill + if (not PenBtn.Down) and (not ClosedPenBtn.Down) and (not FillBtn.Down) then begin + if (EllipseBtn.Down) or (ssRight in Shift) then begin + lImage.Canvas.Brush.Color:=gBGImg.VOIClr; + //lImage.Canvas.Pen.Color :=gBGImg.VOIClr; + ScaleScrn2BMP(lX,lY, lImage); + gSelectRect.Left := lX; + gSelectRect.Top := lY; + gSelectRect.Right := lX; + gSelectRect.Bottom := lY; + ShowFocusRect(gSelectRect); + gSelectOrigin.X := gSelectRect.Left; + gSelectOrigin.Y := gSelectRect.Top; + exit; + end; + //next no paint tools selected - show position where click occurred + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + XViewEdit.value := lXOut; + YViewEdit.value := lYOut; + ZViewEdit.value := lZOut; + //showmessage(floattostr(lXOut)+'x'+floattostr(lYOut)+'x'+floattostr(lZOut)); + //ImgCoordToMM(lXOut,lYOut,lZOut,lXmm,lYmm,lZmm); + //showmessage(floattostr(lXmm)+'x'+floattostr(lYmm)+'x'+floattostr(lZmm)); + + //showmessage(floattostr(gBGImg.ScrnOri[1])+'x'+floattostr(gBGImg.ScrnOri[2])+'x'+floattostr(gBGImg.ScrnOri[3])); + //MMToImgCoord(lXOut,lYOut,lZOut,lXmm,lYmm,lZmm); + //showmessage(floattostr(lXOut)+'x'+floattostr(lYOut)+'x'+floattostr(lZOut)); + + //SetShareMem (lXmm,lYmm,lZmm); + + {$IFDEF FPC} + XViewEditChange(nil); + {$ENDIF} + exit; + end; + ScaleScrn2BMP(lX,lY, lImage); + lImage.Canvas.MoveTo(lX,lY); + + lX2 := X; lY2 := Y; + ScaleBMP2Draw(gBGImg.VOIInvZoom, lX2,lY2,lPanel,lImage); + if (FillBtn.Down) or(ssRight in Shift) then begin + + if (ssShift in Shift) then + FloodFillFX8 (gDrawImg, lX2,lY2,kVOI8bit,0,true) + //FloodFillX(DrawImg2,lX2-1,lY2-1,gBGImg.VOIClr, fsSurface) + else + FloodFillFX8 (gDrawImg, lX2,lY2,kVOI8bit,kVOI8bit,false); + //FloodFillX(DrawImg2,lX2-1,lY2-1,gBGImg.VOIClr, fsBorder); + + exit; + end; + //ImgForm.caption := inttostr(lX2); + MoveToFX8(gDrawImg,lX2,lY2); + if lImage.Canvas.Pen.Color = clBlack then //ensure single pixel is drawn if user clicks without dragging + LineToFX8(gDrawImg,lX2,lY2,0) + else + LineToFX8(gDrawImg,lX2,lY2,kVOI8bit); + gMouseDownX := lX; + gMouseDownY := lY; + +end; //PGImageMouseDown + +var + gDragX,gDragY,gDragZ : integer; + //gDragRefresh : boolean = false; //only redraw one snapshot at a time + +procedure TImgForm.PGImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); +var lX, lY,lPanel,lXOut,lYOut,lZOut: integer; + lImage: TImage; +begin + lImage := Sender as TImage; + lX := X; lY := Y; + ScaleScrn2BMP(lX,lY,lImage); + //if MagnifyImage.Height > 10 then + // MagnifyTimer.Enabled := true;//MagnifyBtn.Down; + //StatusLabel.Caption := inttostr(lX)+','+inttostr(lY); + + if {(ssShift in Shift) and} (gSelectOrigin.X > 0) then begin + ShowFocusRect(gSelectRect); + gSelectRect.Left := gSelectOrigin.X; + gSelectRect.Top := gSelectOrigin.Y; + gSelectRect.Right := lX; + gSelectRect.Bottom := lY; + sortLTRB(gSelectRect.Left,gSelectRect.Top,gSelectRect.Right,gSelectRect.Bottom); + ShowFocusRect(gSelectRect); + exit; + end; + if lImage.Name = PGImageCor.Name then lPanel := kCoroView0 + else if lImage.Name = PGImageSag.Name then lPanel := kSagView0 + else lPanel := kAxView0; + if (not DrawToolSelected) and ((ssLeft in Shift)) then begin + //RefreshImagesTimer.Enabled := false; + //gDragRefresh := true; + + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + if (lXout = gDragX) and (lYout = gDragY) and (lZOut = gDragZ) then + exit;//no change + XViewEdit.value := lXOut; + YViewEdit.value := lYOut; + ZViewEdit.value := lZOut; + + {$IFDEF FPC}XViewEditChange(nil);{$ENDIF} //can generate crash! + //gDragRefresh := false; + exit; + end; + + if (not (ssLeft in Shift)) or (gMouseDownX < 0) then exit; + if PenBtn.Down or ClosedPenBtn.Down then begin + lImage.Canvas.LineTo(lX,lY); + lX := X; lY := Y; + ScaleBMP2Draw(gBGImg.VOIInvZoom, lX,lY,lPanel,lImage); + //DrawImg2.Canvas.LineTo(lX,lY); + if lImage.Canvas.Pen.Color = clBlack then + LineToFX8(gDrawImg,lX,lY,0)//zzzxx + else + LineToFX8(gDrawImg,lX,lY,kVOI8bit);//zzzxx + end; +end; //PGImageMouseMove + +(*procedure Scrn2VOI (var lImage: TImage; lXvoi,lYvoi: integer; var lVOIBuffer: ByteP); + +const + kSh = 10; //bits to shift +var + lInc,lXpos,lYPos,lVOISliceSz: integer; + srcBmp : TBitmap; +begin + srcBmp := lImage.Picture.Bitmap; + lVOISliceSz := lXvoi*lYvoi; + GetMem (lVOIBuffer , lVOISliceSz); + lInc := 0; + for lYpos:=(lYvoi-1) downto 0 do begin + for lXpos:=0 to lXvoi-1 do begin + inc(lInc); //zax + if srcBmp.Canvas.Pixels[lXpos,lYPos] = clBlack then + lVOIBuffer^[lInc] := 0 + else + lVOIBuffer^[lInc] := 100; + end; + end; +end; //Scrn2VOI *) + + +procedure ReadCorVOI (var lImage: TFX8; lSlice: integer); +var lX,lY,lZ,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lXPos: integer; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lYOffset := (lX) * (round(lSlice)-1); + lXYSliceSz := (lX*lY); + //Scrn2VOI (lImage,lX,lZ, lInBuff); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lZOffset+lYOffset+lXPos] :=lImage.Img^[lPixel]; + end; //for each Y + end; //for each Z +end; + +procedure ReadSagVOI (var lImage: TFX8;lSlice: integer); +var lX,lY,lZ,lXOffset,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lYPos: integer; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lXYSliceSz := lX*lY; + lXOffset := round(lSlice); + // dec(lXOffset);//999+8 + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lZOffset+lYOffset+lXOffset] := lImage.Img^[lPixel]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z + //freemem(lInBuff); +end; + +procedure ReadAxialVOI (var lImage: TFX8;lSlice: integer); +var lX,lY,lSliceOffset,lSliceSz: integer; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lSliceSz := lX*lY; + lSliceOffset := (lSlice-1)*lX*lY; + //Scrn2VOI (lImage,lX,lY, lInBuff); + for lX := 1 to lSliceSz do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lSliceOffset+lX] := lImage.Img^[lX]; + +end; + +procedure ReadScrnVOI (lImage: TImage); +var + lView: integer; +begin + if (gBGImg.VOIUndoSlice < 1) or (gBGImg.VOIUndoOrient < 1) or (gBGImg.VOIUndoOrient > 3) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (lImage.Picture.Bitmap.Width < 1) or (lImage.Picture.Bitmap.Height < 1) then + exit; + EnsureVOIOpen; + lView := SelectedImageNum; + case lView of + 3: ReadCorVOI(gDrawImg,ImgForm.YViewEdit.Value); + 2: ReadSagVOI(gDrawImg,ImgForm.XViewEdit.Value); + 1: ReadAxialVOI(gDrawImg,ImgForm.ZViewEdit.Value); + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.PGImageMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var lX, lY,lPanel: integer; +lImage: TImage; +begin + lPanel := SelectedImageNum; + lImage := Sender as TImage; + lX := X; lY := Y; + ScaleScrn2BMP(lX,lY,lImage); + if (gSelectOrigin.X > 0) then begin + sortLTRB(gSelectRect.Left,gSelectRect.Top,gSelectRect.Right,gSelectRect.Bottom); + ShowFocusRect(gSelectRect); + gSelectOrigin.X := -1; + if (EllipseBtn.Down) then + DrawEllipse(Limage,gSelectRect,Shift,lPanel) + else begin + AdjustContrastRectangle(lImage); + exit; + end; + end; + + if ((PenBtn.Down) or (ClosedPenBtn.Down)) and (gMouseDownX > 0) then begin + ScaleBMP2Draw(gBGImg.VOIInvZoom, gMouseDownX,gMouseDownY,lPanel,lImage); + //next: draw single pxiel if user clicks on image without moving the mouse + //DrawImg2.Canvas.Pixels[gMouseDownX,gMouseDownY] := DrawImg2.Canvas.Pen.Color; + if (ClosedPenBtn.Down) then begin + if lImage.Canvas.Pen.Color = clBlack then + LineToFX8(gDrawImg,gMouseDownX,gMouseDownY,0) + else + LineToFX8(gDrawImg,gMouseDownX,gMouseDownY,kVOI8Bit); + end; + end; + + gMouseDownX := -1; //disable draws + //if DrawToolSelected then + if DrawToolSelected and (not (ssAlt in Shift)) then + ReadScrnVOI (lImage); +end; //PGImageMouseUp + + +procedure TImgForm.FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +begin + Case SelectedImageNum of + 3: DecViewEdit(YViewEdit); + 2: DecViewEdit(XViewEdit); + else DecViewEdit(ZViewEdit); + end; +end; + +procedure TImgForm.FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +begin + Case SelectedImageNum of + 3: IncViewEdit(YViewEdit); + 2: IncViewEdit(XViewEdit); + else IncViewEdit(ZViewEdit); + end; +end; + +procedure TImgForm.ZoomDropSelect(Sender: TObject); +begin + gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.ColorBarBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + var lLTRB,lLayer: integer; + lImage: TImage; +begin + + if (ssAlt in Shift) then begin + //lImage := SelectedImage; + lLayer := ActiveLayer; + DrawHistogram(gMRIcroOverlay[lLayer],HistogramForm.HistoImage{lImage}); + HistogramForm.Caption := 'Histogram: '+extractfilename(gMRIcroOverlay[lLayer].HdrFileName); + HistogramForm.show; + if (ssCtrl in Shift) then + TextReportHisto(gMRIcroOverlay[lLayer]); + exit; + end; + lLTRB := 1; + if (ssRight in Shift) then + lLTRB := lLTRB + 1; + if (ssCtrl in Shift) then + lLTRB := lLTRB + 2; + lImage := SelectedImage; + //Caption := inttostr(random(888)); + intenBar(lImage,gMRIcroOverlay[ActiveLayer],lLTRB,0,0); +end; + + + + + +procedure TImgForm.XBarBtnClick(Sender: TObject); +begin + gBGImg.XBarVisible := XBarBtn.Down; + RefreshImagesTimer.Enabled := true; +end; + +procedure RepositionOrigin; +begin + gBGImg.ScrnOri[1] := ImgForm.XviewEdit.value; + gBGImg.ScrnOri[2] := ImgForm.YviewEdit.value; + gBGImg.ScrnOri[3] := ImgForm.ZviewEdit.value; +end; + +procedure TImgForm.XBarBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + +end; + +procedure TImgForm.XBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +label 555; +begin + if not (ssRight in shift) then exit; + if (ssShift in Shift) then begin + RepositionOrigin; + goto 555; + end; + if (ssAlt in Shift) and (ssCtrl in Shift) then begin + inc(gBGImg.FontSize,2); + if gBGImg.FontSize > 24 then + gBGImg.FontSize := 8; + goto 555; + end; + if (ssAlt in Shift) then begin + inc(gBGImg.XBarThick,2); + if gBGImg.XBarThick > 10 then + gBGImg.XBarThick := 1; + goto 555; + end; + if (ssCtrl in Shift) then begin + ColorDialog1.Color := gBGImg.XBarClr; + if not ColorDialog1.Execute then exit; + gBGImg.XBarClr := ColorDialog1.Color; + goto 555; + end; + inc(gBGImg.XBarGap); + if gBGImg.XBarGap > 10 then + gBGImg.XBarGap := 0; +555: + RefreshImagesTimer.Enabled := true; + if MultiSliceForm.Visible then + MultiSliceForm.CreateMultiSlice; +end; //XBarBtnMouseDown + + + +procedure TImgForm.RefreshImagesTimerTimer(Sender: TObject); +begin + RefreshImagesTimer.Enabled := false; + RefreshImages; + UpdateStatusLabel; + + +end; + +procedure TImgForm.ImgPanelClick(Sender: TObject); +begin + SelectPanel((Sender as TScrollBox).tag); +end; + +procedure TImgForm.MagnifyMenuItemClick(Sender: TObject); +begin + (*if MagnifyPanel.Height < 20 then //Height constrained by Y + MagnifyPanel.Height := 128 + else + MagnifyPanel.Height := MagnifyPanel.Constraints.MinHeight; *) +end; + +procedure TImgForm.CloseImagesClick(Sender: TObject); +var + lC: integer; +begin + CloseVOIClick(nil); + FreeUndoVol; + for lC := 0 to knMaxOverlay do //background, all overlays, VOI + FreeImgMemory(gMRIcroOverlay[lC]); + gBGImg.VOIUndoSlice := 0; + + //next- set layers menu + LayerDrop.Items.Clear; + LayerDrop.Items.Add('Background'); + {$IFNDEF FPC} + LayerDrop.SetItemIndex(0); + {$ELSE} + LayerDrop.ItemIndex :=(0); + {$ENDIF} + LayerDropSelect(nil); +end; + +procedure TImgForm.OverlayOpenCore (var lFilename: string; lOverlayNum: integer); +begin + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lOverlayNum]) then exit; + //if not OpenImg(gBGImg,gMRIcroOverlay[lOverlayNum],false,false,false) then exit; + //if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + // if not OpenImg(gBGImg,gMRIcroOverlay[lOverlayNum],false,false,false,not gBGImg.ResliceOnLoad,false) then exit; + //end else + if not OpenImg(gBGImg,gMRIcroOverlay[lOverlayNum],false,false,false,gBGImg.ResliceOnLoad,false) then exit; + ImgForm.UpdateLayerMenu; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LoadOverlay (lFilename: string); +var +lOverlay,lC: integer; +begin + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + OverlayOpenCore ( lFilename, lOverlay); +end; + +procedure TImgForm.LoadOverlayIncludingRGB (lFilename: string); +var +lOverlay,lC: integer; +begin + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + OverlayOpenCore ( lFilename, lOverlay); + if (gMRIcroOverlay[lOverlay].NIFTIhdr.datatype = kDT_RGB) then begin + OverlayOpenCore ( lFilename, lOverlay+1); + OverlayOpenCore ( lFilename, lOverlay+2); + OverlayAdditive.click; + end; +end; + +procedure TImgForm.BrainMask1Click(Sender: TObject); +var + lInc: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + //lImgSamples := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + for lInc := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc] <> 0 then + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc] := 1; + SaveAsVOIorNIFTI(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems,1,1,true,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end; + +procedure TImgForm.ControlPanelDragDrop(Sender, Source: TObject; X, Y: Integer); +begin + +end; + +(*procedure DescribeVOIonLabelsz (lOverlayNum: integer; lShowFilename: boolean); +var + lLocalMax,lLocalSum : HistoDoubleRA; + l16Buf : SmallIntP; + l32Buf : SingleP; + l8Buf: byteP; + lInten: double; + lXmm,lYmm,lZmm: single; + lHisto,lRegionVol,lLocalMaxPos: HistoRA; + lInc,lRegion: Integer; + lLabelStr: string; + lVOI: boolean; + lLabelStr20 : Array[0..kHistoBins] of kstr20; +begin + lInten := 0;//just to hide compiler hint... + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) and ('ratlas.nii.gz' = (extractfilename( gMRIcroOverlay[kBGOverlayNum].HdrFileName))) then begin + // specific for PCDescribeVOIonLabelsRAT(lOverlayNum,lShowFilename); + exit; + end; + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) or (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP <> 1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 2) then + exit; + TextForm.MemoT.Lines.add(' Custom Region Analysis'); + TextForm.MemoT.Lines.add(' For Speculative Brodmann Map: 0=not cortical and 48=no Brodmann label'); + lVOI := IsVOIROIExt(gMRIcroOverlay[lOverlayNum].HdrFileName); + if (not lVOI) and (lOverlayNum = kVOIOverlayNum) then + lVOI := true; + //next describe format + if lShowfilename then + lLabelStr := ' Filename,' + else + lLabelStr := ' '; + if lVOI then //intensity min/max position are not important + TextForm.MemoT.Lines.add(lLabelStr+'Area'+kTextSep+'N>0'+kTextSep+'%N>0') + else + TextForm.MemoT.Lines.add(lLabelStr+'Area'+kTextSep+'N>0'+kTextSep+'%N>0'+kTextSep+'Sum>0'+kTextSep+'Mean>0'+kTextSep+'Max'+kTextSep+'MaxX'+kTextSep+'MaxY'+kTextSep+'MaxZ'); + //next initialize + if lShowFilename then + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName+kTextSep + else + lLabelStr := ''; + for lInc := 0 to kHistoBins do begin + lHisto[lInc] := 0; + lLocalMax[lInc] := 0; + lLocalSum[lInc] := 0; + lRegionVol[lInc] := 0; + if (gMRIcroOverlay[kBGOverlayNum].UsesCustomPalette) then + lLabelStr20[lInc] := gBGImg.LabelStr20[lInc] + else + lLabelStr20[lInc] := inttostr(lInc); + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + inc(lHisto[gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc]]); + //local max start + l32Buf := SingleP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + l16Buf := SmallIntP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + //NEXT if..else July07 - ROIs only use screen buffer, not imgbuffer... + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[lOverlayNum].ImgBufferItems then + l8Buf := gMRIcroOverlay[lOverlayNum].ImgBuffer + else + l8Buf := gMRIcroOverlay[lOverlayNum].ScrnBuffer; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if (gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 4) then + lInten := l32Buf^[lInc] + else if (gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 2) then + lInten := l16Buf^[lInc] + else if gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 1 then + lInten := l8Buf^[lInc];//July07 + lRegion := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc]; + if lInten > 0 then + lLocalSum[lRegion] := lLocalSum[lRegion]+lInten; + if lInten > lLocalMax[lRegion] then begin + lLocalMax[lRegion] := lInten;//intensity + lLocalMaxPos[lRegion] := lInc;//location + end; + inc(lRegionVol[lRegion]); + end; + for lInc := 0 to kHistoBins do begin + if (not lVOI) and (lLocalMax[lInc] > 0) then begin + lLocalMax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[lOverlayNum],lLocalMax[lInc]); + lLocalSum[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[lOverlayNum],lLocalSum[lInc]); + ImgPosToMM(lLocalMaxPos[lInc], lXmm,lYmm,lZmm); + TextForm.MemoT.Lines.Add(lLabelStr+ lLabelStr20[lInc] + kTextSep + inttostr(lHisto[lInc])+kTextSep+floattostr( lHisto[lInc]/lRegionVol[lInc]) + +kTextSep+floattostr( lLocalSum[lInc])+kTextSep+floattostr( lLocalSum[lInc]/lRegionVol[lInc]) //Sum>0, mean>0 + +kTextSep + floattostr(lLocalMax[lInc])+kTextSep+floattostr(lXmm)+kTextSep+floattostr(lYmm)+kTextSep+floattostr(lZmm) ); + end else if (lHisto[lInc] > 0) {necessarily also and (lRegionVol[lInc] > 0)} then + TextForm.MemoT.Lines.Add(lLabelStr+ lLabelStr20[lInc] +kTextSep+ inttostr(lHisto[lInc])+kTextSep+floattostr( lHisto[lInc]/lRegionVol[lInc])) ; + end; //for each row +end; *) +procedure DescribeVOIonLabels (lOverlayNum: integer; lShowFilename: boolean); +const + kT = kTextSep; + PositiveInfinityBits : Int64 = $7FF0000000000000; + NegativeInfinityBits : Int64 = $FFF0000000000000; +VAR + dPositiveInfinity : DOUBLE ABSOLUTE PositiveInfinityBits; + dNegativeInfinity : DOUBLE ABSOLUTE NegativeInfinityBits; +var + l16Buf : SmallIntP; + l32Buf : SingleP; + l8Buf: byteP; + type + TVxStat = RECORD //peristimulus plot + n, nNot0, minPos,maxPos: integer; + sum,sumNot0,min,max: double; + end; +function clearVxStat: TVxStat; +begin + result.sum:=0; + result.sumNot0:= 0; + result.n:=0; + result.nNot0 := 0; + result.minPos:= 0; + result.maxPos:=0; + result.min := dPositiveInfinity; + result.max := dNegativeInfinity; +end; +function roiIntensity(var lHdr: TMRIcroHdr; lPos: integer): integer; +var + l16Buf : SmallIntP; +begin + if (lHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(lHdr.ImgBuffer ); + result := l16Buf^[lPos]; + end else + result := lHdr.ImgBuffer^[lPos]; +end; +function overlayIntensity(var lHdr: TMRIcroHdr; lPos: integer): single; + +begin + if (lHdr.ImgBufferBPP = 4) then begin + result := l32Buf^[lPos]; + end else if (lHdr.ImgBufferBPP = 2) then begin + result := l16Buf^[lPos]; + end else + result := l8Buf^[lPos]; +end; +procedure scaleIntensity(var valn: double); +begin + valn := (valn * gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope)+gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_inter +end; +var + lROI,lVx: integer; + lStat: array of TVxStat; + lVal,loMax,hiMax: double; + lStartTime: DWord; + lBinaryOverlay: boolean; + lLabelStr,lStr: string; +begin + if (not gMRIcroOverlay[kBGOverlayNum].UsesLabels) or (High(gBGImg.LabelRA) < 1) then exit; + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP > 2) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 2) then exit; + //pointers to image data + l32Buf := SingleP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + l16Buf := SmallIntP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[lOverlayNum].ImgBufferItems then + l8Buf := gMRIcroOverlay[lOverlayNum].ImgBuffer + else + l8Buf := gMRIcroOverlay[lOverlayNum].ScrnBuffer; + + lStartTime := GetTickCount; + setlength(lStat, High(gBGImg.LabelRA)+1); + for lROI := 0 to High(gBGImg.LabelRA) do + lStat[lROI] := clearVxStat; + for lVx := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lROI :=roiIntensity(gMRIcroOverlay[kBGOverlayNum], lVx); + inc(lStat[lROI].n); + lVal := overlayIntensity(gMRIcroOverlay[lOverlayNum],lVx); + lStat[lROI].sum := lStat[lROI].sum+ lVal; + if lVal <> 0 then begin + lStat[lROI].sumNot0 := lStat[lROI].sumNot0+ lVal; + inc(lStat[lROI].nNot0); + end; + if lVal > lStat[lROI].max then + lStat[lROI].max := lVal; + if lVal < lStat[lROI].min then + lStat[lROI].min := lVal; + end; //for each voxel + //calibrate values with rescale slope/intercept, see if overlay has variablility + loMax := dPositiveInfinity; + hiMax := dNegativeInfinity; + if gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope = 0 then gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope := 1; + for lROI := 0 to High(gBGImg.LabelRA) do begin + if (lStat[lROI].nNot0 > 0) and (lStat[lROI].max > hiMax) then hiMax := lStat[lROI].max; + if (lStat[lROI].nNot0 > 0) and (lStat[lROI].min < loMax) then loMax := lStat[lROI].max; + scaleIntensity (lStat[lROI].max); + scaleIntensity (lStat[lROI].min); + scaleIntensity (lStat[lROI].sum); + scaleIntensity (lStat[lROI].sumNot0); + end; + lBinaryOverlay := (hiMax <= loMax); + if lShowFilename then begin + if gMRIcroOverlay[lOverlayNum].HdrFileName = '' then + lLabelStr := 'VOI'+kT + else + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName+kT; + end else + lLabelStr := ''; + TextForm.MemoT.Lines.add(lLabelStr+'Custom Region Analysis'); + //add header + lStr := 'Index'+kT+'Name'+kT+'numVox'+kT+'numVoxNotZero'+kT+'fracNotZero'; + if not lBinaryOverlay then + lStr := lStr+kT+'peak'+kT+'min'+kT+'mean'+kT+'meanNotZero'; + TextForm.MemoT.Lines.Add(lLabelStr+lStr); + //report values + for lROI := 0 to High(gBGImg.LabelRA) do begin + if (lStat[lROI].nNot0 > 0) then begin + lStr := inttostr(lROI)+kT+gBGImg.LabelRA[lROI] + +kT+inttostr(lStat[lROI].n)+kT+inttostr(lStat[lROI].nNot0)+kT+ realtoStr(lStat[lROI].nNot0/lStat[lROI].n,3); + if not lBinaryOverlay then + lStr := lStr+kT+floattostr(lStat[lROI].max)+kT+floattostr(lStat[lROI].min) + +kT+floattostr(lStat[lROI].sum/lStat[lROI].n) +kT+floattostr(lStat[lROI].sumNot0/lStat[lROI].nNot0); + TextForm.MemoT.Lines.Add(lLabelStr+lStr ); + end; + + end; +end; + +procedure ShowDescriptive (lOverlayNum: integer; lShowFilename: boolean); +var + lROIVol: array [1..3] of integer; + lInc: integer; + lCenterOfMass,lROISum,lROISumSqr,lROImin,lROImax:array [1..3] of double; + lCC,lVal,lSD,lROImean: double; + lLabelStr,lStr: string; +procedure AddVal( lRA: integer); +begin + inc(lROIVol[lRA]); + lROISum[lRA] := lROISum[lRA]+lVal; + lROISumSqr[lRA] := lROISumSqr[lRA] + sqr(lVal); + if lVal > lROImax[lRA] then + lROImax[lRA] := lVal; + if lVal < lROImin[lRA] then + lROImin[lRA] := lVal; +end; //proc AddVal +begin //proc ShowDescript + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + + if lShowFilename then + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName + else + lLabelStr := ''; + for lInc := 1 to 3 do begin + lROIVol[lInc] := 0; + lROISum[lInc] := 0; + lROISumSqr[lInc] := 0; + lROImin[lInc] := maxint; + lROImax[lInc] := -maxint; + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + //fx(lInc); + lVal := RawBGIntensity(lInc); + AddVal(1); + if lVal <> 0 then + AddVal(2); + if lVal > 0 then + AddVal(3); + end; //if VOI voxel + end; //for each voxel + //next - compute StDev + //compute descriptives for each set of values + if lOverlayNum = kVOIOverlayNum then + lStr := 'VOI notes ' + else + lStr := 'Overlay #'+inttostr(lOverlayNum); + if not lShowFilename then begin + TextForm.MemoT.Lines.Add(lStr+' '+gMRIcroOverlay[lOverlayNum].HdrFileName); + end; + //TextForm.Memo1.Lines.Add('CoM'); + if CenterOfMass (lOverlayNum, lCenterOfMass[1],lCenterOfMass[2],lCenterOfMass[3]) > 0 then + TextForm.MemoT.Lines.Add(' '+lLabelStr+' Center of mass XYZ '+RealToStr(lCenterOfMass[1],2)+'x'+RealToStr(lCenterOfMass[2],2)+'x'+RealToStr(lCenterOfMass[3],2)); + for lInc := 1 to 3 do begin + if lROIVol[lInc] > 1 then begin + lSD := (lROISumSqr[lInc] - ((Sqr(lROISum[lInc]))/lROIVol[lInc])); + if (lSD > 0) then + lSD := Sqrt ( lSD/(lROIVol[lInc]-1)) + else + lSD := 0; + end else + lSD := 0; + //next compute mean + if lROIVol[lInc] > 0 then begin + lROImean := lROISum[lInc]/lROIVol[lInc]; + //next - calibrate values + lROImin[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImin[lInc]); + lROIMean := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROIMean); + lROImax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImax[lInc]); + lSD := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lSD); + + end else begin //2/2008 + lROImin[lInc] := 0; + lROImax[lInc] := 0; + lROImean := 0; + end; + lcc := ((lROIVol[lInc]/1000)*gBGImg.ScrnMM[1]*gBGImg.ScrnMM[2]*gBGImg.ScrnMM[3]); + case lInc of + 3: lStr := 'VOI >0 '; + 2: lStr := 'VOI <>0 '; + else lStr := 'VOI '; + end; + lStr := lStr+' nvox(cc)=min/mean/max=SD: '+inttostr(round(lROIVol[lInc]))+kTextSep+RealToStr(lCC,2)+kTextSep+'='+kTextSep+RealToStr(lROIMin[lInc],4)+kTextSep+realToStr(lROIMean,4)+kTextSep+realToStr(lROIMax[lInc],4)+kTextSep+'='+kTextSep+realtostr(lSD,4); + TextForm.MemoT.Lines.Add(lLabelStr+ lStr); + end; + //June07 if (gMRIcroOverlay[kBGOverlayNum].UsesCustomPalette) or (lShowFilename) then + DescribeVOIonLabels(lOverlayNum,lShowfilename); + TextForm.MemoT.Lines.Add(''); + ImgForm.SaveDialog1.Filename := ExtractFileDirWithPathDelim(gMRIcroOverlay[lOverlayNum].HdrFileName)+'desc.csv'; +end; + + +procedure TImgForm.BatchROImean1Click(Sender: TObject); +var + lInc,lNumberofFiles: integer; + lFilename:string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + UpdateLayerMenu; + if not OpenDialogExecute(kImgFilter,'Select images you wish to analyze',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.MemoT.Lines.Clear; + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + OverlayOpenCore ( lFilename, 2); + ShowDescriptive(2,true); + //LayerDrop.SetItemIndex(LayerDrop.Items.Count-1); + //LayerDropSelect(nil); + end; + FreeImgMemory(gMRIcroOverlay[2]); + UpdateLayerMenu; + //SaveDialog1.Filename := ExtractFileDirWithPathDelim(HdrForm.OpenHdrDlg.Files[0])+'desc.csv'; + TextForm.Show; +end; + +procedure TImgForm.Batchprobmaps1Click(Sender: TObject); +begin + BatchVOI; +end; + +procedure TImgForm.Batchclusterprobmaps1Batchclusterprobmaps1ClickClick( + Sender: TObject); +begin + BatchCluster; +end; + +procedure TImgForm.GenerateSPM5maskslesions1Click(Sender: TObject); +begin + VOISmoothForm.SmoothVOI_SPM5masks; +end; + + +procedure TImgForm.OverlayOpenClick(Sender: TObject); +var + lFilename: string; + lOverlay,lInc: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + if not OpenDialogExecute(kImgFilter,'Select overlay image[s]',true) then exit; + if HdrForm.OpenHdrDlg.Files.Count < 1 then + exit; + for lInc := 1 to HdrForm.OpenHdrDlg.Files.Count do begin //vcx + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + LoadOverlayIncludingRGB{LoadOverlay}(lFilename); + LayerDrop.ItemIndex := (LayerDrop.Items.Count-1); + {$IFNDEF FPC} + LayerDrop.SetItemIndex(LayerDrop.Items.Count-1); + {$ELSE} + LayerDrop.ItemIndex :=(LayerDrop.Items.Count-1); + {$ENDIF} + end; + + +(* //HdrForm.OpenHdrDlg.Filter := kImgFilter; + // if not HdrForm.OpenHdrDlg.Execute then exit; + if not OpenDialogExecute(kImgFilter,'Select overlay image',false) then exit; + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + lFilename := HdrForm.OpenHdrDlg.Filename; + OverlayOpenCore ( lFilename, lOverlay); + *) + LayerDropSelect(nil); +end; //OverlayOpenClick + +procedure TImgForm.BGtrans100Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gBGImg.BGTransPct := (sender as TMenuItem).tag; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.OverlayTransClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gBGImg.OverlayTransPct := (sender as TMenuItem).tag; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LayerDropSelect(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + MaxWindowEdit.Value := gMRIcroOverlay[lLayer].WindowScaledMax; + MinWindowEdit.Value := gMRIcroOverlay[lLayer].WindowScaledMin; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then exit; + {$IFNDEF FPC} + LUTdrop.SetItemIndex(gMRIcroOverlay[lLayer].LUTindex); + {$ELSE} + LUTdrop.ItemIndex :=(gMRIcroOverlay[lLayer].LUTindex); + {$ENDIF} + //LUTinvertBtn.down := gMRIcroOverlay[lLayer].LUTinvert; + LutFromZeroBtn.down := gMRIcroOverlay[lLayer].LutFromZero; +end; + +procedure TImgForm.UpdateLayerMenu; +var + lStrings: TStringList; + lPos,lLayer:integer; +begin + lStrings := TStringList.Create; + lStrings.Add('Background'); + lLayer := 0; + for lPos := 1 to (knMaxOverlay-1) do //-1 as max overlay is VOI + if (gMRIcroOverlay[lPos].ImgBufferItems > 0) then begin + lStrings.Add(ParseFileName(ExtractFileName(gMRIcroOverlay[lPos].HdrFileName))); + inc(lLayer); + LUTdropLoad(lLayer); + end; + LayerDrop.Items := lStrings; + + {$IFNDEF FPC} + if LayerDrop.ItemIndex >= LayerDrop.Items.Count then + LayerDrop.SetItemIndex(LayerDrop.Items.Count-1); + {$ELSE} + if LayerDrop.ItemIndex >= LayerDrop.Items.Count then + LayerDrop.ItemIndex :=(LayerDrop.Items.Count-1); + {$ENDIF} + + LayerDropSelect(nil); + lStrings.Free; +end; + +procedure TImgForm.CloseOverlayImgClick(Sender: TObject); +var + lOverlay: integer; +begin + for lOverlay := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lOverlay]); + UpdateLayerMenu; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LUTdropLoad(var lLayer: integer); +var + lStr: string; +begin + (*if gMRIcroOverlay[lLayer].NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL then begin + createLutLabel (gMRIcroOverlay[lLayer], 1.0); + //RefreshImagesTimer.Enabled := true; + exit; + end; + if gMRIcroOverlay[lLayer].UsesCustomPaletteRandomRainbow then + exit; *) + if gMRIcroOverlay[lLayer].UsesCustomPalette then begin + exit; + end; + //gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + + if gMRIcroOverlay[lLayer].LUTindex < knAutoLUT then begin + LoadMonochromeLUT(gMRIcroOverlay[lLayer].LUTindex,gBGImg,gMRIcroOverlay[lLayer]); + RefreshImagesTimer.Enabled := true; + exit; + end; //if B&W lut + lStr := gColorSchemeDir+pathdelim+LUTdrop.Items.Strings[gMRIcroOverlay[lLayer].LUTindex]+'.lut'; + if not FileExistsEX(lStr) then + showmessage('Can not find '+lStr); + LoadColorScheme(lStr, gMRIcroOverlay[lLayer]); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LUTdropSelect(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + //gMRIcroOverlay[lLayer].LUTinvert := LUTinvertBtn.down; + //gMRIcroOverlay[lLayer].LutFromZero := LutFromZeroBtn.down; + LUTdropLoad(lLayer); + //RescaleImagesTimer.Enabled := true; +end; //proc LUTdropSelect + + + +procedure TImgForm.AutoContrastBtnClick(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + MinWindowEdit.Value := raw2ScaledIntensity(gMRIcroOverlay[lLayer], gMRIcroOverlay[lLayer].AutoBalMinUnscaled); + MaxWindowEdit.Value := raw2ScaledIntensity(gMRIcroOverlay[lLayer],gMRIcroOverlay[lLayer].AutoBalMaxUnscaled);{} + + gMRIcroOverlay[lLayer].WindowScaledMin := MinWindowEdit.Value; + gMRIcroOverlay[lLayer].WindowScaledMax := MaxWindowEdit.Value; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lLayer],lLayer); + + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.MinContrastWindowEditChange(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + //if gMRIcroOverlay[lLayer].WindowScaledMin = MinWindowEdit.Value then exit; + gMRIcroOverlay[lLayer].WindowScaledMin := MinWindowEdit.Value; + gMRIcroOverlay[lLayer].WindowScaledMax := MaxWindowEdit.Value; + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.MaxContrastWindowEditChange(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + if gMRIcroOverlay[lLayer].WindowScaledMax = MaxWindowEdit.Value then exit; + gMRIcroOverlay[lLayer].WindowScaledMax := MaxWindowEdit.Value; + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.OverlaySmoothMenuClick(Sender: TObject); +var + lC: integer; +begin + if Sender = nil then begin + gBGImg.OverlaySmooth := OverlaySmoothMenu.Checked; + exit; + end; + OverlaySmoothMenu.Checked := not OverlaySmoothMenu.Checked; + gBGImg.OverlaySmooth := OverlaySmoothMenu.Checked; + for lC := 1 to knMaxOverlay do + if gMRIcroOverlay[lC].ScrnBufferItems > 0 then + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lC],lC); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.ShowRenderClick(Sender: TObject); +begin + RenderForm.Show; + //RenderForm.BringToFront; +end; + +procedure TImgForm.PenBtnClick(Sender: TObject); +begin + RefreshImagesTimer.Enabled := true; +end; + +procedure OpenMRIcroROI (lFilename: string); +const + kMax12bit = 4095; + kMax16bit = (256*256)-1; + kMax15bit = kMax16bit shr 1; + //kMax20bit = (16*256*256)-1; + // k20v16bit = kMax20bit - kMax16bit; + //kMaxRuns = 10000; + //kMaxFile = 65536; + //k16v12bit = kMax16bit - kMax12bit; +var + lFile32bitItems,lFileSz,lFilePos,lSliceSz,lZ,lRunsOnSlice, + lRunLength,lRun,lRunOffset,lOutputSliceOffset,lRunPos: integer; + lROIformatRA: LongIntp; + lF: File; + lBigFormat: boolean; +begin + lFileSz := FSize(lFilename); + if (lFileSz < 1) or ((lFileSz mod 4) <> 0) then begin + showmessage('Unable to open ROI: file size should be divisible by 4.'); + exit; + end; + lFile32bitItems := lFileSz div 4; //how many 32-bit items? + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + freemem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer); + gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems := lSliceSz * lZ; + getmem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,lSliceSz * lZ); + fillchar(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,0); + if lSliceSz > 65535 then + lBigFormat := true + else + lBigFormat := false; + getmem(lROIformatRA,lFileSz); //file size must be divisible by 4 + {$I-} + AssignFile(lF, lFilename); + FileMode := 0; { Set file access to read only } + Reset(lF, 1); + BlockRead(lF,lROIformatRA^,lFileSz); + CloseFile(lF); + FileMode := 2; + {$I+} + //next: check MSB of first byte to see if this is big format images + if lBigFormat <> odd((lROIformatRA^[1] and kMax16bit) shr 15) then + Showmessage('Warning: this ROI does not appear to be designed for the currently loaded background image.'); + lFilePos := 1; +if lBigFormat then begin //20-byte offset, 12-byte runlength + while lFilePos < lFile32bitItems do begin + lRunsOnSlice := (lROIformatRA^[lFilePos] shr 17) - 1; //shr 17: shift 16 bits, then div 2 (words instead of longints). Subtract 1 as the we have read slice number/ number of runs + lZ := (lROIformatRA^[lFilePos] and kMax15bit); + inc(lFilePos); + lOutputSliceOffset := (lZ-1) * lSliceSz; + for lRun := 1 to lRunsOnSlice do begin + if (lFilePos <= lFileSz) then begin + lRunLength := (lROIformatRA^[lFilePos] shr 16) and kMax12bit; + lRunOffset := (lROIformatRA^[lFilePos] and kMax16bit)+ ((lROIformatRA^[lFilePos] shr 28) shl 16); + if (lOutputSliceOffset+lRunLength+lRunOffset-1)> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then + //showmessage('Overrun on slice '+inttostr(lZ)) + else for lRunPos := lRunOffset to (lRunLength+lRunOffset-1) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lRunPos+lOutputSliceOffset] := kVOI8bit; + end; + inc(lFilePos); + end;//for all runs + end; //while lPos < lFSz +end else begin //not big format format - 16-byte offset, 16-byte length + while lFilePos < lFile32bitItems do begin + //lRunsOnSlice := (lROIformatRA[lFilePos] shr 16) and kMax16bit; + lRunsOnSlice := (lROIformatRA^[lFilePos] shr 17) - 1; //shr 17: shift 16 bits, then div 2 (words instead of longints). Subtract 1 as the we have read slice number/ number of runs + lZ := (lROIformatRA^[lFilePos] and kMax15bit); + inc(lFilePos); + lOutputSliceOffset := (lZ-1) * lSliceSz; + //showmessage(inttostr(lZ)+' '+inttostr(lRunsOnSlice)+' '+inttostr(lFilePos)+' '+inttostr(lFileSz)); + for lRun := 1 to lRunsOnSlice do begin + if (lFilePos <= lFileSz) then begin + lRunLength := (lROIformatRA^[lFilePos] shr 16) and kMax16bit; + lRunOffset := (lROIformatRA^[lFilePos] and kMax16bit); + {if (lRunLength+lRunOffset-1)> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then + showmessage('Overrun on slice '+inttostr(lZ)) + else} for lRunPos := lRunOffset to (lRunLength+lRunOffset-1) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lRunPos+lOutputSliceOffset] := kVOI8bit; + end; + inc(lFilePos); + end;//for all runs + end; //while lPos < lFSz +end; //if bigformat ... else little format + freemem(lROIformatRA); + lRun := maxint; + LoadMonochromeLUT(lRun,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); +end; + +procedure TImgForm.OpenVOICore(var lFilename : string); +var + lExt: string; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + ImgForm.CloseVOIClick(nil); + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if (lExt='.ROI') then begin + Showmessage('Warning: MRIcro ROI format does not save image dimensions. The background image must be in the same dimensions as the ROI.'); + OpenMRIcroROI (lFileName); + ImgForm.RefreshImagesTimer.Enabled := true; + exit; + end; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kVOIOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[kVOIOverlayNum],false,true,false,gBGImg.ResliceOnLoad,false) then exit; + ImgForm.RefreshImagesTimer.Enabled := true; +end;//OpenVOIClick + + +procedure TImgForm.OpenVOIClick(Sender: TObject); +var + lFilename: string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding a VOI.'); + exit; + end; + //HdrForm.OpenHdrDlg.Filter := '*.roi';//kVOIFilter; + //if not HdrForm.OpenHdrDlg.Execute then exit; + if not OpenDialogExecute(kVOIFilter,'Select Volume of Interest drawing',false) then exit; + lFilename := HdrForm.OpenHdrDlg.Filename; + OpenVOICore(lFilename); +end;//OpenVOIClick + +(*procedure TImgForm.SaveVOIClick(Sender: TObject); +var lHdr: TMRIcroHdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); + Freemem(lHdr.ScrnBuffer); + exit; //sept2007 + end; + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end;*) +procedure TImgForm.SaveVOIcore(lPromptFilename: boolean); + var lHdr: TMRIcroHdr; + lNIFTIhdr: TNIFTIhdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + //Start 10/2007: adjust scl_slope;? 10/2007 + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + lNIFTIhdr.scl_slope := 1; + lNIFTIhdr.scl_inter := 0; + //end + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + if lPromptFilename then + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,lNIFTIhdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName) + else + SaveAsVOIorNIFTIcore(gMRIcroOverlay[kVOIOverlayNum].HdrFileName,lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,lNIFTIhdr); + Freemem(lHdr.ScrnBuffer); + exit; //12/2010 + end; + if lPromptFilename then + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,lNiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName) + else + SaveAsVOIorNIFTIcore(gMRIcroOverlay[kVOIOverlayNum].HdrFileName,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,lNiftiHdr); +end; + +procedure TImgForm.Extract1Click(Sender: TObject); +var + lMin : smallint; + lOtsuLevels,lnVox,lVox,lDilate: integer; + lOneContiguousObject : boolean; + l16Buf : SmallIntP; + l32Buf : SingleP; + lMinS: single; +begin + lnVox := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lnVox < 9 then begin + showmessage('Please load a background image.'); + exit; + end; + lOtsuLevels := ReadIntForm.GetInt('Otsu levels: larger values for larger volumes',1,4,5); + lDilate := ReadIntForm.GetInt('Edge dilation voxels: larger values for larger volumes',0,2,12); + lOneContiguousObject := OKMsg('Only extract single largest object?'); + //MaskBackground (var lImg: Bytep; lXi,lYi,lZi,lOtsuLevels: integer; lDilateVox: single; lOneContiguousObject: boolean ); + MaskBackground(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer, gBGImg.ScrnDim[1],gBGImg.ScrnDim[2],gBGImg.ScrnDim[3],lOtsuLevels,lDilate,lOneContiguousObject); + + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + lMinS := l32Buf^[1]; + for lVox := 1 to lnVox do + if l32Buf^[lVox] < lMinS then + lMinS := l32Buf^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + l32Buf^[lVox] := lMinS; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + lMin := l16Buf^[1]; + for lVox := 1 to lnVox do + if l16Buf^[lVox] < lMin then + lMin := l16Buf^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + l16Buf^[lVox] := lMin; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then begin + lMin := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[1]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox] < lMin then + lMin := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox] := lMin; + + end; +end; + +procedure TImgForm.NewWindow1Click(Sender: TObject); +{$IFDEF Darwin} +var + AProcess: TProcess; + i : integer; + //http://wiki.freepascal.org/Executing_External_Programs +begin + AProcess := TProcess.Create(nil); + AProcess.InheritHandles := False; + //AProcess.Options := [poNoConsole]; //poNoConsole is Windows only! http://lazarus-ccr.sourceforge.net/docs/fcl/process/tprocess.options.html + //AProcess.ShowWindow := swoShow; //Windows only http://www.freepascal.org/docs-html/fcl/process/tprocess.showwindow.html + for I := 1 to GetEnvironmentVariableCount do + AProcess.Environment.Add(GetEnvironmentString(I)); + AProcess.Executable := 'open'; + AProcess.Parameters.Add('-n'); + AProcess.Parameters.Add('-a'); + AProcess.Parameters.Add(paramstr(0)); + AProcess.Execute; + AProcess.Free; +end; +{$ELSE} +begin + //only OSX/Darwin +end; +{$ENDIF} + +procedure TImgForm.ToggleDrawMenu(Sender: TObject); +begin + gBGImg.ShowDraw := not DrawMenu.Visible; + WriteIni2Form(gBGImg); +end; + +procedure TImgForm.SaveVOIClick(Sender: TObject); + var lHdr: TMRIcroHdr; + lNIFTIhdr: TNIFTIhdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + //Start 10/2007: adjust scl_slope;? 10/2007 + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + lNIFTIhdr.scl_slope := 1; + lNIFTIhdr.scl_inter := 0; + //end + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,lNIFTIhdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); + Freemem(lHdr.ScrnBuffer); + exit; //sept2007 + end; + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,lNiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end; + +procedure TImgForm.VOIColorClick(Sender: TObject); +var + lMaxi: longint; +begin + ColorDialog1.Color := gBGImg.VOIClr; + if not ColorDialog1.Execute then exit; + gBGImg.VOIClr := ColorDialog1.Color; + if gBGImg.VOIClr = clBlack then + gBGImg.VOIClr := 1; //reserve 0 for deleting + lMaxi:=maxint; + LoadMonochromeLUT(lMaxi,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.CloseVOIClick(Sender: TObject); +begin + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems>0) and (gBGImg.VOIChanged) then begin + case MessageDlg('Do you wish to save the VOI drawing?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + {id_Yes}mrYes: SaveVOIClick(nil); + end; //case + end;//if changed + FreeUndoVol; + FreeImgMemory(gMRIcroOverlay[kVOIOverlayNum]); + gBGImg.VOIUndoSlice := 0; + gBGImg.VOIchanged := false; + gBGImg.VOIUndoOrient := 0; + RefreshImagesTimer.Enabled := true; +end; + +procedure ImageRB (var lMaxR,lMaxB: integer; var lImage: TImage); +var + lPos: integer; +begin + if not lImage.Visible then + exit; + lPos := lImage.Left+lImage.Width; + if lPos > lMaxR then + lMaxR := lPos; + lPos := lImage.Top+lImage.Height; + if lPos > lMaxB then + lMaxB := lPos; +end; + +procedure CopyImg(var lSourceImg,lDestImg: TImage); +var + lPos: integer; +begin + if not lSourceImg.Visible then + exit; + lDestImg.Canvas.Draw(lSourceImg.Left,lSourceImg.Top,lSourceImg.Picture.Graphic); +end; + +procedure TImgForm.SaveOrCopyImages(lCopy: boolean); +var + lMaxR,lMaxB: integer; + lOutImg: TImage; +begin + lMaxR := 0; + lMaxB := 0; + ImageRB(lMaxR,lMaxB,ImgForm.PGImageAx); + ImageRB(lMaxR,lMaxB,ImgForm.PGImageCor); + ImageRB(lMaxR,lMaxB,ImgForm.PGImageSag); + if (lMaxR < 1) or (lMaxB < 1) then + exit; + lOutImg := TImage.Create(ImgForm); + try + //use the object + {$IFDEF FPC} + lOutImg.Width := lMaxR; + lOutImg.Height := lMaxB; + {$ELSE} + CreateImg(lMaxB,lMaxR,lOutImg); + {$ENDIF} + lOutImg.Canvas.Brush.color := ImgForm.TriplePanel.color; + lOutImg.Canvas.Rectangle(0,0,lMaxR+1,lMaxB+1); + CopyImg(ImgForm.PGImageAx,lOutImg); + CopyImg(ImgForm.PGImageCor,lOutImg); + CopyImg(ImgForm.PGImageSag,lOutImg); + if lCopy then begin + {$IFDEF FPC} + lOutImg.Picture.Bitmap.SaveToClipboardFormat(2); + //Clipboard.Assign(lOutImg.Picture.Bitmap); + {$ENDIF} + Clipboard.Assign(lOutImg.Picture.Graphic); + end else + SaveImgAsPNGBMP (lOutImg); + finally + FreeAndNil (lOutImg); + end; +end; + +procedure TImgForm.Saveaspicture1Click(Sender: TObject); +begin + SaveOrCopyImages(false); +end; +(*var + lImage: TImage; +begin + lImage := SelectedImage; + SaveImgAsPNGBMP (lImage); +end; //Proc Saveaspicture1Click +*) +procedure TImgForm.Copy1Click(Sender: TObject); //Requires 'ClipBrd' in uses section +begin + SaveOrCopyImages(true); +end; + +(*procedure TImgForm.Copy1Click(Sender: TObject); //Requires 'ClipBrd' in uses section +var + MyFormat : Word; + lImage: TImage; + AData: THandle; + {$IFNDEF FPC}APalette : HPalette;{$ENDIF} +begin + lImage := SelectedImage; + if (lImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + {$IFNDEF FPC} + lImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); + {$ELSE} + lImage.Picture.Bitmap.SaveToClipboardFormat(2); + {$ENDIF} + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems>0) then + WriteUndoVOI(SelectedImageNum,false); + +end; *) + +procedure TImgForm.Undo1Click(Sender: TObject); +begin + if gBGImg.VOIUndoSlice < 1 then exit; + case gBGImg.VOIUndoOrient of + 4: UndoVolVOI; + 3: ReadCorVOI(gUndoImg,gBGImg.VOIUndoSlice); + 2: ReadSagVOI(gUndoImg,gBGImg.VOIUndoSlice); + 1: ReadAxialVOI(gUndoImg,gBGImg.VOIUndoSlice); + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.Paste1Click(Sender: TObject); +begin + if (gBGImg.VOIUndoSlice < 1) then exit; + if gBGImg.VOIUndoOrient <> SelectedImageNum then //12/2007 + exit; + WriteUndoVOI(SelectedImageNum,true); + case gBGImg.VOIUndoOrient of + 3: ReadCorVOI(gDrawImg,ImgForm.YViewEdit.Value); + 2: ReadSagVOI(gDrawImg,ImgForm.XViewEdit.Value); + 1: ReadAxialVOI(gDrawImg,ImgForm.ZViewEdit.Value); + else exit; + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.HideROIBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + gOrigBGTransPct := gBGImg.BGTransPct; + gBGImg.BGTransPct := 100; + refreshimagestimer.enabled := true; +end; + +procedure TImgForm.HideROIBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + gBGImg.BGTransPct := gOrigBGTransPct; + Refreshimagestimer.enabled := true; +end; + +procedure TImgForm.Applyintensityfiltertovolume1Click(Sender: TObject); +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + showmessage('You must have open a background image in order to apply an intensity filter (use File/Open).'); + exit; + end; + FilterROIform.showmodal; +end; + +procedure TImgForm.Quicksmooth1Click(Sender: TObject); +var + lHdr: TMRicroHdr; + lXDim,lYDim,lZDim,lSum,lMinWt,lMaxWt,lMinInten,lMaxInten,lOutVolVox,lOutSliceSz,lX,lY,lZ,lXxi,l2,lZyi: integer; + lSum32,lMinInten32,lMaxInten32: single; + lTempBuff,lSrcBuff: Bytep; + l16TempBuff,l16SrcBuff: SmallIntP; + l32TempBuff,l32SrcBuff: SingleP; +procedure AddPoint (lInten,lWeight:integer); +begin + lSum := lSum + (lInten*lWeight); + if lInten <= lMinInten then begin + lMinWt := lWeight; + lMinInten := lInten; + end else if lInten >= lMaxInten then begin + lMaxWt := lWeight; + lMaxInten := lInten; + end; +end; //nested AddPoint +procedure AddPoint32 (lInten32: single; lWeight:integer); +begin + lSum32 := lSum32 + (lInten32*lWeight); + if lInten32 <= lMinInten32 then begin + lMinWt := lWeight; + lMinInten32 := lInten32; + end else if lInten32 >= lMaxInten32 then begin + lMaxWt := lWeight; + lMaxInten32 := lInten32; + end; +end; //nested AddPoint32 +begin + lHdr := gMRIcroOverlay[kBGOverlayNum]; + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lOutSliceSz := gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2]; + lOutVolVox := lOutSliceSz * lZDim; + if (lXDim < 3) or (lYDim < 3) or (lZDim < 3) or (lOutVolVox < 36) then begin + showmessage('The 3D smoothing can only be applied to images with at least 3 slices in each dimension.'); + exit; + end; + if (lHdr.ImgBufferItems < 1) then begin + showmessage('Please first load the image you would like to smooth.'); + exit; + end; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lZDim; + StatusLabel.caption := 'Removing noise speckles and smoothing data [blur]'; + if lHdr.ImgBufferBPP = 4 then begin //32-bit float data + l32SrcBuff := SingleP(lHdr.ImgBuffer); + GetMem(l32TempBuff,lOutVolVox*sizeof(single)); + Move(l32SrcBuff^,l32TempBuff^,lOutVolVox*sizeof(single)); + for lZ := 1 to lOutVolVox do + l32SrcBuff^[lZ] := 0; + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum32 := 0; + lMinInten32 := l32TempBuff^[lXxi]; + lMaxInten32 := l32TempBuff^[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint32(l32TempBuff^[lXxi],12);//quad-weight center + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz],2);//prev slice + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz],2);//next slices + AddPoint32(l32TempBuff^[lXxi-1],2);//Left + AddPoint32(l32TempBuff^[lXxi+1],2);//right + AddPoint32(l32TempBuff^[lXxi-lXDim],2);//up + AddPoint32(l32TempBuff^[lXxi+lXDim],2);//down + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz-1],1); + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz+1],1); + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz-lXDim],1); + AddPoint32(l32TempBuff^[lXxi-lOutSliceSz+lXDim],1); + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz-1],1); + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz+1],1); + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz-lXDim],1); + AddPoint32(l32TempBuff^[lXxi+lOutSliceSz+lXDim],1); + AddPoint32(l32TempBuff^[lXxi-lXDim-1],1); + AddPoint32(l32TempBuff^[lXxi+lXDim-1],1); + AddPoint32(l32TempBuff^[lXxi-lXDim+1],1); + AddPoint32(l32TempBuff^[lXxi+lXDim+1],1); + if lMinInten32 = lMaxInten32 then + l32SrcBuff^[lXxi] := lMaxInten32 //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum32 := lSum32 -(lMinWt*lMinInten32) - (lMaxWt*lMaxInten32); //exclude brightest/darkest + l32SrcBuff^[lXxi] := (lSum32/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(l32TempBuff); + end else if (lHdr.ImgBufferBPP = 2) then begin //16-bit int data*) + l16SrcBuff := SmallIntP(lHdr.ImgBuffer ); + GetMem(l16TempBuff,lOutVolVox*sizeof(word)); + Move(l16SrcBuff^,l16TempBuff^,lOutVolVox*sizeof(word)); + for lZ := 1 to lOutVolVox do + l16SrcBuff^[lZ] := 0; + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum := 0; + lMinInten := l16TempBuff^[lXxi]; + lMaxInten := l16TempBuff^[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint(l16TempBuff^[lXxi],12);//quad-weight center + AddPoint(l16TempBuff^[lXxi-lOutSliceSz],2);//prev slice + AddPoint(l16TempBuff^[lXxi+lOutSliceSz],2);//next slices + AddPoint(l16TempBuff^[lXxi-1],2);//Left + AddPoint(l16TempBuff^[lXxi+1],2);//right + AddPoint(l16TempBuff^[lXxi-lXDim],2);//up + AddPoint(l16TempBuff^[lXxi+lXDim],2);//down + AddPoint(l16TempBuff^[lXxi-lOutSliceSz-1],1); + AddPoint(l16TempBuff^[lXxi-lOutSliceSz+1],1); + AddPoint(l16TempBuff^[lXxi-lOutSliceSz-lXDim],1); + AddPoint(l16TempBuff^[lXxi-lOutSliceSz+lXDim],1); + AddPoint(l16TempBuff^[lXxi+lOutSliceSz-1],1); + AddPoint(l16TempBuff^[lXxi+lOutSliceSz+1],1); + AddPoint(l16TempBuff^[lXxi+lOutSliceSz-lXDim],1); + AddPoint(l16TempBuff^[lXxi+lOutSliceSz+lXDim],1); + AddPoint(l16TempBuff^[lXxi-lXDim-1],1); + AddPoint(l16TempBuff^[lXxi+lXDim-1],1); + AddPoint(l16TempBuff^[lXxi-lXDim+1],1); + AddPoint(l16TempBuff^[lXxi+lXDim+1],1); + if lMinInten = lMaxInten then + l16SrcBuff^[lXxi] := lMaxInten //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum := lSum -(lMinWt*lMinInten) - (lMaxWt*lMaxInten); //exclude brightest/darkest + l16SrcBuff^[lXxi] := round(lSum/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(l16TempBuff); + //OptimizeSingle(nil); + end else if lHdr.ImgBufferBPP = 1 then begin //8-bit data + lSrcBuff := lHdr.ImgBuffer; + GetMem(lTempBuff,lOutVolVox); + Move(lSrcBuff^,lTempBuff^,lOutVolVox); + fillchar(lSrcBuff^,lOutVolVox,0); //set edges to 0, as outside voxel is not smoothed + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum := 0; + lMinInten := lTempBuff^[lXxi]; + lMaxInten := lTempBuff^[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint(lTempBuff^[lXxi],12);//quad-weight center + AddPoint(lTempBuff^[lXxi-lOutSliceSz],2);//prev slice + AddPoint(lTempBuff^[lXxi+lOutSliceSz],2);//next slices + AddPoint(lTempBuff^[lXxi-1],2);//Left + AddPoint(lTempBuff^[lXxi+1],2);//right + AddPoint(lTempBuff^[lXxi-lXDim],2);//up + AddPoint(lTempBuff^[lXxi+lXDim],2);//down + AddPoint(lTempBuff^[lXxi-lOutSliceSz-1],1); + AddPoint(lTempBuff^[lXxi-lOutSliceSz+1],1); + AddPoint(lTempBuff^[lXxi-lOutSliceSz-lXDim],1); + AddPoint(lTempBuff^[lXxi-lOutSliceSz+lXDim],1); + AddPoint(lTempBuff^[lXxi+lOutSliceSz-1],1); + AddPoint(lTempBuff^[lXxi+lOutSliceSz+1],1); + AddPoint(lTempBuff^[lXxi+lOutSliceSz-lXDim],1); + AddPoint(lTempBuff^[lXxi+lOutSliceSz+lXDim],1); + AddPoint(lTempBuff^[lXxi-lXDim-1],1); + AddPoint(lTempBuff^[lXxi+lXDim-1],1); + AddPoint(lTempBuff^[lXxi-lXDim+1],1); + AddPoint(lTempBuff^[lXxi+lXDim+1],1); + if lMinInten = lMaxInten then + lSrcBuff^[lXxi] := lMaxInten //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum := lSum -(lMinWt*lMinInten) - (lMaxWt*lMaxInten); //exclude brightest/darkest + lSrcBuff^[lXxi] := round(lSum/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(lTempBuff); + end else begin //8bit data + showmessage('Unknown bits per pixel '+inttostr(lHdr.ImgBufferBPP) ); + end; + ProgressBar1.Position := 0; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[kBGOverlayNum],kBGOverlayNum); + RefreshImagesTimer.Enabled := true; +end; //quicksmooth + +procedure TImgForm.VOImaskClick(Sender: TObject); +var + lPreserve: integer; + lHdr,lMaskHdr: TMRicroHdr; + lXDim,lYDim,lZDim,lOutVolVox,lOutSliceSz,lZ: integer; + lSrcBuff,lMaskBuff: Bytep; + l16SrcBuff: SmallIntP; + l32SrcBuff: SingleP; +begin + lPreserve := (sender as TMenuItem).tag; + lHdr := gMRIcroOverlay[kBGOverlayNum]; + lMaskHdr := gMRIcroOverlay[kVOIOverlayNum]; + + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lOutSliceSz := gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2]; + lOutVolVox := lOutSliceSz * lZDim; + if (lXDim < 2) or (lYDim < 2) or (lZDim < 2) then begin + showmessage('Masking can only be applied to images with multiple slices in 3 dimensions.'); + exit; + end; + if (lHdr.ImgBufferItems <> lMaskHdr.ScrnBufferItems) or (lHdr.ImgBufferItems < 8) then begin + showmessage('Please first load both an image (File/Open) and a masking VOI (Draw/Open).'); + exit; + end; + if gBGImg.Mirror then + MirrorScrnBuffer(gBGImg,lMaskHdr);//4/2008 + lMaskBuff := (lMaskHdr.ScrnBuffer); + ProgressBar1.Min := 0; + ProgressBar1.Max :=lZDim; + StatusLabel.caption := 'Masking data'; + if lHdr.ImgBufferBPP = 4 then begin //32-bit float data + l32SrcBuff := SingleP(lHdr.ImgBuffer); + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] = 0 then + l32SrcBuff^[lZ] := 0; + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] <> 0 then + l32SrcBuff^[lZ] := 0; + end; //if preserve + end else if (lHdr.ImgBufferBPP = 2) then begin //16-bit int data*) + l16SrcBuff := SmallIntP(lHdr.ImgBuffer ); + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] = 0 then + l16SrcBuff^[lZ] := 0; + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] <> 0 then + l16SrcBuff^[lZ] := 0; + end; + end else if lHdr.ImgBufferBPP = 1 then begin //8-bit data + lSrcBuff := lHdr.ImgBuffer; + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] = 0 then + lSrcBuff^[lZ] := 0 + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff^[lZ] <> 0 then + lSrcBuff^[lZ] := 0; + end; + end else begin //8bit data + showmessage('Unknown bits per pixel '+inttostr(lHdr.ImgBufferBPP) ); + end; + if gBGImg.Mirror then + MirrorScrnBuffer(gBGImg,lMaskHdr);//4/2008 + + ProgressBar1.Position := 0; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[kBGOverlayNum],kBGOverlayNum); + RefreshImagesTimer.Enabled := true; +end; //VOImaskClick + +procedure TImgForm.Sagittal1Click(Sender: TObject); +begin + gBGImg.SliceView := (Sender as TMenuItem).Tag; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.ROIcomparisonClick(Sender: TObject); +var lComparison,lVolItems,lOverlay,lnOverlays,lPos: integer; +begin + lComparison := (Sender as TMenuItem).tag; //0=intersect AND,1=union OR ,2=mask + lVolItems := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]* gBGImg.ScrnDim[3]; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lVolItems) or (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems <> lVolItems) then begin + Showmessage('VOI comparisons require a VOI loaded onto a background image (Draw/Open).'); + exit; + end; + lnOverlays := 0; + for lOverlay := 1 to knMaxOverlay do + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then + inc(lnOverlays); + if (lnOverlays = 0) then begin + Showmessage('VOI comparisons require loaded overlays (Overlay/Add).'); + exit; + end; + CreateUndoVol; + if lComparison = 0 then begin //intersect AND + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lPos] = 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lPos] := 0; + end; //if overlay loaded + end; //for each overlay + end else if lComparison = 1 then begin //if intersect else UNION OR + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lPos] > 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lPos] := kVOI8bit; + end; //if overlay loaded + end; //for each overlay + end else if lComparison = 2 then begin //if union else MASK + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lPos] > 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lPos] := 0; + end; //if overlay loaded + end; //for each overlay + end; //if ..else MASK + RefreshImagesTimer.Enabled := true; +end; //ROIcomparisonClick + +procedure TImgForm.RescaleImagesTimerTimer(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + RescaleImagesTimer.Enabled := false; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lLayer],lLayer); + RefreshImages; +end; + +procedure TImgForm.Fill3DBtnClick(Sender: TObject); +begin + AutoROIForm.Show; +end; + + +procedure TImgForm.SmoothVOI1Click(Sender: TObject); +begin + voismoothform.showmodal; + //SmoothVOIForm.Showmodal +end; + +procedure TImgForm.CreateOverlap(Sender: TObject); +var + lNumberofFiles,lC,lOverlay,lPos: integer; + lFilename,lExt: string; + lOverlapBuffer: ByteP; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + if not OpenDialogExecute(kVOIFilter,'Select VOIs you wish to combine',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + exit; + end; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + getmem(lOverlapBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems); + fillchar(lOverlapBuffer^,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems,0); + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lOverlay]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[lOverlay],false,false,false,gBGImg.ResliceOnLoad,false) then exit; + ProgressBar1.Position := lC; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer^[lPos] > 0 then + lOverlapBuffer^[lPos] := lOverlapBuffer^[lPos]+1; + FreeImgMemory(gMRIcroOverlay[lOverlay]); + end; //for each image + //July07 getmem for unaligned buffer getmem(gMRIcroOverlay[lOverlay].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems); + GetMem(gMRIcroOverlay[lOverlay].ImgBufferUnaligned ,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems + 16); //July072007 + //gMRIcroOverlay[lOverlay].ImgBuffer := ByteP($fffffff0 and (integer(gMRIcroOverlay[lOverlay].ImgBufferUnaligned)+15)); + gMRIcroOverlay[lOverlay].ImgBuffer := system.align(gMRIcroOverlay[lOverlay].ImgBufferUnaligned, 16); + gMRIcroOverlay[lOverlay].ImgBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + gMRIcroOverlay[lOverlay].ImgBuffer[lPos] := lOverlapBuffer[lPos]; + freemem(lOverlapBuffer); + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay],0, lNumberofFiles,1,0,0,kNIFTI_INTENT_ESTIMATE,'N'+inttostr(lNumberofFiles) ); + UpdateLayerMenu; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lOverlay],lOverlay); + ProgressBar1.Position := 0; + //SaveAsVOIorNIFTI(gMRIcroOverlay[lOverlay].ImgBuffer,gMRIcroOverlay[lOverlay].ScrnBufferItems,1,false,gMRIcroOverlay[lOverlay].niftiHdr,'sum'+inttostr(lNumberofFiles)); + SaveAsVOIorNIFTI(gMRIcroOverlay[lOverlay].ImgBuffer,gMRIcroOverlay[lOverlay].ScrnBufferItems,1,1,false,gMRIcroOverlay[lOverlay].niftiHdr,'sum'+inttostr(lNumberofFiles)); + RefreshImagesTimer.Enabled := true; +end;//proc CreateOverlap + +procedure TImgForm.Chisquare1Click(Sender: TObject); +var + lNegativeNumbers: boolean; + lVolVoxels,lPos,lnTotalThreshold,lLoop,lnVoxelsTested:integer; + lMinExp,lChi,lChip,luChi, luChiP: double; + lMaxChi,lMinChi: single; + lBufferAligned,lBufferUnAligned,lBuffer: ByteP; + l32Buf : SingleP; + lFilename: string; + lTotal,lYes,lNo: array [1..2] of integer; + lMRIcroHdr: TMRIcroHdr; +begin + lVolVoxels := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lVolVoxels < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + CloseOverlayImgClick(nil); + for lLoop := 1 to 2 do begin //open two images + if lLoop = 1 then begin + if not OpenDialogExecute(kImgFilter,'Select POSITIVE overlap image',false) then exit + end else begin + if not OpenDialogExecute(kImgFilter,'Select NEGATIVE overlap image',false) then exit; + end; + lFilename := HdrForm.OpenHdrDlg.Filename; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lLoop]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[lLoop],false,false,true,gBGImg.ResliceOnLoad,false) then exit; + lTotal[lLoop] := round(gMRIcroOverlay[lLoop].NIFTIhdr.glmax); + if (gMRIcroOverlay[lLoop].NIFTIhdr.intent_code <> kNIFTI_INTENT_ESTIMATE) then + showmessage('Warning: header intent_code is not set to ESTIMATE. Compute Chi-squared only with cumulative maps created with this program.'); + if (gMRIcroOverlay[lLoop].NIFTIhdr.intent_name[1] <> 'N') then + showmessage('Warning: header intention not N. Compute Chi-squared only with cumulative maps created with this program.'); + UpdateLayerMenu; + RefreshImagesTimer.Enabled := true; + end; + if (lVolVoxels<> gMRIcroOverlay[1].ScrnBufferItems) + or (lVolVoxels<> gMRIcroOverlay[2].ScrnBufferItems) then begin + showmessage('Error loading images.'); + exit; + end; + //next - chi squared + lnTotalThreshold:= ReadIntForm.GetInt('Only test voxels damaged in at least N patients [A+B]', 1,1,(lTotal[1]+lTotal[2])); + GetMem(lBufferUnaligned ,(lVolVoxels *sizeof(single) )+16); + //lBufferAligned := ByteP($fffffff0 and (integer(lBufferUnaligned)+15)); + lBufferAligned := system.align(lBufferUnaligned, 16); + l32Buf := SingleP(lBufferAligned); + lnVoxelsTested := 0; + lNegativeNumbers := false; + lMaxChi := 0; + lMinChi := 0; + for lPos := 1 to lVolVoxels do begin + l32Buf^[lPos] := 0; + lYes[1] := gMRIcroOverlay[1].ScrnBuffer^[lPos]; + lNo[1] := lTotal[1]-lYes[1]; + lYes[2] := gMRIcroOverlay[2].ScrnBuffer^[lPos]; + lNo[2] := lTotal[2]-lYes[2]; + if (lYes[1] < 0) or (lNo[1] < 0) or (lYes[2] < 0) or (lNo[2] < 0) then + lNegativeNumbers := true + else if (lYes[1]+lYes[2]) >= lnTotalThreshold then begin//e.g. at least 30% of all patients + inc(lnVoxelsTested); + //showmessage(inttostr(lYes[1])+'x'+inttostr(lNo[1])+'x'+ inttostr(lYes[2])+'x'+inttostr(lNo[2]) ); + Chi2x2 (lYes[1], lNo[1], lYes[2], lNo[2],lMinExp,lChi,lChip,luChi, luChiP); + if (luChi) > lMaxChi then + lMaxChi := (luChi) + else if (luChi < lMinChi) then + lMinChi := luChi; + if (lYes[1]/lTotal[1]) > (lYes[2]/lTotal[2]) then + l32Buf^[lPos] := luChi//100-(100*luChip) //positives more likely than negative + else + l32Buf^[lPos] := -luChi;//-100+(100*luChip); //negatives more common + end;//> threshold + end; //for each voxel + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,lMinChi, lMaxChi,1{df},0,lnVoxelsTested,kNIFTI_INTENT_CHISQ,inttostr(lnVoxelsTested) ); + if lNegativeNumbers then + Showmessage('Serious error: some group sizes were negative. This should be impossible with a Chi-Squared.'); + //SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,false,lMRIcroHdr.NiftiHdr,'chi'+inttostr(lnTotalThreshold)); + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(lnTotalThreshold)); + //next - save log10 p values... + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,lMinChi, lMaxChi,1{df},0,lnVoxelsTested,NIFTI_INTENT_LOG10PVAL,inttostr(lnVoxelsTested) ); + for lPos := 1 to lVolVoxels do + if l32Buf^[lPos] > 0 then + l32Buf^[lPos] := -log(abs(gammq(0.5, 0.5 * l32Buf^[lPos])),10) + else + l32Buf^[lPos] :=0; + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(lnTotalThreshold)); + //next - free float buffer + FreeMem(lBufferUnaligned); + StatusLabel.Caption := 'Voxels tested: '+inttostr(lnVoxelsTested); + //next - subtraction + GetMem(lBuffer ,(lVolVoxels )); + lNegativeNumbers := false; + fillchar(lBuffer^,lVolVoxels,100); + for lPos := 1 to lVolVoxels do begin + lYes[1] := gMRIcroOverlay[1].ScrnBuffer^[lPos]; + lNo[1] := lTotal[1]-lYes[1]; + lYes[2] := gMRIcroOverlay[2].ScrnBuffer^[lPos]; + lNo[2] := lTotal[2]-lYes[2]; + if (lYes[1] < 0) or (lNo[1] < 0) or (lYes[2] < 0) or (lNo[2] < 0) then + lNegativeNumbers := true + else if (lYes[1] >0) or (lYes[2] > 0) then begin + lBuffer^[lPos] := round((100* ((lYes[1]/lTotal[1])-(lYes[2]/lTotal[2])))+100); + end;//> threshold + end; //for each voxel + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,-100, 100,1,0,0,kNIFTI_INTENT_ESTIMATE,'%'+inttostr(lTotal[1])+':'+inttostr(lTotal[2]) ); + lMRIcroHdr.NIFTIhdr.scl_inter:= -100; + if lNegativeNumbers then + Showmessage('Serious error: some group sizes were negative. This should be impossible with a subtraction analysis.'); + SaveAsVOIorNIFTI(lBuffer,lVolVoxels,1,1,false,lMRIcroHdr.NiftiHdr,'Sub'+inttostr(lTotal[1])+'_'+inttostr(lTotal[2])); + FreeMem(lBuffer); +end; //procedure Chisquare1Click + +procedure Paris(lFilename: string); +begin + ImgForm.CloseImagesClick(nil); + + ImgForm.OpenAndDisplayImg(lFilename,True); + ImgForm.caption := 'x'; + //if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kBGOverlayNum]) then exit; + ImgForm.Caption := 'y'; +end; + +procedure Normandy; +begin + gBGImg.Prompt4DVolume := false; + gBGImg.Resliced :=true; + paris('/Users/rorden/downloads/fx/DBM8768/DBM8768_DIFFUSION AX PRE PERFUSION.nii.gz'); + gBGImg.Prompt4DVolume := true; +end; + +procedure TImgForm.ROIVOI1Click(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + Normandy; + exit; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + if gBGImg.Resliced then begin + if not HdrForm.OpenAndDisplayHdr(gMRIcroOverlay[kBGOverlayNum].HdrFileName,gMRIcroOverlay[kBGOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false) then exit; + end; + showmessage('Warning: the currently open background image must have the dimensions (size, space between slices, etc) as the image used when creating the ROIs.'); + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + CloseVOIClick(nil); + if not OpenDialogExecute('MRIcro ROI (.roi)|*.roi','Select MRIcro format ROIs to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + OpenMRIcroROI (lFileName); + lFilename := changefileextX(lFilename,'.voi'); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end; + +procedure TImgForm.LUTinvertBtnClick(Sender: TObject); +begin +end; //proc LUTdropSelect + +procedure TImgForm.LutFromZeroBtnClick(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + gMRIcroOverlay[lLayer].LUTfromZero := LUTfromZeroBtn.down; + LUTdropLoad(lLayer); + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.ShowMultisliceClick(Sender: TObject); +begin +(* if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + MultiSliceForm.MultiImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + MultiSliceForm.MultiImage.canvas.font.Color := gBGImg.XBarClr;*) + MultiSliceForm.Show; + //MultiSliceForm.BringToFront; +end; + +function RawBGIntensity(lPos: integer): single; +var + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + result := 0; + if (lPos > gMRIcroOverlay[kBGOverlayNum].ImgBufferItems) or (lPos < 1) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l32Buf^[lPos]; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l16Buf^[lPos]; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then + result := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos] + else begin + showmessage('Unknown Background Buffer Bytes Per Pixel'); + exit; + end; +end; + +(*procedure DescribeVOIonLabelsX (lOverlayNum: integer); +var + lShowfilename: boolean = true; + lLocalMax,lLocalSum : HistoDoubleRA; + l16Buf : SmallIntP; + l32Buf : SingleP; + l8Buf: byteP; + lInten: double; + lXmm,lYmm,lZmm: single; + lHisto,lRegionVol,lLocalMaxPos: HistoRA; + lInc,lRegion: Integer; + lLabelStr: string; + lVOI: boolean; + lLabelStr20 : Array[0..kHistoBins] of kstr20; +begin + lInten := 0;//just to hide compiler hint... + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) and ('ratlas.nii.gz' = (extractfilename( gMRIcroOverlay[kBGOverlayNum].HdrFileName))) then begin + //DescribeVOIonLabelsRAT(lOverlayNum,lShowFilename); + Showmessage('Please use Windows version.'); + exit; + end; + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) or (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP <> 1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 2) then + exit; + TextForm.MemoT.Lines.add(' Custom Region Analysis'); + TextForm.MemoT.Lines.add(' For Speculative Brodmann Map: 0=not cortical and 48=no Brodmann label'); + lVOI := IsVOIROIExt(gMRIcroOverlay[lOverlayNum].HdrFileName); + if (not lVOI) and (lOverlayNum = kVOIOverlayNum) then + lVOI := true; + //next describe format + if lShowfilename then + lLabelStr := ' Filename,' + else + lLabelStr := ' '; + if lVOI then //intensity min/max position are not important + TextForm.MemoT.Lines.add(lLabelStr+'Area'+kTextSep+'N>0'+kTextSep+'%N>0') + else + TextForm.MemoT.Lines.add(lLabelStr+'Area'+kTextSep+'N>0'+kTextSep+'%N>0'+kTextSep+'Sum>0'+kTextSep+'Mean>0'+kTextSep+'Max'+kTextSep+'MaxX'+kTextSep+'MaxY'+kTextSep+'MaxZ'); + //next initialize + if lShowFilename then + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName+',' + else + lLabelStr := ''; + for lInc := 0 to kHistoBins do begin + lHisto[lInc] := 0; + lLocalMax[lInc] := 0; + lLocalSum[lInc] := 0; + lRegionVol[lInc] := 0; + if (gMRIcroOverlay[kBGOverlayNum].UsesLabels) then + lLabelStr20[lInc] := gBGImg.LabelRA[lInc]// gBGImg.LabelStr20[lInc] + else + lLabelStr20[lInc] := inttostr(lInc); + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + inc(lHisto[gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc]]); + //local max start + l32Buf := SingleP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + l16Buf := SmallIntP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + //NEXT if..else July07 - ROIs only use screen buffer, not imgbuffer... + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[lOverlayNum].ImgBufferItems then + l8Buf := gMRIcroOverlay[lOverlayNum].ImgBuffer + else + l8Buf := gMRIcroOverlay[lOverlayNum].ScrnBuffer; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if (gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 4) then + lInten := l32Buf^[lInc] + else if (gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 2) then + lInten := l16Buf^[lInc] + else if gMRIcroOverlay[lOverlayNum].ImgBufferBPP = 1 then + lInten := l8Buf^[lInc];//July07 + lRegion := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lInc]; + if lInten > 0 then + lLocalSum[lRegion] := lLocalSum[lRegion]+lInten; + if lInten > lLocalMax[lRegion] then begin + lLocalMax[lRegion] := lInten;//intensity + lLocalMaxPos[lRegion] := lInc;//location + end; + inc(lRegionVol[lRegion]); + end; + + for lInc := 0 to kHistoBins do begin + if (not lVOI) and (lLocalMax[lInc] > 0) then begin + lLocalMax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[lOverlayNum],lLocalMax[lInc]); + lLocalSum[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[lOverlayNum],lLocalSum[lInc]); + ImgPosToMM(lLocalMaxPos[lInc], lXmm,lYmm,lZmm); + TextForm.MemoT.Lines.Add(lLabelStr+ lLabelStr20[lInc] +kTextSep+ inttostr(lHisto[lInc])+kTextSep+floattostr( lHisto[lInc]/lRegionVol[lInc]) + +kTextSep+floattostr( lLocalSum[lInc])+kTextSep+floattostr( lLocalSum[lInc]/lRegionVol[lInc]) //Sum>0, mean>0 + +kTextSep + floattostr(lLocalMax[lInc])+kTextSep+floattostr(lXmm)+kTextSep+floattostr(lYmm)+kTextSep+floattostr(lZmm) ); + end else if (lHisto[lInc] > 0) {necessarily also and (lRegionVol[lInc] > 0)} then + TextForm.MemoT.Lines.Add(gBGImg.LabelRA[lInc] + kTextSep+ inttostr(lHisto[lInc])+kTextSep+floattostr( lHisto[lInc]/lRegionVol[lInc])) ; + end; //for each row +end; 2014: no longer used (16 bit LabelRA)*) + + +function Mode (lOverlayNum: integer): double; +const + kBins = 4095; +var + lInc,lS,lMaxI: integer; + lV,lMin,lMax,lScale: single; + lRA: LongIntP0; +begin + result := nan; //error + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems ) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1)then + exit; + lMin := RawBGIntensity(1); + lMax := lMin; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lV := RawBGIntensity(lInc); + if lV < lMin then + lMin := lV; + if lV > lMax then + lMax := lV; + end; //if VOI voxel + end; //for each voxel + if lMin = lMax then begin //no variability + result := Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],lMin); + exit; + end; + lScale := kBins/(lMax-lMin); + getmem(lRA,(kBins+1) * sizeof(longint) ); //0..kBins + for lInc := 0 to kBins do + lRA^[lInc] := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lV := RawBGIntensity(lInc); + lS := round((lV-lMin)*lScale); + inc(lRA^[lS]); + end; //if VOI voxel + end; //for each voxel + lMaxI := 0; + for lInc := 1 to kBins do + if lRA^[lInc] > lRA^[lMaxI] then + lMaxI := lInc; + result := lMin+ (lMaxI/kBins * (lMax-lMin)); + result := Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],result); + freemem(lRA); +end; + +procedure TImgForm.DescriptiveMenuItemClick(Sender: TObject); +var + lROIVol: array [1..3] of integer; + lInc,lOverlayNum,lImgSz: integer; + lCenterOfMass,lROISum,lROISumSqr,lROImin,lROImax:array [1..3] of double; + lMode,lCC,lVal,lSD,lROImean: double; + lStr: string; +procedure AddVal( lRA: integer); +begin + inc(lROIVol[lRA]); + lROISum[lRA] := lROISum[lRA]+lVal; + lROISumSqr[lRA] := lROISumSqr[lRA] + sqr(lVal); + if lVal > lROImax[lRA] then + lROImax[lRA] := lVal; + if lVal < lROImin[lRA] then + lROImin[lRA] := lVal; +end; +begin + lImgSz := 0; + for lOverlayNum := 1 to knMaxOverlay do + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems > lImgSz then + lImgSz := gMRIcroOverlay[lOverlayNum].ScrnBufferItems; + if (lImgSz < 1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < lImgSz) then begin + Showmessage('You need to create or load an overlay (Overlay/Open or Draw/OpenVOI) to get overlay statistics.'); + exit; + end; + + TextForm.MemoT.Lines.Clear; + for lOverlayNum := 1 to knMaxOverlay do begin + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then begin + for lInc := 1 to 3 do begin + lROIVol[lInc] := 0; + lROISum[lInc] := 0; + lROISumSqr[lInc] := 0; + lROImin[lInc] := maxint; + lROImax[lInc] := -maxint; + + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lVal := RawBGIntensity(lInc); + AddVal(1); + if lVal <> 0 then + AddVal(2); + if lVal > 0 then + AddVal(3); + end; //if VOI voxel + end; //for each voxel + //next - compute StDev + //compute descriptives for each set of values + TextForm.MemoT.Lines.Add('Overlay '+gMRIcroOverlay[lOverlayNum].HdrFileName); + if CenterOfMass (lOverlayNum, lCenterOfMass[1],lCenterOfMass[2],lCenterOfMass[3]) > 0 then + TextForm.MemoT.Lines.Add(' Center of mass XYZ '+RealToStr(lCenterOfMass[1],2)+'x'+RealToStr(lCenterOfMass[2],2)+'x'+RealToStr(lCenterOfMass[3],2)); + for lInc := 1 to 3 do begin + if lROIVol[lInc] > 1 then begin + lSD := (lROISumSqr[lInc] - ((Sqr(lROISum[lInc]))/lROIVol[lInc])); + if (lSD > 0) then + lSD := Sqrt ( lSD/(lROIVol[lInc]-1)) + else + lSD := 0; + end else + lSD := 0; + //next compute mean + if lROIVol[lInc] > 0 then + lROImean := lROISum[lInc]/lROIVol[lInc] + else + lROImean := 0; + //next - calibrate values + lROImin[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImin[lInc]); + lROIMean := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROIMean); + lROImax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImax[lInc]); + lSD := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lSD); + lcc := ((lROIVol[lInc]/1000)*gBGImg.ScrnMM[1]*gBGImg.ScrnMM[2]*gBGImg.ScrnMM[3]); + case lInc of + 3: lStr := 'VOI >0 '; + 2: lStr := 'VOI <>0 '; + else lStr := 'VOI '; + end; + lStr := lStr+' nvox(cc)=min/mean/max=SD: '+inttostr(round(lROIVol[lInc]))+kTextSep+RealToStr(lCC,2)+kTextSep+'='+RealToStr(lROIMin[lInc],4)+kTextSep+realToStr(lROIMean,4)+kTextSep+realToStr(lROIMax[lInc],4)+kTextSep+'='+kTextSep+realtostr(lSD,4); + TextForm.MemoT.Lines.Add(lStr); + end; + lMode := Mode(lOverlayNum); + if lMode <> NaN then + TextForm.MemoT.Lines.Add('Mode:'+kTextSep+floattostr(lMode)); + if gMRIcroOverlay[kBGOverlayNum].UsesLabels then + DescribeVOIonLabels(lOverlayNum,false); + TextForm.MemoT.Lines.Add(''); + end; //overlaynum loaded + end; //for each overlay + TextForm.Show; +end; + +procedure TImgForm.FormResize(Sender: TObject); +begin + + if not ImgForm.visible then + exit; + + RefreshImagesTimer.enabled := true; +end; + +function ParamStrFilename (var lParamPos: integer): string; +var + I: integer; + lStr: string; +begin + result := ''; + if (ParamCount < lParamPos) then exit; + I := lParamPos; + repeat + if I = lParamPos then + lStr := ParamStr(I) + else + lStr := lStr +' '+ ParamStr(I); + inc(I); + until (I>ParamCount) or (fileexistsex(lStr)); + lParamPos := I; + if fileexistsex(lStr) then + result := lStr; +end; + +procedure TImgForm.OnLaunch; +var + lStr: String; + lMaximize,lRender,lMultislice : boolean; + lCommandChar: Char; + I,lError,lOverlayNum,lInc,lLUT: integer; + lSingle: single; +procedure ReadCmdVal;//nested +begin + inc(I); + lStr := ParamStr(I); + {$IFNDEF FPC} + lStr := string(StrUpper(PChar(lStr))) ; + {$ELSE} + {$IFNDEF UNIX} + lStr := UpCase(lStr); //unix file names are case specific /EXAMPLE/ATTENTION.NII <> /Example/Attention + {$ENDIF} + {$ENDIF} +end; //nested ReadCmdVal +begin + {$IFDEF Darwin} + //Darwin starts passing a strange paramstr.... + //with Darwin, opening a file can interfere with opening by association... + exit; + //ResliceImg ('/Users/crlab/Documents/example_func.nii.gz','/Users/crlab/Documents/v1x.voi','/Users/crlab/Documents/example_func2standard.mat','/Users/crlab/Documents/z1x.nii.gz'); + {$ENDIF} + + if (ParamCount < 1) then begin + ImgForm.OpenTemplateMRU(nil); + RefreshImagesTimer.enabled := true; + exit; + + end; + lMaximize := false; + lRender := false; + lMultislice := false; + lOverlayNum := 0; + I := 1; + lStr := ParamStrFilename(I); + if lStr <> '' then + OpenAndDisplayImg(lStr,True) + else begin //no requested image + OpenTemplateMRU(nil); + I := 1;//exit; + end; + I := I-1; + //ShowMultisliceClick(nil); + if I >= ParamCount then exit; + gBGIMg.SaveDefaultIni := false; //do not store changes loaded by script + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') then begin //special command + lCommandChar := UpCase(lStr[2]); + case lCommandChar of + 'B': begin //background transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.BGTransPct := round(lSingle); + SetSubmenuWithTag(BGTransPctMenu, gBGImg.BGTransPct); + end; + 'C': begin //color look up table + ReadCmdVal; + if (Length(lStr)>1) then begin + if lStr[1] = '-' then begin //LUT index number + Val(lStr,lSingle,lError); + if lError = 0 then + lLUT := abs(round(lSingle)) + else + lLUT := -1; + end else begin + lStr := ParseFileName(ExtractFileName(lStr)); + {$IFDEF UNIX} + lStr := UpCase(lStr); + {$ENDIF} + lLUT := -1; + for lInc := 1 to (LUTdrop.Items.Count-1) do + if lStr = string(StrUpper(PChar(LUTdrop.Items.Strings[lINc]))) then + lLUT := lInc; + end; //else text LUTname + if lLUT >= 0 then begin + gMRIcroOverlay[lOverlayNum].LUTindex := lLUT; + LUTdropLoad(lOverlayNum); + end; + end; //str length > 1 + end; + 'D': gBGIMg.SaveDefaultIni := true; + 'F': gBGImg.ResliceOnLoad := false; //turn off reslicing... loads files flat + 'H': begin + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMax := (lSingle); + end; + 'L': begin //Low intensity scale + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMin := (lSingle); + end; + 'M': begin //multislice + lMultislice := true; + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gMultiSliceStartupFilename := (lStr); + + end; //if 'M' + 'O': begin//Overlay + ReadCmdVal; + //Showmessage('o'+lStr); + if (lStr <> '') and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then begin + //Showmessage('oexists'+lStr); + inc(lOverlayNum); + OverlayOpenCore (lStr,lOverlayNum); + end; + end; //if 'O' + 'R': begin//Overlay + lRender := true;//Render + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gRenderStartupFilename := (lStr); + end; //if 'R' + 'S': begin //smooth + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then begin + if odd(round(lSingle)) then begin + gBGImg.StretchQuality := sqHigh; + Menu2DSmooth.checked := true; + end else begin + gBGImg.StretchQuality := sqLow; + Menu2DSmooth.checked := false; + end; + if lSingle > 1 then + gBGIMg.OverlaySmooth := true + else + gBGIMg.OverlaySmooth := false; + OverlaySmoothMenu.Checked := gBGIMg.OverlaySmooth; + end;//error=0 + end; + 'T': begin //overlay transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.OverlayTransPct := round(lSingle); + SetSubmenuWithTag(OverlayTransPctMenu, gBGImg.OverlayTransPct); + end; + 'V': begin //open voi + ReadCmdVal; + if (lStr <> '') and (FileexistsEx(lStr)) then + OpenVOICore(lStr); + end; + 'X': lMaximize := true; //open maximized + 'Z': gMRIcroOverlay[lOverlayNum].LUTfromZero := true; + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + until I >= ParamCount; + LayerDropSelect(nil); + for lInc := 0 to lOverlayNum do + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lInc],lINc); + RefreshImages; + if lMultiSlice then + ShowMultisliceClick(nil); + if lRender then + ShowRenderClick(nil); + if lMaximize then begin + ImgForm.WindowState := wsMaximized; + RefreshImagesTimer.enabled := true; + end; +end; + + +procedure TImgForm.FormShow(Sender: TObject); +var + lStr: String; + lMaximize,lRender,lMultislice : boolean; + lCommandChar: Char; + I,lError,lOverlayNum,lInc,lLUT: integer; + lSingle: single; +procedure ReadCmdVal;//nested +begin + inc(I); + lStr := ParamStr(I); + {$IFNDEF FPC} + lStr := string(StrUpper(PChar(lStr))) ; + {$ELSE} + {$IFNDEF UNIX} + lStr := UpCase(lStr); //unix file names are case specific /EXAMPLE/ATTENTION.NII <> /Example/Attention + {$ENDIF} + {$ENDIF} +end; //nested ReadCmdVal +begin + {$IFDEF Darwin} + //Darwin starts passing a strange paramstr.... + //with Darwin, opening a file can interfere with opening by association... + + (*lStr := '/Users/rorden/desktop/mricrox/templates/aal.nii.gz'; + + ImgForm.OpenAndDisplayImg(lStr,True); + lStr := '/Users/rorden/desktop/mricrox/templates/crap.voi'; + LoadOverlayIncludingRGB{LoadOverlay}(lStr); *) + exit; + //ResliceImg ('/Users/crlab/Documents/example_func.nii.gz','/Users/crlab/Documents/v1x.voi','/Users/crlab/Documents/example_func2standard.mat','/Users/crlab/Documents/z1x.nii.gz'); + {$ENDIF} + + if (ParamCount < 1) then begin + ImgForm.OpenTemplateMRU(nil); + RefreshImagesTimer.enabled := true; + exit; + + end; + lMaximize := false; + lRender := false; + lMultislice := false; + lOverlayNum := 0; + I := 1; + lStr := ParamStrFilename(I); + if lStr <> '' then + OpenAndDisplayImg(lStr,True) + else begin //no requested image + OpenTemplateMRU(nil); + I := 1;//exit; + end; + I := I-1; + //ShowMultisliceClick(nil); + if I >= ParamCount then exit; + gBGIMg.SaveDefaultIni := false; //do not store changes loaded by script + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') then begin //special command + lCommandChar := UpCase(lStr[2]); + case lCommandChar of + 'B': begin //background transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.BGTransPct := round(lSingle); + SetSubmenuWithTag(BGTransPctMenu, gBGImg.BGTransPct); + end; + 'C': begin //color look up table + ReadCmdVal; + if (Length(lStr)>1) then begin + if lStr[1] = '-' then begin //LUT index number + Val(lStr,lSingle,lError); + if lError = 0 then + lLUT := abs(round(lSingle)) + else + lLUT := -1; + end else begin + lStr := ParseFileName(ExtractFileName(lStr)); + {$IFDEF UNIX} + lStr := UpCase(lStr); + {$ENDIF} + lLUT := -1; + for lInc := 1 to (LUTdrop.Items.Count-1) do + if lStr = string(StrUpper(PChar(LUTdrop.Items.Strings[lINc]))) then + lLUT := lInc; + end; //else text LUTname + if lLUT >= 0 then begin + gMRIcroOverlay[lOverlayNum].LUTindex := lLUT; + LUTdropLoad(lOverlayNum); + end; + end; //str length > 1 + end; + 'D': gBGIMg.SaveDefaultIni := true; + 'F': gBGImg.ResliceOnLoad := false; //turn off reslicing... loads files flat + 'H': begin + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMax := (lSingle); + end; + 'L': begin //Low intensity scale + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMin := (lSingle); + end; + 'M': begin //multislice + lMultislice := true; + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gMultiSliceStartupFilename := (lStr); + + end; //if 'M' + 'O': begin//Overlay + ReadCmdVal; + //Showmessage('o'+lStr); + if (lStr <> '') and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then begin + //Showmessage('oexists'+lStr); + inc(lOverlayNum); + OverlayOpenCore (lStr,lOverlayNum); + end; + end; //if 'O' + 'R': begin//Overlay + lRender := true;//Render + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gRenderStartupFilename := (lStr); + end; //if 'R' + 'S': begin //smooth + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then begin + if odd(round(lSingle)) then begin + gBGImg.StretchQuality := sqHigh; + Menu2DSmooth.checked := true; + end else begin + gBGImg.StretchQuality := sqLow; + Menu2DSmooth.checked := false; + end; + if lSingle > 1 then + gBGIMg.OverlaySmooth := true + else + gBGIMg.OverlaySmooth := false; + OverlaySmoothMenu.Checked := gBGIMg.OverlaySmooth; + end;//error=0 + end; + 'T': begin //overlay transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.OverlayTransPct := round(lSingle); + SetSubmenuWithTag(OverlayTransPctMenu, gBGImg.OverlayTransPct); + end; + 'V': begin //open voi + ReadCmdVal; + if (lStr <> '') and (FileexistsEx(lStr)) then + OpenVOICore(lStr); + end; + 'X': lMaximize := true; //open maximized + 'Z': gMRIcroOverlay[lOverlayNum].LUTfromZero := true; + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + until I >= ParamCount; + LayerDropSelect(nil); + for lInc := 0 to lOverlayNum do + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lInc],lINc); + RefreshImages; + if lMultiSlice then + ShowMultisliceClick(nil); + if lRender then + ShowRenderClick(nil); + if lMaximize then begin + ImgForm.WindowState := wsMaximized; + RefreshImagesTimer.enabled := true; + end; +end; + + +procedure TImgForm.FlipLRmenuClick(Sender: TObject); +var + lC: integer; + lStr: string; +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gBGImg.Mirror := (sender as TMenuItem).checked ; + gBGImg.VOImirrored := true; + for lC := 0 to knMaxOverlay do + if gMRIcroOverlay[lC].ScrnBufferItems > 0 then + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lC],lC); + RefreshImagesTimer.Enabled := true; + if gBGImg.Mirror then + lStr := 'radiological [right on left side]' + else + lStr := 'neurological [left on left side]'; + showmessage('Warning: left-right flips can be confusing. From now on, this software will attempt to show NIfTI images in '+lStr+' orientation.'); + if MultiSliceForm.Visible then + MultiSliceForm.CreateMultiSlice; +end; + +procedure TImgForm.Menu2DSmoothClick(Sender: TObject); +begin + if Sender <> nil then + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + if Menu2DSmooth.checked then + gBGImg.StretchQuality := sqHigh + else + gBGImg.StretchQuality := sqLow; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.VALclick(Sender: TObject); +begin + //ComputeValFile( (sender as Tmenuitem).tag); +end; + +procedure TImgForm.VOI2NIIClick(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute('VOI Drawings (.VOI)|*.VOI','Select VOI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + OpenAndDisplayImg(lFilename,True); + lFilename := changefileextx(lFilename,'.nii'); + //SaveAsVOIorNIFTIcore (lFilename, lByteP, lVoxels, 1, gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end;//VOI->NII + +procedure TImgForm.TtoP1Click(Sender: TObject); +var + lBufferAligned,lBufferUnAligned: ByteP; + l32Buf,l32BufSrc : SingleP; + l16BufSrc : SmallIntP; + lSlope,lIntercept: single; + lMRIcroHdr: TMRIcroHdr; + lVolVoxels,lPos: integer; +begin +//alfa - currently open image + lVolVoxels := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lVolVoxels < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + GetMem(lBufferUnaligned ,(lVolVoxels *sizeof(single) )+16); + //lBufferAligned := ByteP($fffffff0 and (integer(lBufferUnaligned)+15)); + lBufferAligned := system.align(lBufferUnaligned, 16); + l32Buf := SingleP(lBufferAligned); + //next load values + case gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP of + 4: begin + l32BufSrc := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lPos := 1 to lVolVoxels do + l32Buf^[lPos] := l32BufSrc^[lPos]; + end; + 2: begin + l16BufSrc := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lPos := 1 to lVolVoxels do + l32Buf^[lPos] := l16BufSrc^[lPos]; + end; + 1: begin + for lPos := 1 to lVolVoxels do + l32Buf^[lPos] := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos]; + end; + else begin + showmessage('unknown datatype'); + end; + end; + //next calibrate values + lSlope := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.scl_slope; + lIntercept := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.scl_inter; + if (lSlope=0) or ((lSlope=1) and (lIntercept=0)) then + //no slope + else begin + for lPos := 1 to lVolVoxels do + l32Buf^[lPos] := (l32Buf^[lPos] * lSlope)+lIntercept; + end; + //next - save log10 p values... + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,0, 255,1{df},0,666,NIFTI_INTENT_LOG10PVAL,inttostr(666) ); + for lPos := 1 to lVolVoxels do + if l32Buf^[lPos] > 0 then + l32Buf^[lPos] := -log(abs(pTdistr(42,l32Buf^[lPos])),10) + else + l32Buf^[lPos] :=0; + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(666)); + //next - free float buffer + FreeMem(lBufferUnaligned); +end; + +procedure TImgForm.DesignVALClick(Sender: TObject); +begin + //SpreadForm.Show; +end; + +procedure TImgForm.Up1Click(Sender: TObject); +var lVolVox,lPos,lShift: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + showmessage('You must have open a background image in order to apply an intensity filter (use File/Open).'); + exit; + end; + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + CreateUndoVol;//create gBGImg.VOIUndoVol + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + lVolVox := gBGImg.ScrnDim[1]* gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]; + case (Sender as TMenuItem).tag of + 0: lShift := 1; + 1: lShift := -1; + 2: lShift := gBGImg.ScrnDim[1]; + 3: lShift := -gBGImg.ScrnDim[1]; + 4: lShift := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + 5: lShift := -gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + end; + if lShift > 0 then begin + for lPos := 1 to (lVolVox-lShift) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := gBGImg.VOIUndoVol[lPos+lShift]; + end else begin + for lPos := (1+abs(lShift)) to lVolVox do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := gBGImg.VOIUndoVol[lPos+lShift]; + end; + gBGImg.VOIchanged := true; + ImgForm.ProgressBar1.Position := 0; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + + +procedure TImgForm.FormDestroy(Sender: TObject); +begin +{$IFDEF Darwin} + FormClose(nil); //OSX does not send a FormClose Event if you choose the Application/Quit option +{$ENDIF} + CloseShareMem; +end; + +procedure TImgForm.YokeMenuClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gYoke := (sender as TMenuItem).checked ; + if gYoke then + CreateShareMem + else + CloseShareMem; + +end; + +procedure TImgForm.About1Click(Sender: TObject); +begin + AboutForm.ThreadLabel.Caption := ' '+inttostr(gnCPUThreads)+' threads'+' '+ininame; + AboutForm.Showmodal; +end; +procedure TImgForm.LayerDropChange(Sender: TObject); +begin + {$IFDEF LCLgtk2} + LayerDropSelect(nil); + {$ENDIF} +end; + +procedure TImgForm.LUTdropChange(Sender: TObject); +begin + {$IFDEF LCLgtk2} + LutDropSelect(nil); + {$ENDIF} +end; + +procedure TImgForm.AdjustimagessoVOIintensityiszero1Click(Sender: TObject); +begin + BatchChangeInterceptSoVOIEqualsZero; +end; + +procedure TImgForm.MirrorNII1Click(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + Showmessage('WARNING: This will flip the images in the Left-Right dimension: this has serious consequences'); + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileextX(lFilename,'lr.nii.gz'); + //zap + //showmessage(lFilename); + if MirrorImgBuffer (gMRIcroOverlay[kBGOverlayNum] ) then begin + //showmessage(lFilename); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + end; + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; + +end; + +procedure TImgForm.ZoomDropChange(Sender: TObject); +begin + {$IFDEF LCLgtk2} + ZoomDropSelect(nil); + {$ENDIF} +end; + + + +procedure TImgForm.ResizeControlPanel (lRows: integer); +begin + if lRows = 2 then begin + ControlPanel.Tag := 2; + LayerPanel.Top := 36; + LayerPanel.Left := 1; + + ControlPanel.Height := 72; + + HideROIBtn.left := 307; + XBarBtn.Left := 307+29; + ToolPanel.Left := 307+61; + end else begin + ControlPanel.Tag := 1; + LayerPanel.Top := 1; + LayerPanel.Left := 307; + HideROIBtn.left := 809; + XBarBtn.Left := 809+29; + ToolPanel.Left := 809+61; + ControlPanel.Height := 40; + end; +end; + +procedure TImgForm.ControlPanelDblClick(Sender: TObject); +begin + if ControlPanel.Tag = 1 then + ResizeControlPanel(2) + else + ResizeControlPanel(1); + ImgForm.RefreshImagesTimer.enabled := true; +end; + +procedure TImgForm.DefaultControlPanel; +begin + if gBGImg.SingleRow then begin + ResizeControlPanel(1); + ImgForm.Width := 1025; + ImgForm.Height := 469; + end else begin + ResizeControlPanel(2); + ImgForm.Width := 524; + ImgForm.Height := 640; + end; +end; + +initialization + + for gMouseDownY := 0 to knMaxOverlay do + gMRIcroOverlay[gMouseDownY].index := gMouseDownY; //RGB + +end. diff --git a/niftiview.ico b/niftiview.ico new file mode 100755 index 0000000..8da1d96 Binary files /dev/null and b/niftiview.ico differ diff --git a/niftiview7/DiskSpaceKludge.pas b/niftiview7/DiskSpaceKludge.pas new file mode 100755 index 0000000..5a47ef2 --- /dev/null +++ b/niftiview7/DiskSpaceKludge.pas @@ -0,0 +1,184 @@ +// Disk Space Kludge for Delphi 3 for > 2 GB disk drives +// Works with Windows 95 OSR2 or later, Windows 98 or Windows 4.0 or later +// See http://msdn.microsoft.com/library/sdkdoc/winbase/filesio_8bso.htm +// +// Use DiskSpaceKludge.DiskFree and DiskSpaceKludge.DiskSize now in D3 and +// replace with equivalent SysUtils.DiskFree and SysUtils.DiskSize in D4 + +// efg, April 1999 + +UNIT DiskSpaceKludge; + +INTERFACE + + USES + Windows; // GetDiskFreeSpace, BOOL + + TYPE + TInteger8 = Comp; // 8-byte integer, since disk sizes may be > 2 GB + pInteger8 = ^TInteger8; + + // Use Delphi 4 trick from D4 SysUtils.PAS + VAR + GetDiskFreeSpaceEx: FUNCTION (DirectoryName: pChar; + FreeBytesAvailableToCaller: pInteger8; + TotalNumberOfBytes : pInteger8; + TotalNumberOfFreeBytes : pInteger8): BOOL + StDCall = NIL; + + FUNCTION GetDiskFreeSpaceExA (DirectoryName: pChar; + FreeBytesAvailableToCaller: pInteger8; + TotalNumberOfBytes : pInteger8; + TotalNumberOfFreeBytes : pInteger8): BOOL; + StDCall; + + FUNCTION DiskFreeA(Drive: BYTE): TInteger8; + FUNCTION DiskSize(Drive: BYTE): TInteger8; + FUNCTION DiskFreeStr(DriveStr: String): TInteger8; + FUNCTION DiskFreeEx (DriveStr: String): Integer; + + +IMPLEMENTATION + + USES + SysUtils; // StrCopy +function DiskFreeEx (DriveStr: String): Integer; +var lOutDisk: Integer; lDiskDir : string; lSize8: Tinteger8; begin lOutDisk := ord(upcase(DriveStr[1]))+1-ord('A'); if (lOutDisk >= ord('A')) and (lOutDisk <= ord('Z')) then begin DiskFreeEx := DiskFree(lOutDisk); end else begin lDiskDir :=(ExtractFileDrive(DriveStr))+'\'; lSize8 := DiskFreeStr (lDiskDir); if lSize8 > MaxINt then DiskFreeEx := MaxInt else DiskFreeEx := round(lSize8); end; end; + + /////////////////////////////////////////////////////////////////////////// + + FUNCTION GetDiskFreeSpaceExA; EXTERNAL KERNEL32 NAME 'GetDiskFreeSpaceExA'; + + + /////////////////////////////////////////////////////////////////////////// + + // Borland's DiskFree and DiskSize in D3 SysUtils only return a 4-byte integer. + // Use Integer8 here so values are meaningful on large disk drives. + // These routines may be replaced in D4 with the same name functions that + // return Int64 values. + + // DiskFree returns the number of free bytes on the specified drive number, + // where 0 = Current, 1 = A, 2 = B, etc. DiskFree returns -1 if the drive + // number is invalid. } + + FUNCTION DiskFreeA(Drive: BYTE): TInteger8; + VAR + FreeBytesAvailableToCaller: TInteger8; + RootPath : ARRAY[0..4] OF CHAR; + RootPtr : pChar; + TotalNumberOfBytes : TInteger8; + BEGIN + RootPtr := NIL; + IF Drive > 0 + THEN BEGIN + StrCopy(RootPath, 'A:\'); + RootPath[0] := CHR(Drive + ORD('A') - 1); + StrCopy(RootPath, 'C:\'); + RootPtr := RootPath + END; + + // Use NIL as third parameter, just like in D4 InternalGetDiskSpace routine + IF GetDiskFreeSpaceEx(RootPtr, + @FreeBytesAvailableToCaller, + @TotalNumberOfBytes, + NIL) + THEN RESULT := FreeBytesAvailableToCaller + ELSE RESULT := -1 + END {DiskFree}; + + FUNCTION DiskFreeStr(DriveStr: String): TInteger8; + VAR + FreeBytesAvailableToCaller: TInteger8; + RootPath : ARRAY[0..255] OF CHAR; + RootPtr : pChar; + TotalNumberOfBytes : TInteger8; + BEGIN +// RootPtr := NIL; +// StrCopy(RootPath, DriveStr); +{ RootPath[0] := CHR(Drive + ORD('A') - 1); + StrCopy(RootPath, 'C:\');} + RootPtr := RootPath; + StrPCopy(RootPtr,DriveStr); + + // Use NIL as third parameter, just like in D4 InternalGetDiskSpace routine + IF GetDiskFreeSpaceEx(RootPtr, + @FreeBytesAvailableToCaller, + @TotalNumberOfBytes, + NIL) + THEN RESULT := FreeBytesAvailableToCaller + ELSE RESULT := -1 + END {DiskFree}; + + + // DiskSize returns the size in bytes of the specified drive number, where + // 0 = Current, 1 = A, 2 = B, etc. DiskSize returns -1 if the drive number + // is invalid. } + + FUNCTION DiskSize(Drive: BYTE): TInteger8; + VAR + FreeBytesAvailableToCaller: TInteger8; + RootPath : ARRAY[0..4] OF CHAR; + RootPtr : pChar; + TotalNumberOfBytes : TInteger8; + BEGIN + RootPtr := NIL; + IF Drive > 0 + THEN BEGIN + StrCopy(RootPath, 'A:\'); + RootPath[0] := CHR(Drive + ORD('A') - 1); + RootPtr := RootPath + END; + + // Use NIL as third parameter, just like in D4 InternalGetDiskSpace routine + IF GetDiskFreeSpaceEx(RootPtr, + @FreeBytesAvailableToCaller, + @TotalNumberOfBytes, + NIL) + THEN RESULT := TotalNumberOfBytes + ELSE RESULT := -1 + END {DiskSize}; + + + /////////////////////////////////////////////////////////////////////////// + + // Equivalent to Delphi 4 SysUtils.PAS routines + FUNCTION BackfillGetDiskFreeSpaceEx(Directory: pChar; + VAR FreeAvailable, TotalSpace: TInteger8; + TotalFree: pInteger8): BOOL; StdCall; + + VAR + BytesPerSector : DWORD; + Dir : pChar; + FreeClusters : DWORD; + SectorsPerCluster: DWORD; + Temp : TInteger8; + TotalClusters : DWORD; + BEGIN + IF Directory <> NIL + THEN Dir := Directory + ELSE Dir := NIL; + + RESULT := GetDiskFreeSpaceA(Dir, SectorsPerCluster, BytesPerSector, + FreeClusters, TotalClusters); + Temp := SectorsPerCluster * BytesPerSector; + FreeAvailable := Temp * FreeClusters; + TotalSpace := Temp * TotalClusters + END {BackfillGetDiskFreeSpaceEx}; + + + PROCEDURE InitializeDriveSpacePointer; + VAR + Kernel: THandle; + BEGIN + Kernel := GetModuleHandle(Windows.Kernel32); + + IF Kernel <> 0 + THEN @GetDiskFreeSpaceEx := GetProcAddress(Kernel, 'GetDiskFreeSpaceExA'); + + IF NOT Assigned(GetDiskFreespaceEx) + THEN GetDiskFreeSpaceEx := @BackFillGetDiskFreeSpaceEx + END {InitializeDriveSpacePointer}; + +INITIALIZATION + InitializeDriveSpacePointer +END. diff --git a/niftiview7/Distr.pas b/niftiview7/Distr.pas new file mode 100755 index 0000000..00e8a34 --- /dev/null +++ b/niftiview7/Distr.pas @@ -0,0 +1,687 @@ + +unit Distr; +interface +uses Math,dialogs,define_types; {for Power/Ln} +function TtoZ(t,df: extended): extended; + +function lnGamma(f:longint):extended; + + { Computes the logarithm of the gamma function at f/2. } + + +function pGamma(f:longint;y:extended):extended; + + { Returns the right tail probability in the gamma + distribution with lambda = f/2. } + +function pNormal(z:extended):extended; + +//function pNormalOld(z:extended):extended; +//function pNormalOrig(z:extended):extended; //old +//function pNormalOrig(u:extended):extended; //old + + { Returns the right tail probability in the normal distribution. } + + +function pChi2(f:longint;y:extended):extended; + + { Returns the right tail probability in the chi square distribution + with f degrees of freedom. } + + +function pBeta(f1,f2:longint;y:extended):extended; + + { Returns the LEFT tail probability in the beta distribution + with paramters lambda1=f1/2 and lambda2=f2/2. Use only + f1 and f2 < 1E6. } + + +function pFdistr(f1,f2:longint;y:extended):extended; + + { Returns the right tail probability in the F distribution + with (f1,f2) degrees of freedom. + Use only f1 and f2 < 1E6. } + + +function pTdistr(f:longint;y:extended):extended; + + { Returns the right tail probability in the T distribution. + Use only f < 1E6. } + + +function pNormalInv(p:extended):extended; +function pNormalInvQuickApprox(p : extended) : extended;//errors rise with Z>7 + +//function pNormalInvOld(p:extended):extended; + + + + { Inverse of pNormal. } + + +function pGammaInv(f:longint;p:extended):extended; + + { Inverse of pGamma(f,*). } + + +function pChi2Inv(f:longint;p:extended):extended; + + { Inverse of pChi2(f,*). } + + +function pBetaInv(f1,f2:longint;p:extended):extended; + + { Inverse of pBeta(f1,f2,*) (notice: LEFT tail). } + + +function pFdistrInv(f1,f2:longint;p:extended):extended; + + { 1-p percentile of F distribution. } + +function pTdistrInv(f:longint;p:extended):extended; + + { 1-p percentile of T distribution. } + + +function pPoiss(lambda:extended; n:longint): extended; + + { Returns the right tail probability in the Poisson distribution. } + + +function PoissCL(n:longint; p:extended): extended; + + { Lower 1-p confidence limits for lambda in Poisson distribution + when n is observed. } + + +function pBin(n,x:longint; p:extended): extended; + + { Returns the binomial right tail probability. } + + +function BinCL(n,x:longint; pp:extended): extended; + + { Returns confidence limit for binomial probability parameter, + i.e. inverse to pBin(n,*). } + + +{---------------------------------------------------------------------------} +implementation +//uses stat; + +function TtoZ(t,df: extended): extended; +// Converts a t value to an approximate z value w.r.t the given df +// s.t. std.norm.(z) = t(z, df) at the two-tail probability level. +//from http://www.anu.edu.au/nceph/surfstat/surfstat-home/tables/t.php + var + A9,B9,T9,Z8, P7, B7: extended; + begin + A9 := df - 0.5; + B9 := 48*A9*A9; + T9 := t*t/df; + if T9 >= 0.04 then + Z8 :=A9*ln(1+T9) + else + Z8 := A9*(((1 - T9*0.75)*T9/3 - 0.5)*T9 + 1)*T9; + P7 := ((0.4*Z8 + 3.3)*Z8 + 24)*Z8 + 85.5; + B7 := 0.8*power(Z8, 2) + 100 + B9; + result := (1 + (-P7/B7 + Z8 + 3)/B9)*sqrt(Z8); + if t < 0 then + result := -result; +end; + +function lnGamma; + +var sum,y : extended; + k : longint; + +begin y:=f/2; +if f>500 then + begin + sum:= ln(2*pi)/2 + (y-1/2)*ln(y); sum:=sum -y + 1/(12*y); + sum:=sum - 1/360/y/y/y; + lnGamma:=sum; + end +else + begin + k:=f; sum:=0; + while k>2 do + begin + k:=k-2; + sum:=sum+ln(k/2); + end; + if k=1 then sum:=sum+ln(pi)/2; + lnGamma:=sum; + end; +end; +{---------------------------------------------------------------------------} +function pGamma; + +var term,sum: extended; + k : longint; + +begin if (y<=0) then pGamma:=1 else +if (y<f/2) or (y<42) then + begin + term:=(f/2)*ln(y)-y-lnGamma(f+2); + if term>-1000 then term:=exp(term) else term:=0; + sum:=0; k:=0; + while ((f+k)*term>(f+k-2*y)*1E-20) do + begin + sum:=sum+term; + term:=2*term*y/(f+k+2); + k:=k+2; + end; + pGamma:=abs(1-sum); + end +else + begin + term:=(f/2-1)*ln(y)-y-lnGamma(f); + if term>-1000 then term:=exp(term) else term:=0; + sum:=0; k:=0; + while (term*y > (2*y-f+k)*0.5E-20) and (f-k>1) do + begin + sum:=sum+term; + k:=k+2; + term:=term*(f-k)/2/y; + end; + pGamma:=abs(sum); + end; +end; +{---------------------------------------------------------------------------} +function pNormal(z:extended):extended; +const +PiD2=Pi/2; +var q: extended; +begin + q := z*z; + if abs(z)>7.0 then + result := (0.5)*(1-1/q+3/(q*q))*Exp(-q/2)/(Abs(z)*Sqrt(PiD2)) + else + result := pGamma(1,q/2)/2; + if z<0 then result:=1-result; +end; + +// var q=z*z +// if(Abs(z)>7) {return (1-1/q+3/(q*q))*Exp(-q/2)/(Abs(z)*Sqrt(PiD2))} {return ChiSq(q,1) } + +(*function pNormalOrig; +var p: extended; +begin +p:= pGamma(1,z*z/2)/2; +if z<0 then p:=1-p; +result:=p; +end;(**) +{---------------------------------------------------------------------------} +function pChi2; + +begin +pChi2:= pGamma(f,y/2); +end; +{---------------------------------------------------------------------------} +function pBeta0(f1,f2:longint; y:extended): extended; + + { Returns the left tail probability of the beta distribution + with paramters lambda1=f1/2 and lambda2=f2/2. Use only f1+f2<40. + Accuracy around +/- 1E-16 . } + +var sum,term : extended; + k : longint; + +begin +sum:=0; k:=0; +term:=lnGamma(f1+f2)-lnGamma(f2); +term:=term-lnGamma(f1+2)+f1*ln(y)/2; +term:=exp(term); +while (k<f2) or (abs(term) > 1E-20) do + begin + sum:=sum+term; + k:=k+2; + term:=-term*y*(f2-k)*(f1+k-2)/k/(f1+k); + end; +pBeta0:=sum; +end; +{---------------------------------------------------------------------------} +function pBeta; + +var sum,term : extended; + k : longint; + intch : boolean; + +begin if (f1=f2) and (y=0.5) then pBeta:=0.5 else + if y<=0 then pBeta:=0 else + if y>=1 then pBeta:=1 else + begin + intch:=false; + if y>(1-y) then + begin intch:=true; + k:=f1; f1:=f2; f2:=k; + y:=1-y; + end; + if f1+f2<41 then sum:=pBeta0(f1,f2,y) else + begin + term:= (f2/2-1)*ln(1-y) + (f1/2)*ln(y) + + lnGamma(f1+f2) - lnGamma(f1+2); + term:=term - lnGamma(f2); + if term > -1000 then term:=exp(term) else term:=0; + if (term<1E-35) and (y<f1/(f1+f2)) then sum:=0 + else if (term<1E-35) and (y>f1/(f1+f2)) then sum:=1 + else + begin + k:=0; sum:=0; + while (abs(term)>1E-25) or (y*(f2-k) > (1-y)*(f1+k)) do + begin sum:=sum+term; + k:=k+2; + term:= term*y*(f2-k)/(1-y)/(f1+k); + end; + end; + end; + if intch then sum:=1-sum; + pBeta:= abs(sum); + end; +end; +{---------------------------------------------------------------------------} +function pFdistr; + +begin +pFdistr:=pBeta(f2,f1,f2/(f1*y+f2)); +end; +{---------------------------------------------------------------------------} +function gammln (xx: double): double; {Numerical Recipes for Pascal, p 177} + const + stp = 2.50662827465; + var + x, tmp, ser: double; +begin + x := xx - 1.0; + tmp := x + 5.5; + tmp := (x + 0.5) * ln(tmp) - tmp; + ser := 1.0 + 76.18009173 / (x + 1.0) - 86.50532033 / + (x + 2.0) + 24.01409822 / (x + 3.0) - 1.231739516 / (x + 4.0) + 0.120858003e-2 / (x + 5.0) - 0.536382e-5 / (x + 6.0); + gammln := tmp + ln(stp * ser) +end; {procedure gammln} + +FUNCTION betacf(a,b,x: double): double; +LABEL 1; +CONST + itmax=100; + eps=3.0e-7; +VAR + tem,qap,qam,qab,em,d: double; + bz,bpp,bp,bm,az,app: double; + am,aold,ap: double; + m: integer; +BEGIN + am := 1.0; + bm := 1.0; + az := 1.0; + qab := a+b; + qap := a+1.0; + qam := a-1.0; + bz := 1.0-qab*x/qap; + FOR m := 1 TO itmax DO BEGIN + em := m; + tem := em+em; + d := em*(b-m)*x/((qam+tem)*(a+tem)); + ap := az+d*am; + bp := bz+d*bm; + d := -(a+em)*(qab+em)*x/((a+tem)*(qap+tem)); + app := ap+d*az; + bpp := bp+d*bz; + aold := az; + am := ap/bpp; + bm := bp/bpp; + az := app/bpp; + bz := 1.0; + IF ((abs(az-aold)) < (eps*abs(az))) THEN GOTO 1 + END; + writeln('pause in BETACF'); + writeln('a or b too big, or itmax too small'); readln; +1: betacf := az +END; + + +FUNCTION betai(a,b,x: double): double; +VAR + bt: double; +BEGIN + IF ((x < 0.0) OR (x > 1.0)) THEN BEGIN + writeln('pause in routine BETAI'); readln + END; + IF ((x = 0.0) OR (x = 1.0)) THEN bt := 0.0 + ELSE bt := exp(gammln(a+b)-gammln(a)-gammln(b) + +a*ln(x)+b*ln(1.0-x)); + IF (x < ((a+1.0)/(a+b+2.0))) THEN + betai := bt*betacf(a,b,x)/a + ELSE betai := 1.0-bt*betacf(b,a,1.0-x)/b +END; + +function pTdistr; +begin + if f = 0 then begin + showmessage('Error: DF=0 not valid for t-test.'); + result := 0.5; + exit; + end; + if y = 0 then + result := 0.5 + else begin + + result := betai(0.5*f,0.5,f/(f+sqr(y)))/2; + if y < 0 then + result := 1-result; + end; +end;//from numerical recipes +(*below x5 slower than numerical recipes! +function pTdistr; +//function pTdistr(f:longint;y:extended):extended; +var p: extended; + +begin + +if y=0 then pTdistr:=0.5 else + begin + p:=f/(y*y+f); + p:=pBeta(f,1,p); p:=p/2; + if y<0 then p:=1-p; + pTdistr:=p; + end; +end;*) +{---------------------------------------------------------------------------} +(*function pNormalInv(p:extended):extended; +var + v,dv,z: extended; +begin + v := 0.5; + dv := 0.5; + z := 0; + while (dv>1e-15) do begin + z:=1/v-1; + dv:=dv/2; + if(pNormal(z)>p) then + v:=v-dv + else + v:=v+dv; + end; + result := z; +end; *) +function pNormalInv(p:extended):extended; +var + v,dv,z,tailp: extended; +begin + if p <= 0.5 then + tailp := p + else + tailp := 1-p; + if tailp = 0 then begin + result := 9.2;//fails with Z<-9 + exit; + end; + //showmessage('error'+realtostr(tailp,10)); + //showmessage(realtostr(tailp,10)); + v := 0.5; + dv := 0.5; + z := 0; + while (dv>1e-15) do begin + z:=1/v-1; + dv:=dv/2; + if(pNormal(z)>tailp) then + v:=v-dv + else + v:=v+dv; + end; + if p <= 0.5 then + result := z + else + result := -z; +end; + +function zprob(p : extended {; VAR errorstate : boolean}) : extended; +VAR + z, xp, lim, p0, p1, p2, p3, p4, q0, q1, q2, q3, q4, Y : extended; +begin + // value of probability between approx. 0 and .5 entered in p and the + // z value is returned z + //errorstate := true; + lim := 1E-19; + p0 := -0.322232431088; + p1 := -1.0; + p2 := -0.342242088547; + p3 := -0.0204231210245; + p4 := -4.53642210148E-05; + q0 := 0.099348462606; + q1 := 0.588581570495; + q2 := 0.531103462366; + q3 := 0.10353775285; + q4 := 0.0038560700634; + xp := 0.0; + if (p > 0.5) then + p := 1 - p; + if (p < lim) then //Z>9.5 Z<-9.5 + z := -pNormalInv(p) //use slow method + //z := xp + else if (p = 0.5) then + z := xp + else begin + Y := sqrt(ln(1.0 / (p * p))); + xp := Y + ((((Y * p4 + p3) * Y + p2) * Y + p1) * Y + p0) / + ((((Y * q4 + q3) * Y + q2) * Y + q1) * Y + q0); + if (p < 0.5) then xp := -xp; + z := xp; + end; + zprob := z; +end; // End function zprob + +function pNormalInvQuickApprox(p : extended) : extended; +var + z, px : extended; +// flag : boolean; +begin + // obtains the inverse of z, that is, the z for a probability associated + // with a normally distributed z score. + px := p; + if (p > 0.5) then px := 1.0 - p; + if px < 0.000000000000001 then + z := -8 //lPs[lInc] := 0.000000000000001; + else + z := zprob(px{,flag}); + if (p > 0.5) then z := abs(z); + result := -z; +end; //End of inversez Function + + +(*function zprob(p : double {; VAR errorstate : boolean}) : double; +VAR + z, xp, lim, p0, p1, p2, p3, p4, q0, q1, q2, q3, q4, Y : double; +begin + // value of probability between approx. 0 and .5 entered in p and the + // z value is returned z + //errorstate := true; + lim := 1E-19; + p0 := -0.322232431088; + p1 := -1.0; + p2 := -0.342242088547; + p3 := -0.0204231210245; + p4 := -4.53642210148E-05; + q0 := 0.099348462606; + q1 := 0.588581570495; + q2 := 0.531103462366; + q3 := 0.10353775285; + q4 := 0.0038560700634; + xp := 0.0; + if (p > 0.5) then p := 1 - p; + if (p < lim) then z := xp + else + begin + //errorstate := false; + if (p = 0.5) then z := xp + else + begin + Y := sqrt(ln(1.0 / (p * p))); + xp := Y + ((((Y * p4 + p3) * Y + p2) * Y + p1) * Y + p0) / + ((((Y * q4 + q3) * Y + q2) * Y + q1) * Y + q0); + if (p < 0.5) then xp := -xp; + z := xp; + end; + end; + zprob := z; +end; // End function zprob + +function pNormalInvQuickApprox(p : double) : double; +var + z, px : double; +// flag : boolean; +begin + // obtains the inverse of z, that is, the z for a probability associated + // with a normally distributed z score. + px := p; + if (p > 0.5) then px := 1.0 - p; + z := zprob(px{,flag}); + if (p > 0.5) then z := abs(z); + result := -z; +end; //End of inversez Function +*) +(*function pNormalInvOld; + +var pp,y,a,b,y0 :extended; + +begin +y:= 0; y0:=1; +pp:=0.5; +while y0>1E-10 do + begin y0:=y; + a:=-ln(2*pi)/2-y*y/2; + b:=y; + if abs(b)<1E-2 then y:=y+(pp-p)*exp(-a) + else y:=y+ln(1+b*(pp-p)*exp(-a))/b; + pp:=pNormalOld(y); y0:=abs(y-y0); + end; +result:=y; +end; (**) +{---------------------------------------------------------------------------} +function pGammaInv; + +var pp,y,y0,a,b,a0 :extended; + +begin a0:=-lnGamma(f); +if f=1 then + begin + y:=pNormalInv(p/2); y:=y*y/2; + end +else + begin if f>100 then + begin y:= sqrt(2*f-1)+pNormalInv(p); y:=y*y/4; + end + else y:=f/2; + y0:=1; + pp:=pGamma(f,y); + while y0>1E-7 do + begin y0:=y; + a:=a0+(f/2-1)*ln(y)-y; + b:=(f/2-1)/y-1; + if abs(b*(pp-p)*exp(-a))<1E-5 then y:=y+(pp-p)*exp(-a) + else y:=y+ln(1+b*(pp-p)*exp(-a))/b; + pp:=pGamma(f,y); + y0:=abs(y-y0); + end; + end; +pGammaInv:=y; +end; +{---------------------------------------------------------------------------} +function pChi2Inv; + +var y:extended; + +begin +y:=pGammaInv(f,p); +pChi2Inv:=2*y; +end; +{---------------------------------------------------------------------------} +function pBetaInv1(f1,f2:longint;p:extended):extended; + +var pp,y,y0,a,b,a0 :extended; + +begin +if p<=0 then y:=0 +else if p>=1 then y:=1 +else if (f1=1) and (f2=1) then y:=sin(p*pi/2)*sin(p*pi/2) +else if (f1=1) and (f2=2) then y:=p*p +else if (f1=2) and (f2=1) then y:=1-(1-p)*(1-p) +else if (f1=2) and (f2=2) then y:=p +else + begin + a0:=-lnGamma(f1)-lnGamma(f2); a0:=a0+lnGamma(f1+f2); + y:=f1/(f1+f2); + if f1=1 then + begin + y:= pGammaInv(1,1-p); + y:= 2*y/(2*y+f2-1/2); + end; + y0:=1; + pp:=pBeta(f1,f2,y); + while y0>1E-8 do + begin + a:=a0+(f1/2-1)*ln(y)+(f2/2-1)*ln(1-y); + b:=(f1/2-1)/y-(f2/2-1)/(1-y); + if abs(b*(pp-p))*exp(-a)<1E-5 then y0:=-(pp-p)*exp(-a) + else y0:=ln(1-b*(pp-p)*exp(-a))/b; + y:=y+y0; + pp:=pBeta(f1,f2,y); + y0:=abs(y0)/y/(1-y); + end; + end; +pBetaInv1:=y; +end; +{---------------------------------------------------------------------------} +function pBetaInv; + +var y: extended; + +begin if f1<=f2 then y:=pBetaInv1(f1,f2,p) +else y:= 1-pBetaInv1(f2,f1,1-p); +pBetaInv := y; +end; +{---------------------------------------------------------------------------} +function pFdistrInv; + +var y : extended; + +begin +y:=pBetaInv(f2,f1,p); +if y = 0 then + pFdistrInv:= 0 //infinityINF +else + pFdistrInv:=f2/f1*(1-y)/y; +end; +{---------------------------------------------------------------------------} +function pTdistrInv; + +var t:extended; + +begin if p<=0.5 then t:=sqrt(pFdistrInv(1,f,2*p)) +else t:=-sqrt(pFdistrInv(1,f,2*(1-p))); +pTdistrInv:=t; +end; +{---------------------------------------------------------------------------} +function pPoiss; + +begin pPoiss:= 1-pGamma(2*n,lambda); +end; +{---------------------------------------------------------------------------} +function pBin; + +begin pBin:= pBeta(2*x,2+2*(n-x),p); +end; +{---------------------------------------------------------------------------} +function PoissCL; + +begin PoissCL := pGammaInv(2*n,1-p); +end; +{---------------------------------------------------------------------------} +function BinCL; + +begin BinCL:= pBetaInv(2*x,2+2*(n-x),pp); +end; +{---------------------------------------------------------------------------} + +end. \ No newline at end of file diff --git a/niftiview7/E_MEMMAP.PAS b/niftiview7/E_MEMMAP.PAS new file mode 100755 index 0000000..01c55b4 --- /dev/null +++ b/niftiview7/E_MEMMAP.PAS @@ -0,0 +1,261 @@ +unit E_MemMap; +interface +{ This Unit implements an interface to Win32 memory mapped files. It + can be used to map data simply residing in memory or data residing + in a file. The data can be fully mapped into the processes address + space or chunks can be mapped. It also provides capabilities for + processes to synchronize via mutexes. When mapping sections of the + memory, you must be aware that the Win32 memory mapped file interface + requires that when you are requesting an offset into the memory + region, this offset must be a multiple of the system's memory + allocation granularity (I've called it PageSize). At this point + it is 64K. This is not a concern when you are mapping anything less + than 64K. However, to map anything > 64K the total memory size + mapped must be a multiple of 64K or you will not have access to + the memorysize MOD 64K bytes left over. Basically there are five + rules to be successful when using these routines: + 1. Mapname must be unique for each different case you use + these objects (MyMap1 for case 1, MyMap2 for case 2 + etc.).However, each process using the same memory map + MUST use the same MapName. + 2. Call MapExisting before CreateMemMap or FCreateMemMap. + If another process has already started the mapping, + all you want to do is map to the existing map. ie. + If NOT MapExisting then CreateMemMap. + 3. If your processes are going to write to the mapped + memory, it is suggested you use the mutex stuff. + 4. Pay heed to the warning above concerning seeking + offsets into the mapped memory. Whenever you call + the seek function, always check for an error. Errors + in mapping to the file will result in the Memmap + pointer being Nil. + 5. You MUST call LeaveCriticalSection after calling + EnterCriticalSection or you will lock other processes wishing + to use the map into an infinite wait state. Always use + a Try..Finally block. +} +Uses + Classes,Windows; +Const + hMemMap = $FFFFFFFF; +Type + //Map to memory + TEMemMap = Class(TComponent) + Private + FhFile : THandle; //File handle, hMemMap when simple memory + FhMap : THandle; //Mapping handle + FMap : Pointer; //Memory Pointer + FMapSize : Cardinal; //Mapping Page Size + FMemSize : Cardinal; //Maximum size allocated, >=FileSize when a file + FPageSize : Cardinal; //Minimum System allocation size + FMaxSeeks : Cardinal; //Maximum seeks available,(FMemSize DIV PageSize)-1 + FMapError : Integer; //Error returned + FhMutex : THandle; //Mutex handle for sharing + FInMutex : Boolean; //Internal flag + Function SetMapError : Boolean; + Procedure SetMemSize(Size : Cardinal); + Public + Constructor Create(Aowner : TComponent); Override; + Destructor Destroy; Override; + //Create a mutex for sychronizing access + Function CreateMutex(Const MutexName : String) : Boolean; + //Use the mutex + Procedure EnterCriticalSection; + //Release the mutex + Procedure LeaveCriticalSection; + //Map to existing memory map + Function MapExisting(Const MapName : String; + Const MapSize : Cardinal) : Boolean;Virtual; + //Create a new memory map + Function CreateMemMap(Const MapName : String; + Const MapSize : Cardinal; + Const MapData ) : Boolean;Virtual; + //seek to an offset in the memory map + Function Seek(Const OffSet : Cardinal) : Boolean; + //duh? + Procedure RaiseMappingException;Virtual; + + Property MemMap : Pointer Read FMap; //The mapped memory + Property MapError : Integer Read FMapError Write FMapError; + Property MemSize : Cardinal Read FMemSize Write SetMemSize; //Memory size to allocate + Property PageSize : Cardinal Read FPageSize; //system returned page size + Property MaxSeeks : Cardinal Read FMaxSeeks; //maximum seeks allowed + end; + //map to a file + TEFileMap = Class(TEMemMap) + Public + Function FCreateMemMap(Const Filename : String; + Const MapName : String; + Const MapSize : Cardinal) : Boolean; + + Function FlushFileView : Boolean; + end; +implementation +Uses + SysUtils; +Type + EMappingException = class(Exception); +Constructor TEMemMap.Create(AOwner : TComponent); +Var + SysInfo : TSystemInfo; +begin + Inherited Create(AOwner); + FhFile:=hMemMap; + GetSystemInfo(SysInfo); + FPageSize:=SysInfo.dwAllocationGranularity; +end; +Destructor TEMemmap.Destroy; +begin + LeaveCriticalSection; + If FhMutex<>0 then + CloseHandle(FhMutex); + If FMap<>Nil then + UnMapViewOfFile(FMap); + If FHMap<>0 then + CloseHandle(FHMap); + Inherited Destroy; +end; +Function TEMemMap.CreateMutex(Const MutexName : String) : Boolean; +begin + If FhMutex=0 then + FhMutex:=Windows.CreateMutex(Nil,False,PChar(MutexName)); + If FhMutex=0 then + Result:=SetMapError + else + Result:=True; +end; +Procedure TEMemMap.EnterCriticalSection; +begin + If (NOT FInMutex) AND (FhMutex>0) then + begin + WaitForSingleObject(FhMutex,INFINITE); + FInMutex:=True; + end; +end; +Procedure TEMemMap.LeaveCriticalSection; +begin + If FInMutex AND (FhMutex>0) then + begin + ReleaseMutex(FhMutex); + FInMutex:=False; + end; +end; +Function TEMemMap.SetMapError : Boolean; +begin + FMapError:=GetLastError; + Result:=False; +end; +Procedure TEMemMap.RaiseMappingException; +Var + TError : Integer; +begin + If FMapError<>0 then + begin + LeaveCriticalSection; + TError:=FMapError; + FMapError:=0; + Raise EMappingException.Create('Memory Mapping Error #'+IntToStr(TError)); + end; +end; +Procedure TEMemMap.SetMemSize(Size : Cardinal); +begin + FMemSize:=Size; + If FMemSize>PageSize then + FMaxSeeks:=(FMemSize DIV PageSize)-1 + else + FMaxSeeks:=0; +end; +//map to an existing memory map described by MapName +Function TEMemMap.MapExisting(Const MapName : String; + Const MapSize : Cardinal) : Boolean; +begin + FMapSize:=MapSize; + FMap:=Nil; + FhMap:=OpenFileMapping(FILE_MAP_WRITE,BOOL(True),PChar(MapName)); + If FhMap<>0 then + begin + FMap:=MapViewOfFile(FhMap,FILE_MAP_WRITE,0,0,MapSize); + If FMap=Nil then + begin + CloseHandle(FHMap); + FHMap:=0; + SetMapError; + end; + end; + Result:=FMap<>Nil; +end; +//Create a new memory mapping +Function TEMemMap.CreateMemMap(Const MapName : String; + Const MapSize : Cardinal; + Const MapData ) : Boolean; +begin + If FMemSize=0 then + FMemSize:=MapSize; + FhMap:=CreateFileMapping(FhFile,nil,PAGE_READWRITE,0,FMemSize,PChar(MapName)); + If FhMap<>0 then + begin + FMap:=MapViewOfFile(FhMap,FILE_MAP_WRITE,0,0,MapSize); + If FMap<>Nil then + begin + If fHFile=hMemMap then + begin + EnterCriticalSection; + Try + Move(MapData,FMap^,MapSize); + Finally + LeaveCriticalSection; + end; + end; + Result:=True; + end + else + Result:=SetMapError; + end + else + Result:=SetMapError; +end; +//seek to a different position in map (0..MaxSeeks) +Function TEMemMap.Seek(Const OffSet : Cardinal) : Boolean; +begin + Result:=True; + If NOT UnMapViewOfFile(FMap) then + Result:=SetMapError + else + begin + FMap:=MapViewOfFile(FhMap,FILE_MAP_WRITE,0,OffSet*PageSize,FMapSize); + If FMap=Nil then + Result:=SetMapError; + end; +end; +//Create a file mapping +Function TEFileMap.FCreateMemMap(Const Filename : String; + Const MapName : String; + Const MapSize : Cardinal) : Boolean; +Var + TInt : Cardinal; +begin + FHFile:=CreateFile(PChar(FileName),GENERIC_READ OR GENERIC_WRITE, + FILE_SHARE_READ OR FILE_SHARE_WRITE,NIl,OPEN_EXISTING, + FILE_FLAG_RANDOM_ACCESS,0); + If FhFile<>0 then + begin + Try + Result:=CreateMemMap(MapName,MapSize,TInt); + Finally + CloseHandle(FhFile); + end; + end + else + Result:=SetMapError; +end; + +Function TEFileMap.FlushFileView : Boolean; +begin + EnterCriticalSection; + Try + Result:=FlushViewOfFile(FMap,FMapSize) OR SetMapError; + Finally + LeaveCriticalSection; + end; +end; +end. diff --git a/niftiview7/FFTComplexs.pas b/niftiview7/FFTComplexs.pas new file mode 100755 index 0000000..fe9b68a --- /dev/null +++ b/niftiview7/FFTComplexs.pas @@ -0,0 +1,135 @@ +{ Unit FFTComplexs + + This unit implements complex number arithmic, including the basic + operations addition, substraction, multiplication, division, + magnitude and phase. + + Copyright: Nils Haeck M.Sc. (email: n.haeck@simdesign.nl) + For more information visit http://ww.simdesign.nl + Original date of publication: 10 Mar 2003 + + This unit requires these other units: + - Math: Delphi mathematics unit + - Types: Additional mathematical variable types + + **************************************************************** + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (the "License"); you may not use this file + except in compliance with the License. You may obtain a copy of + the License at: + http://www.mozilla.org/MPL/ + + Software distributed under the License is distributed on an + "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. +} +unit FFTComplexs; + +interface + +uses + FFTTypes, Math; + +type + + // Complex numbers, with precision specified in TFloat (Types unit) + TComplex = packed record + Re: TFloat; // Real part + Im: TFloat; // Imaginary part + end; + +const + + // Zero value + ComplexZero: TComplex = (Re: 0.0; Im: 0.0); + +// Set a complex number +function Complex(Re: TFloat; Im: TFloat): TComplex; + +// Add complex numbers (Result = C1 + C2) +function ComplexAdd(const C1, C2: TComplex): TComplex; + +// Substract complex numbers (Result = C1 - C2) +function ComplexSub(const C1, C2: TComplex): TComplex; + +// Multiply complex numbers (Result = C1 * C2) +function ComplexMul(const C1, C2: TComplex): TComplex; + +// Scale complex numbers (Result = Scale * C) +function ComplexScl(Scale: TFloat; const C: TComplex): TComplex; + +// Get the magnitude of the complex number C +function ComplexMag(const C: TComplex): TFloat; + +// Get the phase of the complex number C (in radians, between -pi and pi) +function ComplexPhase(const C: TComplex): TFloat; + +implementation + +function Complex(Re: TFloat; Im: TFloat): TComplex; +// Set a complex number +begin + Result.Re := Re; + Result.Im := Im; +end; + +function ComplexAdd(const C1, C2: TComplex): TComplex; +// Add complex numbers (Result = C1 + C2) +begin + Result.Re := C1.Re + C2.Re; + Result.Im := C1.Im + C2.Im; +end; + +function ComplexSub(const C1, C2: TComplex): TComplex; +// Substract complex numbers (Result = C1 - C2) +begin + Result.Re := C1.Re - C2.Re; + Result.Im := C1.Im - C2.Im; +end; + +function ComplexMul(const C1, C2: TComplex): TComplex; +// Multiply complex numbers (Result = C1 * C2) +begin + Result.Re := C1.Re * C2.Re - C1.Im * C2.Im; + Result.Im := C1.Im * C2.Re + C1.Re * C2.Im; +end; + +function ComplexScl(Scale: TFloat; const C: TComplex): TComplex; +// Scale complex numbers (Result = Scale * C) +begin + Result.Re := Scale * C.Re; + Result.Im := Scale * C.Im; +end; + +function ComplexMag(const C: TComplex): TFloat; +// Get the magnitude of the complex number C +begin + Result := sqrt(sqr(C.Re) + sqr(C.Im)); +end; + +function ComplexPhase(const C: TComplex): TFloat; +// Get the phase of the complex number C (in radians, between -pi and pi) +const + c2Pi = 2 * pi; + cPid2 = 0.5 * pi; +begin + // Both zero + if (C.Re = 0) and (C.Im = 0) then begin + Result := 0; + exit; + end; + + // Non-zero case + if abs(C.Re) > abs(C.Im) then begin + Result := ArcTan(C.Im / C.Re); {-45 to 45 deg, 135 to -135 deg} + if C.Re < 0 then Result := Result + pi; + end else begin + Result := cPid2 - ArcTan(C.Re / C.Im); {45 to 135, -45 to -135} + if C.Im < 0 then Result := Result + pi; + end; + if Result > pi then Result := Result - c2pi; +end; + +end. diff --git a/niftiview7/FFTTypes.pas b/niftiview7/FFTTypes.pas new file mode 100755 index 0000000..4985ed5 --- /dev/null +++ b/niftiview7/FFTTypes.pas @@ -0,0 +1,50 @@ +{ Unit FFTTypes + + This unit provides the basic floating point type for units based + on this mathematical library. + + TFloat is the basic floating point type and can be set to single + (4 byte) or double (8 byte), or any other type. Please note that + processor instructions are well optimised for single and double + and less for other types. + + Copyright: Nils Haeck M.Sc. (email: n.haeck@simdesign.nl) + For more information visit http://www.simdesign.nl + Original date of publication: 10 Mar 2003 + + **************************************************************** + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (the "License"); you may not use this file + except in compliance with the License. You may obtain a copy of + the License at: + http://www.mozilla.org/MPL/ + + Software distributed under the License is distributed on an + "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. +} +unit FFTTypes; + +interface + +type + + // TFloat is the basic library floating point type. Use single for single + // precision (4 bytes) or double for more demanding, double precision (8 bytes) + TFloat = single; + +const + + // Single ranges from 1.5 x 10^–45 .. 3.4 x 10^38 + cMinFloat = 1.5E-45; + cMaxFloat = 3.4E38; + + // Double ranges from 5.0 x 10^–324 .. 1.7 x 10^308 +{ cMinFloat = 5.0E-324; + cMaxFloat = 1.7E308; } + +implementation + +end. diff --git a/niftiview7/FFTs.pas b/niftiview7/FFTs.pas new file mode 100755 index 0000000..1ba9a29 --- /dev/null +++ b/niftiview7/FFTs.pas @@ -0,0 +1,599 @@ +{ Unit FFTs + + This unit provides a forward and inverse FFT pascal implementation + for complex number series. + + The formal definition of the complex DFT is: + y[k] = sum(x[m]*exp(-i*2*pi*k*m/n), m = 0..n-1), k = 0..n-1 + + Copyright: Nils Haeck M.Sc. (email: n.haeck@simdesign.nl) + For more information visit http://www.simdesign.nl + Original date of publication: 10 Mar 2003 + + This unit requires these other units: + - Complexs: Complex number unit + - Types: Additional mathematical variable types + - SysUtils: Delphi system utilities + + **************************************************************** + + The contents of this file are subject to the Mozilla Public + License Version 1.1 (the "License"); you may not use this file + except in compliance with the License. You may obtain a copy of + the License at: + http://www.mozilla.org/MPL/ + + Software distributed under the License is distributed on an + "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or + implied. See the License for the specific language governing + rights and limitations under the License. +} +unit FFTs; + +interface + +uses + FFTComplexs, FFTTypes, SysUtils,Define_Types; + +const + + cMaxPrimeFactor = 1021; + cMaxPrimeFactorDiv2 = (cMaxPrimeFactor + 1) div 2; + cMaxFactorCount = 20; + +resourcestring + + sErrPrimeTooLarge = 'Prime factor for FFT length too large. Change value for cMaxPrimeFactor in FFTs unit'; + +{ ForwardFFT: + Perform a complex FFT on the data in Source, put result in Dest. This routine + works best for Count as a power of 2, but also works usually faster than DFT + by factoring the series. Only in cases where Count is a prime number will this + method be identical to regular complex DFT. + + The largest prime factor in Count should be less or equal to cMaxPrimeFactor. + + The remaining factors are handled by optimised partial FFT code, that can be + found in the FFT_X procedures + + Inputs: + Source: this can be any zero-based array type of TComplex + Count: The number of elements in the array. + + Outputs: + Dest: this can be any zero-based array type of TComplex, and will contain + the FFT transformed data (frequency spectrum). Source may be equal to + Dest. In this case, the original series will be overwritten with the new + fourier-transformed series. +} +procedure ForwardFFT(const Source: array of TComplex; var Dest: array of TComplex; Count: integer); + +{ Perform the inverse FFT on the Source data, and put result in Dest. This is based + on the forward FFT with some additional customisation. The result of a forward + FFT followed by an inverse FFT should yield the same data, except for rounding + errors. +} +procedure InverseFFT(const Source: array of TComplex; var Dest: array of TComplex; Count: integer); + +function FFTPower(var lDataIn,lDataOut: SingleP; lnIn: Integer): boolean; +//returns lDataOut with (lnIn div 2)-1 samples + +implementation + + +function FFTPower(var lDataIn,lDataOut: SingleP; lnIn: Integer): boolean; +//returns lDataOut with (lnIn div 2)-1 samples + var + I,lnOut : Integer; + Source, Dest : array of TComplex; +begin + result := false; + if lnIn < 6 then + exit; + SetLength(Source, lnIn); + SetLength(Dest, lnIn); + for I := 0 to (lnIn-1) do begin + Source[I].Re := lDataIn[I+1]; //+1 as SingleP is indexed from 1 + Source[I].Im := 0; + end; + ForwardFFT(Source, Dest, lnIn); + + lnOut := ((lnIn) div 2)-1; + //-1 because the first component of Dest, Dest[0], is simply the sum of the data, and can be removed + for I := 1 to (lnOut) do + lDataOut[I] := Sqrt(Sqr(Dest[I].Re)+Sqr(Dest[I].Im));//note we ignore [0].re and [0].im + result := true; +end; + +(*function FFTPower(var lDataIn,lDataOut: SingleP; lnIn: Integer): boolean; +//returns lDataOut with (lnIn div 2)-1 samples + var + I,lnOut : Integer; + Source, Dest : array of TComplex; +begin + result := false; + if lnIn < 6 then + exit; + getmem(Source,lnIn* sizeof(TComplex)); + getmem(Dest,lnIn* sizeof(TComplex)); + for I := 0 to (lnIn-1) do begin + Source[I].Re := lDataIn[I+1]; //+1 as SingleP is indexed from 1 + Source[I].Im := 0; + end; + ForwardFFT(Source, Dest, lnIn); + lnOut := ((lnIn) div 2)-1; + //-1 because the first component of Dest, Dest[0], is simply the sum of the data, and can be removed + for I := 1 to (lnOut) do + lDataOut[I] := Sqrt(Sqr(Dest[I].Re)+Sqr(Dest[I].Im));//note we ignore [0].re and [0].im + freemem(Source); + freemem(Dest); + result := true; +end;*) + +const + // Some helper constants for the FFT optimisations + c31: TFloat = -1.5000000000000E+00; // cos(2*pi / 3) - 1; + c32: TFloat = 8.6602540378444E-01; // sin(2*pi / 3); + + u5: TFloat = 1.2566370614359E+00; // 2*pi / 5; + c51: TFloat = -1.2500000000000E+00; // (cos(u5) + cos(2*u5))/2 - 1; + c52: TFloat = 5.5901699437495E-01; // (cos(u5) - cos(2*u5))/2; + c53: TFloat = -9.5105651629515E-01; //- sin(u5); + c54: TFloat = -1.5388417685876E+00; //-(sin(u5) + sin(2*u5)); + c55: TFloat = 3.6327126400268E-01; // (sin(u5) - sin(2*u5)); + c8: TFloat = 7.0710678118655E-01; // 1 / sqrt(2); + +type + // Base 1 and Base 0 arrays + TIdx0FactorArray = array[0..cMaxFactorCount] of integer; + TIdx1FactorArray = array[1..cMaxFactorCount] of integer; + +// Factorise the series with length Count into FactorCount factors, stored in Fact +procedure Factorize(Count: integer; var FactorCount: integer; var Fact: TIdx1FactorArray); +var + i: integer; + Factors: TIdx1FactorArray; +const + // Define specific FFT lengths (radices) that we can process with optimised routines + cRadixCount = 6; + cRadices: array[1..6] of integer = + (2, 3, 4, 5, 8, 10); +begin + + if Count = 1 then begin + FactorCount := 1; + Factors[1] := 1; + end else begin + FactorCount := 0; + end; + + // Factorise the original series length Count into known factors and rest value + i := cRadixCount; + while (Count > 1) AND (i > 0) do begin + if Count mod cRadices[i] = 0 then begin + Count := Count div cRadices[i]; + inc(FactorCount); + Factors[FactorCount] := cRadices[i]; + end else + dec(i); + end; + + // substitute factors 2*8 with more optimal 4*4 + if Factors[FactorCount] = 2 then begin + i := FactorCount - 1; + while (i > 0) AND (Factors[i] <> 8) do + dec(i); + + if i > 0 then begin + Factors[FactorCount] := 4; + Factors[i] := 4; + end; + end; + + // Analyse the rest value and see if it can be factored in primes + if Count > 1 then begin + for i := 2 to trunc(sqrt(Count)) do begin + while Count mod i = 0 do begin + Count := Count div i; + inc(FactorCount); + Factors[FactorCount] := i; + end; + end; + + if (Count > 1) then begin + inc(FactorCount); + Factors[FactorCount] := Count; + end; + end; + + // Reverse factors so that primes are first + for i := 1 to FactorCount do + Fact[i] := Factors[FactorCount - i + 1]; + +end; + +{ Reorder the series in X to a permuted sequence in Y so that the later step can + be done in place, and the final FFT result is in correct order. + The series X and Y must be different series! +} +procedure ReorderSeries(Count: integer; var Factors: TIdx1FactorArray; var Remain: TIdx0FactorArray; + const X: array of TComplex; var Y: array of TComplex); +var + i, j, k: integer; + Counts: TIdx1FactorArray; +begin + FillChar(Counts, SizeOf(Counts), 0); + + k := 0; + for i := 0 to Count - 2 do begin + Y[i] := X[k]; + j := 1; + k := k + Remain[j]; + Counts[1] := Counts[1] + 1; + while Counts[j] >= Factors[j] do begin + Counts[j] := 0; + k := k - Remain[j - 1] + Remain[j + 1]; + inc(j); + inc(Counts[j]); + end; + end; + + Y[Count - 1] := X[Count - 1]; +end; + +procedure FFT_2(var Z: array of TComplex); +var + T1: TComplex; +begin + T1 := ComplexAdd(Z[0], Z[1]); + Z[1] := ComplexSub(Z[0], Z[1]); + Z[0] := T1; +end; + +procedure FFT_3(var Z: array of TComplex); +var + T1, M1, M2, S1: TComplex; +begin + T1 := ComplexAdd(Z[1], Z[2]); + Z[0] := ComplexAdd(Z[0], T1); + M1 := ComplexScl(c31, T1); + M2.Re := c32 * (Z[1].Im - Z[2].Im); + M2.Im := c32 * (Z[2].Re - Z[1].Re); + S1 := ComplexAdd(Z[0], M1); + Z[1] := ComplexAdd(S1, M2); + Z[2] := ComplexSub(S1, M2); +end; + +procedure FFT_4(var Z: array of TComplex); +var + T1, T2, M2, M3: TComplex; +begin + T1 := ComplexAdd(Z[0], Z[2]); + T2 := ComplexAdd(Z[1], Z[3]); + + M2 := ComplexSub(Z[0], Z[2]); + M3.Re := Z[1].Im - Z[3].Im; + M3.Im := Z[3].Re - Z[1].Re; + + Z[0] := ComplexAdd(T1, T2); + Z[2] := ComplexSub(T1, T2); + Z[1] := ComplexAdd(M2, M3); + Z[3] := ComplexSub(M2, M3); +end; + +procedure FFT_5(var Z: array of TComplex); +var + T1, T2, T3, T4, T5: TComplex; + M1, M2, M3, M4, M5: TComplex; + S1, S2, S3, S4, S5: TComplex; +begin + T1 := ComplexAdd(Z[1], Z[4]); + T2 := ComplexAdd(Z[2], Z[3]); + T3 := ComplexSub(Z[1], Z[4]); + T4 := ComplexSub(Z[3], Z[2]); + + T5 := ComplexAdd(T1, T2); + Z[0] := ComplexAdd(Z[0], T5); + M1 := ComplexScl(c51, T5); + M2 := ComplexScl(c52, ComplexSub(T1, T2)); + + M3.Re := -c53 * (T3.Im + T4.Im); + M3.Im := c53 * (T3.Re + T4.Re); + M4.Re := -c54 * T4.Im; + M4.Im := c54 * T4.Re; + M5.Re := -c55 * T3.Im; + M5.Im := c55 * T3.Re; + + S3 := ComplexSub(M3, M4); + S5 := ComplexAdd(M3, M5);; + S1 := ComplexAdd(Z[0], M1); + S2 := ComplexAdd(S1, M2); + S4 := ComplexSub(S1, M2); + + Z[1] := ComplexAdd(S2, S3); + Z[2] := ComplexAdd(S4, S5); + Z[3] := ComplexSub(S4, S5); + Z[4] := ComplexSub(S2, S3); +end; + +procedure FFT_8(var Z: array of TComplex); +var + A, B: array[0..3] of TComplex; + Gem: TFloat; +begin + A[0] := Z[0]; B[0] := Z[1]; + A[1] := Z[2]; B[1] := Z[3]; + A[2] := Z[4]; B[2] := Z[5]; + A[3] := Z[6]; B[3] := Z[7]; + + FFT_4(A); + FFT_4(B); + + Gem := c8 * (B[1].Re + B[1].Im); + B[1].Im := c8 * (B[1].Im - B[1].Re); + B[1].Re := Gem; + Gem := B[2].Im; + B[2].Im :=-B[2].Re; + B[2].Re := Gem; + Gem := c8 * (B[3].Im - B[3].Re); + B[3].Im :=-c8 * (B[3].Re + B[3].Im); + B[3].Re := Gem; + + Z[0] := ComplexAdd(A[0], B[0]); Z[4] := ComplexSub(A[0], B[0]); + Z[1] := ComplexAdd(A[1], B[1]); Z[5] := ComplexSub(A[1], B[1]); + Z[2] := ComplexAdd(A[2], B[2]); Z[6] := ComplexSub(A[2], B[2]); + Z[3] := ComplexAdd(A[3], B[3]); Z[7] := ComplexSub(A[3], B[3]); +end; + +procedure FFT_10(var Z: array of TComplex); +var + A, B: array[0..4] of TComplex; +begin + A[0] := Z[0]; B[0] := Z[5]; + A[1] := Z[2]; B[1] := Z[7]; + A[2] := Z[4]; B[2] := Z[9]; + A[3] := Z[6]; B[3] := Z[1]; + A[4] := Z[8]; B[4] := Z[3]; + + FFT_5(A); + FFT_5(B); + + Z[0] := ComplexAdd(A[0], B[0]); Z[5] := ComplexSub(A[0], B[0]); + Z[6] := ComplexAdd(A[1], B[1]); Z[1] := ComplexSub(A[1], B[1]); + Z[2] := ComplexAdd(A[2], B[2]); Z[7] := ComplexSub(A[2], B[2]); + Z[8] := ComplexAdd(A[3], B[3]); Z[3] := ComplexSub(A[3], B[3]); + Z[4] := ComplexAdd(A[4], B[4]); Z[9] := ComplexSub(A[4], B[4]); +end; + +{ + Synthesize the FFT by taking the even factors and the odd factors multiplied by + complex sinusoid +} +procedure SynthesizeFFT(Sofar, Radix, Remain: integer; var Y: array of TComplex); +var + GroupOffset, DataOffset, Position: integer; + GroupNo, DataNo, BlockNo, SynthNo: integer; + Omega: double; + S, CosSin: TComplex; + Synth, Trig, Z: array[0..cMaxPrimeFactor - 1] of TComplex; + + // Local function + procedure InitializeTrigonomials(Radix: integer); + // Initialize trigonomial coefficients + var + i: integer; + W: double; + X: TComplex; + begin + W := 2 * pi / Radix; + Trig[0] := Complex(1.0, 0.0); + X := Complex(cos(W), -sin(W)); + Trig[1] := X; + for i := 2 to Radix - 1 do + Trig[i] := ComplexMul(X, Trig[i - 1]); + end; + + // Local Function + procedure FFT_Prime(Radix: integer); + // This is the general DFT, which can't be made any faster by factoring because + // Radix is a prime number + var + i, j, k, N, AMax: integer; + Re, Im: TComplex; + V, W: array[0..cMaxPrimeFactorDiv2 - 1] of TComplex; + begin + N := Radix; + AMax := (N + 1) div 2; + for j := 1 to AMax - 1 do begin + V[j].Re := Z[j].Re + Z[n-j].Re; + V[j].Im := Z[j].Im - Z[n-j].Im; + W[j].Re := Z[j].Re - Z[n-j].Re; + W[j].Im := Z[j].Im + Z[n-j].Im; + end; + + for j := 1 to AMax - 1 do begin + Z[j] := Z[0]; + Z[N-j] := Z[0]; + k := j; + for i := 1 to AMax - 1 do begin + Re.Re := Trig[k].Re * V[i].Re; + Im.Im := Trig[k].Im * V[i].Im; + Re.im := Trig[k].Re * W[i].Im; + Im.Re := Trig[k].Im * W[i].Re; + + Z[N-j].Re := Z[N-j].Re + Re.Re + Im.Im; + Z[N-j].Im := Z[N-j].Im + Re.Im - Im.Re; + Z[j].Re := Z[j].Re + Re.Re - Im.Im; + Z[j].Im := Z[j].Im + Re.Im + Im.Re; + + k := k + j; + if k >= N then + k := k - N; + end; + end; + + for j := 1 to AMax - 1 do begin + Z[0].Re := Z[0].Re + V[j].Re; + Z[0].Im := Z[0].Im + W[j].Im; + end; + end; + +// main +begin + // Initialize trigonomial coefficients + InitializeTrigonomials(Radix); + + Omega := 2 * pi / (Sofar * Radix); + CosSin := Complex(cos(Omega), -sin(Omega)); + S := Complex(1.0, 0.0); + DataOffset := 0; + GroupOffset := 0; + Position := 0; + + for DataNo := 0 to Sofar - 1 do begin + + if Sofar > 1 then begin + + Synth[0] := Complex(1.0, 0.0); + Synth[1] := S; + for SynthNo := 2 to Radix - 1 do + Synth[SynthNo] := ComplexMul(S, Synth[SynthNo - 1]); + S := ComplexMul(CosSin, S); + + end; + + for GroupNo := 0 to Remain - 1 do begin + + if (Sofar > 1) AND (DataNo > 0) then begin + + Z[0] := Y[Position]; + BlockNo := 1; + repeat + inc(Position, Sofar); + Z[BlockNo] := ComplexMul(Synth[BlockNo], Y[Position]); + inc(BlockNo); + until BlockNo >= Radix; + + end else begin + + for BlockNo := 0 to Radix - 1 do begin + Z[BlockNo] := Y[Position]; + inc(Position, Sofar); + end; + + end; + + case Radix of + 2: FFT_2(Z); + 3: FFT_3(Z); + 4: FFT_4(Z); + 5: FFT_5(Z); + 8: FFT_8(Z); + 10: FFT_10(Z); + else + // Any larger prime number than 5 (so 7, 11, 13, etc, up to cMaxPrimeFactor) + FFT_Prime(Radix); + end; //case + + Position := GroupOffset; + for BlockNo := 0 to Radix - 1 do begin + Y[Position] := Z[blockNo]; + Inc(Position, Sofar); + end; + GroupOffset := GroupOffset + Sofar * Radix; + Position := GroupOffset; + end; + inc(DataOffset); + GroupOffset := DataOffset; + Position := DataOffset; + end; +end; + +procedure ForwardFFT(const Source: array of TComplex; var Dest: array of TComplex; Count: integer); +// Perform a FFT on the data in Source, put result in Dest. This routine works best +// for Count as a power of 2, but also works usually faster than DFT by factoring +// the series. Only in cases where Count is a prime number will this method be +// identical to regular DFT. +type + PComplexArray = ^TComplexArray; + TComplexArray = array[0..0] of TComplex; +var + i: integer; + FactorCount: integer; + SofarRadix: TIdx1FactorArray; + ActualRadix: TIdx1FactorArray; + RemainRadix: TIdx0FactorArray; + TmpDest: PComplexArray; +begin + if Count = 0 then exit; + + // Decompose the series with length Count into FactorCount factors in ActualRadix + Factorize(Count, FactorCount, ActualRadix); + + // Check if our biggest prime factor is not too large + if (ActualRadix[1] > cMaxPrimeFactor) then + raise EMathError.Create(sErrPrimeTooLarge); + + // Setup Sofar and Remain tables + RemainRadix[0] := Count; + SofarRadix[1] := 1; + RemainRadix[1] := Count div ActualRadix[1]; + for i := 2 to FactorCount do begin + SofarRadix[i] := SofarRadix[i-1] * ActualRadix[i-1]; + RemainRadix[i] := RemainRadix[i-1] div ActualRadix[i]; + end; + + // Make temp copy if dest = source (otherwise the permute procedure will completely + // ruin the structure + if @Dest = @Source then begin + GetMem(TmpDest, SizeOf(TComplex) * Count);; + Move(Dest, TmpDest^, SizeOf(TComplex) * Count); + end else begin + TmpDest := @Dest; + end; + + // Reorder the series so that the elements are already in the right place for + // synthesis + ReorderSeries(Count{, FactorCount}, ActualRadix, RemainRadix, Source, TmpDest^); + + // Free the temporary copy (if any) + if @Dest = @Source then begin + Move(TmpDest^, Dest, SizeOf(TComplex) * Count); + FreeMem(TmpDest); + end; + + // Synthesize each of the FFT factored series + for i := 1 to FactorCount do + SynthesizeFFT(SofarRadix[i], ActualRadix[i], RemainRadix[i], Dest); + +end; + +procedure InverseFFT(const Source: array of TComplex; var Dest: array of TComplex; Count: integer); +// Perform the inverse FFT on the Source data, and put result in Dest. It performs +// the forward FFT and then divides elements by N +var + i: integer; + S: TFloat; + TmpSource: array of TComplex; +begin + if Count = 0 then exit; + + // Since TmpSource is local, we do not have to free it again, + // it will be freed automatically when out of scope + SetLength(TmpSource, Count); + + // Create a copy with inverted imaginary part. + for i := 0 to Count - 1 do + with Source[i] do + TmpSource[i] := Complex(Re, -Im); + ForwardFFT(TmpSource, Dest, Count); + + // Scale by 1/Count, and inverse the imaginary part + S := 1.0 / Count; + for i := 0 to Count - 1 do begin + Dest[i].Re := S * Dest[i].Re; + Dest[i].Im := - S * Dest[i].Im; + end; +end; + +end. diff --git a/niftiview7/GAUSSJ.PAS b/niftiview7/GAUSSJ.PAS new file mode 100755 index 0000000..6b78a09 --- /dev/null +++ b/niftiview7/GAUSSJ.PAS @@ -0,0 +1,82 @@ +PROCEDURE gaussj(VAR a: glnpbynp; n,np: integer; + VAR b: glnpbymp; m,mp: integer); +(* Programs using GAUSSJ must define the types +TYPE + glnpbynp = ARRAY [1..np,1..np] OF real; + glnpbymp = ARRAY [1..np,1..mp] OF real; + glnp = ARRAY [1..np] OF integer; +in the main routine. *) +VAR + big,dum,pivinv: real; + i,icol,irow,j,k,l,ll: integer; + indxc,indxr,ipiv: glnp; +BEGIN + FOR j := 1 TO n DO BEGIN + ipiv[j] := 0 + END; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO BEGIN + IF (ipiv[j] <> 1) THEN BEGIN + FOR k := 1 TO n DO BEGIN + IF (ipiv[k] = 0) THEN BEGIN + IF (abs(a[j,k]) >= big) THEN BEGIN + big := abs(a[j,k]); + irow := j; + icol := k + END + END ELSE IF (ipiv[k] > 1) THEN BEGIN + writeln('pause 1 in GAUSSJ - singular matrix'); readln + END + END + END + END; + ipiv[icol] := ipiv[icol]+1; + IF (irow <> icol) THEN BEGIN + FOR l := 1 TO n DO BEGIN + dum := a[irow,l]; + a[irow,l] := a[icol,l]; + a[icol,l] := dum + END; + FOR l := 1 TO m DO BEGIN + dum := b[irow,l]; + b[irow,l] := b[icol,l]; + b[icol,l] := dum + END + END; + indxr[i] := irow; + indxc[i] := icol; + IF (a[icol,icol] = 0.0) THEN BEGIN + writeln('pause 2 in GAUSSJ - singular matrix'); readln + END; + pivinv := 1.0/a[icol,icol]; + a[icol,icol] := 1.0; + FOR l := 1 TO n DO BEGIN + a[icol,l] := a[icol,l]*pivinv + END; + FOR l := 1 TO m DO BEGIN + b[icol,l] := b[icol,l]*pivinv + END; + FOR ll := 1 TO n DO BEGIN + IF (ll <> icol) THEN BEGIN + dum := a[ll,icol]; + a[ll,icol] := 0.0; + FOR l := 1 TO n DO BEGIN + a[ll,l] := a[ll,l]-a[icol,l]*dum + END; + FOR l := 1 TO m DO BEGIN + b[ll,l] := b[ll,l]-b[icol,l]*dum + END + END + END + END; + FOR l := n DOWNTO 1 DO BEGIN + IF (indxr[l] <> indxc[l]) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a[k,indxr[l]]; + a[k,indxr[l]] := a[k,indxc[l]]; + a[k,indxc[l]] := dum + END + END + END +END; diff --git a/niftiview7/GraphicsMathLibrary.pas b/niftiview7/GraphicsMathLibrary.pas new file mode 100755 index 0000000..370910f --- /dev/null +++ b/niftiview7/GraphicsMathLibrary.pas @@ -0,0 +1,1059 @@ +// Graphics Math Library +// +// Copyright (C) 1982, 1985, 1992, 1995-1998 Earl F. Glynn, Overland Park, KS. +// All Rights Reserved. E-Mail Address: EarlGlynn@att.net + +UNIT GraphicsMathLibrary; // Matrix/Vector Operations for 2D/3D Graphics} + +INTERFACE + + USES + SysUtils,dialogs; {Exception} + + CONST + sizeUndefined = 1; + size2D = 3; // 'size' of 2D homogeneous vector or transform matrix + size3D = 4; // 'size' of 3D homogeneous vector or transform matrix + + TYPE + EVectorError = CLASS(Exception); + EMatrixError = CLASS(Exception); + + TAxis = (axisX, axisY, axisZ); + TCoordinate = (coordCartesian, coordSpherical, coordCylindrical); + TDimension = (dimen2D, dimen3D); // two- or three-dimensional TYPE + TIndex = 1..4; // index of 'TMatrix' and 'TVector' TYPEs + + TMatrix = // transformation 'matrix' + RECORD + size: TIndex; + matrix: ARRAY[TIndex,TIndex] OF single //azx DOUBLE + END; + TMatrixI = // transformation 'matrix' + RECORD + size: TIndex; + matrix: ARRAY[TIndex,TIndex] OF longint + END; + + Trotation = (rotateClockwise, rotateCounterClockwise); + + // Normally the TVector TYPE is used to define 2D/3D homogenous + // cartesian coordinates for graphics, i.e., (x,y,1) for 2D and + // (x,y,z,1) for 3D. + // + // Cartesian coordinates can be converted to spherical (r, theta, phi), + // or cylindrical coordinates (r,theta, z). Spherical or cylindrical + // coordinates can be converted back to cartesian coordinates. + TVector = + RECORD + size: TIndex; + CASE INTEGER OF + 0: (vector: ARRAY[TIndex] OF single); + 1: (x: single; + y: single; + z: single; // contains 'h' for 2D cartesian vector + h: single) + END; + + TIntVector = + RECORD + size: TIndex; + CASE INTEGER OF + 0: (vector: ARRAY[TIndex] OF integer); + 1: (x: integer; + y: integer; + z: integer; // contains 'h' for 2D cartesian vector + h: integer) + END; + // Vector Operations + +// FUNCTION Vector2D (CONST xValue, yValue: DOUBLE): TVector; + FUNCTION Vector3D (CONST xValue, yValue, zValue: DOUBLE): TVector; + Function SameVec (const u,v: TVector): boolean; + FUNCTION Transform (CONST u: TVector; CONST a: TMatrix): TVector; + (* FUNCTION AddVectors (CONST u,v: TVector): TVector; +// FUNCTION Transform (CONST u: TVector; CONST a: TMatrix): TVector; + *) + //FUNCTION DotProduct (CONST u,v: TVector): DOUBLE; + //FUNCTION CrossProduct(CONST u,v: TVector): TVector; + + + // Basic Matrix Operations + + FUNCTION Matrix2D (CONST m11,m12,m13, // 2D "graphics" matrix + m21,m22,m23, + m31,m32,m33: DOUBLE): TMatrix; + + FUNCTION Matrix3D (CONST m11,m12,m13,m14, // 3D "graphics" matrix + m21,m22,m23,m24, + m31,m32,m33,m34, + m41,m42,m43,m44: DOUBLE): TMatrix; + + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + FUNCTION InvertMatrix3D (CONST Input:TMatrix): TMatrix; + Function Eye3D: TMatrix; //returns identity matrix + FUNCTION InvertMatrix (CONST a,b: TMatrix; VAR determinant: DOUBLE): TMatrix; + FUNCTION InvertMatrix1 (CONST a: TMatrix; VAR determinant: DOUBLE): TMatrix; + + // Transformation Matrices +procedure RotatePitch(lAngleDeg: double; var lM: TMatrix); +procedure RotateRoll(lAngleDeg: double; var lM: TMatrix); +procedure RotateYaw(lAngleDeg: double; var lM: TMatrix); + + FUNCTION RotateMatrix (CONST dimension: TDimension; + CONST xyz : TAxis; + CONST angle : DOUBLE; + CONST rotation : Trotation): TMatrix; + +// FUNCTION ScaleMatrix (CONST s: TVector): TMatrix; + +// FUNCTION TranslateMatrix (CONST t: TVector): TMatrix; + + FUNCTION ViewTransformMatrix (CONST coordinate: TCoordinate; + CONST azimuth {or x}, elevation {or y}, distance {or z}: DOUBLE; + CONST ScreenX, ScreenY, ScreenDistance: DOUBLE): TMatrix; + + + // conversions + +// FUNCTION FromCartesian (CONST ToCoordinate: TCoordinate; CONST u: TVector): TVector; +// FUNCTION ToCartesian (CONST FromCoordinate: TCoordinate; CONST u: TVector): TVector; + + //FUNCTION ToDegrees(CONST angle {radians}: DOUBLE): DOUBLE {degrees}; + FUNCTION ToRadians(CONST angle {degrees}: DOUBLE): DOUBLE {radians}; + + + // miscellaneous + + FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; +{ FUNCTION GetFuzz: DOUBLE; + PROCEDURE SetFuzz(CONST x: DOUBLE); + } + +IMPLEMENTATION + +Function Eye3D: TMatrix; //returns identity matrix +begin + result := Matrix3D (1,0,0,0, + 0,1,0,0, + 0,0,1,0, + 0,0,0,1); + end; + +procedure RotatePitch(lAngleDeg: double; var lM: TMatrix); +var + lRads,lCos,lSin: double; + lRot: TMatrix; +begin + lRads := ToRadians(lAngleDeg); + //lRads :=//showmessage(floattostr(lRads)); + lCos := cos(lRads); + lSin := sin(lRads); + lRot := Matrix3D (1,0,0,0, + 0,lcos,-lsin,0, + 0,lsin,lcos,0, + 0,0,0,1); + lM := MultiplyMatrices(lM,lRot); +end; + +procedure RotateRoll(lAngleDeg: double; var lM: TMatrix); +var + lRads,lCos,lSin: double; + lRot: TMatrix; +begin + lRads := ToRadians(lAngleDeg); + lCos := cos(lRads); + lSin := sin(lRads); + lRot := Matrix3D (lcos,0,lsin,0, + 0,1,0,0, + -lsin,0,lcos,0, + 0,0,0,1); + lM := MultiplyMatrices(lM,lRot); +end; + +procedure RotateYaw(lAngleDeg: double; var lM: TMatrix); +var + lRads,lCos,lSin: double; + lRot: TMatrix; +begin + lRads := ToRadians(lAngleDeg); + lCos := cos(lRads); + lSin := sin(lRads); + lRot := Matrix3D (lcos,-lsin,0,0, + lsin,lcos,0,0, + 0,0,1,0, + 0,0,0,1); + lM := MultiplyMatrices(lM,lRot); +end; + + VAR + fuzz : DOUBLE; + + +// ************************* Vector Operations ************************* + + // This procedure defines two-dimensional homogeneous coordinates (x,y,1) + // as a single 'vector' data element 'u'. The 'size' of a two-dimensional + // homogenous vector is 3. + (* FUNCTION Vector2D (CONST xValue, yValue: DOUBLE): TVector; + + BEGIN + WITH RESULT DO + BEGIN + x := xValue; + y := yValue; + z := 1.0; // should be 'h' but let's use the 'z' slot to keep + size := size2D // subscripting possible + END + END {Vector2D}; + *) + + Function SameVec (const u,v: TVector): boolean; + begin + if (u.x=v.x) and (u.y=v.y) and (u.z=v.z) then + result := true + else + result := false; + + end; + // This procedure defines three-dimensional homogeneous coordinates + // (x,y,z,1) as a single 'vector' data element 'u'. The 'size' of a + // three-dimensional homogenous vector is 4. + FUNCTION Vector3D (CONST xValue, yValue, zValue: DOUBLE): TVector; + BEGIN + WITH RESULT DO + BEGIN + x := xValue; + y := yValue; + z := zValue; + h := 1.0; // homogeneous coordinate + size := size3D + END + END {Vector3D}; + + + // AddVectors adds two vectors defined with homogeneous coordinates. + FUNCTION AddVectors (CONST u,v: TVector): TVector; + VAR + i: TIndex; + BEGIN + IF (u.size IN [size2D..size3D]) AND + (v.size IN [size2D..size3D]) AND + (u.size = v.size) + THEN BEGIN + RESULT.size := u.size; + FOR i := 1 TO u.size-1 DO {2D + 2D = 2D or 3D + 3D = 3D} + BEGIN + RESULT.vector[i] := u.vector[i] + v.vector[i] + END; + RESULT.vector[u.size] := 1.0 {homogeneous coordinate} + END + ELSE raise EVectorError.Create('Vector Addition Mismatch') + END {AddVectors}; + + + // 'Transform' multiplies a row 'vector' by a transformation 'matrix' + // resulting in a new row 'vector'. The 'size' of the 'vector' and 'matrix' + // must agree. To save execution time, the vectors are assumed to contain + // a homogeneous coordinate. + FUNCTION Transform (CONST u: TVector; CONST a: TMatrix): TVector; + VAR + i,k : TIndex; + temp: DOUBLE; + BEGIN + RESULT.size := a.size; + IF a.size = u.size + THEN BEGIN + FOR i := 1 TO a.size-1 DO + BEGIN + temp := 0.0; + FOR k := 1 TO a.size DO + BEGIN + temp := temp + u.vector[k]*a.matrix[k,i]; + END; + RESULT.vector[i] := Defuzz(temp) + END; + RESULT.vector[a.size] := 1.0 {assume homogeneous coordinate} + END + ELSE raise EMatrixError.Create('Transform multiply error') + END {Transform}; + + + // Assume vector contains 'extra' homogeneous coordinate -- ignore it. + FUNCTION DotProduct (CONST u,v: TVector): DOUBLE; + VAR + i: INTEGER; + BEGIN + IF (u.size = v.size) + THEN BEGIN + RESULT := 0.0; + FOR i := 1 TO u.size-1 DO + BEGIN + RESULT := RESULT + u.vector[i] * v.vector[i]; + END; + END + ELSE RAISE EMatrixError.Create('Vector dot product error') + END; {DotProduct} + + + // Assume vector contains 'extra' homogeneous coordinate -- ignore it. + FUNCTION CrossProduct(CONST u,v: TVector): TVector; + BEGIN + IF (u.size = v.size) AND (u.size = size3D) + THEN BEGIN + RESULT := Vector3D( u.y*v.z - v.y*u.z, + -u.x*v.z + v.x*u.z, + u.x*v.y - v.x*u.y) + END + ELSE RAISE EMatrixError.Create('Vector cross product error') + END; {CrossProduct} + + +// *********************** Basic Matrix Operations ********************** + + FUNCTION Matrix2D (CONST m11,m12,m13, m21,m22,m23, m31,m32,m33: DOUBLE): + TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; matrix[1,3] := m13; + matrix[2,1] := m21; matrix[2,2] := m22; matrix[2,3] := m23; + matrix[3,1] := m31; matrix[3,2] := m32; matrix[3,3] := m33; + size := size2D + END + END {Matrix2D}; + + + FUNCTION Matrix3D (CONST m11,m12,m13,m14, m21,m22,m23,m24, + m31,m32,m33,m34, m41,m42,m43,m44: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; + matrix[1,3] := m13; matrix[1,4] := m14; + + matrix[2,1] := m21; matrix[2,2] := m22; + matrix[2,3] := m23; matrix[2,4] := m24; + + matrix[3,1] := m31; matrix[3,2] := m32; + matrix[3,3] := m33; matrix[3,4] := m34; + + matrix[4,1] := m41; matrix[4,2] := m42; + matrix[4,3] := m43; matrix[4,4] := m44; + size := size3D + END + END {Matrix3D}; + + + // Compound geometric transformation matrices can be formed by multiplying + // simple transformation matrices. This procedure only multiplies together + // matrices for two- or three-dimensional transformations, i.e., 3x3 or 4x4 + // matrices. The multiplier and multiplicand must be of the same dimension. + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + VAR + i,j,k: TIndex; + temp : DOUBLE; + BEGIN + RESULT.size := a.size; + IF a.size = b.size + THEN + + FOR i := 1 TO a.size DO + BEGIN + FOR j := 1 TO a.size DO + BEGIN + + temp := 0.0; + FOR k := 1 TO a.size DO + BEGIN + temp := temp + a.matrix[i,k]*b.matrix[k,j]; + END; + RESULT.matrix[i,j] := Defuzz(temp) + + END + END + ELSE Showmessage('shit'+inttostr(a.size)+'x'+inttostr(b.size)); + //ELSE EMatrixError.Create('MultiplyMatrices error') + END {MultiplyMatrices}; + + + +PROCEDURE lubksb(a: {glnpbynp}TMatrix; n: integer; indx: TIntVector; VAR b: TVector); +VAR + j,ip,ii,i: integer; + sum: double; +BEGIN + ii := 0; + FOR i := 1 TO n DO BEGIN + ip := indx.vector[i]; + sum := b.vector[ip]; + b.vector[ip] := b.vector[i]; + IF (ii <> 0) THEN BEGIN + FOR j := ii TO i-1 DO BEGIN + sum := sum-a.matrix[i,j]*b.vector[j] + END + END ELSE IF (sum <> 0.0) THEN BEGIN + ii := i + END; + b.vector[i] := sum + END; + FOR i := n DOWNTO 1 DO BEGIN + sum := b.vector[i]; + IF (i < n) THEN BEGIN + FOR j := i+1 TO n DO BEGIN + sum := sum-a.matrix[i,j]*b.vector[j] + END + END; + b.vector[i] := sum/a.matrix[i,i] + END +end; + + PROCEDURE ludcmp(VAR a: TMatrix; n: integer; + VAR indx: TIntVector; VAR d: double); +CONST + tiny=1.0e-20; +VAR + k,j,imax,i: integer; + sum,dum,big: real; + vv: TVector; +BEGIN + d := 1.0; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO IF (abs(a.matrix[i,j]) > big) THEN big := abs(a.matrix[i,j]); + IF (big = 0.0) THEN BEGIN + writeln('pause in LUDCMP - singular matrix'); readln + END; + vv.vector[i] := 1.0/big + END; + FOR j := 1 TO n DO BEGIN + FOR i := 1 TO j-1 DO BEGIN + sum := a.matrix[i,j]; + FOR k := 1 TO i-1 DO BEGIN + sum := sum-a.matrix[i,k]*a.matrix[k,j] + END; + a.matrix[i,j] := sum + END; + big := 0.0; + FOR i := j TO n DO BEGIN + sum := a.matrix[i,j]; + FOR k := 1 TO j-1 DO BEGIN + sum := sum-a.matrix[i,k]*a.matrix[k,j] + END; + a.matrix[i,j] := sum; + dum := vv.vector[i]*abs(sum); + IF (dum > big) THEN BEGIN + big := dum; + imax := i + END + END; + IF (j <> imax) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a.matrix[imax,k]; + a.matrix[imax,k] := a.matrix[j,k]; + a.matrix[j,k] := dum + END; + d := -d; + vv.vector[imax] := vv.vector[j] + END; + indx.vector[j] := imax; + IF (a.matrix[j,j] = 0.0) THEN a.matrix[j,j] := tiny; + IF (j <> n) THEN BEGIN + dum := 1.0/a.matrix[j,j]; + FOR i := j+1 TO n DO BEGIN + a.matrix[i,j] := a.matrix[i,j]*dum + END + END + END; +END; + + FUNCTION InvertMatrix3D (CONST Input:TMatrix): TMatrix; + var + n,i,j: integer; + d: double; + indx: tIntVector; + col: tvector; + a,y: TMatrix; + begin + a:= Input; + n := 3; + y.size := size3D; + ludcmp(a,n,indx,d); + for j := 1 to n do begin + for i := 1 to n do col.vector[i] := 0; + col.vector[j] := 1.0; + lubksb(a,n,indx,col); + for i := 1 to n do y.matrix[i,j] := col.vector[i]; + end; + result := y; + end; + + // This procedure inverts a general transformation matrix. The user need + // not form an inverse geometric transformation by keeping a product of + // the inverses of simple geometric transformations: translations, rotations + // and scaling. A determinant of zero indicates no inverse is possible for + // a singular matrix. + FUNCTION InvertMatrix (CONST a,b: TMatrix; VAR determinant: DOUBLE): TMatrix; + VAR + c : TMatrix; + i,i_pivot: TIndex; + i_flag : ARRAY[TIndex] OF BOOLEAN; + j,j_pivot: TIndex; + j_flag : ARRAY[TIndex] OF BOOLEAN; + modulus : DOUBLE; + n : TIndex; + pivot : DOUBLE; + pivot_col: ARRAY[TIndex] OF TIndex; + pivot_row: ARRAY[TIndex] OF TIndex; + temporary: DOUBLE; + BEGIN + c := a; // The matrix inversion algorithm used here + WITH c DO // is similar to the "maximum pivot strategy" + BEGIN // described in "Applied Numerical Methods" + FOR i := 1 TO size DO // by Carnahan, Luther and Wilkes, + BEGIN // pp. 282-284. + i_flag[i] := TRUE; + j_flag[i] := TRUE + END; + modulus := 1.0; + i_pivot := 1; // avoid initialization warning + j_pivot := 1; // avoid initialization warning + + FOR n := 1 TO size DO + BEGIN + pivot := 0.0; + IF ABS(modulus) > 0.0 + THEN BEGIN + FOR i := 1 TO size DO + IF i_flag[i] + THEN + + FOR j := 1 TO size DO + IF j_flag[j] + THEN + IF ABS(matrix[i,j]) > ABS(pivot) + THEN BEGIN + pivot := matrix[i,j]; // largest value on which to pivot + i_pivot := i; // indices of pivot element + j_pivot := j + END; + + IF Defuzz(pivot) = 0 // If pivot is too small, consider + THEN modulus := 0 // the matrix to be singular + ELSE BEGIN + pivot_row[n] := i_pivot; + pivot_col[n] := j_pivot; + i_flag[i_pivot] := FALSE; + j_flag[j_pivot] := FALSE; + FOR i := 1 TO size DO + IF i <> i_pivot + THEN + FOR j := 1 TO size DO // pivot column unchanged for elements + IF j <> j_pivot // not in pivot row or column ... + THEN matrix[i,j] := (matrix[i,j]*matrix[i_pivot,j_pivot] - + matrix[i_pivot,j]*matrix[i,j_pivot]) + / modulus; // 2x2 minor / modulus + FOR j := 1 TO size DO + IF j <> j_pivot // change signs of elements in pivot row + THEN matrix[i_pivot,j] := -matrix[i_pivot,j]; + temporary := modulus; // exchange pivot element and modulus + modulus := matrix[i_pivot,j_pivot]; + matrix[i_pivot,j_pivot] := temporary + END + END + END {FOR n} + END {WITH}; + determinant := Defuzz(modulus); + IF determinant <> 0 + THEN BEGIN + RESULT.size := c.size; // The matrix inverse must be unscrambled + FOR i := 1 TO c.size DO // if pivoting was not along main diagonal. + FOR j := 1 TO c.size DO + RESULT.matrix[pivot_row[i],pivot_col[j]] := Defuzz(c.matrix[i,j]/determinant) + END + ELSE EMatrixError.Create('InvertMatrix error') + + END {InvertMatrix}; + + FUNCTION InvertMatrix1 (CONST a: TMatrix; VAR determinant: DOUBLE): TMatrix; + VAR + c : TMatrix; + i,i_pivot: TIndex; + i_flag : ARRAY[TIndex] OF BOOLEAN; + j,j_pivot: TIndex; + j_flag : ARRAY[TIndex] OF BOOLEAN; + modulus : DOUBLE; + n : TIndex; + pivot : DOUBLE; + pivot_col: ARRAY[TIndex] OF TIndex; + pivot_row: ARRAY[TIndex] OF TIndex; + temporary: DOUBLE; + BEGIN + c := a; // The matrix inversion algorithm used here + WITH c DO // is similar to the "maximum pivot strategy" + BEGIN // described in "Applied Numerical Methods" + FOR i := 1 TO size DO // by Carnahan, Luther and Wilkes, + BEGIN // pp. 282-284. + i_flag[i] := TRUE; + j_flag[i] := TRUE + END; + modulus := 1.0; + i_pivot := 1; // avoid initialization warning + j_pivot := 1; // avoid initialization warning + + FOR n := 1 TO size DO + BEGIN + pivot := 0.0; + IF ABS(modulus) > 0.0 + THEN BEGIN + FOR i := 1 TO size DO + IF i_flag[i] + THEN + + FOR j := 1 TO size DO + IF j_flag[j] + THEN + IF ABS(matrix[i,j]) > ABS(pivot) + THEN BEGIN + pivot := matrix[i,j]; // largest value on which to pivot + i_pivot := i; // indices of pivot element + j_pivot := j + END; + + IF Defuzz(pivot) = 0 // If pivot is too small, consider + THEN modulus := 0 // the matrix to be singular + ELSE BEGIN + pivot_row[n] := i_pivot; + pivot_col[n] := j_pivot; + i_flag[i_pivot] := FALSE; + j_flag[j_pivot] := FALSE; + FOR i := 1 TO size DO + IF i <> i_pivot + THEN + FOR j := 1 TO size DO // pivot column unchanged for elements + IF j <> j_pivot // not in pivot row or column ... + THEN matrix[i,j] := (matrix[i,j]*matrix[i_pivot,j_pivot] - + matrix[i_pivot,j]*matrix[i,j_pivot]) + / modulus; // 2x2 minor / modulus + FOR j := 1 TO size DO + IF j <> j_pivot // change signs of elements in pivot row + THEN matrix[i_pivot,j] := -matrix[i_pivot,j]; + temporary := modulus; // exchange pivot element and modulus + modulus := matrix[i_pivot,j_pivot]; + matrix[i_pivot,j_pivot] := temporary + END + END + END {FOR n} + END {WITH}; + + determinant := Defuzz(modulus); + IF determinant <> 0 + THEN BEGIN + RESULT.size := c.size; // The matrix inverse must be unscrambled + FOR i := 1 TO c.size DO // if pivoting was not along main diagonal. + FOR j := 1 TO c.size DO + RESULT.matrix[pivot_row[i],pivot_col[j]] := Defuzz(c.matrix[i,j]/determinant) + END + ELSE EMatrixError.Create('InvertMatrix error') + + END {InvertMatrix}; + +(* FUNCTION InvertMatrix1 (CONST a: TMatrix; VAR determinant: DOUBLE): TMatrix; + VAR + c : TMatrix; + i,i_pivot: TIndex; + i_flag : ARRAY[TIndex] OF BOOLEAN; + j,j_pivot: TIndex; + j_flag : ARRAY[TIndex] OF BOOLEAN; + modulus : DOUBLE; + n : TIndex; + pivot : DOUBLE; + pivot_col: ARRAY[TIndex] OF TIndex; + pivot_row: ARRAY[TIndex] OF TIndex; + temporary: DOUBLE; + BEGIN + c := a; // The matrix inversion algorithm used here + WITH c DO // is similar to the "maximum pivot strategy" + BEGIN // described in "Applied Numerical Methods" + FOR i := 1 TO size DO // by Carnahan, Luther and Wilkes, + BEGIN // pp. 282-284. + i_flag[i] := TRUE; + j_flag[i] := TRUE + END; + modulus := 1.0; + i_pivot := 1; // avoid initialization warning + j_pivot := 1; // avoid initialization warning + + FOR n := 1 TO size DO + BEGIN + pivot := 0.0; + IF ABS(modulus) > 0.0 + THEN BEGIN + FOR i := 1 TO size DO + IF i_flag[i] + THEN + + FOR j := 1 TO size DO + IF j_flag[j] + THEN + IF ABS(matrix[i,j]) > ABS(pivot) + THEN BEGIN + pivot := matrix[i,j]; // largest value on which to pivot + i_pivot := i; // indices of pivot element + j_pivot := j + END; + + IF Defuzz(pivot) = 0 // If pivot is too small, consider + THEN modulus := 0 // the matrix to be singular + ELSE BEGIN + pivot_row[n] := i_pivot; + pivot_col[n] := j_pivot; + i_flag[i_pivot] := FALSE; + j_flag[j_pivot] := FALSE; + FOR i := 1 TO size DO + IF i <> i_pivot + THEN + FOR j := 1 TO size DO // pivot column unchanged for elements + IF j <> j_pivot // not in pivot row or column ... + THEN matrix[i,j] := (matrix[i,j]*matrix[i_pivot,j_pivot] - + matrix[i_pivot,j]*matrix[i,j_pivot]) + / modulus; // 2x2 minor / modulus + FOR j := 1 TO size DO + IF j <> j_pivot // change signs of elements in pivot row + THEN matrix[i_pivot,j] := -matrix[i_pivot,j]; + temporary := modulus; // exchange pivot element and modulus + modulus := matrix[i_pivot,j_pivot]; + matrix[i_pivot,j_pivot] := temporary + END + END + END {FOR n} + END {WITH}; + determinant := Defuzz(modulus); + IF determinant <> 0 + THEN BEGIN + RESULT.size := c.size; // The matrix inverse must be unscrambled + FOR i := 1 TO c.size DO // if pivoting was not along main diagonal. + FOR j := 1 TO c.size DO + RESULT.matrix[pivot_row[i],pivot_col[j]] := Defuzz(c.matrix[i,j]/determinant) + END + + ELSE EMatrixError.Create('InvertMatrix error') + + END {InvertMatrix}; *) + +// *********************** Transformation Matrices ******************** + + + // This procedure defines a matrix for a two- or three-dimensional rotation. + // To avoid possible confusion in the sense of the rotation, 'rotateClockwise' + // or 'roCounterlcockwise' must always be specified along with the axis + // of rotation. Two-dimensional rotations are assumed to be about the z-axis + // in the x-y plane. + // + // A rotation about an arbitrary axis can be performed with the following + // steps: + // (1) Translate the object into a new coordinate system where (x,y,z) + // maps into the origin (0,0,0). + // (2) Perform appropriate rotations about the x and y axes of the + // coordinate system so that the unit vector (a,b,c) is mapped into + // the unit vector along the z axis. + // (3) Perform the desired rotation about the z-axis of the new + // coordinate system. + // (4) Apply the inverse of step (2). + // (5) Apply the inverse of step (1). + FUNCTION RotateMatrix (CONST dimension: TDimension; + CONST xyz : TAxis; + CONST angle : DOUBLE; + CONST rotation : Trotation): TMatrix; + VAR + cosx : DOUBLE; + sinx : DOUBLE; + TempAngle: DOUBLE; + + BEGIN + TempAngle := angle; // Use TempAngle since "angle" is CONST parameter + + IF rotation = rotateCounterClockwise + THEN TempAngle := -TempAngle; + + cosx := Defuzz( COS(TempAngle) ); + sinx := Defuzz( SIN(TempAngle) ); + + CASE dimension OF + dimen2D: + CASE xyz OF + axisX,axisY: EMatrixError.Create('Invalid 2D rotation matrix. Specify axisZ'); + + axisZ: RESULT := Matrix2D ( cosx, -sinx, 0, + sinx, cosx, 0, + 0, 0, 1) + END; + + dimen3D: + CASE xyz OF + axisX: RESULT := Matrix3D ( 1, 0, 0, 0, + 0, cosx, -sinx, 0, + 0, sinx, cosx, 0, + 0, 0, 0, 1); + + axisY: RESULT := Matrix3D ( cosx, 0, sinx, 0, + 0, 1, 0, 0, + -sinx, 0, cosx, 0, + 0, 0, 0, 1); + + axisZ: RESULT := Matrix3D ( cosx, -sinx, 0, 0, + sinx, cosx, 0, 0, + 0, 0, 1, 0, + 0, 0, 0, 1); + END + END + END {RotateMatrix}; + + + // 'ScaleMatrix' accepts a 'vector' containing the scaling factors for + // each of the dimensions and creates a scaling matrix. The size + // of the vector dictates the size of the resulting matrix. + FUNCTION ScaleMatrix (CONST s: TVector): TMatrix; + BEGIN + CASE s.size OF + size2D: RESULT := Matrix2D (s.x, 0, 0, + 0, s.y, 0, + 0, 0, 1); + + size3D: RESULT := Matrix3D (s.x, 0, 0, 0, + 0, s.y, 0, 0, + 0, 0, s.z, 0, + 0, 0, 0, 1) + END + END {ScaleMatrix}; + // 'TranslateMatrix' defines a translation transformation matrix. The + // components of the vector 't' determine the translation components. + // (Note: 'Translate' here is from kinematics in physics.) + FUNCTION TranslateMatrix (CONST t: TVector): TMatrix; + BEGIN + CASE t.size OF + size2D: RESULT := Matrix2D ( 1, 0, 0, + 0, 1, 0, + t.x, t.y, 1); + + size3D: RESULT := Matrix3D ( 1, 0, 0, 0, + 0, 1, 0, 0, + 0, 0, 1, 0, + t.x, t.y, t.z, 1) + END + END {TranslateMatrix}; + // 'ViewTransformMatrix' creates a transformation matrix for changing + // from world coordinates to eye coordinates. The location of the 'eye' + // from the 'object' is given in spherical (azimuth,elevation,distance) + // coordinates or Cartesian (x,y,z) coordinates. The size of the screen + // is 'ScreenX' units horizontally and 'ScreenY' units vertically. The + // eye is 'ScreenDistance' units from the viewing screen. A large ratio + // 'ScreenDistance/ScreenX (or ScreenY)' specifies a narrow aperature + // -- a telephoto view. Conversely, a small ratio specifies a large + // aperature -- a wide-angle view. This view transform matrix is very + // useful as the default three-dimensional transformation matrix. Once + // set, all points are automatically transformed. + FUNCTION ViewTransformMatrix (CONST coordinate: TCoordinate; + CONST azimuth {or x}, elevation {or y}, distance {or z}: DOUBLE; + CONST ScreenX, ScreenY, ScreenDistance: DOUBLE): TMatrix; + + CONST + HalfPI = PI / 2.0; + + VAR + a : TMatrix; + b : TMatrix; + cosm : DOUBLE; // COS(-angle) + hypotenuse: DOUBLE; + sinm : DOUBLE; // SIN(-angle) + temporary : DOUBLE; + u : TVector; + x : DOUBLE ABSOLUTE azimuth; // x and azimuth are synonyms + y : DOUBLE ABSOLUTE elevation; // synonyms + z : DOUBLE ABSOLUTE distance; // synonyms + + BEGIN + CASE coordinate OF + coordCartesian: u := Vector3D (-x, -y, -z); + + coordSpherical: + BEGIN + temporary := -distance * COS(elevation); + u := Vector3D (temporary * COS(azimuth - HalfPI), + temporary * SIN(azimuth - HalfPI), + -distance * SIN(elevation)); + END + END; + a := TranslateMatrix(u); // translate origin to 'eye' + b := RotateMatrix (dimen3D, axisX, HalfPI, rotateClockwise); + a := MultiplyMatrices(a,b); + + CASE coordinate OF + coordCartesian: + BEGIN + temporary := SQR(x) + SQR(y); + hypotenuse := SQRT(temporary); + if hypotenuse <> 0 then begin + cosm := -y/hypotenuse; + sinm := x/hypotenuse; + end else begin + cosm := 1;//abba + sinm := 0; + end; + + b := Matrix3D ( cosm, 0, sinm, 0, + 0, 1, 0, 0, + -sinm, 0, cosm, 0, + 0, 0, 0, 1); + + a := MultiplyMatrices (a,b); + cosm := hypotenuse; + hypotenuse := SQRT(temporary + SQR(z)); + cosm := cosm/hypotenuse; + sinm := -z/hypotenuse; + + b := Matrix3D ( 1, 0, 0, 0, + 0, cosm, -sinm, 0, + 0, sinm, cosm, 0, + 0, 0, 0, 1) + END; + coordSpherical: + BEGIN + b := RotateMatrix (dimen3D,axisY,-azimuth,rotateCounterClockwise); + a := MultiplyMatrices(a,b); + b := RotateMatrix (dimen3D,axisX,elevation,rotateCounterClockwise); + END + END {CASE}; + + a := MultiplyMatrices (a,b); + u := Vector3D (ScreenDistance/(0.5*ScreenX), + ScreenDistance/(0.5*ScreenY),-1.0); + b := ScaleMatrix (u); // reverse sense of z-axis; screen transformation + + RESULT := MultiplyMatrices (a,b); + + END {ViewTransformMatrix}; + +// *************************** Conversions ************************** + // This function converts the vector parameter from Cartesian + // coordinates to the specified type of coordinates. + FUNCTION FromCartesian (CONST ToCoordinate: TCoordinate; CONST u: TVector): TVector; + VAR + phi : DOUBLE; + r : DOUBLE; + temp : DOUBLE; + theta: DOUBLE; + + BEGIN + IF ToCoordinate = coordCartesian + THEN RESULT := u + ELSE BEGIN + RESULT.size := u.size; + + IF (u.size = size3D) AND + (ToCoordinate = coordSpherical) + THEN BEGIN // spherical 3D + temp := SQR(u.x)+SQR(u.y); // (x,y,z) -> (r,theta,phi) + r := SQRT(temp+SQR(u.z)); + IF Defuzz(u.x) = 0.0 + THEN theta := PI/4 + ELSE theta := ARCTAN(u.y/u.x); + IF Defuzz(u.z) = 0.0 + THEN phi := PI/4 + ELSE phi := ARCTAN(SQRT(temp)/u.z); + RESULT.x := r; + RESULT.y := theta; + RESULT.z := phi + END + ELSE BEGIN // cylindrical 2D/3D or spherical 2D + // (x,y) -> (r,theta) or (x,y,z) -> (r,theta,z) + r := SQRT( SQR(u.x) + SQR(u.y) ); + IF Defuzz(u.x) = 0.0 + THEN theta := PI/4 + ELSE theta := ARCTAN(u.y/u.x); + RESULT.x := r; + RESULT.y := theta + END + + END + END {FromCartesian}; + + + // This function converts the vector parameter from specified coordinates + // into Cartesian coordinates. + FUNCTION ToCartesian (CONST FromCoordinate: TCoordinate; CONST u: TVector): TVector; + VAR + phi : DOUBLE; + r : DOUBLE; + sinphi: DOUBLE; + theta : DOUBLE; + + BEGIN + RESULT := u; + + IF FromCoordinate = coordCartesian + THEN RESULT := u + ELSE BEGIN + RESULT.size := u.size; + + IF (u.size = size3D) AND + (FromCoordinate = coordSpherical) + THEN BEGIN // spherical 3D + r := u.x; // (r,theta,phi) -> (x,y,z) + theta := u.y; + phi := u.z; + sinphi := SIN(phi); + RESULT.x := r * COS(theta) * sinphi; + RESULT.y := r * SIN(theta) * sinphi; + RESULT.z := r * COS(phi) + END + ELSE BEGIN // cylindrical 2D/3D or spherical 2D + r := u.x; // (r,theta) -> (x,y) or (r,theta,z) -> (x,y,z) + theta := u.y; + RESULT.x := r * COS(theta); + RESULT.y := r * SIN(theta) + END + END + END {ToCartesian}; + + // Convert angle in radians to degrees. + (*FUNCTION ToDegrees(CONST angle {radians}: DOUBLE): DOUBLE {degrees}; + BEGIN + RESULT := 180.0/PI * angle + END ;//ToDegrees*) + + + // Convert angle in degrees to radians. + FUNCTION ToRadians (CONST angle: DOUBLE): DOUBLE; + BEGIN + RESULT := PI/180.0 * angle + END; {ToRadians} + + +// *************************** Miscellaneous ************************** + + // 'Defuzz' is used for comparisons and to avoid propagation of 'fuzzy', + // nearly-zero values. DOUBLE calculations often result in 'fuzzy' values. + // The term 'fuzz' was adapted from the APL language. + FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; + BEGIN + IF ABS(x) < fuzz + THEN RESULT := 0.0 + ELSE RESULT := x + END {Defuzz}; + +(* FUNCTION GetFuzz: DOUBLE; + BEGIN + RESULT := fuzz + END {GetFuzz}; + *) + + {PROCEDURE SetFuzz(CONST x: DOUBLE); + BEGIN + fuzz := x + END; {SetFuzz} + +INITIALIZATION + fuzz := 1.0E-6; + //SetFuzz(1.0E-6) +END {GraphicsMath UNIT}. diff --git a/niftiview7/MRIcroN.cfg b/niftiview7/MRIcroN.cfg new file mode 100755 index 0000000..b38b09a --- /dev/null +++ b/niftiview7/MRIcroN.cfg @@ -0,0 +1,39 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-LN"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-U"C:\pas\mricron\niftiview7\tpmath;C:\pas\mricron\niftiview7\gzio" +-O"C:\pas\mricron\niftiview7\tpmath;C:\pas\mricron\niftiview7\gzio" +-I"C:\pas\mricron\niftiview7\tpmath;C:\pas\mricron\niftiview7\gzio" +-R"C:\pas\mricron\niftiview7\tpmath;C:\pas\mricron\niftiview7\gzio" diff --git a/niftiview7/MRIcroN.ini b/niftiview7/MRIcroN.ini new file mode 100755 index 0000000..8c09b3d --- /dev/null +++ b/niftiview7/MRIcroN.ini @@ -0,0 +1,47 @@ +[STR] +FSLDIR= +FSLOUTPUTTYPE= +[MRU] +file0=C:\mricrogl\visiblehuman.nii.gz +file1=C:\mricrogl\visiblehuman.nii.gz +file2=C:\pas\raycast\motor.nii.gz +file3=C:\pas\raycast\mni152_2009bet.nii.gz +file4=C:\pas\raycast\mni152_2009bet.nii +file5=C:\test\test c.nii +[BOOL] +AutoFill=0 +FlipAx=0 +FlipSag=0 +LRmirror=0 +OverlaySmooth=1 +Reslice=1 +ResliceOrtho=1 +ShowDraw=1 +SingleRow=1 +Smooth2D=0 +ThinPen=1 +XBar=1 +Yoke=0 +[INT] +BGTransPct=-1 +ImageSeparation=0 +LesionSmooth=3 +LesionDilate=8 +LicenseID=0 +LUT=0 +MaxDim=512 +MaxThreads=8 +OverlayTransPct=-1 +SigDigits=5 +SPMDefaultsStatsFmriT=16 +SPMDefaultsStatsFmriT0=1 +TabletPressure=70 +TabletErasePressure=30 +FontSize=12 +XBarGap=7 +XBarThick=3 +Zoom=0 +PlanarRGB=2 +[CLR] +VOIClr=FF0000 +XBarClr=0000FF diff --git a/niftiview7/MRIcroN_no_ole.ini b/niftiview7/MRIcroN_no_ole.ini new file mode 100755 index 0000000..2b59f01 --- /dev/null +++ b/niftiview7/MRIcroN_no_ole.ini @@ -0,0 +1,41 @@ +[STR] +FSLDIR= +FSLOUTPUTTYPE= +[MRU] +file0=C:\Users\neuropsych\Desktop\perf_vlsm_analysis\ttestMnU.nii.gz +file1=C:\Users\neuropsych\Desktop\perf_vlsm_analysis\ttestMnU.nii.gz +file2=C:\Users\neuropsych\Desktop\perf_vlsm_analysis\ttestObsU.nii.gz +file3=C:\Users\neuropsych\Desktop\perf_vlsm_analysis\ttestZU.nii.gz +file4= +file5= +[BOOL] +AutoFill=0 +FlipAx=0 +FlipSag=0 +LRmirror=0 +OverlaySmooth=0 +Reslice=0 +ResliceOrtho=1 +ShowDraw=0 +SingleRow=0 +Smooth2D=0 +ThinPen=1 +XBar=0 +Yoke=0 +[INT] +BGTransPct=0 +ImageSeparation=0 +LesionSmooth=3 +LicenseID=0 +LUT=0 +MaxDim=512 +MaxThreads=8 +OverlayTransPct=-1 +SigDigits=5 +SPMDefaultsStatsFmriT=16 +SPMDefaultsStatsFmriT0=1 +TabletPressure=70 +TabletErasePressure=30 +XBarGap=7 +XBarThick=3 +Zoom=0 diff --git a/niftiview7/MultiSlice.pas b/niftiview7/MultiSlice.pas new file mode 100755 index 0000000..62ffdcf --- /dev/null +++ b/niftiview7/MultiSlice.pas @@ -0,0 +1,797 @@ +unit MultiSlice; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, Menus,ClipBrd,nifti_img, nifti_hdr,define_types, + nifti_img_view,INiFiles,FileCtrl; +const + kMaxMultiSlice = 24; +type + TMultiSlice = record + Orient,nSlices,OverslicePct: integer; + OrthoView,SliceLabel: boolean; + SliceList: array [1..kMaxMultiSlice] of integer; + end;//TMultiSlice + TMultiSliceForm = class(TForm) + MainMenu1: TMainMenu; + File1: TMenuItem; + Saveasbitmap1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + MultiPanel: TScrollBox; + MultiImage: TImage; + View1: TMenuItem; + OrientMenu: TMenuItem; + Axial1: TMenuItem; + Sagittal1: TMenuItem; + Coronal1: TMenuItem; + Orthoview: TMenuItem; + Slices1: TMenuItem; + Savesettings1: TMenuItem; + Settings1: TMenuItem; + MultiSaveDialog: TSaveDialog; + SliceLabelCheck: TMenuItem; + OversliceMenu: TMenuItem; + N501: TMenuItem; + N331: TMenuItem; + N201: TMenuItem; + N01: TMenuItem; + N202: TMenuItem; + N351: TMenuItem; + N502: TMenuItem; + Close1: TMenuItem; + NoOver: TMenuItem; + procedure Copy1Click(Sender: TObject); + procedure Saveasbitmap1Click(Sender: TObject); + procedure OrientClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure CreateMultiAx; + procedure CreateMultiCor; + procedure CreateMultiSag; + procedure CreateMultiSlice; + procedure OrthoviewClick(Sender: TObject); + procedure Slices1Click(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure UpdateMultiSliceDisplay; + procedure OpenMultiMRU(Sender:TObject); + procedure UpdateMultiSliceMRU; + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure Savesettings1Click(Sender: TObject); + procedure SliceLabelCheckClick(Sender: TObject); + procedure OverlsiceClick(Sender: TObject); + procedure Close1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + MultiSliceForm: TMultiSliceForm; + gMulti:TMultiSlice; + gMultiSliceDir,gMultiSliceStartupFilename,gMultiSliceDefaultsFilename:string; +implementation + +{$R *.DFM} +procedure HLineWithFlatEndCaps (lCanvas: TCanvas; lColor: TColor; X1,X2,Y1,lThick: integer); +var + Y : integer; +begin + Y := Y1 - (lThick div 2); + lCanvas.Brush.Color := lColor; + lCanvas.FillRect(Rect(x1, y, x2, y+lThick)); +end; + +procedure VLineWithFlatEndCaps (lCanvas: TCanvas; lColor: TColor; X1,Y1,Y2,lThick: integer); +var + X : integer; +begin + X := X1 - (lThick div 2)-1; + lCanvas.Brush.Color := lColor; + lCanvas.FillRect(Rect(x, y1, x+lThick,Y2)); +end; + + +function MultiSliceNum2String: string; +var + lSlice: integer; +begin + result := ''; + for lSlice := 1 to gMulti.nSlices do begin + result := result+inttostr(gMulti.SliceList[lSlice]); + if lSlice < gMulti.nSlices then + result := result+','; + end; //for each slice +end; + +procedure MultiSliceString2Num (var lStr: string); +var + lSliceStr: string; + lStrPos,lStrLen,lSlice: integer; +begin + lStrLen := length(lStr); + if lStrLen < 1 then exit; + lSlice := 0; + lSliceStr := ''; + for lStrPos := 1 to lStrLen do begin + if lStr[lStrPos] in ['0'..'9'] then + lSliceStr := lSliceStr+lStr[lStrPos]; + if ((not (lStr[lStrPos] in ['0'..'9'])) or (lStrPos=lStrLen)) and (lSliceStr<>'') then begin + inc(lSlice); + if lSlice <= kMaxMultiSlice then + gMulti.SliceList[lSlice] := strtoint(lSliceStr); + lSliceStr := ''; + end; //if white space or eoln + end; //for lStrPos + gMulti.nSlices := lSlice; + if lSlice > kMaxMultiSlice then begin + showmessage('Warning: maximum number of slices is '+inttostr(kMaxMultiSlice)); + gMulti.nSlices := kMaxMultiSlice; + end; +end; + +procedure WriteMultiSliceIniFile (lFilename: string); +var + lIniFile: TIniFile; +begin + if DiskFreeEx(lFilename) < 1 then + exit; + if not DirectoryExists(extractfiledir(lFilename)) then begin + mkDir(extractfiledir(lFilename)); + end; + lIniFile := TIniFile.Create(lFilename); + //Slice Index + lIniFile.WriteString('STR', 'Slices', MultiSliceNum2String); + //Booleans + lIniFile.WriteString('BOOL', 'OrthoView',Bool2Char( gMulti.OrthoView)); + lIniFile.WriteString('BOOL', 'SliceLabel',Bool2Char( gMulti.SliceLabel)); + //Integers LicenseID + lIniFile.WriteString('INT', 'Orient',IntToStr(gMulti.Orient)); + lIniFile.WriteString('INT', 'OverslicePct',IntToStr(gMulti.OverslicePct)); + //ovx + lIniFile.Free; +end; + +procedure ReadMultiSliceIniFile (lFilename: string); +var + lStr: string; + lIniFile: TIniFile; +begin + if not FileexistsEx(lFilename) then begin + showmessage('Unable to find '+lFilename); + exit; + end; + lIniFile := TIniFile.Create(lFilename); + lStr := lIniFile.ReadString('STR', 'Slices', '10,20,30');//file0 - last file viewed + MultiSliceString2Num(lStr); + gMulti.OrthoView := IniBool(lIniFile,'OrthoView',gMulti.OrthoView); + gMulti.SliceLabel := IniBool(lIniFile,'SliceLabel',gMulti.SliceLabel); + gMulti.Orient:= IniInt(lIniFile,'Orient',gMulti.Orient); + gMulti.OverslicePct:= IniInt(lIniFile,'OverslicePct',gMulti.OverslicePct); + //ovx + lIniFile.Free; +end; + +procedure TMultiSliceForm.OpenMultiMRU(Sender:TObject); +var + lFilename: string; +begin + //showmessage( (Sender as TMenuItem).Caption); + lFilename := gMultiSliceDir +(Sender as TMenuItem).caption+'.ini' ; + ReadMultiSliceIniFile(lFilename); + //showmessage(lFilename); + UpdateMultiSliceDisplay; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.UpdateMultiSliceMRU; +var + NewItem: TMenuItem; + lSearchRec: TSearchRec; +begin + While Settings1.Count > 0 do Settings1.Items[0].Free; + if FindFirst(gMultiSliceDir +'*.ini', faAnyFile, lSearchRec) = 0 then + repeat + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ParseFileName(ExtractFileName(lSearchRec.Name)); + NewItem.Onclick := OpenMultiMRU; + NewItem.AutoHotkeys := maManual; + Settings1.Add(NewItem); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end; + +procedure TMultiSliceForm.Copy1Click(Sender: TObject); +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (MultiImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + MultiImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); +end; + +procedure TMultiSliceForm.Saveasbitmap1Click(Sender: TObject); +begin + SaveImgAsPNGBMP (MultiImage); +end; + +procedure CreateBlankBitmap (lPGHt,lPGWid:integer;var lImage: TImage); +var + sbBits : PByteArray; + l32BitP: DWordp; + lBGInvisibleColor: DWord; + lBMP: TBitmap; + lInc : integer; +begin + lBMP := TBitmap.Create; + TRY + lBMP.PixelFormat := pf32bit; + lBMP.Width := lPGwid; + lBMP.Height := lPGHt; + sbBits := lBmp.ScanLine[lPGHt-1]; + //FillChar(sbBits^,(lPGHt*lPGwid*4), 0); + //FillChar fills with black, the next bit will fill current background color + lBGInvisibleColor := gMRIcroOverlay[kBGOverlayNum].LUTinvisible; + l32BitP := DWordp(sbBits); + for lInc := 1 to (lPGwid*lPGHt) do + l32BitP[lInc] := lBGInvisibleColor; + lImage.Width := (lBmp.Width);//xx + lImage.Height := (lBmp.Height);//xx + lImage.Picture.Graphic := lBMP; + FINALLY + lBMP.Free; + END; //try..finally +end; //proc CreateBlankBitmap + +procedure DefineBackGround(var lBMP: DWordp; lBGInvisibleColor: DWord; lMaskHt,lMaskWid: integer); +//lMaskP should have all invis voxels as 128, non as 255 +//sets all invis boundary voxels to 0 +var + lMaskP: ByteP; + lBGvisibleColor: DWord; + lPos,lMaskSz, + lQSz,lQHead,lQTail: integer; + lQRA: LongIntp; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; +PROCEDURE RetirePixel; //FIFO cleanup +VAR + lVal,lPos: integer; +BEGIN + lVal := lQra[lQTail]; + lPos := lVal-1; + if (lPos > 0) and (lMaskP[lPos]=128) then begin//add item to left + incQra(lQHead,lQSz); + lMaskP[lPos] := 0; + lQra[lQHead] := lPos; + end; + if (lPos > 0) then lMaskP[lPos] := 0; + lPos := lVal+1; + if (lPos < lMaskSz) and (lMaskP[lPos]=128) then begin//add item to right + incQra(lQHead,lQSz); + lMaskP[lPos] := 0; + lQra[lQHead] := lPos; + end; + if (lPos < lMaskSz) then lMaskP[lPos] := 0; + lPos := lVal-lMaskWid; + if (lPos > 0) and (lMaskP[lPos]=128) then begin//add item above + incQra(lQHead,lQSz); + lMaskP[lPos] := 0; + lQra[lQHead] := lPos; + end; + if (lPos > 0) then lMaskP[lPos] := 0; + lPos := lVal+lMaskWid; + if (lPos < lMaskSz) and(lMaskP[lPos]=128) then begin//add item below + incQra(lQHead,lQSz); + lMaskP[lPos] := 0; + lQra[lQHead] := lPos; + end; + if (lPos < lMaskSz) then lMaskP[lPos] := 0; + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +begin + if (lPt < 1) or (lPt > lMaskSz) or (lMaskP[lPt] <> 128) then exit; + //lQSz := 8000;//size of FIFO Queue Array + lQHead := 1; + lQTail := 1; + lQra[lQTail] := (lPt); //NOTE: both X and Y start from 0 not 1 + lMaskP[lPt] := 0; + RetirePixel; + if lQHead >= lQTail then begin + while lQHead <> lQTail do + RetirePixel; + end; +end; +begin //proc DefineBG + lMaskSz := lMaskWid * lMaskHt; + Getmem(lMaskP,lMaskSz); + for lPos := 1 to lMaskSz do + if lBMP[lPos] = lBGInvisibleColor then + lMaskP[lPos] := 128 + else + lMaskP[lPos] := 255; + lQSz := lMaskSz div 4; + GetMem(lQra,lQSz*sizeof(LongInt)); + //erase all rows + for lPos := 1 to lMaskHt do begin + FillStart( (lPos-1)*lMaskWid + 1); + FillStart( (lPos)*lMaskWid); + end; + //erase all cols + for lPos := 1 to lMaskWid do begin + FillStart( lPos + 1); + FillStart( ((lMaskHt-1) *lMaskWid) + lPos); + end; + Freemem(lQRa); + //make sure bright blue 0000FF becauses neighbor 0000FE instead of 000100 + if (lBGInvisibleColor and 255) = 255 then + lBGVisibleColor:= lBGInvisibleColor-1 + else + lBGVisibleColor:= lBGInvisibleColor+1; + //now, fill in islands so they are not transparent + for lPos := 1 to lMaskSz do + if lMaskP[lPos] = 128 then + lBMP[lPos] := lBGVisibleColor; + Freemem(lMaskP); + +end; + + +procedure RemoveHorizGaps (lMaxOverlapWid: integer); //will overlap gaps from 1..lMaxOverlapWid, leave right non-overlapped); +var + sbBits,sbOutBits : PByteArray; + lBMP,lcompressedBMP: TBitmap; + l32BitP,l32OutBitP : DWordp; + lBGInvisibleColor: DWord; + lIsGap,lPrevIsGap: boolean; + lMaxWriteColumn,lInc,lPrevSliceStart,lPrevSliceEnd,lPrevWriteColumn,lWid,lHt,lReadRow,lReadColumn,lWriteColumn,lReadOffset,lWriteOffset,lScanLineBytes: integer; +begin + lBGInvisibleColor := gMRIcroOverlay[kBGOverlayNum].LUTinvisible; + lHt := MultiSliceForm.MultiImage.Picture.Bitmap.Height; + lWid := MultiSliceForm.MultiImage.Picture.Bitmap.Width; + if (lHt < 2) or (lWid < 2) then exit; + //next: prepare input + sbBits := MultiSliceForm.MultiImage.Picture.Bitmap.ScanLine[lHt-1]; + l32BitP := DWordp(sbBits); + DefineBackGround(l32BitP, lBGInvisibleColor, lHt,lWid); + + //next prepare output + lBMP := TBitmap.Create; + lBMP.PixelFormat := pf32bit; + lBMP.Width := lWid; + lBMP.Height := lHt; + sbOutBits := lBmp.ScanLine[lHt-1]; + l32OutBitP := DWordp(sbOutBits); + for lInc := 1 to (lwid*lHt) do + l32OutBitP[lInc] := lBGInvisibleColor; + //next: compress by deleting empty columns + lWriteColumn := 0; + lPrevIsGap := true; + lPrevSliceStart := maxint -10; + lPrevSliceEnd := 0; + lPrevWriteColumn := maxint-10;//do not degap 1st line +if (gMulti.OverSlicePct = 0) or (gMulti.OverSlicePct = 100) then begin + for lReadColumn := 1 to lWid do begin + lReadOffset := lReadColumn; + if (gMulti.OverSlicePct = 0) then begin + lIsGap := true; + lReadRow := 1; + while (lReadRow < lHt) and (lIsGap) do begin + if l32BitP[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + end else + lIsGap := false;//May2008 + if not lIsGap then begin//data in this column + if lReadColumn > (lPrevWriteColumn+1) then begin //leave one pixel gap between noncontiguous columns + inc(lWriteColumn); + lReadOffset := lReadColumn-1; + lWriteOffset := lWriteColumn; + //showmessage(inttostr(lWriteColumn)+' '+inttostr(lReadOffset)); + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //leave 1 pixel gap + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + lPrevWriteColumn := lReadColumn; + //showmessage(inttostr(lReadColumn)+' '+inttostr(lReadRow)+' '+inttostr(l32BitP[lReadOffset])); + end; //not Gap - write this column + end; //for each column +end else begin //show overslice + lMaxWriteColumn := -maxint; + for lReadColumn := 1 to lMaxOverlapWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + while (lReadRow < lHt) and (lIsGap) do begin + //see if this column is a gap... + if l32BitP[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each read row + if (lPrevIsGap <> lIsGap) then begin//change from prev column + if not (lIsGap) then begin + if lPrevSliceEnd > lPrevSliceStart then + lWriteColumn := lPrevSliceEnd-abs(((lPrevSliceEnd-lPrevSliceStart) * gMulti.OverSlicePct)div 100); + lPrevSliceStart := lWriteColumn; + end else + lPrevSliceEnd := lWriteColumn; + end; + lPrevIsGap := lIsGap; + if gMulti.OverSlicePct > 0 then begin + if not lIsGap then begin//data in this column + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + if l32BitP[lReadOffset] <> lBGInvisibleColor then + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //not Gap - write this column + end else begin //if overwrite, else underwrite + if not lIsGap then begin//data in this column + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + if l32OutBitP[lWriteOffset] = lBGInvisibleColor then + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //not Gap - write this column + end; + if lWriteColumn > lMaxWriteColumn then + lMaxWriteColumn := lWriteColumn; + end; //for each column + if lWriteColumn < lMaxWriteColumn then + lWriteColumn := lMaxWriteColumn; + {if lWriteColumn < lMaxWriteColumn then + showmessage('Some of your slices are much smaller than others. Your images will probably look better with the overslice set to zero.'); + } + if lMaxOverlapWid < lWid then begin + lReadColumn := lMaxOverlapWid; + if (lWriteColumn) < lReadColumn then //add gap if some compression + inc(lWriteColumn); + for lReadColumn := (lMaxOverlapWid+1) to lWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + while (lReadRow < lHt) and (lIsGap) do begin + if l32BitP[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + if not lIsGap then begin + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; //for each row + end; //not gap + end; //for each column + if (lWriteColumn+1) < lWid then + inc(lWriteColumn); + end; //if maxwid < wid - unoverlapped +end; + //next prepare compressed output + lcompressedBMP := TBitmap.Create; + lcompressedBMP.PixelFormat := pf32bit; + lcompressedBMP.Width := lWriteColumn; + lScanLineBytes := lWriteColumn * 4; + lcompressedBMP.Height := lHt; + for lReadRow := 1 to lHt do + Move(lBMP.ScanLine[lReadRow-1]^,lcompressedBMP.ScanLine[lReadRow-1]^,lScanLineBytes); + lBMP.Free; + MultiSliceForm.MultiImage.Width := lcompressedBMP.Width; + MultiSliceForm.MultiImage.Picture.Graphic := lcompressedBMP; + lcompressedBMP.Free; +end; //proc RemoveHorizGaps + +(*procedure RemoveHorizGaps; +var + sbBits,sbOutBits : PByteArray; + lBMP,lcompressedBMP: TBitmap; + l32BitP,l32OutBitP : DWordp; + lBGInvisibleColor: DWord; + lIsGap: boolean; + lPrevWriteColumn,lWid,lHt,lReadRow,lReadColumn,lWriteColumn,lReadOffset,lWriteOffset,lScanLineBytes: integer; +begin + lBGInvisibleColor := gMRIcroOverlay[kBGOverlayNum].LUTinvisible; + lHt := MultiSliceForm.MultiImage.Picture.Bitmap.Height; + lWid := MultiSliceForm.MultiImage.Picture.Bitmap.Width; + if (lHt < 2) or (lWid < 2) then exit; + //next: prepare input + sbBits := MultiSliceForm.MultiImage.Picture.Bitmap.ScanLine[lHt-1]; + l32BitP := DWordp(sbBits); + //next prepare output + lBMP := TBitmap.Create; + lBMP.PixelFormat := pf32bit; + lBMP.Width := lWid; + lBMP.Height := lHt; + sbOutBits := lBmp.ScanLine[lHt-1]; + l32OutBitP := DWordp(sbOutBits); + //FillChar(sbOutBits^,(lHt*lWid*4), 0); //default all to black + //next: compress by deleting empty columns + lWriteColumn := 0; + lPrevWriteColumn := maxint-10;//do not degap 1st line + for lReadColumn := 1 to lWid do begin + lReadOffset := lReadColumn; + lIsGap := true; + lReadRow := 1; + while (lReadRow < lHt) and (lIsGap) do begin + if l32BitP[lReadOffset] <> lBGInvisibleColor then + lIsGap := false; + inc(lReadOffset,lWid); + inc(lReadRow); + end; //while each readrow + if not lIsGap then begin//data in this column + if lReadColumn > (lPrevWriteColumn+1) then begin //leave one pixel gap between noncontiguous columns + inc(lWriteColumn); + lReadOffset := lReadColumn-1; + lWriteOffset := lWriteColumn; + //showmessage(inttostr(lWriteColumn)+' '+inttostr(lReadOffset)); + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + end; //leave 1 pixel gap + inc(lWriteColumn); + lReadOffset := lReadColumn; + lWriteOffset := lWriteColumn; + for lReadRow := 1 to lHt do begin + l32OutBitP[lWriteOffset] := l32BitP[lReadOffset]; + inc(lReadOffset,lWid); + inc(lWriteOffset,lWid); + end; + lPrevWriteColumn := lReadColumn; + //showmessage(inttostr(lReadColumn)+' '+inttostr(lReadRow)+' '+inttostr(l32BitP[lReadOffset])); + end; //not Gap - write this column + end; //for each column + //next prepare compressed output + lcompressedBMP := TBitmap.Create; + lcompressedBMP.PixelFormat := pf32bit; + lcompressedBMP.Width := lWriteColumn; + lScanLineBytes := lWriteColumn * 4; + lcompressedBMP.Height := lHt; + for lReadRow := 1 to lHt do + Move(lBMP.ScanLine[lReadRow-1]^,lcompressedBMP.ScanLine[lReadRow-1]^,lScanLineBytes); + lBMP.Free; + MultiSliceForm.MultiImage.Width := lcompressedBMP.Width; + MultiSliceForm.MultiImage.Picture.Graphic := lcompressedBMP; + lcompressedBMP.Free; +end; //proc RemoveHorizGaps*) + +procedure TMultiSliceForm.CreateMultiSag; +var + lSlice,lHt,lWid,lSlicePos,lSliceWid: integer; +begin + lHt:= gBGIMg.ScrnDim[3]; + lSliceWid :=gBGIMg.ScrnDim[2]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := (lSliceWid*gMulti.nSlices); + if gMulti.OrthoView then //coro crossview + lWid := lWid + gBGIMg.ScrnDim[1]; + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + DrawSag (gMulti.SliceList[lSlice],((lSlice-1)*lSliceWid));//+lSlice because we want 1-voxel gap between slices + if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],1),((lSlice-1)*lSliceWid)+(lSliceWid div 2),lWid); + end; + if gMulti.OrthoView then begin //coro crossview + DrawCor (gBGImg.ScrnDim[2] div 2,lSliceWid*gMulti.nSlices); + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + for lSlice := 1 to gMulti.nSlices do begin //draw lines + lSlicePos := (gMulti.nSlices*lSliceWid)+(gMulti.SliceList[lSlice]); + VLineWithFlatEndCaps (MultiImage.Canvas, gBGIMg.XBarClr,lSlicePos,0,lHt,gBGImg.XBarThick); + //MultiImage.Canvas.MoveTo(lSlicePos,0); + //MultiImage.Canvas.LineTo(lSlicePos,lHt); + end;//line for each slice + end;//if cross view + RemoveHorizGaps(lSliceWid*gMulti.nSlices); +end; //CreateMultiSag + +procedure TMultiSliceForm.CreateMultiCor; +var + lSlice,lHt,lWid,lLeft,lSliceWid: integer; +begin + lHt:= gBGIMg.ScrnDim[3]; + lSliceWid :=gBGIMg.ScrnDim[1]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := lSliceWid*gMulti.nSlices; + if gMulti.OrthoView then //sag crossview + lWid := lWid + gBGIMg.ScrnDim[2]; + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + DrawCor (gMulti.SliceList[lSlice],((lSlice-1)*lSliceWid)); + if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],2),((lSlice-1)*lSliceWid)+(gBGIMg.ScrnDim[1] div 2),lWid); + end; + if gMulti.OrthoView then begin + DrawSag (gBGImg.ScrnDim[1] div 2,gMulti.nSlices*lSliceWid); + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + for lSlice := 1 to gMulti.nSlices do begin + lLeft := gMulti.nSlices*lSliceWid+(gMulti.SliceList[lSlice]); + //MultiImage.Canvas.MoveTo(lLeft,0); + //MultiImage.Canvas.LineTo(lLeft,lHt); + VLineWithFlatEndCaps (MultiImage.Canvas, gBGIMg.XBarClr,lLeft,0,lHt,gBGImg.XBarThick); + + end; + end;//if orthoview + RemoveHorizGaps(lSliceWid*gMulti.nSlices); +end; //CreateMultiCor + + +procedure TMultiSliceForm.CreateMultiAx; +var + lSliceWid,lSlice,lHt,lWid,lLeft: integer; +begin + lHt:= gBGIMg.ScrnDim[2]; + lSliceWid :=gBGIMg.ScrnDim[1]+2;//+1 for 1-voxel gap between slices - ensures we can detect slice boundary + lWid := lSliceWid*gMulti.nSlices; + if gMulti.OrthoView then begin //sag crossview + lWid := lWid + gBGIMg.ScrnDim[2]; + if gBGIMg.ScrnDim[3]> lHt then + lHt := gBGIMg.ScrnDim[3]; + end; + CreateBlankBitmap (lHt,lWid, MultiImage); + for lSlice := 1 to gMulti.nSlices do begin + //ImgForm.ZViewEdit.value := gMulti.SliceList[lSlice]; + DrawAxial (gMulti.SliceList[lSlice],(lSlice-1)*lSliceWid); + if gMulti.SliceLabel then DrawLabel(MultiImage,DimToMM(gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],gMulti.SliceList[lSlice],3),((lSlice-1)*lSliceWid)+(gBGIMg.ScrnDim[1] div 2),lWid); + end; + if gMulti.OrthoView then begin + lLeft := gMulti.nSlices*lSliceWid; + DrawSag (gBGImg.ScrnDim[1] div 2,lLeft); + //MultiImage.Canvas.Pen.Color := gBGIMg.XBarClr; + //MultiImage.Canvas.Pen.Width := gBGImg.XBarThick; + //HLineWithFlatEndCaps (MultiImage.Canvas, gBGIMg.XBarClr,lLeft,lWid,1); + for lSlice := 1 to gMulti.nSlices do begin + lHt := gBGImg.ScrnDim[3]-(gMulti.SliceList[lSlice]); + //MultiImage.Canvas.MoveTo(lLeft,lHt); + //MultiImage.Canvas.LineTo(lWid,lHt); + HLineWithFlatEndCaps (MultiImage.Canvas, gBGIMg.XBarClr,lLeft,lWid,lHt,gBGImg.XBarThick); + end; + end; + RemoveHorizGaps(lSliceWid*gMulti.nSlices); +end; //CreateMultiAx + +procedure TMultiSliceForm.CreateMultiSlice; +begin + if gMulti.nSlices < 1 then begin + showmessage('No valid slices selected - please use View/Slices.'); + end; + case gMulti.Orient of + 3: CreateMultiCor; + 2: CreateMultiSag; + else CreateMultiAx; + end;//case +end;//CreateMultiSlice + +procedure TMultiSliceForm.OrientClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gMulti.Orient := (sender as TMenuItem).tag; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.FormShow(Sender: TObject); +begin + ReadMultiSliceIniFile (gMultiSliceStartupFilename ); + UpdateMultiSliceMRU; + UpdateMultiSliceDisplay; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.OrthoviewClick(Sender: TObject); +begin + OrthoView.checked := not OrthoView.Checked; + gMulti.OrthoView := OrthoView.checked; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.Slices1Click(Sender: TObject); +var + lStr: string; +begin + lStr := InputBox('Select multislices', 'Slice numbers [e.g. 10,16,24]',MultiSliceNum2String); + //now parse line + MultiSliceString2Num(lStr); + CreateMultiSlice; +end; + +procedure TMultiSliceForm.Closewindow1Click(Sender: TObject); +begin + Close; +end; + +procedure TMultiSliceForm.UpdateMultiSliceDisplay; +begin + + SetSubmenuWithTag(OversliceMenu, gMulti.OverslicePct); + SetSubmenuWithTag(OrientMenu, gMulti.Orient); + OrthoView.Checked := gMulti.OrthoView; + SliceLabelCheck.Checked := gMulti.SliceLabel; +end; + +procedure TMultiSliceForm.FormCreate(Sender: TObject); +var + lSlice:integer; +begin + gMultiSliceDir := extractfiledir(paramstr(0))+'\multislice\'; + gMultiSliceDefaultsFilename := gMultiSliceDir + 'default.ini'; + gMultiSliceStartupFilename := gMultiSliceDefaultsFilename; + gMulti.Orient := 1; + gMulti.OverslicePct := 0; + gMulti.nSlices:= 4; + gMulti.OrthoView := true; + gMulti.SliceLabel := true; + for lSlice := 1 to gMulti.nSlices do + gMulti.SliceList[lSlice] := 62+10*lSlice; +end; + +procedure TMultiSliceForm.FormClose(Sender: TObject; + var Action: TCloseAction); +begin +WriteMultiSliceIniFile (gMultiSliceDefaultsFilename ); +end; + +procedure TMultiSliceForm.Savesettings1Click(Sender: TObject); +begin + MultiSaveDialog.InitialDir := extractfiledir(gMultiSliceDir ); + if not MultiSaveDialog.Execute then exit; + WriteMultiSliceIniFile(MultiSaveDialog.Filename); + UpdateMultiSliceMRU; +end; + +procedure TMultiSliceForm.SliceLabelCheckClick(Sender: TObject); +begin + SliceLabelCheck.checked := not SliceLabelCheck.Checked; + gMulti.SliceLabel := SliceLabelCheck.checked; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.OverlsiceClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gMulti.OverslicePct := (sender as TMenuItem).tag; + CreateMultiSlice; +end; + +procedure TMultiSliceForm.Close1Click(Sender: TObject); +begin + close; +end; + +end. diff --git a/niftiview7/ROIfilt.pas b/niftiview7/ROIfilt.pas new file mode 100755 index 0000000..39d1890 --- /dev/null +++ b/niftiview7/ROIfilt.pas @@ -0,0 +1,165 @@ +unit ROIfilt; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Buttons,define_types, Mask,nifti_hdr, nifti_types; + +type + TFilterROIform = class(TForm) + Label42: TLabel; + FilterROIBtn: TSpeedButton; + Label43: TLabel; + Filter2NIfTIBtn: TSpeedButton; + FiltROILabel: TLabel; + MinROIfilt: TRxSpinEdit; + MaxROIfilt: TRxSpinEdit; + procedure MinROIfiltChange(Sender: TObject); + procedure FilterROIBtnClick(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure FormShow(Sender: TObject); + procedure Filter2NIfTIBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + FilterROIform: TFilterROIform; + +implementation +uses nifti_img_view,nifti_img; + +{$R *.DFM} + +procedure TFilterROIform.MinROIfiltChange(Sender: TObject); +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then exit; + FilterLUT (gBGImg, gMRIcroOverlay[kBGOverlayNum], round(MinROIFilt.Value),round(MaxROIfilt.value)); //lLUT: 0=gray,1=red,2=green,3=blue + FiltROILabel.caption := 'Calibrated range: '+realtostr(Scrn2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],MinROIfilt.value),3) + +'...'+realtostr(Scrn2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],MaxROIfilt.value),3); + ImgForm.RefreshImagesTimer.enabled := true; +end; + +procedure TFilterROIform.FilterROIBtnClick(Sender: TObject); +var lBGBuffer,lVOIBuffer:ByteP; + lInc,lMin,lMax,lBufferItems,lVOIvoxelsAfter,lVOIvoxelsBefore: integer; +begin + lBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lBufferItems < 1 then begin + showmessage('You need to open up a VOI (Draw/Open) in order to apply an intensity filter to the VOI.'); + exit; + end; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lBufferItems then begin + showmessage('Error: VOI dimensions do not match background image.'); + exit; + end; + CreateUndoVol; + (*case MessageDlg('Unable to undo this operation. You should save a backup copy prior to this (Draw/Save). Are you sure you wish to filter your VOI?', mtConfirmation, + [mbYes, mbCancel], 0) of + id_Cancel: exit; + end; //case *) + lMin := round(MinROIFilt.value); + lMax := round(MaxROIFilt.value); + if lMin > lMax then begin //swap + lInc := lMin; + lMin := lMax; + lMax := lInc; + end; //swap + if lBufferItems < 1 then + showmessage('Error: no background image open to filter.') + else begin + lBGBuffer := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer; + lVOIBuffer := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer; + lVOIvoxelsBefore := 0; + for lInc := 1 to lBufferItems do + if (lVOIBuffer[lInc] > 0) then + inc(lVOIvoxelsBefore); + for lInc := 1 to lBufferItems do + if (lBGBuffer[lInc] < lMin) or (lBGBuffer[lInc] > lMax) then + lVOIBuffer[lInc] := 0; + lVOIvoxelsAfter := 0; + for lInc := 1 to lBufferItems do + if (lVOIBuffer[lInc] > 0) then + inc(lVOIvoxelsAfter); + showmessage('VOI voxels prior to filter = '+inttostr(lVOIvoxelsBefore)+kCR + + 'VOI voxels after filter = '+inttostr(lVOIvoxelsAfter)); + gBGImg.VOIchanged := true; + //Save8BitAsVOIorNIFTI(lFilteredBuffer,lBufferItems); + end; //BGimage open + FilterROIForm.Close; +//nn +end; + +procedure TFilterROIform.FormClose(Sender: TObject; + var Action: TCloseAction); +begin + FilterLUT (gBGImg, gMRIcroOverlay[kBGOverlayNum], -1,-1); //lLUT: 0=gray,1=red,2=green,3=blue + ImgForm.RefreshImagesTimer.enabled := true; +end; + +procedure TFilterROIform.FormShow(Sender: TObject); +var lInc: integer; +begin + for lInc := 0 to 255 do + gBGImg.BackupLUT[lInc]:= gMRIcroOverlay[kBGOverlayNum].LUT[lInc]; + MinROIfiltChange(nil); +end; + +procedure MirrorBuffer(var lBuffer8:ByteP; lX,lXYZ: integer ); +var + lnRow,lRow,lHlfX,lLineOffset,lXPos,lTemp: integer; +begin + if (lXYZ < 2) or (lX > lXYZ) or ((lXYZ mod lX) <> 0) then + exit; + lnRow := lXYZ div lX; + lHlfX := lX div 2; + lLineOffset := 0; + for lRow := 1 to lnRow do begin + for lXPos := 1 to lHlfX do begin + lTemp := lBuffer8^[lXPos+lLineOffset]; + lBuffer8^[lXPos+lLineOffset] := lBuffer8^[1+lX-lXPos+lLineOffset]; + lBuffer8^[1+lX-lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + end;//for each row... + +end; //MirrorBuffer + +procedure TFilterROIform.Filter2NIfTIBtnClick(Sender: TObject); +var lFilteredBuffer:ByteP; + lInc,lMin,lMax,lBufferItems: integer; + lNiftiHdr : TNIFTIhdr; +begin + lBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + lMin := round(MinROIFilt.value); + lMax := round(MaxROIFilt.value); + if lMin > lMax then begin //swap + lInc := lMin; + lMin := lMax; + lMax := lInc; + end; //swap + if lBufferItems < 1 then + showmessage('Error: no background image open to filter.') + else begin + getmem(lFilteredBuffer,lBufferItems); + move(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^,lFilteredBuffer^,lBufferItems); + for lInc := 1 to lBufferItems do begin + if (lFilteredBuffer[lInc] < lMin) or (lFilteredBuffer[lInc] > lMax) then + lFilteredBuffer[lInc] := 0 + else + lFilteredBuffer[lInc] := 1; + end; + lNiftiHdr := gMRIcroOverlay[kBGOverlayNum].NiftiHdr; + if gBGImg.Mirror then + MirrorBuffer(lFilteredBuffer,gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.Dim[1], lBufferItems); //10/2010 + SaveAsVOIorNIFTI(lFilteredBuffer,lBufferItems,1,1,true,{gMRIcroOverlay[kBGOverlayNum].}lNiftiHdr,''); + freemem(lFilteredBuffer); + end; + FilterROIForm.Close; + +end; + +end. diff --git a/niftiview7/ReadInt.pas b/niftiview7/ReadInt.pas new file mode 100755 index 0000000..a28c96d --- /dev/null +++ b/niftiview7/ReadInt.pas @@ -0,0 +1,47 @@ +unit ReadInt; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls,define_types, RXSpin, Mask; + +type + TReadIntForm = class(TForm) + ReadIntLabel: TLabel; + OKBtn: TButton; + ReadIntEdit: TRxSpinEdit; + function GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + procedure OKBtnClick(Sender: TObject); + private + { Private declarations } + public + + { Public declarations } + end; + +var + ReadIntForm: TReadIntForm; + +implementation + +uses nifti_img,nifti_img_view,{license,} MultiSlice, render; + +{$R *.DFM} + function TReadIntForm.GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + begin + ReadIntLabel.caption := lStr+' ['+inttostr(lMin)+'..'+inttostr(lMax)+']'; + ReadIntEdit.MinValue := lMin; + ReadIntEdit.MaxValue := lMax; + ReadIntEdit.Value := lDefault; + ReadIntForm.ShowModal; + result := ReadIntEdit.asInteger; + end; + +procedure TReadIntForm.OKBtnClick(Sender: TObject); +begin + ReadIntForm.ModalResult := mrOK; +end; + + +end. diff --git a/niftiview7/Regmult.pas b/niftiview7/Regmult.pas new file mode 100755 index 0000000..cf8f080 --- /dev/null +++ b/niftiview7/Regmult.pas @@ -0,0 +1,233 @@ +{ ********************************************************************** + * Program REGMULT.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This program performs a weighted multiple linear least squares fit : + + y = b0 + b1 * x1 + b2 * x2 + ... + + The following parameters are passed on the command line : + + 1st parameter = name of input file (default extension = .DAT) + 2nd parameter = 1 if the equation includes a constant term b0 + + Input files are ASCII files with the following structure : + + Line 1 : Title of study + Line 2 : Number of variables (must be >= 2 here !) + Next lines : Names of variables x1, x2, ..., y + Next line : Number of observations (must be > number of variables !) + + The next lines contain the coordinates (x1, x2, ..., y) of the + observations (1 observation by line). The coordinates must be + separated by spaces or tabulations. + + The file INHIB.DAT is an example of data relating the inhibition of an + enzyme to the physico-chemical properties of the inhibitors (J. DEBORD, + P. N'DIAYE, J. C. BOLLINGER et al, J. Enzyme Inhib., 1997, 12, 13-26). + The program parameters are : INHIB 1 + + The program may be executed from Turbo Pascal's integrated environment, + in which case the parameters are entered through the "Parameters" option + of the menu, or from DOS (after compilation into an executable file), + in which case the parameters are entered on the command line (e.g. + REGMULT INHIB 1). + ********************************************************************** } + +unit RegMult; +interface +uses + SysUtils,FMath, Matrices, Regress, Models, PaString,messages,dialogs,classes,define_types; +const +kMaxRA = 127; +kCR = chr (13); +kMaxObs = 100; +kMaxFact = 64; + +function MultipleRegressionVec (lnObservations,lnFactors: integer; var X: PMatrix; var Y: PVector; var lOutT,lOutSlope: DoubleP0): boolean; + + +implementation +procedure ComputeRegress (N,lnFactors : Integer; + var Y, CstPar, Ycalc, S, B : PVector; + var V : PMatrix; + var Test : TRegTest; var lOutT: DoubleP0); +var + I: integer; + SB : PVector; { Standard deviations of parameters } + T : PVector; { Student's t } + Prob : PVector; { Probabilities } +begin + DimVector(SB, LastParam); + DimVector(T, LastParam); + DimVector(Prob, LastParam); + { Perform tests on parameters } + ParamTest(B, V, N, FirstParam, LastParam, SB, T, Prob); + for I := 0 to (lnFactors-1) do + lOutT[I] := T^[FirstParam+I+1];//first parameter is global fit + + lOutT[lnFactors] := T^[FirstParam];//global fit + + //for I := FirstParam to LastParam do + // Showmessage(floattostr(T^[I]) ); + DelVector(SB, LastParam); + DelVector(T, LastParam); + DelVector(Prob, LastParam); + +end; + +function MultipleRegression (lnObservations,lnFactors: integer; var X: PMatrix; var lImgIntensity: DoubleP0; var lOutT: DoubleP0): boolean; +var + K : Integer; { Nb of independent variables } + //X : PMatrix; { Matrix of independent variables } + Y : PVector; { Vector of dependent variable } + Z : PVector; { Vector of independent variable (not used here) } + Ycalc : PVector; { Expected Y values } + S : PVector; { Standard deviations of Y values } + CstPar : PVector; { Constant parameters } + B : PVector; { Regression parameters } + B_min, B_max : PVector; { Parameter bounds (not used, but must be + declared in order to use the WLSFit routine ) } + V : PMatrix; { Variance-covariance matrix of regression parameters } + Theta : PVector; { Variance parameters } + lRegTest : TRegTest; { Regression tests } + gErrCode : Integer; { Error code } +begin + result := false; + if lnObservations < 5 then begin + showmessage('At least 5 samples required for 3D registration.'); + exit; + end; + DimVector(CstPar, 1); + DimVector(Y, lnObservations); + CstPar^[1] := 1; + CstPar^[0] := lnFactors; + for K := 1 to lnObservations do + Y^[K] := lImgIntensity[K-1]; + { Initialize regression and variance models.} + InitModel(REG_MULT,VAR_CONST,{ Here we use a constant variance }CstPar); + { Set the regression algorithm which must be GAUSS_JORDAN or SVD. + The default algorithm is SVD. Comment off the following line if + you wish to change the algorithm. } + { SetRegAlgo(GAUSS_JORDAN); } + DimVector(Theta, LastVarParam); + DimVector(B, LastParam); + DimMatrix(V, LastParam, LastParam); + DimVector(Ycalc, lnObservations); + DimVector(S, lnObservations); + { Perform regression. The numbers 1 and 0.1 denote the maximal number + of iterations and the tolerance on the parameters. They are purely + formal values here since the multiple linear regression does not use + an iterative minimization algorithm. } + gErrCode := WLSFit(Z, X, Y, lnObservations, True, 1, 0.1, Theta, B,B_min, B_max, V, Ycalc, S, lRegTest); + { Write results } + case gErrCode of + MAT_OK : begin + //ScreenOutputFile({XName,}YName,lnObservations,lDim, Y, CstPar, Ycalc, S, B, V, lRegTest,lStr); + //Showmessage(lStr); + ComputeRegress(lnObservations,lnFactors, Y, CstPar, Ycalc, S, B, V, lRegTest,lOutT); + end; +{ MAT_OK : WriteOutputFile(InFName, Title, XName, YName, + N, Y, CstPar, Ycalc, S, B, V, RegTest); + } MAT_SINGUL : Showmessage('Singular matrix !'); + MAT_NON_CONV : Showmessage('Non-convergence of SVD algorithm !'); + end; + DelVector(CstPar, 1); + DelVector(Y, lnObservations); + + DelVector(Theta, LastVarParam); + DelVector(B, LastParam); + DelMatrix(V, LastParam, LastParam); + DelVector(Ycalc, lnObservations); + DelVector(S, lnObservations); + result := true; + +end; + +function MultipleRegressionVec (lnObservations,lnFactors: integer; var X: PMatrix; var Y: PVector; var lOutT,lOutSlope: DoubleP0): boolean; +var + //i,j: integer;lmin,lmax: float; + K : Integer; { Nb of independent variables } + Z : PVector; { Vector of independent variable (not used here) } + Ycalc : PVector; { Expected Y values } + S : PVector; { Standard deviations of Y values } + CstPar : PVector; { Constant parameters } + B : PVector; { Regression parameters } + B_min, B_max : PVector; { Parameter bounds (not used, but must be + declared in order to use the WLSFit routine ) } + V : PMatrix; { Variance-covariance matrix of regression parameters } + Theta : PVector; { Variance parameters } + lRegTest : TRegTest; { Regression tests } + gErrCode : Integer; { Error code } +begin + (*lmin := X^[1]^[1]; + lmax := X^[1]^[1]; + for I := 1 to lnFactors do begin + for J := 1 to lnObservations do begin + if X^[I]^[J] > lmax then + lMax := X^[I]^[J]; + if X^[I]^[J] < lmin then + lMin := X^[I]^[J]; + end; + end; + + fx(lmin,lmax);*) + + result := false; + if lnObservations < 5 then begin + showmessage('At least 5 samples required for 3D registration.'); + exit; + end; + DimVector(CstPar, 1); + CstPar^[1] := 1; + CstPar^[0] := lnFactors; + { Initialize regression and variance models.} + InitModel(REG_MULT,VAR_CONST,{ Here we use a constant variance }CstPar); + { Set the regression algorithm which must be GAUSS_JORDAN or SVD. + The default algorithm is SVD. Comment off the following line if + you wish to change the algorithm. } + { SetRegAlgo(GAUSS_JORDAN); } + DimVector(Theta, LastVarParam); + DimVector(B, LastParam); + DimMatrix(V, LastParam, LastParam); + DimVector(Ycalc, lnObservations); + DimVector(S, lnObservations); + { Perform regression. The numbers 1 and 0.1 denote the maximal number + of iterations and the tolerance on the parameters. They are purely + formal values here since the multiple linear regression does not use + an iterative minimization algorithm. } + gErrCode := WLSFit(Z, X, Y, lnObservations, True, 1, 0.1, Theta, B,B_min, B_max, V, Ycalc, S, lRegTest); + { Write results } + //showmessage(inttostr(xx)); + case gErrCode of + MAT_OK : begin + //ScreenOutputFile({XName,}YName,lnObservations,lDim, Y, CstPar, Ycalc, S, B, V, lRegTest,lStr); + //Showmessage(lStr); + ComputeRegress(lnObservations,lnFactors, Y, CstPar, Ycalc, S, B, V, lRegTest,lOutT); + end; +{ MAT_OK : WriteOutputFile(InFName, Title, XName, YName, + N, Y, CstPar, Ycalc, S, B, V, RegTest); + } MAT_SINGUL : Showmessage('Singular matrix !'); + MAT_NON_CONV : Showmessage('Non-convergence of SVD algorithm !'); + end; + for K := 0 to (lnFactors-1) do + lOutSlope^[K] := B^[FirstParam+K+1];//first parameter is global fit + + lOutSlope^[lnFactors] := B^[FirstParam];//global fit + + DelVector(CstPar, 1); + //DelVector(Y, lnObservations); + //DelStrVector(XName,lnXFactors); + + DelVector(Theta, LastVarParam); + DelVector(B, LastParam); + DelMatrix(V, LastParam, LastParam); + DelVector(Ycalc, lnObservations); + DelVector(S, lnObservations); + result := true; + +end; + + +end. diff --git a/niftiview7/RenderThds.pas b/niftiview7/RenderThds.pas new file mode 100755 index 0000000..dea3b85 --- /dev/null +++ b/niftiview7/RenderThds.pas @@ -0,0 +1,546 @@ +unit RenderThds; + +interface + {$DEFINE SHOWPROG} +uses +{$IFDEF UNIX} +lclintf,//critical sections +{$ELSE} + Windows, +{$ENDIF} + ComCtrls,Classes, Graphics, ExtCtrls, define_types,GraphicsMathLibrary + ,sysutils; +const + kSh = 10; //bits to shift - precision for integers to simulate floats +var + ThreadsRunning: Integer = 0; + + type + + TRotateVals = record + InSliceSz,ZDimStart,ZDimEnd,YDimStart,YDimEnd,OutPivot,OutDim,OutSliceSz: integer; + XPivotInU2,YDimIN,YPivotInU2,ZDimIN,ZPivotInU2,XDimIN: integer; + XPivotIn,YPivotIn,ZPivotIn: integer; + Xxra,Xyra,Xzra: longintp; + //RenderCutout: boolean; + end; + + + TRenderThread = class(TThread) + private + lBarX: TProgressBar; + lRV: TRotateVals; + lMx : TMatrix; + lThreadX: integer; + lRenderCutoutX: boolean; + lBuffInX,lBuffOutX: ByteP; + lPosX: integer; + procedure DoVisualSwap; + protected + procedure Execute; override; + procedure VisualProg(lPos: Integer); + procedure Rotate(lThread: integer; l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); virtual; abstract; + public + + constructor Create(lBar: TProgressBar; lThread: integer; l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); + end; + +{ NearestNeighbor } + + TNNRender = class(TRenderThread) + protected + procedure Rotate(lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); override; + end; + +{ Trilinear } + + TTriRender = class(TRenderThread) + protected + procedure Rotate(lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); override; + end; + +implementation + +uses Render; + +var + {$IFDEF UNIX} + CritSect : LongWord; + {$ELSE} + CritSect : TRTLCriticalSection; + {$ENDIF} + +procedure ThreadDone; +begin + EnterCriticalSection(CritSect); + Dec(ThreadsRunning); + LeaveCriticalSection(CritSect); + +end; + +procedure TRenderThread.DoVisualSwap; +begin + {$IFDEF SHOWPROG} + lBarX.Position := lPosX; + {$ENDIF} +end; + +procedure TRenderThread.VisualProg(lPos: Integer); +begin + lPosX := lPos; + {$IFDEF SHOWPROG} + {$IFDEF FPC} + Synchronize(@DoVisualSwap); + {$ELSE} + Synchronize(DoVisualSwap); + {$ENDIF} + {$ENDIF} + +end; + +constructor TRenderThread.Create(lBar: TProgressBar;lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +begin + lBarX := lBar; + lRV := l; + lMx := lM; + lRenderCutoutX := lRenderCutout; + lBuffInX := lBuffIn; + lBuffOutX := lBuffOut; + lThreadX := lThread; + FreeOnTerminate := True; + inherited Create(False); +end; + +// The Execute method is called when the thread starts + +procedure TRenderThread.Execute; +begin + Rotate(lThreadX,lRV,lMx,lRenderCutoutX, lBuffInX,lBuffOutX); +end; + +procedure FindXBounds (var lXMax,lXMin: integer; +lXDimIN,lYxiZxi,lXPivotInU2,lYDimIN,lYyiZyi,lYPivotInU2,lZDimIN,lYziZzi,lZPivotInU2,lOutDim:integer; + lXxra,lXyra,lXzra : LongIntP); +var + lXo,lYo,lZo,Xo_at_one,Xo_at_two,Xo_grad,Xo_offs,lShiftedOne : integer; + when_it_is_zero, when_it_is_max: double; + lReallySmall {, debugx0, debugx1, debugy0, debugy1, debugz0, debugz1}: double; + l2: integer; +begin + lXMax := lOutDim; + lXMin := 1; + l2 := 2; + lShiftedOne := 1 shl ksh; + lReallySmall := 1e-6; + Xo_at_one := lXxRA^[1] +lYxiZxi + (lXPivotInU2 shl kSh); + Xo_at_two := lXxRA^[l2] +lYxiZxi + (lXPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lXDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugx0 := when_it_is_zero; debugx1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + Xo_at_one := lXyRA^[1] +lYyiZyi + (lYPivotInU2 shl kSh); + Xo_at_two := lXyRA^[l2] +lYyiZyi + (lYPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lYDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugy0 := when_it_is_zero; debugy1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + Xo_at_one := lXzRA^[1] +lYziZzi + (lZPivotInU2 shl kSh); + Xo_at_two := lXzRA^[l2] +lYziZzi + (lZPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lZDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugz0 := when_it_is_zero; debugz1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + // even with all the care about rounding, it's possible that we've got the + // edges wrong in ultra-high-gradient cases + if lXMin < lXMax then begin + while true do begin + lXo := ((lXxRA^[lXMin] +lYxiZxi) shr kSh)+lXPivotInU2; + lYo := ((lXyRA^[lXMin] +lYyiZyi) shr kSh)+lYPivotInU2; + lZo := ((lXzRA^[lXMin] +lYziZzi) shr kSh)+lZPivotInU2; + if (lXMin < lXMax) and ((lXo<1) or (lXo>lXDimIn) or (lYo<1) or (lYo>lYDimIn) or (lZo<1) or (lZo>lZDimIn)) then begin + lXMin := 1+lXMin; + end else + break; + end; + while true do begin + lXo := ((lXxRA^[lXMax] +lYxiZxi) shr kSh)+lXPivotInU2; + lYo := ((lXyRA^[lXMax] +lYyiZyi) shr kSh)+lYPivotInU2; + lZo := ((lXzRA^[lXMax] +lYziZzi) shr kSh)+lZPivotInU2; + if (lXMax > lXMin) and ((lXo<1) or (lXo>lXDimIn) or (lYo<1) or (lYo>lYDimIn) or (lZo<1) or (lZo>lZDimIn)) then begin + lXMax := lXMax-1; + end else + break; + end; + end; +end;//proc findXBounds + +//Nearest Neighbor +procedure TNNRender.Rotate (lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +const kshx = ksh shr 1; +var + + lZxi,lZyi,lZzi,lYxiZxi,lYyiZyi,lYziZzi,lZ,lY,lX,lOutPos, + lMaxX,lMinX,lXo,lYo,lZo: integer; +begin + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := round(lZ*lM.matrix[1,3]* (1 shl kSh) ); + lZyi := round(lZ*lM.matrix[2,3]* (1 shl kSh) ); + lZzi := round(lZ*lM.matrix[3,3]* (1 shl kSh) ); + if (RenderForm.RenderRefreshTimer.enabled) or (Terminated) then begin + ThreadDone; + exit; + end; + {$IFDEF SHOWPROG} //flicker with lazarus + if (lThread = 1) and ((lZ mod 30)=0) then + VisualProg(lZ); + {$ENDIF} + //ImgForm.ProgressBar1.Position := lZ; + for lY := l.YDimStart to l.YDimEnd do begin + lYxiZxi := round(lY * lM.matrix[1,2]* (1 shl kSh) )+lZxi; + lYyiZyi := round(lY * lM.matrix[2,2]* (1 shl kSh) )+lZyi; + lYziZzi := round(lY * lM.matrix[3,2]* (1 shl kSh) )+lZzi; + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + //if gAbortRender > 0 then goto 345; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXo := ((l.XxRA^[lX] +lYxiZxi) shr kSh)+l.XPivotInU2; + lYo := ((l.XyRA^[lX] +lYyiZyi) shr kSh)+l.YPivotInU2; + lZo := ((l.XzRA^[lX] +lYziZzi) shr kSh)+l.ZPivotInU2; + {lXo := (lXo shr 1) + 1; + lYo := lYo shr 1; + lZo := lZo shr 1;} + lBuffOut[lX+lOutPos] := lBuffIn[(lXo)+((lYo-1)*l.XdimIn)+((lZo-1)*l.InSliceSz)] + end; + end; //for y + end; //for z + ThreadDone; +end; + +procedure TTriRender.Rotate (lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +//Trilinear - this uses integer math, and on CoreDuo CPUs is 30% faster than Floating Point +//For precision, integers are multiplied by kSh (~2^10 bits) to simulate floats +// However, we will use 32-bit integers and the image intensity is 8 bit values, +// with the final interpolation multiplying X*Y*Z*intensity +// Therefore, this final interpolation adjusts kSh to be 2^8, avoiding overflow +var + lMi: TMatrixi; + lXr,lYr,lZr,lYxi,lYyi,lYzi,lXxi,lXyi,lXzi,lZxi,lZyi,lZzi, + lYxiZxi,lYyiZyi,lYziZzi,lZ,lY,lX,lOutPos, + lXPiv,lYPiv,lZPiv,lXrM1i,lYrM1i,lZrM1i, + lShr,lShl,lShlTo8,lShl8, + lMinZ,lMaxZ,lMinY,lMaxY,lMaxX,lMinX,lXo,lYo,lZo: integer; +begin + lShl := 1 shl kSh; + lShl8 := 1 shl 8; //8bit precision + lShlTo8 := (kSh - 8); //shr the kSh precision by this to get 8-bit precision + lShr := 24;//24-bits * 8 bit intensity = 32 bits + lXPiv := l.XPivotIn * lShl; + lYPiv := l.YPivotIn * lShl; + lZPiv := l.ZPivotIn * lShl; + for lX := 1 to 3 do + for lY := 1 to 3 do + lMi.matrix[lX,lY] := round(lM.matrix[lX,lY] * lShl); + if (lRenderCutout ) then begin //only separated to unroll IF rendercutout + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := (lZ*lMi.matrix[1,3] ); + lZyi := (lZ*lMi.matrix[2,3] ); + lZzi := (lZ*lMi.matrix[3,3] ); + if (RenderForm.RenderRefreshTimer.enabled) or (Terminated) then begin + ThreadDone; + exit; + end; + {$IFDEF SHOWPROG} //flicker with lazarus + if (lThread = 1) and ((lZ mod 30)=0) then + VisualProg(lZ); + {$ENDIF} + for lY := l.YDimStart to l.YDimEnd do begin + lYxi := lY * lMi.matrix[1,2]; + lYyi := lY * lMi.matrix[2,2]; + lYzi := lY * lMi.matrix[3,2]; + lYxiZxi := (lY * lMi.matrix[1,2] )+lZxi; + lYyiZyi := (lY * lMi.matrix[2,2] )+lZyi; + lYziZzi := (lY * lMi.matrix[3,2] )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXr := ( (lX*lMi.matrix[1,1])+lYxi+lZxi)+lXPiv; + lYr := ((lX*lMi.matrix[2,1])+lYyi+lZyi)+lYPiv; + lZr := ( (lX*lMi.matrix[3,1])+lYzi+lZzi)+lZPiv; + lXo := (lXr shr kSh); + lYo := (lYr shr kSh); + lZo := (lZr shr kSh); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXr := (lXr- (lXo * lShl)) shr lShlTo8; + lYr := (lYr- (lYo * lShl)) shr lShlTo8; + lZr := (lZr- (lZo * lShl)) shr lShlTo8; + lXrM1i := lShl8-lXr; + lYrM1i := lShl8-lYr; + lZrM1i := lShl8-lZr; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + if {(lRenderCutout ) and} ((lBuffIn^[lXo+lMinY+lMinZ]=255) or (lBuffIn^[lXo+1+lMinY+lMinZ]=255) + or (lBuffIn^[lXo+lMaxY+lMinZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMinZ]=255) + or (lBuffIn^[lXo+lMinY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMinY+lMaxZ]=255) + or (lBuffIn^[lXo+lMaxY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMaxZ]=255)) + then lBuffOut^[lX+l.OutPivot+lOutPos] := 255 + else + lBuffOut^[lX+l.OutPivot+lOutPos] := ( + (lXrM1i*lYrM1i*lZrM1i *lBuffIn^[lXo+lMinY+lMinZ] ) + +(lXr*lYrM1i*lZrM1i *lBuffIn^[lXo+1+lMinY+lMinZ]) + +(lXrM1i*lYr*lZrM1i *lBuffIn^[lXo+lMaxY+lMinZ] ) + +(lXrM1i*lYrM1i*lZr *lBuffIn^[lXo+lMinY+lMaxZ] ) + +(lXr*lYr*lZrM1i *lBuffIn^[lXo+1+lMaxY+lMinZ] ) + +(lXr*lYrM1i*lZr *lBuffIn^[lXo+1+lMinY+lMaxZ] ) + +(lXrM1i*lYr*lZr *lBuffIn^[lXo+lMaxY+lMaxZ]) + +(lXr*lYr*lZr *lBuffIn^[lXo+1+lMaxY+lMaxZ] ) + ) shr lShr; + end; //values in range + end; //for x + end; //for y + end; //for z + ThreadDone; + exit; + end; //if RenderCutout + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := (lZ*lMi.matrix[1,3] ); + lZyi := (lZ*lMi.matrix[2,3] ); + lZzi := (lZ*lMi.matrix[3,3] ); + if (RenderForm.RenderRefreshTimer.enabled) or (Terminated) then begin + ThreadDone; + exit; + end; + {$IFDEF SHOWPROG} //flicker with lazarus + if (lThread = 1) and ((lZ mod 30)=0) then + VisualProg(lZ); + {$ENDIF} + for lY := l.YDimStart to l.YDimEnd do begin + lYxi := lY * lMi.matrix[1,2]; + lYyi := lY * lMi.matrix[2,2]; + lYzi := lY * lMi.matrix[3,2]; + lYxiZxi := (lY * lMi.matrix[1,2] )+lZxi; + lYyiZyi := (lY * lMi.matrix[2,2] )+lZyi; + lYziZzi := (lY * lMi.matrix[3,2] )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXr := ( (lX*lMi.matrix[1,1])+lYxi+lZxi)+lXPiv; + lYr := ((lX*lMi.matrix[2,1])+lYyi+lZyi)+lYPiv; + lZr := ( (lX*lMi.matrix[3,1])+lYzi+lZzi)+lZPiv; + lXo := (lXr shr kSh); + lYo := (lYr shr kSh); + lZo := (lZr shr kSh); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXr := (lXr- (lXo * lShl)) shr lShlTo8; + lYr := (lYr- (lYo * lShl)) shr lShlTo8; + lZr := (lZr- (lZo * lShl)) shr lShlTo8; + lXrM1i := lShl8-lXr; + lYrM1i := lShl8-lYr; + lZrM1i := lShl8-lZr; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + lBuffOut^[lX+l.OutPivot+lOutPos] :=( + (lXrM1i*lYrM1i*lZrM1i *lBuffIn^[lXo+lMinY+lMinZ] ) + +(lXr*lYrM1i*lZrM1i *lBuffIn^[lXo+1+lMinY+lMinZ]) + +(lXrM1i*lYr*lZrM1i *lBuffIn^[lXo+lMaxY+lMinZ] ) + +(lXrM1i*lYrM1i*lZr *lBuffIn^[lXo+lMinY+lMaxZ] ) + +(lXr*lYr*lZrM1i *lBuffIn^[lXo+1+lMaxY+lMinZ] ) + +(lXr*lYrM1i*lZr *lBuffIn^[lXo+1+lMinY+lMaxZ] ) + +(lXrM1i*lYr*lZr *lBuffIn^[lXo+lMaxY+lMaxZ]) + +(lXr*lYr*lZr *lBuffIn^[lXo+1+lMaxY+lMaxZ] ) + ) shr lShr; + end; //values in range + end; //for x + end; //for y + end; //for z + ThreadDone; +end; + +(* +// floating point version of the same algorithm... +procedure TTriRender.Rotate (lThread: integer;l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +var + lXreal,lYreal,lZreal,lZx,lZy,lZz,lYx,lYy,lYz,lXrM1,lYrM1,lZrM1: single; + lXxi,lXyi,lXzi,lZxi,lZyi,lZzi,lYxiZxi,lYyiZyi,lYziZzi,lZ,lY,lX,lOutPos, + lMinZ,lMaxZ,lMinY,lMaxY,lMaxX,lMinX,lXo,lYo,lZo: integer; +begin +if (lRenderCutout ) then begin + + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZx := lZ*lM.matrix[1,3]; + lZy := lZ*lM.matrix[2,3]; + lZz := lZ*lM.matrix[3,3]; + lZxi := round(lZ*lM.matrix[1,3]* (1 shl kSh) ); + lZyi := round(lZ*lM.matrix[2,3]* (1 shl kSh) ); + lZzi := round(lZ*lM.matrix[3,3]* (1 shl kSh) ); + if RenderForm.RenderRefreshTimer.enabled then exit;//abort + if Terminated then exit; //goto 345;//abort + if (lThread = 1) and ((lZ mod 10)=0) then + VisualProg(lZ); + for lY := l.YDimStart to l.YDimEnd do begin + lYx := lY * lM.matrix[1,2]; + lYy := lY * lM.matrix[2,2]; + lYz := lY * lM.matrix[3,2]; + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + lYxiZxi := round(lY * lM.matrix[1,2]* (1 shl kSh) )+lZxi; + lYyiZyi := round(lY * lM.matrix[2,2]* (1 shl kSh) )+lZyi; + lYziZzi := round(lY * lM.matrix[3,2]* (1 shl kSh) )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXreal := ( (lX*lM.matrix[1,1])+lYx+lZx)+l.XPivotIn; + lYreal := ( (lX*lM.matrix[2,1])+lYy+lZy)+l.YPivotIn; + lZreal := ( (lX*lM.matrix[3,1])+lYz+lZz)+l.ZPivotIn; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + if {(l.RenderCutout ) and} ((lBuffIn^[lXo+lMinY+lMinZ]=255) or (lBuffIn^[lXo+1+lMinY+lMinZ]=255) + or (lBuffIn^[lXo+lMaxY+lMinZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMinZ]=255) + or (lBuffIn^[lXo+lMinY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMinY+lMaxZ]=255) + or (lBuffIn^[lXo+lMaxY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMaxZ]=255)) + then lBuffOut^[lX+l.OutPivot+lOutPos] := 255 + else + lBuffOut^[lX+l.OutPivot+lOutPos] := round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn^[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for x + end; //for y + end; //for z + ThreadDone; +exit; +end; //rendercutout + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZx := lZ*lM.matrix[1,3]; + lZy := lZ*lM.matrix[2,3]; + lZz := lZ*lM.matrix[3,3]; + lZxi := round(lZ*lM.matrix[1,3]* (1 shl kSh) ); + lZyi := round(lZ*lM.matrix[2,3]* (1 shl kSh) ); + lZzi := round(lZ*lM.matrix[3,3]* (1 shl kSh) ); + if RenderForm.RenderRefreshTimer.enabled then exit;//abort + if Terminated then exit; //goto 345;//abort + if (lThread = 1) and ((lZ mod 10)=0) then + VisualProg(lZ); + for lY := l.YDimStart to l.YDimEnd do begin + lYx := lY * lM.matrix[1,2]; + lYy := lY * lM.matrix[2,2]; + lYz := lY * lM.matrix[3,2]; + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + lYxiZxi := round(lY * lM.matrix[1,2]* (1 shl kSh) )+lZxi; + lYyiZyi := round(lY * lM.matrix[2,2]* (1 shl kSh) )+lZyi; + lYziZzi := round(lY * lM.matrix[3,2]* (1 shl kSh) )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXreal := ( (lX*lM.matrix[1,1])+lYx+lZx)+l.XPivotIn; + lYreal := ((lX*lM.matrix[2,1])+lYy+lZy)+l.YPivotIn; + lZreal := ( (lX*lM.matrix[3,1])+lYz+lZz)+l.ZPivotIn; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + + lBuffOut^[lX+l.OutPivot+lOutPos] := + round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn^[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for x + end; //for y + end; //for z + // if Terminated then Exit; + ThreadDone; +end; *) + + +initialization + InitializeCriticalSection(CritSect); + + +finalization + DeleteCriticalSection(CritSect); +end. diff --git a/niftiview7/SSE.pas b/niftiview7/SSE.pas new file mode 100755 index 0000000..e21e70e --- /dev/null +++ b/niftiview7/SSE.pas @@ -0,0 +1,136 @@ +unit sse; +interface +uses define_types; + +var gSSEenabled: boolean; +procedure SSEScale(var lMod,lMin,lMax : single; lMaxByte: byte; var lSz: integer; var lDataIn: SingleP; var lDataOut: ByteP); + +implementation + +procedure SSEScale(var lMod,lMin,lMax : single; lMaxByte: byte; var lSz: integer; var lDataIn: SingleP; var lDataOut: ByteP); + var + t : integer; + tail : integer; + parameters: singleP; + paralign: singleP; + localIn: singleP; + localOut: byteP; + localS: integer; + fMaxByte: single; + begin + {Get a multiple-of-eight number of voxels} + tail := lSz and 7; + lSz := lSz and $fffffff8; + GetMem(parameters, 80); +{ if tail <> 0 then begin + for t := 0 to (tail) do begin //1402 + if lDataIn[1+t+lSz] > lMax then + lDataOut[1+t+lSz] := lMaxByte + else if lDataIn[1+t+lSz] < lMin then + lDataOut[1+t+lSz] := 0 + else + lDataOut[1+t+lSz] := round((lDataIn[1+t+lSz]-lMin)* lMod); + end; + end;} + if tail <> 0 then begin + for t := 1 to (tail) do begin //1402 + if lDataIn[t+lSz] > lMax then + lDataOut[t+lSz] := lMaxByte + else if lDataIn[t+lSz] < lMin then + lDataOut[t+lSz] := 0 + else + lDataOut[t+lSz] := round((lDataIn[t+lSz]-lMin)* lMod); + end; + end; + paralign := singleP($fffffff0 and (integer(parameters)+15)); + fMaxByte := lMaxByte; + for t := 1 to 4 do begin + paralign[t] := lMod;//scale factors + paralign[t+4] := lMin;//bias + paralign[t+8] := 0; //zeroes + paralign[t+12] := fMaxByte;//MaxByte + end; + + localS := lSz; + localIn := lDataIn; + localOut := lDataOut; + + {Real problem here is getting the pointers into the right places + It gives complete nonsense unless you copy the passed parameters + into local variables before running} + + asm + mov eax, (paralign); + mov ebx, (localIn); + mov ecx, (localS); + mov edx, (localOut); + + db $0f, $28, $78, $00 // movaps xmm7, [eax] - X7 is the scale factors + db $0f, $28, $70, $10 // movaps xmm6, [eax+16] - X6 is the bias + db $0f, $28, $68, $20 // movaps xmm5, [eax+32] - X5 is zeroes + db $0f, $28, $60, $30 // movaps xmm4, [eax+48] - X4 is MaxBytes + + @ProcessLoop: + db $0f, $18, $83, $80, $00, $00, $00 // prefetchnta [ebx+128] + db $0f, $18, $4a, $20 // prefetcht0 [edx+32] + db $0f, $28, $43, $00 // movaps xmm0, [ebx] + db $0f, $28, $4b, $10 // movaps xmm1, [ebx+16] + + db $0f, $5c, $c6 // subps xmm0, xmm6 -- bias + db $0f, $59, $c7 // mulps xmm0, xmm7 -- scale + db $0f, $5c, $ce // subps xmm1, xmm6 + db $0f, $59, $cf // mulps xmm1, xmm7 + + db $0f, $5d, $c4 // minps xmm0, xmm4 -- chop left + db $0f, $5f, $c5 // maxps xmm0, xmm5 -- chop right + db $0f, $5d, $cc // minps xmm1, xmm4 + db $0f, $5f, $cd // maxps xmm1, xmm5 + + db $0f, $2c, $c0 // cvttps2pi mm0,xmm0 + db $0f, $12, $c0 // movhlps xmm0,xmm0 + db $0f, $2c, $c8 // cvttps2pi mm1,xmm0 + db $0f, $2c, $d1 // cvttps2pi mm2,xmm1 + db $0f, $12, $c9 // movhlps xmm1,xmm1 + db $0f, $2c, $d9 // cvttps2pi mm3,xmm1 + + db $0f, $6b, $c1 // packssdw mm0, mm1 + db $0f, $6b, $d3 // packssdw mm2, mm3 + db $0f, $67, $c2 // packuswb mm0, mm2 + + db $0f, $7f, $42, $00 // movq [edx],mm0 + add ebx, 32 + add edx, 8 + sub ecx, 8 + jne @ProcessLoop + db $0f, $77 // emms + end; + + freemem(parameters); + end; + +initialization + try + gSSEenabled := false; + asm + mov eax, 1 + db $0F,$A2 /// cpuid + test edx,(1 shl 25) + jnz @SSEFound + mov gSSEenabled,0 + jmp @END_SSE + @SSEFound: + mov gSSEenabled,1 + @END_SSE: + end; + except + gSSEenabled := false; + end; +(* gSSEenabled := true; + try + asm + db $0F,$54,$C0 //andps xmm0,xmm0 + end; + except + gSSEenabled := false; + end;(**) +end. diff --git a/niftiview7/Tablet.pas b/niftiview7/Tablet.pas new file mode 100755 index 0000000..c75b314 --- /dev/null +++ b/niftiview7/Tablet.pas @@ -0,0 +1,86 @@ +unit Tablet; + +interface +uses + Windows, SysUtils,Forms,WinTab32; + +//procedure InitializeTablet; +//procedure FinalizeTablet; +procedure TabletState(var lPressurePct: integer; var lErase: boolean); +function TabletAvailable: boolean; + +implementation +var + FTablet: HCTX; + FMaxNPressure: integer; + +function TabletAvailable: boolean; +begin + result := false; + if FTablet = 0 then + exit; + if not IsWinTab32Available then + exit; + result := true; +end; + +procedure TabletState(var lPressurePct: integer; var lErase: boolean); +var + buf: array[0..31] of PACKET; + n,p,i: integer; +begin + lPressurePct := -1; + lErase := false; + if FTablet = 0 then + exit; + if not IsWinTab32Available then + exit; + n := WTPacketsGet(FTablet, 32, @buf); + if n = 0 then + exit; + +repeat + i := n-1; + p := (buf[i].pkNormalPressure ); + lErase := (2 = buf[i].pkCursor); + n := WTPacketsGet(FTablet, 32, @buf); +until n = 0; + lPressurePct := round(p /FMaxNPressure * 100); +end; + +procedure FinalizeTablet; +begin + if FTablet <> 0 then begin + WTClose(FTablet); + FTablet := 0; + end; +end; + +procedure InitializeTablet; +var + lc: LOGCONTEXT; + npAxis: AXIS; +begin + if not IsWinTab32Available then Exit; + // get default + WTInfo(WTI_DEFSYSCTX, 0, @lc); + // modify the digitizing region + StrCopy(lc.lcName, PChar('PaintWindow '+IntToHex(HInstance, 8))); + lc.lcOptions := lc.lcOptions or CXO_SYSTEM; + lc.lcMsgBase := WT_DEFBASE; + lc.lcPktData := PACKETDATA; + lc.lcPktMode := PACKETMODE; + lc.lcMoveMask := PACKETDATA; + lc.lcBtnUpMask := lc.lcBtnDnMask; + lc.lcOutExtX := lc.lcOutExtX * 10; + lc.lcOutExtY := lc.lcOutExtY * 10; + FTablet := WTOpen(Application.Handle, lc, TRUE); + WTInfo(WTI_DEVICES + lc.lcDevice, DVC_NPRESSURE, @npAxis); + FMaxNPressure := npAxis.axMax; +end; + +initialization + InitializeTablet; +finalization + FinalizeTablet; +end. diff --git a/niftiview7/Text.dfm b/niftiview7/Text.dfm new file mode 100755 index 0000000..538d91e Binary files /dev/null and b/niftiview7/Text.dfm differ diff --git a/niftiview7/Text.pas b/niftiview7/Text.pas new file mode 100755 index 0000000..4c01b50 --- /dev/null +++ b/niftiview7/Text.pas @@ -0,0 +1,72 @@ +unit Text; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Menus, StdCtrls,Define_Types; + +type + TTextForm = class(TForm) + MainMenu1: TMainMenu; + File1: TMenuItem; + Save1: TMenuItem; + Closewindow1: TMenuItem; + Copy1: TMenuItem; + Copy2: TMenuItem; + MemoT: TMemo; + ClearMenu: TMenuItem; + procedure Closewindow1Click(Sender: TObject); + procedure Copy2Click(Sender: TObject); + procedure Save1Click(Sender: TObject); + procedure ClearMenuClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + TextForm: TTextForm; + +implementation + +uses nifti_img_view; + +{$R *.DFM} + +procedure TTextForm.Closewindow1Click(Sender: TObject); +begin + TextForm.Close; +end; + +procedure TTextForm.Copy2Click(Sender: TObject); +begin + MemoT.SelectAll; + MemoT.CopyToClipboard; +end; + +procedure TTextForm.Save1Click(Sender: TObject); +var + lStr: string; +begin + lStr := ImgForm.SaveDialog1.filename; + ImgForm.SaveDialog1.filename := changefileextX(lstr,''); + if kTextSep = chr(9) then + ImgForm.SaveDialog1.Filter := 'Tab Separated (*.tab)|*.tab|Comma Separated (*.csv)|*.csv|Text (*.txt)|*.txt' + else + ImgForm.SaveDialog1.Filter := 'Comma Separated (*.csv)|*.csv|Tab Separated (*.tab)|*.tab|Text (*.txt)|*.txt'; + if kTextSep = chr(9) then + ImgForm.SaveDialog1.DefaultExt := '*.tab' + else + ImgForm.SaveDialog1.DefaultExt := '*.csv'; + if not ImgForm.SaveDialog1.Execute then exit; + MemoT.Lines.SaveToFile(ImgForm.SaveDialog1.Filename); +end; + +procedure TTextForm.ClearMenuClick(Sender: TObject); +begin + MemoT.lines.clear; +end; + +end. diff --git a/niftiview7/WinTab32.pas b/niftiview7/WinTab32.pas new file mode 100755 index 0000000..38cf968 --- /dev/null +++ b/niftiview7/WinTab32.pas @@ -0,0 +1,505 @@ +unit WinTab32; +{ + WinTab interface for delphi + + WinTab is standardized programming interface to digitizing tablets, + three dimensional position sensors, and other pointing devices + by a group of leading digitizer manufacturers and applications developers. + + converted from wintab.h, pktdef.h from www.pointing.com + + The manager part is omitted for not being widely used or supported. + Dynamic link is used so as not to prevent programs to run without a tablet installed. + Detailed documents can be downloaded from www.pointing.com. + + Note: Modify definations of PACKETDATA and PACKET to define your own data format. + + by LI Qingrui + emailto: the3i@sohu.com + + This file is supplied "AS IS", without warranty of any kind. + Feel free to use and modify for any purpose. + Enjoy yourself. +} + +interface + +uses Windows, Messages; + +const // Message constants + WT_DEFBASE = $7FF0; + WT_MAXOFFSET = $F; + WT_PACKET = WT_DEFBASE + 0; + WT_CTXOPEN = WT_DEFBASE + 1; + WT_CTXCLOSE = WT_DEFBASE + 2; + WT_CTXUPDATE = WT_DEFBASE + 3; + WT_CTXOVERLAP = WT_DEFBASE + 4; + WT_PROXIMITY = WT_DEFBASE + 5; + WT_INFOCHANGE = WT_DEFBASE + 6; + WT_CSRCHANGE = WT_DEFBASE + 7; + WT_MAX = WT_DEFBASE + WT_MAXOFFSET; + +// Common data types + +type + HCTX = THandle; // context handle + WTPKT = Longword; // packet mask + +const // Packet constants + // PACKET DEFINITION + // The following definition controls what data items are requested from the Tablet during the + // "WTOpen" command. Note that while some tablets will open with all data items requested + // (i.e. X, Y, Z, and Pressure information), some tablets will not open if they do not support + // a particular data item. For example, the GTCO Sketchmaster driver will fail on "WTOpen" if + // you request Z data or Pressure data. However, the SummaSketch driver will succeed on open + // even though Z and Pressure are not supported by this tablet. In this case, 0 is returned for + // the Z and Pressure data, as you might expect. + + PK_CONTEXT = $1; // reporting context + PK_STATUS = $2; // status bits + PK_TIME = $4; // time stamp + PK_CHANGED = $8; // change bit vector + PK_SERIAL_NUMBER = $10; // packet serial number + PK_CURSOR = $20; // reporting cursor + PK_BUTTONS = $40; // button information + PK_X = $80; // x axis + PK_Y = $100; // y axis + PK_Z = $200; // z axis + PK_NORMAL_PRESSURE = $400; // normal or tip pressure + PK_TANGENT_PRESSURE = $800; // tangential or barrel pressure + PK_ORIENTATION = $1000; // orientation info: tilts + PK_ROTATION = $2000; // rotation info; 1.1 + + // this constant is used to define PACKET record + PACKETDATA = PK_CURSOR or {PK_X or PK_Y or} PK_NORMAL_PRESSURE; + + // this constant is used to define PACKET record + PACKETMODE = 0; //This means all values are reported "absoulte" + +type + + // Modify this to suit your needs. + PACKET = record +// pkContext: HCTX; // PK_CONTEXT +// pkStatus: Cardinal; // PK_STATUS +// pkTime: Longword; // PK_TIME +// pkChanged: WTPKT; // PK_CHANGED +// pkSerialNumber: cardinal; // PK_SERIAL_NUMBER + pkCursor: cardinal; // PK_CURSOR +// pkButtons: Longword; // PK_BUTTONS +// pkX: LongInt; // PK_X +// pkY: LongInt; // PK_Y +// pkZ: LongInt; // PK_Z + pkNormalPressure: integer; // PK_NORMAL_PRESSURE +// pkTangentPressure: integer; // PK_TANGENT_PRESSURE +// pkOrientation: ORIENTATION; // PK_ORIENTATION +// pkRotation: ROTATION; // PK_ROTATION Ver 1.1 + end; + +type FIX32 = Longword; + + +// Info data defs + +const // unit specifiers + TU_NONE = 0; + TU_INCHES = 1; + TU_CENTIMETERS = 2; + TU_CIRCLE = 3; + +type + AXIS = record + axMin: LongInt; + axMax: LongInt; + axUnits: Cardinal; + axResolution: FIX32; + end; + PAXIS = ^AXIS; + +const // system button assignment values + SBN_NONE = $00; + SBN_LCLICK = $01; + SBN_LDBLCLICK = $02; + SBN_LDRAG = $03; + SBN_RCLICK = $04; + SBN_RDBLCLICK = $05; + SBN_RDRAG = $06; + SBN_MCLICK = $07; + SBN_MDBLCLICK = $08; + SBN_MDRAG = $09; + +const // hardware capabilities + HWC_INTEGRATED = $0001; + HWC_TOUCH = $0002; + HWC_HARDPROX = $0004; + HWC_PHYSID_CURSORS = $0008; // 1.1 + +const // cursor capabilities + CRC_MULTIMODE = $0001; // 1.1 + CRC_AGGREGATE = $0002; // 1.1 + CRC_INVERT = $0004; // 1.1 + +const // info categories + WTI_INTERFACE = 1; + IFC_WINTABID = 1; + IFC_SPECVERSION = 2; + IFC_IMPLVERSION = 3; + IFC_NDEVICES = 4; + IFC_NCURSORS = 5; + IFC_NCONTEXTS = 6; + IFC_CTXOPTIONS = 7; + IFC_CTXSAVESIZE = 8; + IFC_NEXTENSIONS = 9; + IFC_NMANAGERS = 10; + IFC_MAX = 10; + + WTI_STATUS = 2; + STA_CONTEXTS = 1; + STA_SYSCTXS = 2; + STA_PKTRATE = 3; + STA_PKTDATA = 4; + STA_MANAGERS = 5; + STA_SYSTEM = 6; + STA_BUTTONUSE = 7; + STA_SYSBTNUSE = 8; + STA_MAX = 8; + + WTI_DEFCONTEXT = 3; + WTI_DEFSYSCTX = 4; + WTI_DDCTXS = 400; // 1.1 + WTI_DSCTXS = 500; // 1.1 + CTX_NAME = 1; + CTX_OPTIONS = 2; + CTX_STATUS = 3; + CTX_LOCKS = 4; + CTX_MSGBASE = 5; + CTX_DEVICE = 6; + CTX_PKTRATE = 7; + CTX_PKTDATA = 8; + CTX_PKTMODE = 9; + CTX_MOVEMASK = 10; + CTX_BTNDNMASK = 11; + CTX_BTNUPMASK = 12; + CTX_INORGX = 13; + CTX_INORGY = 14; + CTX_INORGZ = 15; + CTX_INEXTX = 16; + CTX_INEXTY = 17; + CTX_INEXTZ = 18; + CTX_OUTORGX = 19; + CTX_OUTORGY = 20; + CTX_OUTORGZ = 21; + CTX_OUTEXTX = 22; + CTX_OUTEXTY = 23; + CTX_OUTEXTZ = 24; + CTX_SENSX = 25; + CTX_SENSY = 26; + CTX_SENSZ = 27; + CTX_SYSMODE = 28; + CTX_SYSORGX = 29; + CTX_SYSORGY = 30; + CTX_SYSEXTX = 31; + CTX_SYSEXTY = 32; + CTX_SYSSENSX = 33; + CTX_SYSSENSY = 34; + CTX_MAX = 34; + + WTI_DEVICES = 100; + DVC_NAME = 1; + DVC_HARDWARE = 2; + DVC_NCSRTYPES = 3; + DVC_FIRSTCSR = 4; + DVC_PKTRATE = 5; + DVC_PKTDATA = 6; + DVC_PKTMODE = 7; + DVC_CSRDATA = 8; + DVC_XMARGIN = 9; + DVC_YMARGIN = 10; + DVC_ZMARGIN = 11; + DVC_X = 12; + DVC_Y = 13; + DVC_Z = 14; + DVC_NPRESSURE = 15; + DVC_TPRESSURE = 16; + DVC_ORIENTATION = 17; + DVC_ROTATION = 18; // 1.1 + DVC_PNPID = 19; // 1.1 + DVC_MAX = 19; + + WTI_CURSORS = 200; + CSR_NAME = 1; + CSR_ACTIVE = 2; + CSR_PKTDATA = 3; + CSR_BUTTONS = 4; + CSR_BUTTONBITS = 5; + CSR_BTNNAMES = 6; + CSR_BUTTONMAP = 7; + CSR_SYSBTNMAP = 8; + CSR_NPBUTTON = 9; + CSR_NPBTNMARKS = 10; + CSR_NPRESPONSE = 11; + CSR_TPBUTTON = 12; + CSR_TPBTNMARKS = 13; + CSR_TPRESPONSE = 14; + CSR_PHYSID = 15; // 1.1 + CSR_MODE = 16; // 1.1 + CSR_MINPKTDATA = 17; // 1.1 + CSR_MINBUTTONS = 18; // 1.1 + CSR_CAPABILITIES = 19; // 1.1 + CSR_MAX = 19; + + WTI_EXTENSIONS = 300; + EXT_NAME = 1; + EXT_TAG = 2; + EXT_MASK = 3; + EXT_SIZE = 4; + EXT_AXES = 5; + EXT_DEFAULT = 6; + EXT_DEFCONTEXT = 7; + EXT_DEFSYSCTX = 8; + EXT_CURSORS = 9; + EXT_MAX = 109; // Allow 100 cursors + + +// Context data defs + +const + LCNAMELEN = 40; + LC_NAMELEN = 40; + + // context option values + CXO_SYSTEM = $0001; // the context is a system cursor context + CXO_PEN = $0002; // the context is a PenWin context, also a system cursor context + CXO_MESSAGES = $0004; // the context sends WT_PACKET messages to its owner + CXO_MARGIN = $8000; // the margin is an area outside the input area where events will be mapped to the edge of the input area + CXO_MGNINSIDE = $4000; // the margin will be inside the specified context + CXO_CSRMESSAGES = $0008; // 1.1 sends WT_CSRCHANGE messages + // context status values + CXS_DISABLED = $0001; + CXS_OBSCURED = $0002; + CXS_ONTOP = $0004; + // context lock values + CXL_INSIZE = $0001; // the context's input size cannot be changed + CXL_INASPECT = $0002; // the context's input aspect ratio cannot be changed + CXL_SENSITIVITY = $0004; // the context's sensitivity settings for x, y, and z cannot be changed + CXL_MARGIN = $0008; // the context's margin options cannot be changed + CXL_SYSOUT = $0010; // If the context is a system cursor context, the value specifies that the system pointing control variables of the context cannot be changed + +type + LOGCONTEXT = record + lcName: array[0..LCNAMELEN-1] of char; // context name string + lcOptions, // unsupported option will cause WTOpen to fail + lcStatus, + lcLocks, // specify attributes of the context that cannot be changed once the context has been opened + lcMsgBase, + lcDevice, // device whose input the context processes + lcPktRate: cardinal; // desired packet report rate in Hertz. returns the actual report rate. + lcPktData, // which optional data items will be in packets. unsupported items will cause WTOpen to fail. + lcPktMode, // whether the packet data items will be returned in absolute or relative mode + lcMoveMask: WTPKT; // which packet data items can generate move events in the context + lcBtnDnMask, // buttons for which button press events will be processed in the context + lcBtnUpMask: Longword; // buttons for which button release events will be processed in the context + lcInOrgX, + lcInOrgY, + lcInOrgZ, // origin of the context's input area in the tablet's native coordinates + lcInExtX, + lcInExtY, + lcInExtZ, // extent of the context's input area in the tablet's native coordinates + lcOutOrgX, + lcOutOrgY, + lcOutOrgZ, // origin of the context's output area in context output coordinates, absolute mode only + lcOutExtX, + lcOutExtY, + lcOutExtZ: LongInt; // extent of the context's output area in context output coordinates, absolute mode only + lcSensX, + lcSensY, + lcSensZ: FIX32; // specifies the relative-mode sensitivity factor + lcSysMode: LongBool; // system cursor tracking mode. Zero specifies absolute; non-zero means relative + lcSysOrgX, + lcSysOrgY, // the origin of the screen mapping area for system cursor tracking, in screen coordinates + lcSysExtX, + lcSysExtY: integer; // the extent of the screen mapping area for system cursor tracking, in screen coordinates + lcSysSensX, + lcSysSensY: FIX32; // specifies the system-cursor relative-mode sensitivity factor for the x and y axes + end; + PLOGCONTEXT = ^LOGCONTEXT; + + +// Event data defs +const // packet status values + TPS_PROXIMITY = $0001; + TPS_QUEUE_ERR = $0002; + TPS_MARGIN = $0004; + TPS_GRAB = $0008; + TPS_INVERT = $0010; // 1.1 + +type + ORIENTATION = record + orAzimuth: integer; + orAltitude: integer; + orTwist: integer; + end; + PORIENTATION = ^ORIENTATION; + + ROTATION = record // 1.1 + roPitch: integer; + roRoll: integer; + roYaw: integer; + end; + PROTATION = ^ROTATION; + +const // relative buttons + TBN_NONE = 0; + TBN_UP = 1; + TBN_DOWN = 2; + + +// device config constants + +const + WTDC_NONE = 0; + WTDC_CANCEL = 1; + WTDC_OK = 2; + WTDC_RESTART = 3; + + +// PREFERENCE FUNCTION CONSTANTS + +const + WTP_LPDEFAULT: Pointer = Pointer(-1); + WTP_DWDEFAULT: Longword = Longword(-1); + + +// functions +var + // Used to read various pieces of information about the tablet. + WTInfo: function (wCategory, nIndex: Cardinal; lpOutput: Pointer): Cardinal; stdcall; + + // Used to begin accessing the Tablet. + WTOpen: function (hw: HWnd; var lc: LOGCONTEXT; fEnable: LongBool): HCTX; stdcall; + + // Fills the supplied structure with the current context attributes for the passed handle. + WTGet: function (hc: HCTX; var lc: LOGCONTEXT): LongBool; stdcall; + + // Allows some of the context's attributes to be changed on the fly. + WTSet: function (hc: HCTX; const lc: LOGCONTEXT): LongBool; stdcall; + + // Used to end accessing the Tablet. + WTClose: function (hc: HCTX): LongBool; stdcall; + + // Used to poll the Tablet for input. + WTPacketsGet: function (hc: HCTX; cMaxPackets: Integer; lpPkts: Pointer): Integer; stdcall; + + // Similar to WTPacketsGet but is used in a window function. + WTPacket: function (hc: HCTX; wSerial: Cardinal; lpPkts: Pointer): LongBool; stdcall; + + // Visibility Functions + + // Enables and Disables a Tablet Context, temporarily turning on or off the processing of packets. + WTEnable: function (hc: HCTX; fEnable: LongBool): LongBool; stdcall; + + // Sends a tablet context to the top or bottom of the order of overlapping tablet contexts. + WTOverlap: function (hc: HCTX; fToTop: LongBool): LongBool; stdcall; + + // Context Editing Functions + + // Used to call a requestor which aids in configuring the Tablet + WTConfig: function (hc: HCTX; hw: HWnd): LongBool; stdcall; + + WTExtGet: function (hc: HCTX; wExt: cardinal; lpData: Pointer): LongBool; stdcall; + + WTExtSet: function (hc: HCTX; wExt: cardinal; lpData: Pointer): LongBool; stdcall; + + // Fills the supplied buffer with binary save information that can be used to restore the equivalent context in a subsequent Windows session. + WTSave: function (hc: HCTX; lpSaveInfo: Pointer): LongBool; stdcall; + + // Creates a tablet context from the save information returned from the WTSave function. + WTRestore: function (hw: HWnd; lpSaveInfo: Pointer; fEnable: LongBool): HCTX; stdcall; + + // Advanced Packet and Queue Functions + + WTPacketsPeek: function (hc: HCTX; cMaxPackets: Integer; lpPkts: Pointer): Integer; stdcall; + WTDataGet: function (hc: HCTX; wBegin, wEnding: cardinal; cMaxPackets: Integer; lpPkts: Pointer; var lpNPkts: Integer): Integer; stdcall; + WTDataPeek: function (hc: HCTX; wBegin, wEnding: cardinal; cMaxPackets: Integer; lpPkts: Pointer; var lpNPkts: Integer): Integer; stdcall; + // Returns the serial numbers of the oldest and newest packets currently in the queue. + WTQueuePacketsEx: function (hc: HCTX; var lpOld, lpNew: cardinal): LongBool; stdcall; + WTQueueSizeGet: function (hc: HCTX): Integer; stdcall; + WTQueueSizeSet: function (hc: HCTX; nPkts: Integer): LongBool; stdcall; + +function IsWinTab32Available: boolean; + +implementation + +var lib: THandle; + +function IsWinTab32Available: boolean; +begin + result := lib <> 0; +end; + +function LoadWinTab32: boolean; +begin + result := true; + if lib <> 0 then Exit; + lib := LoadLibrary('wintab32.dll'); + if lib = 0 then + begin + result := false; + Exit; + end; + WTInfo := GetProcAddress(lib, 'WTInfoA'); + WTOpen := GetProcAddress(lib, 'WTOpenA'); + WTClose := GetProcAddress(lib, 'WTClose'); + WTPacketsGet := GetProcAddress(lib, 'WTPacketsGet'); + WTPacket := GetProcAddress(lib, 'WTPacket'); + WTEnable := GetProcAddress(lib, 'WTEnable'); + WTOverlap := GetProcAddress(lib, 'WTOverlap'); + WTConfig := GetProcAddress(lib, 'WTConfig'); + WTGet := GetProcAddress(lib, 'WTGetA'); + WTSet := GetProcAddress(lib, 'WTSetA'); + WTExtGet := GetProcAddress(lib, 'WTExtGet'); + WTExtSet := GetProcAddress(lib, 'WTExtSet'); + WTSave := GetProcAddress(lib, 'WTSave'); + WTRestore := GetProcAddress(lib, 'WTRestore'); + WTPacketsPeek := GetProcAddress(lib, 'WTPacketsPeek'); + WTDataGet := GetProcAddress(lib, 'WTDataGet'); + WTDataPeek := GetProcAddress(lib, 'WTDataPeek'); + WTQueuePacketsEx := GetProcAddress(lib, 'WTQueuePacketsEx'); + WTQueueSizeGet := GetProcAddress(lib, 'WTQueueSizeGet'); + WTQueueSizeSet := GetProcAddress(lib, 'WTQueueSizeSet'); +end; + +procedure UnloadWinTab32; +begin + if lib <> 0 then + begin + FreeLibrary(lib); + lib := 0; + WTInfo := nil; + WTOpen := nil; + WTClose := nil; + WTPacketsGet := nil; + WTPacket := nil; + WTEnable := nil; + WTOverlap := nil; + WTConfig := nil; + WTGet := nil; + WTSet := nil; + WTExtGet := nil; + WTExtSet := nil; + WTSave := nil; + WTRestore := nil; + WTPacketsPeek := nil; + WTDataGet := nil; + WTDataPeek := nil; + WTQueuePacketsEx := nil; + WTQueueSizeGet := nil; + WTQueueSizeSet := nil; + end; +end; + +initialization + LoadWinTab32; +finalization + UnloadWinTab32; +end. diff --git a/niftiview7/_build.bat b/niftiview7/_build.bat new file mode 100755 index 0000000..1916c54 --- /dev/null +++ b/niftiview7/_build.bat @@ -0,0 +1,16 @@ +"C:\strip" "C:\pas\Delphi\niftiview7\MRIcroN.exe" +copy "C:\pas\Delphi\niftiview7\MRIcroN.exe" C:\mricron\mricron.exe +"C:\Program Files\NSIS2\makensis" "C:\Program Files\NSIS2\mricron.nsi" +del /S *.dcu +del /S *.~pa +del /S *.~df +del /S *.cfg +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt +del /S *.dsm +del /S *.bak + + diff --git a/niftiview7/_buildold.bat b/niftiview7/_buildold.bat new file mode 100755 index 0000000..d640f60 --- /dev/null +++ b/niftiview7/_buildold.bat @@ -0,0 +1,3 @@ +"C:\Program Files\upx125w\upx" --compress-icons=2 "C:\Documents and Settings\Chris Rorden\My Documents\niftiview\MRIcroN.exe" +copy "C:\Documents and Settings\Chris Rorden\My Documents\niftiview\mricron.exe" C:\mricron\mricron.exe +"C:\Program Files\NSIS2\makensis" "C:\Program Files\NSIS2\mricron.nsi" diff --git a/niftiview7/_clean.bat b/niftiview7/_clean.bat new file mode 100755 index 0000000..8e7c3e6 --- /dev/null +++ b/niftiview7/_clean.bat @@ -0,0 +1,9 @@ +del /S *.dcu +del /S *.~* +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt +del /S *.dsm +C:\strip /B "C:\pas\Delphi\niftiview7\MRIcroN.exe" diff --git a/niftiview7/_cleanold.bat b/niftiview7/_cleanold.bat new file mode 100755 index 0000000..c209cd5 --- /dev/null +++ b/niftiview7/_cleanold.bat @@ -0,0 +1,12 @@ +del /S *.dcu +del /S *.~pa +del /S *.~df +del /S *.cfg +del /S *.dof +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt +del /S *.dsm +"C:\Program Files\upx125w\upx" --compress-icons=2 "C:\Documents and Settings\Chris Rorden\My Documents\niftiview\MRIcroN.exe" diff --git a/niftiview7/_mricron.bat.lnk b/niftiview7/_mricron.bat.lnk new file mode 100755 index 0000000..d9176d5 Binary files /dev/null and b/niftiview7/_mricron.bat.lnk differ diff --git a/niftiview7/_tutorialclip.bat b/niftiview7/_tutorialclip.bat new file mode 100755 index 0000000..110e83c --- /dev/null +++ b/niftiview7/_tutorialclip.bat @@ -0,0 +1 @@ +start mricron .\templates\ch2bet.nii.gz -s 3 -c pink -l 40 -h 120 -r .\tutorial\clipnearr.ini \ No newline at end of file diff --git a/niftiview7/_tutorialcut.bat b/niftiview7/_tutorialcut.bat new file mode 100755 index 0000000..b2d5267 --- /dev/null +++ b/niftiview7/_tutorialcut.bat @@ -0,0 +1 @@ +start mricron .\templates\ch2bet.nii.gz -s 3 -c pink -l 40 -h 120 -r .\tutorial\cutr.ini \ No newline at end of file diff --git a/niftiview7/_tutorialfmri.bat b/niftiview7/_tutorialfmri.bat new file mode 100755 index 0000000..3c49e79 --- /dev/null +++ b/niftiview7/_tutorialfmri.bat @@ -0,0 +1 @@ +start /MAX mricron .\templates\ch2bet.nii.gz -s 3 -c -0 -l 20 -h 140 -b 40 -t -1 -r .\tutorial\fmrir.ini -o .\tutorial\saccades.nii.gz -l 1.96 -h 5 -z -o .\tutorial\attention.nii.gz -l 1.96 -h 5 -z -x \ No newline at end of file diff --git a/niftiview7/_tutorialfmri2.bat b/niftiview7/_tutorialfmri2.bat new file mode 100755 index 0000000..a23a5d1 --- /dev/null +++ b/niftiview7/_tutorialfmri2.bat @@ -0,0 +1 @@ +start mricron .\templates\ch2.nii.gz -s 3 -l 0 -h 140 -c pink -o .\templates\ch2bet.nii.gz -c -0 -l 30 -h 200 -o .\tutorial\attention.nii.gz -l 1.96 -h 5 -z -b 40 -t 50 -r .\tutorial\fmri2r.ini \ No newline at end of file diff --git a/niftiview7/_tutorialfmri3.bat b/niftiview7/_tutorialfmri3.bat new file mode 100755 index 0000000..c4447f9 --- /dev/null +++ b/niftiview7/_tutorialfmri3.bat @@ -0,0 +1 @@ +start mricron .\templates\aal.nii.gz -o .\tutorial\attention.nii.gz -c -0 -l 1.96 -h 5 -z -b 40 -t 50 -r .\tutorial\fmri3r.ini \ No newline at end of file diff --git a/niftiview7/_tutoriallesion.bat b/niftiview7/_tutoriallesion.bat new file mode 100755 index 0000000..4b903ca --- /dev/null +++ b/niftiview7/_tutoriallesion.bat @@ -0,0 +1 @@ +start mricron .\tutorial\lesion.nii.gz -s 3 -c gold -l 60 -h 240 -v .\tutorial\lesion.voi -r .\tutorial\lesionr.ini -m .\tutorial\lesionm.ini \ No newline at end of file diff --git a/niftiview7/about.pas b/niftiview7/about.pas new file mode 100755 index 0000000..d838ec5 --- /dev/null +++ b/niftiview7/about.pas @@ -0,0 +1,41 @@ +unit about; +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls,ShellAPI; + +type + TAboutForm = class(TForm) + Label1: TLabel; + ThreadLabel: TLabel; + Label3: TLabel; + Panel1: TPanel; + Label2: TLabel; + procedure FormCreate(Sender: TObject); + procedure Label1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + AboutForm: TAboutForm; + +implementation +var + gX: integer = 0; +{$R *.DFM} + +procedure TAboutForm.FormCreate(Sender: TObject); +begin +//Image1.Picture.Icon:=Application.Icon; +end; + +procedure TAboutForm.Label1Click(Sender: TObject); +begin + ShellExecute (0, Nil, 'http://www.mricro.com', Nil, Nil, SW_ShowDefault); +end; + +end. diff --git a/niftiview7/admin.pas b/niftiview7/admin.pas new file mode 100755 index 0000000..cf267a9 --- /dev/null +++ b/niftiview7/admin.pas @@ -0,0 +1,80 @@ +unit admin; +//For Win95,98,ME all users are administrators. However, with WinNT/XP this is not the case +//non-Administrators do not have access to c;|program files, therefore we will save ini files in their home folder +interface + +function IsAdmin: Boolean; +function AppDataFolder: string; +implementation + +uses + SysUtils, Windows,shlobj; + + +function AppDataFolder: string; //uses shlobj +var +Path : pchar; +idList : PItemIDList; +begin +GetMem(Path, MAX_PATH); +SHGetSpecialFolderLocation(0, CSIDL_APPDATA {CSIDL_PERSONAL}, idList); +SHGetPathFromIDList(idList, Path); +Result := string(Path); +FreeMem(Path); +end; + +function IsAdmin: Boolean; +const + SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = + (Value: (0, 0, 0, 0, 0, 5)); + SECURITY_BUILTIN_DOMAIN_RID = $00000020; + DOMAIN_ALIAS_RID_ADMINS = $00000220; +var + hAccessToken: THandle; + ptgGroups: PTokenGroups; + dwInfoBufferSize: DWORD; + psidAdministrators: PSID; + x: Integer; + bSuccess: BOOL; +begin + if Win32Platform <> VER_PLATFORM_WIN32_NT then + begin + Result := True; + exit; + end; + + Result := False; + bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, + hAccessToken); + if not bSuccess then + begin + if GetLastError = ERROR_NO_TOKEN then + bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, + hAccessToken); + end; + if bSuccess then + begin + GetMem(ptgGroups, 1024); + bSuccess := GetTokenInformation(hAccessToken, TokenGroups, + ptgGroups, 1024, dwInfoBufferSize); + CloseHandle(hAccessToken); + if bSuccess then + begin + AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, + SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, + 0, 0, 0, 0, 0, 0, psidAdministrators); + {$R-} + for x := 0 to ptgGroups.GroupCount - 1 do + if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then + begin + Result := True; + break; + end; + {$R+} + FreeSid(psidAdministrators); + end; + FreeMem(ptgGroups); + end; +end; + +end. \ No newline at end of file diff --git a/niftiview7/autoroi.pas b/niftiview7/autoroi.pas new file mode 100755 index 0000000..47d943a --- /dev/null +++ b/niftiview7/autoroi.pas @@ -0,0 +1,577 @@ +unit autoroi; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Buttons, StdCtrls, RXSpin,define_types, ExtCtrls,nifti_img,nifti_img_view, + Mask; + +type + TAutoROIForm = class(TForm) + OriginLabel: TLabel; + OriginBtn: TSpeedButton; + VarianceEdit: TRxSpinEdit; + DiffLabel: TLabel; + EdgeEdit: TRxSpinEdit; + Label1: TLabel; + Label2: TLabel; + ErodeEdit: TRxSpinEdit; + Label3: TLabel; + AutoROIBtn: TSpeedButton; + CancelBtn: TSpeedButton; + Timer1: TTimer; + Label4: TLabel; + RadiusEdit: TRxSpinEdit; + ExcludeBlackCheck: TCheckBox; + ROIconstraint: TComboBox; + procedure OriginBtnClick(Sender: TObject); + procedure PreviewBtnClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure AutoROIBtnClick(Sender: TObject); + procedure CancelBtnClick(Sender: TObject); + procedure AutoROIchange(Sender: TObject); + procedure Timer1Timer(Sender: TObject); + procedure FormDestroy(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +procedure ROICluster ({lInROIBuf: bytep;} lXdim, lYDim, lZDim,lXOriginIn,lYOrigin,lZOrigin: integer; lDeleteNotFill: boolean); +var + AutoROIForm: TAutoROIForm; + //gImageBackupSz, + gOriginX,gOriginY,gOriginZ: integer; + //gImageBackupBuffer: bytep; +implementation + +//uses MRImain; + +{$R *.DFM} + +procedure TAutoROIForm.OriginBtnClick(Sender: TObject); +begin + gOriginX := ImgForm.XViewEdit.asInteger; + gOriginY := ImgForm.YViewEdit.asInteger; + gOriginZ := ImgForm.ZViewEdit.asInteger; + OriginLabel.Caption := 'Origin: '+inttostr(gOriginX)+'x'+inttostr(gOriginY)+'x'+inttostr(gOriginZ); + PreviewBtnClick(sender); +end; + +procedure TAutoROIForm.PreviewBtnClick(Sender: TObject); +var + lXmm,lYmm,lZmm,lSqrRadius: single; + lExcludeBlackIfZero,//lX,lY,lZ, //abba + {lMaxROISz,}lEdge,lOriginPos,lROISz,lOriginIntensity,lVariance,lXdim, lYDim, lZDim: integer; + lErodeCycles,lQTail,lQHead,lSliceSz,lQSz,lInc,lVolSz{,lX,lY,lZ}: integer; + lROIConstrain,lReadFilteredData: boolean; + lQra: LongIntP; + lSourceBuffer,lBuff,lPreErodeBuff: ByteP; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; +function UnsmoothedIntensity(lPixel: integer): integer; //1381 +begin + if lReadFilteredData then + result := lBuff[lPixel] + else + Result :=lSourceBuffer[lPixel]; +end; + + function MeanIntensity(lPixel: integer): integer; + var lV: integer; + begin + if lReadFilteredData then + result := lBuff[lPixel] + else if ((lPixel-lSliceSz) > 0) and ((lPixel+lSliceSz) <= lVolSz) then begin + lV :=lSourceBuffer[lPixel]+lSourceBuffer[lPixel+1]+lSourceBuffer[lPixel-1] //L/R + +lSourceBuffer[lPixel+lXdim]+lSourceBuffer[lPixel-lXdim] //Anterior/Posterior + +lSourceBuffer[lPixel+lSliceSz]+lSourceBuffer[lPixel-lSliceSz]; //Dorsal/Ventral + result := lV div 7; + end else result := lSourceBuffer[lPixel];//1401 gImageBackupBuffer[lPixel] + end; + procedure Check(lPixel,lIntensity: integer); + var lSmoothInten :integer; + begin + //xxxxxxxxxxxxxx lSmoothInten := MeanIntensity(lPixel); + lSmoothInten := UnsmoothedIntensity(lPixel); + if (lROIConstrain) and (gBGImg.VOIUndoVol[lPixel] > 0) then //1410 + //constrain + else if (lBuff[lPixel]<> 255) and (UnsmoothedIntensity(lPixel) > lExcludeBlackIfZero {1381}) and (abs(lSmoothInten-lIntensity)<=lEdge) and(abs(lSmoothInten-lOriginIntensity)<=lVariance) {}then begin//add item + incQra(lQHead,lQSz); + inc(lROISz); + lBuff[lPixel] := 255; + lQra[lQHead] := lPixel; + end; + end; + +PROCEDURE RetirePixel; //FIFO cleanup +function WithinRadius(lXs,lYs,lZs:integer): boolean; +begin + if (sqr((lXs-gOriginX)*lXmm)+sqr((lYs-gOriginY)*lYmm)+sqr((lZs-gOriginZ)*lZmm)) > lSqrRadius then + result := false + else + result := true; +end; +VAR + lVal,lXPos,lYPos,lZPos,lIntensity: integer; +BEGIN + lVal := lQra[lQTail]; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + if lReadFilteredData then + lIntensity := 128 + else + lIntensity := lSourceBuffer[lVal];//1401 gImageBackupBuffer[lVal]; + if (lXpos > 1) and WithinRadius(lXpos-1,lYpos,lZpos) then Check(lVal -1,lIntensity);//check to left + if (lXPos < lXDim) and (WithinRadius(lXpos+1,lYpos,lZpos)) then Check(lVal + 1,lIntensity); //check to right + if (lYpos > 1) and (WithinRadius(lXpos,lYpos-1,lZpos)) then Check(lVal -lXdim,lIntensity);//check previous line + if (lYPos < lYDim) and (WithinRadius(lXpos,lYpos+1,lZpos)) then Check(lVal + lXdim,lIntensity); //check next line + if (lZpos > 1) and (WithinRadius(lXpos,lYpos,lZpos-1)) then Check(lVal -lSliceSz,lIntensity);//check previous slice + if (lZPos < lZDim) and (WithinRadius(lXpos,lYpos,lZpos+1)) then Check(lVal + lSliceSz,lIntensity); //check next slice + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + for lI := 1 to lQsz do + lQra[lI] := 0; + lQHead := 0; + lQTail := 1; + lROISz := 0; + Check(lPt,lOriginIntensity); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +function ROIOnEdge (lVal: integer): boolean; +BEGIN + result := false; + if lBuff[lVal] <> 255 then exit; //not ROI - is not boundary + //Find + if ((lVal-lSliceSz) > 0) and ((lVal+lSliceSz) <= lVolSz) then begin + if lBuff[lVal+1] = 0 then result := true; + if lBuff[lVal-1] = 0 then result := true; + if lBuff[lVal+lXdim] = 0 then result := true; + if lBuff[lVal-lXdim] = 0 then result := true; + if lBuff[lVal+lSliceSz] = 0 then result := true; + if lBuff[lVal-lSliceSz] = 0 then result := true; + end; +end; + +function ZeroOnEdge (lVal: integer): boolean; +BEGIN + result := false; + if lBuff[lVal] <> 0 then exit; //not ROI - is not boundary + //Find + if ((lVal-lSliceSz) > 0) and ((lVal+lSliceSz) <= lVolSz) then begin + if lBuff[lVal+1] = 255 then result := true; + if lBuff[lVal-1] = 255 then result := true; + if lBuff[lVal+lXdim] = 255 then result := true; + if lBuff[lVal-lXdim] = 255 then result := true; + if lBuff[lVal+lSliceSz] = 255 then result := true; + if lBuff[lVal-lSliceSz] = 255 then result := true; + end; +end; + +begin //alfa666 + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gBGImg.VOIUndoVolItems) then exit; + //if gImageBackupSz <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + //UpdateBackupBuffer; + lXdim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + if (gBGImg.Scrnmm[1] = 0) or (gBGImg.Scrnmm[2]=0) or (gBGImg.Scrnmm[3]=0) then begin + lXmm := 1; + lYmm := 1; + lZmm := 1; + end else begin + lXmm := gBGImg.Scrnmm[1]; + lYmm := gBGImg.Scrnmm[2]; + lZmm := gBGImg.Scrnmm[3]; + end; + lSliceSz := lXdim * lYdim; + lVolSz := lSliceSz*lZdim; + //lMaxROISz := round(PctImg.Value/100 * lVolSz); + lOriginPos := gOriginX + ((gOriginY-1)*lXdim) + ((gOriginZ-1)*lSliceSz); + if (lOriginPos < 1) or (lVolSz <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) or (lOriginPos > lVolSz) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> gBGImg.VOIUndoVolItems) then + exit; + lVariance := AutoROIForm.VarianceEdit.asinteger; + lEdge := AutoROIForm.EdgeEdit.asinteger; + lSqrRadius := sqr(AutoROIForm.RadiusEdit.asinteger); + if (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) then exit; + lSourceBuffer := gMRIcroOverlay[kBGOverlayNum].ScrnBuffer;//gBuffer; + //Next - START count cluster size + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + //check positive clusters.... + Getmem(lBuff,lVolSz); + FillChar(lBuff^,lVolSz, 0); + //Move(gImageBackupBuffer^,lBuff^,lVolSz); + if ExcludeBlackCheck.checked then //1381 + lExcludeBlackIfZero := 0 //0 + else + lExcludeBlackIfZero := -1;//impossible 8-bit value: do not use this feature + lOriginIntensity := lSourceBuffer[lOriginPos]; //1401 gImageBackupBuffer[lOriginPos]; + lReadFilteredData := false; + //ROIconstrainCheck.enabled := (gROIBupSz > 1); //1410: next 3 lines + ROIconstraint.enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); //1410: next 3 lines + if (ROIconstraint.ItemIndex = 2) and (ROIconstraint.enabled) then + lROIConstrain := true + else + lROIconstrain := false; + FillStart(lOriginPos); + lROIConstrain := false;//1410 + //START: ERODE/DILATE CYCLES + lErodeCycles := AutoROIForm.ErodeEdit.asinteger; + if lErodeCycles > 0 then begin + Getmem(lPreErodeBuff,lVolSz); + Move(lBuff^,lPreErodeBuff^,lVolSz); + for lQHead := 1 to lErodeCycles do begin//ERODE + for lInc := 1 to lVolSz do + if ROIonEdge(lInc) then + lBuff[lInc] :=254; + for lInc := 1 to lVolSz do + if lBuff[lInc]=254 then + lBuff[lInc] := 0; //erode + end;//for ErodeCycles = ERODE + //SET ALL VOXELS THAT HAVE SURVIVED EROSION TO 128, WE THEN GROW THE ORIGIN + for lInc := 1 to lVolSz do + if lBuff[lInc] =255 then lBuff[lInc] := 128; + //NOW - ONLY PRESERVE STUFF CONNECTED TO ORIGIN + lBuff[lOriginPos] := 128; + lOriginIntensity := 128; + lVariance := 2; + lEdge := 2; + lReadFilteredData := true; + FillStart(lOriginPos); + //SWITCH OFF ALL UNCONNECTED BLOBS + for lInc := 1 to lVolSz do + if lBuff[lInc] =128 then lBuff[lInc] := 0; + //for lInc := 1 to lVolSz do + // if lBuff[lInc] > 0 then showmessage(inttostr(lBuff[lInc]));// := 0; + + for lQHead := 1 to lErodeCycles{GrowEdit.asinteger} do begin//DILATE + for lInc := 1 to lVolSz do + if (lPreErodeBuff[lInc] = 255) and (ZeroonEdge(lInc)) then + lBuff[lInc] :=254; + for lInc := 1 to lVolSz do + if lBuff[lInc]=254 then + lBuff[lInc] := 255; //erode + end;//for ErodeCycles = DILATE + Freemem(lPreErodeBuff); + {} + end; //ERODE cycles > 0 + //END: ERODE/DILATE + Freemem(lQra); + ROIconstraint.enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); //1410: next 3 lines + if (ROIconstraint.ItemIndex = 1) and (ROIconstraint.enabled) then begin //delete ROI + for lInc := 1 to gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems do //gROIBup + if (lBuff[lInc] = 255) then + lBuff[lInc] := 0 + else + lBuff[lInc] := gBGImg.VOIUndoVol[lInc]; + end else (*if true {alfa (gDynSz > 1) and (gROIBupsz > 1) {and (gImageBackupSz = gDynSz){} then begin + for lInc := 1 to gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems do + if lBuff[lInc] = 255 then + else if gImageBackupBuffer[lInc] = 255 then + lBuff[lInc] := 255//255; + else lBuff[lInc] := lSourceBuffer[lInc]; + + end else *) + for lInc := 1 to lVolSz do + if lBuff[lInc] <> 255 then + lBuff[lInc] := gBGImg.VOIUndoVol[lInc] + else + lBuff[lInc] := kVOI8bit;//1401 gImageBackupBuffer[lInc]; + Move(lBuff^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lVolSz); + Freemem(lBuff); + //END check clusters + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TAutoROIForm.FormShow(Sender: TObject); +begin +EnsureVOIOpen; +CreateUndoVol; + AutoROIForm.ModalResult := mrCancel; + ROIconstraint.Enabled := (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 1); + OriginBtn.OnClick(sender); + //DeleteCheck.enabled := (gROIBupSz > 1); + //ROIConstrainCheck.enabled := (gROIBupSz > 1); +end; + +procedure TAutoROIForm.FormCreate(Sender: TObject); +begin + //gImageBackupSz := 0; + ROIconstraint.ItemIndex :=(0);//1410 +end; + +procedure TAutoROIForm.FormHide(Sender: TObject); +begin +// if (AutoROIForm.ModalResult = mrCancel) and (gBGImg.VOIUndoVolItems > 1) and (gBGImg.VOIUndoVolItems = gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems) then +// Move(gImageBackupBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gImageBackupSz); + if (AutoROIForm.ModalResult = mrCancel) then + UndoVolVOI; + if not (AutoROIForm.ModalResult = mrCancel) then + gBGImg.VOIchanged := true; + //if gImageBackupSz <> 0 then Freemem(gImageBackupBuffer); + //gImageBackupSz := 0; + ImgForm.Fill3DBtn.Down := false; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +//Previous: create 3D ROI +//Below fill bubbles in 3D ROIS +//ROIcluster Follows +(***********************************************************88 +************************************************************ +**********************************************************) +procedure ROICluster (lXdim, lYDim, lZDim,lXOriginIn,lYOrigin,lZOrigin: integer; lDeleteNotFill: boolean); +var + lVariability,lOrigin,lClusterInputValue,lClusterOutputValue, lClusterSz,lQTail, + lXOrigin,lQHead,lSliceSz,lQSz,lInc,lVolSz: integer; + lXInc,lYInc,lZInc,lSlicePos,lYPos, + lMinX,lMaxX,lMinY,lMaxY,lMinZ,lMaxZ, + lMinXBound,lMaxXBound,lMinYBound,lMaxYBound,lMinZBound,lMaxZBound: integer; + lAtEdge: boolean; + lROIBuf: bytep; + lQra: LongIntP; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; + + procedure Check(lPixel: integer); + begin + if (abs(lROIBuf[lPixel] - lClusterInputValue)) <= lVariability then begin//add item + incQra(lQHead,lQSz); + inc(lClusterSz); + lROIBuf[lPixel] := lClusterOutputValue; + lQra[lQHead] := lPixel; + end; + end; + +PROCEDURE RetirePixel; //FIFO cleanup +VAR + lVal,lXPos,lYPos,lZPos: integer; +BEGIN + lVal := lQra[lQTail]; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + + if lXPos < lMinX then lMinX := lXPos; + if lXPos > lMaxX then lMaxX := lXPos; + if lXpos > lMinXBound then Check(lVal -1);//check to left + if lXPos < lMaxXBound then Check(lVal + 1); //check to right + + if lYPos < lMinY then lMinY := lYPos; + if lYPos > lMaxY then lMaxY := lYPos; + if lYpos > lMinYBound then Check(lVal -lXdim);//check previous line + if lYPos < lMaxYBound then Check(lVal + lXdim); //check next line + + if lZPos < lMinZ then lMinZ := lZPos; + if lZPos > lMaxZ then lMaxZ := lZPos; + if lZpos > lMinZBound then Check(lVal -lSliceSz);//check previous slice + if lZPos < lMaxZBound then Check(lVal + lSliceSz); //check next slice + + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + //1414 follows + for lI := 1 to lQsz do + lQra[lI] := 0; + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +procedure SelectClusters (lInput,lOutput: integer); +begin + lClusterSz := 0; + lClusterInputValue := lInput; + lClusterOutputValue := lOutput; + FillStart(lOrigin); +end; + +function Lo (lVolumeEdge,lObjectEdge: integer): integer; +begin + if lVolumeEdge > lObjectEdge then + result := lObjectEdge + else begin + lAtEdge := true; + result := lVolumeEdge; + end; +end; + +function Hi (lVolumeEdge,lObjectEdge: integer): integer; +begin + if lVolumeEdge < lObjectEdge then + result := lObjectEdge + else begin + lAtEdge := true; + result := lVolumeEdge; + end; +end; + +begin + lXOrigin := lXOriginIn; + lVolSz := lXdim*lYdim*lZdim; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems <> lVolSz then begin + showmessage('You need to draw or load a VOI in order to use the 3D bubble tool.'); + exit; + end; + CreateUndoVol; + lSliceSz := lXdim * lYdim; + lMinX:=lXOrigin; + lMaxX:=lXOrigin; + lMinY:=lYOrigin; + lMaxY:=lYOrigin; + lMinZ:=lZOrigin; + lMaxZ:=lZOrigin; + lMinXBound := 1; + lMaxXBound := lXDim; + lMinYBound := 1; + lMaxYBound := lYDim; + lMinZBound := 1; + lMaxZBound := lZDim; + lOrigin := lXOrigin + ((lYOrigin-1)*lXdim)+((lZOrigin-1)*lSliceSz); + if (lOrigin > lVolSz) or (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) {or (gROIBupSz <> lVolSz )} then exit; + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lOrigin] = 0) then begin + showmessage('You must click directly on a ROI to select it. The 3D ROI bubble tool will not work unless you choose the ROI you wish to fill/delete.'); + exit; + end; + GetMem(lROIBuf, lVolSz); + for lInc := 1 to lVolSz do + if gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lInc] > 0 then//ROI + lROIBuf[lInc] := 1 + else + lROIBuf[lInc] := 0; + //BEGIN: define selected ROI contiguous cluster + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + lVariability := 0; //only convert images that are exactly 1 + SelectClusters(1,255); //selected 3D ROI is 255, other ROI = 1, nonROI 0 + //END: define selected roi + //BEGIN: either delete selected ROI, _OR_ fill bubbles in selected ROI + if lDeleteNotFill then begin + for lInc := 1 to lVolSz do + if lROIBuf[lInc] = 1 then //alfa + lROIBuf[lInc] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lInc] //a different ROI + else + lROIBuf[lInc] := 0;//gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lInc]; //1402 selected ROI or non-ROI + end else begin //fill bubbles in selected ROI + //FindROIbounds; + lMinXBound := Hi(1,lMinX-1); + lMaxXBound := Lo(lXDim,lMaxX+1); + lMinYBound := Hi(1,lMinY-1); + lMaxYBound := Lo(lYDim,lMaxY+1); + lMinZBound := Hi(1,lMinZ-1); + lMaxZBound := Lo(lZDim,lMaxZ+1); + lOrigin := (lMinXBound) + ((lMinYBound-1)*lXdim)+((lMinZBound-1)*lSliceSz); + lVariability := 2;//convert voxels that are either 0 or 1 to 1 + SelectClusters(1,128); + //now bubbles trapped in volume are set to zero + //we next need to distinguish bubbles from unmarked voxels outside the searched object boundary + for lZInc := lMinZBound to lMaxZBound do begin + lSlicePos := (lZInc-1) * lSliceSz; + for lYInc := lMinYBound to lMaxYBound do begin + lYPos := (lYInc-1) * lXDim; + for lXInc := lMinXBound to lMaxXBound do begin + lInc := lXInc + lYPos + lSlicePos; + if lROIBuf[lInc] = 0 then lROIBuf[lInc] := 33; + end; //for X + end; //for Y + end; //for Z + + for lInc := 1 to lVolSz do + if lROIBuf[lInc] = 33 then + lROIBuf[lInc] := kVOI8bit //bubble in selected ROI + else + lROIBuf[lInc] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lInc]; + end; + Freemem(lQra); + //BEGIN: CREATE 3D UNDO BUFFER + (*if (gDynSz > 1) and (gDynSz = gImageBackupSz) then begin + if (gUndoBufSz > 0) then freemem(gUndoBuffer); + gUndoBufSz := gDynSz; + getmem(gUndoBuffer,gDynSz); + Move(gImageBackupBuffer^,gUndoBuffer^,gImageBackupSz); + gSaveUndoBuf := true; + end; (**) + //END: CREATE 3D UNDO BUFFER + //BEGIN: mopping up: prepare data for viewing, report ROI change + Move(lROIBuf^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lVolSz); + Freemem(lROIBuf); {} + gBGImg.VOIchanged := true; + //END: mopping up + ImgForm.RefreshImagesTimer.enabled := true; +end; (**) + +procedure TAutoROIForm.AutoROIBtnClick(Sender: TObject); +begin + AutoROIForm.ModalResult := mrOK; + AutoROIForm.close; +end; + +procedure TAutoROIForm.CancelBtnClick(Sender: TObject); +begin + AutoROIForm.close; +end; + +procedure TAutoROIForm.AutoROIchange(Sender: TObject); +begin + if not AutoROIForm.visible then exit; + Timer1.Enabled := true; +end; + +procedure TAutoROIForm.Timer1Timer(Sender: TObject); +begin +Timer1.Enabled := false; +PreviewBtnClick(sender); +end; + +procedure TAutoROIForm.FormDestroy(Sender: TObject); +begin + //if gImageBackupSz <> 0 then Freemem(gImageBackupBuffer); + //gImageBackupSz := 0; +end; + +end. diff --git a/niftiview7/b10.png b/niftiview7/b10.png new file mode 100755 index 0000000..e6c2582 Binary files /dev/null and b/niftiview7/b10.png differ diff --git a/niftiview7/batch.pas b/niftiview7/batch.pas new file mode 100755 index 0000000..19fcaa6 --- /dev/null +++ b/niftiview7/batch.pas @@ -0,0 +1,178 @@ +unit batch; +{$H+} +interface +uses define_types,Windows; +procedure BatchVOI; + +implementation + +uses + Forms, + //lclintf,LResources,{$IFNDEF Unix} Controls, {$ELSE}BaseUnix, LCLType,{$ENDIF} + nifti_img, nifti_img_view, dialogs, nifti_hdr_view, text,sysutils,classes, fdr,batchstatselect; + +(*function LesionFrac (lOverlayNum: integer): double; +var + lLesionSum,lInten: double; + lInc: integer; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lLesionSum := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lInten := RawBGIntensity(lInc); + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then + lLesionSum := lLesionSum + lInten; + end; //for each voxel + result := lLesionSum; +end;*) + +function VOIVol (lOverlayNum: integer): integer; +var + lInc,lVox: integer; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + inc(lVox); + end; //for each voxel + result := lVox; +end; //VOIVol + +function VOIMean (lOverlayNum: integer): double; +var + lSum,lInten,lVol: double; + lInc: integer; +begin + result := 0; + lVol := VOIVol(lOverlayNum); + if lVol < 1 then + exit; + lSum := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lInten := RawBGIntensity(lInc); + //Next line - only voxels that are part of VOI + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + lSum := lSum + lInten; + end; //for each voxel + result := lSum/lVol; +end; //VOIMean + +function VOIMeanFrac10pct (lOverlayNum: integer; lMax: boolean): double; +//if lMax is true, return top 10pct, if false return bottom +var + lSum: double; + lVox,lInc,l10pct: integer; + lRA: singlep; +begin //proc ShowDescript + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + //first - count number of voxels in ROI + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then + inc(lVox); + //next - get memory + if lVox < 1 then + exit; + getmem(lRA,lVox * sizeof(single)); + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + inc(lVox); + lRA^[lVox] := RawBGIntensity(lInc); + end; + qsort(1, lVox,lRA); + l10pct := round(lVox / 10); + if l10pct < 1 then + l10pct := 1; + lSum := 0; + if not lMax then begin //lower 10pct + for lInc := 1 to l10pct do + lSum := lSum + lRA^[lInc] + end else begin //top 10pct + for lInc := (lVox-l10pct+1) to lVox do + lSum := lSum + lRA^[lInc]; + end; + result := lSum / l10pct; + freemem(lRA); +end; + +procedure BatchVOI; +var + lNumberofP,lP,lInc,lNumberofFiles,lLoop: integer; + lFilename,lStr:string; + lBGStrings : TStrings; +begin + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + lBGStrings := TStringList.Create; + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + GetFilesInDir(ExtractFileDir(HdrForm.OpenHdrDlg.Filename),lBGStrings) + end else begin + if not OpenDialogExecute(kImgFilter,'Select background images (stat maps)',true) then + exit; + lBGStrings.AddStrings(HdrForm.OpenHdrDlg.Files); + end; + lNumberofP:= lBGStrings.Count; + if lNumberofP < 1 then begin + lBGStrings.free; + exit; + end; + if not OpenDialogExecute(kImgFilter,'Select overlay images (ROIs)',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.MemoT.Lines.Clear; + lStr := 'Function'+kTextSep+'VOIname'+kTextSep+'VOIvol'; + for lP := 1 to lNumberofP do + lStr := lStr + kTextSep+(lBGStrings.Strings[lP-1]); + TextForm.MemoT.lines.add(lStr); + for lLoop := 1 to 3 do begin + for lInc:= 1 to lNumberofFiles do begin + ImgForm.StatusLabel.Caption := inttostr(lInc)+'/'+inttostr(lNumberofFiles); + IMgForm.refresh; + if lLoop=3 then + lStr := 'min10pct' + else if lLoop=2 then + lStr := 'max10pct' + else + lStr := 'mean'; + lStr := lStr +kTextSep+ (HdrForm.OpenHdrDlg.Files[lInc-1]); + for lP := 1 to lNumberofP do begin + lFilename := lBGStrings.Strings[lP-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + ImgForm.OverlayOpenCore ( lFilename, 2); + if lP = 1 then + lStr := lStr + kTextSep+ inttostr(VOIVol(2) ); + if lLoop = 3 then + lStr := lStr + kTextSep+ floattostr(VOIMeanFrac10Pct(2,false)) + else if lLoop = 2 then + lStr := lStr + kTextSep+ floattostr(VOIMeanFrac10Pct(2,true)) + else + lStr := lStr + kTextSep+ floattostr(VOIMean(2)); + end; + TextForm.MemoT.lines.add(lStr ); + end; + end;//lLoop + FreeImgMemory(gMRIcroOverlay[2]); + ImgForm.UpdateLayerMenu; + lBGStrings.Free; + TextForm.Show; +end; + +end. + diff --git a/niftiview7/batch_old.pas b/niftiview7/batch_old.pas new file mode 100755 index 0000000..f1660fc --- /dev/null +++ b/niftiview7/batch_old.pas @@ -0,0 +1,212 @@ +unit batch; + +interface +uses define_types,Windows; +procedure BatchVOI; + +implementation + +uses nifti_img, nifti_img_view, dialogs, nifti_hdr_view, text,sysutils,classes, fdr; + +(*function LesionFrac (lOverlayNum: integer): double; +var + lLesionSum,lInten: double; + lInc: integer; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lLesionSum := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lInten := RawBGIntensity(lInc); + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then + lLesionSum := lLesionSum + lInten; + end; //for each voxel + result := lLesionSum; +end;*) + +function VOIVol (lOverlayNum: integer): integer; +var + lInc,lVox: integer; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then + inc(lVox); + end; //for each voxel + result := lVox; +end; //VOIVol + +function VOIMean (lOverlayNum: integer): double; +var + lSum,lInten,lVol: double; + lInc: integer; +begin + result := 0; + lVol := VOIVol(lOverlayNum); + if lVol < 1 then + exit; + lSum := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lInten := RawBGIntensity(lInc); + //Next line - only voxels that are part of VOI + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then + lSum := lSum + lInten; + end; //for each voxel + result := lSum/lVol; +end; //VOIMean + +function VOIMeanFrac10pct (lOverlayNum: integer; lMax: boolean): double; +//if lMax is true, return top 10pct, if false return bottom +var + lSum: double; + lVox,lInc,l10pct: integer; + lRA: singlep; +begin //proc ShowDescript + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 1 then + exit; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + //first - count number of voxels in ROI + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then + inc(lVox); + //next - get memory + if lVox < 1 then + exit; + getmem(lRA,lVox * sizeof(single)); + lVox := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then begin + inc(lVox); + lRA^[lVox] := RawBGIntensity(lInc); + end; + qsort(1, lVox,lRA); + l10pct := round(lVox / 10); + if l10pct < 1 then + l10pct := 1; + lSum := 0; + if not lMax then begin //lower 10pct + for lInc := 1 to l10pct do + lSum := lSum + lRA^[lInc] + end else begin //top 10pct + for lInc := (lVox-l10pct+1) to lVox do + lSum := lSum + lRA^[lInc]; + end; + result := lSum / l10pct; + freemem(lRA); +end; + +(*procedure BatchVOI; +var + lInc,lNumberofFiles: integer; + lFilename:string; + lStrings : TStringList; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + + if not OpenDialogExecute(kImgFilter,'Select PMaps',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + lStrings := TStringList.Create; + lStrings.AddStrings(HdrForm.OpenHdrDlg.Files); + if not OpenDialogExecute(kImgFilter,'Select images you wish to analyze',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.Memo1.Lines.Clear; + TextForm.Memo1.lines.add('Background =,'+gMRIcroOverlay[kBGOverlayNum].hdrfilename); + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + ImgForm.OverlayOpenCore ( lFilename, 2); + + TextForm.Memo1.lines.add(lfilename+','{+ inttostr(LesionVol(2))+','}+ floattostr(LesionFrac(2)) ); + //ImgForm.ShowDescriptive(2,true); + end; + FreeImgMemory(gMRIcroOverlay[2]); + ImgForm.UpdateLayerMenu; + //SaveDialog1.Filename := ExtractFileDirWithPathDelim(HdrForm.OpenHdrDlg.Files[0])+'desc.csv'; + lStrings.Free; + //ImgForm.SaveDialog1.Filename := ExtractFileDirWithPathDelim(gMRIcroOverlay[lOverlayNum].HdrFileName)+'desc.csv'; + TextForm.Show; +end;*) +procedure BatchVOI; +var + lNumberofP,lP,lInc,lNumberofFiles,lLoop: integer; + lFilename,lStr:string; + lStrings : TStringList; +begin + + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + + if not OpenDialogExecute(kImgFilter,'Select background images (stat maps)',true) then exit; + lNumberofP:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofP < 1 then + exit; + lStrings := TStringList.Create; + lStrings.AddStrings(HdrForm.OpenHdrDlg.Files); + + if not OpenDialogExecute(kImgFilter,'Select overlay images (ROIs)',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.Memo1.Lines.Clear; + for lLoop := 1 to 3 do begin + if lLoop=3 then + lStr := 'min10pct_Filename,Vol' + else if lLoop=2 then + lStr := 'max10pct_Filename,Vol' + else + lStr := 'mean,Vol'; + for lP := 1 to lNumberofP do + lStr := lStr + ','+Parsefilename(extractfilename(lStrings.Strings[lP-1])); + TextForm.Memo1.lines.add(lStr); + for lInc:= 1 to lNumberofFiles do begin + ImgForm.StatusLabel.Caption := inttostr(lInc)+'/'+inttostr(lNumberofFiles); + IMgForm.refresh; + lStr := Parsefilename(extractfilename(HdrForm.OpenHdrDlg.Files[lInc-1])); + for lP := 1 to lNumberofP do begin + lFilename := lStrings.Strings[lP-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + ImgForm.OverlayOpenCore ( lFilename, 2); + if lP = 1 then + lStr := lStr + ','+ inttostr(VOIVol(2) ); + if lLoop = 3 then + lStr := lStr + ','+ floattostr(VOIMeanFrac10Pct(2,false)) + else if lLoop = 2 then + lStr := lStr + ','+ floattostr(VOIMeanFrac10Pct(2,true)) + else + lStr := lStr + ','+ floattostr(VOIMean(2)); + end; + TextForm.Memo1.lines.add(lStr ); + end; + end;//lLoop + FreeImgMemory(gMRIcroOverlay[2]); + ImgForm.UpdateLayerMenu; + //SaveDialog1.Filename := ExtractFileDirWithPathDelim(HdrForm.OpenHdrDlg.Files[0])+'desc.csv'; + lStrings.Free; + //ImgForm.SaveDialog1.Filename := ExtractFileDirWithPathDelim(gMRIcroOverlay[lOverlayNum].HdrFileName)+'desc.csv'; + TextForm.Show; +end; + +end. + \ No newline at end of file diff --git a/niftiview7/batchstatselect.pas b/niftiview7/batchstatselect.pas new file mode 100755 index 0000000..4acd664 --- /dev/null +++ b/niftiview7/batchstatselect.pas @@ -0,0 +1,88 @@ +unit batchstatselect; +{$H+} +interface + +uses + Classes, SysUtils,StrUtils, define_types, Dialogs; + +procedure GetFilesInDir (lDefaultFolder: string; var lFilenames: TStrings); + +implementation + +function IsStatHdr(lStr: string): boolean; +//detects 'spmT_000*.hdr and zstat*.nii.gz +//requires StrUtils +var + lExt: string; +begin + result := false; + if not IsExtNIFTIHdr(lStr) then + exit; + if AnsiContainsText(lStr, 'spmT_') or AnsiContainsText(lStr, pathdelim+'zstat') then + result := true; +end; + +procedure FindNIIhdrRecursive (var lFolderNameIn: string; var lStringList : TStrings); +var + len: integer; + lFolderName,lNewDir,lNewName,lExt: String; + lSearchRec: TSearchRec; +begin + lFolderName := lFolderNameIn; + if not DirExists (lFolderName) then begin + lFolderName := ExtractFileDir(lFolderName); + end; + if (length(lFolderName) > 1) and (lFolderName[length(lFolderName)] <> PathDelim) then + lNewDir := lFolderName+PathDelim; + if DirExists (lNewDir) then begin +{$IFDEF UNIX} + if FindFirst(lNewDir+'*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ELSE} + if FindFirst(lNewDir+'*.*',faAnyFile-faSysFile,lSearchRec) = 0 then begin +{$ENDIF} + repeat + lNewName := lNewDir+lSearchRec.Name; + if (lSearchRec.Name = '.') or (lSearchRec.Name = '..') then + //current or parent folder - do nothing + else if DirExists(lNewName) then + FindNIIhdrRecursive (lNewName, lStringList) + else if IsStatHdr(lNewName) then + lStringList.Add(lNewName); + until (FindNext(lSearchRec) <> 0); + end; //if findfirst + FindClose(lSearchRec); + end;//Direxists +end; + +procedure FilterForText (lRequiredText: string; var lFilenames: TStrings); +var + i,len: integer; +begin + len := lFilenames.Count; + if (length(lRequiredText) < 1) or (len < 1) then + exit; + for i := len-1 downto 0 do + if not AnsiContainsText(lFilenames[i], lRequiredText) then + lFilenames.Delete(i); +end; + +procedure GetFilesInDir (lDefaultFolder: string; var lFilenames: TStrings); +var + lParentDir,lFilter : string; +begin + lParentDir := GetDirPrompt (lDefaultFolder); + if not DirExists(lParentDir) then + exit; + FindNIIhdrRecursive(lParentDir,lFilenames); + if lFilenames.Count < 1 then begin + showmessage('No statistical files found in the path '+lParentDir); + exit; + end; + lFilter := '.gfeat'; + InputQuery('Filter data', 'Filter for statistical maps [e.g. ''.gfeat'' will only analyze files with this in their path. Set to blank to analyze all files',lFilter); + FilterForText(lFilter,lFilenames); +end; + + +end. + diff --git a/niftiview7/bet.pas b/niftiview7/bet.pas new file mode 100755 index 0000000..56b7845 --- /dev/null +++ b/niftiview7/bet.pas @@ -0,0 +1,218 @@ +unit bet; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Buttons, ExtCtrls, StdCtrls,nifti_img,nifti_img_view,ShellAPI, RXSpin,define_types, + Mask; + +type + TBETForm = class(TForm) + Memo1: TMemo; + Panel1: TPanel; + GoBtn: TSpeedButton; + AboutBtn: TSpeedButton; + SmoothnessEdit: TRxSpinEdit; + CropBtn: TSpeedButton; + procedure GoBtnClick(Sender: TObject); + procedure AboutBtnClick(Sender: TObject); + procedure CropBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + BETForm: TBETForm; + +implementation + +uses cropedges; + +{$R *.DFM} + +function DoBET(lInFile,lOutFile: string; lFrac: single):boolean; +var + lCmd: String; + SEInfo: TShellExecuteInfo; + ExitCode: DWORD; + ExecuteFile, lParamStr, lExecStr: string; +begin + Result := false; + lExecStr := extractfilepath(paramstr(0))+'bet'; + if FSize(lExecStr+'.exe') < 1 then + BETForm.Memo1.Lines.Add('Unable to find executable named '+lCmd); + ExecuteFile:=lExecStr; + lParamStr := '"'+lInFile+'" "'+lOutFile +'" -f '+floattostr(lFrac); + FillChar(SEInfo, SizeOf(SEInfo), 0) ; + SEInfo.cbSize := SizeOf(TShellExecuteInfo) ; + with SEInfo do begin + fMask := SEE_MASK_NOCLOSEPROCESS; + Wnd := Application.Handle; + lpFile := PChar(ExecuteFile) ; + lpParameters := PChar(lParamStr) ; + // lpDirectory := PChar(StartInString) ; + nShow := SW_SHOWNORMAL; + end; + if ShellExecuteEx(@SEInfo) then begin + repeat + Application.ProcessMessages; + GetExitCodeProcess(SEInfo.hProcess, ExitCode) ; + until (ExitCode <> STILL_ACTIVE) or + Application.Terminated; + result := true; + end; +end; + + +function Bright95Pct: byte;//returns intensity of 95th percentile +var + lPos,l5Pct,lCumulative: integer; + lHisto: array [0..255] of integer; +begin + result := 0; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems) then exit; + //next - create histogram of intensity + for lPos := 0 to 255 do + lHisto[lPos] := 0; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + inc(lHisto[gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lPos]]); + //next find 95th percentile + l5Pct := (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems div 20); + lCumulative := 0; + lPos := 256; + while (lPos > 0) and (lCumulative < l5Pct) do begin + dec(lPos); + lCumulative := lCumulative + lHisto[lPos]; + end; + result := lPos; +end; + +procedure CropVOI (lVOIIntensity: byte); +var + lPos: integer; +begin + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems) then exit; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] = kVOI8bit then + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lPos] := lVOIIntensity; +end; + +procedure DeleteHdrImg(lFilename: string); +begin + if lFilename = '' then + exit; + DeleteFile(lFilename); + if (UpCaseExt(lFileName)='.IMG') then + DeleteFile(changefileext(lFilename,'.hdr')); + if (UpCaseExt(lFileName)='.HDR') then + DeleteFile(changefileext(lFilename,'.img')); +end; + +function Mask8BitImg(lImgName,lMaskName: string): boolean;//should be two 8-bit image files of identical dimensions +//all non-zero voxels in the mask are written with value of img +//Warning - only works with .img files with zero voxoffset - can corrupt .nii files - would need to read header.... +var + lPos2,lPos,lC,lSz,lMaskSz,lBPP: integer; + lImg,lMask: bytep; + lInF: File; +begin + result := false; + lSz := FSize(lImgName); + lMaskSz := FSize(lMaskName); + if lSz = lMaskSz then + lBPP := 1 + else if lSz = (2*lMaskSz) then + lBPP := 2 + else if lSz = (2*lMaskSz) then + lBPP := 4 + else + lBPP := 0; + //showmessage('a'); + if (lSz < 1) or (lBPP = 0 ) then + exit; + //showmessage('b'); + //next read mask + GetMem(lMask,lSz); + AssignFile(lInF, lMaskName); + Reset(lInF,1); + BlockRead(lInF, lMask^, lMaskSz); + CloseFile(lInF); + //next: read image + GetMem(lImg,lSz); + AssignFile(lInF, lImgName); + Reset(lInF,1); + BlockRead(lInF, lImg^, lSz); + CloseFile(lInF); + //next mask image + for lPos := 1 to lMaskSz do + if lMask^[lPos] = 0 then begin + lPos2 := ((lPos-1)*lBPP); + for lC := 1 to lBPP do + lImg^[lC+lPos2] := 0; + end; + Freemem(lMask); + //next save masked image + AssignFile(lInF, lImgName); //1/2008.... + //AssignFile(lInF, lMaskName); + Rewrite(lInF,1); + BlockWrite(lInF, lImg^, lSz); + CloseFile(lInF); + Freemem(lImg); + result := true; +end; + +procedure TBETForm.GoBtnClick(Sender: TObject); +var + lTempNameOrig,lTempName8bitMask,lTempBetName: string; +begin + Memo1.Clear; + Memo1.lines.add('Startup Timestamp: '+DateTimeToStr(Now)); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + showmessage('BET error: please use File/Open to display the image you want to brain extract.'); + end; + lTempNameOrig := extractfilepath(paramstr(0))+'orig.hdr'; + SaveAsVOIorNIFTIcore (lTempNameOrig, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems, gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then begin + case MessageDlg('Do you wish to protect tissue shown by the VOI drawing?', mtConfirmation, [mbYes, mbNo], 0) of + mrYes: CropVOI(Bright95Pct); + end; //case for protecting VOI + ImgForm.CloseVOIClick(nil); + //lTempBetName := 'c:\bet.nii'; + //SaveAsVOIorNIFTIcore (lTempBetName, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + + end; + if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP <> 1 then + Memo1.lines.add('Warning: converted image downsampled to 8-bit precision.'); + lTempName8bitMask := extractfilepath(paramstr(0))+'temp8.hdr'; + SaveAsVOIorNIFTIcore (lTempName8bitMask, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + lTempName8bitMask := changefileext(lTempName8bitMask,'.hdr'); //SaveAs renames the .hdr to .img + lTempBetName := extractfilepath(paramstr(0))+'btemp8.hdr'; + DoBET(lTempName8bitMask,lTempBetName,SmoothnessEdit.value); + Memo1.lines.add('Shutdown Timestamp: '+DateTimeToStr(Now)); + + CopyFileEXoverwrite(lTempName8bitMask,lTempBetName); //the old version of BET corrupts some NIfTI information + Mask8BitImg(changefileext(lTempNameOrig,'.img'),changefileext(lTempBetName,'.img')); + ImgForm.OpenAndDisplayImg(lTempNameOrig,True); + Memo1.lines.add('Use File/SaveAsNIfTI to save the stripped 8-bit image.'); + DeleteHdrImg(lTempBetName); + DeleteHdrImg(lTempNameOrig); + DeleteHdrImg(lTempName8bitMask); +end; + +procedure TBETForm.AboutBtnClick(Sender: TObject); +begin + Showmessage('You can skull strip scans to allow you to render the surface of the brain.'+chr (13) ++ 'This uses Steve Smith''s Brain Extraction Tool [BET].'+chr (13)+ +'Default smoothness is 0.50, smaller values generate larger estimates of brain size.'+chr (13) ++'http://www.fmrib.ox.ac.uk/fsl'); +end; + +procedure TBETForm.CropBtnClick(Sender: TObject); +begin + CropEdgeForm.Show; +end; + +end. diff --git a/niftiview7/clustering.pas b/niftiview7/clustering.pas new file mode 100755 index 0000000..cecf69f --- /dev/null +++ b/niftiview7/clustering.pas @@ -0,0 +1,383 @@ +unit clustering; +//USED by stats to select only regions with a given number of connected/contiguous voxels +interface +uses define_types,dialogs,SysUtils,nifti_hdr,nifti_img; + +//procedure FindClusters (lMultiBuf: SingleP; lXdim, lYDim, lZDim, lThreshClusterSz: integer; lMinNeg, lMinPos: single); + +function ClusterFilterScrnImg (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double ): boolean; + + +implementation + + + +procedure FindClusters (var lHdr: TMRIcroHdr; lXdim, lYDim, lZDim, lThreshClusterSz: integer; lThresh: double); +var + lThreshClusterSzM1,lScaledThresh,lClusterSign,lClusterSz,lClusterFillValue,lQTail,lQHead,lSliceSz,lQSz,lInc,lVolSz: integer; + lClusterBuff, lQra: LongIntP; + lBuffIn32 : SingleP; + lBuffIn16 : SmallIntP; + lScaledThreshFloat: double; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; + + procedure Check(lPixel: integer); + begin + //if lClusterFillValue = kFillvalue then showmessage(inttostr(lPixel)+'@'); + if (lClusterBuff[lPixel]=lClusterSign) then begin//add item + //if lClusterFillValue = kFillvalue then showmessage(inttostr(lPixel)); + incQra(lQHead,lQSz); + inc(lClusterSz); + lClusterBuff[lPixel] := lClusterFillValue; + lQra[lQHead] := lPixel; + end; + end; +PROCEDURE RetirePixel; //FIFO cleanup , 1410: added 18-voxel check +VAR + lXDimM,lVal,lValX,lXPos,lYPos,lZPos: integer; +BEGIN + lVal := lQra[lQTail]; + if lVal = 0 then begin + //should never happen: unmarked voxel = increment lQTail so not infinite loop + incQra(lQTail,lQSz); //done with this pixel + exit; + end; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + if (lXPos <= 1) or (lXPos >= lXDim) or + (lYPos <= 1) or (lYPos >= lYDim) or + (lZPos <= 1) or (lZPos >= lZDim) then + // retire and exit +else begin +lXDimM := lXDim; + Check(lVal-1); //left + Check(lVal+1); //right + Check(lVal-lXDimM); //up + Check(lVal+lXDimM); //down + Check(lVal-lSliceSz); //up + Check(lVal+lSliceSz); //down + //check plane above + lValX := lVal + lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check plane below + lValX := lVal - lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check diagonals of current plane + Check(lVal-lXDimM-1); //up, left + Check(lVal-lXDimM+1); //up, right + + Check(lVal+lXDimM-1); //down, left + Check(lVal+lXDimM+1); //down, right +end;{} //not edge + incQra(lQTail,lQSz); //done with this pixel +END; //nested procedure RetirePixel +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + if (lClusterBuff[lPt]<>lClusterSign) then exit; + for lI := 1 to lQsz do + lQra[lI] := 0; + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; //nested proc fillstart +procedure SelectClusters (lSign: integer); +var lInc: integer; +begin + for lInc := 1 to lVolSz do begin + if lClusterBuff[lInc] = lSign then begin + // measure size of the cluster and fill it with kFillValue + lClusterSz := 0; + lClusterSign := lSign; + lClusterFillValue := kFillValue; + FillStart(lInc); + // now fill the cluster with its size (=1 if the voxel was isolated) + lClusterFillValue := lClusterSz; + lClusterSign := kFillValue; + //if lClusterSz > 1 then ShowMessage(inttostr(lClusterSz)+'@'+inttostr(lInc)); + if lClusterSz > 1 then + FillStart(lInc) + else + lClusterBuff[lInc] := 1; //fill all voxels in cluster with size of voxel + end; + end; +end; //nested proc select clusters +begin + lVolSz := lXdim*lYdim*lZdim; + lSliceSz := lXdim * lYdim; + if (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) then exit; + GetMem(lClusterBuff, lVolSz* sizeof(LongInt)); + for lInc := 1 to lVolSz do + lClusterBuff[lInc] := 0; + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + lScaledThreshFloat := Scaled2RawIntensity (lHdr, lThresh); + for lInc := 1 to lVolSz do + if lBuffIn32[lInc] > lScaledThreshFloat then + lClusterBuff[lInc] := 1; + lScaledThreshFloat := Scaled2RawIntensity (lHdr, -lThresh); + for lInc := 1 to lVolSz do + if lBuffIn32[lInc] < lScaledThreshFloat then + lClusterBuff[lInc] := -1; + end else if lHdr.ImgBufferBPP = 2 then begin //not 32bit - if 16bit input + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + lScaledThresh := round(Scaled2RawIntensity (lHdr, lThresh)); + for lInc := 1 to lVolSz do + if lBuffIn16[lInc] > lScaledThresh then + lClusterBuff[lInc] := 1; + lScaledThresh := round(Scaled2RawIntensity (lHdr, -lThresh)); + for lInc := 1 to lVolSz do + if lBuffIn16[lInc] < lScaledThresh then + lClusterBuff[lInc] := -1; + + end else begin //not 16 or 32 bit input + lScaledThresh := round(Scaled2RawIntensity (lHdr, lThresh)); + for lInc := 1 to lVolSz do + if lHdr.ImgBuffer[lInc] > lScaledThresh then + lClusterBuff[lInc] := 1; + lScaledThresh := round(Scaled2RawIntensity (lHdr, -lThresh)); + for lInc := 1 to lVolSz do + if lHdr.ImgBuffer[lInc] < lScaledThresh then + lClusterBuff[lInc] := -1; + end; //8-bit input + lThreshClusterSzM1 := lThreshClusterSz; + if lThreshClusterSzM1 < 1 then + lThreshClusterSzM1 := 1; + if (lThreshClusterSzM1 > 1) then begin + //Next - START count cluster size + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + //check positive clusters.... + SelectClusters(1); + //Check negative clusters + SelectClusters(-1); + Freemem(lQra); + //END check clusters + end; //only count clusters if minimum size > 1, otherwise simple intensity threshold... + //NEXT: mask image data with cluster size + + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + for lInc := 1 to lVolSz do + if lClusterBuff[lInc] < lThreshClusterSzM1 then + lBuffIn32^[lInc] := 0; + end else if lHdr.ImgBufferBPP = 2 then begin + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + + for lInc := 1 to lVolSz do + if lClusterBuff[lInc] < lThreshClusterSzM1 then + lBuffIn16^[lInc] := 0; + end else begin + for lInc := 1 to lVolSz do + if lClusterBuff[lInc] < lThreshClusterSzM1 then + lHdr.ImgBuffer^[lInc] := 0; + end; + Freemem(lClusterBuff); +end; + +function ClusterFilterScrnImg (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double ): boolean; +var + lX,lY,lZ: integer; +begin + result := false; + lX := lHdr.NIFTIhdr.Dim[1]; + lY := lHdr.NIFTIhdr.Dim[2]; + lZ := lHdr.NIFTIhdr.Dim[3]; + + if (lHdr.ImgBufferItems < (lX*lY*lZ)) then + exit; + FindClusters (lHdr, lX, lY, lZ, lThreshClusterSz, lThresh); + result := true; +end; + +//Text output + +procedure FindClustersText (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double); +var + lXdim,lYdim,lZdim,lThreshClusterSzM1,lScaledThresh,lClusterSz,lClusterFillValue,lQTail,lQHead,lSliceSz,lQSz,lInc,lVolSz: integer; + lClusterBuffS: SingleP; + lQra: LongIntP; + lBuffIn32 : SingleP; + lBuffIn16 : SmallIntP; + //lScaledThreshFloat: double; + //lFdata: file;//abba - test +//const +// kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; + + procedure Check(lPixel: integer); + begin + //if lClusterFillValue = kFillvalue then showmessage(inttostr(lPixel)+'@'); + if (lClusterBuffS[lPixel]<> 0) then begin//add item + //if lClusterFillValue = kFillvalue then showmessage(inttostr(lPixel)); + incQra(lQHead,lQSz); + inc(lClusterSz); + lClusterBuffS[lPixel] := lClusterFillValue; + lQra[lQHead] := lPixel; + end; + end; + + +PROCEDURE RetirePixel; //FIFO cleanup , 1410: added 18-voxel check +VAR + lXDimM,lVal,lValX,lXPos,lYPos,lZPos: integer; +BEGIN + lVal := lQra[lQTail]; + if lVal = 0 then begin + //should never happen: unmarked voxel = increment lQTail so not infinite loop + incQra(lQTail,lQSz); //done with this pixel + exit; + end; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + + lZpos := ((lVal-1) div lSliceSz)+1; + if (lXPos <= 1) or (lXPos >= lXDim) or + (lYPos <= 1) or (lYPos >= lYDim) or + (lZPos <= 1) or (lZPos >= lZDim) then + // retire and exit +else begin +lXDimM := lXDim; + Check(lVal-1); //left + Check(lVal+1); //right + Check(lVal-lXDimM); //up + Check(lVal+lXDimM); //down + Check(lVal-lSliceSz); //up + Check(lVal+lSliceSz); //down + //check plane above + lValX := lVal + lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check plane below + lValX := lVal - lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check diagonals of current plane + Check(lVal-lXDimM-1); //up, left + Check(lVal-lXDimM+1); //up, right + + Check(lVal+lXDimM-1); //down, left + Check(lVal+lXDimM+1); //down, right +end;{} //not edge + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + if (lClusterBuffS[lPt]<>0) then exit; + for lI := 1 to lQsz do + lQra[lI] := 0; + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + // check that there was anything in the cluster at all + //showmessage('head'+inttostr(lQHead)+'.'+inttostr(lQTail)); + //if lQHead > 2 then begin + // and do the recursion to get rid of it + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; + //end; + //showmessage('alldone'); +end; + +procedure SelectClusters (lSign: integer); +var lInc: integer; +begin + for lInc := 1 to lVolSz do begin + if lClusterBuffS[lInc] <> 0 then begin + // measure size of the cluster and fill it with kFillValue + lClusterSz := 0; + FillStart(lInc); + // now fill the cluster with its size (=1 if the voxel was isolated) + //if lClusterSz > 1 then ShowMessage(inttostr(lClusterSz)+'@'+inttostr(lInc)); + if lClusterSz > 1 then + FillStart(lInc) + else + lClusterBuffS[lInc] := 0; //fill all voxels in cluster with size of voxel + end; + end; +end; + +begin + lXDim := lHdr.NIFTIhdr.dim[1]; + lYDim := lHdr.NIFTIhdr.dim[2]; + lZDim := lHdr.NIFTIhdr.dim[3]; + lVolSz := lXdim*lYdim*lZdim; + lSliceSz := lXdim * lYdim; + if (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) then exit; + GetMem(lClusterBuffS, lVolSz* sizeof(Single)); + for lInc := 1 to lVolSz do + lClusterBuffS[lInc] := 0; + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + for lInc := 1 to lVolSz do + lClusterBuffS[lInc] := lBuffIn32[lInc]; + end else if lHdr.ImgBufferBPP = 2 then begin //not 32bit - if 16bit input + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + for lInc := 1 to lVolSz do + lClusterBuffS[lInc] := lBuffIn16[lInc]; + end else begin //not 16 or 32 bit input + for lInc := 1 to lVolSz do + lClusterBuffS[lInc] := lHdr.ImgBuffer[lInc]; + end; //8-bit input + lThreshClusterSzM1 := lThreshClusterSz; + if lThreshClusterSzM1 < 1 then + lThreshClusterSzM1 := 1; + if (lThreshClusterSzM1 > 1) then begin + //Next - START count cluster size + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + //check positive clusters.... + SelectClusters(1); + //Check negative clusters + SelectClusters(-1); + Freemem(lQra); + //END check clusters + end; //only count clusters if minimum size > 1, otherwise simple intensity threshold... + Freemem(lClusterBuffS); + +end; + + +end. diff --git a/niftiview7/crop.pas b/niftiview7/crop.pas new file mode 100755 index 0000000..203bec4 --- /dev/null +++ b/niftiview7/crop.pas @@ -0,0 +1,263 @@ +unit crop; + +interface +function CropNIfTI(lL,lR,lA,lP,lD,lV: integer):boolean; +function GrowNeck (lFilename: string; lVox: integer): boolean; + +implementation + +uses nifti_hdr_view, nifti_hdr, nifti_img,define_types, GraphicsMathLibrary,dialogs, nifti_img_view, nifti_types; + + // nifti_img_view, nifti_img,nifti_hdr, nifti_hdr_view,{ShellAPI,}ShlObj,periutils, reslice_fsl; +procedure NIFTIhdr_SlicesToCoord (var lHdr: TNIFTIhdr; lXslice,lYslice,lZslice: integer; var lXmm,lYmm,lZmm: single); +//ignores origin offset +begin + lXmm := (lHdr.srow_x[0]*lXslice)+ (lHdr.srow_x[1]*lYslice)+(lHdr.srow_x[2]*lzslice); + lYmm := (lHdr.srow_y[0]*lXslice)+ (lHdr.srow_y[1]*lYslice)+(lHdr.srow_y[2]*lzslice); + lZmm := (lHdr.srow_z[0]*lXslice)+ (lHdr.srow_z[1]*lYslice)+(lHdr.srow_z[2]*lzslice); +end; + + + +function CropNIfTI(lL,lR,lA,lP,lD,lV: integer):boolean; +//to do : data swapping (errors on detection and writing zero in reverse order) +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lXmm,lYmm,lZmm: single; + lMat: TMatrix; + lOutPos,lSlice,lVol,lOutVolBytes,lInVolBytes,lImgSamples,lInc, + lX,lY,lZ,lBPP, lB, + lInZOffset,lInYOffset,lInSliceSz,lInXSz,lInPos,lImgOffset: integer; + lBuffer: bytep; + lWordX: Word; + lSPM2: boolean; + lOutF,lInF: File; + lACrop,lPCrop,lDorsalCrop,lVentralCrop,lLCrop,lRCrop: integer; + lByteSwap: boolean; +begin + result := false; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (gBGImg.ScrnDim[3] < 2) or (gBGImg.ScrnMM[3] = 0) then begin + showmessage('Please load a 3D background image for neck removal.'); + exit; + end; + if (gBGImg.Resliced) then begin + showmessage('You must switch reslicing OFF (Help/Preferences) for image cropping.'); + exit; + end; + lInHdr := gMRIcroOverlay[kBGOverlayNum].NIFTIHdr; + //check orthogonal alignment.... + if lInHdr.dim[4] > 1 then begin + Showmessage('Only Cropping 1st 3D image (reorienting 4D could disrupt slice timing and diffusion directions.'); + //exit; + end; + //Next create reordered or trimmed image in the correct format + case lInHdr.datatype of + kDT_UNSIGNED_CHAR,kDT_SIGNED_SHORT,kDT_UINT16, kDT_SIGNED_INT,kDT_FLOAT:;//Supported + else begin + Showmessage('Crop 3D unsupported datatype.'); + exit; + end; + end; + lOutHdr := lInHdr; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]; + lBPP := (lInHdr.bitpix div 8); //bytes per pixel + lDorsalCrop := lD; + lVentralCrop := lV; + lLCrop := lL; + lRCrop := lR; + lACrop := lA; + lPCrop := lP; + //FreeMem(lBuffUnaligned); + if (lDorsalCrop = 0) and (lVentralCrop = 0) + and (lLCrop = 0) and (lRCrop = 0) + and (lACrop = 0) and (lPCrop = 0) then begin + Showmessage('Grow 3D quitting: no need to add or delete slices.'); + //Freemem(lSrcBuffer); + end; + if (lDorsalCrop < 0) or (lVentralCrop < 0) + or (lLCrop < 0) or (lRCrop < 0) + or (lACrop < 0) or (lPCrop < 0) then begin + Showmessage('Grow 3D quitting: negative values should be impossible.'); + //Freemem(lSrcBuffer); + end; + //next compute size of cropped volume + lInVolBytes := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lBPP; + lOutHdr.Dim[1] := lInHdr.Dim[1]-lLCrop-lRCrop; + lOutHdr.Dim[2] := lInHdr.Dim[2]-lACrop-lPCrop; + lOutHdr.Dim[3] := lInHdr.Dim[3]-lDorsalCrop-lVentralCrop; + lOutVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*lBPP; + //next: readjust origin to take into account removed slices + //REQUIRES images to be aligned to nearest orthogonal to canonical space [1 0 0; 0 1 0; 0 0 1] + NIFTIhdr_SlicesToCoord (lInHdr,lLCrop,lPCrop,lVentralCrop, lXmm,lYmm,lZmm); + lOutHdr.srow_x[3] := lInHdr.srow_x[3] + lXmm; + lOutHdr.srow_y[3] := lInHdr.srow_y[3] + lYmm; + lOutHdr.srow_z[3] := lInHdr.srow_z[3] + lZmm; + lMat := Matrix3D ( + lOutHdr.srow_x[0], lOutHdr.srow_x[1], lOutHdr.srow_x[2], lOutHdr.srow_x[3], + lOutHdr.srow_y[0], lOutHdr.srow_y[1], lOutHdr.srow_y[2], lOutHdr.srow_y[3], + lOutHdr.srow_z[0], lOutHdr.srow_z[1], lOutHdr.srow_z[2], lOutHdr.srow_z[3], + 0, 0, 0, 1); + nifti_mat44_to_quatern( lMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + lXmm, lYmm, lZmm, lOutHdr.pixdim[0]{QFac}); + //note we write to a different buffer, as we may need to grow output + //no need to byteswap data - we will save in the save format as stored + lOutPos := 0; + lInSliceSz := lInHdr.dim[1]*lInHdr.dim[2]*lBPP; + lInXSz := lInHdr.dim[1]*lBPP; + GetMem(lBuffer,lOutVolBytes); + //Move(gMRIcroOverlay[kBGOverlayNum].ImgBuffer^,lTempBuf^,gBGImg.VOIUndoVolItems); + + + for lZ := 1 to lOutHdr.dim[3] do begin + lInZOffset := (lVentralCrop+lZ-1) * lInSliceSz; + if lInZOffset < 0 then + lInZOffset := 0; + for lY := 1 to lOutHdr.dim[2] do begin + lInYOffset := ((lPCrop+lY-1) * lInXSz) + lInZOffset + (lLCrop*lBPP); + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lBPP) + lInYOffset + lB; + if (lInPos < 1) or (lInPos > lInVolBytes) then + lBuffer^[lOutPos] := 128 + else + lBuffer^[lOutPos] := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lInPos]; + end; + end; + end; //for Y + end; //for Z + lOutname := ChangeFilePrefix (gMRIcroOverlay[kBGOverlayNum].HdrFileName,'c'); + //result := SaveNIfTICore (lOutName, lSrcBuffer, kNIIImgOffset+1, lOutHdr, lPrefs,lByteSwap); + result := gBGImg.UseReorientHdr; + gBGImg.UseReorientHdr := false; + SaveAsVOIorNIFTI (lBuffer,lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3], lBPP,1, false, lOutHdr, lOutname); + gBGImg.UseReorientHdr := result; + result := true; + Freemem(lBuffer); +end; + + +function GrowNeck (lFilename: string; lVox: integer): boolean; +//to do : data swapping (errors on detection and writing zero in reverse order) +var + lInHdr,lOutHdr: TNIFTIhdr; + lOutname,lExt: string; + lXmm,lYmm,lZmm: single; + lMat: TMatrix; + lOutPos,lSlice,lVol,lOutVolBytes,lInVolBytes,lImgSamples,lInc, + lX,lY,lZ,lBPP, lB, + lVolOffset,lInZOffset,lInYOffset,lInSliceSz,lInXSz,lInPos,lImgOffset: integer; + lBuffer: bytep; + lWordX: Word; + lSPM2: boolean; + lOutF,lInF: File; + lACrop,lPCrop,lDorsalCrop,lVentralCrop,lLCrop,lRCrop: integer; + lByteSwap: boolean; +begin + gBGImg.Prompt4DVolume := false; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kBGOverlayNum]) then exit; + gBGImg.Prompt4DVolume := true; + if not OpenImg(gBGImg,gMRIcroOverlay[kBGOverlayNum],false,false,false,false,true {4D!}) then exit; + lInHdr := gMRIcroOverlay[kBGOverlayNum].NIFTIHdr; + result := false; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferItems < 1) or (lInHdr.dim[1] < 2) or (lInHdr.dim[2] < 2) then begin + showmessage('Please load a 3D background image for neck removal.'); + exit; + end; + if (gBGImg.Resliced) then begin + showmessage('You must switch reslicing OFF (Help/Preferences) for image cropping.'); + exit; + end; + + //check orthogonal alignment.... + lOutHdr := lInHdr; + lImgSamples := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]; + lBPP := (lInHdr.bitpix div 8); //bytes per pixel + lDorsalCrop := 0; + lVentralCrop := lVox; + lLCrop := 0; + lRCrop := 0; + lACrop := 0; + lPCrop := 0; + //FreeMem(lBuffUnaligned); + if (lDorsalCrop = 0) and (lVentralCrop = 0) + and (lLCrop = 0) and (lRCrop = 0) + and (lACrop = 0) and (lPCrop = 0) then begin + Showmessage('Grow 3D quitting: no need to add or delete slices.'); + //Freemem(lSrcBuffer); + end; + if (lDorsalCrop < 0) or (lVentralCrop < 0) + or (lLCrop < 0) or (lRCrop < 0) + or (lACrop < 0) or (lPCrop < 0) then begin + Showmessage('Grow 3D quitting: negative values should be impossible.'); + //Freemem(lSrcBuffer); + end; + //next compute size of cropped volume + + lOutHdr.Dim[1] := lInHdr.Dim[1]-lLCrop-lRCrop; + lOutHdr.Dim[2] := lInHdr.Dim[2]-lACrop-lPCrop; + lOutHdr.Dim[3] := lInHdr.Dim[3]-lDorsalCrop-lVentralCrop; + + //next: readjust origin to take into account removed slices + //REQUIRES images to be aligned to nearest orthogonal to canonical space [1 0 0; 0 1 0; 0 0 1] + NIFTIhdr_SlicesToCoord (lInHdr,lLCrop,lPCrop,lVentralCrop, lXmm,lYmm,lZmm); + lOutHdr.srow_x[3] := lInHdr.srow_x[3] + lXmm; + lOutHdr.srow_y[3] := lInHdr.srow_y[3] + lYmm; + lOutHdr.srow_z[3] := lInHdr.srow_z[3] + lZmm; + lMat := Matrix3D ( + lOutHdr.srow_x[0], lOutHdr.srow_x[1], lOutHdr.srow_x[2], lOutHdr.srow_x[3], + lOutHdr.srow_y[0], lOutHdr.srow_y[1], lOutHdr.srow_y[2], lOutHdr.srow_y[3], + lOutHdr.srow_z[0], lOutHdr.srow_z[1], lOutHdr.srow_z[2], lOutHdr.srow_z[3], + 0, 0, 0, 1); + nifti_mat44_to_quatern( lMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + lXmm, lYmm, lZmm, lOutHdr.pixdim[0]{QFac}); + //note we write to a different buffer, as we may need to grow output + //no need to byteswap data - we will save in the save format as stored + lOutPos := 0; + lInSliceSz := lInHdr.dim[1]*lInHdr.dim[2]*lBPP; + lInXSz := lInHdr.dim[1]*lBPP; + lInVolBytes := lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]*lInHdr.dim[4]*lBPP; + lOutVolBytes := lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3]*lOutHdr.dim[4]*lBPP; + GetMem(lBuffer,lOutVolBytes); + //Move(gMRIcroOverlay[kBGOverlayNum].ImgBuffer^,lTempBuf^,gBGImg.VOIUndoVolItems); + + for lVol := 1 to lOutHdr.dim[4] do begin + lVolOffset := (lVol-1) * lInHdr.dim[1]*lInHdr.dim[2]*lInHdr.dim[3]* lBPP; + for lZ := 1 to lOutHdr.dim[3] do begin + + if lZ > -lVentralCrop then + lInZOffset := ((lVentralCrop+lZ-1) * lInSliceSz) + else + lInZOffset := 0; + for lY := 1 to lOutHdr.dim[2] do begin + lInYOffset := ((lPCrop+lY-1) * lInXSz) + lInZOffset + (lLCrop*lBPP); + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to lBPP do begin + inc(lOutPos); + lInPos := ((lX-1) * lBPP) + lInYOffset + lB; + if (lInPos < 1) or (lInPos > lInVolBytes) then + lBuffer^[lOutPos] := 0 + else + lBuffer^[lOutPos] := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lInPos+lVolOffset]; + end; + end; + end; //for Y + end; //for Z + end; //lvol + lOutname := ChangeFilePrefix (gMRIcroOverlay[kBGOverlayNum].HdrFileName,'c'); + //result := SaveNIfTICore (lOutName, lSrcBuffer, kNIIImgOffset+1, lOutHdr, lPrefs,lByteSwap); + result := gBGImg.UseReorientHdr; + gBGImg.UseReorientHdr := false; + SaveAsVOIorNIFTI (lBuffer,lOutHdr.dim[1]*lOutHdr.dim[2]*lOutHdr.dim[3], lBPP,lOutHdr.dim[4], false, lOutHdr, lOutname); + gBGImg.UseReorientHdr := result; + result := true; + Freemem(lBuffer); +end; + + +end. \ No newline at end of file diff --git a/niftiview7/cropedges.pas b/niftiview7/cropedges.pas new file mode 100755 index 0000000..54a7671 --- /dev/null +++ b/niftiview7/cropedges.pas @@ -0,0 +1,482 @@ +unit cropedges; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Buttons, nifti_img,ExtCtrls,define_types,crop, Mask; + +type + TCropEdgeForm = class(TForm) + Timer1: TTimer; + ApplyBtn: TSpeedButton; + CancelBtn: TSpeedButton; + LEdit: TRxSpinEdit; + VEdit: TRxSpinEdit; + REdit: TRxSpinEdit; + AEdit: TRxSpinEdit; + PEdit: TRxSpinEdit; + DEdit: TRxSpinEdit; + CropFileSzBtn: TSpeedButton; + SpeedButton1: TSpeedButton; + procedure FormShow(Sender: TObject); + procedure FormHide(Sender: TObject); + procedure CancelBtnClick(Sender: TObject); + procedure ApplyBtnClick(Sender: TObject); + procedure Timer1Timer(Sender: TObject); + procedure ApplyCrop; + procedure ApplyCrop2Img; + procedure CropEditChange(Sender: TObject); + procedure CropFileSzBtnClick(Sender: TObject); + procedure SpeedButton1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + CropEdgeForm: TCropEdgeForm; + +implementation + +uses nifti_img_view, Text; + +{$R *.DFM} + +procedure SmoothRA (var lRA: Doublep; lItems: integer); +var + lRecip: double; + lTempRA,lTempRAUnaligned: Doublep; + lI: integer; +begin + if lItems < 3 then exit; + GetMem(lTempRAUnaligned,(lItems*sizeof(double))+16); + lTempRA := DoubleP($fffffff0 and (integer(lTempRAUnaligned)+15)); + for lI := 1 to lItems do + lTempRA^[lI] := lRA[lI]; + lRecip := 1/3; //multiplies faster than divides + for lI := 2 to (lItems-1) do + lRA^[lI] := (lTempRA[lI-1]+lTempRA[lI]+lTempRA[lI+1])*lRecip; + FreeMem(lTempRAUnaligned); +end; + +function MaxRA (var lRA: Doublep; lStart,lItems: integer): integer; +var + lMax: double; + lI: integer; +begin + result := lStart; + if (lItems < 2) or (lStart >= lItems) or ((lItems-lStart)< 1) then exit; + lMax := lRA^[lStart]; + for lI := lStart to lItems do + if lRA^[lI] > lMax then begin + result := lI; + lMax := lRA^[lI] + end; +end; + +function MinRA (var lRA: Doublep; lStart,lItems: integer): integer; +var + lMin: double; + lI: integer; +begin + result := lStart; + if (lItems < 2) or (lStart >= lItems) or ((lItems-lStart)< 1) then exit; + lMin := lRA^[lStart]; + for lI := lStart to lItems do + if lRA^[lI] < lMin then begin + result := lI; + lMin := lRA^[lI] + end; +end; + + + + +function VentralClip (var lDorsalCrop,lVentralCrop: integer; lPct: integer): boolean; +var + lSliceMax: double; + lSliceSum,lSliceSumUnaligned: Doublep; + lXY,lZ,lSlices,lSliceSz,lSliceStart,lVentralMaxSlice,lMaxSlice,lMinSlice,lGap: integer; +begin + result := false; + lDorsalCrop := 0; + lVentralCrop := 0; + if (lPct < 1) or (lPct > 100) then + exit; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (gBGImg.ScrnDim[3] < 2) or (gBGImg.ScrnMM[3] = 0) then begin + showmessage('Please load a 3D background image for neck removal.'); + exit; + end; + if not gBGImg.resliced then begin + //showmessage('Neck removal can only be done on resliced images.'); + exit; + end; + lSlices := gBGImg.ScrnDim[3]; + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + GetMem(lSliceSumUnaligned,(lSlices*sizeof(double))+16); + lSliceSum := DoubleP($fffffff0 and (integer(lSliceSumUnaligned)+15)); + lSliceMax := 0; + for lZ := 1 to lSlices do begin + lSliceSum^[lZ] := 0; + lSliceStart := (lZ-1)*lSliceSz; + for lXY := 1 to lSliceSz do + lSliceSum^[lZ] := lSliceSum^[lZ]+ gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lXY+lSliceStart]; + if lSliceMax < lSliceSum^[lZ] then + lSliceMax := lSliceSum^[lZ]; + end; //for each slice + if lSliceMax = 0 then begin //no data variance + Freemem(lSliceSumUnaligned); + exit; + end; //VolSum = 0 + //next: normalize so each slice is normalized to brightest axial slice + for lZ := 1 to lSlices do + lSliceSum^[lZ] := lSliceSum^[lZ]/lSliceMax; + result := true; + //next: smooth + SmoothRA(lSliceSum,lSlices); + //next - top cropping - removing slices that are <5% of maximum slice + lZ := lSlices; + while (lZ > 1) and (lSliceSum^[lZ] < (lPct/100)) do + dec(lZ); + lDorsalCrop := lSlices-lZ; + //next findMax + lMaxSlice := MaxRA(lSliceSum,1,lSlices); + //next - ensure there is at least 60mm from max to bottom of an image - enough spine to worry about + lVentralMaxSlice := lMaxSlice-round(60/abs(gBGImg.ScrnMM[3])); + if lVentralMaxSlice < 1 then + exit; + lVentralMaxSlice := MaxRA(lSliceSum,1,lVentralMaxSlice); + //finally: find minima between these two points... + lMinSlice := MinRA(lSliceSum,lVentralMaxSlice,lMaxSlice); + lGap := round((lMaxSlice-lMinSlice)*0.35); + if (lMinSlice-lGap) > 1 then begin + result := true; + lVentralCrop := lMinSlice-lGap; + end; + //fx(lVentralCrop,lDorsalCrop); + //next show output... + {TextForm.Memo1.Lines.Clear; + for lZ := 1 to lSlices do + TextForm.Memo1.Lines.add(inttostr(lZ)+','+floattostr(lSliceSum^[lZ])); + TextForm.Show; } + //cleanup + Freemem(lSliceSumUnaligned); +end; + +function LRClip (var lLCrop,lRCrop:integer; lPct,lDClip,lVClip: integer): boolean; +//amount of image to crop from left/right for N% signal intensity +var + lSliceMax: double; + lSliceSum,lSliceSumUnaligned: Doublep; + lZmin,lZmax,lX,lY,lZ,lSlices,lSliceSz,lSliceStart: integer; +begin + result := false; + lLCrop := 0; + lRCrop := 0; + if (lPct < 1) or (lPct > 100) then + exit; + lZMin := lVClip; + lZMax := gBGImg.ScrnDim[3]-lDClip; + SortInt(lZMin,lZMax); + lZMin := Bound(lZMin,1,gBGImg.ScrnDim[3]); + lZMax := Bound(lZMax,1,gBGImg.ScrnDim[3]); + if lZMin >= lZMax then + exit; + + + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (gBGImg.ScrnDim[1] < 2) or (gBGImg.ScrnDim[2] < 2) or (gBGImg.ScrnDim[3] < 2) then begin + showmessage('Please load a 3D background image for neck removal.'); + exit; + end; + if not gBGImg.resliced then begin + showmessage('Neck removal can only be done on resliced images.'); + exit; + end; + + lSlices := gBGImg.ScrnDim[1]; + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + GetMem(lSliceSumUnaligned,(lSlices*sizeof(double))+16); + lSliceSum := DoubleP($fffffff0 and (integer(lSliceSumUnaligned)+15)); + lSliceMax := 0; + for lX := 1 to lSlices do begin + lSliceSum^[lX] := 0; + for lZ := {1 to gBGImg.ScrnDim[3]} lZMin to lZMax do begin + lSliceStart := lX+ ((lZ-1)*lSliceSz); + for lY := 1 to gBGImg.ScrnDim[2] do begin + lSliceSum^[lX] := lSliceSum^[lX]+ gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lSliceStart]; + lSliceStart := lSliceStart + gBGImg.ScrnDim[1]; + end; + end; + //for lYZ := 1 to lSliceSz do + // lSliceSum^[lZ] := lSliceSum^[lZ]+ gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lXY+lSliceStart]; + if lSliceMax < lSliceSum^[lX] then + lSliceMax := lSliceSum^[lX]; + end; //for each slice + if lSliceMax = 0 then begin //no data variance + Freemem(lSliceSumUnaligned); + exit; + end; //VolSum = 0 + //next: smooth + SmoothRA(lSliceSum,lSlices); + //next: normalize so each slice is normalized to brightest axial slice + for lX := 1 to lSlices do + lSliceSum^[lX] := lSliceSum^[lX]/lSliceMax; + //next - Left cropping- removing slices that are <5% of maximum slice + lX := lSlices; + while (lX > 1) and (lSliceSum^[lX] < (lPct/100)) do + dec(lX); + lRCrop := lSlices-lX; + //next - Left cropping- removing slices that are <5% of maximum slice + lX := 1; + while (lX <= lSlices) and (lSliceSum^[lX] < (lPct/100)) do + inc(lX); + lLCrop := lX-1; + //fx(lLCrop,lRCrop); + result := true; + Freemem(lSliceSumUnaligned); +end; + +function APClip (var lACrop,lPCrop: integer; lPct,lDClip,lVClip: integer): boolean; +//amount of image to crop from anterior/posterior for 5% signal intensity +var + lSliceMax: double; + lSliceSum,lSliceSumUnaligned: Doublep; + lZMin,lZMax,lX,lY,lZ,lSlices,lSliceSz,lSliceStart: integer; +begin + result := false; + lACrop := 0; + lPCrop := 0; + lZMin := lVClip; + lZMax := gBGImg.ScrnDim[3]-lDClip; + SortInt(lZMin,lZMax); + lZMin := Bound(lZMin,1,gBGImg.ScrnDim[3]); + lZMax := Bound(lZMax,1,gBGImg.ScrnDim[3]); + if lZMin >= lZMax then + exit; + if (lPct < 1) or (lPct > 100) then + exit; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (gBGImg.ScrnDim[1] < 2) or (gBGImg.ScrnDim[2] < 2) or (gBGImg.ScrnDim[3] < 2) then begin + showmessage('Please load a 3D background image for neck removal.'); + exit; + end; + if not gBGImg.resliced then begin + showmessage('Neck removal can only be done on resliced images.'); + exit; + end; + lSlices := gBGImg.ScrnDim[2]; + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + //lCoroSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[3]; + GetMem(lSliceSumUnaligned,(lSlices*sizeof(double))+16); + lSliceSum := DoubleP($fffffff0 and (integer(lSliceSumUnaligned)+15)); + lSliceMax := 0; + for lY := 1 to lSlices do begin + lSliceSum^[lY] := 0; + //lSliceStart := lY; + for lZ := {1 to gBGImg.ScrnDim[3]} lZMin to lZMax do begin + lSliceStart := ((lY-1)* gBGImg.ScrnDim[1])+ ((lZ-1)*lSliceSz); + if lSliceStart > (lSliceSz*gBGImg.ScrnDim[3]) then + showmessage('xx'); + for lX := 1 to gBGImg.ScrnDim[1] do + lSliceSum^[lY] := lSliceSum^[lY]+ gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lSliceStart+lX]; + end; //for lZ + //for lYZ := 1 to lSliceSz do + // lSliceSum^[lY] := lSliceSum^[lY]+ gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lXY+lSliceStart]; + if lSliceMax < lSliceSum^[lY] then + lSliceMax := lSliceSum^[lY]; + end; //for each slice + if lSliceMax = 0 then begin //no data variance + Freemem(lSliceSumUnaligned); + exit; + end; //VolSum = 0 + //next: smooth + SmoothRA(lSliceSum,lSlices); + //next: normalize so each slice is normalized to brightest axial slice + for lY := 1 to lSlices do + lSliceSum^[lY] := lSliceSum^[lY]/lSliceMax; + //next - Left cropping- removing slices that are <5% of maximum slice + lY := lSlices; + while (lY > 1) and (lSliceSum^[lY] < (lPct/100)) do + dec(lY); + lACrop := lSlices-lY; + //next - Left cropping- removing slices that are <5% of maximum slice + lY := 1; + while (lY <= lSlices) and (lSliceSum^[lY] < (lPct/100)) do + inc(lY); + lPCrop := lY-1; + result := true; + Freemem(lSliceSumUnaligned); +end; + + + +procedure TCropEdgeForm.ApplyCrop2Img; +var + lZLo,lZHi,lXLo,lXHi,lYLo,lYHi,lPos,lX,lY,lZ: integer; + l32Buf : SingleP; + l16Buf : SmallIntP; +begin + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferItems<1) then exit; + if (gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ImgBufferItems then begin + Showmessage('Can not crop edges of a rotated image.'); + exit; + end; + lXlo := round(LEdit.value); + lXHi := gBGImg.ScrnDim[1] - round(REdit.value); + lYlo := round(PEdit.value); + lYHi := gBGImg.ScrnDim[2] - round(AEdit.value); + lZLo := round(VEdit.value); + lZHi := gBGImg.ScrnDim[3] - round(DEdit.value); + lPos := 0; + case gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP of + 1: begin + for lZ := 1 to gBGImg.ScrnDim[3] do + for lY := 1 to gBGImg.ScrnDim[2] do + for lX := 1 to gBGImg.ScrnDim[1] do begin + inc(lPos); + if (lZ >= lZHi) or (lZ <= lZLo) or(lY >= lYHi) or (lY <= lYLo) or (lX >= lXHi) or (lX <= lXLo) then + gMRIcroOverlay[kBGOverlayNum].ImgBuffer[lPos] := 0; + end; //for X + end; + 2: begin + //fx(gMRIcroOverlay[kBGOverlayNum].ImgBufferItems); + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lZ := 1 to gBGImg.ScrnDim[3] do + for lY := 1 to gBGImg.ScrnDim[2] do + for lX := 1 to gBGImg.ScrnDim[1] do begin + inc(lPos); + if (lZ >= lZHi) or (lZ <= lZLo) or(lY >= lYHi) or (lY <= lYLo) or (lX >= lXHi) or (lX <= lXLo) then + l16Buf[lPos] := 0; + end; //for X + end; + 4: begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lZ := 1 to gBGImg.ScrnDim[3] do + for lY := 1 to gBGImg.ScrnDim[2] do + for lX := 1 to gBGImg.ScrnDim[1] do begin + inc(lPos); + if (lZ >= lZHi) or (lZ <= lZLo) or(lY >= lYHi) or (lY <= lYLo) or (lX >= lXHi) or (lX <= lXLo) then + l32Buf[lPos] := 0; + end; //for X + end; + else begin showmessage('Unsupported data type'); end + end; //case + ImgForm.RescaleImagesTimer.Enabled := true; +end; + +procedure TCropEdgeForm.ApplyCrop; +var + lZLo,lZHi,lXLo,lXHi,lYLo,lYHi,lPos,lX,lY,lZ: integer; +begin + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems<>gBGImg.VOIUndoVolItems) then exit; + if gBGImg.VOIUndoVolItems <> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then exit; + if (gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then exit; + //xx Move(gBGImg.VOIUndoVol^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVolItems); + FillChar(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVolItems,0); + lXlo := round(LEdit.value); + lXHi := gBGImg.ScrnDim[1] - round(REdit.value); + lYlo := round(PEdit.value); + lYHi := gBGImg.ScrnDim[2] - round(AEdit.value); + lZLo := round(VEdit.value); + lZHi := gBGImg.ScrnDim[3] - round(DEdit.value); + lPos := 0; + for lZ := 1 to gBGImg.ScrnDim[3] do + for lY := 1 to gBGImg.ScrnDim[2] do + for lX := 1 to gBGImg.ScrnDim[1] do begin + inc(lPos); + if (lZ >= lZHi) or (lZ <= lZLo) or(lY >= lYHi) or (lY <= lYLo) or (lX >= lXHi) or (lX <= lXLo) then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := kVOI8bit; + end; //for X + //gBGImg.VOIchanged := true; + ImgForm.RefreshImagesTimer.enabled := true; +end; + +var +vFirst: boolean = true; + +procedure TCropEdgeForm.FormShow(Sender: TObject); +var + lV,lD,lA,lP,lL,lR: integer; +begin + EnsureVOIOpen; + CreateUndoVol; + CropEdgeForm.ModalResult := mrCancel; + lD := 0; + lV := 0; + lL := 0; + lR := 0; + lA := 0; + lP := 0; + if VentralClip (lD,lV,2) then + if LRClip (lL,lR,2,lD,lV) then + APClip (lA,lP,2,lD,lV); + if vFirst then begin + VEdit.Value := lV; + DEdit.value := lD; + LEdit.Value := lL; + REdit.value := lR; + AEdit.Value := lA; + PEdit.value := lP; + vFirst := false; + end; + CropEditChange(nil); +end; + +procedure TCropEdgeForm.FormHide(Sender: TObject); +begin + //if (CropEdgeForm.ModalResult = mrCancel) then + UndoVolVOI; + if not (CropEdgeForm.ModalResult = mrCancel) then + ApplyCrop2Img + else + ImgForm.RefreshImagesTimer.Enabled := true; + ImgForm.CloseVOIClick(nil); +end; + + + +procedure TCropEdgeForm.CancelBtnClick(Sender: TObject); +begin + CropEdgeForm.close; +end; + +procedure TCropEdgeForm.ApplyBtnClick(Sender: TObject); +begin + CropEdgeForm.ModalResult := mrOK; + CropEdgeForm.close; +end; + +procedure TCropEdgeForm.Timer1Timer(Sender: TObject); +begin + Timer1.Enabled := false; + ApplyCrop; +end; + +procedure TCropEdgeForm.CropEditChange(Sender: TObject); +begin + if not CropEdgeForm.visible then exit; + Timer1.Enabled := true; +end; + +procedure TCropEdgeForm.CropFileSzBtnClick(Sender: TObject); +var + lV,lD,lA,lP,lL,lR: integer; +begin + lV := VEdit.AsInteger; + lD := DEdit.AsInteger; + lL := LEdit.AsInteger; + lR := REdit.AsInteger; + lA := AEdit.AsInteger; + lP := PEdit.AsInteger; + CropNIfTI(lL,lR,lA,lP,lD,lV); + CancelBtn.Click; +end; + +procedure TCropEdgeForm.SpeedButton1Click(Sender: TObject); +begin + //GrowNeck ('C:\walker\tpm.nii', -30); + GrowNeck ('C:\MATLAB\spm8\templates\T1.nii', -30); +end; + +end. diff --git a/niftiview7/cutout.pas b/niftiview7/cutout.pas new file mode 100755 index 0000000..bd14442 --- /dev/null +++ b/niftiview7/cutout.pas @@ -0,0 +1,206 @@ +unit cutout; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Buttons,nifti_img_view,nifti_img,define_types; +const + kMaxFrac = 1000;//e.g. if 100 then cutouts are done by percent, if 1000 then 0.001 +type + TCutoutForm = class(TForm) + OKBtn: TSpeedButton; + SpeedButton1: TSpeedButton; + CutoutBox: TGroupBox; + Label2: TLabel; + Label1: TLabel; + Label3: TLabel; + Label5: TLabel; + Label6: TLabel; + Xlo: TRxSpinEdit; + XHi: TRxSpinEdit; + YLo: TRxSpinEdit; + YHi: TRxSpinEdit; + ZLo: TRxSpinEdit; + ZHi: TRxSpinEdit; + CutoutBiasDrop: TComboBox; + cutoutlutdrop: TComboBox; + DefBtn: TSpeedButton; + RenderCutoutCheck: TCheckBox; + PreviewBtn: TSpeedButton; + procedure OKBtnClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure PreviewClick(Sender: TObject); + procedure Prep; + procedure DefBtnClick(Sender: TObject); + procedure RenderCutoutCheckClick(Sender: TObject); + procedure PreviewBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + CutoutForm: TCutoutForm; + +implementation + +uses render,render_composite; +var gInit: boolean; + + +{$R *.DFM} + + + +procedure TCutoutForm.OKBtnClick(Sender: TObject); +begin + CutoutForm.close; +end; + +procedure TCutoutForm.Prep; +begin + gInit := true; + CutoutForm.caption := 'Cutouts: '+inttostr(kMaxFrac)+'= 100%'; + cutoutlutdrop.Items := ImgForm.LUTdrop.items; + if (gRender.cutoutLUTindex < 1) or (gRender.cutoutLUTindex > cutoutlutdrop.Items.Count) then + cutoutlutdrop.itemindex := 0 + else + cutoutlutdrop.itemindex := gRender.cutoutLUTindex; + if gRender.CutoutFrac.Lo[1] < 0 then + SliceToFrac(gBGImg); + SortCutout(gRender.CutoutFrac); + Xlo.maxValue := kMaxFrac;//gBGImg.ScrnDim[1]; + Xhi.maxValue := kMaxFrac;//gBGImg.ScrnDim[1]; + Ylo.maxValue := kMaxFrac;//gBGImg.ScrnDim[2]; + Yhi.maxValue := kMaxFrac;//gBGImg.ScrnDim[2]; + Zlo.maxValue := kMaxFrac;//gBGImg.ScrnDim[3]; + Zhi.maxValue := kMaxFrac;//gBGImg.ScrnDim[3]; + Xlo.Value := gRender.CutoutFrac.Lo[1]; + Xhi.Value := gRender.CutoutFrac.Hi[1]; + Ylo.Value := gRender.CutoutFrac.Lo[2]; + Yhi.Value := gRender.CutoutFrac.Hi[2]; + Zlo.Value := gRender.CutoutFrac.Lo[3]; + Zhi.Value := gRender.CutoutFrac.Hi[3]; + //OverlayClipEdit.value := gRender.OverlayNearClipFrac; + //BGClipEdit.value := gRender.BGNearClipFrac; + RenderCutoutCheck.checked := gRender.ShowCutout; + CutoutBiasDrop.ItemIndex:=( gRender.CutoutBias); + RenderCutoutCheckClick(nil); + gInit := false; +end; + +procedure TCutoutForm.FormShow(Sender: TObject); +begin +Prep; +end; + +procedure ReadCutoutForm; +begin + with CutoutForm do begin + gRender.CutoutFrac.Lo[1] := round(Xlo.Value); + gRender.CutoutFrac.Hi[1] := round(Xhi.Value); + gRender.CutoutFrac.Lo[2] := round(Ylo.Value); + gRender.CutoutFrac.Hi[2] := round(Yhi.Value); + gRender.CutoutFrac.Lo[3] := round(Zlo.Value); + gRender.CutoutFrac.Hi[3] := round(Zhi.Value); + SortCutout(gRender.CutoutFrac); + gRender.ShowCutout := RenderCutoutCheck.checked; + gRender.CutoutBias := CutoutBiasDrop.ItemIndex; + gRender.cutoutLUTindex := cutoutlutdrop.itemindex; + //gRender.OverlayNearClipFrac := round(OverlayClipEdit.value); + // gRender.BGNearClipFrac := round(BGClipEdit.value); + + end; +end; + +(*procedure TCutoutForm.FormClose(Sender: TObject; var Action: TCloseAction); +var + lCutout : TCutOut; + lRenderCutoutCheck,lChange : boolean; + lCutoutBiasDrop,lInc: integer; +begin + lCutout := gRender.Cutout; + lRenderCutoutCheck := gRender.ShowCutout; + lCutoutBiasDrop := gRender.CutoutBias; + ReadCutoutForm; + //next: do not render if no changes... + lChange := false; + if (gRender.ShowCutout <> lRenderCutoutCheck) or (lCutoutBiasDrop <> CutoutBiasDrop.ItemIndex) then + lChange := true; + for lInc := 1 to 3 do + if (gRender.Cutout.Lo[lInc] <> lCutout.Lo[lInc]) or + (gRender.Cutout.Hi[lInc] <> lCutout.Hi[lInc]) then + lChange := true; + if not lChange then exit; + //note: exit if no changes + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end;*) + +procedure TCutoutForm.FormClose(Sender: TObject; var Action: TCloseAction); +begin + ReadCutoutForm; + //note: exit if no changes + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end; + + + +procedure TCutoutForm.DefBtnClick(Sender: TObject); +begin + gInit := true; + if renderForm.FlipLRcheck.checked then begin + Xlo.Value := 0; + Xhi.Value := kMaxFrac shr 1; + + end else begin + Xlo.Value := kMaxFrac shr 1; + Xhi.Value := kMaxFrac ; + end; + Ylo.Value := kMaxFrac shr 1; + Yhi.Value := kMaxFrac ; + Zlo.Value := kMaxFrac shr 1; + Zhi.Value := kMaxFrac ; + //OverlayClipEdit.value := 0; + //BGClipEdit.value := 0; + RenderCutoutCheck.checked := true; + CutoutLUTdrop.ItemIndex := 0; + CutoutBiasDrop.ItemIndex:= 3; + RenderForm.AzimuthEdit.value := 120; + RenderForm.ElevationEdit.value := 45; + gInit := false; + RenderCutoutCheckClick(nil);//PreviewClick(nil); +end; + +procedure TCutoutForm.RenderCutoutCheckClick(Sender: TObject); +begin + CutoutBox.visible := RenderCutoutCheck.Checked; + PreviewClick(nil); +end; + +procedure TCutoutForm.PreviewClick(Sender: TObject); +begin + if gInit then + exit; + ReadCutoutForm; + gZoom := 0.5; + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end; + +procedure TCutoutForm.PreviewBtnClick(Sender: TObject); +//preview at normal resolution +begin + if gInit then + exit; + ReadCutoutForm; + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; + +end; + +end. diff --git a/niftiview7/define_types.pas b/niftiview7/define_types.pas new file mode 100755 index 0000000..a19bf2c --- /dev/null +++ b/niftiview7/define_types.pas @@ -0,0 +1,1109 @@ +unit define_types; + +interface +{$IFDEF LINUX} +uses + SysUtils,QDialogs,QControls; +{$ELSE} +uses + delphiselectfolder,DiskSpaceKludge,Windows,SysUtils,Dialogs,Controls,classes,GZio,IniFiles; +{$ENDIF} +{$H+} +const + NaN : double = 1/0; + //kImgFilter = 'Neuroimage (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz;*.head;*.nrrd;*.nhdr;*.mgh;*.mgz;*.mha;*.mhd|Volume of interest (*.voi)|*.voi'; + //kImgPlusVOIFilter = 'NIfTI/Analyze/VOI|*.hdr;*.nii;*.nii.gz;*.voi;*.head;*.nrrd;*.nhdr;*.mgh;*.mgz;*.mha;*.mhd|NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi|Other|*.head;*.nrrd;*.nhdr;*.mgh;*.mgz;*.mha;*.mhd'; + kImgPlusVOIFilter = 'Neuroimaging/VOI|*.hdr;*.nii;*.nii.gz;*.voi;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd|NIfTI/Analyze Header (*.hdr;*.nii)|*.hdr;*.nii;*.nii.gz|Volume of interest (*.voi)|*.voi|Anything (*.*)|*.*'; + kImgFilter = 'Neuroimaging|*.hdr;*.nii;*.nii.gz;*.HEAD;*.mgh;*.mgz;*.mha;*.mhd;*.nhdr;*.nrrd|Volume of interest (*.voi)|*.voi'; + kTxtFilter = 'Text (*.txt)|*.txt|Comma Separated (*.csv)|*.csv'; + kHistoBins = 256;//numbers of bins for histogram/image balance + PixelCountMax = 32768; + kTab = chr(9); + kEsc = chr(27); + kCR = chr (13); + kBS = #8 ; { Backspace } + kDel = #127 ; { Delete } + kTextSep = kTab;//','; //',' for CSV, kTab for Tab-delimited values + + UNIXeoln = chr(10); + kLUTalpha = 128; + kVOI8bit = 1;//May07 +{$IFDEF LINUX} + PathDelim = '/'; +{$ELSE} + PathDelim = '\'; +{$ENDIF} + +type + TStrRA = Array of String; + TPSPlot = RECORD //peristimulus plot + TRSec,BinWidthSec: single; + nNegBins,nPosBins,SPMDefaultsStatsFmriT,SPMDefaultsStatsFmriT0: integer; + TextOutput,GraphOutput, + SliceTime,SavePSVol,BaselineCorrect,PctSignal,RemoveRegressorVariability,TemporalDeriv,PlotModel,Batch: boolean + end; + TStretchQuality = (sqLow, sqHigh ); + TLUT = array[0..255] of TRGBQuad; + kStr20 = string[20]; + kStr50 = string[50]; + + kStr255 = string[255]; + {TRGBquad = PACKED RECORD + rgbBlue,rgbGreen,rgbRed,rgbreserved: byte; + end; } + TCutout = RECORD + Lo : array [1..3] of integer; + Hi : array [1..3] of integer; + end; + pRGBQuadArray = ^TRGBQuad; + TRGBQuadeArray = ARRAY[0..PixelCountMax-1] OF TRGBQuad; + RGBQuadRA = array [1..1] of TRGBQuad; + RGBQuadp = ^RGBQuadRA; + int32 = LongInt; + uint32 = Cardinal; + int16 = SmallInt; + uint16 = Word; + int8 = ShortInt; + uint8 = Byte; + SingleRA0 = array [0..0] of Single; + Singlep0 = ^SingleRA0; + ByteRA0 = array [0..0] of byte; + Bytep0 = ^ByteRA0; + WordRA0 = array [0..0] of Word; + Wordp0 = ^WordRA0; + SmallIntRA0 = array [0..0] of SmallInt; + SMallIntp0 = ^SmallIntRA0; + LongIntRA0 = array [0..0] of LongInt; + LongIntp0 = ^LongIntRA0; + DWordRA = array [1..1] of DWord; + DWordp = ^DWordRA; + ByteRA = array [1..1] of byte; + Bytep = ^ByteRA; + WordRA = array [1..1] of Word; + Wordp = ^WordRA; + SmallIntRA = array [1..1] of SmallInt; + SMallIntp = ^SmallIntRA; + LongIntRA = array [1..1] of LongInt; + LongIntp = ^LongIntRA; + SingleRA = array [1..1] of Single; + Singlep = ^SingleRA; + DoubleRA = array [1..1] of Double; + Doublep = ^DoubleRA; + DoubleRA0 = array [0..0] of Double; + Doublep0 = ^DoubleRA0; + HistoRA = array [0..kHistoBins] of longint; + HistoDoubleRA = array [0..kHistoBins] of double; + pRGBTripleArray = ^TRGBTripleArray; + TRGBTripleArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple; +function swap64r(s : double):double; +FUNCTION specialsingle (var s:single): boolean; //check if 32-bit float is Not-A-Number, infinity, etc +function FSize (lFName: String): longint; +function FileExistsEX(Name: String): Boolean; +function ParseFileName (lFilewExt:String): string; +function ParseFileFinalDir (lFileName:String): string; +function ExtractFileDirWithPathDelim(lInFilename: string): string; +function PadStr (lValIn, lPadLenIn: integer): string; +function ChangeFileExtX( var lFilename: string; lExt: string): string; +function swap4r4i (s:single): longint; //swap and convert: endian-swap and then typecast 32-bit float as 32-bit integer +function conv4r4i (s:single): longint; //convert: typecast 32-bit float as 32-bit integer +function swap8r(s : double):double; //endian-swap 64-bit float +procedure pswap4i(var s : LongInt); //procedure to endian-swap 32-bit integer +procedure pswap4r ( var s:single); //procedure to endian-swap 32-bit integer +function specialdouble (d:double): boolean; +function RealToStr(lR: double {was extended}; lDec: integer): string; +procedure UnGZip (var lFname: string; var lBuf: ByteP{}; lOffset,lMaxSz: integer); //unzip +procedure UnGZip2 (var lFname: string; var lBuf: ByteP; lOffset,lMaxSz, lUncompressedInitialBytes: integer); //unzip +procedure UnGZipCore (var infile : gzFile; var lBuf: ByteP; lReadBytes: integer; lWrite: boolean); +function UpCaseExt(lFileName: string): string; +procedure swap4(var s : LongInt); +procedure Xswap4r ( var s:single); +function Bool2Char (lBool: boolean): char; +function Char2Bool (lChar: char): boolean; +function Log(X, Base: single): single; +procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +//procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer); +function DiskFreeEx (DriveStr: String): Integer; +procedure SortSingle(var lLo,lHi: single); +function IniInt(lIniFile: TIniFile; lIdent: string; lDefault: integer): integer; +function IniBool(var lIniFile: TIniFile; lIdent: string; lDefault: boolean): boolean; +procedure CopyFileEX (lInName,lOutName: string); +procedure CopyFileEXoverwrite (lInName,lOutName: string); +procedure fx (a: double); overload; +procedure fx (a,b: double); overload; +procedure fx (a,b,c: double); overload; +procedure fx (a,b,c,d: double); overload; +function ChangeFilePostfixExt (lInName,lPostfix,lExt: string): string; +function Bound (lDefault,lMin,lMax: integer): integer; +procedure SortInt (var lMin,lMax: integer); +function ChangeFilePrefix (lInName,lPrefix: string): string; +//function Mod1(lVal,lDiv: integer): integer; //returns 1..n instead of 0..[n-1] - e.g. mod1(360,180)=180 not 0 +//function Div1(lVal,lMod: integer): integer; //for input 1..inifinity, returns 1..lMod,1..lMod,1..lMod usage: Y coordinates +procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +function freeRam: Int64; +function OKMsg(lMsg: string): boolean; //shows dialog with OK/Cancel returns true if user presses OK +function DirExists (lDir: String): boolean; +function IsExtNIFTIHdr(lStr: string): boolean; +function GetDirPrompt (lDefault: string): string; +function GzExt(lFileName: string): boolean; + +implementation + +function GzExt(lFileName: string): boolean; +var lExt: string; +begin + lExt := UpCaseExt(lFilename); + if (lExt = '.VOI') or (lExt = '.NII.GZ') or (lExt = '.GZ') then + result := true + else + result := false; +end; + +function GetDirPrompt (lDefault: string): string; +// Old versions of Delphi have a clumsy SelectDirectory function, and locks the folder until you quit your application... +var + lD: string; +begin + lD := lDefault; + if not DirExists(lD) then + lD := 'c:\'; + result := lD; // Set the starting directory + {$IFDEF FPC} + //Delphi SelectDirectory uses FileCtrl + //Lazarus SelectDirectory uses Dialogs + chdir(result); //start search from previous dir... + if SelectDirectory(result, [sdAllowCreate,sdPerformCreate,sdPrompt], 0) then begin + chdir(result); + exit; + end; + {$ELSE} + if SelectDirectoryDelphi('Select folder', result, true) then + exit; + {$ENDIF} + //if the user aborts, make sure we use the default directory... + result := '';//lD; +end; + +function IsExtNIFTIHdr(lStr: string): boolean; +//detect hdr, nii,niigz +var + lExt: string; +begin + result := false; + lExt := UpCaseExt(lStr); + if (lExt = '.NII') or (lExt = '.NII.GZ') then + result := true; + if (lExt = '.HDR') and (FSize(ChangeFileExt(lStr,'.img'))> 0) then + result := true; + (*if (lExt = '.IMG') and (FSize(ChangeFileExt(lStr,'.hdr'))> 0) then + result := true; *) +end; + +function OKMsg(lMsg: string): boolean; //shows dialog with OK/Cancel returns true if user presses OK +begin + result := false; + case MessageDlg(lMsg, mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: exit; + end; //case + result := true; +end; + +function DirExists (lDir: String): boolean; +var lSearchRec: TSearchRec; +begin + FindFirst(lDir, faAnyFile, lSearchRec); + if (faDirectory and lSearchRec.attr) = faDirectory then + DirExists := true + else + DirExists := false; + FindClose(lSearchRec);{} +end; + +procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +var lInc,lSwap: integer; +begin + for lInc := 1 to 3 do + if lCutout.Lo[lInc] > lCutout.Hi[lInc] then begin + lSwap := lCutout.Lo[lInc]; + lCutout.Lo[lInc] := lCutout.Hi[lInc]; + lCutout.Hi[lInc] := lSwap; + end; +end; + +function ChangeFilePrefix (lInName,lPrefix: string): string; +var + lC,lLen,lPos: integer; + lStr: string; +begin + //result := changefileext(lInName,lExt); + result := lInName; + lLen := length (result); + if lLen < 1 then exit; + lPos := lLen; + while (lPos > 1) and (result[lPos] <> pathdelim) do + dec(lPos); + lStr := ''; + for lC := 1 to lPos do + lStr := lStr+result[lC]; + lStr := lStr+lPrefix; + if lPos < lLen then + for lC := (lPos+1) to lLen do + lStr := lStr+result[lC]; + result := lStr; +end; + +procedure SortInt (var lMin,lMax: integer); +var + lSwap: integer; +begin + if lMin <= lMax then + exit; + lSwap := lMax; + lMax := lMin; + lMin := lSwap; +end; + +function Bound (lDefault,lMin,lMax: integer): integer; +begin + result := lDefault; + if result < lMin then + result := lMin; + if result > lMax then + result := lMax; +end; + +procedure fx (a: double); overload; //fx used to help debugging - reports number values +begin + showmessage(floattostr(a)); +end; + +procedure fx (a,b: double); overload; //fx used to help debugging - reports number values +begin + showmessage(floattostr(a)+'x'+floattostr(b)); +end; + +procedure fx (a,b,c: double); overload; //fx used to help debugging - reports number values +begin + showmessage(floattostr(a)+'x'+floattostr(b)+'x'+floattostr(c)); +end; + +procedure fx (a,b,c,d: double); overload; //fx used to help debugging - reports number values +begin + showmessage(floattostr(a)+'x'+floattostr(b)+'x'+floattostr(c)+'x'+floattostr(d)); +end; + +function freeRam: Int64; +var + memory:TMemoryStatus; + +begin + memory.dwLength:=sizeof(memory); + GlobalMemoryStatus(memory); + result := memory.dwavailPhys; + //result := 1024; +end; + + +function ChangeFilePostfixExt (lInName,lPostfix,lExt: string): string; +var + lC,lLen,lPos: integer; + lStr: string; +begin + result := changefileext(lInName,lExt); + lLen := length (result); + if lLen < 1 then exit; + lPos := lLen; + while (lPos > 1) and (result[lPos] <> pathdelim) and (result[lPos] <> '.') do + dec(lPos); + if result[lPos] = '.' then + dec(lPos); + lStr := ''; + for lC := 1 to lPos do + lStr := lStr+result[lC]; + lStr := lStr+lPostfix; + if lPos < lLen then + for lC := (lPos+1) to lLen do + lStr := lStr+result[lC]; + result := lStr; +end; + +procedure CopyFileEXoverwrite (lInName,lOutName: string); +var lFSize: Integer; + lBuff: bytep0; + lFData: file; +begin + lFSize := FSize(lInName); + if (lFSize < 1) then exit; + assignfile(lFdata,lInName); + filemode := 0; + reset(lFdata,lFSize{1}); + GetMem( lBuff, lFSize); + BlockRead(lFdata, lBuff^, 1{lFSize}); + closefile(lFdata); + assignfile(lFdata,lOutName); + filemode := 2; + Rewrite(lFdata,lFSize); + BlockWrite(lFdata,lBuff^, 1 {, NumWritten}); + closefile(lFdata); + freemem(lBuff); +end; + +procedure CopyFileEX (lInName,lOutName: string); +var lFSize: Integer; +begin + + lFSize := FSize(lInName); + if (lFSize < 1) or (fileexistsEX(lOutName)) then exit; + CopyFileEXoverwrite (lInName,lOutName); +end; + +function IniInt(lIniFile: TIniFile; lIdent: string; lDefault: integer): integer; +var + lStr: string; +begin + result := lDefault; + lStr := lIniFile.ReadString('INT',lIdent, ''); + if length(lStr) > 0 then + result := StrToInt(lStr); +end; //nested IniInt + +function IniBool(var lIniFile: TIniFile; lIdent: string; lDefault: boolean): boolean; +var + lStr: string; +begin + result := lDefault; + lStr := lIniFile.ReadString('BOOL',lIdent, ''); + //showmessage('x'+lStr+'x'); + if length(lStr) > 0 then + result := Char2Bool(lStr[1]); +end; //nested IniBool + + +procedure SortSingle(var lLo,lHi: single); +var lSwap: single; +begin + if lLo > lHi then begin + lSwap := lLo; + lLo := lHi; + lHi := lSwap; + end; //if Lo>Hi +end; //proc SortSingle + +function DiskFreeEx (DriveStr: String): Integer; +var + lOutDisk: Integer; + lDiskDir : string; + lSize8: Tinteger8; +begin + result := 0; + if length(DriveStr) < 1 then + exit; + lOutDisk := ord(upcase(DriveStr[1]))+1-ord('A'); + if (lOutDisk >= ord('A')) and (lOutDisk <= ord('Z')) then begin + DiskFreeEx := DiskFree(lOutDisk); + end else begin + lDiskDir :=(ExtractFileDrive(DriveStr))+'\'; + lSize8 := DiskFreeStr (lDiskDir); + if lSize8 > MaxINt then DiskFreeEx := MaxInt + else DiskFreeEx := round(lSize8); + end; +end; + +function gz_compressBuffer (lxInBuffer: ByteP;lInSize: integer;outfile:gzFile): integer; +var + len : Integer; + lInBufferPos,ioerr : integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; +function blocktransfer(var lInBuffer: ByteP; lSizeRequested: integer; var lSizeTransferred:integer): integer; +begin + result := 0; + if lInBufferPos > lInSize then begin + result := 666; + exit; + end else if (lInBufferPos + lSizeRequested) <= lInSize then + lSizeTransferred := lSizeRequested + else + lSizeTransferred := lInSize-lInBufferPos; + //for lC := 1 to lSizeTransferred do + // buf[lC-1] := lInBuffer[lInBufferPos+lC] ; + move(lInbuffer[lInBufferPos+1],buf,lSizeTransferred); + //move(src,dest,count); + + lInBufferPos := lInBufferPos+lSizeTransferred; +end; +begin +//showmessage(inttostr(Z_BUFSIZE)); + lInBufferPos := 0; + errorcode := 0; + //Progress := 0; + //fsize := lInSize; + //lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + //lll{$I-}blockread (infile, buf, Z_BUFSIZE, len);{$I+} + ioerr := blocktransfer(lxInBuffer,Z_BUFSIZE, len); + if (ioerr <> 0) then begin + errorcode := 1; + break + end; + if (len = 0) then break; + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + end; {WHILE} + if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3; + result := errorcode; +end; + +procedure GZipBuffer(var FGzipFilename,FFileDestination: String;lxInBuffer: byteP;lInSize: Integer; lOverwritewarn: boolean); +var + FGzipComments ,outmode,s : string; + infile : file; + outfile : gzFile; + FCompressionLevel{,errorcode} : integer; + flags : uInt; + stream : gz_streamp; + p : PChar; +begin +FGzipComments := ''; +//FProgress := 0; +FCompressionLevel := 6;//MainForm.CompressEdit.value; +if (FCompressionLevel > 9) or (FCompressionLevel<0) then FCompressionLevel := 6; + if lOverwritewarn and fileexists(FFileDestination) then begin + case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + id_Abort: exit; + end; + end; + //w adds .gz extension-> outmode := 'w '; + outmode := 'w '; + s := IntToStr(FCompressionLevel); + outmode[2] := s[1]; + outmode[3] := ' '; + (*case FCompressionType of + Standard : outmode[3] := ' '; + HuffmanOnly : outmode[3] := 'h'; + Filtered : outmode[3] := 'f'; + end;*) + //flags := 0; + //if (zfilename in FGzipHeader) then + flags := ORIG_NAME; + //if (comment in FGzipHeader) then flags := flags + COMMENT_; + outfile := gzopenZ (FFileDestination, outmode, flags); + //showmessage(FFileDestination); + if (outfile = NIL) then begin + //if FWindowOnError then + MessageDlg('Can''t open: '+FFileDestination, mtError, [mbAbort], 0); + close( infile); + //errorcode := 2 + exit; + end + else begin + stream := gz_streamp(outfile); + if {(zfilename in FGzipHeader)} true then begin + //s := ExtractFilename(lInFileName); + s := ExtractFilename(FGzipFilename); + p := PChar(s); + blockWrite( stream^.gzfile, p[0], length(s)+1); + stream^.startpos := stream^.startpos + length(s) + 1 + end; + gz_compressBuffer (lxInBuffer,lInSize,outfile); + end +end; + + +(*function gz_compress (var infile:file; outfile:gzFile): integer; +var + len : uInt; + ioerr : integer; + buf : packed array [0..Z_BUFSIZE-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + fsize, lensize : DWord; +begin + errorcode := 0; + //Progress := 0; + fsize := FileSize(infile); + lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + while true do begin + {$I-}blockread (infile, buf, Z_BUFSIZE, len);{$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + errorcode := 1; + break + end; + if (len = 0) then break; + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + (*if FProgressStep > 0 then begin + {$WARNINGS OFF}{Calculate progress and raise event} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end *) +(* end; {WHILE} + closeFile (infile); + if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3; + gz_compress := errorcode; +end; + +procedure GZipFile(lSourceFile: String); +var + //FGzipHeader : THeader; + //FCompressionLevel,FProgress,Progress: integer; + FGzipFilename : string; + FGzipComments : string; + outmode : string; + s,FFileDestination : string; + infile : file; + outfile : gzFile; + FCompressionLevel{,errorcode} : integer; + flags : uInt; + stream : gz_streamp; + p : PChar; + //lProceed: TModalResult; + ioerr : integer; +begin +//FGzipHeader := [zFilename]; +FGzipFilename:= lSourceFile; +FGzipComments := ''; +//FProgress := 0; +FCompressionLevel := 6;//MainForm.CompressEdit.value; +if (FCompressionLevel > 9) or (FCompressionLevel<0) then FCompressionLevel := 6; +//MainForm.ProgressBar1.position :=1; +//Gzip (lFile,lMulti); +//MainForm.ProgressBar1.position := 0; + FFileDestination := lSourceFile+'.gz'; + //result := 2; //return error if user aborts + if fileexists(FFileDestination) then begin + case MessageDlg('Overwrite the file '+FFileDestination+'?', mtConfirmation,[mbYes, mbAbort], 0) of { produce the message dialog box } + id_Abort: exit; + end; + end; + AssignFile (infile, lSourceFile); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + //if FWindowOnError then + MessageDlg('Can''t open: '+lSourceFile, mtError, [mbAbort], 0); + //errorcode := 1 + end + else begin + outmode := 'w '; + s := IntToStr(FCompressionLevel); + outmode[2] := s[1]; + outmode[3] := ' '; + (*case FCompressionType of + Standard : outmode[3] := ' '; + HuffmanOnly : outmode[3] := 'h'; + Filtered : outmode[3] := 'f'; + end;*) +(* + //flags := 0; + //if (zfilename in FGzipHeader) then + flags := ORIG_NAME; + //if (comment in FGzipHeader) then flags := flags + COMMENT_; + outfile := gzopenZ ({FFileDestination}lSourceFile, outmode, flags); + if (outfile = NIL) then begin + //if FWindowOnError then + MessageDlg('Can''t open: '+FFileDestination, mtError, [mbAbort], 0); + close( infile); + //errorcode := 2 + exit; + end + else begin + { if flags are set then write them } + stream := gz_streamp(outfile); + if {(zfilename in FGzipHeader)} true then begin + s := ExtractFilename(lSourceFile); + p := PChar(s); + blockWrite( stream^.gzfile, p[0], length(s)+1); + stream^.startpos := stream^.startpos + length(s) + 1 + end; + {if (zcomment in FGzipHeader) then begin + p := PChar(FGzipComments); + blockWrite( stream^.gzfile, p[0], length(FGzipComments)+1); + stream^.startpos := stream^.startpos + length(FGzipComments) + 1 + end; + { start compressing } + {errorcode :=} gz_compress(infile, outfile); + {if errorcode <> 0 then errorcode := errorcode+100 + else + if FDeleteSource then erase (infile);} + end + end; + //MainForm.ProgressBar1.position := 0; +end; *) + +function Log(X, Base: single): single; +begin + if X = 0 then + result := 0 + else + Log := Ln(X) / Ln(Base); +end; + +function Bool2Char (lBool: boolean): char; +begin + if lBool then + result := '1' + else + result := '0'; +end; + +function Char2Bool (lChar: char): boolean; +begin + if lChar = '1' then + result := true + else + result := false; +end; + + +procedure Xswap4r ( var s:single); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + //1:(float:single); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + inguy.Word1 := outguy.Word1; + inguy.Word2 := outguy.Word2; +end; + + +procedure swap4(var s : LongInt); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + s:=outguy.Long; +end; + +function UpCaseExt(lFileName: string): string; +var lI: integer; +l2ndExt,lExt : string; +begin + lExt := ExtractFileExt(lFileName); + if length(lExt) > 0 then + for lI := 1 to length(lExt) do + lExt[lI] := upcase(lExt[lI]); + result := lExt; + if lExt <> '.GZ' then exit; + lI := length(lFileName) - 6; + if li < 1 then exit; + l2ndExt := upcase(lFileName[lI])+upcase(lFileName[lI+1])+upcase(lFileName[li+2])+upcase(lFileName[li+3]); + if (l2ndExt = '.NII')then + result := l2ndExt+lExt + else if (l2ndExt = 'BRIK') and (lI > 1) and (lFileName[lI-1] = '.') then + result := '.BRIK'+lExt; +end; + +procedure UnGZipCore (var infile : gzFile; var lBuf: ByteP; lReadBytes: integer; lWrite: boolean); +const + BUFLEN = 16384; +var + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } + len,lI,written : integer; +begin + written := 0; + if lReadBytes < 1 then exit; + Len := lReadBytes div BUFLEN; + if Len > 0 then + for lI := 1 to Len do begin + gzread (infile, @buf, BUFLEN {1388}); + if lWrite then + Move(buf,lbuf[Written+1],BUFLEN); + Written := Written + BUFLEN; + end; + Len := lReadBytes mod BUFLEN; + if Len = 0 then exit; + gzread (infile, @buf, Len); + if lWrite then + Move(buf,lbuf[Written+1],len); +end; //ungzipCore + +procedure UnGZip2 (var lFname: string; var lBuf: ByteP; lOffset,lMaxSz, lUncompressedInitialBytes: integer); //unzip +const + BUFLEN = 4096;//16384; +var + infile : gzFile; + lbufsz,len,lI : integer; + written : integer; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } +begin + infile := gzopenZskip (lFName, 'r', 0, lUncompressedInitialBytes); + + written := 0; + if lOffset > 0 then begin //gzseek(infile,lOffset,0); + Len := lOffset div BUFLEN; + if Len > 0 then + for lI := 1 to Len do + gzread (infile, @buf, BUFLEN {1388}); + Len := lOffset mod BUFLEN; + gzread (infile, @buf, Len); + end; + lbufsz := BUFLEN; + if lMaxSz < BUFLEN then + lbufsz := lMaxSz; + while true do begin + len := gzread (infile, @buf, lbufsz); + if (len < 0) then begin + break + end; + if (len = 0) then + break; + if (Written+len) > lMaxSz then begin + if Written < lMaxSz then + Move(buf,lbuf[Written+1],lMaxSz-Written); //cr2007 + break; + end; + Move(buf,lbuf[Written+1],len); + Written := Written + len; + end; {WHILE} + gzclose (infile); +end; + +procedure UnGZip (var lFname: string; var lBuf: ByteP; lOffset,lMaxSz: integer); //unzip +begin + UnGZip2(lFname, lBuf, lOffset,lMaxSz,0); +end; +(*procedure UnGZip (var lFname: string; var lBuf: ByteP; lOffset,lMaxSz: integer); //unzip +const + BUFLEN = 4096;//16384; +var + infile : gzFile; + lbufsz,len,lI : integer; + written : integer; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } +begin + infile := gzopenZ (lFName, 'r', 0); + written := 0; + if lOffset > 0 then begin + Len := lOffset div BUFLEN; + if Len > 0 then + for lI := 1 to Len do + gzread (infile, @buf, BUFLEN {1388}); + Len := lOffset mod BUFLEN; + gzread (infile, @buf, Len); + end; + lbufsz := BUFLEN; + if lMaxSz < BUFLEN then + lbufsz := lMaxSz; + while true do begin + len := gzread (infile, @buf, lbufsz); + if (len < 0) then begin + break + end; + if (len = 0) then + break; + if (Written+len) > lMaxSz then begin + if Written < lMaxSz then + Move(buf,lbuf[Written+1],lMaxSz-Written); //cr2007 + break; + end; + Move(buf,lbuf[Written+1],len); + Written := Written + len; + end; {WHILE} + gzclose (infile); +end; *) + + + +function RealToStr(lR: double {was extended}; lDec: integer): string; +begin + RealTOStr := FloatToStrF(lR, ffFixed,7,lDec); +end; + +FUNCTION specialdouble (d:double): boolean; +//returns true if s is Infinity, NAN or Indeterminate +//8byte IEEE: msb[63] = signbit, bits[52-62] exponent, bits[0..51] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +CONST kSpecialExponent = 2047 shl 20; +VAR Overlay: ARRAY[1..2] OF LongInt ABSOLUTE d; +BEGIN + IF ((Overlay[2] AND kSpecialExponent) = kSpecialExponent) THEN + RESULT := true + ELSE + RESULT := false; +END; + +function swap8r(s : double):double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + try + result:=outguy.float; + except + result := 0; + exit; + end; +end; //func swap8r + +procedure pswap4i(var s : LongInt); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(Long:LongInt); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + s:=outguy.Long; +end; //proc swap4 + +procedure pswap4r ( var s:single); +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + //1:(float:single); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + inguy.Word1 := outguy.Word1; + inguy.Word2 := outguy.Word2; +end; //proc Xswap4r + +function swap64r(s : double):double; +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + 1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + try + swap64r:=outguy.float; + except + swap64r := 0; + exit; + end;{} +end; + +function conv4r4i (s:single): longint; +type + swaptype = packed record + case byte of + 1:(long:longint); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; +begin + inguy := @s; //assign address of s to inguy + conv4r4i:=inguy.long; +end; + +function swap4r4i (s:single): longint; // +type + swaptype = packed record + case byte of + 0:(Word1,Word2 : word); //word is 16 bit + 1:(long:longint); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word2); + outguy.Word2 := swap(inguy^.Word1); + swap4r4i:=outguy.long; +end;//swap4r4i + +function ChangeFileExtX( var lFilename: string; lExt: string): string; +begin + result := ParseFileName(lFilename)+lExt; + //showmessage(ParseFileName(lFilename)); + //result := ChangeFileExt(lFilename,lExt); +end; + +function PadStr (lValIn, lPadLenIn: integer): string; +var lOrigLen,lPad : integer; +begin + lOrigLen := length(inttostr(lValIn)); + result := inttostr(lValIn); + if lOrigLen < lPadLenIn then begin + lOrigLen := lPadLenIn-lOrigLen; + for lPad := 1 to lOrigLen do + result := '0'+result; + end; +end; + +function ExtractFileDirWithPathDelim(lInFilename: string): string; +//F:\filename.ext -> 'F:\' and F:\dir\filename.ext -> 'F:\dir\' +//Despite documentation, Delphi3's ExtractFileDir does not always retain final pathdelim +var lFilePath: string; +begin + result := ''; + lFilePath := ExtractFileDir(lInFilename); + if length(lFilepath) < 1 then exit; + if lFilePath[length(lFilepath)] <> pathdelim then + lFilepath := lFilepath + pathdelim; //Delphi3 bug: sometimes forgets pathdelim + result := lFilepath; +end; + +function ParseFileFinalDir (lFileName:String): string; +var + lLen,lInc,lPos: integer; + lInName,lName: String; +begin + lInName := extractfiledir(lFilename); + lName := ''; + lLen := length(lInName); + if lLen < 1 then exit; + lInc := lLen; + repeat + dec(lInc); + until (lInName[lInc] = pathdelim) or (lInc = 1); + if lInName[lInc] = pathdelim then inc(lInc); //if '\folder' then return 'folder' + for lPos := lInc to lLen do + lName := lName + lInName[lPos]; + ParseFileFinalDir := lName; +end; + +function ParseFileName (lFilewExt:String): string; +var + lExt: string; + i: integer; +begin + lExt := UpCaseExt(lFilewExt); + if (length(lExt) < 1) or (length(lExt) >= length(lFilewExt)) then exit; + result := ''; + for i := 1 to ( length(lFilewExt)- length(lExt)) do + result := result + lFileWExt[i] ; +end; + +Function FileExistsEX(Name: String): Boolean; +var + F: File; +begin + result := false; + if Name = '' then + exit; + result := FileExists(Name); + if result then exit; + //the next bit attempts to check for a file to avoid WinNT bug + AssignFile(F, Name); + {$I-} + Reset(F); + {$I+} + Result:=IOresult = 0; + if Result then + CloseFile(F); +end; + +function FSize (lFName: String): longint; +var SearchRec: TSearchRec; +begin + result := 0; + if not fileexistsex(lFName) then exit; + FindFirst(lFName, faAnyFile, SearchRec); + result := SearchRec.size; + FindClose(SearchRec); +end; + +procedure Xswap8r(var s : double); +type + swaptype = packed record + case byte of + 0:(Word1,Word2,Word3,Word4 : word); //word is 16 bit + //1:(float:double); + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; +begin + inguy := @s; //assign address of s to inguy + outguy.Word1 := swap(inguy^.Word4); + outguy.Word2 := swap(inguy^.Word3); + outguy.Word3 := swap(inguy^.Word2); + outguy.Word4 := swap(inguy^.Word1); + inguy.Word1 := outguy.Word1; + inguy.Word2 := outguy.Word2; + inguy.Word3 := outguy.Word3; + inguy.Word4 := outguy.Word4; +end; + +FUNCTION specialsingle (var s:single): boolean; +//returns true if s is Infinity, NAN or Indeterminate +//4byte IEEE: msb[31] = signbit, bits[23-30] exponent, bits[0..22] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +CONST kSpecialExponent = 255 shl 23; +VAR Overlay: LongInt ABSOLUTE s; +BEGIN + IF ((Overlay AND kSpecialExponent) = kSpecialExponent) THEN + RESULT := true + ELSE + RESULT := false; +END; + +end. diff --git a/niftiview7/delphiselectfolder.pas b/niftiview7/delphiselectfolder.pas new file mode 100755 index 0000000..af71661 --- /dev/null +++ b/niftiview7/delphiselectfolder.pas @@ -0,0 +1,98 @@ +unit delphiselectfolder; + +interface + +function BrowseForFolder(const browseTitle: String; + const initialFolder: String = ''; + mayCreateNewFolder: Boolean = False): String; + +function SelectDirectoryDelphi(const browseTitle: String; var Folder: String; mayCreateNewFolder: Boolean = False): boolean; +implementation + +uses + Windows, Forms, shlobj; + +function SelectDirectoryDelphi(const browseTitle: String; var Folder: String; mayCreateNewFolder: Boolean = False): boolean; +var + lTemp: string; +begin + result := false; + lTemp := BrowseForFolder(browseTitle, Folder, mayCreateNewFolder); + if (lTemp <> '') then begin + Folder := lTemp; + result := true; + end; +// +end; + + + +var + lg_StartFolder: String; + +//////////////////////////////////////////////////////////////////////// +// Call back function used to set the initial browse directory. +//////////////////////////////////////////////////////////////////////// +function BrowseForFolderCallBack(Wnd: HWND; uMsg: UINT; lParam, +lpData: LPARAM): Integer stdcall; +begin + if uMsg = BFFM_INITIALIZED then + SendMessage(Wnd,BFFM_SETSELECTION, 1, Integer(@lg_StartFolder[1])); + result := 0; +end; + +//////////////////////////////////////////////////////////////////////// +// This function allows the user to browse for a folder +// +// Arguments:- +// browseTitle : The title to display on the browse dialog. +// initialFolder : Optional argument. Use to specify the folder +// initially selected when the dialog opens. +// mayCreateNewFolder : Flag indicating whether the user can create a +// new folder. +// +// Returns: The empty string if no folder was selected (i.e. if the user +// clicked cancel), otherwise the full folder path. +//////////////////////////////////////////////////////////////////////// +function BrowseForFolder(const browseTitle: String; + const initialFolder: String =''; + mayCreateNewFolder: Boolean = False): String; +// With later versions of Delphi you may not need these constants. +const + BIF_NEWDIALOGSTYLE=$40; + BIF_NONEWFOLDERBUTTON=$200; + +var + browse_info: TBrowseInfo; + folder: array[0..MAX_PATH] of char; + find_context: PItemIDList; + +begin + //-------------------------- + // Initialise the structure. + //-------------------------- + FillChar(browse_info,SizeOf(browse_info),#0); + lg_StartFolder := initialFolder; + browse_info.pszDisplayName := @folder[0]; + browse_info.lpszTitle := PChar(browseTitle); + browse_info.ulFlags := BIF_RETURNONLYFSDIRS or BIF_NEWDIALOGSTYLE; + if not mayCreateNewFolder then + browse_info.ulFlags := browse_info.ulFlags or BIF_NONEWFOLDERBUTTON; + + browse_info.hwndOwner := Application.Handle; + if initialFolder <> '' then + browse_info.lpfn := BrowseForFolderCallBack; + find_context := SHBrowseForFolder(browse_info); + if Assigned(find_context) then + begin + if SHGetPathFromIDList(find_context,folder) then + result := folder + else + result := ''; + GlobalFreePtr(find_context); + end + else + result := ''; +end; + +end. \ No newline at end of file diff --git a/niftiview7/dicomhdr.pas b/niftiview7/dicomhdr.pas new file mode 100755 index 0000000..f051df9 --- /dev/null +++ b/niftiview7/dicomhdr.pas @@ -0,0 +1,498 @@ +unit dicomhdr; +{$H+} +//Simple dicom to nifti translator +interface +uses +{$IFNDEF FPC}Controls, {$ENDIF} + SysUtils,define_types,classes,nifti_hdr,GraphicsMathLibrary, nifti_types, nifti_foreign; +function NIFTIhdr_LoadDCM (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + +type + kDICOMStr = String[32]; + DICOMdata = record + XYZdim: array [1..4] of integer; + XYZori: array [1..3] of integer; + XYZmm: array [1..3] of double; + Orient: array [1..6] of double; + Float,file4D: boolean; + PatientPosX,PatientPosY,PatientPosZ,AngulationAP,AngulationFH,AngulationRL: double; + TE, TR,IntenScale,IntenIntercept,location{,DTIv1,DTIv2,DTIv3}: single; + {Bval,}SlicesPer3DVol,SiemensInterleaved {0=no,1=yes,2=not defined},SiemensSlices,SiemensMosaicX,SiemensMosaicY, + nDTIdir,AcquNum,ImageNum,SeriesNum,ImageStart,little_endian,Allocbits_per_pixel,SamplesPerPixel, + PatientIDint,CSAImageHeaderInfoPos,CSAImageHeaderInfoSz,ManufacturerID: integer; + PatientPos,PatientName,ProtocolName,StudyDate,StudyTime,PhilipsSliceOrient,PhaseEncoding: kDICOMStr; + Filename: string[255]; +end; + +implementation + +uses dialogs; + +procedure Msg(lStr: string); +begin + Showmessage(lStr); +end; + +procedure clear_dicom_data (var lDicomdata:Dicomdata); +var + lI: integer; +begin + with lDicomData do begin + lDicomData.CSAImageHeaderInfoPos := 0; + lDicomData.CSAImageHeaderInfoSz := 0; + for lI := 1 to 6 do + Orient[lI] := 0; + PatientIDInt := 0; + ManufacturerID := 0; + AngulationFH := 0; + AngulationRL := 0; + AngulationAP := 0; + nDTIdir := 0; + PhilipsSliceOrient := 'NA'; + PhaseEncoding := 'NA'; + PatientPos := 'NA'; + + file4D := false; + PatientName := 'NO NAME'; + StudyDate := ''; + StudyTime := ''; + TR := 0; + TE := 0; + Float := false; + ImageNum := 0; + SlicesPer3DVol := 0; + SiemensInterleaved := 2; //0=no,1=yes,2=undefined + SiemensSlices := 0; + SiemensMosaicX := 1; + SiemensMosaicY := 1; + IntenScale := 1; + IntenIntercept := 0; + SeriesNum := 1; + AcquNum := 0; + ImageNum := 1; + SamplesPerPixel := 1; + XYZmm[1] := 1; + XYZmm[2] := 1; + XYZmm[3] := 1; + XYZdim[1] := 1; + XYZdim[2] := 1; + XYZdim[3] := 1; + XYZdim[4] := 1; + lDicomData.XYZori[1] := 0; + lDicomData.XYZori[2] := 0; + lDicomData.XYZori[3] := 0; + ImageStart := 0; + Little_Endian := 0; + Allocbits_per_pixel := 16;//bits + Location:=0; + PatientPosX := 0;//1392 + PatientPosY := 0;//1392 + PatientPosZ := 0;//1392 + end; +end; + +function NIFTIhdr_LoadDCM (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +var + lDICOMdata: DICOMdata; +const + kMaxBuf = (256*256)-1; //bytes + kMax16bit = (256*256)-1; + kImageType = $0008+($0008 shl 16 ); + kStudyDate = $0008+($0020 shl 16 ); + kStudyTime = $0008+($0030 shl 16 ); + kPatientName = $0010+($0010 shl 16 ); + kSeq = $0018+($0020 shl 16 ); + kZThick = $0018+($0050 shl 16 ); + kTR = $0018+($0080 shl 16 ); + kTE = $0018+($0081 shl 16 ); + kEchoNum = $0018+($0086 shl 16 ); + kZSpacing = $0018+($0088 shl 16 ); + kProtocolName = $0018+($1030shl 16 ); + kPatientPos = $0018+($5100 shl 16 ); + kSeriesNum = $0020+($0011 shl 16 ); + kAcquNum = $0020+($0012 shl 16 ); + kImageNum = $0020+($0013 shl 16 ); + kOrientation = $0020+($0037 shl 16 ); + kLocation = $0020+($1041 shl 16 ); + kDim3 = $0028+($0008 shl 16 ); + kDim2 = $0028+($0010 shl 16 ); + kDim1 = $0028+($0011 shl 16 ); + kXYSpacing = $0028+($0030 shl 16 ); + kPosition = $0020+($0032 shl 16 ); + knVol = $0020+($0105 shl 16 ); + kAlloc = $0028+($0100 shl 16 ); + kIntercept = $0028+($1052 shl 16 ); + kSlope = $0028+($1053 shl 16 ); + kCSAImageHeaderInfo = $0029+($1010 shl 16 ); + kSlicesPer3DVol = $2001+($1018 shl 16 ); + kTransferSyntax = $0002+($0010 shl 16); + kImageStart = $7FE0+($0010 shl 16 ); + kMaxFloats = 6; +var + vr : array [1..2] of Char; + lByteRA: Bytep; + lFloatRA: array [1..kMaxFloats] of double; + lBufferSz,lPos,lFileSz,lBuffStart: integer; + lInFile: file; + lBufferError: boolean; +procedure Str2FloatNum ( lStr: string; lnFloats: integer); +var + lFStr: string; + lP,lnF: integer; +begin + if (length(lStr) < 1) or (lnFloats < 1) or (lnFloats > kMaxFloats) then + exit; + for lnF := 1 to lnFloats do + lFloatRA[lnF] := 1; + lStr := lStr + ' '; //terminator + lFStr := ''; + lP := 1; + lnF:= 0; + while lP <= length(lStr) do begin + if lStr[lP] in ['+','-','0'..'9','.','e','E'] then + lFStr := lFStr + lStr[lP] + else if (lFStr <> '') then begin + inc(lnF); + //if lnFloats = 6 then showmessage(lFStr); + try + lFloatRA[lnF] := strtofloat(lFStr); + except on EConvertError do + lFloatRA[lnF] := 1; + end;//except + if lnF = lnFloats then exit; + lFStr := ''; + end; + inc(lP); + end; +end; //function Str2Float + +function GetByte (lFilePos: integer): byte; +var + lBufPos: integer; +begin + //the following error checking slows down reads a lot! + //a simpler alternative would be to make the buffer size the same size as the entire image... + //the current strategy saves memory and is faster for large images with small headers + if lFilepos > lFileSz then begin + lBufferError := true; + result := 0; + exit; + end; + lBufPos := lFilepos - lBuffStart+1; + if (lBufPos > lBufferSz) or (lBufPos < 1) then begin //reload buffer + if lFilePos+kMaxBuf > lFileSz then + lBufferSz := lFileSz - (lFilePos) + else + lBufferSz := kMaxBuf; //read remaining + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lFilePos); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + FileMode := 2; + lBuffStart := lFilePos; + lBufPos := 1; + end; + result := lByteRA^[lBufPos]; +end; + +function ReadInt4: integer; +begin + if lDicomData.little_endian = 0 then + result := GetByte(lPos+3)+(GetByte(lPos+2) shl 8)+(GetByte(lPos+1) shl 16)+(GetByte(lPos) shl 24) + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24); + inc(lPos,4); +end; //function Read4 + +procedure ReadGroupElementLength(var lGroupElement,lLength: integer); +begin + lGroupElement := ReadInt4; + vr[1] := chr(GetByte(lPos)); + vr[2] := chr(GetByte(lPos+1)); + if vr[2] < 'A' then begin //implicit vr with 32-bit length + lLength := ReadInt4; + exit; + end; + + if (vr = 'UN') {2/2008} or (vr = 'OB') or (vr = 'OW') or (vr = 'SQ') then begin {explicit VR with 32-bit length} + lPos := lPos + 4; {skip 2 byte string and 2 reserved bytes = 4 bytes = 2 words} + lLength := ReadInt4;//Ord4(buf[lPos]) + $100 * (buf[lPos+1] + $100 * (buf[lPos+2] + $100 * buf[lPos+3])) + end else begin {explicit VR with 16-bit length} + if lDicomData.little_endian = 0 then + lLength := (GetByte(lPos+3))+(GetByte(lPos+2) shl 8) + else + lLength := (GetByte(lPos+2))+(GetByte(lPos+3) shl 8);//GetLength := Ord4(buf[i+2]) + $100 * (buf[i+3]); + lPos := lPos + 4; {skip 2 byte string and 2 length bytes = 4 bytes = 2 words} + end; +end; //procedure ReadGroupElementLength + +function DCMStr(lBytes: integer): string; +var + lC: integer; +begin + result := ''; + if lBytes < 1 then + exit; + for lC := lPos to (lPos+(lBytes-1)) do + result := result + char(GetByte(lC)); + for lC := 1 to lBytes do + if result[lC] in ['+','-','/','\',' ','0'..'9','a'..'z','A'..'Z','.'] then + else + result[lC] := ' '; +end; //function DCMStr + +function DCMStr2Int (lBytes: integer): integer; +var lErr: integer; + lStr: string; +begin + lStr := DCMStr(lBytes); + Val(lStr,result,lErr); +end; //function DCMStr2Int + +procedure DCMStr2FloatNum (lBytes,lnFloats: integer); +begin + Str2FloatNum (DCMStr(lBytes), lnFloats); +end; //function DCMStr2Float + +function DCMStr2Float (lBytes: integer): single; +begin + DCMStr2FloatNum (lBytes,1); + result := lFloatRA[1]; +end; //function DCMStr2Float + +procedure DCMStr2Float2 (lBytes: integer; var lF1,lF2: double); +begin + DCMStr2FloatNum (lBytes,3); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; +end; //function DCMStr2Float2 + +procedure DCMStr2Float3 (lBytes: integer; var lF1,lF2,lF3: double); +begin + DCMStr2FloatNum (lBytes,3); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; + lF3 := lFloatRA[3]; +end; //function DCMStr2Float3 + +procedure DCMStr2Float6 (lBytes: integer; var lF1,lF2,lF3,lF4,lF5,lF6: double); +begin + DCMStr2FloatNum (lBytes,6); + lF1 := lFloatRA[1]; + lF2 := lFloatRA[2]; + lF3 := lFloatRA[3]; + lF4 := lFloatRA[4]; + lF5 := lFloatRA[5]; + lF6 := lFloatRA[6]; +end; //function DCMStr2Float6 + +function DCMint (lBytes: integer): integer; //read 16 bit short integer +begin + if lBytes <= 2 then + result := GetByte(lPos)+(GetByte(lPos+1) shl 8) //shortint vs word? + else + result := GetByte(lPos)+(GetByte(lPos+1) shl 8)+(GetByte(lPos+2) shl 16)+(GetByte(lPos+3) shl 24);; //byte order?? +end; //function DCMint + + +var + lTempStr,lStr: string; + lOffset,lTemp,lGroupElement,lLength,lEchoNum,lnVol: integer; + lResearchMode: boolean; + lThick: double; +begin //function fast_read_dicom_data + lOffset := 128; + lnVol := 1; + lEchoNum := 1; + lThick := 0; + clear_dicom_data(lDicomData); + lDicomData.little_endian := 1; + result := false; + lResearchMode := false; + lBufferError := false; + lFileSz := FSize(lFilename); + lBufferSz := lFileSz-lOffset; + if lBufferSz < 512 then begin + //showmessage('Error: File too small '+lFilename); + exit; + end; + if lBufferSz > kMaxBuf then + lBufferSz := kMaxBuf; + GetMem(lByteRA,kMaxBuf); + lBufferSz := lBufferSz; + AssignFile(lInFile, lFileName); + FileMode := 0; //Set file access to read only + Reset(lInFile, 1); + seek(lInFile,lOffset); + BlockRead(lInFile, lByteRA^[1], lBufferSz); + CloseFile(lInFile); + FileMode := 2; + lBuffStart := lOffset; + lPos := lOffset; + if lOffset = 128 then begin //DICOM files start with DICM at 128, Siemens shadow headers do not + if DCMStr(4) <> 'DICM' then begin + //Msg(DCMStr(4)+ ' <> DICM'); + FreeMem(lByteRA); + exit; + end; + lPos := lOffset + 4;//DICM read + end;//Offset = 128 + //next check VR + if not( chr(GetByte(lPos+4)) in ['A'..'Z']) or not( chr(GetByte(lPos+5)) in ['A'..'Z']) then + Msg('implicit VR untested'); + //next check Endian + lTemp := lPos; + ReadGroupElementLength(lGroupElement,lLength); + //if lLength > kMax16bit then + // Msg('ByteSwapped'); + lPos := lTemp; + //end VR check + while (lDICOMData.imagestart = 0) and (not lBufferError) do begin + ReadGroupElementLength(lGroupElement,lLength); + //if (lGroupElement and $FF) > $18 then + // msg(VR+inttohex(lGroupElement,8)+' '+inttostr(lLength)); + case lGroupElement of + kTransferSyntax: begin + lTempStr := (DCMStr(lLength)); + if (length(lTempStr) >= 19) and (lTempStr[19] = '2') then + lDicomData.little_endian := 0; + end; + kImageType : begin + lTempStr := DCMStr(lLength); + //read last word - ver\mosaic -> MOSAIC + lStr := ''; + lTemp := length(lTempStr); + while (lTemp > 0) and (lTempStr[lTemp] in ['a'..'z','A'..'Z']) do begin + lStr := upcase(lTempStr[lTemp])+lStr; + dec(lTemp); + end; + if lStr = 'MOSAIC' then + lDicomData.SiemensMosaicX := 2; //we need to read numaris for details... + end; + + kStudyDate: lDicomData.StudyDate := DCMStr(lLength); + kStudyTime : lDicomData.StudyTime := DCMStr(lLength); + kPatientName : lDicomData.PatientName := DCMStr(lLength); + kProtocolName : lDicomData.ProtocolName :=DCMStr(lLength); + kPatientPos : lDicomData.PatientPos :=DCMStr(lLength); //should be HFS for Siemens = Head First Supine + kSeriesNum : lDicomData.SeriesNum := DCMStr2Int(lLength); + kAcquNum : lDicomData.AcquNum := DCMStr2Int(lLength); + kSeq: begin + if DCMStr(lLength) = 'RM' then + lResearchMode := True; + end; + kImageNum : lDicomData.ImageNum := DCMStr2Int(lLength); + kDim3 :lDicomData.XYZdim[3] := DCMStr2Int(lLength); + kDim2 : lDicomData.XYZdim[2] := DCMint (lLength); + kDim1 : lDicomData.XYZdim[1] := DCMint (lLength); + kLocation : lDICOMData.Location := DCMStr2Float(lLength); + kAlloc: lDicomData.Allocbits_per_pixel := DCMint (lLength); + kTR : lDicomData.TR := DCMStr2Float(lLength); + kTE: lDicomData.TE := DCMStr2Float(lLength); + kEchoNum: lEchoNum := round (DCMStr2Float(lLength)); + kSlope : lDICOMData.IntenScale := DCMStr2Float(lLength); + kIntercept : lDICOMData.IntenIntercept := DCMStr2Float(lLength); + kOrientation : DCMStr2Float6(lLength, lDicomData.Orient[1], lDicomData.Orient[2],lDicomData.Orient[3],lDicomData.Orient[4], lDicomData.Orient[5],lDicomData.Orient[6]); + kPosition : DCMStr2Float3 (lLength,lDicomData.PatientPosX, lDicomData.PatientPosY,lDicomData.PatientPosZ); + knVol: lnVol := round (DCMStr2Float(lLength)); + kZThick: begin lThick := DCMStr2Float(lLength); lDICOMData.XYZmm[3] := lThick; end;//used differently by manufacturers + kZSpacing: begin lDICOMData.XYZmm[3] := DCMStr2Float(lLength); + if (lThick/2) > lDICOMdata.XYZmm[3] then + lDICOMdata.XYZmm[3] := lDICOMdata.XYZmm[3] + lThick + end; //used different by different manufacturers + kXYSpacing: DCMStr2Float2 (lLength, lDICOMdata.XYZmm[2], lDICOMdata.XYZmm[1]); + (*kCSAImageHeaderInfo: begin //order ICE,Acq,Num,Vector + lDICOMdata.CSAImageHeaderInfoPos := lPos; + lDICOMdata.CSAImageHeaderInfoSz := lLength; + end; *) + kSlicesPer3DVol: lDICOMData.SlicesPer3DVol := DCMint (lLength); + kImageStart: lDICOMData.ImageStart := lPos ; //-1 as indexed from 0.. not 1.. + + end; //Case lGroupElement + //Msg(VR+inttohex(lGroupElement and kMax16bit,4) +':'+inttohex( lGroupElement shr 16,4)+' '+inttostr(lLength)+'@'+inttostr(lPos) ); + lPos := lPos + (lLength); + end; //while imagestart=0 and not error + + //clean up + if (lDicomData.SiemensMosaicX > 1) then + lDicomData.AcquNum := 1; + if (lEchoNum > 1) and (lEchoNum < 16) then + lDicomData.AcquNum := lDicomData.AcquNum + (100*lEchoNum); + if lResearchMode then + lDicomData.SeriesNum := lDicomData.SeriesNum + 100; + if (lDICOMData.SlicesPer3DVol > 0) and (lnVol > 1) and (lDicomdata.XYZdim[3] > 1) and (lDicomData.SlicesPer3DVol > 0)and ((lDicomdata.XYZdim[3] mod lDicomData.SlicesPer3DVol) = 0) then + lDICOMdata.File4D := true; + + if not lBufferError then + result := true; + FreeMem(lByteRA); + + if result then begin + lHdr.HdrFileName:= lFilename; + lHdr.ImgFileName:= lFilename; + lHdr.NIfTItransform := false;//Analyze + case lDicomData.Allocbits_per_pixel of + 8: lHdr.NiftiHdr.datatype := kDT_UNSIGNED_CHAR; + 16: lHdr.NiftiHdr.datatype := kDT_SIGNED_SHORT; + 32: begin + if lDicomdata.Float then + lHdr.NiftiHdr.datatype := kDT_SIGNED_INT + else + lHdr.NiftiHdr.datatype := kDT_FLOAT; // float (32 bits/voxel) + end; + else begin + Msg('Unsupported DICOM bit-depth : +inttostr(lDicomData.Allocbits_per_pixel.'); + result := false; + + end; + end; + lHdr.NIFTIhdr.vox_offset := lDicomData.ImageStart; + lHdr.NIFTIhdr.bitpix := lDicomData.Allocbits_per_pixel; + lHdr.NIFTIhdr.pixdim[1] := lDicomdata.XYZmm[1]; + lHdr.NIFTIhdr.pixdim[2] := lDicomdata.XYZmm[2]; + lHdr.NIFTIhdr.pixdim[3] := lDicomdata.XYZmm[3]; + NII_SetIdentityMatrix(lHdr.NIFTIhdr); + + lHdr.NIFTIhdr.dim[1] := lDicomdata.XYZdim[1]; + lHdr.NIFTIhdr.dim[2] := lDicomdata.XYZdim[2]; + lHdr.NIFTIhdr.dim[3] := lDicomdata.XYZdim[3]; + lHdr.NIFTIhdr.dim[4] := lDicomdata.XYZdim[4]; + if lHdr.NIFTIhdr.dim[4] < 2 then + lHdr.NIFTIhdr.dim[0] := 3 + else + lHdr.NIFTIhdr.dim[0] := 4; + lHdr.NIFTIhdr.qform_code := kNIFTI_XFORM_UNKNOWN; + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_UNKNOWN; + //test - input estimated orientation matrix + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT ; + lHdr.NIFTIhdr.srow_x[0] := lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[1] := lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[2] := lHdr.NIFTIhdr.pixdim[3]; + + lHdr.NIFTIhdr.srow_x[3] := (lHdr.NIFTIhdr.dim[1] /2)*-lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[3] := (lHdr.NIFTIhdr.dim[2] /2)*-lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[3] := (lHdr.NIFTIhdr.dim[3] /2)*-lHdr.NIFTIhdr.pixdim[3]; + //fx(lHdr.NIFTIhdr.srow_z[3],lOri[3]); + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); //Warning: some of the NIFTI float values that do exist as integer values in Analyze may have bizarre values like +INF, -INF, NaN + lHdr.NIFTIhdr.toffset := 0; + lHdr.NIFTIhdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.NIFTIhdr.dim_info := kNIFTI_SLICE_SEQ_UNKNOWN + (kNIFTI_SLICE_SEQ_UNKNOWN shl 2) + (kNIFTI_SLICE_SEQ_UNKNOWN shl 4); //Freq, Phase and Slie all unknown + lHdr.NIFTIhdr.xyzt_units := kNIFTI_UNITS_UNKNOWN; + lHdr.NIFTIhdr.slice_duration := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p1 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p2 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p3 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.pixdim[0] := 1; //QFactor should be 1 or -1 + lHdr.DiskDataNativeEndian := odd(lDicomData.little_endian); + lHdr.NIFTIHdr.magic := kNIFTI_MAGIC_DCM; + end; +end; //function NIFTIhdr_LoadDCM + + +end. diff --git a/niftiview7/dilate.pas b/niftiview7/dilate.pas new file mode 100755 index 0000000..39397b1 --- /dev/null +++ b/niftiview7/dilate.pas @@ -0,0 +1,570 @@ +unit dilate; + +interface +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Buttons,define_types,nifti_img_view,nifti_img, Mask, ReadInt; + +procedure BatchDilate; +procedure MakeShells; +procedure DilateVOI(lDilateMM: single; var lVOI: bytep); +//function DilateOpenVOI(lDilateMM, lMaskDilateMM: single; lMaskWithBG: boolean): boolean; + +implementation +uses text, nifti_hdr_view, readfloat; + +procedure DilateVOI(lDilateMM: single; var lVOI: bytep); +var + lBuff: bytep; + lSqrDilateMM,lXmm,lYmm,lZmm: single; + lPos,lZ,lY,lX,lCycle,lSliceSz,lI,lXDim,lYDim,lZDim,lPlanes,lImgSz: integer; + lXVox,lYVox,lZVox: integer; +procedure Paint (lxx,lyy,lzz: integer); +//only VOI if voxel has a VOI and distance is less than lDilateMM from origin... +var + lDx: single; + lPos2: integer; +begin + lPos2 := lxx + ((lyy-1)*lXDim)+((lzz-1)*lSliceSz); + if lVOI^[lPos2] <> 0 then + exit; //already painted + lDx := (sqr((lxx-lx)*lXmm)+sqr((lyy-ly)*lYmm)+sqr((lzz-lz)*lZmm)); + if lDx > lSqrDilateMM then + exit; + lVOI^[lPos2] := kVOI8bit; +end; + +procedure PaintNeighbors; +var + i,lxx,lyy,lzz: integer; + lBox: TCutout; +begin + //range to check + lBox.Lo[1] := lX - lXVox; + lBox.Lo[2] := lY - lYVox; + lBox.Lo[3] := lZ - lZVox; + lBox.Hi[1] := lX + lXVox; + lBox.Hi[2] := lY + lYVox; + lBox.Hi[3] := lZ + lZVox; + for i := 1 to 3 do + if lBox.Lo[i] < 1 then + lBox.Lo[i] := 1; + if lBox.Hi[1] > lXDim then + lBox.Hi[1] := lXDim; + if lBox.Hi[2] > lYDim then + lBox.Hi[2] := lYDim; + if lBox.Hi[3] > lZDim then + lBox.Hi[3] := lZDim; + //we will check each voxel in sphere until we find a VOI... + for lzz := lBox.Lo[3] to lBox.Hi[3] do + for lyy := lBox.Lo[2] to lBox.Hi[2] do + for lxx := lBox.Lo[1] to lBox.Hi[1] do + Paint (lxx,lyy,lzz); +end; +begin + if (lDilateMM< 1) then begin + //ShowMessage('Must dilate at least one voxel.'); + Exit; + end; + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lSliceSz := lXdim * lYdim; + lXmm := gBGImg.Scrnmm[1]; + lYmm := gBGImg.Scrnmm[2]; + lZmm := gBGImg.Scrnmm[3]; + lSqrDilateMM := Sqr(lDilateMM); + lXVox := abs(round(lDilateMM/lXmm)); + lYVox := abs(round(lDilateMM/lYmm)); + lZVox := abs(round(lDilateMM/lZmm)); + lImgSz := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lImgSz < 1 then exit; + getmem(lBuff,lImgSz); + Move(lVOI^,lBuff^, lImgSz); + lPos := 0; + for lZ := 1 to lZDim do begin + for lY := 1 to lYDim do begin + for lX := 1 to lXDim do begin + inc(lPos); + if lBuff^[lPos] = kVOI8bit then + PaintNeighbors; + end;//X + end; //Y + end;//Z + //Move(lBuff^,lVOI^,lImgSz); + freemem(lBuff); +end; + +function DilateOpenVOI(lDilateMM, lMaskDilateMM: single; lMaskWithBG: boolean): boolean; +var + lStartTime: DWord; + lVOImask: bytep; + lI,lImgSz: integer; +begin + result := false; + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + if lMaskDilateMM > lDilateMM then begin + ShowMessage('Error: mask-dilation can not be bigger than primary dilation.'); + exit; + end; + if lDilateMM <= 0 then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + lStartTime := GetTickCount; + lImgSz := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lImgSz < 1 then exit; + CreateUndoVol;//create gBGImg.VOIUndoVol + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol[lI] <> 0 then + gBGImg.VOIUndoVol[lI] := kVOI8bit; + //getmem(lVOI,lImgSz); + //Move(gBGImg.VOIUndoVol^,lVOI^, lImgSz); + DilateVOI(lDilateMM, gBGImg.VOIUndoVol); + //freemem(lVOI); + if lMaskDilateMM >= 0 then begin + getmem(lVOImask,lImgSz); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lVOImask^, lImgSz); + DilateVOI(lMaskDilateMM, lVOImask); + for lI := 1 to lImgSz do + if lVOImask[lI] <> 0 then + gBGImg.VOIUndoVol^[lI] := 0; + freemem(lVOImask); + end; //mask using dilated value... + if lMaskWithBG then + for lI := 1 to lImgSz do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lI] = 0 then + gBGImg.VOIUndoVol^[lI] := 0; + ImgForm.StatusLabel.caption :=('Dilation time(ms): '+inttostr(GetTickCount-lStartTime)); + gBGImg.VOIchanged := true; + // ImgForm.ProgressBar1.Position := 0; + ImgForm.Undo1Click(nil); //show smoothed buffer + result := true; +end; + +(*procedure DilateOpenVOI(lDilateMM: single; lMaskWithOriginal,lMaskWithBG: boolean); +var + lBuff: bytep; + lStartTime: DWord; + lSqrDilateMM,lXmm,lYmm,lZmm: single; + lPos,lZ,lY,lX,lCycle,lSliceSz,lI,lXDim,lYDim,lZDim,lPlanes,lImgSz: integer; + lXVox,lYVox,lZVox: integer; +procedure Paint (lxx,lyy,lzz: integer); +//only VOI if voxel has a VOI and distance is less than lDilateMM from origin... +var + lDx: single; + lPos2: integer; +begin + lPos2 := lxx + ((lyy-1)*lXDim)+((lzz-1)*lSliceSz); + if gBGImg.VOIUndoVol[lPos2] <> 0 then + exit; //already painted + lDx := (sqr((lxx-lx)*lXmm)+sqr((lyy-ly)*lYmm)+sqr((lzz-lz)*lZmm)); + if lDx > lSqrDilateMM then + exit; + gBGImg.VOIUndoVol[lPos2] := kVOI8bit; +end; + +procedure PaintNeighbors; +var + i,lxx,lyy,lzz: integer; + lBox: TCutout; +begin + //range to check + lBox.Lo[1] := lX - lXVox; + lBox.Lo[2] := lY - lYVox; + lBox.Lo[3] := lZ - lZVox; + lBox.Hi[1] := lX + lXVox; + lBox.Hi[2] := lY + lYVox; + lBox.Hi[3] := lZ + lZVox; + for i := 1 to 3 do + if lBox.Lo[i] < 1 then + lBox.Lo[i] := 1; + if lBox.Hi[1] > lXDim then + lBox.Hi[1] := lXDim; + if lBox.Hi[2] > lYDim then + lBox.Hi[2] := lYDim; + if lBox.Hi[3] > lZDim then + lBox.Hi[3] := lZDim; + //we will check each voxel in sphere until we find a VOI... + for lzz := lBox.Lo[3] to lBox.Hi[3] do + for lyy := lBox.Lo[2] to lBox.Hi[2] do + for lxx := lBox.Lo[1] to lBox.Hi[1] do + Paint (lxx,lyy,lzz); +end; + + +begin + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lXmm := gBGImg.Scrnmm[1]; + lYmm := gBGImg.Scrnmm[2]; + lZmm := gBGImg.Scrnmm[3]; + lSqrDilateMM := Sqr(lDilateMM); + lXVox := abs(round(lDilateMM/lXmm)); + lYVox := abs(round(lDilateMM/lYmm)); + lZVox := abs(round(lDilateMM/lZmm)); + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + if (lDilateMM< 1) then begin + ShowMessage('Must dilate at least one voxel.'); + Exit; + end; + lImgSz := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lImgSz < 1 then exit; + CreateUndoVol;//create gBGImg.VOIUndoVol + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + //set all voxels to 1 or zero + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol[lI] <> 0 then + gBGImg.VOIUndoVol[lI] := kVOI8bit; + lStartTime := GetTickCOunt; + lSliceSz := lXdim * lYdim; + getmem(lBuff,lImgSz); + Move(gBGImg.VOIUndoVol^,lBuff^, lImgSz); + lPos := 0; + for lZ := 1 to lZDim do begin + for lY := 1 to lYDim do begin + for lX := 1 to lXDim do begin + inc(lPos); + if lBuff[lPos] = kVOI8bit then + PaintNeighbors; + end;//X + end; //Y + end;//Z + if lMaskWithOriginal then + for lI := 1 to lImgSz do + if lBuff[lI] <> 0 then + gBGImg.VOIUndoVol[lI] := 0; + freemem(lBuff); + if lMaskWithBG then + for lI := 1 to lImgSz do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lI] = 0 then + gBGImg.VOIUndoVol[lI] := 0; + ImgForm.StatusLabel.caption :=('Dilation time(ms): '+inttostr(GetTickCount-lStartTime)); + gBGImg.VOIchanged := true; + // ImgForm.ProgressBar1.Position := 0; + ImgForm.Undo1Click(nil); //show smoothed buffer +end; + *) + +(*procedure BatchDilate; +var + lInc,lNumberofFiles: integer; + lPrefix,lOutname,lFilename,lBGname:string; + lMaskBG,lPref: boolean; + lDilateMM,lMaskDilateMM: single; +begin + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + lDilateMM := ReadFloatForm.GetFloat('VOI dilation (mm). ', 0,8,9999); + if lDilateMM <= 0 then begin + showmessage('Error: dilation in mm must be positive'); + exit; + end; + lMaskDilateMM := ReadFloatForm.GetFloat('Dilated rim? mm, -1 for none ', -1,0,lDilateMM); + lMaskBG := false; + case MessageDlg('Mask output with background image?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lMaskBG := true; + end; //case + if not OpenDialogExecute(kImgFilter,'Select background image (mask, e.g. gray matter mask)',false) then exit; + lBGname:= HdrForm.OpenHdrDlg.Filename; + if not OpenDialogExecute(kImgPlusVOIFilter,'Select VOIs',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + lPref := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + ImgForm.OpenAndDisplayImg(lBGname,false); + lPrefix := 'd'+inttostr(round(lDilateMM))+'m'+inttostr(round(lMaskDilateMM)); + if lMaskBG then + lPrefix := lPrefix+'b'; + if not InputQuery('Output filename prefix','Enter prefix for filenames', lPrefix) then + exit; + for lInc:= 1 to lNumberofFiles do begin + FreeImgMemory(gMRIcroOverlay[kVOIOverlayNum]); + ImgForm.UpdateLayerMenu; + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + ImgForm.OpenVOICore(lFilename); + DilateOpenVOI(lDilateMM,lMaskDilateMM,lMaskBG); + lOutname := ChangeFilePrefix(lFilename,lPrefix{'m'}); + SaveAsVOIorNIFTIcore (lOutname, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + gBGImg.VOIchanged := false; + end;//lLoop + gBGImg.ResliceOnLoad := lPref; +end; *) +function MeanInten (lOverlayNum: integer; var lVol: integer): double; +var + lINc: integer; + lSum: double; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 2 then + exit; + lSum := 0; + lVol := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then begin + inc(lVol); + lSum := lSum+ RawBGIntensity(lInc); + end; //if VOI voxel + end; //for each voxel + if lVol < 1 then + exit; + result := lSum/lVol; + result := Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],result); +end; + +function MeanIntenGtrZero (lOverlayNum: integer; var lVol: integer): double; +var + lINc: integer; + lSum: double; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 2 then + exit; + lSum := 0; + lVol := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if (gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0) and (RawBGIntensity(lInc) > 0) then begin + inc(lVol); + lSum := lSum+ RawBGIntensity(lInc); + end; //if VOI voxel + end; //for each voxel + if lVol < 1 then + exit; + result := lSum/lVol; + result := Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],result); +end; + +procedure ExportInten (lOverlayNum: integer); +const + kStatSep = kTab; +var + lINc: integer; + lStr: string; +begin + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems < 2 then + exit; + lStr := 'RawData'; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then begin + TextForm.MemoT.Lines.add( floattostr(Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],RawBGIntensity(lInc)))+kStatSep); + end; //if VOI voxel + end; //for each voxel +end; + +procedure BatchDilate; +label + 888; +const + kMaxDilate = 12; + kStatSep = kTab; +var + lMean,lMeanGtrZero: double; + lVol,lnDilate,lInc,lDilate: integer; + lBasename,lPrefix,lOutname,lBGname,lVOIname,lPERFName:string; + lMaskBG,lPref: boolean; + lDilateMM: array [1..kMaxDilate] of single; +begin + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + lnDilate := ReadIntForm.GetInt('Number of dilation sizes ', 2,8,kMaxDilate); + if (lnDilate < 2 ) or (lnDilate > kMaxDilate) then + exit; + for lInc := 1 to lnDilate do + lDilateMM[lInc] := ReadFloatForm.GetFloat(inttostr(lInc)+ ' VOI dilation (mm). ', 0,lINc*3,9999); + for lInc := 2 to lnDilate do begin + if (lDilateMM[lInc-1] >= lDilateMM[lInc]) then begin + Showmessage('Error: dilation sizes should specified be in ascending order'); + exit; + end; + end; + case MessageDlg('Mask output with background image?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lMaskBG := true; + end; //case + if lMaskBG then begin + if not OpenDialogExecute(kImgFilter,'Select background image (mask, e.g. gray matter mask)',false) then exit; + lBGname:= HdrForm.OpenHdrDlg.Filename; + end else + lBGName := ''; + lPref := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + TextForm.MemoT.Lines.clear; +repeat + if not OpenDialogExecute(kImgPlusVOIFilter,'Select VOI',false) then goto 888; + lVOIname := HdrForm.OpenHdrDlg.Filename; + if not OpenDialogExecute(kImgFilter,'Select PERF image',false) then goto 888; + lPerfName := HdrForm.OpenHdrDlg.Filename; + if lMaskBG then + lBaseName := lBGname + else + lBaseName := lPerfName; + + TextForm.MemoT.Lines.add( 'Mask'+kStatSep+'VOI'+kStatSep+'Perf'+kStatSep+'Outputname'+kStatSep+'MinDilate'+kStatSep+'MaxDilate'+kStatSep+'Volume[vox]'+kStatSep+'MeanIntensity'+kStatSep+'MeanIntensity>0'); + for lDilate := 1 to (lnDilate-1) do begin + ImgForm.OpenAndDisplayImg(lBaseName,false); + lPrefix := inttostr(lDilate); + FreeImgMemory(gMRIcroOverlay[kVOIOverlayNum]); + ImgForm.UpdateLayerMenu; + ImgForm.OpenVOICore(lVOIname); + DilateOpenVOI(lDilateMM[lDilate+1],lDilateMM[lDilate],lMaskBG); + if gBGImg.Mirror then + MirrorScrnBuffer(gBGImg, gMRIcroOverlay[kVOIOverlayNum]); //April 2011 + + lOutname := ChangeFilePrefix(lVOIname,lPrefix); + SaveAsVOIorNIFTIcore (lOutname, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + gBGImg.VOIchanged := false; + ImgForm.OpenAndDisplayImg(lPerfName,false); + FreeImgMemory(gMRIcroOverlay[kVOIOverlayNum]); + ImgForm.OpenVOICore(lOutname); + lMean := MeanInten (kVOIOverlayNum,lVol); + lMeanGtrZero := MeanIntenGtrZero (kVOIOverlayNum,lVol); + TextForm.MemoT.Lines.add( lBGname+kStatSep+lVOIname+kStatSep+lPerfName+kStatSep+lOutname+kStatSep+floattostr(lDilateMM[lDilate])+kStatSep+floattostr(lDilateMM[lDilate+1]) + +kStatSep+inttostr(lVol)+kStatSep+floattostr(lMean)+kStatSep+floattostr(lMeanGtrZero)); + // ExportInten(kVOIOverlayNum); + //ImgForm.ShowDescriptive(kVOIOverlayNum,false); + end;//lLoop +until false; +888: + gBGImg.ResliceOnLoad := lPref; + TextForm.Show; +end; +(*procedure BatchDilate; +label + 888; +const + kMaxDilate = 12; + kStatSep = kTab; +var + lMean: double; + lVol,lnDilate,lInc,lDilate: integer; + lBasename,lPrefix,lOutname,lBGname,lVOIname,lPERFName:string; + lMaskBG,lPref: boolean; + lDilateMM: array [1..kMaxDilate] of single; +begin + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + lnDilate := ReadIntForm.GetInt('Number of dilation sizes ', 2,3,kMaxDilate); + if (lnDilate < 2 ) or (lnDilate > kMaxDilate) then + exit; + for lInc := 1 to lnDilate do + lDilateMM[lInc] := ReadFloatForm.GetFloat(inttostr(lInc)+ ' VOI dilation (mm). ', 0,lINc*3,9999); + for lInc := 2 to lnDilate do begin + if (lDilateMM[lInc-1] >= lDilateMM[lInc]) then begin + Showmessage('Error: dilation sizes should specified be in ascending order'); + exit; + end; + end; + case MessageDlg('Mask output with background image?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lMaskBG := true; + end; //case + if lMaskBG then begin + if not OpenDialogExecute(kImgFilter,'Select background image (mask, e.g. gray matter mask)',false) then exit; + lBGname:= HdrForm.OpenHdrDlg.Filename; + end else + lBGName := ''; + lPref := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + TextForm.MemoT.Lines.clear; +repeat + if not OpenDialogExecute(kImgPlusVOIFilter,'Select VOI',false) then goto 888; + lVOIname := HdrForm.OpenHdrDlg.Filename; + if not OpenDialogExecute(kImgFilter,'Select PERF image',false) then goto 888; + lPerfName := HdrForm.OpenHdrDlg.Filename; + if lMaskBG then + lBaseName := lBGname + else + lBaseName := lPerfName; + TextForm.MemoT.Lines.add( 'Mask'+kStatSep+'VOI'+kStatSep+'Perf'+kStatSep+'Outputname'+kStatSep+'MinDilate'+kStatSep+'MaxDilate'+kStatSep+'Volume[vox]'+kStatSep+'MeanIntensity'); + for lDilate := 1 to (lnDilate-1) do begin + ImgForm.OpenAndDisplayImg(lBaseName,false); + lPrefix := inttostr(lDilate); + FreeImgMemory(gMRIcroOverlay[kVOIOverlayNum]); + ImgForm.UpdateLayerMenu; + ImgForm.OpenVOICore(lVOIname); + DilateOpenVOI(lDilateMM[lDilate+1],lDilateMM[lDilate],lMaskBG); + lOutname := ChangeFilePrefix(lVOIname,lPrefix); + SaveAsVOIorNIFTIcore (lOutname, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + gBGImg.VOIchanged := false; + ImgForm.OpenAndDisplayImg(lPerfName,false); + FreeImgMemory(gMRIcroOverlay[kVOIOverlayNum]); + ImgForm.OpenVOICore(lOutname); + lMean := MeanInten (kVOIOverlayNum,lVol); + TextForm.MemoT.Lines.add( lBGname+kStatSep+lVOIname+kStatSep+lPerfName+kStatSep+lOutname+kStatSep+floattostr(lDilateMM[lDilate])+kStatSep+floattostr(lDilateMM[lDilate+1]) + +kStatSep+inttostr(lVol)+kStatSep+floattostr(lMean)); + ExportInten(kVOIOverlayNum); + + //ImgForm.ShowDescriptive(kVOIOverlayNum,false); + end;//lLoop +until false; +888: + gBGImg.ResliceOnLoad := lPref; + TextForm.Show; +end; *) + +{$DEFINE noTESTSHELL} +procedure MakeShells; +const + kMaxDilate = 24; + kStatSep = kTab; +var + lFilename,lOutname : string; + lV,lnDilate,lInc: integer; + lDilateMM: array [0..kMaxDilate] of single; +begin + {$IFDEF TESTSHELL} + HdrForm.OpenHdrDlg.Files.Clear; + HdrForm.OpenHdrDlg.Files.Add('c:\Voimskog3.voi'); + lnDilate := 2; + lDilateMM[0] := 0; + lDilateMM[1] := 6; + lDilateMM[2] := 12; + {$ELSE} + if not OpenDialogExecute(kImgPlusVOIFilter,'Select VOI[s] to dilate',true) then + exit; + lnDilate := ReadIntForm.GetInt('Number of dilation shells ', 2,3,kMaxDilate); + if (lnDilate < 2 ) or (lnDilate > kMaxDilate) then + exit; + lDilateMM[0] := ReadFloatForm.GetFloat(inttostr(lInc)+ 'Dilated shell 1s inner edge for dilated shell (mm). ', 0,1,9999); + for lInc := 1 to lnDilate do + lDilateMM[lInc] := ReadFloatForm.GetFloat(inttostr(lInc)+ 'Dilated shell '+inttostr(lInc)+'s outer edge (mm). ', 0,lDilateMM[lInc-1]+3,9999); + + {$ENDIF} + if HdrForm.OpenHdrDlg.Files.Count < 1 then + exit; + + for lV := 1 to HdrForm.OpenHdrDlg.Files.Count do begin //vcx + lFilename := HdrForm.OpenHdrDlg.Files[lV-1]; + ImgForm.OpenAndDisplayImg(lFileName,false); + + for lInc := 1 to lnDilate do begin + ImgForm.OpenVOICore(lFilename); + DilateOpenVOI(lDilateMM[lInc], lDilateMM[lInc-1],false); + //ImgForm.Undo1Click(nil); //show smoothed buffer + lOutname := ChangeFilePrefix(lFilename,inttostr(lInc)); + //SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lOutname); + if gBGImg.Mirror then + MirrorScrnBuffer(gBGImg, gMRIcroOverlay[kVOIOverlayNum]); + SaveAsVOIorNIFTIcore (lOutname, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kVOIOverlayNum].NiftiHdr); + gBGImg.VOIchanged := false; + + end;//for each dilate + end; //for each voi + ImgForm.OpenAndDisplayImg(lOutName,false); + +end; //proc makeshells + +end. diff --git a/niftiview7/draw_interpolate_slices.pas b/niftiview7/draw_interpolate_slices.pas new file mode 100755 index 0000000..a0cbe05 --- /dev/null +++ b/niftiview7/draw_interpolate_slices.pas @@ -0,0 +1,156 @@ +unit draw_interpolate_slices; +//USED by stats to select only regions with a given number of connected/contiguous voxels +interface +uses define_types, Classes, SysUtils; + + +function Interpolate_Slices (var lVol: bytep; lX,lY,lZ, lOrient:integer; var lNotes: TStringList): boolean; + + +implementation + +procedure Smooth_Slice (var lSlice: array of single; lX,lY: integer); +var + lSliceVox,lVox,lxx,lyy: integer; + lSliceOrig: array of single; +begin + if (lX <3) or (lY < 3) then exit; + lSliceVox := lX * lY; + SetLength(lSliceOrig, lSliceVox); + //lSliceOrig := Copy(lSlice, Low(lSlice), Length(lSlice)); //really clean, but unnecessary + move(lSlice[0],lSliceOrig[0],sizeof(lSlice)); // it works + lVox := 0; + for lyy := 1 to lY do begin + for lxx := 1 to lX do begin + if (lyy > 1) and (lyy < lY) and (lxx > 1) and (lxx < lX) then begin //not on edges + lSlice[lVox] := ((4*lSliceOrig[lVox])+(2*lSliceOrig[lVox+1])+ (2*lSliceOrig[lVox-1])+ + (2*lSliceOrig[lVox+lX])+ (2*lSliceOrig[lVox-lX])+ + (lSliceOrig[lVox+lX+1])+ (lSliceOrig[lVox-lX+1])+ (lSliceOrig[lVox+lX-1])+ (lSliceOrig[lVox-lX-1]) + )/16; + end; + inc(lVox); + end;//each column X + end; //each row Y +end; + +procedure Binarize_Slice(var lVol: bytep; lX,lY,lSliceTarget,lMax: integer); +var + lThresh,lSliceVox,lVox,lOffset: integer; +begin + lThresh := lMax div 2; + lSliceVox := lX * lY; + lOffset := lSliceVox * lSliceTarget; + for lVox := 1 to lSliceVox do + if (lVol[lVox+lOffset] > lThresh) then + lVol[lVox+lOffset] := lMax + else + lVol[lVox+lOffset] := 0; + +end; + +procedure Interpolate_Slice (var lVol: bytep; lX, lY, lSliceLo,lSliceTarget,lSliceHi: integer); +//e.g. if lowSlice = 0, targetSlice = 1 and highSlice=4 we will interpolate a new slice 1 weighted mostly by slice 0 with some influence of slice 4 +var + lSliceVox,lVox,lOffsetLo,lOffset,lOffsetHi: integer; + lFracLo,lFracHi: single; + lSlice: array of single; +begin + lSliceVox := lX * lY; + SetLength(lSlice, lSliceVox); + lFracHi := (lSliceTarget-lSliceLo)/ (lSliceHi-lSliceLo); //weighting from top slice + lFracLo := 1 - lFracHi; //weighting from lower slice + lOffsetLo := lSliceVox * lSliceLo; + lOffset := lSliceVox * lSliceTarget; + lOffsetHi := lSliceVox * lSliceHi; + for lVox := 1 to lSliceVox do + lSlice[lVox-1] := (lFracLo * lVol[lVox+lOffsetLo])+ (lFracHi * lVol[lVox+lOffsetHi]) ; + + Smooth_Slice (lSlice, lX,lY); + for lVox := 1 to lSliceVox do + lVol[lVox+lOffset] := round(lSlice[lVox-1]); +end; + +function Interpolate_SlicesAx (var lVol: bytep; lX,lY,lZ:integer; var lNotes: TStringList): boolean; +var + lSliceVox,lVox, lSlice, lSliceOffset,lBottomDrawnSlice,lTopDrawnSlice,lLastDrawnSlice,lNextDrawnSlice,lS,lMax:integer; + lSliceDrawn: array of boolean; + lGaps: boolean; +begin + result := false; + if (lZ < 3) or (lX < 3) or (lY <3) then exit; + //Determine which slices are already drawn + lSliceVox := lX * lY; + SetLength(lSliceDrawn, lZ); + // + lBottomDrawnSlice := maxint; + lTopDrawnSlice := -1; + for lSlice := 0 to (lZ-1) do begin + lSliceDrawn[lSlice] := false; + lVox := 0; + lSliceOffset := (lSlice * lSliceVox); + repeat + inc(lVox); + if (lVol[lVox+lSliceOffset] > 0) then lSliceDrawn[lSlice] := true; + until ( lSliceDrawn[lSlice]) or (lVox >= lSliceVox); + if (lSliceDrawn[lSlice]) and (lBottomDrawnSlice > lSlice) then lBottomDrawnSlice := lSlice; + if (lSliceDrawn[lSlice]) and (lTopDrawnSlice < lSlice) then lTopDrawnSlice := lSlice; + //if (lSliceDrawn[lSlice]) then lNotes.Add('drawing on slice '+inttostr(lSlice)); + end; + if (lBottomDrawnSlice > lTopDrawnSlice) then begin + lNotes.Add('No drawing found'); + exit; + end; + lGaps := false; + for lSlice := lBottomDrawnSlice to lTopDrawnSlice do + if (not lSliceDrawn[lSlice]) then lGaps := true; + if (not lGaps) then begin + lNotes.Add('No gaps in drawing found'); + exit; + end; + //images are binary - find non-zero value + lMax := 0; + lSliceOffset := (lBottomDrawnSlice * lSliceVox); + for lVox := 1 to lSliceVox do + if (lVol[lVox+lSliceOffset] > lMax) then lMax := lVol[lVox+lSliceOffset]; + //now fill slices + + for lSlice := lBottomDrawnSlice to lTopDrawnSlice do begin + if lSliceDrawn[lSlice] then + lLastDrawnSlice := lSlice + else begin//gap + for lS := lTopDrawnSlice downto lSlice do + if lSliceDrawn[lS] then lNextDrawnSlice := lS; + lNotes.Add('Interpolate '+inttostr(lSlice)+' using '+inttostr(lLastDrawnSlice)+' and '+inttostr(lNextDrawnSlice)); + Interpolate_Slice (lVol, lX,lY, lLastDrawnSlice,lSlice,lNextDrawnSlice); + Binarize_Slice(lVol, lX,lY,lSlice,lMax); + end; + end; + result := true; +end; + +procedure OrientCor (var lVol: bytep; lX,lY,lZ:integer; Reverse: boolean); +//XZY -> XYZ +begin + +end; + +procedure OrientSag (var lVol: bytep; lX,lY,lZ:integer; Reverse: boolean); +//YZX -> XYZ +begin + +end; + + +function Interpolate_Slices (var lVol: bytep; lX,lY,lZ, lOrient:integer; var lNotes: TStringList): boolean; +begin + if lOrient = 3 then OrientCor(lVol, lX,lY,lZ,true); + if lOrient = 2 then OrientSag( lVol, lX,lY,lZ,true); + result := Interpolate_SlicesAx (lVol, lX,lY,lZ, lNotes); + if lOrient = 3 then OrientCor(lVol, lX,lY,lZ,false); + if lOrient = 2 then OrientSag( lVol, lX,lY,lZ,false); + +end; + + + +end. diff --git a/niftiview7/example/attention.nii.gz b/niftiview7/example/attention.nii.gz new file mode 100755 index 0000000..9944ff9 Binary files /dev/null and b/niftiview7/example/attention.nii.gz differ diff --git a/niftiview7/example/cutr.ini b/niftiview7/example/cutr.ini new file mode 100755 index 0000000..1399986 --- /dev/null +++ b/niftiview7/example/cutr.ini @@ -0,0 +1,23 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +OverlayFromBGSurface=1 +ShowCutout=1 +FlipLR=0 +[INT] +BGNearClip=0 +OverlayNearClip=0 +Azimuth=110 +Elevation=45 +BGSurface=25 +OverlaySurface=1 +BGDepth=12 +OverlayDepth=8 +CutoutLo1=96 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=87 +CutoutHi3=181 +CutoutBias=3 diff --git a/niftiview7/example/fmri2r.ini b/niftiview7/example/fmri2r.ini new file mode 100755 index 0000000..f5831d5 --- /dev/null +++ b/niftiview7/example/fmri2r.ini @@ -0,0 +1,24 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +OverlayFromBGSurface=0 +ShowCutout=0 +FlipLR=0 +[INT] +BGNearClip=0 +OverlayNearClip=0 +Azimuth=110 +Elevation=45 +BGSurface=25 +OverlaySurface=1 +BGDepth=8 +OverlayDepth=8 +CutoutLo1=90 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=90 +CutoutHi3=181 +OverlayFromBGSurface=0 +CutoutBias=4 diff --git a/niftiview7/example/fmri3r.ini b/niftiview7/example/fmri3r.ini new file mode 100755 index 0000000..389a715 --- /dev/null +++ b/niftiview7/example/fmri3r.ini @@ -0,0 +1,22 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +OverlayFromBGSurface=1 +ShowCutout=0 +FlipLR=0 +[INT] +BGNearClip=0 +OverlayNearClip=0 +Azimuth=80 +Elevation=45 +BGSurface=25 +OverlaySurface=1 +BGDepth=8 +OverlayDepth=8 +CutoutLo1=90 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=90 +CutoutHi3=181 diff --git a/niftiview7/example/fmrir.ini b/niftiview7/example/fmrir.ini new file mode 100755 index 0000000..fe5a2d4 --- /dev/null +++ b/niftiview7/example/fmrir.ini @@ -0,0 +1,22 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=0 +Trilinear=0 +OverlayFromBGSurface=1 +ShowCutout=0 +FlipLR=0 +[INT] +BGNearClip=0 +OverlayNearClip=0 +Azimuth=80 +Elevation=45 +BGSurface=51 +OverlaySurface=1 +BGDepth=8 +OverlayDepth=12 +CutoutLo1=90 +CutoutHi1=181 +CutoutLo2=108 +CutoutHi2=217 +CutoutLo3=90 +CutoutHi3=181 diff --git a/niftiview7/example/lesions/1.voi b/niftiview7/example/lesions/1.voi new file mode 100755 index 0000000..b98f478 Binary files /dev/null and b/niftiview7/example/lesions/1.voi differ diff --git a/niftiview7/example/lesions/10.voi b/niftiview7/example/lesions/10.voi new file mode 100755 index 0000000..f43514a Binary files /dev/null and b/niftiview7/example/lesions/10.voi differ diff --git a/niftiview7/example/lesions/11.voi b/niftiview7/example/lesions/11.voi new file mode 100755 index 0000000..620a004 Binary files /dev/null and b/niftiview7/example/lesions/11.voi differ diff --git a/niftiview7/example/lesions/12.voi b/niftiview7/example/lesions/12.voi new file mode 100755 index 0000000..4920051 Binary files /dev/null and b/niftiview7/example/lesions/12.voi differ diff --git a/niftiview7/example/lesions/13.voi b/niftiview7/example/lesions/13.voi new file mode 100755 index 0000000..91aef2c Binary files /dev/null and b/niftiview7/example/lesions/13.voi differ diff --git a/niftiview7/example/lesions/14.voi b/niftiview7/example/lesions/14.voi new file mode 100755 index 0000000..a014e7c Binary files /dev/null and b/niftiview7/example/lesions/14.voi differ diff --git a/niftiview7/example/lesions/15.voi b/niftiview7/example/lesions/15.voi new file mode 100755 index 0000000..8c9c714 Binary files /dev/null and b/niftiview7/example/lesions/15.voi differ diff --git a/niftiview7/example/lesions/16.voi b/niftiview7/example/lesions/16.voi new file mode 100755 index 0000000..a18669f Binary files /dev/null and b/niftiview7/example/lesions/16.voi differ diff --git a/niftiview7/example/lesions/17.voi b/niftiview7/example/lesions/17.voi new file mode 100755 index 0000000..d6bc018 Binary files /dev/null and b/niftiview7/example/lesions/17.voi differ diff --git a/niftiview7/example/lesions/18.voi b/niftiview7/example/lesions/18.voi new file mode 100755 index 0000000..c9eee95 Binary files /dev/null and b/niftiview7/example/lesions/18.voi differ diff --git a/niftiview7/example/lesions/19.voi b/niftiview7/example/lesions/19.voi new file mode 100755 index 0000000..c349b2d Binary files /dev/null and b/niftiview7/example/lesions/19.voi differ diff --git a/niftiview7/example/lesions/2.voi b/niftiview7/example/lesions/2.voi new file mode 100755 index 0000000..1a5e9ba Binary files /dev/null and b/niftiview7/example/lesions/2.voi differ diff --git a/niftiview7/example/lesions/20.voi b/niftiview7/example/lesions/20.voi new file mode 100755 index 0000000..1cbba6b Binary files /dev/null and b/niftiview7/example/lesions/20.voi differ diff --git a/niftiview7/example/lesions/21.voi b/niftiview7/example/lesions/21.voi new file mode 100755 index 0000000..6e08d28 Binary files /dev/null and b/niftiview7/example/lesions/21.voi differ diff --git a/niftiview7/example/lesions/22.voi b/niftiview7/example/lesions/22.voi new file mode 100755 index 0000000..b877f26 Binary files /dev/null and b/niftiview7/example/lesions/22.voi differ diff --git a/niftiview7/example/lesions/23.voi b/niftiview7/example/lesions/23.voi new file mode 100755 index 0000000..0859061 Binary files /dev/null and b/niftiview7/example/lesions/23.voi differ diff --git a/niftiview7/example/lesions/24.voi b/niftiview7/example/lesions/24.voi new file mode 100755 index 0000000..f6949fb Binary files /dev/null and b/niftiview7/example/lesions/24.voi differ diff --git a/niftiview7/example/lesions/3.voi b/niftiview7/example/lesions/3.voi new file mode 100755 index 0000000..d9de58f Binary files /dev/null and b/niftiview7/example/lesions/3.voi differ diff --git a/niftiview7/example/lesions/4.voi b/niftiview7/example/lesions/4.voi new file mode 100755 index 0000000..cbbec20 Binary files /dev/null and b/niftiview7/example/lesions/4.voi differ diff --git a/niftiview7/example/lesions/5.voi b/niftiview7/example/lesions/5.voi new file mode 100755 index 0000000..390a0c3 Binary files /dev/null and b/niftiview7/example/lesions/5.voi differ diff --git a/niftiview7/example/lesions/6.voi b/niftiview7/example/lesions/6.voi new file mode 100755 index 0000000..4e939ec Binary files /dev/null and b/niftiview7/example/lesions/6.voi differ diff --git a/niftiview7/example/lesions/7.voi b/niftiview7/example/lesions/7.voi new file mode 100755 index 0000000..3eff297 Binary files /dev/null and b/niftiview7/example/lesions/7.voi differ diff --git a/niftiview7/example/lesions/8.voi b/niftiview7/example/lesions/8.voi new file mode 100755 index 0000000..8c24f9b Binary files /dev/null and b/niftiview7/example/lesions/8.voi differ diff --git a/niftiview7/example/lesions/9.voi b/niftiview7/example/lesions/9.voi new file mode 100755 index 0000000..1c9640b Binary files /dev/null and b/niftiview7/example/lesions/9.voi differ diff --git a/niftiview7/example/lesions/binomial.val b/niftiview7/example/lesions/binomial.val new file mode 100755 index 0000000..8b0ee6c --- /dev/null +++ b/niftiview7/example/lesions/binomial.val @@ -0,0 +1,29 @@ +#Version:0 +#Covary Volume 0 +#Template C:\template.img +#CritPct 16 +ImageName Cancel +1.voi 0 +2.voi 0 +3.voi 0 +4.voi 0 +5.voi 0 +6.voi 0 +7.voi 0 +8.voi 0 +9.voi 0 +10.voi 0 +11.voi 0 +12.voi 0 +13.voi 1 +14.voi 1 +15.voi 1 +16.voi 1 +17.voi 1 +18.voi 1 +19.voi 1 +20.voi 1 +21.voi 1 +22.voi 1 +23.voi 1 +24.voi 1 \ No newline at end of file diff --git a/niftiview7/example/lesions/continuous.val b/niftiview7/example/lesions/continuous.val new file mode 100755 index 0000000..87252bf --- /dev/null +++ b/niftiview7/example/lesions/continuous.val @@ -0,0 +1,29 @@ +#Version:0 +#Covary Volume 0 +#Template C:\template.img +#CritPct 16 +ImageName Cancel +1.voi 2 +2.voi 44 +3.voi 22 +4.voi 24 +5.voi 23 +6.voi 22 +7.voi 18 +8.voi 12 +9.voi 15 +10.voi 41 +11.voi 32 +12.voi 22 +13.voi 60 +14.voi 58 +15.voi 57 +16.voi 57 +17.voi 55 +18.voi 56 +19.voi 60 +20.voi 59 +21.voi 57 +22.voi 58 +23.voi 56 +24.voi 57 \ No newline at end of file diff --git a/niftiview7/example/saccades.nii.gz b/niftiview7/example/saccades.nii.gz new file mode 100755 index 0000000..66d166e Binary files /dev/null and b/niftiview7/example/saccades.nii.gz differ diff --git a/niftiview7/fastsmooth.pas b/niftiview7/fastsmooth.pas new file mode 100755 index 0000000..5114ac1 --- /dev/null +++ b/niftiview7/fastsmooth.pas @@ -0,0 +1,403 @@ +unit fastsmooth; + +{$IFDEF FPC}{$mode delphi}{$ENDIF} + +interface + +uses + // LCLIntf,//<- only for gettickcount + Classes, SysUtils, define_types, otsuml; + procedure DilateSphere (var lImg: Bytep; lXi,lYi,lZi: integer; lVoxDistance: single; lChange: byte ); +procedure SmoothFWHM2Vox (var lImg: Bytep; lXi,lYi,lZi: integer); +procedure Dilate (var lImg: Bytep; lXi,lYi,lZi,lCycles: integer; lChange: byte ); +procedure PreserveLargestCluster (var lImg: Bytep; lXi,lYi,lZi: integer; lClusterValue,ValueForSmallClusters: byte ); + procedure MaskBackground (var lImg: Bytep; lXi,lYi,lZi,lOtsuLevels: integer; lDilateVox: single; lOneContiguousObject: boolean ); +implementation + +procedure MaskBackground (var lImg: Bytep; lXi,lYi,lZi,lOtsuLevels: integer; lDilateVox: single; lOneContiguousObject: boolean ); +var + lMask: ByteP; + lX,lY,lZ,lV,lXYZ: integer; +begin + lXYZ := lXi * lYi * lZi; + if (lXi < 3) or (lYi < 3) or (lZi < 1) then + exit; + getmem(lMask, lXYZ); + Move(lImg^[1], lMask^[1],lXYZ); + SmoothFWHM2Vox(lMask, lXi,lYi,lZi); + ApplyOtsuBinary (lMask, lXYZ,lOtsuLevels); + if lOneContiguousObject then begin + PreserveLargestCluster (lMask, lXi,lYi,lZi,255,0 ); //only preserve largest single object + if lDilateVox >= 1 then + DilateSphere (lMask, lXi,lYi,lZi,lDilateVox,255 ); + end else begin + if lDilateVox >= 1 then + DilateSphere (lMask, lXi,lYi,lZi,lDilateVox,255 ); + PreserveLargestCluster (lMask, lXi,lYi,lZi,0,255 ); //only erase outside air + end; + lV:=0; + for lZ := 1 to lZi do + for lY := 1 to lYi do + for lX := 1 to lXi do begin + inc(lV); + if (lMask^[lV] = 0) or (lX=1) or (lX=lXi) or (lY=1) or (lY=lYi) or (lZ=1) or (lZ=lZi) then + lImg^[lV] := 0; + + end; + freemem(lMask); +end; + +(*procedure MaskBackground (var lImg: Bytep; lXi,lYi,lZi: integer); +var + lMask: ByteP; + lX,lXYZ: integer; +begin + lXYZ := lXi * lYi * lZi; + if (lXi < 3) or (lYi < 3) or (lZi < 1) then + exit; + getmem(lMask, lXYZ); + Move(lImg^[1], lMask^[1],lXYZ); + SmoothFWHM2Vox(lMask, lXi,lYi,lZi); + ApplyOtsuBinary (lMask, lXYZ); + //Dilate (lMask, lXi,lYi,lZi,5,255 ); + DilateSphere (lMask, lXi,lYi,lZi,5,255 ); + PreserveLargestCluster (lMask, lXi,lYi,lZi,0,255 ); + for lX := 1 to lXYZ do + if lMask^[lX] = 0 then + lImg^[lX] := 0; + freemem(lMask); +end;*) + +procedure CountClusterSize (var lImg: Bytep; var lClusterBuff: longintp; lXi,lYi,lZi: integer; lClusterValue: byte); +//Given volume lImg, will generate volume lCount with number of connected voxels with value lCluster +var + //tart: DWord; + lTopSlice,lInc,lXY,lXYZ,lClusterSign,lQTail,lQHead,lQSz,lClusterSz,lClusterFillValue: integer; + lQra: LongIntP; +const + kFillValue = -2; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; //nested incQra +procedure Check(lPixel: integer); + begin + if (lClusterBuff^[lPixel]=lClusterSign) then begin//add item + incQra(lQHead,lQSz); + inc(lClusterSz); + lClusterBuff^[lPixel] := lClusterFillValue; + lQra^[lQHead] := lPixel; + end; +end;//nested Check +PROCEDURE RetirePixel; //FIFO cleanup , 1410: added 18-voxel check +var + lVal: integer; +BEGIN + lVal := lQra^[lQTail]; + + if (lVal < lTopSlice) and (lVal > lXY) then begin + (* //next code avoids left-right and anterior-posterior wrapping... + if lVal = 0 then begin + //should never happen: unmarked voxel = increment lQTail so not infinite loop + incQra(lQTail,lQSz); //done with this pixel + exit; + end; + lXpos := lVal mod lXi; + if lXpos = 0 then lXPos := lXi; + + lYpos := (1+((lVal-1) div lXi)) mod lYi; + if lYPos = 0 then lYPos := lYi; + + lZpos := ((lVal-1) div lXY)+1; + if (lXPos <= 1) or (lXPos >= lXi) or + (lYPos <= 1) or (lYPos >= lYi) or + (lZPos <= 1) or (lZPos >= lZi) then + // retire and exit +else begin *) + + Check(lVal-1); //left + Check(lVal+1); //right + Check(lVal-lXi); //up + Check(lVal+lXi); //down + Check(lVal-lXY); //up + Check(lVal+lXY); //down +(* //check plane above + lValX := lVal + lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check plane below + lValX := lVal - lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDimM); //up + Check(lValX+lXDimM); //down + //check diagonals of current plane + Check(lVal-lXDimM-1); //up, left + Check(lVal-lXDimM+1); //up, right + + Check(lVal+lXDimM-1); //down, left + Check(lVal+lXDimM+1); //down, right *) +end;{} //not edge + incQra(lQTail,lQSz); //done with this pixel +END; +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +//var lI: integer; +begin + (*if (lClusterBuff^[lPt]<>lClusterSign) then exit;*) + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +procedure SelectClusters (lSign: integer); +var lInc,lV: integer; +begin + for lInc := 1 to lXYZ do begin + if lClusterBuff^[lInc] = lSign then begin + // measure size of the cluster and fill it with kFillValue + lClusterSz := 0; + lClusterSign := lSign; + lClusterFillValue := kFillValue; + FillStart(lInc); + // now fill the cluster with its size (=1 if the voxel was isolated) + if lClusterSz > 1 then begin + for lV := 1 to lXYZ do + if lClusterBuff^[lV] = kFillValue then + lClusterBuff^[lV] := lClusterSz; + end else + lClusterBuff^[lInc] := 1; //fill all voxels in cluster with size of voxel + end;//target color + end; //for each voxel +end; //nested SelectClusters +begin //proc CountClusterSize + if (lXi < 5) or (lYi < 5) or (lZi < 3) then exit; + lXY := lXi*lYi; //offset one slice + lTopSlice := (lZi-1) * lXY; + lXYZ :=lXY*lZi; + lQSz := (lXYZ div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + for lInc := 1 to lXYZ do begin + if lImg^[lInc] = lClusterValue then + lClusterBuff^[lInc] := -1 //target voxel - will be part of a cluster of size 1..XYZ + else + lClusterBuff^[lInc] := 0;//not a target, not part of a cluser, size = 0 + end; + //lStart := GetTickCount; + SelectClusters(-1); //for each voxel with intensity=-1, change value to number of connected voxels in cluster + //fx(GetTickCount-lStart); + //we did not fill bottom slice... + for lInc := 1 to lXY do + if lImg^[lInc] = lClusterValue then + lClusterBuff^[lInc] := lClusterBuff^[lInc+lXY]; + //we did not fill top slice + for lInc := (lTopSlice+1) to (lTopSlice+lXY) do + if lImg^[lInc] = lClusterValue then + lClusterBuff^[lInc] := lClusterBuff^[lInc-lXY]; + + Freemem(lQra); +end; //proc CountClusterSize + +procedure PreserveLargestCluster (var lImg: Bytep; lXi,lYi,lZi: integer; lClusterValue,ValueForSmallClusters: byte ); +var + lC,lXYZ,lX: integer; + lTemp: longintp; +begin + if (lXi < 5) or (lYi < 5) or (lZi < 1) then exit; + lXYZ :=lXi*lYi*lZi; + //ensure at least some voxels exist with clusterValue + lC := 0; + for lX := 1 to lXYZ do + if lImg^[lX] = lClusterValue then inc (lC); + if lC < 2 then + exit;//e.g. if lC = 1 then only a single voxel, which is in fact largest cluster + getmem(lTemp,lXYZ*sizeof(longint)); + CountClusterSize(lImg,lTemp,lXi,lYi,lZi,lClusterValue); + lC := 0; + for lX := 1 to lXYZ do + if lTemp^[lX] > lC then lC := lTemp^[lX]; + if ValueForSmallClusters = 0 then begin + for lX := 1 to lXYZ do + if (lTemp^[lX] >= 0) and (lTemp^[lX] < lC) then //cluster, but not biggest one... + lImg^[lX] := ValueForSmallClusters; + end else for lX := 1 to lXYZ do + if (lTemp^[lX] > 0) and (lTemp^[lX] < lC) then //cluster, but not biggest one... + lImg^[lX] := ValueForSmallClusters; + + freemem(lTemp); + +end; + +procedure Dilate (var lImg: Bytep; lXi,lYi,lZi,lCycles: integer; lChange: byte ); +//Dilates Diamonds - neighbor coefficient = 0 +//Dilate if Change=1 then all voxels where intensity <> 1 but where any neighbors = 1 will become 1 +//Erode if Change=0 then all voxels where intensity <>0 but where any neighbors = 0 will become 0 +//step is repeated for lCycles +var + lC,lX,lY,lZ, lXY,lXYZ,lPos,lOffset,lN: integer; + lTemp: bytep; +begin + if (lXi < 5) or (lYi < 5) or (lZi < 1) then exit; + lXY := lXi*lYi; //offset one slice + lXYZ :=lXY*lZi; + getmem(lTemp,lXYZ); + for lC := 1 to lCycles do begin + Move(lImg^[1], lTemp^[1],lXYZ); + for lZ := 1 to lZi do begin + for lY := 1 to lYi do begin + lOffset := ((lY-1)*lXi) + ((lZ-1) * lXY); + for lX := 1 to lXi do begin + lPos := lOffset + lX; + if (lTemp^[lPos] <> lChange) then begin + if (lX>1) and (lTemp^[lPos-1] = lChange) then lImg^[lPos] := lChange; + if (lX<lXi) and (lTemp^[lPos+1] = lChange) then lImg^[lPos] := lChange; + if (lY>1) and (lTemp^[lPos-lXi] = lChange) then lImg^[lPos] := lChange; + if (lY<lYi) and (lTemp^[lPos+lXi] = lChange) then lImg^[lPos] := lChange; + if (lZ>1) and (lTemp^[lPos-lXY] = lChange) then lImg^[lPos] := lChange; + if (lZ<lZi) and (lTemp^[lPos+lXY] = lChange) then lImg^[lPos] := lChange; + end; //voxel <> lChange + end; + end;//Y + end; //Z + end; + freemem(lTemp); +end; + +procedure SmoothFWHM2Vox (var lImg: Bytep; lXi,lYi,lZi: integer); +const + k0=240;//weight of center voxel + k1=120;//weight of nearest neighbors + k2=15;//weight of subsequent neighbors + kTot=k0+k1+k1+k2+k2; //weight of center plus all neighbors within 2 voxels + kWid = 2; //we will look +/- 2 voxels from center +var + lyPos,lPos,lWSum,lX,lY,lZ,lXi2,lXY,lXY2: integer; + lTemp: bytep; +begin + if (lXi < 5) or (lYi < 5) then exit; + lXY := lXi*lYi; //offset one slice + lXY2 := lXY * 2; //offset two slices + lXi2 := lXi*2;//offset to voxel two lines above or below + getmem(lTemp,lXi*lYi*lZi*sizeof(byte)); + for lPos := 1 to (lXi*lYi*lZi) do + lTemp^[lPos] := lImg^[lPos]; + //smooth horizontally + for lZ := 1 to lZi do begin + for lY := (1) to (lYi) do begin + lyPos := ((lY-1)*lXi) + ((lZ-1)*lXY) ; + for lX := (1+kWid) to (lXi-kWid) do begin + lPos := lyPos + lX; + lWSum := lImg^[lPos-2]*k2+lImg^[lPos-1]*k1 + +lImg^[lPos]*k0 + +lImg^[lPos+1]*k1+lImg^[lPos+2]*k2; + lTemp^[lPos] := lWSum div kTot; + end; {lX} + end; {lY} + end; //lZi + //smooth vertically + + for lPos := 1 to (lXi*lYi*lZi) do + lImg^[lPos] := lTemp^[lPos];//fill in sides + for lZ := 1 to lZi do begin + for lX := (1) to (lXi) do begin + for lY := (1+kWid) to (lYi-kWid) do begin + lPos := ((lY-1)*lXi) + lX + ((lZ-1)*lXY) ; + lWSum := lTemp^[lPos-lXi2]*k2+lTemp^[lPos-lXi]*k1 + +lTemp^[lPos]*k0 + +lTemp^[lPos+lXi]*k1+lTemp^[lPos+lXi2]*k2; + lImg^[lPos] := lWSum div kTot; + end; {lX} + end; //lY + end; //lZ + //if 3rd dimension.... + if lZi >= 5 then begin + //smooth across slices + for lPos := 1 to (lXi*lYi*lZi) do + lTemp^[lPos] := lImg^[lPos]; //fill in sides + for lZ := (1+kWid) to (lZi-kWid) do begin + for lY := (1) to (lYi) do begin + lyPos := ((lY-1)*lXi) + ((lZ-1)*lXY) ; + for lX := (1) to (lXi) do begin + lPos := lyPos + lX; + lWSum := lImg^[lPos-lXY2]*k2+lImg^[lPos-lXY]*k1 + +lImg^[lPos]*k0 + +lImg^[lPos+lXY]*k1+lImg^[lPos+lXY2]*k2; + lTemp^[lPos] := lWSum div kTot; + end; {lX} + end; {lY} + end; //lZi + for lPos := 1 to (lXi*lYi*lZi) do + lImg^[lPos] := lTemp^[lPos]; + end; //at least 5 slices... + //free memory + freemem(lTemp); +end; + +procedure DilateSphere (var lImg: Bytep; lXi,lYi,lZi: integer; lVoxDistance: single; lChange: byte ); +//INPUT: Img is array of bytes 1..XYZ that represents 3D volume, lXi,lYi,lZi are number of voxels in each dimension +// lVoxDistance is search radius (in voxels) +// lChange is the intensity to be changed - if background color: erosion, if foreground color: dilation +//OUTPUT: Eroded/Dilated Img +var + lDxI,lXY,lXYZ,lZ,lY,lX, lVoxOK,lPos: integer; + lDx: single; + lSearch: array of integer; + lTemp: bytep; +function HasNeighbor (lVox: integer): boolean; +var + s,t: integer; +begin + result := true; + for s := 0 to (lVoxOK-1) do begin + t := lVox +lSearch[s]; + if (t > 0) and (t <= lXYZ) and (lTemp^[t] = lChange) then + exit; + end; + result := false; +end; //nested HasNeighbor +begin //proc DilateSphere + if lVoxDistance < 1 then exit; + if lVoxDistance = 1 then begin //much faster to use classic neighbor dilation + Dilate(lImg,Lxi,lYi,lZi,1,lChange); + exit; + end; + if (lXi < 3) or (lYi < 3) or (lZi < 3) then + exit; + lXY := lXi*lYi; //voxels per slice + lXYZ := lXY*lZi; //voxels per volume + //next: make 1D array of all voxels within search sphere: store offset from center + lDxI := trunc(lVoxDistance); //no voxel will be searched further than DxI from center + setlength(lSearch,((lDxI *2)+1)*((lDxI *2)+1)*((lDxI *2)+1) ); + lVoxOK := 0; + for lZ := -lDxI to lDxI do + for lY := -lDxI to lDxI do + for lX := -lDxI to lDxI do begin + lDx := sqrt( sqr(lX)+ sqr(lY)+ sqr(lZ) ); + if (lDx < lVoxDistance) and (lDx > 0) then begin + lSearch[lVoxOK] := lX + (lY*lXi)+(lZ * lXY); //offset to center + inc(lVoxOK); + end; //in range, not center + end; //lX + getmem(lTemp, lXYZ);//we need a temporary buffer, as we will be dilating the original image + Move(lImg^[1], lTemp^[1],lXYZ); + lPos := 0; + for lX := 1 to lXYZ do begin + inc(lPos); + if (lTemp^[lPos] <> lChange) and HasNeighbor(lPos) then + lImg^[lPos] := lChange; + end; //for X, each voxel + freemem(lTemp); //free temporary buffer + lSearch := nil; //free 1D search space +end; //proc DilateSphere + +end. + diff --git a/niftiview7/fdr.pas b/niftiview7/fdr.pas new file mode 100755 index 0000000..1355bde --- /dev/null +++ b/niftiview7/fdr.pas @@ -0,0 +1,78 @@ +unit fdr; +interface + +uses define_types; +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +procedure qsort(lower, upper : integer; var Data:SingleP); +implementation + +procedure qsort(lower, upper : integer; var Data:SingleP); +//40ms - very recursive... +var + left, right : integer; + pivot,lswap: single; +begin + pivot:=Data[(lower+upper) div 2]; + left:=lower; + right:=upper; + while left<=right do begin + while Data[left] < pivot do left:=left+1; { Parting for left } + while Data[right] > pivot do right:=right-1;{ Parting for right} + if left<=right then begin { Validate the change } + lswap := Data[left]; + Data[left] := Data[right]; + Data[right] := lswap; + left:=left+1; + right:=right-1; + end; //validate + end;//while left <=right + if right>lower then qsort(lower,right,Data); { Sort the LEFT part } + if upper>left then qsort(left ,upper,data); { Sort the RIGHT part } +end; + +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +var + lInc: integer; + lrPs,Qs: SingleP; +begin + //rank Pvalues + //ShaQuickSort(lnTests,Singlep0(Ps[1])); + qSort(1,lnTests,Ps); + //qcksrt(1,lnTests,Ps); + GetMem(Qs,lnTests*sizeof(single)); + //next findcrit FDR05 + for lInc := 1 to lnTests do + Qs[lInc] := (0.05*lInc)/lnTests; + lFDR05 := 0; + for lInc := 1 to lnTests do + if Ps[lInc] <= Qs[lInc] then + lFDR05 := Ps[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs[lInc] := (0.01*lInc)/lnTests; + lFDR01 := 0; + for lInc := 1 to lnTests do + if Ps[lInc] <= Qs[lInc] then + lFDR01 := Ps[lInc]; + //reverse + GetMem(lrPs,lnTests*sizeof(single)); + for lInc := 1 to lnTests do + lrPs[lInc] := 1- Ps[lnTests-lInc+1]; + for lInc := 1 to lnTests do + Qs[lInc] := (0.05*lInc)/lnTests; + lnegFDR05 := 0; + for lInc := 1 to lnTests do + if lrPs[lInc] <= Qs[lInc] then + lnegFDR05 := lrPs[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs[lInc] := (0.01*lInc)/lnTests; + lnegFDR01 := 0; + for lInc := 1 to lnTests do + if lrPs[lInc] <= Qs[lInc] then + lnegFDR01 := lrPs[lInc]; + FreeMem(lrPs); + Freemem(Qs); +end; + +end. \ No newline at end of file diff --git a/niftiview7/fill.pas b/niftiview7/fill.pas new file mode 100755 index 0000000..27758c3 --- /dev/null +++ b/niftiview7/fill.pas @@ -0,0 +1,110 @@ +unit fill; + +interface +uses define_types,Windows; +procedure BorderFill(var lBMP: Bytep; lBGInvisibleColor: byte; lMaskHt,lMaskWid: integer); + +implementation + +procedure BorderFill(var lBMP: Bytep; lBGInvisibleColor: byte; lMaskHt,lMaskWid: integer); +//lMaskP should have all invis voxels as 128, non as 255 +//sets all invis boundary voxels to 0 +var + lMaskP: ByteP; + lPos,lMaskSz, + lQSz,lQHead,lQTail: integer; + lQRA: LongIntp; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; +PROCEDURE RetirePixel; //FIFO cleanup +VAR + lVal,lPos: integer; +BEGIN + lVal := lQra[lQTail]; + lPos := lVal-1; + if (lPos > 0) and (lMaskP[lPos]=128) then begin//add item to left + incQra(lQHead,lQSz); + lMaskP[lPos] := 0; + lQra[lQHead] := lPos; + end; + if (lPos > 0) then lMaskP[lPos] := 0; + lPos := lVal+1; + if (lPos < lMaskSz) and (lMaskP[lPos]=128) then begin//add item to right + incQra(lQHead,lQSz); + lMaskP[lPos] := 0; + lQra[lQHead] := lPos; + end; + if (lPos < lMaskSz) then lMaskP[lPos] := 0; + lPos := lVal-lMaskWid; + if (lPos > 0) and (lMaskP[lPos]=128) then begin//add item above + incQra(lQHead,lQSz); + lMaskP[lPos] := 0; + lQra[lQHead] := lPos; + end; + if (lPos > 0) then lMaskP[lPos] := 0; + lPos := lVal+lMaskWid; + if (lPos < lMaskSz) and(lMaskP[lPos]=128) then begin//add item below + incQra(lQHead,lQSz); + lMaskP[lPos] := 0; + lQra[lQHead] := lPos; + end; + if (lPos < lMaskSz) then lMaskP[lPos] := 0; + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +begin + if (lPt < 1) or (lPt > lMaskSz) or (lMaskP[lPt] <> 128) then exit; + //lQSz := 8000;//size of FIFO Queue Array + lQHead := 1; + lQTail := 1; + lQra[lQTail] := (lPt); //NOTE: both X and Y start from 0 not 1 + lMaskP[lPt] := 0; + RetirePixel; + if lQHead >= lQTail then begin + while lQHead <> lQTail do + RetirePixel; + end; +end; +begin //proc DefineBG + lMaskSz := lMaskWid * lMaskHt; + Getmem(lMaskP,lMaskSz); + for lPos := 1 to lMaskSz do + if lBMP[lPos] <> lBGInvisibleColor then + lMaskP[lPos] := 128 + else + lMaskP[lPos] := 255; + lQSz := lMaskSz div 4; + GetMem(lQra,lQSz*sizeof(LongInt)); + //erase all rows + for lPos := 1 to lMaskHt do begin + FillStart( (lPos-1)*lMaskWid + 1); + FillStart( (lPos)*lMaskWid); + end; + //erase all cols + for lPos := 1 to lMaskWid do begin + FillStart( lPos + 1); + FillStart( ((lMaskHt-1) *lMaskWid) + lPos); + end; + Freemem(lQRa); + //make sure bright blue 0000FF becauses neighbor 0000FE instead of 000100 + //now, fill in islands so they are not transparent + for lPos := 1 to lMaskSz do + if lMaskP[lPos] = 128 then + lBMP[lPos] := lBGInvisibleColor; + //else + // lBMP[lPos] := 0; + //for lPos := 1 to lMaskSz do + // lBMP[lPos] := lBGInvisibleColor ; + + Freemem(lMaskP); + +end; + + +end. + \ No newline at end of file diff --git a/niftiview7/fmath.pas b/niftiview7/fmath.pas new file mode 100755 index 0000000..8c9a8a8 --- /dev/null +++ b/niftiview7/fmath.pas @@ -0,0 +1,2225 @@ +{ ********************************************************************** + * Unit FMATH.PAS * + * Version 2.8 * + * (c) J. Debord, July 2003 * + ********************************************************************** + This unit implements some mathematical functions in Turbo Pascal + ********************************************************************** + Notes: + + 1) The default real type is DOUBLE (8-byte real) + Other types may be selected by defining the symbols: + + -------------------------------- + Symbol Type + -------------------------------- + SINGLEREAL Single ( 4-byte) + PASCALREAL Real ( 6-byte) + EXTENDEDREAL Extended (10-byte) + -------------------------------- + + 2) Error handling: The function MathError returns the error code from + the last function evaluation. It must be checked immediately after + a function call: + + Y := f(X); (* f is one of the functions of the library *) + if MathError = FN_OK then ... + + The possible error codes, and the default values attributed to the + function, are the following: + + ------------------------------------------------------------------ + Error code Value Significance Function default value + ------------------------------------------------------------------ + FN_OK 0 No error + FN_DOMAIN -1 Argument domain error 0 + FN_SING -2 Function singularity +/- MAXNUM + FN_OVERFLOW -3 Overflow range error MAXNUM + FN_UNDERFLOW -4 Underflow range error 0 + ------------------------------------------------------------------ + + where MAXNUM is a constant defining the highest number which may be + represented within the chosen floating point type. + + The standard functions Exp and Ln have been redefined according to + the above conventions as Expo and Log. + + 3) Assembler functions: some functions are written in assembler. + These functions may be selected by defining the symbol CPU387 + + Once you have selected these functions you have two possibilities: + + * Call the Pascal functions (e.g. Expo, ArcSin...). This will + provide some acceleration while keeping the error handling. + + * Call the assembler functions directly (e.g. fExp, fArcSin...) + This will provide further acceleration but without error handling. + Thus it is the responsibility of the calling program to check the + arguments passed to the function. See the interface file MATH387.INT + for a list of available functions. + + ********************************************************************** } + +unit fmath; + +interface + +{ ---------------------------------------------------------------------- + Floating point type (Default = Double) + ---------------------------------------------------------------------- } + +{$IFDEF PASCALREAL} + type Float = Real; +{$ELSE} +{$IFDEF SINGLEREAL} + type Float = Single; +{$ELSE} +{$IFDEF EXTENDEDREAL} + type Float = Extended; +{$ELSE} + {$DEFINE DOUBLEREAL} + type Float = Double; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Mathematical constants + ---------------------------------------------------------------------- } + +const + PI = 3.14159265358979323846; { Pi } + LN2 = 0.69314718055994530942; { Ln(2) } + LN10 = 2.30258509299404568402; { Ln(10) } + LNPI = 1.14472988584940017414; { Ln(Pi) } + INVLN2 = 1.44269504088896340736; { 1/Ln(2) } + INVLN10 = 0.43429448190325182765; { 1/Ln(10) } + TWOPI = 6.28318530717958647693; { 2*Pi } + PIDIV2 = 1.57079632679489661923; { Pi/2 } + SQRTPI = 1.77245385090551602730; { Sqrt(Pi) } + SQRT2PI = 2.50662827463100050242; { Sqrt(2*Pi) } + INVSQRT2PI = 0.39894228040143267794; { 1/Sqrt(2*Pi) } + LNSQRT2PI = 0.91893853320467274178; { Ln(Sqrt(2*Pi)) } + LN2PIDIV2 = 0.91893853320467274178; { Ln(2*Pi)/2 } + SQRT2 = 1.41421356237309504880; { Sqrt(2) } + SQRT2DIV2 = 0.70710678118654752440; { Sqrt(2)/2 } + GOLD = 1.61803398874989484821; { Golden Mean = (1 + Sqrt(5))/2 } + CGOLD = 0.38196601125010515179; { 2 - GOLD } + +{ ---------------------------------------------------------------------- + Machine-dependent constants + ---------------------------------------------------------------------- } + +{$IFDEF SINGLEREAL} +const + MACHEP = 1.192093E-7; { Floating point precision: 2^(-23) } + MAXNUM = 3.402823E+38; { Max. floating point number: 2^128 } + MINNUM = 1.175495E-38; { Min. floating point number: 2^(-126) } + MAXLOG = 88.72283; { Max. argument for Exp = Ln(MAXNUM) } + MINLOG = -87.33655; { Min. argument for Exp = Ln(MINNUM) } + MAXFAC = 33; { Max. argument for Factorial } + MAXGAM = 34.648; { Max. argument for Gamma } + MAXLGM = 1.0383E+36; { Max. argument for LnGamma } +{$ELSE} +{$IFDEF DOUBLEREAL} +const + MACHEP = 2.220446049250313E-16; { 2^(-52) } + MAXNUM = 1.797693134862315E+308; { 2^1024 } + MINNUM = 2.225073858507202E-308; { 2^(-1022) } + MAXLOG = 709.7827128933840; + MINLOG = -708.3964185322641; + MAXFAC = 170; + MAXGAM = 171.624376956302; + MAXLGM = 2.556348E+305; +{$ELSE} +{$IFDEF EXTENDEDREAL} +const + MACHEP = 1.08420217248550444E-19; { 2^(-63) } + MAXNUM = 1.18973149535723103E+4932; { 2^16384 } + MINNUM = 3.36210314311209558E-4932; { 2^(-16382) } + MAXLOG = 11356.5234062941439; + MINLOG = - 11355.137111933024; + MAXFAC = 1754; + MAXGAM = 1755.455; + MAXLGM = 1.04848146839019521E+4928; +{$ELSE} +{$IFDEF PASCALREAL} +const + MACHEP = 1.818989404E-12; { 2^(-39) } + MAXNUM = 4.253529586E+37; { 2^126 } + MINNUM = 2.350988703E-38; { 2^(-125) } + MAXLOG = 8.664339757E+01; + MINLOG = - 4.253529586E+01; + MAXFAC = 33; + MAXGAM = 34.64809785; + MAXLGM = 1.038324114E+36; +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Error codes for mathematical functions + ---------------------------------------------------------------------- } + +const + FN_OK = 0; { No error } + FN_DOMAIN = - 1; { Argument domain error } + FN_SING = - 2; { Function singularity } + FN_OVERFLOW = - 3; { Overflow range error } + FN_UNDERFLOW = - 4; { Underflow range error } + FN_TLOSS = - 5; { Total loss of precision } + FN_PLOSS = - 6; { Partial loss of precision } + +{ ---------------------------------------------------------------------- + Global variables and constants + ---------------------------------------------------------------------- } + +const + NFACT = 33; { The factorials of the first NFACT integers are stored + in a table } +var + MathErr : Integer; { Error code from the latest function evaluation } + + FactArray : array[0..NFACT] of Float; { Table of factorials } + +{ ---------------------------------------------------------------------- + Functional type + ---------------------------------------------------------------------- } + +type + TFunc = function(X : Float) : Float; + +{ ---------------------------------------------------------------------- + Error handling function + ---------------------------------------------------------------------- } + +function MathError : Integer; { Error code from the last function call } + +{ ---------------------------------------------------------------------- + Minimum, maximum, sign and exchange + ---------------------------------------------------------------------- } + +function FMin(X, Y : Float) : Float; { Minimum of 2 reals } +function FMax(X, Y : Float) : Float; { Maximum of 2 reals } +function IMin(X, Y : Integer) : Integer; { Minimum of 2 integers } +function IMax(X, Y : Integer) : Integer; { Maximum of 2 integers } +function Sgn(X : Float) : Integer; { Sign (returns 1 if X = 0) } +function Sgn0(X : Float) : Integer; { Sign (returns 0 if X = 0) } +function DSgn(A, B : Float) : Float; { Sgn(B) * |A| } + +procedure FSwap(var X, Y : Float); { Exchange 2 reals } +procedure ISwap(var X, Y : Integer); { Exchange 2 integers } + +{ ---------------------------------------------------------------------- + Assembler functions + ---------------------------------------------------------------------- } + +{$IFDEF CPU387} + {$I math387.int} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Sign, logarithms, exponentials and power + ---------------------------------------------------------------------- } + +function Expo(X : Float) : Float; { Exponential } +function Exp2(X : Float) : Float; { 2^X } +function Exp10(X : Float) : Float; { 10^X } +function Log(X : Float) : Float; { Natural log } +function Log2(X : Float) : Float; { Log, base 2 } +function Log10(X : Float) : Float; { Decimal log } +function LogA(X, A : Float) : Float; { Log, base A } +function IntPower(X : Float; N : Integer) : Float; { X^N } +function Power(X, Y : Float) : Float; { X^Y, X >= 0 } +function Pythag(X, Y : Float) : Float; { Sqrt(X^2 + Y^2) } + +{ ---------------------------------------------------------------------- + Trigonometric and inverse trigonometric functions + ---------------------------------------------------------------------- } + +function FixAngle(Theta : Float) : Float; { Set Theta in -Pi..Pi } +function Tan(X : Float) : Float; { Tangent } +function ArcSin(X : Float) : Float; { Arc sinus } +function ArcCos(X : Float) : Float; { Arc cosinus } +function ArcTan2(Y, X : Float) : Float; { Angle (Ox, OM) with M(X,Y) } + +procedure SinCos(X : Float; var SinX, CosX : Float); { Sin & Cos } + +{ ---------------------------------------------------------------------- + Hyperbolic and inverse hyperbolic functions + ---------------------------------------------------------------------- } + +function Sinh(X : Float) : Float; { Hyperbolic sine } +function Cosh(X : Float) : Float; { Hyperbolic cosine } +function Tanh(X : Float) : Float; { Hyperbolic tangent } +function ArcSinh(X : Float) : Float; { Inverse hyperbolic sine } +function ArcCosh(X : Float) : Float; { Inverse hyperbolic cosine } +function ArcTanh(X : Float) : Float; { Inverse hyperbolic tangent } + +procedure SinhCosh(X : Float; var SinhX, CoshX : Float); { Sinh & Cosh } + +{ ---------------------------------------------------------------------- + Special functions + ---------------------------------------------------------------------- } + +function Fact(N : Integer) : Float; { Factorial } +function Binomial(N, K : Integer) : Float; { Binomial coef. C(N,K) } +function Gamma(X : Float) : Float; { Gamma function } +function SgnGamma(X : Float) : Integer; { Sign of Gamma function } +function LnGamma(X : Float) : Float; { Log(|Gamma(X)|) } +function IGamma(A, X : Float) : Float; { Incomplete Gamma function } +function JGamma(A, X : Float) : Float; { Complement of IGamma } +function Beta(X, Y : Float) : Float; { Beta function } +function IBeta(A, B, X : Float) : Float; { Incomplete Beta function } +function Erf(X : Float) : Float; { Error function } +function Erfc(X : Float) : Float; { Complement of Erf } + +{ ---------------------------------------------------------------------- + Binomial distribution with probability P and number of repetitions N + ---------------------------------------------------------------------- } + +function PBinom(N : Integer; P : Float; K : Integer) : Float; { Prob(X = K) } +function FBinom(N : Integer; P : Float; K : Integer) : Float; { Prob(X <= K) } + +{ ---------------------------------------------------------------------- + Poisson distribution with mean Mu + ---------------------------------------------------------------------- } + +function PPoisson(Mu : Float; K : Integer) : Float; { Prob(X = K) } +function FPoisson(Mu : Float; K : Integer) : Float; { Prob(X <= K) } + +{ ---------------------------------------------------------------------- + Standard normal distribution + ---------------------------------------------------------------------- } + +function DNorm(X : Float) : Float; { Density of standard normal } +function FNorm(X : Float) : Float; { Prob(U <= X) } +function PNorm(X : Float) : Float; { Prob(|U| >= |X|) } +function InvNorm(P : Float) : Float; { Inverse of FNorm : returns X + such that Prob(U <= X) = P} + +{ ---------------------------------------------------------------------- + Student distribution with Nu d.o.f. + ---------------------------------------------------------------------- } + +function DStudent(Nu : Integer; X : Float) : Float; { Density of t } +function FStudent(Nu : Integer; X : Float) : Float; { Prob(t <= X) } +function PStudent(Nu : Integer; X : Float) : Float; { Prob(|t| >= |X|) } + +{ ---------------------------------------------------------------------- + Khi-2 distribution with Nu d.o.f. + ---------------------------------------------------------------------- } + +function DKhi2(Nu : Integer; X : Float) : Float; { Density of Khi2 } +function FKhi2(Nu : Integer; X : Float) : Float; { Prob(Khi2 <= X) } +function PKhi2(Nu : Integer; X : Float) : Float; { Prob(Khi2 >= X) } + +{ ---------------------------------------------------------------------- + Fisher-Snedecor distribution with Nu1 and Nu2 d.o.f. + ---------------------------------------------------------------------- } + +function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Density of F } +function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Prob(F <= X) } +function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Prob(F >= X) } + +{ ---------------------------------------------------------------------- + Exponential distribution + ---------------------------------------------------------------------- } + +function DExpo(A, X : Float) : Float; { Density of exponential distrib. } +function FExpo(A, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Beta distribution + ---------------------------------------------------------------------- } + +function DBeta(A, B, X : Float) : Float; { Density of Beta distribution } +function FBeta(A, B, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Gamma distribution + ---------------------------------------------------------------------- } + +function DGamma(A, B, X : Float) : Float; { Density of Gamma distribution } +function FGamma(A, B, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Random numbers + ---------------------------------------------------------------------- } + +procedure RMarIn(Seed1, Seed2 : Integer); +{ Initializes the random number generator. + The default initialization corresponds to RMarIn(1802, 9373) } + +function IRanMar : LongInt; +{ Returns a 32 bit random number in [ -2,147,483,648 ; 2,147,483,647 ] } + +function RanMar : Float; +{ Returns a random number in [0, 1[ } + +function RanGaussStd : Float; +{ Returns a random number from the standard normal distribution + (i.e. the Gaussian distribution with zero mean and unit variance) } + +function RanGauss(Mu, Sigma : Float) : Float; +{ Returns a random number from a Gaussian distribution + with mean Mu and standard deviation Sigma } + +{ ********************************************************************** } + +implementation + +{ ---------------------------------------------------------------------- + Error handling functions + ---------------------------------------------------------------------- } + + function DefaultVal(ErrCode : Integer) : Float; + { Sets the global variable MathErr and the function default value + according to the error code } + begin + MathErr := ErrCode; + case ErrCode of + FN_DOMAIN : DefaultVal := 0.0; + FN_SING : DefaultVal := MAXNUM; + FN_OVERFLOW : DefaultVal := MAXNUM; + FN_UNDERFLOW : DefaultVal := 0.0; + else + DefaultVal := 0.0; + end; + end; + + function MathError : Integer; + begin + MathError := MathErr; + end; + +{ ---------------------------------------------------------------------- + Minimum, maximum and sign + ---------------------------------------------------------------------- } + + function FMin(X, Y : Float) : Float; + begin + if X <= Y then + FMin := X + else + FMin := Y; + end; + + function FMax(X, Y : Float) : Float; + begin + if X >= Y then + FMax := X + else + FMax := Y; + end; + + function IMin(X, Y : Integer) : Integer; + begin + if X <= Y then + IMin := X + else + IMin := Y; + end; + + function IMax(X, Y : Integer) : Integer; + begin + if X >= Y then + IMax := X + else + IMax := Y; + end; + + procedure FSwap(var X, Y : Float); + var + Temp : Float; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + procedure ISwap(var X, Y : Integer); + var + Temp : Integer; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + function Sgn(X : Float) : Integer; + begin + if X >= 0.0 then + Sgn := 1 + else + Sgn := - 1; + end; + + function Sgn0(X : Float) : Integer; + begin + if X > 0.0 then + Sgn0 := 1 + else if X = 0.0 then + Sgn0 := 0 + else + Sgn0 := - 1; + end; + + function DSgn(A, B : Float) : Float; + begin + if B < 0.0 then DSgn := - Abs(A) else DSgn := Abs(A) + end; + +{ ---------------------------------------------------------------------- + Assembler functions + ---------------------------------------------------------------------- } + +{$IFDEF CPU387} + {$I math387.inc} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Elementary functions + ---------------------------------------------------------------------- } + + function Expo(X : Float) : Float; + begin + MathErr := FN_OK; + if X < MINLOG then + Expo := DefaultVal(FN_UNDERFLOW) + else if X > MAXLOG then + Expo := DefaultVal(FN_OVERFLOW) + else + Expo := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(X); + end; + + function Exp2(X : Float) : Float; + var + XLn2 : Float; + begin + MathErr := FN_OK; + XLn2 := X * LN2; + if XLn2 < MINLOG then + Exp2 := DefaultVal(FN_UNDERFLOW) + else if XLn2 > MAXLOG then + Exp2 := DefaultVal(FN_OVERFLOW) + else + Exp2 := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(XLn2); + end; + + function Exp10(X : Float) : Float; + var + XLn10 : Float; + begin + MathErr := FN_OK; + XLn10 := X * LN10; + if XLn10 < MINLOG then + Exp10 := DefaultVal(FN_UNDERFLOW) + else if XLn10 > MAXLOG then + Exp10 := DefaultVal(FN_OVERFLOW) + else + Exp10 := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(XLn10); + end; + + function Log(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log := - DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log := - DefaultVal(FN_SING) + else + Log := {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X); + end; + + function Log10(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log10 := - DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log10 := - DefaultVal(FN_SING) + else + Log10 := {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) * INVLN10; + end; + + function Log2(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log2 := - DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log2 := - DefaultVal(FN_SING) + else + Log2 := {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) * INVLN2; + end; + + function LogA(X, A : Float) : Float; + begin + MathErr := FN_OK; + if (X < 0.0) or (A <= 0.0) or (A = 1.0) then + LogA := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + LogA := Sgn(1.0 - A) * DefaultVal(FN_SING) + else + {$IFDEF CPU387} + LogA := fLn(X) / fLn(A); + {$ELSE} + LogA := Ln(X) / Ln(A); + {$ENDIF} + end; + +{ ---------------------------------------------------------------------- + Power functions + + Thanks to Volker Walter <vw@metrohm.ch> + for suggesting improvements to Power and IntPower + ---------------------------------------------------------------------- } + + function PowerTests(X, Y : Float; var Res : Float) : Boolean; + { Tests the cases X=0, Y=0 and Y=1. Returns X^Y in Res } + begin + if X = 0.0 then + begin + PowerTests := True; + if Y = 0.0 then { 0^0 = lim X^X = 1 } + Res := 1.0 { X->0 } + else if Y > 0.0 then + Res := 0.0 { 0^Y = 0 } + else + Res := DefaultVal(FN_SING); + end + else if Y = 0.0 then + begin + Res := 1.0; { X^0 = 1 } + PowerTests := True; + end + else if Y = 1.0 then + begin + Res := X; { X^1 = X } + PowerTests := True; + end + else + PowerTests := False; + end; + + function IntPower(X : Float; N : Integer) : Float; + { Computes X^N by repeated multiplications } + const + InverseMaxNum = 1.0 / MAXNUM; + var + T : Float; + M : Integer; + Invert : Boolean; + begin + if PowerTests(X, N, T) then + begin + IntPower := T; + Exit; + end; + + Invert := (N < 0); { Test if inverting is needed } + if 1.0 < Abs(X) then { Test for 0 ..|x| .. 1 } + begin + X := 1.0 / X; + Invert := not Invert; + end; + + { Legendre's algorithm for + minimizing the number of multiplications } + T := 1.0; M := Abs(N); + while 0 < M do + begin + if Odd(M) then T := T * X; + X := Sqr(X); + M := M div 2; + end; + + if Invert then + if Abs(T) < InverseMaxNum then { Only here overflow } + T := DefaultVal(FN_OVERFLOW) + else + T := 1.0 / T; + + IntPower := T; + end; + + function Power(X, Y : Float) : Float; + { Computes X^Y = Exp(Y * Ln(X)), for X >= 0 + Resorts to IntPower if Y is integer } + var + Res : Float; + YLnX : Float; + begin + if PowerTests(X, Y, Res) then + Power := Res + else if (Abs(Y) < MaxInt) and (Trunc(Y) = Y) then { Integer exponent } + Power := IntPower(X, Trunc(Y)) + else if X < 0.0 then + Power := DefaultVal(FN_DOMAIN) + else + begin + YLnX := Y * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X); + if YLnX < MINLOG then + Power := DefaultVal(FN_UNDERFLOW) + else if YLnX > MAXLOG then + Power := DefaultVal(FN_OVERFLOW) + else + Power := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(YLnX); + end; + end; + + function Pythag(X, Y : Float) : Float; + { Computes Sqrt(X^2 + Y^2) without destructive underflow or overflow } + var + AbsX, AbsY : Float; + begin + MathErr := FN_OK; + AbsX := Abs(X); + AbsY := Abs(Y); + if AbsX > AbsY then + Pythag := AbsX * Sqrt(1.0 + Sqr(AbsY / AbsX)) + else if AbsY = 0.0 then + Pythag := 0.0 + else + Pythag := AbsY * Sqrt(1.0 + Sqr(AbsX / AbsY)); + end; + +{ ---------------------------------------------------------------------- + Trigonometric functions + ---------------------------------------------------------------------- } + + procedure SinCos(X : Float; var SinX, CosX : Float); + begin + MathErr := FN_OK; + SinX := {$IFDEF CPU387}fSin{$ELSE}Sin{$ENDIF}(X); + CosX := {$IFDEF CPU387}fCos{$ELSE}Cos{$ENDIF}(X); + end; + + function FixAngle(Theta : Float) : Float; + begin + MathErr := FN_OK; + while Theta > PI do + Theta := Theta - TWOPI; + while Theta <= - PI do + Theta := Theta + TWOPI; + FixAngle := Theta; + end; + + function Tan(X : Float) : Float; + var + SinX, CosX : Float; + begin + MathErr := FN_OK; + SinX := {$IFDEF CPU387}fSin{$ELSE}Sin{$ENDIF}(X); + CosX := {$IFDEF CPU387}fCos{$ELSE}Cos{$ENDIF}(X); + if CosX = 0.0 then + Tan := Sgn(SinX) * DefaultVal(FN_SING) + else + Tan := SinX / CosX; + end; + + function ArcSin(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcSin := DefaultVal(FN_DOMAIN) + else if X = 1.0 then + ArcSin := PIDIV2 + else if X = - 1.0 then + ArcSin := - PIDIV2 + else + ArcSin := {$IFDEF CPU387}fArcTan{$ELSE}ArcTan{$ENDIF}(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcCos(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcCos := DefaultVal(FN_DOMAIN) + else if X = 1.0 then + ArcCos := 0.0 + else if X = - 1.0 then + ArcCos := PI + else + ArcCos := PIDIV2 - {$IFDEF CPU387}fArcTan{$ELSE}ArcTan{$ENDIF}(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcTan2(Y, X : Float) : Float; + var + Theta : Float; + begin + MathErr := FN_OK; + if X = 0.0 then + if Y = 0.0 then + ArcTan2 := 0.0 + else if Y > 0.0 then + ArcTan2 := PIDIV2 + else + ArcTan2 := - PIDIV2 + else + begin + { 4th/1st quadrant -PI/2..PI/2 } + Theta := {$IFDEF CPU387}fArcTan{$ELSE}ArcTan{$ENDIF}(Y / X); + + { 2nd/3rd quadrants } + if X < 0.0 then + if Y >= 0.0 then + Theta := Theta + PI { 2nd quadrant: PI/2..PI } + else + Theta := Theta - PI; { 3rd quadrant: -PI..-PI/2 } + ArcTan2 := Theta; + end; + end; + +{ ---------------------------------------------------------------------- + Hyperbolic functions + ---------------------------------------------------------------------- } + + function Sinh(X : Float) : Float; + var + ExpX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + Sinh := Sgn(X) * DefaultVal(FN_OVERFLOW) + else + begin + ExpX := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(X); + Sinh := 0.5 * (ExpX - 1.0 / ExpX); + end; + end; + + function Cosh(X : Float) : Float; + var + ExpX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + Cosh := DefaultVal(FN_OVERFLOW) + else + begin + ExpX := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(X); + Cosh := 0.5 * (ExpX + 1.0 / ExpX); + end; + end; + + procedure SinhCosh(X : Float; var SinhX, CoshX : Float); + var + ExpX, ExpMinusX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + begin + CoshX := DefaultVal(FN_OVERFLOW); + SinhX := Sgn(X) * CoshX; + end + else + begin + ExpX := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(X); + ExpMinusX := 1.0 / ExpX; + SinhX := 0.5 * (ExpX - ExpMinusX); + CoshX := 0.5 * (ExpX + ExpMinusX); + end; + end; + + function Tanh(X : Float) : Float; + var + SinhX, CoshX : Float; + begin + SinhCosh(X, SinhX, CoshX); + Tanh := SinhX / CoshX; + end; + + function ArcSinh(X : Float) : Float; + begin + MathErr := FN_OK; + ArcSinh := {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X + Sqrt(Sqr(X) + 1.0)); + end; + + function ArcCosh(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 1.0 then + ArcCosh := DefaultVal(FN_DOMAIN) + else + ArcCosh := {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X + Sqrt(Sqr(X) - 1.0)); + end; + + function ArcTanh(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcTanh := DefaultVal(FN_DOMAIN) + else if (X = - 1.0) or (X = 1.0) then + ArcTanh := Sgn(X) * DefaultVal(FN_SING) + else + ArcTanh := 0.5 * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}((1.0 + X) / (1.0 - X)); + end; + +{ ---------------------------------------------------------------------- + Special functions. Translated from Cephes math library by S. Moshier: + http://www.moshier.net + ---------------------------------------------------------------------- } + +const { Used by IGamma and IBeta } + BIG = 9.223372036854775808E18; + BIGINV = 1.084202172485504434007E-19; + +type + TabCoef = array[0..9] of Float; + + function PolEvl(var X : Float; Coef : TabCoef; N : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates polynomial of degree N: + + 2 N + y = C + C x + C x +...+ C x + 0 1 2 N + + Coefficients are stored in reverse order: + + Coef[0] = C , ..., Coef[N] = C + N 0 + + The function P1Evl() assumes that Coef[N] = 1.0 and is + omitted from the array. Its calling arguments are + otherwise the same as PolEvl(). + ---------------------------------------------------------------------- } + var + Ans : Float; + I : Integer; + begin + Ans := Coef[0]; + for I := 1 to N do + Ans := Ans * X + Coef[I]; + PolEvl := Ans; + end; + + function P1Evl(var X : Float; Coef : TabCoef; N : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluate polynomial when coefficient of X is 1.0. + Otherwise same as PolEvl. + ---------------------------------------------------------------------- } + var + Ans : Float; + I : Integer; + begin + Ans := X + Coef[0]; + for I := 1 to N - 1 do + Ans := Ans * X + Coef[I]; + P1Evl := Ans; + end; + + function SgnGamma(X : Float) : Integer; + begin + if X > 0.0 then + SgnGamma := 1 + else if Odd(Trunc(Abs(X))) then + SgnGamma := 1 + else + SgnGamma := - 1; + end; + + function Stirf(X : Float) : Float; + { Stirling's formula for the gamma function + Gamma(x) = Sqrt(2*Pi) x^(x-.5) exp(-x) (1 + 1/x P(1/x)) + where P(x) is a polynomial } + const + STIR : TabCoef = ( + 7.147391378143610789273E-4, + - 2.363848809501759061727E-5, + - 5.950237554056330156018E-4, + 6.989332260623193171870E-5, + 7.840334842744753003862E-4, + - 2.294719747873185405699E-4, + - 2.681327161876304418288E-3, + 3.472222222230075327854E-3, + 8.333333333333331800504E-2, + 0); + + var + W, P : Float; + begin + W := 1.0 / X; + if X > 1024.0 then + begin + P := 6.97281375836585777429E-5 * W + 7.84039221720066627474E-4; + P := P * W - 2.29472093621399176955E-4; + P := P * W - 2.68132716049382716049E-3; + P := P * W + 3.47222222222222222222E-3; + P := P * W + 8.33333333333333333333E-2; + end + else + P := PolEvl(W, STIR, 8); + {$IFDEF CPU387} + Stirf := SQRT2PI * fExp((X - 0.5) * fLn(X) - X) * (1.0 + W * P); + {$ELSE} + Stirf := SQRT2PI * Exp((X - 0.5) * Ln(X) - X) * (1.0 + W * P); + {$ENDIF} + end; + + function GamSmall(X1, Z : Float) : Float; + { Gamma function for small values of the argument } + const + S : TabCoef = ( + - 1.193945051381510095614E-3, + 7.220599478036909672331E-3, + - 9.622023360406271645744E-3, + - 4.219773360705915470089E-2, + 1.665386113720805206758E-1, + - 4.200263503403344054473E-2, + - 6.558780715202540684668E-1, + 5.772156649015328608253E-1, + 1.000000000000000000000E0, + 0); + + SN : TabCoef = ( + 1.133374167243894382010E-3, + 7.220837261893170325704E-3, + 9.621911155035976733706E-3, + - 4.219773343731191721664E-2, + - 1.665386113944413519335E-1, + - 4.200263503402112910504E-2, + 6.558780715202536547116E-1, + 5.772156649015328608727E-1, + - 1.000000000000000000000E0, + 0); + + var + P : Float; + begin + if X1 = 0.0 then + begin + GamSmall := DefaultVal(FN_SING); + Exit; + end; + if X1 < 0.0 then + begin + X1 := - X1; + P := PolEvl(X1, SN, 8); + end + else + P := PolEvl(X1, S, 8); + GamSmall := Z / (X1 * P); + end; + + function StirfL(X : Float) : Float; + { Approximate Ln(Gamma) by Stirling's formula, for X >= 13 } + const + P : TabCoef = ( + 4.885026142432270781165E-3, + - 1.880801938119376907179E-3, + 8.412723297322498080632E-4, + - 5.952345851765688514613E-4, + 7.936507795855070755671E-4, + - 2.777777777750349603440E-3, + 8.333333333333331447505E-2, + 0, 0, 0); + + var + Q, W : Float; + begin + Q := {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) * (X - 0.5) - X; + Q := Q + LNSQRT2PI; + if X > 1.0E+10 then + StirfL := Q + else + begin + W := 1.0 / Sqr(X); + StirfL := Q + PolEvl(W, P, 6) / X; + end; + end; + + function Gamma(X : Float) : Float; + const + P : TabCoef = ( + 4.212760487471622013093E-5, + 4.542931960608009155600E-4, + 4.092666828394035500949E-3, + 2.385363243461108252554E-2, + 1.113062816019361559013E-1, + 3.629515436640239168939E-1, + 8.378004301573126728826E-1, + 1.000000000000000000009E0, + 0, 0); + + Q : TabCoef = ( + - 1.397148517476170440917E-5, + 2.346584059160635244282E-4, + - 1.237799246653152231188E-3, + - 7.955933682494738320586E-4, + 2.773706565840072979165E-2, + - 4.633887671244534213831E-2, + - 2.243510905670329164562E-1, + 4.150160950588455434583E-1, + 9.999999999999999999908E-1, + 0); + + var + SgnGam, N : Integer; + A, X1, Z : Float; + begin + MathErr := FN_OK; + SgnGam := SgnGamma(X); + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + Gamma := SgnGam * DefaultVal(FN_SING); + Exit; + end; + + if X > MAXGAM then + begin + Gamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + + A := Abs(X); + if A > 13.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := A - N; + end; + Z := Abs(A * {$IFDEF CPU387}fSin{$ELSE}Sin{$ENDIF}(PI * Z)) * Stirf(A); + if Z <= PI / MAXNUM then + begin + Gamma := SgnGam * DefaultVal(FN_OVERFLOW); + Exit; + end; + Z := PI / Z; + end + else + Z := Stirf(X); + Gamma := SgnGam * Z; + end + else + begin + Z := 1.0; + X1 := X; + while X1 >= 3.0 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < - 0.03125 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if X1 <= 0.03125 then + Gamma := GamSmall(X1, Z) + else + begin + while X1 < 2.0 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if (X1 = 2.0) or (X1 = 3.0) then + Gamma := Z + else + begin + X1 := X1 - 2.0; + Gamma := Z * PolEvl(X1, P, 7) / PolEvl(X1, Q, 8); + end; + end; + end; + end; + + function LnGamma(X : Float) : Float; + const + P : TabCoef = ( + - 2.163690827643812857640E3, + - 8.723871522843511459790E4, + - 1.104326814691464261197E6, + - 6.111225012005214299996E6, + - 1.625568062543700591014E7, + - 2.003937418103815175475E7, + - 8.875666783650703802159E6, + 0, 0, 0); + + Q : TabCoef = ( + - 5.139481484435370143617E2, + - 3.403570840534304670537E4, + - 6.227441164066219501697E5, + - 4.814940379411882186630E6, + - 1.785433287045078156959E7, + - 3.138646407656182662088E7, + - 2.099336717757895876142E7, + 0, 0, 0); + + var + N : Integer; + A, X1, Z : Float; + begin + MathErr := FN_OK; + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + LnGamma := DefaultVal(FN_SING); + Exit; + end; + + if X > MAXLGM then + begin + LnGamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + + A := Abs(X); + if A > 34.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := N - A; + end; + Z := A * {$IFDEF CPU387}fSin{$ELSE}Sin{$ENDIF}(PI * Z); + if Z = 0.0 then + begin + LnGamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + Z := LNPI - {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(Z) - StirfL(A); + end + else + Z := StirfL(X); + LnGamma := Z; + end + else if X < 13.0 then + begin + Z := 1.0; + X1 := X; + while X1 >= 3 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < 2.0 do + begin + if Abs(X1) <= 0.03125 then + begin + LnGamma := {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(Abs(GamSmall(X1, Z))); + Exit; + end; + Z := Z / X1; + X1 := X1 + 1.0; + end; + if Z < 0.0 then Z := - Z; + if X1 = 2.0 then + LnGamma := {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(Z) + else + begin + X1 := X1 - 2.0; + LnGamma := X1 * PolEvl(X1, P, 6) / P1Evl(X1, Q, 7) + + {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(Z); + end; + end + else + LnGamma := StirfL(X); + end; + + function IGamma(A, X : Float) : Float; + var + Ans, Ax, C, R : Float; + begin + MathErr := FN_OK; + + if (X <= 0.0) or (A <= 0.0) then + begin + IGamma := 0.0; + Exit; + end; + + if (X > 1.0) and (X > A) then + begin + IGamma := 1.0 - JGamma(A, X); + Exit; + end; + + Ax := A * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) - X - LnGamma(A); + if Ax < MINLOG then + begin + IGamma := DefaultVal(FN_UNDERFLOW); + Exit; + end; + + Ax := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(Ax); + + { power series } + R := A; + C := 1.0; + Ans := 1.0; + + repeat + R := R + 1.0; + C := C * X / R; + Ans := Ans + C; + until C / Ans <= MACHEP; + + IGamma := Ans * Ax / A; + end; + + function JGamma(A, X : Float) : Float; + var + Ans, C, Yc, Ax, Y, Z, R, T, + Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2 : Float; + begin + MathErr := FN_OK; + + if (X <= 0.0) or (A <= 0.0) then + begin + JGamma := 1.0; + Exit; + end; + + if (X < 1.0) or (X < A) then + begin + JGamma := 1.0 - IGamma(A, X); + Exit; + end; + + Ax := A * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) - X - LnGamma(A); + + if Ax < MINLOG then + begin + JGamma := DefaultVal(FN_UNDERFLOW); + Exit; + end; + + Ax := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(Ax); + + { continued fraction } + Y := 1.0 - A; + Z := X + Y + 1.0; + C := 0.0; + Pkm2 := 1.0; + Qkm2 := X; + Pkm1 := X + 1.0; + Qkm1 := Z * X; + Ans := Pkm1 / Qkm1; + + repeat + C := C + 1.0; + Y := Y + 1.0; + Z := Z + 2.0; + Yc := Y * C; + Pk := Pkm1 * Z - Pkm2 * Yc; + Qk := Qkm1 * Z - Qkm2 * Yc; + if Qk <> 0.0 then + begin + R := Pk / Qk; + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + if Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 / BIG; + Pkm1 := Pkm1 / BIG; + Qkm2 := Qkm2 / BIG; + Qkm1 := Qkm1 / BIG; + end; + until T <= MACHEP; + + JGamma := Ans * Ax; + end; + + function Fact(N : Integer) : Float; + begin + MathErr := FN_OK; + if N < 0 then + Fact := DefaultVal(FN_DOMAIN) + else if N > MAXFAC then + Fact := DefaultVal(FN_OVERFLOW) + else if N <= NFACT then + Fact := FactArray[N] + else + Fact := Gamma(N + 1); + end; + + function Binomial(N, K : Integer) : Float; + var + I, N1 : Integer; + Prod : Float; + begin + MathErr := FN_OK; + if K < 0 then + Binomial := 0.0 + else if (K = 0) or (K = N) then + Binomial := 1.0 + else if (K = 1) or (K = N - 1) then + Binomial := N + else + begin + if K > N - K then K := N - K; + N1 := Succ(N); + Prod := N; + for I := 2 to K do + Prod := Prod * (Int(N1 - I) / Int(I)); + Binomial := Int(0.5 + Prod); + end; + end; + + function Beta(X, Y : Float) : Float; + { Computes Beta(X, Y) = Gamma(X) * Gamma(Y) / Gamma(X + Y) } + var + Lx, Ly, Lxy : Float; + SgnBeta : Integer; + begin + MathErr := FN_OK; + SgnBeta := SgnGamma(X) * SgnGamma(Y) * SgnGamma(X + Y); + Lxy := LnGamma(X + Y); + if MathErr <> FN_OK then + begin + Beta := 0.0; + Exit; + end; + Lx := LnGamma(X); + if MathErr <> FN_OK then + begin + Beta := SgnBeta * MAXNUM; + Exit; + end; + Ly := LnGamma(Y); + if MathErr <> FN_OK then + begin + Beta := SgnBeta * MAXNUM; + Exit; + end; + Beta := SgnBeta * {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(Lx + Ly - Lxy); + end; + + function PSeries(A, B, X : Float) : Float; + { Power series for incomplete beta integral. Use when B*X is small } + var + S, T, U, V, T1, Z, Ai : Float; + N : Integer; + begin + Ai := 1.0 / A; + U := (1.0 - B) * X; + V := U / (A + 1.0); + T1 := V; + T := U; + N := 2; + S := 0.0; + Z := MACHEP * Ai; + while Abs(V) > Z do + begin + U := (N - B) * X / N; + T := T * U; + V := T / (A + N); + S := S + V; + N := N + 1; + end; + S := S + T1; + S := S + Ai; + + U := A * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X); + if (A + B < MAXGAM) and (Abs(U) < MAXLOG) then + begin + T := Gamma(A + B) / (Gamma(A) * Gamma(B)); + S := S * T * Power(X, A); + end + else + begin + T := LnGamma(A + B) - LnGamma(A) - LnGamma(B) + + U + {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(S); + if T < MINLOG then + S := 0.0 + else + S := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(T); + end; + PSeries := S; + end; + + function CFrac1(A, B, X : Float) : Float; + { Continued fraction expansion #1 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := A + B; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := B - 1.0; + K7 := K4; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MACHEP; + + repeat + Xk := - (X * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (X * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 + 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 - 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 * BIGINV; + Pkm1 := Pkm1 * BIGINV; + Qkm2 := Qkm2 * BIGINV; + Qkm1 := Qkm1 * BIGINV; + end; + + if (Abs(Qk) < BIGINV) or (Abs(Pk) < BIGINV) then + begin + Pkm2 := Pkm2 * BIG; + Pkm1 := Pkm1 * BIG; + Qkm2 := Qkm2 * BIG; + Qkm1 := Qkm1 * BIG; + end; + N := N + 1; + until N > 400; + MathErr := FN_PLOSS; + +CDone: + CFrac1 := Ans; + end; + + function CFrac2(A, B, X : Float) : Float; + { Continued fraction expansion #2 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Z, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := B - 1.0; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := A + B; + K7 := A + 1.0; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Z := X / (1.0 - X); + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MACHEP; + + repeat + Xk := - (Z * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (Z * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 - 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 + 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 * BIGINV; + Pkm1 := Pkm1 * BIGINV; + Qkm2 := Qkm2 * BIGINV; + Qkm1 := Qkm1 * BIGINV; + end; + + if (Abs(Qk) < BIGINV) or (Abs(Pk) < BIGINV) then + begin + Pkm2 := Pkm2 * BIG; + Pkm1 := Pkm1 * BIG; + Qkm2 := Qkm2 * BIG; + Qkm1 := Qkm1 * BIG; + end; + N := N + 1; + until N > 400; + MathErr := FN_PLOSS; + +CDone: + CFrac2 := Ans; + end; + + function IBeta(A, B, X : Float) : Float; + var + A1, B1, X1, T, W, Xc, Y : Float; + Flag : Boolean; + label + Done; + begin + MathErr := FN_OK; + + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + begin + IBeta := DefaultVal(FN_DOMAIN); + Exit; + end; + + if (X = 0.0) or (X = 1.0) then + begin + IBeta := X; + Exit; + end; + + Flag := False; + if (B * X <= 1.0) and (X <= 0.95) then + begin + T := PSeries(A, B, X); + goto Done; + end; + + W := 1.0 - X; + + { Reverse a and b if x is greater than the mean. } + if X > A / (A + B) then + begin + Flag := True; + A1 := B; + B1 := A; + Xc := X; + X1 := W; + end + else + begin + A1 := A; + B1 := B; + Xc := W; + X1 := X; + end; + + if Flag and (B1 * X1 <= 1.0) and (X1 <= 0.95) then + begin + T := PSeries(A1, B1, X1); + goto Done; + end; + + { Choose expansion for optimal convergence } + Y := X1 * (A1 + B1 - 2.0) - (A1 - 1.0); + if Y < 0.0 then + W := CFrac1(A1, B1, X1) + else + W := CFrac2(A1, B1, X1) / Xc; + + { Multiply w by the factor + a b _ _ _ + x (1-x) | (a+b) / ( a | (a) | (b) ) } + + Y := A1 * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X1); + T := B1 * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(Xc); + if (A1 + B1 < MAXGAM) and (Abs(Y) < MAXLOG) and (Abs(T) < MAXLOG) then + begin + T := Power(Xc, B1) ; + T := T * Power(X1, A1); + T := T / A1; + T := T * W; + T := T * Gamma(A1 + B1) / (Gamma(A1) * Gamma(B1)); + end + else + begin + { Resort to logarithms } + Y := Y + T + LnGamma(A1 + B1) - LnGamma(A1) - LnGamma(B1) + + {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(W / A1); + if Y < MINLOG then + T := 0.0 + else + T := {$IFDEF CPU387}fExp{$ELSE}Exp{$ENDIF}(Y); + end; + +Done: + if Flag then + if T <= MACHEP then + T := 1.0 - MACHEP + else + T := 1.0 - T; + + IBeta := T; + end; + + function Erf(X : Float) : Float; + begin + if X < 0.0 then + Erf := - IGamma(0.5, Sqr(X)) + else + Erf := IGamma(0.5, Sqr(X)); + end; + + function Erfc(X : Float) : Float; + begin + if X < 0.0 then + Erfc := 1.0 + IGamma(0.5, Sqr(X)) + else + Erfc := JGamma(0.5, Sqr(X)); + end; + +{ ---------------------------------------------------------------------- + Probability functions + ---------------------------------------------------------------------- } + + function PBinom(N : Integer; P : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + PBinom := DefaultVal(FN_DOMAIN) + else if K = 0 then + PBinom := IntPower(1.0 - P, N) + else if K = N then + PBinom := IntPower(P, N) + else + PBinom := Binomial(N, K) * IntPower(P, K) * IntPower(1.0 - P, N - K); + end; + + function FBinom(N : Integer; P : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + FBinom := DefaultVal(FN_DOMAIN) + else if K = 0 then + FBinom := IntPower(1.0 - P, N) + else if K = N then + FBinom := 1.0 + else + FBinom := 1.0 - IBeta(K + 1, N - K, P); + end; + + function PPoisson(Mu : Float; K : Integer) : Float; + var + P : Float; + I : Integer; + begin + MathErr := FN_OK; + if (Mu <= 0.0) or (K < 0) then + PPoisson := DefaultVal(FN_DOMAIN) + else if K = 0 then + PPoisson := Expo(- Mu) + else + begin + P := Mu; + for I := 2 to K do + P := P * Mu / I; + PPoisson := Expo(- Mu) * P; + end; + end; + + function FPoisson(Mu : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (Mu <= 0.0) or (K < 0) then + FPoisson := DefaultVal(FN_DOMAIN) + else if K = 0 then + FPoisson := Expo(- Mu) + else + FPoisson := JGamma(K + 1, Mu); + end; + + function DNorm(X : Float) : Float; + begin + DNorm := INVSQRT2PI * Expo(- 0.5 * Sqr(X)); + end; + + function FNorm(X : Float) : Float; + begin + FNorm := 0.5 * (1.0 + Erf(X * SQRT2DIV2)); + end; + + function InvNorm(P : Float) : Float; +{ ---------------------------------------------------------------------- + Inverse of Normal distribution function + + Returns the argument, X, for which the area under the Gaussian + probability density function (integrated from minus infinity to X) + is equal to P. + + Translated from Cephes library. + ---------------------------------------------------------------------- } + const + P0 : TabCoef = ( + 8.779679420055069160496E-3, + - 7.649544967784380691785E-1, + 2.971493676711545292135E0, + - 4.144980036933753828858E0, + 2.765359913000830285937E0, + - 9.570456817794268907847E-1, + 1.659219375097958322098E-1, + - 1.140013969885358273307E-2, + 0, 0); + + Q0 : TabCoef = ( + - 5.303846964603721860329E0, + 9.908875375256718220854E0, + - 9.031318655459381388888E0, + 4.496118508523213950686E0, + - 1.250016921424819972516E0, + 1.823840725000038842075E-1, + - 1.088633151006419263153E-2, + 0, 0, 0); + + P1 : TabCoef = ( + 4.302849750435552180717E0, + 4.360209451837096682600E1, + 9.454613328844768318162E1, + 9.336735653151873871756E1, + 5.305046472191852391737E1, + 1.775851836288460008093E1, + 3.640308340137013109859E0, + 3.691354900171224122390E-1, + 1.403530274998072987187E-2, + 1.377145111380960566197E-4); + + Q1 : TabCoef = ( + 2.001425109170530136741E1, + 7.079893963891488254284E1, + 8.033277265194672063478E1, + 5.034715121553662712917E1, + 1.779820137342627204153E1, + 3.845554944954699547539E0, + 3.993627390181238962857E-1, + 1.526870689522191191380E-2, + 1.498700676286675466900E-4, + 0); + + P2 : TabCoef = ( + 3.244525725312906932464E0, + 6.856256488128415760904E0, + 3.765479340423144482796E0, + 1.240893301734538935324E0, + 1.740282292791367834724E-1, + 9.082834200993107441750E-3, + 1.617870121822776093899E-4, + 7.377405643054504178605E-7, + 0, 0); + + Q2 : TabCoef = ( + 6.021509481727510630722E0, + 3.528463857156936773982E0, + 1.289185315656302878699E0, + 1.874290142615703609510E-1, + 9.867655920899636109122E-3, + 1.760452434084258930442E-4, + 8.028288500688538331773E-7, + 0, 0, 0); + + P3 : TabCoef = ( + 2.020331091302772535752E0, + 2.133020661587413053144E0, + 2.114822217898707063183E-1, + - 6.500909615246067985872E-3, + - 7.279315200737344309241E-4, + - 1.275404675610280787619E-5, + - 6.433966387613344714022E-8, + - 7.772828380948163386917E-11, + 0, 0); + + Q3 : TabCoef = ( + 2.278210997153449199574E0, + 2.345321838870438196534E-1, + - 6.916708899719964982855E-3, + - 7.908542088737858288849E-4, + - 1.387652389480217178984E-5, + - 7.001476867559193780666E-8, + - 8.458494263787680376729E-11, + 0, 0, 0); + + var + X, Y, Z, Y2, X0, X1 : Float; + Code : Integer; + begin + if (P <= 0.0) or (P >= 1.0) then + begin + InvNorm := DefaultVal(FN_DOMAIN); + Exit; + end; + + Code := 1; + Y := P; + if Y > (1.0 - 0.13533528323661269189) then { 0.135... = exp(-2) } + begin + Y := 1.0 - Y; + Code := 0; + end; + if Y > 0.13533528323661269189 then + begin + Y := Y - 0.5; + Y2 := Y * Y; + X := Y + Y * (Y2 * PolEvl(Y2, P0, 7) / P1Evl(Y2, Q0, 7)); + X := X * SQRT2PI; + InvNorm := X; + Exit; + end; + + X := Sqrt(- 2.0 * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(Y)); + X0 := X - {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) / X; + Z := 1.0 / X; + if X < 8.0 then + X1 := Z * PolEvl(Z, P1, 9) / P1Evl(Z, Q1, 9) + else if X < 32.0 then + X1 := Z * PolEvl(Z, P2, 7) / P1Evl(Z, Q2, 7) + else + X1 := Z * PolEvl(Z, P3, 7) / P1Evl(Z, Q3, 7); + X := X0 - X1; + if Code <> 0 then + X := - X; + InvNorm := X; + end; + + function PNorm(X : Float) : Float; + var + A : Float; + begin + A := Abs(X); + MathErr := FN_OK; + if A = 0.0 then + PNorm := 1.0 + else if A < 1.0 then + PNorm := 1.0 - Erf(A * SQRT2DIV2) + else + PNorm := Erfc(A * SQRT2DIV2); + end; + + function DStudent(Nu : Integer; X : Float) : Float; + var + L, P, Q : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + DStudent := DefaultVal(FN_DOMAIN) + else + begin + P := 0.5 * (Nu + 1); + Q := 0.5 * Nu; + L := LnGamma(P) - LnGamma(Q) + - 0.5 * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(Nu * PI) + - P * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(1.0 + Sqr(X) / Nu); + DStudent := Expo(L); + end; + end; + + function FStudent(Nu : Integer; X : Float) : Float; + var + F : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + FStudent := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + FStudent := 0.5 + else + begin + F := 0.5 * IBeta(0.5 * Nu, 0.5, Nu / (Nu + Sqr(X))); + if X < 0.0 then FStudent := F else FStudent := 1.0 - F; + end; + end; + + function PStudent(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + PStudent := DefaultVal(FN_DOMAIN) + else + PStudent := IBeta(0.5 * Nu, 0.5, Nu / (Nu + Sqr(X))); + end; + + function DKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + DKhi2 := DGamma(0.5 * Nu, 0.5, X); + end; + + function FKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu < 1) or (X <= 0.0) then + FKhi2 := DefaultVal(FN_DOMAIN) + else + FKhi2 := IGamma(0.5 * Nu, 0.5 * X); + end; + + function PKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu < 1) or (X <= 0.0) then + PKhi2 := DefaultVal(FN_DOMAIN) + else + PKhi2 := JGamma(0.5 * Nu, 0.5 * X); + end; + + function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + var + P1, P2, R, S, L : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + DSnedecor := DefaultVal(FN_DOMAIN) + else + begin + R := Int(Nu1) / Int(Nu2); + P1 := 0.5 * Nu1; + P2 := 0.5 * Nu2; + S := P1 + P2; + L := LnGamma(S) - LnGamma(P1) - LnGamma(P2) + + P1 * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(R); + L := L + (P1 - 1.0) * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) + - S * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(1.0 + R * X); + DSnedecor := Expo(L); + end; + end; + + function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + FSnedecor := DefaultVal(FN_DOMAIN) + else + FSnedecor := 1.0 - IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); + end; + + function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + PSnedecor := DefaultVal(FN_DOMAIN) + else + PSnedecor := IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); + end; + + function DExpo(A, X : Float) : Float; + begin + if (A <= 0.0) or (X < 0.0) then + DExpo := DefaultVal(FN_DOMAIN) + else + DExpo := A * Expo(- A * X); + end; + + function FExpo(A, X : Float) : Float; + begin + if (A <= 0.0) or (X < 0.0) then + FExpo := DefaultVal(FN_DOMAIN) + else + FExpo := 1.0 - Expo(- A * X); + end; + + function DBeta(A, B, X : Float) : Float; + var + L : Float; + begin + MathErr := FN_OK; + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + DBeta := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + if A < 1.0 then DBeta := DefaultVal(FN_SING) else DBeta := 0.0 + else if X = 1.0 then + if B < 1.0 then DBeta := DefaultVal(FN_SING) else DBeta := 0.0 + else + begin + L := LnGamma(A + B) - LnGamma(A) - LnGamma(B); + L := L + (A - 1.0) * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) + + (B - 1.0) * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(1.0 - X); + DBeta := Expo(L); + end; + end; + + function FBeta(A, B, X : Float) : Float; + begin + FBeta := IBeta(A, B, X); + end; + + function DGamma(A, B, X : Float) : Float; + var + L : Float; + begin + MathErr := FN_OK; + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) then + DGamma := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + if A < 1.0 then + DGamma := DefaultVal(FN_SING) + else if A = 1.0 then + DGamma := B + else + DGamma := 0.0 + else + begin + L := A * Ln(B) - LnGamma(A) + + (A - 1.0) * {$IFDEF CPU387}fLn{$ELSE}Ln{$ENDIF}(X) - B * X; + DGamma := Expo(L); + end; + end; + + function FGamma(A, B, X : Float) : Float; + begin + FGamma := IGamma(A, B * X); + end; + +{ ---------------------------------------------------------------------- + Random numbers + ---------------------------------------------------------------------- } + +var + X1, X2 : LongInt; { Uniform random integers } + C1, C2 : LongInt; { Carries } + Gauss_Save : Float; { Saves a gaussian random number } + Gauss_Set : Boolean; { Flags if a gaussian number has been saved } + + procedure RMarIn(Seed1, Seed2 : Integer); + begin + X1 := Seed1; + X2 := Seed2; + C1 := 0; + C2 := 0; + end; + + function IRanMar : LongInt; + var + Y1, Y2 : LongInt; + begin + Y1 := 18000 * X1 + C1; + X1 := Y1 and 65535; + C1 := Y1 shr 16; + Y2 := 30903 * X2 + C2; + X2 := Y2 and 65535; + C2 := Y2 shr 16; + IRanMar := (X1 shl 16) + (X2 and 65535); + end; + + function RanMar : Float; + begin + RanMar := (IRanMar + 2147483648.0) / 4294967296.0; + end; + + function RanGaussStd : Float; + { Computes 2 random numbers from the standard normal distribution, + returns one and saves the other for the next call } + var + R, Theta, SinTheta, CosTheta : Float; + begin + if not Gauss_Set then + begin + R := Sqrt(- 2.0 * Log(RanMar)); + Theta := TWOPI * RanMar; + SinCos(Theta, SinTheta, CosTheta); + RanGaussStd := R * CosTheta; { Return 1st number } + Gauss_Save := R * SinTheta; { Save 2nd number } + end + else + RanGaussStd := Gauss_Save; { Return saved number } + Gauss_Set := not Gauss_Set; + end; + + function RanGauss(Mu, Sigma : Float) : Float; + { Returns a random number from the normal distribution + with mean Mu and standard deviation Sigma } + begin + RanGauss := Mu + Sigma * RanGaussStd; + end; + +{ ---------------------------------------------------------------------- + Initialization code + ---------------------------------------------------------------------- } + +var + I : Integer; + +begin + { Initialize MathErr } + MathErr := FN_OK; + + { Store the factorials of the first NFACT integers in a table } + FactArray[0] := 1.0; + FactArray[1] := 1.0; + FactArray[2] := 2.0; + for I := 3 to NFACT do + FactArray[I] := FactArray[I - 1] * I; + + { Initialize random number generators } + Gauss_Save := 0.0; + Gauss_Set := False; + RMarIn(1802, 9373); +end. diff --git a/niftiview7/foreign2nifti.pas b/niftiview7/foreign2nifti.pas new file mode 100755 index 0000000..9a25381 --- /dev/null +++ b/niftiview7/foreign2nifti.pas @@ -0,0 +1,15 @@ +unit foreign2nifti; + +interface + +//function xreadForeignHeader (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + +implementation + +(*function xreadForeignHeader (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +begin + result := true; +end;*) + +end. + \ No newline at end of file diff --git a/niftiview7/graphx.pas b/niftiview7/graphx.pas new file mode 100755 index 0000000..a046c8a --- /dev/null +++ b/niftiview7/graphx.pas @@ -0,0 +1,1071 @@ +unit graphx; + +interface +{$DEFINE FFTs} +uses +{$IFDEF FFTs} + FFTs, +{$ENDIF} + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Buttons, ToolWin, ComCtrls,define_types, ExtCtrls,Text, StdCtrls, + RXSpin,perisettings, Menus,ClipBrd,metagraph,periplot; + +Type + TGraph4DForm = class(TForm) + Image1: TImage; + StatusBar1: TStatusBar; + FourDBar: TPanel; + TREdit: TRxSpinEdit; + HSpeedDrop: TComboBox; + TrackBar1: TTrackBar; + MainMenu1: TMainMenu; + File1: TMenuItem; + Edit1: TMenuItem; + CopyMenu: TMenuItem; + Closewindow1: TMenuItem; + SaveMenu: TMenuItem; + TRLabel: TLabel; + Openmenu: TMenuItem; + MinEdit: TRxSpinEdit; + MaxEdit: TRxSpinEdit; + FFTmenu: TMenuItem; + Extract4Drois: TMenuItem; + BatchMenu: TMenuItem; + FSLbatch1: TMenuItem; + OpenDataBtn: TSpeedButton; + RefreshBtn: TSpeedButton; + PlotBtn: TSpeedButton; + TextBtn: TSpeedButton; + //procedure Plot4DFFT(lStartSample: integer); + //function XL: boolean; + procedure FormShow(Sender: TObject); + function ReadGraf(lFilename: string; lBatch,lTRcritical: boolean): boolean; + procedure FormCreate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure Plot4DTrace(lStartSample: integer); + procedure TrackBar1Change(Sender: TObject); + procedure OpenDataClick(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure PSPlotClick(Sender: TObject); + procedure PSTextClick(Sender: TObject); + //procedure rfx; + procedure CopyMenuClick(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure SaveMenuClick(Sender: TObject); + procedure FFTmenuClick(Sender: TObject); + procedure RefreshBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Extract4DroisClick(Sender: TObject); + procedure BatchMenuClick(Sender: TObject); + procedure RefreshBtnClick(Sender: TObject); + procedure FSLbatch1Click(Sender: TObject); + procedure FSLtest1Click(Sender: TObject); + + private + + public + { Public declarations } + end; + +var + Graph4DForm: TGraph4DForm; + +implementation + +uses + nifti_img_view, nifti_img,nifti_hdr, nifti_hdr_view,{ShellAPI,}ShlObj,periutils, reslice_fsl; +const + //kMaxCond = 6; + kMaxLines = kMaxCond* knMaxOverlay; + //kClrRA: array [1..kMaxCond] of TColor = (clRed,clBlue,clGreen,clTeal,clAqua,clSilver); + //kPenStyleRA: array[1..kVOIOverlayNum] of TPenStyle = (psDot,psDot,psDash,psDashDot,psDashDotDot);//abba + //kPenStyleRA: array[1..kVOIOverlayNum] of TPenStyle = (psSolid,psDot,psDash,psDashDot,psDashDotDot); + + +{$R *.DFM} +var + g4DHdr: TMRIcroHdr; + g4Ddata: T4DTrace; + + +(*procedure PrepPlot(var lImage: TMetafileCanvas; lL,lT,lR,lB,lWid,lHt,lFontSize: integer); +begin + lImage.Font.Name := 'Arial'; + lImage.Font.Size := 12; + + lImage.pen.color := clBlack; + lImage.Font.color := clBlack; + lImage.Brush.Style := bsSolid; + lImage.Brush.color := clWhite; + lImage.Rectangle(1,1,lWid,lHt); + lImage.Rectangle(lL,lT,lR,lB); +end;*) + + +{$IFDEF FFTs} +procedure ROI2FFT (var l4DHdr: TMRIcroHdr; lROInum: integer; var lFFTLines: SingleP); +var + + lVolSz,lnVol,lVol,lVox,lCount,lVolOffset,lnFFTOut,lP: integer; + l16Buf : SmallIntP; + lFFT,lFFTOut,l32Buf : SingleP; + lFFTsum: doubleP; +begin + lnVol := l4DHdr.NIFTIhdr.dim[4]; + if lnVol < 5 then + exit; + lVolSz :=l4DHdr.NIFTIhdr.dim[1]*l4DHdr.NIFTIhdr.dim[2]*l4DHdr.NIFTIhdr.dim[3]; + Getmem(lFFT,(lnVol) * Sizeof(Single)); + lnFFTout := ((lnVol) div 2)-1 ; + Getmem(lFFTout,(lnFFTout) * Sizeof(Single)); + Getmem(lFFTsum,(lnFFTout) * Sizeof(double)); + for lP := 1 to lnFFTout do + lFFTSum[lP] := 0; + + for lP := 1 to lnFFTout do + lFFTout[lP] := 0; + lVolOffset := lVolSz; + //next - compute sum of signal - unrolled loops for each datatype + lCount := 0; + if (l4DHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(l4DHdr.ImgBuffer ); + for lVox := 1 to lVolSz do begin + if gMRIcroOverlay[lROInum].ScrnBuffer[lVox] > 0 then begin + for lVol := 1 to lnVol do + lFFT[lVol] := l32Buf[lVox+((lVol-1)*lVolOffset)]; + FFTPower(lFFT,lFFTout,lnVol); + for lP := 1 to lnFFTout do + lFFTSum[lP] := lFFTSum[lP]+lFFTout[lP]; + inc(lCount); + end; //part of ROI + end; //for each vox + end else if (l4DHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(l4DHdr.ImgBuffer ); + for lVox := 1 to lVolSz do begin + if gMRIcroOverlay[lROInum].ScrnBuffer[lVox] > 0 then begin + for lVol := 1 to lnVol do + lFFT[lVol] := l16Buf[lVox+((lVol-1)*lVolOffset)]; + FFTPower(lFFT,lFFTout,lnVol); + //FFTPower(lFFT,lFFx,lnVol); + for lP := 1 to lnFFTout do + lFFTSum[lP] := lFFTSum[lP]+lFFTout[lP]; + inc(lCount); + end; //part of ROI + end; //for each vox + end else if l4DHdr.ImgBufferBPP = 1 then begin + for lVox := 1 to lVolSz do begin + if gMRIcroOverlay[lROInum].ScrnBuffer[lVox] > 0 then begin + for lVol := 1 to lnVol do + lFFT[lVol] := l4DHdr.ImgBuffer[lVox+((lVol-1)*lVolOffset)]; + FFTPower(lFFT,lFFTout,lnVol); + for lP := 1 to lnFFTout do + lFFTSum[lP] := lFFTSum[lP]+lFFTout[lP]; + inc(lCount); + end; //part of ROI + end; //for each vox + end else + showmessage('Serious error: unknown data size!'); + //now compute mean signal + if lCount > 0 then begin + for lP := 1 to lnFFTout do + lFFTSum[lP] := lFFTSum[lP] / lCount; + for lP := 1 to lnFFTout do + if specialdouble(lFFTSum[lP]) then + lFFTSum[lP] := 0; + end; + for lP := 1 to lnFFTout do + lFFTLines[lP] := lFFTSum[lP]; + freemem(lFFT); + freemem(lFFTout); + freemem(lFFTsum); +end; + +procedure Plot4DFFT(lStartSample: integer); +var + //lDataOut: SingleP; + lLines,N,I: Integer; + l4DTrace: T4DTrace; +begin + if (g4dData.lines[1].events < 5) then exit; + lLines := 1; + for I := 2 to kMaxLines do + if g4dData.lines[I].events =g4dData.lines[1].events then + inc(lLines); + N := g4dData.lines[1].events; + N := (N div 2)-1; + Create4DTrace ( l4DTrace); + Init4DTrace(N,lLines,l4DTrace,false); + lLines := 0; + for I := 1 to kMaxLines do + if g4dData.lines[I].events =g4dData.lines[1].events then begin + inc(lLines); + l4DTrace.lines[lLines].eLabel := ROIoverlayNameShort(0);// g4dData.lines[I].eLabel; + N := g4dData.lines[I].events; + FFTPower(g4dData.lines[I].EventRA,l4DTrace.lines[lLines].EventRA,N); + end; //events[i] = events[1] + MinMax4DTrace(l4dtrace); + l4dtrace.HorzMin := 0; + //range will be 0.. 1/TR*Nyquist Sec/Cycle + if Graph4DForm.TREdit.value = 0 then + l4dtrace.HorzWidPerBin := (0.5)/(l4dTrace.lines[1].events-1) + else + l4dtrace.HorzWidPerBin := ((1/Graph4DForm.TREdit.value)*0.5)/(l4dTrace.lines[1].events-1); + CorePlot4DTrace(l4Dtrace,Graph4DForm.Image1,lStartSample,Graph4DForm.HSpeedDrop.ItemIndex,-1,Graph4DForm.TREdit.value,Graph4DForm.MinEdit.value,Graph4DForm.MaxEdit.value,false); + Close4DTrace(l4Dtrace,true); +end; + + +procedure FFT4ROI (var l4DHdr: TMRIcroHdr); +var + l4DTrace: T4DTrace; + lnROI,lROI,lnVol,lnFFTOut: integer; +begin + lnVol := l4DHdr.NIFTIhdr.dim[4]; + if lnVol < 5 then + exit; + lnROI := numROI; + if lnROI < 1 then begin + Plot4DFFT(1); + exit; + end; + Create4DTrace ( l4DTrace); + lnFFTout := (lnVol div 2) -1; + Init4DTrace(lnFFTout,lnROI,l4DTrace,false); + for lROI := 1 to lnROI do begin + ROI2FFT(l4DHdr,ROIoverlayNum(lROI),l4DTrace.Lines[lROI].EventRA); + l4DTrace.Lines[lROI].elabel := ROIoverlayNameShort(lROI); + end; + MinMax4DTrace(l4dtrace); + l4dtrace.HorzMin := 0; + //range will be 0.. 1/TR*Nyquist Sec/Cycle + if Graph4DForm.TREdit.value = 0 then + l4dtrace.HorzWidPerBin := (0.5)/(l4dTrace.lines[1].events-1) + else + l4dtrace.HorzWidPerBin := ((1/Graph4DForm.TREdit.value)*0.5)/(l4dTrace.lines[1].events-1); + CorePlot4DTrace(l4Dtrace,Graph4DForm.Image1,1,Graph4DForm.HSpeedDrop.ItemIndex,-1,Graph4DForm.TREdit.value,Graph4DForm.MinEdit.value,Graph4DForm.MaxEdit.value,false); + Close4DTrace(l4Dtrace,true); +end; +{$ENDIF} + +procedure TGraph4DForm.Plot4DTrace(lStartSample: integer); +begin + + + g4Ddata.HorzWidPerBin := TREdit.value; + CorePlot4DTrace(g4Ddata,Image1,lStartSample,HSpeedDrop.ItemIndex,-1,TREdit.value,MinEdit.value,MaxEdit.value,false); + //StatusBar1.Panels[1].Text := 'Offset:'+inttostr(lStartSample); + //ShowLegend(g4Ddata,Image1, 50,5); +end; + + + +procedure TextToTrace (var l4DTrace: T4DTrace); +var + lStr: string; + lCond, lnCond,lE: integer; +begin + lncond := 0; + for lCond := 1 to kMaxCond do + if l4DTrace.Lines[lCond].Events > 0 then + inc(lnCond); + if lncond = 0 then + exit; + for lCond := 1 to kMaxCond do begin + if l4DTrace.Lines[lCond].Events > 0 then begin + lStr := gMRIcroOverlay[kBGOverlayNum].HdrFileName+kTextSep+l4DTrace.Lines[lCond].ELabel; + for lE := 1 to l4DTrace.Lines[lCond].Events do + lStr := lStr + kTextSep+ realtostr(l4DTrace.Lines[lCond].EventRA[lE],4) ; + TextForm.MemoT.lines.add(lStr); + + end; + end; +end; + +function TGraph4DForm.ReadGraf(lFilename: string; lBatch,lTRcritical: boolean): boolean; +label + 666; +var + lnVol: integer; + lReslice : boolean; +begin + ImgForm.CloseImagesClick(nil); + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + result := false; + if not fileexists(lFilename) then exit; + Graph4DForm.Caption := 'Viewing: '+lFilename; + lReslice := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + gBGImg.Prompt4DVolume := false; + //if not lBatch then begin //12/2007 + ImgForm.OpenAndDisplayImg(lFilename,True); + lnVol := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[4]; + if (lnVol < 2) then begin + showmessage('You need to open a 4D image.'); + goto 666; + end; + if not HdrForm.OpenAndDisplayHdr(lFilename,g4DHdr) then goto 666; + if not OpenImg(gBGImg,g4DHdr,false,false,false,false,true {4D!}) then goto 666; + TrackBar1.Max := lnVol; + if gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.PixDim[4] = 0 then begin + beep; + ImgForm.StatusLabel.caption := 'Assuming TR = '+floattostr(TREdit.value); + end else + TREdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.PixDim[4];//TR + if (TREdit.value = 0) and (lTRcritical) then + showmessage('Please set the TR value [in seconds]'); + result := true; +666: + gBGImg.ResliceOnLoad := lReslice; + gBGImg.Prompt4DVolume := true; +end; + +procedure TGraph4DForm.FormShow(Sender: TObject); +begin +end; +(*{x$IFDEF FFTs} +procedure TGraph4DForm.FormShow(Sender: TObject); +var + lFilename: string; +begin + //abba + lFilename := 'C:\cygwin\home\mscae\20061220_140508\'; + //ReadCond(lFilename+'puls.txt',g4Ddata,1); + //ReadCond(lFilename+'resp.txt',g4Ddata,2); + HdrForm.OpenHdrDlg.Filename := lFilename+'rachris.nii.gz'; + ReadGraf(HdrForm.OpenHdrDlg.Filename ); + ImgForm.XViewEdit. value := 43; + ImgForm.YViewEdit. value := 37; + ImgForm.ZViewEdit. value := 22; + PSForm.BinWidthEdit.value := 0.1; + PSForm.PreBinEdit.value := 5; + PSForm.PostBinEdit.value := 5; + lFilename := 'C:\cygwin\home\mscae\20061220_140508\ravoi.voi'; + //ImgForm.OverlayOpenCore ( lFilename, kBGOverlayNum+1); + + RefreshBtnClick(nil); +end; +{x$ELSE} //no FFT + +procedure TGraph4DForm.FormShow(Sender: TObject); +var + lFilename: string; + //lReslice : boolean; +begin + //lReslice :=gReslice; + //gReslice := false; + ReadCond(extractfiledir(paramstr(0))+'\L_Tap.txt',g4Ddata,1); + ReadCond(extractfiledir(paramstr(0))+'\R_Tap.txt',g4Ddata,2); + HdrForm.OpenHdrDlg.Filename := extractfiledir(paramstr(0))+'\filtered_func_data.nii.gz'; + ReadGraf(HdrForm.OpenHdrDlg.Filename ); + ImgForm.XViewEdit. value := 42; + ImgForm.YViewEdit. value := 29; + ImgForm.ZViewEdit. value := 28; + + lFilename := extractfiledir(paramstr(0))+'\Left.voi'; + ImgForm.OverlayOpenCore ( lFilename, kBGOverlayNum+1); + //VR( lFilename, 1); + //ImgForm.OpenVOICore(lFilename); + lFilename := extractfiledir(paramstr(0))+'\Right.voi'; + ImgForm.OverlayOpenCore ( lFilename,kBGOverlayNum+2); + //VR(lFilename,2); + RefreshBtnClick(nil); + //gReslice := lReslice; +end; +{x$ENDIF} +*) + + +procedure TGraph4DForm.FormCreate(Sender: TObject); +begin + gWmf := TMetafile.Create; + gWmf.Enhanced := True; + Create4DTrace(g4Ddata); + //Graph4DForm.DoubleBuffered := true; + HSpeedDrop.ItemIndex := 0; + InitImgMemory(g4DHdr); +end; + +procedure TGraph4DForm.FormClose(Sender: TObject; var Action: TCloseAction); +begin + + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + //gWmf.Free; +end; + +procedure TGraph4DForm.TrackBar1Change(Sender: TObject); +begin + Trackbar1.visible := (HSpeedDrop.ItemIndex > 0); + Plot4DTrace(TrackBar1.position); +end; + +{$DEFINE notTest4D} +procedure TGraph4DForm.OpenDataClick(Sender: TObject); +var + lI,lCnt: integer; + lStr: string; +begin + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); +{$IFDEF Test4D} + if not ReadGraf('C:\tx\20091006\fsl\filtered_func_data.nii.gz',false,true) then exit; + ReadCond('C:\tx\20091006\fsl\timing.txt',g4Ddata,1); + //ReadCond('C:\fatigue\TD\b.txt',g4Ddata,2); + PSPlotClick(nil); + exit; + + if not ReadGraf('C:\fatigue\perisample\filtered_func_data.nii.gz',false,true) then exit; + ReadCond('C:\fatigue\perisample\L_Tap.txt',g4Ddata,1); + ReadCond('C:\fatigue\perisample\R_Tap.txt',g4Ddata,2); + lI := 1; + lStr := 'C:\fatigue\perisample\left.voi'; + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + PSPlotClick(nil); + exit; +{$ENDIF} + if not OpenDialogExecute(kImgFilter,'Select 4D image',false) then exit; + if not ReadGraf(HdrForm.OpenHdrDlg.Filename,false,true) then exit; + ImgForm.XViewEdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1] div 2; + ImgForm.YViewEdit.asInteger := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2] div 2; + ImgForm.ZViewEdit.asInteger := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3] div 2; + if OpenDialogExecute(kTxtFilter,'Select 3-column event onset time files [optional]',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > 0 then begin + lCnt := HdrForm.OpenHdrDlg.Files.Count; + if lCnt > kMaxCond then begin + showmessage('Can only load '+inttostr(kMaxCond)+'conditions'); + lCnt := kMaxCond; + end; + for lI := 1 to lCnt do + ReadCond(HdrForm.OpenHdrDlg.Files[lI-1],g4Ddata,lI); + end;//if count > 1 + end; //if opendialog + if OpenDialogExecute(kImgPlusVOIFilter,'Select regions of interest',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > 0 then begin + lCnt := HdrForm.OpenHdrDlg.Files.Count; + //Apr07 + if lCnt > (knMaxOverlay-2) then begin + showmessage('Can only load '+inttostr(knMaxOverlay-2)+'conditions'); + lCnt := knMaxOverlay; + end; + for lI := 1 to lCnt do begin + lStr := HdrForm.OpenHdrDlg.Files[lI-1]; + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + end; + end;//if count > 1 + end; //if opendialog + RefreshBtnMouseDown(nil,mbleft,[],1,1); + +end; + +procedure TGraph4DForm.FormResize(Sender: TObject); +begin + if not Graph4DForm.visible then + exit; + GraphResize(Image1); + Plot4DTrace(TrackBar1.position); +end; + +procedure TGraph4DForm.PSPlotClick(Sender: TObject); +var +lPSPlot: TPSPlot; +begin + if NCond ( g4Ddata) < 1 then begin + RefreshBtnMouseDown(nil,mbleft,[],1,1); + exit; + end; + lPSPlot.TRSec := TREdit.value; + if not PSForm.GetPeriSettings(lPSPlot) then + exit; + lPSPlot.TextOutput := false; + lPSPlot.GraphOutput := true; + lPSPlot.batch := false; + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot); +end; + +procedure TGraph4DForm.PSTextClick(Sender: TObject); +var lPSPlot: TPSPlot; +begin + if NCond ( g4Ddata) < 1 then begin + RefreshBtnMouseDown(nil,mbleft,[],1,1); + TextForm.MemoT.Lines.Clear;//prepare to report results + TextToTrace (g4Ddata); + TextForm.show; + exit; + end; + lPSPlot.TRSec := TREdit.value; + if not PSForm.GetPeriSettings(lPSPlot) then + exit; + lPSPlot.TextOutput := true; + lPSPlot.GraphOutput := true; + lPSPlot.batch := false; + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot); +end; + +procedure TGraph4DForm.CopyMenuClick(Sender: TObject); + +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; +begin +//rfx; + if gWMF.Empty then begin + showmessage('Please Open a dataset first.'); + exit; + end; + gWmf.SaveToClipboardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); +end; + + +procedure TGraph4DForm.FormDestroy(Sender: TObject); +begin +//gWmf.Free; +end; + +procedure TGraph4DForm.Closewindow1Click(Sender: TObject); +begin + Graph4DForm.Close; +end; + +procedure TGraph4DForm.SaveMenuClick(Sender: TObject); +begin + if gWMF.Empty then begin + showmessage('Please Open a dataset first.'); + exit; + end; + ImgForm.SaveDialog1.Filter := 'Enhanced Metafile|*.emf'; + ImgForm.SaveDialog1.DefaultExt := '*.emf'; + if not ImgForm.SaveDialog1.Execute then exit; + gWmf.SaveToFile (ChangeFileExt(ImgForm.SaveDialog1.FileName,'.emf')); +end; + +procedure TGraph4DForm.FFTmenuClick(Sender: TObject); +begin +{$IFDEF FFTs} + FFT4ROI (g4DHdr); + exit; +{$ENDIF} +showmessage('FFT not included with this build.'); +end; + +procedure TGraph4DForm.RefreshBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + if (g4DHdr.ImgBufferItems = 0) then begin + showmessage('You must first load 4D data [Press the ''Open Data'' button.'); + exit; + end; + ConvertToTrace(g4DHdr,g4Ddata,ImgForm.XViewEdit.asInteger,ImgForm.YViewEdit.asInteger,ImgForm.ZViewEdit.asInteger); + (*if (ssAlt in Shift) then begin + TextForm.Memo1.Lines.Clear;//prepare to report results + TextToTrace (g4Ddata); + end;*) + Plot4DTrace(TrackBar1.position); +end; + +procedure TGraph4DForm.Extract4DroisClick(Sender: TObject); +const + kMin8bit = 0; + kMax8bit = 255; +var + lROInum,lVol,lnVol,lPos,lROI,lVolSz,lVolOffset: integer; + lStr: string; + SumRA : array [kMin8bit..kMax8bit] of double; + nRA : array [kMin8bit..kMax8bit] of longint; + l16Buf : SmallIntP; + l32Buf : SingleP; + lOutStr: string; +begin + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + if not OpenDialogExecute(kImgFilter,'Select 4D image',false) then exit; + if not ReadGraf(HdrForm.OpenHdrDlg.Filename,false,true) then exit; + ImgForm.XViewEdit.value := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1] div 2; + ImgForm.YViewEdit.asInteger := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2] div 2; + ImgForm.ZViewEdit.asInteger := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3] div 2; + lVolSz := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1]*gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]*gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3]; + if not OpenDialogExecute(kImgPlusVOIFilter,'Select regions of interest',false) then + exit; + lROInum := 1+kBGOverlayNum; + lStr := HdrForm.OpenHdrDlg.Filename; + ImgForm.OverlayOpenCore(lStr,lROInum); + if gMRIcroOverlay[lROInum].ImgBufferBPP <> 1 then begin + showmessage('Overlay must be 8-bit image'); + exit; + end; + if (gMRIcroOverlay[lROInum].ImgBufferItems <> lVolSz) or (lVOlSz < 1) then begin + showmessage('Overlay must have identical dimensions as 4D image'); + exit; + end; + lnVol := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[4]; + if lnVol < 2 then begin + showmessage('Requires 4D data'); + exit; + end; + if (g4DHdr.ImgBufferItems <> ({lnVol*}lVolSz)) then begin + showmessage('4D image not loaded correctly '+inttostr(g4DHdr.ImgBufferItems)+' <> '+inttostr(lVolSz)); + exit; + end; + TextForm.MemoT.Lines.Clear;//prepare to report results + //count frequency of each column... + for lPos := kMin8Bit to kMax8bit do + nRA[lPos] := 0; + for lPos := 1 to lVolSz do begin + lROI := gMRIcroOverlay[lROInum].ImgBuffer^[lPos]; //ROI must be 8-bit! + nRA[lROI] := nRA[lROI] + 1; + end; + //report detected ROI volumes + lOutStr := 'vol'; + for lROI := kMin8Bit to kMax8bit do + if nRA[lROI] > 0 then + lOutStr := lOutStr+kTextSep+inttostr(nRA[lROI]); + TextForm.MemoT.lines.add(lOutStr); + //report detected ROIs [column labels] + lOutStr := 'ROI'; + for lROI := kMin8Bit to kMax8bit do + if nRA[lROI] > 0 then + lOutStr := lOutStr+kTextSep+inttostr(lROI); + TextForm.MemoT.lines.add(lOutStr); + //compute mean intensity for each ROI at each timepoint + l32Buf := SingleP(g4DHdr.ImgBuffer); + l16Buf := SmallIntP(g4DHdr.ImgBuffer); + for lVol := 1 to lnVol do begin + lVolOffset := (lVol-1)*lVolSz; + for lPos := kMin8Bit to kMax8bit do //initialize all ROIs for this volume + SumRA[lPos] := 0; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + for lPos := 1 to lVolSz do begin + lROI := gMRIcroOverlay[lROInum].ImgBuffer^[lPos]; //ROI must be 8-bit! + SumRA[lROI] := SumRA[lROI] + l32Buf^[lPos+lVolOffset]; + end; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + for lPos := 1 to lVolSz do begin + lROI := g4DHdr.ImgBuffer^[lPos]; //ROI must be 8-bit! + SumRA[lROI] := SumRA[lROI] + l16Buf^[lPos+lVolOffset]; + end; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then begin + for lPos := 1 to lVolSz do begin + lROI := gMRIcroOverlay[lROInum].ImgBuffer^[lPos]; //ROI must be 8-bit! + SumRA[lROI] := SumRA[lROI] + gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lPos+lVolOffset]; + end; + end else begin + showmessage('Serious error: unsupported datatype!'); + exit; + end; + lOutStr := inttostr(lvol); + for lROI := kMin8Bit to kMax8bit do + if nRA[lROI] > 0 then + lOutStr := lOutStr+kTextSep+realtostr(SumRA[lROI]/nRA[lROI],4); + TextForm.MemoT.lines.add(lOutStr); + end; //for each volume + TextForm.show; + RefreshBtnMouseDown(nil,mbleft,[],1,1); +end; + +procedure TGraph4DForm.BatchMenuClick(Sender: TObject); +label + 111; +var + lStr: string; + l4D,lVectors,lVOI: TStringList; + lPSPlot: TPSPlot; + lImg,lI: integer; + (*lTRSec,lBinWidthSec: single; + lI,lImg,lnNegBins,lnPosBins: integer; + lSliceTime,lSavePSVol,lTextOutput,lGraphOutput,lBaselineCorrect,lPctSignal, + lRemoveRegressorVariability,lTemporalDeriv,lPlotModel: boolean; *) +begin + ImgForm.CloseImagesClick(nil); + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + if not OpenDialogExecute(kImgFilter,'Select 4D images',true) then exit; + l4D := TStringList.Create; + lVectors := TStringList.Create;//empty + lVOI := TStringList.Create; + l4D.AddStrings(HdrForm.OpenHdrDlg.Files); + if OpenDialogExecute(kTxtFilter,'Select 3-column event onset time files',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > kMaxCond then begin + showmessage('Can only load '+inttostr(kMaxCond)+'conditions'); + goto 111; + end; + lVectors.AddStrings(HdrForm.OpenHdrDlg.Files); + end; + if not OpenDialogExecute(kImgPlusVOIFilter,'Select region[s] of interest',true) then + goto 111; + if HdrForm.OpenHdrDlg.Files.Count > (knMaxOverlay-2) then begin + showmessage('Can only load '+inttostr(knMaxOverlay-2)+'conditions'); + goto 111; + end; + lVOI.AddStrings(HdrForm.OpenHdrDlg.Files); + if not ReadGraf(l4D[0],false, (lVectors.count > 0) ) then + goto 111; //read first dataset to set TR! + //get plot settings.... + lPSPlot.TRSec := TREdit.value; + if lVectors.count > 0 then + if not PSForm.GetPeriSettings(lPSPlot) then + goto 111; + lPSPlot.TextOutput := true; + lPSPlot.GraphOutput := false; + lPSPlot.Batch := true; + TextForm.MemoT.Lines.Clear;//prepare to report results + for lImg := 1 to l4D.Count do begin + //showmessage(l4D[lImg-1]); + if lImg > 1 then begin//we have already read 1st img + Refresh; + Close4DTrace(g4Ddata,true); + ImgForm.CloseImagesClick(nil); + FreeImgMemory(g4DHdr); + if not ReadGraf(l4D[lImg-1],true,(lVectors.count > 0)) then + goto 111; //read first dataset to set TR! + end; //all except 1st image + if lVectors.count > 0 then begin + for lI := 1 to lVectors.count do + ReadCond(lVectors[lI-1],g4Ddata,lI); + end;//vectors > 0 + if lVOI.count > 0 then begin + for lI := 1 to lVOI.count do begin + lStr := lVOI[lI-1]; + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + end;//for each VOI + end; //VOI > 0 + if lVectors.Count > 0 then + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot) + else begin + // RefreshBtnMouseDown(nil,mbleft,[],1,1); + ConvertToTrace(g4DHdr,g4Ddata,ImgForm.XViewEdit.asInteger,ImgForm.YViewEdit.asInteger,ImgForm.ZViewEdit.asInteger); + TextToTrace (g4Ddata); + RegressTrace(g4Ddata); + end; + end; + TextForm.show; + 111: + lVOI.Free; + lVectors.Free; + l4D.Free; +end; + +procedure TGraph4DForm.RefreshBtnClick(Sender: TObject); +begin + RefreshBtnMouseDown(nil,mbleft,[],1,1); +end; + + +function SelectDirectory(const Title: string; const Flag: integer): string; +//requires ShlObj in uses list +var + lpItemID : PItemIDList; + BrowseInfo : TBrowseInfo; + DisplayName : array[0..MAX_PATH] of char; + TempPath : array[0..MAX_PATH] of char; +begin + Result:=''; + FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); + with BrowseInfo do begin + hwndOwner := Application.Handle; + pszDisplayName := @DisplayName; + lpszTitle := PChar(Title); + ulFlags := Flag; + end; + lpItemID := SHBrowseForFolder(BrowseInfo); + if lpItemId <> nil then begin + SHGetPathFromIDList(lpItemID, TempPath); + Result := TempPath; + GlobalFreePtr(lpItemID); + end; +end; + +function ResliceFSLVOIs(var lFeatDirs,lVOI: TStringList): boolean; +//uses reslice +var + lDir,lV: integer; + lMatName,lFuncName,lReslicedVOIName:string; +begin + result := false; + if lFeatDirs.count < 1 then exit; + if lVOI.count < 1 then exit; + for lDir := 1 to (lFeatDirs.Count) do begin + lMatName := FSLMatName (lFeatDirs[lDir-1]); + lFuncName := FSLFuncName (lFeatDirs[lDir-1]); + for lV := 1 to lVOI.Count do begin + lReslicedVOIName := FSLReslicedVOIName (lFeatDirs[lDir-1], lVOI[lV-1]); + if not ResliceImg (lFuncName,lVOI[lV-1],lMatName,lReslicedVOIName) then begin + Showmessage('graphx reslice FSL failed.'); + exit; + end; + end;//for each VOI + end;//for each Dir + result := true; +end; +{$DEFINE notTEST} +function FindFEATFolders (var lFeatDirs:TStringList): boolean; +var + lDir,lFeatPath: string; + lSearchRec: TSearchRec; +begin + result := false; + {$IFDEF TEST} + lDir := 'C:\cygwin\home\express'; + {$ELSE} + //lDir := 'C:\cygwin\home\express'; + lDir := SelectDirectory('Choose root folder that contains .feat folders', BIF_RETURNONLYFSDIRS); + {$ENDIF} + if lDir = '' then exit; + lFeatDirs := TStringList.Create; + if FindFirst(lDir+pathdelim+'*'+'.feat', faAnyFile, lSearchRec) = 0 then begin + repeat + if (faDirectory and lSearchRec.attr) = faDirectory then begin + lFeatPath := lDir+pathdelim+lSearchRec.Name; + if Fileexists(FSLMatName(lFeatPath)) and Fileexists(FSLFuncName(lFeatPath)) then + lFeatDirs.Add(lFeatPath) + else + Showmessage('Can not find '+FSLMatName(lFeatPath) +' or '+FSLFuncName(lFeatPath) ); + end; + until (FindNext(lSearchRec) <> 0); + end; + FindClose(lSearchRec); + if lFeatDirs.Count < 1 then begin + Showmessage('Unable to find any feat dirs in path '+lDir); + lFeatDirs.free; + exit; + end; + result := true; +end; + + +procedure TGraph4DForm.FSLbatch1Click(Sender: TObject); +label + 111; +var + lStr: string; + lFeatDirs,lVectors,lVOI: TStringList; + //lTRSec,lBinWidthSec: single; + lI,lImg: integer; + lUseFSLEVs: Boolean; + lPSPlot: TPSPlot; + {lSliceTime,lSavePSVol,lTextOutput,lBaselineCorrect,lPctSignal, + lRemoveRegressorVariability,lTemporalDeriv,lUseFSLEVs,lPlotModel: boolean; } +begin + ImgForm.CloseImagesClick(nil); + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + if not FindFEATFolders (lFeatDirs) then + exit; + lVectors := TStringList.Create;//empty + lVOI := TStringList.Create; + {$IFDEF TEST} + lUseFSLEVs := false; +lFeatDirs.AddStrings(lFeatDirs); +lFeatDirs.AddStrings(lFeatDirs); +lFeatDirs.AddStrings(lFeatDirs); +lFeatDirs.AddStrings(lFeatDirs); +lFeatDirs.AddStrings(lFeatDirs); + lVectors.Add('C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\custom_timing_files\ev1.txt'); + lVectors.Add('C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\custom_timing_files\ev2.txt'); + lVectors.Add('C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\custom_timing_files\ev3.txt'); + lVOI.Add('C:\fatigue\v1.nii.gz'); + lVOI.Add('C:\fatigue\v2.nii.gz'); + {$ELSE} + FSLEVNames (lFeatDirs[0], lVectors); + lUseFSLEVs := false; + if lVectors.count > 0 then + lUseFSLEVs := OKMsg('Use event vectors from the .FEAT'+pathdelim+'custom_timing_files folder?'); //shows dialog with OK/Cancel returns true if user presses OK + if not lUseFSLEVs then begin + lVectors.clear; + if OpenDialogExecute(kTxtFilter,'Select 3-column event onset time files',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > kMaxCond then begin + showmessage('Can only load '+inttostr(kMaxCond)+'conditions'); + goto 111; + end; + lVectors.AddStrings(HdrForm.OpenHdrDlg.Files); + end; + end; //manually select EVs + + if not OpenDialogExecute(kImgPlusVOIFilter,'Select volume[s] of interest [2mm MNI space]',true) then + goto 111; + if HdrForm.OpenHdrDlg.Files.Count > (knMaxOverlay-2) then begin + showmessage('Can only load '+inttostr(knMaxOverlay-2)+'conditions'); + goto 111; + end; + lVOI.AddStrings(HdrForm.OpenHdrDlg.Files); + {$ENDIF} + if not ResliceFSLVOIs(lFeatDirs,lVOI) then begin + showmessage('Unable to reslice VOIs!'); + goto 111; + end; + lPSPlot.TextOutput := true; + lPSPlot.GraphOutput := false; + TextForm.MemoT.Lines.Clear;//prepare to report results + + + if not ReadGraf(FSLFuncName (lFeatDirs[0]),false, (lVectors.count > 0) ) then + goto 111; //read first dataset to set TR! + //la1 := (FreeRAM); + //get plot settings.... + lPSPlot.TRSec := TREdit.value; + if lVectors.count > 0 then + if not PSForm.GetPeriSettings(lPSPlot) then + goto 111; + + for lImg := 1 to lFeatDirs.Count do begin + if lImg > 1 then begin//we have already read 1st img + Refresh; + Application.processmessages; + Close4DTrace(g4Ddata,true); + ImgForm.CloseImagesClick(nil); + FreeImgMemory(g4DHdr); + //Textform.memo1.lines.add(inttostr(FreeRAM));//rascal + if not ReadGraf(FSLFuncName (lFeatDirs[lImg-1]),true,(lVectors.count > 0)) then goto 111; //read first dataset to set TR! + if lUseFSLEVs then + FSLEVNames (lFeatDirs[lImg-1], lVectors) + end; //all except 1st image + if lVectors.count > 0 then begin + for lI := 1 to lVectors.count do + ReadCond(lVectors[lI-1],g4Ddata,lI); + end;//vectors > 0 + if lVOI.count > 0 then begin + for lI := 1 to lVOI.count do begin + lStr := FSLReslicedVOIName (lFeatDirs[lImg-1], lVOI[lI-1]); + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + end;//for each VOI + end; //VOI > 0 + + if lVectors.Count > 0 then begin + if lImg = lFeatDirs.Count then + lPSPlot.GraphOutput := true; + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot) + end else begin + ConvertToTrace(g4DHdr,g4Ddata,ImgForm.XViewEdit.asInteger,ImgForm.YViewEdit.asInteger,ImgForm.ZViewEdit.asInteger); + TextToTrace (g4Ddata); + RegressTrace(g4Ddata); + end; + end; + TextForm.show; + 111: + lVOI.Free; + lVectors.Free; + lFeatDirs.free; +end; + +{$DEFINE TEST} +procedure TGraph4DForm.FSLtest1Click(Sender: TObject); +label + 111; +var + lStr: string; + lFeatDirs,lVectors,lVOI: TStringList; + lI,lImg: integer; + lUseFSLEVs: Boolean; + lPSPlot: TPSPlot; + {lSliceTime,lSavePSVol,lTextOutput,lBaselineCorrect,lPctSignal, + lRemoveRegressorVariability,lTemporalDeriv,lUseFSLEVs,lPlotModel: boolean; } +begin + ImgForm.CloseImagesClick(nil); + Close4DTrace(g4Ddata,true); + FreeImgMemory(g4DHdr); + //x if not FindFEATFolders (lFeatDirs) then + //x exit; + lVectors := TStringList.Create;//empty + lVOI := TStringList.Create; + {$IFDEF TEST} + + lFeatDirs := TStringList.Create; + for lI := 1 to 100 do + lFeatDirs.Add('C:\mri\fds.feat'); + + {lUseFSLEVs := true; + FSLEVNames (lFeatDirs[0], lVectors); + } + lUseFSLEVs := false; + lVectors.Add('C:\mri\fds.feat\custom_timing_files\ev1.txt'); + lVectors.Add('C:\mri\fds.feat\custom_timing_files\ev2.txt'); + //lVectors.Add('C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\custom_timing_files\ev3.txt'); + lVOI.Add('C:\mri\left.voi'); + lVOI.Add('C:\mri\right.voi'); + lVOI.Add('C:\mri\v1.voi'); + {$ELSE} + FSLEVNames (lFeatDirs[0], lVectors); + lUseFSLEVs := false; + if lVectors.count > 0 then + lUseFSLEVs := OKMsg('Use event vectors from the .FEAT'+pathdelim+'custom_timing_files folder?'); //shows dialog with OK/Cancel returns true if user presses OK + if not lUseFSLEVs then begin + lVectors.clear; + if OpenDialogExecute(kTxtFilter,'Select 3-column event onset time files',true) then begin + if HdrForm.OpenHdrDlg.Files.Count > kMaxCond then begin + showmessage('Can only load '+inttostr(kMaxCond)+'conditions'); + goto 111; + end; + lVectors.AddStrings(HdrForm.OpenHdrDlg.Files); + end; + end; //manually select EVs + + if not OpenDialogExecute(kImgPlusVOIFilter,'Select volume[s] of interest [2mm MNI space]',true) then + goto 111; + if HdrForm.OpenHdrDlg.Files.Count > (knMaxOverlay-2) then begin + showmessage('Can only load '+inttostr(knMaxOverlay-2)+'conditions'); + goto 111; + end; + lVOI.AddStrings(HdrForm.OpenHdrDlg.Files); + {$ENDIF} + if not ResliceFSLVOIs(lFeatDirs,lVOI) then begin + showmessage('Unable to reslice VOIs!'); + goto 111; + end; + lPSPlot.TextOutput := true; + lPSPlot.GraphOutput := false; + TextForm.MemoT.Lines.Clear;//prepare to report results + + + if not ReadGraf(FSLFuncName (lFeatDirs[0]),false, (lVectors.count > 0) ) then + goto 111; //read first dataset to set TR! + //la1 := (FreeRAM); + //get plot settings.... + lPSPlot.TRSec := TREdit.value; + if lVectors.count > 0 then + if not PSForm.GetPeriSettings(lPSPlot) then + goto 111; + + for lImg := 1 to lFeatDirs.Count do begin + if lImg > 1 then begin//we have already read 1st img + Refresh; + Application.processmessages; + Close4DTrace(g4Ddata,true); + ImgForm.CloseImagesClick(nil); + FreeImgMemory(g4DHdr); + //Textform.memo1.lines.add(inttostr(FreeRAM));//rascal + if not ReadGraf(FSLFuncName (lFeatDirs[lImg-1]),true,(lVectors.count > 0)) then goto 111; //read first dataset to set TR! + if lUseFSLEVs then + FSLEVNames (lFeatDirs[lImg-1], lVectors) + end; //all except 1st image + if lVectors.count > 0 then begin + for lI := 1 to lVectors.count do + ReadCond(lVectors[lI-1],g4Ddata,lI); + end;//vectors > 0 + if lVOI.count > 0 then begin + for lI := 1 to lVOI.count do begin + lStr := FSLReslicedVOIName (lFeatDirs[lImg-1], lVOI[lI-1]); + ImgForm.OverlayOpenCore(lStr,lI+kBGOverlayNum); + end;//for each VOI + end; //VOI > 0 + + if lVectors.Count > 0 then begin + if lImg = lFeatDirs.Count then + lPSPlot.GraphOutput := true; + CreatePeristimulusPlot (g4DHdr,g4Ddata, lPSPlot) + end else begin + ConvertToTrace(g4DHdr,g4Ddata,ImgForm.XViewEdit.asInteger,ImgForm.YViewEdit.asInteger,ImgForm.ZViewEdit.asInteger); + TextToTrace (g4Ddata); + RegressTrace(g4Ddata); + end; + end; + TextForm.show; + 111: + lVOI.Free; + lVectors.Free; + lFeatDirs.free; + showmessage('done'); +end; //test + +end. diff --git a/niftiview7/grey.voi b/niftiview7/grey.voi new file mode 100755 index 0000000..5b3b3e3 Binary files /dev/null and b/niftiview7/grey.voi differ diff --git a/niftiview7/gzio/ADLER.PAS b/niftiview7/gzio/ADLER.PAS new file mode 100755 index 0000000..c68e656 --- /dev/null +++ b/niftiview7/gzio/ADLER.PAS @@ -0,0 +1,114 @@ +Unit Adler; + +{ + adler32.c -- compute the Adler-32 checksum of a data stream + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil; + +function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; + +{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and + return the updated checksum. If buf is NIL, this function returns + the required initial value for the checksum. + An Adler-32 checksum is almost as reliable as a CRC32 but can be computed + much faster. Usage example: + + var + adler : uLong; + begin + adler := adler32(0, Z_NULL, 0); + + while (read_buffer(buffer, length) <> EOF) do + adler := adler32(adler, buffer, length); + + if (adler <> original_adler) then + error(); + end; +} + +implementation + +const + BASE = uLong(65521); { largest prime smaller than 65536 } + {NMAX = 5552; original code with unsigned 32 bit integer } + { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 } + NMAX = 3854; { code with signed 32 bit integer } + { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 } + { The penalty is the time loss in the extra MOD-calls. } + + +{ ========================================================================= } + +function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; +var + s1, s2 : uLong; + k : int; +begin + s1 := adler and $ffff; + s2 := (adler shr 16) and $ffff; + + if not Assigned(buf) then + begin + adler32 := uLong(1); + exit; + end; + + while (len > 0) do + begin + if len < NMAX then + k := len + else + k := NMAX; + Dec(len, k); + { + while (k >= 16) do + begin + DO16(buf); + Inc(buf, 16); + Dec(k, 16); + end; + if (k <> 0) then + repeat + Inc(s1, buf^); + Inc(puf); + Inc(s2, s1); + Dec(k); + until (k = 0); + } + while (k > 0) do + begin + Inc(s1, buf^); + Inc(s2, s1); + Inc(buf); + Dec(k); + end; + s1 := s1 mod BASE; + s2 := s2 mod BASE; + end; + adler32 := (s2 shl 16) or s1; +end; + +{ +#define DO1(buf,i) + begin + Inc(s1, buf[i]); + Inc(s2, s1); + end; +#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1); +#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2); +#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4); +#define DO16(buf) DO8(buf,0); DO8(buf,8); +} +end. + diff --git a/niftiview7/gzio/Adler_32.pas b/niftiview7/gzio/Adler_32.pas new file mode 100755 index 0000000..0301088 --- /dev/null +++ b/niftiview7/gzio/Adler_32.pas @@ -0,0 +1,142 @@ +unit Adler_32; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + DsgnIntf; + +type + TZeroHundred = 0..100; + + TAboutProperty = class(TPropertyEditor) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + function GetValue: string; override; + end; + + TAdler32 = class(TComponent) + private + { Private declarations } + FAbout : TAboutProperty; + FAdler32FileName : String; + FWindowOnError : boolean; + FOnProgress : TNotifyEvent; + FProgress : integer; + FProgressStep : TZeroHundred; + protected + { Protected declarations } + procedure DoOnProgress; virtual; + public + { Public declarations } + constructor Create( AOwner: TComponent); override; + function CalcAdler32 : longint; + function CalcAdler32_hex : string; + property Progress : integer + read FProgress write FProgress; + published + { Published declarations } + property About: TAboutProperty + read FAbout write FAbout; + property Adler32FileName : String + read FAdler32FileName write FAdler32FileName; + Property WindowOnError : boolean + read FWindowOnError write FWindowOnError; + property ProgressStep : TZeroHundred + read FProgressStep write FProgressStep; + property OnProgress : TNotifyEvent + read FOnProgress write FOnProgress; + end; + +procedure Register; + +implementation + +uses adler, zutil, utils; + +constructor TAdler32.Create( AOwner: TComponent); +begin + inherited Create( AOwner); + WindowOnError := True; + FProgressStep := 0 +end; + +procedure TAdler32.DoOnProgress; +begin + if Assigned (FOnProgress) then + FOnProgress (self) +end; + +function TAdler32.CalcAdler32 : longint; +var adler : uLong; + len : integer; + buffer : array [0..BUFLEN-1] of Byte; + infile : file; + fsize, lensize : LongInt{LongWord}; +begin + adler := 0; + if FileExists( FAdler32Filename) then begin + AssignFile(infile, FAdler32FileName); + Reset(infile, 1); + + adler := adler32(0, NIL, 0); + + FProgress := 0; + fsize := FileSize(infile); + lensize := 0; + if FProgressStep > 0 then DoOnProgress; + + while true do begin + blockread (infile, buffer, BUFLEN, len); + if len=0 then break; + adler := adler32(adler, @buffer, len); + + if FProgressStep > 0 then begin + {$WARNINGS OFF} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end + end; + CloseFile(infile) + end + else if FWindowOnError then + MessageDlg('File '+FAdler32FileName+' does not exist.', + mtError, [mbAbort], 0); + CalcAdler32 := adler +end; + +function TAdler32.CalcAdler32_hex : string; +var utils : TUtils; +begin + CalcAdler32_hex := utils.HexToStr(CalcAdler32) +end; + +procedure TAboutProperty.Edit; +var utils : TUtils; +begin + ShowMessage(utils.CreateAboutMsg('DelphiAdler32')) +end; + +function TAboutProperty.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paDialog, paReadOnly]; +end; + +function TAboutProperty.GetValue: string; +begin + Result := 'DelphiAdler32'; +end; + +procedure Register; +begin + RegisterComponents('Samples', [TAdler32]); + RegisterPropertyEditor(TypeInfo(TAboutProperty), TAdler32, 'ABOUT', TAboutProperty); +end; + +end. diff --git a/niftiview7/gzio/CRC.PAS b/niftiview7/gzio/CRC.PAS new file mode 100755 index 0000000..e20608c --- /dev/null +++ b/niftiview7/gzio/CRC.PAS @@ -0,0 +1,237 @@ +Unit Crc; + +{ + crc32.c -- compute the CRC-32 of a data stream + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil, zlib; + + +function crc32(crc : uLong; buf : pBytef; len : uInt) : uLong; + +{ Update a running crc with the bytes buf[0..len-1] and return the updated + crc. If buf is NULL, this function returns the required initial value + for the crc. Pre- and post-conditioning (one's complement) is performed + within this function so it shouldn't be done by the application. + Usage example: + + var + crc : uLong; + begin + crc := crc32(0, Z_NULL, 0); + + while (read_buffer(buffer, length) <> EOF) do + crc := crc32(crc, buffer, length); + + if (crc <> original_crc) then error(); + end; + +} + +function get_crc_table : puLong; { can be used by asm versions of crc32() } + + +implementation + +{$IFDEF DYNAMIC_CRC_TABLE} + +{local} +const + crc_table_empty : boolean = TRUE; +{local} +var + crc_table : array[0..256-1] of uLongf; + + +{ + Generate a table for a byte-wise 32-bit CRC calculation on the polynomial: + x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1. + + Polynomials over GF(2) are represented in binary, one bit per coefficient, + with the lowest powers in the most significant bit. Then adding polynomials + is just exclusive-or, and multiplying a polynomial by x is a right shift by + one. If we call the above polynomial p, and represent a byte as the + polynomial q, also with the lowest power in the most significant bit (so the + byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p, + where a mod b means the remainder after dividing a by b. + + This calculation is done using the shift-register method of multiplying and + taking the remainder. The register is initialized to zero, and for each + incoming bit, x^32 is added mod p to the register if the bit is a one (where + x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by + x (which is shifting right by one and adding x^32 mod p if the bit shifted + out is a one). We start with the highest power (least significant bit) of + q and repeat for all eight bits of q. + + The table is simply the CRC of all possible eight bit values. This is all + the information needed to generate CRC's on data a byte at a time for all + combinations of CRC register values and incoming bytes. +} +{local} +procedure make_crc_table; +var + c : uLong; + n,k : int; + poly : uLong; { polynomial exclusive-or pattern } + +const + { terms of polynomial defining this crc (except x^32): } + p: array [0..13] of Byte = (0,1,2,4,5,7,8,10,11,12,16,22,23,26); + +begin + { make exclusive-or pattern from polynomial ($EDB88320) } + poly := Long(0); + for n := 0 to (sizeof(p) div sizeof(Byte))-1 do + poly := poly or (Long(1) shl (31 - p[n])); + + for n := 0 to 255 do + begin + c := uLong(n); + for k := 0 to 7 do + begin + if (c and 1) <> 0 then + c := poly xor (c shr 1) + else + c := (c shr 1); + end; + crc_table[n] := c; + end; + crc_table_empty := FALSE; +end; + +{$ELSE} + +{ ======================================================================== + Table of CRC-32's of all single-byte values (made by make_crc_table) } + +{local} +const + crc_table : array[0..256-1] of uLongf = ( + $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, + $706af48f, $e963a535, $9e6495a3, $0edb8832, $79dcb8a4, + $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, + $90bf1d91, $1db71064, $6ab020f2, $f3b97148, $84be41de, + $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7, $136c9856, + $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, + $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, + $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, + $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, + $45df5c75, $dcd60dcf, $abd13d59, $26d930ac, $51de003a, + $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, + $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924, + $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, + $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, + $9fbfe4a5, $e8b8d433, $7807c9a2, $0f00f934, $9609a88e, + $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01, + $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, + $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950, + $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, + $fbd44c65, $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, + $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, $4369e96a, + $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, + $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa, $be0b1010, + $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f, + $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, + $2eb40d81, $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, + $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, + $73dc1683, $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, + $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, $f00f9344, + $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, + $196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, + $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, + $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, + $a6bc5767, $3fb506dd, $48b2364b, $d80d2bda, $af0a1b4c, + $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, + $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236, + $cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, + $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, + $2cd99e8b, $5bdeae1d, $9b64c2b0, $ec63f226, $756aa39c, + $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713, + $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, + $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242, + $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, + $18b74777, $88085ae6, $ff0f6a70, $66063bca, $11010b5c, + $8f659eff, $f862ae69, $616bffd3, $166ccf45, $a00ae278, + $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, + $4969474d, $3e6e77db, $aed16a4a, $d9d65adc, $40df0b66, + $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9, + $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, + $cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8, + $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, + $2d02ef8d); + +{$ENDIF} + +{ ========================================================================= + This function can be used by asm versions of crc32() } + +function get_crc_table : {const} puLong; +begin +{$ifdef DYNAMIC_CRC_TABLE} + if (crc_table_empty) then + make_crc_table; +{$endif} + get_crc_table := {const} puLong(@crc_table); +end; + +{ ========================================================================= } + +function crc32 (crc : uLong; buf : pBytef; len : uInt): uLong; +begin + if (buf = Z_NULL) then + crc32 := Long(0) + else + begin + +{$IFDEF DYNAMIC_CRC_TABLE} + if crc_table_empty then + make_crc_table; +{$ENDIF} + + crc := crc xor uLong($ffffffff); + while (len >= 8) do + begin + {DO8(buf)} + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + + Dec(len, 8); + end; + if (len <> 0) then + repeat + {DO1(buf)} + crc := crc_table[(int(crc) xor buf^) and $ff] xor (crc shr 8); + inc(buf); + + Dec(len); + until (len = 0); + crc32 := crc xor uLong($ffffffff); + end; +end; + + +end. \ No newline at end of file diff --git a/niftiview7/gzio/Crc_32.pas b/niftiview7/gzio/Crc_32.pas new file mode 100755 index 0000000..3073927 --- /dev/null +++ b/niftiview7/gzio/Crc_32.pas @@ -0,0 +1,144 @@ +unit Crc_32; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + DsgnIntf; + +type + TZeroHundred = 0..100; + + TAboutProperty = class(TPropertyEditor) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + function GetValue: string; override; + end; + + TCrc32 = class(TComponent) + private + { Private declarations } + FAbout : TAboutProperty; + FCrc32FileName : String; + FWindowOnError : boolean; + FOnProgress : TNotifyEvent; + FProgress : integer; + FProgressStep : TZeroHundred; + protected + { Protected declarations } + procedure DoOnProgress; virtual; + public + { Public declarations } + constructor Create( AOwner: TComponent); override; + function CalcCrc32 : longint; + function CalcCrc32_hex : string; + property Progress : integer + read FProgress write FProgress; + published + { Published declarations } + property About: TAboutProperty + read FAbout write FAbout; + property Crc32FileName : String + read FCrc32FileName write FCrc32FileName; + Property WindowOnError : boolean + read FWindowOnError write FWindowOnError; + property ProgressStep : TZeroHundred + read FProgressStep write FProgressStep; + property OnProgress : TNotifyEvent + read FOnProgress write FOnProgress; + end; + +procedure Register; + +implementation + +uses crc, zutil, utils; + +constructor TCrc32.Create( AOwner: TComponent); +begin + inherited Create( AOwner); + WindowOnError := True; + FProgressStep := 0 +end; + +procedure TCrc32.DoOnProgress; +begin + if Assigned (FOnProgress) then + + FOnProgress (self) +end; + +function TCrc32.CalcCrc32 : longint; +var crc : uLong; + len : integer; + buffer : array [0..BUFLEN-1] of Byte; + infile : file; + fsize, lensize : LongInt{LongWord}; +begin + crc := 0; + if FileExists( FCrc32Filename) then begin + AssignFile(infile, FCrc32FileName); + Reset(infile, 1); + + crc := crc32(0, NIL, 0); + + FProgress := 0; + fsize := FileSize(infile); + lensize := 0; + if FProgressStep > 0 then DoOnProgress; + + while true do begin + blockread (infile, buffer, BUFLEN, len); + if len=0 then break; + crc := crc32(crc, @buffer, len); + + if FProgressStep > 0 then begin + {$WARNINGS OFF} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end + end; + CloseFile(infile); + end + else if FWindowOnError then + MessageDlg('File '+FCrc32FileName+' does not exist.', + mtError, [mbAbort], 0); + CalcCrc32 := crc +end; + +function TCrc32.CalcCrc32_hex : string; +var utils : TUtils; +begin + CalcCrc32_hex := utils.HexToStr(CalcCrc32) +end; + +procedure TAboutProperty.Edit; +var utils : TUtils; +begin + ShowMessage(utils.CreateAboutMsg('DelphiCrc32')) +end; + +function TAboutProperty.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paDialog, paReadOnly]; +end; + +function TAboutProperty.GetValue: string; +begin + Result := 'DelphiCrc32'; +end; + +procedure Register; +begin + RegisterComponents('Samples', [TCrc32]); + RegisterPropertyEditor(TypeInfo(TAboutProperty), TCrc32, 'ABOUT', TAboutProperty); +end; + +end. + \ No newline at end of file diff --git a/niftiview7/gzio/DelphiGzip.pas b/niftiview7/gzio/DelphiGzip.pas new file mode 100755 index 0000000..29f8738 --- /dev/null +++ b/niftiview7/gzio/DelphiGzip.pas @@ -0,0 +1,641 @@ +unit DelphiGzip; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + DsgnIntf, gzio, zlib; + +type + TZeroHundred = 0..100; + + THeader = set of (filename, comment); + + TAboutProperty = class(TPropertyEditor) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + function GetValue: string; override; + end; + + TCompressionLevel = 1..9; + TCompressionType = (Standard,Filtered,HuffmanOnly); + TGzip = class(TComponent) + private + { Private declarations } + FGzipHeader : THeader; + FAbout : TAboutProperty; + FFileSource : string; + FFileDestination : string; + FDeleteSource : boolean; + FComments : string; + FCompressionLevel : TCompressionLevel; + FCompressionType : TCompressionType; + FWindowOnError : boolean; + FOnProgress : TNotifyEvent; + FProgress : integer; + FProgressStep : TZeroHundred; + FGzipFilename : string; + FGzipComments : string; + protected + { Protected declarations } + procedure DoOnProgress; virtual; + function gz_compress (var infile:file; outfile:gzFile): integer; +function gz_uncompressStream (infile:gzFile; var outstream:TMemoryStream; fsize:LongInt{LongWord}) : integer; + function gz_uncompress (infile:gzFile; var outfile:file; + fsize:LongInt{LongWord}) : integer; + public + { Public declarations } + constructor Create( AOwner: TComponent); override; + procedure FileSwitch; + function GunzipStream(var lStream: TMemoryStream): Integer; + function Gzip : integer; + function Gunzip : integer; + function getGzipInfo : integer; + property GzipFilename : string + read FGzipFilename write FGzipFilename; + property GzipComments : string + read FGzipComments write FGzipComments; + property Progress : integer + read FProgress write FProgress; + published + { Published declarations } + property GzipHeader : THeader + read FGzipHeader write FGzipHeader; + property About: TAboutProperty + read FAbout write FAbout; + Property DeleteSource : boolean + read FDeleteSource write FDeleteSource; + Property FileSource : string + read FFileSource write FFileSource; + Property FileDestination : string + read FFileDestination write FFileDestination; + Property Comments : string + read FComments write FComments; + Property CompressionLevel : TCompressionLevel + read FCompressionLevel write FCompressionLevel; + Property CompressionType : TCompressionType + read FCompressionType write FCompressionType; + Property WindowOnError : boolean + read FWindowOnError write FWindowOnError; + property ProgressStep : TZeroHundred + read FProgressStep write FProgressStep; + property OnProgress : TNotifyEvent + read FOnProgress write FOnProgress; + end; + + procedure Register; + +implementation + +uses utils; + +const + ASCII_FLAG = $01; { bit 0 set: file probably ascii text } + HEAD_CRC = $02; { bit 1 set: header CRC present } + EXTRA_FIELD = $04; { bit 2 set: extra field present } + ORIG_NAME = $08; { bit 3 set: original file name present } + COMMENT_ = $10; { bit 4 set: file comment present } + RESERVED = $E0; { bits 5..7: reserved } + +procedure TAboutProperty.Edit; +var utils : TUtils; +begin + ShowMessage(utils.CreateAboutMsg('DelphiGZip')) +end; + +function TAboutProperty.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paDialog, paReadOnly]; +end; + +function TAboutProperty.GetValue: string; +begin + Result := 'DelphiGzip'; +end; + +constructor TGzip.Create( AOwner: TComponent); +begin + inherited Create( AOwner); + CompressionLevel := 6; + CompressionType := Standard; + FileSource := 'data.dat'; + FileDestination := 'data.dat.gz'; + DeleteSource := False; + WindowOnError := True; + FProgressStep := 0; + FComments := 'generated by DelphiZlib'; + FGzipHeader := [filename] +end; + +procedure TGzip.DoOnProgress; +begin + if Assigned (FOnProgress) then + FOnProgress (self) +end; + +{ gz_compress ---------------------------------------------- +# This code comes from minigzip.pas with some changes +# Original: +# minigzip.c -- usage example of the zlib compression library +# Copyright (C) 1995-1998 Jean-loup Gailly. +# +# Pascal tranlastion +# Copyright (C) 1998 by Jacques Nomssi Nzali +# +# 0 - No Error +# 1 - Read Error +# 2 - Write Error +# 3 - gzclose error +-----------------------------------------------------------} +function TGzip.gz_compress (var infile:file; outfile:gzFile): integer; +var + len : uInt; + ioerr : integer; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + fsize, lensize : LongInt{LongWord}; + +begin + errorcode := 0; + Progress := 0; + fsize := FileSize(infile); + lensize := 0; + if FProgressStep > 0 then DoOnProgress; + + while true do begin + {$I-} + blockread (infile, buf, BUFLEN, len); + {$I+} + + ioerr := IOResult; + if (ioerr <> 0) then begin + errorcode := 1; + break + end; + + if (len = 0) then break; + + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (gzwrite (outfile, @buf, len) <> len) then begin + {$WARNINGS OFF} + errorcode := 2; + break + end; + + if FProgressStep > 0 then begin + {$WARNINGS OFF}{Calculate progress and raise event} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end + end; {WHILE} + + closeFile (infile); + if (gzclose (outfile) <> 0{Z_OK}) then errorcode := 3; + + gz_compress := errorcode; +end; + +{ gz_uncompress ---------------------------------------------- +# This code comes from minigzip.pas with some changes +# Original: +# minigzip.c -- usage example of the zlib compression library +# Copyright (C) 1995-1998 Jean-loup Gailly. +# +# Pascal tranlastion +# Copyright (C) 1998 by Jacques Nomssi Nzali +# +# 0 - No error +# 1 - Read Error +# 2 - Write Error +# 3 - gzclose Error +-----------------------------------------------------------} +function TGzip.gz_uncompress (infile:gzFile; var outfile:file; + fsize:LongInt{LongWord}) : integer; +var + len : integer; + written : uInt; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + lensize : LongInt{LongWord}; +begin + errorcode := 0; + FProgress := 0; + lensize := 0; + if FProgressStep > 0 then DoOnProgress; + + while true do begin + + len := gzread (infile, @buf, BUFLEN); + if (len < 0) then begin + errorcode := 1; + break + end; + if (len = 0) + then break; + + {$I-} + blockwrite (outfile, buf, len, written); + {$I+} + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (written <> len) then begin + {$WARNINGS ON} + errorcode := 2; + break + end; + + if FProgressStep > 0 then begin + {$WARNINGS OFF} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end + end; {WHILE} + + + + if (gzclose (infile) <> 0{Z_OK}) then begin + if FWindowOnError then + MessageDlg('gzclose Error.', mtError, [mbAbort], 0); + errorcode := 3 + end; + + gz_uncompress := errorcode +end; + + +function TGzip.gz_uncompressStream (infile:gzFile; var outstream:TMemoryStream; fsize:LongInt{LongWord}) : integer; +var + len : integer; + written : uInt; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } + errorcode : byte; + lensize,ltotal : LongInt{LongWord}; +begin + errorcode := 0; + FProgress := 0; + lensize := 0; + lTotal := 0; + if FProgressStep > 0 then DoOnProgress; + //outstream.Position := 0; + while true do begin + + len := gzread (infile, @buf, BUFLEN); + if (len < 0) then begin + errorcode := 1; + break + end; + if (len = 0) + then break; + lTotal := lTotal + Len; + //outstream.CopyFrom(lS,len); + //outstream.WriteBuffer(buf,len); + outstream.WriteBuffer(buf,len); + //outstream.Read(buf,len); + //outstream.Write(buf,len);//abba +(* {$I-} + blockwrite (outfile, buf, len, written); + {$I+} + {$WARNINGS OFF}{Comparing signed and unsigned types} + if (written <> len) then begin + {$WARNINGS ON} + errorcode := 2; + break + end; + *) + if FProgressStep > 0 then begin + {$WARNINGS OFF} + lensize := lensize + len; + if ((lensize / fsize) * 100 >= FProgress + FProgressStep) + or (lensize = fsize) then begin + FProgress := Trunc((lensize / fsize) * 100); + DoOnProgress + end + {$WARNINGS ON} + end + end; {WHILE} + if (gzclose (infile) <> 0{Z_OK}) then begin + if FWindowOnError then + MessageDlg('gzclose Error.', mtError, [mbAbort], 0); + errorcode := 3 + end; + + gz_uncompressStream := errorcode +end; + +{*************************************************************** +* The public part +***************************************************************} + +procedure TGzip.FileSwitch; +var s : string; +begin + s := FFileSource; + FFileSource := FFileDestination; + FFileDestination := s; +end; + +{ Gzip --------------------------------------------------------- +# Returns 0 - File compressed +# 1 - Could not open FFileIn +# 2 - Could not create FFileOut +# >100 - Error-100 in gz_compress +---------------------------------------------------------------} +function TGzip.Gzip : integer; +var outmode : string; + s : string; + infile : file; + outfile : gzFile; + errorcode : integer; + flags : uInt; + stream : gz_streamp; + p : PChar; + ioerr : integer; +begin + AssignFile (infile, FFileSource); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + if FWindowOnError then + MessageDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0); + errorcode := 1 + end + else begin + outmode := 'w '; + s := IntToStr(FCompressionLevel); + outmode[2] := s[1]; + case FCompressionType of + Standard : outmode[3] := ' '; + HuffmanOnly : outmode[3] := 'h'; + Filtered : outmode[3] := 'f'; + end; + flags := 0; + if (filename in FGzipHeader) then flags := ORIG_NAME; + if (comment in FGzipHeader) then flags := flags + COMMENT_; + + outfile := gzopen (FFileDestination, outmode, flags); + + if (outfile = NIL) then begin + if FWindowOnError then + MessageDlg('Can''t open: '+FFileDestination, mtError, [mbAbort], 0); + close( infile); + errorcode := 2 + end + else begin + { if flags are set then write them } + stream := gz_streamp(outfile); + + if (filename in FGzipHeader) then + begin + s := ExtractFilename(FFileSource); + p := PChar(s); + blockWrite( stream^.gzfile, p[0], length(s)+1); + stream^.startpos := stream^.startpos + length(s) + 1 + end; + if (comment in FGzipHeader) then + begin + p := PChar(FComments); + blockWrite( stream^.gzfile, p[0], length(FComments)+1); + stream^.startpos := stream^.startpos + length(FComments) + 1 + end; + + { start compressing } + errorcode := gz_compress(infile, outfile); + if errorcode <> 0 then errorcode := errorcode+100 + else + if FDeleteSource then erase (infile); + end + end; + Gzip := errorcode +end; + +{ Gzip --------------------------------------------------------- +# Returns 0 - File decompressed +# 1 - Could not open FFileIn +# 2 - Could not create FFileOut +# 3 - FFileIn not a valid gzip-file +---------------------------------------------------------------} +function TGzip.GunzipStream (var lStream: TMemoryStream) : integer; +var //len : integer; + infile : gzFile; + //outfile : file; + ioerr : integer; + errorcode : integer; + fsize : LongInt{LongWord}; + s : gz_streamp; +begin + errorcode := 0; + + infile := gzopen (FFileSource, 'r', 0); + if (infile = NIL) then begin + if FWindowOnError then + MessageDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0); + errorcode := 1 + end + else begin + s := gz_streamp(infile); + fsize := FileSize( s^.gzfile); + + (*AssignFile (outfile, FFileDestination); + {$I-} + Rewrite (outfile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + if FWindowOnError then + MessageDlg('Can''t create: '+FFileDestination, mtError, [mbAbort], 0); + errorcode := 2 + end + else*) begin + { We could open all files, so time for uncompressing } + gz_uncompressStream (infile, lStream, fsize); + if FDeleteSource then DeleteFile(FFileSource); + + (* {$I-} + close (outfile); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + if FWindowOnError then + MessageDlg('Can''t close file '+FFileDestination, mtError, [mbAbort], 0); + halt(1) + end + *) + end + end; + + GunzipStream := errorcode +end; + + + + +function TGzip.Gunzip : integer; +var //len : integer; + infile : gzFile; + outfile : file; + ioerr : integer; + errorcode : integer; + fsize : LongInt{LongWord}; + s : gz_streamp; +begin + errorcode := 0; + + infile := gzopen (FFileSource, 'r', 0); + if (infile = NIL) then begin + if FWindowOnError then + MessageDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0); + errorcode := 1 + end + else begin + s := gz_streamp(infile); + fsize := FileSize( s^.gzfile); + + AssignFile (outfile, FFileDestination); + {$I-} + Rewrite (outfile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + if FWindowOnError then + MessageDlg('Can''t create: '+FFileDestination, mtError, [mbAbort], 0); + errorcode := 2 + end + else begin + { We could open all files, so time for uncompressing } + gz_uncompress (infile, outfile, fsize); + if FDeleteSource then DeleteFile(FFileSource); + + {$I-} + close (outfile); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + if FWindowOnError then + MessageDlg('Can''t close file '+FFileDestination, mtError, [mbAbort], 0); + halt(1) + end + end + end; + + Gunzip := errorcode +end; + +{ getGzipInfo ================================================================== +# todo: check for more errorcodes +# +# Errorcodes: +# 0 - No error. Info can be found in GzipFilename +# GzipComments +# 1 - Can't open FFileSource +# 2 - Not a Gzip file or invalid header +# 3 - Can't handle this field +# 4 - +===============================================================================} +function TGzip.getGzipInfo : integer; +// todo: check for eof, corrupt files etc etc +var len, dummy: uInt; + infile : file; + head : array[0..9] of byte; + ch : char; + str : string; + errorcode, ioerr : integer; +begin + errorcode := 0; + // Clean up old values + FGzipFilename := ''; + FGzipComments := ''; + + AssignFile( infile, FFileSource); + {$I-} + Reset (infile,1); + {$I+} + ioerr := IOResult; + if (ioerr <> 0) then begin + if FWindowOnError then + MessageDlg('Can''t open: '+FFileSource, mtError, [mbAbort], 0); + errorcode := 1 + end else begin + + TRY + blockRead( infile, head, 10, len); + + if (head[0] <> $1F) or (head[1] <> $8B) or (len<10) then begin + // Not a Gzip-file or header not valid + errorcode := 2; + abort + end; + + if (head[2] <> Z_DEFLATED) or ((head[3] and RESERVED) <> 0) then begin + // Can not handle this + errorcode := 3; + abort + end; + + if ((head[3] and EXTRA_FIELD) <> 0) then begin + // the extra field + blockRead(infile, len, 1); + blockread(infile, dummy, 1); + len := len + (dummy shl 8); + if FileSize( infile) < int(len+12) then begin + errorcode := 2; + abort + end; + seek( infile, len + 12) // just throw it away + end; + + if ((head[3] and ORIG_NAME) <> 0) then begin + // the original file name + str := ''; + blockread( infile, ch, 1); + while (ch <> char(0)) and not eof( infile) do begin + str := str + ch; + blockread( infile, ch, 1) + end; + if eof( infile) then begin + errorcode := 2; + abort + end; + FGzipFilename := str + end; + + if ((head[3] and COMMENT_) <> 0) then begin + // the comments + str := ''; + blockread( infile, ch, 1); + while (ch <> char(0)) and not eof( infile) do begin + str := str + ch; + blockread( infile, ch, 1) + end; + if eof( infile) then begin + errorcode := 2; + abort + end; + FGzipComments := str + end + + FINALLY + CloseFile ( infile) + end + end; + getGzipInfo := errorcode +end; + +procedure Register; +begin + RegisterComponents('Samples', [TGzip]); + RegisterPropertyEditor(TypeInfo(TAboutProperty), TGzip, 'ABOUT', TAboutProperty); +end; + +end. diff --git a/niftiview7/gzio/DelphiZlib.dcp b/niftiview7/gzio/DelphiZlib.dcp new file mode 100755 index 0000000..6049fd5 Binary files /dev/null and b/niftiview7/gzio/DelphiZlib.dcp differ diff --git a/niftiview7/gzio/DelphiZlib.dcr b/niftiview7/gzio/DelphiZlib.dcr new file mode 100755 index 0000000..ef3fa4c Binary files /dev/null and b/niftiview7/gzio/DelphiZlib.dcr differ diff --git a/niftiview7/gzio/DelphiZlib.dpk b/niftiview7/gzio/DelphiZlib.dpk new file mode 100755 index 0000000..e60bc69 --- /dev/null +++ b/niftiview7/gzio/DelphiZlib.dpk @@ -0,0 +1,49 @@ +package DelphiZlib; + +{$R *.RES} +{$R 'DelphiZlib.dcr'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $00400000} +{$DESCRIPTION 'DelphiZlib: TGzip, TCrc32, TAdler32, TUnTar'} +{$IMPLICITBUILD ON} + +requires + vcl30, + VCLX30; + +contains + DelphiGzip,trees,Crc,zDeflate,InfCodes, + InfBlock,Adler,zInflate,Zlib, + InfTrees, + infutil, + InfFast, + ZUtil, + Unzip, + ziputils, + Crc_32, + utils, + gzIO, + Adler_32, + UnTar, + tarfile; + +end. diff --git a/niftiview7/gzio/DelphiZlib.dpl b/niftiview7/gzio/DelphiZlib.dpl new file mode 100755 index 0000000..37af3e1 Binary files /dev/null and b/niftiview7/gzio/DelphiZlib.dpl differ diff --git a/niftiview7/gzio/DelphiZlib.res b/niftiview7/gzio/DelphiZlib.res new file mode 100755 index 0000000..d4ca576 Binary files /dev/null and b/niftiview7/gzio/DelphiZlib.res differ diff --git a/niftiview7/gzio/GZio.pas b/niftiview7/gzio/GZio.pas new file mode 100755 index 0000000..bdec1cf --- /dev/null +++ b/niftiview7/gzio/GZio.pas @@ -0,0 +1,1223 @@ +Unit gzIO; +// Z_BUFSIZE = 16384 size does not appear to make much difference with 2007 systems +{ + Pascal unit based on gzio.c -- IO on .gz files + Copyright (C) 1995-1998 zJean-loup Gailly. + + Define NO_DEFLATE to compile this file without the compression code + + Pascal tranlastion based on code contributed by Francisco Javier Crespo + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + SysUtils, + zutil, zlib, crc, zdeflate, zinflate,dialogs, Windows; + +type gzFile = voidp; +type z_off_t = long; + +function gzopenZskip(sourceFilename:string; mode:string; flags:uInt; skipBytes: int64) : gzFile; +function gzopenZ (SourceFilename:string; mode:string; flags:uInt) : gzFile; //note: sourcefilename without '.gz' if writing, e.g. name file that exists +function gzread (f:gzFile; buf:voidp; len:uInt) : int; +function gzgetc (f:gzfile) : int; +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +{$ifndef NO_DEFLATE} +function gzwrite (f:gzFile; buf:voidp; len:uInt) : int; +function gzputc (f:gzfile; c:char) : int; +function gzputs (f:gzfile; s:PChar) : int; +function gzflush (f:gzFile; flush:int) : int; + {$ifdef GZ_FORMAT_STRING} + function gzprintf (zfile : gzFile; + const format : string; + a : array of int); { doesn't compile } + {$endif} +{$endif} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +function gztell (f:gzfile) : z_off_t; +function gzclose (f:gzFile) : int; +function gzerror (f:gzFile; var errnum:Int) : string; + +const + SEEK_SET {: z_off_t} = 0; { seek from beginning of file } + SEEK_CUR {: z_off_t} = 1; { seek from current position } + SEEK_END {: z_off_t} = 2; +const + Z_EOF = -1; { same value as in STDIO.H } + Z_BUFSIZE = 16384; + { Z_PRINTF_BUFSIZE = 4096; } + + + gz_magic : array[0..1] of byte = ($1F, $8B); { gzip magic header } + + { gzip flag byte } + + ASCII_FLAG = $01; { bit 0 set: file probably ascii text } + HEAD_CRC = $02; { bit 1 set: header CRC present } + EXTRA_FIELD = $04; { bit 2 set: extra field present } + ORIG_NAME = $08; { bit 3 set: original file name present } + COMMENT_ = $10; { bit 4 set: file comment present } + RESERVED = $E0; { bits 5..7: reserved } + +type gz_stream = record + stream : z_stream; + z_err : int; { error code for last stream operation } + z_eof : boolean; { set if end of input file } + gzfile : file; { .gz file } + inbuf : pBytef; { input buffer } + outbuf : pBytef; { output buffer } + crc : uLong; { crc32 of uncompressed data } + msg : string[79]; { error message - limit 79 chars } + path : string[255]; { path name for debugging only - limit 79 chars } + //Change by Chris Rorden: short path clips filename, it is clearly not only for debugging + //Previous line was originally + //path : string[79]; + + transparent : boolean; { true if input file is not a .gz file } + mode : char; { 'w' or 'r' } + startpos : long; { start of compressed data in file (header skipped) } +end; + +type gz_streamp = ^gz_stream; + +implementation + + +function destroyS (var s:gz_streamp) : int; forward; +procedure check_header(s:gz_streamp); forward; + + +{ GZOPEN ==================================================================== + + Opens a gzip (.gz) file for reading or writing. As Pascal does not use + file descriptors, the code has been changed to accept only path names. + + The mode parameter defaults to BINARY read or write operations ('r' or 'w') + but can also include a compression level ('w9') or a strategy: Z_FILTERED + as in 'w6f' or Z_HUFFMAN_ONLY as in 'w1h'. (See the description of + deflateInit2 for more information about the strategy parameter.) + + gzopen can be used to open a file which is not in gzip format; in this + case, gzread will directly read from the file without decompression. + + gzopen returns NIL if the file could not be opened (non-zero IOResult) + or if there was insufficient memory to allocate the (de)compression state + (zlib error is Z_MEM_ERROR). + + Vincent: + Added argument 'flags' to the original Zlib files. +============================================================================} + + +function gzopenZskip(sourceFilename:string; mode:string; flags:uInt; skipBytes: int64) : gzFile; + +var + + i : uInt; + err,level,strategy : int; { compression strategy } + s : gz_streamp; + path: string; +{$IFDEF MSDOS} + attr : word; { file attributes } +{$ENDIF} +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} +begin + path := sourceFilename; + if (path='') or (mode='') then begin + result := Z_NULL; + exit; + end; + if length(path) > 240 then begin + Path := ExtractShortPathName(Path); + if (length(path) > 240) or (length(path) < 1) then begin + Showmessage('Unable to GZip this file: path name is too long'); + result := Z_NULL; + exit; + end; + end; + //showmessage(path+'@'+inttostr(length(path))); + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + result := Z_NULL; + exit; + end; + if (path='') then begin + Showmessage('Error with path'); + result := Z_NULL; + exit; + end; + //showmessage('gzOpenCompleted'); + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + s^.stream.zalloc := NIL; { (alloc_func)0 } + s^.stream.zfree := NIL; { (free_func)0 } + s^.stream.opaque := NIL; { (voidpf)0 } + s^.stream.next_in := Z_NULL; + s^.stream.next_out := Z_NULL; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := Z_NULL; + s^.outbuf := Z_NULL; + s^.crc := crc32(0, Z_NULL, 0); + s^.msg := ''; + s^.transparent := false; + + //showmessage(s^.path+inttostr(length(path))); + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + //if (s^.mode='w') then begin path := path+'.gz'; end; + s^.path := path; { limit to 255 chars } + if (s^.mode=chr(0)) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = Z_NULL) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = Z_NULL) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + Assign (s^.gzfile, s^.path); + {$ifdef MSDOS} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + if {(not FileExists(s^.path)) and} (s^.mode='w') then + // Vincent: changed IF because I don't want old data behind my + // new made .gz-file + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := flags; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := LONG(10); +{$ENDIF} + end else begin + + if skipBytes > 0 then + Seek (s^.gzfile,skipBytes); + check_header(s); { skip the .gz header } + {$WARNINGS OFF} { combining signed and unsigned types } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + {$WARNINGS ON} + end; + result := gzFile(s); +end; + +function gzopenZ(sourceFilename:string; mode:string; flags:uInt) : gzFile; +begin + result := gzopenZskip(sourceFilename, mode, flags, 0); +end; + + + +{ GZSETPARAMS =============================================================== + + Update the compression level and strategy. + +============================================================================} + +//function gzsetparams (f:gzfile; level:int; strategy:int) : int; + +//var + +// s : gz_streamp; +// written: integer; + +//begin + +// s := gz_streamp(f); + +// if (s = NIL) or (s^.mode <> 'w') then begin +// gzsetparams := Z_STREAM_ERROR; +// exit; +// end; + + { Make room to allow flushing } +// if (s^.stream.avail_out = 0) then begin +// s^.stream.next_out := s^.outbuf; +// blockwrite(s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); +// if (written <> Z_BUFSIZE) then s^.z_err := Z_ERRNO; +// s^.stream.avail_out := Z_BUFSIZE; +// end; + +// gzsetparams := deflateParams (s^.stream, level, strategy); +//end; + + +{ GET_BYTE ================================================================== + + Read a byte from a gz_stream. Updates next_in and avail_in. + Returns EOF for end of file. + IN assertion: the stream s has been sucessfully opened for reading. + +============================================================================} + +function get_byte (s:gz_streamp) : int; + +begin + + if (s^.z_eof = true) then begin + get_byte := Z_EOF; + exit; + end; + + if (s^.stream.avail_in = 0) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then s^.z_err := Z_ERRNO; + get_byte := Z_EOF; + exit; + end; + s^.stream.next_in := s^.inbuf; + end; + + Dec(s^.stream.avail_in); + get_byte := s^.stream.next_in^; + Inc(s^.stream.next_in); + +end; + + +{ GETLONG =================================================================== + + Reads a Longint in LSB order from the given gz_stream. + +============================================================================} +{ +function getLong (s:gz_streamp) : uLong; +var + x : array [0..3] of byte; + i : byte; + c : int; + n1 : longint; + n2 : longint; +begin + + for i:=0 to 3 do begin + c := get_byte(s); + if (c = Z_EOF) then s^.z_err := Z_DATA_ERROR; + x[i] := (c and $FF) + end; + n1 := (ush(x[3] shl 8)) or x[2]; + n2 := (ush(x[1] shl 8)) or x[0]; + getlong := (n1 shl 16) or n2; +end; +} +function getLong(s : gz_streamp) : uLong; +var + x : packed array [0..3] of byte; + c : int; +begin + { x := uLong(get_byte(s)); - you can't do this with TP, no unsigned long } + { the following assumes a little endian machine and TP } + x[0] := Byte(get_byte(s)); + x[1] := Byte(get_byte(s)); + x[2] := Byte(get_byte(s)); + c := get_byte(s); + x[3] := Byte(c); + if (c = Z_EOF) then + s^.z_err := Z_DATA_ERROR; + GetLong := uLong(longint(x)); +end; + + +{ CHECK_HEADER ============================================================== + + Check the gzip header of a gz_stream opened for reading. + Set the stream mode to transparent if the gzip magic header is not present. + Set s^.err to Z_DATA_ERROR if the magic header is present but the rest of + the header is incorrect. + + IN assertion: the stream s has already been created sucessfully; + s^.stream.avail_in is zero for the first time, but may be non-zero + for concatenated .gz files + +============================================================================} + +procedure check_header (s:gz_streamp); +const + z_magic : array[0..1] of byte = ($78, $9C); //.z files simply have an abreviated header + +var + + method : int; { method byte } + flags : int; { flags byte } + len : uInt; + c : int; + cx: array[0..1] of integer; +begin + { Check the gzip magic header } + for len := 0 to 1 do begin + c := get_byte(s); + cx[len] := c; + if (c <> gz_magic[len]) and (c <> z_magic[len]) then begin + if (len <> 0) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + end; + if (c <> Z_EOF) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + s^.transparent := TRUE; + end; + if (s^.stream.avail_in <> 0) then s^.z_err := Z_OK + else s^.z_err := Z_STREAM_END; + exit; + end; + end; + if (cx[0] = z_magic[0]) and (cx[1] = z_magic[1]) then begin + //method := Z_DEFLATED; + //flags := 0; //none + //get_byte(s); //skip byte + s^.z_err := Z_OK; + exit; + end; + + method := get_byte(s); + flags := get_byte(s); + if (method <> Z_DEFLATED) or ((flags and RESERVED) <> 0) then begin + s^.z_err := Z_DATA_ERROR; + exit; + end; + for len := 0 to 5 do get_byte(s); { Discard time, xflags and OS code } + if ((flags and EXTRA_FIELD) <> 0) then begin { skip the extra field } + len := uInt(get_byte(s)); + len := len + (uInt(get_byte(s)) shr 8); + { len is garbage if EOF but the loop below will quit anyway } + while (len <> 0) and (get_byte(s) <> Z_EOF) do Dec(len); + end; + + if ((flags and ORIG_NAME) <> 0) then begin { skip the original file name } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and COMMENT_) <> 0) then begin { skip the .gz file comment } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and HEAD_CRC) <> 0) then begin { skip the header crc } + get_byte(s); + get_byte(s); + end; + + if (s^.z_eof = true) then + s^.z_err := Z_DATA_ERROR + else + s^.z_err := Z_OK; +end; + + +{ DESTROY =================================================================== + + Cleanup then free the given gz_stream. Return a zlib error code. + Try freeing in the reverse order of allocations. + +============================================================================} + +function destroyS (var s:gz_streamp) : int; + +begin + + destroyS := Z_OK; + + if not Assigned (s) then begin + destroyS := Z_STREAM_ERROR; + exit; + end; + + if (s^.stream.state <> NIL) then begin + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + destroyS := Z_STREAM_ERROR; +{$ELSE} + destroyS := deflateEnd(s^.stream); +{$ENDIF} + end + else if (s^.mode = 'r') then begin + destroyS := inflateEnd(s^.stream); + end; + end; + + if (s^.path <> '') then begin + {$I-} + close(s^.gzfile); + {$I+} + if (IOResult <> 0) then destroyS := Z_ERRNO; + end; + + if (s^.z_err < 0) then destroyS := s^.z_err; + + if Assigned (s^.inbuf) then + FreeMem(s^.inbuf, Z_BUFSIZE); + if Assigned (s^.outbuf) then + FreeMem(s^.outbuf, Z_BUFSIZE); + FreeMem(s, sizeof(gz_stream)); + +end; + + +{ GZREAD ==================================================================== + + Reads the given number of uncompressed bytes from the compressed file. + If the input file was not in gzip format, gzread copies the given number + of bytes into the buffer. + + gzread returns the number of uncompressed bytes actually read + (0 for end of file, -1 for error). + +============================================================================} + +function gzread (f:gzFile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + start : pBytef; + next_out : pBytef; + n : uInt; + crclen : uInt; { Buffer length to update CRC32 } + filecrc : uLong; { CRC32 stored in GZIP'ed file } + filelen : uLong; { Total lenght of uncompressed file } + bytes : integer; { bytes actually read in I/O blockread } + total_in : uLong; + total_out : uLong; + +begin + + s := gz_streamp(f); + start := pBytef(buf); { starting point for crc computation } + + if (s = NIL) or (s^.mode <> 'r') then begin + gzread := Z_STREAM_ERROR; + exit; + end; + + if (s^.z_err = Z_DATA_ERROR) or (s^.z_err = Z_ERRNO) then begin + gzread := -1; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then begin + gzread := 0; { EOF } + exit; + end; + + s^.stream.next_out := pBytef(buf); + s^.stream.avail_out := len; + + while (s^.stream.avail_out <> 0) do begin + + if (s^.transparent = true) then begin + { Copy first the lookahead bytes: } + n := s^.stream.avail_in; + if (n > s^.stream.avail_out) then n := s^.stream.avail_out; + if (n > 0) then begin + zmemcpy(s^.stream.next_out, s^.stream.next_in, n); + inc (s^.stream.next_out, n); + inc (s^.stream.next_in, n); + dec (s^.stream.avail_out, n); + dec (s^.stream.avail_in, n); + end; + if (s^.stream.avail_out > 0) then begin + blockread (s^.gzfile, s^.stream.next_out^, s^.stream.avail_out, bytes); + dec (s^.stream.avail_out, uInt(bytes)); + end; + dec (len, s^.stream.avail_out); + inc (s^.stream.total_in, uLong(len)); + inc (s^.stream.total_out, uLong(len)); + gzread := int(len); + exit; + end; { IF transparent } + + if (s^.stream.avail_in = 0) and (s^.z_eof = false) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then begin + s^.z_err := Z_ERRNO; + break; + end; + end; + s^.stream.next_in := s^.inbuf; + end; + + s^.z_err := inflate(s^.stream, Z_NO_FLUSH); + + if (s^.z_err = Z_STREAM_END) then begin + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + { Check CRC and original size } + s^.crc := crc32(s^.crc, start, crclen); + start := s^.stream.next_out; + + filecrc := getLong (s); + filelen := getLong (s); + + if (s^.crc <> filecrc) or (s^.stream.total_out <> filelen) + then s^.z_err := Z_DATA_ERROR + else begin + { Check for concatenated .gz files: } + check_header(s); + if (s^.z_err = Z_OK) then begin + total_in := s^.stream.total_in; + total_out := s^.stream.total_out; + + inflateReset (s^.stream); + s^.stream.total_in := total_in; + s^.stream.total_out := total_out; + s^.crc := crc32 (0, Z_NULL, 0); + end; + end; {IF-THEN-ELSE} + end; + + if (s^.z_err <> Z_OK) or (s^.z_eof = true) then break; + + end; {WHILE} + + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + s^.crc := crc32 (s^.crc, start, crclen); + + gzread := int(len - s^.stream.avail_out); + +end; + + +{ GZGETC ==================================================================== + + Reads one byte from the compressed file. + gzgetc returns this byte or -1 in case of end of file or error. + +============================================================================} + +function gzgetc (f:gzfile) : int; + +var c:byte; + +begin + + if (gzread (f,@c,1) = 1) then gzgetc := c else gzgetc := -1; + +end; + + +{ GZGETS ==================================================================== + + Reads bytes from the compressed file until len-1 characters are read, + or a newline character is read and transferred to buf, or an end-of-file + condition is encountered. The string is then Null-terminated. + + gzgets returns buf, or Z_NULL in case of error. + The current implementation is not optimized at all. + +============================================================================} + +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +var + + b : PChar; { start of buffer } + bytes : Int; { number of bytes read by gzread } + gzchar : char; { char read by gzread } + +begin + + if (buf = Z_NULL) or (len <= 0) then begin + gzgets := Z_NULL; + exit; + end; + + b := buf; + repeat + dec (len); + bytes := gzread (f, buf, 1); + gzchar := buf^; + inc (buf); + until (len = 0) or (bytes <> 1) or (gzchar = Chr(13)); + + buf^ := Chr(0); + if (b = buf) and (len > 0) then gzgets := Z_NULL else gzgets := b; + +end; + + +{$IFNDEF NO_DEFLATE} + +{ GZWRITE =================================================================== + + Writes the given number of uncompressed bytes into the compressed file. + gzwrite returns the number of uncompressed bytes actually written + (0 in case of error). + +============================================================================} + +function gzwrite (f:gzfile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + written : integer; + +begin + + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + gzwrite := Z_STREAM_ERROR; + exit; + end; + + s^.stream.next_in := pBytef(buf); + s^.stream.avail_in := len; + + while (s^.stream.avail_in <> 0) do begin + + if (s^.stream.avail_out = 0) then begin + s^.stream.next_out := s^.outbuf; + blockwrite (s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); + if (written <> Z_BUFSIZE) then begin + s^.z_err := Z_ERRNO; + break; + end; + s^.stream.avail_out := Z_BUFSIZE; + end; + + s^.z_err := deflate(s^.stream, Z_NO_FLUSH); + if (s^.z_err <> Z_OK) then break; + + end; {WHILE} + + s^.crc := crc32(s^.crc, buf, len); + gzwrite := int(len - s^.stream.avail_in); + +end; + + +{ =========================================================================== + Converts, formats, and writes the args to the compressed file under + control of the format string, as in fprintf. gzprintf returns the number of + uncompressed bytes actually written (0 in case of error). +} + +{$IFDEF GZ_FORMAT_STRING} +function gzprintf (zfile : gzFile; + const format : string; + a : array of int) : int; +var + buf : array[0..Z_PRINTF_BUFSIZE-1] of char; + len : int; +begin +{$ifdef HAS_snprintf} + snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$else} + sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$endif} + len := strlen(buf); { old sprintf doesn't return the nb of bytes written } + if (len <= 0) return 0; + + gzprintf := gzwrite(file, buf, len); +end; +{$ENDIF} + + +{ GZPUTC ==================================================================== + + Writes c, converted to an unsigned char, into the compressed file. + gzputc returns the value that was written, or -1 in case of error. + +============================================================================} + +function gzputc (f:gzfile; c:char) : int; +begin + if (gzwrite (f,@c,1) = 1) then + {$IFDEF FPC} + gzputc := int(ord(c)) + {$ELSE} + gzputc := int(c) + {$ENDIF} + else + gzputc := -1; +end; + + +{ GZPUTS ==================================================================== + + Writes the given null-terminated string to the compressed file, excluding + the terminating null character. + gzputs returns the number of characters written, or -1 in case of error. + +============================================================================} + +function gzputs (f:gzfile; s:PChar) : int; +begin + gzputs := gzwrite (f, voidp(s), strlen(s)); +end; + + +{ DO_FLUSH ================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + +============================================================================} + +function do_flush (f:gzfile; flush:int) : int; +var + len : uInt; + done : boolean; + s : gz_streamp; + written : integer; +begin + done := false; + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + do_flush := Z_STREAM_ERROR; + exit; + end; + + s^.stream.avail_in := 0; { should be zero already anyway } + + while true do begin + + len := Z_BUFSIZE - s^.stream.avail_out; + + if (len <> 0) then begin + {$I-} + blockwrite(s^.gzfile, s^.outbuf^, len, written); + {$I+} + {$WARNINGS OFF} {Comparing signed and unsigned types} + if (written <> len) then begin + {$WARNINGS ON} + s^.z_err := Z_ERRNO; + do_flush := Z_ERRNO; + exit; + end; + s^.stream.next_out := s^.outbuf; + s^.stream.avail_out := Z_BUFSIZE; + end; + + if (done = true) then break; + s^.z_err := deflate(s^.stream, flush); + + { Ignore the second of two consecutive flushes: } + if (len = 0) and (s^.z_err = Z_BUF_ERROR) then s^.z_err := Z_OK; + + { deflate has finished flushing only when it hasn't used up + all the available space in the output buffer: } + + done := (s^.stream.avail_out <> 0) or (s^.z_err = Z_STREAM_END); + if (s^.z_err <> Z_OK) and (s^.z_err <> Z_STREAM_END) then break; + + end; {WHILE} + + if (s^.z_err = Z_STREAM_END) then do_flush:=Z_OK else do_flush:=s^.z_err; +end; + +{ GZFLUSH =================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + + The return value is the zlib error number (see function gzerror below). + gzflush returns Z_OK if the flush parameter is Z_FINISH and all output + could be flushed. + + gzflush should be called only when strictly necessary because it can + degrade compression. + +============================================================================} + +function gzflush (f:gzfile; flush:int) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + err := do_flush (f, flush); + + if (err <> 0) then begin + gzflush := err; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then gzflush := Z_OK else gzflush := s^.z_err; +end; + +{$ENDIF} (* NO DEFLATE *) + + +{ GZREWIND ================================================================== + + Rewinds input file. + +============================================================================} + +function gzrewind (f:gzFile) : int; +var + s:gz_streamp; +begin + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'r') then begin + gzrewind := -1; + exit; + end; + + s^.z_err := Z_OK; + s^.z_eof := false; + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + + if (s^.startpos = 0) then begin { not a compressed file } + {$I-} + seek (s^.gzfile, 0); + {$I+} + gzrewind := 0; + exit; + end; + + inflateReset(s^.stream); + {$I-} + seek (s^.gzfile, s^.startpos); + {$I+} + gzrewind := int(IOResult); + exit; +end; + + +{ GZSEEK ==================================================================== + + Sets the starting position for the next gzread or gzwrite on the given + compressed file. The offset represents a number of bytes from the beginning + of the uncompressed stream. + + gzseek returns the resulting offset, or -1 in case of error. + SEEK_END is not implemented, returns error. + In this version of the library, gzseek can be extremely slow. + +============================================================================} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +var + s : gz_streamp; + size : uInt; +begin + s := gz_streamp(f); + + if (s = NIL) or (whence = SEEK_END) or (s^.z_err = Z_ERRNO) + or (s^.z_err = Z_DATA_ERROR) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzseek := z_off_t(-1); + exit; +{$ELSE} + if (whence = SEEK_SET) then dec(offset, s^.stream.total_out); + if (offset < 0) then begin; + gzseek := z_off_t(-1); + exit; + end; + + { At this point, offset is the number of zero bytes to write. } + if (s^.inbuf = Z_NULL) then begin + GetMem (s^.inbuf, Z_BUFSIZE); + zmemzero(s^.inbuf, Z_BUFSIZE); + end; + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := uInt(offset); + + size := gzwrite(f, s^.inbuf, size); + if (size = 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + dec (offset,size); + end; + + gzseek := z_off_t(s^.stream.total_in); + exit; +{$ENDIF} + end; + { Rest of function is for reading only } + + { compute absolute position } + if (whence = SEEK_CUR) then inc (offset, s^.stream.total_out); + if (offset < 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.transparent = true) then begin + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + {$I-} + seek (s^.gzfile, offset); + {$I+} + if (IOResult <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + s^.stream.total_in := uLong(offset); + s^.stream.total_out := uLong(offset); + gzseek := z_off_t(offset); + exit; + end; + + { For a negative seek, rewind and use positive seek } + if (uLong(offset) >= s^.stream.total_out) + then dec (offset, s^.stream.total_out) + else if (gzrewind(f) <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + { offset is now the number of bytes to skip. } + + if (offset <> 0) and (s^.outbuf = Z_NULL) + then GetMem (s^.outbuf, Z_BUFSIZE); + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := int(offset); + + size := gzread (f, s^.outbuf, size); + if (size <= 0) then begin + gzseek := z_off_t(-1); + exit; + end; + dec(offset, size); + end; + + gzseek := z_off_t(s^.stream.total_out); +end; + + +{ GZTELL ==================================================================== + + Returns the starting position for the next gzread or gzwrite on the + given compressed file. This position represents a number of bytes in the + uncompressed data stream. + +============================================================================} + +function gztell (f:gzfile) : z_off_t; +begin + gztell := gzseek (f, 0, SEEK_CUR); +end; + + +{ GZEOF ===================================================================== + + Returns TRUE when EOF has previously been detected reading the given + input stream, otherwise FALSE. + +============================================================================} + +//function gzeof (f:gzfile) : boolean; +//var +// s:gz_streamp; +//begin +// s := gz_streamp(f); + +// if (s=NIL) or (s^.mode<>'r') then +// gzeof := false +// else +// gzeof := s^.z_eof; +//end; + + +{ PUTLONG =================================================================== + + Outputs a Longint in LSB order to the given file + +============================================================================} + +procedure putLong (var f:file; x:uLong); +var + n : int; + c : byte; +begin + for n:=0 to 3 do begin + c := x and $FF; + blockwrite (f, c, 1); + x := x shr 8; + end; +end; + + +{ GZCLOSE =================================================================== + + Flushes all pending output if necessary, closes the compressed file + and deallocates all the (de)compression state. + + The return value is the zlib error number (see function gzerror below). + +============================================================================} + +function gzclose (f:gzFile) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + gzclose := Z_STREAM_ERROR; + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzclose := Z_STREAM_ERROR; + exit; +{$ELSE} + err := do_flush (f, Z_FINISH); + if (err <> Z_OK) then begin + gzclose := destroyS (gz_streamp(f)); + exit; + end; + + putLong (s^.gzfile, s^.crc); + putLong (s^.gzfile, s^.stream.total_in); +{$ENDIF} + end; + + gzclose := destroyS (gz_streamp(f)); +end; + + +{ GZERROR =================================================================== + + Returns the error message for the last error which occured on the + given compressed file. errnum is set to zlib error number. If an + error occured in the file system and not in the compression library, + errnum is set to Z_ERRNO and the application may consult errno + to get the exact error code. + +============================================================================} + +function gzerror (f:gzfile; var errnum:int) : string; +var + m : string; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + errnum := Z_STREAM_ERROR; + gzerror := zError(Z_STREAM_ERROR); + end; + + errnum := s^.z_err; + if (errnum = Z_OK) then begin + gzerror := zError(Z_OK); + exit; + end; + + m := s^.stream.msg; + if (errnum = Z_ERRNO) then m := ''; + if (m = '') then m := zError(s^.z_err); + + s^.msg := s^.path+': '+m; + gzerror := s^.msg; +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/InfCodes.pas b/niftiview7/gzio/InfCodes.pas new file mode 100755 index 0000000..7efc590 --- /dev/null +++ b/niftiview7/gzio/InfCodes.pas @@ -0,0 +1,576 @@ +Unit InfCodes; + +{ infcodes.c -- process literals and length/distance pairs + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + {$IFDEF DEBUG} + strutils, + {$ENDIF} + zutil, zlib; + +function inflate_codes_new (bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var z : z_stream): pInflate_codes_state; + +function inflate_codes(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; + +procedure inflate_codes_free(c : pInflate_codes_state; + var z : z_stream); + +implementation + +uses + infutil, inffast; + + +function inflate_codes_new (bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var z : z_stream): pInflate_codes_state; +var + c : pInflate_codes_state; +begin + c := pInflate_codes_state( ZALLOC(z,1,sizeof(inflate_codes_state)) ); + if (c <> Z_NULL) then + begin + c^.mode := START; + c^.lbits := Byte(bl); + c^.dbits := Byte(bd); + c^.ltree := tl; + c^.dtree := td; + {$IFDEF DEBUG} + Tracev('inflate: codes new'); + {$ENDIF} + end; + inflate_codes_new := c; +end; + + +function inflate_codes(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; +var + j : uInt; { temporary storage } + t : pInflate_huft; { temporary pointer } + e : uInt; { extra bits or operation } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } + f : pBytef; { pointer to copy strings from } +var + c : pInflate_codes_state; +begin + c := s.sub.decode.codes; { codes state } + + { copy input/output information to locals } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + { process input and output based on current state } + while True do + case (c^.mode) of + { waiting for "i:"=input, "o:"=output, "x:"=nothing } + START: { x: set up for LEN } + begin +{$ifndef SLOW} + if (m >= 258) and (n >= 10) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + r := inflate_fast(c^.lbits, c^.dbits, c^.ltree, c^.dtree, s, z); + {LOAD} + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + if (r <> Z_OK) then + begin + if (r = Z_STREAM_END) then + c^.mode := WASH + else + c^.mode := BADCODE; + continue; { break for switch-statement in C } + end; + end; +{$endif} { not SLOW } + c^.sub.code.need := c^.lbits; + c^.sub.code.tree := c^.ltree; + c^.mode := LEN; { falltrough } + end; + LEN: { i: get length/literal/eob next } + begin + j := c^.sub.code.need; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + t := c^.sub.code.tree; + Inc(t, uInt(b) and inflate_mask[j]); + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + e := uInt(t^.exop); + if (e = 0) then { literal } + begin + c^.sub.lit := t^.base; + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: literal '+char(t^.base)) + else + Tracevv('inflate: literal '+IntToStr(t^.base)); + {$ENDIF} + c^.mode := LIT; + continue; { break switch statement } + end; + if (e and 16 <> 0) then { length } + begin + c^.sub.copy.get := e and 15; + c^.len := t^.base; + c^.mode := LENEXT; + continue; { break C-switch statement } + end; + if (e and 64 = 0) then { next table } + begin + c^.sub.code.need := e; + c^.sub.code.tree := @huft_ptr(t)^[t^.base]; + continue; { break C-switch statement } + end; + if (e and 32 <> 0) then { end of block } + begin + {$IFDEF DEBUG} + Tracevv('inflate: end of block'); + {$ENDIF} + c^.mode := WASH; + continue; { break C-switch statement } + end; + c^.mode := BADCODE; { invalid code } + z.msg := 'invalid literal/length code'; + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + LENEXT: { i: getting length extra (have base) } + begin + j := c^.sub.copy.get; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + Inc(c^.len, uInt(b and inflate_mask[j])); + {DUMPBITS(j);} + b := b shr j; + Dec(k, j); + + c^.sub.code.need := c^.dbits; + c^.sub.code.tree := c^.dtree; + {$IFDEF DEBUG} + Tracevv('inflate: length '+IntToStr(c^.len)); + {$ENDIF} + c^.mode := DIST; + { falltrough } + end; + DIST: { i: get distance next } + begin + j := c^.sub.code.need; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + t := @huft_ptr(c^.sub.code.tree)^[uInt(b) and inflate_mask[j]]; + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + e := uInt(t^.exop); + if (e and 16 <> 0) then { distance } + begin + c^.sub.copy.get := e and 15; + c^.sub.copy.dist := t^.base; + c^.mode := DISTEXT; + continue; { break C-switch statement } + end; + if (e and 64 = 0) then { next table } + begin + c^.sub.code.need := e; + c^.sub.code.tree := @huft_ptr(t)^[t^.base]; + continue; { break C-switch statement } + end; + c^.mode := BADCODE; { invalid code } + z.msg := 'invalid distance code'; + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + DISTEXT: { i: getting distance extra } + begin + j := c^.sub.copy.get; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + Inc(c^.sub.copy.dist, uInt(b) and inflate_mask[j]); + {DUMPBITS(j);} + b := b shr j; + Dec(k, j); + {$IFDEF DEBUG} + Tracevv('inflate: distance '+ IntToStr(c^.sub.copy.dist)); + {$ENDIF} + c^.mode := COPYZ; + { falltrough } + end; + COPYZ: { o: copying bytes in window, waiting for space } + begin + f := q; + Dec(f, c^.sub.copy.dist); + if (uInt(ptr2int(q) - ptr2int(s.window)) < c^.sub.copy.dist) then + begin + f := s.zend; + Dec(f, c^.sub.copy.dist - uInt(ptr2int(q) - ptr2int(s.window))); + end; + + while (c^.len <> 0) do + begin + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + {OUTBYTE( *f++)} + q^ := f^; + Inc(q); + Inc(f); + Dec(m); + + if (f = s.zend) then + f := s.window; + Dec(c^.len); + end; + c^.mode := START; + { C-switch break; not needed } + end; + LIT: { o: got literal, waiting for output space } + begin + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + {OUTBYTE(c^.sub.lit);} + q^ := c^.sub.lit; + Inc(q); + Dec(m); + + c^.mode := START; + {break;} + end; + WASH: { o: got eob, possibly more output } + begin + {$ifdef patch112} + if (k > 7) then { return unused byte, if any } + begin + {$IFDEF DEBUG} + Assert(k < 16, 'inflate_codes grabbed too many bytes'); + {$ENDIF} + Dec(k, 8); + Inc(n); + Dec(p); { can always return one } + end; + {$endif} + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + if (s.read <> s.write) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + c^.mode := ZEND; + { falltrough } + end; + + ZEND: + begin + r := Z_STREAM_END; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + BADCODE: { x: got error } + begin + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + else + begin + r := Z_STREAM_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; +{NEED_DUMMY_RETURN - Delphi2+ dumb compilers complain without this } + inflate_codes := Z_STREAM_ERROR; +end; + + +procedure inflate_codes_free(c : pInflate_codes_state; + var z : z_stream); +begin + ZFREE(z, c); + {$IFDEF DEBUG} + Tracev('inflate: codes free'); + {$ENDIF} +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/TREES.PAS b/niftiview7/gzio/TREES.PAS new file mode 100755 index 0000000..d4f5aaa --- /dev/null +++ b/niftiview7/gzio/TREES.PAS @@ -0,0 +1,2249 @@ +Unit trees; + +{$T-} +{$define ORG_DEBUG} +{ + trees.c -- output deflated data using Huffman coding + Copyright (C) 1995-1998 Jean-loup Gailly + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +{ + * ALGORITHM + * + * The "deflation" process uses several Huffman trees. The more + * common source values are represented by shorter bit sequences. + * + * Each code tree is stored in a compressed form which is itself + * a Huffman encoding of the lengths of all the code strings (in + * ascending order by source values). The actual code strings are + * reconstructed from the lengths in the inflate process, as described + * in the deflate specification. + * + * REFERENCES + * + * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". + * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc + * + * Storer, James A. + * Data Compression: Methods and Theory, pp. 49-50. + * Computer Science Press, 1988. ISBN 0-7167-8156-5. + * + * Sedgewick, R. + * Algorithms, p290. + * Addison-Wesley, 1983. ISBN 0-201-06672-6. + } + +interface + +{$I zconf.inc} + +uses + {$ifdef DEBUG} + strutils, + {$ENDIF} + zutil, zlib; + +{ =========================================================================== + Internal compression state. } + +const + LENGTH_CODES = 29; +{ number of length codes, not counting the special END_BLOCK code } + + LITERALS = 256; +{ number of literal bytes 0..255 } + + L_CODES = (LITERALS+1+LENGTH_CODES); +{ number of Literal or Length codes, including the END_BLOCK code } + + D_CODES = 30; +{ number of distance codes } + + BL_CODES = 19; +{ number of codes used to transfer the bit lengths } + + HEAP_SIZE = (2*L_CODES+1); +{ maximum heap size } + + MAX_BITS = 15; +{ All codes must not exceed MAX_BITS bits } + +const + INIT_STATE = 42; + BUSY_STATE = 113; + FINISH_STATE = 666; +{ Stream status } + + +{ Data structure describing a single value and its code string. } +type + ct_data_ptr = ^ct_data; + ct_data = record + fc : record + case byte of + 0:(freq : ush); { frequency count } + 1:(code : ush); { bit string } + end; + dl : record + case byte of + 0:(dad : ush); { father node in Huffman tree } + 1:(len : ush); { length of bit string } + end; + end; + +{ Freq = fc.freq + Code = fc.code + Dad = dl.dad + Len = dl.len } + +type + ltree_type = array[0..HEAP_SIZE-1] of ct_data; { literal and length tree } + dtree_type = array[0..2*D_CODES+1-1] of ct_data; { distance tree } + htree_type = array[0..2*BL_CODES+1-1] of ct_data; { Huffman tree for bit lengths } + { generic tree type } + tree_type = array[0..(MaxMemBlock div SizeOf(ct_data))-1] of ct_data; + + tree_ptr = ^tree_type; + ltree_ptr = ^ltree_type; + dtree_ptr = ^dtree_type; + htree_ptr = ^htree_type; + + +type + static_tree_desc_ptr = ^static_tree_desc; + static_tree_desc = + record + {const} static_tree : tree_ptr; { static tree or NIL } + {const} extra_bits : pzIntfArray; { extra bits for each code or NIL } + extra_base : int; { base index for extra_bits } + elems : int; { max number of elements in the tree } + max_length : int; { max bit length for the codes } + end; + + tree_desc_ptr = ^tree_desc; + tree_desc = record + dyn_tree : tree_ptr; { the dynamic tree } + max_code : int; { largest code with non zero frequency } + stat_desc : static_tree_desc_ptr; { the corresponding static tree } + end; + +type + Pos = ush; + Posf = Pos; {FAR} + IPos = uInt; + + pPosf = ^Posf; + + zPosfArray = array[0..(MaxMemBlock div SizeOf(Posf))-1] of Posf; + pzPosfArray = ^zPosfArray; + +{ A Pos is an index in the character window. We use short instead of int to + save space in the various tables. IPos is used only for parameter passing.} + +type + deflate_state_ptr = ^deflate_state; + deflate_state = record + strm : z_streamp; { pointer back to this zlib stream } + status : int; { as the name implies } + pending_buf : pzByteArray; { output still pending } + pending_buf_size : ulg; { size of pending_buf } + pending_out : pBytef; { next pending byte to output to the stream } + pending : int; { nb of bytes in the pending buffer } + noheader : int; { suppress zlib header and adler32 } + data_type : Byte; { UNKNOWN, BINARY or ASCII } + method : Byte; { STORED (for zip only) or DEFLATED } + last_flush : int; { value of flush param for previous deflate call } + + { used by deflate.pas: } + + w_size : uInt; { LZ77 window size (32K by default) } + w_bits : uInt; { log2(w_size) (8..16) } + w_mask : uInt; { w_size - 1 } + + window : pzByteArray; + { Sliding window. Input bytes are read into the second half of the window, + and move to the first half later to keep a dictionary of at least wSize + bytes. With this organization, matches are limited to a distance of + wSize-MAX_MATCH bytes, but this ensures that IO is always + performed with a length multiple of the block size. Also, it limits + the window size to 64K, which is quite useful on MSDOS. + To do: use the user input buffer as sliding window. } + + window_size : ulg; + { Actual size of window: 2*wSize, except when the user input buffer + is directly used as sliding window. } + + prev : pzPosfArray; + { Link to older string with same hash index. To limit the size of this + array to 64K, this link is maintained only for the last 32K strings. + An index in this array is thus a window index modulo 32K. } + + head : pzPosfArray; { Heads of the hash chains or NIL. } + + ins_h : uInt; { hash index of string to be inserted } + hash_size : uInt; { number of elements in hash table } + hash_bits : uInt; { log2(hash_size) } + hash_mask : uInt; { hash_size-1 } + + hash_shift : uInt; + { Number of bits by which ins_h must be shifted at each input + step. It must be such that after MIN_MATCH steps, the oldest + byte no longer takes part in the hash key, that is: + hash_shift * MIN_MATCH >= hash_bits } + + block_start : long; + { Window position at the beginning of the current output block. Gets + negative when the window is moved backwards. } + + match_length : uInt; { length of best match } + prev_match : IPos; { previous match } + match_available : boolean; { set if previous match exists } + strstart : uInt; { start of string to insert } + match_start : uInt; { start of matching string } + lookahead : uInt; { number of valid bytes ahead in window } + + prev_length : uInt; + { Length of the best match at previous step. Matches not greater than this + are discarded. This is used in the lazy match evaluation. } + + max_chain_length : uInt; + { To speed up deflation, hash chains are never searched beyond this + length. A higher limit improves compression ratio but degrades the + speed. } + + { moved to the end because Borland Pascal won't accept the following: + max_lazy_match : uInt; + max_insert_length : uInt absolute max_lazy_match; + } + + level : int; { compression level (1..9) } + strategy : int; { favor or force Huffman coding} + + good_match : uInt; + { Use a faster search when the previous match is longer than this } + + nice_match : int; { Stop searching when current match exceeds this } + + { used by trees.pas: } + { Didn't use ct_data typedef below to supress compiler warning } + dyn_ltree : ltree_type; { literal and length tree } + dyn_dtree : dtree_type; { distance tree } + bl_tree : htree_type; { Huffman tree for bit lengths } + + l_desc : tree_desc; { desc. for literal tree } + d_desc : tree_desc; { desc. for distance tree } + bl_desc : tree_desc; { desc. for bit length tree } + + bl_count : array[0..MAX_BITS+1-1] of ush; + { number of codes at each bit length for an optimal tree } + + heap : array[0..2*L_CODES+1-1] of int; { heap used to build the Huffman trees } + heap_len : int; { number of elements in the heap } + heap_max : int; { element of largest frequency } + { The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used. + The same heap array is used to build all trees. } + + depth : array[0..2*L_CODES+1-1] of uch; + { Depth of each subtree used as tie breaker for trees of equal frequency } + + + l_buf : puchfArray; { buffer for literals or lengths } + + lit_bufsize : uInt; + { Size of match buffer for literals/lengths. There are 4 reasons for + limiting lit_bufsize to 64K: + - frequencies can be kept in 16 bit counters + - if compression is not successful for the first block, all input + data is still in the window so we can still emit a stored block even + when input comes from standard input. (This can also be done for + all blocks if lit_bufsize is not greater than 32K.) + - if compression is not successful for a file smaller than 64K, we can + even emit a stored file instead of a stored block (saving 5 bytes). + This is applicable only for zip (not gzip or zlib). + - creating new Huffman trees less frequently may not provide fast + adaptation to changes in the input data statistics. (Take for + example a binary file with poorly compressible code followed by + a highly compressible string table.) Smaller buffer sizes give + fast adaptation but have of course the overhead of transmitting + trees more frequently. + - I can't count above 4 } + + + last_lit : uInt; { running index in l_buf } + + d_buf : pushfArray; + { Buffer for distances. To simplify the code, d_buf and l_buf have + the same number of elements. To use different lengths, an extra flag + array would be necessary. } + + opt_len : ulg; { bit length of current block with optimal trees } + static_len : ulg; { bit length of current block with static trees } + compressed_len : ulg; { total bit length of compressed file } + matches : uInt; { number of string matches in current block } + last_eob_len : int; { bit length of EOB code for last block } + +{$ifdef DEBUG} + bits_sent : ulg; { bit length of the compressed data } +{$endif} + + bi_buf : ush; + { Output buffer. bits are inserted starting at the bottom (least + significant bits). } + + bi_valid : int; + { Number of valid bits in bi_buf. All bits above the last valid bit + are always zero. } + + case byte of + 0:(max_lazy_match : uInt); + { Attempt to find a better match only when the current match is strictly + smaller than this value. This mechanism is used only for compression + levels >= 4. } + + 1:(max_insert_length : uInt); + { Insert new strings in the hash table only if the match length is not + greater than this length. This saves time but degrades compression. + max_insert_length is used only for compression levels <= 3. } + end; + +procedure _tr_init (var s : deflate_state); + +function _tr_tally (var s : deflate_state; + dist : unsigned; + lc : unsigned) : boolean; + +function _tr_flush_block (var s : deflate_state; + buf : pcharf; + stored_len : ulg; + eof : boolean) : ulg; + +procedure _tr_align(var s : deflate_state); + +procedure _tr_stored_block(var s : deflate_state; + buf : pcharf; + stored_len : ulg; + eof : boolean); + +implementation + +{ #define GEN_TREES_H } + +{$ifndef GEN_TREES_H} +{ header created automatically with -DGEN_TREES_H } + +const + DIST_CODE_LEN = 512; { see definition of array dist_code below } + +{ The static literal tree. Since the bit lengths are imposed, there is no + need for the L_CODES extra codes used during heap construction. However + The codes 286 and 287 are needed to build a canonical tree (see _tr_init + below). } +const + static_ltree : array[0..L_CODES+2-1] of ct_data = ( +{ fc:(freq, code) dl:(dad,len) } +(fc:(freq: 12);dl:(len: 8)), (fc:(freq:140);dl:(len: 8)), (fc:(freq: 76);dl:(len: 8)), +(fc:(freq:204);dl:(len: 8)), (fc:(freq: 44);dl:(len: 8)), (fc:(freq:172);dl:(len: 8)), +(fc:(freq:108);dl:(len: 8)), (fc:(freq:236);dl:(len: 8)), (fc:(freq: 28);dl:(len: 8)), +(fc:(freq:156);dl:(len: 8)), (fc:(freq: 92);dl:(len: 8)), (fc:(freq:220);dl:(len: 8)), +(fc:(freq: 60);dl:(len: 8)), (fc:(freq:188);dl:(len: 8)), (fc:(freq:124);dl:(len: 8)), +(fc:(freq:252);dl:(len: 8)), (fc:(freq: 2);dl:(len: 8)), (fc:(freq:130);dl:(len: 8)), +(fc:(freq: 66);dl:(len: 8)), (fc:(freq:194);dl:(len: 8)), (fc:(freq: 34);dl:(len: 8)), +(fc:(freq:162);dl:(len: 8)), (fc:(freq: 98);dl:(len: 8)), (fc:(freq:226);dl:(len: 8)), +(fc:(freq: 18);dl:(len: 8)), (fc:(freq:146);dl:(len: 8)), (fc:(freq: 82);dl:(len: 8)), +(fc:(freq:210);dl:(len: 8)), (fc:(freq: 50);dl:(len: 8)), (fc:(freq:178);dl:(len: 8)), +(fc:(freq:114);dl:(len: 8)), (fc:(freq:242);dl:(len: 8)), (fc:(freq: 10);dl:(len: 8)), +(fc:(freq:138);dl:(len: 8)), (fc:(freq: 74);dl:(len: 8)), (fc:(freq:202);dl:(len: 8)), +(fc:(freq: 42);dl:(len: 8)), (fc:(freq:170);dl:(len: 8)), (fc:(freq:106);dl:(len: 8)), +(fc:(freq:234);dl:(len: 8)), (fc:(freq: 26);dl:(len: 8)), (fc:(freq:154);dl:(len: 8)), +(fc:(freq: 90);dl:(len: 8)), (fc:(freq:218);dl:(len: 8)), (fc:(freq: 58);dl:(len: 8)), +(fc:(freq:186);dl:(len: 8)), (fc:(freq:122);dl:(len: 8)), (fc:(freq:250);dl:(len: 8)), +(fc:(freq: 6);dl:(len: 8)), (fc:(freq:134);dl:(len: 8)), (fc:(freq: 70);dl:(len: 8)), +(fc:(freq:198);dl:(len: 8)), (fc:(freq: 38);dl:(len: 8)), (fc:(freq:166);dl:(len: 8)), +(fc:(freq:102);dl:(len: 8)), (fc:(freq:230);dl:(len: 8)), (fc:(freq: 22);dl:(len: 8)), +(fc:(freq:150);dl:(len: 8)), (fc:(freq: 86);dl:(len: 8)), (fc:(freq:214);dl:(len: 8)), +(fc:(freq: 54);dl:(len: 8)), (fc:(freq:182);dl:(len: 8)), (fc:(freq:118);dl:(len: 8)), +(fc:(freq:246);dl:(len: 8)), (fc:(freq: 14);dl:(len: 8)), (fc:(freq:142);dl:(len: 8)), +(fc:(freq: 78);dl:(len: 8)), (fc:(freq:206);dl:(len: 8)), (fc:(freq: 46);dl:(len: 8)), +(fc:(freq:174);dl:(len: 8)), (fc:(freq:110);dl:(len: 8)), (fc:(freq:238);dl:(len: 8)), +(fc:(freq: 30);dl:(len: 8)), (fc:(freq:158);dl:(len: 8)), (fc:(freq: 94);dl:(len: 8)), +(fc:(freq:222);dl:(len: 8)), (fc:(freq: 62);dl:(len: 8)), (fc:(freq:190);dl:(len: 8)), +(fc:(freq:126);dl:(len: 8)), (fc:(freq:254);dl:(len: 8)), (fc:(freq: 1);dl:(len: 8)), +(fc:(freq:129);dl:(len: 8)), (fc:(freq: 65);dl:(len: 8)), (fc:(freq:193);dl:(len: 8)), +(fc:(freq: 33);dl:(len: 8)), (fc:(freq:161);dl:(len: 8)), (fc:(freq: 97);dl:(len: 8)), +(fc:(freq:225);dl:(len: 8)), (fc:(freq: 17);dl:(len: 8)), (fc:(freq:145);dl:(len: 8)), +(fc:(freq: 81);dl:(len: 8)), (fc:(freq:209);dl:(len: 8)), (fc:(freq: 49);dl:(len: 8)), +(fc:(freq:177);dl:(len: 8)), (fc:(freq:113);dl:(len: 8)), (fc:(freq:241);dl:(len: 8)), +(fc:(freq: 9);dl:(len: 8)), (fc:(freq:137);dl:(len: 8)), (fc:(freq: 73);dl:(len: 8)), +(fc:(freq:201);dl:(len: 8)), (fc:(freq: 41);dl:(len: 8)), (fc:(freq:169);dl:(len: 8)), +(fc:(freq:105);dl:(len: 8)), (fc:(freq:233);dl:(len: 8)), (fc:(freq: 25);dl:(len: 8)), +(fc:(freq:153);dl:(len: 8)), (fc:(freq: 89);dl:(len: 8)), (fc:(freq:217);dl:(len: 8)), +(fc:(freq: 57);dl:(len: 8)), (fc:(freq:185);dl:(len: 8)), (fc:(freq:121);dl:(len: 8)), +(fc:(freq:249);dl:(len: 8)), (fc:(freq: 5);dl:(len: 8)), (fc:(freq:133);dl:(len: 8)), +(fc:(freq: 69);dl:(len: 8)), (fc:(freq:197);dl:(len: 8)), (fc:(freq: 37);dl:(len: 8)), +(fc:(freq:165);dl:(len: 8)), (fc:(freq:101);dl:(len: 8)), (fc:(freq:229);dl:(len: 8)), +(fc:(freq: 21);dl:(len: 8)), (fc:(freq:149);dl:(len: 8)), (fc:(freq: 85);dl:(len: 8)), +(fc:(freq:213);dl:(len: 8)), (fc:(freq: 53);dl:(len: 8)), (fc:(freq:181);dl:(len: 8)), +(fc:(freq:117);dl:(len: 8)), (fc:(freq:245);dl:(len: 8)), (fc:(freq: 13);dl:(len: 8)), +(fc:(freq:141);dl:(len: 8)), (fc:(freq: 77);dl:(len: 8)), (fc:(freq:205);dl:(len: 8)), +(fc:(freq: 45);dl:(len: 8)), (fc:(freq:173);dl:(len: 8)), (fc:(freq:109);dl:(len: 8)), +(fc:(freq:237);dl:(len: 8)), (fc:(freq: 29);dl:(len: 8)), (fc:(freq:157);dl:(len: 8)), +(fc:(freq: 93);dl:(len: 8)), (fc:(freq:221);dl:(len: 8)), (fc:(freq: 61);dl:(len: 8)), +(fc:(freq:189);dl:(len: 8)), (fc:(freq:125);dl:(len: 8)), (fc:(freq:253);dl:(len: 8)), +(fc:(freq: 19);dl:(len: 9)), (fc:(freq:275);dl:(len: 9)), (fc:(freq:147);dl:(len: 9)), +(fc:(freq:403);dl:(len: 9)), (fc:(freq: 83);dl:(len: 9)), (fc:(freq:339);dl:(len: 9)), +(fc:(freq:211);dl:(len: 9)), (fc:(freq:467);dl:(len: 9)), (fc:(freq: 51);dl:(len: 9)), +(fc:(freq:307);dl:(len: 9)), (fc:(freq:179);dl:(len: 9)), (fc:(freq:435);dl:(len: 9)), +(fc:(freq:115);dl:(len: 9)), (fc:(freq:371);dl:(len: 9)), (fc:(freq:243);dl:(len: 9)), +(fc:(freq:499);dl:(len: 9)), (fc:(freq: 11);dl:(len: 9)), (fc:(freq:267);dl:(len: 9)), +(fc:(freq:139);dl:(len: 9)), (fc:(freq:395);dl:(len: 9)), (fc:(freq: 75);dl:(len: 9)), +(fc:(freq:331);dl:(len: 9)), (fc:(freq:203);dl:(len: 9)), (fc:(freq:459);dl:(len: 9)), +(fc:(freq: 43);dl:(len: 9)), (fc:(freq:299);dl:(len: 9)), (fc:(freq:171);dl:(len: 9)), +(fc:(freq:427);dl:(len: 9)), (fc:(freq:107);dl:(len: 9)), (fc:(freq:363);dl:(len: 9)), +(fc:(freq:235);dl:(len: 9)), (fc:(freq:491);dl:(len: 9)), (fc:(freq: 27);dl:(len: 9)), +(fc:(freq:283);dl:(len: 9)), (fc:(freq:155);dl:(len: 9)), (fc:(freq:411);dl:(len: 9)), +(fc:(freq: 91);dl:(len: 9)), (fc:(freq:347);dl:(len: 9)), (fc:(freq:219);dl:(len: 9)), +(fc:(freq:475);dl:(len: 9)), (fc:(freq: 59);dl:(len: 9)), (fc:(freq:315);dl:(len: 9)), +(fc:(freq:187);dl:(len: 9)), (fc:(freq:443);dl:(len: 9)), (fc:(freq:123);dl:(len: 9)), +(fc:(freq:379);dl:(len: 9)), (fc:(freq:251);dl:(len: 9)), (fc:(freq:507);dl:(len: 9)), +(fc:(freq: 7);dl:(len: 9)), (fc:(freq:263);dl:(len: 9)), (fc:(freq:135);dl:(len: 9)), +(fc:(freq:391);dl:(len: 9)), (fc:(freq: 71);dl:(len: 9)), (fc:(freq:327);dl:(len: 9)), +(fc:(freq:199);dl:(len: 9)), (fc:(freq:455);dl:(len: 9)), (fc:(freq: 39);dl:(len: 9)), +(fc:(freq:295);dl:(len: 9)), (fc:(freq:167);dl:(len: 9)), (fc:(freq:423);dl:(len: 9)), +(fc:(freq:103);dl:(len: 9)), (fc:(freq:359);dl:(len: 9)), (fc:(freq:231);dl:(len: 9)), +(fc:(freq:487);dl:(len: 9)), (fc:(freq: 23);dl:(len: 9)), (fc:(freq:279);dl:(len: 9)), +(fc:(freq:151);dl:(len: 9)), (fc:(freq:407);dl:(len: 9)), (fc:(freq: 87);dl:(len: 9)), +(fc:(freq:343);dl:(len: 9)), (fc:(freq:215);dl:(len: 9)), (fc:(freq:471);dl:(len: 9)), +(fc:(freq: 55);dl:(len: 9)), (fc:(freq:311);dl:(len: 9)), (fc:(freq:183);dl:(len: 9)), +(fc:(freq:439);dl:(len: 9)), (fc:(freq:119);dl:(len: 9)), (fc:(freq:375);dl:(len: 9)), +(fc:(freq:247);dl:(len: 9)), (fc:(freq:503);dl:(len: 9)), (fc:(freq: 15);dl:(len: 9)), +(fc:(freq:271);dl:(len: 9)), (fc:(freq:143);dl:(len: 9)), (fc:(freq:399);dl:(len: 9)), +(fc:(freq: 79);dl:(len: 9)), (fc:(freq:335);dl:(len: 9)), (fc:(freq:207);dl:(len: 9)), +(fc:(freq:463);dl:(len: 9)), (fc:(freq: 47);dl:(len: 9)), (fc:(freq:303);dl:(len: 9)), +(fc:(freq:175);dl:(len: 9)), (fc:(freq:431);dl:(len: 9)), (fc:(freq:111);dl:(len: 9)), +(fc:(freq:367);dl:(len: 9)), (fc:(freq:239);dl:(len: 9)), (fc:(freq:495);dl:(len: 9)), +(fc:(freq: 31);dl:(len: 9)), (fc:(freq:287);dl:(len: 9)), (fc:(freq:159);dl:(len: 9)), +(fc:(freq:415);dl:(len: 9)), (fc:(freq: 95);dl:(len: 9)), (fc:(freq:351);dl:(len: 9)), +(fc:(freq:223);dl:(len: 9)), (fc:(freq:479);dl:(len: 9)), (fc:(freq: 63);dl:(len: 9)), +(fc:(freq:319);dl:(len: 9)), (fc:(freq:191);dl:(len: 9)), (fc:(freq:447);dl:(len: 9)), +(fc:(freq:127);dl:(len: 9)), (fc:(freq:383);dl:(len: 9)), (fc:(freq:255);dl:(len: 9)), +(fc:(freq:511);dl:(len: 9)), (fc:(freq: 0);dl:(len: 7)), (fc:(freq: 64);dl:(len: 7)), +(fc:(freq: 32);dl:(len: 7)), (fc:(freq: 96);dl:(len: 7)), (fc:(freq: 16);dl:(len: 7)), +(fc:(freq: 80);dl:(len: 7)), (fc:(freq: 48);dl:(len: 7)), (fc:(freq:112);dl:(len: 7)), +(fc:(freq: 8);dl:(len: 7)), (fc:(freq: 72);dl:(len: 7)), (fc:(freq: 40);dl:(len: 7)), +(fc:(freq:104);dl:(len: 7)), (fc:(freq: 24);dl:(len: 7)), (fc:(freq: 88);dl:(len: 7)), +(fc:(freq: 56);dl:(len: 7)), (fc:(freq:120);dl:(len: 7)), (fc:(freq: 4);dl:(len: 7)), +(fc:(freq: 68);dl:(len: 7)), (fc:(freq: 36);dl:(len: 7)), (fc:(freq:100);dl:(len: 7)), +(fc:(freq: 20);dl:(len: 7)), (fc:(freq: 84);dl:(len: 7)), (fc:(freq: 52);dl:(len: 7)), +(fc:(freq:116);dl:(len: 7)), (fc:(freq: 3);dl:(len: 8)), (fc:(freq:131);dl:(len: 8)), +(fc:(freq: 67);dl:(len: 8)), (fc:(freq:195);dl:(len: 8)), (fc:(freq: 35);dl:(len: 8)), +(fc:(freq:163);dl:(len: 8)), (fc:(freq: 99);dl:(len: 8)), (fc:(freq:227);dl:(len: 8)) +); + + +{ The static distance tree. (Actually a trivial tree since all lens use + 5 bits.) } + static_dtree : array[0..D_CODES-1] of ct_data = ( +(fc:(freq: 0); dl:(len:5)), (fc:(freq:16); dl:(len:5)), (fc:(freq: 8); dl:(len:5)), +(fc:(freq:24); dl:(len:5)), (fc:(freq: 4); dl:(len:5)), (fc:(freq:20); dl:(len:5)), +(fc:(freq:12); dl:(len:5)), (fc:(freq:28); dl:(len:5)), (fc:(freq: 2); dl:(len:5)), +(fc:(freq:18); dl:(len:5)), (fc:(freq:10); dl:(len:5)), (fc:(freq:26); dl:(len:5)), +(fc:(freq: 6); dl:(len:5)), (fc:(freq:22); dl:(len:5)), (fc:(freq:14); dl:(len:5)), +(fc:(freq:30); dl:(len:5)), (fc:(freq: 1); dl:(len:5)), (fc:(freq:17); dl:(len:5)), +(fc:(freq: 9); dl:(len:5)), (fc:(freq:25); dl:(len:5)), (fc:(freq: 5); dl:(len:5)), +(fc:(freq:21); dl:(len:5)), (fc:(freq:13); dl:(len:5)), (fc:(freq:29); dl:(len:5)), +(fc:(freq: 3); dl:(len:5)), (fc:(freq:19); dl:(len:5)), (fc:(freq:11); dl:(len:5)), +(fc:(freq:27); dl:(len:5)), (fc:(freq: 7); dl:(len:5)), (fc:(freq:23); dl:(len:5)) +); + +{ Distance codes. The first 256 values correspond to the distances + 3 .. 258, the last 256 values correspond to the top 8 bits of + the 15 bit distances. } + _dist_code : array[0..DIST_CODE_LEN-1] of uch = ( + 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, + 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10, +10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, +11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, +12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13, +13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, +13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17, +18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22, +23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29 +); + +{ length code for each normalized match length (0 == MIN_MATCH) } + _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch = ( + 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12, +13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16, +17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, +19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, +21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22, +22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23, +23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, +25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28 +); + + +{ First normalized length for each code (0 = MIN_MATCH) } + base_length : array[0..LENGTH_CODES-1] of int = ( +0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56, +64, 80, 96, 112, 128, 160, 192, 224, 0 +); + + +{ First normalized distance for each code (0 = distance of 1) } + base_dist : array[0..D_CODES-1] of int = ( + 0, 1, 2, 3, 4, 6, 8, 12, 16, 24, + 32, 48, 64, 96, 128, 192, 256, 384, 512, 768, + 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576 +); +{$endif} + +{ Output a byte on the stream. + IN assertion: there is enough room in pending_buf. +macro put_byte(s, c) +begin + s^.pending_buf^[s^.pending] := (c); + Inc(s^.pending); +end +} + +const + MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1); +{ Minimum amount of lookahead, except at the end of the input file. + See deflate.c for comments about the MIN_MATCH+1. } + +{macro d_code(dist) + if (dist) < 256 then + := _dist_code[dist] + else + := _dist_code[256+((dist) shr 7)]); + Mapping from a distance to a distance code. dist is the distance - 1 and + must not have side effects. _dist_code[256] and _dist_code[257] are never + used. } + +{$ifndef ORG_DEBUG} +{ Inline versions of _tr_tally for speed: } + +#if defined(GEN_TREES_H) || !defined(STDC) + extern uch _length_code[]; + extern uch _dist_code[]; +#else + extern const uch _length_code[]; + extern const uch _dist_code[]; +#endif + +macro _tr_tally_lit(s, c, flush) +var + cc : uch; +begin + cc := (c); + s^.d_buf[s^.last_lit] := 0; + s^.l_buf[s^.last_lit] := cc; + Inc(s^.last_lit); + Inc(s^.dyn_ltree[cc].fc.Freq); + flush := (s^.last_lit = s^.lit_bufsize-1); +end; + +macro _tr_tally_dist(s, distance, length, flush) \ +var + len : uch; + dist : ush; +begin + len := (length); + dist := (distance); + s^.d_buf[s^.last_lit] := dist; + s^.l_buf[s^.last_lit] = len; + Inc(s^.last_lit); + Dec(dist); + Inc(s^.dyn_ltree[_length_code[len]+LITERALS+1].fc.Freq); + Inc(s^.dyn_dtree[d_code(dist)].Freq); + flush := (s^.last_lit = s^.lit_bufsize-1); +end; + +{$endif} + +{ =========================================================================== + Constants } + +const + MAX_BL_BITS = 7; +{ Bit length codes must not exceed MAX_BL_BITS bits } + +const + END_BLOCK = 256; +{ end of block literal code } + +const + REP_3_6 = 16; +{ repeat previous bit length 3-6 times (2 bits of repeat count) } + +const + REPZ_3_10 = 17; +{ repeat a zero length 3-10 times (3 bits of repeat count) } + +const + REPZ_11_138 = 18; +{ repeat a zero length 11-138 times (7 bits of repeat count) } + +{local} +const + extra_lbits : array[0..LENGTH_CODES-1] of int + { extra bits for each length code } + = (0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0); + +{local} +const + extra_dbits : array[0..D_CODES-1] of int + { extra bits for each distance code } + = (0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13); + +{local} +const + extra_blbits : array[0..BL_CODES-1] of int { extra bits for each bit length code } + = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7); + +{local} +const + bl_order : array[0..BL_CODES-1] of uch + = (16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15); +{ The lengths of the bit length codes are sent in order of decreasing + probability, to avoid transmitting the lengths for unused bit length codes. + } + +const + Buf_size = (8 * 2*sizeof(char)); +{ Number of bits used within bi_buf. (bi_buf might be implemented on + more than 16 bits on some systems.) } + +{ =========================================================================== + Local data. These are initialized only once. } + + +{$ifdef GEN_TREES_H)} +{ non ANSI compilers may not accept trees.h } + +const + DIST_CODE_LEN = 512; { see definition of array dist_code below } + +{local} +var + static_ltree : array[0..L_CODES+2-1] of ct_data; +{ The static literal tree. Since the bit lengths are imposed, there is no + need for the L_CODES extra codes used during heap construction. However + The codes 286 and 287 are needed to build a canonical tree (see _tr_init + below). } + +{local} + static_dtree : array[0..D_CODES-1] of ct_data; +{ The static distance tree. (Actually a trivial tree since all codes use + 5 bits.) } + + _dist_code : array[0..DIST_CODE_LEN-1] of uch; +{ Distance codes. The first 256 values correspond to the distances + 3 .. 258, the last 256 values correspond to the top 8 bits of + the 15 bit distances. } + + _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch; +{ length code for each normalized match length (0 == MIN_MATCH) } + +{local} + base_length : array[0..LENGTH_CODES-1] of int; +{ First normalized length for each code (0 = MIN_MATCH) } + +{local} + base_dist : array[0..D_CODES-1] of int; +{ First normalized distance for each code (0 = distance of 1) } + +{$endif} { GEN_TREES_H } + +{local} +const + static_l_desc : static_tree_desc = + (static_tree: {tree_ptr}(@(static_ltree)); { pointer to array of ct_data } + extra_bits: {pzIntfArray}(@(extra_lbits)); { pointer to array of int } + extra_base: LITERALS+1; + elems: L_CODES; + max_length: MAX_BITS); + +{local} +const + static_d_desc : static_tree_desc = + (static_tree: {tree_ptr}(@(static_dtree)); + extra_bits: {pzIntfArray}(@(extra_dbits)); + extra_base : 0; + elems: D_CODES; + max_length: MAX_BITS); + +{local} +const + static_bl_desc : static_tree_desc = + (static_tree: {tree_ptr}(NIL); + extra_bits: {pzIntfArray}@(extra_blbits); + extra_base : 0; + elems: BL_CODES; + max_length: MAX_BL_BITS); + +(* =========================================================================== + Local (static) routines in this file. } + +procedure tr_static_init; +procedure init_block(var deflate_state); +procedure pqdownheap(var s : deflate_state; + var tree : ct_data; + k : int); +procedure gen_bitlen(var s : deflate_state; + var desc : tree_desc); +procedure gen_codes(var tree : ct_data; + max_code : int; + bl_count : pushf); +procedure build_tree(var s : deflate_state; + var desc : tree_desc); +procedure scan_tree(var s : deflate_state; + var tree : ct_data; + max_code : int); +procedure send_tree(var s : deflate_state; + var tree : ct_data; + max_code : int); +function build_bl_tree(var deflate_state) : int; +procedure send_all_trees(var deflate_state; + lcodes : int; + dcodes : int; + blcodes : int); +procedure compress_block(var s : deflate_state; + var ltree : ct_data; + var dtree : ct_data); +procedure set_data_type(var s : deflate_state); +function bi_reverse(value : unsigned; + length : int) : unsigned; +procedure bi_windup(var deflate_state); +procedure bi_flush(var deflate_state); +procedure copy_block(var deflate_state; + buf : pcharf; + len : unsigned; + header : int); +*) + +{$ifdef GEN_TREES_H} +{local} +procedure gen_trees_header; +{$endif} + +(* +{ =========================================================================== + Output a short LSB first on the stream. + IN assertion: there is enough room in pendingBuf. } + +macro put_short(s, w) +begin + {put_byte(s, (uch)((w) & 0xff));} + s.pending_buf^[s.pending] := uch((w) and $ff); + Inc(s.pending); + + {put_byte(s, (uch)((ush)(w) >> 8));} + s.pending_buf^[s.pending] := uch(ush(w) shr 8);; + Inc(s.pending); +end +*) + +{ =========================================================================== + Send a value on a given number of bits. + IN assertion: length <= 16 and value fits in length bits. } + +{$ifdef ORG_DEBUG} + +{local} +procedure send_bits(var s : deflate_state; + value : int; { value to send } + length : int); { number of bits } +begin + {$ifdef DEBUG} + Tracevv(' l '+IntToStr(length)+ ' v '+IntToStr(value)); + Assert((length > 0) and (length <= 15), 'invalid length'); + Inc(s.bits_sent, ulg(length)); + {$ENDIF} + + { If not enough room in bi_buf, use (valid) bits from bi_buf and + (16 - bi_valid) bits from value, leaving (width - (16-bi_valid)) + unused bits in value. } + {$IFOPT Q+} {$Q-} {$DEFINE NoOverflowCheck} {$ENDIF} + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (s.bi_valid > int(Buf_size) - length) then + begin + s.bi_buf := s.bi_buf or int(value shl s.bi_valid); + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s.bi_buf := ush(value) shr (Buf_size - s.bi_valid); + Inc(s.bi_valid, length - Buf_size); + end + else + begin + s.bi_buf := s.bi_buf or int(value shl s.bi_valid); + Inc(s.bi_valid, length); + end; + {$IFDEF NoOverflowCheck} {$Q+} {$UNDEF NoOverflowCheck} {$ENDIF} + {$IFDEF NoRangeCheck} {$Q+} {$UNDEF NoRangeCheck} {$ENDIF} +end; + +{$else} { !DEBUG } + + +macro send_code(s, c, tree) +begin + send_bits(s, tree[c].Code, tree[c].Len); + { Send a code of the given tree. c and tree must not have side effects } +end + +macro send_bits(s, value, length) \ +begin int len := length;\ + if (s^.bi_valid > (int)Buf_size - len) begin\ + int val := value;\ + s^.bi_buf |= (val << s^.bi_valid);\ + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s^.bi_buf := (ush)val >> (Buf_size - s^.bi_valid);\ + s^.bi_valid += len - Buf_size;\ + end else begin\ + s^.bi_buf |= (value) << s^.bi_valid;\ + s^.bi_valid += len;\ + end\ +end; +{$endif} { DEBUG } + +{ =========================================================================== + Reverse the first len bits of a code, using straightforward code (a faster + method would use a table) + IN assertion: 1 <= len <= 15 } + +{local} +function bi_reverse(code : unsigned; { the value to invert } + len : int) : unsigned; { its bit length } + +var + res : unsigned; {register} +begin + res := 0; + repeat + res := res or (code and 1); + code := code shr 1; + res := res shl 1; + Dec(len); + until (len <= 0); + bi_reverse := res shr 1; +end; + +{ =========================================================================== + Generate the codes for a given tree and bit counts (which need not be + optimal). + IN assertion: the array bl_count contains the bit length statistics for + the given tree and the field len is set for all tree elements. + OUT assertion: the field code is set for all tree elements of non + zero code length. } + +{local} +procedure gen_codes(tree : tree_ptr; { the tree to decorate } + max_code : int; { largest code with non zero frequency } + var bl_count : array of ushf); { number of codes at each bit length } + +var + next_code : array[0..MAX_BITS+1-1] of ush; { next code value for each bit length } + code : ush; { running code value } + bits : int; { bit index } + n : int; { code index } +var + len : int; +begin + code := 0; + + { The distribution counts are first used to generate the code values + without bit reversal. } + + for bits := 1 to MAX_BITS do + begin + code := ((code + bl_count[bits-1]) shl 1); + next_code[bits] := code; + end; + { Check that the bit counts in bl_count are consistent. The last code + must be all ones. } + + {$IFDEF DEBUG} + Assert (code + bl_count[MAX_BITS]-1 = (1 shl MAX_BITS)-1, + 'inconsistent bit counts'); + Tracev(#13'gen_codes: max_code '+IntToStr(max_code)); + {$ENDIF} + + for n := 0 to max_code do + begin + len := tree^[n].dl.Len; + if (len = 0) then + continue; + { Now reverse the bits } + tree^[n].fc.Code := bi_reverse(next_code[len], len); + Inc(next_code[len]); + {$ifdef DEBUG} + if (n>31) and (n<128) then + Tracecv(tree <> tree_ptr(@static_ltree), + (^M'n #'+IntToStr(n)+' '+char(n)+' l '+IntToStr(len)+' c '+ + IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')')) + else + Tracecv(tree <> tree_ptr(@static_ltree), + (^M'n #'+IntToStr(n)+' l '+IntToStr(len)+' c '+ + IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')')); + {$ENDIF} + end; +end; + +{ =========================================================================== + Genererate the file trees.h describing the static trees. } +{$ifdef GEN_TREES_H} + +macro SEPARATOR(i, last, width) + if (i) = (last) then + ( ^M');'^M^M + else \ + if (i) mod (width) = (width)-1 then + ','^M + else + ', ' + +procedure gen_trees_header; +var + header : system.text; + i : int; +begin + system.assign(header, 'trees.inc'); + {$I-} + ReWrite(header); + {$I+} + Assert (IOresult <> 0, 'Can''t open trees.h'); + WriteLn(header, + '{ header created automatically with -DGEN_TREES_H }'^M); + + WriteLn(header, 'local const ct_data static_ltree[L_CODES+2] := ('); + for i := 0 to L_CODES+2-1 do + begin + WriteLn(header, '((%3u),(%3u))%s', static_ltree[i].Code, + static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5)); + end; + + WriteLn(header, 'local const ct_data static_dtree[D_CODES] := ('); + for i := 0 to D_CODES-1 do + begin + WriteLn(header, '((%2u),(%2u))%s', static_dtree[i].Code, + static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5)); + end; + + WriteLn(header, 'const uch _dist_code[DIST_CODE_LEN] := ('); + for i := 0 to DIST_CODE_LEN-1 do + begin + WriteLn(header, '%2u%s', _dist_code[i], + SEPARATOR(i, DIST_CODE_LEN-1, 20)); + end; + + WriteLn(header, 'const uch _length_code[MAX_MATCH-MIN_MATCH+1]= ('); + for i := 0 to MAX_MATCH-MIN_MATCH+1-1 do + begin + WriteLn(header, '%2u%s', _length_code[i], + SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20)); + end; + + WriteLn(header, 'local const int base_length[LENGTH_CODES] := ('); + for i := 0 to LENGTH_CODES-1 do + begin + WriteLn(header, '%1u%s', base_length[i], + SEPARATOR(i, LENGTH_CODES-1, 20)); + end; + + WriteLn(header, 'local const int base_dist[D_CODES] := ('); + for i := 0 to D_CODES-1 do + begin + WriteLn(header, '%5u%s', base_dist[i], + SEPARATOR(i, D_CODES-1, 10)); + end; + + close(header); +end; +{$endif} { GEN_TREES_H } + + +{ =========================================================================== + Initialize the various 'constant' tables. } + +{local} +procedure tr_static_init; + +{$ifdef GEN_TREES_H} +const + static_init_done : boolean = FALSE; +var + n : int; { iterates over tree elements } + bits : int; { bit counter } + length : int; { length value } + code : int; { code value } + dist : int; { distance index } + bl_count : array[0..MAX_BITS+1-1] of ush; + { number of codes at each bit length for an optimal tree } +begin + if (static_init_done) then + exit; + + { Initialize the mapping length (0..255) -> length code (0..28) } + length := 0; + for code := 0 to LENGTH_CODES-1-1 do + begin + base_length[code] := length; + for n := 0 to (1 shl extra_lbits[code])-1 do + begin + _length_code[length] := uch(code); + Inc(length); + end; + end; + Assert (length = 256, 'tr_static_init: length <> 256'); + { Note that the length 255 (match length 258) can be represented + in two different ways: code 284 + 5 bits or code 285, so we + overwrite length_code[255] to use the best encoding: } + + _length_code[length-1] := uch(code); + + { Initialize the mapping dist (0..32K) -> dist code (0..29) } + dist := 0; + for code := 0 to 16-1 do + begin + base_dist[code] := dist; + for n := 0 to (1 shl extra_dbits[code])-1 do + begin + _dist_code[dist] := uch(code); + Inc(dist); + end; + end; + Assert (dist = 256, 'tr_static_init: dist <> 256'); + dist := dist shr 7; { from now on, all distances are divided by 128 } + for code := 16 to D_CODES-1 do + begin + base_dist[code] := dist shl 7; + for n := 0 to (1 shl (extra_dbits[code]-7))-1 do + begin + _dist_code[256 + dist] := uch(code); + Inc(dist); + end; + end; + Assert (dist = 256, 'tr_static_init: 256+dist <> 512'); + + { Construct the codes of the static literal tree } + for bits := 0 to MAX_BITS do + bl_count[bits] := 0; + n := 0; + while (n <= 143) do + begin + static_ltree[n].dl.Len := 8; + Inc(n); + Inc(bl_count[8]); + end; + while (n <= 255) do + begin + static_ltree[n].dl.Len := 9; + Inc(n); + Inc(bl_count[9]); + end; + while (n <= 279) do + begin + static_ltree[n].dl.Len := 7; + Inc(n); + Inc(bl_count[7]); + end; + while (n <= 287) do + begin + static_ltree[n].dl.Len := 8; + Inc(n); + Inc(bl_count[8]); + end; + + { Codes 286 and 287 do not exist, but we must include them in the + tree construction to get a canonical Huffman tree (longest code + all ones) } + + gen_codes(tree_ptr(@static_ltree), L_CODES+1, bl_count); + + { The static distance tree is trivial: } + for n := 0 to D_CODES-1 do + begin + static_dtree[n].dl.Len := 5; + static_dtree[n].fc.Code := bi_reverse(unsigned(n), 5); + end; + static_init_done := TRUE; + + gen_trees_header; { save to include file } +{$else} +begin +{$endif} { GEN_TREES_H) } +end; + +{ =========================================================================== + Initialize a new block. } +{local} + +procedure init_block(var s : deflate_state); +var + n : int; { iterates over tree elements } +begin + { Initialize the trees. } + for n := 0 to L_CODES-1 do + s.dyn_ltree[n].fc.Freq := 0; + for n := 0 to D_CODES-1 do + s.dyn_dtree[n].fc.Freq := 0; + for n := 0 to BL_CODES-1 do + s.bl_tree[n].fc.Freq := 0; + + s.dyn_ltree[END_BLOCK].fc.Freq := 1; + s.static_len := Long(0); + s.opt_len := Long(0); + s.matches := 0; + s.last_lit := 0; +end; + +const + SMALLEST = 1; +{ Index within the heap array of least frequent node in the Huffman tree } + +{ =========================================================================== + Initialize the tree data structures for a new zlib stream. } +procedure _tr_init(var s : deflate_state); +begin + tr_static_init; + + s.compressed_len := Long(0); + + s.l_desc.dyn_tree := tree_ptr(@s.dyn_ltree); + s.l_desc.stat_desc := @static_l_desc; + + s.d_desc.dyn_tree := tree_ptr(@s.dyn_dtree); + s.d_desc.stat_desc := @static_d_desc; + + s.bl_desc.dyn_tree := tree_ptr(@s.bl_tree); + s.bl_desc.stat_desc := @static_bl_desc; + + s.bi_buf := 0; + s.bi_valid := 0; + s.last_eob_len := 8; { enough lookahead for inflate } +{$ifdef DEBUG} + s.bits_sent := Long(0); +{$endif} + + { Initialize the first block of the first file: } + init_block(s); +end; + +{ =========================================================================== + Remove the smallest element from the heap and recreate the heap with + one less element. Updates heap and heap_len. + +macro pqremove(s, tree, top) +begin + top := s.heap[SMALLEST]; + s.heap[SMALLEST] := s.heap[s.heap_len]; + Dec(s.heap_len); + pqdownheap(s, tree, SMALLEST); +end +} + +{ =========================================================================== + Compares to subtrees, using the tree depth as tie breaker when + the subtrees have equal frequency. This minimizes the worst case length. + +macro smaller(tree, n, m, depth) + ( (tree[n].Freq < tree[m].Freq) or + ((tree[n].Freq = tree[m].Freq) and (depth[n] <= depth[m])) ) +} + +{ =========================================================================== + Restore the heap property by moving down the tree starting at node k, + exchanging a node with the smallest of its two sons if necessary, stopping + when the heap property is re-established (each father smaller than its + two sons). } +{local} + +procedure pqdownheap(var s : deflate_state; + var tree : tree_type; { the tree to restore } + k : int); { node to move down } +var + v : int; + j : int; +begin + v := s.heap[k]; + j := k shl 1; { left son of k } + while (j <= s.heap_len) do + begin + { Set j to the smallest of the two sons: } + if (j < s.heap_len) and + {smaller(tree, s.heap[j+1], s.heap[j], s.depth)} + ( (tree[s.heap[j+1]].fc.Freq < tree[s.heap[j]].fc.Freq) or + ((tree[s.heap[j+1]].fc.Freq = tree[s.heap[j]].fc.Freq) and + (s.depth[s.heap[j+1]] <= s.depth[s.heap[j]])) ) then + begin + Inc(j); + end; + { Exit if v is smaller than both sons } + if {(smaller(tree, v, s.heap[j], s.depth))} + ( (tree[v].fc.Freq < tree[s.heap[j]].fc.Freq) or + ((tree[v].fc.Freq = tree[s.heap[j]].fc.Freq) and + (s.depth[v] <= s.depth[s.heap[j]])) ) then + break; + { Exchange v with the smallest son } + s.heap[k] := s.heap[j]; + k := j; + + { And continue down the tree, setting j to the left son of k } + j := j shl 1; + end; + s.heap[k] := v; +end; + +{ =========================================================================== + Compute the optimal bit lengths for a tree and update the total bit length + for the current block. + IN assertion: the fields freq and dad are set, heap[heap_max] and + above are the tree nodes sorted by increasing frequency. + OUT assertions: the field len is set to the optimal bit length, the + array bl_count contains the frequencies for each bit length. + The length opt_len is updated; static_len is also updated if stree is + not null. } + +{local} +procedure gen_bitlen(var s : deflate_state; + var desc : tree_desc); { the tree descriptor } +var + tree : tree_ptr; + max_code : int; + stree : tree_ptr; {const} + extra : pzIntfArray; {const} + base : int; + max_length : int; + h : int; { heap index } + n, m : int; { iterate over the tree elements } + bits : int; { bit length } + xbits : int; { extra bits } + f : ush; { frequency } + overflow : int; { number of elements with bit length too large } +begin + tree := desc.dyn_tree; + max_code := desc.max_code; + stree := desc.stat_desc^.static_tree; + extra := desc.stat_desc^.extra_bits; + base := desc.stat_desc^.extra_base; + max_length := desc.stat_desc^.max_length; + overflow := 0; + + for bits := 0 to MAX_BITS do + s.bl_count[bits] := 0; + + { In a first pass, compute the optimal bit lengths (which may + overflow in the case of the bit length tree). } + + tree^[s.heap[s.heap_max]].dl.Len := 0; { root of the heap } + + for h := s.heap_max+1 to HEAP_SIZE-1 do + begin + n := s.heap[h]; + bits := tree^[tree^[n].dl.Dad].dl.Len + 1; + if (bits > max_length) then + begin + bits := max_length; + Inc(overflow); + end; + tree^[n].dl.Len := ush(bits); + { We overwrite tree[n].dl.Dad which is no longer needed } + + if (n > max_code) then + continue; { not a leaf node } + + Inc(s.bl_count[bits]); + xbits := 0; + if (n >= base) then + xbits := extra^[n-base]; + f := tree^[n].fc.Freq; + Inc(s.opt_len, ulg(f) * (bits + xbits)); + if (stree <> NIL) then + Inc(s.static_len, ulg(f) * (stree^[n].dl.Len + xbits)); + end; + if (overflow = 0) then + exit; + {$ifdef DEBUG} + Tracev(^M'bit length overflow'); + {$endif} + { This happens for example on obj2 and pic of the Calgary corpus } + + { Find the first bit length which could increase: } + repeat + bits := max_length-1; + while (s.bl_count[bits] = 0) do + Dec(bits); + Dec(s.bl_count[bits]); { move one leaf down the tree } + Inc(s.bl_count[bits+1], 2); { move one overflow item as its brother } + Dec(s.bl_count[max_length]); + { The brother of the overflow item also moves one step up, + but this does not affect bl_count[max_length] } + + Dec(overflow, 2); + until (overflow <= 0); + + { Now recompute all bit lengths, scanning in increasing frequency. + h is still equal to HEAP_SIZE. (It is simpler to reconstruct all + lengths instead of fixing only the wrong ones. This idea is taken + from 'ar' written by Haruhiko Okumura.) } + h := HEAP_SIZE; { Delphi3: compiler warning w/o this } + for bits := max_length downto 1 do + begin + n := s.bl_count[bits]; + while (n <> 0) do + begin + Dec(h); + m := s.heap[h]; + if (m > max_code) then + continue; + if (tree^[m].dl.Len <> unsigned(bits)) then + begin + {$ifdef DEBUG} + Trace('code '+IntToStr(m)+' bits '+IntToStr(tree^[m].dl.Len) + +'.'+IntToStr(bits)); + {$ENDIF} + Inc(s.opt_len, (long(bits) - long(tree^[m].dl.Len)) + * long(tree^[m].fc.Freq) ); + tree^[m].dl.Len := ush(bits); + end; + Dec(n); + end; + end; +end; + +{ =========================================================================== + Construct one Huffman tree and assigns the code bit strings and lengths. + Update the total bit length for the current block. + IN assertion: the field freq is set for all tree elements. + OUT assertions: the fields len and code are set to the optimal bit length + and corresponding code. The length opt_len is updated; static_len is + also updated if stree is not null. The field max_code is set. } + +{local} +procedure build_tree(var s : deflate_state; + var desc : tree_desc); { the tree descriptor } + +var + tree : tree_ptr; + stree : tree_ptr; {const} + elems : int; + n, m : int; { iterate over heap elements } + max_code : int; { largest code with non zero frequency } + node : int; { new node being created } +begin + tree := desc.dyn_tree; + stree := desc.stat_desc^.static_tree; + elems := desc.stat_desc^.elems; + max_code := -1; + + { Construct the initial heap, with least frequent element in + heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1]. + heap[0] is not used. } + s.heap_len := 0; + s.heap_max := HEAP_SIZE; + + for n := 0 to elems-1 do + begin + if (tree^[n].fc.Freq <> 0) then + begin + max_code := n; + Inc(s.heap_len); + s.heap[s.heap_len] := n; + s.depth[n] := 0; + end + else + begin + tree^[n].dl.Len := 0; + end; + end; + + { The pkzip format requires that at least one distance code exists, + and that at least one bit should be sent even if there is only one + possible code. So to avoid special checks later on we force at least + two codes of non zero frequency. } + + while (s.heap_len < 2) do + begin + Inc(s.heap_len); + if (max_code < 2) then + begin + Inc(max_code); + s.heap[s.heap_len] := max_code; + node := max_code; + end + else + begin + s.heap[s.heap_len] := 0; + node := 0; + end; + tree^[node].fc.Freq := 1; + s.depth[node] := 0; + Dec(s.opt_len); + if (stree <> NIL) then + Dec(s.static_len, stree^[node].dl.Len); + { node is 0 or 1 so it does not have extra bits } + end; + desc.max_code := max_code; + + { The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree, + establish sub-heaps of increasing lengths: } + + for n := s.heap_len div 2 downto 1 do + pqdownheap(s, tree^, n); + + { Construct the Huffman tree by repeatedly combining the least two + frequent nodes. } + + node := elems; { next internal node of the tree } + repeat + {pqremove(s, tree, n);} { n := node of least frequency } + n := s.heap[SMALLEST]; + s.heap[SMALLEST] := s.heap[s.heap_len]; + Dec(s.heap_len); + pqdownheap(s, tree^, SMALLEST); + + m := s.heap[SMALLEST]; { m := node of next least frequency } + + Dec(s.heap_max); + s.heap[s.heap_max] := n; { keep the nodes sorted by frequency } + Dec(s.heap_max); + s.heap[s.heap_max] := m; + + { Create a new node father of n and m } + tree^[node].fc.Freq := tree^[n].fc.Freq + tree^[m].fc.Freq; + { maximum } + if (s.depth[n] >= s.depth[m]) then + s.depth[node] := uch (s.depth[n] + 1) + else + s.depth[node] := uch (s.depth[m] + 1); + + tree^[m].dl.Dad := ush(node); + tree^[n].dl.Dad := ush(node); +{$ifdef DUMP_BL_TREE} + if (tree = tree_ptr(@s.bl_tree)) then + begin + WriteLn(#13'node ',node,'(',tree^[node].fc.Freq,') sons ',n, + '(',tree^[n].fc.Freq,') ', m, '(',tree^[m].fc.Freq,')'); + end; +{$endif} + { and insert the new node in the heap } + s.heap[SMALLEST] := node; + Inc(node); + pqdownheap(s, tree^, SMALLEST); + + until (s.heap_len < 2); + + Dec(s.heap_max); + s.heap[s.heap_max] := s.heap[SMALLEST]; + + { At this point, the fields freq and dad are set. We can now + generate the bit lengths. } + + gen_bitlen(s, desc); + + { The field len is now set, we can generate the bit codes } + gen_codes (tree, max_code, s.bl_count); +end; + +{ =========================================================================== + Scan a literal or distance tree to determine the frequencies of the codes + in the bit length tree. } + +{local} +procedure scan_tree(var s : deflate_state; + var tree : array of ct_data; { the tree to be scanned } + max_code : int); { and its largest code of non zero frequency } +var + n : int; { iterates over all tree elements } + prevlen : int; { last emitted length } + curlen : int; { length of current code } + nextlen : int; { length of next code } + count : int; { repeat count of the current code } + max_count : int; { max repeat count } + min_count : int; { min repeat count } +begin + prevlen := -1; + nextlen := tree[0].dl.Len; + count := 0; + max_count := 7; + min_count := 4; + + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end; + tree[max_code+1].dl.Len := ush($ffff); { guard } + + for n := 0 to max_code do + begin + curlen := nextlen; + nextlen := tree[n+1].dl.Len; + Inc(count); + if (count < max_count) and (curlen = nextlen) then + continue + else + if (count < min_count) then + Inc(s.bl_tree[curlen].fc.Freq, count) + else + if (curlen <> 0) then + begin + if (curlen <> prevlen) then + Inc(s.bl_tree[curlen].fc.Freq); + Inc(s.bl_tree[REP_3_6].fc.Freq); + end + else + if (count <= 10) then + Inc(s.bl_tree[REPZ_3_10].fc.Freq) + else + Inc(s.bl_tree[REPZ_11_138].fc.Freq); + + count := 0; + prevlen := curlen; + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end + else + if (curlen = nextlen) then + begin + max_count := 6; + min_count := 3; + end + else + begin + max_count := 7; + min_count := 4; + end; + end; +end; + +{ =========================================================================== + Send a literal or distance tree in compressed form, using the codes in + bl_tree. } + +{local} +procedure send_tree(var s : deflate_state; + var tree : array of ct_data; { the tree to be scanned } + max_code : int); { and its largest code of non zero frequency } + +var + n : int; { iterates over all tree elements } + prevlen : int; { last emitted length } + curlen : int; { length of current code } + nextlen : int; { length of next code } + count : int; { repeat count of the current code } + max_count : int; { max repeat count } + min_count : int; { min repeat count } +begin + prevlen := -1; + nextlen := tree[0].dl.Len; + count := 0; + max_count := 7; + min_count := 4; + + { tree[max_code+1].dl.Len := -1; } { guard already set } + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end; + + for n := 0 to max_code do + begin + curlen := nextlen; + nextlen := tree[n+1].dl.Len; + Inc(count); + if (count < max_count) and (curlen = nextlen) then + continue + else + if (count < min_count) then + begin + repeat + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(curlen)); + {$ENDIF} + send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len); + Dec(count); + until (count = 0); + end + else + if (curlen <> 0) then + begin + if (curlen <> prevlen) then + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(curlen)); + {$ENDIF} + send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len); + Dec(count); + end; + {$IFDEF DEBUG} + Assert((count >= 3) and (count <= 6), ' 3_6?'); + {$ENDIF} + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REP_3_6)); + {$ENDIF} + send_bits(s, s.bl_tree[REP_3_6].fc.Code, s.bl_tree[REP_3_6].dl.Len); + send_bits(s, count-3, 2); + end + else + if (count <= 10) then + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REPZ_3_10)); + {$ENDIF} + send_bits(s, s.bl_tree[REPZ_3_10].fc.Code, s.bl_tree[REPZ_3_10].dl.Len); + send_bits(s, count-3, 3); + end + else + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REPZ_11_138)); + {$ENDIF} + send_bits(s, s.bl_tree[REPZ_11_138].fc.Code, s.bl_tree[REPZ_11_138].dl.Len); + send_bits(s, count-11, 7); + end; + count := 0; + prevlen := curlen; + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end + else + if (curlen = nextlen) then + begin + max_count := 6; + min_count := 3; + end + else + begin + max_count := 7; + min_count := 4; + end; + end; +end; + +{ =========================================================================== + Construct the Huffman tree for the bit lengths and return the index in + bl_order of the last bit length code to send. } + +{local} +function build_bl_tree(var s : deflate_state) : int; +var + max_blindex : int; { index of last bit length code of non zero freq } +begin + { Determine the bit length frequencies for literal and distance trees } + scan_tree(s, s.dyn_ltree, s.l_desc.max_code); + scan_tree(s, s.dyn_dtree, s.d_desc.max_code); + + { Build the bit length tree: } + build_tree(s, s.bl_desc); + { opt_len now includes the length of the tree representations, except + the lengths of the bit lengths codes and the 5+5+4 bits for the counts. } + + { Determine the number of bit length codes to send. The pkzip format + requires that at least 4 bit length codes be sent. (appnote.txt says + 3 but the actual value used is 4.) } + + for max_blindex := BL_CODES-1 downto 3 do + begin + if (s.bl_tree[bl_order[max_blindex]].dl.Len <> 0) then + break; + end; + { Update opt_len to include the bit length tree and counts } + Inc(s.opt_len, 3*(max_blindex+1) + 5+5+4); + {$ifdef DEBUG} + Tracev(^M'dyn trees: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + + build_bl_tree := max_blindex; +end; + +{ =========================================================================== + Send the header for a block using dynamic Huffman trees: the counts, the + lengths of the bit length codes, the literal tree and the distance tree. + IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. } + +{local} +procedure send_all_trees(var s : deflate_state; + lcodes : int; + dcodes : int; + blcodes : int); { number of codes for each tree } +var + rank : int; { index in bl_order } +begin + {$IFDEF DEBUG} + Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4), + 'not enough codes'); + Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES) + and (blcodes <= BL_CODES), 'too many codes'); + Tracev(^M'bl counts: '); + {$ENDIF} + send_bits(s, lcodes-257, 5); { not +255 as stated in appnote.txt } + send_bits(s, dcodes-1, 5); + send_bits(s, blcodes-4, 4); { not -3 as stated in appnote.txt } + for rank := 0 to blcodes-1 do + begin + {$ifdef DEBUG} + Tracev(^M'bl code '+IntToStr(bl_order[rank])); + {$ENDIF} + send_bits(s, s.bl_tree[bl_order[rank]].dl.Len, 3); + end; + {$ifdef DEBUG} + Tracev(^M'bl tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} + + send_tree(s, s.dyn_ltree, lcodes-1); { literal tree } + {$ifdef DEBUG} + Tracev(^M'lit tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} + + send_tree(s, s.dyn_dtree, dcodes-1); { distance tree } + {$ifdef DEBUG} + Tracev(^M'dist tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} +end; + +{ =========================================================================== + Flush the bit buffer and align the output on a byte boundary } + +{local} +procedure bi_windup(var s : deflate_state); +begin + if (s.bi_valid > 8) then + begin + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + end + else + if (s.bi_valid > 0) then + begin + {put_byte(s, (Byte)s^.bi_buf);} + s.pending_buf^[s.pending] := Byte(s.bi_buf); + Inc(s.pending); + end; + s.bi_buf := 0; + s.bi_valid := 0; +{$ifdef DEBUG} + s.bits_sent := (s.bits_sent+7) and (not 7); +{$endif} +end; + +{ =========================================================================== + Copy a stored block, storing first the length and its + one's complement if requested. } + +{local} +procedure copy_block(var s : deflate_state; + buf : pcharf; { the input data } + len : unsigned; { its length } + header : boolean); { true if block header must be written } +begin + bi_windup(s); { align on byte boundary } + s.last_eob_len := 8; { enough lookahead for inflate } + + if (header) then + begin + {put_short(s, (ush)len);} + s.pending_buf^[s.pending] := uch(ush(len) and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(len) shr 8);; + Inc(s.pending); + {put_short(s, (ush)~len);} + s.pending_buf^[s.pending] := uch(ush(not len) and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(not len) shr 8);; + Inc(s.pending); + +{$ifdef DEBUG} + Inc(s.bits_sent, 2*16); +{$endif} + end; +{$ifdef DEBUG} + Inc(s.bits_sent, ulg(len shl 3)); +{$endif} + while (len <> 0) do + begin + Dec(len); + {put_byte(s, *buf++);} + s.pending_buf^[s.pending] := buf^; + Inc(buf); + Inc(s.pending); + end; +end; + + +{ =========================================================================== + Send a stored block } + +procedure _tr_stored_block(var s : deflate_state; + buf : pcharf; { input block } + stored_len : ulg; { length of input block } + eof : boolean); { true if this is the last block for a file } + +begin + send_bits(s, (STORED_BLOCK shl 1)+ord(eof), 3); { send block type } + s.compressed_len := (s.compressed_len + 3 + 7) and ulg(not Long(7)); + Inc(s.compressed_len, (stored_len + 4) shl 3); + + copy_block(s, buf, unsigned(stored_len), TRUE); { with header } +end; + +{ =========================================================================== + Flush the bit buffer, keeping at most 7 bits in it. } + +{local} +procedure bi_flush(var s : deflate_state); +begin + if (s.bi_valid = 16) then + begin + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s.bi_buf := 0; + s.bi_valid := 0; + end + else + if (s.bi_valid >= 8) then + begin + {put_byte(s, (Byte)s^.bi_buf);} + s.pending_buf^[s.pending] := Byte(s.bi_buf); + Inc(s.pending); + + s.bi_buf := s.bi_buf shr 8; + Dec(s.bi_valid, 8); + end; +end; + + +{ =========================================================================== + Send one empty static block to give enough lookahead for inflate. + This takes 10 bits, of which 7 may remain in the bit buffer. + The current inflate code requires 9 bits of lookahead. If the + last two codes for the previous block (real code plus EOB) were coded + on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode + the last real code. In this case we send two empty static blocks instead + of one. (There are no problems if the previous block is stored or fixed.) + To simplify the code, we assume the worst case of last real code encoded + on one bit only. } + +procedure _tr_align(var s : deflate_state); +begin + send_bits(s, STATIC_TREES shl 1, 3); + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len); + Inc(s.compressed_len, Long(10)); { 3 for block type, 7 for EOB } + bi_flush(s); + { Of the 10 bits for the empty block, we have already sent + (10 - bi_valid) bits. The lookahead for the last real code (before + the EOB of the previous block) was thus at least one plus the length + of the EOB plus what we have just sent of the empty static block. } + if (1 + s.last_eob_len + 10 - s.bi_valid < 9) then + begin + send_bits(s, STATIC_TREES shl 1, 3); + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len); + Inc(s.compressed_len, Long(10)); + bi_flush(s); + end; + s.last_eob_len := 7; +end; + +{ =========================================================================== + Set the data type to ASCII or BINARY, using a crude approximation: + binary if more than 20% of the bytes are <= 6 or >= 128, ascii otherwise. + IN assertion: the fields freq of dyn_ltree are set and the total of all + frequencies does not exceed 64K (to fit in an int on 16 bit machines). } + +{local} +procedure set_data_type(var s : deflate_state); +var + n : int; + ascii_freq : unsigned; + bin_freq : unsigned; +begin + n := 0; + ascii_freq := 0; + bin_freq := 0; + + while (n < 7) do + begin + Inc(bin_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + while (n < 128) do + begin + Inc(ascii_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + while (n < LITERALS) do + begin + Inc(bin_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + if (bin_freq > (ascii_freq shr 2)) then + s.data_type := Byte(Z_BINARY) + else + s.data_type := Byte(Z_ASCII); +end; + +{ =========================================================================== + Send the block data compressed using the given Huffman trees } + +{local} +procedure compress_block(var s : deflate_state; + var ltree : array of ct_data; { literal tree } + var dtree : array of ct_data); { distance tree } +var + dist : unsigned; { distance of matched string } + lc : int; { match length or unmatched char (if dist == 0) } + lx : unsigned; { running index in l_buf } + code : unsigned; { the code to send } + extra : int; { number of extra bits to send } +begin + lx := 0; + if (s.last_lit <> 0) then + repeat + dist := s.d_buf^[lx]; + lc := s.l_buf^[lx]; + Inc(lx); + if (dist = 0) then + begin + { send a literal byte } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(lc)); + Tracecv((lc > 31) and (lc < 128), ' '+char(lc)+' '); + {$ENDIF} + send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len); + end + else + begin + { Here, lc is the match length - MIN_MATCH } + code := _length_code[lc]; + { send the length code } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(code+LITERALS+1)); + {$ENDIF} + send_bits(s, ltree[code+LITERALS+1].fc.Code, ltree[code+LITERALS+1].dl.Len); + extra := extra_lbits[code]; + if (extra <> 0) then + begin + Dec(lc, base_length[code]); + send_bits(s, lc, extra); { send the extra length bits } + end; + Dec(dist); { dist is now the match distance - 1 } + {code := d_code(dist);} + if (dist < 256) then + code := _dist_code[dist] + else + code := _dist_code[256+(dist shr 7)]; + + {$IFDEF DEBUG} + Assert (code < D_CODES, 'bad d_code'); + {$ENDIF} + + { send the distance code } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(code)); + {$ENDIF} + send_bits(s, dtree[code].fc.Code, dtree[code].dl.Len); + extra := extra_dbits[code]; + if (extra <> 0) then + begin + Dec(dist, base_dist[code]); + send_bits(s, dist, extra); { send the extra distance bits } + end; + end; { literal or match pair ? } + + { Check that the overlay between pending_buf and d_buf+l_buf is ok: } + {$IFDEF DEBUG} + Assert(s.pending < s.lit_bufsize + 2*lx, 'pendingBuf overflow'); + {$ENDIF} + until (lx >= s.last_lit); + + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, ltree[END_BLOCK].fc.Code, ltree[END_BLOCK].dl.Len); + s.last_eob_len := ltree[END_BLOCK].dl.Len; +end; + + +{ =========================================================================== + Determine the best encoding for the current block: dynamic trees, static + trees or store, and output the encoded block to the zip file. This function + returns the total compressed length for the file so far. } + +function _tr_flush_block (var s : deflate_state; + buf : pcharf; { input block, or NULL if too old } + stored_len : ulg; { length of input block } + eof : boolean) : ulg; { true if this is the last block for a file } +var + opt_lenb, static_lenb : ulg; { opt_len and static_len in bytes } + max_blindex : int; { index of last bit length code of non zero freq } +begin + max_blindex := 0; + + { Build the Huffman trees unless a stored block is forced } + if (s.level > 0) then + begin + { Check if the file is ascii or binary } + if (s.data_type = Z_UNKNOWN) then + set_data_type(s); + + { Construct the literal and distance trees } + build_tree(s, s.l_desc); + {$ifdef DEBUG} + Tracev(^M'lit data: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + + build_tree(s, s.d_desc); + {$ifdef DEBUG} + Tracev(^M'dist data: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + { At this point, opt_len and static_len are the total bit lengths of + the compressed block data, excluding the tree representations. } + + { Build the bit length tree for the above two trees, and get the index + in bl_order of the last bit length code to send. } + max_blindex := build_bl_tree(s); + + { Determine the best encoding. Compute first the block length in bytes} + opt_lenb := (s.opt_len+3+7) shr 3; + static_lenb := (s.static_len+3+7) shr 3; + + {$ifdef DEBUG} + Tracev(^M'opt %lu(%lu) stat %lu(%lu) stored %lu lit %u '+ + '{opt_lenb, s.opt_len, static_lenb, s.static_len, stored_len,'+ + 's.last_lit}'); + {$ENDIF} + + if (static_lenb <= opt_lenb) then + opt_lenb := static_lenb; + + end + else + begin + {$IFDEF DEBUG} + Assert(buf <> pcharf(NIL), 'lost buf'); + {$ENDIF} + static_lenb := stored_len + 5; + opt_lenb := static_lenb; { force a stored block } + end; + + { If compression failed and this is the first and last block, + and if the .zip file can be seeked (to rewrite the local header), + the whole file is transformed into a stored file: } + +{$ifdef STORED_FILE_OK} +{$ifdef FORCE_STORED_FILE} + if eof and (s.compressed_len = Long(0)) then + begin { force stored file } +{$else} + if (stored_len <= opt_lenb) and eof and (s.compressed_len=Long(0)) + and seekable()) do + begin +{$endif} + { Since LIT_BUFSIZE <= 2*WSIZE, the input data must be there: } + if (buf = pcharf(0)) then + error ('block vanished'); + + copy_block(buf, unsigned(stored_len), 0); { without header } + s.compressed_len := stored_len shl 3; + s.method := STORED; + end + else +{$endif} { STORED_FILE_OK } + +{$ifdef FORCE_STORED} + if (buf <> pchar(0)) then + begin { force stored block } +{$else} + if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then + begin + { 4: two words for the lengths } +{$endif} + { The test buf <> NULL is only necessary if LIT_BUFSIZE > WSIZE. + Otherwise we can't have processed more than WSIZE input bytes since + the last block flush, because compression would have been + successful. If LIT_BUFSIZE <= WSIZE, it is never too late to + transform a block into a stored block. } + + _tr_stored_block(s, buf, stored_len, eof); + +{$ifdef FORCE_STATIC} + end + else + if (static_lenb >= 0) then + begin { force static trees } +{$else} + end + else + if (static_lenb = opt_lenb) then + begin +{$endif} + send_bits(s, (STATIC_TREES shl 1)+ord(eof), 3); + compress_block(s, static_ltree, static_dtree); + Inc(s.compressed_len, 3 + s.static_len); + end + else + begin + send_bits(s, (DYN_TREES shl 1)+ord(eof), 3); + send_all_trees(s, s.l_desc.max_code+1, s.d_desc.max_code+1, + max_blindex+1); + compress_block(s, s.dyn_ltree, s.dyn_dtree); + Inc(s.compressed_len, 3 + s.opt_len); + end; + {$ifdef DEBUG} + Assert (s.compressed_len = s.bits_sent, 'bad compressed size'); + {$ENDIF} + init_block(s); + + if (eof) then + begin + bi_windup(s); + Inc(s.compressed_len, 7); { align on byte boundary } + end; + {$ifdef DEBUG} + Tracev(#13'comprlen %lu(%lu) {s.compressed_len shr 3,'+ + 's.compressed_len-7*ord(eof)}'); + {$ENDIF} + + _tr_flush_block := s.compressed_len shr 3; +end; + + +{ =========================================================================== + Save the match info and tally the frequency counts. Return true if + the current block must be flushed. } + +function _tr_tally (var s : deflate_state; + dist : unsigned; { distance of matched string } + lc : unsigned) : boolean; { match length-MIN_MATCH or unmatched char (if dist=0) } +var + {$IFDEF DEBUG} + MAX_DIST : ush; + {$ENDIF} + code : ush; +{$ifdef TRUNCATE_BLOCK} +var + out_length : ulg; + in_length : ulg; + dcode : int; +{$endif} +begin + s.d_buf^[s.last_lit] := ush(dist); + s.l_buf^[s.last_lit] := uch(lc); + Inc(s.last_lit); + if (dist = 0) then + begin + { lc is the unmatched char } + Inc(s.dyn_ltree[lc].fc.Freq); + end + else + begin + Inc(s.matches); + { Here, lc is the match length - MIN_MATCH } + Dec(dist); { dist := match distance - 1 } + + {macro d_code(dist)} + if (dist) < 256 then + code := _dist_code[dist] + else + code := _dist_code[256+(dist shr 7)]; + {$IFDEF DEBUG} +{macro MAX_DIST(s) <=> ((s)^.w_size-MIN_LOOKAHEAD) + In order to simplify the code, particularly on 16 bit machines, match + distances are limited to MAX_DIST instead of WSIZE. } + MAX_DIST := ush(s.w_size-MIN_LOOKAHEAD); + Assert((dist < ush(MAX_DIST)) and + (ush(lc) <= ush(MAX_MATCH-MIN_MATCH)) and + (ush(code) < ush(D_CODES)), '_tr_tally: bad match'); + {$ENDIF} + Inc(s.dyn_ltree[_length_code[lc]+LITERALS+1].fc.Freq); + {s.dyn_dtree[d_code(dist)].Freq++;} + Inc(s.dyn_dtree[code].fc.Freq); + end; + +{$ifdef TRUNCATE_BLOCK} + { Try to guess if it is profitable to stop the current block here } + if (s.last_lit and $1fff = 0) and (s.level > 2) then + begin + { Compute an upper bound for the compressed length } + out_length := ulg(s.last_lit)*Long(8); + in_length := ulg(long(s.strstart) - s.block_start); + for dcode := 0 to D_CODES-1 do + begin + Inc(out_length, ulg(s.dyn_dtree[dcode].fc.Freq * + (Long(5)+extra_dbits[dcode])) ); + end; + out_length := out_length shr 3; + {$ifdef DEBUG} + Tracev(^M'last_lit %u, in %ld, out ~%ld(%ld%%) '); + { s.last_lit, in_length, out_length, + Long(100) - out_length*Long(100) div in_length)); } + {$ENDIF} + if (s.matches < s.last_lit div 2) and (out_length < in_length div 2) then + begin + _tr_tally := TRUE; + exit; + end; + end; +{$endif} + _tr_tally := (s.last_lit = s.lit_bufsize-1); + { We avoid equality with lit_bufsize because of wraparound at 64K + on 16 bit machines and because stored blocks are restricted to + 64K-1 bytes. } +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/UnTar.pas b/niftiview7/gzio/UnTar.pas new file mode 100755 index 0000000..10af24e --- /dev/null +++ b/niftiview7/gzio/UnTar.pas @@ -0,0 +1,333 @@ +unit UnTar; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + DsgnIntf, tarfile; + +CONST BUFSIZE = 512 * 128; // 512 = SECSIZE in unit tarfile + +type + TZeroHundred = 0..100; + TOverwriteMode = ( omSkip, omRename, omReplace ); + TNextFile = record + name : string; + size : longint; + timestamp : TDateTime + end; + + TAboutProperty = class(TPropertyEditor) + public + procedure Edit; override; + function GetAttributes: TPropertyAttributes; override; + function GetValue: string; override; + end; + + TUnTar = class(TComponent) + private + { Private declarations } + FAbout : TAboutProperty; + FOnNextFile : TNotifyEvent; + FNextFile : TNextFile; + FCreateEmptyDir: boolean; + FOnExtractOverwrite : TNotifyEvent; + FOnProgress : TNotifyEvent; + FProgress : integer; + FProgressStep : TZeroHundred; + FOverwriteMode : TOverwriteMode; + FOverwriteThisTime : TOverwriteMode; + FOverwriteFilename : String; + FFileSource : string; + FUnpackPath : string; + FNewFileName : string; + procedure DoProgress( tarfile : TTarFile); + procedure CreateNextFile( tarfile: TTarfile); + function TranslateDate( dt : TDateTime): longint; + protected + { Protected declarations } + procedure DoOnNextFile; virtual; + procedure DoOnExtractOverwrite; virtual; + procedure DoOnProgress; virtual; + public + { Public declarations } + constructor Create( AOwner: TComponent); override; +// destructor Free; + procedure UnTar; + procedure UnTarSelected( list: TStringList); + procedure GetInfo; + property Progress : integer + read FProgress; + property NextFile : TNextfile + read FNextFile; + property OverwriteThisTime : TOverwriteMode + read FOverwriteThisTime write FOverwriteThisTime; + property OverwriteFilename : String + read FOverwriteFilename write FOverwriteFilename; + published + { Published declarations } + property About: TAboutProperty + read FAbout write FAbout; + property FileSource : String + read FFileSource write FFileSource; + property UnpackPath : String + read FUnpackPath write FUnpackPath; + property ProgressStep : TZeroHundred + read FProgressStep write FProgressStep; + property OnProgress : TNotifyEvent + read FOnProgress write FOnProgress; + Property OverwriteMode : TOverwriteMode + read FOverwriteMode write FOverwriteMode; + Property CreateEmptyDir: boolean + read FCreateEmptyDir write FCreateEmptyDir; + Property OnExtractOverwrite : TNotifyEvent + read FOnExtractOverwrite write FOnExtractOverwrite; + Property OnNextFile : TNotifyEvent + read FOnNextFile write FOnNextFile; + + end; + +procedure Register; + +implementation + +uses utils, filectrl; + +procedure TAboutProperty.Edit; +var utils : TUtils; +begin + ShowMessage(utils.CreateAboutMsg('DelphiUnTar')) +end; + +function TAboutProperty.GetAttributes: TPropertyAttributes; +begin + Result := [paMultiSelect, paDialog, paReadOnly]; +end; + +function TAboutProperty.GetValue: string; +begin + Result := 'DelphiUnTar'; +end; + +constructor TUnTar.Create( AOwner: TComponent); +begin + inherited Create( AOwner); + FFileSource := ''; + FUnpackPath := ''; + FProgressStep := 0; + FCreateEmptyDir := false; + FOverwriteMode := omRename +end; + +procedure TUnTar.DoOnNextFile; +begin + if Assigned (FOnNextFile) then + FOnNextFile (self) +end; + +procedure TUnTar.DoOnExtractOverwrite; +begin + if Assigned (FOnExtractOverwrite) then + FOnExtractOverwrite (self) +end; + +procedure TUnTar.DoOnProgress; +begin + if Assigned (FOnProgress) then + FOnProgress (self) +end; + +procedure TUnTar.DoProgress( tarfile : TTarFile); +var dummy : integer; +begin + if FProgressStep > 0 then + begin + dummy := tarfile.Progress; + if (dummy >= FProgress + FProgressStep) or + (dummy = 100) then + begin + FProgress := dummy - (dummy mod FProgressStep); + if dummy = 100 then FProgress := dummy; + DoOnProgress + end + end +end; + +function TUnTar.TranslateDate( dt : TDateTime) : longint; +begin + Result := DateTimeToFileDate( + EncodeDate( dt.year, dt.month, dt.day) + + EncodeTime( dt.hour, dt.min, dt.sec, 0)) +end; + +procedure TUnTar.CreateNextFile( tarfile: TTarfile); +type TBuffer = Array [0..Pred(BUFSIZE)] Of byte; +var outfiledir: string; + outf: TFileStream; + iread: longint; + buffer: TBuffer; +begin + outfileDir := ExtractFileDir(FNextFile.name); + // Check if sub-dir exists, if not create + if not(DirectoryExists(outfileDir)) and (outfileDir<>'') then + begin + outfileDir := ExpandFileName(outfileDir); + ForceDirectories(outfileDir); + end; + + if outfileDir <> '' then outfileDir := outfileDir + '\'; + FNewFilename := outfileDir+ExtractFileName(FNextFile.name); + + FOverwriteThisTime := omRename; + while (FileExists( FNewFilename)) and + (FOverwriteMode = omRename)and + (FOverwriteThisTime = omRename) do + begin + FOverwriteFilename := ''; + // Raise event to ask what should be done + DoOnExtractOverwrite; + if (FOverwriteThisTime = omRename) and + (FOverwriteFilename <> '') then + FNewFilename := FOverwriteFilename + end; + + if (not FileExists( FNewFilename)) or + (FOverwriteMode = omReplace) or + (FOverwriteThisTime = omReplace) then + begin + outf := TFileStream.Create(FNewFilename, fmCreate or fmShareDenyWrite); + + while FNextFile.size > 0 do + begin + iread := tarfile.ReadFile( buffer, BUFSIZE); + outf.Write( buffer, iread); + FNextFile.size := FNextFile.size - iread; + DoProgress(tarfile) + end; + FileSetDate(outf.Handle, translateDate(FNextFile.timestamp)); + outf.Free + end else + begin + tarfile.SkipFile; // We do not need the file + DoProgress(tarfile) + end +end; + +procedure TUnTar.UnTar; +var oldDir, outfileDir : string; + tarfile : TTarFile; +begin + FProgress := 0; + oldDir := getCurrentDir; + // check if destination-path exists + if FUnpackPath <> '' then + begin + if not(DirectoryExists(FUnpackPath)) then + ForceDirectories(FUnpackPath); + setCurrentDir(FUnpackPath); + end; + + tarfile := TTarFile.Create( FFileSource); + DoProgress(tarfile); + while not( tarfile.EOF) do + begin + FNextFile.name := tarfile.GetNextFilename; + DoProgress( tarfile); + outfileDir := ExtractFileDir(FNextFile.name); + + if FCreateEmptyDir then + // Check if sub-dir exists, if not create + if not(DirectoryExists(outfileDir)) and (outfileDir<>'') then + begin + outfileDir := ExpandFileName(outfileDir); + ForceDirectories(outfileDir); + end; + + FNextFile.size := tarfile.GetNextSize; + if FNextFile.size > 0 then + begin + FNextFile.timestamp := tarfile.GetNextDate; + DoOnNextFile; // raise event that we start with new file + // Info is now read and in FNextFile + // Create the file + CreateNextFile(tarfile) + end + end; + DoProgress( tarfile); + tarfile.Free; + + setCurrentDir(oldDir) +end; + +procedure TUnTar.UnTarSelected( list: TStringList); +var oldDir, outfileDir : string; + tarfile : TTarFile; +begin + FProgress := 0; + oldDir := getCurrentDir; + // check if destination-path exists + if FUnpackPath <> '' then + begin + if not(DirectoryExists(FUnpackPath)) then + ForceDirectories(FUnpackPath); + setCurrentDir(FUnpackPath); + end; + + tarfile := TTarFile.Create( FFileSource); + DoProgress(tarfile); + while not( tarfile.EOF) do + begin + FNextFile.name := tarfile.GetNextFilename; + DoProgress( tarfile); + outfileDir := ExtractFileDir(FNextFile.name); + + FNextFile.size := tarfile.GetNextSize; + if FNextFile.size > 0 then + begin + FNextFile.timestamp := tarfile.GetNextDate; + if list.IndexOf(FNextFile.Name) > -1 then + begin + DoOnNextFile; // raise event that we start with new file + // Info is now read and in FNextFile + // Create the file + CreateNextFile(tarfile) + end else + tarFile.SkipFile + end + end; + DoProgress( tarfile); + tarfile.Free; + + setCurrentDir(oldDir) +end; + +procedure TUnTar.GetInfo; +var tarfile : TTarFile; +begin + FProgress := 0; + tarfile := TTarFile.Create( FFileSource); + DoProgress( tarfile); + while not( tarfile.EOF) do + begin + FNextFile.name := tarfile.GetNextFilename; + FNextFile.size := tarfile.GetNextSize; + DoProgress( tarfile); + if FNextFile.size > 0 then + begin + FNextFile.timestamp := tarfile.GetNextDate; + tarfile.SkipFile; + DoOnNextFile; + DoProgress( tarfile) + end + end; + DoProgress( tarfile); + tarfile.Free; +end; + +procedure Register; +begin + RegisterComponents('Samples', [TUnTar]); + RegisterPropertyEditor(TypeInfo(TAboutProperty), TUnTar, 'ABOUT', TAboutProperty); +end; + +end. diff --git a/niftiview7/gzio/Unzip.pas b/niftiview7/gzio/Unzip.pas new file mode 100755 index 0000000..8a5365a --- /dev/null +++ b/niftiview7/gzio/Unzip.pas @@ -0,0 +1,1631 @@ +Unit Unzip; +{ ----------------------------------------------------------------- } +{ unzip.c -- IO on .zip files using zlib + Version 0.15 beta, Mar 19th, 1998, + unzip.h -- IO for uncompress .zip files using zlib + Version 0.15 beta, Mar 19th, 1998, + + Copyright (C) 1998 Gilles Vollant <info@winimage.com> + http://www.winimage.com/zLibDll/zip.htm + + This unzip package allow extract file from .ZIP file, compatible + with PKZip 2.04g, WinZip, InfoZip tools and compatible. + Encryption and multi volume ZipFile (span) are not supported. + Old compressions used by old PKZip 1.x are not supported + + Pascal tranlastion + Copyright (C) 2000 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt } + + +interface + +{$ifdef WIN32} + {$define Delphi} +{$endif} + +uses + zutil, + zLib, + ziputils; + + +const + UNZ_OK = (0); + UNZ_END_OF_LIST_OF_FILE = (-100); + UNZ_ERRNO = (Z_ERRNO); + UNZ_EOF = (0); + UNZ_PARAMERROR = (-102); + UNZ_BADZIPFILE = (-103); + UNZ_INTERNALERROR = (-104); + UNZ_CRCERROR = (-105); +(* +{ tm_unz contain date/time info } +type + tm_unz = record + tm_sec : uInt; { seconds after the minute - [0,59] } + tm_min : uInt; { minutes after the hour - [0,59] } + tm_hour : uInt; { hours since midnight - [0,23] } + tm_mday : uInt; { day of the month - [1,31] } + tm_mon : uInt; { months since January - [0,11] } + tm_year : uInt; { years - [1980..2044] } + end; +*) +{ unz_global_info structure contain global data about the ZIPfile + These data comes from the end of central dir } +type + unz_global_info = record + number_entry : uLong; { total number of entries in + the central dir on this disk } + size_comment : uLong; { size of the global comment of the zipfile } + end; + + +{ unz_file_info contain information about a file in the zipfile } +type + unz_file_info = record + version : uLong; { version made by 2 bytes } + version_needed : uLong; { version needed to extract 2 bytes } + flag : uLong; { general purpose bit flag 2 bytes } + compression_method : uLong; { compression method 2 bytes } + dosDate : uLong; { last mod file date in Dos fmt 4 bytes } + crc : uLong; { crc-32 4 bytes } + compressed_size : uLong; { compressed size 4 bytes } + uncompressed_size : uLong; { uncompressed size 4 bytes } + size_filename : uLong; { filename length 2 bytes } + size_file_extra : uLong; { extra field length 2 bytes } + size_file_comment : uLong; { file comment length 2 bytes } + + disk_num_start : uLong; { disk number start 2 bytes } + internal_fa : uLong; { internal file attributes 2 bytes } + external_fa : uLong; { external file attributes 4 bytes } + + tmu_date : tm_unz; + end; + unz_file_info_ptr = ^unz_file_info; + + +function unzStringFileNameCompare(const fileName1 : PChar; + const fileName2 : PChar; + iCaseSensitivity : int) : int; +{ Compare two filename (fileName1,fileName2). + If iCaseSenisivity = 1 (1=true), + comparision is case sensitive (like strcmp) + If iCaseSenisivity = 2 (0=false), + comparision is not case sensitive (like strcmpi or strcasecmp) + If iCaseSenisivity = 0, case sensitivity is defaut of your + operating system like 1 on Unix, 2 on Windows) +} + + +function unzOpen (const path : PChar) : unzFile; + +{ Open a Zip file. path contain the full pathname (by example, + on a Windows NT computer "c:\\zlib\\zlib111.zip" or on an Unix computer + "zlib/zlib111.zip". + If the zipfile cannot be opened (file don't exist or in not valid), the + return value is NIL. + Else, the return value is a unzFile Handle, usable with other function + of this unzip package. +} + +function unzClose (afile : unzFile) : int; + +{ Close a ZipFile opened with unzipOpen. + If there are files inside the .Zip opened with unzOpenCurrentFile() + (see later), these files MUST be closed with unzipCloseCurrentFile() + before a call unzipClose. + return UNZ_OK if there is no problem. } + +function unzGetGlobalInfo (afile : unzFile; + var pglobal_info : unz_global_info) : int; + +{ Write info about the ZipFile in the *pglobal_info structure. + No preparation of the structure is needed + return UNZ_OK if there is no problem. } + +function unzGetGlobalComment (afile : unzFile; + szComment : PChar; + uSizeBuf : uLong) : int; + +{ Get the global comment string of the ZipFile, in the szComment buffer. + uSizeBuf is the size of the szComment buffer. + return the number of byte copied or an error code <0 } + +{***************************************************************************} +{ Unzip package allow you browse the directory of the zipfile } + +function unzGoToFirstFile(afile : unzFile) : int; + +{ Set the current file of the zipfile to the first file. + return UNZ_OK if there is no problem } + +function unzGoToNextFile(afile : unzFile) : int; + +{ Set the current file of the zipfile to the next file. + return UNZ_OK if there is no problem + return UNZ_END_OF_LIST_OF_FILE if the actual file was the latest. } + + +function unzLocateFile(afile : unzFile; + const szFileName : PChar; + iCaseSensitivity : int) : int; { ZEXPORT } + +{ Try locate the file szFileName in the zipfile. + For the iCaseSensitivity signification, see unzStringFileNameCompare + + return value : + UNZ_OK if the file is found. It becomes the current file. + UNZ_END_OF_LIST_OF_FILE if the file is not found } + + +function unzGetCurrentFileInfo(afile : unzFile; + pfile_info : unz_file_info_ptr; + szFileName : PChar; + fileNameBufferSize : uLong; + extraField : voidp; + extraFieldBufferSize : uLong; + szComment : PChar; + commentBufferSize : uLong) : int; { ZEXPORT } + +{ Get Info about the current file + if pfile_info<>NIL, the pfile_info^ structure will contain somes + info about the current file + if szFileName<>NIL, the filemane string will be copied in szFileName + (fileNameBufferSize is the size of the buffer) + if extraField<>NIL, the extra field information will be copied in + extraField (extraFieldBufferSize is the size of the buffer). + This is the Central-header version of the extra field + if szComment<>NIL, the comment string of the file will be copied in + szComment (commentBufferSize is the size of the buffer) } + + +{***************************************************************************} +{* for reading the content of the current zipfile, you can open it, read data + from it, and close it (you can close it before reading all the file) } + + +function unzOpenCurrentFile(afile : unzFile) : int; { ZEXPORT } + +{ Open for reading data the current file in the zipfile. + If there is no error, the return value is UNZ_OK. } + + +function unzCloseCurrentFile(afile : unzFile) : int; { ZEXPORT } + +{ Close the file in zip opened with unzOpenCurrentFile + Return UNZ_CRCERROR if all the file was read but the CRC is not good } + + +function unzReadCurrentFile(afile : unzFile; + buf : voidp; + len : unsigned) : int; { ZEXPORT } + +{ Read bytes from the current file (opened by unzOpenCurrentFile) + buf contain buffer where data must be copied + len the size of buf. + + return the number of byte copied if somes bytes are copied + return 0 if the end of file was reached + return <0 with error code if there is an error + (UNZ_ERRNO for IO error, or zLib error for uncompress error) } + +function unztell(afile : unzFile) : z_off_t; + +{ Give the current position in uncompressed data } + +function unzeof(afile : unzFile) : int; + +{ return 1 if the end of file was reached, 0 elsewhere + ! checks for valid params } + +function unzGetLocalExtrafield (afile : unzFile; + buf : voidp; + len : unsigned) : int; +{ Read extra field from the current file (opened by unzOpenCurrentFile) + This is the local-header version of the extra field (sometimes, there is + more info in the local-header version than in the central-header) + + if buf=NIL, it return the size of the local extra field + + if buf<>NIL, len is the size of the buffer, the extra header is copied in + buf. + the return value is the number of bytes copied in buf, or (if <0) + the error code } + + +{ ----------------------------------------------------------------- } + +implementation + +uses + {$ifdef Delphi} + SysUtils, + {$else} + strings, + {$endif} + zInflate, crc; + +{$ifdef unix and not def (CASESENSITIVITYDEFAULT_YES) and \ + !defined(CASESENSITIVITYDEFAULT_NO)} +{$define CASESENSITIVITYDEFAULT_NO} +{$endif} + + +const + UNZ_BUFSIZE = Z_BUFSIZE; + UNZ_MAXFILENAMEINZIP = Z_MAXFILENAMEINZIP; + +const + unz_copyright : PChar = ' unzip 0.15 Copyright 1998 Gilles Vollant '; + +{ unz_file_info_internal contain internal info about a file in zipfile } +type + unz_file_info_internal = record + offset_curfile : uLong; { relative offset of local header 4 bytes } + end; + unz_file_info_internal_ptr = ^unz_file_info_internal; + + +{ file_in_zip_read_info_s contain internal information about a file + in zipfile, when reading and decompress it } +type + file_in_zip_read_info_s = record + read_buffer : PChar; { internal buffer for compressed data } + stream : z_stream; { zLib stream structure for inflate } + + pos_in_zipfile : uLong; { position in byte on the zipfile, for fseek} + stream_initialised : boolean; { flag set if stream structure is initialised} + + offset_local_extrafield : uLong;{ offset of the local extra field } + size_local_extrafield : uInt;{ size of the local extra field } + pos_local_extrafield : uLong; { position in the local extra field in read} + + crc32 : uLong; { crc32 of all data uncompressed } + crc32_wait : uLong; { crc32 we must obtain after decompress all } + rest_read_compressed : uLong; { number of byte to be decompressed } + rest_read_uncompressed : uLong;{number of byte to be obtained after decomp} + afile : FILEptr; { io structure of the zipfile } + compression_method : uLong; { compression method (0=store) } + byte_before_the_zipfile : uLong;{ byte before the zipfile, (>0 for sfx) } + end; + file_in_zip_read_info_s_ptr = ^file_in_zip_read_info_s; + + +{ unz_s contain internal information about the zipfile } +type + unz_s = record + afile : FILEptr; { io structore of the zipfile } + gi : unz_global_info; { public global information } + byte_before_the_zipfile : uLong;{ byte before the zipfile, (>0 for sfx)} + num_file : uLong; { number of the current file in the zipfile} + pos_in_central_dir : uLong; { pos of the current file in the central dir} + current_file_ok : boolean; { flag about the usability of the current file} + central_pos : uLong; { position of the beginning of the central dir} + + size_central_dir : uLong; { size of the central directory } + offset_central_dir : uLong; { offset of start of central directory with + respect to the starting disk number } + + cur_file_info : unz_file_info; { public info about the current file in zip} + cur_file_info_internal : unz_file_info_internal; { private info about it} + pfile_in_zip_read : file_in_zip_read_info_s_ptr; { structure about the current + file if we are decompressing it } + end; + unz_s_ptr = ^unz_s; + + +{ =========================================================================== + Read a byte from a gz_stream; update next_in and avail_in. Return EOF + for end of file. + IN assertion: the stream s has been sucessfully opened for reading. } + + +function unzlocal_getByte(fin : FILEptr; var pi : int) : int; +var + c : Byte; + err : int; +begin + err := fread(@c, 1, 1, fin); + + if (err = 1) then + begin + pi := int(c); + unzlocal_getByte := UNZ_OK; + {exit;} + end + else + begin + if feof(fin)=1 then {if ferror(fin) then} + unzlocal_getByte := UNZ_ERRNO + else + unzlocal_getByte := UNZ_EOF; + {exit;} + end; +end; + + +{ =========================================================================== + Reads a long in LSB order from the given gz_stream. Sets } + +function unzlocal_getShort (fin : FILEptr; + var pX : uLong) : int; +var + x : uLong; + i : int; + err : int; +begin + err := unzlocal_getByte(fin, i); + x := uLong(i); + + if (err=UNZ_OK) then + err := unzlocal_getByte(fin,i); + Inc(x, uLong(i) shl 8); + + if (err=UNZ_OK) then + pX := x + else + pX := 0; + unzlocal_getShort := err; +end; + +function unzlocal_getLong (fin : FILEptr; var pX : uLong) : int; +var + x : uLong; + i : int; + err : int; +begin + err := unzlocal_getByte(fin,i); + x := uLong(i); + + if (err=UNZ_OK) then + err := unzlocal_getByte(fin,i); + Inc(x, uLong(i) shl 8); + + if (err=UNZ_OK) then + err := unzlocal_getByte(fin,i); + Inc(x, uLong(i) shl 16); + + if (err=UNZ_OK) then + err := unzlocal_getByte(fin,i); + Inc(x, uLong(i) shl 24); + + if (err=UNZ_OK) then + pX := x + else + pX := 0; + unzlocal_getLong := err; +end; + + +{ My own strcmpi / strcasecmp } +function strcmpcasenosensitive_internal (fileName1 : PChar; + fileName2 : PChar) : int; +var + c1, c2 : char; +begin + repeat + c1 := fileName1^; Inc(fileName1); + c2 := fileName2^; Inc(fileName2); + if (c1>='a') and (c1<='z') then + Dec(c1,$20); + if (c2>='a') and (c2<='z') then + Dec(c2, $20); + if (c1=#0) then + begin + if c2=#0 then + strcmpcasenosensitive_internal := 0 + else + strcmpcasenosensitive_internal := -1; + exit; + end; + if (c2=#0) then + begin + strcmpcasenosensitive_internal := 1; + exit; + end; + if (c1<c2) then + begin + strcmpcasenosensitive_internal := -1; + exit; + end; + if (c1>c2) then + begin + strcmpcasenosensitive_internal := 1; + exit; + end; + until false; +end; + + +const + CASESENSITIVITYDEFAULTVALUE = 2; + +function unzStringFileNameCompare(const fileName1 : PChar; + const fileName2 : PChar; + iCaseSensitivity : int) : int; { ZEXPORT } +{ Compare two filename (fileName1,fileName2). + If iCaseSenisivity = 1 (1=true), + comparision is case sensitive (like strcmp) + If iCaseSenisivity = 2 (0=false), + comparision is not case sensitive (like strcmpi or strcasecmp) + If iCaseSenisivity = 0, case sensitivity is defaut of your + operating system like 1 on Unix, 2 on Windows) +} +begin + if (iCaseSensitivity=0) then + iCaseSensitivity := CASESENSITIVITYDEFAULTVALUE; + + if (iCaseSensitivity=1) then + begin + unzStringFileNameCompare := strComp(fileName1,fileName2); + exit; + end; + + unzStringFileNameCompare := strcmpcasenosensitive_internal(fileName1,fileName2); +end; + +const + BUFREADCOMMENT = $400; + +{ Locate the Central directory of a zipfile (at the end, just before + the global comment) } + +function unzlocal_SearchCentralDir(fin : FILEptr) : uLong; +var + buf : pzByteArray; + uSizeFile : uLong; + uBackRead : uLong; + uMaxBack : uLong; + uPosFound : uLong; +var + uReadSize,uReadPos : uLong; + i : int; +begin + uMaxBack := $ffff; { maximum size of global comment } + uPosFound := 0; + + if (fseek(fin,0,SEEK_END) <> 0) then + begin + unzlocal_SearchCentralDir := 0; + exit; + end; + + uSizeFile := ftell(fin); + + if (uMaxBack>uSizeFile) then + uMaxBack := uSizeFile; + + buf := pzByteArray(ALLOC(BUFREADCOMMENT+4)); + if (buf=NIL) then + begin + unzlocal_SearchCentralDir := 0; + exit; + end; + + uBackRead := 4; + while (uBackRead<uMaxBack) do + begin + + if (uBackRead+BUFREADCOMMENT>uMaxBack) then + uBackRead := uMaxBack + else + Inc(uBackRead, BUFREADCOMMENT); + uReadPos := uSizeFile-uBackRead ; + + if ((BUFREADCOMMENT+4) < (uSizeFile-uReadPos)) then + uReadSize := (BUFREADCOMMENT+4) + else + uReadSize := (uSizeFile-uReadPos); + + if fseek(fin,uReadPos,SEEK_SET)<>0 then + break; + + if fread(buf, uInt(uReadSize), 1, fin)<>1 then + break; + + i := int(uReadSize)-3; + while (i>0) do + begin + Dec(i); + if (buf^[i] = $50) and (buf^[i+1] = $4b) and { ENDHEADERMAGIC } + (buf^[i+2] = $05) and (buf^[i+3] = $06) then + begin + uPosFound := uReadPos+uInt(i); + break; + end; + end; + + if (uPosFound <> 0) then + break; + end; + TRYFREE(buf); + unzlocal_SearchCentralDir := uPosFound; +end; + + +{ Open a Zip file. path contain the full pathname (by example, + on a Windows NT computer "c:\\zlib\\zlib111.zip" or on an Unix computer + "zlib/zlib111.zip". + If the zipfile cannot be opened (file don't exist or in not valid), the + return value is NIL. + Else, the return value is a unzFile Handle, usable with other function + of this unzip package. +} + +function unzOpen (const path : PChar) : unzFile; { ZEXPORT } +var + us : unz_s; + s : unz_s_ptr; + central_pos,uL : uLong; + fin : FILEptr; + + number_disk : uLong; { number of the current dist, used for spaning ZIP, + unsupported, always 0 } + number_disk_with_CD : uLong; { number the the disk with central dir, + used for spaning ZIP, unsupported, always 0 } + number_entry_CD : uLong; { total number of entries in the central dir + (same than number_entry on nospan) } + + err : int; +begin + err := UNZ_OK; + + if (unz_copyright[0]<>' ') then + begin + unzOpen := NIL; + exit; + end; + + fin := fopen(path,fopenread); + if (fin=NIL) then + begin + unzOpen := NIL; + exit; + end; + + central_pos := unzlocal_SearchCentralDir(fin); + if (central_pos = 0) then + err := UNZ_ERRNO; + + if (fseek(fin,central_pos,SEEK_SET) <> 0) then + err := UNZ_ERRNO; + + { the signature, already checked } + if (unzlocal_getLong(fin,uL) <> UNZ_OK) then + err := UNZ_ERRNO; + + { number of this disk } + if (unzlocal_getShort(fin,number_disk) <> UNZ_OK) then + err := UNZ_ERRNO; + + { number of the disk with the start of the central directory } + if (unzlocal_getShort(fin,number_disk_with_CD) <> UNZ_OK) then + err := UNZ_ERRNO; + + { total number of entries in the central dir on this disk } + if (unzlocal_getShort(fin,us.gi.number_entry) <> UNZ_OK) then + err := UNZ_ERRNO; + + { total number of entries in the central dir } + if (unzlocal_getShort(fin,number_entry_CD) <> UNZ_OK) then + err := UNZ_ERRNO; + + if ((number_entry_CD <> us.gi.number_entry) or + (number_disk_with_CD <> 0) or + (number_disk <> 0)) then + err := UNZ_BADZIPFILE; + + { size of the central directory } + if (unzlocal_getLong(fin,us.size_central_dir)<>UNZ_OK) then + err := UNZ_ERRNO; + + { offset of start of central directory with respect to the + starting disk number } + if (unzlocal_getLong(fin,us.offset_central_dir)<>UNZ_OK) then + err := UNZ_ERRNO; + + { zipfile comment length } + if (unzlocal_getShort(fin,us.gi.size_comment)<>UNZ_OK) then + err := UNZ_ERRNO; + + if ((central_pos < us.offset_central_dir+us.size_central_dir) and + (err = UNZ_OK)) then + err := UNZ_BADZIPFILE; + + if (err<>UNZ_OK) then + begin + fclose(fin); + unzOpen := NIL; + exit; + end; + + us.afile := fin; + us.byte_before_the_zipfile := central_pos - + (us.offset_central_dir + us.size_central_dir); + us.central_pos := central_pos; + us.pfile_in_zip_read := NIL; + + s := unz_s_ptr(ALLOC(sizeof(unz_s))); + s^ := us; + unzGoToFirstFile(unzFile(s)); + unzOpen := unzFile(s); +end; + + +{ Close a ZipFile opened with unzipOpen. + If there are files inside the .Zip opened with unzOpenCurrentFile() + (see later), these files MUST be closed with unzipCloseCurrentFile() + before a call unzipClose. + return UNZ_OK if there is no problem. } + +function unzClose (afile : unzFile) : int; { ZEXPORT } +var + s : unz_s_ptr; +begin + if (afile=NIL) then + begin + unzClose := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + + if (s^.pfile_in_zip_read<>NIL) then + unzCloseCurrentFile(afile); + + fclose(s^.afile); + TRYFREE(s); + unzClose := UNZ_OK; +end; + +{ Write info about the ZipFile in the pglobal_info structure. + No preparation of the structure is needed + return UNZ_OK if there is no problem. } + +function unzGetGlobalInfo (afile : unzFile; + var pglobal_info : unz_global_info) : int; { ZEXPORT } +var + s : unz_s_ptr; +begin + if (afile=NIL) then + begin + unzGetGlobalInfo := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + pglobal_info := s^.gi; + unzGetGlobalInfo := UNZ_OK; +end; + + +{ Translate date/time from Dos format to tm_unz (more easily readable) } +procedure unzlocal_DosDateToTmuDate (ulDosDate : uLong; + var ptm : tm_unz); +var + uDate : uLong; +begin + uDate := uLong(ulDosDate shr 16); + ptm.tm_mday := uInt(uDate and $1f) ; + ptm.tm_mon := uInt((( (uDate) and $1E0) div $20)-1) ; + ptm.tm_year := uInt(((uDate and $0FE00) div $0200)+1980) ; + + ptm.tm_hour := uInt ((ulDosDate and $F800) div $800); + ptm.tm_min := uInt ((ulDosDate and $7E0) div $20) ; + ptm.tm_sec := uInt (2*(ulDosDate and $1f)) ; +end; + +{$HINTS OFF} +{ Get Info about the current file in the zipfile, with internal only info } +function unzlocal_GetCurrentFileInfoInternal ( + afile : unzFile; + pfile_info : unz_file_info_ptr; + pfile_info_internal : unz_file_info_internal_ptr; + szFileName : PChar; + fileNameBufferSize : uLong; + extraField : voidp; + extraFieldBufferSize : uLong; + szComment : PChar; + commentBufferSize : uLong ) : int; + var + s : unz_s_ptr; + file_info : unz_file_info; + file_info_internal : unz_file_info_internal; + err : int; + uMagic : uLong; + lSeek : long; + var + uSizeRead : uLong; + begin + err := UNZ_OK; + lSeek := 0; + if (afile = NIL) then + begin + unzlocal_GetCurrentFileInfoInternal := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + + if (fseek(s^.afile, + s^.pos_in_central_dir+s^.byte_before_the_zipfile,SEEK_SET)<>0) then + err := UNZ_ERRNO; + + { we check the magic } + if (err=UNZ_OK) then + if (unzlocal_getLong(s^.afile, uMagic) <> UNZ_OK) then + err := UNZ_ERRNO + else + if (uMagic<> CENTRALHEADERMAGIC) then + err := UNZ_BADZIPFILE; + + if (unzlocal_getShort(s^.afile, file_info.version) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, file_info.version_needed) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, file_info.flag) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, file_info.compression_method) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getLong(s^.afile, file_info.dosDate) <> UNZ_OK) then + err := UNZ_ERRNO; + + unzlocal_DosDateToTmuDate(file_info.dosDate, file_info.tmu_date); + + if (unzlocal_getLong(s^.afile, file_info.crc) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getLong(s^.afile, file_info.compressed_size) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getLong(s^.afile, file_info.uncompressed_size) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, file_info.size_filename) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, file_info.size_file_extra) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, file_info.size_file_comment) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, file_info.disk_num_start) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, file_info.internal_fa) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getLong(s^.afile, file_info.external_fa) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getLong(s^.afile, file_info_internal.offset_curfile) <> UNZ_OK) then + err := UNZ_ERRNO; + + Inc(lSeek, file_info.size_filename); + if ((err=UNZ_OK) and (szFileName<>NIL)) then + begin + if (file_info.size_filename<fileNameBufferSize) then + begin + (szFileName+file_info.size_filename)^:=#0; + uSizeRead := file_info.size_filename; + end + else + uSizeRead := fileNameBufferSize; + + if (file_info.size_filename>0) and (fileNameBufferSize>0) then + begin + if fread(szFileName, uInt(uSizeRead),1,s^.afile)<>1 then + err := UNZ_ERRNO; + end; + Dec(lSeek, uSizeRead); + end; + + if ((err=UNZ_OK) and (extraField<>NIL)) then + begin + if (file_info.size_file_extra<extraFieldBufferSize) then + uSizeRead := file_info.size_file_extra + else + uSizeRead := extraFieldBufferSize; + + if (lSeek<>0) then + begin + if (fseek(s^.afile,lSeek,SEEK_CUR)=0) then + lSeek := 0 + else + err := UNZ_ERRNO; + end; + + if ((file_info.size_file_extra>0) and (extraFieldBufferSize>0)) then + begin + if fread(extraField, uInt(uSizeRead),1, s^.afile)<>1 then + err := UNZ_ERRNO; + end; + Inc(lSeek, file_info.size_file_extra - uSizeRead); + end + else + Inc(lSeek, file_info.size_file_extra); + + if ((err=UNZ_OK) and (szComment<>NIL)) then + begin + if (file_info.size_file_comment<commentBufferSize) then + begin + (szComment+file_info.size_file_comment)^ := #0; + uSizeRead := file_info.size_file_comment; + end + else + uSizeRead := commentBufferSize; + + if (lSeek<>0) then + begin + if (fseek(s^.afile,lSeek,SEEK_CUR)=0) then + lSeek := 0 + else + err := UNZ_ERRNO; + end; + if ((file_info.size_file_comment>0) and (commentBufferSize>0)) then + begin + if fread(szComment, uInt(uSizeRead),1,s^.afile)<>1 then + err := UNZ_ERRNO; + end; + Inc(lSeek, file_info.size_file_comment - uSizeRead); + end + else + Inc(lSeek, file_info.size_file_comment); + + if ((err=UNZ_OK) and (pfile_info<>NIL)) then + pfile_info^ := file_info; + + if ((err=UNZ_OK) and (pfile_info_internal<>NIL)) then + pfile_info_internal^ := file_info_internal; + + unzlocal_GetCurrentFileInfoInternal := err; + end; +{$HINTS ON} + +{ Write info about the ZipFile in the *pglobal_info structure. + No preparation of the structure is needed + return UNZ_OK if there is no problem. } + +function unzGetCurrentFileInfo(afile : unzFile; + pfile_info : unz_file_info_ptr; + szFileName : PChar; + fileNameBufferSize : uLong; + extraField : voidp; + extraFieldBufferSize : uLong; + szComment : PChar; + commentBufferSize : uLong) : int; { ZEXPORT } + +{ Get Info about the current file + if pfile_info<>NIL, the pfile_info^ structure will contain somes + info about the current file + if szFileName<>NIL, the filemane string will be copied in szFileName + (fileNameBufferSize is the size of the buffer) + if extraField<>NIL, the extra field information will be copied in + extraField (extraFieldBufferSize is the size of the buffer). + This is the Central-header version of the extra field + if szComment<>NIL, the comment string of the file will be copied in + szComment (commentBufferSize is the size of the buffer) } + +begin + unzGetCurrentFileInfo := unzlocal_GetCurrentFileInfoInternal(afile, + pfile_info,NIL,szFileName,fileNameBufferSize, extraField, + extraFieldBufferSize, szComment,commentBufferSize); +end; + + +{ Set the current file of the zipfile to the first file. + return UNZ_OK if there is no problem } + +function unzGoToFirstFile(afile : unzFile) : int; { ZEXPORT } +var + err : int; + s : unz_s_ptr; +begin + if (afile=NIL) then + begin + unzGoToFirstFile := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + s^.pos_in_central_dir := s^.offset_central_dir; + s^.num_file := 0; + err := unzlocal_GetCurrentFileInfoInternal(afile, @s^.cur_file_info, + @s^.cur_file_info_internal, NIL,0,NIL,0,NIL,0); + s^.current_file_ok := (err = UNZ_OK); + unzGoToFirstFile := err; +end; + + +{ Set the current file of the zipfile to the next file. + return UNZ_OK if there is no problem + return UNZ_END_OF_LIST_OF_FILE if the actual file was the latest. } + +function unzGoToNextFile(afile : unzFile) : int; { ZEXPORT } +var + s : unz_s_ptr; + err : int; +begin + if (afile=NIL) then + begin + unzGoToNextFile := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + if not s^.current_file_ok then + begin + unzGoToNextFile := UNZ_END_OF_LIST_OF_FILE; + exit; + end; + if (s^.num_file+1 = s^.gi.number_entry) then + begin + unzGoToNextFile := UNZ_END_OF_LIST_OF_FILE; + exit; + end; + + Inc(s^.pos_in_central_dir, + SIZECENTRALDIRITEM + s^.cur_file_info.size_filename + + s^.cur_file_info.size_file_extra + s^.cur_file_info.size_file_comment); + Inc(s^.num_file); + err := unzlocal_GetCurrentFileInfoInternal(afile, @s^.cur_file_info, + @s^.cur_file_info_internal, NIL,0,NIL,0,NIL,0); + s^.current_file_ok := (err = UNZ_OK); + unzGoToNextFile := err; +end; + + +{ Try locate the file szFileName in the zipfile. + For the iCaseSensitivity signification, see unzStringFileNameCompare + + return value : + UNZ_OK if the file is found. It becomes the current file. + UNZ_END_OF_LIST_OF_FILE if the file is not found } + +function unzLocateFile(afile : unzFile; + const szFileName : PChar; + iCaseSensitivity : int) : int; { ZEXPORT } +var + s : unz_s_ptr; + err : int; + num_fileSaved : uLong; + pos_in_central_dirSaved : uLong; +var + szCurrentFileName : array[0..UNZ_MAXFILENAMEINZIP+1-1] of char; +begin + if (afile=NIL) then + begin + unzLocateFile := UNZ_PARAMERROR; + exit; + end; + + if (strlen(szFileName)>=UNZ_MAXFILENAMEINZIP) then + begin + unzLocateFile := UNZ_PARAMERROR; + exit; + end; + + s := unz_s_ptr(afile); + if (not s^.current_file_ok) then + begin + unzLocateFile := UNZ_END_OF_LIST_OF_FILE; + exit; + end; + num_fileSaved := s^.num_file; + pos_in_central_dirSaved := s^.pos_in_central_dir; + + err := unzGoToFirstFile(afile); + + while (err = UNZ_OK) do + begin + unzGetCurrentFileInfo(afile,NIL, + szCurrentFileName,sizeof(szCurrentFileName)-1, NIL,0,NIL,0); + if (unzStringFileNameCompare(szCurrentFileName, + szFileName,iCaseSensitivity)=0) then + begin + unzLocateFile := UNZ_OK; + exit; + end; + err := unzGoToNextFile(afile); + end; + + s^.num_file := num_fileSaved; + s^.pos_in_central_dir := pos_in_central_dirSaved; + unzLocateFile := err; +end; + + +{ Read the local header of the current zipfile + Check the coherency of the local header and info in the end of central + directory about this file + store in *piSizeVar the size of extra info in local header + (filename and size of extra field data) } + +function unzlocal_CheckCurrentFileCoherencyHeader ( + s : unz_s_ptr; + var piSizeVar : uInt; + var poffset_local_extrafield : uLong; + var psize_local_extrafield : uInt) : int; +var + uMagic,uData,uFlags : uLong; + size_filename : uLong; + size_extra_field : uLong; + err : int; +begin + err := UNZ_OK; + + piSizeVar := 0; + poffset_local_extrafield := 0; + psize_local_extrafield := 0; + + if (fseek(s^.afile,s^.cur_file_info_internal.offset_curfile + + s^.byte_before_the_zipfile,SEEK_SET)<>0) then + begin + unzlocal_CheckCurrentFileCoherencyHeader := UNZ_ERRNO; + exit; + end; + + if (err=UNZ_OK) then + if (unzlocal_getLong(s^.afile, uMagic) <> UNZ_OK) then + err := UNZ_ERRNO + else + if (uMagic<> $04034b50) then + err := UNZ_BADZIPFILE; + + if (unzlocal_getShort(s^.afile, uData) <> UNZ_OK) then + err := UNZ_ERRNO; +{ + else + if ((err=UNZ_OK) and (uData<>s^.cur_file_info.wVersion)) then + err := UNZ_BADZIPFILE; +} + if (unzlocal_getShort(s^.afile, uFlags) <> UNZ_OK) then + err := UNZ_ERRNO; + + if (unzlocal_getShort(s^.afile, uData) <> UNZ_OK) then + err := UNZ_ERRNO + else + if ((err=UNZ_OK) and (uData<>s^.cur_file_info.compression_method)) then + err := UNZ_BADZIPFILE; + + if ((err=UNZ_OK) and (s^.cur_file_info.compression_method<>0) and + (s^.cur_file_info.compression_method<>Z_DEFLATED)) then + err := UNZ_BADZIPFILE; + + if (unzlocal_getLong(s^.afile, uData) <> UNZ_OK) then { date/time } + err := UNZ_ERRNO; + + if (unzlocal_getLong(s^.afile, uData) <> UNZ_OK) then { crc } + err := UNZ_ERRNO + else + if ((err=UNZ_OK) and (uData<>s^.cur_file_info.crc) and + ((uFlags and 8)=0)) then + err := UNZ_BADZIPFILE; + + if (unzlocal_getLong(s^.afile, uData) <> UNZ_OK) then { size compr } + err := UNZ_ERRNO + else + if ((err=UNZ_OK) and (uData<>s^.cur_file_info.compressed_size) and + ((uFlags and 8)=0)) then + err := UNZ_BADZIPFILE; + + if (unzlocal_getLong(s^.afile, uData) <> UNZ_OK) then { size uncompr } + err := UNZ_ERRNO + else + if ((err=UNZ_OK) and (uData<>s^.cur_file_info.uncompressed_size) and + ((uFlags and 8)=0)) then + err := UNZ_BADZIPFILE; + + + if (unzlocal_getShort(s^.afile, size_filename) <> UNZ_OK) then + err := UNZ_ERRNO + else + if ((err=UNZ_OK) and (size_filename<>s^.cur_file_info.size_filename)) then + err := UNZ_BADZIPFILE; + + Inc(piSizeVar, uInt(size_filename)); + + if (unzlocal_getShort(s^.afile, size_extra_field) <> UNZ_OK) then + err := UNZ_ERRNO; + poffset_local_extrafield := s^.cur_file_info_internal.offset_curfile + + SIZEZIPLOCALHEADER + size_filename; + psize_local_extrafield := uInt(size_extra_field); + + Inc(piSizeVar, uInt(size_extra_field)); + + unzlocal_CheckCurrentFileCoherencyHeader := err; +end; + +{ Open for reading data the current file in the zipfile. + If there is no error, the return value is UNZ_OK. } + +{$HINTS OFF} +function unzOpenCurrentFile(afile : unzFile) : int; { ZEXPORT } +var + err : int; + Store : boolean; + iSizeVar : uInt; + s : unz_s_ptr; + pfile_in_zip_read_info : file_in_zip_read_info_s_ptr; + offset_local_extrafield : uLong; { offset of the local extra field } + size_local_extrafield : uInt; { size of the local extra field } +begin + err := UNZ_OK; + + if (afile=NIL) then + begin + unzOpenCurrentFile := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + if not s^.current_file_ok then + begin + unzOpenCurrentFile := UNZ_PARAMERROR; + exit; + end; + + if (s^.pfile_in_zip_read <> NIL) then + unzCloseCurrentFile(afile); + + if (unzlocal_CheckCurrentFileCoherencyHeader(s, iSizeVar, + offset_local_extrafield, size_local_extrafield)<>UNZ_OK) then + begin + unzOpenCurrentFile := UNZ_BADZIPFILE; + exit; + end; + + pfile_in_zip_read_info := file_in_zip_read_info_s_ptr( + ALLOC(sizeof(file_in_zip_read_info_s)) ); + if (pfile_in_zip_read_info=NIL) then + begin + unzOpenCurrentFile := UNZ_INTERNALERROR; + exit; + end; + + pfile_in_zip_read_info^.read_buffer := PChar(ALLOC(UNZ_BUFSIZE)); + pfile_in_zip_read_info^.offset_local_extrafield := offset_local_extrafield; + pfile_in_zip_read_info^.size_local_extrafield := size_local_extrafield; + pfile_in_zip_read_info^.pos_local_extrafield := 0; + + if (pfile_in_zip_read_info^.read_buffer=NIL) then + begin + TRYFREE(pfile_in_zip_read_info); + unzOpenCurrentFile := UNZ_INTERNALERROR; + exit; + end; + + pfile_in_zip_read_info^.stream_initialised := false; + + if ((s^.cur_file_info.compression_method<>0) and + (s^.cur_file_info.compression_method<>Z_DEFLATED)) then + err := UNZ_BADZIPFILE; + Store := s^.cur_file_info.compression_method = 0; + + pfile_in_zip_read_info^.crc32_wait := s^.cur_file_info.crc; + pfile_in_zip_read_info^.crc32 := 0; + pfile_in_zip_read_info^.compression_method := s^.cur_file_info.compression_method; + pfile_in_zip_read_info^.afile := s^.afile; + pfile_in_zip_read_info^.byte_before_the_zipfile := s^.byte_before_the_zipfile; + + pfile_in_zip_read_info^.stream.total_out := 0; + + if (not Store) then + begin + pfile_in_zip_read_info^.stream.zalloc := NIL; + pfile_in_zip_read_info^.stream.zfree := NIL; + pfile_in_zip_read_info^.stream.opaque := voidpf(NIL); + + err := inflateInit2(pfile_in_zip_read_info^.stream, -MAX_WBITS); + + if (err = Z_OK) then + pfile_in_zip_read_info^.stream_initialised := true; + { windowBits is passed < 0 to tell that there is no zlib header. + Note that in this case inflate *requires* an extra "dummy" byte + after the compressed stream in order to complete decompression and + return Z_STREAM_END. + In unzip, i don't wait absolutely Z_STREAM_END because I known the + size of both compressed and uncompressed data } + end; + pfile_in_zip_read_info^.rest_read_compressed := s^.cur_file_info.compressed_size ; + pfile_in_zip_read_info^.rest_read_uncompressed := s^.cur_file_info.uncompressed_size ; + + + pfile_in_zip_read_info^.pos_in_zipfile := + s^.cur_file_info_internal.offset_curfile + SIZEZIPLOCALHEADER + iSizeVar; + + pfile_in_zip_read_info^.stream.avail_in := uInt(0); + + + s^.pfile_in_zip_read := pfile_in_zip_read_info; + unzOpenCurrentFile := UNZ_OK; +end; +{$HINTS ON} + +{ Read bytes from the current file (opened by unzOpenCurrentFile) + buf contain buffer where data must be copied + len the size of buf. + + return the number of byte copied if somes bytes are copied + return 0 if the end of file was reached + return <0 with error code if there is an error + (UNZ_ERRNO for IO error, or zLib error for uncompress error) } + +function unzReadCurrentFile(afile : unzFile; + buf : voidp; + len : unsigned) : int; { ZEXPORT } + +var + err : int; + iRead: uInt; + s : unz_s_ptr; + pfile_in_zip_read_info : file_in_zip_read_info_s_ptr; +var + uReadThis : uInt; +var + uDoCopy,i : uInt; +var + uTotalOutBefore,uTotalOutAfter : uLong; + bufBefore : pBytef; + uOutThis : uLong; + flush : int; +begin + err := UNZ_OK; + iRead := 0; + if (afile=NIL) then + begin + unzReadCurrentFile := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + pfile_in_zip_read_info := s^.pfile_in_zip_read; + + if (pfile_in_zip_read_info=NIL) then + begin + unzReadCurrentFile := UNZ_PARAMERROR; + exit; + end; + + if ((pfile_in_zip_read_info^.read_buffer = NIL)) then + begin + unzReadCurrentFile := UNZ_END_OF_LIST_OF_FILE; + exit; + end; + + if (len=0) then + begin + unzReadCurrentFile := 0; + exit; + end; + + pfile_in_zip_read_info^.stream.next_out := pBytef(buf); + + pfile_in_zip_read_info^.stream.avail_out := uInt(len); + + if (len>pfile_in_zip_read_info^.rest_read_uncompressed) then + pfile_in_zip_read_info^.stream.avail_out := + uInt(pfile_in_zip_read_info^.rest_read_uncompressed); + + while (pfile_in_zip_read_info^.stream.avail_out>0) do + begin + if ((pfile_in_zip_read_info^.stream.avail_in = 0) and + (pfile_in_zip_read_info^.rest_read_compressed>0) ) then + begin + uReadThis := UNZ_BUFSIZE; + if (pfile_in_zip_read_info^.rest_read_compressed<uReadThis) then + uReadThis := uInt(pfile_in_zip_read_info^.rest_read_compressed); + if (uReadThis = 0) then + begin + unzReadCurrentFile := UNZ_EOF; + exit; + end; + if (fseek(pfile_in_zip_read_info^.afile, + pfile_in_zip_read_info^.pos_in_zipfile + + pfile_in_zip_read_info^.byte_before_the_zipfile,SEEK_SET)<>0) then + begin + unzReadCurrentFile := UNZ_ERRNO; + exit; + end; + if fread(pfile_in_zip_read_info^.read_buffer, uReadThis, 1, + pfile_in_zip_read_info^.afile)<>1 then + begin + unzReadCurrentFile := UNZ_ERRNO; + exit; + end; + Inc(pfile_in_zip_read_info^.pos_in_zipfile, uReadThis); + + Dec(pfile_in_zip_read_info^.rest_read_compressed, uReadThis); + + pfile_in_zip_read_info^.stream.next_in := + pBytef(pfile_in_zip_read_info^.read_buffer); + pfile_in_zip_read_info^.stream.avail_in := uInt(uReadThis); + end; + + if (pfile_in_zip_read_info^.compression_method=0) then + begin + if (pfile_in_zip_read_info^.stream.avail_out < + pfile_in_zip_read_info^.stream.avail_in) then + uDoCopy := pfile_in_zip_read_info^.stream.avail_out + else + uDoCopy := pfile_in_zip_read_info^.stream.avail_in; + + for i:=0 to uDoCopy-1 do + pzByteArray(pfile_in_zip_read_info^.stream.next_out)^[i] := + pzByteArray(pfile_in_zip_read_info^.stream.next_in)^[i]; + + pfile_in_zip_read_info^.crc32 := crc32(pfile_in_zip_read_info^.crc32, + pfile_in_zip_read_info^.stream.next_out, uDoCopy); + Dec(pfile_in_zip_read_info^.rest_read_uncompressed, uDoCopy); + Dec(pfile_in_zip_read_info^.stream.avail_in, uDoCopy); + Dec(pfile_in_zip_read_info^.stream.avail_out, uDoCopy); + Inc(pfile_in_zip_read_info^.stream.next_out, uDoCopy); + Inc(pfile_in_zip_read_info^.stream.next_in, uDoCopy); + Inc(pfile_in_zip_read_info^.stream.total_out, uDoCopy); + Inc(iRead, uDoCopy); + end + else + begin + flush := Z_SYNC_FLUSH; + + uTotalOutBefore := pfile_in_zip_read_info^.stream.total_out; + bufBefore := pfile_in_zip_read_info^.stream.next_out; + + { + if ((pfile_in_zip_read_info^.rest_read_uncompressed = + pfile_in_zip_read_info^.stream.avail_out) and + (pfile_in_zip_read_info^.rest_read_compressed = 0)) then + flush := Z_FINISH; + } + err := inflate(pfile_in_zip_read_info^.stream,flush); + + uTotalOutAfter := pfile_in_zip_read_info^.stream.total_out; + uOutThis := uTotalOutAfter-uTotalOutBefore; + + pfile_in_zip_read_info^.crc32 := + crc32(pfile_in_zip_read_info^.crc32,bufBefore, uInt(uOutThis)); + + Dec(pfile_in_zip_read_info^.rest_read_uncompressed, uOutThis); + + Inc(iRead, uInt(uTotalOutAfter - uTotalOutBefore)); + + if (err=Z_STREAM_END) then + begin + if iRead=0 then + unzReadCurrentFile := UNZ_EOF + else + unzReadCurrentFile := iRead; + exit; + end; + if (err<>Z_OK) then + break; + end; + end; { while } + + if (err=Z_OK) then + begin + unzReadCurrentFile := iRead; + exit; + end; + unzReadCurrentFile := err; +end; + +{ Give the current position in uncompressed data } + +function unztell(afile : unzFile) : z_off_t; { ZEXPORT } +var + s : unz_s_ptr; + pfile_in_zip_read_info : file_in_zip_read_info_s_ptr; +begin + if (afile=NIL) then + begin + unztell := UNZ_PARAMERROR; + exit; + end; + + s := unz_s_ptr(afile); + pfile_in_zip_read_info := s^.pfile_in_zip_read; + + if (pfile_in_zip_read_info=NIL) then + begin + unztell := UNZ_PARAMERROR; + exit; + end; + + unztell := z_off_t(pfile_in_zip_read_info^.stream.total_out); +end; + + +{ return 1 (TRUE) if the end of file was reached, 0 elsewhere } + +function unzeof(afile : unzFile) : int; +var + s : unz_s_ptr; + pfile_in_zip_read_info : file_in_zip_read_info_s_ptr; +begin + if (afile=NIL) then + begin + unzeof := UNZ_PARAMERROR; + exit; + end; + + s := unz_s_ptr(afile); + pfile_in_zip_read_info := s^.pfile_in_zip_read; + + if (pfile_in_zip_read_info = NIL) then + begin + unzeof := UNZ_PARAMERROR; + exit; + end; + + if (pfile_in_zip_read_info^.rest_read_uncompressed = 0) then + unzeof := 1 + else + unzeof := 0; +end; + + +{ Read extra field from the current file (opened by unzOpenCurrentFile) + This is the local-header version of the extra field (sometimes, there is + more info in the local-header version than in the central-header) + + if buf=NIL, it return the size of the local extra field + + if buf<>NIL, len is the size of the buffer, the extra header is copied in + buf. + the return value is the number of bytes copied in buf, or (if <0) + the error code } + +function unzGetLocalExtrafield (afile : unzFile; + buf : voidp; + len : unsigned) : int; +var + s : unz_s_ptr; + pfile_in_zip_read_info : file_in_zip_read_info_s_ptr; + read_now : uInt; + size_to_read : uLong; +begin + if (afile=NIL) then + begin + unzGetLocalExtrafield := UNZ_PARAMERROR; + exit; + end; + + s := unz_s_ptr(afile); + pfile_in_zip_read_info := s^.pfile_in_zip_read; + + if (pfile_in_zip_read_info=NIL) then + begin + unzGetLocalExtrafield := UNZ_PARAMERROR; + exit; + end; + + size_to_read := (pfile_in_zip_read_info^.size_local_extrafield - + pfile_in_zip_read_info^.pos_local_extrafield); + + if (buf=NIL) then + begin + unzGetLocalExtrafield := int(size_to_read); + exit; + end; + + if (len>size_to_read) then + read_now := uInt(size_to_read) + else + read_now := uInt(len); + + if (read_now=0) then + begin + unzGetLocalExtrafield := 0; + exit; + end; + + if (fseek(pfile_in_zip_read_info^.afile, + pfile_in_zip_read_info^.offset_local_extrafield + + pfile_in_zip_read_info^.pos_local_extrafield,SEEK_SET)<>0) then + begin + unzGetLocalExtrafield := UNZ_ERRNO; + exit; + end; + + if fread(buf,uInt(size_to_read),1, pfile_in_zip_read_info^.afile)<>1 then + begin + unzGetLocalExtrafield := UNZ_ERRNO; + exit; + end; + + unzGetLocalExtrafield := int(read_now); +end; + +{ Close the file in zip opened with unzOpenCurrentFile + Return UNZ_CRCERROR if all the file was read but the CRC is not good } + +function unzCloseCurrentFile(afile : unzFile) : int; { ZEXPORT } +var + err : int; + s : unz_s_ptr; + pfile_in_zip_read_info : file_in_zip_read_info_s_ptr; +begin + err := UNZ_OK; + + if (afile=NIL) then + begin + unzCloseCurrentFile := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + pfile_in_zip_read_info := s^.pfile_in_zip_read; + + if (pfile_in_zip_read_info=NIL) then + begin + unzCloseCurrentFile := UNZ_PARAMERROR; + exit; + end; + + + if (pfile_in_zip_read_info^.rest_read_uncompressed = 0) then + begin + if (pfile_in_zip_read_info^.crc32 <> pfile_in_zip_read_info^.crc32_wait) then + err :=UNZ_CRCERROR; + end; + + + TRYFREE(pfile_in_zip_read_info^.read_buffer); + pfile_in_zip_read_info^.read_buffer := NIL; + if (pfile_in_zip_read_info^.stream_initialised) then + inflateEnd(pfile_in_zip_read_info^.stream); + + pfile_in_zip_read_info^.stream_initialised := false; + TRYFREE(pfile_in_zip_read_info); + + s^.pfile_in_zip_read := NIL; + + unzCloseCurrentFile := err; +end; + + +{ Get the global comment string of the ZipFile, in the szComment buffer. + uSizeBuf is the size of the szComment buffer. + return the number of byte copied or an error code <0 } + +function unzGetGlobalComment (afile : unzFile; + szComment : PChar; + uSizeBuf : uLong) : int; { ZEXPORT } + +var + s : unz_s_ptr; + uReadThis : uLong; +begin + if (afile=NIL) then + begin + unzGetGlobalComment := UNZ_PARAMERROR; + exit; + end; + s := unz_s_ptr(afile); + + uReadThis := uSizeBuf; + if (uReadThis>s^.gi.size_comment) then + uReadThis := s^.gi.size_comment; + + if (fseek(s^.afile,s^.central_pos+22,SEEK_SET)<>0) then + begin + unzGetGlobalComment := UNZ_ERRNO; + exit; + end; + + if (uReadThis>0) then + begin + szComment^ := #0; + if fread(szComment, uInt(uReadThis), 1,s^.afile)<>1 then + begin + unzGetGlobalComment := UNZ_ERRNO; + exit; + end; + end; + + if ((szComment <> NIL) and (uSizeBuf > s^.gi.size_comment)) then + (szComment+s^.gi.size_comment)^ := #0; + + unzGetGlobalComment := int(uReadThis); +end; + +end. diff --git a/niftiview7/gzio/ZCONF.INC b/niftiview7/gzio/ZCONF.INC new file mode 100755 index 0000000..c7bd86b --- /dev/null +++ b/niftiview7/gzio/ZCONF.INC @@ -0,0 +1,32 @@ +{ -------------------------------------------------------------------- } + +{$DEFINE MAX_MATCH_IS_258} + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{- $DEFINE MAXSEG_64K} +{$IFDEF VER70} + {$DEFINE MAXSEG_64K} +{$ENDIF} +{$IFNDEF WIN32} + {$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } +{$ENDIF} + +{$UNDEF DYNAMIC_CRC_TABLE} +{$UNDEF FASTEST} +{$define patch112} { apply patch from the zlib home page } +{ -------------------------------------------------------------------- } +{$IFDEF WIN32} + {$DEFINE Delphi32} + {- $DEFINE Delphi5} { keep compiler quiet } +{$ENDIF} + +{$IFDEF FPC} + {$DEFINE Use32} + {$UNDEF DPMI} + {$UNDEF MSDOS} + {$UNDEF UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } + {$UNDEF MAXSEG_64K} + {$UNDEF Delphi32} +{$ENDIF} diff --git a/niftiview7/gzio/ZINFLATE.PAS b/niftiview7/gzio/ZINFLATE.PAS new file mode 100755 index 0000000..07935b4 --- /dev/null +++ b/niftiview7/gzio/ZINFLATE.PAS @@ -0,0 +1,750 @@ +Unit zInflate; + +{ inflate.c -- zlib interface to inflate modules + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil, zlib, infblock, infutil; + +function inflateInit(var z : z_stream) : int; + +{ Initializes the internal stream state for decompression. The fields + zalloc, zfree and opaque must be initialized before by the caller. If + zalloc and zfree are set to Z_NULL, inflateInit updates them to use default + allocation functions. + + inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_VERSION_ERROR if the zlib library version is incompatible + with the version assumed by the caller. msg is set to null if there is no + error message. inflateInit does not perform any decompression: this will be + done by inflate(). } + + + +function inflateInit_(z : z_streamp; + const version : string; + stream_size : int) : int; + + +function inflateInit2_(var z: z_stream; + w : int; + const version : string; + stream_size : int) : int; + +function inflateInit2(var z: z_stream; + windowBits : int) : int; + +{ + This is another version of inflateInit with an extra parameter. The + fields next_in, avail_in, zalloc, zfree and opaque must be initialized + before by the caller. + + The windowBits parameter is the base two logarithm of the maximum window + size (the size of the history buffer). It should be in the range 8..15 for + this version of the library. The default value is 15 if inflateInit is used + instead. If a compressed stream with a larger window size is given as + input, inflate() will return with the error code Z_DATA_ERROR instead of + trying to allocate a larger window. + + inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough + memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative + memLevel). msg is set to null if there is no error message. inflateInit2 + does not perform any decompression apart from reading the zlib header if + present: this will be done by inflate(). (So next_in and avail_in may be + modified, but next_out and avail_out are unchanged.) +} + + + +function inflateEnd(var z : z_stream) : int; + +{ + All dynamically allocated data structures for this stream are freed. + This function discards any unprocessed input and does not flush any + pending output. + + inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state + was inconsistent. In the error case, msg may be set but then points to a + static string (which must not be deallocated). +} + +function inflateReset(var z : z_stream) : int; + +{ + This function is equivalent to inflateEnd followed by inflateInit, + but does not free and reallocate all the internal decompression state. + The stream will keep attributes that may have been set by inflateInit2. + + inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source + stream state was inconsistent (such as zalloc or state being NULL). +} + + +function inflate(var z : z_stream; + f : int) : int; +{ + inflate decompresses as much data as possible, and stops when the input + buffer becomes empty or the output buffer becomes full. It may introduce + some output latency (reading input without producing any output) + except when forced to flush. + + The detailed semantics are as follows. inflate performs one or both of the + following actions: + + - Decompress more input starting at next_in and update next_in and avail_in + accordingly. If not all input can be processed (because there is not + enough room in the output buffer), next_in is updated and processing + will resume at this point for the next call of inflate(). + + - Provide more output starting at next_out and update next_out and avail_out + accordingly. inflate() provides as much output as possible, until there + is no more input data or no more space in the output buffer (see below + about the flush parameter). + + Before the call of inflate(), the application should ensure that at least + one of the actions is possible, by providing more input and/or consuming + more output, and updating the next_* and avail_* values accordingly. + The application can consume the uncompressed output when it wants, for + example when the output buffer is full (avail_out == 0), or after each + call of inflate(). If inflate returns Z_OK and with zero avail_out, it + must be called again after making room in the output buffer because there + might be more output pending. + + If the parameter flush is set to Z_SYNC_FLUSH, inflate flushes as much + output as possible to the output buffer. The flushing behavior of inflate is + not specified for values of the flush parameter other than Z_SYNC_FLUSH + and Z_FINISH, but the current implementation actually flushes as much output + as possible anyway. + + inflate() should normally be called until it returns Z_STREAM_END or an + error. However if all decompression is to be performed in a single step + (a single call of inflate), the parameter flush should be set to + Z_FINISH. In this case all pending input is processed and all pending + output is flushed; avail_out must be large enough to hold all the + uncompressed data. (The size of the uncompressed data may have been saved + by the compressor for this purpose.) The next operation on this stream must + be inflateEnd to deallocate the decompression state. The use of Z_FINISH + is never required, but can be used to inform inflate that a faster routine + may be used for the single inflate() call. + + If a preset dictionary is needed at this point (see inflateSetDictionary + below), inflate sets strm-adler to the adler32 checksum of the + dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise + it sets strm->adler to the adler32 checksum of all output produced + so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or + an error code as described below. At the end of the stream, inflate() + checks that its computed adler32 checksum is equal to that saved by the + compressor and returns Z_STREAM_END only if the checksum is correct. + + inflate() returns Z_OK if some progress has been made (more input processed + or more output produced), Z_STREAM_END if the end of the compressed data has + been reached and all uncompressed output has been produced, Z_NEED_DICT if a + preset dictionary is needed at this point, Z_DATA_ERROR if the input data was + corrupted (input stream not conforming to the zlib format or incorrect + adler32 checksum), Z_STREAM_ERROR if the stream structure was inconsistent + (for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not + enough memory, Z_BUF_ERROR if no progress is possible or if there was not + enough room in the output buffer when Z_FINISH is used. In the Z_DATA_ERROR + case, the application may then call inflateSync to look for a good + compression block. +} + + +function inflateSetDictionary(var z : z_stream; + dictionary : pBytef; {const array of byte} + dictLength : uInt) : int; + +{ + Initializes the decompression dictionary from the given uncompressed byte + sequence. This function must be called immediately after a call of inflate + if this call returned Z_NEED_DICT. The dictionary chosen by the compressor + can be determined from the Adler32 value returned by this call of + inflate. The compressor and decompressor must use exactly the same + dictionary (see deflateSetDictionary). + + inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a + parameter is invalid (such as NULL dictionary) or the stream state is + inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the + expected one (incorrect Adler32 value). inflateSetDictionary does not + perform any decompression: this will be done by subsequent calls of + inflate(). +} + +function inflateSync(var z : z_stream) : int; + +{ + Skips invalid compressed data until a full flush point (see above the + description of deflate with Z_FULL_FLUSH) can be found, or until all + available input is skipped. No output is provided. + + inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR + if no more input was provided, Z_DATA_ERROR if no flush point has been found, + or Z_STREAM_ERROR if the stream structure was inconsistent. In the success + case, the application may save the current current value of total_in which + indicates where valid compressed data was found. In the error case, the + application may repeatedly call inflateSync, providing more input each time, + until success or end of the input data. +} + + +function inflateSyncPoint(var z : z_stream) : int; + + +implementation + +uses + adler; + +function inflateReset(var z : z_stream) : int; +begin + if (z.state = Z_NULL) then + begin + inflateReset := Z_STREAM_ERROR; + exit; + end; + z.total_out := 0; + z.total_in := 0; + z.msg := ''; + if z.state^.nowrap then + z.state^.mode := BLOCKS + else + z.state^.mode := METHOD; + inflate_blocks_reset(z.state^.blocks^, z, Z_NULL); + {$IFDEF DEBUG} + Tracev('inflate: reset'); + {$ENDIF} + inflateReset := Z_OK; +end; + + +function inflateEnd(var z : z_stream) : int; +begin + if (z.state = Z_NULL) or not Assigned(z.zfree) then + begin + inflateEnd := Z_STREAM_ERROR; + exit; + end; + if (z.state^.blocks <> Z_NULL) then + inflate_blocks_free(z.state^.blocks, z); + ZFREE(z, z.state); + z.state := Z_NULL; + {$IFDEF DEBUG} + Tracev('inflate: end'); + {$ENDIF} + inflateEnd := Z_OK; +end; + + +function inflateInit2_(var z: z_stream; + w : int; + const version : string; + stream_size : int) : int; +begin + if (version = '') or (version[1] <> ZLIB_VERSION[1]) or + (stream_size <> sizeof(z_stream)) then + begin + inflateInit2_ := Z_VERSION_ERROR; + exit; + end; + { initialize state } + { SetLength(strm.msg, 255); } + z.msg := ''; + if not Assigned(z.zalloc) then + begin + {$IFDEF FPC} z.zalloc := @zcalloc; {$ELSE} + z.zalloc := zcalloc; + {$endif} + z.opaque := voidpf(0); + end; + if not Assigned(z.zfree) then + {$IFDEF FPC} z.zfree := @zcfree; {$ELSE} + z.zfree := zcfree; + {$ENDIF} + + z.state := pInternal_state( ZALLOC(z,1,sizeof(internal_state)) ); + if (z.state = Z_NULL) then + begin + inflateInit2_ := Z_MEM_ERROR; + exit; + end; + + z.state^.blocks := Z_NULL; + + { handle undocumented nowrap option (no zlib header or check) } + z.state^.nowrap := FALSE; + if (w < 0) then + begin + w := - w; + z.state^.nowrap := TRUE; + end; + + { set window size } + if (w < 8) or (w > 15) then + begin + inflateEnd(z); + inflateInit2_ := Z_STREAM_ERROR; + exit; + end; + z.state^.wbits := uInt(w); + + { create inflate_blocks state } + if z.state^.nowrap then + z.state^.blocks := inflate_blocks_new(z, NIL, uInt(1) shl w) + else + {$IFDEF FPC} + z.state^.blocks := inflate_blocks_new(z, @adler32, uInt(1) shl w); + {$ELSE} + z.state^.blocks := inflate_blocks_new(z, adler32, uInt(1) shl w); + {$ENDIF} + if (z.state^.blocks = Z_NULL) then + begin + inflateEnd(z); + inflateInit2_ := Z_MEM_ERROR; + exit; + end; + {$IFDEF DEBUG} + Tracev('inflate: allocated'); + {$ENDIF} + { reset state } + inflateReset(z); + inflateInit2_ := Z_OK; +end; + +function inflateInit2(var z: z_stream; windowBits : int) : int; +begin + inflateInit2 := inflateInit2_(z, windowBits, ZLIB_VERSION, sizeof(z_stream)); +end; + + +function inflateInit(var z : z_stream) : int; +{ inflateInit is a macro to allow checking the zlib version + and the compiler's view of z_stream: } +begin + inflateInit := inflateInit2_(z, DEF_WBITS, ZLIB_VERSION, sizeof(z_stream)); +end; + +function inflateInit_(z : z_streamp; + const version : string; + stream_size : int) : int; +begin + { initialize state } + if (z = Z_NULL) then + inflateInit_ := Z_STREAM_ERROR + else + inflateInit_ := inflateInit2_(z^, DEF_WBITS, version, stream_size); +end; + +function inflate(var z : z_stream; + f : int) : int; +var + r : int; + b : uInt; +begin + if (z.state = Z_NULL) or (z.next_in = Z_NULL) then + begin + inflate := Z_STREAM_ERROR; + exit; + end; + if f = Z_FINISH then + f := Z_BUF_ERROR + else + f := Z_OK; + r := Z_BUF_ERROR; + while True do + case (z.state^.mode) of + BLOCKS: + begin + r := inflate_blocks(z.state^.blocks^, z, r); + if (r = Z_DATA_ERROR) then + begin + z.state^.mode := BAD; + z.state^.sub.marker := 0; { can try inflateSync } + continue; { break C-switch } + end; + if (r = Z_OK) then + r := f; + if (r <> Z_STREAM_END) then + begin + inflate := r; + exit; + end; + r := f; + inflate_blocks_reset(z.state^.blocks^, z, @z.state^.sub.check.was); + if (z.state^.nowrap) then + begin + z.state^.mode := DONE; + continue; { break C-switch } + end; + z.state^.mode := CHECK4; { falltrough } + end; + CHECK4: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.check.need := uLong(z.next_in^) shl 24; + Inc(z.next_in); + + z.state^.mode := CHECK3; { falltrough } + end; + CHECK3: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16); + Inc(z.next_in); + + z.state^.mode := CHECK2; { falltrough } + end; + CHECK2: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8); + Inc(z.next_in); + + z.state^.mode := CHECK1; { falltrough } + end; + CHECK1: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) );} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) ); + Inc(z.next_in); + + + if (z.state^.sub.check.was <> z.state^.sub.check.need) then + begin + z.state^.mode := BAD; + z.msg := 'incorrect data check'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + {$IFDEF DEBUG} + Tracev('inflate: zlib check ok'); + {$ENDIF} + z.state^.mode := DONE; { falltrough } + end; + DONE: + begin + inflate := Z_STREAM_END; + exit; + end; + METHOD: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; {} + + {z.state^.sub.method := NEXTBYTE(z);} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.method := z.next_in^; + Inc(z.next_in); + + if ((z.state^.sub.method and $0f) <> Z_DEFLATED) then + begin + z.state^.mode := BAD; + z.msg := 'unknown compression method'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + if ((z.state^.sub.method shr 4) + 8 > z.state^.wbits) then + begin + z.state^.mode := BAD; + z.msg := 'invalid window size'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + z.state^.mode := FLAG; + { fall trough } + end; + FLAG: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; {} + {b := NEXTBYTE(z);} + Dec(z.avail_in); + Inc(z.total_in); + b := z.next_in^; + Inc(z.next_in); + + if (((z.state^.sub.method shl 8) + b) mod 31) <> 0 then {% mod ?} + begin + z.state^.mode := BAD; + z.msg := 'incorrect header check'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + {$IFDEF DEBUG} + Tracev('inflate: zlib header ok'); + {$ENDIF} + if ((b and PRESET_DICT) = 0) then + begin + z.state^.mode := BLOCKS; + continue; { break C-switch } + end; + z.state^.mode := DICT4; + { falltrough } + end; + DICT4: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.check.need := uLong(z.next_in^) shl 24; + Inc(z.next_in); + + z.state^.mode := DICT3; { falltrough } + end; + DICT3: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16); + Inc(z.next_in); + + z.state^.mode := DICT2; { falltrough } + end; + DICT2: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8); + Inc(z.next_in); + + z.state^.mode := DICT1; { falltrough } + end; + DICT1: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + { r := f; --- wird niemals benutzt } + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) );} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) ); + Inc(z.next_in); + + z.adler := z.state^.sub.check.need; + z.state^.mode := DICT0; + inflate := Z_NEED_DICT; + exit; + end; + DICT0: + begin + z.state^.mode := BAD; + z.msg := 'need dictionary'; + z.state^.sub.marker := 0; { can try inflateSync } + inflate := Z_STREAM_ERROR; + exit; + end; + BAD: + begin + inflate := Z_DATA_ERROR; + exit; + end; + else + begin + inflate := Z_STREAM_ERROR; + exit; + end; + end; +{$ifdef NEED_DUMMY_result} + result := Z_STREAM_ERROR; { Some dumb compilers complain without this } +{$endif} +end; + +function inflateSetDictionary(var z : z_stream; + dictionary : pBytef; {const array of byte} + dictLength : uInt) : int; +var + length : uInt; +begin + length := dictLength; + + if (z.state = Z_NULL) or (z.state^.mode <> DICT0) then + begin + inflateSetDictionary := Z_STREAM_ERROR; + exit; + end; + if (adler32(Long(1), dictionary, dictLength) <> z.adler) then + begin + inflateSetDictionary := Z_DATA_ERROR; + exit; + end; + z.adler := Long(1); + + if (length >= (uInt(1) shl z.state^.wbits)) then + begin + length := (1 shl z.state^.wbits)-1; + Inc( dictionary, dictLength - length); + end; + inflate_set_dictionary(z.state^.blocks^, dictionary^, length); + z.state^.mode := BLOCKS; + inflateSetDictionary := Z_OK; +end; + + +function inflateSync(var z : z_stream) : int; +const + mark : packed array[0..3] of byte = (0, 0, $ff, $ff); +var + n : uInt; { number of bytes to look at } + p : pBytef; { pointer to bytes } + m : uInt; { number of marker bytes found in a row } + r, w : uLong; { temporaries to save total_in and total_out } +begin + { set up } + if (z.state = Z_NULL) then + begin + inflateSync := Z_STREAM_ERROR; + exit; + end; + if (z.state^.mode <> BAD) then + begin + z.state^.mode := BAD; + z.state^.sub.marker := 0; + end; + n := z.avail_in; + if (n = 0) then + begin + inflateSync := Z_BUF_ERROR; + exit; + end; + p := z.next_in; + m := z.state^.sub.marker; + + { search } + while (n <> 0) and (m < 4) do + begin + if (p^ = mark[m]) then + Inc(m) + else + if (p^ <> 0) then + m := 0 + else + m := 4 - m; + Inc(p); + Dec(n); + end; + + { restore } + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + z.avail_in := n; + z.state^.sub.marker := m; + + + { return no joy or set up to restart on a new block } + if (m <> 4) then + begin + inflateSync := Z_DATA_ERROR; + exit; + end; + r := z.total_in; + w := z.total_out; + inflateReset(z); + z.total_in := r; + z.total_out := w; + z.state^.mode := BLOCKS; + inflateSync := Z_OK; +end; + + +{ + returns true if inflate is currently at the end of a block generated + by Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP + implementation to provide an additional safety check. PPP uses Z_SYNC_FLUSH + but removes the length bytes of the resulting empty stored block. When + decompressing, PPP checks that at the end of input packet, inflate is + waiting for these length bytes. +} + +function inflateSyncPoint(var z : z_stream) : int; +begin + if (z.state = Z_NULL) or (z.state^.blocks = Z_NULL) then + begin + inflateSyncPoint := Z_STREAM_ERROR; + exit; + end; + inflateSyncPoint := inflate_blocks_sync_point(z.state^.blocks^); +end; + +end. diff --git a/niftiview7/gzio/Zdeflate.pas b/niftiview7/gzio/Zdeflate.pas new file mode 100755 index 0000000..34fb8ab --- /dev/null +++ b/niftiview7/gzio/Zdeflate.pas @@ -0,0 +1,2133 @@ +Unit zDeflate; + +{ Orginal: deflate.h -- internal compression state + deflate.c -- compress data using the deflation algorithm + Copyright (C) 1995-1996 Jean-loup Gailly. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + + +{ ALGORITHM + + The "deflation" process depends on being able to identify portions + of the input text which are identical to earlier input (within a + sliding window trailing behind the input currently being processed). + + The most straightforward technique turns out to be the fastest for + most input files: try all possible matches and select the longest. + The key feature of this algorithm is that insertions into the string + dictionary are very simple and thus fast, and deletions are avoided + completely. Insertions are performed at each input character, whereas + string matches are performed only when the previous match ends. So it + is preferable to spend more time in matches to allow very fast string + insertions and avoid deletions. The matching algorithm for small + strings is inspired from that of Rabin & Karp. A brute force approach + is used to find longer strings when a small match has been found. + A similar algorithm is used in comic (by Jan-Mark Wams) and freeze + (by Leonid Broukhis). + A previous version of this file used a more sophisticated algorithm + (by Fiala and Greene) which is guaranteed to run in linear amortized + time, but has a larger average cost, uses more memory and is patented. + However the F&G algorithm may be faster for some highly redundant + files if the parameter max_chain_length (described below) is too large. + + ACKNOWLEDGEMENTS + + The idea of lazy evaluation of matches is due to Jan-Mark Wams, and + I found it in 'freeze' written by Leonid Broukhis. + Thanks to many people for bug reports and testing. + + REFERENCES + + Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". + Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc + + A description of the Rabin and Karp algorithm is given in the book + "Algorithms" by R. Sedgewick, Addison-Wesley, p252. + + Fiala,E.R., and Greene,D.H. + Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595} + +{ $Id: deflate.c,v 1.14 1996/07/02 12:40:55 me Exp $ } + +interface + +{$I zconf.inc} + +uses + zutil, zlib; + + +function deflateInit_(strm : z_streamp; + level : int; + const version : string; + stream_size : int) : int; + + +function deflateInit (var strm : z_stream; level : int) : int; + +{ Initializes the internal stream state for compression. The fields + zalloc, zfree and opaque must be initialized before by the caller. + If zalloc and zfree are set to Z_NULL, deflateInit updates them to + use default allocation functions. + + The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9: + 1 gives best speed, 9 gives best compression, 0 gives no compression at + all (the input data is simply copied a block at a time). + Z_DEFAULT_COMPRESSION requests a default compromise between speed and + compression (currently equivalent to level 6). + + deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_STREAM_ERROR if level is not a valid compression level, + Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible + with the version assumed by the caller (ZLIB_VERSION). + msg is set to null if there is no error message. deflateInit does not + perform any compression: this will be done by deflate(). } + + +{EXPORT} +function deflate (var strm : z_stream; flush : int) : int; + +{ Performs one or both of the following actions: + + - Compress more input starting at next_in and update next_in and avail_in + accordingly. If not all input can be processed (because there is not + enough room in the output buffer), next_in and avail_in are updated and + processing will resume at this point for the next call of deflate(). + + - Provide more output starting at next_out and update next_out and avail_out + accordingly. This action is forced if the parameter flush is non zero. + Forcing flush frequently degrades the compression ratio, so this parameter + should be set only when necessary (in interactive applications). + Some output may be provided even if flush is not set. + + Before the call of deflate(), the application should ensure that at least + one of the actions is possible, by providing more input and/or consuming + more output, and updating avail_in or avail_out accordingly; avail_out + should never be zero before the call. The application can consume the + compressed output when it wants, for example when the output buffer is full + (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK + and with zero avail_out, it must be called again after making room in the + output buffer because there might be more output pending. + + If the parameter flush is set to Z_PARTIAL_FLUSH, the current compression + block is terminated and flushed to the output buffer so that the + decompressor can get all input data available so far. For method 9, a future + variant on method 8, the current block will be flushed but not terminated. + Z_SYNC_FLUSH has the same effect as partial flush except that the compressed + output is byte aligned (the compressor can clear its internal bit buffer) + and the current block is always terminated; this can be useful if the + compressor has to be restarted from scratch after an interruption (in which + case the internal state of the compressor may be lost). + If flush is set to Z_FULL_FLUSH, the compression block is terminated, a + special marker is output and the compression dictionary is discarded; this + is useful to allow the decompressor to synchronize if one compressed block + has been damaged (see inflateSync below). Flushing degrades compression and + so should be used only when necessary. Using Z_FULL_FLUSH too often can + seriously degrade the compression. If deflate returns with avail_out == 0, + this function must be called again with the same value of the flush + parameter and more output space (updated avail_out), until the flush is + complete (deflate returns with non-zero avail_out). + + If the parameter flush is set to Z_FINISH, all pending input is processed, + all pending output is flushed and deflate returns with Z_STREAM_END if there + was enough output space; if deflate returns with Z_OK, this function must be + called again with Z_FINISH and more output space (updated avail_out) but no + more input data, until it returns with Z_STREAM_END or an error. After + deflate has returned Z_STREAM_END, the only possible operations on the + stream are deflateReset or deflateEnd. + + Z_FINISH can be used immediately after deflateInit if all the compression + is to be done in a single step. In this case, avail_out must be at least + 0.1% larger than avail_in plus 12 bytes. If deflate does not return + Z_STREAM_END, then it must be called again as described above. + + deflate() may update data_type if it can make a good guess about + the input data type (Z_ASCII or Z_BINARY). In doubt, the data is considered + binary. This field is only for information purposes and does not affect + the compression algorithm in any manner. + + deflate() returns Z_OK if some progress has been made (more input + processed or more output produced), Z_STREAM_END if all input has been + consumed and all output has been produced (only when flush is set to + Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example + if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible. } + + +function deflateEnd (var strm : z_stream) : int; + +{ All dynamically allocated data structures for this stream are freed. + This function discards any unprocessed input and does not flush any + pending output. + + deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the + stream state was inconsistent, Z_DATA_ERROR if the stream was freed + prematurely (some input or output was discarded). In the error case, + msg may be set but then points to a static string (which must not be + deallocated). } + + + + + { Advanced functions } + +{ The following functions are needed only in some special applications. } + + +{EXPORT} +function deflateInit2 (var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int) : int; + +{ This is another version of deflateInit with more compression options. The + fields next_in, zalloc, zfree and opaque must be initialized before by + the caller. + + The method parameter is the compression method. It must be Z_DEFLATED in + this version of the library. (Method 9 will allow a 64K history buffer and + partial block flushes.) + + The windowBits parameter is the base two logarithm of the window size + (the size of the history buffer). It should be in the range 8..15 for this + version of the library (the value 16 will be allowed for method 9). Larger + values of this parameter result in better compression at the expense of + memory usage. The default value is 15 if deflateInit is used instead. + + The memLevel parameter specifies how much memory should be allocated + for the internal compression state. memLevel=1 uses minimum memory but + is slow and reduces compression ratio; memLevel=9 uses maximum memory + for optimal speed. The default value is 8. See zconf.h for total memory + usage as a function of windowBits and memLevel. + + The strategy parameter is used to tune the compression algorithm. Use the + value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a + filter (or predictor), or Z_HUFFMAN_ONLY to force Huffman encoding only (no + string match). Filtered data consists mostly of small values with a + somewhat random distribution. In this case, the compression algorithm is + tuned to compress them better. The effect of Z_FILTERED is to force more + Huffman coding and less string matching; it is somewhat intermediate + between Z_DEFAULT and Z_HUFFMAN_ONLY. The strategy parameter only affects + the compression ratio but not the correctness of the compressed output even + if it is not set appropriately. + + If next_in is not null, the library will use this buffer to hold also + some history information; the buffer must either hold the entire input + data, or have at least 1<<(windowBits+1) bytes and be writable. If next_in + is null, the library will allocate its own history buffer (and leave next_in + null). next_out need not be provided here but must be provided by the + application for the next call of deflate(). + + If the history buffer is provided by the application, next_in must + must never be changed by the application since the compressor maintains + information inside this buffer from call to call; the application + must provide more input only by increasing avail_in. next_in is always + reset by the library in this case. + + deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was + not enough memory, Z_STREAM_ERROR if a parameter is invalid (such as + an invalid method). msg is set to null if there is no error message. + deflateInit2 does not perform any compression: this will be done by + deflate(). } + + +{EXPORT} +function deflateSetDictionary (var strm : z_stream; + dictionary : pBytef; {const bytes} + dictLength : uint) : int; + +{ Initializes the compression dictionary (history buffer) from the given + byte sequence without producing any compressed output. This function must + be called immediately after deflateInit or deflateInit2, before any call + of deflate. The compressor and decompressor must use exactly the same + dictionary (see inflateSetDictionary). + The dictionary should consist of strings (byte sequences) that are likely + to be encountered later in the data to be compressed, with the most commonly + used strings preferably put towards the end of the dictionary. Using a + dictionary is most useful when the data to be compressed is short and + can be predicted with good accuracy; the data can then be compressed better + than with the default empty dictionary. In this version of the library, + only the last 32K bytes of the dictionary are used. + Upon return of this function, strm->adler is set to the Adler32 value + of the dictionary; the decompressor may later use this value to determine + which dictionary has been used by the compressor. (The Adler32 value + applies to the whole dictionary even if only a subset of the dictionary is + actually used by the compressor.) + + deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a + parameter is invalid (such as NULL dictionary) or the stream state + is inconsistent (for example if deflate has already been called for this + stream). deflateSetDictionary does not perform any compression: this will + be done by deflate(). } + +{EXPORT} +function deflateCopy (dest : z_streamp; + source : z_streamp) : int; + +{ Sets the destination stream as a complete copy of the source stream. If + the source stream is using an application-supplied history buffer, a new + buffer is allocated for the destination stream. The compressed output + buffer is always application-supplied. It's the responsibility of the + application to provide the correct values of next_out and avail_out for the + next call of deflate. + + This function can be useful when several compression strategies will be + tried, for example when there are several ways of pre-processing the input + data with a filter. The streams that will be discarded should then be freed + by calling deflateEnd. Note that deflateCopy duplicates the internal + compression state which can be quite large, so this strategy is slow and + can consume lots of memory. + + deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_STREAM_ERROR if the source stream state was inconsistent + (such as zalloc being NULL). msg is left unchanged in both source and + destination. } + +{EXPORT} +function deflateReset (var strm : z_stream) : int; + +{ This function is equivalent to deflateEnd followed by deflateInit, + but does not free and reallocate all the internal compression state. + The stream will keep the same compression level and any other attributes + that may have been set by deflateInit2. + + deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source + stream state was inconsistent (such as zalloc or state being NIL). } + + +{EXPORT} +function deflateParams (var strm : z_stream; level : int; strategy : int) : int; + +{ Dynamically update the compression level and compression strategy. + This can be used to switch between compression and straight copy of + the input data, or to switch to a different kind of input data requiring + a different strategy. If the compression level is changed, the input + available so far is compressed with the old level (and may be flushed); + the new level will take effect only at the next call of deflate(). + + Before the call of deflateParams, the stream state must be set as for + a call of deflate(), since the currently available input may have to + be compressed and flushed. In particular, strm->avail_out must be non-zero. + + deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source + stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR + if strm->avail_out was zero. } + + +const + deflate_copyright : string = ' deflate 1.1.2 Copyright 1995-1998 Jean-loup Gailly '; + +{ If you use the zlib library in a product, an acknowledgment is welcome + in the documentation of your product. If for some reason you cannot + include such an acknowledgment, I would appreciate that you keep this + copyright string in the executable of your product. } + +implementation + +uses + trees, adler; + +{ =========================================================================== + Function prototypes. } + +type + block_state = ( + need_more, { block not completed, need more input or more output } + block_done, { block flush performed } + finish_started, { finish started, need only more output at next deflate } + finish_done); { finish done, accept no more input or output } + +{ Compression function. Returns the block state after the call. } +type + compress_func = function(var s : deflate_state; flush : int) : block_state; + +{local} +procedure fill_window(var s : deflate_state); forward; +{local} +function deflate_stored(var s : deflate_state; flush : int) : block_state; far; forward; +{local} +function deflate_fast(var s : deflate_state; flush : int) : block_state; far; forward; +{local} +function deflate_slow(var s : deflate_state; flush : int) : block_state; far; forward; +{local} +procedure lm_init(var s : deflate_state); forward; + +{local} +procedure putShortMSB(var s : deflate_state; b : uInt); forward; +{local} +procedure flush_pending (var strm : z_stream); forward; +{local} +function read_buf(strm : z_streamp; + buf : pBytef; + size : unsigned) : int; forward; +{$ifdef ASMV} +procedure match_init; { asm code initialization } +function longest_match(var deflate_state; cur_match : IPos) : uInt; forward; +{$else} +{local} +function longest_match(var s : deflate_state; cur_match : IPos) : uInt; + forward; +{$endif} + +{$ifdef DEBUG} +{local} +procedure check_match(var s : deflate_state; + start, match : IPos; + length : int); forward; +{$endif} + +{ ========================================================================== + local data } + +const + ZNIL = 0; +{ Tail of hash chains } + +const + TOO_FAR = 4096; +{ Matches of length 3 are discarded if their distance exceeds TOO_FAR } + +const + MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1); +{ Minimum amount of lookahead, except at the end of the input file. + See deflate.c for comments about the MIN_MATCH+1. } + +{macro MAX_DIST(var s : deflate_state) : uInt; +begin + MAX_DIST := (s.w_size - MIN_LOOKAHEAD); +end; + In order to simplify the code, particularly on 16 bit machines, match + distances are limited to MAX_DIST instead of WSIZE. } + + +{ Values for max_lazy_match, good_match and max_chain_length, depending on + the desired pack level (0..9). The values given below have been tuned to + exclude worst case performance for pathological files. Better values may be + found for specific files. } + +type + config = record + good_length : ush; { reduce lazy search above this match length } + max_lazy : ush; { do not perform lazy search above this match length } + nice_length : ush; { quit search above this match length } + max_chain : ush; + func : compress_func; + end; + +{local} +const + configuration_table : array[0..10-1] of config = ( +{ good lazy nice chain } +{0} (good_length:0; max_lazy:0; nice_length:0; max_chain:0; func:deflate_stored), { store only } +{1} (good_length:4; max_lazy:4; nice_length:8; max_chain:4; func:deflate_fast), { maximum speed, no lazy matches } +{2} (good_length:4; max_lazy:5; nice_length:16; max_chain:8; func:deflate_fast), +{3} (good_length:4; max_lazy:6; nice_length:32; max_chain:32; func:deflate_fast), + +{4} (good_length:4; max_lazy:4; nice_length:16; max_chain:16; func:deflate_slow), { lazy matches } +{5} (good_length:8; max_lazy:16; nice_length:32; max_chain:32; func:deflate_slow), +{6} (good_length:8; max_lazy:16; nice_length:128; max_chain:128; func:deflate_slow), +{7} (good_length:8; max_lazy:32; nice_length:128; max_chain:256; func:deflate_slow), +{8} (good_length:32; max_lazy:128; nice_length:258; max_chain:1024; func:deflate_slow), +{9} (good_length:32; max_lazy:258; nice_length:258; max_chain:4096; func:deflate_slow)); { maximum compression } + +{ Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4 + For deflate_fast() (levels <= 3) good is ignored and lazy has a different + meaning. } + +const + EQUAL = 0; +{ result of memcmp for equal strings } + +{ ========================================================================== + Update a hash value with the given input byte + IN assertion: all calls to to UPDATE_HASH are made with consecutive + input characters, so that a running hash key can be computed from the + previous key instead of complete recalculation each time. + +macro UPDATE_HASH(s,h,c) + h := (( (h) shl s^.hash_shift) xor (c)) and s^.hash_mask; +} + +{ =========================================================================== + Insert string str in the dictionary and set match_head to the previous head + of the hash chain (the most recent string with same hash key). Return + the previous length of the hash chain. + If this file is compiled with -DFASTEST, the compression level is forced + to 1, and no hash chains are maintained. + IN assertion: all calls to to INSERT_STRING are made with consecutive + input characters and the first MIN_MATCH bytes of str are valid + (except for the last MIN_MATCH-1 bytes of the input file). } + +procedure INSERT_STRING(var s : deflate_state; + str : uInt; + var match_head : IPos); +begin +{$ifdef FASTEST} + {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])} + s.ins_h := ((s.ins_h shl s.hash_shift) xor + (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask; + match_head := s.head[s.ins_h] + s.head[s.ins_h] := Pos(str); +{$else} + {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])} + s.ins_h := ((s.ins_h shl s.hash_shift) xor + (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask; + + match_head := s.head^[s.ins_h]; + s.prev^[(str) and s.w_mask] := match_head; + s.head^[s.ins_h] := Pos(str); +{$endif} +end; + +{ ========================================================================= + Initialize the hash table (avoiding 64K overflow for 16 bit systems). + prev[] will be initialized on the fly. + +macro CLEAR_HASH(s) + s^.head[s^.hash_size-1] := ZNIL; + zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0])); +} + +{ ======================================================================== } + +function deflateInit2_(var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int; + const version : string; + stream_size : int) : int; +var + s : deflate_state_ptr; + noheader : int; + + overlay : pushfArray; + { We overlay pending_buf and d_buf+l_buf. This works since the average + output size for (length,distance) codes is <= 24 bits. } +begin + noheader := 0; + if (version = '') or (version[1] <> ZLIB_VERSION[1]) or + (stream_size <> sizeof(z_stream)) then + begin + deflateInit2_ := Z_VERSION_ERROR; + exit; + end; + { + if (strm = Z_NULL) then + begin + deflateInit2_ := Z_STREAM_ERROR; + exit; + end; + } + { SetLength(strm.msg, 255); } + strm.msg := ''; + if not Assigned(strm.zalloc) then + begin + {$IFDEF FPC} strm.zalloc := @zcalloc; {$ELSE} + strm.zalloc := zcalloc; + {$ENDIF} + strm.opaque := voidpf(0); + end; + if not Assigned(strm.zfree) then + {$IFDEF FPC} strm.zfree := @zcfree; {$ELSE} + strm.zfree := zcfree; + {$ENDIF} + + if (level = Z_DEFAULT_COMPRESSION) then + level := 6; +{$ifdef FASTEST} + level := 1; +{$endif} + + if (windowBits < 0) then { undocumented feature: suppress zlib header } + begin + noheader := 1; + windowBits := -windowBits; + end; + if (memLevel < 1) or (memLevel > MAX_MEM_LEVEL) or (method <> Z_DEFLATED) + or (windowBits < 8) or (windowBits > 15) or (level < 0) + or (level > 9) or (strategy < 0) or (strategy > Z_HUFFMAN_ONLY) then + begin + deflateInit2_ := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr (ZALLOC(strm, 1, sizeof(deflate_state))); + if (s = Z_NULL) then + begin + deflateInit2_ := Z_MEM_ERROR; + exit; + end; + strm.state := pInternal_state(s); + s^.strm := @strm; + + s^.noheader := noheader; + s^.w_bits := windowBits; + s^.w_size := 1 shl s^.w_bits; + s^.w_mask := s^.w_size - 1; + + s^.hash_bits := memLevel + 7; + s^.hash_size := 1 shl s^.hash_bits; + s^.hash_mask := s^.hash_size - 1; + s^.hash_shift := ((s^.hash_bits+MIN_MATCH-1) div MIN_MATCH); + + s^.window := pzByteArray (ZALLOC(strm, s^.w_size, 2*sizeof(Byte))); + s^.prev := pzPosfArray (ZALLOC(strm, s^.w_size, sizeof(Pos))); + s^.head := pzPosfArray (ZALLOC(strm, s^.hash_size, sizeof(Pos))); + + s^.lit_bufsize := 1 shl (memLevel + 6); { 16K elements by default } + + overlay := pushfArray (ZALLOC(strm, s^.lit_bufsize, sizeof(ush)+2)); + s^.pending_buf := pzByteArray (overlay); + s^.pending_buf_size := ulg(s^.lit_bufsize) * (sizeof(ush)+Long(2)); + + if (s^.window = Z_NULL) or (s^.prev = Z_NULL) or (s^.head = Z_NULL) + or (s^.pending_buf = Z_NULL) then + begin + {ERR_MSG(Z_MEM_ERROR);} + strm.msg := z_errmsg[z_errbase-Z_MEM_ERROR]; + deflateEnd (strm); + deflateInit2_ := Z_MEM_ERROR; + exit; + end; + s^.d_buf := pushfArray( @overlay^[s^.lit_bufsize div sizeof(ush)] ); + s^.l_buf := puchfArray( @s^.pending_buf^[(1+sizeof(ush))*s^.lit_bufsize] ); + + s^.level := level; + s^.strategy := strategy; + s^.method := Byte(method); + + deflateInit2_ := deflateReset(strm); +end; + +{ ========================================================================= } + +function deflateInit2(var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int) : int; +{ a macro } +begin + deflateInit2 := deflateInit2_(strm, level, method, windowBits, + memLevel, strategy, ZLIB_VERSION, sizeof(z_stream)); +end; + +{ ========================================================================= } + +function deflateInit_(strm : z_streamp; + level : int; + const version : string; + stream_size : int) : int; +begin + if (strm = Z_NULL) then + deflateInit_ := Z_STREAM_ERROR + else + deflateInit_ := deflateInit2_(strm^, level, Z_DEFLATED, MAX_WBITS, + DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, version, stream_size); + { To do: ignore strm^.next_in if we use it as window } +end; + +{ ========================================================================= } + +function deflateInit(var strm : z_stream; level : int) : int; +{ deflateInit is a macro to allow checking the zlib version + and the compiler's view of z_stream: } +begin + deflateInit := deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS, + DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(z_stream)); +end; + +{ ======================================================================== } +function deflateSetDictionary (var strm : z_stream; + dictionary : pBytef; + dictLength : uInt) : int; +var + s : deflate_state_ptr; + length : uInt; + n : uInt; + hash_head : IPos; +var + MAX_DIST : uInt; {macro} +begin + length := dictLength; + hash_head := 0; + + if {(@strm = Z_NULL) or} + (strm.state = Z_NULL) or (dictionary = Z_NULL) + or (deflate_state_ptr(strm.state)^.status <> INIT_STATE) then + begin + deflateSetDictionary := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + strm.adler := adler32(strm.adler, dictionary, dictLength); + + if (length < MIN_MATCH) then + begin + deflateSetDictionary := Z_OK; + exit; + end; + MAX_DIST := (s^.w_size - MIN_LOOKAHEAD); + if (length > MAX_DIST) then + begin + length := MAX_DIST; +{$ifndef USE_DICT_HEAD} + Inc(dictionary, dictLength - length); { use the tail of the dictionary } +{$endif} + end; + + zmemcpy( pBytef(s^.window), dictionary, length); + s^.strstart := length; + s^.block_start := long(length); + + { Insert all strings in the hash table (except for the last two bytes). + s^.lookahead stays null, so s^.ins_h will be recomputed at the next + call of fill_window. } + + s^.ins_h := s^.window^[0]; + {UPDATE_HASH(s, s^.ins_h, s^.window[1]);} + s^.ins_h := ((s^.ins_h shl s^.hash_shift) xor (s^.window^[1])) + and s^.hash_mask; + + for n := 0 to length - MIN_MATCH do + begin + INSERT_STRING(s^, n, hash_head); + end; + {if (hash_head <> 0) then + hash_head := 0; - to make compiler happy } + deflateSetDictionary := Z_OK; +end; + +{ ======================================================================== } +function deflateReset (var strm : z_stream) : int; +var + s : deflate_state_ptr; +begin + if {(@strm = Z_NULL) or} + (strm.state = Z_NULL) + or (not Assigned(strm.zalloc)) or (not Assigned(strm.zfree)) then + begin + deflateReset := Z_STREAM_ERROR; + exit; + end; + + strm.total_out := 0; + strm.total_in := 0; + strm.msg := ''; { use zfree if we ever allocate msg dynamically } + strm.data_type := Z_UNKNOWN; + + s := deflate_state_ptr(strm.state); + s^.pending := 0; + s^.pending_out := pBytef(s^.pending_buf); + + if (s^.noheader < 0) then + begin + s^.noheader := 0; { was set to -1 by deflate(..., Z_FINISH); } + end; + if s^.noheader <> 0 then + s^.status := BUSY_STATE + else + s^.status := INIT_STATE; + strm.adler := 1; + s^.last_flush := Z_NO_FLUSH; + + _tr_init(s^); + lm_init(s^); + + deflateReset := Z_OK; +end; + +{ ======================================================================== } +function deflateParams(var strm : z_stream; + level : int; + strategy : int) : int; +var + s : deflate_state_ptr; + func : compress_func; + err : int; +begin + err := Z_OK; + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then + begin + deflateParams := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + + if (level = Z_DEFAULT_COMPRESSION) then + begin + level := 6; + end; + if (level < 0) or (level > 9) or (strategy < 0) + or (strategy > Z_HUFFMAN_ONLY) then + begin + deflateParams := Z_STREAM_ERROR; + exit; + end; + func := configuration_table[s^.level].func; + + if (@func <> @configuration_table[level].func) + and (strm.total_in <> 0) then + begin + { Flush the last buffer: } + err := deflate(strm, Z_PARTIAL_FLUSH); + end; + if (s^.level <> level) then + begin + s^.level := level; + s^.max_lazy_match := configuration_table[level].max_lazy; + s^.good_match := configuration_table[level].good_length; + s^.nice_match := configuration_table[level].nice_length; + s^.max_chain_length := configuration_table[level].max_chain; + end; + s^.strategy := strategy; + deflateParams := err; +end; + +{ ========================================================================= + Put a short in the pending buffer. The 16-bit value is put in MSB order. + IN assertion: the stream state is correct and there is enough room in + pending_buf. } + +{local} +procedure putShortMSB (var s : deflate_state; b : uInt); +begin + s.pending_buf^[s.pending] := Byte(b shr 8); + Inc(s.pending); + s.pending_buf^[s.pending] := Byte(b and $ff); + Inc(s.pending); +end; + +{ ========================================================================= + Flush as much pending output as possible. All deflate() output goes + through this function so some applications may wish to modify it + to avoid allocating a large strm^.next_out buffer and copying into it. + (See also read_buf()). } + +{local} +procedure flush_pending(var strm : z_stream); +var + len : unsigned; + s : deflate_state_ptr; +begin + s := deflate_state_ptr(strm.state); + len := s^.pending; + + if (len > strm.avail_out) then + len := strm.avail_out; + if (len = 0) then + exit; + + zmemcpy(strm.next_out, s^.pending_out, len); + Inc(strm.next_out, len); + Inc(s^.pending_out, len); + Inc(strm.total_out, len); + Dec(strm.avail_out, len); + Dec(s^.pending, len); + if (s^.pending = 0) then + begin + s^.pending_out := pBytef(s^.pending_buf); + end; +end; + +{ ========================================================================= } +function deflate (var strm : z_stream; flush : int) : int; +var + old_flush : int; { value of flush param for previous deflate call } + s : deflate_state_ptr; +var + header : uInt; + level_flags : uInt; +var + bstate : block_state; +begin + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) + or (flush > Z_FINISH) or (flush < 0) then + begin + deflate := Z_STREAM_ERROR; + exit; + end; + s := deflate_state_ptr(strm.state); + + if (strm.next_out = Z_NULL) or + ((strm.next_in = Z_NULL) and (strm.avail_in <> 0)) or + ((s^.status = FINISH_STATE) and (flush <> Z_FINISH)) then + begin + {ERR_RETURN(strm^, Z_STREAM_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_STREAM_ERROR]; + deflate := Z_STREAM_ERROR; + exit; + end; + if (strm.avail_out = 0) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + s^.strm := @strm; { just in case } + old_flush := s^.last_flush; + s^.last_flush := flush; + + { Write the zlib header } + if (s^.status = INIT_STATE) then + begin + + header := (Z_DEFLATED + ((s^.w_bits-8) shl 4)) shl 8; + level_flags := (s^.level-1) shr 1; + + if (level_flags > 3) then + level_flags := 3; + header := header or (level_flags shl 6); + if (s^.strstart <> 0) then + header := header or PRESET_DICT; + Inc(header, 31 - (header mod 31)); + + s^.status := BUSY_STATE; + putShortMSB(s^, header); + + { Save the adler32 of the preset dictionary: } + if (s^.strstart <> 0) then + begin + putShortMSB(s^, uInt(strm.adler shr 16)); + putShortMSB(s^, uInt(strm.adler and $ffff)); + end; + strm.adler := long(1); + end; + + { Flush as much pending output as possible } + if (s^.pending <> 0) then + begin + flush_pending(strm); + if (strm.avail_out = 0) then + begin + { Since avail_out is 0, deflate will be called again with + more output space, but possibly with both pending and + avail_in equal to zero. There won't be anything to do, + but this is not an error situation so make sure we + return OK instead of BUF_ERROR at next call of deflate: } + + s^.last_flush := -1; + deflate := Z_OK; + exit; + end; + + { Make sure there is something to do and avoid duplicate consecutive + flushes. For repeated and useless calls with Z_FINISH, we keep + returning Z_STREAM_END instead of Z_BUFF_ERROR. } + + end + else + if (strm.avail_in = 0) and (flush <= old_flush) + and (flush <> Z_FINISH) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + { User must not provide more input after the first FINISH: } + if (s^.status = FINISH_STATE) and (strm.avail_in <> 0) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + { Start a new block or continue the current one. } + if (strm.avail_in <> 0) or (s^.lookahead <> 0) + or ((flush <> Z_NO_FLUSH) and (s^.status <> FINISH_STATE)) then + begin + bstate := configuration_table[s^.level].func(s^, flush); + + if (bstate = finish_started) or (bstate = finish_done) then + s^.status := FINISH_STATE; + + if (bstate = need_more) or (bstate = finish_started) then + begin + if (strm.avail_out = 0) then + s^.last_flush := -1; { avoid BUF_ERROR next call, see above } + + deflate := Z_OK; + exit; + { If flush != Z_NO_FLUSH && avail_out == 0, the next call + of deflate should use the same flush parameter to make sure + that the flush is complete. So we don't have to output an + empty block here, this will be done at next call. This also + ensures that for a very small output buffer, we emit at most + one empty block. } + end; + if (bstate = block_done) then + begin + if (flush = Z_PARTIAL_FLUSH) then + _tr_align(s^) + else + begin { FULL_FLUSH or SYNC_FLUSH } + _tr_stored_block(s^, pcharf(NIL), Long(0), FALSE); + { For a full flush, this empty block will be recognized + as a special marker by inflate_sync(). } + + if (flush = Z_FULL_FLUSH) then + begin + {macro CLEAR_HASH(s);} { forget history } + s^.head^[s^.hash_size-1] := ZNIL; + zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0])); + end; + end; + + flush_pending(strm); + if (strm.avail_out = 0) then + begin + s^.last_flush := -1; { avoid BUF_ERROR at next call, see above } + deflate := Z_OK; + exit; + end; + + end; + end; + {$IFDEF DEBUG} + Assert(strm.avail_out > 0, 'bug2'); + {$ENDIF} + if (flush <> Z_FINISH) then + begin + deflate := Z_OK; + exit; + end; + + if (s^.noheader <> 0) then + begin + deflate := Z_STREAM_END; + exit; + end; + + { Write the zlib trailer (adler32) } + putShortMSB(s^, uInt(strm.adler shr 16)); + putShortMSB(s^, uInt(strm.adler and $ffff)); + flush_pending(strm); + { If avail_out is zero, the application will call deflate again + to flush the rest. } + + s^.noheader := -1; { write the trailer only once! } + if s^.pending <> 0 then + deflate := Z_OK + else + deflate := Z_STREAM_END; +end; + +{ ========================================================================= } +function deflateEnd (var strm : z_stream) : int; +var + status : int; + s : deflate_state_ptr; +begin + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then + begin + deflateEnd := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + status := s^.status; + if (status <> INIT_STATE) and (status <> BUSY_STATE) and + (status <> FINISH_STATE) then + begin + deflateEnd := Z_STREAM_ERROR; + exit; + end; + + { Deallocate in reverse order of allocations: } + TRY_FREE(strm, s^.pending_buf); + TRY_FREE(strm, s^.head); + TRY_FREE(strm, s^.prev); + TRY_FREE(strm, s^.window); + + ZFREE(strm, s); + strm.state := Z_NULL; + + if status = BUSY_STATE then + deflateEnd := Z_DATA_ERROR + else + deflateEnd := Z_OK; +end; + +{ ========================================================================= + Copy the source state to the destination state. + To simplify the source, this is not supported for 16-bit MSDOS (which + doesn't have enough memory anyway to duplicate compression states). } + + +{ ========================================================================= } +function deflateCopy (dest, source : z_streamp) : int; +{$ifndef MAXSEG_64K} +var + ds : deflate_state_ptr; + ss : deflate_state_ptr; + overlay : pushfArray; +{$endif} +begin +{$ifdef MAXSEG_64K} + deflateCopy := Z_STREAM_ERROR; + exit; +{$else} + + if (source = Z_NULL) or (dest = Z_NULL) or (source^.state = Z_NULL) then + begin + deflateCopy := Z_STREAM_ERROR; + exit; + end; + ss := deflate_state_ptr(source^.state); + dest^ := source^; + + ds := deflate_state_ptr( ZALLOC(dest^, 1, sizeof(deflate_state)) ); + if (ds = Z_NULL) then + begin + deflateCopy := Z_MEM_ERROR; + exit; + end; + dest^.state := pInternal_state(ds); + ds^ := ss^; + ds^.strm := dest; + + ds^.window := pzByteArray ( ZALLOC(dest^, ds^.w_size, 2*sizeof(Byte)) ); + ds^.prev := pzPosfArray ( ZALLOC(dest^, ds^.w_size, sizeof(Pos)) ); + ds^.head := pzPosfArray ( ZALLOC(dest^, ds^.hash_size, sizeof(Pos)) ); + overlay := pushfArray ( ZALLOC(dest^, ds^.lit_bufsize, sizeof(ush)+2) ); + ds^.pending_buf := pzByteArray ( overlay ); + + if (ds^.window = Z_NULL) or (ds^.prev = Z_NULL) or (ds^.head = Z_NULL) + or (ds^.pending_buf = Z_NULL) then + begin + deflateEnd (dest^); + deflateCopy := Z_MEM_ERROR; + exit; + end; + { following zmemcpy do not work for 16-bit MSDOS } + zmemcpy(pBytef(ds^.window), pBytef(ss^.window), ds^.w_size * 2 * sizeof(Byte)); + zmemcpy(pBytef(ds^.prev), pBytef(ss^.prev), ds^.w_size * sizeof(Pos)); + zmemcpy(pBytef(ds^.head), pBytef(ss^.head), ds^.hash_size * sizeof(Pos)); + zmemcpy(pBytef(ds^.pending_buf), pBytef(ss^.pending_buf), uInt(ds^.pending_buf_size)); + + ds^.pending_out := @ds^.pending_buf^[ptr2int(ss^.pending_out) - ptr2int(ss^.pending_buf)]; + ds^.d_buf := pushfArray (@overlay^[ds^.lit_bufsize div sizeof(ush)] ); + ds^.l_buf := puchfArray (@ds^.pending_buf^[(1+sizeof(ush))*ds^.lit_bufsize]); + + ds^.l_desc.dyn_tree := tree_ptr(@ds^.dyn_ltree); + ds^.d_desc.dyn_tree := tree_ptr(@ds^.dyn_dtree); + ds^.bl_desc.dyn_tree := tree_ptr(@ds^.bl_tree); + + deflateCopy := Z_OK; +{$endif} +end; + + +{ =========================================================================== + Read a new buffer from the current input stream, update the adler32 + and total number of bytes read. All deflate() input goes through + this function so some applications may wish to modify it to avoid + allocating a large strm^.next_in buffer and copying from it. + (See also flush_pending()). } + +{local} +function read_buf(strm : z_streamp; buf : pBytef; size : unsigned) : int; +var + len : unsigned; +begin + len := strm^.avail_in; + + if (len > size) then + len := size; + if (len = 0) then + begin + read_buf := 0; + exit; + end; + + Dec(strm^.avail_in, len); + + if deflate_state_ptr(strm^.state)^.noheader = 0 then + begin + strm^.adler := adler32(strm^.adler, strm^.next_in, len); + end; + zmemcpy(buf, strm^.next_in, len); + Inc(strm^.next_in, len); + Inc(strm^.total_in, len); + + read_buf := int(len); +end; + +{ =========================================================================== + Initialize the "longest match" routines for a new zlib stream } + +{local} +procedure lm_init (var s : deflate_state); +begin + s.window_size := ulg( uLong(2)*s.w_size); + + {macro CLEAR_HASH(s);} + s.head^[s.hash_size-1] := ZNIL; + zmemzero(pBytef(s.head), unsigned(s.hash_size-1)*sizeof(s.head^[0])); + + { Set the default configuration parameters: } + + s.max_lazy_match := configuration_table[s.level].max_lazy; + s.good_match := configuration_table[s.level].good_length; + s.nice_match := configuration_table[s.level].nice_length; + s.max_chain_length := configuration_table[s.level].max_chain; + + s.strstart := 0; + s.block_start := long(0); + s.lookahead := 0; + s.prev_length := MIN_MATCH-1; + s.match_length := MIN_MATCH-1; + s.match_available := FALSE; + s.ins_h := 0; +{$ifdef ASMV} + match_init; { initialize the asm code } +{$endif} +end; + +{ =========================================================================== + Set match_start to the longest match starting at the given string and + return its length. Matches shorter or equal to prev_length are discarded, + in which case the result is equal to prev_length and match_start is + garbage. + IN assertions: cur_match is the head of the hash chain for the current + string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1 + OUT assertion: the match length is not greater than s^.lookahead. } + + +{$ifndef ASMV} +{ For 80x86 and 680x0, an optimized version will be provided in match.asm or + match.S. The code will be functionally equivalent. } + +{$ifndef FASTEST} + +{local} +function longest_match(var s : deflate_state; + cur_match : IPos { current match } + ) : uInt; +label + nextstep; +var + chain_length : unsigned; { max hash chain length } + {register} scan : pBytef; { current string } + {register} match : pBytef; { matched string } + {register} len : int; { length of current match } + best_len : int; { best match length so far } + nice_match : int; { stop if match long enough } + limit : IPos; + + prev : pzPosfArray; + wmask : uInt; +{$ifdef UNALIGNED_OK} + {register} strend : pBytef; + {register} scan_start : ush; + {register} scan_end : ush; +{$else} + {register} strend : pBytef; + {register} scan_end1 : Byte; + {register} scan_end : Byte; +{$endif} +var + MAX_DIST : uInt; +begin + chain_length := s.max_chain_length; { max hash chain length } + scan := @(s.window^[s.strstart]); + best_len := s.prev_length; { best match length so far } + nice_match := s.nice_match; { stop if match long enough } + + + MAX_DIST := s.w_size - MIN_LOOKAHEAD; +{In order to simplify the code, particularly on 16 bit machines, match +distances are limited to MAX_DIST instead of WSIZE. } + + if s.strstart > IPos(MAX_DIST) then + limit := s.strstart - IPos(MAX_DIST) + else + limit := ZNIL; + { Stop when cur_match becomes <= limit. To simplify the code, + we prevent matches with the string of window index 0. } + + prev := s.prev; + wmask := s.w_mask; + +{$ifdef UNALIGNED_OK} + { Compare two bytes at a time. Note: this is not always beneficial. + Try with and without -DUNALIGNED_OK to check. } + + strend := pBytef(@(s.window^[s.strstart + MAX_MATCH - 1])); + scan_start := pushf(scan)^; + scan_end := pushfArray(scan)^[best_len-1]; { fix } +{$else} + strend := pBytef(@(s.window^[s.strstart + MAX_MATCH])); + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + scan_end1 := pzByteArray(scan)^[best_len-1]; + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + scan_end := pzByteArray(scan)^[best_len]; +{$endif} + + { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. + It is easy to get rid of this optimization if necessary. } + {$IFDEF DEBUG} + Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever'); + {$ENDIF} + { Do not waste too much time if we already have a good match: } + if (s.prev_length >= s.good_match) then + begin + chain_length := chain_length shr 2; + end; + + { Do not look for matches beyond the end of the input. This is necessary + to make deflate deterministic. } + + if (uInt(nice_match) > s.lookahead) then + nice_match := s.lookahead; + {$IFDEF DEBUG} + Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead'); + {$ENDIF} + repeat + {$IFDEF DEBUG} + Assert(cur_match < s.strstart, 'no future'); + {$ENDIF} + match := @(s.window^[cur_match]); + + { Skip to next match if the match length cannot increase + or if the match length is less than 2: } + +{$undef DO_UNALIGNED_OK} +{$ifdef UNALIGNED_OK} + {$ifdef MAX_MATCH_IS_258} + {$define DO_UNALIGNED_OK} + {$endif} +{$endif} + +{$ifdef DO_UNALIGNED_OK} + { This code assumes sizeof(unsigned short) = 2. Do not use + UNALIGNED_OK if your compiler uses a different size. } + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (pushfArray(match)^[best_len-1] <> scan_end) or + (pushf(match)^ <> scan_start) then + goto nextstep; {continue;} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + + { It is not necessary to compare scan[2] and match[2] since they are + always equal when the other bytes match, given that the hash keys + are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at + strstart+3, +5, ... up to strstart+257. We check for insufficient + lookahead only every 4th comparison; the 128th check will be made + at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is + necessary to put more guard bytes at the end of the window, or + to check more often for insufficient lookahead. } + {$IFDEF DEBUG} + Assert(pzByteArray(scan)^[2] = pzByteArray(match)^[2], 'scan[2]?'); + {$ENDIF} + Inc(scan); + Inc(match); + + repeat + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + until (ptr2int(scan) >= ptr2int(strend)); + { The funny "do while" generates better code on most compilers } + + { Here, scan <= window+strstart+257 } + {$IFDEF DEBUG} + {$ifopt R+} {$define RangeCheck} {$endif} {$R-} + Assert(ptr2int(scan) <= + ptr2int(@(s.window^[unsigned(s.window_size-1)])), + 'wild scan'); + {$ifdef RangeCheck} {$R+} {$undef RangeCheck} {$endif} + {$ENDIF} + if (scan^ = match^) then + Inc(scan); + + len := (MAX_MATCH - 1) - int(ptr2int(strend)) + int(ptr2int(scan)); + scan := strend; + Dec(scan, (MAX_MATCH-1)); + +{$else} { UNALIGNED_OK } + + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (pzByteArray(match)^[best_len] <> scan_end) or + (pzByteArray(match)^[best_len-1] <> scan_end1) or + (match^ <> scan^) then + goto nextstep; {continue;} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + Inc(match); + if (match^ <> pzByteArray(scan)^[1]) then + goto nextstep; {continue;} + + { The check at best_len-1 can be removed because it will be made + again later. (This heuristic is not always a win.) + It is not necessary to compare scan[2] and match[2] since they + are always equal when the other bytes match, given that + the hash keys are equal and that HASH_BITS >= 8. } + + Inc(scan, 2); + Inc(match); + {$IFDEF DEBUG} + Assert( scan^ = match^, 'match[2]?'); + {$ENDIF} + { We check for insufficient lookahead only every 8th comparison; + the 256th check will be made at strstart+258. } + + repeat + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + until (ptr2int(scan) >= ptr2int(strend)); + + {$IFDEF DEBUG} + Assert(ptr2int(scan) <= + ptr2int(@(s.window^[unsigned(s.window_size-1)])), + 'wild scan'); + {$ENDIF} + + len := MAX_MATCH - int(ptr2int(strend) - ptr2int(scan)); + scan := strend; + Dec(scan, MAX_MATCH); + +{$endif} { UNALIGNED_OK } + + if (len > best_len) then + begin + s.match_start := cur_match; + best_len := len; + if (len >= nice_match) then + break; + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} +{$ifdef UNALIGNED_OK} + scan_end := pzByteArray(scan)^[best_len-1]; +{$else} + scan_end1 := pzByteArray(scan)^[best_len-1]; + scan_end := pzByteArray(scan)^[best_len]; +{$endif} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + end; + nextstep: + cur_match := prev^[cur_match and wmask]; + Dec(chain_length); + until (cur_match <= limit) or (chain_length = 0); + + if (uInt(best_len) <= s.lookahead) then + longest_match := uInt(best_len) + else + longest_match := s.lookahead; +end; +{$endif} { ASMV } + +{$else} { FASTEST } +{ --------------------------------------------------------------------------- + Optimized version for level = 1 only } + +{local} +function longest_match(var s : deflate_state; + cur_match : IPos { current match } + ) : uInt; +var + {register} scan : pBytef; { current string } + {register} match : pBytef; { matched string } + {register} len : int; { length of current match } + {register} strend : pBytef; +begin + scan := @s.window^[s.strstart]; + strend := @s.window^[s.strstart + MAX_MATCH]; + + + { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. + It is easy to get rid of this optimization if necessary. } + {$IFDEF DEBUG} + Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever'); + + Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead'); + + Assert(cur_match < s.strstart, 'no future'); + {$ENDIF} + match := s.window + cur_match; + + { Return failure if the match length is less than 2: } + + if (match[0] <> scan[0]) or (match[1] <> scan[1]) then + begin + longest_match := MIN_MATCH-1; + exit; + end; + + { The check at best_len-1 can be removed because it will be made + again later. (This heuristic is not always a win.) + It is not necessary to compare scan[2] and match[2] since they + are always equal when the other bytes match, given that + the hash keys are equal and that HASH_BITS >= 8. } + + scan += 2, match += 2; + Assert(scan^ = match^, 'match[2]?'); + + { We check for insufficient lookahead only every 8th comparison; + the 256th check will be made at strstart+258. } + + repeat + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + until (ptr2int(scan) >= ptr2int(strend)); + + Assert(scan <= s.window+unsigned(s.window_size-1), 'wild scan'); + + len := MAX_MATCH - int(strend - scan); + + if (len < MIN_MATCH) then + begin + return := MIN_MATCH - 1; + exit; + end; + + s.match_start := cur_match; + if len <= s.lookahead then + longest_match := len + else + longest_match := s.lookahead; +end; +{$endif} { FASTEST } + +{$ifdef DEBUG} +{ =========================================================================== + Check that the match at match_start is indeed a match. } + +{local} +procedure check_match(var s : deflate_state; + start, match : IPos; + length : int); +begin + exit; + { check that the match is indeed a match } + if (zmemcmp(pBytef(@s.window^[match]), + pBytef(@s.window^[start]), length) <> EQUAL) then + begin + WriteLn(' start ',start,', match ',match ,' length ', length); + repeat + Write(char(s.window^[match]), char(s.window^[start])); + Inc(match); + Inc(start); + Dec(length); + Until (length = 0); + z_error('invalid match'); + end; + if (z_verbose > 1) then + begin + Write('\\[',start-match,',',length,']'); + repeat + Write(char(s.window^[start])); + Inc(start); + Dec(length); + Until (length = 0); + end; +end; +{$endif} + +{ =========================================================================== + Fill the window when the lookahead becomes insufficient. + Updates strstart and lookahead. + + IN assertion: lookahead < MIN_LOOKAHEAD + OUT assertions: strstart <= window_size-MIN_LOOKAHEAD + At least one byte has been read, or avail_in = 0; reads are + performed for at least two bytes (required for the zip translate_eol + option -- not supported here). } + +{local} +procedure fill_window(var s : deflate_state); +var + {register} n, m : unsigned; + {register} p : pPosf; + more : unsigned; { Amount of free space at the end of the window. } + wsize : uInt; +begin + wsize := s.w_size; + repeat + more := unsigned(s.window_size -ulg(s.lookahead) -ulg(s.strstart)); + + { Deal with !@#$% 64K limit: } + if (more = 0) and (s.strstart = 0) and (s.lookahead = 0) then + more := wsize + else + if (more = unsigned(-1)) then + begin + { Very unlikely, but possible on 16 bit machine if strstart = 0 + and lookahead = 1 (input done one byte at time) } + Dec(more); + + { If the window is almost full and there is insufficient lookahead, + move the upper half to the lower one to make room in the upper half.} + end + else + if (s.strstart >= wsize+ {MAX_DIST}(wsize-MIN_LOOKAHEAD)) then + begin + zmemcpy( pBytef(s.window), pBytef(@(s.window^[wsize])), + unsigned(wsize)); + Dec(s.match_start, wsize); + Dec(s.strstart, wsize); { we now have strstart >= MAX_DIST } + Dec(s.block_start, long(wsize)); + + { Slide the hash table (could be avoided with 32 bit values + at the expense of memory usage). We slide even when level = 0 + to keep the hash table consistent if we switch back to level > 0 + later. (Using level 0 permanently is not an optimal usage of + zlib, so we don't care about this pathological case.) } + + n := s.hash_size; + p := @s.head^[n]; + repeat + Dec(p); + m := p^; + if (m >= wsize) then + p^ := Pos(m-wsize) + else + p^ := Pos(ZNIL); + Dec(n); + Until (n=0); + + n := wsize; +{$ifndef FASTEST} + p := @s.prev^[n]; + repeat + Dec(p); + m := p^; + if (m >= wsize) then + p^ := Pos(m-wsize) + else + p^:= Pos(ZNIL); + { If n is not on any hash chain, prev^[n] is garbage but + its value will never be used. } + Dec(n); + Until (n=0); +{$endif} + Inc(more, wsize); + end; + if (s.strm^.avail_in = 0) then + exit; + + {* If there was no sliding: + * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 && + * more == window_size - lookahead - strstart + * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1) + * => more >= window_size - 2*WSIZE + 2 + * In the BIG_MEM or MMAP case (not yet supported), + * window_size == input_size + MIN_LOOKAHEAD && + * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD. + * Otherwise, window_size == 2*WSIZE so more >= 2. + * If there was sliding, more >= WSIZE. So in all cases, more >= 2. } + + {$IFDEF DEBUG} + Assert(more >= 2, 'more < 2'); + {$ENDIF} + + n := read_buf(s.strm, pBytef(@(s.window^[s.strstart + s.lookahead])), + more); + Inc(s.lookahead, n); + + { Initialize the hash value now that we have some input: } + if (s.lookahead >= MIN_MATCH) then + begin + s.ins_h := s.window^[s.strstart]; + {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);} + s.ins_h := ((s.ins_h shl s.hash_shift) xor s.window^[s.strstart+1]) + and s.hash_mask; +{$ifdef MIN_MATCH <> 3} + Call UPDATE_HASH() MIN_MATCH-3 more times +{$endif} + end; + { If the whole input has less than MIN_MATCH bytes, ins_h is garbage, + but this is not important since only literal bytes will be emitted. } + + until (s.lookahead >= MIN_LOOKAHEAD) or (s.strm^.avail_in = 0); +end; + +{ =========================================================================== + Flush the current block, with given end-of-file flag. + IN assertion: strstart is set to the end of the current match. } + +procedure FLUSH_BLOCK_ONLY(var s : deflate_state; eof : boolean); {macro} +begin + if (s.block_start >= Long(0)) then + _tr_flush_block(s, pcharf(@s.window^[unsigned(s.block_start)]), + ulg(long(s.strstart) - s.block_start), eof) + else + _tr_flush_block(s, pcharf(Z_NULL), + ulg(long(s.strstart) - s.block_start), eof); + + s.block_start := s.strstart; + flush_pending(s.strm^); + {$IFDEF DEBUG} + Tracev('[FLUSH]'); + {$ENDIF} +end; + +{ Same but force premature exit if necessary. +macro FLUSH_BLOCK(var s : deflate_state; eof : boolean) : boolean; +var + result : block_state; +begin + FLUSH_BLOCK_ONLY(s, eof); + if (s.strm^.avail_out = 0) then + begin + if eof then + result := finish_started + else + result := need_more; + exit; + end; +end; +} + +{ =========================================================================== + Copy without compression as much as possible from the input stream, return + the current block state. + This function does not insert new strings in the dictionary since + uncompressible data is probably not useful. This function is used + only for the level=0 compression option. + NOTE: this function should be optimized to avoid extra copying from + window to pending_buf. } + + +{local} +function deflate_stored(var s : deflate_state; flush : int) : block_state; +{ Stored blocks are limited to 0xffff bytes, pending_buf is limited + to pending_buf_size, and each stored block has a 5 byte header: } +var + max_block_size : ulg; + max_start : ulg; +begin + max_block_size := $ffff; + if (max_block_size > s.pending_buf_size - 5) then + max_block_size := s.pending_buf_size - 5; + + { Copy as much as possible from input to output: } + while TRUE do + begin + { Fill the window as much as possible: } + if (s.lookahead <= 1) then + begin + {$IFDEF DEBUG} + Assert( (s.strstart < s.w_size + {MAX_DIST}s.w_size-MIN_LOOKAHEAD) or + (s.block_start >= long(s.w_size)), 'slide too late'); + {$ENDIF} + fill_window(s); + if (s.lookahead = 0) and (flush = Z_NO_FLUSH) then + begin + deflate_stored := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + {$IFDEF DEBUG} + Assert(s.block_start >= long(0), 'block gone'); + {$ENDIF} + Inc(s.strstart, s.lookahead); + s.lookahead := 0; + + { Emit a stored block if pending_buf will be full: } + max_start := s.block_start + max_block_size; + if (s.strstart = 0) or (ulg(s.strstart) >= max_start) then + begin + { strstart = 0 is possible when wraparound on 16-bit machine } + {$WARNINGS OFF} + s.lookahead := uInt(s.strstart - max_start); + {$WARNINGS ON} + s.strstart := uInt(max_start); + {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_stored := need_more; + exit; + end; + end; + + { Flush if we may have to slide, otherwise block_start may become + negative and the data will be gone: } + + if (s.strstart - uInt(s.block_start) >= {MAX_DIST} + s.w_size-MIN_LOOKAHEAD) then + begin + {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_stored := need_more; + exit; + end; + end; + end; + + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_stored := finish_started + else + deflate_stored := need_more; + exit; + end; + + if flush = Z_FINISH then + deflate_stored := finish_done + else + deflate_stored := block_done; +end; + +{ =========================================================================== + Compress as much as possible from the input stream, return the current + block state. + This function does not perform lazy evaluation of matches and inserts + new strings in the dictionary only for unmatched strings or for short + matches. It is used only for the fast compression options. } + +{local} +function deflate_fast(var s : deflate_state; flush : int) : block_state; +var + hash_head : IPos; { head of the hash chain } + bflush : boolean; { set if current block must be flushed } +begin + hash_head := ZNIL; + while TRUE do + begin + { Make sure that we always have enough lookahead, except + at the end of the input file. We need MAX_MATCH bytes + for the next match, plus MIN_MATCH bytes to insert the + string following the next match. } + + if (s.lookahead < MIN_LOOKAHEAD) then + begin + fill_window(s); + if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then + begin + deflate_fast := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + + + { Insert the string window[strstart .. strstart+2] in the + dictionary, and set hash_head to the head of the hash chain: } + + if (s.lookahead >= MIN_MATCH) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + + { Find the longest match, discarding those <= prev_length. + At this point we have always match_length < MIN_MATCH } + if (hash_head <> ZNIL) and + (s.strstart - hash_head <= (s.w_size-MIN_LOOKAHEAD){MAX_DIST}) then + begin + { To simplify the code, we prevent matches with the string + of window index 0 (in particular we have to avoid a match + of the string with itself at the start of the input file). } + if (s.strategy <> Z_HUFFMAN_ONLY) then + begin + s.match_length := longest_match (s, hash_head); + end; + { longest_match() sets match_start } + end; + if (s.match_length >= MIN_MATCH) then + begin + {$IFDEF DEBUG} + check_match(s, s.strstart, s.match_start, s.match_length); + {$ENDIF} + + {_tr_tally_dist(s, s.strstart - s.match_start, + s.match_length - MIN_MATCH, bflush);} + bflush := _tr_tally(s, s.strstart - s.match_start, + s.match_length - MIN_MATCH); + + Dec(s.lookahead, s.match_length); + + { Insert new strings in the hash table only if the match length + is not too large. This saves time but degrades compression. } + +{$ifndef FASTEST} + if (s.match_length <= s.max_insert_length) + and (s.lookahead >= MIN_MATCH) then + begin + Dec(s.match_length); { string at strstart already in hash table } + repeat + Inc(s.strstart); + INSERT_STRING(s, s.strstart, hash_head); + { strstart never exceeds WSIZE-MAX_MATCH, so there are + always MIN_MATCH bytes ahead. } + Dec(s.match_length); + until (s.match_length = 0); + Inc(s.strstart); + end + else +{$endif} + + begin + Inc(s.strstart, s.match_length); + s.match_length := 0; + s.ins_h := s.window^[s.strstart]; + {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);} + s.ins_h := (( s.ins_h shl s.hash_shift) xor + s.window^[s.strstart+1]) and s.hash_mask; +if MIN_MATCH <> 3 then { the linker removes this } +begin + {Call UPDATE_HASH() MIN_MATCH-3 more times} +end; + + { If lookahead < MIN_MATCH, ins_h is garbage, but it does not + matter since it will be recomputed at next deflate call. } + + end; + end + else + begin + { No match, output a literal byte } + {$IFDEF DEBUG} + Tracevv(char(s.window^[s.strstart])); + {$ENDIF} + {_tr_tally_lit (s, 0, s.window^[s.strstart], bflush);} + bflush := _tr_tally (s, 0, s.window^[s.strstart]); + + Dec(s.lookahead); + Inc(s.strstart); + end; + if bflush then + begin {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_fast := need_more; + exit; + end; + end; + end; + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_fast := finish_started + else + deflate_fast := need_more; + exit; + end; + + if flush = Z_FINISH then + deflate_fast := finish_done + else + deflate_fast := block_done; +end; + +{ =========================================================================== + Same as above, but achieves better compression. We use a lazy + evaluation for matches: a match is finally adopted only if there is + no better match at the next window position. } + +{local} +function deflate_slow(var s : deflate_state; flush : int) : block_state; +var + hash_head : IPos; { head of hash chain } + bflush : boolean; { set if current block must be flushed } +var + max_insert : uInt; +begin + hash_head := ZNIL; + + { Process the input block. } + while TRUE do + begin + { Make sure that we always have enough lookahead, except + at the end of the input file. We need MAX_MATCH bytes + for the next match, plus MIN_MATCH bytes to insert the + string following the next match. } + + if (s.lookahead < MIN_LOOKAHEAD) then + begin + fill_window(s); + if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then + begin + deflate_slow := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + + { Insert the string window[strstart .. strstart+2] in the + dictionary, and set hash_head to the head of the hash chain: } + + if (s.lookahead >= MIN_MATCH) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + + { Find the longest match, discarding those <= prev_length. } + + s.prev_length := s.match_length; + s.prev_match := s.match_start; + s.match_length := MIN_MATCH-1; + + if (hash_head <> ZNIL) and (s.prev_length < s.max_lazy_match) and + (s.strstart - hash_head <= {MAX_DIST}(s.w_size-MIN_LOOKAHEAD)) then + begin + { To simplify the code, we prevent matches with the string + of window index 0 (in particular we have to avoid a match + of the string with itself at the start of the input file). } + + if (s.strategy <> Z_HUFFMAN_ONLY) then + begin + s.match_length := longest_match (s, hash_head); + end; + { longest_match() sets match_start } + + if (s.match_length <= 5) and ((s.strategy = Z_FILTERED) or + ((s.match_length = MIN_MATCH) and + (s.strstart - s.match_start > TOO_FAR))) then + begin + { If prev_match is also MIN_MATCH, match_start is garbage + but we will ignore the current match anyway. } + + s.match_length := MIN_MATCH-1; + end; + end; + { If there was a match at the previous step and the current + match is not better, output the previous match: } + + if (s.prev_length >= MIN_MATCH) + and (s.match_length <= s.prev_length) then + begin + max_insert := s.strstart + s.lookahead - MIN_MATCH; + { Do not insert strings in hash table beyond this. } + {$ifdef DEBUG} + check_match(s, s.strstart-1, s.prev_match, s.prev_length); + {$endif} + + {_tr_tally_dist(s, s->strstart -1 - s->prev_match, + s->prev_length - MIN_MATCH, bflush);} + bflush := _tr_tally(s, s.strstart -1 - s.prev_match, + s.prev_length - MIN_MATCH); + + { Insert in hash table all strings up to the end of the match. + strstart-1 and strstart are already inserted. If there is not + enough lookahead, the last two strings are not inserted in + the hash table. } + + Dec(s.lookahead, s.prev_length-1); + Dec(s.prev_length, 2); + repeat + Inc(s.strstart); + if (s.strstart <= max_insert) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + Dec(s.prev_length); + until (s.prev_length = 0); + s.match_available := FALSE; + s.match_length := MIN_MATCH-1; + Inc(s.strstart); + + if (bflush) then {FLUSH_BLOCK(s, FALSE);} + begin + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_slow := need_more; + exit; + end; + end; + end + else + if (s.match_available) then + begin + { If there was no match at the previous position, output a + single literal. If there was a match but the current match + is longer, truncate the previous match to a single literal. } + {$IFDEF DEBUG} + Tracevv(char(s.window^[s.strstart-1])); + {$ENDIF} + bflush := _tr_tally (s, 0, s.window^[s.strstart-1]); + + if bflush then + begin + FLUSH_BLOCK_ONLY(s, FALSE); + end; + Inc(s.strstart); + Dec(s.lookahead); + if (s.strm^.avail_out = 0) then + begin + deflate_slow := need_more; + exit; + end; + end + else + begin + { There is no previous match to compare with, wait for + the next step to decide. } + + s.match_available := TRUE; + Inc(s.strstart); + Dec(s.lookahead); + end; + end; + + {$IFDEF DEBUG} + Assert (flush <> Z_NO_FLUSH, 'no flush?'); + {$ENDIF} + if (s.match_available) then + begin + {$IFDEF DEBUG} + Tracevv(char(s.window^[s.strstart-1])); + bflush := + {$ENDIF} + _tr_tally (s, 0, s.window^[s.strstart-1]); + s.match_available := FALSE; + end; + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_slow := finish_started + else + deflate_slow := need_more; + exit; + end; + if flush = Z_FINISH then + deflate_slow := finish_done + else + deflate_slow := block_done; +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/Zip.pas b/niftiview7/gzio/Zip.pas new file mode 100755 index 0000000..45f01ac --- /dev/null +++ b/niftiview7/gzio/Zip.pas @@ -0,0 +1,1790 @@ +//------------------------------------------------------------------------------ +// Component TZip Component . +// Version: 0.9.4 . +// Date: 29 October 2001 . +// Compilers: Delphi 3 - Delphi 6, C++ Builder 3 - C++ Builder 5 . +// Author: Angus Johnson - ajohnson@rpi.net.au . +// Copyright: © 2001 Angus Johnson . +// . +// Description: Delphi interface to the ZipDll.dll & UnzDll.dll libraries . +// created by Eric W. Engler and Chris Vleghert. (SFX . +// support is provided but not as part of this component.) . +// . +// Acknowledgements: Based on the TZipMstr component which was created by . +// Eric W. Engler and Chris Vleghert. . +// ----------------------------------------------------------------------------- + +//Updated 29 October 2001: +// Resourcestring s_unable_to_load was missing a %s in its definition + +//Updated 5 Sept 2001: +// The TZip.AddPath property is now unassigned after each Add method call. +// If the TZip.AddPath property is assigned, TZip will change +// the current directory to that path (ChDir) just before Adding. + +(* +Current Dll issues (ver 1.6): + 1. when adding Foldernames to FileSpecList, a trailing slash is required + to indicate they are folders. + 2. ??bug - if filenames stored in OEM format the dll will extract but + not delete them. + 3. cancelling an add/delete operation corrupts the zip file. A workaround + requires saving a copy of the file before these operations. +*) + +unit Zip; + +{$IFDEF VER120} //delphi 4 + {$DEFINE VER120_PLUS} +{$ENDIF} +{$IFDEF VER125} //bcb 4 + {$DEFINE VER120_PLUS} +{$ENDIF} +{$IFDEF VER130} //delphi 5 + {$DEFINE VER120_PLUS} +{$ENDIF} +{$IFDEF VER135} //bcb 5 + {$DEFINE VER120_PLUS} +{$ENDIF} +{$IFDEF VER140} //delphi 6 + {$DEFINE VER120_PLUS} +{$ENDIF} + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ZipDlls, StdCtrls, ComCtrls {$IFNDEF VER120_PLUS}, FileCtrl {$ENDIF}; + +type + + ZipException = class(Exception); + + TAddOption = (aoFreshen, aoUpdate, aoRecursive, aoWithFullPath, + aoFolderEntries, aoZipTime, aoHiddenFiles, aoForceDOS); + TAddOptions = set of TAddOption; + + //TExtractOptions - + //nb: newer files will be overwritten automatically if eoUpdate or eoFreshen + //set. eoAskOverwrite will be ignored with eoUpdate or eoFreshen options. + TExtractOption = (eoUpdate, eoFreshen, eoTest, eoAskOverwrite, eoWithPaths); + TExtractOptions = set of TExtractOption; + + //Zip/Extract/Delete (ZED) event methods... + TZEDBeginFileEvent = procedure(Sender: TObject; const Filename: string; + FileSize, BatchCount, TotalBytesInBatch: longint) of object; + TZEDEndBatchEvent = procedure(Sender: TObject; + SkippedCount, BatchCount, TotalBytesInBatch: longint) of object; + + //All purpose progress event... + TProgressEvent = procedure(Sender: TObject; const Filename: string; + BytesDone, TotalBytes: longint) of object; + + //A record for each file within the Zip archive ... + pFileInfo = ^TFileInfo; + TFileInfo = packed record + cfh : TCentralFileHeader; + PasswordUsed : Boolean; + Filename : string; //ANSI format + ExtraField : string; + FileComment : string; //ANSI format + Reserved1 : Cardinal; //2 fields used internally by TZip when + Reserved2 : Cardinal; //creating spanned archives. + end; + + TEOCHInfo = packed record + eoch : TEndOfCentralHeader; + ZipComment : string; //ANSI format + EocOffset : integer; + end; + + TZip = class(TComponent) + private + fFilename: string; + fPassword: string; + fDllPath: string; + fTempPath: string; + fRequiresOemAnsiConversion: boolean; + //fFileList contains a list of pointers to TFileInfo records ... + fFileList: TList; + fFileSpecList: TStrings; + fEocInfo: TEOCHInfo; + fCancel: boolean; + fShowProgress: boolean; + fTrueSfxSize: integer; + fOnContentsChanged: TNotifyEvent; + fProgressForm: TCustomForm; + + fAddPath: string; + fAddOptions: TAddOptions; + + fExtractPath: string; + fExtractOptions: TExtractOptions; + + fZEDBeginFileEvent: TZEDBeginFileEvent; + fZEDProgressEvent: TProgressEvent; + fZEDEndBatchEvent: TZEDEndBatchEvent; + fMergeProgressEvent: TProgressEvent; + fSpanProgressEvent: TProgressEvent; + procedure SetFilename(const filename: string); + procedure SetFileSpecList(strings: TStrings); + procedure ClearFileList; + procedure LoadFileList; + function GetFileInfo(index: integer): TFileInfo; + + function GetCount: integer; + function LoadZipDll: boolean; + function LoadUnZipDll: boolean; + procedure UnLoadDlls; + procedure SetPassword(const password: string); + function DoAddDelete(IsAdd: boolean): integer; + + // get/set general zip file comment... + function GetZipComment: string; + procedure SetZipComment(comment: string); + // get/set individual file comments... + function GetFileComment(index: integer): string; + procedure SetFileComment(index: integer; comment: string); + + function OemStrToAnsiStr(const s: string): string; + function AnsiStrToOemStr(const s: string): string; + + protected + { Protected declarations } + public + constructor create(aOwner: TComponent); override; + destructor destroy; override; + + function Extract: integer; //returns No. files extracted + function Add: integer; //returns No. files added + function Delete: integer; //returns No. files deleted + + + //merge a multi disk Zip file into one file (on hard disk) + function MergeArchiveTo(const Target: string): boolean; + //create a multi disk Zip file from one file (on hard disk) + function SpanArchiveTo(const Target: string; + MaxBytesPerDisk, BytesToReserveDisk1: integer): boolean; + + property Count: integer read GetCount; + property FileInfos[index: integer]: TFileInfo read GeTFileInfo; + //Name of Zip archive (will auto create a new file if it doesn't exist)... + property Filename: string read fFilename write SetFilename; + //List of files to add/extract/delete (with or without wildcards *.*) ... + property FileSpecList: TStrings read fFileSpecList write SetFileSpecList; + //Optional path to Dlls if they're not stored in exe's folder or shell's path ... + property DllPath: string read fDllPath write fDllPath; + //Base path to which files will be extracted + //(otherwise files will be extracted into same folder as Zip archive) + property ExtractPath: string read fExtractPath write fExtractPath; + + property AddPath: string read fAddPath write fAddPath; + property AddOptions: TAddOptions read fAddOptions write fAddOptions; + + property ExtractOptions: TExtractOptions read fExtractOptions write fExtractOptions; + + property FileComments[index: integer]: string read GetFileComment write SetFileComment; + property ZipComment: string read GetZipComment write SetZipComment; + property Password: string read fPassword write SetPassword; + property SfxSize: integer read fTrueSfxSize; + published + property ShowProgressDialog: boolean read fShowProgress write fShowProgress; + //Zip/Extract/Delete (ZED) events... + property OnZEDBeginFileEvent: TZEDBeginFileEvent + read fZEDBeginFileEvent write fZEDBeginFileEvent; + property OnZEDProgressEvent: TProgressEvent + read fZEDProgressEvent write fZEDProgressEvent; + property OnZEDEndBatchEvent: TZEDEndBatchEvent + read fZEDEndBatchEvent write fZEDEndBatchEvent; + //Merge and Span progress events... + property OnMergeProgress: TProgressEvent + read fMergeProgressEvent write fMergeProgressEvent; + property OnSpanProgress: TProgressEvent + read fSpanProgressEvent write fSpanProgressEvent; + //When a new zip is opened, or files added to or deleted from zip ... + property OnContentsChanged: TNotifyEvent read fOnContentsChanged write fOnContentsChanged; + end; + +//Declared in the interface section as also needed by SfxUtils.pas +function FindEOCHeaderOffset(stream: TStream): longint; + +//wrapper functions for WinAPI functions... +function GetVolumeName(DrivePath: string; out VolumeName: string): boolean; +function GetDiskType(const filename: string): integer; +function GetTempPathWinOS: string; + +function AppendSlash(const str: string): string; + +procedure Register; + +const + ERROR_VALUE = -1; + +//add in all the resource strings ... +//(An include file is used to simplify translations.) +{$I zip_str_english.txt} + +implementation + +type + + TProgressForm = class(TCustomForm) + private + OwnerZip: TZip; + TextLabel: TLabel; + CancelButton: TButton; + ProgressBar: TProgressBar; + procedure CancelClicked(Sender: TObject); + procedure SetProgressMax(max: integer); + procedure SetProgressPosition(position: integer); + procedure SetText(text: string); + public + property ProgressMax: integer write SetProgressMax; + property ProgressPosition: integer write SetProgressPosition; + property Text: string write SetText; + constructor CreateNew(Owner: TComponent + {$IFDEF VER120_PLUS};Dummy: Integer = 0); override;{$ELSE});{$ENDIF} + end; + +//--------------------------------------------------------------------- +// Miscellaneous functions... +//--------------------------------------------------------------------- + +procedure Register; +begin + RegisterComponents('Samples', [TZip]); +end; +//--------------------------------------------------------------------- + +function min(a,b: integer): integer; +begin + if a < b then result := a else result := b; +end; +//--------------------------------------------------------------------- + +function SwapSlashes(const str: string): string; +var + i: integer; +begin + result := str; + for i := 1 to length(result) do + if result[i] = '/' then result[i] := '\'; +end; +//--------------------------------------------------------------------- + +function AppendSlash(const str: string): string; +begin + if (str <> '') and (str[length(str)] <> '\') then + result := str +'\' else + result := str; +end; +//--------------------------------------------------------------------- + +function GetDiskType(const filename: string): integer; +var + drive: string; +begin + if filename = '' then result := DRIVE_NO_ROOT_DIR else + begin + drive := AppendSlash(ExtractFileDrive(filename)); + result := GetDriveType(pchar(drive)); + end; +end; +//--------------------------------------------------------------------- + +function GetTempPathWinOS: string; +begin + //get the OS's temppath... + Setlength(result,MAX_PATH+1); + Setlength(result,GetTempPath(MAX_PATH, pchar(result))); + if result = '' then result := extractfilepath(paramstr(0)); +end; +//--------------------------------------------------------------------- + +//nb: GetDiskFree() is used internally only when creating +//multi-disk archives on floppies so I've chosen to ignore free space > 2gig +function GetDiskFree(const Filename: string): cardinal; +var + SectorsPCluster, BytesPSector, FreeClusters, TotalClusters: DWORD; + Drive: string; +begin + Result := 0; + if (length(Filename) < 3) or (pos(':\',Filename) <> 2) then exit; + Drive := copy(Filename,1,3); + if GetDiskFreeSpace( pChar( Drive ), + SectorsPCluster, BytesPSector, FreeClusters, TotalClusters ) then + result := FreeClusters * SectorsPCluster * BytesPSector; +end; +//--------------------------------------------------------------------- + +function GetVolumeName(DrivePath: string; out VolumeName: string): boolean; +var + OldErrMode: dword; + VolName: array[0..11] of char; + dummy1: {$IFDEF VER120_PLUS}Cardinal{$ELSE}Integer{$ENDIF}; + dummy2: dword; +begin + DrivePath := AppendSlash(DrivePath); + OldErrMode := SetErrorMode( SEM_FAILCRITICALERRORS ); + result := GetVolumeInformation(pchar(DrivePath), + VolName, 12, nil, dummy1, dummy2, nil, 0 ); + if result then VolumeName := VolName; + SetErrorMode( OldErrMode ); +end; +//--------------------------------------------------------------------- + +function GetSpannedZipDiskNum(const Filename: string): integer; +var + Volume: string; +begin + result := 0; + //nb: cannot detect floppy disks if across the network + if not FileExists(Filename) or (GetDiskType(Filename) <> DRIVE_REMOVABLE) or + not GetVolumeName(ExtractFileDrive(Filename),Volume) then exit; + if (Pos( 'PKBACK# ', Volume) = 1) then + result := StrToIntDef(Copy(Volume,9,3), 0); +end; +//--------------------------------------------------------------------- + +function PromptMultiDiskNum(const filename: string; Num: integer): boolean; +var + i: integer; +begin + result := false; + i := GetSpannedZipDiskNum(filename); + while i <> num do + begin + if application.messagebox(pchar(format(s_multidisk_prompt, [Num])), + pchar(application.title), mb_okcancel or mb_iconinformation) <> IDOK then + exit; //cancelled + i := GetSpannedZipDiskNum(filename); + end; + result := true; +end; + +//--------------------------------------------------------------------- +// TProgressForm methods ... +//--------------------------------------------------------------------- + +const + PROGRESS_CLIENTWIDTH = 300; + +constructor TProgressForm.CreateNew(Owner: TComponent + {$IFDEF VER120_PLUS};Dummy: Integer);{$ELSE});{$ENDIF} +begin + inherited CreateNew(Owner); + OwnerZip := Owner as TZip; + BorderStyle := bsDialog; + Caption := application.title; + ClientWidth := PROGRESS_CLIENTWIDTH; + ClientHeight := 100; + FormStyle := fsStayOnTop; + + //center the progressForm over the middle of the mainform... + with application.mainform do + self.SetBounds(left + (width-self.width) div 2, + top + (height-self.height) div 2, self.width, self.height); + + //create controls... + TextLabel := TLabel.Create(self); + with TextLabel do + begin + Parent := self; + AutoSize := False; + Top := 15; + caption := s_wait_caption; + width := PROGRESS_CLIENTWIDTH -20; + Left := (PROGRESS_CLIENTWIDTH - width) div 2; + end; + ProgressBar := TProgressBar.create(self); + with ProgressBar do + begin + Parent := self; + width := PROGRESS_CLIENTWIDTH -20; + Left := (PROGRESS_CLIENTWIDTH - width) div 2; + Top := 35; + end; + CancelButton := TButton.Create(self); + with CancelButton do + begin + Parent := self; + Caption := s_cancel_caption; + Default := True; + Top := 60; + Left := (PROGRESS_CLIENTWIDTH-width) div 2; + OnClick := CancelClicked; + end; +end; +//--------------------------------------------------------------------- + +procedure TProgressForm.CancelClicked(Sender: TObject); +begin + OwnerZip.fCancel := true; + hide; +end; +//--------------------------------------------------------------------- + +procedure TProgressForm.SetProgressMax(max: integer); +begin + ProgressBar.Max := max; +end; +//--------------------------------------------------------------------- + +procedure TProgressForm.SetProgressPosition(position: integer); +begin + ProgressBar.Position := position; +end; +//--------------------------------------------------------------------- + +procedure TProgressForm.SetText(text: string); +begin + TextLabel.Caption := text; + TextLabel.Left := (PROGRESS_CLIENTWIDTH - TextLabel.width) div 2; +end; + +//--------------------------------------------------------------------- +// TZip methods... +//--------------------------------------------------------------------- + +constructor TZip.create(aOwner: TComponent); +begin + inherited; + fFileList := TList.create; + fFileSpecList := TStringList.create; + fShowProgress := true; + fAddOptions := [aoUpdate]; //default to update + fExtractOptions := [eoUpdate]; + fTempPath := GetTempPathWinOS; +end; +//--------------------------------------------------------------------- + +destructor TZip.destroy; +begin + fFileSpecList.free; + ClearFileList; + fFileList.free; + UnLoadDlls; //unloads dlls if loaded + inherited destroy; +end; +//--------------------------------------------------------------------- + +function TZip.LoadZipDll: boolean; +var + fullname: string; + OldErrMode: dword; +begin + result := true; + if ZipDllHandle <> 0 then exit; //returns non-zero if already loaded + if fDllPath = '' then + fullname := 'ZipDll.dll' else + fullname := AppendSlash(fDllPath)+ 'ZipDll.dll'; + + OldErrMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOGPFAULTERRORBOX); + try + ZipDllHandle := LoadLibrary(pChar(fullname)); + if ZipDllHandle = 0 then exit; //error! + @ZipDllExec := GetProcAddress( ZipDllHandle, 'ZipDllExec' ); + @GetZipDllVersion := GetProcAddress( ZipDllHandle, 'GetZipDllVersion' ); + if (@ZipDllExec = nil) or (@GetZipDllVersion = nil) then //error + begin + FreeLibrary( ZipDllHandle ); + ZipDllHandle := 0; + end; + finally + SetErrorMode(OldErrMode); + result := (ZipDllHandle <> 0); + end; +end; +//--------------------------------------------------------------------- + +function TZip.LoadUnZipDll: boolean; +var + fullname: string; + OldErrMode: dword; +begin + result := true; + if UnZipDllHandle <> 0 then exit; //returns non-zero if already loaded + if fDllPath = '' then + fullname := 'UnZDll.dll' else + fullname := AppendSlash(fDllPath)+ 'UnZDll.dll'; + OldErrMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOGPFAULTERRORBOX); + try + UnZipDllHandle := LoadLibrary(pChar(fullname)); + if UnZipDllHandle = 0 then exit; //error! + @UnZipDllExec := GetProcAddress( UnZipDllHandle, 'UnzDllExec' ); + @GetUnZipDllVersion := GetProcAddress( UnZipDllHandle, 'GetUnzDllVersion' ); + if (@UnZipDllExec = nil) or (@GetUnZipDllVersion = nil) then //error + begin + FreeLibrary( UnZipDllHandle ); + UnZipDllHandle := 0; + end; + finally + SetErrorMode(OldErrMode); + result := (UnZipDllHandle <> 0); + end; +end; +//--------------------------------------------------------------------- + +procedure TZip.UnLoadDlls; +begin + if ZipDllHandle <> 0 then + begin + FreeLibrary( ZipDllHandle ); + ZipDllHandle := 0; + end; + if UnZipDllHandle <> 0 then + begin + FreeLibrary( UnZipDllHandle ); + UnZipDllHandle := 0; + end; +end; +//--------------------------------------------------------------------- + +procedure TZip.SetFileSpecList(strings: TStrings); +begin + fFileSpecList.assign(strings); +end; +//--------------------------------------------------------------------- + +procedure TZip.ClearFileList; +var + i: integer; +begin + for i := 0 to fFileList.count-1 do dispose(pFileInfo(fFileList[i])); + fFileList.clear; +end; +//--------------------------------------------------------------------- + +function TZip.GetCount: integer; +begin + result := fFileList.count; +end; +//--------------------------------------------------------------------- + +function TZip.GetFileInfo(index: integer): TFileInfo; +begin + if (index < 0) or (index >= fFileList.count) then + raise ZipException.create(s_index_range_error) + else + result := pFileInfo(fFileList[index])^; +end; +//--------------------------------------------------------------------- + +procedure TZip.SetPassword(const password: string); +begin + if length(password) <= PASSWORD_MAXLEN then + fPassword := password else + raise ZipException.create(s_password_too_long); +end; +//--------------------------------------------------------------------- + +procedure TZip.SetFilename(const filename: string); +var + vol: string; + Stream: TfileStream; +begin + //allow assigning the same filename to force reinitializing... + + //reinitialize values... + fPassword := ''; + fRequiresOemAnsiConversion := false; + FillChar(fEocInfo.eoch, sizeof(TEndOfCentralHeader),0); + fEocInfo.ZipComment := ''; + fEocInfo.EocOffset := ERROR_VALUE; + + fEocInfo.eoch.HeaderSig := EOC_HEADERSIG; + fTrueSfxSize := 0; + ClearFileList; + fFilename := filename; + if filename <> '' then + begin + //first check there is a disk in the selected drive... + if not GetVolumeName(ExtractFileDrive(filename), vol) then + raise ZipException.create(s_unable_to_access_drive); + + //if filename doesn't exist, create a new empty Zip file... + if not fileexists(filename) then + begin + try + Stream := TfileStream.create(filename,fmCreate); + try + //write just the fixed length fields... + Stream.write(fEocInfo.eoch , SizeOf(TEndOfCentralHeader)); + finally + Stream.free; + end; + except + raise ZipException.createfmt(s_unable_to_create,[filename]); + end; + end; + + LoadFileList; + end; + if assigned(fOnContentsChanged) then fOnContentsChanged(self); +end; +//--------------------------------------------------------------------- + +//returns stream position (or -1 if not found)... +function FindEOCHeaderOffset(stream: TStream): longint; +var + buffSize: integer; + Buffer, buffptr: pchar; + Eoc: TEndOfCentralHeader; +begin + result := ERROR_VALUE; + if Stream.size < sizeof(TEndOfCentralHeader) then exit; //can't be a zip file + + //Note: A zip file comment may exist at the end of the archive just + //after the EndOfCentralHeader record. As its length is unknown (but <= 65k), + //we may have to seek for the EOCHeader record. + + Stream.seek(-sizeof(TEndOfCentralHeader), soFromEnd); + if Stream.read(Eoc, sizeof(TEndOfCentralHeader)) <> sizeof(TEndOfCentralHeader) then + exit; //error + + if Eoc.HeaderSig = EOC_HEADERSIG then //found + begin + Stream.seek(-sizeof(TEndOfCentralHeader),soFromCurrent); + result := stream.Position; + exit; + end; + + buffSize := min(Stream.size,MAXWORD); //ie: buffSize <= 65k + buffer := AllocMem(buffSize); + try + Stream.seek(-buffSize,soFromEnd); + //read the block into the buffer... + if Stream.read(Buffer^,buffSize) <> buffSize then exit; + + //perform a backwards search for the EOC_HEADERSIG ('PK'#5#6)... + buffptr := buffer + buffSize - sizeof(TEndOfCentralHeader); + while buffptr >= buffer do + begin + if pdword(buffptr)^ = EOC_HEADERSIG then //FOUND!! + begin + //move the stream position to the beginning of the EOCHeader... + Stream.seek(Stream.position - buffSize + (buffptr-buffer), soFromBeginning); + result := stream.Position; + exit; + end; + dec(buffptr); + end; + finally + FreeMem(Buffer); + end; +end; +//--------------------------------------------------------------------- + +procedure TZip.LoadFileList; +var + i: integer; + stream: TStream; + + //------------------------------------------------------------------- + + function GetCentralHeaderInfo: boolean; + var + i,j: integer; + cfhdr: TCentralFileHeader; + FileInfo: pFileInfo; + begin + result := false; + if fEocInfo.eoch.ThisDiskNo > 0 then //multi disk zip + Stream.Position := fEocInfo.eoch.CentralOffSet + else + //nb: fEocInfo.eoch.CentralOffSet may NOT be accurate with SFX files + //as the zip file may have simply been appended to the Sfx stub + //without updating the EndOfCentralHeader. + Stream.Position := fEocInfo.EocOffset - fEocInfo.eoch.CentralSize; + + fTrueSfxSize := Stream.Size; //set to an impossible value + + //read each central file header record ... + i := 0; + while i < fEocInfo.eoch.TotalEntries do + begin + if (Stream.read(cfhdr,sizeof(TCentralFileHeader)) <> sizeof(TCentralFileHeader)) then + begin + //if single disk zip then error!! + if (fEocInfo.eoch.ThisDiskNo = 0) then exit; + + //Hopefully the read of header record failed due to spanning to + //the next disk (multi-disk archive) ... + j := GetSpannedZipDiskNum(Filename); + //(nb: GetSpannedZipDiskNum() returns the current Disk No *1* based + //while fEocInfo.eoch.ThisDiskNo is *zero* based. ) + if (j = 0) or (j > fEocInfo.eoch.ThisDiskNo) then exit; //error!! + Stream.free; + Stream := nil; + //prompt for the next disk... + if not PromptMultiDiskNum(fFilename, j+1) then exit; + Stream := TFileStream.create(Filename,fmOpenRead or fmShareDenyWrite); + continue; + end; + + if (cfhdr.HeaderSig <> CENTRAL_HEADERSIG) then exit; //error!! + + if (i = 0) then //only to do this once (ie assume they're all the same)... + begin + // OEM <-> ANSI conversion rules: + // cfh.HostVersionNo = FAT, VFAT, FAT32 (0) -> do conversion + // cfh.HostVersionNo = OS2 HPFS (6) -> do conversion (OS2) + // cfh.HostVersionNo = WIN NTFS (11) && cfh.MadeByVersion = 50 -> do conversion + // else no conversion required + if (cfhdr.HostVersionNo = 0) or (cfhdr.HostVersionNo = 6) or + ((cfhdr.HostVersionNo = 11) and (cfhdr.MadeByVersion = 50)) then + fRequiresOemAnsiConversion := true else + fRequiresOemAnsiConversion := false; + end; + + //ok, now store the file header data... + new(FileInfo); + fFileList.add(FileInfo); + //get filename + setlength(FileInfo.Filename, cfhdr.FileNameLength); + if Stream.read(FileInfo.Filename[1], cfhdr.FileNameLength) <> + cfhdr.FileNameLength then exit; //error + + FileInfo.Filename := SwapSlashes(OemStrToAnsiStr(FileInfo.Filename)); + //get ExtraField + setlength(FileInfo.ExtraField, cfhdr.ExtraFieldLength); + if Stream.read(FileInfo.ExtraField[1],cfhdr.ExtraFieldLength) <> + cfhdr.ExtraFieldLength then exit; //error + //get comment + setlength(FileInfo.FileComment, cfhdr.FileCommentLen); + if Stream.read(FileInfo.FileComment[1], cfhdr.FileCommentLen) <> + cfhdr.FileCommentLen then exit; //error + FileInfo.FileComment := OemStrToAnsiStr(FileInfo.FileComment); + + //this is a block move of all the fixed fields (46 bytes total)... + move(cfhdr, FileInfo.cfh, sizeof(TCentralFileHeader)); + //simplify getting the password flag... + FileInfo^.PasswordUsed := Odd(FileInfo.cfh.Flag); + + //find the very first LocalHeader offset + //nb: they don't have to be in the same order as the CentralDirectory + if cfhdr.RelOffLocalHdr < fTrueSfxSize then + fTrueSfxSize := cfhdr.RelOffLocalHdr; + inc(i); + end; + //nb: A zip file may have simply been appended to the Sfx stub so + //the Header Offset values inaccurate. + //The TrueSfxSize is derived from the perceived offset of the first file + //plus the difference between the real and perceived EocHeader offsets. + if (fEocInfo.eoch.ThisDiskNo = 0) and (fTrueSfxSize < Stream.Size) then + fTrueSfxSize := fTrueSfxSize + (fEocInfo.EocOffset - + (fEocInfo.eoch.CentralOffset + fEocInfo.eoch.CentralSize)) else + fTrueSfxSize := 0; + result := true; + end; + //------------------------------------------------------------------- + +begin {LoadFileList} + + ClearFileList; + if Filename = '' then exit; //should never happen! + Stream := TFileStream.create(Filename,fmOpenRead or fmShareDenyWrite); + try + //get EOCHeader... + while (FindEOCHeaderOffset(Stream) = ERROR_VALUE) do + begin + Stream.free; + Stream := nil; + i := GetSpannedZipDiskNum(Filename); + if i = 0 then + raise ZipException.createfmt(s_not_a_zip_file,[Filename]); + + if application.messagebox(pchar(format(s_multidisk_prompt_last,[i])), + pchar(application.title), mb_okcancel or mb_iconinformation) <> idok then + exit; //cancelled + Stream := TFileStream.create(Filename,fmOpenRead or fmShareDenyWrite); + end; + + fEocInfo.EocOffset := stream.Position; + Stream.read(fEocInfo, sizeof(TEndOfCentralHeader)); + //several checks in case eoc.HeaderSig has been found eroneously... + if (fEocInfo.eoch.ThisDiskNo > 1000) or + (fEocInfo.eoch.CentralDiskNo > 1000) or + (fEocInfo.eoch.CentralSize > 1024* 1000) then + raise ZipException.createfmt(s_not_a_zip_file,[Filename]); + + //get the general zip comment (if there is one)... + SetLength(fEocInfo.ZipComment, fEocInfo.eoch.ZipCommentLen); + if Stream.read(fEocInfo.ZipComment[1], fEocInfo.eoch.ZipCommentLen) <> + fEocInfo.eoch.ZipCommentLen then fEocInfo.ZipComment := ''; + fEocInfo.ZipComment := OemStrToAnsiStr(fEocInfo.ZipComment); + + if (fEocInfo.eoch.TotalEntries = 0) then exit; //ie: empty zip file. + + //EOC Header has been found, now find Central header... + //and load the info into fFileList... + + //if a multiple disk archive, the CentralHeader may be on another disk ... + //and so, make sure the correct disk is inserted before proceeding. + //(nb: exits if the user selects [cancel] in the prompt dialog.) + if (fEocInfo.eoch.ThisDiskNo <> fEocInfo.eoch.CentralDiskNo) then + if not PromptMultiDiskNum(Filename, fEocInfo.eoch.CentralDiskNo) then exit; + + if not GetCentralHeaderInfo then + begin + ClearFileList; //CleanUp + raise ZipException.create(s_cfh_read_error); + end; + + finally + Stream.free; + end; +end; +//--------------------------------------------------------------------- + +//static variables used by ZCallback() +var + fn: string = ''; + BatchCount: longint = 0; // no. of files in batch + TotalBytes: longint = 0; // total uncompressed size of all files + BytesCounted: longint = 0; // total bytes counted in batch + SkippedCount: longint = 0; + +function ZCallback( ZCallBackRec: PZCallBackStruct ): LongBool; stdcall; export; +var + txt: string; + res: integer; +begin + + //if already cancelled don't bother me any more... + if not TZip(ZCallBackRec.Caller).fCancel then + with ZCallBackRec^, TZip(Caller) do + case ActionCode of + 1: begin + fn := msg; //save for progress event (ActionCode = 2) ... + if assigned(fZEDBeginFileEvent) then + fZEDBeginFileEvent(Caller, fn, Size, BatchCount, TotalBytes); + if fShowProgress and assigned(fProgressForm) then + TProgressForm(fProgressForm).Text := fn; + end; + + 2: //Size = size of each block just processed (usually <= 32k) + begin + inc(BytesCounted,Size); + if assigned(fZEDProgressEvent) then + fZEDProgressEvent(Caller, fn, Size, TotalBytes); + if fShowProgress and assigned(fProgressForm) then + TProgressForm(fProgressForm).ProgressPosition := BytesCounted; + end; + + 3: //end of a batch of ZIP/UNZIP operations. + //todo - check that SkippedCount works + begin + if Assigned(fZEDEndBatchEvent) then + fZEDEndBatchEvent(Caller, SkippedCount, BatchCount, TotalBytes); + if fShowProgress and assigned(fProgressForm) then + fProgressForm.hide; + end; + + 4: ; //used for debugging with breakpoint + //msg = routine status message - ErrorCode occasionally used + + 5: BatchCount := Size; //No. of Files in batch + + 6: begin + TotalBytes := Size; //Total bytes in batch + BytesCounted := 0; //reset + SkippedCount := 0; //reset + if fShowProgress and assigned(fProgressForm) then + TProgressForm(fProgressForm).ProgressMax := TotalBytes; + end; + + 7: ;//enables setting a new path+name just before zipping... + //get/set fullname using Msg, flag to change by returning ActionCode := 8; + //if Assigned(FOnSetNewName) then FOnSetNewName(Caller, Msg); + + 8: //wrong or no password. (if Odd(ErrorCode) then Add operation else Extract) + begin + txt := ''; + //Msg = filename... + if fShowProgress and assigned(fProgressForm) then + fProgressForm.hide; + txt := InputBox(application.title, + format(s_new_password_required, [StrPas(Msg)]),txt); + if fShowProgress and assigned(fProgressForm) then + fProgressForm.show; + if txt <> '' then + begin + StrPCopy(Msg,txt); //Msg = new password + ErrorCode := 1; //new attempt flagged + if Size > 0 then Dec(Size); //No. of retries + end else + begin + ErrorCode := 0; + Size := 0; + end; + end; + + 9: //CRC32 error... + begin + if fShowProgress and assigned(fProgressForm) then + fProgressForm.hide; + txt := format(s_crc_error_query_extract,[StrPas(Msg)]); + res := application.messagebox(pchar(txt),pchar(application.title), + mb_yesnocancel or mb_iconquestion or mb_defbutton2); + case res of + idcancel: fCancel := true; //cancel extract op. + idyes: ErrorCode := 1; + else ErrorCode := 0; //skip (2 = issue warnings) + end; + if fShowProgress and assigned(fProgressForm) and not fCancel then + fProgressForm.show; + end; + + 10: // Extract Overwrite check ... + if (fExtractOptions * [eoFreshen, eoUpdate, eoAskOverwrite] = []) then + Size := 1 //overwrite irrespective of file age + else if (fExtractOptions * [eoFreshen,eoUpdate] <> []) then + Size := (ErrorCode and $1) //overwrite if existing is older + else // if (eoAskOverwrite in fExtractOptions) then + begin + if fShowProgress and assigned(fProgressForm) then + fProgressForm.hide; + if Odd(ErrorCode) then //existing is older... + begin + txt := format(s_older_file_query_extract,[StrPas(Msg)]); + res := application.messagebox(pchar(txt),pchar(application.title), + mb_yesnocancel or mb_iconinformation or mb_defbutton1); + end else + begin //existing is newer... + txt := format(s_newer_file_query_extract,[StrPas(Msg)]); + res := application.messagebox(pchar(txt),pchar(application.title), + mb_yesnocancel or mb_iconstop or mb_defbutton2); + end; + case res of + idcancel: begin Size := 0; fCancel := true; end; //cancel extract + idyes: Size := 1; //continue with extract + else Size := 0; //skip this file only + end; + if fShowProgress and assigned(fProgressForm) and not FCancel then + fProgressForm.hide; + end; + + 11: // Extract(UnZip) was skipped and why ... + inc(SkippedCount); + //if Assigned( FOnExtractSkipped ) then + // FOnExtractSkipped(Caller, Msg, UnZipSkipTypes(Size)); + end; + + //If result = TRUE, the DLL will abort ASAP + Result := TZip(ZCallbackRec.Caller).fCancel; + Application.ProcessMessages; +end; +//-------------------------------------------------------------------------- + +procedure SetUnZipParams(UnZipParams: pUnZipParams; Owner: TZip); +begin + with UnZipParams^ do + begin + //nb: all zero initialized + Version := ZIP_VERSION; + Caller := Owner; + Quiet := True; + ZCallbackFunc := ZCallback; + TraceEnabled := False; + VerboseEnabled := False; + Quiet := True; + Comments := False; //supported external to dll + Convert := False; //ascii/EBCDIC conversion - not supported + + // ? recreate directory structure + Directories := eoWithPaths in Owner.fExtractOptions; + //These fields seems to be ignored by the dll and handled in ZCallback(). + Overwrite := (Owner.fExtractOptions * [eoFreshen, eoUpdate, eoTest] = []); + if eoUpdate in Owner.fExtractOptions then Update := True + else if eoFreshen in Owner.fExtractOptions then Freshen := True + else if eoTest in Owner.fExtractOptions then Test := True; + + PwdReqCount := 3; + Seven := $7; + end; +end; +//--------------------------------------------------------------------- + +function TZip.Extract: integer; +var + i: integer; + UnZipParams: pUnZipParams; + pUZFD: pUnzipFileData; +begin + result := 0; + fCancel := false; + if (fFileList.count = 0) then exit; + if fEocInfo.eoch.ThisDiskNo > 0 then //multi-disk zip archive ... + begin + application.messagebox(pchar(s_multidisk_op_error), + pchar(application.title),mb_iconinformation); + exit; + end; + + if (fExtractPath <> '') and not DirectoryExists(fExtractPath) then + begin + application.messagebox(pchar(format(s_extract_error_no_folder,[fExtractPath])), + pchar(application.title),mb_iconinformation); + exit; + end; + + if not LoadUnZipDll then + raise ZipException.createfmt(s_unable_to_load,['"UnzDll.dll".']); + + if fExtractPath = '' then + SetCurrentDir(extractfilepath(fFilename)) else + SetCurrentDir(fExtractPath); + + UnZipParams := AllocMem(sizeof(TUnZipParams)); //zero initialized + try + SetUnZipParams(UnZipParams,self); + UnZipParams.ZipFilename := pchar(fFilename); + if fPassword <> '' then UnZipParams.ZipPassword := pchar(fPassword); + UnZipParams.FileDataCount := fFileSpecList.count; + UnZipParams.UnzipFileData := AllocMem(sizeof(TUnzipFileData)*fFileSpecList.count); + try + pUZFD := UnZipParams.UnzipFileData; + for i := 0 to fFileSpecList.count-1 do + begin + pUZFD.fFileSpec := pchar(fFileSpecList[i]); + inc(pUZFD); + end; + + //DO IT HERE... + if not fShowProgress then + result := UnzipDLLExec(UnZipParams) + else + begin + fProgressForm := TProgressForm.createnew(self); + try + fProgressForm.show; + result := UnzipDLLExec(UnZipParams); + finally + fProgressForm.free; + fProgressForm := nil; + end; + end; + + finally + FreeMem(UnZipParams.UnzipFileData); + end; + finally + FreeMem(UnZipParams); + end; + fFileSpecList.clear; +end; +//--------------------------------------------------------------------- + +procedure SetZipParams(ZipParams: pZipParams; Owner: TZip; IsAdd: Boolean); +begin + with ZipParams^ do + begin + Version := ZIP_VERSION; // version we expect the DLL to be + Caller := Owner; // point to our VCL instance; returned in callback + Quiet := True; + ZCallbackFunc := ZCallback; // pass function to be called from DLL + Level := 9; //Compression level (0 - 9, 0=none and 9=best) + Seven := 7; + //The following are already initialized to zero (false)... + //TraceEnabled := False; + //VerboseEnabled := False; + //JunkSFX := False; // if True, convert input .EXE file to .ZIP + //ComprSpecial := False; // if True, try to compr already compressed files + //Volume := False; // if True, include volume label from root dir + //Extra := False; // if True, include extended file attributes-NOT SUPORTED + //UseDate := False; // if True, exclude files earlier than specified date + //CRLF_LF := False; // if True, translate text file CRLF to LF (if dest Unix) + //Handle := 0; + //LatestTime := False; // if True, make zipfile's timestamp same as newest file + //Move := False; // if True, beware! } + + if not IsAdd then //DELETE... + DeleteEntries := True + else + begin //ADD... + Grow := True; //Allow appending to zip file + + if (Owner.fAddPath <> '') and + DirectoryExists(Owner.fAddPath) then ChDir(Owner.fAddPath); + + //Update = add files as well as freshen + //Freshen = replace existing zipped files if newer + if (aoUpdate in Owner.fAddOptions) then + Update := true else + Freshen := aoFreshen in Owner.fAddOptions; + //? include system and hidden files... + SystemFiles := aoHiddenFiles in Owner.fAddOptions; + //force 8.3 filenames... + ForceDOS := aoForceDOS in Owner.fAddOptions; + Encrypt := (Owner.fPassword <> ''); + //Use the following together (ie: need directories if recursive) - + Recurse := aoRecursive in Owner.fAddOptions; + if Recurse then + JunkDir := false //include (relative) folder paths + else if not (aoWithFullPath in Owner.fAddOptions) then JunkDir := true; + //? make separate folder entries too ... + NoDirEntries := not (aoFolderEntries in Owner.fAddOptions); + end; + end; +end; +//--------------------------------------------------------------------- + +function TZip.Add: integer; +begin + result := DoAddDelete(true); + fAddPath := ''; +end; +//--------------------------------------------------------------------- + +function TZip.Delete: integer; +begin + result := DoAddDelete(false); +end; +//--------------------------------------------------------------------- + +function TZip.DoAddDelete(IsAdd: boolean): integer; +var + i: integer; + ZipParams: pZipParams; + pFD: pZipFileData; + MsgTxt, OemComment: string; +begin + + result := 0; + if fFilename = '' then + MsgTxt := s_no_zip_no_op + else if fFileSpecList.count = 0 then + MsgTxt := s_no_select_no_op + else if fEocInfo.eoch.ThisDiskNo > 0 then + MsgTxt := s_multidisk_op_error; + if MsgTxt <> '' then + begin + application.messagebox(pchar(MsgTxt),pchar(application.title),mb_iconinformation); + exit; + end; + + if not LoadZipDll then + raise ZipException.createfmt(s_unable_to_load,['"ZipDll.dll".']); + + fCancel := false; + ZipParams := AllocMem(sizeof(TZipParams)); //zero initialized + try + SetZipParams(ZipParams,self,IsAdd); + ZipParams.ZipFilename := pchar(fFilename); + ZipParams.TempPath := pchar(fTempPath); + OemComment := AnsiStrToOemStr(fEocInfo.ZipComment); + if (OemComment <> '') then + ZipParams.FileComment := pchar(OemComment); + if IsAdd and (fPassword <> '') then ZipParams.ZipPassword := pchar(fPassword); + ZipParams.FileDataCount := fFileSpecList.count; + ZipParams.FileData := AllocMem(sizeof(TZipFileData)*fFileSpecList.count); + try + pFD := ZipParams.FileData; + for i := 0 to fFileSpecList.count-1 do + begin + pFD.FileSpec := pchar(fFileSpecList[i]); + inc(pFD); + end; + + //DO IT HERE... + if not fShowProgress or not IsAdd then + result := ZipDLLExec(ZipParams) + else + begin + fProgressForm := TProgressForm.createnew(self); + try + fProgressForm.show; + result := ZipDLLExec(ZipParams); //ADD!!!!!!!!!!!!!!! + finally + fProgressForm.free; + fProgressForm := nil; + end; + end; + + finally + FreeMem(ZipParams.FileData); + end; + finally + FreeMem(ZipParams); + end; + fFileSpecList.clear; + //update filelist if any changes... + if result > 0 then + begin + LoadFileList; + if assigned(fOnContentsChanged) then fOnContentsChanged(self); + end; +end; +//--------------------------------------------------------------------- + +function TZip.OemStrToAnsiStr(const s: string): string; +begin + result := s; + if (s = '') or not fRequiresOemAnsiConversion then exit; + OemToChar(pchar(s),pchar(result)); +end; +//--------------------------------------------------------------------- + +function TZip.AnsiStrToOemStr(const s: string): string; +begin + result := s; + if (s = '') or not fRequiresOemAnsiConversion then exit; + CharToOem(pchar(s),pchar(result)); +end; +//--------------------------------------------------------------------- + +function TZip.GetFileComment(index: integer): string; +begin + if (index < 0) or (index >= fFileList.count) then + raise ZipException.create(s_index_range_error); + result := pFileInfo(fFileList[index]).FileComment; +end; +//--------------------------------------------------------------------- + +procedure TZip.SetFileComment(index: integer; comment: string); +var + Stream: TFileStream; + FileInfo: TFileInfo; + i, CommOffset, NewCommLen, FHOffset, CommDelta: integer; + MemStream: TMemoryStream; + Succeeded: boolean; +begin + //check there are files in the archive, and it's not a multiple disk archive. + if (fFilename = '') or (fEocInfo.eoch.ThisDiskNo > 0) or + (index < 0) or (index >= fFileList.Count) then exit; //error + + Succeeded := false; + Stream := TFileStream.create(fFilename,fmOpenReadWrite or fmShareDenyWrite); + try + Stream.Seek(fEocInfo.EocOffset - fEocInfo.eoch.CentralSize, soFromBeginning); + i := 0; + while Stream.Position < fEocInfo.EocOffset do + begin + if (Stream.Read(FileInfo, sizeof(TCentralFileHeader)) <> + sizeof(TCentralFileHeader)) or + (FileInfo.cfh.HeaderSig <> CENTRAL_HEADERSIG) then exit; //error + + if i = index then + begin + pFileInfo(fFileList[index]).FileComment := Comment; + Comment := AnsiStrToOemStr(Comment); + NewCommLen := length(comment); + //if no change in comment length then it's easy... + if FileInfo.cfh.FileCommentLen = NewCommLen then + begin + if FileInfo.cfh.FileCommentLen = 0 then exit; //ie: still empty + with FileInfo.cfh do Stream.Seek(FileNameLength+ExtraFieldLength,soFromCurrent); + Stream.Write(comment[1],NewCommLen); + end else + begin + //space has to be inserted/deleted to allow for the comment... + //so save a couple of file offsets... + FHOffset := Stream.Position - sizeof(TCentralFileHeader); + CommOffset := Stream.Position + + FileInfo.cfh.FileNameLength + FileInfo.cfh.ExtraFieldLength; + //how many bytes will be added to/deleted from the file... + CommDelta := NewCommLen - FileInfo.cfh.FileCommentLen; + //update the EndOfCentral Header to allow for the comment... + fEocInfo.eoch.CentralSize := fEocInfo.eoch.CentralSize + CommDelta; + Stream.Seek(fEocInfo.EocOffset,soFromBeginning); + Stream.Write(fEocInfo,SizeOf(TEndOfCentralHeader)); + //update to the new fEocInfo.EocOffset... + fEocInfo.EocOffset := fEocInfo.EocOffset + CommDelta; + //save everything after the old comment to a temp stream... + Stream.Seek(CommOffset+FileInfo.cfh.FileCommentLen,soFromBeginning); + MemStream := TMemoryStream.create; + try + MemStream.copyfrom(Stream,Stream.Size-Stream.Position); + //now update the central file header comment length... + Stream.Seek(FHOffset,soFromBeginning); + FileInfo.cfh.FileCommentLen := NewCommLen; + Stream.write(FileInfo.cfh,sizeof(TCentralFileHeader)); + Stream.Seek(CommOffset,soFromBeginning); + Stream.write(Comment[1],NewCommLen); + //copy the remaining stuff back to the stream... + Stream.copyfrom(MemStream,0); + //increase/truncate the file setting eof marker... + Stream.Size := Stream.Position; + finally + MemStream.free; + end; + end; + Succeeded := true; + break; + end; + inc(i); + with FileInfo.cfh do + Stream.Seek(FileNameLength+ExtraFieldLength+FileCommentLen,soFromCurrent); + continue; + end; + finally + Stream.free; + end; + if Succeeded and assigned(fOnContentsChanged) then + fOnContentsChanged(self); +end; +//--------------------------------------------------------------------- + +procedure TZip.SetZipComment(comment: string); +var + Stream: TFileStream; + ComLen: integer; +begin + if (fFilename = '') or (fEocInfo.eoch.ThisDiskNo > 0) then exit; //error + if comment = fEocInfo.ZipComment then exit; //nothing to change + Stream := TFileStream.create(fFilename,fmOpenReadWrite or fmShareDenyWrite); + try + //goto the start of the EndOfCentral Header... + Stream.Seek(fEocInfo.EocOffset,soFromBeginning); + fEocInfo.ZipComment := comment; + comment := AnsiStrToOemStr(comment); + ComLen := Length(comment); + fEocInfo.eoch.ZipCommentLen := ComLen; + if Stream.Write(fEocInfo,SizeOf(TEndOfCentralHeader)) <> + SizeOf(TEndOfCentralHeader) then exit; //error + Stream.write(comment[1],ComLen); + Stream.Size := Stream.Position; //set end of file marker. + finally + Stream.free; + end; + if assigned(fOnContentsChanged) then fOnContentsChanged(self); +end; +//--------------------------------------------------------------------- + +function TZip.GetZipComment: string; +begin + result := fEocInfo.ZipComment; +end; +//--------------------------------------------------------------------- + +const + BUFFER_SIZE = 1024 * 32; //32k buffer + +function TZip.MergeArchiveTo(const Target: string): boolean; +var + SrcStream, TrgtStream: TFileStream; + SrcSizesList: TList; + i, ReadToBuffer, CurrentDiskNo, LastDiskNo: integer; + TotalBytesToMerge: longint; + NewEoc: TEndOfCentralHeader; + NewCfhOffset: integer; + Cfh: TCentralFileHeader; + MultiSig: Cardinal; + buffer: pchar; +begin + result := false; + if (fFilename = '') or (Target = '') then exit; + if (fEocInfo.eoch.ThisDiskNo = 0) or (GetDiskType(fFilename) <> DRIVE_REMOVABLE) then + raise ZipException.create(s_need_multidisk_zip); + + TotalBytesToMerge := 0; + for i := 0 to fEocInfo.eoch.TotalEntries-1 do + with pFileInfo(fFileList[i]).cfh do + inc(TotalBytesToMerge, CompressedSize + FileNameLength + + ExtraFieldLength + cfh.FileCommentLen); + inc(TotalBytesToMerge,fEocInfo.eoch.CentralSize + + fEocInfo.eoch.ZipCommentLen + SizeOf(TEndOfCentralHeader)); + + //1. make sure that the target file will be on a local hard disk... + if GetDiskType(Target) <> DRIVE_FIXED then + raise ZipException.create(s_merge_only_to_fixed_disk); + + //2. find the first source disk ... + if application.messagebox(pchar(format(s_multidisk_prompt,[1])), + pchar(application.title), mb_okcancel or mb_iconinformation) <> IDOK then + exit; //false + if not PromptMultiDiskNum(fFilename,1) then exit; + + //3. loop through each source file, concatenating it into the target file + LastDiskNo := fEocInfo.eoch.ThisDiskNo+1; //fEocInfo.ThisDiskNo is zero based + CurrentDiskNo := 1; //CurrentDiskNo & LastDiskNo 1 based + + + //Each CentralFileHeader.RelOffLocalHdr must be adjusted + //so store a list of RelOffLocalHdr deltas... + SrcSizesList := TList.create; + //and to reduce the number of nested try-finally blocks... + SrcStream := nil; + TrgtStream := nil; + buffer := nil; + try + SrcStream := TFileStream.create(fFilename,fmOpenRead or fmShareDenyWrite); + TrgtStream := TFileStream.create(Target,fmCreate); + buffer := allocmem(BUFFER_SIZE); + //skip multidisk flag on first disk 1.. + SrcStream.read(MultiSig,sizeof(MultiSig)); + if MultiSig <> MULTIPLE_DISK_SIG then + raise ZipException.create(s_multidisk_sig_error);//error + + SrcSizesList.add(pointer(-4)); //we've just stripped a 4 byte MultiSig header + repeat //TOP OF LOOP + //read thru whole file in BUFFER_SIZE blocks copying to target file + screen.cursor := crHourglass; + try + repeat + ReadToBuffer := SrcStream.read(buffer[0],BUFFER_SIZE); + TrgtStream.write(buffer[0],ReadToBuffer); + if assigned(fMergeProgressEvent) then + fMergeProgressEvent(self,target,TrgtStream.position,TotalBytesToMerge); + application.processmessages; + until (ReadToBuffer <> BUFFER_SIZE); //end of file reached + finally + screen.cursor := crDefault; + end; + SrcSizesList.add(pointer(TrgtStream.Position)); + if CurrentDiskNo = LastDiskNo then break; //EXIT LOOP HERE + //get next disk here... + inc(CurrentDiskNo); + SrcStream.free; + SrcStream := nil; //just incase the TFileStream.create line fails... + if not PromptMultiDiskNum(fFilename,CurrentDiskNo) then exit; //cancelled + SrcStream := TFileStream.create(fFilename,fmOpenRead or fmShareDenyWrite); + until false; //BOTTOM OF LOOP + + //4. Update the target file EndOfCentral and Central Directories... + + //first copy the old Eoch + NewEoc := fEocInfo.eoch; + + //find the offset of the newly created target's CentralDirectoryHeader... + NewCfhOffset := TrgtStream.size - NewEoc.ZipCommentLen - + - sizeof(TEndOfCentralHeader) - NewEoc.CentralSize; + if NewCfhOffset < 0 then + raise ZipException.create(s_eoch_read_error); + + TrgtStream.seek(NewCfhOffset,soFromBeginning); + for i := 0 to NewEoc.TotalEntries-1 do + begin + TrgtStream.Read(Cfh,sizeof(TCentralFileHeader)); + if Cfh.HeaderSig <> CENTRAL_HEADERSIG then + raise ZipException.create(s_cfh_read_error); + TrgtStream.seek(-sizeof(Cfh),soFromCurrent); + //adjust LocalHeader offsets by values stored in SrcSizesList + inc(Cfh.RelOffLocalHdr,integer(SrcSizesList[Cfh.StartOnDisk])); + Cfh.StartOnDisk := 0; + TrgtStream.Write(Cfh,sizeof(TCentralFileHeader)); + TrgtStream.Seek(Cfh.FileNameLength+ + Cfh.ExtraFieldLength+Cfh.FileCommentLen, soFromCurrent); + end; + + NewEoc.ThisDiskNo := 0; + NewEoc.CentralDiskNo := 0; + NewEoc.CentralOffset := NewCfhOffset; + + //update Eoc header... + TrgtStream.write(NewEoc,sizeof(NewEoc)); + + finally + SrcSizesList.Free; + SrcStream.free; + TrgtStream.free; + if assigned(buffer) then freemem(buffer); + end; +end; +//--------------------------------------------------------------------- + +//This is a *very* long method but I'm not sure of the best way to break it up. +function TZip.SpanArchiveTo(const Target: string; + MaxBytesPerDisk, BytesToReserveDisk1: integer): boolean; +var + i, DiskNum, FreeSpace, DataRead, BytesRead, SfxDelta: integer; + TargetDrivePath, VolText: string; + SrcStream,TrgtStream: TFileStream; + MultiDiskSig: cardinal; + buffer: pchar; + Loc : TLocalHeader; + Cfh: TCentralFileHeader; + Eoc: TEndOfCentralHeader; + SavedCursor: TCursor; + + //------------------------------------------------------------------- + + function GetNextDisk(out SpaceAvailable: integer): boolean; + begin + result := false; + inc(DiskNum); + //Load a disk into drive and make sure it has space ... + if application.messagebox(pchar(format(s_multidisk_prompt, [DiskNum])), + pchar(application.title), mb_okcancel or mb_iconinformation) <> IDOK then + exit; //cancelled + SpaceAvailable := GetDiskFree(TargetDrivePath); + while (SpaceAvailable < 1024*256) do //bare minimum = 256k + begin + if application.messagebox(pchar(s_no_space_prompt), pchar(application.title), + mb_okcancel or mb_iconinformation) <> IDOK then exit; //cancelled + SpaceAvailable := GetDiskFree(TargetDrivePath); + end; + //set the disk's volume label ... + VolText := format('PKBACK# %0.3d',[DiskNum]); + if not SetVolumeLabel(pchar(TargetDrivePath),pchar(VolText)) then + raise ZipException.create(s_no_create_vol_label); + result := true; + end; + //------------------------------------------------------------------- + + function GetNextDiskWithNewTgtStream: boolean; + begin + TrgtStream.free; + TrgtStream := nil; + screen.cursor := SavedCursor; + result := GetNextDisk(FreeSpace); + if not result then exit; + screen.cursor := crHourglass; + TrgtStream := TFileStream.create(Target,fmCreate); + if MaxBytesPerDisk > 0 then + FreeSpace := min(FreeSpace,MaxBytesPerDisk); + end; + //------------------------------------------------------------------- + +begin + result := false; + if (fFilename = '') or (Target = '') then exit; + TargetDrivePath := AppendSlash(ExtractFileDrive(target)); + //1. check that the destination is a floppy... + if (GetDiskType(TargetDrivePath) <> DRIVE_REMOVABLE) then + raise ZipException.create(s_create_multdisk_on_floppies_only); + + //2. make sure the source is not a multiple disk archive too... + if (fEocInfo.eoch.ThisDiskNo > 0) or (GetDiskType(fFilename) = DRIVE_REMOVABLE) then + raise ZipException.create(s_source_file_cannot_be_on_floppy); + + //3. check space issues... + if (MaxBytesPerDisk > 0) then + begin + if MaxBytesPerDisk < 1024*256 then + raise ZipException.create(s_max_multidisk_at_least_256); + if MaxBytesPerDisk - BytesToReserveDisk1 < 1024*256 then + raise ZipException.create(s_min_space_disk1_at_least_256); + end; + + //4. Load the first disk into floppy, get free space & set volume label ... + DiskNum := 0; + if not GetNextDisk(FreeSpace) then exit; //also sets volume label here + if MaxBytesPerDisk > 0 then + FreeSpace := min(FreeSpace,MaxBytesPerDisk); + dec(FreeSpace,BytesToReserveDisk1); + + SavedCursor := screen.cursor; + buffer := nil; + TrgtStream := nil; + SrcStream := TFileStream.create(fFilename,fmOpenRead or fmShareDenyWrite); + try + TrgtStream := TFileStream.create(Target,fmCreate); + + //5. if the whole archive will fit on one disk, copy and exit ... + if FreeSpace > SrcStream.Size then + begin + if not SetVolumeLabel(pchar(TargetDrivePath),'') then + raise ZipException.create(s_no_create_vol_label); + TrgtStream.CopyFrom(SrcStream,0); + result := true; + exit; + end; + + buffer := allocmem(BUFFER_SIZE); + + //6. Write MULTIPLE_DISK_SIG. + MultiDiskSig := MULTIPLE_DISK_SIG; + TrgtStream.Write(MultiDiskSig,sizeof(MultiDiskSig)); + dec(FreeSpace,4); + + screen.cursor := crHourglass; + + //if the zip file (fFilename) has an SFX stub, then + //cfh.RelOffLocalHdr values may or may not be accurate... + SfxDelta := fEocInfo.EocOffset - + (fEocInfo.eoch.CentralOffset + fEocInfo.eoch.CentralSize); + + //7. Copy all [LocalHeader, Data & DataDescriptor] blocks ... + for i := 0 to fEocInfo.eoch.TotalEntries-1 do + begin + //Copy the local header... + SrcStream.seek(pFileInfo(fFileList[i]).cfh.RelOffLocalHdr + SfxDelta, soFromBeginning); + if SrcStream.read(Loc,SizeOf(TLocalHeader)) <> SizeOf(TLocalHeader) then + raise ZipException.create(s_localheader_read_error); + if Loc.HeaderSig <> LOCAL_HEADERSIG then + raise ZipException.create(s_localheader_read_error); + if FreeSpace < SizeOf(TLocalHeader)+Loc.FileNameLen+Loc.ExtraLen then + if not GetNextDiskWithNewTgtStream then exit; //ie: cancelled + + //save the diskNum & offset to update the target CentralDirectory later... + pFileInfo(fFileList[i]).Reserved1 := DiskNum-1; //zero based + pFileInfo(fFileList[i]).Reserved2 := TrgtStream.Position; + //if the Data Descriptor field is present in the source, it's not needed + //in the target file if the target's LocalHeader info is updated ... + if (Loc.Flag and $8) = $8 then + begin + Loc.Flag := Loc.Flag and not $8; + Loc.CRC32 := pFileInfo(fFileList[i]).cfh.CRC32; + Loc.ComprSize := pFileInfo(fFileList[i]).cfh.CompressedSize; + Loc.UnComprSize := pFileInfo(fFileList[i]).cfh.UncompressedSize; + end; + + if TrgtStream.Write(Loc,Sizeof(Loc))<> Sizeof(Loc) then + raise ZipException.create(s_localheader_write_error); + dec(FreeSpace,SizeOf(Loc)); + + //Copy Filename & Extra field... + BytesRead := Loc.FileNameLen+Loc.ExtraLen; + BytesRead := SrcStream.read(buffer[0],BytesRead); + BytesRead := TrgtStream.Write(buffer[0],BytesRead); + dec(FreeSpace,BytesRead); + if BytesRead <> Loc.FileNameLen+Loc.ExtraLen then + raise ZipException.create(s_localheader_write_error); + + //Copy file data... + DataRead := 0; + while (DataRead < Loc.ComprSize) do + begin + if FreeSpace = 0 then + if not GetNextDiskWithNewTgtStream then exit; + BytesRead := min(Loc.ComprSize-DataRead,BUFFER_SIZE); + BytesRead := min(BytesRead,FreeSpace); + BytesRead := SrcStream.read(buffer[0],BytesRead); + BytesRead := TrgtStream.Write(buffer[0],BytesRead); + inc(DataRead,BytesRead); + dec(FreeSpace,BytesRead); + if BytesRead = 0 then + raise ZipException.create(s_local_data_write_error); + if assigned(fSpanProgressEvent) then + fSpanProgressEvent(self,Target,SrcStream.Position,SrcStream.Size); + application.processmessages; + end; + end; + + //8. Copy Central Directory... + Move(fEocInfo.eoch ,Eoc, sizeof(TEndOfCentralHeader)); + Eoc.ThisDiskEntries := 0; + SrcStream.seek(fEocInfo.eoch.CentralOffset + SfxDelta, soFromBeginning); + for i := 0 to fEocInfo.eoch.TotalEntries-1 do + begin + if SrcStream.read(Cfh,SizeOf(TCentralFileHeader)) <> SizeOf(TCentralFileHeader) then + raise ZipException.create(s_cfh_read_error); + if Cfh.HeaderSig <> CENTRAL_HEADERSIG then + raise ZipException.create(s_cfh_read_error); + if FreeSpace < (SizeOf(TCentralFileHeader) + Cfh.FileNameLength + + Cfh.ExtraFieldLength + Cfh.FileCommentLen + SizeOf(TEndOfCentralHeader)) then + begin + if not GetNextDiskWithNewTgtStream then exit; + Eoc.ThisDiskEntries := 0; //reset this count + end; + + inc(Eoc.ThisDiskEntries); + if i = 0 then + begin + Eoc.CentralDiskNo := DiskNum-1; //zero based + Eoc.CentralOffset := TrgtStream.Position; + end; + Cfh.StartOnDisk := pFileInfo(fFileList[i]).Reserved1; + Cfh.RelOffLocalHdr := pFileInfo(fFileList[i]).Reserved2; + + if TrgtStream.Write(Cfh,Sizeof(Cfh))<> Sizeof(Cfh) then + raise ZipException.create(s_cfh_write_error); + dec(FreeSpace,SizeOf(Cfh)); + BytesRead := Cfh.FileNameLength + Cfh.ExtraFieldLength + Cfh.FileCommentLen; + if BytesRead > BUFFER_SIZE then + raise ZipException.create(s_cfh_write_error); + BytesRead := SrcStream.read(buffer[0],BytesRead); + BytesRead := TrgtStream.Write(buffer[0],BytesRead); + if BytesRead < Cfh.FileNameLength + Cfh.ExtraFieldLength + Cfh.FileCommentLen then + raise ZipException.create(s_cfh_write_error); + dec(FreeSpace,BytesRead); + end; + + //9. Copy EndOf Central Header (& main comment)... + Eoc.ThisDiskNo := DiskNum-1; //zero based. + if TrgtStream.Write(Eoc,SizeOf(TEndOfCentralHeader)) <> SizeOf(TEndOfCentralHeader) then + raise ZipException.create(s_eoch_write_error); + if Eoc.ZipCommentLen > 0 then + begin + SrcStream.seek(SizeOf(TEndOfCentralHeader),soFromCurrent); + if SrcStream.read(buffer[0],Eoc.ZipCommentLen) <> Eoc.ZipCommentLen then + raise ZipException.create(s_comment_read_error); + if TrgtStream.Write(buffer[0],Eoc.ZipCommentLen) <> Eoc.ZipCommentLen then + raise ZipException.create(s_comment_write_error); + end; + result := true; //ALL DONE!! + finally + screen.cursor := SavedCursor; + SrcStream.free; + TrgtStream.free; + if assigned(buffer) then freemem(buffer); + end; +end; +//--------------------------------------------------------------------- + +function StripSfxStub(const SfxExeFile, NewZipFile: string): boolean; +var + i, BytesRead, TrueSfxSize, EocOffset: integer; + SrcStream,TrgtStream: TFileStream; + Eoc: TEndOfCentralHeader; + cfh: TCentralFileHeader; + SavedCursor: TCursor; +begin + result := false; + if (not FileExists(SfxExeFile)) or (NewZipFile = '') then exit; + + SrcStream := nil; + TrgtStream := nil; + SavedCursor := screen.cursor; + screen.cursor := crHourglass; + try + SrcStream := TFileStream.create(SfxExeFile,fmOpenRead or fmShareDenyWrite); + TrgtStream := TFileStream.create(NewZipFile, fmCreate); //nb - no check for overwrite + + EocOffset := FindEOCHeaderOffset(SrcStream); + if (EocOffset = ERROR_VALUE) then + raise ZipException.Createfmt(s_not_an_sfx_file, [SfxExeFile]); + if SrcStream.Read(Eoc, sizeof(TEndOfCentralHeader)) <> sizeof(TEndOfCentralHeader) then + raise ZipException.Create(s_sfx_read_error); + + if (Eoc.ThisDiskNo > 0) then exit; //Multi disk archives cannot be SfxExes! + + //get the relative offset of the first file in the archive ... + SrcStream.seek(EocOffset - Eoc.CentralSize, soFromBeginning); + SrcStream.read(cfh,sizeof(TCentralFileHeader)); + if cfh.HeaderSig <> CENTRAL_HEADERSIG then + raise ZipException.Create(s_sfx_read_error); + + {TODO - nb: the central directory order does not have to reflect local order} + TrueSfxSize := cfh.RelOffLocalHdr + + (EocOffset - (Eoc.CentralOffset + Eoc.CentralSize)); + if TrueSfxSize < 1 then exit; //not an Exe. + + //skip over the Sfx stub... + SrcStream.Seek(TrueSfxSize,soFromBeginning); + //copy the rest of the file... + BytesRead := TrgtStream.copyfrom(SrcStream, SrcStream.size-TrueSfxSize); + if BytesRead <> SrcStream.size-TrueSfxSize then exit; //error + + //now fix up the central directory offsets if necessary... + if cfh.RelOffLocalHdr <> 0 then + begin + Eoc.CentralOffset := Eoc.CentralOffset - TrueSfxSize; + TrgtStream.Seek(EocOffset-TrueSfxSize, soFromBeginning); + TrgtStream.Write(Eoc,sizeof(TEndOfCentralHeader)); + TrgtStream.Seek(Eoc.CentralOffset, soFromBeginning); + for i := 0 to Eoc.TotalEntries-1 do + begin + TrgtStream.read(cfh,sizeof(TCentralFileHeader)); + if cfh.HeaderSig <> CENTRAL_HEADERSIG then exit; //error + cfh.RelOffLocalHdr := cfh.RelOffLocalHdr - TrueSfxSize; + TrgtStream.Seek(-sizeof(TCentralFileHeader), soFromCurrent); + TrgtStream.write(cfh,sizeof(TCentralFileHeader)); + //go to next central file header... + TrgtStream.Seek(cfh.FileNameLength+ + cfh.ExtraFieldLength+cfh.FileCommentLen, soFromCurrent); + end; + end; + result := true; //all ok if we get this far. + finally + SrcStream.free; + TrgtStream.free; + screen.cursor := SavedCursor; + end; +end; +//-------------------------------------------------------------------------- +//--------------------------------------------------------------------- + +end. diff --git a/niftiview7/gzio/Ziputils.pas b/niftiview7/gzio/Ziputils.pas new file mode 100755 index 0000000..1c573bf --- /dev/null +++ b/niftiview7/gzio/Ziputils.pas @@ -0,0 +1,335 @@ +Unit ziputils; + +{ ziputils.pas - IO on .zip files using zlib + - definitions, declarations and routines used by both + zip.pas and unzip.pas + The file IO is implemented here. + + based on work by Gilles Vollant + + March 23th, 2000, + Copyright (C) 2000 Jacques Nomssi Nzali } + +interface + +{$undef UseStream} +{$ifdef WIN32} + {$define Delphi} + {$ifdef UseStream} + {$define Streams} + {$endif} +{$endif} + +uses + {$ifdef Delphi} + classes, SysUtils, + {$endif} + zutil; + +{ -------------------------------------------------------------- } +{$ifdef Streams} +type + FILEptr = TFileStream; +{$else} +type + FILEptr = ^file; +{$endif} +type + seek_mode = (SEEK_SET, SEEK_CUR, SEEK_END); + open_mode = (fopenread, fopenwrite, fappendwrite); + +function fopen(filename : PChar; mode : open_mode) : FILEptr; + +procedure fclose(fp : FILEptr); + +function fseek(fp : FILEptr; recPos : uInt; mode : seek_mode) : int; + +function fread(buf : voidp; recSize : uInt; + recCount : uInt; fp : FILEptr) : uInt; + +function fwrite(buf : voidp; recSize : uInt; + recCount : uInt; fp : FILEptr) : uInt; + +function ftell(fp : FILEptr) : uInt; { ZIP } + +function feof(fp : FILEptr) : uInt; { MiniZIP } + +{ ------------------------------------------------------------------- } + +type + zipFile = voidp; + unzFile = voidp; +type + z_off_t = long; + +{ tm_zip contain date/time info } +type + tm_zip = record + tm_sec : uInt; { seconds after the minute - [0,59] } + tm_min : uInt; { minutes after the hour - [0,59] } + tm_hour : uInt; { hours since midnight - [0,23] } + tm_mday : uInt; { day of the month - [1,31] } + tm_mon : uInt; { months since January - [0,11] } + tm_year : uInt; { years - [1980..2044] } + end; + + tm_unz = tm_zip; + +const + Z_BUFSIZE = (16384); + Z_MAXFILENAMEINZIP = (256); + +const + CENTRALHEADERMAGIC = $02014b50; + +const + SIZECENTRALDIRITEM = $2e; + SIZEZIPLOCALHEADER = $1e; + +function ALLOC(size : int) : voidp; + +procedure TRYFREE(p : voidp); + +const + Paszip_copyright : PChar = ' Paszip Copyright 2000 Jacques Nomssi Nzali '; + +implementation + +function ALLOC(size : int) : voidp; +begin + ALLOC := zcalloc (NIL, size, 1); +end; + +procedure TRYFREE(p : voidp); +begin + if Assigned(p) then + zcfree(NIL, p); +end; + +{$ifdef Streams} +{ ---------------------------------------------------------------- } + +function fopen(filename : PChar; mode : open_mode) : FILEptr; +var + fp : FILEptr; +begin + fp := NIL; + try + Case mode of + fopenread: fp := TFileStream.Create(filename, fmOpenRead); + fopenwrite: fp := TFileStream.Create(filename, fmCreate); + fappendwrite : + begin + fp := TFileStream.Create(filename, fmOpenReadWrite); + fp.Seek(soFromEnd, 0); + end; + end; + except + on EFOpenError do + fp := NIL; + end; + fopen := fp; +end; + +procedure fclose(fp : FILEptr); +begin + fp.Free; +end; + +function fread(buf : voidp; + recSize : uInt; + recCount : uInt; + fp : FILEptr) : uInt; +var + totalSize, readcount : uInt; +begin + if Assigned(buf) then + begin + totalSize := recCount * uInt(recSize); + readCount := fp.Read(buf^, totalSize); + if (readcount <> totalSize) then + fread := readcount div recSize + else + fread := recCount; + end + else + fread := 0; +end; + +function fwrite(buf : voidp; + recSize : uInt; + recCount : uInt; + fp : FILEptr) : uInt; +var + totalSize, written : uInt; +begin + if Assigned(buf) then + begin + totalSize := recCount * uInt(recSize); + written := fp.Write(buf^, totalSize); + if (written <> totalSize) then + fwrite := written div recSize + else + fwrite := recCount; + end + else + fwrite := 0; +end; + +function fseek(fp : FILEptr; + recPos : uInt; + mode : seek_mode) : int; +const + fsmode : array[seek_mode] of Word + = (soFromBeginning, soFromCurrent, soFromEnd); +begin + fp.Seek(recPos, fsmode[mode]); + fseek := 0; { = 0 for success } +end; + +function ftell(fp : FILEptr) : uInt; +begin + ftell := fp.Position; +end; + +function feof(fp : FILEptr) : uInt; +begin + feof := 0; + if Assigned(fp) then + if fp.Position = fp.Size then + feof := 1 + else + feof := 0; +end; + +{$else} +{ ---------------------------------------------------------------- } + +{$HINTS OFF} +function fopen(filename : PChar; mode : open_mode) : FILEptr; +var + fp : FILEptr; + OldFileMode : byte; +begin + fp := NIL; + OldFileMode := FileMode; + + GetMem(fp, SizeOf(file)); + Assign(fp^, filename); + {$i-} + Case mode of + fopenread: + begin + FileMode := 0; + Reset(fp^, 1); + end; + fopenwrite: + begin + FileMode := 1; + ReWrite(fp^, 1); + end; + fappendwrite : + begin + FileMode := 2; + Reset(fp^, 1); + Seek(fp^, FileSize(fp^)); + end; + end; + FileMode := OldFileMode; + if IOresult<>0 then + begin + FreeMem(fp, SizeOf(file)); + fp := NIL; + end; + + fopen := fp; +end; +{$HINTS ON} + +procedure fclose(fp : FILEptr); +begin + if Assigned(fp) then + begin + {$i-} + system.close(fp^); + if IOresult=0 then; + FreeMem(fp, SizeOf(file)); + end; +end; + +function fread(buf : voidp; + recSize : uInt; + recCount : uInt; + fp : FILEptr) : uInt; +var + totalSize, readcount : uInt; +begin + if Assigned(buf) then + begin + totalSize := recCount * uInt(recSize); + {$i-} + system.BlockRead(fp^, buf^, totalSize, readcount); + if (readcount <> totalSize) then + fread := readcount div recSize + else + fread := recCount; + end + else + fread := 0; +end; + +function fwrite(buf : voidp; + recSize : uInt; + recCount : uInt; + fp : FILEptr) : uInt; +var + totalSize, written : uInt; +begin + if Assigned(buf) then + begin + totalSize := recCount * uInt(recSize); + {$i-} + system.BlockWrite(fp^, buf^, totalSize, written); + if (written <> totalSize) then + fwrite := written div recSize + else + fwrite := recCount; + end + else + fwrite := 0; +end; + +function fseek(fp : FILEptr; + recPos : uInt; + mode : seek_mode) : int; +begin + {$i-} + case mode of + SEEK_SET : system.Seek(fp^, recPos); + {$WARNINGS OFF} + SEEK_CUR : system.Seek(fp^, FilePos(fp^)+recPos); + SEEK_END : system.Seek(fp^, FileSize(fp^)-1-recPos); { ?? check } + {$WARNINGS ON} + end; + fseek := IOresult; { = 0 for success } +end; + +function ftell(fp : FILEptr) : uInt; +begin + ftell := FilePos(fp^); +end; + +function feof(fp : FILEptr) : uInt; +begin + feof := 0; + if Assigned(fp) then + if eof(fp^) then + feof := 1 + else + feof := 0; +end; + +{$endif} +{ ---------------------------------------------------------------- } + +end. diff --git a/niftiview7/gzio/Zlib.pas b/niftiview7/gzio/Zlib.pas new file mode 100755 index 0000000..b8316e8 --- /dev/null +++ b/niftiview7/gzio/Zlib.pas @@ -0,0 +1,523 @@ +Unit Zlib; + + +{ Original: + zlib.h -- interface of the 'zlib' general purpose compression library + version 1.1.0, Feb 24th, 1998 + + Copyright (C) 1995-1998 Jean-loup Gailly and Mark Adler + + This software is provided 'as-is', without any express or implied + warranty. In no event will the authors be held liable for any damages + arising from the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + 3. This notice may not be removed or altered from any source distribution. + + Jean-loup Gailly Mark Adler + jloup@gzip.org madler@alumni.caltech.edu + + + The data format used by the zlib library is described by RFCs (Request for + Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt + (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). + + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil; + +{ zconf.h -- configuration of the zlib compression library } +{ zutil.c -- target dependent utility functions for the compression library } + +{ The 'zlib' compression library provides in-memory compression and + decompression functions, including integrity checks of the uncompressed + data. This version of the library supports only one compression method + (deflation) but other algorithms will be added later and will have the same + stream interface. + + Compression can be done in a single step if the buffers are large + enough (for example if an input file is mmap'ed), or can be done by + repeated calls of the compression function. In the latter case, the + application must provide more input and/or consume the output + (providing more output space) before each call. + + The library also supports reading and writing files in gzip (.gz) format + with an interface similar to that of stdio. + + The library does not install any signal handler. The decoder checks + the consistency of the compressed data, so the library should never + crash even in case of corrupted input. } + + + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{ Maximum value for memLevel in deflateInit2 } +{$ifdef MAXSEG_64K} + {$IFDEF VER70} + const + MAX_MEM_LEVEL = 7; + DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel } + {$ELSE} + const + MAX_MEM_LEVEL = 8; + DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel } + {$ENDIF} +{$else} +const + MAX_MEM_LEVEL = 9; + DEF_MEM_LEVEL = 8; { if MAX_MEM_LEVEL > 8 } +{$endif} + +{ Maximum value for windowBits in deflateInit2 and inflateInit2 } +const +{$IFDEF VER70} + MAX_WBITS = 14; { 32K LZ77 window } +{$ELSE} + MAX_WBITS = 15; { 32K LZ77 window } +{$ENDIF} + +{ default windowBits for decompression. MAX_WBITS is for compression only } +const + DEF_WBITS = MAX_WBITS; + +{ The memory requirements for deflate are (in bytes): + 1 shl (windowBits+2) + 1 shl (memLevel+9) + that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) + plus a few kilobytes for small objects. For example, if you want to reduce + the default memory requirements from 256K to 128K, compile with + DMAX_WBITS=14 DMAX_MEM_LEVEL=7 + Of course this will generally degrade compression (there's no free lunch). + + The memory requirements for inflate are (in bytes) 1 shl windowBits + that is, 32K for windowBits=15 (default value) plus a few kilobytes + for small objects. } + + +{ Huffman code lookup table entry--this entry is four bytes for machines + that have 16-bit pointers (e.g. PC's in the small or medium model). } + +type + pInflate_huft = ^inflate_huft; + inflate_huft = Record + Exop, { number of extra bits or operation } + bits : Byte; { number of bits in this code or subcode } + {pad : uInt;} { pad structure to a power of 2 (4 bytes for } + { 16-bit, 8 bytes for 32-bit int's) } + base : uInt; { literal, length base, or distance base } + { or table offset } + End; + +type + huft_field = Array[0..(MaxMemBlock div SizeOf(inflate_huft))-1] of inflate_huft; + huft_ptr = ^huft_field; +type + ppInflate_huft = ^pInflate_huft; + +type + inflate_codes_mode = ( { waiting for "i:"=input, "o:"=output, "x:"=nothing } + START, { x: set up for LEN } + LEN, { i: get length/literal/eob next } + LENEXT, { i: getting length extra (have base) } + DIST, { i: get distance next } + DISTEXT, { i: getting distance extra } + COPYZ, { o: copying bytes in window, waiting for space } + LIT, { o: got literal, waiting for output space } + WASH, { o: got eob, possibly still output waiting } + ZEND, { x: got eob and all data flushed } + BADCODE); { x: got error } + +{ inflate codes private state } +type + pInflate_codes_state = ^inflate_codes_state; + inflate_codes_state = record + + mode : inflate_codes_mode; { current inflate_codes mode } + + { mode dependent information } + len : uInt; + sub : record { submode } + Case Byte of + 0:(code : record { if LEN or DIST, where in tree } + tree : pInflate_huft; { pointer into tree } + need : uInt; { bits needed } + end); + 1:(lit : uInt); { if LIT, literal } + 2:(copy: record { if EXT or COPY, where and how much } + get : uInt; { bits to get for extra } + dist : uInt; { distance back to copy from } + end); + end; + + { mode independent information } + lbits : Byte; { ltree bits decoded per branch } + dbits : Byte; { dtree bits decoder per branch } + ltree : pInflate_huft; { literal/length/eob tree } + dtree : pInflate_huft; { distance tree } + end; + +type + check_func = function(check : uLong; + buf : pBytef; + {const buf : array of byte;} + len : uInt) : uLong; +type + inflate_block_mode = + (ZTYPE, { get type bits (3, including end bit) } + LENS, { get lengths for stored } + STORED, { processing stored block } + TABLE, { get table lengths } + BTREE, { get bit lengths tree for a dynamic block } + DTREE, { get length, distance trees for a dynamic block } + CODES, { processing fixed or dynamic block } + DRY, { output remaining window bytes } + BLKDONE, { finished last block, done } + BLKBAD); { got a data error--stuck here } + +type + pInflate_blocks_state = ^inflate_blocks_state; + +{ inflate blocks semi-private state } + inflate_blocks_state = record + + mode : inflate_block_mode; { current inflate_block mode } + + { mode dependent information } + sub : record { submode } + case Byte of + 0:(left : uInt); { if STORED, bytes left to copy } + 1:(trees : record { if DTREE, decoding info for trees } + table : uInt; { table lengths (14 bits) } + index : uInt; { index into blens (or border) } + blens : PuIntArray; { bit lengths of codes } + bb : uInt; { bit length tree depth } + tb : pInflate_huft; { bit length decoding tree } + end); + 2:(decode : record { if CODES, current state } + tl : pInflate_huft; + td : pInflate_huft; { trees to free } + codes : pInflate_codes_state; + end); + end; + last : boolean; { true if this block is the last block } + + { mode independent information } + bitk : uInt; { bits in bit buffer } + bitb : uLong; { bit buffer } + hufts : huft_ptr; {pInflate_huft;} { single malloc for tree space } + window : pBytef; { sliding window } + zend : pBytef; { one byte after sliding window } + read : pBytef; { window read pointer } + write : pBytef; { window write pointer } + checkfn : check_func; { check function } + check : uLong; { check on output } + end; + +type + inflate_mode = ( + METHOD, { waiting for method byte } + FLAG, { waiting for flag byte } + DICT4, { four dictionary check bytes to go } + DICT3, { three dictionary check bytes to go } + DICT2, { two dictionary check bytes to go } + DICT1, { one dictionary check byte to go } + DICT0, { waiting for inflateSetDictionary } + BLOCKS, { decompressing blocks } + CHECK4, { four check bytes to go } + CHECK3, { three check bytes to go } + CHECK2, { two check bytes to go } + CHECK1, { one check byte to go } + DONE, { finished check, done } + BAD); { got an error--stay here } + +{ inflate private state } +type + pInternal_state = ^internal_state; { or point to a deflate_state record } + internal_state = record + + mode : inflate_mode; { current inflate mode } + + { mode dependent information } + sub : record { submode } + case byte of + 0:(method : uInt); { if FLAGS, method byte } + 1:(check : record { if CHECK, check values to compare } + was : uLong; { computed check value } + need : uLong; { stream check value } + end); + 2:(marker : uInt); { if BAD, inflateSync's marker bytes count } + end; + + { mode independent information } + nowrap : boolean; { flag for no wrapper } + wbits : uInt; { log2(window size) (8..15, defaults to 15) } + blocks : pInflate_blocks_state; { current inflate_blocks state } + end; + +type + alloc_func = function(opaque : voidpf; items : uInt; size : uInt) : voidpf; + free_func = procedure(opaque : voidpf; address : voidpf); + +type + z_streamp = ^z_stream; + z_stream = record + next_in : pBytef; { next input byte } + avail_in : uInt; { number of bytes available at next_in } + total_in : uLong; { total nb of input bytes read so far } + + next_out : pBytef; { next output byte should be put there } + avail_out : uInt; { remaining free space at next_out } + total_out : uLong; { total nb of bytes output so far } + + msg : string[255]; { last error message, '' if no error } + state : pInternal_state; { not visible by applications } + + zalloc : alloc_func; { used to allocate the internal state } + zfree : free_func; { used to free the internal state } + opaque : voidpf; { private data object passed to zalloc and zfree } + + data_type : int; { best guess about the data type: ascii or binary } + adler : uLong; { adler32 value of the uncompressed data } + reserved : uLong; { reserved for future use } + end; + + +{ The application must update next_in and avail_in when avail_in has + dropped to zero. It must update next_out and avail_out when avail_out + has dropped to zero. The application must initialize zalloc, zfree and + opaque before calling the init function. All other fields are set by the + compression library and must not be updated by the application. + + The opaque value provided by the application will be passed as the first + parameter for calls of zalloc and zfree. This can be useful for custom + memory management. The compression library attaches no meaning to the + opaque value. + + zalloc must return Z_NULL if there is not enough memory for the object. + On 16-bit systems, the functions zalloc and zfree must be able to allocate + exactly 65536 bytes, but will not be required to allocate more than this + if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, + pointers returned by zalloc for objects of exactly 65536 bytes *must* + have their offset normalized to zero. The default allocation function + provided by this library ensures this (see zutil.c). To reduce memory + requirements and avoid any allocation of 64K objects, at the expense of + compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h). + + The fields total_in and total_out can be used for statistics or + progress reports. After compression, total_in holds the total size of + the uncompressed data and may be saved for use in the decompressor + (particularly if the decompressor wants to decompress everything in + a single step). } + +const { constants } + Z_NO_FLUSH = 0; + Z_PARTIAL_FLUSH = 1; + Z_SYNC_FLUSH = 2; + Z_FULL_FLUSH = 3; + Z_FINISH = 4; +{ Allowed flush values; see deflate() below for details } + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = (-1); + Z_STREAM_ERROR = (-2); + Z_DATA_ERROR = (-3); + Z_MEM_ERROR = (-4); + Z_BUF_ERROR = (-5); + Z_VERSION_ERROR = (-6); +{ Return codes for the compression/decompression functions. Negative + values are errors, positive values are used for special but normal events.} + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = (-1); +{ compression levels } + + Z_FILTERED = 1; + Z_HUFFMAN_ONLY = 2; + Z_DEFAULT_STRATEGY = 0; +{ compression strategy; see deflateInit2() below for details } + + Z_BINARY = 0; + Z_ASCII = 1; + Z_UNKNOWN = 2; +{ Possible values of the data_type field } + + Z_DEFLATED = 8; +{ The deflate compression method (the only one supported in this version) } + + Z_NULL = NIL; { for initializing zalloc, zfree, opaque } + + {$IFDEF GZIO} +var + errno : int; + {$ENDIF} + + { common constants } + + +{ The three kinds of block type } +const + STORED_BLOCK = 0; + STATIC_TREES = 1; + DYN_TREES = 2; +{ The minimum and maximum match lengths } +const + MIN_MATCH = 3; +{$ifdef MAX_MATCH_IS_258} + MAX_MATCH = 258; +{$else} + MAX_MATCH = ??; { deliberate syntax error } +{$endif} + +const + PRESET_DICT = $20; { preset dictionary flag in zlib header } + + + {$IFDEF DEBUG} +// procedure Assert(cond : boolean; msg : string); + {$ENDIF} + + procedure Trace(x : string); + procedure Tracev(x : string); + procedure Tracevv(x : string); + procedure Tracevvv(x : string); + procedure Tracec(c : boolean; x : string); + procedure Tracecv(c : boolean; x : string); + +function zlibVersion : string; +{ The application can compare zlibVersion and ZLIB_VERSION for consistency. + If the first character differs, the library code actually used is + not compatible with the zlib.h header file used by the application. + This check is automatically made by deflateInit and inflateInit. } + +function zError(err : int) : string; + +function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; + +procedure ZFREE (var strm : z_stream; ptr : voidpf); + +procedure TRY_FREE (var strm : z_stream; ptr : voidpf); + +const + ZLIB_VERSION : string[10] = '1.1.2'; + +const + z_errbase = Z_NEED_DICT; + z_errmsg : Array[0..9] of string[21] = { indexed by 2-zlib_error } + ('need dictionary', { Z_NEED_DICT 2 } + 'stream end', { Z_STREAM_END 1 } + '', { Z_OK 0 } + 'file error', { Z_ERRNO (-1) } + 'stream error', { Z_STREAM_ERROR (-2) } + 'data error', { Z_DATA_ERROR (-3) } + 'insufficient memory', { Z_MEM_ERROR (-4) } + 'buffer error', { Z_BUF_ERROR (-5) } + 'incompatible version',{ Z_VERSION_ERROR (-6) } + ''); +const + z_verbose : int = 1; + +{$IFDEF DEBUG} +procedure z_error (m : string); +{$ENDIF} + +implementation + +function zError(err : int) : string; +begin + zError := z_errmsg[Z_NEED_DICT-err]; +end; + +function zlibVersion : string; +begin + zlibVersion := ZLIB_VERSION; +end; + +//procedure z_error (m : string); +//begin +// WriteLn(output, m); +// Write('Zlib - Halt...'); +// ReadLn; +// Halt(1); +//end; + +//procedure Assert(cond : boolean; msg : string); +//begin +// if not cond then +// z_error(msg); +//end; + +procedure Trace(x : string); +begin + WriteLn(x); +end; + +procedure Tracev(x : string); +begin + if (z_verbose>0) then + WriteLn(x); +end; + +procedure Tracevv(x : string); +begin + if (z_verbose>1) then + WriteLn(x); +end; + +procedure Tracevvv(x : string); +begin + if (z_verbose>2) then + WriteLn(x); +end; + +procedure Tracec(c : boolean; x : string); +begin + if (z_verbose>0) and (c) then + WriteLn(x); +end; + +procedure Tracecv(c : boolean; x : string); +begin + if (z_verbose>1) and c then + WriteLn(x); +end; + +function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; +begin + ZALLOC := strm.zalloc(strm.opaque, items, size); +end; + +procedure ZFREE (var strm : z_stream; ptr : voidpf); +begin + strm.zfree(strm.opaque, ptr); +end; + +procedure TRY_FREE (var strm : z_stream; ptr : voidpf); +begin + {if @strm <> Z_NULL then} + strm.zfree(strm.opaque, ptr); +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/Zlib_old.pas b/niftiview7/gzio/Zlib_old.pas new file mode 100755 index 0000000..357f51f --- /dev/null +++ b/niftiview7/gzio/Zlib_old.pas @@ -0,0 +1,523 @@ +Unit Zlib; + + +{ Original: + zlib.h -- interface of the 'zlib' general purpose compression library + version 1.1.0, Feb 24th, 1998 + + Copyright (C) 1995-1998 Jean-loup Gailly and Mark Adler + + This software is provided 'as-is', without any express or implied + warranty. In no event will the authors be held liable for any damages + arising from the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + 3. This notice may not be removed or altered from any source distribution. + + Jean-loup Gailly Mark Adler + jloup@gzip.org madler@alumni.caltech.edu + + + The data format used by the zlib library is described by RFCs (Request for + Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt + (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). + + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil; + +{ zconf.h -- configuration of the zlib compression library } +{ zutil.c -- target dependent utility functions for the compression library } + +{ The 'zlib' compression library provides in-memory compression and + decompression functions, including integrity checks of the uncompressed + data. This version of the library supports only one compression method + (deflation) but other algorithms will be added later and will have the same + stream interface. + + Compression can be done in a single step if the buffers are large + enough (for example if an input file is mmap'ed), or can be done by + repeated calls of the compression function. In the latter case, the + application must provide more input and/or consume the output + (providing more output space) before each call. + + The library also supports reading and writing files in gzip (.gz) format + with an interface similar to that of stdio. + + The library does not install any signal handler. The decoder checks + the consistency of the compressed data, so the library should never + crash even in case of corrupted input. } + + + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{ Maximum value for memLevel in deflateInit2 } +{$ifdef MAXSEG_64K} + {$IFDEF VER70} + const + MAX_MEM_LEVEL = 7; + DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel } + {$ELSE} + const + MAX_MEM_LEVEL = 8; + DEF_MEM_LEVEL = MAX_MEM_LEVEL; { default memLevel } + {$ENDIF} +{$else} +const + MAX_MEM_LEVEL = 9; + DEF_MEM_LEVEL = 8; { if MAX_MEM_LEVEL > 8 } +{$endif} + +{ Maximum value for windowBits in deflateInit2 and inflateInit2 } +const +{$IFDEF VER70} + MAX_WBITS = 14; { 32K LZ77 window } +{$ELSE} + MAX_WBITS = 15; { 32K LZ77 window } +{$ENDIF} + +{ default windowBits for decompression. MAX_WBITS is for compression only } +const + DEF_WBITS = MAX_WBITS; + +{ The memory requirements for deflate are (in bytes): + 1 shl (windowBits+2) + 1 shl (memLevel+9) + that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) + plus a few kilobytes for small objects. For example, if you want to reduce + the default memory requirements from 256K to 128K, compile with + DMAX_WBITS=14 DMAX_MEM_LEVEL=7 + Of course this will generally degrade compression (there's no free lunch). + + The memory requirements for inflate are (in bytes) 1 shl windowBits + that is, 32K for windowBits=15 (default value) plus a few kilobytes + for small objects. } + + +{ Huffman code lookup table entry--this entry is four bytes for machines + that have 16-bit pointers (e.g. PC's in the small or medium model). } + +type + pInflate_huft = ^inflate_huft; + inflate_huft = Record + Exop, { number of extra bits or operation } + bits : Byte; { number of bits in this code or subcode } + {pad : uInt;} { pad structure to a power of 2 (4 bytes for } + { 16-bit, 8 bytes for 32-bit int's) } + base : uInt; { literal, length base, or distance base } + { or table offset } + End; + +type + huft_field = Array[0..(MaxMemBlock div SizeOf(inflate_huft))-1] of inflate_huft; + huft_ptr = ^huft_field; +type + ppInflate_huft = ^pInflate_huft; + +type + inflate_codes_mode = ( { waiting for "i:"=input, "o:"=output, "x:"=nothing } + START, { x: set up for LEN } + LEN, { i: get length/literal/eob next } + LENEXT, { i: getting length extra (have base) } + DIST, { i: get distance next } + DISTEXT, { i: getting distance extra } + COPY, { o: copying bytes in window, waiting for space } + LIT, { o: got literal, waiting for output space } + WASH, { o: got eob, possibly still output waiting } + ZEND, { x: got eob and all data flushed } + BADCODE); { x: got error } + +{ inflate codes private state } +type + pInflate_codes_state = ^inflate_codes_state; + inflate_codes_state = record + + mode : inflate_codes_mode; { current inflate_codes mode } + + { mode dependent information } + len : uInt; + sub : record { submode } + Case Byte of + 0:(code : record { if LEN or DIST, where in tree } + tree : pInflate_huft; { pointer into tree } + need : uInt; { bits needed } + end); + 1:(lit : uInt); { if LIT, literal } + 2:(copy: record { if EXT or COPY, where and how much } + get : uInt; { bits to get for extra } + dist : uInt; { distance back to copy from } + end); + end; + + { mode independent information } + lbits : Byte; { ltree bits decoded per branch } + dbits : Byte; { dtree bits decoder per branch } + ltree : pInflate_huft; { literal/length/eob tree } + dtree : pInflate_huft; { distance tree } + end; + +type + check_func = function(check : uLong; + buf : pBytef; + {const buf : array of byte;} + len : uInt) : uLong; +type + inflate_block_mode = + (ZTYPE, { get type bits (3, including end bit) } + LENS, { get lengths for stored } + STORED, { processing stored block } + TABLE, { get table lengths } + BTREE, { get bit lengths tree for a dynamic block } + DTREE, { get length, distance trees for a dynamic block } + CODES, { processing fixed or dynamic block } + DRY, { output remaining window bytes } + BLKDONE, { finished last block, done } + BLKBAD); { got a data error--stuck here } + +type + pInflate_blocks_state = ^inflate_blocks_state; + +{ inflate blocks semi-private state } + inflate_blocks_state = record + + mode : inflate_block_mode; { current inflate_block mode } + + { mode dependent information } + sub : record { submode } + case Byte of + 0:(left : uInt); { if STORED, bytes left to copy } + 1:(trees : record { if DTREE, decoding info for trees } + table : uInt; { table lengths (14 bits) } + index : uInt; { index into blens (or border) } + blens : PuIntArray; { bit lengths of codes } + bb : uInt; { bit length tree depth } + tb : pInflate_huft; { bit length decoding tree } + end); + 2:(decode : record { if CODES, current state } + tl : pInflate_huft; + td : pInflate_huft; { trees to free } + codes : pInflate_codes_state; + end); + end; + last : boolean; { true if this block is the last block } + + { mode independent information } + bitk : uInt; { bits in bit buffer } + bitb : uLong; { bit buffer } + hufts : huft_ptr; {pInflate_huft;} { single malloc for tree space } + window : pBytef; { sliding window } + zend : pBytef; { one byte after sliding window } + read : pBytef; { window read pointer } + write : pBytef; { window write pointer } + checkfn : check_func; { check function } + check : uLong; { check on output } + end; + +type + inflate_mode = ( + METHOD, { waiting for method byte } + FLAG, { waiting for flag byte } + DICT4, { four dictionary check bytes to go } + DICT3, { three dictionary check bytes to go } + DICT2, { two dictionary check bytes to go } + DICT1, { one dictionary check byte to go } + DICT0, { waiting for inflateSetDictionary } + BLOCKS, { decompressing blocks } + CHECK4, { four check bytes to go } + CHECK3, { three check bytes to go } + CHECK2, { two check bytes to go } + CHECK1, { one check byte to go } + DONE, { finished check, done } + BAD); { got an error--stay here } + +{ inflate private state } +type + pInternal_state = ^internal_state; { or point to a deflate_state record } + internal_state = record + + mode : inflate_mode; { current inflate mode } + + { mode dependent information } + sub : record { submode } + case byte of + 0:(method : uInt); { if FLAGS, method byte } + 1:(check : record { if CHECK, check values to compare } + was : uLong; { computed check value } + need : uLong; { stream check value } + end); + 2:(marker : uInt); { if BAD, inflateSync's marker bytes count } + end; + + { mode independent information } + nowrap : boolean; { flag for no wrapper } + wbits : uInt; { log2(window size) (8..15, defaults to 15) } + blocks : pInflate_blocks_state; { current inflate_blocks state } + end; + +type + alloc_func = function(opaque : voidpf; items : uInt; size : uInt) : voidpf; + free_func = procedure(opaque : voidpf; address : voidpf); + +type + z_streamp = ^z_stream; + z_stream = record + next_in : pBytef; { next input byte } + avail_in : uInt; { number of bytes available at next_in } + total_in : uLong; { total nb of input bytes read so far } + + next_out : pBytef; { next output byte should be put there } + avail_out : uInt; { remaining free space at next_out } + total_out : uLong; { total nb of bytes output so far } + + msg : string[255]; { last error message, '' if no error } + state : pInternal_state; { not visible by applications } + + zalloc : alloc_func; { used to allocate the internal state } + zfree : free_func; { used to free the internal state } + opaque : voidpf; { private data object passed to zalloc and zfree } + + data_type : int; { best guess about the data type: ascii or binary } + adler : uLong; { adler32 value of the uncompressed data } + reserved : uLong; { reserved for future use } + end; + + +{ The application must update next_in and avail_in when avail_in has + dropped to zero. It must update next_out and avail_out when avail_out + has dropped to zero. The application must initialize zalloc, zfree and + opaque before calling the init function. All other fields are set by the + compression library and must not be updated by the application. + + The opaque value provided by the application will be passed as the first + parameter for calls of zalloc and zfree. This can be useful for custom + memory management. The compression library attaches no meaning to the + opaque value. + + zalloc must return Z_NULL if there is not enough memory for the object. + On 16-bit systems, the functions zalloc and zfree must be able to allocate + exactly 65536 bytes, but will not be required to allocate more than this + if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, + pointers returned by zalloc for objects of exactly 65536 bytes *must* + have their offset normalized to zero. The default allocation function + provided by this library ensures this (see zutil.c). To reduce memory + requirements and avoid any allocation of 64K objects, at the expense of + compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h). + + The fields total_in and total_out can be used for statistics or + progress reports. After compression, total_in holds the total size of + the uncompressed data and may be saved for use in the decompressor + (particularly if the decompressor wants to decompress everything in + a single step). } + +const { constants } + Z_NO_FLUSH = 0; + Z_PARTIAL_FLUSH = 1; + Z_SYNC_FLUSH = 2; + Z_FULL_FLUSH = 3; + Z_FINISH = 4; +{ Allowed flush values; see deflate() below for details } + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = (-1); + Z_STREAM_ERROR = (-2); + Z_DATA_ERROR = (-3); + Z_MEM_ERROR = (-4); + Z_BUF_ERROR = (-5); + Z_VERSION_ERROR = (-6); +{ Return codes for the compression/decompression functions. Negative + values are errors, positive values are used for special but normal events.} + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = (-1); +{ compression levels } + + Z_FILTERED = 1; + Z_HUFFMAN_ONLY = 2; + Z_DEFAULT_STRATEGY = 0; +{ compression strategy; see deflateInit2() below for details } + + Z_BINARY = 0; + Z_ASCII = 1; + Z_UNKNOWN = 2; +{ Possible values of the data_type field } + + Z_DEFLATED = 8; +{ The deflate compression method (the only one supported in this version) } + + Z_NULL = NIL; { for initializing zalloc, zfree, opaque } + + {$IFDEF GZIO} +var + errno : int; + {$ENDIF} + + { common constants } + + +{ The three kinds of block type } +const + STORED_BLOCK = 0; + STATIC_TREES = 1; + DYN_TREES = 2; +{ The minimum and maximum match lengths } +const + MIN_MATCH = 3; +{$ifdef MAX_MATCH_IS_258} + MAX_MATCH = 258; +{$else} + MAX_MATCH = ??; { deliberate syntax error } +{$endif} + +const + PRESET_DICT = $20; { preset dictionary flag in zlib header } + + + {$IFDEF DEBUG} +// procedure Assert(cond : boolean; msg : string); + {$ENDIF} + + procedure Trace(x : string); + procedure Tracev(x : string); + procedure Tracevv(x : string); + procedure Tracevvv(x : string); + procedure Tracec(c : boolean; x : string); + procedure Tracecv(c : boolean; x : string); + +function zlibVersion : string; +{ The application can compare zlibVersion and ZLIB_VERSION for consistency. + If the first character differs, the library code actually used is + not compatible with the zlib.h header file used by the application. + This check is automatically made by deflateInit and inflateInit. } + +function zError(err : int) : string; + +function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; + +procedure ZFREE (var strm : z_stream; ptr : voidpf); + +procedure TRY_FREE (var strm : z_stream; ptr : voidpf); + +const + ZLIB_VERSION : string[10] = '1.1.2'; + +const + z_errbase = Z_NEED_DICT; + z_errmsg : Array[0..9] of string[21] = { indexed by 2-zlib_error } + ('need dictionary', { Z_NEED_DICT 2 } + 'stream end', { Z_STREAM_END 1 } + '', { Z_OK 0 } + 'file error', { Z_ERRNO (-1) } + 'stream error', { Z_STREAM_ERROR (-2) } + 'data error', { Z_DATA_ERROR (-3) } + 'insufficient memory', { Z_MEM_ERROR (-4) } + 'buffer error', { Z_BUF_ERROR (-5) } + 'incompatible version',{ Z_VERSION_ERROR (-6) } + ''); +const + z_verbose : int = 1; + +{$IFDEF DEBUG} +procedure z_error (m : string); +{$ENDIF} + +implementation + +function zError(err : int) : string; +begin + zError := z_errmsg[Z_NEED_DICT-err]; +end; + +function zlibVersion : string; +begin + zlibVersion := ZLIB_VERSION; +end; + +//procedure z_error (m : string); +//begin +// WriteLn(output, m); +// Write('Zlib - Halt...'); +// ReadLn; +// Halt(1); +//end; + +//procedure Assert(cond : boolean; msg : string); +//begin +// if not cond then +// z_error(msg); +//end; + +procedure Trace(x : string); +begin + WriteLn(x); +end; + +procedure Tracev(x : string); +begin + if (z_verbose>0) then + WriteLn(x); +end; + +procedure Tracevv(x : string); +begin + if (z_verbose>1) then + WriteLn(x); +end; + +procedure Tracevvv(x : string); +begin + if (z_verbose>2) then + WriteLn(x); +end; + +procedure Tracec(c : boolean; x : string); +begin + if (z_verbose>0) and (c) then + WriteLn(x); +end; + +procedure Tracecv(c : boolean; x : string); +begin + if (z_verbose>1) and c then + WriteLn(x); +end; + +function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; +begin + ZALLOC := strm.zalloc(strm.opaque, items, size); +end; + +procedure ZFREE (var strm : z_stream; ptr : voidpf); +begin + strm.zfree(strm.opaque, ptr); +end; + +procedure TRY_FREE (var strm : z_stream; ptr : voidpf); +begin + {if @strm <> Z_NULL then} + strm.zfree(strm.opaque, ptr); +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/_clean.bat b/niftiview7/gzio/_clean.bat new file mode 100755 index 0000000..da1bfc9 --- /dev/null +++ b/niftiview7/gzio/_clean.bat @@ -0,0 +1,12 @@ +del /S *.dcu +del /S *.~pa +del /S *.~df +del /S *.cfg +del /S *.dof +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt +del /S *.dsm +"C:\Documents and Settings\Chris Rorden\My Documents\niftiview\strip" "C:\Documents and Settings\Chris Rorden\My Documents\niftiview\MRIcroN.exe" diff --git a/niftiview7/gzio/gzio_old.pas b/niftiview7/gzio/gzio_old.pas new file mode 100755 index 0000000..b477855 --- /dev/null +++ b/niftiview7/gzio/gzio_old.pas @@ -0,0 +1,1198 @@ +Unit gzIO; + +{ + Pascal unit based on gzio.c -- IO on .gz files + Copyright (C) 1995-1998 Jean-loup Gailly. + + Define NO_DEFLATE to compile this file without the compression code + + Pascal tranlastion based on code contributed by Francisco Javier Crespo + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + dialogs, + SysUtils, + zutil, zlib, crc, zdeflate, zinflate; + +type gzFile = voidp; +type z_off_t = long; + +function gzopen (path:string; mode:string; flags:uInt) : gzFile; +function gzread (f:gzFile; buf:voidp; len:uInt) : int; +function gzgetc (f:gzfile) : int; +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +{$ifndef NO_DEFLATE} +function gzwrite (f:gzFile; buf:voidp; len:uInt) : int; +function gzputc (f:gzfile; c:char) : int; +function gzputs (f:gzfile; s:PChar) : int; +function gzflush (f:gzFile; flush:int) : int; + {$ifdef GZ_FORMAT_STRING} + function gzprintf (zfile : gzFile; + const format : string; + a : array of int); { doesn't compile } + {$endif} +{$endif} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +function gztell (f:gzfile) : z_off_t; +function gzclose (f:gzFile) : int; +function gzerror (f:gzFile; var errnum:Int) : string; + +const + SEEK_SET {: z_off_t} = 0; { seek from beginning of file } + SEEK_CUR {: z_off_t} = 1; { seek from current position } + SEEK_END {: z_off_t} = 2; + +type gz_stream = record + stream : z_stream; + z_err : int; { error code for last stream operation } + z_eof : boolean; { set if end of input file } + gzfile : file; { .gz file } + inbuf : pBytef; { input buffer } + outbuf : pBytef; { output buffer } + crc : uLong; { crc32 of uncompressed data } + msg : string[79]; { error message - limit 79 chars } + //path : string[255]; { path name for debugging only - limit 79 chars } + transparent : boolean; { true if input file is not a .gz file } + mode : char; { 'w' or 'r' } + startpos : long; { start of compressed data in file (header skipped) } + path: string; +end; + +type gz_streamp = ^gz_stream; + +implementation + +const + Z_EOF = -1; { same value as in STDIO.H } + Z_BUFSIZE = 16384; + { Z_PRINTF_BUFSIZE = 4096; } + + + gz_magic : array[0..1] of byte = ($1F, $8B); { gzip magic header } + + { gzip flag byte } + + ASCII_FLAG = $01; { bit 0 set: file probably ascii text } + HEAD_CRC = $02; { bit 1 set: header CRC present } + EXTRA_FIELD = $04; { bit 2 set: extra field present } + ORIG_NAME = $08; { bit 3 set: original file name present } + COMMENT = $10; { bit 4 set: file comment present } + RESERVED = $E0; { bits 5..7: reserved } + +function destroy (var s:gz_streamp) : int; forward; +procedure check_header(s:gz_streamp); forward; + + +{ GZOPEN ==================================================================== + + Opens a gzip (.gz) file for reading or writing. As Pascal does not use + file descriptors, the code has been changed to accept only path names. + + The mode parameter defaults to BINARY read or write operations ('r' or 'w') + but can also include a compression level ('w9') or a strategy: Z_FILTERED + as in 'w6f' or Z_HUFFMAN_ONLY as in 'w1h'. (See the description of + deflateInit2 for more information about the strategy parameter.) + + gzopen can be used to open a file which is not in gzip format; in this + case, gzread will directly read from the file without decompression. + + gzopen returns NIL if the file could not be opened (non-zero IOResult) + or if there was insufficient memory to allocate the (de)compression state + (zlib error is Z_MEM_ERROR). + + Vincent: + Added argument 'flags' to the original Zlib files. +============================================================================} + +function gzopen (path:string; mode:string; flags:uInt) : gzFile; + +var + + i : uInt; + err : int; + level : int; { compression level } + strategy : int; { compression strategy } + s : gz_streamp; +{$IFDEF MSDOS} + attr : word; { file attributes } +{$ENDIF} + +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} + +begin + //showmessage('a'); + if (path='') or (mode='') then begin + gzopen := Z_NULL; + exit; + end; + //showmessage('b'); + + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + gzopen := Z_NULL; + exit; + end; + //showmessage('c'); + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + + s^.stream.zalloc := NIL; { (alloc_func)0 } + s^.stream.zfree := NIL; { (free_func)0 } + s^.stream.opaque := NIL; { (voidpf)0 } + s^.stream.next_in := Z_NULL; + s^.stream.next_out := Z_NULL; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := Z_NULL; + s^.outbuf := Z_NULL; + s^.crc := crc32(0, Z_NULL, 0); + s^.msg := ''; + s^.transparent := false; + //showmessage('d'+path); + + s^.path := path; { limit to 255 chars } + //showmessage(s^.path); + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + if (s^.mode=chr(0)) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = Z_NULL) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = Z_NULL) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + Assign (s^.gzfile, s^.path); + {$ifdef MSDOS} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + if {(not FileExists(s^.path)) and} (s^.mode='w') then + // Vincent: changed IF because I don't want old data behind my + // new made .gz-file + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := flags; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := LONG(10); +{$ENDIF} + end + else begin + check_header(s); { skip the .gz header } + {$WARNINGS OFF} { combining signed and unsigned types } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + {$WARNINGS ON} + end; + + gzopen := gzFile(s); +end; + + +{ GZSETPARAMS =============================================================== + + Update the compression level and strategy. + +============================================================================} + +//function gzsetparams (f:gzfile; level:int; strategy:int) : int; + +//var + +// s : gz_streamp; +// written: integer; + +//begin + +// s := gz_streamp(f); + +// if (s = NIL) or (s^.mode <> 'w') then begin +// gzsetparams := Z_STREAM_ERROR; +// exit; +// end; + + { Make room to allow flushing } +// if (s^.stream.avail_out = 0) then begin +// s^.stream.next_out := s^.outbuf; +// blockwrite(s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); +// if (written <> Z_BUFSIZE) then s^.z_err := Z_ERRNO; +// s^.stream.avail_out := Z_BUFSIZE; +// end; + +// gzsetparams := deflateParams (s^.stream, level, strategy); +//end; + + +{ GET_BYTE ================================================================== + + Read a byte from a gz_stream. Updates next_in and avail_in. + Returns EOF for end of file. + IN assertion: the stream s has been sucessfully opened for reading. + +============================================================================} + +function get_byte (s:gz_streamp) : int; + +begin + + if (s^.z_eof = true) then begin + get_byte := Z_EOF; + exit; + end; + + if (s^.stream.avail_in = 0) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then s^.z_err := Z_ERRNO; + get_byte := Z_EOF; + exit; + end; + s^.stream.next_in := s^.inbuf; + end; + + Dec(s^.stream.avail_in); + get_byte := s^.stream.next_in^; + Inc(s^.stream.next_in); + +end; + + +{ GETLONG =================================================================== + + Reads a Longint in LSB order from the given gz_stream. + +============================================================================} +{ +function getLong (s:gz_streamp) : uLong; +var + x : array [0..3] of byte; + i : byte; + c : int; + n1 : longint; + n2 : longint; +begin + + for i:=0 to 3 do begin + c := get_byte(s); + if (c = Z_EOF) then s^.z_err := Z_DATA_ERROR; + x[i] := (c and $FF) + end; + n1 := (ush(x[3] shl 8)) or x[2]; + n2 := (ush(x[1] shl 8)) or x[0]; + getlong := (n1 shl 16) or n2; +end; +} +function getLong(s : gz_streamp) : uLong; +var + x : packed array [0..3] of byte; + c : int; +begin + { x := uLong(get_byte(s)); - you can't do this with TP, no unsigned long } + { the following assumes a little endian machine and TP } + x[0] := Byte(get_byte(s)); + x[1] := Byte(get_byte(s)); + x[2] := Byte(get_byte(s)); + c := get_byte(s); + x[3] := Byte(c); + if (c = Z_EOF) then + s^.z_err := Z_DATA_ERROR; + GetLong := uLong(longint(x)); +end; + + +{ CHECK_HEADER ============================================================== + + Check the gzip header of a gz_stream opened for reading. + Set the stream mode to transparent if the gzip magic header is not present. + Set s^.err to Z_DATA_ERROR if the magic header is present but the rest of + the header is incorrect. + + IN assertion: the stream s has already been created sucessfully; + s^.stream.avail_in is zero for the first time, but may be non-zero + for concatenated .gz files + +============================================================================} + +procedure check_header (s:gz_streamp); + +var + + method : int; { method byte } + flags : int; { flags byte } + len : uInt; + c : int; + +begin + + { Check the gzip magic header } + for len := 0 to 1 do begin + c := get_byte(s); + if (c <> gz_magic[len]) then begin + if (len <> 0) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + end; + if (c <> Z_EOF) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + s^.transparent := TRUE; + end; + if (s^.stream.avail_in <> 0) then s^.z_err := Z_OK + else s^.z_err := Z_STREAM_END; + exit; + end; + end; + + method := get_byte(s); + flags := get_byte(s); + if (method <> Z_DEFLATED) or ((flags and RESERVED) <> 0) then begin + s^.z_err := Z_DATA_ERROR; + exit; + end; + + for len := 0 to 5 do get_byte(s); { Discard time, xflags and OS code } + + if ((flags and EXTRA_FIELD) <> 0) then begin { skip the extra field } + len := uInt(get_byte(s)); + len := len + (uInt(get_byte(s)) shr 8); + { len is garbage if EOF but the loop below will quit anyway } + while (len <> 0) and (get_byte(s) <> Z_EOF) do Dec(len); + end; + + if ((flags and ORIG_NAME) <> 0) then begin { skip the original file name } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and COMMENT) <> 0) then begin { skip the .gz file comment } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and HEAD_CRC) <> 0) then begin { skip the header crc } + get_byte(s); + get_byte(s); + end; + + if (s^.z_eof = true) then + s^.z_err := Z_DATA_ERROR + else + s^.z_err := Z_OK; + +end; + + +{ DESTROY =================================================================== + + Cleanup then free the given gz_stream. Return a zlib error code. + Try freeing in the reverse order of allocations. + +============================================================================} + +function destroy (var s:gz_streamp) : int; + +begin + + destroy := Z_OK; + + if not Assigned (s) then begin + destroy := Z_STREAM_ERROR; + exit; + end; + + if (s^.stream.state <> NIL) then begin + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + destroy := Z_STREAM_ERROR; +{$ELSE} + destroy := deflateEnd(s^.stream); +{$ENDIF} + end + else if (s^.mode = 'r') then begin + destroy := inflateEnd(s^.stream); + end; + end; + + if (s^.path <> '') then begin + {$I-} + close(s^.gzfile); + {$I+} + if (IOResult <> 0) then destroy := Z_ERRNO; + end; + + if (s^.z_err < 0) then destroy := s^.z_err; + + if Assigned (s^.inbuf) then + FreeMem(s^.inbuf, Z_BUFSIZE); + if Assigned (s^.outbuf) then + FreeMem(s^.outbuf, Z_BUFSIZE); + FreeMem(s, sizeof(gz_stream)); + +end; + + +{ GZREAD ==================================================================== + + Reads the given number of uncompressed bytes from the compressed file. + If the input file was not in gzip format, gzread copies the given number + of bytes into the buffer. + + gzread returns the number of uncompressed bytes actually read + (0 for end of file, -1 for error). + +============================================================================} + +function gzread (f:gzFile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + start : pBytef; + next_out : pBytef; + n : uInt; + crclen : uInt; { Buffer length to update CRC32 } + filecrc : uLong; { CRC32 stored in GZIP'ed file } + filelen : uLong; { Total lenght of uncompressed file } + bytes : integer; { bytes actually read in I/O blockread } + total_in : uLong; + total_out : uLong; + +begin + + s := gz_streamp(f); + start := pBytef(buf); { starting point for crc computation } + + if (s = NIL) or (s^.mode <> 'r') then begin + gzread := Z_STREAM_ERROR; + exit; + end; + + if (s^.z_err = Z_DATA_ERROR) or (s^.z_err = Z_ERRNO) then begin + gzread := -1; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then begin + gzread := 0; { EOF } + exit; + end; + + s^.stream.next_out := pBytef(buf); + s^.stream.avail_out := len; + + while (s^.stream.avail_out <> 0) do begin + + if (s^.transparent = true) then begin + { Copy first the lookahead bytes: } + n := s^.stream.avail_in; + if (n > s^.stream.avail_out) then n := s^.stream.avail_out; + if (n > 0) then begin + zmemcpy(s^.stream.next_out, s^.stream.next_in, n); + inc (s^.stream.next_out, n); + inc (s^.stream.next_in, n); + dec (s^.stream.avail_out, n); + dec (s^.stream.avail_in, n); + end; + if (s^.stream.avail_out > 0) then begin + blockread (s^.gzfile, s^.stream.next_out^, s^.stream.avail_out, bytes); + dec (s^.stream.avail_out, uInt(bytes)); + end; + dec (len, s^.stream.avail_out); + inc (s^.stream.total_in, uLong(len)); + inc (s^.stream.total_out, uLong(len)); + gzread := int(len); + exit; + end; { IF transparent } + + if (s^.stream.avail_in = 0) and (s^.z_eof = false) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then begin + s^.z_err := Z_ERRNO; + break; + end; + end; + s^.stream.next_in := s^.inbuf; + end; + + s^.z_err := inflate(s^.stream, Z_NO_FLUSH); + + if (s^.z_err = Z_STREAM_END) then begin + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + { Check CRC and original size } + s^.crc := crc32(s^.crc, start, crclen); + start := s^.stream.next_out; + + filecrc := getLong (s); + filelen := getLong (s); + + if (s^.crc <> filecrc) or (s^.stream.total_out <> filelen) + then s^.z_err := Z_DATA_ERROR + else begin + { Check for concatenated .gz files: } + check_header(s); + if (s^.z_err = Z_OK) then begin + total_in := s^.stream.total_in; + total_out := s^.stream.total_out; + + inflateReset (s^.stream); + s^.stream.total_in := total_in; + s^.stream.total_out := total_out; + s^.crc := crc32 (0, Z_NULL, 0); + end; + end; {IF-THEN-ELSE} + end; + + if (s^.z_err <> Z_OK) or (s^.z_eof = true) then break; + + end; {WHILE} + + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + s^.crc := crc32 (s^.crc, start, crclen); + + gzread := int(len - s^.stream.avail_out); + +end; + + +{ GZGETC ==================================================================== + + Reads one byte from the compressed file. + gzgetc returns this byte or -1 in case of end of file or error. + +============================================================================} + +function gzgetc (f:gzfile) : int; + +var c:byte; + +begin + + if (gzread (f,@c,1) = 1) then gzgetc := c else gzgetc := -1; + +end; + + +{ GZGETS ==================================================================== + + Reads bytes from the compressed file until len-1 characters are read, + or a newline character is read and transferred to buf, or an end-of-file + condition is encountered. The string is then Null-terminated. + + gzgets returns buf, or Z_NULL in case of error. + The current implementation is not optimized at all. + +============================================================================} + +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +var + + b : PChar; { start of buffer } + bytes : Int; { number of bytes read by gzread } + gzchar : char; { char read by gzread } + +begin + + if (buf = Z_NULL) or (len <= 0) then begin + gzgets := Z_NULL; + exit; + end; + + b := buf; + repeat + dec (len); + bytes := gzread (f, buf, 1); + gzchar := buf^; + inc (buf); + until (len = 0) or (bytes <> 1) or (gzchar = Chr(13)); + + buf^ := Chr(0); + if (b = buf) and (len > 0) then gzgets := Z_NULL else gzgets := b; + +end; + + +{$IFNDEF NO_DEFLATE} + +{ GZWRITE =================================================================== + + Writes the given number of uncompressed bytes into the compressed file. + gzwrite returns the number of uncompressed bytes actually written + (0 in case of error). + +============================================================================} + +function gzwrite (f:gzfile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + written : integer; + +begin + + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + gzwrite := Z_STREAM_ERROR; + exit; + end; + + s^.stream.next_in := pBytef(buf); + s^.stream.avail_in := len; + + while (s^.stream.avail_in <> 0) do begin + + if (s^.stream.avail_out = 0) then begin + s^.stream.next_out := s^.outbuf; + blockwrite (s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); + if (written <> Z_BUFSIZE) then begin + s^.z_err := Z_ERRNO; + break; + end; + s^.stream.avail_out := Z_BUFSIZE; + end; + + s^.z_err := deflate(s^.stream, Z_NO_FLUSH); + if (s^.z_err <> Z_OK) then break; + + end; {WHILE} + + s^.crc := crc32(s^.crc, buf, len); + gzwrite := int(len - s^.stream.avail_in); + +end; + + +{ =========================================================================== + Converts, formats, and writes the args to the compressed file under + control of the format string, as in fprintf. gzprintf returns the number of + uncompressed bytes actually written (0 in case of error). +} + +{$IFDEF GZ_FORMAT_STRING} +function gzprintf (zfile : gzFile; + const format : string; + a : array of int) : int; +var + buf : array[0..Z_PRINTF_BUFSIZE-1] of char; + len : int; +begin +{$ifdef HAS_snprintf} + snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$else} + sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$endif} + len := strlen(buf); { old sprintf doesn't return the nb of bytes written } + if (len <= 0) return 0; + + gzprintf := gzwrite(file, buf, len); +end; +{$ENDIF} + + +{ GZPUTC ==================================================================== + + Writes c, converted to an unsigned char, into the compressed file. + gzputc returns the value that was written, or -1 in case of error. + +============================================================================} + +function gzputc (f:gzfile; c:char) : int; +begin + if (gzwrite (f,@c,1) = 1) then + {$IFDEF FPC} + gzputc := int(ord(c)) + {$ELSE} + gzputc := int(c) + {$ENDIF} + else + gzputc := -1; +end; + + +{ GZPUTS ==================================================================== + + Writes the given null-terminated string to the compressed file, excluding + the terminating null character. + gzputs returns the number of characters written, or -1 in case of error. + +============================================================================} + +function gzputs (f:gzfile; s:PChar) : int; +begin + gzputs := gzwrite (f, voidp(s), strlen(s)); +end; + + +{ DO_FLUSH ================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + +============================================================================} + +function do_flush (f:gzfile; flush:int) : int; +var + len : uInt; + done : boolean; + s : gz_streamp; + written : integer; +begin + done := false; + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + do_flush := Z_STREAM_ERROR; + exit; + end; + + s^.stream.avail_in := 0; { should be zero already anyway } + + while true do begin + + len := Z_BUFSIZE - s^.stream.avail_out; + + if (len <> 0) then begin + {$I-} + blockwrite(s^.gzfile, s^.outbuf^, len, written); + {$I+} + {$WARNINGS OFF} {Comparing signed and unsigned types} + if (written <> len) then begin + {$WARNINGS ON} + s^.z_err := Z_ERRNO; + do_flush := Z_ERRNO; + exit; + end; + s^.stream.next_out := s^.outbuf; + s^.stream.avail_out := Z_BUFSIZE; + end; + + if (done = true) then break; + s^.z_err := deflate(s^.stream, flush); + + { Ignore the second of two consecutive flushes: } + if (len = 0) and (s^.z_err = Z_BUF_ERROR) then s^.z_err := Z_OK; + + { deflate has finished flushing only when it hasn't used up + all the available space in the output buffer: } + + done := (s^.stream.avail_out <> 0) or (s^.z_err = Z_STREAM_END); + if (s^.z_err <> Z_OK) and (s^.z_err <> Z_STREAM_END) then break; + + end; {WHILE} + + if (s^.z_err = Z_STREAM_END) then do_flush:=Z_OK else do_flush:=s^.z_err; +end; + +{ GZFLUSH =================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + + The return value is the zlib error number (see function gzerror below). + gzflush returns Z_OK if the flush parameter is Z_FINISH and all output + could be flushed. + + gzflush should be called only when strictly necessary because it can + degrade compression. + +============================================================================} + +function gzflush (f:gzfile; flush:int) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + err := do_flush (f, flush); + + if (err <> 0) then begin + gzflush := err; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then gzflush := Z_OK else gzflush := s^.z_err; +end; + +{$ENDIF} (* NO DEFLATE *) + + +{ GZREWIND ================================================================== + + Rewinds input file. + +============================================================================} + +function gzrewind (f:gzFile) : int; +var + s:gz_streamp; +begin + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'r') then begin + gzrewind := -1; + exit; + end; + + s^.z_err := Z_OK; + s^.z_eof := false; + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + + if (s^.startpos = 0) then begin { not a compressed file } + {$I-} + seek (s^.gzfile, 0); + {$I+} + gzrewind := 0; + exit; + end; + + inflateReset(s^.stream); + {$I-} + seek (s^.gzfile, s^.startpos); + {$I+} + gzrewind := int(IOResult); + exit; +end; + + +{ GZSEEK ==================================================================== + + Sets the starting position for the next gzread or gzwrite on the given + compressed file. The offset represents a number of bytes from the beginning + of the uncompressed stream. + + gzseek returns the resulting offset, or -1 in case of error. + SEEK_END is not implemented, returns error. + In this version of the library, gzseek can be extremely slow. + +============================================================================} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +var + s : gz_streamp; + size : uInt; +begin + s := gz_streamp(f); + + if (s = NIL) or (whence = SEEK_END) or (s^.z_err = Z_ERRNO) + or (s^.z_err = Z_DATA_ERROR) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzseek := z_off_t(-1); + exit; +{$ELSE} + if (whence = SEEK_SET) then dec(offset, s^.stream.total_out); + if (offset < 0) then begin; + gzseek := z_off_t(-1); + exit; + end; + + { At this point, offset is the number of zero bytes to write. } + if (s^.inbuf = Z_NULL) then begin + GetMem (s^.inbuf, Z_BUFSIZE); + zmemzero(s^.inbuf, Z_BUFSIZE); + end; + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := uInt(offset); + + size := gzwrite(f, s^.inbuf, size); + if (size = 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + dec (offset,size); + end; + + gzseek := z_off_t(s^.stream.total_in); + exit; +{$ENDIF} + end; + { Rest of function is for reading only } + + { compute absolute position } + if (whence = SEEK_CUR) then inc (offset, s^.stream.total_out); + if (offset < 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.transparent = true) then begin + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + {$I-} + seek (s^.gzfile, offset); + {$I+} + if (IOResult <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + s^.stream.total_in := uLong(offset); + s^.stream.total_out := uLong(offset); + gzseek := z_off_t(offset); + exit; + end; + + { For a negative seek, rewind and use positive seek } + if (uLong(offset) >= s^.stream.total_out) + then dec (offset, s^.stream.total_out) + else if (gzrewind(f) <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + { offset is now the number of bytes to skip. } + + if (offset <> 0) and (s^.outbuf = Z_NULL) + then GetMem (s^.outbuf, Z_BUFSIZE); + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := int(offset); + + size := gzread (f, s^.outbuf, size); + if (size <= 0) then begin + gzseek := z_off_t(-1); + exit; + end; + dec(offset, size); + end; + + gzseek := z_off_t(s^.stream.total_out); +end; + + +{ GZTELL ==================================================================== + + Returns the starting position for the next gzread or gzwrite on the + given compressed file. This position represents a number of bytes in the + uncompressed data stream. + +============================================================================} + +function gztell (f:gzfile) : z_off_t; +begin + gztell := gzseek (f, 0, SEEK_CUR); +end; + + +{ GZEOF ===================================================================== + + Returns TRUE when EOF has previously been detected reading the given + input stream, otherwise FALSE. + +============================================================================} + +//function gzeof (f:gzfile) : boolean; +//var +// s:gz_streamp; +//begin +// s := gz_streamp(f); + +// if (s=NIL) or (s^.mode<>'r') then +// gzeof := false +// else +// gzeof := s^.z_eof; +//end; + + +{ PUTLONG =================================================================== + + Outputs a Longint in LSB order to the given file + +============================================================================} + +procedure putLong (var f:file; x:uLong); +var + n : int; + c : byte; +begin + for n:=0 to 3 do begin + c := x and $FF; + blockwrite (f, c, 1); + x := x shr 8; + end; +end; + + +{ GZCLOSE =================================================================== + + Flushes all pending output if necessary, closes the compressed file + and deallocates all the (de)compression state. + + The return value is the zlib error number (see function gzerror below). + +============================================================================} + +function gzclose (f:gzFile) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + gzclose := Z_STREAM_ERROR; + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzclose := Z_STREAM_ERROR; + exit; +{$ELSE} + err := do_flush (f, Z_FINISH); + if (err <> Z_OK) then begin + gzclose := destroy (gz_streamp(f)); + exit; + end; + + putLong (s^.gzfile, s^.crc); + putLong (s^.gzfile, s^.stream.total_in); +{$ENDIF} + end; + + gzclose := destroy (gz_streamp(f)); +end; + + +{ GZERROR =================================================================== + + Returns the error message for the last error which occured on the + given compressed file. errnum is set to zlib error number. If an + error occured in the file system and not in the compression library, + errnum is set to Z_ERRNO and the application may consult errno + to get the exact error code. + +============================================================================} + +function gzerror (f:gzfile; var errnum:int) : string; +var + m : string; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + errnum := Z_STREAM_ERROR; + gzerror := zError(Z_STREAM_ERROR); + end; + + errnum := s^.z_err; + if (errnum = Z_OK) then begin + gzerror := zError(Z_OK); + exit; + end; + + m := s^.stream.msg; + if (errnum = Z_ERRNO) then m := ''; + if (m = '') then m := zError(s^.z_err); + + s^.msg := s^.path+': '+m; + gzerror := s^.msg; +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/gzio_oldish.pas b/niftiview7/gzio/gzio_oldish.pas new file mode 100755 index 0000000..8b70e30 --- /dev/null +++ b/niftiview7/gzio/gzio_oldish.pas @@ -0,0 +1,1213 @@ +Unit gzIO; + +{ + Pascal unit based on gzio.c -- IO on .gz files + Copyright (C) 1995-1998 zJean-loup Gailly. + + Define NO_DEFLATE to compile this file without the compression code + + Pascal tranlastion based on code contributed by Francisco Javier Crespo + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + SysUtils, + zutil, zlib, crc, zdeflate, zinflate,dialogs, Windows; + +type gzFile = voidp; +type z_off_t = long; + + +function gzopenZ (SourceFilename:string; mode:string; flags:uInt) : gzFile; //note: sourcefilename without '.gz' if writing, e.g. name file that exists +function gzread (f:gzFile; buf:voidp; len:uInt) : int; +function gzgetc (f:gzfile) : int; +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +{$ifndef NO_DEFLATE} +function gzwrite (f:gzFile; buf:voidp; len:uInt) : int; +function gzputc (f:gzfile; c:char) : int; +function gzputs (f:gzfile; s:PChar) : int; +function gzflush (f:gzFile; flush:int) : int; + {$ifdef GZ_FORMAT_STRING} + function gzprintf (zfile : gzFile; + const format : string; + a : array of int); { doesn't compile } + {$endif} +{$endif} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +function gztell (f:gzfile) : z_off_t; +function gzclose (f:gzFile) : int; +function gzerror (f:gzFile; var errnum:Int) : string; + +const + SEEK_SET {: z_off_t} = 0; { seek from beginning of file } + SEEK_CUR {: z_off_t} = 1; { seek from current position } + SEEK_END {: z_off_t} = 2; +const + Z_EOF = -1; { same value as in STDIO.H } + Z_BUFSIZE = 16384; + { Z_PRINTF_BUFSIZE = 4096; } + + + gz_magic : array[0..1] of byte = ($1F, $8B); { gzip magic header } + + { gzip flag byte } + + ASCII_FLAG = $01; { bit 0 set: file probably ascii text } + HEAD_CRC = $02; { bit 1 set: header CRC present } + EXTRA_FIELD = $04; { bit 2 set: extra field present } + ORIG_NAME = $08; { bit 3 set: original file name present } + COMMENT_ = $10; { bit 4 set: file comment present } + RESERVED = $E0; { bits 5..7: reserved } + +type gz_stream = record + stream : z_stream; + z_err : int; { error code for last stream operation } + z_eof : boolean; { set if end of input file } + gzfile : file; { .gz file } + inbuf : pBytef; { input buffer } + outbuf : pBytef; { output buffer } + crc : uLong; { crc32 of uncompressed data } + msg : string[79]; { error message - limit 79 chars } + path : string[255]; { path name for debugging only - limit 79 chars } + //Change by Chris Rorden: short path clips filename, it is clearly not only for debugging + //Previous line was originally + //path : string[79]; + + transparent : boolean; { true if input file is not a .gz file } + mode : char; { 'w' or 'r' } + startpos : long; { start of compressed data in file (header skipped) } +end; + +type gz_streamp = ^gz_stream; + +implementation + + +function destroyS (var s:gz_streamp) : int; forward; +procedure check_header(s:gz_streamp); forward; + + +{ GZOPEN ==================================================================== + + Opens a gzip (.gz) file for reading or writing. As Pascal does not use + file descriptors, the code has been changed to accept only path names. + + The mode parameter defaults to BINARY read or write operations ('r' or 'w') + but can also include a compression level ('w9') or a strategy: Z_FILTERED + as in 'w6f' or Z_HUFFMAN_ONLY as in 'w1h'. (See the description of + deflateInit2 for more information about the strategy parameter.) + + gzopen can be used to open a file which is not in gzip format; in this + case, gzread will directly read from the file without decompression. + + gzopen returns NIL if the file could not be opened (non-zero IOResult) + or if there was insufficient memory to allocate the (de)compression state + (zlib error is Z_MEM_ERROR). + + Vincent: + Added argument 'flags' to the original Zlib files. +============================================================================} + + +function gzopenZ(sourceFilename:string; mode:string; flags:uInt) : gzFile; + +var + + i : uInt; + err,level,strategy : int; { compression strategy } + s : gz_streamp; + path: string; +{$IFDEF MSDOS} + attr : word; { file attributes } +{$ENDIF} + +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} + +begin + path := sourceFilename; + if (path='') or (mode='') then begin + result := Z_NULL; + exit; + end; + if length(path) > 240 then begin + Path := ExtractShortPathName(Path); + if (length(path) > 240) or (length(path) < 1) then begin + Showmessage('Unable to GZip this file: path name is too long'); + result := Z_NULL; + exit; + end; + end; + //showmessage(path+'@'+inttostr(length(path))); + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + result := Z_NULL; + exit; + end; + if (path='') then begin + Showmessage('Error with path'); + result := Z_NULL; + exit; + end; + //showmessage('gzOpenCompleted'); + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + s^.stream.zalloc := NIL; { (alloc_func)0 } + s^.stream.zfree := NIL; { (free_func)0 } + s^.stream.opaque := NIL; { (voidpf)0 } + s^.stream.next_in := Z_NULL; + s^.stream.next_out := Z_NULL; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := Z_NULL; + s^.outbuf := Z_NULL; + s^.crc := crc32(0, Z_NULL, 0); + s^.msg := ''; + s^.transparent := false; + + //showmessage(s^.path+inttostr(length(path))); + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + if (s^.mode='w') then begin + path := path+'.gz'; + end; + s^.path := path; { limit to 255 chars } + if (s^.mode=chr(0)) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = Z_NULL) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = Z_NULL) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + Assign (s^.gzfile, s^.path); + {$ifdef MSDOS} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + if {(not FileExists(s^.path)) and} (s^.mode='w') then + // Vincent: changed IF because I don't want old data behind my + // new made .gz-file + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + destroyS(s); + result := gzFile(Z_NULL); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := flags; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := LONG(10); +{$ENDIF} + end + else begin + check_header(s); { skip the .gz header } + {$WARNINGS OFF} { combining signed and unsigned types } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + {$WARNINGS ON} + end; + result := gzFile(s); +end; + + +{ GZSETPARAMS =============================================================== + + Update the compression level and strategy. + +============================================================================} + +//function gzsetparams (f:gzfile; level:int; strategy:int) : int; + +//var + +// s : gz_streamp; +// written: integer; + +//begin + +// s := gz_streamp(f); + +// if (s = NIL) or (s^.mode <> 'w') then begin +// gzsetparams := Z_STREAM_ERROR; +// exit; +// end; + + { Make room to allow flushing } +// if (s^.stream.avail_out = 0) then begin +// s^.stream.next_out := s^.outbuf; +// blockwrite(s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); +// if (written <> Z_BUFSIZE) then s^.z_err := Z_ERRNO; +// s^.stream.avail_out := Z_BUFSIZE; +// end; + +// gzsetparams := deflateParams (s^.stream, level, strategy); +//end; + + +{ GET_BYTE ================================================================== + + Read a byte from a gz_stream. Updates next_in and avail_in. + Returns EOF for end of file. + IN assertion: the stream s has been sucessfully opened for reading. + +============================================================================} + +function get_byte (s:gz_streamp) : int; + +begin + + if (s^.z_eof = true) then begin + get_byte := Z_EOF; + exit; + end; + + if (s^.stream.avail_in = 0) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then s^.z_err := Z_ERRNO; + get_byte := Z_EOF; + exit; + end; + s^.stream.next_in := s^.inbuf; + end; + + Dec(s^.stream.avail_in); + get_byte := s^.stream.next_in^; + Inc(s^.stream.next_in); + +end; + + +{ GETLONG =================================================================== + + Reads a Longint in LSB order from the given gz_stream. + +============================================================================} +{ +function getLong (s:gz_streamp) : uLong; +var + x : array [0..3] of byte; + i : byte; + c : int; + n1 : longint; + n2 : longint; +begin + + for i:=0 to 3 do begin + c := get_byte(s); + if (c = Z_EOF) then s^.z_err := Z_DATA_ERROR; + x[i] := (c and $FF) + end; + n1 := (ush(x[3] shl 8)) or x[2]; + n2 := (ush(x[1] shl 8)) or x[0]; + getlong := (n1 shl 16) or n2; +end; +} +function getLong(s : gz_streamp) : uLong; +var + x : packed array [0..3] of byte; + c : int; +begin + { x := uLong(get_byte(s)); - you can't do this with TP, no unsigned long } + { the following assumes a little endian machine and TP } + x[0] := Byte(get_byte(s)); + x[1] := Byte(get_byte(s)); + x[2] := Byte(get_byte(s)); + c := get_byte(s); + x[3] := Byte(c); + if (c = Z_EOF) then + s^.z_err := Z_DATA_ERROR; + GetLong := uLong(longint(x)); +end; + + +{ CHECK_HEADER ============================================================== + + Check the gzip header of a gz_stream opened for reading. + Set the stream mode to transparent if the gzip magic header is not present. + Set s^.err to Z_DATA_ERROR if the magic header is present but the rest of + the header is incorrect. + + IN assertion: the stream s has already been created sucessfully; + s^.stream.avail_in is zero for the first time, but may be non-zero + for concatenated .gz files + +============================================================================} + +procedure check_header (s:gz_streamp); + +var + + method : int; { method byte } + flags : int; { flags byte } + len : uInt; + c : int; + +begin + + { Check the gzip magic header } + for len := 0 to 1 do begin + c := get_byte(s); + if (c <> gz_magic[len]) then begin + if (len <> 0) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + end; + if (c <> Z_EOF) then begin + Inc(s^.stream.avail_in); + Dec(s^.stream.next_in); + s^.transparent := TRUE; + end; + if (s^.stream.avail_in <> 0) then s^.z_err := Z_OK + else s^.z_err := Z_STREAM_END; + exit; + end; + end; + + method := get_byte(s); + flags := get_byte(s); + if (method <> Z_DEFLATED) or ((flags and RESERVED) <> 0) then begin + s^.z_err := Z_DATA_ERROR; + exit; + end; + + for len := 0 to 5 do get_byte(s); { Discard time, xflags and OS code } + + if ((flags and EXTRA_FIELD) <> 0) then begin { skip the extra field } + len := uInt(get_byte(s)); + len := len + (uInt(get_byte(s)) shr 8); + { len is garbage if EOF but the loop below will quit anyway } + while (len <> 0) and (get_byte(s) <> Z_EOF) do Dec(len); + end; + + if ((flags and ORIG_NAME) <> 0) then begin { skip the original file name } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and COMMENT_) <> 0) then begin { skip the .gz file comment } + repeat + c := get_byte(s); + until (c = 0) or (c = Z_EOF); + end; + + if ((flags and HEAD_CRC) <> 0) then begin { skip the header crc } + get_byte(s); + get_byte(s); + end; + + if (s^.z_eof = true) then + s^.z_err := Z_DATA_ERROR + else + s^.z_err := Z_OK; + +end; + + +{ DESTROY =================================================================== + + Cleanup then free the given gz_stream. Return a zlib error code. + Try freeing in the reverse order of allocations. + +============================================================================} + +function destroyS (var s:gz_streamp) : int; + +begin + + destroyS := Z_OK; + + if not Assigned (s) then begin + destroyS := Z_STREAM_ERROR; + exit; + end; + + if (s^.stream.state <> NIL) then begin + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + destroyS := Z_STREAM_ERROR; +{$ELSE} + destroyS := deflateEnd(s^.stream); +{$ENDIF} + end + else if (s^.mode = 'r') then begin + destroyS := inflateEnd(s^.stream); + end; + end; + + if (s^.path <> '') then begin + {$I-} + close(s^.gzfile); + {$I+} + if (IOResult <> 0) then destroyS := Z_ERRNO; + end; + + if (s^.z_err < 0) then destroyS := s^.z_err; + + if Assigned (s^.inbuf) then + FreeMem(s^.inbuf, Z_BUFSIZE); + if Assigned (s^.outbuf) then + FreeMem(s^.outbuf, Z_BUFSIZE); + FreeMem(s, sizeof(gz_stream)); + +end; + + +{ GZREAD ==================================================================== + + Reads the given number of uncompressed bytes from the compressed file. + If the input file was not in gzip format, gzread copies the given number + of bytes into the buffer. + + gzread returns the number of uncompressed bytes actually read + (0 for end of file, -1 for error). + +============================================================================} + +function gzread (f:gzFile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + start : pBytef; + next_out : pBytef; + n : uInt; + crclen : uInt; { Buffer length to update CRC32 } + filecrc : uLong; { CRC32 stored in GZIP'ed file } + filelen : uLong; { Total lenght of uncompressed file } + bytes : integer; { bytes actually read in I/O blockread } + total_in : uLong; + total_out : uLong; + +begin + + s := gz_streamp(f); + start := pBytef(buf); { starting point for crc computation } + + if (s = NIL) or (s^.mode <> 'r') then begin + gzread := Z_STREAM_ERROR; + exit; + end; + + if (s^.z_err = Z_DATA_ERROR) or (s^.z_err = Z_ERRNO) then begin + gzread := -1; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then begin + gzread := 0; { EOF } + exit; + end; + + s^.stream.next_out := pBytef(buf); + s^.stream.avail_out := len; + + while (s^.stream.avail_out <> 0) do begin + + if (s^.transparent = true) then begin + { Copy first the lookahead bytes: } + n := s^.stream.avail_in; + if (n > s^.stream.avail_out) then n := s^.stream.avail_out; + if (n > 0) then begin + zmemcpy(s^.stream.next_out, s^.stream.next_in, n); + inc (s^.stream.next_out, n); + inc (s^.stream.next_in, n); + dec (s^.stream.avail_out, n); + dec (s^.stream.avail_in, n); + end; + if (s^.stream.avail_out > 0) then begin + blockread (s^.gzfile, s^.stream.next_out^, s^.stream.avail_out, bytes); + dec (s^.stream.avail_out, uInt(bytes)); + end; + dec (len, s^.stream.avail_out); + inc (s^.stream.total_in, uLong(len)); + inc (s^.stream.total_out, uLong(len)); + gzread := int(len); + exit; + end; { IF transparent } + + if (s^.stream.avail_in = 0) and (s^.z_eof = false) then begin + {$I-} + blockread (s^.gzfile, s^.inbuf^, Z_BUFSIZE, s^.stream.avail_in); + {$I+} + if (s^.stream.avail_in = 0) then begin + s^.z_eof := true; + if (IOResult <> 0) then begin + s^.z_err := Z_ERRNO; + break; + end; + end; + s^.stream.next_in := s^.inbuf; + end; + + s^.z_err := inflate(s^.stream, Z_NO_FLUSH); + + if (s^.z_err = Z_STREAM_END) then begin + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + { Check CRC and original size } + s^.crc := crc32(s^.crc, start, crclen); + start := s^.stream.next_out; + + filecrc := getLong (s); + filelen := getLong (s); + + if (s^.crc <> filecrc) or (s^.stream.total_out <> filelen) + then s^.z_err := Z_DATA_ERROR + else begin + { Check for concatenated .gz files: } + check_header(s); + if (s^.z_err = Z_OK) then begin + total_in := s^.stream.total_in; + total_out := s^.stream.total_out; + + inflateReset (s^.stream); + s^.stream.total_in := total_in; + s^.stream.total_out := total_out; + s^.crc := crc32 (0, Z_NULL, 0); + end; + end; {IF-THEN-ELSE} + end; + + if (s^.z_err <> Z_OK) or (s^.z_eof = true) then break; + + end; {WHILE} + + crclen := 0; + next_out := s^.stream.next_out; + while (next_out <> start ) do begin + dec (next_out); + inc (crclen); { Hack because Pascal cannot substract pointers } + end; + s^.crc := crc32 (s^.crc, start, crclen); + + gzread := int(len - s^.stream.avail_out); + +end; + + +{ GZGETC ==================================================================== + + Reads one byte from the compressed file. + gzgetc returns this byte or -1 in case of end of file or error. + +============================================================================} + +function gzgetc (f:gzfile) : int; + +var c:byte; + +begin + + if (gzread (f,@c,1) = 1) then gzgetc := c else gzgetc := -1; + +end; + + +{ GZGETS ==================================================================== + + Reads bytes from the compressed file until len-1 characters are read, + or a newline character is read and transferred to buf, or an end-of-file + condition is encountered. The string is then Null-terminated. + + gzgets returns buf, or Z_NULL in case of error. + The current implementation is not optimized at all. + +============================================================================} + +function gzgets (f:gzfile; buf:PChar; len:int) : PChar; + +var + + b : PChar; { start of buffer } + bytes : Int; { number of bytes read by gzread } + gzchar : char; { char read by gzread } + +begin + + if (buf = Z_NULL) or (len <= 0) then begin + gzgets := Z_NULL; + exit; + end; + + b := buf; + repeat + dec (len); + bytes := gzread (f, buf, 1); + gzchar := buf^; + inc (buf); + until (len = 0) or (bytes <> 1) or (gzchar = Chr(13)); + + buf^ := Chr(0); + if (b = buf) and (len > 0) then gzgets := Z_NULL else gzgets := b; + +end; + + +{$IFNDEF NO_DEFLATE} + +{ GZWRITE =================================================================== + + Writes the given number of uncompressed bytes into the compressed file. + gzwrite returns the number of uncompressed bytes actually written + (0 in case of error). + +============================================================================} + +function gzwrite (f:gzfile; buf:voidp; len:uInt) : int; + +var + + s : gz_streamp; + written : integer; + +begin + + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + gzwrite := Z_STREAM_ERROR; + exit; + end; + + s^.stream.next_in := pBytef(buf); + s^.stream.avail_in := len; + + while (s^.stream.avail_in <> 0) do begin + + if (s^.stream.avail_out = 0) then begin + s^.stream.next_out := s^.outbuf; + blockwrite (s^.gzfile, s^.outbuf^, Z_BUFSIZE, written); + if (written <> Z_BUFSIZE) then begin + s^.z_err := Z_ERRNO; + break; + end; + s^.stream.avail_out := Z_BUFSIZE; + end; + + s^.z_err := deflate(s^.stream, Z_NO_FLUSH); + if (s^.z_err <> Z_OK) then break; + + end; {WHILE} + + s^.crc := crc32(s^.crc, buf, len); + gzwrite := int(len - s^.stream.avail_in); + +end; + + +{ =========================================================================== + Converts, formats, and writes the args to the compressed file under + control of the format string, as in fprintf. gzprintf returns the number of + uncompressed bytes actually written (0 in case of error). +} + +{$IFDEF GZ_FORMAT_STRING} +function gzprintf (zfile : gzFile; + const format : string; + a : array of int) : int; +var + buf : array[0..Z_PRINTF_BUFSIZE-1] of char; + len : int; +begin +{$ifdef HAS_snprintf} + snprintf(buf, sizeof(buf), format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$else} + sprintf(buf, format, a1, a2, a3, a4, a5, a6, a7, a8, + a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20); +{$endif} + len := strlen(buf); { old sprintf doesn't return the nb of bytes written } + if (len <= 0) return 0; + + gzprintf := gzwrite(file, buf, len); +end; +{$ENDIF} + + +{ GZPUTC ==================================================================== + + Writes c, converted to an unsigned char, into the compressed file. + gzputc returns the value that was written, or -1 in case of error. + +============================================================================} + +function gzputc (f:gzfile; c:char) : int; +begin + if (gzwrite (f,@c,1) = 1) then + {$IFDEF FPC} + gzputc := int(ord(c)) + {$ELSE} + gzputc := int(c) + {$ENDIF} + else + gzputc := -1; +end; + + +{ GZPUTS ==================================================================== + + Writes the given null-terminated string to the compressed file, excluding + the terminating null character. + gzputs returns the number of characters written, or -1 in case of error. + +============================================================================} + +function gzputs (f:gzfile; s:PChar) : int; +begin + gzputs := gzwrite (f, voidp(s), strlen(s)); +end; + + +{ DO_FLUSH ================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + +============================================================================} + +function do_flush (f:gzfile; flush:int) : int; +var + len : uInt; + done : boolean; + s : gz_streamp; + written : integer; +begin + done := false; + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'w') then begin + do_flush := Z_STREAM_ERROR; + exit; + end; + + s^.stream.avail_in := 0; { should be zero already anyway } + + while true do begin + + len := Z_BUFSIZE - s^.stream.avail_out; + + if (len <> 0) then begin + {$I-} + blockwrite(s^.gzfile, s^.outbuf^, len, written); + {$I+} + {$WARNINGS OFF} {Comparing signed and unsigned types} + if (written <> len) then begin + {$WARNINGS ON} + s^.z_err := Z_ERRNO; + do_flush := Z_ERRNO; + exit; + end; + s^.stream.next_out := s^.outbuf; + s^.stream.avail_out := Z_BUFSIZE; + end; + + if (done = true) then break; + s^.z_err := deflate(s^.stream, flush); + + { Ignore the second of two consecutive flushes: } + if (len = 0) and (s^.z_err = Z_BUF_ERROR) then s^.z_err := Z_OK; + + { deflate has finished flushing only when it hasn't used up + all the available space in the output buffer: } + + done := (s^.stream.avail_out <> 0) or (s^.z_err = Z_STREAM_END); + if (s^.z_err <> Z_OK) and (s^.z_err <> Z_STREAM_END) then break; + + end; {WHILE} + + if (s^.z_err = Z_STREAM_END) then do_flush:=Z_OK else do_flush:=s^.z_err; +end; + +{ GZFLUSH =================================================================== + + Flushes all pending output into the compressed file. + The parameter flush is as in the zdeflate() function. + + The return value is the zlib error number (see function gzerror below). + gzflush returns Z_OK if the flush parameter is Z_FINISH and all output + could be flushed. + + gzflush should be called only when strictly necessary because it can + degrade compression. + +============================================================================} + +function gzflush (f:gzfile; flush:int) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + err := do_flush (f, flush); + + if (err <> 0) then begin + gzflush := err; + exit; + end; + + if (s^.z_err = Z_STREAM_END) then gzflush := Z_OK else gzflush := s^.z_err; +end; + +{$ENDIF} (* NO DEFLATE *) + + +{ GZREWIND ================================================================== + + Rewinds input file. + +============================================================================} + +function gzrewind (f:gzFile) : int; +var + s:gz_streamp; +begin + s := gz_streamp(f); + + if (s = NIL) or (s^.mode <> 'r') then begin + gzrewind := -1; + exit; + end; + + s^.z_err := Z_OK; + s^.z_eof := false; + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + + if (s^.startpos = 0) then begin { not a compressed file } + {$I-} + seek (s^.gzfile, 0); + {$I+} + gzrewind := 0; + exit; + end; + + inflateReset(s^.stream); + {$I-} + seek (s^.gzfile, s^.startpos); + {$I+} + gzrewind := int(IOResult); + exit; +end; + + +{ GZSEEK ==================================================================== + + Sets the starting position for the next gzread or gzwrite on the given + compressed file. The offset represents a number of bytes from the beginning + of the uncompressed stream. + + gzseek returns the resulting offset, or -1 in case of error. + SEEK_END is not implemented, returns error. + In this version of the library, gzseek can be extremely slow. + +============================================================================} + +function gzseek (f:gzfile; offset:z_off_t; whence:int) : z_off_t; +var + s : gz_streamp; + size : uInt; +begin + s := gz_streamp(f); + + if (s = NIL) or (whence = SEEK_END) or (s^.z_err = Z_ERRNO) + or (s^.z_err = Z_DATA_ERROR) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzseek := z_off_t(-1); + exit; +{$ELSE} + if (whence = SEEK_SET) then dec(offset, s^.stream.total_out); + if (offset < 0) then begin; + gzseek := z_off_t(-1); + exit; + end; + + { At this point, offset is the number of zero bytes to write. } + if (s^.inbuf = Z_NULL) then begin + GetMem (s^.inbuf, Z_BUFSIZE); + zmemzero(s^.inbuf, Z_BUFSIZE); + end; + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := uInt(offset); + + size := gzwrite(f, s^.inbuf, size); + if (size = 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + dec (offset,size); + end; + + gzseek := z_off_t(s^.stream.total_in); + exit; +{$ENDIF} + end; + { Rest of function is for reading only } + + { compute absolute position } + if (whence = SEEK_CUR) then inc (offset, s^.stream.total_out); + if (offset < 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + if (s^.transparent = true) then begin + s^.stream.avail_in := 0; + s^.stream.next_in := s^.inbuf; + {$I-} + seek (s^.gzfile, offset); + {$I+} + if (IOResult <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + + s^.stream.total_in := uLong(offset); + s^.stream.total_out := uLong(offset); + gzseek := z_off_t(offset); + exit; + end; + + { For a negative seek, rewind and use positive seek } + if (uLong(offset) >= s^.stream.total_out) + then dec (offset, s^.stream.total_out) + else if (gzrewind(f) <> 0) then begin + gzseek := z_off_t(-1); + exit; + end; + { offset is now the number of bytes to skip. } + + if (offset <> 0) and (s^.outbuf = Z_NULL) + then GetMem (s^.outbuf, Z_BUFSIZE); + + while (offset > 0) do begin + size := Z_BUFSIZE; + if (offset < Z_BUFSIZE) then size := int(offset); + + size := gzread (f, s^.outbuf, size); + if (size <= 0) then begin + gzseek := z_off_t(-1); + exit; + end; + dec(offset, size); + end; + + gzseek := z_off_t(s^.stream.total_out); +end; + + +{ GZTELL ==================================================================== + + Returns the starting position for the next gzread or gzwrite on the + given compressed file. This position represents a number of bytes in the + uncompressed data stream. + +============================================================================} + +function gztell (f:gzfile) : z_off_t; +begin + gztell := gzseek (f, 0, SEEK_CUR); +end; + + +{ GZEOF ===================================================================== + + Returns TRUE when EOF has previously been detected reading the given + input stream, otherwise FALSE. + +============================================================================} + +//function gzeof (f:gzfile) : boolean; +//var +// s:gz_streamp; +//begin +// s := gz_streamp(f); + +// if (s=NIL) or (s^.mode<>'r') then +// gzeof := false +// else +// gzeof := s^.z_eof; +//end; + + +{ PUTLONG =================================================================== + + Outputs a Longint in LSB order to the given file + +============================================================================} + +procedure putLong (var f:file; x:uLong); +var + n : int; + c : byte; +begin + for n:=0 to 3 do begin + c := x and $FF; + blockwrite (f, c, 1); + x := x shr 8; + end; +end; + + +{ GZCLOSE =================================================================== + + Flushes all pending output if necessary, closes the compressed file + and deallocates all the (de)compression state. + + The return value is the zlib error number (see function gzerror below). + +============================================================================} + +function gzclose (f:gzFile) : int; +var + err : int; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + gzclose := Z_STREAM_ERROR; + exit; + end; + + if (s^.mode = 'w') then begin +{$IFDEF NO_DEFLATE} + gzclose := Z_STREAM_ERROR; + exit; +{$ELSE} + err := do_flush (f, Z_FINISH); + if (err <> Z_OK) then begin + gzclose := destroyS (gz_streamp(f)); + exit; + end; + + putLong (s^.gzfile, s^.crc); + putLong (s^.gzfile, s^.stream.total_in); +{$ENDIF} + end; + + gzclose := destroyS (gz_streamp(f)); +end; + + +{ GZERROR =================================================================== + + Returns the error message for the last error which occured on the + given compressed file. errnum is set to zlib error number. If an + error occured in the file system and not in the compression library, + errnum is set to Z_ERRNO and the application may consult errno + to get the exact error code. + +============================================================================} + +function gzerror (f:gzfile; var errnum:int) : string; +var + m : string; + s : gz_streamp; +begin + s := gz_streamp(f); + if (s = NIL) then begin + errnum := Z_STREAM_ERROR; + gzerror := zError(Z_STREAM_ERROR); + end; + + errnum := s^.z_err; + if (errnum = Z_OK) then begin + gzerror := zError(Z_OK); + exit; + end; + + m := s^.stream.msg; + if (errnum = Z_ERRNO) then m := ''; + if (m = '') then m := zError(s^.z_err); + + s^.msg := s^.path+': '+m; + gzerror := s^.msg; +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/infblock.pas b/niftiview7/gzio/infblock.pas new file mode 100755 index 0000000..70e90f1 --- /dev/null +++ b/niftiview7/gzio/infblock.pas @@ -0,0 +1,951 @@ +Unit InfBlock; + +{ infblock.h and + infblock.c -- interpret and process block types to last block + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + {$IFDEF DEBUG} + strutils, + {$ENDIF} + zutil, zlib; + +function inflate_blocks_new(var z : z_stream; + c : check_func; { check function } + w : uInt { window size } + ) : pInflate_blocks_state; + +function inflate_blocks (var s : inflate_blocks_state; + var z : z_stream; + r : int { initial return code } + ) : int; + +procedure inflate_blocks_reset (var s : inflate_blocks_state; + var z : z_stream; + c : puLong); { check value on output } + + +function inflate_blocks_free(s : pInflate_blocks_state; + var z : z_stream) : int; + +procedure inflate_set_dictionary(var s : inflate_blocks_state; + const d : array of byte; { dictionary } + n : uInt); { dictionary length } + +function inflate_blocks_sync_point(var s : inflate_blocks_state) : int; + +implementation + +uses + infcodes, inftrees, infutil; + +{ Tables for deflate from PKZIP's appnote.txt. } +Const + border : Array [0..18] Of Word { Order of the bit length code lengths } + = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); + +{ Notes beyond the 1.93a appnote.txt: + + 1. Distance pointers never point before the beginning of the output + stream. + 2. Distance pointers can point back across blocks, up to 32k away. + 3. There is an implied maximum of 7 bits for the bit length table and + 15 bits for the actual data. + 4. If only one code exists, then it is encoded using one bit. (Zero + would be more efficient, but perhaps a little confusing.) If two + codes exist, they are coded using one bit each (0 and 1). + 5. There is no way of sending zero distance codes--a dummy must be + sent if there are none. (History: a pre 2.0 version of PKZIP would + store blocks with no distance codes, but this was discovered to be + too harsh a criterion.) Valid only for 1.93a. 2.04c does allow + zero distance codes, which is sent as one code of zero bits in + length. + 6. There are up to 286 literal/length codes. Code 256 represents the + end-of-block. Note however that the static length tree defines + 288 codes just to fill out the Huffman codes. Codes 286 and 287 + cannot be used though, since there is no length base or extra bits + defined for them. Similarily, there are up to 30 distance codes. + However, static trees define 32 codes (all 5 bits) to fill out the + Huffman codes, but the last two had better not show up in the data. + 7. Unzip can check dynamic Huffman blocks for complete code sets. + The exception is that a single code would not be complete (see #4). + 8. The five bits following the block type is really the number of + literal codes sent minus 257. + 9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits + (1+6+6). Therefore, to output three times the length, you output + three codes (1+1+1), whereas to output four times the same length, + you only need two codes (1+3). Hmm. + 10. In the tree reconstruction algorithm, Code = Code + Increment + only if BitLength(i) is not zero. (Pretty obvious.) + 11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19) + 12. Note: length code 284 can represent 227-258, but length code 285 + really is 258. The last length deserves its own, short code + since it gets used a lot in very redundant files. The length + 258 is special since 258 - 3 (the min match length) is 255. + 13. The literal/length and distance code bit lengths are read as a + single stream of lengths. It is possible (and advantageous) for + a repeat code (16, 17, or 18) to go across the boundary between + the two sets of lengths. } + + +procedure inflate_blocks_reset (var s : inflate_blocks_state; + var z : z_stream; + c : puLong); { check value on output } +begin + if (c <> Z_NULL) then + c^ := s.check; + if (s.mode = BTREE) or (s.mode = DTREE) then + ZFREE(z, s.sub.trees.blens); + if (s.mode = CODES) then + inflate_codes_free(s.sub.decode.codes, z); + + s.mode := ZTYPE; + s.bitk := 0; + s.bitb := 0; + + s.write := s.window; + s.read := s.window; + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(uLong(0), pBytef(NIL), 0); + z.adler := s.check; + end; + {$IFDEF DEBUG} + Tracev('inflate: blocks reset'); + {$ENDIF} +end; + + +function inflate_blocks_new(var z : z_stream; + c : check_func; { check function } + w : uInt { window size } + ) : pInflate_blocks_state; +var + s : pInflate_blocks_state; +begin + s := pInflate_blocks_state( ZALLOC(z,1, sizeof(inflate_blocks_state)) ); + if (s = Z_NULL) then + begin + inflate_blocks_new := s; + exit; + end; + s^.hufts := huft_ptr( ZALLOC(z, sizeof(inflate_huft), MANY) ); + + if (s^.hufts = Z_NULL) then + begin + ZFREE(z, s); + inflate_blocks_new := Z_NULL; + exit; + end; + + s^.window := pBytef( ZALLOC(z, 1, w) ); + if (s^.window = Z_NULL) then + begin + ZFREE(z, s^.hufts); + ZFREE(z, s); + inflate_blocks_new := Z_NULL; + exit; + end; + s^.zend := s^.window; + Inc(s^.zend, w); + s^.checkfn := c; + s^.mode := ZTYPE; + {$IFDEF DEBUG} + Tracev('inflate: blocks allocated'); + {$ENDIF} + inflate_blocks_reset(s^, z, Z_NULL); + inflate_blocks_new := s; +end; + + +function inflate_blocks (var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; { initial return code } +label + start_btree, start_dtree, + start_blkdone, start_dry, + start_codes; + +var + t : uInt; { temporary storage } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } +{ fixed code blocks } +var + bl, bd : uInt; + tl, td : pInflate_huft; +var + h : pInflate_huft; + i, j, c : uInt; +var + cs : pInflate_codes_state; +begin + { copy input/output information to locals } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + +{ decompress an inflated block } + + + { process input based on current state } + while True do + Case s.mode of + ZTYPE: + begin + {NEEDBITS(3);} + while (k < 3) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := uInt(b) and 7; + s.last := boolean(t and 1); + case (t shr 1) of + 0: { stored } + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: stored block (last)') + else + Tracev('inflate: stored block'); + {$ENDIF} + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + t := k and 7; { go to byte boundary } + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + s.mode := LENS; { get length of stored block } + end; + 1: { fixed } + begin + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: fixed codes blocks (last)') + else + Tracev('inflate: fixed codes blocks'); + {$ENDIF} + inflate_trees_fixed(bl, bd, tl, td, z); + s.sub.decode.codes := inflate_codes_new(bl, bd, tl, td, z); + if (s.sub.decode.codes = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := CODES; + end; + 2: { dynamic } + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: dynamic codes block (last)') + else + Tracev('inflate: dynamic codes block'); + {$ENDIF} + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := TABLE; + end; + 3: + begin { illegal } + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := BLKBAD; + z.msg := 'invalid block type'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + end; + LENS: + begin + {NEEDBITS(32);} + while (k < 32) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + if (((not b) shr 16) and $ffff) <> (b and $ffff) then + begin + s.mode := BLKBAD; + z.msg := 'invalid stored block lengths'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.left := uInt(b) and $ffff; + k := 0; + b := 0; { dump bits } + {$IFDEF DEBUG} + Tracev('inflate: stored length '+IntToStr(s.sub.left)); + {$ENDIF} + if s.sub.left <> 0 then + s.mode := STORED + else + if s.last then + s.mode := DRY + else + s.mode := ZTYPE; + end; + STORED: + begin + if (n = 0) then + begin + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + t := s.sub.left; + if (t > n) then + t := n; + if (t > m) then + t := m; + zmemcpy(q, p, t); + Inc(p, t); Dec(n, t); + Inc(q, t); Dec(m, t); + Dec(s.sub.left, t); + if (s.sub.left = 0) then + begin + {$IFDEF DEBUG} + if (ptr2int(q) >= ptr2int(s.read)) then + Tracev('inflate: stored end '+ + IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out') + else + Tracev('inflate: stored end '+ + IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) + + ptr2int(q) - ptr2int(s.window)) + ' total out'); + {$ENDIF} + if s.last then + s.mode := DRY + else + s.mode := ZTYPE; + end; + end; + TABLE: + begin + {NEEDBITS(14);} + while (k < 14) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := uInt(b) and $3fff; + s.sub.trees.table := t; + {$ifndef PKZIP_BUG_WORKAROUND} + if ((t and $1f) > 29) or (((t shr 5) and $1f) > 29) then + begin + s.mode := BLKBAD; + z.msg := 'too many length or distance symbols'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {$endif} + t := 258 + (t and $1f) + ((t shr 5) and $1f); + s.sub.trees.blens := puIntArray( ZALLOC(z, t, sizeof(uInt)) ); + if (s.sub.trees.blens = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {DUMPBITS(14);} + b := b shr 14; + Dec(k, 14); + + s.sub.trees.index := 0; + {$IFDEF DEBUG} + Tracev('inflate: table sizes ok'); + {$ENDIF} + s.mode := BTREE; + { fall trough case is handled by the while } + { try GOTO for speed - Nomssi } + goto start_btree; + end; + BTREE: + begin + start_btree: + while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do + begin + {NEEDBITS(3);} + while (k < 3) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + s.sub.trees.blens^[border[s.sub.trees.index]] := uInt(b) and 7; + Inc(s.sub.trees.index); + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + end; + while (s.sub.trees.index < 19) do + begin + s.sub.trees.blens^[border[s.sub.trees.index]] := 0; + Inc(s.sub.trees.index); + end; + s.sub.trees.bb := 7; + t := inflate_trees_bits(s.sub.trees.blens^, s.sub.trees.bb, + s.sub.trees.tb, s.hufts^, z); + if (t <> Z_OK) then + begin + ZFREE(z, s.sub.trees.blens); + r := t; + if (r = Z_DATA_ERROR) then + s.mode := BLKBAD; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.trees.index := 0; + {$IFDEF DEBUG} + Tracev('inflate: bits tree ok'); + {$ENDIF} + s.mode := DTREE; + { fall through again } + goto start_dtree; + end; + DTREE: + begin + start_dtree: + while TRUE do + begin + t := s.sub.trees.table; + if not (s.sub.trees.index < 258 + + (t and $1f) + ((t shr 5) and $1f)) then + break; + t := s.sub.trees.bb; + {NEEDBITS(t);} + while (k < t) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + h := s.sub.trees.tb; + Inc(h, uInt(b) and inflate_mask[t]); + t := h^.Bits; + c := h^.Base; + + if (c < 16) then + begin + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + s.sub.trees.blens^[s.sub.trees.index] := c; + Inc(s.sub.trees.index); + end + else { c = 16..18 } + begin + if c = 18 then + begin + i := 7; + j := 11; + end + else + begin + i := c - 14; + j := 3; + end; + {NEEDBITS(t + i);} + while (k < t + i) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + Inc(j, uInt(b) and inflate_mask[i]); + {DUMPBITS(i);} + b := b shr i; + Dec(k, i); + + i := s.sub.trees.index; + t := s.sub.trees.table; + if (i + j > 258 + (t and $1f) + ((t shr 5) and $1f)) or + ((c = 16) and (i < 1)) then + begin + ZFREE(z, s.sub.trees.blens); + s.mode := BLKBAD; + z.msg := 'invalid bit length repeat'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + if c = 16 then + c := s.sub.trees.blens^[i - 1] + else + c := 0; + repeat + s.sub.trees.blens^[i] := c; + Inc(i); + Dec(j); + until (j=0); + s.sub.trees.index := i; + end; + end; { while } + s.sub.trees.tb := Z_NULL; + begin + bl := 9; { must be <= 9 for lookahead assumptions } + bd := 6; { must be <= 9 for lookahead assumptions } + t := s.sub.trees.table; + t := inflate_trees_dynamic(257 + (t and $1f), + 1 + ((t shr 5) and $1f), + s.sub.trees.blens^, bl, bd, tl, td, s.hufts^, z); + ZFREE(z, s.sub.trees.blens); + if (t <> Z_OK) then + begin + if (t = uInt(Z_DATA_ERROR)) then + s.mode := BLKBAD; + r := t; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {$IFDEF DEBUG} + Tracev('inflate: trees ok'); + {$ENDIF} + { c renamed to cs } + cs := inflate_codes_new(bl, bd, tl, td, z); + if (cs = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.decode.codes := cs; + end; + s.mode := CODES; + { yet another falltrough } + goto start_codes; + end; + CODES: + begin + start_codes: + { update pointers } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + r := inflate_codes(s, z, r); + if (r <> Z_STREAM_END) then + begin + inflate_blocks := inflate_flush(s, z, r); + exit; + end; + r := Z_OK; + inflate_codes_free(s.sub.decode.codes, z); + { load local pointers } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + {$IFDEF DEBUG} + if (ptr2int(q) >= ptr2int(s.read)) then + Tracev('inflate: codes end '+ + IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out') + else + Tracev('inflate: codes end '+ + IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) + + ptr2int(q) - ptr2int(s.window)) + ' total out'); + {$ENDIF} + if (not s.last) then + begin + s.mode := ZTYPE; + continue; { break for switch statement in C-code } + end; + {$ifndef patch112} + if (k > 7) then { return unused byte, if any } + begin + {$IFDEF DEBUG} + Assert(k < 16, 'inflate_codes grabbed too many bytes'); + {$ENDIF} + Dec(k, 8); + Inc(n); + Dec(p); { can always return one } + end; + {$endif} + s.mode := DRY; + { another falltrough } + goto start_dry; + end; + DRY: + begin + start_dry: + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + + { not needed anymore, we are done: + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + } + + if (s.read <> s.write) then + begin + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.mode := BLKDONE; + goto start_blkdone; + end; + BLKDONE: + begin + start_blkdone: + r := Z_STREAM_END; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + BLKBAD: + begin + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + else + begin + r := Z_STREAM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; { Case s.mode of } + +end; + + +function inflate_blocks_free(s : pInflate_blocks_state; + var z : z_stream) : int; +begin + inflate_blocks_reset(s^, z, Z_NULL); + ZFREE(z, s^.window); + ZFREE(z, s^.hufts); + ZFREE(z, s); + {$IFDEF DEBUG} + Trace('inflate: blocks freed'); + {$ENDIF} + inflate_blocks_free := Z_OK; +end; + + +procedure inflate_set_dictionary(var s : inflate_blocks_state; + const d : array of byte; { dictionary } + n : uInt); { dictionary length } +begin + zmemcpy(s.window, pBytef(@d), n); + s.write := s.window; + Inc(s.write, n); + s.read := s.write; +end; + + +{ Returns true if inflate is currently at the end of a block generated + by Z_SYNC_FLUSH or Z_FULL_FLUSH. + IN assertion: s <> Z_NULL } + +function inflate_blocks_sync_point(var s : inflate_blocks_state) : int; +begin + inflate_blocks_sync_point := int(s.mode = LENS); +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/inffast.pas b/niftiview7/gzio/inffast.pas new file mode 100755 index 0000000..668f71b --- /dev/null +++ b/niftiview7/gzio/inffast.pas @@ -0,0 +1,318 @@ +Unit InfFast; + +{ + inffast.h and + inffast.c -- process literals and length/distance pairs fast + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + + +interface + +{$I zconf.inc} + +uses + {$ifdef DEBUG} + strutils, + {$ENDIF} + zutil, zlib; + +function inflate_fast( bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var s : inflate_blocks_state; + var z : z_stream) : int; + + +implementation + +uses + infutil; + + +{ Called with number of bytes left to write in window at least 258 + (the maximum string length) and number of input bytes available + at least ten. The ten bytes are six bytes for the longest length/ + distance pair plus four bytes for overloading the bit buffer. } + +function inflate_fast( bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var s : inflate_blocks_state; + var z : z_stream) : int; + +var + t : pInflate_huft; { temporary pointer } + e : uInt; { extra bits or operation } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } + ml : uInt; { mask for literal/length tree } + md : uInt; { mask for distance tree } + c : uInt; { bytes to copy } + d : uInt; { distance back to copy from } + r : pBytef; { copy source pointer } +begin + { load input, output, bit values (macro LOAD) } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + { initialize masks } + ml := inflate_mask[bl]; + md := inflate_mask[bd]; + + { do until not enough input or output space for fast loop } + repeat { assume called with (m >= 258) and (n >= 10) } + { get literal/length code } + {GRABBITS(20);} { max bits for literal/length code } + while (k < 20) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := @(huft_ptr(tl)^[uInt(b) and ml]); + + e := t^.exop; + if (e = 0) then + begin + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: * literal '+char(t^.base)) + else + Tracevv('inflate: * literal '+ IntToStr(t^.base)); + {$ENDIF} + q^ := Byte(t^.base); + Inc(q); + Dec(m); + continue; + end; + repeat + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + if (e and 16 <> 0) then + begin + { get extra bits for length } + e := e and 15; + c := t^.base + (uInt(b) and inflate_mask[e]); + {DUMPBITS(e);} + b := b shr e; + Dec(k, e); + {$IFDEF DEBUG} + Tracevv('inflate: * length ' + IntToStr(c)); + {$ENDIF} + { decode distance base of block to copy } + {GRABBITS(15);} { max bits for distance code } + while (k < 15) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := @huft_ptr(td)^[uInt(b) and md]; + e := t^.exop; + repeat + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + if (e and 16 <> 0) then + begin + { get extra bits to add to distance base } + e := e and 15; + {GRABBITS(e);} { get extra bits (up to 13) } + while (k < e) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + d := t^.base + (uInt(b) and inflate_mask[e]); + {DUMPBITS(e);} + b := b shr e; + Dec(k, e); + + {$IFDEF DEBUG} + Tracevv('inflate: * distance '+IntToStr(d)); + {$ENDIF} + { do the copy } + Dec(m, c); + if (uInt(ptr2int(q) - ptr2int(s.window)) >= d) then { offset before dest } + begin { just copy } + r := q; + Dec(r, d); + q^ := r^; Inc(q); Inc(r); Dec(c); { minimum count is three, } + q^ := r^; Inc(q); Inc(r); Dec(c); { so unroll loop a little } + end + else { else offset after destination } + begin + e := d - uInt(ptr2int(q) - ptr2int(s.window)); { bytes from offset to end } + r := s.zend; + Dec(r, e); { pointer to offset } + if (c > e) then { if source crosses, } + begin + Dec(c, e); { copy to end of window } + repeat + q^ := r^; + Inc(q); + Inc(r); + Dec(e); + until (e=0); + r := s.window; { copy rest from start of window } + end; + end; + repeat { copy all or what's left } + q^ := r^; + Inc(q); + Inc(r); + Dec(c); + until (c = 0); + break; + end + else + if (e and 64 = 0) then + begin + Inc(t, t^.base + (uInt(b) and inflate_mask[e])); + e := t^.exop; + end + else + begin + z.msg := 'invalid distance code'; + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + inflate_fast := Z_DATA_ERROR; + exit; + end; + until FALSE; + break; + end; + if (e and 64 = 0) then + begin + {t += t->base; + e = (t += ((uInt)b & inflate_mask[e]))->exop;} + + Inc(t, t^.base + (uInt(b) and inflate_mask[e])); + e := t^.exop; + if (e = 0) then + begin + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: * literal '+char(t^.base)) + else + Tracevv('inflate: * literal '+IntToStr(t^.base)); + {$ENDIF} + q^ := Byte(t^.base); + Inc(q); + Dec(m); + break; + end; + end + else + if (e and 32 <> 0) then + begin + {$IFDEF DEBUG} + Tracevv('inflate: * end of block'); + {$ENDIF} + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_STREAM_END; + exit; + end + else + begin + z.msg := 'invalid literal/length code'; + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_DATA_ERROR; + exit; + end; + until FALSE; + until (m < 258) or (n < 10); + + { not enough input or output--restore pointers and return } + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_OK; +end; + +end. \ No newline at end of file diff --git a/niftiview7/gzio/inftrees.pas b/niftiview7/gzio/inftrees.pas new file mode 100755 index 0000000..74ec067 --- /dev/null +++ b/niftiview7/gzio/inftrees.pas @@ -0,0 +1,780 @@ +Unit InfTrees; + +{ inftrees.h -- header to use inftrees.c + inftrees.c -- generate Huffman trees for efficient decoding + Copyright (C) 1995-1998 Mark Adler + + WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +Interface + +{$I zconf.inc} + +uses + zutil, zlib; + + +{ Maximum size of dynamic tree. The maximum found in a long but non- + exhaustive search was 1004 huft structures (850 for length/literals + and 154 for distances, the latter actually the result of an + exhaustive search). The actual maximum is not known, but the + value below is more than safe. } +const + MANY = 1440; + + +{$ifdef DEBUG} +var + inflate_hufts : uInt; +{$endif} + +function inflate_trees_bits( + var c : array of uIntf; { 19 code lengths } + var bb : uIntf; { bits tree desired/actual depth } + var tb : pinflate_huft; { bits tree result } + var hp : array of Inflate_huft; { space for trees } + var z : z_stream { for messages } + ) : int; + +function inflate_trees_dynamic( + nl : uInt; { number of literal/length codes } + nd : uInt; { number of distance codes } + var c : Array of uIntf; { that many (total) code lengths } + var bl : uIntf; { literal desired/actual bit depth } + var bd : uIntf; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var hp : array of Inflate_huft; { space for trees } +var z : z_stream { for messages } + ) : int; + +function inflate_trees_fixed ( + var bl : uInt; { literal desired/actual bit depth } + var bd : uInt; { distance desired/actual bit depth } + var tl : pInflate_huft; { literal/length tree result } + var td : pInflate_huft; { distance tree result } + var z : z_stream { for memory allocation } + ) : int; + + +implementation + +const + inflate_copyright = 'inflate 1.1.2 Copyright 1995-1998 Mark Adler'; + +{ + If you use the zlib library in a product, an acknowledgment is welcome + in the documentation of your product. If for some reason you cannot + include such an acknowledgment, I would appreciate that you keep this + copyright string in the executable of your product. +} + + +const +{ Tables for deflate from PKZIP's appnote.txt. } + cplens : Array [0..30] Of uInt { Copy lengths for literal codes 257..285 } + = (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, + 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0); + { actually lengths - 2; also see note #13 above about 258 } + + invalid_code = 112; + + cplext : Array [0..30] Of uInt { Extra bits for literal codes 257..285 } + = (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, + 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid_code, invalid_code); + + cpdist : Array [0..29] Of uInt { Copy offsets for distance codes 0..29 } + = (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, + 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, + 8193, 12289, 16385, 24577); + + cpdext : Array [0..29] Of uInt { Extra bits for distance codes } + = (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, + 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, + 12, 12, 13, 13); + +{ Huffman code decoding is performed using a multi-level table lookup. + The fastest way to decode is to simply build a lookup table whose + size is determined by the longest code. However, the time it takes + to build this table can also be a factor if the data being decoded + is not very long. The most common codes are necessarily the + shortest codes, so those codes dominate the decoding time, and hence + the speed. The idea is you can have a shorter table that decodes the + shorter, more probable codes, and then point to subsidiary tables for + the longer codes. The time it costs to decode the longer codes is + then traded against the time it takes to make longer tables. + + This results of this trade are in the variables lbits and dbits + below. lbits is the number of bits the first level table for literal/ + length codes can decode in one step, and dbits is the same thing for + the distance codes. Subsequent tables are also less than or equal to + those sizes. These values may be adjusted either when all of the + codes are shorter than that, in which case the longest code length in + bits is used, or when the shortest code is *longer* than the requested + table size, in which case the length of the shortest code in bits is + used. + + There are two different values for the two tables, since they code a + different number of possibilities each. The literal/length table + codes 286 possible values, or in a flat code, a little over eight + bits. The distance table codes 30 possible values, or a little less + than five bits, flat. The optimum values for speed end up being + about one bit more than those, so lbits is 8+1 and dbits is 5+1. + The optimum values may differ though from machine to machine, and + possibly even between compilers. Your mileage may vary. } + + +{ If BMAX needs to be larger than 16, then h and x[] should be uLong. } +const + BMAX = 15; { maximum bit length of any code } + +{$DEFINE USE_PTR} + +function huft_build( +var b : array of uIntf; { code lengths in bits (all assumed <= BMAX) } + n : uInt; { number of codes (assumed <= N_MAX) } + s : uInt; { number of simple-valued codes (0..s-1) } +const d : array of uIntf; { list of base values for non-simple codes } +{ array of word } +const e : array of uIntf; { list of extra bits for non-simple codes } +{ array of byte } + t : ppInflate_huft; { result: starting table } +var m : uIntf; { maximum lookup bits, returns actual } +var hp : array of inflate_huft; { space for trees } +var hn : uInt; { hufts used in space } +var v : array of uIntf { working area: values in order of bit length } + ) : int; +{ Given a list of code lengths and a maximum table size, make a set of + tables to decode that set of codes. Return Z_OK on success, Z_BUF_ERROR + if the given code set is incomplete (the tables are still built in this + case), Z_DATA_ERROR if the input is invalid (an over-subscribed set of + lengths), or Z_MEM_ERROR if not enough memory. } +Var + a : uInt; { counter for codes of length k } + c : Array [0..BMAX] Of uInt; { bit length count table } + f : uInt; { i repeats in table every f entries } + g : int; { maximum code length } + h : int; { table level } + i : uInt; {register} { counter, current code } + j : uInt; {register} { counter } + k : Int; {register} { number of bits in current code } + l : int; { bits per table (returned in m) } + mask : uInt; { (1 shl w) - 1, to avoid cc -O bug on HP } + p : ^uIntf; {register} { pointer into c[], b[], or v[] } + q : pInflate_huft; { points to current table } + r : inflate_huft; { table entry for structure assignment } + u : Array [0..BMAX-1] Of pInflate_huft; { table stack } + w : int; {register} { bits before this table = (l*h) } + x : Array [0..BMAX] Of uInt; { bit offsets, then code stack } + {$IFDEF USE_PTR} + xp : puIntf; { pointer into x } + {$ELSE} + xp : uInt; + {$ENDIF} + y : int; { number of dummy codes added } + z : uInt; { number of entries in current table } +Begin + { Generate counts for each bit length } + FillChar(c,SizeOf(c),0) ; { clear c[] } + + for i := 0 to n-1 do + Inc (c[b[i]]); { assume all entries <= BMAX } + + If (c[0] = n) Then { null input--all zero length codes } + Begin + t^ := pInflate_huft(NIL); + m := 0 ; + huft_build := Z_OK ; + Exit; + End ; + + { Find minimum and maximum length, bound [m] by those } + l := m; + for j:=1 To BMAX do + if (c[j] <> 0) then + break; + k := j ; { minimum code length } + if (uInt(l) < j) then + l := j; + for i := BMAX downto 1 do + if (c[i] <> 0) then + break ; + g := i ; { maximum code length } + if (uInt(l) > i) then + l := i; + m := l; + + { Adjust last length count to fill out codes, if needed } + y := 1 shl j ; + while (j < i) do + begin + Dec(y, c[j]) ; + if (y < 0) then + begin + huft_build := Z_DATA_ERROR; { bad input: more codes than bits } + exit; + end ; + Inc(j) ; + y := y shl 1 + end; + Dec (y, c[i]) ; + if (y < 0) then + begin + huft_build := Z_DATA_ERROR; { bad input: more codes than bits } + exit; + end; + Inc(c[i], y); + + { Generate starting offsets into the value table FOR each length } + {$IFDEF USE_PTR} + x[1] := 0; + j := 0; + + p := @c[1]; + xp := @x[2]; + + dec(i); { note that i = g from above } + WHILE (i > 0) DO + BEGIN + inc(j, p^); + xp^ := j; + inc(p); + inc(xp); + dec(i); + END; + {$ELSE} + x[1] := 0; + j := 0 ; + for i := 1 to g do + begin + x[i] := j; + Inc(j, c[i]); + end; + {$ENDIF} + + { Make a table of values in order of bit lengths } + for i := 0 to n-1 do + begin + j := b[i]; + if (j <> 0) then + begin + v[ x[j] ] := i; + Inc(x[j]); + end; + end; + n := x[g]; { set n to length of v } + + { Generate the Huffman codes and for each, make the table entries } + i := 0 ; + x[0] := 0 ; { first Huffman code is zero } + p := Addr(v) ; { grab values in bit order } + h := -1 ; { no tables yet--level -1 } + w := -l ; { bits decoded = (l*h) } + + u[0] := pInflate_huft(NIL); { just to keep compilers happy } + q := pInflate_huft(NIL); { ditto } + z := 0 ; { ditto } + + { go through the bit lengths (k already is bits in shortest code) } + while (k <= g) Do + begin + a := c[k] ; + while (a<>0) Do + begin + Dec (a) ; + { here i is the Huffman code of length k bits for value p^ } + { make tables up to required level } + while (k > w + l) do + begin + + Inc (h) ; + Inc (w, l); { add bits already decoded } + { previous table always l bits } + { compute minimum size table less than or equal to l bits } + + { table size upper limit } + z := g - w; + If (z > uInt(l)) Then + z := l; + + { try a k-w bit table } + j := k - w; + f := 1 shl j; + if (f > a+1) Then { too few codes for k-w bit table } + begin + Dec(f, a+1); { deduct codes from patterns left } + {$IFDEF USE_PTR} + xp := Addr(c[k]); + + if (j < z) then + begin + Inc(j); + while (j < z) do + begin { try smaller tables up to z bits } + f := f shl 1; + Inc (xp) ; + If (f <= xp^) Then + break; { enough codes to use up j bits } + Dec(f, xp^); { else deduct codes from patterns } + Inc(j); + end; + end; + {$ELSE} + xp := k; + + if (j < z) then + begin + Inc (j) ; + While (j < z) Do + begin { try smaller tables up to z bits } + f := f * 2; + Inc (xp) ; + if (f <= c[xp]) then + Break ; { enough codes to use up j bits } + Dec (f, c[xp]) ; { else deduct codes from patterns } + Inc (j); + end; + end; + {$ENDIF} + end; + + z := 1 shl j; { table entries for j-bit table } + + { allocate new table } + if (hn + z > MANY) then { (note: doesn't matter for fixed) } + begin + huft_build := Z_MEM_ERROR; { not enough memory } + exit; + end; + + q := @hp[hn]; + u[h] := q; + Inc(hn, z); + + { connect to last table, if there is one } + if (h <> 0) then + begin + x[h] := i; { save pattern for backing up } + r.bits := Byte(l); { bits to dump before this table } + r.exop := Byte(j); { bits in this table } + j := i shr (w - l); + {r.base := uInt( q - u[h-1] -j);} { offset to this table } + r.base := (ptr2int(q) - ptr2int(u[h-1]) ) div sizeof(q^) - j; + huft_Ptr(u[h-1])^[j] := r; { connect to last table } + end + else + t^ := q; { first table is returned result } + end; + + { set up table entry in r } + r.bits := Byte(k - w); + + { C-code: if (p >= v + n) - see ZUTIL.PAS for comments } + + if ptr2int(p)>=ptr2int(@(v[n])) then { also works under DPMI ?? } + r.exop := 128 + 64 { out of values--invalid code } + else + if (p^ < s) then + begin + if (p^ < 256) then { 256 is end-of-block code } + r.exop := 0 + Else + r.exop := 32 + 64; { EOB_code; } + r.base := p^; { simple code is just the value } + Inc(p); + end + Else + begin + r.exop := Byte(e[p^-s] + 16 + 64); { non-simple--look up in lists } + r.base := d[p^-s]; + Inc (p); + end ; + + { fill code-like entries with r } + f := 1 shl (k - w); + j := i shr w; + while (j < z) do + begin + huft_Ptr(q)^[j] := r; + Inc(j, f); + end; + + { backwards increment the k-bit code i } + j := 1 shl (k-1) ; + while (i and j) <> 0 do + begin + i := i xor j; { bitwise exclusive or } + j := j shr 1 + end ; + i := i xor j; + + { backup over finished tables } + mask := (1 shl w) - 1; { needed on HP, cc -O bug } + while ((i and mask) <> x[h]) do + begin + Dec(h); { don't need to update q } + Dec(w, l); + mask := (1 shl w) - 1; + end; + + end; + + Inc(k); + end; + + { Return Z_BUF_ERROR if we were given an incomplete table } + if (y <> 0) And (g <> 1) then + huft_build := Z_BUF_ERROR + else + huft_build := Z_OK; +end; { huft_build} + + +function inflate_trees_bits( + var c : array of uIntf; { 19 code lengths } + var bb : uIntf; { bits tree desired/actual depth } + var tb : pinflate_huft; { bits tree result } + var hp : array of Inflate_huft; { space for trees } + var z : z_stream { for messages } + ) : int; +var + r : int; + hn : uInt; { hufts used in space } + v : PuIntArray; { work area for huft_build } +begin + hn := 0; + v := PuIntArray( ZALLOC(z, 19, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + inflate_trees_bits := Z_MEM_ERROR; + exit; + end; + + r := huft_build(c, 19, 19, cplens, cplext, + {puIntf(Z_NULL), puIntf(Z_NULL),} + @tb, bb, hp, hn, v^); + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed dynamic bit lengths tree' + else + if (r = Z_BUF_ERROR) or (bb = 0) then + begin + z.msg := 'incomplete dynamic bit lengths tree'; + r := Z_DATA_ERROR; + end; + ZFREE(z, v); + inflate_trees_bits := r; +end; + + +function inflate_trees_dynamic( + nl : uInt; { number of literal/length codes } + nd : uInt; { number of distance codes } + var c : Array of uIntf; { that many (total) code lengths } + var bl : uIntf; { literal desired/actual bit depth } + var bd : uIntf; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var hp : array of Inflate_huft; { space for trees } +var z : z_stream { for messages } + ) : int; +var + r : int; + hn : uInt; { hufts used in space } + v : PuIntArray; { work area for huft_build } +begin + hn := 0; + { allocate work area } + v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + inflate_trees_dynamic := Z_MEM_ERROR; + exit; + end; + + { build literal/length tree } + r := huft_build(c, nl, 257, cplens, cplext, @tl, bl, hp, hn, v^); + if (r <> Z_OK) or (bl = 0) then + begin + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed literal/length tree' + else + if (r <> Z_MEM_ERROR) then + begin + z.msg := 'incomplete literal/length tree'; + r := Z_DATA_ERROR; + end; + + ZFREE(z, v); + inflate_trees_dynamic := r; + exit; + end; + + { build distance tree } + r := huft_build(puIntArray(@c[nl])^, nd, 0, + cpdist, cpdext, @td, bd, hp, hn, v^); + if (r <> Z_OK) or ((bd = 0) and (nl > 257)) then + begin + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed literal/length tree' + else + if (r = Z_BUF_ERROR) then + begin +{$ifdef PKZIP_BUG_WORKAROUND} + r := Z_OK; + end; +{$else} + z.msg := 'incomplete literal/length tree'; + r := Z_DATA_ERROR; + end + else + if (r <> Z_MEM_ERROR) then + begin + z.msg := 'empty distance tree with lengths'; + r := Z_DATA_ERROR; + end; + ZFREE(z, v); + inflate_trees_dynamic := r; + exit; +{$endif} + end; + + { done } + ZFREE(z, v); + inflate_trees_dynamic := Z_OK; +end; + +{$UNDEF BUILDFIXED} + +{ build fixed tables only once--keep them here } +{$IFNDEF BUILDFIXED} +{ locals } +const + fixed_built : Boolean = false; + FIXEDH = 544; { number of hufts used by fixed tables } +var + fixed_mem : array[0..FIXEDH-1] of inflate_huft; + fixed_bl : uInt; + fixed_bd : uInt; + fixed_tl : pInflate_huft; + fixed_td : pInflate_huft; + +{$ELSE} + +{ inffixed.h -- table for decoding fixed codes } + +{local} +const + fixed_bl = uInt(9); +{local} +const + fixed_bd = uInt(5); +{local} +const + fixed_tl : array [0..288-1] of inflate_huft = ( + Exop, { number of extra bits or operation } + bits : Byte; { number of bits in this code or subcode } + {pad : uInt;} { pad structure to a power of 2 (4 bytes for } + { 16-bit, 8 bytes for 32-bit int's) } + base : uInt; { literal, length base, or distance base } + { or table offset } + + ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), ((82,7),31), + ((0,8),112), ((0,8),48), ((0,9),192), ((80,7),10), ((0,8),96), + ((0,8),32), ((0,9),160), ((0,8),0), ((0,8),128), ((0,8),64), + ((0,9),224), ((80,7),6), ((0,8),88), ((0,8),24), ((0,9),144), + ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),208), ((81,7),17), + ((0,8),104), ((0,8),40), ((0,9),176), ((0,8),8), ((0,8),136), + ((0,8),72), ((0,9),240), ((80,7),4), ((0,8),84), ((0,8),20), + ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), ((0,9),200), + ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),168), ((0,8),4), + ((0,8),132), ((0,8),68), ((0,9),232), ((80,7),8), ((0,8),92), + ((0,8),28), ((0,9),152), ((84,7),83), ((0,8),124), ((0,8),60), + ((0,9),216), ((82,7),23), ((0,8),108), ((0,8),44), ((0,9),184), + ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),248), ((80,7),3), + ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), ((0,8),114), + ((0,8),50), ((0,9),196), ((81,7),11), ((0,8),98), ((0,8),34), + ((0,9),164), ((0,8),2), ((0,8),130), ((0,8),66), ((0,9),228), + ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),148), ((84,7),67), + ((0,8),122), ((0,8),58), ((0,9),212), ((82,7),19), ((0,8),106), + ((0,8),42), ((0,9),180), ((0,8),10), ((0,8),138), ((0,8),74), + ((0,9),244), ((80,7),5), ((0,8),86), ((0,8),22), ((192,8),0), + ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),204), ((81,7),15), + ((0,8),102), ((0,8),38), ((0,9),172), ((0,8),6), ((0,8),134), + ((0,8),70), ((0,9),236), ((80,7),9), ((0,8),94), ((0,8),30), + ((0,9),156), ((84,7),99), ((0,8),126), ((0,8),62), ((0,9),220), + ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),188), ((0,8),14), + ((0,8),142), ((0,8),78), ((0,9),252), ((96,7),256), ((0,8),81), + ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), ((0,8),49), + ((0,9),194), ((80,7),10), ((0,8),97), ((0,8),33), ((0,9),162), + ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),226), ((80,7),6), + ((0,8),89), ((0,8),25), ((0,9),146), ((83,7),59), ((0,8),121), + ((0,8),57), ((0,9),210), ((81,7),17), ((0,8),105), ((0,8),41), + ((0,9),178), ((0,8),9), ((0,8),137), ((0,8),73), ((0,9),242), + ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), ((83,7),43), + ((0,8),117), ((0,8),53), ((0,9),202), ((81,7),13), ((0,8),101), + ((0,8),37), ((0,9),170), ((0,8),5), ((0,8),133), ((0,8),69), + ((0,9),234), ((80,7),8), ((0,8),93), ((0,8),29), ((0,9),154), + ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),218), ((82,7),23), + ((0,8),109), ((0,8),45), ((0,9),186), ((0,8),13), ((0,8),141), + ((0,8),77), ((0,9),250), ((80,7),3), ((0,8),83), ((0,8),19), + ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), ((0,9),198), + ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),166), ((0,8),3), + ((0,8),131), ((0,8),67), ((0,9),230), ((80,7),7), ((0,8),91), + ((0,8),27), ((0,9),150), ((84,7),67), ((0,8),123), ((0,8),59), + ((0,9),214), ((82,7),19), ((0,8),107), ((0,8),43), ((0,9),182), + ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),246), ((80,7),5), + ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), ((0,8),119), + ((0,8),55), ((0,9),206), ((81,7),15), ((0,8),103), ((0,8),39), + ((0,9),174), ((0,8),7), ((0,8),135), ((0,8),71), ((0,9),238), + ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),158), ((84,7),99), + ((0,8),127), ((0,8),63), ((0,9),222), ((82,7),27), ((0,8),111), + ((0,8),47), ((0,9),190), ((0,8),15), ((0,8),143), ((0,8),79), + ((0,9),254), ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), + ((82,7),31), ((0,8),112), ((0,8),48), ((0,9),193), ((80,7),10), + ((0,8),96), ((0,8),32), ((0,9),161), ((0,8),0), ((0,8),128), + ((0,8),64), ((0,9),225), ((80,7),6), ((0,8),88), ((0,8),24), + ((0,9),145), ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),209), + ((81,7),17), ((0,8),104), ((0,8),40), ((0,9),177), ((0,8),8), + ((0,8),136), ((0,8),72), ((0,9),241), ((80,7),4), ((0,8),84), + ((0,8),20), ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), + ((0,9),201), ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),169), + ((0,8),4), ((0,8),132), ((0,8),68), ((0,9),233), ((80,7),8), + ((0,8),92), ((0,8),28), ((0,9),153), ((84,7),83), ((0,8),124), + ((0,8),60), ((0,9),217), ((82,7),23), ((0,8),108), ((0,8),44), + ((0,9),185), ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),249), + ((80,7),3), ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), + ((0,8),114), ((0,8),50), ((0,9),197), ((81,7),11), ((0,8),98), + ((0,8),34), ((0,9),165), ((0,8),2), ((0,8),130), ((0,8),66), + ((0,9),229), ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),149), + ((84,7),67), ((0,8),122), ((0,8),58), ((0,9),213), ((82,7),19), + ((0,8),106), ((0,8),42), ((0,9),181), ((0,8),10), ((0,8),138), + ((0,8),74), ((0,9),245), ((80,7),5), ((0,8),86), ((0,8),22), + ((192,8),0), ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),205), + ((81,7),15), ((0,8),102), ((0,8),38), ((0,9),173), ((0,8),6), + ((0,8),134), ((0,8),70), ((0,9),237), ((80,7),9), ((0,8),94), + ((0,8),30), ((0,9),157), ((84,7),99), ((0,8),126), ((0,8),62), + ((0,9),221), ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),189), + ((0,8),14), ((0,8),142), ((0,8),78), ((0,9),253), ((96,7),256), + ((0,8),81), ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), + ((0,8),49), ((0,9),195), ((80,7),10), ((0,8),97), ((0,8),33), + ((0,9),163), ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),227), + ((80,7),6), ((0,8),89), ((0,8),25), ((0,9),147), ((83,7),59), + ((0,8),121), ((0,8),57), ((0,9),211), ((81,7),17), ((0,8),105), + ((0,8),41), ((0,9),179), ((0,8),9), ((0,8),137), ((0,8),73), + ((0,9),243), ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), + ((83,7),43), ((0,8),117), ((0,8),53), ((0,9),203), ((81,7),13), + ((0,8),101), ((0,8),37), ((0,9),171), ((0,8),5), ((0,8),133), + ((0,8),69), ((0,9),235), ((80,7),8), ((0,8),93), ((0,8),29), + ((0,9),155), ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),219), + ((82,7),23), ((0,8),109), ((0,8),45), ((0,9),187), ((0,8),13), + ((0,8),141), ((0,8),77), ((0,9),251), ((80,7),3), ((0,8),83), + ((0,8),19), ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), + ((0,9),199), ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),167), + ((0,8),3), ((0,8),131), ((0,8),67), ((0,9),231), ((80,7),7), + ((0,8),91), ((0,8),27), ((0,9),151), ((84,7),67), ((0,8),123), + ((0,8),59), ((0,9),215), ((82,7),19), ((0,8),107), ((0,8),43), + ((0,9),183), ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),247), + ((80,7),5), ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), + ((0,8),119), ((0,8),55), ((0,9),207), ((81,7),15), ((0,8),103), + ((0,8),39), ((0,9),175), ((0,8),7), ((0,8),135), ((0,8),71), + ((0,9),239), ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),159), + ((84,7),99), ((0,8),127), ((0,8),63), ((0,9),223), ((82,7),27), + ((0,8),111), ((0,8),47), ((0,9),191), ((0,8),15), ((0,8),143), + ((0,8),79), ((0,9),255) + ); + +{local} +const + fixed_td : array[0..32-1] of inflate_huft = ( +(Exop:80;bits:5;base:1), (Exop:87;bits:5;base:257), (Exop:83;bits:5;base:17), +(Exop:91;bits:5;base:4097), (Exop:81;bits:5;base), (Exop:89;bits:5;base:1025), +(Exop:85;bits:5;base:65), (Exop:93;bits:5;base:16385), (Exop:80;bits:5;base:3), +(Exop:88;bits:5;base:513), (Exop:84;bits:5;base:33), (Exop:92;bits:5;base:8193), +(Exop:82;bits:5;base:9), (Exop:90;bits:5;base:2049), (Exop:86;bits:5;base:129), +(Exop:192;bits:5;base:24577), (Exop:80;bits:5;base:2), (Exop:87;bits:5;base:385), +(Exop:83;bits:5;base:25), (Exop:91;bits:5;base:6145), (Exop:81;bits:5;base:7), +(Exop:89;bits:5;base:1537), (Exop:85;bits:5;base:97), (Exop:93;bits:5;base:24577), +(Exop:80;bits:5;base:4), (Exop:88;bits:5;base:769), (Exop:84;bits:5;base:49), +(Exop:92;bits:5;base:12289), (Exop:82;bits:5;base:13), (Exop:90;bits:5;base:3073), +(Exop:86;bits:5;base:193), (Exop:192;bits:5;base:24577) + ); +{$ENDIF} + +function inflate_trees_fixed( +var bl : uInt; { literal desired/actual bit depth } +var bd : uInt; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var z : z_stream { for memory allocation } + ) : int; +type + pFixed_table = ^fixed_table; + fixed_table = array[0..288-1] of uIntf; +var + k : int; { temporary variable } + c : pFixed_table; { length list for huft_build } + v : PuIntArray; { work area for huft_build } +var + f : uInt; { number of hufts used in fixed_mem } +begin + { build fixed tables if not already (multiple overlapped executions ok) } + if not fixed_built then + begin + f := 0; + + { allocate memory } + c := pFixed_table( ZALLOC(z, 288, sizeof(uInt)) ); + if (c = Z_NULL) then + begin + inflate_trees_fixed := Z_MEM_ERROR; + exit; + end; + v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + ZFREE(z, c); + inflate_trees_fixed := Z_MEM_ERROR; + exit; + end; + + { literal table } + for k := 0 to Pred(144) do + c^[k] := 8; + for k := 144 to Pred(256) do + c^[k] := 9; + for k := 256 to Pred(280) do + c^[k] := 7; + for k := 280 to Pred(288) do + c^[k] := 8; + fixed_bl := 9; + huft_build(c^, 288, 257, cplens, cplext, @fixed_tl, fixed_bl, + fixed_mem, f, v^); + + { distance table } + for k := 0 to Pred(30) do + c^[k] := 5; + fixed_bd := 5; + huft_build(c^, 30, 0, cpdist, cpdext, @fixed_td, fixed_bd, + fixed_mem, f, v^); + + { done } + ZFREE(z, v); + ZFREE(z, c); + fixed_built := True; + end; + bl := fixed_bl; + bd := fixed_bd; + tl := fixed_tl; + td := fixed_td; + inflate_trees_fixed := Z_OK; +end; { inflate_trees_fixed } + + +end. \ No newline at end of file diff --git a/niftiview7/gzio/infutil.pas b/niftiview7/gzio/infutil.pas new file mode 100755 index 0000000..e5c0858 --- /dev/null +++ b/niftiview7/gzio/infutil.pas @@ -0,0 +1,222 @@ +Unit infutil; + +{ types and macros common to blocks and codes + Copyright (C) 1995-1998 Mark Adler + + WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +uses + zutil, zlib; + +{ copy as much as possible from the sliding window to the output area } +function inflate_flush(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; + +{ And'ing with mask[n] masks the lower n bits } +const + inflate_mask : array[0..17-1] of uInt = ( + $0000, + $0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff, + $01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff); + +{procedure GRABBITS(j : int);} +{procedure DUMPBITS(j : int);} +{procedure NEEDBITS(j : int);} + +implementation + +{ macros for bit input with no checking and for returning unused bytes } +//procedure GRABBITS(j : int); +//begin + {while (k < j) do + begin + Dec(z^.avail_in); + Inc(z^.total_in); + b := b or (uLong(z^.next_in^) shl k); + Inc(z^.next_in); + Inc(k, 8); + end;} +//end; + +//procedure DUMPBITS(j : int); +//begin + {b := b shr j; + Dec(k, j);} +//end; + +//procedure NEEDBITS(j : int); +//begin + (* + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); + z.next_in := p; + s.write := q; + result := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + *) +//end; + +//procedure NEEDOUT; +//begin + (* + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); + z.next_in := p; + s.write := q; + result := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + *) +//end; + +{ copy as much as possible from the sliding window to the output area } +function inflate_flush(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; +var + n : uInt; + p : pBytef; + q : pBytef; +begin + { local copies of source and destination pointers } + p := z.next_out; + q := s.read; + + { compute number of bytes to copy as far as end of window } + if ptr2int(q) <= ptr2int(s.write) then + n := uInt(ptr2int(s.write) - ptr2int(q)) + else + n := uInt(ptr2int(s.zend) - ptr2int(q)); + if (n > z.avail_out) then + n := z.avail_out; + if (n <> 0) and (r = Z_BUF_ERROR) then + r := Z_OK; + + { update counters } + Dec(z.avail_out, n); + Inc(z.total_out, n); + + + { update check information } + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(s.check, q, n); + z.adler := s.check; + end; + + { copy as far as end of window } + zmemcpy(p, q, n); + Inc(p, n); + Inc(q, n); + + { see if more to copy at beginning of window } + if (q = s.zend) then + begin + { wrap pointers } + q := s.window; + if (s.write = s.zend) then + s.write := s.window; + + { compute bytes to copy } + n := uInt(ptr2int(s.write) - ptr2int(q)); + if (n > z.avail_out) then + n := z.avail_out; + if (n <> 0) and (r = Z_BUF_ERROR) then + r := Z_OK; + + { update counters } + Dec( z.avail_out, n); + Inc( z.total_out, n); + + { update check information } + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(s.check, q, n); + z.adler := s.check; + end; + + { copy } + zmemcpy(p, q, n); + Inc(p, n); + Inc(q, n); + end; + + + { update pointers } + z.next_out := p; + s.read := q; + + { done } + inflate_flush := r; +end; + +end. diff --git a/niftiview7/gzio/oPNGImage.pas b/niftiview7/gzio/oPNGImage.pas new file mode 100755 index 0000000..c51855e --- /dev/null +++ b/niftiview7/gzio/oPNGImage.pas @@ -0,0 +1,2555 @@ +{*******************************************************} +{ } +{ Portable Graphics Network decoder } +{ * decode & encode png files in delphi * } +{ } +{ EMAIL: gustavodaud@uol.com.br } +{ } +{*******************************************************} + +{ Delphi 3 compatibility by Paul TOTH <tothpaul@free.fr> } + +unit oPNGImage; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,gzio; + +resourcestring + {.$INCLUDE Portuguese.TXT} + {$INCLUDE English.TXT} + +{Portable Graphics Network implementation} +type + {Encoding filter} + TFilterRow = array[0..4] of PByteArray; + TEncodeFilter = (efNone, efSub, efUp, efAverage, efPaeth); + TEncodeFilterSet = set of TEncodeFilter; + + {:Chunk type} + TChunkType = Array[0..3] of char; + + {Forward declarations} + TPNGImage = class; + TChunkList = class; + TChunkGAMA = class; + TChunkIHDR = class; + + {:This class handles the chunks} + TChunk = class + constructor Create(AOwner: TChunkList); virtual; + destructor Destroy; override; + private + fList : TChunkList; + fStream: TMemoryStream; + + function GetSize: Integer; + + {Returns pointer to the most common chunk types} + function GetIHDR : TChunkIHDR; + function GetGAMA : TChunkGAMA; + {Return a pointer to the TPNGImage owner} + function GetBitmap : TPNGImage; + + protected + fType : TChunkType; + function GetIndex: Integer; + procedure DoAction; virtual; + + property IHDR : TChunkIHDR read GetIHDR; + property GAMA : TChunkGAMA read GetGama; + property Bitmap: TPNGImage read GetBitmap; + property Stream: TMemoryStream read fStream; + public + procedure Assign(Source: TChunk); virtual; + procedure SaveToStream(Stream: TStream); virtual; + property Index: Integer read GetIndex; + property Owner: TChunkList read fList; + property Size: Integer read GetSize; + property ChunkType: TChunkType read fType; + end; + + + {:IEND Chunk, 0 bytes length} + TChunkIEND = class(TChunk); + + {:tEXt Chunk, dynamic size, minimum 2 bytes (null separators)} + TChunkTEXT = Class(TChunk) + constructor Create(AOwner: TChunkList); override; + private + function GetValue(Index: Integer): String; + procedure SetValue(Index: Integer; Value: String); + public + property Keyword: String index 0 read GetValue write SetValue; + property Text: String index 1 read GetValue write SetValue; + end; + + {:zTXt Chunk, dynamic size} + TChunkZTXT = Class(TChunk) + private + function GetValue(Index: Integer): String; + procedure SetValue(Index: Integer; Value: String); + public + property Keyword: String index 0 read GetValue write SetValue; + property Text: String index 1 read GetValue write SetValue; + end; + + {:gAMA Chunk, 4 bytes length} + TChunkGAMA = class(TChunk) + constructor Create(AOwner: TChunkList); override; + procedure Assign(Source: TChunk); override; + protected + GammaTable, + InverseTable: Array[Byte] of Byte; + procedure DoAction; override; + private + function GetValue: Cardinal; + procedure SetValue(Value: Cardinal); + public + property Value: Cardinal read GetValue write SetValue; + end; + + {:PLTE Chunk, dynamic length} + TChunkPLTE = class(TChunk) + destructor Destroy; Override; + private + fPalette: HPalette; + function GetPalette: HPalette; + public + procedure SaveToStream(Stream: TStream); override; + property Palette: HPalette read GetPalette; + end; + + {:IHDR Chunk, 13 bytes length} + TChunkIHDR = class(TChunk) + procedure SaveToStream(Stream: TStream); override; + constructor Create(AOwner: TChunkList); override; + private + function GetWidth: Cardinal; + function GetHeight: Cardinal; + procedure SetWidth(Value: Cardinal); + procedure SetHeight(Value: Cardinal); + function GetValue(Index: Integer): Byte; + procedure SetValue(Index: Integer; Value: Byte); + public + property Width: Cardinal read GetWidth write SetWidth; + property Height: Cardinal read GetHeight write SetHeight; + property BitDepth: Byte index 0 read GetValue write SetValue; + property ColorType: Byte index 1 read GetValue write SetValue; + property Compression: Byte index 2 read GetValue write SetValue; + property Filter: Byte index 3 read GetValue write SetValue; + property Interlaced: Byte index 4 read GetValue write SetValue; + end; + + {:IDAT Chunk, dynamic size} + TChunkIDAT = class(TChunk) + public + procedure SaveToStream(Stream: TStream); override; + protected + function GetBufferWidth: Integer; + procedure FilterRow(Filter: Byte; CurrentRow, LastRow: pbytearray; + offset, row_buffer_width: Integer); + function EncodeFilterRow(row_buffer: pbytearray; + Filter_buffers: TFilterRow; row_width, filter_width: Cardinal): Integer; + procedure DoAction; override; + function GetOffset: Integer; + procedure EncodeImage; + procedure SetupPixelFormat; + procedure DecodeNonInterlacedRow(ImageData: Pointer; Data: pByteArray; + RowBytes: Integer; GamaChunk: TChunkGama); + procedure DecodeInterlacedRow(ImageData: Pointer; Data: pByteArray; + ColStart, ColIncrement, RowBytes, Pass: Integer; GamaChunk: TChunkGama); + end; + + {:tIME Chunk, 7 bytes} + TChunkTIME = class(TChunk) + constructor Create(AOwner: TChunkList); override; + function GetDateTime: TDateTime; + private + procedure SetDateTime(const Value: TDateTime); + public + property DateTime: TDateTime read GetDateTime write SetDateTime; + end; + + {:tRNS Chunk, dynamic length} + TChunkTRNS = class(TChunk) + private + function GetRGBColor: TColor; + public + procedure SaveToStream(Stream: TStream); override; + property RGBColor: TColor read GetRGBColor; + end; + + + {:Chunk class handler} + TChunkClass = Class of TChunk; + + {:Record containg a chunk class info} + pChunkClassInfo = ^TChunkClassInfo; + TChunkClassInfo = record + ChunkType: TChunkType; + ChunkClass: TChunkClass; + end; + + {:This class contains the avaliable kinds of TChunk class} + TChunkClasses = class + destructor Destroy; Override; + private + fList: TList; + function GetCount: Integer; + function GetItem(Index: Integer): TChunkClassInfo; + public + property Count: Integer read GetCount; + function IndexOfType(Item: TChunkType): Integer; { Paul - overload; } + function IndexOfClass(Item: TChunkClass): Integer; { Paul - overload; } + procedure Add(ChunkType: TChunkType; ChunkClass: TChunkClass); + property Item[Index: Integer]: TChunkClassInfo read GetItem; default; + end; + + {:This class contains the list of avaliable chunks for a TPNGImage } + {:object class. } + TChunkList = class + constructor Create(AOwner: TPNGImage); + destructor Destroy; override; + private + fImage: TPNGImage; + fList : TList; + function GetCount: Integer; + function GetItem(Index: Integer): TChunk; + public + property Owner: TPNGImage read fImage; + property Count: Integer read GetCount; + property Item[Index: Integer]: TChunk read GetItem; default; + procedure Move(Index1, Index2: Integer); + function AddItem(Item: TChunk): TChunk; { Paul - overload; } + function AddClass(ChunkClass: TChunkClass): TChunk; { Paul - overload; } + function AddStream(Stream: TStream): TChunk; { Paul - overload; } + procedure Remove(Item: TChunk); + function IndexOfChunk(Chunk: TChunk): Integer; { Paul - overload; } + function IndexOfClass(ChunkClass: TChunkClass): Integer; { Paul - overload; } + procedure Clear; + end; + + {:This format handler is able to load and save booth interlaced and + non interlaced portable graphics network images using a ZLIB + compression decoder} + TPNGImage = class(TBitmap) + constructor Create; override; + destructor Destroy; override; + procedure LoadFromStream(Stream: TStream); override; + procedure SaveToStream(Stream: TStream); override; + private + fMask: TBitmap; + fEncodeFilter: TEncodeFilterSet; + fInterlacing: Boolean; + fChunkList: TChunkList; + procedure SetFilter(Value: TEncodeFilterSet); + public + procedure Assign(Source: TPersistent); override; + property Filter: TEncodeFilterSet read fEncodeFilter write SetFilter; + property Interlacing: Boolean read fInterlacing write fInterlacing; + procedure Clear; + property Chunks: TChunkList read fChunkList; + class procedure RegisterChunkClass(ChunkType: TChunkType; + ChunkClass: TChunkClass); + end; + +implementation + + +uses zdeflate,zinflate,infblock,inftrees,infcodes,infutil,inffast,trees,adler_32,zutil, zlib; + //oPNGZLIB{, Math}; + +{ Delphi 3 missing function } +Procedure ReplaceTimePNG(Var D:TDateTime; T:TDateTime); + begin + D:=D+T; // this work for PNGImage only ! + end; +(*Procedure ShowMessageFmt(msg:string; fmt:array of const); + begin + ShowMessage(Format(msg,fmt)); + end; *) + +var + {Stores the avaliable kinds of TChunk} + ChunkClasses: TChunkClasses; + +const + FILTERBUFFERCOUNT = 5; + + {Interlacing} + RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1); + ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0); + RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2); + ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1); + PassMask: array[0..6] of Byte = ($80, $08, $88, $22, $AA, $55, $FF); + + {Color types} + Grayscale = 0; + RGB = 2; + Palette = 3; + GrayscaleAlpha = 4; + RGBAlpha = 6; + + {Filter types} + FILTERNONE = 0; + FILTERSUB = 1; + FILTERUP = 2; + FILTERAVERAGE = 3; + FILTERPAETH = 4; + + {Valid PNG header (first 8 bytes)} + PNGHeader: array[0..7] of Byte = (137, 80, 78, 71, 13, 10, 26, 10); + +type + pCardinal = ^Cardinal; + + {Default error handler for PNG format} + EPNGImageException = Class(Exception); + + {:IHDR Chunk} + pIHDRChunk = ^TIHDRChunk; + TIHDRChunk = packed record + {Width and height give the image dimensions in pixels} + Width, Height: Cardinal; + {Bit depth is a single-byte integer giving the number of bits } + {per sample or per palette index (not per pixel). Valid values} + {are 1, 2, 4, 8, and 16, although not all values are allowed } + {for all color types } + BitDepth, + {Color type is a single-byte integer that describes the } + {interpretation of the image data. Color type codes } + {represent sums of the following values: } + {1 (palette used) } + {2 (color used) } + {4 (alpha channel used). } + {Valid values are 0, 2, 3, 4, and 6. } + ColorType, + {Compression method is a single-byte integer that indicates} + {the method used to compress the image data. At present, } + {only compression method 0 (deflate/inflate compression } + {with a sliding window of at most 32768 bytes) is defined. } + {All standard PNG images must be compressed with this } + {scheme. The compression method field is provided for } + {possible future expansion or proprietary variants. } + {Decoders must check this byte and report an error if it } + {holds an unrecognized code } + Compression, + {Filter method is a single-byte integer that indicates the } + {preprocessing method applied to the image data before } + {compression. At present, only filter method 0 (adaptive } + {filtering with five basic filter types) is defined. } + Filter, + {Interlace method is a single-byte integer that indicates } + {the transmission order of the image data. Two values are } + {currently defined: 0 (no interlace) or 1 (Adam7 interlace)} + Interlaced: Byte; + end; + + {tIME Chunk} + pTIMEChunk = ^TTimeChunk; + TTIMEChunk = Record + Year : Word; + Month : Byte; + Day : Byte; + Hour : Byte; + Min : Byte; + Sec : Byte; + end; + + {Pixel memory access} + pRGBLine = ^TRGBLine; + TRGBLine = Array[Word] of TRGBTriple; + pRGBALine = ^TRGBALine; + TRGBALine = Array[Word] of TRGBQuad; + + {Standard PNG header} + TPNGHeader = Array[0..7] of Byte; + +procedure ConvertBits(Source: array of Pointer; Target: Pointer; + Count: Cardinal; Mask: Byte; FSourceBPS, FTargetBPS: Byte); forward; + +{Forward declaration for the CRC check function} +function crc(chunktype: tchunktype; buf: pbytearray; + len: Integer): Cardinal; forward; + +{:swaps high and low bytes of the given 32 bit value} +function SwapLong(Value: Cardinal): Cardinal; +asm + BSWAP EAX +end; + +{:Register a new chunk kind class} +procedure RegisterNewChunkClass(ChunkType: TChunkType; ChunkClass: TChunkClass); +begin + {Add to the list} + ChunkClasses.Add(ChunkType, ChunkClass); +end; + +{:From time to time, shows a message} +procedure Shareware; +begin + Randomize; + + {From time to time, shows a message} + if INT(RANDOM(20)) = 1 then + MessageBox(GetActiveWindow, pchar(PNG_SHARE), pchar(PNG_SHARE_TITLE), + MB_ICONINFORMATION); +end; + +{:Extracted from PNG specification, returns paeth prediction of the values} +function PaethPredictor(a, b, c: Byte): Byte; +var + p, pa, pb, pc: Integer; +begin + { a = left, b = above, c = upper left } + p := a + b - c; { initial estimate } + pa := Abs(p - a); { distances to a, b, c } + pb := Abs(p - b); + pc := Abs(p - c); + { return nearest of a, b, c, breaking ties in order a, b, c } + if (pa <= pb) and (pa <= pc) then + Result := a + else + if pb <= pc then + Result := b + else + Result := c; +end; + +{:Default error handler method} +procedure CallError(ErrorCode: String); +begin + {Show the error message} + raise EPNGImageException.CreateFmt('Portable Graphics Network format handler ' + + 'error%s%s', [#13#10#13#10, ErrorCode]); +end; + +{Returns the RGB color} +function TChunkTRNS.GetRGBColor: TColor; +var + Data: pByteArray; +begin + + {Test if the current color type is RGB} + if IHDR.ColorType <> RGB then + CallError(PNG_INVALID_COLOR_TYPE); + + Data := fStream.Memory; + Result := Windows.RGB(Data^[0], Data^[1], Data^[2]); +end; + +{When the chunk is being created} +constructor TChunkTIME.Create(AOwner: TChunkList); +begin + inherited; + + {Initial size and value} + fStream.SetSize(7); { Paul - fStream.Size := 7; } + DateTime := Now; +end; + +{:Return the value of the date and time stamped on the chunk} +function TChunkTIME.GetDateTime: TDateTime; +var + Data : TTimeChunk; +begin + {Makes sure that the stream size is 7} + if fStream.Size <> 7 then + CallError(TIME_CORRUPTED); + + {Read the data into the record} + Data := pTimeChunk(fStream.Memory)^; + Data.Year := SwapLong(Data.Year); + + {Return value} + with Data do + {Test if time is corrupted} + try + if Year = 0 then Year := 2000; + Result := EncodeDate(Year, Month, Day); + ReplaceTimePNG(Result, EncodeTime(Hour, Min, Sec, 0)); + except + ShowMessageFmt('Year: %d, Month: %d, Day: %d, Hour: %d, Min: %d,' + + 'Sec: %d', [Year, Month, Day, Hour, Min, Sec]); + CallError(TIME_CORRUPTED); + end; + +end; + +{:Set the value for the date and time in the chunk} +procedure TChunkTIME.SetDateTime(const Value: TDateTime); +var + Year, + Month, + Day, + Hour, + Min, + Sec, + MSec : word; + Temp : Byte; +begin + fStream.Clear; + + {Get the datetime values} + DecodeTime(Value, Hour, Min, Sec, MSec); + DecodeDate(Value, Year, Month, Day); + + {Write the values} + Year := SwapLong(Year); + fStream.Write(Year, 2); + Temp := Month; fStream.Write(Temp, 1); + Temp := Day; fStream.Write(Temp, 1); + Temp := Hour; fStream.Write(Temp, 1); + Temp := Min; fStream.Write(Temp, 1); + Temp := Sec; fStream.Write(Sec, 1); +end; + +{When the chunk is being saved} +procedure TChunkTRNS.SaveToStream(Stream: TStream); +var + Temp: Byte; +begin + {Clear the data contents} + fStream.Clear; + + {Write different transparency for different color formats} + case IHDR.ColorType of + RGB: + begin + {RGB data} + Temp := GetRValue(Bitmap.TransparentColor); fStream.Write(Temp, 1); + Temp := GetGValue(Bitmap.TransparentColor); fStream.Write(Temp, 1); + Temp := GetBValue(Bitmap.TransparentColor); fStream.Write(Temp, 1); + end; + else + exit; + end; + + inherited; +end; +(* +procedure UnGZip (var lFname: string; var lBuf: ByteP{}; lMaxSz: integer); //unzip +const +BUFLEN = 16384; +var +infile : gzFile; + len : integer; + written : integer; + buf : packed array [0..BUFLEN-1] of byte; { Global uses BSS instead of stack } + s : gz_streamp; +begin + //errorcode := 0; + infile := gzopen (lFName, 'r', 0); + s := gz_streamp(infile); + //fsize := FileSize( s^.gzfile); + //FProgress := 0; + //lensize := 0; + //if FProgressStep > 0 then DoOnProgress; + written := 0; + while true do begin + len := gzread (infile, @buf, BUFLEN); + if (len < 0) then begin + //errorcode := 1; + break + end; + if (len = 0) + then break; + if (Written+len) > lMaxSz then begin + break; + end; + Move(buf,lbuf[Written+1],len); + Written := Written + len; + end; {WHILE} +//showmessage(inttostr(Written)); +end; +*) +{:Return value of one of the properties} +function TChunkZTXT.GetValue(Index: Integer): String; +var + fKeyword: Pchar; + DSize : Integer; + fText : Pchar; { Paul - Array of Char; } + Decode : gz_streamp;//TZDecompressionStream; +begin + {Read the keyword} +showmessage('a'); + fKeyword := fStream.Memory; + + {Get the size of the uncompressed text and resize the holder} + DSize := fStream.Size - Length(fKeyword) - 2; + GetMem(fText,DSize); { Paul - SetLength(fText, DSize); } + + {Create a especial stream to decompress} + fStream.Position := Length(fKeyword) + 2; + // s := gz_streamp(infile); + Decode := gz_streamp(fStream); + //Decode := TZDecompressionStream.Create(fStream); + //Decode.Read(fText[0], DSize); + // len := gzread (infile, @buf, BUFLEN); +gzread (decode, @fText[0], DSize); +showmessage('abba'); + + //{len :=} gzread (@fText[0], @Decode, DSize); + case Index of + 0: + Result := fKeyword; + else + Result := ftext; { Paul - pchar(@fText[0]); } + end; + {Free that stream} + //Decode.Free; +end; + +{:Set the value of one of the properties} +procedure TChunkZTXT.SetValue(Index: Integer; Value: String); +var + fKeyword, fText: pchar; + Encode : gz_streamp;//TZCompressionStream; + Method : Byte; +begin +showmessage('c'); + {Test which property to set} + case Index of + 0: begin + {Setting keyword} + fKeyword := pchar(Value); + fText := pchar(Text); + end; + else + begin + {Setting text} + fText := pchar(Value); + fKeyword := pchar(Keyword); + end; + end; + + {Clear the stream for rewriting} + fStream.Clear; + fStream.Position := 0; + Method := 0; + + {Write data} + Encode := gz_streamp(fStream); + //Decode := TZDecompressionStream.Create(fStream); + //Decode.Read(fText[0], DSize); + // len := gzread (infile, @buf, BUFLEN); + + + fStream.Write(fKeyword[0], Length(fKeyword) + 1); {+1 to include null character} + fStream.Write(Method, 1); + + + + //Encode := TZCompressionStream.Create(fStream, zcDefault); + gzwrite (encode, @fText[0], Length(fText)); + + //Encode.Write(fText[0], Length(fText)); + //Encode.Free; + +end; + +{:When the TEXT chunk is being created} +constructor TChunkTEXT.Create(AOwner: TChunkList); +begin + inherited; + fType := 'tEXt'; + {Set the stream size to 2 and set the two bytes as null} + fStream.SetSize(2); { Paul - fStream.Size := 2; } + pByteArray(fStream.Memory)^[0] := 0; + pByteArray(fStream.Memory)^[1] := 0; +end; + +{:Return one of the properties of the chunk TEXT} +function TChunkTEXT.GetValue(Index: Integer): String; +var + fKeyword, fText: pChar; +begin + fKeyword := fStream.Memory; + fText := @pByteArray(fStream.Memory)[Length(fKeyword) + 1]; + + {Test which property to return} + case Index of + 0: Result := fKeyword; + else + Result := fText; + end; +end; + +{:Set the value of the TEXT chunk} +procedure TChunkTEXT.SetValue(Index: Integer; Value: String); +var + fKeyword, fText: pchar; +begin + {Test which property to set} + case Index of + 0: begin + {Setting keyword} + fKeyword := pchar(Value); + fText := pchar(Text); + end; + else + begin + {Setting text} + fText := pchar(Value); + fKeyword := pchar(Keyword); + end; + end; + + {Clear the stream for rewriting} + fStream.Clear; + fStream.Position := 0; + + {Write data} + fStream.Write(fKeyword[0], Length(fKeyword) + 1); {+1 to include null character} + fStream.Write(fText[0], Length(fText) + 1); +end; + +{:When the object is being destroyed} +destructor TChunkPLTE.Destroy; +begin + {If the main bitmap is using the palette make it don't use it anymore} + if Owner.Owner.Palette = fPalette then + Owner.Owner.Palette := 0; + + {Delete the palette from the memory} + DeleteObject(fPalette); + + inherited; +end; + + + +{Returns the palette from the image} +function TChunkPLTE.GetPalette: HPalette; +var + MaxPalette: TMaxLogPalette; + i: Integer; + GamaChunk : TChunkGAMA; +begin + GamaChunk := Gama; + + {Delete the old palette from the memory} + DeleteObject(fPalette); + + {The palette stream must be divisible by 3} + if fStream.Size MOD 3 <> 0 then + CallError(PNG_ERROR_INVALID_PLTE); + + {Set the MaxPalette attributes} + with MaxPalette do + begin + Fillchar(MaxPalette, sizeof(MaxPalette), 0); + palVersion := $300; + palNumEntries := fStream.Size DIV 3; + + {Get each value} + FOR i := 0 to palNumEntries - 1 DO + WITH palPalEntry[i] do + BEGIN + peRed := pByteArray(fStream.Memory)[(i * 3)]; + {Correct red using gamma} + if Assigned(GamaChunk) then + peRed := GamaChunk.GammaTable[peRed]; + + peGreen := pByteArray(fStream.Memory)[(i * 3) + 1]; + {Correct green using gamma} + if Assigned(GamaChunk) then + peGreen := GamaChunk.GammaTable[peGreen]; + + peBlue := pByteArray(fStream.Memory)[(i * 3) + 2]; + {Correct red using gamma} + if Assigned(GamaChunk) then + peBlue := GamaChunk.GammaTable[peBlue]; + + peFlags := 0; + END; + IF (IHDR.BitDepth = 2) and (palNumEntries < 16) then + begin + {Note: This is really a crazy fix for supporting 2bit} + {images} + palNumEntries := 16; + copymemory(@palpalentry[4], @palpalentry[0], 21); + copymemory(@palpalentry[8], @palpalentry[0], 21); + copymemory(@palpalentry[12], @palpalentry[0], 21); + + end; + + end; + + {Create the palette object} + fPalette := CreatePalette(PLogPalette(@MaxPalette)^); + + {Returns the palette handle} + Result := fPalette; +end; + +{:When the chunk is being saved} +procedure TChunkPLTE.SaveToStream(Stream: TStream); +var + PaletteSize: Word; + LogPalette : TMaxLogPalette; + I : Integer; + GamaChunk : TChunkGama; +begin + GamaChunk := Gama; + + {Free the stream for rewritting} + fStream.Clear; + + {If the image does not contains palette, exit} + if Owner.Owner.Palette = 0 then + exit + else + begin + {If it does, retrieve the palette} + + {First discover the palette size} + GetObject(Bitmap.Palette, SizeOf(WORD), @PaletteSize); + {Now get the entries} + GetPaletteEntries(Bitmap.Palette, 0, PaletteSize, + LogPalette.palpalentry); + + {Now write the entries to the stream} + FOR I := 0 TO PaletteSize - 1 DO + With LogPalette do + begin + {Test if uses gamma} + if Assigned(GamaChunk) then + begin + fStream.Write(GamaChunk.InverseTable[palPalEntry[i].peRed], 1); + fStream.Write(GamaChunk.InverseTable[palPalEntry[i].peGreen], 1); + fStream.Write(GamaChunk.InverseTable[palPalEntry[i].peBlue], 1); + end + else + begin + fStream.Write(palPalEntry[i].peRed, 1); + fStream.Write(palPalEntry[i].peGreen, 1); + fStream.Write(palPalEntry[i].peBlue, 1); + end; + end; + + end; + + {Call default writting} + inherited; +end; + +{:Copy interlaced data into the current image} +procedure TChunkIDAT.DecodeInterlacedRow(ImageData: Pointer; Data: pByteArray; + ColStart, ColIncrement, RowBytes, Pass: Integer; GamaChunk: TChunkGama); +var + J, I: Integer; +begin + I := ColStart; + J := 0; + + {Test for color type} + CASE IHDR.ColorType of + Palette, Grayscale: + {Test for bit depth} + CASE IHDR.BitDepth of + 2: {2 bits per pixel, not supported by TBitmap, so move to 4 bits} + ConvertBits([@Data[0]], ImageData, IHDR.Width, PassMask[Pass], 2, 4); + 4: {4 bits per pixel} + ConvertBits([@Data[0]], ImageData, IHDR.Width, PassMask[Pass], 4, 4); + 1: {1 bit per pixel} + ConvertBits([@Data[0]], ImageData, IHDR.Width, PassMask[Pass], 1, 1); + 8: {1 byte per pixel} + repeat + pByteArray(ImageData)^[I] := Data^[J]; + inc(J); + inc(I, ColIncrement); + until J >= RowBytes; + 16: {Grayscale interlaced images with 2 bytes per sample} + repeat + pByteArray(ImageData)^[I] := Data^[J]; + inc(J, 2); + inc(I, ColIncrement); + until J >= RowBytes; + END; + RGB: + {Test for bit depth} + CASE IHDR.BitDepth of + 8: {1 byte per R, G, B} + repeat + with PRGBLine(ImageData)^[I] do + begin + rgbtRed := Data^[J]; + rgbtGreen := Data^[J + 1]; + rgbtBlue := Data^[J + 2]; + {Gamma correction} + if Assigned(GamaChunk) then + begin + rgbtRed := GamaChunk.GammaTable[rgbtRed]; + rgbtGreen := GamaChunk.GammaTable[rgbtGreen]; + rgbtBlue := GamaChunk.GammaTable[rgbtBlue]; + end; + end; + inc(J, 3); + inc(I, ColIncrement); + until J >= RowBytes; + 16: {2 bytes per R, G, B} + repeat + with PRGBLine(ImageData)^[I] do + begin + rgbtRed := Data^[J]; + rgbtGreen := Data^[J + 2]; + rgbtBlue := Data^[J + 4]; + {Gamma correction} + if Assigned(GamaChunk) then + begin + rgbtRed := GamaChunk.GammaTable[rgbtRed]; + rgbtGreen := GamaChunk.GammaTable[rgbtGreen]; + rgbtBlue := GamaChunk.GammaTable[rgbtBlue]; + end; + end; + inc(J, 6); + inc(I, ColIncrement); + until J >= RowBytes; + end; + RGBALPHA: + {Test for bit depth} + CASE IHDR.BitDepth of + 8: {1 byte per R, G, B, Alpha} + repeat + with PRGBLine(ImageData)^[I] do + begin + rgbtRed := Data^[J]; + rgbtGreen := Data^[J + 1]; + rgbtBlue := Data^[J + 2]; + {Gamma correction} + if Assigned(GamaChunk) then + begin + rgbtRed := GamaChunk.GammaTable[rgbtRed]; + rgbtGreen := GamaChunk.GammaTable[rgbtGreen]; + rgbtBlue := GamaChunk.GammaTable[rgbtBlue]; + end; + end; + inc(J, 4); + inc(I, ColIncrement); + until J >= RowBytes; + 16: {2 bytes per R, G, B, Alpha} + repeat + with PRGBLine(ImageData)^[I] do + begin + rgbtRed := Data^[J]; + rgbtGreen := Data^[J + 2]; + rgbtBlue := Data^[J + 4]; + {Gamma correction} + if Assigned(GamaChunk) then + begin + rgbtRed := GamaChunk.GammaTable[rgbtRed]; + rgbtGreen := GamaChunk.GammaTable[rgbtGreen]; + rgbtBlue := GamaChunk.GammaTable[rgbtBlue]; + end; + end; + inc(J, 8); + inc(I, ColIncrement); + until J >= RowBytes; + + END; + GRAYSCALEALPHA: + {Test for bit depth} + CASE IHDR.BitDepth of + 8: {1 byte per gray and alpha} + repeat + pByteArray(ImageData)^[I] := Data^[J]; + inc(J, 2); + inc(I, ColIncrement); + until J >= RowBytes; + 16: {2 bytes per gray and alpha} + repeat + pByteArray(ImageData)^[I] := Data^[J]; + inc(J, 4); + inc(I, ColIncrement); + until J >= RowBytes; + END; + + end; +end; + + +{:Copy non interlaced data into the current image} +procedure TChunkIDAT.DecodeNonInterlacedRow(ImageData: Pointer; Data: pByteArray; + RowBytes: Integer; GamaChunk: TChunkGama); +var + Col: Integer; +begin + + {Test for color type} + case IHDR.ColorType of + Palette, Grayscale: + {Test for bit depth} + CASE IHDR.BitDepth of + 1, 4, 8: {Simple memory copy} + CopyMemory(ImageData, Data, RowBytes); + 2: {Pixelformat pf2bits ? not supported (pf4bits being used) } + ConvertBits([@Data[0]], ImageData, Bitmap.Width, $FF, 2, 4); + 16: {Grayscale with 2 pixels} + FOR Col := 0 to Bitmap.Width - 1 DO + pByteArray(ImageData)^[Col] := Data^[Col * 2]; + END; + RGB: + {Test for bit depth} + CASE IHDR.BitDepth of + 8: {1 byte for each R, G AND B values} + FOR Col := 0 to (Bitmap.Width - 1) DO + with PRGBLine(ImageData)^[Col] do + begin + rgbtRed := Data^[Col * 3]; + rgbtGreen := Data^[1 + Col * 3]; + rgbtBlue := Data^[2 + Col * 3]; + + {Gamma correction} + if Assigned(GamaChunk) then + begin + rgbtRed := GamaChunk.GammaTable[rgbtRed]; + rgbtGreen := GamaChunk.GammaTable[rgbtGreen]; + rgbtBlue := GamaChunk.GammaTable[rgbtBlue]; + end; + end; + 16: {2 bytes for each R, G AND B values} + FOR Col := 0 to (Bitmap.Width - 1) DO + with PRGBLine(ImageData)^[Col] do + begin + rgbtRed := Data^[Col * 6]; + rgbtGreen := Data^[2 + Col * 6]; + rgbtBlue := Data^[4 + Col * 6]; + + {Gamma correction} + if Assigned(GamaChunk) then + begin + rgbtRed := GamaChunk.GammaTable[rgbtRed]; + rgbtGreen := GamaChunk.GammaTable[rgbtGreen]; + rgbtBlue := GamaChunk.GammaTable[rgbtBlue]; + end; + + end; + end; + RGBALPHA: + {Test for bit depth} + CASE IHDR.BitDepth of + 8: {1 byte for each R, G, B AND ALPHA values} + FOR Col := 0 to (Bitmap.Width - 1) DO + with PRGBLine(ImageData)^[Col] do + begin + rgbtRed := Data^[Col * 4]; + rgbtGreen := Data^[1 + Col * 4]; + rgbtBlue := Data^[2 + Col * 4]; + + {Gamma correction} + if Assigned(GamaChunk) then + begin + rgbtRed := GamaChunk.GammaTable[rgbtRed]; + rgbtGreen := GamaChunk.GammaTable[rgbtGreen]; + rgbtBlue := GamaChunk.GammaTable[rgbtBlue]; + end; + end; + 16: {2 bytes for each R, G AND B values and 1 for ALPHA} + FOR Col := 0 to (Bitmap.Width - 1) DO + with PRGBLine(ImageData)^[Col] do + begin + rgbtRed := Data^[Col * 8]; + rgbtGreen := Data^[2 + Col * 8]; + rgbtBlue := Data^[4 + Col * 8]; + + {Gamma correction} + if Assigned(GamaChunk) then + begin + rgbtRed := GamaChunk.GammaTable[rgbtRed]; + rgbtGreen := GamaChunk.GammaTable[rgbtGreen]; + rgbtBlue := GamaChunk.GammaTable[rgbtBlue]; + end; + end; + end; + GRAYSCALEALPHA: + {Test for bit depth} + CASE IHDR.BitDepth of + 8: {1 byte for grayscale and 1 for alpha} + FOR Col := 0 to (Bitmap.Width - 1) DO + pByteArray(ImageData)^[Col] := Data^[Col * 2]; + 16: {2 bytes for grayscale and 1 for alpha} + FOR Col := 0 to (Bitmap.Width - 1) DO + pByteArray(ImageData)^[Col] := Data^[Col * 4]; + end; + + end; +end; + +{:Decode the readed image to the bitmap} +procedure TChunkIDAT.DoAction; +const + CHAR_BIT = 8; +var + RowBuffer : array[Boolean] of pbytearray; + Row_Buffer_Width : Integer; + OddLine : Boolean; + Offset : Integer; + UseProgress : Boolean; + j : Integer; + Pass : Integer; + Decode : gz_streamp;//TZDecompressionStream; + Row : Integer; + PixelsThisRow : Integer; + RowBytes : Integer; + GamaChunk : TChunkGama; +begin + GamaChunk := Gama; + //showmessage('dd'); + {Create the decompression object} + //Decode := TZDecompressionStream.Create(fStream); + //Decode.Position := 0; + Decode := gz_streamp(fStream); + xxxPo + rowbytes := 0; + showmessage('ddx'); + + {Filtering is done on corresponding items within a record. Determine} + {the number of bytes between corresponding items. } + OffSet := GetOffSet; + + {Define if uses OnProgress} + UseProgress := Assigned(Bitmap.Onprogress); + + {Retrieve the number of bytes per line} + row_buffer_width := GetBufferWidth; + + {Allocate memory for the row buffers and fill them with zeros} + OddLine := TRUE; + GetMem(RowBuffer[True], row_buffer_width + 1); + GetMem(RowBuffer[False], row_buffer_width + 1); + ZeroMemory(RowBuffer[False], row_buffer_width + 1); + + {Set the bitmap properties} + with Bitmap do + begin + {Setup pixel formats and palette} + SetupPixelFormat; + + {Set width and height} + Width := IHDR.Width; + Height := IHDR.Height; + end; + + {Interlace decode} + if IHDR.Interlaced = 1 then + begin + {Each of the interlacing passes} + FOR Pass := 0 TO 6 DO + begin + {Number of pixels in this row} + pixelsthisrow := (Bitmap.width - ColumnStart[Pass] + + + ColumnIncrement[Pass] - 1) div ColumnIncrement[Pass] ; + + {Number of bytes} + case (IHDR.ColorType) of + Grayscale, Palette: + rowbytes := (pixelsthisrow * IHDR.BitDepth + CHAR_BIT - 1) div CHAR_BIT ; + RGB: + rowbytes := pixelsthisrow * 3 * IHDR.BitDepth div CHAR_BIT ; + RGBAlpha: + rowbytes := pixelsthisrow * 4 * IHDR.BitDepth div CHAR_BIT ; + GrayscaleAlpha: + rowbytes := pixelsthisrow * 2 * IHDR.BitDepth div CHAR_BIT ; + end; + + Row := RowStart[Pass]; + while Row < Bitmap.Height do + begin + {Read line from the stream} + gzread (decode, @rowBuffer[OddLine][0], rowbytes + 1); + //Decode.Read(rowBuffer[OddLine][0], rowbytes + 1); + {Filter the row} + FilterRow(RowBuffer[OddLine][0], @RowBuffer[OddLine][1], + @RowBuffer[not OddLine][1], offset, rowbytes); + + {Translate data into the image} + DecodeInterlacedRow(Bitmap.ScanLine[Row], @RowBuffer[OddLine][1], + ColumnStart[Pass], ColumnIncrement[Pass], RowBytes, Pass, Gamachunk); + + {Jump to the next line} + Inc(Row, RowIncrement[Pass]); + {Change the line} + OddLine := not OddLine; + end; + + {Call progress event} + If UseProgress then + Bitmap.OnProgress(Bitmap, psRunning, MulDiv(100, Pass, 6), + True, Rect(0, 0, Bitmap.Width, Bitmap.Height), 'Drawing...'); + + end; + end + {Non interlace decode} + else if IHDR.Interlaced = 0 then + begin + {Pass each row} + for j := 0 to Bitmap.Height - 1 DO + begin + {Decompress} + gzread (decode, @RowBuffer[OddLine][0], row_buffer_width + 1); + //Decode.Read(RowBuffer[OddLine][0], row_buffer_width + 1); + + {Filter the current row} + FilterRow(RowBuffer[OddLine][0], @RowBuffer[OddLine][1], + @RowBuffer[not OddLine][1], OffSet, row_buffer_width); + + {Translate the data into the image} + DecodeNonInterlacedRow(Bitmap.Scanline[j], @RowBuffer[OddLine][1], + row_buffer_width, GamaChunk); + + {Change the line} + OddLine := not OddLine; + + + {Call progress event} + If UseProgress then + Bitmap.OnProgress(Bitmap, psRunning, MulDiv(j, 100, Bitmap.Height), + True, Rect(0, j - 1, Bitmap.Width, j), 'Drawing...'); + end; + end + else + {Unknown interlace method} + CallError(PNG_ERROR_INVALID_INTERLACE); + + {Free memory for the row buffers} + FreeMem(RowBuffer[True], row_buffer_width + 1); + FreeMem(RowBuffer[False], row_buffer_width + 1); + + {Free the decompression object} + // Decode.Free; + + {$IFDEF SHAREWARE} Shareware {$ENDIF}; +end; + +{:Returns the buffer width} +function TChunkIDAT.GetBufferWidth: Integer; +const + CHAR_BIT = 8; +var + RowBits : Integer; +begin + Result := 0; + + case IHDR.ColorType of + Grayscale, Palette: + begin + rowbits := IHDR.Width * IHDR.BitDepth; + Result := (rowbits + CHAR_BIT - 1) div CHAR_BIT; + end; + GrayscaleAlpha: + Result := 2 * IHDR.width * IHDR.BitDepth div CHAR_BIT ; + RGB: + Result := IHDR.width * 3 * IHDR.BitDepth div CHAR_BIT ; + RGBAlpha: + Result := IHDR.width * 4 * IHDR.BitDepth div CHAR_BIT ; + else + {In case we have an undetermined color type} + CallError(PNG_ERROR_INVALID_COLOR_TYPE); + end; + +end; + +{:Returns the offset for filtering} +function TChunkIDAT.GetOffset: Integer; +const + CHAR_BIT = 8; +begin + case IHDR.ColorType of + Grayscale, Palette: result := 1; + RGB: result := 3 * IHDR.BitDepth div CHAR_BIT ; + GrayscaleAlpha: result := 2 * IHDR.BitDepth div CHAR_BIT ; + RGBAlpha: result := 4 * IHDR.BitDepth div CHAR_BIT ; + else + result := 0; + end; +end; + +{:Filter the row for encoding} +function TChunkIDAT.EncodeFilterRow(row_buffer: pbytearray; + Filter_buffers: TFilterRow; row_width, filter_width: Cardinal): Integer; +const + FTest: Array[0..4] of TEncodeFilter = (efNone, efSub, efUp, + efAverage, efPaeth); +var + ii, run, jj: Cardinal; + longestrun : Cardinal; + last, + above, + lastabove : byte; + +begin + + // Filter for each type in the filter_mask. + if efSub in Bitmap.Filter then + begin + + for ii := 0 to row_width - 1 do + begin + if (ii >= filter_width) then + last := row_buffer^[ii-filter_width] + else + last := 0 ; + + filter_buffers [FILTERSUB]^[ii] := row_buffer^[ii] - last ; + end; + end; + + if efUp in Bitmap.Filter then + for ii := 0 to row_width - 1 do + filter_buffers[FILTERUP]^[ii] := row_buffer^[ii] - + filter_buffers[FILTERNONE]^[ii] ; + + if efAverage in Bitmap.Filter then + begin + for ii := 0 to row_width - 1 do + begin + if (ii >= filter_width) then + last := row_buffer^[ii - filter_width] + else + last := 0 ; + above := filter_buffers [FILTERNONE]^[ii] ; + + filter_buffers [FILTERAVERAGE]^[ii] + := row_buffer^[ii] - (above + last) div 2 ; + end; + end; + + if efPaeth in Bitmap.Filter then + begin + for ii := 0 to row_width - 1 do + begin + if (ii >= filter_width) then + begin + last := row_buffer^[ii-filter_width] ; + lastabove := filter_buffers [FILTERNONE]^[ii - filter_width] ; + end + else + begin + last := 0 ; + lastabove := 0 ; + end; + + above := filter_buffers [FILTERNONE]^[ii] ; + filter_buffers [FILTERPAETH]^[ii] + := row_buffer^[ii] - PaethPredictor (last, above, lastabove) ; + end; + end; + + + // Filter None + // THIS MUST BE THE LAST FILTER!!!!!!!!!! We save the value + // here to be used in the next call with the filters that require data from the + // previous row. + for ii := 0 to row_width - 1 do + filter_buffers[FILTERNONE]^[ii] := row_buffer^[ii] ; + + // If we only performed FilterNone then we do not need to proceed + // any further. + Result := FILTERNONE ; + if Bitmap.Filter = [efNone] then + exit; + + // Find the best filter. We do a simple test for the + // longest runs of the same value. + + LongestRun := 0; + for ii := 0 to FILTERBUFFERCOUNT - 1 DO + begin + if FTest[ii] in Bitmap.Filter then + begin + run := 0; + for jj := 4 to row_width - 1 do + begin + if (filter_buffers[ii]^[jj] = filter_buffers [ii]^[jj-1]) and + (filter_buffers[ii]^[jj] = filter_buffers [ii]^[jj-2]) and + (filter_buffers[ii]^[jj] = filter_buffers [ii]^[jj-3]) and + (filter_buffers[ii]^[jj] = filter_buffers [ii]^[jj-4]) then + inc(Run); + end; + + if (run > longestrun) then + begin + result := ii ; + longestrun := run ; + end; + end; + end; + +end; + +{:Encode the actual image from the bitmap} +procedure TChunkIDAT.EncodeImage; +var + Encode : gz_streamp;//: TZCompressionStream; + j, offset, i : Integer; + row_buffer_width: Integer; + filter_buffers : TFilterRow; + Filter : byte; + row_buffer : pByteArray; + Line : Pointer; + GamaChunk : TChunkGama; + + function AdjustValue(Value: Byte): Byte; + begin + if Assigned(GamaChunk) then + Result := GamaChunk.InverseTable[Value] + else + Result := Value; + end; +begin + GamaChunk := Gama; + showmessage('ax'); + {Clear the previous IDAT memory since we will use bitmap} + {data to write all over again} + fStream.Clear; + + {Create a stream to handle the compression} + //Encode := TZCompressionStream.Create(fStream, zcDefault); + Encode := gz_streamp(fStream); + {Number of bytes in each row} + row_buffer_width := GetBufferWidth; + offset := GetOffset; + + {Allocate memory for filtering} + GetMem(row_buffer, row_buffer_width); + GetMem(filter_buffers[FILTERNONE], row_buffer_width); + if efSub in Bitmap.Filter then + GetMem(filter_buffers[FILTERSUB], row_buffer_width); + if efUp in Bitmap.Filter then + GetMem(filter_buffers[FILTERUP], row_buffer_width); + if efAverage in Bitmap.Filter then + GetMem(filter_buffers[FILTERAVERAGE], row_buffer_width); + if efPaeth in Bitmap.Filter then + GetMem(filter_buffers[FILTERPAETH], row_buffer_width); + {Fill the filternone with zeros} + ZeroMemory(@filter_buffers[FILTERNONE][0], row_buffer_width); + + Bitmap.Interlacing := FALSE; + + {Testing encoding method} + if Bitmap.Interlacing then + {No interlacing} + begin + end + else + {Interlacing} + begin + {Pass each row} + for j := 0 to Bitmap.Height - 1 do + begin + + {Write depending on the pixel format} + case Bitmap.PixelFormat of + pf1bit, pf4bit, pf8bit: + filter := EncodeFilterRow(Bitmap.ScanLine[j], filter_buffers, + row_buffer_width, offset); + else + begin + {Copy pointer to the line bytes} + Line := Bitmap.ScanLine[j]; + + {Test the pixel format} + case Bitmap.PixelFormat of + {3 bytes, just swap} + pf24bit: + FOR i := 0 to Bitmap.Width - 1 do + begin + Row_Buffer^[i * 3] := AdjustValue(pRGBLine(Line)^[i].rgbtRed); + Row_Buffer^[1 + (i * 3)] := AdjustValue(pRGBLine(Line)^[i].rgbtGreen); + Row_Buffer^[2 + (i * 3)] := AdjustValue(pRGBLine(Line)^[i].rgbtBlue); + end; + {4 bytes, swap and ignore last byte unused} + pf32bit: + FOR i := 0 to Bitmap.Width - 1 do + begin + Row_Buffer^[i * 4] := AdjustValue(pRGBALine(Line)^[i].rgbRed); + Row_Buffer^[1 + (i * 4)] := AdjustValue(pRGBALine(Line)^[i].rgbGreen); + Row_Buffer^[2 + (i * 4)] := AdjustValue(pRGBALine(Line)^[i].rgbBlue); + end; + end; + + {Filter the row} + filter := EncodeFilterRow(@Row_Buffer[0], filter_buffers, + row_buffer_width, offset); + end; + end; + + (*Write to stream*) + //Encode.Write(Filter, 1); + gzwrite (encode, @Filter, 1); + gzwrite (encode, @filter_buffers[Filter]^[0], row_buffer_width); + //Encode.Write(filter_buffers[Filter]^[0], row_buffer_width); + end; + end; + + {Free the compression stream} + //Encode.Free; + {Free memory from the filters} + FreeMem(row_buffer, row_buffer_width); + FreeMem(filter_buffers[FILTERNONE], row_buffer_width); + if efSub in Bitmap.Filter then + FreeMem(filter_buffers[FILTERSUB], row_buffer_width); + if efUp in Bitmap.Filter then + FreeMem(filter_buffers[FILTERUP], row_buffer_width); + if efAverage in Bitmap.Filter then + FreeMem(filter_buffers[FILTERAVERAGE], row_buffer_width); + if efPaeth in Bitmap.Filter then + FreeMem(filter_buffers[FILTERPAETH], row_buffer_width); + + {$IFDEF SHAREWARE} Shareware {$ENDIF}; +end; + +{:Adjust image pixel format} +procedure TChunkIDAT.SetupPixelFormat; +var + PlteIndex, i : Integer; + GrayscalePal : TMaxLogPalette; + GAMACHUNK : TChunkGAMA; +begin + (*{In case we need an alpha channel bitmap} + if (IHDR.ColorType = GrayscaleALpha) or + (IHDR.ColorType = RGBAlpha) then + begin + {Free the old mask} + FreeAndNil(Bitmap.fMask); + + {Create a new bitmap} + Bitmap.fMask := TBitmap.Create; + + {Set its properties} + with Bitmap.fMask do + begin + Width := IHDR.Width; + Height := IHDR.Height; + PixelFormat := pf8bit; + end; + end; *) + {Retrieve the chunk GAMA} + GamaChunk := Gama; + + {Set the pixel formats} + CASE IHDR.ColorType of + GrayScale, Palette, GrayScaleAlpha: + CASE IHDR.BitDepth of + 1: Bitmap.PixelFormat := pf1bit; {1 bit, 2 colors: 2^1} + 2: Bitmap.PixelFormat := pf4bit; + 4: Bitmap.PixelFormat := pf4bit; + 8: Bitmap.PixelFormat := pf8bit; {1 byte in each pixel, 256 colors} + 16: Bitmap.PixelFormat := pf8bit; {2 bytes per sample} + END; + RGB, RGBALPHA: + CASE IHDR.BitDepth of + 8: Bitmap.PixelFormat := pf24bit; {R, G, B values for each pixel} + 16: Bitmap.PixelFormat := pf24bit; {Increased range of values for RGB} + END; + END; + + {Create the palettes for the file formats} + CASE IHDR.ColorType of + Grayscale, GrayscaleAlpha: + {Create grayscale palette} + with GrayscalePal do + begin + palVersion := $300; + + {Set the number of colors in palette} + {Since the max is 256 colors 16bit per sample pixels will be} + {averanged to 8} + if IHDR.BitDepth = 16 then + palNumEntries := 256 + else + palNumEntries := (1 shl IHDR.BitDepth); + + {Set the palette colors} + FOR i := 0 to palNumEntries - 1 DO + WITH palPalEntry[i] do + begin //cr + {Average the colors} + {When i is 0, the color is black} + {When i is palNumEntries, the color is white} + peRed := MulDiv(i, 255, palNumEntries - 1); + {Correct using gamma} + if Assigned(GamaChunk) then + peRed := GamaChunk.GammaTable[peRed]; + peGreen := peRed; + peBlue := peGreen; + peFlags := PC_NOCOLLAPSE; + end; + + IF (IHDR.BitDepth = 2) and (palNumEntries < 16) then + begin + {Note: This is really a crazy totally nonsence fix for supporting 2bit} + palNumEntries := 16; + copymemory(@palpalentry[4], @palpalentry[0], 21); + copymemory(@palpalentry[8], @palpalentry[0], 21); + copymemory(@palpalentry[12], @palpalentry[0], 21); + end; + + {Apply the bitmap palette} + Bitmap.Palette := CreatePalette(PLogPalette(@GrayscalePal)^); + end; + Palette: + BEGIN + {Test if there is PLTE chunk, if so apply the palette} + PlteIndex := Owner.IndexOfClass(TChunkPLTE); { Paul } + if PlteIndex <> -1 then + Bitmap.Palette := TChunkPLTE(Owner[PlteIndex]).Palette + ELSE + CallError(PNG_ERROR_NO_PALETTE); + END; + END; +end; + +{:Filters the row using definied types} +procedure TChunkIDAT.FilterRow(Filter: Byte; CurrentRow, LastRow: pByteArray; + offset, row_buffer_width: Integer); +var + Col: Integer; {Current Column} + Left, Above, AboveLeft: Integer; + vv, pp: Integer; +begin + + // Filter the row based upon the filter type. + case filter of + {No filtering, do nothing} + FILTERNONE: begin end; + {Sub filter} + FILTERSUB: + {The value is the difference from the value to the left} + for col := offset to row_buffer_width - 1 do + CurrentRow[col] := (CurrentRow[col] + CurrentRow[col-offset]) AND $FF; + FILTERUP: + {The value is the difference from the value in the previous row.} + for col := 0 to row_buffer_width - 1 do + CurrentRow[col] := (CurrentRow[col] + LastRow[col]) AND $FF ; + FILTERAVERAGE: + for col := 0 to row_buffer_width - 1 do + begin + above := LastRow[col]; + + if (col < offset) then + left := 0 + else + left := CurrentRow[col-offset] ; + + CurrentRow[col] := (CurrentRow[col] + (left + above) div 2) AND $FF ; + end; + FILTERPAETH: + for col := 0 to row_buffer_width - 1 do + begin + above := LastRow[col] ; + + if (col < offset) then + begin + left := 0 ; + aboveleft := 0 ; + end + else + begin + left := CurrentRow[col-offset] ; + aboveleft := LastRow[col-offset] ; + end; + + vv := CurrentRow[col] ; + pp := PaethPredictor(left, above, aboveleft) ; + CurrentRow[col] := (pp + vv) AND $FF ; + end; + else + {In case the filter is not reconized} + CallError(PNG_ERROR_INVALID_FILTER_TYPE); + end; {Case} + +end; + +{:When the chunk is going to be saved to a stream} +procedure TChunkIDAT.SaveToStream(Stream: TStream); +begin + {Set to encode the image to the data} + EncodeImage; + {Then write} + inherited; +end; + +{Assign data from one gama chunk} +procedure TChunkGAMA.Assign(Source: TChunk); +begin + inherited; // fix 1 + GammaTable := TChunkGAMA(Source).GammaTable; + InverseTable := TChunkGAMA(Source).InverseTable; +end; + +{When the object is being created} +constructor TChunkGAMA.Create(AOwner: TChunkList); +begin + inherited; + {Set the size of the stream and initial value} + fStream.SetSize(4); + Value := 1; +end; +function Power(Base, Exponent: extended): extended; +begin + if Base > 0 then + Power := Exp(Exponent * Ln(Base) ) + else + Power := 0; +end; +{:Creates a gamma table for using} +procedure TChunkGAMA.DoAction; +var + I : Integer; + lX: Extended; +begin + {Create gamma table and inverse gamma table (for saving)} + FOR I := 0 TO 255 DO + begin + if Value = 0 then //problem with Adobe PNG images + lX := 0.00001//random(255) +1 + else + lX := Value; + GammaTable[I] := Round(Power((I / 255), 1 / (lX / 100000 * 2.2)) * 255); + InverseTable[Round(Power((I / 255), 1 / (lX / 100000 * 2.2)) * 255)] := I; + end; +end; + + +{Returns the Gama value} +function TChunkGAMA.GetValue: Cardinal; +begin + Result := SwapLong(pCardinal(fStream.Memory)^); +end; + +{Sets the Gama value} +procedure TChunkGAMA.SetValue(Value: Cardinal); +begin + pCardinal(fStream.Memory)^ := SwapLong(Value); +end; + +{:When the chunk is being saved} +procedure TChunkIHDR.SaveToStream(Stream: TStream); +begin + {Set the IHDR chunk properties} + Compression := 0; {The only compression method avaliable} + Filter := 0; {The only filter scheme avaliable} + + if Owner.Owner.Interlacing then {Interlace method} + Interlaced := 1 {ADAM 7} + else + Interlaced := 0; {NONE} + + Width := Owner.Owner.Width; + Height := Owner.Owner.Height; + + {Color type} + case Owner.Owner.PixelFormat of + pf1bit, pf4bit, pf8bit: + begin + {Palette} + ColorType := PALETTE; + {Bit depth} + case Owner.Owner.PixelFormat of + pf1bit: BitDepth := 1; + pf4bit: BitDepth := 4; + pf8bit: BitDepth := 8; + end; + + end; + else + begin + {R, G, B} + Owner.Owner.PixelFormat := pf24bit; + ColorType := RGB; + BitDepth := 8; + end; + end; + + inherited; +end; + +{Get values for the other properties} +function TChunkIHDR.GetValue(Index: Integer): Byte; +begin + case Index of + 0: {Bit depth} Result := pIHDRChunk(fStream.Memory)^.BitDepth; + 1: {Color type} Result := pIHDRChunk(fStream.Memory)^.ColorType; + 2: {Compression} Result := pIHDRChunk(fStream.Memory)^.Compression; + 3: {Filter} Result := pIHDRChunk(fStream.Memory)^.Filter; + 4: {Interlaced} Result := pIHDRChunk(fStream.Memory)^.Interlaced; + else {Avoid warning} + Result := 0; + end; + +end; + +{Set value for the other properties} +procedure TChunkIHDR.SetValue(Index: Integer; Value: Byte); +begin + case Index of + 0: {Bit depth} pIHDRChunk(fStream.Memory)^.BitDepth := Value; + 1: {Color type} pIHDRChunk(fStream.Memory)^.ColorType := Value; + 2: {Compression} pIHDRChunk(fStream.Memory)^.Compression := Value; + 3: {Filter} pIHDRChunk(fStream.Memory)^.Filter := Value; + 4: {Interlaced} pIHDRChunk(fStream.Memory)^.Interlaced := Value; + end; +end; + +{Returns the image height} +function TChunkIHDR.GetHeight: Cardinal; +begin + Result := SwapLong(pIHDRChunk(fStream.Memory)^.Height); +end; + +{Returns the image width} +function TChunkIHDR.GetWidth: Cardinal; +begin + Result := SwapLong(pIHDRChunk(fStream.Memory)^.Width); +end; + +{Sets the image height} +procedure TChunkIHDR.SetHeight(Value: Cardinal); +begin + pIHDRChunk(fStream.Memory)^.Height := SwapLong(Value); + + {Changes the image size} + if Owner.Owner.Height <> Int(Value) then + Owner.Owner.Height := Value; +end; + +{Sets the image width} +procedure TChunkIHDR.SetWidth(Value: Cardinal); +begin + pIHDRChunk(fStream.Memory)^.Width := SwapLong(Value); + + {Changes the image size} + if Owner.Owner.Width <> Int(Value) then + Owner.Owner.Width := Value; +end; + +{:When the object is being created} +constructor TChunkIHDR.Create(AOwner: TChunkList); +begin + inherited; + {Resize the IHDR chunk} + fStream.SetSize(13); +end; + +{:Returns the index of the chunk class} +function TChunkClasses.IndexOfClass(Item: TChunkClass): Integer; { Paul } +var + i: Integer; +begin + {If none found, return -1} + Result := -1; + + {Test each class} + if Count > 0 then + FOR i := 0 to Count - 1 DO + if Self.Item[I].ChunkClass = Item then + begin + Result := i; + break; + end; +end; + +{:Returns the index of the given chunk type} +function TChunkClasses.IndexOfType(Item: TChunkType): Integer; { Paul } +var + i: Integer; +begin + {If none found, return -1} + Result := -1; + + {Test each class} + if Count > 0 then + FOR i := 0 to Count - 1 DO + if Self.Item[I].ChunkType = Item then + begin + Result := i; + break; + end; +end; + +{:When the object is being destroyed} +destructor TChunkClasses.Destroy; +var + i: Integer; +begin + FOR i := 0 TO Count - 1 DO + Dispose(pChunkClassInfo(fList[i])); + + inherited; +end; + +{:Returns an item from the list} +function TChunkClasses.GetItem(Index: Integer): TChunkClassInfo; +begin + {Test if the index is valid} + if (Index < 0) or (Index > Count - 1) then + CallError(PNG_ERROR_INVALID_CHUNK_CLASS_INDEX); + + Result := pChunkClassInfo(fList[Index])^; + +end; + + +{Returns the number of items in the list} +function TChunkClasses.GetCount: Integer; +begin + {If the list object exists, then return the count from it} + {otherwise returns 0 } + if Assigned(fList) then + Result := fList.Count + else + Result := 0; +end; + +{:Add a new chunk class to the list of classes} +procedure TChunkClasses.Add(ChunkType: TChunkType; + ChunkClass: TChunkClass); +var + NewItem: pChunkClassInfo; +begin + {Create the list if it does not exists} + if not Assigned(fList) then + fList := TList.Create; + + {Allocate memory for the new item} + New(NewItem); + + {Set the new item properties} + NewItem^.ChunkType := ChunkType; + NewItem^.ChunkClass := ChunkClass; + + {Add to the list} + fList.Add(NewItem); + +end; + +{Do the action when the chunk is read} +procedure TChunk.DoAction; +begin + inherited; +end; + +{Returns a pointer to the png image owner} +function TChunk.GetBitmap: TPNGImage; +begin + Result := Owner.Owner; +end; + +{Returns a pointer to the GAMA} +function TChunk.GetGAMA: TChunkGAMA; +var + Pos: Integer; +begin + {Position of the chunk} + Pos := Owner.IndexOfClass(TChunkGAMA); { Paul } + + {Returns nil if the chunk does not exists} + if Pos = -1 then + Result := nil + else + Result := TChunkGAMA(Owner[Pos]); + +end; + +{Returns a pointer to the IHDR} +function TChunk.GetIHDR: TChunkIHDR; +begin + Result := TChunkIHDR(Owner[0]); +end; + +{:Assign from another chunk} +procedure TChunk.Assign(Source: TChunk); +begin + {Clear the current stream} + fStream.Clear; + {Copy data from the other stream} + fStream.CopyFrom(Source.fStream, 0); + + {Copy the chunk name} + fType := Source.fType; +end; + +{:Returns the chunk size} +function TChunk.GetSize: Integer; +begin + Result := fStream.Size; +end; + +{:Saves the chunk data to the stream} +procedure TChunk.SaveToStream(Stream: TStream); +var + ChunkLen: Cardinal; + ChunkCRC: Cardinal; +begin + {The chunk is not safe-to-copy} + if ChunkType[3] = LowerCase(ChunkType[3]) then + exit; + + {First the chunk length} + ChunkLen := SwapLong(fStream.Size); + Stream.Write(ChunkLen, 4); + + {Now write the chunk type} + Stream.Write(fType, 4); + + {Write the chunk data} + Stream.CopyFrom(fStream, 0); + + {Calculate and write the CRC} + ChunkCRC := SwapLong(CRC(fType, fStream.Memory, fStream.Size)); + Stream.Write(ChunkCRC, 4); +end; + +{Retrieve the chunk index inside the list} +function TChunk.GetIndex: Integer; +begin + Result := Owner.IndexOfChunk(Self); { Paul } +end; + +{:Called when the object is being created} +constructor TChunk.Create(AOwner: TChunkList); +var + ClassPos: Integer; +begin + {Create the stream containg the memory data} + fStream := TMemoryStream.Create; + fList := AOwner; + + {Default class name} + ClassPos := ChunkClasses.IndexOfClass(TChunkClass(ClassType)); { Paul } + if ClassPos <> -1 then + fType := ChunkClasses[ClassPos].ChunkType; +end; + +{:Called when the object is being destroyed} +destructor TChunk.Destroy; +begin + {Free the stream containing the memory data} + fStream.Free; + + inherited; +end; + +{:Move one chunk position in the list} +procedure TChunkList.Move(Index1, Index2: Integer); +begin + {Test for index} + if (Index1 < 0) or (Index1 >= Count) then + CallError(PNG_ERROR_INVALID_CHUNK_INDEX); + + FList.Move(Index1, Index2); +end; + +{Returns the number of items in the list (Used with Count property)} +function TChunkList.GetCount: Integer; +begin + Result := fList.Count; +end; + +{Returns an item from the list (Used with Item property)} +function TChunkList.GetItem(Index: Integer): TChunk; +begin + {Test if the chunk index is valid} + if (Index < 0) or (Index > Count - 1) then + CallError(PNG_ERROR_INVALID_CHUNK_INDEX); + + {If so, return the item} + Result := fList[Index]; +end; + +{:Removes a chunk} +procedure TChunkList.Remove(Item: TChunk); +begin + {Makes sure that the list contains the chunk} + if Item.Owner <> Self then + CallError(CHUNK_NOT_CHILD); + + {Delete the chunk} + FList.Delete(Item.Index); + Item.Free; + +end; + +{:Add a chunk to the list when the chunk object ALREADY EXISTS} +function TChunkList.AddItem(Item: TChunk): TChunk; { Paul } +begin + {Add the item to the list} + fList.Add(Item); + Result := Item; +end; + + +{:Returns the index of the first chunk of the type in the parameter} +function TChunkList.IndexOfClass(ChunkClass: TChunkClass): Integer; { Paul } +var + I: Integer; +begin + {Returns -1 if none found} + Result := -1; + + {If there are items in the list, test each item} + if Count > 0 then + FOR i := 0 TO Count - 1 DO + if Item[I].ClassType = ChunkClass then + begin + result := i; + break; + end; +end; + +{:Returns the position of a chunk inside the list} +function TChunkList.IndexOfChunk(Chunk: TChunk): Integer; { Paul } +begin + Result := fList.IndexOf(Chunk); +end; + +{:Add a chunk to the list when the chunk object DOES NOT EXISTS + but it already knows which chunk class to create} +function TChunkList.AddClass(ChunkClass: TChunkClass): TChunk; { Paul } +begin + Result := AddItem(ChunkClass.Create(Self)); +end; + +{:Add a chunk to the list when the chunk data needs to be readed + from a stream. } +function TChunkList.AddStream(Stream: TStream): TChunk; { Paul } +var + CLength: Cardinal; + CType : TChunkType; + CCRC : Cardinal; + i, p : Integer; +begin + {First read the chunk length} + Stream.Read(CLength, 4); + CLength := SwapLong(CLength); + {Now read the chunk type} + Stream.Read(CType, 4); + + {Look for chunk classes supporting the given chunk type} + i := ChunkClasses.IndexOfType(CType); { Paul } + + {Test if the chunk is critical but unknown} + if ((Byte(CType[0]) AND $20) = 0) and (i = -1) then + CallError(PNG_ERROR_UNKOWN_CRITICAL_CHUNK); + + {If the chunk type exists in the list, then create an object } + {using the class found, otherwise use the generic TChunk class} + if i <> - 1 then + Result := ChunkClasses[I].ChunkClass.Create(Self) + else + Result := TChunk.Create(Self); + + {Copy the chunk type} + Result.fType := CType; + + {Read the data if the chunk contains data} + if CLength > 0 then + Result.fStream.CopyFrom(Stream, CLength); + + {Read the CRC for checking} + Stream.Read(CCRC, 4); + CCRC := SwapLong(CCRC); + + {Test if the CRC is valid} + if CRC(CType, Result.fStream.Memory, CLength) <> CCRC then + CallError(PNG_ERROR_CHUNK_INVALID_CRC); + + {If there are already IDAT chunks, then mix the actual IDAT} + {being readed with the previous IDAT} + if (Result is TChunkIDAT) then + p := IndexOfClass(TChunkIDAT) { Paul } + else + p := -1; + + if (Result is TChunkIDAT) and (p <> -1) then + begin + {Copy data to the old stream} + Item[p].fStream.CopyFrom(Result.fStream, 0); + + {Free the actual IDAT stream and returns the last} + Result.Free; + Result := Item[p]; + end + else {Add the item to the list} + Result := AddItem(Result); { Paul } +end; + +{:Clear all the chunks in the list} +procedure TChunkList.Clear; +var + i: Integer; +begin + {If there are items in the list, delete each one} + if Count > 0 then + FOR i := Count - 1 DOWNTO 0 DO + BEGIN + {Free the chunk and delete from the list} + Item[i].Free; + FList.Delete(I); + END; + +end; + +{:Called when the object is being created} +constructor TChunkList.Create(AOwner: TPNGImage); +begin + {Copy the TPNGImage owner pointer} + fImage := AOwner; + + {Create the TList} + fList := TList.Create; +end; + +{:Called when the object is being destroyed} +destructor TChunkList.Destroy; +begin + {Clear and free the TList} + Clear; + fList.Free; + + inherited; +end; + + +{:Special override for assigning other TPNGImages} +procedure TPNGImage.Assign(Source: TPersistent); +var + SourcePNG: TPNGImage; + i, j : Integer; +begin + {If the source is also a TPNGImage, copy the chunks} + if Source is TPNGImage then + begin + SourcePNG := TPNGImage(Source); + {Clear current chunks} + Chunks.Clear; + + {Copy the chunks} + if SourcePNG.Chunks.Count > 0 then + FOR i := 0 TO SourcePNG.Chunks.Count - 1 DO + begin + j := Chunkclasses.IndexOfType(SourcePNG.Chunks[i].fType); { Paul } + {If the class is a know class, create it using that class} + {otherwise with the default TChunk class} + if j <> -1 then + Chunks.AddItem(Chunkclasses[j].ChunkClass.Create(Chunks)).Assign(SourcePNG.Chunks[i]) { Paul } + else + Chunks.AddItem(TChunk.Create(Chunks)).Assign(SourcePNG.Chunks[i]); { Paul } + end; + + {Copy other info} + Filter := SourcePNG.fEncodeFilter; + Interlacing := SourcePNG.fInterlacing; + end; + + inherited; + +end; + +{:Called when the object is being created} +constructor TPNGImage.Create; +begin + inherited; + fMask := nil; + + {Create the list of chunks object} + fChunkList := TChunkList.Create(Self); + fInterlacing := FALSE; + + Filter := [efNone, efSub, efAverage, efPaeth]; + + {Create the standard chunks} + Clear; +end; + +{:Called when the object is being destroyed} +destructor TPNGImage.Destroy; +begin + {Free the mask if assigned} + if Assigned(fMask) then + fMask.Free; + + {Destroy the list of chunks object} + fChunkList.Free; + inherited; +end; + +{Set the filters that are going to be used when encoding} +procedure TPNGImage.SetFilter(Value: TEncodeFilterSet); +begin + {efNone is the only value that the set must have} + if not (efNone in Value) then + Include(Value, efNone); + + fEncodeFilter := Value; +end; + +{:Clears the current image} +procedure TPNGImage.Clear; +begin + {Clear the current chunks} + Chunks.Clear; + + with TChunkIHDR(Chunks.AddClass(TChunkIHDR)) do { Paul } + begin + Width := 0; + Height := 0; + BitDepth := 2; + ColorType := 3; + Compression := 0; + Filter := 0; + Interlaced := 0; + end; + + {Clears the palette} + Palette := 0; + + {Add IDAT chunk} + Chunks.AddClass(TChunkIDAT); { Paul } + + {Add IEND chunk} + Chunks.AddClass(TChunkIEND); { Paul } +end; + +{:Saves the current PNG image to the stream} +procedure TPNGImage.SaveToStream(Stream: TStream); +var + i: Integer; +begin + {Do the actual writting} + with Stream do + begin + {Write the valid header} + Write(PNGHeader, 8); + + {If there are no chunks, then create the standard ones} + if Chunks.Count = 0 then + Clear; + + {Ensure that there is a IHDR chunk} + if (Chunks.Count = 0) or (not (Chunks[0] is TChunkIHDR)) then + Chunks.Move(Chunks.AddClass(TChunkIHDR).Index, 0); { Paul } + + {PLTE chunk needed} + if ((PixelFormat = pf1bit) or (PixelFormat = pf4bit) or + (PixelFormat = pf8bit)) and (Chunks.IndexOfClass(TChunkPLTE) = -1) then { Paul } + Chunks.Move(Chunks.AddClass(TChunkPLTE).Index, 1); { Paul } + + {If the image needs TRNS chunk} + if Transparent then + Chunks.Move(Chunks.AddClass(TChunkTRNS).Index, 1) { Paul } + {If transparency is not being used, delete the transparency chunk(s)} + else if Chunks.IndexOfClass(TChunkTRNS) <> -1 then { Paul } + repeat + Chunks.Remove(Chunks[Chunks.IndexOfClass(TChunkTRNS)]); { Paul } + until Chunks.IndexOfClass(TChunkTRNS) = -1; { Paul } + + {Make sures that there is a IEND chunk} + if Chunks.IndexOfClass(TChunkIEND) = -1 then { Paul } + Chunks.AddClass(TChunkIEND); { Paul } + + {Make sures that there is a IDAT chunk} + if Chunks.IndexOfClass(TChunkIDAT) = -1 then { Paul } + Chunks.Move(Chunks.AddClass(TChunkIDAT).Index, 1); { Paul } + + {Write each chunk} + FOR i := 0 to Chunks.Count -1 DO + Chunks[i].SaveToStream(Stream); + + end; +end; + +{:Loads a PNG image from the stream} +procedure TPNGImage.LoadFromStream(Stream: TStream); +var + ReadHeader: TPNGHeader; + i : Integer; +begin + + {Clear the current chunks} + Clear; + Chunks.Clear; +xxxx + {Do the actual reading} + with Stream do + begin + {Read the PNG file header for checking} + Read(ReadHeader, 8); + if not CompareMem(@ReadHeader, @PNGHeader, 8) then + CallError(PNG_ERROR_INVALID_HEADER); + + {Read the chunks} + while (not (Chunks.AddStream(Stream) is TChunkIEND)) and { Paul } + not (Stream.Position = Stream.Size) do + begin end; + + {Test if IHDR is the first chunk} + if (Chunks.Count = 0) or not (Chunks[0] is TChunkIHDR) then + CallError(PNG_ERROR_IHDR_NOT_FIRST); + + {Test if there is IDAT chunk, if so, decode it} + if Chunks.IndexOfClass(TChunkIDAT) = -1 then { Paul } + CallError(PNG_ERROR_NO_IDAT); + + {Execute each chunks action} + FOR i := 0 to Chunks.Count - 1 DO + Chunks[i].DoAction; + + {Test if there is tRNS chunk, if so, apply the transparency} + if Chunks.IndexOfClass(TChunkTRNS) <> -1 then { Paul } + case TChunkIHDR(Chunks[0]).ColorType of + RGB: + begin + TransparentColor := + TChunkTRNS(Chunks[Chunks.IndexOfClass(TChunkTRNS)]).GetRGBColor; { Paul } + Transparent := TRUE; + end; + end; + + end; {with} + +end; + +{:Register a new chunk class} +class procedure TPNGImage.RegisterChunkClass(ChunkType: TChunkType; + ChunkClass: TChunkClass); +begin + RegisterNewChunkClass(ChunkType, ChunkClass); +end; + +procedure ConvertBits(Source: array of Pointer; Target: Pointer; + Count: Cardinal; Mask: Byte; FSourceBPS, FTargetBPS: Byte); +var + SourceRun, TargetRun: PByte; + Value, BitRun,TargetMask, SourceMask, SourceShift, TargetShift, MaxInSample, + MaxOutSample, SourceBPS, TargetBPS: Byte; + Done: Cardinal; +begin + SourceRun := Source[0]; TargetRun := Target; + BitRun := $80; SourceBPS := FSourceBPS; TargetBPS := FTargetBPS; + SourceMask := Byte(not ((1 shl (8 - SourceBPS)) - 1)); + MaxInSample := (1 shl SourceBPS) - 1; + TargetMask := (1 shl (8 - TargetBPS)) - 1; + MaxOutSample := (1 shl TargetBPS) - 1; + SourceShift := 8; TargetShift := 8 - TargetBPS; Done := 0; + while Done < Count do + begin + if Boolean(Mask and BitRun) then + begin + Dec(SourceShift, SourceBPS); + Value := (SourceRun^ and SourceMask) shr SourceShift; + Value := MulDiv(Value, MaxOutSample, MaxInSample); + TargetRun^ := (TargetRun^ and TargetMask) or (Value shl TargetShift); + if SourceShift = 0 then + begin + SourceShift := 8; + Inc(SourceRun); + end; + asm + MOV CL, [SourceBPS] + ROR BYTE PTR [SourceMask], CL + end; + end; + asm + ROR BYTE PTR [BitRun], 1 + MOV CL, [TargetBPS] + ROR BYTE PTR [TargetMask], CL + end; + if TargetShift = 0 then + TargetShift := 8 - TargetBPS + else + Dec(TargetShift, TargetBPS); + Inc(Done); + if (Done mod (8 div TargetBPS)) = 0 then Inc(TargetRun); + end; +end; + +var +(* Table of CRCs of all 8-bit messages. *) +crc_table: array[0..255] of Cardinal; +(* Flag: has the table been computed? Initially false. *) +crc_table_computed: Integer = 0; + +(*: Make the table for a fast CRC. *) +procedure make_crc_table; +var + c : Cardinal; + n, k: Integer; +begin + + for n := 0 to 255 do + begin + c := n; + for k := 0 to 7 do + begin + if boolean(c and 1) then + c := $edb88320 xor (c shr 1) + else + c := c shr 1; + end; + crc_table[n] := c; + end; + + crc_table_computed := 1; +end; + +(*: Update a running CRC with the bytes buf[0..len-1]--the CRC + should be initialized to all 1's, and the transmitted value + is the 1's complement of the final running CRC (see the + crc() routine below)). *) +function update_crc(chunktype: tchunktype; crc: Cardinal; buf: pByteArray; + len: Integer): Cardinal; +var + c: Cardinal absolute crc; + n: Integer; +begin + if not boolean(crc_table_computed) then + make_crc_table; + + for n := 0 to 3 do + c := crc_table[(c XOR ord(chunktype[n])) AND $ff] XOR (c SHR 8); + + for n := 0 to Len - 1 do + c := crc_table[(c XOR buf[n]) AND $ff] XOR (c SHR 8); + + Result := C; +end; + +(*: Return the CRC of the bytes buf[0..len-1]. *) +function crc(chunktype: tchunktype; buf: pbytearray; len: Integer): Cardinal; +begin + result := update_crc(chunktype, Cardinal($ffffffff), buf, len) xor Cardinal($ffffffff); { Paul } +end; + + +{When the compiled unit is being initialized} + + +initialization + ChunkClasses := TChunkClasses.Create; + + {Register the chunk classes} + RegisterNewChunkClass('IEND', TChunkIEND); + RegisterNewChunkClass('IHDR', TChunkIHDR); + RegisterNewChunkClass('gAMA', TChunkGAMA); + RegisterNewChunkClass('IDAT', TChunkIDAT); + RegisterNewChunkClass('PLTE', TChunkPLTE); + RegisterNewChunkClass('tEXt', TChunkTEXT); + RegisterNewChunkClass('tRNS', TChunkTRNS); + RegisterNewChunkClass('tIME', TChunkTRNS); + + {Register the graphical class} + TPicture.RegisterFileFormat('PNG', 'Portable Graphics Network', TPNGImage); + +{When the compiled unit is being finalized} +finalization + ChunkClasses.Free; + + {Unregister the graphical class} + TPicture.UnregisterGraphicClass(TPNGImage); + +end. diff --git a/niftiview7/gzio/oPNGZLIB.pas b/niftiview7/gzio/oPNGZLIB.pas new file mode 100755 index 0000000..506305a --- /dev/null +++ b/niftiview7/gzio/oPNGZLIB.pas @@ -0,0 +1,802 @@ +unit oPNGZLIB; + +{ Delphi 3 compatibility by Paul TOTH <tothpaul@free.fr> } + +interface + +uses + Sysutils, Classes; + +const + ZLIB_VERSION = '1.1.3'; +//type gzFile = voidp; +type + TZAlloc = function (opaque: Pointer; items, size: Integer): Pointer; + TZFree = procedure (opaque, block: Pointer); + + TZCompressionLevel = (zcNone, zcFastest, zcDefault, zcMax); + + {** TZStreamRec ***********************************************************} + + TZStreamRec = packed record + next_in : PChar; // next input byte + avail_in : Longint; // number of bytes available at next_in + total_in : Longint; // total nb of input bytes read so far + + next_out : PChar; // next output byte should be put here + avail_out: Longint; // remaining free space at next_out + total_out: Longint; // total nb of bytes output so far + + msg : PChar; // last error message, NULL if no error + state : Pointer; // not visible by applications + + zalloc : TZAlloc; // used to allocate the internal state + zfree : TZFree; // used to free the internal state + opaque : Pointer; // private data object passed to zalloc and zfree + + data_type: Integer; // best guess about the data type: ascii or binary + adler : Longint; // adler32 value of the uncompressed data + reserved : Longint; // reserved for future use + end; + + {** TCustomZStream ********************************************************} + + TCustomZStream = class(TStream) + private + FStream : TStream; + FStreamPos : Integer; + FOnProgress: TNotifyEvent; + + FZStream : TZStreamRec; + FBuffer : Array [Word] of Char; + protected + constructor Create(stream: TStream); + + procedure DoProgress; dynamic; + + property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; + end; + + {** TZCompressionStream ***************************************************} + + TZCompressionStream = class(TCustomZStream) + private + function GetCompressionRate: Single; + public + constructor Create(dest: TStream; compressionLevel: TZCompressionLevel {Paul= zcDefault{}); + destructor Destroy; override; + + function Read(var buffer; count: Longint): Longint; override; + function Write(const buffer; count: Longint): Longint; override; + function Seek(offset: Longint; origin: Word): Longint; override; + + property CompressionRate: Single read GetCompressionRate; + property OnProgress; + end; + + {** TZDecompressionStream *************************************************} + + TZDecompressionStream = class(TCustomZStream) + public + constructor Create(source: TStream); + destructor Destroy; override; + + function Read(var buffer; count: Longint): Longint; override; + function Write(const buffer; count: Longint): Longint; override; + function Seek(offset: Longint; origin: Word): Longint; override; + + property OnProgress; + end; + +{** zlib public routines ****************************************************} + +{***************************************************************************** +* ZCompress * +* * +* pre-conditions * +* inBuffer = pointer to uncompressed data * +* inSize = size of inBuffer (bytes) * +* outBuffer = pointer (unallocated) * +* level = compression level * +* * +* post-conditions * +* outBuffer = pointer to compressed data (allocated) * +* outSize = size of outBuffer (bytes) * +*****************************************************************************} + +procedure ZCompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; + level: TZCompressionLevel { Paul = zcDefault}); + +{***************************************************************************** +* ZDecompress * +* * +* pre-conditions * +* inBuffer = pointer to compressed data * +* inSize = size of inBuffer (bytes) * +* outBuffer = pointer (unallocated) * +* outEstimate = estimated size of uncompressed data (bytes) * +* * +* post-conditions * +* outBuffer = pointer to decompressed data (allocated) * +* outSize = size of outBuffer (bytes) * +*****************************************************************************} + +procedure ZDecompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; outEstimate: Integer {Paul = 0}); + +{** string routines *********************************************************} + function DeflateInit2(var stream: TZStreamRec; level, method, windowBits,memLevel, strategy: Integer): Integer; + +function ZCompressStr(const s: String; level: TZCompressionLevel {Paul= zcDefault}): String; + +function ZDecompressStr(const s: String): String; + +type + EZLibError = class(Exception); + + EZCompressionError = class(EZLibError); + EZDecompressionError = class(EZLibError); + +implementation + +{ GZOPEN ==================================================================== + + Opens a gzip (.gz) file for reading or writing. As Pascal does not use + file descriptors, the code has been changed to accept only path names. + + The mode parameter defaults to BINARY read or write operations ('r' or 'w') + but can also include a compression level ('w9') or a strategy: Z_FILTERED + as in 'w6f' or Z_HUFFMAN_ONLY as in 'w1h'. (See the description of + deflateInit2 for more information about the strategy parameter.) + + gzopen can be used to open a file which is not in gzip format; in this + case, gzread will directly read from the file without decompression. + + gzopen returns NIL if the file could not be opened (non-zero IOResult) + or if there was insufficient memory to allocate the (de)compression state + (zlib error is Z_MEM_ERROR). + + Vincent: + Added argument 'flags' to the original Zlib files. +============================================================================} + +uses zdeflate,zinflate,infblock,inftrees,infcodes,infutil,inffast,trees,adler_32; + +(*{** link zlib code **********************************************************} + +{$L deflate.obj} +{$L inflate.obj} +{$L infblock.obj} +{$L inftrees.obj} +{$L infcodes.obj} +{$L infutil.obj} +{$L inffast.obj} +{$L trees.obj} +{$L adler32.obj} + *) +{***************************************************************************** +* note: do not reorder the above -- doing so will result in external * +* functions being undefined * +*****************************************************************************} + +const + {** flush constants *******************************************************} + + Z_NO_FLUSH = 0; + Z_PARTIAL_FLUSH = 1; + Z_SYNC_FLUSH = 2; + Z_FULL_FLUSH = 3; + Z_FINISH = 4; + + {** return codes **********************************************************} + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = (-1); + Z_STREAM_ERROR = (-2); + Z_DATA_ERROR = (-3); + Z_MEM_ERROR = (-4); + Z_BUF_ERROR = (-5); + Z_VERSION_ERROR = (-6); + + {** compression levels ****************************************************} + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = (-1); + + {** compression strategies ************************************************} + + Z_FILTERED = 1; + Z_HUFFMAN_ONLY = 2; + Z_DEFAULT_STRATEGY = 0; + + {** data types ************************************************************} + + Z_BINARY = 0; + Z_ASCII = 1; + Z_UNKNOWN = 2; + + {** compression methods ***************************************************} + + Z_DEFLATED = 8; + + {** return code messages **************************************************} + + _z_errmsg: array[0..9] of PChar = ( + 'need dictionary', // Z_NEED_DICT (2) + 'stream end', // Z_STREAM_END (1) + '', // Z_OK (0) + 'file error', // Z_ERRNO (-1) + 'stream error', // Z_STREAM_ERROR (-2) + 'data error', // Z_DATA_ERROR (-3) + 'insufficient memory', // Z_MEM_ERROR (-4) + 'buffer error', // Z_BUF_ERROR (-5) + 'incompatible version', // Z_VERSION_ERROR (-6) + '' + ); + + ZLevels: array [TZCompressionLevel] of Shortint = ( + Z_NO_COMPRESSION, + Z_BEST_SPEED, + Z_DEFAULT_COMPRESSION, + Z_BEST_COMPRESSION + ); + + SZInvalid = 'Invalid ZStream operation!'; + +{** deflate routines ********************************************************} + +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; + recsize: Integer): Integer; external; + + + function DeflateInit2_(var stream: TZStreamRec; level, method, windowBits, + memLevel, strategy: Integer;version: PChar; + recsize: Integer): Integer;external; + + + function InflateInit2_(var stream: TZStreamRec; windowBits: Integer;version: PChar; + recsize: Integer): Integer;external; + +function deflate(var strm: TZStreamRec; flush: Integer): Integer; + external; + +function deflateEnd(var strm: TZStreamRec): Integer; external; + +{** inflate routines ********************************************************} + +function inflateInit_(var strm: TZStreamRec; version: PChar; + recsize: Integer): Integer; external; + +function inflate(var strm: TZStreamRec; flush: Integer): Integer; + external; + +function inflateEnd(var strm: TZStreamRec): Integer; external; + +function inflateReset(var strm: TZStreamRec): Integer; external; + +{** zlib function implementations *******************************************} + +function zcalloc(opaque: Pointer; items, size: Integer): Pointer; +begin + GetMem(result,items * size); +end; + +procedure zcfree(opaque, block: Pointer); +begin + FreeMem(block); +end; + +{** c function implementations **********************************************} + +procedure _memset(p: Pointer; b: Byte; count: Integer); cdecl; +begin + FillChar(p^,count,b); +end; + +procedure _memcpy(dest, source: Pointer; count: Integer); cdecl; +begin + Move(source^,dest^,count); +end; + +{** custom zlib routines ****************************************************} + +function DeflateInit(var stream: TZStreamRec; level: Integer): Integer; +begin + result := DeflateInit_(stream,level,ZLIB_VERSION,SizeOf(TZStreamRec)); +end; + + function DeflateInit2(var stream: TZStreamRec; level, method, windowBits, + memLevel, strategy: Integer): Integer; + begin + result := DeflateInit2_(stream,level,method,windowBits,memLevel, + strategy,ZLIB_VERSION,SizeOf(TZStreamRec)); + end; + +(*function gzopen (path:string; mode:string; flags:longint) : gzFile; +var + + i : longint; + err : int; + level : int; { compression level } + strategy : int; { compression strategy } + s : gz_streamp; +{$IFDEF MSDOS} + attr : word; { file attributes } +{$ENDIF} + +{$IFNDEF NO_DEFLATE} + gzheader : array [0..9] of byte; +{$ENDIF} + +begin + + if (path='') or (mode='') then begin + gzopen := Z_NULL; + exit; + end; + + GetMem (s,sizeof(gz_stream)); + if not Assigned (s) then begin + gzopen := Z_NULL; + exit; + end; + + level := Z_DEFAULT_COMPRESSION; + strategy := Z_DEFAULT_STRATEGY; + + s^.stream.zalloc := NIL; { (alloc_func)0 } + s^.stream.zfree := NIL; { (free_func)0 } + s^.stream.opaque := NIL; { (voidpf)0 } + s^.stream.next_in := Z_NULL; + s^.stream.next_out := Z_NULL; + s^.stream.avail_in := 0; + s^.stream.avail_out := 0; + s^.z_err := Z_OK; + s^.z_eof := false; + s^.inbuf := Z_NULL; + s^.outbuf := Z_NULL; + s^.crc := crc32(0, Z_NULL, 0); + s^.msg := ''; + s^.transparent := false; + + s^.path := path; { limit to 255 chars } + + s^.mode := chr(0); + for i:=1 to Length(mode) do begin + case mode[i] of + 'r' : s^.mode := 'r'; + 'w' : s^.mode := 'w'; + '0'..'9' : level := Ord(mode[i])-Ord('0'); + 'f' : strategy := Z_FILTERED; + 'h' : strategy := Z_HUFFMAN_ONLY; + end; + end; + if (s^.mode=chr(0)) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + + if (s^.mode='w') then begin +{$IFDEF NO_DEFLATE} + err := Z_STREAM_ERROR; +{$ELSE} + err := deflateInit2 (s^.stream, level, Z_DEFLATED, -MAX_WBITS, + DEF_MEM_LEVEL, strategy); + { windowBits is passed < 0 to suppress zlib header } + + GetMem (s^.outbuf, Z_BUFSIZE); + s^.stream.next_out := s^.outbuf; +{$ENDIF} + if (err <> Z_OK) or (s^.outbuf = Z_NULL) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + end + + else begin + GetMem (s^.inbuf, Z_BUFSIZE); + s^.stream.next_in := s^.inbuf; + + err := inflateInit2_ (s^.stream, -MAX_WBITS, ZLIB_VERSION, sizeof(z_stream)); + { windowBits is passed < 0 to tell that there is no zlib header } + + if (err <> Z_OK) or (s^.inbuf = Z_NULL) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + end; + + s^.stream.avail_out := Z_BUFSIZE; + + {$IFOPT I+} {$I-} {$define IOcheck} {$ENDIF} + Assign (s^.gzfile, s^.path); + {$ifdef MSDOS} + GetFAttr(s^.gzfile, Attr); + if (DosError <> 0) and (s^.mode='w') then + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$else} + if {(not FileExists(s^.path)) and} (s^.mode='w') then + // Vincent: changed IF because I don't want old data behind my + // new made .gz-file + ReWrite (s^.gzfile,1) + else + Reset (s^.gzfile,1); + {$endif} + {$IFDEF IOCheck} {$I+} {$ENDIF} + if (IOResult <> 0) then begin + destroy(s); + gzopen := gzFile(Z_NULL); + exit; + end; + + if (s^.mode = 'w') then begin { Write a very simple .gz header } +{$IFNDEF NO_DEFLATE} + gzheader [0] := gz_magic [0]; + gzheader [1] := gz_magic [1]; + gzheader [2] := Z_DEFLATED; { method } + gzheader [3] := flags; { flags } + gzheader [4] := 0; { time[0] } + gzheader [5] := 0; { time[1] } + gzheader [6] := 0; { time[2] } + gzheader [7] := 0; { time[3] } + gzheader [8] := 0; { xflags } + gzheader [9] := 0; { OS code = MS-DOS } + blockwrite (s^.gzfile, gzheader, 10); + s^.startpos := LONG(10); +{$ENDIF} + end + else begin + check_header(s); { skip the .gz header } + {$WARNINGS OFF} { combining signed and unsigned types } + s^.startpos := FilePos(s^.gzfile) - s^.stream.avail_in; + {$WARNINGS ON} + end; + + gzopen := gzFile(s); +end;*) + + +function InflateInit(var stream: TZStreamRec): Integer; +begin + result := InflateInit_(stream,ZLIB_VERSION,SizeOf(TZStreamRec)); +end; + + function InflateInit2(var stream: TZStreamRec; windowBits: Integer): Integer; + begin + result := InflateInit2_(stream,windowBits,ZLIB_VERSION,SizeOf(TZStreamRec)); + end; + +{****************************************************************************} + +function ZCompressCheck(code: Integer): Integer; +begin + result := code; + + if code < 0 then + begin + raise EZCompressionError.Create(_z_errmsg[2 - code]); + end; +end; + +function ZDecompressCheck(code: Integer): Integer; +begin + Result := code; + + if code < 0 then + begin + raise EZDecompressionError.Create(_z_errmsg[2 - code]); + end; +end; + +procedure ZCompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; + level: TZCompressionLevel); +const + delta = 256; +var + zstream: TZStreamRec; +begin + FillChar(zstream,SizeOf(TZStreamRec),0); + + outSize := ((inSize + (inSize div 10) + 12) + 255) and not 255; + GetMem(outBuffer,outSize); + + try + zstream.next_in := inBuffer; + zstream.avail_in := inSize; + zstream.next_out := outBuffer; + zstream.avail_out := outSize; + + ZCompressCheck(DeflateInit(zstream,ZLevels[level])); + + try + while ZCompressCheck(deflate(zstream,Z_FINISH)) <> Z_STREAM_END do + begin + Inc(outSize,delta); + ReallocMem(outBuffer,outSize); + + zstream.next_out := PChar(Integer(outBuffer) + zstream.total_out); + zstream.avail_out := delta; + end; + finally + ZCompressCheck(deflateEnd(zstream)); + end; + + ReallocMem(outBuffer,zstream.total_out); + outSize := zstream.total_out; + except + FreeMem(outBuffer); + raise; + end; +end; + +procedure ZDecompress(const inBuffer: Pointer; inSize: Integer; + out outBuffer: Pointer; out outSize: Integer; outEstimate: Integer); +var + zstream: TZStreamRec; + delta : Integer; +begin + FillChar(zstream,SizeOf(TZStreamRec),0); + + delta := (inSize + 255) and not 255; + + if outEstimate = 0 then outSize := delta + else outSize := outEstimate; + + GetMem(outBuffer,outSize); + + try + zstream.next_in := inBuffer; + zstream.avail_in := inSize; + zstream.next_out := outBuffer; + zstream.avail_out := outSize; + + ZDecompressCheck(InflateInit(zstream)); + + try + while ZDecompressCheck(inflate(zstream,Z_NO_FLUSH)) <> Z_STREAM_END do + begin + Inc(outSize,delta); + ReallocMem(outBuffer,outSize); + + zstream.next_out := PChar(Integer(outBuffer) + zstream.total_out); + zstream.avail_out := delta; + end; + finally + ZDecompressCheck(inflateEnd(zstream)); + end; + + ReallocMem(outBuffer,zstream.total_out); + outSize := zstream.total_out; + except + FreeMem(outBuffer); + raise; + end; +end; + +function ZCompressStr(const s: String; level: TZCompressionLevel): String; +var + buffer: Pointer; + size : Integer; +begin + ZCompress(PChar(s),Length(s),buffer,size,level); + + SetLength(result,size); + Move(buffer^,result[1],size); + + FreeMem(buffer); +end; + +function ZDecompressStr(const s: String): String; +var + buffer: Pointer; + size : Integer; +begin + ZDecompress(PChar(s),Length(s),buffer,size,0); + + SetLength(result,size); + Move(buffer^,result[1],size); + + FreeMem(buffer); +end; + +{** TCustomZStream **********************************************************} + +constructor TCustomZStream.Create(stream: TStream); +begin + inherited Create; + + FStream := stream; + FStreamPos := stream.Position; +end; + +procedure TCustomZStream.DoProgress; +begin + if Assigned(FOnProgress) then FOnProgress(Self); +end; + +{** TZCompressionStream *****************************************************} + +constructor TZCompressionStream.Create(dest: TStream; + compressionLevel: TZCompressionLevel); +begin + inherited Create(dest); + + FZStream.next_out := FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + + ZCompressCheck(DeflateInit(FZStream,ZLevels[compressionLevel])); +end; + +destructor TZCompressionStream.Destroy; +begin + FZStream.next_in := Nil; + FZStream.avail_in := 0; + + try + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + while ZCompressCheck(deflate(FZStream,Z_FINISH)) <> Z_STREAM_END do + begin + FStream.WriteBuffer(FBuffer,SizeOf(FBuffer) - FZStream.avail_out); + + FZStream.next_out := FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + end; + + if FZStream.avail_out < SizeOf(FBuffer) then + begin + FStream.WriteBuffer(FBuffer,SizeOf(FBuffer) - FZStream.avail_out); + end; + finally + deflateEnd(FZStream); + end; + + inherited Destroy; +end; + +function TZCompressionStream.Read(var buffer; count: Longint): Longint; +begin + raise EZCompressionError.Create(SZInvalid); +end; + +function TZCompressionStream.Write(const buffer; count: Longint): Longint; +begin + FZStream.next_in := @buffer; + FZStream.avail_in := count; + + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + while FZStream.avail_in > 0 do + begin + ZCompressCheck(deflate(FZStream,Z_NO_FLUSH)); + + if FZStream.avail_out = 0 then + begin + FStream.WriteBuffer(FBuffer,SizeOf(FBuffer)); + + FZStream.next_out := FBuffer; + FZStream.avail_out := SizeOf(FBuffer); + + FStreamPos := FStream.Position; + + DoProgress; + end; + end; + + result := Count; +end; + +function TZCompressionStream.Seek(offset: Longint; origin: Word): Longint; +begin + if (offset = 0) and (origin = soFromCurrent) then + begin + result := FZStream.total_in; + end + else raise EZCompressionError.Create(SZInvalid); +end; + +function TZCompressionStream.GetCompressionRate: Single; +begin + if FZStream.total_in = 0 then result := 0 + else result := (1.0 - (FZStream.total_out / FZStream.total_in)) * 100.0; +end; + +{** TZDecompressionStream ***************************************************} + +constructor TZDecompressionStream.Create(source: TStream); +begin + inherited Create(source); + + FZStream.next_in := FBuffer; + FZStream.avail_in := 0; + + ZDecompressCheck(InflateInit(FZStream)); +end; + +destructor TZDecompressionStream.Destroy; +begin + inflateEnd(FZStream); + + inherited Destroy; +end; + +function TZDecompressionStream.Read(var buffer; count: Longint): Longint; +begin + FZStream.next_out := @buffer; + FZStream.avail_out := count; + + if FStream.Position <> FStreamPos then FStream.Position := FStreamPos; + + while FZStream.avail_out > 0 do + begin + if FZStream.avail_in = 0 then + begin + FZStream.avail_in := FStream.Read(FBuffer,SizeOf(FBuffer)); + + if FZStream.avail_in = 0 then + begin + result := count - FZStream.avail_out; + + Exit; + end; + + FZStream.next_in := FBuffer; + FStreamPos := FStream.Position; + + DoProgress; + end; + + ZDecompressCheck(inflate(FZStream,Z_NO_FLUSH)); + end; + + result := Count; +end; + +function TZDecompressionStream.Write(const Buffer; Count: Longint): Longint; +begin + raise EZDecompressionError.Create(SZInvalid); +end; + +function TZDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; +var + buf: Array [0..4095] of Char; + i : Integer; +begin + if (offset = 0) and (origin = soFromBeginning) then + begin + ZDecompressCheck(inflateReset(FZStream)); + + FZStream.next_in := FBuffer; + FZStream.avail_in := 0; + + FStream.Position := 0; + FStreamPos := 0; + end + else if ((offset >= 0) and (origin = soFromCurrent)) or + (((offset - FZStream.total_out) > 0) and (origin = soFromBeginning)) then + begin + if origin = soFromBeginning then Dec(offset,FZStream.total_out); + + if offset > 0 then + begin + for i := 1 to offset div SizeOf(buf) do ReadBuffer(buf,SizeOf(buf)); + ReadBuffer(buf,offset mod SizeOf(buf)); + end; + end + else raise EZDecompressionError.Create(SZInvalid); + + result := FZStream.total_out; +end; + +end. diff --git a/niftiview7/gzio/tarfile.pas b/niftiview7/gzio/tarfile.pas new file mode 100755 index 0000000..b4a941c --- /dev/null +++ b/niftiview7/gzio/tarfile.pas @@ -0,0 +1,237 @@ +unit tarfile; + +interface + +uses classes, sysutils{, math}; + +const EXP_FILENAME = 0; + EXP_SIZE = 1; + EXP_DATE = 2; + EXP_BODY = 3; + EXP_ERROR = 4; + EXP_EOF = 5; + + SECSIZE = 512; +// SECSPERBLOCK = 120; + BUFSIZE = SECSIZE; // * SECSPERBLOCK; + +type + TBuffer = Array [0..Pred(BUFSIZE)] Of byte; + TDateTime = record + sec : integer; + min : integer; + hour : integer; + day : integer; + month : integer; + year : integer; + end; + + TTarFile = class + private + FTarF : TFileStream; + FExpecting : byte; + FName : string; + FBuffer : TBuffer; + FLen : longint; + FUnreadSec : integer; + function CrackUnixDateTime( UnixDate : longint) : TDateTime; + procedure AdjustFilename( var filename : string); + public + constructor Create( filename : string); + destructor Free; + function EOF : boolean; + function Progress : integer; + function GetNextFilename : string; + function GetNextSize : longint; + function GetNextDate : TDateTime; + function ReadFile( var buffer; maximum : longint) : longint; + Procedure SkipFile; + protected +end; + +implementation + +// ************************************************** +// Private part +// ************************************************** + +function TTarFile.CrackUnixDateTime( UnixDate : longint) : TDateTime; +Const monlen : Array [1..12] Of byte + = (31,28,31,30,31,30,31,31,30,31,30,31); +var dt : TDateTime; +begin + dt.sec := UnixDate mod 60; + UnixDate := UnixDate div 60; + dt.min := UnixDate mod 60; + UnixDate := UnixDate div 60; + dt.hour := UnixDate mod 24; + UnixDate := UnixDate div 24; + + dt.year := 1970; + while ((UnixDate>=365) and (dt.year mod 4 <> 0)) or + ((UnixDate>=366) and (dt.year mod 4 = 0 )) do + begin + if dt.year mod 4 = 0 then UnixDate := UnixDate - 1; + UnixDate := UnixDate - 365; + Inc(dt.year) + end; + + dt.month := 1; + if dt.year mod 4 = 0 then Inc(monlen[2]); + while UnixDate>=monlen[dt.month] do + begin + UnixDate := UnixDate - monlen[dt.month]; + Inc(dt.month) + end; + if dt.year mod 4 = 0 then Dec(monlen[2]); + + dt.day := UnixDate + 1; + + Result := dt +end; + +Procedure TTarFile.AdjustFilename(Var filename : string); + +Const badletter : Set Of char = ['+',' ',':','<','>','|']; +Var i : byte; +Begin { openfile } + For i := Length(filename) DownTo 1 Do + Begin + If filename[i] = '/' Then filename[i] := '\'; + If filename[i] In badletter Then filename[i] := '_'; + End +end; + +// ************************************************** +// Public part +// ************************************************** + +constructor TTarFile.Create( filename : string); +begin + FTarF := TFileStream.Create( filename, fmOpenRead or fmShareDenyWrite); +end; + +destructor TTarFile.Free; +begin + FTarF.Free; +end; + +function TTarFile.EOF : boolean; +begin + EOF := FTarF.Size = FTarF.Position; +end; + +function TTarFile.Progress : integer; +begin + Progress := {Floor}Trunc((FTarF.Position / FTarF.Size) * 100) +end; + +function TTarFile.GetNextFilename : string; +var iread : integer; + i : integer; +begin + FName := ''; + if (not(EOF) and (FExpecting = EXP_FILENAME)) then + begin + iread := FTarF.Read( FBuffer, SECSIZE); + If iread <> SECSIZE Then FExpecting := EXP_ERROR + else begin + i := 0; + While (FBuffer[i] <> 0) And (i < 254) Do + begin + FName := FName + char(FBuffer[i]); + Inc(i); + end; + if i > 0 then + begin + FExpecting := EXP_SIZE; + AdjustFilename( FName) + end + else begin + i := 0; + // Lazy evaluation needed to prvent reading from FBuffer[SECSIZE] + while (i < SECSIZE) and (FBuffer[i]=0) do Inc(i); + if i < SECSIZE then + FExpecting := EXP_FILENAME + else begin + FExpecting := EXP_EOF; + FTarF.Position := FTarF.Size + end + end + end + end; + Result := FName; +end; + +function TTarFile.GetNextSize : longint; +var i : byte; +begin + FLen := 0; + GetNextSize := 0; + if (not(EOF) and (FExpecting = EXP_SIZE)) then + begin + For i := $7C To $86 Do + If (FBuffer[i] >= 48) And (FBuffer[i] <= 55) Then + FLen := 8*FLen + FBuffer[i] - 48; + if FLen > 0 then + FExpecting := EXP_DATE + else + FExpecting := EXP_FILENAME; + + GetNextSize := FLen + end; + FUnreadSec := (SECSIZE - (FLen mod SECSIZE)) mod SECSIZE +end; + +function TTarFile.GetNextDate : TDateTime; +var UnixDate : longint; + i : byte; +begin + UnixDate := 0; + if FExpecting = EXP_DATE then + begin + For i := $88 To $92 Do + If (FBuffer[i] >= 48) And (FBuffer[i] <= 55) Then + UnixDate := 8*UnixDate + FBuffer[i] - 48; + + FExpecting := EXP_BODY + end; + Result := CrackUnixDateTime( UnixDate) +end; +function min(A,B: longint): longint; +begin +if A < B then result := A +else result := B; +end; +function TTarFile.ReadFile( var buffer; maximum : longint) : longint; +var iread : longint; + buff : TBuffer; +begin + iread := 0; + if (FLen > FTarF.Size - FTarF.Position) or + (FExpecting <> EXP_BODY) + then FExpecting := EXP_ERROR + else begin + iread := FTarF.Read( buffer, min(maximum,FLen)); + FLen := FLen - iread; + if FLen = 0 then + begin + FExpecting := EXP_FILENAME; + if FUnreadSec > 0 then FTarF.Read( buff, FUnreadSec) + end + end; + ReadFile := iread +end; + +procedure TTarFile.SkipFile; +begin + if (FLen > FTarF.Size - FTarF.Position) or + (FExpecting <> EXP_BODY) + then FExpecting := EXP_ERROR + else begin + FTarF.Position := FTarF.Position + FLen + FUnreadSec; + FExpecting := EXP_FILENAME + end +end; + +end. diff --git a/niftiview7/gzio/utils.pas b/niftiview7/gzio/utils.pas new file mode 100755 index 0000000..a3a19ad --- /dev/null +++ b/niftiview7/gzio/utils.pas @@ -0,0 +1,59 @@ +unit utils; + +interface + +const VERSION = '0.2.99'; + BUFLEN = 16384; + +type + TUtils = class + private + { Private declarations } + protected + { Protected declarations } + public + { Public declarations } + function HexToStr(w : longint) : string; + function CreateAboutMsg(componentName : string) : string; + published + { Published declarations } + end; + +implementation + +function TUtils.HexToStr(w : longint) : string; +const + ByteToChar : array[0..$F] of char ='0123456789ABCDEF'; +var s : string; + i : integer; + x : longint; +begin + s := ''; + x := w; + for i := 0 to 3 do + begin + s := ByteToChar[Byte(x) shr 4] + ByteToChar[Byte(x) and $F] + s; + x := x shr 8; + end; + HexToStr := s; +end; + +function TUtils.CreateAboutMsg(componentName : string) : string; +const CR = chr(13); +var Msg : string; +begin + Msg := componentName+' component '+version+CR+CR; + Msg:=Msg+'Copyright © 2000 Vincent Nikkelen.'+CR+CR; + Msg:=Msg+'Do not thank me for this component, please'+CR; + Msg:=Msg+'thank Jean-loup Gailly and Mark Adler for'+CR; + Msg:=Msg+'the zlib-library and Jacques Nomssi Nzali'+CR; + Msg:=Msg+'for the Pascal translation.'+CR+CR; + Msg:=Msg+'Pleas read the README.TXT that comes with'+CR; + Msg:=Msg+'this component.'+CR+CR; + Msg:=Msg+'http://www.cdrom.com/pub/infozip/zlib/'+CR; + Msg:=Msg+'http://www.tu-chemnitz.de/~nomssi/paszlib.html'+CR; + Msg:=Msg+'http://www.stack.nl/~vincentn/delphizlib/'; + CreateAboutMsg := Msg +end; + +end. diff --git a/niftiview7/gzio/zutil.pas b/niftiview7/gzio/zutil.pas new file mode 100755 index 0000000..cd44dd2 --- /dev/null +++ b/niftiview7/gzio/zutil.pas @@ -0,0 +1,546 @@ +Unit ZUtil; + +{ + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I zconf.inc} + +{ Type declarations } + +type + {Byte = usigned char; 8 bits} + Bytef = byte; + charf = byte; + +{$IFDEF FPC} + int = longint; +{$ELSE} + int = integer; +{$ENDIF} + + intf = int; +{$IFDEF MSDOS} + uInt = Word; +{$ELSE} + {$IFDEF FPC} + uInt = longint; { 16 bits or more } + {$INFO Cardinal} + {$ELSE} + uInt = cardinal; { 16 bits or more } + {$ENDIF} +{$ENDIF} + uIntf = uInt; + + Long = longint; +{$ifdef Delphi5} + uLong = Cardinal; +{$else} +// uLong = LongInt; { 32 bits or more } + uLong = LongInt{LongWord}; { DelphiGzip: LongInt is Signed, longword not } +{$endif} + uLongf = uLong; + + voidp = pointer; + voidpf = voidp; + pBytef = ^Bytef; + pIntf = ^intf; + puIntf = ^uIntf; + puLong = ^uLongf; + + ptr2int = uInt; +{ a pointer to integer casting is used to do pointer arithmetic. + ptr2int must be an integer type and sizeof(ptr2int) must be less + than sizeof(pointer) - Nomssi } + +const + {$IFDEF MAXSEG_64K} + MaxMemBlock = $FFFF; + {$ELSE} + MaxMemBlock = MaxInt; + {$ENDIF} + +type + zByteArray = array[0..(MaxMemBlock div SizeOf(Bytef))-1] of Bytef; + pzByteArray = ^zByteArray; +type + zIntfArray = array[0..(MaxMemBlock div SizeOf(Intf))-1] of Intf; + pzIntfArray = ^zIntfArray; +type + zuIntArray = array[0..(MaxMemBlock div SizeOf(uInt))-1] of uInt; + PuIntArray = ^zuIntArray; + +{ Type declarations - only for deflate } + +type + uch = Byte; + uchf = uch; { FAR } + ush = Word; + ushf = ush; + ulg = LongInt; + + unsigned = uInt; + + pcharf = ^charf; + puchf = ^uchf; + pushf = ^ushf; + +type + zuchfArray = zByteArray; + puchfArray = ^zuchfArray; +type + zushfArray = array[0..(MaxMemBlock div SizeOf(ushf))-1] of ushf; + pushfArray = ^zushfArray; + +procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt); +function zmemcmp(s1p, s2p : pBytef; len : uInt) : int; +procedure zmemzero(destp : pBytef; len : uInt); +procedure zcfree(opaque : voidpf; ptr : voidpf); +function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf; + +implementation + +{$ifdef ver80} + {$define Delphi16} +{$endif} +{$ifdef ver70} + {$define HugeMem} +{$endif} +{$ifdef ver60} + {$define HugeMem} +{$endif} + +{$IFDEF CALLDOS} +uses + WinDos; +{$ENDIF} +{$IFDEF Delphi16} +uses + WinTypes, + WinProcs; +{$ENDIF} +{$IFNDEF FPC} + {$IFDEF DPMI} + uses + WinAPI; + {$ENDIF} +{$ENDIF} + +{$IFDEF CALLDOS} +{ reduce your application memory footprint with $M before using this } +function dosAlloc (Size : Longint) : Pointer; +var + regs: TRegisters; +begin + regs.bx := (Size + 15) div 16; { number of 16-bytes-paragraphs } + regs.ah := $48; { Allocate memory block } + msdos(regs); + if regs.Flags and FCarry <> 0 then + DosAlloc := NIL + else + DosAlloc := Ptr(regs.ax, 0); +end; + + +function dosFree(P : pointer) : boolean; +var + regs: TRegisters; +begin + dosFree := FALSE; + regs.bx := Seg(P^); { segment } + if Ofs(P) <> 0 then + exit; + regs.ah := $49; { Free memory block } + msdos(regs); + dosFree := (regs.Flags and FCarry = 0); +end; +{$ENDIF} + +type + LH = record + L, H : word; + end; + +{$IFDEF HugeMem} + {$define HEAP_LIST} +{$endif} + +{$IFDEF HEAP_LIST} {--- to avoid Mark and Release --- } +const + MaxAllocEntries = 50; +type + TMemRec = record + orgvalue, + value : pointer; + size: longint; + end; +const + allocatedCount : 0..MaxAllocEntries = 0; +var + allocatedList : array[0..MaxAllocEntries-1] of TMemRec; + + function NewAllocation(ptr0, ptr : pointer; memsize : longint) : boolean; + begin + if (allocatedCount < MaxAllocEntries) and (ptr0 <> NIL) then + begin + with allocatedList[allocatedCount] do + begin + orgvalue := ptr0; + value := ptr; + size := memsize; + end; + Inc(allocatedCount); { we don't check for duplicate } + NewAllocation := TRUE; + end + else + NewAllocation := FALSE; + end; +{$ENDIF} + +{$IFDEF HugeMem} + +{ The code below is extremely version specific to the TP 6/7 heap manager!!} +type + PFreeRec = ^TFreeRec; + TFreeRec = record + next: PFreeRec; + size: Pointer; + end; +type + HugePtr = voidpf; + + + procedure IncPtr(var p:pointer;count:word); + { Increments pointer } + begin + inc(LH(p).L,count); + if LH(p).L < count then + inc(LH(p).H,SelectorInc); { $1000 } + end; + + procedure DecPtr(var p:pointer;count:word); + { decrements pointer } + begin + if count > LH(p).L then + dec(LH(p).H,SelectorInc); + dec(LH(p).L,Count); + end; + + procedure IncPtrLong(var p:pointer;count:longint); + { Increments pointer; assumes count > 0 } + begin + inc(LH(p).H,SelectorInc*LH(count).H); + inc(LH(p).L,LH(Count).L); + if LH(p).L < LH(count).L then + inc(LH(p).H,SelectorInc); + end; + + procedure DecPtrLong(var p:pointer;count:longint); + { Decrements pointer; assumes count > 0 } + begin + if LH(count).L > LH(p).L then + dec(LH(p).H,SelectorInc); + dec(LH(p).L,LH(Count).L); + dec(LH(p).H,SelectorInc*LH(Count).H); + end; + { The next section is for real mode only } + +function Normalized(p : pointer) : pointer; +var + count : word; +begin + count := LH(p).L and $FFF0; + Normalized := Ptr(LH(p).H + (count shr 4), LH(p).L and $F); +end; + +procedure FreeHuge(var p:HugePtr; size : longint); +const + blocksize = $FFF0; +var + block : word; +begin + while size > 0 do + begin + { block := minimum(size, blocksize); } + if size > blocksize then + block := blocksize + else + block := size; + + dec(size,block); + freemem(p,block); + IncPtr(p,block); { we may get ptr($xxxx, $fff8) and 31 bytes left } + p := Normalized(p); { to free, so we must normalize } + end; +end; + +function FreeMemHuge(ptr : pointer) : boolean; +var + i : integer; { -1..MaxAllocEntries } +begin + FreeMemHuge := FALSE; + i := allocatedCount - 1; + while (i >= 0) do + begin + if (ptr = allocatedList[i].value) then + begin + with allocatedList[i] do + FreeHuge(orgvalue, size); + + Move(allocatedList[i+1], allocatedList[i], + SizeOf(TMemRec)*(allocatedCount - 1 - i)); + Dec(allocatedCount); + FreeMemHuge := TRUE; + break; + end; + Dec(i); + end; +end; + +procedure GetMemHuge(var p:HugePtr;memsize:Longint); +const + blocksize = $FFF0; +var + size : longint; + prev,free : PFreeRec; + save,temp : pointer; + block : word; +begin + p := NIL; + { Handle the easy cases first } + if memsize > maxavail then + exit + else + if memsize <= blocksize then + begin + getmem(p, memsize); + if not NewAllocation(p, p, memsize) then + begin + FreeMem(p, memsize); + p := NIL; + end; + end + else + begin + size := memsize + 15; + + { Find the block that has enough space } + prev := PFreeRec(@freeList); + free := prev^.next; + while (free <> heapptr) and (ptr2int(free^.size) < size) do + begin + prev := free; + free := prev^.next; + end; + + { Now free points to a region with enough space; make it the first one and + multiple allocations will be contiguous. } + + save := freelist; + freelist := free; + { In TP 6, this works; check against other heap managers } + while size > 0 do + begin + { block := minimum(size, blocksize); } + if size > blocksize then + block := blocksize + else + block := size; + dec(size,block); + getmem(temp,block); + end; + + { We've got what we want now; just sort things out and restore the + free list to normal } + + p := free; + if prev^.next <> freelist then + begin + prev^.next := freelist; + freelist := save; + end; + + if (p <> NIL) then + begin + { return pointer with 0 offset } + temp := p; + if Ofs(p^)<>0 Then + p := Ptr(Seg(p^)+1,0); { hack } + if not NewAllocation(temp, p, memsize + 15) then + begin + FreeHuge(temp, size); + p := NIL; + end; + end; + + end; +end; + +{$ENDIF} + +procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt); +begin + Move(sourcep^, destp^, len); +end; + +function zmemcmp(s1p, s2p : pBytef; len : uInt) : int; +var + j : uInt; + source, + dest : pBytef; +begin + source := s1p; + dest := s2p; + for j := 0 to pred(len) do + begin + if (source^ <> dest^) then + begin + zmemcmp := 2*Ord(source^ > dest^)-1; + exit; + end; + Inc(source); + Inc(dest); + end; + zmemcmp := 0; +end; + +procedure zmemzero(destp : pBytef; len : uInt); +begin + FillChar(destp^, len, 0); +end; + +procedure zcfree(opaque : voidpf; ptr : voidpf); +{$ifdef Delphi16} +var + Handle : THandle; +{$endif} +{$IFDEF FPC} +var + memsize : uint; +{$ENDIF} +begin + {$IFDEF DPMI} + {h :=} GlobalFreePtr(ptr); + {$ELSE} + {$IFDEF CALL_DOS} + dosFree(ptr); + {$ELSE} + {$ifdef HugeMem} + FreeMemHuge(ptr); + {$else} + {$ifdef Delphi16} + Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) } + GlobalUnLock(Handle); + GlobalFree(Handle); + {$else} + {$IFDEF FPC} + Dec(puIntf(ptr)); + memsize := puIntf(ptr)^; + FreeMem(ptr, memsize+SizeOf(uInt)); + {$ELSE} + FreeMem(ptr); { Delphi 2,3,4 } + {$ENDIF} + {$endif} + {$endif} + {$ENDIF} + {$ENDIF} +end; + +function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf; +var + p : voidpf; + memsize : uLong; +{$ifdef Delphi16} + handle : THandle; +{$endif} +begin + memsize := uLong(items) * size; + {$IFDEF DPMI} + p := GlobalAllocPtr(gmem_moveable, memsize); + {$ELSE} + {$IFDEF CALLDOS} + p := dosAlloc(memsize); + {$ELSE} + {$ifdef HugeMem} + GetMemHuge(p, memsize); + {$else} + {$ifdef Delphi16} + Handle := GlobalAlloc(HeapAllocFlags, memsize); + p := GlobalLock(Handle); + {$else} + {$IFDEF FPC} + GetMem(p, memsize+SizeOf(uInt)); + puIntf(p)^:= memsize; + Inc(puIntf(p)); + {$ELSE} + GetMem(p, memsize); { Delphi: p := AllocMem(memsize); } + {$ENDIF} + {$endif} + {$endif} + {$ENDIF} + {$ENDIF} + zcalloc := p; +end; + +{$WARNINGS OFF} +end. + +{ edited from a SWAG posting: + +In Turbo Pascal 6, the heap is the memory allocated when using the Procedures 'New' and +'GetMem'. The heap starts at the address location pointed to by 'Heaporg' and +grows to higher addresses as more memory is allocated. The top of the heap, +the first address of allocatable memory space above the allocated memory +space, is pointed to by 'HeapPtr'. + +Memory is deallocated by the Procedures 'Dispose' and 'FreeMem'. As memory +blocks are deallocated more memory becomes available, but..... When a block +of memory, which is not the top-most block in the heap is deallocated, a gap +in the heap will appear. to keep track of these gaps Turbo Pascal maintains +a so called free list. + +The Function 'MaxAvail' holds the size of the largest contiguous free block +_in_ the heap. The Function 'MemAvail' holds the sum of all free blocks in +the heap. + +TP6.0 keeps track of the free blocks by writing a 'free list Record' to the +first eight Bytes of the freed memory block! A (TP6.0) free-list Record +contains two four Byte Pointers of which the first one points to the next +free memory block, the second Pointer is not a Real Pointer but contains the +size of the memory block. + +Summary + +TP6.0 maintains a linked list with block sizes and Pointers to the _next_ +free block. An extra heap Variable 'Heapend' designate the end of the heap. +When 'HeapPtr' and 'FreeList' have the same value, the free list is empty. + + + TP6.0 Heapend + ÚÄÄÄÄÄÄÄÄÄ¿ <ÄÄÄÄ + ³ ³ + ³ ³ + ³ ³ + ³ ³ + ³ ³ + ³ ³ + ³ ³ + ³ ³ HeapPtr + ÚÄ>ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ + ³ ³ ³ + ³ ÃÄÄÄÄÄÄÄÄÄ´ + ÀÄij Free ³ + ÚÄ>ÃÄÄÄÄÄÄÄÄÄ´ + ³ ³ ³ + ³ ÃÄÄÄÄÄÄÄÄÄ´ + ÀÄij Free ³ FreeList + ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ + ³ ³ Heaporg + ÃÄÄÄÄÄÄÄÄÄ´ <ÄÄÄÄ + + +} +{$WARNINGS ON} diff --git a/niftiview7/hires.bmp b/niftiview7/hires.bmp new file mode 100755 index 0000000..8511d99 Binary files /dev/null and b/niftiview7/hires.bmp differ diff --git a/niftiview7/histoform.pas b/niftiview7/histoform.pas new file mode 100755 index 0000000..ef98a3b --- /dev/null +++ b/niftiview7/histoform.pas @@ -0,0 +1,61 @@ +unit histoform; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Menus, ExtCtrls,ClipBrd; + +type + THistogramForm = class(TForm) + HistoPanel: TScrollBox; + HistoImage: TImage; + MainMenu1: TMainMenu; + File1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Saveasbitmap1: TMenuItem; + Closewindow1: TMenuItem; + procedure Copy1Click(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure Saveasbitmap1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + HistogramForm: THistogramForm; + +implementation +{$R *.DFM} +uses nifti_img; + +procedure THistogramForm.Copy1Click(Sender: TObject); +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (HistoImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + HistoImage.Picture.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData) + //HistoImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); +end; + + +procedure THistogramForm.Closewindow1Click(Sender: TObject); +begin + HistogramForm.Close; +end; + +procedure THistogramForm.Saveasbitmap1Click(Sender: TObject); +begin + SaveImgAsPNGBMP (HistoImage); +end; + +end. diff --git a/niftiview7/hrf.pas b/niftiview7/hrf.pas new file mode 100755 index 0000000..e2eead4 --- /dev/null +++ b/niftiview7/hrf.pas @@ -0,0 +1,289 @@ +unit hrf; + +interface +uses + define_types, matrices,metagraph; +const + kHRFdur = 24000; //ms for 'full' HRF - window size for HRF +function CreateHRF (lTRsec: double; var lKernelBins: integer; lDefaultsStatsFmriT: integer; var lHRFra, lTDra: doublep): boolean; + +function ConvolveTimeCourse(var lTimeCourse: PMatrix; var lKernel {,lTimeCoursePreciseOut}: doublep; var l4DTrace: T4DTrace; +lCond,lCondOut,lnVol,lKernelBins,lDefaultsStatsFmriT,lDefaultsStatsFmriT0: integer; + lTRSec: single; lSliceTime: boolean): boolean; +//function OptimalOffset (lSlope,lIntercept: double; lDefaultsStatsFmriT0,lDefaultsStatsFmriT,lnVol: integer; lTimeCourse,lEstTimeCoursePrecise: doublep): double; + + +implementation +uses math {power}, fmath {gamma},sysutils,dialogs; + +const + kHRFkernelSec = 32; + //kDefaultsStatsFmriT = 16; //each TR is supersampled at 16x resolution + + +//from SPM's hrf.m +function spm_Gpdf(x,h,l: double): double; +//emulates spm_Gpdf +begin + result := power(l,h)*power(x,(h-1))* exp(-l*x); + result := result / gamma(h); +end; + +function fHRF (u,dt: double): double; +//emulates spm_hrf.m +const + //TR = 1; + p1= 6; //delay of response + p2=16;//delay of undershoot (relative to onset) + p3=1; //dispersion of response + p4=1; //dispersion of undershoot + p5=6; //ratio of response to undershoot + p7=kHRFkernelSec;//length of kernel (seconds) +begin + if u <= 0 then + result := 0 + else + result := spm_Gpdf(u,p1/p3,dt/p3) - spm_Gpdf(u,p2/p4,dt/p4)/p5; +end; + +function CreateHRF (lTRsec: double; var lKernelBins: integer; lDefaultsStatsFmriT: integer; var lHRFra, lTDra: doublep): boolean; +//NOTE: if this returns TRUE, you MUST freemem lHRFra, lTDra +//returns lHRFra and lTDra with lBins of data - equal to 32sec convolution kernel for +//hemodynamic response (HRF) and the HRF's temporal derivative +var + lDT,lSum,l1sec: double; + lI: integer; +begin + result := false; + if lDefaultsStatsFmriT < 1 then exit; + lDT := (lTRsec / lDefaultsStatsFmriT); //DeltaTime - width of each sample in sec + lKernelBins := round ( kHRFkernelSec / lDT); + if lKernelBins < 1 then + exit; + getmem(lHRFra,lKernelBins*sizeof(double)); + //generate whole HRF kernel + for lI := 1 to lKernelBins do + lHRFra^[lI] := fHRF (lI-1,lDT); + //find sum + lSum := 0; + for lI := 1 to lKernelBins do + lSum := lSum + lHRFra^[lI]; + //normalize - so sum = 1 + for lI := 1 to lKernelBins do + lHRFra^[lI] := lHRFra^[lI]/lsum; + //next temporal derivative + getmem(ltdra,lKernelBins*sizeof(double)); + l1sec := 1/lDT; + for lI := 1 to lKernelBins do + ltdra^[lI] := fHRF((lI-1)-l1sec,lDT); //tdHRF (lI-1,lDT); + //find sum + lSum := 0; + for lI := 1 to lKernelBins do + lSum := lSum + ltdra^[lI]; + //normalize - so sum = 1 + for lI := 1 to lKernelBins do + ltdra^[lI] := ltdra^[lI]/lsum; + //temporal derivative is difference between normalized TD and normalized HRF + for lI := 1 to lKernelBins do + ltdra^[lI] := lHRFra^[lI]- ltdra^[lI]; + result := true; +end; + +function Convolve(var lTimeCoursePrecise,lKernel: doublep; lEventBin,lnVolPrecise,lKernelBins: integer): boolean; +var + lVol,lStart,lEnd: integer; +begin + result := false; + if (lEventBin > lnVolPrecise) then exit; //event too late to influence timecourse + if ((lEventBin+lKernelBins)< 1) then exit;//event too early to influence timecourse + lStart := lEventBin; + if lStart < 1 then + lStart := 1; + lEnd := (lEventBin+lKernelBins-1); + if lEnd > lnVolPrecise then + lEnd := lnVolPrecise; + //lOffset := lEventBin; + for lVol := lStart to lEnd do begin + lTimeCoursePrecise^[lVol] := lTimeCoursePrecise^[lVol] + lKernel^[lVol -lEventBin+1]; + end; + result := true; +end; + +(*procedure SampleTimeCourse (lOffset,lDefaultsStatsFmriT0,lDefaultsStatsFmriT,lnVol: integer; lTimeCourse,lTimeCoursePrecise: doublep); +var + lVol,lVolx,lnVolPrecise: integer; +begin + lVolx := lDefaultsStatsFmriT0+lOffset; + lnVolPrecise := lnVol * lDefaultsStatsFmriT; + for lVol := 1 to lnVol do begin + if (lVolx > 0) and (lVolx < lnVolPrecise) then + lTimeCourse^[lVol] := lTimeCoursePrecise^[lVolx] + else begin + lTimeCourse^[lVol] := 0; + end; + inc(lVolx,lDefaultsStatsFmriT); + end; +end; //proc SampleTimeCourse + + +procedure OutCSV (lTimeCourse: DoubleP; lIndex,lnVol: integer); +var + lVol: integer; + lF: TextFile; + lStr: string; +begin + lStr := 'C:\shitz'+inttostr(lIndex)+'.csv'; + AssignFile(lF, lStr); + if fileexists(lStr) then + Append(lF) + else + Rewrite(lF); + lStr := ''; + for lVol := 1 to lnVol do + lStr := lStr+floattostr(lTimeCourse^[lVol])+','; + lStr := lStr + '666'; + writeln(lF,lStr); + CloseFile(lF); +end; + + +function MeanDiffSqr(lOffset,lnVol:integer;lTimeCourse,lEstTimeCourse: doublep): double; +var + lSqr: double; + lVol,lOffsetAbs: integer; +begin + result := 0; + lOffsetAbs := abs(lOffset); + if (2*lOffsetAbs) >= lnVol then + exit; + lSqr := 0; + + for lvol := (lOffsetAbs+1) to (lnvol-lOffsetAbs) do + lSqr := lSqr + Sqr(lTimeCourse^[lVol]-lEstTimeCourse^[lVol]); + result := lSqr / (lnvol - (2*lOffsetAbs) ); +end; + +function OptimalOffset (lSlope,lIntercept: double; lDefaultsStatsFmriT0,lDefaultsStatsFmriT,lnVol: integer; lTimeCourse,lEstTimeCoursePrecise: doublep): double; +//estimate number of bins adjustment required for best fit of model... +var + lMinDiff,lDiff: double; + lR, + lSearchSize,lStepSize,lMinOffset,lOffset,lOffsetDir,lVol: integer; + lEstTimeCourse: doublep; +begin + lR:= random(111); + //lMaxSteps := lDefaultsStatsFmriT * 4; + lStepSize := lDefaultsStatsFmriT div 2; + lSearchSize := lStepSize * 4; //4 TRs + + if lStepSize < 1 then + lStepSize :=1; + result := 0; + if (lnVol < 1) or (lSearchSize < 1) or (lSlope = 0) then exit; + for lVol := 1 to (lnVol * lDefaultsStatsFmriT) do + lEstTimeCoursePrecise^[lVol] := (lEstTimeCoursePrecise^[lVol] * lSlope)+lIntercept; + //compute + getmem(lEstTimeCourse,lnVol * sizeof(double)); + lOffset := 0; + SampleTimeCourse (lOffset,lDefaultsStatsFmriT0,lDefaultsStatsFmriT,lnVol,lEstTimeCourse,lEstTimeCoursePrecise); + lDiff := MeanDiffSqr(lSearchSize{lOffset},lnVol,lTimeCourse,lEstTimeCourse); + lMinOffset := 0; + lMinDiff := lDiff; //assume zero is best outcome... + //first pass - search by 0.5 TR increments for best fit.... + OutCSV(lTimeCourse,lR,lnVol); + lOffset := -lSearchSize; + while lOffset <= lSearchSize do begin + SampleTimeCourse (lOffset,lDefaultsStatsFmriT0,lDefaultsStatsFmriT,lnVol,lEstTimeCourse,lEstTimeCoursePrecise); + lDiff := MeanDiffSqr(lSearchSize{lOffset},lnVol,lTimeCourse,lEstTimeCourse); + OutCSV(lEstTimeCourse,lR,lnVol); + if lDiff < lMinDiff then begin + lMinOffset := lOffset; + lMinDiff := lDiff; + end; + lOffset := lOffset + lStepSize; + end; + + //second pass - search by smallest possible increments... + lSearchSize := lStepSize; //0.5TR + lOffset := lMinOffset-lSearchSize; //search within this TR's region + lSearchSize := lMinOffset+lSearchSize; + lStepSize := 1; + SampleTimeCourse (lMinOffset,lDefaultsStatsFmriT0,lDefaultsStatsFmriT,lnVol,lEstTimeCourse,lEstTimeCoursePrecise); + lDiff := MeanDiffSqr(lSearchSize{lOffset},lnVol,lTimeCourse,lEstTimeCourse); + + while lOffset <= lSearchSize do begin + //fx(lOffset,lMinOffset); + SampleTimeCourse (lOffset,lDefaultsStatsFmriT0,lDefaultsStatsFmriT,lnVol,lEstTimeCourse,lEstTimeCoursePrecise); + lDiff := MeanDiffSqr({lOffset}lSearchSize,lnVol,lTimeCourse,lEstTimeCourse); + if lDiff < lMinDiff then begin + lMinOffset := lOffset; + lMinDiff := lDiff; + end; + lOffset := lOffset + lStepSize; + end; + result := lMinOffset; + freemem(lEstTimeCourse); +end; //proc OptimalOffset +*) + + + +function ConvolveTimeCourse(var lTimeCourse: PMatrix; var lKernel {,lTimeCoursePreciseOut}: doublep; var l4DTrace: T4DTrace; lCond,lCondOut, lnVol,lKernelBins,lDefaultsStatsFmriT,lDefaultsStatsFmriT0: integer; + lTRSec: single; lSliceTime: boolean): boolean; +var + lnVolPrecise,lEvent,lVol,lVolx,lEventBin,lEventEnd: integer; + lDT: double; + lTimeCoursePrecise: doublep;//supersampled by kDefaultsStatsFmriT + lAllEvents: boolean; +begin + result := false; + if (l4DTrace.Conditions[lCond].Events < 1) or (lnVol < 1) or (lTRSec <= 0) then exit; + lnVolPrecise := lnVol * lDefaultsStatsFmriT; + getmem(lTimeCoursePrecise,lnVolPrecise * sizeof(double)); + for lVol := 1 to lnVolPrecise do + lTimeCoursePrecise^[lVol] := 0; + lDT := (lTRsec / lDefaultsStatsFmriT); //DeltaTime - width of each sample in sec + //spm_fmri_design + //X is supersampled at 16 times (fMRI_T) the number of volumes - with (32 bin offset) + //k = SPM.nscan(s); + //X = X([0:(k - 1)]*fMRI_T + fMRI_T0 + 32,:); + for lEvent := 1 to l4DTrace.Conditions[lCond].Events do begin + lEventBin := round((l4DTrace.Conditions[lCond].EventRA[lEvent])/lDT); + //incorrect: same dur will have different number of bins due to rounding: + //lEventEnd := round((l4DTrace.Conditions[lCond].EventRA^[lEvent]+l4DTrace.Conditions[lCond].DurRA^[lEvent])/lDT); + //correct: all stimuli of same duration will have identical number of bins + lEventEnd := lEventBin+round(l4DTrace.Conditions[lCond].DurRA^[lEvent]/lDT); + //if lEvent = 1 then fx(lEventBin,lEventEnd,l4DTrace.Conditions[lCond].DurRA^[lEvent]); + repeat + if (lEventBin > 0) and (lEventBin <= lnVolPrecise) then + Convolve(lTimeCoursePrecise,lKernel,lEventBin,lnVolPrecise,lKernelBins); + inc(lEventBin); + until lEventBin > lEventEnd; + end; //for each event + //output - scaled by reciprocal of DT: e.g. if TR=2, DT=0.125, Scale = 8 + //if TR=2.2, DT=0.1375 Scale = 7.2727 + //this linear scaling does not change any effects - it simply clones SPM2 + lAllEvents := true; + for lEvent := 1 to l4DTrace.Conditions[lCond].Events do + if l4DTrace.Conditions[lCond].DurRA^[lEvent] > lDT then + lAllEvents := false; + if lAllEvents then + lDT := 1/lDT + else + lDT := 1; + lVolx := lDefaultsStatsFmriT0; + for lVol := 1 to lnVol do begin + if (lVolx > 0) and (lVolx < lnVolPrecise) then + lTimeCourse^[lCondOut]^[lVol] := lDT * lTimeCoursePrecise^[lVolx]; + inc(lVolx,lDefaultsStatsFmriT); + end; + (*if lTimeCoursePreciseOut <> nil then begin + for lVol := 1 to lnVolPrecise do + lTimeCoursePreciseOut^[lVol] := lTimeCoursePrecise^[lVol]*lDT; + end;*) + freemem(lTimeCoursePrecise); + result := true; +end;//func ConvolveTimeCourse + + +end. diff --git a/niftiview7/ico32.ico b/niftiview7/ico32.ico new file mode 100755 index 0000000..cc925ba Binary files /dev/null and b/niftiview7/ico32.ico differ diff --git a/niftiview7/ico8.ico b/niftiview7/ico8.ico new file mode 100755 index 0000000..ae5b4a4 Binary files /dev/null and b/niftiview7/ico8.ico differ diff --git a/niftiview7/icon48.ico b/niftiview7/icon48.ico new file mode 100755 index 0000000..2c06d7e Binary files /dev/null and b/niftiview7/icon48.ico differ diff --git a/niftiview7/iconfinal.ico b/niftiview7/iconfinal.ico new file mode 100755 index 0000000..14b256a Binary files /dev/null and b/niftiview7/iconfinal.ico differ diff --git a/niftiview7/imgutil.pas b/niftiview7/imgutil.pas new file mode 100755 index 0000000..7ee8457 --- /dev/null +++ b/niftiview7/imgutil.pas @@ -0,0 +1,84 @@ +unit imgutil; +interface + +function UnscaledMean (lOverlayNum: integer): double; +function ScaledMean (lOverlayNum: integer): double; +procedure BatchChangeInterceptSoVOIEqualsZero; + + +implementation +uses text,nifti_hdr,nifti_hdr_view,define_types,nifti_img, nifti_img_view, nifti_types; + + +function UnscaledMean (lOverlayNum: integer): double; +//kVOIOverlayNum +var + lROIVol,lInc: integer; + lROISum: double; +begin //proc ShowDescript + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lROIVol := 0; + lROISum := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then begin + lROISum := lROISum + RawBGIntensity(lInc); + inc(lROIVol); + end; + end; //for each voxel + if lROIVol > 0 then + result := lROISum/lROIVol; +end; + +function ScaledMean (lOverlayNum: integer): double; +begin + result := UnscaledMean(lOverlayNum); + result := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],result); +end; + +procedure BatchChangeInterceptSoVOIEqualsZero; +var + lInc,lNumberofFiles,lMinClusterSz: integer; + lZeroHdr : TNIfTIHdr; + lFilename,lVOIname:string; + lPref: boolean; + lMean: double; +begin + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + + if not OpenDialogExecute(kImgPlusVOIFilter,'Select volume of interest',false) then exit; + lVOIName := HdrForm.OpenHdrDlg.FileName; + if not OpenDialogExecute(kImgFilter,'Select perfusion images',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.MemoT.Lines.Clear; + lPref := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + ImgForm.OpenAndDisplayImg(lFilename,false); + ImgForm.OverlayOpenCore ( lVOIname, kVOIOverlayNum); + lMean := UnscaledMean(kVOIOverlayNum); + lZeroHdr := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr; + if lZeroHdr.scl_slope <> 1 then + TextForm.MemoT.Lines.Add(lFilename+' Scale slope is not 1, please contact Chris Rorden ') + else if lMean <> 0 then begin + TextForm.MemoT.Lines.Add(lFilename+kTextSep+realtostr(lMean,5)); + lZeroHdr.scl_inter := lZeroHdr.scl_inter - lMean; + lFilename := changefileprefix(lFilename,'z'); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,lZeroHdr) + end else + TextForm.MemoT.Lines.Add(lFilename+' UNCHANGED (mean of VOI is already zero) '); + + //FindClustersText(gMRIcroOverlay[kBGOverlayNum], lThresh,lMinClusterSz); + end;//lLoop + gBGImg.ResliceOnLoad := lPref; + TextForm.Show; +end; + + +end. diff --git a/niftiview7/info.bmp b/niftiview7/info.bmp new file mode 100755 index 0000000..3f667e7 Binary files /dev/null and b/niftiview7/info.bmp differ diff --git a/niftiview7/landmarks.pas b/niftiview7/landmarks.pas new file mode 100755 index 0000000..6099cd9 --- /dev/null +++ b/niftiview7/landmarks.pas @@ -0,0 +1,413 @@ +unit landmarks; + +interface +{$H+} + + +uses + {$IFDEF Win32} + Windows, Messages, +{$ELSE} + LMessages, LCLType, +{$ENDIF} + {$IFDEF FPC}LResources, {$ENDIF} + SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, Buttons, ToolWin, ComCtrls; + +type + TAnatForm = class(TForm) + ToolBar1: TToolBar; + SaveBtn: TSpeedButton; + AddBtn: TSpeedButton; + AnatDrop: TComboBox; + UpdateBtn: TSpeedButton; + OpenBtn: TSpeedButton; + DeleteBtn: TSpeedButton; + procedure SaveBtnClick(Sender: TObject); + procedure AddBtnClick(Sender: TObject); + procedure AnatDropChange(Sender: TObject); + procedure UpdateCombo; + procedure OpenBtnClick(Sender: TObject); + procedure Update(lIndex: integer); + procedure UpdateBtnClick(Sender: TObject); + procedure DeleteBtnClick(Sender: TObject); + procedure OpenAnat(lFilename: string); + procedure CloseAnat; + procedure ComputeRMS; + procedure AcceptLandmark; + procedure BatchLandmarks; + procedure LoadLandmark; + private + { Private declarations } + public + { Public declarations } + end; + +var + AnatForm: TAnatForm; + +implementation + +uses nifti_img_view, nifti_img, nifti_hdr_view, define_types, Text; + {$IFNDEF FPC} //Delphi +{$R *.dfm} +{$ENDIF} +type + TLandmark = record + Name: string; + X,Y,Z: single; + end; + TLandmarkRA = array of TLandmark; +const +kAnatFilter = 'AnatomyFile|*.anat'; +var + gLandmarks: TLandmarkRA; + gBatchImg,gBatchMark: integer; +// gBatchName: string; + +function BatchName (lImg: integer): string; +begin + result := ChangeFileExt(HdrForm.OpenHdrDlg.Files[lImg-1], '.anat'); //10102006 +end; + +procedure SaveLandmarks (Filename: string); +const + kSep = chr(9); +var + i: integer; + lF: TextFile; +begin + Filemode := 0; + AssignFile(lF,Filename); + rewrite(lF); + for i := 0 to length(gLandmarks)-1 do + Writeln(lF, gLandmarks[i].Name+kSep+floattostr(gLandmarks[i].X)+kSep+floattostr(gLandmarks[i].Y)+kSep+floattostr(gLandmarks[i].Z) ); + CloseFile(lF); +end; + +procedure TAnatForm.LoadLandmark; +var + lI: string; +begin + if (gBatchImg < 1) or (gBatchMark < 1) then exit;//or (gBatchImg > HdrForm.OpenHdrDlg.Files.Count) or (gBatchMark > length(gLandmarks)) then exit; + lI := HdrForm.OpenHdrDlg.Files[gBatchImg-1]; + ImgForm.CloseImagesClick(nil); + ImgForm.OpenAndDisplayImg(lI,True); + OpenAnat(BatchName(gBatchImg)); + AnatDrop.ItemIndex := gBatchMark-1; + ImgForm.Caption := 'Img '+inttostr(gBatchImg)+'/'+inttostr(HdrForm.OpenHdrDlg.Files.Count)+' Landmark '+inttostr(gBatchMark)+'/'+inttostr( length(gLandmarks)); + AnatDropChange(nil); +end; + +procedure TAnatForm.AcceptLandmark; +var + lSaveName: string; +begin + Update(AnatDrop.ItemIndex); + lSaveName := ChangeFileExt(HdrForm.OpenHdrDlg.Files[gBatchImg-1], '.anat'); //10102006 + SaveLandmarks(lSaveName); + if gBatchImg >= HdrForm.OpenHdrDlg.Files.Count then begin + gBatchImg := 1; + if gBatchMark = length(gLandmarks) then begin + ImgForm.AcceptLandmark1.Enabled := false; + showmessage('Done with landmarks'); + end else + inc(gBatchMark); + end else + inc(gBatchImg); + LoadLandmark; +end; + +procedure TAnatForm.BatchLandmarks; +var + lTemplateName, lBatchName: string; + lI,lPrevAnat: integer; +begin + if not OpenDialogExecute(kAnatFilter,'Select landmark template',false) then exit; + lTemplateName := HdrForm.OpenHdrDlg.Filename; + // OpenAnat(HdrForm.OpenHdrDlg.Filename) ; + if not OpenDialogExecute(kImgFilter,'Select image[s] to create landmarks',true) then exit; + // length(gLandmarks) + //for lInc := 1 to HdrForm.OpenHdrDlg.Files.Count do begin //vcx + // lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + gBatchImg := 1; + gBatchMark := 1; + //make anatomy files for each image + lPrevAnat := 0; + for lI := 1 to HdrForm.OpenHdrDlg.Files.Count do begin + lBatchName := BatchName(lI); + if fileexists(lBatchName) then + inc(lPrevAnat) + else + CopyFile(PChar(lTemplateName), PChar(lBatchName), False);//SaveLandmarks(lBatchName); + end; + if lPrevAnat > 0 then + Showmessage('Warning: '+inttostr(lPrevAnat)+' pre-existing .anat files were not overwritten! Lets hope these have the correct order/number of landmarks.'); + LoadLandmark; + if (length(gLandmarks)< 1) or (HdrForm.OpenHdrDlg.Files.Count < 1) then begin + showmessage('Error loading template anatomy file!'); + exit; + end; + Showmessage('Press F10 to position the '+ inttostr(length(gLandmarks))+' landmarks to '+inttostr(HdrForm.OpenHdrDlg.Files.Count)+' images'); + + + ImgForm.AcceptLandmark1.Enabled := true; +end; + +procedure TAnatForm.CloseAnat; +begin + if length(gLandmarks) < 1 then + exit; + SetLength(gLandmarks,0); + UpdateCombo; +end; + +procedure TAnatForm.SaveBtnClick(Sender: TObject); +const + kSep = chr(9); +var + i: integer; + lF: TextFile; +begin + if length(gLandmarks) < 1 then begin + showmessage('No landmarks open - either open a file or create new landmarks'); + exit; + end; + ImgForm.SaveDialog1.Filter := kAnatFilter; + ImgForm.SaveDialog1.DefaultExt := '.anat'; + ImgForm.SaveDialog1.Filename := ChangeFileExt(ImgForm.SaveDialog1.Filename, ImgForm.SaveDialog1.DefaultExt); //10102006 + if not ImgForm.SaveDialog1.Execute then exit; + Filemode := 0; + AssignFile(lF, ImgForm.SaveDialog1.Filename); + rewrite(lF); + for i := 0 to length(gLandmarks)-1 do + Writeln(lF, gLandmarks[i].Name+kSep+floattostr(gLandmarks[i].X)+kSep+floattostr(gLandmarks[i].Y)+kSep+floattostr(gLandmarks[i].Z) ); + CloseFile(lF); + +end; + +procedure TAnatForm.UpdateCombo; +var + i: integer; +begin +//xxx + AnatDrop.Items.Clear; + if length(gLandmarks) < 1 then + exit; + for i := 0 to length(gLandmarks)-1 do + AnatDrop.Items.Add(gLandmarks[i].Name); + AnatDrop.ItemIndex := length(gLandmarks)-1; + AnatDropChange(nil); +end; + + +procedure TAnatForm.AddBtnClick(Sender: TObject); +var + s: string; + i: integer; + lOK: boolean; +begin + i := length(gLandmarks)+1; + s := 'A'+inttostr(i); + lOK := InputQuery('Enter a name', 'region name', s); + if not lOK then + exit; + setlength(gLandmarks,i); + gLandmarks[i-1].Name := s; + Update(i-1); + UpdateCombo; +end; + +(* + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + *) +procedure SetLandmark(index: integer);//indexed from 0 +var +//lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if (index < 0) or (index >= length(gLandmarks)) then + exit; + MMToImgCoord(lX,lY,lZ,gLandmarks[index].X,gLandmarks[index].Y,gLandmarks[index].Z); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + ImgForm.XViewEditChange(nil); +end; + +procedure TAnatForm.AnatDropChange(Sender: TObject); +begin + SetLandmark(AnatDrop.ItemIndex); +end; + +function NextTab(lStr: string; var lP: integer): string; +//reports text prior to tab... +var + len: integer; +begin + result := ''; + len := length(lStr); + if len < lP then exit; + repeat + if (lStr[lP] = chr(9)) then begin + lP := lP + 1; + exit; + end; + //if lStr[lP] <> ' ' then + result := result + lStr[lP]; + lP := lP + 1; + until (lP > len); +end; + +procedure TAnatForm.OpenAnat(lFilename: string); +var + st: string; + sl: TStringList; + n, line, col : integer; +begin + if not Fileexists(lFilename) then begin + CloseAnat; + exit; + end; + //will load the TAB delimited TXT here + sl := TStringList.Create; + try + //load the tab delimited txt file + sl.LoadFromFile(lFilename) ; + //for each tab delimited line + n := 0; + setlength(gLandmarks,sl.Count); + for line := 0 to sl.Count-1 do begin + st := sl[line]; + col := 1; + if (NextTab(st,col) <> '') and (NextTab(st,col) <> '') and(NextTab(st,col) <> '') and(NextTab(st,col) <> '') then begin + inc(n); + col := 1; + gLandmarks[line].Name := NextTab(st,col); + gLandmarks[line].X := strtofloat(NextTab(st,col)); + gLandmarks[line].Y := strtofloat(NextTab(st,col)); + gLandmarks[line].Z := strtofloat(NextTab(st,col)); + end; + end; + setlength(gLandmarks,n); + finally + sl.Free; + end; + UpdateCombo; + AnatForm.show; +end; + +procedure RMS (lS,lT: TLandmark;var nummatch: integer; var summatch: double); +var + DX: double; +begin + DX := sqrt(sqr(lS.X-lT.X)+sqr(lS.Y-lT.Y)+sqr(lS.Z-lT.Z)); + summatch := summatch + DX; + nummatch := nummatch+ 1; +end; + +procedure TAnatForm.ComputeRMS; +const + kTab= chr(9); +var + lSource: TLandmarkRA; + lStrings: TStringList; + lInc,l,p,t,s,nummatch:integer; + meanRMS,summatch: double; + lFilename: string; +begin + lStrings := TStringList.Create; + if not OpenDialogExecute(kAnatFilter,'Select template landmark file',false) then exit; + OpenAnat(HdrForm.OpenHdrDlg.Filename) ; + l := Length(gLandmarks); + if l < 1 then exit; + SetLength(lSource,l); + for p := 0 to l-1 do + lSource[p] := gLandmarks[p]; + lStrings := TStringList.Create; + lStrings.Add('Source='+kTab+HdrForm.OpenHdrDlg.Filename); + if not OpenDialogExecute(kAnatFilter,'Select test landmark file[s]',true) then exit; + TextForm.MemoT.Lines.Clear; + if HdrForm.OpenHdrDlg.Files.Count < 1 then + exit; + for lInc := 1 to HdrForm.OpenHdrDlg.Files.Count do begin //vcx + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + OpenAnat(lFilename) ; + nummatch := 0; + summatch := 0; + t := Length(gLandmarks); + if t > 0 then begin + for l := 0 to l-1 do begin + for s := 0 to t-1 do begin + if lSource[l].Name = gLandmarks[s].Name then + RMS(lSource[l],gLandmarks[s],nummatch,summatch); + end; //for each item in target + end;//for each item in source + end; + if nummatch < 1 then + meanRMS := 0 + else + meanRMS := summatch/nummatch; + lStrings.Add('Target='+kTab+lFilename+kTab+'N='+kTab+inttostr(nummatch)+kTab+'RMS'+kTab+floattostr(summatch)+kTab+'MeanRMS'+kTab+floattostr(meanRMS)); + + end; + TextForm.MemoT.Lines.AddStrings(lStrings); + lStrings.Free; + SetLength(lSource,0); + TextForm.Show; +end; + +procedure TAnatForm.OpenBtnClick(Sender: TObject); +begin + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + ComputeRMS; + exit; + end; + if not OpenDialogExecute(kAnatFilter,'Select landmark file',false) then exit; + OpenAnat(HdrForm.OpenHdrDlg.Filename) ; +end; + +procedure TAnatForm.Update(lIndex: integer); +var + X,Y,Z: integer; +begin + if lIndex >= Length(gLandmarks) then + exit; + X := round(ImgForm.XViewEdit.value); + Y := round(ImgForm.YViewEdit.value); + Z := round(ImgForm.ZViewEdit.value); + ImgCoordToMM(X,Y,Z, gLandmarks[lIndex].X,gLandmarks[lIndex].Y,gLandmarks[lIndex].Z); + AnatDropChange(nil); +end; + +procedure TAnatForm.UpdateBtnClick(Sender: TObject); +begin + Update(AnatDrop.ItemIndex); + +end; + +procedure TAnatForm.DeleteBtnClick(Sender: TObject); +var + p,i,l: integer; +begin + l := Length(gLandmarks); + i := AnatDrop.ItemIndex; + if (l < 1) or (i >= l) or (i < 0) then + exit; + if i < (l-1) then + for p := i+1 to l-1 do + gLandmarks[p-1] := gLandmarks[p]; + SetLength(gLandmarks,l-1); + UpdateCombo; +end; + +initialization +{$IFDEF FPC} +{$I landmarks.lrs} +{$ENDIF} + +end. + diff --git a/niftiview7/landmarksx.pas b/niftiview7/landmarksx.pas new file mode 100755 index 0000000..7a74a26 --- /dev/null +++ b/niftiview7/landmarksx.pas @@ -0,0 +1,238 @@ +unit landmarks; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, Buttons, ToolWin, ComCtrls; + +type + TAnatForm = class(TForm) + ToolBar1: TToolBar; + SaveBtn: TSpeedButton; + AddBtn: TSpeedButton; + ComboBox1: TComboBox; + UpdateBtn: TSpeedButton; + OpenBtn: TSpeedButton; + DeleteBtn: TSpeedButton; + procedure SaveBtnClick(Sender: TObject); + procedure AddBtnClick(Sender: TObject); + procedure ComboBox1Change(Sender: TObject); + procedure UpdateCombo; + procedure OpenBtnClick(Sender: TObject); + procedure Update(lIndex: integer); + procedure UpdateBtnClick(Sender: TObject); + procedure DeleteBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + AnatForm: TAnatForm; + +implementation + +uses nifti_img_view, nifti_img, nifti_hdr_view, define_types; + +{$R *.dfm} +type + TLandmark = record + Name: string; + X,Y,Z: single; + end; + TLandmarkRA = array of TLandmark; +const +kAnatFilter = 'AnatomyFile|*.anat'; +var + gLandmarks: TLandmarkRA; + + +procedure TAnatForm.SaveBtnClick(Sender: TObject); +const + kSep = chr(9); +var + i: integer; + lF: TextFile; +begin + if length(gLandmarks) < 1 then begin + showmessage('No landmarks open - either open a file or create new landmarks'); + exit; + end; + ImgForm.SaveDialog1.Filter := kAnatFilter; + ImgForm.SaveDialog1.DefaultExt := '.anat'; + ImgForm.SaveDialog1.Filename := ChangeFileExt(ImgForm.SaveDialog1.Filename, ImgForm.SaveDialog1.DefaultExt); //10102006 + if not ImgForm.SaveDialog1.Execute then exit; + Filemode := 0; + AssignFile(lF, ImgForm.SaveDialog1.Filename); + rewrite(lF); + for i := 0 to length(gLandmarks)-1 do + Writeln(lF, gLandmarks[i].Name+kSep+floattostr(gLandmarks[i].X)+kSep+floattostr(gLandmarks[i].Y)+kSep+floattostr(gLandmarks[i].Z) ); + CloseFile(lF); (**) + +end; + +procedure TAnatForm.UpdateCombo; +var + i: integer; +begin +//xxx + ComboBox1.Items.Clear; + if length(gLandmarks) < 1 then + exit; + for i := 0 to length(gLandmarks)-1 do + ComboBox1.Items.Add(gLandmarks[i].Name); + ComboBox1.ItemIndex := length(gLandmarks)-1; + ComboBox1Change(nil); +end; + + +procedure TAnatForm.AddBtnClick(Sender: TObject); +var + s: string; + i: integer; + lOK: boolean; +begin + i := length(gLandmarks)+1; + s := 'A'+inttostr(i); + lOK := InputQuery('Enter a name', 'region name', s); + if not lOK then + exit; + setlength(gLandmarks,i); + gLandmarks[i-1].Name := s; + Update(i-1); + UpdateCombo; +end; + +(* + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + *) +procedure SetLandmark(index: integer);//indexed from 0 +var +//lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if (index < 0) or (index >= length(gLandmarks)) then + exit; + MMToImgCoord(lX,lY,lZ,gLandmarks[index].X,gLandmarks[index].Y,gLandmarks[index].Z); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; +end; + +procedure TAnatForm.ComboBox1Change(Sender: TObject); +begin + SetLandmark(ComboBox1.ItemIndex); +end; + +function NextTab(lStr: string; var lP: integer): string; +//reports text prior to comma... +var + len: integer; +begin + result := ''; + len := length(lStr); + if len < lP then exit; + repeat + if (lStr[lP] = chr(9){','}) then begin + lP := lP + 1; + exit; + end; + //if lStr[lP] <> ' ' then + result := result + lStr[lP]; + lP := lP + 1; + until (lP > len); +end; + +procedure TAnatForm.OpenBtnClick(Sender: TObject); +var + //lFilename: string; + //i: integer; + //lX,lY,lZ + st: string; + sl{, slRow} : TStringList; + n, line, col : integer; +begin + if not OpenDialogExecute(kAnatFilter,'Select background image',false) then exit; + //will load the TAB delimited TXT here + sl := TStringList.Create; + //will process each TAB delimited line here + //slRow := TStringList.Create; + //slRow.StrictDelimiter := true; + //slRow.Delimiter := #9; //TAB + try + //load the tab delimited txt file + sl.LoadFromFile(HdrForm.OpenHdrDlg.Filename) ; + //StringGrid1.RowCount := sl.Count; + + //for each tab delimited line + n := 0; + setlength(gLandmarks,sl.Count); + for line := 0 to sl.Count-1 do begin + //"load" the line into a stringlist + //slRow.DelimitedText := sl[line]; + st := sl[line]; + col := 1; + if (NextTab(st,col) <> '') and (NextTab(st,col) <> '') and(NextTab(st,col) <> '') and(NextTab(st,col) <> '') then begin + inc(n); + col := 1; + gLandmarks[line].Name := NextTab(st,col); + //showmessage(gLandmarks[line].Name+' '+NextTab(st,col)); + gLandmarks[line].X := strtofloat(NextTab(st,col)); + gLandmarks[line].Y := strtofloat(NextTab(st,col)); + gLandmarks[line].Z := strtofloat(NextTab(st,col)); + end; + //StringGrid1.Rows[line].Assign(slRow); + {gLandmarks[line].Name := slRow.Strings[0]; + gLandmarks[line].X := strtofloat(slRow.Strings[1]); + gLandmarks[line].Y := strtofloat(slRow.Strings[2]); + gLandmarks[line].Z := strtofloat(slRow.Strings[3]); } + end; + setlength(gLandmarks,n); + finally + //slRow.Free; + sl.Free; + end; + UpdateCombo; +end; + +procedure TAnatForm.Update(lIndex: integer); +var + X,Y,Z: integer; +begin + if lIndex >= Length(gLandmarks) then + exit; + X := round(ImgForm.XViewEdit.value); + Y := round(ImgForm.YViewEdit.value); + Z := round(ImgForm.ZViewEdit.value); + ImgCoordToMM(X,Y,Z, gLandmarks[lIndex].X,gLandmarks[lIndex].Y,gLandmarks[lIndex].Z); + ComboBox1Change(nil); +end; + +procedure TAnatForm.UpdateBtnClick(Sender: TObject); +begin + Update(ComboBox1.ItemIndex); + +end; + +procedure TAnatForm.DeleteBtnClick(Sender: TObject); +var + p,i,l: integer; +begin + l := Length(gLandmarks); + i := ComboBox1.ItemIndex; + if (l < 1) or (i >= l) or (i < 0) then + exit; + if i < (l-1) then + for p := i+1 to l-1 do + gLandmarks[p-1] := gLandmarks[p]; + SetLength(gLandmarks,l-1); + UpdateCombo; +end; + +end. + diff --git a/niftiview7/license.pas b/niftiview7/license.pas new file mode 100755 index 0000000..bb1a804 --- /dev/null +++ b/niftiview7/license.pas @@ -0,0 +1,198 @@ +unit license; +interface +//uses Windows; //DWord definition +//uses definetypes;//dialogs,SysUtils; + + type + TCPUIDARRAY=array[1..4] of Longint; + //procedure Encrypt64(var lInt1,lInt2: longint); + //procedure Decrypt64(var lInt1,lInt2: longint); +//procedure GetIDInfo64(var lInt64: Int64); +//procedure GetIDInfo(var lInt1,lInt2: longint); +function GetIDInfo32: longint; +function Encrypt32(var lIn: longint): longint; + +implementation +const + kStartKey = 3891; {Start default key} + kMultKey = 23272; {Mult default key} + kAddKey = 31198; {Add default key} + +function IsCPUID_Available : Boolean;assembler;register; +const + ID_BIT=$200000; (** EFLAGS ID bit **) +asm + PUSHFD {direct access to flags no possible, only via stack} + POP EAX {flags to EAX} + MOV EDX,EAX {save current flags} + XOR EAX,ID_BIT {not ID bit} + PUSH EAX {onto stack} + POPFD {from stack to flags, with not ID bit} + PUSHFD {back to stack} + POP EAX {get back to EAX} + XOR EAX,EDX {check if ID bit affected} + JZ @exit {no, CPUID not availavle} + MOV AL,True {Result=True} +@exit: +end; + +function GetCPUID : TCPUIDARRAY; assembler;register; +asm + PUSH EBX {Save affected register} + PUSH EDI + MOV EDI,EAX {@Resukt} + MOV EAX,1 + DW $A20F {CPUID Command} + STOSD {CPUID[1]} + MOV EAX,EBX + STOSD {CPUID[2]} + MOV EAX,ECX + STOSD {CPUID[3]} + MOV EAX,EDX + STOSD {CPUID[4]} + POP EDI {Restore registers} + POP EBX +end; + +function GetIDInfo32: longint; +var + I : Integer; + CPUIDARRAY,ByteArray: TCPUIDARRAY; +begin + result:=-1; + //for I := Low(CPUIDARRAY) to High(CPUIDARRAY) do CPUIDARRAY[I] := -1; + if not IsCPUID_Available then exit; + CPUIDARRAY:=GetCPUID; + for I := Low(CPUIDARRAY) to High(CPUIDARRAY) do begin + ByteArray[I] := CPUIDARRAY[I] and 255; + if ByteArray[I] = 0 then + ByteArray[I] := (CPUIDARRAY[I] shr 8) and 255; + if ByteArray[I] = 0 then + ByteArray[I] := (CPUIDARRAY[I] shr 16) and 255; + if ByteArray[I] = 0 then + ByteArray[I] := (CPUIDARRAY[I] shr 24) and 255; + end; + result := (ByteArray[1] and 255)+((ByteArray[2] and 255) shl 8) + + ((ByteArray[3] and 255) shl 16)+((ByteArray[4] and 255) shl 24); +end; + +(*procedure GetIDInfo(var lInt1,lInt2: longint); + const + kMax16bit = (256*256)-1; +var + I : Integer; + CPUIDARRAY,WordArray: TCPUIDARRAY; + +begin + lInt1:=-1; + lInt2 := -1; + //for I := Low(CPUIDARRAY) to High(CPUIDARRAY) do CPUIDARRAY[I] := -1; + if not IsCPUID_Available then exit; + CPUIDARRAY:=GetCPUID; + for I := Low(CPUIDARRAY) to High(CPUIDARRAY) do begin + WordArray[I] := CPUIDARRAY[I] and kMax16bit; + if WordArray[I] = 0 then + WordArray[I] := (CPUIDARRAY[I] shr 8) and kMax16bit; + if WordArray[I] = 0 then + WordArray[I] := (CPUIDARRAY[I] shr 16) and kMax16bit; + if WordArray[I] = 0 then + WordArray[I] := (CPUIDARRAY[I] shr 24) and kMax16bit; + end; + lInt1 := (WordArray[1] and kMax16bit)+((WordArray[2] and kMax16bit) shl 16); + lInt2 := (WordArray[3] and kMax16bit)+((WordArray[4] and kMax16bit) shl 16); +end; + (**) +{$R-} +{$Q-} +function Encrypt32(var lIn: longint): longint; +type + swaptype = packed record + case byte of + 0:(b1,b2,b3,b4 : byte); //byte is 8 bits + 1:(Long:LongInt); //long is 16 bits + end; + swaptypep = ^swaptype; +var + inguy,outguy:swaptypep; + lResult,StartKey:Longint; +begin + StartKey := kStartKey; + inguy := @lIn; + outguy := @lResult; + outguy.b1 := ((inguy.b1) xor (StartKey shr 8)); + StartKey := (outguy.b1 + StartKey) * kMultKey + kAddkey; + outguy.b2 := ((inguy.b2) xor (StartKey shr 8)); + StartKey := (outguy.b2 + StartKey) * kMultKey + kAddkey; + outguy.b3 := ((inguy.b3) xor (StartKey shr 8)); + StartKey := (outguy.b3 + StartKey) * kMultKey + kAddkey; + outguy.b4 := ((inguy.b4) xor (StartKey shr 8)); + //StartKey := (outguy.b4 + StartKey) * kMultKey + kAddkey; + //inguy.Long := outguy.long; + Result := outguy.long; +end; + +(*procedure Encrypt64(var lInt1,lInt2: longint); +type + swaptype = packed record + case byte of + 0:(b1,b2,b3,b4 : byte); //byte is 8 bits + 1:(Long:LongInt); //long is 16 bits + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; + lLoop,StartKey:Integer; +begin + StartKey := kStartKey; + for lLoop := 1 to 2 do begin + if lLoop = 1 then + inguy := @lInt1 + else + inguy := @lInt2; //assign address of s to inguy + outguy.b1 := ((inguy.b1) xor (StartKey shr 8)); + StartKey := (outguy.b1 + StartKey) * kMultKey + kAddkey; + outguy.b2 := ((inguy.b2) xor (StartKey shr 8)); + StartKey := (outguy.b2 + StartKey) * kMultKey + kAddkey; + outguy.b3 := ((inguy.b3) xor (StartKey shr 8)); + StartKey := (outguy.b3 + StartKey) * kMultKey + kAddkey; + outguy.b4 := ((inguy.b4) xor (StartKey shr 8)); + StartKey := (outguy.b4 + StartKey) * kMultKey + kAddkey; + inguy.Long := outguy.long; + end; +end; + +procedure Decrypt64(var lInt1,lInt2: longint); +type + swaptype = packed record + case byte of + 0:(b1,b2,b3,b4 : byte); //byte is 8 bits + 1:(Long:LongInt); //long is 16 bits + end; + swaptypep = ^swaptype; +var + inguy:swaptypep; + outguy:swaptype; + lLoop,StartKey:Integer; +begin + StartKey := kStartKey; + for lLoop := 1 to 2 do begin + if lLoop = 1 then + inguy := @lInt1 + else + inguy := @lInt2; //assign address of s to inguy + outguy.b1 := ((inguy.b1) xor (StartKey shr 8)); + StartKey := ((inguy.b1) + StartKey) * kMultKey + kAddkey; + outguy.b2 := ((inguy.b2) xor (StartKey shr 8)); + StartKey := ((inguy.b2) + StartKey) * kMultKey + kAddkey; + outguy.b3 := ((inguy.b3) xor (StartKey shr 8)); + StartKey := ((inguy.b3) + StartKey) * kMultKey + kAddkey; + outguy.b4 := ((inguy.b4) xor (StartKey shr 8)); + StartKey := ((inguy.b4) + StartKey) * kMultKey + kAddkey; + inguy.Long := outguy.long; + end; +end; (**) + + + +end. diff --git a/niftiview7/lut/16.lut b/niftiview7/lut/16.lut new file mode 100755 index 0000000..91accec Binary files /dev/null and b/niftiview7/lut/16.lut differ diff --git a/niftiview7/lut/1hot.lut b/niftiview7/lut/1hot.lut new file mode 100755 index 0000000..7e4f94a Binary files /dev/null and b/niftiview7/lut/1hot.lut differ diff --git a/niftiview7/lut/2winter.lut b/niftiview7/lut/2winter.lut new file mode 100755 index 0000000..2ef40be Binary files /dev/null and b/niftiview7/lut/2winter.lut differ diff --git a/niftiview7/lut/3warm.lut b/niftiview7/lut/3warm.lut new file mode 100755 index 0000000..f408534 Binary files /dev/null and b/niftiview7/lut/3warm.lut differ diff --git a/niftiview7/lut/4cool.lut b/niftiview7/lut/4cool.lut new file mode 100755 index 0000000..04d2184 Binary files /dev/null and b/niftiview7/lut/4cool.lut differ diff --git a/niftiview7/lut/5redyell.lut b/niftiview7/lut/5redyell.lut new file mode 100755 index 0000000..9809f89 Binary files /dev/null and b/niftiview7/lut/5redyell.lut differ diff --git a/niftiview7/lut/6bluegrn.lut b/niftiview7/lut/6bluegrn.lut new file mode 100755 index 0000000..020fad8 Binary files /dev/null and b/niftiview7/lut/6bluegrn.lut differ diff --git a/niftiview7/lut/GE_color.lut b/niftiview7/lut/GE_color.lut new file mode 100755 index 0000000..ca04dd5 Binary files /dev/null and b/niftiview7/lut/GE_color.lut differ diff --git a/niftiview7/lut/HOTIRON.lut b/niftiview7/lut/HOTIRON.lut new file mode 100755 index 0000000..8728e7f Binary files /dev/null and b/niftiview7/lut/HOTIRON.lut differ diff --git a/niftiview7/lut/NIH.lut b/niftiview7/lut/NIH.lut new file mode 100755 index 0000000..94ebbe0 Binary files /dev/null and b/niftiview7/lut/NIH.lut differ diff --git a/niftiview7/lut/NIH_fire.lut b/niftiview7/lut/NIH_fire.lut new file mode 100755 index 0000000..976a88d Binary files /dev/null and b/niftiview7/lut/NIH_fire.lut differ diff --git a/niftiview7/lut/NIH_ice.lut b/niftiview7/lut/NIH_ice.lut new file mode 100755 index 0000000..302afc6 Binary files /dev/null and b/niftiview7/lut/NIH_ice.lut differ diff --git a/niftiview7/lut/Rainramp.lut b/niftiview7/lut/Rainramp.lut new file mode 100755 index 0000000..47e19fd Binary files /dev/null and b/niftiview7/lut/Rainramp.lut differ diff --git a/niftiview7/lut/actc.lut b/niftiview7/lut/actc.lut new file mode 100755 index 0000000..8067a51 Binary files /dev/null and b/niftiview7/lut/actc.lut differ diff --git a/niftiview7/lut/blackbdy.lut b/niftiview7/lut/blackbdy.lut new file mode 100755 index 0000000..3722fdb Binary files /dev/null and b/niftiview7/lut/blackbdy.lut differ diff --git a/niftiview7/lut/blue_otto.lut b/niftiview7/lut/blue_otto.lut new file mode 100755 index 0000000..fd38d69 --- /dev/null +++ b/niftiview7/lut/blue_otto.lut @@ -0,0 +1,257 @@ +* s=byte index red green blue +S 0 0 0 0 +S 1 0 0 128 +S 2 0 0 128 +S 3 0 0 128 +S 4 0 0 128 +S 5 0 0 128 +S 6 0 0 128 +S 7 0 0 128 +S 8 0 0 128 +S 9 0 0 128 +S 10 0 0 128 +S 11 0 0 128 +S 12 0 0 128 +S 13 0 0 128 +S 14 0 0 128 +S 15 0 0 128 +S 16 0 0 128 +S 17 0 0 128 +S 18 0 0 128 +S 19 0 0 128 +S 20 0 0 128 +S 21 0 0 128 +S 22 0 0 128 +S 23 0 0 128 +S 24 0 0 128 +S 25 0 0 128 +S 26 0 0 128 +S 27 0 0 128 +S 28 0 0 128 +S 29 0 0 128 +S 30 0 0 128 +S 31 0 0 128 +S 32 0 0 128 +S 33 0 0 128 +S 34 0 0 128 +S 35 0 0 128 +S 36 0 0 128 +S 37 0 0 128 +S 38 0 0 128 +S 39 0 0 128 +S 40 0 0 128 +S 41 0 0 128 +S 42 0 0 128 +S 43 0 0 128 +S 44 0 0 128 +S 45 0 0 128 +S 46 0 0 128 +S 47 0 0 128 +S 48 0 0 128 +S 49 0 0 128 +S 50 0 0 128 +S 51 32 0 192 +S 52 32 0 192 +S 53 32 0 192 +S 54 32 0 192 +S 55 32 0 192 +S 56 32 0 192 +S 57 32 0 192 +S 58 32 0 192 +S 59 32 0 192 +S 60 32 0 192 +S 61 32 0 192 +S 62 32 0 192 +S 63 32 0 192 +S 64 32 0 192 +S 65 32 0 192 +S 66 32 0 192 +S 67 32 0 192 +S 68 32 0 192 +S 69 32 0 192 +S 70 32 0 192 +S 71 32 0 192 +S 72 32 0 192 +S 73 32 0 192 +S 74 32 0 192 +S 75 32 0 192 +S 76 32 0 192 +S 77 32 0 192 +S 78 32 0 192 +S 79 32 0 192 +S 80 32 0 192 +S 81 32 0 192 +S 82 32 0 192 +S 83 32 0 192 +S 84 32 0 192 +S 85 32 0 192 +S 86 32 0 192 +S 87 32 0 192 +S 88 32 0 192 +S 89 32 0 192 +S 90 32 0 192 +S 91 32 0 192 +S 92 32 0 192 +S 93 32 0 192 +S 94 32 0 192 +S 95 32 0 192 +S 96 32 0 192 +S 97 32 0 192 +S 98 32 0 192 +S 99 32 0 192 +S 100 32 0 192 +S 101 32 0 192 +S 102 0 168 190 +S 103 0 168 190 +S 104 0 168 190 +S 105 0 168 190 +S 106 0 168 190 +S 107 0 168 190 +S 108 0 168 190 +S 109 0 168 190 +S 110 0 168 190 +S 111 0 168 190 +S 112 0 168 190 +S 113 0 168 190 +S 114 0 168 190 +S 115 0 168 190 +S 116 0 168 190 +S 117 0 168 190 +S 118 0 168 190 +S 119 0 168 190 +S 120 0 168 190 +S 121 0 168 190 +S 122 0 168 190 +S 123 0 168 190 +S 124 0 168 190 +S 125 0 168 190 +S 126 0 168 190 +S 127 0 168 190 +S 128 0 168 190 +S 129 0 168 190 +S 130 0 168 190 +S 131 0 168 190 +S 132 0 168 190 +S 133 0 168 190 +S 134 0 168 190 +S 135 0 168 190 +S 136 0 168 190 +S 137 0 168 190 +S 138 0 168 190 +S 139 0 168 190 +S 140 0 168 190 +S 141 0 168 190 +S 142 0 168 190 +S 143 0 168 190 +S 144 0 168 190 +S 145 0 168 190 +S 146 0 168 190 +S 147 0 168 190 +S 148 0 168 190 +S 149 0 168 190 +S 150 0 168 190 +S 151 0 168 190 +S 152 0 168 190 +S 153 127 255 255 +S 154 127 255 255 +S 155 127 255 255 +S 156 127 255 255 +S 157 127 255 255 +S 158 127 255 255 +S 159 127 255 255 +S 160 127 255 255 +S 161 127 255 255 +S 162 127 255 255 +S 163 127 255 255 +S 164 127 255 255 +S 165 127 255 255 +S 166 127 255 255 +S 167 127 255 255 +S 168 127 255 255 +S 169 127 255 255 +S 170 127 255 255 +S 171 127 255 255 +S 172 127 255 255 +S 173 127 255 255 +S 174 127 255 255 +S 175 127 255 255 +S 176 127 255 255 +S 177 127 255 255 +S 178 127 255 255 +S 179 127 255 255 +S 180 127 255 255 +S 181 127 255 255 +S 182 127 255 255 +S 183 127 255 255 +S 184 127 255 255 +S 185 127 255 255 +S 186 127 255 255 +S 187 127 255 255 +S 188 127 255 255 +S 189 127 255 255 +S 190 127 255 255 +S 191 127 255 255 +S 192 127 255 255 +S 193 127 255 255 +S 194 127 255 255 +S 195 127 255 255 +S 196 127 255 255 +S 197 127 255 255 +S 198 127 255 255 +S 199 127 255 255 +S 200 127 255 255 +S 201 127 255 255 +S 202 127 255 255 +S 203 127 255 255 +S 204 127 255 255 +S 205 220 255 255 +S 206 220 255 255 +S 207 220 255 255 +S 208 220 255 255 +S 209 220 255 255 +S 210 220 255 255 +S 211 220 255 255 +S 212 220 255 255 +S 213 220 255 255 +S 214 220 255 255 +S 215 220 255 255 +S 216 220 255 255 +S 217 220 255 255 +S 218 220 255 255 +S 219 220 255 255 +S 220 220 255 255 +S 221 220 255 255 +S 222 220 255 255 +S 223 220 255 255 +S 224 220 255 255 +S 225 220 255 255 +S 226 220 255 255 +S 227 220 255 255 +S 228 220 255 255 +S 229 220 255 255 +S 230 220 255 255 +S 231 220 255 255 +S 232 220 255 255 +S 233 220 255 255 +S 234 220 255 255 +S 235 220 255 255 +S 236 220 255 255 +S 237 220 255 255 +S 238 220 255 255 +S 239 220 255 255 +S 240 220 255 255 +S 241 220 255 255 +S 242 220 255 255 +S 243 220 255 255 +S 244 220 255 255 +S 245 220 255 255 +S 246 220 255 255 +S 247 220 255 255 +S 248 220 255 255 +S 249 220 255 255 +S 250 220 255 255 +S 251 220 255 255 +S 252 220 255 255 +S 253 220 255 255 +S 254 220 255 255 +S 255 220 255 255 diff --git a/niftiview7/lut/bluegray.lut b/niftiview7/lut/bluegray.lut new file mode 100755 index 0000000..2abf989 Binary files /dev/null and b/niftiview7/lut/bluegray.lut differ diff --git a/niftiview7/lut/bone.lut b/niftiview7/lut/bone.lut new file mode 100755 index 0000000..ea6ff74 Binary files /dev/null and b/niftiview7/lut/bone.lut differ diff --git a/niftiview7/lut/cardiac.lut b/niftiview7/lut/cardiac.lut new file mode 100755 index 0000000..3b72b95 Binary files /dev/null and b/niftiview7/lut/cardiac.lut differ diff --git a/niftiview7/lut/cortex.lut b/niftiview7/lut/cortex.lut new file mode 100755 index 0000000..f19bd7e --- /dev/null +++ b/niftiview7/lut/cortex.lut @@ -0,0 +1,5 @@ + +  !#$%'()+,./0234679:;=>?ABDEFHIKLMOPQSTVWXZ[\^_abcefhijlmnpqstuwxy{|~€‚ƒ„†‡‰Š‹Ž‘’”•–˜™›œŸ ¡£¤¦§¨ª«­®¯±²³µ¶¸¹º¼½¾ÀÁÃÄÅÇÈÉËÌÎÏÐÒÓÕÖ×ÙÚÛÝÞàáâäåæèéëìíïðòóôö÷øúûýþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ +  !"#$$%&'()*+,--./01234556789:;<==>?@ABCDEEFGHIJKLMMNOPQRSTUUVWXYZ[\]]^_`abcdeefghijklmmnopqrstuuvwxyz{|}}~€‚ƒ„…††‡ˆ‰Š‹ŒŽŽ‘’“”•––—˜™š›œžžŸ ¡¢£¤¥¦¦§¨©ª«¬­®®¯°±²³´µ¶¶·¸¹º»¼½¾¾¿ÀÁÂÃÄÅÆÆÇÈÉÊËÌÍÎÎÏÐÑÒÓÔÕÖÖ×ØÙÚÛÜÝàãæëðõúÿ + +  !""#$$%&&'(()**+,--.//01123345567789::;<<=>>?@@ABBCDDEFGGHIIJKKLMMNOOPQRRSTTUVVWXXYZZ[\\]^__`aabccdeefgghiijkllmnnoppqrrsttuvvwxyyz{{|}}~€‚ƒ„„…††‡ˆˆ‰ŠŠ‹ŒŒŽŽ‘‘’““”••–——˜™™š››œžžŸ ¡¢£¤¦ª¯´¹¾ÃÈÍÒÒ×Üáæëðõÿ \ No newline at end of file diff --git a/niftiview7/lut/flow.lut b/niftiview7/lut/flow.lut new file mode 100755 index 0000000..2b6eb3e Binary files /dev/null and b/niftiview7/lut/flow.lut differ diff --git a/niftiview7/lut/french.lut b/niftiview7/lut/french.lut new file mode 100755 index 0000000..150528a Binary files /dev/null and b/niftiview7/lut/french.lut differ diff --git a/niftiview7/lut/gold.lut b/niftiview7/lut/gold.lut new file mode 100755 index 0000000..4f4dfe2 Binary files /dev/null and b/niftiview7/lut/gold.lut differ diff --git a/niftiview7/lut/gooch.lut b/niftiview7/lut/gooch.lut new file mode 100755 index 0000000..be336d9 Binary files /dev/null and b/niftiview7/lut/gooch.lut differ diff --git a/niftiview7/lut/greengray.lut b/niftiview7/lut/greengray.lut new file mode 100755 index 0000000..e77808b Binary files /dev/null and b/niftiview7/lut/greengray.lut differ diff --git a/niftiview7/lut/hyper.lut b/niftiview7/lut/hyper.lut new file mode 100755 index 0000000..517faae Binary files /dev/null and b/niftiview7/lut/hyper.lut differ diff --git a/niftiview7/lut/middlegray.lut b/niftiview7/lut/middlegray.lut new file mode 100755 index 0000000..1523d4c --- /dev/null +++ b/niftiview7/lut/middlegray.lut @@ -0,0 +1,256 @@ +S 0 0 0 0 +S 1 1 1 1 +S 2 2 2 2 +S 3 3 3 3 +S 4 4 4 4 +S 5 5 5 5 +S 6 6 6 6 +S 7 7 7 7 +S 8 8 8 8 +S 9 9 9 9 +S 10 10 10 10 +S 11 11 11 11 +S 12 12 12 12 +S 13 13 13 13 +S 14 14 14 14 +S 15 15 15 15 +S 16 16 16 16 +S 17 17 17 17 +S 18 18 18 18 +S 19 19 19 19 +S 20 20 20 20 +S 21 21 21 21 +S 22 22 22 22 +S 23 23 23 23 +S 24 24 24 24 +S 25 25 25 25 +S 26 26 26 26 +S 27 27 27 27 +S 28 28 28 28 +S 29 29 29 29 +S 30 30 30 30 +S 31 31 31 31 +S 32 32 32 32 +S 33 33 33 33 +S 34 34 34 34 +S 35 35 35 35 +S 36 36 36 36 +S 37 37 37 37 +S 38 38 38 38 +S 39 39 39 39 +S 40 40 40 40 +S 41 41 41 41 +S 42 42 42 42 +S 43 43 43 43 +S 44 44 44 44 +S 45 45 45 45 +S 46 46 46 46 +S 47 47 47 47 +S 48 48 48 48 +S 49 49 49 49 +S 50 50 50 50 +S 51 51 51 51 +S 52 52 52 52 +S 53 53 53 53 +S 54 54 54 54 +S 55 55 55 55 +S 56 56 56 56 +S 57 57 57 57 +S 58 58 58 58 +S 59 59 59 59 +S 60 60 60 60 +S 61 61 61 61 +S 62 62 62 62 +S 63 63 63 63 +S 64 64 64 64 +S 65 65 65 65 +S 66 66 66 66 +S 67 67 67 67 +S 68 68 68 68 +S 69 69 69 69 +S 70 70 70 70 +S 71 71 71 71 +S 72 72 72 72 +S 73 73 73 73 +S 74 74 74 74 +S 75 75 75 75 +S 76 76 76 76 +S 77 77 77 77 +S 78 78 78 78 +S 79 79 79 79 +S 80 80 80 80 +S 81 81 81 81 +S 82 82 82 82 +S 83 83 83 83 +S 84 84 84 84 +S 85 85 85 85 +S 86 86 86 86 +S 87 87 87 87 +S 88 88 88 88 +S 89 89 89 89 +S 90 90 90 90 +S 91 91 91 91 +S 92 92 92 92 +S 93 93 93 93 +S 94 94 94 94 +S 95 95 95 95 +S 96 96 96 96 +S 97 97 97 97 +S 98 98 98 98 +S 99 99 99 99 +S 100 100 100 100 +S 101 101 101 101 +S 102 102 102 102 +S 103 103 103 103 +S 104 104 104 104 +S 105 105 105 105 +S 106 106 106 106 +S 107 107 107 107 +S 108 108 108 108 +S 109 109 109 109 +S 110 110 110 110 +S 111 111 111 111 +S 112 112 112 112 +S 113 113 113 113 +S 114 114 114 114 +S 115 115 115 115 +S 116 116 116 116 +S 117 117 117 117 +S 118 118 118 118 +S 119 119 119 119 +S 120 120 120 120 +S 121 121 121 121 +S 122 122 122 122 +S 123 123 123 123 +S 124 124 124 124 +S 125 125 125 125 +S 126 126 126 126 +S 127 127 127 127 +S 128 128 128 128 +S 129 129 129 129 +S 130 130 130 130 +S 131 131 131 131 +S 132 132 132 132 +S 133 133 133 133 +S 134 134 134 134 +S 135 135 135 135 +S 136 136 136 136 +S 137 137 137 137 +S 138 138 138 138 +S 139 139 139 139 +S 140 140 140 140 +S 141 141 141 141 +S 142 142 142 142 +S 143 143 143 143 +S 144 144 144 144 +S 145 145 145 145 +S 146 146 146 146 +S 147 147 147 147 +S 148 148 148 148 +S 149 149 149 149 +S 150 150 150 150 +S 151 151 151 151 +S 152 152 152 152 +S 153 153 153 153 +S 154 154 154 154 +S 155 155 155 155 +S 156 156 156 156 +S 157 157 157 157 +S 158 158 158 158 +S 159 159 159 159 +S 160 160 160 160 +S 161 161 161 161 +S 162 162 162 162 +S 163 163 163 163 +S 164 164 164 164 +S 165 165 165 165 +S 166 166 166 166 +S 167 167 167 167 +S 168 168 168 168 +S 169 169 169 169 +S 170 170 170 170 +S 171 171 171 171 +S 172 172 172 172 +S 173 173 173 173 +S 174 174 174 174 +S 175 175 175 175 +S 176 176 176 176 +S 177 177 177 177 +S 178 178 178 178 +S 179 179 179 179 +S 180 180 180 180 +S 181 181 181 181 +S 182 182 182 182 +S 183 183 183 183 +S 184 184 184 184 +S 185 185 185 185 +S 186 186 186 186 +S 187 187 187 187 +S 188 188 188 188 +S 189 189 189 189 +S 190 190 190 190 +S 191 191 191 191 +S 192 192 192 192 +S 193 193 193 193 +S 194 194 194 194 +S 195 195 195 195 +S 196 196 196 196 +S 197 197 197 197 +S 198 198 198 198 +S 199 199 199 199 +S 200 200 200 200 +S 201 201 201 201 +S 202 202 202 202 +S 203 203 203 203 +S 204 204 204 204 +S 205 205 205 205 +S 206 206 206 206 +S 207 207 207 207 +S 208 208 208 208 +S 209 209 209 209 +S 210 210 210 210 +S 211 211 211 211 +S 212 212 212 212 +S 213 213 213 213 +S 214 214 214 214 +S 215 215 215 215 +S 216 216 216 216 +S 217 217 217 217 +S 218 218 218 218 +S 219 219 219 219 +S 220 220 220 220 +S 221 221 221 221 +S 222 222 222 222 +S 223 223 223 223 +S 224 224 224 224 +S 225 225 225 225 +S 226 226 226 226 +S 227 227 227 227 +S 228 228 228 228 +S 229 229 229 229 +S 230 230 230 230 +S 231 231 231 231 +S 232 232 232 232 +S 233 233 233 233 +S 234 234 234 234 +S 235 235 235 235 +S 236 236 236 236 +S 237 237 237 237 +S 238 238 238 238 +S 239 239 239 239 +S 240 240 240 240 +S 241 241 241 241 +S 242 242 242 242 +S 243 243 243 243 +S 244 244 244 244 +S 245 245 245 245 +S 246 246 246 246 +S 247 247 247 247 +S 248 248 248 248 +S 249 249 249 249 +S 250 250 250 250 +S 251 251 251 251 +S 252 252 252 252 +S 253 253 253 253 +S 254 254 254 254 +S 255 0 0 0 diff --git a/niftiview7/lut/overlay_classic.lut b/niftiview7/lut/overlay_classic.lut new file mode 100755 index 0000000..6d5add9 --- /dev/null +++ b/niftiview7/lut/overlay_classic.lut @@ -0,0 +1,257 @@ +* s=byte index red green blue +S 0 0 0 0 +S 1 250 0 255 +S 2 245 0 255 +S 3 240 0 255 +S 4 235 0 255 +S 5 230 0 255 +S 6 224 0 255 +S 7 219 0 255 +S 8 214 0 255 +S 9 209 0 255 +S 10 204 0 255 +S 11 199 0 255 +S 12 194 0 255 +S 13 189 0 255 +S 14 184 0 255 +S 15 179 0 255 +S 16 173 0 255 +S 17 168 0 255 +S 18 163 0 255 +S 19 158 0 255 +S 20 153 0 255 +S 21 148 0 255 +S 22 143 0 255 +S 23 138 0 255 +S 24 133 0 255 +S 25 128 0 255 +S 26 122 0 255 +S 27 117 0 255 +S 28 112 0 255 +S 29 107 0 255 +S 30 102 0 255 +S 31 97 0 255 +S 32 92 0 255 +S 33 87 0 255 +S 34 82 0 255 +S 35 77 0 255 +S 36 71 0 255 +S 37 66 0 255 +S 38 61 0 255 +S 39 56 0 255 +S 40 51 0 255 +S 41 46 0 255 +S 42 41 0 255 +S 43 36 0 255 +S 44 31 0 255 +S 45 26 0 255 +S 46 20 0 255 +S 47 15 0 255 +S 48 10 0 255 +S 49 5 0 255 +S 50 0 5 255 +S 51 0 10 255 +S 52 0 15 255 +S 53 0 20 255 +S 54 0 26 255 +S 55 0 31 255 +S 56 0 36 255 +S 57 0 41 255 +S 58 0 46 255 +S 59 0 51 255 +S 60 0 56 255 +S 61 0 61 255 +S 62 0 66 255 +S 63 0 71 255 +S 64 0 77 255 +S 65 0 82 255 +S 66 0 87 255 +S 67 0 92 255 +S 68 0 97 255 +S 69 0 102 255 +S 70 0 107 255 +S 71 0 112 255 +S 72 0 117 255 +S 73 0 122 255 +S 74 0 128 255 +S 75 0 133 255 +S 76 0 138 255 +S 77 0 143 255 +S 78 0 148 255 +S 79 0 153 255 +S 80 0 158 255 +S 81 0 163 255 +S 82 0 168 255 +S 83 0 173 255 +S 84 0 179 255 +S 85 0 184 255 +S 86 0 189 255 +S 87 0 194 255 +S 88 0 199 255 +S 89 0 204 255 +S 90 0 209 255 +S 91 0 214 255 +S 92 0 219 255 +S 93 0 224 255 +S 94 0 230 255 +S 95 0 235 255 +S 96 0 240 255 +S 97 0 245 255 +S 98 0 250 255 +S 99 0 255 255 +S 100 0 255 250 +S 101 0 255 245 +S 102 0 255 240 +S 103 0 255 235 +S 104 0 255 229 +S 105 0 255 224 +S 106 0 255 219 +S 107 0 255 214 +S 108 0 255 209 +S 109 0 255 204 +S 110 0 255 199 +S 111 0 255 194 +S 112 0 255 189 +S 113 0 255 184 +S 114 0 255 178 +S 115 0 255 173 +S 116 0 255 168 +S 117 0 255 163 +S 118 0 255 158 +S 119 0 255 153 +S 120 0 255 148 +S 121 0 255 143 +S 122 0 255 138 +S 123 0 255 133 +S 124 0 255 127 +S 125 0 255 122 +S 126 0 255 117 +S 127 0 255 112 +S 128 0 255 107 +S 129 0 255 102 +S 130 0 255 97 +S 131 0 255 92 +S 132 0 255 87 +S 133 0 255 82 +S 134 0 255 76 +S 135 0 255 71 +S 136 0 255 66 +S 137 0 255 61 +S 138 0 255 56 +S 139 0 255 51 +S 140 0 255 46 +S 141 0 255 41 +S 142 0 255 36 +S 143 0 255 31 +S 144 0 255 25 +S 145 0 255 20 +S 146 0 255 15 +S 147 0 255 10 +S 148 0 255 5 +S 149 0 255 0 +S 150 5 255 0 +S 151 10 255 0 +S 152 15 255 0 +S 153 20 255 0 +S 154 26 255 0 +S 155 31 255 0 +S 156 36 255 0 +S 157 41 255 0 +S 158 46 255 0 +S 159 51 255 0 +S 160 56 255 0 +S 161 61 255 0 +S 162 66 255 0 +S 163 71 255 0 +S 164 77 255 0 +S 165 82 255 0 +S 166 87 255 0 +S 167 92 255 0 +S 168 97 255 0 +S 169 102 255 0 +S 170 107 255 0 +S 171 112 255 0 +S 172 117 255 0 +S 173 122 255 0 +S 174 128 255 0 +S 175 133 255 0 +S 176 138 255 0 +S 177 143 255 0 +S 178 148 255 0 +S 179 153 255 0 +S 180 158 255 0 +S 181 163 255 0 +S 182 168 255 0 +S 183 173 255 0 +S 184 179 255 0 +S 185 184 255 0 +S 186 189 255 0 +S 187 194 255 0 +S 188 199 255 0 +S 189 204 255 0 +S 190 209 255 0 +S 191 214 255 0 +S 192 219 255 0 +S 193 224 255 0 +S 194 230 255 0 +S 195 235 255 0 +S 196 240 255 0 +S 197 245 255 0 +S 198 250 255 0 +S 199 255 255 0 +S 200 255 250 0 +S 201 255 245 0 +S 202 255 240 0 +S 203 255 235 0 +S 204 255 229 0 +S 205 255 224 0 +S 206 255 219 0 +S 207 255 214 0 +S 208 255 209 0 +S 209 255 204 0 +S 210 255 199 0 +S 211 255 194 0 +S 212 255 189 0 +S 213 255 184 0 +S 214 255 178 0 +S 215 255 173 0 +S 216 255 168 0 +S 217 255 163 0 +S 218 255 158 0 +S 219 255 153 0 +S 220 255 148 0 +S 221 255 143 0 +S 222 255 138 0 +S 223 255 133 0 +S 224 255 127 0 +S 225 255 122 0 +S 226 255 117 0 +S 227 255 112 0 +S 228 255 107 0 +S 229 255 102 0 +S 230 255 97 0 +S 231 255 92 0 +S 232 255 87 0 +S 233 255 82 0 +S 234 255 76 0 +S 235 255 71 0 +S 236 255 66 0 +S 237 255 61 0 +S 238 255 56 0 +S 239 255 51 0 +S 240 255 46 0 +S 241 255 41 0 +S 242 255 36 0 +S 243 255 31 0 +S 244 255 25 0 +S 245 255 20 0 +S 246 255 15 0 +S 247 255 10 0 +S 248 255 5 0 +S 249 255 0 0 +S 250 255 0 3 +S 251 255 0 5 +S 252 255 0 8 +S 253 255 0 10 +S 254 255 0 13 +S 255 255 0 16 diff --git a/niftiview7/lut/pink.lut b/niftiview7/lut/pink.lut new file mode 100755 index 0000000..b614ea5 Binary files /dev/null and b/niftiview7/lut/pink.lut differ diff --git a/niftiview7/lut/pink_old.lut b/niftiview7/lut/pink_old.lut new file mode 100755 index 0000000..d87bf6b Binary files /dev/null and b/niftiview7/lut/pink_old.lut differ diff --git a/niftiview7/lut/red_otto.lut b/niftiview7/lut/red_otto.lut new file mode 100755 index 0000000..358622e --- /dev/null +++ b/niftiview7/lut/red_otto.lut @@ -0,0 +1,257 @@ +* s=byte index red green blue +S 0 0 0 0 +S 1 128 0 0 +S 2 128 0 0 +S 3 128 0 0 +S 4 128 0 0 +S 5 128 0 0 +S 6 128 0 0 +S 7 128 0 0 +S 8 128 0 0 +S 9 128 0 0 +S 10 128 0 0 +S 11 128 0 0 +S 12 128 0 0 +S 13 128 0 0 +S 14 128 0 0 +S 15 128 0 0 +S 16 128 0 0 +S 17 128 0 0 +S 18 128 0 0 +S 19 128 0 0 +S 20 128 0 0 +S 21 128 0 0 +S 22 128 0 0 +S 23 128 0 0 +S 24 128 0 0 +S 25 128 0 0 +S 26 128 0 0 +S 27 128 0 0 +S 28 128 0 0 +S 29 128 0 0 +S 30 128 0 0 +S 31 128 0 0 +S 32 128 0 0 +S 33 128 0 0 +S 34 128 0 0 +S 35 128 0 0 +S 36 128 0 0 +S 37 128 0 0 +S 38 128 0 0 +S 39 128 0 0 +S 40 128 0 0 +S 41 128 0 0 +S 42 128 0 0 +S 43 128 0 0 +S 44 128 0 0 +S 45 128 0 0 +S 46 128 0 0 +S 47 128 0 0 +S 48 128 0 0 +S 49 128 0 0 +S 50 128 0 0 +S 51 192 0 32 +S 52 192 0 32 +S 53 192 0 32 +S 54 192 0 32 +S 55 192 0 32 +S 56 192 0 32 +S 57 192 0 32 +S 58 192 0 32 +S 59 192 0 32 +S 60 192 0 32 +S 61 192 0 32 +S 62 192 0 32 +S 63 192 0 32 +S 64 192 0 32 +S 65 192 0 32 +S 66 192 0 32 +S 67 192 0 32 +S 68 192 0 32 +S 69 192 0 32 +S 70 192 0 32 +S 71 192 0 32 +S 72 192 0 32 +S 73 192 0 32 +S 74 192 0 32 +S 75 192 0 32 +S 76 192 0 32 +S 77 192 0 32 +S 78 192 0 32 +S 79 192 0 32 +S 80 192 0 32 +S 81 192 0 32 +S 82 192 0 32 +S 83 192 0 32 +S 84 192 0 32 +S 85 192 0 32 +S 86 192 0 32 +S 87 192 0 32 +S 88 192 0 32 +S 89 192 0 32 +S 90 192 0 32 +S 91 192 0 32 +S 92 192 0 32 +S 93 192 0 32 +S 94 192 0 32 +S 95 192 0 32 +S 96 192 0 32 +S 97 192 0 32 +S 98 192 0 32 +S 99 192 0 32 +S 100 192 0 32 +S 101 192 0 32 +S 102 255 179 0 +S 103 255 179 0 +S 104 255 179 0 +S 105 255 179 0 +S 106 255 179 0 +S 107 255 179 0 +S 108 255 179 0 +S 109 255 179 0 +S 110 255 179 0 +S 111 255 179 0 +S 112 255 179 0 +S 113 255 179 0 +S 114 255 179 0 +S 115 255 179 0 +S 116 255 179 0 +S 117 255 179 0 +S 118 255 179 0 +S 119 255 179 0 +S 120 255 179 0 +S 121 255 179 0 +S 122 255 179 0 +S 123 255 179 0 +S 124 255 179 0 +S 125 255 179 0 +S 126 255 179 0 +S 127 255 179 0 +S 128 255 179 0 +S 129 255 179 0 +S 130 255 179 0 +S 131 255 179 0 +S 132 255 179 0 +S 133 255 179 0 +S 134 255 179 0 +S 135 255 179 0 +S 136 255 179 0 +S 137 255 179 0 +S 138 255 179 0 +S 139 255 179 0 +S 140 255 179 0 +S 141 255 179 0 +S 142 255 179 0 +S 143 255 179 0 +S 144 255 179 0 +S 145 255 179 0 +S 146 255 179 0 +S 147 255 179 0 +S 148 255 179 0 +S 149 255 179 0 +S 150 255 179 0 +S 151 255 179 0 +S 152 255 235 97 +S 153 255 235 97 +S 154 255 235 97 +S 155 255 235 97 +S 156 255 235 97 +S 157 255 235 97 +S 158 255 235 97 +S 159 255 235 97 +S 160 255 235 97 +S 161 255 235 97 +S 162 255 235 97 +S 163 255 235 97 +S 164 255 235 97 +S 165 255 235 97 +S 166 255 235 97 +S 167 255 235 97 +S 168 255 235 97 +S 169 255 235 97 +S 170 255 235 97 +S 171 255 235 97 +S 172 255 235 97 +S 173 255 235 97 +S 174 255 235 97 +S 175 255 235 97 +S 176 255 235 97 +S 177 255 235 97 +S 178 255 235 97 +S 179 255 235 97 +S 180 255 235 97 +S 181 255 235 97 +S 182 255 235 97 +S 183 255 235 97 +S 184 255 235 97 +S 185 255 235 97 +S 186 255 235 97 +S 187 255 235 97 +S 188 255 235 97 +S 189 255 235 97 +S 190 255 235 97 +S 191 255 235 97 +S 192 255 235 97 +S 193 255 235 97 +S 194 255 235 97 +S 195 255 235 97 +S 196 255 235 97 +S 197 255 235 97 +S 198 255 235 97 +S 199 255 235 97 +S 200 255 235 97 +S 201 255 235 97 +S 202 255 235 97 +S 203 255 235 97 +S 204 255 235 97 +S 205 255 255 200 +S 206 255 255 200 +S 207 255 255 200 +S 208 255 255 200 +S 209 255 255 200 +S 210 255 255 200 +S 211 255 255 200 +S 212 255 255 200 +S 213 255 255 200 +S 214 255 255 200 +S 215 255 255 200 +S 216 255 255 200 +S 217 255 255 200 +S 218 255 255 200 +S 219 255 255 200 +S 220 255 255 200 +S 221 255 255 200 +S 222 255 255 200 +S 223 255 255 200 +S 224 255 255 200 +S 225 255 255 200 +S 226 255 255 200 +S 227 255 255 200 +S 228 255 255 200 +S 229 255 255 200 +S 230 255 255 200 +S 231 255 255 200 +S 232 255 255 200 +S 233 255 255 200 +S 234 255 255 200 +S 235 255 255 200 +S 236 255 255 200 +S 237 255 255 200 +S 238 255 255 200 +S 239 255 255 200 +S 240 255 255 200 +S 241 255 255 200 +S 242 255 255 200 +S 243 255 255 200 +S 244 255 255 200 +S 245 255 255 200 +S 246 255 255 200 +S 247 255 255 200 +S 248 255 255 200 +S 249 255 255 200 +S 250 255 255 200 +S 251 255 255 200 +S 252 255 255 200 +S 253 255 255 200 +S 254 255 255 200 +S 255 255 255 200 \ No newline at end of file diff --git a/niftiview7/lut/spectrum.lut b/niftiview7/lut/spectrum.lut new file mode 100755 index 0000000..f77a7d5 Binary files /dev/null and b/niftiview7/lut/spectrum.lut differ diff --git a/niftiview7/lut/surface.lut b/niftiview7/lut/surface.lut new file mode 100755 index 0000000..68b28d9 --- /dev/null +++ b/niftiview7/lut/surface.lut @@ -0,0 +1,5 @@ + + !"$%&()+,./124578:;=>@ACDFGIJKMNPQSTVWYZ\]_`bcefhiklnoprsuvxy{|~‚„…‡ˆŠ‹Ž‘“”•—˜š›ž ¡£¤¦§©ª¬­¯°²³µ¶¸¹º¼½¿ÀÂÃÅÆÈÉËÌÎÏÑÒÔÕ×ØÚÛÝÞßáâäåçèêëíîðñóôö÷ùúüýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ +  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«¬­®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿÿ + +  !"##$%&&'(()*++,-../01123345667899:;<<=>??@AABCDDEFGGHIJJKLLMNOOPQRRSTUUVWXXYZZ[\]]^_``abccdeefghhijkklmnnopqqrsstuvvwxyyz{||}~~€‚ƒ„„…†‡‡ˆ‰ŠŠ‹ŒŒŽ‘’’“”••–——˜™šš›œžŸ  ¡¢££¤¥¥¦§¨¨©ª««¬­®®¯°´¹¾ÃÈÍÒ×Üáæëðõúüÿ \ No newline at end of file diff --git a/niftiview7/lut/thresholdmiddle.lut b/niftiview7/lut/thresholdmiddle.lut new file mode 100755 index 0000000..c66ea77 --- /dev/null +++ b/niftiview7/lut/thresholdmiddle.lut @@ -0,0 +1,257 @@ +* s=byte index red green blue +S 0 0 0 0 +S 1 250 0 255 +S 2 245 0 255 +S 3 240 0 255 +S 4 235 0 255 +S 5 230 0 255 +S 6 224 0 255 +S 7 219 0 255 +S 8 214 0 255 +S 9 209 0 255 +S 10 204 0 255 +S 11 199 0 255 +S 12 194 0 255 +S 13 189 0 255 +S 14 184 0 255 +S 15 179 0 255 +S 16 173 0 255 +S 17 168 0 255 +S 18 163 0 255 +S 19 158 0 255 +S 20 153 0 255 +S 21 148 0 255 +S 22 143 0 255 +S 23 138 0 255 +S 24 133 0 255 +S 25 128 0 255 +S 26 122 0 255 +S 27 117 0 255 +S 28 112 0 255 +S 29 107 0 255 +S 30 102 0 255 +S 31 97 0 255 +S 32 92 0 255 +S 33 87 0 255 +S 34 82 0 255 +S 35 77 0 255 +S 36 71 0 255 +S 37 66 0 255 +S 38 61 0 255 +S 39 56 0 255 +S 40 51 0 255 +S 41 46 0 255 +S 42 41 0 255 +S 43 36 0 255 +S 44 31 0 255 +S 45 26 0 255 +S 46 20 0 255 +S 47 15 0 255 +S 48 10 0 255 +S 49 5 0 255 +S 50 0 5 255 +S 51 0 10 255 +S 52 0 15 255 +S 53 0 20 255 +S 54 0 26 255 +S 55 0 31 255 +S 56 0 36 255 +S 57 0 41 255 +S 58 0 46 255 +S 59 0 51 255 +S 60 0 56 255 +S 61 0 61 255 +S 62 0 66 255 +S 63 0 71 255 +S 64 0 77 255 +S 65 0 82 255 +S 66 0 87 255 +S 67 0 92 255 +S 68 0 97 255 +S 69 0 102 255 +S 70 0 107 255 +S 71 0 112 255 +S 72 0 117 255 +S 73 0 122 255 +S 74 0 128 255 +S 75 0 133 255 +S 76 0 138 255 +S 77 0 143 255 +S 78 0 148 255 +S 79 0 153 255 +S 80 0 158 255 +S 81 0 163 255 +S 82 0 168 255 +S 83 0 173 255 +S 84 0 179 255 +S 85 0 184 255 +S 86 0 189 255 +S 87 0 194 255 +S 88 0 199 255 +S 89 0 204 255 +S 90 0 209 255 +S 91 0 214 255 +S 92 0 219 255 +S 93 0 224 255 +S 94 0 230 255 +S 95 0 235 255 +S 96 0 240 255 +S 97 0 245 255 +S 98 0 250 255 +S 99 0 255 255 +S 100 0 255 250 +S 101 0 255 245 +S 102 0 255 240 +S 103 0 255 235 +S 104 0 255 229 +S 105 0 255 224 +S 106 0 255 219 +S 107 0 255 214 +S 108 0 255 209 +S 109 0 255 204 +S 110 0 255 199 +S 111 0 255 194 +S 112 0 255 189 +S 113 0 255 184 +S 114 0 255 178 +S 115 0 255 173 +S 116 0 255 168 +S 117 0 255 163 +S 118 0 255 158 +S 119 0 255 153 +S 120 0 255 148 +S 121 0 255 143 +S 122 0 255 138 +S 123 0 255 133 +S 124 0 255 127 +S 125 0 255 122 +S 126 0 255 117 +S 127 0 255 112 +S 128 0 255 107 +S 129 0 255 102 +S 130 0 255 97 +S 131 0 255 92 +S 132 0 255 87 +S 133 0 255 82 +S 134 0 255 76 +S 135 0 255 71 +S 136 0 255 66 +S 137 0 255 61 +S 138 0 255 56 +S 139 0 255 51 +S 140 0 255 46 +S 141 0 255 41 +S 142 0 255 36 +S 143 0 255 31 +S 144 0 255 25 +S 145 0 255 20 +S 146 0 255 15 +S 147 0 255 10 +S 148 0 255 5 +S 149 0 255 0 +S 150 5 255 0 +S 151 10 255 0 +S 152 15 255 0 +S 153 20 255 0 +S 154 26 255 0 +S 155 31 255 0 +S 156 36 255 0 +S 157 41 255 0 +S 158 46 255 0 +S 159 51 255 0 +S 160 56 255 0 +S 161 61 255 0 +S 162 66 255 0 +S 163 71 255 0 +S 164 77 255 0 +S 165 82 255 0 +S 166 87 255 0 +S 167 92 255 0 +S 168 97 255 0 +S 169 102 255 0 +S 170 107 255 0 +S 171 112 255 0 +S 172 117 255 0 +S 173 122 255 0 +S 174 128 255 0 +S 175 133 255 0 +S 176 138 255 0 +S 177 143 255 0 +S 178 148 255 0 +S 179 153 255 0 +S 180 158 255 0 +S 181 163 255 0 +S 182 168 255 0 +S 183 173 255 0 +S 184 179 255 0 +S 185 184 255 0 +S 186 189 255 0 +S 187 194 255 0 +S 188 199 255 0 +S 189 204 255 0 +S 190 209 255 0 +S 191 214 255 0 +S 192 219 255 0 +S 193 224 255 0 +S 194 230 255 0 +S 195 235 255 0 +S 196 240 255 0 +S 197 245 255 0 +S 198 250 255 0 +S 199 255 255 0 +S 200 255 250 0 +S 201 255 245 0 +S 202 255 240 0 +S 203 255 235 0 +S 204 255 229 0 +S 205 255 224 0 +S 206 255 219 0 +S 207 255 214 0 +S 208 255 209 0 +S 209 255 204 0 +S 210 255 199 0 +S 211 255 194 0 +S 212 255 189 0 +S 213 255 184 0 +S 214 255 178 0 +S 215 255 173 0 +S 216 255 168 0 +S 217 255 163 0 +S 218 255 158 0 +S 219 255 153 0 +S 220 255 148 0 +S 221 255 143 0 +S 222 255 138 0 +S 223 255 133 0 +S 224 255 127 0 +S 225 255 122 0 +S 226 255 117 0 +S 227 255 112 0 +S 228 255 107 0 +S 229 255 102 0 +S 230 255 97 0 +S 231 255 92 0 +S 232 255 87 0 +S 233 255 82 0 +S 234 255 76 0 +S 235 255 71 0 +S 236 255 66 0 +S 237 255 61 0 +S 238 255 56 0 +S 239 255 51 0 +S 240 255 46 0 +S 241 255 41 0 +S 242 255 36 0 +S 243 255 31 0 +S 244 255 25 0 +S 245 255 20 0 +S 246 255 15 0 +S 247 255 10 0 +S 248 255 5 0 +S 249 255 0 0 +S 250 255 0 3 +S 251 255 0 5 +S 252 255 0 8 +S 253 255 0 10 +S 254 255 0 13 +S 255 0 0 0 \ No newline at end of file diff --git a/niftiview7/lut/wNIH.lut b/niftiview7/lut/wNIH.lut new file mode 100755 index 0000000..a40ecc8 Binary files /dev/null and b/niftiview7/lut/wNIH.lut differ diff --git a/niftiview7/lut/x_hot.lut b/niftiview7/lut/x_hot.lut new file mode 100755 index 0000000..291ee87 Binary files /dev/null and b/niftiview7/lut/x_hot.lut differ diff --git a/niftiview7/lut/x_rain.lut b/niftiview7/lut/x_rain.lut new file mode 100755 index 0000000..94ae461 Binary files /dev/null and b/niftiview7/lut/x_rain.lut differ diff --git a/niftiview7/madGraphics.pas b/niftiview7/madGraphics.pas new file mode 100755 index 0000000..ad9c6ee --- /dev/null +++ b/niftiview7/madGraphics.pas @@ -0,0 +1,112 @@ +// *************************************************************** +// tiny madGraphics.pas version: 1.0 · date: 2001-03-04 +// ------------------------------------------------------------- +// gray scaling, smooth stretching, alpha blending, ... +// ------------------------------------------------------------- +// Copyright (C) 1999 - 2001 www.madshi.net, All Rights Reserved +// *************************************************************** + +unit madGraphics; + + +{$R-}{$Q-} + +interface + +uses Windows, Graphics,define_types; + + + +procedure StretchBitmap (srcBmp, dstBmp : TBitmap; + quality : TStretchQuality = sqHigh); + +implementation + +uses SysUtils, Classes, Math, CommCtrl; + + + +procedure StretchBitmap(srcBmp, dstBmp : TBitmap; quality : TStretchQuality = sqHigh); + procedure Bilinear32; // 525 -> 305 + var ix, iy : integer; + x, y, xdif, ydif : integer; + xp1, xp2, yp : integer; + wy, wyi, wx : integer; + w11, w21, w12, w22 : integer; + sbBits, sbLine1, sbLine2 : PByteArray; + {smBits,} smLine1{, smLine2} : PByteArray; + dbLine : PByteArray; + //dmLine : ^byte; + sbLineDif, dbLineDif : integer; + //smLineDif, dmLineDif : integer; + w : integer; +begin + xdif := (srcBmp.Width shl 16) div (dstBmp.Width);//CR: +1 avoids slight scaling distortion + ydif := (srcBmp.Height shl 16) div (dstBmp.Height);//CR: +1 avoids slight scaling distortion + y := 0; + sbBits := srcBmp.ScanLine[0]; + if srcBmp.Height > 1 then + sbLineDif := integer(srcBmp.ScanLine[1]) - integer(sbBits) + else sbLineDif := 0; + dbLine := dstBmp.ScanLine[0]; + if dstBmp.Height > 1 then + dbLineDif := integer(dstBmp.ScanLine[1]) - integer(dbLine) - 4 * dstBmp.Width + else dbLineDif := 0; + //smBits := nil; + //smLineDif := 0; + //dmLine := nil; + //dmLineDif := 0; + + w := srcBmp.Width - 1; + for iy := 0 to dstBmp.Height - 1 do begin + yp := y shr 16; + integer(sbLine1) := integer(sbBits) + sbLineDif * yp; + integer(smLine1) := integer({smBits}nil) {+ smLineDif * yp}; + if yp < srcBmp.Height - 1 then begin + integer(sbLine2) := integer(sbLine1) + sbLineDif; + end else begin + sbLine2 := sbLine1; + //smLine2 := smLine1; + end; + x := 0; + wy := y and $FFFF; + wyi := (not y) and $FFFF; + for ix := 0 to dstBmp.Width - 1 do begin + xp1 := x shr 16; + if xp1 < w then xp2 := xp1 + 1 + else xp2 := xp1; + wx := x and $FFFF; + w21 := (wyi * wx) shr 16; w11 := wyi - w21; + w22 := (wy * wx) shr 16; w12 := wy - w22; + {if smLine1 <> nil then begin + w11 := (w11 * (256 - smLine1^[xp1])) shr 8; + w21 := (w21 * (256 - smLine1^[xp2])) shr 8; + w12 := (w12 * (256 - smLine2^[xp1])) shr 8; + w22 := (w22 * (256 - smLine2^[xp2])) shr 8; + dmLine^ := 255 - byte((w11 + w21 + w12 + w22) shr 8); + end;} + xp1 := xp1 * 4; + xp2 := xp2 * 4; + {blue}dbLine^[0] := (sbLine1[xp1 ] * w11 + sbLine1[xp2 ] * w21 + sbLine2[xp1 ] * w12 + sbLine2[xp2 ] * w22) shr 16; + {green}dbLine^[1] := (sbLine1[xp1 + 1] * w11 + sbLine1[xp2 + 1] * w21 + sbLine2[xp1 + 1] * w12 + sbLine2[xp2 + 1] * w22) shr 16; + {red}dbLine^[2] := (sbLine1[xp1 + 2] * w11 + sbLine1[xp2 + 2] * w21 + sbLine2[xp1 + 2] * w12 + sbLine2[xp2 + 2] * w22) shr 16; + inc(integer(dbLine), 4); + //inc(dmLine); + inc(x, xdif); + //if ix = 0 then + // inc(x, Hlfxdif); + end; + inc(integer(dbLine), dbLineDif); + //inc(integer(dmLine), dmLineDif); + inc(y, ydif); + //if iy = 0 then + // inc(y, Hlfydif); + end; +end; +begin + case quality of + sqLow : dstBmp.Canvas.StretchDraw(Rect(0, 0, dstBmp.Width, dstBmp.Height), srcBmp); + sqHigh : Bilinear32; + end; //case +end; +end. diff --git a/niftiview7/metagraph.pas b/niftiview7/metagraph.pas new file mode 100755 index 0000000..a2f9751 --- /dev/null +++ b/niftiview7/metagraph.pas @@ -0,0 +1,685 @@ +unit metagraph; +interface + +uses + {$IFNDEF Unix}Windows, Messages, {$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Buttons, ToolWin, ComCtrls,define_types, ExtCtrls, StdCtrls, Menus,ClipBrd; + +const + kMaxCond = 6; + knMaxRow = 20; //Niftiimgvie + kMaxLines = kMaxCond* knMaxRow; + kClrRA: array [1..kMaxCond] of TColor = (clRed,clGreen,clBlue,clTeal,clAqua,clSilver); + kPenStyleRA: array[1..knMaxRow] of TPenStyle = (psSolid,psDot,psDash,psDashDot,psDashDotDot,psSolid,psDot,psDash,psDashDot,psDashDotDot, + psSolid,psDot,psDash,psDashDot,psDashDotDot,psSolid,psDot,psDash,psDashDot,psDashDotDot); +type + TEventOnset = RECORD + Events: integer; + ELabel: string[16]; + EventRA,DurRA: SingleP; + END; + + T4DTrace = RECORD + //Title: string[16]; + //Samples: integer; + HorzMin,HorzWidPerBin,SampleMin,SampleMax,SamplePlotMin,SamplePlotMax: Double; + Lines: array [1..kMaxLines] of TEventOnset; + Conditions: array [1..kMaxLines] of TEventOnset; + //DurationRA: array [1..kMaxLines] of SingleP; + END; +procedure Create4DTrace (var l4DTrace: T4DTrace); +procedure Init4DTrace(lnSample,lnLines: integer; var l4DTrace: T4DTrace; lErrorBars: boolean); +procedure Close4DTrace (var l4DTrace: T4DTrace; lCloseCond: boolean); +procedure MinMax4DTrace(var l4DTrace: T4DTrace); +procedure CorePlot4DTrace(var l4DTrace: T4DTrace; lImage: TImage; lStartSample,HSpeed,lnColors: integer;lTR,lVertMin,lVertMax: single; lErrorBars: boolean); +procedure GraphResize(lImage: TImage); +procedure CloseCond (var l4DTrace: T4DTrace; lCond: integer); +procedure InitCond (var l4DTrace: T4DTrace; lCond, lnEvents: integer); + + +{$IFNDEF FPC} var gWmf: TMetafile; {$ENDIF} +implementation + + + +procedure GraphResize(lImage: TImage); +var + TempBitmap: TBitmap; + lx,ly: integer; +begin + lx := lImage.Width; + ly := lImage.Height; + TempBitmap := TBitmap.Create; + TempBitmap.Width := lx; + TempBitmap.Height := ly; + //Draw32Bitmap(TempBitmap.Canvas.Handle, lx, ly,lBuff {Self}); + lImage.Picture.Bitmap := TempBitmap; + lImage.Width := lx;//delphi + lImage.Height := ly;//delphi + TempBitmap.Free; +end; + +function RealToStr(lR: double {was extended}; lDec: integer): string; +begin + if lR > 99999 then + RealTOStr := FloatToStrF(lR, ffExponent ,lDec,7) + else + RealTOStr := FloatToStrF(lR, ffFixed,7,lDec); +end; + +procedure Create4DTrace (var l4DTrace: T4DTrace); +var + lLine: integer; +begin + with l4DTrace do begin + for lLine := 1 to kMaxLines do begin + Lines[lLine].events := 0; + Lines[lLine].elabel := ''; + Conditions[lLine].events := 0; + Conditions[lLine].elabel := ''; + + end; + end; //with trace +end; + +procedure Init4DTrace(lnSample,lnLines: integer; var l4DTrace: T4DTrace; lErrorBars: boolean); +var + lLine: integer; +begin + Close4DTrace(l4DTrace,lErrorBars); + if (lnSample < 1) or (lnLines < 1) then + exit; + with l4DTrace do begin + HorzMin := 0; + HorzWidPerBin := 1; + for lLine := 1 to lnLines do begin + getmem(Lines[lLine].EventRA,lnSample*sizeof(single)); + Lines[lLine].events := lnSample; + if lErrorBars then begin + getmem(Conditions[lLine].EventRA,lnSample*sizeof(single)); + getmem(Conditions[lLine].DurRA,lnSample*sizeof(single)); + Conditions[lLine].events := lnSample; + end; + end; //for each line + end; //with trace +end; + +procedure Close4DTrace (var l4DTrace: T4DTrace; lCloseCond: boolean); +var + lLine: integer; +begin + with l4DTrace do begin + for lLine := 1 to kMaxLines do begin + if Lines[lLine].events > 0 then begin + + freemem(Lines[lLine].EventRA); + end; + Lines[lLine].events := 0; + if lCloseCond then begin + if Conditions[lLine].events > 0 then begin + freemem(Conditions[lLine].EventRA); + freemem(Conditions[lLine].DurRA); //1/1/2008 + end; + Conditions[lLine].events := 0; + end; + end; //for each Line + end; //with trace +end; + +procedure CloseCond (var l4DTrace: T4DTrace; lCond: integer); +begin + if (lCond < 1) or (lCond > kMaxLines) then + exit; + if l4DTrace.Conditions[lCond].events > 0 then begin + freemem(l4DTrace.Conditions[lCond].EventRA); + freemem(l4DTrace.Conditions[lCond].DurRA); + + end; + l4DTrace.Conditions[lCond].events := 0; +end; + +procedure InitCond (var l4DTrace: T4DTrace; lCond, lnEvents: integer); +begin + if (lCond < 1) or (lCond > kMaxLines) then + exit; + CloseCond (l4DTrace, lCond); + if lnEvents > 0 then begin + getmem(l4DTrace.Conditions[lCond].EventRA, lnEvents * sizeof(single)); + getmem(l4DTrace.Conditions[lCond].DurRA,lnEvents*sizeof(single)); + //fx(lLine,lnSample); + end; + l4DTrace.Conditions[lCond].events := lnEvents; +end; + +procedure MinMax4DTrace(var l4DTrace: T4DTrace); +var lPos,lLine: integer; +l1stLine :boolean; +begin + l1stLine := true; + with l4DTrace do begin + for lLine := 1 to kMaxLines do begin + if Lines[lLine].events > 0 then begin + if l1stLine then begin + SampleMin := Lines[lLine].EventRA^[1]; + SampleMax:= Lines[lLine].EventRA^[1]; + end; + l1stLine := false; + + for lPos := 1 to Lines[lLine].events do begin + if Lines[lLine].EventRA^[lPos] > SampleMax then + SampleMax := Lines[lLine].EventRA^[lPos]; + if Lines[lLine].EventRA^[lPos] < SampleMin then + SampleMin := Lines[lLine].EventRA^[lPos]; + end; //for each event + end; //if events > 0 + end; //for each line + SamplePlotMin := SampleMin-0.1*abs(SampleMax-SampleMin); + SamplePlotMax := SampleMax+0.1*abs(SampleMax-SampleMin); + end; //with trace +end; + +{$IFDEF FPC} +procedure HText(lImage: TImage; lX,lY,lDec: integer; lVal: single); +{$ELSE} +procedure HText(lImage: TMetafileCanvas; lX,lY,lDec: integer; lVal: single); +{$ENDIF} +var + lStr: string; +begin + if lDec >= 0 then + lStr := realtostr(round(lVal),0) + else + lStr := realtostr(lVal,abs(lDec)); +{$IFDEF FPC} + lImage.Canvas.TextOut(lX-(lImage.Canvas.TextWidth(lStr) shr 1),lY,lStr); +{$ELSE} + lImage.TextOut(lX-(lImage.TextWidth(lStr) shr 1),lY,lStr); +{$ENDIF} +end; + +{$IFDEF FPC} +procedure VText(lImage: TImage; lX,lY,lDec: integer; lVal: single); +{$ELSE} +procedure VText(lImage: TMetafileCanvas; lX,lY,lDec: integer; lVal: single); +{$ENDIF} +var + lStr: string; +begin + if lDec >= 0 then + lStr := realtostr(round(lVal),0) + else + lStr := realtostr(lVal,abs(lDec)); +{$IFDEF FPC} + lImage.Canvas.TextOut(lX-lImage.Canvas.TextWidth(lStr) ,lY,lStr); +{$ELSE} + lImage.TextOut(lX-lImage.TextWidth(lStr) ,lY,lStr); +{$ENDIF} + +end; + +{$IFDEF FPC} +procedure VTextLeftJustified(lImage: TIMage; lX,lY,lDec: integer; lVal: single); +{$ELSE} +procedure VTextLeftJustified(lImage: TMetafileCanvas; lX,lY,lDec: integer; lVal: single); +{$ENDIF} +var + lStr: string; +begin + if lDec >= 0 then + lStr := inttostr(round(lVal)) + else + lStr := realtostr(lVal,abs(lDec)); +{$IFDEF FPC} + lImage.Canvas.TextOut(lX ,lY,lStr); +{$ELSE} + lImage.TextOut(lX ,lY,lStr); +{$ENDIF} + +end; + +{$IFDEF FPC} +procedure ShowRange(lImage: TImage; lMin,lMax: single; lL,lT,lR,lB,lPosition: integer); +{$ELSE} +procedure ShowRange(lImage: TMetafileCanvas; lMin,lMax: single; lL,lT,lR,lB,lPosition: integer); +{$ENDIF} +//position 1=L,2=T,3=R,4=B +var + lRangeR,lRange,lD,lV: double; + lDecimals,lPos,lLo,lHi,lHPos,lOffset : integer; +begin +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + Font.color := clBlack; + lRange := abs(lMax-lMin); + lRangeR := lRange; + lDecimals := 0; + lD := 1; + if lRangeR = 0 then + exit; + while lRangeR > 10 do begin//get range 1..10 + lRangeR := lRangeR / 10; + inc(lDecimals); + lD := lD * 10; + end; + while lRangeR < 1 do begin//get range 1..10 + lRangeR := lRangeR * 10; + dec(lDecimals); + lD := lD / 10; + end; + lLo := round((lMin + (lD/2)) / lD); + lHi := trunc((lMax + (lD/20) ) / lD);//2007 + //lHi := trunc((lMax ) / lD); + if lHi <= (lLo+2) then begin + lD := lD /2; + if lDecimals <= 0 then + dec(lDecimals) + else + inc(lDecimals); + lLo := round((lMin + (lD/2)) / lD); + lHi := trunc((lMax + (lD/20) ) / lD);//2007 + end; + if (lPosition = 2{T}) or (lPosition = 4{B}) then begin + lOffset := TextHeight('0'); + for lPos := lLo to lHi do begin + lV := lPos * lD; + lHPos := lL+ round( ((lV-lMin) / lRange)* abs(lR-lL)); + if (lPosition = 2{T}) then + HText(lImage, lHPos,lT- lOffset,lDecimals,lV) + else + HText(lImage, lHPos,lB+1,lDecimals,lV); + end; + end else if (lPosition = 1{L}) or (lPosition = 3{R}) then begin //vertical values + lOffset := TextHeight('0') div 2; //2007 + for lPos := lLo to lHi do begin + lV := lPos * lD; + {lHPos := lB- round( ((lV-lMin) / lRange)* abs(lT-lB)); + lImage.MoveTo(1,lHPos); + lImage.LineTo(1000,lHPos);} + lHPos := lB- round( ((lV-lMin) / lRange)* abs(lT-lB))-lOffset; + + if (lPosition = 1{L}) then + VText(lImage, lL-1,lHPos,lDecimals,lV) + else + VTextLeftJustified(lImage, lR+1,lHPos,lDecimals,lV); + end; + + end; //if vertical + end; //with limage +end; + +{$IFDEF FPC} +function ShowLegend(var l4DTrace: T4DTrace; lImage: TImage; lL,lT: integer): integer; +{$ELSE} +function ShowLegend(var l4DTrace: T4DTrace; lImage: TMetafileCanvas; lL,lT: integer): integer; +{$ENDIF} +var + lC,lLegendLeft: integer; +begin +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + lLegendLeft := lL; + font.color := clBlack; + for lC := 1 to kMaxCond do begin + //lImage.canvas.pen.color := kClrRA[lC]; + font.color := kClrRA[lC] ; + if (l4DTrace.Conditions[lC].events > 0) then begin + TextOut(lLegendLeft,lT,l4DTrace.Conditions[lC].ELabel); + lLegendLeft := lLegendLeft + TextWidth(l4DTrace.Conditions[lC].ELabel)+5; + end; //for each tevent + end; //if cond has events + result := lLegendLeft; +end; //with limage +end; //for each cond + +function n4DTrace(var l4DTrace: T4DTrace;var lSamples: integer; lErrorBars: boolean): integer; +var lLine: integer; +l1stLine :boolean; +begin + lSamples:= 0; + result := 0; + l1stLine := true; + with l4DTrace do begin + for lLine := 1 to kMaxLines do begin + if Lines[lLine].events > 0 then begin + if l1stLine then + lSamples := Lines[lLine].events; + l1stLine := false; + if (lErrorBars) and (Lines[lLine].events <> lSamples) then + exit; //all lines must have same number of samples + inc(result); + end; //if events > 0 + end; //for each line + end; //with trace +end; + +{$IFDEF FPC} +function SetColorStyle (lImage: TImage; lLine,lnColors: integer): TPenStyle; +{$ELSE} +function SetColorStyle (lImage: TMetafileCanvas; lLine,lnColors: integer): TPenStyle; +{$ENDIF} +var + lC: integer; +begin +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + if lnColors < 1 then begin + pen.color := clBlack;//clRed + pen.style := kPenStyleRA[lLine]; + result := kPenStyleRA[lLine]; + exit; + end; + lC := lLine mod lnColors; + if lC = 0 then + lC := lnColors; + pen.color := kClrRA[lC]; + lC := ((lLine-1) div lnColors)+1; + pen.style := kPenStyleRA[lC]; + result := kPenStyleRA[lC]; +end; //with lImage. +end; + +{$IFDEF FPC} +procedure ShowLineLegend(var l4DTrace: T4DTrace; lImage: TImage; lL, lT,lnLines,lnColors: integer); +{$ELSE} +procedure ShowLineLegend(var l4DTrace: T4DTrace; lImage: TMetafileCanvas; lL, lT,lnLines,lnColors: integer); +{$ENDIF} +var + lLineTop,lStyle,lnStyles,lLegendLeft: integer; +begin + if lnColors < 1 then + lnStyles := lnLines + else + lnStyles := lnLines div lnColors; + if lnStyles < 1 then + lnStyles := 1; +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + + font.color := clBlack; + pen.color := clBlack; + lLegendLeft := lL; + lLineTop := lT+(TextHeight('X') div 2); + for lStyle := 1 to lnStyles do begin + pen.style := kPenStyleRA[lStyle]; + MoveTo(lLegendLeft,lLineTop); + lLegendLeft := lLegendLeft +40; + LineTo(lLegendLeft,lLineTop); + lLegendLeft := lLegendLeft + 2; + TextOut(lLegendLeft,lT,l4DTrace.Lines[lStyle].ELabel); + lLegendLeft := lLegendLeft + TextWidth(l4DTrace.Lines[lStyle].ELabel)+5; + end; + pen.style := psSolid; +end;//with lImage. +end; + +{$IFDEF FPC} +procedure ShowPlot(var l4DTrace: T4DTrace; lImage: TImage; lL,lT,lR,lB,lStartSample,lHSpeedIn,lScalePos,lnColors: integer; lSecPerSample,lVertMin,lVertMax: single; lShowHRange,lErrorBars: boolean); +{$ELSE} +procedure ShowPlot(var l4DTrace: T4DTrace; lImage: TMetafileCanvas; lL,lT,lR,lB,lStartSample,lHSpeedIn,lScalePos,lnColors: integer; lSecPerSample,lVertMin,lVertMax: single; lShowHRange,lErrorBars: boolean); +{$ENDIF} +const + kMinMax = 0; + k2SD = 1; + k12bit = 2; + kMaxPt = 16000; +type + TPtRA= array [1..kMaxPt] of TPoint; +var + lnPt,lnLines,lLine,lnSamples,lC,lStartSamp,lEndSamp,lEndPix,lPos,lI: integer; + lVert,lHorz,lVMax,lVMin,lScale,lHSpeed: single; + lPenStyle: TPenStyle; + lPtRA: TPtRA; +begin + lnLines := n4DTrace(l4DTrace,lnSamples,lErrorBars); + if (lnLines < 1) or (lnSamples < 2) or (lB <= lT) then exit; + lStartSamp := lStartSample; + if (lStartSamp > lnSamples) then + exit; + if lStartSamp < 1 then + lStartSamp := 1; + lHSpeed := lHSpeedIn; + if lHSpeed < 1 then begin + lStartSamp := 1; + lHSpeed := (lnSamples-1)/(lR-lL); + end; +{$IFDEF FPC} +with lImage.Canvas do begin +{$ELSE} +with lImage do begin +{$ENDIF} + lEndSamp := trunc(lStartSamp + ((lR-lL)*lHSpeed))+1; + ShowRange(lImage, l4DTrace.HorzMin+((lStartSamp-1)*l4DTrace.HorzWidPerBin),l4DTrace.HorzMin+((lEndSamp-1)*l4DTrace.HorzWidPerBin),lL,lT,lR,lB,4); + if lShowHRange then + ShowRange(lImage, l4DTrace.HorzMin+((lStartSamp-1)*l4DTrace.HorzWidPerBin),l4DTrace.HorzMin+((lEndSamp-1)*l4DTrace.HorzWidPerBin),lL,lT,lR,lB,4); + + lI := ShowLegend(l4DTrace,lImage, lL,5); + ShowLineLegend(l4DTrace, lImage, lI+10, 5,lnLines,lnColors); + //next show event onsets + if not lErrorBars then + for lC := 1 to kMaxCond do begin + pen.color := kClrRA[lC]; + if (l4DTrace.Conditions[lC].events > 0) and (lSecPerSample > 0) then begin + //canvas.TextOut(lLegendLeft,lT-canvas.TextHeight('X')-2,l4DTrace.Conditions[lC].ELabel); + //lLegendLeft := lLegendLeft + canvas.TextWidth(l4DTrace.Conditions[lC].ELabel)+5; + for lPos := 1 to l4DTrace.Conditions[lC].events do begin + lHorz := l4DTrace.Conditions[lC].EventRA^[lPos] / lSecPerSample; + if (lHorz < lEndSamp) and (lHorz > lStartSamp) then begin + lVert := ((lHorz - lStartSamp) / lHSpeed)+lL; + moveto(round(lVert),lT); + lineto(round(lVert),lB); + end; //if event in range + end; //for each tevent + end; //if cond has events + end; //for each cond + if (lEndSamp > lnSamples) then begin + lEndSamp := lnSamples; + lEndPix := lL+trunc((lnSamples-lStartSamp) / lHSpeed); + end else + lEndPix := lR; + lVMax := lVertMax; + lVMin := lVertMin; + if (lVMax <= lVMin) then begin + lVMax := l4DTrace.SamplePlotMax; + lVMin := l4DTrace.SamplePlotMin; + end; + if (lVMax < l4DTrace.SampleMin) or (lVMin > l4DTrace.SampleMax) then begin + lVMax := l4DTrace.SamplePlotMax; + lVMin := l4DTrace.SamplePlotMin; + end; + + ShowRange(lImage,lVMin,lVMax,lL,lT,lR,lB,lScalePos); + moveto(lL,lT); + if lVMax <= lVMin then + lScale := 1 + else + lScale := (lB-lT)/ (lVMax-lVMin); + if lHSpeed < 1 then begin + //lHSpeed := (l4DTrace.Samples-1)/(lR-lL); + for lLine := 1 to lnLines do begin + lPenStyle := SetColorStyle (lImage, lLine,lnColors); + lnPt := 0; + for lPos := lStartSamp to lEndSamp do begin + lVert := l4DTrace.Lines[lLine].EventRA^[lPos]; + if lVert > lVMax then + lVert := lVMax + else if lVert < lVMin then + lVert := lVMin; + lVert := round((lVert-lVMin)*lScale); + lVert := lB-lVert; + lHorz := lL+round((lPos-lStartSamp)/lHSpeed); + inc(lnPt); + if lnPt < kMaxPt then + lPtRA[lnPt] := Point(round(lHorz),round(lVert)); + if lErrorBars then begin + pen.style := psSolid; + moveto(round(lHorz),round(lVert-(l4DTrace.Conditions[lLine].EventRA^[lPos]*lScale))); + lineto(round(lHorz) ,round(lVert+(l4DTrace.Conditions[lLine].EventRA^[lPos]*lScale))); + moveto(round(lHorz) ,round(lVert)); + pen.style := lPenStyle; + end; + end; //for lPos + if lnPt > kMaxPt then + lnPt := kMaxPt; + if lnPt > 0 then + PolyLine( Slice(lPtRA, lnPt)); + + end; //for each line + end else begin //HSpeed >=1 so every pixel unique + for lLine := 1 to lnLines do begin + lPenStyle := SetColorStyle (lImage, lLine,lnColors); + lI := lStartSamp; + lnPt := 0; + for lPos := lL to lEndPix do begin + lVert := l4DTrace.Lines[lLine].EventRA^[lI]; + if lVert > lVMax then + lVert := lVMax + else if lVert < lVMin then + lVert := lVMin; + lVert := round((lVert-lVMin)*lScale); + //lVert := lVert + lT; + lVert := lB-lVert; + inc(lnPt); + if lnPt < kMaxPt then + lPtRA[lnPt] := Point(lPos,round(lVert)); + + if lErrorBars then begin + pen.style := psSolid; + moveto(lPos,round(lVert-(l4DTrace.Conditions[lLine].EventRA^[lPos]*lScale))); + lineto(lPos ,round(lVert+(l4DTrace.Conditions[lLine].EventRA^[lPos]*lScale))); + moveto(lPos ,round(lVert)); + pen.style := lPenStyle; + end; + lI := round( lStartSamp+((lPos-lL)*lHSpeed) ); + if lI < 1 then + lI := 1; + if lI > lEndSamp then + lI := lEndSamp; + end; //for lPos + if lnPt > kMaxPt then + lnPt := kMaxPt; + if lnPt > 0 then + PolyLine( Slice(lPtRA, lnPt)) + + end; //for each line + end; //hspeed >= 1 + pen.style := psSolid; +end;//with .lImage +end; + + + +procedure DrawBMP( lx, ly: integer; {lBuff: RGBQuadp;} var lImage: TImage); +var + TempBitmap: TBitmap; +begin + TempBitmap := TBitmap.Create; + TempBitmap.Width := lx; + TempBitmap.Height := ly; + //Draw32Bitmap(TempBitmap.Canvas.Handle, lx, ly,lBuff {Self}); + lImage.Picture.Bitmap := TempBitmap; + lImage.Width := lx;//delphi + lImage.Height := ly;//delphi + TempBitmap.Free; +end; + + + {$IFDEF FPC} +procedure PrepPlot(var lImage: TIMage; lL,lT,lR,lB,lWid,lHt,lFontSize: integer); +{$ELSE} +procedure PrepPlot(var lImage: TMetafileCanvas; lL,lT,lR,lB,lWid,lHt,lFontSize: integer); +{$ENDIF} +begin +{$IFDEF FPC} + with lImage.Canvas do begin +{$ELSE} + with lImage do begin +{$ENDIF} + Font.Name := 'Arial'; + Font.Size := 12; + pen.color := clBlack; + Font.color := clBlack; + Brush.Style := bsSolid; + Brush.color := clWhite; + Rectangle(1,1,lWid,lHt); + Rectangle(lL,lT,lR,lB); + end; +end; + +procedure CorePlot4DTrace(var l4DTrace: T4DTrace; lImage: TImage; lStartSample,HSpeed,lnColors: integer;lTR,lVertMin,lVertMax: single; lErrorBars: boolean); +var + lWid,lHt,lBorder,lL,lT,lR,lB,lFontSize: integer; +{$IFDEF FPC} + //WmfCanvas: TCanvas; + +{$ELSE} + WmfCanvas: TMetafileCanvas; +{$ENDIF} +begin + lWid := lImage.Width; + lHt := lImage.Height; + lFontSize := 12; + lBorder := lFontSize * 4; + if (lWid <= (2*lBorder)) or (lHt <= (2*lBorder)) then + exit; + + lL := round(1.3*lBorder); + lT :=lFontSize*2; + lR := lWid - lBorder; + lB := lHt-(lFontSize*2); +{$IFDEF FPC} + //WmfCanvas := TCanvas.Create; + PrepPlot(lImage,lL,lT,lR,lB,lWid,lHt,lFontSize); + ShowPlot(l4DTrace,lImage,lL,lT,lR,lB,lStartSample,HSpeed,1,lnColors, lTR,lVertMin,lVertMax,true,lErrorBars); +//abba lImage.Canvas.Draw (0, 0, WmfCanvas); + //WmfCanvas.Free; +{$ELSE} + gWmf.clear; + gWmf.Width := lWid; + gWmf.Height := lHt; + WmfCanvas := TMetafileCanvas.CreateWithComment(gWmf, 0, 'mricron', 'plot metafile'); + try + PrepPlot(WmfCanvas,lL,lT,lR,lB,lWid,lHt,lFontSize); + ShowPlot(l4DTrace,WmfCanvas,lL,lT,lR,lB,lStartSample,HSpeed,1,lnColors, lTR,lVertMin,lVertMax,true,lErrorBars); + finally + WmfCanvas.Free; + end;//finally + lImage.Canvas.Draw (0, 0, gWmf); +{$ENDIF} +end; + + +initialization +begin +{$IFDEF FPC} +{$ELSE} + gWmf := TMetafile.Create; + gWmf.Enhanced := True; +{$ENDIF} + // Create4DTrace(g4Ddata); +end; + +finalization +begin + //Close4DTrace(g4Ddata); +{$IFDEF FPC} +{$ELSE} + gWmf.free; +{$ENDIF} + +end; + + +end. diff --git a/niftiview7/mni.pas b/niftiview7/mni.pas new file mode 100755 index 0000000..6ea27e5 --- /dev/null +++ b/niftiview7/mni.pas @@ -0,0 +1,48 @@ +unit mni; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Mask; + +type + TMNIForm = class(TForm) + XEdit: TRxSpinEdit; + YEdit: TRxSpinEdit; + ZEdit: TRxSpinEdit; + procedure XEditChange(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + MNIForm: TMNIForm; + +implementation + +uses nifti_img_view,nifti_img,define_types; + +{$R *.DFM} + +procedure TMNIForm.XEditChange(Sender: TObject); + var +lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if not MNIForm.visible then exit; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + lXmm:=XEdit.value; + lYmm:=YEdit.value; + lZmm:=ZEdit.value; + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> ImgForm.XViewEdit.value then ImgForm.XViewEdit.value := lX; + if lY <> ImgForm.YViewEdit.value then ImgForm.YViewEdit.value := lY; + if lZ <> ImgForm.ZViewEdit.value then ImgForm.ZViewEdit.value := lZ; + ImgForm.XViewEditChange(nil); +end; + +end. diff --git a/niftiview7/multislice/2mm.ini b/niftiview7/multislice/2mm.ini new file mode 100755 index 0000000..9c1a03a --- /dev/null +++ b/niftiview7/multislice/2mm.ini @@ -0,0 +1,8 @@ +[STR] +Slices=37,41,45,49,53,57,62,67 +[BOOL] +OrthoView=0 +SliceLabel=0 +[INT] +Orient=1 +OverslicePct=100 diff --git a/niftiview7/multislice/ax.ini b/niftiview7/multislice/ax.ini new file mode 100755 index 0000000..10f78e0 --- /dev/null +++ b/niftiview7/multislice/ax.ini @@ -0,0 +1,6 @@ +[STR] +Slices=72,82,92,102 +[BOOL] +OrthoView=1 +[INT] +Orient=1 diff --git a/niftiview7/multislice/coro.ini b/niftiview7/multislice/coro.ini new file mode 100755 index 0000000..f2c5707 --- /dev/null +++ b/niftiview7/multislice/coro.ini @@ -0,0 +1,6 @@ +[STR] +Slices=72,82,92,102 +[BOOL] +OrthoView=1 +[INT] +Orient=3 diff --git a/niftiview7/multislice/crap.ini b/niftiview7/multislice/crap.ini new file mode 100755 index 0000000..f3be232 --- /dev/null +++ b/niftiview7/multislice/crap.ini @@ -0,0 +1,8 @@ +[STR] +Slices=56,64,72,80,88,96,104,112 +[BOOL] +OrthoView=0 +SliceLabel=1 +[INT] +Orient=1 +OverslicePct=-10 diff --git a/niftiview7/multislice/davis_toj.ini b/niftiview7/multislice/davis_toj.ini new file mode 100755 index 0000000..2cadc55 --- /dev/null +++ b/niftiview7/multislice/davis_toj.ini @@ -0,0 +1,8 @@ +[STR] +Slices=67,83,91,99,107,125,135 +[BOOL] +OrthoView=0 +SliceLabel=1 +[INT] +Orient=1 +OverslicePct=5 diff --git a/niftiview7/multislice/default.ini b/niftiview7/multislice/default.ini new file mode 100755 index 0000000..f3a0f05 --- /dev/null +++ b/niftiview7/multislice/default.ini @@ -0,0 +1,8 @@ +[STR] +Slices=21,29,37,45,53,62,72 +[BOOL] +OrthoView=1 +SliceLabel=0 +[INT] +Orient=1 +OverslicePct=0 diff --git a/niftiview7/multislice/epilepsy.ini b/niftiview7/multislice/epilepsy.ini new file mode 100755 index 0000000..32c5959 --- /dev/null +++ b/niftiview7/multislice/epilepsy.ini @@ -0,0 +1,8 @@ +[STR] +Slices=54,100,110,130 +[BOOL] +OrthoView=0 +SliceLabel=0 +[INT] +Orient=3 +OverslicePct=10 diff --git a/niftiview7/multislice/junk.ini b/niftiview7/multislice/junk.ini new file mode 100755 index 0000000..cf84779 --- /dev/null +++ b/niftiview7/multislice/junk.ini @@ -0,0 +1,8 @@ +[STR] +Slices=82,92,102,112,122,132 +[BOOL] +OrthoView=1 +SliceLabel=1 +[INT] +Orient=1 +OverslicePct=50 diff --git a/niftiview7/multislice/mricro.ini b/niftiview7/multislice/mricro.ini new file mode 100755 index 0000000..a5eb7ff --- /dev/null +++ b/niftiview7/multislice/mricro.ini @@ -0,0 +1,8 @@ +[STR] +Slices=48,56,64,72,80,88,96,104,112,122,132 +[BOOL] +OrthoView=1 +SliceLabel=1 +[INT] +Orient=1 +OverslicePct=50 diff --git a/niftiview7/multislice/mricror.ini b/niftiview7/multislice/mricror.ini new file mode 100755 index 0000000..0225d56 --- /dev/null +++ b/niftiview7/multislice/mricror.ini @@ -0,0 +1,8 @@ +[STR] +Slices=64,72,80,88,96,104,112 +[BOOL] +OrthoView=0 +SliceLabel=1 +[INT] +Orient=1 +OverslicePct=-50 diff --git a/niftiview7/multislice/next.ini b/niftiview7/multislice/next.ini new file mode 100755 index 0000000..053c789 --- /dev/null +++ b/niftiview7/multislice/next.ini @@ -0,0 +1,8 @@ +[STR] +Slices=95,105,180,190 +[BOOL] +OrthoView=1 +SliceLabel=1 +[INT] +Orient=1 +OverslicePct=10 diff --git a/niftiview7/multislice/over10.ini b/niftiview7/multislice/over10.ini new file mode 100755 index 0000000..bdb0e87 --- /dev/null +++ b/niftiview7/multislice/over10.ini @@ -0,0 +1,8 @@ +[STR] +Slices=82,92,102,112,122,132 +[BOOL] +OrthoView=0 +SliceLabel=0 +[INT] +Orient=1 +OverslicePct=10 diff --git a/niftiview7/multislice/sag.ini b/niftiview7/multislice/sag.ini new file mode 100755 index 0000000..ba211af --- /dev/null +++ b/niftiview7/multislice/sag.ini @@ -0,0 +1,6 @@ +[STR] +Slices=72,82,92,102 +[BOOL] +OrthoView=1 +[INT] +Orient=2 diff --git a/niftiview7/nifti.ico b/niftiview7/nifti.ico new file mode 100755 index 0000000..2d16d6a Binary files /dev/null and b/niftiview7/nifti.ico differ diff --git a/niftiview7/nifti_foreign.pas b/niftiview7/nifti_foreign.pas new file mode 100755 index 0000000..396770c --- /dev/null +++ b/niftiview7/nifti_foreign.pas @@ -0,0 +1,1144 @@ +unit nifti_foreign; + +interface +uses nifti_types, define_types, sysutils, classes, dialogs,StrUtils;//2015! dialogsx + +function readForeignHeader (var lFilename: string; var lHdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +procedure NII_Clear (var lHdr: TNIFTIHdr); +procedure NII_SetIdentityMatrix (var lHdr: TNIFTIHdr); //create neutral rotation matrix + +implementation + +Type + mat44 = array [0..3, 0..3] of Single; + vect4 = array [0..3] of Single; + mat33 = array [0..2, 0..2] of Single; + vect3 = array [0..2] of Single; + ivect3 = array [0..2] of integer; + +procedure NII_SetIdentityMatrix (var lHdr: TNIFTIHdr); //create neutral rotation matrix +var lInc: integer; +begin + with lHdr do begin + for lInc := 0 to 3 do + srow_x[lInc] := 0; + for lInc := 0 to 3 do + srow_y[lInc] := 0; + for lInc := 0 to 3 do + srow_z[lInc] := 0; + for lInc := 1 to 16 do + intent_name[lInc] := chr(0); + //next: create identity matrix: if code is switched on there will not be a problem + srow_x[0] := 1; + srow_y[1] := 1; + srow_z[2] := 1; + end; +end; //proc NIFTIhdr_IdentityMatrix + +procedure NII_Clear (var lHdr: TNIFTIHdr); +var + lInc: integer; +begin + with lHdr do begin + HdrSz := sizeof(TNIFTIhdr); + for lInc := 1 to 10 do + Data_Type[lInc] := chr(0); + for lInc := 1 to 18 do + db_name[lInc] := chr(0); + extents:=0; + session_error:= 0; + regular:='r'{chr(0)}; + dim_info:=(0); + dim[0] := 4; + for lInc := 1 to 7 do + dim[lInc] := 0; + intent_p1 := 0; + intent_p2 := 0; + intent_p3 := 0; + intent_code:=0; + datatype:=0 ; + bitpix:=0; + slice_start:=0; + for lInc := 1 to 7 do + pixdim[linc]:= 1.0; + vox_offset:= 0.0; + scl_slope := 1.0; + scl_inter:= 0.0; + slice_end:= 0; + slice_code := 0; + xyzt_units := 10; + cal_max:= 0.0; + cal_min:= 0.0; + slice_duration:=0; + toffset:= 0; + glmax:= 0; + glmin:= 0; + for lInc := 1 to 80 do + descrip[lInc] := chr(0);{80 spaces} + for lInc := 1 to 24 do + aux_file[lInc] := chr(0);{80 spaces} + {below are standard settings which are not 0} + bitpix := 16;//vc16; {8bits per pixel, e.g. unsigned char 136} + DataType := 4;//vc4;{2=unsigned char, 4=16bit int 136} + Dim[0] := 3; + Dim[1] := 256; + Dim[2] := 256; + Dim[3] := 128; + Dim[4] := 1; {n vols} + Dim[5] := 1; + Dim[6] := 1; + Dim[7] := 1; + glMin := 0; + glMax := 255; + qform_code := kNIFTI_XFORM_UNKNOWN; + sform_code:= kNIFTI_XFORM_UNKNOWN; + quatern_b := 0; + quatern_c := 0; + quatern_d := 0; + qoffset_x := 0; + qoffset_y := 0; + qoffset_z := 0; + NII_SetIdentityMatrix(lHdr); + magic := kNIFTI_MAGIC_SEPARATE_HDR; + end; //with the NIfTI header... +end; + +procedure LOAD_MAT44(var m: mat44; m00,m01,m02,m03, m10,m11,m12,m13, m20,m21,m22,m23: single); +begin + m[0,0] := m00; + m[0,1] := m01; + m[0,2] := m02; + m[0,3] := m03; + m[1,0] := m10; + m[1,1] := m11; + m[1,2] := m12; + m[1,3] := m13; + m[2,0] := m20; + m[2,1] := m21; + m[2,2] := m22; + m[2,3] := m23; + m[3,0] := 0.0; + m[3,1] := 0.0; + m[3,2] := 0.0; + m[3,3] := 1.0; +end; + +procedure ZERO_MAT44(var m: mat44); //note sets m[3,3] to one +var + i,j: integer; +begin + for i := 0 to 3 do + for j := 0 to 3 do + m[i,j] := 0.0; + m[3,3] := 1; +end; + +procedure LOAD_MAT33(var m: mat33; m00,m01,m02, m10,m11,m12, m20,m21,m22: single); +begin + m[0,0] := m00; + m[0,1] := m01; + m[0,2] := m02; + m[1,0] := m10; + m[1,1] := m11; + m[1,2] := m12; + m[2,0] := m20; + m[2,1] := m21; + m[2,2] := m22; +end; + +function nifti_mat33_mul( A,B: mat33): mat33; +var + i,j: integer; +begin + for i:=0 to 3 do + for j:=0 to 3 do + result[i,j] := A[i,0] * B[0,j] + + A[i,1] * B[1,j] + + A[i,2] * B[2,j] ; +end; + +procedure convertForeignToNifti(var nhdr: TNIFTIhdr); +var + i,nonSpatialMult: integer; + +begin + nhdr.HdrSz := 348; //used to signify header does not need to be byte-swapped + nhdr.magic:=kNIFTI_MAGIC_EMBEDDED_HDR; + if (nhdr.dim[3] = 0) then nhdr.dim[3] := 1; //for 2D images the 3rd dim is not specified and set to zero + nhdr.dim[0] := 3; //for 2D images the 3rd dim is not specified and set to zero + nonSpatialMult := 1; + for i := 4 to 7 do + if nhdr.dim[i] > 0 then + nonSpatialMult := nonSpatialMult * nhdr.dim[i]; + if (nonSpatialMult > 1) then begin + nhdr.dim[0] := 4; + nhdr.dim[4] := nonSpatialMult; + for i := 5 to 7 do + nhdr.dim[i] := 0; + end; + nhdr.bitpix := 8; + if (nhdr.datatype = 4) or (nhdr.datatype = 512) then nhdr.bitpix := 16; + if (nhdr.datatype = 8) or (nhdr.datatype = 16) or (nhdr.datatype = 768) then nhdr.bitpix := 32; + if (nhdr.datatype = 32) or (nhdr.datatype = 64) or (nhdr.datatype = 1024) or (nhdr.datatype = 1280) then nhdr.bitpix := 64; + nhdr.sform_code := 1; +end; + +procedure NSLog( str: string); +begin + ShowMessage(str); +end; + +function readMGHHeader (var fname: string; var nhdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +Type + Tmgh = packed record //Next: analyze Format Header structure + version, width,height,depth,nframes,mtype,dof : longint; + goodRASFlag: smallint; + spacingX,spacingY,spacingZ,xr,xa,xs,yr,ya,ys,zr,za,zs,cr,ca,cs: single; + end; +var + mgh: Tmgh; + lBuff: Bytep; + lExt: string; + lHdrFile: file; + PxyzOffset, Pcrs: vect4; + i,j: integer; + base: single; + m: mat44; +begin + result := false; + lExt := UpCaseExt(fname); + if (lExt = '.MGZ') then begin + lBuff := @mgh; + UnGZip(fname,lBuff,0,sizeof(Tmgh)); //1388 + gzBytes := K_gzBytes_headerAndImageCompressed; + end else begin //if MGZ, else assume uncompressed MGH + gzBytes := 0; + {$I-} + AssignFile(lHdrFile, fname); + FileMode := 0; //Set file access to read only + Reset(lHdrFile, 1); + {$I+} + if ioresult <> 0 then begin + ShowMessage('Error in reading NIFTI header.'+inttostr(IOResult)); + FileMode := 2; + exit; + end; + BlockRead(lHdrFile, mgh, sizeof(Tmgh)); + CloseFile(lHdrFile); + end; + {$IFDEF ENDIAN_BIG} //data always stored big endian + swapEndian := false; + {$ELSE} + swapEndian := true; + swap4(mgh.version); + swap4(mgh.width); + swap4(mgh.height); + swap4(mgh.depth); + swap4(mgh.nframes); + swap4(mgh.mtype); + swap4(mgh.dof); + mgh.goodRASFlag := swap(mgh.goodRASFlag); + Xswap4r(mgh.spacingX); + Xswap4r(mgh.spacingY); + Xswap4r(mgh.spacingZ); + Xswap4r(mgh.xr); + Xswap4r(mgh.xa); + Xswap4r(mgh.xs); + Xswap4r(mgh.yr); + Xswap4r(mgh.ya); + Xswap4r(mgh.ys); + Xswap4r(mgh.zr); + Xswap4r(mgh.za); + Xswap4r(mgh.zs); + Xswap4r(mgh.cr); + Xswap4r(mgh.ca); + Xswap4r(mgh.cs); + {$ENDIF} + if ((mgh.version <> 1) or (mgh.mtype < 0) or (mgh.mtype > 4)) then begin + NSLog('Error: first value in a MGH header should be 1 and data type should be in the range 1..4.'); + exit; + end; + if (mgh.mtype = 0) then + nhdr.datatype := kDT_UINT8 + else if (mgh.mtype = 4) then + nhdr.datatype := kDT_INT16 + else if (mgh.mtype = 1) then + nhdr.datatype := kDT_INT32 + else if (mgh.mtype = 3) then + nhdr.datatype := kDT_FLOAT32; + nhdr.dim[1]:=mgh.width; + nhdr.dim[2]:=mgh.height; + nhdr.dim[3]:=mgh.depth; + nhdr.dim[4]:=mgh.nframes; + nhdr.pixdim[1]:=mgh.spacingX; + nhdr.pixdim[2]:=mgh.spacingY; + nhdr.pixdim[3]:=mgh.spacingZ; + nhdr.vox_offset := 284; + nhdr.sform_code := 1; + //convert MGH to NIfTI transform see Bruce Fischl mri.c MRIxfmCRS2XYZ https://github.com/neurodebian/freesurfer/blob/master/utils/mri.c + LOAD_MAT44(m,mgh.xr*nhdr.pixdim[1],mgh.yr*nhdr.pixdim[2],mgh.zr*nhdr.pixdim[3],0, + mgh.xa*nhdr.pixdim[1],mgh.ya*nhdr.pixdim[2],mgh.za*nhdr.pixdim[3],0, + mgh.xs*nhdr.pixdim[1],mgh.ys*nhdr.pixdim[2],mgh.zs*nhdr.pixdim[3],0); + base := 0.0; //0 or 1: are voxels indexed from 0 or 1? + Pcrs[0] := (nhdr.dim[1]/2.0)+base; + Pcrs[1] := (nhdr.dim[2]/2.0)+base; + Pcrs[2] := (nhdr.dim[3]/2.0)+base; + Pcrs[3] := 1; + for i:=0 to 3 do begin //multiply Pcrs * m + PxyzOffset[i] := 0; + for j := 0 to 3 do + PxyzOffset[i] := PxyzOffset[i]+ (m[i,j]*Pcrs[j]); + end; + nhdr.srow_x[0]:=m[0,0]; nhdr.srow_x[1]:=m[0,1]; nhdr.srow_x[2]:=m[0,2]; nhdr.srow_x[3]:=mgh.cr - PxyzOffset[0]; + nhdr.srow_y[0]:=m[1,0]; nhdr.srow_y[1]:=m[1,1]; nhdr.srow_y[2]:=m[1,2]; nhdr.srow_y[3]:=mgh.ca - PxyzOffset[1]; + nhdr.srow_z[0]:=m[2,0]; nhdr.srow_z[1]:=m[2,1]; nhdr.srow_z[2]:=m[2,2]; nhdr.srow_z[3]:=mgh.cs - PxyzOffset[2]; + convertForeignToNifti(nhdr); + result := true; +end; + +procedure splitStr(delimiter: char; str: string; mArray: TStrings); +begin + mArray.Clear; + mArray.Delimiter := delimiter; + mArray.DelimitedText := str; +end; + +procedure splitStrStrict(delimiter: char; S: string; sl: TStrings); +begin + sl.Clear; + sl.Delimiter := delimiter; + sl.DelimitedText := '"' + StringReplace(S, sl.Delimiter, '"' + sl.Delimiter + '"', [rfReplaceAll]) + '"'; +end; + +function cleanStr (S:string): string; // "(12.31)" ->"12.31" +begin + result := StringReplace(S, '(', '', [rfReplaceAll]); + result := StringReplace(result, ')', '', [rfReplaceAll]); +end; + +function readMHAHeader (var fname: string; var nhdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +//Read VTK "MetaIO" format image +//http://www.itk.org/Wiki/ITK/MetaIO/Documentation#Reading_a_Brick-of-Bytes_.28an_N-Dimensional_volume_in_a_single_file.29 +//https://www.assembla.com/spaces/plus/wiki/Sequence_metafile_format +//http://itk-insight-users.2283740.n2.nabble.com/MHA-MHD-File-Format-td7585031.html +var + FP: TextFile; + str, tagName, elementNames: string; + ch: char; + isLocal,compressedData: boolean; + mat, d, t: mat33; + matElements, compressedDataSize, headerSize, nItems, i, channels, fileposBytes: longint; + offset: array [0..3] of single; + elementSize: array [0..3] of single; + transformMatrix: array [0..11] of single; + mArray: TStringList; +begin + result := false; + if not FileExistsEX(fname) then exit; + gzBytes := 0; + fileposBytes := 0; + compressedDataSize := 0; + swapEndian := false; + isLocal := true; //image and header embedded in same file, if false detached image + headerSize := 0; + matElements := 0; + compressedData := false; + mArray := TStringList.Create; + Filemode := fmOpenRead; + AssignFile(fp,fname); + reset(fp); + while not EOF(fp) do begin + str := ''; + while not EOF(fp) do begin + read(fp,ch); + inc(fileposBytes); + if (ch = chr($0D)) or (ch = chr($0A)) then break; + str := str+ch; + end; + if (length(str) < 1) or (str[1]='#') then continue; + splitstrStrict('=',str,mArray); + if (mArray.count < 2) then continue; + tagName := cleanStr(mArray[0]); + elementNames := mArray[1]; + splitstr(',',elementNames,mArray); + nItems :=mArray.count; + if (nItems < 1) then continue; + for i := 0 to (nItems-1) do + mArray[i] := cleanStr(mArray[i]); //remove '(' and ')', + if AnsiContainsText(tagName, 'ObjectType') and (not AnsiContainsText(mArray.Strings[0], 'Image')) then begin + NSLog('Expecting file with tag "ObjectType = Image" instead of "ObjectType = '+mArray.Strings[0]+'"'); + + end {else if AnsiContainsText(tagName, 'NDims') then begin + nDims := strtoint(mArray[0]); + if (nDims > 4) then begin + NSLog('Warning: only reading first 4 dimensions'); + nDims := 4; + end; + end} else if AnsiContainsText(tagName, 'BinaryDataByteOrderMSB') then begin + {$IFDEF ENDIAN_BIG} //data always stored big endian + if not AnsiContainsText(mArray[0], 'True') then swapEndian := true; + {$ELSE} + if AnsiContainsText(mArray[0], 'True') then swapEndian := true; + {$ENDIF} + end {else if AnsiContainsText(tagName, 'BinaryData') then begin + if AnsiContainsText(mArray[0], 'True') then binaryData := true; + end} else if AnsiContainsText(tagName, 'CompressedDataSize') then begin + compressedDataSize := strtoint(mArray[0]); + end else if AnsiContainsText(tagName, 'CompressedData') then begin + if AnsiContainsText(mArray[0], 'True') then + compressedData := true; + end else if AnsiContainsText(tagName, 'TransformMatrix') then begin + if (nItems > 12) then nItems := 12; + matElements := nItems; + for i := 0 to (nItems-1) do + transformMatrix[i] := strtofloat(mArray[i]); + if (matElements >= 12) then + LOAD_MAT33(mat, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[4],transformMatrix[5],transformMatrix[6], + transformMatrix[8],transformMatrix[9],transformMatrix[10]) + else if (matElements >= 9) then + LOAD_MAT33(mat, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[3],transformMatrix[4],transformMatrix[5], + transformMatrix[6],transformMatrix[7],transformMatrix[8]); + end else if AnsiContainsText(tagName, 'Offset') then begin + if (nItems > 3) then nItems := 3; + for i := 0 to (nItems-1) do + offset[i] := strtofloat(mArray[i]); + end else if AnsiContainsText(tagName, 'AnatomicalOrientation') then begin + //e.g. RAI + end else if AnsiContainsText(tagName, 'ElementSpacing') then begin + if (nItems > 4) then nItems := 4; + for i := 0 to (nItems-1) do + nhdr.pixdim[i+1] := strtofloat(mArray[i]); + end else if AnsiContainsText(tagName, 'DimSize') then begin + if (nItems > 4) then nItems := 4; + for i := 0 to (nItems-1) do + nhdr.dim[i+1] := strtoint(mArray[i]); + end else if AnsiContainsText(tagName, 'HeaderSize') then begin + headerSize := strtoint(mArray[0]); + end else if AnsiContainsText(tagName, 'ElementSize') then begin + if (nItems > 4) then nItems := 4; + for i := 0 to (nItems-1) do + elementSize[i] := strtofloat(mArray[i]); + end else if AnsiContainsText(tagName, 'ElementNumberOfChannels') then begin + channels := strtoint(mArray[0]); + if (channels > 1) then NSLog('Unable to read MHA/MHD files with multiple channels '); + end else if AnsiContainsText(tagName, 'ElementByteOrderMSB') then begin + {$IFDEF ENDIAN_BIG} //data always stored big endian + if not AnsiContainsText(mArray[0], 'True') then swapEndian := true; + {$ELSE} + if AnsiContainsText(mArray[0], 'True') then swapEndian := true; + {$ENDIF} + end else if AnsiContainsText(tagName, 'ElementType') then begin + + //convert metaImage format to NIfTI http://portal.nersc.gov/svn/visit/tags/2.2.1/vendor_branches/vtk/src/IO/vtkMetaImageWriter.cxx + //set NIfTI datatype http://nifti.nimh.nih.gov/pub/dist/src/niftilib/nifti1.h + if AnsiContainsText(mArray[0], 'MET_UCHAR') then + nhdr.datatype := kDT_UINT8 // + else if AnsiContainsText(mArray[0], 'MET_CHAR') then + nhdr.dataType := kDT_INT8 // + else if AnsiContainsText(mArray[0], 'MET_SHORT') then + nhdr.dataType := kDT_INT16 // + else if AnsiContainsText(mArray[0], 'MET_USHORT') then + nhdr.dataType := kDT_UINT16 // + else if AnsiContainsText(mArray[0], 'MET_INT') then + nhdr.dataType := kDT_INT32 //DT_INT32 + else if AnsiContainsText(mArray[0], 'MET_UINT') then + nhdr.dataType := kDT_UINT32 //DT_UINT32 + else if AnsiContainsText(mArray[0], 'MET_ULONG') then + nhdr.dataType := kDT_UINT64 //DT_UINT64 + else if AnsiContainsText(mArray[0], 'MET_LONG') then + nhdr.dataType := kDT_INT64 //DT_INT64 + else if AnsiContainsText(mArray[0], 'MET_FLOAT') then + nhdr.dataType := kDT_FLOAT32 //DT_FLOAT32 + else if AnsiContainsText(mArray[0], 'MET_DOUBLE') then + nhdr.dataType := kDT_DOUBLE; //DT_FLOAT64 + end else if AnsiContainsText(tagName, 'ElementDataFile') then begin + if not AnsiContainsText(mArray[0], 'local') then begin + str := mArray.Strings[0]; + if fileexistsex(str) then + fname := str + else begin + fname := ExtractFileDirWithPathDelim(fname)+str; + end; + isLocal := false; + end; + break; + end; + end; //while reading + if (headerSize = 0) and (isLocal) then headerSize :=fileposBytes; //!CRAP 2015 + nhdr.vox_offset := headerSize; + CloseFile(FP); + Filemode := 2; + mArray.free; + //convert transform + if (matElements >= 9) then begin + LOAD_MAT33(d, nhdr.pixdim[1],0,0, + 0, nhdr.pixdim[2],0, + 0,0, nhdr.pixdim[3]); + t := nifti_mat33_mul( d, mat); + nhdr.srow_x[0] := -t[0,0]; + nhdr.srow_x[1] := -t[1,0]; + nhdr.srow_x[2] := -t[2,0]; + nhdr.srow_x[3] := -offset[0]; + nhdr.srow_y[0] := -t[0,1]; + nhdr.srow_y[1] := -t[1,1]; + nhdr.srow_y[2] := -t[2,1]; + nhdr.srow_y[3] := -offset[1]; + nhdr.srow_z[0] := t[0,2]; + nhdr.srow_z[1] := t[1,2]; + nhdr.srow_z[2] := t[2,2]; + nhdr.srow_z[3] := offset[2]; + end else + NSLog('Warning: unable to determine image orientation (unable to decode metaIO "TransformMatrix" tag)'); + //end transform + convertForeignToNifti(nhdr); + if (compressedData) then begin + if (compressedDataSize < 1) then + gzBytes := K_gzBytes_onlyImageCompressed + else + gzBytes := compressedDataSize; + end; + result := true; +end;//MHA + +function readNRRDHeader (var fname: string; var nhdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +//http://www.sci.utah.edu/~gk/DTI-data/ +//http://teem.sourceforge.net/nrrd/format.html +label + 666; +var + FP: TextFile; + ch: char; + mArray: TStringList; + str,tagName,elementNames: string; + i,s,nItems,headerSize,matElements,fileposBytes: integer; + mat: mat33; + isDetachedFile,isFirstLine: boolean; + offset: array[0..3] of single; + vSqr: single; + transformMatrix: array [0..11] of single; +begin + result := false; + gzBytes :=0; + fileposBytes := 0; + swapEndian :=false; + //nDims := 0; + headerSize :=0; + isDetachedFile :=false; + matElements :=0; + mArray := TStringList.Create; + Filemode := 0; + isFirstLine := true; + AssignFile(fp,fname); + reset(fp); + while (not EOF(fp)) do begin + str := ''; + while not EOF(fp) do begin + read(fp,ch); + fileposBytes := fileposBytes + 1; + if (ch = chr($0D)) or (ch = chr($0A)) then break; + str := str+ch; + end; + if str = '' then break; + if (isFirstLine) then begin + if (length(str) <4) or (str[1]<>'N') or (str[2]<>'R') or (str[3]<>'R') or (str[4]<>'D') then + goto 666; + isFirstLine := false; + end; + //showmessage(str+'->'+inttostr(fileposBytes)); + if (length(str) < 1) or (str[1]='#') then continue; + splitstrStrict(':',str,mArray); + if (mArray.count < 2) then continue; + tagName := mArray[0]; + elementNames := mArray[1]; + splitstr(',',elementNames,mArray); + nItems :=mArray.count; + if (nItems < 1) then continue; + for i := 0 to (nItems-1) do + mArray.Strings[i] := cleanStr(mArray.Strings[i]); //remove '(' and ')' + (*if AnsiContainsText(tagName, 'dimension') then + nDims := strtoint(mArray.Strings[0]) + else*) if AnsiContainsText(tagName, 'spacings') then begin + if (nItems > 6) then nItems :=6; + for i:=0 to (nItems-1) do + nhdr.pixdim[i+1] :=strtofloat(mArray.Strings[i]); + end else if AnsiContainsText(tagName, 'sizes') then begin + if (nItems > 6) then nItems :=6; + for i:=0 to (nItems-1) do + nhdr.dim[i+1] := strtoint(mArray.Strings[i]); + end else if AnsiContainsText(tagName, 'space directions') then begin + if (nItems > 12) then nItems :=12; + matElements :=nItems; + for i:=0 to (nItems-1) do + transformMatrix[i] :=strtofloat(mArray.Strings[i]); + if (matElements >= 12) then + LOAD_MAT33(mat, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[4],transformMatrix[5],transformMatrix[6], + transformMatrix[8],transformMatrix[9],transformMatrix[10]) + else if (matElements >= 9) then + LOAD_MAT33(mat, transformMatrix[0],transformMatrix[1],transformMatrix[2], + transformMatrix[3],transformMatrix[4],transformMatrix[5], + transformMatrix[6],transformMatrix[7],transformMatrix[8]); + end else if AnsiContainsText(tagName, 'type') then begin + if AnsiContainsText(mArray.Strings[0], 'uchar') or + AnsiContainsText(mArray.Strings[0], 'uint8') or + AnsiContainsText(mArray.Strings[0], 'uint8_t') then + nhdr.datatype := KDT_UINT8 //DT_UINT8 DT_UNSIGNED_CHAR + else if AnsiContainsText(mArray.Strings[0], 'short') or //specific so + AnsiContainsText(mArray.Strings[0], 'int16') or + AnsiContainsText(mArray.Strings[0], 'int16_t') then + nhdr.datatype :=kDT_INT16 //DT_INT16 + else if AnsiContainsText(mArray.Strings[0], 'float') then + nhdr.datatype := kDT_FLOAT32 //DT_FLOAT32 + else if AnsiContainsText(mArray.Strings[0], 'unsigned') + and (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'char') then + nhdr.datatype := kDT_UINT8 //DT_UINT8 + else if AnsiContainsText(mArray.Strings[0], 'unsigned') and + (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'int') then + nhdr.datatype := kDT_INT32 // + else if AnsiContainsText(mArray.Strings[0], 'signed') and + (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'char') then + nhdr.datatype := kDT_INT8 //do UNSIGNED first, as "isigned" includes string "unsigned" + else if AnsiContainsText(mArray.Strings[0], 'signed') and + (nItems > 1) and AnsiContainsText(mArray.Strings[1], 'short') then + nhdr.datatype := kDT_INT16 //do UNSIGNED first, as "isigned" includes string "unsigned" + else if AnsiContainsText(mArray.Strings[0], 'double') then + nhdr.datatype := kDT_DOUBLE //DT_DOUBLE + else if AnsiContainsText(mArray.Strings[0], 'int') then //do this last and "uint" includes "int" + nhdr.datatype := kDT_UINT32 + else begin + NSLog('Unsupported NRRD datatype'+mArray.Strings[0]); + end + end else if AnsiContainsText(tagName, 'endian') then begin + {$IFDEF ENDIAN_BIG} //data always stored big endian + if AnsiContainsText(mArray.Strings[0], 'little') then swapEndian :=true; + {$ELSE} + if AnsiContainsText(mArray.Strings[0], 'big') then swapEndian :=true; + {$ENDIF} + end else if AnsiContainsText(tagName, 'encoding') then begin + if AnsiContainsText(mArray.Strings[0], 'raw') then + gzBytes :=0 + else if AnsiContainsText(mArray.Strings[0], 'gz') or AnsiContainsText(mArray.Strings[0], 'gzip') then + gzBytes := K_gzBytes_headerAndImageCompressed//K_gzBytes_headeruncompressed + else + NSLog('Unknown encoding format '+mArray.Strings[0]); + end else if AnsiContainsText(tagName, 'space origin') then begin + if (nItems > 3) then nItems :=3; + for i:=0 to (nItems-1) do + offset[i] := strtofloat(mArray.Strings[i]); + end else if AnsiContainsText(tagName, 'data file') then begin + str := mArray.Strings[0]; + if fileexistsex(str) then + fname := str + else begin + fname := ExtractFileDirWithPathDelim(fname)+str; + end; + isDetachedFile :=true; + //break; + end; //for ...else tag names + end; + if ((headerSize = 0) and ( not isDetachedFile)) then begin + if gzBytes = K_gzBytes_headerAndImageCompressed then + gzBytes := K_gzBytes_onlyImageCompressed; //raw text file followed by GZ image + headerSize :=fileposBytes; + end; + result := true; +666: + CloseFile(FP); + Filemode := 2; + mArray.free; + if not result then exit; + nhdr.vox_offset :=headerSize; + if (matElements >= 9) then begin + nhdr.srow_x[0] :=-mat[0,0]; + nhdr.srow_x[1] :=-mat[1,0]; + nhdr.srow_x[2] :=-mat[2,0]; + nhdr.srow_x[3] :=-offset[0]; + nhdr.srow_y[0] :=-mat[0,1]; + nhdr.srow_y[1] :=-mat[1,1]; + nhdr.srow_y[2] :=-mat[2,1]; + nhdr.srow_y[3] :=-offset[1]; + nhdr.srow_z[0] :=mat[0,2]; + nhdr.srow_z[1] :=mat[1,2]; + nhdr.srow_z[2] :=mat[2,2]; + nhdr.srow_z[3] :=offset[2]; + //next: ITK does not generate a "spacings" tag - get this from the matrix... + for s :=0 to 2 do begin + vSqr :=0.0; + for i :=0 to 2 do + vSqr := vSqr+ ( mat[s,i]*mat[s,i]); + nhdr.pixdim[s+1] :=sqrt(vSqr); + end //for each dimension + end else + NSLog('Warning: unable to determine image orientation (unable to decode metaIO "TransformMatrix" tag)'+inttostr(matElements)); + convertForeignToNifti(nhdr); +end; + +(*procedure fromMatrix (m: mat44; var r11,r12,r13,r21,r22,r23,r31,r32,r33: double); +begin + r11 := m[0,0]; + r12 := m[0,1]; + r13 := m[0,2]; + r21 := m[1,0]; + r22 := m[1,1]; + r23 := m[1,2]; + r31 := m[2,0]; + r32 := m[2,1]; + r33 := m[2,2]; +end; + +function Matrix2D (r11,r12,r13,r21,r22,r23,r31,r32,r33: double): mat33; +begin + result[0,0] := r11; + result[0,1] := r12; + result[0,2] := r13; + result[1,0] := r21; + result[1,1] := r22; + result[1,2] := r23; + result[2,0] := r31; + result[2,1] := r32; + result[2,2] := r33; +end; + +function nifti_mat33_determ( R: mat33 ):double; //* determinant of 3x3 matrix */ +begin + result := r[0,0]*r[1,1]*r[2,2] + -r[0,0]*r[2,1]*r[1,2] + -r[1,0]*r[0,1]*r[2,2] + +r[1,0]*r[2,1]*r[0,2] + +r[2,0]*r[0,1]*r[1,2] + -r[2,0]*r[1,1]*r[0,2] ; +end; + +function nifti_mat33_rownorm( A: mat33 ): single; // max row norm of 3x3 matrix +var + r1,r2,r3: single ; +begin + r1 := abs(A[0,0])+abs(A[0,1])+abs(A[0,2]); + r2 := abs(A[1,0])+abs(A[1,1])+abs(A[1,2]); + r3 := abs(A[2,0])+abs(A[2,1])+abs(A[2,2]); + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +procedure fromMatrix33 (m: mat33; var r11,r12,r13,r21,r22,r23,r31,r32,r33: double); +begin + r11 := m[0,0]; + r12 := m[0,1]; + r13 := m[0,2]; + r21 := m[1,0]; + r22 := m[1,1]; + r23 := m[1,2]; + r31 := m[2,0]; + r32 := m[2,1]; + r33 := m[2,2]; +end; + +function nifti_mat33_inverse( R: mat33 ): mat33; //* inverse of 3x3 matrix */ +var + r11,r12,r13,r21,r22,r23,r31,r32,r33 , deti: double ; +begin + FromMatrix33(R,r11,r12,r13,r21,r22,r23,r31,r32,r33); + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + if( deti <> 0.0 ) then deti := 1.0 / deti ; + result[0,0] := deti*( r22*r33-r32*r23) ; + result[0,1] := deti*(-r12*r33+r32*r13) ; + result[0,2] := deti*( r12*r23-r22*r13) ; + result[1,0] := deti*(-r21*r33+r31*r23) ; + result[1,1] := deti*( r11*r33-r31*r13) ; + result[1,2] := deti*(-r11*r23+r21*r13) ; + result[2,0] := deti*( r21*r32-r31*r22) ; + result[2,1] := deti*(-r11*r32+r31*r12) ; + result[2,2] := deti*( r11*r22-r21*r12) ; +end; + +function nifti_mat33_colnorm( A: mat33 ): single; //* max column norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A[0,0])+abs(A[1,0])+abs(A[2,0]) ; + r2 := abs(A[0,1])+abs(A[1,1])+abs(A[2,1]) ; + r3 := abs(A[0,2])+abs(A[1,2])+abs(A[2,2]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_polar( A: mat33 ): mat33; +var + k:integer; + X , Y , Z: mat33 ; + dif,alp,bet,gam,gmi : single; +begin + dif := 1; + k := 0; + X := A ; + gam := nifti_mat33_determ(X) ; + while( gam = 0.0 )do begin //perturb matrix + gam := 0.00001 * ( 0.001 + nifti_mat33_rownorm(X) ) ; + X[0,0] := X[0,0]+gam ; + X[1,1] := X[1,1]+gam ; + X[2,2] := X[2,2] +gam ; + gam := nifti_mat33_determ(X) ; + end; + while true do begin + Y := nifti_mat33_inverse(X) ; + if( dif > 0.3 )then begin // far from convergence + alp := sqrt( nifti_mat33_rownorm(X) * nifti_mat33_colnorm(X) ) ; + bet := sqrt( nifti_mat33_rownorm(Y) * nifti_mat33_colnorm(Y) ) ; + gam := sqrt( bet / alp ) ; + gmi := 1.0 / gam ; + end else begin + gam := 1.0; + gmi := 1.0 ; //close to convergence + end; + Z[0,0] := 0.5 * ( gam*X[0,0] + gmi*Y[0,0] ) ; + Z[0,1] := 0.5 * ( gam*X[0,1] + gmi*Y[1,0] ) ; + Z[0,2] := 0.5 * ( gam*X[0,2] + gmi*Y[2,0] ) ; + Z[1,0] := 0.5 * ( gam*X[1,0] + gmi*Y[0,1] ) ; + Z[1,1] := 0.5 * ( gam*X[1,1] + gmi*Y[1,1] ) ; + Z[1,2] := 0.5 * ( gam*X[1,2] + gmi*Y[2,1] ) ; + Z[2,0] := 0.5 * ( gam*X[2,0] + gmi*Y[0,2] ) ; + Z[2,1] := 0.5 * ( gam*X[2,1] + gmi*Y[1,2] ) ; + Z[2,2] := 0.5 * ( gam*X[2,2] + gmi*Y[2,2] ) ; + dif := abs(Z[0,0]-X[0,0])+abs(Z[0,1]-X[0,1])+abs(Z[0,2]-X[0,2]) + +abs(Z[1,0]-X[1,0])+abs(Z[1,1]-X[1,1])+abs(Z[1,2]-X[1,2]) + +abs(Z[2,0]-X[2,0])+abs(Z[2,1]-X[2,1])+abs(Z[2,2]-X[2,2]); + k := k+1 ; + if( k > 100) or (dif < 3.e-6 ) then begin + result := Z; + break ; //convergence or exhaustion + end; + X := Z ; + end; + result := Z ; +end; + +procedure nifti_mat44_to_quatern( lR :mat44; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd , a,b,c,d : double; + P,Q: mat33; //3x3 +begin + // offset outputs are read write out of input matrix + qx := lR[0,3]; + qy := lR[1,3]; + qz := lR[2,3]; + //load 3x3 matrix into local variables + fromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + //compute lengths of each column; these determine grid spacings + xd := sqrt( r11*r11 + r21*r21 + r31*r31 ) ; + yd := sqrt( r12*r12 + r22*r22 + r32*r32 ) ; + zd := sqrt( r13*r13 + r23*r23 + r33*r33 ) ; + //if a column length is zero, patch the trouble + if( xd = 0.0 )then begin r11 := 1.0 ; r21 := 0; r31 := 0.0 ; xd := 1.0 ; end; + if( yd = 0.0 )then begin r22 := 1.0 ; r12 := 0; r32 := 0.0 ; yd := 1.0 ; end; + if( zd = 0.0 )then begin r33 := 1.0 ; r13 := 0; r23 := 0.0 ; zd := 1.0 ; end; + //assign the output lengths + dx := xd; + dy := yd; + dz := zd; + //normalize the columns + r11 := r11/xd ; r21 := r21/xd ; r31 := r31/xd ; + r12 := r12/yd ; r22 := r22/yd ; r32 := r32/yd ; + r13 := r13/zd ; r23 := r23/zd ; r33 := r33/zd ; + { At this point, the matrix has normal columns, but we have to allow + for the fact that the hideous user may not have given us a matrix + with orthogonal columns. So, now find the orthogonal matrix closest + to the current matrix. + One reason for using the polar decomposition to get this + orthogonal matrix, rather than just directly orthogonalizing + the columns, is so that inputting the inverse matrix to R + will result in the inverse orthogonal matrix at this point. + If we just orthogonalized the columns, this wouldn't necessarily hold.} + Q := Matrix2D (r11,r12,r13, // 2D "graphics" matrix + r21,r22,r23, + r31,r32,r33); + P := nifti_mat33_polar(Q) ; //P is orthog matrix closest to Q + FromMatrix33(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); +{ [ r11 r12 r13 ] + at this point, the matrix [ r21 r22 r23 ] is orthogonal + [ r31 r32 r33 ] + compute the determinant to determine if it is proper} + + zd := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; //should be -1 or 1 + + if( zd > 0 )then begin // proper + qfac := 1.0 ; + end else begin //improper ==> flip 3rd column + qfac := -1.0 ; + r13 := -r13 ; r23 := -r23 ; r33 := -r33 ; + end; + // now, compute quaternion parameters + a := r11 + r22 + r33 + 1.0; + if( a > 0.5 ) then begin //simplest case + a := 0.5 * sqrt(a) ; + b := 0.25 * (r32-r23) / a ; + c := 0.25 * (r13-r31) / a ; + d := 0.25 * (r21-r12) / a ; + end else begin //trickier case + xd := 1.0 + r11 - (r22+r33) ;// 4*b*b + yd := 1.0 + r22 - (r11+r33) ;// 4*c*c + zd := 1.0 + r33 - (r11+r22) ;// 4*d*d + if( xd > 1.0 ) then begin + b := 0.5 * sqrt(xd) ; + c := 0.25* (r12+r21) / b ; + d := 0.25* (r13+r31) / b ; + a := 0.25* (r32-r23) / b ; + end else if( yd > 1.0 ) then begin + c := 0.5 * sqrt(yd) ; + b := 0.25* (r12+r21) / c ; + d := 0.25* (r23+r32) / c ; + a := 0.25* (r13-r31) / c ; + end else begin + d := 0.5 * sqrt(zd) ; + b := 0.25* (r13+r31) / d ; + c := 0.25* (r23+r32) / d ; + a := 0.25* (r21-r12) / d ; + end; + if( a < 0.0 )then begin b:=-b ; c:=-c ; d:=-d; {a:=-a; this is not used} end; + end; + qb := b ; + qc := c ; + qd := d ; +end; *) + +procedure THD_daxes_to_NIFTI (var nhdr: TNIFTIhdr; xyzDelta, xyzOrigin: vect3; orientSpecific: ivect3); +//see http://afni.nimh.nih.gov/pub/dist/src/thd_matdaxes.c +const + ORIENT_xyz1 = 'xxyyzzg'; //note Pascal strings indexed from 1, not 0! + ORIENT_sign1 = '+--++-'; //note Pascal strings indexed from 1, not 0! +var + axnum: array[0..2] of integer; + axcode,axsign: array[0..2] of char; + axstart,axstep: array[0..2] of single; + ii, nif_x_axnum, nif_y_axnum, nif_z_axnum: integer; + qto_xyz: mat44; + //dumqx, dumqy, dumqz, dumdx, dumdy, dumdz: single; +begin + nif_x_axnum := -1; + nif_y_axnum := -1; + nif_z_axnum := -1; + axnum[0] := nhdr.dim[1]; + axnum[1] := nhdr.dim[2]; + axnum[2] := nhdr.dim[3]; + axcode[0] := ORIENT_xyz1[1+ orientSpecific[0] ] ; + axcode[1] := ORIENT_xyz1[1+ orientSpecific[1] ] ; + axcode[2] := ORIENT_xyz1[1+ orientSpecific[2] ] ; + axsign[0] := ORIENT_sign1[1+ orientSpecific[0] ] ; + axsign[1] := ORIENT_sign1[1+ orientSpecific[1] ] ; + axsign[2] := ORIENT_sign1[1+ orientSpecific[2] ] ; + axstep[0] := xyzDelta[0] ; + axstep[1] := xyzDelta[1] ; + axstep[2] := xyzDelta[2] ; + axstart[0] := xyzOrigin[0] ; + axstart[1] := xyzOrigin[1] ; + axstart[2] := xyzOrigin[2] ; + for ii := 0 to 2 do begin + if (axcode[ii] = 'x') then + nif_x_axnum := ii + else if (axcode[ii] = 'y') then + nif_y_axnum := ii + else + nif_z_axnum := ii ; + end; + if (nif_x_axnum < 0) or (nif_y_axnum < 0) or (nif_z_axnum < 0) then exit; //not assigned + if (nif_x_axnum = nif_y_axnum) or (nif_x_axnum = nif_z_axnum) or (nif_y_axnum = nif_z_axnum) then exit; //not assigned + ZERO_MAT44(qto_xyz); + //-- set voxel and time deltas and units -- + nhdr.pixdim[1] := abs ( axstep[0] ) ; + nhdr.pixdim[2] := abs ( axstep[1] ) ; + nhdr.pixdim[3] := abs ( axstep[2] ) ; + qto_xyz[0,nif_x_axnum] := - axstep[nif_x_axnum]; + qto_xyz[1,nif_y_axnum] := - axstep[nif_y_axnum]; + qto_xyz[2,nif_z_axnum] := axstep[nif_z_axnum]; + nhdr.qoffset_x := -axstart[nif_x_axnum] ; + nhdr.qoffset_y := -axstart[nif_y_axnum]; + nhdr.qoffset_z := axstart[nif_z_axnum]; + qto_xyz[0,3] := nhdr.qoffset_x ; + qto_xyz[1,3] := nhdr.qoffset_y ; + qto_xyz[2,3] := nhdr.qoffset_z ; + //nifti_mat44_to_quatern( qto_xyz , nhdr.quatern_b, nhdr.quatern_c, nhdr.quatern_d,dumqx, dumqy, dumqz, dumdx, dumdy, dumdz,nhdr.pixdim[0]) ; + //nhdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; + nhdr.srow_x[0] :=qto_xyz[0,0]; nhdr.srow_x[1] :=qto_xyz[0,1]; nhdr.srow_x[2] :=qto_xyz[0,2]; nhdr.srow_x[3] :=qto_xyz[0,3]; + nhdr.srow_y[0] :=qto_xyz[1,0]; nhdr.srow_y[1] :=qto_xyz[1,1]; nhdr.srow_y[2] :=qto_xyz[1,2]; nhdr.srow_y[3] :=qto_xyz[1,3]; + nhdr.srow_z[0] :=qto_xyz[2,0]; nhdr.srow_z[1] :=qto_xyz[2,1]; nhdr.srow_z[2] :=qto_xyz[2,2]; nhdr.srow_z[3] :=qto_xyz[2,3]; + nhdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT; +end; + +function readAFNIHeader (var fname: string; var nhdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +label + 666; +var + sl, mArray: TStringList; + typeStr,nameStr, valStr: string; + lineNum, itemCount,i, vInt, nVols: integer; + isAllVolumesSame, isProbMap, isStringAttribute: boolean; + valArray : Array of double; + orientSpecific: ivect3; + xyzOrigin, xyzDelta: vect3; +begin + nVols := 1; + result := false; + isProbMap := false; + gzBytes := 0; + swapEndian := false; + sl := TStringList.Create; + mArray := TStringList.Create; + sl.LoadFromFile(fname); + if(sl.count) < 4 then goto 666; + lineNum := -1; + repeat + //read type string + lineNum := lineNum + 1; + if length(sl[lineNum]) < 1 then continue; + splitstr('=',sl[lineNum],mArray); + if mArray.Count < 2 then continue; + if not AnsiContainsText(cleanStr(mArray[0]), 'type') then continue; + typeStr := cleanStr(mArray[1]); + isStringAttribute := AnsiContainsText(typeStr, 'string-attribute'); + //next: read name string + lineNum := lineNum + 1; + if (lineNum >= (sl.count-1)) then continue; + splitstr('=',sl[lineNum],mArray); + if mArray.Count < 2 then continue; + if not AnsiContainsText(cleanStr(mArray[0]), 'name') then continue; + nameStr := cleanStr(mArray[1]); + //if AnsiContainsText(nameStr,'BYTEORDER_STRING') and isStringAttribute then showmessage('txt'); + //next: read count string + lineNum := lineNum + 1; + if (lineNum >= (sl.count-1)) then continue; + splitstr('=',sl[lineNum],mArray); + if mArray.Count < 2 then continue; + if not AnsiContainsText(cleanStr(mArray[0]), 'count') then continue; + itemCount := strtoint(cleanStr(mArray[1])); + if itemCount < 1 then exit; + //next read values + lineNum := lineNum + 1; + if (lineNum > (sl.count-1)) then continue; + valStr := sl[lineNum]; + while ((lineNum+1) <= (sl.count-1)) and (length(sl[lineNum+1]) > 0) do begin + lineNum := lineNum + 1; //AFNI wraps some arrays across multiple lines + valStr := valStr + ' '+ sl[lineNum]; + end; + splitstr(' ',valStr,mArray); + if (mArray.Count < itemCount) then itemCount := mArray.Count; // <- only if corrupt + if itemCount < 1 then continue; // <- only if corrupt data + if isStringAttribute then begin + if AnsiContainsText(nameStr,'BYTEORDER_STRING') then begin + {$IFDEF ENDIAN_BIG} + if AnsiContainsText(mArray[0],'LSB_FIRST') then swapEndian := true; + {$ELSE} + if AnsiContainsText(mArray[0],'MSB_FIRST') then swapEndian := true; + {$ENDIF} + end + end else begin //if numeric attributes... + setlength(valArray,itemCount); + for i := 0 to (itemCount-1) do + valArray[i] := strtofloat(cleanStr(mArray[i]) ); + //next - harvest data from important names + if AnsiContainsText(nameStr,'BRICK_TYPES') then begin + vInt := round(valArray[0]); + if (vInt = 0) then begin + nhdr.datatype := kDT_UINT8; + end else if (vInt = 1) then begin + nhdr.datatype := kDT_INT16; //16 bit signed int + end else if (vInt = 3) then begin + nhdr.datatype := kDT_FLOAT32;//32-bit float + end else begin + NSLog('Unsupported BRICK_TYPES '+inttostr(vInt)); + goto 666; + end; + if (itemCount > 1) then begin //check that all volumes are of the same datatype + nVols := itemCount; + isAllVolumesSame := true; + for i := 1 to (itemCount-1) do + if (valArray[0] <> valArray[i]) then isAllVolumesSame := false; + if (not isAllVolumesSame) then begin + NSLog('Unsupported BRICK_TYPES feature: datatype varies between sub-bricks'); + goto 666; + end; + end; //if acount > 0 + //NSLog('HEAD datatype is '+inttostr(nhdr.datatype) ); + end else if AnsiContainsText(nameStr,'BRICK_FLOAT_FACS') then begin + nhdr.scl_slope := valArray[0]; + if (itemCount > 1) then begin //check that all volumes are of the same datatype + isAllVolumesSame := true; + for i := 1 to (itemCount-1) do + if (valArray[0] <> valArray[i]) then isAllVolumesSame := false; + if (not isAllVolumesSame) then begin + NSLog('Unsupported BRICK_FLOAT_FACS feature: intensity scale between sub-bricks'); + end; + end; //if acount > 0 + end else if AnsiContainsText(nameStr,'DATASET_DIMENSIONS') then begin + if itemCount > 3 then itemCount := 3; + for i := 0 to (itemCount-1) do + nhdr.dim[i+1] := round(valArray[i]); + end else if AnsiContainsText(nameStr,'ORIENT_SPECIFIC') then begin + if itemCount > 3 then itemCount := 3; + for i := 0 to (itemCount-1) do + orientSpecific[i] := round(valArray[i]);; + //NSLog(@"HEAD orient specific %d %d %d",orientSpecific.v[0],orientSpecific.v[1],orientSpecific.v[2]); + end else if AnsiContainsText(nameStr,'ORIGIN') then begin + if itemCount > 3 then itemCount := 3; + for i := 0 to (itemCount-1) do + xyzOrigin[i] := valArray[i]; + //NSLog(@"HEAD origin %g %g %g",xyzOrigin.v[0],xyzOrigin.v[1],xyzOrigin.v[2]); + end else if AnsiContainsText(nameStr,'ATLAS_PROB_MAP') then begin + if (round(valArray[0]) = 1) then isProbMap := true; + end else if AnsiContainsText(nameStr,'ATLAS_LABEL_TABLE') then begin + nhdr.intent_code := kNIFTI_INTENT_LABEL; + end else if AnsiContainsText(nameStr,'DELTA') then begin + if itemCount > 3 then itemCount := 3; + for i := 0 to (itemCount-1) do + xyzDelta[i] := valArray[i]; + //NSLog(@"HEAD delta %g %g %g",xyzDelta.v[0],xyzDelta.v[1],xyzDelta.v[2]); + end else if AnsiContainsText(nameStr,'TAXIS_FLOATS') then begin + if (itemCount > 1) then nhdr.pixdim[4] := valArray[1]; //second item is TR + end; + end;// if isStringAttribute else numeric inputs... + until (lineNum >= (sl.count-1)); + result := true; +666: + valArray := nil; //release dynamic array + Filemode := 2; + sl.free; + mArray.free; + if not result then exit; //error - code jumped to 666 without setting result to true + if (nVols > 1) then nhdr.dim[4] := nVols; + if (isProbMap) and (nhdr.intent_code = kNIFTI_INTENT_LABEL) then nhdr.intent_code := kNIFTI_INTENT_NONE; + THD_daxes_to_NIFTI(nhdr, xyzDelta, xyzOrigin, orientSpecific ); + nhdr.vox_offset := 0; + convertForeignToNifti(nhdr); + fname := ChangeFileExtX(fname, '.BRIK'); + if (not FileExistsEX(fname)) then begin + fname := fname+'.gz'; + gzBytes := K_gzBytes_onlyImageCompressed; //separate file, so K_gzBytes_headerAndImageCompressed would also work + end; +end; + +function readForeignHeader (var lFilename: string; var lHdr: TNIFTIhdr; var gzBytes: int64; var swapEndian: boolean): boolean; +var + lExt: string; +begin + NII_Clear (lHdr); + result := false; + lExt := UpCaseExt(lFilename); + if (lExt = '.MGH') or (lExt = '.MGZ') then + result := readMGHHeader(lFilename, lHdr, gzBytes, swapEndian) + else if (lExt = '.MHD') or (lExt = '.MHA') then + result := readMHAHeader(lFilename, lHdr, gzBytes, swapEndian) + else if (lExt = '.NRRD') or (lExt = '.NHDR') then + result := readNRRDHeader(lFilename, lHdr, gzBytes, swapEndian) + else if (lExt = '.HEAD') then + result := readAFNIHeader(lFilename, lHdr, gzBytes, swapEndian); +end; + +end. + diff --git a/niftiview7/nifti_hdr.pas b/niftiview7/nifti_hdr.pas new file mode 100755 index 0000000..5469253 --- /dev/null +++ b/niftiview7/nifti_hdr.pas @@ -0,0 +1,1623 @@ +unit nifti_hdr; +interface +uses Dialogs ,gzio,ZLib,SysUtils,DiskSpaceKludge{DiskSpaceEX}, define_types,Windows,GraphicsMathLibrary, nifti_types, nifti_foreign; + +type + + TMRIcroHdr = record //Next: analyze Format Header structure + NIFTIhdr : TNIFTIhdr; + //Ori: array [1..3] of single; + AutoBalMinUnscaled,AutoBalMaxUnscaled + ,WindowScaledMin,WindowScaledMax + ,GlMinUnscaledS,GlMaxUnscaledS,Zero8Bit,Slope8bit: single; //brightness and contrast + NIfTItransform,DiskDataNativeEndian,UsesCustomPalette,LutFromZero,usesLabels,UsesCustomPaletteRandomRainbow: boolean; + HdrFileName,ImgFileName: string; + gzBytesX: int64; + LUTindex,ScrnBufferItems,ImgBufferItems,RenderBufferItems,ImgBufferBPP,RenderDim,Index: longint; + ImgBufferUnaligned: Pointer; //raw address of Image Buffer: address may not be aligned + ScrnBuffer,ImgBuffer,RenderBuffer: Bytep; + LUTinvisible: DWord;//DWord; + LUT: TLUT; + Mat: TMatrix; + end; //TNIFTIhdr Header Structure + + + function IsVOIROIExt (var lFName: string):boolean; + function ComputeImageDataBytes (var lHdr: TMRIcroHdr): longint; //size of image data in bytes + function ComputeImageDataBytes8bpp (var lHdr: TMRIcroHdr): longint; //size of image as 32-bit per voxel data in bytes + function ComputeImageDataBytes32bpp (var lHdr: TMRIcroHdr): longint; //size of image as 32-bit per voxel data in bytes + procedure NIFTIhdr_SwapBytes (var lAHdr: TNIFTIhdr); //Swap Byte order for the Analyze type + procedure NIFTIhdr_ClearHdr (var lHdr: TMRIcroHdr); //set all values of header to something reasonable + function NIFTIhdr_LoadHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TMRIcroHdr; lAllowOverwrite: boolean): boolean; + //procedure NIFTIhdr_SetIdentityMatrix (var lHdr: TMRIcroHdr); //create neutral rotation matrix + //procedure NII_SetIdentityMatrix (var lHdr: TNIFTIhdr); //create neutral rotation matrix + function IsNIfTIHdrExt (var lFName: string):boolean; //1494 + function IsNifTiMagic (var lHdr: TNIFTIhdr): boolean; + procedure nifti_mat2mricronmat (var lHdr: TMRIcroHdr); + //procedure NearestOrtho(var lHdr: TMRIcroHdr); +//function nifti_mat44_orthog( lR :TMatrix; lImm,lJmm,lKmm: double): TMatrix; + + function CopyNiftiHdr (var lInHdr,lOutHdr: TNIFTIhdr): boolean; + procedure WriteNiftiMatrix (var lHdr: TNIFTIhdr; + m11,m12,m13,m14, + m21,m22,m23,m24, + m31,m32,m33,m34: Single); + procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); + procedure nifti_mat2quat (var lHdr: TNIfTIhdr); + + +implementation +uses dicomhdr;//2/2208 + +procedure nifti_mat2mricronmat (var lHdr: TMRIcroHdr); +begin + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); +end; + + + +procedure nifti_mat2quat (var lHdr: TNIfTIhdr); +var + lM: TMatrix; + var qb, qc, qd,qx, qy, qz,dx, dy, dz {, qfac} : single; +begin + lM := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], // 3D "graphics" matrix + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], // 3D "graphics" matrix + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + nifti_mat44_to_quatern( lM,qb, qc, qd,qx, qy, qz,dx, dy, dz, lHdr.pixdim[0]); + lHdr.quatern_b := qb; + lHdr.quatern_c := qc; + lHdr.quatern_d := qd; + lHdr.qoffset_x := qx; + lHdr.qoffset_y := qy; + lHdr.qoffset_z := qz; + //lHdr.pixdim[0] := qfac; +end; + + + +function CopyNiftiHdr (var lInHdr,lOutHdr: TNIFTIhdr): boolean; +begin + move(lInHdr,lOutHdr,sizeof(TNIFTIhdr)); + result := true; +end; + +procedure WriteNiftiMatrix (var lHdr: TNIFTIhdr; + m11,m12,m13,m14, + m21,m22,m23,m24, + m31,m32,m33,m34: Single); +begin + with lHdr do begin + srow_x[0] := m11; + srow_x[1] := m12; + srow_x[2] := m13; + srow_x[3] := m14; + srow_y[0] := m21; + srow_y[1] := m22; + srow_y[2] := m23; + srow_y[3] := m24; + srow_z[0] := m31; + srow_z[1] := m32; + srow_z[2] := m33; + srow_z[3] := m34; + end; //with lHdr +end; + + +function IsNifTiMagic (var lHdr: TNIFTIhdr): boolean; +begin + if (lHdr.magic =kNIFTI_MAGIC_SEPARATE_HDR) or (lHdr.Magic = kNIFTI_MAGIC_EMBEDDED_HDR ) then + result := true + else + result :=false; //analyze +end; + +function IsNIfTIHdrExt (var lFName: string):boolean; +var + lExt: string; +begin + lExt := UpCaseExt(lFName); + if (lExt='.NII') or (lExt = '.HDR') or (lExt = '.NII.GZ') or (lExt = '.VOI') then + result := true + else + result := false; +end; + +function IsVOIROIExt (var lFName: string):boolean; +var + lExt: string; +begin + lExt := UpCaseExt(lFName); + if (lExt = '.VOI') or (lExt = '.ROI') then + result := true + else + result := false; +end; + +function ComputeImageDataBytes32bpp (var lHdr: TMRIcroHdr): integer; +var + lDim, lSzInBits : integer; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + showmessage('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + lSzInBits := 32; //bits per voxel + for lDim := 1 to 3 {Dim[0]} do + lSzInBits := lSzInBits * Dim[lDim]; + end; //with niftihdr + result := (lSzInBits + 7) div 8; //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes32bpp + +function ComputeImageDataBytes8bpp (var lHdr: TMRIcroHdr): integer; +var + lDim, lSzInBits : integer; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + showmessage('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + lSzInBits := 8; //bits per voxel + for lDim := 1 to 3 {Dim[0]} do + lSzInBits := lSzInBits * Dim[lDim]; + end; //with niftihdr + result := (lSzInBits + 7) div 8; //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes8bpp +function ComputeImageDataBytes (var lHdr: TMRIcroHdr): integer; +var + lDim, lVox : integer; +begin + result := 0; + with lHdr.NIFTIhdr do begin + if Dim[0] < 1 then begin + showmessage('NIFTI format error: datasets must have at least one dimension (dim[0] < 1).'); + exit; + end; + //lSzInBits := bitpix; //bits per voxel + if bitpix < 1 then exit; + lVox := 1; + for lDim := 1 to 3 {Dim[0]} do + lVox := lVox * Dim[lDim]; + if lVox < 1 then + exit; + if (bitpix mod 8) = 0 then + result := lVox * (bitpix div 8) + else + result := (lVox*bitpix + 7) div 8; + //showmessage(inttostr(bitpix)); + end; //with niftihdr + + //+7 to ensure binary data not clipped +end; //func ComputeImageDataBytes + + +function orthogonalMatrix(var lHdr: TMRIcroHdr): boolean; +var + lM: TMatrix; + lRow,lCol,lN0: integer; +begin + result := false; + lM := Matrix3D ( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + for lRow := 1 to 3 do begin + lN0 := 0; + for lCol := 1 to 3 do + if lM.matrix[lRow,lCol] = 0 then + inc(lN0); + if lN0 <> 2 then exit; //exactly two values are zero + end; + for lCol := 1 to 3 do begin + lN0 := 0; + for lRow := 1 to 3 do + if lM.matrix[lRow,lCol] = 0 then + inc(lN0); + if lN0 <> 2 then exit; //exactly two values are zero + end; + result := true; +end; + +function EmptyRow (lRow: integer; var lM: TMatrix): boolean; +begin + //fx(lM.matrix[lRow,1],lM.matrix[lRow,2],lM.matrix[lRow,3]); + if (abs(lM.matrix[lRow,1]) < 0.00000001) and (abs(lM.matrix[lRow,2]) < 0.00000001) and (abs(lM.matrix[lRow,3]) < 0.00000001) then + result := true + else + result := false; +end; + +procedure ReportMatrix (lStr: string;lM:TMatrix); +begin + showmessage(lStr+kCR+ + RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+ + kCR+RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+ + kCR+RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+ + kCR+RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6)); +end; + +function EmptyMatrix(var lHdr: TMRIcroHdr): boolean; +var + lM: TMatrix; + lRow,lCol: integer; +begin + result := false; + lM := Matrix3D ( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + //ReportMatrix('x',lm); + if EmptyRow(1,lM) or EmptyRow(2,lM) or EmptyRow(3,lM) then begin + //ReportMatrix('Matrix appears bogus',lm); + end else begin + for lRow := 1 to 3 do begin {3/2008} + for lCol := 1 to 4 do begin + if (lRow = lCol) then begin + if lM.matrix[lRow,lCol] <> 1 then + exit; + end else begin + if lM.matrix[lRow,lCol] <> 0 then + exit; + end// unity matrix does not count - mriconvert creates bogus [1 0 0 0; 0 1 0 0; 0 0 1 0; 0 0 0 0] + end; //each col + end;//each row + end; + + result := true; +end; + + + +procedure FromMatrix (M: TMatrix; var m11,m12,m13, m21,m22,m23, + m31,m32,m33: DOUBLE) ; + BEGIN + + m11 := M.Matrix[1,1]; + m12 := M.Matrix[1,2]; + m13 := M.Matrix[1,3]; + m21 := M.Matrix[2,1]; + m22 := M.Matrix[2,2]; + m23 := M.Matrix[2,3]; + m31 := M.Matrix[3,1]; + m32 := M.Matrix[3,2]; + m33 := M.Matrix[3,3]; +END {FromMatrix3D}; + + +function nifti_mat33_determ( R: TMatrix ):double; //* determinant of 3x3 matrix */ +begin + result := r.matrix[1,1]*r.matrix[2,2]*r.matrix[3,3] + -r.matrix[1,1]*r.matrix[3,2]*r.matrix[2,3] + -r.matrix[2,1]*r.matrix[1,2]*r.matrix[3,3] + +r.matrix[2,1]*r.matrix[3,2]*r.matrix[1,3] + +r.matrix[3,1]*r.matrix[1,2]*r.matrix[2,3] + -r.matrix[3,1]*r.matrix[2,2]*r.matrix[1,3] ; +end; + +procedure FixCrapMat(var lMat: TMatrix); +var + lVec000,lVec100,lVec010,lVec001: TVector; +begin + lVec000 := Vector3D (0, 0, 0); + lVec100 := Vector3D (1, 0, 0); + lVec010 := Vector3D (0, 1, 0); + lVec001 := Vector3D (0, 0, 1); + lVec000 := Transform (lVec000, lMat); + lVec100 := Transform (lVec100, lMat); + lVec010 := Transform (lVec010, lMat); + lVec001 := Transform (lVec001, lMat); + + if SameVec(lVec000,lVec100) or + SameVec(lVec000,lVec010) or + SameVec(lVec000,lVec001) then begin + lMat := eye3D; + showmessage('Warning: the transformation matrix is corrupt [some dimensions have zero size]'); + end; +end; + + +function nifti_mat33_rownorm( A: TMatrix ): single; //* max row norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A.matrix[1,1])+abs(A.matrix[1,2])+abs(A.matrix[1,3]) ; + r2 := abs(A.matrix[2,1])+abs(A.matrix[2,2])+abs(A.matrix[2,3]) ; + r3 := abs(A.matrix[3,1])+abs(A.matrix[3,2])+abs(A.matrix[3,3]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_colnorm( A: TMatrix ): single; //* max column norm of 3x3 matrix */ +var + r1,r2,r3: single ; +begin + r1 := abs(A.matrix[1,1])+abs(A.matrix[2,1])+abs(A.matrix[3,1]) ; + r2 := abs(A.matrix[1,2])+abs(A.matrix[2,2])+abs(A.matrix[3,2]) ; + r3 := abs(A.matrix[1,3])+abs(A.matrix[2,3])+abs(A.matrix[3,3]) ; + if( r1 < r2 ) then r1 := r2 ; + if( r1 < r3 ) then r1 := r3 ; + result := r1 ; +end; + +function nifti_mat33_inverse( R: TMatrix ): TMatrix; //* inverse of 3x3 matrix */ +var + r11,r12,r13,r21,r22,r23,r31,r32,r33 , deti: double ; + Q: TMatrix ; +begin + FromMatrix(R,r11,r12,r13,r21,r22,r23,r31,r32,r33); + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + + if( deti <> 0.0 ) then deti := 1.0 / deti ; + + Q.matrix[1,1] := deti*( r22*r33-r32*r23) ; + Q.matrix[1,2] := deti*(-r12*r33+r32*r13) ; + Q.matrix[1,3] := deti*( r12*r23-r22*r13) ; + + Q.matrix[2,1] := deti*(-r21*r33+r31*r23) ; + Q.matrix[2,2] := deti*( r11*r33-r31*r13) ; + Q.matrix[2,3] := deti*(-r11*r23+r21*r13) ; + + Q.matrix[3,1] := deti*( r21*r32-r31*r22) ; + Q.matrix[3,2] := deti*(-r11*r32+r31*r12) ; + Q.matrix[3,3] := deti*( r11*r22-r21*r12) ; + result := Q; +end; + +function nifti_mat33_polar( A: TMatrix ): TMatrix; +var + k:integer; + X , Y , Z: TMatrix ; + dif,alp,bet,gam,gmi : single; +begin +dif := 1; +k := 0; + X := A ; + // force matrix to be nonsingular + //reportmatrix('x',X); + gam := nifti_mat33_determ(X) ; + while( gam = 0.0 )do begin //perturb matrix + gam := 0.00001 * ( 0.001 + nifti_mat33_rownorm(X) ) ; + X.matrix[1,1] := X.matrix[1,1]+gam ; + X.matrix[2,2] := X.matrix[2,2]+gam ; + X.matrix[3,3] := X.matrix[3,3] +gam ; + gam := nifti_mat33_determ(X) ; + end; + + while true do begin + Y := nifti_mat33_inverse(X) ; + if( dif > 0.3 )then begin // far from convergence + alp := sqrt( nifti_mat33_rownorm(X) * nifti_mat33_colnorm(X) ) ; + bet := sqrt( nifti_mat33_rownorm(Y) * nifti_mat33_colnorm(Y) ) ; + gam := sqrt( bet / alp ) ; + gmi := 1.0 / gam ; + end else begin + gam := 1.0; + gmi := 1.0 ; //close to convergence + end; + Z.matrix[1,1] := 0.5 * ( gam*X.matrix[1,1] + gmi*Y.matrix[1,1] ) ; + Z.matrix[1,2] := 0.5 * ( gam*X.matrix[1,2] + gmi*Y.matrix[2,1] ) ; + Z.matrix[1,3] := 0.5 * ( gam*X.matrix[1,3] + gmi*Y.matrix[3,1] ) ; + Z.matrix[2,1] := 0.5 * ( gam*X.matrix[2,1] + gmi*Y.matrix[1,2] ) ; + Z.matrix[2,2] := 0.5 * ( gam*X.matrix[2,2] + gmi*Y.matrix[2,2] ) ; + Z.matrix[2,3] := 0.5 * ( gam*X.matrix[2,3] + gmi*Y.matrix[3,2] ) ; + Z.matrix[3,1] := 0.5 * ( gam*X.matrix[3,1] + gmi*Y.matrix[1,3] ) ; + Z.matrix[3,2] := 0.5 * ( gam*X.matrix[3,2] + gmi*Y.matrix[2,3] ) ; + Z.matrix[3,3] := 0.5 * ( gam*X.matrix[3,3] + gmi*Y.matrix[3,3] ) ; + + dif := abs(Z.matrix[1,1]-X.matrix[1,1])+abs(Z.matrix[1,2]-X.matrix[1,2]) + +abs(Z.matrix[1,3]-X.matrix[1,3])+abs(Z.matrix[2,1]-X.matrix[2,1]) + +abs(Z.matrix[2,2]-X.matrix[2,2])+abs(Z.matrix[2,3]-X.matrix[2,3]) + +abs(Z.matrix[3,1]-X.matrix[3,1])+abs(Z.matrix[3,2]-X.matrix[3,2]) + +abs(Z.matrix[3,3]-X.matrix[3,3]) ; + k := k+1 ; + if( k > 100) or (dif < 3.e-6 ) then begin + result := Z; + break ; //convergence or exhaustion + end; + X := Z ; + end; + result := Z ; +end; + + + + + + + (* + + + + + +{ +polar decomposition of a 3x3 matrix + + This finds the closest orthogonal matrix to input A + (in both the Frobenius and L2 norms). + + Algorithm is that from NJ Higham, SIAM J Sci Stat Comput, 7:1160-1174.} + + + +procedure nifti_mat44_orthog11( lR :TMatrix); +//reutrns orthogonalized matrix +var +m11,m12,m13 , m21,m22,m23 , m31,m32,m33, + u11,u21,u31,u22,u32,u33, + v33,v32,v31,v22,v21,v11,n11,n12,n13,n22,n23,n33, + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd: double; + + Q: TMatrix; //3x3 +begin + // load 3x3 matrix into local variables + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + // Step 1 -- form symmetric M = A.transpose * A +m11 := r11*r11 + r21*r21 + r31*r31; +m12 := r11*r12 + r21*r22 + r31*r32; +m13 := r11*r13 + r21*r23 + r31*r33; +m22 := r12*r12 + r22*r22 + r32*r32; +m23 := r12*r13 + r22*r23 + r32*r33; +m33 := r13*r13 + r23*r23 + r33*r33; + +// Step 2 -- find lower-triangular U such that U * U.transpose = M +u11 := sqrt(m11); +u21 := m12/u11; +u31 := m13/u11; +u22 := sqrt(m22-u21*u21); +u32 := (m23-m12*m13/m11)/u22; +u33 := sqrt(m33 - u31*u31 - u32*u32); +// Step 3 -- find V such that V*V = U. U is also lower-triangular +v33 := 1/u33; +v32 := -v33*u32/u22; +v31 := -(v32*u21+v33*u31)/u11; +v22 := 1/u22; +v21 := -v22*u21/u11; +v11 := 1/u11; +// Step 4 -- N = V.transpose * V is inverse(sqrt(A.transpose()*A.inverse())) +n11 := v11*v11 + v21*v21 + v31*v31; +n12 := v11*v21 + v21*v22 + v31*v32; +n13 := v11*v31 + v21*v32 + v31*v33; +n22 := v21*v21 + v22*v22 + v32*v32; +n23 := v21*v31 + v22*v32 + v32*v33; +n33 := v31*v31 + v32*v32 + v33*v33; + +// Step 5 -- The new matrix is A * N +m11 := r11*n11 + r12*n12 + r13*n13; +m12 := r11*n12 + r12*n22 + r13*n23; +m13 := r11*n13 + r12*n23 + r13*n33; +m21 := r21*n11 + r22*n12 + r23*n13; +m22 := r21*n12 + r22*n22 + r23*n23; +m23 := r21*n13 + r22*n23 + r23*n33; +m31 := r31*n11 + r32*n12 + r33*n13; +m32 := r31*n12 + r32*n22 + r33*n23; +m33 := r31*n13 + r32*n23 + r33*n33; + Q := Matrix2D (m11,m12,m13, // 2D "graphics" matrix + m21,m22,m23, + m31,m32,m33); + ReportMatrix('pre',Q); + +end; + + +procedure nifti_mat44_orthog22( lR :TMatrix); +//reutrns orthogonalized matrix +var + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd: double; + P,Q: TMatrix; //3x3 +begin + // load 3x3 matrix into local variables + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + // compute lengths of each column; these determine grid spacings + + xd := sqrt( r11*r11 + r21*r21 + r31*r31 ) ; + yd := sqrt( r12*r12 + r22*r22 + r32*r32 ) ; + zd := sqrt( r13*r13 + r23*r23 + r33*r33 ) ; + + // if a column length is zero, patch the trouble + + if( xd = 0.0 )then begin r11 := 1.0 ; r21 := 0; r31 := 0.0 ; xd := 1.0 ; end; + if( yd = 0.0 )then begin r22 := 1.0 ; r12 := 0; r32 := 0.0 ; yd := 1.0 ; end; + if( zd = 0.0 )then begin r33 := 1.0 ; r13 := 0; r23 := 0.0 ; zd := 1.0 ; end; + + // assign the output lengths + //dx := xd; + // dy := yd; + //dz := zd; + + // normalize the columns + + r11 := r11/xd ; r21 := r21/xd ; r31 := r31/xd ; + r12 := r12/yd ; r22 := r22/yd ; r32 := r32/yd ; + r13 := r13/zd ; r23 := r23/zd ; r33 := r33/zd ; + + { At this point, the matrix has normal columns, but we have to allow + for the fact that the hideous user may not have given us a matrix + with orthogonal columns. + + So, now find the orthogonal matrix closest to the current matrix. + + One reason for using the polar decomposition to get this + orthogonal matrix, rather than just directly orthogonalizing + the columns, is so that inputting the inverse matrix to R + will result in the inverse orthogonal matrix at this point. + If we just orthogonalized the columns, this wouldn't necessarily hold. } + Q := Matrix2D (r11,r12,r13, // 2D "graphics" matrix + r21,r22,r23, + r31,r32,r33); + + + + P := nifti_mat33_polar(Q) ; // P is orthog matrix closest to Q + //FromMatrix(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); + // compute the determinant to determine if it is proper + FromMatrix(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); + {zd := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; // should be -1 or 1 + if( zd <= 0 )then begin //proper + r13 := -r13 ; r23 := -r23 ; r33 := -r33 ; + end; + P := Matrix2D( r11,r12,r13,r21,r22,r23,r31,r32,r33); + Q := MultiplyMatrices(Q,P); + } + ReportMatrix('pre',Q); + + //ReportMatrix('xxx',Q); + ReportMatrix('svd',P); +end; *) + +(*function OrthoMat (lPerm: integer): TMatrix; +var + lx,ly,lz,lPx:integer; + m11,m12,m13,m21,m22,m23,m31,m32,m33: double; + +begin + if (lPerm < 1) or (lPerm > 48) then begin + result :=Matrix2D(1,0,0,0,1,0,0,0,1); + exit; + end; + m11 := 0; + m12 := 0; + m13 := 0; + m21 := 0; + m22 := 0; + m23 := 0; + m31 :=0; + m32 := 0; + m33 := 0; + lPx := ((lPerm-1) div 6)+1; //1..8 + if lPx <= 4 then + lx := 1 + else + lx := -1; + if odd(lPx) then + ly := 1 + else + ly := -1; + if (lPx = 1) or (lPx = 2) or (lPx = 5) or (lPx = 6) then + lz := 1 + else + lz := -1; + lPx := lPerm mod 6; + case lPx of + 1: begin m11:= lx; m22 := ly; m33 := lz end; + 2: begin m11:= lx; m23 := ly; m32 := lz end; + 3: begin m12:= lx; m21 := ly; m33 := lz end; + 4: begin m12:= lx; m23 := ly; m31 := lz end; + 5: begin m13:= lx; m21 := ly; m32 := lz end; + else begin m13:= lx; m22 := ly; m31 := lz end; + end; + + result := Matrix2D (m11,m12,m13, // 2D "graphics" matrix + m21,m22,m23, + m31,m32,m33); + +end; + +function ErrorSqr (lA,lB: TMatrix): double; +var + lr,lc: integer; +begin + result := 0; + for lr := 1 to 3 do + for lc := 1 to 3 do + result := result + sqr(lA.matrix[lr,lc]-lB.matrix[lr,lc]) + +end; + +function nifti_mat44_orthog( lR :TMatrix; lImm,lJmm,lKmm: double): TMatrix; +//reutrns orthogonalized matrix +var + i,lmini: integer; + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, val,lmin: double; + P,Q,R: TMatrix; //3x3 +begin + // load 3x3 matrix into local variables + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + //R.m[3][0] = R.m[3][1] = R.m[3][2] = 0.0l ; R.m[3][3] = 1.0l ; + Q := Matrix2D( r11,r12,r13,r21,r22,r23,r31,r32,r33); + //* normalize row 1 */ + + val := Q.matrix[1,1]*Q.matrix[1,1] + Q.matrix[1,2]*Q.matrix[1,2] + Q.matrix[1,3]*Q.matrix[1,3] ; + if( val > 0.0 )then begin + val := 1.0 / sqrt(val) ; + Q.matrix[1,1] := Q.matrix[1,1]*val ; + Q.matrix[1,2] := Q.matrix[1,2]*val ; + Q.matrix[1,3] := Q.matrix[1,3]*val ; + end else begin + Q.matrix[1,1] := 1.0 ; Q.matrix[1,2] := 0.0; Q.matrix[1,3] := 0.0 ; + end; + + //* normalize row 2 */ + val := Q.matrix[2,1]*Q.matrix[2,1] + Q.matrix[2,2]*Q.matrix[2,2] + Q.matrix[2,3]*Q.matrix[2,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[2,1] := Q.matrix[2,1]* val ; + Q.matrix[2,2] := Q.matrix[2,2] * val ; + Q.matrix[2,3] := Q.matrix[2,3] * val ; + end else begin + Q.matrix[2,1] := 0.0 ; Q.matrix[2,2] := 1.0 ; Q.matrix[2,3] := 0.0 ; + end; + + //* normalize row 3 */ + val := Q.matrix[3,1]*Q.matrix[3,1] + Q.matrix[3,2]*Q.matrix[3,2] + Q.matrix[3,3]*Q.matrix[3,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[3,1] := Q.matrix[3,1] *val ; + Q.matrix[3,2] := Q.matrix[3,2] *val ; + Q.matrix[3,3] := Q.matrix[3,3] *val ; + end else begin + Q.matrix[3,1] := Q.matrix[1,2]*Q.matrix[2,3] - Q.matrix[1,3]*Q.matrix[2,2] ; //* cross */ + Q.matrix[3,2] := Q.matrix[1,3]*Q.matrix[2,1] - Q.matrix[1,1]*Q.matrix[2,3] ; //* product */ + Q.matrix[3,3] := Q.matrix[1,1]*Q.matrix[2,2] - Q.matrix[1,2]*Q.matrix[2,1] ; + end; + //ReportMatrix(inttostr(lmini),Q); + P := OrthoMat(1); + lmin := ErrorSqr(Q,P); + lmini := 1; + for i := 2 to 48 do begin + P := OrthoMat(i); + val := ErrorSqr(Q,P); + //if val = lmin then + // showmessage('tie'); + if val < lmin then begin + lmin := val; + lmini := i; + end; + //ReportMatrix(inttostr(i),OrthoMat(i)); + end; + + P := OrthoMat(lmini) ; + //finally - rescale by input dimensions... + P.matrix[1,1] := P.matrix[1,1] * lImm; + P.matrix[1,2] := P.matrix[1,2] * lImm; + P.matrix[1,3] := P.matrix[1,3] * lImm; + + P.matrix[2,1] := P.matrix[2,1] * lJmm; + P.matrix[2,2] := P.matrix[2,2] * lJmm; + P.matrix[2,3] := P.matrix[2,3] * lJmm; + + P.matrix[3,1] := P.matrix[3,1] * lKmm; + P.matrix[3,2] := P.matrix[3,2] * lKmm; + P.matrix[3,3] := P.matrix[3,3] * lKmm; + result := P; + //ReportMatrix(inttostr(lmini),OrthoMat(lmini)); +end; + *) + { +} + +(*function EyeMatrix (lM: TMatrix): boolean; +//check that diagonals are positive and all other cells are zero +//negative diagonals suggests flipping... +//non-negative other cells suggests the image is not pure axial +var + lr,lc: integer; +begin + result := false; + for lr := 1 to 3 do + for lc := 1 to 3 do begin + if (lr = lc) and (lM.matrix[lr,lc] <= 0) then + exit; + if (lr <> lc) and (lM.matrix[lr,lc] <> 0) then + exit; + + end; + result := true; +end; + + +function nifti_mat44_orthogx( lR :TMatrix): TMatrix; +//returns rotation matrix required to orient image so it is aligned nearest to the identity matrix = +// 1 0 0 0 +// 0 1 0 0 +// 0 0 1 0 +// 0 0 0 1 +//Therefore, image is approximately oriented in space +var + i,lrow,lcol,lMaxRow,lMaxCol,l2ndMaxRow,l2ndMaxCol,l3rdMaxRow,l3rdMaxCol: integer; + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, val,lAbsmax,lAbs: double; + Q: TMatrix; //3x3 +begin + // load 3x3 matrix into local variables + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + Q := Matrix2D( r11,r12,r13,r21,r22,r23,r31,r32,r33); + // normalize row 1 + val := Q.matrix[1,1]*Q.matrix[1,1] + Q.matrix[1,2]*Q.matrix[1,2] + Q.matrix[1,3]*Q.matrix[1,3] ; + if( val > 0.0 )then begin + val := 1.0 / sqrt(val) ; + Q.matrix[1,1] := Q.matrix[1,1]*val ; + Q.matrix[1,2] := Q.matrix[1,2]*val ; + Q.matrix[1,3] := Q.matrix[1,3]*val ; + end else begin + Q.matrix[1,1] := 1.0 ; Q.matrix[1,2] := 0.0; Q.matrix[1,3] := 0.0 ; + end; + // normalize row 2 + val := Q.matrix[2,1]*Q.matrix[2,1] + Q.matrix[2,2]*Q.matrix[2,2] + Q.matrix[2,3]*Q.matrix[2,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[2,1] := Q.matrix[2,1]* val ; + Q.matrix[2,2] := Q.matrix[2,2] * val ; + Q.matrix[2,3] := Q.matrix[2,3] * val ; + end else begin + Q.matrix[2,1] := 0.0 ; Q.matrix[2,2] := 1.0 ; Q.matrix[2,3] := 0.0 ; + end; + // normalize row 3 + val := Q.matrix[3,1]*Q.matrix[3,1] + Q.matrix[3,2]*Q.matrix[3,2] + Q.matrix[3,3]*Q.matrix[3,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[3,1] := Q.matrix[3,1] *val ; + Q.matrix[3,2] := Q.matrix[3,2] *val ; + Q.matrix[3,3] := Q.matrix[3,3] *val ; + end else begin + Q.matrix[3,1] := Q.matrix[1,2]*Q.matrix[2,3] - Q.matrix[1,3]*Q.matrix[2,2] ; //* cross */ + Q.matrix[3,2] := Q.matrix[1,3]*Q.matrix[2,1] - Q.matrix[1,1]*Q.matrix[2,3] ; //* product */ + Q.matrix[3,3] := Q.matrix[1,1]*Q.matrix[2,2] - Q.matrix[1,2]*Q.matrix[2,1] ; + end; + //next - find closest orthogonal coordinates - each matrix cell must be 0,-1 or 1 + //First: find axis most aligned to a principal axis + lAbsmax := 0; + lMaxRow := 1; + lMaxCol := 1; + for lrow := 1 to 3 do begin + for lcol := 1 to 3 do begin + lAbs := abs(Q.matrix[lrow,lcol]); + if lAbs > lAbsMax then begin + lAbsmax := lAbs; + lMaxRow := lRow; + lMaxCol := lCol; + end; + end; //for rows + end; //for columns + //Second - find find axis that is 2nd closest to principal axis + lAbsmax := 0; + l2ndMaxRow := 2; + l2ndMaxCol := 2; + for lrow := 1 to 3 do begin + for lcol := 1 to 3 do begin + if (lrow <> lMaxRow) and (lCol <> lMaxCol) then begin + lAbs := abs(Q.matrix[lrow,lcol]); + if lAbs > lAbsMax then begin + lAbsmax := lAbs; + l2ndMaxRow := lRow; + l2ndMaxCol := lCol; + end; //new max + end; //do not check MaxRow/MaxCol + end; //for rows + end; //for columns + //next - no degrees of freedom left: third prinicple axis is the remaining axis + if ((lMaxRow = 1) or (l2ndMaxRow = 1)) and ((lMaxRow = 2) or (l2ndMaxRow = 2)) then + l3rdMaxRow := 3 + else if ((lMaxRow = 1) or (l2ndMaxRow = 1)) and ((lMaxRow = 3) or (l2ndMaxRow = 3)) then + l3rdMaxRow := 2 + else + l3rdMaxRow := 1; + if ((lMaxCol = 1) or (l2ndMaxCol = 1)) and ((lMaxCol = 2) or (l2ndMaxCol = 2)) then + l3rdMaxCol := 3 + else if ((lMaxCol = 1) or (l2ndMaxCol = 1)) and ((lMaxCol = 3) or (l2ndMaxCol = 3)) then + l3rdMaxCol := 2 + else + l3rdMaxCol := 1; + //finally, fill in our rotation matrix + //cells in the canonical rotation transform can only have values 0,1,-1 + result := Matrix3D( 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0); + if Q.matrix[lMaxRow,lMaxCol] < 0 then + result.matrix[lMaxRow,lMaxCol] := -1 + else + result.matrix[lMaxRow,lMaxCol] := 1; + + if Q.matrix[l2ndMaxRow,l2ndMaxCol] < 0 then + result.matrix[l2ndMaxRow,l2ndMaxCol] := -1 + else + result.matrix[l2ndMaxRow,l2ndMaxCol] := 1; + + if Q.matrix[l3rdMaxRow,l3rdMaxCol] < 0 then + result.matrix[l3rdMaxRow,l3rdMaxCol] := -1 + else + result.matrix[l3rdMaxRow,l3rdMaxCol] := 1; +end; + + +FUNCTION QuickInvertMatrix3D (CONST Input:TMatrix): TMatrix; +//http://www.cellperformance.com/articles/2006/06/a_4x4_matrix_inverse_1.html +//Most of the time in the video games, programmers are not doing a standard inverse matrix. +//It is too expensive. Instead, to inverse a matrix, they consider it as orthonormal +//and they just do a 3x3 transpose of the rotation part with a dot product for the translation. +//Sometimes the full inverse algorithm is necessary.... +var + i,j: integer; +begin + result.size := Input.size; + for i := 1 to 3 do + for j := 1 to 3 do + result.matrix[i,j] := input.matrix[j,i]; + //next - fill in edge if 3D + if result.size <> size3D then + exit; //do not fill in final column for 2D matrices + for i := 1 to 3 do + result.matrix[4,i] := 0; + for i := 1 to 3 do + result.matrix[i,4] := 0; + result.matrix[4,4] := 1; +end; + +procedure NearestOrtho(var lHdr: TMRIcroHdr); +var + lIn,lM: TMatrix; + qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single; +begin + if (lHdr.NIFTIhdr.pixdim[1] = 0) or (lHdr.NIFTIhdr.pixdim[2]=0) or (lHdr.NIFTIhdr.pixdim[3]=0) then + exit; + lIn := Matrix3D ( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], + 0,0,0,1); + if EyeMatrix (lIn) then + exit; + lM := nifti_mat44_orthogx( lIn); + lM.matrix[1,4] := lHdr.Mat.matrix[1,4]; + lM.matrix[2,4] := lHdr.Mat.matrix[2,4]; + lM.matrix[3,4] := lHdr.Mat.matrix[3,4]; + lHdr.Mat:= lM; + //reportmatrix('rx',lIn); + lM := QuickInvertMatrix3D(lM); + //reportmatrix('invx',lM); + lM := multiplymatrices(lIn,lM); +end; *) + +procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd , a,b,c,d : double; + P,Q: TMatrix; //3x3 +begin + (* offset outputs are read write out of input matrix *) + qx := lR.matrix[1,4]; + qy := lR.matrix[2,4]; + qz := lR.matrix[3,4]; + + (* load 3x3 matrix into local variables *) + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + (* compute lengths of each column; these determine grid spacings *) + + xd := sqrt( r11*r11 + r21*r21 + r31*r31 ) ; + yd := sqrt( r12*r12 + r22*r22 + r32*r32 ) ; + zd := sqrt( r13*r13 + r23*r23 + r33*r33 ) ; + + (* if a column length is zero, patch the trouble *) + + if( xd = 0.0 )then begin r11 := 1.0 ; r21 := 0; r31 := 0.0 ; xd := 1.0 ; end; + if( yd = 0.0 )then begin r22 := 1.0 ; r12 := 0; r32 := 0.0 ; yd := 1.0 ; end; + if( zd = 0.0 )then begin r33 := 1.0 ; r13 := 0; r23 := 0.0 ; zd := 1.0 ; end; + + (* assign the output lengths *) + dx := xd; + dy := yd; + dz := zd; + + (* normalize the columns *) + + r11 := r11/xd ; r21 := r21/xd ; r31 := r31/xd ; + r12 := r12/yd ; r22 := r22/yd ; r32 := r32/yd ; + r13 := r13/zd ; r23 := r23/zd ; r33 := r33/zd ; + + (* At this point, the matrix has normal columns, but we have to allow + for the fact that the hideous user may not have given us a matrix + with orthogonal columns. + + So, now find the orthogonal matrix closest to the current matrix. + + One reason for using the polar decomposition to get this + orthogonal matrix, rather than just directly orthogonalizing + the columns, is so that inputting the inverse matrix to R + will result in the inverse orthogonal matrix at this point. + If we just orthogonalized the columns, this wouldn't necessarily hold. *) + Q := Matrix2D (r11,r12,r13, // 2D "graphics" matrix + r21,r22,r23, + r31,r32,r33); + + + + P := nifti_mat33_polar(Q) ; (* P is orthog matrix closest to Q *) + FromMatrix(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + //ReportMatrix('xxx',Q); + //ReportMatrix('svd',P); + (* [ r11 r12 r13 ] *) + (* at this point, the matrix [ r21 r22 r23 ] is orthogonal *) + (* [ r31 r32 r33 ] *) + + (* compute the determinant to determine if it is proper *) + + zd := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; (* should be -1 or 1 *) + + if( zd > 0 )then begin (* proper *) + qfac := 1.0 ; + end else begin (* improper ==> flip 3rd column *) + qfac := -1.0 ; + r13 := -r13 ; r23 := -r23 ; r33 := -r33 ; + end; + + (* now, compute quaternion parameters *) + + a := r11 + r22 + r33 + 1.0; + + if( a > 0.5 ) then begin (* simplest case *) + a := 0.5 * sqrt(a) ; + b := 0.25 * (r32-r23) / a ; + c := 0.25 * (r13-r31) / a ; + d := 0.25 * (r21-r12) / a ; + end else begin (* trickier case *) + xd := 1.0 + r11 - (r22+r33) ; (* 4*b*b *) + yd := 1.0 + r22 - (r11+r33) ; (* 4*c*c *) + zd := 1.0 + r33 - (r11+r22) ; (* 4*d*d *) + if( xd > 1.0 ) then begin + b := 0.5 * sqrt(xd) ; + c := 0.25* (r12+r21) / b ; + d := 0.25* (r13+r31) / b ; + a := 0.25* (r32-r23) / b ; + end else if( yd > 1.0 ) then begin + c := 0.5 * sqrt(yd) ; + b := 0.25* (r12+r21) / c ; + d := 0.25* (r23+r32) / c ; + a := 0.25* (r13-r31) / c ; + end else begin + d := 0.5 * sqrt(zd) ; + b := 0.25* (r13+r31) / d ; + c := 0.25* (r23+r32) / d ; + a := 0.25* (r21-r12) / d ; + end; + if( a < 0.0 )then begin b:=-b ; c:=-c ; d:=-d; {a:=-a; this is not used} end; + end; + + qb := b ; + qc := c ; + qd := d ; + //fx(qb,qc,qd); +end; + +{procedure nifti_mat44_to_quatern( lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, xd,yd,zd , a,b,c,d : double; + P,Q: TMatrix; //3x3 +begin + + + (* offset outputs are read write out of input matrix *) + qx := lR.matrix[1,4]; + qy := lR.matrix[2,4]; + qz := lR.matrix[3,4]; + + (* load 3x3 matrix into local variables *) + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + (* compute lengths of each column; these determine grid spacings *) + + xd := sqrt( r11*r11 + r21*r21 + r31*r31 ) ; + yd := sqrt( r12*r12 + r22*r22 + r32*r32 ) ; + zd := sqrt( r13*r13 + r23*r23 + r33*r33 ) ; + + (* if a column length is zero, patch the trouble *) + + if( xd = 0.0 )then begin r11 := 1.0 ; r21 := 0; r31 := 0.0 ; xd := 1.0 ; end; + if( yd = 0.0 )then begin r22 := 1.0 ; r12 := 0; r32 := 0.0 ; yd := 1.0 ; end; + if( zd = 0.0 )then begin r33 := 1.0 ; r13 := 0; r23 := 0.0 ; zd := 1.0 ; end; + + (* assign the output lengths *) + dx := xd; + dy := yd; + dz := zd; + + (* normalize the columns *) + + r11 := r11/xd ; r21 := r21/xd ; r31 := r31/xd ; + r12 := r12/yd ; r22 := r22/yd ; r32 := r32/yd ; + r13 := r13/zd ; r23 := r23/zd ; r33 := r33/zd ; + + (* At this point, the matrix has normal columns, but we have to allow + for the fact that the hideous user may not have given us a matrix + with orthogonal columns. + + So, now find the orthogonal matrix closest to the current matrix. + + One reason for using the polar decomposition to get this + orthogonal matrix, rather than just directly orthogonalizing + the columns, is so that inputting the inverse matrix to R + will result in the inverse orthogonal matrix at this point. + If we just orthogonalized the columns, this wouldn't necessarily hold. *) + Q := Matrix2D (r11,r12,r13, // 2D "graphics" matrix + r21,r22,r23, + r31,r32,r33); + + + + P := nifti_mat33_polar(Q) ; (* P is orthog matrix closest to Q *) + FromMatrix(P,r11,r12,r13,r21,r22,r23,r31,r32,r33); + + //ReportMatrix('xxx',Q); + //ReportMatrix('svd',P); + (* [ r11 r12 r13 ] *) + (* at this point, the matrix [ r21 r22 r23 ] is orthogonal *) + (* [ r31 r32 r33 ] *) + + (* compute the determinant to determine if it is proper *) + + zd := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; (* should be -1 or 1 *) + + if( zd > 0 )then begin (* proper *) + qfac := 1.0 ; + end else begin (* improper ==> flip 3rd column *) + qfac := -1.0 ; + r13 := -r13 ; r23 := -r23 ; r33 := -r33 ; + end; + + (* now, compute quaternion parameters *) + + a := r11 + r22 + r33 + 1.0; + + if( a > 0.5 ) then begin (* simplest case *) + a := 0.5 * sqrt(a) ; + b := 0.25 * (r32-r23) / a ; + c := 0.25 * (r13-r31) / a ; + d := 0.25 * (r21-r12) / a ; + end else begin (* trickier case *) + xd := 1.0 + r11 - (r22+r33) ; (* 4*b*b *) + yd := 1.0 + r22 - (r11+r33) ; (* 4*c*c *) + zd := 1.0 + r33 - (r11+r22) ; (* 4*d*d *) + if( xd > 1.0 ) then begin + b := 0.5 * sqrt(xd) ; + c := 0.25* (r12+r21) / b ; + d := 0.25* (r13+r31) / b ; + a := 0.25* (r32-r23) / b ; + end else if( yd > 1.0 ) then begin + c := 0.5 * sqrt(yd) ; + b := 0.25* (r12+r21) / c ; + d := 0.25* (r23+r32) / c ; + a := 0.25* (r13-r31) / c ; + end else begin + d := 0.5 * sqrt(zd) ; + b := 0.25* (r13+r31) / d ; + c := 0.25* (r23+r32) / d ; + a := 0.25* (r21-r12) / d ; + end; + if( a < 0.0 )then begin b:=-b ; c:=-c ; d:=-d; end; + end; + + qb := b ; + qc := c ; + qd := d ; + //fx(qb,qc,qd); +end; } + +procedure nifti_quatern_to_mat44( var lR :TMatrix; + var qb, qc, qd, + qx, qy, qz, + dx, dy, dz, qfac : single); +var + a,b,c,d,xd,yd,zd: double; +begin + //a := qb; + b := qb; + c := qc; + d := qd; + //* last row is always [ 0 0 0 1 ] */ + lR.matrix[4,1] := 0; + lR.matrix[4,2] := 0; + lR.matrix[4,3] := 0; + lR.matrix[4,4] := 1; + //* compute a parameter from b,c,d */ + a := 1.0 - (b*b + c*c + d*d) ; + if( a < 1.e-7 ) then begin//* special case */ + a := 1.0 / sqrt(b*b+c*c+d*d) ; + b := b*a ; c := c*a ; d := d*a ;//* normalize (b,c,d) vector */ + a := 0.0 ;//* a = 0 ==> 180 degree rotation */ + end else begin + a := sqrt(a) ; //* angle = 2*arccos(a) */ + end; + //* load rotation matrix, including scaling factors for voxel sizes */ + if dx > 0 then + xd := dx + else + xd := 1; + if dy > 0 then + yd := dy + else + yd := 1; + if dz > 0 then + zd := dz + else + zd := 1; + if( qfac < 0.0 ) then zd := -zd ;//* left handedness? */ + lR.matrix[1,1]:= (a*a+b*b-c*c-d*d) * xd ; + lR.matrix[1,2]:= 2.0 * (b*c-a*d ) * yd ; + lR.matrix[1,3]:= 2.0 * (b*d+a*c ) * zd ; + lR.matrix[2,1]:= 2.0 * (b*c+a*d ) * xd ; + lR.matrix[2,2]:= (a*a+c*c-b*b-d*d) * yd ; + lR.matrix[2,3]:= 2.0 * (c*d-a*b ) * zd ; + lR.matrix[3,1]:= 2.0 * (b*d-a*c ) * xd ; + lR.matrix[3,2]:= 2.0 * (c*d+a*b ) * yd ; + lR.matrix[3,3]:= (a*a+d*d-c*c-b*b) * zd ; + //* load offsets */ + lR.matrix[1,4]:= qx ; + lR.matrix[2,4]:= qy ; + lR.matrix[3,4]:= qz ; + +end; + +function TryQuat2Matrix( var lHdr: TNIfTIHdr ): boolean; +var lR :TMatrix; +begin + + result := false; + if (lHdr.qform_code <= kNIFTI_XFORM_UNKNOWN) or (lHdr.qform_code > kNIFTI_XFORM_MNI_152) then + exit; + result := true; + nifti_quatern_to_mat44(lR,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lHdr.pixdim[1],lHdr.pixdim[2],lHdr.pixdim[3], + lHdr.pixdim[0]); + lHdr.srow_x[0] := lR.matrix[1,1]; + lHdr.srow_x[1] := lR.matrix[1,2]; + lHdr.srow_x[2] := lR.matrix[1,3]; + lHdr.srow_x[3] := lR.matrix[1,4]; + lHdr.srow_y[0] := lR.matrix[2,1]; + lHdr.srow_y[1] := lR.matrix[2,2]; + lHdr.srow_y[2] := lR.matrix[2,3]; + lHdr.srow_y[3] := lR.matrix[2,4]; + lHdr.srow_z[0] := lR.matrix[3,1]; + lHdr.srow_z[1] := lR.matrix[3,2]; + lHdr.srow_z[2] := lR.matrix[3,3]; + lHdr.srow_z[3] := lR.matrix[3,4]; + lHdr.sform_code := 1; +end; + +{procedure ReportMatrix (lM:TMatrix); +var lStr: string; +begin + + lStr := ( RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)) + +kCR+( RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)) + +kCR+( RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)) + +kCR+( RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6)); +showmessage(lStr); +end; } + +function FixDataType (var lHdr: TMRIcroHdr {; lCompress: boolean}): boolean; +//correct mistakes of datatype and bitpix - especially for software which only sets one +label + 191; +var + ldatatypebpp,lbitpix: integer; +begin + result := true; + lbitpix := lHdr.NIFTIhdr.bitpix; + case lHdr.NIFTIhdr.datatype of + kDT_BINARY : ldatatypebpp := 1; + kDT_UNSIGNED_CHAR : ldatatypebpp := 8; // unsigned char (8 bits/voxel) + kDT_SIGNED_SHORT : ldatatypebpp := 8; // signed short (16 bits/voxel) + kDT_SIGNED_INT : ldatatypebpp := 32; // signed int (32 bits/voxel) + kDT_FLOAT : ldatatypebpp := 32; // float (32 bits/voxel) + kDT_COMPLEX : ldatatypebpp := 64; // complex (64 bits/voxel) + kDT_DOUBLE : ldatatypebpp := 64; // double (64 bits/voxel) + kDT_RGB : ldatatypebpp := 24; // RGB triple (24 bits/voxel) + kDT_INT8 : ldatatypebpp := 8; // signed char (8 bits) + kDT_UINT16 : ldatatypebpp := 16; // unsigned short (16 bits) + kDT_UINT32 : ldatatypebpp := 32; // unsigned int (32 bits) + kDT_INT64 : ldatatypebpp := 64; // long long (64 bits) + kDT_UINT64 : ldatatypebpp := 64; // unsigned long long (64 bits) + kDT_FLOAT128 : ldatatypebpp := 128; // long double (128 bits) + kDT_COMPLEX128 : ldatatypebpp := 128; // double pair (128 bits) + kDT_COMPLEX256 : ldatatypebpp := 256; // long double pair (256 bits) + else + ldatatypebpp := 0; + end; + if (ldatatypebpp = lHdr.NIFTIhdr.bitpix) and (ldatatypebpp <> 0) then + exit; + if (lbitpix = 0) and (ldatatypebpp <> 0) then begin + //use bitpix from datatype... + lHdr.NIFTIhdr.bitpix := ldatatypebpp; + exit; + end; + if (lbitpix <> 0) and (ldatatypebpp = 0) then begin + //assume bitpix is correct.... + //note that several datatypes correspond to each bitpix, so assume most popular... + case lbitpix of + 1: lHdr.NIFTIhdr.datatype := kDT_BINARY; + 8: lHdr.NIFTIhdr.datatype := kDT_UNSIGNED_CHAR; + 16: lHdr.NIFTIhdr.datatype := kDT_SIGNED_SHORT; + 24: lHdr.NIFTIhdr.datatype := kDT_RGB; + 32: lHdr.NIFTIhdr.datatype := kDT_FLOAT; + 64: lHdr.NIFTIhdr.datatype := kDT_DOUBLE; + else goto 191; //impossible bitpix + end; + exit; + end; +191: + //ComputeImageDataBytes(lHdr); + lHdr.NIFTIhdr.bitpix := 16; + lHdr.NIFTIhdr.datatype := kDT_SIGNED_SHORT; + //fx(lHdr.NIFTIhdr.bitpix, lHdr.NIFTIhdr.datatype); +end; + +function NIFTIhdr_LoadHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +var + lHdrFile: file; + lOri: array [1..3] of single; + lBuff: Bytep; + lAHdr: TAnalyzeHdrSection; + swapEndian: boolean; + lTemp,lReportedSz, lSwappedReportedSz,lHdrSz,lFileSz: Longint; + lExt: string; //1494 +begin + Result := false; //assume error + if lFilename = '' then exit; + lExt := UpCaseExt(lFilename); + if lExt = '.IMG' then + lFilename := changeFileExt(lFilename,'.hdr'); + if (lExt = '.BRIK') or (lExt = '.BRIK.GZ') then + lFilename := changeFileExtX(lFilename,'.HEAD'); + + lExt := UpCaseExt(lFilename); + lHdrSz := sizeof(TniftiHdr); + lFileSz := FSize (lFilename); + if lFileSz = 0 then begin + ShowMessage('Unable to find NIFTI header named '+lFilename); + exit; + end; + swapEndian := false; + lHdr.gzBytesX := K_gzBytes_headerAndImageUncompressed; + lHdr.HdrFileName:= lFilename; + lHdr.ImgFileName:= lFilename; + FileMode := 0; { Set file access to read only } + if (lExt = '.MGH') or (lExt = '.MGZ') or (lExt = '.MHD') or (lExt = '.MHA') or (lExt = '.NRRD') or (lExt = '.NHDR') or (lExt = '.HEAD') then begin + result := readForeignHeader( lFilename, lHdr.NIFTIhdr,lHdr.gzBytesX, swapEndian); //we currently ignore result! + lHdr.ImgFileName := lFilename; + end else begin //native NIfTI + if (lExt = '.NII.GZ') or (lExt = '.VOI') then begin//1388 + lBuff := @lHdr; + UnGZip(lFileName,lBuff,0,lHdrSz); //1388 + lHdr.gzBytesX := K_gzBytes_headerAndImageCompressed; + end else begin //if gzip else uncompressed + if (lFileSz < lHdrSz) then begin + ShowMessage('Error in reading NIFTI header: NIfTI headers need to be at least '+inttostr(lHdrSz)+ ' bytes: '+lFilename); + result := false; + end else begin + {$I-} + AssignFile(lHdrFile, lFileName); + FileMode := 0; { Set file access to read only } + Reset(lHdrFile, 1); + {$I+} + if ioresult <> 0 then begin + ShowMessage('Error in reading NIFTI header.'+inttostr(IOResult)); + CloseFile(lHdrFile); + FileMode := 2; + exit; + end; + BlockRead(lHdrFile, lHdr, lHdrSz); + CloseFile(lHdrFile); + end; + end; + if ((lHdr.niftiHdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR) and (lFileSz > lHdrSz)) or (lExt = '.NII.GZ') or (lExt = '.VOI') or (lExt = '.NII'){1494} then + lHdr.ImgFileName:= lFilename + else + lHdr.ImgFileName:= changefileext(lFilename,'.img'); + end; //native NIFTI + FileMode := 2; + if (IOResult <> 0) then exit; + lReportedSz := lHdr.niftiHdr.HdrSz; + lSwappedReportedSz := lReportedSz; + swap4(lSwappedReportedSz); + if lReportedSz = lHdrSz then begin + lHdr.DiskDataNativeEndian := true; + end else if lSwappedReportedSz = lHdrSz then begin + lHdr.DiskDataNativeEndian := false; + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + end else begin + result := NIFTIhdr_LoadDCM (lFilename,lHdr); //2/2008 + if not result then + ShowMessage('Warning: the header file is not in NIfTi format [the first 4 bytes do not have the value 348].'); + exit; + end; + + if (lHdr.NIFTIhdr.dim[0] > 7) or (lHdr.NIFTIhdr.dim[0] < 1) then begin //only 1..7 dims, so this + Showmessage('Illegal NIfTI Format Header: this header does not specify 1..7 dimensions.'); + exit; + end; + FixDataType (lHdr{,lCompress}); + result := true; + if IsNifTiMagic(lHdr.niftiHdr) then begin //must match MAGMA in nifti_img + lOri[1] := (lHdr.NIFTIhdr.dim[1]+1) div 2; + lOri[2] := (lHdr.NIFTIhdr.dim[2]+1) div 2; + lOri[3] := (lHdr.NIFTIhdr.dim[3]+1) div 2; + //TryQuat2Matrix(lHdr.NiftiHdr); + if (lHdr.NIFTIhdr.sform_code <= kNIFTI_XFORM_UNKNOWN) or (lHdr.NIFTIhdr.sform_code > kNIFTI_XFORM_MNI_152) then + TryQuat2Matrix(lHdr.NiftiHdr); + if emptymatrix(lHdr) then begin + + (*if HasQuat(lHdr.NiftiHdr) then + //HasQuat will specify + else*) begin + for lTemp := 1 to 3 do //Sept 2008 + if lHdr.NIFTIhdr.pixdim[lTemp] = 0 then begin + lHdr.NIFTIhdr.pixdim[lTemp] := 1; + end; + lHdr.NIFTIhdr.srow_x[0] := lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_x[1] := 0; + lHdr.NIFTIhdr.srow_x[2] := 0; + + lHdr.NIFTIhdr.srow_y[0] := 0; + lHdr.NIFTIhdr.srow_y[1] := lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_y[2] := 0; + lHdr.NIFTIhdr.srow_z[0] := 0; + lHdr.NIFTIhdr.srow_z[1] := 0; + lHdr.NIFTIhdr.srow_z[2] := lHdr.NIFTIhdr.pixdim[3]; + + lHdr.NIFTIhdr.srow_x[3] := -round(lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.pixdim[1]*0.5); + lHdr.NIFTIhdr.srow_y[3] := -round(lHdr.NIFTIhdr.dim[2]*lHdr.NIFTIhdr.pixdim[2]*0.5); + lHdr.NIFTIhdr.srow_z[3] := -round(lHdr.NIFTIhdr.dim[3]*lHdr.NIFTIhdr.pixdim[3]*0.5); + lHdr.NIFTIhdr.sform_code := 1; + end; + end; + + + if (lHdr.NIFTIhdr.srow_x[0] > 0) and (lHdr.NIFTIhdr.srow_y[1] > 0) and (lHdr.NIFTIhdr.srow_z[2] > 0) and + (lHdr.NIFTIhdr.srow_x[3] > 0) and (lHdr.NIFTIhdr.srow_y[3] > 0) and (lHdr.NIFTIhdr.srow_z[3] > 0) then begin + lHdr.NIFTIhdr.srow_x[3] := -lHdr.NIFTIhdr.srow_x[3]; + lHdr.NIFTIhdr.srow_y[3] := -lHdr.NIFTIhdr.srow_y[3]; + lHdr.NIFTIhdr.srow_z[3] := -lHdr.NIFTIhdr.srow_z[3]; + lHdr.NIFTIhdr.sform_code := 1; + end; //added 4Mar2006 -> corrects for improperly signed offset values... + + end else begin //not NIFT: Analyze + lHdr.NIfTItransform := false;//Analyze + if not lHdr.DiskDataNativeEndian then begin + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + move(lHdr.niftiHdr,lAHdr,sizeof(lAHdr)); + NIFTIhdr_SwapBytes (lHdr.niftiHdr); + lAHdr.Originator[1] := swap(lAHdr.Originator[1]); + lAHdr.Originator[2] := swap(lAHdr.Originator[2]); + lAHdr.Originator[3] := swap(lAHdr.Originator[3]); + end else + move(lHdr.niftiHdr,lAHdr,sizeof(lAHdr)); + lOri[1] :=lAHdr.Originator[1]; + lOri[2] := lAHdr.Originator[2]; + lOri[3] := lAHdr.Originator[3]; + if (lOri[1]=76) and (lOri[2]=116) and (lOri[3]=64) + and (lHdr.NIFTIhdr.dim[1]=151) and (lHdr.NIFTIhdr.dim[2]=188) and (lHdr.NIFTIhdr.dim[3]=154) then begin + lOri[2] := 111; + lOri[3] := 68; + end; //2/2008 Juelich fudge factor + + if ((lOri[1]<1) or (lOri[1]> lHdr.NIFTIhdr.dim[1])) and + ((lOri[2]<1) or (lOri[2]> lHdr.NIFTIhdr.dim[2])) and + ((lOri[3]<1) or (lOri[3]> lHdr.NIFTIhdr.dim[3])) then begin + lOri[1] := (lHdr.NIFTIhdr.dim[1]+1) / 2; //May07 use / not div + lOri[2] := (lHdr.NIFTIhdr.dim[2]+1) / 2; //May07 use / not div + lOri[3] := (lHdr.NIFTIhdr.dim[3]+1) / 2; //May07 use / not div : if 20 slices, then origin is between 10 and 11 + + end; + //showmessage(inttostr(sizeof(lAHdr))+' '+realtostr(lHdr.Ori[1],1)+' '+ realtostr(lHdr.Ori[2],1)+' '+realtostr(lHdr.Ori[3],1) ); + //DANGER: This header was from ANALYZE format, not NIFTI: make sure the rotation matrix is switched off + NII_SetIdentityMatrix(lHdr.NIFTIhdr); + lHdr.NIFTIhdr.qform_code := kNIFTI_XFORM_UNKNOWN; + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_UNKNOWN; + for lTemp := 1 to 3 do //Sept 2008 + if lHdr.NIFTIhdr.pixdim[lTemp] = 0 then begin + lHdr.NIFTIhdr.pixdim[lTemp] := 1; + end; + + //test - input estimated orientation matrix + lHdr.NIFTIhdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT ; + lHdr.NIFTIhdr.srow_x[0] := lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[1] := lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[2] := lHdr.NIFTIhdr.pixdim[3]; + + lHdr.NIFTIhdr.srow_x[3] := (lOri[1]-1)*-lHdr.NIFTIhdr.pixdim[1]; + lHdr.NIFTIhdr.srow_y[3] := (lOri[2]-1)*-lHdr.NIFTIhdr.pixdim[2]; + lHdr.NIFTIhdr.srow_z[3] := (lOri[3]-1)*-lHdr.NIFTIhdr.pixdim[3]; + //fx(lHdr.NIFTIhdr.srow_z[3],lOri[3]); + //end test + //Warning: some of the NIFTI float values that do exist as integer values in Analyze may have bizarre values like +INF, -INF, NaN + lHdr.NIFTIhdr.toffset := 0; + lHdr.NIFTIhdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.NIFTIhdr.dim_info := kNIFTI_SLICE_SEQ_UNKNOWN + (kNIFTI_SLICE_SEQ_UNKNOWN shl 2) + (kNIFTI_SLICE_SEQ_UNKNOWN shl 4); //Freq, Phase and Slie all unknown + lHdr.NIFTIhdr.xyzt_units := kNIFTI_UNITS_UNKNOWN; + lHdr.NIFTIhdr.slice_duration := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p1 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p2 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.intent_p3 := 0; //avoid +inf/-inf, NaN + lHdr.NIFTIhdr.pixdim[0] := 1; //QFactor should be 1 or -1 + end; + if (lHdr.NIFTIhdr.sform_code > kNIFTI_XFORM_UNKNOWN) and (lHdr.NIFTIhdr.sform_code <= kNIFTI_XFORM_MNI_152) then begin //DEC06 + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + end else begin + lHdr.Mat:= Matrix3D( + lHdr.NIFTIhdr.pixdim[1],0,0,(lOri[1]-1)*-lHdr.NIFTIhdr.pixdim[1], // 3D "graphics" matrix + 0,lHdr.NIFTIhdr.pixdim[2],0,(lOri[2]-1)*-lHdr.NIFTIhdr.pixdim[2], // 3D "graphics" matrix + 0,0,lHdr.NIFTIhdr.pixdim[3],(lOri[3]-1)*-lHdr.NIFTIhdr.pixdim[3], // 3D "graphics" matrix + 0,0,0,1); + end; + + FixCrapMat(lHdr.Mat); + if swapEndian then + lHdr.DiskDataNativeEndian := false;//foreign data with swapped image data + //ReportMatrix(lHdr.mat); +end; //func NIFTIhdr_LoadHdr + +procedure NIFTIhdr_ClearHdr (var lHdr: TMRIcroHdr); //put sensible default values into header +begin + lHdr.UsesCustomPalette := false; + lHdr.DiskDataNativeEndian := true; + lHdr.gzBytesX := K_gzBytes_headerAndImageUncompressed; + lHdr.UsesCustomPaletteRandomRainbow := false; + + //lHdr.LUTinvert := false; + lHdr.LutFromZero := false; + lHdr.NIfTItransform := true;//assume genuine NIfTI, not Analyze + NII_Clear( lHdr.NIFTIhdr); + with lHdr do begin + usesLabels := false; + ScrnBufferItems := 0; + ImgBufferItems := 0; + ImgBufferBPP := 0; + RenderBufferItems := 0; + ScrnBuffer:= nil; + ImgBuffer := nil; + end; +end; //proc NIFTIhdr_ClearHdr + +function NIFTIhdr_SaveHdr (var lFilename: string; var lHdr: TMRIcroHdr; lAllowOverwrite: boolean): boolean; +var lOutHdr: TNIFTIhdr; + lExt: string; + lF: File; + lOverwrite: boolean; +begin + lOverwrite := false; //will we overwrite existing file? + result := false; //assume failure + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then begin + lExt := UpCaseExt(lFileName); + if (lExt = '.GZ') or (lExt = '.NII.GZ') then begin + showmessage('Unable to save .nii.gz headers (first ungzip your image if you wish to edit the header)'); + exit; + end; + lFilename := changefileext(lFilename,'.nii') + end else + lFilename := changefileext(lFilename,'.hdr'); + if ((sizeof(TNIFTIhdr))> DiskFreeEx(lFileName)) then begin + ShowMessage('There is not enough free space on the destination disk to save the header. '+kCR+ + lFileName+ kCR+' Bytes Required: '+inttostr(sizeof(TNIFTIhdr)) ); + exit; + end; + if Fileexists(lFileName) then begin + if lAllowOverwrite then begin + case MessageDlg('Do you wish to modify the existing file '+lFilename+'?', mtConfirmation,[mbYes, mbNo], 0) of { produce the message dialog box } + 6: lOverwrite := true; //6= mrYes, 7=mrNo... not sure what this is for Linux. Hardcoded as we do not include Form values + end;//case + end else + showmessage('Error: the file '+lFileName+' already exists.'); + if not lOverwrite then Exit; + end; + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_EMBEDDED_HDR then + if lHdr.NIFTIhdr.vox_offset < sizeof(TNIFTIHdr) then + lHdr.NIFTIhdr.vox_offset := sizeof(TNIFTIHdr); //embedded images MUST start after header + if lHdr.NIFTIhdr.magic = kNIFTI_MAGIC_SEPARATE_HDR then + lHdr.NIFTIhdr.vox_offset := 0; //embedded images MUST start after header + result := true; + move(lHdr.NIFTIhdr, lOutHdr, sizeof(lOutHdr)); + if lHdr.DiskDataNativeEndian = false then + NIFTIhdr_SwapBytes (lOutHdr);{swap to big-endianformat} + Filemode := 1; + AssignFile(lF, lFileName); {WIN} + if lOverwrite then //this allows us to modify just the 348byte header of an existing NII header without touching image data + Reset(lF,sizeof(TNIFTIhdr)) + else + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lOutHdr, 1 {, NumWritten}); + CloseFile(lF); + Filemode := 2; +end; //func NIFTIhdr_SaveHdr + +procedure NIFTIhdr_SwapBytes (var lAHdr: TNIFTIhdr); //Swap Byte order for the Analyze type +var + lInc: integer; +begin + with lAHdr do begin + swap4(hdrsz); + swap4(extents); + session_error := swap(session_error); + for lInc := 0 to 7 do + dim[lInc] := swap(dim[lInc]); + Xswap4r(intent_p1); + Xswap4r(intent_p2); + Xswap4r(intent_p3); + intent_code:= swap(intent_code); + datatype:= swap(datatype); + bitpix := swap(bitpix); + slice_start:= swap(slice_start); + for lInc := 0 to 7 do + Xswap4r(pixdim[linc]); + Xswap4r(vox_offset); +{roi scale = 1} + Xswap4r(scl_slope); + Xswap4r(scl_inter); + slice_end := swap(slice_end); + Xswap4r(cal_max); + Xswap4r(cal_min); + Xswap4r(slice_duration); + Xswap4r(toffset); + swap4(glmax); + swap4(glmin); + qform_code := swap(qform_code); + sform_code:= swap(sform_code); + Xswap4r(quatern_b); + Xswap4r(quatern_c); + Xswap4r(quatern_d); + Xswap4r(qoffset_x); + Xswap4r(qoffset_y); + Xswap4r(qoffset_z); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_x[lInc]); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_y[lInc]); + for lInc := 0 to 3 do //alpha + Xswap4r(srow_z[lInc]); + end; //with NIFTIhdr +end; //proc NIFTIhdr_SwapBytes + +end. + \ No newline at end of file diff --git a/niftiview7/nifti_hdr_view.pas b/niftiview7/nifti_hdr_view.pas new file mode 100755 index 0000000..f67b398 --- /dev/null +++ b/niftiview7/nifti_hdr_view.pas @@ -0,0 +1,679 @@ +unit nifti_hdr_view; +interface +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Buttons, nifti_hdr, Menus, ComCtrls,ShellAPI, + define_types,GraphicsMathLibrary, Mask, clipbrd, nifti_types; + +type + THdrForm = class(TForm) + MainMenu1: TMainMenu; + Help1: TMenuItem; + OpenHdrDlg: TOpenDialog; + SaveHdrDlg: TSaveDialog; + PageControl1: TPageControl; + TabRequired: TTabSheet; + TabUnused: TTabSheet; + intent_nameEdit: TEdit; + data_typeEdit: TEdit; + CommentEdit: TEdit; + db_: TEdit; + aux: TEdit; + gmax: TRxSpinEdit; + gmin: TRxSpinEdit; + ses: TRxSpinEdit; + ext: TRxSpinEdit; + reg: TRxSpinEdit; + Label34: TLabel; + Label5: TLabel; + Label6: TLabel; + Label9: TLabel; + Label10: TLabel; + Label14: TLabel; + Label15: TLabel; + Label18: TLabel; + Label19: TLabel; + Label26: TLabel; + Label21: TLabel; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + Label8: TLabel; + Label7: TLabel; + Label44: TLabel; + Xdim: TRxSpinEdit; + Ydim: TRxSpinEdit; + Ymm: TRxSpinEdit; + Zdim: TRxSpinEdit; + Zmm: TRxSpinEdit; + OffsetEdit: TRxSpinEdit; + TDim: TRxSpinEdit; + Xmm: TRxSpinEdit; + TSec: TRxSpinEdit; + StatusBar1: TStatusBar; + Label29: TLabel; + Dim5Edit: TRxSpinEdit; + TabSheet1: TTabSheet; + Label35: TLabel; + intent_p1Edit: TRxSpinEdit; + intent_p2Edit: TRxSpinEdit; + intent_p3Edit: TRxSpinEdit; + Label25: TLabel; + Label27: TLabel; + Label28: TLabel; + TabSheet2: TTabSheet; + Label11: TLabel; + Label16: TLabel; + Label17: TLabel; + Label32: TLabel; + slice_startEdit: TRxSpinEdit; + Slice_durationEdit: TRxSpinEdit; + toffsetEdit: TRxSpinEdit; + TabSheet3: TTabSheet; + cmax: TRxSpinEdit; + cmin: TRxSpinEdit; + Label12: TLabel; + Label13: TLabel; + Scale: TRxSpinEdit; + Label23: TLabel; + Intercept: TRxSpinEdit; + Label22: TLabel; + Label30: TLabel; + Label33: TLabel; + Page1: TMenuItem; + Dimensions1: TMenuItem; + ImageIntensity1: TMenuItem; + Statistics1: TMenuItem; + FunctionalMRI1: TMenuItem; + Optional1: TMenuItem; + TabSheet4: TTabSheet; + Rotations1: TMenuItem; + srow_x0Edit: TRxSpinEdit; + srow_x1Edit: TRxSpinEdit; + srow_x2Edit: TRxSpinEdit; + Label24: TLabel; + Label36: TLabel; + Label37: TLabel; + srow_y0Edit: TRxSpinEdit; + srow_y1Edit: TRxSpinEdit; + srow_y2Edit: TRxSpinEdit; + srow_z0Edit: TRxSpinEdit; + srow_z1Edit: TRxSpinEdit; + srow_z2Edit: TRxSpinEdit; + srow_x3Edit: TRxSpinEdit; + srow_y3Edit: TRxSpinEdit; + srow_z3Edit: TRxSpinEdit; + quatern_bEdit: TRxSpinEdit; + quatern_cEdit: TRxSpinEdit; + quatern_dEdit: TRxSpinEdit; + qoffset_xEdit: TRxSpinEdit; + qoffset_yEdit: TRxSpinEdit; + qoffset_zEdit: TRxSpinEdit; + Label39: TLabel; + Label40: TLabel; + Label41: TLabel; + Dim6Edit: TRxSpinEdit; + Label42: TLabel; + Dim7Edit: TRxSpinEdit; + PixDim5: TRxSpinEdit; + PixDim6: TRxSpinEdit; + PixDim7: TRxSpinEdit; + Label20: TLabel; + slice_endEdit: TRxSpinEdit; + Label31: TLabel; + Label43: TLabel; + Label45: TLabel; + QFacEdit: TRxSpinEdit; + Label46: TLabel; + Label38: TLabel; + Label47: TLabel; + Saveheader1: TMenuItem; + HeaderMagicDrop: TComboBox; + xyzt_sizeDrop: TComboBox; + xyzt_timeDrop: TComboBox; + fTypeDrop: TComboBox; + Endian: TComboBox; + QFormDrop: TComboBox; + SFormDrop: TComboBox; + IntentCodeDrop: TComboBox; + SliceCodeDrop: TComboBox; + FreqDimDrop: TComboBox; + PhaseDimDrop: TComboBox; + SliceDimDrop: TComboBox; + Closewindow1: TMenuItem; + SpeedButton1: TSpeedButton; + Edit1: TMenuItem; + CopyMAT1: TMenuItem; + procedure WriteHdrForm (var lHdr: TMRIcroHdr); + procedure ReadHdrDimensionsOnly (var lHdr: TMRIcroHdr); //reads only size dimensions: useful for computing estimated filesize + procedure ReadHdrForm (var lHdr: TMRIcroHdr); + procedure Open1Click(Sender: TObject); + procedure TabMenuClick(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure ImageSzChange(Sender: TObject); + procedure HeaderMagicDropSelect(Sender: TObject); + function OpenAndDisplayHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; + procedure Saveheader1Click(Sender: TObject); + procedure Closewindow1Click(Sender: TObject); + procedure SpeedButton1Click(Sender: TObject); + procedure CopyMAT1Click(Sender: TObject); + //procedure ReadXForm (var lHdr: TMRIcroHdr); + private + { Private declarations } + procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES; + public + { Public declarations } + end; + function OpenDialogExecute (lFilter,lCaption: string; lAllowMultiSelect: boolean): boolean; + +var + HdrForm: THdrForm; + +implementation + +uses nifti_img_view, render,nifti_img, ActiveX{, XMLintf, XMLDoc}; + +{$R *.DFM} + +function OpenDialogExecute (lFilter,lCaption: string; lAllowMultiSelect: boolean): boolean; +begin + HdrForm.OpenHdrDlg.Filter := lFilter; + HdrForm.OpenHdrDlg.FilterIndex := 1; + HdrForm.OpenHdrDlg.Title := lCaption; + if lAllowMultiSelect then + HdrForm.OpenHdrDlg.Options := [ofAllowMultiSelect,ofFileMustExist]; + CoInitialize(nil); + result := HdrForm.OpenHdrDlg.Execute; + CoUninitialize; + HdrForm.OpenHdrDlg.Options := [ofFileMustExist]; +end; + +function DropItem2DataType(lItemIndex: integer): integer; //returns NIfTI datatype number +begin + case lItemIndex of + 0: result :=1; //binary + 1 : result := 256; //8-bit S + 2 : result := 2; //8-bit int U* + 3 : result := 4; //16-bit int S* + 4 : result := 512; //16-bit int U + 5 : result := 8; //32-bit int S* + 6 : result := 768; //32-bit int U + 7: result := 1024; //64-bit int S + 8: result := 1280; //64-bit int U + 9: result := 16; //32-bit real* + 10: result := 64; //64-bit real* + 11: result := 1536; //128-bit real + 12: result := 128; //24-bit rgb + 13: result := 32; //64-bit complex + 14: result := 1792; //128-bit complex + 15: result := 2048; //256-bit complex + else + result := 0; + end; //case +end; //func DropItem2DataType + +function DataType2DropItem (lDataType: smallint): integer; +begin + case lDataType of + 1: result := 0; //binary + 256: result := 1; //8-bit S + 2: result := 2; //8-bit int U* + 4: result := 3; //16-bit int S* + 512: result := 4; //16-bit int U + 8: result := 5; //32-bit int S* + 768: result := 6; //32-bit int U + 1024: result := 7; //64-bit int S + 1280: result := 8; //64-bit int U + 16: result := 9; //32-bit real* + 64: result := 10; //64-bit real* + 1536: result := 11; //128-bit real + 128: result := 12; //24-bit rgb + 32: result := 13; //64-bit complex + 1792: result := 14; //128-bit complex + 2048: result := 15; //256-bit complex + else + result := 0; + end; //case +end; //func DataType2DropItem + +function DataType2BitsPerVoxel (lDataType: smallint): integer; +begin + case lDataType of + 1: result := 1; //binary + 256: result := 8; //8-bit S + 2: result := 8; //8-bit int U* + 4: result := 16; //16-bit int S* + 512: result := 16; //16-bit int U + 8: result := 32; //32-bit int S* + 768: result := 32; //32-bit int U + 1024: result := 64; //64-bit int S + 1280: result := 64; //64-bit int U + 16: result := 32; //32-bit real* + 64: result := 64; //64-bit real* + 1536: result := 128; //128-bit real + 128: result := 24; //24-bit rgb + 32: result := 64; //64-bit complex + 1792: result := 128; //128-bit complex + 2048: result := 256; //256-bit complex + else + result := 0; + end; //case +end; //func DataType2BitsPerVoxel + +function time_units2DropItem (lxyzt_units: byte): integer; +var lxyzt_unitsClipped: byte; +begin + lxyzt_unitsClipped := lxyzt_units and 56; + case lxyzt_unitsClipped of + kNIFTI_UNITS_SEC : result := 1;//= 8; + kNIFTI_UNITS_MSEC : result := 2;//= 16; + kNIFTI_UNITS_USEC : result := 3;//= 24; + kNIFTI_UNITS_HZ : result := 4;//= 32; + kNIFTI_UNITS_PPM : result := 5;//= 40; + else result := 0; //unknown + end; //case +end; //func time_units2DropItem + +function DropItem2time_units (lDropItemIndex: byte): integer; //convert ComboBox index to NIFTI time units +begin + case lDropItemIndex of + 1: result := kNIFTI_UNITS_SEC; + 2: result := kNIFTI_UNITS_MSEC; + 3: result := kNIFTI_UNITS_USEC; + 4: result := kNIFTI_UNITS_HZ; + 5: result := kNIFTI_UNITS_PPM; + else result := 0; //unknown + end; //case +end; //func DropItem2time_units + +procedure THdrForm.WriteHdrForm (var lHdr: TMRIcroHdr); //writes a header to the various controls +var //lCStr: string[80]; + lInc: Integer; +begin + with lHdr.NIFTIhdr do begin + //numDimEdit.value := dim[0]; + XDim.Value := dim[1]; + YDim.Value := dim[2]; + ZDim.Value := dim[3]; + TDim.Value := dim[4]; + Dim5Edit.value := dim[5]; + Dim6Edit.value := dim[6]; + Dim7Edit.value := dim[7]; + Xmm.Value := pixdim[1]; + Ymm.Value := pixdim[2]; + Zmm.Value := pixdim[3]; + TSec.Value := pixdim[4]; + PixDim5.value := pixdim[5]; + PixDim6.value := pixdim[6]; + PixDim7.value := pixdim[7]; + OffsetEdit.value := round(vox_offset); + Scale.value := scl_slope; + Intercept.value := scl_inter; + fTypeDrop.ItemIndex :=( DataType2DropItem( datatype)); + if lHdr.DiskDataNativeEndian then + Endian.ItemIndex :=(0) + else + Endian.ItemIndex :=(1); + if Magic = kNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.ItemIndex :=(2) + else if Magic = kNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.ItemIndex :=(1) + else if Magic = kswapNIFTI_MAGIC_EMBEDDED_HDR then + HeaderMagicDrop.ItemIndex :=(2) + else if Magic = kswapNIFTI_MAGIC_SEPARATE_HDR then + HeaderMagicDrop.ItemIndex :=(1) + else + HeaderMagicDrop.ItemIndex :=(0); + CommentEdit.text := descrip; + data_typeEdit.text := data_type; + db_.text := db_name; + aux.text := aux_file; + intent_nameEdit.text := intent_name; + (*lCStr := ''; + for lInc := 1 to 80 do + lCStr := lCStr + descrip[lInc]; + CommentEdit.text := lCStr; + lCStr := ''; + for lInc := 1 to 10 do + lCStr := lCStr + data_type[lInc]; + data_typeEdit.text := lCStr; + lCStr := ''; + for lInc := 1 to 18 do + lCStr := lCStr + db_name[lInc]; + db_.text := lCStr; + lCStr := ''; + for lInc := 1 to 24 do + lCStr := lCStr + aux_file[lInc]; + aux.text := lCStr; + lCStr := ''; + for lInc := 1 to 16 do + lCStr := lCStr + intent_name[lInc]; + intent_nameEdit.text := lCStr;*) + xyzt_sizeDrop.ItemIndex :=(xyzt_units and 3); + xyzt_timeDrop.ItemIndex :=(time_units2DropItem(xyzt_units)); + ext.value := extents; + lInc := intent_code; + if (intent_code > 1) and (intent_code <= kNIFTI_LAST_STATCODE) then + lInc := lInc - 1 //intent_codes start from 2 not 1 + else if intent_code >= kNIFTI_FIRST_NONSTATCODE then //remove gap in numbers that follow final statcode + lInc := (intent_code - kNIFTI_FIRST_NONSTATCODE)+kNIFTI_LAST_STATCODE + else begin + lInc := 0; //unknown + end; + IntentCodeDrop .ItemIndex :=(lInc); + intent_p1Edit.value := intent_p1; + intent_p2Edit.value := intent_p2; + intent_p3Edit.value := intent_p3; + ses.value := session_error; + reg.value := ord(regular); + SliceCodeDrop.ItemIndex :=(slice_code); + //slice_end + //dimInfoEdit.value := (dim_info); + FreqDimDrop.ItemIndex :=(dim_info and 3); + PhaseDimDrop.ItemIndex :=((dim_info shr 2) and 3); + SliceDimDrop.ItemIndex :=((dim_info shr 4) and 3); + slice_startEdit.value := slice_start; + slice_endEdit.value := slice_end; + cmax.value := cal_max; + cmin.value := cal_min; + slice_durationEdit.value := slice_duration; + toffsetEdit.value := toffset; + gmax.value := glmax; + gmin.value := glmin; + //Next: 3D orientation rotations + QFacEdit.value := pixdim[0]; + QFormDrop.ItemIndex :=(qform_code); + //fx (quatern_b); + quatern_bEdit.value := quatern_b; + quatern_cEdit.value := quatern_c; + quatern_dEdit.value := quatern_d; + qoffset_xEdit.value := qoffset_x; + qoffset_yEdit.value := qoffset_y; + qoffset_zEdit.value := qoffset_z; + SFormDrop.ItemIndex :=(sform_code); + srow_x0Edit.value := srow_x[0];//12 affine matrix values + //showmessage(floattostr(srow_x[0])); + srow_x1Edit.value := srow_x[1]; + srow_x2Edit.value := srow_x[2]; + srow_x3Edit.value := srow_x[3]; + srow_y0Edit.value := srow_y[0]; + srow_y1Edit.value := srow_y[1]; + srow_y2Edit.value := srow_y[2]; + srow_y3Edit.value := srow_y[3]; + srow_z0Edit.value := srow_z[0]; + srow_z1Edit.value := srow_z[1]; + srow_z2Edit.value := srow_z[2]; + srow_z3Edit.value := srow_z[3]; + //Finally... check values + HeaderMagicDropSelect(nil); //disable or enable offset based on image format + end; //with lHdr +end; + +procedure THdrForm.ReadHdrDimensionsOnly (var lHdr: TMRIcroHdr); //reads only size dimensions: useful for computing estimated filesize +var + lInc: Integer; +begin + with lHdr.NIFTIhdr do begin + dim[1] := round(XDim.Value); + dim[2] := round(YDim.Value); + dim[3] := round(ZDim.Value); + dim[4] := round(TDim.Value); + dim[5] := round(Dim5Edit.value); + dim[6] := round(Dim6Edit.value); + dim[7] := round(Dim7Edit.value); + //Next: compute Dim[0]: compute number of dimensions by finding largest dimension with at least two samples + lInc := 7; + while dim[lInc] < 2 do + dec(lInc); + Dim[0] := lInc; //comp + //showmessage(inttostr(Dim[0])); + vox_offset := OffsetEdit.value; + DataType := DropItem2DataType(FTypeDrop.ItemIndex); + bitpix := DataType2BitsPerVoxel(DataType); + if Endian.ItemIndex = 0 then + lHdr.DiskDataNativeEndian := true + else + lHdr.DiskDataNativeEndian := false; + end; //with NIfTIhdr +end; //proc ReadHdrDimensionsOnly + +procedure THdrForm.ReadHdrForm (var lHdr: TMRIcroHdr); //read the values the user has entered +var + lInc: Integer; +begin + NIFTIhdr_ClearHdr(lHdr); //important: reset values like first 4 bytes = 348 + ReadHdrDimensionsOnly(lHdr); + //StatusBar1.Panels[0].text := 'ImageData (bytes)= '+inttostr(ComputeImageDataBytes(lHdr)); + with lHdr.NIFTIhdr do begin + pixdim[1] := Xmm.Value; + pixdim[2] := Ymm.Value; + pixdim[3] := Zmm.Value; + pixdim[4] := TSec.Value; + pixdim[5] := PixDim5.Value; + pixdim[6] := PixDim6.Value; + pixdim[7] := PixDim7.Value; + scl_slope := Scale.value; + scl_inter := Intercept.value; + if HeaderMagicDrop.ItemIndex = 2 then + Magic := kNIFTI_MAGIC_EMBEDDED_HDR + else if HeaderMagicDrop.ItemIndex = 1 then + Magic := kNIFTI_MAGIC_SEPARATE_HDR + else + Magic := 0; //not saed as NIFTI + for lInc := 1 to 80 do + descrip[lInc] := chr(0); + for lInc := 1 to length(CommentEdit.text) do + descrip[lInc] := CommentEdit.text[lInc]; + for lInc := 1 to 10 do + data_type[lInc] := chr(0); + for lInc := 1 to length(data_typeEdit.text) do + data_type[lInc] := data_typeEdit.text[lInc]; + for lInc := 1 to 18 do + db_name[lInc] := chr(0); + for lInc := 1 to length(db_.text) do + db_name[lInc] := db_.text[lInc]; + for lInc := 1 to 24 do + aux_file[lInc] := chr(0); + for lInc := 1 to length(aux.text) do + aux_file[lInc] := aux.text[lInc]; + for lInc := 1 to 16 do + intent_name[lInc] := chr(0); + for lInc := 1 to length(intent_nameEdit.text) do + intent_name[lInc] := intent_nameEdit.text[lInc]; + xyzt_units := xyzt_sizeDrop.ItemIndex; + xyzt_units := xyzt_units+ (DropItem2time_units(xyzt_timeDrop.ItemIndex)); + lInc := IntentCodeDrop.ItemIndex; + if (lInc > 0) and (lInc < kNIFTI_LAST_STATCODE) then + lInc := lInc + 1 //intent_codes start from 2 not 1 + else if (lInc >= kNIFTI_LAST_STATCODE) then //add gap in numbers between last stat code and misc codes + lInc := (lInc - kNIFTI_LAST_STATCODE)+kNIFTI_FIRST_NONSTATCODE + else + lInc := 0; //unknown + intent_code := lInc; + intent_p1 := intent_p1Edit.value; + intent_p2 := intent_p2Edit.value; + intent_p3 := intent_p3Edit.value; + extents:= round(ext.value); + session_error := round(ses.value); + regular := chr(round(reg.value)); + dim_Info := FreqDimDrop.ItemIndex+(PhaseDimDrop.ItemIndex shl 2)+(SliceDimDrop.ItemIndex shl 4); + slice_start := round(slice_startEdit.value); + slice_end := round(slice_endEdit.value); + slice_code := SliceCodeDrop.ItemIndex; + Slice_duration := (Slice_DurationEdit.value); + toffset := (toffsetEdit.value); + cal_max := cmax.value; + cal_min := cmin.value; + glmax := round(gmax.value); + glmin := round(gmin.value); + //Next: 3D orientation rotations + pixdim[0] := QFacEdit.value; + qform_code := QFormDrop.ItemIndex; + quatern_b := quatern_bEdit.value; + quatern_c := quatern_cEdit.value; + quatern_d := quatern_dEdit.value; + qoffset_x := qoffset_xEdit.value; + qoffset_y := qoffset_yEdit.value; + qoffset_z := qoffset_zEdit.value; + sform_code := SFormDrop.ItemIndex; + srow_x[0] := srow_x0Edit.value;//12 affine matrix values + srow_x[1] := srow_x1Edit.value; + srow_x[2] := srow_x2Edit.value; + srow_x[3] := srow_x3Edit.value; + srow_y[0] := srow_y0Edit.value; + srow_y[1] := srow_y1Edit.value; + srow_y[2] := srow_y2Edit.value; + srow_y[3] := srow_y3Edit.value; + srow_z[0] := srow_z0Edit.value; + srow_z[1] := srow_z1Edit.value; + srow_z[2] := srow_z2Edit.value; + srow_z[3] := srow_z3Edit.value; + end; //with lHdr + //zero_intercept := intercept.value; +end; + +function THdrForm.OpenAndDisplayHdr (var lFilename: string; var lHdr: TMRIcroHdr): boolean; +var lFileDir: string; +begin + FreeImgMemory(lHdr); + result := false; + NIFTIhdr_ClearHdr(lHdr); + if not NIFTIhdr_LoadHdr(lFilename, lHdr) then exit; + // result := true; exit;//rascal + WriteHdrForm (lHdr); + lFileDir := extractfiledir(lFilename); + if lFileDir <> gTemplateDir then + OpenHdrDlg.InitialDir := lFileDir; + SaveHdrDlg.InitialDir := lFileDir; + ImgForm.SaveDialog1.InitialDir := lFileDir; + SaveHdrDlg.FileName := lFilename; //make this default file to write + StatusBar1.Panels[1].text := lFilename; + StatusBar1.Panels[0].text := 'ImageBytes= '+inttostr(ComputeImageDataBytes(lHdr)); + result := true; +end; + +procedure THdrForm.Open1Click(Sender: TObject); +var lHdr: TMRIcroHdr; + lFilename: string; +begin +//NIfTI (*.hdr;*.nii)|*.hdr; *.nii; *.nii.gz|NIfTI separate header (*.hdr)|*.hdr|NIfTI embedded header|*.nii|NIfTI compressed|*.nii.gz + //if not OpenHdrDlg.Execute then exit; + if not OpenDialogExecute(kImgFilter,'Select header',false) then exit; + lFilename := OpenHdrDlg.Filename; + OpenAndDisplayHdr(lFilename,lHdr); +end; + +procedure THdrForm.TabMenuClick(Sender: TObject); +begin + PageControl1.ActivePage := PageControl1.Pages[(Sender as TMenuItem).Tag]; +end; + +procedure THdrForm.Exit1Click(Sender: TObject); //Quit the program or form +begin + Close; +end; + +procedure THdrForm.WMDropFiles(var Msg: TWMDropFiles); //implement drag and drop +//NOTE: requires 'ShellAPI' in uses clause +var lHdr: TMRIcroHdr; + CFileName: array[0..MAX_PATH] of Char; + lFilename: string; +begin + try + if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then + begin + lFilename := CFilename; + OpenAndDisplayHdr(lFileName, lHdr); + Msg.Result := 0; + end; + finally + DragFinish(Msg.Drop); + end; +end; + +procedure THdrForm.FormCreate(Sender: TObject); +var lHdr: TMRIcroHdr; +begin + DecimalSeparator := '.'; //important for reading DICOM data: e.g. Germans write '12,00' but DICOM is '12.00' + DragAcceptFiles(Handle, True); //engage drag and drop + NIFTIhdr_ClearHdr(lHdr); + HdrForm.WriteHdrForm (lHdr); //show default header +end; + +procedure THdrForm.ImageSzChange(Sender: TObject); //report size of image data +var + lHdr: TMRIcroHdr; +begin + NIFTIhdr_ClearHdr(lHdr); //important: reset values like first 4 bytes = 348 + ReadHdrDimensionsOnly(lHdr); + StatusBar1.Panels[0].text := 'ImageData (bytes)= '+inttostr(ComputeImageDataBytes(lHdr)); +end; + +procedure THdrForm.HeaderMagicDropSelect(Sender: TObject); +var lHdrIndex: integer; +begin + lHdrIndex := HeaderMagicDrop.ItemIndex; //0=unkown, 1=nifti hdr+img, 2=nifti .nii embedded + if lHdrIndex = 1 then begin//nifti hdr+img, offset must be = 0 + OffsetEdit.MinValue := 0; + OffsetEdit.Enabled := false; + OffsetEdit.value := 0; + end else if lHdrIndex = 2 then begin//embedded header, offset must be at least 348 + OffsetEdit.Enabled := true; + if OffsetEdit.value < sizeof(TNIFTIHdr) then + OffsetEdit.value := sizeof(TNIFTIHdr); + OffsetEdit.MinValue := sizeof(TNIFTIHdr); + end else begin //no embedded header... therefore offset can be zero + OffsetEdit.MinValue := 0; + OffsetEdit.Enabled := true; + if OffsetEdit.value = sizeof(TNIFTIHdr) then + OffsetEdit.value := 0; + end; +end; + +procedure THdrForm.Saveheader1Click(Sender: TObject); +var lHdr: TMRIcroHdr; + lFilename: string; +begin + NIFTIhdr_ClearHdr(lHdr); + if not SaveHdrDlg.Execute then exit; + lFilename := SaveHdrDlg.Filename; + OpenHdrDlg.InitialDir := extractfiledir(lFilename); + ImgForm.SaveDialog1.InitialDir := extractfiledir(lFilename); + ReadHdrForm (lHdr); + if not NIFTIhdr_SaveHdr (lFilename, lHdr,true) then exit; + OpenHdrDlg.FileName := lFilename; //make this default file to open + StatusBar1.Panels[1].text := 'wrote: '+lFilename; +end; + +procedure THdrForm.Closewindow1Click(Sender: TObject); +begin + Close; +end; + +procedure THdrForm.SpeedButton1Click(Sender: TObject); +var + lHdr: TMRIcroHdr; +begin + ReadHdrForm (lHdr); +//fx(lHdr.NIfTIhdr.pixdim[0]); + nifti_mat2quat (lHdr.NIfTIhdr); +//fx(lHdr.NIfTIhdr.pixdim[0]); + WriteHdrForm (lHdr); //show new Q values +end; + +procedure THdrForm.CopyMAT1Click(Sender: TObject); +var + lHdr: TMRIcroHdr; + +begin + ReadHdrForm (lHdr); + with lHdr.NIFTIhdr do + Clipboard.AsText := '['+floattostr(srow_x[0])+', '+floattostr(srow_x[1])+', '+floattostr(srow_x[2])+', '+floattostr(srow_x[3])+';' + +floattostr(srow_y[0])+', '+floattostr(srow_y[1])+', '+floattostr(srow_y[2])+', '+floattostr(srow_y[3])+';' + +floattostr(srow_z[0])+', '+floattostr(srow_z[1])+', '+floattostr(srow_z[2])+', '+floattostr(srow_z[3])+';' + +'0, 0, 0, 1]'; +end; + +end. diff --git a/niftiview7/nifti_img.pas b/niftiview7/nifti_img.pas new file mode 100755 index 0000000..4cce6ee --- /dev/null +++ b/niftiview7/nifti_img.pas @@ -0,0 +1,6276 @@ +unit nifti_img; +interface +{$DEFINE madfx} //madfx: madgraphics interpolate instead of windows halftone - better for pre-WinXP, similar speed +uses + {$IFDEF madfx}madGraphics, {$ENDIF} + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Menus, Buttons, ToolWin, ComCtrls, ExtCtrls, NIFTI_hdr, StdCtrls, RXSpin,Math, + ClipBrd,ShellAPI,nifti_hdr_view,define_types,SSE, nii_label, + graphicsMathLibrary,Distr,{Stat,}ReadInt,fdr,PNGImage,pref_ini, nifti_types; +const + kMultiView = 0; + kAxView0 = 1; + kSagView0 = 2; + kCoroView0 = 3; + kAxViewOnly = -1; + kSagViewOnly = -2; + kCoroViewOnly = -3; + +procedure CreateAnaRGB; +procedure MirrorScrnBuffer(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr ); +function MirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +function SlicesToImgPos(lX,lY,lZ: integer): integer; +procedure ImgPosToSlices(lPos: integer; var lX,lY,lZ: integer); +procedure ImgPosToMM(lPos: integer; var lXmm,lYmm,lZmm: single); +procedure RefreshActiveImage; +procedure IntenBar (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer {1=Left,2=Top,3=right,4=bottom}; lMin,lMax: single); +procedure Balance (var lHdr: TMRIcroHdr); +function OpenImg(var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground,lVOILoadAsBinary,lNoScaling8bit,lResliceIn,l4D{,lOrthoReslice}: boolean): boolean; +procedure InitImgMemory(var lHdr: TMRIcroHdr); +procedure FreeImgMemory(var lHdr: TMRIcroHdr); +procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +procedure RescaleImgIntensity(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lLayer: integer ); +procedure LoadColorScheme(lStr: string; var lHdr: TMRIcroHdr); +procedure LoadMonochromeLUT (var lLUT: integer; var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); //lLUT: 0=gray,1=red,2=green,3=blue +procedure FilterLUT (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lMin, lMax: integer); //lLUT: 0=gray,1=red,2=green,3=blue +function Raw2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +function Scaled2RawIntensity (lHdr: TMRIcroHdr; lScaled: single): single; +procedure AlphaBlend32(lBGQuad,lOverlayQuad : RGBQuadp; lBG0Clr,lOverlay0Clr: DWord; lSlicePixels, lOverlayTransPct: integer); // 630 +function MaxDim (lX,lY,lZ: integer): integer; //returns largest of 3 +procedure DrawHistogram (var lHdr: TMRIcroHdr; var lImage: TImage); +procedure SetSubmenuWithTag (var lRootMenu: TMenuItem; lTag: Integer); +procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +procedure SaveAsVOIorNIFTI (var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; DefaultFormatVOI: boolean; var lNiftiHdr: TNIFTIHdr; lDefFilename: string); +function Scrn2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +procedure ScaleScrn2BMP (var lX, lY: integer;lImage: TImage); +procedure DrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +function ImageZoomPct( var lImage: TImage): integer; +procedure ScaleBMP2Draw (var InvZoomShl10,lX, lY,lPanel: integer; lImage: TImage); +function ImgVaries ( var lHdr: TMRIcroHdr): boolean; +function ComputeInvZoomShl10(lSelectedImageNum: integer; var lImage: TImage): integer; +function ComputeZoomPct(lSelectedImageNum: integer; var lImage: TImage): integer; +function SelectedImageNum: Integer; +procedure EnsureVOIOpen; +procedure FreeUndoVol; +procedure CreateUndoVol; +procedure UndoVolVOI; +function IsVOIOpen: boolean; +//procedure SortCutout (var lCutout : TCutout); //ensure Lo < Hi +procedure SaveImgAsPNGBMPCore (lImage: TImage; lFilename: string); +procedure SaveImgAsPNGBMP (lImage: TImage); +procedure RefreshImages; +procedure DrawAxial (lSlice,lMultiSlice: integer); +procedure DrawSag(lSlice,lMultiSlice: integer); +procedure DrawCor(lSlice,lMultiSlice: integer); +procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +procedure ImgCoordToMM(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +procedure MMToImgCoord(var lX,lY,lZ: integer; lXmm,lYmm,lZmm: single); +//function DimToMM (lIn, lDim: integer): integer; +function DimToMM (lX,lY,lZ, lDim: integer): integer; +function DimToMMx (lDim: integer): integer; + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TMRIcroHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +function CenterOfMass (lOverlay: integer; var lX,lY,lZ: double): integer; +procedure TextReportHisto (var lHdr: TMRIcroHdr); +procedure ReturnMinMax (var lHdr: TMRIcroHdr; var lMin,lMax: single; var lFiltMin8bit, lFiltMax8bit: integer); +function RawBGIntensity(lPos: integer): single; + +var +gSelectedImageNum :integer; +//gAxZoom100 : integer; +//gTripleZoom100 : integer; +(*LoadYaw : single = 0; +loadPitch : single = 0; +LoadRoll : single = 0; *) +//gImgSpacing: integer = 0; +//gTripleZoom: single = 1; +implementation + +uses rotation, nifti_img_view,MultiSlice,histoform,text,reslice_img,ortho_reorient; + +procedure ScaleBMP2Draw (var InvZoomShl10,lX, lY, lPanel: integer; lImage: TImage); +begin + //lScaleShl10 := ComputeInvZoomShl10(SelectedImageNum,lImage); + //ImgForm.StatusLabel.Caption := inttostr(InvZoomShl10); + if (gBGImg.FlipSag) and (lPanel = 2) then + lX := ((lImage.Width-lX) * InvZoomShl10) shr 10 + else if (lX < 1) then + lX := 0 + else + lX := (lX * InvZoomShl10) shr 10; + if (gBGImg.FlipAx) and (lPanel = 1) then + lY := ((lImage.Height-lY) * InvZoomShl10) shr 10 + else if (lY < 1) then + lY := 0 + else + lY := (lY * InvZoomShl10) shr 10; + +end; + + +function RawBGIntensity(lPos: integer): single; +var + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + result := 0; + if (lPos > gMRIcroOverlay[kBGOverlayNum].ImgBufferItems) or (lPos < 1) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l32Buf[lPos]; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + result := l16Buf[lPos]; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then + result := gMRIcroOverlay[kBGOverlayNum].ImgBuffer[lPos] + else begin + showmessage('Unknown Background Buffer Bytes Per Pixel'); + exit; + end; +end; + +function CenterOfMass (lOverlay: integer; var lX,lY,lZ: double): integer; +//result is volume in voxels - 0 = no volume or error +var + lXpos,lYpos,lZpos,lInc: integer; + +begin + result := 0; + lX := 0; + lY := 0; + lZ := 0; + //fx(gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1],gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2],gMRIcroOverlay[lOverlay].ScrnBufferItems); + if (gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1]*gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2]* gMRIcroOverlay[lOverlay].NIFTIhdr.dim[3]) <> gMRIcroOverlay[lOverlay].ScrnBufferItems then + exit; + lInc := 0; + for lZpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[3] do begin + for lYpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[2] do begin + for lXpos := 1 to gMRIcroOverlay[lOverlay].NIFTIhdr.dim[1] do begin + inc(lInc); + if gMRIcroOverlay[lOverlay].ScrnBuffer[lInc] > 0 then begin + inc(result); + lX := lX + lXpos; + lY := lY + lYpos; + lZ := lZ + lZpos; + end; + end; //lX + end;//Y + end;//Z + if result > 0 then begin + lX := lX / result; + lY := lY / result; + lZ := lZ / result; + end; + //lARDistance := round(sqrt( sqr(lRX-lAX)+sqr(lRY-lAY)+sqr(lRZ-lAZ))); //<- pythagorean theorem for dx +end; + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TMRIcroHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +//lIntent kNIFTI_INTENT_CHISQ lIntent_p1 = DOF +//lIntent kNIFTI_INTENT_ZSCORE no params +//lIntent kNIFTI_INTENT_TTEST lIntent_p1 = DOF +var lIntentNameLen,lPos: integer; +begin + with lStatHdr do begin + move(lBGHdr.niftiHdr,lStatHdr.niftiHdr,sizeof(TniftiHdr)); + ImgBufferBPP := 1; + ImgBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + NIFTIhdr.scl_slope:= 1; + NIFTIhdr.scl_inter:= 0; + NIFTIhdr.glmin := round(lMinIntensity); + NIFTIhdr.glmax := round(lMaxIntensity); + AutoBalMinUnscaled := lMinIntensity; + AutoBalMaxUnscaled := lMaxIntensity; + WindowScaledMin := lMinIntensity; + WindowScaledMax := lMaxIntensity; + GlMinUnscaledS := lMinIntensity; + GlMaxUnscaledS := lMaxIntensity; + HdrFileName := extractfilepath(HdrFilename)+pathdelim+'stat.nii.gz'; + ImgFileName := HdrFileName; + NIFTIhdr.intent_code := lIntent_Code;// kNIFTI_INTENT_ESTIMATE; + NIFTIhdr.intent_p1 := lIntent_p1; + NIFTIhdr.intent_p2 := lIntent_p2; + NIFTIhdr.intent_p3 := lIntent_p3; + lIntentNameLen := length(lIntentName); + if lIntentNameLen > sizeof(NIFTIhdr.intent_name) then + lIntentNameLen := sizeof(NIFTIhdr.intent_name); + if lIntentNameLen > 0 then + for lPos := 1 to lIntentNameLen do + NIFTIhdr.intent_name[lPos] := lIntentName[lPos]; + end; +end; +(*procedure FindMatrixPtX (lX,lY,lZ: single; var lXout,lYOut,lZOut: single; var lMatrix: TMatrix); +//given voxel lX,lY,lZ returns the rotated coordinate Xout,Yout,Zout 3 +begin + lXOut := (lX*lMatrix.matrix[1,1])+(lY*lMatrix.matrix[1,2])+(lZ*lMatrix.matrix[1,3])+lMatrix.matrix[1,4]; + lYOut := (lX*lMatrix.matrix[2,1])+(lY*lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[2,3])+lMatrix.matrix[2,4]; + lZOut := (lX*lMatrix.matrix[3,1])+(lY*lMatrix.matrix[3,2])+(lZ*lMatrix.matrix[3,3])+lMatrix.matrix[3,4]; +end;*) + +(*procedure Crap (lX,lY,lZ: single); +var + lxmm,lymm,lzmm: single; +begin + lxmm := lX; + lymm := ly; + lzmm := lZ; + Voxel2mm (lxmm,lymm,lzmm, gMRIcroOverlay[kBGOverlayNum].NIftiHdr); + ImgForm.caption := floattostr(lx)+'x'+floattostr(ly)+'x'+floattostr(lz)+'= '+floattostr(lxmm)+' '+floattostr(lymm)+' '+floattostr(lzmm); + +end; *) + +procedure MMToImgCoord(var lX,lY,lZ: integer; {var} lXmm,lYmm,lZmm: single); +var + lXx,lYy,lZz: single; +begin + if (not gBGImg.Resliced) and ( gMRIcroOverlay[kBGOverlayNum].NIfTItransform) then begin//vcx + //mirror + lxx := lXmm; + lyy := lYmm; + lzz := lZmm; + mm2Voxel (lxx,lyy,lzz,gBGImg.InvMat); + //crap(lxx,lyy,lzz); + if gBGImg.Mirror then + lXx := gBGImg.ScrnDim[1]-lXx; + + lX := round(lxx); + ly := round(lyy); + lz := round(lzz); + exit; + end; + if gBGImg.ScrnMM[1] = 0 then + lX := 1 + else if gBGImg.Mirror then //Sept2008 + lX := round((gBGImg.ScrnDim[1]-gBGImg.ScrnOri[1]+1)-(lXmm/gBGImg.ScrnMM[1])) + else + lX := round((lXmm/gBGImg.ScrnMM[1])+gBGImg.ScrnOri[1]); + if gBGImg.ScrnMM[2] = 0 then //Sept2008 + lY := 1 + else + lY := round((lYmm/gBGImg.ScrnMM[2])+gBGImg.ScrnOri[2]); + if gBGImg.ScrnMM[3] = 0 then //Sept2008 + lZ := 1 + else + lZ := round((lZmm/gBGImg.ScrnMM[3])+gBGImg.ScrnOri[3]); + if lX < 1 then lX := 1; + if lY < 1 then lY := 1; + if lZ < 1 then lZ := 1; + if lX > gBGImg.ScrnDim[1] then lX := gBGImg.ScrnDim[1]; + if lY > gBGImg.ScrnDim[2] then lY := gBGImg.ScrnDim[2]; + if lZ > gBGImg.ScrnDim[3] then lZ := gBGImg.ScrnDim[3]; +end; + +procedure ImgCoordToMM(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +begin + if (not gBGImg.Resliced) and ( gMRIcroOverlay[kBGOverlayNum].NIfTItransform) then begin//vcx + //mirror + lXmm := lX; + if gBGImg.Mirror then + lXmm := gBGImg.ScrnDim[1]-lXmm; + lYmm := lY; + lZmm := lZ; + Voxel2mm (lxmm,lymm,lzmm, gMRIcroOverlay[kBGOverlayNum].NIftiHdr); + //imgform.Caption := floattostr(lxmm)+' '+floattostr(lymm)+' '+floattostr(lzmm)+' 666'; + exit; + end; +if gBGImg.Mirror then lXmm := ((gBGImg.ScrnDim[1]-lX+1)-gBGImg.ScrnOri[1])*gBGImg.ScrnMM[1] else + + lXmm := ((lX)-gBGImg.ScrnOri[1])*gBGImg.ScrnMM[1]; + lYmm := ((lY)-gBGImg.ScrnOri[2])*gBGImg.ScrnMM[2]; + lZmm := ((lZ)-gBGImg.ScrnOri[3])*gBGImg.ScrnMM[3]; +end; + +function XPos(lPos,XDim: integer): integer; //given 1D array return 3D column +begin + result := lPos mod XDim; + if result = 0 then + result := XDim; +end; + +function ZPos(lPos, XDimTimesYDim: integer): integer; //given 1D array return 3D slice +begin + result := lPos div XDimTimesYDim; + if (lPos mod XDimTimesYDim) <> 0 then + inc(result); +end; + +function YPos(lPos, XDim,YDim: integer): integer; //given 1D array return 3D row +var + lSlicePos: integer; +begin + //first - eliminate slice offset + result := ZPos(lPos,XDim*YDim); + lSlicePos := lPos - ((result-1)*(XDim*YDim)); + //now find row + result :=lSlicePos div XDim; + if (lSlicePos mod XDim) <> 0 then + inc(result); +end; + +function SlicesToImgPos(lX,lY,lZ: integer): integer; +begin + result := lX + ((lY-1) * gBGImg.ScrnDim[1])+ ((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); +end; +procedure ImgPosToSlices(lPos: integer; var lX,lY,lZ: integer); +begin + lX := XPos(lPos,gBGImg.ScrnDim[1]); + lY := YPos(lPos,gBGImg.ScrnDim[1],gBGImg.ScrnDim[2]); + lZ := ZPos(lPos,gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); +end; + +procedure ImgPosToMM(lPos: integer; var lXmm,lYmm,lZmm: single); +var lX,lY,lZ: integer; +begin + lX := XPos(lPos,gBGImg.ScrnDim[1]); + lY := YPos(lPos,gBGImg.ScrnDim[1],gBGImg.ScrnDim[2]); + lZ := ZPos(lPos,gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + ImgCoordToMM(lX,lY,lZ, lXmm,lYmm,lZmm); +end; + +function DimToMM (lX,lY,lZ, lDim: integer): integer; +//Sept2008 - X/Y/Z required for rotated images +var + lXi,lYi,lZi: integer; + lXmm,lYmm,lZmm: single; +begin + lXi := lX; + lYi := lY; + lZi := lZ; + ImgCoordToMM(lXi,lYi,lZi,lXmm,lYmm,lZmm); + //imgform.Caption := floattostr(lxmm)+' '+floattostr(lymm)+' '+floattostr(lzmm)+' 666'; + case lDim of + 3: result := round(lZmm); + 2: result := round(lYmm); + else result := round(lXmm); + end //case +end; //DimToMM + +function DimToMMx (lDim: integer): integer; +var + lX,lY,lZ: integer; +begin + lX := round(ImgForm.XViewEdit.value); + lY := round(ImgForm.YViewEdit.value); + lZ := round(ImgForm.ZViewEdit.value); + result := DimToMM(lX,lY,lZ,lDim); +end; //DimToMM + +(*function DimToMM (lIn, lDim: integer): integer; +var + lX,lY,lZ: integer; + lXmm,lYmm,lZmm: single; +begin + lX := lIn; + lY := lIn; + lZ := lIn; + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + imgform.Caption := floattostr(lxmm)+' '+floattostr(lymm)+' '+floattostr(lzmm)+' 666'; + case lDim of + 3: result := round(lZmm); + 2: result := round(lYmm); + else result := round(lXmm); + end //case +end; //DimToMM *) + +procedure DrawTextLabel(var lImage: TImage; lOutStr: string; lXCenterIn,lXWidthIn: integer); +var + lXWidth,lXCenter: integer; +begin +//exit;//drawgrid + lXWidth := lXWidthIn; + lXCenter:= lXCenterIn; + if lXWidth < 1 then begin + lXWidth := lImage.Picture.Bitmap.Width; + end; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + lImage.Canvas.Font.Size := gBGImg.FontSize; + (*if lXWidth < 100 then + lImage.Canvas.Font.Size := 9 + else if lXWidth < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14; *) + if lXCenterIn < 1 then + lImage.canvas.TextOut(2,1,lOutStr) + else if lXCenterIn = MaxInt then + lImage.canvas.TextOut((lXWidth div 2)-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) + else + lImage.canvas.TextOut(lXCenter-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) +end; + +procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +begin + DrawTextLabel(lImage,inttostr(lValue),lXCenterIn,lXWidthIn); +end; + +procedure DrawTextLabelV(var lImage: TImage; lOutStr: string); +var + lYHt: integer; +begin + lYHt := lImage.Picture.Bitmap.Height; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + lImage.canvas.TextOut(2,(lYHt div 2)-round(0.5*lImage.Canvas.TextHeight('X')),lOutStr) +end; + +(*procedure DrawLabel(var lImage: TImage; lValue,lXCenterIn,lXWidthIn: integer); +var + lOutStr: string; + lXWidth,lXCenter: integer; +begin + lXWidth := lXWidthIn; + lXCenter:= lXCenterIn; + if lXWidth < 1 then begin + lXWidth := lImage.Picture.Bitmap.Width; + end; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.font.Color := gBGImg.XBarClr; + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + if lXWidth < 100 then + lImage.Canvas.Font.Size := 9 + else if lXWidth < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14; + lOutStr := inttostr(lValue); + if lXCenterIn < 1 then + lImage.canvas.TextOut(2,1,lOutStr) + else if lXCenterIn = MaxInt then + lImage.canvas.TextOut((lXWidth div 2)-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) + else + lImage.canvas.TextOut(lXCenter-(lImage.Canvas.TextWidth(lOutStr) div 2),1,lOutStr) +end;*) + + +procedure PasteDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lImage: TImage; lXOffset: integer); +var + sbBits : PByteArray; + lPGWid,lPGHt,nBytesInImage: integer; + lBMP: TBitmap; + lSrcRect,lDestRect: TRect; +begin + lPGWid := lInPGWid; + lPGHt := lInPGHt; + lBMP := TBitmap.Create; + TRY + lBMP.PixelFormat := pf32bit; + lBMP.Width := lPGwid; + lBMP.Height := lPGHt; + sbBits := lBmp.ScanLine[lPGHt-1]; + nBytesInImage := lPGWid*lPGHt * 4; + CopyMemory(Pointer(sbBits),Pointer(lBuff),nBytesInImage); + lImage.Canvas.CopyMode := cmSrcCopy; + lSrcRect := Rect(0,0,lBMP.Width,lBMP.Height); + lDestRect := Rect(lXOffset,0,lXOffset+lBMP.Width,lBMP.Height); + lImage.Canvas.CopyRect(lDestRect,lBMP.Canvas,lSrcRect); + FINALLY + lBMP.Free; + END; //try..finally +end; //proc PasteDimension32 + +procedure FlipSlice (lY,lX: integer; lImage: RGBQuadp); +var + lRowData: RGBQuadp; + lYi,lHalfY,lRowBytes,lTop,lBottom: integer; +begin + if lY < 2 then exit; + lRowBytes := lX * 4; + getmem(lRowData,lRowBytes); + lHalfY := lY div 2; + lTop := 1; + lBottom := ((lY-1)*lX)+1; + for lYi := 1 to lHalfY do begin + Move(lImage^[lTop],lRowData^[1],lRowBytes); + Move(lImage^[lBottom],lImage^[lTop],lRowBytes); + Move(lRowData^[1],lImage^[lBottom],lRowBytes); + lTop := lTop + lX; + lBottom := lBottom - lX; + end; + freemem(lRowData); +end; + +procedure MirrorSlice (lY,lX: integer; lImage: RGBQuadp); +var + lRowData: RGBQuadp; + lXi,lYi,lHalfX,lRowBytes,lTop: integer; +begin + if lX < 2 then exit; + lRowBytes := lX * 4; + getmem(lRowData,lRowBytes); + lHalfX := lX div 2; + lTop := 1; + for lYi := 1 to lY do begin + Move(lImage^[lTop],lRowData^[1],lRowBytes); + for lXi := 1 to lX do + lImage^[lTop+lXi-1] := lRowData^[lX - lXi + 1]; + lTop := lTop + lX; + end; + freemem(lRowData); +end; + +procedure CreateSag(var lHdr: TMRIcroHdr; lX,lXOffset,lY,lZ,lXYSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + lPixel,lYPos,lZPos,lZOffset,lYOffset: integer; +begin + lSrc := lHdr.ScrnBuffer; + lPixel := 0; + if lHdr.ScrnBufferItems < (((lZ-1)*lXYSliceSz)+(lX*lY) ) then + exit; //lukas + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + lQuadP[lPixel]:=lHdr.LUT[lSrc[lZOffset+lYOffset+lXOffset]]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z +end; //CreateSag + +procedure DrawSag (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lOverlay,lnOverlay,lXOffset, lX,lY,lZ,lXYSliceSz,lYZSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + if (lMultiSlice < 0) and (not ImgForm.PGImageSag.visible) then //not visible - no reason to draw... + exit; + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lXOffset := round(lSlice{gBGImg.XViewCenter}); + lXYSliceSz := (lX*lY); + lYZSliceSz := (lY*lZ); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lXOffset < 0) or (lXYSliceSz < 1) then + exit; + if (lZ < 2) then begin + ImgForm.PGImageSag.Width := 1; + ImgForm.PGImageSag.Height := 1; + exit; + end; + GetMem ( lBGQuadP , lYZSliceSz*4); + CreateSag(gMRIcroOverlay[kBGOverlayNum], lX,lXOffset,lY,lZ,lXYSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +lBG0Clr:= (gMRIcroOverlay[kBGOverlayNum].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lYZSliceSz*4); + lBG0Clr:= (gMRIcroOverlay[lOverlay].LUTinvisible); + CreateSag(gMRIcroOverlay[lOverlay], lX,lXOffset,lY,lZ,lXYSliceSz, lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lYZSliceSz*4); + CreateSag(gMRIcroOverlay[lOverlay], lX,lXOffset,lY,lZ,lXYSliceSz, l2ndOverlayQuadP); + lOverlay0Clr:= (gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lYZSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible [no alpha] DWord(lHdr.LUTinvisible); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lYZSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; + if gBGImg.FlipSag then + MirrorSlice (lZ,lY, lBGQuadP); +//draw image + if lMultiSlice >= 0 then + PasteDimension32(lZ,lY, lBGQuadP, MultiSliceForm.MultiImage,lMultiSlice) + else begin + SetDimension32(lZ,lY, lBGQuadP, gBGImg, ImgForm.PGImageSag,ImgForm.TriplePanel); + FreeMem ( lBGQuadP); + if ImgForm.XBarBtn.Down then begin + if gBGImg.FlipSag then + DrawXBar ( round(lY-gBGImg.YViewCenter), round(gBGImg.ZViewCenter),ImgForm.PGImageSag) + else + DrawXBar ( round(gBGImg.YViewCenter), round(gBGImg.ZViewCenter),ImgForm.PGImageSag); + DrawLabel(ImgForm.PGImageSag, DimToMMx(1),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageSag,gBGImg.MaxChar[3],MaxInt,-1); + if gBGImg.FlipSag then + DrawTextLabelV(ImgForm.PGImageSag,gBGImg.MaxChar[2]) + else + DrawTextLabelV(ImgForm.PGImageSag,gBGImg.MinChar[2]); + end; + end; //XBars + end; //draw +end; + +(*procedure DrawSagCore (lSlice: integer; lBGQuadP: RGBQuadp); +var + lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lOverlay,lnOverlay,lXOffset, lX,lY,lZ,lXYSliceSz,lYZSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lXOffset := round(lSlice{gBGImg.XViewCenter}); + lXYSliceSz := (lX*lY); + lYZSliceSz := (lY*lZ); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lXOffset < 0) or (lXYSliceSz < 1) then + exit; + if (lZ < 2) then begin + ImgForm.PGImageSag.Width := 1; + ImgForm.PGImageSag.Height := 1; + exit; + end; + //GetMem ( lBGQuadP , lYZSliceSz*4); + CreateSag(gMRIcroOverlay[kBGOverlayNum], lX,lXOffset,lY,lZ,lXYSliceSz, lBGQuadP); + //next: overlays + lnOverlay := 0; + lBG0Clr:= (gMRIcroOverlay[kBGOverlayNum].LUTinvisible);//just to avoid compiler warning hint - never used... + for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lYZSliceSz*4); + lBG0Clr:= (gMRIcroOverlay[lOverlay].LUTinvisible); + CreateSag(gMRIcroOverlay[lOverlay], lX,lXOffset,lY,lZ,lXYSliceSz, lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lYZSliceSz*4); + CreateSag(gMRIcroOverlay[lOverlay], lX,lXOffset,lY,lZ,lXYSliceSz, l2ndOverlayQuadP); + lOverlay0Clr:= (gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lYZSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded + end; //for knOverlay..1 + //Finally: draw overlays on BG + if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible [no alpha] DWord(lHdr.LUTinvisible); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lYZSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); + end; +end; + +type + RGBTripleRA = array [1..1] of TRGBTriple; + RGBTriplep = ^RGBTripleRA; +procedure Quad2Triple (lQ: RGBQuadp; var lT: RGBTriplep; lPos: integer); +begin +//note swizzle color order + lT^[lPos].rgbtBlue := lQ^[lPos].rgbRed; + lT^[lPos].rgbtGreen := lQ^[lPos].rgbGreen; + lT^[lPos].rgbtRed := lQ^[lPos].rgbBlue; +end; + +procedure CreateTX3; +var + lF: File; + lFilename: string; + lHdr: array [1..4] of longint; + lQ: RGBQuadp; + lT: RGBTriplep; + lImg,lImg3: Bytep; + lVolVox,lX,lY,lZ,lI,lnSlice,lSliceBytes: integer; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lVolVox := lX*lY*lZ ; + getmem(lImg, lVolVox* sizeof(TRGBQuad)) ; + //for Sag + lnSlice := lX; + lSliceBytes := lY * lZ* sizeof(TRGBQuad); + for lI := 1 to lnSlice do //[1+ ((lI-1)*lSliceBytes)] + DrawSagCore (lI,RGBQuadp(@lImg^[1+((lI-1)*lSliceBytes)]) ); + //NIfTI does not have a RGBA format, save as RGB + lQ := RGBQuadp(lImg); + getmem(lImg3, lVolVox* sizeof(TRGBTriple)) ; + lT := RGBTriplep(lImg3); + for lI := 1 to lVolVox do begin + Quad2Triple(lQ, lT,lI); + end; + freemem(lImg); + //output data + Filemode := 1; + lFilename := 'C:\pas\mricrongl\q.tx3'; + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,1); + lHdr[1] := 6407; + lHdr[2] := lY; + lHdr[3] := lZ; + lHdr[4] := lX; + + BlockWrite(lF,lHdr,sizeof(lHdr)); + BlockWrite(lF,lImg3^,lVolVox* sizeof(TRGBTriple)); + CloseFile(lF); + Filemode := 2; + //release memory + freemem(lImg3); +end;*) + + + +procedure CreateCor(var lHdr: TMRIcroHdr; lX,lYOffset,lZ,lXYSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + lPixel,lXPos,lZPos,lZOffset: integer; +begin + lSrc := lHdr.ScrnBuffer; + lPixel := 0; + if lHdr.ScrnBufferItems < (((lZ-1)*lXYSliceSz)+lX+lYOffset ) then + exit; //lukas + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + lQuadP[lPixel]:=lHdr.LUT[lSrc[lZOffset+lYOffset+lXPos]]; + end; //for each Y + end; //for each Z +end; + +procedure DrawCor (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lOverlay,lnOverlay, lYOffset, lX,lY,lZ,lS,lXYSliceSz,lXZSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + //kc + //if (lMultiSlice < 0) and (not ImgForm.PGImageCor.visible) then //not visible - no reason to draw... + // exit; + + lX := (gBGImg.ScrnDim[1]); + lY := (gBGImg.ScrnDim[2]); + lZ := (gBGImg.ScrnDim[3]); + lS := round(lSlice); + lXYSliceSz := (lX*lY); + lXZSliceSz := (lX*lZ); + lYOffset := (lX) * (lS-1); + if (lS > lY) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 1) or (lXYSliceSz < 1) then + exit; + if (lZ < 2) then begin + //ImgForm.caption := inttostr(random(888)); + ImgForm.PGImageCor.Width := 1; + ImgForm.PGImageCor.Height := 1; + exit; + end; + GetMem ( lBGQuadP , lXZSliceSz*4); + CreateCor(gMRIcroOverlay[kBGOverlayNum], lX,lYOffset,lZ,lXYSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lXZSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateCor(gMRIcroOverlay[lOverlay], lX,lYOffset,lZ,lXYSliceSz, lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lXZSliceSz*4); + CreateCor(gMRIcroOverlay[lOverlay], lX,lYOffset,lZ,lXYSliceSz, l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lXZSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUTinvisible); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lXZSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + if lMultiSlice >= 0 then begin + PasteDimension32(lZ,lX, lBGQuadP, MultiSliceForm.MultiImage,lMultiSlice) + end else begin + SetDimension32(lZ,lX, lBGQuadP, gBGImg,ImgForm.PGImageCor,ImgForm.TriplePanel); + if ImgForm.XBarBtn.Down then begin + DrawXBar ( round(gBGImg.XViewCenter), round({lZ-}gBGImg.ZViewCenter),ImgForm.PGImageCor); + DrawLabel(ImgForm.PGImageCor, DimToMMx(2),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageCor,gBGImg.MaxChar[3]{'S'},MaxInt,-1); + if gBGImg.Mirror then + DrawTextLabelV(ImgForm.PGImageCor,gBGImg.MaxChar[1]{'R'}) + else + DrawTextLabelV(ImgForm.PGImageCor,gBGImg.MinChar[1]{'L'}); + end; + + end; //XBar + end; + FreeMem ( lBGQuadP); +end; +procedure CreateAxial(var lHdr: TMRIcroHdr; lStart,lSliceSz: Integer; var lQuadP: RGBQuadp); +var + lSrc: Bytep; + lPixel: integer; +begin + lSrc := lHdr.ScrnBuffer; + if lHdr.ScrnBufferItems < (lStart+lSliceSz ) then + exit; //lukas + + for lPixel := 1 to lSliceSz do + lQuadP[lPixel]:=lHdr.LUT[lSrc[lStart+lPixel]]; +end; + +procedure DrawAxial (lSlice,lMultiSlice: integer); +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lnOverlay,lOverlay, lX,lY,lS,lStart,lSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + if (lMultiSlice < 0) and (not ImgForm.PGImageAx.visible) then //not visible - no reason to draw... + exit; + + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lS := (lSlice); + if lS = 0 then + lS := 1; + lSliceSz := (lX * lY{*lByte}); + lStart := (lX*lY*(lS-1)); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 0) or (lX < 2) or (lStart < 0) or (lSliceSz < 1) or ((lStart+lSliceSz-1) > gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then + exit; + GetMem ( lBGQuadP, lSliceSz*4); + CreateAxial(gMRIcroOverlay[kBGOverlayNum], lStart,lSliceSz, lBGQuadP); +//next: overlays +lnOverlay := 0; +lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + if gBGImg.FlipAx then + FlipSlice (lY,lX, lBGQuadP); + if lMultiSlice >= 0 then + PasteDimension32(lY,lX, lBGQuadP, MultiSliceForm.MultiImage,lMultiSlice) + else begin + SetDimension32(lY,lX, lBGQuadP, gBGImg, ImgForm.PGImageAx,ImgForm.TriplePanel); + if ImgForm.XBarBtn.Down then begin + if gBGImg.FlipAx then + lS := round(lY-gBGImg.YViewCenter) + else + lS := round(gBGImg.YViewCenter); + DrawXBar ( round(gBGImg.XViewCenter), lS{round(gBGImg.YViewCenter)},ImgForm.PGImageAx); + DrawLabel(ImgForm.PGImageAx, DimToMMx(3),-1,-1); + if gBGImg.KnownAlignment then begin + DrawTextLabel(ImgForm.PGImageAx,gBGImg.MaxChar[2]{'A'},MaxInt,-1); + if gBGImg.Mirror then + DrawTextLabelV(ImgForm.PGImageAx,gBGImg.MaxChar[1]{'R'}) + else + DrawTextLabelV(ImgForm.PGImageAx,gBGImg.MinChar[1]{'L'}); + end; + end; //XBar + + end; + FreeMem ( lBGQuadP); +end; //DrawAxial + +procedure DrawAxialCore (lSlice: integer; var lBGQuadP: RGBQuadp); +var + lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lnOverlay,lOverlay, lX,lY,lS,lStart,lSliceSz: longint; + lBG0Clr,lOverlay0Clr: DWord; +begin + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lS := round(lSlice{ImgForm.ZViewEdit.value}); + lSliceSz := (lX * lY{*lByte}); + lStart := lX*lY*(lS-1); + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0)or (lS < 0) or (lX < 2) or (lStart < 0) or (lSliceSz < 1) or ((lStart+lSliceSz-1) > gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then + exit; + CreateAxial(gMRIcroOverlay[kBGOverlayNum], lStart,lSliceSz, lBGQuadP); + //next: overlays + lnOverlay := 0; + lBG0Clr:= DWord(gMRIcroOverlay[1].LUTinvisible);//just to avoid compiler warning hint - never used... + for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems > 0 then begin + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,lOverlayQuadP); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateAxial(gMRIcroOverlay[lOverlay], lStart,lSliceSz,l2ndOverlayQuadP); + lOverlay0Clr:= DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded + end; //for knOverlay..1 + //Finally: draw overlays on BG + if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); + end; +end; //DrawAxialCore + +procedure SegmentRGBplanes (lSlice,lXVox,lYVox: integer; var lSliceQuadP: RGBQuadp; var lImg3: bytep; isPlanarRGB: boolean); +//analyze RGB saves data as red, green blue planes +var + lLineOffset,lHalfX,lX,lY,lPos,lOutStart,lSliceVox: integer; + lTempQuadP: RGBQuadp; + lRGB: TRGBQuad; +begin + lSliceVox := lXVox*lYVox; + if lSliceVox < 1 then exit; + {lRGB.rgbRed := 255; + lRGB.rgbBlue := 255; + lRGB.rgbGreen := 0;} + + if (ImgForm.FlipLRmenu.checked) and (lXVox > 1) then begin + //showmessage('Flip'); + lHalfX := lXVox div 2; + lLineOffset := 0; + for lY := 1 to lYVox do begin + for lX := 1 to lHalfX do begin + lRGB := lSliceQuadP[lX+lLineOffset]; + lSliceQuadP[lX+lLineOffset] := lSliceQuadP[1+lXVox-lX+lLineOffset]; + lSliceQuadP[1+lXVox-lX+lLineOffset] := lRGB; + end; //for X + lLineOffset := lLineOffset + lXVox; + end;//lY + + end; //mirror + if isPlanarRGB then begin + // + lOutStart := (lSlice-1)*lSliceVox*3; + for lPos := 1 to lSliceVox do begin + lImg3^[lPos+lOutStart] := lSliceQuadP^[lPos].rgbRed; + lImg3^[lPos+lOutStart+lSliceVox] := lSliceQuadP^[lPos].rgbGreen; + lImg3^[lPos+lOutStart+lSliceVox+lSliceVox] := lSliceQuadP^[lPos].rgbBlue; + end; + end else begin + lOutStart := (lSlice-1)*lSliceVox*3; + for lPos := 1 to lSliceVox do begin + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbRed; + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbGreen; + lOutStart := lOutStart + 1; + lImg3^[lOutStart] := lSliceQuadP^[lPos].rgbBlue; + end; + + end; + (*lOutStart := (lSlice-1)*lSliceVox*3; + for lPos := 1 to lSliceVox do begin + lImg3^[lPos+lOutStart] := lSliceQuadP[lPos].rgbRed; + lImg3^[lPos+lOutStart+lSliceVox] := lSliceQuadP[lPos].rgbGreen; + lImg3^[lPos+lOutStart+lSliceVox+lSliceVox] := lSliceQuadP[lPos].rgbBlue; + end; *) +end; + + +procedure CreateAnaRGB; +var + lF: File; + lFilename: string; + lImg3: bytep; + lSliceQuadP: RGBQuadp; + lVolVox,lX,lY,lZ,lI,lnSlice: integer; + lHdr: TNIftiHdr; + isPlanarRGB : boolean; +begin + ImgForm.SaveDialog1.Filter := 'NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.nii)|*.nii|NIfTI (.hdr/.img)|*.hdr|Volume of Interest(.voi)|*.voi|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.DefaultExt := '.hdr'; + + ImgForm.SaveDialog1.Filename := ChangeFileExt(ImgForm.SaveDialog1.Filename, ImgForm.SaveDialog1.DefaultExt); //10102006 + if not ImgForm.SaveDialog1.Execute then exit; + isPlanarRGB := false; + case MessageDlg('Save as modern NIfTI style (RGBRGB..)? Press cancel for Analyze style (RR..RGG..GBB..B)?', mtConfirmation, + [mbYes, mbCancel], 0) of + mrCancel: isPlanarRGB := true; + end; //case + + + lFilename := ImgForm.SaveDialog1.Filename; + lX := round(gBGImg.ScrnDim[1]); + lY := round(gBGImg.ScrnDim[2]); + lZ := round(gBGImg.ScrnDim[3]); + lVolVox := lX*lY*lZ ; + if DiskFreeEx(lFilename) < (lVolVox*3) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + id_Cancel: exit; + end; //case + end; + + getmem(lImg3, lVolVox* 3) ; + //for Sag + lnSlice := lZ; + //fx(lX,lY,lZ); + getmem(lSliceQuadP, lX*lY* sizeof(TRGBQuad)) ; + for lI := 1 to lnSlice do begin //[1+ ((lI-1)*lSliceBytes)] + + DrawAxialCore (lI,lSliceQuadP ); + SegmentRGBplanes (lI,lX,lY,lSliceQuadP,lImg3, isPlanarRGB); + end; + freemem(lSliceQuadP); + //output data + SaveAsVOIorNIFTIcore (lFilename, lImg3, lVolVox, 3,1, gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + freemem(lImg3); +end; + +procedure RefreshActiveImage; +var + lView: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + + exit; + + lView := SelectedImageNum; + case lView of + 3: DrawCor (round(gBGImg.YViewCenter),-1); + 2: DrawSag (round(gBGImg.XViewCenter),-1); + 1: DrawAxial(round(gBGImg.ZViewCenter),-1); + end; +end; //RefreshActiveImage + +procedure ComputeTripleZoom; +//computes axial, coronal and sagittal zoom +//values are SHL 10, so a 1% signal change will be 1024 +//this preserves precision (though at the moment we round to nearest 1%) +label 543,641; +const + kSHval = 1 shl 10; +procedure SetPct(lAfrac,lCfrac,lSfrac: single); +begin + ImgForm.PGImageAx.Tag := trunc(lAfrac*100); + ImgForm.PGImageCor.Tag := trunc(lCfrac*100) ; + ImgForm.PGImageSag.Tag := trunc(lSfrac*100) ; +end; +var + lHpanel,lWpanel,lH,lW: integer; + lPrimaryZoom,l2ndZoom,lZoomw,lZoomh: single; +begin + SetPct(1,1,1); + lHpanel := ImgForm.TriplePanel.ClientHeight-1; + lWpanel := ImgForm.TriplePanel.ClientWidth-1; + //gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + if gBGImg.ZoomPct > 0 then begin + SetPct(gBGImg.ZoomPct/100,gBGImg.ZoomPct/100,gBGImg.ZoomPct/100); + lPrimaryZoom := ImgForm.PGImageAx.Tag/100; + if abs(gBGImg.SliceView) <> kSagView0 then + lW := gBGImg.ScrnDim[1] //Axial and Coronal width is X + else + lW := gBGImg.ScrnDim[2]; //Sagittal width is Y + goto 543; + exit; + end; + if (abs(gBGImg.SliceView) = kAxView0) or(abs(gBGImg.SliceView) = kCoroView0) or(abs(gBGImg.SliceView) = kSagView0) then begin //only show a single slice + if abs(gBGImg.SliceView) <> kAxView0 then + lH := gBGImg.ScrnDim[3] //Coronal and Sagitall height is Z + else + lH := gBGImg.ScrnDim[2]; //Axial height is Y + + if abs(gBGImg.SliceView) <> kSagView0 then + lW := gBGImg.ScrnDim[1] //Axial and Coronal width is X + else + lW := gBGImg.ScrnDim[2]; //Sagittal width is Y + lH := lH+1; + lW := lW + 1; + end else if gBGImg.SingleRow then begin //show 3 slices in row + lW := gBGImg.ScrnDim[2]+gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1]; + lWpanel := lWpanel-2- (2*gBGImg.ImageSeparation); + if gBGImg.ScrnDim[2]>gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2]+1 + else + lH := gBGImg.ScrnDim[3]+1 + end else begin //show three slices, 2 in top row, one in bottom + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2]+4; + lWpanel := lWpanel - 1 - gBGImg.ImageSeparation; + lH := gBGImg.ScrnDim[3]+gBGImg.ScrnDim[2]+4; + lHpanel := lHpanel - 1 - gBGImg.ImageSeparation; + end; + + if (lW<1) or (lH < 1) or (lHpanel < 1) or (lWpanel < 1) then + exit; + lZoomw := lWpanel/ lW; + lZoomh := lHpanel/ lH; + if lZoomw < lZoomh then + lPrimaryZoom := lZoomw + else + lPrimaryZoom := lZoomh; + if (gBGImg.ZoomPct = 0) then begin//nearest integer + lPrimaryZoom := trunc(lPrimaryZoom); + if lPrimaryZoom < 1 then + lPrimaryZoom := 1; + end; + SetPct(lPrimaryZoom,lPrimaryZoom,lPrimaryZoom); +543: //for single slice views, set residual ... + if gBGImg.SliceView = kMultiView then + exit;//All orientations use primary zoom + if gBGImg.SliceView < 0 then begin + l2ndZoom := 0; + goto 641; + end; + lWpanel := lWpanel-2- (2*gBGImg.ImageSeparation); //see if we can fit in two more images horizontally + //note all images are currently set to primary zooom, so we will read PGImageAx + lWpanel := lWPanel - round(lW*lPrimaryZoom); + l2ndZoom := 0; + if lWpanel < 3 then goto 641; + if (abs(gBGImg.SliceView) = kAxView0) then + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2] //CorX + SagY + else if (abs(gBGImg.SliceView) = kCoroView0) then + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2] //AxX + SagY + else //(gBGImg.SliceView = kSagView) + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1];//AxX+CorX + if lW < 1 then //avoid div0 + lZoomw := 0 + else + lZoomw := lWpanel/ lW; + if gBGImg.ScrnDim[2] > gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2] + else + lH := gBGImg.ScrnDim[3]; + if lH < 1 then //avoid div0 + lZoomh := 0 + else + lZoomh := lHpanel/ lH; + if lZoomw < lZoomh then + l2ndZoom := lZoomw + else + l2ndZoom := lZoomh; +641: + if (abs(gBGImg.SliceView) = kAxView0) then + SetPct(lPrimaryZoom,l2ndZoom,l2ndZoom) + else if (abs(gBGImg.SliceView) = kCoroView0) then + SetPct(l2ndZoom,lPrimaryZoom,l2ndZoom) + else //(gBGImg.SliceView = kSagView) + SetPct(l2ndZoom,l2ndZoom,lPrimaryZoom); +end; + +(*function ComputeTripleZoom : single; +var + lHc,lWc,lH,lW: integer; + lZw,lZh: single; +begin + result := 1; + lHc := ImgForm.TriplePanel.ClientHeight-1; + lWc := ImgForm.TriplePanel.ClientWidth-1; + //gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + if gBGImg.ZoomPct > 0 then begin + result := gBGImg.ZoomPct / 100; + exit; + end; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if gBGImg.SliceView <> kAxView then + lH := gBGImg.ScrnDim[3] //Coronal and Sagitall height is Z + else + lH := gBGImg.ScrnDim[2]; //Axial height is Y + + if gBGImg.SliceView <> kSagView then + lW := gBGImg.ScrnDim[1] //Axial and Coronal width is X + else + lW := gBGImg.ScrnDim[2]; //Sagittal width is Y + lH := lH+1; + lW := lW + 1; + end else if gBGImg.SingleRow then begin //show 3 slices in row + lW := gBGImg.ScrnDim[2]+gBGImg.ScrnDim[1]+gBGImg.ScrnDim[1]; + lWc := lWc-2- (2*gBGImg.ImageSeparation); + if gBGImg.ScrnDim[2]>gBGImg.ScrnDim[3] then + lH := gBGImg.ScrnDim[2]+1 + else + lH := gBGImg.ScrnDim[3]+1 + end else begin //show three slices, 2 in top row, one in bottom + lW := gBGImg.ScrnDim[1]+gBGImg.ScrnDim[2]+4; + lWc := lWc - 1 - gBGImg.ImageSeparation; + lH := gBGImg.ScrnDim[3]+gBGImg.ScrnDim[2]+4; + lHc := lHc - 1 - gBGImg.ImageSeparation; + + end; + if (lW<1) or (lH < 1) or (lHc < 1) or (lWc < 1) then + exit; + lZw := lWc/ lW; + lZh := lHc/ lH; + if lZw < lZh then + result := lZw + else + result := lZh; + if (gBGImg.ZoomPct = 0) then begin//nearest integer + result := trunc(result); + if result < 1 then + result := 1; + end; +end;*) + +(*procedure RefreshImages; +//var +// lZoom: single; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + ImgForm.PGImageAx.Width := 0; + ImgForm.PGImageSag.Width := 0; + ImgForm.PGImageCor.Width := 0; + //yui + exit; + end; + gTripleZoom100 := trunc(100*ComputeTripleZoom); + if gTripleZoom100 < 1 then + gTripleZOom100 := 1; + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if (gBGImg.SliceView = kAxView) then begin + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kCoroView) then begin + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kSagView) then begin + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := true; + end; + end else if gBGImg.SingleRow then begin + ImgForm.PGImageCor.Left := round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := 1; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+round(gBGImg.ScrnDim[2]*gTripleZoom100/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1; + ImgForm.PGImageAx.Top := 1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end else begin + + ImgForm.PGImageCor.Left := 1; + ImgForm.PGImageCor.Top := 1; + ImgForm.PGImageSag.Left := round(gBGImg.ScrnDim[1]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageSag.Top := 1; + ImgForm.PGImageAx.Left := 1; + ImgForm.PGImageAx.Top := round(gBGImg.ScrnDim[3]*gTripleZoom100/100)+gBGImg.ImageSeparation+1; + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + + end; + DrawAxial(round(gBGImg.ZViewCenter),-1); + DrawSag (round(gBGImg.XViewCenter),-1); + DrawCor (round(gBGImg.YViewCenter),-1); +end; //RefreshImages*) +procedure ImageLT (lLScroll,lTScroll,lL,lT: integer; var lImage: TImage); +begin + //if (lImage.Left = lL) and (lImage.Top = lT) then + // exit; ImgForm.Caption := 'a'+inttostr(lL)+'x'+inttostr(lT)+'debug'+inttostr(lImage.Left)+'x'+inttostr(lImage.Top); + //if lImage.Left <> lL then + lImage.Left := lL-lLScroll; + //if lImage.Top <> lT then + lImage.Top := lT-lTScroll; +end; + + +procedure RefreshImages; +var + lL,lT: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + ImgForm.PGImageAx.Width := 0; + ImgForm.PGImageSag.Width := 0; + ImgForm.PGImageCor.Width := 0; + exit; + end; + lL := imgForm.Triplepanel.HorzScrollBar.Position; + lT := imgForm.Triplepanel.VertScrollBar.Position; + //imgform.Caption := inttostr(lL)+'x'+inttostr(lT); + ComputeTripleZoom; + //ImgForm.Caption := inttostr(ImgForm.PGImageAx.tag); + ImgForm.PGImageAx.visible := ImgForm.PGImageAx.tag <> 0; + ImgForm.PGImageCor.visible := ImgForm.PGImageCor.tag <> 0; + ImgForm.PGImageSag.visible := ImgForm.PGImageSag.tag <> 0; + if (gBGImg.SliceView = kMultiView) and (not gBGImg.SingleRow) then begin + //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageSag); + end else begin + //Sag is left-most + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + //Next is coronal... + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + //Axial is rightmost + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1,1,ImgForm.PGImageAx); + end; +(* //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end; + + if (gBGImg.SliceView = kAxView) or(gBGImg.SliceView = kCoroView) or(gBGImg.SliceView = kSagView) then begin //only show a single slice + if (gBGImg.SliceView = kAxView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageAx); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kCoroView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := false; + end; + if (gBGImg.SliceView = kSagView) then begin + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + ImgForm.PGImageAx.visible := false; + ImgForm.PGImageCor.visible := false; + ImgForm.PGImageSag.visible := true; + end; + end else if gBGImg.SingleRow then begin + //Sag is left-most + ImageLT(lL,lT,1,1,ImgForm.PGImageSag); + //Next is coronal... + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + //Axial is rightmost + ImageLT(lL,lT,round(gBGImg.ScrnDim[2]*ImgForm.PGImageSag.Tag/100)+round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+gBGImg.ImageSeparation+1,1,ImgForm.PGImageAx); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end else begin + //Coronal is upper-left + ImageLT(lL,lT,1,1,ImgForm.PGImageCor); + //Axial is below Coronal + ImageLT(lL,lT,1,round(gBGImg.ScrnDim[3]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,ImgForm.PGImageAx); + //Sag is to right of coronal + ImageLT(lL,lT,round(gBGImg.ScrnDim[1]*ImgForm.PGImageCor.Tag/100)+gBGImg.ImageSeparation+1,1,ImgForm.PGImageCor); + ImgForm.PGImageAx.visible := true; + ImgForm.PGImageCor.visible := true; + ImgForm.PGImageSag.visible := true; + end; *) + DrawAxial(round(gBGImg.ZViewCenter),-1); + DrawSag (round(gBGImg.XViewCenter),-1); + DrawCor (round(gBGImg.YViewCenter),-1); +end; //RefreshImages + +(*function PNGFilterSize(lFilter: integer; lImage: TImage): integer; +var + lStream: TMemoryStream; + lPNGFilters : TEncodeFilterSet; +begin + result := 0; + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + lStream := TMemoryStream.Create; + try + with TPNGImage.Create do begin + //gPNGSaveFilters := []; + case lFilter of + 1: lPNGFilters := [efSub]; + 2: lPNGFilters := [efUp]; + 3: lPNGFilters := [efAverage]; + 4: lPNGFilters := [efPaeth];//Include(SaveFilters, efPaeth); + else lPNGFilters := [efNone];//[efNone,efSub,efUp,efAverage,efPaeth]; + end; + Filter := lPNGFilters; + //filters(efNone, efSub, efUp, efAverage, efPaeth); + Assign(lImage.Picture.Graphic); + SaveToStream(lStream); + result := (lStream.Size); + end; + finally + lStream.Free; + end; //Stream TRY..FINALLY +end; *) + +(*procedure SaveImgAsPNGBMPCore (lImage: TImage; lFilename: string); +//var + //lPNGFilter,lMinFilter,lMinFilterSz,lFilter,lSz: integer; + //lPNGFilters : TEncodeFilterSet; +begin +// lPNGFilter := 1; + +this code tries to find the smallest PNG file size, but it LEAKS MEMORY +//This leaks memory + lPNGFilter := 5; + if lPNGFilter = 5 then begin //find PNG filter for smallest filesize + lMinFilter := 0; + lMinFilterSz := PNGFilterSize(0,lImage); + for lFilter := 1 to 4 do begin + Application.ProcessMessages; + lSz := PNGFilterSize(lFilter,lImage); + if lSz < lMinFilterSz then begin + lMinFilter := lFilter; + lMinFilterSz := lSz; + end; + end; //Filter 1..4 try each filter + end else + lMinFilter := lPNGFilter; //if look for smallest filter + case lMinFilter of + 1: lPNGFilters := [efSub]; + 2: lPNGFilters := [efUp]; + 3: lPNGFilters := [efAverage]; + 4: lPNGFilters := [efPaeth];//Include(SaveFilters, efPaeth); + else lPNGFilters := [efNone];//[efNone,efSub,efUp,efAverage,efPaeth]; + end; + + with TPNGImage.Create do begin + //filters(efNone, efSub, efUp, efAverage, efPaeth); + Filter := [efAverage]; + Assign(lImage.Picture.Bitmap); + SaveToFile(ChangeFileExt(lFilename,'.png')); + free; + end; + +end; *) + +procedure SaveImgAsPNGBMPCore (lImage: TImage; lFilename: string); +var + PNG: TPNGObject; +begin + PNG := TPNGObject.Create; + try + PNG.Assign(lImage.Picture.Bitmap); //Convert data into png + PNG.SaveToFile(lFilename); + finally + PNG.Free; + end +end; + +procedure SaveImgAsPNGBMP (lImage: TImage); +//var + //lPNGFilter,lMinFilter,lMinFilterSz,lFilter,lSz: integer; + // lPNGFilters : TEncodeFilterSet; +begin + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + + if not ImgForm.SaveDialog1.Execute then exit; + SaveImgAsPNGBMPCore(lImage,ImgForm.SaveDialog1.Filename); +(* ImgForm.SaveDialog1.Filter := 'Bitmap|*.bmp'; + ImgForm.SaveDialog1.DefaultExt := '*.bmp'; +lImage.Picture.Bitmap.SaveToFile(ImgForm.SaveDialog1.Filename);*) + +(* ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + //lImage.Picture.Bitmap.SaveToFile(ImgForm.SaveDialog1.Filename); + lPNGFilter := 5; + if lPNGFilter = 5 then begin //find PNG filter for smallest filesize + lMinFilter := 0; + lMinFilterSz := PNGFilterSize(0,lImage); + for lFilter := 1 to 4 do begin + Application.ProcessMessages; + lSz := PNGFilterSize(lFilter,lImage); + if lSz < lMinFilterSz then begin + lMinFilter := lFilter; + lMinFilterSz := lSz; + end; + end; //Filter 1..4 try each filter + end else + lMinFilter := lPNGFilter; //if look for smallest filter + case lMinFilter of + 1: lPNGFilters := [efSub]; + 2: lPNGFilters := [efUp]; + 3: lPNGFilters := [efAverage]; + 4: lPNGFilters := [efPaeth];//Include(SaveFilters, efPaeth); + else lPNGFilters := [efNone];//[efNone,efSub,efUp,efAverage,efPaeth]; + end; + with TPNGImage.Create do begin + //filters(efNone, efSub, efUp, efAverage, efPaeth); + Filter := lPNGFilters; + Assign(lImage.Picture.Bitmap); + SaveToFile(ChangeFileExt(ImgForm.SaveDialog1.FileName,'.png')); + free; + end; *) +end; +(*procedure SaveImgAsBMP (lImage: TImage); +begin + if (lImage.Picture.Graphic = nil) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) then begin + Showmessage('You need to load an image before you can save it.'); + exit; + end; + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + ImgForm.SaveDialog1.Filter := 'Bitmap|*.bmp'; + ImgForm.SaveDialog1.DefaultExt := '*.bmp'; + if not ImgForm.SaveDialog1.Execute then exit; + lImage.Picture.Bitmap.SaveToFile(ImgForm.SaveDialog1.Filename); +end;*) + + + +procedure UndoVolVOI; +var lTempBuf: ByteP; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems < 1 then exit; + if gBGImg.VOIUndoVolItems <> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then exit; + GetMem(lTempBuf,gBGImg.VOIUndoVolItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,lTempBuf^,gBGImg.VOIUndoVolItems); + Move(gBGImg.VOIUndoVol^,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVolItems); + Move(lTempBuf^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + FreeMem(lTempBuf); +end; + +procedure FreeUndoVol; +begin + if gBGImg.VOIUndoVolItems > 0 then + freemem(gBGImg.VOIUndoVol); + gBGImg.VOIUndoVolItems := 0; + if gBGImg.RenderDepthBufferItems > 0 then + freemem(gBGImg.RenderDepthBuffer); + gBGImg.RenderDepthBufferItems := 0; +end; + +procedure CreateUndoVol; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems < 1 then exit; + gBGImg.VOIUndoSlice := 1; + gBGImg.VOIUndoOrient := 4; + if gBGImg.VOIUndoVolItems <> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then begin + FreeUndoVol; + gBGImg.VOIUndoVolItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + getmem(gBGImg.VOIUndoVol,gBGImg.VOIUndoVolItems); + end; + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); +end; + +function IsVOIOpen: boolean; +begin + result := false; + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems = gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) + and (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0) then + result := true; +end; + +function SameAsBG(var lBGImg: TBGImg; var lHdr: TMRIcroHdr): boolean; +var + lMatrixBG: TMatrix; + i, j: Integer; +begin + result := false; + for i := 1 to 3 do //999 + if lHdr.NIFTIhdr.dim[i] <>lBGImg.ScrnDim[i] then //999 + exit; //999 + lMatrixBG := Matrix3D ( lBGImg.Scrnmm[1],0,0,-lBGImg.Scrnmm[1]*(lBGImg.ScrnOri[1]-1), + 0,lBGImg.Scrnmm[2],0,-lBGImg.Scrnmm[2]*(lBGImg.ScrnOri[2]-1), + 0,0,lBGImg.Scrnmm[3],-lBGImg.Scrnmm[3]*(lBGImg.ScrnOri[3]-1), + 0,0,0,1); + //lMatrixBG := Hdr2Mat(gBGImg.ReorientHdr); + for i := 1 to 3 do + for j := 1 to 4 do begin + //fx(lMatrixBG.matrix[i,j],lHdr.mat.matrix[i,j],i,j); + + if lMatrixBG.matrix[i,j] <> lHdr.Mat.matrix[i,j] then begin + exit; + end; + end; + //fx(11); + //showmessage('same'); + //for i := 1 to 3 do if (lBGIMg.ScrnDim[i])<>lHdr.NIFTIhdr.dim[i] then exit; + result := true; +end; + +procedure EnsureVOIOpen; +var lMaxi: integer; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems = gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then exit; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + Freemem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer); + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[1] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[2] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.dim[3] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[1] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[1]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[2] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[2]; + gMRIcroOverlay[kVOIOverlayNum].NIFTIhdr.pixdim[3] := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.pixdim[3]; + gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + Getmem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + fillchar(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,0); + lMaxI := maxint; + LoadMonochromeLUT(lMaxi,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + if (gBGImg.Resliced) and (not SameAsBG(gBGImg,gMRIcroOverlay[kBGOverlayNum])) then //fv + showmessage('Warning: you are about to draw a region of interest on an resliced image, which can problems with SPM and FSL. Solution: choose Help/Preferences and uncheck ''Reorient images when loading'', then reload your image.'); +end; + +function SelectedImageNum: Integer; +begin + result := gSelectedImageNum; + if (result < 1) or (result > 3) then + result := 1; +end;//SelectedImageNum + +function ComputeInvZoomShl10(lSelectedImageNum: integer; var lImage: TImage): integer; +const + kSHval = 1 shl 10; +var lPGWid,lImgWid: integer; +begin + result := kSHval;//100% + lPGWid := lImage.Picture.Bitmap.Width; + if lImage.Tag > 0 then begin + result := round((100/lImage.Tag)*kShVal); + exit; + end; + if lSelectedImageNum = 2 then + lImgWid := gBGImg.ScrnDim[2] //Sag - horizontal is Y + else + lImgWid := gBGImg.ScrnDim[1]; //cor and ax - horizontal is X + If (lPGWid < 1) or (lImgWid < 1) then exit; + result := round(lImgWid/lPGWid* kShVal); +end; + +function ComputeZoomPct(lSelectedImageNum: integer; var lImage: TImage): integer; +var lPGWid,lImgWid: integer; +begin + result := 100;//100% + lPGWid := lImage.Picture.Bitmap.Width; + if lImage.Tag > 0 then begin + result := lImage.Tag; + exit; + end; + if lSelectedImageNum = 2 then + lImgWid := gBGImg.ScrnDim[2] //Sag - horizontal is Y + else + lImgWid := gBGImg.ScrnDim[1]; //cor and ax - horizontal is X + If (lPGWid < 1) or (lImgWid < 1) then exit; + result := round(lPGWid/lImgWid* 100); +end; //ComputeZoomPct + +function ImageZoomPct( var lImage: TImage): integer; +begin + result := ComputeZoomPct(SelectedImageNum,lImage); +end; + +procedure DrawGrid (var lImage: TImage); +var lSpacing,lL,lW,lH,lZoomPct: integer; +begin + lZoomPct := ImageZoomPct(lImage); + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + lZoomPct := lZoomPct div 100; + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + lImage.Canvas.Pen.Width := 1;//gBGImg.XBarThick; + lSpacing := -1; + for lL := 1 to (lW div lZoomPct) do begin + lSpacing := lSpacing+lZoomPct; + lImage.Canvas.MoveTo((lSpacing),0); + lImage.Canvas.LineTo((lSpacing),lH); + end; + lSpacing := -1; + for lL := 1 to (lH div lZoomPct) do begin + lSpacing := lSpacing+lZoomPct; + lImage.Canvas.MoveTo(0,lSpacing); + lImage.Canvas.LineTo(lW,lSpacing); + end; + +end; + +procedure DrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +var lL,lT,lW,lH,lZoomPct: integer; +lOffset: single; +begin + lZoomPct := ImageZoomPct(lImage); + //amx - must match XYscrn2Img and DrawXBar + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + //lL := lHorPos-1; + if lZoomPct > 100 then lOffset := 0.5 else + lOffset := 0; + (*if (lZoomPct > 199) and ((lZoomPct mod 100) = 0) then begin + drawgrid(lImage); + exit; + end;*) + lL := round((lHorPos-lOffset) * lZoomPct/100)-1;// div 100; //-1 as indexed from zero, 0.5 for middle of slice + lT := lH-round((lVerPos-lOffset) * lZoomPct/100);// div 100; + //ImgForm.Caption := inttostr(lZoomPct); + //lL := (lHorPos * lZoomPct) div 100; + //lT := (lVerPos * lZoomPct) div 100; + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + //lImage.Canvas.Pen.Color:=$03FF0000; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + //next horizontal lines + lImage.Canvas.MoveTo(0,lT); + lImage.Canvas.LineTo(lL-gBGImg.XBarGap,lT); + lImage.Canvas.MoveTo(lL+gBGImg.XBarGap,lT); + lImage.Canvas.LineTo(lW,lT); + //next vertical lines + lImage.Canvas.MoveTo(lL,0); + lImage.Canvas.LineTo(lL,lT-gBGImg.XBarGap); + lImage.Canvas.MoveTo(lL,lT+gBGImg.XBarGap); + lImage.Canvas.LineTo(lL,lH); +end; //Proc DrawXBar + +procedure ScaleScrn2BMP (var lX, lY: integer;lImage: TImage); +var lScale: single; +begin + if (lImage.Height = 0) or (lImage.Width = 0) then exit; + lScale := lImage.Picture.Bitmap.Height /lImage.Height; + lX := round(lX * lScale); + lY := round(lY * lScale); +end; + +function Scrn2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +var lRange,lMin,lMax: single; +begin + lMin := lHdr.WindowScaledMin; + lMax := lHdr.WindowScaledMax; + if lMin > lMax then begin + lRange := lMin; + lMin := lMax; + lMax := lRange; + end; + lRange := lMax - lMin; + result := lMin+(lRaw/255*lRange); +end; + +procedure SaveMRIcroROI (lFilename: string); +const + kMax12bit = 4095; + kMax16bit = (256*256)-1; + kMax20bit = (16*256*256)-1; + k20v16bit = kMax20bit - kMax16bit; + kMaxRuns = 10000; + kMaxFile = 65536; +var lFilePos,lZPos,lZ,lSliceSz,lSliceOffset,lPrevVoxel,lVoxel,lRun,lnRuns,lSlicePos: integer; + lRunStartRA,lRunLengthRA : array [1..kMaxRuns] of longint; + lOutputRA: array [1..kMaxFile] of word; + lF: File; + lBigFormat: boolean; +begin + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + if lSliceSz > 65535 then + lBigFormat := true + else + lBigFormat := false; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems<> (lSLiceSz*lZ) then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + lSliceOffset := 0; + lFilePos := 0; + for lZPos := 1 to lZ do begin + lnRuns := 0; + lPrevVoxel := 0; + for lSlicePos := 1 to lSliceSz do begin + lVoxel := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lSlicePos+lSliceOffset]; + if lVoxel > 1 then lVoxel := 1; + if lVoxel <> lPrevVoxel then begin //start or end run + lPrevVoxel := lVoxel; + if lnRuns = kMaxRuns then + Showmessage('Error: To many runs...') + else if lVoxel = 1 then begin //start new run + inc(lnRuns); + lRunStartRA[lnRuns] := lSlicePos; + + end else begin + lRunLengthRA[lnRuns] := lSlicePos-lRunStartRA[lnRuns]; + end; + end; //if start or end + if (lVoxel > 0) and ((lSlicePos-lRunStartRA[lnRuns])>4090) then begin //end this run, begin new + lRunLengthRA[lnRuns] := lSlicePos-lRunStartRA[lnRuns]+1; + lPrevVoxel := 0; + end; //run >4090 + end; //for each voxel in slice + if lPrevVoxel = 1 then + lRunLengthRA[lnRuns] := lSliceSz-lRunStartRA[lnRuns]+1; + lSliceOffset := lSliceOffset+lSliceSz; + if lnRuns > 0 then begin + inc(lFilePos); + lOutputRA[lFilePos] := lZPos; //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := 2*(lnRuns+1); //words to store this slice: 2 per run, plus 2 for slice number and size + if lBigFormat then begin + for lRun := 1 to lnRuns do begin + inc(lFilePos); + lOutputRA[lFilePos] := (lRunStartRA[lRun] and kMax16bit); //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := (lRunLengthRA[lRun] and kMax12bit)+ ((lRunStartRA[lRun] and k20v16bit)shr 4) ; //record slice number + end; + end else begin + for lRun := 1 to lnRuns do begin + inc(lFilePos); + lOutputRA[lFilePos] := lRunStartRA[lRun]; //record slice number + inc(lFilePos); + lOutputRA[lFilePos] := lRunLengthRA[lRun]; //record slice number + end;//for each run + end; //small format + end; //if data on this slice + end; //for lZ + if lFilePos = 0 then begin + Showmessage('No VOIs detected - unable to create blank MRIcro ROI.'); + exit; + end; + if lBigFormat then + lOutputRA[1] := lOutputRA[1]+ 32768; //set MSB to 1 to denote this file uses 12/20 bytes + Filemode := 1; + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lFilePos*2); + BlockWrite(lF,lOutputRA, 1 {, NumWritten}); + CloseFile(lF); + Filemode := 2; +end; + +procedure SaveAsVOIorNIFTIinnercore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +var + lHdr: TNIFTIhdr; + lBuff: ByteP; + lF: File; + lXmm,lYmm,lZmm: single; + lUnCompressedFilename,lExt: string; + lC,lFSize: integer; + lMat: TMatrix; +begin + lExt := UpCaseExt(lFileName); + move(lNiftiHdr,lHdr,sizeof(lHdr)); + lHdr.regular :='r'; + if (lExt='.VOI') then begin + lHdr.intent_code := kNIFTI_INTENT_NONE; + lHdr.intent_name[1] := 'B';//Binary + lHdr.scl_slope := 1/kVOI8bit; + lHdr.scl_inter := 0; + end; + if lnVol > 1 then begin + lHdr.dim[0] := 4;//3D july2006 + lHdr.dim[4] := lnVol;//3D july2006 + end else begin + lHdr.dim[0] := 3;//3D july2006 + lHdr.dim[4] := 1;//3D july2006 + end; + if gBGImg.Resliced then begin + lHdr.dim[1] := gBGImg.ScrnDim[1]; + lHdr.dim[2] := gBGImg.ScrnDim[2]; + lHdr.dim[3] := gBGImg.ScrnDim[3]; + lHdr.pixdim[1] := gBGImg.ScrnMM[1]; //Apr07 + lHdr.pixdim[2] := gBGImg.ScrnMM[2]; //Apr07 + lHdr.pixdim[3] := gBGImg.ScrnMM[3]; //Apr07 + lHdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT; //10102006 + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + lHdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; //May07 + lMat:= Matrix3D ( gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3], + 0,0,0,1); + nifti_mat44_to_quatern( lMat,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lXmm,lYmm,lZmm,lHdr.pixdim[0]); + end else begin + //Apr07 - for unresliced data, use raw header for data + end; + + case lImgBufferBPP of + 4: begin + lHdr.bitpix := 32; + lHdr.datatype := kDT_FLOAT;//note 32-bit integers saved internally as 32-bit float + end; + 3: begin + lHdr.bitpix := 24; + lHdr.datatype := kDT_RGB; + end; + 2: begin + lHdr.bitpix := 16; + lHdr.datatype := kDT_SIGNED_SHORT; + end; + 1: begin + lHdr.bitpix := 8; + lHdr.datatype := kDT_UNSIGNED_CHAR; + //lHdr.scl_inter := lHdr.WindowScaledMin; + //lHdr.scl_slope := (lHdr.WindowScaledMax-lHdr.WindowScaledMin) /255; + end; + else begin + showmessage('Error: Unsupported bytes per voxel: '+inttostr(lImgBufferBPP)); + exit; + end; + end; + if (lExt='.IMG') or (lExt ='.HDR') then begin + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + lHdr.vox_offset := 0; + Filemode := 1; + //next write header data as .hdr + lFilename := changeFileExt(lFilename,'.hdr'); + AssignFile(lF, lFileName); + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lHdr, 1); + CloseFile(lF); + //next write image data as .img + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lImgBufferItems*lnVOL*lImgBufferBPP); + BlockWrite(lF,lImgBuffer^,1); + CloseFile(lF); + Filemode := 2; + exit;//no need to append data + end; //separate header + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lHdr.vox_offset := kImgOffset;//352 bytes + lFSize := kImgOffset+(lImgBufferItems*lnVOl*lImgBufferBPP); + getmem(lBuff,lFSize); + move(lHdr,lBuff^,sizeof(lHdr)); + //Next: NIfTI 1.1 requires bytes 349..352 set to zero when no XML information + lC := kImgOffset; + lBuff[lC-3] := 0; + lBuff[lC-2] := 0; + lBuff[lC-1] := 0; + lBuff[lC] := 0; + lC := kImgOffset+1; + move(lImgBuffer^,lBuff[lC],lImgBufferItems*lnVol*lImgBufferBPP); + if (lExt='.NII') then begin + Filemode := 1; + AssignFile(lF, lFileName); + Rewrite(lF,lFSize); + BlockWrite(lF,lBuff^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //uncompressed + lUnCompressedFilename := changefileextx(lFilename,'.nii'); + //showmessage(lFilename+' '+lUnCompressedFilename); + GZipBuffer(lUnCompressedFilename,lFilename,lBuff,lFSize,false); + freemem(lBuff); +end; + +procedure SaveAsVOIorNIFTIcoreOrtho (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +var + lISize: integer; + lTempHdr: TMRIcroHdr; +begin + if not gBGImg.UseReorientHdr then + exit; + lTempHdr.NIFTIhdr := lNIftIHdr; + lISize := (lImgBufferItems*lImgBufferBPP); + GetMem(lTempHdr.ImgBufferUnaligned ,lISize + 16); + lTempHdr.ImgBuffer := ByteP($fffffff0 and (integer(lTempHdr.ImgBufferUnaligned)+15)); + lTempHdr.ImgBufferItems := lImgBufferItems; + lTempHdr.ImgBufferBPP := lImgBufferBPP; + move(lImgBuffer^,lTempHdr.ImgBuffer^,lISize); + Reslice_Img_To_Unaligned (gBGImg.ReorientHdr, lTempHdr,true{lBGImg.OverlaySmooth} ); + SaveAsVOIorNIFTIinnercore (lFilename, lTempHdr.ImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lTempHdr.NIFTIhdr); + //restore orientation + //lNiftiHdr := lTempHdr.NIFtiHdr; + //reslease memory + FreeMem(lTempHdr.ImgBufferUnaligned); +end; + + procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +begin + //10/2007 - scl_slope; + //lExt := UpCaseExt(lFileName); + if DiskFreeEx(lFilename) < (kImgOffset+(lImgBufferItems*lImgBufferBPP)) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + id_Cancel: exit; + end; //case + end; + if FileExistsEX(lFileName) then begin + case MessageDlg('Overwrite the file named '+lFileName+'?', mtConfirmation, + [mbYes, mbCancel], 0) of + id_Cancel: exit; + end; //case + end; //file exists + if not gBGImg.UseReorientHdr then + SaveAsVOIorNIFTIinnercore (lFilename, lImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lNiftiHdr) + else + SaveAsVOIorNIFTIcoreOrtho (lFilename, lImgBuffer,lImgBufferItems, lImgBufferBPP,lnVol, lNiftiHdr); +end; + +(*procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; var lNiftiHdr: TNIFTIHdr); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +var + lHdr: TNIFTIhdr; + lBuff: ByteP; + lF: File; + lXmm,lYmm,lZmm: single; + lUnCompressedFilename,lExt: string; + lC,lFSize: integer; + lMat: TMatrix; +begin + //10/2007 - scl_slope; + lExt := UpCaseExt(lFileName); + if DiskFreeEx(lFilename) < (kImgOffset+(lImgBufferItems*lImgBufferBPP)) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + id_Cancel: exit; + end; //case + end; + if FileExistsEX(lFileName) then begin + case MessageDlg('Overwrite the file named '+lFileName+'?', mtConfirmation, + [mbYes, mbCancel], 0) of + id_Cancel: exit; + end; //case + end; //file exists + //if gBGImg.UseReorientHdr then + // Reslice_Img_To_Unaligned(gBGImg.ReorientHdr,//vcx + + move(lNiftiHdr,lHdr,sizeof(lHdr)); + lHdr.regular :='r'; + if (lExt='.VOI') then begin + lHdr.intent_name[1] := 'B';//Binary + lHdr.scl_slope := 1/kVOI8bit; + lHdr.scl_inter := 0; + end; + if lnVol > 1 then begin + lHdr.dim[0] := 4;//3D july2006 + lHdr.dim[4] := lnVol;//3D july2006 + end else begin + lHdr.dim[0] := 3;//3D july2006 + lHdr.dim[4] := 1;//3D july2006 + end; + if gBGImg.Resliced then begin + lHdr.dim[1] := gBGImg.ScrnDim[1]; + lHdr.dim[2] := gBGImg.ScrnDim[2]; + lHdr.dim[3] := gBGImg.ScrnDim[3]; + lHdr.pixdim[1] := gBGImg.ScrnMM[1]; //Apr07 + lHdr.pixdim[2] := gBGImg.ScrnMM[2]; //Apr07 + lHdr.pixdim[3] := gBGImg.ScrnMM[3]; //Apr07 + lHdr.sform_code := kNIFTI_XFORM_SCANNER_ANAT; //10102006 + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + lHdr.qform_code := kNIFTI_XFORM_SCANNER_ANAT; //May07 + lMat:= Matrix3D ( gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3], + 0,0,0,1); + nifti_mat44_to_quatern( lMat,lHdr.quatern_b,lHdr.quatern_c,lHdr.quatern_d, + lHdr.qoffset_x,lHdr.qoffset_y,lHdr.qoffset_z, + lXmm,lYmm,lZmm,lHdr.pixdim[0]); + end else begin + //Apr07 - for unresliced data, use raw header for data + end; + + case lImgBufferBPP of + 4: begin + lHdr.bitpix := 32; + lHdr.datatype := kDT_FLOAT;//note 32-bit integers saved internally as 32-bit float + end; + 3: begin + lHdr.bitpix := 24; + lHdr.datatype := kDT_RGB; + end; + 2: begin + lHdr.bitpix := 16; + lHdr.datatype := kDT_SIGNED_SHORT; + end; + 1: begin + lHdr.bitpix := 8; + lHdr.datatype := kDT_UNSIGNED_CHAR; + //lHdr.scl_inter := lHdr.WindowScaledMin; + //lHdr.scl_slope := (lHdr.WindowScaledMax-lHdr.WindowScaledMin) /255; + end; + else begin + showmessage('Error: Unsupported bytes per voxel: '+inttostr(lImgBufferBPP)); + exit; + end; + end; + if (lExt='.IMG') or (lExt ='.HDR') then begin + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + lHdr.vox_offset := 0; + Filemode := 1; + //next write header data as .hdr + lFilename := changeFileExt(lFilename,'.hdr'); + AssignFile(lF, lFileName); + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lHdr, 1); + CloseFile(lF); + //next write image data as .img + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lImgBufferItems*lImgBufferBPP); + BlockWrite(lF,lImgBuffer^,1); + CloseFile(lF); + Filemode := 2; + exit;//no need to append data + end; //separate header + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lHdr.vox_offset := kImgOffset;//352 bytes + lFSize := kImgOffset+(lImgBufferItems*lImgBufferBPP); + getmem(lBuff,lFSize); + move(lHdr,lBuff^,sizeof(lHdr)); + //Next: NIfTI 1.1 requires bytes 349..352 set to zero when no XML information + lC := kImgOffset; + lBuff[lC-3] := 0; + lBuff[lC-2] := 0; + lBuff[lC-1] := 0; + lBuff[lC] := 0; + lC := kImgOffset+1; + move(lImgBuffer^,lBuff[lC],lImgBufferItems*lImgBufferBPP); + if (lExt='.NII') then begin + Filemode := 1; + AssignFile(lF, lFileName); + Rewrite(lF,lFSize); + BlockWrite(lF,lBuff^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //uncompressed + lUnCompressedFilename := changefileext(lFilename,'.nii'); + GZipBuffer(lUnCompressedFilename,lFilename,lBuff,lFSize,false); + freemem(lBuff); +end;*) + + +function ExtX (lItem: integer): string; +var + lLen,lPos,lI,lDelim,lEnd : Integer; + lFilt: string; +begin + lFilt := ImgForm.SaveDialog1.Filter; + result := ''; + //There is one | before each item, and one after + //therefore, the 2nd item will be preceded by 3 |s + lDelim := lItem * 2 - 1; + lI := 0; + lLen := length(lFilt); + lPos := 1; + while (lI < lDelim) and (lPos <= lLen) do begin + if lFilt[lPos] = '|' then + inc(lI); + inc(lPos); + end; + if lPos >= lLen then + exit; + while (lPos <= lLen) and (lFilt[lPos] <> '|') do begin + if lFilt[lPos] <> '*' then + result := result + lFilt[lPos]; + inc(lPos); + end; +end; + +procedure SaveAsVOIorNIFTI (var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; DefaultFormatVOI: boolean; var lNiftiHdr: TNIFTIHdr; lDefFilename: string); +const + kImgOffset = 352; //header is 348 bytes, but 352 is diisible by 8... +var + lFileName,lExt: string; +begin + if DefaultFormatVOI then begin + ImgForm.SaveDialog1.Filter := 'Volume of Interest(.voi)|*.voi|NIfTI (.nii)|*.nii|NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.hdr/.img)|*.hdr|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.DefaultExt := '.voi'; + end else begin + ImgForm.SaveDialog1.Filter := 'NIfTI compressed (.nii.gz)|*.nii.gz|NIfTI (.nii)|*.nii|NIfTI (.hdr/.img)|*.hdr|Volume of Interest(.voi)|*.voi|MRIcro (.roi)|*.roi'; + ImgForm.SaveDialog1.DefaultExt := '.nii.gz'; + end; + if lDefFilename <> '' then + ImgForm.SaveDialog1.Filename := ParseFilename(lDefFilename) + else if HdrForm.OpenHdrDlg.Filename <> '' then + ImgForm.SaveDialog1.Filename := HdrForm.OpenHdrDlg.Filename + else if gMRIcroOverlay[kBGOverlayNum].HdrFileName <> '' then + ImgForm.SaveDialog1.Filename := gMRIcroOverlay[kBGOverlayNum].HdrFileName + else + ImgForm.SaveDialog1.Filename := 'image'; + ImgForm.SaveDialog1.Filename := ChangeFileExt(ImgForm.SaveDialog1.Filename, ImgForm.SaveDialog1.DefaultExt); //10102006 + ImgForm.SetSaveDlgFileExt; + if not ImgForm.SaveDialog1.Execute then exit; + lFileName := ImgForm.SaveDialog1.Filename; + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if (lExt='.ROI') then begin + Showmessage('Note that the MRIcro ROI format does not save image dimensions. You may want to save a copy as VOI format.'); + SaveMRIcroROI (lFileName); + exit; + end; + SaveAsVOIorNIFTIcore (lFilename,lImgBuffer, lImgBufferItems, lImgBufferBPP,lnVol,lNiftiHdr); +end; + +procedure SetSubmenuWithTag (var lRootMenu: TMenuItem; lTag: Integer); +var + lCount,lSubMenu: integer; +begin + lCount := lRootMenu.Count; + if lCount < 1 then exit; + for lSubMenu := (lCount-1) downto 0 do + if lRootmenu.Items[lSubmenu].Tag = lTag then begin + lRootmenu.Items[lSubmenu].Checked := true; + exit + end; + //will exit unless tag not found: default select 1st item + lRootmenu.Items[0].Checked := true; + //While Recent1.Count > 0 do Recent1.Items[0].Free; +end; + +function MaxDim (lX,lY,lZ: integer): integer; //returns largest of 3 +begin + result := lX; + if lY > result then + result := lY; + if lZ > result then + result := lZ; +end; + + +procedure AlphaBlend32(lBGQuad,lOverlayQuad : RGBQuadp; lBG0Clr,lOverlay0Clr: DWord; lSlicePixels, lOverlayTransPct: integer); // 630 +var + lBGwt,lOverlaywt,lPixel,lPos:integer; + lBGp,lOverlayP: ByteP; + lBGDWordp,lOverlayDWordp : DWordp; +begin + lBGp := ByteP(lBGQuad); + lOverlayP := ByteP(lOverlayQuad); + lOverlayDWordp := DWordp(lOverlayQuad); + lBGDWordp := DWordp(lBGQuad); + //next: transparency weighting + lBGwt := round((lOverlayTransPct)/100 * 1024); + lOverlaywt := round((100-lOverlayTransPct)/100 * 1024); + //next redraw each pixel + lPos := 1; + if lOverlayTransPct > -1 then begin + for lPixel := 1 to lSlicePixels do begin + if lOverlayDWordp[lPixel] = lOverlay0Clr then + inc(lPos,4) + else if lBGDWordp[lPixel] = lBG0Clr then begin + lBGDWordp[lPixel] := lOverlayDWordp[lPixel]; + inc(lPos,4); + end else begin + lBGp[lPos] := (lBGp[lPos]*lBGwt+lOverlayP[lPos]*lOverlaywt) shr 10; + inc(lPos); + lBGp[lPos] := (lBGp[lPos]*lBGwt+lOverlayP[lPos]*lOverlaywt) shr 10; + inc(lPos); + lBGp[lPos] := (lBGp[lPos]*lBGwt+lOverlayP[lPos]*lOverlaywt) shr 10; + inc(lPos); + inc(lPos); + end; + end; + end else begin + for lPixel := 1 to lSlicePixels do begin + if lOverlayDWordp[lPixel] = lOverlay0Clr then + inc(lPos,4) + else if lBGDWordp[lPixel] = lBG0Clr then begin + lBGDWordp[lPixel] := lOverlayDWordp[lPixel]; + inc(lPos,4); + end else begin + if lOverlayP[lPos] > lBGp[lPos] then lBGp[lPos] := lOverlayP[lPos]; + inc(lPos); + if lOverlayP[lPos] > lBGp[lPos] then lBGp[lPos] := lOverlayP[lPos]; + inc(lPos); + if lOverlayP[lPos] > lBGp[lPos] then lBGp[lPos] := lOverlayP[lPos]; + inc(lPos); + inc(lPos); + end; + end; + end; +end; + +function Raw2ScaledIntensity (lHdr: TMRIcroHdr; lRaw: single): single; +begin + if lHdr.NIFTIhdr.scl_slope = 0 then + result := lRaw+lHdr.NIFTIhdr.scl_inter + else + result := (lRaw * lHdr.NIFTIhdr.scl_slope)+lHdr.NIFTIhdr.scl_inter; +end; + +function Scaled2RawIntensity (lHdr: TMRIcroHdr; lScaled: single): single; +begin + if lHdr.NIFTIhdr.scl_slope = 0 then + result := (lScaled)-lHdr.NIFTIhdr.scl_inter + else + result := (lScaled-lHdr.NIFTIhdr.scl_inter) / lHdr.NIFTIhdr.scl_slope; +end; + +procedure FilterLUT (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lMin, lMax: integer); //lLUT: 0=gray,1=red,2=green,3=blue +var + lInc: integer; + lRGB : TRGBQuad; +begin + for lInc := 0 to 255 do + lHdr.LUT[lInc] := lBackgroundImg.BackupLUT[lInc]; + if (lMin < 0) or (lMin > 255) or (lMax < 0) or (lMax > 255) then + exit; + if lMin > lMax then begin + lInc := lMin; + lMin := lMax; + lMax := lInc; + end; //swap lMin/lMax + lRGB.rgbRed := (lBackgroundImg.XBarClr and 255) ; + lRGB.rgbGreen := ((lBackgroundImg.XBarClr shr 8) and 255) ;// and 65280; + lRGB.rgbBlue := ((lBackgroundImg.XBarClr shr 16) and 255) ;//and 16711680; + lRGB.rgbReserved := kLUTalpha; + for lInc := lMin to lMax do + lHdr.LUT[lInc] := lRGB; +end; + +procedure LoadLabelsOld(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); +const +kMaxLabel = 255; +var lLUTname: string; + lInc: integer; + lTextFile: TextFile; + lStr1: string; + lCh: char; +begin + SetLength(lBackgroundImg.LabelRA,kMaxLabel+1); //+1 as indexed from 0 + for lInc := 0 to High(lBackgroundImg.LabelRA) do + lBackgroundImg.LabelRA[lInc] := inttostr(lInc); + lLUTname := changefileext(lHdr.HdrFileName,'.txt'); + if not Fileexists(lLUTname) then begin + lLUTname := ParseFileName(lHdr.HdrFileName)+'.txt'; //file.nii.gz -> file.txt + if not Fileexists(lLUTname) then + exit; + end; + assignfile(lTextFile,lLUTname); + lHdr.UsesLabels := true; + Filemode := 0; + reset(lTextFile); + while not EOF(lTextFile) do begin + lStr1 := ''; + repeat + read(lTextFile,lCh); + if (lCh >= '0') and (lCh <= '9') then + lStr1 := lStr1 + lCh; + until (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) or (((lCh=kTab)or (lCh=' ')) and (length(lStr1)>0)); + if (length(lStr1) > 0) and (not EOF(lTextFile)) then begin + linc := strtoint(lStr1); + if (lInc >= 0) and (lInc <= kMaxLabel) then begin + lStr1 := ''; + repeat + read(lTextFile,lCh); + if (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab) or (lCh=' ')} then + else + lStr1 := lStr1 + lCh; + until (EOF(lTextFile)) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab)or (lCh=' ')}; + //showmessage(inttostr(lInc)+'x'+lStr1); + lBackgroundImg.LabelRA[lInc] := lStr1; + end; + + end; + end; + CloseFile(lTextFile); + Filemode := 2; +end; + + +procedure LoadMonochromeLUT (var lLUT: integer; var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); //lLUT: 0=gray,1=red,2=green,3=blue +var + lR,lG,lB,lInc: integer; +begin + case lLUT of + 1: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := 0; + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + end;//red + 2: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := lInc; + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + end;//blue + 3: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := 0; + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + end;//green + 4: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := 0; + lHdr.LUT[lInc].rgbBlue := lInc; + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + end;//r+b=violet + 5: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := 0; + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + end;//red + green = yellow + 6: + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := 0; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := lINc; + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + end;//green+blue = cyan + maxint: begin// + lHdr.LUT[0].rgbRed := 0; + lHdr.LUT[0].rgbGreen := 0; + lHdr.LUT[0].rgbBlue := 0; + lHdr.LUT[0].rgbReserved := kLUTalpha; + lR := (lBackgroundImg.VOIClr and 255) ; + lG := ((lBackgroundImg.VOIClr shr 8) and 255) ;// and 65280; + lB:= ((lBackgroundImg.VOIClr shr 16) and 255) ;//and 16711680; + for lInc := 1 to kVOI8bit do begin + lHdr.LUT[lInc].rgbRed := round((lInc*lR) div kVOI8bit); + lHdr.LUT[lInc].rgbGreen := round((lInc*lG) div kVOI8bit); + lHdr.LUT[lInc].rgbBlue := round((lInc*lB) div kVOI8bit); + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + end;//green+blue = cyan + end; + else begin + lLUT := 0; + for lInc := 0 to 255 do begin + lHdr.LUT[lInc].rgbRed := lInc; + lHdr.LUT[lInc].rgbGreen := lInc; + lHdr.LUT[lInc].rgbBlue := lInc; + lHdr.LUT[lInc].rgbReserved := kLUTalpha; + end;//for gray + end//else... gray + end; + lHdr.LUTinvisible := DWord(lHdr.LUT[0]); +end; + +procedure LUTbias (var lHdr: TMRIcroHdr); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick +Graphics Gems IV, p379-382, April 1994 } +var + lIndex,lBias: integer; + lA,lT: single; + lLUT: array[0..255] of TRGBQuad; +begin +//if gBias = 0.5 then exit; + lA := 0.2; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lBias := round(255*(lt/((1/la-2)*(1-lt)+1)) ); + lLUT[lIndex] := lHdr.LUT[(lBias)]; + //lHdr.LUT[lIndex].rgbReserved := kLUTalpha; + end; + for lIndex := 1 to 254 do + lHdr.LUT[lIndex] := lLUT[lIndex]; +end; + +procedure LoadColorScheme(lStr: string; var lHdr: TMRIcroHdr); +const UNIXeoln = chr(10); +var + lF: textfile; + lBuff: bytep0; + lFData: file; + lCh: char; + lNumStr: String; + lZ : integer; + lByte,lIndex: byte; + lType,lIndx,lLong,lR,lG: boolean; +procedure ResetBools; //nested +begin + lType := false; + lIndx := false; + lR := false; + lG := false; + lNumStr := ''; +end; //nested proc ResetBools +begin //proc LoadColorScheme + if not fileexistsex(lStr) then exit; + lZ := FSize(lStr); + if (lZ =768) or (lZ = 800) or (lZ=970) then begin + //binary LUT + assignfile(lFdata,lStr); + Filemode := 0; + reset(lFdata,1); + seek(lFData,lZ-768); + GetMem( lBuff, 768); + BlockRead(lFdata, lBuff^, 768); + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := lBuff[lZ]; + lHdr.LUT[lZ].rgbGreen := lBuff[lZ+256]; + lHdr.LUT[lZ].rgbBlue := lBuff[lZ+512]; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + closefile(lFdata); + Filemode := 2; + (* + LUTbias(lHdr); + for lZ := 0 to 255 do begin + lBuff[lZ]:= lHdr.LUT[lZ].rgbRed ; + lBuff[lZ+256]:= lHdr.LUT[lZ].rgbGreen; + lBuff[lZ+512]:= lHdr.LUT[lZ].rgbBlue; + end; + AssignFile(lFData, 'C:\pink2.lut'); + Rewrite(lFData,1); + BlockWrite(lFdata, lBuff^, 768); + CloseFile(lFData); (**) + + freemem(lBuff); + //LUTBIas (lHdr); + lHdr.LUTinvisible := DWord(lHdr.LUT[0]); + + + exit; + end; + //Text LUT + assignfile(lF,lStr); + Filemode := 0; + reset(lF); + lLong := false; + lIndex := 0; + ResetBools; + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := 0; + lHdr.LUT[lZ].rgbGreen := 0; + lHdr.LUT[lZ].rgbBlue := 0; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + while not EOF(lF) do begin + read(lF,lCh); + if lCh = '*' then //comment character + while (not EOF(lF)) and (lCh <> kCR) and (lCh <> UNIXeoln) do + read(lF,lCh); + if (lCh = 'L') or (lCh = 'l') then begin + lType := true; + lLong := true; + end; //'l' + if (lCh = 's') or (lCh = 'S') then begin + lType := true; + lLong := false; + end; //'s' + if lCh in ['0'..'9'] then + lNumStr := lNumStr + lCh; + if ((not(lCh in ['0'..'9'])) or (EOF(lF)) ) and (length(lNumStr) > 0) then begin //not a number = space??? try to read number string + if not lIndx then begin + lIndex := strtoint(lNumStr); + lIndx := true; + end else begin //not index + if lLong then + lByte := trunc(strtoint(lNumStr) / 256) + else + lByte := strtoint(lNumStr); + if not lR then begin + lHdr.LUT[lIndex].rgbRed := lByte; + lR := true; + end else if not lG then begin + lHdr.LUT[lIndex].rgbGreen := lByte; + lG := true; + end else {final value is blue} begin + lHdr.LUT[lIndex].rgbBlue := lByte; + ResetBools; + end; + end; + lNumStr := ''; + end; + end; //not eof + CloseFile(lF); + Filemode := 2; + //LUTBIas (lHdr); + lHdr.LUTinvisible := DWord(lHdr.LUT[0]); +end; //Proc LoadColorScheme + +procedure InitImgMemory(var lHdr: TMRIcroHdr); +begin + with lHdr do begin + RenderBufferItems := 0; + ScrnBufferItems := 0; + ImgBufferItems := 0; + end; +end; +procedure FreeImgMemory(var lHdr: TMRIcroHdr); +begin + + with lHdr do begin + {if ScrnBuffer <> nil then freemem(ScrnBuffer); + if ImgBuffer<> nil then freemem(ImgBufferUnaligned); + if RenderBuffer<> nil then freemem(RenderBuffer); + if RenderDepthBuffer<> nil then freemem(RenderDepthBuffer);{} + {lstr := ''; + if ScrnBufferItems > 0 then lStr := 'scrn'; + if ImgBufferItems > 0 then lStr := lStr + ' img'; + if RenderBufferItems > 0 then lStr := lStr + ' rend'; + if lStr <> '' then showmessage(lStr);} + if ScrnBufferItems > 0 then freemem(ScrnBuffer); + if ImgBufferItems > 0 then freemem(ImgBufferUnaligned); + if RenderBufferItems > 0 then freemem(RenderBuffer); + InitImgMemory (lHdr); + end; +end; + +procedure DrawFrame (var lImage: TImage; lL,lT,lR,lB: integer); +begin +lImage.Canvas.Brush.Style := bsSolid; + lImage.canvas.pen.color := clWhite; + lImage.Canvas.Rectangle(lL,lT,lR,lB); + lImage.canvas.pen.color := clBlack; + lImage.Canvas.Rectangle(lL+1,lT+1,lR-1,lB-1); +end; + +procedure IntenLabel (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer;lMinIn,lMaxIn: single); +//special: if lMin=lMax, assumes current window values +var + lDesiredSteps,lPower,lTxtWid,lTxtTop,lPGWid,lPGHt,lBarTop,lBarLeft,lBarLength,lBarBorder,lBarThick: integer; + lMin,lMax,l1stStep,lRange,lStepSize,lStepPos: single; + lSteps,lStep,lDecimals,lStepPosScrn: integer; +begin + lMin := lMinIn; + lMax := lMaxIn; + lBarBorder := 6; + lBarThick := 8; + lPGWid := lImage.Width; + lPGHt := lImage.Height; + if gBGImg.XBarClr = TColor(gMRIcroOverlay[kBGOverlayNum].LUTinvisible) then + lImage.canvas.font.Color := clBlack + else + lImage.canvas.font.Color := gBGImg.XBarClr; + if lImage = HistogramForm.HistoImage then + lImage.canvas.font.Color := clBlack;//always white background on histoform... + lImage.Canvas.Brush.Style := bsClear; + lImage.Canvas.Font.Name := 'Arial'; + if lPGWid < 100 then + lImage.Canvas.Font.Size := 9 + else if lPGWid < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14; + lTxtTop := lPGHt - ( lBarBorder +(lImage.Canvas.TextHeight('X') div 2)); + //next: compute increment + lDesiredSteps := 4; + if lMin=lMax then begin + + lMin := lHdr.WindowScaledMin; + lMax := lHdr.WindowScaledMax; + SortSingle(lMin,lMax); + if (lHdr.WindowScaledMin <= 0) and (lHdr.WindowScaledMax <= 0) then begin + if (lHdr.LutFromZero) then + lMax := 0; + lStepPos := lMin; + lMin := lMax; + lMax := lStepPos; + end else + if (lHdr.LutFromZero) and (lMin > 0) then + lMin := 0; + end; //lMinIn=lMaxIn + if lMin = lMax then exit; + lRange := abs(lMax - lMin); + //if lRange = 0 then exit; + if lRange < 0.000001 then exit; + lStepSize := lRange / lDesiredSteps; + lPower := 0; + while lStepSize >= 10 do begin + lStepSize := lStepSize/10; + inc(lPower); + end; + while lStepSize < 1 do begin + lStepSize := lStepSize * 10; + dec(lPower); + end; + lStepSize := round(lStepSize) *Power(10,lPower); + if lPower < 0 then + lDecimals := abs(lPower) + else + lDecimals := 0; + if lMin > lMax then begin // inverted + l1stStep := trunc((lMax) / lStepSize)*lStepSize; + if l1stStep < (lMax) then l1stStep := l1stStep+lStepSize; + lSteps := trunc( abs((lMin+0.0001)-l1stStep) / lStepSize)+1; + end else begin + l1stStep := trunc((lMin) / lStepSize)*lStepSize; + if l1stStep < (lMin) then l1stStep := l1stStep+lStepSize; + lSteps := trunc( abs((lMax+0.0001)-l1stStep) / lStepSize)+1; + end; + if not odd(lLTRB) then begin //vertical + if lLTRB > 2 then //right + lBarLeft := lPGWid - (lBarThick+lBarBorder+3) + else //if right else LEFT + lBarLeft := (lBarThick+lBarBorder+3); + lBarLength := lPGHt - (lBarBorder+lBarBorder+2); + for lStep := 1 to lSteps do begin + lStepPos := l1stStep+((lStep-1)*lStepSize); + lStepPosScrn := round( abs(lStepPos-lMin)/lRange*lBarLength); + if lLTRB > 2 then //right - align text for width + lImage.canvas.TextOut(lBarLeft-(lImage.Canvas.TextWidth(realtostr(lStepPos,lDecimals))),lTxtTop-lStepPosScrn,realtostr(lStepPos,lDecimals)) + else + lImage.canvas.TextOut(lBarLeft,lTxtTop-lStepPosScrn,realtostr(lStepPos,lDecimals)); + end; + end else begin //if vert else HORIZ + lBarLength := lPGWid - (lBarBorder+lBarBorder+2); + if lLTRB > 2 then //bottom + lBarTop := lPGHt - (lBarThick+lBarBorder+lImage.Canvas.TextHeight('X')+1 ) + else //top + lBarTop := lBarThick+lBarBorder+1; + for lStep := 1 to lSteps do begin + lStepPos := l1stStep+((lStep-1)*lStepSize); + lStepPosScrn := round(abs(lStepPos-lMin)/lRange*lBarLength); + //lStepPosScrn := 15*lStep; + lTxtWid := lImage.Canvas.TextWidth(realtostr(lStepPos,lDecimals)); + lImage.canvas.TextOut(lBarBorder+lStepPosScrn-(lTxtWid div 2),lBarTop,realtostr(lStepPos,lDecimals)); + end; + end;//if vert else HORIZ +end; + +procedure IntenBar (var lImage: TImage; var lHdr: TMRIcroHdr; lLTRB: integer; lMin,lMax: single); +var lPGHt, lPGWid,lClr,lStripe,lBarBorder,lnStripes,lHorBarTop,lVerBarLeft,lBarThick: integer; +begin + //if lMin = lMax then + lBarBorder := 6; + lBarThick := 8; + lPGWid := lImage.Width; + lPGHt := lImage.Height; + lHorBarTop := lBarBorder; + lVerBarLeft := lBarBorder; + lImage.canvas.pen.width := 1; + if not odd(lLTRB) then begin + //vertical + if lLTRB > 2 then //right + lVerBarLeft := lPGWid - (lBarThick+lBarBorder); + lnStripes := lPGHt - (lBarBorder+lBarBorder+2); + if lnStripes < 1 then exit; + DrawFrame(lImage, lVerBarLeft-2, lBarBorder-2,lVerBarLeft+lBarThick+2, lBarBorder+lnStripes+3); + for lStripe := 0 to lnStripes do begin + lClr := round(((lnStripes- lStripe) / lnStripes)*255); + lImage.canvas.pen.color := lHdr.LUT[lClr].rgbRed+(lHdr.LUT[lClr].rgbGreen shl 8)+(lHdr.LUT[lClr].rgbBlue shl 16); + lImage.canvas.moveto(lVerBarLeft, lBarBorder+lStripe); + lImage.canvas.lineto(lVerBarLeft+lBarThick,lBarBorder+lStripe); + end; //draw each stripe + end else begin //LTRB + //Horizontal + if lLTRB > 2 then //bottom + lHorBarTop := lPGHt - (lBarThick+lBarBorder)-1; + lnStripes := lPGWid - (lBarBorder+lBarBorder+1); + DrawFrame(lImage,lBarBorder-2, lHorBarTop-2, lBarBorder+lnStripes+3,lHorBarTop+lBarThick+2); + if lnStripes < 1 then exit; + for lStripe := 0 to lnStripes do begin + lClr := round((lStripe / lnStripes)*255); + lImage.canvas.pen.color := lHdr.LUT[lClr].rgbRed+(lHdr.LUT[lClr].rgbGreen shl 8)+(lHdr.LUT[lClr].rgbBlue shl 16); + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop+lBarThick); + end; //draw each stripe + end; //if horizontal + IntenLabel(lImage,lHdr,lLTRB,lMin,lMax); +end; + +{$IFNDEF madfx} +procedure Draw32Bitmap(Dest: HDC; lWidth, lHeight: Integer; Bitmap: RGBQuadp); +var + Clip: TRect; + Info: BITMAPINFO; +begin + if (Bitmap = nil) then Exit; + if (lWidth <= 0) or (lHeight <= 0) then Exit; + // clipping: + with Info.bmiHeader do + begin + biSize := SizeOf(BITMAPINFOHEADER); + biWidth := lWidth; + biHeight := lHeight; + biPlanes := 1; + biBitCount := 32; + biCompression := BI_RGB; + biSizeImage := 0; + biClrImportant := 0; + end; + SetStretchBltMode(Dest, COLORONCOLOR); + StretchDIBits(Dest, 0, Pred( lHeight), lWidth, -lHeight, + 0, 0, lWidth, lHeight, Bitmap, Info, DIB_RGB_COLORS, SRCCOPY); +end; + +procedure DrawBMP( lx, ly: integer; lBuff: RGBQuadp; var lImage: TImage); +var + TempBitmap: TBitmap; +begin + TempBitmap := TBitmap.Create; + TempBitmap.Width := lx; + TempBitmap.Height := ly; + Draw32Bitmap(TempBitmap.Canvas.Handle, lx, ly,lBuff {Self}); + lImage.Picture.Bitmap := TempBitmap; + lImage.Width := lx;//delphi + lImage.Height := ly;//delphi + TempBitmap.Free; +end; + +procedure StretchDraw32Bitmap(Dest: HDC; DstWidth, DstHeight,SrcWidth, SrcHeight: Integer; Bitmap: RGBQuadp;lQ: TStretchQuality); +var + Clip: TRect; + Info: BITMAPINFO; + //DstX, DstY,SrcX, SrcY: integer; +begin + if (Bitmap = nil) then Exit; + if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit; + if (DstWidth <= 0) or (DstHeight <= 0) then Exit; + //DstX := 0; DstY := 0; SrcX := 0; SrcY := 0; + if (DstWidth = SrcWidth) and (DstHeight = SrcHeight) then begin + Draw32Bitmap(Dest, SrcWidth, SrcHeight, Bitmap); + Exit; + end; + with Info.bmiHeader do begin + biSize := SizeOf(BITMAPINFOHEADER); + biWidth := SrcWidth; + biHeight := SrcHeight; + biPlanes := 1; + biBitCount := 32; + biCompression := BI_RGB; + biSizeImage := 0; + biClrImportant := 0; + end; + if lQ = sqLow then + SetStretchBltMode(Dest, COLORONCOLOR) + else + SetStretchBltMode(Dest, HALFTONE); + //SetStretchBltMode(Dest, COLORONCOLOR); + //SetStretchBltMode(Dest,STRETCH_DELETESCANS); + StretchDIBits(Dest, 0, Pred( DstHeight), DstWidth, -DstHeight, 0, 0, + SrcWidth, SrcHeight, Bitmap, Info, DIB_RGB_COLORS, SRCCOPY); +end; + +procedure DrawBMPZoom( lx, ly, lZoomPct: integer; lBuff: RGBQuadp; var lImage: TImage;lQ: TStretchQuality); +var + x, y,lYPos,lPos,lImgSz,lOutX,lOutY: Integer; + lRatio,lRatioRecip: single; + TempBitmap: TBitmap; +begin + if lZoomPct > 1 then + lRatio := lZoomPct/100 + else + lRatio := 1; + lRatioRecip := 1/lRatio;//e.g. 200% -> ratio = 2, recip = 0.5 + lImgSz := lx * ly; + TempBitmap := TBitmap.Create; + lOutX := round(lx*lRatio); + lOutY := round(ly*lRatio); + TempBitmap.Width := lOutX; + TempBitmap.Height := lOutY; + StretchDraw32Bitmap(TempBitmap.Canvas.Handle, lOutX, lOutY,lx, ly, lBuff,lQ); + lImage.Picture.Bitmap := TempBitmap; + lImage.Width := lOutX;//delphi + lImage.Height := lOutY;//delphi + TempBitmap.Free; +end; +procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +var + lZoom,lZoomY,lZoomX,lInc,lY,lLen,lSrc,lDest: integer; + lTBuff: RGBQuadp; +begin + ImgForm.caption := random(lBackgroundImg.ZoomPct); + if lBuff = nil then + xxxxxx + DrawBMP( lInPGWid, lInPGHt, lBuff, lImage) + else if (lBackgroundImg.ZoomPct = 100) or (lPanel = nil) then begin + getmem(lTBuff,lInPGHt*lInPGWid*4); + lLen := lInPGWid*4; + lSrc := 1; + lDest := ((lInPGHt-1)*lInPGWid)+1; + for lY := 1 to lInPGHt do begin + Move(Pointer(lBuff^[lSrc]),Pointer(lTBuff^[lDest]),lLen); + lSrc := lSrc + lInPGWid; + lDest := lDest - lInPGWid; + end; + DrawBMP( lInPGWid, lInPGHt, lTBuff, lImage); + freemem(lTBuff); + xxxxxxxxxxxxxxxxxxxxxxxxx + //8888 DrawBMP( lInPGWid, lInPGHt, lBuff, lImage); + lImage.Tag := lBackgroundImg.ZoomPct; + end else begin //not 100% + lZoom := lBackgroundImg.ZoomPct; + if (lZoom <= 0) and (lPanel.Tag = 666) then begin //use precomputed scale + //ImgForm.caption := floattostr(gTripleZoom); + lZoom := gTripleZoom100 + //lZoom := round(gTripleZoom * 100); + end else if (lZoom <= 0) then begin //compute best fit + if (lPanel = nil) or (lPanel.Height < 20) or (lPanel.Width < 20) then + lZoom := 100 + else begin + {'$IFDEF ENDIAN_BIG} //OSX PPC + //lZoomY := round(100*(lPanel.Height-24)/lInPGHt); + //lZoomX := round(100*(lPanel.Width-24)/lInPGWid); + {'$ELSE} + lZoomY := round(100*(lPanel.Height-8)/lInPGHt); + lZoomX := round(100*(lPanel.Width-8)/lInPGWid); + {'$ENDIF} + if lZoomX < lZoomY then + lZoomY := lZoomX; + if lZoom = 0 then begin//nearest integer e.g. 100% or 200%, not 148% + lZoom := (lZoomY div 100)*100; + if lZoom < 100 then + lZoom := 100; + end else + lZoom := lZoomY; + end; //calculate optimal zoom to fit region + end; + getmem(lTBuff,lInPGHt*lInPGWid*4); + lLen := lInPGWid*4; + lSrc := 1; + lDest := ((lInPGHt-1)*lInPGWid)+1; + for lY := 1 to lInPGHt do begin + Move(Pointer(lBuff^[lSrc]),Pointer(lTBuff^[lDest]),lLen); + lSrc := lSrc + lInPGWid; + lDest := lDest - lInPGWid; + end; + if lZoom = 100 then + DrawBMP( lInPGWid, lInPGHt, lTBuff, lImage) + else + DrawBMPZoom( lInPGWid, lInPGHt, lZoom, lTBuff, lImage,gBGImg.StretchQuality);//ScaleStretch(lInPGHt,lInPGWid,lZoom/100,lTBuff, lImage) + freemem(lTBuff);//flip + lImage.Tag := lZoom; + end; +end; +{$ELSE} + +procedure SetDimension32(lInPGHt,lInPGWid:integer; lBuff: RGBQuadp; var lBackgroundImg: TBGImg; var lImage: TImage; lPanel: TScrollBox); +var + sbBits : PByteArray; + lPGWid,lPGHt,nBytesInImage ,lZoom,lZoomX,lZoomY: integer; + lBMP,lStretchBmp: TBitmap; +begin + //first, compute zoom + if (lPanel = nil) then + lImage.Tag := 100 + else if (lPanel.Tag < 1) then begin//autosize + lZoomY := round(100*(lPanel.Height-8)/lInPGHt); + lZoomX := round(100*(lPanel.Width-8)/lInPGWid); + if lZoomX < lZoomY then + lZoom := lZoomX + else + lZoom := lZoomY; + if lZoom < 1 then //nearest integer e.g. 100% or 200%, not 148% + lZoom := 100; + lImage.Tag := lZoom; + end; + if (lImage.Tag < 1) then + lImage.Tag := 100 ; + //next draw bitmap + lPGWid := lInPGWid; + lPGHt := lInPGHt; + lBMP := TBitmap.Create; + TRY + lBMP.PixelFormat := pf32bit; + lBMP.Width := lPGwid; + lBMP.Height := lPGHt; + sbBits := lBmp.ScanLine[lPGHt-1]; + nBytesInImage := lPGWid*lPGHt * 4; + if lBuff <> nil then begin + CopyMemory(Pointer(sbBits),Pointer(lBuff),nBytesInImage); + end else begin //lBuff = nil - no information + FillChar(sbBits^,({lPGHt*{}lPGHt*lPGwid*4), 255); + end; //information in Buffer + if lImage.Tag = 100 then begin + lImage.Width := (lBmp.Width);//xx + lImage.Height := (lBmp.Height);//xx + lImage.Picture.Graphic := lBMP; + end else begin + lStretchBmp := TBitmap.Create; + lStretchBmp.PixelFormat := pf32bit; + lStretchBmp.Height := round(lBmp.Height * lImage.Tag/100); + lStretchBmp.Width := round(lBmp.Width * lImage.Tag/100); + StretchBitmap (lBMP, lStretchBmp,lBackgroundImg.StretchQuality); + if lImage.Width <>lStretchBmp.Width then + lImage.Width := (lStretchBmp.Width); + if lImage.Height <>lStretchBmp.Height then + lImage.Height := (lStretchBmp.Height); + lImage.Picture.Graphic := lStretchBmp; + // lImage.Tag := lZoom; + lStretchBmp.Free; + //ImgForm.TriplePanel.HorzScrollBar.Position := lScrollPos.X; + //ImgForm.TriplePanel.VertScrollBar.Position := lScrollPos.Y; + + end; + FINALLY + lBMP.Free; + END; //try..finally +end; //proc SetDimension32 +{$ENDIF} + +procedure FindImgMinMax8 (var lHdr: TMRIcroHdr; var lMini,lMaxi: integer); +var + lInc: integer; +begin + if (lHdr.ImgBufferBPP <> 1) or (lHdr.ImgBufferItems < 1) then exit; + lMini := lHdr.ImgBuffer [1]; + lMaxi := lHdr.ImgBuffer [1]; + for lInc := 1 to lHdr.ImgBufferItems do begin + if lHdr.ImgBuffer [lInc] > lMaxi then lMaxi := lHdr.ImgBuffer [lInc]; + if lHdr.ImgBuffer [lInc] < lMini then lMini := lHdr.ImgBuffer [lInc]; + end; +end; //FindImgMinMax8 + +procedure FindImgMinMax16 (var lHdr: TMRIcroHdr; var lMini,lMaxi: integer); +//very fast routine for finding brightest and darkest intensity... +var + lImgSamples,lInc,lFinalVal: integer; + l16Buf: SmallIntP; +begin + if (lHdr.ImgBufferBPP <> 2) or (lHdr.ImgBufferItems < 1) then exit; + lImgSamples := lHdr.ImgBufferItems; + lInc:=1; + l16Buf := SmallIntP(lHdr.ImgBuffer ); + lMaxI := l16Buf[lImgSamples]; + lMinI := lMaxi; + lFinalVal := lMaxi; + l16Buf[lImgSamples]:=32767; // set last value to the maximum integer value + while true do // no check here at all now + begin + while (lMaxI>l16Buf[lInc]) and (l16Buf[lInc] >= lMini) do // stop for a >= value + inc(lInc); + if lInc=lImgSamples then begin + l16Buf[lImgSamples]:=lFinalVal; + exit; // check to see if new max is actually end of data + end; + if l16Buf[lInc] >lMaxi then + lMaxI:=l16Buf[lInc]; + if l16Buf[lInc] < lMini then + lMini:=l16Buf[lInc]; + inc(lInc); + end; +end; //FindImgMinMax16 + +procedure FindImgMinMax32 (var lHdr: TMRIcroHdr; var lMin,lMax: single); +var + lInc: integer; + l32Buf : SingleP; +begin + if (lHdr.ImgBufferBPP <> 4) or (lHdr.ImgBufferItems < 2) then exit; + l32Buf := SingleP(lHdr.ImgBuffer ); + //if specialsingle(lHdr.MRIcroHdr.gMultiBuf[1]) then lHdr.MRIcroHdr.gMultiBuf[1] := 0.0; + lMin := l32Buf[1]; + lMax := l32Buf[1]; + for lInc := 2 to lHdr.ImgBufferItems do begin + if (l32Buf[lInc] > lMax) then lMax := l32Buf[lInc]; + if (l32Buf[lInc] < lMin) then lMin := l32Buf[lInc]; + end; + + {for lInc := 2 to lHdr.ImgBufferItems do + if (l32Buf[lInc]= lMax) then lMaxPos := lInc; + showmessage(inttostr(lMaxPos));} + +end; //FindImgMinMax32 + +function ImgVaries ( var lHdr: TMRIcroHdr): boolean; +var + lF: single; + lI,lPos: integer; + l32Buf : SingleP; + l16Buf : SmallIntP; + +begin + result := false; + if lHdr.ImgBufferItems = 2 then exit; + result := true; //assume variance... + if lHdr.ImgBufferBPP = 4 then begin //32bit + l32Buf := SingleP(lHdr.ImgBuffer ); + lF := l32Buf^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if l32Buf^[lPos] <> lF then + exit; + end else if lHdr.ImgBufferBPP = 2 then begin //if 16bit ints + l16Buf := SmallIntP(lHdr.ImgBuffer ); + lI := l16Buf^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if l16Buf^[lPos] <> lI then + exit; + + end else if lHdr.ImgBufferBPP = 1 then begin //if 16bit ints + lI := lHdr.ImgBuffer^[1]; + for lPos := 2 to lHdr.ImgBufferItems do + if lHdr.ImgBuffer^[lPos] <> lI then + exit; + end else + showmessage('ImgVaries error: Unsupported format'); + result := false; //entire image has no variability... +end; + + +procedure CreateHisto (var lHdr: TMRIcroHdr; var lHisto: HistoRA); +var + lModShl10,lMinI,lC: integer; + lMod,lRng: double {was extended}; + l32Buf : SingleP; + l16Buf : SmallIntP; +begin + if lHdr.ImgBufferItems = 0 then exit; + for lC := 0 to kHistoBins do + lHisto[lC] := 0; + if lHdr.ImgBufferBPP = 4 then begin //32bit + l32Buf := SingleP(lHdr.ImgBuffer ); + lRng := lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS; + if lRng > 0 then + lMod := (kHistoBins)/lRng + else + lMod := 0; + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[round((l32Buf[lC]-lHdr.GlMinUnscaledS)*lMod)]); + end else {if lHdr.g16Sz >= lHdr.ScrnBufferSz then}begin //<>32bit.. integer + + lMinI := round(lHdr.GlMinUnscaledS); + lRng := lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS; + if lRng > 0 then + lMod := (kHistoBins)/lRng + else + lMod := 0; + lModShl10 := trunc(lMod * 1024); + if lHdr.ImgBufferBPP = 2 then begin //if 16bit ints + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[((l16Buf[lC]-lMinI)*lModShl10)shr 10]) + end else //else 8 bit data + for lC := 1 to lHdr.ImgBufferItems do + inc(lHisto[((lHdr.ImgBuffer[lC]-lMinI)*lModShl10)shr 10]); + end; //not 32bit +end; + +(*procedure HistoDescriptives (var lHdr: TMRIcroHdr; var lHisto: HistoRA; var lModePos,lMaxModePos: integer; var lMode1,lMode2: double); +var + + lModeWid,lMinPos,lC: integer; + lMode,lRng,lIntercept,lScale: double {was extended}; + l32Buf : SingleP; + l16Buf : SmallIntP; +begin + lMaxModePos := 0; + lModePos := 0; + lMode := 0; + + if lHdr.ImgBufferItems = 0 then exit; + lMinPos := 1;//indexed from zero + lModeWid := 25; //how wide is the modal value, e.g. 10% = 25 (25/255) + //find highest peak + for lC := lMinPos to kHistoBins do begin + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //for each bin + if lMode > 0 then + lMaxModePos := lModePos + else + exit; + //now find 2nd highest peak + lMode := 0; + lC := lMaxModePos; + while ((lC-1) > lMinPos) and (lHisto[lC] > lHisto[lC-1]) do + dec(lC); //find inflection + while ((lC-1) > lMinPos) do begin + dec(lC); + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //look for mode + + lC := lMaxModePos; + while ((lC+1) <= kHistoBins) and (lHisto[lC] > lHisto[lC+1]) do + inc(lC); //find inflection + while ((lC+1) <= kHistoBins) do begin + inc(lC); + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //look for mode + if lHdr.ImgBufferBPP = 4 then begin //32bit + + lRng := lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS; + lRng := lRng/kHistoBins; + //fx((lModePos*lRng)+lHdr.GlMinUnscaledS, (lMaxModePos*lRng)+lHdr.GlMinUnscaledS, lRng); + lMode1 := (lModePos*lRng)+lHdr.GlMinUnscaledS; + lMode2 := (lMaxModePos*lRng)+lHdr.GlMinUnscaledS; + end else begin + fx(-666); + end; + lMode1 := (lModePos*lRng)+lHdr.GlMinUnscaledS; + lMode2 := (lMaxModePos*lRng)+lHdr.GlMinUnscaledS; + //fx(lMode1,lMode2,lModePos,lMaxModePos); + lScale := (1/abs(lMode1-lMode2))*lHdr.NIFTIhdr.scl_slope;//make mode2 = 2 + if lMode1 < lMode2 then + lIntercept := 1+(lMode1*lScale)-lHdr.NIFTIhdr.scl_inter + else + lIntercept := 1+(lMode2*lScale)-lHdr.NIFTIhdr.scl_inter; //make mode1 = 1 + fx(lScale,lIntercept); + +end; *) + + +function BinCenter (lBin: integer; var lHdr: TMRIcroHdr): single; +begin + result := (lHdr.GlMaxUnscaledS - lHdr.GlMinUnscaledS)/(kHistoBins-1); //range div bins + result := (lBin * result)+ lHdr.GlMinUnscaledS+ (0.5*result); + +end; + +procedure TextReportHisto (var lHdr: TMRIcroHdr); +var + lC: integer; + var lHisto: HistoRA; +begin + CreateHisto (lHdr, lHisto); + TextForm.MemoT.Lines.Clear; + TextForm.MemoT.Lines.add('#Histogram summary ~ Approximate Values'); + TextForm.MemoT.Lines.add('#Image intensity range: '+realtostr(lHdr.GlMinUnscaledS,3)+'..'+realtostr(lHdr.GlMaxUnscaledS,3)); + TextForm.MemoT.Lines.add('#BinNumber'+kTextSep+'BinCenter'+kTextSep+'BinCount'); + for lC := 0 to kHistoBins do + TextForm.MemoT.Lines.Add( inttostr(lC) + kTextSep+realtostr(BinCenter(lC,lHdr),3) + kTextSep+ inttostr(lHisto[lC]) ); + TextForm.Show; + +end; + +(*procedure CreateHisto (var lHdr: TMRIcroHdr; var lHisto: HistoRA); +var + lZi,lZ,lC,lSz,lS: integer; + l16Buf : SmallIntP; +begin + if lHdr.ImgBufferItems = 0 then exit; + for lC := 0 to kHistoBins do + lHisto[lC] := 0; + lSz := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]; + lZ :=lHdr.NIFTIhdr.dim[3]; + if ( lHdr.ImgBufferItems <> (lSz*lZ)) or (lZ > kHistoBins) then begin + showmessage('HistoZ needs more work.'); + exit; + end; + + lC := 0; + if lHdr.ImgBufferBPP = 2 then begin //if 16bit ints + + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lZi := 1 to lZ do begin + for lS := 1 to lSz do begin + inc(lC); + lHisto[lZi] := lHisto[lZi]+ (l16Buf[lC]div 100); + end; + end; + end; //not 32bit +end;*) + +procedure DrawHistogram (var lHdr: TMRIcroHdr; var lImage: TImage); +var lPGHt, lPGWid,lIntenBarHt,lStripe,lBarBorder,lnStripes,lHorBarTop,lBarHt, + lThresh,l005Pct,ln005Pct,l02Pct,ln02Pct,l0005Pct,ln0005Pct,l001Pct,ln001Pct,l01Pct,ln01Pct,lMaxFreq,lMaxBarHt,lHistoPos,lPrevHistoPos,lFreq,lPos,lTotFreq: integer; + lModePos1,lModePos2: integer; + lPct,lMode1,lMode2: double; + lHisto: HistoRA; +begin + + lPGWid := lImage.Width; + lPGHt := lImage.Height; + SetDimension32(lPGHt,lPGWid,nil,gBGImg,lImage,nil); + lImage.Canvas.Font.Name := 'Arial'; + if lPGWid < 100 then + lImage.Canvas.Font.Size := 9 + else if lPGWid < 200 then + lImage.Canvas.Font.Size := 12 + else + lImage.Canvas.Font.Size := 14; + CreateHisto (lHdr, lHisto); + lBarBorder := 6; + lIntenBarHt := 14; + DrawFrame(lImage, 0, 0,lPGWid,lPGHt); + lHorBarTop := lPGHt - lBarBorder-lIntenBarHt-lImage.Canvas.TextHeight('X'); + lMaxBarHt := lHorBarTop - lBarBorder- lBarBorder- lBarBorder; + lMaxFreq := 0; + lnStripes := lPGWid - (lBarBorder+lBarBorder+1); + if gBGImg.XBarClr = clWhite then + lImage.canvas.pen.color := clBlack//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + else + lImage.canvas.pen.color := gBGImg.XBarClr;//clWhite;//gLUT[lClr].rgbRed+(gLUT[lClr].rgbGreen shl 8)+(gLUT[lClr].rgbBlue shl 16); + lImage.Canvas.Font.Color := lImage.canvas.pen.color; + lImage.Canvas.Brush.Style := bsSolid; + lImage.Canvas.Pen.Width := 1; + LImage.Canvas.Pen.Style := psDot; + lImage.canvas.moveto(lBarBorder,lHorBarTop-lMaxBarHt-1); + lImage.canvas.lineto(lPGWid-lBarBorder,lHorBarTop-lMaxBarHt-1); + lImage.Canvas.Brush.Style := bsClear; + if (lnStripes < 1) then exit; + //Next: find freq in graph - not same as image, as with large graphs bars resampled + lPrevHistoPos := 0; + lTotFreq := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + for lPos := lPrevHistoPos to lHistoPos do + lTotFreq := lTotFreq+lHisto[lPos]; + lPrevHistoPos := lHistoPos+1; + end; + ln02Pct := 0; + ln01Pct := 0; + ln005Pct := 0; + ln001Pct := 0; + ln0005Pct := 0; + l02Pct := round(lTotFreq/50); + l01Pct := round(lTotFreq/100); + l005Pct := round(lTotFreq/200); + l001Pct := round(lTotFreq/1000); + l0005Pct := round(lTotFreq/2000); + lPrevHistoPos := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + lFreq := 0; + for lPos := lPrevHistoPos to lHistoPos do + lFreq := lFreq+lHisto[lPos]; + if lFreq > lMaxFreq then + lMaxFreq := lFreq; + if lFreq > l02Pct then + inc(ln02Pct); + if lFreq > l01Pct then + inc(ln01Pct); + if lFreq > l005Pct then + inc(ln005Pct); + if lFreq > l001Pct then + inc(ln001Pct); + if lFreq > l0005Pct then + inc(ln0005Pct); + //lTotFreq := lTotFreq + lFreq; + lPrevHistoPos := lHistoPos+1; + end; + lImage.Canvas.Pen.Style := psSolid; + lThresh := round(lnStripes * 0.07); + if ln02Pct > lThresh then + lPct := 5 + else if ln01Pct > lThresh then + lPct := 2 + else if ln005Pct > lThresh then + lPct := 1 + else if ln001Pct > lThresh then + lPct := 0.5 + else if ln0005Pct > lThresh then + lPct := 0.01 + else + lPct := 0.05; + lMaxFreq :=round( lTotFreq * (lPct/100)); + if (lMaxFreq = 0) then exit; + lImage.canvas.TextOut(lPGWid div 2,lHorBarTop-lMaxBarHt-1-6,' '+floattostr(lPct)+'% '); + lImage.Canvas.Brush.Style := bsClear; + + //Next: draw bars + lPrevHistoPos := 0; + for lStripe := 0 to lnStripes do begin + lHistoPos := round(lStripe / lnStripes*kHistoBins); + if lPrevHistoPos > lHistoPos then + lPrevHistoPos := lHistoPos; + lFreq := 0; + for lPos := lPrevHistoPos to lHistoPos do + lFreq := lFreq+lHisto[lPos]; + if lFreq > lMaxFreq then begin + lFreq := lMaxFreq; + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-8); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-6); + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-4); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lMaxBarHt-2); + end; + lBarHt := round(lFreq/lMaxFreq*lMaxBarHt); + lImage.canvas.moveto(lBarBorder+lStripe,lHorBarTop); + lImage.canvas.lineto(lBarBorder+lStripe,lHorBarTop-lBarHt); + lPrevHistoPos := lHistoPos+1; + end; //draw each stripe + intenBar(lImage,lHdr,3,Raw2ScaledIntensity(lHdr,lHdr.GlMinUnScaledS),Raw2ScaledIntensity(lHdr,lHdr.GlMaxUnscaledS)); +end; + +procedure Balance (var lHdr: TMRIcroHdr); +var + lPct,lNum,lC: integer; + lHisto: HistoRA; + lBlackAUtoBal,lWhiteAutoBal: integer; +begin //dsa + if lHdr.ImgBufferItems = 0 then exit; + CreateHisto (lHdr, lHisto); + lPct := (lHdr.ImgBufferItems *2) div 100; + lNum := 0; + lC := kHistoBins; + repeat + lNum := lNum + lHisto[lC]; + dec(lC); + until (lC = 0) or (lNum >= lPct); + if (lNum >= lPct) and (lC > 0) then + lWHiteAUtoBal:= lC + else begin + lC := kHistoBins; + repeat + lNum := lHisto[lC]; + dec(lC); + until (lC = 0) or (lNum > 0); + if lC = 0 then + lWHiteAUtoBal := kHistoBins + else + lWHiteAUtoBal := lC; + end; + lNum := 0; + lC := 0; + repeat + lNum := lNum + lHisto[lC]; + inc(lC); + until (lC >= kHistoBins) or (lNum >= lPct); + if (lNum >= lPct) and (lC < kHistoBins) and (lC >2) then + lBlackAutoBal := lC + else + lBlackAutoBal := 2; + //fx(lBlackAutoBal,lWHiteAUtoBal,789); + if (lWHiteAUtoBal-lBlackAutoBal) < (kHistoBins/20) then begin //5% of range.. + lBlackAutoBal := 2; + lWHiteAUtoBal := kHistoBins; + end; + lHdr.AutoBalMaxUnscaled := ((lWhiteAutoBal/kHistoBins)*(lHdr.GlMaxUnscaledS-lHdr.GlMinUnscaledS))+lHdr.GlMinUnscaledS; + lHdr.AutoBalMinUnscaled := ((lBlackAutoBal/kHistoBins)*(lHdr.GlMaxUnscaledS-lHdr.GlMinUnscaledS))+lHdr.GlMinUnscaledS; + //only apply rounding if there is a large difference - e.g. if range is 0..1 then rounding will hurt + if (lHdr.ImgBufferBPP < 4) and ((lHdr.AutoBalMaxUnscaled-lHdr.AutoBalMinUnscaled) > 50) then begin //round integer values + lHdr.AutoBalMinUnscaled := round(lHdr.AutoBalMinUnscaled); + lHdr.AutoBalMaxUnscaled := round(lHdr.AutoBalMaxUnscaled); + end;//11/2007 +end; //proc Balance + +procedure ReturnMinMax (var lHdr: TMRIcroHdr; var lMin,lMax: single; var lFiltMin8bit, lFiltMax8bit: integer); +var + lSwap,lMinS,lMaxS {,lHalfBit}: single; +begin + lFiltMin8bit := 0; + lFiltMax8bit := 255; + lMinS := lHdr.WindowScaledMin; + lMaxS := lHdr.WindowScaledMax; + if lMinS > lMaxS then begin //swap + lSwap := lMinS; + lMinS := lMaxS; + lMaxS := lSwap; + end;//swap + lMin := (Scaled2RawIntensity(lHdr, lMinS)); + lMax := (Scaled2RawIntensity(lHdr, lMaxS)); + //if lMin = lMax then exit; + if (lHdr.LutFromZero) then begin + if (lMinS > 0) and (lMaxS <> 0) then begin + //lMin := Scaled2RawIntensity(lHdr, 0); + lFiltMin8bit := round(lMinS/lMaxS*255); + //lMinS := - lHalfBit;//0; + lHdr.Zero8Bit := 0; + end else if (lMaxS < 0) and (lMinS <> 0) then begin + //lMax := Scaled2RawIntensity(lHdr, -0.000001); + lFiltMax8bit := 255-round(lMaxS/lMinS*255); + //lMaxS := lHalfBit; //0; + //lFiltMax8bit := (Scaled2RawIntensity(lHdr, lHdr.WindowScaledMax)); + end; //> 0 + end; //LUTfrom Zero + lHdr.Zero8Bit := lMinS; + lHdr.Slope8bit := (lMaxS-lMinS)/255; +end; //ReturnMinMax + +procedure FilterScrnImg (var lHdr: TMRIcroHdr); +var + lInc,lItems,lFiltMin8bit,lFiltMax8bit: integer; + lMinS,lMaxS,lScale: single; +begin + ReturnMinMax(lHdr,lMinS,lMaxS,lFiltMin8bit,lFiltMax8bit); + lItems :=lHdr.ScrnBufferItems; + if lItems < 1 then exit; + if lFiltMax8Bit < 255 then begin + lFiltMin8bit := 255-lFiltMax8bit; + lFiltMax8Bit := 255; + end; + lScale := (lFiltMax8bit-lFiltMin8bit)/255; + if (lFiltMin8bit > 0) or (lFiltMax8bit < 255) then + for lInc := 1 to lItems do + if lHdr.ScrnBuffer[lInc] <> 0 then + lHdr.ScrnBuffer[lInc] := lFiltMin8bit+round(lHdr.ScrnBuffer[lInc]*lScale); +end; //FilterScrnImg + +procedure RescaleImgIntensity8(var lHdr: TMRIcroHdr ); +var lRng: single; + lLUTra: array[0..255] of byte; + lMax,lMin,lSwap,lMod: single; + lFiltMin8bit,lFiltMax8bit,lInc: integer; +begin + if (lHdr.ImgBufferBPP <> 1) or (lHdr.ImgBufferItems < 2) then + exit; + if (lHdr.UsesCustomPaletteRandomRainbow) then begin + createLutLabel (lHdr.LUT, abs(lHdr.WindowScaledMax-lHdr.WindowScaledMin)/100); + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := lHdr.ImgBuffer^[lInc]; + exit; + end; + ReturnMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + //ImgForm.Caption := floattostr(lMin); + //fx(lMin,lMax,lFiltMin8bit,lFiltMax8bit); + lRng := (lMax - lMin); + if lRng <> 0 then + lMod := abs({trunc}(((254)/lRng))) + else + lMod := 0; + if lMin > lMax then begin //maw + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + for lInc := 0 to 255 do begin + if lInc < lMin then + lLUTra[lInc] := 0 + else if lInc >= lMax then + lLUTra[lInc] := 255 + else + lLUTra[lInc] := trunc(((lInc-lMin)*lMod)+1); + end; //fill LUT + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 0 to 255 do + lLUTra[lInc] := 255-lLUTra[lInc]; + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer[lInc] := lLUTra[lHdr.ImgBuffer[lInc]]; +end;//proc RescaleImgIntensity8 + +procedure ReturnMinMaxInt (var lHdr: TMRIcroHdr; var lMin,lMax, lFiltMin8bit, lFiltMax8bit: integer); +var + lMinS,lMaxS: single; +begin + ReturnMinMax (lHdr, lMinS,lMaxS,lFiltMin8bit, lFiltMax8bit); + lMin := round(lMinS); + lMax := round(lMaxS); +end; +(* +procedure RescaleImgIntensity8(var lHdr: TMRIcroHdr ); +var lRng: single; + lLUTra: array[0..255] of byte; + lFiltMin8bit,lFiltMax8bit,lMax,lMin,lModShl10,lInc,lSwap: integer; +begin + if (lHdr.ImgBufferBPP <> 1) or (lHdr.ImgBufferItems < 2) then + exit; + ReturnMinMaxInt (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + ImgForm.Caption := inttostr(lMin)); + lRng := (lMax - lMin); + if lRng <> 0 then + lModShl10 := abs(trunc(((254)/lRng)* 1024)) + else + lModShl10 := 0; + if lMin > lMax then begin //maw + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + for lInc := 0 to 255 do begin + if lInc < lMin then + lLUTra[lInc] := 0 + else if lInc >= lMax then + lLUTra[lInc] := 255 + else + lLUTra[lInc] := (((lInc-lMin)*lModShl10) shr 10)+1; + end; //fill LUT + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 0 to 255 do + lLUTra[lInc] := 255-lLUTra[lInc]; + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer[lInc] := lLUTra[lHdr.ImgBuffer[lInc]]; +end;//proc RescaleImgIntensity8 +*) +procedure RescaleImgIntensity16(var lHdr: TMRIcroHdr ); +var lRng: single; + lBuff: bytep0; + l16Buf : SmallIntP; + lFiltMin8bit,lFiltMax8bit,lRngi,lMin16Val,lMax,lMin,lSwap,lModShl10,lInc,lInt: integer; +begin + if (lHdr.ImgBufferBPP <> 2) or (lHdr.ImgBufferItems < 2) then exit; + if (lHdr.UsesCustomPaletteRandomRainbow) then begin + createLutLabel (lHdr.LUT, abs(lHdr.WindowScaledMax-lHdr.WindowScaledMin)/100); + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lInc := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer^[lInc] := ((l16Buf^[lInc]-1) mod 100)+1; + exit; + end; + + ReturnMinMaxInt (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + lRng := lMax - lMin; + if lRng <> 0 then + lModShl10 := abs( trunc(((254)/lRng)* 1024)) + else + lModShl10 := 0; + if lMin > lMax then begin + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + lMin16Val := trunc(lHdr.GlMinUnscaledS); + lRngi := (1+ trunc(lHdr.GlMaxUnscaledS))-lMin16Val; + getmem(lBuff, lRngi+1); //+1 if the only values are 0,1,2 the range is 2, but there are 3 values! + for lInc := 0 to (lRngi) do begin //build lookup table + lInt := lInc+lMin16Val; + if lInt >= lMax then + lBuff[lInc] := (255) + else if lInt < lMin then + lBuff[lInc] := 0 + else + lBuff[lInc] := (((lInt-lMin)*lModShl10) shr 10)+1 ; + //lBuff[lInc] := (((lInt-lMin)*lModShl10) shr 10) ; + end; //build lookup table + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 0 to lRngi do + lBuff[lInc] := 255-lBuff[lInc]; + l16Buf := SmallIntP(lHdr.ImgBuffer ); + for lInc := 1 to lHdr.ImgBufferItems do + lHdr.ScrnBuffer[lInc] := lBuff[l16Buf[lInc]-lMin16Val] ; + freemem(lBuff); //release lookup table +end;//proc RescaleImgIntensity16; + +procedure RescaleImgIntensity32(var lHdr: TMRIcroHdr ); +var lRng: double; +lMod,lMax,lMin,lSwap: single {was extended}; + lInc,lItems,lFiltMin8bit,lFiltMax8bit: integer; + l32Buf : SingleP; +begin + lItems := lHdr.ImgBufferItems ; + //fx(lItems,777); + if (lHdr.ImgBufferBPP <> 4) or (lItems< 2) then exit; + l32Buf := SingleP(lHdr.ImgBuffer ); + ReturnMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); //qaz + lRng := (lMax - lMin); + if lRng <> 0 then + lMod := abs(254/lRng) + else begin //June 2007 + for lInc := 1 to lItems do begin + if l32Buf[lInc] >= lMax then + lHdr.ScrnBuffer[lInc] := 255 + else //if l32Buf[lInc] < lMin then + lHdr.ScrnBuffer[lInc] := 0; + end; + exit; + end; +(* if lRng <> 0 then + lMod := abs(254/lRng) + else + lMod := 0; +*) + if lMin > lMax then begin + lSwap := lMin; + lMin := lMax; + lMax := lSwap; + end; + lMin := lMin - abs(lRng/255);//lMod; + //showmessage(realtostr(lMin,3)+' '+realtostr(lMax,3)); + if gSSEenabled then + SSEScale(lMod,lMin,lMax,255,lItems,l32Buf,lHdr.ScrnBuffer) + else begin//not SSE + for lInc := 1 to lItems do begin + if l32Buf[lInc] > lMax then + lHdr.ScrnBuffer[lInc] := 255 + else if l32Buf[lInc] < lMin then + lHdr.ScrnBuffer[lInc] := 0 //alfa + else begin + lHdr.ScrnBuffer[lInc] := round ((l32Buf[lInc]-lMin)*lMod); + end; + end; //for each voxel + end; // SSE-vs-x87 choice + //next: prevent rounding errors for images where LUT is from zero + //next - flip intensity range OPTIONAL + if lRng < 0 then //inverted scale... e.g. negative scale factor + for lInc := 1 to lItems do + lHdr.ScrnBuffer[lInc] := 255-lHdr.ScrnBuffer[lInc]; +end; //RescaleImgIntensity32 + +procedure MirrorScrnBuffer(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr ); +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfX,lLineOffset: integer; + lTemp: byte; +begin + lX := lBackgroundImg.ScrnDim[1]; + lY := lBackgroundImg.ScrnDim[2]; + lZ := lBackgroundImg.ScrnDim[3]; + if (lHdr.ScrnBufferItems < (lX*lY*lZ)) or (lX < 2) then exit; + lHlfX := lX div 2; + lLineOffset := 0; + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp := lHdr.ScrnBuffer[lXPos+lLineOffset]; + lHdr.ScrnBuffer[lXPos+lLineOffset] := lHdr.ScrnBuffer[1+lX-lXPos+lLineOffset]; + lHdr.ScrnBuffer[1+lX-lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z +end; //proc MirrorScrnBuffer + +function MirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfX,lLineOffset: integer; + lTemp32: single; + lTemp16: SmallInt; + lTemp: byte; + l32: SingleP; + l16: SmallIntP; +begin + result := false; + lX := lHdr.NIFTIhdr.Dim[1]; + lY := lHdr.NIFTIhdr.Dim[2]; + lZ := lHdr.NIFTIhdr.Dim[3]; + if lHdr.NIFTIhdr.Dim[4] > 1 then begin + Showmessage('Can not mirror 4D data : '+lHdr.HdrFileName); + exit; + + end; + + if (lHdr.ImgBufferItems < (lX*lY*lZ)) or (lX < 2) then begin + Showmessage('Unsupported filetype : '+lHdr.HdrFileName); + exit; + end; + lHlfX := lX div 2; + lLineOffset := 0; + + //for each datatype... + if lHdr.ImgBufferBPP = 4 then begin + l32 := SingleP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp32 := l32^[lXPos+lLineOffset]; + l32^[lXPos+lLineOffset] := l32^[1+lX-lXPos+lLineOffset]; + l32^[1+lX-lXPos+lLineOffset] := lTemp32; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 2 then begin + l16 := SmallIntP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp16 := l16^[lXPos+lLineOffset]; + l16^[lXPos+lLineOffset] := l16^[1+lX-lXPos+lLineOffset]; + l16^[1+lX-lXPos+lLineOffset] := lTemp16; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 1 then begin + for lZPos := 1 to lZ do begin + for lYPos := 1 to lY do begin + for lXPos := 1 to lHlfX do begin + lTemp := lHdr.ImgBuffer^[lXPos+lLineOffset]; + lHdr.ImgBuffer^[lXPos+lLineOffset] := lHdr.ImgBuffer^[1+lX-lXPos+lLineOffset]; + lHdr.ImgBuffer^[1+lX-lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + end; //for Y + end; //for Z + + + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); + result := true; +end; //proc MirrorImgBuffer + +function DICOMMirrorImgBuffer(var lHdr: TMRIcroHdr ): boolean; +var + lXPos,lYPos,lZPos,lX,lY,lZ,lHlfY,lLineOffset,lLineOffsetIn: integer; + lTemp32: single; + lTemp16: SmallInt; + lTemp: byte; + l32: SingleP; + l16: SmallIntP; +begin + result := false; + lX := lHdr.NIFTIhdr.Dim[1]; + lY := lHdr.NIFTIhdr.Dim[2]; + lZ := lHdr.NIFTIhdr.Dim[3]; + if lHdr.NIFTIhdr.Dim[4] > 1 then begin + Showmessage('Can not mirror 4D data : '+lHdr.HdrFileName); + exit; + end; + if (lHdr.ImgBufferItems < (lX*lY*lZ)) or (lX < 2) then begin + Showmessage('Unsupported filetype : '+lHdr.HdrFileName); + exit; + end; + lHlfY := lY div 2; + lLineOffset := 0; + + //for each datatype... + if lHdr.ImgBufferBPP = 4 then begin + l32 := SingleP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp32 := l32^[lXPos+lLineOffsetIn]; + l32^[lXPos+lLineOffsetIn] := l32^[lXPos+lLineOffset]; + l32^[lXPos+lLineOffset] := lTemp32; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + + end else if lHdr.ImgBufferBPP = 2 then begin + l16 := SmallIntP(lHdr.ImgBuffer); + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp16 := l16^[lXPos+lLineOffsetIn]; + l16^[lXPos+lLineOffsetIn] := l16^[lXPos+lLineOffset]; + l16^[lXPos+lLineOffset] := lTemp16; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + end else if lHdr.ImgBufferBPP = 1 then begin + for lZPos := 1 to lZ do begin + lLineOffsetIn := lLineOffset + ((lY-1)*lX ); + for lYPos := 1 to lHlfY do begin + for lXPos := 1 to lX do begin + lTemp := lHdr.ImgBuffer^[lXPos+lLineOffsetIn]; + lHdr.ImgBuffer^[lXPos+lLineOffsetIn] := lHdr.ImgBuffer^[lXPos+lLineOffset]; + lHdr.ImgBuffer^[lXPos+lLineOffset] := lTemp; + end; //for X + lLineOffset := lLineOffset + lX; + lLineOffsetIn := lLineOffsetIn - lX; + end; //for Y + end; //for Z + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); + result := true; +end; //proc DICOMMirrorImgBuffer + +(*procedure OrthogonalResliceScrnImg (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); +label 345; +const + kSh = 8; //bits to shift + kSHval = 1 shl kSh; + kShDiv = 3 * kSh; +Type + TXImg = record //Next: analyze Format Header structure + rDim: array [1..3] of integer; + rOri,rMM: array [1..3] of single; + rSliceSz: integer; + end; //TNIFTIhdr Header Structure +var + //lStartTime,lEndTime: DWord; + lIn,lOut: TXImg; + lBuffIn,lBuffOut: Bytep; + lX,lY,lZ,lI,lPos,lOutVolSz,lInZPos,lInYPos,lOutZPos,lOutYPos,lInZPosHi,lInYPosHi, + lXmodLo,lXmodHi,lYmodLo,lYmodHi,lZmodLo,lZmodHi: integer; + lScale,lFloatPos: single; + lMin,lMax: array [1..3] of integer; + lLUTra,lLUTmodRA: array [1..3] of LongIntp; +begin + //lStartTime := GetTickCount; + //Input dimensions: raw dimensions of overlay + for lI := 1 to 3 do begin + lIn.rDim[lI] := lHdr.NIFTIhdr.dim[lI]; + lIn.rMM[lI] := lHdr.NIFTIhdr.pixdim[lI]; + lIn.rOri[lI] := lHdr.Ori[lI]; + end; + lIn.rSliceSz := lIn.rDim[1]*lIn.rDim[2]; + //Output screen size + for lI := 1 to 3 do begin + lOut.rDim[lI] := lBackgroundImg.ScrnDim[lI]; + lOut.rMM[lI] := lBackgroundImg.ScrnMM[lI]; + lOut.rOri[lI] := lBackgroundImg.ScrnOri[lI]; + end; + lOut.rSliceSz := lOut.rDim[1]*lOut.rDim[2]; + lOutVolSz := lOut.rSliceSz * lOut.rDim[3]; //InVolSz! + //next- prepare to write + lBuffIn := lHdr.ScrnBuffer; + GetMem(lBuffOut,lOutVolSz); + if (lHdr.WindowScaledMin <= 0) and (lHdr.WindowScaledMax <= 0) then //invert + fillchar(lBuffOut^,lOutVolSz,255) //set all to inverted zero + else + fillchar(lBuffOut^,lOutVolSz,0); //set all to zero + //find bounding box for overlay, and create lookup tables + for lI := 1 to 3 do begin + lScale := lOut.rMM[lI] / lIn.rMM[lI]; + getmem(lLUTra[lI],lOut.rDim[lI]*4); + getmem(lLUTmodra[lI],lOut.rDim[lI]*4); + lMin[lI] := maxint; + lMax[lI] := -1; + for lPos := 1 to lOut.rDim[lI] do begin + if lBackgroundImg.OverlaySmooth then begin + lFloatPos := ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] {-0.5}; + lLUTra[lI][lPos] := trunc ( lFloatPos ); + lLUTmodra[lI][lPos] := round(kSHval * frac (lFloatPos )); + end else begin + lLUTra[lI][lPos] := round ( ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] ); + lLUTmodra[lI][lPos] :=0;//not used + end; + if (lLUTra[lI][lPos] > 0) and (lMin[lI]=MaxInt){(lLUTra[lI][lPos] < lMin[lI])} then + lMin[lI] := lPos; + if (lLUTra[lI][lPos] < lIn.rDim[lI]) {<=} then + lMax[lI] := lPos; + end; + end; + for lI := 1 to 3 do + if lMin[lI] >= lMax[lI] then goto 345; //do after previous loop so we are sure all buffers used + ImgForm.ProgressBar1.Min := lMin[3]; + ImgForm.ProgressBar1.Max := lMax[3]; +if lBackgroundImg.OverlaySmooth then begin //trilinear + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + //Application.ProcessMessages; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3][lZ]; + lZModLo := kShVal - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2][lY]; + lYModLo := kShVal - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1][lX]; + lXModLo := kShVal - lXmodHi; + lBuffOut[lOutZPos+lOutYPos+lX] := ( + lBuffIn[lInZPos+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn[lInZPos+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn[lInZPos+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn[lInZPos+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn[lInZPosHi+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn[lInZPosHi+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn[lInZPosHi+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn[lInZPosHi+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModHi + ) shr kShDiv; + end; //for X + end; //for Y + end; //for Z +end else begin //nearest neighbor + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + //Application.ProcessMessages; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + for lX := lMin[1] to lMax[1] do begin + lBuffOut[lOutZPos+lOutYPos+lX] := lBuffIn[lInZPos+lInYPos+lLUTra[1][lX]]; + end; //for X + end; //for Y + end; //for Z +end; //if..smooth...else + ImgForm.ProgressBar1.Position := lMin[3]; + 345: + for lI := 1 to 3 do begin + freemem(lLUTra[lI]); + freemem(lLUTmodra[lI]); + end; + //Output dimensions: size of background image + FreeMem(lHdr.ScrnBuffer); + lHdr.ScrnBufferItems := lOutVolSz; + GetMem(lHdr.ScrnBuffer,lOutVolSz); + CopyMemory(Pointer(lHdr.ScrnBuffer),Pointer(lBuffOut),lOutVolSz); + FreeMem(lBuffOut); + //ImgForm.StatusLabel.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); +end; //procedure OrthogonalResliceScrnImg + +(*procedure OrthogonalResliceImgBuffer8 (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); +label 345; +Type + TXImg = record //Next: analyze Format Header structure + rDim: array [1..3] of integer; + rOri,rMM: array [1..3] of single; + rSliceSz: integer; + end; //TNIFTIhdr Header Structure +var + //lStartTime,lEndTime: DWord; + lIn,lOut: TXImg; + lBuffIn,lBuffOut: Bytep; + lX,lY,lZ,lI,lPos,lOutVolItems,lInZPos,lInYPos,lOutZPos,lOutYPos,lInZPosHi,lInYPosHi: integer; + lXmodLo,lXmodHi,lYmodLo,lYmodHi,lZmodLo,lZmodHi: single; + lScale,lFloatPos: single; + lMin,lMax: array [1..3] of integer; + lLUTra: array [1..3] of LongIntp; + lLUTmodRA: array [1..3] of Singlep; +begin + //lStartTime := GetTickCount; + //Input dimensions: raw dimensions of overlay + + showmessage('ortho DIVA'); + for lI := 1 to 3 do begin + lIn.rDim[lI] := lHdr.NIFTIhdr.dim[lI]; + lIn.rMM[lI] := lHdr.NIFTIhdr.pixdim[lI]; + lIn.rOri[lI] := lHdr.Ori[lI]; + end; + lIn.rSliceSz := lIn.rDim[1]*lIn.rDim[2]; + //Output to background size + for lI := 1 to 3 do begin + lOut.rDim[lI] := lBackgroundImg.ScrnDim[lI]; + lOut.rMM[lI] := lBackgroundImg.ScrnMM[lI]; + lOut.rOri[lI] := lBackgroundImg.ScrnOri[lI]; + end; + lOut.rSliceSz := lOut.rDim[1]*lOut.rDim[2]; + lOutVolItems := lOut.rSliceSz * lOut.rDim[3]; //InVolSz! + //next- prepare to write + lBuffIn := lHdr.ImgBuffer; + GetMem(lBuffOut,lOutVolItems); + for lI := 1 to lOutVolItems do + lBuffOut[lI] := 0; //set all to zero + //find bounding box for overlay, and create lookup tables + for lI := 1 to 3 do begin + lScale := lOut.rMM[lI] / lIn.rMM[lI]; + getmem(lLUTra[lI],lOut.rDim[lI]*4); + getmem(lLUTmodra[lI],lOut.rDim[lI]*4); + lMin[lI] := maxint; + lMax[lI] := -1; + for lPos := 1 to lOut.rDim[lI] do begin + if lBackgroundImg.OverlaySmooth then begin + lFloatPos := ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] {-0.5}; + lLUTra[lI][lPos] := trunc ( lFloatPos ); + lLUTmodra[lI][lPos] := ( frac (lFloatPos )); + end else begin + lLUTra[lI][lPos] := round ( ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] ); + lLUTmodra[lI][lPos] :=0;//not used + end; + if (lLUTra[lI][lPos] > 0) and (lMin[lI]=MaxInt){(lLUTra[lI][lPos] < lMin[lI])} then + lMin[lI] := lPos; + if (lLUTra[lI][lPos] < lIn.rDim[lI]) {<=} then + lMax[lI] := lPos; + end; + end; + for lI := 1 to 3 do + if lMin[lI] >= lMax[lI] then goto 345; //do after previous loop so we are sure all buffers used + ImgForm.ProgressBar1.Min := lMin[3]; + ImgForm.ProgressBar1.Max := lMax[3]; + if gBGImg.ResizeBeforeRescale > 1 then begin //trilinear + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3][lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2][lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1][lX]; + lXModLo := 1 - lXmodHi; + lBuffOut[lOutZPos+lOutYPos+lX] := round( + lBuffIn[lInZPos+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn[lInZPos+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn[lInZPos+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn[lInZPos+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn[lInZPosHi+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn[lInZPosHi+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn[lInZPosHi+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn[lInZPosHi+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModHi) ; + end; //for X + end; //for Y + end; //for Z + end else begin //nearest neighbor + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + for lX := lMin[1] to lMax[1] do begin + lBuffOut[lOutZPos+lOutYPos+lX] := lBuffIn[lInZPos+lInYPos+lLUTra[1][lX]]; + end; //for X + end; //for Y + end; //for Z +end; //if..smooth...else + ImgForm.ProgressBar1.Position := lMin[3]; + 345: + for lI := 1 to 3 do begin + freemem(lLUTra[lI]); + freemem(lLUTmodra[lI]); + end; + //Output dimensions: size of background image + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut),lOutVolItems); + FreeMem(lBuffOut); + lHdr.SameDimsAsBG := true; + //ImgForm.StatusLabel.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); +end; //procedure OrthogonalResliceImg + +procedure OrthogonalResliceImgBuffer16 (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); +label 345; +Type + TXImg = record //Next: analyze Format Header structure + rDim: array [1..3] of integer; + rOri,rMM: array [1..3] of single; + rSliceSz: integer; + end; //TNIFTIhdr Header Structure +var + //lStartTime,lEndTime: DWord; + lIn,lOut: TXImg; + lBuffOutUnaligned: Bytep; + lBuffIn16,lBuffOut16 : SmallIntP; + lX,lY,lZ,lI,lPos,lOutVolItems,lOutVolBytes,lInZPos,lInYPos,lOutZPos,lOutYPos,lInZPosHi,lInYPosHi: integer; + lXmodLo,lXmodHi,lYmodLo,lYmodHi,lZmodLo,lZmodHi: single; + lScale,lFloatPos: single; + lMin,lMax: array [1..3] of integer; + lLUTra: array [1..3] of LongIntp; + lLUTmodRA: array [1..3] of Singlep; +begin + //lStartTime := GetTickCount; + //Input dimensions: raw dimensions of overlay + for lI := 1 to 3 do begin + lIn.rDim[lI] := lHdr.NIFTIhdr.dim[lI]; + lIn.rMM[lI] := lHdr.NIFTIhdr.pixdim[lI]; + lIn.rOri[lI] := lHdr.Ori[lI]; + end; + lIn.rSliceSz := lIn.rDim[1]*lIn.rDim[2]; + //Output to background size + for lI := 1 to 3 do begin + lOut.rDim[lI] := lBackgroundImg.ScrnDim[lI]; + lOut.rMM[lI] := lBackgroundImg.ScrnMM[lI]; + lOut.rOri[lI] := lBackgroundImg.ScrnOri[lI]; + end; + lOut.rSliceSz := lOut.rDim[1]*lOut.rDim[2]; + lOutVolItems := lOut.rSliceSz * lOut.rDim[3]; //InVolSz! + lOutVolBytes := lOutVolItems * 2;//*2 as 16bit + //next- prepare to write + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,lOutVolBytes+16); + lBuffOut16 := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lI := 1 to lOutVolItems do + lBuffOut16[lI] := 0; //set all to zero + //find bounding box for overlay, and create lookup tables + for lI := 1 to 3 do begin + lScale := lOut.rMM[lI] / lIn.rMM[lI]; + getmem(lLUTra[lI],lOut.rDim[lI]*4); + getmem(lLUTmodra[lI],lOut.rDim[lI]*4); + lMin[lI] := maxint; + lMax[lI] := -1; + for lPos := 1 to lOut.rDim[lI] do begin + if lBackgroundImg.OverlaySmooth then begin + lFloatPos := ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] {-0.5}; + lLUTra[lI][lPos] := trunc ( lFloatPos ); + lLUTmodra[lI][lPos] := ( frac (lFloatPos )); + end else begin + lLUTra[lI][lPos] := round ( ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] ); + lLUTmodra[lI][lPos] :=0;//not used + end; + if (lLUTra[lI][lPos] > 0) and (lMin[lI]=MaxInt){(lLUTra[lI][lPos] < lMin[lI])} then + lMin[lI] := lPos; + if (lLUTra[lI][lPos] < lIn.rDim[lI]) {<=} then + lMax[lI] := lPos; + end; + end; + for lI := 1 to 3 do + if lMin[lI] >= lMax[lI] then goto 345; //do after previous loop so we are sure all buffers used + ImgForm.ProgressBar1.Min := lMin[3]; + ImgForm.ProgressBar1.Max := lMax[3]; + if gBGImg.ResizeBeforeRescale > 1 then begin //trilinear + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3][lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2][lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1][lX]; + lXModLo := 1 - lXmodHi; + lBuffOut16[lOutZPos+lOutYPos+lX] := round( + lBuffIn16[lInZPos+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn16[lInZPos+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn16[lInZPos+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn16[lInZPos+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn16[lInZPosHi+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn16[lInZPosHi+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn16[lInZPosHi+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn16[lInZPosHi+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModHi + ) ;{} + end; //for X + end; //for Y + end; //for Z + end else begin //nearest neighbor + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + for lX := lMin[1] to lMax[1] do begin + lBuffOut16[lOutZPos+lOutYPos+lX] := lBuffIn16[lInZPos+lInYPos+lLUTra[1][lX]]; + end; //for X + end; //for Y + end; //for Z +end; //if..smooth...else + ImgForm.ProgressBar1.Position := lMin[3]; + 345: + for lI := 1 to 3 do begin + freemem(lLUTra[lI]); + freemem(lLUTmodra[lI]); + end; + //Output dimensions: size of background image + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolBytes + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut16),lOutVolBytes); + FreeMem(lBuffOutUnaligned); + lHdr.SameDimsAsBG := true; +end; //procedure OrthogonalResliceImgBuffer16 + +procedure OrthogonalResliceImgBuffer32 (var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr); +label 345; +Type + TXImg = record //Next: analyze Format Header structure + rDim: array [1..3] of integer; + rOri,rMM: array [1..3] of single; + rSliceSz: integer; + end; //TNIFTIhdr Header Structure +var + //lStartTime,lEndTime: DWord; + lIn,lOut: TXImg; + lBuffOutUnaligned: Bytep; + lBuffIn32,lBuffOut32 : SingleP; + lX,lY,lZ,lI,lPos,lOutVolItems,lOutVolBytes,lInZPos,lInYPos,lOutZPos,lOutYPos,lInZPosHi,lInYPosHi: integer; + lXmodLo,lXmodHi,lYmodLo,lYmodHi,lZmodLo,lZmodHi: single; + lScale,lFloatPos: single; + lMin,lMax: array [1..3] of integer; + lLUTra: array [1..3] of LongIntp; + lLUTmodRA: array [1..3] of Singlep; +begin + //lStartTime := GetTickCount; + //Input dimensions: raw dimensions of overlay + for lI := 1 to 3 do begin + lIn.rDim[lI] := lHdr.NIFTIhdr.dim[lI]; + lIn.rMM[lI] := lHdr.NIFTIhdr.pixdim[lI]; + lIn.rOri[lI] := lHdr.Ori[lI]; + end; + lIn.rSliceSz := lIn.rDim[1]*lIn.rDim[2]; + //Output to background size + for lI := 1 to 3 do begin + lOut.rDim[lI] := lBackgroundImg.ScrnDim[lI]; + lOut.rMM[lI] := lBackgroundImg.ScrnMM[lI]; + lOut.rOri[lI] := lBackgroundImg.ScrnOri[lI]; + end; + lOut.rSliceSz := lOut.rDim[1]*lOut.rDim[2]; + lOutVolItems := lOut.rSliceSz * lOut.rDim[3]; //InVolSz! + lOutVolBytes := lOutVolItems * 4;//*4 as 32bit + //next- prepare to write + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,lOutVolBytes+16); + lBuffOut32 := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lI := 1 to lOutVolItems do + lBuffOut32[lI] := 0; //set all to zero + //find bounding box for overlay, and create lookup tables + for lI := 1 to 3 do begin + lScale := lOut.rMM[lI] / lIn.rMM[lI]; + getmem(lLUTra[lI],lOut.rDim[lI]*4); + getmem(lLUTmodra[lI],lOut.rDim[lI]*4); + lMin[lI] := maxint; + lMax[lI] := -1; + for lPos := 1 to lOut.rDim[lI] do begin + if lBackgroundImg.OverlaySmooth then begin + lFloatPos := ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] {-0.5}; + lLUTra[lI][lPos] := trunc ( lFloatPos ); + lLUTmodra[lI][lPos] := ( frac (lFloatPos )); + end else begin + lLUTra[lI][lPos] := round ( ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] ); + lLUTmodra[lI][lPos] :=0;//not used + end; + if (lLUTra[lI][lPos] > 0) and (lMin[lI]=MaxInt){(lLUTra[lI][lPos] < lMin[lI])} then + lMin[lI] := lPos; + if (lLUTra[lI][lPos] < lIn.rDim[lI]) {<=} then + lMax[lI] := lPos; + end; + end; + for lI := 1 to 3 do + if lMin[lI] >= lMax[lI] then goto 345; //do after previous loop so we are sure all buffers used + ImgForm.ProgressBar1.Min := lMin[3]; + ImgForm.ProgressBar1.Max := lMax[3]; + if gBGImg.ResizeBeforeRescale > 1 then begin //trilinear + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3][lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2][lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1][lX]; + lXModLo := 1 - lXmodHi; + lBuffOut32[lOutZPos+lOutYPos+lX] := ( + lBuffIn32[lInZPos+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn32[lInZPos+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn32[lInZPos+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn32[lInZPos+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn32[lInZPosHi+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn32[lInZPosHi+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn32[lInZPosHi+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn32[lInZPosHi+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModHi + ) ;{} + end; //for X + end; //for Y + end; //for Z + end else begin //nearest neighbor + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + for lX := lMin[1] to lMax[1] do begin + lBuffOut32[lOutZPos+lOutYPos+lX] := lBuffIn32[lInZPos+lInYPos+lLUTra[1][lX]]; + end; //for X + end; //for Y + end; //for Z +end; //if..smooth...else + ImgForm.ProgressBar1.Position := lMin[3]; + 345: + for lI := 1 to 3 do begin + freemem(lLUTra[lI]); + freemem(lLUTmodra[lI]); + end; + //Output dimensions: size of background image + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolBytes + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut32),lOutVolBytes); + FreeMem(lBuffOutUnaligned); + lHdr.SameDimsAsBG := true; +end; //procedure OrthogonalResliceImgBuffer32 *) + +procedure FindMatrixPt (lX,lY,lZ: single; var lXout,lYOut,lZOut: single; var lMatrix: TMatrix); +//given voxel lX,lY,lZ returns the rotated coordinate Xout,Yout,Zout 3 +begin + lXOut := (lX*lMatrix.matrix[1,1])+(lY*lMatrix.matrix[1,2])+(lZ*lMatrix.matrix[1,3])+lMatrix.matrix[1,4]; + lYOut := (lX*lMatrix.matrix[2,1])+(lY*lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[2,3])+lMatrix.matrix[2,4]; + lZOut := (lX*lMatrix.matrix[3,1])+(lY*lMatrix.matrix[3,2])+(lZ*lMatrix.matrix[3,3])+lMatrix.matrix[3,4]; +end; + +procedure CheckMaxMin(var lX,lY,lZ,lXMax,lYMax,lZMax,lXMin,lYMin,lZMin: single); +begin + if lX > lXMax then lXMax := lX; + if lY > lYMax then lYMax := lY; + if lZ > lZMax then lZMax := lZ; + if lX < lXMin then lXMin := lX; + if lY < lYMin then lYMin := lY; + if lZ < lZMin then lZMin := lZ; +end; + +function FindOriMM (lX1,lY1,lZ1,lX2,lY2,lZ2: integer; var lMatrix: TMatrix): single; +var + lXdx,lYdx,lZdx,lXmm1,lYmm1,lZmm1,lXmm2,lYmm2,lZmm2: single; +begin + FindMatrixPt(lX1,lY1,lZ1,lXmm1,lYmm1,lZmm1,lMatrix); + FindMatrixPt(lX2,lY2,lZ2,lXmm2,lYmm2,lZmm2,lMatrix); + lXdx := abs(lXmm1-lXmm2); + lYdx := abs(lYmm1-lYmm2); + lZdx := abs(lZmm1-lZmm2); + if (lXdx > lYdx) and (lXdx > lZdx) then begin //X greatest + result := lXmm1; + end else if (lYdx > lZdx) then begin //Y greatest + result := lYmm1; + end else begin //Z greatest + result := lZmm1; + end; + result := -(result); + //result := sqrt( sqr(lXmm1-lXmm2)+sqr(lYmm1-lYmm2)+sqr(lZmm1-lZmm2) ); + //fx(lXmm1,lXmm2,result); +end; + +(*procedure ReportMatrix (lM:TMatrix); +const + kCR = chr (13); +begin + showmessage(RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+kCR+ + RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+kCR+ + RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+kCR + ); +end;*) + +procedure FindMatrixBounds (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; lReslice: boolean); +label 121; +var + lMatrix: TMatrix; + lPos,lPass: integer; + lXc,lYc,lZc,lXmin,lXMax,lYMin,lYMax,lZMin,lZMax,lX,lY,lZ,lmmMin,lDimMMMax: single; +begin + if not lReslice then begin //Dec06 + lBGImg.ScrnDim[1] := lHdr.NIFTIhdr.Dim[1];//+0.5 Dec06 + lBGImg.ScrnDim[2] := lHdr.NIFTIhdr.Dim[2];//+0.5 Dec06 + lBGImg.ScrnDim[3] := lHdr.NIFTIhdr.Dim[3];//+0.5 Dec06 + lBGImg.ScrnMM[1] := lHdr.NIFTIhdr.pixdim[1]; + lBGImg.ScrnMM[2] := lHdr.NIFTIhdr.pixdim[2]; + lBGImg.ScrnMM[3] := lHdr.NIFTIhdr.pixdim[3]; + //Sept07 -estimate origin + lBGImg.ScrnOri[1] := lBGImg.ScrnDim[1] div 2; + lBGImg.ScrnOri[2] := lBGImg.ScrnDim[2] div 2; + lBGImg.ScrnOri[3] := lBGImg.ScrnDim[3] div 2; + if lHdr.NIfTItransform then begin + lBGImg.ScrnOri[1] := 0; + lBGImg.ScrnOri[2] := 0; + lBGImg.ScrnOri[3] := 0; + mm2Voxel (lBGImg.ScrnOri[1],lBGImg.ScrnOri[2],lBGImg.ScrnOri[3], lBGImg.invMat);//vcx +(* lMatrix := lHdr.Mat; + if lBGImg.ScrnMM[1] <> 0 then + lBGImg.ScrnOri[1] := 1+FindOriMM (0,0,0,lBGImg.ScrnDim[1]-1,0,0, lMatrix)/lBGImg.ScrnMM[1]; + if lBGImg.ScrnMM[2] <> 0 then + lBGImg.ScrnOri[2] := 1+FindOriMM (0,0,0,0,lBGImg.ScrnDim[2]-1,0, lMatrix)/lBGImg.ScrnMM[2]; + if lBGImg.ScrnMM[3] <> 0 then + lBGImg.ScrnOri[3] := 1+FindOriMM (0,0,0,0,0,lBGImg.ScrnDim[3]-1, lMatrix)/lBGImg.ScrnMM[3]; + *) + end; + //end estimate origin + //fx(lBGImg.ScrnOri[1],lBGImg.ScrnMM[1],lBGImg.ScrnOri[3],1112); + exit; + end; + lPass := 0; + if (abs(lHdr.Mat.matrix[1,4]) > maxInt) or (abs(lHdr.Mat.matrix[2,4]) > MaxInt) or (abs(lHdr.Mat.matrix[3,4]) > maxint) then begin + showmessage('Error: the origin is not plausible.'); + lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; + + end; +121: + inc(lPass); + lMatrix := lHdr.Mat; + FindMatrixPt(0,0,0,lX,lY,lZ,lMatrix); + lXMax := lX; + lYMax := lY; + lZMax := lZ; + lXMin := lX; + lYMin := lY; + lZMin := lZ; + for lPos := 1 to 7 do begin + if odd(lPos) then + lXc := lHdr.NIFTIhdr.Dim[1]-1 + else + lXc := 0; + if odd(lPos shr 1) then + lYc := lHdr.NIFTIhdr.Dim[2]-1 + else + lYc := 0; + if odd(lPos shr 2) then + lZc := lHdr.NIFTIhdr.Dim[3]-1 + else + lZc := 0; + //showmessage(floattostr(lXc)+' '+floattostr(lYc)+' '+floattostr(lZc) ); + FindMatrixPt(lXc,lYc,lZc,lX,lY,lZ,lMatrix); + CheckMaxMin(lX,lY,lZ,lXMax,lYMax,lZMax,lXMin,lYMin,lZMin); + end; + //fx(lXMax,lXMin,lZMax,lZMin); + //next find min MM + //fx(lZMin,lZMax); + lmmMin := abs(lHdr.NIFTIhdr.pixdim[1]); + if abs(lHdr.NIFTIhdr.pixdim[2]) < lmmMin then lmmMin := abs(lHdr.NIFTIhdr.pixdim[2]); + if abs(lHdr.NIFTIhdr.pixdim[3]) < lmmMin then lmmMin := abs(lHdr.NIFTIhdr.pixdim[3]); + if lmmMin = 0 then lmmMin := 1; + //next find max Dim + lDimMMMax := abs(lXMax-lXMin); + if abs(lYMax-lYMin) > lDimMMMax then lDimMMMax := abs(lYMax-lYMin); + if abs(lZMax-lZMin) > lDimMMMax then lDimMMMax := abs(lZMax-lZMin); + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scalled by smallest mm, try largest mm + lmmMin := lHdr.NIFTIhdr.pixdim[1]; + if lHdr.NIFTIhdr.pixdim[2] > lmmMin then lmmMin := lHdr.NIFTIhdr.pixdim[2]; + if lHdr.NIFTIhdr.pixdim[3] > lmmMin then lmmMin := lHdr.NIFTIhdr.pixdim[3]; + if lmmMin = 0 then lmmMin := 1; + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scalled by largest mm, try isotropic 1mm + lmmMin := 1; + end; + if (1+trunc(lDimMMMax/lmmMin)) > gBGImg.MaxDim then begin + //image will be too large if isotropically scaled by 1mm, find optimal scaling factor + lmmMin := lDimMMMax/gBGImg.MaxDim; + Showmessage('Maximum dimension is >'+inttostr(gBGImg.MaxDim)+' voxels. Therefore the image will resolution will be reduced. If you have a fast computer, you may consider increasing the ''MaxDim'' value saved in the mricron.ini file.'); + //showmessage('Warning: having to downsample this large image - you may wish to view this image with MRIcro.'); + end; + //showmessage( floattostr(lmmMin)); + //lmmMin := 3.5;// + end; + lBGImg.ScrnDim[1] := 1+trunc(0.5+((lXMax-lXMin)/lmmMin));//+0.5 May06 + lBGImg.ScrnDim[2] := 1+trunc(0.5+((lYMax-lYMin)/lmmMin));//+0.5 May06 + lBGImg.ScrnDim[3] := 1+trunc(0.5+((lZMax-lZMin)/lmmMin));//+0.5 May06 + //fx(lBGImg.ScrnDim[3],lmmMin); + lBGImg.ScrnMM[1] := lmmMin; + lBGImg.ScrnMM[2] := lmmMin; + lBGImg.ScrnMM[3] := lmmMin; + //fx(lBGImg.ScrnDim[1],lBGImg.ScrnDim[2],lBGImg.ScrnDim[3]); + //showmessage(floattostr(lZMin)+'...'+floattostr(lZMax)+' '+floattostr((lZMin)/lmmMin)); + lBGImg.ScrnOri[1] := -(((lXMin)/lmmMin))+1; + lBGImg.ScrnOri[2] := -(((lYMin)/lmmMin))+1; + lBGImg.ScrnOri[3] := -(((lZMin)/lmmMin))+1; + + //fx(lBGImg.ScrnOri[1],lBGImg.ScrnOri[2],lBGImg.ScrnOri[3]); + if (lXMin > 0) and (lYMin > 0) and (lZMin > 0) and (lPass <= 2) then begin + lHdr.Mat.matrix[1,4] := -lHdr.Mat.matrix[1,4]; + lHdr.Mat.matrix[2,4] := -lHdr.Mat.matrix[2,4]; + lHdr.Mat.matrix[3,4] := -lHdr.Mat.matrix[3,4]; + {lHdr.NIFTIhdr.srow_x[3] := -lHdr.NIFTIhdr.srow_x[3]; + lHdr.NIFTIhdr.srow_y[3] := -lHdr.NIFTIhdr.srow_y[3]; + lHdr.NIFTIhdr.srow_z[3] := -lHdr.NIFTIhdr.srow_z[3];} + {lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; } + if lPass = 1 then begin + Showmessage('The origin is not in the image... check your transformation matrix - will attempt to invert offsets'); + goto 121; + end else if lPass = 2 then begin + lHdr.Mat.matrix[1,4] := 0; + lHdr.Mat.matrix[2,4] := 0; + lHdr.Mat.matrix[3,4] := 0; + Showmessage('The origin is not in the image... check your transformation matrix - will attempt to zero offsets'); + goto 121; + end else + showmessage('The origin is not in the image... unable to correct.'); + end; +end; + +function mat44_inverse(var R: Tmatrix ) : TMatrix; +var + r11,r12,r13,r21,r22,r23,r31,r32,r33,v1,v2,v3 , deti : double; + Q: TMatrix; +begin + r11 := R.matrix[1,1]; r12 := R.matrix[1,2]; r13 := R.matrix[1,3]; //* [ r11 r12 r13 v1 ] */ + r21 := R.matrix[2,1]; r22 := R.matrix[2,2]; r23 := R.matrix[2,3]; //* [ r21 r22 r23 v2 ] */ + r31 := R.matrix[3,1]; r32 := R.matrix[3,2]; r33 := R.matrix[3,3]; //* [ r31 r32 r33 v3 ] */ + v1 := R.matrix[1,4]; v2 := R.matrix[2,4]; v3 := R.matrix[3,4]; //* [ 0 0 0 1 ] */ + + deti := r11*r22*r33-r11*r32*r23-r21*r12*r33 + +r21*r32*r13+r31*r12*r23-r31*r22*r13 ; + + if( deti <> 0.0 ) then + deti := 1.0 / deti ; + + Q.matrix[1,1] := deti*( r22*r33-r32*r23) ; + Q.matrix[1,2] := deti*(-r12*r33+r32*r13) ; + Q.matrix[1,3] := deti*( r12*r23-r22*r13) ; + Q.matrix[1,4] := deti*(-r12*r23*v3+r12*v2*r33+r22*r13*v3 + -r22*v1*r33-r32*r13*v2+r32*v1*r23) ; + + Q.matrix[2,1] := deti*(-r21*r33+r31*r23) ; + Q.matrix[2,2] := deti*( r11*r33-r31*r13) ; + Q.matrix[2,3] := deti*(-r11*r23+r21*r13) ; + Q.matrix[2,4] := deti*( r11*r23*v3-r11*v2*r33-r21*r13*v3 + +r21*v1*r33+r31*r13*v2-r31*v1*r23) ; + + Q.matrix[3,1] := deti*( r21*r32-r31*r22) ; + Q.matrix[3,2] := deti*(-r11*r32+r31*r12) ; + Q.matrix[3,3] := deti*( r11*r22-r21*r12) ; + Q.matrix[3,4] := deti*(-r11*r22*v3+r11*r32*v2+r21*r12*v3 + -r21*r32*v1-r31*r12*v2+r31*r22*v1) ; + + Q.matrix[4,1] := 0; Q.matrix[4,2] := 0; Q.matrix[4,3] := 0.0 ; + Q.matrix[4,4] := 1;// (deti == 0.0l) ? 0.0l : 1.0l ; /* failure flag if deti == 0 */ + + result := Q ; +end; + +function TestSameOrtho(var lHdr: TMRIcroHdr): boolean; +var + lRow,lCol: integer; +begin + result := false; + for lRow := 1 to 3 do + for lCol := 1 to 3 do + if (lRow=lCol) then begin + if lHdr.Mat.Matrix[lRow,lCol] <= 0 then + exit; + end else + if lHdr.Mat.Matrix[lRow,lCol] <> 0 then + exit; + result := true; +end; + +function OrthoReslice (var lBGImg: TBGImg; var lHdr: TMRIcroHdr): boolean; +label + 666; +Type + TXImg = record //Next: analyze Format Header structure + rDim: array [1..3] of integer; + rOri,rMM: array [1..3] of single; + rSliceSz: integer; + end; //TNIFTIhdr Header Structure +var + lIn,lOut: TXImg; + lBuffIn,lBuffOut,lBuffOutUnaligned: Bytep; + lBuffIn16,lBuffOut16 : SmallIntP; + lBuffIn32,lBuffOut32 : SingleP; + lX,lY,lZ,lI,lPos,lOutVolItems,lInZPos,lInYPos,lOutZPos,lOutYPos,lInZPosHi,lInYPosHi: integer; + lXmodLo,lXmodHi,lYmodLo,lYmodHi,lZmodLo,lZmodHi: single; + lScale,lFloatPos: single; + lMin,lMax: array [1..3] of integer; + lLUTra: array [1..3] of LongIntp; + lLUTmodRA: array [1..3] of Singlep; +begin + result := false; + if not TestSameOrtho(lHdr) then exit; + + for lI := 1 to 3 do begin + lIn.rDim[lI] := lHdr.NIFTIhdr.dim[lI]; + lIn.rMM[lI] := lHdr.NIFTIhdr.pixdim[lI]; + //if lHdr.NIFTIhdr.pixdim[lI] <> 0 then + lIn.rOri[lI] := (abs(lHdr.Mat.Matrix[lI,4]))/abs(lHdr.NIFTIhdr.pixdim[lI])+1; //May07 + end; + lIn.rSliceSz := lIn.rDim[1]*lIn.rDim[2]; + for lI := 1 to 3 do begin + lOut.rDim[lI] := lBGImg.ScrnDim[lI]; + lOut.rMM[lI] := lBGImg.ScrnMM[lI]; + lOut.rOri[lI] := lBGImg.ScrnOri[lI]; + end; + //lOut.rOri[3] := 12.5; + lOut.rSliceSz := lOut.rDim[1]*lOut.rDim[2]; + lOutVolItems := lOut.rSliceSz * lOut.rDim[3]; //InVolSz! + //find bounding box for overlay, and create lookup tables + for lI := 1 to 3 do begin + lScale := lOut.rMM[lI] / lIn.rMM[lI]; + getmem(lLUTra[lI],lOut.rDim[lI]*4); + getmem(lLUTmodra[lI],lOut.rDim[lI]*4); + lMin[lI] := maxint; + lMax[lI] := -1; + + for lPos := 1 to lOut.rDim[lI] do begin + if lBGImg.OverlaySmooth then begin + lFloatPos := ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] {-0.5}; + lLUTra[lI][lPos] := trunc ( lFloatPos ); + lLUTmodra[lI][lPos] := ( frac (lFloatPos )); + end else begin + lLUTra[lI]^[lPos] := round ( ((lPos-lOut.rOri[lI]) *lScale)+lIn.rOri[lI] ); + lLUTmodra[lI]^[lPos] :=0;//not used + end; + if (lLUTra[lI][lPos] > 0) and (lMin[lI]=MaxInt) then + lMin[lI] := lPos; + if (lLUTra[lI][lPos] < lIn.rDim[lI]) then + lMax[lI] := lPos; + end; + end; + //for lI := 1 to 3 do fx( lMin[lI],lMax[lI],lOut.rDim[lI]);//fx( lOut.rMM[lI],lIn.rMM[lI]); + for lI := 1 to 3 do + if lMin[lI] > lMax[lI] then begin + showmessage ('Unusual rotation matrix - consider viewing with MRIcro.');//goto 345; //do after previous loop so we are sure all buffers used + goto 666; + end; + lMax[1] := lMax[1] -1;{-1 as we do not want to sample past edge} + //next portion could be accelerated for situations where lBGImg.OverlaySmooth = false + if lHdr.ImgBufferBPP = 4 then begin //next- 32 bit + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + lBuffOut32 := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut32[lX] := 0; //set all to zero + for lZ := lMin[3] to lMax[3] do begin + //Mar2007 ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3][lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2][lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1][lX]; + lXModLo := 1 - lXmodHi; + lBuffOut32[lOutZPos+lOutYPos+lX] := ( + lBuffIn32[lInZPos+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn32[lInZPos+lInYPos+lLUTra[1][lX]+1]*lXModHi*lYModLo*lZModLo + + lBuffIn32[lInZPos+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn32[lInZPos+lInYPosHi+lLUTra[1][lX]+1]*lXModHi*lYModHi*lZModLo + + lBuffIn32[lInZPosHi+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn32[lInZPosHi+lInYPos+lLUTra[1][lX]+1]*lXModHi*lYModLo*lZModHi + + lBuffIn32[lInZPosHi+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn32[lInZPosHi+lInYPosHi+lLUTra[1][lX]+1]*lXModHi*lYModHi*lZModHi) ; + end; //for X + end; //for Y + end; //for Z + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + lHdr.ImgBuffer := ByteP ($fffffff0 and (integer(lHdr.ImgBufferUnaligned )+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut32),(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin //next- 16 bit + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + lBuffOut16 := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut16[lX] := 0; //set all to zero + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3][lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2][lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1][lX]; + lXModLo := 1 - lXmodHi; + lBuffOut16[lOutZPos+lOutYPos+lX] := round( + lBuffIn16[lInZPos+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn16[lInZPos+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn16[lInZPos+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn16[lInZPos+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn16[lInZPosHi+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn16[lInZPosHi+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn16[lInZPosHi+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn16[lInZPosHi+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModHi) ; + end; //for X + end; //for Y + end; //for Z + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut16),(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin //next- 8 bit + lBuffIn := lHdr.ImgBuffer; + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + //for lI := 1 to lOutVolItems do lBuffOut[lI] := 0; //set all to zero + for lZ := lMin[3] to lMax[3] do begin + ImgForm.ProgressBar1.Position := lZ; + lOutZPos := (lZ-1) * lOut.rSliceSz; + lInZPos:= (lLUTra[3][lZ]-1) * lIn.rSliceSz; + lInZPosHi := lInZPos + lIn.rSliceSz; + lZmodHi := lLUTmodra[3][lZ]; + lZModLo := 1 - lZmodHi; + for lY := lMin[2] to lMax[2] do begin + lOutYPos := (lY-1) * lOut.rDim[1]; + lInYPos := (lLUTra[2][lY]-1) * lIn.rDim[1]; //number of lines + lInYPosHi := lInYPos + lIn.rDim[1]; + lYmodHi := lLUTmodra[2][lY]; + lYModLo := 1 - lYmodHi; + for lX := lMin[1] to lMax[1] do begin + lXmodHi := lLUTmodra[1][lX]; + lXModLo := 1 - lXmodHi; + lBuffOut[lOutZPos+lOutYPos+lX] := round( + lBuffIn[lInZPos+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModLo + + lBuffIn[lInZPos+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModLo + + lBuffIn[lInZPos+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModLo + + lBuffIn[lInZPos+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModLo + + lBuffIn[lInZPosHi+lInYPos+lLUTra[1][lX]]*lXModLo*lYModLo*lZModHi + + lBuffIn[lInZPosHi+lInYPos+lLUTra[1][lX+1]]*lXModHi*lYModLo*lZModHi + + lBuffIn[lInZPosHi+lInYPosHi+lLUTra[1][lX]]*lXModLo*lYModHi*lZModHi + + lBuffIn[lInZPosHi+lInYPosHi+lLUTra[1][lX+1]]*lXModHi*lYModHi*lZModHi); + end; //for X + end; //for Y + end; //for Z + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut),lOutVolItems); + FreeMem(lBuffOut); + end else + Showmessage('Unsupported BPP '+inttostr(lHdr.ImgBufferBPP)); + ImgForm.ProgressBar1.Position := 0;//Mar2007 + result := true; + +666: + for lI := 1 to 3 do begin + freemem(lLUTra[lI]); + freemem(lLUTmodra[lI]); + end; + //Output dimensions: size of background image + //lEndTime := GetTickCount; + //ImgForm.Label1.caption :=('update(ms): '+inttostr(lEndTime-lStartTime)); +end; //procedure OrthogonalResliceImg + +procedure fSwap(var lX,lY: single); +var + lSwap: single; +begin + lSwap := lX; + lX := lY; + lY := lSwap; +end; + +procedure ResliceScrnImg (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; lTrilinearSmooth: boolean); +var + lOverlap: boolean; + lMinY,lMinZ,lMaxY,lMaxZ: integer; //<- used by trilinear + lXreal,lYreal,lZreal,lXrM1,lYrM1,lZrM1, //<- used by trilinear + lZr,lYr,lXr,lZx,lZy,lZz,lYx,lYy,lYz,lSwap: single; + lZ,lY,lX,lOutVolItems,lOutSliceSz,lInVolItems, + lXdimIn,lYDimIn,lZDimIn,lInSliceSz, + lOutPos,lOutDimX,lOutDimY,lOutDimZ,lSrcPos,lXo,lYo,lZo: integer; + lXxp,lXyp,lXzp: Pointer; + lXxra,lXyra,lXzra : SingleP; + lMatrix,lMatrixBG: TMatrix; + lBuffIn,lBuffOut,lBuffOutUnaligned: Bytep; + lBuffIn16,lBuffOut16 : SmallIntP;//16bit + lBuffIn32,lBuffOut32: SingleP; + begin + if SameAsBG(lBGImg,lHdr) then exit; + + if not lBGImg.Resliced then begin //2008 + Reslice_Img_To_Unaligned (gMRIcroOverlay[kBGOverlayNum].NIftiHdr, lHdr, lBGImg.OverlaySmooth); + exit; + end; + if OrthoReslice(lBGImg,lHdr) then exit; + + lOverlap := false; + lMatrix := lHdr.Mat; + lMatrix := mat44_inverse(lMatrix); + lMatrixBG := Matrix3D ( lBGImg.Scrnmm[1],0,0,0, + 0,lBGImg.Scrnmm[2],0,0, + 0,0,lBGImg.Scrnmm[3],0, + 0,0,0,1); + lMatrix.size := size3D; + lMatrix := MultiplyMatrices(lMatrix,lMatrixBG); + lXdimIn := lHdr.NiftiHdr.dim[1]; + lYdimIn := lHdr.NiftiHdr.dim[2]; + lZDimIn := lHdr.NiftiHdr.dim[3]; + lInSliceSz := lHdr.NiftiHdr.dim[1]*lHdr.NiftiHdr.dim[2]; + lInVolItems := lInSliceSz*lHdr.NiftiHdr.dim[3]; + if (lHdr.ImgBufferItems < lInVolItems) then + exit; + lBuffIn := lHdr.ImgBuffer; + lOutDimX := lBGImg.ScrnDim[1]; + lOutDimY := lBGImg.ScrnDim[2]; + lOutDimZ := lBGImg.ScrnDim[3]; + lOutSliceSz := lOutDimX*lOutDimY; + lOutVolItems := lBGImg.ScrnDim[1]*lBGImg.ScrnDim[2]*lBGImg.ScrnDim[3]; + //lStartTime := GetTickCount; + lOutPos := 0; + //start look up table... + GetMem(lXxp, (sizeof(single)* lOutDimX)+16); + GetMem(lXyp, (sizeof(single)* lOutDimX)+16); + GetMem(lXzp, (sizeof(single)* lOutDimX)+16); + lXxRA := SingleP($fffffff0 and (integer(lXxP)+15)); //data aligned to quad-word boundary + lXyRA := SingleP($fffffff0 and (integer(lXyP)+15)); //quad-word boundary + lXzRA := SingleP($fffffff0 and (integer(lXzP)+15)); //quad-word boundary + for lX := 1 to lOutDimX do begin + lXr := lX-(lBGImg.ScrnOri[1]);//* lBGImg.ScrnMM[1]) ; + //lXr := lX; + lXxRA[lX] := lXr*lMatrix.matrix[1,1]+1; + lXyRA[lX] := lXr*lMatrix.matrix[2,1]+1; + lXzRA[lX] := lXr*lMatrix.matrix[3,1]+1; + end; + //end look up table +if lTrilinearSmooth then begin //smooth data + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + lBuffOut32 := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut32[lX] := 0; //set all to zero + //core 32 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA[lX]+lYx+lZx; + lYreal := lXyRA[lX]+lYy+lZy; + lZreal := lXzRA[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lMaxY := ((lYo)*lXdimIn); + lMaxZ := ((lZo)*lInSliceSz); + lOverlap := true; + lBuffOut32[lOutPos] := ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn32[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn32[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn32[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn32[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn32[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn32[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn32[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn32[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 32 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut32),(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + lBuffOut16 := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut16[lX] := 0; //set all to zero + //core 16 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA[lX]+lYx+lZx; + lYreal := lXyRA[lX]+lYy+lZy; + lZreal := lXzRA[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lXrM1 := 1-lXreal; + lYreal := lYreal-lYo; + lYrM1 := 1-lYreal; + lZreal := lZreal-lZo; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMaxY := lMinY+lXdimIn; + lMinZ := ((lZo-1)*lInSliceSz); + lMaxZ := lMinZ+lInSliceSz; + lOverlap := true; + lBuffOut16[lOutPos] := round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn16[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn16[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn16[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn16[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn16[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn16[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn16[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn16[lXo+1+lMaxY+lMaxZ]) ); (**) + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 16 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut16),(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXreal := lXxRA[lX]+lYx+lZx; + lYreal := lXyRA[lX]+lYy+lZy; + lZreal := lXzRA[lX]+lYz+lZz; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lMaxY := ((lYo)*lXdimIn); + lMaxZ := ((lZo)*lInSliceSz); + lOverlap := true; + lBuffOut[lOutPos] := round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*lBuffIn[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*lBuffIn[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*lBuffIn[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*lBuffIn[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*lBuffIn[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*lBuffIn[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*lBuffIn[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*lBuffIn[lXo+1+lMaxY+lMaxZ]) ); + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut),lOutVolItems); + FreeMem(lBuffOut); + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); +end else begin //not trilinear - use nearest neighbor +//start nearest neighbor + + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + lBuffOut32 := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut32[lX] := 0; //set all to zero + //core 32 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA[lX]+lYx+lZx); + lYo := round(lXyRA[lX]+lYy+lZy); + lZo := round(lXzRA[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lOverlap := true; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lBuffOut32[lOutPos] := lBuffIn32[lXo+lMinY+lMinZ]; + end; + end; //for X + end; //for OutY + end; //for OutZ + //core 32 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut32),(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 2 then begin + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + lBuffOut16 := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lX := 1 to lOutVolItems do + lBuffOut16[lX] := 0; //set all to zero + //core 16 start + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA[lX]+lYx+lZx); + lYo := round(lXyRA[lX]+lYy+lZy); + lZo := round(lXzRA[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lOverlap := true; + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lBuffOut16[lOutPos] := lBuffIn16[lXo+lMinY+lMinZ]//lBuffIn16[lXo+lYo+lZo]; xxxx + + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + //core 16 end + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut16),(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lHdr.ImgBufferBPP = 1 then begin + GetMem(lBuffOut,lOutVolItems); + Fillchar(lBuffOut^,lOutVolItems,0); //set all to zero + for lZ := 1 to lOutDimZ do begin + lZr := lZ -(lBGImg.ScrnOri[3]); + lZx := lZr*lMatrix.matrix[1,3]+lMatrix.matrix[1,4]; + lZy := lZr*lMatrix.matrix[2,3]+lMatrix.matrix[2,4]; + lZz := lZr*lMatrix.matrix[3,3]+lMatrix.matrix[3,4]; + for lY := 1 to lOutDimY do begin + lYr := lY -(lBGImg.ScrnOri[2]); + lYx := lYr*lMatrix.matrix[1,2]; + lYy := lYr*lMatrix.matrix[2,2]; + lYz := lYr*lMatrix.matrix[3,2]; + for lX := 1 to lOutDimX do begin + inc(lOutPos); + lXo := round(lXxRA[lX]+lYx+lZx); + lYo := round(lXyRA[lX]+lYy+lZy); + lZo := round(lXzRA[lX]+lYz+lZz); + if (lXo > 0) and (lXo < lXDimIn) + and (lYo > 0) and (lYo < lYDimIn) and + (lZo > 0) and (lZo < lZDimIn) then begin + lMinY := ((lYo-1)*lXdimIn); + lMinZ := ((lZo-1)*lInSliceSz); + lOverlap := true; + lBuffOut[lOutPos] := lBuffIn[lXo+lMinY+lMinZ]; + end; //values in range + end; //for X + end; //for OutY + end; //for OutZ + FreeMem(lHdr.ImgBufferUnaligned); + GetMem(lHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lHdr.ImgBufferItems := lOutVolItems; + CopyMemory(Pointer(lHdr.ImgBuffer),Pointer(lBuffOut),lOutVolItems); + FreeMem(lBuffOut); + end else //unsupported bits-per-pixel dataformat + Showmessage('Unsupported BPP ='+inttostr(lHdr.ImgBufferBPP) ); + + +//end nearest neighbor +end; //end if trilinear else nearest neighbor + if not lOverlap then + showmessage('No overlap between image and background bounding box - check the transfomation matrices.'); + FreeMem(lXxp); + FreeMem(lXyp); + FreeMem(lXzp); + //lEndTime := GetTickCount; + //ImgForm.Label1.caption :=('update(ms): '+inttostr(lEndTime-lStartTime)); +end; //ResliceScrnImg + +(*procedure Reslice; +var + l: TMatrix; + lDestVolSz,lDestX,lDestY,lDestZ,lDestPos, + lX,lY,lZ, + lSrcPos,lSrcSliceSz,lSrcXSz,lSrcVolSz: integer; + lXSrc,lYSrc,lZSrc: integer; + lSrcBuffer,lDestBuffer: ByteP; + lF: File; + lFileName: string; +begin + //standard 2 func + lSrcXSz := 90;//X + lSrcSliceSz := lSrcXSz*108;//*Y + lSrcVolSz := lSrcSliceSz * 90; //*Z + Getmem(lSrcBuffer,lSrcVolSz); + fillchar(lSrcBuffer^,lSrcVolSz,255); + Move(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^,lSrcBuffer^,lSrcVolSz); + {l := Matrix3D (0.897052, 0.0144336, 0.0512677, 16.7418 , // 3D "graphics" matrix + -0.0249253, 0.958655, -0.110782, 5.96582, + -0.049872, 0.111169, 0.883145, -33.4288, + 0,0,0,1); + + l := Matrix3D(1.11086, -0.00911452, -0.0656302, -20.7374, +0.0356138, 1.02788, 0.12687, -2.48728, +0.0582482 , -0.129903 , 1.11264, 36.994, +0, 0, 0 , 1 );} +l := Matrix3D(1, 0, 0, 0, + 0, 1, 0, 0, + 0 , 0 , 2, 0, + 0, 0, 0 , 1 ); + lDestX := 91; + lDestY := 109; + lDestZ := 91; + lDestVolSz:= lDestX*lDestY*lDestZ; + Getmem(lDestBuffer,lDestVolSz); + fillchar(lDestBuffer^,lDestVolSz,0); + lDestPos := 1; + for lZ := 0 to (lDestZ-1) do begin + for lY := 0 to (lDestY-1) do begin + for lX := 0 to (lDestX-1) do begin + inc(lDestPos); + lXSrc:= round((lX*l.matrix[1,1])+(lY*l.matrix[1,2])+(lZ*l.matrix[1,3])+l.matrix[1,4]); + lYSrc := round((lX*l.matrix[2,1])+(lY*l.matrix[2,2])+(lZ*l.matrix[2,3])+l.matrix[2,4]); + lZSrc := round((lX*l.matrix[3,1])+(lY*l.matrix[3,2])+(lZ*l.matrix[3,3])+l.matrix[3,4]); + lSrcPos := lXSrc+ (lYSrc*lSrcXSz)+(lZSrc*lSrcSliceSz); + if (lSrcPos > 0) and (lSrcPos <= lSrcVolSz) then + lDestBuffer[lDestPos] := lSrcBuffer[lSrcPos]; + end; //for lX + end; //for lY + end; //for lZ + Freemem(lSrcBuffer); + lFilename := 'c:\tx2.img'; + //lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lDestVolSz); + BlockWrite(lF,lDestBuffer^,1); + CloseFile(lF); + Filemode := 2; + Freemem(lDestBuffer); +end; //Reslice *) + +procedure InvertScrnBuffer(var lHdr: TMRIcroHdr); +var lPos: integer; +begin + if lHdr.ScrnBufferItems < 1 then exit; + lHdr.Zero8Bit := lHdr.Zero8Bit+(255*lHdr.Slope8bit); + lHdr.Slope8bit := -lHdr.Slope8bit; + for lPos := 1 to lHdr.ScrnBufferItems do + lHdr.ScrnBuffer[lPos] := 255- lHdr.ScrnBuffer[lPos]; +end; + +const + kMin8bit = 1; + +procedure RescaleImgIntensity(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr; lLayer: integer ); +var + lImgSamples: integer; +begin + if (lHdr.ImgBufferItems < 1) and (lHdr.ScrnBufferItems < 1) then + exit; //1/2008 + lImgSamples := round(ComputeImageDataBytes8bpp(lHdr)); + if (lHdr.ImgBufferItems = 0) and (lHdr.ScrnBufferItems > 0) then begin //image buffer loaded - not VOIs have screen but not img buffers + if lBackgroundImg.VOImirrored then + MirrorScrnBuffer(lBackgroundImg,lHdr); + lBackgroundImg.VOImirrored := false; + exit; + end; + if lHdr.ImgBufferItems<>lHdr.ScrnBufferItems then begin + if lHdr.ScrnBufferItems > 0 then + freemem(lHdr.ScrnBuffer); + lHdr.ScrnBufferItems := lHdr.ImgBufferItems; + GetMem(lHdr.ScrnBuffer ,lHdr.ScrnBufferItems); + end; + if (lHdr.UsesCustomPalette) and (not lHdr.UsesCustomPaletteRandomRainbow) then begin //2014 + lHdr.WindowScaledMin := kMin8bit; + lHdr.WindowScaledMax := 255; + end; + if lImgSamples < 1 then + exit; + if (lHdr.ImgBufferBPP = 4) then + RescaleImgIntensity32(lHdr) + else if (lHdr.ImgBufferBPP = 2) then + RescaleImgIntensity16(LHdr) + else if lHdr.ImgBufferBPP = 1 then + RescaleImgIntensity8(lHdr) + else if lHdr.ImgBufferBPP = 3 then + exit + else begin + showmessage(lHdr.HdrFileName +' :: Unknown Image Buffer Bytes Per Pixel: '+inttostr(lHdr.ImgBufferBPP)); + exit; + end; + //if not lHdr.SameDimsAsBG then OrthogonalResliceScrnImg (lBackgroundImg, lHdr); + //ReturnRawMinMax (lHdr, lMin,lMax,lFiltMin8bit,lFiltMax8bit); + if (lLayer <> kBGOverlayNum) and ((lHdr.WindowScaledMin <= 0) and (lHdr.WindowScaledMax <= 0)) then + InvertScrnBuffer(lHdr); + FilterScrnImg (lHdr);//,lFiltMin8bit,lFiltMax8bit); + + if lBackgroundImg.Mirror then + MirrorScrnBuffer(lBackgroundImg,lHdr); +end; //RescaleImgIntensity + +procedure ComputeFDR (var lInHdr: TMRIcroHdr; var lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01: single); +//(lImg2Load.NIFTIhdr.intent_code,round(lImg2Load.NIFTIhdr.intent_p1),lImg2Load.ImgBufferItems,lImg2Load.ImgBufferBPP,lImg2Load.ImgBuffer,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); +//procedure ComputeFDR(lStatIntent,lDF,lImgSamples,lImgBPP: integer; l32Buf:SingleP; var lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01: single); +//StatIntents in kNIFTI_INTENT_CHISQ, kNIFTI_INTENT_ZSCORE,kNIFTI_INTENT_TTEST +//Note DF meaningless for ZScore +var + lPs: SingleP; //array of tests + lStr: string; + lStatIntent,lImgSamples,lnTests,lInc,lDF: integer; + lPrevP,lP,lFDR05p, lFDR01p ,lnegFDR05p, lnegFDR01p,lnegFDR05,lnegFDR01: double; + //lHdr:TMRIcroHdr; + l32Buf : SingleP; + //lStartTime: DWord; +begin + lStatIntent := lInHdr.NIFTIhdr.intent_code; + lDF := round(lInHdr.NIFTIhdr.intent_p1); + if (lStatIntent =NIFTI_INTENT_LOG10PVAL) then begin + showmessage('Not designed for LOG10 p-values'); + exit; + end; + if ((lStatIntent = kNIFTI_INTENT_CHISQ) or (lStatIntent = kNIFTI_INTENT_TTEST)) and (lDF <= 1) then //May07 + lDF := ReadIntForm.GetInt('Please specify degrees of freedom for '+extractfilename(lInHdr.HdrFileName),1,16,32000); + lImgSamples := lInHdr.ImgBufferItems; + if (lImgSamples < 1) then exit; + ImgForm.StatusLabel.Caption := 'Computing FDR rates...'; + ImgForm.refresh; + //next: count number of tests [we could just rely on value lChiSamples to us, but perhaps value in intention is not correct + lnTests := 0; + l32Buf := SingleP(lInHdr.ImgBuffer ); + for lInc := 1 to lImgSamples do + if l32Buf[lInc] <> 0 then + inc(lnTests); + if lnTests < 1 then exit; + GetMem(lPs,lnTests*sizeof(single)); + //for lInc := 1 to lnTests do lPs[lInc] := 1; + //next - place Pvalues in array, as computing P is slow, we remember last Pvalue + lPrevP := 0; + lnTests := 0; + lP := 1; //never used + //lStartTime := GetTickCount; + //showmessage('bx'); + for lInc := 1 to lImgSamples do + if l32Buf[lInc] <> 0 then begin + inc(lnTests); + if l32Buf[lInc] <> lPrevP then + case lStatIntent of + kNIFTI_INTENT_TTEST: lP := pTdistr(lDF,l32Buf[lInc]);//slow!! 110ms + kNIFTI_INTENT_ZSCORE: lP := pNormal(l32Buf[lInc]);//slow!! 94ms + kNIFTI_INTENT_PVAL: lP := l32Buf[lInc]; + //NIFTI_INTENT_LOG10PVAL: lP := Log10toP(l32Buf[lInc]); + else {kNIFTI_INTENT_CHISQ:}begin + if l32Buf[lInc] < 0 then //MRIcro saves negative Chi + lP := 0.6 + else + lP := pChi2(lDF,l32Buf[lInc]);//slow! 47ms + end; + end; + lPs[lnTests] := lP; + lPrevP := l32Buf[lInc]; + end; //Chi <> 0 + //showmessage('dx'); + //lStartTime := GetTickCount; + //EstimateFDR(lnTests, lPs, lFDR05p, lFDR01p); //about 64ms for 1.5mm iso image - virtually all sorting + EstimateFDR2(lnTests, lPs, lFDR05p, lFDR01p,lnegFDR05p, lnegFDR01p); + + //lFDRTime := GetTickCount-lStartTime; + //ImgForm.Caption := inttostr(GetTickCount-lStartTime); + //lStartTime := GetTickCount; + //next histogram! + (* + {slower...} + for lInc := 1 to lnTests do //about 44ms for 1.5 iso image + lPs[lInc] := pNormalInvQuickApprox(lPs[lInc]); //slow!!!!!!!!! >5100ms + + + lHdr.ImgBuffer :=bytep(lPs); + lHdr.ImgBufferItems :=lnTests; + lHdr.GlMaxUnscaledS :=lPs[1]; + lHdr.GlMinUnscaledS := lPs[lnTests]; + {faster...} + lHdr.ImgBuffer :=bytep(lInHdr.ImgBuffer); + lHdr.ImgBufferItems :=lImgSamples; + lHdr.GlMaxUnscaledS :=5; + lHdr.GlMinUnscaledS := -5; + {etc} + + lHdr.ImgBufferBPP := 4; + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; + lInc := 0;//B&W + LoadMonochromeLUT(lInc,gBGImg,lHdr); + DrawHistogram(lHdr,HistogramForm.HistoImage); + HistogramForm.Caption := 'Histogram'+realtostr(lHdr.GlMinUnscaledS,6)+'..'+realtostr(lHdr.GlMaxUnscaledS,6); + HistogramForm.show; + *) + ImgForm.PGImageCor.refresh; + FreeMem(lPs); + case lStatIntent of + kNIFTI_INTENT_CHISQ:begin + lP05:= pChi2Inv(lDF,0.05); + lP01 := pChi2Inv(lDF,0.01); + lFWE05 := pChi2Inv(lDF,0.05/lnTests); + lFWE01 := pChi2Inv(lDF,0.01/lnTests); + lFDR05 := pChi2Inv(lDF,lFDR05p); + lFDR01 := pChi2Inv(lDF,lFDR01p); + lnegFDR05 := pChi2Inv(lDF,lnegFDR05p); + lnegFDR01 := pChi2Inv(lDF,lnegFDR01p); + lStr := 'X DF='+inttostr(lDF); + end; + kNIFTI_INTENT_ZSCORE: begin + lP05:= pNormalInv(0.05); + lP01 := pNormalInv(0.01); + lFWE05 := pNormalInv(0.05/lnTests); + lFWE01 := pNormalInv(0.01/lnTests); + lFDR05 := pNormalInv(lFDR05p); + lFDR01 := pNormalInv(lFDR01p); + lnegFDR05 := pNormalInv(lnegFDR05p); + lnegFDR01 := pNormalInv(lnegFDR01p); + lStr := 'Z'; + end; + kNIFTI_INTENT_TTEST: begin + lP05:= pTdistrInv(lDF,0.05); + lP01 := pTdistrInv(lDF,0.01); + lFWE05 := pTdistrInv(lDF,0.05/lnTests); + lFWE01 := pTdistrInv(lDF,0.01/lnTests); + lFDR05 := pTdistrInv(lDF,lFDR05p); + lFDR01 := pTdistrInv(lDF,lFDR01p); + lnegFDR05 := pTdistrInv(lDF,lnegFDR05p); + lnegFDR01 := pTdistrInv(lDF,lnegFDR01p); + lStr := 't DF='+inttostr(lDF); + + end; + kNIFTI_INTENT_PVAL:begin + lP05:= (0.05); + lP01 := (0.01); + lFWE05 := (0.05/lnTests); + lFWE01 := (0.01/lnTests); + lFDR05 := (lFDR05p); + lFDR01 := (lFDR01p); + lnegFDR05 := (lnegFDR05p); + lnegFDR01 := (lnegFDR01p); + lStr := 'p'; + end; + (*NIFTI_INTENT_LOG10PVAL: begin + lP05:= PtoLog10(0.05); + lP01 := PtoLog10(0.01); + lFWE05 := PtoLog10(0.05/lnTests); + lFWE01 := PtoLog10(0.01/lnTests); + lFDR05 := PtoLog10(lFDR05p); + lFDR01 := PtoLog10(lFDR01p); + lnegFDR05 := PtoLog10(lnegFDR05p); + lnegFDR01 := PtoLog10(lnegFDR01p); + + lStr := 'log10p'; + end;*) + else + Showmessage('Error: unknown stats intent'); + end; //case + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lFDR05 < lFWE05) then + lFDR05 := lFWE05; + end else if (lFDR05 > lFWE05) then + lFDR05 := lFWE05; + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lFDR01 < lFWE01) then + lFDR01 := lFWE01; + end else if (lFDR01 > lFWE01) then + lFDR01 := lFWE01; + + if (lStatIntent = kNIFTI_INTENT_PVAL) then begin + if (lnegFDR05 > -lFWE05) then + lnegFDR05 := -lFWE05; + if (lnegFDR01 > -lFWE01) then + lnegFDR01 := -lFWE01; + end else begin + if (lnegFDR05 < -lFWE05) then + lnegFDR05 := -lFWE05; + if (lnegFDR01 < -lFWE01) then + lnegFDR01 := -lFWE01; + end; + ImgForm.StatusLabel.Caption := lStr+' Tests='+inttostr(lnTests)+' p05='+realtostr(lP05,4)+ ' p01='+realtostr(lP01,4)+' fwe05='+realtostr(lFWE05,4)+ ' fwe01='+realtostr(lFWE01,4) + +' fdr05='+realtostr(lFDR05,4)+' fdr01='+realtostr(lFDR01,4) + +' -fdr05='+realtostr(lnegFDR05,4)+' -fdr01='+realtostr(lnegFDR01,4) ; + //ImgForm.Caption := inttostr(lFDRTime) +' '+inttostr(GetTickCount-lStartTime); + + (* +if (lStatIntent=kNIFTI_INTENT_TTEST) or (lStatIntent = NIFTI_INTENT_LOG10PVAL) then begin + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,0, 0,1{df},0,lnTests,kNIFTI_INTENT_ZSCORE,inttostr(lnTests) ); + lMax := l32Buf[1]; + for lInc := 1 to lImgSamples do begin + if l32Buf[lInc]<>0 then begin + case lStatIntent of + kNIFTI_INTENT_TTEST: l32Buf[lInc] := pNormalInv(pTdistr(lDF,l32Buf[lInc])); + NIFTI_INTENT_LOG10PVAL: l32Buf[lInc] := pNormalInv(Log10toP(l32Buf[lInc])); + end; //case + end; + end; + SaveAsVOIorNIFTI(bytep(l32Buf),lImgSamples,4,false,lMRIcroHdr.NiftiHdr,'Z'+inttostr(lnTests)); + +end; (**) + (* + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,0, 0,1{df},0,lnTests,NIFTI_INTENT_LOG10PVAL,inttostr(lnTests) ); + for lInc := 1 to lImgSamples do begin + lP := pNormal(l32Buf[lInc]); + if lP <> 0 then + l32Buf[lInc] := -log(lP,10) + else + l32Buf[lInc] :=0; + end; + SaveAsVOIorNIFTI(bytep(l32Buf),lImgSamples,4,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(lnTests)); + *) +end; + +function MakeSameOrtho(var lBGImg: TBGImg; var lHdr: TMRIcroHdr{; lReslice: boolean}):boolean; +var + lRow: integer; +begin + result := false; + for lRow := 1 to 3 do begin + //lHdr.NIFTIhdr.pixdim[lRow] := 1; //Apr07 + if lHdr.NIFTIhdr.dim[lRow] <>lBGImg.ScrnDim[lRow] then + exit; + end; + lHdr.Mat:= Matrix3D ( lBGImg.Scrnmm[1],0,0,-lBGImg.Scrnmm[1]*(lBGImg.ScrnOri[1]-1), + 0,lBGImg.Scrnmm[2],0,-lBGImg.Scrnmm[2]*(lBGImg.ScrnOri[2]-1), + 0,0,lBGImg.Scrnmm[3],-lBGImg.Scrnmm[3]*(lBGImg.ScrnOri[3]-1), + 0,0,0,1); + result := true; +end; + +(*procedure FindMatrixPt (lX,lY,lZ: single; var lXmm,lYmm,lZmm: single; var lMatrix: TMatrix); +//given slice X,Y,Z returns location +xxx +begin + lXOut := (lX*lMatrix.matrix[1,1])+(lY*lMatrix.matrix[1,2])+(lZ*lMatrix.matrix[1,3])+lMatrix.matrix[1,4]; + lYOut := (lX*lMatrix.matrix[2,1])+(lY*lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[2,3])+lMatrix.matrix[2,4]; + lZOut := (lX*lMatrix.matrix[3,1])+(lY*lMatrix.matrix[3,2])+(lZ*lMatrix.matrix[3,3])+lMatrix.matrix[3,4]; +end;*) + +procedure FindAlignment (var lBGImg: TBGImg; var lHdr: TMRIcroHdr); +//identifies spatial position of low X,Y,Z voxels : A/P/L/R/S/I +var + lDim: integer; + lXMid,lYMid,lZMid,laX,laY,laZ,lX,lY,lZ,lX2,lY2,lZ2: single; + lMatrix: TMatrix; +begin + lBGImg.KnownAlignment := false; + if not IsNifTiMagic (lHdr.NIFTIHdr) then + exit; //Analyze format: spatial coordinates are amibguous + if (lHdr.NIFTIhdr.sform_code <= 0) and (lHdr.NIFTIhdr.qform_code <= 0) then + exit; //NIfTI format with unspecified coordinates + lBGImg.KnownAlignment := true; + if (lBGImg.Resliced) and (lHdr.NIFTIhdr.sform_code > 0) then begin + lBGImg.MinChar[1] := 'L'; + lBGImg.MaxChar[1] := 'R'; + lBGImg.MinChar[2] := 'P'; + lBGImg.MaxChar[2] := 'A'; + lBGImg.MinChar[3] := 'I'; + lBGImg.MaxChar[3] := 'S'; + exit; + end; + (*for lDim := 1 to 3 do begin + lBGImg.MinChar[lDim] := '?'; + lBGImg.MaxChar[lDim] := '?'; + end;*) + //there are two approaches to solve this - a more elegant solution is to find the nearest orthogonal aligment + //the method below is simpler, but might give unusual results if the field of view in one dimension is much larger than another + lMatrix := lHdr.Mat; + lXMid := lHdr.NIFTIhdr.Dim[1] div 2; + lYMid := lHdr.NIFTIhdr.Dim[2] div 2; + lZMid := lHdr.NIFTIhdr.Dim[3] div 2; + for lDim := 1 to 3 do begin + if lDim = 1 then begin + FindMatrixPt(0,lYMid,lZMid,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid*2,lYMid,lZMid,lX2,lY2,lZ2,lMatrix); + end else if lDim = 2 then begin + FindMatrixPt(lXMid,0,lZMid,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid,lYMid*2,lZMid,lX2,lY2,lZ2,lMatrix); + end else begin //lDim=3 + FindMatrixPt(lXMid,lYMid,0,lX,lY,lZ,lMatrix); + FindMatrixPt(lXMid,lYMid,lZMid*2,lX2,lY2,lZ2,lMatrix); + end; + lX := lX-lX2; laX := abs(lX); + lY := lY-lY2; laY := abs(lY); + lZ := lZ-lZ2; laZ := abs(lZ); + if (laX > laY) and (laX > laZ) then begin + if lX < 0 then begin + lBGImg.MinChar[lDim] := 'L'; + lBGImg.MaxChar[lDim] := 'R'; + end else begin + lBGImg.MinChar[lDim] := 'R'; + lBGImg.MaxChar[lDim] := 'L'; + end; + end else if (laY > laZ) then begin + if lY < 0 then begin + lBGImg.MinChar[lDIm] := 'P'; + lBGImg.MaxChar[lDim] := 'A'; + end else begin + lBGImg.MinChar[lDim] := 'A'; + lBGImg.MaxChar[lDim] := 'P'; + end; + end else if (laZ > laX) then begin + if lZ < 0 then begin + lBGImg.MinChar[lDim] := 'I'; + lBGImg.MaxChar[lDim] := 'S'; + end else begin + lBGImg.MinChar[lDim] := 'S'; + lBGImg.MaxChar[lDim] := 'I'; + end; + end else begin //all dims are equal + lBGImg.MinChar[lDim] := '?'; + lBGImg.MaxChar[lDim] := '?'; + end; + end;//for each dim +end; //proc FindAlignment + +function GetTextFileRecordsWinAPI(FileName : String) : Integer; +const + BlockSize = 8192; +var + TF : THandle; + amtXFer, + fSize : DWORD; + buf : Array[0..BlockSize] of Char; +begin + //Open up file + TF := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL OR FILE_FLAG_NO_BUFFERING, 0); + fSize := GetFileSize(TF, nil); //Get the file's size + ReadFile(TF, buf, BlockSize, amtXfer, nil); //Read a block from the file + CloseHandle(TF); + Result := Round(fSize/(Pos(#13, StrPas(buf)) + 1)); +end; + +function isPlanarImg( rawRGB: bytep; lX, lY, lZ: integer): boolean ; +var + pos, posEnd, incPlanar, incPacked, byteSlice: integer; + dxPlanar, dxPacked: double; +begin + //determine if RGB image is PACKED TRIPLETS (RGBRGBRGB...) or planar (RR..RGG..GBB..B) + //assumes strong correlation between voxel and neighbor on next line + result := false; + if (lY < 2) then exit; //requires at least 2 rows of data + incPlanar := lX; //increment next row of PLANAR image + incPacked := lX * 3; //increment next row of PACKED image + byteSlice := incPacked * lY; //bytes per 3D slice of RGB data + dxPlanar := 0.0;//difference in PLANAR + dxPacked := 0.0;//difference in PACKED + pos := ((lZ div 2) * byteSlice)+1; //offset to middle slice for 3D data + posEnd := pos + byteSlice - incPacked; + while (pos <= posEnd) do begin + dxPlanar := dxPlanar + abs(rawRGB[pos]-rawRGB[pos+incPlanar]); + dxPacked := dxPacked + abs(rawRGB[pos]-rawRGB[pos+incPacked]); + pos := pos + 1; + end; + result := (dxPlanar < dxPacked); +end; + +function ParseRGB (var lHdr: TMRIcroHdr): boolean;//RGB +//red green blue saved as contiguous planes... +var + lInSlice,lOutSlice,lZ,lSliceSz,lSliceVox, lInPos, lOutPos: integer; + isPlanarRGB: boolean; + lP: bytep; +begin + result := false; + lSliceSz := lHdr.NIFTIhdr.Dim[1]*lHdr.NIFTIhdr.Dim[2]; + lZ := lSliceSz * 3 * lHdr.NIFTIhdr.Dim[3]; + if lZ < 1 then exit; + getmem( lP,lZ); + Move(lHdr.ImgBuffer^,lP^,lZ); + freemem(lHdr.ImgBufferUnaligned); + lZ := lSliceSz * lHdr.NIFTIhdr.Dim[3]; + GetMem(lHdr.ImgBufferUnaligned ,lZ+16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + if gBGImg.PlanarRGB = 0 then + isPlanarRGB := false + else if gBGImg.PlanarRGB = 1 then + isPlanarRGB := true + else + isPlanarRGB := isPlanarImg(lP, lHdr.NIFTIhdr.Dim[1], lHdr.NIFTIhdr.Dim[2], lHdr.NIFTIhdr.Dim[3]); + if isPlanarRGB then begin + if (lHdr.Index mod 3) = 1 then //green + lInSlice := lSliceSz + else if (lHdr.Index mod 3) = 2 then//blue + lInSlice := lSliceSz+lSliceSz + else + lInSlice := 0; + lOutSlice := 0; + for lZ := 1 to lHdr.NIFTIhdr.Dim[3] do begin + for lSliceVox := 1 to lSliceSz do begin + lHdr.ImgBuffer^[lSliceVox+lOutSlice] := lP^[lSliceVox+lInSlice]; + end; + inc(lOutSlice,lSliceSz); + inc(lInSlice,lSliceSz+lSliceSz+lSliceSz); + end; + end else begin + if (lHdr.Index mod 3) = 1 then //green + lInPos := 2 + else if (lHdr.Index mod 3) = 2 then//blue + lInPos := 3 + else + lInPos := 1; + for lOutPos := 1 to lZ do begin + lHdr.ImgBuffer^[lOutPos] := lP^[lInPos]; + lInPos := lInPos + 3; + end; + end; + (*if (lHdr.Index mod 3) = 1 then //green + lInSlice := lSliceSz + else if (lHdr.Index mod 3) = 2 then//blue + lInSlice := lSliceSz+lSliceSz + else + lInSlice := 0; + lOutSlice := 0; + for lZ := 1 to lHdr.NIFTIhdr.Dim[3] do begin + for lSliceVox := 1 to lSliceSz do begin + lHdr.ImgBuffer^[lSliceVox+lOutSlice] := lP^[lSliceVox+lInSlice]; + end; + inc(lOutSlice,lSliceSz); + inc(lInSlice,lSliceSz+lSliceSz+lSliceSz); + end;*) + freemem(lP); + for lZ := 0 to 255 do begin + lHdr.LUT[lZ].rgbRed := 0; + lHdr.LUT[lZ].rgbGreen := 0; + lHdr.LUT[lZ].rgbBlue := 0; + lHdr.LUT[lZ].rgbReserved := kLUTalpha; + end; + if (lHdr.Index mod 3) = 1 then begin//green + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbGreen := lZ; + end else if (lHdr.Index mod 3) = 2 then begin //blue + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbBlue := lZ; + end else begin + for lZ := 0 to 255 do + lHdr.LUT[lZ].rgbRed := lZ; + end; + result := true; +end; + +procedure NonReslicedGB (var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr);//vcx +begin + if lImg2Load.NIfTItransform then + lBackgroundImg.InvMat := Hdr2InvMat (lImg2Load.NIftiHdr,lImg2Load.NIfTItransform); + + FindMatrixBounds(lBackgroundImg,lImg2Load,false); + FindAlignment(lBackgroundImg,lImg2Load); + MakeSameOrtho(lBackgroundImg,lImg2Load); +end; + +procedure ReorientToNearestOrtho (var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground: boolean); +//only apply this to the background image - other routines will reorient overlays +begin + lBackgroundImg.ReorientHdr := lImg2Load.NIFTIhdr;//vcx + if not OrthoReorientCore(lImg2Load,false) then exit;//no change + if not lLoadBackground then exit; //no change in bounding box + lBackgroundImg.UseReorientHdr := true; + NonReslicedGB(lBackgroundImg,lImg2Load); +end; + +procedure LoadLabelLUT(var lBackgroundImg: TBGImg; var lHdr: TMRIcroHdr {; isBackground: boolean}); +var lLUTname: string; +(* lInc: integer; + lTextFile: TextFile; + lStr1: string; + lCh: char; *) +begin + lLUTname := changefileext(lHdr.HdrFileName,'.lut'); + if Fileexists(lLUTname) then begin + lHdr.UsesCustomPalette := true; + LoadColorScheme(lLUTname,lHdr); + + end; + //if isBackground then begin + LoadLabelsOld(lBackgroundImg,lHdr); + lHdr.UsesLabels := true; + //end; +end; + +function OpenImg(var lBackgroundImg: TBGImg; var lImg2Load: TMRIcroHdr; lLoadBackground,lVOILoadAsBinary,lNoScaling8bit,lResliceIn,l4D{,lOrthoReslice}: boolean): boolean; +//lReslice: use orientation matrix to transform image -> do not use if l4D = true +//l4D: load all slices of a 4D volume +label +456; +var + lSwap: boolean; + lWordX: word; + lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01:single; + lMultiImgSzOff,lMultiImgSz,lOffset, + lVol,lnVol,lFileSz,lDataType,lInc,lFSz,lImgSamples,lMinI,lMaxI,lRow: Integer; + lP: Bytep; + lFName,lExt,lParseName: String; + Fz: file; + TF : THandle; + l16Buf : SmallIntP; + l32Buf,l32TempBuf : SingleP; + l64Buf : DoubleP; + lReslice: boolean; + amtXFer : DWord; +begin + result := false; + lReslice := lResliceIn; + if lLoadBackground then begin + lBackgroundImg.LabelRA := nil; + ImgForm.CloseImagesClick(nil); + end; + FreeImgMemory(lImg2Load); + if not lImg2Load.DiskDataNativeEndian then + lSwap := true + else + lSwap := false; + if lLoadBackground then begin //May07 + lBackgroundImg.UseReorientHdr := false;//vcx + if (RotationForm.Visible) and ((RotationForm.YawEdit.value<>0) or (RotationForm.PitchEdit.value<>0) or (RotationForm.RollEdit.value<>0) ) then begin + lReslice := true; + RotationForm.RotateNIFTIMatrix (lImg2Load.NIFTIHdr, RotationForm.YawEdit.value, RotationForm.PitchEdit.value, RotationForm.RollEdit.value); + nifti_mat2mricronmat (lImg2Load); + end; + if(lImg2Load.NIFTIhdr.Dim[3] = 1) then //do not reslice 2D images - terrible interpolation + lReslice := false; + lBackgroundImg.Resliced := lReslice; + if not lReslice then + NonReslicedGB(lBackgroundImg,lImg2Load); + FindMatrixBounds(lBackgroundImg,lImg2Load,lReslice); + if (gBGImg.ScrnDim[1] < 2) or (gBGImg.ScrnDim[2] < 2) or (gBGImg.ScrnDim[3] < 1) then begin + Showmessage('Error: this does not appear to be a valid 2D/3D image.'); + //fx( gBGImg.ScrnDim[1],gBGImg.ScrnDim[2],gBGImg.ScrnDim[3]); + exit; + end; + if(gBGImg.ScrnDim[3] = 1) then begin + lBackgroundImg.Resliced := false; + //Showmessage('Error: this does not appear to be a valid 2D image.'); + //exit; + end; + FindAlignment(lBackgroundImg,lImg2Load); + end; + + if (not IsNifTiMagic(lImg2Load.niftiHdr)) or (lImg2Load.NIFTIhdr.sform_code < 1) or (lImg2Load.NIFTIhdr.sform_code > 10) then + lBackgroundImg.KnownAlignment := false; + if (not lLoadBackground) and (not lBackgroundImg.Resliced) then //Mar2007 + lReslice := false; + ///1112 fx(lBackgroundImg.ScrnOri[1],lBackgroundImg.ScrnOri[2],lBackgroundImg.ScrnOri[3]); + lDataType := lImg2Load.NIFTIhdr.datatype; + lFName := lImg2Load.ImgFileName; + + lMultiImgSz := ComputeImageDataBytes(lImg2Load); + + lOffset := round(lImg2Load.NIFTIhdr.vox_offset); + lMultiImgSzOff := lMultiImgSz + abs(lOffset); + if lImg2Load.NIFTIhdr.dim[4] < 1 then //June2009 - prevent error if 3D image sets field to zero instead of one + lImg2Load.NIFTIhdr.dim[4] := 1; + if lImg2Load.NIFTIhdr.dim[5] < 1 then //June2009 - prevent error if DTI image sets field to zero instead of one + lImg2Load.NIFTIhdr.dim[5] := 1; + lnVol := lImg2Load.NIFTIhdr.dim[4]*lImg2Load.NIFTIhdr.dim[5];//June2009 - for DTI data where direction is 5th dimension + + if lMultiImgSz < 1 then exit; + lFSz := FSize(lFName); + if (lFSz = 0) then + Showmessage('Unable to find the image file '+lFName); + lExt := UpCaseExt(lFName); + lVol := 1; + if lnVol > 1 then begin + if lOffset < 0 then + lFileSz := lMultiImgSzOff * {gAHdr.dim[4]}lnVol + else + lFileSz := ( lnVol * lMultiImgSz) + lOffset; + lVol := 1; + if {not l4D} lBackgroundImg.Prompt4DVolume then begin + lVol := ReadIntForm.GetInt('Multi-volume file, please select volume to view.',1,1,lnVol); + application.processmessages; + end; + end else + lFileSz := lMultiImgSzOff; + if ((lFileSz) > lFSz) and (lImg2Load.gzBytesX = K_gzBytes_headerAndImageUncompressed) then begin + ShowMessage('Error: This image file is smaller than described in header.'+ + ' Expected: '+inttostr(lFileSz)+' Selected:'+inttostr(lFSz)+ ' '+lFname); + goto 456; + exit; + end; + {$I-} + //lstarttime := gettickcount; + FileMode := 0; { Set file access to read only } + AssignFile(Fz, lFName); + FileMode := 0; { Set file access to read only } + Reset(Fz, 1); + if (lImg2Load.gzBytesX <> K_gzBytes_headerAndImageUncompressed) then begin //deal with compressed data + if (lImg2Load.gzBytesX = K_gzBytes_headerAndImageCompressed) then begin + if lOffset < 0 then + lOffset := abs(lOffset) + (lMultiImgSzOff *(lVol-1)) + else + lOffset := lOffset + (lMultiImgSz *(lVol-1)); + end else + lOffset := (lMultiImgSz *(lVol-1));//header UNCOMPRESSED! + end else if lOffset < 0 then + Seek (Fz,abs(lOffset) + (lMultiImgSzOff *(lVol-1)) ) + else + Seek (Fz,lOffset + (lMultiImgSz *(lVol-1)) ); + case lDataType of + kDT_SIGNED_SHORT,kDT_UINT16: lImg2Load.ImgBufferBPP := 2; + kDT_SIGNED_INT,kDT_FLOAT: lImg2Load.ImgBufferBPP := 4; + kDT_DOUBLE: lImg2Load.ImgBufferBPP := 8; + kDT_UNSIGNED_CHAR : lImg2Load.ImgBufferBPP := 1; + kDT_RGB: lImg2Load.ImgBufferBPP := 1;//rgb + else begin + showmessage('Unable to read this image format '+inttostr(lDataType)); + goto 456; + end; + end; + //Next get memory + lImgSamples := round(ComputeImageDataBytes8bpp(lImg2Load)); + lImg2Load.ImgBufferItems := lImgSamples; + lMultiImgSz := (lImgSamples * lImg2Load.ImgBufferBPP); + if lDataType = kDT_RGB then + lMultiImgSz := lMultiImgSz * 3;//RGB + if lMultiImgSz > freeRam then begin + Showmessage('Unable to load image: not enough RAM.'); + goto 456; + exit; + end; + if l4D then begin + lMultiImgSz := lMultiImgSz * lnVol; + lImgSamples := lImgSamples * lnVol; //Apr07 + end; + try + GetMem(lImg2Load.ImgBufferUnaligned ,lMultiImgSz+16); + except + showmessage('Load Image Error: System memory exhausted.'); + freemem(lImg2Load.ImgBufferUnaligned); + //do goto 456 + exit; + end; + lImg2Load.ImgBuffer := ByteP($fffffff0 and (integer(lImg2Load.ImgBufferUnaligned)+15)); + //Next Load Image + if (lImg2Load.gzBytesX <> K_gzBytes_headerAndImageUncompressed) then begin + lP := ByteP(lImg2Load.ImgBuffer); + //for lInc := 1 to {lMultiImgSz} 64*64*2*35 do + // lP[lInc] := lInc mod 255; + if lImg2Load.gzBytesX = K_gzBytes_headerAndImageCompressed then + UnGZip(lFName,lP,lOffset,lMultiImgSz) + else begin + UnGZip2 (lFName,lP,lOffset,lMultiImgSz, round(lImg2Load.NIFTIhdr.vox_offset)); //unzip + //UnGZipX (lFName,lP,lOffset,lMultiImgSz, round(lImg2Load.NIFTIhdr.vox_offset)); //unzip + end; + //fx(64*64*35*2,lMultiImgSz); + //for lInc := 1 to lMultiImgSz do + // lP[lInc] := lInc mod 255; + end else + BlockRead(Fz,lImg2Load.ImgBuffer^,lMultiImgSz); + closefile(fz); + if IOResult <> 0 then + ShowMessage('Open image file error: '+inttostr(IOResult)); + //Next: prepare image : byte swap, check for special.. + case lDataType of + kDT_RGB: ParseRGB(lImg2Load);//RGB + kDT_SIGNED_SHORT,kDT_UINT16: begin //16-bit int + l16Buf := SmallIntP(lImg2Load.ImgBuffer ); + if lSwap then + for lInc := 1 to lImgSamples do begin + l16Buf[lInc] := Swap(l16Buf[lInc]); + end; + if (kDT_UINT16=lDataType ) then begin //avoid wrap around if read as signed value + for lInc := 1 to lImgSamples do begin + lWordX := word(l16Buf[lInc]); + l16Buf[lInc] := lWordX shr 1; + end; //for + end; //if kDT_UINT16 + end; //16-bit + kDT_SIGNED_INT: begin + l32Buf := SingleP(lImg2Load.ImgBuffer ); + if lSwap then //unswap and convert integer to float + for lInc := 1 to lImgSamples do + l32Buf[lInc] := (Swap4r4i(l32Buf[lInc])) + else //convert integer to float + for lInc := 1 to lImgSamples do + l32Buf[lInc] := Conv4r4i(l32Buf[lInc]); + end; //32-bit int + kDT_FLOAT: begin + l32Buf := SingleP(lImg2Load.ImgBuffer ); + if lSwap then + for lInc := 1 to lImgSamples do begin + pswap4r(l32Buf[lInc]) //faster as procedure than function see www.optimalcode.com + end; + + for lInc := 1 to lImgSamples do + if specialsingle(l32Buf[lInc]) then l32Buf[lInc] := 0.0; + //thresh= for lInc := 1 to lImgSamples do if l32Buf[lInc] < 2.300611 then l32Buf[lInc] := 0.0; + //invert= for lInc := 1 to lImgSamples do l32Buf[lInc] := -l32Buf[lInc]; + end; //32-bit float + kDT_DOUBLE: begin + l64Buf := DoubleP(lImg2Load.ImgBuffer ); + lImg2Load.ImgBufferBPP := 4; //we will save as 32-bit + lMultiImgSz := (lImgSamples * lImg2Load.ImgBufferBPP); + if l4D then begin + lMultiImgSz := lMultiImgSz * lnVol; + lImgSamples := lImgSamples * lnVol; //Apr07 + end; + try + GetMem(l32TempBuf ,lMultiImgSz+16); + except + showmessage('64-bit Image Error: System memory exhausted.'); + freemem(l32TempBuf); + freemem(lImg2Load.ImgBufferUnaligned); + exit; + end; + if lSwap then begin + for lInc := 1 to lImgSamples do begin + try + l32TempBuf[lInc] := Swap64r(l64Buf[lInc]) + except + l32TempBuf[lInc] := 0; + end; //except + end; //for + end else begin + for lInc := 1 to lImgSamples do begin + try + l32TempBuf[lInc] := l64Buf[lInc] + except + l32TempBuf[lInc] := 0; + end; //except + end; //for + end; //not swap + //now copy from temp buffer to longer-term buffer + freemem(lImg2Load.ImgBufferUnaligned); + try + GetMem(lImg2Load.ImgBufferUnaligned ,lMultiImgSz+16); + except + showmessage('Load Image Error: System memory exhausted.'); + freemem(lImg2Load.ImgBufferUnaligned); + exit; + end; + lImg2Load.ImgBuffer := ByteP($fffffff0 and (integer(lImg2Load.ImgBufferUnaligned)+15)); + l32Buf := SingleP(lImg2Load.ImgBuffer ); + Move(l32TempBuf^,l32Buf^,lMultiImgSz); + freemem(l32TempBuf); + for lInc := 1 to lImgSamples do + if specialsingle(l32Buf[lInc]) then l32Buf[lInc] := 0.0; + for lInc := 1 to lImgSamples do + if specialsingle(l32Buf[lInc]) then l32Buf[lInc] := 0.0; + + end; //64-bit float + kDT_UNSIGNED_CHAR : ; + //else will be aborted at previous case + end;//case lDataType of + // fx(lBackgroundImg.xxx[1,1],66); + if lImg2Load.NIFTIhdr.magic = kNIFTI_MAGIC_DCM then + DICOMMirrorImgBuffer(lImg2Load) + else if (lLoadBackground) and (not lReslice) and (lBackgroundImg.KnownAlignment) and (lBackgroundImg.OrthoReslice) then + ReorientToNearestOrtho(lBackgroundImg,lImg2Load,lLoadBackground) + else if (l4D) and (not lReslice) and (lBackgroundImg.KnownAlignment) and (lBackgroundImg.OrthoReslice) then + OrthoReorientCore(lImg2Load,true); + //next correct image size + if lImg2Load.NIFTIhdr.scl_slope = 0 then + lImg2Load.NIFTIhdr.scl_slope := 1; + if (lLoadBackground) and (not l4D) then + ResliceScrnImg ( lBackgroundImg,lImg2Load,true) + else if not l4D then begin + ResliceScrnImg ( lBackgroundImg,lImg2Load,lBackgroundImg.OverlaySmooth); + end; + + if (not lLoadBackground) and (lImg2Load.NIFTIhdr.descrip[1] = 'N') and (lImg2Load.NIFTIhdr.descrip[2] = 'P') and (lImg2Load.NIFTIhdr.descrip[3] = 'M') then begin + lImg2Load.NIFTIhdr.intent_code := kNIFTI_INTENT_ZSCORE; + end; + //Next: find min/max - better after reslicing incase we have padded zeros at the edges and zero < min + //showmessage(lImg2Load.NIFTIhdr.descrip); + case lImg2Load.ImgBufferBPP of + 1: begin + FindImgMinMax8 (lImg2Load, lMini,lMaxi); + lImg2Load.GlMaxUnscaledS := lMaxI; + lImg2Load.GlMinUnscaledS := lMinI;; + end; + 2: begin + FindImgMinMax16 (lImg2Load, lMini,lMaxi); + lImg2Load.GlMaxUnscaledS := lMaxI; + lImg2Load.GlMinUnscaledS := lMinI;; + end; + 4: + FindImgMinMax32 (lImg2Load,lImg2Load.GlMinUnscaledS,lImg2Load.GlMaxUnscaledS); + else Showmessage('OpenImg and LoadImg error'); + end; //case ImgBufferBPP + balance(lImg2Load); //preparecontrast autobalance + + //fx(lImg2Load.GlMinUnscaledS,lImg2Load.GlMaxUnscaledS,lImg2Load.WindowScaledMin,lImg2Load.WindowScaledMax); + //diva showmessage(floattostr(lImg2Load.AutoBalMaxUnscaled)); + lImg2Load.WindowScaledMin := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMinUnscaled); + lImg2Load.WindowScaledMax := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMaxUnscaled); +// fx(lImg2Load.WindowScaledMin , lImg2Load.WindowScaledMax); + if (lVOILoadAsBinary) then begin + lImg2Load.WindowScaledMin := kMin8bit;//MAW + lImg2Load.WindowScaledMax := kVOI8bit; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + end else if lDataType = kDT_RGB then begin//RGB + lImg2Load.UsesCustomPalette := true; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lNoScaling8bit) and (lImg2Load.ImgBufferBPP = 1) then begin + lImg2Load.UsesCustomPalette := false; + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_ESTIMATE) and (lImg2Load.NIFTIhdr.intent_name[1] = '%') then begin + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 100;//lImg2Load.GlMaxUnscaledS; + lImg2Load.LutFromZero := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if ( {(lImg2Load.NIFTIhdr.intent_code = NIFTI_INTENT_LOG10PVAL) or} (lImg2Load.NIFTIhdr.intent_code =kNIFTI_INTENT_PVAL) or (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_ZSCORE) or ((lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_TTEST) or (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_CHISQ))) and (lImg2Load.ImgBufferBPP = 4) and (not l4D) then begin + //ComputeFDR(lImg2Load.NIFTIhdr.intent_code,round(lImg2Load.NIFTIhdr.intent_p1),lImg2Load.ImgBufferItems,lImg2Load.ImgBufferBPP,lImg2Load.ImgBuffer,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); + ComputeFDR(lImg2Load,lP05,lP01,lFWE05,lFWE01,lFDR05,lFDR01); + + if (Raw2ScaledIntensity(lImg2Load,lImg2Load.GlMaxUnscaledS)> lFDR05) and (lFDR05 > 0) then begin + lImg2Load.WindowScaledMin := lFDR05; //0.001 xxx + if lFDR01 > 0 then + lImg2Load.WindowScaledMax := lFDR01 + else + lImg2Load.WindowScaledMax := 2*lFDR05; //0.000001 + end else begin + lImg2Load.WindowScaledMin := lP05; //0.001 xxx + lImg2Load.WindowScaledMax := lP01; //0.000001 + end; + if (lImg2Load.WindowScaledMax < 0.00001) and (lImg2Load.WindowScaledMin < 0.00001) then begin + lImg2Load.WindowScaledMax := 5; + lImg2Load.WindowScaledMin := 0; + end; + lImg2Load.LutFromZero := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + {end else if (lImg2Load.NIFTIhdr.intent_code = NIFTI_INTENT_LOG10PVAL) and (Raw2ScaledIntensity(lImg2Load,lImg2Load.GlMaxUnscaledS)> 3.0) then begin + lImg2Load.WindowScaledMin := 2; //0.01 + lImg2Load.WindowScaledMax := 4; //0.0001 + lImg2Load.LutFromZero := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax;{} + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) and (lImg2Load.ImgBufferBPP = 1) and (lImg2Load.NIFTIhdr.regular = char(98)) then begin + //createLutLabel (lImg2Load, 1.0); + LoadLabelLUT(lBackgroundImg,lImg2Load); + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := kMin8bit; + lImg2Load.WindowScaledMax := 255; + lImg2Load.UsesCustomPalette := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end else if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) and ((lImg2Load.ImgBufferBPP = 1) or (lImg2Load.ImgBufferBPP = 2)) then begin + + createLutLabel (lImg2Load.LUT, 1.0); + lImg2Load.NIFTIhdr.scl_slope := 1; + lImg2Load.NIFTIhdr.scl_inter := 0; + lImg2Load.WindowScaledMin := 0;//kMin8bit; + lImg2Load.WindowScaledMax := 100;//255; + lImg2Load.UsesCustomPalette := true; + lImg2Load.UsesCustomPaletteRandomRainbow := true; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + if {lLoadBackground} true then begin + if (( lImg2Load.NIFTIhdr.vox_offset- lImg2Load.NIFTIhdr.HdrSz) > 128) then + LoadLabels(lImg2Load.HdrFileName,lBackgroundImg.LabelRA, lImg2Load.NIFTIhdr.HdrSz, round( lImg2Load.NIFTIhdr.vox_offset)) + else + LoadLabelsTxt(lImg2Load.HdrFileName, lBackgroundImg.LabelRA); + if (High(lBackgroundImg.LabelRA) < 1) and (lImg2Load.ImgBufferBPP = 1) then + LoadLabelsOld(lBackgroundImg,lImg2Load); + if High(lBackgroundImg.LabelRA) > 0 then + lImg2Load.UsesLabels := true; + //showmessage(inttostr(High(lBackgroundImg.LabelRA) )+'xxx'); + end + //ImgForm.Help1.caption := 'imaw'+realtostr(lImg2Load.WindowScaledMin,4);//maw + end else begin + if (lImg2Load.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then begin//>only called when BPP <> 1 + LoadLabelLUT(lBackgroundImg,lImg2Load); + end; + lImg2Load.UsesCustomPalette := false; + lImg2Load.WindowScaledMin := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMinUnscaled); + lImg2Load.WindowScaledMax := raw2ScaledIntensity(lImg2Load,lImg2Load.AutoBalMaxUnscaled); + + end; + lParseName := (parsefilename(extractfilename(lImg2Load.HdrFileName))) ; + if (lParseName= 'ch2bet') or (lParseName = 'ch2better') then begin //11/2007 - add better + lImg2Load.WindowScaledMin := 45; + lImg2Load.WindowScaledMax := 120; + + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end; + if lParseName = 'ch2' then begin + lImg2Load.WindowScaledMin := 30; + lImg2Load.WindowScaledMax := 120; + lImg2Load.AutoBalMinUnscaled := lImg2Load.WindowScaledMin; + lImg2Load.AutoBalMaxUnscaled := lImg2Load.WindowScaledMax; + end; + //fx(lImg2Load.WindowScaledMin , lImg2Load.WindowScaledMax); + //Next: create screen buffer [scaled to background] + + if not l4D then begin//12/2007: do not create screen buffer for 4D load! saves memory and time + if lLoadBackground then + RescaleImgIntensity (lBackgroundImg,lImg2Load,kBGOverlayNum) + else + RescaleImgIntensity (lBackgroundImg,lImg2Load,kVOIOverlayNum); + end; + + if (lVOILoadAsBinary) and (lImg2Load.ScrnBufferItems> 0) then begin + if lImg2Load.NIFTIhdr.intent_name[1] = 'I' then //indexed + showmessage('Indexed drawing - assuming drawing is binary. You may want to upgrade this software.'); + gBGImg.VOIchanged := false; + for lInc := 1 to lImg2Load.ScrnBufferItems do + if lImg2Load.ScrnBuffer[lInc] > 1 then + lImg2Load.ScrnBuffer[lInc] := kVOI8bit; + lMaxI := maxint; + LoadMonochromeLUT(lMaxi,lBackgroundImg,lImg2Load); + if lImg2Load.ImgBufferItems > 1 then + freemem(lImg2Load.ImgBufferUnaligned); + lImg2Load.ImgBufferItems := 0; + end else begin + ImgForm.LayerDropSelect(nil); + ImgForm.LUTdropSelect(nil); + end; + result := true; +456: + + {$I+} + FileMode := 2; +end; //proc OpenImg + +end. diff --git a/niftiview7/nifti_img_view.pas b/niftiview7/nifti_img_view.pas new file mode 100755 index 0000000..5d26bf9 --- /dev/null +++ b/niftiview7/nifti_img_view.pas @@ -0,0 +1,5282 @@ +unit nifti_img_view; +interface + +uses + CommDlg,//FiltEdit, + //DsgnIntf, + draw_interpolate_slices, ExtCtrls, Dialogs, Menus, Forms, + StdCtrls, RXSpin, Controls, Buttons, PngSpeedButton, Classes, + Windows, Messages, SysUtils, Graphics, Math, + ToolWin, ComCtrls, NIFTI_hdr,GraphicsMathLibrary, + ClipBrd,ShellAPI,define_types, nifti_hdr_view,nifti_img,IniFiles, + ReadInt,registry,Distr,E_memmap,Tablet,gzio,batch,readfloat, Mask, + imgutil,pref_ini,sliceinterpolate, fastsmooth, nifti_types; + +type + TImgForm = class(TForm) + Recent1: TMenuItem; + File1: TMenuItem; + Open1: TMenuItem; + Templates1: TMenuItem; + CloseImages: TMenuItem; + SaveasNIfTI1: TMenuItem; + Saveaspicture1: TMenuItem; + Exit1: TMenuItem; + MainMenu1: TMainMenu; + Edit1: TMenuItem; + Copy1: TMenuItem; + Help1: TMenuItem; + About1: TMenuItem; + ControlPanel: TPanel; + Crosshair1: TMenuItem; + Pen1: TMenuItem; + Penautoclose1: TMenuItem; + CircleSquare1: TMenuItem; + MagPanel: TPanel; + ProgressBar1: TProgressBar; + StatusLabel: TLabel; + LabelX: TLabel; + LabelY: TLabel; + LabelZ: TLabel; + Controls1: TMenuItem; + Multiple1: TMenuItem; + Panel1: TPanel; + MagnifyPanel: TPanel; + SaveDialog1: TSaveDialog; + ColorDialog1: TColorDialog; + RefreshImagesTimer: TTimer; + MagnifyMenuItem: TMenuItem; + OverlayMenu: TMenuItem; + OverlayOpen: TMenuItem; + LayerMenu: TMenuItem; + Noneopen1: TMenuItem; + OverlaySmoothMenu: TMenuItem; + CloseOverlayImg: TMenuItem; + BGTransPctMenu: TMenuItem; + OverlayTransPctMenu: TMenuItem; + BGtrans0: TMenuItem; + BGtrans20: TMenuItem; + BGtrans40: TMenuItem; + BGtrans50: TMenuItem; + BGtrans60: TMenuItem; + BGtrans80: TMenuItem; + BGtrans100: TMenuItem; + N0opaque1: TMenuItem; + N201: TMenuItem; + N401: TMenuItem; + N501: TMenuItem; + N601: TMenuItem; + N801: TMenuItem; + N100transparent1: TMenuItem; + Layerrange1: TMenuItem; + Noneopen2: TMenuItem; + BGAdditive: TMenuItem; + OverlayAdditive: TMenuItem; + ShowRender: TMenuItem; + DrawMenu: TMenuItem; + OpenVOI: TMenuItem; + SaveVOI: TMenuItem; + CloseVOI: TMenuItem; + VOIColor: TMenuItem; + UndoImg: TImage; + DrawImg: TImage; + Undo1: TMenuItem; + Paste1: TMenuItem; + Applyintensityfiltertovolume1: TMenuItem; + Quicksmooth1: TMenuItem; + MaskimagewithVOI1: TMenuItem; + VOImaskDelete: TMenuItem; + VOImaskPreserve: TMenuItem; + Circle1: TMenuItem; + Overlaycomparisons1: TMenuItem; + IntersectionmutualtoVOIandoverlays1: TMenuItem; + UnionVOIoroverlays1: TMenuItem; + MaskVOIbutnotoverlays1: TMenuItem; + RescaleImagesTimer: TTimer; + SmoothVOI1: TMenuItem; + Circle2: TMenuItem; + Beta1: TMenuItem; + Chisquare1: TMenuItem; + Convert1: TMenuItem; + ROIVOI1: TMenuItem; + Statistics1: TMenuItem; + ShowMultislice: TMenuItem; + DescriptiveMenuItem: TMenuItem; + N1: TMenuItem; + ToolPanel: TPanel; + N2: TMenuItem; + Display1: TMenuItem; + N3: TMenuItem; + FlipLRmenu: TMenuItem; + N4: TMenuItem; + Menu2DSmooth: TMenuItem; + VOI2NII: TMenuItem; + Nudge1: TMenuItem; + Up1: TMenuItem; + Left1: TMenuItem; + LeftX1: TMenuItem; + RightX1: TMenuItem; + Posterior1: TMenuItem; + Posterior2: TMenuItem; + YokeTimer: TTimer; + YokeMenu: TMenuItem; + BrainExtraction1: TMenuItem; + N5: TMenuItem; + MNICoordinates1: TMenuItem; + Histogram1: TMenuItem; + N4DTraces1: TMenuItem; + Sagittal1: TMenuItem; + Axial1: TMenuItem; + Coronal1: TMenuItem; + N6: TMenuItem; + CropEdges1: TMenuItem; + HideVOI1: TMenuItem; + HideROITimer: TTimer; + Preferences1: TMenuItem; + GenerateSPM5maskslesions1: TMenuItem; + Header1: TMenuItem; + RescaleMenu: TMenuItem; + Brainmask1: TMenuItem; + BatchROImean1: TMenuItem; + NIIVOI1: TMenuItem; + ZoomDrop: TComboBox; + XViewEdit: TRxSpinEdit; + YViewEdit: TRxSpinEdit; + ZViewEdit: TRxSpinEdit; + MirrorNII1: TMenuItem; + LRFlip1: TMenuItem; + Blackborders1: TMenuItem; + Applyclusterthreshold1: TMenuItem; + Batchprobmaps1: TMenuItem; + ExportasRGBAnalyzeimage1: TMenuItem; + HideROIBtn: TPngSpeedButton; + XBarBtn: TPngSpeedButton; + PenBtn: TPngSpeedButton; + ClosedPenBtn: TPngSpeedButton; + FillBtn: TPngSpeedButton; + EllipseBtn: TPngSpeedButton; + Fill3DBtn: TPngSpeedButton; + Resliceimage1: TMenuItem; + Batchclusterprobmaps1: TMenuItem; + VOI2Text: TMenuItem; + AdjustimagessoVOIintensityiszero1: TMenuItem; + TriplePanel: TScrollBox; + PGImageSag: TImage; + PGImageCor: TImage; + PGImageAx: TImage; + LayerPanel: TPanel; + LayerDrop: TComboBox; + AutoContrastBtn: TPngSpeedButton; + MinWindowEdit: TRxSpinEdit; + MaxWindowEdit: TRxSpinEdit; + LUTDrop: TComboBox; + LutFromZeroBtn: TPngSpeedButton; + ColorBarBtn: TPngSpeedButton; + Display2: TMenuItem; + RotateMenu: TMenuItem; + Axial2: TMenuItem; + Coronal2: TMenuItem; + Sagittal2: TMenuItem; + DilateVOIs1: TMenuItem; + Left2: TMenuItem; + Nudge2D1: TMenuItem; + Left3: TMenuItem; + Right1: TMenuItem; + Anterior1: TMenuItem; + Posterior3: TMenuItem; + Interpolate1: TMenuItem; + SaveSmooth1: TMenuItem; + Landmarks1: TMenuItem; + Extract1: TMenuItem; + AcceptLandmark1: TMenuItem; + Batchlandmarks1: TMenuItem; + DrawHiddenMenu: TMenuItem; + ShowDrawMenuItem: TMenuItem; + HideDrawMenuItem: TMenuItem; + //procedure SetIniMenus; + procedure SaveOrCopyImages(lCopy: boolean); + function ImgIntensityString(var lHdr: TMRIcroHdr; lVox: integer): string; + function ImgIntensityStringXYZ(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): string; + procedure UpdateColorSchemes; + procedure UpdateTemplates; + procedure UpdateMRU; + procedure UpdateStatusLabel; + procedure Exit1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure DisplayHdrClick(Sender: TObject); + procedure Open1Click(Sender: TObject); + procedure ToolSelectClick(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + function OpenAndDisplayImg(var lFilename: string; lAdd2MRU: boolean): boolean; + procedure OpenTemplateMRU(Sender: TObject); + procedure XViewEditChange(Sender: TObject); + procedure SetAutoFill; + function ActiveLayer:integer; + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure PGImageMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); + procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure ShowDescriptive (lOverlayNum: integer; lShowFilename: boolean); + + procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure PGImageMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure PGImageMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure LUTdropLoad(var lLayer: integer); + procedure LUTdropSelect(Sender: TObject); + procedure ZoomDropSelect(Sender: TObject); + procedure ColorBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +// procedure OptimizeViewMenuItemClick(Sender: TObject); + procedure Saveaspicture1Click(Sender: TObject); + procedure XBarBtnClick(Sender: TObject); + procedure XBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure AutoContrastBtnClick(Sender: TObject); + procedure RefreshImagesTimerTimer(Sender: TObject); + procedure MinContrastWindowEditChange(Sender: TObject); + //procedure ImgPanelClick(Sender: TObject); + procedure MagnifyMenuItemClick(Sender: TObject); + procedure CloseImagesClick(Sender: TObject); + procedure UpdateLayerMenu; + procedure LoadOverlay (lFilename: string); + procedure LoadOverlayIncludingRGB (lFilename: string); + procedure OverlayOpenCore (var lFilename: string; lOverlayNum: integer); + procedure OverlayOpenClick(Sender: TObject); + procedure CloseOverlayImgClick(Sender: TObject); + procedure BGtrans100Click(Sender: TObject); + procedure OverlayTransClick(Sender: TObject); + procedure LayerDropSelect(Sender: TObject); + procedure OverlaySmoothMenuClick(Sender: TObject); + procedure MaxContrastWindowEditChange(Sender: TObject); + procedure ShowRenderClick(Sender: TObject); + procedure PenBtnClick(Sender: TObject); + procedure OpenVOIClick(Sender: TObject); + procedure OpenVOICore(var lFilename : string); + procedure SaveVOIcore(lPromptFilename: boolean); + procedure SaveVOIClick(Sender: TObject); + procedure VOIColorClick(Sender: TObject); + procedure CloseVOIClick(Sender: TObject); + procedure SetDimension8(lInPGHt,lInPGWid:integer; lBuff: ByteP; lUndoOnly: boolean); + procedure Undo1Click(Sender: TObject); + procedure Paste1Click(Sender: TObject); + procedure HideROIBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure HideROIBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Applyintensityfiltertovolume1Click(Sender: TObject); + procedure Quicksmooth1Click(Sender: TObject); + procedure VOImaskClick(Sender: TObject); + procedure SaveasNIfTI1Click(Sender: TObject); + procedure ROIcomparisonClick(Sender: TObject); + procedure RescaleImagesTimerTimer(Sender: TObject); + procedure Fill3DBtnClick(Sender: TObject); + procedure SmoothVOI1Click(Sender: TObject); + procedure CreateOverlap(Sender: TObject); + procedure Chisquare1Click(Sender: TObject); + procedure ROIVOI1Click(Sender: TObject); + procedure LUTinvertBtnClick(Sender: TObject); + procedure LutFromZeroBtnClick(Sender: TObject); + procedure ShowMultisliceClick(Sender: TObject); + procedure DescriptiveMenuItemClick(Sender: TObject); + procedure DrawInterpolateSlicesClick (Sender: TObject); + procedure FormResize(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FlipLRmenuClick(Sender: TObject); + procedure Menu2DSmoothClick(Sender: TObject); + procedure VALclick(Sender: TObject); + procedure VOI2NIIClick(Sender: TObject); + procedure TtoP1Click(Sender: TObject); + procedure DesignVALClick(Sender: TObject); + procedure Up1Click(Sender: TObject); +procedure SetShareMem (lXmm,lYmm,lZmm: single); +procedure CreateShareMem; +procedure CloseShareMem; + procedure YokeTimerTimer(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure YokeMenuClick(Sender: TObject); + procedure X1Click(Sender: TObject); + procedure BrainExtraction1Click(Sender: TObject); + procedure NZ1Click(Sender: TObject); + procedure MNICoordinates1Click(Sender: TObject); + procedure Histogram1Click(Sender: TObject); + procedure N4DTraces1Click(Sender: TObject); + procedure Sagittal1Click(Sender: TObject); + procedure HideVOI1Click(Sender: TObject); + procedure HideROITimerTimer(Sender: TObject); + procedure CropEdges1Click(Sender: TObject); + procedure Preferences1Click(Sender: TObject); + procedure GenerateSPM5maskslesions1Click(Sender: TObject); + procedure Header1Click(Sender: TObject); + procedure RescaleMenuClick(Sender: TObject); + procedure Brainmask1Click(Sender: TObject); + procedure BatchROImean1Click(Sender: TObject); + procedure NIIVOI1Click(Sender: TObject); + procedure MirrorNII1Click(Sender: TObject); + procedure MagPanelClick(Sender: TObject); + procedure FillBtnClick(Sender: TObject); + procedure Blackborders1Click(Sender: TObject); + procedure Applyclusterthreshold1Click(Sender: TObject); + procedure Batchprobmaps1Click(Sender: TObject); + procedure ExportasRGBAnalyzeimage1Click(Sender: TObject); + procedure PGImageSagDblClick(Sender: TObject); + procedure Resliceimage1Click(Sender: TObject); + procedure Batchclusterprobmaps1Click(Sender: TObject); + procedure SetSaveDlgFileExt; + procedure VOI2TextClick(Sender: TObject); + procedure AdjustimagessoVOIintensityiszero1Click(Sender: TObject); + procedure ControlPanelDblClick(Sender: TObject); + procedure ResizeControlPanel (lRows: integer); + procedure DefaultControlPanel; + procedure RotateMenuClick(Sender: TObject); + procedure DilateVOIs1Click(Sender: TObject); + procedure Nudge2D(Sender: TObject); + procedure Interpolate1Click(Sender: TObject); + procedure SaveSmooth1Click(Sender: TObject); + procedure SaveDialog1TypeChange(Sender: TObject); + procedure Landmarks1Click(Sender: TObject); + procedure Extract1Click(Sender: TObject); + procedure AcceptLandmark1Click(Sender: TObject); + procedure Batchlandmarks1Click(Sender: TObject); + procedure ToggleDrawMenu(Sender: TObject); + + private + { Private declarations } + EMemMap : TEMemMap; + procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES; + procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; + public + { Public declarations } +public + //procedure WMSysCommand (var Msg: TWMSysCommand) ; message WM_SYSCOMMAND; + end; + +const + kYokeItems= 12; + knMRU = 5;//max items in most recently used list + knMaxOverlay = 22; + kVOIOverlayNum = knMaxOverlay; + kBGOverlayNum = 0; + knAutoLUT = 7; + kVOIFilter = 'Volume of interest (*.voi)|*.voi|MRIcro ROI (*.roi)|*.roi|'+kImgFilter; +var + gYoke: boolean = false; + //gReslice : boolean = true; + ImgForm: TImgForm; + gBGImg: TBGImg; + gMRIcroOverlay: array [0..knMaxOverlay] of TMRIcroHdr; + gColorSchemeDir,gTemplateDir: String; + gMRUstr: array [0..knMRU] of String; //most recently used files + gMouseDownX,gMouseDownY: integer; + gSelectOrigin: TPoint; + gSelectRect: TRect; + //gMaxCPUThreads : integer = 8; + gnCPUThreads : integer = 1; + gOrigBGTransPct : integer= 50; +Type + SingleArr = Array[1..kYokeItems] Of Single; + SingleArrPtr = ^SingleArr; + +implementation + + + +uses reslice_fsl,render, ROIfilt,autoroi,smoothvoi, MultiSlice, Text, histoform, statclustertable, + about, cropedges, bet, mni, graphx, prefs, admin,fill, cutout {, swrender},activex,clustering, + rotation,Dilate, landmarks; + +{$R *.DFM} +{$R WindowsXP.RES} +procedure ReadForm2Ini (var lBGImg: TBGImg); +begin + lBGImg.ShowDraw := ImgForm.DrawMenu.Visible; + lBGImg.Smooth2D := ImgForm.Menu2DSmooth.checked; + lBGImg.XBar := ImgForm.XBarBtn.Down; + lBGImg.OverlaySmooth := ImgForm.OverlaySmoothMenu.Checked; + lBGImg.Yoke := gYoke;//ImgForm.YokeMenu.checked; +end; + +procedure WriteIni2Form (lBGImg: TBGImg); +begin + ImgForm.ToolPanel.Visible := lBGImg.ShowDraw; + ImgForm.DrawMenu.Visible := lBGImg.ShowDraw; + ImgForm.DrawHiddenMenu.Visible := not lBGImg.ShowDraw; + ImgForm.Menu2DSmooth.checked := lBGImg.Smooth2D; + ImgForm.XBarBtn.Down := lBGImg.XBar; + gYoke := lBGImg.Yoke; + ImgForm.YokeMenu.Checked := gYoke; + ImgForm.OverlaySmoothMenu.Checked := lBGImg.OverlaySmooth; + SetSubmenuWithTag(ImgForm.OverlayTransPctMenu, lBGImg.OverlayTransPct); + SetSubmenuWithTag(ImgForm.BGTransPctMenu, lBGImg.BGTransPct); +end; + +function GetLogicalCpuCount: Integer; +var + SystemInfo: _SYSTEM_INFO; +begin + GetSystemInfo(SystemInfo); + Result := SystemInfo.dwNumberOfProcessors; +end; + +procedure TImgForm.CloseShareMem; +begin + //if not gYoke then exit; + EMemMap.Free; +end; + +procedure TImgForm.SetShareMem (lXmm,lYmm,lZmm: single); +begin + if not gYoke then exit; + EMemMap.EnterCriticalSection; + Try + SingleArrPtr(EMemMap.MemMap)^[1]:=(lXmm); + SingleArrPtr(EMemMap.MemMap)^[2]:=(lYmm); + SingleArrPtr(EMemMap.MemMap)^[3]:=(lZmm); + Finally + EMemMap.LeaveCriticalSection; + end; +end; + +procedure TImgForm.CreateShareMem; +var + IArr : SingleArrPtr; + I: integer; +begin + EMemMap:=TEMemMap.Create(Self); + EMemMap.CreateMutex('MRICROMUTEX2'); + If NOT EMemMap.MapExisting('MRICROMAP2',SizeOf(SingleArr)) then begin + New(IArr); + For I:=1 To kYokeItems do + IArr^[I]:=0; + Try + If NOT EMemMap.CreateMemMap('MRICROMAP2',SizeOf(SingleArr),IArr^) then + EMemMap.RaiseMappingException; + Finally + Dispose(IArr); + end; + SetShareMem (0,0,0) + end; +end; + +procedure TImgForm.YokeTimerTimer(Sender: TObject); +var +lXmm,lYmm,lZmm: single; +lX,lY,lZ: integer; +begin + if not gYoke then begin + YokeTimer.Enabled := false; + exit; + end; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then + exit; + EMemMap.EnterCriticalSection; + Try + lXmm:=SingleArrPtr(EMemMap.MemMap)^[1]; + lYmm:=SingleArrPtr(EMemMap.MemMap)^[2]; + lZmm:=SingleArrPtr(EMemMap.MemMap)^[3]; + Finally + EMemMap.LeaveCriticalSection; + end; + MMToImgCoord(lX,lY,lZ,lXmm,lYmm,lZmm); + if lX <> XViewEdit.value then XViewEdit.value := lX; + if lY <> YViewEdit.value then YViewEdit.value := lY; + if lZ <> ZViewEdit.value then ZViewEdit.value := lZ; +end; + +procedure TImgForm.WMSysCommand; +begin + if (Msg.CmdType = SC_MINIMIZE) then + Application.Minimize + else + DefaultHandler(Msg) ; + if (Msg.CmdType = SC_MAXIMIZE) then RefreshImagesTimer.Enabled := true; +end; + +function SelectedImagePanel: TScrollBox; +begin +(*yui + case SelectedImageNum of + 3: result := ImgForm.ImgPanel3; + 2: result := ImgForm.ImgPanel2; + else result := ImgForm.ImgPanel1; + end;*) +end; + +function DrawToolSelected: boolean; +begin + if ( ImgForm.PenBtn.Down) or ( ImgForm.ClosedPenBtn.Down) or (ImgForm.FillBtn.Down) or (ImgForm.EllipseBtn.Down) then + result := true + else + result := false; +end; + +Procedure TImgForm.SetAutoFill; +begin + if gBGImg.AutoFill then begin + if FillBtn.Down then + ClosedPenBtn.Down := true; + FillBtn.GroupIndex := 0 + end else + FillBtn.GroupIndex :=ClosedPenBtn.GroupIndex; +end; + + +procedure TImgForm.UpdateColorSchemes; +var + lSearchRec: TSearchRec; +begin + LUTdrop.Items.Clear; + LUTdrop.Items.Add('Grayscale'); + LUTdrop.Items.Add('Red'); + LUTdrop.Items.Add('Blue'); + LUTdrop.Items.Add('Green'); + LUTdrop.Items.Add('Violet [r+b]'); + LUTdrop.Items.Add('Yellow [r+g]'); + LUTdrop.Items.Add('Cyan [g+b]'); + if FindFirst(gColorSchemeDir+pathdelim+'*.lut', faAnyFile, lSearchRec) = 0 then + repeat + LUTdrop.Items.Add(ParseFileName(ExtractFileName(lSearchRec.Name))); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end;//UpdateColorSchemes + +procedure Add2MRU (var lNewFilename: string); //add new file to most-recent list +var + lStr: string; + lPos,lN : integer; +begin + //first, increase position of all old MRUs + lN := 0; //Number of MRU files + for lPos := 1 to (knMRU) do begin//first, eliminate duplicates + lStr := gMRUstr[lPos]; + if (lStr <> '') and (lStr <> lNewFileName) then begin + inc(lN); + gMRUstr[lN] := lStr; + end; //keep in MRU list + end; //for each MRU + //next, increment positions + if lN >= knMRU then + lN := knMRU - 1; + for lPos := lN downto 1 do + gMRUstr[lPos+1] := gMRUstr[lPos]; + if (lN+2) < (knMRU) then //+1 as we have added a file + for lPos := (lN+2) to knMRU do + gMRUstr[lPos] := ''; + gMRUstr[1] := lNewFilename; + ImgForm.UpdateMRU; + ImgForm.SaveDialog1.FileName := lNewFilename; +end;//Add2MRU + +procedure TImgForm.UpdateMRU;//most-recently-used menu +var + NewItem: TMenuItem; + lPos,lN : integer; +begin + While Recent1.Count > 0 do Recent1.Items[0].Free; + lN := 0; //Number of MRU files + for lPos := 1 to knMRU do begin//for each MRU + if gMRUstr[lPos] <> '' then begin + inc(lN); + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ExtractFileName(gMRUstr[lPos]);//(ParseFileName(ExtractFileName(gMRUstr[lPos]))); + NewItem.Tag := lN; + NewItem.RadioItem := true; + NewItem.Onclick := OpenTemplateMRU; + NewItem.ShortCut := ShortCut(Word('1')+ord(lN-1), [ssCtrl]); + Recent1.Add(NewItem); + gMRUstr[lN] := gMRUstr[lPos]; //eliminate empty items + end; //add new item + end; //for each possible MRU + if lN < knMRU then //empty unused strings + for lPos := (lN +1) to knMRU do + gMRUstr[lPos] := ''; +end;//UpdateMRU + +procedure TImgForm.UpdateTemplates; +var + NewItem: TMenuItem; + lN : integer; + lFName : String; + lSearchRec: TSearchRec; +begin + While Templates1.Count > 0 do Templates1.Items[0].Free; + lN := 0; + if FindFirst(gTemplateDir+pathdelim+'*.*', faAnyFile, lSearchRec) = 0 then begin + repeat + lFName := lSearchRec.Name; + if IsNIfTIHdrExt (lFName) then begin + inc(lN); + NewItem := TMenuItem.Create(Self); + NewItem.Caption :=ExtractFileName(lFName);//(ParseFileName(ExtractFileName(lFName))); + //showmessage(newItem.caption); + NewItem.Tag := 0; + NewItem.RadioItem := true; + NewItem.Onclick := OpenTemplateMRU; + NewItem.ShortCut := ShortCut(Word('1')+knMRU+ord(lN-1), [ssCtrl]); + Templates1.Add(NewItem); + end; + until (FindNext(lSearchRec) <> 0) + end; + FindClose(lSearchRec); +end;//UpdateTemplates + +function txt(str: string): string; +//Delphi6 and later add special characters... +var + lp,llen: integer; +begin + result := ''; + llen := length(str); + if llen < 1 then + exit; + for lp := 1 to llen do + if str[lp] in [' ','[',']','+','-','.','\','~','/', '0'..'9','a'..'z','A'..'Z'] then + result := result + str[lp]; +end; + +function Findfile ( lDir, lExt: string): string; +//findfile ('c:\myfolder','.nii') +var + lLen: integer; + lDirx,lExtx,lPath: string; + lSearchRec: TSearchRec; +begin + //1st : make sure pathdelim at end of folder name + lDirx := lDir; + lLen := length(lDir); + if (lLen > 1) and (lDirx[lLen] <> pathdelim) then + lDirx := lDirx + pathdelim; + //2nd : make sure extension is '.hdr' not 'hdr' + lExtx := lExt; + lLen := length(lExt); + if (lLen > 0) and (lExtx[1] <> '.') then + lExtx := '.'+lExtx; + lPath := lDirx+'*'+lExtx; + Filemode := 0; //readonly + result := ''; + if FindFirst(lPath, faAnyFile-faSysFile-faDirectory, lSearchRec) = 0 then + result := lDirx + lSearchRec.Name; + SysUtils.FindClose(lSearchRec); + Filemode := 2; +end; + +procedure TImgForm.OpenTemplateMRU(Sender: TObject);//open template or MRU +//Templates have tag set to 0, Most-Recently-Used items have tag set to position in gMRUstr +var + lFilename: string; +begin + CloseImagesClick(nil); + if sender = nil then begin + //autolaunch with last image, or last template image in list + lFilename := gMRUstr[0]; + if (lFilename = '') or (not FileExistsEX(lFilename)) then begin + lFilename := Findfile(GetCurrentDir,'.hdr'); + if lFilename = '' then + lFilename := Findfile(GetCurrentDir,'.nii'); + if lFilename = '' then + lFilename := Findfile(GetCurrentDir,'.nii.gz'); + //lStr := extractfiledir(ParamStr(0))+'\templates\xz.voi'; + //lStr := 'c:\zx\c1fxcbruce.nii'; + if fileexists(lFilename) then begin + OpenAndDisplayImg(lFilename,false); + exit; + end; + if Templates1.Count > 0 then + Templates1.Items[Templates1.Count-1].click; + exit; + end; + OpenAndDisplayImg(lFilename,false); //open but do not add templates to MRU + end else if (Sender as TMenuItem).tag = 0 then begin + lFilename := gTemplateDir+pathdelim+txt((Sender as TMenuItem).caption) ;//+ '.hdr'; + OpenAndDisplayImg(lFilename,false); //open but do not add templates to MRU + end else if (Sender as TMenuItem).tag <= knMRU then begin + lFilename := gMRUstr[(Sender as TMenuItem).tag]; + OpenAndDisplayImg(lFilename,true); + end else + Showmessage('OpenTemplateMRU error.'); +end; + +function TImgForm.OpenAndDisplayImg(var lFilename: string; lAdd2MRU: boolean): boolean; +var + lInName: string; +begin + CloseImagesClick(nil); + Result := false; + imgForm.Triplepanel.VertScrollBar.Position := 0; + imgForm.Triplepanel.HorzScrollBar.Position := 0; + lInName := lFilename; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kBGOverlayNum]) then exit; + if (ssCtrl in KeyDataToShiftState(vk_Shift)) and (gBGIMg.OrthoReslice) then begin + gBGIMg.OrthoReslice := false; + OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false); + gBGIMg.OrthoReslice := true; + end else if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,not gBGImg.ResliceOnLoad,false) then exit + end else + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,gBGImg.ResliceOnLoad,false) then exit; + XViewEdit.MaxValue := gBGImg.ScrnDim[1];//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1]; + YViewEdit.MaxValue := gBGImg.ScrnDim[2];//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]; + ZViewEdit.MaxValue :=gBGImg.ScrnDim[3];// gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3]; + //XViewEdit.Value := round(gBGImg.ScrnOri[1]);//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[1] div 2; + //YViewEdit.Value := round(gBGImg.ScrnOri[2]);//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[2]div 2; + //ZViewEdit.Value := round(gBGImg.ScrnOri[3]);//gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.dim[3] div 2; + XViewEdit.Value := Bound ( round(gBGImg.ScrnOri[1]),1,round(XViewEdit.MaxValue)); + YViewEdit.Value := Bound ( round(gBGImg.ScrnOri[2]),1,round(YViewEdit.MaxValue)); + ZViewEdit.Value := Bound ( round(gBGImg.ScrnOri[3]),1,round(ZViewEdit.MaxValue)); + ImgForm.Caption := extractfilename(paramstr(0))+' - '+lInName; + ImgForm.SaveDialog1.Filename := lInName; + StatusLabel.caption := 'opened: '+lInName; + Result := true; + if lAdd2MRU then + Add2MRU(lInName); //inname not filename, so if user selects im.nhdr that points to im.nhdr.gz + if gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.datatype = kDT_RGB then begin //RGB + //we have loaded the first [red] plane - now load green and blue... + LoadOverlay(lFilename); + LoadOverlay(lFilename); + //must use additive blending + //gBGImg.BGTransPct := -1; + //gBGImg.OverlayTransPct := -1; + OverlayAdditive.Click; + BGAdditive.Click; + end; + AnatForm.OpenAnat( ChangeFileextx(lFilename,'.anat')); +end; //OpenAndDisplayImg + +procedure TImgForm.WMDropFiles(var Msg: TWMDropFiles); //implement drag and drop +var + CFileName: array[0..MAX_PATH] of Char; + lFilename: string; +begin + try + if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then + begin + lFilename := CFilename; + OpenAndDisplayImg(lFilename,true); + Msg.Result := 0; + end; + finally + DragFinish(Msg.Drop); + end; +end; + +procedure TImgForm.Exit1Click(Sender: TObject); +begin + ImgForm.Close; +end; + +function XToStr(lR: extended; lDec: integer): string; +begin + result := FloatToStrF(lR, ffFixed,7,lDec); +end; + +(*procedure RZ; +var + lC: integer; +begin + TextForm.Memo1.Lines.clear; + for lC := 0 to knMaxOverlay do begin + TextForm.Memo1.Lines.add(inttostr(lC)+'= '+inttostr (gMRIcroOverlay[lC].ScrnBufferItems)+'= '+inttostr (gMRIcroOverlay[lC].ImgBufferItems)); + end; + TextForm.show; +end; + +procedure KillBlueX; +var + lVox,lVolVox: integer; +begin + lVolVox := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lVolVox then exit;//r + if gMRIcroOverlay[kBGOverlayNum+1].ScrnBufferItems <> lVolVox then exit;//g + if gMRIcroOverlay[kBGOverlayNum+2].ScrnBufferItems <> lVolVox then exit;//b + for lVox := 1 to lVolVox do begin + if (gMRIcroOverlay[kBGOverlayNum+2].ScrnBuffer^[lVox] > (gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox]+24)) + and (gMRIcroOverlay[kBGOverlayNum+2].ScrnBuffer^[lVox] > (gMRIcroOverlay[kBGOverlayNum+1].ScrnBuffer^[lVox]+24)) then begin + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] := 0; + gMRIcroOverlay[kBGOverlayNum+1].ScrnBuffer^[lVox] := 0; + gMRIcroOverlay[kBGOverlayNum+2].ScrnBuffer^[lVox] := 0; + + end; + + end; +end; + +procedure KillBlue; +var + lVox,lVolVox: integer; +begin + lVolVox := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lVolVox then exit;//r + if gMRIcroOverlay[kBGOverlayNum+1].ScrnBufferItems <> lVolVox then exit;//g + if gMRIcroOverlay[kBGOverlayNum+2].ScrnBufferItems <> lVolVox then exit;//b + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems <> lVolVox then exit;//b + for lVox := 1 to lVolVox do begin + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lVox] = 0) and (gMRIcroOverlay[kBGOverlayNum+2].ScrnBuffer^[lVox] > (gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox])) + and (gMRIcroOverlay[kBGOverlayNum+2].ScrnBuffer^[lVox] > (gMRIcroOverlay[kBGOverlayNum+1].ScrnBuffer^[lVox])) then begin + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] := 0; + gMRIcroOverlay[kBGOverlayNum+1].ScrnBuffer^[lVox] := 0; + gMRIcroOverlay[kBGOverlayNum+2].ScrnBuffer^[lVox] := 0; + + end; + end; +end; *) + + + +procedure TImgForm.About1Click(Sender: TObject); +begin +//KillBlue; exit; +// Graph4DForm.XL; + AboutForm.ThreadLabel.Caption := 'Threads = '+inttostr(gnCPUThreads); + AboutForm.Showmodal; +end; + +function TImgForm.ActiveLayer:integer; +begin + result := ImgForm.LayerDrop.ItemIndex; + if result < 0 then begin + result := 0; + ImgForm.LayerDrop.ItemIndex := 0; + + end; +end; + +procedure TImgForm.DisplayHdrClick(Sender: TObject); +var + lLayer:integer; +begin + lLayer := ActiveLayer; + HdrForm.SaveHdrDlg.Filename := gMRIcroOverlay[lLayer].HdrFilename; + HdrForm.WriteHdrForm (gMRIcroOverlay[lLayer]); + HdrForm.Show; +end; + +procedure TImgForm.Open1Click(Sender: TObject); +var + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select background image',false) then exit; + lFilename := HdrForm.OpenHdrDlg.Filename; + OpenAndDisplayImg(lFilename,True); +end; + +procedure TImgForm.ToolSelectClick(Sender: TObject); +begin + if (not ToolPanel.Visible) and ((Sender as TMenuItem).Tag > 0) then exit; //tools disabled + case (Sender as TMenuItem).Tag of + 0: XBarBtn.Down := not XBarBtn.Down; + 2: PenBtn.Down := true; + 3: ClosedPenBtn.Down := true; + 4: begin + if gBGImg.AutoFill then + FillBtnClick(nil) + else + FillBtn.Down := true; + end; + 5: EllipseBtn.Down := true; + 6: begin + PenBtn.Down := false; + ClosedPenBtn.Down := false; + FillBtn.Down := false; + EllipseBtn.Down := false; + end; + end; //case + RefreshImagesTimer.Enabled := true; +end; + +function SelectedImage: TImage; +begin + case SelectedImageNum of + 3: result := ImgForm.PGImageCor; + 2: result := ImgForm.PGImageSag; + else + result := ImgForm.PGImageAx; + end; +end; + +procedure TImgForm.SetDimension8(lInPGHt,lInPGWid:integer; lBuff: ByteP; lUndoOnly: boolean); +var + PixMap: pointer; + Bmp : TBitmap; + hBmp : HBITMAP; + BI : PBitmapInfo; + BIH : TBitmapInfoHeader; + ImagoDC : hDC; + lPixmapInt,lBuffInt, + I,lScanLineSz,lScanLineSz8: integer; +begin + BIH.biSize := Sizeof(BIH); + BIH.biWidth := lInPGwid; + BIH.biHeight := lInPGHt; + BIH.biPlanes := 1; + BIH.biBitCount := 8;//lBits; + BIH.biCompression := BI_RGB; + BIH.biSizeImage := 0; + BIH.biXPelsPerMeter := 0; + BIH.biYPelsPerMeter := 0; + BIH.biClrUsed := 0; + BIH.biClrImportant := 0; + BI := AllocMem(SizeOf(TBitmapInfoHeader) + 256*Sizeof(TRGBQuad)); + BI^.bmiHeader := BIH; + for I:=0 to 255 do begin + BI^.bmiColors[I].rgbRed := i; + BI^.bmiColors[I].rgbGreen := i; + BI^.bmiColors[I].rgbBlue := i; + BI^.bmiColors[I].rgbReserved := 0; + end; + I := kVOI8bit; + BI^.bmiColors[I].rgbRed := (gBGImg.VOIClr ) and 255;; + BI^.bmiColors[I].rgbGreen := (gBGImg.VOIClr shr 8) and 255;; + BI^.bmiColors[I].rgbBlue := (gBGImg.VOIClr shr 16) and 255;; + Bmp := TBitmap.Create; + Bmp.Height := lInPGHt; + Bmp.Width := lInPGwid; + ImagoDC := GetDC(Self.Handle); + hBmp:= CreateDIBSection(imagodc,bi^,DIB_RGB_COLORS,pixmap,0,0); + lScanLineSz := lInPGwid; + if(lInPGwid mod 4) <> 0 then lScanLineSz8 := 4*((lInPGWid + 3)div 4) + else lScanLineSz8 := lInPGwid; + if lBuff <> nil then begin + lPixmapInt := Integer(pixmap); + lBuffInt := Integer(lBuff); + For i:= (Bmp.Height-1) downto 0 do + CopyMemory(Pointer(lPixmapInt+lScanLineSz8*(i)), + Pointer(lBuffInt+i*lScanLineSz),lScanLineSz); + end; //lBuff full + ReleaseDC(0,ImagoDC); + Bmp.Handle := hBmp; + UndoImg.Picture.Assign(Bmp); + UndoImg.width := Bmp.Width; + UndoImg.height := Bmp.Height; + if not lUndoOnly then begin + DrawImg.Picture.Assign(Bmp); + DrawImg.width := Bmp.Width; + DrawImg.height := Bmp.Height; + end; + Bmp.Free; + FreeMem( BI); +end; + +procedure WriteAxialVOI (lUndoOnly: boolean); +var lX,lY,lSliceOffset,lSliceSz,lSlicePos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lSliceSz := lX*lY; + if lSliceSz < 1 then exit; + lSliceOffset := (ImgForm.ZViewEdit.asInteger-1)*lX*lY; + gBGImg.VOIUndoSlice := ImgForm.ZViewEdit.asInteger; + getmem(lInBuff,lSliceSz); + for lSlicePos := 1 to lSliceSz do + lInBuff[lSlicePos] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lSliceOffset+lSlicePos]; + ImgForm.SetDimension8(lY,lX, lInBuff,lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteCorVOI (lUndoOnly: boolean); +var lX,lY,lZ,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lXPos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lYOffset := (lX) * (round(ImgForm.YViewEdit.asInteger)-1); + gBGImg.VOIUndoSlice := ImgForm.YViewEdit.asInteger; + lXYSliceSz := (lX*lY); + getmem(lInBuff,lZ*lX); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + lInBuff[lPixel] := + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lZOffset+lYOffset+lXPos]; + end; //for each Y + end; //for each Z + ImgForm.SetDimension8(lZ,lX, lInBuff,lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteSagVOI (lUndoOnly: boolean); +var lX,lY,lZ,lXOffset,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lYPos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lXYSliceSz := lX*lY; + lXOffset := round(ImgForm.XViewEdit.Value); + gBGImg.VOIUndoSlice := ImgForm.XViewEdit.asInteger; + getmem(lInBuff,lZ*lY); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + lInBuff[lPixel] := gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lZOffset+lYOffset+lXOffset]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z + ImgForm.SetDimension8(lZ,lY, lInBuff, lUndoOnly); + freemem(lInBuff); +end; + +procedure WriteUndoVOI(lPanel: integer;lUndoOnly: boolean); +begin + EnsureVOIOPen; + case lPanel of + 3: WriteCorVOI(lUndoOnly); + 2: WriteSagVOI(lUndoOnly); + else WriteAxialVOI(lUndoOnly); + end; + gBGImg.VOIchanged := true; + if gBGImg.VOIUndoOrient = 4 then + FreeUndoVol; //release 3D undo buffer when creating 2D buffer + gBGImg.VOIUndoOrient := lPanel; +end; + +procedure TImgForm.FormCreate(Sender: TObject); +var + lInc: longint; +begin +gnCPUThreads := GetLogicalCpuCount; +randomize; + DecimalSeparator := '.'; + gMouseDownX := -1; + ImgForm.Caption := extractfilename(paramstr(0)); + {$IFNDEF VER150} + ImgForm.DoubleBuffered := true; //bug in D7 causes form transparency issues + {$ENDIF} + for lInc := 0 to knMaxOverlay do begin + InitImgMemory(gMRIcroOverlay[lInc]); + NIFTIhdr_ClearHdr(gMRIcroOverlay[lInc]); + //gMRIcroOverlay[lInc].ScrnBufferItems := 0; + //gMRIcroOverlay[lInc].ImgBufferItems := 0; + //gMRIcroOverlay[lInc].RenderBufferItems := 0; + if lInc < knAutoLUT then + gMRIcroOverlay[lInc].LUTindex := lInc + else + gMRIcroOverlay[lInc].LUTindex := lInc;//B&W + LoadMonochromeLUT(gMRIcroOverlay[lInc].LUTindex,gBGImg,gMRIcroOverlay[lInc]); + end; + lInc:=maxint; + LoadMonochromeLUT(lInc,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + SetBGImgDefaults(gBGImg); + CloseImagesClick(nil); + gColorSchemeDir := extractfilepath(paramstr(0))+'lut'; + DragAcceptFiles(Handle, True); //engage drag and drop + UpdateColorSchemes; + LUTdrop.ItemIndex := (0); + Zoomdrop.ItemIndex := (0); + LayerDrop.ItemIndex :=(0); + gTemplateDir := extractfilepath(paramstr(0))+'templates'; + UpdateTemplates; + for lInc := 1 to knMRU do + gMRUstr[lInc] := ''; + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + case MessageDlg('Shift key down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + id_No: ReadIniFile; + end; //case + end else + ReadIniFile; + //SetIniMenus; + WriteIni2Form(gBGImg); + SetAutoFill; + DefaultControlPanel; + UpdateMRU; + //SmoothBtnClick(nil); + OverlaySmoothMenuClick(nil); + LUTDropSelect(nil); + ZoomDropSelect(nil); + CreateShareMem; + if YokeMenu.checked then YokeTimer.enabled := true; +end; + +function ImgIntensity(var lHdr: TMRIcroHdr; lPos: integer): single; overload; +var + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + + result := 0; + if (lPos > lHdr.ImgBufferItems) or (lPos < 1) then exit; + if (lHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(lHdr.ImgBuffer ); + result := l32Buf^[lPos]; + end else if (lHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(lHdr.ImgBuffer ); + result := l16Buf^[lPos]; + end else if lHdr.ImgBufferBPP = 1 then + result := lHdr.ImgBuffer^[lPos] + else begin + showmessage('Unknown Image Buffer Bytes Per Pixel: '+inttostr(lHdr.ImgBufferBPP)+' '+lHdr.HdrFileName); + exit; + end; + result := Raw2ScaledIntensity (lHdr,result); +end; + +function ImgIntensity(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): single; overload; +var + lPos: integer; +begin + lPos := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + ImgIntensity(lHdr,lPos); +end; + +function TImgForm.ImgIntensityString(var lHdr: TMRIcroHdr; lVox: integer): string; +var + lV: integer; +begin + if (lVox > lHdr.ImgBufferItems) or (lVox < 1) then exit; + if lHdr.UsesLabels then begin + lV := round(ImgIntensity(lHdr,lVox)); + if lV <= High(gBGImg.LabelRA) then + result := gBGImg.LabelRA[lV]; + exit; + end; + if (not lHdr.UsesCustomPalette) or (lHdr.NIFTIhdr.datatype = kDT_RGB) then begin + result := realtostr(ImgIntensity(lHdr,lVox),gBGImg.SigDig); + exit; + end; +end; + +function TImgForm.ImgIntensityStringXYZ(var lHdr: TMRIcroHdr; lX,lY,lZ: integer): string; +var + lVox: integer; +begin + lVox := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + result := ImgIntensityString(lHdr,lVox); +end; + +procedure TImgForm.UpdateStatusLabel; +var + lX,lY,lZ,lOverlay,lLen: integer; + lXmm,lYmm,lZmm: single; + lIntenStr : string; +begin + lX := XviewEdit.asInteger; + lY := YViewEdit.asInteger; + lZ := ZViewEdit.asInteger; + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + lIntenStr := ''; + for lOverlay := kBGOverlayNum to (kVOIOverlayNum-1) do + if gMRIcroOverlay[lOverlay].ImgBufferItems > 0 then + lIntenStr := lIntenStr + ImgIntensityStringXYZ(gMRIcroOverlay[lOverlay],lX,lY,lZ)+', '; + lLen := length (lIntenstr); + if lLen > 2 then + lIntenStr[lLen-1] := ' '; + StatusLabel.Caption := realtostr(lXmm,0)+'x'+realtostr(lYmm,0)+'x'+realtostr(lZmm,0)+'= '+lIntenStr; + SetShareMem (lXmm,lYmm,lZmm); +end; + +procedure TImgForm.XViewEditChange(Sender: TObject); +begin + gBGImg.XViewCenter := XviewEdit.value; + gBGImg.YViewCenter := YViewEdit.asInteger; + gBGImg.ZViewCenter := ZViewEdit.asInteger; + RefreshImagesTimer.Enabled := true; + //Oct2007:better only once per ImagesTimer: UpdateStatusLabel; +end; + +procedure TImgForm.FormClose(Sender: TObject; var Action: TCloseAction); +begin + ReadForm2Ini (gBGImg); + WriteIniFile; + CloseImagesClick(nil); +end; + +procedure SelectPanel (lPanelNumber: integer); +begin +(* with ImgForm do begin + case lPanelNumber of + 2: begin ImgPanel1.BorderStyle := bsNone; ImgPanel2.BorderStyle := bsSingle; ImgPanel3.BorderStyle := bsNone; end; + 3: begin ImgPanel1.BorderStyle := bsNone; ImgPanel2.BorderStyle := bsNone; ImgPanel3.BorderStyle := bsSingle; end; + else begin ImgPanel1.BorderStyle := bsSingle; ImgPanel2.BorderStyle := bsNone; ImgPanel3.BorderStyle := bsNone; end; + end; + end; //with ImgForm *) +gSelectedImageNum := lPanelNumber; +end; //Proc SelectPanel + +procedure ShowFocusRect(lInRect: TRect); +var LImage: TImage; +begin + lImage := SelectedImage; + lImage.Canvas.DrawFocusRect(lInRect); +end; //proc ShowFocusRect + +procedure XYscrn2Img (lImage: TImage;lPanel,lXinRaw,lYinRaw: integer; var lXout,lYOut,lZOut: integer); +var + lYin,lXin,lZoom : integer; + lOffset: single; +begin + //amx - must match XYscrn2Img and DrawXBar - e.g. +0.5 for middle of zoomed slice + lZoom := ImageZoomPct(lImage); + if lZoom = 0 then lZoom := 100; + if lZoom > 100 then lOffset := 0.5 else + lOffset := 0; + lXIn := lXinRaw + 1; //index from 0 + lYin := lImage.Height-lYinRaw; + case lPanel of + 2: begin + lXOut := ImgForm.XViewEdit.asInteger; + if gBGImg.FlipSag then + lXin := lImage.Width-lXinRaw; + lYOut := round((lXin*100) / lZoom +lOffset); + lZOut := round((lYin*100) / lZoom +lOffset); + end; + 3: begin + lXOut := round((lXin*100) / lZoom +lOffset); + lYOut := ImgForm.YViewEdit.asInteger; + lZOut := round((lYin*100) / lZoom +lOffset); + + end; + else begin //Axial + if gBGImg.FlipAx then + lYin := lYinRaw; + lXOut := round((lXin*100) / lZoom +lOffset); + lYOut := round((lYin*100) / lZoom +lOffset); + lZOut := ImgForm.ZViewEdit.asInteger; + end; //else + end;//case lPanel + //ImgForm.Caption := inttostr(lXOut)+' '+inttostr(lYOut)+' '+Inttostr(lZOut); +end; //proc XYscrn2Img + + +function DX (lImage: TIMage;lPanel: integer; lInRect: TRect): single; +var lX,lY,lZ: integer; + lXmm,lYmm,lZmm,lXmm2,lYmm2,lZmm2: single; +begin + //XYscrn2Img (lImage: TIMage;lPanel,lXinRaw,lYinRaw: integer; var lXout,lYOut,lZOut: integer); + XYscrn2Img (lImage,lPanel,lInRect.Left,lInRect.Top, lX,lY,lZ); + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + XYscrn2Img (lImage,lPanel,lInRect.Right,lInRect.Bottom, lX,lY,lZ); + ImgCoordToMM(lX,lY,lZ,lXmm2,lYmm2,lZmm2); + result := sqrt(sqr( lXmm-lXmm2 ) + sqr(lYmm-lYmm2)+ sqr(lZmm-lZmm2)); + (*lView := SelectedImageNum; + case lView of + 3: begin //coronal + lY := 1; + lX := lInRect.Left; + lZ := lInRect.Top; + xx + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + lX := lInRect.Right; + lZ := lInRect.Bottom; + ImgCoordToMM(lX,lY,lZ,lXmm2,lYmm2,lZmm2); + result := sqrt(sqr( lXmm-lXmm2 ) + sqr(lZmm-lZmm2)); + end; + 2: begin //sagittal + lX := 1; + lY := lInRect.Left; + lZ := lInRect.Top; + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + lY := lInRect.Right; + lZ := lInRect.Bottom; + ImgCoordToMM(lX,lY,lZ,lXmm2,lYmm2,lZmm2); + result := sqrt(sqr( lYmm-lYmm2 ) + sqr(lZmm-lZmm2)); + end; + else begin //axial + lZ := 1; + lX := lInRect.Left; + lY := lInRect.Top; + ImgCoordToMM(lX,lY,lZ,lXmm,lYmm,lZmm); + lX := lInRect.Right; + lY := lInRect.Bottom; + ImgCoordToMM(lX,lY,lZ,lXmm2,lYmm2,lZmm2); + result := sqrt(sqr( lXmm-lXmm2 ) + sqr(lYmm-lYmm2)); + end; + end; //case *) +end;//func DX + +procedure ShowDXLine(lImage: TIMage;lPanel: integer; lInRect: TRect); +begin + if lPanel <> gSelectOrigin.Y then + exit; //only draw on source + RefreshActiveImage; + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + lImage.Canvas.MoveTo(lInRect.Left,lInRect.Top); + lImage.Canvas.LineTo(lInRect.Right,lInRect.Bottom); + ImgForm.StatusLabel.Caption := realtostr(DX(lImage,lPanel, lInRect),gBGImg.SigDig); +end; //proc ShowFocusRect + +procedure AdjustContrastRectangle (lImage: TImage; lRect: TRect); +var + lXpos,lYPos,lXOut,lYOut,lZOut,lPanel,lLayer: integer; + lMinInten,lMaxInten,lVal: single; +begin + lPanel := SelectedImageNum; + lLayer := ImgForm.ActiveLayer; + XYscrn2Img (lImage,lPanel,gSelectRect.Left,gSelectRect.Top, lXout,lYOut,lZOut); + lMinInten := ImgIntensity(gMRIcroOverlay[lLayer],lXout,lYOut,lZOut); + lMaxInten := lMinInten; + for lYpos := gSelectRect.Top to gSelectRect.Bottom do begin + for lXpos := gSelectRect.Left to gSelectRect.Right do begin + XYscrn2Img (lImage,lPanel,lXpos,lYPos, lXout,lYOut,lZOut); + lVal:= ImgIntensity(gMRIcroOverlay[lLayer],lXout,lYOut,lZOut); + if lVal < lMinInten then lMinInten := lVal; + if lVal > lMaxInten then lMaxInten := lVal; + end; //for PGX each column + end; //for PGY2 - each row + ImgForm.StatusLabel.caption := 'Intensity range '+(RealToStr(lMinInten,4))+'..'+({x} RealToStr(lMaxInten,4)); + if lMinInten = lMaxInten then exit; //no range + ImgForm.MinWindowEdit.value := lMinInten; + ImgForm.MaxWindowEdit.value := lMaxInten; +end; + +procedure sortLTRB(var lXoutLow,lYOutLow,lXoutHi,lYOutHi: integer); //left<right, top<bottom +var lXin1,lYin1,lXin2,lYin2: integer; +begin + lXin1 := lXoutLow; + lYin1 := lYOutLow; + lXin2 := lXoutHi; + lYin2 := lYOutHi; + if lXIn1 < lXin2 then begin + lXoutLow := lXIn1; + lXOutHi := lXIn2; + end else begin + lXoutLow := lXIn2; + lXOutHi := lXIn1; + end; + if lYIn1 < lYin2 then begin + lYoutLow := lYIn1; + lYOutHi := lYIn2; + end else begin + lYoutLow := lYIn2; + lYOutHi := lYIn1; + end; +end; //sortLTRB + +procedure DrawEllipse (lImage: TImage; lRect: TRect; lShift: TShiftState; lPanel: integer); +begin + ScaleBMP2Draw(gBGImg.VOIInvZoom, lRect.Left,lRect.Top, lPanel,lImage); + ScaleBMP2Draw(gBGImg.VOIInvZoom, lRect.Right,lRect.Bottom,lPanel, lImage); + if (ssCtrl in lShift) then + ImgForm.DrawImg.Canvas.Rectangle(lRect.Left,lRect.Top,lRect.Right,lRect.Bottom) + else + ImgForm.DrawImg.Canvas.Ellipse(lRect.Left,lRect.Top,lRect.Right,lRect.Bottom); +end; //DrawEllipse + +function PenThick (lWidth: integer): integer; +//gives scaled pen thickness, e.g. 3-width pen at 200% = 6pixels +begin + result := round(gBGImg.BasePenThick * lWidth); + if result < 1 then + result := 1; +end; + +procedure TImgForm.PGImageMouseDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer); +label 131; +var lZoom,lPanel,lX, lY,lXout,lYOut,lZOut,lX2, lY2: integer; + lImage: TImage; + lDX: boolean; +begin + if gSelectOrigin.X = -666 then + lDX := true + else + lDX := false; + gSelectOrigin.X := -1; + lX := X; lY := Y; + lImage := Sender as TImage; + if lImage.Name = 'PGImageCor' then lPanel := 3 + else if lImage.Name = 'PGImageSag' then lPanel := 2 + else lPanel := 1; + SelectPanel(lPanel); + gBGImg.VOIInvZoom := ComputeInvZoomShl10(lPanel,lImage); +if DrawToolSelected and (ssAlt in Shift) then + goto 131; + if DrawToolSelected then begin //paint tool + WriteUndoVOI(lPanel,false); + if (ssShift in Shift) then begin //erase + lImage.Canvas.Brush.Color:=clBlack; + lImage.Canvas.Pen.Color := clBlack; + DrawImg.Canvas.Brush.Color:=clBlack; + DrawImg.Canvas.Pen.Color := clBlack; + end else begin + lImage.Canvas.Brush.Color:=gBGImg.VOIClr; + lImage.Canvas.Pen.Color := gBGImg.VOIClr; + DrawImg.Canvas.Brush.Color:=gBGImg.VOIClr; + DrawImg.Canvas.Pen.Color :=gBGImg.VOIClr; + end; + if (gBGImg.ThinPen) then + gBGImg.BasePenThick := 1 + else begin //adjust pen thickness for zoom level + if gBGImg.ZoomPct < 100 then begin + lZoom := ComputeZoomPct(lPanel,lImage); + if lZoom = 100 then + gBGImg.BasePenThick := 1 + else + gBGImg.BasePenThick := ComputeZoomPct(lPanel,lImage) / 100;//mar07 round((ComputeZoomPct(lPanel,lImage)+50) / 100); + end else if gBGImg.ZoomPct > 100 then + gBGImg.BasePenThick := gBGImg.ZoomPct / 100//mar07 gBGImg.ZoomPct div 100 + else + gBGImg.BasePenThick := 1; + end; //if not thinpen + //gBGImg.BasePenThick := lBasePenThick; + if (ssCtrl in Shift) then begin + lImage.Canvas.Pen.Width := PenThick(3); + DrawImg.Canvas.Pen.Width := 3; + end else begin + lImage.Canvas.Pen.Width := PenThick(1); + DrawImg.Canvas.Pen.Width := 1; + + //lImage.Canvas.Pen.Width := PenThick(20); //thick pen! + //DrawImg.Canvas.Pen.Width := 20; //thick pen! + end; + end; //paint tool selected + if (FillBtn.Down) and (ssCtrl in Shift) then begin //3D fill + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + XViewEdit.asInteger := lXOut; + YViewEdit.asInteger := lYOut; + ZViewEdit.asInteger := lZOut; + if (ssShift in Shift) then //erase + ROICluster(gBGImg.ScrnDim[1], gBGImg.ScrnDim[2], gBGImg.ScrnDim[3],XViewEdit.asInteger,YViewEdit.asInteger,ZViewEdit.asInteger,true) + else //draw + ROICluster(gBGImg.ScrnDim[1], gBGImg.ScrnDim[2], gBGImg.ScrnDim[3],XViewEdit.asInteger,YViewEdit.asInteger,ZViewEdit.asInteger,false); + exit; + end; //end 3D fill + if (not PenBtn.Down) and (not ClosedPenBtn.Down) and (not FillBtn.Down) then begin + if (EllipseBtn.Down) or (ssRight in Shift) then begin + lImage.Canvas.Brush.Color:=gBGImg.VOIClr; + //lImage.Canvas.Pen.Color :=gBGImg.VOIClr; + ScaleScrn2BMP(lX,lY, lImage); + gSelectRect.Left := lX; + gSelectRect.Top := lY; + gSelectRect.Right := lX; + gSelectRect.Bottom := lY; + ShowFocusRect(gSelectRect); + gSelectOrigin.X := gSelectRect.Left; + gSelectOrigin.Y := gSelectRect.Top; + exit; + end; +131: + //show distance line if shift + if (not lDX) and (ssShift in Shift) then begin + ScaleScrn2BMP(lX,lY, lImage); + gSelectRect.Left := lX; + gSelectRect.Top := lY; + gSelectOrigin.X := -666;//length line + gSelectOrigin.Y := lPanel; + end; + //next no paint tools selected - show position where click occurred + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + XViewEdit.asInteger := lXOut; + YViewEdit.asInteger := lYOut; + ZViewEdit.asInteger := lZOut; + //showmessage(floattostr(lXOut)+'x'+floattostr(lYOut)+'x'+floattostr(lZOut)); + //ImgCoordToMM(lXOut,lYOut,lZOut,lXmm,lYmm,lZmm); + //showmessage(floattostr(lXmm)+'x'+floattostr(lYmm)+'x'+floattostr(lZmm)); + + //showmessage(floattostr(gBGImg.ScrnOri[1])+'x'+floattostr(gBGImg.ScrnOri[2])+'x'+floattostr(gBGImg.ScrnOri[3])); + //MMToImgCoord(lXOut,lYOut,lZOut,lXmm,lYmm,lZmm); + //showmessage(floattostr(lXOut)+'x'+floattostr(lYOut)+'x'+floattostr(lZOut)); + + //SetShareMem (lXmm,lYmm,lZmm); + exit; + end; + //if (lX < 2) or (lY < 2) then exit; + ScaleScrn2BMP(lX,lY, lImage); + //lImage.Canvas.MoveTo(lX,lY); + lX2 := X; lY2 := Y; + ScaleBMP2Draw(gBGImg.VOIInvZoom, lX2,lY2,lPanel,lImage); + if (FillBtn.Down) or(ssRight in Shift) then begin + gMouseDownX := -1; //5/5/2008 - Wacom Stylus patch + if (ssShift in Shift) then //8/8/2008 - removed -1 from lX2 and lY2 + DrawImg.Canvas.FloodFill(lX2,lY2,gBGImg.VOIClr, fsSurface) + else + DrawImg.Canvas.FloodFill(lX2,lY2,gBGImg.VOIClr, fsBorder); + + exit; + end; + lImage.Canvas.MoveTo(lX,lY); + DrawImg.Canvas.MoveTo(lX2,lY2); + gMouseDownX := lX; + gMouseDownY := lY; +end; //PGImageMouseDown + +procedure TImgForm.PGImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); +var lX, lY,lPanel,lXout,lYOut,lZOut,lPressurePct,lPenThick: integer; +lErase: boolean; + lImage: TImage; +begin + lImage := Sender as TImage; + lX := X; lY := Y; + ScaleScrn2BMP(lX,lY,lImage); + if lImage.Name = 'PGImageCor' then lPanel := 3 + else if lImage.Name = 'PGImageSag' then lPanel := 2 + else lPanel := 1; + + if (gSelectOrigin.X = -666) then begin + gSelectRect.Right := lX; + gSelectRect.Bottom := lY; + //sortLTRB(gSelectRect.Left,gSelectRect.Top,gSelectRect.Right,gSelectRect.Bottom); + ShowDXLine(lImage,lPanel,gSelectRect); + exit; + end; + + if (gSelectOrigin.X > 0) then begin + ShowFocusRect(gSelectRect); + gSelectRect.Left := gSelectOrigin.X; + gSelectRect.Top := gSelectOrigin.Y; + gSelectRect.Right := lX; + gSelectRect.Bottom := lY; + sortLTRB(gSelectRect.Left,gSelectRect.Top,gSelectRect.Right,gSelectRect.Bottom); + ShowFocusRect(gSelectRect); + exit; + end; + if (not DrawToolSelected) and ((ssLeft in Shift)) then begin + if lImage.Name = 'PGImageCor' then lPanel := 3 + else if lImage.Name = 'PGImageSag' then lPanel := 2 + else lPanel := 1; + XYscrn2Img (lImage,lPanel,lX,lY, lXout,lYOut,lZOut); + if lXOut < 1 then lXOut := 1;//11/2007 : bound values + if lYOut < 1 then lYOut := 1; + if lZOut < 1 then lZOut := 1; + + //if (lXOut < 1) or (lYOut < 1) or (lZOut < 1) then exit; + XViewEdit.asInteger := lXOut; + YViewEdit.asInteger := lYOut; + ZViewEdit.asInteger := lZOut; + exit; + end; + if (not (ssLeft in Shift)) or (gMouseDownX < 0) then exit; + if PenBtn.Down or ClosedPenBtn.Down then begin + if {(gBGImg.Tablet) and} (TabletAvailable) then begin + TabletState(lPressurePct,lErase); + if lPressurePct > -1 then begin //using tablet + if (ssShift in Shift) then + lErase := not lErase; + //next detemine pen thickness + lPenThick := 1; + if ((lErase) and (lPressurePct > (2*gBGImg.TabletErasePressure))) + or ((not lErase) and (lPressurePct > (2*gBGImg.TabletPressure))) then + lPenThick := 5 + else if ((lErase) and (lPressurePct > gBGImg.TabletErasePressure)) + or ((not lErase) and (lPressurePct > gBGImg.TabletPressure)) then + lPenThick := 3; + DrawImg.Canvas.Pen.Width := lPenThick; + lImage.Canvas.Pen.Width := PenThick(lPenThick); + if (lErase) then begin //erase + lImage.Canvas.Brush.Color:=clBlack; + lImage.Canvas.Pen.Color := clBlack; + DrawImg.Canvas.Brush.Color:=clBlack; + DrawImg.Canvas.Pen.Color := clBlack; + end else begin + lImage.Canvas.Brush.Color:=gBGImg.VOIClr; + lImage.Canvas.Pen.Color := gBGImg.VOIClr; + DrawImg.Canvas.Brush.Color:=gBGImg.VOIClr; + DrawImg.Canvas.Pen.Color :=gBGImg.VOIClr; + end; + end;//TabletPressure > -1 = tablet being used + end; //Tablet + lImage.Canvas.LineTo(lX,lY); + lX := X; lY := Y; + ScaleBMP2Draw(gBGImg.VOIInvZoom, lX,lY,lPanel,lImage); + DrawImg.Canvas.LineTo(lX,lY); + end; +end; //PGImageMouseMove + +(*procedure VOI2Scrn (var lImage: TImage; lXvoi,lYvoi: integer; var lVOIBuffer: ByteP); +//copy data from VOIbuffer to lImage +begin + ImgForm.SetDimension8(lYvoi,lXvoi, lVOIBuffer,false); +end; *) + +procedure Scrn2VOI (var lImage: TImage; lXvoi,lYvoi: integer; var lVOIBuffer: ByteP); +const + kSh = 10; //bits to shift + kSHval = 1 shl kSh; + kHalfSHval = kSHval div 2; +var + lInc,lXpos,lYPos,lVOISliceSz,lScanLineSz8,lLineStart: integer; + srcBmp : TBitmap; + lInBuffer: Bytep; +begin + srcBmp := lImage.Picture.Bitmap;//ImgForm.DrawImg.Picture.Bitmap; + lVOISliceSz := lXvoi*lYvoi; + linBuffer := srcBmp.ScanLine[lYvoi-1]; + GetMem (lVOIBuffer , lVOISliceSz); + if(lXvoi mod 4) <> 0 then lScanLineSz8 := 4*((lXvoi + 3)div 4) + else lScanLineSz8 := lXvoi; + lLineStart := 0; + lInc := 0; + for lYPos := 1 to lYvoi do begin + for lXPos := 1 to lXvoi do begin + inc(lInc); + lVOIBuffer[lInc] := linBuffer[lLineStart+lXPos]; + end; + lLineStart := lLineStart + lScanLineSz8; + end; +end; //Scrn2VOI + +procedure ReadCorVOI (var lImage: TImage; lSlice: integer); +var lX,lY,lZ,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lXPos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lYOffset := (lX) * (round(lSlice)-1); + lXYSliceSz := (lX*lY); + Scrn2VOI (lImage,lX,lZ, lInBuff); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + for lXPos := 1 to lX do begin + inc(lPixel); + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lZOffset+lYOffset+lXPos] :=lInBuff[lPixel]; + end; //for each Y + end; //for each Z + freemem(lInBuff); +end; + +procedure ReadSagVOI (var lImage: TImage;lSlice: integer); +var lX,lY,lZ,lXOffset,lYOffset,lZOffset,lXYSliceSz,lPixel,lZPos,lYPos: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + lXYSliceSz := lX*lY; + lXOffset := round(lSlice); + Scrn2VOI (lImage,lY,lZ, lInBuff); + lPixel := 0; + for lZPos := 1 to lZ do begin + lZOffset := (lZPos-1) * lXYSliceSz; + lYOffset := 0; + for lYPos := 1 to lY do begin + inc(lPixel); + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lZOffset+lYOffset+lXOffset] := lInBuff[lPixel]; + lYOffset := lYOffset+ lX; + end; //for each Y + end; //for each Z + freemem(lInBuff); +end; + +procedure ReadAxialVOI (var lImage: TImage;lSlice: integer); +var lX,lY,lSliceOffset,lSliceSz: integer; + lInBuff: ByteP; +begin + lX := gBGImg.ScrnDim[1]; + lY := gBGImg.ScrnDim[2]; + lSliceSz := lX*lY; + lSliceOffset := (lSlice-1)*lX*lY; + Scrn2VOI (lImage,lX,lY, lInBuff); + for lX := 1 to lSliceSz do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lSliceOffset+lX] := lInBuff[lX]; + freemem(lInBuff); +end; + +procedure ReadScrnVOI (lImage: TImage); +var + lView: integer; +begin + if (gBGImg.VOIUndoSlice < 1) or (gBGImg.VOIUndoOrient < 1) or (gBGImg.VOIUndoOrient > 3) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1) or (lImage.Picture.Bitmap.Width < 1) or (lImage.Picture.Bitmap.Height < 1) then + exit; + EnsureVOIOpen; + lView := SelectedImageNum; + case lView of + 3: ReadCorVOI(ImgForm.DrawImg,ImgForm.YViewEdit.asInteger); + 2: ReadSagVOI(ImgForm.DrawImg,ImgForm.XViewEdit.asInteger); + 1: ReadAxialVOI(ImgForm.DrawImg,ImgForm.ZViewEdit.asInteger); + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + + +procedure TImgForm.PGImageMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var lPanel,lX, lY: integer; +lImage: TImage; +begin + lImage := Sender as TImage; + lPanel := SelectedImageNum; + + lX := X; lY := Y; + ScaleScrn2BMP(lX,lY,lImage); +if (gSelectOrigin.X > 0) then begin + sortLTRB(gSelectRect.Left,gSelectRect.Top,gSelectRect.Right,gSelectRect.Bottom); + ShowFocusRect(gSelectRect); + gSelectOrigin.X := -1; + if (EllipseBtn.Down) then + DrawEllipse(lImage,gSelectRect,Shift,lPanel) + else begin + AdjustContrastRectangle(lImage,gSelectRect); + gMouseDownX := -1; + exit; + end; +end; + if ((PenBtn.Down) or (ClosedPenBtn.Down)) and (gMouseDownX > 0) then begin + ScaleBMP2Draw(gBGImg.VOIInvZoom, gMouseDownX,gMouseDownY,lPanel,lImage); + //next: draw single pxiel if user clicks on image without moving the mouse + DrawImg.Canvas.Pixels[gMouseDownX,gMouseDownY] := DrawImg.Canvas.Pen.Color; + if (ClosedPenBtn.Down) then + DrawImg.Canvas.LineTo(gMouseDownX,gMouseDownY); + end; + (*if (ClosedPenBtn.Down)and (gMouseDownX > 0) then begin + ScaleBMP2Draw(gBGImg.VOIInvZoom, gMouseDownX,gMouseDownY); + DrawImg.Canvas.LineTo(gMouseDownX,gMouseDownY); + end;*) + gMouseDownX := -1; //disable draws + if DrawToolSelected and (not (ssAlt in Shift)) then + ReadScrnVOI (lImage); +end; //PGImageMouseUp + +procedure DecViewEdit(var lEdit: TRXSpinEdit); +begin + if lEdit.Value > 1 then + lEdit.value := lEdit.value -1 + else + lEdit.Value := lEdit.MaxValue; +end; //DecViewEdit + +procedure IncViewEdit(var lEdit: TRXSpinEdit); +begin + if lEdit.Value < lEdit.MaxValue then + lEdit.value := lEdit.value +1 + else + lEdit.Value := 1; +end; //IncViewEdit +var + gX: integer = 0; + +procedure TImgForm.FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +begin + inc(gX); + if (gX mod 3) <> 0 then + exit; + Case SelectedImageNum of + 3: DecViewEdit(YViewEdit); + 2: DecViewEdit(XViewEdit); + else DecViewEdit(ZViewEdit); + end; +end; + +procedure TImgForm.FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +begin + //if ZoomDrop.Focused then + // XViewEdit.SetFocus; + inc(gX); + if (gX mod 3) <> 0 then + exit; + Case SelectedImageNum of + 3: IncViewEdit(YViewEdit); + 2: IncViewEdit(XViewEdit); + else IncViewEdit(ZViewEdit); + end; +end; + +procedure TImgForm.ZoomDropSelect(Sender: TObject); +begin + gBGImg.ZoomPct := (ZoomDrop.ItemIndex-1)*100; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.ColorBarBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + var lLTRB,lLayer: integer; + lImage: TImage; +begin + if (ssAlt in Shift) then begin + //lImage := SelectedImage; + lLayer := ActiveLayer; + DrawHistogram(gMRIcroOverlay[lLayer],HistogramForm.HistoImage{lImage}); + HistogramForm.Caption := 'Histogram: '+extractfilename(gMRIcroOverlay[lLayer].HdrFileName); + HistogramForm.show; + if (ssCtrl in Shift) then + TextReportHisto(gMRIcroOverlay[lLayer]);; + exit; + end; + lLTRB := 1; + if (ssRight in Shift) then + lLTRB := lLTRB + 1; + if (ssCtrl in Shift) then + lLTRB := lLTRB + 2; + lImage := SelectedImage; + intenBar(lImage,gMRIcroOverlay[ActiveLayer],lLTRB,0,0); +end; + + +(*procedure SaveAllAx; +var + lZ,lSlices: integer; +begin + lSlices := round(ImgForm.ZViewEdit.maxvalue); + if lSlices < 1 then exit; + for lZ := 1 to lSlices do begin + ImgForm.ZViewEdit.value := lZ; + ImgForm.RefreshImagesTimer.Enabled := false; + RefreshImages; + SaveImgAsPNGBMPCore (ImgForm.PGImageAx,'c:\temp\'+padstr(lZ,3)+'.png'); + end; +end;(**) + + + +procedure TImgForm.XBarBtnClick(Sender: TObject); +begin + RefreshImagesTimer.Enabled := true; + +end; + +procedure RepositionOrigin; +begin + gBGImg.ScrnOri[1] := ImgForm.XViewEdit.asInteger; + gBGImg.ScrnOri[2] := ImgForm.YViewEdit.asInteger; + gBGImg.ScrnOri[3] := ImgForm.ZViewEdit.asInteger; + ImgForm.SetShareMem (0,0,0); +end; + + +procedure TImgForm.XBarBtnMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + label 555; +begin + if not (ssRight in shift) then exit; + if (ssAlt in Shift) and (ssCtrl in Shift) then begin + inc(gBGImg.FontSize,2); + if gBGImg.FontSize > 24 then + gBGImg.FontSize := 8; + goto 555; + end; + if (ssShift in Shift) then begin + RepositionOrigin; + goto 555; + end; + + + + if (ssAlt in Shift) then begin + inc(gBGImg.XBarThick,2); + if gBGImg.XBarThick > 10 then + gBGImg.XBarThick := 1; + + goto 555; + end; + if (ssCtrl in Shift) then begin + ColorDialog1.Color := gBGImg.XBarClr; + if not ColorDialog1.Execute then exit; + gBGImg.XBarClr := ColorDialog1.Color; + goto 555; + end; + inc(gBGImg.XBarGap); + if gBGImg.XBarGap > 10 then + gBGImg.XBarGap := 0; +555: +RefreshImagesTimer.Enabled := true; + if MultiSliceForm.Visible then + MultiSliceForm.CreateMultiSlice; +end; //XBarBtnMouseDown + +procedure TImgForm.RefreshImagesTimerTimer(Sender: TObject); +begin + RefreshImagesTimer.Enabled := false; + RefreshImages; + UpdateStatusLabel; + +end; + +(*procedure TImgForm.ImgPanelClick(Sender: TObject); +begin + SelectPanel((Sender as TScrollBox).tag); +end; *) + +procedure TImgForm.MagnifyMenuItemClick(Sender: TObject); +begin +(* if MagnifyPanel.Height < 20 then //Height constrained by Y + MagnifyPanel.Height := 128 + else + MagnifyPanel.Height := MagnifyPanel.Constraints.MinHeight;*) +end; + +procedure TImgForm.CloseImagesClick(Sender: TObject); +var + lC: integer; +begin + //fx(gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems);//FreeImgMemory(gMRIcroOverlay[kBGOverlayNum]); + CloseVOIClick(nil); + FreeUndoVol; + //qaz + + for lC := 0 to knMaxOverlay do //background, all overlays, VOI + FreeImgMemory(gMRIcroOverlay[lC]); + gBGImg.VOIUndoSlice := 0; + //next- set layers menu + LayerDrop.ItemIndex := (0); + LayerDrop.Items.Clear; + LayerDrop.Items.Add('Background'); + LayerDropSelect(nil); +end; + + +procedure TImgForm.OverlayOpenCore (var lFilename: string; lOverlayNum: integer); +begin + if (lOverLayNum <= kBGOverlayNum) or (lOverlayNum > knMaxOverlay) then exit; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lOverlayNum]) then exit; + (*if ReorientForm.visible then + ReorientForm.ApplyTransform(gMRIcroOverlay[lOverlayNum]); *) + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + if not OpenImg(gBGImg,gMRIcroOverlay[lOverlayNum],false,false,false,not gBGImg.ResliceOnLoad,false) then exit; + end else + if not OpenImg(gBGImg,gMRIcroOverlay[lOverlayNum],false,false,false,gBGImg.ResliceOnLoad,false) then exit; + ImgForm.UpdateLayerMenu; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LoadOverlay (lFilename: string); +var +lOverlay,lC: integer; +begin + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + OverlayOpenCore ( lFilename, lOverlay); +end; + + +procedure TImgForm.LoadOverlayIncludingRGB (lFilename: string); +var +lOverlay,lC: integer; +begin + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Unable to add an overlay. You have loaded the maximum number of overlays.'); + exit; + end; + OverlayOpenCore ( lFilename, lOverlay); + if (gMRIcroOverlay[lOverlay].NIFTIhdr.datatype = kDT_RGB) then begin + OverlayOpenCore ( lFilename, lOverlay+1); + OverlayOpenCore ( lFilename, lOverlay+2); + OverlayAdditive.click; + end; +end; + +procedure TImgForm.OverlayOpenClick(Sender: TObject); +var + lFilename: string; + lINc: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + if not OpenDialogExecute(kImgFilter,'Select overlay image[s]',true) then exit; + if HdrForm.OpenHdrDlg.Files.Count < 1 then + exit; + for lInc := 1 to HdrForm.OpenHdrDlg.Files.Count do begin //vcx + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + LoadOverlayIncludingRGB(lFilename); + + (* LoadOverlay(lFilename); + LoadOverlay(lFilename);*) + (*if gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.datatype = kDT_RGB then begin //RGB + //we have loaded the first [red] plane - now load green and blue... + LoadOverlay(lFilename); + LoadOverlay(lFilename); + //garbo xxx + xxx + *) + LayerDrop.ItemIndex := (LayerDrop.Items.Count-1); + LayerDropSelect(nil); + end; +(* if not OpenDialogExecute(kImgFilter,'Select overlay image',false) then exit; + lFilename := HdrForm.OpenHdrDlg.Filename; + LoadOverlay(lFilename); + LayerDrop.ItemIndex := (LayerDrop.Items.Count-1); + LayerDropSelect(nil); + *) +end; //OverlayOpenClick + +procedure TImgForm.BGtrans100Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gBGImg.BGTransPct := (sender as TMenuItem).tag; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.OverlayTransClick(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gBGImg.OverlayTransPct := (sender as TMenuItem).tag; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LayerDropSelect(Sender: TObject); +var + lLayer: integer; +begin + + lLayer := ActiveLayer; + MaxWindowEdit.Value := gMRIcroOverlay[lLayer].WindowScaledMax; + MinWindowEdit.Value := gMRIcroOverlay[lLayer].WindowScaledMin; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then exit; + LUTdrop.ItemIndex := (gMRIcroOverlay[lLayer].LUTindex); + //LUTinvertBtn.down := gMRIcroOverlay[lLayer].LUTinvert; + LutFromZeroBtn.down := gMRIcroOverlay[lLayer].LutFromZero; +end; + +procedure TImgForm.UpdateLayerMenu; +var + lStrings: TStringList; + lPos,lLayer:integer; +begin + lStrings := TStringList.Create; + lStrings.Add('Background'); + lLayer := 0; + for lPos := 1 to (knMaxOverlay-1) do //-1 as max overlay is VOI + if (gMRIcroOverlay[lPos].ImgBufferItems > 0) then begin + lStrings.Add(ParseFileName(ExtractFileName(gMRIcroOverlay[lPos].HdrFileName))); + inc(lLayer); + LUTdropLoad(lLayer); + end; + LayerDrop.Items := lStrings; + if LayerDrop.ItemIndex >= LayerDrop.Items.Count then + LayerDrop.ItemIndex := (LayerDrop.Items.Count-1); + LayerDropSelect(nil); + lStrings.Free; +end; + +procedure TImgForm.CloseOverlayImgClick(Sender: TObject); +var + lOverlay: integer; +begin + for lOverlay := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lOverlay]); + UpdateLayerMenu; + RefreshImagesTimer.Enabled := true; +end; + + + +procedure TImgForm.LUTdropLoad(var lLayer: integer); +var + lStr: string; +begin + if gMRIcroOverlay[lLayer].UsesCustomPalette then begin + exit; + end; + //gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + if gMRIcroOverlay[lLayer].LUTindex < knAutoLUT then begin + LoadMonochromeLUT(gMRIcroOverlay[lLayer].LUTindex,gBGImg,gMRIcroOverlay[lLayer]); + RefreshImagesTimer.Enabled := true; + exit; + end; //if B&W lut + lStr := gColorSchemeDir+pathdelim+LUTdrop.Items.Strings[gMRIcroOverlay[lLayer].LUTindex]+'.lut'; + if not FileExistsEX(lStr) then + showmessage('Can not find '+lStr); + LoadColorScheme(lStr, gMRIcroOverlay[lLayer]); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.LUTdropSelect(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + //gMRIcroOverlay[lLayer].LUTinvert := LUTinvertBtn.down; + //gMRIcroOverlay[lLayer].LutFromZero := LutFromZeroBtn.down; + LUTdropLoad(lLayer); + //RescaleImagesTimer.Enabled := true; +end; //proc LUTdropSelect + +procedure TImgForm.AutoContrastBtnClick(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + MinWindowEdit.Value := raw2ScaledIntensity(gMRIcroOverlay[lLayer], gMRIcroOverlay[lLayer].AutoBalMinUnscaled); + MaxWindowEdit.Value := raw2ScaledIntensity(gMRIcroOverlay[lLayer],gMRIcroOverlay[lLayer].AutoBalMaxUnscaled);{} + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lLayer], llayer); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.MinContrastWindowEditChange(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + if gMRIcroOverlay[lLayer].WindowScaledMin = MinWindowEdit.Value then exit; + gMRIcroOverlay[lLayer].WindowScaledMin := MinWindowEdit.Value; + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.MaxContrastWindowEditChange(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + if gMRIcroOverlay[lLayer].WindowScaledMax = MaxWindowEdit.Value then exit; + gMRIcroOverlay[lLayer].WindowScaledMax := MaxWindowEdit.Value; + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.OverlaySmoothMenuClick(Sender: TObject); +var + lC: integer; +begin + if Sender = nil then begin + gBGImg.OverlaySmooth := OverlaySmoothMenu.Checked; + exit; + end; + OverlaySmoothMenu.Checked := not OverlaySmoothMenu.Checked; + gBGImg.OverlaySmooth := OverlaySmoothMenu.Checked; + for lC := 1 to knMaxOverlay do + if gMRIcroOverlay[lC].ScrnBufferItems > 0 then + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lC], lC); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.ShowRenderClick(Sender: TObject); +begin + RenderForm.Show; +end; + +procedure TImgForm.PenBtnClick(Sender: TObject); +begin + RefreshImagesTimer.Enabled := true; +end; + +procedure OpenMRIcroROI (lFilename: string); +const + kMax12bit = 4095; + kMax16bit = (256*256)-1; + kMax15bit = kMax16bit shr 1; + kMax20bit = (16*256*256)-1; + k20v16bit = kMax20bit - kMax16bit; + kMaxRuns = 10000; + kMaxFile = 65536; + k16v12bit = kMax16bit - kMax12bit; +var + lFile32bitItems,lFileSz,lFilePos,lSliceSz,lZ,lRunsOnSlice, + lRunLength,lRun,lRunOffset,lOutputSliceOffset,lRunPos: integer; + lROIformatRA: LongIntp; + lF: File; + lBigFormat: boolean; +begin + lFileSz := FSize(lFilename); + if (lFileSz < 1) or ((lFileSz mod 4) <> 0) then begin + showmessage('Unable to open ROI: file size should be divisible by 4.'); + exit; + end; + lFile32bitItems := lFileSz div 4; //how many 32-bit items? + lSliceSz := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + lZ := gBGImg.ScrnDim[3]; + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + freemem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer); + gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems := lSliceSz * lZ; + getmem(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,lSliceSz * lZ); + fillchar(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,0); + if lSliceSz > 65535 then + lBigFormat := true + else + lBigFormat := false; + getmem(lROIformatRA,lFileSz); //file size must be divisible by 4 + {$I-} + AssignFile(lF, lFilename); + FileMode := 0; { Set file access to read only } + Reset(lF, 1); + BlockRead(lF,lROIformatRA^,lFileSz); + CloseFile(lF); + FileMode := 2; + {$I+} + //next: check MSB of first byte to see if this is big format images + if lBigFormat <> odd((lROIformatRA[1] and kMax16bit) shr 15) then + Showmessage('Warning: this ROI does not appear to be designed for the currently loaded background image.'); + lFilePos := 1; +if lBigFormat then begin //20-byte offset, 12-byte runlength + while lFilePos < lFile32bitItems do begin + lRunsOnSlice := (lROIformatRA[lFilePos] shr 17) - 1; //shr 17: shift 16 bits, then div 2 (words instead of longints). Subtract 1 as the we have read slice number/ number of runs + lZ := (lROIformatRA[lFilePos] and kMax15bit); + inc(lFilePos); + lOutputSliceOffset := (lZ-1) * lSliceSz; + for lRun := 1 to lRunsOnSlice do begin + if (lFilePos <= lFileSz) then begin + lRunLength := (lROIformatRA[lFilePos] shr 16) and kMax12bit; + lRunOffset := (lROIformatRA[lFilePos] and kMax16bit)+ ((lROIformatRA[lFilePos] shr 28) shl 16); + if (lOutputSliceOffset+lRunLength+lRunOffset-1)> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then + //showmessage('Overrun on slice '+inttostr(lZ)) + else for lRunPos := lRunOffset to (lRunLength+lRunOffset-1) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lRunPos+lOutputSliceOffset] := kVOI8bit; + end; + inc(lFilePos); + end;//for all runs + end; //while lPos < lFSz +end else begin //not big format format - 16-byte offset, 16-byte length + while lFilePos < lFile32bitItems do begin + //lRunsOnSlice := (lROIformatRA[lFilePos] shr 16) and kMax16bit; + lRunsOnSlice := (lROIformatRA[lFilePos] shr 17) - 1; //shr 17: shift 16 bits, then div 2 (words instead of longints). Subtract 1 as the we have read slice number/ number of runs + lZ := (lROIformatRA[lFilePos] and kMax15bit); + inc(lFilePos); + lOutputSliceOffset := (lZ-1) * lSliceSz; + //showmessage(inttostr(lZ)+' '+inttostr(lRunsOnSlice)+' '+inttostr(lFilePos)+' '+inttostr(lFileSz)); + for lRun := 1 to lRunsOnSlice do begin + if (lFilePos <= lFileSz) then begin + lRunLength := (lROIformatRA[lFilePos] shr 16) and kMax16bit; + lRunOffset := (lROIformatRA[lFilePos] and kMax16bit); + {if (lRunLength+lRunOffset-1)> gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems then + showmessage('Overrun on slice '+inttostr(lZ)) + else} for lRunPos := lRunOffset to (lRunLength+lRunOffset-1) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lRunPos+lOutputSliceOffset] := kVOI8bit; + end; + inc(lFilePos); + end;//for all runs + end; //while lPos < lFSz +end; //if bigformat ... else little format + freemem(lROIformatRA); + lRun := maxint; + LoadMonochromeLUT(lRun,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); +end; + +function ComputeCC (lOverlayNum: integer): single; +var + lInc, lVol: integer; +begin + result := 0; + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + lVol := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then + inc(lVol); + result := ((lVol/1000)*gBGImg.ScrnMM[1]*gBGImg.ScrnMM[2]*gBGImg.ScrnMM[3]); +end; +procedure TImgForm.OpenVOICore(var lFilename : string); +var + lExt: string; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + ImgForm.CloseVOIClick(nil); + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if (lExt='.ROI') then begin + + Showmessage('Warning: MRIcro ROI format does not save image dimensions. The background image must be in the same dimensions as the ROI.'); + OpenMRIcroROI (lFileName); + if (gBGImg.Resliced) then begin + Showmessage('If the ROI appears distorted, you may want to open you background image without reslicing and try again. '+ + '(hold down the shift key when you load the background image)'); + end; + ImgForm.RefreshImagesTimer.Enabled := true; + exit; + end; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[kVOIOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[kVOIOverlayNum],false,true,false,gBGImg.ResliceOnLoad,false) then exit; + caption := lFilename +' cc=' +realtostr( ComputeCC(kVOIOverlayNum),2); + ImgForm.RefreshImagesTimer.Enabled := true; +end;//OpenVOIClick + + +procedure TImgForm.OpenVOIClick(Sender: TObject); +var + lFilename: string; + State : TKeyboardState; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding a VOI.'); + exit; + end; + //HdrForm.OpenHdrDlg.Filter := '*.roi';//kVOIFilter; + //if not HdrForm.OpenHdrDlg.Execute then exit; + if not OpenDialogExecute(kVOIFilter,'Select Volume of Interest drawing',false) then exit; + lFilename := HdrForm.OpenHdrDlg.Filename; + OpenVOICore(lFilename); + GetKeyboardState(State) ; + if ((State[vk_shift] And 128) <> 0) then begin + Showmessage('Overlay loaded left-right flipped (shift key depressed)'); + MirrorScrnBuffer(gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + //MirrorImgBuffer (gMRIcroOverlay[kVOIOverlayNum] ); + end; +end;//OpenVOIClick + +(*procedure SaveVOIunmirror; +var lHdr: TMRIcroHdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + //Start 10/2007: adjust scl_slope;? 10/2007 + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + lNIFTIhdr.scl_slope := 1; + lNIFTIhdr.scl_inter := 0; + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,lNIFTIhdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); + Freemem(lHdr.ScrnBuffer); + exit; //sept2007 + end; + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,lNiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); + //656 +end;*) + + + +procedure TImgForm.SaveVOIcore(lPromptFilename: boolean); + var lHdr: TMRIcroHdr; + lNIFTIhdr: TNIFTIhdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + //Start 10/2007: adjust scl_slope;? 10/2007 + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + lNIFTIhdr.scl_slope := 1; + lNIFTIhdr.scl_inter := 0; + //end + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + if lPromptFilename then + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,lNIFTIhdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName) + else + SaveAsVOIorNIFTIcore(gMRIcroOverlay[kVOIOverlayNum].HdrFileName,lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,lNIFTIhdr); + Freemem(lHdr.ScrnBuffer); + exit; //12/2010 + end; + if lPromptFilename then + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,lNiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName) + else + SaveAsVOIorNIFTIcore(gMRIcroOverlay[kVOIOverlayNum].HdrFileName,gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,lNiftiHdr); +end; + +procedure TImgForm.SaveVOIClick(Sender: TObject); + var lHdr: TMRIcroHdr; + lNIFTIhdr: TNIFTIhdr; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + //Start 10/2007: adjust scl_slope;? 10/2007 + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + lNIFTIhdr.scl_slope := 1; + lNIFTIhdr.scl_inter := 0; + //end + if gBGImg.Mirror then begin + lHdr.ScrnBufferItems := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + Getmem(lHdr.ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[1],lHdr.ScrnBuffer^[1],lHdr.ScrnBufferItems); + MirrorScrnBuffer(gBGImg,lHdr); + SaveAsVOIorNIFTI(lHdr.ScrnBuffer,lHdr.ScrnBufferItems,1,1,true,lNIFTIhdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); + Freemem(lHdr.ScrnBuffer); + exit; //sept2007 + end; + SaveAsVOIorNIFTI(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems,1,1,true,lNiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end; + +procedure TImgForm.VOIColorClick(Sender: TObject); +var + lMaxi: longint; +begin + ColorDialog1.Color := gBGImg.VOIClr; + if not ColorDialog1.Execute then exit; + gBGImg.VOIClr := ColorDialog1.Color; + if gBGImg.VOIClr = clBlack then + gBGImg.VOIClr := 1; //reserve 0 for deleting + lMaxi:=maxint; + LoadMonochromeLUT(lMaxi,gBGImg,gMRIcroOverlay[kVOIOverlayNum]); + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.CloseVOIClick(Sender: TObject); +begin + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems>0) and (gBGImg.VOIChanged) then begin + case MessageDlg('Do you wish to save the VOI drawing?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + id_Yes: SaveVOIClick(nil); + end; //case + end;//if changed + FreeUndoVol; + FreeImgMemory(gMRIcroOverlay[kVOIOverlayNum]); + gBGImg.VOIUndoSlice := 0; + gBGImg.VOIchanged := false; + gBGImg.VOIUndoOrient := 0; + RefreshImagesTimer.Enabled := true; +end; + +procedure ImageRB (var lMaxR,lMaxB: integer; var lImage: TImage); +var + lPos: integer; +begin + if not lImage.Visible then + exit; + lPos := lImage.Left+lImage.Width; + if lPos > lMaxR then + lMaxR := lPos; + lPos := lImage.Top+lImage.Height; + if lPos > lMaxB then + lMaxB := lPos; +end; + +procedure CreateImg(lPGHt,lPGWid:integer; var lImage: TImage); +var + sbBits : PByteArray; + nBytesInImage: integer; + lBMP: TBitmap; + lSrcRect,lDestRect: TRect; +begin + + lBMP := TBitmap.Create; + TRY + lBMP.PixelFormat := pf32bit; + lBMP.Width := lPGwid; + lBMP.Height := lPGHt; + sbBits := lBmp.ScanLine[lPGHt-1]; + nBytesInImage := lPGWid*lPGHt * 4; + //CopyMemory(Pointer(sbBits),Pointer(lBuff),nBytesInImage); + FillChar(sbBits^,({lPGHt*{}lPGHt*lPGwid*4), 255); + lImage.Canvas.CopyMode := cmSrcCopy; + lImage.Width := (lBmp.Width);//xx + lImage.Height := (lBmp.Height);//xx + lImage.Picture.Graphic := lBMP; + FINALLY + lBMP.Free; + END; //try..finally +end; //proc SetDimension32 + +procedure CopyImg(var lSourceImg,lDestImg: TImage); +var + lPos: integer; +begin + if not lSourceImg.Visible then + exit; + lDestImg.Canvas.Draw(lSourceImg.Left,lSourceImg.Top,lSourceImg.Picture.Graphic); +end; + +procedure TImgForm.SaveOrCopyImages(lCopy: boolean); +//Requires 'ClipBrd' in uses section +var + lMaxR,lMaxB: integer; + lOutImg: TImage; +begin + lMaxR := 0; + lMaxB := 0; + ImageRB(lMaxR,lMaxB,ImgForm.PGImageAx); + ImageRB(lMaxR,lMaxB,ImgForm.PGImageCor); + ImageRB(lMaxR,lMaxB,ImgForm.PGImageSag); + if (lMaxR < 1) or (lMaxB < 1) then + exit; + lOutImg := TImage.Create(ImgForm); + try + //use the object + CreateImg(lMaxB,lMaxR,lOutImg); + lOutImg.Canvas.Brush.color := ImgForm.TriplePanel.color; + lOutImg.Canvas.Rectangle(0,0,lMaxR+1,lMaxB+1); + CopyImg(ImgForm.PGImageAx,lOutImg); + CopyImg(ImgForm.PGImageCor,lOutImg); + CopyImg(ImgForm.PGImageSag,lOutImg); + if lCopy then + Clipboard.Assign(lOutImg.Picture.Graphic) + else + SaveImgAsPNGBMP (lOutImg); + finally + FreeAndNil (lOutImg); + end; + +end; + +procedure TImgForm.Saveaspicture1Click(Sender: TObject); +begin + SaveOrCopyImages(false); +end; //Proc Saveaspicture1Click + +procedure TImgForm.Copy1Click(Sender: TObject); //Requires 'ClipBrd' in uses section +begin + SaveOrCopyImages(true); +end; + +(*procedure TImgForm.Copy1Click(Sender: TObject); //Requires 'ClipBrd' in uses section +var + MyFormat : Word; + lImage: TImage; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + lImage := SelectedImage; + if (lImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + lImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); + if (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems>0) then + WriteUndoVOI(SelectedImageNum,false); +end; *) + +procedure TImgForm.Undo1Click(Sender: TObject); +begin + if gBGImg.VOIUndoSlice < 1 then exit; + case gBGImg.VOIUndoOrient of + 4: UndoVolVOI; + 3: ReadCorVOI(ImgForm.UndoImg,gBGImg.VOIUndoSlice); + 2: ReadSagVOI(ImgForm.UndoImg,gBGImg.VOIUndoSlice); + 1: ReadAxialVOI(ImgForm.UndoImg,gBGImg.VOIUndoSlice); + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.Paste1Click(Sender: TObject); +begin + if (gBGImg.VOIUndoSlice < 1) then exit; + if gBGImg.VOIUndoOrient <> SelectedImageNum then //12/2007 + exit; + WriteUndoVOI(SelectedImageNum,true); + case gBGImg.VOIUndoOrient of + 3: ReadCorVOI(ImgForm.DrawImg,ImgForm.YViewEdit.asInteger); + 2: ReadSagVOI(ImgForm.DrawImg,ImgForm.XViewEdit.asInteger); + 1: ReadAxialVOI(ImgForm.DrawImg,ImgForm.ZViewEdit.asInteger); + else exit; + end; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.HideROIBtnMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + gOrigBGTransPct := gBGImg.BGTransPct; + gBGImg.BGTransPct := 100; + refreshimagestimer.enabled := true; +end; + +procedure TImgForm.HideROIBtnMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + gBGImg.BGTransPct := gOrigBGTransPct; + Refreshimagestimer.enabled := true; +end; + +procedure TImgForm.Applyintensityfiltertovolume1Click(Sender: TObject); +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + showmessage('You must have open a background image in order to apply an intensity filter (use File/Open).'); + exit; + end; + FilterROIform.showmodal; +end; + +procedure TImgForm.Quicksmooth1Click(Sender: TObject); +var + lHdr: TMRicroHdr; + lXDim,lYDim,lZDim,lMaxGray,lSum,lMinWt,lMaxWt,lMinInten,lMaxInten,lOutVolVox,lOutSliceSz,lX,lY,lZ,lXxi,l2,lZyi: integer; + lSum32,lMinInten32,lMaxInten32: single; + lTempBuff,lSrcBuff: Bytep; + l16TempBuff,l16SrcBuff: SmallIntP; + l32TempBuff,l32SrcBuff: SingleP; +procedure AddPoint (lInten,lWeight:integer); +begin + lSum := lSum + (lInten*lWeight); + if lInten <= lMinInten then begin + lMinWt := lWeight; + lMinInten := lInten; + end else if lInten >= lMaxInten then begin + lMaxWt := lWeight; + lMaxInten := lInten; + end; +end; //nested AddPoint +procedure AddPoint32 (lInten32: single; lWeight:integer); +begin + lSum32 := lSum32 + (lInten32*lWeight); + if lInten32 <= lMinInten32 then begin + lMinWt := lWeight; + lMinInten32 := lInten32; + end else if lInten32 >= lMaxInten32 then begin + lMaxWt := lWeight; + lMaxInten32 := lInten32; + end; +end; //nested AddPoint32 +begin + lHdr := gMRIcroOverlay[kBGOverlayNum]; + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lOutSliceSz := gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2]; + lOutVolVox := lOutSliceSz * lZDim; + if (lXDim < 3) or (lYDim < 3) or (lZDim < 3) or (lOutVolVox < 36) then begin + showmessage('The 3D smoothing can only be applied to images with at least 3 slices in each dimension.'); + exit; + end; + if (lHdr.ImgBufferItems < 1) then begin + showmessage('Please first load the image you would like to smooth.'); + exit; + end; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lZDim; + StatusLabel.caption := 'Removing noise speckles and smoothing data [blur]'; + if lHdr.ImgBufferBPP = 4 then begin //32-bit float data + l32SrcBuff := SingleP(lHdr.ImgBuffer); + GetMem(l32TempBuff,lOutVolVox*sizeof(single)); + Move(l32SrcBuff^,l32TempBuff^,lOutVolVox*sizeof(single)); + for lZ := 1 to lOutVolVox do + l32SrcBuff[lZ] := 0; + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum32 := 0; + lMinInten32 := l32TempBuff[lXxi]; + lMaxInten32 := l32TempBuff[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint32(l32TempBuff[lXxi],12);//quad-weight center + AddPoint32(l32TempBuff[lXxi-lOutSliceSz],2);//prev slice + AddPoint32(l32TempBuff[lXxi+lOutSliceSz],2);//next slices + AddPoint32(l32TempBuff[lXxi-1],2);//Left + AddPoint32(l32TempBuff[lXxi+1],2);//right + AddPoint32(l32TempBuff[lXxi-lXDim],2);//up + AddPoint32(l32TempBuff[lXxi+lXDim],2);//down + AddPoint32(l32TempBuff[lXxi-lOutSliceSz-1],1); + AddPoint32(l32TempBuff[lXxi-lOutSliceSz+1],1); + AddPoint32(l32TempBuff[lXxi-lOutSliceSz-lXDim],1); + AddPoint32(l32TempBuff[lXxi-lOutSliceSz+lXDim],1); + AddPoint32(l32TempBuff[lXxi+lOutSliceSz-1],1); + AddPoint32(l32TempBuff[lXxi+lOutSliceSz+1],1); + AddPoint32(l32TempBuff[lXxi+lOutSliceSz-lXDim],1); + AddPoint32(l32TempBuff[lXxi+lOutSliceSz+lXDim],1); + AddPoint32(l32TempBuff[lXxi-lXDim-1],1); + AddPoint32(l32TempBuff[lXxi+lXDim-1],1); + AddPoint32(l32TempBuff[lXxi-lXDim+1],1); + AddPoint32(l32TempBuff[lXxi+lXDim+1],1); + if lMinInten32 = lMaxInten32 then + l32SrcBuff[lXxi] := lMaxInten32 //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum32 := lSum32 -(lMinWt*lMinInten32) - (lMaxWt*lMaxInten32); //exclude brightest/darkest + l32SrcBuff[lXxi] := (lSum32/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(l32TempBuff); + end else if (lHdr.ImgBufferBPP = 2) then begin //16-bit int data*) + l16SrcBuff := SmallIntP(lHdr.ImgBuffer ); + GetMem(l16TempBuff,lOutVolVox*sizeof(word)); + Move(l16SrcBuff^,l16TempBuff^,lOutVolVox*sizeof(word)); + for lZ := 1 to lOutVolVox do + l16SrcBuff[lZ] := 0; + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum := 0; + lMinInten := l16TempBuff[lXxi]; + lMaxInten := l16TempBuff[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint(l16TempBuff[lXxi],12);//quad-weight center + AddPoint(l16TempBuff[lXxi-lOutSliceSz],2);//prev slice + AddPoint(l16TempBuff[lXxi+lOutSliceSz],2);//next slices + AddPoint(l16TempBuff[lXxi-1],2);//Left + AddPoint(l16TempBuff[lXxi+1],2);//right + AddPoint(l16TempBuff[lXxi-lXDim],2);//up + AddPoint(l16TempBuff[lXxi+lXDim],2);//down + AddPoint(l16TempBuff[lXxi-lOutSliceSz-1],1); + AddPoint(l16TempBuff[lXxi-lOutSliceSz+1],1); + AddPoint(l16TempBuff[lXxi-lOutSliceSz-lXDim],1); + AddPoint(l16TempBuff[lXxi-lOutSliceSz+lXDim],1); + AddPoint(l16TempBuff[lXxi+lOutSliceSz-1],1); + AddPoint(l16TempBuff[lXxi+lOutSliceSz+1],1); + AddPoint(l16TempBuff[lXxi+lOutSliceSz-lXDim],1); + AddPoint(l16TempBuff[lXxi+lOutSliceSz+lXDim],1); + AddPoint(l16TempBuff[lXxi-lXDim-1],1); + AddPoint(l16TempBuff[lXxi+lXDim-1],1); + AddPoint(l16TempBuff[lXxi-lXDim+1],1); + AddPoint(l16TempBuff[lXxi+lXDim+1],1); + if lMinInten = lMaxInten then + l16SrcBuff[lXxi] := lMaxInten //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum := lSum -(lMinWt*lMinInten) - (lMaxWt*lMaxInten); //exclude brightest/darkest + l16SrcBuff[lXxi] := round(lSum/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(l16TempBuff); + //OptimizeSingle(nil); + end else if lHdr.ImgBufferBPP = 1 then begin //8-bit data + lSrcBuff := lHdr.ImgBuffer; + GetMem(lTempBuff,lOutVolVox); + Move(lSrcBuff^,lTempBuff^,lOutVolVox); + fillchar(lSrcBuff^,lOutVolVox,0); //set edges to 0, as outside voxel is not smoothed + for lZ := lZDim-1 downto 2 do begin + ProgressBar1.Position := (lZDim-lZ); + for lY := lYDim-1 downto 2 do begin + lZyi := ((lZ-1)*lOutSliceSz) + ((lY-1) * lXDim); + for lX := lXDim-1 downto 2 do begin + lXxi := lZyi + lX; + //next: gaussian mean after min/max values are excluded + lSum := 0; + lMinInten := lTempBuff[lXxi]; + lMaxInten := lTempBuff[lXxi]; + lMinWt := 12; + lMaxWt := 12; + AddPoint(lTempBuff[lXxi],12);//quad-weight center + AddPoint(lTempBuff[lXxi-lOutSliceSz],2);//prev slice + AddPoint(lTempBuff[lXxi+lOutSliceSz],2);//next slices + AddPoint(lTempBuff[lXxi-1],2);//Left + AddPoint(lTempBuff[lXxi+1],2);//right + AddPoint(lTempBuff[lXxi-lXDim],2);//up + AddPoint(lTempBuff[lXxi+lXDim],2);//down + AddPoint(lTempBuff[lXxi-lOutSliceSz-1],1); + AddPoint(lTempBuff[lXxi-lOutSliceSz+1],1); + AddPoint(lTempBuff[lXxi-lOutSliceSz-lXDim],1); + AddPoint(lTempBuff[lXxi-lOutSliceSz+lXDim],1); + AddPoint(lTempBuff[lXxi+lOutSliceSz-1],1); + AddPoint(lTempBuff[lXxi+lOutSliceSz+1],1); + AddPoint(lTempBuff[lXxi+lOutSliceSz-lXDim],1); + AddPoint(lTempBuff[lXxi+lOutSliceSz+lXDim],1); + AddPoint(lTempBuff[lXxi-lXDim-1],1); + AddPoint(lTempBuff[lXxi+lXDim-1],1); + AddPoint(lTempBuff[lXxi-lXDim+1],1); + AddPoint(lTempBuff[lXxi+lXDim+1],1); + if lMinInten = lMaxInten then + lSrcBuff[lXxi] := lMaxInten //no variability in data + else begin + l2 := 36 - lMinWt -lMaxWt; //weight after we exceed brightest and darkest + lSum := lSum -(lMinWt*lMinInten) - (lMaxWt*lMaxInten); //exclude brightest/darkest + lSrcBuff[lXxi] := round(lSum/l2); + end; + end; //forX + end; //forY + end; //forZ + Freemem(lTempBuff); + end else begin //8bit data + showmessage('Unknown bits per pixel '+inttostr(lHdr.ImgBufferBPP) ); + end; + ProgressBar1.Position := 0; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[kBGOverlayNum],kBGOverlayNum); + RefreshImagesTimer.Enabled := true; +end; //quicksmooth + +function GetReal (lDefault: single): single; +var + lOK: boolean; + lS: string; +begin + result := lDefault; + lS := floattostr(lDefault); + lOK := InputQuery('Enter a number', 'Enter a value', lS); + if not lOK then + exit; + result := strtofloat(lS); +end; + +procedure TImgForm.VOImaskClick(Sender: TObject); +const + kMax = 0.995; +var + lFillS: single; + lHdr,lMaskHdr: TMRicroHdr; + lPreserve, lFillI, lLayer,lXDim,lYDim,lZDim,lOutVolVox,lOutSliceSz,lZ: integer; + lSrcBuff,lMaskBuff: Bytep; + l16SrcBuff: SmallIntP; + lScale : boolean; //make region brighter or darker... + l32SrcBuff: SingleP; +begin + lScale := false; + lPreserve := (sender as TMenuItem).tag; + if (ssCtrl in KeyDataToShiftState(vk_Shift)) then begin + lScale := true; + lFillS := GetReal(0); + end else if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + lFillS := GetReal(0); + end else + lFillS := 0; + lFillI := round(lFillS); + + lHdr := gMRIcroOverlay[kBGOverlayNum]; + lMaskHdr := gMRIcroOverlay[kVOIOverlayNum]; + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lOutSliceSz := gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2]; + lOutVolVox := lOutSliceSz * lZDim; + if (lXDim < 2) or (lYDim < 2) or (lZDim < 2) then begin + showmessage('Masking can only be applied to images with multiple slices in 3 dimensions.'); + exit; + end; + if (lHdr.ImgBufferItems <> lMaskHdr.ScrnBufferItems) or (lHdr.ImgBufferItems < 8) then begin + showmessage('Please first load both an image (File/Open) and a masking VOI (Draw/Open).'); + exit; + end; + if gBGImg.Mirror then + MirrorScrnBuffer(gBGImg,lMaskHdr);//4/2008 + lMaskBuff := (lMaskHdr.ScrnBuffer); + ProgressBar1.Min := 0; + ProgressBar1.Max :=lZDim; + StatusLabel.caption := 'Masking data'; + for lLayer := kBGOverlayNum to ( kVOIOverlayNum-1) do begin + lHdr := gMRIcroOverlay[lLayer {kBGOverlayNum}]; + if (lHdr.ImgBufferItems = lMaskHdr.ScrnBufferItems) and (lScale) then begin + showmessage('Scaling region under VOI by '+floattostr(lFillS)); + if lHdr.ImgBufferBPP = 4 then begin //32-bit float data + l32SrcBuff := SingleP(lHdr.ImgBuffer); + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff[lZ] = 0 then + l32SrcBuff[lZ] := lFillS*l32SrcBuff[lZ]; + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff[lZ] <> 0 then + l32SrcBuff[lZ] := lFillS*l32SrcBuff[lZ]; + end; //if preserve + for lZ := 1 to lOutVolVox do + if l32SrcBuff[lZ] > kMax then + l32SrcBuff[lZ] := kMax; + end else + showmessage('Scaling only works for 32-bit float images.'); + end else if (lHdr.ImgBufferItems = lMaskHdr.ScrnBufferItems) then begin + if lHdr.ImgBufferBPP = 4 then begin //32-bit float data + l32SrcBuff := SingleP(lHdr.ImgBuffer); + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff[lZ] = 0 then + l32SrcBuff[lZ] := lFillS; + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff[lZ] <> 0 then + l32SrcBuff[lZ] := lFillS; + end; //if preserve + end else if (lHdr.ImgBufferBPP = 2) then begin //16-bit int data*) + l16SrcBuff := SmallIntP(lHdr.ImgBuffer ); + //lMin := round( lHdr.GlMinUnscaledS); + + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff[lZ] = 0 then + l16SrcBuff[lZ] := lFillI;//lMin; + end else begin + for lZ := 1 to lOutVolVox do + if lMaskBuff[lZ] <> 0 then + l16SrcBuff[lZ] := lFillI;//lMin; + end; + end else if lHdr.ImgBufferBPP = 1 then begin //8-bit data + lSrcBuff := lHdr.ImgBuffer; + if lPreserve = 1 then begin + for lZ := 1 to lOutVolVox do + if lMaskBuff[lZ] = 0 then + lSrcBuff[lZ] := lFillI + end else begin + + for lZ := 1 to lOutVolVox do + if lMaskBuff[lZ] <> 0 then + lSrcBuff[lZ] := lFillI; + //else if lSrcBuff[lZ] = 0 then + // lSrcBuff[lZ] := 1; + end; + end else begin //8bit data + showmessage('Unknown bits per pixel '+inttostr(lHdr.ImgBufferBPP) ); + end; + end;//layer exists + end; //for each layer + + if gBGImg.Mirror then + MirrorScrnBuffer(gBGImg,lMaskHdr);//4/2008 + + ProgressBar1.Position := 0; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[kBGOverlayNum],kBGOverlayNum); + RefreshImagesTimer.Enabled := true; +end; //VOImaskClick + +(*procedure RepositionOrigin (var lNiftiHdr: TNIFTIHdr); +var + lX,lY,lZ,lOverlay,lLen: integer; + lXmm,lYmm,lZmm: single; + lIntenStr : string; +begin + lX := ImgForm.XViewEdit.asInteger; + lY := ImgForm.YViewEdit.asInteger; + lZ := ImgForm.ZViewEdit.asInteger; + for lLen := 0 to 2 do begin + lNiftiHdr.srow_x[lLen] := abs(lNiftiHdr.srow_x[lLen]); + lNiftiHdr.srow_y[lLen] := abs(lNiftiHdr.srow_y[lLen]); + lNiftiHdr.srow_z[lLen] := abs(lNiftiHdr.srow_z[lLen]); + end; + lNiftiHdr.srow_x[3] := -lNiftiHdr.srow_x[0]*(lX-1); + lNiftiHdr.srow_y[3] := -lNiftiHdr.srow_y[1]*(lY-1); + lNiftiHdr.srow_z[3] := -lNiftiHdr.srow_z[2]*(lZ-1); + //fx(lNiftiHdr.srow_x[3],lNiftiHdr.srow_y[3],lNiftiHdr.srow_z[3]); + //fx(lX,lY,lZ); +end; + +function CtrlDown : Boolean; +var + State : TKeyboardState; +begin + GetKeyboardState(State) ; + Result := ((State[vk_Control] And 128) <> 0) ; +end;*) + +(*procedure RescaleImageIntensity (var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; DefaultFormatVOI: boolean; var lNiftiHdr: TNIFTIHdr; lDefFilename: string); +const + kSlopeChange = 4; + kInterceptChange = -2000; +var + lFilename: string; + l16Buf : SmallIntP; + lInterChange : single; + lC: integer; +begin + if lImgBufferItems < 1 then + exit; + if lImgBufferBPP <> 2 then begin + showmessage('rescale only currently works with 16-bit data...'); + end; + lFilename := 'c:\nx.nii'; + lInterChange := 0; + if lNiftiHdr.scl_slope <> 0 then + lInterChange := kInterceptChange/lNiftiHdr.scl_slope; + l16Buf := SmallIntP(lImgBuffer ); + for lC := 1 to lImgBufferItems do + l16Buf[lC] := round((l16Buf[lC]-lInterChange)*kSlopeChange); + lNiftiHdr.scl_slope := lNiftiHdr.scl_slope/kSlopeChange; + lNiftiHdr.scl_inter := lNiftiHdr.scl_inter + kInterceptChange; + SaveAsVOIorNIFTIcore (lFilename,lImgBuffer, lImgBufferItems, lImgBufferBPP,lnVol,lNiftiHdr); +end;*) + +(*procedure MinImageIntensity (var lImgBuffer: ByteP; lImgBufferItems, lImgBufferBPP,lnVol: integer; DefaultFormatVOI: boolean; var lNiftiHdr: TNIFTIHdr; lDefFilename: string); +var + lFilename: string; + l16Buf : SmallIntP; + lInterChange : single; + lC: integer; +begin + if lImgBufferItems < 1 then + exit; + if lImgBufferBPP <> 2 then begin + showmessage('rescale only currently works with 16-bit data...'); + end; + lFilename := 'c:\nx.nii'; + lInterChange := 0; + l16Buf := SmallIntP(lImgBuffer ); + for lC := 1 to lImgBufferItems do + if l16Buf[lC] < 400 then + l16Buf[lC] := 0; + SaveAsVOIorNIFTIcore (lFilename,lImgBuffer, lImgBufferItems, lImgBufferBPP,lnVol,lNiftiHdr); +end;*) + +procedure TImgForm.SaveasNIfTI1Click(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + if gMRIcroOverlay[lLayer].ImgBufferItems=0 then begin + Showmessage('You must load an image [File/Open] before you can save the image.'); + exit; + end; + (*if CtrlDown then begin + RepositionOrigin(gMRIcroOverlay[lLayer].NiftiHdr); + Showmessage('Ctrl pressed while saving - current coordinates will be used for origin.'); + end;*) + if (not IsNifTiMagic(gMRIcroOverlay[lLayer].niftiHdr)) then + Showmessage('Warning: image will be saved with NIfTI spatial transform - ensure this image matches the orientation of the template images.'); + //RescaleImageIntensity(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); + //MinImageIntensity(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); + SaveAsVOIorNIFTI(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); +end; + +procedure TImgForm.ROIcomparisonClick(Sender: TObject); +var lComparison,lVolItems,lOverlay,lnOverlays,lPos: integer; +begin + lComparison := (Sender as TMenuItem).tag; //0=intersect AND,1=union OR ,2=mask + lVolItems := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]* gBGImg.ScrnDim[3]; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lVolItems) or (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems <> lVolItems) then begin + Showmessage('VOI comparisons require a VOI loaded onto a background image (Draw/Open).'); + exit; + end; + lnOverlays := 0; + for lOverlay := 1 to knMaxOverlay do + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then + inc(lnOverlays); + if (lnOverlays = 0) then begin + Showmessage('VOI comparisons require loaded overlays (Overlay/Add).'); + exit; + end; + CreateUndoVol; + {case MessageDlg('Warning: Unable to undo this operation. You should save a backup copy prior to this (Draw/Save). Are you sure you wish to filter your VOI?', mtConfirmation, + [mbYes, mbCancel], 0) of + id_Cancel: exit; + end; //case {} + if lComparison = 0 then begin //intersect AND + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer[lPos] = 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := 0; + end; //if overlay loaded + end; //for each overlay + end else if lComparison = 1 then begin //if intersect else UNION OR + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer[lPos] > 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := kVOI8bit; + end; //if overlay loaded + end; //for each overlay + end else if lComparison = 2 then begin //if union else MASK + for lOverlay := 1 to (knMaxOverlay-1) do begin + if gMRIcroOverlay[lOverlay].ScrnBufferItems = lVolItems then begin + for lPos := 1 to lVolItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer[lPos] > 0 then + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := 0; + end; //if overlay loaded + end; //for each overlay + end; //if ..else MASK + RefreshImagesTimer.Enabled := true; +end; //ROIcomparisonClick + +procedure TImgForm.RescaleImagesTimerTimer(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + RescaleImagesTimer.Enabled := false; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lLayer],lLayer); + RefreshImages; +end; + +procedure TImgForm.Fill3DBtnClick(Sender: TObject); +begin + AutoROIForm.Show; +end; + +procedure TImgForm.SmoothVOI1Click(Sender: TObject); +begin + SmoothVOIForm.Showmodal +end; + +procedure TImgForm.GenerateSPM5maskslesions1Click(Sender: TObject); +begin + SmoothVOIForm.SmoothVOI_SPM5masks; +end; + + +procedure TImgForm.CreateOverlap(Sender: TObject); +var + lNumberofFiles,lC,lOverlay,lPos: integer; + lMin: byte; + lFilename,lExt: string; + lOverlapBuffer: ByteP; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + UpdateLayerMenu; + lOverlay := 0; + for lC := 1 to (knMaxOverlay-1) do //-1: save final overlay for VOI + if (lOverlay = 0) and (gMRIcroOverlay[lC].ImgBufferItems = 0) then + lOverlay := lC; + if lOverlay = 0 then begin + showmessage('Too many overlays loaded to create an overlap image (Choose ''Close Overlays'' from the ''Overlay'' menu).'); + exit; + end; + if not OpenDialogExecute(kVOIFilter,'Select VOIs you wish to combine',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + exit; + end; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + getmem(lOverlapBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems); + fillchar(lOverlapBuffer^,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems,0); + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + lExt := UpCaseExt(lFileName); + gBGImg.VOIchanged := false; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lOverlay]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[lOverlay],false,false,false,gBGImg.ResliceOnLoad,false) then exit; + ProgressBar1.Position := lC; + //July07 - correct for scaling + lMin := 255; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer[lPos] < lMin then + lMin := gMRIcroOverlay[lOverlay].ScrnBuffer[lPos]; + //end July07 + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[lOverlay].ScrnBuffer[lPos] > lMin {July 07 0} then + lOverlapBuffer[lPos] := lOverlapBuffer[lPos]+1; + FreeImgMemory(gMRIcroOverlay[lOverlay]); + end; //for each image + GetMem(gMRIcroOverlay[lOverlay].ImgBufferUnaligned ,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems + 16); //July072007 + gMRIcroOverlay[lOverlay].ImgBuffer := ByteP($fffffff0 and (integer(gMRIcroOverlay[lOverlay].ImgBufferUnaligned)+15)); + gMRIcroOverlay[lOverlay].ImgBufferItems := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + for lPos := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + gMRIcroOverlay[lOverlay].ImgBuffer[lPos] := lOverlapBuffer[lPos]; + freemem(lOverlapBuffer); + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay],0, lNumberofFiles,1,0,0,kNIFTI_INTENT_ESTIMATE,'N'+inttostr(lNumberofFiles) ); + UpdateLayerMenu; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lOverlay],lOverlay); + ProgressBar1.Position := 0; + SaveAsVOIorNIFTI(gMRIcroOverlay[lOverlay].ImgBuffer,gMRIcroOverlay[lOverlay].ScrnBufferItems,1,1,false,gMRIcroOverlay[lOverlay].niftiHdr,'sum'+inttostr(lNumberofFiles)); + RefreshImagesTimer.Enabled := true; +end;//proc CreateOverlap + +procedure TImgForm.Chisquare1Click(Sender: TObject); +var + lNegativeNumbers: boolean; + lVolVoxels,lPos,lLoop:integer; + + lBuffer: ByteP; + lFilename: string; + lTotal,lYes,lNo: array [1..2] of integer; + lMRIcroHdr: TMRIcroHdr; + //code below for chi2 + //lBufferAligned,lBufferUnAligned: byteP; + //lnTotalThreshold,,lnVoxelsTested: integer + //l32Buf : SingleP; + //lMinExp,lChi,lChip,luChi, luChiP: double; + //lMaxChi,lMinChi: single; +begin + lVolVoxels := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lVolVoxels < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + CloseOverlayImgClick(nil); + for lLoop := 1 to 2 do begin //open two images + if lLoop = 1 then begin + if not OpenDialogExecute(kImgFilter,'Select POSITIVE overlap image',false) then exit + end else begin + if not OpenDialogExecute(kImgFilter,'Select NEGATIVE overlap image',false) then exit; + end; + lFilename := HdrForm.OpenHdrDlg.Filename; + if not HdrForm.OpenAndDisplayHdr(lFilename,gMRIcroOverlay[lLoop]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[lLoop],false,false,true,gBGImg.ResliceOnLoad,false) then exit; + lTotal[lLoop] := round(gMRIcroOverlay[lLoop].NIFTIhdr.glmax); + if (gMRIcroOverlay[lLoop].NIFTIhdr.intent_code <> kNIFTI_INTENT_ESTIMATE) then + showmessage('Warning: header intent_code is not set to ESTIMATE. Compute Chi-squared only with cumulative maps created with this program.'); + if (gMRIcroOverlay[lLoop].NIFTIhdr.intent_name[1] <> 'N') then + showmessage('Warning: header intention not N. Compute Chi-squared only with cumulative maps created with this program.'); + UpdateLayerMenu; + RefreshImagesTimer.Enabled := true; + end; + if (lVolVoxels<> gMRIcroOverlay[1].ScrnBufferItems) + or (lVolVoxels<> gMRIcroOverlay[2].ScrnBufferItems) then begin + showmessage('Error loading images.'); + exit; + end; + //next - chi squared + (*lnTotalThreshold:= ReadIntForm.GetInt('Only test voxels damaged in at least N patients [A+B]', 1,1,(lTotal[1]+lTotal[2])); + GetMem(lBufferUnaligned ,(lVolVoxels *sizeof(single) )+16); + lBufferAligned := ByteP($fffffff0 and (integer(lBufferUnaligned)+15)); + l32Buf := SingleP(lBufferAligned); + lnVoxelsTested := 0; + lNegativeNumbers := false; + lMaxChi := 0; + lMinChi := 0; + for lPos := 1 to lVolVoxels do begin + l32Buf[lPos] := 0; + lYes[1] := gMRIcroOverlay[1].ScrnBuffer[lPos]; + lNo[1] := lTotal[1]-lYes[1]; + lYes[2] := gMRIcroOverlay[2].ScrnBuffer[lPos]; + lNo[2] := lTotal[2]-lYes[2]; + if (lYes[1] < 0) or (lNo[1] < 0) or (lYes[2] < 0) or (lNo[2] < 0) then + lNegativeNumbers := true + else if (lYes[1]+lYes[2]) >= lnTotalThreshold then begin//e.g. at least 30% of all patients + inc(lnVoxelsTested); + Chi2x2 (lYes[1], lNo[1], lYes[2], lNo[2],lMinExp,lChi,lChip,luChi, luChiP); + if (luChi) > lMaxChi then + lMaxChi := (luChi) + else if (luChi < lMinChi) then + lMinChi := luChi; + if (lYes[1]/lTotal[1]) > (lYes[2]/lTotal[2]) then + l32Buf[lPos] := luChi//100-(100*luChip) //positives more likely than negative + else + l32Buf[lPos] := -luChi;//-100+(100*luChip); //negatives more common + end;//> threshold + end; //for each voxel + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,lMinChi, lMaxChi,1{df},0,lnVoxelsTested,kNIFTI_INTENT_CHISQ,inttostr(lnVoxelsTested) ); + if lNegativeNumbers then + Showmessage('Serious error: some group sizes were negative. This should be impossible with a Chi-Squared.'); + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'chi'+inttostr(lnTotalThreshold)); + //next - save log10 p values... + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,lMinChi, lMaxChi,1{df},0,lnVoxelsTested,NIFTI_INTENT_LOG10PVAL,inttostr(lnVoxelsTested) ); + for lPos := 1 to lVolVoxels do + if l32Buf[lPos] > 0 then + l32Buf[lPos] := -log(abs(gammq(0.5, 0.5 * l32Buf[lPos])),10) + else + l32Buf[lPos] :=0; + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(lnTotalThreshold)); + //next - free float buffer + FreeMem(lBufferUnaligned); + StatusLabel.Caption := 'Voxels tested: '+inttostr(lnVoxelsTested); + *) + //next - subtraction + GetMem(lBuffer ,(lVolVoxels )); + lNegativeNumbers := false; + fillchar(lBuffer^,lVolVoxels,100); + for lPos := 1 to lVolVoxels do begin + lYes[1] := gMRIcroOverlay[1].ScrnBuffer[lPos]; + lNo[1] := lTotal[1]-lYes[1]; + lYes[2] := gMRIcroOverlay[2].ScrnBuffer[lPos]; + lNo[2] := lTotal[2]-lYes[2]; + if (lYes[1] < 0) or (lNo[1] < 0) or (lYes[2] < 0) or (lNo[2] < 0) then + lNegativeNumbers := true + else if (lYes[1] >0) or (lYes[2] > 0) then begin + lBuffer[lPos] := round((100* ((lYes[1]/lTotal[1])-(lYes[2]/lTotal[2])))+100); + end;//> threshold + end; //for each voxel + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,-100, 100,1,0,0,kNIFTI_INTENT_ESTIMATE,'%'+inttostr(lTotal[1])+':'+inttostr(lTotal[2]) ); + lMRIcroHdr.NIFTIhdr.scl_inter:= -100; + if lNegativeNumbers then + Showmessage('Serious error: some group sizes were negative. This should be impossible with a subtraction analysis.'); + SaveAsVOIorNIFTI(lBuffer,lVolVoxels,1,1,false,lMRIcroHdr.NiftiHdr,'Sub'+inttostr(lTotal[1])+'_'+inttostr(lTotal[2])); + FreeMem(lBuffer); +end; //procedure Chisquare1Click + +procedure TImgForm.ROIVOI1Click(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + if gBGImg.Resliced then begin + if not HdrForm.OpenAndDisplayHdr(gMRIcroOverlay[kBGOverlayNum].HdrFileName,gMRIcroOverlay[kBGOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false) then exit; + end; + + showmessage('Warning: the currently open background image must have the dimensions (size, space between slices, etc) as the image used when creating the ROIs.'); + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems > 0 then + CloseVOIClick(nil); + if not OpenDialogExecute('MRIcro ROI (.roi)|*.roi','Select MRIcro format ROIs to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + OpenMRIcroROI (lFileName); + lFilename := changefileextx(lFilename,'.voi'); //Xversion 10/2007 - removes .nii.gz not just gz + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end; + +procedure TImgForm.LUTinvertBtnClick(Sender: TObject); +begin +end; //proc LUTdropSelect + +procedure TImgForm.LutFromZeroBtnClick(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + gMRIcroOverlay[lLayer].LUTfromZero := LUTfromZeroBtn.down; + LUTdropLoad(lLayer); + RescaleImagesTimer.Enabled := true; +end; + +procedure TImgForm.ShowMultisliceClick(Sender: TObject); +begin + MultiSliceForm.Show; +end; + +procedure DescribeVOIonLabels (lOverlayNum: integer; lShowFilename: boolean); +const + kT = kTextSep; + PositiveInfinityBits : Int64 = $7FF0000000000000; + NegativeInfinityBits : Int64 = $FFF0000000000000; +VAR + dPositiveInfinity : DOUBLE ABSOLUTE PositiveInfinityBits; + dNegativeInfinity : DOUBLE ABSOLUTE NegativeInfinityBits; +var + l16Buf : SmallIntP; + l32Buf : SingleP; + l8Buf: byteP; + type + TVxStat = RECORD //peristimulus plot + n, nNot0, minPos,maxPos: integer; + sum,sumNot0,min,max: double; + end; +function clearVxStat: TVxStat; +begin + result.sum:=0; + result.sumNot0:= 0; + result.n:=0; + result.nNot0 := 0; + result.minPos:= 0; + result.maxPos:=0; + result.min := dPositiveInfinity; + result.max := dNegativeInfinity; +end; +function roiIntensity(var lHdr: TMRIcroHdr; lPos: integer): integer; +var + l16Buf : SmallIntP; +begin + if (lHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(lHdr.ImgBuffer ); + result := l16Buf^[lPos]; + end else + result := lHdr.ImgBuffer^[lPos]; +end; +function overlayIntensity(var lHdr: TMRIcroHdr; lPos: integer): single; + +begin + if (lHdr.ImgBufferBPP = 4) then begin + result := l32Buf^[lPos]; + end else if (lHdr.ImgBufferBPP = 2) then begin + result := l16Buf^[lPos]; + end else + result := l8Buf^[lPos]; +end; +procedure scaleIntensity(var valn: double); +begin + valn := (valn * gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope)+gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_inter +end; +var + lROI,lVx: integer; + lStat: array of TVxStat; + lVal,loMax,hiMax: double; + lStartTime: DWord; + lBinaryOverlay: boolean; + lLabelStr,lStr: string; +begin + if (not gMRIcroOverlay[kBGOverlayNum].UsesLabels) or (High(gBGImg.LabelRA) < 1) then exit; + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then exit; + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP > 2) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 2) then exit; + //pointers to image data + l32Buf := SingleP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + l16Buf := SmallIntP(gMRIcroOverlay[lOverlayNum].ImgBuffer ); + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems = gMRIcroOverlay[lOverlayNum].ImgBufferItems then + l8Buf := gMRIcroOverlay[lOverlayNum].ImgBuffer + else + l8Buf := gMRIcroOverlay[lOverlayNum].ScrnBuffer; + + lStartTime := GetTickCount; + setlength(lStat, High(gBGImg.LabelRA)+1); + for lROI := 0 to High(gBGImg.LabelRA) do + lStat[lROI] := clearVxStat; + for lVx := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + lROI :=roiIntensity(gMRIcroOverlay[kBGOverlayNum], lVx); + inc(lStat[lROI].n); + lVal := overlayIntensity(gMRIcroOverlay[lOverlayNum],lVx); + lStat[lROI].sum := lStat[lROI].sum+ lVal; + if lVal <> 0 then begin + lStat[lROI].sumNot0 := lStat[lROI].sumNot0+ lVal; + inc(lStat[lROI].nNot0); + end; + if lVal > lStat[lROI].max then + lStat[lROI].max := lVal; + if lVal < lStat[lROI].min then + lStat[lROI].min := lVal; + end; //for each voxel + //calibrate values with rescale slope/intercept, see if overlay has variablility + loMax := dPositiveInfinity; + hiMax := dNegativeInfinity; + if gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope = 0 then gMRIcroOverlay[lOverlayNum].NIFTIhdr.scl_slope := 1; + for lROI := 0 to High(gBGImg.LabelRA) do begin + if (lStat[lROI].nNot0 > 0) and (lStat[lROI].max > hiMax) then hiMax := lStat[lROI].max; + if (lStat[lROI].nNot0 > 0) and (lStat[lROI].min < loMax) then loMax := lStat[lROI].max; + scaleIntensity (lStat[lROI].max); + scaleIntensity (lStat[lROI].min); + scaleIntensity (lStat[lROI].sum); + scaleIntensity (lStat[lROI].sumNot0); + end; + lBinaryOverlay := (hiMax <= loMax); + if lShowFilename then begin + if gMRIcroOverlay[lOverlayNum].HdrFileName = '' then + lLabelStr := 'VOI'+kT + else + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName+kT; + end else + lLabelStr := ''; + TextForm.MemoT.Lines.add(lLabelStr+'Custom Region Analysis'); + //add header + lStr := 'Index'+kT+'Name'+kT+'numVox'+kT+'numVoxNotZero'+kT+'fracNotZero'; + if not lBinaryOverlay then + lStr := lStr+kT+'peak'+kT+'min'+kT+'mean'+kT+'meanNotZero'; + TextForm.MemoT.Lines.Add(lLabelStr+lStr); + //report values + for lROI := 0 to High(gBGImg.LabelRA) do begin + if (lStat[lROI].nNot0 > 0) then begin + lStr := inttostr(lROI)+kT+gBGImg.LabelRA[lROI] + +kT+inttostr(lStat[lROI].n)+kT+inttostr(lStat[lROI].nNot0)+kT+ realtoStr(lStat[lROI].nNot0/lStat[lROI].n,3); + if not lBinaryOverlay then + lStr := lStr+kT+floattostr(lStat[lROI].max)+kT+floattostr(lStat[lROI].min) + +kT+floattostr(lStat[lROI].sum/lStat[lROI].n) +kT+floattostr(lStat[lROI].sumNot0/lStat[lROI].nNot0); + TextForm.MemoT.Lines.Add(lLabelStr+lStr ); + end; + + end; +end; + +function Mode (lOverlayNum: integer): double; +const + kBins = 4095; +var + lInc,lS,lMaxI: integer; + lV,lMin,lMax,lScale: single; + lRA: LongIntP0; +begin + result := nan; //error + if (gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems ) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1)then + exit; + lMin := RawBGIntensity(1); + lMax := lMin; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lV := RawBGIntensity(lInc); + if lV < lMin then + lMin := lV; + if lV > lMax then + lMax := lV; + end; //if VOI voxel + end; //for each voxel + if lMin = lMax then begin //no variability + result := Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],lMin); + exit; + end; + lScale := kBins/(lMax-lMin); + getmem(lRA,(kBins+1) * sizeof(longint) ); //0..kBins + for lInc := 0 to kBins do + lRA^[lInc] := 0; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer^[lInc] > 0 then begin + lV := RawBGIntensity(lInc); + lS := round((lV-lMin)*lScale); + inc(lRA^[lS]); + end; //if VOI voxel + end; //for each voxel + lMaxI := 0; + for lInc := 1 to kBins do + if lRA^[lInc] > lRA^[lMaxI] then + lMaxI := lInc; + result := lMin+ (lMaxI/kBins * (lMax-lMin)); + result := Raw2ScaledIntensity(gMRIcroOverlay[kBGOverlayNum],result); + freemem(lRA); +end; + +procedure TImgForm.ShowDescriptive (lOverlayNum: integer; lShowFilename: boolean); +var + lROIVol: array [1..3] of integer; + lInc: integer; + lCenterOfMass,lROISum,lROISumSqr,lROImin,lROImax:array [1..3] of double; + lMode,lCC,lVal,lSD,lROImean: double; + lLabelStr,lStr: string; +procedure AddVal( lRA: integer); +begin + inc(lROIVol[lRA]); + lROISum[lRA] := lROISum[lRA]+lVal; + lROISumSqr[lRA] := lROISumSqr[lRA] + sqr(lVal); + if lVal > lROImax[lRA] then + lROImax[lRA] := lVal; + if lVal < lROImin[lRA] then + lROImin[lRA] := lVal; +end; //proc AddVal +begin //proc ShowDescript + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems then + exit; + + if lShowFilename then + lLabelStr := gMRIcroOverlay[lOverlayNum].HdrFileName + else + lLabelStr := ''; + for lInc := 1 to 3 do begin + lROIVol[lInc] := 0; + lROISum[lInc] := 0; + lROISumSqr[lInc] := 0; + lROImin[lInc] := maxint; + lROImax[lInc] := -maxint; + end; + for lInc := 1 to gMRIcroOverlay[lOverlayNum].ScrnBufferItems do begin + if gMRIcroOverlay[lOverlayNum].ScrnBuffer[lInc] > 0 then begin + //fx(lInc); + lVal := RawBGIntensity(lInc); + AddVal(1); + if lVal <> 0 then + AddVal(2); + if lVal > 0 then + AddVal(3); + end; //if VOI voxel + end; //for each voxel + //next - compute StDev + //compute descriptives for each set of values + if lOverlayNum = kVOIOverlayNum then + lStr := 'VOI notes ' + else + lStr := 'Overlay #'+inttostr(lOverlayNum); + if not lShowFilename then begin + TextForm.MemoT.Lines.Add(lStr+' '+gMRIcroOverlay[lOverlayNum].HdrFileName); + end; + //TextForm.Memo1.Lines.Add('CoM'); + if CenterOfMass (lOverlayNum, lCenterOfMass[1],lCenterOfMass[2],lCenterOfMass[3]) > 0 then + TextForm.MemoT.Lines.Add(' '+lLabelStr+' Center of mass XYZ '+RealToStr(lCenterOfMass[1],2)+'x'+RealToStr(lCenterOfMass[2],2)+'x'+RealToStr(lCenterOfMass[3],2)); + for lInc := 1 to 3 do begin + if lROIVol[lInc] > 1 then begin + lSD := (lROISumSqr[lInc] - ((Sqr(lROISum[lInc]))/lROIVol[lInc])); + if (lSD > 0) then + lSD := Sqrt ( lSD/(lROIVol[lInc]-1)) + else + lSD := 0; + end else + lSD := 0; + //next compute mean + if lROIVol[lInc] > 0 then begin + lROImean := lROISum[lInc]/lROIVol[lInc]; + //next - calibrate values + lROImin[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImin[lInc]); + lROIMean := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROIMean); + lROImax[lInc] := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lROImax[lInc]); + lSD := Raw2ScaledIntensity (gMRIcroOverlay[kBGOverlayNum],lSD); + + end else begin //2/2008 + lROImin[lInc] := 0; + lROImax[lInc] := 0; + lROImean := 0; + end; + lcc := ((lROIVol[lInc]/1000)*gBGImg.ScrnMM[1]*gBGImg.ScrnMM[2]*gBGImg.ScrnMM[3]); + case lInc of + 3: lStr := 'VOI >0 '; + 2: lStr := 'VOI <>0 '; + else lStr := 'VOI '; + end; + lStr := lStr+' nvox[cc]=min/mean/max=SD:'+kTextSep+inttostr(round(lROIVol[lInc]))+kTextSep+RealToStr(lCC,2)+kTextSep+'='+kTextSep+RealToStr(lROIMin[lInc],4)+kTextSep+realToStr(lROIMean,4)+kTextSep+realToStr(lROIMax[lInc],4)+kTextSep+'='+kTextSep+realtostr(lSD,4); + TextForm.MemoT.Lines.Add(lLabelStr+ lStr); + end; + lMode := Mode(lOverlayNum); + if lMode <> NaN then + TextForm.MemoT.Lines.Add('Mode:'+kTextSep+floattostr(lMode)); + //June07 if (gMRIcroOverlay[kBGOverlayNum].UsesCustomPalette) or (lShowFilename) then + DescribeVOIonLabels(lOverlayNum,lShowfilename); + TextForm.MemoT.Lines.Add(''); + ImgForm.SaveDialog1.Filename := ExtractFileDirWithPathDelim(gMRIcroOverlay[lOverlayNum].HdrFileName)+'desc.csv'; +end; + +procedure TImgForm.DrawInterpolateSlicesClick (Sender: TObject); +var + lStrings: TStringList; + lOrient:integer; + lOK: boolean; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems=0 then begin + showmessage('Please open the drawing you wish to interpolate.'); + exit; + end; + lOrient := gBGImg.VOIUndoOrient; + if (lOrient < 1) or (lOrient > 3) then begin + showmessage('Unknown orient'); + exit; + end; + (* 4: UndoVolVOI; + 3: ReadCorVOI(ImgForm.UndoImg,gBGImg.VOIUndoSlice); + 2: ReadSagVOI(ImgForm.UndoImg,gBGImg.VOIUndoSlice); + 1: ReadAxialVOI(ImgForm.UndoImg,gBGImg.VOIUndoSlice); + end; *) + + CreateUndoVol; + lStrings := TStringList.Create; + + TextForm.MemoT.Lines.Clear; + lStrings.Add('Background'); + lOK := Interpolate_Slices (gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gBGImg.ScrnDim[1],gBGImg.ScrnDim[2],gBGImg.ScrnDim[3],lOrient, lStrings); + if not lOK then begin + TextForm.MemoT.Lines.AddStrings(lStrings); + TextForm.Show; + end; + ImgForm.RefreshImagesTimer.Enabled := true; + lStrings.Free; +end; + +procedure TImgForm.DescriptiveMenuItemClick(Sender: TObject); +var + lInc,lOverlayNum,lImgSz: integer; +begin + // DrawInterpolateSlicesClick (Sender); exit; //666 + lImgSz := 0; + for lOverlayNum := 1 to knMaxOverlay do + if gMRIcroOverlay[lOverlayNum].ScrnBufferItems > lImgSz then + lImgSz := gMRIcroOverlay[lOverlayNum].ScrnBufferItems; + if (lImgSz < 1) or (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < lImgSz) then begin + Showmessage('You need to create or load an overlay (Overlay/Open or Draw/OpenVOI) to get overlay statistics.'); + exit; + end; + TextForm.MemoT.Lines.Clear; + for lInc := 1 to knMaxOverlay do begin + ShowDescriptive(lInc,false); + end; + //SaveDialog1.Filename := ExtractFileDirWithPathDelim(HdrForm.OpenHdrDlg.Files[0])+'desc.csv'; + TextForm.Show; +end; + +procedure TImgForm.BatchROImean1Click(Sender: TObject); +var + lInc,lNumberofFiles: integer; + lFilename:string; +begin + +//OpenAndDisplayImg(lStr,false); + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + UpdateLayerMenu; + if not OpenDialogExecute(kImgFilter,'Select regions of interest you wish to analyze',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.MemoT.Lines.Clear; + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + OverlayOpenCore ( lFilename, 2); + ShowDescriptive(2,true); + end; + FreeImgMemory(gMRIcroOverlay[2]); + UpdateLayerMenu; + TextForm.Show; +end; +(*procedure TImgForm.BatchROImean1Click(Sender: TObject); +var + lInc,lNumberofFiles: integer; + lFilename:string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + UpdateLayerMenu; + if not OpenDialogExecute(kImgFilter,'Select regions of interest you wish to analyze',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + TextForm.MemoT.Lines.Clear; + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + OverlayOpenCore ( lFilename, 2); + ShowDescriptive(2,true); + end; + FreeImgMemory(gMRIcroOverlay[2]); + UpdateLayerMenu; + TextForm.Show; +end; *) + +procedure TImgForm.FormResize(Sender: TObject); +begin + //if ImgForm.WindowState = wsMaximized then + RefreshImagesTimer.Enabled := true; +end; + +function ParamStrFilename (var lParamPos: integer): string; +var + I: integer; + lStr: string; +begin + result := ''; + if (ParamCount < lParamPos) then exit; + I := lParamPos; + repeat + if I = lParamPos then + lStr := ParamStr(I) + else + lStr := lStr +' '+ ParamStr(I); + inc(I); + until (I>ParamCount) or (fileexistsex(lStr)); + lParamPos := I; + if fileexistsex(lStr) then + result := lStr; + //Showmessage(lStr+ '-> '+result); +end; + +{$DEFINE notTEST} + +{$IFDEF TEST} +(*procedure Merge; +var + lInc,lLayer: integer; + lOut: double; +begin + showmessage(inttostr(kBGOverlayNum)); + + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for merging.'); + exit; + end; + lLayer := 1; + if gMRIcroOverlay[lLayer].ScrnBufferItems < 1 then begin + showmessage('Please load an overlay image for merging.'); + exit; + end; + //lImgSamples := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + for lInc := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do begin + //if (gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lInc] <> 0) then + //lOut := (gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lInc]/255) * 80; + //lOut := lOut+((gMRIcroOverlay[lLayer].ScrnBuffer[lInc]/255)*130) ; + lOut := 0; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lInc]+gMRIcroOverlay[lLayer].ScrnBuffer[lInc])> 52 then + lOut := 100; + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lInc] := round(lOut); + + end; + SaveAsVOIorNIFTI(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems,1,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end; *) +{$ENDIF} + + + + +procedure TImgForm.FormShow(Sender: TObject); +var + lStr: String; + lMaximize,lRender,lMultislice : boolean; + lCommandChar: Char; + I,lError,lOverlayNum,lInc,lLUT: integer; + lSingle: single; +procedure ReadCmdVal;//nested +begin + inc(I); + lStr := ParamStr(I); + lStr := string(StrUpper(PChar(lStr))) ; +end; //nested ReadCmdVal +begin + + (*ResliceImg ( + 'C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\example_func.nii.gz', + 'C:\fatigue\v1.nii.gz', + 'C:\cygwin\home\express\20070420_132327fMRIcontin30x30x36s004a001.feat\reg\example_func2standard.mat', + 'C:\fatigue\crapp.nii.gz') ; + *) + {$IFDEF TEST} + //ResliceImgNIfTI ('c:\fx\target.nii.gz','c:\fx\source.nii.gz','c:\fx\junk2.nii.gz'); + //ResliceImgNIfTI ('c:\fx\target.nii.gz','c:\fx\target.nii.gz','c:\fx\junk24.nii.gz'); + //ResliceImgNIfTI ('c:\fx\hires.nii.gz','c:\fx\higher.nii.gz','c:\fx\junk.nii.gz'); + + //ResliceImg('C:\fatigue\example_func.nii.gz' ,'C:\fatigue\avg152T1.hdr','C:\fatigue\example_func2standard.mat'); + //ResliceImg('C:\fatigue\lowres.nii.gz' ,'C:\fatigue\hires.nii.gz','C:\fatigue\example_func2standard.mat','c:\fatigue\fzz.nii.gz'); + lStr := 'c:\drawx\c.nii.gz'; + OpenAndDisplayImg(lStr,false); + lStr := 'C:\drawx\c.voi'; + OpenVOICore(lStr); + //LoadOverlay(lStr); + //lStr := 'c:\fatigue\jx.nii'; + //OpenAndDisplayImg(lStr,false); + //'C:\fatigue\example_func2standard.mat'); + //Graph4DForm.show; + //Graph4DForm.FSLbatch1Click(nil); + //Graph4DForm.OpenDataClick(nil); + + exit; + {$ENDIF} + //Graph4DForm.rfx; + if (ParamCount < 1) then begin + {$IFNDEF TEST} + lStr := gMRIcroOverlay[kBGOverlayNum].HdrFilename; + if fileexists (lStr) then + OpenAndDisplayImg(lStr,false) + else + ImgForm.OpenTemplateMRU(nil); + // Reorient1Click(nil); + exit; + {$ELSE} + lStr := extractfiledir(ParamStr(0))+'\templates\ch2bet.nii.gz'; + //lStr := extractfiledir(ParamStr(0))+'\templates\xz.voi'; + //lStr := 'c:\zx\c1fxcbruce.nii'; + if fileexists(lStr) then begin + OpenAndDisplayImg(lStr,false); + //OverlayOpenCore (kBGOverlayNum); + //showmessage('22');xxx + //gMRIcroOverlay[1].LUTfromZero := true; + //gMRIcroOverlay[1].WindowScaledMin := -4; + //gMRIcroOverlay[1].WindowScaledMax := -2; + //RescaleImgIntensity(gBGImg,gMRIcroOverlay[1]); + RefreshImages; + end; + + lStr := extractfiledir(ParamStr(0))+'\example\attention.nii.gz'; + lInc := 1+kBGOverlayNum; + if fileexists(lStr) then begin + OverlayOpenCore (lStr,lInc); + gMRIcroOverlay[lInc].LUTfromZero := true; + gMRIcroOverlay[lInc].WindowScaledMin := 4; + gMRIcroOverlay[lInc].WindowScaledMax := 4; + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lInc],lInc); + end else + showmessage('Can not find '+lStr); + //Merge; + exit; + {$ENDIF} + end; + lMaximize := false; + lRender := false; + lMultislice := false; + lOverlayNum := 0; + I := 1; + lStr := ParamStrFilename(I); + if lStr <> '' then + ImgForm.OpenAndDisplayImg(lStr,True) + else begin //no requested image + ImgForm.OpenTemplateMRU(nil); + I := 1;//exit; + end; + I := I-1; + //ShowMultisliceClick(nil); + if I >= ParamCount then exit; + gBGIMg.SaveDefaultIni := false; //do not store changes loaded by script + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') then begin //special command + lCommandChar := UpCase(lStr[2]); + case lCommandChar of + 'B': begin //background transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then begin + gBGImg.BGTransPct := round(lSingle); + SetSubmenuWithTag(BGTransPctMenu, gBGImg.BGTransPct); + end; + end; + 'C': begin //color look up table + ReadCmdVal; + if (Length(lStr)>1) then begin + if lStr[1] = '-' then begin //LUT index number + Val(lStr,lSingle,lError); + if lError = 0 then + lLUT := abs(round(lSingle)) + else + lLUT := -1; + end else begin + lStr := ParseFileName(ExtractFileName(lStr)); + lLUT := -1; + for lInc := 1 to (LUTdrop.Items.Count-1) do + if lStr = string(StrUpper(PChar(LUTdrop.Items.Strings[lINc]))) then + lLUT := lInc; + end; //else text LUTname + if lLUT >= 0 then begin + gMRIcroOverlay[lOverlayNum].LUTindex := lLUT; + LUTdropLoad(lOverlayNum); + end; + end; //str length > 1 + end; + 'D': gBGIMg.SaveDefaultIni := true; //save defaults + 'F': gBGImg.ResliceOnLoad := false; //turn off reslicing... loads files flat + 'H': begin //High intensity scale + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMax := (lSingle); + end; //not 'A' or 'H'} + 'L': begin //Low intensity scale + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gMRIcroOverlay[lOverlayNum].WindowScaledMin := (lSingle); + end; + 'M': begin //multislice + lMultislice := true; + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gMultiSliceStartupFilename := (lStr); + + //CopyFileEXoverwrite (lStr,extractfiledir(paramstr(0))+'\multislice\default.ini'); + end; //if 'M' + + 'O': begin//Overlay + ReadCmdVal; + if (lStr <> '') and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then begin + inc(lOverlayNum); + OverlayOpenCore (lStr,lOverlayNum); + end; + end; //if 'O' + 'R': begin//Overlay + lRender := true;//Render + ReadCmdVal; + if (lStr <> '') and (lStr <> '-')and (FileexistsEx(lStr)) and (lOverlayNum < (knMaxOverlay-1)) then + gRenderStartupFilename := (lStr); + end; //if 'R' + 'S': begin //smooth + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then begin + if odd(round(lSingle)) then begin + gBGImg.StretchQuality := sqHigh; + Menu2DSmooth.checked := true; + end else begin + gBGImg.StretchQuality := sqLow; + Menu2DSmooth.checked := false; + end; + if lSingle > 1 then + gBGIMg.OverlaySmooth := true + else + gBGIMg.OverlaySmooth := false; + OverlaySmoothMenu.Checked := gBGIMg.OverlaySmooth; + end;//error=0 + end; + 'T': begin //overlay transparency + ReadCmdVal; + Val(lStr,lSingle,lError); + if lError = 0 then + gBGImg.OverlayTransPct := round(lSingle); + SetSubmenuWithTag(OverlayTransPctMenu, gBGImg.OverlayTransPct); + + end; + 'V': begin //open voi + ReadCmdVal; + if (lStr <> '') and (FileexistsEx(lStr)) then + OpenVOICore(lStr); + end; + 'X': lMaximize := true; //open maximized + 'Z': gMRIcroOverlay[lOverlayNum].LUTfromZero := true; + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + until I >= ParamCount; + LayerDropSelect(nil); + //RescaleImagesTimer.Enabled := true; + //RescaleImagesTimerTimer(nil); + for lInc := 0 to lOverlayNum do + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lInc],lInc); + RefreshImages; + if lMultiSlice then + ShowMultisliceClick(nil); + if lRender then + ShowRenderClick(nil); + if lMaximize then begin + ImgForm.WindowState := wsMaximized; + RefreshImagesTimer.Enabled := true; + end; + +end; + +procedure TImgForm.FlipLRmenuClick(Sender: TObject); +var + lC: integer; + lStr: string; +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gBGImg.Mirror := (sender as TMenuItem).checked ; + gBGImg.VOImirrored := true; + for lC := 0 to knMaxOverlay do + if gMRIcroOverlay[lC].ScrnBufferItems > 0 then + RescaleImgIntensity(gBGImg,gMRIcroOverlay[lC],lC); + RefreshImagesTimer.Enabled := true; + if gBGImg.Mirror then + lStr := 'radiological [right on left side]' + else + lStr := 'neurological [left on left side]'; + showmessage('Warning: left-right flips can be confusing. From now on, this software will attempt to show NIfTI images in '+lStr+' orientation.'); + if MultiSliceForm.Visible then + MultiSliceForm.CreateMultiSlice; +end; + +procedure TImgForm.Menu2DSmoothClick(Sender: TObject); +begin + if Sender <> nil then + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + if Menu2DSmooth.checked then + gBGImg.StretchQuality := sqHigh + else + gBGImg.StretchQuality := sqLow; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.VALclick(Sender: TObject); +begin + showmessage('Please use NPM'); + //ComputeValFile( (sender as Tmenuitem).tag); +end; + +procedure TImgForm.VOI2NIIClick(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; + lNIFTIhdr: TNIFTIhdr; +begin + CloseImagesClick(nil); + if not OpenDialogExecute('VOI Drawings (.VOI)|*.VOI','Select VOI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileextx(lFilename,'.nii'); ////Xversion 10/2007 - removes .nii.gz not just gz + //Start 10/2007: adjust scl_slope;? 10/2007 + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + lNIFTIhdr.scl_slope := 1; + lNIFTIhdr.scl_inter := 0; + //end + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,lNiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end;//VOI->NII + +procedure TImgForm.NIIVOI1Click(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter {10/2007},'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileextx(lFilename,'.voi'); ////Xversion 10/2007 - removes .nii.gz not just gz + //SaveAsVOIorNIFTIcore (lFilename, lByteP, lVoxels, 1, gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end; + +procedure TImgForm.TtoP1Click(Sender: TObject); +var + lBufferAligned,lBufferUnAligned: ByteP; + l32Buf,l32BufSrc : SingleP; + l16BufSrc : SmallIntP; + lSlope,lIntercept: single; + //l32Buf : SingleP; + + lMRIcroHdr: TMRIcroHdr; + lVolVoxels,lPos: integer; +begin +//alfa - currently open image + lVolVoxels := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lVolVoxels < 1 then begin + showmessage('Please load a background image (''File''/''Open'') before adding an overlay.'); + exit; + end; + GetMem(lBufferUnaligned ,(lVolVoxels *sizeof(single) )+16); + lBufferAligned := ByteP($fffffff0 and (integer(lBufferUnaligned)+15)); + l32Buf := SingleP(lBufferAligned); + //next load values + case gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP of + 4: begin + l32BufSrc := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lPos := 1 to lVolVoxels do + l32Buf[lPos] := l32BufSrc[lPos]; + end; + 2: begin + l16BufSrc := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lPos := 1 to lVolVoxels do + l32Buf[lPos] := l16BufSrc[lPos]; + end; + 1: begin + for lPos := 1 to lVolVoxels do + l32Buf[lPos] := gMRIcroOverlay[kBGOverlayNum].ImgBuffer[lPos]; + end; + else begin + showmessage('unknown datatype'); + end; + end; + //next calibrate values + lSlope := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.scl_slope; + lIntercept := gMRIcroOverlay[kBGOverlayNum].NIFTIhdr.scl_inter; + if (lSlope=0) or ((lSlope=1) and (lIntercept=0)) then + //no slope + else begin + for lPos := 1 to lVolVoxels do + l32Buf[lPos] := (l32Buf[lPos] * lSlope)+lIntercept; + end; + //next - save log10 p values... + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lMRIcroHdr,0, 255,1{df},0,666,NIFTI_INTENT_LOG10PVAL,inttostr(666) ); + for lPos := 1 to lVolVoxels do + if l32Buf[lPos] > 0 then + l32Buf[lPos] := -log(abs(pTdistr(42,l32Buf[lPos])),10) + else + l32Buf[lPos] :=0; + SaveAsVOIorNIFTI(lBufferAligned,lVolVoxels,4,1,false,lMRIcroHdr.NiftiHdr,'log10p'+inttostr(666)); + //next - free float buffer + FreeMem(lBufferUnaligned); + +end; + +procedure TImgForm.DesignVALClick(Sender: TObject); +begin + showmessage('Please use NPM'); + //SpreadForm.Show; +end; + +procedure TImgForm.Up1Click(Sender: TObject); +var lVolVox,lPos,lShift: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + showmessage('You must have open a background image in order to apply an intensity filter (use File/Open).'); + exit; + end; + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + CreateUndoVol;//create gBGImg.VOIUndoVol + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + lVolVox := gBGImg.ScrnDim[1]* gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]; + case (Sender as TMenuItem).tag of + 0: lShift := 1; + 1: lShift := -1; + 2: lShift := gBGImg.ScrnDim[1]; + 3: lShift := -gBGImg.ScrnDim[1]; + 4: lShift := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + else {5} lShift := -gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + end; + if lShift > 0 then begin + for lPos := 1 to (lVolVox-lShift) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := gBGImg.VOIUndoVol[lPos+lShift]; + end else begin + for lPos := (1+abs(lShift)) to lVolVox do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := gBGImg.VOIUndoVol[lPos+lShift]; + end; + gBGImg.VOIchanged := true; + ImgForm.ProgressBar1.Position := 0; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + + +procedure TImgForm.FormDestroy(Sender: TObject); +begin +CloseShareMem; +end; + +procedure TImgForm.YokeMenuClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gYoke := (sender as TMenuItem).checked ; + YokeTimer.Enabled := gYoke; +end; + +(*function A2R(var lIn: string): string; +begin + result := lIn; + if length(lIn) < 6 then exit; + //result[1] := 'r'; + result[length(lIn)-4] := 'R'; +end; + +procedure VolComp(var lAVol,lOldVol,lNewVol,lARdistance: integer); +var + lAX,lAY,lAZ,lRX,lRY,lRZ: double; + lRVol,lXd,lYd,lZd,lImgSz,lX,lY,lZ,lInc: integer; + +begin + lAX := 0; lAY := 0; lAZ := 0; lRX := 0; lRY := 0; lRZ := 0; + lAVol := 0; + lOldVol := 0; + lNewVol := 0; + lImgSz := gMRIcroOverlay[0].ScrnBufferItems; + if lImgSz <> gMRIcroOverlay[1].ScrnBufferItems then exit; + lXd := gMRIcroOverlay[0].NIFTIhdr.dim[1]; + lYd := gMRIcroOverlay[0].NIFTIhdr.dim[2]; + lZd := gMRIcroOverlay[0].NIFTIhdr.dim[3]; + //fx(lXd,lYd,lZd); + lInc := 0; + for lZ := 1 to lZd do begin + for lY := 1 to lYd do begin + for lX := 1 to lXd do begin + inc(lInc); + if gMRIcroOverlay[0].ScrnBuffer[lInc] > 0 then begin + + lAX := lAX + lX; + lAY := lAY + lY; + lAZ := lAZ + lZ; + end; + + if gMRIcroOverlay[1].ScrnBuffer[lInc] > 0 then begin + lRX := lRX + lX; + lRY := lRY + lY; + lRZ := lRZ + lZ; + end; + + end; //lX + end;//Y + end;//Z + for lInc := 1 to lImgSz do begin + if gMRIcroOverlay[0].ScrnBuffer[lInc] > 0 then begin + inc(lAVol);//acute volume + if gMRIcroOverlay[1].ScrnBuffer[lInc] > 0 then + inc(lOldVol); + end else if gMRIcroOverlay[1].ScrnBuffer[lInc] > 0 then + inc(lNewVol); + end; //for each voxel + if lAVol > 0 then begin + lAX := lAX / lAVol; + lAY := lAY / lAVol; + lAZ := lAZ / lAVol; + end; + + lRVol := lOldVol + lNewVol; + if lRVol > 0 then begin + lRX := lRX / lRVol; + lRY := lRY / lRVol; + lRZ := lRZ / lRVol; + end; + lARDistance := round(sqrt( sqr(lRX-lAX)+sqr(lRY-lAY)+sqr(lRZ-lAZ))); + //fx(lAX,lAY,lAZ); + //fx(lRX,lRY,lRZ); + //fx(sqrt( sqr(lRX-lAX)+sqr(lRY-lAY)+sqr(lRZ-lAZ)),lARdistance); +end; + +function Age(var lIn: string): integer; +var + lStr: string; + +begin + result := length(lIn); + if result < 12 then exit; + lStr := lIn[result-9]+lIn[result-8]+lIn[result-7]+lIn[result-6]; + //showmessage(lStr); + result := 2006- strtoint(lStr); + //result[length(lIn)-4] := 'R'; +end; + +procedure TImgForm.x1Click(Sender: TObject); +var + lSearchRec: TSearchRec; + lAName,lRName,lDir: string; + lOrigVol,lOldVol,lNewVol,lAge,lARdistance: integer; + lGroupChar : char; +begin + TextForm.Memo1.Lines.Clear; + TextForm.Memo1.Lines.Add('Aimg,Rimg,group,Avol,Rvol,RinsideA,RoutsideA,Age,ARdistance' ); + lDir := 'C:\t\'; + if FindFirst(lDir+'*A.voi', faAnyFile, lSearchRec) = 0 then + repeat + lAName := lSearchRec.Name; + lRName := A2R(lAName); + lAge := Age(lAName); + lGroupChar := lAName[1]; + lAName := lDir+lAName; + lRName := lDir+lRName; + if not FileExistsEx(lRName) then + TextForm.Memo1.Lines.Add('*Error:,'+lAName+','+lRName) + else begin + //LoadBG + CloseImagesClick(nil); + OpenAndDisplayImg(lAname,True); + OverlayOpenCore ( lRname, 1); + VolComp(lOrigVol,lOldVol,lNewVol,lARdistance); + TextForm.Memo1.Lines.Add(lAName+','+lRName+','+lGroupChar+','+inttostr(lOrigVol)+','+inttostr(lOldVol+lNewVol)+','+inttostr(lOldVol)+','+inttostr(lNewVol)+','+inttostr(lAge)+','+inttostr(lARdistance) ); + end; + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); + TextForm.Show; +end;*) + +procedure TImgForm.X1Click(Sender: TObject); +begin + CropEdgeForm.Show; +end; + +procedure TImgForm.BrainExtraction1Click(Sender: TObject); +begin + BETForm.show; +end; + +procedure TImgForm.NZ1Click(Sender: TObject); +begin +end; + + +(*var + lFilename: string; + lPos,lInc: Integer; +begin + + showmessage('Convert images to .nii.gz '+kImgFilter); + if not OpenDialogExecute(kImgFilter,'Select images',true) then + exit; + if HdrForm.OpenHdrDlg.Files.Count < 1 then + exit; + + for lPos := 1 to HdrForm.OpenHdrDlg.Files.Count do begin + lFilename := HdrForm.OpenHdrDlg.Files[lPos-1]; + OpenAndDisplayImg(lFilename,True); + for lInc := 1 to 18 do + gMRIcroOverlay[kBGOverlayNum].NIfTIHdr.db_name[lInc] := chr(0); + lFilename := extractfiledir(lFilename)+'\'+inttostr(lPos)+'.nii.gz'; + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + end; +end;*) + +procedure TImgForm.MNICoordinates1Click(Sender: TObject); +begin + MNIForm.show; +end; + +procedure TImgForm.Histogram1Click(Sender: TObject); +var + lLayer: integer; +begin + lLayer := ActiveLayer; + DrawHistogram(gMRIcroOverlay[lLayer],HistogramForm.HistoImage{lImage}); + HistogramForm.Caption := 'Histogram: '+extractfilename(gMRIcroOverlay[lLayer].HdrFileName); + HistogramForm.show; +end; + +procedure TImgForm.N4DTraces1Click(Sender: TObject); +begin + Graph4DForm.show; +end; + +procedure TImgForm.Sagittal1Click(Sender: TObject); +begin + gBGImg.SliceView := (Sender as TMenuItem).Tag; + imgForm.Triplepanel.VertScrollBar.Position := 0; + imgForm.Triplepanel.HorzScrollBar.Position := 0; + RefreshImagesTimer.Enabled := true; +end; + +procedure TImgForm.HideVOI1Click(Sender: TObject); +begin + if HideROITimer.enabled then + exit; //still hiding - do not forget desired transparency + HideROIBtnMouseDown(nil,mbleft,[],0,0); + HideROITimer.enabled := true; +end; + +procedure TImgForm.HideROITimerTimer(Sender: TObject); +begin + HideROITimer.enabled := false; + HideROIBtnMouseUp (nil,mbleft,[],0,0); +end; + +(*procedure Stripe (L,T,R,B: integer); +var + lL,lR,lT,lB,lX,lY,lZ,lLinePos,lSlicePos: integer; +begin + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> (gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2] * gBGImg.ScrnDim[3])) or + (gBGImg.ScrnDim[1] < 2) or (gBGImg.ScrnDim[2] < 2) or ( gBGImg.ScrnDim[3] < 2) then exit; + lL := Bound(L,1,gBGImg.ScrnDim[1]); + lT := Bound(T,1,gBGImg.ScrnDim[2]); + lR := Bound(R,1,gBGImg.ScrnDim[1]); + lB := Bound(B,1,gBGImg.ScrnDim[2]); + SortInt(lL,lR); + SortInt(lT,lB); + for lZ := 1 to gBGImg.ScrnDim[3] do begin + lSlicePos := (lZ-1) * gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + for lY := lT to lB do begin + lLinePos := lSlicePos + ((lY-1)* gBGImg.ScrnDim[1]); + for lX := lL to lR do begin + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lX+lLinePos] := 255; + + end;//X + end;//Y + end;//Z +end; + +procedure StripeVol; +const + kStipeThick = 2; + kStipeSpacing = 20; +var + lRow,lNumberofFiles,lX,lY,lZ: integer; + lFilename: string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for striping.'); + exit; + end; + if ((gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2] * gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then begin + showmessage('Unable to stripe.'); + exit; + end; + if (gBGImg.ScrnDim[1] < kStipeSpacing) or (gBGImg.ScrnDim[2] < kStipeSpacing) then begin + showmessage('Image resolution to low to stripe.'); + exit; + end; + {for lRow := 1 to (1+(gBGImg.ScrnDim[1] div kStipeSpacing)) do + Stripe( 1+((lRow-1)*kStipeSpacing), 1,2+((lRow-1)*kStipeSpacing),gBGImg.ScrnDim[2]); + for lRow := 1 to ((gBGImg.ScrnDim[2] div kStipeSpacing)+1) do + Stripe( 1, 1+((lRow-1)*kStipeSpacing), gBGImg.ScrnDim[1],2+((lRow-1)*kStipeSpacing)); } + Stripe(46,1,46,gBGImg.ScrnDim[2]); + Stripe(1,64,gBGImg.ScrnDim[1],64); + + lFilename := 'c:\striped2.hdr'; + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + +end; *) + + + +procedure TImgForm.CropEdges1Click(Sender: TObject); +begin +//StripeVol; +CropEdgeForm.Show; +end; + +procedure TImgForm.Preferences1Click(Sender: TObject); +begin + PrefForm.ShowModal; +end; + + +procedure TImgForm.Header1Click(Sender: TObject); +begin +DisplayHdrClick(nil); +end; + + +function AbsImg: boolean; +//generate absolute image +var + lHdr:TMRIcroHdr; + lImgSamples,lInc,lBPP: integer; + l32Buf,lo32Buf : SingleP; + l16Buf : SmallIntP; +begin + //note ignores input slope/intercept scaling values + result := false; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for calculating abolutes.'); + exit; + end; + if ((gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2] * gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then begin + showmessage('Unable to rescale.'); + exit; + end; + lBPP := gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP;//check if BitsPerPixel is supported + if (lBPP = 1) then begin + showmessage('Can not make absoulte image for (unsigned) 8-bit data.'); + exit; + end; + + if (lBPP <> 4) and (lBPP <> 2) and (lBPP <> 1) then begin + showmessage('AbsoluteImg Error: Unsupported BPP: '+inttostr(lBPP)); + exit; + end; + lImgSamples := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lHdr,0{min}, 0{max},0{p1},0{p2},0{p3},kNIFTI_INTENT_NONE,'abs' ); + GetMem(lHdr.ImgBufferUnaligned ,(lImgSamples*4)+16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lo32Buf := SingleP( lHdr.ImgBuffer ); + if lBPP = 4 then begin + l32Buf := SingleP( gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lInc := 1 to lImgSamples do + lo32Buf[lInc] := abs(l32Buf[lInc]) ; + end else if lBPP = 2 then begin //lBPP=4 else + l16Buf := SmallIntP( gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lInc := 1 to lImgSamples do + lo32Buf[lInc] := abs(l16Buf[lInc]); + end else if lBPP = 1 then begin //lBPP=2 else + for lInc := 1 to lImgSamples do + lo32Buf[lInc] := (gMRIcroOverlay[kBGOverlayNum].ImgBuffer[lInc]); + end;//lBPP = 1 + SaveAsVOIorNIFTI(bytep(lo32Buf),lImgSamples,4,1,false,lHdr.NiftiHdr,'rscl'+extractfilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename)); + //SaveAsVOIorNIFTI(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); + FreeMem(lHdr.ImgBufferUnaligned); + //lFilename := 'c:\striped2.hdr'; + //SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + result := true; +end; + + +function RescaleImg( lRescaleIntercept,lRescaleSlope: double): boolean; +var + //lRow,lNumberofFiles,lX,lY,lZ: integer; + //lFilename: string; + lHdr:TMRIcroHdr; + lImgSamples,lInc,lBPP: integer; + l32Buf,lo32Buf : SingleP; + l16Buf : SmallIntP; +begin + //note ignores input slope/intercept scaling values + result := false; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + if ((gBGImg.ScrnDim[1] * gBGImg.ScrnDim[2] * gBGImg.ScrnDim[3]) <> gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems) then begin + showmessage('Unable to rescale.'); + exit; + end; + lBPP := gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP;//check if BitsPerPixel is supported + if (lBPP <> 4) and (lBPP <> 2) and (lBPP <> 1) then begin + showmessage('RescaleImg Error: Unsupported BPP: '+inttostr(lBPP)); + exit; + end; + lImgSamples := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + MakeStatHdr (gMRIcroOverlay[kBGOverlayNum],lHdr,0{min}, 0{max},0{p1},0{p2},0{p3},kNIFTI_INTENT_NONE,floattostr(lRescaleSlope) ); + GetMem(lHdr.ImgBufferUnaligned ,(lImgSamples*4)+16); + lHdr.ImgBuffer := ByteP($fffffff0 and (integer(lHdr.ImgBufferUnaligned)+15)); + lo32Buf := SingleP( lHdr.ImgBuffer ); + if lBPP = 4 then begin + l32Buf := SingleP( gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lInc := 1 to lImgSamples do + lo32Buf[lInc] := (l32Buf[lInc]+lRescaleIntercept) * lRescaleSlope; + end else if lBPP = 2 then begin //lBPP=4 else + l16Buf := SmallIntP( gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + for lInc := 1 to lImgSamples do + lo32Buf[lInc] := (l16Buf[lInc]+lRescaleIntercept) * lRescaleSlope; + end else if lBPP = 1 then begin //lBPP=2 else + for lInc := 1 to lImgSamples do + lo32Buf[lInc] := (gMRIcroOverlay[kBGOverlayNum].ImgBuffer[lInc]+lRescaleIntercept) * lRescaleSlope; + end;//lBPP = 1 + SaveAsVOIorNIFTI(bytep(lo32Buf),lImgSamples,4,1,false,lHdr.NiftiHdr,'rscl'+extractfilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename)); + //SaveAsVOIorNIFTI(gMRIcroOverlay[lLayer].ImgBuffer,gMRIcroOverlay[lLayer].ImgBufferItems,gMRIcroOverlay[lLayer].ImgBufferBPP,1,false,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[lLayer].HdrFilename); + FreeMem(lHdr.ImgBufferUnaligned); + //lFilename := 'c:\striped2.hdr'; + //SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + result := true; +end; + +procedure TImgForm.RescaleMenuClick(Sender: TObject); +var ldTE,lScale,lTE1,lTE2: double; + //lStr: string; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + if gBGImg.Resliced then begin + if not HdrForm.OpenAndDisplayHdr(gMRIcroOverlay[kBGOverlayNum].HdrFileName,gMRIcroOverlay[kBGOverlayNum]) then exit; + if not OpenImg(gBGImg,gMRIcroOverlay[0],true,false,false,false,false) then exit; + end; + if (gMRIcroOverlay[kBGOverlayNum].GlMinUnscaledS < 0) or (gMRIcroOverlay[kBGOverlayNum].GlMaxUnscaledS > 4096) then begin + showmessage('Error: you need to load a Siemens format Phase map with raw values in the range 0..4096'); + exit; + end; + lTE1 := ReadFloatForm.GetFloat('Please enter the first TE (ms) used for phasemap. ', 0,5.19,9999); + lTE2 := ReadFloatForm.GetFloat('Please enter the second TE (ms) used for phasemap. ', 0,7.65,9999); + (*lStr := floattostr(5.19); //use floattostr for local decimal separator + if not InputQuery('TEs used to create phasemap','Please enter the first TE in ms', lStr) then + exit; + try + lTE1 := strtofloat(lStr); + except + showmessage('Unable to convert the string '+lStr+' to a number'); + exit; + end; + lStr := floattostr(7.65); + if not InputQuery('TEs used to create phasemap','Please enter the second TE in ms', lStr) then + exit; + try + lTE2 := strtofloat(lStr); + except + showmessage('Unable to convert the string '+lStr+' to a number'); + exit; + end; *) + if lTE1 = lTE2 then begin + showmessage('In order to compute Rad/S the two TEs must be different.'); + exit; + end; + //fx(lTE1,lTE2); + //exit; +//the fieldmap is simply a phase +//difference image and is not scaled to any particular units. In Siemens +//phase images the data goes from 0 to 4095 with 0 being -pi radians, 2048 +//is 0 radians, and 4095 is just short of +pi radians. + //So, to get units of radians/s you would need to know the difference in + //echo times (dTE) in units of s (not ms). You would then take + //(x-2048)(2pi/4096)/dTE +//Note ignore original intercept and scale values + //ldTE := abs(5.19 - 7.65)/1000; // div 1000 to scale ms to sec + ldTE := abs(lTE1 - lTE2)/1000; // div 1000 to scale ms to sec + lScale := (2*pi/4096)/ldTE; + //showmessage(floattostr(lScale)); + rescaleImg(-2048,lScale); +end; + +procedure TImgForm.Brainmask1Click(Sender: TObject); +var + lInc: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a background image for rescaling.'); + exit; + end; + //lImgSamples := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + for lInc := 1 to gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lInc] <> 0 then + gMRIcroOverlay[kBGOverlayNum].ScrnBuffer[lInc] := 1; + SaveAsVOIorNIFTI(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems,1,1,true,gMRIcroOverlay[kBGOverlayNum].NiftiHdr,gMRIcroOverlay[kVOIOverlayNum].HdrFileName); +end; + + + + + +procedure TImgForm.MirrorNII1Click(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + Showmessage('WARNING: This will flip the images in the Left-Right dimension: this has serious consequences'); + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileextX(lFilename,'lr.nii.gz'); + //zap + //showmessage(lFilename); + if MirrorImgBuffer (gMRIcroOverlay[kBGOverlayNum] ) then begin + //showmessage(lFilename); + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + end; + CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end; + +procedure TImgForm.MagPanelClick(Sender: TObject); +var + lM: TMouse; + lB: boolean; + lX,lW: integer; +begin + lW := MagPanel.width; + +(*jULY2008 lM:= TMouse.Create; + lX := lM.CursorPos.X- ImgForm.Left; //position relative to window + if (lW > 1) and (lX > 1) and ((lX/lW) > 0.5) then + FormMouseWheelUp(nil,[],lM.CursorPos,lB) + else + FormMouseWheelDown(nil,[],lM.CursorPos,lB); + *) + {Case SelectedImageNum of + 3: IncViewEdit(YViewEdit); + 2: IncViewEdit(XViewEdit); + else IncViewEdit(ZViewEdit); + end;} +end; + +procedure TImgForm.FillBtnClick(Sender: TObject); +var + lX,lY,lPanel: integer; + lBuffer: ByteP; + lImage: TImage; +begin + if FillBtn.GroupIndex <> 0 then begin + RefreshImagesTimer.Enabled := true; + exit; + end; + lPanel := SelectedImageNum; + SelectPanel(lPanel); + WriteUndoVOI(lPanel,false);//false -write undo and draw + lX := DrawImg.Width; + lY := DrawImg.Height; + Scrn2VOI (DrawImg,lX,lY, lBuffer); + BorderFill(lBuffer,kVOI8Bit, lY,lX); + ImgForm.SetDimension8(lY,lX, lBuffer,false); + freemem(lBuffer); + if lPanel = 3 then lImage:= PGImageCor + else if lPanel = 2 then lImage:= PGImageSag + else lImage:= PGImageAx; + ReadScrnVOI (lImage); +end; + +procedure TImgForm.Blackborders1Click(Sender: TObject); +begin + if not blackborders1.checked then begin + ImgForm.Color := clBlack; + //ImgForm.Font.Color := clWhite; + end else begin + ImgForm.Color := clBtnFace;//clButtonFace; + //ImgForm.Font.Color := clWindowText; + + end; + RenderForm.Color := ImgForm.Color; + //RenderForm.Font.Color := ImgForm.Font.Color; + MultiSliceForm.Color := ImgForm.Color; + //MultiSliceForm.Font.Color := ImgForm.Font.Color; + //CutoutForm.Color := ImgForm.Color; + //CutoutForm.Font.Color := ImgForm.Font.Color; + blackborders1.checked := not blackborders1.checked; +end; + +procedure TImgForm.Applyclusterthreshold1Click(Sender: TObject); +var + lNumberofFiles,lC,lClusterSz: integer; + lThresh: double; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select NIfTI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + lClusterSz := ReadIntForm.GetInt('Minimum cluster size [in voxels]: ', 1,32,9999); + lThresh := ReadFloatForm.GetFloat('Include voxels with an intensity above: ', 0,2,9999); + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileprefix(lFilename,'I'+inttostr(round(lThresh))+'C'+inttostr(lClusterSz)); + //lFilename := changefileextX(lFilename,'I'+inttostr(round(lThresh))+'C'+inttostr(lClusterSz)+'.nii.gz'); + if ClusterFilterScrnImg (gMRIcroOverlay[kBGOverlayNum],lClusterSz,lThresh ) then + if ImgVaries(gMRIcroOverlay[kBGOverlayNum]) then + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr) + else + showmessage('No clusters survive filter '+ HdrForm.OpenHdrDlg.Files[lC-1]); + ProgressBar1.Position := lC; + end; + if fileexistsEX(lFilename) then + ImgForm.OpenAndDisplayImg(lFilename,True); + ProgressBar1.Position := 0; +end; + +procedure TImgForm.Batchprobmaps1Click(Sender: TObject); +begin + BatchVOI; +end; + +procedure TImgForm.ExportasRGBAnalyzeimage1Click(Sender: TObject); +var + lFlip: boolean; +begin + lFlip := gBGImg.Mirror; + gBGImg.Mirror := true; + CreateAnaRGB; + gBGImg.Mirror := lFlip; + +end; + +procedure TImgForm.PGImageSagDblClick(Sender: TObject); +begin + if Graph4DForm.visible then + Graph4DForm.RefreshBtn.click; +end; + +procedure TImgForm.Resliceimage1Click(Sender: TObject); +//use dcm2nii for this function +begin + ResliceFSL; +end; + +procedure TImgForm.Batchclusterprobmaps1Click(Sender: TObject); +begin + BatchCluster; +end; + +function Img2Txt (lFilename: string): boolean; +var + lF: textfile; + lZ,lY,lX,lXDim,lYDim,lZDim,lPos: integer; +begin + result := false; + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + if (lXDim < 1) or (lYDim < 1) or (lZDim < 1) then + exit; + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> (lXDim*lYDim*lZDim) then + exit; + if fileexists (lFilename) then begin + Showmessage('Problem: there is already a file named '+lFilename); + exit; + end; + //Filemode := 2;//random access + Filemode := 0; + AssignFile(lF, lFilename); + rewrite(lF); + Writeln(lF, '#Min '+inttostr(1)+' '+inttostr(1)+' '+inttostr(1)); + Writeln(lF, '#Max '+inttostr(lXDim)+' '+inttostr(lYDim)+' '+inttostr(lZDim)); + lPos := 0; + for lZ := 1 to lZdim do begin + for lY := 1 to lYdim do begin + for lX := 1 to lXdim do begin + inc(lPos); + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lPos] <> 0 then + Writeln(lF, inttostr(lX)+' '+inttostr(lY)+' '+inttostr(lZ)); + end;//lX + end;//lY + end;//lZ + CloseFile(lF); (**) + result := true; +end; //Img2Txt + +procedure TImgForm.VOI2TextClick(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFilename: string; +begin + CloseImagesClick(nil); + if not OpenDialogExecute('VOI Drawings (.VOI)|*.VOI','Select VOI format images to convert',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + ProgressBar1.Min := 0; + ProgressBar1.Max :=lNumberofFiles; + ProgressBar1.Position := 0; + for lC:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lC-1]; + if ImgForm.OpenAndDisplayImg(lFilename,True) then begin + //SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ScrnBuffer,gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems, 1,1,lNiftiHdr); + lFilename := ChangeFileExtX(lFilename,'.txt'); + Img2Txt(lFilename); + end; + CloseImagesClick(nil); + //CloseVOIClick(nil); + ProgressBar1.Position := lC; + end; + ProgressBar1.Position := 0; +end;//VOI->Text + + +procedure TImgForm.AdjustimagessoVOIintensityiszero1Click(Sender: TObject); +begin + BatchChangeInterceptSoVOIEqualsZero; +end; + +procedure TImgForm.ResizeControlPanel (lRows: integer); +begin + if lRows = 2 then begin + ControlPanel.Tag := 2; + LayerPanel.Top := 36; + LayerPanel.Left := 1; + ToolPanel.Left := 292; + ControlPanel.Height := 72; + + HideROIBtn.left := 226; + XBarBtn.Left := 258; + end else begin + ControlPanel.Tag := 1; + LayerPanel.Top := 0; + LayerPanel.Left := 226; + HideROIBtn.left := 680; + XBarBtn.Left := 712; + + ToolPanel.Left := 746; + ControlPanel.Height := 34; + end; +end; + +procedure TImgForm.ControlPanelDblClick(Sender: TObject); +begin + if ControlPanel.Tag = 1 then + ResizeControlPanel(2) + else + ResizeControlPanel(1); + ImgForm.RefreshImagesTimer.enabled := true; +end; + +procedure TImgForm.DefaultControlPanel; +begin + if gBGImg.SingleRow then begin + ResizeControlPanel(1); + ImgForm.Width := 924; + ImgForm.Height := 469; + end else begin + ResizeControlPanel(2); + ImgForm.Width := 460; + ImgForm.Height := 640; + end; +end; + +procedure TImgForm.RotateMenuClick(Sender: TObject); +begin + RotationForm.show; +end; + + +procedure TImgForm.DilateVOIs1Click(Sender: TObject); +begin + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + MakeShells; + exit; + + end else if (ssCtrl in KeyDataToShiftState(vk_Shift)) then + BatchDilate + else begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems= 0 then begin + Showmessage('You need to create a VOI before you can save it.'); + exit; + end; + CreateUndoVol;//create gBGImg.VOIUndoVol + DilateVOI(1, gBGImg.VOIUndoVol); + gBGImg.VOIchanged := true; + + UndoVolVOI; + ImgForm.RefreshImagesTimer.Enabled := true; + end; + // DilateOpenVOI(10,true); + +end; + +procedure TImgForm.Nudge2D(Sender: TObject); +var lSliceStart,lSliceEnd,lVolVox,lPos,lShift: integer; +begin + if gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems=0 then begin + showmessage('You must have open a background image in order to apply an intensity filter (use File/Open).'); + exit; + end; + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + CreateUndoVol;//create gBGImg.VOIUndoVol + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + lVolVox := gBGImg.ScrnDim[1]* gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]; + case (Sender as TMenuItem).tag of + 0: lShift := 1; + 1: lShift := -1; + 2: lShift := gBGImg.ScrnDim[1]; + 3: lShift := -gBGImg.ScrnDim[1]; + 4: lShift := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + else {5} lShift := -gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]; + end; + lSliceStart := ((ZviewEdit.asinteger-1) * ( gBGImg.ScrnDim[1]* gBGImg.ScrnDim[2]))+1; + lSliceEnd := lSliceStart + (gBGImg.ScrnDim[1]* gBGImg.ScrnDim[2]); + if (lSliceEnd > lVolVox) or (lSliceStart < 1) then + exit; + //lSliceOffset := ((XviewEdit.value-1) * SliceVox)+1 + if lShift > 0 then begin + for lPos := lSliceStart to (lSliceEnd-lShift) do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := gBGImg.VOIUndoVol[lPos+lShift]; + end else begin + for lPos := (lSliceStart+abs(lShift)) to lSliceEnd do + gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := gBGImg.VOIUndoVol[lPos+lShift]; + end; + //caption := inttostr(random(888))+' '+inttostr(lShift); + gBGImg.VOIchanged := true; + ImgForm.ProgressBar1.Position := 0; + ImgForm.RefreshImagesTimer.Enabled := true; +end; + + +procedure TImgForm.Interpolate1Click(Sender: TObject); +begin + ROISliceInterpolate (gMRIcroOverlay[kBGOverlayNum]); + RescaleImagesTimer.Enabled := true; +end; + +procedure LoadAll (lFilename: string; lBytes: integer; var lB: bytep); +var + lF: File; +begin + getmem(lB,lBytes ); + AssignFile(lF, lFilename); + FileMode := 0; { Set file access to read only } + Reset(lF, 1); + BlockRead(lF,lB^,lBytes); + CloseFile(lF); + FileMode := 2; + +end; + + +var + gSz: singlep; +procedure Copy2; +var + lVox,lI: integer; + l32SrcBuff: SingleP; +begin + + lVox := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]; + getmem(gSz,lVox*4); + l32SrcBuff := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer); + for lI := 1 to lVox do + if gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lI] <> 0 then + gSz^[lI] := l32SrcBuff^[lI] + else + gSz^[lI] := 0; + ImgForm.caption := 'Copied to RAM'; +end; + +procedure CopyFrom; +var + lVox,lI: integer; + l32SrcBuff: SingleP; +begin + lVox := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]*gBGImg.ScrnDim[3]; + l32SrcBuff := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer); + for lI := 1 to lVox do + if gSz^[lI] <> 0 then + l32SrcBuff^[lI] := {l32SrcBuff^[lI]+}gSz^[lI]; + ImgForm.caption := 'Copied from RAM'; + ImgForm.RefreshImagesTimer.Enabled := true; + +end; + +procedure TImgForm.SaveSmooth1Click(Sender: TObject); +begin + if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + Copy2; + end else + CopyFrom; +end; //VOImaskClick +(*procedure TImgForm.SaveSmooth1Click(Sender: TObject); +function OK (lV,lMax: integer):boolean; +begin + if (lV < 2) or (lV >= lMax) then + result := false + else + result := true; +end; +function Empty (lP: integer): boolean; +begin + result := (gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lP]= 0); +end; +var lVolItems,lPos,lX,lY,lZ: integer; + lXok,lYOK,lZOK: boolean; +begin + lVolItems := gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]* gBGImg.ScrnDim[3]; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lVolItems) or (gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems <> lVolItems) then begin + Showmessage('VOI fill requires a VOI loaded onto a background image (Draw/Open).'); + exit; + end; + CreateUndoVol; + lPos := 0; + for lZ := 1 to gBGImg.ScrnDim[3] do begin + lZOK := OK(lZ,gBGImg.ScrnDim[3]); + for lY := 1 to gBGImg.ScrnDim[2] do begin + lYOK := OK(lY,gBGImg.ScrnDim[2]); + for lX := 1 to gBGImg.ScrnDim[1] do begin + lXOK := OK(lX,gBGImg.ScrnDim[1]); + inc(lPos); + if (Empty(lPos)) and (lXOK) and (lYOK) and (lZOK) then begin + //x CountCluster(lPos); + end; + end; + end; + end; + //gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer[lPos] := 0; + RefreshImagesTimer.Enabled := true; +end; //ROIcomparisonClick + +(*procedure TImgForm.SaveSmooth1Click(Sender: TObject); +var + lF: File; + lLname,lSname: string; + lVox,lSo,lLo,lVol,lI,lnVol,lOffset,lLbytespervol,lSbytespervol: integer; + lLb,lSb: bytep; +begin + lSName := 'C:\walker\TPM.nii'; + lLName := 'C:\walker\TPMX.nii'; + lSbytespervol := 121*145*121*4; //X*Y*Z*bytespervoxel + lLbytespervol := 121*145*199*4; //X*Y*Z*bytespervoxel + lOffset := 352; + lnVol := 6; + LoadAll (lSname,lOffset + (lnVol *lSbytespervol ),lSb); + LoadAll (lLname,lOffset + (lnVol *lLbytespervol ),lLb); + lSo := lOffset; + lLo := lOffset+ (lLbytespervol-lSbytespervol); + for lVol := 1 to lnVol do begin + for lVox := 1 to lSbytespervol do + lLb^[lLo+lVox] := lSb^[lSo+lVox]; + lSo := lSo + lSbytespervol; + lLo := lLo + lLbytespervol; + + end; + //fx( lOffset + (lnVol *lLbytespervol )); + AssignFile(lF, 'C:\shit.nii'); + Rewrite(lF,1); + BlockWrite(lF, lLb^, lOffset + (lnVol *lLbytespervol )); + CloseFile(lF); + freemem(lSb); + freemem(lLb); + +end; + +(*procedure TImgForm.SaveSmooth1Click(Sender: TObject); +var + lBGname,lmaskname: string; + lI: integer; + lB: bytep; +begin + if gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems < 1 then begin + showmessage('Please load a VOI drawing.'); + exit; + end; + lBGname := gMRIcroOverlay[kBGOverlayNum].HdrFileName; + lmaskname := ChangeFilePrefix(lBGname,'m'); + lmaskname := changefileext(lmaskname, '.nii'); + if (fileexists(lmaskname)) then begin + showmessage ('Files already exist named '+lmaskname); + exit; + end; + ImgForm.StatusLabel.caption := 'Saving mask as '+lmaskname; + getmem(lB,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems); + for lI := 1 to gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems do + if gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^[lI] = 0 then + lB^[lI] := 1 + else + lB^[lI] := 0; + SaveAsVOIorNIFTIcore (lmaskname, lB,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + ImgForm.StatusLabel.caption := 'Saving mask as '+lmaskname; + freemem(lB); +end;*) + +function ExtX (lItem: integer): string; +var + lLen,lPos,lI,lDelim,lEnd : Integer; + lFilt: string; +begin + lFilt := ImgForm.SaveDialog1.Filter; + result := ''; + //There is one | before each item, and one after + //therefore, the 2nd item will be preceded by 3 |s + lDelim := lItem * 2 - 1; + lI := 0; + lLen := length(lFilt); + lPos := 1; + while (lI < lDelim) and (lPos <= lLen) do begin + if lFilt[lPos] = '|' then + inc(lI); + inc(lPos); + end; + if lPos >= lLen then + exit; + while (lPos <= lLen) and (lFilt[lPos] <> '|') do begin + if lFilt[lPos] <> '*' then + result := result + lFilt[lPos]; + inc(lPos); + end; +end; + +procedure TImgForm.SetSaveDlgFileExt; +var + Fn: string; +begin + Fn := ExtractFilename(SaveDialog1.FileName); + Fn:=ChangeFileExtX(Fn,ExtX(SaveDialog1.FilterIndex)); + SaveDialog1.FileName := Fn; + //showmessage('666'+Fn); +end; + +procedure TImgForm.SaveDialog1TypeChange(Sender: TObject); +var + Fn : String; +const + CB_FILENAME_ID = 1148; +begin + Fn := ExtractFilename(SaveDialog1.FileName); + Fn:=ChangeFileExtX(Fn,ExtX(SaveDialog1.FilterIndex)); + //Not sure if LongInt cast for string is 64-bit safe... + SendMessage( GetParent(SaveDialog1.Handle), CDM_SETCONTROLTEXT, CB_FILENAME_ID, LongInt(Pchar(Fn))); +end; + +procedure TImgForm.Landmarks1Click(Sender: TObject); +begin + AnatForm.show; +end; + +procedure TImgForm.Extract1Click(Sender: TObject); +var + lMin : smallint; + lnVox,lVox,lDilate,lOtsuLevels: integer; + lOneContiguousObject : boolean; + l16Buf : SmallIntP; + l32Buf : SingleP; + lMinS: single; +begin + lnVox := gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems; + if lnVox < 9 then begin + showmessage('Please load a background image.'); + exit; + end; + lOtsuLevels := ReadIntForm.GetInt('Otsu levels: larger values for larger volumes',1,5,5); + lDilate := ReadIntForm.GetInt('Edge dilation voxels: larger values for larger volumes',0,2,12); + lOneContiguousObject := OKMsg('Only extract single largest object?'); + MaskBackground(gMRIcroOverlay[kBGOverlayNum].ScrnBuffer, gBGImg.ScrnDim[1],gBGImg.ScrnDim[2],gBGImg.ScrnDim[3],lOtsuLevels,lDilate,lOneContiguousObject); + //ExtractTexture (gTexture3D, lOtsuLevels, lDilate, lOneContiguousObject); + + if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 4) then begin + l32Buf := SingleP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + lMinS := l32Buf^[1]; + for lVox := 1 to lnVox do + if l32Buf^[lVox] < lMinS then + lMinS := l32Buf^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + l32Buf^[lVox] := lMinS; + end else if (gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(gMRIcroOverlay[kBGOverlayNum].ImgBuffer ); + lMin := l16Buf^[1]; + for lVox := 1 to lnVox do + if l16Buf^[lVox] < lMin then + lMin := l16Buf^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + l16Buf^[lVox] := lMin; + end else if gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP = 1 then begin + lMin := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[1]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox] < lMin then + lMin := gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox]; + for lVox := 1 to lnVox do + if gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lVox] = 0 then + gMRIcroOverlay[kBGOverlayNum].ImgBuffer^[lVox] := lMin; + + end; +end; + + +procedure TImgForm.AcceptLandmark1Click(Sender: TObject); +begin + AnatForm.AcceptLandmark; +end; + +procedure TImgForm.Batchlandmarks1Click(Sender: TObject); +begin + AnatForm.BatchLandmarks; +end; + +procedure TImgForm.ToggleDrawMenu(Sender: TObject); +begin + gBGImg.ShowDraw := not DrawMenu.Visible; + WriteIni2Form(gBGImg); +end; + +initialization + {$IFNDEF UNIX} + Set8087CW($133F); //Windows 64-bit can generate spurious FPU exceptions + {$ENDIF} + OleInitialize(nil); + for gMouseDownY := 0 to knMaxOverlay do + gMRIcroOverlay[gMouseDownY].index := gMouseDownY; //RGB + +finalization + OleUninitialize +end. diff --git a/niftiview7/nifti_types.pas b/niftiview7/nifti_types.pas new file mode 100755 index 0000000..8ff9c38 --- /dev/null +++ b/niftiview7/nifti_types.pas @@ -0,0 +1,142 @@ +unit nifti_types; + +interface + +type + TNIFTIhdr = packed record //Next: analyze Format Header structure + HdrSz : longint; //MUST BE 348 + Data_Type: array [1..10] of char; //unused + db_name: array [1..18] of char; //unused + extents: longint; //unused + session_error: smallint; //unused ` + regular: char; ////unused: in Analyze 7.5 this must be 114 + dim_info: byte; //MRI slice order + dim: array[0..7] of smallint; //Data array dimensions + intent_p1, intent_p2, intent_p3: single; + intent_code: smallint; + datatype: smallint; + bitpix: smallint; + slice_start: smallint; + pixdim: array[0..7]of single; + vox_offset: single; + scl_slope: single;//scaling slope + scl_inter: single;//scaling intercept + slice_end: smallint; + slice_code: byte; //e.g. ascending + xyzt_units: byte; //e.g. mm and sec + cal_max,cal_min: single; //unused + slice_duration: single; //time for one slice + toffset: single; //time axis to shift + glmax, glmin: longint; //UNUSED + descrip: array[1..80] of char; + aux_file: array[1..24] of char; + qform_code, sform_code: smallint; + quatern_b,quatern_c,quatern_d, + qoffset_x,qoffset_y,qoffset_z: single; + srow_x: array[0..3]of single; + srow_y: array[0..3]of single; + srow_z: array[0..3]of single; + intent_name: array[1..16] of char; + magic: longint; + end; //TNIFTIhdr Header Structure + TAnalyzeHdrSection = packed record //Next: analyze Format Header structure + Pad: array [1..253] of byte; + originator: array [1..5] of smallint; (* 105 + 10 *) +end;//TAnalyzeHdrSection Structure + +const +kDT_BINARY =1; // binary (1 bit/voxel) +kDT_UNSIGNED_CHAR =2; // unsigned char (8 bits/voxel) +kDT_UINT8 = kDT_UNSIGNED_CHAR; +kDT_SIGNED_SHORT =4; // signed short (16 bits/voxel) +kDT_INT16 = kDT_SIGNED_SHORT; +kDT_SIGNED_INT =8; // signed int (32 bits/voxel) +kDT_INT32 = kDT_SIGNED_INT; +kDT_FLOAT =16; // float (32 bits/voxel) +kDT_FLOAT32 = kDT_FLOAT; +kDT_COMPLEX =32; // complex (64 bits/voxel) +kDT_DOUBLE =64; // double (64 bits/voxel) +kDT_RGB =128; // RGB triple (24 bits/voxel) +kDT_INT8 =256; // signed char (8 bits) +kDT_UINT16 =512; // unsigned short (16 bits) +kDT_UINT32 =768; // unsigned int (32 bits) +kDT_INT64 =1024; // long long (64 bits) +kDT_UINT64 =1280; // unsigned long long (64 bits) +kDT_FLOAT128 =1536; // long double (128 bits) +kDT_COMPLEX128 =1792; // double pair (128 bits) +kDT_COMPLEX256 =2048; // long double pair (256 bits) +// slice_code values + kNIFTI_SLICE_SEQ_UNKNOWN = 0; + kNIFTI_SLICE_SEQ_INC = 1; + kNIFTI_SLICE_SEQ_DEC = 2; + kNIFTI_SLICE_ALT_INC = 3; + kNIFTI_SLICE_ALT_DEC = 4; +//xyzt_units values: note 3bit space and 3bit time packed into single byte + kNIFTI_UNITS_UNKNOWN = 0; + kNIFTI_UNITS_METER = 1; + kNIFTI_UNITS_MM = 2; + kNIFTI_UNITS_MICRON = 3; + kNIFTI_UNITS_SEC = 8; + kNIFTI_UNITS_MSEC = 16; + kNIFTI_UNITS_USEC = 24; + kNIFTI_UNITS_HZ = 32; + kNIFTI_UNITS_PPM = 40; + //qform_code, sform_code values + kNIFTI_XFORM_UNKNOWN = 0; + kNIFTI_XFORM_SCANNER_ANAT = 1;//Scanner-based anatomical coordinates + kNIFTI_XFORM_ALIGNED_ANAT = 2; //Coordinates aligned to another file e.g. EPI coregistered to T1 + kNIFTI_XFORM_TALAIRACH = 3; //Talairach-Tournoux Atlas; (0,0,0)=AC, etc. + kNIFTI_XFORM_MNI_152 = 4; //MNI 152 normalized coordinates + //Magic values + kNIFTI_MAGIC_SEPARATE_HDR = $0031696E;//$6E693100; + kNIFTI_MAGIC_EMBEDDED_HDR = $00312B6E;//$6E2B3100; + kNIFTI_MAGIC_DCM = $0044434D; + //byte-swapped magic values + kswapNIFTI_MAGIC_SEPARATE_HDR = $6E693100; + kswapNIFTI_MAGIC_EMBEDDED_HDR = $6E2B3100; + //Statistics Intention + kNIFTI_INTENT_NONE =0; +kNIFTI_INTENT_CORREL =2; +kNIFTI_INTENT_TTEST =3; +kNIFTI_INTENT_FTEST =4; +kNIFTI_INTENT_ZSCORE =5; +kNIFTI_INTENT_CHISQ =6; +kNIFTI_INTENT_BETA =7; +kNIFTI_INTENT_BINOM =8; +kNIFTI_INTENT_GAMMA =9; +kNIFTI_INTENT_POISSON =10; +kNIFTI_INTENT_NORMAL =11; +kNIFTI_INTENT_FTEST_NONC =12; +kNIFTI_INTENT_CHISQ_NONC =13; +kNIFTI_INTENT_LOGISTIC =14; +kNIFTI_INTENT_LAPLACE =15; +kNIFTI_INTENT_UNIFORM =16; +kNIFTI_INTENT_TTEST_NONC =17; +kNIFTI_INTENT_WEIBULL =18; +kNIFTI_INTENT_CHI =19; +kNIFTI_INTENT_INVGAUSS =20; +kNIFTI_INTENT_EXTVAL =21; +kNIFTI_INTENT_PVAL =22; +NIFTI_INTENT_LOGPVAL =23; +NIFTI_INTENT_LOG10PVAL =24; +kNIFTI_LAST_STATCODE = 24;//kNIFTI_INTENT_PVAL; +kNIFTI_INTENT_ESTIMATE =1001; +kNIFTI_FIRST_NONSTATCODE = kNIFTI_INTENT_ESTIMATE; +kNIFTI_INTENT_LABEL =1002; +kNIFTI_INTENT_NEURONAME =1003; +kNIFTI_INTENT_GENMATRIX =1004; +kNIFTI_INTENT_SYMMATRIX =1005; +kNIFTI_INTENT_DISPVECT =1006; +kNIFTI_INTENT_VECTOR =1007; +kNIFTI_INTENT_POINTSET =1008; +kNIFTI_INTENT_TRIANGLE =1009; +kNIFTI_INTENT_QUATERNION =1010; + const + K_gzBytes_headerAndImageCompressed = -2; + K_gzBytes_onlyImageCompressed= -1; + K_gzBytes_headerAndImageUncompressed= 0; + +implementation + +end. + \ No newline at end of file diff --git a/niftiview7/niftifile.ico b/niftiview7/niftifile.ico new file mode 100755 index 0000000..8cb3501 Binary files /dev/null and b/niftiview7/niftifile.ico differ diff --git a/niftiview7/niftisuper.ico b/niftiview7/niftisuper.ico new file mode 100755 index 0000000..15da42e Binary files /dev/null and b/niftiview7/niftisuper.ico differ diff --git a/niftiview7/niftisuper32.ico b/niftiview7/niftisuper32.ico new file mode 100755 index 0000000..5e5fb0a Binary files /dev/null and b/niftiview7/niftisuper32.ico differ diff --git a/niftiview7/niftiview.ico b/niftiview7/niftiview.ico new file mode 100755 index 0000000..8da1d96 Binary files /dev/null and b/niftiview7/niftiview.ico differ diff --git a/niftiview7/nii_label.pas b/niftiview7/nii_label.pas new file mode 100755 index 0000000..b0c39d7 --- /dev/null +++ b/niftiview7/nii_label.pas @@ -0,0 +1,258 @@ +unit nii_label; +{$IFDEF FPC} +{$mode delphi} +{$ENDIF} +interface +uses +{$IFNDEF FPC} + windows, + //gziod, +{$ELSE} + gzio2, +{$ENDIF} + dialogs,Classes, SysUtils, define_types; + +procedure createLutLabel (var lut: TLUT; lSaturationFrac: single); +procedure LoadLabels(lFileName: string; var lLabels: TStrRA; lOffset,lLength: integer); +procedure LoadLabelsTxt(lFileName: string; var lLabels: TStrRA); + +implementation + +procedure LoadLabelsCore(lInStr: string; var lLabels: TStrRA); +var + lIndex,lPass,lMaxIndex,lPos,lLength: integer; + lStr1: string; + lCh: char; +begin + lLabels := nil; + lLength := length(lInStr); + lMaxIndex := -1; + for lPass := 1 to 2 do begin + lPos := 1; + if lPass = 2 then begin + if lMaxIndex < 1 then + exit; + SetLength(lLabels,lMaxIndex+1); + for lIndex := 0 to lMaxIndex do + lLabels[lIndex] := ''; + end; + while lPos <= lLength do begin + lStr1 := ''; + repeat + lCh := lInStr[lPos]; inc(lPos); + if (lCh >= '0') and (lCh <= '9') then + lStr1 := lStr1 + lCh; + until (lPos > lLength) or (lCh=kCR) or (lCh=UNIXeoln) or (((lCh=kTab)or (lCh=' ')) and (length(lStr1)>0)); + if (length(lStr1) > 0) and (lPos <= lLength) then begin + lIndex := strtoint(lStr1); + if lPass = 1 then begin + if lIndex > lMaxIndex then + lMaxIndex := lIndex + end else if lIndex >= 0 then begin //pass 2 + lStr1 := ''; + repeat + lCh := lInStr[lPos]; inc(lPos); + if (lPos > lLength) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab) or (lCh=' ')} then + // + else + lStr1 := lStr1 + lCh; + until (lPos > lLength) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab)or (lCh=' ')}; + lLabels[lIndex] := lStr1; + end; //if pass 2 + end; //if lStr1>0 + end; //while not EOF + end; //for each pass +end; + +procedure LoadLabels(lFileName: string; var lLabels: TStrRA; lOffset,lLength: integer); +var + f : file; // untyped file + s : string; // string for reading a file + sz: int64; + ptr: bytep; +begin + if GzExt(lFilename) then begin + if (lLength < 1) then exit; + SetLength(s, lLength); + ptr := @s[1]; + UnGZip (lFileName,ptr, lOffset,lLength); + end else begin + AssignFile(f, lFileName); + FileMode := fmOpenRead; + reset(f, 1); + if lOffset > 0 then + seek(f, lOffset); + if (lLength < 1) then + sz := FileSize(f)-lOffset + else + sz := lLength; + if (lOffset+sz) > FileSize(f) then + exit; + SetLength(s, sz); + BlockRead(f, s[1], length(s)); + CloseFile(f); + FileMode := fmOpenReadWrite; + end; + LoadLabelsCore(s, lLabels); + //showmessage(lLabels[1]); +end; + +procedure LoadLabelsTxt(lFileName: string; var lLabels: TStrRA); +//filename = 'all.nii' will read 'aal.txt' +var + lLUTname: string; +begin + lLabels := nil; //empty current labels + lLUTname := changefileext(lFileName,'.txt'); + if not Fileexists(lLUTname) then begin + lLUTname := ParseFileName(lFileName)+'.txt'; //file.nii.gz -> file.txt + if not Fileexists(lLUTname) then + exit; + end; + LoadLabels(lLUTname, lLabels,0,-1); +end; + +procedure desaturateRGBA( var lRGBA: TRGBquad; frac: single); +var + r,g,b: byte; + y: single; +begin + r := lRGBA.rgbRed; + g := lRGBA.rgbGreen; + b := lRGBA.rgbBlue; + //convert RGB->YUV http://en.wikipedia.org/wiki/YUV + y := 0.299 * r + 0.587 * g + 0.114 * b; + r := round(y * (1-frac) + r * frac); + g := round(y * (1-frac) + g * frac); + b := round(y * (1-frac) + b * frac); + lRGBA.rgbRed := r; + lRGBA.rgbGreen := g; + lRGBA.rgbBlue := b; +end; + +function makeRGB(r,g,b: byte): TRGBquad; +begin + result.rgbRed := r; + result.rgbGreen := g; + result.rgbBlue := b; + result.rgbReserved := 64; +end; + +procedure createLutLabel (var lut: TLUT; lSaturationFrac: single); //lLUT: 0=gray,1=red,2=green,3=blue +var + i:integer; +begin + lut[0] := makeRGB(0,0,0); + lut[0].rgbReserved:= 0; + lut[1] := makeRGB(71,46,154); + lut[2] := makeRGB(33,78,43); + lut[3] := makeRGB(192,199,10); + lut[4] := makeRGB(32,79,207); + lut[5] := makeRGB(195,89,204); + lut[6] := makeRGB(208,41,164); + lut[7] := makeRGB(173,208,231); + lut[8] := makeRGB(233,135,136); + lut[9] := makeRGB(202,20,58); + lut[10] := makeRGB(25,154,239); + lut[11] := makeRGB(210,35,30); + lut[12] := makeRGB(145,21,147); + lut[13] := makeRGB(89,43,230); + lut[14] := makeRGB(87,230,101); + lut[15] := makeRGB(245,113,111); + lut[16] := makeRGB(246,191,150); + lut[17] := makeRGB(38,147,35); + lut[18] := makeRGB(3,208,128); + lut[19] := makeRGB(25,37,57); + lut[20] := makeRGB(57,28,252); + lut[21] := makeRGB(167,27,79); + lut[22] := makeRGB(245,86,173); + lut[23] := makeRGB(86,203,120); + lut[24] := makeRGB(227,25,25); + lut[25] := makeRGB(208,209,126); + lut[26] := makeRGB(81,148,81); + lut[27] := makeRGB(64,187,85); + lut[28] := makeRGB(90,139,8); + lut[29] := makeRGB(199,111,7); + lut[30] := makeRGB(140,48,122); + lut[31] := makeRGB(48,102,237); + lut[32] := makeRGB(212,76,190); + lut[33] := makeRGB(180,110,152); + lut[34] := makeRGB(70,106,246); + lut[35] := makeRGB(120,130,182); + lut[36] := makeRGB(9,37,130); + lut[37] := makeRGB(192,160,219); + lut[38] := makeRGB(245,34,67); + lut[39] := makeRGB(177,222,76); + lut[40] := makeRGB(65,90,167); + lut[41] := makeRGB(157,165,178); + lut[42] := makeRGB(9,245,235); + lut[43] := makeRGB(193,222,250); + lut[44] := makeRGB(100,102,28); + lut[45] := makeRGB(181,47,61); + lut[46] := makeRGB(125,19,186); + lut[47] := makeRGB(145,130,250); + lut[48] := makeRGB(62,4,199); + lut[49] := makeRGB(8,232,67); + lut[50] := makeRGB(108,137,58); + lut[51] := makeRGB(36,211,50); + lut[52] := makeRGB(140,240,86); + lut[53] := makeRGB(237,11,182); + lut[54] := makeRGB(242,140,108); + lut[55] := makeRGB(248,21,77); + lut[56] := makeRGB(161,42,89); + lut[57] := makeRGB(189,22,112); + lut[58] := makeRGB(41,241,59); + lut[59] := makeRGB(114,61,125); + lut[60] := makeRGB(65,99,226); + lut[61] := makeRGB(121,115,50); + lut[62] := makeRGB(97,199,205); + lut[63] := makeRGB(50,166,227); + lut[64] := makeRGB(238,114,125); + lut[65] := makeRGB(149,190,128); + lut[66] := makeRGB(44,204,104); + lut[67] := makeRGB(214,60,27); + lut[68] := makeRGB(124,233,59); + lut[69] := makeRGB(167,66,66); + lut[70] := makeRGB(40,115,53); + lut[71] := makeRGB(167,230,133); + lut[72] := makeRGB(127,125,159); + lut[73] := makeRGB(178,103,203); + lut[74] := makeRGB(231,203,97); + lut[75] := makeRGB(30,125,125); + lut[76] := makeRGB(173,13,139); + lut[77] := makeRGB(244,176,159); + lut[78] := makeRGB(193,94,158); + lut[79] := makeRGB(203,131,7); + lut[80] := makeRGB(204,39,215); + lut[81] := makeRGB(238,198,47); + lut[82] := makeRGB(139,167,140); + lut[83] := makeRGB(135,124,226); + lut[84] := makeRGB(71,67,223); + lut[85] := makeRGB(234,175,231); + lut[86] := makeRGB(234,254,44); + lut[87] := makeRGB(217,1,110); + lut[88] := makeRGB(66,15,184); + lut[89] := makeRGB(14,198,61); + lut[90] := makeRGB(129,62,233); + lut[91] := makeRGB(19,237,47); + lut[92] := makeRGB(97,159,67); + lut[93] := makeRGB(165,31,148); + lut[94] := makeRGB(112,218,22); + lut[95] := makeRGB(244,58,120); + lut[96] := makeRGB(35,244,173); + lut[97] := makeRGB(73,47,156); + lut[98] := makeRGB(192,61,117); + lut[99] := makeRGB(12,67,181); + lut[100] := makeRGB(149,94,94); + for i := 1 to 100 do + lut[i+100] := lut[i]; //fill 101..200 + for i := 1 to 55 do + lut[i+200] := lut[i]; //fill 201..255 + if (lSaturationFrac < 0) or (lSaturationFrac >= 1.0) then + exit; + for i := 1 to 255 do + desaturateRGBA(lut[i], lSaturationFrac); +end; + +end. + diff --git a/niftiview7/ortho_reorient.pas b/niftiview7/ortho_reorient.pas new file mode 100755 index 0000000..4ea02c5 --- /dev/null +++ b/niftiview7/ortho_reorient.pas @@ -0,0 +1,454 @@ +unit ortho_reorient; +//reorient image to nearest orthogonal plane +interface + +uses + SysUtils,define_types,GraphicsMathLibrary,prefs,nifti_hdr,dialogs, nifti_types; + +function OrthoReorientCore(var lHdr: TMRIcroHdr; l4D: boolean): boolean; + +implementation + + +function NIfTIAlignedM (var lM: TMatrix): boolean; +//check that diagonals are positive and all other cells are zero +//negative diagonals suggests flipping... +//non-negative other cells suggests the image is not pure axial +var + lr,lc: integer; +begin + result := false; + for lr := 1 to 3 do + for lc := 1 to 3 do begin + if (lr = lc) and (lM.matrix[lr,lc] <= 0) then + exit; + if (lr <> lc) and (lM.matrix[lr,lc] <> 0) then + exit; + end; + result := true; +end; + + +function NIfTIAligned (var lHdr: TNIFTIhdr): boolean; +//check that diagonals are positive and all other cells are zero +//negative diagonals suggests flipping... +//non-negative other cells suggests the image is not pure axial +var + lM: TMatrix; +begin + lM := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], + 0,0,0,1); + result := NIfTIAlignedM(lM); +end; + +procedure FromMatrix (M: TMatrix; var m11,m12,m13, m21,m22,m23, + m31,m32,m33: DOUBLE) ; + BEGIN + + m11 := M.Matrix[1,1]; + m12 := M.Matrix[1,2]; + m13 := M.Matrix[1,3]; + m21 := M.Matrix[2,1]; + m22 := M.Matrix[2,2]; + m23 := M.Matrix[2,3]; + m31 := M.Matrix[3,1]; + m32 := M.Matrix[3,2]; + m33 := M.Matrix[3,3]; +END {FromMatrix3D}; + +function nifti_mat44_orthogx( lR :TMatrix): TMatrix; +//returns rotation matrix required to orient image so it is aligned nearest to the identity matrix = +// 1 0 0 0 +// 0 1 0 0 +// 0 0 1 0 +// 0 0 0 1 +//Therefore, image is approximately oriented in space +var + lrow,lcol,lMaxRow,lMaxCol,l2ndMaxRow,l2ndMaxCol,l3rdMaxRow,l3rdMaxCol: integer; + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, val,lAbsmax,lAbs: double; + Q: TMatrix; //3x3 +begin + // load 3x3 matrix into local variables + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + Q := Matrix2D( r11,r12,r13,r21,r22,r23,r31,r32,r33); + // normalize row 1 + val := Q.matrix[1,1]*Q.matrix[1,1] + Q.matrix[1,2]*Q.matrix[1,2] + Q.matrix[1,3]*Q.matrix[1,3] ; + if( val > 0.0 )then begin + val := 1.0 / sqrt(val) ; + Q.matrix[1,1] := Q.matrix[1,1]*val ; + Q.matrix[1,2] := Q.matrix[1,2]*val ; + Q.matrix[1,3] := Q.matrix[1,3]*val ; + end else begin + Q.matrix[1,1] := 1.0 ; Q.matrix[1,2] := 0.0; Q.matrix[1,3] := 0.0 ; + end; + // normalize row 2 + val := Q.matrix[2,1]*Q.matrix[2,1] + Q.matrix[2,2]*Q.matrix[2,2] + Q.matrix[2,3]*Q.matrix[2,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[2,1] := Q.matrix[2,1]* val ; + Q.matrix[2,2] := Q.matrix[2,2] * val ; + Q.matrix[2,3] := Q.matrix[2,3] * val ; + end else begin + Q.matrix[2,1] := 0.0 ; Q.matrix[2,2] := 1.0 ; Q.matrix[2,3] := 0.0 ; + end; + // normalize row 3 + val := Q.matrix[3,1]*Q.matrix[3,1] + Q.matrix[3,2]*Q.matrix[3,2] + Q.matrix[3,3]*Q.matrix[3,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[3,1] := Q.matrix[3,1] *val ; + Q.matrix[3,2] := Q.matrix[3,2] *val ; + Q.matrix[3,3] := Q.matrix[3,3] *val ; + end else begin + Q.matrix[3,1] := Q.matrix[1,2]*Q.matrix[2,3] - Q.matrix[1,3]*Q.matrix[2,2] ; //* cross */ + Q.matrix[3,2] := Q.matrix[1,3]*Q.matrix[2,1] - Q.matrix[1,1]*Q.matrix[2,3] ; //* product */ + Q.matrix[3,3] := Q.matrix[1,1]*Q.matrix[2,2] - Q.matrix[1,2]*Q.matrix[2,1] ; + end; + //next - find closest orthogonal coordinates - each matrix cell must be 0,-1 or 1 + //First: find axis most aligned to a principal axis + lAbsmax := 0; + lMaxRow := 1; + lMaxCol := 1; + for lrow := 1 to 3 do begin + for lcol := 1 to 3 do begin + lAbs := abs(Q.matrix[lrow,lcol]); + if lAbs > lAbsMax then begin + lAbsmax := lAbs; + lMaxRow := lRow; + lMaxCol := lCol; + end; + end; //for rows + end; //for columns + //Second - find find axis that is 2nd closest to principal axis + lAbsmax := 0; + l2ndMaxRow := 2; + l2ndMaxCol := 2; + for lrow := 1 to 3 do begin + for lcol := 1 to 3 do begin + if (lrow <> lMaxRow) and (lCol <> lMaxCol) then begin + lAbs := abs(Q.matrix[lrow,lcol]); + if lAbs > lAbsMax then begin + lAbsmax := lAbs; + l2ndMaxRow := lRow; + l2ndMaxCol := lCol; + end; //new max + end; //do not check MaxRow/MaxCol + end; //for rows + end; //for columns + //next - no degrees of freedom left: third prinicple axis is the remaining axis + if ((lMaxRow = 1) or (l2ndMaxRow = 1)) and ((lMaxRow = 2) or (l2ndMaxRow = 2)) then + l3rdMaxRow := 3 + else if ((lMaxRow = 1) or (l2ndMaxRow = 1)) and ((lMaxRow = 3) or (l2ndMaxRow = 3)) then + l3rdMaxRow := 2 + else + l3rdMaxRow := 1; + if ((lMaxCol = 1) or (l2ndMaxCol = 1)) and ((lMaxCol = 2) or (l2ndMaxCol = 2)) then + l3rdMaxCol := 3 + else if ((lMaxCol = 1) or (l2ndMaxCol = 1)) and ((lMaxCol = 3) or (l2ndMaxCol = 3)) then + l3rdMaxCol := 2 + else + l3rdMaxCol := 1; + //finally, fill in our rotation matrix + //cells in the canonical rotation transform can only have values 0,1,-1 + result := Matrix3D( 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0); + if Q.matrix[lMaxRow,lMaxCol] < 0 then + result.matrix[lMaxRow,lMaxCol] := -1 + else + result.matrix[lMaxRow,lMaxCol] := 1; + + if Q.matrix[l2ndMaxRow,l2ndMaxCol] < 0 then + result.matrix[l2ndMaxRow,l2ndMaxCol] := -1 + else + result.matrix[l2ndMaxRow,l2ndMaxCol] := 1; + + if Q.matrix[l3rdMaxRow,l3rdMaxCol] < 0 then + result.matrix[l3rdMaxRow,l3rdMaxCol] := -1 + else + result.matrix[l3rdMaxRow,l3rdMaxCol] := 1; +end; + + +FUNCTION QuickInvertMatrix3D (CONST Input:TMatrix): TMatrix; +//http://www.cellperformance.com/articles/2006/06/a_4x4_matrix_inverse_1.html +//Most of the time in the video games, programmers are not doing a standard inverse matrix. +//It is too expensive. Instead, to inverse a matrix, they consider it as orthonormal +//and they just do a 3x3 transpose of the rotation part with a dot product for the translation. +//Sometimes the full inverse algorithm is necessary.... +var + i,j: integer; +begin + result.size := Input.size; + for i := 1 to 3 do + for j := 1 to 3 do + result.matrix[i,j] := input.matrix[j,i]; + //next - fill in edge if 3D + if result.size <> size3D then + exit; //do not fill in final column for 2D matrices + for i := 1 to 3 do + result.matrix[4,i] := 0; + for i := 1 to 3 do + result.matrix[i,4] := 0; + result.matrix[4,4] := 1; +end; + +procedure FindMatrixPt (lX,lY,lZ: single; var lXout,lYOut,lZOut: single; var lMatrix: TMatrix); +begin + lXOut := (lX*lMatrix.matrix[1,1])+(lY*lMatrix.matrix[1,2])+(lZ*lMatrix.matrix[1,3])+lMatrix.matrix[1,4]; + lYOut := (lX*lMatrix.matrix[2,1])+(lY*lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[2,3])+lMatrix.matrix[2,4]; + lZOut := (lX*lMatrix.matrix[3,1])+(lY*lMatrix.matrix[3,2])+(lZ*lMatrix.matrix[3,3])+lMatrix.matrix[3,4]; +end; + +procedure CheckMin(var lX,lY,lZ,lXMin,lYMin,lZMin: single); +begin + if lX < lXMin then lXMin := lX; + if lY < lYMin then lYMin := lY; + if lZ < lZMin then lZMin := lZ; +end; + +procedure Mins (var lMatrix: TMatrix; var lHdr: TNIFTIhdr; var lXMin,lYMin,lZMin: single); +var + lPos,lXc,lYc,lZc: integer; + lx,ly,lz: single; +begin + FindMatrixPt(0,0,0,lX,lY,lZ,lMatrix); + lXMin := lX; + lYMin := lY; + lZMin := lZ; + for lPos := 1 to 7 do begin + if odd(lPos) then + lXc := lHdr.Dim[1]-1 + else + lXc := 0; + if odd(lPos shr 1) then + lYc := lHdr.Dim[2]-1 + else + lYc := 0; + if odd(lPos shr 2) then + lZc := lHdr.Dim[3]-1 + else + lZc := 0; + FindMatrixPt(lXc,lYc,lZc,lX,lY,lZ,lMatrix); + CheckMin(lX,lY,lZ,lXMin,lYMin,lZMin); + end; +end; + +(*procedure ReportMatrix (lM:TMatrix); +const + kCR = chr (13); +begin + showmessage(RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+kCR+ + RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+kCR+ + RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+kCR + +RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6) + ); +end;*) + + +function OrthoReorientCore(var lHdr: TMRIcrohdr; l4D: boolean): boolean; +var + //lF: File; + lOutHdr: TNIFTIhdr; + lOutName: string; + lResidualMat: TMatrix; + lInMinX,lInMinY,lInMinZ,lOutMinX,lOutMinY,lOutMinZ, + dx, dy, dz, QFac: single; + lStartX,lStartY,lStartZ, + lZ,lY,lX,lB, + lOutZ,lOutY, + lXInc, lYInc, lZInc,lBPP,lVol,lnVol: integer; + lInPos,lVolBytes,lOutPos,lInOffset: integer; + lBufferOut: bytep; + lByteSwap,lFlipX,lFlipY,lFlipZ: boolean; + lInMat,lRotMat: TMatrix; +begin + result := false; + if {(lhdr.NIfTIhdr.dim[4] > 1) or} (lhdr.NIfTIhdr.dim[3] < 2) then begin + //Showmessage('Can only orient 3D images '+inttostr(lhdr.NIfTIhdr.dim[3])+' '+inttostr(lhdr.NIfTIhdr.dim[4])); + exit; + end; + if (lHdr.ImgBufferItems < lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]*lhdr.NIfTIhdr.dim[3]) then + exit; + lInMat := Matrix3D ( + lhdr.NIfTIhdr.srow_x[0],lhdr.NIfTIhdr.srow_x[1],lhdr.NIfTIhdr.srow_x[2],lhdr.NIfTIhdr.srow_x[3], + lhdr.NIfTIhdr.srow_y[0],lhdr.NIfTIhdr.srow_y[1],lhdr.NIfTIhdr.srow_y[2],lhdr.NIfTIhdr.srow_y[3], + lhdr.NIfTIhdr.srow_z[0],lhdr.NIfTIhdr.srow_z[1],lhdr.NIfTIhdr.srow_z[2],lhdr.NIfTIhdr.srow_z[3], + 0,0,0,1); + //ReportMatrix(lInMat); + if (NIfTIAlignedM (lInMat)) then begin + //Msg('According to header, image is already canonically oriented'); + + exit; + end; + + + lRotMat := nifti_mat44_orthogx( lInMat); + if NIfTIAlignedM (lRotMat) then begin + //Msg('According to header, image is already approximately canonically oriented'); + exit; //already as close as possible + end; + lOutHdr := lHdr.NIFTIhdr; + //Some software uses negative pixdims to represent a spatial flip - now that the image is canonical, all dimensions are positive + lOutHdr.pixdim[1] := abs(lhdr.NIfTIhdr.pixdim[1]); + lOutHdr.pixdim[2] := abs(lhdr.NIfTIhdr.pixdim[2]); + lOutHdr.pixdim[3] := abs(lhdr.NIfTIhdr.pixdim[3]); + //sort out dim1 + lFlipX := false; + if lRotMat.Matrix[1,2] <> 0 then begin + lXinc := lhdr.NIfTIhdr.dim[1]; + lOutHdr.dim[1] := lhdr.NIfTIhdr.dim[2]; + lOutHdr.pixdim[1] := abs(lhdr.NIfTIhdr.pixdim[2]); + if lRotMat.Matrix[1,2] < 0 then lFlipX := true + end else if lRotMat.Matrix[1,3] <> 0 then begin + lXinc := lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]; + lOutHdr.dim[1] := lhdr.NIfTIhdr.dim[3]; + lOutHdr.pixdim[1] := abs(lhdr.NIfTIhdr.pixdim[3]); + if lRotMat.Matrix[1,3] < 0 then lFlipX := true + end else begin + lXinc := 1; + if lRotMat.Matrix[1,1] < 0 then lFlipX := true + end; + //sort out dim2 + lFlipY := false; + if lRotMat.Matrix[2,2] <> 0 then begin + lYinc := lhdr.NIfTIhdr.dim[1]; + //lOutHdr.dim[2] := lhdr.NIfTIhdr.dim[2]; + //lOutHdr.pixdim[2] := lhdr.NIfTIhdr.pixdim[2]; + if lRotMat.Matrix[2,2] < 0 then lFlipY := true + end else if lRotMat.Matrix[2,3] <> 0 then begin + lYinc := lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]; + lOutHdr.dim[2] := lhdr.NIfTIhdr.dim[3]; + lOutHdr.pixdim[2] := abs(lhdr.NIfTIhdr.pixdim[3]); + if lRotMat.Matrix[2,3] < 0 then lFlipY := true + end else begin + lYinc := 1; + lOutHdr.dim[2] := lhdr.NIfTIhdr.dim[1]; + lOutHdr.pixdim[2] := abs(lhdr.NIfTIhdr.pixdim[1]); + if lRotMat.Matrix[2,1] < 0 then lFlipY := true + end; + //sort out dim3 + lFlipZ := false; + if lRotMat.Matrix[3,2] <> 0 then begin + lZinc := lhdr.NIfTIhdr.dim[1]; + lOutHdr.dim[3] := lhdr.NIfTIhdr.dim[2]; + lOutHdr.pixdim[3] := lhdr.NIfTIhdr.pixdim[2]; + if lRotMat.Matrix[3,2] < 0 then lFlipZ := true; + end else if lRotMat.Matrix[3,3] <> 0 then begin + lZinc := lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]; + //lOutHdr.dim[3] := lhdr.NIfTIhdr.dim[3]; + //lOutHdr.pixdim[3] := lhdr.NIfTIhdr.pixdim[3]; + if lRotMat.Matrix[3,3] < 0 then lFlipZ := true; + end else begin + lZinc := 1; + lOutHdr.dim[3] := lhdr.NIfTIhdr.dim[1]; + lOutHdr.pixdim[3] := lhdr.NIfTIhdr.pixdim[1]; + if lRotMat.Matrix[3,1] < 0 then lFlipZ := true; + end; + //details for writing... + lBPP := (lhdr.NIfTIhdr.bitpix div 8); //bytes per pixel + if lBPP = 3 then //RGB loaded as 3 planes? + lBPP := 1; + if lBPP > 4 then + lBPP := 4;//64bit data is stored as 32-bit precision June 2009 + lXinc := lXinc * lBPP; + lYinc := lYinc * lBPP; + lZinc := lZinc * lBPP; + lVolBytes := lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]*lhdr.NIfTIhdr.dim[3]*lBPP; + //now write header... + //create Matrix of residual orientation... + lResidualMat := QuickInvertMatrix3D(lRotMat); + //the next steps are inelegant - the translation values are computed by brute force + //at the moment, our lResidualMat looks like this + //lResidualMat = [ 0 -1 0 0; 0 0 1 0; 1 0 0 0; 0 0 0 1]; + //however, it should specify the dimensions in mm of the dimensions that are flipped + //However, note that whenever you reverse the direction of + //voxel coordinates, you need to include the appropriate offset + //in the 'a' matrix. That is: + //lResidualMat = [0 0 1 0; -1 0 0 Nx-1; 0 1 0 0; 0 0 0 1] + //where Nx is the number of voxels in the x direction. + //So, if you took Nx=256, then for your values before, you'd get: + //TransRot = [ 0 -1 0 255; 0 0 1 0; 1 0 0 0; 0 0 0 1]; + //Because we do not do this, we use the function mins to compute the translations... + //I have not implemented refined version yet - require sample volumes to check + //Ensure Nx is voxels not mm, etc.... + //start of kludge + lResidualMat := multiplymatrices(lInMat,lResidualMat); //source + lResidualMat.Matrix[1,4] := 0; + lResidualMat.Matrix[2,4] := 0; + lResidualMat.Matrix[3,4] := 0; + Mins (lInMat, lHdr.NIFTIHdr,lInMinX,lInMinY,lInMinZ); + Mins (lResidualMat, lOutHdr,lOutMinX,lOutMinY,lOutMinZ); + lResidualMat.Matrix[1,4] := lInMinX-lOutMinX; + lResidualMat.Matrix[2,4] := lInMinY-lOutMinY; + lResidualMat.Matrix[3,4] := lInMinZ-lOutMinZ; + //End of kuldge + lOutHdr.srow_x[0] := lResidualMat.Matrix[1,1]; + lOutHdr.srow_x[1] := lResidualMat.Matrix[1,2]; + lOutHdr.srow_x[2] := lResidualMat.Matrix[1,3]; + lOutHdr.srow_y[0] := lResidualMat.Matrix[2,1]; + lOutHdr.srow_y[1] := lResidualMat.Matrix[2,2]; + lOutHdr.srow_y[2] := lResidualMat.Matrix[2,3]; + lOutHdr.srow_z[0] := lResidualMat.Matrix[3,1]; + lOutHdr.srow_z[1] := lResidualMat.Matrix[3,2]; + lOutHdr.srow_z[2] := lResidualMat.Matrix[3,3]; + lOutHdr.srow_x[3] := lResidualMat.Matrix[1,4]; + lOutHdr.srow_y[3] := lResidualMat.Matrix[2,4]; + lOutHdr.srow_z[3] := lResidualMat.Matrix[3,4]; + nifti_mat44_to_quatern( lResidualMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + dx, dy, dz, lOutHdr.pixdim[0]); + + GetMem(lBufferOut,lVolBytes); + + lnVol := 1; + if (lhdr.NIfTIhdr.dim[4] > 1) and (l4D) then + lnVol := lhdr.NIfTIhdr.dim[4]; + //convert + if lFlipX then + lXInc := -lXInc; + if lFlipY then + lYInc := -lYInc; + if lFlipZ then + lZInc := -lZInc; + for lVol := 1 to lnVol do begin + lOutPos := 0; + if lFlipX then + lStartX := (lOutHdr.dim[1]-1)*-lXInc + else + lStartX := 0; + if lFlipY then + lStartX := lStartX + (lOutHdr.dim[2]-1)*-lYInc; + if lFlipZ then + lStartX := lStartX + (lOutHdr.dim[3]-1)*-lZInc; + lStartX := lStartX+ ((lVol-1)*lVolBytes); + for lZ := 1 to lOutHdr.dim[3] do begin + lOutZ := lStartX + (lZ-1) * lZInc; + for lY := 1 to lOutHdr.dim[2] do begin + lOutY := ((lY-1) * lYInc) + lOutZ; + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to (lBPP) do begin + inc(lOutPos); + //lInPos := ((lX-1) * lXInc) + lOutY + lB; + lInPos := lOutY + lB; + lBufferOut^[lOutPos] := lHdr.ImgBuffer^[lInPos]; + end; + inc(lOutY,lXinc); + end; + end; //for Y + end; //for Z + Move(lBufferOut^,lHdr.ImgBuffer^[1+((lVol-1)*lVolBytes)],lVolBytes); + end; //for each volume + (* Filemode := 2; + AssignFile(lF,'C:\Documents and Settings\Admin\Desktop\rorden\perisample\shit.img'); {WIN} + Rewrite(lF,1); + BlockWrite(lF,lHdr.ImgBuffer^,lnVol*lVolBytes); + CloseFile(lF);*) + Freemem(lBufferOut); + lHdr.NIFTIhdr := lOutHdr; + //fx(lOutHdr.srow_x[3],lOutHdr.srow_y[3],lOutHdr.srow_z[3]); + result := true; +end;//ReorientCore + +end. diff --git a/niftiview7/otsuml.pas b/niftiview7/otsuml.pas new file mode 100755 index 0000000..17ca587 --- /dev/null +++ b/niftiview7/otsuml.pas @@ -0,0 +1,360 @@ +unit otsuml; +//Multilevel Otsu's Method +//Otsu N (1979) A threshold selection method from gray-level histograms. IEEE Trans. Sys., Man., Cyber. 9: 62-66. +//Lookup Tables as suggested by Liao, Chen and Chung (2001) A fast algorithm for multilevel thresholding +//note that my "otsu.pas" is slightly faster and much simpler if you only want bi-level output + +interface +uses define_types, sysutils; + +function FindOtsu2 (var Img: Bytep; nVox: integer): byte; +//function ApplyOtsu2 (var Img: Bytep; nVox: integer): byte; +//function ApplyOtsu3 (var Img: Bytep; nVox: integer): byte; +//function ApplyOtsu4 (var Img: Bytep; nVox: integer): byte; +procedure ApplyOtsu (var Img: Bytep; nVox, levels: integer);//levels: 2=black/white, 3=3tone, 4=4tone +procedure ApplyOtsuBinary (var Img: Bytep; nVox,levels: integer); + +implementation + +Type +HistoRAd = array [0..255] of double; +Histo2D = array [0..255] of HistoRAd; // + +Function OtsuLUT(var H: HistoRA): Histo2D; +var + Sum,Prob: double; + v,u: integer;//column/rom index + P,S: array of array of double; + //P,S: Histo2D; //<- this works in Lazarus, but crashes Delphi: static arrays are too large for heap +begin + Sum := 0; + for v := 0 to 255 do + Sum := Sum + H[v]; + if Sum <= 0 then + exit; + SetLength(P,256,256); + SetLength(S,256,256); + P[0][0] := H[0]; + S[0][0] := H[0]; + for v := 1 to 255 do begin + prob := H[v]/Sum; + P[0][v] := P[0][v-1]+prob; + S[0][V] := S[0][v-1]+(v+1)*prob; + end; + for u := 1 to 255 do begin + for v := u to 255 do begin + P[u][v] := P[0][v]-P[0][u-1]; + S[u][v] := S[0][v]-S[0][u-1]; + end + end; + + //result is eq 29 from Liao + for u := 0 to 255 do begin + for v := u to 255 do begin + if S[u][v] = 0 then //avoid divide by zero errors... + result[u][v] := 0 + else + result[u][v] := sqr(S[u][v]) /P[u][v]; + end + end; + P := nil; + S := nil; +end; +(*Function OtsuLUT(var H: HistoRA): Histo2D; +var + Sum,Prob: double; + v,u: integer;//column/rom index + //P,S: Histo2D; +begin + Sum := 0; + for v := 0 to 255 do + Sum := Sum + H[v]; + if Sum <= 0 then + exit; + + P[0][0] := H[0]; + S[0][0] := H[0]; + for v := 1 to 255 do begin + prob := H[v]/Sum; + P[0][v] := P[0][v-1]+prob; + S[0][V] := S[0][v-1]+(v+1)*prob; + end; + for u := 1 to 255 do begin + for v := u to 255 do begin + P[u][v] := P[0][v]-P[0][u-1]; + S[u][v] := S[0][v]-S[0][u-1]; + end + end; + + //result is eq 29 from Liao + for u := 0 to 255 do begin + for v := u to 255 do begin + if S[u][v] = 0 then //avoid divide by zero errors... + result[u][v] := 0 + else + result[u][v] := sqr(S[u][v]) /P[u][v]; + end + end; +end; *) + +Function OtsuCostFunc(H: HistoRA): integer; +//Otsu N (1979) A threshold selection method from gray-level histograms". IEEE Trans. Sys., Man., Cyber. 9: 62-66. +//http://en.wikipedia.org/wiki/Otsu's_method +//http://www.labbookpages.co.uk/software/imgProc/otsuThreshold.html +//returns threshold for binarizing an image +// all voxel <=Threshold are background +// all voxel >Threshold are object +const + kMaxBin = 255; +var + t,total: integer; + wB,wF,Sum,SumB,mF,mB,varBetween,varMax: double; +begin + result := 0; + wB := 0; + //wF := 0; + SumB := 0; + Sum := 0; + Total := 0; + varMax := 0; + for t := 0 to kMaxBin do + Total := Total + H[t]; + if Total = 0 then exit; + for t := 0 to kMaxBin do + Sum := Sum + (t*H[t]); + for t :=0 to kMaxBin do begin + wB := wB + H[t]; // Weight Background + if (wB = 0) then continue; + wF := Total - wB; // Weight Foreground + if (wF = 0) then break; + sumB := sumB+(t * H[t]); + mB := sumB / wB; // Mean Background + mF := (sum - sumB) / wF; // Mean Foreground + // Calculate Between Class Variance + varBetween := (wB/Total) * (wF/Total) * sqr(mB - mF); + // Check if new maximum found + if (t=0) or (varBetween > varMax) then begin + varMax := varBetween; + result := t; + end; + end; +end; + +//OtsuCostFunc2 provides same answer as OtsuCostFunc, but is slightly slower and requires more RAM +function OtsuCostFunc2(lHisto: HistoRA): integer; +var + v,max: double; + h2d: Histo2D; + n: integer; +begin + h2d := OtsuLUT(lHisto); + //default solution + n := 128; + max := h2d[0,n]+h2d[n+1,255]; + result := n; + //exhaustively search + for n := 0 to (255-1) do begin + v := h2d[0,n]+h2d[n+1,255]; + if v > max then begin + result := n; + max := v; + end; //new max + end; //for n +end; //bilevel OtsuCostFunc2 + +procedure OtsuCostFunc3(lHisto: HistoRA; var Lo,Hi: integer); +var + v,max: double; + l,h: integer; + h2d: Histo2D; +begin + h2d := OtsuLUT(lHisto); + //default solution + lo := 85; + hi := 170; + max := h2d[0,lo]+h2d[lo+1,Hi]+h2d[Hi+1,255]; + //exhaustively search + for l := 0 to (255-2) do begin + for h := l+1 to (255-1) do begin + v := h2d[0,l]+h2d[l+1,h]+h2d[h+1,255]; + if v > max then begin + lo := l; + hi := h; + max := v; + end; //new max + end;//for h -> hi + end; //for l -> low +end; //trilevel OtsuCostFunc3 + +procedure OtsuCostFunc4(var lHisto: HistoRA; var Lo,Mid,Hi: integer); +var + v,max: double; + l,m,h: integer; + h2d: Histo2D; +begin + h2d := OtsuLUT(lHisto); + //default solution + lo := 64; + mid := 128; + hi := 192; + max := h2d[0,lo]+h2d[lo+1,mid]+h2d[mid+1,hi]+h2d[Hi+1,255]; + //exhaustively search + for l := 0 to (255-3) do begin + for m := l+1 to (255-2) do begin + for h := m+1 to (255-1) do begin + v := h2d[0,l]+h2d[l+1,m]+h2d[m+1,h]+h2d[h+1,255]; + if v > max then begin + lo := l; + mid := m; + hi := h; + max := v; + end; //new max + end;//for h -> hi + end; //for mid + end; //for l -> low +end; //quad OtsuCostFunc4 + +function FindOtsu2 (var Img: Bytep; nVox: integer): byte; +var + n: integer; + lHisto: HistoRA; +begin + result := 128; + if nVox < 1 then exit; + //create histogram + for n := 0 to 255 do + lHisto[n] := 0; + for n := 0 to nVox do + inc(lHisto[Img^[n]]); + //now find minimum intraclass variance.... + //result := OtsuCostFunc(lHisto); + result := OtsuCostFunc2(lHisto); //same answer, just slower and more memory +end; + +procedure FindOtsu3 (var Img: Bytep; nVox: integer; var lo, hi: integer); +var + n: integer; + lHisto: HistoRA; +begin + lo := 85; + hi := 170; + if nVox < 1 then exit; + //create histogram + for n := 0 to 255 do + lHisto[n] := 0; + for n := 0 to nVox do + inc(lHisto[Img^[n]]); + //now find minimum intraclass variance.... + OtsuCostFunc3(lHisto,lo,hi); +end; + +procedure FindOtsu4 (var Img: Bytep; nVox: integer; var lo, med, hi: integer); +var + n: integer; + lHisto: HistoRA; +begin + lo := 64; + med := 128; + hi := 192; + if nVox < 1 then exit; + //create histogram + for n := 0 to 255 do + lHisto[n] := 0; + for n := 0 to nVox do + inc(lHisto[Img^[n]]); + //now find minimum intraclass variance.... + OtsuCostFunc4(lHisto,lo,med,hi); +end; + +function ApplyOtsu2 (var Img: Bytep; nVox: integer): byte; +var + n: integer; +begin + result := 128; + if nVox < 1 then exit; + result := FindOtsu2(Img,nVox); + for n := 1 to nVox do + if Img^[n] > result then + Img^[n] := 255 + else + Img^[n] := 0; +end; + +procedure ApplyOtsu3 (var Img: Bytep; nVox: integer); +var + n,lo,hi: integer; + h: histora; +begin + if nVox < 1 then exit; + FindOtsu3(Img,nVox,lo,hi); + for n := 0 to 255 do + if n <= Lo then + H[n] := 0 + else if n <= hi then + h[n] := 128 + else + h[n] := 255; + for n := 1 to nVox do + Img^[n] := H[Img^[n]]; +end; + +procedure ApplyOtsu4 (var Img: Bytep; nVox: integer); +var + n,lo,med,hi: integer; + h: histora; +begin + if nVox < 1 then exit; + FindOtsu4(Img,nVox,lo,med,hi); + for n := 0 to 255 do + if n <= Lo then + H[n] := 0 + else if n <= med then + h[n] := 85 + else if n <= hi then + h[n] := 170 + else + h[n] := 255; + for n := 1 to nVox do + Img^[n] := H[Img^[n]]; +end; + +procedure ApplyOtsu (var Img: Bytep; nVox,levels: integer); +begin + if levels <= 2 then + ApplyOtsu2(Img,nVox) + else if levels = 3 then + ApplyOtsu3(Img,nVox) + else + ApplyOtsu4(Img,nVox); +end; + +procedure ApplyOtsuBinary (var Img: Bytep; nVox,levels: integer); +//1=1/4, 2=1/3, 3=1/2, 4=2/3, 5=3/4 +var + n: integer; + h: histora; +begin + if nVox < 1 then exit; + if (levels <= 1) or (levels >= 5) then + ApplyOtsu4(Img,nVox) + else if (levels = 2) or (levels = 4) then + ApplyOtsu3(Img,nVox) + else //level = 3 + ApplyOtsu2(Img,nVox); + if levels <= 3 then begin //make dark: all except 255 equal 0 + for n := 0 to 254 do + H[n] := 0; + H[255] := 255; + end else begin //make bright: all except 0 equal 255 + H[0] := 0; + for n := 1 to 255 do + H[n] := 255; + end; + for n := 1 to nVox do + Img^[n] := H[Img^[n]]; + +end; + + +end. + \ No newline at end of file diff --git a/niftiview7/periplot.pas b/niftiview7/periplot.pas new file mode 100755 index 0000000..c6f630c --- /dev/null +++ b/niftiview7/periplot.pas @@ -0,0 +1,676 @@ +unit periplot; +//peristimulus plotting routines + +interface +uses + nifti_hdr,define_types,metagraph,sysutils; + +function CreatePeristimulusPlot (var l4DHdr: TMRIcroHdr; var l4DTrace: T4DTrace; +var lPSPlot: TPSPlot): boolean; +function ROIoverlayNameShort(lROI: integer): string; +function numROI: integer; +function ROIoverlayNum(lROI: integer): integer; +function NCond ( var l4DTrace: T4DTrace): integer; +function ROImean (var l4DHdr: TMRIcroHdr; lROInum,lVol: integer): double; + +implementation + + +{$IFNDEF FPC} +{$DEFINE REMOVEREGRESS} +{$ENDIF} +uses nifti_img_view,dialogs,nifti_img,text,graphx,math +{$IFDEF REMOVEREGRESS},fmath, hrf, +matrices,Regmult{$ENDIF}; //need to specify path, e.g. C:\pas\mricron\npm\math + + +//var gOffsetError: array [1..kMaxCond] of double; + +function numROI: integer; +var + lR: integer; +begin + result := 0; + for lR := (kBGOverlayNum+1) to knMaxOverlay do + if gMRIcroOverlay[lR].ScrnBufferItems > 0 then + inc(result); +end; + +function ROIoverlayNum(lROI: integer): integer; +var + lR,lN: integer; +begin + result := 0; + lN := 0; + for lR := (kBGOverlayNum+1) to knMaxOverlay do begin + //fx(lR,gMRIcroOverlay[lR].ScrnBufferItems); + if gMRIcroOverlay[lR].ScrnBufferItems > 0 then begin + inc(lN); + if lROI = lN then begin + result := lR; + exit; + end; + end; //if ROI has items + end; +end; + + +function ROIoverlayNameShort(lROI: integer): string; +begin + if ROIoverlayNum(lROI) = 0 then +{$IFDEF FPC} + result := inttostr(ImgForm.XViewEdit.value)+'x'+inttostr(ImgForm.YViewEdit.value)+'x'+inttostr(ImgForm.ZViewEdit.value) +{$ELSE} + result := inttostr(ImgForm.XViewEdit.asinteger)+'x'+inttostr(ImgForm.YViewEdit.asinteger)+'x'+inttostr(ImgForm.ZViewEdit.asinteger) +{$ENDIF} + else + result := parsefilename(extractfilename(gMRIcroOverlay[ROIoverlayNum(lROI)].HdrFileName)); +end; + +function StDev (lSum, lSumSqr: single; lN: integer): single; +begin + result := 0; + if lN < 2 then + exit; //avoid divide by zero. We divide by N-1 + result:= (lSumSqr - ((Sqr(lSum))/lN)); + if (result > 0) then + result := Sqrt ( result/(lN-1)) +end; + + +function ROIoverlayNameLong(lROI: integer): string; +begin + if ROIoverlayNum(lROI) = 0 then +{$IFDEF FPC} + result := inttostr(ImgForm.XViewEdit.value)+'x'+inttostr(ImgForm.YViewEdit.value)+'x'+inttostr(ImgForm.ZViewEdit.value) +{$ELSE} + result := inttostr(ImgForm.XViewEdit.asinteger)+'x'+inttostr(ImgForm.YViewEdit.asinteger)+'x'+inttostr(ImgForm.ZViewEdit.asinteger) +{$ENDIF} + else + result := gMRIcroOverlay[ROIoverlayNum(lROI)].HdrFileName; +end; + + +function NCond ( var l4DTrace: T4DTrace): integer; +var + lCond: integer; +begin + result := 0; + for lCond := 1 to kMaxCond do + if l4DTrace.Conditions[lCond].Events > 0 then + inc(result); +end; + +function StError (lSum, lSumSqr: single; lN: integer): single; +//= STANDARD DEVIATION / SQUARE ROOT OF THE POPULATION SIZE +//= STDEV(range of values)/SQRT(lN) +begin + if lN > 1 then + result := StDev (lSum, lSumSqr, lN)/ sqrt(lN) + else + result := 0; +end; + +const + kMaxEvents = 2048; + +procedure TimecourseVoxinten (var l4DHdr: TMRIcroHdr; lVoxel: integer; lTimeCourse: DoubleP); +//could also use periutil's VoxInten, but this is faster... +var + lVol,lVolOffset,lImgVox,lMaxStatVol: integer; + l32Buf: singleP; + l16Buf: smallintp; +begin //if ROI else no ROI - single voxel + lImgVox := l4DHdr.NIFTIhdr.dim[1]*l4DHdr.NIFTIhdr.dim[2]*l4DHdr.NIFTIhdr.dim[3]; + lMaxStatVol := l4DHdr.NIFTIhdr.dim[4]; + if (l4DHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(l4DHdr.ImgBuffer ); + for lVol := 1 to lMaxStatVol do begin + lVolOffset := (lVol-1)*lImgVox; + lTimeCourse^[lVol] := l32Buf^[lVoxel+lVolOffset] + end; + end else if l4DHdr.ImgBufferBPP = 2 then begin + l16Buf := SmallIntP(l4DHdr.ImgBuffer ); + for lVol := 1 to lMaxStatVol do begin + lVolOffset := (lVol-1)*lImgVox; + lTimeCourse^[lVol] := l16Buf^[lVoxel+lVolOffset] + end; + end else if l4DHdr.ImgBufferBPP = 1 then begin + for lVol := 1 to lMaxStatVol do begin + lVolOffset := (lVol-1)*lImgVox; + lTimeCourse^[lVol] := l4DHdr.ImgBuffer^[lVoxel+lVolOffset]; + end; + end; //if 1 bpp +end; //GenerateVoxinten + +function ROImean (var l4DHdr: TMRIcroHdr; lROInum,lVol: integer): double; +var + l32Buf: singleP; + l16Buf: smallintp; + lSum: double; + lMaskVox: int64; + lInc,lVolOffset,lImgVox: integer; +begin + result := 0; + //compute number of voxels in mask + lImgVox := l4DHdr.NIFTIhdr.dim[1]*l4DHdr.NIFTIhdr.dim[2]*l4DHdr.NIFTIhdr.dim[3]; + + lMaskVox := 0; + for lInc := 1 to lImgVox do + if gMRIcroOverlay[lROInum].ScrnBuffer^[lInc] > 0 then //in mask + lMaskVox := lMaskVox + gMRIcroOverlay[lROInum].ScrnBuffer^[lInc]; + if lMaskVox < 1 then + exit; + lSum := 0; + lVolOffset := (lVol-1)*lImgVox; + if (l4DHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(l4DHdr.ImgBuffer ); + for lInc := 1 to lImgVox do begin + if gMRIcroOverlay[lROInum].ScrnBuffer^[lInc] > 0 then begin//in mask + lSum := lSum + (gMRIcroOverlay[lROInum].ScrnBuffer^[lInc]*l32Buf^[lInc+lVolOffset]); + end; //in mask + end; //for each vox + end else if (l4DHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(l4DHdr.ImgBuffer ); + for lInc := 1 to lImgVox do begin + if gMRIcroOverlay[lROInum].ScrnBuffer^[lInc] > 0 then begin//in mask + lSum := lSum + (gMRIcroOverlay[lROInum].ScrnBuffer^[lInc]*l16Buf^[lInc+lVolOffset]); + end; //in mask + end; //for each vox + end else if (l4DHdr.ImgBufferBPP = 1) then begin + for lInc := 1 to lImgVox do begin + if gMRIcroOverlay[lROInum].ScrnBuffer^[lInc] > 0 then begin//in mask + lSum := lSum + (gMRIcroOverlay[lROInum].ScrnBuffer^[lInc]*l4DHdr.ImgBuffer^[lInc+lVolOffset]); + end; //for each volume + end; //for each vox + end; //for image type + result := lSum/lMaskVox; +end; + +function TimecourseROIinten (var l4DHdr: TMRIcroHdr; lROInum: integer; lTimeCourse: DoubleP): boolean; +var + lVol,lMaxStatVol: integer; +begin + lMaxStatVol := l4DHdr.NIFTIhdr.dim[4]; + //result := false; + for lVol := 1 to lMaxStatVol do + lTimeCourse^[lVol] := ROImean (l4DHdr,lROInum,lVol); + //compute mean for each volume + result := true; +end; + +function ComputeMeanSE (lCountBin: longintp; lMnBin,lSEBin,lSumBin,lSumSqrBin: doublep; + lNegBins,lPosBins: integer): boolean; +var + lBin: integer; +begin + result := false; + + (*var + lBins,lBin,lnBinsWithSamples: integer; + lIntensitySum: double; +begin + result := false; + lIntensitySum := 0; + lnBinsWithSamples := 0; + lBins := lNegBins; + if lBins < 1 then + lBins := lNegBins+lPosBins; + for lBin := lBins downto 1 do begin //new only base pct on baseline + if lCountBin^[lBin] > 0 then begin + lIntensitySum := lIntensitySum+lMnBin^[lBin]; + inc(lnBinsWithSamples); + end; //samples in bin + end; //for each bin + if lnBinsWithSamples < 1 then + exit;*) + if (lNegBins + lPosBins) < 1 then + exit; + for lBin := (lNegBins + lPosBins) downto 1 do + lSEBin^[lBin] := StError(lSumBin^[lBin],lSumSqrBin^[lBin],lCountBin^[lBin]); + result := true; +end; //ifunc ComputeMeanSE + +{$IFDEF REMOVEREGRESS} + + +function RemoveRegressors(lTimeCourseRaw,lTimeCourseFilt: DoubleP; var l4DTrace: T4DTrace;lCond,lnVol: integer;var lPSPlot: TPSPlot): boolean; +var + lOK: boolean; + lKernelBins,lncond,lC,lVol,lnCondincludeTD: integer; + lHRFra, lTDra: doublep; + lInputSum,lOutputSum : double; + X: PMatrix; + Y: PVector; + //lDummy,lEstTimeCoursePrecise: DoubleP; + lOutT,lOutSlope: DoubleP0; +begin + result := false; + lncond := NCond (l4DTrace); + lnCondincludeTD := lnCond; + if lPSPlot.TemporalDeriv then + lnCondincludeTD := lnCondincludeTD * 2; + if (lnCondincludeTD < 2) or (lPSPlot.SPMDefaultsStatsFmriT < 1) then begin + Showmessage('You need at least two variables to remove regressors (you could add the temporal derivative)'); + exit; + end; //cond = 0 + if not CreateHRF (lPSPlot.TRsec, lKernelBins,lPSPlot.SPMDefaultsStatsFmriT, lHRFra, lTDra) then exit; + //getmem(lTimeCourseRegress,lnVol*sizeof(double)); + for lVol := 1 to lnVol do + lTimeCourseFilt^[lVol] := lTimeCourseRaw^[lVol]; + //compute sum intensity so we can adjust for shifts in the mean... + lInputSum := 0; + for lVol := 1 to lnVol do + lInputSum := lInputSum+lTimeCourseRaw^[lVol]; + //convolve each condition... + DimMatrix(X, lnCondincludeTD, lnVol); + //lDummy := nil; + //Getmem(lEstTimeCoursePrecise, lnVol *lPSPlot.SPMDefaultsStatsFmriT * sizeof(double)); + for lC := 1 to lnCond do begin + (*if lC = lCond then + ConvolveTimeCourse(X, lHRFra, lEstTimeCoursePrecise,l4DTrace, lC,lC,lnVol,lKernelBins,lPSPlot.SPMDefaultsStatsFmriT,lPSPlot.SPMDefaultsStatsFmriT0,lPSPlot.TRSec, lPSPlot.SliceTime) + else*) + ConvolveTimeCourse(X, lHRFra, l4DTrace, lC,lC,lnVol,lKernelBins,lPSPlot.SPMDefaultsStatsFmriT,lPSPlot.SPMDefaultsStatsFmriT0,lPSPlot.TRSec, lPSPlot.SliceTime); + end; + //convolve temporal derivatives for each condition + if lPSPlot.TemporalDeriv then + for lC := 1 to lnCond do + ConvolveTimeCourse(X, lTDra, l4DTrace, lC,lC+lnCond,lnVol,lKernelBins,lPSPlot.SPMDefaultsStatsFmriT,lPSPlot.SPMDefaultsStatsFmriT0,lPSPlot.TRSec, lPSPlot.SliceTime); + freemem(lHRFra); + freemem(lTDra); + DimVector(Y, lnVol); + for lVol := 1 to lnVol do + Y^[lVol] := lTimeCourseRaw^[lVol]; + getmem(lOutT, (lnCondincludeTD+1)* sizeof(double)); + getmem(lOutSlope, (lnCondincludeTD+1)* sizeof(double)); + lOK := MultipleRegressionVec (lnVol,lnCondincludeTD, X, Y, lOutT,lOutSlope); + freemem(lOutT); + DelVector(Y, lnVol); + //begin test - show responses... +if lPSPlot.PlotModel then begin + lC := lCond; //response for condition + //if lTemporalDeriv then lC := lCond + lnCond; //lCond + lnCond = TD + //if lPSPlot.TemporalDeriv then fx( lC,lOutSlope^[lC-1],lOutSlope^[lnCond+lC-1] ); + for lVol := 1 to lnVol do + lTimeCourseFilt^[lVol] := (X^[lC]^[lVol] *lOutSlope[lC-1]); +end else begin //not test + if lOK then begin + for lC := 1 to lnCondincludeTD do begin + if lC <> lCond then begin + for lVol := 1 to lnVol do + lTimeCourseFilt^[lVol] := lTimeCourseFilt^[lVol]- (X^[lC]^[lVol] *lOutSlope[lC-1]); + + end; //for each regressor + end; //for lC + result := true;//SUCCESS! + //next - search for optimal fit of model to data.. + //if (lPSPlot.TextOutput) and (lCond > 0) and (lCond <= kMaxCond) then + // gOffsetError[lCond] := (OptimalOffset(lOutSlope^[lCond-1],lOutSlope^[lnCondincludeTD], lPSPlot.SPMDefaultsStatsFmriT0,lPSPlot.SPMDefaultsStatsFmriT,lnVol, lTimeCourseFilt,lEstTimeCoursePrecise)/ lPSPlot.SPMDefaultsStatsFmriT ) * lPSPlot.TRsec; + end;//lOK +end; + //Freemem(lEstTimeCoursePrecise); + DelMatrix(X, lnCondincludeTD, lnVol); + + //adjust for shifts in the mean... + lOutputSum := 0; + for lVol := 1 to lnVol do + lOutputSum := lOutputSum+lTimeCourseFilt^[lVol]; + if lOutputSum <> lInputsum then begin + lOutputSum := (lOutputSum - lInputSum)/lnVol; + for lVol := 1 to lnVol do + lTimeCourseFilt^[lVol] := lTimeCourseFilt^[lVol] - lOutputSum; + end; //correct for changes... + freemem(lOutSlope); +end; + +{$ENDIF} //IFDEF REMOVEREGRESS +//old TimeCourseToPSPlot - each event can contribute to several samples e.g. both before and after stimulus +(*function TimeCourseToPSPlot(lTimeCourse: DoubleP; var l4DTrace: T4DTrace; + lCountBin: longintp; lMnBin,lSumBin,lSumSqrBin: doublep; + var lTRsec,lBinWidthSec: single; lCond,lnNegBins,lnPosBins,lMaxStatVol: integer; lSliceTime: boolean): boolean; +var + lOnsetRAx: doublep; + lEvent,lnEvent,lBin,lVol: integer; + lNegMS,lPosMS,lVolTime,lTRms,lHalfTRms,lPeristimulusTime,lmsPerBin: double; +begin + result := false; + if l4DTrace.Conditions[lCond].Events < 1 then exit; + lmsPerBin := lBinWidthSec * 1000; + lTRms := lTRsec * 1000; + if lTRms = 0 then begin + Showmessage('Unable to compute plots: You need to specify the TR in seconds.'); + exit; + end; + lHalfTRms := lTRms/2; + lNegMS := -lnNegBins * lmsPerBin; + lPosMS := lnPosBins * lmsPerBin; + lnEvent := l4DTrace.Conditions[lCond].Events; + getmem(lOnsetRAx,lnEvent*sizeof(double) ); + if lSliceTime then begin + for lEvent := 1 to lnEvent do begin + lOnsetRAx^[lEvent] := (l4DTrace.Conditions[lCond].EventRA^[lEvent]*1000)-lHalfTRms; + end; + end else + for lEvent := 1 to lnEvent do + lOnsetRAx^[lEvent] := (l4DTrace.Conditions[lCond].EventRA^[lEvent]*1000); + //initialize bins + for lBin := 1 to (lnNegBins + lnPosBins) do begin + lMnBin^[lBin] := 0; + lSumBin^[lBin] := 0; + lSumSqrBin^[lBin] := 0; + lCountBin^[lBin] := 0; //no samples in each cell + end; + for lVol := 1 to lMaxStatVol do begin + lVolTime := (lVol-1) * lTRms; + for lEvent := 1 to l4DTrace.Conditions[lCond].Events do begin + lPeristimulusTime := lVolTime-lOnsetRAx^[lEvent]; + if (lPeristimulusTime >= lNegMS) and (lPeristimulusTime < lPosMS) then begin + lBin := trunc((lPeristimulusTime - lNegMS) / lmsPerBin)+1; + inc(lCountBin^[lBin]); + lSumBin^[lBin] := lSumBin^[lBin] + lTimeCourse^[lVol]; + lSumSqrBin^[lBin] := lSumSqrBin^[lBin] + sqr(lTimeCourse^[lVol]); + end; //if lPeristimulusTime within mix/max temporal window + end; //for each event + end; //for each vol + //next compute mean + for lBin := 1 to (lnNegBins + lnPosBins) do + if lCountBin^[lBin] > 0 then + lMnBin^[lBin] := lSumBin^[lBin]/lCountBin^[lBin]; + freemem(lOnsetRAx); + result := true; +end;//func TimeCourseToPS +*) +function TimeCourseToPSPlot(lTimeCourse: DoubleP; var l4DTrace: T4DTrace; + lCountBin: longintp; lMnBin,lSumBin,lSumSqrBin: doublep; + var lPSPlot: TPSPlot; lCond,lMaxStatVol: integer): boolean; +var + lOnsetRAx: doublep; + lEvent,lnEvent,lBin,lVol: integer; + lNextEvent,lPrevEvent,lNegMS,lPosMS,lVolTime,lTRms,lHalfTRms,lPeristimulusTime,lmsPerBin: double; +begin + result := false; + if (l4DTrace.Conditions[lCond].Events < 1) or ((lPSPlot.nNegBins + lPSPlot.nPosBins)<1) then exit; + lmsPerBin := lPSPlot.BinWidthSec * 1000; + lTRms := lPSPlot.TRsec * 1000; + if lTRms = 0 then begin + Showmessage('Unable to compute plots: You need to specify the TR in seconds.'); + exit; + end; + lHalfTRms := lTRms/2; + lNegMS := -lPSPlot.nNegBins * lmsPerBin; + lPosMS := lPSPlot.nPosBins * lmsPerBin; + lnEvent := l4DTrace.Conditions[lCond].Events; + getmem(lOnsetRAx,lnEvent*sizeof(double) ); + if lPSPlot.SliceTime then begin + for lEvent := 1 to lnEvent do begin + lOnsetRAx^[lEvent] := (l4DTrace.Conditions[lCond].EventRA^[lEvent]*1000)-lHalfTRms; + end; + end else + for lEvent := 1 to lnEvent do + lOnsetRAx^[lEvent] := (l4DTrace.Conditions[lCond].EventRA^[lEvent]*1000); + //initialize bins + for lBin := 1 to (lPSPlot.nNegBins + lPSPlot.nPosBins) do begin + lMnBin^[lBin] := 0; + lSumBin^[lBin] := 0; + lSumSqrBin^[lBin] := 0; + lCountBin^[lBin] := 0; //no samples in each cell + end; + //find volume's peristimulus time + //note: we assume periutil's ReadCond ensures that Cond.Events are sorted in ascending order + lEvent := 1; + lPrevEvent := -MaxInt; + lNextEvent := lOnsetRAx^[lEvent]; + for lVol := 1 to lMaxStatVol do begin + lVolTime := (lVol-1) * lTRms; + while lVolTime > lNextEvent do begin + inc(lEvent); + lPrevEvent := lNextEvent; + if lEvent > lnEvent then + lNextEvent := MaxInt + else + lNextEvent := lOnsetRAx^[lEvent]; + end; + lPeristimulusTime := lVolTime-lPrevEvent; + if (lPeristimulusTime >= 0) and (lPeristimulusTime < lPosMS) then begin + lBin := trunc((lPeristimulusTime - lNegMS) / lmsPerBin)+1; + inc(lCountBin^[lBin]); + lSumBin^[lBin] := lSumBin^[lBin] + lTimeCourse^[lVol]; + lSumSqrBin^[lBin] := lSumSqrBin^[lBin] + sqr(lTimeCourse^[lVol]); + end else begin //if not after - check if before + lPeristimulusTime := lVolTime-lNextEvent; + if (lPeristimulusTime >= lNegMS) and (lPeristimulusTime < 0) then begin + lBin := trunc((lPeristimulusTime - lNegMS) / lmsPerBin)+1; + inc(lCountBin^[lBin]); + lSumBin^[lBin] := lSumBin^[lBin] + lTimeCourse^[lVol]; + lSumSqrBin^[lBin] := lSumSqrBin^[lBin] + sqr(lTimeCourse^[lVol]); + end; //if lPeristimulusTime within mix/max temporal window + end; //if else... not after stimuli + + (*for lEvent := 1 to l4DTrace.Conditions[lCond].Events do begin + lPeristimulusTime := lVolTime-lOnsetRAx^[lEvent]; + if (lPeristimulusTime >= lNegMS) and (lPeristimulusTime < lPosMS) then begin + lBin := trunc((lPeristimulusTime - lNegMS) / lmsPerBin)+1; + inc(lCountBin^[lBin]); + lSumBin^[lBin] := lSumBin^[lBin] + lTimeCourse^[lVol]; + lSumSqrBin^[lBin] := lSumSqrBin^[lBin] + sqr(lTimeCourse^[lVol]); + end; //if lPeristimulusTime within mix/max temporal window + end; //for each event*) + end; //for each vol + //next compute mean + for lBin := 1 to (lPSPlot.nNegBins + lPSPlot.nPosBins) do + if lCountBin^[lBin] > 0 then + lMnBin^[lBin] := lSumBin^[lBin]/lCountBin^[lBin]; + freemem(lOnsetRAx); + result := true; +end;//func TimeCourseToPS + +function TextOutput (lROI,lCond: integer; var lPSPlot : TPSPlot; var l4DTrace: T4DTrace; lCountBin: longintp; lMnROI,lSEROI: doublep): boolean; +var + lOutMnStr,lOutSDStr,lCondStr, lOutStr,lModelStr: string; + lNegMS,lmsPerBin: double; + lnBins,lBin,lMinBinCount,lMaxBinCount: integer; +begin + result := false; + lnBins := lPSPlot.nNegBins + lPSPlot.nPosBins; + if lnBins < 1 then + exit; + lmsPerBin := lPSPlot.BinWidthSec * 1000; + lNegMS := -lPSPlot.nNegBins * lmsPerBin; + lMinBinCount := lCountBin^[1]; + lMaxBinCount := lCountBin^[1]; + for lBin := 1 to lnBins do begin + if lCountBin^[lBin] < lMinBinCount then + lMinBinCount := lCountBin^[lBin]; + if lCountBin^[lBin] > lMaxBinCount then + lMaxBinCount := lCountBin^[lBin]; + end; + lModelStr := kTextSep+'Processing='+kTextSep; + if lPSPlot.RemoveRegressorVariability then begin + if lPSPlot.PlotModel then + lModelStr := lModelStr+'MODEL[hrf' + else + lModelStr := lModelStr+'observed[hrf'; + if lPSPlot.TemporalDeriv then + lModelStr := lModelStr+'+TD'; + lModelStr := lModelStr+']'; + //if (lCond > 0) and (lCond <= kMaxCond) then lModelStr := lModelStr+ floattostr(gOffsetError[lCond]); + + end else + lModelStr := lModelStr+'observed[raw]'; + lModelStr := lModelStr+kTextSep; + lCondStr := 'Image=,'+gMRIcroOverlay[kBGOverlayNum].HdrFileName+', '+inttostr(lCond)+',Condition=,'+l4DTrace.Conditions[lCond].ELabel+lModelStr+'Events=, '+inttostr(l4DTrace.Conditions[lCond].Events)+', samples per bin= '+inttostr(lMinBinCount)+'..'+inttostr(lMaxBinCount); + lOutStr := kTextSep; + for lBin := 1 to 11 do + lOutStr := lOutStr+kTextSep; + lOutStr := lOutStr+'Bin Starts At->'; + for lBin := 1 to lnBins do + lOutStr := lOutStr+kTextSep+ RealToStr((lNegMS+ ((lBin-1)* lmsPerBin)),0 ); + TextForm.MemoT.lines.add(lOutStr); + TextForm.MemoT.Lines.add('samples per bin '+inttostr(lMinBinCount)+'..'+inttostr(lMaxBinCount)); + //next report number of samples averaged + lOutStr := lCondStr+kTextSep+kTextSep+kTextSep+'samples in bin='; + for lBin := 1 to lnBins do + lOutStr := lOutStr+kTextSep+ inttostr(lCountBin^[lBin] ); + TextForm.MemoT.lines.add(lOutStr); + //next report mean signal + lOutMnStr := lCondStr+kTextSep+'roiMn'+kTextSep+'MaskROI['+ROIoverlayNameShort(lROI)+']=,'+ROIoverlayNameLong(lROI); + lOutSDStr := lCondStr+kTextSep+'roiSE'+kTextSep+'MaskROI['+ROIoverlayNameShort(lROI)+']=,'+ROIoverlayNameLong(lROI); + for lBin := 1 to (lnBins) do begin + lOutMnStr := lOutMnStr+kTextSep+ floattostr(lMnROI^[lBin]);//floattostr(lSumROI[lROI,lBin]/lBinCountRA[lBin]); + lOutSDStr := lOutSDStr+kTextSep+ floattostr(lSEROI^[lBin]);//StDev(lSumROI[lROI,lBin],lSumSqrROI[lROI,lBin],lBinCountRA[lBin]) ); + end; //for each bin + TextForm.MemoT.lines.add(lOutMnStr); + TextForm.MemoT.lines.add(lOutSDStr); + result := true; +end; //proc TextOutput + +function CalcMean (lTimeCourse: DoubleP;lnVol: integer): double; +var + lSum: double; + lVol: integer; +begin + result := 0; + if lnVol < 1 then + exit; + lSum := 0; + for lVol := 1 to lnVol do + lSum := lSum + lTimeCourse^[lVol]; //Sum + result := lSum / lnVol; +end; + +procedure PctSignal (lTimeCourse: DoubleP;lnVol: integer); +var + lMean,lScale: double; + lVol: integer; +begin + if lnVol < 1 then + exit; + lMean := CalcMean (lTimeCourse,lnVol); + if lMean = 0 then + exit; //can't compute % signal change... + lScale := abs(1/lMean); + for lVol := 1 to lnVol do + lTimeCourse^[lVol] := (lTimeCourse^[lVol]-lMean)*lScale; //Sum + +end; + +function CreatePeristimulusPlot (var l4DHdr: TMRIcroHdr; var l4DTrace: T4DTrace; var lPSPlot: TPSplot): boolean; +var + lBinData: T4DTrace; + lTimeCourse,lTimeCourseFilt: doublep; + lCountBin: longintp; + lMnBin,lSEBin,lSumBin,lSumSqrBin: doublep; + lCond,lncond,lnVol,lnROI,lROI,lnROImin1,lLine,lBin: integer; + lTR: double; +begin + result := false; + lncond := NCond (l4DTrace); + if lncond = 0 then begin + Showmessage('You need to specify event onset times before creating a peristimulus plot.'); + exit; + end; //cond = 0 + lnVol := l4DHdr.NIFTIhdr.dim[4]; + if lnVol < 3 then begin + Showmessage('Unable to compute plots: You need to analyze a 4D image.'); + exit; + end; + if (l4DHdr.ImgBufferItems = 0) then exit; + + lTR := lPSPlot.TRsec * 1000; + if lTR = 0 then begin + Showmessage('Unable to compute plots: You need to specify the TR in seconds.'); + exit; + end; + lnROI := 0; + for lROI := (kBGOverlayNum+1) to knMaxOverlay do + if gMRIcroOverlay[lROI].ScrnBufferItems > 0 then //current implementation only one ROI + inc(lnROI); + if lnROI < 1 then begin + lnROImin1 := 1; + end else begin + lnROImin1 := lnROI; + end; + //allocate memory + getmem(lTimeCourse,lnVol*sizeof(double)); + getmem(lTimeCourseFilt,lnVol*sizeof(double)); + getmem(lCountBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(integer)); + getmem(lMnBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(double)); + getmem(lSEBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(double)); + getmem(lSumSqrBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(double)); + getmem(lSumBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(double)); + if lPSPlot.GraphOutput then begin + Create4DTrace (lBinData); + Init4DTrace(lPSPlot.nNegBins + lPSPlot.nPosBins,lnROImin1*lnCond,lBinData,true); + for lROI := 1 to lnROImin1 do + lBinData.Lines[lROI].ELabel := ROIoverlayNameShort(lROI); + end; //if graphoutput + //repeat for each Region of interest + for lROI := 1 to lnROImin1 do begin + //compute complete timecourse for all volumes... + if lnROI = 0 then begin + {$IFDEF FPC} + TimecourseVoxinten (l4DHdr, ImgForm.XViewEdit.value + + ((ImgForm.YViewEdit.value-1)*gBGImg.ScrnDim[1]) + +((ImgForm.ZViewEdit.value-1)*gBGImg.ScrnDim[1] + *gBGImg.ScrnDim[2]),lTimeCourse) + {$ELSE} + TimecourseVoxinten (l4DHdr, ImgForm.XViewEdit.asinteger + + ((ImgForm.YViewEdit.asinteger-1)*gBGImg.ScrnDim[1]) + +((ImgForm.ZViewEdit.asinteger-1)*gBGImg.ScrnDim[1] + *gBGImg.ScrnDim[2]),lTimeCourse) + {$ENDIF} + end else + TimecourseROIinten (l4DHdr, ROIoverlayNum(lROI), lTimeCourse); + //next normalize signal + if lPSPlot.PctSignal then + PctSignal(lTimeCourse,lnVol); + //next compute PSPlots + for lCond := 1 to lnCond do begin + //here is where we can remove variability predicted by regressors.... + {$IFDEF REMOVEREGRESS} + if lPSPlot.RemoveRegressorVariability then begin + RemoveRegressors(lTimeCourse,lTimeCourseFilt,l4DTrace,lCond,lnVol,lPSPlot); + TimeCourseToPSPlot(lTimeCourseFilt, l4DTrace,lCountBin, lMnBin,lSumBin,lSumSqrBin + ,lPSPlot, lCond,lnVol); + end else + {$ENDIF} + TimeCourseToPSPlot(lTimeCourse, l4DTrace,lCountBin, lMnBin,lSumBin,lSumSqrBin + ,lPSPlot,lCond,lnVol); + //percent signal change and std error + ComputeMeanSE (lCountBin, lMnBin,lSEBin,lSumBin,lSumSqrBin + ,lPSPlot.nNegBins,lPSPlot.nPosBins); + //report results + if lPSPlot.TextOutput then + TextOutput (lROI,lCond,lPSPlot, l4DTrace,lCountBin,lMnBin,lSEBin); + if (lPSPlot.GraphOutput) then begin + lLine := lROI + ((lCond-1)* lnROImin1); + for lBin := 1 to (lPSPlot.nNegBins + lPSPlot.nPosBins) do begin + lBinData.Lines[lLine].EventRA^[lBin] := lMnBin^[lBin]; + lBinData.Conditions[lLine].EventRA^[lBin] := lSEBin^[lBin]; + end;//for each bin + end; //if graphoutput + end; //for each cond + end; //for each ROI + freemem(lCountBin); //12/2007 + freemem(lTimeCourse); + freemem(lTimeCourseFilt); + freemem(lMnBin); + freemem(lSEBin); + freemem(lSumSqrBin); + freemem(lSumBin); + if lPSPlot.TextOutput then + TextForm.show; + if (lPSPlot.GraphOutput) then begin + MinMax4DTrace(lBinData); + for lCond := 1 to lnCond do + lBinData.Conditions[lCond].eLabel:= l4DTrace.Conditions[lCond].eLabel; + lBinData.HorzMin := (-lPSPlot.nNegBins+0.5)*lPSPlot.BinWidthSec; + lBinData.HorzWidPerBin := lPSPlot.BinWidthSec; + CorePlot4DTrace(lBinData,Graph4DForm.Image1,1,0,lnCond,lPSPlot.TRsec,Graph4DForm.MinEdit.value,Graph4DForm.MaxEdit.value,true); + Close4DTrace(lBinData,true); + end;//if graph + result := true; +end; + + +end. diff --git a/niftiview7/perisettings.pas b/niftiview7/perisettings.pas new file mode 100755 index 0000000..e6149ec --- /dev/null +++ b/niftiview7/perisettings.pas @@ -0,0 +1,81 @@ +unit perisettings; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin,define_types; + +type + TPSForm = class(TForm) + BinWidthEdit: TRxSpinEdit; + Label3: TLabel; + Label1: TLabel; + Label2: TLabel; + SliceTimeCheck: TCheckBox; + OKBtn: TButton; + PreBinEdit: TRxSpinEdit; + PostBinEdit: TRxSpinEdit; + SavePSVolCheck: TCheckBox; + BaselineCorrectCheck: TCheckBox; + PctSignalCheck: TCheckBox; + RegressCheck: TCheckBox; + TDCheck: TCheckBox; + ModelCheck: TCheckBox; + function GetPeriSettings(var lPSPlot: TPSPlot):boolean; + procedure RegressCheckClick(Sender: TObject); + procedure FormShow(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + PSForm: TPSForm; + +implementation + +{$R *.DFM} +uses NIFti_Img_View; + function TPSForm.GetPeriSettings(var lPSPlot: TPSPlot): boolean; + begin + result := false; + if lPSPlot.TRSec <= 0 then begin + showmessage('Please specify the TR (in seconds) before creating a peristimulus plot.'); + exit; + end; + if BinWidthEdit.value = 0 then + BinWidthEdit.value := lPSPlot.TRsec; + PSForm.ShowModal; + if BinWidthEdit.value = 0 then + BinWidthEdit.value := lPSPlot.TRsec + else + lPSPlot.BinWidthSec := BinWidthEdit.Value; + lPSPlot.nNegBins := PreBinEdit.AsInteger; + lPSPlot.nPosBins := PostBinEdit.AsInteger; + lPSPlot.SliceTime := SliceTimeCheck.checked; + lPSPlot.SavePSVol := SavePSVolCheck.checked; + lPSPlot.BaselineCorrect := BaselineCorrectCheck.checked; + lPSPlot.PctSignal := PctSignalCheck.checked; + lPSPlot.RemoveRegressorVariability := RegressCheck.checked; + lPSPlot.TemporalDeriv := TDcheck.checked; + lPSPlot.PlotModel := ModelCheck.checked; + lPSPlot.SPMDefaultsStatsFmriT := gBGImg.SPMDefaultsStatsFmriT; + lPSPlot.SPMDefaultsStatsFmriT0 := gBGImg.SPMDefaultsStatsFmriT0; + result := true; + end; + + +procedure TPSForm.RegressCheckClick(Sender: TObject); +begin + TDCheck.visible := RegressCheck.checked; + ModelCheck.Visible := RegressCheck.checked; +end; + +procedure TPSForm.FormShow(Sender: TObject); +begin +RegressCheckClick(nil); +end; + +end. diff --git a/niftiview7/periutils.pas b/niftiview7/periutils.pas new file mode 100755 index 0000000..4fd9886 --- /dev/null +++ b/niftiview7/periutils.pas @@ -0,0 +1,315 @@ +unit periutils; +interface + +uses metagraph, define_types, sysutils,nifti_hdr, classes; + +function FSLMatName (lFeatDir: string): string; +function FSLFuncName (lFeatDir: string): string;//Given feat folder returns name of filtered data +function FSLReslicedVOIName (lFeatDir, lMNIVOIName: string): string; +procedure RegressTrace (var l4DTrace: T4DTrace); +function ConvertToTrace (var l4DHdr: TMRIcroHdr;var l4DTrace: T4DTrace; lX,lY,lZ: integer): boolean; +function ReadCond (l3ColTextFileName: string; var l4DTrace: T4DTrace; lCond: integer): boolean; +procedure FSLEVNames (lFeatDir: string; var lEVlist: TStringList); + +implementation + +uses nifti_img_view, text,dialogs,periplot; + +function ReadCond (l3ColTextFileName: string; var l4DTrace: T4DTrace; lCond: integer): boolean; +var + lOnsetText: TextFile; + lnEvents: integer; + lPrev,lFloat,lFloat2,lFloat3: single; +begin + result := false; + if (lCond < 1) or (lCond > kMaxCond) then + exit; + CloseCond(l4DTrace,lCond); + Filemode := 0; + assignfile(lOnsetText,l3ColTextFileName); + {I-} + reset(lOnsetText); + {$I+} + if ioresult <> 0 then begin + Showmessage('Unable to read file [may be in use by another program '+ l3ColTextFileName); + exit; + end; + lnEvents := 0; + lPrev := -MaxInt; + while not EOF(lOnsetText) do begin + lFloat := 999; + {$I-} + read(lOnsetText,lFloat,lFloat2,lFloat3); //read triplets instead of readln: this should load UNIX files + {$I+} + if (ioresult = 0) and (lFloat3 > 0) then begin + inc(lnEvents); + if lFloat < lPrev then begin + closefile(lOnsetText); + showmessage('Error reading 3-column file: durations should be in ascending order '+floattostr(lFloat)+'<'+floattostr(lPrev)+': '+l3ColTextFileName); + exit; + end; + lPrev := lFloat; + end; //if not io error and valid weighting + end; //while not EOF + //fx(lnEvents); + if lnEvents < 1 then begin + closefile(lOnsetText); + showmessage('No events detected. Is this really a FSL-style 3 Column format file? '+l3ColTextFileName); + exit; + end; + InitCond (l4DTrace, lCond, lnEvents); + reset(lOnsetText); + lnEvents := 0; + while not EOF(lOnsetText) do begin + lFloat := 0; + {$I-} + read(lOnsetText,lFloat,lFloat2,lFloat3); //read triplets instead of readln: this should load UNIX files + {$I+} + if (ioresult = 0) and (lFloat3 > 0) then begin + inc(lnEvents); + l4DTrace.Conditions[lCond].EventRA^[lnEvents] := lFloat; + l4DTrace.Conditions[lCond].DurRA^[lnEvents] := lFloat2; + end; + end; + closefile(lOnsetText); + l4DTrace.Conditions[lCond].ELabel := parsefilename(extractfilename(l3ColTextFileName)); + result := true; +end; + +function ConvertToTrace (var l4DHdr: TMRIcroHdr;var l4DTrace: T4DTrace; lX,lY,lZ: integer): boolean; +var + lVol,lVolSz,lPos,lSamples,lLine,lnLines,lROI: integer; + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + result := false; + lSamples := l4DHdr.NIFTIhdr.dim[4]; + lVolSz := l4DHdr.NIFTIhdr.dim[1]*l4DHdr.NIFTIhdr.dim[2]*l4DHdr.NIFTIhdr.dim[3]; + if lSamples < 2 then + exit; + + lnLines := 0; + for lVol := (kBGOverlayNum+1) to knMaxOverlay do + if gMRIcroOverlay[lVol].ScrnBufferItems > 0 then //for each ROI + inc(lnLines); + if lnLines = 0 then begin //no ROIs + lLine := 1; + lPos := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + if (lPos > l4DHdr.ImgBufferItems) or (lPos < 1) then exit; + Init4DTrace(lSamples, 1,l4DTrace,false); + l4DTrace.Lines[1].ELabel := inttostr(lX)+'x'+inttostr(lY)+'x'+inttostr(lZ); + if (l4DHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(l4DHdr.ImgBuffer ); + for lVol := 1 to lSamples do begin + l4DTrace.Lines[lLine].EventRA[lVol] := l32Buf[lPos]; + lPos := lPos + lVolSz; + end; + end else if (l4DHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(l4DHdr.ImgBuffer ); + for lVol := 1 to lSamples do begin + l4DTrace.Lines[lLine].EventRA^[lVol] := l16Buf^[lPos]; + lPos := lPos + lVolSz; + end; + end else if l4DHdr.ImgBufferBPP = 1 then begin + for lVol := 1 to lSamples do begin + l4DTrace.Lines[lLine].EventRA^[lVol] := l4DHdr.ImgBuffer^[lPos]; + lPos := lPos + lVolSz; + end; + end else + showmessage('Serious error: unknown data size!'); + end else begin //>0 ROIS + Init4DTrace(lSamples, lnLines,l4DTrace,false); + for lLine := 1 to lnLines do begin + lROI := ROIoverlayNum(lLine); + l4DTrace.Lines[lLine].ELabel := ParseFileName(extractfilename(gMRIcroOverlay[lROI].HdrFileName)); + for lVol := 1 to lSamples do + l4DTrace.Lines[lLine].EventRA^[lVol] := ROImean(l4DHdr,lROI,lVol{,lVolSz}); + end; + end; + MinMax4DTrace(l4DTrace); + result := true; +end; + +function ComputeRegress (ldataRA: singlep; lndata: integer): string; +const + //kMax = 1000; + kCR = chr (13); +Var + gx : Array[1..4] of extended; + gy : Array[1..4] of extended; + Exy : Array[1..4] of extended; + Ex : Array[1..4] of extended; + Ey : Array[1..4] of extended; + Ex2 : Array[1..4] of extended; + Ey2 : Array[1..4] of extended; + a : Array[1..4] of extended; + b : Array[1..4] of extended; + r : Array[1..4] of extended; + chtX: Array[1..4] of extended; + chtY: Array[1..4] of extended; + no : Integer; + gInter, gSlope,gRSqr : extended; + +function calcit: string; +Var + q : Integer; +Begin + +For q := 1 To 4 Do Begin + b[q] := (no * Exy[q] - Ex[q] * Ey[q]) / (no * Ex2[q] - (Ex[q]*Ex[q]) ); + a[q] := (Ey[q] - b[q] * Ex[q]) / no; + r[q] := (no * Exy[q] - Ex[q] * Ey[q]) / (Sqrt((no * Ex2[q] - (Ex[q]*Ex[q]) ) * (no * Ey2[q] - (Ey[q]*Ey[q]) ) )); +End; // for +a[2] := Exp(a[2]); +a[4] := Exp(a[4]); +result := (' Linear Y=' + RealToStr(a[1],8) + ' +' + RealToStr(b[1],8) + ' * X'+' R=' + RealToStr(r[1],8)+' R^2=' + RealToStr(r[1]*r[1],8)); +gInter := a[1]; +gSlope := b[1]; +gRSqr := r[1]; +result := result + (', Exp Y=' + RealToStr(a[2],8) + ' * e ^' + RealToStr(b[2],8) + ' * X'+' R=' + RealToStr(r[2],8)+' R^2=' + RealToStr(r[2]*r[2],8)); +result := result + (', Log Y=' + RealToStr(a[3],8) + ' +' + RealToStr(b[3],8) + ' * LOG(X)'+' R=' + RealToStr(r[3],8)+' R^2=' + RealToStr(r[3]*r[3],8)); +result := result +(', Power Y=' + RealToStr(a[4],8) + ' * X ^' + RealToStr(b[4],8)+' R=' + RealToStr(r[4],8)+' R^2=' + RealToStr(r[4]*r[4],8)); +End; // nested calcit() +Procedure inpcalc (lX, lY: extended); +Var + q : Integer; +Begin +gx[1] := lX; +gy[1] := lY; +//inc(gnVal); +inc(no); + gx[2] := gx[1]; + gy[2] := Ln(gy[1]); // exp +gx[3] := Ln(gx[1]); + gy[3] := gy[1]; // log +gx[4] := Ln(gx[1]); + gy[4] := Ln(gy[1]); // power + +For q := 1 To 4 Do Begin + Exy[q] := Exy[q] + gx[q] * gy[q]; + Ex[q] := Ex[q] + gx[q]; + Ey[q] := Ey[q] + gy[q]; + Ex2[q] := Ex2[q] + (gx[q]*gx[q]); + Ey2[q] := Ey2[q] + (gy[q]*gy[q]); + End; // For +End; //nested inpcalc +procedure initReg; +var lC: byte; +begin +for lC := 1 to 4 do begin + gx [lC]:= 0; + gy [lC]:= 0; + Exy [lC]:= 0; + Ex[lC]:= 0; + Ey[lC]:= 0; + Ex2[lC]:= 0; + Ey2[lC]:= 0; + a[lC]:= 0; + b[lC]:= 0; + r[lC]:= 0; + chtX[lC]:= 0; + chtY[lC]:= 0; + end; //for lC +end;//nested inp calc +const + kDeleteVols = 3; +var + i: integer; +begin //computeRegress + result := ''; + no := 0; + if lndata < (kDeleteVols+5) then exit; + + //gnVal := 0; + initReg; + for i := kDeleteVols to lndata do begin + //fx(i,ldatara[i]); + inpcalc (i, ldataRA^[i]); + end; + result := calcit; +end; //func ComputeRegress + +procedure RegressTrace (var l4DTrace: T4DTrace); +var + lStr: string; + lE,lCond, lnCond,lnE: integer; + lMean : double; + ldataRA: singlep; +begin + lncond := 0; + for lCond := 1 to kMaxCond do + if l4DTrace.Lines[lCond].Events > 0 then + inc(lnCond); + if lncond = 0 then + exit; + for lCond := 1 to kMaxCond do begin + if l4DTrace.Lines[lCond].Events > 0 then begin + lnE := l4DTrace.Lines[lCond].Events; + getmem(ldataRA,lnE * sizeof(single)); + lStr := gMRIcroOverlay[kBGOverlayNum].HdrFileName+kTextSep+l4DTrace.Lines[lCond].ELabel; + //load data + lMean := 0; + for lE := 1 to lnE do begin + ldataRA[lE] := l4DTrace.Lines[lCond].EventRA[lE]; + lMean := ldataRA^[lE] + lMean; //sum + end; + + lMean := lMean / lnE; + //fx(lMean); + //normalize data... + for lE := 1 to lnE do + ldataRA^[lE] := ldataRA^[lE]/lMean; + //compute functions + lStr := lStr +kTextSep+ (ComputeRegress (ldataRA, lnE) ); + TextForm.MemoT.lines.add(lStr); + //TextForm.Memo1.lines.add(lStr); + freemem(ldataRA); + end; + end; + //TextForm.show; +end; + +//NEXT SECTION - FSL UTILITIES +procedure FSLEVNames (lFeatDir: string; var lEVlist: TStringList); +//Given feat folder returns name of matrix to reorient MNI image to functional data +var + lEVdir : string; + lSearchRec: TSearchRec; +begin + lEVList.clear; + lEVdir := lFEATDir+pathdelim+'custom_timing_files'; +//showmessage(lEVdir); + if not DirExists(lEVdir) then + exit; +//showmessage(lEVdir); + if FindFirst(lEVdir+pathdelim+'*'+'.txt', faAnyFile, lSearchRec) = 0 then begin + repeat + lEVlist.Add(lEVdir+pathdelim+lSearchRec.Name) + until (FindNext(lSearchRec) <> 0); + end; + FindClose(lSearchRec); +//fx(lEVlist.count); + //result := lFeatDir+PathDelim+'reg'+PathDelim+'example_func2standard.mat'; +end; //MatName + + + +function FSLMatName (lFeatDir: string): string; +//Given feat folder returns name of matrix to reorient MNI image to functional data +begin + result := lFeatDir+PathDelim+'reg'+PathDelim+'example_func2standard.mat'; +end; //MatName + +function FSLFuncName (lFeatDir: string): string;//Given feat folder returns name of filtered data +begin + result := lFeatDir+PathDelim+'filtered_func_data.nii.gz'; +end; //FuncName + +function FSLReslicedVOIName (lFeatDir, lMNIVOIName: string): string; +//Given FSL .feat folder name and source MNI volume name retuns resliced VOI name +begin + result := lFeatDir+PathDelim+extractfilename(lMNIVOIName); +end; //ReslicedVOIName + + +end. diff --git a/niftiview7/pref_ini.pas b/niftiview7/pref_ini.pas new file mode 100755 index 0000000..9de7a29 --- /dev/null +++ b/niftiview7/pref_ini.pas @@ -0,0 +1,327 @@ +unit pref_ini; +//save and reads prefs from ini file +{$H+} + +interface +uses + Windows, + IniFiles,SysUtils,define_types,graphics,Dialogs,Classes,ShellAPI, + registry, Admin,graphicsMathLibrary,NIFTI_hdr, nifti_types; +type + TBGImg = record //Next: Background image information + ScrnDim: array [1..3] of smallint; + ScrnMM,ScrnOri: array [1..3] of single; + XViewCenter,YViewCenter,ZViewCenter,BasePenThick: single; + SliceView,SPMDefaultsStatsFmriT,SPMDefaultsStatsFmriT0, + MaxDim,LicenseID,XBarGap,XBarThick,VOIUndoSlice,VOIUndoOrient,VOIUndoVolItems, + RenderDepthBufferItems,VOIInvZoom,ZoomPct,BGTransPct,OverlayTransPct, PlanarRGB, + Zoom, + ImageSeparation,RenderDim,SigDig,{Apr07}TabletPressure,TabletErasePressure,LesionSmooth,LesionDilate,FontSize: integer; + //ResizeBeforeRescale - 0=intensity rescale, then resize; 1= nearest neighbor resize, then rescale;1=trilinear resize, then rescale; + //Show2ndSliceViews, + FlipAx,FlipSag,SingleRow,ResliceOnLoad,OrthoReslice,UseReorientHdr,AutoFill, + ThinPen,Mirror,OverlaySmooth,VOIchanged,VOImirrored,SaveDefaultIni,Prompt4DVolume, + KnownAlignment,Resliced, + Smooth2D,ShowDraw,XBar,Yoke: boolean; + MinChar,MaxChar: array [1..3] of char; //May07 + StretchQuality : TStretchQuality; + VOIClr,XBarClr: TColor; + BackupLUT: array[0..255] of TRGBQuad; + FSLDIR,FSLOUTPUTTYPE: kStr255; + //LabelStr20 : Array[0..kHistoBins] of kstr20; + LabelRA: TStrRA; + InvMat: TMatrix; + ReorientHdr: TNIFTIHdr; + //Cutout: TCutout; + VOIUndoVol: bytep; + RenderDepthBuffer: SmallIntp; + end; //BGImg Header Structure + +//function zIniFile(lRead: boolean; lFilename: string; var lPrefs: TBGImg): boolean; +procedure ReadIniFile; //read init file values +procedure WriteIniFile; + + function IniName: string; + +procedure SetBGImgDefaults (var lBGImg: TBGImg); + +implementation +uses nifti_img_view {,nifti_img}; + +function IniName: string; +//only administrators can write to c:\program files -use AppDataFolder for non-Administrators +begin + if isAdmin then + result := changefileext(paramstr(0),'.ini') + else + result := AppDataFolder+pathdelim{+ParseFileName(extractfilename(paramstr(0)) ) +pathdelim}+changefileext(extractfilename(paramstr(0)),'.ini'); +end; + +procedure SetBGImgDefaults (var lBGImg: TBGImg); +begin + with lBGImg do begin + XBar := true; + Yoke := false; + OverlayTransPct := -1; + BGTransPct := 0; + ResliceOnLoad := false; + OrthoReslice := true; + Prompt4DVolume := true; + FlipAx := false; + FlipSag := false; + LicenseID := 0; + MaxDim := 512; + XBarGap := 7; + XBarThick := 3; + XBarClr := clBlue; + VOIClr := 255;//clRed; + VOIInvZoom := 1 shl 10; //1024 = 100% + PlanarRGB := 2; + VOIUndoSlice := 0; + VOIUndoOrient := 0; + VOIChanged := false; + VOImirrored := false; + TabletPressure := 70; + TabletErasePressure := 30; + LesionSmooth := 3;//3mm smoothing + LesionDilate := 8; + VOIUndoVolItems := 0; + RenderDepthBufferItems := 0; + FontSize := 12; + SigDig := 5; + ImageSeparation := 0; + SliceView := 0;//multiple slices + SPMDefaultsStatsFmriT := 16; + SPMDefaultsStatsFmriT0 := 1; + SaveDefaultIni := true; + SingleRow := false; + ThinPen := true; + AutoFill := false; + KnownAlignment := false; + StretchQuality := sqHigh; + //XMinChar := ' ';XMaxChar := ' ';YMinChar :=' ';ZMinChar:=' '; //May07 + OverlaySmooth := true; + end; //with lBGImg +end; //set BGDef , + +(*procedure SetIniMenus; +begin + //XBarBtn.Down := gBGImg.XBarVisible; + with ImgForm do begin + YokeMenu.Checked := gYoke; + Menu2DSmooth.checked := gBGImg.StretchQuality = sqHigh; + Menu2DSmoothClick(nil);//set qualit + end; +end; *) + + +function registerfiletype(inft,inkey,desc,icon:string): boolean; +var myreg : treginifile; + ct : integer; + ft,key: string; +begin + result := true; +(* ft := inft; + key := inkey; + ct := pos('.',ft); + while ct > 0 do begin + delete(ft,ct,1); + ct := pos('.',ft); + end; + if (ft = '') or (ImgForm.Application.ExeName = '') then exit; //not a valid file-ext or ass. app + ft := '.'+ft; + myreg := treginifile.create(''); + try + myreg.rootkey := hkey_classes_root; // where all file-types are described + if key = '' then key := copy(ft,2,maxint)+'_auto_file'; // if no key-name is given, create one + myreg.writestring(ft,'',key); // set a pointer to the description-key + myreg.writestring(key,'',desc); // write the description + myreg.writestring(key+'\DefaultIcon','',icon); // write the def-icon if given + myreg.writestring(key+'\shell\open\command','',Application.ExeName+' %1'); //association + except + result := false; + showmessage('Only administrators can change file associations. You are currently logged in as a restricted user.'); + end; + myreg.free; *) +end; + + +procedure SetDefaultPrefs (var lPrefs: TBGImg); +begin + with lPrefs do begin + //ProportionalStretch := true; + end;//with lPrefs +end; //Proc SetDefaultPrefs + +procedure IniInt(lRead: boolean; lIniFile: TIniFile; lIdent: string; var lValue: integer); +//read or write an integer value to the initialization file +var + lStr: string; +begin + if not lRead then begin + lIniFile.WriteString('INT',lIdent,IntToStr(lValue)); + exit; + end; + lStr := lIniFile.ReadString('INT',lIdent, ''); + if length(lStr) > 0 then + lValue := StrToInt(lStr); +end; //IniInt + +procedure IniBool(lRead: boolean; lIniFile: TIniFile; lIdent: string; var lValue: boolean); +//read or write a boolean value to the initialization file +var + lStr: string; +begin + if not lRead then begin + lIniFile.WriteString('BOOL',lIdent,Bool2Char(lValue)); + exit; + end; + lStr := lIniFile.ReadString('BOOL',lIdent, ''); + if length(lStr) > 0 then + lValue := Char2Bool(lStr[1]); +end; //IniBool + +procedure IniStr255(lRead: boolean; lIniFile: TIniFile; lIdent: string; var lValue: kStr255); +//read or write a string value to the initialization file +begin + if not lRead then begin + lIniFile.WriteString('STR',lIdent,lValue); + exit; + end; + lValue := lIniFile.ReadString('STR',lIdent, ''); +end; //IniStr + +procedure IniMRU(lRead: boolean; lIniFile: TIniFile; lIdent: string; var lValue: string); +//read or write a string value to the initialization file +begin + if not lRead then begin + lIniFile.WriteString('MRU',lIdent,lValue); + exit; + end; + lValue := lIniFile.ReadString('MRU',lIdent, ''); +end; //IniMRU + +function TColorToHex( Color : TColor ) : string; +begin + Result := + { red value } + IntToHex( GetRValue( Color ), 2 ) + + { green value } + IntToHex( GetGValue( Color ), 2 ) + + { blue value } + IntToHex( GetBValue( Color ), 2 ); +end; + +function HexToTColor( sColor : string ) : TColor; +begin + Result := + RGB( + { get red value } + StrToInt( '$'+Copy( sColor, 1, 2 ) ), + { get green value } + StrToInt( '$'+Copy( sColor, 3, 2 ) ), + { get blue value } + StrToInt( '$'+Copy( sColor, 5, 2 ) ) + ); +end; + +procedure IniColor(lRead: boolean; lIniFile: TIniFile; lIdent: string; var lValue: TColor); +//read or write an integer value to the initialization file +var + lStr: string; +begin + if not lRead then begin + lIniFile.WriteString('CLR',lIdent,TColorToHex(lValue)); + exit; + end; + lStr := lIniFile.ReadString('CLR',lIdent, ''); + if length(lStr) > 0 then + lValue := HexToTColor(lStr); +end; //IniColor + +function IniFile(lRead: boolean; lFilename: string; var lPrefs: TBGImg): boolean; +//Read or write initialization variables to disk +var + lINc: integer; + lIniFile: TIniFile; +begin + result := false; + if (lRead) and (not Fileexists(lFilename)) then + exit; + lIniFile := TIniFile.Create(lFilename); + //STR + IniStr255(lRead,lIniFile,'FSLDIR',lPrefs.FSLDIR); + IniStr255(lRead,lIniFile,'FSLOUTPUTTYPE',lPrefs.FSLOUTPUTTYPE); + //recent files + IniMRU(lRead,lIniFile,'file0', gMRIcroOverlay[kBGOverlayNum].HdrFilename); + for lInc := 1 to knMRU do + IniMRU(lRead,lIniFile,'file'+inttostr(lInc), gMRUstr[lINc]); + // if lRead then + // showmessage( gMRUstr[1] +' : '+gMRUstr[2]); + //Booleans + with lPrefs do begin + IniBool(lRead,lIniFile, 'AutoFill',AutoFill); + IniBool(lRead,lIniFile, 'FlipAx',FlipAx); + IniBool(lRead,lIniFile, 'FlipSag',FlipSag); + IniBool(lRead,lIniFile, 'LRmirror',Mirror); + IniBool(lRead,lIniFile, 'OverlaySmooth',OverlaySmooth); + IniBool(lRead,lIniFile, 'Reslice',ResliceOnLoad); + IniBool(lRead,lIniFile, 'ResliceOrtho',OrthoReslice); + IniBool(lRead,lIniFile, 'ShowDraw',ShowDraw); + IniBool(lRead,lIniFile, 'SingleRow',SingleRow); + IniBool(lRead,lIniFile, 'Smooth2D',Smooth2D); + IniBool(lRead,lIniFile, 'ThinPen',ThinPen); + IniBool(lRead,lIniFile, 'XBar',XBar); + IniBool(lRead,lIniFile, 'Yoke',Yoke); + //Integers + IniInt(lRead,lIniFile, 'BGTransPct',BGTransPct); + IniInt(lRead,lIniFile, 'ImageSeparation',ImageSeparation); + IniInt(lRead,lIniFile, 'LesionSmooth',LesionSmooth); + IniInt(lRead,lIniFile, 'LesionDilate',LesionDilate); + IniInt(lRead,lIniFile, 'LicenseID',LicenseID); + IniInt(lRead,lIniFile, 'LUT',gMRIcroOverlay[kBGOverlayNum].LUTindex);//read + IniInt(lRead,lIniFile, 'MaxDim',MaxDim); + IniInt(lRead,lIniFile, 'MaxThreads',gnCPUThreads); + IniInt(lRead,lIniFile, 'OverlayTransPct',OverlayTransPct); + IniInt(lRead,lIniFile, 'SigDigits',SigDig); + IniInt(lRead,lIniFile, 'SPMDefaultsStatsFmriT',SPMDefaultsStatsFmriT); + IniInt(lRead,lIniFile, 'SPMDefaultsStatsFmriT0',SPMDefaultsStatsFmriT0); + IniInt(lRead,lIniFile, 'TabletPressure',TabletPressure); + IniInt(lRead,lIniFile, 'TabletErasePressure',TabletErasePressure); + IniInt(lRead,lIniFile, 'FontSize',FontSize); + + IniColor(lRead,lIniFile, 'VOIClr',VOIClr); + IniColor(lRead,lIniFile, 'XBarClr',XBarClr); + IniInt(lRead,lIniFile, 'XBarGap',XBarGap); + IniInt(lRead,lIniFile, 'XBarThick',XBarThick); + IniInt(lRead,lIniFile, 'Zoom',Zoom); + IniInt(lRead,lIniFile, 'PlanarRGB',PlanarRGB); + end;//with + lIniFile.Free; +(* + YokeTimer.Enabled := gYoke; + if (gBGImg.BGTransPct < 0) or (gBGImg.BGTransPct > 90) then + gBGImg.BGTransPct := 20; //additive or transparent values can confuse users + if (gBGImg.OverlayTransPct < 0) or (gBGImg.OverlayTransPct > 90) then + gBGImg.OverlayTransPct := 20; //additive or transparent values can confuse users +*) + +end; + +procedure WriteIniFile; +begin + if (DiskFreeEx(paramstr(0)) < 1) or (not gBGIMg.SaveDefaultIni) then + exit; + IniFile(false,IniName,gBGImg); +end; + +procedure ReadIniFile; +var + lFilename: string; + lOK: boolean; +begin + lFilename := IniName; + IniFile(true,IniName,gBGImg); +end; //ReadIniFile + +end. diff --git a/niftiview7/prefs.pas b/niftiview7/prefs.pas new file mode 100755 index 0000000..9bb527e --- /dev/null +++ b/niftiview7/prefs.pas @@ -0,0 +1,104 @@ +unit prefs; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Buttons, Mask; + +type + TPrefForm = class(TForm) + CancelBtn: TSpeedButton; + OKBtn: TSpeedButton; + GroupBox1: TGroupBox; + ThinPenCheck: TCheckBox; + Label4: TLabel; + Label5: TLabel; + GroupBox2: TGroupBox; + ResliceCheck: TCheckBox; + Label2: TLabel; + Label1: TLabel; + LabelX: TLabel; + MaxDimEdit: TRxSpinEdit; + ThreadEdit: TRxSpinEdit; + SigDigEdit: TRxSpinEdit; + TabletPressureEdit: TRxSpinEdit; + TabletErasePressureEdit: TRxSpinEdit; + AutoFillCheck: TCheckBox; + OrthoCheck: TCheckBox; + SingleROwCheck: TCheckBox; + procedure CancelBtnClick(Sender: TObject); + procedure OKBtnClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure ResliceCheckClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + PrefForm: TPrefForm; + +implementation +uses + nifti_img_view; + +{$R *.DFM} + +procedure TPrefForm.CancelBtnClick(Sender: TObject); +begin + Close; +end; + +procedure TPrefForm.OKBtnClick(Sender: TObject); +begin + gBGImg.ResliceOnLoad := ResliceCheck.checked; + gBGImg.OrthoReslice := OrthoCheck.checked; + gBGImg.MaxDim := MaxDimEdit.asInteger; + gnCPUThreads{gMaxCPUThreads} := ThreadEdit.asInteger; + //ImgForm.ToolPanel.Visible := DrawCheck.checked; + //ImgForm.DrawMenu.Visible := DrawCheck.checked; + gBGImg.ThinPen := ThinPenCheck.Checked; + gBGImg.AutoFill := AutoFillCheck.checked; + gBGImg.SigDig := SigDigEdit.asInteger; + gBGImg.TabletPressure := TabletPressureEdit.asInteger; + gBGImg.TabletErasePressure := TabletErasePressureEdit.asInteger; + ImgForm.SetAutoFill; + + + if (gBGImg.SingleRow <> SingleRowCheck.Checked) then begin + gBGImg.SingleRow := SingleRowCheck.Checked; + //gBGImg.Show2ndSliceViews := Show2ndSliceViewsCheck.checked; + ImgForm.DefaultControlPanel; + ImgForm.RefreshImagesTimer.enabled := true; + end; + + Close; + +end; + +procedure TPrefForm.FormShow(Sender: TObject); +begin + ResliceCheck.checked := gBGImg.ResliceOnLoad; + //OrthoCheck.Visible := not gBGImg.ResliceOnLoad; + OrthoCheck.checked := gBGImg.OrthoReslice; + MaxDimEdit.value := gBGImg.MaxDim; + ThreadEdit.value := gnCPUThreads{gMaxCPUThreads}; + //DrawCheck.checked := ImgForm.ToolPanel.Visible; + ThinPenCheck.Checked := gBGImg.ThinPen; + AutoFillCheck.Checked := gBGImg.AutoFill; + SigDigEdit.value := gBGImg.SigDig; + SingleRowCheck.checked := gBGImg.SingleRow; + //Show2ndSliceViewsCheck.Checked := gBGImg.Show2ndSliceViews; + TabletPressureEdit.value := gBGImg.TabletPressure; + TabletErasePressureEdit.value := gBGImg.TabletErasePressure; + +end; + +procedure TPrefForm.ResliceCheckClick(Sender: TObject); +begin + //OrthoCheck.Visible := not ResliceCheck.checked; +end; + +end. diff --git a/niftiview7/readfloat.pas b/niftiview7/readfloat.pas new file mode 100755 index 0000000..b5c4b97 --- /dev/null +++ b/niftiview7/readfloat.pas @@ -0,0 +1,45 @@ +unit ReadFloat; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Mask; + +type + TReadFloatForm = class(TForm) + OKBtn: TButton; + ReadFloatLabel: TLabel; + ReadFloatEdit: TRxSpinEdit; + function GetFloat(lStr: string; lMin,lDefault,lMax: double): double; + + procedure OKBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + ReadFloatForm: TReadFloatForm; + +implementation + +{$R *.DFM} + function TReadFloatForm.GetFloat(lStr: string; lMin,lDefault,lMax: double): double; + begin + //result := lDefault; + ReadFloatLabel.caption := lStr+' ['+floattostr(lMin)+'..'+floattostr(lMax)+']'; + ReadFloatEdit.MinValue := lMin; + ReadFloatEdit.MaxValue := lMax; + ReadFloatEdit.Value := lDefault; + ReadFloatForm.ShowModal; + result := ReadFloatEdit.Value; + end; + +procedure TReadFloatForm.OKBtnClick(Sender: TObject); +begin + ReadFloatForm.ModalResult := mrOK; +end; + +end. diff --git a/niftiview7/ref26.bmp b/niftiview7/ref26.bmp new file mode 100755 index 0000000..58792ba Binary files /dev/null and b/niftiview7/ref26.bmp differ diff --git a/niftiview7/ref26b.bmp b/niftiview7/ref26b.bmp new file mode 100755 index 0000000..4918307 Binary files /dev/null and b/niftiview7/ref26b.bmp differ diff --git a/niftiview7/refresh.bmp b/niftiview7/refresh.bmp new file mode 100755 index 0000000..c8104db Binary files /dev/null and b/niftiview7/refresh.bmp differ diff --git a/niftiview7/refresh2.bmp b/niftiview7/refresh2.bmp new file mode 100755 index 0000000..d2b2b25 Binary files /dev/null and b/niftiview7/refresh2.bmp differ diff --git a/niftiview7/refresh24.bmp b/niftiview7/refresh24.bmp new file mode 100755 index 0000000..272cbe9 Binary files /dev/null and b/niftiview7/refresh24.bmp differ diff --git a/niftiview7/refresh26.bmp b/niftiview7/refresh26.bmp new file mode 100755 index 0000000..c99e29c Binary files /dev/null and b/niftiview7/refresh26.bmp differ diff --git a/niftiview7/render.pas b/niftiview7/render.pas new file mode 100755 index 0000000..4197eb9 --- /dev/null +++ b/niftiview7/render.pas @@ -0,0 +1,731 @@ +unit render; + +interface + +uses +FileCtrl, //<- Delphi 4 only + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, Buttons,nifti_img, nifti_hdr,define_types,nifti_img_view, + StdCtrls, GraphicsMathLibrary, Menus,ClipBrd,ReadInt,cutout,IniFiles, + RenderThds, ComCtrls, RXSpin,render_composite, PngSpeedButton, Mask, pref_ini; + +type + TRenderForm = class(TForm) + RenderBar: TPanel; + MainMenu1: TMainMenu; + FileMenu: TMenuItem; + Close1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Save1: TMenuItem; + Label4: TLabel; + Volume1: TMenuItem; + RenderBGSurfaceMenu: TMenuItem; + N1: TMenuItem; + N101: TMenuItem; + N401: TMenuItem; + N601: TMenuItem; + N801: TMenuItem; + N403: TMenuItem; + N404: TMenuItem; + N405: TMenuItem; + RenderBGDepthMenu: TMenuItem; + N1voxel1: TMenuItem; + N2voxels1: TMenuItem; + N4voxels1: TMenuItem; + N8voxels1: TMenuItem; + N16voxels1: TMenuItem; + N16voxels: TMenuItem; + RenderSmoothBG: TMenuItem; + RenderPreciseInterpolation: TMenuItem; + Label1: TLabel; + Overlay1: TMenuItem; + RenderOverlaySurfaceMenu: TMenuItem; + N701: TMenuItem; + N602: TMenuItem; + N501: TMenuItem; + N402: TMenuItem; + N301: TMenuItem; + N201: TMenuItem; + N102: TMenuItem; + N01: TMenuItem; + RenderOverlayDepthMenu: TMenuItem; + N16voxels2: TMenuItem; + N12voxels1: TMenuItem; + N8voxels2: TMenuItem; + N4voxels2: TMenuItem; + N2voxels2: TMenuItem; + N1voxel2: TMenuItem; + Quality1: TMenuItem; + RenderRefreshTimer: TTimer; + RenderPanel: TScrollBox; + RenderImage: TImage; + RenderImageBup: TImage; + Cutout1: TMenuItem; + RenderSmoothOverlay: TMenuItem; + FlipLRcheck: TMenuItem; + Settings1: TMenuItem; + Savesettings1: TMenuItem; + N2: TMenuItem; + Infinite1: TMenuItem; + Infinite2: TMenuItem; + Search1: TMenuItem; + BehindBG1: TMenuItem; + Infront1: TMenuItem; + Anydepth1: TMenuItem; + MIP1: TMenuItem; + Saveas36bitmaps1: TMenuItem; + BiasTrack: TTrackBar; + GainTrack: TTrackBar; + AzimuthEdit: TRxSpinEdit; + ElevationEdit: TRxSpinEdit; + ShadeEdit: TRxSpinEdit; + Label2: TLabel; + N3: TMenuItem; + Saverotationbitmaps1: TMenuItem; + ClipTrack: TTrackBar; + N4: TMenuItem; + Refresh1: TMenuItem; + QualityBtn: TPngSpeedButton; + procedure Save1Click(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure Close1Click(Sender: TObject); + procedure N1Click(Sender: TObject); + procedure N01Click(Sender: TObject); + procedure N1voxel1Click(Sender: TObject); + procedure N16voxels2Click(Sender: TObject); + procedure UpdateMenuClick(Sender: TObject); + procedure RenderPreciseInterpolationClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure RenderRefreshTimerTimer(Sender: TObject); + procedure EditChange(Sender: TObject); + procedure OverlayRenderDepthItem(Sender: TObject); + procedure RenderImageMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Cutout1Click(Sender: TObject); + procedure Savesettings1Click(Sender: TObject); + procedure UpdateRenderMRU; + procedure OpenRenderMRU(Sender:TObject); + procedure UpdateRenderDisplay; + procedure FormHide(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure CapBtnMenu1Click(Sender: TObject); + procedure SetSearch(Sender: TObject); +procedure RefreshRotation; + //procedure VolumeRotateMatrixX (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean;lNearSlicesClipInFrac: integer); + procedure Saveas36bitmaps1Click(Sender: TObject); + procedure BiasTrackChange(Sender: TObject); + procedure QualityBtnClick(Sender: TObject); + procedure Generateoversampledrenderingslow1Click(Sender: TObject); + procedure SaverClipClick(Sender: TObject); + procedure ClipTrackChange(Sender: TObject); + procedure RenderSmoothBGClick(Sender: TObject); + procedure Refresh1Click(Sender: TObject); + + private + { Private declarations } + public + //procedure SliceToFrac; { Public declarations } + end; +var + RenderForm: TRenderForm; + gZoom : single = 1; + gRenderDir,gRenderStartupFilename,gRenderDefaultsFilename:string; +implementation + +uses MultiSlice; + +{$R *.DFM} + +procedure TRenderForm.UpdateRenderDisplay; +begin + SetSubmenuWithTag(RenderBGSurfaceMenu,gRender.BGSurface); + SetSubmenuWithTag(RenderOverlaySurfaceMenu,gRender.OverlaySurface); + SetSubmenuWithTag(RenderBGDepthMenu,gRender.BGDepth); + SetSubmenuWithTag(RenderOverlayDepthMenu,gRender.OverlayDepth); + RenderSmoothBG.checked := gRender.SmoothBG; + RenderSmoothOverlay.checked := gRender.SmoothOverlay; + RenderPreciseInterpolation.Checked := gRender.Trilinear; + //RenderSurfaceOverlay.Checked := gRender.OverlayFromBGSurface; + SetSubmenuWithTag(Search1,gRender.OverlayFromBGSurface); + FlipLRCheck.Checked := gRender.FlipLR; + AzimuthEdit.value := gRender.Azimuth; + ElevationEdit.value := gRender.Elevation; + ShadeEdit.value := gRender.ShadePct; + RenderRefreshTimer.tag := -1; + RenderRefreshTimer.enabled := true; +end; + +procedure WriteRenderIniFile (lFilename: string); +var + lIniFile: TIniFile; + lInc: integer; +begin + if DiskFreeEx(lFilename) < 1 then + exit; + if not DirectoryExists(extractfiledir(lFilename)) then begin + mkDir(extractfiledir(lFilename)); + end; + lIniFile := TIniFile.Create(lFilename); + with gRender do begin + lIniFile.WriteString('BOOL', 'SmoothBG',Bool2Char( SmoothBG)); + lIniFile.WriteString('BOOL', 'SmoothOverlay',Bool2Char( SmoothOverlay)); + lIniFile.WriteString('BOOL', 'Trilinear',Bool2Char( Trilinear)); + lIniFile.WriteString('BOOL', 'ShowCutout',Bool2Char( ShowCutout)); + lIniFile.WriteString('BOOL', 'FlipLR',Bool2Char( FlipLR)); + lIniFile.WriteString('INT', 'OverlayFromBGSurface',IntToStr( OverlayFromBGSurface)); + //lIniFile.WriteString('INT', 'BGNearClipFrac',IntToStr(BGNearClipFrac)); + //lIniFile.WriteString('INT', 'OverlayNearClipFrac',IntToStr(OverlayNearClipFrac)); + lIniFile.WriteString('INT', 'Azimuth',IntToStr(Azimuth)); + lIniFile.WriteString('INT', 'Elevation',IntToStr(Elevation)); + lIniFile.WriteString('INT', 'BGSurface',IntToStr(BGSurface)); + lIniFile.WriteString('INT', 'OverlaySurface',IntToStr(OverlaySurface)); + lIniFile.WriteString('INT', 'BGDepth',IntToStr(BGDepth)); + lIniFile.WriteString('INT', 'OverlayDepth',IntToStr(OverlayDepth)); + lIniFile.WriteString('INT', 'CutoutBias',IntToStr(CutoutBias)); + lIniFile.WriteString('INT', 'ShadePct',IntToStr(ShadePct)); + lIniFile.WriteString('INT', 'cutoutLUTindex',IntToStr(cutoutLUTindex)); + for lInc := 1 to 3 do begin + lIniFile.WriteString('INT', 'CutoutLoFrac'+inttostr(lInc),IntToStr(CutoutFrac.Lo[lInc])); + lIniFile.WriteString('INT', 'CutoutHiFrac'+inttostr(lInc),IntToStr(CutoutFrac.Hi[lInc])); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure ReadRenderIniFile (lFilename: string); +var + lStr: string; + lIniFile: TIniFile; + lInc: integer; +begin + if not FileexistsEx(lFilename) then begin + exit; + end; + lIniFile := TIniFile.Create(lFilename); + lStr := lIniFile.ReadString('STR', 'Slices', '10,20,30');//file0 - last file viewed + with gRender do begin + SmoothBG := IniBool(lIniFile,'SmoothBG',SmoothBG); + SmoothOverlay := IniBool(lIniFile,'SmoothOverlay',SmoothOverlay); + Trilinear := IniBool(lIniFile,'Trilinear',Trilinear); + ShowCutout := IniBool(lIniFile,'ShowCutout',ShowCutout); + FlipLR := IniBool(lIniFile,'FlipLR',FlipLR); + OverlayFromBGSurface:= IniInt(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + //BGNearClip:= IniInt(lIniFile,'BGNearClip',0); + //OverlayNearClip:= IniInt(lIniFile,'OverlayNearClip',0); + //BGNearClipFrac:= IniInt(lIniFile,'BGNearClipFrac',-1); + //OverlayNearClipFrac:= IniInt(lIniFile,'OverlayNearClipFrac',-1); + Azimuth:= IniInt(lIniFile,'Azimuth',Azimuth); + Elevation:= IniInt(lIniFile,'Elevation',Elevation); + BGSurface:= IniInt(lIniFile,'BGSurface',BGSurface); + OverlaySurface:= IniInt(lIniFile,'OverlaySurface',OverlaySurface); + BGDepth:= IniInt(lIniFile,'BGDepth',BGDepth); + if BGDepth > 32000 then + BGDepth := 32000; + OverlayDepth:= IniInt(lIniFile,'OverlayDepth',OverlayDepth); + if OverlayDepth > 32000 then + OverlayDepth := 32000; + CutoutBias:= IniInt(lIniFile,'CutoutBias', CutoutBias); + ShadePct:= IniInt(lIniFile,'ShadePct', 0); + cutoutLUTindex:= IniInt(lIniFile,'cutoutLUTindex',cutoutLUTindex); + for lInc := 1 to 3 do begin + Cutout.Lo[lInc] := IniInt(lIniFile,'CutoutLo'+inttostr(lInc),Cutout.Lo[lInc]); + Cutout.Hi[lInc] := IniInt(lIniFile,'CutoutHi'+inttostr(lInc),Cutout.Hi[lInc]); + end; + + for lInc := 1 to 3 do begin + CutoutFrac.Lo[lInc] := IniInt(lIniFile,'CutoutLoFrac'+inttostr(lInc),-1); + CutoutFrac.Hi[lInc] := IniInt(lIniFile,'CutoutHiFrac'+inttostr(lInc),-1); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure TRenderForm.OpenRenderMRU(Sender:TObject); +var + lFilename: string; +begin + lFilename := gRenderDir+(Sender as TMenuItem).caption+'.ini' ; + ReadRenderIniFile(lFilename); + CutoutForm.Prep; + UpdateRenderDisplay; +end; + +procedure TRenderForm.UpdateRenderMRU; +var + NewItem: TMenuItem; + lSearchRec: TSearchRec; +begin + While Settings1.Count > 0 do Settings1.Items[0].Free; + if FindFirst(gRenderDir+'*.ini', faAnyFile, lSearchRec) = 0 then + repeat + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ParseFileName(ExtractFileName(lSearchRec.Name)); + NewItem.Onclick := OpenRenderMRU; + Settings1.Add(NewItem); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end; + +Function AziElevMatrix: TMatrix; +var + lLRFlipMatrix: TMatrix; +begin + gRender.Azimuth := RenderForm.AzimuthEdit.asInteger; + gRender.Elevation := RenderForm.ElevationEdit.asInteger; + result := ViewTransformMatrix( + coordSpherical, + ToRadians(RenderForm.AzimuthEdit.Value), + ToRadians(RenderForm.ElevationEdit.Value), + 3{Distance.Value},6{ScreenWidthHeight.Value},6{ScreenWidthHeight.Value},{ScreenToCamera.Value}3); + {The ViewTransformMatrix is all that is needed for other objects defined in world coordinates.} + if gRender.FlipLR then begin + // Mx(result); + lLRFlipMatrix := Matrix3D (-1,0,0,0, // 3D "graphics" matrix + 0,1,0,0, + 0,0,1,0, + 0,0,0,1); + + result := MultiplyMatrices(lLRFlipMatrix,Result); + end; +end; + +procedure InvertMatrixPoint (var lBackgroundImg: TBGImg; var lInMatrix: TMatrix; var lXin,lYin,lZIn, lXout,lYout,lZout: integer); +//convert mouse click to position +var + lZ,lY,lX,lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn: integer; + lMatrix: TMatrix; +begin + //lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutDim := round(gBGImg.RenderDim/gRender.Zoom) + else + lOutDim :=gBGImg.RenderDim; //11/2007b + lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (lBackgroundImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (lBackgroundImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (lBackgroundImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lX := (lXin-lOutPivot); + lY := ({lYin-}lOutPivot-lYin); + lZ := (lZin-lOutPivot); + lMatrix := InvertMatrix3D(lInMatrix); + lXout := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYout := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZout := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXOut := (lXOut+lXPivotIn); + lYOut := (lYOut+lYPivotIn); + lZOut := (lZOut+lZPivotIn); +end; + +procedure TRenderForm.Save1Click(Sender: TObject); +begin + //if (RenderImage.Picture.Graphic = nil) then begin + SaveImgAsPNGBMP (RenderImage); +end; + +procedure TRenderForm.Copy1Click(Sender: TObject); +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (RenderImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + RenderImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); +end; + +procedure TRenderForm.Close1Click(Sender: TObject); +begin + RenderForm.Close; +end; + +procedure TRenderForm.N1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N01Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlaySurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N1voxel1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N16voxels2Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.UpdateMenuClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gRender.FlipLR := FlipLRCheck.Checked; + gRender.SmoothBG := RenderSmoothBG.checked; + gRender.SmoothOverlay := RenderSmoothOverlay.checked; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderPreciseInterpolationClick(Sender: TObject); +begin + RenderPreciseInterpolation.Checked := not RenderPreciseInterpolation.Checked; + gRender.Trilinear := RenderPreciseInterpolation.Checked; + RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.FormShow(Sender: TObject); +var + lInc: integer; +begin + gRender.ClipFrac := 0; + gRender.Bias := 50; + gRender.Gain := 50; + gRender.cutoutLUTindex := 0; + gRender.BGSurface := 51; + gRender.OverlaySurface := 1; + gRender.BGDepth := 12; + gRender.OverlayDepth := 8; + gRender.Azimuth := 90; + gRender.Elevation := 45; + gRender.ShadePct := 0; + //gRender.OverlayNearClip := 0; + //gRender.BGNearClip := 0; + //gRender.OverlayNearClipFrac := -1; + //gRender.BGNearClipFrac := -1; + gRender.SmoothBG := true; + gRender.SmoothOverlay := false; + gRender.Trilinear := true; + gRender.FlipLR := false; + gRender.OverlayFromBGSurface := kBelow; + gRender.ShowCutout := false;//10/10/2006 + gRender.CutoutBias := 4; + for lInc := 1 to 3 do begin + gRender.CutoutFrac.Lo[lInc] := kMaxFrac div 2; + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end; + ReadRenderIniFile (gRenderStartupFilename); + UpdateRenderMRU; + UpdateRenderDisplay; +end; + +(*procedure ClipFracCheck (var lFrac,lSlice: integer); +//provide backward compatibility for files that explicitly report slices not fraction +var + lMax: integer; +begin + if lFrac >= 0 then + exit; + lFrac := 0; + lMax := MaxDim(gBGImg.ScrnDim[1],gBGImg.ScrnDim[2],gBGImg.ScrnDim[3]); + if (lSlice <= 0) or (lSlice > lMax) then + exit; + lFrac := round(lSlice/lMax*kMaxFrac); +end;*) + +function RAMok (var lBGImg: TBGImg): boolean; +var + lOutDim,lOutBytes,lBytesNeeded: int64; + lBGSz,lC: integer; +begin + lBGSz := lBGImg.ScrnDim[1]*lBGImg.ScrnDim[2]*lBGImg.ScrnDim[3]; + lOutDim := round(MaxDim(lBGImg.ScrnDim[1],lBGImg.ScrnDim[2],lBGImg.ScrnDim[3]) * gRender.Zoom); + lOutBytes := lOutDim*lOutDim*lOutDim; + lBytesNeeded := 0; + for lC := 0 to knMaxOverlay do begin + if (gMRIcroOverlay[lC].ScrnBufferItems >= lBGSz) then begin + + lBytesNeeded := lBytesNeeded + (lOutBytes - gMRIcroOverlay[lC].RenderBufferItems); + end; + + end; + //lFreeRam := FreeRAM; + //renderform.Caption := inttostr(lfreeram)+' '+inttostr(lBytesNeeded); + if (lBytesNeeded > freeRam) then begin + beep; + ImgForm.StatusLabel.Caption := 'Memory exhausted: unable to render at this quality'; + result := false; + + end else + result := true; +end; + +procedure TRenderForm.RefreshRotation; +var + lC: integer; + lMatrix: TMatrix; + lStartTime: DWord; +begin + lMatrix := AziElevMatrix; + Application.processmessages; + gRender.Zoom := gZoom; //11/2007b + gZoom := 1; + lStartTime := GetTickCount; + gRender.ClipFrac := ClipTrack.position; + gRender.Bias := BiasTrack.position; + gRender.Gain := GainTrack.Position; + gRender.Azimuth := round(AzimuthEdit.value); + gRender.Elevation := round(ElevationEdit.value); + if not RAMok(gBGImg) then exit; + VolumeRotateMatrix (gBGImg, gMRIcroOverlay[0],lMatrix, gRender.Trilinear,gRender.ShowCutout,true{,gRender.BGNearClipFrac}); + if RenderRefreshTimer.Enabled then exit; + Refresh; + for lC := 1 to knMaxOverlay do begin + VolumeRotateMatrix (gBGImg, gMRIcroOverlay[lC],lMatrix, gRender.Trilinear,false,false{,gRender.OverlayNearClipFrac}); + if RenderRefreshTimer.Enabled then exit; + end; + ImgForm.StatusLabel.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); +end; +procedure TRenderForm.RenderRefreshTimerTimer(Sender: TObject); +begin + RenderRefreshTimer.Enabled := false; + if gMRIcroOverlay[0].ScrnBufferItems=0 then begin + RenderImage.Width := 0; + exit; + end; + gRender.ShadePct := ShadeEdit.asInteger; + if (gMRIcroOverlay[0].RenderBufferItems=0) or (RenderRefreshTimer.Tag <> 0) or (AzimuthEdit.value<>gRender.Azimuth) or (ElevationEdit.value<>gRender.Elevation) then + RefreshRotation; + if RenderRefreshTimer.Enabled then exit; + //gZoom := 1; + RenderRefreshTimer.Tag := 0; + DrawRender; +end; + +procedure TRenderForm.EditChange(Sender: TObject); +begin + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.OverlayRenderDepthItem(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure RenderDrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +var lL,lT,lW,lH,lZoomPct: integer; +begin + lImage.Picture.Graphic := RenderForm.RenderImageBup.Picture.Graphic; + lZoomPct := 100; //ImageZoomPct(lImage); + lL := (lHorPos * lZoomPct) div 100; + lT := (lVerPos * lZoomPct) div 100; + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + //next horizontal lines + lImage.Canvas.MoveTo(0,lT); + lImage.Canvas.LineTo(lL-gBGImg.XBarGap,lT); + lImage.Canvas.MoveTo(lL+gBGImg.XBarGap,lT); + lImage.Canvas.LineTo(lW,lT); + //next vertical lines + lImage.Canvas.MoveTo(lL,0); + lImage.Canvas.LineTo(lL,lT-gBGImg.XBarGap); + lImage.Canvas.MoveTo(lL,lT+gBGImg.XBarGap); + lImage.Canvas.LineTo(lL,lH); +end; //Proc RenderDrawXBar + +procedure TRenderForm.RenderImageMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var lXrender,lYrender,lZrender,lXout,lYout,lZOut,lPixelOffset,lZoom: integer; +lMatrix: TMatrix; +begin + if ImgForm.XBarBtn.Down then + RenderDrawXBar ( X,Y,RenderImage); + //Next: find coordinates for orthogonal views: + lZoom := ImageZoomPct(RenderImage); + lXrender := round((X*100) / lZoom ); + lYrender := round(((Y)*100) / lZoom ); + + lPixelOffset := lXrender+ ((gBGImg.RenderDim-lYrender)*gBGImg.RenderDim); + //ImgForm.StatusLabel.caption := inttostr(lXrender)+'x'+inttostr(lYrender)+' -> '+inttostr(gMRIcroOverlay[kBGOverlayNum].RenderDepthBufferItems ); + if (lPixelOffset < 1) or (lPixelOffset >gBGImg.RenderDepthBufferItems ) then exit; + lZrender := gBGImg.RenderDepthBuffer[lPixelOffset]; + lXrender := round(lXrender / gRender.Zoom); + lYrender := round(lYrender / gRender.Zoom); + lZrender := round(lZrender / gRender.Zoom); + //caption := inttostr(lXrender)+'x'+inttostr(lYrender)+'x'+inttostr(LZrender)+' '+inttostr(gBGImg.RenderDepthBuffer[lPixelOffset]); + lMatrix := AziElevMatrix; + InvertMatrixPoint (gBGImg,lMatrix,lXrender,lYrender,lZrender, lXout,lYout,lZOut); + ImgForm.XViewEdit.value := lXOut; + ImgForm.YViewEdit.asInteger := lYOut; + ImgForm.ZViewEdit.asInteger := lZOut; +end; + +procedure TRenderForm.Cutout1Click(Sender: TObject); +begin + CutoutForm.Show; +end; + +procedure TRenderForm.Savesettings1Click(Sender: TObject); +begin + MultiSliceForm.MultiSaveDialog.InitialDir := extractfiledir(gRenderDir); + MultiSliceForm.MultiSaveDialog.FileName := 'a'+inttostr(gRender.Azimuth)+'e'+inttostr(gRender.Elevation); + if not MultiSliceForm.MultiSaveDialog.Execute then exit; + WriteRenderIniFile(MultiSliceForm.MultiSaveDialog.Filename); + UpdateRenderMRU; +end; + +procedure TRenderForm.FormHide(Sender: TObject); +begin + WriteRenderIniFile (gRenderDefaultsFilename); +end; + +procedure TRenderForm.FormCreate(Sender: TObject); +begin +//ThreadsRunning := 0; + gRenderDir := extractfiledir(paramstr(0))+'\render\'; + gRenderDefaultsFilename := gRenderDir + 'default.ini'; + gRenderStartupFilename := gRenderDefaultsFilename; +end; + +procedure TRenderForm.CapBtnMenu1Click(Sender: TObject); +begin + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end; + +procedure TRenderForm.SetSearch(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayFromBGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.Saveas36bitmaps1Click(Sender: TObject); +var + lnViews,lC,lAngle,lStartA: integer; + lAzi,lZoom: boolean; + lBaseFilename,lFilename: string; + lStartTime: DWord; +begin + lnViews:= ReadIntForm.GetInt('How many bitmaps for a 360-degree rotation?', 4,24,72); + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + lBaseFilename := ImgForm.SaveDialog1.Filename; + lAzi := false; + lZoom := false;//11/2007b + case MessageDlg('Rotate azimuth?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lAzi := true; + end; //case + case MessageDlg('Generate super-sampled (high quality) renderings?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lZoom := true; + end; //case + + if lAzi then + lStartA := AzimuthEdit.asInteger + else + lStartA := ElevationEdit.asInteger; + lStartTime := GetTickCount; + for lC := 1 to lnViews do begin + lAngle := round((lC-1) * (360/lnviews)); + if lAzi then + AzimuthEdit.value := lAngle + else + ElevationEdit.value := lAngle - 180; + RenderRefreshTimer.enabled := false; + if lZoom then + gZoom := 2; + RefreshRotation; + DrawRender; + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lAngle,3),'.png'); + SaveImgAsPNGBMPCore(RenderImage,lFilename); + end; //for each of 36 views + if lAzi then + AzimuthEdit.value := lStartA + else + ElevationEdit.value := lStartA; + ImgForm.StatusLabel.caption :=('batchtime(ms): '+inttostr(GetTickCount-lStartTime)); + //showmessage('batchtime(ms): '+inttostr(GetTickCount-lStartTime)) +end; + +procedure TRenderForm.BiasTrackChange(Sender: TObject); +begin + gRender.Bias := BiasTrack.position; + gRender.Gain := GainTrack.Position; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.QualityBtnClick(Sender: TObject); +begin + gZoom := 2; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; + +end; + +procedure TRenderForm.Generateoversampledrenderingslow1Click( + Sender: TObject); +begin + gZoom := 2; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.SaverClipClick(Sender: TObject); +var + lStartClip,lnClips,lC: integer; + lBaseFilename,lFilename: string; + lStartTime: DWord; +begin + lStartClip := gRender.ClipFrac; + lnClips:= ReadIntForm.GetInt('How many bitmaps for a 360-degree rotation?', 4,24,200); + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + lBaseFilename := ImgForm.SaveDialog1.Filename; + lStartTime := GetTickCount; + for lC := 1 to lnClips do begin + gRender.ClipFrac := round( ((lC-1)/lnClips)*kMaxFrac ); + DrawRender; + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lC,3),'.png'); + refresh; + SaveImgAsPNGBMPCore(RenderImage,lFilename); + end; //for each of 36 views + ImgForm.StatusLabel.caption :=('batchtime(ms): '+inttostr(GetTickCount-lStartTime)); + gRender.ClipFrac := lStartClip; +end; + +procedure TRenderForm.ClipTrackChange(Sender: TObject); +begin + gRender.ClipFrac := ClipTrack.Position; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderSmoothBGClick(Sender: TObject); +//smoothing does not require new rotation to be computed... +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gRender.SmoothBG := RenderSmoothBG.checked; + gRender.SmoothOverlay := RenderSmoothOverlay.checked; + RenderRefreshTimer.Enabled := true; + +end; + +procedure TRenderForm.Refresh1Click(Sender: TObject); +begin + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; + +end; + +end. diff --git a/niftiview7/render/default.ini b/niftiview7/render/default.ini new file mode 100755 index 0000000..2fcb764 --- /dev/null +++ b/niftiview7/render/default.ini @@ -0,0 +1,23 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=0 +Trilinear=1 +ShowCutout=0 +FlipLR=0 +[INT] +OverlayFromBGSurface=2 +Azimuth=260 +Elevation=30 +BGSurface=0 +OverlaySurface=178 +BGDepth=8 +OverlayDepth=16 +CutoutBias=3 +ShadePct=0 +cutoutLUTindex=0 +CutoutLoFrac1=1 +CutoutHiFrac1=1000 +CutoutLoFrac2=541 +CutoutHiFrac2=1000 +CutoutLoFrac3=1 +CutoutHiFrac3=1000 diff --git a/niftiview7/render_composite.pas b/niftiview7/render_composite.pas new file mode 100755 index 0000000..3e27be7 --- /dev/null +++ b/niftiview7/render_composite.pas @@ -0,0 +1,1064 @@ +unit render_composite; + +{$DEFINE SHOWPROG} +interface + +uses +{$IFDEF Unix} +lclintf, //gettickcount +{$ELSE} +Windows, +{$ENDIF} +{$IFNDEF NoThreads} + renderthds, +{$ENDIF} +{$IFDEF FPC} + LResources, //not sure if this is used... + {$ENDIF} + SysUtils, GraphicsMathLibrary,Classes, Graphics, Controls, Forms, Dialogs,ExtCtrls,Buttons, + nifti_img, nifti_hdr,define_types,nifti_img_view,StdCtrls, Menus,ClipBrd,ReadInt,cutout,IniFiles, + ComCtrls, pref_ini, nifti_types; +type + TRender = record + Zoom: single; + Cutout,CutoutFrac: TCutout; + //BGNearClipFrac, BGNearClip,OverlayNearClipFrac,OverlayNearClip, + ClipFrac, + Azimuth,Elevation,cutoutLUTindex,ShadePct, + OverlayFromBGSurface,BGSurface,OverlaySurface,BGDepth,OverlayDepth,CutoutBias,Gain,Bias: integer; + SmoothBG,SmoothOverlay,Trilinear,ShowCutout,FlipLR: boolean; + end; + procedure VolumeRotateMatrix (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean{;lNearSlicesClipIn: integer}); + procedure DrawRender; + procedure SliceToFrac(var lBGImg: TBGImg); + +var + + gRender:TRender; +const + kBelow = 1; + kInFront = 2; + +implementation + +uses math,render; + +procedure MinMaxFilt (var lHdr: TMRIcroHdr; var lFiltMin8bit, lFiltMax8bit: integer);var lMin,lMax: single; +begin +ReturnMinMax (lHdr,lMin,lMax, lFiltMin8bit, lFiltMax8bit); +end; + + +procedure Smooth2DImage (lX,lY: integer; lInBuffer: ByteP); +var + lSmoothBuffer: ByteP; + lLine,lLineStart,lInc,lOutPixel,lV: integer; +begin + GetMem (lSmoothBuffer , lX*lY); + FillChar(lSmoothBuffer^,lX*lY, 0); //zero array + for lLine:= (lY-1) downto 2 do begin + lLineStart := ((lLine-1)*(lX)); + for lInc := (lX-1) downto 2 do begin + lOutPixel := lLineStart+lInc; + lV := (lInBuffer^[lOutPixel] shl 3) + +(lInBuffer^[lOutPixel+1] shl 1)+(lInBuffer^[lOutPixel-1] shl 1) + +(lInBuffer^[lOutPixel+lX] shl 1)+(lInBuffer^[lOutPixel-lX] shl 1) + +(lInBuffer^[lOutPixel+lX+1])+(lInBuffer^[lOutPixel+lX-1]) + +(lInBuffer^[lOutPixel-lX+1])+(lInBuffer^[lOutPixel-lX-1]) + ; + lV := lV div 20; + lSmoothBuffer^[lOutPixel] := lV;//lV; + end; //for each column + end; //for each line (row) + Move(lSmoothBuffer^,lInBuffer^,lX*lY); + //Move(lSmoothBuffer^[1],lInBuffer[1]^,lX*lY); + FreeMem(lSmoothBuffer); +end; //proc Smooth2DImage + +procedure CreateOverlayRenderInfrontNear(var lBGHdr,lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDepth: Integer; var lQuadP: RGBQuadp; Smooth2D: boolean); +//changes Aug2007 - make sure search depth is not MAxInt - we get wrap around +var + lSrc,lOutBuffer: Bytep; + lLow,lHigh, + lIntensity,lDepth,lPixel,lSliceSz,lRenderSurface,lRenderDepth,lSamples: integer; +begin + if gBGImg.RenderDepthBufferItems < 1 then exit; + lSrc := lHdr.RenderBuffer;//lHdr.ScrnBuffer; + lSliceSz := lX*lY; + //lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lSliceSz); + fillchar(lOutBuffer^,lSliceSz,0); + lRenderSurface := lInRenderSurface; + //RenderForm.caption := inttostr(lRenderSurface); + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1; + for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lIntensity := 0; + lSamples := 0; + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+1 + else + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+lInRenderDepth; + if lRenderDepth >= lX then + lRenderDepth := lX-1; + lDepth := ((lPixel-1)* lX)+1; + lRenderDepth := lDepth + lRenderDepth; + while (lDepth < lRenderDepth) do begin + if (lSrc^[lDepth] > lRenderSurface) then begin + lIntensity := lIntensity+lSrc^[lDepth]; + inc(lSamples); + end; + + inc(lDepth); + end; + if lSamples > 0 then + lOutBuffer^[lPixel]:= lIntensity div lSamples; + end; //for each pixel with a background image +end; //for each pixel + (*for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lDepth := 0; + lIntensity := 0; + lSliceOffset := 0; + lSamples := 0; + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+lInRenderDepth; + while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin + if (lSrc^[lSliceOffset+lPixel] > lRenderSurface) then begin + lIntensity := lIntensity+lSrc^[lSliceOffset+lPixel]; + inc(lSamples); + end; + inc(lSliceOffset,lSliceSz); + inc(lDepth); + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lDepth := lRenderDepth; //only show surface for cutout + end; + if lSamples > 0 then + lOutBuffer^[lPixel]:= lIntensity div lSamples; + end ; //if background + end; *) + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); +//Mar2007 start +if lHdr.LUTfromZero then begin + MinMaxFilt(lHdr,lLow,lHigh); + //fx(lLow,lHigh); + if lLow > 0 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lLow then + lOutBuffer^[lPixel] := 0; + if lHigh < 255 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lHigh then + lOutBuffer^[lPixel] := 0; +end; + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lHdr.LUT[lOutBuffer^[lPixel]]; + Freemem(lOutBuffer); +end; +procedure CreateOverlayRenderBehind(var lBGHdr,lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDepth: Integer; var lQuadP: RGBQuadp; Smooth2D: boolean); +var + lSrc,lOutBuffer: Bytep; + lQ,lLow,lHigh, + lSurfaceDepth,lIntensity,lDepth,lPixel,lSliceSz,lRenderSurface,lRenderDepth: integer; +begin + if gBGImg.RenderDepthBufferItems < 1 then exit; + lSrc := lHdr.RenderBuffer;//lHdr.ScrnBuffer; + lSliceSz := lX*lY; + //lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lSliceSz); + fillchar(lOutBuffer^,lSliceSz,0); + //lRenderDepth := lInRenderDepth; + //if (lRenderDepth < 1) or (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + // lRenderDepth := 1; + lRenderSurface := lInRenderSurface; + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1; + for lPixel := 1 to lSliceSz do begin + lSurfaceDepth := abs(gBGImg.RenderDepthBuffer^[lPixel]); + if (lSurfaceDepth > 0) and (lSurfaceDepth <= lX) then begin //background surface at this voxel + lIntensity := 0; + lRenderDepth := (lSurfaceDepth-1)+lInRenderDepth; + if lRenderDepth >= lX then + lRenderDepth := lX-1; + lDepth := ((lPixel-1)* lX)+1; + lRenderDepth := lDepth + lRenderDepth; + lDepth := lDepth + lSurfaceDepth-1; + lQ := 0; + while (lDepth < lRenderDepth) do begin + if (lSrc^[lDepth] > lRenderSurface) and (lSrc^[lDepth] > lIntensity) then + lIntensity := lSrc^[lDepth]; + if (gBGImg.RenderDepthBuffer^[lPixel] < 0) and (lQ > 3) then + lDepth := lRenderDepth; //only show surface for cutout + inc(lDepth); + inc(lQ); + end; + + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel with a background image +end; //for each pixel + + (*for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lDepth := 0; + lIntensity := 0; + lSliceOffset := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)*lSliceSz; //start with nearest slice + while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin + if (lSrc^[lSliceOffset+lPixel] > lRenderSurface) and (lSrc^[lSliceOffset+lPixel] > lIntensity) then + lIntensity := lSrc^[lSliceOffset+lPixel]; + inc(lSliceOffset,lSliceSz); + inc(lDepth); + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lDepth := lRenderDepth; //only show surface for cutout + end; + lOutBuffer^[lPixel]:= lIntensity; + end; //background surface at this voxel + end; *) + + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); + +//Mar2007 start +if lHdr.LUTfromZero then begin + MinMaxFilt(lHdr,lLow,lHigh); + //fx(lLow,lHigh); + if lLow > 0 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lLow then + lOutBuffer^[lPixel] := 0; + if lHigh < 255 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lHigh then + lOutBuffer^[lPixel] := 0; +end; +//Mar2007 end + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lHdr.LUT[lOutBuffer^[lPixel]]; + Freemem(lOutBuffer); +end; + + +Function AziElevMatrix : TMatrix; +var + lLRFlipMatrix: TMatrix; +begin + // gRender.Azimuth := RenderForm.AzimuthEdit.value; + //gRender.Elevation := RenderForm.ElevationEdit.value; + result := ViewTransformMatrix( + coordSpherical, + ToRadians(gRender.Azimuth), + ToRadians(gRender.Elevation), + 3{Distance.Value},6{ScreenWidthHeight.Value},6{ScreenWidthHeight.Value},{ScreenToCamera.Value}3); + {The ViewTransformMatrix is all that is needed for other objects defined + in world coordinates.} + if {RenderForm.FlipLRcheck.checked} gRender.FlipLR then begin + lLRFlipMatrix := Matrix3D (-1,0,0,0, // 3D "graphics" matrix + 0,1,0,0, + 0,0,1,0, + 0,0,0,0); + result := MultiplyMatrices(lLRFlipMatrix,Result); + end; +end; + +procedure ShadeCutoutCrease (var lRenderBuffer: bytep); +var +lZ,lY,lX: single; + lXin,lYin,lZIn,lXm,lYm,lZm,lPixel, + lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn, + lXlo,lXhi,lYlo,lYhi,lZlo,lZhi,lYOffset: integer; + lClose,lScale: single; + lMatrix: TMatrix; +begin + lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutPivot := (round(gBGImg.RenderDim/gRender.Zoom)+1) shr 1 + else + lOutPivot :=(gBGImg.RenderDim+1) shr 1; //11/2007b + //lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (gBGImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (gBGImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (gBGImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lMatrix := InvertMatrix3D(AziElevMatrix); + //next: dilate borders by 1 pixel - draw crease INSIDE cutout + lXlo := gRender.CutOut.Lo[1]-1; + lXhi := gRender.CutOut.Hi[1]+1; + lYlo := gRender.CutOut.Lo[2]-1; + lYhi := gRender.CutOut.Hi[2]+1; + lZlo := gRender.CutOut.Lo[3]-1; + lZhi := gRender.CutOut.Hi[3]+1; +lScale := 1/gRender.Zoom; //11/2007 + + for lYin := 1 to lOutDim do begin + lYOffset := ((gBGImg.RenderDim-lYin)*gBGImg.RenderDim); + for lXin := 1 to lOutDim do begin + lPixel := lXin+ lYOffset; + if gBGImg.RenderDepthBuffer^[lPixel]<0 then begin + lZin := abs(gBGImg.RenderDepthBuffer^[lPixel]); + lX := (lXin *lScale)-lOutPivot ; + lY := lOutPivot -(lYin * lScale); + lZ := (lZin * lScale)-lOutPivot; + lXm := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYm := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZm := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXm := (lXm+lXPivotIn); + lYm := (lYm+lYPivotIn); + lZm := (lZm+lZPivotIn); + if abs(lXlo-lXm) < abs(lXhi-lXm) then + lXm := abs(lXlo-lXm) + else + lXm := abs(lXhi-lXm); + if abs(lYlo-lYm) < abs(lYhi-lYm) then + lYm := abs(lYlo-lYm) + else + lYm := abs(lYhi-lYm); + if abs(lZlo-lZm) < abs(lZhi-lZm) then + lZm := abs(lZlo-lZm) + else + lZm := abs(lZhi-lZm); + if (lXm < lYm) and (lZm < lYm) then + lYm := lZm //Y is furthest, replace with Z + else if lZm < lXm then //X is furthest, replace with Z + lXm := lZm; + lClose := sqrt((lXm*lXm) + (lYm*lYm)); + if lClose < 8 then begin + lClose := 1-sqr(1-(lClose/8)); + lRenderBuffer^[lPixel] := round(lRenderBuffer^[lPixel]*(0.33+(0.67*lClose))); + end; + end; + end; //for lYin + end; //for lXin +end; + +procedure LUTbiasX (var lOutLUT : TLUT); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick +Graphics Gems IV, p379-382, April 1994 } +var + lIndex: integer; + lA,lT,lBias: single; + lLUT: TLUT; +begin + if gRender.CutoutBias = 4 then exit; + lA := (gRender.CutoutBias+1)/10; + + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[round(lBias)]; + {lHdr.LUT[lIndex].rgbRed := round(lBias*lHdr.LUT[lIndex].rgbRed); + lHdr.LUT[lIndex].rgbGreen := round(lBias*lHdr.LUT[lIndex].rgbGreen); + lHdr.LUT[lIndex].rgbBlue := round(lBias*lHdr.LUT[lIndex].rgbBlue);} + //lHdr.LUT[lIndex].rgbReserved := kLUTalpha; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + +procedure LUTgainX (var lOutLUT : TLUT; lBiasIn,lGainIn: integer {0..99}); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick Graphics Gems IV, p379-382, April 1994 } +var + lIndex,lV: integer; + lA,lG,lT,lGain: single; + lLUT: TLUT; +begin + if (lGainIn = 50) and (lBiasIn = 50){gRender.CutoutBias = 4} then exit; + lA := (lBiasIn)/100; + if lA = 0 then + lA := 0.000001; + lG := (lGainIn)/100; + if lG = 0 then + lG := 0.00001; + if lG = 1 then + lG := 0.99999; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //apply bias + lT := (lt/((1/la-2)*(1-lt)+1)) ; + //next apply gain + if lT < 0.5 then + lGain := (lT/((1/lG-2)*(1-2*lT)+1)) + else + lGain := (( (1/lG-2)*(1-2*lT)-lT ) / ( (1/lG-2)*(1-2*lT)-1 ) ); + lGain := lGain / lT; + lV := round(255*lT*lGain); + if lV > 255 then + lV := 255; + if lV < 0 then + lV := 0; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[lV]; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + +function SmoothShading (lX,lY: integer; lRenderDepthBuffer: SmallintP): boolean; +var + kRenderInfiniteDepth,lPrevLineStart,lNextLineStart,lLineStart,lScanLines, + lGap,lDepthSum,lWeightSum,lFar,lClose,lCenter,lInc,lXmG: integer; + lRenderDepthBufferS: SmallIntP; +procedure AddPt (lI,lW: integer; var lSumI,lSumW: integer); +begin + if lI = kRenderInfiniteDepth then exit; + lSumI := lSumI + (lW*lI); //add scaled value + lSumW := lSumW + lW;//add weight +end; +//problem - smoothing gives embossed look! +begin //func Smoothshading + kRenderInfiniteDepth := 0; + result := false; + if (gRender.Zoom < 1) or (lY < 5) or (lX < 5) or (gBGImg.RenderDepthBufferItems <> (lX * lY)) then + exit; + lFar := 2; + lClose := 3; + lCenter := 5; + lGap := trunc((gRender.Zoom-0.001)/1)+1; //must be at least 1! + lXmG := lX-lGap; + Getmem(lRenderDepthBufferS,lX*lY*sizeof(smallint)); + for lInc := 1 to (lX*lY) do + lRenderDepthBufferS^[lInc] := lRenderDepthBuffer^[lInc]; + + for lScanlines := (1+lGap) to (lY - lGap) do begin //can not compute angle for 1st and last scanline + lLineStart := (lScanLines-1)*lX; //inc from 0 + lPrevLineStart := lLineStart-(lX*lGap); //inc from 0 + lNextLineStart := lLineStart+(lX*lGap); //inc from 0 + for lInc := (1+lGap) to (lXmG) do begin + lWeightSum := 0; + lDepthSum := 0; + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc-1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc+1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc-1],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc],lCenter,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc+1],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc-1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc+1],lFar,lDepthSum,lWeightSum); + if lWeightSum > 0 then + lRenderDepthBufferS^[lLineStart+lInc] := round(lDepthSum/lWeightSum); + end; //columns + end; //for scanlines: rows + for lInc := 1 to (lX*lY) do + lRenderDepthBuffer^[lInc] := lRenderDepthBufferS^[lInc]; + freemem(lRenderDepthBufferS); + result := true; +end; //function SmoothShading + + +function IlluminationShading (lX,lY,lPct: integer; lImgBuffer: bytep; lRenderDepthBuffer: SmallintP): boolean; +var + kRenderInfiniteDepth,lXm1,lPrevLineStart,lNextLineStart,lLineStart,lScanLines, + lIntensity,lInc,lGrayMin,lGrayMax: integer; + lShadeFrac,lImgFrac, + lPhongMagic,lMagic,lYVal,lXVal,lNormalPlane,lXLight,lYLight,lZLight,lLightVectorNormalise: single; + lShadeBuffer: bytep; +begin //func illumination shading + + result := false; + if (lPct < 1) or (lY < 5) or (lX < 5) or (gBGImg.RenderDepthBufferItems <> (lX * lY)) then + exit; + lMagic := 1; + lPhongMagic := 1; + kRenderInfiniteDepth := 0; + lXLight := 0;//RenderForm.XL.value / 100;//lXLight / lLightVectorNormalise; + lYLight := -0.5;//Renderform.YL.value / 100;//lYLight / lLightVectorNormalise; + lZLight := -1;//RenderForm.ZL.value / 100;//lZLight / lLightVectorNormalise; + lLightVectorNormalise := sqrt(sqr(lXLight)+sqr(lYLight)+sqr(lZLight)); + lXLight := lXLight / lLightVectorNormalise; + lYLight := lYLight / lLightVectorNormalise; + lZLight := lZLight / lLightVectorNormalise; + lGrayMin := 0{64}; + lGrayMax := 255 - lGrayMin; + lXm1 := lX-1; + Getmem(lShadeBuffer,lX*lY*sizeof(byte)); + fillchar(lShadeBuffer^,lX*lY,0); + + for lScanlines := 2 to (lY - 1) do begin //can not compute angle for 1st and last scanline + lLineStart := (lScanLines-1)*lX; //inc from 0 + lPrevLineStart := lLineStart-lX; //inc from 0 + lNextLineStart := lLineStart+lX; //inc from 0 + for lInc := 2 to (lXm1) do begin + if lImgBuffer^[lLineStart+lInc] <> 0 then begin //only shade non-zero intensities + if ( lRenderDepthBuffer^[lPrevLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lPrevLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lPrevLineStart+lInc+1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc+1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc+1]<>kRenderInfiniteDepth) then begin + lYVal := lRenderDepthBuffer^[lPrevLineStart+lInc-1]+lRenderDepthBuffer^[lPrevLineStart+lInc]+lRenderDepthBuffer^[lPrevLineStart+lInc+1] + -lRenderDepthBuffer^[lNextLineStart+lInc-1]-lRenderDepthBuffer^[lNextLineStart+lInc]-lRenderDepthBuffer^[lNextLineStart+lInc+1]; + lXVal := lRenderDepthBuffer^[lPrevLineStart+lInc-1]+lRenderDepthBuffer^[lLineStart+lInc-1]+lRenderDepthBuffer^[lNextLineStart+lInc-1] + -lRenderDepthBuffer^[lPrevLineStart+lInc+1]-lRenderDepthBuffer^[lLineStart+lInc+1]-lRenderDepthBuffer^[lNextLineStart+lInc+1]; + lNormalPlane := sqrt(sqr(lXVal)+sqr(lYVal)+sqr(lMagic)); + if lNormalPlane <> 0 then begin + lNormalPlane := -((-lXLight*lXVal)-(lYLight*lYVal)+lMagic*lZLight)/lNormalPlane; + if {lImageAndShade} false then begin + lNormalPlane := Power(lNormalPlane,lPhongMagic); + //lIntensity := gProjBuffer[lLineStart+lInc]; + //lIntensity := lPropShadingPivot+round((lPctImage*(lIntensity-lPropShadingPivot))+(lPctShade*(lNormalPlane-0.5)) ); + if lIntensity > 254 then lIntensity := 254; + lShadeBuffer^[lLineStart+lInc] := lIntensity; + end else begin //shading only + //if lAbbaRandom then //abba + lNormalPlane := (lNormalPlane+1) / 2; + if lNormalPlane > 0 then begin + lNormalPlane := Power(lNormalPlane,lPhongMagic); + //if lAbbaRandom then //abba + //if lNormalPlane < 0.5 then lNormalPlane := 1-lNormalPlane; //backlighting + lShadeBuffer^[lLineStart+lInc] := lGrayMin{64}+ round(lNormalPlane*(lGrayMax)); + end else + lShadeBuffer^[lLineStart+lInc] := lGrayMin; + end; //Shading vs ImageAndShading + end; //NormalPlane = 0 + end else begin //samples for each pixel + if {lImageAndShade}false then + lShadeBuffer^[lLineStart+lInc] := 0//lPropShadingPivot+round((lPctImage*(gProjBuffer[lLineStart+lInc]-lPropShadingPivot))+(lPctShade*(-0.5)) )//1362 + else + lShadeBuffer^[lLineStart+lInc] := lGrayMin;//1363;'# 20{64}; + end; + end; //only shade non-zero intensities + end; //columns + end; //for scanlines: rows + if lPct > 99 then begin + for lInc := 1 to (lX*lY) do + lImgBuffer^[lInc] := lShadeBuffer^[lInc]; + + end else begin //partial shade + lImgFrac := (100-lPct)/100; + lShadeFrac := lPct/100; + for lInc := 1 to (lX*lY) do + lImgBuffer^[lInc] := round((lImgBuffer^[lInc]* lImgFrac) + (lShadeBuffer^[lInc]*lShadeFrac )); + end; + freemem(lShadeBuffer); + result := true; +end; //function illuminationshading + +procedure LUTLoad( lLUTindex: integer; var lLUT: TLUT); +var + lHdr: TMRIcroHdr; + lStr: string; + lInc: integer; +begin + //gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + if lLUTindex < knAutoLUT then begin + LoadMonochromeLUT(lLUTindex,gBGImg,lHdr); + end else begin //if B&W lut + lStr := gColorSchemeDir+pathdelim+ImgForm.LUTdrop.Items.Strings[lLUTindex]+'.lut'; + if not FileExistsEX(lStr) then + showmessage('Can not find '+lStr); + LoadColorScheme(lStr, lHdr); + end; + for lInc := 0 to 255 do + lLUT[lInc] := lHdr.LUT[lInc]; +end; + + +procedure CreateRender(var lBGHdr, lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDpeth: Integer; var lQuadP: RGBQuadp; Smooth2D, NormalizeIntensity,lCreateDepthBuffer: boolean;lUseDepthBuffer: integer); +var + lLUT : array [0..255] of byte; + lrgbLUT: TLUT;// array[0..255] of TRGBQuad; + //lTime: DWord; + lSrc,lOutBuffer: Bytep; + lShade,lShadePrecise: boolean; + lPreciseDepthBuffer: Smallintp; + lMaxInten,lDepth,lPixel,lSamples,lSliceOffset,lIntensity,lSliceSz,lSliceEnd,lSliceStart, + lVolSz,lRenderDepth,lRenderSurface,lTemp,lNear,lSubPixel,lClip: integer; +begin + + lShade := false; + lShadePrecise := false; + if {(gRender.BGNearClip<>0) or} (gRender.ShowCutout) then + lMaxInten := 254 + else + lMaxInten := 257; + lRenderDepth := lInRenderDpeth; + //RenderForm.caption := inttostr(lRenderDepth); + {if (lHdr.IMgBufferItems > 0) and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + RenderForm.caption := 'surface'; } + if (lHdr.IMgBufferItems > 0){2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderDepth := 1; + lRenderSurface := lInRenderSurface; + //if not lCreateDepthBuffer then + + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1 + else begin + //make sure at least some voxels are below air-surface threshold + if (lHdr.WindowScaledMin <= (Raw2ScaledIntensity(lHdr,lHdr.GlMinUnscaledS) )) and (lHdr.WindowScaledMax <> 0 ) then begin + lTemp := round( (Raw2ScaledIntensity(lHdr,lHdr.GlMinUnscaledS)-lHdr.WindowScaledMin)/(lHdr.WindowScaledMax)*255); + //showmessage(inttostr(lTemp)); + if lTemp >= lRenderSurface then + lRenderSurface := lTemp + 1; + end; + end; + + if (lUseDepthBuffer=kBelow) then begin + CreateOverlayRenderBehind(lBGHdr,lHdr, lX,lY,lZ,lRenderSurface,lRenderDepth, lQuadP, Smooth2D); + exit; + end; + + if (lUseDepthBuffer=kInFront) then begin + CreateOverlayRenderInfrontNear(lBGHdr,lHdr, lX,lY,lZ,lRenderSurface,lRenderDepth, lQuadP, Smooth2D); + exit; + end; + lSrc := lHdr.RenderBuffer; + lSliceSz := lX*lY; + lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lX*lY); + //gRender.ClipFrac := kMaxFrac div 2; + lClip := round(gRender.ClipFrac/kMaxFrac * lX); + if lClip >= lX then + lClip := 0; + if lCreateDepthBuffer then begin + if (gRender.ShadePct > 0) then begin + lShade := true; + if lRenderDepth > 0 then begin//not MIP + lShadePrecise := true; + getmem(lPreciseDepthBuffer,lSliceSz * sizeof(smallint)); + fillchar(lPreciseDepthBuffer^,lSliceSz* sizeof(smallint),0); + end; + end; + if gBGImg.RenderDepthBufferItems <> lSliceSz then begin + if gBGImg.RenderDepthBufferItems > 0 then + Freemem(gBGImg.RenderDepthBuffer); + gBGImg.RenderDepthBufferItems := lSliceSz; + GetMem(gBGImg.RenderDepthBuffer,lSliceSz*sizeof(smallint)); + end; + fillchar(gBGImg.RenderDepthBuffer^,lSliceSz* sizeof(smallint),0); + //lTime := gettickcount; + if lRenderDepth < 1 then begin//MIP + for lPixel := 1 to lSliceSz do begin + lIntensity := 0; + lSliceStart := ((lPixel-1)* lX)+1; + lSliceOffset := lSliceStart+lClip; //start with nearest slice + lSliceEnd := lSliceStart + lX; + while (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and (lSrc^[lSliceOffset] > lIntensity) then begin + lIntensity := lSrc^[lSliceOffset]; + gBGImg.RenderDepthBuffer^[lPixel] := lSliceOffset - lSliceStart; + end; + inc(lSliceOffset,1); + end; //while traversing front to back + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel + end else begin //if MIP else use opacity filter... + for lPixel := 1 to lSliceSz do begin + lDepth := 0; + lSamples := 0; + lIntensity := 0; + lSliceStart := ((lPixel-1)* lX)+1; + lSliceOffset := lSliceStart+lClip; //start with nearest slice + lSliceEnd := (lPixel* lX); + while (lDepth < lRenderDepth) and (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and ((lDepth > 0) or (lSrc^[lSliceOffset] > lRenderSurface)) then begin + inc(lDepth); + if (lSrc^[lSliceOffset] > lRenderSurface) then begin + lIntensity := lIntensity+ lSrc^[lSliceOffset]; + inc(lSamples); + end; + if (lDepth = 1) then begin + gBGImg.RenderDepthBuffer^[lPixel] := lSliceOffset - lSliceStart; + + if (gBGImg.RenderDepthBuffer^[lPixel]=lCLip ) or ((gBGImg.RenderDepthBuffer^[lPixel] > 1) and (lSrc^[lSliceOffset-1]>=lMaxInten)) then begin //cutout + if lSrc^[lSliceOffset-1]=lMaxInten-1 then + lIntensity := 0; + lDepth := lRenderDepth; + gBGImg.RenderDepthBuffer^[lPixel] := -gBGImg.RenderDepthBuffer^[lPixel]; //negative: this is a cutout + end; + if lShade then begin + if (gBGImg.RenderDepthBuffer^[lPixel] > 1) then begin //estimate surface depth with sub-pixel accuracy + lNear := lSrc^[lSliceOffset-1]; + lSubPixel := lIntensity-lNear; //delta + lSubPixel := round(((lRenderSurface-lNear)/lSubPixel)*10); + if lNear >= lMaxInten then //cutout + lSubPixel := 0; + end else + lSubpixel := 0; + lPreciseDepthBuffer^[lPixel] := (gBGImg.RenderDepthBuffer^[lPixel] * 10)+lSubPixel; + end; + end; + end; + inc(lSliceOffset,1); + + end; //while no voxel found + if lDepth > 0 then + lIntensity := lIntensity div lSamples; + //lIntensity := lIntensity div lDepth; //mean of nDepth voxels + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel 1..sliceSz + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); //only smooth volume renderings - not MIPS (they looked embossed) + end; //if not MIP +end else begin //do not create depth buffer + for lPixel := 1 to lSliceSz do begin + lDepth := 0; + lSamples := 0; + lIntensity := 0; + lSliceOffset := ((lPixel-1)* lX)+1+lClip; //start with nearest slice + lSliceEnd := (lPixel* lX); + while (lDepth < lRenderDepth) and (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and ((lDepth > 0) or (lSrc^[lSliceOffset] > lRenderSurface)) then begin + inc(lDepth); + if (lSrc^[lSliceOffset] > lRenderSurface) then begin + lIntensity := lIntensity+ lSrc^[lSliceOffset]; + inc(lSamples); + end; + end; + inc(lSliceOffset,1); + end; //while no voxel found + if lDepth > 0 then + lIntensity := lIntensity div lSamples; + //lIntensity := lIntensity div lDepth; //mean of nDepth voxels + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel +end; //volume render without depth buffer + //RenderForm.Caption := inttostr(gettickcount - lTime)+' '+inttostr(lRenderDepth); + if (NormalizeIntensity) and (lRenderSurface < 254) then begin //do BEFORE shading! + for lPixel := 0 to 255 do + lLUT[lPixel] := 0; + for lPixel := lRenderSurface to 255 do + lLUT[lPixel] := round(255*(lPixel-lRenderSurface)/(255-lRenderSurface)); + for lPixel := 1 to lSliceSz do + lOutBuffer^[lPixel] := lLUT[lOutBuffer^[lPixel]]; + end; + if lShade then begin + if lShadePrecise then begin + SmoothShading (lX,lY,lPreciseDepthBuffer); + IlluminationShading(lX,lY,gRender.ShadePct,lOutBuffer,lPreciseDepthBuffer{gBGImg.RenderDepthBuffer} ); + freemem(lPreciseDepthBuffer); + end else + IlluminationShading(lX,lY,gRender.ShadePct,lOutBuffer,gBGImg.RenderDepthBuffer); + + end;//shading + + for lPixel := 0 to 255 do + lrgbLUT[lPixel] := lHdr.LUT[lPixel]; + if (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + LUTGainX(lrgbLUT,gRender.Bias,gRender.Gain ); //Mar2007 + + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lrgbLUT[lOutBuffer^[lPixel]]; + if ((lClip >0) or (gRender.ShowCutout)) and (lCreateDepthBuffer) then begin //make cutout grayscale, shade edges + if gRender.ShowCutout then + ShadeCutoutCrease(lOutBuffer); + LUTLoad(gRender.cutoutLUTindex,lrgblut);//11/2007 + {for lPixel := 0 to 255 do begin + lrgbLUT[lPixel].rgbRed := lPixel; + lrgbLUT[lPixel].rgbGreen := lPixel; + lrgbLUT[lPixel].rgbBlue := lPixel; + lrgbLUT[lPixel].rgbReserved := kLUTalpha; + + end;}//create grayscale LUT + LUTBiasX(lrgbLUT); + for lPixel := 1 to lSliceSz do + if gBGImg.RenderDepthBuffer^[lPixel]<0 then //cutout + lQuadP^[lPixel]:= lrgbLUT[lOutBuffer^[lPixel]]; + end; //if BGimg with Cutout + Freemem(lOutBuffer); +end; + +function RenderDepth (lVal: integer): integer;//11/2007 +begin + if (lVal > 0) and (lVal < 16000) and (gBGImg.ScrnMM[1] > 0.1) and (gBGImg.ScrnMM[1] < 10) then begin + result:= round (lVal / gBGImg.ScrnMM[1]); + if result < 1 then + result := 1; + end else + result := lVal; +result := round(result * gRender.Zoom); +end; + +procedure DrawRender; +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lUseBGSurface,lnOverlay,lOverlay, lX,lY,lZ,lSliceSz,lRenderSurface,lRenderDepth: longint; + lBG0Clr,lOverlay0Clr: DWord; + lSmooth : boolean; +begin + lRenderSurface := gRender.BGSurface; + //lRenderDepth:= gRender.BGDepth; + lRenderDepth:= RenderDepth(gRender.BGDepth);//11/2007 + lSmooth := gRender.SmoothBG; + lUseBGSurface := gRender.OverlayFromBGSurface ; + lX := gMRIcroOverlay[kBGOverlayNum].RenderDim; + lY := lX; + lZ := lX; + lSliceSz := (lX * lY); + if (gMRIcroOverlay[kBGOverlayNum].RenderBufferItems=0)or (lX < 2) or (lY < 2) or (lZ < 2) or ((lX*lY*lZ) > gMRIcroOverlay[kBGOverlayNum].RenderBufferItems{ScrnBufferItems}) then + exit; + GetMem ( lBGQuadP, lSliceSz*4); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[kBGOverlayNum], lX,lY,lZ,lRenderSurface,lRenderDepth, lBGQuadP, lSmooth, true,true,0); +//next: overlays + lSmooth := gRender.SmoothOverlay; + lRenderSurface := gRender.OverlaySurface; + //lRenderDepth:= gRender.OverlayDepth; + lRenderDepth:= RenderDepth(gRender.OverlayDepth);//11/2007 +lnOverlay := 0; +lBG0Clr:= (gMRIcroOverlay[0].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].RenderBufferItems{ScrnBufferItems} > 0 then begin + + if lOverlay = kVOIOverlayNum then //Aug2007 + lRenderSurface := 0 + else + lRenderSurface := gRender.OverlaySurface;// + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= (gMRIcroOverlay[lOverlay].LUTinvisible); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay],lX,lY,lZ,lRenderSurface,lRenderDepth,lOverlayQuadP,lSmooth,false,false,lUseBGSurface); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay], lX,lY,lZ,lRenderSurface,lRenderDepth,l2ndOverlayQuadP,lSmooth,false,false,lUseBGSurface); + lOverlay0Clr:= (gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + //lBG0Clr := DWord(lHdr.LUTinvisible); + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image +//RenderForm.RenderPanel.Tag := 100;//pyrex + SetDimension32(lY,lX, lBGQuadP, gBGImg, RenderForm.RenderImage,RenderForm.RenderPanel); + SetDimension32(lY,lX, lBGQuadP, gBGImg, RenderForm.RenderImageBUP,RenderForm.RenderPanel); + FreeMem ( lBGQuadP); + if gBGImg.RenderDepthBufferItems > 0 then //negative depth was used for cutouts, now set to true depth + for lX := 1 to gBGImg.RenderDepthBufferItems do + gBGImg.RenderDepthBuffer^[lX] := abs(gBGImg.RenderDepthBuffer^[lX]); +end; + +procedure SliceToFrac(var lBGImg: TBGImg); +var + lInc: integer; +begin + SortCutOut (gRender.CutOut); + for lInc := 1 to 3 do begin + if lBGImg.ScrnDim[lInc] < 1 then begin + gRender.CutoutFrac.Lo[lInc] := round (0.5* kMaxFrac); + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end else begin + gRender.CutoutFrac.Lo[lInc] := round(kMaxFrac * gRender.Cutout.Lo[lInc]/lBGImg.ScrnDim[lInc]); + gRender.CutoutFrac.Hi[lInc] := round(kMaxFrac * gRender.Cutout.Hi[lInc]/lBGImg.ScrnDim[lInc]); + end; + end; +end; + +procedure SetLimits(var lBGImg: TBGImg); +var lInc: integer; +lUpdateCutout: boolean; +lScale: single; +begin + SortCutOut (gRender.CutOutFrac); + if gRender.CutoutFrac.Lo[1] < 0 then + SliceToFrac(lBGImg); + lScale := 1/kMaxFrac; + for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := round(gBGImg.ScrnDim[lInc] * lScale * gRender.CutoutFrac.Lo[lInc]); + gRender.Cutout.Hi[lInc] := round(gBGImg.ScrnDim[lInc] * lScale * gRender.CutoutFrac.Hi[lInc]); + end; + lUpdateCutout := true; + for lInc := 1 to 3 do + if gRender.Cutout.Lo[lInc] <> gRender.Cutout.Hi[lInc] then lUpdateCutout := false; + if lUpdateCutout then + for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := gBGImg.ScrnDim[lInc] div 2; + gRender.Cutout.Hi[lInc] := gBGImg.ScrnDim[lInc]; + end; + for lInc := 1 to 3 do begin + if gRender.Cutout.Lo[lInc] < 1 then gRender.Cutout.Lo[lInc] := 1; + if gRender.Cutout.Lo[lInc] > lBGImg.ScrnDim[lInc] then gRender.Cutout.Lo[lInc] := lBGImg.ScrnDim[lInc]; + if gRender.Cutout.Hi[lInc] < 1 then gRender.Cutout.Hi[lInc] := 1; + if gRender.Cutout.Hi[lInc] > lBGImg.ScrnDim[lInc] then gRender.Cutout.Hi[lInc] := lBGImg.ScrnDim[lInc]; + end; +end; +procedure VolumeRotateMatrix (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean {;lNearSlicesClipIn: integer}); +label 345; +const + kUgly2 = 10000; + //kSh = 10; //bits to shift + kUgly1 = (kUgly2 shl kSh) + (1 shl kSh); +var + + l: TRotateVals; + lZinc,lZ,lY,lX,lOutVolSz, + lOutPos,lInVolSz, + lYo,lZo,lnThreads: integer; + lBuffIn,lSrcBuff,lBuffOut: Bytep; + lXxp,lXyp,lXzp: Pointer; + lStartTime: DWord; + lM, lScale,lMatrix: TMatrix; + lZoomRatio: Single; + begin + + lMatrix := lMatrixIn; + if (gRender.Zoom <> 0) and (gRender.Zoom <> 1 )then begin + lZoomRatio := 1/gRender.Zoom; + lScale := Matrix3D(lZoomRatio,0,0,0, 0,lZoomRatio,0,0, 0,0,lZoomRatio,0, 0,0,0,0); + lMatrix := MultiplyMatrices(lMatrixIn,lScale); + end else + gRender.Zoom := 1; + //lScale := Matrix3D(0,1,0,0, 1,0,0,0, 0,0,1,0, 0,0,0,0); + //lScale := Matrix3D(0,1,0,0, 0,0,1,0, 1,0,0,0, 0,0,0,0); + lScale := Matrix3D(0,1,0,0, 0,0,1,0, 1,0,0,0, 0,0,0,0); + lMatrix := MultiplyMatrices(lMatrix,lScale); + lStartTime := GetTickCount; + l.XdimIn := lBGImg.ScrnDim[1]; + l.YdimIn := lBGImg.ScrnDim[2]; + l.ZdimIn := lBGImg.ScrnDim[3];; + l.InSliceSz := l.XDimIn*l.YDimIn; + lInVolSz := l.XdimIn*l.YdimIn*l.ZdimIn; //InVolSz! + if (lHdr.ScrnBufferItems < lInVolSz) then + exit; + lSrcBuff := lHdr.ScrnBuffer; + l.OutDim := MaxDim(l.XDimIn,l.YDimIn,l.ZDimIn); + l.OutDim := round(gRender.Zoom * l.OutDim); //11/2007 + (*lNearSlicesClip := lNearSlicesClipIn;//May07 + if lNearSlicesClip >= l.OutDim then //May07 + lNearSlicesClip := 0; //May07*) + lBGImg.RenderDim := l.OutDim; + lHdr.RenderDim := l.OutDim; + //l.RenderCutout := false; + if (lRenderCutout) then begin + //l.RenderCutout := true; + + SetLimits(lBGImg); + GetMem(lBuffIn, lInVolSz); + Move(lSrcBuff^,lBuffIn^,lInVolSz); + for lZ := 1 to lInVolSz do + if lBuffIn^[lZ] >= 254 then lBuffIn^[lZ] := 253; + if lRenderCutout then begin + + for lZ := gRender.Cutout.Lo[3] to gRender.Cutout.Hi[3] do begin + lZo := (lZ-1) * l.InSliceSz; + Application.ProcessMessages; + for lY := gRender.Cutout.Lo[2] to gRender.Cutout.Hi[2] do begin + lYo := (lY-1) * l.XdimIn; + for lX := gRender.Cutout.Lo[1] to gRender.Cutout.Hi[1] do + lBuffIn^[lX+lYo+lZo] := 255; + end; //for lY + end; //for lZ + end; + end else + lBuffIn := lSrcBuff; + l.OutPivot := (lHdr.RenderDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + l.XPivotIn := ((l.XdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.YPivotIn := ((l.YdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.ZPivotIn := ((l.ZdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.YDimStart := -l.OutPivot+1; //e.g. if 9, start from -4 + l.ZDimStart := l.YDimStart ; + + l.YDimEnd := l.YDimStart+lHdr.RenderDim-1; //e.g. if 9, go to 4 + l.ZDimEnd := l.YDimEnd; + if l.ZDimStart >= l.ZDimEnd then + l.ZDImStart := l.ZDimStart; + l.OutSliceSz := sqr(lHdr.RenderDim); + lOutVolSz := lHdr.RenderDim*l.OutSliceSz; + if lHdr.RenderBufferItems <> lOutVolSz then begin + if lHdr.RenderBufferItems > 0 then + Freemem(lHdr.RenderBuffer); + lHdr.RenderBufferItems := lOutVolSz; + try + GetMem(lHdr.RenderBuffer,lOutVolSz); + except //12/2007 + showmessage('Volume Rotate Error: System memory exhausted.'); + lHdr.RenderBufferItems := 0; + exit; + end; + + end; + lBuffOut := lHdr.RenderBuffer; + fillchar(lBuffOut^,lOutVolSz,0); //set all to zero + + //lMatrix := InvertMatrix3D(lMatrix); + lZ := (sizeof(longint)* l.OutDim)+16; + GetMem(lXxp, lZ); + GetMem(lXyp, lZ); + GetMem(lXzp, lZ); +// if RenderForm.RenderRefreshTimer.enabled then goto 345;//abort + {$IFNDEF FPC} + l.XxRA := LongIntP($fffffff0 and (integer(lXxP)+15)); //data aligned to quad-word boundary + l.XyRA := LongIntP($fffffff0 and (integer(lXyP)+15)); //quad-word boundary + l.XzRA := LongIntP($fffffff0 and (integer(lXzP)+15)); //quad-word boundary} + {$ELSE} + l.XxRA := system.align(lXxP, 16); //data aligned to quad-word boundary + l.XyRA := system.align(lXyP, 16); //quad-word boundary + l.XzRA := system.align(lXzP, 16); //quad-word boundary + {$ENDIF} + for lX := 1 to l.OutDim do begin + l.XxRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[1,1]* (1 shl kSh) )+kUgly1; + l.XyRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[2,1]* (1 shl kSh) )+kUgly1; + l.XzRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[3,1]* (1 shl kSh) )+kUgly1; + end; + l.XPivotInU2 := l.XPivotIn-kUgly2; + l.YPivotInU2 := l.YPivotIn-kUgly2; + l.ZPivotInU2 := l.ZPivotIn-kUgly2; + + lnThreads := gnCPUThreads; + //if lIsBG then + //TextForm.Memo1.Lines.Add( 'bg'+(inttostr(RenderForm.ThreadsRunning)+' '+inttostr(lnThreads))) + + //else + //TextForm.Memo1.Lines.Add( 'xx'+(inttostr(RenderForm.ThreadsRunning)+' '+inttostr(lnThreads))); + lZ := l.ZDimStart; + lZo := l.ZDimEnd; + lZinc := (l.ZDimEnd - l.ZDimStart) div lnThreads; + l.ZDimEnd := l.ZDimStart + lZinc; + //showmessage( inttostr(l.ZDimStart)+'..'+inttostr(l.ZDimEnd) +' '+inttostr(lZo)); + if l.ZDimEnd > ImgForm.ProgressBar1.Min then begin //crashes if max < min, so write order important... + ImgForm.ProgressBar1.Max := l.ZDimEnd+1; + ImgForm.ProgressBar1.Min := l.ZDimStart; + end else begin + ImgForm.ProgressBar1.Min := l.ZDimStart; + ImgForm.ProgressBar1.Max := l.ZDimEnd+1; + + end; + Application.processmessages; + + for lX := 1 to lnThreads do begin + if lX = lnThreads then + l.ZDimEnd := lZo; //avoid integer rounding error + //TextForm.Memo1.Lines.Add('+'+inttostr(lX)); + if (lBilinearSmooth) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + TTriRender.Create(ImgForm.ProgressBar1,lX,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut) + else + TNNRender.Create(ImgForm.ProgressBar1,lX,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut); + inc(ThreadsRunning); + l.ZDimStart := l.ZDimEnd + 1; + l.ZDimEnd := l.ZDimEnd + lZInc; + + end; //for each thread + l.ZDimStart := lZ; + + repeat + Application.processmessages; + until ThreadsRunning = 0; + Application.processmessages; + FreeMem(lXxp); + FreeMem(lXyp); + FreeMem(lXzp); + if (lRenderCutout) then begin + FreeMem(lBuffIn); + end; + ImgForm.ProgressBar1.Position := l.ZDimStart; + ImgForm.StatusLabel.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); +end; //proceudre VolumeRotate; + +end. diff --git a/niftiview7/reslice_fsl.pas b/niftiview7/reslice_fsl.pas new file mode 100755 index 0000000..7700c8e --- /dev/null +++ b/niftiview7/reslice_fsl.pas @@ -0,0 +1,201 @@ +unit reslice_fsl; +{$H+} +interface +uses + nifti_hdr,define_types,metagraph,sysutils; + +function ResliceImg (lTargetImgName,lSrcImgName,lSrc2TargetMatName,lOutputName: string): boolean; +procedure ResliceFSL; + +implementation + +uses nifti_img_view,dialogs,nifti_img,text,graphx,math,nifti_hdr_view,GraphicsMathLibrary,classes; + +procedure ResliceFSL; +label + 666; +var + lInc,lNumberofFiles: integer; + lSrc2TargetMatName,lSrcImgName,lTargetImgName,lOutputName:string; + lStrings : TStringList; +begin + ImgForm.CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select source image[s]',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + lStrings := TStringList.Create; + lStrings.AddStrings(HdrForm.OpenHdrDlg.Files); + if not OpenDialogExecute('FSL (*.mat)|*.mat','Select FSL source-to-target matrix',false) then goto 666; + lSrc2TargetMatName := HdrForm.OpenHdrDlg.Filename; + if not OpenDialogExecute(kImgFilter,'Select target image (source image will be warped to this)',false) then goto 666; + lTargetImgName := HdrForm.OpenHdrDlg.Filename; + + TextForm.MemoT.Lines.Clear; + for lInc:= 1 to lNumberofFiles do begin + lSrcImgName := lStrings[lInc-1]; + lOutputName := ChangeFilePrefix (lSrcImgName,'w'); + TextForm.MemoT.Lines.Add(' Source->Matrix->Target '+lSrcImgName+'->'+ lSrc2TargetMatName+'->'+lTargetImgName); + ResliceImg (lTargetImgName,lSrcImgName,lSrc2TargetMatName,lOutputName); + end;//lLoop + TextForm.Show; + 666: + lStrings.free; +end; + +function ReadFSLMat (var lMat: TMatrix; lSrc2TargetMatName: string):boolean; +var + lF: TextFile; + xx,xy,xz,xo + ,yx,yy,yz,yo + ,zx,zy,zz,zo: double; +begin + result := false; + if not fileexists(lSrc2TargetMatName) then exit; + Assign(lF,lSrc2TargetMatName); + Filemode := 0; + Reset(lF); + readln(lF,xx,xy,xz,xo,yx,yy,yz,yo,zx,zy,zz,zo); + //read all with one readln - + // separate readlns only work for native eoln + CloseFile(lF); + lMat:= Matrix3D (xx,xy,xz,xo + ,yx,yy,yz,yo + ,zx,zy,zz,zo + ,0,0,0,1); + result := true; + Filemode := 2; +end; + +function Rx (var lDestHdr,lSrcHdr: TMRIcroHdr; var lInMat: TMatrix; var lOutputName: string):boolean; +var + lPos,lXYs,lXYZs,lXs,lYs,lZs,lXi,lYi,lZi,lX,lY,lZ, + lXo,lYo,lZo,lMinY,lMinZ,lMaxY,lMaxZ: integer; + lXrM1,lYrM1,lZrM1, + lXreal,lYreal,lZreal: double; + lOutImg: bytep; + lScale,lMat: TMatrix; +begin + result := false; + lXs := lSrcHdr.NIFTIhdr.Dim[1]; + lYs := lSrcHdr.NIFTIhdr.Dim[2]; + lZs := lSrcHdr.NIFTIhdr.Dim[3]; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lXs*lYs*lZs) then begin + showmessage('Reslice error: background image not loaded.'); + exit; + end; + lXYs:=lXs*lYs; //slicesz + lXYZs := lXYs*lZs; + lX := lDestHdr.NIFTIhdr.Dim[1]; + lY := lDestHdr.NIFTIhdr.Dim[2]; + lZ := lDestHdr.NIFTIhdr.Dim[3]; + //TextForm.Memo1.Lines.Add(inttostr(lXs)+'x'+inttostr(lYs)+'x'+inttostr(lZs)+'->'+inttostr(lX)+'x'+inttostr(lY)+'x'+inttostr(lZ)); + lDestHdr.NIFTIhdr.Dim[4] := 1; + getmem(lOutImg, lX*lY*lZ*sizeof(byte)); + lPos := 0; + //http://eeg.sourceforge.net/MJenkinson_coordtransforms.pdf + //FLIRT transforms are in world coordinates [mm] + //to convert to a vxl-vxl transform, the matrix must be + //PRE-multiplied by inv(Dest) and POST-multiplied by Src + //where Dest and Src are the spatial dimensions in mm +lScale:= Matrix3D (abs(lSrcHdr.NIFTIhdr.pixdim[1]),0,0,0 + ,0,abs(lSrcHdr.NIFTIhdr.pixdim[2]),0,0 + ,0,0,abs(lSrcHdr.NIFTIhdr.pixdim[3]),0 + ,0,0,0,1); + lScale := InvertMatrix3D(lScale); + lMat := MultiplyMatrices(lScale,lInMat); + lScale:= Matrix3D (abs(lDestHdr.NIFTIhdr.pixdim[1]),0,0,0 + ,0,abs(lDestHdr.NIFTIhdr.pixdim[2]),0,0 + ,0,0,abs(lDestHdr.NIFTIhdr.pixdim[3]),0 + ,0,0,0,1); + lMat := MultiplyMatrices(lMat,lScale); + for lZi := 0 to (lZ-1) do begin + for lYi := 0 to (lY-1) do begin + for lXi := 0 to (lX-1) do begin + inc(lPos); + lOutImg^[lPos] := 0; + lXreal := (lXi*lMat.matrix[1][1]+lYi*lMat.matrix[1][2]+lZi*lMat.matrix[1][3]+lMat.matrix[1][4]); + lYreal := (lXi*lMat.matrix[2][1]+lYi*lMat.matrix[2][2]+lZi*lMat.matrix[2][3]+lMat.matrix[2][4]); + lZreal := (lXi*lMat.matrix[3][1]+lYi*lMat.matrix[3][2]+lZi*lMat.matrix[3][3]+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXreal >= 0) and (lYreal >= 1) and (lZreal >= 1) and + (lXreal < (lXs -1)) and (lYreal < (lYs -1) ) and (lZreal < (lZs -1)) + then begin + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo)*lXs); + lMinZ := ((lZo)*lXYs); + lMaxY := ((lYo+1)*lXs); + lMaxZ := ((lZo+1)*lXYs); + inc(lXo);//images incremented from 1 not 0 + {if lMax <(lXreal) then + lMax := lXreal; + if lMin >(lXreal) then + lMin := lXreal; } + lOutImg^[lPos] := + round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+1+lMaxY+lMaxZ]) ); + end; + end;//z + end;//y + end;//z + deletefile(lOutputName); + SaveAsVOIorNIFTIcore (lOutputName,lOutImg, lX*lY*lZ, 1,1,lDestHdr.NIFTIhdr); + lPos := 1; + while (lPos <= (lX*lY*lZ)) and (lOutImg^[lPos] = 0) do + inc(lPos); + if lPos > (lX*lY*lZ) then + result := false + else + result := true; + freemem(lOutImg); +end; + +function ResliceImg (lTargetImgName,lSrcImgName,lSrc2TargetMatName,lOutputName: string): boolean; +label + 666; +var + lReslice,lOrtho : boolean; + lDestHdr,lSrcHdr: TMRIcroHdr; + lMat: TMatrix; +begin + result := false; + if not fileexists(lTargetImgName) then exit; + if not fileexists(lSrcImgName) then exit; + if not fileexists(lSrc2TargetMatName) then exit; + if not ReadFSLMat(lMat,lSrc2TargetMatName) then exit; + ImgForm.CloseImagesClick(nil); + lReslice := gBGImg.ResliceOnLoad; + lOrtho := gBGImg.OrthoReslice; + gBGImg.OrthoReslice := false; + gBGImg.ResliceOnLoad := false; + //if not HdrForm.OpenAndDisplayHdr(lTargetImgName,lDestHdr) then goto 666; + if not NIFTIhdr_LoadHdr(lTargetImgName, lDestHdr) then goto 666; + if not NIFTIhdr_LoadHdr(lSrcImgName, lSrcHdr) then goto 666; + ImgForm.OpenAndDisplayImg(lSrcImgName,True); + if not Rx(lDestHdr,lSrcHdr,lMat,lOutputName) then goto 666; + result := true; +666: + if not result then + showmessage('Error applying transform '+lSrcImgName+'->'+lTargetImgName+' using '+lSrc2TargetMatName); + gBGImg.ResliceOnLoad := lReslice; + gBGImg.OrthoReslice := lOrtho; +end; + + +end. + diff --git a/niftiview7/reslice_img.pas b/niftiview7/reslice_img.pas new file mode 100755 index 0000000..2553883 --- /dev/null +++ b/niftiview7/reslice_img.pas @@ -0,0 +1,821 @@ +unit reslice_img; + +interface +uses +{$ifndef fpc}{windows,} {$endif} +GraphicsMathLibrary,nifti_hdr, nifti_types; + +function Reslice_Img_To_Unaligned (var lTargHdr: TNIfTIhdr; var lSrcHdr: TMRIcroHdr; lTrilinearSmoothIn: boolean): boolean; +//procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +function Hdr2InvMat (lHdr: TNiftiHdr; var lOK: boolean): TMatrix; +procedure Voxel2mm(var X,Y,Z: single; var lHdr: TNIfTIHdr); +procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +function Hdr2Mat (lHdr: TNIFTIhdr): TMatrix; +procedure Mat2Hdr (var lM: TMatrix; var lHdr: TNIFTIhdr); + +implementation + + + +uses dialogs, define_types; + + +function Hdr2Mat (lHdr: TNIFTIhdr): TMatrix; +begin + Result := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], // 3D "graphics" matrix + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], // 3D "graphics" matrix + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); +end; + +procedure Mat2Hdr (var lM: TMatrix; var lHdr: TNIFTIhdr); +begin + lHdr.srow_x[0] := lM.matrix[1,1]; + lHdr.srow_x[1] := lM.matrix[1,2]; + lHdr.srow_x[2] := lM.matrix[1,3]; + lHdr.srow_x[3] := lM.matrix[1,4]; + + lHdr.srow_y[0] := lM.matrix[2,1]; + lHdr.srow_y[1] := lM.matrix[2,2]; + lHdr.srow_y[2] := lM.matrix[2,3]; + lHdr.srow_y[3] := lM.matrix[2,4]; + + + lHdr.srow_z[0] := lM.matrix[3,1]; + lHdr.srow_z[1] := lM.matrix[3,2]; + lHdr.srow_z[2] := lM.matrix[3,3]; + lHdr.srow_z[3] := lM.matrix[3,4]; +end; + +procedure ReportMatrix (lM:TMatrix); +const + kCR = chr (13); +begin + showmessage(RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+kCR+ + RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+kCR+ + RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+kCR + +RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6) + ); +end; + +(* +procedure SPMmat(var lDestMat: TMatrix); +//SPM matrices are indexed from 1 +//This function is only useful for direct comparisons with SPM +var + lTemp,lVS: TMatrix; +begin + lVS := Matrix3D (1,0,0,-1, + 0,1,0,-1, + 0,0,1,-1, 0,0,0,1);//VoxelShift + lTemp := lDestMat; + lDestMat := MultiplyMatrices(lTemp,lVS); +end;*) + +procedure Coord(var lV: TVector; var lMat: TMatrix); +//transform X Y Z by matrix +var + lXi,lYi,lZi: single; +begin + lXi := lV.x; lYi := lV.y; lZi := lV.z; + lV.x := (lXi*lMat.matrix[1][1]+lYi*lMat.matrix[1][2]+lZi*lMat.matrix[1][3]+lMat.matrix[1][4]); + lV.y := (lXi*lMat.matrix[2][1]+lYi*lMat.matrix[2][2]+lZi*lMat.matrix[2][3]+lMat.matrix[2][4]); + lV.z := (lXi*lMat.matrix[3][1]+lYi*lMat.matrix[3][2]+lZi*lMat.matrix[3][3]+lMat.matrix[3][4]); +end; + +procedure Transposemat(var lMat: TMatrix); +var + lTemp: TMatrix; + i,j: integer; +begin + lTemp := lMat; + for i := 1 to lMat.size do + for j := 1 to lMat.size do + lMat.matrix[i,j] := lTemp.matrix[j,i]; +end; + +function gaussj(VAR a: TMatrix): boolean;//Invert a Matrix - see Numerical Recipes +label + 666; +VAR + big,dum,pivinv: real; + n,i,icol,irow,j,k,l,ll: integer; + indxc,indxr,ipiv: array [1..4] of integer; +BEGIN + result := true; + icol := 1;//not used - avoids compiler warning + irow := 1;//not used - avoids compiler warning + n := a.size; + FOR j := 1 TO n DO BEGIN + ipiv[j] := 0 + END; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO BEGIN + IF (ipiv[j] <> 1) THEN BEGIN + FOR k := 1 TO n DO BEGIN + IF (ipiv[k] = 0) THEN BEGIN + IF (abs(a.matrix[j,k]) >= big) THEN BEGIN + big := abs(a.matrix[j,k]); + irow := j; + icol := k + END + END ELSE IF (ipiv[k] > 1) THEN BEGIN + goto 666; + END + END + END + END; + ipiv[icol] := ipiv[icol]+1; + IF (irow <> icol) THEN BEGIN + FOR l := 1 TO n DO BEGIN + dum := a.matrix[irow,l]; + a.matrix[irow,l] := a.matrix[icol,l]; + a.matrix[icol,l] := dum + END; + END; + indxr[i] := irow; + indxc[i] := icol; + IF (a.matrix[icol,icol] = 0.0) THEN + goto 666; + pivinv := 1.0/a.matrix[icol,icol]; + a.matrix[icol,icol] := 1.0; + FOR l := 1 TO n DO BEGIN + a.matrix[icol,l] := a.matrix[icol,l]*pivinv + END; + FOR ll := 1 TO n DO BEGIN + IF (ll <> icol) THEN BEGIN + dum := a.matrix[ll,icol]; + a.matrix[ll,icol] := 0.0; + FOR l := 1 TO n DO BEGIN + a.matrix[ll,l] := a.matrix[ll,l]-a.matrix[icol,l]*dum + END; + END + END + END; + FOR l := n DOWNTO 1 DO BEGIN + IF (indxr[l] <> indxc[l]) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a.matrix[k,indxr[l]]; + a.matrix[k,indxr[l]] := a.matrix[k,indxc[l]]; + a.matrix[k,indxc[l]] := dum + END + END + END; + exit; + 666: //only get here if there is an error + Showmessage('error in reslice_img - singular matrix. Spatial orientation is ambiguous.'); + a := Eye3D; + result := false; +END; + +procedure SubVec (var lVx: TVector; lV0: TVector); +begin + lVx.x := lVx.x - lV0.x; + lVx.y := lVx.y - lV0.y; + lVx.z := lVx.z - lV0.z; +end; + +(*procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +//returns voxels indexed from 1 not 0! +var + lV: TVector; + lSrcMatInv,lSrcMat: TMatrix; +begin + lV := Vector3D (X,Y,Z); + lV := Transform (lV,lInvMat); + X := lV.x+1; + Y := lV.y+1; + Z := lV.z+1; +end;*) + +procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +//returns voxels indexed from 1 not 0! +var + lV: TVector; + lSrcMatInv,lSrcMat: TMatrix; +begin + lV := Vector3D (X,Y,Z); + Coord (lV,lInvMat); + X := lV.x+1; + Y := lV.y+1; + Z := lV.z+1; +end; + + +procedure Voxel2mm(var X,Y,Z: single; var lHdr: TNIfTIHdr); +var + lV: TVector; + lMat: TMatrix; +begin + //lV := Vector3D (X-1,Y-1,Z-1); + lV := Vector3D (X-1,Y-1,Z-1); + lMat := Hdr2Mat(lHdr); + Coord(lV,lMat); + X := lV.x; + Y := lV.y; + Z := lV.z; +end; +(*procedure Voxel2mm(var X,Y,Z: single; var lHdr: TNIfTIHdr); +var + lV: TVector; + lMat: TMatrix; +begin + //lV := Vector3D (X-1,Y-1,Z-1); + lV := Vector3D (X-1,Y-1,Z-1); + lMat := Hdr2Mat(lHdr); + Coord(lV,lMat); + X := lV.x; + Y := lV.y; + Z := lV.z; +end;*) + +function Voxel2Voxel (var lDestHdr,lSrcHdr: TNIFTIhdr): TMatrix; +//returns matrix for transforming voxels from one image to the other image +//results are in VOXELS not mm +var + lV0,lVx,lVy,lVz: TVector; + lDestMat,lSrcMatInv,lSrcMat: TMatrix; + +begin + //Step 1 - compute source coordinates in mm for 4 voxels + //the first vector is at 0,0,0, with the + //subsequent voxels being left, up or anterior + lDestMat := Hdr2Mat(lDestHdr); + //SPMmat(lDestMat); + lV0 := Vector3D (0,0,0); + lVx := Vector3D (1,0,0); + lVy := Vector3D (0,1,0); + lVz := Vector3D (0,0,1); + Coord(lV0,lDestMat); + Coord(lVx,lDestMat); + Coord(lVy,lDestMat); + Coord(lVz,lDestMat); + lSrcMat := Hdr2Mat(lSrcHdr); + //SPMmat(lSrcMat); + lSrcMatInv := lSrcMat; + gaussj(lSrcMatInv); + //the vectors should be rows not columns.... + //therefore we transpose the matrix + Transposemat(lSrcMatInv); + //the 'transform' multiplies the vector by the matrix + lV0 := Transform (lV0,lSrcMatInv); + lVx := Transform (lVx,lSrcMatInv); + lVy := Transform (lVy,lSrcMatInv); + lVz := Transform (lVz,lSrcMatInv); + //subtract each vector from the origin + // this reveals the voxel-space influence for each dimension + SubVec(lVx,lV0); + SubVec(lVy,lV0); + SubVec(lVz,lV0); + result := Matrix3D(lVx.x,lVy.x,lVz.x,lV0.x, + lVx.y,lVy.y,lVz.y,lV0.y, + lVx.z,lVy.z,lVz.z,lV0.z, 0,0,0,1); +end; + +procedure CopyHdrMat(var lTarg,lDest: TNIfTIHdr); +//destination has dimensions and rotations of destination +var + lI: integer; +begin + //destination will have dimensions of target + lDest.dim[0] := 3; //3D + for lI := 1 to 3 do + lDest.dim[lI] := lTarg.dim[lI]; + lDest.dim[4] := 1; //3D + //destination will have pixdim of target + for lI := 0 to 7 do + lDest.pixdim[lI] := lTarg.pixdim[lI]; + lDest.xyzt_units := lTarg.xyzt_units; //e.g. mm and sec + lDest.qform_code := lTarg.qform_code; + lDest.sform_code := lTarg.sform_code; + lDest.quatern_b := lTarg.quatern_b; + lDest.quatern_c := lTarg.quatern_c; + lDest.quatern_d := lTarg.quatern_d; + lDest.qoffset_x := lTarg.qoffset_x; + lDest.qoffset_y := lTarg.qoffset_y; + lDest.qoffset_z := lTarg.qoffset_z; + for lI := 0 to 3 do begin + lDest.srow_x[lI] := lTarg.srow_x[lI]; + lDest.srow_y[lI] := lTarg.srow_y[lI]; + lDest.srow_z[lI] := lTarg.srow_z[lI]; + end; +end; + +function OneToOne(lM:TMatrix): boolean; +var + lC,lR: integer; +begin + result := false; + for lC := 1 to 3 do + for lR := 1 to 3 do + if (lM.matrix[lC,lR] <> 0) and ((abs(lM.matrix[lC,lR])- 1) > 0.00001) then + exit; + result := true; +end; + +function Reslice_Img_To_Unaligned (var lTargHdr: TNIfTIhdr; var lSrcHdr: TMRIcroHdr; lTrilinearSmoothIn: boolean): boolean; +var + lXrM1,lYrM1,lZrM1,lZx,lZy,lZz,lYx,lYy,lYz,lXreal,lYreal,lZreal: single; + lXo,lYo,lZo,lMinY,lMaxY,lMinZ,lMaxZ, + lPos,lXs,lYs,lZs,lXYs,lXYZs,lX,lY,lZ,lOutVolItems, + lXi,lYi,lZi: integer; + lDestHdr: TNIFTIhdr; + lMat: TMatrix; + lTrilinearSmooth,lOverlap: boolean; + lXx,lXy,lXz: Singlep0; + l32fs,l32f : SingleP; + l16is,l16i : SmallIntP; + l8i,l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned,lBuffOutUnaligned: bytep; +begin + + lTrilinearSmooth := lTrilinearSmoothIn; + result := false; + lOverlap := false; + lDestHdr := lSrcHdr.NIfTIHdr; //destination has the comments and voxel BPP of source + CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + lXs := lSrcHdr.NIfTIHdr.Dim[1]; + lYs := lSrcHdr.NIfTIHdr.Dim[2]; + lZs := lSrcHdr.NIfTIHdr.Dim[3]; + + lXYs:=lXs*lYs; //slicesz + lXYZs := lXYs*lZs; + lX := lDestHdr.Dim[1]; + lY := lDestHdr.Dim[2]; + lZ := lDestHdr.Dim[3]; + lOutVolItems :=lX*lY*lZ; + if lSrcHdr.ImgBufferBPP = 4 then begin + l32fs := SingleP(lSrcHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + {$IFDEF FPC} + l32f := align(lBuffOutUnaligned,16); + {$ELSE} + l32f := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + {$ENDIF} + for lPos := 1 to lOutVolItems do + l32f^[lPos] := 0; //set all to zero + end else if lSrcHdr.ImgBufferBPP = 2 then begin + l16is := SmallIntP(lSrcHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + {$IFDEF FPC} + l16i := align(lBuffOutUnaligned,16); + {$ELSE} + l16i := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + {$ENDIF} + for lPos := 1 to lOutVolItems do + l16i^[lPos] := 0; //set all to zero + end else if lSrcHdr.ImgBufferBPP = 1 then begin + l8is := ByteP(lSrcHdr.ImgBuffer); + GetMem(l8i,lOutVolItems); + Fillchar(l8i^,lOutVolItems,0); //set all to zero + end; + lMat := Voxel2Voxel (lTargHdr,lSrcHdr.NIfTIHdr); + //lDestHdr := lSrcHdr; //destination has the comments and voxel BPP of source + //CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + //now we can apply the transforms... + //build lookup table - speed up inner loop + getmem(lXx, lX*sizeof(single)); + getmem(lXy, lX*sizeof(single)); + getmem(lXz, lX*sizeof(single)); + for lXi := 0 to (lX-1) do begin + lXx^[lXi] := lXi*lMat.matrix[1][1]; + lXy^[lXi] := lXi*lMat.matrix[2][1]; + lXz^[lXi] := lXi*lMat.matrix[3][1]; + end; + lPos := 0; + if (lTrilinearSmooth) and (OneToOne(lMat)) then + lTrilinearSmooth := false; +if lTrilinearSmooth then begin//compute trilinear interpolation +//compute trilinear interpolation + + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + lXreal := (lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYreal := (lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZreal := (lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXreal >= 0) and (lYreal >= 0) and (lZreal >= 0) and + (lXreal < (lXs -1)) and (lYreal < (lYs -1) ) and (lZreal <= (lZs -1)) //June09 lZReal <= instead of < + then begin + //compute the contribution for each of the 8 source voxels + //nearest to the target + lOverlap := true; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := lYo*lXs; + lMinZ := lZo*lXYs; + lMaxY := lMinY+lXs; + inc(lXo);//images incremented from 1 not 0 + //Check if sample is perfectly in the Z-plane. + //This requires only 8 samples, so its faster + //in addition, for very thin volumes, it allows us to sample to the edge + if lZReal = 0 then begin // perfectly in plane, only sample 4 voxels near each other + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] := + round ( ( (lXrM1*lYrM1)*l8is^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l8is^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l8is^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l8is^[lXo+1+lMaxY+lMinZ])); + 2: l16i^[lPos] := + round (( (lXrM1*lYrM1)*l16is^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l16is^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l16is^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l16is^[lXo+1+lMaxY+lMinZ])); + 4: l32f^[lPos] := + ( (lXrM1*lYrM1)*l32fs^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l32fs^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l32fs^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l32fs^[lXo+1+lMaxY+lMinZ]); + end; //case + end else begin //not perfectly in plane... we need 8 samples... + lMaxZ := lMinZ+lXYs; + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] := + round ({all min} ( (lXrM1*lYrM1*lZrM1)*l8is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l8is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l8is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l8is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l8is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l8is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l8is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l8is^[lXo+1+lMaxY+lMaxZ]) ); + 2:l16i^[lPos] := + round ({all min} ( (lXrM1*lYrM1*lZrM1)*l16is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l16is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l16is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l16is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l16is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l16is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l16is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l16is^[lXo+1+lMaxY+lMaxZ]) ); + 4: l32f^[lPos] := + {all min} ( (lXrM1*lYrM1*lZrM1)*l32fs^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l32fs^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l32fs^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l32fs^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l32fs^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l32fs^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l32fs^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l32fs^[lXo+1+lMaxY+lMaxZ]) ; + end; //case + end; //not perfectly in plane + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z +end else begin //if trilinear, else nearest neighbor +//nearest neighbor - added 12 April 2009 + //showmessage('2012xxxx666'); + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + lXo := round(lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYo := round(lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZo := round(lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXo >= 0) and (lYo >= 0) and (lZo >= 0) and + (lXo < (lXs)) and (lYo < (lYs) ) and (lZo < (lZs)) + //12/12/2012 removed -1 for nearest neighbor (lXo < (lXs -1)) and (lYo < (lYs -1) ) and (lZo < (lZs)) + then begin + lOverlap := true; + inc(lXo);//images incremented from 1 not 0 + lYo := lYo*lXs; + lZo := lZo*lXYs; + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] :=l8is^[lXo+lYo+lZo]; + 2: l16i^[lPos] :=l16is^[lXo+lYo+lZo]; + 4: l32f^[lPos] :=l32fs^[lXo+lYo+lZo] ; + end; //case + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z +//end nearest neighbor +end; + + //release lookup tables + freemem(lXx); + freemem(lXy); + freemem(lXz); + //check to see if image is empty... + if not lOverlap then + Showmessage('No overlap between overlay and background - these images do not appear coregistered.'); + + if lSrcHdr.ImgBufferBPP = 4 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + lSrcHdr.ImgBufferItems := lOutVolItems; + move(l32f^,lSrcHdr.ImgBuffer^,(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lSrcHdr.ImgBufferBPP = 2 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l16i),(lOutVolItems*sizeof(SmallInt))); + move(l16i^,lSrcHdr.ImgBuffer^,(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lSrcHdr.ImgBufferBPP = 1 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,lOutVolItems + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l8i),lOutVolItems); + move(l8i^,lSrcHdr.ImgBuffer^,lOutVolItems); + FreeMem(l8i); + end; + lSrcHdr.NIfTIHdr := lDestHdr; //header inherits coordinates of target +end; + + +(*function Reslice_Img_To_Unaligned (var lTargHdr: TNIfTIhdr; var lSrcHdr: TMRIcroHdr; lTrilinearSmoothIn: boolean): boolean; +var + lXrM1,lYrM1,lZrM1,lZx,lZy,lZz,lYx,lYy,lYz,lXreal,lYreal,lZreal: single; + lXo,lYo,lZo,lMinY,lMaxY,lMinZ,lMaxZ, + lXYZo,lPoso,lPos,lXs,lYs,lZs,lXYs,lXYZs,lX,lY,lZ,lOutVolItems, + lXi,lYi,lZi: integer; + lTrilinearSmooth,lOverlap: boolean; + lDestHdr: TNIFTIhdr; + lMat: TMatrix; + lXx,lXy,lXz: Singlep0; + l32fs,l32f : SingleP; + l16is,l16i : SmallIntP; + l8i,l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned,lBuffOutUnaligned: bytep; +begin + lTrilinearSmooth := lTrilinearSmoothIn; + result := false; + lOverlap := false; + lDestHdr := lSrcHdr.NIfTIHdr; //destination has the comments and voxel BPP of source + CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + lXs := lSrcHdr.NIfTIHdr.Dim[1]; + lYs := lSrcHdr.NIfTIHdr.Dim[2]; + lZs := lSrcHdr.NIfTIHdr.Dim[3]; + lXYs:=lXs*lYs; //slicesz + lXYZs := lXYs*lZs; + lX := lDestHdr.Dim[1]; + lY := lDestHdr.Dim[2]; + lZ := lDestHdr.Dim[3]; + lXYZo := lX*lY*lZ; + lOutVolItems :=lX*lY*lZ; + if lSrcHdr.ImgBufferBPP = 4 then begin + l32fs := SingleP(lSrcHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + l32f := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lPos := 1 to lOutVolItems do + l32f^[lPos] := 0; //set all to zero + end else if lSrcHdr.ImgBufferBPP = 2 then begin + l16is := SmallIntP(lSrcHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + l16i := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + for lPos := 1 to lOutVolItems do + l16i^[lPos] := 0; //set all to zero + end else if lSrcHdr.ImgBufferBPP = 1 then begin + l8is := ByteP(lSrcHdr.ImgBuffer); + GetMem(l8i,lOutVolItems); + Fillchar(l8i^,lOutVolItems,0); //set all to zero + end; + lMat := Voxel2Voxel (lTargHdr,lSrcHdr.NIfTIHdr); + //fx(lMat.matrix[1][1],lMat.matrix[1][1],lMat.matrix[2][1],lMat.matrix[3][1]); + //lDestHdr := lSrcHdr; //destination has the comments and voxel BPP of source + //CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + //now we can apply the transforms... + //build lookup table - speed up inner loop + getmem(lXx, lX*sizeof(single)); + getmem(lXy, lX*sizeof(single)); + getmem(lXz, lX*sizeof(single)); + for lXi := 0 to (lX-1) do begin + lXx^[lXi] := lXi*lMat.matrix[1][1]; + lXy^[lXi] := lXi*lMat.matrix[2][1]; + lXz^[lXi] := lXi*lMat.matrix[3][1]; + end; + lPos := 0; + if (lTrilinearSmooth) and (OneToOne(lMat)) then begin + lTrilinearSmooth := false; + end; +if lTrilinearSmooth then begin//compute trilinear interpolation + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + lXreal := (lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYreal := (lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZreal := (lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXreal >= 0) and (lYreal >= 0) and (lZreal >= 0) and + (lXreal < (lXs -1)) and (lYreal < (lYs -1) ) and (lZreal <= (lZs -1)) //June09 lZReal <= instead of < + then begin + //compute the contribution for each of the 8 source voxels + //nearest to the target + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := lYo*lXs; + lMinZ := lZo*lXYs; + lMaxY := lMinY+lXs; + inc(lXo);//images incremented from 1 not 0 + //Check if sample is perfectly in the Z-plane. + //This requires only 8 samples, so its faster + //in addition, for very thin volumes, it allows us to sample to the edge + lOverlap := true; + if lZReal = 0 then begin // perfectly in plane, only sample 4 voxels near each other + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] := + round ( ( (lXrM1*lYrM1)*l8is^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l8is^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l8is^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l8is^[lXo+1+lMaxY+lMinZ])); + 2: l16i^[lPos] := + round (( (lXrM1*lYrM1)*l16is^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l16is^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l16is^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l16is^[lXo+1+lMaxY+lMinZ])); + 4: l32f^[lPos] := + ( (lXrM1*lYrM1)*l32fs^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l32fs^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l32fs^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l32fs^[lXo+1+lMaxY+lMinZ]); + end; //case + end else begin //not perfectly in plane... we need 8 samples... + lMaxZ := lMinZ+lXYs; + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] := + round ({all min} ( (lXrM1*lYrM1*lZrM1)*l8is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l8is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l8is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l8is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l8is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l8is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l8is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l8is^[lXo+1+lMaxY+lMaxZ]) ); + 2:l16i^[lPos] := + round ({all min} ( (lXrM1*lYrM1*lZrM1)*l16is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l16is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l16is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l16is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l16is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l16is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l16is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l16is^[lXo+1+lMaxY+lMaxZ]) ); + 4: l32f^[lPos] := + {all min} ( (lXrM1*lYrM1*lZrM1)*l32fs^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l32fs^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l32fs^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l32fs^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l32fs^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l32fs^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l32fs^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l32fs^[lXo+1+lMaxY+lMaxZ]) ; + end; //case + end; //not perfectly in plane + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z +end else begin //if trilinear, else nearest neighbor + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + //fx(lZx,lZy,lZz,+lMat.matrix[3][4]); + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + lXo := round(lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYo := round(lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZo := round(lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + lPoso := lXo+lYo+lZo ; + if (lPoso > 0) and (lPoso <= lXYZo) + //if (lXo >= 0)and (lYo >= 0) and (lZo >= 0) and (lXo < (lXs -1)) and (lYo < (lYs -1) ) and (lZo < lZs) + then begin + lOverlap := true; + inc(lXo);//images incremented from 1 not 0 + lYo := lYo*lXs; + lZo := lZo*lXYs; + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] :=l8is^[lXo+lYo+lZo]; + 2: l16i^[lPos] := l16is^[lXo+lYo+lZo]; + 4: l32f^[lPos] := l32fs^[lXo+lYo+lZo]; + end; //case + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z + +end;//nearest neighbor + + //release lookup tables + freemem(lXx); + freemem(lXy); + freemem(lXz); + //check to see if image is empty... + {lPos := 1; + case lSrcHdr.ImgBufferBPP of + 1 : while (lPos <= (lX*lY*lZ)) and (l8i^[lPos] = 0) do inc(lPos); + 2: while (lPos <= (lX*lY*lZ)) and (l16i^[lPos] = 0) do inc(lPos); + 4: while (lPos <= (lX*lY*lZ)) and (l32f^[lPos] = 0) do inc(lPos); + end; //case + if lPos <= (lX*lY*lZ) then begin //image not empty + result := true; + end else + Showmessage('No overlap between overlay and background - these images do not appear coregistered.');} + if not lOverlap then + Showmessage('No overlap between overlay and background - these images do not appear coregistered.'); + if lSrcHdr.ImgBufferBPP = 4 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l32f),(lOutVolItems*sizeof(Single))); + //move(Pointer(l32f),Pointer(lSrcHdr.ImgBuffer),(lOutVolItems*sizeof(Single))); + + move(l32f^,lSrcHdr.ImgBuffer^,(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lSrcHdr.ImgBufferBPP = 2 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l16i),(lOutVolItems*sizeof(SmallInt))); + move(l16i^,lSrcHdr.ImgBuffer^,(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lSrcHdr.ImgBufferBPP = 1 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,lOutVolItems + 16); + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l8i),lOutVolItems); + move(l8i^,lSrcHdr.ImgBuffer^,lOutVolItems); + FreeMem(l8i); + end; + lSrcHdr.NIfTIHdr := lDestHdr; //header inherits coordinates of target +end; *) + +function Hdr2InvMat (lHdr: TNiftiHdr; var lOK: boolean): TMatrix; +var + lSrcMat,lSrcMatInv: TMatrix; +begin + lSrcMat := Hdr2Mat( lHdr); + lSrcMatInv := lSrcMat; + lOK := gaussj(lSrcMatInv); + //the vectors should be rows not columns.... + //therefore we transpose the matrix + //use this if you use transform instead of coord + //Transposemat(lSrcMatInv); + result := lSrcMatInv; +end; + +end. diff --git a/niftiview7/rotation.pas b/niftiview7/rotation.pas new file mode 100755 index 0000000..3953045 --- /dev/null +++ b/niftiview7/rotation.pas @@ -0,0 +1,181 @@ +unit rotation; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, nifti_hdr,Buttons, StdCtrls, Mask, RXSpin, nifti_types; + +type + TRotationForm = class(TForm) + YawEdit: TRxSpinEdit; + PitchEdit: TRxSpinEdit; + ROllEdit: TRxSpinEdit; + LabelX: TLabel; + Label1: TLabel; + Label2: TLabel; + ResliceBtn: TSpeedButton; + AdjustMatrixBtn: TSpeedButton; + procedure ResliceBtnClick(Sender: TObject); + procedure YawPitchRollChange(Sender: TObject); + procedure RotateNIFTIMatrix (var lHdr: TNIFTIhdr; lYaw,lPitch,lRoll: single); + procedure AdjustMatrixBtnClick(Sender: TObject); + procedure GenerateRotation (lReslice: boolean); + private + { Private declarations } + public + { Public declarations } + end; + +var + RotationForm: TRotationForm; + +implementation + +{$R *.dfm} +uses +nifti_img_view, nifti_img, nifti_hdr_view, define_types, reslice_img,GraphicsMathLibrary; + + +procedure ReportMatrix (lM:TMatrix); +const + kCR = chr (13); +begin + showmessage(RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+kCR+ + RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+kCR+ + RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+kCR + +RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6) + ); +end; + + +procedure RotateAroundPivot (var lR: TMatrix; lXoffset,lYoffset,lZOffset: single); +(*http://www.euclideanspace.com/maths/geometry/affine/aroundPoint/index.htm +For three dimensional rotations about x,y we can represent it with the following 4x4 matrix: +r00 r01 r02 x - r00*x - r01*y - r02*z +r10 r11 r12 y - r10*x - r11*y - r12*z +r20 r21 r22 z - r20*x - r21*y - r22*z +0 0 0 1 *) +begin + lR.matrix[1,4] := lXoffset - lR.matrix[1,1]*lXoffset - lR.matrix[1,2]*lYOffset - lR.matrix[1,3]*lZoffset; + lR.matrix[2,4] := lYoffset - lR.matrix[2,1]*lXoffset - lR.matrix[2,2]*lYOffset - lR.matrix[2,3]*lZoffset; + lR.matrix[3,4] := lZoffset - lR.matrix[3,1]*lXoffset - lR.matrix[3,2]*lYOffset - lR.matrix[3,3]*lZoffset; +end; + + +procedure TRotationForm.RotateNIFTIMatrix (var lHdr: TNIFTIhdr; lYaw,lPitch,lRoll: single); +//reorient image by YPR degrees... +var + lM, lR: TMatrix; +begin + //caption := floattostr(lYaw)+'x'+floattostr(lPitch)+'x'+floattostr(lRoll); + if (lYaw = 0) and (lPitch = 0) and (lRoll = 0) then + exit; + + lR := Eye3D; + RotateYaw(lYaw, lR); + RotatePitch(lPitch,lR); + RotateRoll(lRoll, lR); + + lM := Hdr2Mat (lHdr); + //RotateAroundPivot ( lR, -lM.matrix[1,4],-lM.matrix[2,4],-lM.matrix[3,4]); + //RotateAroundPivot ( lR, lM.matrix[1,4],lM.matrix[2,4],lM.matrix[3,4]); + //ReportMatrix (lR); + //order lM := MultiplyMatrices(lM,lR); + lM := MultiplyMatrices(lR,lM); + //ReportMatrix(lM); + Mat2Hdr(lM,lHdr); +end; + +(*procedure RotateMatrix (var lHdr: TNIFTIhdr; lYaw,lPitch,lRoll: single); +//reorient image by YPR degrees... +var + lM, lR: TMatrix; +begin + lR := Eye3D; + lM := Hdr2Mat (lHdr); + RotateYaw(lYaw, lM); + RotatePitch(lPitch,lM); + RotateRoll(lRoll, lM); + //ReportMatrix (lM); + Mat2Hdr(lM,lHdr); +end; *) +procedure TRotationForm.GenerateRotation (lReslice: boolean); +var + lDefaultReorient,lDefaultResliceView: boolean; + lLayer: integer; + lY,lP,lR: single; + lFilename: string; + lNIFTIhdr: TNIFTIhdr; +begin + lLayer := ImgForm.ActiveLayer; + if gMRIcroOverlay[lLayer].ImgBufferItems=0 then begin + Showmessage('You must load an image [File/Open] before you can save the image.'); + exit; + end; + lDefaultResliceView := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := lReslice; + lDefaultReorient := gBGImg.UseReorientHdr; + + lFilename := gMRIcroOverlay[lLayer].HdrFileName;//HdrForm.OpenHdrDlg.Filename; + lY := YawEdit.Value; + lP := PitchEdit.value; + lR := RollEdit.value; + if not lReslice then begin + YawEdit.Value := 0; + PitchEdit.value := 0; + RollEdit.value := 0; + end; + ImgForm.CloseImagesClick(nil); + ImgForm.OpenAndDisplayImg(lFilename,True); + lFilename := changefileprefix(lFilename,'r'); + CopyNiftiHdr(gMRIcroOverlay[kBGOverlayNum].NiftiHdr,lNIFTIhdr); + + if not lReslice then begin + gBGImg.UseReorientHdr := false; + RotateNIFTIMatrix(lNiftiHdr,lY,lP,lR); + end; + SaveAsVOIorNIFTIcore (lFilename, gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,lNIFTIhdr) ; + ImgForm.CloseImagesClick(nil); + if lReslice then begin + YawEdit.Value := 0; + PitchEdit.value := 0; + RollEdit.value := 0; + end; + gBGImg.UseReorientHdr := lDefaultReorient; + gBGImg.ResliceOnLoad := lDefaultResliceView; + ImgForm.OpenAndDisplayImg(lFilename,True); +end; + +procedure TRotationForm.ResliceBtnClick(Sender: TObject); +begin + GenerateRotation(true); +end; + +procedure TRotationForm.YawPitchRollChange(Sender: TObject); + +var + lLayer: integer; + lFilename: string; + lNIFTIhdr: TNIFTIhdr; +begin + lLayer := ImgForm.ActiveLayer; + if gMRIcroOverlay[lLayer].ImgBufferItems=0 then begin + //Showmessage('You must load an image [File/Open] before you can save the image.'); + exit; + end; + (*LoadYaw := YawEdit.value; + loadPitch := Pitchedit.Value; + LoadRoll := RollEdit.Value;*) + lFilename := gMRIcroOverlay[lLayer].HdrFileName; + //lFilename := HdrForm.OpenHdrDlg.Filename; + //caption := lFilename; + ImgForm.OpenAndDisplayImg(lFilename,false); +end; + +procedure TRotationForm.AdjustMatrixBtnClick(Sender: TObject); +begin + GenerateRotation(false); +end; + +end. diff --git a/niftiview7/sliceinterpolate.pas b/niftiview7/sliceinterpolate.pas new file mode 100755 index 0000000..6bc0ad0 --- /dev/null +++ b/niftiview7/sliceinterpolate.pas @@ -0,0 +1,63 @@ +unit sliceinterpolate; + +interface +uses define_types, dialogs, nifti_hdr; + +procedure ROISliceInterpolate (var lHdr: TMRIcroHdr); + +implementation + +procedure ROISliceInterpolate (var lHdr: TMRIcroHdr); +const + knRef = 14; + kRefSlices: array [1..knRef] of integer = (32,40,48,56,64,72,80,88,96,104,112,122,132,142); +var + l8Buf: Bytep; + l16Buf : SmallIntP; + l32Buf : SingleP; + lXDim,lYDim,lZDim, + lLo,lHi,lRef,lZ,lY,lX,lV,lSliceSz,lLoSliceStart,lHiSliceStart,lSliceStart,lPos: integer; + lLoFrac,lHiFrac: single; +begin + lXDim := lHdr.NIFTIhdr.dim[1]; + lYDim := lHdr.NIFTIhdr.dim[2]; + lZDim := lHdr.NIFTIhdr.dim[3]; + for lRef := 1 to knRef do + if kRefSlices[lRef] > lZDim then begin + showmessage('Out of bounds'); + exit; + end; + lSliceSz := lXDim * lYDim; + + for lZ := kRefSlices[1] to kRefSlices[knRef] do begin + for lRef := 1 to knRef do + if kRefSlices[lRef] <= lZ then + lLo := kRefSlices[lRef]; + for lRef := knRef downto 1 do + if kRefSlices[lRef] >= lZ then + lHi := kRefSlices[lRef]; + if lLo <> lHi then begin //do not interpolate reference slices + lHiFrac := (lZ - lLo) /(lHi-lLo); + lLoFrac := 1 - lHiFrac; + lSliceStart := lSliceSz * (lZ-1); + lLoSliceStart := lSliceSz * (lLo-1); + lHiSliceStart := lSliceSz * (lHi-1); + if lHdr.ImgBufferBPP = 4 then begin + l32Buf := SingleP(lHdr.ImgBuffer); + for lPos := 1 to lSliceSz do + l32Buf^[lPos + lSliceStart] :=((lLoFrac*l32Buf^[lPos + lLoSliceStart]) +(lHiFrac*l32Buf^[lPos + lHiSliceStart])); + end else if lHdr.ImgBufferBPP = 2 then begin //not 32bit - if 16bit input + l16Buf := SmallIntP(lHdr.ImgBuffer); + for lPos := 1 to lSliceSz do + l16Buf^[lPos + lSliceStart] := round((lLoFrac*l16Buf^[lPos + lLoSliceStart]) +(lHiFrac*l16Buf^[lPos + lHiSliceStart]) ); + end else if lHdr.ImgBufferBPP = 1 then begin //not 8bit input + l8Buf := lHdr.ImgBuffer; + for lPos := 1 to lSliceSz do + l8Buf^[lPos + lSliceStart] := round((lLoFrac*l8Buf^[lPos + lLoSliceStart]) +(lHiFrac*l8Buf^[lPos + lHiSliceStart]) ); + end; // + end; //if lLo <> lHi + end;//for lZ +end; //ezInterpolate + +end. + \ No newline at end of file diff --git a/niftiview7/smooth.bmp b/niftiview7/smooth.bmp new file mode 100755 index 0000000..cc4ada8 Binary files /dev/null and b/niftiview7/smooth.bmp differ diff --git a/niftiview7/smoothVOI.pas b/niftiview7/smoothVOI.pas new file mode 100755 index 0000000..540d37a --- /dev/null +++ b/niftiview7/smoothVOI.pas @@ -0,0 +1,490 @@ +unit smoothVOI; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin, Buttons,define_types,nifti_img_view,nifti_img, Mask; + +type + TSmoothVOIForm = class(TForm) + Label37: TLabel; + Label38: TLabel; + CancelBtn: TSpeedButton; + OKBtn: TSpeedButton; + SpeedButton5: TSpeedButton; + XROIthresh: TRxSpinEdit; + XROIfwhm: TRxSpinEdit; + ScaleSides: TComboBox; + xROIoutput: TComboBox; + procedure SpeedButton5Click(Sender: TObject); + procedure CloseBtnClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure SmoothOpenVOI(Sender: TObject); + procedure SmoothVOI_SPM5masks; + private + { Private declarations } + public + { Public declarations } + end; + +var + SmoothVOIForm: TSmoothVOIForm; + +implementation + +{$R *.DFM} + +procedure TSmoothVOIForm.SpeedButton5Click(Sender: TObject); +begin + Showmessage('The Full Width Half Maximum [FWHM] defines the width of the smoothing Gaussian. '+ + 'The threshold defines a binary cutoff boundary - signals greater than the threshold will be included in the output. '+ + 'A threshold of 0 will create an continuous 8-bit output (0..200 for signal 0..1)'); +end; + +procedure TSmoothVOIForm.CloseBtnClick(Sender: TObject); +begin + if (Sender as TSpeedButton).tag = 1 then + SmoothOpenVOI(Sender); + SmoothVOIForm.Close; +end; + +procedure TSmoothVOIForm.FormShow(Sender: TObject); +begin + SmoothVOIForm.ModalResult := mrCancel; + +end; + +procedure VOIinvert; +var + lI,lImgSz: integer; +begin + lImgSz := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lImgSz < 1 then exit; + CreateUndoVol; + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol^[lI] = 0 then + gBGImg.VOIUndoVol^[lI] := 1 + else + gBGImg.VOIUndoVol^[lI] := 0; + gBGImg.VOIchanged := true; + ImgForm.Undo1Click(nil); //show smoothed buffer +end; + +procedure TSmoothVOIForm.SmoothVOI_SPM5masks; +var + lBGname,lmaskname,llesionname: string; + lorigFWHM , + lorigThresh : single; + lorigSS,lOrigOut: integer; +begin + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + lBGname := gMRIcroOverlay[kBGOverlayNum].HdrFileName; + if not gMRIcroOverlay[kBGOverlayNum].NIfTItransform then begin + //need to save BG as NIfTI + lBGName := ChangeFilePrefix(lBGname,'x'); + SaveAsVOIorNIFTIcore(lBGName,gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + end; + lmaskname := ChangeFilePrefix(lBGname,'m'); + lmaskname := changefileextx(lmaskname, '.nii'); + llesionname := ChangeFilePrefix(lBGname,'l'); + llesionname := changefileextx(llesionname, '.nii'); + if (fileexists(lmaskname)) or (fileexists(llesionname)) then begin + showmessage ('Files already exist named '+lmaskname+' '+llesionname); + exit; + end; + //init + lorigFWHM := XROIfwhm.value; + lorigThresh := XROIthresh.value; + lorigSS := SmoothVOIForm.ScaleSides.itemindex; + lorigOut := xROIoutput.itemindex; + //compute mask + XROIfwhm.value := gBGImg.LesionDilate; + XROIthresh.value := 0.001; + ScaleSides.itemindex:=(1); + xROIoutput.itemindex:=(1); + if gBGImg.LesionDilate <= 0 then + VOIinvert + else + SmoothOpenVOI(nil); + if (gBGImg.VOIUndoSlice < 1) or (gBGImg.VOIUndoOrient <> 4) then begin //should be impossible - smoothVOI creates undovol + showmessage('Serious error.'); + exit; + end; + ImgForm.StatusLabel.caption := 'Saving mask as '+lmaskname; + gMRIcroOverlay[kVOIOverlayNum].HdrFileName := lmaskname; + ImgForm.SaveVOIcore(false);//12/2010 //unmirrors image + //xx SaveAsVOIorNIFTIcore (lmaskname, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + //compute lesion + UndoVolVOI; + + XROIfwhm.value := gBGImg.LesionSmooth; + XROIthresh.value := 0.5; + //ScaleSides.setitemindex(0); + xROIoutput.itemindex:=(0); + SmoothOpenVOI(nil); + gMRIcroOverlay[kVOIOverlayNum].HdrFileName := llesionname; + ImgForm.SaveVOIcore(false);//12/2010 //unmirrors image + gMRIcroOverlay[kVOIOverlayNum].HdrFileName := lmaskname; + + //SaveAsVOIorNIFTIcore (llesionname, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + + //re-init + UndoVolVOI; + + XROIfwhm.value := lorigFWHM; + XROIthresh.value := lorigThresh; + ScaleSides.itemindex:=(lOrigSS); + xROIoutput.itemindex:=(lOrigOut); +end; + +procedure TSmoothVOIForm.SmoothOpenVOI(Sender: TObject); +//label +// 123; +var + lScaleXY,lOK,lResliceNotMask: boolean; + lZXra,lYOutra,lROIrealRA: SingleP; + lIncX,lSliceZ, + lSlicePos,lMissing,lZPos,lYPos,lSliceSz,lXt,lYt,lZt,lX,lY,lZ,lXoffset,lYOffset,lZOffset,lI,lI2,lImgSz,lcutoffvoxx,lcutoffvoxy,lcutoffvoxz: integer; + lScale,lThreshComp,lExpd,lThresh,lXVar,lSig,lXmm,lYmm,lZmm,lcumgauss: single;//double; + lxra,lyra,lzra,lzraScaled,lxCutra,lyCutra,lzCutra:SingleP0;//x0P; + lStartTime,lEndTime: DWord; + lXDim,lYDim,lZDim,lPlanes,lMinX,lMaxX,lMinY,lMaxY,lMinZ,lMaxZ: integer; +begin + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lXmm := gBGImg.ScrnMM[1]; + lYmm := gBGImg.ScrnMM[2]; + lZmm := gBGImg.ScrnMM[3]; + lResliceNotMask := false; + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + if (gBGImg.ScrnMM[1] = 0) or (lXmm = 0) or (lYmm = 0) or (lZmm =0) or (SmoothVOIForm.XROIfwhm.value=0) then begin + ShowMessage('At least one of the images ''size [mm]'' settings or the ''FWHM [mm]'' is zero. Smoothing requires the image size to be specified.'); + Exit; + end; + if SmoothVOIForm.ScaleSides.itemindex = 1 then + lScaleXY := true + else + lScaleXY := false; + lOK := true; + if lScaleXY then begin + lsig := (SmoothVOIForm.XROIfwhm.value / lXmm)/sqrt(8*ln(2)); // % FWHM -> sigma + lcutoffvoxX := round(6*lsig); + if (lcutoffvoxX *2) >= lXdim then lOK := false; + lsig := (SmoothVOIForm.XROIfwhm.value / lYmm)/sqrt(8*ln(2)); // % FWHM -> sigma + lcutoffvoxY := round(6*lsig); + if (lcutoffvoxY *2) >= lYdim then lOK := false; + end; {scaleXY} + lsig := (SmoothVOIForm.XROIfwhm.value / lZmm)/sqrt(8*ln(2)); // % FWHM -> sigma + lcutoffvoxZ := round(6*lsig); + if (lcutoffvoxZ *2) >= lZdim then lOK := false; + if not lOK then begin + showmessage('Unable to smooth image: image dimensions are too small for such a broad smoothing. Reduce the FWHM'); + exit; + end; + if SmoothVOIForm.xROIoutput.itemindex <> 1 then + lResliceNotMask := true; + lImgSz := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lImgSz < 1 then exit; + CreateUndoVol;//create gBGImg.VOIUndoVol + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + if lResliceNotMask then begin //reslice + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol[lI] <> 0 then + gBGImg.VOIUndoVol[lI] := 1; + end else begin //create mask: invert + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol[lI] = 0 then + gBGImg.VOIUndoVol[lI] := 1 + else + gBGImg.VOIUndoVol[lI] := 0; + end; //create mask + lSliceSz := lXdim * lYdim; + //lZXi := lZdim*lXdim; //for swizzle + lPlanes := 0; + ImgForm.ProgressBar1.Position := 0; + ImgForm.ProgressBar1.Min := 0; + ImgForm.ProgressBar1.Max := lZdim * 3; + ImgForm.StatusLabel.caption := 'Smoothing slice data: X-plane'; + lStartTime := GetTickCount; + lThresh := SmoothVOIForm.XRoiThresh.value; + lsig := (SmoothVOIForm.XROIfwhm.value / lXmm)/sqrt(8*ln(2)); // % FWHM -> sigma + if lsig = 0 then begin + Showmessage('Unable to compute gaussian with current FWHM'); + exit; + end; + lcutoffvoxx := round(6*lsig); // % highest / lowest voxel to go out to + getmem(lxra,(lcutoffvoxx+1)*sizeof(double {was extended})); + getmem(lxCutra,(lcutoffvoxx+1)*sizeof(double {was extended})); + lexpd := 2*lsig*lsig; + lCumGauss := 0; + for lI := 0 to lcutoffvoxx do begin + lxra[lI] := exp(-1*(lI*lI)/lexpd) ; + lCumGauss := lCumGauss + lxra[lI]; + end; + lCumGauss := 2*lCumGauss - lxra[0]; + if lCumGauss <> 0 then + for lI := 0 to lcutoffvoxx do begin + lxra[lI] := lxra[lI]/lCumGauss; + end; + for lI := 1 to lcutoffvoxX do begin + lCumGauss := 0; + for lI2 := (lcutoffvoxX - lI) downto -lcutoffvoxX do + lCumGauss := lCumGauss + lXra[abs(lI2)]; + if lCumGauss <> 0 then + lXCutra[lI] := 1/lCumGauss; + end; + lXCutra[0] := 1; + lsig := (SmoothVOIForm.XROIfwhm.value / lYmm)/sqrt(8*ln(2)); // % FWHM -> sigma + if lsig = 0 then begin + Showmessage('Unable to compute gaussian with current FWHM'); + exit; + end; + lcutoffvoxY := round(6*lsig); // % highest / lowest voxel to go out to + getmem(lYra,(lcutoffvoxY+1)*sizeof(double {was extended})); + getmem(lYCutra,(lcutoffvoxY+1)*sizeof(double {was extended})); + lexpd := 2*lsig*lsig; + lCumGauss := 0; + for lI := 0 to lcutoffvoxY do begin + lYra[lI] := exp(-1*(lI*lI)/lexpd) ; + lCumGauss := lCumGauss + lYra[lI]; + end; + lCumGauss := 2*lCumGauss - lYra[0]; + if lCumGauss <> 0 then + for lI := 0 to lcutoffvoxY do begin + lYra[lI] := lYra[lI]/lCumGauss; + end; + + for lI := 1 to lcutoffvoxY do begin + lCumGauss := 0; + for lI2 := (lcutoffvoxY - lI) downto -lcutoffvoxY do + lCumGauss := lCumGauss + lYra[abs(lI2)]; + if lCumGauss <> 0 then + lYCutra[lI] := 1/lCumGauss; + end; + lYCutra[0] := 1;(**) + lsig := (SmoothVOIForm.XROIfwhm.value / lZmm)/sqrt(8*ln(2)); // % FWHM -> sigma + if lsig = 0 then begin + Showmessage('Unable to compute gaussian with current FWHM'); + exit; + end; + lcutoffvoxZ := round(6*lsig); // % highest / lowest voxel to go out to + getmem(lZra,(lcutoffvoxZ+1)*sizeof(double {was extended})); + getmem(lZraScaled,(lcutoffvoxZ+lcutoffvoxZ+1)*sizeof(double {was extended})); + getmem(lZCutra,(lcutoffvoxZ+1)*sizeof(double {was extended})); + lexpd := 2*lsig*lsig; + lCumGauss := 0; + for lI := 0 to lcutoffvoxZ do begin + lZra[lI] := exp(-1*(lI*lI)/lexpd ); + lCumGauss := lCumGauss + lZra[lI]; + end; + lCumGauss := 2*lCumGauss - lZra[0]; + if lCumGauss <> 0 then + for lI := 0 to lcutoffvoxZ do begin + lZra[lI] := lZra[lI]/lCumGauss; + end; + for lI := 1 to lcutoffvoxZ do begin + lCumGauss := 0; + for lI2 := (lcutoffvoxZ - lI) downto -lcutoffvoxZ do + lCumGauss := lCumGauss + lZra[abs(lI2)]; + if lCumGauss <> 0 then + lZCutra[lI] := 1/lCumGauss; + end; + lZCutra[0] := 1;(**) + GetMem ( lROIrealRA , sizeof(single)*lImgSz); + GetMem (lYOutRA, sizeof(single) * lYdim); + if lResliceNotMask then + for lI := 1 to lImgSz do + lROIrealRA[lI] := 0 + else + for lI := 1 to lImgSz do + lROIrealRA[lI] := 1; + //X-direction + for lZ := 1 to lZdim do begin + lZPos := (lZ-1)*lSliceSz; + for lY := 1 to lYdim do begin + lyPos := (lY-1)*lXdim; + for lX := 1 to lXdim do begin + lMinX := lX - lCutoffVoxX; + if lMinX < 1 then lMinX := 1; + lMaxX := lX + lCutoffVoxX; + if lMaxX > lXdim then lMaxX := lXdim; + lMissing := (2*lCutOffVoxX)-(lMaxX-lMinX); + if lScaleXY then + lScale := lXCutRA[lMissing] + else + lScale := lXCutRA[0]; + lCumGauss := 0; + for lXt := lMinX to lMaxX do begin + //SSE optimization? + if (gBGImg.VOIUndoVol[lXt+lYPos+lZpos] <> 0) then + lCumGauss := lCumGauss + lScale*lXra[abs(lX-lXt)] (*{kSmoothImg}*(gROIEXport[lXt+lYPos+lZpos]/255)*); + end; {for each position} + lROIrealRA[lX+lYPos+lZpos] := lCumGauss; + end; {lX} + end; {lY} + + Application.ProcessMessages; + inc(lPlanes); + ImgForm.ProgressBar1.Position := lPLanes; + end; {lZ loop for X-plane} + ImgForm.StatusLabel.caption := 'Smoothing slice data: Y-plane'; + for lZ := 1 to lZdim do begin {Z loop for Y plane} + lZPos := (lZ-1)*lSliceSz; + for lX := 1 to lXdim do begin + for lY := 1 to lYdim do begin + lMinY := lY - lCutoffVoxY; + if lMinY < 1 then lMinY := 1; + lMaxY := lY + lCutoffVoxY; + if lMaxY > lYdim then lMaxY := lYdim; + lMissing := (2*lCutOffVoxY)-(lMaxY-lMinY); + if lScaleXY then + lScale := lYCutRA[lMissing] + else + lScale := lYCutRA[0]; + lCumGauss := 0; + for lYt := lMinY to lMaxY do begin + //SSE optimization? + lCumGauss := lCumGauss+ lScale*(lROIrealRA[lX+((lYt-1)*lXdim)+lZpos])*lYra[abs(lY-lYt)]; + end; {for each position} + lYOutRA[lY] := lCumGauss; + end; {lY} + for lY := 1 to lYdim do begin + //SSE optimization + lROIrealRA[lX+((lY-1)*lXdim)+lZpos] := lYOutRA[lY]; + end; + end; {lX} + Application.ProcessMessages; + inc(lPlanes); + ImgForm.ProgressBar1.Position := lPlanes; + end; {Z loop for Y plane} + (*if (not lScaleXY) then begin + //lOrigZPos := (lFirstEmptySlice-1)*lSliceSz; + for lZ := lFirstEmptySlice to lZi do begin + if (lROIonSliceRA[lZ]=0) then begin + lZPos := (lZ-1)*lSliceSz; + for lX := 1 to lSliceSz do + //SSE optimization? + lROIrealRA[lX+lZPos] := lROIrealRA[lX+lOrigZPos]; + Application.ProcessMessages; + end; {no ROI on this slice} + end; {for n slices} + end; {not scaled} (**) + lThreshComp := 1 - lThresh; + ImgForm.StatusLabel.caption := 'Smoothing slice data: Z-plane'; + lI := 0; + for lZ := 1 to lZdim do begin + lMinZ := lZ - lCutoffVoxZ; + if lMinZ < 1 then lMinZ := 1; + lMaxZ := lZ + lCutoffVoxZ; + if lMaxZ > lZdim then lMaxZ := lZdim; + lScale := 1; + lMissing := (2*lCutOffVoxZ)-(lMaxZ-lMinZ); + if (lMissing >= 0) and (lMissing <= lCutOffVoxZ) then + lScale := lZCutRA[lMissing]; + if lThreshComp <> 1 then begin +if lResliceNotMask then begin + for lIncX := 1 to lcutoffvoxZ do + lZraScaled[lcutoffvoxZ-lIncX] := lZra[lIncX]*lScale; + for lIncX := 0 to lcutoffvoxZ do + lZraScaled[lcutoffvoxZ+lIncX] := lZra[lIncX]*lScale; + lZOffset := lcutoffvoxZ + lZ; + for lY := 1 to lYdim do begin + lyPos := (lY-1)*lXdim; + for lX := 1 to lXdim do begin + lCumGauss := 0; + lIncX := ((lMinZ-1)*lSliceSz)+lX+lYPos; + for lZt := lMinZ to lMaxZ do begin + lCumGauss := lCumGauss + lROIrealRA[lIncX]*lZraScaled[(lZoffset-lZt)]; + lIncX := lIncX+ lSliceSz + //SSE optimization + //lCumGauss := lCumGauss + lROIrealRA[lX+lYPos+(lZt-1)*lSliceSz]*lZra[abs(lZ-lZt)]*lScale; + end; + inc(lI); + if (lCumGauss < (1-lThreshComp)) then + gBGImg.VOIUndoVol[lI] := 100 + else + gBGImg.VOIUndoVol[lI] := 0; + end; {lX} + end; {lY} +end else begin //this is a mask -> unrolled loop means faster processing + for lY := 1 to lYdim do begin + lyPos := (lY-1)*lXdim; + for lX := 1 to lXdim do begin + lCumGauss := 0; + for lZt := lMinZ to lMaxZ do + lCumGauss := lCumGauss + lROIrealRA[lX+lYPos+(lZt-1)*lSliceSz]*lZra[abs(lZ-lZt)]*lScale; + inc(lI); + if lCumGauss > lThreshComp then + gBGImg.VOIUndoVol[lI] := 0 + else + gBGImg.VOIUndoVol[lI] := 100; + end; {lX} + end; {lY} +end; + end else begin //threshcomp = 1 analogua output + for lY := 1 to lYdim do begin + lyPos := (lY-1)*lXdim; + for lX := 1 to lXdim do begin + lCumGauss := 0; + for lZt := lMinZ to lMaxZ do + //SSE optimization? + lCumGauss := lCumGauss + lROIrealRA[lX+lYPos+(lZt-1)*lSliceSz]*lZra[abs(lZ-lZt)]*lScale; + inc(lI); + gBGImg.VOIUndoVol[lI] := round(200 * lCumGauss); + end; {lX} + end; {lY} + end; //threshcomp=1 analogue output + Application.ProcessMessages; + inc(lPlanes); + ImgForm.ProgressBar1.Position := lPlanes; + end; {lZ loop} + lEndTime := GetTickCOunt; + ImgForm.StatusLabel.caption :=('Smoothing time(ms): '+inttostr(lEndTime-lStartTime)); + FreeMem (lROIrealRA); + FreeMem (lYOutRA); + Freemem(lXra); + Freemem(lYra); + Freemem(lZra); + Freemem(lZraScaled); + Freemem(lXCutra); + Freemem(lYCutra); + Freemem(lZCutra); + if (lThreshComp = 1) then begin //analogue output + //gGlMaxUnscaledS := 200; + //Scale.value := 0.0050000; + for lI := 1 to lImgSz do + gBGImg.VOIUndoVol[lI] := 200 - gBGImg.VOIUndoVol[lI]; + end else begin //threshcomp <> 1 + //gGlMaxUnscaledS := 100; + //Scale.value := 0.0100000; + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol[lI] = 0 then + gBGImg.VOIUndoVol[lI] := kVOI8bit + else + gBGImg.VOIUndoVol[lI] := 0; + end; //Threshcomp <> 1 so digital output + lResliceNotMask := false; + gBGImg.VOIchanged := true; + ImgForm.ProgressBar1.Position := 0; + ImgForm.Undo1Click(nil); //show smoothed buffer + end; + +procedure TSmoothVOIForm.FormCreate(Sender: TObject); +begin + ScaleSides.itemindex:=(0); + xROIoutput.itemindex:=(0); + XROIthresh.value := 0.5; + XROIfwhm.value := 8; +end; + +end. diff --git a/niftiview7/statclustertable.pas b/niftiview7/statclustertable.pas new file mode 100755 index 0000000..4a3edd4 --- /dev/null +++ b/niftiview7/statclustertable.pas @@ -0,0 +1,313 @@ +unit statclustertable; +//USED by stats to select only regions with a given number of connected/contiguous voxels +interface +uses define_types,dialogs,SysUtils,nifti_hdr,nifti_img, classes; + +//procedure FindClustersText (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double); +procedure BatchCluster; + + +implementation + +uses text,nifti_img_view, nifti_hdr_view, readfloat, readint; + + + +procedure FindClustersText (var lHdr: TMRIcroHdr; lThreshIn: single; lMinClusterSz: integer); +var + lClusterMaxPos,lXdim,lYdim,lZdim,lScaledThresh,lClusterSz,lClusterFillVal,lQTail,lQHead,lSliceSz,lQSz,lInc,lVolSz: integer; + lThresh,lClusterMax: single; + lClusterBuffS: SingleP; + lQra: LongIntP; + lXcom,lYcom,lZcom,lBuffIn32 : SingleP; + lBuffIn16 : SmallIntP; + lCh: char; +procedure InitCenterOfMass; +begin + getmem(lXcom, lXDim*sizeof(single)); + getmem(lYcom, lYDim*sizeof(single)); + getmem(lZcom, lZDim*sizeof(single)); +end; + +procedure FreeCenterOfMass; +begin + freemem(lXcom); + freemem(lYcom); + freemem(lZcom); +end; + +procedure ClearCenterOfMass; +var + i: integer; +begin + for i := 1 to lXDim do + lXcom^[i] := 0; + for i := 1 to lYDim do + lYcom^[i] := 0; + for i := 1 to lZDim do + lZcom^[i] := 0; +end; + +procedure AddCenterOfMass (lVox: integer; lInten: single); +var + lXi,lYi,lZi: integer; +begin +//lukas + ImgPosToSlices(lVox,lXi,lYi,lZi); + lXcom^[lXi] := lXcom^[lXi] + lInten; + lYcom^[lYi] := lYcom^[lYi] + lInten; + lZcom^[lZi] := lZcom^[lZi] + lInten; +end; + +function CenterOfMassPosition: integer; +var + i : integer; + lSum,lXs,lYs,lZs: double; +begin + lSum := 0; + lXs := 0; + for i := 1 to lXDim do + lSum := lSum +lXcom^[i]; + for i := 1 to lXDim do + lXs := lXs +(i*lXcom^[i]); + if lSum > 0 then + lXs := lXs/lSum; + // + lSum := 0; + lYs := 0; + for i := 1 to lYDim do + lSum := lSum +lYcom^[i]; + for i := 1 to lYDim do + lYs := lYs +(i*lYcom^[i]); + if lSum > 0 then + lYs := lYs/lSum; + //Z + lSum := 0; + lZs := 0; + for i := 1 to lZDim do + lSum := lSum +lZcom^[i]; + for i := 1 to lZDim do + lZs := lZs +(i*lZcom^[i]); + if lSum > 0 then + lZs := lzs/lSum; + result := SlicesToImgPos(round(lXs),round(lYs),round(lZs)); + //fx(result, lXs,lYs,lZs); +end; + +function XYZstr (lPos: integer): string; +var lXmm,lYmm,lZmm: single; +begin + ImgPosToMM(lPos, lXmm,lYmm,lZmm); + result := inttostr(round(lXmm))+kTextSep+inttostr(round(lYmm))+kTextSep+inttostr(round(lZmm)); +end; + +procedure Report (lClusterMax: single; lClusterSz, lClusterMaxPos: integer); +var + lTemplateLabel: string; +begin + if lClusterSz < lMinClusterSz then + exit; + //lTemplateLabel := ImgForm.BGLabelString(lClusterMaxPos); + //burger ImgIntensityString + lTemplateLabel := ImgForm.ImgIntensityString(gMRIcroOverlay[2], lClusterMaxPos); + TextForm.MemoT.lines.add(XYZstr(lClusterMaxPos)+kTextSep+XYZstr(CenterOfMassPosition)+kTextSep+inttostr(lClusterSz)+kTextSep+lCh+floattostr(lClusterMax)+kTextSep+lTemplateLabel); +end; + +procedure ReportLabel; +begin + TextForm.MemoT.lines.add('# Data='+kTextSep+lHdr.HdrFileName +kTextSep+'Threshold='+kTextSep+floattostr(lThreshIn) +kTextSep+'MinCluster='+kTextSep+inttostr(lMinClusterSz)); + TextForm.MemoT.lines.add('#X'+kTextSep+'Y'+kTextSep+'Z'+kTextSep+'Xcom'+kTextSep+'Ycom'+kTextSep+'Zcom'+kTextSep+'ClusterSize[Vox]'+kTextSep+'Max'+kTextSep+'BA'+kTextSep+'AAL'); + +end; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; + +procedure Check(lPixel: integer); +var + lVal: single; +begin + lVal := lClusterBuffS[lPixel]; + if (lVal= 0) then + exit; + AddCenterOfMass(lPixel,lVal); + if lVal > lClusterMax then begin + lClusterMax := lVal; + lClusterMaxPos := lPixel; + end; + incQra(lQHead,lQSz); + inc(lClusterSz); + lClusterBuffS[lPixel] := 0; + lQra[lQHead] := lPixel; +end; + +PROCEDURE RetirePixel; //FIFO cleanup , 1410: added 18-voxel check +VAR + lVal,lValX,lXPos,lYPos,lZPos: integer; +BEGIN + lVal := lQra[lQTail]; + if lVal = 0 then begin + incQra(lQTail,lQSz); //done with this pixel + exit; + end; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + lZpos := ((lVal-1) div lSliceSz)+1; + if (lXPos <= 1) or (lXPos >= lXDim) or + (lYPos <= 1) or (lYPos >= lYDim) or + (lZPos <= 1) or (lZPos >= lZDim) then + // retire and exiT + else begin + //lXDimM := lXDim; + Check(lVal-1); //left + Check(lVal+1); //right + Check(lVal-lXDim); //up + Check(lVal+lXDim); //down + Check(lVal-lSliceSz); //up + Check(lVal+lSliceSz); //down + //check plane above + lValX := lVal + lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDim); //up + Check(lValX+lXDim); //down + //check plane below + lValX := lVal - lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDim); //up + Check(lValX+lXDim); //down + //check diagonals of current plane + Check(lVal-lXDim-1); //up, left + Check(lVal-lXDim+1); //up, right + Check(lVal+lXDim-1); //down, left + Check(lVal+lXDim+1); //down, right + end; //not edge + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + if (lClusterBuffS[lPt]=0) then exit; + for lI := 1 to lQsz do + lQra[lI] := 0; + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + // check that there was anything in the cluster at all + //showmessage('head'+inttostr(lQHead)+'.'+inttostr(lQTail)); + //if lQHead > 2 then begin + // and do the recursion to get rid of it + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +begin + lCh := ' '; //assume positive values + lXDim := lHdr.NIFTIhdr.dim[1]; + lYDim := lHdr.NIFTIhdr.dim[2]; + lZDim := lHdr.NIFTIhdr.dim[3]; + InitCenterOfMass; + lVolSz := lXdim*lYdim*lZdim; + lSliceSz := lXdim * lYdim; + if (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) or (lHdr.ImgBufferItems <> lVolSz) then exit; + GetMem(lClusterBuffS, lVolSz* sizeof(Single)); + ReportLabel; + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lBuffIn32^[lInc]; + end else if lHdr.ImgBufferBPP = 2 then begin //not 32bit - if 16bit input + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lBuffIn16^[lInc]; + end else begin //not 16 or 32 bit input + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lHdr.ImgBuffer^[lInc]; + end; //8-bit input + //Next - apply scale and intercept + if (lHdr.NIFTIhdr.scl_slope <> 0) and (lHdr.NIFTIhdr.scl_slope <> 1) then //if one then no effect - zero is meaningless + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lClusterBuffS^[lInc]*lHdr.NIFTIhdr.scl_slope; + if (lHdr.NIFTIhdr.scl_inter <> 0) then //if zero then no effect + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lClusterBuffS^[lInc]+lHdr.NIFTIhdr.scl_inter; + lThresh := lThreshIn; + if lThreshIn < 0 then begin //invert all values... + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := -lClusterBuffS^[lInc]; + lThresh := -lThresh; + lCh := '-'; + end; + //Next - zero all voxels less than threshold + for lInc := 1 to lVolSz do + if (lClusterBuffS[lInc]) < lThresh then + lClusterBuffS^[lInc] := 0; + //Next - get memory + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + //check positive clusters.... + ClearCenterOfMass; + for lInc := 1 to lVolSz do begin + if lClusterBuffS[lInc] <> 0 then begin + lClusterSz := 0; + lClusterMax := 0; + FillStart(lInc); + // now fill the cluster with its size (=1 if the voxel was isolated) + Report (lClusterMax,lClusterSz,lClusterMaxPos); + ClearCenterOfMass; + end; + end; + FreeCenterOfMass; + Freemem(lQra); + Freemem(lClusterBuffS); +end; + +procedure BatchCluster; +var + lInc,lNumberofFiles,lMinClusterSz: integer; + lFilename,lTemplateName:string; + lPref: boolean; + lThresh: single; +begin + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + lMinClusterSz := ReadIntForm.GetInt('Minimum cluster size [in voxels]: ', 1,4,9999); + lThresh := ReadFloatForm.GetFloat('Please enter statistical threshold. ', -9999,2.3,9999); + lTemplateName := ''; + if OpenDialogExecute(kImgFilter,'Select anatomical template (optional)',false) then begin + lTemplateName := HdrForm.OpenHdrDlg.Filename; + end; + if not OpenDialogExecute(kImgFilter,'Select statistical maps',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + if not fileexists(lTemplateName) then + lTemplateName := ''; + TextForm.MemoT.Lines.Clear; + lPref := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + + ImgForm.OpenAndDisplayImg(lFilename,false); + if lTemplateName <> '' then + ImgForm.OverlayOpenCore ( lTemplateName, 2); + FindClustersText(gMRIcroOverlay[kBGOverlayNum], lThresh,lMinClusterSz); + end;//lLoop + gBGImg.ResliceOnLoad := lPref; + TextForm.Show; +end; + +end. diff --git a/niftiview7/templates/aal.nii.gz b/niftiview7/templates/aal.nii.gz new file mode 100755 index 0000000..21e4a73 Binary files /dev/null and b/niftiview7/templates/aal.nii.gz differ diff --git a/niftiview7/templates/aal.nii.lut b/niftiview7/templates/aal.nii.lut new file mode 100755 index 0000000..7c8e0f8 Binary files /dev/null and b/niftiview7/templates/aal.nii.lut differ diff --git a/niftiview7/templates/aal.nii.txt b/niftiview7/templates/aal.nii.txt new file mode 100755 index 0000000..6e1dc4a --- /dev/null +++ b/niftiview7/templates/aal.nii.txt @@ -0,0 +1,117 @@ +1 Precentral_L 2001 +2 Precentral_R 2002 +3 Frontal_Sup_L 2101 +4 Frontal_Sup_R 2102 +5 Frontal_Sup_Orb_L 2111 +6 Frontal_Sup_Orb_R 2112 +7 Frontal_Mid_L 2201 +8 Frontal_Mid_R 2202 +9 Frontal_Mid_Orb_L 2211 +10 Frontal_Mid_Orb_R 2212 +11 Frontal_Inf_Oper_L 2301 +12 Frontal_Inf_Oper_R 2302 +13 Frontal_Inf_Tri_L 2311 +14 Frontal_Inf_Tri_R 2312 +15 Frontal_Inf_Orb_L 2321 +16 Frontal_Inf_Orb_R 2322 +17 Rolandic_Oper_L 2331 +18 Rolandic_Oper_R 2332 +19 Supp_Motor_Area_L 2401 +20 Supp_Motor_Area_R 2402 +21 Olfactory_L 2501 +22 Olfactory_R 2502 +23 Frontal_Sup_Medial_L 2601 +24 Frontal_Sup_Medial_R 2602 +25 Frontal_Mid_Orb_L 2611 +26 Frontal_Mid_Orb_R 2612 +27 Rectus_L 2701 +28 Rectus_R 2702 +29 Insula_L 3001 +30 Insula_R 3002 +31 Cingulum_Ant_L 4001 +32 Cingulum_Ant_R 4002 +33 Cingulum_Mid_L 4011 +34 Cingulum_Mid_R 4012 +35 Cingulum_Post_L 4021 +36 Cingulum_Post_R 4022 +37 Hippocampus_L 4101 +38 Hippocampus_R 4102 +39 ParaHippocampal_L 4111 +40 ParaHippocampal_R 4112 +41 Amygdala_L 4201 +42 Amygdala_R 4202 +43 Calcarine_L 5001 +44 Calcarine_R 5002 +45 Cuneus_L 5011 +46 Cuneus_R 5012 +47 Lingual_L 5021 +48 Lingual_R 5022 +49 Occipital_Sup_L 5101 +50 Occipital_Sup_R 5102 +51 Occipital_Mid_L 5201 +52 Occipital_Mid_R 5202 +53 Occipital_Inf_L 5301 +54 Occipital_Inf_R 5302 +55 Fusiform_L 5401 +56 Fusiform_R 5402 +57 Postcentral_L 6001 +58 Postcentral_R 6002 +59 Parietal_Sup_L 6101 +60 Parietal_Sup_R 6102 +61 Parietal_Inf_L 6201 +62 Parietal_Inf_R 6202 +63 SupraMarginal_L 6211 +64 SupraMarginal_R 6212 +65 Angular_L 6221 +66 Angular_R 6222 +67 Precuneus_L 6301 +68 Precuneus_R 6302 +69 Paracentral_Lobule_L 6401 +70 Paracentral_Lobule_R 6402 +71 Caudate_L 7001 +72 Caudate_R 7002 +73 Putamen_L 7011 +74 Putamen_R 7012 +75 Pallidum_L 7021 +76 Pallidum_R 7022 +77 Thalamus_L 7101 +78 Thalamus_R 7102 +79 Heschl_L 8101 +80 Heschl_R 8102 +81 Temporal_Sup_L 8111 +82 Temporal_Sup_R 8112 +83 Temporal_Pole_Sup_L 8121 +84 Temporal_Pole_Sup_R 8122 +85 Temporal_Mid_L 8201 +86 Temporal_Mid_R 8202 +87 Temporal_Pole_Mid_L 8211 +88 Temporal_Pole_Mid_R 8212 +89 Temporal_Inf_L 8301 +90 Temporal_Inf_R 8302 +91 Cerebelum_Crus1_L 9001 +92 Cerebelum_Crus1_R 9002 +93 Cerebelum_Crus2_L 9011 +94 Cerebelum_Crus2_R 9012 +95 Cerebelum_3_L 9021 +96 Cerebelum_3_R 9022 +97 Cerebelum_4_5_L 9031 +98 Cerebelum_4_5_R 9032 +99 Cerebelum_6_L 9041 +100 Cerebelum_6_R 9042 +101 Cerebelum_7b_L 9051 +102 Cerebelum_7b_R 9052 +103 Cerebelum_8_L 9061 +104 Cerebelum_8_R 9062 +105 Cerebelum_9_L 9071 +106 Cerebelum_9_R 9072 +107 Cerebelum_10_L 9081 +108 Cerebelum_10_R 9082 +109 Vermis_1_2 9100 +110 Vermis_3 9110 +111 Vermis_4_5 9120 +112 Vermis_6 9130 +113 Vermis_7 9140 +114 Vermis_8 9150 +115 Vermis_9 9160 +116 Vermis_10 9170 + diff --git a/niftiview7/templates/brodmann.nii.gz b/niftiview7/templates/brodmann.nii.gz new file mode 100755 index 0000000..effe7be Binary files /dev/null and b/niftiview7/templates/brodmann.nii.gz differ diff --git a/niftiview7/templates/brodmann.nii.lut b/niftiview7/templates/brodmann.nii.lut new file mode 100755 index 0000000..6bdf199 Binary files /dev/null and b/niftiview7/templates/brodmann.nii.lut differ diff --git a/niftiview7/templates/ch2.nii.gz b/niftiview7/templates/ch2.nii.gz new file mode 100755 index 0000000..f691bba Binary files /dev/null and b/niftiview7/templates/ch2.nii.gz differ diff --git a/niftiview7/templates/ch2bet.nii.gz b/niftiview7/templates/ch2bet.nii.gz new file mode 100755 index 0000000..6daee0c Binary files /dev/null and b/niftiview7/templates/ch2bet.nii.gz differ diff --git a/niftiview7/templates/lch2bet.nii.nii b/niftiview7/templates/lch2bet.nii.nii new file mode 100755 index 0000000..9d2a75c Binary files /dev/null and b/niftiview7/templates/lch2bet.nii.nii differ diff --git a/niftiview7/templates/mch2bet.nii.nii b/niftiview7/templates/mch2bet.nii.nii new file mode 100755 index 0000000..62398c0 Binary files /dev/null and b/niftiview7/templates/mch2bet.nii.nii differ diff --git a/niftiview7/tpmath/Matrices.pas b/niftiview7/tpmath/Matrices.pas new file mode 100755 index 0000000..2610107 --- /dev/null +++ b/niftiview7/tpmath/Matrices.pas @@ -0,0 +1,1696 @@ +{ ********************************************************************** + * Unit MATRICES.PAS * + * Version 2.0 * + * (c) J. Debord, May 2001 * + ********************************************************************** + This unit implements dynamic allocation of vectors and matrices in + Pascal, together with various matrix operations. + + Dynamic allocation is allowed by declaring arrays as pointers. There + are 8 types available : + + PVector, PMatrix for floating point arrays + PIntVector, PIntMatrix for integer arrays + PBoolVector, PBoolMatrix for boolean arrays + PStrVector, PStrMatrix for string arrays (255 char.) + + To use these arrays in your programs, you must : + + (1) Declare variables of the appropriate type, e.g. + + var + V : PVector; + A : PMatrix; + + (2) Allocate each array BEFORE using it : + + DimVector(V, N); creates vector V[0..N] + DimMatrix(A, N, M); creates matrix A[0..N, 0..M] + where N, M are two integer variables + + If the allocation succeeds, all array elements are initialized + to zero (for numeric arrays), False (for boolean arrays), or + the null string (for string arrays). Otherwise, the pointer is + initialized to NIL. + + (3) Use arrays as in standard Turbo Pascal, with the following + exceptions : + + (a) You must use the indirection operator (^) to reference any + array element, i.e. write V^[I] and A^[I]^[J] instead of + V[I] and A[I,J]. + + (b) You cannot use the assignment operator (:=) to copy the + contents of an array into another array. Writing B := A + simply makes B point to the same memory block than A. You + must use one of the provided Copy... procedures (see their + documentation in the interface part of the unit). + + In addition, note that : + + (a) All arrays begin at index 0, so that the 0-indexed element + is always present, even if you don't use it. + + (b) A matrix is declared as an array of vectors, so that A^[I] + denotes the I-th vector of matrix A and may be used as any + vector. + + (4) Deallocate arrays when you no longer need them. This will free + the corresponding memory : + + DelVector(V, N); + DelMatrix(A, N, M); + + For more information, read the comments of each routine in the + interface part of the unit, and check the demo programs. + ********************************************************************** + References : + 1) 'Basic Programs for Scientists and Engineers' by A.R. Miller : + GaussJordan, InvMat + 2) Borland's Numerical Methods Toolbox : Det + 3) 'Numerical Recipes' by Press et al. : Cholesky, LU, SVD + 4) 'Matrix Computations' by Golub & Van Loan : QR_Decomp & QR_Solve + (Pascal implementation contributed by Mark Vaughan) + ********************************************************************** } + +unit Matrices; + +interface + +uses + FMath,dialogs,sysutils; + +{ ********************************************************************** + This section defines some error codes. + ********************************************************************** } + +const + MAT_OK = 0; { No error } + MAT_SINGUL = - 1; { Singular matrix } + MAT_NON_CONV = - 2; { Non convergence of iterative procedure } + MAT_NOT_PD = - 3; { Matrix not positive definite } + +{ ********************************************************************** + This section defines the vector and matrix types. Maximal sizes are + given for a 16-bit compiler (TP / BP / Delphi 1). Higher values may + be used with the 32-bit compilers (Delphi 2-4, FPK, GPC). + ********************************************************************** } + +const +{$IFDEF EXTENDEDREAL} + MAX_FLT = 6552; { Max size of real vector } +{$ELSE} +{$IFDEF SINGLEREAL} + MAX_FLT = 16382; +{$ELSE} +{$IFDEF PASCALREAL} + MAX_FLT = 10921; +{$ELSE} + {$DEFINE DOUBLEREAL} + MAX_FLT = 8190; +{$ENDIF} +{$ENDIF} +{$ENDIF} + + MAX_INT = 16382; { Max size of integer vector } + MAX_BOOL = 32766; { Max size of boolean vector } + MAX_STR = 254; { Max size of string vector } + MAX_VEC = 16382; { Max number of vectors in a matrix } + +type + Str255= string[255]; + TVector = array[0..MAX_FLT] of Float; + TIntVector = array[0..MAX_INT] of Integer; + TBoolVector = array[0..MAX_BOOL] of Boolean; + TStrVector = array[0..MAX_STR] of Str255; + + PVector = ^TVector; + PIntVector = ^TIntVector; + PBoolVector = ^TBoolVector; + PStrVector = ^TStrVector; + + TMatrix = array[0..MAX_VEC] of PVector; + TIntMatrix = array[0..MAX_VEC] of PIntVector; + TBoolMatrix = array[0..MAX_VEC] of PBoolVector; + TStrMatrix = array[0..MAX_VEC] of PStrVector; + + PMatrix = ^TMatrix; + PIntMatrix = ^TIntMatrix; + PBoolMatrix = ^TBoolMatrix; + PStrMatrix = ^TStrMatrix; + +{ ********************************************************************** + Memory allocation routines + ********************************************************************** } + +procedure DimVector(var V : PVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates floating point vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimIntVector(var V : PIntVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates integer vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimBoolVector(var V : PBoolVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates boolean vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimStrVector(var V : PStrVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates string vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates floating point matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates integer matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates boolean matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates string matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Memory deallocation routines + ********************************************************************** } + +procedure DelVector(var V : PVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes floating point vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelIntVector(var V : PIntVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes integer vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelBoolVector(var V : PBoolVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes boolean vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelStrVector(var V : PStrVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes string vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes floating point matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes integer matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes boolean matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes string matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Routines for copying vectors and matrices + ---------------------------------------------------------------------- + Lbound, Ubound : indices of first and last vector elements + Lbound1, Lbound2 : indices of first matrix element in each dimension + Ubound1, Ubound2 : indices of last matrix element in each dimension + ********************************************************************** } + +procedure SwapRows(I, K : Integer; A : PMatrix; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Exchanges rows I and K of matrix A + ---------------------------------------------------------------------- } + +procedure SwapCols(J, K : Integer; A : PMatrix; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Exchanges columns J and K of matrix A + ---------------------------------------------------------------------- } + +procedure CopyVector(Dest, Source : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into vector Dest + ---------------------------------------------------------------------- } + +procedure CopyMatrix(Dest, Source : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Copies matrix Source into matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyRowFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Row : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into line Row of matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyColFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Col : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into column Col of matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyVectorFromRow(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Row : Integer); +{ ---------------------------------------------------------------------- + Copies line Row of matrix Source into vector Dest + ---------------------------------------------------------------------- } + +procedure CopyVectorFromCol(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Col : Integer); +{ ---------------------------------------------------------------------- + Copies column Col of matrix Source into vector Dest + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Vector and matrix functions + ********************************************************************** } + +function Min(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the lowest value of vector X + ---------------------------------------------------------------------- } + +function Max(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the highest value of vector X + ---------------------------------------------------------------------- } + +function IntMin(X : PIntVector; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + Returns the lowest value of integer vector X + ---------------------------------------------------------------------- } + +function IntMax(X : PIntVector; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + Returns the highest value of integer vector X + ---------------------------------------------------------------------- } + +procedure Transpose(A : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer; + A_t : PMatrix); +{ ---------------------------------------------------------------------- + Transposes a matrix + ---------------------------------------------------------------------- + Input parameters : A = original matrix + Lbound1, + Lbound2 = indices of 1st matrix elem. in each dim. + Ubound1, + Ubound2 = indices of last matrix elem. in each dim. + ---------------------------------------------------------------------- + Output parameter : A_t = transposed matrix + ---------------------------------------------------------------------- } + +function GaussJordan(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + A_inv : PMatrix; X : PVector) : Integer; +{ ---------------------------------------------------------------------- + Solves a system of linear equations by the Gauss-Jordan method + ---------------------------------------------------------------------- + Input parameters : A = system matrix + B = constant vector + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameters : A_inv = inverse matrix + X = solution vector + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- } + +function InvMat(A : PMatrix; Lbound, Ubound : Integer; + A_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Computes the inverse of a square matrix by the Gauss-Jordan method + ---------------------------------------------------------------------- + Parameters : as in Gauss-Jordan + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- } + +function Det(A : PMatrix; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Computes the determinant of a square matrix + ---------------------------------------------------------------------- + Parameters : as in Gauss-Jordan + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function Cholesky(A : PMatrix; Lbound, Ubound : Integer; + L : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Cholesky decomposition. Factors the symmetric positive definite matrix + A as a product L * L', where L is a lower triangular matrix. This + procedure may be used as a test of positive definiteness. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameter : L = Cholesky factor of matrix A + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NOT_PD + ---------------------------------------------------------------------- } + +function LU_Decomp(A : PMatrix; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + LU decomposition. Factors the square matrix A as a product L * U, + where L is a lower triangular matrix (with unit diagonal terms) and U + is an upper triangular matrix. This routine is used in conjunction + with LU_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of L and U + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure LU_Solve(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations whose matrix has been transformed by + LU_Decomp + ---------------------------------------------------------------------- + Input parameters : A = result from LU_Decomp + B = constant vector + Lbound, + Ubound = as in LU_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + ---------------------------------------------------------------------- } + +function SV_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + S : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Singular value decomposition. Factors the matrix A (n x m, with n >= m) + as a product U * S * V' where U is a (n x m) column-orthogonal matrix, + S a (m x m) diagonal matrix with elements >= 0 (the singular values) + and V a (m x m) orthogonal matrix. This routine is used in conjunction + with SV_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound1 = index of last matrix element in 1st dim. + Ubound2 = index of last matrix element in 2nd dim. + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of U + S = vector of singular values + V = orthogonal matrix + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure SV_SetZero(S : PVector; Lbound, Ubound : Integer; Tol : Float); +{ ---------------------------------------------------------------------- + Sets the singular values to zero if they are lower than a specified + threshold. + ---------------------------------------------------------------------- + Input parameters : S = vector of singular values + Tol = relative tolerance + Threshold value will be Tol * Max(S) + Lbound = index of first vector element + Ubound = index of last vector element + ---------------------------------------------------------------------- + Output parameter : S = modified singular values + ---------------------------------------------------------------------- } + +procedure SV_Solve(U : PMatrix; S : PVector; V : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations by singular value decomposition, after + the matrix has been transformed by SV_Decomp, and the lowest singular + values have been set to zero by SV_SetZero. + ---------------------------------------------------------------------- + Input parameters : U, S, V = vector and matrices from SV_Decomp + B = constant vector + Lbound, + Ubound1, + Ubound2 = as in SV_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + = V * Diag(1/s(i)) * U' * B, for s(i) <> 0 + ---------------------------------------------------------------------- } + +procedure SV_Approx(U : PMatrix; S : PVector; V : PMatrix; + Lbound, Ubound1, Ubound2 : Integer; + A : PMatrix); +{ ---------------------------------------------------------------------- + Approximates a matrix A by the product USV', after the lowest singular + values have been set to zero by SV_SetZero. + ---------------------------------------------------------------------- + Input parameters : U, S, V = vector and matrices from SV_Decomp + Lbound, + Ubound1, + Ubound2 = as in SV_Decomp + ---------------------------------------------------------------------- + Output parameter : A = approximated matrix + ---------------------------------------------------------------------- } + +function QR_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + R : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + QR decomposition. Factors the matrix A (n x m, with n >= m) as a + product Q * R where Q is a (n x m) column-orthogonal matrix, and R + a (m x m) upper triangular matrix. This routine is used in conjunction + with QR_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound1 = index of last matrix element in 1st dim. + Ubound2 = index of last matrix element in 2nd dim. + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of Q + R = upper triangular matrix + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SING + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure QR_Solve(Q, R : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations by the QR decomposition, + after the matrix has been transformed by QR_Decomp. + ---------------------------------------------------------------------- + Input parameters : Q, R = matrices from QR_Decomp + B = constant vector + Lbound, + Ubound1, + Ubound2 = as in QR_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + ---------------------------------------------------------------------- } + +implementation + +const + { Used by LU procedures } + LastDim : Integer = 1; { Dimension of the last system solved } + Index : PIntVector = nil; { Records the row permutations } + + procedure DimVector(var V : PVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_FLT) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Float)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := 0.0; + end; + + procedure DimIntVector(var V : PIntVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_INT) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Integer)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := 0; + end; + + procedure DimBoolVector(var V : PBoolVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_BOOL) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Boolean)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := False; + end; + + procedure DimStrVector(var V : PStrVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_STR) then + begin + showmessage('DIMstr error'); + V := nil; + Exit; + end; + + { Allocate vector } + + GetMem(V, Succ(Ubound) * sizeof(TStrVector) {256}); + + if V = nil then Exit; + { Initialize vector } + + for I := 0 to Ubound do + V^[I] := ''; + //showmessage(inttostr(Ubound)+'b'+inttostr(MAX_STR)); + end; + + procedure DimMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_FLT) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Float); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := 0.0; + end; + + procedure DimIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_INT) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PIntVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Integer); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := 0; + end; + + procedure DimBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_BOOL) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PBoolVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Boolean); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := False; + end; + + procedure DimStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_STR) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PStrVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * 256; + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := ''; + end; + + procedure DelVector(var V : PVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Float)); + V := nil; + end; + end; + + procedure DelIntVector(var V : PIntVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Integer)); + V := nil; + end; + end; + + procedure DelBoolVector(var V : PBoolVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Boolean)); + V := nil; + end; + end; + + procedure DelStrVector(var V : PStrVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V{, Succ(Ubound) * 256}); + V := nil; + end; + end; + + procedure DelMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Float); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PVector)); + A := nil; + end; + end; + + procedure DelIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Integer); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PIntVector)); + A := nil; + end; + end; + + procedure DelBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Boolean); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PBoolVector)); + A := nil; + end; + end; + + procedure DelStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * 256; + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PStrVector)); + A := nil; + end; + end; + + procedure SwapRows(I, K : Integer; A : PMatrix; Lbound, Ubound : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + FSwap(A^[I]^[J], A^[K]^[J]); + end; + + procedure SwapCols(J, K : Integer; A : PMatrix; Lbound, Ubound : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + FSwap(A^[I]^[J], A^[I]^[K]); + end; + + procedure CopyVector(Dest, Source : PVector; Lbound, Ubound : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I] := Source^[I]; + end; + + procedure CopyMatrix(Dest, Source : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer); + var + I, J : Integer; + begin + for I := Lbound1 to Ubound1 do + for J := Lbound2 to Ubound2 do + Dest^[I]^[J] := Source^[I]^[J]; + end; + + procedure CopyRowFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Row : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + Dest^[Row]^[J] := Source^[J]; + end; + + procedure CopyColFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Col : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I]^[Col] := Source^[I]; + end; + + procedure CopyVectorFromRow(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Row : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + Dest^[J] := Source^[Row]^[J]; + end; + + procedure CopyVectorFromCol(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Col : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I] := Source^[I]^[Col]; + end; + + function Min(X : PVector; Lbound, Ubound : Integer) : Float; + var + Xmin : Float; + I : Integer; + begin + Xmin := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] < Xmin then Xmin := X^[I]; + Min := Xmin; + end; + + function Max(X : PVector; Lbound, Ubound : Integer) : Float; + var + Xmax : Float; + I : Integer; + begin + Xmax := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] > Xmax then Xmax := X^[I]; + Max := Xmax; + end; + + function IntMin(X : PIntVector; Lbound, Ubound : Integer) : Integer; + var + I, Xmin : Integer; + begin + Xmin := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] < Xmin then Xmin := X^[I]; + IntMin := Xmin; + end; + + function IntMax(X : PIntVector; Lbound, Ubound : Integer) : Integer; + var + I, Xmax : Integer; + begin + Xmax := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] > Xmax then Xmax := X^[I]; + IntMax := Xmax; + end; + + procedure Transpose(A : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer; + A_t : PMatrix); + var + I, J : Integer; + begin + for I := Lbound1 to Ubound1 do + for J := Lbound2 to Ubound2 do + A_t^[J]^[I] := A^[I]^[J]; + end; + + function GaussJordan(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + A_inv : PMatrix; X : PVector) : Integer; + var + I, J, K : Integer; + Pvt, T : Float; + PRow, PCol : PIntVector; { Store line and column of pivot } + begin + DimIntVector(PRow, Ubound); + DimIntVector(PCol, Ubound); + + { Copy A into A_inv and B into X } + CopyMatrix(A_inv, A, Lbound, Lbound, Ubound, Ubound); + CopyVector(X, B, Lbound, Ubound); + + K := Lbound; + while K <= Ubound do + begin + { Search for largest pivot in submatrix A_inv[K..Ubound, K..Ubound] } + Pvt := A_inv^[K]^[K]; + PRow^[K] := K; + PCol^[K] := K; + for I := K to Ubound do + for J := K to Ubound do + if Abs(A_inv^[I]^[J]) > Abs(Pvt) then + begin + Pvt := A_inv^[I]^[J]; + PRow^[K] := I; + PCol^[K] := J; + end; + + { Pivot too weak ==> quasi-singular matrix } + if Abs(Pvt) < MACHEP then + begin + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + GaussJordan := MAT_SINGUL; + Exit; + end; + + { Exchange current row (K) with pivot row } + if PRow^[K] <> K then + begin + SwapRows(PRow^[K], K, A_inv, Lbound, Ubound); + FSwap(X^[PRow^[K]], X^[K]); + end; + + { Exchange current column (K) with pivot column } + if PCol^[K] <> K then + SwapCols(PCol^[K], K, A_inv, Lbound, Ubound); + + { Transform pivot row } + A_inv^[K]^[K] := 1.0; + for J := Lbound to Ubound do + A_inv^[K]^[J] := A_inv^[K]^[J] / Pvt; + X^[K] := X^[K] / Pvt; + + { Transform other rows } + for I := Lbound to Ubound do + if I <> K then + begin + T := A_inv^[I]^[K]; + A_inv^[I]^[K] := 0.0; + for J := Lbound to Ubound do + A_inv^[I]^[J] := A_inv^[I]^[J] - T * A_inv^[K]^[J]; + X^[I] := X^[I] - T * X^[K]; + end; + Inc(K); + end; + + { Rearrange inverse matrix } + for I := Ubound downto Lbound do + if PCol^[I] <> I then + begin + SwapRows(PCol^[I], I, A_inv, Lbound, Ubound); + FSwap(X^[PCol^[I]], X^[I]); + end; + for J := Ubound downto Lbound do + if PRow^[J] <> J then + SwapCols(PRow^[J], J, A_inv, Lbound, Ubound); + + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + GaussJordan := MAT_OK; + end; + + function InvMat(A : PMatrix; Lbound, Ubound : Integer; + A_inv : PMatrix) : Integer; + var + I, J, K : Integer; + Pvt, T : Float; + PRow, PCol : PIntVector; { Store line and column of pivot } + begin + DimIntVector(PRow, Ubound); + DimIntVector(PCol, Ubound); + + { Copy A into A_inv } + CopyMatrix(A_inv, A, Lbound, Lbound, Ubound, Ubound); + + K := Lbound; + while K <= Ubound do + begin + { Search for largest pivot in submatrix A_inv[K..Ubound, K..Ubound] } + Pvt := A_inv^[K]^[K]; + PRow^[K] := K; + PCol^[K] := K; + for I := K to Ubound do + for J := K to Ubound do + if Abs(A_inv^[I]^[J]) > Abs(Pvt) then + begin + Pvt := A_inv^[I]^[J]; + PRow^[K] := I; + PCol^[K] := J; + end; + + { Pivot too weak ==> quasi-singular matrix } + if Abs(Pvt) < MACHEP then + begin + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + InvMat := MAT_SINGUL; + Exit; + end; + + { Exchange current row (K) with pivot row } + if PRow^[K] <> K then + SwapRows(PRow^[K], K, A_inv, Lbound, Ubound); + + { Exchange current column (K) with pivot column } + if PCol^[K] <> K then + SwapCols(PCol^[K], K, A_inv, Lbound, Ubound); + + { Transform pivot row } + A_inv^[K]^[K] := 1.0; + for J := Lbound to Ubound do + A_inv^[K]^[J] := A_inv^[K]^[J] / Pvt; + + { Transform other rows } + for I := Lbound to Ubound do + if I <> K then + begin + T := A_inv^[I]^[K]; + A_inv^[I]^[K] := 0.0; + for J := Lbound to Ubound do + A_inv^[I]^[J] := A_inv^[I]^[J] - T * A_inv^[K]^[J]; + end; + Inc(K); + end; + + { Rearrange inverse matrix } + for I := Ubound downto Lbound do + if PCol^[I] <> I then + SwapRows(PCol^[I], I, A_inv, Lbound, Ubound); + for J := Ubound downto Lbound do + if PRow^[J] <> J then + SwapCols(PRow^[J], J, A_inv, Lbound, Ubound); + + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + InvMat := MAT_OK; + end; + + function Det(A : PMatrix; Lbound, Ubound : Integer) : Float; + var + D, T : Float; { Partial determinant & multiplier } + I, J, K : Integer; { Loop variables } + ZeroDet : Boolean; { Flags a null determinant } + begin + ZeroDet := False; + D := 1.0; + K := Lbound; + + { Make the matrix upper triangular } + while not(ZeroDet) and (K < Ubound) do + begin + { If diagonal element is zero then switch rows } + if Abs(A^[K]^[K]) < MACHEP then + begin + ZeroDet := True; + I := K; + + { Try to find a row with a non-zero element in this column } + while ZeroDet and (I < Ubound) do + begin + I := Succ(I); + if Abs(A^[I]^[K]) > MACHEP then + begin + { Switch these two rows } + SwapRows(I, K, A, Lbound, Ubound); + ZeroDet := False; + { Switching rows changes the sign of the determinant } + D := - D; + end; + end; + end; + + if not(ZeroDet) then + for I := Succ(K) to Ubound do + if Abs(A^[I]^[K]) > MACHEP then + begin + { Make the K element of this row zero } + T := - A^[I]^[K] / A^[K]^[K]; + for J := 1 to Ubound do + A^[I]^[J] := A^[I]^[J] + T * A^[K]^[J]; + end; + + D := D * A^[K]^[K]; { Multiply the diagonal term into D } + Inc(K); + end; + + if ZeroDet then + Det := 0.0 + else + Det := D * A^[Ubound]^[Ubound]; + end; + + function Cholesky(A : PMatrix; Lbound, Ubound : Integer; + L : PMatrix) : Integer; + var + I, J, K : Integer; + Sum : Float; + begin + for K := Lbound to Ubound do + begin + Sum := A^[K]^[K]; + for J := Lbound to K - 1 do + Sum := Sum - Sqr(L^[K]^[J]); + + if Sum <= 0.0 then + begin + Cholesky := MAT_NOT_PD; + Exit; + end; + + L^[K]^[K] := Sqrt(Sum); + for I := K + 1 to Ubound do + begin + Sum := A^[I]^[K]; + for J := Lbound to K - 1 do + Sum := Sum - L^[I]^[J] * L^[K]^[J]; + L^[I]^[K] := Sum / L^[K]^[K]; + end; + end; + Cholesky := MAT_OK; + end; + + function LU_Decomp(A : PMatrix; Lbound, Ubound : Integer) : Integer; + const + TINY = 1.0E-20; + var + I, Imax, J, K : Integer; + Pvt, T, Sum : Float; + V : PVector; + begin + DimVector(V, Ubound); + { Reallocate Index } + if Index <> nil then + DelIntVector(Index, LastDim); + DimIntVector(Index, Ubound); + LastDim := Ubound; + + for I := Lbound to Ubound do + begin + Pvt := 0.0; + for J := Lbound to Ubound do + if Abs(A^[I]^[J]) > Pvt then + Pvt := Abs(A^[I]^[J]); + if Pvt < MACHEP then + begin + DelVector(V, Ubound); + LU_Decomp := MAT_SINGUL; + Exit; + end; + V^[I] := 1.0 / Pvt; + end; + for J := Lbound to Ubound do + begin + for I := Lbound to Pred(J) do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(I) do + Sum := Sum - A^[I]^[K] * A^[K]^[J]; + A^[I]^[J] := Sum; + end; + Pvt := 0.0; + for I := J to Ubound do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(J) do + Sum := Sum - A^[I]^[K] * A^[K]^[J]; + A^[I]^[J] := Sum; + T := V^[I] * Abs(Sum); + if T > Pvt then + begin + Pvt := T; + Imax := I; + end; + end; + if J <> Imax then + begin + SwapRows(Imax, J, A, Lbound, Ubound); + V^[Imax] := V^[J]; + end; + Index^[J] := Imax; + if A^[J]^[J] = 0.0 then + A^[J]^[J] := TINY; + if J <> Ubound then + begin + T := 1.0 / A^[J]^[J]; + for I := Succ(J) to Ubound do + A^[I]^[J] := A^[I]^[J] * T; + end; + end; + DelVector(V, Ubound); + LU_Decomp := MAT_OK; + end; + + procedure LU_Solve(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + X : PVector); + var + I, Ip, J, K : Integer; + Sum : Float; + begin + K := Pred(Lbound); + CopyVector(X, B, Lbound, Ubound); + for I := Lbound to Ubound do + begin + Ip := Index^[I]; + Sum := X^[Ip]; + X^[Ip] := X^[I]; + if K >= Lbound then + for J := K to Pred(I) do + Sum := Sum - A^[I]^[J] * X^[J] + else if Sum <> 0.0 then + K := I; + X^[I] := Sum; + end; + for I := Ubound downto Lbound do + begin + Sum := X^[I]; + if I < Ubound then + for J := Succ(I) to Ubound do + Sum := Sum - A^[I]^[J] * X^[J]; + X^[I] := Sum / A^[I]^[I]; + end; + end; + + function SV_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + S : PVector; V : PMatrix) : Integer; + label + 1, 2, 3; + var + I, Its, J, JJ, K, L, N : Integer; + Anorm, C, F, G, H, Sum, Scale, T, X, Y, Z : Float; + R : PVector; + begin + G := 0.0; + Scale := 0.0; + Anorm := 0.0; + DimVector(R, Ubound2); + for I := Lbound to Ubound2 do + begin + L := I + 1; + R^[I] := Scale * G; + G := 0.0; + Sum := 0.0; + Scale := 0.0; + if I <= Ubound1 then + begin + for K := I to Ubound1 do + Scale := Scale + Abs(A^[K]^[I]); + if Scale <> 0.0 then + begin + for K := I to Ubound1 do + begin + A^[K]^[I] := A^[K]^[I] / Scale; + Sum := Sum + A^[K]^[I] * A^[K]^[I]; + end; + F := A^[I]^[I]; + G := - Sgn(F) * Sqrt(Sum); + H := F * G - Sum; + A^[I]^[I] := F - G; + if I <> Ubound2 then + begin + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := I to Ubound1 do + Sum := Sum + A^[K]^[I] * A^[K]^[J]; + F := Sum / H; + for K := I to Ubound1 do + A^[K]^[J] := A^[K]^[J] + F * A^[K]^[I]; + end; + end; + for K := I to Ubound1 do + A^[K]^[I] := Scale * A^[K]^[I]; + end; + end; + S^[I] := Scale * G; + G := 0.0; + Sum := 0.0; + Scale := 0.0; + if (I <= Ubound1) and (I <> Ubound2) then + begin + for K := L to Ubound2 do + Scale := Scale + Abs(A^[I]^[K]); + if Scale <> 0.0 then + begin + for K := L to Ubound2 do + begin + A^[I]^[K] := A^[I]^[K] / Scale; + Sum := Sum + A^[I]^[K] * A^[I]^[K]; + end; + F := A^[I]^[L]; + G := - Sgn(F) * Sqrt(Sum); + H := F * G - Sum; + A^[I]^[L] := F - G; + for K := L to Ubound2 do + R^[K] := A^[I]^[K] / H; + if I <> Ubound1 then + for J := L to Ubound1 do + begin + Sum := 0.0; + for K := L to Ubound2 do + Sum := Sum + A^[J]^[K] * A^[I]^[K]; + for K := L to Ubound2 do + A^[J]^[K] := A^[J]^[K] + Sum * R^[K]; + end; + for K := L to Ubound2 do + A^[I]^[K] := Scale * A^[I]^[K]; + end; + end; + Anorm := FMax(Anorm, Abs(S^[I]) + Abs(R^[I])); + end; + for I := Ubound2 downto Lbound do + begin + if I < Ubound2 then + begin + if G <> 0.0 then + begin + for J := L to Ubound2 do + V^[J]^[I] := (A^[I]^[J] / A^[I]^[L]) / G; + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := L to Ubound2 do + Sum := Sum + A^[I]^[K] * V^[K]^[J]; + for K := L to Ubound2 do + V^[K]^[J] := V^[K]^[J] + Sum * V^[K]^[I]; + end; + end; + for J := L to Ubound2 do + begin + V^[I]^[J] := 0.0; + V^[J]^[I] := 0.0; + end; + end; + V^[I]^[I] := 1.0; + G := R^[I]; + L := I; + end; + for I := Ubound2 downto Lbound do + begin + L := I + 1; + G := S^[I]; + if I < Ubound2 then + for J := L to Ubound2 do + A^[I]^[J] := 0.0; + if G <> 0.0 then + begin + G := 1.0 / G; + if I <> Ubound2 then + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := L to Ubound1 do + Sum := Sum + A^[K]^[I] * A^[K]^[J]; + F := (Sum / A^[I]^[I]) * G; + for K := I to Ubound1 do + A^[K]^[J] := A^[K]^[J] + F * A^[K]^[I]; + end; + for J := I to Ubound1 do + A^[J]^[I] := A^[J]^[I] * G; + end + else + for J := I to Ubound1 do + A^[J]^[I] := 0.0; + A^[I]^[I] := A^[I]^[I] + 1.0; + end; + for K := Ubound2 downto Lbound do + begin + for Its := 1 to 30 do + begin + for L := K downto Lbound do + begin + N := L - 1; + if (Abs(R^[L]) + Anorm) = Anorm then goto 2; + if (Abs(S^[N]) + Anorm) = Anorm then goto 1; + end; +1: T := 1.0; + for I := L to K do + begin + F := T * R^[I]; + if (Abs(F) + Anorm) <> Anorm then + begin + G := S^[I]; + H := Pythag(F, G); + S^[I] := H; + H := 1.0 / H; + C := G * H; + T := - (F * H); + for J := Lbound to Ubound1 do + begin + Y := A^[J]^[N]; + Z := A^[J]^[I]; + A^[J]^[N] := (Y * C) + (Z * T); + A^[J]^[I] := - (Y * T) + (Z * C); + end; + end; + end; +2: Z := S^[K]; + if L = K then + begin + if Z < 0.0 then + begin + S^[K] := - Z; + for J := Lbound to Ubound2 do + V^[J]^[K] := - V^[J]^[K]; + end; + goto 3 + end; + if Its = 30 then + begin + DelVector(R, Ubound2); + SV_Decomp := MAT_NON_CONV; + Exit; + end; + X := S^[L]; + N := K - 1; + Y := S^[N]; + G := R^[N]; + H := R^[K]; + F := ((Y - Z) * (Y + Z) + (G - H) * (G + H)) / (2.0 * H * Y); + G := Pythag(F, 1.0); + F := ((X - Z) * (X + Z) + H * ((Y / (F + Sgn(F) * Abs(G))) - H)) / X; + C := 1.0; + T := 1.0; + for J := L to N do + begin + I := J + 1; + G := R^[I]; + Y := S^[I]; + H := T * G; + G := C * G; + Z := Pythag(F, H); + R^[J] := Z; + C := F / Z; + T := H / Z; + F := (X * C) + (G * T); + G := - (X * T) + (G * C); + H := Y * T; + Y := Y * C; + for JJ := Lbound to Ubound2 do + begin + X := V^[JJ]^[J]; + Z := V^[JJ]^[I]; + V^[JJ]^[J] := (X * C) + (Z * T); + V^[JJ]^[I] := - (X * T) + (Z * C); + end; + Z := Pythag(F, H); + S^[J] := Z; + if Z <> 0.0 then + begin + Z := 1.0 / Z; + C := F * Z; + T := H * Z; + end; + F := (C * G) + (T * Y); + X := - (T * G) + (C * Y); + for JJ := Lbound to Ubound1 do + begin + Y := A^[JJ]^[J]; + Z := A^[JJ]^[I]; + A^[JJ]^[J] := (Y * C) + (Z * T); + A^[JJ]^[I] := - (Y * T) + (Z * C); + end + end; + R^[L] := 0.0; + R^[K] := F; + S^[K] := X; + end; +3: + end; + DelVector(R, Ubound2); + SV_Decomp := MAT_OK; + end; + + procedure SV_SetZero(S : PVector; Lbound, Ubound : Integer; Tol : Float); + var + Threshold : Float; + I : Integer; + begin + Threshold := Tol * Max(S, Lbound, Ubound); + for I := Lbound to Ubound do + if S^[I] < Threshold then S^[I] := 0.0; + end; + + procedure SV_Solve(U : PMatrix; S : PVector; V : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); + var + I, J, JJ : Integer; + Sum : Float; + Tmp : PVector; + begin + DimVector(Tmp, Ubound2); + for J := Lbound to Ubound2 do + begin + Sum := 0.0; + if S^[J] > 0.0 then + begin + for I := Lbound to Ubound1 do + Sum := Sum + U^[I]^[J] * B^[I]; + Sum := Sum / S^[J]; + end; + Tmp^[J] := Sum; + end; + for J := Lbound to Ubound2 do + begin + Sum := 0.0; + for JJ := Lbound to Ubound2 do + Sum := Sum + V^[J]^[JJ] * Tmp^[JJ]; + X^[J] := Sum; + end; + DelVector(Tmp, Ubound2); + end; + + procedure SV_Approx(U : PMatrix; S : PVector; V : PMatrix; + Lbound, Ubound1, Ubound2 : Integer; A : PMatrix); + var + I, J, K : Integer; + begin + for I := Lbound to Ubound1 do + for J := Lbound to Ubound2 do + begin + A^[I]^[J] := 0.0; + for K := Lbound to Ubound2 do + if S^[K] > 0.0 then + A^[I]^[J] := A^[I]^[J] + U^[I]^[K] * V^[J]^[K]; + end; + end; + + function QR_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + R : PMatrix) : Integer; + var + I, J, K : Integer; + Sum : Float; + begin + for K := Lbound to Ubound2 do + begin + { Compute the "k"th diagonal entry in R } + Sum := 0.0; + for I := Lbound to Ubound1 do + Sum := Sum + Sqr(A^[I]^[K]); + + if Sum = 0.0 then + begin + QR_Decomp := MAT_SINGUL; + Exit; + end; + + R^[K]^[K] := Sqrt(Sum); + + { Divide the entries in the "k"th column of A by the computed "k"th } + { diagonal element of R. this begins the process of overwriting A } + { with Q . . . } + for I := Lbound to Ubound1 do + A^[I]^[K] := A^[I]^[K] / R^[K]^[K]; + + for J := (K + 1) to Ubound2 do + begin + { Complete the remainder of the row entries in R } + Sum := 0.0; + for I := Lbound to Ubound1 do + Sum := Sum + A^[I]^[K] * A^[I]^[J]; + R^[K]^[J] := Sum; + + { Update the column entries of the Q/A matrix } + for I := Lbound to Ubound1 do + A^[I]^[J] := A^[I]^[J] - A^[I]^[K] * R^[K]^[J]; + end; + end; + + QR_Decomp := MAT_OK; + end; + + procedure QR_Solve(Q, R : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); + var + I, J : Integer; + Sum : Float; + begin + { Form Q'B and store the result in X } + for J := Lbound to Ubound2 do + begin + X^[J] := 0.0; + for I := Lbound to Ubound1 do + X^[J] := X^[J] + Q^[I]^[J] * B^[I]; + end; + + { Update X with the solution vector } + X^[Ubound2] := X^[Ubound2] / R^[Ubound2]^[Ubound2]; + for I := (Ubound2 - 1) downto Lbound do + begin + Sum := 0.0; + for J := (I + 1) to Ubound2 do + Sum := Sum + R^[I]^[J] * X^[J]; + X^[I] := (X^[I] - Sum) / R^[I]^[I]; + end; + end; + +end. diff --git a/niftiview7/tpmath/Regress.pas b/niftiview7/tpmath/Regress.pas new file mode 100755 index 0000000..3ed2bd3 --- /dev/null +++ b/niftiview7/tpmath/Regress.pas @@ -0,0 +1,1323 @@ +{ ********************************************************************** + * Unit REGRESS.PAS * + * Version 2.2 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Regression routines + ********************************************************************** } + +unit Regress; + +interface + +uses + FMath, Matrices, Eigen, Optim, SimOpt, Stat,dialogs; + +{ ********************************************************************** + Type definitions + ********************************************************************** } + +{ Algorithm for linear regression } +type + TRegAlgo = ( + GAUSS_JORDAN, { Gauss-Jordan solution of normal equations } + SVD); { Singular value decomposition } + +{ Optimization algorithm for nonlinear regression } +type + TOptAlgo = ( + NL_MARQ, { Marquardt algorithm } + NL_SIMP, { Simplex algorithm } + NL_BFGS, { BFGS algorithm } + NL_SA); { Simulated annealing } + +{ Regression modes } +type + TRegMode = (UNWEIGHTED, WEIGHTED); + +{ Regression function } +type + TRegFunc = function(X : Float; B : PVector) : Float; + +{ Procedure to compute the derivatives of the regression function + with respect to the regression parameters } +type + TDerivProc = procedure(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + +{ Test of regression } +type + TRegTest = record + Vr, { Residual variance } + R2, { Coefficient of determination } + R2a, { Adjusted coeff. of determination } + F, { Variance ratio (explained/residual) } + Prob : Float; { Probability of F } + end; + +{ ********************************************************************** + Procedures to modify the regression settings + ********************************************************************** } + +procedure SetRegAlgo(Algo : TRegAlgo); +{ ---------------------------------------------------------------------- + Sets the linear regression algorithm according to Algo, which must be + GAUSS_JORDAN or SVD. The default algorithm is SVD. + ---------------------------------------------------------------------- } + +procedure SetOptAlgo(Algo : TOptAlgo); +{ ---------------------------------------------------------------------- + Sets the optimization algorithm according to Algo, which must be + NL_MARQ, NL_SIMP, NL_BFGS or NL_SA. The default algorithm is NL_MARQ. + ---------------------------------------------------------------------- } + +procedure SetFirstPoint(Index : Integer); +{ ---------------------------------------------------------------------- + Sets the index of the first data point (usually 0 or 1). The default + value is 1. + ---------------------------------------------------------------------- } + +function GetRegAlgo : TRegAlgo; +{ ---------------------------------------------------------------------- + Returns the linear regression algorithm + ---------------------------------------------------------------------- } + +function GetOptAlgo : TOptAlgo; +{ ---------------------------------------------------------------------- + Returns the optimization algorithm + ---------------------------------------------------------------------- } + +function GetFirstPoint : Integer; +{ ---------------------------------------------------------------------- + Returns the index of the first data point + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Unweighted regression routines + ********************************************************************** + These routines fit equations to data by minimizing the sum of squared + residuals : + SS = Sum [y(k) - ycalc(k)]^2 + + where y(k) and ycalc(k) are respectively the observed and calculated + value of the dependent variable for observation k. ycalc(k) is a + function of the regression parameters b(0), b(1) ... + + The following regression types are implemented : + + * Simple linear regression : + + y(k) = b(0) + b(1) * x(k) + + * Multiple linear regression : + + y(k) = b(0) + b(1) * x(1,k) + b(2) * x(2,k) + ... + b(Nvar) * x(Nvar,k) + + * Polynomial regression : + + y(k) = b(0) + b(1) * x(k) + b(2) * x(k)^2 + ... + b(Deg) * x(k)^Deg + + * Nonlinear regression : + + y(k) = f[x(k), b(0), b(1), ... ] + + where f is a user-specified function. + + The following parameters are common to all routines : + + Input : X = Vector or matrix of independent variables + Y = Vector of dependent variable + N = Index of the last observation + Output : B = Regression parameters + V = Inverse matrix of normal equations + ********************************************************************** } + +function LinFit(X, Y : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Simple linear regression + ---------------------------------------------------------------------- } + +function MulFit(X : PMatrix; Y : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Multiple linear regression + ---------------------------------------------------------------------- + Additional input parameters : + Nvar = Index of the last independent variable + ConsTerm = Flags the presence of a constant term b(0) + ---------------------------------------------------------------------- } + +function PolFit(X, Y : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Polynomial regression + ---------------------------------------------------------------------- + Additional input parameter : + Deg = Degree of polynomial + ---------------------------------------------------------------------- } + +function NLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Nonlinear regression + ---------------------------------------------------------------------- + Additional input parameters : + RegFunc = Regression function + DerivProc = Procedure to compute the derivatives of RegFunc + Lbound, Ubound = Indices of first and last function parameters + MaxIter = Maximum number of iterations + Tol = Required parameter precision + B = Initial parameter values + B_min, B_max = Lower and upper parameter bounds + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Weighted regression routines + ********************************************************************** + These routines fit equations to data by minimizing the sum of weighted + squared residuals : + + SWS = Sum w(k)*[y(k) - ycalc(k)]^2 + + where the "weight" w(k) is inversely proportional to the variance v(k) + of the observation y(k). v(k) is usually computed as : + + v(k) = Vr * g[y(k)] = Vr / w(k) + + where Vr is the residual variance and g is a user-specified function + (e.g. g[y(k)] = y(k)^2 for a constant coefficient of variation). + + Function syntax and results are the same than for unweighted regression + except that the vector of weights (W) is passed as an additional input + parameter. + ********************************************************************** } + +function WLinFit(X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + +function WMulFit(X : PMatrix; Y, W : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + +function WPolFit(X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + +function WNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y, W : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + +{ ********************************************************************** + Procedure to compute the derivatives of the regression function by + numerical differentiation. + ********************************************************************** } + +procedure NumDeriv(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); +{ ---------------------------------------------------------------------- + Input parameters : RegFunc = Regression function + X, Y = Coordinates of point + B = Regression parameters + + Output parameter : D = Derivatives (D^[I] contains the + derivative w.r.t. parameter B^[I]) + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Routines to test the quality of the regression + ********************************************************************** + These routines compute the variance-covariance matrix of the fitted + parameters and the different statistics used to test the quality of + the fit. + + Input parameters : Y = Vector of dependent variable + Ycalc = Computed Y values + W = Vector of weights (if any) + N = Index of the last observation + Lbound, + Ubound = Indices of first & last fitted parameters + V = Inverse normal equations matrix + + Output parameters : V = Variance-covariance matrix + Test = Test statistics (Vr, R2, R2a, F, Prob) + ********************************************************************** } + +procedure RegTest(Y, Ycalc : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); +{ ---------------------------------------------------------------------- + Test of unweighted regression + ---------------------------------------------------------------------- } + +procedure WRegTest(Y, Ycalc, W : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); +{ ---------------------------------------------------------------------- + Test of weighted regression + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Test of regression parameters + ********************************************************************** } + +procedure ParamTest(B : PVector; V : PMatrix; N, Lbound, Ubound : Integer; + S, T, Prob : PVector); +{ ---------------------------------------------------------------------- + This routine tests the significance of the parameters. It must be + called AFTER RegTest or WRegTest since it uses the variance-covariance + matrix. + ---------------------------------------------------------------------- + Input parameters : B = Regression parameters + V = Variance-covariance matrix + N = Index of the last observation + Lbound, + Ubound = Indices of first & last fitted parameters + ---------------------------------------------------------------------- + Output parameters : S = Standard deviations of parameters + T = Student's t + Prob = Probabilities + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Correlation and principal component analysis + + Common parameters: + + X = matrix of variables (X^[I] contains the I-th variable) + N = Index of the last observation + Lbound, Ubound = Indices of first & last variables + M = Mean vector (M^[I] = mean of X^[I]) + S = Vector of standard deviations + V = Variance-covariance matrix + R = Correlation matrix + ********************************************************************** } + +procedure VecMean(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector); +{ ---------------------------------------------------------------------- + Computes the mean vector (M) from matrix X + + Input : X, Lbound, Ubound + Output : M + ---------------------------------------------------------------------- } + +procedure VecSD(X : PMatrix; N, Lbound, Ubound : Integer; M, S : PVector); +{ ---------------------------------------------------------------------- + Computes the vector of standard deviations (S) from matrix X + + Input : X, Lbound, Ubound, M + Output : S + ---------------------------------------------------------------------- } + +procedure MatVarCov(X : PMatrix; N, Lbound, Ubound : Integer; + M : PVector; V : PMatrix); +{ ---------------------------------------------------------------------- + Computes the variance-covariance matrix (V) from matrix X + + Input : X, Lbound, Ubound, M + Output : V + ---------------------------------------------------------------------- } + +procedure MatCorrel(V : PMatrix; Lbound, Ubound : Integer; R : PMatrix); +{ ---------------------------------------------------------------------- + Computes the correlation matrix (R) from the variance-covariance + matrix (V) + + Input : V, Lbound, Ubound + Output : R + ---------------------------------------------------------------------- } + +function PCA(R : PMatrix; Lbound, Ubound : Integer; + Lambda : PVector; C, Rc : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Performs a principal component analysis of the correlation matrix R + ---------------------------------------------------------------------- + Input : R, Lbound, Ubound + Output : Lambda = Eigenvalues of the correlation matrix + (in descending order) + C = Eigenvectors of the correlation matrix + (C^[I] is the I-th eigenvector) + Rc = Correlations between principal factors and variables + (R^[I]^[J] is the correlation coefficient between + factor I and variable J) + ---------------------------------------------------------------------- + Possible results : MAT_OK : No error + MAT_NON_CONV : Non-convergence of eigenvalue + determination + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix R + ---------------------------------------------------------------------- } + +procedure ScaleVar(X : PMatrix; N, Lbound, Ubound : Integer; + M, S : PVector; Z : PMatrix); +{ ---------------------------------------------------------------------- + Scales a set of variables by subtracting means and dividing by SD's + ---------------------------------------------------------------------- + Input : X, N, Lbound, Ubound, M, S + Output : Z = matrix of scaled variables (Z^[I] contains the I-th var.) + ---------------------------------------------------------------------- } + +procedure PrinFac(Z : PMatrix; N, Lbound, Ubound : Integer; C, F : PMatrix); +{ ---------------------------------------------------------------------- + Computes principal factors + ---------------------------------------------------------------------- + Input : Z, N, Lbound, Ubound + C = matrix of eigenvectors from PCA + Output : F = matrix of principal factors (F^[I] contains the I-th factor) + ---------------------------------------------------------------------- } + +implementation + +{ Constants for eigenvalue determination in PCA } +const + PCA_MAXITER = 100; { Max number of iterations } + PCA_TOL = 1.0E-6; { Required precision } + MAX_FUNC = 1.0E+30; { Max. value for objective function + (used to prevent overflow) } +{ Default settings } +const + RegAlgo : TRegAlgo = SVD; { Linear regression algorithm } + OptAlgo : TOptAlgo = NL_MARQ; { Optimization algorithms } + FirstPoint : Integer = 1; { Index of first data point } + +{ Global variables used by the nonlinear regression routines } +const + NN : Integer = 1; { Number of observations } + XX : PVector = nil; { X coordinates } + YY : PVector = nil; { Y coordinates } + WW : PVector = nil; { Weights } + YYcalc : PVector = nil; { Estimated Y values } + FirstParam : Integer = 0; { Index of first fitted parameter } + LastParam : Integer = 1; { Index of last fitted parameter } + ParamMin : PVector = nil; { Lower bounds on parameters } + ParamMax : PVector = nil; { Higher bounds on parameters } + +var + RegFunc1 : TRegFunc; { Regression function } + DerivProc1 : TDerivProc; { Derivation procedure } + + function TolSVD(N : Integer) : Float; + { This function sets the relative threshold below which a singular value + is considered zero. N is the number of observations. } + begin + TolSVD := N * MACHEP; + end; + + procedure SetRegAlgo(Algo : TRegAlgo); + begin + RegAlgo := Algo; + end; + + procedure SetOptAlgo(Algo : TOptAlgo); + begin + OptAlgo := Algo; + end; + + procedure SetFirstPoint(Index : Integer); + begin + if Index >= 0 then + FirstPoint := Index; + end; + + function GetRegAlgo : TRegAlgo; + begin + GetRegAlgo := RegAlgo; + end; + + function GetOptAlgo : TOptAlgo; + begin + GetOptAlgo := OptAlgo; + end; + + function GetFirstPoint : Integer; + begin + GetFirstPoint := FirstPoint; + end; + + function GenLinFit(Mode : TRegMode; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General linear regression routine + ---------------------------------------------------------------------- } + var + WX, S, SX, SY, SX2, SXY, D : Float; + K : Integer; + begin + S := 0.0; + SX := 0.0; + SY := 0.0; + SX2 := 0.0; + SXY := 0.0; + if Mode = UNWEIGHTED then + begin + S := N - FirstPoint + 1; + for K := FirstPoint to N do + begin + SX := SX + X^[K]; + SY := SY + Y^[K]; + SX2 := SX2 + Sqr(X^[K]); + SXY := SXY + X^[K] * Y^[K]; + end; + end + else + begin + for K := FirstPoint to N do + begin + WX := W^[K] * X^[K]; + S := S + W^[K]; + SX := SX + WX; + SY := SY + W^[K] * Y^[K]; + SX2 := SX2 + WX * X^[K]; + SXY := SXY + WX * Y^[K]; + end; + end; + D := S * SX2 - Sqr(SX); + if D <= 0.0 then + GenLinFit := MAT_SINGUL + else + begin + V^[0]^[0] := SX2 / D; + V^[0]^[1] := - SX / D; + V^[1]^[0] := V^[0]^[1]; + V^[1]^[1] := S / D; + B^[0] := V^[0]^[0] * SY + V^[0]^[1] * SXY; + B^[1] := V^[1]^[0] * SY + V^[1]^[1] * SXY; + GenLinFit := MAT_OK; + end; + end; + + function LinFit(X, Y : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + LinFit := GenLinFit(UNWEIGHTED, X, Y, W, N, B, V); + end; + + function WLinFit(X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + begin + WLinFit := GenLinFit(WEIGHTED, X, Y, W, N, B, V); + end; + + function Gauss_GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine (Gauss-Jordan algorithm) + ---------------------------------------------------------------------- } + var + A : PMatrix; { Matrix of normal equations } + G : PVector; { Constant vector } + I, J, K : Integer; { Loop variables } + WX : Float; + begin + DimMatrix(A, Nvar, Nvar); + DimVector(G, Nvar); + + { If constant term, set line 0 and column 0 of matrix A, + and element 0 of vecteur G } + if ConsTerm then + begin + if Mode = UNWEIGHTED then + begin + A^[0]^[0] := Int(N - FirstPoint + 1); + for K := FirstPoint to N do + begin + for J := 1 to Nvar do + A^[0]^[J] := A^[0]^[J] + X^[J]^[K]; + G^[0] := G^[0] + Y^[K]; + end; + end + else + begin + for K := FirstPoint to N do + begin + A^[0]^[0] := A^[0]^[0] + W^[K]; + for J := 1 to Nvar do + A^[0]^[J] := A^[0]^[J] + W^[K] * X^[J]^[K]; + G^[0] := G^[0] + W^[K] * Y^[K]; + end; + end; + for J := 1 to Nvar do + A^[J]^[0] := A^[0]^[J]; + end; + + { Set other elements of A and G } + if Mode = UNWEIGHTED then + for K := FirstPoint to N do + for I := 1 to Nvar do + begin + for J := I to Nvar do + A^[I]^[J] := A^[I]^[J] + X^[I]^[K] * X^[J]^[K]; + G^[I] := G^[I] + X^[I]^[K] * Y^[K]; + end + else + for K := FirstPoint to N do + for I := 1 to Nvar do + begin + WX := W^[K] * X^[I]^[K]; + for J := I to Nvar do + A^[I]^[J] := A^[I]^[J] + WX * X^[J]^[K]; + G^[I] := G^[I] + WX * Y^[K]; + end; + + { Fill in symmetric matrix } + for I := 2 to Nvar do + for J := 1 to Pred(I) do + A^[I]^[J] := A^[J]^[I]; + + { Solve normal equations } + if ConsTerm then + Gauss_GenMulFit := GaussJordan(A, G, 0, Nvar, V, B) + else + Gauss_GenMulFit := GaussJordan(A, G, 1, Nvar, V, B); + + DelMatrix(A, Nvar, Nvar); + DelVector(G, Nvar); + end; + + function SVD_GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine (SVD algorithm) + ---------------------------------------------------------------------- } + var + U : PMatrix; { Matrix of independent variables for SVD } + Z : PVector; { Vector of dependent variables for SVD } + S : PVector; { Singular values } + S2inv : PVector; { Inverses of squared singular values } + V1 : PMatrix; { Orthogonal matrix from SVD } + Lbound : Integer; { Lower bound of U matrix in both dims. } + Ubound : Integer; { Upper bound of U matrix in 1st dim. } + I, J, K : Integer; { Loop variables } + Sigma : Float; { Square root of weight } + Sum : Float; { Element of variance-covariance matrix } + ErrCode : Integer; { Error code } + begin + if ConsTerm then + begin + Lbound := 0; + Ubound := N - FirstPoint; + end + else + begin + Lbound := 1; + Ubound := N - FirstPoint + 1; + end; + + { Dimension arrays } + DimMatrix(U, Ubound, Nvar); + DimVector(Z, Ubound); + DimVector(S, Nvar); + DimVector(S2inv, Nvar); + DimMatrix(V1, Nvar, Nvar); + + { ---------------------------------------------------------- + Prepare arrays for SVD : + If constant term, use U[0..(N - FirstPoint), 0..Nvar] + and Z[0..(N - FirstPoint)] + Else use U[1..(N - FirstPoint + 1), 1..Nvar] + and Z[1..(N - FirstPoint + 1)] + ---------------------------------------------------------- } + if Mode = UNWEIGHTED then + for I := Lbound to Ubound do + begin + K := I - Lbound + FirstPoint; + Z^[I] := Y^[K]; + if ConsTerm then + U^[I]^[0] := 1.0; + for J := 1 to Nvar do + U^[I]^[J] := X^[J]^[K]; + end + else + for I := Lbound to Ubound do + begin + K := I - Lbound + FirstPoint; + Sigma := Sqrt(W^[K]); + Z^[I] := Y^[K] * Sigma; + if ConsTerm then + U^[I]^[0] := Sigma; + for J := 1 to Nvar do + U^[I]^[J] := X^[J]^[K] * Sigma; + end; + + { Perform singular value decomposition } + ErrCode := SV_Decomp(U, Lbound, Ubound, Nvar, S, V1); + + if ErrCode = MAT_OK then + begin + { Set the lowest singular values to zero } + SV_SetZero(S, Lbound, Nvar, TolSVD(N - FirstPoint + 1)); + + { Solve the system } + SV_Solve(U, S, V1, Z, Lbound, Ubound, Nvar, B); + + { Compute variance-covariance matrix } + for I := Lbound to Nvar do + if S^[I] > 0.0 then + S2inv^[I] := 1.0 / Sqr(S^[I]) + else + S2inv^[I] := 0.0; + for I := Lbound to Nvar do + for J := Lbound to I do + begin + Sum := 0.0; + for K := Lbound to Nvar do + Sum := Sum + V1^[I]^[K] * V1^[J]^[K] * S2inv^[K]; + V^[I]^[J] := Sum; + V^[J]^[I] := Sum; + end; + end; + + SVD_GenMulFit := ErrCode; + + DelMatrix(U, Ubound, Nvar); + DelVector(Z, Ubound); + DelVector(S, Nvar); + DelVector(S2inv, Nvar); + DelMatrix(V1, Nvar, Nvar); + end; + + function GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine + ---------------------------------------------------------------------- } + begin + case RegAlgo of + GAUSS_JORDAN : GenMulFit := Gauss_GenMulFit(Mode, X, Y, W, N, Nvar, + ConsTerm, B, V); + SVD : GenMulFit := SVD_GenMulFit(Mode, X, Y, W, N, Nvar, + ConsTerm, B, V); + end; + end; + + function MulFit(X : PMatrix; Y : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + MulFit := GenMulFit(UNWEIGHTED, X, Y, W, N, Nvar, ConsTerm, B, V); + end; + + function WMulFit(X : PMatrix; Y, W : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + begin + WMulFit := GenMulFit(WEIGHTED, X, Y, W, N, Nvar, ConsTerm, B, V); + end; + + procedure PowMat(X : PVector; N, Deg : Integer; U : PMatrix); +{ ---------------------------------------------------------------------- + Computes matrix of increasing powers of X for polynomial regression + ---------------------------------------------------------------------- } + var + I, K : Integer; + begin + for K := FirstPoint to N do + begin + U^[1]^[K] := X^[K]; + for I := 2 to Deg do + U^[I]^[K] := U^[I - 1]^[K] * X^[K]; + end; + end; + + function GenPolFit(Mode : TRegMode; X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General polynomial regression routine + ---------------------------------------------------------------------- } + var + U : PMatrix; + begin + DimMatrix(U, Deg, N); + PowMat(X, N, Deg, U); + GenPolFit := GenMulFit(Mode, U, Y, W, N, Deg, True, B, V); + DelMatrix(U, Deg, N); + end; + + function PolFit(X, Y : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + PolFit := GenPolFit(UNWEIGHTED, X, Y, W, N, Deg, B, V); + end; + + function WPolFit(X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + begin + WPolFit := GenPolFit(WEIGHTED, X, Y, W, N, Deg, B, V); + end; + + procedure SetGlobalVar(RegFunc : TRegFunc; DerivProc : TDerivProc; + Mode : TRegMode; X, Y, W : PVector; + N, Lbound, Ubound : Integer; + B_min, B_max : PVector); + { Sets the global variables used by the nonlinear regression routines } + begin + DelVector(XX, NN); + DelVector(YY, NN); + DelVector(YYcalc, NN); + + DimVector(XX, N); + DimVector(YY, N); + DimVector(YYcalc, N); + + CopyVector(XX, X, FirstPoint, N); + CopyVector(YY, Y, FirstPoint, N); + + if Mode = WEIGHTED then + begin + DelVector(WW, NN); + DimVector(WW, N); + CopyVector(WW, W, FirstPoint, N); + end; + + NN := N; + + DelVector(ParamMin, LastParam); + DelVector(ParamMax, LastParam); + + DimVector(ParamMin, Ubound); + DimVector(ParamMax, Ubound); + + CopyVector(ParamMin, B_min, Lbound, Ubound); + CopyVector(ParamMax, B_max, Lbound, Ubound); + + FirstParam := Lbound; + LastParam := Ubound; + + RegFunc1 := RegFunc; + DerivProc1 := DerivProc; + end; + + {$F+} + + procedure NumDeriv(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + var + I : Integer; + Eps, Temp, Y1 : Float; + begin + Eps := Sqrt(MACHEP); + for I := FirstParam to LastParam do + begin + Temp := B^[I]; { Save parameter } + B^[I] := B^[I] + Eps * Abs(B^[I]); { Modified parameter } + Y1 := RegFunc(X, B); + D^[I] := (Y1 - Y) / (B^[I] - Temp); { Derivative } + B^[I] := Temp; { Restore parameter } + end; + end; + + function OutOfBounds(B, B_min, B_max : PVector) : Boolean; + { Check if the parameters are inside the bounds } + var + I : Integer; + OoB : Boolean; + begin + I := FirstParam; + OoB := False; + repeat + OoB := (B^[I] < B_min^[I]) or (B^[I] > B_max^[I]); + Inc(I); + until OoB or (I > LastParam); + OutOfBounds := OoB; + end; + + function OLS_ObjFunc(B : PVector) : Float; + { Objective function for unweighted nonlinear regression } + var + K : Integer; + S : Float; + begin + if OutOfBounds(B, ParamMin, ParamMax) then + begin + OLS_ObjFunc := MAX_FUNC; + Exit; + end; + S := 0.0; + K := FirstPoint; + repeat + YYcalc^[K] := RegFunc1(XX^[K], B); + S := S + Sqr(YY^[K] - YYcalc^[K]); + Inc(K); + until (K > NN) or (S > MAX_FUNC); + if S > MAX_FUNC then S := MAX_FUNC; + OLS_ObjFunc := S; + end; + + procedure OLS_Gradient(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; G : PVector); + { Gradient for unweighted nonlinear regression. + Func is a dummy parameter here. } + var + I, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + G^[I] := 0.0; + + { Compute Gradient } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + G^[I] := G^[I] - D^[I] * R; + end; + + for I := Lbound to Ubound do + G^[I] := 2.0 * G^[I]; + + DelVector(D, Ubound); + end; + + procedure OLS_HessGrad(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; + G : PVector; H : PMatrix); + { Gradient and Hessian for unweighted nonlinear regression. + Func is a dummy parameter here. } + var + I, J, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + begin + DimVector(D, Ubound); + + { Initializations } + for I := Lbound to Ubound do + begin + G^[I] := 0.0; + for J := I to Ubound do + H^[I]^[J] := 0.0; + end; + + { Compute Gradient & Hessian } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + G^[I] := G^[I] - D^[I] * R; + for J := I to Ubound do + H^[I]^[J] := H^[I]^[J] + D^[I] * D^[J]; + end; + end; + + { Fill in symmetric matrix } + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + H^[I]^[J] := H^[J]^[I]; + + DelVector(D, Ubound); + end; + + function WLS_ObjFunc(B : PVector) : Float; + { Objective function for weighted nonlinear regression } + var + K : Integer; + S : Float; + begin + if OutOfBounds(B, ParamMin, ParamMax) then + begin + WLS_ObjFunc := MAX_FUNC; + Exit; + end; + S := 0.0; + K := FirstPoint; + repeat + YYcalc^[K] := RegFunc1(XX^[K], B); + S := S + WW^[K] * Sqr(YY^[K] - YYcalc^[K]); + Inc(K); + until (K > NN) or (S > MAX_FUNC); + if S > MAX_FUNC then S := MAX_FUNC; + WLS_ObjFunc := S; + end; + + procedure WLS_Gradient(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; G : PVector); + { Gradient for weighted nonlinear regression. + Func is a dummy parameter here. } + var + I, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + WD : Float; { Weighted derivative } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + G^[I] := 0.0; + + { Compute Gradient } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + WD := WW^[K] * D^[I]; + G^[I] := G^[I] - WD * R; + end; + end; + + for I := Lbound to Ubound do + G^[I] := 2.0 * G^[I]; + + DelVector(D, Ubound); + end; + + procedure WLS_HessGrad(Func: TFuncNVar; B : PVector; + Lbound, Ubound : Integer; + G : PVector; H : PMatrix); + { Gradient and Hessian for weighted nonlinear regression. + Func is a dummy parameter here. } + var + I, J, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + WD : Float; { Weighted derivative } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + begin + G^[I] := 0.0; + for J := I to Ubound do + H^[I]^[J] := 0.0; + end; + + { Compute Gradient & Hessian } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + WD := WW^[K] * D^[I]; + G^[I] := G^[I] - WD * R; + for J := I to Ubound do + H^[I]^[J] := H^[I]^[J] + WD * D^[J]; + end; + end; + + { Fill in symmetric matrix } + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + H^[I]^[J] := H^[J]^[I]; + DelVector(D, Ubound); + end; + + {$F-} + + function GenNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + Mode : TRegMode; X, Y, W : PVector; + N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; + V : PMatrix) : Integer; + { -------------------------------------------------------------------- + General nonlinear regression routine + -------------------------------------------------------------------- } + var + F_min : Float; { Value of objective function at minimum } + ErrCode : Integer; { Error code } + G : PVector; { Gradient vector } + H : PMatrix; { Hessian matrix } + ObjFunc : TFuncNVar; { Objective function } + GradProc : TGradient; { Procedure to compute gradient } + HessProc : THessGrad; { Procedure to compute gradient and hessian } + begin + SetGlobalVar(RegFunc, DerivProc, Mode, X, Y, W, + N, Lbound, Ubound, B_min, B_max); + + case Mode of + UNWEIGHTED : begin + ObjFunc := {$IFDEF FPK}@{$ENDIF}OLS_ObjFunc; + GradProc := {$IFDEF FPK}@{$ENDIF}OLS_Gradient; + HessProc := {$IFDEF FPK}@{$ENDIF}OLS_HessGrad; + end; + WEIGHTED : begin + ObjFunc := {$IFDEF FPK}@{$ENDIF}WLS_ObjFunc; + GradProc := {$IFDEF FPK}@{$ENDIF}WLS_Gradient; + HessProc := {$IFDEF FPK}@{$ENDIF}WLS_HessGrad; + end; + end; + + case OptAlgo of + NL_MARQ : ErrCode := Marquardt(ObjFunc, HessProc, B, Lbound, Ubound, + MaxIter, Tol, F_min, V); + NL_SIMP : ErrCode := Simplex(ObjFunc, B, Lbound, Ubound, + MaxIter, Tol, F_min); + NL_BFGS : ErrCode := BFGS(ObjFunc, GradProc, B, Lbound, Ubound, + MaxIter, Tol, F_min, V); + NL_SA : ErrCode := SimAnn(ObjFunc, B, B_min, B_max, Lbound, Ubound, + MaxIter, Tol, F_min); + end; + + if (OptAlgo <> NL_MARQ) and (OptAlgo <> NL_BFGS) and (ErrCode = OPT_OK) then + begin + { Compute the Hessian matrix and its inverse } + DimVector(G, Ubound); + DimMatrix(H, Ubound, Ubound); + case Mode of + UNWEIGHTED : OLS_HessGrad(ObjFunc, B, Lbound, Ubound, G, H); + WEIGHTED : WLS_HessGrad(ObjFunc, B, Lbound, Ubound, G, H); + end; + if InvMat(H, Lbound, Ubound, V) = 0 then + ErrCode := OPT_OK + else + ErrCode := OPT_SING; + DelVector(G, Ubound); + DelMatrix(H, Ubound, Ubound); + end; + + GenNLFit := ErrCode; + end; + + function NLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + NLFit := GenNLFit(RegFunc, DerivProc, UNWEIGHTED, X, Y, W, N, + Lbound, Ubound, MaxIter, Tol, B, B_min, B_max, V); + end; + + function WNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y, W : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + begin + WNLFit := GenNLFit(RegFunc, DerivProc, WEIGHTED, X, Y, W, N, + Lbound, Ubound, MaxIter, Tol, B, B_min, B_max, V); + end; + + procedure GenRegTest(Mode : TRegMode; Y, Ycalc, W : PVector; + N, Lbound, Ubound : Integer; V : PMatrix; + var Test : TRegTest); + var + Ybar : Float; { Average Y value } + SSt : Float; { Total sum of squares } + SSe : Float; { Explained sum of squares } + SSr : Float; { Residual sum of squares } + Nobs : Integer; { Number of observations } + Npar : Integer; { Number of fitted parameters } + Nu1, Nu2 : Integer; { Degrees of freedom } + I, J : Integer; { Loop variables } + begin + Nobs := N - FirstPoint + 1; + Npar := Ubound - Lbound + 1; + with Test do + if Nobs > Npar then + begin + Ybar := Average(Y, FirstPoint, N); + if Mode = UNWEIGHTED then + begin + SSt := SumSqrDif(Y, FirstPoint, N, Ybar); + SSe := SumSqrDif(Ycalc, FirstPoint, N, Ybar); + SSr := SumSqrDifVect(Y, Ycalc, FirstPoint, N); + end + else + begin + SSt := SumWSqrDif(Y, W, FirstPoint, N, Ybar); + SSe := SumWSqrDif(Ycalc, W, FirstPoint, N, Ybar); + SSr := SumWSqrDifVect(Y, Ycalc, W, FirstPoint, N); + end; + Nu1 := Npar - 1; + Nu2 := Nobs - Npar; + if (SSt = 0) or (Nu2=0) then begin + //showmessage('Error: are all you data points in the same plane?'); + exit; + end; + R2 := SSe / SSt; + R2a := 1.0 - (1.0 - R2) * (Nobs - 1) / Nu2; + Vr := SSr / Nu2; + if (Vr > 0.0) and (Nu1 > 0.0) then + begin + F := (SSe / Nu1) / Vr; + Prob := PSnedecor(Nu1, Nu2, F); + end + else + begin + F := MAXNUM; + Prob := 0.0; + end; + end + else + begin + Vr := 0.0; + R2 := 1.0; + R2a := 0.0; + F := 0.0; + Prob := 1.0; + end; + + { Compute variance-covariance matrix } + for I := Lbound to Ubound do + for J := I to Ubound do + V^[I]^[J] := V^[I]^[J] * Test.Vr; + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + end; + + procedure RegTest(Y, Ycalc : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); + var + W : PVector; + begin + GenRegTest(UNWEIGHTED, Y, Ycalc, W, N, Lbound, Ubound, V, Test); + end; + + procedure WRegTest(Y, Ycalc, W : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); + begin + GenRegTest(WEIGHTED, Y, Ycalc, W, N, Lbound, Ubound, V, Test); + end; + + procedure ParamTest(B : PVector; V : PMatrix; N, Lbound, Ubound : Integer; + S, T, Prob : PVector); + var + I : Integer; + Nu : Integer; { Degrees of freedom } + Nobs : Integer; { Number of observations } + Nvar : Integer; { Number of indep. variables } + begin + Nobs := N - FirstPoint + 1; + Nvar := Ubound - Lbound + 1; + Nu := Nobs - Nvar; { DoF = Nb points - Nb parameters } + for I := Lbound to Ubound do + if V^[I]^[I] > 0.0 then + begin + S^[I] := Sqrt(V^[I]^[I]); + T^[I] := B^[I] / S^[I]; + Prob^[I] := PStudent(Nu, T^[I]); + end + else + begin + S^[I] := 0.0; + T^[I] := 0.0; + Prob^[I] := 1.0; + end; + end; + + procedure VecMean(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector); + var + I, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + X^[I]^[K]; + M^[I] := Sum / Nobs; + end; + end; + + procedure VecSD(X : PMatrix; N, Lbound, Ubound : Integer; M, S : PVector); + var + I, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + Sqr(X^[I]^[K] - M^[I]); + S^[I] := Sqrt(Sum / Nobs); + end; + end; + + procedure MatVarCov(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector; V : PMatrix); + var + I, J, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + for J := I to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + (X^[I]^[K] - M^[I]) * (X^[J]^[K] - M^[J]); + V^[I]^[J] := Sum / Nobs; + end; + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + end; + + procedure MatCorrel(V : PMatrix; Lbound, Ubound : Integer; R : PMatrix); + var + I, J : Integer; + begin + for I := Lbound to Ubound do + begin + R^[I]^[I] := 1.0; + for J := Succ(I) to Ubound do + begin + R^[I]^[J] := V^[I]^[J] / Sqrt(V^[I]^[I] * V^[J]^[J]); + R^[J]^[I] := R^[I]^[J]; + end; + end; + end; + + function PCA(R : PMatrix; Lbound, Ubound : Integer; + Lambda : PVector; C, Rc : PMatrix) : Integer; + var + I, J, ErrCode : Integer; + Rac : Float; + begin + { Compute eigenvalues and eigenvectors of correlation matrix } + ErrCode := Jacobi(R, Lbound, Ubound, PCA_MAXITER, PCA_TOL, C, Lambda); + + if ErrCode <> 0 then + begin + PCA := ErrCode; + Exit; + end; + + { Compute correlations between principal factors and reduced variables } + for I := Lbound to Ubound do + begin + Rac := Sqrt(Lambda^[I]); + for J := Lbound to Ubound do + Rc^[I]^[J] := C^[I]^[J] * Rac; + end; + + PCA := ErrCode; + end; + + procedure ScaleVar(X : PMatrix; N, Lbound, Ubound : Integer; + M, S : PVector; Z : PMatrix); + var + I, K : Integer; + begin + for I := Lbound to Ubound do + for K := FirstPoint to N do + Z^[I]^[K] := (X^[I]^[K] - M^[I]) / S^[I]; + end; + + procedure PrinFac(Z : PMatrix; N, Lbound, Ubound : Integer; + C, F : PMatrix); + var + I, J, K : Integer; + begin + for I := Lbound to Ubound do + for K := FirstPoint to N do + begin + F^[I]^[K] := 0.0; + for J := Lbound to Ubound do + F^[I]^[K] := F^[I]^[K] + C^[I]^[J] * Z^[J]^[K]; + end; + end; + +end. diff --git a/niftiview7/tpmath/_clean.bat b/niftiview7/tpmath/_clean.bat new file mode 100755 index 0000000..f4eb821 --- /dev/null +++ b/niftiview7/tpmath/_clean.bat @@ -0,0 +1,10 @@ +del /S *.~* +del /S *.dcu +del /S *.dsk +del /S *.cfg +del /S *.dof +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt diff --git a/niftiview7/tpmath/eigen.pas b/niftiview7/tpmath/eigen.pas new file mode 100755 index 0000000..0de4df1 --- /dev/null +++ b/niftiview7/tpmath/eigen.pas @@ -0,0 +1,715 @@ +{ ********************************************************************** + * Unit EIGEN.PAS * + * Version 1.8 * + * (c) J. Debord, May 2001 * + ********************************************************************** + Procedures for computing eigenvalues and eigenvectors + ********************************************************************** + References: + 1) Borland's Numerical Methods Toolbox : Jacobi + 2) 'Numerical Recipes' by Press et al. : EigenVals, RootPol + ********************************************************************** } + +unit Eigen; + +interface + +uses + FMath, Matrices; + +function Jacobi(A : PMatrix; Lbound, Ubound, MaxIter : Integer; + Tol : Float; V : PMatrix; Lambda : PVector) : Integer; +{ ---------------------------------------------------------------------- + Eigenvalues and eigenvectors of a symmetric matrix by the iterative + method of Jacobi + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : V = matrix of eigenvectors (stored by lines) + Lambda = eigenvalues in decreasing order + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : 1. The eigenvectors are normalized, with their first component > 0 + 2. This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function EigenVals(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Eigenvalues of a general square matrix + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameters : Lambda_Re = real part of eigenvalues + Lambda_Im = imaginary part of eigenvalues + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function EigenVect(A : PMatrix; Lbound, Ubound : Integer; + Lambda, Tol : Float; V : PVector) : Integer; +{ ---------------------------------------------------------------------- + Computes the eigenvector associated to a real eigenvalue + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + Lambda = eigenvalue + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : V = eigenvector + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : 1. The eigenvector is normalized, with its first component > 0 + 2. The function returns only one eigenvector, even if the + eigenvalue has a multiplicity greater than 1. + ---------------------------------------------------------------------- } + +procedure DivLargest(V : PVector; Lbound, Ubound : Integer; + var Largest : Float); +{ ---------------------------------------------------------------------- + Normalizes an eigenvector V by dividing by the element with the + largest absolute value + ---------------------------------------------------------------------- } + +function RootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Real and complex roots of a real polynomial by the method of the + companion matrix + ---------------------------------------------------------------------- + Input parameters : Coef = coefficients of polynomial + Deg = degree of polynomial + ---------------------------------------------------------------------- + Output parameters : X_Re = real parts of root (in increasing order) + X_Im = imaginary parts of root + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + + function Jacobi(A : PMatrix; Lbound, Ubound, MaxIter : Integer; + Tol : Float; V : PMatrix; Lambda : PVector) : Integer; + var + SinTheta, CosTheta, TanTheta, Tan2Theta : Float; + CosSqr, SinSqr, SinCos, SumSqrDiag : Float; + AII, AJJ, AIJ, AIK, AJK, VIK, VJK, D : Float; + I, J, K, Iter : Integer; + Done : Boolean; + begin + Iter := 0; + for I := Lbound to Ubound do + for J := Lbound to Ubound do + if I = J then + V^[I]^[J] := 1.0 + else + V^[I]^[J] := 0.0; + + repeat + Iter := Succ(Iter); + SumSqrDiag := 0.0; + for I := Lbound to Ubound do + SumSqrDiag := SumSqrDiag + Sqr(A^[I]^[I]); + Done := True; + + for I := Lbound to Pred(Ubound) do + for J := Succ(I) to Ubound do + if Abs(A^[I]^[J]) > Tol * SumSqrDiag then + begin + Done := False; + + { Calculate rotation } + D := A^[I]^[I] - A^[J]^[J]; + if Abs(D) > MACHEP then + begin + Tan2Theta := D / (2.0 * A^[I]^[J]); + TanTheta := - Tan2Theta + Sgn(Tan2Theta) * + Sqrt(1.0 + Sqr(Tan2Theta)); + CosTheta := 1.0 / Sqrt(1.0 + Sqr(TanTheta)); + SinTheta := CosTheta * TanTheta; + end + else + begin + CosTheta := SQRT2DIV2; { Sqrt(2)/2 } + SinTheta := Sgn(A^[I]^[J]) * SQRT2DIV2; + end; + + { Rotate matrix } + CosSqr := Sqr(CosTheta); + SinSqr := Sqr(SinTheta); + SinCos := SinTheta * CosTheta; + AII := A^[I]^[I] * CosSqr + 2.0 * A^[I]^[J] * SinCos + + A^[J]^[J] * SinSqr; + AJJ := A^[I]^[I] * SinSqr - 2.0 * A^[I]^[J] * SinCos + + A^[J]^[J] * CosSqr; + AIJ := (A^[J]^[J] - A^[I]^[I]) * SinCos + + A^[I]^[J] * (CosSqr - SinSqr); + for K := Lbound to Ubound do + if not(K in [I, J]) then + begin + AIK := A^[I]^[K] * CosTheta + A^[J]^[K] * SinTheta; + AJK := - A^[I]^[K] * SinTheta + A^[J]^[K] * CosTheta; + A^[I]^[K] := AIK; + A^[K]^[I] := AIK; + A^[J]^[K] := AJK; + A^[K]^[J] := AJK; + end; + A^[I]^[I] := AII; + A^[J]^[J] := AJJ; + A^[I]^[J] := AIJ; + A^[J]^[I] := AIJ; + + { Rotate eigenvectors } + for K := Lbound to Ubound do + begin + VIK := CosTheta * V^[I]^[K] + SinTheta * V^[J]^[K]; + VJK := - SinTheta * V^[I]^[K] + CosTheta * V^[J]^[K]; + V^[I]^[K] := VIK; + V^[J]^[K] := VJK; + end; + end; + until Done or (Iter > MaxIter); + + { The diagonal terms of the transformed matrix are the eigenvalues } + for I := Lbound to Ubound do + Lambda^[I] := A^[I]^[I]; + + if Iter > MaxIter then + begin + Jacobi := MAT_NON_CONV; + Exit; + end; + + { Sort eigenvalues and eigenvectors } + for I := Lbound to Pred(Ubound) do + begin + K := I; + D := Lambda^[I]; + for J := Succ(I) to Ubound do + if Lambda^[J] > D then + begin + K := J; + D := Lambda^[J]; + end; + FSwap(Lambda^[I], Lambda^[K]); + SwapRows(I, K, V, Lbound, Ubound); + end; + + { Make sure that the first component of each eigenvector is > 0 } + for I := Lbound to Ubound do + if V^[I]^[Lbound] < 0.0 then + for J := Lbound to Ubound do + V^[I]^[J] := - V^[I]^[J]; + + Jacobi := MAT_OK; + end; + + procedure Balance(A : PMatrix; Lbound, Ubound : Integer); + { Balances the matrix, i.e. reduces norm without affecting eigenvalues } + const + RADIX = 2; { Base used for machine computations } + var + I, J, Last : Integer; + C, F, G, R, S, Sqrdx : Float; + begin + Sqrdx := Sqr(RADIX); + repeat + Last := 1; + for I := Lbound to Ubound do + begin + C := 0.0; + R := 0.0; + for J := Lbound to Ubound do + if J <> I then + begin + C := C + Abs(A^[J]^[I]); + R := R + Abs(A^[I]^[J]); + end; + if (C <> 0.0) and (R <> 0.0) then + begin + G := R / RADIX; + F := 1.0; + S := C + R; + while C < G do + begin + F := F * RADIX; + C := C * Sqrdx; + end; + G := R * RADIX; + while C > G do + begin + F := F / RADIX; + C := C / Sqrdx; + end; + if (C + R) / F < 0.95 * S then + begin + Last := 0; + G := 1.0 / F; + for J := Lbound to Ubound do + A^[I]^[J] := A^[I]^[J] * G; + for J := Lbound to Ubound do + A^[J]^[I] := A^[J]^[I] * F; + end; + end; + end; + until Last <> 0; + end; + + procedure ElmHes(A : PMatrix; Lbound, Ubound : Integer); + { Reduces the matrix to upper Hessenberg form by elimination } + var + I, J, M : Integer; + X, Y : Float; + begin + for M := Succ(Lbound) to Pred(Ubound) do + begin + X := 0.0; + I := M; + for J := M to Ubound do + if Abs(A^[J]^[M - 1]) > Abs(X) then + begin + X := A^[J]^[M - 1]; + I := J; + end; + if I <> M then + begin + for J := Pred(M) to Ubound do + FSwap(A^[I]^[J], A^[M]^[J]); + for J := Lbound to Ubound do + FSwap(A^[J]^[I], A^[J]^[M]); + end; + if X <> 0.0 then + for I := Succ(M) to Ubound do + begin + Y := A^[I]^[M - 1]; + if Y <> 0.0 then + begin + Y := Y / X; + A^[I]^[M - 1] := Y; + for J := M to Ubound do + A^[I]^[J] := A^[I]^[J] - Y * A^[M]^[J]; + for J := Lbound to Ubound do + A^[J]^[M] := A^[J]^[M] + Y * A^[J]^[I]; + end; + end; + end; + for I := (Lbound + 2) to Ubound do + for J := Lbound to (I - 2) do + A^[I]^[J] := 0.0; + end; + + function Hqr(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; + { Finds the eigenvalues of an upper Hessenberg matrix } + label 2, 3, 4; + var + I, Its, J, K, L, M, N : Integer; + Anorm, P, Q, R, S, T, U, V, W, X, Y, Z : Float; + + function Sign(A, B : Float) : Float; + begin + if B < 0.0 then Sign := - Abs(A) else Sign := Abs(A) + end; + + begin + Anorm := Abs(A^[1]^[1]); + for I := Succ(Lbound) to Ubound do + for J := I - 1 to Ubound do + Anorm := Anorm + Abs(A^[I]^[J]); + N := Ubound; + T := 0.0; + while N >= Lbound do + begin + Its := 0; +2: for L := N downto Succ(Lbound) do + begin + S := Abs(A^[L - 1]^[L - 1]) + Abs(A^[L]^[L]); + if S = 0.0 then S := Anorm; + if Abs(A^[L]^[L - 1]) <= MACHEP * S then goto 3 + end; + L := Lbound; +3: X := A^[N]^[N]; + if L = N then + begin + Lambda_Re^[N] := X + T; + Lambda_Im^[N] := 0.0; + N := N - 1 + end + else + begin + Y := A^[N - 1]^[N - 1]; + W := A^[N]^[N - 1] * A^[N - 1]^[N]; + if L = N - 1 then + begin + P := 0.5 * (Y - X); + Q := Sqr(P) + W; + Z := Sqrt(Abs(Q)); + X := X + T; + if Q >= 0.0 then + begin + Z := P + Sign(Z, P); + Lambda_Re^[N] := X + Z; + Lambda_Re^[N - 1] := Lambda_Re^[N]; + if Z <> 0.0 then Lambda_Re^[N] := X - W / Z; + Lambda_Im^[N] := 0.0; + Lambda_Im^[N - 1] := 0.0 + end + else + begin + Lambda_Re^[N] := X + P; + Lambda_Re^[N - 1] := Lambda_Re^[N]; + Lambda_Im^[N] := Z; + Lambda_Im^[N - 1] := - Z + end; + N := N - 2 + end + else + begin + if Its = 30 then + begin + Hqr := MAT_NON_CONV; + Exit; + end; + if (Its = 10) or (Its = 20) then + begin + T := T + X; + for I := Lbound to N do + A^[I]^[I] := A^[I]^[I] - X; + S := Abs(A^[N]^[N - 1]) + Abs(A^[N - 1]^[N - 2]); + X := 0.75 * S; + Y := X; + W := - 0.4375 * Sqr(S) + end; + Its := Its + 1; + for M := N - 2 downto L do + begin + Z := A^[M]^[M]; + R := X - Z; + S := Y - Z; + P := (R * S - W) / A^[M + 1]^[M] + A^[M]^[M + 1]; + Q := A^[M + 1]^[M + 1] - Z - R - S; + R := A^[M + 2]^[M + 1]; + S := Abs(P) + Abs(Q) + Abs(R); + P := P / S; + Q := Q / S; + R := R / S; + if M = L then goto 4; + U := Abs(A^[M]^[M - 1]) * (Abs(Q) + Abs(R)); + V := Abs(P) * (Abs(A^[M - 1]^[M - 1]) + Abs(Z) + + Abs(A^[M + 1]^[M + 1])); + if U <= MACHEP * V then goto 4 + end; +4: for I := M + 2 to N do + begin + A^[I]^[I - 2] := 0.0; + if I <> (M + 2) then A^[I]^[I - 3] := 0.0 + end; + for K := M to N - 1 do + begin + if K <> M then + begin + P := A^[K]^[K - 1]; + Q := A^[K + 1]^[K - 1]; + R := 0.0; + if K <> (N - 1) then + R := A^[K + 2]^[K - 1]; + X := Abs(P) + Abs(Q) + Abs(R); + if X <> 0.0 then + begin + P := P / X; + Q := Q / X; + R := R / X + end + end; + S := Sign(Sqrt(Sqr(P) + Sqr(Q) + Sqr(R)), P); + if S <> 0.0 then + begin + if K = M then + begin + if L <> M then + A^[K]^[K - 1] := - A^[K]^[K - 1]; + end + else + begin + A^[K]^[K - 1] := - S * X + end; + P := P + S; + X := P / S; + Y := Q / S; + Z := R / S; + Q := Q / P; + R := R / P; + for J := K to N do + begin + P := A^[K]^[J] + Q * A^[K + 1]^[J]; + if K <> (N - 1) then + begin + P := P + R * A^[K + 2]^[J]; + A^[K + 2]^[J] := A^[K + 2]^[J] - P * Z + end; + A^[K + 1]^[J] := A^[K + 1]^[J] - P * Y; + A^[K]^[J] := A^[K]^[J] - P * X + end; + for I := L to IMin(N, K + 3) do + begin + P := X * A^[I]^[K] + Y * A^[I]^[K + 1]; + if K <> (N - 1) then + begin + P := P + Z * A^[I]^[K + 2]; + A^[I]^[K + 2] := A^[I]^[K + 2] - P * R + end; + A^[I]^[K + 1] := A^[I]^[K + 1] - P * Q; + A^[I]^[K] := A^[I]^[K] - P + end + end + end; + goto 2 + end + end + end; + Hqr := MAT_OK; + end; + + function EigenVals(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; + begin + Balance(A, Lbound, Ubound); + ElmHes(A, Lbound, Ubound); + EigenVals := Hqr(A, Lbound, Ubound, Lambda_Re, Lambda_Im); + end; + + procedure DivLargest(V : PVector; Lbound, Ubound : Integer; + var Largest : Float); + var + I : Integer; + begin + Largest := V^[Lbound]; + for I := Succ(Lbound) to Ubound do + if Abs(V^[I]) > Abs(Largest) then + Largest := V^[I]; + for I := Lbound to Ubound do + V^[I] := V^[I] / Largest; + end; + + function EigenVect(A : PMatrix; Lbound, Ubound : Integer; + Lambda, Tol : Float; V : PVector) : Integer; + + procedure SetMatrix(A, A1 : PMatrix; Lbound, Ubound : Integer; Lambda : Float); + { Form A1 = A - Lambda * I } + var + I : Integer; + begin + CopyMatrix(A1, A, Lbound, Lbound, Ubound, Ubound); + for I := Lbound to Ubound do + A1^[I]^[I] := A^[I]^[I] - Lambda; + end; + + function Solve(A : PMatrix; Lbound, Ubound, N : Integer; + Tol : Float; V : PVector) : Integer; + { Solve the system A*X = 0 after fixing the N-th unknown to 1 } + var + A1, W : PMatrix; + B, S, X : PVector; + ErrCode, I, I1, J, J1, Ubound1 : Integer; + begin + Ubound1 := Pred(Ubound); + + DimMatrix(A1, Ubound1, Ubound1); + DimMatrix(W, Ubound1, Ubound1); + DimVector(B, Ubound1); + DimVector(S, Ubound1); + DimVector(X, Ubound1); + + I1 := Pred(Lbound); + for I := Lbound to Ubound do + if I <> N then + begin + Inc(I1); + J1 := 0; + for J := Lbound to Ubound do + if J <> N then + begin + Inc(J1); + A1^[I1]^[J1] := A^[I]^[J]; + end + else + B^[I1] := - A^[I]^[J]; + end; + + ErrCode := SV_Decomp(A1, Lbound, Ubound1, Ubound1, S, W); + + if ErrCode = 0 then + begin + SV_SetZero(S, Lbound, Ubound1, Tol); + SV_Solve(A1, S, W, B, Lbound, Ubound1, Ubound1, X); + + { Update eigenvector } + I1 := 0; + for I := Lbound to Ubound do + if I = N then + V^[I] := 1.0 + else + begin + Inc(I1); + V^[I] := X^[I1]; + end; + end; + + DelMatrix(A1, Ubound1, Ubound1); + DelMatrix(W, Ubound1, Ubound1); + DelVector(B, Ubound1); + DelVector(S, Ubound1); + DelVector(X, Ubound1); + + Solve := ErrCode; + end; + + function ZeroVector(B : PVector; Lbound, Ubound : Integer; Tol : Float) : Boolean; + { Check if vector B is zero } + var + I : Integer; + Z : Boolean; + begin + Z := True; + for I := Lbound to Ubound do + Z := Z and (Abs(B^[I]) < Tol); + ZeroVector := Z; + end; + + function CheckEigenVector(A1 : PMatrix; V : PVector; + Lbound, Ubound : Integer; Tol : Float) : Boolean; + { Check if the equation A1 * V = 0 holds } + var + I, K : Integer; + B : PVector; + begin + DimVector(B, Ubound); + + { Form B = A1 * V } + for I := Lbound to Ubound do + for K := Lbound to Ubound do + B^[I] := B^[I] + A1^[I]^[K] * V^[K]; + + { Check if B is zero } + CheckEigenVector := ZeroVector(B, Lbound, Ubound, Tol); + + DelVector(B, Ubound); + end; + + procedure Normalize(V : PVector; Lbound, Ubound : Integer); + { Normalize eigenvector and make sure that the first component is >= 0 } + var + Sum, Norm : Float; + I : Integer; + begin + Sum := 0.0; + for I := Lbound to Ubound do + Sum := Sum + Sqr(V^[I]); + Norm := Sqrt(Sum); + for I := Lbound to Ubound do + if V^[I] <> 0.0 then V^[I] := V^[I] / Norm; + if V^[Lbound] < 0.0 then + for I := Lbound to Ubound do + if V^[I] <> 0.0 then V^[I] := - V^[I]; + end; + + var + ErrCode, I : Integer; + A1 : PMatrix; + + begin + DimMatrix(A1, Ubound, Ubound); + + { Form A1 = A - Lambda * I } + SetMatrix(A, A1, Lbound, Ubound, Lambda); + + { Try to solve the system A1*V=0 by eliminating 1 equation } + I := Lbound; + repeat + if (Solve(A1, Lbound, Ubound, I, Tol, V) = 0) and + CheckEigenVector(A1, V, Lbound, Ubound, Tol) + then + ErrCode := 0 + else + ErrCode := - 1; + Inc(I); + until (ErrCode = 0) or (I > Ubound); + + if ErrCode = 0 then + begin + Normalize(V, Lbound, Ubound); + EigenVect := MAT_OK; + end + else + EigenVect := MAT_NON_CONV; + + DelMatrix(A1, Ubound, Ubound); + end; + + function RootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; + var + A : PMatrix; { Companion matrix } + N : Integer; { Size of matrix } + I, J, K : Integer; { Loop variables } + ErrCode : Integer; { Error code } + Temp : Float; + begin + N := Pred(Deg); + DimMatrix(A, N, N); + + { Set up the companion matrix (to save space, begin at index 0) } + for J := 0 to N do + A^[0]^[J] := - Coef^[Deg - J - 1] / Coef^[Deg]; + for J := 0 to Pred(N) do + A^[J + 1]^[J] := 1.0; + + { The roots of the polynomial are the eigenvalues of the companion matrix } + Balance(A, 0, N); + ErrCode := Hqr(A, 0, N, X_Re, X_Im); + + if ErrCode = MAT_OK then + begin + { Sort roots in increasing order of real parts } + for I := 0 to N - 1 do + begin + K := I; + Temp := X_Re^[I]; + for J := Succ(I) to N do + if X_Re^[J] < Temp then + begin + K := J; + Temp := X_Re^[J]; + end; + FSwap(X_Re^[I], X_Re^[K]); + FSwap(X_Im^[I], X_Im^[K]); + end; + + { Transfer roots from 0..(Deg - 1) to 1..Deg } + for J := N downto 0 do + begin + X_Re^[J + 1] := X_Re^[J]; + X_Im^[J + 1] := X_Im^[J]; + end; + end; + + DelMatrix(A, N, N); + RootPol := ErrCode; + end; + +end. diff --git a/niftiview7/tpmath/fcomp.pas b/niftiview7/tpmath/fcomp.pas new file mode 100755 index 0000000..fa5a1a5 --- /dev/null +++ b/niftiview7/tpmath/fcomp.pas @@ -0,0 +1,649 @@ +{ ********************************************************************** + * Unit FCOMP.PAS * + * Version 1.1 * + * (c) J. Debord, July 2000 * + ********************************************************************** + Complex functions for TPMATH + (Based on CMPLX.ZIP by E.F. Glynn) + ********************************************************************** } + +unit FComp; + +interface + +uses + FMath; + +{ ********************************************************************** + Complex type + ********************************************************************** } + +type + ComplexForm = (Rec, Pol); { Rectangular or Polar form } + + Complex = record + case Form : ComplexForm of + Rec : (X, Y : Float); + Pol : (R, Theta : Float); + end; + +const + C_infinity : Complex = (Form : Rec; X : MAXNUM; Y : 0.0); + C_zero : Complex = (Form : Rec; X : 0.0; Y : 0.0); + C_one : Complex = (Form : Rec; X : 1.0; Y : 0.0); + C_i : Complex = (Form : Rec; X : 0.0; Y : 1.0); + C_pi : Complex = (Form : Rec; X : PI; Y : 0.0); + C_pi_div_2 : Complex = (Form : Rec; X : PIDIV2; Y : 0.0); + +{ ********************************************************************** + Complex number initialization and conversion + ********************************************************************** } + +procedure CSet(var Z : Complex; A, B : Float; F : ComplexForm); +{ ---------------------------------------------------------------------- + Initializes a complex number according to the form specified by F + F = Rec ==> Z = A + i * B + F = Pol ==> Z = A * Exp(i * B) + ---------------------------------------------------------------------- } + +procedure CConvert(var Z : Complex; F : ComplexForm); +{ Converts the complex number Z to the form specified by F } + +procedure CSwap(var X, Y : Complex); +{ Exchanges two complex numbers } + +{ ********************************************************************** + Complex functions + ********************************************************************** } + +function CReal(Z : Complex) : Float; { Re(Z) } +function CImag(Z : Complex) : Float; { Im(Z) } +function CAbs(Z : Complex) : Float; { |Z| } +function CArg(Z : Complex) : Float; { Arg(Z) } +function CSgn(Z : Complex) : Integer; { Complex sign } + +procedure CNeg(A : Complex; var Z : Complex); { Z = -A } +procedure CConj(A : Complex; var Z : Complex); { Z = A* } +procedure CAdd(A, B : Complex; var Z : Complex); { Z = A + B } +procedure CSub(A, B : Complex; var Z : Complex); { Z = A - B } +procedure CDiv(A, B : Complex; var Z : Complex); { Z = A / B } +procedure CMult(A, B : Complex; var Z : Complex); { Z = A * B } +procedure CLn(A : Complex; var Z : Complex); { Z = Ln(A) } +procedure CExp(A : Complex; var Z : Complex); { Z = Exp(A) } +procedure CPower(A, B : Complex; var Z : Complex); { Z = A^B } + +procedure CIntPower(A : Complex; N : Integer; var Z : Complex); { Z = A^N } +procedure CRealPower(A : Complex; X : Float; var Z : Complex); { Z = A^X } +procedure CSqrt(A : Complex; var Z : Complex); { Z = Sqrt(A) } +procedure CRoot(A : Complex; K, N : Integer; var Z : Complex); { Z = A^(1/N) } + +procedure CSin(A : Complex; var Z : Complex); { Z = Sin(A) } +procedure CCos(A : Complex; var Z : Complex); { Z = Cos(A) } +procedure CTan(A : Complex; var Z : Complex); { Z = Tan(A) } + +procedure CArcSin(A : Complex; var Z : Complex); { Z = ArcSin(A) } +procedure CArcCos(A : Complex; var Z : Complex); { Z = ArcCos(A) } +procedure CArcTan(A : Complex; var Z : Complex); { Z = ArcTan(A) } + +procedure CSinh(A : Complex; var Z : Complex); { Z = Sinh(A) } +procedure CCosh(A : Complex; var Z : Complex); { Z = Cosh(A) } +procedure CTanh(A : Complex; var Z : Complex); { Z = Tanh(A) } + +procedure CArcSinh(A : Complex; var Z : Complex); { Z = ArcSinh(A) } +procedure CArcCosh(A : Complex; var Z : Complex); { Z = ArcCosh(A) } +procedure CArcTanh(A : Complex; var Z : Complex); { Z = ArcTanh(A) } + +procedure CLnGamma(A : Complex; var Z : Complex); { Z = Ln(Gamma(A)) } + +implementation + +{$IFDEF CPU387} + {$DEFINE USE_ASM} +{$ENDIF} + +{$IFDEF CPUP2} + {$DEFINE USE_ASM} +{$ENDIF} + + procedure CSet(var Z : Complex; A, B : Float; F : ComplexForm); + begin + Z.Form := F; + if F = Pol then + begin + Z.R := A; + Z.Theta := B; + end + else + begin + Z.X := A; + Z.Y := B; + end; + end; + + function CAbs(Z : Complex) : Float; + begin + if Z.Form = Rec then + CAbs := Pythag(Z.X, Z.Y) + else + CAbs := Z.R; + end; + + function CArg(Z : Complex) : Float; + begin + if Z.Form = Rec then + CArg := ArcTan2(Z.Y, Z.X) + else + CArg := Z.Theta; + end; + + function CReal(Z : Complex) : Float; + begin + if Z.Form = Rec then + CReal := Z.X + else + CReal := Z.R * {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(Z.Theta); + end; + + function CImag(Z : Complex) : Float; + begin + if Z.Form = Rec then + CImag := Z.Y + else + CImag := Z.R * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(Z.Theta); + end; + + function CSgn(Z : Complex) : Integer; + var + Re, Im : Float; + begin + Re := CReal(Z); + if Re > 0.0 then + CSgn := 1 + else if Re < 0.0 then + CSgn := - 1 + else + begin + Im := CImag(Z); + if Im > 0.0 then + CSgn := 1 + else if Im < 0.0 then + CSgn := - 1 + else + CSgn := 0; + end; + end; + + procedure CConvert(var Z : Complex; F : ComplexForm); + var + A : Complex; + begin + if Z.Form = F then Exit; + if Z.Form = Pol then + begin { Polar-to-rectangular conversion } + A.Form := Rec; + A.X := Z.R * {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(Z.Theta); + A.Y := Z.R * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(Z.Theta); + end + else + begin { Rectangular-to-polar conversion } + A.Form := Pol; + if Z.X = 0.0 then + if Z.Y = 0.0 then + A.R := 0.0 + else if Z.Y > 0.0 then + A.R := Z.Y + else + A.R := - Z.Y + else + A.R := CAbs(Z); + A.Theta := ArcTan2(Z.Y, Z.X); + end; + Z := A; + end; + + procedure CSwap(var X, Y : Complex); + var + Temp : Complex; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + procedure CNeg(A : Complex; var Z : Complex); + begin + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R; + Z.Theta := FixAngle(A.Theta + PI) + end + else + begin + Z.X := - A.X; + Z.Y := - A.Y + end; + end; + + procedure CConj(A : Complex; var Z : Complex); + begin + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R; + Z.Theta := FixAngle(- A.Theta) + end + else + begin + Z.X := A.X; + Z.Y := - A.Y + end + end; + + procedure CAdd(A, B : Complex; var Z : Complex); + begin + CConvert(A, Rec); + CConvert(B, Rec); + Z.Form := Rec; + Z.X := A.X + B.X; + Z.Y := A.Y + B.Y; + end; + + procedure CSub(A, B : Complex; var Z : Complex); + begin + CConvert(A, Rec); + CConvert(B, Rec); + Z.Form := Rec; + Z.X := A.X - B.X; + Z.Y := A.Y - B.Y; + end; + + procedure CMult(A, B : Complex; var Z : Complex); + begin + CConvert(B, A.Form); { arbitrarily convert one to type of other } + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R * B.R; + Z.Theta := FixAngle(A.Theta + B.Theta) + end + else + begin + Z.X := A.X * B.X - A.Y * B.Y; + Z.Y := A.X * B.Y + A.Y * B.X + end; + end; + + procedure CDiv(A, B : Complex; var Z : Complex); + var + Temp : Float; + begin + if ((B.Form = Rec) and (B.X = 0.0) and (B.Y = 0.0)) or + ((B.Form = Pol) and (B.R = 0.0)) then + begin + MathErr := FN_OVERFLOW; + Z := C_infinity; + Exit; + end; + + CConvert(B, A.Form); { arbitrarily convert one to type of other } + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R / B.R; + Z.Theta := FixAngle(A.Theta - B.Theta); + end + else + begin + Temp := Sqr(B.X) + Sqr(B.Y); + Z.X := (A.X * B.X + A.Y * B.Y) / Temp; + Z.Y := (A.Y * B.X - A.X * B.Y) / Temp; + end; + end; + + procedure CLn(A : Complex; var Z : Complex); + var + LnR : Float; + begin + CConvert(A, Pol); + LnR := Log(A.R); + if MathErr = FN_OK then + CSet(Z, LnR, FixAngle(A.Theta), Rec) + else + CSet(Z, - MAXNUM, 0.0, Rec); + end; + + procedure CExp(A : Complex; var Z : Complex); + var + ExpX, SinY, CosY : Float; + begin + CConvert(A, Rec); + ExpX := Expo(A.X); + if MathErr = FN_OK then + begin + SinY := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(A.Y); + CosY := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(A.Y); + CSet(Z, ExpX * CosY, ExpX * SinY, Rec); + end + else + CSet(Z, ExpX, 0.0, Rec); + end; + + procedure CPower(A, B : Complex; var Z : Complex); + var + BLnA, LnA : Complex; + begin + CConvert(A, Rec); + CConvert(B, Rec); + if (A.X = 0.0) and (A.Y = 0.0) then + if (B.X = 0.0) and (B.Y = 0.0) then + Z := C_one { lim a^a = 1 as a -> 0 } + else + Z := C_zero { 0^b = 0, b > 0 } + else + begin + CLn(A, LnA); + CMult(B, LnA, BLnA); + CExp(BLnA, Z); + end; + end; + + procedure CIntPower(A : Complex; N : Integer; var Z : Complex); + { CIntPower directly applies DeMoivre's theorem to calculate an integer + power of a complex number. The formula holds for both positive and + negative values of N } + begin + CConvert(A, Pol); + if A.R = 0.0 then + if N = 0 then + Z := C_one + else if N > 0 then + Z := C_zero + else + begin + MathErr := FN_SING; + Z := C_infinity; + end + else + CSet(Z, IntPower(A.R, N), FixAngle(N * A.Theta), Pol); + end; + + procedure CRealPower(A : Complex; X : Float; var Z : Complex); + begin + CConvert(A, Pol); + if A.R = 0.0 then + if X = 0.0 then + Z := C_one + else if X > 0.0 then + Z := C_zero + else + begin + MathErr := FN_SING; + Z := C_infinity; + end + else + CSet(Z, Power(A.R, X), FixAngle(X * A.Theta), Pol); + end; + + procedure CRoot(A : Complex; K, N : Integer; var Z : Complex); + { CRoot can calculate all 'N' roots of 'A' by varying 'K' from 0..N-1 } + { This is another application of DeMoivre's theorem. See CIntPower. } + begin + if (N <= 0) or (K < 0) or (K >= N) then + begin + MathErr := FN_DOMAIN; + Z := C_zero; + Exit; + end; + CConvert(A, Pol); + if A.R = 0.0 then + Z := C_zero + else + CSet(Z, Power(A.R, 1.0 / N), FixAngle((A.Theta + K * TWOPI) / N), Pol); + end; + + procedure CSqrt(A : Complex; var Z : Complex); + begin + CConvert(A, Pol); + if A.R = 0.0 then + Z := C_zero + else + CSet(Z, Sqrt(A.R), FixAngle(0.5 * A.Theta), Pol); + end; + + procedure CCos(A : Complex; var Z : Complex); + var + SinX, CosX, SinhY, CoshY : Float; + begin + CConvert(A, Rec); + SinCos(A.X, SinX, CosX); + SinhCosh(A.Y, SinhY, CoshY); { Called here to set MathErr } + CSet(Z, CosX * CoshY, - SinX * SinhY, Rec) + end; + + procedure CSin(A : Complex; var Z : Complex); + var + SinX, CosX, SinhY, CoshY : Float; + begin + CConvert(A, Rec); + SinCos(A.X, SinX, CosX); + SinhCosh(A.Y, SinhY, CoshY); { Called here to set MathErr } + CSet(Z, SinX * CoshY, CosX * SinhY, Rec) + end; + + procedure CTan(A : Complex; var Z : Complex); + var + X2, Y2, SinX2, CosX2, SinhY2, CoshY2, Temp : Float; + begin + CConvert(A, Rec); + X2 := 2.0 * A.X; + Y2 := 2.0 * A.Y; + SinCos(X2, SinX2, CosX2); + SinhCosh(Y2, SinhY2, CoshY2); + if MathErr = FN_OK then + Temp := CosX2 + CoshY2 + else + Temp := CoshY2; + if Temp <> 0.0 then + CSet(Z, SinX2 / Temp, SinhY2 / Temp, Rec) + else + begin { A = Pi/2 + k*Pi } + MathErr := FN_SING; + CSet(Z, MAXNUM, 0.0, Rec); + end; + end; + + procedure CCosh(A : Complex; var Z : Complex); + var + SinhX, CoshX, SinY, CosY : Float; + begin + CConvert(A, Rec); + SinCos(A.Y, SinY, CosY); + SinhCosh(A.X, SinhX, CoshX); + CSet(Z, CoshX * CosY, SinhX * SinY, Rec) + end; + + procedure CSinh(A : Complex; var Z : Complex); + var + SinhX, CoshX, SinY, CosY : Float; + begin + CConvert(A, Rec); + SinCos(A.Y, SinY, CosY); + SinhCosh(A.X, SinhX, CoshX); + CSet(Z, SinhX * CosY, CoshX * SinY, Rec) + end; + + procedure CTanh(A : Complex; var Z : Complex); + var + X2, Y2, SinY2, CosY2, SinhX2, CoshX2, Temp : Float; + begin + CConvert(A, Rec); + X2 := 2.0 * A.X; + Y2 := 2.0 * A.Y; + SinCos(Y2, SinY2, CosY2); + SinhCosh(X2, SinhX2, CoshX2); + if MathErr = FN_OK then + Temp := CoshX2 + CosY2 + else + Temp := CoshX2; + if Temp <> 0.0 then + CSet(Z, SinhX2 / Temp, SinY2 / Temp, Rec) + else + begin { A = i * (Pi/2 + k*Pi) } + MathErr := FN_SING; + CSet(Z, 0.0, MAXNUM, Rec); + end; + end; + + procedure CArcSin(A : Complex; var Z : Complex); + var + Rp, Rm, S, T, X2, XX, YY : Float; + B : Complex; + begin + CConvert(A, Rec); + CSet(B, A.Y, - A.X, Rec); { Y - i*X } + X2 := 2.0 * A.X; + XX := Sqr(A.X); + YY := Sqr(A.Y); + S := XX + YY + 1.0; + Rp := 0.5 * Sqrt(S + X2); + Rm := 0.5 * Sqrt(S - X2); + T := Rp + Rm; + Z.Form := Rec; + Z.X := ArcSin(Rp - Rm); + Z.Y := CSgn(B) * Log(T + Sqrt(Sqr(T) - 1.0)); + end; + + procedure CArcCos(A : Complex; var Z : Complex); + begin + CArcSin(A, Z); + CSub(C_pi_div_2, Z, Z); { Pi/2 - ArcSin(Z) } + end; + + procedure CArcTan(A : Complex; var Z : Complex); + var + XX, Yp1, Ym1 : Float; + begin + CConvert(A, Rec); + if (A.X = 0.0) and (Abs(A.Y) = 1.0) then { A = +/- i } + begin + MathErr := FN_SING; + CSet(Z, 0.0, Sgn(A.Y) * MAXNUM, Rec); + Exit; + end; + XX := Sqr(A.X); + Yp1 := A.Y + 1.0; + Ym1 := A.Y - 1.0; + Z.Form := Rec; + Z.X := 0.5 * (ArcTan2(A.X, - Ym1) - ArcTan2(- A.X, Yp1)); + Z.Y := 0.25 * Log((XX + Sqr(Yp1)) / (XX + Sqr(Ym1))); + end; + + procedure CArcSinh(A : Complex; var Z : Complex); + { ArcSinH(A) = -i*ArcSin(i*A) } + begin + CMult(C_i, A, Z); + CArcSin(Z, Z); + CMult(C_i, Z, Z); + CNeg(Z, Z); + end; + + procedure CArcCosh(A : Complex; var Z : Complex); + { ArcCosH(A) = CSgn(Y + i(1-X))*i*ArcCos(A) where A = X+iY } + var + B : Complex; + begin + CArcCos(A, Z); + CMult(C_i, Z, Z); + CSet(B, A.Y, 1.0 - A.X, Rec); { Y + i*(1-X) } + if CSgn(B) = -1 then CNeg(Z, Z); + end; + + procedure CArcTanh(A : Complex; var Z : Complex); + { ArcTanH(A) = -i*ArcTan(i*A) } + begin + CConvert(A, Rec); + if (Abs(A.X) = 1.0) and (A.Y = 0.0) then { A = +/- 1 } + begin + MathErr := FN_SING; + CSet(Z, Sgn(A.X) * MAXNUM, 0.0, Rec); + Exit; + end; + CMult(C_i, A, Z); + CArcTan(Z, Z); + CMult(C_i, Z, Z); + CNeg(Z, Z); + end; + + procedure CApproxLnGamma(Z : Complex; var Sum : Complex); + { This is the approximation used in the National Bureau of + Standards "Table of the Gamma Function for Complex Arguments," + Applied Mathematics Series 34, 1954. The NBS table was created + using this approximation over the area 9 < Re(z) < 10 and + 0 < Im(z) < 10. Other table values were computed using the + relationship: + _ _ + ln | (z+1) = ln z + ln | (z) } + + const + C : array[1..8] of Float = + (8.33333333333333E-02, - 2.77777777777778E-03, + 7.93650793650794E-04, - 5.95238095238095E-04, + 8.41750841750842E-04, - 1.91752691752692E-03, + 6.41025641025641E-03, - 2.95506535947712E-02); + var + I : Integer; + Powers : array[1..8] of Complex; + Temp1, Temp2 : Complex; + begin + CConvert(Z, Rec); + CLn(Z, Temp1); { Ln(Z) } + CSet(Temp2, Z.X - 0.5, Z.Y, Rec); { Z - 0.5 } + CMult(Temp1, Temp2, Sum); { (Z - 0.5)*Ln(Z) } + CSub(Sum, Z, Sum); { (Z - 0.5)*ln(Z) - Z } + Sum.X := Sum.X + LN2PIDIV2; + Temp1 := C_one; + CDiv(Temp1, Z, Powers[1]); { Z^(-1) } + CMult(Powers[1], Powers[1], Temp2); { Z^(-2) } + for I := 2 to 8 do + CMult(Powers[I - 1], Temp2, Powers[I]); + for I := 8 downto 1 do + begin + CSet(Temp1, C[I] * Powers[I].X, C[I] * Powers[I].Y, Rec); + CAdd(Sum, Temp1, Sum); + end + end; + + procedure CLnGamma(A : Complex; var Z : Complex); + var + LnA, Temp : Complex; + begin + CConvert(A, Rec); + if (A.X <= 0.0) and (A.Y = 0.0) then + if (Int(A.X - 1E-8) - A.X) = 0.0 then { Negative integer? } + begin + MathErr := FN_SING; + Z := C_infinity; + Exit + end; + if A.Y < 0.0 then { 3rd or 4th quadrant? } + begin + CConj(A, A); + CLnGamma(A, Z); { Try again in 1st or 2nd quadrant } + CConj(Z, Z) { Left this out! 1/3/91 } + end + else + begin + if A.X < 9.0 then { "left" of NBS table range } + begin + CLn(A, LnA); + CSet(A, A.X + 1.0, A.Y, Rec); + CLnGamma(A, Temp); + CSub(Temp, LnA, Z) + end + else + CApproxLnGamma(A, Z) { NBS table range: 9 < Re(z) < 10 } + end + end; + +end. diff --git a/niftiview7/tpmath/fitexlin.pas b/niftiview7/tpmath/fitexlin.pas new file mode 100755 index 0000000..06f798a --- /dev/null +++ b/niftiview7/tpmath/fitexlin.pas @@ -0,0 +1,129 @@ +{ ********************************************************************** + * Unit FITEXLIN.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the "exponential + linear" model: + + y = A.[1 - exp(-k.x)] + B.x + + ********************************************************************** } + +unit FitExLin; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A[1 - exp(-k.x)] + B.x'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'k'; + 2 : ParamName := 'B'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = A B^[1] = k B^[2] = B + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * (1.0 - Expo(- B^[1] * X)) + B^[2] * X; + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + E : Float; + begin + E := Expo(- B^[1] * X); { exp(-k.x) } + D^[0] := 1.0 - E; { dy/dA = 1 - exp(-k.x) } + D^[1] := B^[0] * X * E; { dy/dk = A.x.exp(-k.x) } + D^[2] := X; { dy/dB = x } + end; + + function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Computes initial estimates of the regression parameters + -------------------------------------------------------------------- + Input : N = number of points + X, Y = point coordinates + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + K : Integer; + D : Float; + begin + { B is the slope of the last (linear) part of the curve } + K := Round(0.9 * N); + if K = N then K := Pred(N); + B^[2] := (Y^[N] - Y^[K]) / (X^[N] - X^[K]); + + { A is the intercept of the linear part } + B^[0] := Y^[N] - B^[2] * X^[N]; + + { Slope of the tangent at origin = B + k.A } + K := Round(0.1 * N); + if K = 1 then K := 2; + D := (Y^[K] - Y^[1]) / (X^[K] - X^[1]); + B^[1] := (D - B^[1]) / B^[0]; + + FitModel := 0; + end; + + end. diff --git a/niftiview7/tpmath/fitexpo.pas b/niftiview7/tpmath/fitexpo.pas new file mode 100755 index 0000000..218d092 --- /dev/null +++ b/niftiview7/tpmath/fitexpo.pas @@ -0,0 +1,316 @@ +{ ********************************************************************** + * Unit FITEXPO.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits a sum of decreasing exponentials : + + y = Ymin + A1.exp(-a1.x) + A2.exp(-a2.x) + A3.exp(-a3.x) + ... + + ********************************************************************** } + +unit FitExpo; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Stat, Regress; + +const + NO_REAL_ROOT = - 2; { No real exponent } + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + N_exp : Integer = 1; { Number of exponentials } + ConsTerm : Boolean = True; { Flags the presence of a constant term Ymin } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + I : Integer; + Name, S : String; + begin + Name := 'y = '; + if ConsTerm then + Name := Name + 'Ymin + '; + Name := Name + 'A1.exp(-a1.x)'; + for I := 2 to N_exp do + begin + Str(I, S); + Name := Name + ' + A' + S + '.exp(-a' + S + '.x)'; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term Ymin, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2 * N_exp; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + if I = 0 then + ParamName := 'Ymin' + else if Odd(I) then + begin + Str(Succ(I) div 2, S); + ParamName := 'A' + S; + end + else + begin + Str(I div 2, S); + ParamName := 'a' + S; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + B^[0] = Ymin + B^[1] = A1 B^[2] = a1 + ............................... + B^[2*i-1] = Ai B^[2*i] = ai i = 1..N_exp + -------------------------------------------------------------------- } + var + I : Integer; + S : Float; + begin + if ConsTerm then + S := B^[0] + else + S := 0.0; + for I := 1 to N_exp do + S := S + B^[2 * I - 1] * Expo(- B^[2 * I] * X); + RegFunc := S; + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + I, P, Q : Integer; + E : Float; + begin + D^[0] := 1.0; { dy/dYmin = 1 } + for I := 1 to N_exp do + begin + Q := 2 * I; + P := Pred(Q); + E := Expo(- B^[Q] * X); + D^[P] := E; { dy/dAi = exp(-ai.x) } + D^[Q] := - X * B^[P] * E; { dy/dai = -x.Ai.exp(-ai.x) } + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a sum of exponentials by linear regression + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- + Ref. : R. GOMENI & C. GOMENI, Automod : A polyalgorithm for an + integrated analysis of linear pharmacokinetic models + Comput. Biol. Med., 1979, 9, 39-48 + -------------------------------------------------------------------- } + var + I, K, M : Integer; + X1, Y1 : PVector; { Modified coordinates } + U : PMatrix; { Variables for linear regression } + P : PVector; { Linear regression parameters } + C, Z : PVector; { Coefficients and roots of polynomial } + V : PMatrix; { Variance-covariance matrix } + H : Float; { Integration step } + ErrCode : Integer; { Error code } + begin + M := Pred(2 * N_exp); + DimVector(X1, N); + DimVector(Y1, N); + DimMatrix(U, M, N); + DimMatrix(V, M, M); + DimVector(P, M); + DimVector(C, N_exp); + DimVector(Z, N_exp); + CopyVector(X1, X, 1, N); + CopyVector(Y1, Y, 1, N); + + { Change scale so that the X's begin at zero } + if X^[1] <> 0.0 then + for K := 1 to N do + X1^[K] := X1^[K] - X^[1]; + + { Estimate the constant term at 90% of the lowest observed value, + then subtract it from each Y value } + if ConsTerm then + begin + B^[0] := 0.9 * Min(Y1, 1, N); + for K := 1 to N do + Y1^[K] := Y1^[K] - B^[0]; + end; + + { ------------------------------------------------------------------ + Fit the linearized form of the function : + + y = p(0) + p(1) * x + p(2) * x^2 + ... + p(N_exp-1) * x^(N_exp-1) + + (x (x (x + + p(N_exp) | y dx + ... + p(2*N_exp-1) | ....| y dx + )0 )0 )0 + ------------------------------------------------------------------ } + + { Compute increasing powers of X } + if N_exp > 1 then + for K := 2 to N do + begin + U^[1]^[K] := X1^[K]; + for I := 2 to Pred(N_exp) do + U^[I]^[K] := U^[I - 1]^[K] * X1^[K]; + end; + + { Compute integrals by the trapezoidal rule } + for K := 2 to N do + begin + H := 0.5 * (X1^[K] - X1^[K - 1]); + U^[N_exp]^[K] := U^[N_exp]^[K - 1] + (Y1^[K] + Y1^[K - 1]) * H; + for I := Succ(N_exp) to M do + U^[I]^[K] := U^[I]^[K - 1] + (U^[I - 1]^[K] + U^[I - 1]^[K - 1]) * H; + end; + + { Fit the equation } + case Method of + 0 : ErrCode := MulFit(U, Y1, N, M, True, P, V); + 1 : ErrCode := WMulFit(U, Y1, W, N, M, True, P, V); + end; + + if ErrCode = MAT_SINGUL then + FitModel := ErrCode + else + begin + { ---------------------------------------------------------------- + The exponents are the roots of the polynomial : + x^N_exp + p(N_exp) * x^(N_exp-1) - p(N_exp+1) * x^(N_exp-2) +... + ---------------------------------------------------------------- } + + { Compute polynomial coefficients } + C^[N_exp] := 1.0; + for I := 1 to N_exp do + if Odd(I) then + C^[N_exp - I] := P^[N_exp + I - 1] + else + C^[N_exp - I] := - P^[N_exp + I - 1]; + + { Solve polynomial } + if RRootPol(C, N_exp, Z) <> N_exp then + FitModel := NO_REAL_ROOT + else + begin + { Sort exponents in decreasing order } + DQSort(Z, 1, N_exp); + + { Compute the coefficients of the exponentials by + linear regression on the exponential terms } + for I := 1 to N_exp do + for K := 1 to N do + U^[I]^[K] := Expo(- Z^[I] * X1^[K]); + + case Method of + 0 : ErrCode := MulFit(U, Y1, N, N_exp, False, P, V); + 1 : ErrCode := WMulFit(U, Y1, W, N, N_exp, False, P, V); + end; + + if ErrCode = MAT_SINGUL then + FitModel := ErrCode + else + begin + { Extract model parameters } + for I := 1 to N_exp do + begin + { Correct for scale change if necessary } + if X^[1] <> 0.0 then + P^[I] := P^[I] * Expo(Z^[I] * X^[1]); + + { Extract coefficients and exponents } + B^[2 * I - 1] := P^[I]; { Coefficients } + B^[2 * I] := Z^[I]; { Exponents } + end; + FitModel := MAT_OK; + end; + end; + end; + + DelVector(X1, N); + DelVector(Y1, N); + DelMatrix(U, M, N); + DelMatrix(V, M, M); + DelVector(P, M); + DelVector(C, N_exp); + DelVector(Z, N_exp); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = number of exponentials + CstPar^[1] = 1 to include a constant term (Ymin) + -------------------------------------------------------------------- } + var + N : Integer; + begin + N := Round(CstPar^[0]); + if N > 0 then N_exp := N; + ConsTerm := (CstPar^[1] = 1); + end; + +end. diff --git a/niftiview7/tpmath/fitfrac.pas b/niftiview7/tpmath/fitfrac.pas new file mode 100755 index 0000000..156db73 --- /dev/null +++ b/niftiview7/tpmath/fitfrac.pas @@ -0,0 +1,220 @@ +{ ********************************************************************** + * Unit FITFRAC.PAS * + * Version 1.2 * + * (c) J. Debord, April 1999 * + ********************************************************************** + This unit fits a rational fraction : + + p0 + p1.x + p2.x^2 + ... + y = ------------------------ + 1 + q1.x + q2.x^2 + ... + + ********************************************************************** } + +unit FitFrac; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Deg1 : Integer = 1; { Degree of numerator } + Deg2 : Integer = 1; { Degree of denominator } + ConsTerm : Boolean = True; { Flags the presence of a constant term p0 } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = ('; + if ConsTerm then + Name := Name + 'p0 + '; + Name := Name + 'p1.x'; + for I := 2 to Deg1 do + begin + Str(I, S); + Name := Name + ' + p' + S + '.x^' + S; + end; + Name := Name + ') / (1 + q1.x'; + for I := (Deg1 + 2) to (Deg1 + Deg2) do + begin + Str(I - Deg1, S); + Name := Name + ' + q' + S + '.x^' + S; + end; + Name := Name + ')'; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term p0, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := Deg1 + Deg2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + if I <= Deg1 then + begin + Str(I, S); + ParamName := 'p' + S; + end + else + begin + Str(I - Deg1, S); + ParamName := 'q' + S; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = p0 + B^[1] = p1 B^[2] = p2 ... + + B^[Deg1 + 1] = q1 B^[Deg1 + 2] = q2 ... + -------------------------------------------------------------------- } + begin + RegFunc := RFrac(X, B, Deg1, Deg2); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + I : Integer; + Den : Float; + begin + { Compute denominator (1 + q1.x + q2.x^2 + ...) } + Den := 0.0; + for I := (Deg1 + Deg2) downto Succ(Deg1) do + Den := (Den + B^[I]) * X; + Den := 1.0 + Den; + + { dy/dp0 = 1 / (1 + q1.x + q2.x^2 + ...) } + D^[0] := 1.0 / Den; + + { dy/dpi = x^i / (1 + q1.x + q2.x^2 + ...) } + for I := 1 to Deg1 do + D^[I] := D^[I - 1] * X; + + { dy/dq1 = -x.y / (1 + q1.x + q2.x^2 + ...) } + D^[Deg1 + 1] := - X * Y / Den; + + { dy/dqi = -x^i.y / (1 + q1.x + q2.x^2 + ...) } + for I := (Deg1 + 2) to (Deg1 + Deg2) do + D^[I] := D^[I - 1] * X; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a rational fraction by linear regression: + y = p0 + p1.x + p2.x^2 + ... - q1.(x.y) - q2.(x^2.y) - ... + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + I, J : Integer; { Loop variables } + M : Integer; { Index of last fitted parameter } + U : PMatrix; { Matrix of independent variables } + V : PMatrix; { Variance-covariance matrix } + begin + M := LastParam; + DimMatrix(U, M, N); + DimMatrix(V, M, M); + + for J := 1 to N do + begin + U^[1]^[J] := X^[J]; + for I := 2 to Deg1 do + U^[I]^[J] := U^[I - 1]^[J] * X^[J]; + U^[Deg1 + 1]^[J] := - X^[J] * Y^[J]; + for I := (Deg1 + 2) to M do + U^[I]^[J] := U^[I - 1]^[J] * X^[J]; + end; + + case Method of + 0 : FitModel := MulFit(U, Y, N, M, ConsTerm, B, V); + 1 : FitModel := WMulFit(U, Y, W, N, M, ConsTerm, B, V); + end; + + if not ConsTerm then B^[0] := 0.0; + + DelMatrix(U, M, N); + DelMatrix(V, M, M); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = Degree of numerator + CstPar^[1] = Degree of denominator + CstPar^[2] = 1 to include a constant term (p0) + -------------------------------------------------------------------- } + var + D1, D2 : Integer; + begin + D1 := Round(CstPar^[0]); + D2 := Round(CstPar^[1]); + if D1 > 0 then Deg1 := D1; + if D2 > 0 then Deg2 := D2; + ConsTerm := (CstPar^[2] = 1); + end; + +end. diff --git a/niftiview7/tpmath/fithill.pas b/niftiview7/tpmath/fithill.pas new file mode 100755 index 0000000..69c1eee --- /dev/null +++ b/niftiview7/tpmath/fithill.pas @@ -0,0 +1,182 @@ +{ ********************************************************************** + * Unit FITHILL.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the Hill equation : + + Ymax . x^n + y = ---------- + K^n + x^n + + ********************************************************************** } + +unit FitHill; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = Ymax . x^n / (K^n + x^n)'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'Ymax'; + 1 : ParamName := 'K '; + 2 : ParamName := 'n '; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = Ymax B^[1] = K B^[2] = n + -------------------------------------------------------------------- } + begin + if X = 0.0 then + if B^[2] > 0.0 then RegFunc := 0.0 else RegFunc := B^[0] + else + { Compute function according to y = Ymax / [1 + (K/x)^n] } + RegFunc := B^[0] / (1.0 + Power(B^[1] / X, B^[2])); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + Q, R, S : Float; + begin + if X = 0.0 then + begin + if B^[2] > 0.0 then D^[0] := 0.0 else D^[0] := 1.0; + D^[1] := 0.0; + D^[2] := 0.0; + end + else + begin + Q := Power(B^[1] / X, B^[2]); { (K/x)^n } + R := 1.0 / (1.0 + Q); { 1 / [1 + (K/x)^n] } + S := - Y * R * Q; { -Ymax.(K/x)^n / [1 + (K/x)^n]^2 } + + { dy/dYmax = 1 / [1 + (K/x)^n] } + D^[0] := R; + + { dy/dK = -Ymax.(K/x)^n.(n/K)/[1 + (K/x)^n]^2 } + D^[1] := S * B^[2] / B^[1]; + + { dy/dn = -Ymax.(K/x)^n.Ln(K/x)/[1 + (K/x)^n]^2 } + D^[2] := S * Log(B^[1] / X); + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the Hill equation by linear regression: + Ln(Ymax/y - 1) = n.Ln(K) - n.Ln(x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + Ymax : Float; { Estimated value of Ymax } + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + Ymax := Max(Y, 1, N); + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) and (Y^[K] < Ymax) then + begin + Inc(P); + X1^[P] := Log(X^[K]); + Y1^[P] := Log(Ymax / Y^[K] - 1.0); + W1^[P] := Sqr(Y^[K] * (1.0 - Y^[K] / Ymax)); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := Ymax; + B^[1] := Expo(- A^[0] / A^[1]); + B^[2] := - A^[1]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/niftiview7/tpmath/fitiexpo.pas b/niftiview7/tpmath/fitiexpo.pas new file mode 100755 index 0000000..153de74 --- /dev/null +++ b/niftiview7/tpmath/fitiexpo.pas @@ -0,0 +1,147 @@ +{ ********************************************************************** + * Unit FITIEXPO.PAS * + * Version 1.2 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the increasing exponential : + + y = A.[1 - exp(-k.x)] + + ********************************************************************** } + +unit FitIExpo; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A[1 - exp(-k.x)]'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'k'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = A B^[1] = k + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * (1.0 - Expo(- B^[1] * X)); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + E : Float; + begin + E := Expo(- B^[1] * X); { exp(-k.x) } + D^[0] := 1.0 - E; { dy/dA = 1 - exp(-k.x) } + D^[1] := B^[0] * X * E; { dy/dk = A.x.exp(-k.x) } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the increasing exponential by linear regression: + Ln(1 - y/A) = -k.x + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + Y1 : PVector; { Transformed ordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + { Estimation of A } + B^[0] := 1.1 * Max(Y, 1, N); + + for K := 1 to N do + begin + Y1^[K] := Log(1.0 - Y^[K] / B^[0]); + W1^[K] := Sqr(Y^[K] - B^[0]); + if Method = 1 then W1^[K] := W1^[K] * W^[K]; + end; + + ErrCode := WLinFit(X, Y1, W1, N, A, V); + + if ErrCode = MAT_OK then + B^[1] := - A^[1]; + + FitModel := ErrCode; + + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/niftiview7/tpmath/fitlin.pas b/niftiview7/tpmath/fitlin.pas new file mode 100755 index 0000000..415d7ff --- /dev/null +++ b/niftiview7/tpmath/fitlin.pas @@ -0,0 +1,102 @@ +{ ********************************************************************** + * Unit FITLIN.PAS * + * Version 1.0 * + * (c) J. Debord, April 1998 * + ********************************************************************** + This unit fits a linear function : + + y = a + b.x + + ********************************************************************** } + +unit FitLin; + +{$F+} + +interface + +uses + FMath, Matrices, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = a + b.x'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'a'; + 1 : ParamName := 'b'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = a B^[1] = b + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] + B^[1] * X; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Fit the straight line + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + V = variance-covariance matrix of the parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := LinFit(X, Y, N, B, V); + 1 : FitModel := WLinFit(X, Y, W, N, B, V); + end; + end; + +end. diff --git a/niftiview7/tpmath/fitlogis.pas b/niftiview7/tpmath/fitlogis.pas new file mode 100755 index 0000000..4452f4b --- /dev/null +++ b/niftiview7/tpmath/fitlogis.pas @@ -0,0 +1,224 @@ +{ ********************************************************************** + * Unit FITLOGIS.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the logistic function : + + B - A + y = A + ----------------- + 1 + exp(-a.x + b) + + ********************************************************************** } + +unit FitLogis; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + ConsTerm : Boolean = True; { Flags the presence of a constant term A } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + begin + if ConsTerm then + FuncName := 'y = A + (B - A) / [1 + exp(-a.x + b)]' + else + FuncName := 'y = B / [1 + exp(-a.x + b)]'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term A, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 3; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'B'; + 2 : ParamName := 'a'; + 3 : ParamName := 'b'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters, such that : + B^[0] = A B^[1] = B B^[2] = a B^[3] = b + -------------------------------------------------------------------- } + begin + if ConsTerm then + RegFunc := B^[0] + (B^[1] - B^[0]) / (1.0 + Expo(- B^[2] * X + B^[3])) + else + RegFunc := B^[1] / (1.0 + Expo(- B^[2] * X + B^[3])); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + Q, R : Float; + begin + Q := Expo(- B^[2] * X + B^[3]); { exp(-ax+b) } + R := 1.0 / (1.0 + Q); { 1 / [1 + exp(-ax+b)] } + + D^[0] := 1.0 - R; { dy/dA = 1 - 1 / [1 + exp(-ax+b)] } + D^[1] := R; { dy/dB = 1 / [1 + exp(-ax+b)] } + + { dy/db = (A-B).exp(-ax+b) / [1 + exp(-ax+b)]^2 } + D^[3] := (B^[0] - B^[1]) * Q * Sqr(R); + + { dy/da = (B-A).x.exp(-ax+b) / [1 + exp(-ax+b)]^2 } + D^[2] := - D^[3] * X; + end; + + procedure SortPoints(X, Y : PVector; N : Integer); + { ---------------------------------------------------------------------- + Sort points by increasing X values + ---------------------------------------------------------------------- } + var + I, J, K : Integer; + A : Float; + begin + for I := 1 to Pred(N) do + begin + K := I; + A := X^[I]; + for J := Succ(I) to N do + if X^[J] < A then + begin + K := J; + A := X^[J]; + end; + FSwap(X^[I], X^[K]); + FSwap(Y^[I], Y^[K]); + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a logistic function by linear regression: + Ln[(B - A)/(y - A) - 1] = -ax + b + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + XX : PVector; { Transformed X coordinates } + YY : PVector; { Transformed Y coordinates } + WW : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + D : Float; { B - A } + begin + DimVector(XX, N); + DimVector(YY, N); + DimVector(WW, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + SortPoints(X, Y, N); + + if ConsTerm then + B^[0] := Y^[1] + else + B^[0] := 0.0; + B^[1] := Y^[N]; + + P := 0; + D := B^[1] - B^[0]; + for K := 1 to N do + if (X^[K] > X^[1]) and (X^[K] < X^[N]) then + begin + Inc(P); + XX^[P] := X^[K]; + YY^[P] := Log(D / (Y^[K] - B^[0]) - 1.0); + WW^[P] := Sqr((Y^[K] - B^[0]) * (Y^[K] - B^[1]) / D); + if Method = 1 then WW^[P] := WW^[P] * W^[K]; + end; + + ErrCode := WLinFit(XX, YY, WW, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[2] := - A^[1]; + B^[3] := A^[0]; + end; + + FitModel := ErrCode; + + DelVector(XX, N); + DelVector(YY, N); + DelVector(WW, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit. + -------------------------------------------------------------------- + CstPar^[0] = 1 to include a constant term (A) + -------------------------------------------------------------------- } + begin + ConsTerm := (CstPar^[0] = 1); + end; + + end. diff --git a/niftiview7/tpmath/fitmich.pas b/niftiview7/tpmath/fitmich.pas new file mode 100755 index 0000000..1f80644 --- /dev/null +++ b/niftiview7/tpmath/fitmich.pas @@ -0,0 +1,152 @@ +{ ********************************************************************** + * Unit FITMICH.PAS * + * Version 1.0 * + * (c) J. Debord, April 1998 * + ********************************************************************** + This unit fits the Michaelis equation : + + Ymax . x + y = -------- + Km + x + + ********************************************************************** } + +unit FitMich; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = Ymax . x / (Km + x)'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'Ymax'; + 1 : ParamName := 'Km '; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = Ymax B^[1] = Km + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * X / (B^[1] + X); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + begin + D^[0] := Y / B^[0]; { dy/dYmax = x / (Km + x) } + D^[1] := - Y / (B^[1] + X); { dy/dKm = - Ymax.x / (Km + x)^2 } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the Michaelis equation by linear regression: + 1/y = 1/Ymax + (Km/Ymax) * (1/x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) then + begin + Inc(P); + X1^[P] := 1.0 / X^[K]; + Y1^[P] := 1.0 / Y^[K]; + W1^[P] := Sqr(Sqr(Y^[K])); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := 1.0 / A^[0]; + B^[1] := A^[1] / A^[0]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/niftiview7/tpmath/fitmult.pas b/niftiview7/tpmath/fitmult.pas new file mode 100755 index 0000000..4ac787b --- /dev/null +++ b/niftiview7/tpmath/fitmult.pas @@ -0,0 +1,140 @@ +{ ********************************************************************** + * Unit FITMULT.PAS * + * Version 1.1 * + * (c) J. Debord, October 1998 * + ********************************************************************** + This unit fits the multiple linear equation: + + y = b0 + b1.x1 + b2.x2 + ... + + ********************************************************************** } + +unit FitMult; + +{$F+} + +interface + +uses + FMath, Matrices, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X, B : PVector) : Float; + +function FitModel(Method : Integer; X : PMatrix; Y, W : PVector; + N : Integer; B : PVector; V : PMatrix) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Nvar : Integer = 2; { Number of independent variables } + ConsTerm : Boolean = True; { Flags the presence of a constant term b0 } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = '; + if ConsTerm then + Name := Name + 'b0 + '; + Name := Name + 'b1.x1'; + for I := 2 to Nvar do + begin + Str(I, S); + Name := Name + ' + b' + S + '.x' + S; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := Nvar; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + Str(I, S); + ParamName := 'b' + S; + end; + + function RegFunc(X, B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at observation X + B is the vector of parameters. + -------------------------------------------------------------------- } + var + I : Integer; + Y : Float; + begin + if ConsTerm then Y := B^[0] else Y := 0.0; + for I := 1 to Nvar do + Y := Y + B^[I] * X^[I]; + RegFunc := Y; + end; + + function FitModel(Method : Integer; X : PMatrix; Y, W : PVector; + N : Integer; B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Multiple linear regression + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X = matrix of independent variables + Y = vector of dependent variable + W = vector of weights + N = number of observations + Output : B = estimated regression parameters + V = variance-covariance matrix of parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := MulFit(X, Y, N, Nvar, ConsTerm, B, V); + 1 : FitModel := WMulFit(X, Y, W, N, Nvar, ConsTerm, B, V); + end; + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = number of independent variables + CstPar^[1] = 1 to include a constant term (b0) + -------------------------------------------------------------------- } + begin + Nvar := Round(CstPar^[0]); + ConsTerm := (CstPar^[1] = 1); + end; + +end. diff --git a/niftiview7/tpmath/fitpka.pas b/niftiview7/tpmath/fitpka.pas new file mode 100755 index 0000000..2781082 --- /dev/null +++ b/niftiview7/tpmath/fitpka.pas @@ -0,0 +1,163 @@ +{ ********************************************************************** + * Unit FITPKA.PAS * + * Version 1.1 * + * (c) J. Debord, July 1999 * + ********************************************************************** + This unit fits the acid/base titration function : + + B - A + y = A + ---------------- + 1 + 10^(pKa - x) + + where x is pH + y is some property (e.g. absorbance) which depends on the + ratio of the acidic and basic forms of the compound + A is the property for the pure acidic form + B is the property for the pure basic form + pKa is the acidity constant + ********************************************************************** } + +unit FitPKa; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A + (B - A) / [1 + 10^(pKa - x)]' + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term A, 1 otherwise) + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'B'; + 2 : ParamName := 'pKa'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + B^[0] = A B^[1] = B B^[2] = pKa + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] + (B^[1] - B^[0]) / (1.0 + Exp10(B^[2] - X)); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + Q, R : Float; + begin + Q := Exp10(B^[2] - X); { 10^(pKa - x) } + R := 1.0 / (1.0 + Q); { 1/[1 + 10^(pKa - x)] } + + D^[0] := 1.0 - R; { dy/dA = 1 - 1/[1 + 10^(pKa - x)] } + D^[1] := R; { dy/dB = 1/[1 + 10^(pKa - x)] } + + { dy/dpKa = (A-B).10^(pKa - x).Ln(10) / [1 + 10^(pKa - x)]^2 } + D^[2] := (B^[0] - B^[1]) * Q * LN10 * Sqr(R); + end; + + procedure SortPoints(X, Y : PVector; N : Integer); + { ---------------------------------------------------------------------- + Sort points by increasing X values + ---------------------------------------------------------------------- } + var + I, J, K : Integer; + A : Float; + begin + for I := 1 to Pred(N) do + begin + K := I; + A := X^[I]; + for J := Succ(I) to N do + if X^[J] < A then + begin + K := J; + A := X^[J]; + end; + FSwap(X^[I], X^[K]); + FSwap(Y^[I], Y^[K]); + end; + end; + + function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the acid/base titration function + -------------------------------------------------------------------- + Input : X, Y = point coordinates + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + K : Integer; { Loop variable } + Z : Float; { (A + B) / 2 } + begin + SortPoints(X, Y, N); + + B^[0] := Y^[1]; + B^[1] := Y^[N]; + + Z := 0.5 * (B^[0] + B^[1]); + for K := 2 to N - 1 do + if Y^[K] = Z then + B^[2] := X^[K] + else if ((Y^[K] < Z) and (Y^[K + 1] > Z)) or + ((Y^[K] > Z) and (Y^[K + 1] < Z)) then + B^[2] := 0.5 * (X^[K] + X^[K + 1]); + + FitModel := 0; + end; + +end. diff --git a/niftiview7/tpmath/fitpoly.pas b/niftiview7/tpmath/fitpoly.pas new file mode 100755 index 0000000..d88903d --- /dev/null +++ b/niftiview7/tpmath/fitpoly.pas @@ -0,0 +1,127 @@ +{ ********************************************************************** + * Unit FITPOLY.PAS * + * Version 1.2 * + * (c) J. Debord, March 1999 * + ********************************************************************** + This unit fits a polynomial : + + y = b0 + b1.x + b2.x^2 + ... + + ********************************************************************** } + +unit FitPoly; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Deg : Integer = 2; { Degree of polynomial } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = b0 + b1.x'; + for I := 2 to Deg do + begin + Str(I, S); + Name := Name + ' + b' + S + '.x^' + S; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted. + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted. + -------------------------------------------------------------------- } + begin + LastParam := Deg; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + var + S : String; + begin + Str(I, S); + ParamName := 'b' + S; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters (coefficients of polynomial). + -------------------------------------------------------------------- } + begin + RegFunc := Poly(X, B, Deg); + end; + + function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Fit of polynomial. + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + V = variance-covariance matrix of parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := PolFit(X, Y, N, Deg, B, V); + 1 : FitModel := WPolFit(X, Y, W, N, Deg, B, V); + end; + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit. + -------------------------------------------------------------------- + CstPar^[0] = Degree of polynomial + -------------------------------------------------------------------- } + var + D : Integer; + begin + D := Round(CstPar^[0]); + if D > 1 then Deg := D; + end; + +end. diff --git a/niftiview7/tpmath/fitpower.pas b/niftiview7/tpmath/fitpower.pas new file mode 100755 index 0000000..c4f5ca4 --- /dev/null +++ b/niftiview7/tpmath/fitpower.pas @@ -0,0 +1,150 @@ +{ ********************************************************************** + * Unit FITPOWER.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits a power function : + + y = A.x^n + + ********************************************************************** } + +unit FitPower; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + begin + FuncName := 'y = A.x^n'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted. + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted. + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'n'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters, such that : + + B^[0] = A B^[1] = n + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * Power(X, B^[1]); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + begin + D^[0] := Y / B^[0]; { dy/dA = x^n } + D^[1] := Y * Log(X); { dy/dk = A.x^n.Ln(x) } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a power function by linear regression: + Ln(y) = Ln(A) + n.Ln(x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) then + begin + Inc(P); + X1^[P] := Log(X^[K]); + Y1^[P] := Log(Y^[K]); + W1^[P] := Sqr(Y^[K]); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := Expo(A^[0]); + B^[1] := A^[1]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/niftiview7/tpmath/fmath.pas b/niftiview7/tpmath/fmath.pas new file mode 100755 index 0000000..9e33f72 --- /dev/null +++ b/niftiview7/tpmath/fmath.pas @@ -0,0 +1,2222 @@ +{ ********************************************************************** + * Unit FMATH.PAS * + * Version 2.4 * + * (c) J. Debord, June 2001 * + ********************************************************************** + This unit implements some mathematical functions in Pascal + ********************************************************************** + Notes: + + 1) The default real type is DOUBLE (8-byte real). Depending on the + compiler, other types may be selected by defining the symbols: + + ------------------------------------------------------- + Symbol Type TP-BP-Delphi FPC GPC + ------------------------------------------------------- + SINGLEREAL Single X X X + PASCALREAL Real X + EXTENDEDREAL Extended X X X + ------------------------------------------------------- + Note: "Real" is equivalent to "Double" in FPC and GPC + + 2) Error handling: The function MathError returns the error code from + the last function evaluation. It must be checked immediately after + a function call: + + Y := f(X); (* f is one of the functions of the library *) + if MathError = FN_OK then ... + + The possible error codes, and the default values attributed to the + function, are the following: + + ------------------------------------------------------------------ + Error code Value Significance Function default value + ------------------------------------------------------------------ + FN_OK 0 No error + FN_DOMAIN -1 Argument domain error 0 + FN_SING -2 Function singularity +/- MAXNUM + FN_OVERFLOW -3 Overflow range error MAXNUM + FN_UNDERFLOW -4 Underflow range error 0 + ------------------------------------------------------------------ + + where MAXNUM is a constant defining the highest number which may be + represented within the chosen floating point type. + + The standard functions Exp and Ln have been redefined according to + the above conventions as Expo and Log. + + 3) Assembler functions: some functions are written in assembler. There + are two versions: + + * One for BP 7 or Delphi 1 with a 387, 486 or Pentium processor. + This version may be selected by defining the symbol CPU387 + + * The other for FPC with a Pentium II or Pentium III processor. + This version may be selected by defining the symbol CPUP2 + Units and programs must be compiled with the options -Si + and -Rintel (e.g. ppc386 -Si -Rintel -dCPUP2 fmath) + + Once you have selected a version you have two possibilities: + + * Call the Pascal functions (e.g. Expo, ArcSin...). This will + provide some acceleration while keeping the error handling. + + * Call the assembler functions directly (e.g. fExp, fArcSin...) + This will provide further acceleration but without error handling. + Thus it is the responsibility of the calling program to check the + arguments passed to the function. See the interface files + MATH387.INT and MATHP2.INT for a list of available functions. + + ********************************************************************** } + +unit FMath; + +interface + +{ ---------------------------------------------------------------------- + Floating point type (Default = Double) + ---------------------------------------------------------------------- } + +{$IFDEF __GPC__} + {$UNDEF PASCALREAL} +{$ENDIF} + +{$IFDEF FPK} + {$UNDEF PASCALREAL} +{$ENDIF} + +{$IFDEF PASCALREAL} + {$IFDEF VER120} + type Float = Real48; { Delphi 4 } + {$ELSE} + type Float = Real; + {$ENDIF} +{$ELSE} +{$IFDEF SINGLEREAL} + type Float = Single; +{$ELSE} +{$IFDEF EXTENDEDREAL} + type Float = Extended; +{$ELSE} + {$DEFINE DOUBLEREAL} + type Float = Double; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Mathematical constants + ---------------------------------------------------------------------- } + +const + PI = 3.14159265358979323846; { Pi } + LN2 = 0.69314718055994530942; { Ln(2) } + LN10 = 2.30258509299404568402; { Ln(10) } + LNPI = 1.14472988584940017414; { Ln(Pi) } + INVLN2 = 1.44269504088896340736; { 1/Ln(2) } + INVLN10 = 0.43429448190325182765; { 1/Ln(10) } + TWOPI = 6.28318530717958647693; { 2*Pi } + PIDIV2 = 1.57079632679489661923; { Pi/2 } + SQRTPI = 1.77245385090551602730; { Sqrt(Pi) } + SQRT2PI = 2.50662827463100050242; { Sqrt(2*Pi) } + INVSQRT2PI = 0.39894228040143267794; { 1/Sqrt(2*Pi) } + LNSQRT2PI = 0.91893853320467274178; { Ln(Sqrt(2*Pi)) } + LN2PIDIV2 = 0.91893853320467274178; { Ln(2*Pi)/2 } + SQRT2 = 1.41421356237309504880; { Sqrt(2) } + SQRT2DIV2 = 0.70710678118654752440; { Sqrt(2)/2 } + GOLD = 1.61803398874989484821; { Golden Mean = (1 + Sqrt(5))/2 } + CGOLD = 0.38196601125010515179; { 2 - GOLD } + +{ ---------------------------------------------------------------------- + Machine-dependent constants + ---------------------------------------------------------------------- } + +{$IFDEF SINGLEREAL} +const + MACHEP = 1.192093E-7; { Floating point precision: 2^(-23) } + MAXNUM = 3.402823E+38; { Max. floating point number: 2^128 } + MINNUM = 1.175495E-38; { Min. floating point number: 2^(-126) } + MAXLOG = 88.72283; { Max. argument for Exp = Ln(MAXNUM) } + MINLOG = -87.33655; { Min. argument for Exp = Ln(MINNUM) } + MAXFAC = 33; { Max. argument for Factorial } + MAXGAM = 34.648; { Max. argument for Gamma } + MAXLGM = 1.0383E+36; { Max. argument for LnGamma } +{$ELSE} +{$IFDEF DOUBLEREAL} +const + MACHEP = 2.220446049250313E-16; { 2^(-52) } + MAXNUM = 1.797693134862315E+308; { 2^1024 } + MINNUM = 2.225073858507202E-308; { 2^(-1022) } + MAXLOG = 709.7827128933840; + MINLOG = -708.3964185322641; + MAXFAC = 170; + MAXGAM = 171.624376956302; + MAXLGM = 2.556348E+305; +{$ELSE} +{$IFDEF EXTENDEDREAL} +const + MACHEP = 1.08420217248550444E-19; { 2^(-63) } + MAXNUM = 1.18973149535723103E+4932; { 2^16384 } + MINNUM = 3.36210314311209558E-4932; { 2^(-16382) } + MAXLOG = 11356.5234062941439; + MINLOG = - 11355.137111933024; + MAXFAC = 1754; + MAXGAM = 1755.455; + MAXLGM = 1.04848146839019521E+4928; +{$ELSE} +{$IFDEF PASCALREAL} +const + MACHEP = 1.818989404E-12; { 2^(-39) } + MAXNUM = 4.253529586E+37; { 2^126 } + MINNUM = 2.350988703E-38; { 2^(-125) } + MAXLOG = 8.664339757E+01; + MINLOG = - 4.253529586E+01; + MAXFAC = 33; + MAXGAM = 34.64809785; + MAXLGM = 1.038324114E+36; +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Error codes for mathematical functions + ---------------------------------------------------------------------- } + +const + FN_OK = 0; { No error } + FN_DOMAIN = - 1; { Argument domain error } + FN_SING = - 2; { Function singularity } + FN_OVERFLOW = - 3; { Overflow range error } + FN_UNDERFLOW = - 4; { Underflow range error } + FN_TLOSS = - 5; { Total loss of precision } + FN_PLOSS = - 6; { Partial loss of precision } + +{ ---------------------------------------------------------------------- + Global variables and constants + ---------------------------------------------------------------------- } + +const + NFACT = 33; { The factorials of the first NFACT integers are stored + in a table } +var + MathErr : Integer; { Error code from the latest function evaluation } + + FactArray : array[0..NFACT] of Float; { Table of factorials } + +{ ---------------------------------------------------------------------- + Functional type + ---------------------------------------------------------------------- } + +type + TFunc = function(X : Float) : Float; + +{ ---------------------------------------------------------------------- + Error handling function + ---------------------------------------------------------------------- } + +function MathError : Integer; { Error code from the last function call } + +{ ---------------------------------------------------------------------- + Minimum, maximum, sign and exchange + ---------------------------------------------------------------------- } + +function FMin(X, Y : Float) : Float; { Minimum of 2 reals } +function FMax(X, Y : Float) : Float; { Maximum of 2 reals } +function IMin(X, Y : Integer) : Integer; { Minimum of 2 integers } +function IMax(X, Y : Integer) : Integer; { Maximum of 2 integers } +function Sgn(X : Float) : Integer; { Sign (returns 1 if X = 0) } +function Sgn0(X : Float) : Integer; { Sign (returns 0 if X = 0) } + +procedure FSwap(var X, Y : Float); { Exchange 2 reals } +procedure ISwap(var X, Y : Integer); { Exchange 2 integers } + +{ ---------------------------------------------------------------------- + Assembler functions + ---------------------------------------------------------------------- } + +{$IFDEF CPU387} + {$UNDEF CPUP2} + {$I MATH387.INT} +{$ENDIF} + +{$IFDEF CPUP2} + {$UNDEF CPU387} + {$I MATHP2.INT} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Sign, logarithms, exponentials and power + ---------------------------------------------------------------------- } + +function Expo(X : Float) : Float; { Exponential } +function Exp2(X : Float) : Float; { 2^X } +function Exp10(X : Float) : Float; { 10^X } +function Log(X : Float) : Float; { Natural log } +function Log2(X : Float) : Float; { Log, base 2 } +function Log10(X : Float) : Float; { Decimal log } +function LogA(X, A : Float) : Float; { Log, base A } +function IntPower(X : Float; N : Integer) : Float; { X^N } +function Power(X, Y : Float) : Float; { X^Y, X >= 0 } +function Pythag(X, Y : Float) : Float; { Sqrt(X^2 + Y^2) } + +{ ---------------------------------------------------------------------- + Trigonometric and inverse trigonometric functions + ---------------------------------------------------------------------- } + +function FixAngle(Theta : Float) : Float; { Set Theta in -Pi..Pi } +function Tan(X : Float) : Float; { Tangent } +function ArcSin(X : Float) : Float; { Arc sinus } +function ArcCos(X : Float) : Float; { Arc cosinus } +function ArcTan2(Y, X : Float) : Float; { Angle (Ox, OM) with M(X,Y) } + +procedure SinCos(X : Float; var SinX, CosX : Float); { Sin & Cos } + +{ ---------------------------------------------------------------------- + Hyperbolic and inverse hyperbolic functions + ---------------------------------------------------------------------- } + +function Sinh(X : Float) : Float; { Hyperbolic sine } +function Cosh(X : Float) : Float; { Hyperbolic cosine } +function Tanh(X : Float) : Float; { Hyperbolic tangent } +function ArcSinh(X : Float) : Float; { Inverse hyperbolic sine } +function ArcCosh(X : Float) : Float; { Inverse hyperbolic cosine } +function ArcTanh(X : Float) : Float; { Inverse hyperbolic tangent } + +procedure SinhCosh(X : Float; var SinhX, CoshX : Float); { Sinh & Cosh } + +{ ---------------------------------------------------------------------- + Special functions + ---------------------------------------------------------------------- } + +function Fact(N : Integer) : Float; { Factorial } +function Binomial(N, K : Integer) : Float; { Binomial coef. C(N,K) } +function Gamma(X : Float) : Float; { Gamma function } +function SgnGamma(X : Float) : Integer; { Sign of Gamma function } +function LnGamma(X : Float) : Float; { Log(|Gamma(X)|) } +function IGamma(A, X : Float) : Float; { Incomplete Gamma function } +function JGamma(A, X : Float) : Float; { Complement of IGamma } +function Beta(X, Y : Float) : Float; { Beta function } +function IBeta(A, B, X : Float) : Float; { Incomplete Beta function } +function Erf(X : Float) : Float; { Error function } +function Erfc(X : Float) : Float; { Complement of Erf } + +{ ---------------------------------------------------------------------- + Binomial distribution with probability P and number of repetitions N + ---------------------------------------------------------------------- } + +function PBinom(N : Integer; P : Float; K : Integer) : Float; { Prob(X = K) } +function FBinom(N : Integer; P : Float; K : Integer) : Float; { Prob(X <= K) } + +{ ---------------------------------------------------------------------- + Poisson distribution with mean Mu + ---------------------------------------------------------------------- } + +function PPoisson(Mu : Float; K : Integer) : Float; { Prob(X = K) } +function FPoisson(Mu : Float; K : Integer) : Float; { Prob(X <= K) } + +{ ---------------------------------------------------------------------- + Standard normal distribution + ---------------------------------------------------------------------- } + +function DNorm(X : Float) : Float; { Density of standard normal } +function FNorm(X : Float) : Float; { Prob(U <= X) } +function PNorm(X : Float) : Float; { Prob(|U| >= |X|) } +function InvNorm(P : Float) : Float; { Inverse of FNorm : returns X + such that Prob(U <= X) = P} + +{ ---------------------------------------------------------------------- + Student distribution with Nu d.o.f. + ---------------------------------------------------------------------- } + +function DStudent(Nu : Integer; X : Float) : Float; { Density of t } +function FStudent(Nu : Integer; X : Float) : Float; { Prob(t <= X) } +function PStudent(Nu : Integer; X : Float) : Float; { Prob(|t| >= |X|) } + +{ ---------------------------------------------------------------------- + Khi-2 distribution with Nu d.o.f. + ---------------------------------------------------------------------- } + +function DKhi2(Nu : Integer; X : Float) : Float; { Density of Khi2 } +function FKhi2(Nu : Integer; X : Float) : Float; { Prob(Khi2 <= X) } +function PKhi2(Nu : Integer; X : Float) : Float; { Prob(Khi2 >= X) } + +{ ---------------------------------------------------------------------- + Fisher-Snedecor distribution with Nu1 and Nu2 d.o.f. + ---------------------------------------------------------------------- } + +function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Density of F } +function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Prob(F <= X) } +function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Prob(F >= X) } + +{ ---------------------------------------------------------------------- + Exponential distribution + ---------------------------------------------------------------------- } + +function DExpo(A, X : Float) : Float; { Density of exponential distrib. } +function FExpo(A, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Beta distribution + ---------------------------------------------------------------------- } + +function DBeta(A, B, X : Float) : Float; { Density of Beta distribution } +function FBeta(A, B, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Gamma distribution + ---------------------------------------------------------------------- } + +function DGamma(A, B, X : Float) : Float; { Density of Gamma distribution } +function FGamma(A, B, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Random numbers + ---------------------------------------------------------------------- } + +procedure RMarIn(Seed1, Seed2 : Integer); +{ Initializes the random number generator. + The default initialization corresponds to RMarIn(1802, 9373) } + +function IRanMar : LongInt; +{ Returns a 32 bit random number in [ -2,147,483,648 ; 2,147,483,647 ] } + +function RanMar : Float; +{ Returns a random number in [0, 1[ } + +function RanGaussStd : Float; +{ Returns a random number from the standard normal distribution + (i.e. the Gaussian distribution with zero mean and unit variance) } + +function RanGauss(Mu, Sigma : Float) : Float; +{ Returns a random number from a Gaussian distribution + with mean Mu and standard deviation Sigma } + +{ ********************************************************************** } + +implementation + +{ ---------------------------------------------------------------------- + Error handling functions + ---------------------------------------------------------------------- } + + function DefaultVal(ErrCode : Integer) : Float; + { Sets the global variable MathErr and the function default value + according to the error code } + begin + MathErr := ErrCode; + case ErrCode of + FN_DOMAIN : DefaultVal := 0.0; + FN_SING : DefaultVal := MAXNUM; + FN_OVERFLOW : DefaultVal := MAXNUM; + FN_UNDERFLOW : DefaultVal := 0.0; + else + DefaultVal := 0.0; + end; + end; + + function MathError : Integer; + begin + MathError := MathErr; + end; + +{ ---------------------------------------------------------------------- + Minimum, maximum and sign + ---------------------------------------------------------------------- } + + function FMin(X, Y : Float) : Float; + begin + if X <= Y then + FMin := X + else + FMin := Y; + end; + + function FMax(X, Y : Float) : Float; + begin + if X >= Y then + FMax := X + else + FMax := Y; + end; + + function IMin(X, Y : Integer) : Integer; + begin + if X <= Y then + IMin := X + else + IMin := Y; + end; + + function IMax(X, Y : Integer) : Integer; + begin + if X >= Y then + IMax := X + else + IMax := Y; + end; + + procedure FSwap(var X, Y : Float); + var + Temp : Float; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + procedure ISwap(var X, Y : Integer); + var + Temp : Integer; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + function Sgn(X : Float) : Integer; + begin + if X >= 0.0 then + Sgn := 1 + else + Sgn := - 1; + end; + + function Sgn0(X : Float) : Integer; + begin + if X > 0.0 then + Sgn0 := 1 + else if X = 0.0 then + Sgn0 := 0 + else + Sgn0 := - 1; + end; + +{ ---------------------------------------------------------------------- + Assembler functions + ---------------------------------------------------------------------- } + +{$IFDEF CPU387} + {$I MATH387.INC} + {$DEFINE USE_ASM} +{$ENDIF} + +{$IFDEF CPUP2} + {$I MATHP2.INC} + {$DEFINE USE_ASM} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Elementary functions + ---------------------------------------------------------------------- } + + function Expo(X : Float) : Float; + begin + MathErr := FN_OK; + if X < MINLOG then + Expo := DefaultVal(FN_UNDERFLOW) + else if X > MAXLOG then + Expo := DefaultVal(FN_OVERFLOW) + else + Expo := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + end; + + function Exp2(X : Float) : Float; + var + XLn2 : Float; + begin + MathErr := FN_OK; + XLn2 := X * LN2; + if XLn2 < MINLOG then + Exp2 := DefaultVal(FN_UNDERFLOW) + else if XLn2 > MAXLOG then + Exp2 := DefaultVal(FN_OVERFLOW) + else + Exp2 := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(XLn2); + end; + + function Exp10(X : Float) : Float; + var + XLn10 : Float; + begin + MathErr := FN_OK; + XLn10 := X * LN10; + if XLn10 < MINLOG then + Exp10 := DefaultVal(FN_UNDERFLOW) + else if XLn10 > MAXLOG then + Exp10 := DefaultVal(FN_OVERFLOW) + else + Exp10 := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(XLn10); + end; + + function Log(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log := DefaultVal(FN_SING) + else + Log := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + end; + + function Log10(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log10 := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log10 := DefaultVal(FN_SING) + else + Log10 := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * INVLN10; + end; + + function Log2(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log2 := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log2 := DefaultVal(FN_SING) + else + Log2 := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * INVLN2; + end; + + function LogA(X, A : Float) : Float; + begin + MathErr := FN_OK; + if (X < 0.0) or (A <= 0.0) or (A = 1.0) then + LogA := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + LogA := Sgn(1.0 - A) * DefaultVal(FN_SING) + else + {$IFDEF USE_ASM} + LogA := fLn(X) / fLn(A); + {$ELSE} + LogA := Ln(X) / Ln(A); + {$ENDIF} + end; + + function IntPower(X : Float; N : Integer) : Float; + { Computes X^N by repeated multiplications } + var + M : Integer; + T : Float; + begin + MathErr := FN_OK; + + if X = 0.0 then + begin + if N = 0 then { 0^0 = lim x^x = 1 } + IntPower := 1.0 { x->0 } + else if N > 0 then + IntPower := 0.0 { 0^N = 0 } + else + IntPower := DefaultVal(FN_SING); + Exit; + end; + + if N = 0 then + begin + IntPower := 1.0; + Exit; + end; + + { Legendre's algorithm for minimizing the number of multiplications } + T := 1.0; + M := Abs(N); + repeat + if Odd(M) then + begin + Dec(M); + T := T * X; + end + else + begin + M := M div 2; + X := Sqr(X); + end; + until M = 0; + + if N > 0 then IntPower := T else IntPower := 1.0 / T; + end; + + function Power(X, Y : Float) : Float; + { Computes X^Y = Exp(Y * Ln(X)), for X >= 0 } + var + YLnX : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + begin + Power := DefaultVal(FN_DOMAIN); + Exit; + end; + + if X = 0.0 then + begin + if Y = 0.0 then { 0^0 = lim x^x = 1 } + Power := 1.0 { x->0 } + else if Y > 0.0 then + Power := 0.0 { 0^Y = 0 } + else + Power := DefaultVal(FN_SING); + Exit; + end; + + if Y = 0.0 then + begin + Power := 1.0; + Exit; + end; + + YLnX := Y * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + + if YLnX < MINLOG then + Power := DefaultVal(FN_UNDERFLOW) + else if YLnX > MAXLOG then + Power := DefaultVal(FN_OVERFLOW) + else + Power := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(YLnX); + end; + + function Pythag(X, Y : Float) : Float; + { Computes Sqrt(X^2 + Y^2) without destructive underflow or overflow } + var + AbsX, AbsY : Float; + begin + MathErr := FN_OK; + AbsX := Abs(X); + AbsY := Abs(Y); + if AbsX > AbsY then + Pythag := AbsX * Sqrt(1.0 + Sqr(AbsY / AbsX)) + else if AbsY = 0.0 then + Pythag := 0.0 + else + Pythag := AbsY * Sqrt(1.0 + Sqr(AbsX / AbsY)); + end; + + procedure SinCos(X : Float; var SinX, CosX : Float); + begin + MathErr := FN_OK; + SinX := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(X); + CosX := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(X); + end; + + function FixAngle(Theta : Float) : Float; + begin + MathErr := FN_OK; + while Theta > PI do + Theta := Theta - TWOPI; + while Theta <= - PI do + Theta := Theta + TWOPI; + FixAngle := Theta; + end; + + function Tan(X : Float) : Float; + var + SinX, CosX : Float; + begin + MathErr := FN_OK; + SinX := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(X); + CosX := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(X); + if CosX = 0.0 then + Tan := Sgn(SinX) * DefaultVal(FN_SING) + else + Tan := SinX / CosX; + end; + + function ArcSin(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcSin := DefaultVal(FN_DOMAIN) + else if X = 1.0 then + ArcSin := PIDIV2 + else if X = - 1.0 then + ArcSin := - PIDIV2 + else + ArcSin := {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcCos(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcCos := DefaultVal(FN_DOMAIN) + else if X = 1.0 then + ArcCos := 0.0 + else if X = - 1.0 then + ArcCos := PI + else + ArcCos := PIDIV2 - {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcTan2(Y, X : Float) : Float; + var + Theta : Float; + begin + MathErr := FN_OK; + if X = 0.0 then + if Y = 0.0 then + ArcTan2 := 0.0 + else if Y > 0.0 then + ArcTan2 := PIDIV2 + else + ArcTan2 := - PIDIV2 + else + begin + { 4th/1st quadrant -PI/2..PI/2 } + Theta := {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(Y / X); + + { 2nd/3rd quadrants } + if X < 0.0 then + if Y >= 0.0 then + Theta := Theta + PI { 2nd quadrant: PI/2..PI } + else + Theta := Theta - PI; { 3rd quadrant: -PI..-PI/2 } + ArcTan2 := Theta; + end; + end; + +{ ---------------------------------------------------------------------- + Hyperbolic functions + ---------------------------------------------------------------------- } + + function Sinh(X : Float) : Float; + var + ExpX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + Sinh := Sgn(X) * DefaultVal(FN_OVERFLOW) + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + Sinh := 0.5 * (ExpX - 1.0 / ExpX); + end; + end; + + function Cosh(X : Float) : Float; + var + ExpX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + Cosh := DefaultVal(FN_OVERFLOW) + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + Cosh := 0.5 * (ExpX + 1.0 / ExpX); + end; + end; + + procedure SinhCosh(X : Float; var SinhX, CoshX : Float); + var + ExpX, ExpMinusX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + begin + CoshX := DefaultVal(FN_OVERFLOW); + SinhX := Sgn(X) * CoshX; + end + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + ExpMinusX := 1.0 / ExpX; + SinhX := 0.5 * (ExpX - ExpMinusX); + CoshX := 0.5 * (ExpX + ExpMinusX); + end; + end; + + function Tanh(X : Float) : Float; + var + SinhX, CoshX : Float; + begin + SinhCosh(X, SinhX, CoshX); + Tanh := SinhX / CoshX; + end; + + function ArcSinh(X : Float) : Float; + begin + MathErr := FN_OK; + ArcSinh := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X + Sqrt(Sqr(X) + 1.0)); + end; + + function ArcCosh(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 1.0 then + ArcCosh := DefaultVal(FN_DOMAIN) + else + ArcCosh := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X + Sqrt(Sqr(X) - 1.0)); + end; + + function ArcTanh(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcTanh := DefaultVal(FN_DOMAIN) + else if (X = - 1.0) or (X = 1.0) then + ArcTanh := Sgn(X) * DefaultVal(FN_SING) + else + ArcTanh := 0.5 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}((1.0 + X) / (1.0 - X)); + end; + +{ ---------------------------------------------------------------------- + Special functions (translated from Cephes math library by S. Moshier: + http://www.netlib.org/cephes) + ---------------------------------------------------------------------- } + +const { Used by IGamma and IBeta } + BIG = 9.223372036854775808E18; + BIGINV = 1.084202172485504434007E-19; + +type + TabCoef = array[0..9] of Float; + + function PolEvl(var X : Float; var Coef : TabCoef; N : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates polynomial of degree N: + + 2 N + y = C + C x + C x +...+ C x + 0 1 2 N + + Coefficients are stored in reverse order: + + Coef[0] = C , ..., Coef[N] = C + N 0 + + The function P1Evl() assumes that Coef[N] = 1.0 and is + omitted from the array. Its calling arguments are + otherwise the same as PolEvl(). + ---------------------------------------------------------------------- } + var + Ans : Float; + I : Integer; + begin + Ans := Coef[0]; + for I := 1 to N do + Ans := Ans * X + Coef[I]; + PolEvl := Ans; + end; + + function P1Evl(var X : Float; var Coef : TabCoef; N : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluate polynomial when coefficient of X is 1.0. + Otherwise same as PolEvl. + ---------------------------------------------------------------------- } + var + Ans : Float; + I : Integer; + begin + Ans := X + Coef[0]; + for I := 1 to N - 1 do + Ans := Ans * X + Coef[I]; + P1Evl := Ans; + end; + + function SgnGamma(X : Float) : Integer; + begin + if X > 0.0 then + SgnGamma := 1 + else if Odd(Trunc(Abs(X))) then + SgnGamma := 1 + else + SgnGamma := - 1; + end; + + function Stirf(X : Float) : Float; + { Stirling's formula for the gamma function + Gamma(x) = Sqrt(2*Pi) x^(x-.5) exp(-x) (1 + 1/x P(1/x)) + where P(x) is a polynomial } + const + STIR : TabCoef = ( + 7.147391378143610789273E-4, + - 2.363848809501759061727E-5, + - 5.950237554056330156018E-4, + 6.989332260623193171870E-5, + 7.840334842744753003862E-4, + - 2.294719747873185405699E-4, + - 2.681327161876304418288E-3, + 3.472222222230075327854E-3, + 8.333333333333331800504E-2, + 0); + + var + W, P : Float; + begin + W := 1.0 / X; + if X > 1024.0 then + begin + P := 6.97281375836585777429E-5 * W + 7.84039221720066627474E-4; + P := P * W - 2.29472093621399176955E-4; + P := P * W - 2.68132716049382716049E-3; + P := P * W + 3.47222222222222222222E-3; + P := P * W + 8.33333333333333333333E-2; + end + else + P := PolEvl(W, STIR, 8); + {$IFDEF USE_ASM} + Stirf := SQRT2PI * fExp((X - 0.5) * fLn(X) - X) * (1.0 + W * P); + {$ELSE} + Stirf := SQRT2PI * Exp((X - 0.5) * Ln(X) - X) * (1.0 + W * P); + {$ENDIF} + end; + + function GamSmall(X1, Z : Float) : Float; + { Gamma function for small values of the argument } + const + S : TabCoef = ( + - 1.193945051381510095614E-3, + 7.220599478036909672331E-3, + - 9.622023360406271645744E-3, + - 4.219773360705915470089E-2, + 1.665386113720805206758E-1, + - 4.200263503403344054473E-2, + - 6.558780715202540684668E-1, + 5.772156649015328608253E-1, + 1.000000000000000000000E0, + 0); + + SN : TabCoef = ( + 1.133374167243894382010E-3, + 7.220837261893170325704E-3, + 9.621911155035976733706E-3, + - 4.219773343731191721664E-2, + - 1.665386113944413519335E-1, + - 4.200263503402112910504E-2, + 6.558780715202536547116E-1, + 5.772156649015328608727E-1, + - 1.000000000000000000000E0, + 0); + + var + P : Float; + begin + if X1 = 0.0 then + begin + GamSmall := DefaultVal(FN_SING); + Exit; + end; + if X1 < 0.0 then + begin + X1 := - X1; + P := PolEvl(X1, SN, 8); + end + else + P := PolEvl(X1, S, 8); + GamSmall := Z / (X1 * P); + end; + + function StirfL(X : Float) : Float; + { Approximate Ln(Gamma) by Stirling's formula, for X >= 13 } + const + P : TabCoef = ( + 4.885026142432270781165E-3, + - 1.880801938119376907179E-3, + 8.412723297322498080632E-4, + - 5.952345851765688514613E-4, + 7.936507795855070755671E-4, + - 2.777777777750349603440E-3, + 8.333333333333331447505E-2, + 0, 0, 0); + + var + Q, W : Float; + begin + Q := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * (X - 0.5) - X; + Q := Q + LNSQRT2PI; + if X > 1.0E+10 then + StirfL := Q + else + begin + W := 1.0 / Sqr(X); + StirfL := Q + PolEvl(W, P, 6) / X; + end; + end; + + function Gamma(X : Float) : Float; + const + P : TabCoef = ( + 4.212760487471622013093E-5, + 4.542931960608009155600E-4, + 4.092666828394035500949E-3, + 2.385363243461108252554E-2, + 1.113062816019361559013E-1, + 3.629515436640239168939E-1, + 8.378004301573126728826E-1, + 1.000000000000000000009E0, + 0, 0); + + Q : TabCoef = ( + - 1.397148517476170440917E-5, + 2.346584059160635244282E-4, + - 1.237799246653152231188E-3, + - 7.955933682494738320586E-4, + 2.773706565840072979165E-2, + - 4.633887671244534213831E-2, + - 2.243510905670329164562E-1, + 4.150160950588455434583E-1, + 9.999999999999999999908E-1, + 0); + + var + SgnGam, N : Integer; + A, X1, Z : Float; + begin + MathErr := FN_OK; + SgnGam := SgnGamma(X); + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + Gamma := SgnGam * DefaultVal(FN_SING); + Exit; + end; + + if X > MAXGAM then + begin + Gamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + + A := Abs(X); + if A > 13.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := A - N; + end; + Z := Abs(A * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(PI * Z)) * Stirf(A); + if Z <= PI / MAXNUM then + begin + Gamma := SgnGam * DefaultVal(FN_OVERFLOW); + Exit; + end; + Z := PI / Z; + end + else + Z := Stirf(X); + Gamma := SgnGam * Z; + end + else + begin + Z := 1.0; + X1 := X; + while X1 >= 3.0 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < - 0.03125 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if X1 <= 0.03125 then + Gamma := GamSmall(X1, Z) + else + begin + while X1 < 2.0 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if (X1 = 2.0) or (X1 = 3.0) then + Gamma := Z + else + begin + X1 := X1 - 2.0; + Gamma := Z * PolEvl(X1, P, 7) / PolEvl(X1, Q, 8); + end; + end; + end; + end; + + function LnGamma(X : Float) : Float; + const + P : TabCoef = ( + - 2.163690827643812857640E3, + - 8.723871522843511459790E4, + - 1.104326814691464261197E6, + - 6.111225012005214299996E6, + - 1.625568062543700591014E7, + - 2.003937418103815175475E7, + - 8.875666783650703802159E6, + 0, 0, 0); + + Q : TabCoef = ( + - 5.139481484435370143617E2, + - 3.403570840534304670537E4, + - 6.227441164066219501697E5, + - 4.814940379411882186630E6, + - 1.785433287045078156959E7, + - 3.138646407656182662088E7, + - 2.099336717757895876142E7, + 0, 0, 0); + + var + N : Integer; + A, X1, Z : Float; + begin + MathErr := FN_OK; + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + LnGamma := DefaultVal(FN_SING); + Exit; + end; + + if X > MAXLGM then + begin + LnGamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + + A := Abs(X); + if A > 34.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := N - A; + end; + Z := A * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(PI * Z); + if Z = 0.0 then + begin + LnGamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + Z := LNPI - {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z) - StirfL(A); + end + else + Z := StirfL(X); + LnGamma := Z; + end + else if X < 13.0 then + begin + Z := 1.0; + X1 := X; + while X1 >= 3 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < 2.0 do + begin + if Abs(X1) <= 0.03125 then + begin + LnGamma := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Abs(GamSmall(X1, Z))); + Exit; + end; + Z := Z / X1; + X1 := X1 + 1.0; + end; + if Z < 0.0 then Z := - Z; + if X1 = 2.0 then + LnGamma := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z) + else + begin + X1 := X1 - 2.0; + LnGamma := X1 * PolEvl(X1, P, 6) / P1Evl(X1, Q, 7) + + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z); + end; + end + else + LnGamma := StirfL(X); + end; + + function IGamma(A, X : Float) : Float; + var + Ans, Ax, C, R : Float; + begin + MathErr := FN_OK; + + if (X <= 0.0) or (A <= 0.0) then + begin + IGamma := 0.0; + Exit; + end; + + if (X > 1.0) and (X > A) then + begin + IGamma := 1.0 - JGamma(A, X); + Exit; + end; + + Ax := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - X - LnGamma(A); + if Ax < MINLOG then + begin + IGamma := DefaultVal(FN_UNDERFLOW); + Exit; + end; + + Ax := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Ax); + + { power series } + R := A; + C := 1.0; + Ans := 1.0; + + repeat + R := R + 1.0; + C := C * X / R; + Ans := Ans + C; + until C / Ans <= MACHEP; + + IGamma := Ans * Ax / A; + end; + + function JGamma(A, X : Float) : Float; + var + Ans, C, Yc, Ax, Y, Z, R, T, + Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2 : Float; + begin + MathErr := FN_OK; + + if (X <= 0.0) or (A <= 0.0) then + begin + JGamma := 1.0; + Exit; + end; + + if (X < 1.0) or (X < A) then + begin + JGamma := 1.0 - IGamma(A, X); + Exit; + end; + + Ax := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - X - LnGamma(A); + + if Ax < MINLOG then + begin + JGamma := DefaultVal(FN_UNDERFLOW); + Exit; + end; + + Ax := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Ax); + + { continued fraction } + Y := 1.0 - A; + Z := X + Y + 1.0; + C := 0.0; + Pkm2 := 1.0; + Qkm2 := X; + Pkm1 := X + 1.0; + Qkm1 := Z * X; + Ans := Pkm1 / Qkm1; + + repeat + C := C + 1.0; + Y := Y + 1.0; + Z := Z + 2.0; + Yc := Y * C; + Pk := Pkm1 * Z - Pkm2 * Yc; + Qk := Qkm1 * Z - Qkm2 * Yc; + if Qk <> 0.0 then + begin + R := Pk / Qk; + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + if Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 / BIG; + Pkm1 := Pkm1 / BIG; + Qkm2 := Qkm2 / BIG; + Qkm1 := Qkm1 / BIG; + end; + until T <= MACHEP; + + JGamma := Ans * Ax; + end; + + function Fact(N : Integer) : Float; + begin + MathErr := FN_OK; + if N < 0 then + Fact := DefaultVal(FN_DOMAIN) + else if N > MAXFAC then + Fact := DefaultVal(FN_OVERFLOW) + else if N <= NFACT then + Fact := FactArray[N] + else + Fact := Gamma(N + 1); + end; + + function Binomial(N, K : Integer) : Float; + var + I, N1 : Integer; + Prod : Float; + begin + MathErr := FN_OK; + if K < 0 then + Binomial := 0.0 + else if (K = 0) or (K = N) then + Binomial := 1.0 + else if (K = 1) or (K = N - 1) then + Binomial := N + else + begin + if K > N - K then K := N - K; + N1 := Succ(N); + Prod := N; + for I := 2 to K do + Prod := Prod * (Int(N1 - I) / Int(I)); + Binomial := Int(0.5 + Prod); + end; + end; + + function Beta(X, Y : Float) : Float; + { Computes Beta(X, Y) = Gamma(X) * Gamma(Y) / Gamma(X + Y) } + var + Lx, Ly, Lxy : Float; + SgnBeta : Integer; + begin + MathErr := FN_OK; + SgnBeta := SgnGamma(X) * SgnGamma(Y) * SgnGamma(X + Y); + Lxy := LnGamma(X + Y); + if MathErr <> FN_OK then + begin + Beta := 0.0; + Exit; + end; + Lx := LnGamma(X); + if MathErr <> FN_OK then + begin + Beta := SgnBeta * MAXNUM; + Exit; + end; + Ly := LnGamma(Y); + if MathErr <> FN_OK then + begin + Beta := SgnBeta * MAXNUM; + Exit; + end; + Beta := SgnBeta * {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Lx + Ly - Lxy); + end; + + function PSeries(A, B, X : Float) : Float; + { Power series for incomplete beta integral. Use when B*X is small } + var + S, T, U, V, T1, Z, Ai : Float; + N : Integer; + begin + Ai := 1.0 / A; + U := (1.0 - B) * X; + V := U / (A + 1.0); + T1 := V; + T := U; + N := 2; + S := 0.0; + Z := MACHEP * Ai; + while Abs(V) > Z do + begin + U := (N - B) * X / N; + T := T * U; + V := T / (A + N); + S := S + V; + N := N + 1; + end; + S := S + T1; + S := S + Ai; + + U := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + if (A + B < MAXGAM) and (Abs(U) < MAXLOG) then + begin + T := Gamma(A + B) / (Gamma(A) * Gamma(B)); + S := S * T * Power(X, A); + end + else + begin + T := LnGamma(A + B) - LnGamma(A) - LnGamma(B) + + U + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(S); + if T < MINLOG then + S := 0.0 + else + S := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(T); + end; + PSeries := S; + end; + + function CFrac1(A, B, X : Float) : Float; + { Continued fraction expansion #1 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := A + B; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := B - 1.0; + K7 := K4; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MACHEP; + + repeat + Xk := - (X * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (X * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 + 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 - 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 * BIGINV; + Pkm1 := Pkm1 * BIGINV; + Qkm2 := Qkm2 * BIGINV; + Qkm1 := Qkm1 * BIGINV; + end; + + if (Abs(Qk) < BIGINV) or (Abs(Pk) < BIGINV) then + begin + Pkm2 := Pkm2 * BIG; + Pkm1 := Pkm1 * BIG; + Qkm2 := Qkm2 * BIG; + Qkm1 := Qkm1 * BIG; + end; + N := N + 1; + until N > 400; + MathErr := FN_PLOSS; + +CDone: + CFrac1 := Ans; + end; + + function CFrac2(A, B, X : Float) : Float; + { Continued fraction expansion #2 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Z, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := B - 1.0; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := A + B; + K7 := A + 1.0; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Z := X / (1.0 - X); + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MACHEP; + + repeat + Xk := - (Z * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (Z * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 - 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 + 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 * BIGINV; + Pkm1 := Pkm1 * BIGINV; + Qkm2 := Qkm2 * BIGINV; + Qkm1 := Qkm1 * BIGINV; + end; + + if (Abs(Qk) < BIGINV) or (Abs(Pk) < BIGINV) then + begin + Pkm2 := Pkm2 * BIG; + Pkm1 := Pkm1 * BIG; + Qkm2 := Qkm2 * BIG; + Qkm1 := Qkm1 * BIG; + end; + N := N + 1; + until N > 400; + MathErr := FN_PLOSS; + +CDone: + CFrac2 := Ans; + end; + + function IBeta(A, B, X : Float) : Float; + var + A1, B1, X1, T, W, Xc, Y : Float; + Flag : Boolean; + label + Done; + begin + MathErr := FN_OK; + + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + begin + IBeta := DefaultVal(FN_DOMAIN); + Exit; + end; + + if (X = 0.0) or (X = 1.0) then + begin + IBeta := X; + Exit; + end; + + Flag := False; + if (B * X <= 1.0) and (X <= 0.95) then + begin + T := PSeries(A, B, X); + goto Done; + end; + + W := 1.0 - X; + + { Reverse a and b if x is greater than the mean. } + if X > A / (A + B) then + begin + Flag := True; + A1 := B; + B1 := A; + Xc := X; + X1 := W; + end + else + begin + A1 := A; + B1 := B; + Xc := W; + X1 := X; + end; + + if Flag and (B1 * X1 <= 1.0) and (X1 <= 0.95) then + begin + T := PSeries(A1, B1, X1); + goto Done; + end; + + { Choose expansion for optimal convergence } + Y := X1 * (A1 + B1 - 2.0) - (A1 - 1.0); + if Y < 0.0 then + W := CFrac1(A1, B1, X1) + else + W := CFrac2(A1, B1, X1) / Xc; + + { Multiply w by the factor + a b _ _ _ + x (1-x) | (a+b) / ( a | (a) | (b) ) } + + Y := A1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X1); + T := B1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Xc); + if (A1 + B1 < MAXGAM) and (Abs(Y) < MAXLOG) and (Abs(T) < MAXLOG) then + begin + T := Power(Xc, B1) ; + T := T * Power(X1, A1); + T := T / A1; + T := T * W; + T := T * Gamma(A1 + B1) / (Gamma(A1) * Gamma(B1)); + end + else + begin + { Resort to logarithms } + Y := Y + T + LnGamma(A1 + B1) - LnGamma(A1) - LnGamma(B1) + + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(W / A1); + if Y < MINLOG then + T := 0.0 + else + T := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Y); + end; + +Done: + if Flag then + if T <= MACHEP then + T := 1.0 - MACHEP + else + T := 1.0 - T; + + IBeta := T; + end; + + function Erf(X : Float) : Float; + begin + if X < 0.0 then + Erf := - IGamma(0.5, Sqr(X)) + else + Erf := IGamma(0.5, Sqr(X)); + end; + + function Erfc(X : Float) : Float; + begin + if X < 0.0 then + Erfc := 1.0 + IGamma(0.5, Sqr(X)) + else + Erfc := JGamma(0.5, Sqr(X)); + end; + +{ ---------------------------------------------------------------------- + Probability functions + ---------------------------------------------------------------------- } + + function PBinom(N : Integer; P : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + PBinom := DefaultVal(FN_DOMAIN) + else if K = 0 then + PBinom := IntPower(1.0 - P, N) + else if K = N then + PBinom := IntPower(P, N) + else + PBinom := Binomial(N, K) * IntPower(P, K) * IntPower(1.0 - P, N - K); + end; + + function FBinom(N : Integer; P : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + FBinom := DefaultVal(FN_DOMAIN) + else if K = 0 then + FBinom := IntPower(1.0 - P, N) + else if K = N then + FBinom := 1.0 + else + FBinom := 1.0 - IBeta(K + 1, N - K, P); + end; + + function PPoisson(Mu : Float; K : Integer) : Float; + var + P : Float; + I : Integer; + begin + MathErr := FN_OK; + if (Mu <= 0.0) or (K < 0) then + PPoisson := DefaultVal(FN_DOMAIN) + else if K = 0 then + PPoisson := Expo(- Mu) + else + begin + P := Mu; + for I := 2 to K do + P := P * Mu / I; + PPoisson := Expo(- Mu) * P; + end; + end; + + function FPoisson(Mu : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (Mu <= 0.0) or (K < 0) then + FPoisson := DefaultVal(FN_DOMAIN) + else if K = 0 then + FPoisson := Expo(- Mu) + else + FPoisson := JGamma(K + 1, Mu); + end; + + function DNorm(X : Float) : Float; + begin + DNorm := INVSQRT2PI * Expo(- 0.5 * Sqr(X)); + end; + + function FNorm(X : Float) : Float; + begin + FNorm := 0.5 * (1.0 + Erf(X * SQRT2DIV2)); + end; + + function InvNorm(P : Float) : Float; +{ ---------------------------------------------------------------------- + Inverse of Normal distribution function + + Returns the argument, X, for which the area under the Gaussian + probability density function (integrated from minus infinity to X) + is equal to P. + + Translated from Cephes library. + ---------------------------------------------------------------------- } + const + P0 : TabCoef = ( + 8.779679420055069160496E-3, + - 7.649544967784380691785E-1, + 2.971493676711545292135E0, + - 4.144980036933753828858E0, + 2.765359913000830285937E0, + - 9.570456817794268907847E-1, + 1.659219375097958322098E-1, + - 1.140013969885358273307E-2, + 0, 0); + + Q0 : TabCoef = ( + - 5.303846964603721860329E0, + 9.908875375256718220854E0, + - 9.031318655459381388888E0, + 4.496118508523213950686E0, + - 1.250016921424819972516E0, + 1.823840725000038842075E-1, + - 1.088633151006419263153E-2, + 0, 0, 0); + + P1 : TabCoef = ( + 4.302849750435552180717E0, + 4.360209451837096682600E1, + 9.454613328844768318162E1, + 9.336735653151873871756E1, + 5.305046472191852391737E1, + 1.775851836288460008093E1, + 3.640308340137013109859E0, + 3.691354900171224122390E-1, + 1.403530274998072987187E-2, + 1.377145111380960566197E-4); + + Q1 : TabCoef = ( + 2.001425109170530136741E1, + 7.079893963891488254284E1, + 8.033277265194672063478E1, + 5.034715121553662712917E1, + 1.779820137342627204153E1, + 3.845554944954699547539E0, + 3.993627390181238962857E-1, + 1.526870689522191191380E-2, + 1.498700676286675466900E-4, + 0); + + P2 : TabCoef = ( + 3.244525725312906932464E0, + 6.856256488128415760904E0, + 3.765479340423144482796E0, + 1.240893301734538935324E0, + 1.740282292791367834724E-1, + 9.082834200993107441750E-3, + 1.617870121822776093899E-4, + 7.377405643054504178605E-7, + 0, 0); + + Q2 : TabCoef = ( + 6.021509481727510630722E0, + 3.528463857156936773982E0, + 1.289185315656302878699E0, + 1.874290142615703609510E-1, + 9.867655920899636109122E-3, + 1.760452434084258930442E-4, + 8.028288500688538331773E-7, + 0, 0, 0); + + P3 : TabCoef = ( + 2.020331091302772535752E0, + 2.133020661587413053144E0, + 2.114822217898707063183E-1, + - 6.500909615246067985872E-3, + - 7.279315200737344309241E-4, + - 1.275404675610280787619E-5, + - 6.433966387613344714022E-8, + - 7.772828380948163386917E-11, + 0, 0); + + Q3 : TabCoef = ( + 2.278210997153449199574E0, + 2.345321838870438196534E-1, + - 6.916708899719964982855E-3, + - 7.908542088737858288849E-4, + - 1.387652389480217178984E-5, + - 7.001476867559193780666E-8, + - 8.458494263787680376729E-11, + 0, 0, 0); + + var + X, Y, Z, Y2, X0, X1 : Float; + Code : Integer; + begin + if (P <= 0.0) or (P >= 1.0) then + begin + InvNorm := DefaultVal(FN_DOMAIN); + Exit; + end; + + Code := 1; + Y := P; + if Y > (1.0 - 0.13533528323661269189) then { 0.135... = exp(-2) } + begin + Y := 1.0 - Y; + Code := 0; + end; + if Y > 0.13533528323661269189 then + begin + Y := Y - 0.5; + Y2 := Y * Y; + X := Y + Y * (Y2 * PolEvl(Y2, P0, 7) / P1Evl(Y2, Q0, 7)); + X := X * SQRT2PI; + InvNorm := X; + Exit; + end; + + X := Sqrt(- 2.0 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Y)); + X0 := X - {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) / X; + Z := 1.0 / X; + if X < 8.0 then + X1 := Z * PolEvl(Z, P1, 9) / P1Evl(Z, Q1, 9) + else if X < 32.0 then + X1 := Z * PolEvl(Z, P2, 7) / P1Evl(Z, Q2, 7) + else + X1 := Z * PolEvl(Z, P3, 7) / P1Evl(Z, Q3, 7); + X := X0 - X1; + if Code <> 0 then + X := - X; + InvNorm := X; + end; + + function PNorm(X : Float) : Float; + var + A : Float; + begin + A := Abs(X); + MathErr := FN_OK; + if A = 0.0 then + PNorm := 1.0 + else if A < 1.0 then + PNorm := 1.0 - Erf(A * SQRT2DIV2) + else + PNorm := Erfc(A * SQRT2DIV2); + end; + + function DStudent(Nu : Integer; X : Float) : Float; + var + L, P, Q : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + DStudent := DefaultVal(FN_DOMAIN) + else + begin + P := 0.5 * (Nu + 1); + Q := 0.5 * Nu; + L := LnGamma(P) - LnGamma(Q) + - 0.5 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Nu * PI) + - P * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 + Sqr(X) / Nu); + DStudent := Expo(L); + end; + end; + + function FStudent(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + FStudent := DefaultVal(FN_DOMAIN) + else + FStudent := 1.0 - IBeta(0.5 * Nu, 0.5, Nu / (Nu + Sqr(X))); + end; + + function PStudent(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + PStudent := DefaultVal(FN_DOMAIN) + else + PStudent := IBeta(0.5 * Nu, 0.5, Nu / (Nu + Sqr(X))); + end; + + function DKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + DKhi2 := DGamma(0.5 * Nu, 0.5, X); + end; + + function FKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu < 1) or (X <= 0.0) then + FKhi2 := DefaultVal(FN_DOMAIN) + else + FKhi2 := IGamma(0.5 * Nu, 0.5 * X); + end; + + function PKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu < 1) or (X <= 0.0) then + PKhi2 := DefaultVal(FN_DOMAIN) + else + PKhi2 := JGamma(0.5 * Nu, 0.5 * X); + end; + + function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + var + P1, P2, R, S, L : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + DSnedecor := DefaultVal(FN_DOMAIN) + else + begin + R := Int(Nu1) / Int(Nu2); + P1 := 0.5 * Nu1; + P2 := 0.5 * Nu2; + S := P1 + P2; + L := LnGamma(S) - LnGamma(P1) - LnGamma(P2) + + P1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(R); + L := L + (P1 - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) + - S * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 + R * X); + DSnedecor := Expo(L); + end; + end; + + function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + FSnedecor := DefaultVal(FN_DOMAIN) + else + FSnedecor := 1.0 - IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); + end; + + function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + PSnedecor := DefaultVal(FN_DOMAIN) + else + PSnedecor := IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); + end; + + function DExpo(A, X : Float) : Float; + begin + if (A <= 0.0) or (X < 0.0) then + DExpo := DefaultVal(FN_DOMAIN) + else + DExpo := A * Expo(- A * X); + end; + + function FExpo(A, X : Float) : Float; + begin + if (A <= 0.0) or (X < 0.0) then + FExpo := DefaultVal(FN_DOMAIN) + else + FExpo := 1.0 - Expo(- A * X); + end; + + function DBeta(A, B, X : Float) : Float; + var + L : Float; + begin + MathErr := FN_OK; + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + DBeta := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + if A < 1.0 then DBeta := DefaultVal(FN_SING) else DBeta := 0.0 + else if X = 1.0 then + if B < 1.0 then DBeta := DefaultVal(FN_SING) else DBeta := 0.0 + else + begin + L := LnGamma(A + B) - LnGamma(A) - LnGamma(B); + L := L + (A - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) + + (B - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 - X); + DBeta := Expo(L); + end; + end; + + function FBeta(A, B, X : Float) : Float; + begin + FBeta := IBeta(A, B, X); + end; + + function DGamma(A, B, X : Float) : Float; + var + L : Float; + begin + MathErr := FN_OK; + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) then + DGamma := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + if A < 1.0 then + DGamma := DefaultVal(FN_SING) + else if A = 1.0 then + DGamma := B + else + DGamma := 0.0 + else + begin + L := A * Ln(B) - LnGamma(A) + + (A - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - B * X; + DGamma := Expo(L); + end; + end; + + function FGamma(A, B, X : Float) : Float; + begin + FGamma := IGamma(A, B * X); + end; + +{ ---------------------------------------------------------------------- + Random numbers + ---------------------------------------------------------------------- } + +var + X1, X2, C1, C2 : LongInt; + + procedure RMarIn(Seed1, Seed2 : Integer); + begin + X1 := Seed1; + X2 := Seed2; + C1 := 0; + C2 := 0; + end; + + function IRanMar : LongInt; + var + Y1, Y2 : LongInt; + begin + Y1 := 18000 * X1 + C1; + X1 := Y1 and 65535; + C1 := Y1 shr 16; + Y2 := 30903 * X2 + C2; + X2 := Y2 and 65535; + C2 := Y2 shr 16; + IRanMar := (X1 shl 16) + (X2 and 65535); + end; + + function RanMar : Float; + begin + RanMar := (IRanMar + 2147483648.0) / 4294967296.0; + end; + + function RanGaussStd : Float; + { Computes 2 random numbers from the standard normal distribution, + returns one and saves the other for the next call } + const + Gauss_Save : Float = 0.0; { Saves a random number } + Gauss_Set : Boolean = False; { Flags if a number has been saved } + var + R, Theta, SinTheta, CosTheta : Float; + begin + if not Gauss_Set then + begin + R := Sqrt(- 2.0 * Log(RanMar)); + Theta := TWOPI * RanMar; + SinCos(Theta, SinTheta, CosTheta); + RanGaussStd := R * CosTheta; { Return 1st number } + Gauss_Save := R * SinTheta; { Save 2nd number } + end + else + RanGaussStd := Gauss_Save; { Return saved number } + Gauss_Set := not Gauss_Set; + end; + + function RanGauss(Mu, Sigma : Float) : Float; + { Returns a random number from the normal distribution + with mean Mu and standard deviation Sigma } + begin + RanGauss := Mu + Sigma * RanGaussStd; + end; + +{ ---------------------------------------------------------------------- + Initialization code + ---------------------------------------------------------------------- } + +var + I : Integer; + +begin + { Initialize MathErr } + MathErr := FN_OK; + + { Store the factorials of the first NFACT integers in a table } + FactArray[0] := 1.0; + FactArray[1] := 1.0; + FactArray[2] := 2.0; + for I := 3 to NFACT do + FactArray[I] := FactArray[I - 1] * I; + + { Initialize random number generator } + RMarIn(1802, 9373); +end. diff --git a/niftiview7/tpmath/fourier.pas b/niftiview7/tpmath/fourier.pas new file mode 100755 index 0000000..b395165 --- /dev/null +++ b/niftiview7/tpmath/fourier.pas @@ -0,0 +1,336 @@ +(*========================================================================== + + fourier.pas - Don Cross <dcross@intersrv.com> + + Modified by Jean Debord <JDebord@compuserve.com> for use with TP Math. + + This is a Turbo Pascal Unit for calculating the Fast Fourier Transform + (FFT) and the Inverse Fast Fourier Transform (IFFT). + Visit the following URL for the latest version of this code. + This page also has a C/C++ version, and a brief discussion of the + theory behind the FFT algorithm. + + http://www.intersrv.com/~dcross/fft.html#pascal + + Revision history [most recent first]: + +1998 November 27 [Jean Debord] + Replaced the constant MAXPOWER by a variable which is initialized + according to the value of MAX_FLT defined in MATRICES.PAS + +1997 March 1 [Jean Debord] + Modifications for use with the TP Math library: + 1. Added a USES clause for the TP Math units. + 2. Set real type to Float (defined in FMATH.PAS) + 3. Added a constant MAXPOWER to define the maximum number of points. + Modified functions IsPowerOfTwo and NumberOfBitsNeeded accordingly. + 4. Changed array types to those defined in TP Math. Modified array + allocation, deallocation and reference accordingly. + 5. Removed compiler directives, which were no longer necessary. + 6. Modified some typographical and formatting options so that the + code looks like the other TP Math units. + No modification was made to the original algorithm. + +1996 December 11 [Don Cross] + Improved documentation of the procedure CalcFrequency. + Fixed some messed up comments in procedure IFFT. + +1996 December 6 [Don Cross] + Made procedure 'fft_integer' more efficient when buffer size changes + in successive calls: the buffer is now only resized when the input + has more samples, not a differing number of samples. + Also changed the way 'fft_integer_cleanup' works so that it is + more "bullet-proof". + +1996 December 4 [Don Cross] + Adding the procedure 'CalcFrequency', which calculates the FFT + at a specific frequency index p=0..n-1, instead of the whole + FFT. This is O(n^2) instead of O(n*log(n)). + +1996 November 30 [Don Cross] + Adding a routine to allow FFT of an input array of integers. + It is called 'fft_integer'. + +1996 November 18 [Don Cross] + Added some comments. + +1996 November 17 [Don Cross] + Wrote and debugged first version. + +==========================================================================*) + +unit Fourier; + +interface + +uses + FMath, Matrices; + +(*--------------------------------------------------------------------------- + procedure FFT + + Calculates the Fast Fourier Transform of the array of complex numbers + represented by 'RealIn' and 'ImagIn' to produce the output complex + numbers in 'RealOut' and 'ImagOut'. +---------------------------------------------------------------------------*) +procedure FFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + + +(*--------------------------------------------------------------------------- + procedure IFFT + + Calculates the Inverse Fast Fourier Transform of the array of complex + numbers represented by 'RealIn' and 'ImagIn' to produce the output complex + numbers in 'RealOut' and 'ImagOut'. +---------------------------------------------------------------------------*) +procedure IFFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + + +(*--------------------------------------------------------------------------- + procedure FFT_Integer + + Same as procedure FFT, but uses Integer input arrays instead of + double. Make sure you call FFT_Integer_Cleanup after the last + time you call FFT_Integer to free up memory it allocates. +---------------------------------------------------------------------------*) +procedure FFT_Integer(NumSamples : Integer; RealIn, ImagIn : PIntVector; + RealOut, ImagOut : PVector); + + +(*-------------------------------------------------------------------------- + procedure FFT_Integer_Cleanup + + If you call the procedure 'FFT_Integer', you must call + 'FFT_Integer_Cleanup' after the last time you call 'FFT_Integer' + in order to free up dynamic memory. +--------------------------------------------------------------------------*) +procedure FFT_Integer_Cleanup; + + +(*-------------------------------------------------------------------------- + procedure CalcFrequency + + This procedure calculates the complex frequency sample at a given + index directly. Use this instead of 'FFT' when you only need one + or two frequency samples, not the whole spectrum. + + It is also useful for calculating the Discrete Fourier Transform (DFT) + of a number of data which is not an integer power of 2. For example, + you could calculate the DFT of 100 points instead of rounding up to + 128 and padding the extra 28 array slots with zeroes. +--------------------------------------------------------------------------*) +procedure CalcFrequency(NumSamples, FrequencyIndex : Integer; + RealIn, ImagIn : PVector; + var RealOut, ImagOut : Float); + +implementation + +var + MaxPower : Integer; + + function IsPowerOfTwo(X : Integer) : Boolean; + var + I, Y : Integer; + begin + Y := 2; + for I := 1 to Pred(MaxPower) do + begin + if X = Y then + begin + IsPowerOfTwo := True; + Exit; + end; + Y := Y shl 1; + end; + IsPowerOfTwo := False; + end; + + function NumberOfBitsNeeded(PowerOfTwo : Integer) : Integer; + var + I : Integer; + begin + for I := 0 to MaxPower do + begin + if (PowerOfTwo and (1 shl I)) <> 0 then + begin + NumberOfBitsNeeded := I; + Exit; + end; + end; + end; + + function ReverseBits(Index, NumBits : Integer) : Integer; + var + I, Rev : Integer; + begin + Rev := 0; + for I := 0 to NumBits - 1 do + begin + Rev := (Rev shl 1) or (Index and 1); + Index := Index shr 1; + end; + ReverseBits := Rev; + end; + + procedure FourierTransform(AngleNumerator : Float; NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + var + NumBits, I, J, K, N, BlockSize, BlockEnd : Integer; + Delta_angle, Delta_ar : Float; + Alpha, Beta : Float; + Tr, Ti, Ar, Ai : Float; + begin + if not IsPowerOfTwo(NumSamples) or (NumSamples < 2) then + begin + Write('Error in procedure Fourier: NumSamples=', NumSamples); + WriteLn(' is not a positive integer power of 2.'); + Halt; + end; + + NumBits := NumberOfBitsNeeded(NumSamples); + for I := 0 to NumSamples - 1 do + begin + J := ReverseBits(I, NumBits); + RealOut^[J] := RealIn^[I]; + ImagOut^[J] := ImagIn^[I]; + end; + + BlockEnd := 1; + BlockSize := 2; + while BlockSize <= NumSamples do + begin + Delta_angle := AngleNumerator / BlockSize; + Alpha := Sin(0.5 * Delta_angle); + Alpha := 2.0 * Alpha * Alpha; + Beta := Sin(Delta_angle); + + I := 0; + while I < NumSamples do + begin + Ar := 1.0; (* cos(0) *) + Ai := 0.0; (* sin(0) *) + + J := I; + for N := 0 to BlockEnd - 1 do + begin + K := J + BlockEnd; + Tr := Ar * RealOut^[K] - Ai * ImagOut^[K]; + Ti := Ar * ImagOut^[K] + Ai * RealOut^[K]; + RealOut^[K] := RealOut^[J] - Tr; + ImagOut^[K] := ImagOut^[J] - Ti; + RealOut^[J] := RealOut^[J] + Tr; + ImagOut^[J] := ImagOut^[J] + Ti; + Delta_ar := Alpha * Ar + Beta * Ai; + Ai := Ai - (Alpha * Ai - Beta * Ar); + Ar := Ar - Delta_ar; + Inc(J); + end; + + I := I + BlockSize; + end; + + BlockEnd := BlockSize; + BlockSize := BlockSize shl 1; + end; + end; + + procedure FFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + begin + FourierTransform(2 * PI, NumSamples, RealIn, ImagIn, RealOut, ImagOut); + end; + + procedure IFFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + var + I : Integer; + begin + FourierTransform(- 2 * PI, NumSamples, RealIn, ImagIn, RealOut, ImagOut); + + { Normalize the resulting time samples } + for I := 0 to NumSamples - 1 do + begin + RealOut^[I] := RealOut^[I] / NumSamples; + ImagOut^[I] := ImagOut^[I] / NumSamples; + end; + end; + +var + RealTemp, ImagTemp : PVector; + TempArraySize : Integer; + + procedure FFT_Integer(NumSamples : Integer; + RealIn, ImagIn : PIntVector; + RealOut, ImagOut : PVector); + var + I : Integer; + begin + if NumSamples > TempArraySize then + begin + FFT_Integer_Cleanup; { free up memory in case we already have some } + DimVector(RealTemp, NumSamples); + DimVector(ImagTemp, NumSamples); + TempArraySize := NumSamples; + end; + + for I := 0 to NumSamples - 1 do + begin + RealTemp^[I] := RealIn^[I]; + ImagTemp^[I] := ImagIn^[I]; + end; + + FourierTransform(2 * PI, NumSamples, RealTemp, ImagTemp, RealOut, ImagOut); + end; + + procedure FFT_Integer_Cleanup; + begin + if TempArraySize > 0 then + begin + if RealTemp <> nil then + DelVector(RealTemp, TempArraySize); + if ImagTemp <> nil then + DelVector(ImagTemp, TempArraySize); + TempArraySize := 0; + end; + end; + + procedure CalcFrequency(NumSamples, FrequencyIndex : Integer; + RealIn, ImagIn : PVector; + var RealOut, ImagOut : Float); + var + K : Integer; + Cos1, Cos2, Cos3, Theta, Beta : Float; + Sin1, Sin2, Sin3 : Float; + begin + RealOut := 0.0; + ImagOut := 0.0; + Theta := 2 * PI * FrequencyIndex / NumSamples; + Sin1 := Sin(- 2 * Theta); + Sin2 := Sin(- Theta); + Cos1 := Cos(- 2 * Theta); + Cos2 := Cos(- Theta); + Beta := 2 * Cos2; + for K := 0 to NumSamples - 1 do + begin + { Update trig values } + Sin3 := Beta * Sin2 - Sin1; + Sin1 := Sin2; + Sin2 := Sin3; + + Cos3 := Beta * Cos2 - Cos1; + Cos1 := Cos2; + Cos2 := Cos3; + + RealOut := RealOut + RealIn^[K] * Cos3 - ImagIn^[K] * Sin3; + ImagOut := ImagOut + ImagIn^[K] * Cos3 + RealIn^[K] * Sin3; + end; + end; + +begin { Unit initialization code } + MaxPower := Trunc(Log2(MAX_FLT)); { Max power of two } + TempArraySize := 0; { flag that buffers RealTemp, RealImag not allocated } + RealTemp := nil; + ImagTemp := nil; +end. diff --git a/niftiview7/tpmath/matcomp.pas b/niftiview7/tpmath/matcomp.pas new file mode 100755 index 0000000..3d3c33e --- /dev/null +++ b/niftiview7/tpmath/matcomp.pas @@ -0,0 +1,302 @@ +{ ********************************************************************** + * Unit MATCOMP.PAS * + * Version 1.3 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Matrices with complex elements. See MATRICES.PAS for details + concerning the dynamic allocation and use of matrices. + ********************************************************************** + References: + 1) 'Basic Programs for Scientists and Engineers' by A.R. Miller + 2) 'Numerical Recipes' by Press et al. + ********************************************************************** } + +unit MatComp; + +interface + +uses + FMath, FComp, Matrices; + +{ ********************************************************************** + This section defines the vector and matrix types. Maximal sizes are + given for a 16-bit compiler (TP/BP). Higher values may be used with + a 32-bit compiler such as FPC. + ********************************************************************** } + +const +{$IFDEF DOUBLEREAL} + MAX_COMP = 3854; { Max size of complex vector } +{$ELSE} +{$IFDEF SINGLEREAL} + MAX_COMP = 7280; +{$ELSE} +{$IFDEF PASCALREAL} + MAX_COMP = 5040; +{$ELSE} + {$DEFINE EXTENDEDREAL} + MAX_COMP = 3119; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +type + TCompVector = array[0..MAX_COMP] of Complex; + PCompVector = ^TCompVector; + + TCompMatrix = array[0..MAX_VEC] of PCompVector; + PCompMatrix = ^TCompMatrix; + +{ ********************************************************************** + Memory allocation routines + ********************************************************************** } + +procedure DimCompVector(var V : PCompVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates complex vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimCompMatrix(var A : PCompMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates complex matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Memory deallocation routines + ********************************************************************** } + +procedure DelCompVector(V : PCompVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes complex vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelCompMatrix(A : PCompMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes complex matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Complex matrix functions + ********************************************************************** } + +function C_LU_Decomp(A : PCompMatrix; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + LU decomposition + ---------------------------------------------------------------------- } + +procedure C_LU_Solve(A : PCompMatrix; B : PCompVector; + Lbound, Ubound : Integer; X : PCompVector); +{ ---------------------------------------------------------------------- + Solves a system of equations whose matrix has been transformed by + C_LU_Decomp + ---------------------------------------------------------------------- } + +implementation + +const + { Used by LU procedures } + LastDim : Integer = 1; { Dimension of the last system solved } + Index : PIntVector = nil; { Records the row permutations } + + procedure DimCompVector(var V : PCompVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_COMP) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Complex)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := C_zero; + end; + + procedure DimCompMatrix(var A : PCompMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_COMP) then + begin + A := nil; + Exit; + end; + + { Size of a row } + GetMem(A, Succ(Ubound1) * SizeOf(PCompVector)); + if A = nil then Exit; + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := C_zero; + end; + + procedure DelCompVector(V : PCompVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Complex)); + V := nil; + end; + end; + + procedure DelCompMatrix(A : PCompMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Complex); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PCompVector)); + A := nil; + end; + end; + + function C_LU_Decomp(A : PCompMatrix; Lbound, Ubound : Integer) : Integer; + const + TINY = 1.0E-20; + var + I, Imax, J, K : Integer; + C, Pvt, T : Float; + Sum, Z : Complex; + V : PVector; + begin + DimVector(V, Ubound); + { Reallocate Index } + if Index <> nil then + DelIntVector(Index, LastDim); + DimIntVector(Index, Ubound); + LastDim := Ubound; + + for I := Lbound to Ubound do + begin + Pvt := 0.0; + for J := Lbound to Ubound do + begin + C := CAbs(A^[I]^[J]); + if C > Pvt then Pvt := C; + end; + if Pvt < MACHEP then + begin + DelVector(V, Ubound); + C_LU_Decomp := MAT_SINGUL; + Exit; + end; + V^[I] := 1.0 / Pvt; + end; + for J := Lbound to Ubound do + begin + for I := Lbound to Pred(J) do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(I) do + begin + { Sum := Sum - A^[I]^[K] * A^[K]^[J]; } + CMult(A^[I]^[K], A^[K]^[J], Z); + CSub(Sum, Z, Sum); + end; + A^[I]^[J] := Sum; + end; + Pvt := 0.0; + for I := J to Ubound do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(J) do + begin + { Sum := Sum - A^[I]^[K] * A^[K]^[J]; } + CMult(A^[I]^[K], A^[K]^[J], Z); + CSub(Sum, Z, Sum); + end; + A^[I]^[J] := Sum; + T := V^[I] * CAbs(Sum); + if T > Pvt then + begin + Pvt := T; + Imax := I; + end; + end; + if J <> Imax then + begin + { SwapRows(Imax, J, A, Lbound, Ubound); } + for K := Lbound to Ubound do + CSwap(A^[Imax]^[K], A^[J]^[K]); + V^[Imax] := V^[J]; + end; + Index^[J] := Imax; + if CAbs(A^[J]^[J]) = 0.0 then + CSet(A^[J]^[J], TINY, TINY, Rec); + if J <> Ubound then + for I := Succ(J) to Ubound do + { A^[I]^[J] := A^[I]^[J] / A^[J]^[J]; } + CDiv(A^[I]^[J], A^[J]^[J], A^[I]^[J]); + end; + DelVector(V, Ubound); + C_LU_Decomp := MAT_OK; + end; + + procedure C_LU_Solve(A : PCompMatrix; B : PCompVector; + Lbound, Ubound : Integer; X : PCompVector); + var + I, Ip, J, K : Integer; + Sum, Z : Complex; + begin + K := Pred(Lbound); + { CopyVector(X, B, Lbound, Ubound); } + for I := Lbound to Ubound do + X^[I] := B^[I]; + for I := Lbound to Ubound do + begin + Ip := Index^[I]; + Sum := X^[Ip]; + X^[Ip] := X^[I]; + if K >= Lbound then + for J := K to Pred(I) do + begin + { Sum := Sum - A^[I]^[J] * X^[J] } + CMult(A^[I]^[J], X^[J], Z); + CSub(Sum, Z, Sum); + end + else if CAbs(Sum) <> 0.0 then + K := I; + X^[I] := Sum; + end; + for I := Ubound downto Lbound do + begin + Sum := X^[I]; + if I < Ubound then + for J := Succ(I) to Ubound do + begin + { Sum := Sum - A^[I]^[J] * X^[J]; } + CMult(A^[I]^[J], X^[J], Z); + CSub(Sum, Z, Sum); + end; + { X^[I] := Sum / A^[I]^[I]; } + CDiv(Sum, A^[I]^[I], X^[I]); + end; + end; + +end. diff --git a/niftiview7/tpmath/math387.inc b/niftiview7/tpmath/math387.inc new file mode 100755 index 0000000..fb4c86c --- /dev/null +++ b/niftiview7/tpmath/math387.inc @@ -0,0 +1,314 @@ +{ ********************************************************************** + * MATH387.INC * + ********************************************************************** + Mathematical functions for TPMATH + (Assembler version for 387/486/Pentium with BP7 and Delphi1) + ********************************************************************** } + + +(* Bibliotheque mathematique pour utilisation du coprocesseur flottant + JD GAYRARD Sept. 95 + + ---------------------------------------------------------------------- + Unite d'origine : MATH387.PAS, disponible dans MATHLIB2.ZIP + (http://wcarchive.cdrom.com/pub/delphi_www/) + Convertie en fichier Include par J. DEBORD, Juin 97 + avec ajout des fonctions fexp2 et flog2 + ---------------------------------------------------------------------- + + la bibliotheque est batie … partir des fonctions du coprocesseur + du type 386, elle fournit les fonctions suivantes: + fsin, fcos, ftan, farctan, farctan2, + farcsin, farccos, fmod, mod_2PI, + ften_to, fy_to_x, fexp, fexp2, fln, flog, flog2... + +Aucune verification du domaine de definition des fonctions n'est faite, +pas plus qu'un controle de la validite des operandes. Il est conseille +d'utiliser cette bibliotheque pour les types single et double exclusivement *) + +{ table opcode du 387 non comprise par turbo pascal V7 } +{ FSIN : D9 FE + FCOS : D9 FF + FSINCOS : D9 FB + FPREM1 : D9 F5 } + +(* use only with 80387, 80486 or pentium for type single, double and extended, +no check of definition domain of the function or range (FPU limitation). +The f prefix avoids function redefinition of system runtime library *) + +function fsin(x : Float): Float; assembler; +{if x < pi.2^62, then C2 is set to 0 and ST = sin(x) + else C2 is set to 1 and ST = x } +{no check range validity is performed in this function} +asm + FLD x { load x } + DB $D9, $FE { opcode for FSIN } +end; + +function fcos(x : Float): Float; assembler; +{ if x < pi.2^62, then C2 is set to 0 and ST = sin(x) + else C2 is set to 1 and ST = x } +{no range validity check is performed in this function} +asm + FLD x { load angle } + DB $D9, $FF { opcode for FCOS } +end; +(* +procedure dsincos(x : Float; var sinus, cosinus : double); assembler; +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80468 et pentium et type double } +asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + LES DI,cosinus { } + FSTP ES:QWORD PTR [DI] { sin(x) - } + LES DI,sinus { } + FSTP ES:QWORD PTR [DI] { - - } +end; + +procedure ssincos(x : Float; var sinus, cosinus : single); assembler; +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80468 et pentium et type single } +asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + LES DI,cosinus { } + FSTP ES:DWORD PTR [DI] { sin(x) - } + LES DI,sinus { } + FSTP ES:DWORD PTR [DI] { - - } +end; + +procedure fsincos(x : Float; var sinus, cosinus : Float); +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80486 et pentium } +var lcos, lsin : Float; +begin + asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + FSTP lcos { sin(x) - } + FSTP lsin { - - } + end; +cosinus := lcos; +sinus := lsin +end; +*) +function ftan(x : Float): Float; assembler; +{ if x < pi.2^62, then C2 is set to 0 and ST = 1 and ST(1) = tan(x) + else C2 is set to 1 and ST = x } +{no range validity check is performed in this function} +asm { ST(0) ST(1) } + FLD x { x - } + FPTAN { 1 tan(x) } + FSTP ST(0) { tan(x) - } +end; + +function farcsin(x : Float): Float; assembler; +(* retourne l'arcsin de x *) +{ methode : ________ + arcsin(x) = arctan( x / V 1 - x.x ) } +{no range validity check is performed in this function |x| > 1 } +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLD ST(0) { x x - } + FMUL ST(0), ST { x.x x - } + FLD1 { 1 x.x x } + FSUBRP ST(1), ST { 1 - xý x - } + FSQRT { sqrt(1-xý) x - } + FPATAN { arcsin(x) - - } +end; + +function farccos(x : Float): Float; assembler; +{ retourne arccos(x) + methode : ________ + arcsin(x) = arctan( V 1 - x.x / x ) } +{ pas de controle de domaine de definition |x| > 1 } +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLD ST(0) { x x - } + FMUL ST(0), ST { x.x x - } + FLD1 { 1 x.x x } + FSUBRP ST(1), ST { 1 - xý x - } + FSQRT { sqrt(1-xý) x - } + FXCH { x z - } + FPATAN { arccos(x) - - } +end; + +function farctan(x : Float): Float; assembler; +asm { ST(0) ST(1) } + FLD x { x - } + FLD1 { 1 x } + FPATAN { atan(x/1) - } +end; + +function farctan2(y, x : Float): Float; assembler; +{ retourne arctan (y / x) } +asm { ST(0) ST(1) } + FLD y { y - } + FLD x { x y } + FPATAN { atan(y/x) - } +end; +(* +function fmod(x, y : Float): Float; assembler; +{ retourne x mod y } +asm { ST(0) ST(1) } + FLD Y { y - } + FLD X { x y } +@repeat_mod: + FPREM { x mod y y } + FSTSW AX + SAHF + JP @repeat_mod + FSTP ST(1) { x mod y - } +end; + +function fmod_2PI( x : Float): Float; assembler; +{ retourne x mod 2.pi } +asm { ST(0) ST(1) } + FLDPI { pi - } + FADD ST, ST { 2.pi - } + FLD x { x 2.pi } +@unit_circle: + FPREM { x mod 2pi 2pi } + FSTSW AX + SAHF + JP @unit_circle + FSTP ST(1) { x mod 2pi - } +end; +*) +function fln(x : Float): Float; assembler; +{ retourne le logarithme naturel de x, utilise + la methode loge(x) = loge(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLN2 { ln(2) - } + FLD X { x ln(2) } + FYL2X { ln(2).log2(x) - } +end; + +function flog2(x : Float): Float; assembler; +{ retourne le logarithme de base 2 de x } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLD1 { 1 - } + FLD X { x 1 } + FYL2X { log2(x) - } +end; + +function flog10(x : Float): Float; assembler; +{ retourne le logarithme base 10 de x, utilise + la methode log10(x) = log10(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLG2 { log10(2) - } + FLD X { x log10(2) } + FYL2X {log2(x).log10(2) - } +end; + +function fexp(x : Float): Float; assembler; +{ retourne e^x, par la methode e^x = 2^(x.log2(e)) } +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) } +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLDL2E { log2(e) x - } + FMULP ST(1), ST { x.log2(e) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { e^x - - } +end; + +function fexp2(x : Float): Float; assembler; +{ retourne 2^x par la methode 2^z = 2^f.2^i } +{ with f = frac(z) and i = int(z) } +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { x x - } + FRNDINT { int(x) x - } + FLDCW control_ww + FXCH { x i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { 2^x - - } +end; + +function fexp10(x : Float): Float; assembler; +{ retourne 10^x, par la methode 10^x = 2^(x.log2(10)) +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLDL2T { log2(10) x - } + FMULP ST(1), ST { x.log2(10) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { 10^x - - } +end; +(* +function fpower(y, x : Float): Float; assembler; +{ retourne y^x, par la methode y^x = 2^(y.log2(y)) +{no range validity check is performed in this function (y > 0) } +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD Y { y - - } + FLD X { x y - } + FYL2X { x.log2(y) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { y^x - - } +end; + +function module(x, y : Float): Float; assembler; +{ retourne le module du complexe (x,y) } +asm { ST(0) ST(1) } + FLD Y { y - } + FMUL ST(0), ST { y.y - } + FLD X { x y.y } + FMUL ST(0), ST { x.x y.y } + FADDP ST(1), ST { d.d - } + FSQRT { d - } +end; +*) + diff --git a/niftiview7/tpmath/mathp2.inc b/niftiview7/tpmath/mathp2.inc new file mode 100755 index 0000000..969ecec --- /dev/null +++ b/niftiview7/tpmath/mathp2.inc @@ -0,0 +1,582 @@ +{ ********************************************************************** + * MATHP2.INC * + ********************************************************************** + Mathematical functions for TPMATH + (Assembler version for Pentium II/III with FPC) + ********************************************************************** } + + +{ Bibliotheque mathematique pour utilisation du coprocesseur flottant + JD GAYRARD Sept. 95 + + ---------------------------------------------------------------------- + Unite d'origine : MATH387.PAS, disponible dans MATHLIB2.ZIP + (http://wcarchive.cdrom.com/pub/delphi_www/) + Adapte aux pentiums II/III et complete par P. NOGARET (2000) + ---------------------------------------------------------------------- } + + + +{***********************************************************************} +{* function fexp(x : Float): Float;assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne e^x, par la methode e^x = 2^(x.log2(e)) *} +{* 2^z = 2^f.2^i avec f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1, *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{***********************************************************************} + function fexp(x : Float): Float;assembler; + var + round_z : dword; + temp : extended; + asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['eax']; + + +{***********************************************************************} +{* function fexp2(x : Float): Float; assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne 2^x par la methode 2^z = 2^f.2^i *} +{* avec f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1, *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* x - *} +{* z:=x - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{***********************************************************************} + function fexp2(x : Float): Float; assembler; + var + round_z : dword; + temp : extended; + asm + FLD x + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z { round_zmax := 16384 } + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['EAX']; + +{***********************************************************************} +{* function fexp10(x : Float): Float; assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne 10^x, par la methode 10^x = 2^(x.log2(10)) *} +{* 2^z = 2^f.2^i with f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1 *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* log2(10) - *} +{* x log2(10) *} +{* z:=x.log2(10) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* 10^x - *} +{***********************************************************************} + function fexp10(x : Float): Float; assembler; + var + round_z : dword; + temp : extended; + asm + FLDL2T + FLD X + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['EAX']; + +function fln(x : Float): Float; assembler; +{ retourne le logarithme naturel de x, utilise + la methode loge(x) = loge(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLN2 { ln(2) - } + FLD X { x ln(2) } + FYL2X { ln(2).log2(x) - } +end; + +function flog2(x : Float): Float; assembler; +{ retourne le logarithme de base 2 de x } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLD1 { 1 - } + FLD X { x 1 } + FYL2X { log2(x) - } +end; + +{***********************************************************************} +{* function flog10(X : Float) : Float; *} +{***********************************************************************} +{* Compute a common (base 10) logarithm. If X is near 1.0, then we *} +{* use the FYL2XP1 instruction instead of FYL2X. "Near" means between *} +{* 1.0 and 1+Sqrt(2)/2. We use an approximation for Sqrt(2)/2, so we *} +{* don't have to compute it. The exact value isn't important, since *} +{* FYL2X works fine for values near the transition. *} +{***********************************************************************} + function flog10(x : Float): Float; assembler; + const + HalfSqrt2p1: Extended = 1.7071; + asm + fldlg2 { push Log2 } + fld X { push X } + fld1 { push 1.0 } + fcomp ST(1) { if (X < 1.0) } + jl @@1 { goto @@1 } + fld HalfSqrt2p1 { push 1.707 } + fcomp ST(1) { if (X > 1.707) } + jg @@1 { goto @@1 } + fld1 { X is small, so subtract 1.0 } + fsubrp { X := X - 1.0 } + fyl2xp1 { Log10(2) * Log2(X+1) } + jmp @@2 + @@1: { X is not near 1.0 } + fyl2x { Log10(2) * Log2(X) } + @@2: + end; + +{***********************************************************************} +{* function fsin(X : Float) : Float; *} +{***********************************************************************} +{* if x < pi.2^62, then C2 is set to 0 and ST = sin(x) *} +{* else C2 is set to 1 and ST = x *} +{* no check range validity is performed in this function *} +{***********************************************************************} + function fsin(X : Float) : Float; assembler; + asm + FLD x + fsin + end; + +{***********************************************************************} +{* function fcos(X : Float) : Float; *} +{***********************************************************************} + function fcos(X : Float) : Float; assembler; + asm + FLD x + fcos + end; + +{***********************************************************************} +{* function ftan(X : Float) : Float;assembler; *} +{***********************************************************************} + function ftan(X : Float) : Float; assembler; + asm { ST(0) ST(1) } + FLD x { x - } + FPTAN { 1 tan(x) } + FSTP ST(0) { tan(x) - } + end; + +{***********************************************************************} +{* function farctan(X : Float) : Float; *} +{***********************************************************************} + function farctan(x : Float): Float; assembler; + asm { ST(0) ST(1) } + FLD x { x - } + FLD1 { 1 x } + FPATAN { atan(x/1) - } + end; + +{***********************************************************************} +{* function farctan2(Y, X : Float) : Float; *} +{***********************************************************************} +function farctan2(y, x : Float): Float; assembler; +{ retourne arctan (y / x) } +asm { ST(0) ST(1) } + FLD y { y - } + FLD x { x y } + FPATAN { atan(y/x) - } +end; + +{***********************************************************************} +{* function farcsin(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arcsin de x *} +{* methode : ________ *} +{* arcsin(x) = arctan( x / V 1 - x.x ) *} +{* no range validity check is performed in this function |x| > 1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* x - - *} +{* x x - *} +{* x.x x - *} +{* 1 x.x x *} +{* 1 - xý x - *} +{* sqrt(1-xý) x - *} +{* arcsin(x) - - *} +{***********************************************************************} +function farcsin(x : Float): Float; assembler; +asm + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBRP ST(1), ST + FSQRT + FPATAN +end; + +{***********************************************************************} +{* function farccos(x : Float): Float; assembler; *} +{***********************************************************************} +{* retourne l'arccos de x *} +{* methode : ________ *} +{* arccos(x) = arctan( V 1 - x.x / x) *} +{* pas de controle de domaine de definition |x| > 1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* x - - *} +{* x x - *} +{* x.x x - *} +{* 1 x.x x *} +{* 1 - xý x - *} +{* sqrt(1-xý) x - *} +{* x z - *} +{* arccos(x) - - *} +{***********************************************************************} +function farccos(x : Float): Float; assembler; +asm + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBRP ST(1), ST + FSQRT + FXCH + FPATAN +end; + +{***********************************************************************} +{* function fsinh(X : Float) : Float; *} +{***********************************************************************} +{* retourne le sinus hyperbolique de l'argument *} +{* sh(x) = [exp(x) - exp(-x)] / 2 *} +{* methode : z = exp(x), ch(x) = 1/2 (z - 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* log2(e) - - *} +{* x log2(e) - *} +{* z:=x.log2(e) - - *} +{* z - - *} +{* z - round(z) - - *} +{* 2^(z - round(z)) - 1 - - *} +{* 1 2^(z - round(z)) - 1 - *} +{* 2^(z - round(z)) - - *} +{* temp:=2^i 2^f:=2^(z - round(z)) - *} +{* e^x - - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z - *} +{* z-1/z - - *} +{* 0.5 z-1/z - *} +{* sh(x) - - *} +{***********************************************************************} +function fsinh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIVRP ST(1), ST + FSUBP ST(1), ST + FLD one_half + FMULP ST(1), ST +end; + +{***********************************************************************} +{* function fcosh(X : Float) : Float; *} +{***********************************************************************} +{* retourne le cosinus hyperbolique de l'argument *} +{* ch(x) = [exp(x) + exp(-x)] / 2 *} +{* methode : z = exp(x), ch(x) = 1/2 (z + 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* st(0) st(1) st(2) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z - *} +{* z+1/z - - *} +{* 0.5 z+1/z - *} +{* ch(x) - - *} +{***********************************************************************} +function fcosh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIVRP ST(1), ST + FADDP ST(1), ST + FLD one_half + FMULP ST(1), ST +end; + +{***********************************************************************} +{* function ftanh(X : Float) : Float; *} +{***********************************************************************} +{* retourne la tangente hyperbolique de l'argument *} +{* th(x) = sh(x) / ch(x) *) *} +{* th(x) = [exp(x) - exp(-x)] / [exp(x) + exp(-x)] *} +{* methode : z = exp(x), ch(x) = (z - 1/z) / (z + 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* st(0) st(1) st(2) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z z *} +{* 1/z z z-1/z *} +{* z+1/z z-1/z - *} +{* th(x) - - *} +{***********************************************************************} +function ftanh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIV ST, ST(1) + FSUB ST(2), ST + FADDP ST(1), ST + FDIVP ST(1), ST +end; + +{***********************************************************************} +{* function farcsinh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc sinus hyperbolique de l'argument *} +{* _________ *} +{* arg sh(x) = ln ( x + V x.x + 1 ) *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* x.x x ln(2) - *} +{* 1 x.x x ln(2) *} +{* x.x + 1 x ln(2) - *} +{* sqrt(x.x+1) x ln(2) - *} +{* x + z ln(2) - - *} +{* arg_sh(x) - - - *} +{***********************************************************************} +function farcsinh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FADDP ST(1), ST + FSQRT + FADDP ST(1), ST + FYL2X +end; + +{***********************************************************************} +{* function farccosh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc cosinus hyperbolique de l'argument *} +{* ________ *} +{* arg ch(x) = ln ( x + V x.x - 1 ) x >=1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* x.x x ln(2) - *} +{* 1 x.x x ln(2) *} +{* x.x - 1 x ln(2) - *} +{* sqrt(x2-1) x ln(2) - *} +{* x + z ln(2) - - *} +{* arg_ch(x) - - - *} +{***********************************************************************} +function farccosh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBP ST(1), ST + FSQRT + FADDP ST(1), ST + FYL2X +end; + +{***********************************************************************} +{* function farctanh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc tangente hyperbolique de l'argument *} +{* arg th(x) = 1/2 ln [ (1 + x) / (1 - x) ] *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* 1 x x ln(2) *} +{* 1 x 1 + x ln(2) *} +{* 1 - x 1 + x ln(2) - *} +{* 1+x/1-x ln(2) - - *} +{* ln(z) - - - *} +{***********************************************************************} +function farctanh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FLD1 + FADD ST(2),ST + FSUBRP ST(1),ST + FDIVP ST(1),ST + FYL2X +end; diff --git a/niftiview7/tpmath/mcmc.pas b/niftiview7/tpmath/mcmc.pas new file mode 100755 index 0000000..4536521 --- /dev/null +++ b/niftiview7/tpmath/mcmc.pas @@ -0,0 +1,273 @@ +{ ********************************************************************** + * Unit MCMC.PAS * + * Version 1.2 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Simulation by Markov Chain Monte Carlo (MCMC) with the + Metropolis-Hastings algorithm. + + This algorithm simulates the probability density function (pdf) of a + vector X. The pdf P(X) is written as: + + P(X) = C * Exp(- F(X) / T) + + Simulating P by the Metropolis-Hastings algorithm is equivalent to + minimizing F by simulated annealing at the constant temperature T. + The constant C is not used in the simulation. + + The series of random vectors generated during the annealing step + constitutes a Markov chain which tends towards the pdf to be simulated. + + It is possible to run several cycles of the algorithm. + The variance-covariance matrix of the simulated distribution is + re-evaluated at the end of each cycle and used for the next cycle. + ********************************************************************** } + +unit MCMC; + +interface + +uses + FMath, Matrices, Optim, Regress; + + +{ ********************************************************************** + Metropolis-Hastings parameters + ********************************************************************** } + +const + MH_NCycles : Integer = 1; { Number of cycles } + MH_MaxSim : Integer = 1000; { Max nb of simulations at each cycle } + MH_SavedSim : Integer = 200; { Nb of simulations to be saved } + +{ ********************************************************************** + Simulation routine + ********************************************************************** } + + function Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Simulation of a probability density function by the + Metropolis-Hastings algorithm + ---------------------------------------------------------------------- + Input parameters : Func = Function such that the pdf is + P(X) = C * Exp(- Func(X) / T) + T = Temperature + X = Initial mean vector + V = Initial variance-covariance matrix + Lbound, + Ubound = Indices of first and last variables + ---------------------------------------------------------------------- + Output parameters : Xmat = Matrix of simulated vectors, stored + columnwise, i.e. + Xmat[Lbound..Ubound, 1..MH_SavedSim] + X = Mean of distribution + V = Variance-covariance matrix of distribution + X_min = Coordinates of minimum of F(X) + (mode of the distribution) + F_min = Value of F(X) at minimum + ---------------------------------------------------------------------- + Possible results : MAT_OK : No error + MAT_NOT_PD : The variance-covariance matrix + is not positive definite + ---------------------------------------------------------------------- } + +implementation + + function CalcSD(V : PMatrix; + Lbound, Ubound : Integer; + L : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Computes the standard deviations for independent random numbers + from the variance-covariance matrix. + ---------------------------------------------------------------------- } + var + I, ErrCode : Integer; + begin + I := LBound; + ErrCode := 0; + repeat + if V^[I]^[I] > 0.0 then + L^[I]^[I] := Sqrt(V^[I]^[I]) + else + ErrCode := MAT_NOT_PD; + Inc(I); + until (ErrCode <> 0) or (I > Ubound); + CalcSD := ErrCode; + end; + + procedure GenIndepRandomVector(X : PVector; + L : PMatrix; + Lbound, Ubound : Integer; + X1 : PVector); +{ ---------------------------------------------------------------------- + Generates a random vector X1 from X, using independent gaussian random + increments. L is the diagonal matrix of the standard deviations. + ---------------------------------------------------------------------- } + var + I : Integer; + begin + for I := Lbound to Ubound do + X1^[I] := RanGauss(X^[I], L^[I]^[I]); + end; + + procedure GenRandomVector(X : PVector; + L : PMatrix; + Lbound, Ubound : Integer; + X1 : PVector); +{ ---------------------------------------------------------------------- + Generates a random vector X1 from X, using correlated gaussian random + increments. L is the Cholesky factor of the variance-covariance matrix + ---------------------------------------------------------------------- } + var + U : PVector; + I, J : Integer; + begin + { Form a vector U of independent standard normal variates } + DimVector(U, Ubound); + for I := Lbound to Ubound do + U^[I] := RanGaussStd; + + { Form X1 = X + L*U, which follows the multinormal distribution } + for I := Lbound to Ubound do + begin + X1^[I] := X^[I]; + for J := Lbound to I do + X1^[I] := X1^[I] + L^[I]^[J] * U^[J]; + end; + DelVector(U, Ubound); + end; + + function Accept(DeltaF, T : Float) : Boolean; +{ ---------------------------------------------------------------------- + Checks if a variation DeltaF of the function at temperature T is + acceptable. + ---------------------------------------------------------------------- } + begin + Accept := (DeltaF < 0.0) or (Expo(- DeltaF / T) > RanMar); + end; + + function HastingsCycle(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Indep : Boolean; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs one cycle of the Metropolis-Hastings algorithm + ---------------------------------------------------------------------- } + var + F, F1 : Float; { Function values } + DeltaF : Float; { Variation of function } + X1 : PVector; { New coordinates } + L : PMatrix; { Standard dev. or Cholesky factor } + I, K : Integer; { Loop variable } + Iter : Integer; { Iteration count } + FirstSavedSim : Integer; { Index of first simulation to be saved } + ErrCode : Integer; { Error code } + begin + { Dimension arrays } + DimVector(X1, Ubound); + DimMatrix(L, Ubound, Ubound); + + { Compute SD's or Cholesky factor } + if Indep then + ErrCode := CalcSD(V, Lbound, Ubound, L) + else + ErrCode := Cholesky(V, Lbound, Ubound, L); + + HastingsCycle := ErrCode; + if ErrCode = MAT_NOT_PD then Exit; + + { Compute initial function value } + F := Func(X); + + { Perform MH_MaxSim simulations at constant temperature } + FirstSavedSim := MH_MaxSim - MH_SavedSim + 1; + Iter := 1; + K := 1; + + repeat + { Generate new vector } + if Indep then + GenIndepRandomVector(X, L, Lbound, Ubound, X1) + else + GenRandomVector(X, L, Lbound, Ubound, X1); + + { Compute new function value } + F1 := Func(X1); + DeltaF := F1 - F; + + { Check for acceptance } + if Accept(DeltaF, T) then + begin + CopyVector(X, X1, Lbound, Ubound); + + if Iter >= FirstSavedSim then + begin + { Save simulated vector into column K of matrix Xmat } + CopyColFromVector(Xmat, X1, Lbound, Ubound, K); + Inc(K); + end; + + if F1 < F_min then + begin + { Update minimum } + CopyVector(X_min, X1, Lbound, Ubound); + F_min := F1; + end; + + F := F1; + Inc(Iter); + end; + until Iter > MH_MaxSim; + + { Update mean vector and variance-covariance matrix } + VecMean(Xmat, MH_SavedSim, Lbound, Ubound, X); + MatVarCov(Xmat, MH_SavedSim, Lbound, Ubound, X, V); + + DelVector(X1, Ubound); + DelMatrix(L, Ubound, Ubound); + end; + + function Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; + var + K, ErrCode : Integer; + Indep : Boolean; + begin + { Initialize the Marsaglia random number generator + using the standard Pascal generator } + Randomize; + RMarIn(System.Random(10000), System.Random(10000)); + + K := 1; + Indep := True; + F_min := MAXNUM; + + repeat + ErrCode := HastingsCycle(Func, T, X, V, Lbound, Ubound, + Indep, Xmat, X_min, F_min); + Indep := False; + Inc(K); + until (ErrCode <> 0) or (K > MH_NCycles); + + Hastings := ErrCode; + end; + +end. \ No newline at end of file diff --git a/niftiview7/tpmath/models.pas b/niftiview7/tpmath/models.pas new file mode 100755 index 0000000..7dfd892 --- /dev/null +++ b/niftiview7/tpmath/models.pas @@ -0,0 +1,530 @@ +{ ********************************************************************** + * Unit MODELS.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Library of regression and variance models + ********************************************************************** } + +unit Models; + +{$F+} + +interface + +uses + FMath, + Matrices, + Regress, + FitLin, + FitMult, + FitPoly, + FitFrac, + FitExpo, + FitIExpo, + FitExLin, + FitPower, + FitMich, + FitHill, + FitLogis, + FitPKa; + +{ --------------------------------------------------------------------- + Highest index of regression models + --------------------------------------------------------------------- } +const + MAXMODEL = 11; + +{ --------------------------------------------------------------------- + Highest index of variance models + --------------------------------------------------------------------- } +const + MAXVARMODEL = 5; + +{ --------------------------------------------------------------------- + Definition of regression models + --------------------------------------------------------------------- } +const + REG_LIN = 0; { Linear } + REG_MULT = 1; { Multiple linear } + REG_POL = 2; { Polynomial } + REG_FRAC = 3; { Rational fraction } + REG_EXPO = 4; { Sum of exponentials } + REG_IEXPO = 5; { Increasing exponential } + REG_EXLIN = 6; { Exponential + linear } + REG_POWER = 7; { Power } + REG_MICH = 8; { Michaelis } + REG_HILL = 9; { Hill } + REG_LOGIS = 10; { Logistic } + REG_PKA = 11; { Acid/Base titration curve } + +{ --------------------------------------------------------------------- + Definition of variance models + --------------------------------------------------------------------- } +const + VAR_CONST = 0; { Constant } + VAR_LIN = 1; { Linear } + VAR_POL2 = 2; { 2nd degree polynomial } + VAR_POL3 = 3; { 3rd degree polynomial } + VAR_EXPO = 4; { Exponential } + VAR_POWER = 5; { Power } + +{ --------------------------------------------------------------------- + Names of regression models + --------------------------------------------------------------------- } + +const + MODELNAME : array[0..MAXMODEL] of String = +{$IFDEF FRENCH} + ('Lineaire', + 'Lineaire multiple', + 'Polynomial', + 'Fraction rationnelle', + 'Somme d''exponentielles', + 'Exponentielle croissante', + 'Exponentielle + lineaire', + 'Puissance', + 'Michaelis', + 'Hill', + 'Logistique', + 'Titrage acide/base'); +{$ELSE} + ('Linear', + 'Multiple linear', + 'Polynomial', + 'Rational fraction', + 'Sum of exponentials', + 'Increasing exponential', + 'Exponential + linear', + 'Power', + 'Michaelis', + 'Hill', + 'Logistic', + 'Acid/Base titration curve'); +{$ENDIF} + +{ --------------------------------------------------------------------- + Names of variance models + --------------------------------------------------------------------- } + +const + VARMODELNAME : array[0..MAXVARMODEL] of String = +{$IFDEF FRENCH} + ('Constante', + 'Lineaire', + 'Polynome de degre 2', + 'Polynome de degre 3', + 'Exponentielle', + 'Puissance'); +{$ELSE} + ('Constant', + 'Linear', + '2nd degree polynomial', + '3rd degree polynomial', + 'Exponential', + 'Power'); +{$ENDIF} + +function FuncName : String; +{ -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + +function FirstParam : Integer; +{ -------------------------------------------------------------------- + Returns the index of the first fitted parameter + -------------------------------------------------------------------- } + +function LastParam : Integer; +{ -------------------------------------------------------------------- + Returns the index of the last fitted parameter + -------------------------------------------------------------------- } + +function ParamName(I : Integer) : String; +{ -------------------------------------------------------------------- + Returns the name of the I-th fitted parameter + -------------------------------------------------------------------- } + +function RegFunc(X : Float; B : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the regression function for one independent variable + B is the vector of parameters + -------------------------------------------------------------------- } + +function RegFuncNVar(X, B : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the regression function for several independent variables + B is the vector of parameters + -------------------------------------------------------------------- } + +procedure DerivProc(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); +{ -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + +procedure InitModel(Reg_Model, Var_Model : Integer; CstPar : PVector); +{ -------------------------------------------------------------------- + Initializes the regression and variance models. Constant parameters + (e.g. degree of polynomial) are passed in vector CstPar. + -------------------------------------------------------------------- } + +function WLSFit(X : PVector; + U : PMatrix; + Y : PVector; + N : Integer; + Init : Boolean; + MaxIter : Integer; + Tol : Float; + Theta, B : PVector; + B_min, B_max : PVector; + V : PMatrix; + Ycalc, S : PVector; + var Test : TRegTest) : Integer; +{ ---------------------------------------------------------------------- + Fits the regression function and computes the regression tests + ---------------------------------------------------------------------- + Input : X, U = vector or matrix of independent variable(s) + Y = vector of dependent variable + N = number of observations + Init = TRUE to compute initial parameter estimates + FALSE to use the current values + MaxIter = maximum number of iterations + (if 0 the parameters will not be refined) + Tol = required parameter precision + Theta = variance parameters + B = initial parameters values + B_min, B_max = parameter bounds + -------------------------------------------------------------------- + Output : Theta = updated variance parameters + (residual variance stored in Theta^[0]) + B = regression parameters + V = variance-covariance matrix + Ycalc = estimated Y values + S = standard deviations of Y + Test = regression tests + -------------------------------------------------------------------- + Possible results = OPT_OK : no error + OPT_SING : singular matrix + OPT_BIG_LAMBDA : too high Marquardt's parameter + OPT_NON_CONV : non-convergence + -------------------------------------------------------------------- } + +function VarFuncName : String; +{ -------------------------------------------------------------------- + Returns the name of the variance function + -------------------------------------------------------------------- } + +function LastVarParam : Integer; +{ ---------------------------------------------------------------------- + Returns the index of the last variance parameter (upper bound of Theta) + ---------------------------------------------------------------------- } + +function VarFunc(Y : Float; Theta : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the variance of an observation Y. The parameters are + Theta^[1], Theta^[2],... The true variance is Theta^[0] * VarFunc, + where Theta^[0] (equal to the residual variance Vr) is estimated by + the regression program. + -------------------------------------------------------------------- } + +implementation + +const + RegModel : Integer = 0; { Index of regression model } + VarModel : Integer = 0; { Index of variance model } + + function FuncName : String; + begin + case RegModel of + REG_LIN : FuncName := FitLin.FuncName; + REG_MULT : FuncName := FitMult.FuncName; + REG_POL : FuncName := FitPoly.FuncName; + REG_FRAC : FuncName := FitFrac.FuncName; + REG_EXPO : FuncName := FitExpo.FuncName; + REG_IEXPO : FuncName := FitIExpo.FuncName; + REG_EXLIN : FuncName := FitExLin.FuncName; + REG_POWER : FuncName := FitPower.FuncName; + REG_MICH : FuncName := FitMich.FuncName; + REG_HILL : FuncName := FitHill.FuncName; + REG_LOGIS : FuncName := FitLogis.FuncName; + REG_PKA : FuncName := FitPKa.FuncName; + end; + end; + + function FirstParam : Integer; + begin + case RegModel of + REG_LIN : FirstParam := FitLin.FirstParam; + REG_MULT : FirstParam := FitMult.FirstParam; + REG_POL : FirstParam := FitPoly.FirstParam; + REG_FRAC : FirstParam := FitFrac.FirstParam; + REG_EXPO : FirstParam := FitExpo.FirstParam; + REG_IEXPO : FirstParam := FitIExpo.FirstParam; + REG_EXLIN : FirstParam := FitExLin.FirstParam; + REG_POWER : FirstParam := FitPower.FirstParam; + REG_MICH : FirstParam := FitMich.FirstParam; + REG_HILL : FirstParam := FitHill.FirstParam; + REG_LOGIS : FirstParam := FitLogis.FirstParam; + REG_PKA : FirstParam := FitPKa.FirstParam; + end; + end; + + function LastParam : Integer; + begin + case RegModel of + REG_LIN : LastParam := FitLin.LastParam; + REG_MULT : LastParam := FitMult.LastParam; + REG_POL : LastParam := FitPoly.LastParam; + REG_FRAC : LastParam := FitFrac.LastParam; + REG_EXPO : LastParam := FitExpo.LastParam; + REG_IEXPO : LastParam := FitIExpo.LastParam; + REG_EXLIN : LastParam := FitExLin.LastParam; + REG_POWER : LastParam := FitPower.LastParam; + REG_MICH : LastParam := FitMich.LastParam; + REG_HILL : LastParam := FitHill.LastParam; + REG_LOGIS : LastParam := FitLogis.LastParam; + REG_PKA : LastParam := FitPKa.LastParam; + end; + end; + + function ParamName(I : Integer) : String; + begin + case RegModel of + REG_LIN : ParamName := FitLin.ParamName(I); + REG_MULT : ParamName := FitMult.ParamName(I); + REG_POL : ParamName := FitPoly.ParamName(I); + REG_FRAC : ParamName := FitFrac.ParamName(I); + REG_EXPO : ParamName := FitExpo.ParamName(I); + REG_IEXPO : ParamName := FitIExpo.ParamName(I); + REG_EXLIN : ParamName := FitExLin.ParamName(I); + REG_POWER : ParamName := FitPower.ParamName(I); + REG_MICH : ParamName := FitMich.ParamName(I); + REG_HILL : ParamName := FitHill.ParamName(I); + REG_LOGIS : ParamName := FitLogis.ParamName(I); + REG_PKA : ParamName := FitPKa.ParamName(I); + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + begin + case RegModel of + REG_LIN : RegFunc := FitLin.RegFunc(X, B); + REG_POL : RegFunc := FitPoly.RegFunc(X, B); + REG_FRAC : RegFunc := FitFrac.RegFunc(X, B); + REG_EXPO : RegFunc := FitExpo.RegFunc(X, B); + REG_IEXPO : RegFunc := FitIExpo.RegFunc(X, B); + REG_EXLIN : RegFunc := FitExLin.RegFunc(X, B); + REG_POWER : RegFunc := FitPower.RegFunc(X, B); + REG_MICH : RegFunc := FitMich.RegFunc(X, B); + REG_HILL : RegFunc := FitHill.RegFunc(X, B); + REG_LOGIS : RegFunc := FitLogis.RegFunc(X, B); + REG_PKA : RegFunc := FitPKa.RegFunc(X, B); + end; + end; + + function RegFuncNVar(X, B : PVector) : Float; + begin + case RegModel of + REG_MULT : RegFuncNVar := FitMult.RegFunc(X, B); + end; + end; + + procedure DerivProc(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + begin + case RegModel of + REG_FRAC : FitFrac.DerivProc(X, Y, B, D); + REG_EXPO : FitExpo.DerivProc(X, B, D); + REG_IEXPO : FitIExpo.DerivProc(X, B, D); + REG_EXLIN : FitExLin.DerivProc(X, B, D); + REG_POWER : FitPower.DerivProc(X, Y, B, D); + REG_MICH : FitMich.DerivProc(X, Y, B, D); + REG_HILL : FitHill.DerivProc(X, Y, B, D); + REG_LOGIS : FitLogis.DerivProc(X, B, D); + REG_PKA : FitPKa.DerivProc(X, B, D); + else + NumDeriv(RegFunc, X, Y, B, D); + end; + end; + + procedure InitModel(Reg_Model, Var_Model : Integer; CstPar : PVector); + begin + RegModel := Reg_Model; + VarModel := Var_Model; + case RegModel of + REG_MULT : FitMult.InitModel(CstPar); + REG_POL : FitPoly.InitModel(CstPar); + REG_FRAC : FitFrac.InitModel(CstPar); + REG_EXPO : FitExpo.InitModel(CstPar); + REG_LOGIS : FitLogis.InitModel(CstPar); + end; + end; + + function FitModel(Method : Integer; + X : PVector; + U : PMatrix; + Y, W : PVector; + N : Integer; + B : PVector; + V : PMatrix) : Integer; +{ -------------------------------------------------------------------- + Fits the regression model by unweighted linear least squares. For + nonlinear models, this is only an approximate fit, to be refined by + the nonlinear regression procedure WLSFit + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, U = vector or matrix of independent variable(s) + Y = vector of dependent variable + W = weights + N = number of observations + -------------------------------------------------------------------- + Output : B = estimated regression parameters + V = unscaled variance-covariance matrix (for linear + and polynomial models only). The true matrix will + be Vr * V, where Vr is the residual variance. + -------------------------------------------------------------------- + The function returns 0 if no error occurred + -------------------------------------------------------------------- } + begin + case RegModel of + REG_LIN : FitModel := FitLin.FitModel(Method, X, Y, W, N, B, V); + REG_MULT : FitModel := FitMult.FitModel(Method, U, Y, W, N, B, V); + REG_POL : FitModel := FitPoly.FitModel(Method, X, Y, W, N, B, V); + REG_FRAC : FitModel := FitFrac.FitModel(Method, X, Y, W, N, B); + REG_EXPO : FitModel := FitExpo.FitModel(Method, X, Y, W, N, B); + REG_IEXPO : FitModel := FitIExpo.FitModel(Method, X, Y, W, N, B); + REG_EXLIN : FitModel := FitExLin.FitModel(X, Y, N, B); + REG_POWER : FitModel := FitPower.FitModel(Method, X, Y, W, N, B); + REG_MICH : FitModel := FitMich.FitModel(Method, X, Y, W, N, B); + REG_HILL : FitModel := FitHill.FitModel(Method, X, Y, W, N, B); + REG_LOGIS : FitModel := FitLogis.FitModel(Method, X, Y, W, N, B); + REG_PKA : FitModel := FitPKa.FitModel(X, Y, N, B); + end; + end; + + function WLSFit(X : PVector; + U : PMatrix; + Y : PVector; + N : Integer; + Init : Boolean; + MaxIter : Integer; + Tol : Float; + Theta, B : PVector; + B_min, B_max : PVector; + V : PMatrix; + Ycalc, S : PVector; + var Test : TRegTest) : Integer; + var + Method : Integer; { Regression method } + W : PVector; { Weights } + Xk : PVector; { Vector of variables for observation k } + Sr : Float; { Residual standard deviation } + ErrCode : Integer; { Error code } + K : Integer; { Loop variable } + begin + DimVector(W, N); + DimVector(Xk, LastParam); + + { Determine regression method } + if VarModel = VAR_CONST then Method := 0 else Method := 1; + + { Compute weights if necessary } + if Method = 1 then + for K := 1 to N do + W^[K] := 1.0 / VarFunc(Y^[K], Theta); + + { Compute initial parameter estimates if necessary } + if Init then + ErrCode := FitModel(Method, X, U, Y, W, N, B, V) + else + ErrCode := 0; + + { Refine parameters if necessary } + if not(RegModel in [REG_LIN, REG_MULT, REG_POL]) and + (MaxIter > 0) and (ErrCode = 0) then + if VarModel = VAR_CONST then + ErrCode := NLFit({$IFDEF FPK}@{$ENDIF}RegFunc, + {$IFDEF FPK}@{$ENDIF}DerivProc, + X, Y, N, FirstParam, LastParam, + MaxIter, Tol, B, B_min, B_max, V) + else + ErrCode := WNLFit({$IFDEF FPK}@{$ENDIF}RegFunc, + {$IFDEF FPK}@{$ENDIF}DerivProc, + X, Y, W, N, FirstParam, LastParam, + MaxIter, Tol, B, B_min, B_max, V); + + if ErrCode = 0 then + begin + { Estimate Y values } + if RegModel = REG_MULT then + for K := 1 to N do + begin + CopyVectorFromCol(Xk, U, FirstParam, LastParam, K); + Ycalc^[K] := RegFuncNVar(Xk, B); + end + else + for K := 1 to N do + Ycalc^[K] := RegFunc(X^[K], B); + + { Compute regression tests and update variance-covariance matrix } + if VarModel = VAR_CONST then + RegTest(Y, Ycalc, N, FirstParam, LastParam, V, Test) + else + WRegTest(Y, Ycalc, W, N, FirstParam, LastParam, V, Test); + + { Store residual variance in Theta^[0] } + Theta^[0] := Test.Vr; + + { Compute standard deviations } + Sr := Sqrt(Test.Vr); + for K := 1 to N do + S^[K] := Sr; + if VarModel <> VAR_CONST then + for K := 1 to N do + S^[K] := S^[K] / Sqrt(W^[K]); + end; + + DelVector(W, N); + DelVector(Xk, LastParam); + + WLSFit := ErrCode; + end; + + function VarFuncName : String; + begin + case VarModel of + VAR_CONST : VarFuncName := 'v = e0'; + VAR_LIN : VarFuncName := 'v = e0.(1 + e1.y)'; + VAR_POL2 : VarFuncName := 'v = e0.(1 + e1.y + e2.y^2)'; + VAR_POL3 : VarFuncName := 'v = e0.(1 + e1.y + e2.y^2 + e3.y^3)'; + VAR_EXPO : VarFuncName := 'v = e0.exp(e1.y)'; + VAR_POWER : VarFuncName := 'v = e0.y^e1'; + end; + end; + + function VarFunc(Y : Float; Theta : PVector) : Float; + begin + case VarModel of + VAR_CONST : VarFunc := 1.0; + VAR_LIN : VarFunc := 1.0 + Theta^[1] * Y; + VAR_POL2 : VarFunc := 1.0 + Y * (Theta^[1] + Theta^[2] * Y); + VAR_POL3 : VarFunc := 1.0 + Y * (Theta^[1] + Y * (Theta^[2] + Theta^[3] * Y)); + VAR_EXPO : VarFunc := Exp(Theta^[1] * Y); + VAR_POWER : VarFunc := Power(Y, Theta^[1]); + end; + end; + + function LastVarParam : Integer; + begin + case VarModel of + VAR_CONST : LastVarParam := 0; + VAR_LIN : LastVarParam := 1; + VAR_POL2 : LastVarParam := 2; + VAR_POL3 : LastVarParam := 3; + VAR_EXPO : LastVarParam := 1; + VAR_POWER : LastVarParam := 1; + end; + end; + +end. diff --git a/niftiview7/tpmath/optim.pas b/niftiview7/tpmath/optim.pas new file mode 100755 index 0000000..17575b0 --- /dev/null +++ b/niftiview7/tpmath/optim.pas @@ -0,0 +1,972 @@ +{ ********************************************************************** + * Unit OPTIM.PAS * + * Version 2.1 * + * (c) J. Debord, June 2001 * + ********************************************************************** + This unit implements the following methods for function minimization: + + * Golden search for a function of one variable + * Simplex, Marquardt, BFGS for a function of several variables + ********************************************************************** + References: + 1) 'Numerical Recipes' by Press et al. + 2) D. W. MARQUARDT, J. Soc. Indust. Appl. Math., 1963, 11, 431-441 + 3) J. A. NELDER & R. MEAD, Comput. J., 1964, 7, 308-313 + 4) R. O'NEILL, Appl. Statist., 1971, 20, 338-345 + ********************************************************************** } + +unit Optim; + +interface + +uses + FMath, Matrices; + +{ ********************************************************************** + Error codes + ********************************************************************** } + +const + OPT_OK = 0; { No error } + OPT_SING = - 1; { Singular hessian matrix } + OPT_BIG_LAMBDA = - 2; { Too high Marquardt's parameter } + OPT_NON_CONV = - 3; { Non-convergence } + +{ ********************************************************************** + Functional types + ********************************************************************** } + +type + { Function of several variables } + TFuncNVar = function(X : PVector) : Float; + + { Procedure to compute gradient vector } + TGradient = procedure(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); + + { Procedure to compute gradient vector and hessian matrix } + THessGrad = procedure(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); + +{ ********************************************************************** + Log file + ********************************************************************** } + +const + WriteLogFile : Boolean = False; { Write iteration info to log file } + LogFileName : String = 'optim.log'; { Name of log file } + +{ ********************************************************************** + Minimization routines + ********************************************************************** } + +function GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs a golden search for the minimum of function Func + ---------------------------------------------------------------------- + Input parameters : Func = objective function + A, B = two points near the minimum + MaxIter = maximum number of iterations + Tol = required precision (should not be less than + the square root of the machine precision) + ---------------------------------------------------------------------- + Output parameters : Xmin, Ymin = coordinates of minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + +{ ---------------------------------------------------------------------- + Minimizes function Func from point X in the direction specified by + DeltaX + ---------------------------------------------------------------------- + Input parameters : Func = objective function + X = initial minimum coordinates + DeltaX = direction in which minimum is searched + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function Simplex(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by the simplex method + of Nelder and Mead + ---------------------------------------------------------------------- + Input parameters : Func = objective function + X = initial minimum coordinates + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +procedure NumGradient(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); +{ ---------------------------------------------------------------------- + Computes the gradient vector of a function of several variables by + numerical differentiation + ---------------------------------------------------------------------- + Input parameters : Func = function of several variables + X = vector of variables + Lbound, + Ubound = indices of first and last variables + ---------------------------------------------------------------------- + Output parameter : G = gradient vector + ---------------------------------------------------------------------- } + +procedure NumHessGrad(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); +{ ---------------------------------------------------------------------- + Computes gradient vector & hessian matrix by numerical differentiation + ---------------------------------------------------------------------- + Input parameters : as in NumGradient + ---------------------------------------------------------------------- + Output parameters : G = gradient vector + H = hessian matrix + ---------------------------------------------------------------------- } + +function Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by Marquardt's method + ---------------------------------------------------------------------- + Input parameters : Func = objective function + HessGrad = procedure to compute gradient & hessian + X = initial minimum coordinates + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + H_inv = inverse hessian matrix + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_SING + OPT_BIG_LAMBDA + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by the + Broyden-Fletcher-Goldfarb-Shanno method + ---------------------------------------------------------------------- + Parameters : Gradient = procedure to compute gradient vector + Other parameters as in Marquardt + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + +var + Eps : Float; { Fractional increment for numer. derivation } + X1 : PVector; { Initial point for line minimization } + DeltaX1 : PVector; { Direction for line minimization } + Lbound1, Ubound1 : Integer; { Bounds of X1 and DeltaX1 } + LinObjFunc : TFuncNVar; { Objective function for line minimization } + LogFile : Text; { Stores the result of each minimization step } + + + procedure MinBrack(Func : TFunc; var A, B, C, Fa, Fb, Fc : Float); +{ ---------------------------------------------------------------------- + Given two points (A, B) this procedure finds a triplet (A, B, C) + such that: + + 1) A < B < C + 2) A, B, C are within the golden ratio + 3) Func(B) < Func(A) and Func(B) < Func(C). + + The corresponding function values are returned in Fa, Fb, Fc + ---------------------------------------------------------------------- } + + begin + if A > B then + FSwap(A, B); + Fa := Func(A); + Fb := Func(B); + if Fb > Fa then + begin + FSwap(A, B); + FSwap(Fa, Fb); + end; + C := B + GOLD * (B - A); + Fc := Func(C); + while Fc < Fb do + begin + A := B; + B := C; + Fa := Fb; + Fb := Fc; + C := B + GOLD * (B - A); + Fc := Func(C); + end; + if A > C then + begin + FSwap(A, C); + FSwap(Fa, Fc); + end; + end; + + function GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float) : Integer; + var + C, Fa, Fb, Fc, F1, F2, MinTol, X0, X1, X2, X3 : Float; + Iter : Integer; + begin + MinTol := Sqrt(MACHEP); + if Tol < MinTol then Tol := MinTol; + MinBrack(Func, A, B, C, Fa, Fb, Fc); + X0 := A; + X3 := C; + if (C - B) > (B - A) then + begin + X1 := B; + X2 := B + CGOLD * (C - B); + F1 := Fb; + F2 := Func(X2); + end + else + begin + X1 := B - CGOLD * (B - A); + X2 := B; + F1 := Func(X1); + F2 := Fb; + end; + Iter := 0; + while (Iter <= MaxIter) and (Abs(X3 - X0) > Tol * (Abs(X1) + Abs(X2))) do + if F2 < F1 then + begin + X0 := X1; + X1 := X2; + F1 := F2; + X2 := X1 + CGOLD * (X3 - X1); + F2 := Func(X2); + Inc(Iter); + end + else + begin + X3 := X2; + X2 := X1; + F2 := F1; + X1 := X2 - CGOLD * (X2 - X0); + F1 := Func(X1); + Inc(Iter); + end; + if F1 < F2 then + begin + Xmin := X1; + Ymin := F1; + end + else + begin + Xmin := X2; + Ymin := F2; + end; + if Iter > MaxIter then + GoldSearch := OPT_NON_CONV + else + GoldSearch := OPT_OK; + end; + + procedure CreateLogFile; + begin + Assign(LogFile, LogFileName); + Rewrite(LogFile); + end; + + function Simplex(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + const + STEP = 1.50; { Step used to construct the initial simplex } + var + P : PMatrix; { Simplex coordinates } + F : PVector; { Function values } + Pbar : PVector; { Centroid coordinates } + Pstar, P2star : PVector; { New vertices } + Ystar, Y2star : Float; { New function values } + F0 : Float; { Function value at minimum } + N : Integer; { Number of parameters } + M : Integer; { Index of last vertex } + L, H : Integer; { Vertices with lowest & highest F values } + I, J : Integer; { Loop variables } + Iter : Integer; { Iteration count } + Corr, MaxCorr : Float; { Corrections } + Sum : Float; + Flag : Boolean; + + procedure UpdateSimplex(Y : Float; Q : PVector); + { Update "worst" vertex and function value } + begin + F^[H] := Y; + CopyVector(P^[H], Q, Lbound, Ubound); + end; + + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'Simplex'); + WriteLn(LogFile, 'Iter F'); + end; + + N := Ubound - Lbound + 1; + M := Succ(Ubound); + + DimMatrix(P, M, Ubound); + DimVector(F, M); + DimVector(Pbar, Ubound); + DimVector(Pstar, Ubound); + DimVector(P2star, Ubound); + + Iter := 1; + F0 := MAXNUM; + + { Construct initial simplex } + for I := Lbound to M do + CopyVector(P^[I], X, Lbound, Ubound); + for I := Lbound to Ubound do + P^[I]^[I] := P^[I]^[I] * STEP; + + { Evaluate function at each vertex } + for I := Lbound to M do + F^[I] := Func(P^[I]); + + repeat + { Find vertices (L,H) having the lowest and highest + function values, i.e. "best" and "worst" vertices } + L := Lbound; + H := Lbound; + for I := Succ(Lbound) to M do + if F^[I] < F^[L] then + L := I + else if F^[I] > F^[H] then + H := I; + if F^[L] < F0 then + F0 := F^[L]; + + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F0:12); + + { Find centroid of points other than P(H) } + for J := Lbound to Ubound do + begin + Sum := 0.0; + for I := Lbound to M do + if I <> H then Sum := Sum + P^[I]^[J]; + Pbar^[J] := Sum / N; + end; + + { Reflect worst vertex through centroid } + for J := Lbound to Ubound do + Pstar^[J] := 2.0 * Pbar^[J] - P^[H]^[J]; + Ystar := Func(Pstar); + + { If reflection successful, try extension } + if Ystar < F^[L] then + begin + for J := Lbound to Ubound do + P2star^[J] := 3.0 * Pstar^[J] - 2.0 * Pbar^[J]; + Y2star := Func(P2star); + + { Retain extension or contraction } + if Y2star < F^[L] then + UpdateSimplex(Y2star, P2star) + else + UpdateSimplex(Ystar, Pstar); + end + else + begin + I := Lbound; + Flag := False; + repeat + if (I <> H) and (F^[I] > Ystar) then Flag := True; + Inc(I); + until Flag or (I > M); + if Flag then + UpdateSimplex(Ystar, Pstar) + else + begin + { Contraction on the reflection side of the centroid } + if Ystar <= F^[H] then + UpdateSimplex(Ystar, Pstar); + + { Contraction on the opposite side of the centroid } + for J := Lbound to Ubound do + P2star^[J] := 0.5 * (P^[H]^[J] + Pbar^[J]); + Y2star := Func(P2star); + if Y2star <= F^[H] then + UpdateSimplex(Y2star, P2star) + else + { Contract whole simplex } + for I := Lbound to M do + for J := Lbound to Ubound do + P^[I]^[J] := 0.5 * (P^[I]^[J] + P^[L]^[J]); + end; + end; + + { Test convergence } + MaxCorr := 0.0; + for J := Lbound to Ubound do + begin + Corr := Abs(P^[H]^[J] - P^[L]^[J]); + if Corr > MaxCorr then MaxCorr := Corr; + end; + Inc(Iter); + until (MaxCorr < Tol) or (Iter > MaxIter); + + CopyVector(X, P^[L], Lbound, Ubound); + F_min := F^[L]; + + DelMatrix(P, M, Ubound); + DelVector(F, M); + DelVector(Pbar, Ubound); + DelVector(Pstar, Ubound); + DelVector(P2star, Ubound); + + if WriteLogFile then + Close(LogFile); + + if Iter > MaxIter then + Simplex := OPT_NON_CONV + else + Simplex := OPT_OK; + end; + + {$F+} + function F1dim(R : Float) : Float; +{ ---------------------------------------------------------------------- + Function used by LinMin to find the minimum of the objective function + LinObjFunc in the direction specified by the global variables X1 and + DeltaX1. R is the step in this direction. + ---------------------------------------------------------------------- } + const + Xt : PVector = nil; + var + I : Integer; + begin + if Xt = nil then + DimVector(Xt, Ubound1); + for I := Lbound1 to Ubound1 do + Xt^[I] := X1^[I] + R * DeltaX1^[I]; + F1dim := LinObjFunc(Xt); + end; + {$F-} + + function LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + var + I, ErrCode : Integer; + R : Float; + begin + { Redimension global vectors } + DelVector(X1, Ubound1); + DelVector(DeltaX1, Ubound1); + DimVector(X1, Ubound); + DimVector(DeltaX1, Ubound); + + Lbound1 := Lbound; + Ubound1 := Ubound; + + { Initialize global variables } + LinObjFunc := Func; + for I := Lbound to Ubound do + begin + X1^[I] := X^[I]; + DeltaX1^[I] := DeltaX^[I] + end; + + { Perform golden search } + ErrCode := GoldSearch({$IFDEF FPK}@{$ENDIF}F1dim, + 0.0, 1.0, MaxIter, Tol, R, F_min); + + { Update variables } + if ErrCode = OPT_OK then + for I := Lbound to Ubound do + X^[I] := X^[I] + R * DeltaX^[I]; + + LinMin := ErrCode; + end; + + {$F+} + procedure NumGradient(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); + var + Temp, Delta, Fplus, Fminus : Float; + I : Integer; + begin + for I := Lbound to Ubound do + begin + Temp := X^[I]; + if Temp <> 0.0 then Delta := Eps * Abs(Temp) else Delta := Eps; + X^[I] := Temp - Delta; + Fminus := Func(X); + X^[I] := Temp + Delta; + Fplus := Func(X); + G^[I] := (Fplus - Fminus) / (2.0 * Delta); + X^[I] := Temp; + end; + end; + {$F-} + + {$F+} + procedure NumHessGrad(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); + var + Delta, Xminus, Xplus, Fminus, Fplus : PVector; + Temp1, Temp2, F, F2plus : Float; + I, J : Integer; + begin + DimVector(Delta, Ubound); { Increments } + DimVector(Xminus, Ubound); { X - Delta } + DimVector(Xplus, Ubound); { X + Delta } + DimVector(Fminus, Ubound); { F(X - Delta) } + DimVector(Fplus, Ubound); { F(X + Delta) } + + F := Func(X); + + for I := Lbound to Ubound do + begin + if X^[I] <> 0.0 then + Delta^[I] := Eps * Abs(X^[I]) + else + Delta^[I] := Eps; + Xplus^[I] := X^[I] + Delta^[I]; + Xminus^[I] := X^[I] - Delta^[I]; + end; + + for I := Lbound to Ubound do + begin + Temp1 := X^[I]; + X^[I] := Xminus^[I]; + Fminus^[I] := Func(X); + X^[I] := Xplus^[I]; + Fplus^[I] := Func(X); + X^[I] := Temp1; + end; + + for I := Lbound to Ubound do + begin + G^[I] := (Fplus^[I] - Fminus^[I]) / (2.0 * Delta^[I]); + H^[I]^[I] := (Fplus^[I] + Fminus^[I] - 2.0 * F) / Sqr(Delta^[I]); + end; + + for I := Lbound to Pred(Ubound) do + begin + Temp1 := X^[I]; + X^[I] := Xplus^[I]; + for J := Succ(I) to Ubound do + begin + Temp2 := X^[J]; + X^[J] := Xplus^[J]; + F2plus := Func(X); + H^[I]^[J] := (F2plus - Fplus^[I] - Fplus^[J] + F) / (Delta^[I] * Delta^[J]); + H^[J]^[I] := H^[I]^[J]; + X^[J] := Temp2; + end; + X^[I] := Temp1; + end; + + DelVector(Delta, Ubound); + DelVector(Xminus, Ubound); + DelVector(Xplus, Ubound); + DelVector(Fminus, Ubound); + DelVector(Fplus, Ubound); + end; + {$F-} + + function ParamConv(OldX, X : PVector; + Lbound, Ubound : Integer; + Tol : Float) : Boolean; +{ ---------------------------------------------------------------------- + Check for convergence on parameters + ---------------------------------------------------------------------- } + var + I : Integer; + Conv : Boolean; + begin + I := Lbound; + Conv := True; + repeat + Conv := Conv and (Abs(X^[I] - OldX^[I]) < FMax(Tol, Tol * Abs(OldX^[I]))); + Inc(I); + until (Conv = False) or (I > Ubound); + ParamConv := Conv; + end; + + function Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; + const + LAMBDA0 = 1.0E-2; { Initial lambda value } + LAMBDAMAX = 1.0E+3; { Highest lambda value } + FTOL = 1.0E-10; { Tolerance on function decrease } + var + Lambda, + Lambda1 : Float; { Marquardt's lambda } + I : Integer; { Loop variable } + OldX : PVector; { Old parameters } + G : PVector; { Gradient vector } + H : PMatrix; { Hessian matrix } + A : PMatrix; { Modified Hessian matrix } + DeltaX : PVector; { New search direction } + F1 : Float; { New minimum } + Lambda_Ok : Boolean; { Successful Lambda decrease } + Conv : Boolean; { Convergence reached } + Done : Boolean; { Iterations done } + Iter : Integer; { Iteration count } + ErrCode : Integer; { Error code } + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'Marquardt'); + WriteLn(LogFile, 'Iter F Lambda'); + end; + + Lambda := LAMBDA0; + ErrCode := OPT_OK; + + DimVector(OldX, Ubound); + DimVector(G, Ubound); + DimMatrix(H, Ubound, Ubound); + DimMatrix(A, Ubound, Ubound); + DimVector(DeltaX, Ubound); + + F_min := Func(X); { Initial function value } + LinObjFunc := Func; { Function for line minimization } + + Iter := 1; + Conv := False; + Done := False; + + repeat + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12, ' ', Lambda:12); + + { Save current parameters } + CopyVector(OldX, X, Lbound, Ubound); + + { Compute Gradient and Hessian } + HessGrad(Func, X, Lbound, Ubound, G, H); + CopyMatrix(A, H, Lbound, Lbound, Ubound, Ubound); + + { Change sign of gradient } + for I := Lbound to Ubound do + G^[I] := - G^[I]; + + if Conv then { Newton-Raphson iteration } + begin + ErrCode := GaussJordan(A, G, Lbound, Ubound, H_inv, DeltaX); + if ErrCode = MAT_OK then + for I := Lbound to Ubound do + X^[I] := OldX^[I] + DeltaX^[I]; + Done := True; + end + else { Marquardt iteration } + begin + repeat + { Multiply each diagonal term of H by (1 + Lambda) } + Lambda1 := 1.0 + Lambda; + for I := Lbound to Ubound do + A^[I]^[I] := Lambda1 * H^[I]^[I]; + + ErrCode := GaussJordan(A, G, Lbound, Ubound, H_inv, DeltaX); + + if ErrCode = MAT_OK then + begin + { Initialize parameters } + CopyVector(X, OldX, Lbound, Ubound); + + { Minimize in the direction specified by DeltaX } + ErrCode := LinMin(Func, X, DeltaX, + Lbound, Ubound, 100, 0.01, F1); + + { Check that the function has decreased. Otherwise + increase Lambda, without exceeding LAMBDAMAX } + Lambda_Ok := (F1 - F_min) < F_min * FTOL; + if not Lambda_Ok then Lambda := 10.0 * Lambda; + if Lambda > LAMBDAMAX then ErrCode := OPT_BIG_LAMBDA; + end; + until Lambda_Ok or (ErrCode <> MAT_OK); + + { Check for convergence } + Conv := ParamConv(OldX, X, Lbound, Ubound, Tol); + + { Prepare next iteration } + Lambda := 0.1 * Lambda; + F_min := F1; + end; + + Inc(Iter); + if Iter > MaxIter then ErrCode := OPT_NON_CONV; + until Done or (ErrCode <> OPT_OK); + + DelVector(OldX, Ubound); + DelVector(G, Ubound); + DelMatrix(H, Ubound, Ubound); + DelMatrix(A, Ubound, Ubound); + DelVector(DeltaX, Ubound); + + if WriteLogFile then + Close(LogFile); + + if ErrCode = MAT_SINGUL then ErrCode := OPT_SING; + Marquardt := ErrCode; + end; + + function BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; + var + I, J, Iter, ErrCode : Integer; + DeltaXmax, Gmax, P1, P2, R1, R2 : Float; + OldX, DeltaX, dX, G, OldG, dG, HdG, R1dX, R2HdG, U, P2U : PVector; + Conv : Boolean; + + function AbsMax(V : PVector; Lbound, Ubound : Integer) : Float; + { Returns the component with maximum absolute value } + var + I : Integer; + AbsV : PVector; + begin + DimVector(AbsV, Ubound); + for I := Lbound to Ubound do + AbsV^[I] := Abs(V^[I]); + AbsMax := Max(AbsV, Lbound, Ubound); + DelVector(AbsV, Ubound); + end; + + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'BFGS'); + WriteLn(LogFile, 'Iter F'); + end; + + DimVector(OldX, Ubound); + DimVector(DeltaX, Ubound); + DimVector(dX, Ubound); + DimVector(G, Ubound); + DimVector(OldG, Ubound); + DimVector(dG, Ubound); + DimVector(HdG, Ubound); + DimVector(R1dX, Ubound); + DimVector(R2HdG, Ubound); + DimVector(U, Ubound); + DimVector(P2U, Ubound); + + Iter := 0; + Conv := False; + LinObjFunc := Func; { Function for line minimization } + + { Initialize function } + F_min := Func(X); + + { Initialize inverse hessian to unit matrix } + for I := Lbound to Ubound do + for J := Lbound to Ubound do + if I = J then H_inv^[I]^[J] := 1.0 else H_inv^[I]^[J] := 0.0; + + { Initialize gradient } + Gradient(Func, X, Lbound, Ubound, G); + Gmax := AbsMax(G, Lbound, Ubound); + + { Initialize search direction } + if Gmax > MACHEP then + for I := Lbound to Ubound do + DeltaX^[I] := - G^[I] + else + Conv := True; { Quit if gradient is already small } + + while (not Conv) and (Iter < MaxIter) do + begin + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12); + + { Normalize search direction to avoid excessive displacements } + DeltaXmax := AbsMax(DeltaX, Lbound, Ubound); + if DeltaXmax > 1.0 then + for I := Lbound to Ubound do + DeltaX^[I] := DeltaX^[I] / DeltaXmax; + + { Save old parameters and gradient } + CopyVector(OldX, X, Lbound, Ubound); + CopyVector(OldG, G, Lbound, Ubound); + + { Minimize along the direction specified by DeltaX } + ErrCode := LinMin(Func, X, DeltaX, Lbound, Ubound, 100, 0.01, F_min); + + { Compute new gradient } + Gradient(Func, X, Lbound, Ubound, G); + + { Compute differences between two successive + estimations of parameter vector and gradient vector } + for I := Lbound to Ubound do + begin + dX^[I] := X^[I] - OldX^[I]; + dG^[I] := G^[I] - OldG^[I]; + end; + + { Multiply by inverse hessian } + for I := Lbound to Ubound do + begin + HdG^[I] := 0.0; + for J := Lbound to Ubound do + HdG^[I] := HdG^[I] + H_inv^[I]^[J] * dG^[J]; + end; + + { Scalar products in denominator of BFGS formula } + P1 := 0.0; P2 := 0.0; + for I := Lbound to Ubound do + begin + P1 := P1 + dX^[I] * dG^[I]; + P2 := P2 + dG^[I] * HdG^[I]; + end; + + if (P1 = 0.0) or (P2 = 0.0) then + Conv := True + else + begin + { Inverses of scalar products } + R1 := 1.0 / P1; R2 := 1.0 / P2; + + { Compute BFGS correction terms } + for I := Lbound to Ubound do + begin + R1dX^[I] := R1 * dX^[I]; + R2HdG^[I] := R2 * HdG^[I]; + U^[I] := R1dX^[I] - R2HdG^[I]; + P2U^[I] := P2 * U^[I]; + end; + + { Update inverse hessian } + for I := Lbound to Ubound do + for J := Lbound to Ubound do + H_inv^[I]^[J] := H_inv^[I]^[J] + R1dX^[I] * dX^[J] + - R2HdG^[I] * HdG^[J] + P2U^[I] * U^[J]; + + { Update search direction } + for I := Lbound to Ubound do + begin + DeltaX^[I] := 0.0; + for J := Lbound to Ubound do + DeltaX^[I] := DeltaX^[I] - H_inv^[I]^[J] * G^[J]; + end; + + { Test convergence and update iteration count } + Conv := ParamConv(OldX, X, Lbound, Ubound, Tol); + Inc(Iter); + end; + end; + + DelVector(OldX, Ubound); + DelVector(DeltaX, Ubound); + DelVector(dX, Ubound); + DelVector(G, Ubound); + DelVector(OldG, Ubound); + DelVector(dG, Ubound); + DelVector(HdG, Ubound); + DelVector(R1dX, Ubound); + DelVector(R2HdG, Ubound); + DelVector(U, Ubound); + DelVector(P2U, Ubound); + + if WriteLogFile then + Close(LogFile); + + if Iter > MaxIter then + BFGS := OPT_NON_CONV + else + BFGS := OPT_OK; + end; + +begin + X1 := nil; + DeltaX1 := nil; + Ubound1 := 1; + Eps := Power(MACHEP, 0.333); +end. diff --git a/niftiview7/tpmath/pastring.pas b/niftiview7/tpmath/pastring.pas new file mode 100755 index 0000000..97881ab --- /dev/null +++ b/niftiview7/tpmath/pastring.pas @@ -0,0 +1,275 @@ +{ ********************************************************************** + * Unit PASTRING.PAS * + * Version 1.8 * + * (c) J. Debord, December 2000 * + ********************************************************************** + Turbo Pascal string routines + ********************************************************************** } + +unit PaString; + +interface + +uses + FMath, FComp, Matrices; + +{ *** Global variables controlling the appearance of a numeric string ** } + +const + NumLength : Integer = 10; { Length of a numeric field } + MaxDec : Integer = 4; { Max. number of decimal places } + FloatPoint : Boolean = False; { Floating point notation } + NSZero : Boolean = True; { Write non significant zero's } + +{ ************************** String routines *************************** } + +function LTrim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes leading blanks + ---------------------------------------------------------------------- } + +function RTrim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes trailing blanks + ---------------------------------------------------------------------- } + +function Trim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes leading and trailing blanks + ---------------------------------------------------------------------- } + +function StrChar(N : Byte; C : Char) : String; +{ ---------------------------------------------------------------------- + Returns a string made of character C repeated N times + ---------------------------------------------------------------------- } + +function RFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with trailing blanks for a total length L + ---------------------------------------------------------------------- } + +function LFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with leading blanks for a total length L + ---------------------------------------------------------------------- } + +function CFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with leading blanks + to center the string on a total length L + ---------------------------------------------------------------------- } + +function Replace(S : String; C1, C2 : Char) : String; +{ ---------------------------------------------------------------------- + Replaces in string S all the occurences + of character C1 by character C2 + ---------------------------------------------------------------------- } + +function Extract(S : String; var Index : Byte; Delim : Char) : String; +{ ---------------------------------------------------------------------- + Extracts a field from a string. Index is the position of the first + character of the field. Delim is the character used to separate + fields (e.g. blank, comma or tabulation). Blanks immediately + following Delim are ignored. Index is updated to the position of + the next field. + ---------------------------------------------------------------------- } + +procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); +{ ---------------------------------------------------------------------- + Parses a string into its constitutive fields. Delim is the field + separator. The number of fields is returned in N. The fields are + returned in Field^[0]..Field^[N - 1]. Field must be dimensioned in + the calling program. + ---------------------------------------------------------------------- } + +function FloatToStr(X : Float) : String; +{ ---------------------------------------------------------------------- + Converts a real to a string according to the values of the global + variables NumLength, MaxDec, FloatPoint and NSZero + ---------------------------------------------------------------------- } + +function IntToStr(N : LongInt) : String; +{ ---------------------------------------------------------------------- + Converts an integer to a string according to the values of the global + variables NumLength and MaxDec. + ---------------------------------------------------------------------- } + +function CompToStr(Z : Complex) : String; +{ ---------------------------------------------------------------------- + Converts a complex number to a string. + ---------------------------------------------------------------------- } + +implementation + + function LTrim(S : String) : String; + begin + if S <> '' then + repeat + if S[1] = ' ' then Delete(S, 1, 1); + until S[1] <> ' '; + LTrim := S; + end; + + function RTrim(S : String) : String; + var + L1 : Byte; + begin + if S <> '' then + repeat + L1 := Length(S); + if S[L1] = ' ' then Delete(S, L1, 1); + until S[L1] <> ' '; + RTrim := S; + end; + + function Trim(S : String) : String; + begin + Trim := LTrim(RTrim(S)); + end; + + function StrChar(N : Byte; C : Char) : String; + var + I : Byte; + S : String; + begin + S := ''; + for I := 1 to N do + S := S + C; + StrChar := S; + end; + + function RFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + RFill := S + else + RFill := S + StrChar(L - L1, ' '); + end; + + function LFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + LFill := S + else + LFill := StrChar(L - L1, ' ') + S; + end; + + function CFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + CFill := S + else + CFill := StrChar((L - L1) div 2, ' ') + S; + end; + + function Replace(S : String; C1, C2 : Char) : String; + var + S1 : String; + K : Byte; + begin + S1 := S; + K := Pos(C1, S1); + while K > 0 do + begin + S1[K] := C2; + K := Pos(C1, S1); + end; + Replace := S1; + end; + + function Extract(S : String; var Index : Byte; Delim : Char) : String; + var + I, L : Byte; + begin + I := Index; + L := Length(S); + + { Search for Delim } + while (I <= L) and (S[I] <> Delim) do + Inc(I); + + { Extract field } + if I = Index then + Extract := '' + else + Extract := Copy(S, Index, I - Index); + + { Skip blanks after Delim } + repeat + Inc(I); + until (I > L) or (S[I] <> ' '); + + { Update Index } + Index := I; + end; + + procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); + var + I, Index, L : Byte; + begin + I := 0; + Index := 1; + L := Length(S); + repeat + Field^[I] := Extract(S, Index, Delim); + Inc(I); + until Index > L; + N := I; + end; + + function FloatToStr(X : Float) : String; + var + S : String; + C : Char; + L : Byte; + begin + if FloatPoint then + begin + Str(X:Pred(NumLength), S); + S := ' ' + S; + end + else + begin + Str(X:NumLength:MaxDec, S); + if not NSZero then + repeat + L := Length(S); + C := S[L]; + if (C = '0') or (C = '.') then Delete(S, L, 1); + until C <> '0'; + end; + FloatToStr := S; + end; + + function IntToStr(N : LongInt) : String; + var + S : String; + begin + Str(N:(NumLength - MaxDec - 1), S); + IntToStr := S; + end; + + function CompToStr(Z : Complex) : String; + var + S : String; + begin + if Z.Form = Rec then + begin + if Z.Y >= 0.0 then S := ' + ' else S := ' - '; + CompToStr := FloatToStr(Z.X) + S + FloatToStr(Abs(Z.Y)) + ' * i'; + end + else + CompToStr := FloatToStr(Z.R) + ' * Exp(' + FloatToStr(Z.Theta) + ' * i)'; + end; + +end. + diff --git a/niftiview7/tpmath/plot.inc b/niftiview7/tpmath/plot.inc new file mode 100755 index 0000000..ef9e6a8 --- /dev/null +++ b/niftiview7/tpmath/plot.inc @@ -0,0 +1,94 @@ +{ ********************************************************************** + * PLOT.INC * + ********************************************************************** + Variables and routines common to PLOT.PAS and WINPLOT.PAS + ********************************************************************** } + +var + XminPixel, YminPixel : Integer; { Pixel coord. of upper left corner } + XmaxPixel, YmaxPixel : Integer; { Pixel coord. of lower right corner } + FactX, FactY : Float; { Scaling factors } + + function Xpixel(X : Float) : Integer; + var + P : Float; + begin + P := FactX * (X - XAxis.Min); + if Abs(P) > 30000 then + Xpixel := 30000 + else + Xpixel := Round(P) + XminPixel; + end; + + function Ypixel(Y : Float) : Integer; + var + P : Float; + begin + P := FactY * (YAxis.Max - Y); + if Abs(P) > 30000 then + Ypixel := 30000 + else + Ypixel := Round(P) + YminPixel; + end; + + function Xuser(X : Integer) : Float; + begin + Xuser := XAxis.Min + (X - XminPixel) / FactX; + end; + + function Yuser(Y : Integer) : Float; + begin + Yuser := YAxis.Max - (Y - YminPixel) / FactY; + end; + + procedure Interval(X1, X2 : Float; MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); + var + H, R, K : Float; + begin + if X1 >= X2 then Exit; + H := X2 - X1; + R := Int(Log10(H)); + if H < 1.0 then R := R - 1.0; + Step := Exp10(R); + + repeat + K := Int(H / Step); + if K < MinDiv then Step := 0.5 * Step; + if K > MaxDiv then Step := 2.0 * Step; + until (K >= MinDiv) and (K <= MaxDiv); + + Min := Step * Int(X1 / Step); + Max := Step * Int(X2 / Step); + while Min > X1 do Min := Min - Step; + while Max < X2 do Max := Max + Step; + end; + + procedure AutoScale(Z : PVector; Lbound, Ubound : Integer; + var Axis : TAxis); + var + I : Integer; + Zmin, Zmax, Z1, Z2 : Float; + begin + if Axis.Scale = LIN_SCALE then + Interval(Min(Z, Lbound, Ubound), Max(Z, Lbound, Ubound), + 2, 6, Axis.Min, Axis.Max, Axis.Step) + else + begin + Zmin := MAXNUM; Zmax := 0.0; + for I := Lbound to Ubound do + if Z^[I] > 0.0 then + if Z^[I] < Zmin then + Zmin := Z^[I] + else if Z^[I] > Zmax then + Zmax := Z^[I]; + Z1 := Int(Log10(Zmin)); + Z2 := Int(Log10(Zmax)); + if Zmin < 1.0 then Z1 := Z1 - 1.0; + if Zmax > 1.0 then Z2 := Z2 + 1.0; + Axis.Min := Z1; + Axis.Max := Z2; + Axis.Step := 1.0; + end; + end; + diff --git a/niftiview7/tpmath/plot.pas b/niftiview7/tpmath/plot.pas new file mode 100755 index 0000000..d0357e1 --- /dev/null +++ b/niftiview7/tpmath/plot.pas @@ -0,0 +1,473 @@ +{ ********************************************************************** + * Unit PLOT.PAS * + * Version 1.7 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Plotting routines for Turbo Pascal + ********************************************************************** } + +unit Plot; + +interface + +uses + Graph, FMath, Matrices, PaString; + +const + BGIPath : String = 'C:\BP\BGI'; { Access path for graphic drivers } + DefSymbSize : Integer = 3; { Default symbol size } + + +{ ********************** Include global variables ********************** } + + {$I PLOTVAR.INC} + +{ ************************** Graphic routines ************************** } + +function GraphOk : Boolean; +{ ---------------------------------------------------------------------- + Initializes high resolution graphics and plots the axes + ---------------------------------------------------------------------- } + +procedure PlotGrid; +{ ---------------------------------------------------------------------- + Plots a grid on the graph + ---------------------------------------------------------------------- } + +procedure WriteLegend(NCurv : Integer); +{ ---------------------------------------------------------------------- + Writes the graph title and the legends for the plotted curves + Input parameter : NCurv = number of curves (1 to MAXCURV) + ---------------------------------------------------------------------- } + +procedure SetClipping(Clip : Boolean); +{ ---------------------------------------------------------------------- + Determines whether drawings are clipped at the current viewport + boundaries, according to the value of the Boolean parameter Clip + ---------------------------------------------------------------------- } + +procedure PlotPoint(Xp, Yp, Symbol, Size, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a point on the screen + ---------------------------------------------------------------------- + Input parameters : Xp, Yp : point coordinates in pixels + Symbol : 0 = point (.) + 1 = solid circle 2 = open circle + 3 = solid square 4 = open square + 5 = solid triangle 6 = open triangle + 7 = plus (+) 8 = multiply (x) + 9 = star (*) + Size : symbol size + Trace : type of line between points + 0 = none + 1 = solid + 2 = dotted + 3 = centered + 4 = dashed + ---------------------------------------------------------------------- } + +procedure PlotCurve(X, Y : PVector; Lbound, Ubound, Symbol, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a curve + ---------------------------------------------------------------------- + Input parameters : X, Y = point coordinates + Lbound, Ubound = indices of first and last points + Symbol, Trace = as in PlotPoint + ---------------------------------------------------------------------- } + +procedure PlotCurveWithErrorBars(X, Y, S : PVector; + Lbound, Ubound, Symbol, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a curve with error bars + ---------------------------------------------------------------------- + Input parameters : X, Y = point coordinates + S = errors (standard deviations) + Lbound, Ubound = indices of first and last points + Symbol, Trace = as in PlotPoint + ---------------------------------------------------------------------- } + +procedure PlotFunc(Func : TFunc; X1, X2 : Float; Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a function + ---------------------------------------------------------------------- + Input parameters : Func = function to be plotted + X1, X2 = abscissae of 1st and last point to plot + Trace = as in PlotPoint + ---------------------------------------------------------------------- + The function must be programmed as : function Func(X : Float) : Float; + ---------------------------------------------------------------------- } + +{ *********** The following routines are defined in PLOT.INC *********** } + +procedure Interval(X1, X2 : Float; MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); +{ ---------------------------------------------------------------------- + Determines an interval [Min, Max] including the values from X1 to X2, + and a subdivision Step of this interval + ---------------------------------------------------------------------- + Input parameters : X1, X2 = min. & max. values to be included + MinDiv = minimum nb of subdivisions + MaxDiv = maximum nb of subdivisions + ---------------------------------------------------------------------- + Output parameters : Min, Max, Step + ---------------------------------------------------------------------- } + +procedure AutoScale(Z : PVector; Lbound, Ubound : Integer; + var Axis : TAxis); +{ ---------------------------------------------------------------------- + Determines the scale of an axis + ---------------------------------------------------------------------- + Input parameters : Z = array of values to be plotted + Lbound, + Ubound = indices of first and last elements of Z + ---------------------------------------------------------------------- + Output parameters : Axis + ---------------------------------------------------------------------- } + +function Xpixel(X : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user abscissa X to screen coordinate + ---------------------------------------------------------------------- } + +function Ypixel(Y : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user ordinate Y to screen coordinate + ---------------------------------------------------------------------- } + +function Xuser(X : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate X to user abscissa + ---------------------------------------------------------------------- } + +function Yuser(Y : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate Y to user ordinate + ---------------------------------------------------------------------- } + +implementation + +{ ---------------------------------------------------------------------- + Include the variables and routines common to PLOT.PAS and WINPLOT.PAS + ---------------------------------------------------------------------- } + + {$I PLOT.INC} + +{ ---------------------------------------------------------------------- } + + procedure PlotXAxis; + var + W, X, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + Line(XminPixel, YmaxPixel, XmaxPixel, YmaxPixel); + SetTextStyle(XTitle.Font, HorizDir, 1); + SetUserCharSize(XTitle.CharWidth, 100, XTitle.CharHeight, 100); + SetTextJustify(CenterText, TopText); + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + X := XAxis.Min; { Tick mark position } + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + MoveTo(Xpixel(X), YmaxPixel); + LineRel(0, 5); { Plot tick mark } + if XAxis.Scale = LIN_SCALE then Z := X else Z := Exp10(X); + OutText(Trim(FloatToStr(Z))); + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do { Plot minor divisions } + begin { on logarithmic scale } + W := X + Log10(J); + MoveTo(Xpixel(W), YmaxPixel); + LineRel(0, 3); + end; + X := X + XAxis.Step; + end; + if XTitle.Text <> '' then { Plot axis title } + OutTextXY((XminPixel + XmaxPixel) div 2, + YmaxPixel + GetMaxY div 12, XTitle.Text); + NSZero := NSZ; + end; + + procedure PlotYAxis; + var + W, Y, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + Line(XminPixel, YminPixel, XminPixel, YmaxPixel); + SetTextStyle(YTitle.Font, HorizDir, 1); + SetUserCharSize(YTitle.CharWidth, 100, YTitle.CharHeight, 100); + SetTextJustify(RightText, CenterText); + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); + Y := YAxis.Min; + NSZ := NSZero; + NSZero := False; + for I := 0 to N do + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + MoveTo(XminPixel, Ypixel(Y)); + LineRel(- 5, 0); + MoveRel(- 2, - 2); + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + OutText(Trim(FloatToStr(Z))); + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + MoveTo(XminPixel, Ypixel(W)); + LineRel(- 3, 0); + end; + Y := Y + YAxis.Step; + end; + if YTitle.Text <> '' then + begin + SetTextStyle(YTitle.Font, VertDir, 1); + SetUserCharSize(YTitle.CharWidth, 100, YTitle.CharHeight, 100); + OutTextXY(XminPixel - GetMaxX div 8, + (YminPixel + YmaxPixel) div 2, YTitle.Text); + end; + NSZero := NSZ; + end; + + function GraphOk : Boolean; + var + Pilot, Mode : Integer; + begin + Pilot := Detect; + InitGraph(Pilot, Mode, BGIPath); + if GraphResult <> 0 then + begin + GraphOk := False; + Exit; + end; + GraphOk := True; + XminPixel := Round(Xwin1 / 100 * GetMaxX); + YminPixel := Round(Ywin1 / 100 * GetMaxY); + XmaxPixel := Round(Xwin2 / 100 * GetMaxX); + YmaxPixel := Round(Ywin2 / 100 * GetMaxY); + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); + if GraphBorder then + Rectangle(XminPixel, YminPixel, XmaxPixel, YmaxPixel); + PlotXAxis; + PlotYAxis; + end; + + procedure PlotGrid; + var + X, Y : Float; + I, N, Xp, Yp : Integer; + begin + SetLineStyle(DottedLn, 0, NormWidth); + if Grid in [HORIZ_GRID, BOTH_GRID] then { Horizontal lines } + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yp := Ypixel(Y); + Line(XminPixel, Yp, XmaxPixel, Yp); + end; + end; + if Grid in [VERTIC_GRID, BOTH_GRID] then { Vertical lines } + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xp := Xpixel(X); + Line(Xp, YminPixel, Xp, YmaxPixel); + end; + end; + SetLineStyle(SolidLn, 0, NormWidth); + end; + + procedure PlotPoint(Xp, Yp, Symbol, Size, Trace : Integer); + var + Xasp, Yasp, Xp1, Xp2, Yp1, Yp2, Dx, Dy : Word; + R : Float; + Triangle : array[1..4] of PointType; + Square : array[1..5] of PointType; + begin + if Trace = 0 then + MoveTo(Xp, Yp) + else + begin + SetLineStyle(Pred(Trace), 0, NormWidth); + LineTo(Xp, Yp); + SetLineStyle(0, 0, 1); + end; + GetAspectRatio(Xasp, Yasp); + R := 0.0001 * Size; + Dx := Round(R * Yasp); + Dy := Round(R * Xasp); + Xp1 := Xp - Size; Xp2 := Xp + Size; + Yp1 := Yp - Size; Yp2 := Yp + Size; + if Symbol in [3, 4] then + begin + Square[1].X := Xp1; Square[1].Y := Yp1; + Square[2].X := Xp1; Square[2].Y := Yp2; + Square[3].X := Xp2; Square[3].Y := Yp2; + Square[4].X := Xp2; Square[4].Y := Yp1; + Square[5].X := Xp1; Square[5].Y := Yp1; + end; + if Symbol in [5, 6] then + begin + Triangle[1].X := Xp; Triangle[1].Y := Yp1; + Triangle[2].X := Xp2; Triangle[2].Y := Yp2; + Triangle[3].X := Xp1; Triangle[3].Y := Yp2; + Triangle[4].X := Xp; Triangle[4].Y := Yp1; + end; + case Symbol of + 0 : PutPixel(Xp, Yp, GetColor); { ù } + 1 : PieSlice(Xp, Yp, 0, 360, Dx); { Solid circle } + 2 : Ellipse(Xp, Yp, 0, 360, Dx, Dy); { Open circle } + 3 : FillPoly(5, Square); { Solid square } + 4 : DrawPoly(5, Square); { Open square } + 5 : FillPoly(4, Triangle); { Solid triangle } + 6 : DrawPoly(4, Triangle); { Open triangle } + 7 : begin { + } + Line(Xp, Yp1, Xp, Yp2); + Line(Xp1, Yp, Xp2, Yp); + end; + 8 : begin { x } + Line(Xp1, Yp1, Xp2, Yp2); + Line(Xp1, Yp2, Xp2, Yp1); + end; + 9 : begin + Line(Xp, Yp1, Xp, Yp2); { * } + Line(Xp1, Yp, Xp2, Yp); + Line(Xp1, Yp1, Xp2, Yp2); + Line(Xp1, Yp2, Xp2, Yp1); + end; + end; + end; + + procedure WriteLegend(NCurv : Integer); + var + I, Xp, Yp, Dy : Integer; + begin + with GraphTitle do + if Text <> '' then + begin + SetTextStyle(Font, HorizDir, 1); + SetUserCharSize(CharWidth, 100, CharHeight, 100); + SetTextJustify(CenterText, TopText); + OutTextXY((XminPixel + XmaxPixel) div 2, + YminPixel - GetMaxY div 10, Text); + end; + with Legend do + begin + SetTextStyle(Font, HorizDir, 1); + SetUserCharSize(CharWidth, 100, CharHeight, 100); + SetTextJustify(LeftText, CenterText); + Dy := (YmaxPixel - YminPixel) div 10; + Xp := XmaxPixel + 30; + Yp := YminPixel + Dy; + for I := 1 to NCurv do + if Text[I] <> '' then + begin + PlotPoint(Xp, Yp, I, SymbolSize, 0); + OutTextXY(Xp + 20, Yp, Text[I]); + Yp := Yp + Dy; + end; + end; + end; + + procedure SetClipping(Clip : Boolean); + begin + if XminPixel = 0 then + begin + XminPixel := Round(Xwin1 / 100 * GetMaxX); + YminPixel := Round(Ywin1 / 100 * GetMaxY); + XmaxPixel := Round(Xwin2 / 100 * GetMaxX); + YmaxPixel := Round(Ywin2 / 100 * GetMaxY); + end; + SetViewPort(XminPixel, YminPixel, XmaxPixel, YmaxPixel, Clip); + XmaxPixel := XmaxPixel - XminPixel; XminPixel := 0; + YmaxPixel := YmaxPixel - YminPixel; YminPixel := 0; + end; + + procedure PlotCurve(X, Y : PVector; + Lbound, Ubound, Symbol, Trace : Integer); + var + XI, YI : Float; + I, NL : Integer; + begin + NL := 0; + for I := Lbound to Ubound do + begin + XI := X^[I]; + if XAxis.Scale = LOG_SCALE then XI := Log10(XI); + YI := Y^[I]; + if YAxis.Scale = LOG_SCALE then YI := Log10(YI); + PlotPoint(Xpixel(XI), Ypixel(YI), Symbol, DefSymbSize, NL); + NL := Trace; + end; + end; + + procedure PlotCurveWithErrorBars(X, Y, S : PVector; + Lbound, Ubound, Symbol, Trace : Integer); + var + XI, YI, Y1, Y2 : Float; + I, NL, Xp, Yp, Yp1, Yp2 : Integer; + begin + NL := 0; + for I := Lbound to Ubound do + begin + XI := X^[I]; + if XAxis.Scale = LOG_SCALE then XI := Log10(XI); + YI := Y^[I]; + if YAxis.Scale = LOG_SCALE then YI := Log10(YI); + Xp := Xpixel(XI); Yp := Ypixel(YI); + PlotPoint(Xp, Yp, Symbol, DefSymbSize, NL); + if S^[I] > 0 then + begin + Y1 := Y^[I] - S^[I]; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Y2 := Y^[I] + S^[I]; + if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Yp1 := Ypixel(Y1); Yp2 := Ypixel(Y2); + Line(Xp - 5, Yp1, Xp + 5, Yp1); + Line(Xp - 5, Yp2, Xp + 5, Yp2); + Line(Xp, Yp1, Xp, Yp2); + end; + NL := Trace; + end; + end; + + procedure PlotFunc(Func : TFunc; X1, X2 : Float; Trace : Integer); + var + X, Y, H : Float; + I, Npt, NL, Xp, Yp : Integer; + begin + NL := 0; { Indicates if a line must be drawn from the previous point } + X := X1; + + { Nb of points to be plotted = number of pixels between X1 and X2 } + Npt := Xpixel(X2) - Xpixel(X1); + + H := (X2 - X1) / Npt; + for I := 0 to Npt do + begin + X := X1 + I * H; + if XAxis.Scale = LIN_SCALE then + Y := Func(X) + else + Y := Func(Exp10(X)); + if MathError <> FN_OK then + NL := 0 + else + begin + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + Xp := Xpixel(X); + Yp := Ypixel(Y); + PlotPoint(Xp, Yp, 0, 0, NL); + NL := Trace; + end; + end; + end; + +end. diff --git a/niftiview7/tpmath/plotvar.inc b/niftiview7/tpmath/plotvar.inc new file mode 100755 index 0000000..7b3ee09 --- /dev/null +++ b/niftiview7/tpmath/plotvar.inc @@ -0,0 +1,93 @@ +{ ********************************************************************** + * PLOTVAR.INC * + ********************************************************************** + Constants, types and global variables + common to PLOT.PAS and TEXPLOT.PAS + ********************************************************************** } + +const + MAXSYMBOL = 9; { Max. number of graphic symbols } + EPS = 1.0E-10; { Lower limit for an axis label } + +type + TScale = (LIN_SCALE, { Scale } + LOG_SCALE); + + TGrid = (NO_GRID, { Grid } + HORIZ_GRID, + VERTIC_GRID, + BOTH_GRID); + + TAxis = record { Coordinate axis } + Scale : TScale; + Min : Float; + Max : Float; + Step : Float; + end; + + TTitle = record { Title for main graph or axis } + Text : String[70]; + Font : Integer; + CharWidth : Integer; + CharHeight : Integer; + end; + + TLegend = record { Legends of plotted curves } + Text : array[1..MAXSYMBOL] of String[40]; + Font : Integer; + CharWidth : Integer; + CharHeight : Integer; + SymbolSize : Integer; + end; + +{ ******** Global variables defining the appearance of the graph ******* } + +const + Xwin1 : Integer = 15; { Window limits in % } + Ywin1 : Integer = 15; + Xwin2 : Integer = 85; + Ywin2 : Integer = 85; + + GraphBorder : Boolean = True; { Plot graph border } + + XAxis : TAxis = (Scale : LIN_SCALE; { Horizontal axis } + Min : 0.0; + Max : 1.0; + Step : 0.2); + + YAxis : TAxis = (Scale : LIN_SCALE; { Vertical axis } + Min : 0.0; + Max : 1.0; + Step : 0.2); + + Grid : TGrid = NO_GRID; { Grid } + + GraphTitle : TTitle = (Text : ''; { Title of graph } + Font : 2; + CharWidth : 300; + CharHeight : 350); + + XTitle : TTitle = (Text : 'X'; { Title of X axis } + Font : 2; + CharWidth : 200; + CharHeight : 250); + + YTitle : TTitle = (Text : 'Y'; { Title of Y axis } + Font : 2; + CharWidth : 200; + CharHeight : 250); + + Legend : TLegend = (Text : ('A', { Legends of curves } + 'B', + 'C', + 'D', + 'E', + 'F', + 'G', + 'H', + 'I'); + Font : 2; + CharWidth : 50; + CharHeight : 50; + SymbolSize : 3); + diff --git a/niftiview7/tpmath/polynom.pas b/niftiview7/tpmath/polynom.pas new file mode 100755 index 0000000..87009e3 --- /dev/null +++ b/niftiview7/tpmath/polynom.pas @@ -0,0 +1,194 @@ +{ ********************************************************************** + * Unit POLYNOM.PAS * + * Version 1.3 * + * (c) J. Debord, January 1998 * + ********************************************************************** + This unit implements routines for polynomials and rational fractions. + ********************************************************************** + Reference: 'Numerical Recipes' by Press et al. + ********************************************************************** } + +unit Polynom; + +interface + +uses + FMath, Matrices, Eigen, Stat; + +function Poly(X : Float; Coef : PVector; Deg : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates the polynomial : + P(X) = Coef[0] + Coef[1] * X + Coef[2] * X^2 +...+ Coef[Deg] * X^Deg + ---------------------------------------------------------------------- } + +function RRootPol(Coef : PVector; Deg : Integer; X : PVector) : Integer; +{ ---------------------------------------------------------------------- + Real roots of a polynomial. The roots are computed analytically if + Deg <= 3, otherwise they are computed numerically from the eigenvalues + of the companion matrix (function RootPol in EIGEN.PAS). The roots are + returned in X (in increasing order). The function returns the number + of real roots found. + ---------------------------------------------------------------------- } + +function CRootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Complex roots of a polynomial. The roots are computed numerically + from the eigenvalues of the companion matrix (function RootPol in + EIGEN.PAS). The real and imaginary parts of the roots are returned + in X_Re and X_Im (in increasing order of the real parts). The function + returns the number of roots found, which may be Deg or zero if the + method did not converge. + ---------------------------------------------------------------------- } + +function RFrac(X : Float; Coef : PVector; Deg1, Deg2 : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates the rational fraction : + + Coef[0] + Coef[1] * X + ... + Coef[Deg1] * X^Deg1 + F(X) = ----------------------------------------------------- + 1 + Coef[Deg1+1] * X + ... + Coef[Deg1+Deg2] * X^Deg2 + ---------------------------------------------------------------------- } + +implementation + +const + MAXDEG = 3; { Maximal degree for analytical solution of polynomial } + + function Poly(X : Float; Coef : PVector; Deg : Integer) : Float; + var + I : Integer; + Y : Float; + begin + Y := Coef^[Deg]; + for I := Pred(Deg) downto 0 do + Y := Y * X + Coef^[I]; + Poly := Y; + end; + + function RFrac(X : Float; Coef : PVector; Deg1, Deg2 : Integer) : Float; + var + I : Integer; + Sum : Float; { Denominator sum } + begin + Sum := 0.0; + for I := (Deg1 + Deg2) downto Succ(Deg1) do + Sum := (Sum + Coef^[I]) * X; + RFrac := Poly(X, Coef, Deg1) / (1.0 + Sum); + end; + + function RootPol3(Coef : PVector; Deg : Integer; X : PVector) : Integer; + { Real roots of polynomial up to degree 3 (Analytical solution) } + const + PI2DIV3 = 2.0943951023931954923; { 2*pi/3 } + var + NR : Integer; { Number of roots } + R, R2, Q, Q3, Delta, A0, A1, A2, A22, A3, AA, BB, Theta, Z : Float; + begin + if (Deg < 1) or (Deg > MAXDEG) then + begin + RootPol3 := 0; + Exit; + end; + case Deg of + 1 : begin + NR := 1; + X^[1] := - Coef^[0] / Coef^[1]; + end; + 2 : begin + Delta := Sqr(Coef^[1]) - 4.0 * Coef^[0] * Coef^[2]; + if Delta < 0 then + NR := 0 + else + begin + NR := 2; + if Coef^[1] >= 0 then + Q := - 0.5 * (Coef^[1] + Sqrt(Delta)) + else + Q := - 0.5 * (Coef^[1] - Sqrt(Delta)); + X^[1] := Q / Coef^[2]; + X^[2] := Coef^[0] / Q; + end; + end; + 3 : begin + A0 := Coef^[0] / Coef^[3]; + A1 := Coef^[1] / Coef^[3]; + A2 := Coef^[2] / Coef^[3]; + A3 := A2 / 3.0; + A22 := Sqr(A2); + Q := (A22 - 3.0 * A1) / 9.0; + R := (A2 * (2.0 * A22 - 9.0 * A1) + 27.0 * A0) / 54.0; + R2 := R * R; + Q3 := Q * Q * Q; + Delta := Q3 - R2; + if Delta < 0 then + begin + NR := 1; + AA := Power(Abs(R) + Sqrt(- Delta), 0.333333333333333); + if R >= 0 then AA := - AA; + if AA <> 0 then BB := Q / AA else BB := 0.0; + X^[1] := (AA + BB) - A3; + end + else + begin + NR := 3; + Theta := ArcCos(R / Sqrt(Q3)) / 3.0; + Z := - 2.0 * Sqrt(Q); + X^[1] := Z * Cos(Theta) - A3; + X^[2] := Z * Cos(Theta + PI2DIV3) - A3; + X^[3] := Z * Cos(Theta - PI2DIV3) - A3; + end; + end; + end; + QSort(X, 1, Deg); + RootPol3 := NR; + end; + + function RRootPol(Coef : PVector; Deg : Integer; X : PVector) : Integer; + var + N : Integer; { Number of real roots } + X_Re, X_Im : PVector; { Real and imaginary parts } + ErrCode : Integer; { Error code } + I : Integer; { Loop variable } + begin + DimVector(X_Re, Deg); + DimVector(X_Im, Deg); + + if Deg <= MAXDEG then + RRootPol := RootPol3(Coef, Deg, X) + else + begin + ErrCode := RootPol(Coef, Deg, X_Re, X_Im); + if ErrCode = MAT_OK then + begin + { Get real roots } + N := 0; + for I := 1 to Deg do + if Abs(X_Im^[I]) <= MACHEP then + begin + Inc(N); + X^[N] := X_Re^[I]; + end; + { Set other roots to zero } + for I := Succ(N) to Deg do + X^[I] := 0.0; + RRootPol := N; + end + else + RRootPol := 0; + end; + + DelVector(X_Re, Deg); + DelVector(X_Im, Deg); + end; + + function CRootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; + begin + if RootPol(Coef, Deg, X_Re, X_Im) = MAT_OK then + CRootPol := Deg + else + CRootPol := 0; + end; + +end. diff --git a/niftiview7/tpmath/simopt.pas b/niftiview7/tpmath/simopt.pas new file mode 100755 index 0000000..e7c7168 --- /dev/null +++ b/niftiview7/tpmath/simopt.pas @@ -0,0 +1,308 @@ +{ ********************************************************************** + * Unit SIMOPT.PAS * + * Version 1.0 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit implements simulated annealing for function minimization + ********************************************************************** + Reference: Program SIMANN.FOR by Bill Goffe + (http://www.netlib.org/simann) + ********************************************************************** } + +unit SimOpt; + +interface + +uses + FMath, Matrices, Optim, Stat; + +const + SA_Nt : Integer = 5; { Number of loops at constant temperature } + SA_Ns : Integer = 15; { Number of loops before step adjustment } + SA_Rt : Float = 0.9; { Temperature reduction factor } + SA_NCycles : Integer = 1; { Number of cycles } + +function SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by simulated annealing + ---------------------------------------------------------------------- + Input parameters : Func = objective function to be minimized + X = initial minimum coordinates + Xmin = minimum value of X + Xmax = maximum value of X + Lbound, + Ubound = indices of first and last variables + MaxIter = max number of annealing steps + Tol = required precision + ---------------------------------------------------------------------- + Output parameter : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + +var + LogFile : Text; { Stores the result of each minimization step } + + procedure CreateLogFile; + begin + Assign(LogFile, LogFileName); + Rewrite(LogFile); + end; + + function InitTemp(Func : TFuncNVar; + X, Xmin, Range : PVector; + Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Computes the initial temperature so that the probability + of accepting an increase of the function is about 0.5 + ---------------------------------------------------------------------- } + const + N_EVAL = 50; { Number of function evaluations } + var + T : Float; { Temperature } + F, F1 : Float; { Function values } + DeltaF : PVector; { Function increases } + N_inc : Integer; { Number of function increases } + I : Integer; { Index of function evaluation } + K : Integer; { Index of parameter } + begin + DimVector(DeltaF, N_EVAL); + + T := 0.0; + N_inc := 0; + F := Func(X); + + { Compute N_EVAL function values, changing each parameter in turn } + K := Lbound; + for I := 1 to N_EVAL do + begin + X^[K] := Xmin^[K] + RanMar * Range^[K]; + F1 := Func(X); + if F1 > F then + begin + Inc(N_inc); + DeltaF^[N_inc] := F1 - F; + end; + F := F1; + Inc(K); + if K > Ubound then K := Lbound; + end; + + { The median M of these N_eval values has a probability of 1/2. + From Boltzmann's formula: Exp(-M/T) = 1/2 ==> T = M / Ln(2) } + T := Median(DeltaF, 1, N_inc) / LN2; + if T = 0.0 then T := 1.0; + InitTemp := T; + + DelVector(DeltaF, N_EVAL); + end; + + function ParamConv(X, Step : PVector; + Lbound, Ubound : Integer; + Tol : Float) : Boolean; +{ ---------------------------------------------------------------------- + Checks for convergence on parameters + ---------------------------------------------------------------------- } + var + I : Integer; + Conv : Boolean; + begin + I := Lbound; + Conv := True; + repeat + Conv := Conv and (Step^[I] < FMax(Tol, Tol * Abs(X^[I]))); + Inc(I); + until (Conv = False) or (I > Ubound); + ParamConv := Conv; + end; + + function Accept(DeltaF, T : Float; + var N_inc, N_acc : Integer) : Boolean; +{ ---------------------------------------------------------------------- + Checks if a variation DeltaF of the function at temperature T is + acceptable. Updates the counters N_inc (number of increases of the + function) and N_acc (number of accepted increases). + ---------------------------------------------------------------------- } + begin + if DeltaF < 0.0 then + Accept := True + else + begin + Inc(N_inc); + if Expo(- DeltaF / T) > RanMar then + begin + Accept := True; + Inc(N_acc); + end + else + Accept := False; + end; + end; + + function SimAnnCycle(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var LogFile : Text; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs one cycle of simulated annealing + ---------------------------------------------------------------------- } + const + N_FACT = 2.0; { Factor for step reduction } + var + I, Iter, J, K, N_inc, N_acc : Integer; + F, F1, DeltaF, Ratio, T, OldX : Float; + Range, Step, Xopt : PVector; + Nacc : PIntVector; + begin + DimVector(Step, Ubound); + DimVector(Xopt, Ubound); + DimVector(Range, Ubound); + DimIntVector(Nacc, Ubound); + + { Determine parameter range, step and optimum } + for K := Lbound to Ubound do + begin + Range^[K] := Xmax^[K] - Xmin^[K]; + Step^[K] := 0.5 * Range^[K]; + Xopt^[K] := X^[K]; + end; + + { Initialize function values } + F := Func(X); + F_min := F; + + { Initialize temperature and iteration count } + T := InitTemp(Func, X, Xmin, Range, Lbound, Ubound); + Iter := 0; + + repeat + { Perform SA_Nt evaluations at constant temperature } + N_inc := 0; N_acc := 0; + for I := 1 to SA_Nt do + begin + for J := 1 to SA_Ns do + for K := Lbound to Ubound do + begin + { Save current parameter value } + OldX := X^[K]; + + { Pick new value, keeping it within Range } + X^[K] := X^[K] + (2.0 * RanMar - 1.0) * Step^[K]; + if (X^[K] < Xmin^[K]) or (X^[K] > Xmax^[K]) then + X^[K] := Xmin^[K] + RanMar * Range^[K]; + + { Compute new function value } + F1 := Func(X); + DeltaF := F1 - F; + + { Check for acceptance } + if Accept(DeltaF, T, N_inc, N_acc) then + begin + Inc(Nacc^[K]); + F := F1; + end + else + { Restore parameter value } + X^[K] := OldX; + + { Update minimum if necessary } + if F < F_min then + begin + Xopt^[K] := X^[K]; + F_min := F; + end; + end; + + { Ajust step length to maintain an acceptance + ratio of about 50% for each parameter } + for K := Lbound to Ubound do + begin + Ratio := Int(Nacc^[K]) / Int(SA_Ns); + if Ratio > 0.6 then + begin + { Increase step length, keeping it within Range } + Step^[K] := Step^[K] * (1.0 + ((Ratio - 0.6) / 0.4) * N_FACT); + if Step^[K] > Range^[K] then Step^[K] := Range^[K]; + end + else if Ratio < 0.4 then + { Reduce step length } + Step^[K] := Step^[K] / (1.0 + ((0.4 - Ratio) / 0.4) * N_FACT); + + { Restore counter } + Nacc^[K] := 0; + end; + end; + + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', T:12, ' ', F:12, N_inc:6, N_acc:6); + + { Update temperature and iteration count } + T := T * SA_Rt; + Inc(Iter); + until ParamConv(Xopt, Step, Lbound, Ubound, Tol) or (Iter > MaxIter); + + for K := Lbound to Ubound do + X^[K] := Xopt^[K]; + + DelVector(Step, Ubound); + DelVector(Xopt, Ubound); + DelVector(Range, Ubound); + DelIntVector(Nacc, Ubound); + + if Iter > MaxIter then + SimAnnCycle := OPT_NON_CONV + else + SimAnnCycle := OPT_OK; + end; + + function SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + var + Cycle, ErrCode : Integer; + begin + if WriteLogFile then + CreateLogFile; + + { Initialize the Marsaglia random number generator + using the standard Pascal generator } + Randomize; + RMarIn(System.Random(10000), System.Random(10000)); + + Cycle := 1; + repeat + if WriteLogFile then + begin + WriteLn(LogFile, 'Simulated annealing: Cycle ', Cycle); + WriteLn(LogFile); + WriteLn(LogFile, 'Iter T F Inc Acc'); + end; + + ErrCode := SimAnnCycle(Func, X, Xmin, Xmax, Lbound, Ubound, + MaxIter, Tol, LogFile, F_min); + + Inc(Cycle); + until (Cycle > SA_NCycles) or (ErrCode <> OPT_OK); + + if WriteLogFile then + Close(LogFile); + + SimAnn := ErrCode; + end; + +end. diff --git a/niftiview7/tpmath/stat.pas b/niftiview7/tpmath/stat.pas new file mode 100755 index 0000000..4fc81b3 --- /dev/null +++ b/niftiview7/tpmath/stat.pas @@ -0,0 +1,333 @@ +{ ********************************************************************** + * Unit STAT.PAS * + * Version 1.5 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Statistical routines + ********************************************************************** } + +unit Stat; + +interface + +uses + FMath, Matrices; + +{ ---------------------------------------------------------------------- + Common input parameters : X : Vector of statistical variable + Lbound, + Ubound : Indices of first and last + elements of X + W : Vector of weights + ---------------------------------------------------------------------- } + +procedure QSort(X : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Sorts the elements of vector X in increasing order (quick sort) + ---------------------------------------------------------------------- } + +procedure DQSort(X : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Sorts the elements of vector X in decreasing order (quick sort) + ---------------------------------------------------------------------- } + +function Median(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Sorts vector X is ascending order and returns its median value + ---------------------------------------------------------------------- } + +function Sum(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of the elements of vector X + ---------------------------------------------------------------------- } + +function SumSqr(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared elements of vector X + ---------------------------------------------------------------------- } + +function SumSqrDif(X : PVector; Lbound, Ubound : Integer; + A : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared differences between + the elements of vector X and the constant A + ---------------------------------------------------------------------- } + +function SumSqrDifVect(X, Y : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared differences between two vectors + ---------------------------------------------------------------------- } + +function SumWSqr(X, W : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared elements of vector X + ---------------------------------------------------------------------- } + +function SumWSqrDif(X, W : PVector; Lbound, Ubound : Integer; + A : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared differences between + the elements of vector X and the constant A + ---------------------------------------------------------------------- } + +function SumWSqrDifVect(X, Y, W : PVector; + Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared differences between two vectors + ---------------------------------------------------------------------- } + +function Average(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the average value of vector X + ---------------------------------------------------------------------- } + +function Variance(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the variance of vector X, with average Avg + ---------------------------------------------------------------------- } + +function EstVar(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the estimated variance of the population + to which vector X belongs + ---------------------------------------------------------------------- } + +function Skewness(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the skewness of vector X, + with average Avg and standard deviation Sigma + ---------------------------------------------------------------------- } + +function Kurtosis(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the kurtosis of vector X, + with average Avg and standard deviation Sigma + ---------------------------------------------------------------------- } + +procedure RanMult(M : PVector; L : PMatrix; N : Integer; X : PVector); +{ ---------------------------------------------------------------------- + Samples a vector X from the N-dimensioned multinormal distribution + with mean vector M. L is the Cholesky factor of the variance-covariance + matrix. + ---------------------------------------------------------------------- } + +implementation + + procedure QSort(X : PVector; Lbound, Ubound : Integer); + { Quick sort in ascending order - Adapted from Borland's BP7 demo } + procedure Sort(L, R : Integer); + var + I, J : Integer; + U, V : Float; + begin + I := L; + J := R; + U := X^[(L + R) div 2]; + repeat + while X^[I] < U do I := I + 1; + while U < X^[J] do J := J - 1; + if I <= J then + begin + V := X^[I]; X^[I] := X^[J]; X^[J] := V; + I := I + 1; J := J - 1; + end; + until I > J; + if L < J then Sort(L, J); + if I < R then Sort(I, R); + end; + + begin + Sort(Lbound, Ubound); + end; + + procedure DQSort(X : PVector; Lbound, Ubound : Integer); + { Quick sort in descending order - Adapted from Borland's BP7 demo } + procedure Sort(L, R : Integer); + var + I, J : Integer; + U, V : Float; + begin + I := L; + J := R; + U := X^[(L + R) div 2]; + repeat + while X^[I] > U do I := I + 1; + while U > X^[J] do J := J - 1; + if I <= J then + begin + V := X^[I]; X^[I] := X^[J]; X^[J] := V; + I := I + 1; J := J - 1; + end; + until I > J; + if L < J then Sort(L, J); + if I < R then Sort(I, R); + end; + + begin + Sort(Lbound, Ubound); + end; + + function Median(X : PVector; Lbound, Ubound : Integer) : Float; + var + N, N2 : Integer; + begin + N := Ubound - Lbound + 1; + N2 := N div 2 + Lbound - 1; + QSort(X, Lbound, Ubound); + if Odd(N) then + Median := X^[N2 + 1] + else + Median := 0.5 * (X^[N2] + X^[N2 + 1]); + end; + + function Sum(X : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + X^[I]; + Sum := S; + end; + + function SumSqr(X : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I]); + SumSqr := S; + end; + + function SumSqrDif(X : PVector; Lbound, Ubound : Integer; + A : Float) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I] - A); + SumSqrDif := S; + end; + + function SumSqrDifVect(X, Y : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I] - Y^[I]); + SumSqrDifVect := S; + end; + + function SumWSqr(X, W : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I]); + SumWSqr := S; + end; + + function SumWSqrDif(X, W : PVector; Lbound, Ubound : Integer; A : Float) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I] - A); + SumWSqrDif := S; + end; + + function SumWSqrDifVect(X, Y, W : PVector; + Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I] - Y^[I]); + SumWSqrDifVect := S; + end; + + function Average(X : PVector; Lbound, Ubound : Integer) : Float; + begin + Average := Sum(X, Lbound, Ubound) / (Ubound - Lbound + 1); + end; + + function Variance(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; + begin + Variance := SumSqrDif(X, Lbound, Ubound, Avg) / (Ubound - Lbound + 1); + end; + + function EstVar(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; + begin + EstVar := SumSqrDif(X, Lbound, Ubound, Avg) / (Ubound - Lbound); + end; + + function Skewness(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; + var + S, T : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + begin + T := (X^[I] - Avg) / Sigma; + S := S + T * Sqr(T); + end; + Skewness := S / (Ubound - Lbound + 1); + end; + + function Kurtosis(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; + var + S, T : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + begin + T := (X^[I] - Avg) / Sigma; + S := S + Sqr(Sqr(T)); + end; + Kurtosis := S / (Ubound - Lbound + 1) - 3.0; + end; + + procedure RanMult(M : PVector; L : PMatrix; N : Integer; X : PVector); + var + U : PVector; + I, J : Integer; + begin + { Form a vector of N independent standard normal variates } + DimVector(U, N); + for I := 1 to N do + U^[I] := RanGaussStd; + + { Form X = M + L*U, which follows the multinormal distribution } + for I := 1 to N do + begin + X^[I] := M^[I]; + for J := 1 to I do + X^[I] := X^[I] + L^[I]^[J] * U^[J]; + end; + DelVector(U, N); + end; + +end. diff --git a/niftiview7/tpmath/texplot.pas b/niftiview7/tpmath/texplot.pas new file mode 100755 index 0000000..b918b28 --- /dev/null +++ b/niftiview7/tpmath/texplot.pas @@ -0,0 +1,488 @@ +{ ********************************************************************** + * Unit TEXPLOT.PAS * + * Version 1.1 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Plotting routines for TeX/PSTricks + ********************************************************************** } + +unit TexPlot; + +interface + +uses + FMath, Matrices, PaString; + +{ ********************** Include global variables ********************** } + + {$I PLOTVAR.INC} + +{ ************************** Graphic routines ************************** } + +procedure InitTexGraph(var F : Text; FileName : String); +{ ---------------------------------------------------------------------- + Initializes TeX graphics. + Writes a border around the graph according to the value + of the global variable GraphBorder (defined in PLOTVAR.INC) + ---------------------------------------------------------------------- + F : file to be written + FileName : name of TeX file (e.g. 'figure.tex') + ---------------------------------------------------------------------- } + +function Xcm(X : Float) : Float; +{ ---------------------------------------------------------------------- + Converts user coordinate X to cm + ---------------------------------------------------------------------- } + +function Ycm(Y : Float) : Float; +{ ---------------------------------------------------------------------- + Converts user coordinate Y to cm + ---------------------------------------------------------------------- } + +procedure WriteXAxis(var F : Text); +{ ---------------------------------------------------------------------- + Writes horizontal axis (global variable XAxis in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteYAxis(var F : Text); +{ ---------------------------------------------------------------------- + Writes vertical axis (global variable YAxis in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteGrid(var F : Text); +{ ---------------------------------------------------------------------- + Writes a grid (global variable Grid in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteLine(var F : Text; X1, Y1, X2, Y2 : Float; Style : String); +{ ---------------------------------------------------------------------- + Writes a line between two points + ---------------------------------------------------------------------- + F : output file + + X1, Y1 : coordinates of first point + + X2, Y2 : coordinates of second point + + Style : line style (must be 'solid', 'dotted' or 'dashed') + ---------------------------------------------------------------------- } + +procedure WritePoints(var F : Text; X, Y : PVector; + Lbound, Ubound, Symbol, Size : Integer); +{ ---------------------------------------------------------------------- + Writes a set of points + ---------------------------------------------------------------------- + F : output file + + X, Y : point coordinates + + Lbound, Ubound : indices of first and last point + + Symbol : 1 = solid circle 2 = open circle + 3 = solid square 4 = open square + 5 = solid triangle 6 = open triangle + 7 = plus (+) 8 = multiply (x) + 9 = star (*) + + Size : size of points + ---------------------------------------------------------------------- } + +procedure WriteText(var F : Text; Place : String; X, Y : Float; S : String); +{ ---------------------------------------------------------------------- + Writes a text + ---------------------------------------------------------------------- + F : output file + + Place : defines the position of point (X,Y) with respect + to the box enclosing the text + + the possible values are + 'tl', 't', 'tr', 'l', 'r', 'Bl', 'B', 'Br', 'bl', 'b', 'br' + according to the following scheme: + + t + tl +---------------------+ tr + | | + | | + l | | r + | | + Bl |----------B----------| Br + bl +---------------------+ br + b + + X, Y : position of text + + S : text to be written + ---------------------------------------------------------------------- } + +procedure WriteNumber(var F : Text; Place : String; X, Y, Z : Float); +{ ---------------------------------------------------------------------- + Writes a number + ---------------------------------------------------------------------- + Z is the number to be written + Other parameters as in WriteText + ---------------------------------------------------------------------- } + +procedure WriteCurve(var F : Text; X, Y : PVector; + Lbound, Ubound, Width : Integer; + Style : String; Smooth : Boolean); +{ ---------------------------------------------------------------------- + Writes a curve + ---------------------------------------------------------------------- + F : output file + + X, Y : point coordinates + + Lbound, Ubound : indices of first and last point + + Width : curve width in units of 0.01 cm + + Style : curve style (must be 'solid', 'dotted' or 'dashed') + + Smooth : indicates if the curve must be smoothed + ---------------------------------------------------------------------- } + +procedure WriteFunc(var F : Text; Func : TFunc; X1, X2 : Float; + Npt, Width : Integer; Style : String); +{ ---------------------------------------------------------------------- + Writes the curve representing a function + ---------------------------------------------------------------------- + F : output file + + Func : function to be plotted + + X1, X2 : abscissae of 1st and last point to plot + + Npt : number of points + + Width, Style : width of curve (as in WriteCurve) + ---------------------------------------------------------------------- + The function must be programmed as: function Func(X : Float) : Float; + ---------------------------------------------------------------------- } + +procedure CloseTexGraph(var F : Text); +{ ---------------------------------------------------------------------- + Close graphics + ---------------------------------------------------------------------- } + +implementation + +const + PAGEWIDTH = 13; { Graph width in cm } + PAGEHEIGHT = 10; { Graph height in cm } + +var + XminCm, YminCm : Float; { Coord. of lower left corner in cm } + XmaxCm, YmaxCm : Float; { Coord. of upper right corner in cm } + FactX, FactY : Float; { Scaling factors } + + function Xcm(X : Float) : Float; + { Converts user coordinate X to cm } + begin + Xcm := XminCm + FactX * (X - XAxis.Min); + end; + + function Ycm(Y : Float) : Float; + { Converts user coordinate Y to cm } + begin + Ycm := YminCm + FactY * (Y - YAxis.Min); + end; + + procedure WriteHeader(var F : Text); + begin + WriteLn(F, '\documentclass[12pt,a4paper]{article}'); + WriteLn(F, '\usepackage{t1enc}'); + WriteLn(F, '\usepackage{pst-plot}'); + WriteLn(F, '\begin{document}'); + WriteLn(F); + WriteLn(F, '\begin{pspicture}(', PAGEWIDTH, ',', PAGEHEIGHT, ')'); + end; + + procedure WriteCoord(var F : Text; X, Y : Float); + { Writes the coordinates (in cm) of a point } + var + NSZ : Boolean; + begin + NSZ := NSZEro; + NSZero := False; + Write(F, '(', Trim(FloatToStr(X)), ',', Trim(FloatToStr(Y)), ')'); + NSZEro := NSZ; + end; + + procedure WriteLine(var F : Text; X1, Y1, X2, Y2 : Float; Style : String); + begin + Write(F, '\psline'); + if Style <> '' then + Write(F, '[linestyle=', Style, ']'); + WriteCoord(F, X1, Y1); + WriteCoord(F, X2, Y2); + WriteLn(F); + end; + + procedure WriteText(var F : Text; Place : String; X, Y : Float; S : String); + begin + Write(F, '\rput[', Place, ']'); + WriteCoord(F, X, Y); + WriteLn(F, '{', S, '}'); + end; + + procedure WriteNumber(var F : Text; Place : String; X, Y, Z : Float); + begin + Write(F, '\rput[', Place, ']'); + WriteCoord(F, X, Y); + WriteLn(F, '{', Trim(FloatToStr(Z)), '}'); + end; + + procedure WriteXAxis(var F: Text); + var + W, X, Xc, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + WriteLine(F, XminCm, YminCm, XmaxCm, YminCm, ''); + + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + X := XAxis.Min; { Tick mark position } + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + + Xc := Xcm(X); + WriteLine(F, Xc, YminCm, Xc, YminCm - 0.25, ''); { Tick mark } + + if XAxis.Scale = LIN_SCALE then + Z := X + else + Z := Exp10(X); + WriteNumber(F, 't', Xc, YminCm - 0.35, Z); { Label } + + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do { Plot minor divisions } + begin { on logarithmic scale } + W := X + Log10(J); + Xc := Xcm(W); + WriteLine(F, Xc, YminCm, Xc, YminCm - 0.15, ''); + end; + + X := X + XAxis.Step; + end; + + { Write axis title } + if XTitle.Text <> '' then + WriteText(F, 't', 0.5 * (XminCm + XmaxCm), YminCm - 1.0, XTitle.Text); + + NSZero := NSZ; + end; + + procedure WriteYAxis(var F : Text); + var + W, Y, Yc, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + WriteLine(F, XminCm, YminCm, XminCm, YmaxCm, ''); + + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); + Y := YAxis.Min; + + NSZ := NSZero; + NSZero := False; + + for I := 0 to N do + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + + Yc := Ycm(Y); + WriteLine(F, XminCm, Yc, XminCm - 0.25, Yc, ''); + + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + WriteNumber(F, 'r', XminCm - 0.35, Yc, Z); + + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + Yc := Ycm(W); + WriteLine(F, XminCm, Yc, XminCm - 0.15, Yc, ''); + end; + + Y := Y + YAxis.Step; + end; + + { Write axis title } + if YTitle.Text <> '' then + WriteText(F, 'l', XminCm, YmaxCm + 0.5, YTitle.Text); + + NSZero := NSZ; + end; + + procedure WriteGrid(var F : Text); + var + X, Y, Xc, Yc : Float; + I, N : Integer; + begin + { Horizontal lines } + if Grid in [HORIZ_GRID, BOTH_GRID] then + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yc := Ycm(Y); + WriteLine(F, XminCm, Yc, XmaxCm, Yc, 'dotted'); + end; + end; + + { Vertical lines } + if Grid in [VERTIC_GRID, BOTH_GRID] then + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xc := Xcm(X); + WriteLine(F, Xc, YminCm, Xc, YmaxCm, 'dotted'); + end; + end; + end; + + procedure InitTexGraph(var F : Text; Filename : String); + begin + XminCm := 0.01 * Xwin1 * PAGEWIDTH; + XmaxCm := 0.01 * Xwin2 * PAGEWIDTH; + YminCm := 0.01 * Ywin1 * PAGEHEIGHT; + YmaxCm := 0.01 * Ywin2 * PAGEHEIGHT; + + FactX := (XmaxCm - XminCm) / (XAxis.Max - XAxis.Min); + FactY := (YmaxCm - YminCm) / (YAxis.Max - YAxis.Min); + + Assign(F, FileName); + Rewrite(F); + + WriteHeader(F); + + if GraphBorder then + begin + Write(F, '\pspolygon'); + WriteCoord(F, XminCm, YminCm); + WriteCoord(F, XmaxCm, YminCm); + WriteCoord(F, XmaxCm, YmaxCm); + WriteCoord(F, XminCm, YmaxCm); + WriteLn(F); + end; + end; + + procedure WritePoint(var F : Text; X, Y : Float); + var + Xc, Yc : Float; + begin + if XAxis.Scale = LOG_SCALE then X := Log10(X); + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + + Xc := Xcm(X); + Yc := Ycm(Y); + + if (Xc >= XminCm) and (Xc <= XmaxCm) and + (Yc >= YminCm) and (Yc <= YmaxCm) then + WriteCoord(F, Xc, Yc); + end; + + procedure WritePoints(var F : Text; X, Y : PVector; + Lbound, Ubound, Symbol, Size : Integer); + var + I, N : Integer; + begin + Write(F, '\psdots[dotscale=', Size, ' ', Size, ', dotstyle='); + case Symbol of + 1 : Write(F, '*'); + 2 : Write(F, 'o'); + 3 : Write(F, 'square*'); + 4 : Write(F, 'square'); + 5 : Write(F, 'triangle*'); + 6 : Write(F, 'triangle'); + 7 : Write(F, '+'); + 8 : Write(F, 'x'); + 9 : Write(F, 'asterisk'); + end; + WriteLn(F, ']%'); + + I := Lbound; + repeat + WritePoint(F, X^[I], Y^[I]); + if (I > 0) and (I < Ubound) and (I mod 5 = 0) then WriteLn(F, '%'); + Inc(I); + until I > Ubound; + WriteLn(F); + end; + + procedure WriteCurve(var F : Text; X, Y : PVector; + Lbound, Ubound, Width : Integer; + Style : String; Smooth : Boolean); + var + I, N : Integer; + W : Float; + Ws : String; + begin + W := 0.01 * Width; + Str(W:5:2, Ws); + Ws := Trim(Ws); + + if Smooth then Write(F, '\pscurve') else Write(F, '\psline'); + WriteLn(F, '[linewidth=', Ws, ', linestyle=', Style, ']%'); + + I := Lbound; + repeat + WritePoint(F, X^[I], Y^[I]); + if (I > 0) and (I < Ubound) and (I mod 5 = 0) then WriteLn(F, '%'); + Inc(I); + until I > Ubound; + WriteLn(F); + end; + + procedure WriteFunc(var F : Text; Func : TFunc; X1, X2 : Float; + Npt, Width : Integer; Style : String); + const + X : PVector = nil; + Y : PVector = nil; + N : Integer = 0; + var + H : Float; + I : Integer; + begin + if Npt <> N then + begin + DelVector(X, N); + DelVector(Y, N); + DimVector(X, Npt); + DimVector(Y, Npt); + N := Npt; + end; + + H := (X2 - X1) / N; + for I := 0 to N do + begin + X^[I] := X1 + I * H; + if XAxis.Scale = LIN_SCALE then + Y^[I] := Func(X^[I]) + else + Y^[I] := Func(Exp10(X^[I])); + end; + + WriteCurve(F, X, Y, 0, N, Width, Style, True); + end; + + procedure CloseTexGraph(var F: Text); + begin + WriteLn(F, '\end{pspicture}'); + WriteLn(F); + WriteLn(F, '\end{document}'); + Close(F); + end; + +end. + + diff --git a/niftiview7/tpmath/winplot.pas b/niftiview7/tpmath/winplot.pas new file mode 100755 index 0000000..4376db5 --- /dev/null +++ b/niftiview7/tpmath/winplot.pas @@ -0,0 +1,856 @@ +{ ********************************************************************** + * Unit WINPLOT.PAS * + * Version 1.1 * + * (c) J. Debord, October 1999 * + ********************************************************************** + Plotting routines for DELPHI + ********************************************************************** } + +unit WinPlot; + +interface + +uses + { DELPHI units } + WinTypes, + Graphics, + { TPMath units } + FMath, + Matrices, + Stat, + PaString; + +{ ************************* Constants and types ************************ } + +const + MAXCURV = 255; { Max. number of curves which may be plotted } + MAXSYMBOL = 9; { Max. number of symbols for plotting curves } + EPS = 1.0E-10; { Lower limit for an axis label } + +type + TScale = (LIN_SCALE, { Scale } + LOG_SCALE); + + TGrid = (NO_GRID, { Grid } + HORIZ_GRID, + VERTIC_GRID, + BOTH_GRID); + + TAxis = record { Coordinate axis } + Scale : TScale; + Min, Max, Step : Float; + Title : String; + end; + + TPointParam = record { Point parameters } + Symbol : Integer; { Symbol index } + Size : Integer; { Symbol size in 1/250 of graphic width } + Color : TColor; + end; + + TLineParam = record { Line parameters } + Width : Integer; + Style : TPenStyle; + Color : TColor; + end; + + TCurvParam = record { Curve parameters } + PointParam : TPointParam; + LineParam : TLineParam; + Legend : String[30]; { Legend of curve } + Step : Integer; { Plot 1 point every Step points } + Connect : Boolean; { Connect points with line? } + end; + + TCurvParamArray = array[1..MAXCURV] of TCurvParam; + + PCurvParamArray = ^TCurvParamArray; + +{ ******** Global variables defining the appearance of the graph ******* } + +const + Xwin1 : Integer = 15; { Window coordinates in percent of maximum } + Ywin1 : Integer = 15; + Xwin2 : Integer = 75; + Ywin2 : Integer = 75; + + GraphBorder : Boolean = True; { For plotting a rectangle around the graph } + + XAxis : TAxis = (Scale : LIN_SCALE; { Horizontal axis } + Min : 0.0; + Max : 1.0; + Step : 0.2; + Title : 'X'); + + YAxis : TAxis = (Scale : LIN_SCALE; { Vertical axis } + Min : 0.0; + Max : 1.0; + Step : 0.2; + Title : 'Y'); + + Grid : TGrid = BOTH_GRID; { Grid } + + GraphTitle : String = ''; { Title of graph } + +{ ************************** Graphic routines ************************** } + +procedure InitGraph(Canvas : TCanvas; + Width, Height : Integer); +{ ---------------------------------------------------------------------- + Initializes the graphic + ---------------------------------------------------------------------- + The parameters refer to the object on which the graphic is plotted. + + Examples: + + To draw on a TImage object: + InitGraph(Image1.Canvas, Image1.Width, Image1.Height); + + To print the graphic: + InitGraph(Printer.Canvas, Printer.PageWidth, Printer.PageHeight); + ---------------------------------------------------------------------- } + +procedure PlotXAxis(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots the X axis + ---------------------------------------------------------------------- } + +procedure PlotYAxis(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots the Y axis + ---------------------------------------------------------------------- } + +procedure WriteTitle(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Writes the title of the graph + ---------------------------------------------------------------------- } + +procedure PlotGrid(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots a grid on the graph + ---------------------------------------------------------------------- } + +procedure PlotPoint(Canvas : TCanvas; + X, Y : Float; + PointParam : TPointParam); +{ ---------------------------------------------------------------------- + Plots a point + ---------------------------------------------------------------------- + X, Y : point coordinates + PointParam : point parameters + ---------------------------------------------------------------------- } + +procedure PlotCurve(Canvas : TCanvas; + X, Y : PVector; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); +{ ---------------------------------------------------------------------- + Plots a curve + ---------------------------------------------------------------------- + X, Y : point coordinates + Lbound, Ubound : indices of first and last points + CurvParam : curve parameters + ---------------------------------------------------------------------- } + +procedure PlotCurveWithErrorBars(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); +{ ---------------------------------------------------------------------- + Plots a curve with error bars + ---------------------------------------------------------------------- + X, Y : point coordinates + S : errors (e.g. standard deviations) + Ns : error multiplier (e.g. 2 for plotting 2 SD's) + Lbound, Ubound : indices of first and last points + CurvParam : curve parameters + ---------------------------------------------------------------------- } + +procedure PlotFunc(Canvas : TCanvas; + Func : TFunc; + Xmin, Xmax : Float; + Npt : Integer; + LineParam : TLineParam); +{ ---------------------------------------------------------------------- + Plots a function + ---------------------------------------------------------------------- + Func : function to be plotted + must be programmed as: function Func(X : Float) : Float; + Xmin, Xmax : abscissae of 1st and last point to plot + Npt : number of points + LineParam : line parameters + ---------------------------------------------------------------------- } + +procedure WriteLegend(Canvas : TCanvas; + NCurv : Integer; + CurvParam : PCurvParamArray; + ShowPoints, + ShowLines : Boolean); +{ ---------------------------------------------------------------------- + Writes the legends for the plotted curves + ---------------------------------------------------------------------- + NCurv : number of curves (1 to MAXCURV) + CurvParam : curve parameters + ShowPoints : for displaying points + ShowLines : for displaying lines + ---------------------------------------------------------------------- } + + +{ *********** The following routines are defined in PLOT.INC *********** } + +procedure Interval(X1, X2 : Float; + MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); +{ ---------------------------------------------------------------------- + Determines an interval [Min, Max] including the values from X1 to X2, + and a subdivision Step of this interval + ---------------------------------------------------------------------- + Input parameters : X1, X2 = min. & max. values to be included + MinDiv = minimum nb of subdivisions + MaxDiv = maximum nb of subdivisions + ---------------------------------------------------------------------- + Output parameters : Min, Max, Step + ---------------------------------------------------------------------- } + +procedure AutoScale(Z : PVector; + Lbound, Ubound : Integer; + var Axis : TAxis); +{ ---------------------------------------------------------------------- + Determines the scale of an axis + ---------------------------------------------------------------------- + Input parameters : Z = array of values to be plotted + Lbound, + Ubound = indices of first and last elements of Z + ---------------------------------------------------------------------- + Output parameters : Axis + ---------------------------------------------------------------------- } + +function Xpixel(X : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user abscissa X to screen coordinate + ---------------------------------------------------------------------- } + +function Ypixel(Y : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user ordinate Y to screen coordinate + ---------------------------------------------------------------------- } + +function Xuser(X : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate X to user abscissa + ---------------------------------------------------------------------- } + +function Yuser(Y : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate Y to user ordinate + ---------------------------------------------------------------------- } + +implementation + +uses + Classes; + +var + GraphWidth, GraphHeight, SymbolSizeUnit : Integer; + +{ ---------------------------------------------------------------------- + Include the variables and routines common to PLOT.PAS and WINPLOT.PAS + ---------------------------------------------------------------------- } + + {$I PLOT.INC} + +{ ---------------------------------------------------------------------- } + +procedure PlotXAxis(Canvas : TCanvas); + var + W, X, Z : Float; + N, I, J, TickLength, MinorTickLength, Wp, Xp : Integer; + XLabel : String; + NSZ : Boolean; + begin + TickLength := Canvas.TextHeight('M') div 2; + MinorTickLength := Round(0.67 * TickLength); { For log scale } + + { Draw axis } + Canvas.MoveTo(XminPixel, YmaxPixel); + Canvas.LineTo(XmaxPixel, YmaxPixel); + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + + X := XAxis.Min; { Tick mark position } + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + Xp := Xpixel(X); + + { Draw tick mark } + Canvas.MoveTo(Xp, YmaxPixel); + Canvas.LineTo(Xp, YmaxPixel + TickLength); + + { Write label } + if XAxis.Scale = LIN_SCALE then Z := X else Z := Exp10(X); + XLabel := Trim(PaString.FloatToStr(Z)); + Canvas.TextOut(Xp - Canvas.TextWidth(XLabel) div 2, + YmaxPixel + TickLength, XLabel); + + { Plot minor divisions on logarithmic scale } + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := X + Log10(J); + Wp := Xpixel(W); + Canvas.MoveTo(Wp, YmaxPixel); + Canvas.LineTo(Wp, YmaxPixel + MinorTickLength); + end; + X := X + XAxis.Step; + end; + + NSZero := NSZ; + + { Write axis title } + if XAxis.Title <> '' then + Canvas.TextOut(XminPixel + (XmaxPixel - XminPixel - + Canvas.TextWidth(XAxis.Title)) div 2, + YmaxPixel + 2 * Canvas.TextHeight('M'), + XAxis.Title); + end; + + procedure PlotYAxis(Canvas : TCanvas); + var + W, Y, Z : Float; + N, I, J, Wp, Yp : Integer; + TickLength, MinorTickLength, Yoffset : Integer; + YLabel : String; + NSZ : Boolean; + begin + TickLength := Canvas.TextWidth('M') div 2; + MinorTickLength := Round(0.67 * TickLength); { For log scale } + + Yoffset := Canvas.TextHeight('M') div 2; + + { Draw axis } + Canvas.MoveTo(XminPixel, YminPixel); + Canvas.LineTo(XminPixel, YmaxPixel); + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + + Y := YAxis.Min; { Tick mark position } + for I := 0 to N do { Label axis } + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + Yp := Ypixel(Y); + + { Draw tick mark } + Canvas.MoveTo(XminPixel, Yp); + Canvas.LineTo(XminPixel - TickLength, Yp); + + { Write label } + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + YLabel := Trim(PaString.FloatToStr(Z)); + Canvas.TextOut(XminPixel - TickLength - Canvas.TextWidth(YLabel), + Yp - Yoffset, YLabel); + + { Plot minor divisions on logarithmic scale } + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + Wp := Ypixel(W); + Canvas.MoveTo(XminPixel, Wp); + Canvas.LineTo(XminPixel - MinorTickLength, Wp); + end; + Y := Y + YAxis.Step; + end; + + NSZero := NSZ; + + { Write axis title } + if YAxis.Title <> '' then + Canvas.TextOut(XminPixel, YminPixel - 3 * Yoffset, YAxis.Title); + end; + + procedure InitGraph(Canvas : TCanvas; Width, Height : Integer); + begin + GraphWidth := Width; + GraphHeight := Height; + SymbolSizeUnit := GraphWidth div 250; + + XminPixel := Round(Xwin1 / 100 * Width); + YminPixel := Round(Ywin1 / 100 * Height); + XmaxPixel := Round(Xwin2 / 100 * Width); + YmaxPixel := Round(Ywin2 / 100 * Height); + + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); + + if GraphBorder then + Canvas.Rectangle(XminPixel, YminPixel, Succ(XmaxPixel), Succ(YmaxPixel)); + end; + + procedure WriteTitle(Canvas : TCanvas); + begin + if GraphTitle <> '' then + with Canvas do + TextOut((XminPixel + XmaxPixel - TextWidth(GraphTitle)) div 2, + YminPixel - 2 * TextHeight(GraphTitle), GraphTitle); + end; + + procedure PlotGrid(Canvas : TCanvas); + var + X, Y : Float; + I, N, Xp, Yp : Integer; + PenStyle : TpenStyle; + begin + { Save current settings } + PenStyle := Canvas.Pen.Style; + Canvas.Pen.Style := psDot; + + if Grid in [HORIZ_GRID, BOTH_GRID] then { Horizontal lines } + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yp := Ypixel(Y); + Canvas.MoveTo(XminPixel, Yp); + Canvas.LineTo(XmaxPixel, Yp); + end; + end; + + if Grid in [VERTIC_GRID, BOTH_GRID] then { Vertical lines } + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xp := Xpixel(X); + Canvas.MoveTo(Xp, YminPixel); + Canvas.LineTo(Xp, YmaxPixel); + end; + end; + + { Restore settings } + Canvas.Pen.Style := PenStyle; + end; + + function XOutOfBounds(X : Integer) : Boolean; + { Checks if an absissa is outside the graphic bounds } + begin + XOutOfBounds := (X < XminPixel) or (X > XmaxPixel); + end; + + function YOutOfBounds(Y : Integer) : Boolean; + { Checks if an ordinate is outside the graphic bounds } + begin + YOutOfBounds := (Y < YminPixel) or (Y > YmaxPixel); + end; + + function CheckPoint(X, Y : Float; + var Xp, Yp : Integer) : Boolean; + { Computes the pixel coordinates of a point and + checks if it is enclosed within the graph limits } + begin + Xp := Xpixel(X); + Yp := Ypixel(Y); + CheckPoint := not(XOutOfBounds(Xp) or YOutOfBounds(Yp)); + end; + + procedure PlotSymbol(Canvas : TCanvas; + Xp, Yp : Integer; + Symbol, Size : Integer); + { Plots a symbol at pixel coordinates (Xp, Yp) + with the current canvas settings } + var + Xp1, Xp2, Yp1, Yp2 : Integer; + begin + if Symbol > 0 then + begin + Size := Size * SymbolSizeUnit; + Xp1 := Xp - Size; + Yp1 := Yp - Size; + Xp2 := Xp + Size + 1; + Yp2 := Yp + Size + 1; + end; + + with Canvas do + case Symbol of + 0 : Pixels[Xp, Yp] := Brush.Color; + 1, 2 : Ellipse(Xp1, Yp1, Xp2, Yp2); { Circle } + 3, 4 : Rectangle(Xp1, Yp1, Xp2, Yp2); { Square } + 5, 6 : Polygon([Point(Xp1, Yp2 - 1), + Point(Xp2, Yp2 - 1), + Point(Xp, Yp1 - 1)]); { Triangle } + 7 : begin { + } + MoveTo(Xp, Yp1); + LineTo(Xp, Yp2); + MoveTo(Xp1, Yp); + LineTo(Xp2, Yp); + end; + 8 : begin { x } + MoveTo(Xp1, Yp1); + LineTo(Xp2, Yp2); + MoveTo(Xp1, Yp2 - 1); + LineTo(Xp2, Yp1 - 1); + end; + 9 : begin { * } + MoveTo(Xp, Yp1); + LineTo(Xp, Yp2); + MoveTo(Xp1, Yp); + LineTo(Xp2, Yp); + MoveTo(Xp1, Yp1); + LineTo(Xp2, Yp2); + MoveTo(Xp1, Yp2 - 1); + LineTo(Xp2, Yp1 - 1); + end; + end; + end; + + procedure PlotLine(Canvas : TCanvas; + Xp1, Yp1, Xp2, Yp2 : Integer); + { Plots a line with the current canvas settings } + begin + Canvas.MoveTo(Xp1, Yp1); + Canvas.LineTo(Xp2, Yp2); + end; + + procedure PlotPoint(Canvas : TCanvas; + X, Y : Float; + PointParam : TPointParam); + var + Xp, Yp : Integer; + BrushStyle : TBrushStyle; + PenColor, BrushColor : TColor; + begin + if XAxis.Scale = LOG_SCALE then X := Log10(X); + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + + if not CheckPoint(X, Y, Xp, Yp) then Exit; + + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + + Pen.Color := PointParam.Color; + Brush.Color := PointParam.Color; + if PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + PlotSymbol(Canvas, Xp, Yp, PointParam.Symbol, PointParam.Size); + + { Restore settings } + Pen.Color := PenColor; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + + procedure PlotErrorBar(Canvas : TCanvas; + Y, S : Float; + Ns : Integer; + Xp, Yp, Size : Integer); + { Plots an error bar with the current canvas settings } + var + Delta, Y1 : Float; + Yp1 : Integer; + begin + Size := Size * SymbolSizeUnit; + + Delta := Ns * S; + Y1 := Y - Delta; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Yp1 := Ypixel(Y1); + + if Yp1 <= YmaxPixel then + begin + PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1); + PlotLine(Canvas, Xp, Yp, Xp, Yp1); + end + else + PlotLine(Canvas, Xp, Yp, Xp, YmaxPixel); + + Y1 := Y + Delta; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Yp1 := Ypixel(Y1); + + if Yp1 >= YminPixel then + begin + PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1); + PlotLine(Canvas, Xp, Yp, Xp, Yp1); + end + else + PlotLine(Canvas, Xp, Yp, Xp, YminPixel); + end; + + procedure GenPlotCurve(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam; + ErrorBars : Boolean); + { General curve plotting routine } + var + X1, Y1, X2, Y2 : Float; + Xp1, Yp1, Xp2, Yp2 : Integer; + I : Integer; + Flag1, Flag2 : Boolean; + PenWidth : Integer; + PenStyle : TpenStyle; + PenColor, BrushColor : TColor; + BrushStyle : TBrushStyle; + begin + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + + Pen.Color := CurvParam.LineParam.Color; + Pen.Style := CurvParam.LineParam.Style; + Pen.Width := CurvParam.LineParam.Width; + Brush.Color := CurvParam.PointParam.Color; + + if CurvParam.PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + { Plot first point } + X1 := X^[Lbound]; if XAxis.Scale = LOG_SCALE then X1 := Log10(X1); + Y1 := Y^[Lbound]; if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Flag1 := CheckPoint(X1, Y1, Xp1, Yp1); + if Flag1 then + begin + PlotSymbol(Canvas, Xp1, Yp1, CurvParam.PointParam.Symbol, + CurvParam.PointParam.Size); + if ErrorBars and (S^[Lbound] > 0.0) then + PlotErrorBar(Canvas, Y^[Lbound], S^[Lbound], Ns, Xp1, Yp1, + CurvParam.PointParam.Size); + end; + + { Plot other points and connect them by lines if necessary } + I := Lbound + CurvParam.Step; + while I <= Ubound do + begin + X2 := X^[I]; if XAxis.Scale = LOG_SCALE then X2 := Log10(X2); + Y2 := Y^[I]; if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Flag2 := CheckPoint(X2, Y2, Xp2, Yp2); + if Flag2 then + begin + PlotSymbol(Canvas, Xp2, Yp2, CurvParam.PointParam.Symbol, + CurvParam.PointParam.Size); + if ErrorBars and (S^[I] > 0.0) then + PlotErrorBar(Canvas, Y^[I], S^[I], Ns, Xp2, Yp2, + CurvParam.PointParam.Size); + if CurvParam.Connect and Flag1 then + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + end; + + Xp1 := Xp2; + Yp1 := Yp2; + Flag1 := Flag2; + Inc(I, CurvParam.Step); + end; + + { Restore settings } + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + + procedure PlotCurve(Canvas : TCanvas; + X, Y : PVector; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); + var + Ns : Integer; { Dummy variables } + S : PVector; + begin + GenPlotCurve(Canvas, X, Y, S, Ns, Lbound, Ubound, CurvParam, False); + end; + + procedure PlotCurveWithErrorBars(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); + begin + GenPlotCurve(Canvas, X, Y, S, Ns, Lbound, Ubound, CurvParam, True); + end; + + procedure PlotFunc(Canvas : TCanvas; + Func : TFunc; + Xmin, Xmax : Float; + Npt : Integer; + LineParam : TLineParam); + var + PenColor : TColor; + PenStyle : TpenStyle; + PenWidth : Integer; + X1, Y1, X2, Y2, H : Float; + Xp1, Yp1, Xp2, Yp2 : Integer; + Flag1, Flag2 : Boolean; + I : Integer; + begin + if (Npt < 2) or (LineParam.Style = psClear) then Exit; + + if Xmin >= Xmax then + begin + Xmin := XAxis.Min; + Xmax := XAxis.Max; + end; + + H := (Xmax - Xmin) / Npt; + + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + + Pen.Color := LineParam.Color; + Pen.Style := LineParam.Style; + Pen.Width := LineParam.Width; + + { Check first point } + X1 := Xmin; + if XAxis.Scale = LIN_SCALE then + Y1 := Func(X1) + else + Y1 := Func(Exp10(X1)); + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Flag1 := CheckPoint(X1, Y1, Xp1, Yp1); + + { Check other points and plot lines if possible } + for I := 1 to Npt do + begin + X2 := X1 + H; + if XAxis.Scale = LIN_SCALE then + Y2 := Func(X2) + else + Y2 := Func(Exp10(X2)); + if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Flag2 := CheckPoint(X2, Y2, Xp2, Yp2); + if Flag1 and Flag2 then + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + X1 := X2; + Xp1 := Xp2; + Yp1 := Yp2; + Flag1 := Flag2; + end; + + { Restore settings } + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + end; + end; + + procedure WriteLegend(Canvas : TCanvas; + NCurv : Integer; + CurvParam : PCurvParamArray; + ShowPoints, + ShowLines : Boolean); + + var + CharHeight, I, L, Lmax, N, Nmax, Xp, Xl, Y : Integer; + PenWidth : Integer; + PenStyle : TpenStyle; + PenColor, BrushColor : TColor; + BrushStyle : TBrushStyle; + begin + N := 0; { Nb of legends to be plotted } + Lmax := 0; { Length of the longest legend } + + for I := 1 to NCurv do + if CurvParam^[I].Legend <> '' then + begin + Inc(N); + L := Canvas.TextWidth(CurvParam^[I].Legend); + if L > Lmax then Lmax := L; + end; + + if (N = 0) or (Lmax = 0) then Exit; + + { Character height } + CharHeight := Canvas.TextHeight('M'); + + { Max. number of legends which may be plotted } + Nmax := Round((YmaxPixel - YminPixel) / CharHeight) - 1; + if N > Nmax then N := Nmax; + + { Draw rectangle around the legends } + Canvas.Rectangle(XmaxPixel + Round(0.02 * GraphWidth), YminPixel, + XmaxPixel + Round(0.12 * GraphWidth) + Lmax, + YminPixel + (N + 1) * CharHeight); + + L := Round(0.02 * GraphWidth); { Half-length of line } + Xp := XmaxPixel + 3 * L; { Position of symbol } + Xl := XmaxPixel + 5 * L; { Position of legend } + + { Save current settings } + with Canvas do + begin + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + end; + + for I := 1 to IMin(NCurv, Nmax) do + with Canvas do + begin + Pen.Color := CurvParam^[I].LineParam.Color; + Pen.Style := CurvParam^[I].LineParam.Style; + Pen.Width := CurvParam^[I].LineParam.Width; + Brush.Color := CurvParam^[I].PointParam.Color; + + if CurvParam^[I].PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + { Plot point and line } + Y := YminPixel + I * CharHeight; + if ShowPoints then + PlotSymbol(Canvas, Xp, Y, CurvParam^[I].PointParam.Symbol, + CurvParam^[I].PointParam.Size); + if ShowLines then + PlotLine(Canvas, Xp - L, Y, Xp + L, Y); + + { Write legend } + Brush.Style := bsClear; + Canvas.TextOut(Xl, Y - CharHeight div 2, CurvParam^[I].Legend); + end; + + { Restore settings } + with Canvas do + begin + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + +end. diff --git a/niftiview7/windowsxp.RES b/niftiview7/windowsxp.RES new file mode 100755 index 0000000..5f33505 Binary files /dev/null and b/niftiview7/windowsxp.RES differ diff --git a/niftiview7/xrender.pas b/niftiview7/xrender.pas new file mode 100755 index 0000000..c1a0ccb --- /dev/null +++ b/niftiview7/xrender.pas @@ -0,0 +1,1266 @@ +unit xrender; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, Buttons,nifti_img, nifti_hdr,define_types,nifti_img_view, + StdCtrls, GraphicsMathLibrary, Menus,ClipBrd,ReadInt,cutout,IniFiles,FileCtrl, + RenderThds, ComCtrls, RXSpin; + +type + TRender = record + CutoutFrac,Cutout: TCutout; + Zoom: single; + cutoutLUTindex, ShadePct,BGNearClipFrac,OverlayNearClipFrac,BGNearClip,OverlayNearClip,Azimuth,Elevation, + OverlayFromBGSurface,BGSurface,OverlaySurface,BGDepth,OverlayDepth,CutoutBias: integer; + SmoothBG,SmoothOverlay,Trilinear,ShowCutout,FlipLR: boolean; + end; + + TRenderForm = class(TForm) + RenderBar: TPanel; + MainMenu1: TMainMenu; + FileMenu: TMenuItem; + Close1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Save1: TMenuItem; + Label4: TLabel; + Volume1: TMenuItem; + RenderBGSurfaceMenu: TMenuItem; + N1: TMenuItem; + N101: TMenuItem; + N401: TMenuItem; + N601: TMenuItem; + N801: TMenuItem; + N403: TMenuItem; + N404: TMenuItem; + N405: TMenuItem; + RenderBGDepthMenu: TMenuItem; + N1voxel1: TMenuItem; + N2voxels1: TMenuItem; + N4voxels1: TMenuItem; + N8voxels1: TMenuItem; + N16voxels1: TMenuItem; + N16voxels: TMenuItem; + RenderSmoothBG: TMenuItem; + RenderPreciseInterpolation: TMenuItem; + Label1: TLabel; + Overlay1: TMenuItem; + RenderOverlaySurfaceMenu: TMenuItem; + N701: TMenuItem; + N602: TMenuItem; + N501: TMenuItem; + N402: TMenuItem; + N301: TMenuItem; + N201: TMenuItem; + N102: TMenuItem; + N01: TMenuItem; + RenderOverlayDepthMenu: TMenuItem; + N16voxels2: TMenuItem; + N12voxels1: TMenuItem; + N8voxels2: TMenuItem; + N4voxels2: TMenuItem; + N2voxels2: TMenuItem; + N1voxel2: TMenuItem; + Quality1: TMenuItem; + RenderRefreshTimer: TTimer; + RenderPanel: TScrollBox; + RenderImage: TImage; + RenderImageBup: TImage; + Cutout1: TMenuItem; + RenderSmoothOverlay: TMenuItem; + FlipLRcheck: TMenuItem; + Settings1: TMenuItem; + Savesettings1: TMenuItem; + N2: TMenuItem; + Infinite1: TMenuItem; + Infinite2: TMenuItem; + Search1: TMenuItem; + BehindBG1: TMenuItem; + Infront1: TMenuItem; + Anydepth1: TMenuItem; + MIP1: TMenuItem; + Saveas36bitmaps1: TMenuItem; + BiasTrack: TTrackBar; + GainTrack: TTrackBar; + AzimuthEdit: TRxSpinEdit; + ElevationEdit: TRxSpinEdit; + QualityBtn: TSpeedButton; + ShadeEdit: TRxSpinEdit; + Label2: TLabel; + N3: TMenuItem; + procedure Save1Click(Sender: TObject); + procedure RenderImageMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure Copy1Click(Sender: TObject); + procedure Close1Click(Sender: TObject); + procedure N1Click(Sender: TObject); + procedure N01Click(Sender: TObject); + procedure N1voxel1Click(Sender: TObject); + procedure N16voxels2Click(Sender: TObject); + procedure RenderSmoothClick(Sender: TObject); + procedure RenderPreciseInterpolationClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure RenderRefreshTimerTimer(Sender: TObject); + procedure EditChange(Sender: TObject); + procedure OverlayRenderDepthItem(Sender: TObject); + procedure RenderImageMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Cutout1Click(Sender: TObject); + procedure Savesettings1Click(Sender: TObject); + procedure UpdateRenderMRU; + procedure OpenRenderMRU(Sender:TObject); + procedure UpdateRenderDisplay; + procedure FormHide(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure CapBtnMenu1Click(Sender: TObject); + procedure SetSearch(Sender: TObject); +procedure RefreshRotation; + procedure VolumeRotateMatrix (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean;lNearSlicesClipInFrac: integer); + procedure Saveas36bitmaps1Click(Sender: TObject); + procedure BiasTrackChange(Sender: TObject); + procedure QualityBtnClick(Sender: TObject); + procedure Generateoversampledrenderingslow1Click(Sender: TObject); + + private + + ThreadsRunning: Integer; + procedure ThreadDone(Sender: TObject); + { Private declarations } + public + procedure SliceToFrac; { Public declarations } + end; +var + CritSect : TRTLCriticalSection; + RenderForm: TRenderForm; + gRender:TRender; + gRenderDir,gRenderStartupFilename,gRenderDefaultsFilename:string; + gZoom : single = 1; +implementation + +uses MultiSlice,Math {power}; +const + //kAnywhere = 0; + kBelow = 1; + kInFront = 2; + gInc: integer = 0; + +{x$R *.DFM} + +procedure LUTbiasX (var lOutLUT : TLUT; lBiasIn: integer {0..9}); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick Graphics Gems IV, p379-382, April 1994 } +var + lIndex: integer; + lA,lT,lBias: single; + lLUT: TLUT; +begin + if lBiasIn = 4 then exit; + lA := (lBiasIn+1)/10; + if lA = 0 then + lA := 0.000001; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[round(lBias)]; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + +procedure LUTgainX (var lOutLUT : TLUT; lBiasIn,lGainIn: integer {0..99}); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick Graphics Gems IV, p379-382, April 1994 } +var + lIndex,lV: integer; + lA,lG,lT,lGain: single; + lLUT: TLUT; +begin + if (lGainIn = 50) and (lBiasIn = 50) then exit; + lA := (lBiasIn)/100; + if lA = 0 then + lA := 0.000001; + lG := (lGainIn)/100; + if lG = 0 then + lG := 0.00001; + if lG = 1 then + lG := 0.99999; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //apply bias + lT := (lt/((1/la-2)*(1-lt)+1)) ; + //next apply gain + if lT < 0.5 then + lGain := (lT/((1/lG-2)*(1-2*lT)+1)) + else + lGain := (( (1/lG-2)*(1-2*lT)-lT ) / ( (1/lG-2)*(1-2*lT)-1 ) ); + lGain := lGain / lT; + lV := round(255*lT*lGain); + if lV > 255 then + lV := 255; + if lV < 0 then + lV := 0; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[lV]; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + + +procedure TRenderForm.ThreadDone(Sender: TObject); +begin + EnterCriticalSection(CritSect); +Dec(ThreadsRunning); + LeaveCriticalSection(CritSect); +end; + +procedure TRenderForm.UpdateRenderDisplay; +begin + SetSubmenuWithTag(RenderBGSurfaceMenu,gRender.BGSurface); + SetSubmenuWithTag(RenderOverlaySurfaceMenu,gRender.OverlaySurface); + SetSubmenuWithTag(RenderBGDepthMenu,gRender.BGDepth); + SetSubmenuWithTag(RenderOverlayDepthMenu,gRender.OverlayDepth); + RenderSmoothBG.checked := gRender.SmoothBG; + RenderSmoothOverlay.checked := gRender.SmoothOverlay; + RenderPreciseInterpolation.Checked := gRender.Trilinear; + //RenderSurfaceOverlay.Checked := gRender.OverlayFromBGSurface; + SetSubmenuWithTag(Search1,gRender.OverlayFromBGSurface); + FlipLRCheck.Checked := gRender.FlipLR; + AzimuthEdit.value := gRender.Azimuth; + ElevationEdit.value := gRender.Elevation; + ShadeEdit.value := gRender.ShadePct; + RenderRefreshTimer.tag := -1; + RenderRefreshTimer.enabled := true; +end; + +procedure WriteRenderIniFile (lFilename: string); +var + lIniFile: TIniFile; + lInc: integer; +begin + if DiskFreeEx(lFilename) < 1 then + exit; + if not DirectoryExists(extractfiledir(lFilename)) then begin + mkDir(extractfiledir(lFilename)); + end; + lIniFile := TIniFile.Create(lFilename); + with gRender do begin + //Booleans + //SmoothBG,SmoothOverlay,Trilinear,OverlayFromBGSurface,ShowCutout + + lIniFile.WriteString('BOOL', 'SmoothBG',Bool2Char( SmoothBG)); + lIniFile.WriteString('BOOL', 'SmoothOverlay',Bool2Char( SmoothOverlay)); + lIniFile.WriteString('BOOL', 'Trilinear',Bool2Char( Trilinear)); + lIniFile.WriteString('BOOL', 'ShowCutout',Bool2Char( ShowCutout)); + lIniFile.WriteString('BOOL', 'FlipLR',Bool2Char( FlipLR)); + //Integers + //BGNearClip,OverlayNearClip,Azimuth,Elevation, + //BGSurface,OverlaySurface,BGDepth,OverlayDepth: integer; + lIniFile.WriteString('INT', 'OverlayFromBGSurface',IntToStr( OverlayFromBGSurface)); + lIniFile.WriteString('INT', 'BGNearClipFrac',IntToStr(BGNearClipFrac)); + lIniFile.WriteString('INT', 'OverlayNearClipFrac',IntToStr(OverlayNearClipFrac)); + lIniFile.WriteString('INT', 'Azimuth',IntToStr(Azimuth)); + lIniFile.WriteString('INT', 'Elevation',IntToStr(Elevation)); + lIniFile.WriteString('INT', 'BGSurface',IntToStr(BGSurface)); + lIniFile.WriteString('INT', 'OverlaySurface',IntToStr(OverlaySurface)); + lIniFile.WriteString('INT', 'BGDepth',IntToStr(BGDepth)); + lIniFile.WriteString('INT', 'OverlayDepth',IntToStr(OverlayDepth)); + lIniFile.WriteString('INT', 'CutoutBias',IntToStr(CutoutBias)); + lIniFile.WriteString('INT', 'ShadePct',IntToStr(ShadePct)); + lIniFile.WriteString('INT', 'cutoutLUTindex',IntToStr(cutoutLUTindex)); + for lInc := 1 to 3 do begin + lIniFile.WriteString('INT', 'CutoutLoFrac'+inttostr(lInc),IntToStr(CutoutFrac.Lo[lInc])); + lIniFile.WriteString('INT', 'CutoutHiFrac'+inttostr(lInc),IntToStr(CutoutFrac.Hi[lInc])); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure ReadRenderIniFile (lFilename: string); +var + lStr: string; + lIniFile: TIniFile; + lInc: integer; +begin + if not FileexistsEx(lFilename) then begin + exit; + end; + lIniFile := TIniFile.Create(lFilename); + lStr := lIniFile.ReadString('STR', 'Slices', '10,20,30');//file0 - last file viewed + with gRender do begin + //Booleans + //SmoothBG,SmoothOverlay,Trilinear,OverlayFromBGSurface,ShowCutout + SmoothBG := IniBool(lIniFile,'SmoothBG',SmoothBG); + SmoothOverlay := IniBool(lIniFile,'SmoothOverlay',SmoothOverlay); + Trilinear := IniBool(lIniFile,'Trilinear',Trilinear); + //OverlayFromBGSurface := IniBool(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + ShowCutout := IniBool(lIniFile,'ShowCutout',ShowCutout); + FlipLR := IniBool(lIniFile,'FlipLR',FlipLR); + //lIniFile.WriteString('BOOL', 'FlipLR',Bool2Char( FlipLR)); + //Integers + //BGNearClip,OverlayNearClip,Azimuth,Elevation, + //BGSurface,OverlaySurface,BGDepth,OverlayDepth: integer; + OverlayFromBGSurface:= IniInt(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + BGNearClip:= IniInt(lIniFile,'BGNearClip',0); + OverlayNearClip:= IniInt(lIniFile,'OverlayNearClip',0); + BGNearClipFrac:= IniInt(lIniFile,'BGNearClipFrac',-1); + OverlayNearClipFrac:= IniInt(lIniFile,'OverlayNearClipFrac',-1); + Azimuth:= IniInt(lIniFile,'Azimuth',Azimuth); + Elevation:= IniInt(lIniFile,'Elevation',Elevation); + BGSurface:= IniInt(lIniFile,'BGSurface',BGSurface); + OverlaySurface:= IniInt(lIniFile,'OverlaySurface',OverlaySurface); + BGDepth:= IniInt(lIniFile,'BGDepth',BGDepth); + if BGDepth > 32000 then + BGDepth := 32000; + OverlayDepth:= IniInt(lIniFile,'OverlayDepth',OverlayDepth); + if OverlayDepth > 32000 then + OverlayDepth := 32000; + CutoutBias:= IniInt(lIniFile,'CutoutBias', CutoutBias); + ShadePct:= IniInt(lIniFile,'ShadePct', 0); + cutoutLUTindex:= IniInt(lIniFile,'cutoutLUTindex',cutoutLUTindex); + for lInc := 1 to 3 do begin + Cutout.Lo[lInc] := IniInt(lIniFile,'CutoutLo'+inttostr(lInc),Cutout.Lo[lInc]); + Cutout.Hi[lInc] := IniInt(lIniFile,'CutoutHi'+inttostr(lInc),Cutout.Hi[lInc]); + end; + + for lInc := 1 to 3 do begin + CutoutFrac.Lo[lInc] := IniInt(lIniFile,'CutoutLoFrac'+inttostr(lInc),-1); + CutoutFrac.Hi[lInc] := IniInt(lIniFile,'CutoutHiFrac'+inttostr(lInc),-1); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure TRenderForm.OpenRenderMRU(Sender:TObject); +var + lFilename: string; +begin + lFilename := gRenderDir+(Sender as TMenuItem).caption+'.ini' ; + ReadRenderIniFile(lFilename); + CutoutForm.Prep; + UpdateRenderDisplay; +end; + +procedure TRenderForm.UpdateRenderMRU; +var + NewItem: TMenuItem; + lSearchRec: TSearchRec; +begin + While Settings1.Count > 0 do Settings1.Items[0].Free; + if FindFirst(gRenderDir+'*.ini', faAnyFile, lSearchRec) = 0 then + repeat + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ParseFileName(ExtractFileName(lSearchRec.Name)); + NewItem.Onclick := OpenRenderMRU; + Settings1.Add(NewItem); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end; + +procedure Smooth2DImage (lX,lY: integer; lInBuffer: ByteP); +var + lSmoothBuffer: ByteP; + lLine,lLineStart,lInc,lOutPixel,lV: integer; +begin GetMem (lSmoothBuffer , lX*lY); FillChar(lSmoothBuffer^,lX*lY, 0); //zero array + for lLine:= (lY-1) downto 2 do begin + lLineStart := ((lLine-1)*(lX)); + for lInc := (lX-1) downto 2 do begin + lOutPixel := lLineStart+lInc; + lV := (lInBuffer[lOutPixel] shl 3) + +(lInBuffer[lOutPixel+1] shl 1)+(lInBuffer[lOutPixel-1] shl 1) + +(lInBuffer[lOutPixel+lX] shl 1)+(lInBuffer[lOutPixel-lX] shl 1) + +(lInBuffer[lOutPixel+lX+1])+(lInBuffer[lOutPixel+lX-1]) + +(lInBuffer[lOutPixel-lX+1])+(lInBuffer[lOutPixel-lX-1]) + ; + lV := lV div 20; + lSmoothBuffer[lOutPixel] := lV;//lV; + end; //for each column + end; //for each line (row) + Move(lSmoothBuffer[1],lInBuffer[1],lX*lY); + FreeMem(lSmoothBuffer); +end; //proc Smooth2DImage + +(*function MinFilt (var lHdr: TMRIcroHdr): integer; +var lMin,lMax: single; +lFiltMin8bit, lFiltMax8bit: integer; +begin +ReturnMinMax (lHdr,lMin,lMax, lFiltMin8bit, lFiltMax8bit); +result := lFiltMin8bit; +end;*) +procedure MinMaxFilt (var lHdr: TMRIcroHdr; var lFiltMin8bit, lFiltMax8bit: integer);var lMin,lMax: single; +begin +ReturnMinMax (lHdr,lMin,lMax, lFiltMin8bit, lFiltMax8bit); +end;procedure CreateOverlayRenderBehind(var lBGHdr,lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDepth: Integer; var lQuadP: RGBQuadp; Smooth2D: boolean);var lSrc,lOutBuffer: Bytep; lLow,lHigh, lIntensity,lDepth,lPixel,lSliceOffset,lSliceSz,lVolSz,lRenderSurface,lRenderDepth: integer;begin if gBGImg.RenderDepthBufferItems < 1 then exit; lSrc := lHdr.RenderBuffer;//lHdr.ScrnBuffer; lSliceSz := lX*lY; lVolSz := lSliceSz * lZ; GetMem (lOutBuffer , lSliceSz); fillchar(lOutBuffer^,lSliceSz,0); lRenderDepth := lInRenderDepth; if (lRenderDepth < 1) or (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then lRenderDepth := 1; lRenderSurface := lInRenderSurface; if (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then lRenderSurface := 1; for lPixel := 1 to lSliceSz do begin if gBGImg.RenderDepthBuffer[lPixel] <> 0 then begin //background surface at this voxel lDepth := 0; lIntensity := 0; lSliceOffset := (abs(gBGImg.RenderDepthBuffer[lPixel])-1)*lSliceSz; //start with nearest slice while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin if (lSrc[lSliceOffset+lPixel] > lRenderSurface) and (lSrc[lSliceOffset+lPixel] > lIntensity) then lIntensity := lSrc[lSliceOffset+lPixel]; inc(lSliceOffset,lSliceSz); inc(lDepth); if gBGImg.RenderDepthBuffer[lPixel] < 0 then lDepth := lRenderDepth; //only show surface for cutout end; lOutBuffer[lPixel]:= lIntensity; end; //background surface at this voxel end; if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels Smooth2DImage (lX,lY, lOutBuffer);//Mar2007 startif lHdr.LUTfromZero then begin MinMaxFilt(lHdr,lLow,lHigh); //fx(lLow,lHigh); if lLow > 0 then for lPixel := 1 to (lSliceSz) do if lOutBuffer[lPixel] < lLow then lOutBuffer[lPixel] := 0; if lHigh < 255 then for lPixel := 1 to (lSliceSz) do if lOutBuffer[lPixel] < lHigh then lOutBuffer[lPixel] := 0; //xxxend;//Mar2007 end for lPixel := 1 to lSliceSz do lQuadP[lPixel]:= lHdr.LUT[lOutBuffer[lPixel]]; Freemem(lOutBuffer);end;procedure CreateOverlayRenderInfrontNear(var lBGHdr,lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDepth: Integer; var lQuadP: RGBQuadp; Smooth2D: boolean);//changes Aug2007 - make sure search depth is not MAxInt - we get wrap aroundvar lSrc,lOutBuffer: Bytep; lLow,lHigh, lIntensity,lDepth,lPixel,lSliceOffset,lSliceSz,lVolSz,lRenderSurface,lRenderDepth,lSamples: integer;begin if gBGImg.RenderDepthBufferItems < 1 then exit; lSrc := lHdr.RenderBuffer;//lHdr.ScrnBuffer; lSliceSz := lX*lY; lVolSz := lSliceSz * lZ; GetMem (lOutBuffer , lSliceSz); fillchar(lOutBuffer^,lSliceSz,0); //lRenderDepth := lInRenderDepth; //if (lRenderDepth < 1) or (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then // lRenderDepth := 1; lRenderSurface := lInRenderSurface; if (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then lRenderSurface := 1; for lPixel := 1 to lSliceSz do begin if gBGImg.RenderDepthBuffer[lPixel] <> 0 then begin //background surface at this voxel lDepth := 0; lIntensity := 0; lSliceOffset := 0; lSamples := 0; lRenderDepth := (abs(gBGImg.RenderDepthBuffer[lPixel])-1)+lInRenderDepth; //lSliceOffset := (abs(gBGImg.RenderDepthBuffer[lPixel])-1)*lSliceSz; //start with nearest slice while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin if (lSrc[lSliceOffset+lPixel] > lRenderSurface) then begin lIntensity := lIntensity+lSrc[lSliceOffset+lPixel]; inc(lSamples); end; inc(lSliceOffset,lSliceSz); inc(lDepth); if gBGImg.RenderDepthBuffer[lPixel] < 0 then lDepth := lRenderDepth; //only show surface for cutout end; if lSamples > 0 then lOutBuffer[lPixel]:= lIntensity div lSamples; //lOutBuffer[lPixel]:= lIntensity; end ; //if background end; if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels Smooth2DImage (lX,lY, lOutBuffer);//Mar2007 startif lHdr.LUTfromZero then begin MinMaxFilt(lHdr,lLow,lHigh); //fx(lLow,lHigh); if lLow > 0 then for lPixel := 1 to (lSliceSz) do if lOutBuffer[lPixel] < lLow then lOutBuffer[lPixel] := 0; if lHigh < 255 then for lPixel := 1 to (lSliceSz) do if lOutBuffer[lPixel] < lHigh then lOutBuffer[lPixel] := 0; //xxxend; for lPixel := 1 to lSliceSz do lQuadP[lPixel]:= lHdr.LUT[lOutBuffer[lPixel]]; Freemem(lOutBuffer);end;(*procedure Mx (M: TMatrix);beginTextForm.Memo1.Lines.Add(floattostr(M.matrix[1,1])+'x'+floattostr(M.matrix[1,2])+'x'+floattostr(M.matrix[1,3])+'x'+floattostr(M.matrix[1,4]));TextForm.Memo1.Lines.Add(floattostr(M.matrix[2,1])+'x'+floattostr(M.matrix[2,2])+'x'+floattostr(M.matrix[2,3])+'x'+floattostr(M.matrix[2,4]));TextForm.Memo1.Lines.Add(floattostr(M.matrix[3,1])+'x'+floattostr(M.matrix[3,2])+'x'+floattostr(M.matrix[3,3])+'x'+floattostr(M.matrix[3,4]));TextForm.Memo1.Lines.Add(floattostr(M.matrix[4,1])+'x'+floattostr(M.matrix[4,2])+'x'+floattostr(M.matrix[4,3])+'x'+floattostr(M.matrix[4,4]));TextForm.Memo1.Lines.Add('-');end;*)Function AziElevMatrix: TMatrix;var lLRFlipMatrix: TMatrix;begin + gRender.Azimuth := RenderForm.AzimuthEdit.asInteger; + gRender.Elevation := RenderForm.ElevationEdit.asInteger; + result := ViewTransformMatrix( + coordSpherical, + ToRadians(RenderForm.AzimuthEdit.Value), + ToRadians(RenderForm.ElevationEdit.Value), + 3{Distance.Value},6{ScreenWidthHeight.Value},6{ScreenWidthHeight.Value},{ScreenToCamera.Value}3); + {The ViewTransformMatrix is all that is needed for other objects defined in world coordinates.} + if gRender.FlipLR then begin + // Mx(result); + lLRFlipMatrix := Matrix3D (-1,0,0,0, // 3D "graphics" matrix + 0,1,0,0, + 0,0,1,0, + 0,0,0,1); + + result := MultiplyMatrices(lLRFlipMatrix,Result); + end; +end; +procedure InvertMatrixPoint (var lBackgroundImg: TBGImg; var lInMatrix: TMatrix; var lXin,lYin,lZIn, lXout,lYout,lZout: integer);//convert mouse click to position +var + lZ,lY,lX,lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn: integer; + lMatrix: TMatrix; +begin + //lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutDim := round(gBGImg.RenderDim/gRender.Zoom) + else + lOutDim :=gBGImg.RenderDim; //11/2007b + lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (lBackgroundImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (lBackgroundImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (lBackgroundImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lX := (lXin-lOutPivot); + lY := ({lYin-}lOutPivot-lYin); + lZ := (lZin-lOutPivot); + lMatrix := InvertMatrix3D(lInMatrix); + lXout := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYout := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZout := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXOut := (lXOut+lXPivotIn); + lYOut := (lYOut+lYPivotIn); + lZOut := (lZOut+lZPivotIn); +end; +procedure ShadeCutoutCrease (var lRenderBuffer: bytep);var +lZ,lY,lX: single; + lXin,lYin,lZIn,lXm,lYm,lZm,lPixel, + lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn, + lXlo,lXhi,lYlo,lYhi,lZlo,lZhi,lYOffset: integer; + lClose,lScale: single; + lMatrix: TMatrix; +begin + lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutPivot := (round(gBGImg.RenderDim/gRender.Zoom)+1) shr 1 + else + lOutPivot :=(gBGImg.RenderDim+1) shr 1; //11/2007b + //lOutPivot := (gRender.UnscaledRenderDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + //lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (gBGImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (gBGImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (gBGImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lMatrix := InvertMatrix3D(AziElevMatrix); + //next: dilate borders by 1 pixel - draw crease INSIDE cutout + lXlo := gRender.CutOut.Lo[1]-1; + lXhi := gRender.CutOut.Hi[1]+1; + lYlo := gRender.CutOut.Lo[2]-1; + lYhi := gRender.CutOut.Hi[2]+1; + lZlo := gRender.CutOut.Lo[3]-1; + lZhi := gRender.CutOut.Hi[3]+1; + lScale := 1/gRender.Zoom; //11/2007 + //renderform.caption := inttostr(gRender.UnscaledRenderDim)+' '+inttostr(gRender.Zoom); + for lYin := 1 to lOutDim do begin + lYOffset := ((gBGImg.RenderDim-lYin)*gBGImg.RenderDim); + for lXin := 1 to lOutDim do begin + lPixel := lXin+ lYOffset; + if gBGImg.RenderDepthBuffer[lPixel]<0 then begin + lZin := abs(gBGImg.RenderDepthBuffer[lPixel]); + {lX := (lXin-lOutPivot); + lY := (lOutPivot-(lYin)); + lZ := (lZin-lOutPivot);} + lX := (lXin *lScale)-lOutPivot ; + lY := lOutPivot -(lYin * lScale); + lZ := (lZin * lScale)-lOutPivot; + lXm := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYm := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZm := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXm := (lXm+lXPivotIn); + lYm := (lYm+lYPivotIn); + lZm := (lZm+lZPivotIn); + if abs(lXlo-lXm) < abs(lXhi-lXm) then + lXm := abs(lXlo-lXm) + else + lXm := abs(lXhi-lXm); + if abs(lYlo-lYm) < abs(lYhi-lYm) then + lYm := abs(lYlo-lYm) + else + lYm := abs(lYhi-lYm); + if abs(lZlo-lZm) < abs(lZhi-lZm) then + lZm := abs(lZlo-lZm) + else + lZm := abs(lZhi-lZm); + if (lXm < lYm) and (lZm < lYm) then + lYm := lZm //Y is furthest, replace with Z + else if lZm < lXm then //X is furthest, replace with Z + lXm := lZm; + lClose := sqrt((lXm*lXm) + (lYm*lYm)); + if lClose < 8 then begin + lClose := 1-sqr(1-(lClose/8)); + lRenderBuffer[lPixel] := round(lRenderBuffer[lPixel]*(0.33+(0.67*lClose))); + end; + end; + end; //for lYin + end; //for lXin +end; + + +function SmoothShading (lX,lY: integer; lRenderDepthBuffer: SmallintP): boolean; +var + kRenderInfiniteDepth,lPrevLineStart,lNextLineStart,lLineStart,lScanLines, + lGap,lDepthSum,lWeightSum,lFar,lClose,lCenter,lInc,lXmG: integer; + lRenderDepthBufferS: SmallIntP; +procedure AddPt (lI,lW: integer; var lSumI,lSumW: integer); +begin + if lI = kRenderInfiniteDepth then exit; + lSumI := lSumI + (lW*lI); //add scaled value + lSumW := lSumW + lW;//add weight +end; +//problem - smoothing gives embossed look! +begin //func Smoothshading + kRenderInfiniteDepth := 0; + result := false; + if (gRender.Zoom < 1) or (lY < 5) or (lX < 5) or (gBGImg.RenderDepthBufferItems <> (lX * lY)) then + exit; + lFar := 2; + lClose := 3; + lCenter := 5; + lGap := trunc((gRender.Zoom-0.001)/1)+1; //must be at least 1! + lXmG := lX-lGap; + Getmem(lRenderDepthBufferS,lX*lY*sizeof(smallint)); + for lInc := 1 to (lX*lY) do + lRenderDepthBufferS^[lInc] := lRenderDepthBuffer^[lInc]; + + for lScanlines := (1+lGap) to (lY - lGap) do begin //can not compute angle for 1st and last scanline + lLineStart := (lScanLines-1)*lX; //inc from 0 + lPrevLineStart := lLineStart-(lX*lGap); //inc from 0 + lNextLineStart := lLineStart+(lX*lGap); //inc from 0 + for lInc := (1+lGap) to (lXmG) do begin + lWeightSum := 0; + lDepthSum := 0; + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc-1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc+1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc-1],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc],lCenter,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc+1],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc-1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc+1],lFar,lDepthSum,lWeightSum); + if lWeightSum > 0 then + lRenderDepthBufferS^[lLineStart+lInc] := round(lDepthSum/lWeightSum); + end; //columns + end; //for scanlines: rows + for lInc := 1 to (lX*lY) do + lRenderDepthBuffer^[lInc] := lRenderDepthBufferS^[lInc]; + freemem(lRenderDepthBufferS); + result := true; +end; //function SmoothShading + + +function IlluminationShading (lX,lY,lPct: integer; lImgBuffer: bytep; lRenderDepthBuffer: SmallintP): boolean; +var + kRenderInfiniteDepth,lXmG,lPrevLineStart,lNextLineStart,lLineStart,lScanLines, + lGap,lIntensity,lInc,lGrayMin,lGrayMax: integer; + lShadeFrac,lImgFrac, + lPhongMagic,lMagic,lYVal,lXVal,lNormalPlane,lXLight,lYLight,lZLight,lLightVectorNormalise: single; + lShadeBuffer: bytep; +begin //func illumination shading + + result := false; + if {(gRender.Zoom < 1) or} (lPct < 1) or (lY < 5) or (lX < 5) or (gBGImg.RenderDepthBufferItems <> (lX * lY)) then + exit; + lMagic := 1; + lPhongMagic := 1; + kRenderInfiniteDepth := 0; + lXLight := 0;//RenderForm.XL.value / 100;//lXLight / lLightVectorNormalise; + lYLight := -0.5;//Renderform.YL.value / 100;//lYLight / lLightVectorNormalise; + lZLight := -1;//RenderForm.ZL.value / 100;//lZLight / lLightVectorNormalise; + lLightVectorNormalise := sqrt(sqr(lXLight)+sqr(lYLight)+sqr(lZLight)); + lXLight := lXLight / lLightVectorNormalise; + lYLight := lYLight / lLightVectorNormalise; + lZLight := lZLight / lLightVectorNormalise; + lGrayMin := 0{64}; + lGrayMax := 255 - lGrayMin; + lGap := 1; + lXmG := lX-lGap; + Getmem(lShadeBuffer,lX*lY*sizeof(byte)); + fillchar(lShadeBuffer^,lX*lY,0); + + for lScanlines := (1+lGap) to (lY - lGap) do begin //can not compute angle for 1st and last scanline + lLineStart := (lScanLines-1)*lX; //inc from 0 + lPrevLineStart := lLineStart-(lGap*lX); //inc from 0 + lNextLineStart := lLineStart+(lGap*lX); //inc from 0 + for lInc := (1+lGap) to (lXmG) do begin + if lImgBuffer^[lLineStart+lInc] <> 0 then begin //only shade non-zero intensities + if ( lRenderDepthBuffer^[lPrevLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lPrevLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lPrevLineStart+lInc+1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc+1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc+1]<>kRenderInfiniteDepth) then begin + lYVal := lRenderDepthBuffer^[lPrevLineStart+lInc-1]+lRenderDepthBuffer^[lPrevLineStart+lInc]+lRenderDepthBuffer^[lPrevLineStart+lInc+1] + -lRenderDepthBuffer^[lNextLineStart+lInc-1]-lRenderDepthBuffer^[lNextLineStart+lInc]-lRenderDepthBuffer^[lNextLineStart+lInc+1]; + lXVal := lRenderDepthBuffer^[lPrevLineStart+lInc-1]+lRenderDepthBuffer^[lLineStart+lInc-1]+lRenderDepthBuffer^[lNextLineStart+lInc-1] + -lRenderDepthBuffer^[lPrevLineStart+lInc+1]-lRenderDepthBuffer^[lLineStart+lInc+1]-lRenderDepthBuffer^[lNextLineStart+lInc+1]; + lNormalPlane := sqrt(sqr(lXVal)+sqr(lYVal)+sqr(lMagic)); + if lNormalPlane <> 0 then begin + lNormalPlane := -((-lXLight*lXVal)-(lYLight*lYVal)+lMagic*lZLight)/lNormalPlane; + if {lImageAndShade} false then begin + lNormalPlane := Power(lNormalPlane,lPhongMagic); + //lIntensity := gProjBuffer[lLineStart+lInc]; + //lIntensity := lPropShadingPivot+round((lPctImage*(lIntensity-lPropShadingPivot))+(lPctShade*(lNormalPlane-0.5)) ); + if lIntensity > 254 then lIntensity := 254; + lShadeBuffer^[lLineStart+lInc] := lIntensity; + end else begin //shading only + //if lAbbaRandom then //abba + lNormalPlane := (lNormalPlane+1) / 2; + if lNormalPlane > 0 then begin + lNormalPlane := Power(lNormalPlane,lPhongMagic); + //if lAbbaRandom then //abba + //if lNormalPlane < 0.5 then lNormalPlane := 1-lNormalPlane; //backlighting + lShadeBuffer^[lLineStart+lInc] := lGrayMin{64}+ round(lNormalPlane*(lGrayMax)); + end else + lShadeBuffer^[lLineStart+lInc] := lGrayMin; + end; //Shading vs ImageAndShading + end; //NormalPlane = 0 + end else begin //samples for each pixel + if {lImageAndShade}false then + lShadeBuffer^[lLineStart+lInc] := 0//lPropShadingPivot+round((lPctImage*(gProjBuffer[lLineStart+lInc]-lPropShadingPivot))+(lPctShade*(-0.5)) )//1362 + else + lShadeBuffer^[lLineStart+lInc] := lGrayMin;//1363;'# 20{64}; + end; + end; //only shade non-zero intensities + end; //columns + end; //for scanlines: rows + if lPct > 99 then begin + for lInc := 1 to (lX*lY) do + lImgBuffer^[lInc] := lShadeBuffer^[lInc]; + + end else begin //partial shade + lImgFrac := (100-lPct)/100; + lShadeFrac := lPct/100; + for lInc := 1 to (lX*lY) do + lImgBuffer^[lInc] := round((lImgBuffer^[lInc]* lImgFrac) + (lShadeBuffer^[lInc]*lShadeFrac )); + end; + freemem(lShadeBuffer); + result := true; +end; //function illuminationshading + +procedure LUTLoad( lLUTindex: integer; var lLUT: TLUT); +var + lHdr: TMRIcroHdr; + lStr: string; + lInc: integer; +begin + //gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + if lLUTindex < knAutoLUT then begin + LoadMonochromeLUT(lLUTindex,gBGImg,lHdr); + end else begin //if B&W lut + lStr := gColorSchemeDir+pathdelim+ImgForm.LUTdrop.Items.Strings[lLUTindex]+'.lut'; + if not FileExistsEX(lStr) then + showmessage('Can not find '+lStr); + LoadColorScheme(lStr, lHdr); + end; + for lInc := 0 to 255 do + lLUT[lInc] := lHdr.LUT[lInc]; +end; + + +procedure CreateRender(var lBGHdr, lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDpeth: Integer; var lQuadP: RGBQuadp; Smooth2D, NormalizeIntensity,lCreateDepthBuffer: boolean;lUseDepthBuffer: integer); +var lLUT : array [0..255] of byte; lrgbLUT: TLUT;// array[0..255] of TRGBQuad; lSrc,lOutBuffer: Bytep; lShade: boolean; lPreciseDepthBuffer: Smallintp; //lTime: Dword; lNear,lSubPixel,lMaxInten,lDepth,lPixel,lSamples,lSliceOffset, //lEnd, lIntensity,lSliceSz,lVolSz,lRenderDepth,lRenderSurface,lTemp: integer;begin lShade := false; if (gRender.BGNearClipFrac<>0) or (gRender.ShowCutout) then lMaxInten := 254 else lMaxInten := 257; lRenderDepth := lInRenderDpeth; if (lRenderDepth < 0) or (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then lRenderDepth := 1; lRenderSurface := lInRenderSurface; if (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then lRenderSurface := 1 else begin //make sure at least some voxels are below air-surface threshold if (lHdr.WindowScaledMin <= (Raw2ScaledIntensity(lHdr,lHdr.GlMinUnscaledS) )) and (lHdr.WindowScaledMax <> 0)then begin lTemp := round( (Raw2ScaledIntensity(lHdr,lHdr.GlMinUnscaledS)-lHdr.WindowScaledMin)/(lHdr.WindowScaledMax)*255); if lTemp >= lRenderSurface then lRenderSurface := lTemp + 1; end; end; if (lUseDepthBuffer=kBelow) then begin CreateOverlayRenderBehind(lBGHdr,lHdr, lX,lY,lZ,lRenderSurface,lRenderDepth, lQuadP, Smooth2D); exit; end; if (lUseDepthBuffer=kInFront) then begin CreateOverlayRenderInfrontNear(lBGHdr,lHdr, lX,lY,lZ,lRenderSurface,lRenderDepth, lQuadP, Smooth2D); exit; end; lSrc := lHdr.RenderBuffer; lSliceSz := lX*lY; lVolSz := lSliceSz * lZ; GetMem (lOutBuffer , lX*lY); if lCreateDepthBuffer then begin if (gRender.ShadePct > 0) then begin lShade := true; getmem(lPreciseDepthBuffer,lSliceSz * sizeof(smallint)); fillchar(lPreciseDepthBuffer^,lSliceSz* sizeof(smallint),0); end; if gBGImg.RenderDepthBufferItems <> lSliceSz then begin if gBGImg.RenderDepthBufferItems > 0 then Freemem(gBGImg.RenderDepthBuffer); gBGImg.RenderDepthBufferItems := lSliceSz; GetMem(gBGImg.RenderDepthBuffer,lSliceSz*sizeof(smallint)); end; //no RenderDepthBuffer fillchar(gBGImg.RenderDepthBuffer^,lSliceSz{* sizeof(smallint)},0); if lRenderDepth = 0 then begin//MIP //MIP follows //lTime := GetTickCount; (*for lPixel := 1 to lSliceSz do begin lIntensity := 0; lSliceOffset := (lPixel-1)*lX; //start with nearest slice lEnd := lSliceOffset + lX; while (lSliceOffset < lEnd) do begin if (lSrc[lSliceOffset] < lMaxInten) and (lSrc[lSliceOffset] > lIntensity) then begin lIntensity := lSrc[lSliceOffset]; gBGImg.RenderDepthBuffer[lPixel] := lSliceOffset div lSliceSz+1; if lShade then lPreciseDepthBuffer[lPixel] := gBGImg.RenderDepthBuffer[lPixel] * 10; end; inc(lSliceOffset,1); end; //while no voxel found (* *) for lPixel := 1 to lSliceSz do begin lIntensity := 0; lSliceOffset := 0; //start with nearest slice while (lSliceOffset < lVolSz) do begin if (lSrc[lSliceOffset+lPixel] < lMaxInten) and (lSrc[lSliceOffset+lPixel] > lIntensity) then begin lIntensity := lSrc[lSliceOffset+lPixel]; gBGImg.RenderDepthBuffer[lPixel] := lSliceOffset div lSliceSz+1; if lShade then lPreciseDepthBuffer[lPixel] := gBGImg.RenderDepthBuffer[lPixel] * 10; end; inc(lSliceOffset,lSliceSz); end; //while no voxel found (**) lOutBuffer[lPixel]:= lIntensity; end; //for each pixel 1..sliceSz inc(gInc); //RenderForm.caption := inttostr(gettickcount-lTime)+' '+inttostr(gInc); //MIP end end else begin //not MIP for lPixel := 1 to lSliceSz do begin lDepth := 0; lSamples := 0; lIntensity := 0; lSliceOffset := 0; //start with nearest slice while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin if (lSrc[lSliceOffset+lPixel] < lMaxInten) and ((lDepth > 0) or (lSrc[lSliceOffset+lPixel] > lRenderSurface)) then begin inc(lDepth); if (lSrc[lSliceOffset+lPixel] > lRenderSurface) then begin lIntensity := lIntensity+ lSrc[lSliceOffset+lPixel]; inc(lSamples); end; if (lDepth = 1) then begin gBGImg.RenderDepthBuffer[lPixel] := lSliceOffset div lSliceSz+1; if lShade then begin if (lSliceOffset > 0) then begin //estimate surface depth with sub-pixel accuracy lNear := lSrc[lSliceOffset+lPixel-lSliceSz]; lSubPixel := lIntensity-lNear; //delta + lSubPixel := round(((lRenderSurface-lNear)/lSubPixel)*100); + if lNear >= lMaxInten then //cutout lSubPixel := 0; end else lSubpixel := 0; lPreciseDepthBuffer[lPixel] := (gBGImg.RenderDepthBuffer[lPixel] * 100)+lSubPixel; end; if (gBGImg.RenderDepthBuffer[lPixel] > 1) and (lSrc[lSliceOffset+lPixel-lSliceSz]>= lMaxInten) then begin //cutout if lSrc[lSliceOffset+lPixel-lSliceSz]=lMaxInten-1 then lIntensity := 0; lDepth := lRenderDepth; gBGImg.RenderDepthBuffer[lPixel] := -gBGImg.RenderDepthBuffer[lPixel]; //negative: this is a cutout end; end; end; inc(lSliceOffset,lSliceSz); end; //while no voxel found if lDepth > 0 then lIntensity := lIntensity div lSamples; //lIntensity := lIntensity div lDepth; //mean of nDepth voxels lOutBuffer[lPixel]:= lIntensity; //lOutBuffer[lPixel]:= lHdr.RenderDepthBuffer[lPixel]; //use this to show Z-buffer end; //for each pixel 1..sliceSz end; //NOT MIP {if true then for lPixel := 1 to lSliceSz do if gBGImg.RenderDepthBuffer[lPixel] > 0 then lOutBuffer[lPixel]:= lZ- gBGImg.RenderDepthBuffer[lPixel]; {}//use this to show Z-buffer end else begin //do not create depth buffer for lPixel := 1 to lSliceSz do begin lDepth := 0; lSamples := 0; lIntensity := 0; lSliceOffset := 0; //start with nearest slice while ((lDepth < lRenderDepth) and (lSliceOffset < lVolSz)) do begin if (lDepth > 0) or (lSrc[lSliceOffset+lPixel] > lRenderSurface) then begin inc(lDepth); if (lSrc[lSliceOffset+lPixel] > lRenderSurface) then begin lIntensity := lIntensity+ lSrc[lSliceOffset+lPixel]; inc(lSamples); end; end; inc(lSliceOffset,lSliceSz); end; if lDepth > 0 then lIntensity := lIntensity div lSamples; //lIntensity := lIntensity div lDepth; //mean of nDepth voxels lOutBuffer[lPixel]:= lIntensity; end; //for each lpixelend; //volume render without depth buffer if (NormalizeIntensity) and (lRenderSurface < 254) then begin //must be done BEFORE shading for lPixel := 0 to 255 do lLUT[lPixel] := 0; for lPixel := lRenderSurface to 255 do lLUT[lPixel] := round(255*(lPixel-lRenderSurface)/(255-lRenderSurface)); for lPixel := 1 to lSliceSz do lOutBuffer[lPixel] := lLUT[lOutBuffer[lPixel]]; end; if lShade then begin SmoothShading (lX,lY,lPreciseDepthBuffer); IlluminationShading(lX,lY,gRender.ShadePct,lOutBuffer,lPreciseDepthBuffer{gBGImg.RenderDepthBuffer} ); freemem(lPreciseDepthBuffer); end;//shading if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels Smooth2DImage (lX,lY, lOutBuffer); //lrgbLUT := lHdr.LUT; //Mar2007 + for lPixel := 0 to 255 do + lrgbLUT[lPixel] := lHdr.LUT[lPixel]; + if (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then LUTGainX(lrgbLUT,RenderForm.BiasTrack.Position,RenderForm.GainTrack.Position {RenderForm.BiasTrack.Position}); //Mar2007 for lPixel := 1 to lSliceSz do lQuadP[lPixel]:= lrgbLUT[lOutBuffer[lPixel]]; //Mar2007 //lQuadP[lPixel]:= lHdr.LUT[lOutBuffer[lPixel]]; if ( (gRender.BGNearClipFrac<>0) or (gRender.ShowCutout)) and (lCreateDepthBuffer) then begin //make cutout grayscale, shade edges if gRender.ShowCutout then ShadeCutoutCrease(lOutBuffer); LUTLoad(gRender.cutoutLUTindex,lrgblut);//11/2007 + (*for lPixel := 0 to 255 do begin + lrgbLUT[lPixel].rgbRed := lPixel; + lrgbLUT[lPixel].rgbGreen := lPixel; + lrgbLUT[lPixel].rgbBlue := lPixel; + lrgbLUT[lPixel].rgbReserved := kLUTalpha; + + end;//create grayscale LUT *) LUTBiasX(lrgbLUT,gRender.CutoutBias); for lPixel := 1 to lSliceSz do if gBGImg.RenderDepthBuffer[lPixel]<0 then //cutout lQuadP[lPixel]:= lrgbLUT[lOutBuffer[lPixel]]; end; //if BGimg with Cutout Freemem(lOutBuffer);end;function RenderDepth (lVal: integer): integer;//11/2007begin if (lVal > 0) and (lVal < 16000) and (gBGImg.ScrnMM[1] > 0.1) and (gBGImg.ScrnMM[1] < 10) then begin result:= round (lVal / gBGImg.ScrnMM[1]); if result < 1 then result := 1; end else result := lVal; result := round(result * gRender.Zoom);end;procedure DrawRender;var lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; lUseBGSurface,lnOverlay,lOverlay, lX,lY,lZ,lSliceSz,lRenderSurface,lRenderDepth: longint; lBG0Clr,lOverlay0Clr: DWord; lSmooth : boolean;begin lRenderSurface := gRender.BGSurface; lRenderDepth:= RenderDepth(gRender.BGDepth);//11/2007 lSmooth := gRender.SmoothBG; lUseBGSurface := gRender.OverlayFromBGSurface ; lX := gMRIcroOverlay[kBGOverlayNum].RenderDim; lY := lX; lZ := lX; lSliceSz := (lX * lY); if (gMRIcroOverlay[kBGOverlayNum].RenderBufferItems=0)or (lX < 2) or (lY < 2) or (lZ < 2) or ((lX*lY*lZ) > gMRIcroOverlay[kBGOverlayNum].RenderBufferItems{ScrnBufferItems}) then exit; GetMem ( lBGQuadP, lSliceSz*4); CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[kBGOverlayNum], lX,lY,lZ,lRenderSurface,lRenderDepth, lBGQuadP, lSmooth, true,true,0);//next: overlays lSmooth := gRender.SmoothOverlay; lRenderSurface := gRender.OverlaySurface; lRenderDepth:= RenderDepth(gRender.OverlayDepth);//11/2007lnOverlay := 0;lBG0Clr:= (gMRIcroOverlay[0].LUTinvisible);//just to avoid compiler warning hint - never used...for lOverlay := knMaxOverlay downto 1 do begin if gMRIcroOverlay[lOverlay].RenderBufferItems{ScrnBufferItems} > 0 then begin if lOverlay = kVOIOverlayNum then //Aug2007 lRenderSurface := 0 else lRenderSurface := gRender.OverlaySurface;// inc(lnOverlay); if lnOverlay = 1 then begin //top overlay GetMem ( lOverlayQuadP , lSliceSz*4); lBG0Clr:= (gMRIcroOverlay[lOverlay].LUTinvisible); CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay],lX,lY,lZ,lRenderSurface,lRenderDepth,lOverlayQuadP,lSmooth,false,false,lUseBGSurface); end else begin //2nd or lower overlay if lnOverlay = 2 then //2nd overlay GetMem ( l2ndOverlayQuadP , lSliceSz*4); CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay], lX,lY,lZ,lRenderSurface,lRenderDepth,l2ndOverlayQuadP,lSmooth,false,false,lUseBGSurface); lOverlay0Clr:= (gMRIcroOverlay[lOverlay].LUTinvisible); AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); end; //2nd overlay or more end; //overlay loadedend; //for knOverlay..1//Finally: draw overlays on BGif lnOverlay > 0 then begin lOverlay0Clr := lBG0Clr; //lBG0Clr := DWord(lHdr.LUTinvisible); lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); if lnOverlay > 1 then FreeMem ( l2ndOverlayQuadP); AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); FreeMem ( lOverlayQuadP);end;//draw image SetDimension32(lY,lX, lBGQuadP, gBGImg, RenderForm.RenderImage, RenderForm.RenderPanel); SetDimension32(lY,lX, lBGQuadP, gBGImg, RenderForm.RenderImageBup, RenderForm.RenderPanel); FreeMem ( lBGQuadP); if gBGImg.RenderDepthBufferItems > 0 then //negative depth was used for cutouts, now set to true depth for lX := 1 to gBGImg.RenderDepthBufferItems do gBGImg.RenderDepthBuffer[lX] := abs(gBGImg.RenderDepthBuffer[lX]);end; +procedure TRenderForm.SliceToFrac; +var + lInc: integer; +begin + SortCutOut (gRender.CutOut); + for lInc := 1 to 3 do begin + if gBGImg.ScrnDim[lInc] < 1 then begin + gRender.CutoutFrac.Lo[lInc] := round (0.5* kMaxFrac); + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end else begin + gRender.CutoutFrac.Lo[lInc] := round(kMaxFrac * gRender.Cutout.Lo[lInc]/gBGImg.ScrnDim[lInc]); + gRender.CutoutFrac.Hi[lInc] := round(kMaxFrac * gRender.Cutout.Hi[lInc]/gBGImg.ScrnDim[lInc]); + end; + end; +end; + + +procedure SetLimits(var lBGImg: TBGImg); +var lInc: integer; +lUpdateCutout: boolean; +lScale: single; +begin + SortCutOut (gRender.CutOutFrac); + if gRender.CutoutFrac.Lo[1] < 0 then + RenderForm.SliceToFrac; + lScale := 1/kMaxFrac; + for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := round(gBGImg.ScrnDim[lInc] * lScale * gRender.CutoutFrac.Lo[lInc]); + gRender.Cutout.Hi[lInc] := round(gBGImg.ScrnDim[lInc] * lScale * gRender.CutoutFrac.Hi[lInc]); + end; + //renderform.caption := inttostr(gRender.Cutout.Lo[1])+' '+inttostr(gRender.Cutout.Hi[1])+' '+inttostr(random(888)); + SortCutout (gRender.Cutout); //ensure Lo < Hi + lUpdateCutout := true; + for lInc := 1 to 3 do + if gRender.Cutout.Lo[lInc] <> gRender.Cutout.Hi[lInc] then lUpdateCutout := false; + if lUpdateCutout then + for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := gBGImg.ScrnDim[lInc] div 2; + gRender.Cutout.Hi[lInc] := gBGImg.ScrnDim[lInc]; + end; + for lInc := 1 to 3 do begin + if gRender.Cutout.Lo[lInc] < 1 then gRender.Cutout.Lo[lInc] := 1; + if gRender.Cutout.Lo[lInc] > lBGImg.ScrnDim[lInc] then gRender.Cutout.Lo[lInc] := lBGImg.ScrnDim[lInc]; + if gRender.Cutout.Hi[lInc] < 1 then gRender.Cutout.Hi[lInc] := 1; + if gRender.Cutout.Hi[lInc] > lBGImg.ScrnDim[lInc] then gRender.Cutout.Hi[lInc] := lBGImg.ScrnDim[lInc]; + end; +end; + +{function ClipFracSlices (var lClipFrac,lClip: integer): integer; +var + lMax : integer; +begin + lMax := gBGImg.RenderDim; + RenderForm.Caption := inttostr(lClipFrac)+' '+inttostr(lClip); + if (lClipFrac < 0) and (lClip > 0) then + lClipFrac := round(lClip/lMax*kMaxFrac); + if lClipFrac < 1 then + lClipFrac := 0; + if lClipFrac > kMaxFrac then + lClipFrac := kMaxFrac div 2; + + lClip := round(lClipFrac/kMaxFrac*lMax* gRender.Zoom); + +end;} +function ClipFracSlices(lClipFrac,lMax: integer): integer; +begin + if (lClipFrac <= 0) then + result := 0 + else if (lClipFrac >= kMaxFrac) then + result := lMax div 2 + else + result := round(lClipFrac/kMaxFrac*lMax); +end; + + + +procedure TRenderForm.VolumeRotateMatrix (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean;lNearSlicesClipInFrac: integer); +label 345; +const + //lZoom = true; + kUgly2 = 10000; + // kSh = 10; //bits to shift + kUgly1 = (kUgly2 shl kSh) + (1 shl kSh); +var + l: TRotateVals; + lNearSlicesClip,lZinc,lZ,lY,lX,lOutVolSz, + lOutPos,lInVolSz, + lYo,lZo,lnThreads: integer; + lBuffIn,lSrcBuff,lBuffOut: Bytep; + lXxp,lXyp,lXzp: Pointer; + lScale ,lMatrix: TMatrix; + lZoomRatio : single; + begin + lMatrix := lMatrixIn; + //gRender.Zoom := gZoom; + //gZoom := 1; + if (gRender.Zoom <> 0) and (gRender.Zoom <> 1 )then begin + lZoomRatio := 1/gRender.Zoom; + lScale := Matrix3D(lZoomRatio,0,0,0, 0,lZoomRatio,0,0, 0,0,lZoomRatio,0, 0,0,0,0); + lMatrix := MultiplyMatrices(lMatrixIn,lScale); + end else + gRender.Zoom := 1; + + + //lScale := Matrix3D(0,1,0,0, 0,0,1,0, 1,0,0,0, 0,0,0,0); + // lMatrix := MultiplyMatrices(lMatrixIn,lScale); + + l.XdimIn := lBGImg.ScrnDim[1]; + l.YdimIn := lBGImg.ScrnDim[2]; + l.ZdimIn := lBGImg.ScrnDim[3]; + l.InSliceSz := l.XDimIn*l.YDimIn; + lInVolSz := l.XdimIn*l.YdimIn*l.ZdimIn; //InVolSz! + if (lHdr.ScrnBufferItems < lInVolSz) then + exit; + lSrcBuff := lHdr.ScrnBuffer; + l.OutDim := MaxDim(l.XDimIn,l.YDimIn,l.ZDimIn); + //if gRender.Zoom then + //gRender.UnscaledRenderDim := l.OutDim; + l.OutDim := round(gRender.Zoom * l.OutDim); //11/2007 + lNearSlicesClip := ClipFracSlices(lNearSlicesClipInFrac,l.OutDim);//May07 + if lNearSlicesClip >= l.OutDim then //May07 + lNearSlicesClip := 0; //May07 + lBGImg.RenderDim := l.OutDim; + lHdr.RenderDim := l.OutDim; + if (lNearSlicesClip> 0) or (lRenderCutout) then begin + SetLimits(lBGImg); + GetMem(lBuffIn, lInVolSz); + Move(lSrcBuff^,lBuffIn^,lInVolSz); + for lZ := 1 to lInVolSz do + if lBuffIn[lZ] >= 254 then lBuffIn[lZ] := 253; + if lRenderCutout then begin + + for lZ := gRender.Cutout.Lo[3] to gRender.Cutout.Hi[3] do begin + lZo := (lZ-1) * l.InSliceSz; + Application.ProcessMessages; + for lY := gRender.Cutout.Lo[2] to gRender.Cutout.Hi[2] do begin + lYo := (lY-1) * l.XdimIn; + for lX := gRender.Cutout.Lo[1] to gRender.Cutout.Hi[1] do + lBuffIn[lX+lYo+lZo] := 255; + end; //for lY + end; //for lZ + end; + end else + lBuffIn := lSrcBuff; + l.OutPivot := (lHdr.RenderDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + l.XPivotIn := ((l.XdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.YPivotIn := ((l.YdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.ZPivotIn := ((l.ZdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.YDimStart := -l.OutPivot+1; //e.g. if 9, start from -4 + l.ZDimStart := l.YDimStart + lNearSlicesClip; + + l.YDimEnd := l.YDimStart+lHdr.RenderDim-1; //e.g. if 9, go to 4 + l.ZDimEnd := l.YDimEnd; + if l.ZDimStart >= l.ZDimEnd then + l.ZDImStart := l.ZDimStart; + l.OutSliceSz := sqr(lHdr.RenderDim); + lOutVolSz := lHdr.RenderDim*l.OutSliceSz; + if lHdr.RenderBufferItems <> lOutVolSz then begin + if lHdr.RenderBufferItems > 0 then + Freemem(lHdr.RenderBuffer); + lHdr.RenderBufferItems := lOutVolSz; + GetMem(lHdr.RenderBuffer,lOutVolSz); + end; + lBuffOut := lHdr.RenderBuffer; + fillchar(lBuffOut^,lOutVolSz,0); //set all to zero + //next shade clipping + if (lIsBG) and (lNearSlicesClip > 1) then begin + lOutPos := (lNearSlicesClip-1)*l.OutDim*l.OutDim; + for lY := 1 to l.OutDim do + for lX := 1 to l.OutDim do + lBuffOut[((lY-1)*l.OutDim)+lX+lOutPos] := 255; + end; + //lMatrix := InvertMatrix3D(lMatrix); + lZ := (sizeof(longint)* l.OutDim)+16; + GetMem(lXxp, lZ); + GetMem(lXyp, lZ); + GetMem(lXzp, lZ); +// if RenderForm.RenderRefreshTimer.enabled then goto 345;//abort + l.XxRA := LongIntP($fffffff0 and (integer(lXxP)+15)); //data aligned to quad-word boundary + l.XyRA := LongIntP($fffffff0 and (integer(lXyP)+15)); //quad-word boundary + l.XzRA := LongIntP($fffffff0 and (integer(lXzP)+15)); //quad-word boundary + for lX := 1 to l.OutDim do begin + l.XxRA[lX] := round((lX-l.OutPivot)*lMatrix.matrix[1,1]* (1 shl kSh) )+kUgly1; + l.XyRA[lX] := round((lX-l.OutPivot)*lMatrix.matrix[2,1]* (1 shl kSh) )+kUgly1; + l.XzRA[lX] := round((lX-l.OutPivot)*lMatrix.matrix[3,1]* (1 shl kSh) )+kUgly1; + end; + l.XPivotInU2 := l.XPivotIn-kUgly2; + l.YPivotInU2 := l.YPivotIn-kUgly2; + l.ZPivotInU2 := l.ZPivotIn-kUgly2; + + lnThreads := gnCPUThreads; + //if lIsBG then + //TextForm.Memo1.Lines.Add( 'bg'+(inttostr(RenderForm.ThreadsRunning)+' '+inttostr(lnThreads))) + + //else + //TextForm.Memo1.Lines.Add( 'xx'+(inttostr(RenderForm.ThreadsRunning)+' '+inttostr(lnThreads))); + lZ := l.ZDimStart; + lZo := l.ZDimEnd; + lZinc := (l.ZDimEnd - l.ZDimStart) div lnThreads; + l.ZDimEnd := l.ZDimStart + lZinc; + //showmessage( inttostr(l.ZDimStart)+'..'+inttostr(l.ZDimEnd) +' '+inttostr(lZo)); + if l.ZDimEnd > ImgForm.ProgressBar1.Min then begin //crashes if max < min, so write order important... + ImgForm.ProgressBar1.Max := l.ZDimEnd+1; + ImgForm.ProgressBar1.Min := l.ZDimStart; + end else begin + ImgForm.ProgressBar1.Min := l.ZDimStart; + ImgForm.ProgressBar1.Max := l.ZDimEnd+1; + + end; + //l.ZDimEnd; + Application.processmessages; + + for lX := 1 to lnThreads do begin + if lX = lnThreads then + l.ZDimEnd := lZo; //avoid integer rounding error + //TextForm.Memo1.Lines.Add('+'+inttostr(lX)); + if (lBilinearSmooth) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + with TTriRender.Create(ImgForm.ProgressBar1,lX,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut) do + OnTerminate := ThreadDone + else + with TNNRender.Create(ImgForm.ProgressBar1,lX,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut) do + OnTerminate := ThreadDone; + inc(ThreadsRunning); + l.ZDimStart := l.ZDimEnd + 1; + l.ZDimEnd := l.ZDimEnd + lZInc; + + end; //for each thread + l.ZDimStart := lZ; + + repeat + Application.processmessages; + until ThreadsRunning = 0; + Application.processmessages; + + Refresh; +//345: + FreeMem(lXxp); + FreeMem(lXyp); + FreeMem(lXzp); + if (lRenderCutout) or (lNearSlicesClip> 0) then begin + FreeMem(lBuffIn); + //for lZ := 1 to lInVolSz do + // if lBuffOut[lZ] = 255 then lBuffOut[lZ] := 0; + end; + ImgForm.ProgressBar1.Position := l.ZDimStart; +end; //proceudre VolumeRotate;(**) + + +procedure TRenderForm.Save1Click(Sender: TObject); +begin + //if (RenderImage.Picture.Graphic = nil) then begin + SaveImgAsPNGBMP (RenderImage); +end; + +procedure TRenderForm.RenderImageMouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin + if ImgForm.MagnifyImage.Width > 10 then + ImgForm.MagnifyTimer.Enabled := true;//MagnifyBtn.Down; +end; + +procedure TRenderForm.Copy1Click(Sender: TObject); +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (RenderImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + RenderImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); +end; + +procedure TRenderForm.Close1Click(Sender: TObject); +begin + RenderForm.Close; +end; + +procedure TRenderForm.N1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N01Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlaySurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N1voxel1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N16voxels2Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderSmoothClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gRender.FlipLR := FlipLRCheck.Checked; + //RenderSmoothSurface.checked := not RenderSmoothSurface.Checked; + gRender.SmoothBG := RenderSmoothBG.checked; + gRender.SmoothOverlay := RenderSmoothOverlay.checked; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderPreciseInterpolationClick(Sender: TObject); +begin + RenderPreciseInterpolation.Checked := not RenderPreciseInterpolation.Checked; + gRender.Trilinear := RenderPreciseInterpolation.Checked; + RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.FormShow(Sender: TObject); +var + lInc: integer; +begin + gRender.cutoutLUTindex := 0; + gRender.BGSurface := 51; + gRender.OverlaySurface := 1; + gRender.BGDepth := 12; + gRender.OverlayDepth := 8; + gRender.Azimuth := 90; + gRender.Elevation := 45; + gRender.ShadePct := 0; + gRender.OverlayNearClip := 0; + gRender.BGNearClip := 0; + gRender.OverlayNearClipFrac := -1; + gRender.BGNearClipFrac := -1; + gRender.SmoothBG := true; + gRender.SmoothOverlay := false; + gRender.Trilinear := true; + gRender.FlipLR := false; + gRender.OverlayFromBGSurface := kBelow; + gRender.ShowCutout := false;//10/10/2006 + gRender.CutoutBias := 4; + for lInc := 1 to 3 do begin + gRender.CutoutFrac.Lo[lInc] := kMaxFrac div 2; + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end; + ReadRenderIniFile (gRenderStartupFilename); + UpdateRenderMRU; + UpdateRenderDisplay; +end; + +procedure ClipFracCheck (var lFrac,lSlice: integer); +//provide backward compatibility for files that explicitly report slices not fraction +var + lMax: integer; +begin + if lFrac >= 0 then + exit; + lFrac := 0; + lMax := MaxDim(gBGImg.ScrnDim[1],gBGImg.ScrnDim[2],gBGImg.ScrnDim[3]); + if (lSlice <= 0) or (lSlice > lMax) then + exit; + lFrac := round(lSlice/lMax*kMaxFrac); + +end; + +procedure TRenderForm.RefreshRotation; +var + lC: integer; + lMatrix: TMatrix; + lStartTime: DWord; +begin + lMatrix := AziElevMatrix; Application.processmessages; gRender.Zoom := gZoom; //11/2007b gZoom := 1; lStartTime := GetTickCount; ClipFracCheck (gRender.BGNearClipFrac,gRender.BGNearClip); ClipFracCheck (gRender.OverlayNearClipFrac,gRender.OverlayNearClip); VolumeRotateMatrix (gBGImg, gMRIcroOverlay[0],lMatrix, gRender.Trilinear,gRender.ShowCutout,true,gRender.BGNearClipFrac); if RenderRefreshTimer.Enabled then exit; Refresh; for lC := 1 to knMaxOverlay do begin VolumeRotateMatrix (gBGImg, gMRIcroOverlay[lC],lMatrix, gRender.Trilinear,false,false,gRender.OverlayNearClipFrac); if RenderRefreshTimer.Enabled then exit; end; ImgForm.StatusLabel.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime));end; +procedure TRenderForm.RenderRefreshTimerTimer(Sender: TObject); +begin + RenderRefreshTimer.Enabled := false; + if gMRIcroOverlay[0].ScrnBufferItems=0 then begin + RenderImage.Width := 0; exit; end; + gRender.ShadePct := ShadeEdit.asInteger; + if (gMRIcroOverlay[0].RenderBufferItems=0) or (RenderRefreshTimer.Tag <> 0) or (AzimuthEdit.value<>gRender.Azimuth) or (ElevationEdit.value<>gRender.Elevation) then + RefreshRotation; + if RenderRefreshTimer.Enabled then exit; + //gZoom := 1; + RenderRefreshTimer.Tag := 0; + DrawRender; +end; + +procedure TRenderForm.EditChange(Sender: TObject); +begin + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.OverlayRenderDepthItem(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure RenderDrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +var lL,lT,lW,lH,lZoomPct: integer; +begin + lImage.Picture.Graphic := RenderForm.RenderImageBup.Picture.Graphic; + lZoomPct := 100; //ImageZoomPct(lImage); + lL := (lHorPos * lZoomPct) div 100; + lT := (lVerPos * lZoomPct) div 100; + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + //next horizontal lines + lImage.Canvas.MoveTo(0,lT); + lImage.Canvas.LineTo(lL-gBGImg.XBarGap,lT); + lImage.Canvas.MoveTo(lL+gBGImg.XBarGap,lT); + lImage.Canvas.LineTo(lW,lT); + //next vertical lines + lImage.Canvas.MoveTo(lL,0); + lImage.Canvas.LineTo(lL,lT-gBGImg.XBarGap); + lImage.Canvas.MoveTo(lL,lT+gBGImg.XBarGap); + lImage.Canvas.LineTo(lL,lH); +end; //Proc RenderDrawXBar + +procedure TRenderForm.RenderImageMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var lXrender,lYrender,lZrender,lXout,lYout,lZOut,lPixelOffset,lZoom: integer; +lMatrix: TMatrix; +begin + if ImgForm.XBarBtn.Down then + RenderDrawXBar ( X,Y,RenderImage); + //Next: find coordinates for orthogonal views: + lZoom := ImageZoomPct(RenderImage); + lXrender := round((X*100) / lZoom ); + lYrender := round(((Y)*100) / lZoom ); + + lPixelOffset := lXrender+ ((gBGImg.RenderDim-lYrender)*gBGImg.RenderDim); + //ImgForm.StatusLabel.caption := inttostr(lXrender)+'x'+inttostr(lYrender)+' -> '+inttostr(gMRIcroOverlay[kBGOverlayNum].RenderDepthBufferItems ); + if (lPixelOffset < 1) or (lPixelOffset >gBGImg.RenderDepthBufferItems ) then exit; + lZrender := gBGImg.RenderDepthBuffer[lPixelOffset]; + lXrender := round(lXrender / gRender.Zoom); + lYrender := round(lYrender / gRender.Zoom); + lZrender := round(lZrender / gRender.Zoom); + //caption := inttostr(lXrender)+'x'+inttostr(lYrender)+'x'+inttostr(LZrender)+' '+inttostr(gBGImg.RenderDepthBuffer[lPixelOffset]); + lMatrix := AziElevMatrix; + InvertMatrixPoint (gBGImg,lMatrix,lXrender,lYrender,lZrender, lXout,lYout,lZOut); + ImgForm.XViewEdit.value := lXOut; + ImgForm.YViewEdit.asInteger := lYOut; + ImgForm.ZViewEdit.asInteger := lZOut; +end; + +procedure TRenderForm.Cutout1Click(Sender: TObject); +begin + CutoutForm.Show; +end; + +procedure TRenderForm.Savesettings1Click(Sender: TObject); +begin + MultiSliceForm.MultiSaveDialog.InitialDir := extractfiledir(gRenderDir); + MultiSliceForm.MultiSaveDialog.FileName := 'a'+inttostr(gRender.Azimuth)+'e'+inttostr(gRender.Elevation); + if not MultiSliceForm.MultiSaveDialog.Execute then exit; + WriteRenderIniFile(MultiSliceForm.MultiSaveDialog.Filename); + UpdateRenderMRU; +end; + +procedure TRenderForm.FormHide(Sender: TObject); +begin + WriteRenderIniFile (gRenderDefaultsFilename); +end; + +procedure TRenderForm.FormCreate(Sender: TObject); +begin +ThreadsRunning := 0; + gRenderDir := extractfiledir(paramstr(0))+'\render\'; + gRenderDefaultsFilename := gRenderDir + 'default.ini'; + gRenderStartupFilename := gRenderDefaultsFilename; +end; + +procedure TRenderForm.CapBtnMenu1Click(Sender: TObject); +begin + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end; + +procedure TRenderForm.SetSearch(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayFromBGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.Saveas36bitmaps1Click(Sender: TObject); +var + lnViews,lC,lAngle,lStartA: integer; + lAzi,lZoom: boolean; + lBaseFilename,lFilename: string; +begin + lnViews:= ReadIntForm.GetInt('How many bitmaps for a 360-degree rotation?', 4,24,72); + + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + lBaseFilename := ImgForm.SaveDialog1.Filename; + lAzi := false; + lZoom := false;//11/2007b + case MessageDlg('Rotate azimuth?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lAzi := true; + end; //case + case MessageDlg('Generate super-sampled (high quality) renderings?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lZoom := true; + end; //case + + if lAzi then + lStartA := AzimuthEdit.asInteger + else + lStartA := ElevationEdit.asInteger; + for lC := 1 to lnViews do begin + lAngle := round((lC-1) * (360/lnviews)); + if lAzi then + AzimuthEdit.value := lAngle + else + ElevationEdit.value := lAngle - 180; + RenderRefreshTimer.enabled := false; + if lZoom then + gZoom := 2; + RefreshRotation; + DrawRender; + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lAngle,3),'.png'); + SaveImgAsPNGBMPCore(RenderImage,lFilename); + end; //for each of 36 views + if lAzi then + AzimuthEdit.value := lStartA + else + ElevationEdit.value := lStartA; +end; + +procedure TRenderForm.BiasTrackChange(Sender: TObject); +begin + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.QualityBtnClick(Sender: TObject); +begin + gZoom := 2; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; + +end; + +procedure TRenderForm.Generateoversampledrenderingslow1Click( + Sender: TObject); +begin + gZoom := 2; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +initialization + InitializeCriticalSection(CritSect); + + +finalization + DeleteCriticalSection(CritSect); +end. diff --git a/niftiview7/yrender.pas b/niftiview7/yrender.pas new file mode 100755 index 0000000..f4b7cd4 --- /dev/null +++ b/niftiview7/yrender.pas @@ -0,0 +1,732 @@ +unit yrender; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, Buttons,nifti_img, nifti_hdr,define_types,nifti_img_view, + StdCtrls, GraphicsMathLibrary, Menus,ClipBrd,ReadInt,cutout,IniFiles,FileCtrl, + RenderThds, ComCtrls, RXSpin,render_composite; + +type + (*TRender = record + CutoutFrac,Cutout: TCutout; + Zoom: single; + cutoutLUTindex, ShadePct,BGNearClipFrac,OverlayNearClipFrac,BGNearClip,OverlayNearClip,Azimuth,Elevation, + OverlayFromBGSurface,BGSurface,OverlaySurface,BGDepth,OverlayDepth,CutoutBias: integer; + SmoothBG,SmoothOverlay,Trilinear,ShowCutout,FlipLR: boolean; + end;*) + + TRenderForm = class(TForm) + RenderBar: TPanel; + MainMenu1: TMainMenu; + FileMenu: TMenuItem; + Close1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Save1: TMenuItem; + Label4: TLabel; + Volume1: TMenuItem; + RenderBGSurfaceMenu: TMenuItem; + N1: TMenuItem; + N101: TMenuItem; + N401: TMenuItem; + N601: TMenuItem; + N801: TMenuItem; + N403: TMenuItem; + N404: TMenuItem; + N405: TMenuItem; + RenderBGDepthMenu: TMenuItem; + N1voxel1: TMenuItem; + N2voxels1: TMenuItem; + N4voxels1: TMenuItem; + N8voxels1: TMenuItem; + N16voxels1: TMenuItem; + N16voxels: TMenuItem; + RenderSmoothBG: TMenuItem; + RenderPreciseInterpolation: TMenuItem; + Label1: TLabel; + Overlay1: TMenuItem; + RenderOverlaySurfaceMenu: TMenuItem; + N701: TMenuItem; + N602: TMenuItem; + N501: TMenuItem; + N402: TMenuItem; + N301: TMenuItem; + N201: TMenuItem; + N102: TMenuItem; + N01: TMenuItem; + RenderOverlayDepthMenu: TMenuItem; + N16voxels2: TMenuItem; + N12voxels1: TMenuItem; + N8voxels2: TMenuItem; + N4voxels2: TMenuItem; + N2voxels2: TMenuItem; + N1voxel2: TMenuItem; + Quality1: TMenuItem; + RenderRefreshTimer: TTimer; + RenderPanel: TScrollBox; + RenderImage: TImage; + RenderImageBup: TImage; + Cutout1: TMenuItem; + RenderSmoothOverlay: TMenuItem; + FlipLRcheck: TMenuItem; + Settings1: TMenuItem; + Savesettings1: TMenuItem; + N2: TMenuItem; + Infinite1: TMenuItem; + Infinite2: TMenuItem; + Search1: TMenuItem; + BehindBG1: TMenuItem; + Infront1: TMenuItem; + Anydepth1: TMenuItem; + MIP1: TMenuItem; + Saveas36bitmaps1: TMenuItem; + BiasTrack: TTrackBar; + GainTrack: TTrackBar; + AzimuthEdit: TRxSpinEdit; + ElevationEdit: TRxSpinEdit; + QualityBtn: TSpeedButton; + ShadeEdit: TRxSpinEdit; + Label2: TLabel; + N3: TMenuItem; + procedure Save1Click(Sender: TObject); + procedure RenderImageMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure Copy1Click(Sender: TObject); + procedure Close1Click(Sender: TObject); + procedure N1Click(Sender: TObject); + procedure N01Click(Sender: TObject); + procedure N1voxel1Click(Sender: TObject); + procedure N16voxels2Click(Sender: TObject); + procedure RenderSmoothClick(Sender: TObject); + procedure RenderPreciseInterpolationClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure RenderRefreshTimerTimer(Sender: TObject); + procedure EditChange(Sender: TObject); + procedure OverlayRenderDepthItem(Sender: TObject); + procedure RenderImageMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Cutout1Click(Sender: TObject); + procedure Savesettings1Click(Sender: TObject); + procedure UpdateRenderMRU; + procedure OpenRenderMRU(Sender:TObject); + procedure UpdateRenderDisplay; + procedure FormHide(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure CapBtnMenu1Click(Sender: TObject); + procedure SetSearch(Sender: TObject); +procedure RefreshRotation; + //procedure VolumeRotateMatrixX (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean;lNearSlicesClipInFrac: integer); + procedure Saveas36bitmaps1Click(Sender: TObject); + procedure BiasTrackChange(Sender: TObject); + procedure QualityBtnClick(Sender: TObject); + procedure Generateoversampledrenderingslow1Click(Sender: TObject); + + private + + // ThreadsRunning: Integer; + //procedure ThreadDone(Sender: TObject); + { Private declarations } + public + //procedure SliceToFrac; { Public declarations } + end; +var + RenderForm: TRenderForm; + + gRenderDir,gRenderStartupFilename,gRenderDefaultsFilename:string; + (*CritSect : TRTLCriticalSection; + gRender:TRender; + gZoom : single = 1;*) +implementation + +uses MultiSlice,Math {power}; +const + //kAnywhere = 0; + kBelow = 1; + kInFront = 2; + gInc: integer = 0; + +{x$R *.DFM} + +procedure LUTbiasX (var lOutLUT : TLUT; lBiasIn: integer {0..9}); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick Graphics Gems IV, p379-382, April 1994 } +var + lIndex: integer; + lA,lT,lBias: single; + lLUT: TLUT; +begin + if lBiasIn = 4 then exit; + lA := (lBiasIn+1)/10; + if lA = 0 then + lA := 0.000001; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[round(lBias)]; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + +procedure LUTgainX (var lOutLUT : TLUT; lBiasIn,lGainIn: integer {0..99}); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick Graphics Gems IV, p379-382, April 1994 } +var + lIndex,lV: integer; + lA,lG,lT,lGain: single; + lLUT: TLUT; +begin + if (lGainIn = 50) and (lBiasIn = 50) then exit; + lA := (lBiasIn)/100; + if lA = 0 then + lA := 0.000001; + lG := (lGainIn)/100; + if lG = 0 then + lG := 0.00001; + if lG = 1 then + lG := 0.99999; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //apply bias + lT := (lt/((1/la-2)*(1-lt)+1)) ; + //next apply gain + if lT < 0.5 then + lGain := (lT/((1/lG-2)*(1-2*lT)+1)) + else + lGain := (( (1/lG-2)*(1-2*lT)-lT ) / ( (1/lG-2)*(1-2*lT)-1 ) ); + lGain := lGain / lT; + lV := round(255*lT*lGain); + if lV > 255 then + lV := 255; + if lV < 0 then + lV := 0; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[lV]; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + + +(*procedure TRenderForm.ThreadDone(Sender: TObject); +begin + EnterCriticalSection(CritSect); +Dec(ThreadsRunning); + LeaveCriticalSection(CritSect); +end; *) + +procedure TRenderForm.UpdateRenderDisplay; +begin + SetSubmenuWithTag(RenderBGSurfaceMenu,gRender.BGSurface); + SetSubmenuWithTag(RenderOverlaySurfaceMenu,gRender.OverlaySurface); + SetSubmenuWithTag(RenderBGDepthMenu,gRender.BGDepth); + SetSubmenuWithTag(RenderOverlayDepthMenu,gRender.OverlayDepth); + RenderSmoothBG.checked := gRender.SmoothBG; + RenderSmoothOverlay.checked := gRender.SmoothOverlay; + RenderPreciseInterpolation.Checked := gRender.Trilinear; + //RenderSurfaceOverlay.Checked := gRender.OverlayFromBGSurface; + SetSubmenuWithTag(Search1,gRender.OverlayFromBGSurface); + FlipLRCheck.Checked := gRender.FlipLR; + AzimuthEdit.value := gRender.Azimuth; + ElevationEdit.value := gRender.Elevation; + ShadeEdit.value := gRender.ShadePct; + RenderRefreshTimer.tag := -1; + RenderRefreshTimer.enabled := true; +end; + +procedure WriteRenderIniFile (lFilename: string); +var + lIniFile: TIniFile; + lInc: integer; +begin + if DiskFreeEx(lFilename) < 1 then + exit; + if not DirectoryExists(extractfiledir(lFilename)) then begin + mkDir(extractfiledir(lFilename)); + end; + lIniFile := TIniFile.Create(lFilename); + with gRender do begin + //Booleans + //SmoothBG,SmoothOverlay,Trilinear,OverlayFromBGSurface,ShowCutout + + lIniFile.WriteString('BOOL', 'SmoothBG',Bool2Char( SmoothBG)); + lIniFile.WriteString('BOOL', 'SmoothOverlay',Bool2Char( SmoothOverlay)); + lIniFile.WriteString('BOOL', 'Trilinear',Bool2Char( Trilinear)); + lIniFile.WriteString('BOOL', 'ShowCutout',Bool2Char( ShowCutout)); + lIniFile.WriteString('BOOL', 'FlipLR',Bool2Char( FlipLR)); + //Integers + //BGNearClip,OverlayNearClip,Azimuth,Elevation, + //BGSurface,OverlaySurface,BGDepth,OverlayDepth: integer; + lIniFile.WriteString('INT', 'OverlayFromBGSurface',IntToStr( OverlayFromBGSurface)); + lIniFile.WriteString('INT', 'BGNearClipFrac',IntToStr(BGNearClipFrac)); + lIniFile.WriteString('INT', 'OverlayNearClipFrac',IntToStr(OverlayNearClipFrac)); + lIniFile.WriteString('INT', 'Azimuth',IntToStr(Azimuth)); + lIniFile.WriteString('INT', 'Elevation',IntToStr(Elevation)); + lIniFile.WriteString('INT', 'BGSurface',IntToStr(BGSurface)); + lIniFile.WriteString('INT', 'OverlaySurface',IntToStr(OverlaySurface)); + lIniFile.WriteString('INT', 'BGDepth',IntToStr(BGDepth)); + lIniFile.WriteString('INT', 'OverlayDepth',IntToStr(OverlayDepth)); + lIniFile.WriteString('INT', 'CutoutBias',IntToStr(CutoutBias)); + lIniFile.WriteString('INT', 'ShadePct',IntToStr(ShadePct)); + lIniFile.WriteString('INT', 'cutoutLUTindex',IntToStr(cutoutLUTindex)); + for lInc := 1 to 3 do begin + lIniFile.WriteString('INT', 'CutoutLoFrac'+inttostr(lInc),IntToStr(CutoutFrac.Lo[lInc])); + lIniFile.WriteString('INT', 'CutoutHiFrac'+inttostr(lInc),IntToStr(CutoutFrac.Hi[lInc])); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure ReadRenderIniFile (lFilename: string); +var + lStr: string; + lIniFile: TIniFile; + lInc: integer; +begin + if not FileexistsEx(lFilename) then begin + exit; + end; + lIniFile := TIniFile.Create(lFilename); + lStr := lIniFile.ReadString('STR', 'Slices', '10,20,30');//file0 - last file viewed + with gRender do begin + //Booleans + //SmoothBG,SmoothOverlay,Trilinear,OverlayFromBGSurface,ShowCutout + SmoothBG := IniBool(lIniFile,'SmoothBG',SmoothBG); + SmoothOverlay := IniBool(lIniFile,'SmoothOverlay',SmoothOverlay); + Trilinear := IniBool(lIniFile,'Trilinear',Trilinear); + //OverlayFromBGSurface := IniBool(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + ShowCutout := IniBool(lIniFile,'ShowCutout',ShowCutout); + FlipLR := IniBool(lIniFile,'FlipLR',FlipLR); + //lIniFile.WriteString('BOOL', 'FlipLR',Bool2Char( FlipLR)); + //Integers + //BGNearClip,OverlayNearClip,Azimuth,Elevation, + //BGSurface,OverlaySurface,BGDepth,OverlayDepth: integer; + OverlayFromBGSurface:= IniInt(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + BGNearClip:= IniInt(lIniFile,'BGNearClip',0); + OverlayNearClip:= IniInt(lIniFile,'OverlayNearClip',0); + BGNearClipFrac:= IniInt(lIniFile,'BGNearClipFrac',-1); + OverlayNearClipFrac:= IniInt(lIniFile,'OverlayNearClipFrac',-1); + Azimuth:= IniInt(lIniFile,'Azimuth',Azimuth); + Elevation:= IniInt(lIniFile,'Elevation',Elevation); + BGSurface:= IniInt(lIniFile,'BGSurface',BGSurface); + OverlaySurface:= IniInt(lIniFile,'OverlaySurface',OverlaySurface); + BGDepth:= IniInt(lIniFile,'BGDepth',BGDepth); + if BGDepth > 32000 then + BGDepth := 32000; + OverlayDepth:= IniInt(lIniFile,'OverlayDepth',OverlayDepth); + if OverlayDepth > 32000 then + OverlayDepth := 32000; + CutoutBias:= IniInt(lIniFile,'CutoutBias', CutoutBias); + ShadePct:= IniInt(lIniFile,'ShadePct', 0); + cutoutLUTindex:= IniInt(lIniFile,'cutoutLUTindex',cutoutLUTindex); + for lInc := 1 to 3 do begin + Cutout.Lo[lInc] := IniInt(lIniFile,'CutoutLo'+inttostr(lInc),Cutout.Lo[lInc]); + Cutout.Hi[lInc] := IniInt(lIniFile,'CutoutHi'+inttostr(lInc),Cutout.Hi[lInc]); + end; + + for lInc := 1 to 3 do begin + CutoutFrac.Lo[lInc] := IniInt(lIniFile,'CutoutLoFrac'+inttostr(lInc),-1); + CutoutFrac.Hi[lInc] := IniInt(lIniFile,'CutoutHiFrac'+inttostr(lInc),-1); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure TRenderForm.OpenRenderMRU(Sender:TObject); +var + lFilename: string; +begin + lFilename := gRenderDir+(Sender as TMenuItem).caption+'.ini' ; + ReadRenderIniFile(lFilename); + CutoutForm.Prep; + UpdateRenderDisplay; +end; + +procedure TRenderForm.UpdateRenderMRU; +var + NewItem: TMenuItem; + lSearchRec: TSearchRec; +begin + While Settings1.Count > 0 do Settings1.Items[0].Free; + if FindFirst(gRenderDir+'*.ini', faAnyFile, lSearchRec) = 0 then + repeat + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ParseFileName(ExtractFileName(lSearchRec.Name)); + NewItem.Onclick := OpenRenderMRU; + Settings1.Add(NewItem); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end; + +Function AziElevMatrix: TMatrix;var lLRFlipMatrix: TMatrix;begin + gRender.Azimuth := RenderForm.AzimuthEdit.asInteger; + gRender.Elevation := RenderForm.ElevationEdit.asInteger; + result := ViewTransformMatrix( + coordSpherical, + ToRadians(RenderForm.AzimuthEdit.Value), + ToRadians(RenderForm.ElevationEdit.Value), + 3{Distance.Value},6{ScreenWidthHeight.Value},6{ScreenWidthHeight.Value},{ScreenToCamera.Value}3); + {The ViewTransformMatrix is all that is needed for other objects defined in world coordinates.} + if gRender.FlipLR then begin + // Mx(result); + lLRFlipMatrix := Matrix3D (-1,0,0,0, // 3D "graphics" matrix + 0,1,0,0, + 0,0,1,0, + 0,0,0,1); + + result := MultiplyMatrices(lLRFlipMatrix,Result); + end; +end; +procedure InvertMatrixPoint (var lBackgroundImg: TBGImg; var lInMatrix: TMatrix; var lXin,lYin,lZIn, lXout,lYout,lZout: integer);//convert mouse click to position +var + lZ,lY,lX,lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn: integer; + lMatrix: TMatrix; +begin + //lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutDim := round(gBGImg.RenderDim/gRender.Zoom) + else + lOutDim :=gBGImg.RenderDim; //11/2007b + lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (lBackgroundImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (lBackgroundImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (lBackgroundImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lX := (lXin-lOutPivot); + lY := ({lYin-}lOutPivot-lYin); + lZ := (lZin-lOutPivot); + lMatrix := InvertMatrix3D(lInMatrix); + lXout := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYout := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZout := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXOut := (lXOut+lXPivotIn); + lYOut := (lYOut+lYPivotIn); + lZOut := (lZOut+lZPivotIn); +end; +procedure TRenderForm.Save1Click(Sender: TObject); +begin + //if (RenderImage.Picture.Graphic = nil) then begin + SaveImgAsPNGBMP (RenderImage); +end; + +procedure TRenderForm.RenderImageMouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin + if ImgForm.MagnifyImage.Width > 10 then + ImgForm.MagnifyTimer.Enabled := true;//MagnifyBtn.Down; +end; + +procedure TRenderForm.Copy1Click(Sender: TObject); +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (RenderImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + RenderImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); +end; + +procedure TRenderForm.Close1Click(Sender: TObject); +begin + RenderForm.Close; +end; + +procedure TRenderForm.N1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N01Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlaySurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N1voxel1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N16voxels2Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderSmoothClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gRender.FlipLR := FlipLRCheck.Checked; + //RenderSmoothSurface.checked := not RenderSmoothSurface.Checked; + gRender.SmoothBG := RenderSmoothBG.checked; + gRender.SmoothOverlay := RenderSmoothOverlay.checked; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderPreciseInterpolationClick(Sender: TObject); +begin + RenderPreciseInterpolation.Checked := not RenderPreciseInterpolation.Checked; + gRender.Trilinear := RenderPreciseInterpolation.Checked; + RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.FormShow(Sender: TObject); +var + lInc: integer; +begin + gRender.Bias := 50; + gRender.Gain := 50; + gRender.cutoutLUTindex := 0; + gRender.BGSurface := 51; + gRender.OverlaySurface := 1; + gRender.BGDepth := 12; + gRender.OverlayDepth := 8; + gRender.Azimuth := 90; + gRender.Elevation := 45; + gRender.ShadePct := 0; + gRender.OverlayNearClip := 0; + gRender.BGNearClip := 0; + gRender.OverlayNearClipFrac := -1; + gRender.BGNearClipFrac := -1; + gRender.SmoothBG := true; + gRender.SmoothOverlay := false; + gRender.Trilinear := true; + gRender.FlipLR := false; + gRender.OverlayFromBGSurface := kBelow; + gRender.ShowCutout := false;//10/10/2006 + gRender.CutoutBias := 4; + for lInc := 1 to 3 do begin + gRender.CutoutFrac.Lo[lInc] := kMaxFrac div 2; + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end; + ReadRenderIniFile (gRenderStartupFilename); + UpdateRenderMRU; + UpdateRenderDisplay; +end; + +procedure ClipFracCheck (var lFrac,lSlice: integer); +//provide backward compatibility for files that explicitly report slices not fraction +var + lMax: integer; +begin + if lFrac >= 0 then + exit; + lFrac := 0; + lMax := MaxDim(gBGImg.ScrnDim[1],gBGImg.ScrnDim[2],gBGImg.ScrnDim[3]); + if (lSlice <= 0) or (lSlice > lMax) then + exit; + lFrac := round(lSlice/lMax*kMaxFrac); + +end; + +procedure TRenderForm.RefreshRotation; +var + lC: integer; + lMatrix: TMatrix; + lStartTime: DWord; +begin + lMatrix := AziElevMatrix; Application.processmessages; gRender.Zoom := gZoom; //11/2007b gZoom := 1; lStartTime := GetTickCount; ClipFracCheck (gRender.BGNearClipFrac,gRender.BGNearClip); ClipFracCheck (gRender.OverlayNearClipFrac,gRender.OverlayNearClip); gRender.Azimuth := round(AzimuthEdit.value); gRender.Elevation := round(ElevationEdit.value); VolumeRotateMatrix (gBGImg, gMRIcroOverlay[0],lMatrix, gRender.Trilinear,gRender.ShowCutout,true,gRender.BGNearClipFrac); if RenderRefreshTimer.Enabled then exit; Refresh; for lC := 1 to knMaxOverlay do begin VolumeRotateMatrix (gBGImg, gMRIcroOverlay[lC],lMatrix, gRender.Trilinear,false,false,gRender.OverlayNearClipFrac); if RenderRefreshTimer.Enabled then exit; end; ImgForm.StatusLabel.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime));end; +procedure TRenderForm.RenderRefreshTimerTimer(Sender: TObject); +begin + RenderRefreshTimer.Enabled := false; + if gMRIcroOverlay[0].ScrnBufferItems=0 then begin + RenderImage.Width := 0; exit; end; + gRender.ShadePct := ShadeEdit.asInteger; + if (gMRIcroOverlay[0].RenderBufferItems=0) or (RenderRefreshTimer.Tag <> 0) or (AzimuthEdit.value<>gRender.Azimuth) or (ElevationEdit.value<>gRender.Elevation) then + RefreshRotation; + if RenderRefreshTimer.Enabled then exit; + //gZoom := 1; + RenderRefreshTimer.Tag := 0; + DrawRender; +end; + +procedure TRenderForm.EditChange(Sender: TObject); +begin + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.OverlayRenderDepthItem(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure RenderDrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +var lL,lT,lW,lH,lZoomPct: integer; +begin + lImage.Picture.Graphic := RenderForm.RenderImageBup.Picture.Graphic; + lZoomPct := 100; //ImageZoomPct(lImage); + lL := (lHorPos * lZoomPct) div 100; + lT := (lVerPos * lZoomPct) div 100; + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + //next horizontal lines + lImage.Canvas.MoveTo(0,lT); + lImage.Canvas.LineTo(lL-gBGImg.XBarGap,lT); + lImage.Canvas.MoveTo(lL+gBGImg.XBarGap,lT); + lImage.Canvas.LineTo(lW,lT); + //next vertical lines + lImage.Canvas.MoveTo(lL,0); + lImage.Canvas.LineTo(lL,lT-gBGImg.XBarGap); + lImage.Canvas.MoveTo(lL,lT+gBGImg.XBarGap); + lImage.Canvas.LineTo(lL,lH); +end; //Proc RenderDrawXBar + +procedure TRenderForm.RenderImageMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var lXrender,lYrender,lZrender,lXout,lYout,lZOut,lPixelOffset,lZoom: integer; +lMatrix: TMatrix; +begin + if ImgForm.XBarBtn.Down then + RenderDrawXBar ( X,Y,RenderImage); + //Next: find coordinates for orthogonal views: + lZoom := ImageZoomPct(RenderImage); + lXrender := round((X*100) / lZoom ); + lYrender := round(((Y)*100) / lZoom ); + + lPixelOffset := lXrender+ ((gBGImg.RenderDim-lYrender)*gBGImg.RenderDim); + //ImgForm.StatusLabel.caption := inttostr(lXrender)+'x'+inttostr(lYrender)+' -> '+inttostr(gMRIcroOverlay[kBGOverlayNum].RenderDepthBufferItems ); + if (lPixelOffset < 1) or (lPixelOffset >gBGImg.RenderDepthBufferItems ) then exit; + lZrender := gBGImg.RenderDepthBuffer[lPixelOffset]; + lXrender := round(lXrender / gRender.Zoom); + lYrender := round(lYrender / gRender.Zoom); + lZrender := round(lZrender / gRender.Zoom); + //caption := inttostr(lXrender)+'x'+inttostr(lYrender)+'x'+inttostr(LZrender)+' '+inttostr(gBGImg.RenderDepthBuffer[lPixelOffset]); + lMatrix := AziElevMatrix; + InvertMatrixPoint (gBGImg,lMatrix,lXrender,lYrender,lZrender, lXout,lYout,lZOut); + ImgForm.XViewEdit.value := lXOut; + ImgForm.YViewEdit.asInteger := lYOut; + ImgForm.ZViewEdit.asInteger := lZOut; +end; + +procedure TRenderForm.Cutout1Click(Sender: TObject); +begin + CutoutForm.Show; +end; + +procedure TRenderForm.Savesettings1Click(Sender: TObject); +begin + MultiSliceForm.MultiSaveDialog.InitialDir := extractfiledir(gRenderDir); + MultiSliceForm.MultiSaveDialog.FileName := 'a'+inttostr(gRender.Azimuth)+'e'+inttostr(gRender.Elevation); + if not MultiSliceForm.MultiSaveDialog.Execute then exit; + WriteRenderIniFile(MultiSliceForm.MultiSaveDialog.Filename); + UpdateRenderMRU; +end; + +procedure TRenderForm.FormHide(Sender: TObject); +begin + WriteRenderIniFile (gRenderDefaultsFilename); +end; + +procedure TRenderForm.FormCreate(Sender: TObject); +begin +//ThreadsRunning := 0; + gRenderDir := extractfiledir(paramstr(0))+'\render\'; + gRenderDefaultsFilename := gRenderDir + 'default.ini'; + gRenderStartupFilename := gRenderDefaultsFilename; +end; + +procedure TRenderForm.CapBtnMenu1Click(Sender: TObject); +begin + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end; + +procedure TRenderForm.SetSearch(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayFromBGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.Saveas36bitmaps1Click(Sender: TObject); +var + lnViews,lC,lAngle,lStartA: integer; + lAzi,lZoom: boolean; + lBaseFilename,lFilename: string; +begin + lnViews:= ReadIntForm.GetInt('How many bitmaps for a 360-degree rotation?', 4,24,72); + + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + lBaseFilename := ImgForm.SaveDialog1.Filename; + lAzi := false; + lZoom := false;//11/2007b + case MessageDlg('Rotate azimuth?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lAzi := true; + end; //case + case MessageDlg('Generate super-sampled (high quality) renderings?', mtConfirmation, + [mbYes, mbNo], 0) of + id_Yes: lZoom := true; + end; //case + + if lAzi then + lStartA := AzimuthEdit.asInteger + else + lStartA := ElevationEdit.asInteger; + for lC := 1 to lnViews do begin + lAngle := round((lC-1) * (360/lnviews)); + if lAzi then + AzimuthEdit.value := lAngle + else + ElevationEdit.value := lAngle - 180; + RenderRefreshTimer.enabled := false; + if lZoom then + gZoom := 2; + RefreshRotation; + DrawRender; + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lAngle,3),'.png'); + SaveImgAsPNGBMPCore(RenderImage,lFilename); + end; //for each of 36 views + if lAzi then + AzimuthEdit.value := lStartA + else + ElevationEdit.value := lStartA; +end; + +procedure TRenderForm.BiasTrackChange(Sender: TObject); +begin + gRender.Bias := BiasTrack.position; + gRender.Gain := GainTrack.Position; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.QualityBtnClick(Sender: TObject); +begin + gZoom := 2; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; + +end; + +procedure TRenderForm.Generateoversampledrenderingslow1Click( + Sender: TObject); +begin + gZoom := 2; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +end. diff --git a/nii_label.pas b/nii_label.pas new file mode 100755 index 0000000..2dfe114 --- /dev/null +++ b/nii_label.pas @@ -0,0 +1,257 @@ +unit nii_label; +{$IFDEF FPC} +{$mode delphi} +{$ENDIF} +interface +uses +{$IFNDEF FPC} + gziod, +{$ELSE} + gzio2, +{$ENDIF} + dialogs,Classes, SysUtils, define_types; + +procedure createLutLabel (var lut: TLUT; lSaturationFrac: single); +procedure LoadLabels(lFileName: string; var lLabels: TStrRA; lOffset,lLength: integer); +procedure LoadLabelsTxt(lFileName: string; var lLabels: TStrRA); + +implementation + +procedure LoadLabelsCore(lInStr: string; var lLabels: TStrRA); +var + lIndex,lPass,lMaxIndex,lPos,lLength: integer; + lStr1: string; + lCh: char; +begin + lLabels := nil; + lLength := length(lInStr); + lMaxIndex := -1; + for lPass := 1 to 2 do begin + lPos := 1; + if lPass = 2 then begin + if lMaxIndex < 1 then + exit; + SetLength(lLabels,lMaxIndex+1); + for lIndex := 0 to lMaxIndex do + lLabels[lIndex] := ''; + end; + while lPos <= lLength do begin + lStr1 := ''; + repeat + lCh := lInStr[lPos]; inc(lPos); + if (lCh >= '0') and (lCh <= '9') then + lStr1 := lStr1 + lCh; + until (lPos > lLength) or (lCh=kCR) or (lCh=UNIXeoln) or (((lCh=kTab)or (lCh=' ')) and (length(lStr1)>0)); + if (length(lStr1) > 0) and (lPos <= lLength) then begin + lIndex := strtoint(lStr1); + if lPass = 1 then begin + if lIndex > lMaxIndex then + lMaxIndex := lIndex + end else if lIndex >= 0 then begin //pass 2 + lStr1 := ''; + repeat + lCh := lInStr[lPos]; inc(lPos); + if (lPos > lLength) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab) or (lCh=' ')} then + // + else + lStr1 := lStr1 + lCh; + until (lPos > lLength) or (lCh=kCR) or (lCh=UNIXeoln) {or (lCh=kTab)or (lCh=' ')}; + lLabels[lIndex] := lStr1; + end; //if pass 2 + end; //if lStr1>0 + end; //while not EOF + end; //for each pass +end; + +procedure LoadLabels(lFileName: string; var lLabels: TStrRA; lOffset,lLength: integer); +var + f : file; // untyped file + s : string; // string for reading a file + sz: int64; + ptr: bytep; +begin + if GzExt(lFilename) then begin + if (lLength < 1) then exit; + SetLength(s, lLength); + ptr := @s[1]; + UnGZip (lFileName,ptr, lOffset,lLength); + end else begin + AssignFile(f, lFileName); + FileMode := fmOpenRead; + reset(f, 1); + if lOffset > 0 then + seek(f, lOffset); + if (lLength < 1) then + sz := FileSize(f)-lOffset + else + sz := lLength; + if (lOffset+sz) > FileSize(f) then + exit; + SetLength(s, sz); + BlockRead(f, s[1], length(s)); + CloseFile(f); + FileMode := fmOpenReadWrite; + end; + LoadLabelsCore(s, lLabels); + //showmessage(lLabels[1]); +end; + +procedure LoadLabelsTxt(lFileName: string; var lLabels: TStrRA); +//filename = 'all.nii' will read 'aal.txt' +var + lLUTname: string; +begin + lLabels := nil; //empty current labels + lLUTname := changefileext(lFileName,'.txt'); + if not Fileexists(lLUTname) then begin + lLUTname := ParseFileName(lFileName)+'.txt'; //file.nii.gz -> file.txt + if not Fileexists(lLUTname) then + exit; + end; + LoadLabels(lLUTname, lLabels,0,-1); +end; + +procedure desaturateRGBA( var lRGBA: TRGBquad; frac: single); +var + r,g,b: byte; + y: single; +begin + r := lRGBA.rgbRed; + g := lRGBA.rgbGreen; + b := lRGBA.rgbBlue; + //convert RGB->YUV http://en.wikipedia.org/wiki/YUV + y := 0.299 * r + 0.587 * g + 0.114 * b; + r := round(y * (1-frac) + r * frac); + g := round(y * (1-frac) + g * frac); + b := round(y * (1-frac) + b * frac); + lRGBA.rgbRed := r; + lRGBA.rgbGreen := g; + lRGBA.rgbBlue := b; +end; + +function makeRGB(r,g,b: byte): TRGBquad; +begin + result.rgbRed := r; + result.rgbGreen := g; + result.rgbBlue := b; + result.rgbReserved := kLUTalpha; +end; + +procedure createLutLabel (var lut: TLUT; lSaturationFrac: single); //lLUT: 0=gray,1=red,2=green,3=blue +var + i:integer; +begin + lut[0] := makeRGB(0,0,0); + lut[0].rgbReserved:= 0; + lut[1] := makeRGB(71,46,154); + lut[2] := makeRGB(33,78,43); + lut[3] := makeRGB(192,199,10); + lut[4] := makeRGB(32,79,207); + lut[5] := makeRGB(195,89,204); + lut[6] := makeRGB(208,41,164); + lut[7] := makeRGB(173,208,231); + lut[8] := makeRGB(233,135,136); + lut[9] := makeRGB(202,20,58); + lut[10] := makeRGB(25,154,239); + lut[11] := makeRGB(210,35,30); + lut[12] := makeRGB(145,21,147); + lut[13] := makeRGB(89,43,230); + lut[14] := makeRGB(87,230,101); + lut[15] := makeRGB(245,113,111); + lut[16] := makeRGB(246,191,150); + lut[17] := makeRGB(38,147,35); + lut[18] := makeRGB(3,208,128); + lut[19] := makeRGB(25,37,57); + lut[20] := makeRGB(57,28,252); + lut[21] := makeRGB(167,27,79); + lut[22] := makeRGB(245,86,173); + lut[23] := makeRGB(86,203,120); + lut[24] := makeRGB(227,25,25); + lut[25] := makeRGB(208,209,126); + lut[26] := makeRGB(81,148,81); + lut[27] := makeRGB(64,187,85); + lut[28] := makeRGB(90,139,8); + lut[29] := makeRGB(199,111,7); + lut[30] := makeRGB(140,48,122); + lut[31] := makeRGB(48,102,237); + lut[32] := makeRGB(212,76,190); + lut[33] := makeRGB(180,110,152); + lut[34] := makeRGB(70,106,246); + lut[35] := makeRGB(120,130,182); + lut[36] := makeRGB(9,37,130); + lut[37] := makeRGB(192,160,219); + lut[38] := makeRGB(245,34,67); + lut[39] := makeRGB(177,222,76); + lut[40] := makeRGB(65,90,167); + lut[41] := makeRGB(157,165,178); + lut[42] := makeRGB(9,245,235); + lut[43] := makeRGB(193,222,250); + lut[44] := makeRGB(100,102,28); + lut[45] := makeRGB(181,47,61); + lut[46] := makeRGB(125,19,186); + lut[47] := makeRGB(145,130,250); + lut[48] := makeRGB(62,4,199); + lut[49] := makeRGB(8,232,67); + lut[50] := makeRGB(108,137,58); + lut[51] := makeRGB(36,211,50); + lut[52] := makeRGB(140,240,86); + lut[53] := makeRGB(237,11,182); + lut[54] := makeRGB(242,140,108); + lut[55] := makeRGB(248,21,77); + lut[56] := makeRGB(161,42,89); + lut[57] := makeRGB(189,22,112); + lut[58] := makeRGB(41,241,59); + lut[59] := makeRGB(114,61,125); + lut[60] := makeRGB(65,99,226); + lut[61] := makeRGB(121,115,50); + lut[62] := makeRGB(97,199,205); + lut[63] := makeRGB(50,166,227); + lut[64] := makeRGB(238,114,125); + lut[65] := makeRGB(149,190,128); + lut[66] := makeRGB(44,204,104); + lut[67] := makeRGB(214,60,27); + lut[68] := makeRGB(124,233,59); + lut[69] := makeRGB(167,66,66); + lut[70] := makeRGB(40,115,53); + lut[71] := makeRGB(167,230,133); + lut[72] := makeRGB(127,125,159); + lut[73] := makeRGB(178,103,203); + lut[74] := makeRGB(231,203,97); + lut[75] := makeRGB(30,125,125); + lut[76] := makeRGB(173,13,139); + lut[77] := makeRGB(244,176,159); + lut[78] := makeRGB(193,94,158); + lut[79] := makeRGB(203,131,7); + lut[80] := makeRGB(204,39,215); + lut[81] := makeRGB(238,198,47); + lut[82] := makeRGB(139,167,140); + lut[83] := makeRGB(135,124,226); + lut[84] := makeRGB(71,67,223); + lut[85] := makeRGB(234,175,231); + lut[86] := makeRGB(234,254,44); + lut[87] := makeRGB(217,1,110); + lut[88] := makeRGB(66,15,184); + lut[89] := makeRGB(14,198,61); + lut[90] := makeRGB(129,62,233); + lut[91] := makeRGB(19,237,47); + lut[92] := makeRGB(97,159,67); + lut[93] := makeRGB(165,31,148); + lut[94] := makeRGB(112,218,22); + lut[95] := makeRGB(244,58,120); + lut[96] := makeRGB(35,244,173); + lut[97] := makeRGB(73,47,156); + lut[98] := makeRGB(192,61,117); + lut[99] := makeRGB(12,67,181); + lut[100] := makeRGB(149,94,94); + for i := 1 to 100 do + lut[i+100] := lut[i]; //fill 101..200 + for i := 1 to 55 do + lut[i+200] := lut[i]; //fill 201..255 + if (lSaturationFrac < 0) or (lSaturationFrac >= 1.0) then + exit; + for i := 1 to 255 do + desaturateRGBA(lut[i], lSaturationFrac); +end; + +end. + diff --git a/npm.compiled b/npm.compiled new file mode 100755 index 0000000..a6e1131 --- /dev/null +++ b/npm.compiled @@ -0,0 +1,5 @@ +<?xml version="1.0"?> +<CONFIG> + <Compiler Value="/usr/bin/fpc" Date="1285642858"/> + <Params Value=" -MObjFPC -Scgi -O1 -Xs -XX -WG -vewnhi -l @extrafpc.cfg -Fu../fpmath -Fu../common -Fu/usr/lib/lazarus/lcl/units/i386-linux -Fu/usr/lib/lazarus/lcl/units/i386-linux/gtk2 -Fu/usr/lib/lazarus/packager/units/i386-linux -Fu. -onpm -dLCL -dLCLgtk2 npm.lpr"/> +</CONFIG> diff --git a/npm.svg b/npm.svg new file mode 100755 index 0000000..4a2974b --- /dev/null +++ b/npm.svg @@ -0,0 +1,367 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> + +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + width="48" + height="48" + id="svg7854" + sodipodi:version="0.32" + inkscape:version="0.91 r13725" + version="1.0" + sodipodi:docname="npm.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape" + sodipodi:modified="true"> + <defs + id="defs7856"> + <linearGradient + id="linearGradient5656"> + <stop + style="stop-color:#4e83c7;stop-opacity:1;" + offset="0" + id="stop5658" /> + <stop + id="stop5665" + offset="0.24324325" + style="stop-color:#4573a9;stop-opacity:1;" /> + <stop + style="stop-color:#729fcf;stop-opacity:1" + offset="1" + id="stop5660" /> + </linearGradient> + <linearGradient + id="linearGradient5785"> + <stop + style="stop-color:#f1f1f0;stop-opacity:1;" + offset="0" + id="stop5787" /> + <stop + style="stop-color:#555753;stop-opacity:1;" + offset="1" + id="stop5789" /> + </linearGradient> + <linearGradient + id="linearGradient5737"> + <stop + style="stop-color:#babdb6;stop-opacity:1;" + offset="0" + id="stop5739" /> + <stop + style="stop-color:#dddedb;stop-opacity:1;" + offset="1" + id="stop5741" /> + </linearGradient> + <linearGradient + id="linearGradient5660"> + <stop + style="stop-color:#cbcbcb;stop-opacity:1;" + offset="0" + id="stop5662" /> + <stop + style="stop-color:#9f9f9f;stop-opacity:1;" + offset="1" + id="stop5664" /> + </linearGradient> + <linearGradient + id="linearGradient5633"> + <stop + style="stop-color:#f8f8f8;stop-opacity:1;" + offset="0" + id="stop5635" /> + <stop + style="stop-color:#c7c7c1;stop-opacity:1;" + offset="1" + id="stop5637" /> + </linearGradient> + <linearGradient + id="linearGradient5611"> + <stop + style="stop-color:#5e5e5e;stop-opacity:1;" + offset="0" + id="stop5613" /> + <stop + style="stop-color:#929292;stop-opacity:1;" + offset="1" + id="stop5615" /> + </linearGradient> + <linearGradient + id="linearGradient6842"> + <stop + style="stop-color:#d8d9d7;stop-opacity:1;" + offset="0" + id="stop6844" /> + <stop + style="stop-color:#7c7f79;stop-opacity:1;" + offset="1" + id="stop6846" /> + </linearGradient> + <linearGradient + id="linearGradient6832"> + <stop + style="stop-color:#555753;stop-opacity:1;" + offset="0" + id="stop6834" /> + <stop + style="stop-color:#838680;stop-opacity:1;" + offset="1" + id="stop6836" /> + </linearGradient> + <linearGradient + id="linearGradient5048"> + <stop + style="stop-color:black;stop-opacity:0;" + offset="0" + id="stop5050" /> + <stop + id="stop5056" + offset="0.5" + style="stop-color:black;stop-opacity:1;" /> + <stop + style="stop-color:black;stop-opacity:0;" + offset="1" + id="stop5052" /> + </linearGradient> + <linearGradient + id="linearGradient5534"> + <stop + style="stop-color:#888a85;stop-opacity:1;" + offset="0" + id="stop5536" /> + <stop + style="stop-color:#6b6d68;stop-opacity:1;" + offset="1" + id="stop5538" /> + </linearGradient> + <linearGradient + id="linearGradient5491"> + <stop + style="stop-color:#959792;stop-opacity:1;" + offset="0" + id="stop5493" /> + <stop + id="stop5501" + offset="0.25" + style="stop-color:#838681;stop-opacity:1;" /> + <stop + id="stop5499" + offset="0.62437075" + style="stop-color:#abaca9;stop-opacity:1;" /> + <stop + style="stop-color:#ffffff;stop-opacity:1;" + offset="0.79695714" + id="stop5771" /> + <stop + style="stop-color:#90928d;stop-opacity:1;" + offset="1" + id="stop5495" /> + </linearGradient> + </defs> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#e0e0e0" + borderopacity="1" + gridtolerance="10000" + guidetolerance="10" + objecttolerance="10" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="3.9100003" + inkscape:cx="-48.10611" + inkscape:cy="35.428446" + inkscape:document-units="px" + inkscape:current-layer="layer1" + width="48px" + height="48px" + inkscape:showpageshadow="false" + inkscape:window-width="1315" + inkscape:window-height="855" + inkscape:window-x="42" + inkscape:window-y="1" + showgrid="false" + inkscape:window-maximized="0" /> + <metadata + id="metadata7859"> + <rdf:RDF> + <cc:Work + rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type + rdf:resource="http://purl.org/dc/dcmitype/StillImage" /> + <dc:creator> + <cc:Agent> + <dc:title>Jakub Steiner</dc:title> + </cc:Agent> + </dc:creator> + <dc:source>http://jimmac.musichall.cz</dc:source> + <cc:license + rdf:resource="http://creativecommons.org/licenses/GPL/2.0/" /> + <dc:title /> + <dc:subject> + <rdf:Bag> + <rdf:li>file</rdf:li> + <rdf:li>roller</rdf:li> + <rdf:li>compressed</rdf:li> + <rdf:li>handler</rdf:li> + <rdf:li>unzip</rdf:li> + <rdf:li>tar</rdf:li> + <rdf:li>archive</rdf:li> + <rdf:li>extract</rdf:li> + <rdf:li>compress</rdf:li> + </rdf:Bag> + </dc:subject> + </cc:Work> + <cc:License + rdf:about="http://creativecommons.org/licenses/GPL/2.0/"> + <cc:permits + rdf:resource="http://web.resource.org/cc/Reproduction" /> + <cc:permits + rdf:resource="http://web.resource.org/cc/Distribution" /> + <cc:requires + rdf:resource="http://web.resource.org/cc/Notice" /> + <cc:permits + rdf:resource="http://web.resource.org/cc/DerivativeWorks" /> + <cc:requires + rdf:resource="http://web.resource.org/cc/ShareAlike" /> + <cc:requires + rdf:resource="http://web.resource.org/cc/SourceCode" /> + </cc:License> + </rdf:RDF> + </metadata> + <g + inkscape:label="Layer 1" + inkscape:groupmode="layer" + id="layer1"> + <g + id="g4352" + transform="matrix(1.1776889,0,0,1.1776889,91.476193,3.7260676)"> + <g + transform="matrix(0.87994968,-0.30552564,0.67228589,0.61711047,-19.886908,-4.0042723)" + id="g4329"> + <rect + style="fill:#ff0000;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="rect4271" + width="20.875957" + height="20.875957" + x="-50.225185" + y="-11.701121" /> + <circle + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="path4275" + cx="-46.23037" + cy="5.186327" + r="2.4992342" /> + <circle + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="circle4283" + cx="-46.23037" + cy="-7.6806431" + r="2.4992342" /> + <circle + r="2.4992342" + cy="5.186327" + cx="-33.346741" + id="circle4289" + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" /> + <circle + r="2.4992342" + cy="-7.6806431" + cx="-33.346741" + id="circle4293" + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" /> + <circle + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="circle4295" + cx="-39.787209" + cy="-1.2631419" + r="2.4992342" /> + </g> + <g + transform="matrix(0.88734853,-0.32907927,-0.17450793,0.87746319,-23.435719,-3.0296049)" + id="g4343"> + <rect + y="10.542901" + x="-36.661758" + height="20.875957" + width="20.875957" + id="rect4297" + style="fill:#ff0000;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" /> + <circle + r="2.4992342" + cy="27.430349" + cx="-32.666943" + id="circle4299" + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" /> + <circle + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="circle4301" + cx="-32.666943" + cy="20.996866" + r="2.4992342" /> + <circle + r="2.4992342" + cy="14.563379" + cx="-32.666943" + id="circle4303" + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" /> + <circle + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="circle4305" + cx="-19.783312" + cy="27.430349" + r="2.4992342" /> + <circle + r="2.4992342" + cy="20.996866" + cx="-19.783312" + id="circle4307" + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" /> + <circle + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="circle4309" + cx="-19.783312" + cy="14.563379" + r="2.4992342" /> + </g> + <g + transform="matrix(0.66043024,0.64261815,-0.15311427,0.88069755,-27.085258,35.327665)" + id="g4337"> + <rect + style="fill:#ff0000;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="rect4313" + width="20.875957" + height="20.875957" + x="-65.86834" + y="13.255587" /> + <circle + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="circle4315" + cx="-61.873524" + cy="30.143036" + r="2.4992342" /> + <circle + r="2.4992342" + cy="17.276066" + cx="-48.989895" + id="circle4325" + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" /> + <circle + style="fill:#ffffff;fill-opacity:1;stroke:none;stroke-width:0.30000001;stroke-miterlimit:4;stroke-dasharray:none" + id="circle4327" + cx="-55.430363" + cy="23.693567" + r="2.4992342" /> + </g> + </g> + </g> + <g + inkscape:groupmode="layer" + id="layer2" + inkscape:label="Layer 2" /> +</svg> diff --git a/npm/Copy of npm.cfg b/npm/Copy of npm.cfg new file mode 100755 index 0000000..22d5940 --- /dev/null +++ b/npm/Copy of npm.cfg @@ -0,0 +1,38 @@ +-$A+ +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LN"c:\program files\borland\delphi4\Lib" +-U"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-O"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-I"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-R"C:\pas\mricron\common;C:\pas\mricron\fpmath" diff --git a/npm/Copy of prefs.pas b/npm/Copy of prefs.pas new file mode 100755 index 0000000..7f001c6 --- /dev/null +++ b/npm/Copy of prefs.pas @@ -0,0 +1,249 @@ +unit prefs; + +{$H+} +interface +uses + inifiles, define_types,SysUtils,classes; + +type + TPrefs = record + UnusedBool: boolean; + Test, Permutations,CritPct: integer; + end; +const + knotest = 0; //no test specified + kltest = 1;//binomial Liebermeister test + kttest = 2; //t-test + kbmtest = 4;//Bruneer-Mnuzel test + klrtest = 8; //logisitic regression test + +//procedure ReadIni(var lIniName: string; var lPrefs: TPrefs); +procedure SetDefaultPrefs (var lPrefs: TPrefs); +//procedure SaveIni (var lIniName: string; var lPrefs: TPrefs); +//procedure CorrectPrefs (var lPrefs: TPrefs); //ensures only usable file types are created +procedure ReadParamStr; + +implementation + +uses nifti_img, hdr,nifti_hdr; + +procedure Msg(lStr: string); +begin + // +end; + +procedure SetDefaultPrefs (var lPrefs: TPrefs); +begin + lPrefs.unusedbool := true; + lPrefs.Test := knotest; + lPrefs.Permutations := 0; + lPrefs.CritPct := 0; +end; +function CheckBool (lPref, lFlag: integer): boolean; +//check if Flag is ni lPref. For example, if Flag is 1 then returns true for all odd lPrefs +begin + result := (lPref and lFlag) = lFlag; +end; + +function DoLesion (lPrefs: TPrefs): boolean; +label + 666; +const + kSimSampleSize = 64; + knSim = 100; + kCrit = 3; +var + //lBinomial: boolean; + lSim,lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit,lnControlObservations: integer; + lPartImageNames,lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname,lOutNameSim: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA,lPartSymptomRA,lControlSymptomRA: singleP; +begin + result := false; + //lBinomial := not odd( (Sender as tMenuItem).tag); + if (not CheckBool(lPrefs.test ,kltest)) and (not CheckBool(lPrefs.test, kttest)) and (not CheckBool(lPrefs.test, kbmtest)) then begin + Msg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPartImageNames := TStringList.Create; + getmem(lPartSymptomRA,kSimSampleSize*sizeof(single)); + lnControlObservations := 20; + getmem(lControlSymptomRA,lnControlObservations*sizeof(single)); + for lSim := 1 to lnControlObservations do + lControlSymptomRA[lSim] := 5; + //next, get 1st group + if not MainForm.GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit,lBinomial,lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := MainForm.CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not MainForm.CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + //randomization loop.... + for lSim := 1 to knSim do begin + RandomGroup(kSimSampleSize, lImageNames,lSymptomRA, lPartImageNames, lPartSymptomRA); + lOutNameSim := AddIndexToFilename(lOutName,lSim); + lnCrit := kCrit; + MainForm.NPMMsgClear; + //Msg(GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := MainForm.LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to kSimSampleSize do + MainForm.NPMMsg (lPartImageNames.Strings[lSubj-1] + ' = '+realtostr(lPartSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(kSimSampleSize)); + if not MainForm.CheckVoxelsGroup(lPartImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + if lBinomial then + MainForm.LesionNPMAnalyzeBinomial(lPartImageNames,lMaskHdr,lnCrit,lPartSymptomRA,lFactname,lOutNameSim) + else begin + MainForm.ReportDescriptives(lPartSymptomRA,lnSubj); + //LesionNPMAnalyze2(lImageNames,lMaskHdr,lnCrit,-1,lSymptomRA,lFactName,lOutname); + LesionNPMAnalyze2(lPartImageNames,lMaskHdr,lnCrit,lSim{-1},MainForm.ReadPermute,lPartSymptomRA,lFactName,lOutNameSim,lTTest,lBM); + end; + end; //for each simulation... + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + result := true; + 666: + lPartImageNames.free; + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + freemem(lPartSymptomRA); + MainForm.DeleteDecompressed4D(lTemp4D); +end; + + +procedure ReadParamStr; +var + lStr: String; + I,lError: integer; + + //lResult,lHelpShown : boolean; + lCommandChar: Char; + //I,lError: integer; + lSingle: single; + //lOrigWinWid,lOrigWinCen: Integer;*) + lPrefs: TPrefs; +begin + SetDefaultPrefs(lPrefs); + lStr := paramstr(0); + lStr := extractfilename(lStr); + lStr := string(StrUpper(PChar(lStr))) ; + {$IFDEF PNG} + if (lStr = 'DCM2PNG.EXE') then + gOutputFormat := kPNG; + {$ENDIF} + + if (ParamCount > 0) then begin + I := 0; + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') and (ParamCount > I) then begin //special command + //-z= zoom, -f= format [png,jpeg,bmp], -o= output directory + lCommandChar := UpCase(lStr[2]); + inc(I); + lStr := ParamStr(I); + lStr := string(StrUpper(PChar(lStr))) ; + case lCommandChar of + 'C','P','T': begin //CritPct + Val(lStr,lSingle,lError); + if lError = 0 then begin + if lCommandChar = 'C' then + lPrefs.CritPct := round(lSingle) + else if lCOmmandChar = 'P' then + lPrefs.Permutations := round(lSingle) + else if lCOmmandChar = 'T' then + lPrefs.Test := round(lSingle); + end; //not lError + end; //C= CritPct + + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + if fileexists(lStr) then begin + //lStr := GetLongFileName(lStr); + xxx + end else if not (gSilent) then begin + MyWriteln('0 dcm2jpg ERROR: unable to find '+lStr); + if lHelpShown then + MyReadln + else + Showhelp; + lHelpShown := true; + end; + until I >= ParamCount; + end else begin + //begin test routines.... + (* + lStr := 'D:\yuv2.dcm'; + ResetDCMvalues; + lOrigWinWid := gWinWid; + lOrigWinCen := gWinCen; + LoadData(lStr); + gWinWid := lOrigWinWid; + gWinCen := lOrigWinCen; + //...end test routines(**) + ShowHelp; + end;{param count > 0} +end; + +end. + \ No newline at end of file diff --git a/npm/Copy of turbolesion.pas b/npm/Copy of turbolesion.pas new file mode 100755 index 0000000..9025fc6 --- /dev/null +++ b/npm/Copy of turbolesion.pas @@ -0,0 +1,235 @@ +unit turbolesion; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +Type + TLDMPrefs = record + NULP,BMtest,Ttest,Ltest: boolean; + nCrit,nPermute,Run{0 except for montecarlo}: integer; + NameAppend: string; + end; + + + +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} + +function TurboLDM (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lPrefs: TLDMPrefs ; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lPos,lPlank,lThread: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,//,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshPermute,lThreshBonf,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lPlankAllocated: boolean; + //lttest,lBM: boolean; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + lPlankAllocated := false; + //lnPermute := MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lPrefs.nPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lPlankAllocated := true; + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + getmem(lOutImgAUC,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lPrefs.nPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + //next create permuted BM bounds + if lPrefs.BMtest then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lImages.Count, lObs); + end; + ClearThreadData(gnCPUThreads,lPrefs.nPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TLesionContinuous.Create (MainForm.ProgressBar1,lPrefs.ttest,lPrefs.BMtest,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA) do + //with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + //freemem(lPlankImg); + //lPlankAllocated := false; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lPrefs.nCrit)+' patients**'); + goto 123; + end; + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lPrefs.nCrit)+' lesions'); + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + //save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lPrefs.Run < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + if lPrefs.Run > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lPrefs.nCrit,lnVoxTested,lPlankImg)); + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lPrefs.ttest then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lPrefs.nPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('ttest',lPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest'+lFactName,'.hdr'); + if lPrefs.Run > 0 then + MainForm.NPMmsgAppend('threshtt,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lPrefs.BMtest then begin //save Brunner Munzel + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('BM',lPrefs.nPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM'+lFactName,'.hdr'); + if lPrefs.Run > 0 then + MainForm.NPMmsgAppend('threshbm,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgAUC); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + if lPlankAllocated then + freemem(lPlankImg); + //Next: NULPS - do this after closing all memory - this is a memory hog + if lPrefs.NULP then + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lPrefs.nCrit,lnVoxTested)); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + //if lRun > 0 then + // AX(freeram,freeram,freeram,freeram,freeram,freeram); + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + +end. diff --git a/npm/LesionStatThds.o b/npm/LesionStatThds.o new file mode 100644 index 0000000..c2529c9 Binary files /dev/null and b/npm/LesionStatThds.o differ diff --git a/npm/LesionStatThds.pas b/npm/LesionStatThds.pas new file mode 100755 index 0000000..00f59aa --- /dev/null +++ b/npm/LesionStatThds.pas @@ -0,0 +1,453 @@ +unit LesionStatThds; +{$Include ..\common\isgui.inc} +interface + +uses + // ComCtrls,Classes, Graphics, ExtCtrls, + {$IFDEF GUI} ComCtrls,{$ENDIF} + SysUtils, Classes, dialogsx, + define_types,stats,StatThdsUtil,Brunner,lesion_pattern; + + + +type + + TLesionStatThread = class(TThread) + private + lBarX: TProgressBar; + lttestx,lBMx: boolean; + lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx, + lImagesCountx,lControlsx : integer; + lPlankImgx:ByteP; + lOutImgMnx,lOutImgBMx,lOutImgTx,lOutImgAUCX,lSymptomRAx: SingleP; + //lBarX: TProgressBar; + procedure DoVisualSwap; + protected + procedure Execute; override; + procedure VisualProg(lPos: Integer); + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg:bytep;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); virtual; abstract; + public + property Terminated; + constructor Create(lBar: TProgressBar;lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg:ByteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); + end; + + { Lesion - image reveals value } + + TLesionContinuous = class(TLesionStatThread ) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); override; + end; + + TLesionBinom = class(TLesionStatThread ) + protected + procedure Analyze(lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgL,lOutImgX,lOutImgAUC,lSymptomRA: SingleP); override; + end; + +implementation + +(*procedure OutStr(lStr: string); +var + lOutname: string; + f: TextFile; +begin + lOutname:='c:\fx.txt'; + if fileexists(lOutname) then + begin { open a text file } + AssignFile(f, lOutname); + Append(f); + Writeln(f, lStr); + Flush(f); { ensures that the text was actually written to file } + { insert code here that would require a Flush before closing the file } + CloseFile(f); + end; +end; +*) + +Const Two32 = 4294967296.0 ; +function GenRandThreaded(lRange: integer; var lRandSeed:comp): integer; +//normal random function does not work well when threaded - randseed is changed by each thread +const lFactor = $08088405 ; lTerm = 1 ; +type lT = array [0..1] of longint ; +var + lX: extended; +begin + lRandSeed := lRandSeed*lFactor + lTerm; + lT(lRandSeed)[1] := 0 ; // < May'04 was: RS := RS - Trunc(RS/Two32)*Two32 ; + lX := lRandSeed/Two32 ; + result := trunc((lRange)*lX); +end; + +procedure GenPermuteThreaded (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: double; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteThreaded (lttest,lBM: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT,lDF,lBMz: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lttest then begin + TStat2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lBM then begin + //BMTest (lnSubj, lnGroup0, lRanOrder,lOutT); + tBM (lnSubj, lnGroup0, lRanOrder,lBMz,lDF); + lBMz := BMzVal (lnSubj, lnGroup0,lBMz,lDF); + + if lBMz > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lBMz; + if lBMz < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lBMz; + end; //compute BM + end; + freemem(lRanOrderp); +end; + +procedure GenPermuteThreadedBinom (lnSubj: integer; var lOrigOrder,lRanOrder: ByteP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: byte; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteBinomialThreaded (lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: ByteP0); +var + lInc: integer; + lOutP: double; + lRS: Comp; + lRanOrder: byteP0; + //lRanOrderp: pointer; + //lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + //createArray64(lRanOrderp,lRanOrder,lnSubj); + getmem(lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreadedBinom(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + (*if lChi2 then begin + Chi2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lLieber then begin*) + //Liebermeister2bP (lnSubj, lnGroup0, lRanOrder,lOutP); + Liebermeister2bP (lnSubj, lnGroup0, lRanOrder,lOutP); + if (lOutP > 0) and (lOutP < gPermuteMinT[lThread,lInc]) then begin //negative correlation + //fx(lOutP, gPermuteMinBM[lThread,lInc]); + gPermuteMinT[lThread,lInc] := lOutP; + end; + if (lOutP < 0) and ( lOutP > gPermuteMaxT[lThread,lInc]) then //negative correlation + gPermuteMaxT[lThread,lInc] := lOutP; + //end; //compute BM + end; + freemem(lRanOrder); +end; + +procedure TLesionStatThread .DoVisualSwap; +begin + lBarX.Position := lBarPosX; +end; + +procedure TLesionStatThread .VisualProg(lPos: Integer); +begin + lBarPosX := lPos; + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} +end; + +constructor TLesionStatThread .Create(lBar: TProgressBar; lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); +begin + + lBarX := lBar; + lttestx := lttest; + lBMx:= lBM; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lControlsX := lControlsIn; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgBMx := lOutImgBM; + lOutImgTx := lOutImgT; + lOutImgAUCx := lOutImgAUC; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + FreeOnTerminate := True; + inherited Create(False); + //inherited Create(CreateSuspended); +end; + +{ The Execute method is called when the thread starts } + +procedure TLesionStatThread .Execute; +begin + Analyze(lttestx,lBMx, lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lControlsx,lPlankImgX,lOutImgMnx,lOutImgBMx,lOutImgTx,lOutImgAUCx,lSymptomRAx); + +end; + + +procedure TLesionContinuous.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIN : integer; lPlankImg:bytep;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); +//pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsT,lPrevZValsBM,lPrevAUCVals: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + lStr: string; + lObstp,lObsp: pointer; + lObst,lObs: Doublep0; + lT,lBMz,lDF: Double; + lObsB: bytep0; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnControl, + lnControlsPlusLesion,lnControlsPlusPatients : integer; +begin //statthread + //init patterns + lnControl := abs(lControlsIn); + if lControlsIn < 0 then begin //binomial + getmem(lObsB, lImagesCount+lnControl); + end; + lnControlsPlusPatients := lImagesCount+lnControl; + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + //lMaxLesion := lImagesCount-lnCrit; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lnControlsPlusPatients); + lPosPct := (lThreadEnd-lThreadStart) div 100; + //if lThread = 1 then + // OutStr( inttostr(lThreadStart)+':'+inttostr(lThreadEnd)); //xxxxx + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] = 0 then begin + //no lesion + inc(lnNoLesion); + lLesionOrderp^[lPos] := 0; + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + //lObs^[lImagesCount-lnLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) and (lnLesion < lImagesCount) then begin + //when there are 0 lesions or all lesions there is no variability! + inc(gnVoxTestedRA[lThread]); + //now check if we have seen this precise lesion order recently... + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + if lttest then + lOutImgT^[lPos2Offset] := lPrevZvalsT[lPos]; + if lBM then + lOutImgBM^[lPos2Offset] := lPrevZvalsBM[lPos]; + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lPrevAUCvals[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + lnControlsPlusLesion := lnControlsPlusPatients; + if (lControlsIn > 0) {and (lnLesion > 0)} then begin //anaCOm + createArray64(lObstp,lObst,lImagesCount); + for lPos := 1 to lImagesCount do + lObst^[lPos-1] := lObs^[lPos-1]; + for lPos := 1 to lnLesion do + lObs^[lPos-1+lnControl] := lObst^[lPos-1+lnNoLesion]; + freemem(lObstP); + for lPos := 1 to lnControl do + lObs^[lPos-1] := lSymptomRA^[lPos+lImagesCount]; + lnControlsPlusLesion := lnControl+lnLesion; + lnNoLesion := {lnNoLesion +} lnControl; + end;//controls + (*if lPos2 = 2570879 then begin //xxxx + for lPos := 1 to lImagesCount do begin + outstr(inttostr(lPos)+'>'+floattostr(lObs^[lPos-1]) ); + end; + end;*) + + if lttest then begin + if lControlsIn > 0 then begin//anacom + TStat2Z (lnControlsPlusLesion, lnControl {lnNoLesion},lObs,lT); +(* if lPos2 = 2570879 then begin + outstr( floattostr(lT)+ ' '+inttostr(lnControl)); //xxxx + for lPos := 1 to lnControlsPlusLesion do begin + outstr(inttostr(lPos)+', '+floattostr(lObs^[lPos-1]) ); + end; + + end; *) + end else + TStat2 (lnControlsPlusLesion, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + lPrevZValsT[lPatternPos] := lT; + end; + + if lBM then begin + tBM (lnControlsPlusLesion, lnNoLesion, lObs,lBMz,lDF); + lBMz := BMzVal (lnControlsPlusPatients, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + lPrevZValsBM[lPatternPos] := lBMz; + end; + if lOutImgAUC <> nil then begin + lOutImgAUC^[lPos2Offset] := continROC (lnControlsPlusLesion, lnNoLesion, lObs); + lPrevAUCVals[lPatternPos] := lOutImgAUC^[lPos2Offset]; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //novel lesion pattern + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp); + if lControlsIn < 0 then //binomial + freemem(lObsB); + + +end; + +procedure TLesionBinom.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: bytep;lOutImgMn,lOutImgL,lOutImgX,lOutImgAUC,lSymptomRA: SingleP); +//procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); + //pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsL ,lPrevAUCVals: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + //lObsp: pointer; + //lObs: Doublep0; lPrevZVals + lObs: ByteP0; + lAUC,lZ: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //Binomial StatThread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + //createArray64(lObsp,lObs,lImagesCount); + getmem(lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := round(lSymptomRA^[lPos]); + lLesionOrderp^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lnLesion-1] := round(lSymptomRA^[lPos]); //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) and (lnLesion < lImagesCount) then begin + //when there are 0 lesions or all lesions there is no variability! + inc(gnVoxTestedRA[lThread]); + //next check patterns + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + //if lChi2 then + // lOutImgX^[lPos2Offset] := lPrevZvalsX[lPos]; + //if lLieber then + lOutImgL^[lPos2Offset] := lPrevZvalsL[lPos]; + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lPrevAUCvals[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + + {if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + lPrevZValsX[lPatternPos] := lT; + end; + if lLieber then begin} + Liebermeister2b(lImagesCount, lnLesion, lObs,lAUC,lZ); + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lAUC; + lPrevAUCVals[lPatternPos] := lAUC; + lOutImgL^[lPos2Offset] := lZ; + lPrevZValsL[lPatternPos] := lZ; + //end; + StatPermuteBinomialThreaded (lImagesCount, lnLesion,lnPermute,lThread, lObs); + end; + end; //in brain mask - compute + end; //for each voxel + freemem(lObs); + freemem(lLesionOrderp) +end; + +end. \ No newline at end of file diff --git a/npm/LesionStatThds.ppu b/npm/LesionStatThds.ppu new file mode 100644 index 0000000..398d337 Binary files /dev/null and b/npm/LesionStatThds.ppu differ diff --git a/npm/Mat.o b/npm/Mat.o new file mode 100644 index 0000000..af6969a Binary files /dev/null and b/npm/Mat.o differ diff --git a/npm/Mat.pas b/npm/Mat.pas new file mode 100755 index 0000000..020cb09 --- /dev/null +++ b/npm/Mat.pas @@ -0,0 +1,2396 @@ +unit Mat; + +{ Basic Matrix Unit for Delphi, May 1996. Implemented using original iMAP C matrix library } +{ Use this instead of matrix } + + +interface + +Uses SysUtils, Classes, Vector,dialogsx; + +//var gMat: boolean = false; +type EMatrixError = class (Exception); + EMatrixSizeError = class (EMatrixError); + ESingularMatrix = class (EMatrixError); + ENonSquareMatrix = class (EMatrixError); + + TMatError = (Singular, NonSingular, NonSquare); + + + + { A Matrix is made up of a set of rows of type TRow, pTRow is + a pointer to a single row and a matrix is a row of pTRows, this + allows arrays larger then 65K to be built, the max size of + a matrix is roughly 4096 MBytes } + MatRA = array [1..1] of Double; + Matp = ^MatRA; + + { forward declare the Matrix class } + TMatrix = class; + + { Used by svdfit, supplies basis functions at x } + BasisProc = procedure (x : TMatElement; var BasisFunc : TVector); + + { Define a dynamic matrix type for holding doubles } + TMatrix = class (TObject) + private + + nr, nc : integer; + mx :matp;//: pTRowList; { pointer to a list of rows } + procedure SetSize (ri, ci : integer); + procedure FreeSpace; + public + constructor create (r, c : integer); overload; virtual; + constructor create (n : integer); overload; virtual; + constructor create (c : integer; d : array of TMatElement); overload; virtual; + destructor destroy; override; + procedure Setval (ri, ci : integer; v : TMatElement); + function Getval (ri, ci : integer) : TMatElement; + property M[x, y : Integer] : TMatElement read GetVal write SetVal; default; + property r : integer read nr; + property c : integer read nc; + function IsSquare : boolean; + function SameDimensions (m1, m2 : TMatrix) : boolean; + function Identity : TMatrix; + function Diagonal (k : TMatElement) : TMatrix; overload; + function Diagonal (v : TVector) : TMatrix; overload; + function Zero : TMatrix; + function Ones : TMatrix; + function L (ci :integer; d : array of TMatElement) : TMatrix; + function transpose : TMatrix; overload; + function transpose (m1 : TMatrix) : TMatrix; overload; + function add (m1, m2 : TMatrix) : TMatrix; overload; + function add (m1 : TMatrix) : TMatrix; overload; + function sub (m1, m2 : TMatrix) : TMatrix; overload; + function sub (m1 : TMatrix) : TMatrix; overload; + function mult (m1 : TMatrix; k : TMatElement) : TMatrix; overload; + function mult (k : TMatElement) : TMatrix; overload; + function mult (m1, m2 : TMatrix) : TMatrix; overload; + function copy (m1 : TMatrix) : TMatrix; + procedure ExtractColumn (var v : TVector; cc : integer); + procedure ExtractRow (var v : TVector; rr : integer); + function ExchangeRows (r1, r2 : integer) : TMatrix; + function ExchangeCols (c1, c2 : integer) : TMatrix; + function Rank (echelon : TMatrix; eps : double) : integer; + procedure Invert (inv : TMatrix); overload; + procedure Invert; overload; + procedure Invert2 (var dest, src : TMatrix; var col: TVector; var index : TVectori); + function Det2 (m1 : TMatrix; var index : TVectori; var v : TVector): double; + procedure SolveLinear (v, b : TVector; SelfToInv : boolean); + procedure LUSolve (index : TVectori; b : TVector); + procedure LUDecomp (m1 : TMatrix; index : TVectori); + procedure LUDecomp2 (var m1 : TMatrix; var index : TVectori; var v : TVector); + function MatMax: double; + function MatAbsMax: double; + function Det : double; + procedure NullSpace (var NullVectors : TMatrix; var BasisSize : integer; + var Echelon : TMatrix; var TheRank : integer); + + procedure svd (var u : TMatrix; var w : TVector; var v : TMatrix); + procedure svd2 (var u : TMatrix; var w : TVector; var v : TMatrix); + procedure svdSolve (var u : TMatrix; var w : TVector; var v : TMatrix; + b : TVector; var x : TVector); + function svdfit (x, y, yerr : TVector; var fit : TVector; + var u, v : TMatrix; var w : TVector; funcs : BasisProc): TMatElement; + procedure svdCovar (v : TMatrix; w : TVector; alpha : TMatrix); + + procedure eliminate_cms (S, Tk1 : TMatrix; var cr, N : integer); + procedure ElementaryModes (D : TVectori; var mf, mb, C1, k : integer; Tk : TMatrix); + class procedure Tableau (N, R1 : integer; var mf, mb, C1, k : integer; Tk, Tk1 : TMatrix); + class function grecodiv_of_vector (N, R1 : integer; vec : TVector) : integer; + class function grecodiv(P, Rest: integer) : integer; + procedure Conserve(st : TMatrix); + end; + + +{ ------------------------------------------------------------------------- } + +implementation + +const MATERROR = 'Matrix Operation Error:'; + + + +{ ------------------------------------------------------------------------- } +{ START OF MATRIX IMPLEMETATION } +{ ------------------------------------------------------------------------- } + + +{ ------------------------- Constructors first ---------------------------- } + + +{ ******************************************************************** } +{ Usage: A := TMatrix.create (3, 2); } +{ ******************************************************************** } +constructor TMatrix.create (r, c : integer); +begin + Inherited Create; nr := 0; nc := 0; mx := Nil; + Self.SetSize (r, c); + +end; + + + + +{ ******************************************************************** } +{ Create an identity matrix } +{ } +{ Usage: A := TMatrix.createI (3); } +{ ******************************************************************** } +constructor TMatrix.create (n : integer); +var i : integer; +begin + Inherited Create; nr := 0; nc := 0; mx := Nil; + Self.SetSize (n, n); + for i := 1 to n do Self[i,i] := 1.0; +end; + + +{ ******************************************************************** } +{ Create a matrix filled with values from array d given that the } +{ number of columns equals c. } +{ } +{ Usage: A := TMatrix.createLit (2, [1, 2, 3, 4]); } +{ Creates a 2 by 2 array } +{ ******************************************************************** } +constructor TMatrix.create (c : integer; d : array of TMatElement); +var i, j, ri, count : integer; +begin + Inherited Create; nr := 0; nc := 0; mx := Nil; + ri := (High(d)+1) div c; + Self.SetSize (ri, c); + count := 0; + for i := 1 to ri do + for j := 1 to c do + begin + Self[i,j] := d[count]; + inc (count); + end; +end; + + +{ ******************************************************************** } +{ Usage: A.destroy, use a.free in a program } +{ ******************************************************************** } +destructor TMatrix.destroy; +begin + FreeSpace; + Inherited Destroy; +end; + + + +{ Free the data space but not the object } +procedure TMatrix.FreeSpace; +//var i : integer; +begin + if mx <> Nil then + begin + FreeMem (mx); mx := Nil; + end; +end; + + +{ Internal routine used set size of matrix and allocate space } +procedure TMatrix.SetSize (ri, ci : integer); +//var i : integer; +begin + if (mx <> Nil) and ((ri*ci)= (nr*nc) ) then begin + nr := ri; nc := ci; + exit; + end; + //if gMat then beep; + FreeSpace; + nr := ri; nc := ci; + //if gMat then beep; + Getmem(mx,ri*ci*sizeof(TMatElement));//AllocMem (sizeof (pTRowList) * (nr+1)); { r+1 so that I can index from 1 } +end; + + +{ ---------------------------------------------------------------------------- } +{ BASIC ROUTINES } +{ ---------------------------------------------------------------------------- } + + +{ ******************************************************************** } +{ Used internally but is also accessible from the outside } +{ } +{ Normal Usage: A[2, 3] := 1.2; } +{ } +{ ******************************************************************** } +procedure TMatrix.Setval (ri, ci : integer; v : TMatElement); +begin + if ri > r then + raise EMatrixSizeError.Create ('ri index out of range: ' + inttostr (ri)); + + if ci > c then + raise EMatrixSizeError.Create ('ci index out of range: ' + inttostr (ci)); + + mx^[ri + ((ci-1)* r )] := v; +end; + + +{ ******************************************************************** } +{ Used internally but is also accessible from the outside } +{ } +{ Normal Usage: d := A[2, 3]; } +{ } +{ ******************************************************************** } +function TMatrix.Getval (ri, ci : integer) : TMatElement; +begin + result := mx^[ri + ((ci-1)* r )]; +end; + + + + +{ ******************************************************************** } +{ Fill an existing matrix with the array d of numbers. ci equals } +{ the number of columns. } +{ } +{ Usage: A.L(3, [1, 2, 3, 4, 5, 6, 7, 8, 9]); } +{ } +{ ******************************************************************** } +function TMatrix.L (ci :integer; d : array of TMatElement) : TMatrix; +var i, j, ri, count : integer; +begin + ri := (High(d)+1) div ci; + FreeMem (mx, sizeof (TMatElement) * nr * nc); + Self.SetSize (ri, ci); + count := 0; + for i := 1 to ri do + for j := 1 to ci do + begin + Self[i,j] := d[count]; + inc (count); + end; + result := Self; +end; +{ ******************************************************************** } +{ Set all elements to one } +{ } +{ Usage: A.Ones; } +{ } +{ ******************************************************************** } + +function TMatrix.Ones : TMatrix; +var i, j : integer; +begin + for i := 1 to r do + for j := 1 to c do + Self[i,j] := 1.0; + result := Self; +end; +{ ******************************************************************** } +{ Zero the Self matrix } +{ } +{ Usage: A.Zero; } +{ } +{ ******************************************************************** } +function TMatrix.Zero : TMatrix; +var i, j : integer; +begin + for i := 1 to r do + for j := 1 to c do + Self[i,j] := 0.0; + result := Self; +end; + + +{ ******************************************************************** } +{ Returns true if matrices m1 and m2 have the same dimensions } +{ } +{ Usage: if SameDimensions (A, B) then } +{ } +{ ******************************************************************** } +function TMatrix.SameDimensions (m1, m2 : TMatrix) : boolean; +begin + result := (m1.nr = m2.nr) and (m1.nc = m2.nc); { use nr, nc for direct access } +end; + + +{ ******************************************************************** } +{ Returns true if matrix m is square } +{ } +{ Usage: if IsSquare then } +{ } +{ ******************************************************************** } +function TMatrix.IsSquare : boolean; +begin + result := Self.nr = Self.nc; +end; + + +{ ******************************************************************** } +{ Turn the matrix Self into an identify matrix } +{ } +{ Usage: A.Identity } +{ } +{ ******************************************************************** } +function TMatrix.Identity : TMatrix; +var i : integer; +begin + if Self.IsSquare then + begin + Self.Zero; + for i := 1 to r do Self[i,i] := 1.0; + result := Self; + end + else + raise EMatrixSizeError.Create ('An identity matrix can only be formed from a square matrix'); +end; + + +{ ******************************************************************** } +{ Make the matrix object a diagonal matrix with the value, k } +{ } +{ Usage: A.Diagonal (3.1415); } +{ } +{ ******************************************************************** } +function TMatrix.Diagonal (k : TMatElement) : TMatrix; +var i : integer; +begin + if Self.IsSquare then + begin + Self.Zero; + for i := 1 to r do Self[i,i] := k; + result := Self; + end + else + raise EMatrixSizeError.Create ('Can only form a diagonal matrix from a square matrix'); +end; + + +{ ******************************************************************** } +{ This forms a diagonal matrix from the elements of vector v. } +{ } +{ Usage: A.Diagonal (v) } +{ } +{ ******************************************************************** } +function TMatrix.Diagonal (v : TVector) : TMatrix; +var i : integer; +begin + if Self.IsSquare then + begin + if v.size = Self.nr then + begin + Self.zero; + for i := 1 to r do Self[i,i] := v[i]; + result := Self; + end + else + raise EMatrixSizeError.Create ('Vector must be same size as matrix in DiagonalV'); + end + else + raise EMatrixSizeError.Create ('Can only form a diagonal matrix from a square matrix'); +end; + + +{ ******************************************************************** } +{ Transpose matrix 'Self', Self is thus destroyed and replaced } +{ } +{ Usage: A.transpose } +{ } +{ ******************************************************************** } +function TMatrix.Transpose : TMatrix; +var i, j : integer; tmp : TMatrix; +begin + if (r=1) or (c=1) then begin + i := nr; + nr := nc; + nc := i; + exit; + end; + tmp := TMatrix.create (c, r); + try + for i := 1 to r do + for j := 1 to c do + tmp [j,i] := Self[i,j]; + Self.FreeSpace; Self.SetSize (tmp.nr, tmp.nc); + { move data from transpose to Self } + Self.Copy (tmp); + finally + tmp.Destroy; + end; + result := Self; +end; + + +{ ******************************************************************** } +{ Transpose the matrix 'm' into Self } +{ } +{ Usage: T.transpose (A); Tranposes A and puts result into T } +{ Will also accept T.transpose (T) } +{ ******************************************************************** } +function TMatrix.Transpose (m1 : TMatrix) : TMatrix; +var i, j : integer; t : TMatrix; +begin + if (m1.r <> Self.c) and (m1.c <> Self.r) then + raise EMatrixSizeError.Create ('Destination matrix has incorrect dimensions for transpose'); + { If the user is trying to transpose itself.... } + if Self = m1 then + begin + t := TMatrix.Create (r, c); + try + t.Copy (m1); + for i := 1 to m1.r do + for j := 1 to m1.c do + Self[j,i] := t[i,j]; + finally + t.free; + result := Self; + end; + exit; + end; + + for i := 1 to m1.r do + for j := 1 to m1.c do + Self[j,i] := m1[i,j]; + result := Self; +end; + + +{ ******************************************************************** } +{ Copy matrix 'm' to Self, Self must exist and is overwritten } +{ in the process. This procedure does a fast deep copy of the matrix. } +{ } +{ Usage: B.Copy (A); performs the operation: B = A with deep copy } +{ } +{ ******************************************************************** } +function TMatrix.Copy (m1 : TMatrix) : TMatrix; +begin + + if ( r<> m1.r) or (c <> m1.c) then begin + (*if r <> m.r then + raise EMatrixSizeError.Create (MATERROR + #13#10'Cannot copy matrices with different sized rows: dest<' + + inttostr (r) + '> src<' + inttostr (m.r) + '>') + else + raise EMatrixSizeError.Create (MATERROR + #13#10'Cannot copy matrices with different sized columns: dest<' + + inttostr (c) + '> src<' + inttostr (m.c) + '>'); *) + SetSize (self.r, self.c); + end; + { Copy a whole row at a time using move } + //for i := 1 to r do move (m.mx^[i]^, Self.mx^[i]^, sizeof(TMatElement) * (c+1)); + move(m1.mx^,self.mx^,r*c*sizeof(double)); + // Copy over column and row names, clear destination first then copy + result := Self; +end; + + +{ ******************************************************************** } +{ Extract column cc from the Self matrix and return it as a TVector } +{ } +{ Usage: m.ExtractColumn (v, 1) extract column 1 from m and place in v} +{ } +{ ******************************************************************** } +procedure TMatrix.ExtractColumn (var v : TVector; cc : integer); +var i : integer; +begin + v.freeSpace; v.SetSize (Self.r); { Create result vector of appropriate size } + for i := 1 to Self.r do v[i] := Self[i, cc]; +end; + + +{ ******************************************************************** } +{ Extract rwo rr from the Self matrix and return it as a TVector } +{ } +{ Usage: m.ExtractRow (v, 1) extract row 1 from m and place in v } +{ } +{ ******************************************************************** } +procedure TMatrix.ExtractRow (var v : TVector; rr : integer); +var i : integer; +begin + v.freespace; v.SetSize (Self.c); + for i := 1 to Self.c do v[i] := Self[rr, i]; +end; + + +{ ******************************************************************** } +{ Add matrix 'm' to Self, giving a new Self } +{ } +{ Usage: A.addU (B); add B to A, giving A } +{ } +{ ******************************************************************** } +function TMatrix.add (m1 : TMatrix) : TMatrix; +var i, j : integer; +begin + if Not SameDimensions (m1, Self) then + raise EMatrixSizeError.Create ('Incorrectly sized result matrix for matrix addition'); + + for i := 1 to r do + for j := 1 to c do + Self[i,j] := Self[i,j] + m1[i,j]; + result := Self; +end; + + +{ ******************************************************************** } +{ Add matrix 'm1' and 'm2' and assign to Self } +{ } +{ Usage: A.add (A1, A2); add A1 to A2 giving A } +{ } +{ ******************************************************************** } +function TMatrix.add (m1, m2 : TMatrix) : TMatrix; +var i, j : integer; +begin + if Not SameDimensions (m1, m2) then + raise EMatrixSizeError.Create ('Incompatible matrix operands to add'); + + if Not SameDimensions (m1, Self) then + raise EMatrixSizeError.Create ('Incorrectly sized result matrix for matrix addition'); + + for i := 1 to r do + for j := 1 to c do + Self[i,j] := m1[i,j] + m2[i,j]; + result := Self; +end; + + + +{ ******************************************************************** } +{ Subtract matrix m from Self giving a new Self } +{ } +{ Usage: A.subU (B); subtract B from A giving A } +{ } +{ ******************************************************************** } +function TMatrix.sub (m1 : TMatrix) : TMatrix; +var i, j : integer; +begin + if Not SameDimensions (m1, Self) then + raise EMatrixSizeError.Create ('Incorrecly sized result matrix for matrix subtraction'); + + for i := 1 to r do + for j := 1 to c do + Self[i,j] := Self[i,j] - m1[i,j]; + result := Self; +end; + + + +{ ******************************************************************** } +{ Subtract m2 from m1 giving Self } +{ } +{ Usage: A.sub (A1, A2); subtract A2 from A1 giving A (A = A2 - A1) } +{ } +{ ******************************************************************** } +function TMatrix.sub (m1, m2 : TMatrix) : TMatrix; +var i, j : integer; +begin + if Not SameDimensions (m1, m2) then + raise EMatrixSizeError.Create ('Incompatible matrix operands to subtract'); + + if Not SameDimensions (m1, Self) then + raise EMatrixSizeError.Create ('Incorrectly sized result matrix for matrix subtraction'); + + for i := 1 to r do + for j := 1 to c do + Self[i,j] := m1[i,j] - m2[i,j]; + result := Self; +end; + + +{ ******************************************************************** } +{ Multiply a matrix 'm' by scalar constant k and assign result to Self } +{ } +{ Usage: A.multk (B, 0.5); multiply scalar, 0.5 by B giving A } +{ } +{ ******************************************************************** } +function TMatrix.mult (m1 : TMatrix; k : TMatElement) : TMatrix; +var i, j : integer; +begin + for i := 1 to m1.r do + for j := 1 to m1.c do + Self[i, j] := m1[i,j] * k; + result := Self; +end; + + +{ ******************************************************************** } +{ Multiply the Self matrix by the scalar constant k } +{ } +{ Usage: A.multKU (0.5); multiply scalar 0.5 by A giving A } +{ } +{ ******************************************************************** } +function TMatrix.mult (k : TMatElement) : TMatrix; +var i, j : integer; +begin + for i := 1 to r do + for j := 1 to c do + Self[i, j] := Self[i,j] * k; + result := Self; +end; + + + +{ ******************************************************************** } +{ Multiply matrix 'm1' by 'm2' to give result in Self } +{ } +{ Usage: A.mult (A1, A2); multiply A1 by A2 giving A } +{ } +{ ******************************************************************** } +function TMatrix.mult (m1, m2 : Tmatrix) : TMatrix; +var i, j, k, m1_Col : integer; sum : TMatElement; +begin + if m1.c = m2.r then + begin + m1_col := m1.c; + for i := 1 to Self.r do + for j := 1 to Self.c do + begin + sum := 0.0; + for k := 1 to m1_Col do + sum := sum + m1[i, k]* m2[k, j]; + Self[i,j] := sum; + end; + result := Self; + end + else + raise EMatrixSizeError.Create ('Incompatible matrix operands to multiply'); +end; + + +{ ******************************************************************** } +{ LU Solve. Solve the linear system represented by m and right-hand } +{ side b m is assumed have have been decomposed by LUDecomp } +{ } +{ Usage: m.LUSolve (index, b) } +{ } +{ ******************************************************************** } +procedure TMatrix.LUSolve (index : TVectori; b : TVector); +var i, j, ii, ip, nRows : integer; sum : TMatElement; +begin + ii := 0; + nRows := r; + for i := 1 to nRows do + begin + ip := index[i]; + sum := b[ip]; + b[ip] := b[i]; + if ii <> 0 then + for j := ii TO i-1 do sum := sum - Self[i,j]*b[j] + else if sum <> 0.0 then ii := i; + b[i] := sum; + end; + for i := nRows downto 1 do + begin + sum := b[i]; + if i < nRows then + for j := i+1 to nRows do sum := sum - Self[i,j]*b[j]; + b[i] := sum/Self[i,i]; + end +end; + + +{ ******************************************************************** } +{ Form LU decomposition of Self matrix. Result goes into m } +{ } +{ Usage: m.LUDecomp(result, index); } +{ } +{ ******************************************************************** } +procedure TMatrix.LUDecomp (m1 : TMatrix; index : TVectori); +var v : TVector; i, k, j, imax, nRows : integer; sum, big, tmp : TMatElement; +begin + if Self.r = m1.c then + begin + m1.Copy (Self); + v := TVector.Create (m1.r); + try + { Find the largest element in every row, and store its reciprocal in v[i] } + nRows := m1.r; + for i := 1 to nRows do + begin + big := 0.0; { needed to test for singularity } + { Although we're working across columns we can use nRows since m1 is square } + for j := 1 to nRows do if (abs(m[i,j]) > big) then big := abs(m[i,j]); + if big = 0.0 then raise ESingularMatrix.Create ('LUDecomp: Singular matrix in LUDecomp, found row of zeros'); + v[i] := 1.0/big + end; + + for j := 1 TO nRows do + begin + { Form beta = aij - sum_k=1^i-1 aik * bkj } + for i := 1 TO j-1 do + begin + sum := m[i,j]; + for k := 1 to i-1 do sum := sum - m[i,k]*m[k,j]; + m[i,j] := sum + end; + big := 0.0; + for i := j to nRows do + begin + sum := m[i,j]; + for k := 1 to j-1 do sum := sum - m[i,k]*m[k,j]; + m[i,j] := sum; + if v[i]*abs(sum) >= big then + begin + big := v[i]*abs(sum); + imax := i + end + end; + + { Interchange rows if necessary } + if j <> imax then + begin + { Swap row names aswell } + for k := 1 to nRows do + begin + tmp := m[imax,k]; + m[imax,k] := m[j,k]; + m[j,k] := tmp + end; + v[imax] := v[j] + end; + index[j] := imax; + { Get ready to divide by pivot element } + if m[j,j] = 0.0 then + raise ESingularMatrix.Create ('LUDecomp: Singular Matrix, pivot value is zero'); + if j <> nRows then + begin + tmp := 1.0/m[j,j]; + for i := j+1 to nRows do m[i,j] := m[i,j]*tmp + end + end; + finally + v.destroy; + end; + end + else + raise ENonSquareMatrix.Create ('LUDecomp: Matrix must be square'); +end; + +//return max value in a matrix +function TMatrix.MatMax : double; +var i,j : integer; +begin + if (r < 1) or (c<1) then begin + result := 0; + exit; + end; + result := m[1,1]; + for i := 1 to r do + for j := 1 to c do + if m[i, j] > result then + result := m[i,j]; +end; + +//return max value in a matrix +function TMatrix.MatAbsMax : double; +var i,j : integer; +begin + if (r < 1) or (c<1) then begin + result := 0; + exit; + end; + result := abs(m[1,1]); + for i := 1 to r do + for j := 1 to c do + if abs(m[i, j]) > result then + result := abs(m[i,j]); +end; +{ ******************************************************************** } +{ Find determinant of matrix } +{ } +{ Usage: d := m.det } +{ } +{ ******************************************************************** } +function TMatrix.Det : double; +var m1 : TMatrix; index : TVectori; i : integer; +begin + result := 1; + if r = c then + begin + index := TVectori.Create (r); + m1 := TMatrix.Create (r,r); + try + m1.copy (Self); + Self.LUDecomp (m1, index); + for i := 1 to r do result := result * m1[i,i]; + finally + m1.free; index.free; + end; + end + else + raise ENonSquareMatrix.Create ('Determinant: Matrix must be square'); +end; + +(*procedure wMatrix( lTitle: string; A : TMatrix); +var + lR,lC: integer; + lStr: string; +begin + if (A.r < 1) or (A.c < 1) then + exit; + lStr := (lTitle)+chr($0D)+chr($0A); + + for lR := 1 to (A.r) do begin + for lC := 1 to (A.c) do + lStr := lStr + floattostr(A.Getval(lr, lc))+' '; + lStr := lStr + chr($0D)+chr($0A); + end; //each row + showmessage(lStr); +end;*) + + +procedure TMatrix.LUDecomp2 (var m1 : TMatrix; var index : TVectori; var v : TVector); +var i, k, j, imax, nRows : integer; sum, big, tmp : TMatElement; +begin + if Self.r = m1.c then + begin + m1.Copy (Self); + //wmatrix('m1',m1); + //v := TVector.Create (m.r); + try + { Find the largest element in every row, and store its reciprocal in v[i] } + nRows := m1.r; + for i := 1 to nRows do + begin + big := 0.0; { needed to test for singularity } + { Although we're working across columns we can use nRows since m1 is square } + for j := 1 to nRows do if (abs(m1[i,j]) > big) then big := abs(m1[i,j]); + if big = 0.0 then raise ESingularMatrix.Create ('LUDecomp: Singular matrix in LUDecomp, found row of zeros'); + v[i] := 1.0/big + end; + + for j := 1 TO nRows do + begin + { Form beta = aij - sum_k=1^i-1 aik * bkj } + for i := 1 TO j-1 do + begin + sum := m1[i,j]; + for k := 1 to i-1 do sum := sum - m1[i,k]*m1[k,j]; + m1[i,j] := sum + end; + big := 0.0; + for i := j to nRows do + begin + sum := m1[i,j]; + for k := 1 to j-1 do sum := sum - m1[i,k]*m1[k,j]; + m1[i,j] := sum; + if v[i]*abs(sum) >= big then + begin + big := v[i]*abs(sum); + imax := i + end + end; + + { Interchange rows if necessary } + if j <> imax then + begin + { Swap row names aswell } + for k := 1 to nRows do + begin + tmp := m1[imax,k]; + m1[imax,k] := m1[j,k]; + m1[j,k] := tmp + end; + v[imax] := v[j] + end; + index[j] := imax; + { Get ready to divide by pivot element } + if m1[j,j] = 0.0 then + raise ESingularMatrix.Create ('LUDecomp: Singular Matrix, pivot value is zero'); + if j <> nRows then + begin + tmp := 1.0/m1[j,j]; + for i := j+1 to nRows do m1[i,j] := m1[i,j]*tmp + end + end; + finally + //v.destroy; + end; + end + else + raise ENonSquareMatrix.Create ('LUDecomp: Matrix must be square'); +end; + +function TMatrix.Det2 (m1 : TMatrix; var index : TVectori; var v : TVector): double; +var i : integer; +begin + result := 1; + if r = c then + begin + //index := TVectori.Create (r); + //m := TMatrix.Create (r,r); + try + m1.copy (Self); + Self.LUDecomp2 (m1, index,v); + for i := 1 to r do result := result * m1[i,i]; + finally + //m.free; index.free; + end; + end + else + raise ENonSquareMatrix.Create ('Determinant: Matrix must be square'); +end; + +{ ******************************************************************** } +{ Solve a linear system of equations: Self.v = b, i.e solve for v } +{ } +{ Usage: A.SolveLinear (v, b, t); } +{ Solution in v } +{ If the boolean t is true then self is replaced by the inverse } +{ ******************************************************************** } +procedure TMatrix.SolveLinear (v, b : TVector; SelfToInv : boolean); +var n, i, j : integer; + indx : TVectori; col : TVector; + dest, src : TMatrix; +begin + if Self.r = Self.c then + begin + n := Self.r; + { Make a copy and work on the copy } + dest := TMatrix.Create (n, n); + src := TMatrix.Create (n, n); + indx := TVectori.Create (n); + try + src.Copy (Self); + for i := 1 to n do v[i] := b[i]; + src.LUDecomp (dest, indx); + dest.LUSolve (indx, v); + if SelfToInv then + begin + col := TVector.Create (n); + try + for j := 1 to n do + begin + for i := 1 to n do col[i] := 0.0; + col[j] := 1.0; + dest.LUSolve (indx, col); + for i := 1 to n do Self[i,j] := col[i]; + end; + finally + col.free; + end; + end; + finally + indx.destroy; dest.destroy; src.destroy; + end; + end + else + raise ENonSquareMatrix.Create ('SolveLinear: Matrix must be square'); +end; + + + + +{ ******************************************************************** } +{ Fast method for inverting a matrix (Self) } +{ Result in inv } +{ } +{ Usage: A.Invert (inv); } +{ ******************************************************************** } +procedure TMatrix.Invert2 (var dest, src : TMatrix; var col: TVector; var index : TVectori); +var n, i, j : integer; +begin + n := Self.r; + try + src.Copy (Self); + try + //wmatrix('w1',src); + src.LUDecomp2 (dest, index,col); + //wmatrix('w2',src); + except + on ESingularMatrix do + raise ESingularMatrix.Create ('Invert: Singular Matrix'); + end; + for j := 1 to n do + begin + for i := 1 to n do col[i] := 0.0; + col[j] := 1.0; + dest.LUSolve (index, col); + for i := 1 to n do Self[i,j] := col[i]; + end; + finally + //col.destroy; dest.destroy; src.destroy; index.destroy; + end; +end; + +procedure TMatrix.Invert (inv : TMatrix); +var col : TVector; n, i, j : integer; + dest, src : TMatrix; indx : TVectori; +begin + n := Self.r; + col := TVector.Create (n); + dest := TMatrix.Create (n, n); + src := TMatrix.Create (n, n); + indx := TVectori.Create (n); + try + src.Copy (Self); + try + src.LUDecomp (dest, indx); + except + on ESingularMatrix do + raise ESingularMatrix.Create ('Invert: Singular Matrix'); + end; + for j := 1 to n do + begin + for i := 1 to n do col[i] := 0.0; + col[j] := 1.0; + dest.LUSolve (indx, col); + for i := 1 to n do inv[i,j] := col[i]; + end; + finally + col.destroy; dest.destroy; src.destroy; indx.destroy; + end; +end; + + +{ ******************************************************************** } +{ Fast method for inverting a matrix (Self) } +{ Result in Self } +{ } +{ Usage: A.Invert } +{ ******************************************************************** } + +procedure TMatrix.Invert; +var col : TVector; n, i, j : integer; + dest, src : TMatrix; index : TVectori; +begin + n := Self.r; + col := TVector.Create (n); + dest := TMatrix.Create (n, n); + src := TMatrix.Create (n, n); + index := TVectori.Create (n); + try + src.Copy (Self); + try + src.LUDecomp (dest, index); + except + on ESingularMatrix do + raise ESingularMatrix.Create ('Invert: Singular Matrix'); + end; + for j := 1 to n do + begin + for i := 1 to n do col[i] := 0.0; + col[j] := 1.0; + dest.LUSolve (index, col); + for i := 1 to n do Self[i,j] := col[i]; + end; + finally + col.destroy; dest.destroy; src.destroy; index.destroy; + end; +end; + + +{ Internal routine that sets any values less than eps to 0.0 } +procedure CleanUpMatrix (m : TMatrix; eps : double); +var i, j, ri, ci : integer; +begin + { Removes all numbers close to zero, i.e between -eps and +eps } + ri := m.r; ci := m.c; + for i := 1 to ri do + for j := 1 to ci do + if abs (m [i, j]) < eps then m [i, j] := 0.0; +end; + + +{ Internal routine to work out the rank of a matrix given the reduced row-echelon } +function ComputeRank (m : TMatrix; eps : double) : integer; +var i, j, ri, ci, rank : integer; +begin + ri := m.r; ci := m.c; + { find the rank - brute force algorithm } + rank := 0; + { search row by row for zero rows } + for i := 1 to ri do + begin + { search along the row looking for nonzero entry } + for j := 1 to ci do + if abs (m [i, j]) > eps then + begin + inc (rank); + break; + end; + + end; + result := rank; +end; + + +{ ******************************************************************** } +{ Routine to exchange two rows, r1 and r2 in matrix Self } +{ } +{ Usage: A.exchangeRows (1, 2); } +{ } +{ ******************************************************************** } +function TMatrix.ExchangeRows (r1, r2 : integer) : TMatrix; +var ci, i : integer; t : double; +begin + if (r1 > 0) and (r1 <= Self.r) and (r2 > 0) and (r2 <= Self.r) then + begin + ci := Self.c; + for i := 1 to ci do + begin + t := Self[r1, i]; + Self[r1, i] := Self[r2, i]; + Self[r2, i] := t; + end; + result := Self; + end + else + raise EMatrixSizeError.Create ('Rows not in range for exchange'); +end; + + + +{ ******************************************************************** } +{ Routine to exchange two columns, c1 and c2 in matrix Self } +{ } +{ Usage: A.exchangeCols (1, 2); } +{ } +{ ******************************************************************** } +function TMatrix.ExchangeCols (c1, c2 : integer) : TMatrix; +var ri, i : integer; t : double; +begin + if (c1 > 0) and (c1 <= Self.c) and (c2 > 0) and (c2 <= Self.c) then + begin + ri := Self.r; + for i := 1 to ri do + begin + t := Self[c1, i]; + Self[c1, i] := Self[c2, i]; + Self[c2, i] := t; + end; + result := Self; + end + else + raise EMatrixSizeError.Create ('Columns not in range for exchange'); +end; + + + +{ ******************************************************************** } +{ Find the rank r, of the matrix Self, The reduced Row } +{ echelon is returned in mat. eps is the magnitude of } +{ the largest number before it is assumed to be zero. } +{ } +{ Usage: r := A.Rank (echelon, 1e-8) } +{ Find the rank of A, place echelon in echelon } +{ } +{ ******************************************************************** } +function TMatrix.Rank (echelon : TMatrix; eps : double) : integer; +var Arow, Acol, i, j, n, m1, RowScan : integer; + factor : double; +begin + echelon.copy (Self); { we work on mat, not Self } + + if (eps = 0.0) then eps := 1.0E-14; + + n := echelon.r; m1 := echelon.c; + + Arow := 1; Acol := 1; + repeat + { locate a nonzero column } + if abs(echelon [Arow, Acol]) <= eps then { i.e equals zero } + begin + { First entry was zero, therefore work our way down the matrix + looking for a nonzero entry, when found, swap it for Arow } + RowScan := Arow; + repeat + { next row } + inc (RowScan); + { have we reached the end of the rows but we've still got columns left to scan } + if (RowScan > n) and (Acol < m1) then + begin + { reset row counter back to where it was and try next column } + RowScan := Arow; inc (Acol); + end; + + { If we've scanned the whole matrix, so lets get out... } + if (RowScan > n) then + begin + CleanUpMatrix (echelon, eps); + result := ComputeRank (echelon, eps); + exit; + end; + until abs (echelon [RowScan, Acol]) > eps; { keep searching until non-zero entry found } + + { We've found a nonzero row entry so swap it with + 'Arow' which did have a zero as its entry } + echelon.exchangeRows (Arow, RowScan); + end; + { Arow now holds the row of interest } + factor := 1.0/echelon [Arow, Acol]; + { reduce all the entries along the column by the factor } + for i := Acol to m1 do echelon[Arow,i] := echelon[Arow, i] * factor; + + { now eliminate all entries above and below Arow, this generates the reduced form } + for i := 1 to n do + { miss out Arow itself } + if (i <> Arow) and (abs (echelon [i, Acol]) > eps) then + begin + factor := echelon [i, Acol]; + { work your way along the column doing the same operation } + for j := Acol to m1 do + echelon[i,j] := echelon [i, j] - factor * echelon [Arow, j]; + end; + + inc (Arow); inc (Acol); + until (Arow > n) or (Acol > m1); + CleanUpMatrix (echelon, eps); + result := ComputeRank (echelon, eps); { This is just a patch for the moment } +end; + + +(* + Algorithm + + 1. Reduce matrix to reduced echelon form + 2. There will be as many null space vectors as there are + non-leading columns. Select one of these non-leading columns. + 3. Select the ith non-leading column and place a 1 at the ith + position in the growing null space vector + 4. Consider the remaining non-leading columns, say j,k,l... + and place zero's at positions j,k,l... in the growing null + vector. + 5. Consider now the column positions of the leading columns, say + l,m,n... The equivalent entries in the growing null space + are what remains to be filled in. Select each of these leading + columns in turn, say the lth first. Record which row the + leading one is in, say r. Then place at position l in the + growing null space vector, the element -1 * element (r, i) + where i is the original ith non-leading column selected in + step 3. Continue for leading columns m,n... until the growing + null space vector is complete. + 6. Go back to step 2 and pick another non-leading column to + compute the next null space vector. + +Does not disturb the matrix Self. Null space to be found in NullVectors, size of +the basis in BasisSize, the reduced row-echelon in Echelon and the rank in TheRank } + + Usage: A.NullSpace (N, b, Echelon, r); +*) +procedure TMatrix.NullSpace (var NullVectors : TMatrix; var BasisSize : integer; + var Echelon : TMatrix; var TheRank : integer); +var eps, x: double; + i, j, k : integer; + mask : TVectori; + tmpNullVectors : TMatrix; + VectorCounter, maskcount : integer; + minus999, minus888, EchelonCols : integer; +begin + try + eps := 0.000000001; + minus999 := -999; { leading column } + minus888 := -888; { non-leading column } + + if NullVectors <> Nil then NullVectors.free; + if Echelon <> Nil then Echelon.free; + + tmpNullVectors := TMatrix.Create (Self.c, Self.c); + Echelon := TMatrix.Create (Self.r, Self.c); + EchelonCols := Echelon.c; + mask := TVectori.create (EchelonCols); + + // STEP 1 + k := Self.Rank (Echelon, eps); + TheRank := k; + + k := Self.c - TheRank; + BasisSize := k; + if BasisSize > 0 then + begin + for i := 1 to EchelonCols do mask [i] := minus888; + + for i := 1 to Echelon.r do + begin + { scan along columns looking for a leading one } + j := 1; + repeat + x := Echelon[i, j]; + if (x > -eps) and (x < eps) then { check if its practically zero } + Echelon [i, j] := 0.0; + + if (x > 1.0-eps) and (x < 1.0+eps) then { x is then = 1.0 } + begin + mask [j] := minus999; { tag as leading column } + j := 0; { exit signal } + end + else + j := j + 1; + + until (j = 0) or (j > EchelonCols); + + end; { end row scan } + { Find non-leading columns } + VectorCounter := 1; + i := 1; { i = column counter, check all columns } + repeat + for j := 1 to EchelonCols do tmpNullVectors[j, VectorCounter] := minus888; + + { STEP 5 } + { remember, all minus888's in mask = non-leading columns } + if mask [i] = minus888 then { found a non-leading column } + begin + j := 1; + { move down mask } + for maskcount := 1 to EchelonCols do + if (mask [maskcount] = minus999) then + begin + tmpNullVectors[maskcount, VectorCounter] := -Echelon[j, i]; + inc (j); + end; + + { STEP 4 } + { zero all -888 (free) entries } + for j := 1 to EchelonCols do + if tmpNullVectors[j, VectorCounter] = minus888 then + tmpNullVectors[j, VectorCounter] := 0.0; + + { STEP 2 AND 3 } + { mark free variable } + tmpNullVectors[i, VectorCounter] := 1.0; + VectorCounter := VectorCounter + 1; + end; + inc (i); + until i > EchelonCols; + end + else + begin + BasisSize := 0; + NullVectors := Nil; + end; + finally + if BasisSize > 0 then + begin + NullVectors := TMatrix.Create (Self.c, BasisSize); + for i := 1 to Self.c do + for j := 1 to BasisSize do + NullVectors[i,j] := tmpNullVectors[i,j]; + end; + mask.free; + tmpNullVectors.free; + end; +end; + + +function sign (a, b : TMatElement) : TMatElement; +begin + if b >= 0.0 then + result := abs (a) + else + result := -abs(a); +end; + + +function max (a, b : TMatElement) : TMatElement; +begin + if a > b then + result := a + else + result := b; +end; + + +{ Compute sqrt (a^2 + b^2) using numerically more stable method. If x = sqrt(a^2 + b^2), +then, x/a^2 = 1/a^2 sqrt (a^2 + b^2), mult both sides by sqrt(..), so +x/a^2 * sqrt (a^2 + b^2) = 1/a^2 (a^2 + b^2) or +x/a^2 * sqrt (a^2 + b^2) = 1 + (b/a)^2 but on left side 1/a^2 sqrt(a^2 + b^2) equals +x/a^2, therefore x * x/a^2 = 1 + (b/a) ^2, take square roots on both side yields: +x/a := sqrt (1+(b/a)^2), or FINALLY: x := a sqrt (1 + (b/a)^2) } + +function pythag (a, b : TMatElement) : TMatElement; +var at, bt, ct : TMatElement; +begin + result := sqrt (a*a + b*b); + exit; + at := abs (a); bt := abs (b); + if at > bt then + begin + ct := bt/at; + result := at*sqrt (1 + ct*ct); + end + else + begin + if bt > 0 then + begin + ct := at/bt; + result := bt*sqrt (1 + ct*ct); + end + else + result := 0.0; + end; +end; + + function MyAbs (x : TMatElement) : TMatElement; + begin + if x < 0.0 then x := -x; + result := x; + end; + + +{procedure TMatrix.svd2 (var u : TMatrix; var w : TVector; var v : TMatrix);} +procedure TMatrix.svd2 (var u : TMatrix; var w : TVector; var v : TMatrix); +LABEL 1,2,3; +CONST + nmax=100; +VAR + n, m1, nm, l1, k, j, jj, its, i : integer; + z, y, x, scale, s, h, g, f, cc, anorm : real; + rv1 : TVector; //Aug : TMatrix; + AugMatrix : boolean; + + function sign(a,b: TMatElement): TMatElement; + begin + if (b >= 0.0) then sign := abs(a) else sign := -abs(a) + end; + + function max(a,b: TMatElement): TMatElement; + begin + if (a > b) then max := a else max := b + end; + +begin + m1 := r; n := c; AugMatrix := false; + (*if m < n then + begin + { More parameters than data ! Change structure of Self by augmenting + Self with additional rows (entries set to zero) so that m = n, don't change m or n though } + {Aug := TMatrix.Create (n, n); Aug.zero; + try + for i := 1 to m do + for j := 1 to n do + Aug[i,j] := Self[i,j]; + u.FreeSpace; u.SetSize (n, n); u.Copy (Aug); + AugMatrix := true; + finally + Aug.free; + end; + end + else*) + u.Copy(Self); { Work on U, don't destroy Self } + + + if AugMatrix then + rv1 := TVector.Create (n) { Make enough room } + else + rv1 := TVector.Create (m1); { Save some space } + g := 0.0; + scale := 0.0; + anorm := 0.0; + FOR i := 1 TO n DO BEGIN + l1 := i+1; + rv1[i] := scale*g; + g := 0.0; + s := 0.0; + scale := 0.0; + IF (i <= m1) THEN BEGIN + FOR k := i TO m1 DO scale := scale + Myabs(u[k,i]); + IF (Myabs(scale) > 1e-12) THEN BEGIN + {IF (scale <> 0.0) THEN BEGIN} + for k := i to m1 do + begin + u[k,i] := u[k,i]/scale; + s := s + u[k,i]*u[k,i] + end; + f := u[i,i]; + g := -sign(sqrt(s),f); + h := f*g-s; + u[i,i] := f-g; + if (i <> n) then + begin + for j := l1 to n do + begin + s := 0.0; + for k := i to m1 do s := s + u[k,i]*u[k,j]; + f := s/h; + for k := i to m1 do u[k,j] := u[k,j] + f*u[k,i]; + end + end; + for k := i to m1 do u[k,i] := scale*u[k,i] + END + END; + w[i] := scale*g; + g := 0.0; + s := 0.0; + scale := 0.0; + IF ((i <= m1) AND (i <> n)) THEN BEGIN + for k := l1 to n do scale := scale + Myabs(u[i,k]); + if (Myabs(scale) > 1e-12) then begin + {if (scale <> 0.0) then begin} + for k := l1 to n do + begin + u[i,k] := u[i,k]/scale; + s := s + u[i,k]*u[i,k] + end; + f := u[i,l1]; + g := -sign(sqrt(s),f); + h := f*g-s; + u[i,l1] := f-g; + for k := l1 to n do rv1[k] := u[i,k]/h; + if (i <> m1) then + begin + for j := l1 to m1 do + begin + s := 0.0; + for k := l1 to n do s := s + u[j,k]*u[i,k]; + for k := l1 to n do u[j,k] := u[j,k] + s*rv1[k]; + end + end; + for k := l1 to n do u[i,k] := scale*u[i,k]; + END + END; + anorm := max(anorm,(Myabs(w[i]) + Myabs(rv1[i]))) + END; + + FOR i := n DOWNTO 1 DO BEGIN + IF (i < n) THEN BEGIN + if (Myabs(g) > 1e-12) then + {IF (g <> 0.0) THEN} + begin + for j := l1 to n do v[j,i] := (u[i,j]/u[i,l1])/g; + for j := l1 to n do + begin + s := 0.0; + for k := l1 to n do s := s + u[i,k]*v[k,j]; + for k := l1 to n do v[k,j] := v[k,j] + s*v[k,i] + end + end; + for j := l1 to n do + begin + v[i,j] := 0.0; + v[j,i] := 0.0; + end + END; + v[i,i] := 1.0; + g := rv1[i]; + l1 := i + end; + FOR i := n DOWNTO 1 DO BEGIN + l1 := i+1; + g := w[i]; + if (i < n) then for j := l1 to n do u[i,j] := 0.0; + if (Myabs(g) > 1e-12) then + {IF (g <> 0.0) THEN} + begin + g := 1.0/g; + IF (i <> n) THEN + begin + for j := l1 to n do + begin + s := 0.0; + for k := l1 to m1 do s := s + u[k,i]*u[k,j]; + f := (s/u[i,i])*g; + for k := i to m1 do u[k,j] := u[k,j] + f*u[k,i]; + end + end; + for j := i to m1 do u[j,i] := u[j,i]*g; + end else + begin + for j := i to m1 do u[j,i] := 0.0; + end; + u[i,i] := u[i,i]+1.0 + END; + FOR k := n DOWNTO 1 DO BEGIN + FOR its := 1 TO 30 DO BEGIN + for l1 := k downto 1 do + begin + nm := l1-1; + if ((Myabs(rv1[l1]) + anorm) - anorm < 1e-12) then goto 2; + {if ((Myabs(rv1[l]) + anorm) = anorm) then goto 2;} + if ((Myabs(w[nm]) + anorm) - anorm < 1e-12) then goto 1 + {if ((Myabs(w[nm]) + anorm) = anorm) then goto 1} + end; +1: cc := 0.0; + s := 1.0; + for i := l1 to k do + begin + f := s*rv1[i]; + if ((Myabs(f) + anorm) - anorm > 1e-12) then + {if ((Myabs(f)+anorm) <> anorm) then} + begin + g := w[i]; + h := sqrt(f*f+g*g); + w[i] := h; + h := 1.0/h; + cc := (g*h); + s := -(f*h); + for j := 1 to m1 do + begin + y := u[j,nm]; + z := u[j,i]; + u[j,nm] := (y*cc)+(z*s); + u[j,i] := -(y*s)+(z*cc) + end + end + end; +2: z := w[k]; + if (l1 = k) then + begin + if (z < 0.0) then + begin + w[k] := -z; + for j := 1 to n do v[j,k] := -v[j,k]; + end; + GOTO 3 + end; + if (its = 30) then writeln ('no convergence in 30 SVDCMP iterations'); + x := w[l1]; + nm := k-1; + y := w[nm]; + g := rv1[nm]; + h := rv1[k]; + f := ((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y); + g := sqrt(f*f+1.0); + f := ((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x; + cc := 1.0; + s := 1.0; + for j := l1 to nm do + begin + i := j+1; + g := rv1[i]; + y := w[i]; + h := s*g; + g := cc*g; + z := sqrt(f*f+h*h); + rv1[j] := z; + cc := f/z; + s := h/z; + f := (x*cc)+(g*s); + g := -(x*s)+(g*cc); + h := y*s; + y := y*cc; + for jj := 1 to n do + begin + x := v[jj,j]; + z := v[jj,i]; + v[jj,j] := (x*cc)+(z*s); + v[jj,i] := -(x*s)+(z*cc) + end; + z := sqrt(f*f+h*h); + w[j] := z; + if (Myabs(z) > 1e-12) then + {if (z <> 0.0) then} + begin + z := 1.0/z; + cc := f*z; + s := h*z + end; + f := (cc*g)+(s*y); + x := -(s*g)+(cc*y); + for jj := 1 to m1 do + begin + y := u[jj,j]; + z := u[jj,i]; + u[jj,j] := (y*cc)+(z*s); + u[jj,i] := -(y*s)+(z*cc) + end + end; + rv1[l1] := 0.0; + rv1[k] := f; + w[k] := x + END; +3: END + + +END; + + +{ Perform a Singular Value Decompostion on self, returning u, w, and v, modified +from Numerical Recipes and Forsythe et al 1977, Computer methods for Math Calc } +procedure TMatrix.svd (var u : TMatrix; var w : TVector; var v : TMatrix); +label 3; +var i, j, k, l1, n, m1, its, flag, nm, jj : integer; rv1 : TVector; + scale, g, h, f, anorm, s, cc, x, y, z : TMatElement; Aug : TMatrix; + AugMatrix : boolean; +begin + m1:= r; n := c; AugMatrix := false; + if m1 < n then + begin + { More parameters than data ! Change structure of Self by augmenting + Self with additional rows (entries set to zero) so that m = n, don't change m or n though } + Aug := TMatrix.Create (n, n); Aug.zero; + try + for i := 1 to m1 do + for j := 1 to n do + Aug[i,j] := Self[i,j]; + u.FreeSpace; u.SetSize (n, n); u.Copy (Aug); + AugMatrix := true; + finally + Aug.free; + end; + end + else + u.Copy(Self); { Work on U, don't destroy Self } + + scale := 0.0; g := 0.0; anorm := 0.0; + if AugMatrix then + rv1 := TVector.Create (n) { Make enough room } + else + rv1 := TVector.Create (m1); { Save some space } + + try + for i := 1 to n do + begin + l1 := i + 1; + rv1[i] := scale * g; + g := 0.0; s := 0.0; scale := 0.0; + if i <= m1 then + begin + for k := i to m1 do scale := scale + abs (u[k,i]); + if scale <> 0.0 then + begin + for k := i to m1 do + begin + u[k, i] := u[k, i] / scale; + s := s + u[k,i]*u[k,i]; + end; + f := u[i,i]; + g := -sign (sqrt (s), f); + h := f*g - s; + u[i,i] := f - g; + if i <> n then + begin + for j := l1 to n do + begin + s := 0.0; + for k := i to m1 do s := s + u[k,i]*u[k,j]; + f := s/h; + for k := i to m1 do u[k,j] := u[k,j] + f*u[k,i]; + end; + end; + for k := i to m1 do u[k,i] := u[k,i] * scale; + end; + end; + w[i] := scale * g; + g := 0.0; s := 0.0; scale := 0.0; + if (i <= m1) and (i <> n) then + begin + for k := l1 to n do scale := scale + abs (u[i,k]); + if scale <> 0.0 then + begin + for k := l1 to n do + begin + u[i,k] := u[i,k] / scale; + s := s + u[i,k]*u[i,k]; + end; + f := u[i,l1]; + g := -sign(sqrt (s), f); + h := f*g - s; + u[i,l1] := f - g; + for k := l1 to n do rv1[k] := u[i,k]/h; + if i <> m1 then + begin + for j := l1 to m1 do + begin + s := 0.0; + for k := l1 to n do s := s + u[j,k]*u[i,k]; + for k := l1 to n do u[j,k] := u[j,k] + s*rv1[k]; + end; + end; + for k := l1 to n do u[i,k] := u[i,k] * scale; + end; + end; + anorm := max (anorm, abs(w[i]) + abs(rv1[i])); + end; + + { ------------------------------------------ } + { Accumulation of right-hand transformations } + for i := n downto 1 do + begin + if i < n then + begin + if g <> 0.0 then + begin + for j := l1 to n do v[j,i] := (u[i,j]/u[i,l1])/g; + for j := l1 to n do + begin + s := 0.0; + for k := l1 to n do s := s + u[i,k]*v[k,j]; + for k := l1 to n do v[k,j] := v[k,j] + s*v[k,i]; + end; + end; + for j := l1 to n do begin v[i,j] := 0.0; v[j,i] := 0.0; end; + end; + v[i,i] := 1.0; + g := rv1[i]; + l1 := i; + end; + + { ------------------------------------------ } + { Accumulation of left-hand transformations } + for i := n downto 1 do + begin + l1 := i + 1; + g := w[i]; + if i < n then for j := l1 to n do u[i,j] := 0.0; + if g <> 0.0 then + begin + g := 1.0/g; + if i <> n then + begin + for j := l1 to n do + begin + s := 0.0; + for k := l1 to m1 do s := s + u[k,i]*u[k,j]; + f := (s/u[i,i])*g; + for k := i to m1 do u[k,j] := u[k,j] + f*u[k,i]; + end; + end; + for j := i to m1 do u[j,i] := u[j,i] * g; + end + else + begin + for j := i to m1 do u[j,i] := 0.0; + end; + u[i,i] := u[i,i] + 1.0; + end; + + { --------------------------------------------- } + { Diagonalization of the bidiagonal form } + for k := n downto 1 do + begin + for its := 1 to 30 do + begin + flag := 1; + for l1 := k downto 1 do + begin + nm := l1 - 1; + if abs (rv1[l1] + anorm) = anorm then + begin + flag := 0; + break; + end; + if abs (w[nm] + anorm) = anorm then break; + end; + if flag <> 0 then + begin + cc := 0.0; s := 1.0; + for i := l1 to k do + begin + f := s * rv1[i]; + if (abs (f) + anorm) <> anorm then + begin + g := w[i]; + h := pythag (f, g); + w[i] := h; + h := 1.0/h; + cc := g*h; + s := -f*h; + for j := 1 to m1 do + begin + y := u[j,nm]; + z := u[j, i]; + u[j,nm] := y*cc + z*s; + u[j,i] := z*cc - y*s; + end; + end; + end; + end; + z := w[k]; + if l1 = k then + begin + if z < 0.0 then + begin + w[k] := -z; + for j := 1 to n do v[j,k] := -v[j,k]; + end; + {break;} goto 3; + end; + if (its = 30) then raise Exception.Create ('Exceeded iterations in SVD routine'); + x := w[l1]; + nm := k - 1; + y := w[nm]; g := rv1[nm]; + h := rv1[k]; + f := ((y - z)*(y + z) + (g - h)*(g + h))/(2.0*h*y); + g := pythag (f, 1.0); + f := ((x - z) * (x + z) + h*((y/(f + sign(g, f))) - h))/x; + + cc := 1.0; s := 1.0; + for j := l1 to nm do + begin + i := j + 1; + g := rv1[i]; + y := w[i]; h := s*g; + g := cc*g; + z := pythag (f, h); + rv1[j] := z; + cc := f/z; s := h/z; + f := x*cc + g*s; g := g*cc - x*s; + h := y*s; + y := y*cc; + for jj := 1 to n do + begin + x := v[jj,j]; z := v[jj,i]; + v[jj,j] := x*cc + z*s; + v[jj,i] := z*cc - x*s; + end; + z := pythag (f, h); + w[j] := z; + if z <> 0 then + begin + z := 1.0/z; cc := f*z; s := h*z; + end; + f := (cc*g) + (s*y); + x := (cc*y) - (s*g); + for jj := 1 to m1 do + begin + y := u[jj,j]; z := u[jj,i]; + u[jj,j] := y*cc + z*s; + u[jj,i] := z*cc - y*s; + end; + end; + rv1[l1] := 0.0; + rv1[k] := f; + w[k] := x; +3: end; + end; + finally + rv1.free; + end; + + if AugMatrix then + begin + { This means that originally m < n, therefore u has some junk rows, remove them here } + Aug := TMatrix.Create (m1, n); + try + for i := 1 to m1 do + for j := 1 to n do + Aug[i,j] := u[i,j]; + u.FreeSpace; u.SetSize (m1, n); u.Copy (Aug); + finally + Aug.free; + end; + end; +end; + + + +{ Call this after having called svd, computes x = V [diag (1/wj)]. U^t.b } +procedure TMatrix.svdSolve (var u : TMatrix; var w : TVector; var v : TMatrix; + b : TVector; var x : TVector); +var j, i, n, m1 : integer; s: TMatElement; tmp: TVector; +begin + m1 := u.r; n := u.c; + tmp := TVector.Create (u.c); + try + { Compute diag (1/wj) . U^t . b } + for j := 1 to n do + begin + s := 0.0; + if (w[j] <> 0.0) then + begin + for i := 1 to m1 do s := s + u[i,j]*b[i]; + s := s/w[j] + end; + tmp[j] := s + end; + { ...mult by V to get solution vector x } + for i := 1 to n do + begin + s := 0.0; + for j := 1 to w.size do s := s + v[i,j]*tmp[j]; + x[i] := s + end; + finally + tmp.free; + end; +end; + + +{ Solves the equation: (A.a - b)^2 = 0 for a. Where, A is the 'design matrix', +Aij = Xj(xi)/sigi, where Xj is the value of the jth basis function; b is the set +of weighted observed y values, b = yi/sigi; and a is the set of fitting coefficients +for the basis functions. Thus A.a - b expresses predicted - observed } + +{ BasisProc is a procedure which must return in an array the values for the +basis functions at a particular value of xi, i.e it computes, Xj(xi) } + +function TMatrix.svdfit (x, y, yerr : TVector; var fit : TVector; + var u, v : TMatrix; var w : TVector; funcs : BasisProc): TMatElement; +const + tol=1.0e-5; +var + i, j : integer; wmax, weight, thresh, sum: TMatElement; + BasisVal, b : TVector; A : TMatrix; +begin + BasisVal := TVector.Create (fit.size); b := TVector.Create (x.size); + A := TMatrix.Create (x.size, fit.size); + try + { Form the A matrix } + for i := 1 to x.size do + begin + funcs(x[i], BasisVal); + weight := 1.0/yerr[i]; + for j := 1 to fit.size do A[i,j] := BasisVal[j]*weight; + b[i] := y[i]*weight + end; + A.svd (u, w, v); + + wmax := 0.0; + for j := 1 to fit.size do if (w[j] > wmax) then wmax := w[j]; + thresh := tol*wmax; + for j := 1 to fit.size do if (w[j] < thresh) then w[j] := 0.0; + + svdSolve (u, w, v, b, fit); + + result := 0.0; { chisqr set to zero ready to accumulate } + for i := 1 to x.size do + begin + funcs(x[i], BasisVal); + sum := 0.0; + for j := 1 to fit.size do sum := sum + fit[j]*BasisVal[j]; + result := result + sqr((y[i]-sum)/yerr[i]); { Accumulate chisqr } + end; + finally + BasisVal.free; A.free; b.free; + end; +end; + + +procedure TMatrix.svdCovar (v : TMatrix; w : TVector; alpha : TMatrix); +var i, j, k : integer; wti : TVector; sum : TMatElement; +begin + wti := TVector.Create (w.size); + try + for i := 1 to w.size do + begin + wti[i] := 0.0; + if w[i] > 0.0 then wti[i] := 1.0/(w[i]*w[i]); + end; + for i := 1 to w.size do + begin + for j := 1 to i do + begin + sum := 0.0; + for k := 1 to w.size do sum := sum + v[i,k]*v[j,k]*wti[k]; + alpha[j,i] := sum; alpha[i,j] := alpha[j,i]; + end; + end; + finally + wti.free; + end; +end; + + +procedure TMatrix.eliminate_cms (S, Tk1 : TMatrix; var cr, N : integer); (* eliminating conserved moieties *) +var + i,j,x,y,crc,old_cr : byte; +begin + x := 0; cr := 0; (* cr - conservation relations *) + for i := 1 to N do + begin + old_cr := cr; + for j := i+1 to N do + begin + crc := 0; (* crc - cr counter *) + // S.c = number of reactions + for y := 1 to S.c do crc := crc + trunc (abs(S[i,y]+S[j,y])); + if crc = 0 then cr := cr+1; + end; + if cr = old_cr then + begin + x := x+1; + for y := 1 to S.c do + Tk1[x,y] := S[i,y]; + end; + end; +end; + + +procedure TMatrix.ElementaryModes (D : TVectori; var mf, mb, C1, k : integer; Tk : TMatrix); +var i, j, cr, N, k1 : integer; Tk1 : TMatrix; hlpRow : TVector; +begin + N := Self.r; + Tk1 := TMatrix.Create (Self.r, Self.c); + hlpRow := TVector.Create (Self.c); + try + {eliminate_cms; (* also transscribing S into Tk1 *) + N := N-cr; + + for i := 1 to R do + begin + for j := 1 to N do Tk[i,j] := Tk1[j,i]; (* transposing matrix *) + for j:=N+1 to N+R do + if i=j-N then + Tk[i,j]:=1 (* appending.. *) + else Tk[i,j]:=0; (*..unity matrix*) + end; + (* (preliminary) fund. rows to the top *) + i := 0; (* splitting indices into F/B *) + for j := 1 TO R DO + begin + if (D[j] <> 0) then + begin + i := i+1; + hlprow := Tk[i]; + Tk[i] := Tk[j]; + Tk[j] := hlprow; + end; + end; + mf := i; (* no. of fundamental rows *) + mb := R-mf;} + + + + eliminate_cms (Self, Tk1, cr, N); (* also transscribing S into Tk1 *) + N := N-cr; + + for i := 1 to Self.c do + begin + for j := 1 to N do Tk[i,j] := Tk1[j,i]; (* transposing matrix *) + for j := N+1 to N+Self.c do + if i=j-N then + Tk[i,j] := 1 (* appending.. *) + else Tk[i,j] := 0; (*..unity matrix*) + end; + (* (preliminary) fund. rows to the top *) + i := 0; (* splitting indices into F/B *) + for j := 1 TO Self.c DO + begin + if (D[j] <> 0) then + begin + i := i+1; + for k1 := 1 to Self.c do hlprow[k1] := Tk[i,k1]; + for k1 := 1 to Self.c do Tk[i,k1] := Tk[j,k1]; + for k1 := 1 to Self.c do Tk[j,k1] := hlprow[k1]; + //hlprow := Tk[i]; + //Tk[i] := Tk[j]; + //Tk[j] := hlprow; + end; + end; + mf := i; (* no. of fundamental rows *) + mb := Self.c-mf; (* no. of basis rows *) + + Tableau (N, Self.c, mf, mb, C1, k, Tk, Tk1); + finally + hlpRow.Free; + Tk1.Free; + end; +end; + + +class function TMatrix.grecodiv(P, Rest: integer) : integer; +var + old_Rest : integer; +begin + grecodiv := 1; + if (Rest*P <> 0) then + begin + if ABS(P) < ABS(Rest) then + begin + old_Rest := Rest; + Rest := P; + P := old_Rest; (* swap P 'n' R *) + end; + + repeat (* Euclidean Algorithm: *) + old_Rest := Rest; + Rest := P mod old_Rest; + P := old_Rest; + until (Rest = 0); + grecodiv := P; + end + else + if (P = 0) then + begin + if (Rest = 0) then grecodiv := 1 else grecodiv := Rest; + end + else grecodiv := P; +end; + + +class function TMatrix.grecodiv_of_vector (N, R1 : integer; vec : TVector) : integer; +var + x : byte; + coeff : integer; +begin + coeff := trunc (vec[1]); + for x := 2 to (N+R1) do + begin + if (vec[x] <> 0) then coeff := grecodiv(trunc (vec[x]), coeff); + end; + grecodiv_of_vector := coeff; +end; + + + + + +class procedure TMatrix.Tableau (N, R1 : integer; var mf, mb, C1, k : integer; Tk, Tk1 : TMatrix); +var + i,j,k1,x,xa,y,m1 : integer; + cf,dir,ifrom,iend : integer; + index,bool,allow_comb : boolean; + l1 : integer; + vec : TVector; +begin + C1 := R1; (* C: number of rows of the tableau *) + k := 0; (* k: tableau index *) + vec := TVector.Create (Tk1.c); + + repeat + + //output; (* HELPFUL MONITORING*) + //write(' k = ');writeln(k);writeln('cf=',cf); (* OF TABLEAU STEPS *) + {write(' Press <ENTER> to continue.'); readln;} + + l1 := 1; (* l: row index in the tableau k+1 *) + cf := 0; (* counter for f-rows in the tableau k+1*) + for dir :=1 to 2 do + BEGIN + IF dir=1 THEN + BEGIN + ifrom:=1; iend:=mf; + END + ELSE + BEGIN + ifrom:=mf+1; iend:=c1 + END; + FOR i := ifrom TO iend DO + BEGIN + IF Tk[i,k+1] = 0 THEN (* copying rows that *) + BEGIN (* have a zero element *) + for k1 := 1 to Tk1.c do + Tk1[l1, k1] := Tk[i, k1]; (* already *) + //Tk1[l] := Tk[i]; (* already *) + l1 := l1+1; + IF i <= mf THEN cf := cf+1; + END + END; + FOR i:=ifrom TO iend DO + BEGIN + IF Tk[i,k+1]<>0 THEN + BEGIN + FOR j := i+1 TO C1 DO + BEGIN + IF Tk[j,k+1] <> 0 THEN + BEGIN + IF Tk[i,k+1]*Tk[j,k+1] > 0 THEN + BEGIN (* not for f-rows with *) + IF j <= mf THEN + allow_comb := false (* same signum *) + ELSE + BEGIN + FOR y := 1 TO N+R1 DO Tk[j,y] := -1 * Tk[j,y]; (* invert b-row *) + allow_comb := true; + END; + END + ELSE allow_comb := true; + IF allow_comb THEN + BEGIN + index:=true; (* first simplicity (S) test: *) + IF (l1>1) THEN + BEGIN + IF dir=1 THEN x:=0 + ELSE x:=cf; + WHILE (x<l1-1) AND (INDEX) DO + BEGIN + x:=x+1; + y:=n; + bool:=true; + REPEAT + y:=y+1; + IF ((Tk[i,y] = 0) and (Tk[j,y] = 0)) THEN + IF Tk1[x,y] <> Tk[i,y] THEN bool:=false; + UNTIL (y=n+r1)or NOT bool; + IF (y=n+r1)and bool THEN index:=false; + END; + END; + IF index THEN + BEGIN (* combine rows *) + FOR y:=1 TO R1+N DO + Tk1[l1,y]:=abs(Tk[i,k+1])*Tk[j,y]+abs(Tk[j,k+1])*Tk[i,y]; + + for k1 := 1 to Tk1.c do + vec[i] := Tk1[l1,k1]; + + m1:= Grecodiv_of_vector(N, R1, vec) ; + //m:= Grecodiv_of_vector(Tk1[l]) ; + IF (ABS(m1)<>1) AND (m1<>0) THEN FOR y:=1 to R1+N DO + Tk1[l1,y]:= trunc (Tk1[l1,y]) DIV ABS(m1); + l1:= l1+1; + IF i <= mf THEN cf := cf+1; + (* second simplicity (S) test: *) + IF dir=1 THEN x:=0 + ELSE x:=cf; + bool:=true; + WHILE (X<L1-2) AND (bool=true) DO + BEGIN + x:=x+1; + y:=n; + bool:=false; + REPEAT + y:=y+1; + IF Tk1[x,y]=0 THEN + IF (Tk1[x,y]<>Tk[i,y]) OR (Tk1[x,y]<>Tk[j,y]) + THEN bool:=true; + UNTIL (y=n+r1)or bool; + IF (y=n+r1)and NOT(bool) THEN + BEGIN + {writeln('Jetzt hat folgende Zeile:'); + FOR Y:=n+1 to n+r DO + write(Tk1[x,y]:3); + writeln; writeln('x=',x); + writeln; writeln('l-1=',l-1); + writeln('verloren gegen folgende Zeilen:'); + FOR Y:=n+1 to n+r DO + write(Tk[i,y]:3); + writeln; writeln('i=',i); + FOR Y:=n+1 to n+r DO + write(Tk[j,y]:3); + writeln; writeln('j=',j); writeln; + writeln(x,'+1te Zeile:'); + FOR Y:=n+1 to n+r DO + write(Tk1[x+1,y]:3); + writeln;} + FOR xa:=x TO l1-2 DO + BEGIN + FOR y:=1 TO n+r1 DO + Tk1[xa,y]:=Tk1[xa+1,y]; + END; + l1:=l1-1; + IF x<=cf THEN cf:=cf-1; + END; + END; + END; + END; + END; + END; + END; + END; + END; + + C1 := l1-1; (* new no. of rows *) + mf := cf; + mb := C1-mf; + + k := k+1; (* next tableau *) + for i := 1 to C1 do + begin + for k1 := 1 to Tk.c do + Tk[i, k1] := Tk1[i, k1]; (* restarting with Tk1 *) + end; + //for i := 1 to C do Tk[i] := Tk1[i]; (* restarting with Tk1 *) + + until (k = N) or ((mb = 0) and (mf = 0)); + + //if ((mb = 0) and (mf = 0)) then + // writeln(' There exist neither irreversible nor reversible flux modes.') + //else + // output; + vec.Free; +end; + + +// Evaluate conservation relations, uses the algorthim: tr(ns(tr(m))) +procedure TMatrix.Conserve(st : TMatrix); +var tmp, ns, echelon : TMatrix; b, r1 : integer; +begin + tmp := TMatrix.Create (st.c, st.r); + ns := TMatrix.Create (1,1); + echelon := TMatrix.Create (1,1); + try + tmp.Transpose (st); + tmp.NullSpace (ns, b, Echelon, r1); + Self.SetSize (ns.c, ns.r); + Self.Transpose (ns); + finally + ns.free; + echelon.free; + tmp.free; + end; +end; + + +end. \ No newline at end of file diff --git a/npm/Mat.ppu b/npm/Mat.ppu new file mode 100644 index 0000000..58b5b21 Binary files /dev/null and b/npm/Mat.ppu differ diff --git a/npm/MeanFLU.nii.gz b/npm/MeanFLU.nii.gz new file mode 100755 index 0000000..f654e0a Binary files /dev/null and b/npm/MeanFLU.nii.gz differ diff --git a/npm/Notes.txt b/npm/Notes.txt new file mode 100755 index 0000000..59d7218 --- /dev/null +++ b/npm/Notes.txt @@ -0,0 +1,52 @@ +Chris Rorden's 32-bit NPM: 28 August 2013 32bit; Threads used = 4 plankSize: 512mb +Single Linear Regression [Weighted Least Squares] +Mask = /Users/rorden/Downloads/dazhou_npm_glitch/BinaryLesionMask.nii +Total voxels = 510340 +Number of observations = 35 +Image,FLU +/Users/rorden/Downloads/dazhou_npm_glitch/zwrTW_T2.nii,0 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrRH_T2.nii,5 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrRW_T2.nii,9 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrDE_T2.nii,4 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrJR_T2.nii,5 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrFJ_T2.nii,0 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrAC_T2.nii,7 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrMJ_T2.nii,4 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrAS_T2.nii,8 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrSH_T2.nii,1 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrDV_T2.nii,1 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrLO_T2.nii,10 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrMB_T2.nii,9 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrAS2_T2.nii,7 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrJR2_T2.nii,9 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrSF_T2.nii,1 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrTC_T2.nii,7 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrTR2_T2.nii,2 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrGK2_T2.nii,8 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrMH_T2.nii,1 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrTM_T2.nii,3 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrRS_T2.nii,9 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrAH_T2.nii,4 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrMB2_T2.nii,6 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrJM2_T2.nii,2 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrRC2_T2.nii,7 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrLM_T2.nii,4 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrMK_T2.nii,1 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrPC_T2.nii,7 +/Users/rorden/Downloads/dazhou_npm_glitch/zwr125_T2.nii,4 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrJE_T2.nii,9 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrJY_T2.nii,4 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrJA_T2.nii,9 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrMW_T2.nii,5 +/Users/rorden/Downloads/dazhou_npm_glitch/zwrML_T2.nii,9 +Analysis began = 2013-22-08 13:22:21 +Mask has voxels from 4080..468678 +Memory planks = 0.121153637537577 +Max voxels per Plank = 3834792 +Computing plank = 1 +Voxels tested = 75335 +75335 test Std Bonferroni FWE Z 0.050=4.836, 0.025=4.972, 0.01=5.146 +wlsFLU Range -5.551...3.209 +wlsFLU +FDR Z 0.050=9.20000000, 0.01=9.20000000 +wlsFLU -FDR Z 0.050=-2.31827721, 0.01=-3.42041674 +Analysis finished = 2013-22-08 13:22:31 \ No newline at end of file diff --git a/npm/ReadFloat.dfm b/npm/ReadFloat.dfm new file mode 100755 index 0000000..4c22c67 Binary files /dev/null and b/npm/ReadFloat.dfm differ diff --git a/npm/ReadFloat.pas b/npm/ReadFloat.pas new file mode 100755 index 0000000..316fe92 --- /dev/null +++ b/npm/ReadFloat.pas @@ -0,0 +1,45 @@ +unit ReadFloat; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin; + +type + TReadFloatForm = class(TForm) + OKBtn: TButton; + ReadFloatLabel: TLabel; + ReadFloatEdit: TRxSpinEdit; + function GetFloat(lStr: string; lMin,lDefault,lMax: double): double; + + procedure OKBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + ReadFloatForm: TReadFloatForm; + +implementation + +{$R *.DFM} + function TReadFloatForm.GetFloat(lStr: string; lMin,lDefault,lMax: double): double; + begin + //result := lDefault; + ReadFloatLabel.caption := lStr+' ['+floattostr(lMin)+'..'+floattostr(lMax)+']'; + ReadFloatEdit.MinValue := lMin; + ReadFloatEdit.MaxValue := lMax; + ReadFloatEdit.Value := lDefault; + ReadFloatForm.ShowModal; + result := ReadFloatEdit.Value; + end; + +procedure TReadFloatForm.OKBtnClick(Sender: TObject); +begin + ReadFloatForm.ModalResult := mrOK; +end; + +end. diff --git a/npm/ReadInt.dfm b/npm/ReadInt.dfm new file mode 100755 index 0000000..6dc59bd Binary files /dev/null and b/npm/ReadInt.dfm differ diff --git a/npm/ReadInt.lfm b/npm/ReadInt.lfm new file mode 100755 index 0000000..110f4d6 --- /dev/null +++ b/npm/ReadInt.lfm @@ -0,0 +1,48 @@ +object ReadIntForm: TReadIntForm + Left = 306 + Height = 80 + Top = 554 + Width = 469 + HorzScrollBar.Page = 468 + VertScrollBar.Page = 79 + ActiveControl = ReadIntEdit + BorderStyle = bsDialog + Caption = 'Integer required' + ClientHeight = 80 + ClientWidth = 469 + Constraints.MaxHeight = 80 + Constraints.MaxWidth = 469 + Constraints.MinHeight = 80 + Constraints.MinWidth = 469 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '0.9.28.2' + object ReadIntLabel: TLabel + Left = 16 + Height = 14 + Top = 12 + Width = 336 + Alignment = taRightJustify + AutoSize = False + Caption = 'Enter a number' + ParentColor = False + end + object ReadIntEdit: TSpinEdit + Left = 360 + Height = 27 + Top = 12 + Width = 93 + MaxValue = 0 + TabOrder = 0 + end + object OKBtn: TButton + Left = 368 + Height = 25 + Top = 44 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + OnClick = OKBtnClick + TabOrder = 1 + end +end diff --git a/npm/ReadInt.lrs b/npm/ReadInt.lrs new file mode 100755 index 0000000..a7478ca --- /dev/null +++ b/npm/ReadInt.lrs @@ -0,0 +1,16 @@ +LazarusResources.Add('TReadIntForm','FORMDATA',[ + 'TPF0'#12'TReadIntForm'#11'ReadIntForm'#4'Left'#3'2'#1#6'Height'#2'P'#3'Top'#3 + +'*'#2#5'Width'#3#213#1#18'HorzScrollBar.Page'#3#212#1#18'VertScrollBar.Page' + +#2'O'#13'ActiveControl'#7#11'ReadIntEdit'#11'BorderStyle'#7#8'bsDialog'#7'Ca' + +'ption'#6#16'Integer required'#12'ClientHeight'#2'P'#11'ClientWidth'#3#213#1 + +#21'Constraints.MaxHeight'#2'P'#20'Constraints.MaxWidth'#3#213#1#21'Constrai' + +'nts.MinHeight'#2'P'#20'Constraints.MinWidth'#3#213#1#8'OnCreate'#7#10'FormC' + +'reate'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#8'0.9.28.2'#0#6'TL' + +'abel'#12'ReadIntLabel'#4'Left'#2#16#6'Height'#2#14#3'Top'#2#12#5'Width'#3'P' + +#1#9'Alignment'#7#14'taRightJustify'#8'AutoSize'#8#7'Caption'#6#14'Enter a n' + +'umber'#11'ParentColor'#8#0#0#9'TSpinEdit'#11'ReadIntEdit'#4'Left'#3'h'#1#6 + +'Height'#2#27#3'Top'#2#12#5'Width'#2']'#8'MaxValue'#2#0#8'TabOrder'#2#0#0#0#7 + +'TButton'#5'OKBtn'#4'Left'#3'p'#1#6'Height'#2#25#3'Top'#2','#5'Width'#2'K'#25 + +'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#2'OK'#7'OnClick'#7#10'OKBtnClic' + +'k'#8'TabOrder'#2#1#0#0#0 +]); diff --git a/npm/ReadInt.o b/npm/ReadInt.o new file mode 100644 index 0000000..31286e7 Binary files /dev/null and b/npm/ReadInt.o differ diff --git a/npm/ReadInt.pas b/npm/ReadInt.pas new file mode 100755 index 0000000..98813e4 --- /dev/null +++ b/npm/ReadInt.pas @@ -0,0 +1,60 @@ +unit ReadInt; + +interface + +uses + {$IFDEF FPC} LResources,{$ENDIF} + Buttons{only Lazarus?},SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Spin; + +type + TReadIntForm = class(TForm) + ReadIntEdit: TSpinEdit; + ReadIntLabel: TLabel; + OKBtn: TButton; + function GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + procedure OKBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + public + + { Public declarations } + end; + +var + ReadIntForm: TReadIntForm; + +implementation + + + {$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + function TReadIntForm.GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + begin + //result := lDefault; + ReadIntLabel.caption := lStr+' ['+inttostr(lMin)+'..'+inttostr(lMax)+']'; + ReadIntEdit.MinValue := lMin; + ReadIntEdit.MaxValue := lMax; + ReadIntEdit.Value := lDefault; + ReadIntForm.ShowModal; + result := ReadIntEdit.Value; + end; + +procedure TReadIntForm.OKBtnClick(Sender: TObject); +begin + ReadIntForm.ModalResult := mrOK; +end; + + +procedure TReadIntForm.FormCreate(Sender: TObject); +begin +end; + +{$IFDEF FPC} +initialization + {$I ReadInt.lrs} +{$ENDIF} + +end. diff --git a/npm/ReadInt.ppu b/npm/ReadInt.ppu new file mode 100644 index 0000000..4762d0b Binary files /dev/null and b/npm/ReadInt.ppu differ diff --git a/npm/StatThds.o b/npm/StatThds.o new file mode 100644 index 0000000..5ba4d9e Binary files /dev/null and b/npm/StatThds.o differ diff --git a/npm/StatThds.pas b/npm/StatThds.pas new file mode 100755 index 0000000..e0bd66b --- /dev/null +++ b/npm/StatThds.pas @@ -0,0 +1,578 @@ +unit StatThds; + {$Include ..\common\isgui.inc} +interface + +uses + {$IFDEF GUI} ComCtrls,{$ENDIF} + //ComCtrls, Graphics, ExtCtrls, + Classes, define_types,stats,StatThdsUtil,Brunner,lesion_pattern, dialogsx; + + + +type + + TStatThread = class(TThread) + private + lBarX: TProgressBar; + lttestx,lBMx: boolean; + lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lnGroup1x : integer; + lMaskImgx,lPlankImgx,lOutImgMnx,lOutImgBMx,lOutImgTx,lSymptomRAx: SingleP; + procedure DoVisualSwap; + protected + procedure Execute; override; + //procedure Terminate; + procedure VisualProg(lPos: Integer); + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); virtual; abstract; + public + constructor Create(lBar: TProgressBar;lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); + end; + +{ VBM - two groups } + + TNNStat = class(TStatThread) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + + TPairedTStat = class(TStatThread) + protected + procedure Analyze(lunused1,lunused2: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + { Lesion - image reveals value } + + TLesionStat = class(TStatThread) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + TLesionBinomial = class(TStatThread) + protected + procedure Analyze(lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); override; + end; + +implementation +uses unpm; +//uses Stat; + + +{ TSortThread } + +(*tpIdle The thread executes only when the system is idle. The system will not interrupt other threads to execute a thread with tpIdle priority. +tpLowest The thread's priority is two points below normal. +tpLower The thread's priority is one point below normal. +tpNormal The thread has normal priority. +tpHigher The thread's priority is one point above normal. +tpHighest The thread's priority is two points above normal. +tpTimeCritical*) + +Const Two32 = 4294967296.0 ; +function GenRandThreaded(lRange: integer; var lRandSeed:comp): integer; +//normal random function does not work well when threaded - randseed is changed by each thread +const lFactor = $08088405 ; lTerm = 1 ; +type lT = array [0..1] of longint ; +var + lX: extended; +begin + lRandSeed := lRandSeed*lFactor + lTerm; + lT(lRandSeed)[1] := 0 ; // < May'04 was: RS := RS - Trunc(RS/Two32)*Two32 ; + lX := lRandSeed/Two32 ; + result := trunc((lRange)*lX); +end; + +procedure GenPermuteThreaded (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: double; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteThreaded (lttest,lBM: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lttest then begin + TStat2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lBM then begin + BMTest (lnSubj, lnGroup0, lRanOrder,lOutT); + if lOutT > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lOutT; + if lOutT < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lOutT; + end; //compute BM + end; + freemem(lRanOrderp); +end; + +procedure StatPermuteBinomialThreaded (lChi2,lLieber: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lChi2 then begin + Chi2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lLieber then begin + Liebermeister2 (lnSubj, lnGroup0, lRanOrder,lOutT); + if lOutT > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lOutT; + if lOutT < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lOutT; + end; //compute BM + end; + freemem(lRanOrderp); +end; + + +procedure TStatThread.DoVisualSwap; +begin + {$IFDEF GUI} + lBarX.Position := lBarPosX; + {$ENDIF} +end; + +procedure TStatThread.VisualProg(lPos: Integer); +begin + {$IFDEF GUI} + lBarPosX := lPos; + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} + {$ENDIF} +end; + +constructor TStatThread.Create(lBar: TProgressBar; lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +begin + lBarX := lBar; + lttestx := lttest; + lBMx:= lBM; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lnGroup1x := lnGroup1; + lMaskImgx := lMaskImg; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgBMx := lOutImgBM; + lOutImgTx := lOutImgT; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + FreeOnTerminate := True; + inherited Create(False); +end; + + + +{ The Execute method is called when the thread starts } + +procedure TStatThread.Execute; +begin + Analyze(lttestx,lBMx, lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lnGroup1x,lMaskImgx,lPlankImgX,lOutImgMnx,lOutImgBMx,lOutImgTx,lSymptomRAx); +end; + +(*procedure TStatThread.Terminate; +begin + Dec(gThreadsRunning); + NPMmsg('Thread done'); + inherited Terminate; +end; *) + +{ Nearest Nighbor } +procedure TNNStat.Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + + lPosPct,lPos,lPos2,lPos2Offset: integer; + lSum: single; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(gnVoxTestedRA[lThread]); + lSum := 0; + for lPos := 1 to lImagesCount do begin + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSum := lSum + lObs^[lPos-1]; + end; + lOutImgMn^[lPos2Offset] := lSum/lImagesCount; + if lttest then begin + TStat2 (lImagesCount, lnGroup1, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + end; + if lBM then begin + BMTest(lImagesCount, lnGroup1, lObs,lT); + lOutImgBM^[lPos2Offset] := lT; + + //TStatAbs (lImagesCount, lnGroup1, lObs,lT); + //lOutImgBM[lPos2Offset] := lT; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnGroup1,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + Terminate; +end; + + +{ Paired T-Test} +(*procedure PairedTTest (N, SumOfDifSqrs, SumDif: double;var t, p,DF: double); + var + meanDif, SumDifSqr, temp: double; + begin + df := n - 1; + t := 0; + p := 1; + + if (SumOfDifSqrs <> 0)and (SumDif <> 0)and (df <> 0) and (N <> 0) then begin + meanDif := SumDif / N; + SumDifSqr := sqr(SumDif); + temp := SumOfDifSqrs - (SumDifSqr / n); + temp := temp / (n * df); + temp := sqrt(temp); + if temp <> 0 then begin + t := meanDif / temp; + p := betai(0.5 * df, 0.5, df / (df + sqr(t))) + end else {t is infinitely big} + p := -1.0; + end; +end; {paired ttest} *) + + +procedure TPairedTStat.Analyze(lUnused1,lUnused2: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lPosPct,lPos,lPos2,lPos2Offset: integer; + lSum: single; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(gnVoxTestedRA[lThread]); + lSum := 0; + for lPos := 1 to lImagesCount do begin + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSum := lSum + lObs^[lPos-1]; + end; + lOutImgMn^[lPos2Offset] := lSum/lImagesCount; + PairedTStat (lImagesCount, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + //StatPermuteThreaded (lttest,lBM,lImagesCount, lnGroup1,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); +end; + +(*procedure TLesionStat.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT,lBMz,lDF: Double; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + inc(lnNoLesion); + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + + end else begin + //lesion + inc(lnLesion); + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + if lttest then begin + TStat2 (lImagesCount, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + end; + if lBM then begin + tBM (lImagesCount, lnNoLesion, lObs,lBMz,lDF); + BMzVal (lImagesCount, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); +end;*) + +procedure TLesionStat.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +//pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsT,lPrevZValsBM: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + + lObsp: pointer; + lObs: Doublep0; + lT,lBMz,lDF: Double; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + inc(lnNoLesion); + lLesionOrderp^[lPos] := 0; + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + //now check if we have seen this precise lesion order recently... + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + if lttest then + lOutImgT^[lPos2Offset] := lPrevZvalsT[lPos]; + if lBM then + lOutImgBM^[lPos2Offset] := lPrevZvalsBM[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + + + if lttest then begin + TStat2 (lImagesCount, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + lPrevZValsT[lPatternPos] := lT; + end; + if lBM then begin + tBM (lImagesCount, lnNoLesion, lObs,lBMz,lDF); + BMzVal (lImagesCount, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + lPrevZValsBM[lPatternPos] := lBMz; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //novel lesion pattern + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp) + +end; + +procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); + //pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsL,lPrevZValsX: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //Binomial StatThread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := lSymptomRA^[lPos]; + lLesionOrderp^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lnLesion-1] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + //next check patterns + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + //if lChi2 then + // lOutImgX^[lPos2Offset] := lPrevZvalsX[lPos]; + //if lLieber then + lOutImgL^[lPos2Offset] := lPrevZValsL[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + + {if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + lPrevZValsX[lPatternPos] := lT; + end; + if lLieber then begin} + Liebermeister2(lImagesCount, lnLesion, lObs,lT); + lOutImgL^[lPos2Offset] := lT; + lPrevZValsL[lPatternPos] := lT; + //end; + StatPermuteBinomialThreaded ({lChi2}false,lLieber,lImagesCount, lnLesion,lnPermute,lThread, lObs); + end; + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp) +end; + +(*procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lObs^[lnLesion-1] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + end; + if lLieber then begin + Liebermeister2(lImagesCount, lnLesion, lObs,lT); + lOutImgL^[lPos2Offset] := lT; + end; + StatPermuteBinomialThreaded (lChi2,lLieber,lImagesCount, lnLesion,lnPermute,lThread, lObs); + + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + +end;*) + + +end. diff --git a/npm/StatThds.ppu b/npm/StatThds.ppu new file mode 100644 index 0000000..28d3506 Binary files /dev/null and b/npm/StatThds.ppu differ diff --git a/npm/StatThdsUtil.o b/npm/StatThdsUtil.o new file mode 100644 index 0000000..d8d3bdf Binary files /dev/null and b/npm/StatThdsUtil.o differ diff --git a/npm/StatThdsUtil.pas b/npm/StatThdsUtil.pas new file mode 100755 index 0000000..f7d1117 --- /dev/null +++ b/npm/StatThdsUtil.pas @@ -0,0 +1,106 @@ +unit StatThdsUtil; +interface +uses + //ComCtrls,Graphics, ExtCtrls, + Classes, define_types,dialogsx; +const + kMaxThreads = 16; + kSh = 10; //bits to shift + kMaxImages = 1024; + kMaxPermute = 4000; + //kPlankMB : integer = 512; + +var +gnCPUThreads, gThreadsRunning: Integer; + kPlankSz : int64;// =1024 {bytes/kb} * 1024 {bytes/mb} * kPlankMB; //e.g. 512 MB + gDataTypeRA: array [0..kMaxImages] of integer; + gOffsetRA,gScaleRA,gInterceptRA: array [0..kMaxImages] of single; + gnVoxTestedRA : array [0..kMaxThreads] of integer; + gPermuteMinT,gPermuteMaxT,gPermuteMinBM,gPermuteMaxBM : array [0..kMaxThreads,0..kMaxPermute ] of double; +procedure ClearThreadData(lnThreads,lnPermute: integer); +function SumThreadDataLite (lnThreads: integer): integer; +function SumThreadData (lnThreads,lnPermute: integer;lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP): integer; +procedure ClearThreadDataPvals (lnThreads,lnPermute: integer); + +implementation + +procedure ClearThreadDataPvals (lnThreads,lnPermute: integer); +var lT,lP: integer; +begin + if lnThreads < 1 then exit; + if lnPermute > kMaxPermute then + ShowMsg('Error: recompile with larger kMaxPermute'); + for lT := 1 to lnThreads do + gnVoxTestedRA[lT] := 0; + if lnPermute < 1 then exit; + for lT := 1 to lnThreads do begin + for lP := 1 to lnPermute do begin + gPermuteMinT[lT,lP] := 10; + gPermuteMaxT[lT,lP] := -10; + gPermuteMinBM[lT,lP] := 10; + gPermuteMaxBM[lT,lP] := -10; + end; + end; +end; + + +procedure ClearThreadData (lnThreads,lnPermute: integer); +var lT,lP: integer; +begin + if lnThreads < 1 then exit; + if lnPermute > kMaxPermute then + ShowMsg('Error: recompile with larger kMaxPermute'); + for lT := 1 to lnThreads do + gnVoxTestedRA[lT] := 0; + if lnPermute < 1 then exit; + for lT := 1 to lnThreads do begin + for lP := 1 to lnPermute do begin + gPermuteMinT[lT,lP] := 0; + gPermuteMaxT[lT,lP] := 0; + gPermuteMinBM[lT,lP] := 0; + gPermuteMaxBM[lT,lP] := 0; + end; + end; +end; + +function SumThreadDataLite (lnThreads: integer): integer; +var lT: integer; +begin + result := 0; + if lnThreads < 1 then exit; + for lT := 1 to lnThreads do + result := result + gnVoxTestedRA[lT]; +end; + +function SumThreadData (lnThreads,lnPermute: integer;lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP): integer; +var lT,lP: integer; +begin + result := 0; + if lnThreads < 1 then exit; + for lT := 1 to lnThreads do + result := result + gnVoxTestedRA[lT]; + if lnPermute < 1 then exit; + for lP := 1 to lnPermute do begin + lPermuteMinT^[lP] := gPermuteMinT[1,lP]; + lPermuteMaxT^[lP] := gPermuteMaxT[1,lP]; + lPermuteMinBM^[lP] := gPermuteMinBM[1,lP]; + lPermuteMaxBM^[lP] := gPermuteMaxBM[1,lP]; + end; + if lnThreads < 2 then exit; + for lT := 2 to lnThreads do begin + for lP := 1 to lnPermute do begin + if lPermuteMinT^[lP] > gPermuteMinT[lT,lP] then + lPermuteMinT^[lP] := gPermuteMinT[lT,lP]; + if lPermuteMinBM^[lP] > gPermuteMinBM[lT,lP] then + lPermuteMinBM^[lP] := gPermuteMinBM[lT,lP]; + if lPermuteMaxT^[lP] < gPermuteMaxT[lT,lP] then + lPermuteMaxT^[lP] := gPermuteMaxT[lT,lP]; + if lPermuteMaxBM^[lP] < gPermuteMaxBM[lT,lP] then + lPermuteMaxBM^[lP] := gPermuteMaxBM[lT,lP]; + + end; + end; +end; //SumThreadData + + +end. \ No newline at end of file diff --git a/npm/StatThdsUtil.ppu b/npm/StatThdsUtil.ppu new file mode 100644 index 0000000..c6b579f Binary files /dev/null and b/npm/StatThdsUtil.ppu differ diff --git a/npm/Thumbs.db b/npm/Thumbs.db new file mode 100755 index 0000000..987d5b6 Binary files /dev/null and b/npm/Thumbs.db differ diff --git a/npm/Vector.o b/npm/Vector.o new file mode 100644 index 0000000..ec7c3df Binary files /dev/null and b/npm/Vector.o differ diff --git a/npm/Vector.pas b/npm/Vector.pas new file mode 100755 index 0000000..d2f893b --- /dev/null +++ b/npm/Vector.pas @@ -0,0 +1,544 @@ +unit Vector; +{$Include ..\common\isgui.inc} +interface + +uses SysUtils; + + +//var gMat: boolean = false; + +type + EVectorSizeError = class (Exception); + TMatElement = double; //extended; + { The 1000 in the array types below does not impose a limit at runtime! + If you compile with range checking on then the compiled code will impose + an effective limit of 1000, but with range checking off the size of + vector is limited to 64K under 16bit OS or *much* greater under 32bit OS } + TArrayd = array[1..1000] of TMatElement; pTArrayd = ^TArrayd; + TArrayi = array[1..1000] of integer; pTArrayi = ^TArrayi; + + { Define a dynamic array type for holding integers } + TVectori = class (TObject) + private + s : integer; { size of vector } + vx : pTArrayi; { pointer to the data } + private + procedure SetSize (NewSize : integer); + public + constructor create (i : integer); virtual; + destructor destroy; override; + procedure EnlargeBy (n : integer); + procedure ReduceBy (n : integer); + procedure Enlarge; + procedure Reduce; + procedure Zero; + procedure Clear; + procedure Assign (v : TVectori); + procedure Setval (i : integer; v : integer); + function Getval (i : integer) : integer; + function GetSize : integer; + property Elem[x : Integer] : integer read GetVal write SetVal; default; + property Size : integer read s; + end; + + + { Define a dynamic array type for holding Extendeds } + TVector = class (TObject) + private + s : integer; { size of vector } + vx : pTArrayd; { pointer to the data } + Tmp : boolean; { set to true if temporary } + public + { Declare as a class method, saves having a self variable } + class function Dot (u, v : TVector) : TMatElement; + + constructor create (i : integer); virtual; + constructor createTmp (i : integer); + destructor destroy; override; + procedure FreeSpace; + procedure SetSize (i : integer); + procedure EnlargeBy (n : integer); + procedure ReduceBy (n : integer); + procedure Enlarge; + procedure Reduce; + procedure Zero; + procedure Clear; + procedure Setval (i : integer; v : TMatElement); + function Getval (i : integer) : TMatElement; + property Elem[x : Integer] : TMatElement read GetVal write SetVal; default; + property Size : integer read s; + procedure Assign (v : TVector); + function Add (v, u : TVector) : TVector; + function Sub (v, u : TVector) : TVector; + class function xAdd (v, u : TVector) : TVector; + class function xSub (v, u : TVector) : TVector; + function DotU (v : TVector) : TMatElement; + function CrossU (v : TVector) : TVector; + function Cross (v1, v2 : TVector) : TVector; + function Sum : TMatElement; + function Mean : TMatElement; + function SumofSquares : TMatElement; + function Norm : TMatElement; + function StdDev : TMatElement; + procedure Scale (factor : TMatElement); + end; + + +implementation + + +// ------------------------------------------------------------------------- +// START OF VECTOR TYPE IMPLEMETATION +// ------------------------------------------------------------------------- + + +{ The data space which holds the data for a vector is typed as [1..x] so that +indexing autmatically starts at one, therefore there is no need in the +following code to add 1 to the size of the vector when creating or destroying it } + +{ Create a vector of size i } +constructor TVector.create(i : integer); +begin + Inherited Create; + s := 0; vx := Nil; { vx set to Nil to indicate empty vector, used by SetSize } + if i > 0 then Self.SetSize (i); +end; + +constructor TVector.createTmp (i : integer); +begin + Inherited Create; + s := 0; vx := Nil; { vx set to Nil to indicate empty vector, used by SetSize } + if i > 0 then Self.SetSize (i); + Tmp := true; +end; + + +destructor TVector.destroy; +begin + FreeSpace; + Inherited Destroy; +end; + + +{ Private internal procedure } +procedure TVector.FreeSpace; +begin + if vx <> Nil then FreeMem (vx, sizeof (TMatElement) * s); vx := Nil; s := 0; +end; + + +{ Internal routine to allocate space. If space already exists then it frees it first } +procedure TVector.SetSize (i : integer); +begin + if vx <> Nil then FreeMem (vx, sizeof (TMatElement) * s); + s := i; vx := AllocMem (sizeof (TMatElement) * s); + //if gMat then beep; +end; + + + +{ Increase the size of the vector without destroying and existing data } +procedure TVector.EnLargeBy (n : integer); +begin + if n < 0 then raise EVectorSizeError.Create ('Argument to EnLargeBy must be positive'); + ReAllocMem (vx, sizeof (TMatElement)*(s+n)); inc (s,n); { Modified for D2 } +end; + + +{ Reduce the size of the vector } +procedure TVector.ReduceBy (n : integer); +begin + if n >= s then + raise EVectorSizeError.Create ('Can''t reduce size of vector to below zero elements'); + ReAllocMem (vx, sizeof (TMatElement)*(s-n)); dec (s,n); { modified for D2 } +end; + + +{ Enlarge the vector by one element without destroying any existing data } +procedure TVector.Enlarge; +begin + ReAllocMem (vx, sizeof (TMatElement)*(s+1)); inc (s); { Modified for D2 } +end; + + +{ Reduce the vector by one element, the top most element is destroyed } +procedure TVector.Reduce; +begin + ReAllocMem (vx, sizeof (TMatElement)*(s-1)); dec (s); { Modified for D2 } +end; + + +{ Clears the vector, sets all elements to zero } +procedure TVector.Zero; +var i : integer; +begin + for i := 1 to s do vx^[i] := 0.0; +end; + + +{ Clears the vector, sets all elements to zero } +procedure TVector.Clear; +begin + Zero; +end; + + + +{ used internally but is also accessible from the outside } +procedure TVector.Setval (i : integer; v : TMatElement); +begin + vx^[i] := v; +end; + + +{ used internally but is also accessible from the outside } +function TVector.Getval (i : integer) : TMatElement; +begin + result := vx^[i]; +end; + + +// ------------------------------------------------------------------------- +// Copies vector v, including contects to self. If self is not the same +// size as v then self is resized + +// Copy v to u: +// Usage: u.Assign (v) +// ------------------------------------------------------------------------- +procedure TVector.Assign (v : TVector); +begin + v.Tmp := False; { just in case its a temporary variable } + if v.s <> Self.s then Self.SetSize (v.s); + move (v.vx^, Self.vx^, sizeof(TMatElement) * s) +end; + + +// ------------------------------------------------------------------------- +// Add the vectors, 'v' and 'u' together to produce Self. Error if v and u are +// the the same size. If Self is not sized correctly, then Add will resize Self + +// Usage: w.Add (u, v) +// Add u to v giving result w +// ------------------------------------------------------------------------- + +function TVector.Add (v, u : TVector) : TVector; +var i : integer; +begin + if v.s <> u.s then + raise EVectorSizeError.Create ('Vectors must be the same size to sum them'); + if Self.s <> v.s then Self.SetSize (v.s); + for i := 1 to v.s do Self[i] := v[i] + u[i]; + if v.tmp then v.free; if u.tmp then u.free; + result := Self; +end; + + +// ------------------------------------------------------------------------- +// Add the vectors, 'v' and 'u' together and RETURN the result. An Error +// occurs if v and u are the the same size. xAdd returns the result to the +// caller therefore it is the responsibility of the caller to dispose of the +// memory allocated by xSub. Note, the variable which is used to store the +// returned result must not have been previously allocated, otherwise you'll +// get memory leak! + +// w must be unallocated +// Usage: w := Add (u, v) +// Add u to v giving result w +// ------------------------------------------------------------------------- + +class function TVector.xAdd (v, u : TVector) : TVector; +var i : integer; t : TVector; +begin + if v.s <> u.s then + raise EVectorSizeError.Create ('Vectors must be the same size to sum them'); + t := TVector.CreateTmp (v.s); + for i := 1 to v.s do t[i] := v[i] + u[i]; + result := t; +end; + + +// ------------------------------------------------------------------------- +// Subtract the vectors, 'v' and 'u' together to produce Self. Error if v and u are +// the the same size. If Self is not sized correctly, then Add will resize Self + +// Usage: w.Sub (u, v) +// Add u to v giving result w +// ------------------------------------------------------------------------- + +function TVector.Sub (v, u : TVector) : TVector; +var i : integer; +begin + if v.s <> u.s then + raise EVectorSizeError.Create ('Vectors must be the same size to subtract them'); + if Self.s <> v.s then Self.SetSize (v.s); + for i := 1 to v.s do Self[i] := v[i] - u[i]; + if v.tmp then v.free; if u.tmp then u.free; + result := Self; +end; + + +// ------------------------------------------------------------------------- +// Subtract the vectors, 'v' and 'u' together and RETURN the result. An Error +// occurs if v and u are the the same size. xSub returns the result to the +// caller therefore it is the responsibility of the caller to dispose of the +// memory allocated by xSub. Note, the variable which is used to store the +// returned result must not have been previously allocated, otherwise you'll +// get memory leak! + +// w must be unallocated +// Usage: w := Sub (u, v) +// Add u to v giving result w +// ------------------------------------------------------------------------- + + +class function TVector.xSub (v, u : TVector) : TVector; +var i : integer; t : TVector; +begin + if v.s <> u.s then + raise EVectorSizeError.Create ('Vectors must be the same size to subtract them'); + t := TVector.CreateTmp (v.s); + for i := 1 to v.s do t[i] := v[i] - u[i]; + result := t; +end; + + +// ------------------------------------------------------------------------- +// Compute the dot product of vectors 'u' and 'v' +// Usage: d := dot (u, v); +// ------------------------------------------------------------------------- +class function TVector.Dot (u, v : TVector) : TMatElement; +var i : integer; +begin + if u.Size <> v.Size then + raise EVectorSizeError.Create ('Vectors must be of the same size to compute dot product'); + + result := 0.0; + for i := 1 to u.Size do result := result + u[i]*v[i]; +end; + + +// ------------------------------------------------------------------------- +// Apply a dot product to Self and argument, 'v' +// Usage: d := u.dotU (v); +// ------------------------------------------------------------------------- +function TVector.DotU (v : TVector) : TMatElement; +var i : integer; +begin + if Self.Size <> v.Size then + raise EVectorSizeError.Create ('Vectors must be of the same size to compute dot product'); + + result := 0.0; + for i := 1 to Self.Size do + result := result + Self[i]*v[i]; +end; + + +// ------------------------------------------------------------------------- +// Compute the cross product of Self and vector 'v', replacing Self +// Usage: v.CrossU (u) +// ------------------------------------------------------------------------- +function TVector.CrossU (v : TVector) : TVector; +begin + if (v.Size = 3) and (Self.Size = 3) then + begin + Self[1] := Self[2]*v[3] - Self[3]*v[2]; + Self[2] := Self[3]*v[1] - Self[1]*v[3]; + Self[3] := Self[1]*v[2] - Self[2]*v[1]; + result := Self; + end + else + raise EVectorSizeError.Create ('Cross product can only be calculated for vectors in 3D'); +end; + + +// ------------------------------------------------------------------------- +// Compute the cross product of 'v1' and vector 'v2' giving Self +// Usage: v.Cross (v1, v2) +// ------------------------------------------------------------------------- +function TVector.Cross (v1, v2 : TVector) : TVector; +begin + if (v1.Size = 3) and (v2.Size = 3) and (Self.Size = 3) then + begin + Self[1] := v1[2]*v2[3] - v1[3]*v2[2]; + Self[2] := v1[3]*v2[1] - v1[1]*v2[3]; + Self[3] := v1[1]*v2[2] - v1[2]*v2[1]; + result := Self; + end + else + raise EVectorSizeError.Create ('Cross product can only be calculated for vectors in 3D'); +end; + + +// ------------------------------------------------------------------------- +// Returns the sum of values in the vector +// Usage: total := v.sum +// ------------------------------------------------------------------------- +function TVector.Sum : TMatElement; +var i : integer; +begin + result := 0.0; + for i := 1 to s do result := result + vx^[i]; +end; + +// ------------------------------------------------------------------------- +// Returns the mean of the elements of the vector +// Usage: average := v.mean; +// ------------------------------------------------------------------------- +function TVector.Mean : TMatElement; +begin + if s > 0 then result := sum / s + else raise Exception.Create ('Vector must have at least one element to compute mean'); +end; + + +// ------------------------------------------------------------------------- +// Returns the sum of the squares of values in Data +// Usage: s := v.SumOfSquares; +// ------------------------------------------------------------------------- +function TVector.SumOfSquares : TMatElement; +var i : integer; +begin + result := 0.0; + for i := 1 to s do result := result + sqr(vx^[i]); +end; + + +// ------------------------------------------------------------------------- +// Returns the Euclidean norm of the Self vector +// ------------------------------------------------------------------------- +function TVector.Norm : TMatElement; +begin + result := sqrt (Self.SumOfSquares); +end; + + +// ------------------------------------------------------------------------- +// Returns the sample standard deviation +// Usage: sd := v.StdDev; +// ------------------------------------------------------------------------- +function TVector.StdDev : TMatElement; +var sq, total : TMatElement; i : integer; +begin + sq := 0; total := 0; + if s > 1 then + begin + for i := 1 to s do + begin sq := sq + sqr(vx^[i]); total := total + vx^[i]; end; + result := sqrt ((sq - sqr(total)/s)/(s-1)); + // The following code is easier to read but slightly slower in execution: + // result := sqrt ((SumOfSquares - sqr (sum)/s)/(s-1));} + end + else + raise Exception.Create ('Can''t calculate stddev for vector with one or no elements'); +end; + + +// ------------------------------------------------------------------------- +// Scale the vector by factor +// Usage: v.Scale (2) Multiplies all elements by 2 +// ------------------------------------------------------------------------- +procedure TVector.Scale (factor : TMatElement); +var i : integer; +begin + for i := 1 to s do vx^[i] := vx^[i]*factor; +end; + + +{ ------------------------------------------------------------------------- } +{ START OF INTEGER VECTOR IMPLEMETATION } +{ ------------------------------------------------------------------------- } + + +{ Create a vector of size i } +constructor TVectori.create(i : integer); +begin + Inherited Create; vx := Nil; + Self.SetSize (i); +end; + + +destructor TVectori.destroy; +begin + if vx <> Nil then FreeMem (vx, sizeof (integer) * s); + Inherited Destroy; +end; + + +{ Internal routine used by define } +procedure TVectori.SetSize (NewSize : integer); +begin + if vx <> Nil then FreeMem (vx, sizeof (integer) * s); + s := NewSize; vx := AllocMem (sizeof (integer) * NewSize); +end; + +procedure TVectori.EnLargeBy (n : integer); +begin + ReAllocMem (vx, sizeof (integer)*(s+n)); inc (s,n); { Modified for D2 } +end; + + +procedure TVectori.ReduceBy (n : integer); +begin + if n >= s then + raise EVectorSizeError.Create ('Can''t reduce size of vector to below zero elements'); + ReAllocMem (vx, sizeof (integer)*(s-n)); dec (s,n); { Modified for D2 } +end; + + +{ Enlarge the vector by one element without destroying any existing data } +procedure TVectori.Enlarge; +begin + ReAllocMem (vx, sizeof (integer)*(s+1)); inc (s); { Modified for D2 } +end; + + +{ Reduce the vector by one element, the top most element is destroyed } +procedure TVectori.Reduce; +begin + ReAllocMem (vx, sizeof (integer)*(s-1)); dec (s); { Modified for D2 } +end; + + +{ Clear the vector, sets all elements to zero } +procedure TVectori.Zero; +var i : integer; +begin + for i := 1 to s do vx^[i] := 0; +end; + + +{ Clear the vector, sets all elements to zero } +procedure TVectori.Clear; +begin + Zero; +end; + + +procedure TVectori.Assign (v : TVectori); +begin + if v.s <> Self.s then Self.SetSize (v.s); + move (v.vx^, Self.vx^, sizeof(integer) * s) +end; + + +{ used internally but is also accessible from the outside } +procedure TVectori.Setval (i : integer; v : integer); +begin + vx^[i] := v; +end; + + +{ used internally but is also accessible from the outside } +function TVectori.Getval (i : integer) : integer; +begin + result := vx^[i]; +end; + + +function TVectori.GetSize : integer; +begin + result := s; +end; + + +end. \ No newline at end of file diff --git a/npm/Vector.ppu b/npm/Vector.ppu new file mode 100644 index 0000000..4c014bf Binary files /dev/null and b/npm/Vector.ppu differ diff --git a/npm/_npmcl.bat b/npm/_npmcl.bat new file mode 100755 index 0000000..2b8ab25 --- /dev/null +++ b/npm/_npmcl.bat @@ -0,0 +1,6 @@ + +lazbuild ./npmcl.lpr --cpu=x86_64 --compiler="/usr/local/bin/ppcx64" +mv ./npmcl ./npmcl64 + +lazbuild ./npmcl.lpr + diff --git a/npm/anacom.pas b/npm/anacom.pas new file mode 100755 index 0000000..f551127 --- /dev/null +++ b/npm/anacom.pas @@ -0,0 +1,632 @@ +unit anacom; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr,filename, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +//procedure DoAnaCOM; +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; + + + +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lCombinedSymptomRA: singleP; + lPos,lPlank,lThread,lnControlsPlusPatients: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshBonf,lThreshPermute,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lBM,lttest,lLtest: boolean; + lnControlNeg: integer; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + lnControlNeg := lnControl; //negative for binomial test + lttest := lttestin; + lbm := lbmin; + if (not (lttest)) and (not (lbm)) then begin + lLtest := true; + lBM := true; + lnControlNeg := -lnControl; + end; + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + if lnControl < 1 then begin + MainForm.NPMmsg('AnaCom aborted - need data from at least 1 control individual'); + exit; + end; + lnPermute := 0;//MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + lnControlsPlusPatients := lImages.Count+lnControl; + createArray64(lObsp,lObs,lnControlsPlusPatients); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + //sumptom array for lesions AND controls + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + for lPos := 1 to lnControl do + lObs^[lPos-1+lImages.Count] := lControlSymptomRA^[lPos]; + getmem(lCombinedSymptomRA,lnControlsPlusPatients* sizeof(single)); + for lPos := 1 to lnControlsPlusPatients do + lCombinedSymptomRA^[lPos] := lObs^[lPos-1]; + //next create permuted BM bounds + if lBM then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + //for lPos := 1 to lImages.Count do + // lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lnControlsPlusPatients, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + + with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lnControlNeg,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,nil,lCombinedSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + //Next: NULPS + if lRun > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lnCrit,lnVoxTested,lPlankImg)); + + //lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit)); + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if (lRun < 1) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lRun < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + if lnControl < 1 then + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('attest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'attest'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaComthreshtt,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Mann Whitney + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('aBM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'aBM'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaCOMthreshbm,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + + + +(*function readCSV2 (lFilename: string; lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) or (MaxC < (kHdrCol+lCol2)) then begin + showmessage('problems reading CSV - not enough columns/rows '+inttostr(lCol1)+' '+inttostr(lCol2)); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := MaxC-1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + getmem(ldataRA2,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) or ((C-kHdrCol) = lCol2) then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then + ldataRA1^[R-kHdrRow] := lTempFloat + else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat; + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + ldataRA2^[R-1] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; *) + +function readTxt (lFilename: string; var lnObservations : integer; var ldataRA1: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lCol1: integer; + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lCol1:= 1; + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) then begin + showmessage('problems reading CSV - not enough columns/rows '); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := kHdrCol+lCol1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) {or ((C-kHdrCol) = lCol2)} then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then begin + //showmessage(lNumStr); + ldataRA1^[R-kHdrRow] := lTempFloat; + end; + {else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat;} + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + //showmessage(lNumStr+' '+inttostr(lnFactors)+' '+inttostr(C)); + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(inttostr(R)+' '+floattostr(lTempFLoat)); + ldataRA1^[R] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; + +(*procedure DoAnaCOM; +label + 666; +var + lControlFilename: string; + lI, lnControlObservations : integer; + lControldata: singlep; + lBinomial: boolean; + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('AnaCOM analysis requires TXT/CSV format text file.'); + npmform.MainForm.memo1.lines.add('One row per control participant.'); + npmform.MainForm.memo1.lines.add('First column is performance of that participant.'); + npmform.MainForm.memo1.lines.add('Example file:'); + //npmform.MainForm.memo1.lines.add('deficit, voxels'); + npmform.MainForm.memo1.lines.add('11'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('2'); + npmform.MainForm.memo1.lines.add('22'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('6'); + lControlFilename := 'c:\fx.txt'; + if (not readTxt (lControlFilename, lnControlObservations,lControldata)) or (lnControlObservations < 1) then begin + showmessage('Error reading file '+lControlFilename); + exit; + end; + npmform.MainForm.memo1.lines.add('Control (n='+inttostr(lnControlObservations)+')performance: '); + for lI := 1 to lnControlObservations do begin + npmform.MainForm.memo1.lines.add(inttostr(lI)+' '+floattostr(lControldata^[lI])); + + end; + //begin - copy + + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not MainForm.GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit,{,binom}lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + + + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then exit; + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + MainForm.NPMmsgClear; + MainForm.NPMMsg(MainForm.GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to lnSubj do + MainForm.NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroup(lImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + MainForm.ReportDescriptives(lSymptomRA,lnSubj); + AnacomLesionNPMAnalyze(lImageNames,lMaskHdr,lnCrit,-1,lnControlObservations,lSymptomRA,lControldata,lFactName,lOutname,true {ttest},false{BM}); + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + + Freemem(lMultiSymptomRA); + end; + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + ///end + //AnacomLesionNPMAnalyze ( lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttest,lBM: boolean): boolean; + freemem(lControldata); + + + +end;*) + +end. diff --git a/npm/associate.pas b/npm/associate.pas new file mode 100755 index 0000000..225aae7 --- /dev/null +++ b/npm/associate.pas @@ -0,0 +1,42 @@ +unit associate; +interface +uses Windows,registry,Forms,dialogs,SysUtils; + +function registerfiletype(inft,inkey,desc,icon:string): boolean; + +implementation + +function registerfiletype(inft,inkey,desc,icon:string): boolean; +var myreg : treginifile; + ct : integer; + ft,key: string; +begin + result := true; + ft := inft; + key := inkey; + ct := pos('.',ft); + while ct > 0 do begin + delete(ft,ct,1); + ct := pos('.',ft); + end; + if (ft = '') or (Application.ExeName = '') then exit; //not a valid file-ext or ass. app + ft := '.'+ft; + myreg := treginifile.create(''); + try + myreg.rootkey := hkey_classes_root; // where all file-types are described + if key = '' then key := copy(ft,2,maxint)+'_auto_file'; // if no key-name is given, create one + myreg.writestring(ft,'',key); // set a pointer to the description-key + myreg.writestring(key,'',desc); // write the description + myreg.writestring(key+'\DefaultIcon','',icon); // write the def-icon if given + //showmessage(key); + myreg.writestring(key+'\shell\open\command','',Application.ExeName+' %1'); //association + except + result := false; + showmessage('Only administrators can change file associations. You are currently logged in as a restricted user.'); + end; + //finally + myreg.free; + //end; +end; + +end. \ No newline at end of file diff --git a/npm/backup/StatThds.pas.bak b/npm/backup/StatThds.pas.bak new file mode 100755 index 0000000..613748c --- /dev/null +++ b/npm/backup/StatThds.pas.bak @@ -0,0 +1,578 @@ +unit StatThds; + {$Include ..\common\isgui.inc} +interface + +uses + {$IFDEF GUI} ComCtrls,{$ENDIF} + //ComCtrls, Graphics, ExtCtrls, + Classes, define_types,stats,StatThdsUtil,Brunner,lesion_pattern, dialogsx; + + + +type + + TStatThread = class(TThread) + private + lBarX: TProgressBar; + lttestx,lBMx: boolean; + lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lnGroup1x : integer; + lMaskImgx,lPlankImgx,lOutImgMnx,lOutImgBMx,lOutImgTx,lSymptomRAx: SingleP; + procedure DoVisualSwap; + protected + procedure Execute; override; + //procedure Terminate; + procedure VisualProg(lPos: Integer); + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); virtual; abstract; + public + constructor Create(lBar: TProgressBar;lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); + end; + +{ VBM - two groups } + + TNNStat = class(TStatThread) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + + TPairedTStat = class(TStatThread) + protected + procedure Analyze(lunused1,lunused2: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + { Lesion - image reveals value } + + TLesionStat = class(TStatThread) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + TLesionBinomial = class(TStatThread) + protected + procedure Analyze(lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); override; + end; + +implementation +uses unpm; +//uses Stat; + + +{ TSortThread } + +(*tpIdle The thread executes only when the system is idle. The system will not interrupt other threads to execute a thread with tpIdle priority. +tpLowest The thread's priority is two points below normal. +tpLower The thread's priority is one point below normal. +tpNormal The thread has normal priority. +tpHigher The thread's priority is one point above normal. +tpHighest The thread's priority is two points above normal. +tpTimeCritical*) + +Const Two32 = 4294967296.0 ; +function GenRandThreaded(lRange: integer; var lRandSeed:comp): integer; +//normal random function does not work well when threaded - randseed is changed by each thread +const lFactor = $08088405 ; lTerm = 1 ; +type lT = array [0..1] of longint ; +var + lX: extended; +begin + lRandSeed := lRandSeed*lFactor + lTerm; + lT(lRandSeed)[1] := 0 ; // < May'04 was: RS := RS - Trunc(RS/Two32)*Two32 ; + lX := lRandSeed/Two32 ; + result := trunc((lRange)*lX); +end; + +procedure GenPermuteThreaded (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: double; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteThreaded (lttest,lBM: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lttest then begin + TStat2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lBM then begin + BMTest (lnSubj, lnGroup0, lRanOrder,lOutT); + if lOutT > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lOutT; + if lOutT < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lOutT; + end; //compute BM + end; + freemem(lRanOrderp); +end; + +procedure StatPermuteBinomialThreaded (lChi2,lLieber: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lChi2 then begin + Chi2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lLieber then begin + Liebermeister2 (lnSubj, lnGroup0, lRanOrder,lOutT); + if lOutT > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lOutT; + if lOutT < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lOutT; + end; //compute BM + end; + freemem(lRanOrderp); +end; + + +procedure TStatThread.DoVisualSwap; +begin + {$IFDEF GUI} + lBarX.Position := lBarPosX; + {$ENDIF} +end; + +procedure TStatThread.VisualProg(lPos: Integer); +begin + {$IFDEF GUI} + lBarPosX := lPos; + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} + {$ENDIF} +end; + +constructor TStatThread.Create(lBar: TProgressBar; lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +begin + lBarX := lBar; + lttestx := lttest; + lBMx:= lBM; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lnGroup1x := lnGroup1; + lMaskImgx := lMaskImg; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgBMx := lOutImgBM; + lOutImgTx := lOutImgT; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + FreeOnTerminate := True; + inherited Create(False); +end; + + + +{ The Execute method is called when the thread starts } + +procedure TStatThread.Execute; +begin + Analyze(lttestx,lBMx, lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lnGroup1x,lMaskImgx,lPlankImgX,lOutImgMnx,lOutImgBMx,lOutImgTx,lSymptomRAx); +end; + +(*procedure TStatThread.Terminate; +begin + Dec(gThreadsRunning); + NPMmsg('Thread done'); + inherited Terminate; +end; *) + +{ Nearest Nighbor } +procedure TNNStat.Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + + lPosPct,lPos,lPos2,lPos2Offset: integer; + lSum: single; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(gnVoxTestedRA[lThread]); + lSum := 0; + for lPos := 1 to lImagesCount do begin + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSum := lSum + lObs^[lPos-1]; + end; + lOutImgMn^[lPos2Offset] := lSum/lImagesCount; + if lttest then begin + TStat2 (lImagesCount, lnGroup1, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + end; + if lBM then begin + BMTest(lImagesCount, lnGroup1, lObs,lT); + lOutImgBM^[lPos2Offset] := lT; + + //TStatAbs (lImagesCount, lnGroup1, lObs,lT); + //lOutImgBM[lPos2Offset] := lT; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnGroup1,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + Terminate; +end; + + +{ Paired T-Test} +(*procedure PairedTTest (N, SumOfDifSqrs, SumDif: double;var t, p,DF: double); + var + meanDif, SumDifSqr, temp: double; + begin + df := n - 1; + t := 0; + p := 1; + + if (SumOfDifSqrs <> 0)and (SumDif <> 0)and (df <> 0) and (N <> 0) then begin + meanDif := SumDif / N; + SumDifSqr := sqr(SumDif); + temp := SumOfDifSqrs - (SumDifSqr / n); + temp := temp / (n * df); + temp := sqrt(temp); + if temp <> 0 then begin + t := meanDif / temp; + p := betai(0.5 * df, 0.5, df / (df + sqr(t))) + end else {t is infinitely big} + p := -1.0; + end; +end; {paired ttest} *) + + +procedure TPairedTStat.Analyze(lUnused1,lUnused2: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lPosPct,lPos,lPos2,lPos2Offset: integer; + lSum: single; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(gnVoxTestedRA[lThread]); + lSum := 0; + for lPos := 1 to lImagesCount do begin + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSum := lSum + lObs^[lPos-1]; + end; + lOutImgMn^[lPos2Offset] := lSum/lImagesCount; + PairedTStat (lImagesCount, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + //StatPermuteThreaded (lttest,lBM,lImagesCount, lnGroup1,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); +end; + +(*procedure TLesionStat.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT,lBMz,lDF: Double; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + inc(lnNoLesion); + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + + end else begin + //lesion + inc(lnLesion); + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + if lttest then begin + TStat2 (lImagesCount, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + end; + if lBM then begin + tBM (lImagesCount, lnNoLesion, lObs,lBMz,lDF); + BMzVal (lImagesCount, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); +end;*) + +procedure TLesionStat.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +//pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsT,lPrevZValsBM: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + + lObsp: pointer; + lObs: Doublep0; + lT,lBMz,lDF: Double; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + inc(lnNoLesion); + lLesionOrderp^[lPos] := 0; + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + //now check if we have seen this precise lesion order recently... + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + if lttest then + lOutImgT^[lPos2Offset] := lPrevZvalsT[lPos]; + if lBM then + lOutImgBM^[lPos2Offset] := lPrevZvalsBM[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + + + if lttest then begin + TStat2 (lImagesCount, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + lPrevZValsT[lPatternPos] := lT; + end; + if lBM then begin + tBM (lImagesCount, lnNoLesion, lObs,lBMz,lDF); + BMzVal (lImagesCount, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + lPrevZValsBM[lPatternPos] := lBMz; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //novel lesion pattern + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp) + +end; + +procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); + //pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsL,lPrevZValsX: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //Binomial StatThread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := lSymptomRA^[lPos]; + lLesionOrderp^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lnLesion-1] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + //next check patterns + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + //if lChi2 then + // lOutImgX^[lPos2Offset] := lPrevZvalsX[lPos]; + //if lLieber then + lOutImgL^[lPos2Offset] := lPrevZvalsL[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + + {if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + lPrevZValsX[lPatternPos] := lT; + end; + if lLieber then begin} + Liebermeister2(lImagesCount, lnLesion, lObs,lT); + lOutImgL^[lPos2Offset] := lT; + lPrevZValsL[lPatternPos] := lT; + //end; + StatPermuteBinomialThreaded ({lChi2}false,lLieber,lImagesCount, lnLesion,lnPermute,lThread, lObs); + end; + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp) +end; + +(*procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lObs^[lnLesion-1] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + end; + if lLieber then begin + Liebermeister2(lImagesCount, lnLesion, lObs,lT); + lOutImgL^[lPos2Offset] := lT; + end; + StatPermuteBinomialThreaded (lChi2,lLieber,lImagesCount, lnLesion,lnPermute,lThread, lObs); + + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + +end;*) + + +end. \ No newline at end of file diff --git a/npm/backup/npm.lpi.bak b/npm/backup/npm.lpi.bak new file mode 100755 index 0000000..1abb122 --- /dev/null +++ b/npm/backup/npm.lpi.bak @@ -0,0 +1,649 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <LRSInOutputDirectory Value="False"/> + </Flags> + <MainUnit Value="0"/> + </General> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="70"> + <Unit0> + <Filename Value="npm.lpr"/> + <IsPartOfProject Value="True"/> + <CursorPos X="34" Y="11"/> + <UsageCount Value="111"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit0> + <Unit1> + <Filename Value="npmform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MainForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="1"/> + <TopLine Value="14"/> + <CursorPos X="7" Y="21"/> + <UsageCount Value="111"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit1> + <Unit2> + <Filename Value="nifti_hdr.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="358"/> + <CursorPos X="49" Y="368"/> + <UsageCount Value="107"/> + </Unit2> + <Unit3> + <Filename Value="define_types.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="945"/> + <CursorPos X="38" Y="959"/> + <UsageCount Value="107"/> + </Unit3> + <Unit4> + <Filename Value="GraphicsMathLibrary.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="681"/> + <CursorPos Y="738"/> + <UsageCount Value="107"/> + </Unit4> + <Unit5> + <Filename Value="distr.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="99"/> + <CursorPos Y="107"/> + <UsageCount Value="107"/> + </Unit5> + <Unit6> + <Filename Value="statcr.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="4"/> + <CursorPos X="11" Y="25"/> + <UsageCount Value="107"/> + </Unit6> + <Unit7> + <Filename Value="stats.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="615"/> + <CursorPos Y="635"/> + <UsageCount Value="107"/> + </Unit7> + <Unit8> + <Filename Value="brunner.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="500"/> + <CursorPos X="29" Y="517"/> + <UsageCount Value="107"/> + </Unit8> + <Unit9> + <Filename Value="StatThdsUtil.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="49"/> + <CursorPos X="38" Y="4"/> + <UsageCount Value="107"/> + </Unit9> + <Unit10> + <Filename Value="StatThds.pas"/> + <IsPartOfProject Value="True"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="3"/> + <TopLine Value="488"/> + <CursorPos X="45" Y="493"/> + <UsageCount Value="107"/> + <Loaded Value="True"/> + </Unit10> + <Unit11> + <Filename Value="valformat.pas"/> + <IsPartOfProject Value="True"/> + <CursorPos X="9" Y="12"/> + <UsageCount Value="107"/> + </Unit11> + <Unit12> + <Filename Value="design.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="DesignForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="37"/> + <CursorPos X="36" Y="58"/> + <UsageCount Value="106"/> + </Unit12> + <Unit13> + <Filename Value="spread.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="SpreadForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="4"/> + <TopLine Value="547"/> + <CursorPos X="15" Y="559"/> + <UsageCount Value="106"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit13> + <Unit14> + <Filename Value="gzio2.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="774"/> + <CursorPos X="22" Y="793"/> + <UsageCount Value="107"/> + </Unit14> + <Unit15> + <Filename Value="part.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="91"/> + <CursorPos X="38" Y="108"/> + <UsageCount Value="107"/> + </Unit15> + <Unit16> + <Filename Value="markorder.pas"/> + <TopLine Value="8"/> + <CursorPos X="44" Y="23"/> + <UsageCount Value="6"/> + </Unit16> + <Unit17> + <Filename Value="ztopform.pas"/> + <ComponentName Value="ZForm"/> + <TopLine Value="9"/> + <CursorPos X="18" Y="23"/> + <UsageCount Value="18"/> + </Unit17> + <Unit18> + <Filename Value="..\examples\opendialogcrash\unit1.pas"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <UnitName Value="Unit1"/> + <TopLine Value="19"/> + <CursorPos X="40" Y="14"/> + <UsageCount Value="6"/> + </Unit18> + <Unit19> + <Filename Value="nifti_img.pas"/> + <CursorPos X="77" Y="4"/> + <UsageCount Value="10"/> + </Unit19> + <Unit20> + <Filename Value="lesion_pattern.pas"/> + <CursorPos X="13" Y="21"/> + <UsageCount Value="11"/> + </Unit20> + <Unit21> + <Filename Value="ReadInt.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ReadIntForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="23"/> + <CursorPos X="9" Y="50"/> + <UsageCount Value="105"/> + </Unit21> + <Unit22> + <Filename Value="ReadInt.lrs"/> + <IsPartOfProject Value="True"/> + <CursorPos Y="3"/> + <UsageCount Value="103"/> + </Unit22> + <Unit23> + <Filename Value="LesionStatThds.pas"/> + <TopLine Value="319"/> + <CursorPos X="28" Y="335"/> + <UsageCount Value="35"/> + </Unit23> + <Unit24> + <Filename Value="power.pas"/> + <UsageCount Value="7"/> + </Unit24> + <Unit25> + <Filename Value="Mat.pas"/> + <TopLine Value="225"/> + <CursorPos X="18" Y="239"/> + <UsageCount Value="7"/> + </Unit25> + <Unit26> + <Filename Value="Vector.pas"/> + <UsageCount Value="6"/> + </Unit26> + <Unit27> + <Filename Value="firth.pas"/> + <TopLine Value="294"/> + <CursorPos X="38" Y="23"/> + <UsageCount Value="34"/> + </Unit27> + <Unit28> + <Filename Value="overlap.pas"/> + <TopLine Value="280"/> + <CursorPos X="23" Y="301"/> + <UsageCount Value="8"/> + </Unit28> + <Unit29> + <Filename Value="firthThds.pas"/> + <TopLine Value="604"/> + <CursorPos X="52" Y="36"/> + <UsageCount Value="29"/> + </Unit29> + <Unit30> + <Filename Value="design.lfm"/> + <UsageCount Value="6"/> + <DefaultSyntaxHighlighter Value="LFM"/> + </Unit30> + <Unit31> + <Filename Value="options.inc"/> + <CursorPos X="21" Y="3"/> + <UsageCount Value="7"/> + </Unit31> + <Unit32> + <Filename Value="userdir.pas"/> + <CursorPos X="64" Y="45"/> + <UsageCount Value="7"/> + </Unit32> + <Unit33> + <Filename Value="..\..\lcl\forms.pp"/> + <UnitName Value="Forms"/> + <TopLine Value="642"/> + <CursorPos X="14" Y="661"/> + <UsageCount Value="7"/> + </Unit33> + <Unit34> + <Filename Value="..\gzio2.pas"/> + <TopLine Value="627"/> + <CursorPos X="22" Y="635"/> + <UsageCount Value="6"/> + </Unit34> + <Unit35> + <Filename Value="..\..\fpc\2.0.4\source\rtl\objpas\sysutils\finah.inc"/> + <TopLine Value="17"/> + <CursorPos X="22" Y="27"/> + <UsageCount Value="6"/> + </Unit35> + <Unit36> + <Filename Value="..\define_types.pas"/> + <CursorPos X="31" Y="5"/> + <UsageCount Value="6"/> + </Unit36> + <Unit37> + <Filename Value="..\..\fpc\2.0.4\source\rtl\win32\wininc\messages.inc"/> + <TopLine Value="1191"/> + <CursorPos X="6" Y="1201"/> + <UsageCount Value="6"/> + </Unit37> + <Unit38> + <Filename Value="regression.pas"/> + <EditorIndex Value="8"/> + <CursorPos X="69" Y="13"/> + <UsageCount Value="42"/> + <Loaded Value="True"/> + </Unit38> + <Unit39> + <Filename Value="Regmult.pas"/> + <UnitName Value="RegMult"/> + <TopLine Value="30"/> + <CursorPos X="27" Y="43"/> + <UsageCount Value="6"/> + </Unit39> + <Unit40> + <Filename Value="..\fpmath\regmult.pas"/> + <TopLine Value="39"/> + <CursorPos X="69" Y="45"/> + <UsageCount Value="6"/> + </Unit40> + <Unit41> + <Filename Value="..\common\distr.pas"/> + <TopLine Value="296"/> + <CursorPos Y="308"/> + <UsageCount Value="7"/> + </Unit41> + <Unit42> + <Filename Value="..\common\define_types.pas"/> + <EditorIndex Value="7"/> + <TopLine Value="8"/> + <CursorPos X="57" Y="25"/> + <UsageCount Value="36"/> + <Loaded Value="True"/> + </Unit42> + <Unit43> + <Filename Value="hdr.pas"/> + <CursorPos X="42" Y="5"/> + <UsageCount Value="34"/> + </Unit43> + <Unit44> + <Filename Value="..\common\gzio2.pas"/> + <TopLine Value="1770"/> + <CursorPos X="11" Y="1778"/> + <UsageCount Value="12"/> + </Unit44> + <Unit45> + <Filename Value="..\common\nifti_hdr.pas"/> + <CursorPos X="52" Y="14"/> + <UsageCount Value="9"/> + </Unit45> + <Unit46> + <Filename Value="..\common\GraphicsMathLibrary.pas"/> + <CursorPos X="17" Y="8"/> + <UsageCount Value="6"/> + </Unit46> + <Unit47> + <Filename Value="..\fpmath\utypes.pas"/> + <TopLine Value="470"/> + <CursorPos X="41" Y="482"/> + <UsageCount Value="8"/> + </Unit47> + <Unit48> + <Filename Value="lesion.pas"/> + <TopLine Value="299"/> + <CursorPos X="64" Y="313"/> + <UsageCount Value="6"/> + </Unit48> + <Unit49> + <Filename Value="anacom.pas"/> + <TopLine Value="579"/> + <CursorPos X="32" Y="593"/> + <UsageCount Value="6"/> + </Unit49> + <Unit50> + <Filename Value="filename.pas"/> + <CursorPos X="6" Y="4"/> + <UsageCount Value="6"/> + </Unit50> + <Unit51> + <Filename Value="montecarlo.pas"/> + <CursorPos X="6" Y="3"/> + <UsageCount Value="7"/> + </Unit51> + <Unit52> + <Filename Value="roc.pas"/> + <TopLine Value="2"/> + <CursorPos X="41" Y="14"/> + <UsageCount Value="7"/> + </Unit52> + <Unit53> + <Filename Value="..\fpmath\types.inc"/> + <TopLine Value="153"/> + <CursorPos X="3" Y="174"/> + <UsageCount Value="11"/> + </Unit53> + <Unit54> + <Filename Value="C:\Developer\lazarus\lcl\interfaces\carbon\carbonprivatecommon.inc"/> + <TopLine Value="170"/> + <CursorPos Y="184"/> + <UsageCount Value="6"/> + </Unit54> + <Unit55> + <Filename Value="tfce_clustering.pas"/> + <TopLine Value="8"/> + <CursorPos X="75" Y="11"/> + <UsageCount Value="10"/> + </Unit55> + <Unit56> + <Filename Value="C:\Developer\lazarus\lcl\include\menuitem.inc"/> + <TopLine Value="61"/> + <CursorPos Y="83"/> + <UsageCount Value="8"/> + </Unit56> + <Unit57> + <Filename Value="..\common\isgui.inc"/> + <CursorPos X="10"/> + <UsageCount Value="36"/> + </Unit57> + <Unit58> + <Filename Value="..\common\dialogsx.pas"/> + <TopLine Value="8"/> + <CursorPos X="10" Y="35"/> + <UsageCount Value="31"/> + </Unit58> + <Unit59> + <Filename Value="..\common\dicomhdr.pas"/> + <CursorPos X="13" Y="7"/> + <UsageCount Value="6"/> + </Unit59> + <Unit60> + <Filename Value="unpm.pas"/> + <EditorIndex Value="6"/> + <CursorPos X="49" Y="8"/> + <UsageCount Value="40"/> + <Loaded Value="True"/> + </Unit60> + <Unit61> + <Filename Value="turbolesion.pas"/> + <EditorIndex Value="5"/> + <CursorPos X="63" Y="8"/> + <UsageCount Value="35"/> + <Loaded Value="True"/> + </Unit61> + <Unit62> + <Filename Value="prefs.pas"/> + <TopLine Value="129"/> + <CursorPos X="22" Y="134"/> + <UsageCount Value="33"/> + </Unit62> + <Unit63> + <Filename Value="C:\usr\local\share\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/> + <CursorPos X="10" Y="107"/> + <UsageCount Value="7"/> + </Unit63> + <Unit64> + <Filename Value="..\common\cpucount.pas"/> + <CursorPos X="10" Y="5"/> + <UsageCount Value="31"/> + </Unit64> + <Unit65> + <Filename Value="C:\Developer\lazarus\lcl\include\progressbar.inc"/> + <TopLine Value="155"/> + <CursorPos Y="178"/> + <UsageCount Value="8"/> + </Unit65> + <Unit66> + <Filename Value="C:\Developer\lazarus\lcl\dialogs.pp"/> + <UnitName Value="Dialogs"/> + <TopLine Value="486"/> + <CursorPos X="10" Y="500"/> + <UsageCount Value="31"/> + </Unit66> + <Unit67> + <Filename Value="..\..\..\..\..\..\usr\local\share\fpcsrc\packages\paszlib\src\zdeflate.pas"/> + <TopLine Value="1035"/> + <CursorPos X="10" Y="1049"/> + <UsageCount Value="12"/> + </Unit67> + <Unit68> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\menuitem.inc"/> + <TopLine Value="5"/> + <CursorPos Y="83"/> + <UsageCount Value="10"/> + </Unit68> + <Unit69> + <Filename Value="upower.pas"/> + <EditorIndex Value="2"/> + <TopLine Value="3"/> + <CursorPos X="10" Y="31"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit69> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="npmform.pas"/> + <Caret Line="335" Column="16" TopLine="324"/> + </Position1> + <Position2> + <Filename Value="npmform.pas"/> + <Caret Line="422" Column="30" TopLine="402"/> + </Position2> + <Position3> + <Filename Value="npmform.pas"/> + <Caret Line="462" Column="40" TopLine="460"/> + </Position3> + <Position4> + <Filename Value="npmform.pas"/> + <Caret Line="799" Column="35" TopLine="786"/> + </Position4> + <Position5> + <Filename Value="npmform.pas"/> + <Caret Line="800" Column="58" TopLine="786"/> + </Position5> + <Position6> + <Filename Value="npmform.pas"/> + <Caret Line="801" Column="29" TopLine="786"/> + </Position6> + <Position7> + <Filename Value="npmform.pas"/> + <Caret Line="805" Column="26" TopLine="786"/> + </Position7> + <Position8> + <Filename Value="npmform.pas"/> + <Caret Line="906" Column="26" TopLine="886"/> + </Position8> + <Position9> + <Filename Value="npmform.pas"/> + <Caret Line="2" Column="127"/> + </Position9> + <Position10> + <Filename Value="npmform.pas"/> + <Caret Line="130" Column="21" TopLine="110"/> + </Position10> + <Position11> + <Filename Value="npmform.pas"/> + <Caret Line="2" Column="129"/> + </Position11> + <Position12> + <Filename Value="npmform.pas"/> + <Caret Line="25" Column="18" TopLine="5"/> + </Position12> + <Position13> + <Filename Value="npmform.pas"/> + <Caret Line="3" Column="130"/> + </Position13> + <Position14> + <Filename Value="npmform.pas"/> + <Caret Line="82" Column="17" TopLine="62"/> + </Position14> + <Position15> + <Filename Value="npmform.pas"/> + <Caret Line="94" Column="15" TopLine="74"/> + </Position15> + <Position16> + <Filename Value="npmform.pas"/> + <Caret Line="119" Column="25" TopLine="99"/> + </Position16> + <Position17> + <Filename Value="npmform.pas"/> + <Caret Line="3" Column="129"/> + </Position17> + <Position18> + <Filename Value="npmform.pas"/> + <Caret Line="104" Column="30" TopLine="84"/> + </Position18> + <Position19> + <Filename Value="npmform.pas"/> + <Caret Line="414" Column="49" TopLine="394"/> + </Position19> + <Position20> + <Filename Value="npmform.pas"/> + <Caret Line="992" Column="7" TopLine="991"/> + </Position20> + <Position21> + <Filename Value="npmform.pas"/> + <Caret Line="991" Column="7" TopLine="990"/> + </Position21> + <Position22> + <Filename Value="npmform.pas"/> + <Caret Line="5" Column="105"/> + </Position22> + <Position23> + <Filename Value="npmform.pas"/> + <Caret Line="103" Column="7" TopLine="83"/> + </Position23> + <Position24> + <Filename Value="npmform.pas"/> + <Caret Line="118" Column="32" TopLine="98"/> + </Position24> + <Position25> + <Filename Value="npmform.pas"/> + <Caret Line="434" Column="8" TopLine="410"/> + </Position25> + <Position26> + <Filename Value="spread.pas"/> + <Caret Line="584" TopLine="555"/> + </Position26> + <Position27> + <Filename Value="npmform.pas"/> + <Caret Line="1049" Column="75" TopLine="1046"/> + </Position27> + <Position28> + <Filename Value="npmform.pas"/> + <Caret Line="1295" Column="19" TopLine="1283"/> + </Position28> + <Position29> + <Filename Value="upower.pas"/> + <Caret Line="51" Column="47" TopLine="38"/> + </Position29> + <Position30> + <Filename Value="StatThds.pas"/> + <Caret Line="6" Column="24"/> + </Position30> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <OtherUnitFiles Value="..\fpmath;..\common"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + <UseLineInfoUnit Value="False"/> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <LinkerOptions Value=" -macosx_version_min 10.4 "/> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="2"> + <Item1> + <Name Value="ECodetoolError"/> + </Item1> + <Item2> + <Name Value="EFOpenError"/> + </Item2> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/npm/backup/npmform.lfm.bak b/npm/backup/npmform.lfm.bak new file mode 100755 index 0000000..c7d45da --- /dev/null +++ b/npm/backup/npmform.lfm.bak @@ -0,0 +1,288 @@ +object MainForm: TMainForm + Left = 468 + Height = 418 + Top = 213 + Width = 542 + ActiveControl = Memo1 + Caption = 'Non-Parametric Mapping' + ClientHeight = 418 + ClientWidth = 542 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.0.12.0' + object Memo1: TMemo + Left = 0 + Height = 393 + Top = 0 + Width = 542 + Align = alClient + ScrollBars = ssAutoBoth + TabOrder = 0 + end + object Panel1: TPanel + Left = 0 + Height = 25 + Top = 393 + Width = 542 + Align = alBottom + ClientHeight = 25 + ClientWidth = 542 + TabOrder = 1 + object ProgressBar1: TProgressBar + Left = 1 + Height = 23 + Top = 1 + Width = 540 + Align = alClient + TabOrder = 0 + end + end + object MainMenu1: TMainMenu + left = 8 + top = 8 + object File1: TMenuItem + Caption = 'File' + object SaveText1: TMenuItem + Caption = 'Save text...' + OnClick = Savetext1Click + end + object Exit1: TMenuItem + Caption = 'Exit' + OnClick = Exit1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + end + object VLSM1: TMenuItem + Caption = 'VLSM' + object BinomialAnalysislesions1: TMenuItem + Caption = 'Binary images, binary groups (lesions) ' + ShortCut = 16450 + OnClick = LesionBtnClick + end + object Binaryimagescontinuousgroupsfast1: TMenuItem + Tag = 1 + Caption = 'Binary images, continuous groups (vlsm)' + ShortCut = 16460 + OnClick = LesionBtnClick + end + object PenalizedLogisticRegerssion1: TMenuItem + Caption = 'Binary images, multiple factors' + OnClick = PenalizedLogisticRegerssion1Click + end + object ROIanalysis1: TMenuItem + Caption = 'ROI analysis' + OnClick = ROIanalysis1Click + end + object Design1: TMenuItem + Caption = 'Design...' + ShortCut = 16452 + OnClick = Design1Click + end + end + object VBM1: TMenuItem + Caption = 'VBM' + object ContinuousanalysisVBM1: TMenuItem + Caption = 'Continuous images, binary groups (VBM)' + ShortCut = 16470 + OnClick = NPMclick + end + object PairedTMenu: TMenuItem + Caption = 'Paired Measures T-test' + OnClick = PairedTMenuClick + end + object MultipleRegress: TMenuItem + Caption = 'Multiple WLS Regression' + Visible = False + OnClick = MultipleRegressClick + end + object SingleRegress: TMenuItem + Caption = 'Single WLS Regression' + Visible = False + OnClick = SingleRegressClick + end + object DualImageCorrelation1: TMenuItem + Caption = 'Dual image correlation' + Visible = False + OnClick = DualImageCorrelation1Click + end + end + object Options1: TMenuItem + Caption = 'Options' + object Permutations1: TMenuItem + Caption = 'Permutations' + object N0: TMenuItem + AutoCheck = True + Caption = 'None' + Checked = True + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N1000: TMenuItem + Tag = 1000 + AutoCheck = True + Caption = '1000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N2000: TMenuItem + Tag = 2000 + AutoCheck = True + Caption = '2000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N3000: TMenuItem + Tag = 3000 + AutoCheck = True + Caption = '3000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N4000: TMenuItem + Tag = 4000 + AutoCheck = True + Caption = '4000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + end + object Tests1: TMenuItem + Caption = 'Tests' + object ttestmenu: TMenuItem + Caption = 't-test' + OnClick = testmenuclick + end + object BMmenu: TMenuItem + Caption = 'Brunner Munzel' + Checked = True + OnClick = testmenuclick + end + end + object Threads1: TMenuItem + Caption = 'Threads' + object T1: TMenuItem + AutoCheck = True + Caption = '1' + Checked = True + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T2: TMenuItem + AutoCheck = True + Caption = '2' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T3: TMenuItem + AutoCheck = True + Caption = '3' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T4: TMenuItem + AutoCheck = True + Caption = '4' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T7: TMenuItem + AutoCheck = True + Caption = '7' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T8: TMenuItem + AutoCheck = True + Caption = '8' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T15: TMenuItem + AutoCheck = True + Caption = '15' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T16: TMenuItem + AutoCheck = True + Caption = '16' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + end + object PlankSzMenuItem1: TMenuItem + Caption = 'Plank Size' + OnClick = PlankSzMenuItem1Click + end + end + object Utilities1: TMenuItem + Caption = 'Utilities' + object Variance1: TMenuItem + Caption = 'Variance image' + OnClick = Variance1Click + end + object Makemeanimage2: TMenuItem + Tag = 1 + Caption = 'Make binarized mean' + OnClick = Makemeanimage1Click + end + object Makemeanimage1: TMenuItem + Caption = 'Make mean/StDev image' + OnClick = Makemeanimage1Click + end + object SingleSubjectZScores1: TMenuItem + Caption = 'Single Subject Z-Score' + OnClick = SingleSubjectZScores1Click + end + object IntensitynormalizationA1: TMenuItem + Tag = 1 + Caption = 'Intensity normalization A' + OnClick = Balance1Click + end + object Balance1: TMenuItem + Caption = 'Intensity normalization B' + OnClick = Balance1Click + end + end + object Help1: TMenuItem + Caption = 'Help' + Visible = False + object About1: TMenuItem + Caption = 'About' + OnClick = About1Click + end + end + end + object SaveHdrDlg: TSaveDialog + FilterIndex = 0 + left = 8 + top = 40 + end + object OpenHdrDlg: TOpenDialog + FilterIndex = 0 + left = 8 + top = 72 + end +end \ No newline at end of file diff --git a/npm/backup/npmform.pas.bak b/npm/backup/npmform.pas.bak new file mode 100755 index 0000000..a7ba9b2 --- /dev/null +++ b/npm/backup/npmform.pas.bak @@ -0,0 +1,2208 @@ +unit npmform; +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} +{$DEFINE SINGLETHREAD} +//{$DEFINE FIRTHNOTHREAD} +interface +{$I options.inc} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, + Messages, userDir, + Classes, Graphics, Controls, Forms, DialogsX,Dialogs, nifti_types , + Menus, ComCtrls, ExtCtrls, StdCtrls, +overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, + {$ELSE} + LCLType, + {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,math, +regmult,utypes,turbolesion +{$IFDEF compileANACOM}, anacom{$ENDIF} + +{$IFDEF benchmark}, montecarlo{$ENDIF} +; +//regmultdelphi,matrices; +type + + { TMainForm } + + TMainForm = class(TForm) + Binaryimagescontinuousgroupsfast1: TMenuItem; + Memo1: TMemo; + + Design1: TMenuItem; + //PlankSzMenuItem1: TMenuItem; + DualImageCorrelation1: TMenuItem; + MultipleRegress: TMenuItem; + SaveText1: TMenuItem; + ROIanalysis1: TMenuItem; + OpenHdrDlg: TOpenDialog; + SaveHdrDlg: TSaveDialog; + Panel1: TPanel; + ProgressBar1: TProgressBar; + MainMenu1: TMainMenu; + About1: TMenuItem; + AssociatevalfileswithNPM1: TMenuItem; + Balance1: TMenuItem; + BinomialAnalysislesions1: TMenuItem; + BMmenu: TMenuItem; + ContinuousanalysisVBM1: TMenuItem; + Copy1: TMenuItem; + Edit1: TMenuItem; + Exit1: TMenuItem; + File1: TMenuItem; + Help1: TMenuItem; + IntensitynormalizationA1: TMenuItem; + Makemeanimage1: TMenuItem; + Makemeanimage2: TMenuItem; + N0: TMenuItem; + N1000: TMenuItem; + N2000: TMenuItem; + N3000: TMenuItem; + N4000: TMenuItem; + Options1: TMenuItem; + PairedTMenu: TMenuItem; + PenalizedLogisticRegerssion1: TMenuItem; + Permutations1: TMenuItem; + SingleRegress: TMenuItem; + SingleSubjectZScores1: TMenuItem; + T1: TMenuItem; + T15: TMenuItem; + T16: TMenuItem; + T2: TMenuItem; + T3: TMenuItem; + T4: TMenuItem; + T7: TMenuItem; + T8: TMenuItem; + Tests1: TMenuItem; + Threads1: TMenuItem; + //StartTimer: TTimer; + ttestmenu: TMenuItem; + Utilities1: TMenuItem; + Variance1: TMenuItem; + VBM1: TMenuItem; + VLSM1: TMenuItem; + Intensitynormalization1: TMenuItem; + Masked1: TMenuItem; + MaskedintensitynormalizationA1: TMenuItem; + MaskedintensitynormalizationB1: TMenuItem; + Binarizeimages1: TMenuItem; + PlankSzMenuItem1: TMenuItem; + //Setnonseroto1001: TMenuItem; + //AnaCOMmenu: TMenuItem; + //MonteCarloSimulation1: TMenuItem; + //Subtract1: TMenuItem; + //LogPtoZ1: TMenuItem; + procedure PlankSzMenuItem1Click(Sender: TObject); + procedure NPMmsgUI( lStr: string); + procedure NPMmsgClearUI; + procedure NPMmsgSaveUI(lFilename: string); + //procedure ProcessParamStr; + function GetValX (var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean; + function FirthNPMAnalyze (var lImages: TStrings; var lPredictorList: TStringList; var lMaskHdr: TMRIcroHdr; lnCond,lnCrit: integer; var lSymptomRA: SingleP; var lOutName: string): boolean; + procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); + function SaveHdrName (lCaption: string; var lFilename: string): boolean; + procedure NPMclick(Sender: TObject); + function OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; + //function NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels,lnGroup1: integer): boolean; + //function NPMAnalyzePaired (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels: integer): boolean; + procedure FormCreate(Sender: TObject); + //function MakeSubtract (lPosName,lNegName: string): boolean; + //function MakeMean (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lBinarize,lVariance: boolean): boolean; + //function Balance (var lImageName,lMaskName: String; lMethod: integer{lInflection: boolean}): boolean; + procedure LesionBtnClick(Sender: TObject); + procedure Copy1Click(Sender: TObject); + //procedure StartTimerTimer(Sender: TObject); + procedure testmenuclick(Sender: TObject); + procedure radiomenuclick(Sender: TObject); + procedure Makemeanimage1Click(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure Balance1Click(Sender: TObject); + + procedure Variance1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure Design1Click(Sender: TObject); + procedure DualImageCorrelation1Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure PairedTMenuClick(Sender: TObject); + procedure SingleSubjectZScores1Click(Sender: TObject); + procedure MultipleRegressClick(Sender: TObject); + function ReadPermute: integer; + procedure SingleRegressClick(Sender: TObject); + procedure AssociatevalfileswithNPM1Click(Sender: TObject); + procedure threadChange(Sender: TObject); + //procedure Countlesionoverlaps1Click(Sender: TObject); + procedure PenalizedLogisticRegerssion1Click(Sender: TObject); + //procedure ROCbinomialdeficit1Click(Sender: TObject); + //procedure ROCcontinuousdeficit1Click(Sender: TObject); + procedure ThreadDone(Sender: TObject); + procedure ROIanalysis1Click(Sender: TObject); + procedure Masked1Click(Sender: TObject); + procedure Binarizeimages1Click(Sender: TObject); + procedure Setnonseroto1001Click(Sender: TObject); + procedure Savetext1Click(Sender: TObject); + //procedure Subtract1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + MainForm: TMainForm; +implementation + +uses unpm, filename,prefs,hdr,roc,regression,valformat {$IFDEF SPREADSHEET} ,design,spread{$ENDIF} +{$IFNDEF UNIX},ActiveX {$ENDIF}; +{$IFNDEF FPC} +{$R *.DFM} + {$ENDIF} + +(*function WarnIfLowNCrit(lnSubj,lnCrit: integer): boolean; +//returns true if warning generated +begin + result := (round(lnSubj * 0.15) ) > lnCrit; //15% + if result then + Showmessage('Warning: low statistical power as tests computed for voxels damaged in at least '+inttostr(lnCrit) +' people. Solution: change Design value "Ignore voxels damaged in less than N%".'); + +end; *) + +procedure TMainForm.NPMmsgUI( lStr: string); +begin + Memo1.Lines.add(lStr); +end; + +procedure TMainForm.PlankSzMenuItem1Click(Sender: TObject); +var + str : string; + v,max: integer; +begin + {$IFDEF CPU32} + max := 1536; + {$ELSE} + max := 8000; + {$ENDIF} + + str := inttostr(gNPMPrefs.PlankMB); + if not InputQuery('Specify cache size', 'Mb for computation (256..'+inttostr(max)+')', str) then exit; + try + v := StrToInt(str); // Trailing blanks are not supported + except + on Exception : EConvertError do begin + ShowMessage(Exception.Message); + exit; + end; + end; + if (v < 256) then + v := 256; + if v > max then + v := max; + gNPMPrefs.PlankMB := v; + NPMMsgClear; + NPMMsg(GetKVers); + ComputePlankSize(gNPMPrefs.PlankMB); +end; + +procedure TMainForm.NPMmsgClearUI; +begin + Memo1.Lines.Clear; +end; + + +procedure TMainForm.NPMMsgSaveUI(lFilename: string); +var + i: integer; + f: textfile; +begin + if (Memo1.Lines.Count < 1) then exit; + if fileexists(lFilename) then begin + AssignFile(f, lFilename); + {$I-} + append(f); + {$I+} + if IOResult= 0 then + for i:= 0 to Memo1.Lines.Count- 1 do + WriteLn(f, Memo1.Lines[i]); + CloseFile(f); + end else + MainForm.Memo1.Lines.SaveToFile(lFilename); +end; + +procedure TMainForm.ThreadDone(Sender: TObject); +begin + Dec(gThreadsRunning); +end; + +function TMainForm.SaveHdrName (lCaption: string; var lFilename: string): boolean; +begin + result := false; + SaveHdrDlg.InitialDir := lFilename; + SaveHdrDlg.Title := lCaption; + SaveHdrDlg.Filter := kAnaHdrFilter; + if not SaveHdrDlg.Execute then exit; + lFilename := SaveHdrDlg.Filename; + result := true; +end; + +procedure TMainForm.FormClose(Sender: TObject; var CloseAction: TCloseAction); +begin + WriteIniFile; +end; + +procedure WriteThread( lnThread: integer); +begin + case lnThread of + 2: MainForm.T2.checked := true; + 3: MainForm.T3.checked := true; + 4: MainForm.T4.checked := true; + 7: MainForm.T7.checked := true; + 8: MainForm.T8.checked := true; + 15: MainForm.T15.checked := true; + 16: MainForm.T16.checked := true; + else MainForm.T1.checked := true; + end; + gnCPUThreads := lnThread; +end; + +function ReadThread: integer; +begin + if MainForm.T16.checked then result := 16 + else if MainForm.T15.checked then result := 15 + else if MainForm.T8.checked then result := 8 + else if MainForm.T7.checked then result := 7 + else if MainForm.T4.checked then result := 4 + else if MainForm.T3.checked then result := 3 + else if MainForm.T2.checked then result := 2 + else result := 1; + gnCPUThreads := result; +end; + +procedure WritePermute( lnPermute: integer); +begin + case lnPermute of + 4000: MainForm.N4000.checked := true; + 3000: MainForm.N3000.checked := true; + 2000: MainForm.N2000.checked := true; + 1000: MainForm.N1000.checked := true; + else MainForm.N0.checked := true; + end; +end; + +function TMainForm.ReadPermute: integer; +begin + if MainForm.N4000.checked then result := 4000 + else if MainForm.N3000.checked then result := 3000 + else if MainForm.N2000.checked then result := 2000 + else if MainForm.N1000.checked then result := 1000 + else result := 0; +end; + +function TMainForm.OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; +var + lNumberofFiles: integer; +begin + OpenHdrDlg.Filter := lFilter;//kAnaHdrFilter;//lFilter; + OpenHdrDlg.FilterIndex := 1; + OpenHdrDlg.Title := lCaption; + if lAllowMultiSelect then + OpenHdrDlg.Options := [ofAllowMultiSelect,ofFileMustExist] + else + OpenHdrDlg.Options := [ofFileMustExist]; + result := OpenHdrDlg.Execute; + if not result then exit; + if lForceMultiSelect then begin + lNumberofFiles:= OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + ShowMsg('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + result := false; + end; + end; +end; + +procedure TMainForm.NPMclick(Sender: TObject); +label + 666; +var + lnGroup1,lMaskVoxels: integer; + lG: TStrings; + lMaskname, lOutName: string; + lMaskHdr: TMRIcroHdr; +begin + if (not ttestmenu.checked) and (not BMmenu.checked) then begin + ShowMsg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: mask selection failed.'); + exit; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + (*if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showMsg('Error reading mask.'); + exit; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + exit; + end; *) + + //next, get 1st group + if not OpenDialogExecute('Select postive group (Z scores positive if this group is brighter)',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; //not sure why TStrings.Create does not work??? + lG.addstrings(OpenHdrDlg.Files); + lnGroup1 :=OpenHdrDlg.Files.Count; + + //next, get 2nd group + if not OpenDialogExecute('Select negative group (Z scores negative if this group is brighter)',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + goto 666; + end; //if not selected + lG.addstrings(OpenHdrDlg.Files); + if not CheckVoxelsGroupX(lG,lMaskHdr {lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + lOutName := lMaskHdr.ImgFileName; + if not SaveHdrName ('Statistical Map', lOutName) then exit; + NPMAnalyze(lG,lMaskName,lMaskVoxels,lnGroup1,gNPMPrefs,lOutName); + 666: + lG.Free; +end; + +function TMainForm.GetValX (var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit: integer; var lPredictorList: TStringList):boolean; +//warning: you MUST free lPredictorList +var + lVALFilename: string; + lCritPct: integer; +begin + lPredictorList := TStringList.Create; + result := false; + lnSubj := 0; + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + ShowMsg('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lVALFilename := MainForm.OpenHdrDlg.Filename; + result := GetValCore ( lVALFilename, lnSubj, lnFactors, lSymptomRA, lImageNames, lCrit,lCritPct{,binom},lPredictorList); +end; + +procedure TMainForm.Copy1Click(Sender: TObject); +begin + Memo1.SelectAll; + Memo1.CopyToClipboard; + +end; + +(*procedure TMainForm.StartTimerTimer(Sender: TObject); +begin + if StartTimer.Tag < 2 then begin + StartTimer.tag := StartTimer.tag + 1; + exit; + + end; + + StartTimer.Enabled := false; + //if (ParamCount > 0) then ProcessParamStr; + +end; *) + +procedure TMainForm.testmenuclick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gNPMprefs.BMtest := BMmenu.Checked; + gNPMprefs.ttest := TTestmenu.Checked; +end; + +procedure TMainForm.radiomenuclick(Sender: TObject); +begin + (sender as tmenuitem).checked := true; + gNPMprefs.nPermute:= readPermute; +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + File1.visible := false;//for OSX, exit is in the application's menu + //Edit1.visible := false;//clipboard note yet working for OSX + {$ENDIF} + {$IFDEF FPC} + Application.ShowButtonGlyphs := sbgNever; + {$ENDIF} + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + BinomialAnalysislesions1.ShortCut := ShortCut(Word('B'), [ssMeta]); + Binaryimagescontinuousgroupsfast1.ShortCut := ShortCut(Word('L'), [ssMeta]); + Design1.ShortCut := ShortCut(Word('D'), [ssMeta]); + ContinuousanalysisVBM1.ShortCut := ShortCut(Word('V'), [ssMeta]); + MultipleRegress.ShortCut := ShortCut(Word('R'), [ssMeta]); + Makemeanimage1.ShortCut := ShortCut(Word('M'), [ssMeta]); + About1.ShortCut := ShortCut(Word('A'), [ssMeta]); + {$ENDIF}//Carbon + {$ENDIF}//Darwin + gnCPUThreads := GetLogicalCpuCount; + (*if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + case MessageDlg('Shift key down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrNo: ReadIniFile; + end; //case + end else *) + if not ResetDefaults then + ReadIniFile; + + ttestmenu.checked := gNPMprefs.ttest; + bmmenu.Checked:= gNPMprefs.BMtest; + WritePermute(gNPMprefs.nPermute); + WriteThread(gnCPUThreads); +end; + +(*procedure TMainForm.Makemeanimage1Click(Sender: TObject); +label + 666; +var + lG: TStrings; + loutname: string; +begin + + if not OpenDialogExecute('Select images to average',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if not SaveHdrName ('Output image', lOutName) then exit; + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + + + MakeMean(lG,odd((Sender as TMenuItem).tag),false,loutname); + 666: + lG.Free; +end; *) +procedure TMainForm.Makemeanimage1Click(Sender: TObject); +var + loutname: string; +begin + + if not OpenDialogExecute('Select images to average666',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if not SaveHdrName ('Output image', lOutName) then exit; + MakeMean(OpenHdrDlg.Files,odd((Sender as TMenuItem).tag),false,loutname); +end; + + +procedure TMainForm.Exit1Click(Sender: TObject); +begin + Close; +end; + +(*procedure CopyFileEXoverwrite (lInName,lOutName: string); +var lFSize: Integer; + lBuff: bytep0; + lFData: file; +begin + lFSize := FSize(lInName); + if (lFSize < 1) then exit; + assignfile(lFdata,lInName); + filemode := 0; + reset(lFdata,lFSize{1}); + GetMem( lBuff, lFSize); + BlockRead(lFdata, lBuff^, 1{lFSize}); + closefile(lFdata); + assignfile(lFdata,lOutName); + filemode := 2; + Rewrite(lFdata,lFSize); + BlockWrite(lFdata,lBuff^, 1 {, NumWritten}); + closefile(lFdata); + freemem(lBuff); +end;*) + +procedure TMainForm.Balance1Click(Sender: TObject); +var + lFilename,lMaskName: string; + lPos: Integer; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + lMaskName := ''; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + balance(lFilename,lMaskname,(Sender as TMenuItem).tag); + end; +end; + + +procedure TMainForm.Variance1Click(Sender: TObject); +label + 666; +var + lMaskVoxels: integer; + lG: TStrings; + lMaskname,loutname: string; + lMaskHdr: TMRIcroHdr; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select 2 images)',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + if lG.count <> 2 then begin + ShowMsg('You must select exactly two image.'); + goto 666; + end; + if not SaveHdrName ('Output image', lOutName) then exit; + MakeMean(lG, odd((Sender as TMenuItem).tag),true,loutname); + 666: + lG.Free; +end; + +procedure TMainForm.About1Click(Sender: TObject); +begin + ShowMsg(GetkVers ); +end; + +procedure TMainForm.Design1Click(Sender: TObject); +begin +{$IFDEF SPREADSHEET} SpreadForm.Show; {$ELSE} ShowMsg('Spreadsheet not yet supported on the Operating System');{$ENDIF} +end; + +function AddNumStr(var X : PMatrix; var lNumStr: string; lRow,lCol: integer):boolean; +var + lTempFloat: double; +begin + + result := false; + if (lNumStr = '') or (lRow < 1) or (lCol < 1) then exit; + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + ShowMsg('Empty cells? Error reading TXT file row:'+inttostr(lRow)+' col:'+inttostr(lCol)+' - Unable to convert the string '+lNumStr+' to a number'); + exit; + end; + end; + //fx(lRow,lCol,lTempFloat); + X^[lCol]^[lRow] := lTempFloat; + lNumStr := ''; + result := true; +end; + +function ReadPairedFilenamesReg(var lImageNames: TStrings; var X : PMatrix; var lnAdditionalFactors: integer): boolean; +var + lLen,lPos,lSep,lMaxSep,lLine: integer; + lFilenames,lF1,lF2,lNumStr: string; + lImageNames2: TStrings; + lF: TextFile; +begin + result := false; + + ShowMsg('Please select a text file with the image names. '+kCR+ + 'Each line of the file should specify the control and experimental filenames, separated by an *'+kCR+ + 'C:\vbmdata\c1.nii.gz*C:\vbmdata\e1.nii.gz'+kCR + + 'C:\vbmdata\c2.nii.gz*C:\vbmdata\e2.nii.gz'+kCR+ + 'C:\vbmdata\c3.nii.gz*C:\vbmdata\e3.nii.gz'+kCR+ + '...' ); + if not MainForm.OpenDialogExecute('Select asterix separated filenames ',false,false,kTxtFilter) then + exit; + lImageNames2:= TStringList.Create; //not sure why TStrings.Create does not work??? + //xxx + assignfile(lF,MainForm.OpenHdrDlg.FileName ); + FileMode := 0; //read only + reset(lF); + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + + if lLen > 0 then begin + lF1:= ''; + lF2 := ''; + lPos := 1; + while (lPos <= lLen) and (lFilenames[lPos] <> '*') do begin + lF1 := lF1 + lFilenames[lPos]; + inc(lPos); + end; + inc(lPos); + while (lPos <= lLen) and (lFilenames[lPos] <> '*') do begin + lF2 := lF2 + lFilenames[lPos]; + inc(lPos); + end; + if (length(lF1) > 0) and (length(lF2)>0) then begin + if Fileexists4D(lF1) then begin + if Fileexists4D(lF2) then begin + lImageNames.add(lF1); + lImageNames2.add(lF2); + end else //F2exists + ShowMsg('Can not find image '+lF2); + end else //F1 exists + ShowMsg('Can not find image '+lF1); + end; + end;//len>0 + end; //while not EOF + + //fx(lImageNames.count); + //next - count additional factors + lnAdditionalFactors := 0; + reset(lF); + lMaxSep := 0; + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + lSep := 0; + if lLen > 0 then begin + for lPos := 1 to lLen do + if lFilenames[lPos] = '*' then + inc(lSep) + end;//len>0 + if lSep > lMaxSep then + lMaxSep := lSep; + end; //while not EOF + if (lMaxSep > 1) and (lImageNames2.count > 1) then begin //additional factors present + //final pas - load additional factors + lnAdditionalFactors := lMaxSep - 1; + + DimMatrix(X, lnAdditionalFactors, lImageNames2.count); + reset(lF); + lLine := 0; + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + lSep := 0; + + if lLen > 0 then begin + inc(lLine); + lPos := 1; + lNumStr := ''; + while lPos <= lLen do begin + if (lFilenames[lPos] = '*') then begin + AddNumStr(X,lNumStr,lLine,lSep-1); + inc(lSep); + end else if (lSep >= 2) and (not (lFilenames[lPos] in [#10,#13,#9]) ) then begin + lNumStr := lNumStr+lFilenames[lPos]; + //ShowMsg(lNumStr); + end; + inc(lPos); + end; //while not EOLN + AddNumStr(X,lNumStr,lLine,lSep-1); + end;//len>0 + end; //while not EOF + //next - read final line of unterminated string... + end;//maxsepa > 1 + //2nd pass vals + closefile(lF); + FileMode := 2; //read/write + if (lImageNames.count > 0) and (lImageNames2.count = lImageNames.count) then begin + lImageNames.AddStrings(lImageNames2); + + result := true; + end; + lImageNames2.Free; + result := true; +end; + +procedure TMainForm.DualImageCorrelation1Click(Sender: TObject); +label + 666; +var + lnSubj,lSubj,lMaskVoxels,lnAdditionalFactors,lI: integer; + lImageNames: TStrings; + X: PMatrix; + lMaskname,lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + NPMMsgClear; + NPMMsg(GetKVers); + + NPMMsg('Dual-image Linear Regression [Weighted Least Squares]'); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: mask selection failed.'); + goto 666; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + ShowMsg('Error reading Mask image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + goto 666; + end; + if not ReadPairedFilenamesReg(lImageNames,X,lnAdditionalFactors) then exit; + lnSubj :=lImageNames.Count div 2; + + //fx(lnAdditionalFactors); + //show matrix + //MsgStrings (lImageNames); + NPMMsg ('n Subjects = '+inttostr(lnSubj)); + for lSubj := 0 to (lnSubj-1) do begin + lStr := lImageNames[lSubj]+' <-> '+lImageNames[lSubj+lnSubj]; + if lnAdditionalFactors > 0 then + for lI := 1 to lnAdditionalFactors do + lStr := lStr+','+floattostr(X^[lI]^[lSubj+1]); + + + NPMMsg(lStr); + end; + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + + + NPMMsg('Mask = '+lMaskname); + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Number of observations = '+inttostr(lnSubj)); + + if lnSubj < 5 then begin + ShowMsg('Paired regression error: Requires at least 5 images per group.'); + goto 666; + end; + lOutName := lMaskName; + if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + //ShowMsg('Unimplemented Regress');// + Regress2NPMAnalyze (lImageNames, lMaskHdr, lOutname,X,lnAdditionalFactors,gNPMprefs.nPermute); + if lnAdditionalFactors > 1 then + DelMatrix(X, lnAdditionalFactors, lnSubj); + 666: + lImageNames.Free; +end; + +procedure TMainForm.LesionBtnClick(Sender: TObject); + label + 666; +var + lPrefs: TLDMPrefs ; +begin + lPrefs.NULP := gNPMPrefs.NULP; + if (1= (Sender as tMenuItem).tag) then begin //continuous + lPrefs.BMtest := BMmenu.checked; + lPrefs.Ttest := ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin //binomial + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.CritPct := -1; + lPrefs.nPermute := ReadPermute; + lPrefs.Run := 0;{0 except for montecarlo} + {if (not lPrefs.Ltest) and (not lPrefs.Ttest) and (not lPrefs.BMtest) then begin + ShowMsg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; code above defaults to t-test} + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + ShowMsg('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lPrefs.VALFilename := MainForm.OpenHdrDlg.Filename; + lPrefs.OutName := ExtractFileDirWithPathDelim(lPrefs.VALFilename)+'results'; + lPrefs.OutName := lPrefs.OutName+'.nii.gz'; + SaveHdrDlg.Filename := lPrefs.Outname; + if not SaveHdrName ('Base Statistical Map', lPrefs.OutName) then exit; + //Explicit mask + if not OpenDialogExecute('Select explicit mask [optional]',false,false,kImgPlusVOIFilter) then + lPrefs.ExplicitMaskName := '' + else + lPrefs.ExplicitMaskName := OpenHdrDlg.FileName; + + DoLesion (lPrefs); //Prefs.pas +end; + +function HasOption(const S: string):Boolean; +var + i: integer; +begin + result := false; + if (ParamCount < 1) then exit; + for i := 1 to ParamCount do + if ParamStr(i) = ('-'+S) then result := true; +end; + +procedure msg (s: string); +begin + writeln(s); +end; + +procedure ShowOptions (lTestInt: integer; lMaskFilename,lOutFilename: string); +begin + msg(' -c : CPU threads, Default : '+inttostr(gnCPUThreads)); + msg(' -m : mask name. Default "' +lMaskFilename+'"'); + msg(' -n : neighbors for TFCE, 0 for none. Default ' +inttostr(gNPMprefs.TFCE)); + msg(' -o : output name. Default "' +lOutFilename+'"'); + msg(' -p : Permutations, 0 for none. Default '+inttostr(gNPMprefs.nPermute)); + msg(' -r : RAM for processing (Mb). Default '+inttostr(gNPMPrefs.PlankMB)); + msg(' -t : test (0=continuous,1=binomial,2=regress,3=multiregress). Default '+inttostr(lTestInt)); + +end; + +procedure WriteHelp ; +begin + msg(GetKVers); + msg(' usage: '+ExtractFileName(ParseFileName(paramstr(0)))+' [options] [-t test] [valfilename]' ); + msg('Examples:'); + msg(' '+ ExtractFileName(ParseFileName(paramstr(0)))+' -t 0 test.val'); + msg(' '+ ExtractFileName(ParseFileName(paramstr(0)))+' -r 1024 -p 1000 -m mymask.nii -t 0 test.val'); + msg('Options:'); + msg(' -h : Help displayed'); +end; + +function GetOptionValue(const S: string):string; +var + i: integer; +begin + result := ''; + if (ParamCount < 2) then exit; + for i := 1 to (ParamCount-1) do + if ParamStr(i) = ('-'+S) then begin + result := ParamStr(i+1); + exit; + + end; +end; + +function GetOptionValueInt(lCmd: string; lDefault: integer): integer; +var + lResp : string; +begin + lResp := GetOptionValue(lCmd); + if length(lResp) < 1 then result := lDefault; + try + result := strtoint(lResp); + except + Writeln('Error '+(lResp)+' is not a valid integer.'); + result := lDefault; + end; +end; + +procedure doVLSM(lBinomial: boolean; VALFilename, lMaskFilename,lOutFilename: string); + var + lPrefs: TLDMPrefs ; +begin + lPrefs.NULP := gNPMPrefs.NULP; + if (not lBinomial) then begin //continuous + lPrefs.BMtest := true; + lPrefs.Ttest := true; + lPrefs.Ltest:= false; + end else begin //binomial + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.CritPct := -1; + lPrefs.nPermute := gNPMprefs.nPermute; + lPrefs.Run := 0;{0 except for montecarlo} + lPrefs.VALFilename := VALFilename; + lPrefs.OutName := lOutFilename; + lPrefs.ExplicitMaskName := lMaskFilename; + DoLesion (lPrefs); +end; + +(*procedure TMainForm.ProcessParamStr; +label + 666; +var + lTestInt: integer; + lMaskFilename : string; + lValFilename : string; + lOutFilename : string; +begin + lTestInt := 0; + lMaskFilename := ''; + lValFilename := ''; + lOutFilename := ''; + gnCPUThreads := GetLogicalCpuCount; + ReadIniFile; + // parse parameters + if (HasOption('h')) or (ParamCount = 0) then begin + WriteHelp; + ShowOptions(lTestInt, lMaskFilename, lOutFilename); + goto 666; + end; + if (HasOption('c')) then gnCPUThreads := GetOptionValueInt('c', gnCPUThreads); + if (HasOption('m')) then begin + lMaskFilename := GetOptionValue('m'); + if (not FileExistsEX(lMaskFilename)) then begin + WriteHelp ; + writeln('Can not find masking image '+ lMaskFilename); + + ShowOptions(lTestInt,lMaskFilename,lOutFilename); + goto 666; + end; + end; + if (HasOption('n')) then gnCPUThreads := GetOptionValueInt('n', gNPMprefs.TFCE); + if (HasOption('o')) then begin + lOutFilename := GetOptionValue('o'); + end; + if (HasOption('p')) then gNPMprefs.nPermute := GetOptionValueInt('p', gNPMprefs.nPermute); + if (HasOption('r')) then begin + gNPMPrefs.PlankMB := GetOptionValueInt('r', gNPMPrefs.PlankMB); + ComputePlankSize(gNPMPrefs.PlankMB); + end; + if (HasOption('t')) then lTestInt := GetOptionValueInt('t', lTestInt); + + + lValFilename := (paramstr(ParamCount)); + if (UpCaseExt(lValFilename) <> '.VAL') or (not FileExistsEX(lValFilename)) then begin + Writeln('Error: final option should be an existing file with the .val extension'); + WriteHelp ; + ShowOptions(lTestInt,lMaskFilename,lOutFilename); + goto 666; + end; + + if (lOutFilename = '') then begin + lOutFilename := ChangeFileExtX( lValFilename,'res.nii'); + end; + //show settings + ShowOptions(lTestInt,lMaskFilename,lOutFilename); + Writeln('VAL File: '+lValFilename); + if (lTestInt > 1) and (lMaskFilename = '') then begin + Writeln('Error: this test require you to specify a mask image'); + goto 666; + end; + //run test + Application.ProcessMessages; + case lTestInt of + 0: doVLSM(false, lVALFilename, lMaskFilename,lOutFilename);//continuous : t-test + 1: doVLSM(true, lVALFilename, lMaskFilename,lOutFilename);//binomial: Liebermeister + 2: NPMSingleRegress ( lVALFilename, lMaskFilename,lOutFilename); + 3: NPMMultipleRegressClick( lVALFilename, lMaskFilename,lOutFilename); + + end; + Writeln('Goodbye'); + Application.ProcessMessages; + + + //WriteIniFile; + // stop program loop + 666: + Close; +end; *) + +(*function TestT: string; +var + T: double; + l1,l0,lN: integer; + + lIn: DoubleP0; + lInp: pointer; + //TStat2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +begin + T := 666; + l1 := 16; + l0 := 8; + lN := l0+l1; + createArray64(lInp,lIn,lN); + lIn^[0] := 44 ; + lIn^[1] := 23 ; + lIn^[2] := 41 ; + lIn^[3] := 32 ; + lIn^[4] := 60 ; + lIn^[5] := 58 ; + lIn^[6] := 57 ; + lIn^[7] := 57 ; + lIn^[8] := 55 ; + lIn^[9] := 56 ; + lIn^[10] := 60; + lIn^[11] := 59; + lIn^[12] := 57; + lIn^[13] := 58; + lIn^[14] := 56; + lIn^[15] := 57; + lIn^[16] := 2 ; + lIn^[17] := 22; + lIn^[18] := 24; + lIn^[19] := 22; + lIn^[20] := 18; + lIn^[21] := 12; + lIn^[22] := 15 ; + lIn^[23] := 22; + + TStat2 (lN, l1, lIn, T); + result := floattostr(T); + freemem(lInp); + +end; *) + +procedure TMainForm.FormShow(Sender: TObject); +begin + NPMMsgClear; + NPMMsg(GetkVers); + {$IFNDEF UNIX} {GUILaunch;}{$ENDIF} + LongTimeFormat := 'YYYY-MMM-DD hh:nn:ss'; //delphi TimeToStr + ShortTimeFormat := 'YYYY-MMM-DD hh:nn:ss'; //freepascal TimeToStr + {$IFDEF FPC}{$IFNDEF UNIX} ReadParamStr; {$ENDIF} {$ENDIF} + {$IFDEF benchmark} + //MonteCarloSimulation1.visible := true; + {$ENDIF} + //StartTimer.enabled := true; +end; + +procedure TMainForm.PairedTMenuClick(Sender: TObject); +label + 666; +var + lnSubj,lSubj,lMaskVoxels: integer; + lImageNames: TStrings; + lMaskname,lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Paired T-test [Repeated Measures]'); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: mask selection failed.'); + goto 666; + end; //if not selected + //OpenHdrDlg.FileName := 'c:\vbmdata\mask50.nii.gz'; + lMaskname := OpenHdrDlg.Filename; + + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + ShowMsg('Error reading Mask image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + goto 666; + end; + if not ReadPairedFilenames(lImageNames) then exit; + lnSubj :=lImageNames.Count div 2; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + NPMMsg('Mask = '+lMaskname); + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Number of observations = '+inttostr(lnSubj)); + NPMMsg('Degrees of Freedom = '+inttostr(lnSubj-1)); + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + //show matrix + //MsgStrings (lImageNames); + NPMMsg ('n Subjects = '+inttostr(lnSubj)); + lStr := 'Image,'; + for lSubj := 0 to (lnSubj-1) do + NPMMsg(lImageNames[lSubj]+' <-> '+lImageNames[lSubj+lnSubj]); + if lnSubj < 4 then begin + ShowMsg('Paired t-test error: Requires at least 4 images per group.'); + goto 666; + end; + lOutName := lMaskName; + if not SaveHdrName ('Statistical Map', lOutName) then exit; + //if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + NPMAnalyzePaired (lImageNames, lMaskHdr, lMaskVoxels,lOutName); + //Regress2NPMAnalyze (lImageNames, lMaskHdr, lOutname); + 666: + lImageNames.Free; +end; + +procedure TMainForm.SingleSubjectZScores1Click(Sender: TObject); +label + 666; +var + lnSubj,lMnVoxels: integer; + lG: TStrings; + lMn,lStDev: string; + lMnHdr,lStDevHdr: TMRIcroHdr; +begin + if (not ttestmenu.checked) and (not BMmenu.checked) then begin + ShowMsg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Threads: '+inttostr(gnCPUThreads)); + if not OpenDialogExecute('Select mean image ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: mean selection failed.'); + exit; + end; //if not selected + lMn := OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr(lMn,lMnHdr) then begin + ShowMsg('Error reading mask.'); + exit; + end; + lMnVoxels := ComputeImageDataBytes8bpp(lMnHdr); + if (lMnVoxels < 2) or (not CheckVoxels(lMn,lMnVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mean file size too small.'); + exit; + end; + + if not OpenDialogExecute('Select StDev image ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: StDev selection failed.'); + exit; + end; //if not selected + lStDev := OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr(lStDev,lStDevHdr) then begin + showmessage('Error reading StDev.'); + exit; + end; + if not CheckVoxels(lStDev, lMnVoxels,kMaxImages) then begin + showmessage('Error Mean and StDev must have same size.'); + exit; + end; + NPMMsg('Mean name = '+ lMn); + NPMMsg('Total voxels = '+inttostr(lMnVoxels)); + //next, get 1st group + if not OpenDialogExecute('Select postive group (Z scores positive if this group is brighter)',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; //not sure why TStrings.Create does not work??? + lG.addstrings(OpenHdrDlg.Files); + lnSubj :=OpenHdrDlg.Files.Count; + NPMMsg('Subjects= '+inttostr(lnSubj)); + if not CheckVoxelsGroupX(lG,lMnHdr {lMnVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + NPMzscore (lG, lMnHdr,lStDevHdr); + 666: + lG.Free; +end; + +procedure TMainForm.MultipleRegressClick(Sender: TObject); +var lVALFilename, lMaskname,lOutname: string; +begin + Showmessage('This function has been superceded by nii_stat'); + exit; + + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + ShowMsg('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lVALFilename := MainForm.OpenHdrDlg.Filename; + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + exit; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + lOutName := lMaskName; + if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + NPMMultipleRegressClick(lVALFilename, lMaskname,lOutname); +end; + +procedure TMainForm.SingleRegressClick(Sender: TObject); +var lVALFilename, lMaskname,lOutname: string; +begin + showmessage('This function has been superceded with nii_stat'); + exit; + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then exit; + lVALFilename := MainForm.OpenHdrDlg.Filename; + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then exit; + lMaskname := OpenHdrDlg.Filename; + lOutname := lVALFilename; + NPMSingleRegress (lVALFilename, lMaskname,lOutname); +end; + +procedure TMainForm.AssociatevalfileswithNPM1Click(Sender: TObject); +begin +{$IFNDEF FPC}//unsupported by FreePascal + case MessageDlg('NPM installation:'+kCR+'Do you want .val fiels to automatically open NPM when you double click on their icons?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + id_No: exit; + end; + registerfiletype(kVALNativeExt,'NPM'{key},'NPM',Application.ExeName+',1'); +{$ENDIF} +end; + +procedure TMainForm.threadChange(Sender: TObject); +begin + (sender as tmenuitem).checked := true; + ReadThread; +end; + +(*procedure TMainForm.Countlesionoverlaps1Click(Sender: TObject); +label + 666; +var + lReps,lMax,lInc,lMaskVoxels,lDefault,lTotal,lPct: integer; + lG: TStrings; + lMaskname: string; + lMaskHdr: TMRIcroHdr; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select images to overlap',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if MainForm.OpenHdrDlg.Files.Count < 2 then begin + lTotal := NIFTIhdr_HdrVolumes(MainForm.OpenHdrDlg.Filename); + if lTotal < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE volumes. You selected less than two images.'); + exit; + end; + lG:= TStringList.Create; + for lReps := 1 to lTotal do + lG.Add(MainForm.OpenHdrDlg.Filename+':'+inttostr(lReps) ); + end else begin + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + end; + lMaskname := lG[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lG,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lTotal := lG.Count; + if lTotal > kMaxObs then + lTotal := kMaxObs; //this implemmentation uses 126 bits per voxel - we can not test more than this! + if lTotal > 100 then + lDefault := 100 + else + lDefault := lTotal; + lMax := ReadIntForm.GetInt('Enter maximum number of overlaps to test ', 3,lDefault,lTotal); + lDefault := lMax div 10; + if lDefault < 1 then + lDefault := 1; + lInc := ReadIntForm.GetInt('Enter overlap increment (e.g. if 5; then 5, 10, 15...) ', 1,lDefault,lMax); + lReps := ReadIntForm.GetInt('Enter number of times each increment is tested ', 1,10,100); + lPct := ReadIntForm.GetInt('Only include voxels damaged in N% of patients ', 0,5,100); + + NPMMsg('Voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Scans to permute = '+inttostr(lG.count)); + EvaluatePower (lG,lInc,lMax,lReps,lPct); + + //MakeMean(lG,lMaskHdr, odd((Sender as TMenuItem).tag),false); + 666: + lG.Free; +end; *) + + + +function TMainForm.FirthNPMAnalyze (var lImages: TStrings; var lPredictorList: TStringList; var lMaskHdr: TMRIcroHdr; lnCond,lnCrit: integer; var lSymptomRA: SingleP; var lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: bytep; + lOutImgSum : singleP; + lOutImg: SingleRAp; + {$IFDEF SINGLETHREAD}lnCPUThreads,{$ENDIF} + lCond,lPos,lPlank,lThread,lnDeficit: integer; + lTotalMemory,lVolVox,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadInc,lThreadEnd, lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT, lSum: double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if lnCond < 1 then + exit; + lnPermute := ReadPermute; + if lnPermute > 1 then begin + NPMMsg('NPM does not (yet) support permutation thresholding with Logisitic Regression.'); + lnPermute := 0; + end; + {$IFDEF SINGLETHREAD} + lnCPUThreads := gnCPUThreads; + if gnCPUThreads > 1 then + NPMMsg('July 2007 logistic regression will only use 1 thread. You may want to check for a software update'); + gnCPUThreads := 1; + {$ENDIF} + NPMMsg('Permutations = ' +IntToStr(lnPermute)); + NPMMsg('Logisitic Regression began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + NPMMsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + NPMMsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + //getmem(lOutImgL,lVolVox* sizeof(single)); + getmem(lOutImg,lnCond*sizeof(Singlep)); + for lCond := 1 to lnCond do begin + getmem(lOutImg^[lCond],lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImg^[lCond]^[lPos] := 0; + end; + //InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do + lOutImgSum^[lPos] := 0; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + ProgressBar1.Position := 1; + NPMMsg('Computing plank = ' +Inttostr(lPlank)); + Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + {$IFDEF FIRTHNOTHREAD} + FirthAnalyzeNoThread (lnCond, lnCrit,lnPermute,1,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg); + {$ELSE} + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TFirthThreadStat.Create ((lThread = ((gnCPUThreads+1) div 2)),MainForm, ProgressBar1,lnCond,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + NPMMsg('Thread ' +Inttostr(gThreadsRunning)+' = '+inttostr(lThreadStart)+'..'+inttostr(lThreadEnd)); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + + repeat + Application.processmessages; + until gThreadsRunning = 0; + {$ENDIF} //THREADED + Application.processmessages; + //showmessage('Threads done'); + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadDataLite(gnCPUThreads); //not yet lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + if lnVoxTested < 1 then begin + NPMMsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + //next report findings + NPMMsg('Voxels tested = ' +Inttostr(lnVoxTested)); + NPMMsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + reportBonferroni('Std',lnVoxTested); + //next: save data +(*savedata *) + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + for lCond := 1 to lnCond do begin + reportFDR (lPredictorList[lCond-1]+inttostr(lCond), lVolVox, lnVoxTested, lOutImg^[lCond]); + //reportPermute('L',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,lPredictorList[lCond-1]+inttostr(lCond),'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImg^[lCond],1); + end; +123: +//next: free dynamic memory + //FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + for lCond := 1 to lnCond do + freemem(lOutImg^[lCond]); + freemem(lOutImg); + + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + NPMMsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + NPMMsgSave(lOutNameMod); + + ProgressBar1.Position := 0; + {$IFDEF SINGLETHREAD} + gnCPUThreads := lnCPUThreads; + {$ENDIF} + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + NPMMsg('Unable to complete analysis.'); + ProgressBar1.Position := 0; + {$IFDEF SINGLETHREAD} + gnCPUThreads := lnCPUThreads; + {$ENDIF} +end; + +procedure TMainForm.PenalizedLogisticRegerssion1Click(Sender: TObject); +label + 666; +var + lVol,lMin,lMax,lI,lFact,lnFactors,lSubj,lnSubj,lMaskVoxels,lnCrit: integer; + lImageNames: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lStr: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lTempRA: singleP; + //lBinomial: boolean; +begin + Showmessage('This function has been superceded by nii_stat'); + exit; + // lBinomial := false; + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not GetValX(lnSubj,lnFactors,lMultiSymptomRA,lImageNames,lnCrit{,binom},lPredictorList) then + goto 666; + if (lnSubj < 2) or (lnFactors < 1) then begin + showmessage('This analysis requires at least 2 participants and one factor'); + goto 666; + end; + WarnIfLowNCrit(lnSubj,lnCrit); + lTemp4D := CreateDecompressed4D(lImageNames); + lMaskname := lImageNames[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st image: '+lMaskname); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + case MessageDlg('Do you want to add lesion volume as a regressor?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrYes: begin + //add a new condition called lesionvolume - create a new larger array for data + NPMMsg('Computing lesion volumes...'); + lPredictorList.Add('LesionVolume'); + GetMem(lTempRA,lnSubj*lnFactors*sizeof(single)); + for lI := 1 to (lnSubj*lnFactors) do + lTempRA^[lI] := lMultiSymptomRA^[lI]; + Freemem(lMultiSymptomRA); + GetMem(lMultiSymptomRA,lnSubj*(lnFactors+1)*sizeof(single)); + for lI := 1 to (lnSubj*lnFactors) do + lMultiSymptomRA^[lI] := lTempRA^[lI]; + Freemem(lTempRA); + //now create the new factor + lI := lnSubj*lnFactors; + for lSubj := 1 to lnSubj do + lMultiSymptomRA^[lI+lSubj] := ComputeLesionVolume(lImageNames[lSubj-1]); + //ensure there is variability in this regressor + lMin := round(lMultiSymptomRA^[lI+1]); + lMax := round(lMultiSymptomRA^[lI+1]); + for lSubj := 1 to lnSubj do begin + lVol := round(lMultiSymptomRA^[lI+lSubj]); + if lVol < lMin then lMin := lVol; + if lVol > lMax then lMax := lVol; + end; + if (lMin < 0) then begin + showmessage('Regression aborted: Error computing lesion volumes.'); + goto 666; + end; + if (lMin = lMax) then begin + showmessage('Regression aborted: no variability in lesion volume.'); + goto 666; + end; + inc(lnFactors); + end; //if user decides to include lesion volume + end; //case + + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + SaveHdrDlg.Filename := loutname; + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Firth Penalized regression is still beta software...'); + NPMMsg('Number of participants: '+inttostr(lnSubj)); + NPMMsg('Number of factors: '+inttostr(lnFactors)); + NPMMsg('Threads: '+inttostr(gnCPUThreads)); + //next - header shows factor names + lStr :='imagename'; + for lFact := 1 to lnFactors do + lStr := lStr+','+lPredictorList[lFact-1]; + NPMMsg(lStr); + For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lStr := lStr+','+realtostr(lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)],2); + end; + NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+lStr ); + end; + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + lOutName := lOutName+'.nii.gz'; + if not SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + FirthNPMAnalyze (lImageNames,lPredictorList,lMaskHdr,lnFactors,lnCrit, lMultiSymptomRA, lOutName); + 666: + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); +end; + +(*function ComputeIntersection ( lAname,lBname: string; var lUnion,lIntersection,lAnotB,lBnotA: integer): boolean; +label 667; +var + lOutName,lOutNameMod: string; + lVolVox,lVolVoxA,lVox: integer; + lImgA,lImgB: SingleP; + + lMaskHdr: TMRIcroHdr; + lA,lB: boolean; +begin + lUnion:= 0; + lIntersection := 0; + lAnotB := 0; + lBnotA := 0; + result := false; + //read A + if not NIFTIhdr_LoadHdr(lAname,lMaskHdr) then begin + showmessage('Error reading image A - '+lAname); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + getmem(lImgA,lVolVox*sizeof(single)); + if not LoadImg(lAname, lImgA, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + lVolVoxA := lVolVox; + //read B + if not NIFTIhdr_LoadHdr(lBname,lMaskHdr) then begin + showmessage('Error reading image B - '+lBname); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVoxA <> lVolVox) or (lVolVox < 1) then goto 667; + getmem(lImgB,lVolVox*sizeof(single)); + if not LoadImg(lBname, lImgB, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + for lVox := 1 to lVolVox do begin + lA := (lImgA^[lVox] <> 0); + lB := (lImgB^[lVox] <> 0); + if lA and lB then begin + //fx(lVox,lImgA^[lVox],lImgB^[lVox]); + inc(lIntersection); + end; + if lA or lB then + inc(lUnion); + if lA and not lB then + inc(lAnotB); + if lB and not lA then + inc(lBnotA); + + end; + freemem(lImgA); + freemem(lImgB); + result := true; + 667: +end; + +procedure TMainForm.ZtoP1Click(Sender: TObject); +var +lAname,lBname: string; var lUnion,lIntersection,lAnotB,lBnotA: integer; +begin +//removed + lAName := 'C:\mri\roc\p2.nii.gz'; + lBName := 'C:\mri\roc\RBD35.voi'; + if not ComputeIntersection ( lAName,lBName,lUnion,lIntersection,lAnotB,lBnotA) then + NPMMsg('Error'); + NPMMsg( lAName+' '+lBName+' I'+inttostr(lIntersection)+' U'+inttostr(lUnion)+' AnotB'+inttostr(lAnotB)+' BnotA'+inttostr(lBnotA)); + +end; *) + + +(*procedure TMainForm.ComputeIntersectionandUnion1Click(Sender: TObject); +label + 666; +var + lUnion,lIntersection,lAnotB,lBnotA, + lnSubj,lSubj,lMaskVoxels,lnAdditionalFactors: integer; + lImageNames: TStrings; + lMaskname, + lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; + X: PMatrix; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Compute intersection [A and B] and union [A or B] for a series of images'); + + + if not ReadPairedFilenamesReg(lImageNames,X,lnAdditionalFactors) then exit; + lnSubj :=lImageNames.Count div 2; + if lnAdditionalFactors > 1 then + DelMatrix(X, lnAdditionalFactors, lnSubj); + + lMaskname :=lImageNames[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading first image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Image file size too small.'); + goto 666; + end; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from first image.'); + goto 666; + end; + + + NPMMsg ('n Subjects = '+inttostr(lnSubj)); + for lSubj := 0 to (lnSubj-1) do begin + lStr := 'A=,'+lImageNames[lSubj]+',B=,'+lImageNames[lSubj+lnSubj]; + ComputeIntersection ( lImageNames[lSubj],lImageNames[lSubj+lnSubj],lUnion,lIntersection,lAnotB,lBnotA); + lStr := lStr + ',A and B=,'+inttostr(lIntersection); + lStr := lStr + ',A or B=,'+inttostr(lUnion); + lStr := lStr + ',A not B=,'+inttostr(lAnotB); + lStr := lStr + ',B not A=,'+inttostr(lBnotA); + NPMMsg(lStr); + end; + + //Msg('Mask = '+lMaskname); + //Msg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Number of observations = '+inttostr(lnSubj)); + 666: + lImageNames.Free; +end; //compute intersection and union + *) + +(*procedure TMainForm.ROCbinomialdeficit1Click(Sender: TObject); +begin + testROC; +end; + +procedure TMainForm.ROCcontinuousdeficit1Click(Sender: TObject); +begin + testROC2; +end; *) + +function isBinom ( lRA: singleP; lnObs: integer): boolean; +var + lI: integer; +begin + result := false; + if lnObs < 1 then exit; + for lI := 1 to lnObs do + if (lRA^[lI] <> 0) and (lRA^[lI] <> 1) then + exit; + result := true; +end; + +procedure Means ( lBinomRA,lContRA: singleP; lnObs: integer); +var + lI,ln0: integer; + lMeans0, lMeans1: double; +begin + lMeans0 := 0; + lMeans1 := 0; + ln0 := 0; + if lnObs < 1 then exit; + for lI := 1 to lnObs do begin + if (lBinomRA^[lI] = 0) then begin + inc(ln0); + lMeans0 := lMeans0 + lContRA^[lI]; + end else + lMeans1 := lMeans1 + lContRA^[lI]; + end; + if ln0 > 0 then + lMeans0 := lMeans0 / ln0; + if ln0 < lnObs then + lMeans1 := lMeans1 / (lnObs-ln0); + npmform.MainForm.memo1.lines.add('mean volume for '+inttostr(ln0)+' people who scored 0 is = '+floattostr(lmeans0)); + npmform.MainForm.memo1.lines.add('mean volume for '+inttostr(lnObs-ln0)+' people who scored 1 is = '+floattostr(lmeans1)); +end; + +function AUCbinomcontT (lBinomdataRA,lContdataRA: singlep; lnSubj :integer; var lT: double): double; +var + lIn : DoubleP0; + lnGroup0,lnGroup1,lI: integer; +begin + result := 0.5; + if lnSubj < 1 then + exit; + Getmem(lIn,lnSubj*sizeof(double)); + lnGroup0 := 0; + lnGroup1 := 0; + for lI := 1 to lnSubj do begin + if lBinomdataRA^[lI] = 0 then begin + lIn^[lnGroup0] := lContdataRA^[lI]; + inc (lnGroup0); + end else begin + inc (lnGroup1); + lIn^[lnSubj-lnGroup1] := lContdataRA^[lI]; + + end; + end; + result := continROC (lnSubj, lnGroup0, lIn); + TStat2 (lnSubj, lnGroup0, lIn,lT); + freemem(lIn); +end; + + +procedure Contrast(lBehavName,lROIname: string; lBehavRA,lLesionVolRA: singleP; lnSubj: integer); +var + lDF: integer; + lROC,lT,lP: double; +begin + if isBinom (lBehavRA,lnSubj) then begin + lROC := AUCbinomcontT (lBehavRA,lLesionVolRA, lnSubj,lT); + lDF := lnSubj-2; + lP := pTdistr(lDF,lT); + Means ( lBehavRA,lLesionVolRA, lnSubj); + + npmform.MainForm.memo1.lines.add('ROI=,'+lROIname+',Behav=,'+lBehavName+', Area Under Curve=,'+floattostr(lROC)+', T('+inttostr(lDF)+')=,'+floattostr(lT)+',p<,'+floattostr(lp)); + end else begin + lROC := AUCcontcont (lBehavRA,lLesionVolRA, lnSubj); + npmform.MainForm.memo1.lines.add('ROI=,'+lROIname+',Behav=,'+lBehavName+', Area Under Curve = '+floattostr(lROC)); + end; + //xxx +end; + (* +procedure ROIanalysis(var lROInames,lImageNames: TStrings; var lVALFilename: string); +label + 666; +var + lROI,lnROI,lVol,lMin,lMax,lI,lFact,lnFactors,lSubj,lnSubj,lMaskVoxels,lnCrit: integer; + //lROInames,lImageNames: TStrings; + lPredictorList: TStringList; + lVolStr,lTemp4D,lOutName,lStr: string; + lBehav: single; + lROIvolRA: doubleP; + lMultiSymptomRA,lLesionVolRA,lBehavRA: singleP; + lError: boolean; +begin + lnROI := lROINames.Count; + if lnROI < 1 then begin + showmessage('You need to select at least one ROI.'); + goto 666; + end; + //lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + if not GetValCore ( lVALFilename,lnSubj,lnFactors,lMultiSymptomRA,lImageNames,lnCrit,lPredictorList) then + goto 666; + lTemp4D := CreateDecompressed4D(lImageNames); + if (lnSubj < 1) or (lnFactors < 1) then begin + showmessage('This analysis requires at least 1 participant and one factor'); + goto 666; + end; + NPMMsgClear; + NPMMsg(GetKVers); + NPMmsg('Analysis began = ' +TimeToStr(Now)); + NPMMsg('VAL file name: '+MainForm.OpenHdrDlg.Filename); + NPMMsg('Number of participants: '+inttostr(lnSubj)); + NPMMsg('Number of factors: '+inttostr(lnFactors)); + NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + //next - header shows factor names + lStr :='imagename'; + for lFact := 1 to lnFactors do + lStr := lStr+','+lPredictorList[lFact-1]; + for lROI := 1 to lnROI do + lStr := lStr+','+lROInames[lROI-1]; + NPMMsg(lStr+',LesionVolume'); + lError := false; + Getmem(lROIVolRA, lnSubj*lnROI*sizeof(double)); + Getmem(lLesionVolRA, lnSubj*lnROI*sizeof(single)); + Getmem(lBehavRA, lnSubj*lnFactors*sizeof(single)); + for lROI := 1 to lnROI do begin + //if not ComputeIntersection ( lImageNames.Strings[lSubj-1],lROInames[lROI-1],lUnion,lIntersection,lAnotB,lBnotA) then + if not ComputeOverlap (lROInames[lROI-1],lImageNames, lROIvolRA^[lROI], singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1])) then begin + NPMmsg('Error computing overlap'); + goto 666; + end; + end; + For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lBehav := lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)]; + lStr := lStr+','+realtostr(lBehav,2); + lBehavRA^[((lFact-1)*lnSubj) +lSubj] := lBehav; + end; + for lROI := 1 to lnROI do + lStr := lStr+','+floattostr(lLesionVolRA^[((lROI-1)*lnSubj) +lSubj]); + lVolStr := floattostr(ComputeLesionVolume(lImageNames.Strings[lSubj-1])); + NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+lStr +','+lVolStr ); + end; + for lROI := 1 to lnROI do begin + for lFact := 1 to lnFactors do begin + Contrast(lPredictorList[lFact-1],lROInames[lROI-1],singlep(@lBehavRA^[((lFact-1)*lnSubj)+1]),singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1]),lnSubj);//,((lFact-1)*lnSubj),((lROI-1)*lnSubj)); + end; //for each factor + end; //for each ROI + for lROI := 1 to lnROI do begin + NPMMsg( lROInames[lROI-1] +' volume = '+floattostr(lROIvolRA^[lROI]) ) + end; //for each ROI + Freemem(lLesionVolRA); + Freemem(lBehavRA); + Freemem(lROIvolRA); +666: + lROInames.free; + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + NPMmsg('Analysis finished = ' +TimeToStr(Now)); +end; *) + + +procedure TMainForm.ROIanalysis1Click(Sender: TObject); +label + 666; +var + lROI,lnROI,lVol,lMin,lMax,lI,lFact,lnFactors,lSubj,lnSubj,lMaskVoxels,lnCrit: integer; + lROInames,lImageNames: TStrings; + lPredictorList: TStringList; + lVolStr,lTemp4D,lOutName,lStr: string; + lBehav: single; + lROIvolRA: doubleP; + lMultiSymptomRA,lLesionVolRA,lBehavRA: singleP; + lError: boolean; +begin + if not OpenDialogExecute('Select regions of interest',true,false,kImgPlusVOIFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lROInames:= TStringList.Create; + lROInames.addstrings(OpenHdrDlg.Files); + lnROI := lROINames.Count; + if lnROI < 1 then begin + showmessage('You need to select at least one ROI.'); + exit; + end; + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + if not GetValX(lnSubj,lnFactors,lMultiSymptomRA,lImageNames,lnCrit,lPredictorList) then + goto 666; + lTemp4D := CreateDecompressed4D(lImageNames); + if (lnSubj < 1) or (lnFactors < 1) then begin + showmessage('This analysis requires at least 1 participant and one factor'); + goto 666; + end; + NPMMsgClear; + NPMMsg(GetKVers); + NPMmsg('Analysis began = ' +TimeToStr(Now)); + NPMMsg('VAL file name: '+MainForm.OpenHdrDlg.Filename); + NPMMsg('Number of participants: '+inttostr(lnSubj)); + NPMMsg('Number of factors: '+inttostr(lnFactors)); + NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + //next - header shows factor names + lStr :='imagename'; + for lFact := 1 to lnFactors do + lStr := lStr+','+lPredictorList[lFact-1]; + for lROI := 1 to lnROI do + lStr := lStr+','+lROInames[lROI-1]; + NPMMsg(lStr+',LesionVolume'); + lError := false; + Getmem(lROIVolRA, lnSubj*lnROI*sizeof(double)); + Getmem(lLesionVolRA, lnSubj*lnROI*sizeof(single)); + Getmem(lBehavRA, lnSubj*lnFactors*sizeof(single)); + for lROI := 1 to lnROI do begin + //if not ComputeIntersection ( lImageNames.Strings[lSubj-1],lROInames[lROI-1],lUnion,lIntersection,lAnotB,lBnotA) then + if not ComputeOverlap (lROInames[lROI-1],lImageNames, lROIvolRA^[lROI], singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1])) then begin + NPMmsg('Error computing overlap'); + goto 666; + end; + end; + For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lBehav := lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)]; + lStr := lStr+','+realtostr(lBehav,2); + lBehavRA^[((lFact-1)*lnSubj) +lSubj] := lBehav; + end; + for lROI := 1 to lnROI do + lStr := lStr+','+floattostr(lLesionVolRA^[((lROI-1)*lnSubj) +lSubj]); + lVolStr := floattostr(ComputeLesionVolume(lImageNames.Strings[lSubj-1])); + NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+lStr +','+lVolStr ); + end; + for lROI := 1 to lnROI do begin + for lFact := 1 to lnFactors do begin + Contrast(lPredictorList[lFact-1],lROInames[lROI-1],singlep(@lBehavRA^[((lFact-1)*lnSubj)+1]),singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1]),lnSubj);//,((lFact-1)*lnSubj),((lROI-1)*lnSubj)); + end; //for each factor + end; //for each ROI + for lROI := 1 to lnROI do begin + NPMMsg( lROInames[lROI-1] +' volume = '+floattostr(lROIvolRA^[lROI]) ) + end; //for each ROI + Freemem(lLesionVolRA); + Freemem(lBehavRA); + Freemem(lROIvolRA); +666: + lROInames.free; + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + NPMmsg('Analysis finished = ' +TimeToStr(Now)); +end; + + +procedure TMainForm.Masked1Click(Sender: TObject); +var + lFilename,lMaskname: string; + lPos: Integer; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + exit; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + balance(lFilename,lMaskname,(Sender as TMenuItem).tag); + end; +end; + +function Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; +var + lImg8: ByteP; + lImg: SingleP; + lHdr: TMRIcroHdr; + lVolVox,lVox: integer; + lMin,lMax: single; + lModeLo,lModeHi,lIntercept,lSlope: single; + lOutNameMod: string; +begin + //lOutName := lMaskHdr.ImgFileName; + result := false; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + if not NIFTIhdr_LoadHdr(lImageName,lHdr) then begin + showmessage('Error reading '+lImageName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + getmem(lImg8,lVolVox*sizeof(byte)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; +if lZeroThresh then begin + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.nii'); + + lMin := 0; + lMax := 0 +end else begin + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.voi'); + + lMin := lIMg^[1]; + for lVox := 1 to lVolVox do + if lImg^[lVox] < lMin then lMin := lIMg^[lVox]; + + lMax := lIMg^[1]; + for lVox := 1 to lVolVox do + if lImg^[lVox] > lMax then lMax := lIMg^[lVox]; + for lVox := 1 to lVolVox do + lImg8^[lVox] := 0; + lMax := ((lMax-lMin) / 2)+lMin; +end; + for lVox := 1 to lVolVox do + if lImg^[lVox] > lMax then + lImg8^[lVox] := lNonZeroVal; + NPMMsg('Creating ' +lOutNameMod+' Threshold = '+floattostr(lMax)); + NIFTIhdr_SaveHdrImg8(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lImg8,1); + freemem(lIMg8); + freemem(lImg); +end; + + +procedure TMainForm.Binarizeimages1Click(Sender: TObject); +var + lFilename: string; + lPos: Integer; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + Binarize(lFilename,1,false); + //Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; + end; + NPMMsg('Done'); +end; + + + +procedure TMainForm.Setnonseroto1001Click(Sender: TObject); +var + lFilename: string; + lPos: Integer; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + Binarize(lFilename,100,true); + //Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; + end; +end; + +procedure TMainForm.Savetext1Click(Sender: TObject); +begin + SaveHdrDlg.Title := 'Save file as comma separated values (to open with Excel)'; + SaveHdrDlg.Filter := 'Comma Separated (*.csv)|*.csv|Text (*.txt)|*.txt'; + SaveHdrDlg.DefaultExt := '*.csv'; + if not SaveHdrDlg.Execute then exit; + Memo1.Lines.SaveToFile(SaveHdrDlg.Filename); +end; + +(* +function TMainForm.MakeSubtract (lPosName,lNegName: string): boolean; +var + lNegImg,lImg,lOutImg: SingleP; + lHdr,lNegHdr: TMRIcroHdr; + lVolVox,lVox: integer; + lOutNameMod: string; +begin + result := false; + if not NIFTIhdr_LoadHdr(lPosName,lHdr) then begin + ShowMsg('Error reading '+lPosName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + + if not NIFTIhdr_LoadHdr(lNegName,lNegHdr) then begin + showmessage('Error reading '+lNegName); + exit; + end; + if lVolVox <> (lNegHdr.NIFTIhdr.dim[1]*lNegHdr.NIFTIhdr.dim[2]* lNegHdr.NIFTIhdr.dim[3]) then begin + ShowMsg('Volumes differ'); + exit; + + end; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + getmem(lNegImg,lVolVox*sizeof(single)); + if not LoadImg(lNegHdr.ImgFileName, lNegImg, 1, lVolVox,round(lNegHdr.NIFTIhdr.vox_offset),1,lNegHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lNegHdr.ImgFileName); + exit; + end; + getmem(lOutImg,lVolVox*sizeof(single)); + for lVox := 1 to lVolVox do + lOutImg^[lVox] := lImg^[lVox] - lNegImg^[lVox]; + + + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; + lOutNameMod := ChangeFilePrefixExt(lPosName,'subtract_','.hdr'); + NPMMsg(lPosName+' - ' + lNegName+ ' = '+lOutNameMod); + NIFTIhdr_SaveHdrImg(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lOutImg,1); + + + freemem(lImg); + freemem(lOutImg); + freemem(lNegImg); +end;//makesubtract +*) + +(*procedure TMainForm.Subtract1Click(Sender: TObject); +var + lPosName,lNegName: string; +begin + if not OpenDialogExecute('Select positive',false,false,kImgPlusVOIFilter) then + exit; + lPosName := OpenHdrDlg.FileName; + if not OpenDialogExecute('Select negative',false,false,kImgPlusVOIFilter) then + exit; + lNegName := OpenHdrDlg.FileName; + MakeSubtract (lPosName,lNegName); + +end; *) + + + + + + {$IFDEF UNIX} + + +initialization + {$I npmform.lrs} +{$ELSE} //not unix: windows +initialization +{$IFDEF FPC} + {$I npmform.lrs} + {$ENDIF}//FPC + OleInitialize(nil); + +finalization + OleUninitialize +{$ENDIF} //Windows + +end. + \ No newline at end of file diff --git a/npm/brunner.o b/npm/brunner.o new file mode 100644 index 0000000..ae32e9e Binary files /dev/null and b/npm/brunner.o differ diff --git a/npm/brunner.pas b/npm/brunner.pas new file mode 100755 index 0000000..431eaec --- /dev/null +++ b/npm/brunner.pas @@ -0,0 +1,547 @@ +unit brunner; + +interface +uses define_types,math,Distr; + +procedure tBM (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var ltBM,lDF: double); +procedure genBMsim (lnSubj: integer; var lOrigOrder: DoubleP0); +function BMzVal(lnSubj, lnGroup0: integer; ltBM,lDF: double): double; +function continROC (lnSubj, lnGroup0: integer; var lIn: DoubleP0): single; +function continROC2 (lnSubj: integer; var lInIV, lInDV: DoubleP0): single; + +const + knPermute= 20000; + knSim = 15; +var + gSimRA: array [1..knSim] of DoubleP; + gSimRAp: array [1..knSim] of pointer; +implementation + + +function BMzVal(lnSubj,lnGroup0 : integer; ltBM,lDF: double): double; +//can be approximated by result := TtoZ(ltBM,lDF); +var + lnSmallGroup,lJump,lEstimate,i,tie: integer; + ltBMs : double; + lSwap: boolean; +begin + //result := TtoZ(ltBM,lDF); exit; + lSwap := false; + ltBMs := ltBM; + result := 0; + tie := 0; + if (lnSubj div 2) > lnGroup0 then + lnSmallGroup := lnGroup0 + else + lnSmallGroup := lnSubj-lnGroup0; + if lnSmallGroup < 1 then exit; + if lnSmallGroup > knSim then begin + result := TtoZ(ltBMs,lDF); + exit; + end; + if (lnSubj div 2) < lnGroup0 then begin + ltBMs := -ltBMs; + lSwap := not lSwap; //distributions are not symetrical + end; + lEstimate := knPermute div 2; //start half way through data + lJump := lEstimate div 2; + for i := 1 to 9 do begin + if gSimRA[lnSmallGroup]^[lEstimate] > ltBMs then + lEstimate := lEstimate - lJump + else + lEstimate := lEstimate + lJump; + lJump := (lJump+1) div 2; + end; + if lEstimate < (knPermute div 2) then begin //p < 0.5 count up for less extreme + i := lEstimate-lJump-lJump; + if i < 1 then + i := 1; + while ltBMs > gSimRA[lnSmallGroup]^[i] do begin + inc(i); + end; + if ltBMs = gSimRA[lnSmallGroup]^[i] then begin + while ltBMs = gSimRA[lnSmallGroup]^[i] do begin + inc(i); + dec(tie); + end; + dec(tie); + end; + end else begin //p < 0.5 count down for less extreme + i := lEstimate+lJump+lJump; + if i >= knPermute then + i := knPermute; + while ltBMs < gSimRA[lnSmallGroup]^[i] do + dec(i); + if ltBMs = gSimRA[lnSmallGroup]^[i] then begin + while ltBMs = gSimRA[lnSmallGroup]^[i] do begin + dec(i); + inc(tie); + end; + inc(tie); + end; + i := i - 1; //indexed from 1 not 0 + end; + //result := (i+(tie/2)); + //result := (1-( (i+(tie/2))/knPermute)); + result := pNormalInv(1-( (i+(tie/2))/knPermute)); + if lSwap then + result := -result; +end; + +procedure Sort (lo, up: integer; var r:DoubleP); +//62ms Shell Sort http://www.dcc.uchile.cl/~rbaeza/handbook/algs/4/414.sort.p.html +label 999; +var + d, i, j : integer; + tempr : single; +begin + d := up-lo+1; + while d>1 do begin + if d<5 then + d := 1 + else + d := trunc( 0.45454*d ); // Do linear insertion sort in steps size d + for i:=up-d downto lo do begin + tempr := r^[i]; + j := i+d; + while j <= up do + if tempr > r^[j] then begin + r^[j-d] := r^[j]; + j := j+d + end else + goto 999; {*** break ***} + 999: + r^[j-d] := tempr + end + end +end; //sort + +procedure GenPermute (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0); +var + lInc,lRand: integer; + lSwap: double; +begin + //next lines commented out - this check should be done before inner loop + //if lnSubj < 2 then //can not randomize order of single value + // exit; + //Move(src,dest,count); + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + //for lInc := 1 to lnSubj do + // lRanOrder[lInc-1] := lOrigOrder[lInc-1]; + for lInc := lnSubj downto 2 do begin + lRand := Random(lInc); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure genBMsim (lnSubj: integer; var lOrigOrder: DoubleP0); +//1.) creates kSim random permutations of the data +//2.) sorts permutations +var + lRanOrderp: pointer; + lRanOrder: DoubleP0; + lInc,lnSmallGroup: integer; + lOutT,lDF: double; +begin + if (lnSubj < 1) or (knPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + //lnSmallGroup := lnGroup0; + //if lnSmallGroup > knSim then exit; + for lnSmallGroup := 1 to knSim do begin + //RandSeed := 128; //same order for all voxels + for lInc := 1 to knPermute do begin + GenPermute(lnSubj, lOrigOrder,lRanOrder); //generate random order of participants + tBM (lnSubj, lnSmallGroup, lRanOrder,lOutT,lDF); + gSimRA[lnSmallGroup]^[lInc] := lOutT; + end; + //next sort permutes... + Sort(1,knPermute,gSimRA[lnSmallGroup]); + end; + freemem(lRanOrderp); +end; + + + +procedure SortDouble (first, last: integer; var DynDataRA:DoubleP0; var lGroupRA: Bytep0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; + swapbyte: byte; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 0 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + swapbyte := lGroupRA^[i]; + lGroupRA^[i] := lGroupRA^[l]; + lGroupRA^[l] := swapbyte; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + +procedure RankArray (first, last: integer; var DynDataRA:DoubleP0; var lGSum: double); +var + lnTies,lPos,lStartPos,lRankPos: integer; + lScore,lTie : double; +begin + lGSum := 0; + lPos := first; + while lPos <= last do begin + lStartPos := lPos; + lScore := DynDataRA^[lPos]; + while (lPos < last) and (lScore = DynDataRA^[lPos+1]) do + inc(lPos); //count ties + lnTies := lPos - lStartPos; + lTie := (lnTies) *0.5; + if lnTies > 0 then begin + lnTies := lnTies+1;//tj on page 135 of Siegel + lGSum := lGSum + (( (lnTies*lnTies*lnTies) - lnTies)/12); + //showmessage(inttostr(lnTies)+' '+realtostr(lGSum,4)); + end; + for lRankPos := lStartPos to lPos do + DynDataRA^[lRankPos] := lStartPos+1+lTie; + inc(lPos);//start with next value + end; +end; + +procedure LocalRank (first, last: integer; var DynDataRA,DynDataRAX:DoubleP0; var lGroupRA: Bytep0); +var + lGroup,lnTies,lPos,lStartPos,lRankPos,lLocalRank: integer; + lScore,lTie : double; +begin + for lGroup := 0 to 1 do begin + lPos := first; + lLocalRank := 0; + while lPos <= last do begin + if lGroupRA^[lPos] = lGroup then begin// + inc(lLocalRank); + lStartPos := lPos; + lScore := DynDataRA^[lPos]; + lnTies := 0; + while (lPos < last) and (0.001 > abs (lScore - DynDataRA^[lPos+1]) ) do begin + inc(lPos); //count ties + if lGroupRA^[lPos] = lGroup then + inc(lnTies); + end; + lTie := (lnTies) *0.5; + for lRankPos := lStartPos to lPos do begin + if lGroupRA^[lRankPos] = lGroup then + DynDataRAX^[lRankPos] := (lLocalRank+lTie); + end; + lLocalRank := lLocalRank + lnTies; + end; //if in group + inc(lPos);//start with next value + end; //while... for each observation + end; //for each group +end; + +(*procedure tBM (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var ltBM,lDF: double); +//this is a t-test - only use to test BM!!! +var + i,lnGroupY,lnGroupX: integer; + lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lS: double; +begin + lnGroupX := lnGroup0; + lnGroupY := lnSubj - lnGroupX; + lDF := lnSubj -1; + if (lnGroupX < 1) or (lnGroupY < 1) then begin //need at least 1 subj in each group + ltBM := 0; + exit; + end; + lSumx := 0; + lSumSqrX := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + //lVal := lIn[i]; + lsumx := lsumx + lIn[i]; + lSumSqrX := lSumSqrX + sqr(lIn[i]); + end; + //lMnX := lsumx/lnGroupX; + lVarx := (lnGroupX*lSumSqrX) - Sqr(lsumx); + if lnGroupX > 1 then + lVarX := lVarX / (lnGroupX*(lnGroupX-1)) + else + lVarx := 0; + lSumy := 0; + lSumSqry := 0; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lsumy := lsumy + lIn[i]; + lSumSqry := lSumSqry + sqr(lIn[i]); + end; //for each sub + //lMnY := lsumy/lnGroupY; + lVary := (lnGroupY*lSumSqrY) - Sqr(lsumy); + if lnGroupY > 1 then + lVary := lVary / (lnGroupY*(lnGroupY-1)) + else + lVary := 0; + //lm := (lsumx/lnGroupX)-(lsumy/lnGroupY); //mean effect size lmnx - lmny; + //ldf := lnSubj - 2; + ls := sqrt( ( ((lnGroupX - 1) * lvarx + (lnGroupY - 1) * lvary) / (lnSubj - 2){ldf}) ) ; + ls := ls * sqrt(1 / lnGroupX + 1 / lnGroupY); //note - to get here both lnx and lny > 0 + if ls = 0 then + ltBM := 0 + else + ltBM := ( ((lsumx/lnGroupX)-(lsumy/lnGroupY))/ls);//t = lm / ls; +end; *) + +procedure tBM (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var ltBM,lDF: double); +var + lObspX,lObsp: pointer; + lObsX,lObs: Doublep0; + lGroupRA: Bytep0; + i,ln0,ln1: integer; + lZ,lGSum: double; + lSum0,lSum1,lMean0,lMean1,lSqr0,lSqr1,lk0,lk1: double; +begin + createArray64(lObsp,lObs,lnSubj); + getmem(lGroupRA,lnSubj*sizeof(Byte)); + createArray64(lObspX,lObsX,lnSubj); + ln0 := 0; + ln1 := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lObs[i] := lIn[i]; + if i < lnGroup0 then //group0 + lGroupRA^[i] := 0 + else + lGroupRA^[i] := 1; + end; //for each sub + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + inc(ln0) //number of observations in group zero + else + inc(ln1); //number of observations in group one + if (ln0 > 1) and (ln1 > 1) then begin + SortDouble(0,lnSubj-1,lObs,lGroupRA); + RankArray(0,lnSubj-1,lObs,lGSum); + lSum0 := 0; + lSum1 := 0; + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lSum0 := lSum0 + lObs^[i] + else + lSum1 := lSum1 + lObs^[i]; + lMean0 := lSum0 / ln0; + lMean1 := lSum1 / ln1; + //fx(lmean0,lMean1); + lSqr0 := 0; + lSqr1 := 1; + lk0 := (ln0+1)/2; + lk1 := (ln1+1)/2; + LocalRank(0,lnSubj-1,lObs,lObsX,lGroupRA); + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lSqr0 := lSqr0 + Sqr(lObs^[i]-lObsX^[i]-lMean0+lk0) + else + lSqr1 := lSqr1 + Sqr(lObs^[i]-lObsX^[i]-lMean1+lk1); + lSqr0 := (1/(ln0-1))*lSqr0; + lSqr1 := (1/(ln1-1))*lSqr1; + + lZ := -(ln0*ln1*(lMean1-lMean0))/((ln0+ln1)*sqrt((ln0*lSqr0)+(ln1*lSqr1) ) ); + lDF := sqr(ln0*lSqr0+ln1*lSqr1) / ( (sqr(ln0*lSqr0)/(ln0-1)) + (sqr(ln1*lSqr1)/(ln1-1)) ) ; + //lZ := TtoZ(lZ,lDF); + ltBM := lZ; + //fx(lZ,lDF); + end else //>1 + ltBM := 0; + freemem(lObsp); + freemem(lObspX); + freemem(lGroupRA); +end; //tBM (**) + +procedure SortDoubleP0 (first, last: integer; var DynDataRA:DoubleP0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; + //swapbyte: byte; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 0 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + + +function continROC (lnSubj, lnGroup0: integer; var lIn: DoubleP0): single; +//see equation 1 of Obuchiwski, Statistics in Medicine, 25: 481-493 +var + lSum,lV: double; + linc0,linc1,lnGroup1,i: integer; + lObsp0,lObsp1: pointer; + lObs0,lObs1: Doublep0; + +begin + result := -1; + lnGroup1 := lnSubj - lnGroup0; + if (lnGroup1 < 1) or (lnGroup0 < 1) then exit; + createArray64(lObsp1,lObs1,lnSubj); + createArray64(lObsp0,lObs0,lnSubj); + for i := 0 to (lnGroup0-1) do //for each subject without disease + lObs0[i] := lIn[i]; + SortDoubleP0(0,lnGroup0-1,lObs0); + + for i := lnGroup0 to (lnSubj-1) do //for each subject with disease + lObs1[i-lnGroup0] := lIn[i]; + SortDoubleP0(0,lnGroup1-1,lObs1); + lSum := 0; + for linc0 := 0 to (lnGroup0-1) do begin + for linc1 := 0 to (lnGroup1-1) do begin + if (lObs0^[linc0]) > (lObs1^[linc1]) then + lV := 1 + else if (lObs0^[linc0]) = (lObs1^[linc1]) then //tie + lV := 0.5 + else + lV := 0; + + lSum := lV + lSum; + end;//for group1 + end;//for group0 + lSum := lSum * (1/ (lnGroup0*lnGroup1 ) ); + result := lSum; + + freemem(lObsp1); + freemem(lObsp0); +end; //continROC + +procedure SortDoubleDouble (first, last: integer; var DynDataRA, lGroupRA: DoubleP0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap,swapbyte: double; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 0 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + swapbyte := lGroupRA^[i]; + lGroupRA^[i] := lGroupRA^[l]; + lGroupRA^[l] := swapbyte; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + + +function continROC2 (lnSubj: integer; var lInIV, lInDV: DoubleP0): single; +//see equation 9 of Obuchiwski, Statistics in Medicine, 25: 481-493 +var + lSum,lV: double; + linci,lincj,i: integer; + lObspIV,lObspDV: pointer; + lObsIV,lObsDV: Doublep0; + +begin + result := -1; + if (lnSubj < 1) then exit; + createArray64(lObspIV,lObsIV,lnSubj); + createArray64(lObspDV,lObsDV,lnSubj); + for i := 0 to (lnSubj-1) do //for each subject without disease + lObsIV[i] := lInIV[i]; + for i := 0 to (lnSubj-1) do //for each subject without disease + lObsDV[i] := lInDV[i]; + SortDoubleDouble(0,lnSubj-1,lObsIV,lObsDV); + + lSum := 0; + for linci := 0 to (lnSubj-1) do begin + for lincj := 0 to (lnSubj-1) do begin + if lincj <> linci then begin + if ((lObsDV^[linci] > lObsDV^[lincj]) and (lObsIV^[linci] > lObsIV^[lincj])) or + ((lObsDV^[linci] < lObsDV^[lincj]) and (lObsIV^[linci] < lObsIV^[lincj])) then + lV := 1 + else if (lObsDV^[linci] = lObsDV^[lincj]) or (lObsIV^[linci] = lObsIV^[lincj]) then //tie + lV := 0.5 + else + lV := 0; + lSum := lV + lSum; + end; + + end;//for group1 + end;//for group0 + lSum := lSum * (1/ (lnSubj* (lnSubj-1) ) ); + result := lSum; + freemem(lObspDV); + freemem(lObspIV); +end; //continROC2 + + + +var + i: integer; +initialization +begin + for i := 1 to knSim do + createArray64(gSimRAp[i],gSimRA[i],knPermute); +end; + +finalization +begin + for i := 1 to knSim do + freemem(gSimRAp[i]); +end; +end. diff --git a/npm/brunner.ppu b/npm/brunner.ppu new file mode 100644 index 0000000..baf49c2 Binary files /dev/null and b/npm/brunner.ppu differ diff --git a/npm/design.dfm b/npm/design.dfm new file mode 100755 index 0000000..d64e141 Binary files /dev/null and b/npm/design.dfm differ diff --git a/npm/design.lfm b/npm/design.lfm new file mode 100755 index 0000000..b125fac --- /dev/null +++ b/npm/design.lfm @@ -0,0 +1,135 @@ +object DesignForm: TDesignForm + Left = 481 + Height = 207 + Top = 179 + Width = 636 + HorzScrollBar.Page = 635 + VertScrollBar.Page = 206 + ActiveControl = AVal + BorderStyle = bsDialog + Caption = 'Design' + ClientHeight = 207 + ClientWidth = 636 + Constraints.MaxHeight = 207 + Constraints.MaxWidth = 636 + Constraints.MinHeight = 207 + Constraints.MinWidth = 636 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '0.9.28.2' + object Label4: TLabel + Left = 4 + Height = 18 + Top = 8 + Width = 70 + Caption = 'Predictors' + ParentColor = False + end + object Label5: TLabel + Left = 76 + Height = 18 + Top = 8 + Width = 114 + Caption = 'Predictor Names' + ParentColor = False + end + object Label1: TLabel + Left = 12 + Height = 18 + Top = 123 + Width = 81 + Caption = 'Participants' + ParentColor = False + end + object TemplateLabel: TLabel + Left = 148 + Height = 18 + Top = 95 + Width = 112 + Caption = 'C:\template.img' + ParentColor = False + end + object Label2: TLabel + Left = 12 + Height = 18 + Top = 168 + Width = 263 + Caption = 'Ignore voxels damaged in less than N%' + ParentColor = False + end + object OKBtn: TButton + Left = 527 + Height = 25 + Top = 168 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + ModalResult = 1 + TabOrder = 0 + end + object AVal: TSpinEdit + Left = 12 + Height = 27 + Top = 37 + Width = 70 + MaxValue = 99 + MinValue = 1 + OnChange = AValChange + TabOrder = 1 + Value = 2 + end + object ALevelNames: TStringGrid + Left = 98 + Height = 42 + Top = 30 + Width = 527 + ColCount = 2 + FixedCols = 0 + FixedRows = 0 + Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goDrawFocusSelected, goEditing] + RowCount = 1 + ScrollBars = ssHorizontal + TabOrder = 2 + TitleFont.Height = -11 + OnEnter = ALevelNamesEnter + OnExit = ALevelNamesExit + end + object LesionCovaryCheck: TCheckBox + Left = 255 + Height = 21 + Top = 123 + Width = 267 + Caption = 'Automatically Covary Lesion Volume' + TabOrder = 5 + Visible = False + end + object AddMRIBtn: TButton + Left = 93 + Height = 25 + Top = 118 + Width = 129 + BorderSpacing.InnerBorder = 4 + Caption = 'Select Images' + OnClick = AddMRIBtnClick + TabOrder = 4 + end + object TemplateBtn: TButton + Left = 12 + Height = 25 + Top = 89 + Width = 129 + BorderSpacing.InnerBorder = 4 + Caption = 'Select Template' + OnClick = TemplateBtnClick + TabOrder = 3 + end + object CritPctEdit: TSpinEdit + Left = 304 + Height = 27 + Top = 162 + Width = 76 + OnChange = AValChange + TabOrder = 6 + Value = 1 + end +end diff --git a/npm/design.lrs b/npm/design.lrs new file mode 100755 index 0000000..cd28fa5 --- /dev/null +++ b/npm/design.lrs @@ -0,0 +1,38 @@ +LazarusResources.Add('TDesignForm','FORMDATA',[ + 'TPF0'#11'TDesignForm'#10'DesignForm'#4'Left'#3#225#1#6'Height'#3#207#0#3'Top' + +#3#179#0#5'Width'#3'|'#2#18'HorzScrollBar.Page'#3'{'#2#18'VertScrollBar.Page' + +#3#206#0#13'ActiveControl'#7#4'AVal'#11'BorderStyle'#7#8'bsDialog'#7'Caption' + +#6#6'Design'#12'ClientHeight'#3#207#0#11'ClientWidth'#3'|'#2#21'Constraints.' + +'MaxHeight'#3#207#0#20'Constraints.MaxWidth'#3'|'#2#21'Constraints.MinHeight' + +#3#207#0#20'Constraints.MinWidth'#3'|'#2#8'OnCreate'#7#10'FormCreate'#8'Posi' + +'tion'#7#14'poScreenCenter'#10'LCLVersion'#6#8'0.9.28.2'#0#6'TLabel'#6'Label' + +'4'#4'Left'#2#4#6'Height'#2#18#3'Top'#2#8#5'Width'#2'F'#7'Caption'#6#10'Pred' + +'ictors'#11'ParentColor'#8#0#0#6'TLabel'#6'Label5'#4'Left'#2'L'#6'Height'#2 + +#18#3'Top'#2#8#5'Width'#2'r'#7'Caption'#6#15'Predictor Names'#11'ParentColor' + +#8#0#0#6'TLabel'#6'Label1'#4'Left'#2#12#6'Height'#2#18#3'Top'#2'{'#5'Width'#2 + +'Q'#7'Caption'#6#12'Participants'#11'ParentColor'#8#0#0#6'TLabel'#13'Templat' + +'eLabel'#4'Left'#3#148#0#6'Height'#2#18#3'Top'#2'_'#5'Width'#2'p'#7'Caption' + +#6#15'C:\template.img'#11'ParentColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2#12 + +#6'Height'#2#18#3'Top'#3#168#0#5'Width'#3#7#1#7'Caption'#6'%Ignore voxels da' + +'maged in less than N%'#11'ParentColor'#8#0#0#7'TButton'#5'OKBtn'#4'Left'#3 + +#15#2#6'Height'#2#25#3'Top'#3#168#0#5'Width'#2'K'#25'BorderSpacing.InnerBord' + +'er'#2#4#7'Caption'#6#2'OK'#11'ModalResult'#2#1#8'TabOrder'#2#0#0#0#9'TSpinE' + +'dit'#4'AVal'#4'Left'#2#12#6'Height'#2#27#3'Top'#2'%'#5'Width'#2'F'#8'MaxVal' + +'ue'#2'c'#8'MinValue'#2#1#8'OnChange'#7#10'AValChange'#8'TabOrder'#2#1#5'Val' + +'ue'#2#2#0#0#11'TStringGrid'#11'ALevelNames'#4'Left'#2'b'#6'Height'#2'*'#3'T' + +'op'#2#30#5'Width'#3#15#2#8'ColCount'#2#2#9'FixedCols'#2#0#9'FixedRows'#2#0#7 + +'Options'#11#15'goFixedVertLine'#15'goFixedHorzLine'#10'goVertLine'#19'goDra' + +'wFocusSelected'#9'goEditing'#0#8'RowCount'#2#1#10'ScrollBars'#7#12'ssHorizo' + +'ntal'#8'TabOrder'#2#2#16'TitleFont.Height'#2#245#7'OnEnter'#7#16'ALevelName' + +'sEnter'#6'OnExit'#7#15'ALevelNamesExit'#0#0#9'TCheckBox'#17'LesionCovaryChe' + +'ck'#4'Left'#3#255#0#6'Height'#2#21#3'Top'#2'{'#5'Width'#3#11#1#7'Caption'#6 + +'"Automatically Covary Lesion Volume'#8'TabOrder'#2#5#7'Visible'#8#0#0#7'TBu' + +'tton'#9'AddMRIBtn'#4'Left'#2']'#6'Height'#2#25#3'Top'#2'v'#5'Width'#3#129#0 + +#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#13'Select Images'#7'OnClick' + +#7#14'AddMRIBtnClick'#8'TabOrder'#2#4#0#0#7'TButton'#11'TemplateBtn'#4'Left' + +#2#12#6'Height'#2#25#3'Top'#2'Y'#5'Width'#3#129#0#25'BorderSpacing.InnerBord' + +'er'#2#4#7'Caption'#6#15'Select Template'#7'OnClick'#7#16'TemplateBtnClick'#8 + +'TabOrder'#2#3#0#0#9'TSpinEdit'#11'CritPctEdit'#4'Left'#3'0'#1#6'Height'#2#27 + +#3'Top'#3#162#0#5'Width'#2'L'#8'OnChange'#7#10'AValChange'#8'TabOrder'#2#6#5 + +'Value'#2#1#0#0#0 +]); diff --git a/npm/design.o b/npm/design.o new file mode 100644 index 0000000..7b97fa5 Binary files /dev/null and b/npm/design.o differ diff --git a/npm/design.pas b/npm/design.pas new file mode 100755 index 0000000..4be34ce --- /dev/null +++ b/npm/design.pas @@ -0,0 +1,200 @@ +unit design; + +interface + +uses +{$IFNDEF FPC} +//Utils, +{$ELSE} +LResources, +{$ENDIF} +//{$IFNDEF Unix} Windows,{$ENDIF} + + Buttons, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Spin, Grids,nifti_hdr; + +type + String10= String[10]; + + { TDesignForm } + + TDesignForm = class(TForm) + OKBtn: TButton; + AVal: TSpinEdit; + Label4: TLabel; + Label5: TLabel; + ALevelNames: TStringGrid; + LesionCovaryCheck: TCheckBox; + AddMRIBtn: TButton; + Label1: TLabel; + TemplateBtn: TButton; + TemplateLabel: TLabel; + CritPctEdit: TSpinEdit; + Label2: TLabel; + //procedure LRsetup (var NumColumns,Vars,L1,L2,L3: integer; var OK: boolean); + procedure AValChange(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure ALevelNamesEnter(Sender: TObject); + procedure ALevelNamesExit(Sender: TObject); + procedure AddMRIBtnClick(Sender: TObject); + procedure TemplateBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + DesignForm: TDesignForm; + +implementation + +uses npmform,spread,hdr; +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + +const + kMaxColumns = 16; {for ANOVA} + //maxElements = kMaxColumns; {ANOVA} + MaxLen = 12; + //kCR = chr (13); + //kTab = chr(9); + kVALImgFilter = 'Image (*.hdr;*.nii;*.voi)|*.hdr;*.nii;*.nii.gz;*.voi'; + +procedure TDesignForm.AValChange(Sender: TObject); +{$IFDEF FPC} +var + lOrig,lP: integer; +begin + lOrig := ALevelNames.ColCount; + DesignForm.Caption := inttostr(AVal.Value); + ALevelNames.ColCount := AVal.Value; + if AVal.value > lOrig then + for lP := lOrig to (AVal.value-1) do + AlevelNames.Cells[lP,0] := 'Pred'+inttostr(lP+1); +end; + +{$ELSE} +begin + ALevelNames.ColCount := AVal.Value; +end; +{$ENDIF} + +procedure TDesignForm.FormCreate(Sender: TObject); +var lC: integer; +begin + ALevelNames.ColCount := 16 ; + AlevelNames.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + //AlevelNames.Cells[8,0] := 'Pred'; + for lC := 0 to 15 do begin + AlevelNames.Cells[lC,0] := 'Pred'+inttostr(lC+1); + end; + SpreadForm.UpdateLabels; + AValChange(nil); +end; + +procedure TDesignForm.ALevelNamesEnter(Sender: TObject); +begin + AlevelNames.Selection:=TGridRect(Rect(0,0,0,0)); +end; + +procedure TDesignForm.ALevelNamesExit(Sender: TObject); +begin + AlevelNames.Selection:=TGridRect(Rect(-1,-1,-1,-1)); +end; + +function LeadingZeroFilename (lInX: string): string; +var + lIn: string; + lC,lnPad,lPos,lnDec,lExtPos,lLen: integer; +begin + {$IFDEF Unix} + lIn := lInX; + {$ELSE} + lIn := Lowercase(lInX); + {$ENDIF} + lnPad := 8; + lLen := length(lIn); + result := lIn; + if lLen < 1 then exit; + lExtPos := 1; + while (lExtPos <= lLen) and (lIn[lExtPos] <> '.') do + inc(lExtPos); + if lExtPos <= 1 then + exit; + lnDec := 0; + lPos := lExtPos -1; + while (lPos > 0) and ( lIn[lPos] in ['0'..'9']) do + dec(lPos); + lnDec := (lExtPos-lPos)-1; + if (lnDec = 0) or (lnDec >= lnPad) then + exit; + result := ''; + if lPos > 0 then + for lC := 1 to lPos do + result := result + lIn[lC]; + for lC := 1 to (lnPad-lnDec) do + result := result + '0'; + for lC := (lPos+1) to lLen do + result := result+lIn[lC]; +end; + +procedure SortStrPadded (var lStr: TStringList); +{file1,file2...file10 not file1,file10..file2} +var counter, look:integer; temp:Tstrings; +begin + if lStr.Count < 2 then exit; + temp := TStringList.Create; + for counter:=0 to lStr.Count-1 do + temp.Append(LeadingZeroFilename{LowerCase}(lStr[counter])); + for counter:=0 to temp.Count-1 do + for look:=counter+1 to temp.Count-1 do + if temp[look]<temp[counter] then begin + lStr.Exchange(look, counter); + temp.Exchange(look,counter); + end; + temp.Free; +end; + +procedure TDesignForm.AddMRIBtnClick(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFileStrs: TStringList; +begin + if not MainForm.OpenDialogExecute('Select VOIs you wish to analyze',true,false,kVALImgFilter) then exit; + lNumberofFiles:= MainForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + lNumberofFiles := NIFTIhdr_HdrVolumes(MainForm.OpenHdrDlg.Filename); + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + exit; + end; + lFileStrs := TStringList.Create; + for lC:= 1 to lNumberofFiles do + lFileStrs.Add(extractfilename(MainForm.OpenHdrDlg.Filename)+':'+inttostr(lC)); + end else begin + lFileStrs := TStringList.Create; + for lC:= 1 to lNumberofFiles do + lFileStrs.Add(extractfilename(MainForm.OpenHdrDlg.Files[lC-1])); + SortStrPadded (lFileStrs); + end; + SpreadForm.DataGrid.RowCount := lNumberofFiles+1+kMaxFactors; //10/10/2006 -must resize BEFORE to populating cells + for lC:= 1 to lNumberofFiles do + SpreadForm.DataGrid.Cells[0,kMaxFactors+lC] := lFileStrs[lC-1]; + lFileStrs.free; + +end; + +procedure TDesignForm.TemplateBtnClick(Sender: TObject); +begin + if not MainForm.OpenDialogExecute('Select Template image [determines bounding box and dimensions]',false,false,kVALImgFilter) then exit; + TemplateLabel.Caption := (MainForm.OpenHdrDlg.Filename); +end; + + {$IFDEF FPC} +initialization + {$I design.lrs} +{$ENDIF} + +end. diff --git a/npm/design.ppu b/npm/design.ppu new file mode 100644 index 0000000..8b88bc1 Binary files /dev/null and b/npm/design.ppu differ diff --git a/npm/dice.ico b/npm/dice.ico new file mode 100755 index 0000000..bb844ee Binary files /dev/null and b/npm/dice.ico differ diff --git a/npm/dmath/GraphicsMathLibrary.pas b/npm/dmath/GraphicsMathLibrary.pas new file mode 100755 index 0000000..173bca9 --- /dev/null +++ b/npm/dmath/GraphicsMathLibrary.pas @@ -0,0 +1,738 @@ +// Graphics Math Library +// +// Copyright (C) 1982, 1985, 1992, 1995-1998 Earl F. Glynn, Overland Park, KS. +// All Rights Reserved. E-Mail Address: EarlGlynn@att.net + +UNIT GraphicsMathLibrary; // Matrix/Vector Operations for 2D/3D Graphics} + +INTERFACE + + USES + SysUtils,dialogs; {Exception} + + CONST + sizeUndefined = 1; + size2D = 3; // 'size' of 2D homogeneous vector or transform matrix + size3D = 4; // 'size' of 3D homogeneous vector or transform matrix + + TYPE + EVectorError = CLASS(Exception); + EMatrixError = CLASS(Exception); + + TAxis = (axisX, axisY, axisZ); + TCoordinate = (coordCartesian, coordSpherical, coordCylindrical); + TDimension = (dimen2D, dimen3D); // two- or three-dimensional TYPE + TIndex = 1..4; // index of 'TMatrix' and 'TVector' TYPEs + + TMatrix = // transformation 'matrix' + RECORD + size: TIndex; + matrix: ARRAY[TIndex,TIndex] OF single //azx DOUBLE + END; + + Trotation = (rotateClockwise, rotateCounterClockwise); + + // Normally the TVector TYPE is used to define 2D/3D homogenous + // cartesian coordinates for graphics, i.e., (x,y,1) for 2D and + // (x,y,z,1) for 3D. + // + // Cartesian coordinates can be converted to spherical (r, theta, phi), + // or cylindrical coordinates (r,theta, z). Spherical or cylindrical + // coordinates can be converted back to cartesian coordinates. + TVector = + RECORD + size: TIndex; + CASE INTEGER OF + 0: (vector: ARRAY[TIndex] OF single); + 1: (x: single; + y: single; + z: single; // contains 'h' for 2D cartesian vector + h: single) + END; + + TIntVector = + RECORD + size: TIndex; + CASE INTEGER OF + 0: (vector: ARRAY[TIndex] OF integer); + 1: (x: integer; + y: integer; + z: integer; // contains 'h' for 2D cartesian vector + h: integer) + END; + // Vector Operations + +// FUNCTION Vector2D (CONST xValue, yValue: DOUBLE): TVector; + FUNCTION Vector3D (CONST xValue, yValue, zValue: DOUBLE): TVector; +(* FUNCTION AddVectors (CONST u,v: TVector): TVector; +// FUNCTION Transform (CONST u: TVector; CONST a: TMatrix): TVector; + + FUNCTION DotProduct (CONST u,v: TVector): DOUBLE; + FUNCTION CrossProduct(CONST u,v: TVector): TVector; + *) + + // Basic Matrix Operations + + FUNCTION Matrix2D (CONST m11,m12,m13, // 2D "graphics" matrix + m21,m22,m23, + m31,m32,m33: DOUBLE): TMatrix; + + FUNCTION Matrix3D (CONST m11,m12,m13,m14, // 3D "graphics" matrix + m21,m22,m23,m24, + m31,m32,m33,m34, + m41,m42,m43,m44: DOUBLE): TMatrix; + + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + + FUNCTION InvertMatrix3D (CONST Input:TMatrix): TMatrix; + + FUNCTION InvertMatrix (CONST a,b: TMatrix; VAR determinant: DOUBLE): TMatrix; + + + // Transformation Matrices + + FUNCTION RotateMatrix (CONST dimension: TDimension; + CONST xyz : TAxis; + CONST angle : DOUBLE; + CONST rotation : Trotation): TMatrix; + +// FUNCTION ScaleMatrix (CONST s: TVector): TMatrix; + +// FUNCTION TranslateMatrix (CONST t: TVector): TMatrix; + + FUNCTION ViewTransformMatrix (CONST coordinate: TCoordinate; + CONST azimuth {or x}, elevation {or y}, distance {or z}: DOUBLE; + CONST ScreenX, ScreenY, ScreenDistance: DOUBLE): TMatrix; + + + // conversions + +// FUNCTION FromCartesian (CONST ToCoordinate: TCoordinate; CONST u: TVector): TVector; +// FUNCTION ToCartesian (CONST FromCoordinate: TCoordinate; CONST u: TVector): TVector; + + //FUNCTION ToDegrees(CONST angle {radians}: DOUBLE): DOUBLE {degrees}; + FUNCTION ToRadians(CONST angle {degrees}: DOUBLE): DOUBLE {radians}; + + + // miscellaneous + + FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; +{ FUNCTION GetFuzz: DOUBLE; + PROCEDURE SetFuzz(CONST x: DOUBLE); + } + +IMPLEMENTATION + + VAR + fuzz : DOUBLE; + + +// ************************* Vector Operations ************************* + + // This procedure defines two-dimensional homogeneous coordinates (x,y,1) + // as a single 'vector' data element 'u'. The 'size' of a two-dimensional + // homogenous vector is 3. + + + // This procedure defines three-dimensional homogeneous coordinates + // (x,y,z,1) as a single 'vector' data element 'u'. The 'size' of a + // three-dimensional homogenous vector is 4. + FUNCTION Vector3D (CONST xValue, yValue, zValue: DOUBLE): TVector; + BEGIN + WITH RESULT DO + BEGIN + x := xValue; + y := yValue; + z := zValue; + h := 1.0; // homogeneous coordinate + size := size3D + END + END {Vector3D}; + + + // AddVectors adds two vectors defined with homogeneous coordinates. + FUNCTION AddVectors (CONST u,v: TVector): TVector; + VAR + i: TIndex; + BEGIN + IF (u.size IN [size2D..size3D]) AND + (v.size IN [size2D..size3D]) AND + (u.size = v.size) + THEN BEGIN + RESULT.size := u.size; + FOR i := 1 TO u.size-1 DO {2D + 2D = 2D or 3D + 3D = 3D} + BEGIN + RESULT.vector[i] := u.vector[i] + v.vector[i] + END; + RESULT.vector[u.size] := 1.0 {homogeneous coordinate} + END + ELSE raise EVectorError.Create('Vector Addition Mismatch') + END {AddVectors}; + + +// *********************** Basic Matrix Operations ********************** + + FUNCTION Matrix2D (CONST m11,m12,m13, m21,m22,m23, m31,m32,m33: DOUBLE): + TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; matrix[1,3] := m13; + matrix[2,1] := m21; matrix[2,2] := m22; matrix[2,3] := m23; + matrix[3,1] := m31; matrix[3,2] := m32; matrix[3,3] := m33; + size := size2D + END + END {Matrix2D}; + + + FUNCTION Matrix3D (CONST m11,m12,m13,m14, m21,m22,m23,m24, + m31,m32,m33,m34, m41,m42,m43,m44: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; + matrix[1,3] := m13; matrix[1,4] := m14; + + matrix[2,1] := m21; matrix[2,2] := m22; + matrix[2,3] := m23; matrix[2,4] := m24; + + matrix[3,1] := m31; matrix[3,2] := m32; + matrix[3,3] := m33; matrix[3,4] := m34; + + matrix[4,1] := m41; matrix[4,2] := m42; + matrix[4,3] := m43; matrix[4,4] := m44; + size := size3D + END + END {Matrix3D}; + + + // Compound geometric transformation matrices can be formed by multiplying + // simple transformation matrices. This procedure only multiplies together + // matrices for two- or three-dimensional transformations, i.e., 3x3 or 4x4 + // matrices. The multiplier and multiplicand must be of the same dimension. + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + VAR + i,j,k: TIndex; + temp : DOUBLE; + BEGIN + RESULT.size := a.size; + IF a.size = b.size + THEN + + FOR i := 1 TO a.size DO + BEGIN + FOR j := 1 TO a.size DO + BEGIN + + temp := 0.0; + FOR k := 1 TO a.size DO + BEGIN + temp := temp + a.matrix[i,k]*b.matrix[k,j]; + END; + RESULT.matrix[i,j] := Defuzz(temp) + + END + END + ELSE Showmessage('shit'+inttostr(a.size)+'x'+inttostr(b.size)); + //ELSE EMatrixError.Create('MultiplyMatrices error') + END {MultiplyMatrices}; + +PROCEDURE lubksb(a: {glnpbynp}TMatrix; n: integer; indx: TIntVector; VAR b: TVector); +VAR + j,ip,ii,i: integer; + sum: double; +BEGIN + ii := 0; + FOR i := 1 TO n DO BEGIN + ip := indx.vector[i]; + sum := b.vector[ip]; + b.vector[ip] := b.vector[i]; + IF (ii <> 0) THEN BEGIN + FOR j := ii TO i-1 DO BEGIN + sum := sum-a.matrix[i,j]*b.vector[j] + END + END ELSE IF (sum <> 0.0) THEN BEGIN + ii := i + END; + b.vector[i] := sum + END; + FOR i := n DOWNTO 1 DO BEGIN + sum := b.vector[i]; + IF (i < n) THEN BEGIN + FOR j := i+1 TO n DO BEGIN + sum := sum-a.matrix[i,j]*b.vector[j] + END + END; + b.vector[i] := sum/a.matrix[i,i] + END +end; + + PROCEDURE ludcmp(VAR a: TMatrix; n: integer; + VAR indx: TIntVector; VAR d: double); +CONST + tiny=1.0e-20; +VAR + k,j,imax,i: integer; + sum,dum,big: real; + vv: TVector; +BEGIN + d := 1.0; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO IF (abs(a.matrix[i,j]) > big) THEN big := abs(a.matrix[i,j]); + IF (big = 0.0) THEN BEGIN + writeln('pause in LUDCMP - singular matrix'); readln + END; + vv.vector[i] := 1.0/big + END; + FOR j := 1 TO n DO BEGIN + FOR i := 1 TO j-1 DO BEGIN + sum := a.matrix[i,j]; + FOR k := 1 TO i-1 DO BEGIN + sum := sum-a.matrix[i,k]*a.matrix[k,j] + END; + a.matrix[i,j] := sum + END; + big := 0.0; + FOR i := j TO n DO BEGIN + sum := a.matrix[i,j]; + FOR k := 1 TO j-1 DO BEGIN + sum := sum-a.matrix[i,k]*a.matrix[k,j] + END; + a.matrix[i,j] := sum; + dum := vv.vector[i]*abs(sum); + IF (dum > big) THEN BEGIN + big := dum; + imax := i + END + END; + IF (j <> imax) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a.matrix[imax,k]; + a.matrix[imax,k] := a.matrix[j,k]; + a.matrix[j,k] := dum + END; + d := -d; + vv.vector[imax] := vv.vector[j] + END; + indx.vector[j] := imax; + IF (a.matrix[j,j] = 0.0) THEN a.matrix[j,j] := tiny; + IF (j <> n) THEN BEGIN + dum := 1.0/a.matrix[j,j]; + FOR i := j+1 TO n DO BEGIN + a.matrix[i,j] := a.matrix[i,j]*dum + END + END + END; +END; + + FUNCTION InvertMatrix3D (CONST Input:TMatrix): TMatrix; + var + n,i,j: integer; + d: double; + indx: tIntVector; + col: tvector; + a,y: TMatrix; + begin + a:= Input; + n := 3; + ludcmp(a,n,indx,d); + for j := 1 to n do begin + for i := 1 to n do col.vector[i] := 0; + col.vector[j] := 1.0; + lubksb(a,n,indx,col); + for i := 1 to n do y.matrix[i,j] := col.vector[i]; + end; + result := y; + end; + + // This procedure inverts a general transformation matrix. The user need + // not form an inverse geometric transformation by keeping a product of + // the inverses of simple geometric transformations: translations, rotations + // and scaling. A determinant of zero indicates no inverse is possible for + // a singular matrix. + FUNCTION InvertMatrix (CONST a,b: TMatrix; VAR determinant: DOUBLE): TMatrix; + VAR + c : TMatrix; + i,i_pivot: TIndex; + i_flag : ARRAY[TIndex] OF BOOLEAN; + j,j_pivot: TIndex; + j_flag : ARRAY[TIndex] OF BOOLEAN; + modulus : DOUBLE; + n : TIndex; + pivot : DOUBLE; + pivot_col: ARRAY[TIndex] OF TIndex; + pivot_row: ARRAY[TIndex] OF TIndex; + temporary: DOUBLE; + BEGIN + c := a; // The matrix inversion algorithm used here + WITH c DO // is similar to the "maximum pivot strategy" + BEGIN // described in "Applied Numerical Methods" + FOR i := 1 TO size DO // by Carnahan, Luther and Wilkes, + BEGIN // pp. 282-284. + i_flag[i] := TRUE; + j_flag[i] := TRUE + END; + modulus := 1.0; + i_pivot := 1; // avoid initialization warning + j_pivot := 1; // avoid initialization warning + + FOR n := 1 TO size DO + BEGIN + pivot := 0.0; + IF ABS(modulus) > 0.0 + THEN BEGIN + FOR i := 1 TO size DO + IF i_flag[i] + THEN + + FOR j := 1 TO size DO + IF j_flag[j] + THEN + IF ABS(matrix[i,j]) > ABS(pivot) + THEN BEGIN + pivot := matrix[i,j]; // largest value on which to pivot + i_pivot := i; // indices of pivot element + j_pivot := j + END; + + IF Defuzz(pivot) = 0 // If pivot is too small, consider + THEN modulus := 0 // the matrix to be singular + ELSE BEGIN + pivot_row[n] := i_pivot; + pivot_col[n] := j_pivot; + i_flag[i_pivot] := FALSE; + j_flag[j_pivot] := FALSE; + FOR i := 1 TO size DO + IF i <> i_pivot + THEN + FOR j := 1 TO size DO // pivot column unchanged for elements + IF j <> j_pivot // not in pivot row or column ... + THEN matrix[i,j] := (matrix[i,j]*matrix[i_pivot,j_pivot] - + matrix[i_pivot,j]*matrix[i,j_pivot]) + / modulus; // 2x2 minor / modulus + FOR j := 1 TO size DO + IF j <> j_pivot // change signs of elements in pivot row + THEN matrix[i_pivot,j] := -matrix[i_pivot,j]; + temporary := modulus; // exchange pivot element and modulus + modulus := matrix[i_pivot,j_pivot]; + matrix[i_pivot,j_pivot] := temporary + END + END + END {FOR n} + END {WITH}; + determinant := Defuzz(modulus); + IF determinant <> 0 + THEN BEGIN + RESULT.size := c.size; // The matrix inverse must be unscrambled + FOR i := 1 TO c.size DO // if pivoting was not along main diagonal. + FOR j := 1 TO c.size DO + RESULT.matrix[pivot_row[i],pivot_col[j]] := Defuzz(c.matrix[i,j]/determinant) + END + ELSE EMatrixError.Create('InvertMatrix error') + + END {InvertMatrix}; + + +// *********************** Transformation Matrices ******************** + + + // This procedure defines a matrix for a two- or three-dimensional rotation. + // To avoid possible confusion in the sense of the rotation, 'rotateClockwise' + // or 'roCounterlcockwise' must always be specified along with the axis + // of rotation. Two-dimensional rotations are assumed to be about the z-axis + // in the x-y plane. + // + // A rotation about an arbitrary axis can be performed with the following + // steps: + // (1) Translate the object into a new coordinate system where (x,y,z) + // maps into the origin (0,0,0). + // (2) Perform appropriate rotations about the x and y axes of the + // coordinate system so that the unit vector (a,b,c) is mapped into + // the unit vector along the z axis. + // (3) Perform the desired rotation about the z-axis of the new + // coordinate system. + // (4) Apply the inverse of step (2). + // (5) Apply the inverse of step (1). + FUNCTION RotateMatrix (CONST dimension: TDimension; + CONST xyz : TAxis; + CONST angle : DOUBLE; + CONST rotation : Trotation): TMatrix; + VAR + cosx : DOUBLE; + sinx : DOUBLE; + TempAngle: DOUBLE; + + BEGIN + TempAngle := angle; // Use TempAngle since "angle" is CONST parameter + + IF rotation = rotateCounterClockwise + THEN TempAngle := -TempAngle; + + cosx := Defuzz( COS(TempAngle) ); + sinx := Defuzz( SIN(TempAngle) ); + + CASE dimension OF + dimen2D: + CASE xyz OF + axisX,axisY: EMatrixError.Create('Invalid 2D rotation matrix. Specify axisZ'); + + axisZ: RESULT := Matrix2D ( cosx, -sinx, 0, + sinx, cosx, 0, + 0, 0, 1) + END; + + dimen3D: + CASE xyz OF + axisX: RESULT := Matrix3D ( 1, 0, 0, 0, + 0, cosx, -sinx, 0, + 0, sinx, cosx, 0, + 0, 0, 0, 1); + + axisY: RESULT := Matrix3D ( cosx, 0, sinx, 0, + 0, 1, 0, 0, + -sinx, 0, cosx, 0, + 0, 0, 0, 1); + + axisZ: RESULT := Matrix3D ( cosx, -sinx, 0, 0, + sinx, cosx, 0, 0, + 0, 0, 1, 0, + 0, 0, 0, 1); + END + END + END {RotateMatrix}; + + + // 'ScaleMatrix' accepts a 'vector' containing the scaling factors for + // each of the dimensions and creates a scaling matrix. The size + // of the vector dictates the size of the resulting matrix. + FUNCTION ScaleMatrix (CONST s: TVector): TMatrix; + BEGIN + CASE s.size OF + size2D: RESULT := Matrix2D (s.x, 0, 0, + 0, s.y, 0, + 0, 0, 1); + + size3D: RESULT := Matrix3D (s.x, 0, 0, 0, + 0, s.y, 0, 0, + 0, 0, s.z, 0, + 0, 0, 0, 1) + END + END {ScaleMatrix}; + // 'TranslateMatrix' defines a translation transformation matrix. The + // components of the vector 't' determine the translation components. + // (Note: 'Translate' here is from kinematics in physics.) + FUNCTION TranslateMatrix (CONST t: TVector): TMatrix; + BEGIN + CASE t.size OF + size2D: RESULT := Matrix2D ( 1, 0, 0, + 0, 1, 0, + t.x, t.y, 1); + + size3D: RESULT := Matrix3D ( 1, 0, 0, 0, + 0, 1, 0, 0, + 0, 0, 1, 0, + t.x, t.y, t.z, 1) + END + END {TranslateMatrix}; + // 'ViewTransformMatrix' creates a transformation matrix for changing + // from world coordinates to eye coordinates. The location of the 'eye' + // from the 'object' is given in spherical (azimuth,elevation,distance) + // coordinates or Cartesian (x,y,z) coordinates. The size of the screen + // is 'ScreenX' units horizontally and 'ScreenY' units vertically. The + // eye is 'ScreenDistance' units from the viewing screen. A large ratio + // 'ScreenDistance/ScreenX (or ScreenY)' specifies a narrow aperature + // -- a telephoto view. Conversely, a small ratio specifies a large + // aperature -- a wide-angle view. This view transform matrix is very + // useful as the default three-dimensional transformation matrix. Once + // set, all points are automatically transformed. + FUNCTION ViewTransformMatrix (CONST coordinate: TCoordinate; + CONST azimuth {or x}, elevation {or y}, distance {or z}: DOUBLE; + CONST ScreenX, ScreenY, ScreenDistance: DOUBLE): TMatrix; + + CONST + HalfPI = PI / 2.0; + + VAR + a : TMatrix; + b : TMatrix; + cosm : DOUBLE; // COS(-angle) + hypotenuse: DOUBLE; + sinm : DOUBLE; // SIN(-angle) + temporary : DOUBLE; + u : TVector; + x : DOUBLE ABSOLUTE azimuth; // x and azimuth are synonyms + y : DOUBLE ABSOLUTE elevation; // synonyms + z : DOUBLE ABSOLUTE distance; // synonyms + + BEGIN + CASE coordinate OF + coordCartesian: u := Vector3D (-x, -y, -z); + + coordSpherical: + BEGIN + temporary := -distance * COS(elevation); + u := Vector3D (temporary * COS(azimuth - HalfPI), + temporary * SIN(azimuth - HalfPI), + -distance * SIN(elevation)); + END + END; + a := TranslateMatrix(u); // translate origin to 'eye' + b := RotateMatrix (dimen3D, axisX, HalfPI, rotateClockwise); + a := MultiplyMatrices(a,b); + + CASE coordinate OF + coordCartesian: + BEGIN + temporary := SQR(x) + SQR(y); + hypotenuse := SQRT(temporary); + if hypotenuse <> 0 then begin + cosm := -y/hypotenuse; + sinm := x/hypotenuse; + end else begin + cosm := 1;//abba + sinm := 0; + end; + + b := Matrix3D ( cosm, 0, sinm, 0, + 0, 1, 0, 0, + -sinm, 0, cosm, 0, + 0, 0, 0, 1); + + a := MultiplyMatrices (a,b); + cosm := hypotenuse; + hypotenuse := SQRT(temporary + SQR(z)); + cosm := cosm/hypotenuse; + sinm := -z/hypotenuse; + + b := Matrix3D ( 1, 0, 0, 0, + 0, cosm, -sinm, 0, + 0, sinm, cosm, 0, + 0, 0, 0, 1) + END; + coordSpherical: + BEGIN + b := RotateMatrix (dimen3D,axisY,-azimuth,rotateCounterClockwise); + a := MultiplyMatrices(a,b); + b := RotateMatrix (dimen3D,axisX,elevation,rotateCounterClockwise); + END + END {CASE}; + + a := MultiplyMatrices (a,b); + u := Vector3D (ScreenDistance/(0.5*ScreenX), + ScreenDistance/(0.5*ScreenY),-1.0); + b := ScaleMatrix (u); // reverse sense of z-axis; screen transformation + + RESULT := MultiplyMatrices (a,b); + + END {ViewTransformMatrix}; + +// *************************** Conversions ************************** + // This function converts the vector parameter from Cartesian + // coordinates to the specified type of coordinates. + FUNCTION FromCartesian (CONST ToCoordinate: TCoordinate; CONST u: TVector): TVector; + VAR + phi : DOUBLE; + r : DOUBLE; + temp : DOUBLE; + theta: DOUBLE; + + BEGIN + IF ToCoordinate = coordCartesian + THEN RESULT := u + ELSE BEGIN + RESULT.size := u.size; + + IF (u.size = size3D) AND + (ToCoordinate = coordSpherical) + THEN BEGIN // spherical 3D + temp := SQR(u.x)+SQR(u.y); // (x,y,z) -> (r,theta,phi) + r := SQRT(temp+SQR(u.z)); + IF Defuzz(u.x) = 0.0 + THEN theta := PI/4 + ELSE theta := ARCTAN(u.y/u.x); + IF Defuzz(u.z) = 0.0 + THEN phi := PI/4 + ELSE phi := ARCTAN(SQRT(temp)/u.z); + RESULT.x := r; + RESULT.y := theta; + RESULT.z := phi + END + ELSE BEGIN // cylindrical 2D/3D or spherical 2D + // (x,y) -> (r,theta) or (x,y,z) -> (r,theta,z) + r := SQRT( SQR(u.x) + SQR(u.y) ); + IF Defuzz(u.x) = 0.0 + THEN theta := PI/4 + ELSE theta := ARCTAN(u.y/u.x); + RESULT.x := r; + RESULT.y := theta + END + + END + END {FromCartesian}; + + + // This function converts the vector parameter from specified coordinates + // into Cartesian coordinates. + FUNCTION ToCartesian (CONST FromCoordinate: TCoordinate; CONST u: TVector): TVector; + VAR + phi : DOUBLE; + r : DOUBLE; + sinphi: DOUBLE; + theta : DOUBLE; + + BEGIN + RESULT := u; + + IF FromCoordinate = coordCartesian + THEN RESULT := u + ELSE BEGIN + RESULT.size := u.size; + + IF (u.size = size3D) AND + (FromCoordinate = coordSpherical) + THEN BEGIN // spherical 3D + r := u.x; // (r,theta,phi) -> (x,y,z) + theta := u.y; + phi := u.z; + sinphi := SIN(phi); + RESULT.x := r * COS(theta) * sinphi; + RESULT.y := r * SIN(theta) * sinphi; + RESULT.z := r * COS(phi) + END + ELSE BEGIN // cylindrical 2D/3D or spherical 2D + r := u.x; // (r,theta) -> (x,y) or (r,theta,z) -> (x,y,z) + theta := u.y; + RESULT.x := r * COS(theta); + RESULT.y := r * SIN(theta) + END + END + END {ToCartesian}; + + + + + // Convert angle in degrees to radians. + FUNCTION ToRadians (CONST angle: DOUBLE): DOUBLE; + BEGIN + RESULT := PI/180.0 * angle + END; {ToRadians} + + +// *************************** Miscellaneous ************************** + + // 'Defuzz' is used for comparisons and to avoid propagation of 'fuzzy', + // nearly-zero values. DOUBLE calculations often result in 'fuzzy' values. + // The term 'fuzz' was adapted from the APL language. + FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; + BEGIN + IF ABS(x) < fuzz + THEN RESULT := 0.0 + ELSE RESULT := x + END {Defuzz}; + + +INITIALIZATION + fuzz := 1.0E-6; + +END. {GraphicsMath UNIT} diff --git a/npm/dmath/Matrices.pas b/npm/dmath/Matrices.pas new file mode 100755 index 0000000..2610107 --- /dev/null +++ b/npm/dmath/Matrices.pas @@ -0,0 +1,1696 @@ +{ ********************************************************************** + * Unit MATRICES.PAS * + * Version 2.0 * + * (c) J. Debord, May 2001 * + ********************************************************************** + This unit implements dynamic allocation of vectors and matrices in + Pascal, together with various matrix operations. + + Dynamic allocation is allowed by declaring arrays as pointers. There + are 8 types available : + + PVector, PMatrix for floating point arrays + PIntVector, PIntMatrix for integer arrays + PBoolVector, PBoolMatrix for boolean arrays + PStrVector, PStrMatrix for string arrays (255 char.) + + To use these arrays in your programs, you must : + + (1) Declare variables of the appropriate type, e.g. + + var + V : PVector; + A : PMatrix; + + (2) Allocate each array BEFORE using it : + + DimVector(V, N); creates vector V[0..N] + DimMatrix(A, N, M); creates matrix A[0..N, 0..M] + where N, M are two integer variables + + If the allocation succeeds, all array elements are initialized + to zero (for numeric arrays), False (for boolean arrays), or + the null string (for string arrays). Otherwise, the pointer is + initialized to NIL. + + (3) Use arrays as in standard Turbo Pascal, with the following + exceptions : + + (a) You must use the indirection operator (^) to reference any + array element, i.e. write V^[I] and A^[I]^[J] instead of + V[I] and A[I,J]. + + (b) You cannot use the assignment operator (:=) to copy the + contents of an array into another array. Writing B := A + simply makes B point to the same memory block than A. You + must use one of the provided Copy... procedures (see their + documentation in the interface part of the unit). + + In addition, note that : + + (a) All arrays begin at index 0, so that the 0-indexed element + is always present, even if you don't use it. + + (b) A matrix is declared as an array of vectors, so that A^[I] + denotes the I-th vector of matrix A and may be used as any + vector. + + (4) Deallocate arrays when you no longer need them. This will free + the corresponding memory : + + DelVector(V, N); + DelMatrix(A, N, M); + + For more information, read the comments of each routine in the + interface part of the unit, and check the demo programs. + ********************************************************************** + References : + 1) 'Basic Programs for Scientists and Engineers' by A.R. Miller : + GaussJordan, InvMat + 2) Borland's Numerical Methods Toolbox : Det + 3) 'Numerical Recipes' by Press et al. : Cholesky, LU, SVD + 4) 'Matrix Computations' by Golub & Van Loan : QR_Decomp & QR_Solve + (Pascal implementation contributed by Mark Vaughan) + ********************************************************************** } + +unit Matrices; + +interface + +uses + FMath,dialogs,sysutils; + +{ ********************************************************************** + This section defines some error codes. + ********************************************************************** } + +const + MAT_OK = 0; { No error } + MAT_SINGUL = - 1; { Singular matrix } + MAT_NON_CONV = - 2; { Non convergence of iterative procedure } + MAT_NOT_PD = - 3; { Matrix not positive definite } + +{ ********************************************************************** + This section defines the vector and matrix types. Maximal sizes are + given for a 16-bit compiler (TP / BP / Delphi 1). Higher values may + be used with the 32-bit compilers (Delphi 2-4, FPK, GPC). + ********************************************************************** } + +const +{$IFDEF EXTENDEDREAL} + MAX_FLT = 6552; { Max size of real vector } +{$ELSE} +{$IFDEF SINGLEREAL} + MAX_FLT = 16382; +{$ELSE} +{$IFDEF PASCALREAL} + MAX_FLT = 10921; +{$ELSE} + {$DEFINE DOUBLEREAL} + MAX_FLT = 8190; +{$ENDIF} +{$ENDIF} +{$ENDIF} + + MAX_INT = 16382; { Max size of integer vector } + MAX_BOOL = 32766; { Max size of boolean vector } + MAX_STR = 254; { Max size of string vector } + MAX_VEC = 16382; { Max number of vectors in a matrix } + +type + Str255= string[255]; + TVector = array[0..MAX_FLT] of Float; + TIntVector = array[0..MAX_INT] of Integer; + TBoolVector = array[0..MAX_BOOL] of Boolean; + TStrVector = array[0..MAX_STR] of Str255; + + PVector = ^TVector; + PIntVector = ^TIntVector; + PBoolVector = ^TBoolVector; + PStrVector = ^TStrVector; + + TMatrix = array[0..MAX_VEC] of PVector; + TIntMatrix = array[0..MAX_VEC] of PIntVector; + TBoolMatrix = array[0..MAX_VEC] of PBoolVector; + TStrMatrix = array[0..MAX_VEC] of PStrVector; + + PMatrix = ^TMatrix; + PIntMatrix = ^TIntMatrix; + PBoolMatrix = ^TBoolMatrix; + PStrMatrix = ^TStrMatrix; + +{ ********************************************************************** + Memory allocation routines + ********************************************************************** } + +procedure DimVector(var V : PVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates floating point vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimIntVector(var V : PIntVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates integer vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimBoolVector(var V : PBoolVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates boolean vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimStrVector(var V : PStrVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates string vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates floating point matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates integer matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates boolean matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates string matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Memory deallocation routines + ********************************************************************** } + +procedure DelVector(var V : PVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes floating point vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelIntVector(var V : PIntVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes integer vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelBoolVector(var V : PBoolVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes boolean vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelStrVector(var V : PStrVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes string vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes floating point matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes integer matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes boolean matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes string matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Routines for copying vectors and matrices + ---------------------------------------------------------------------- + Lbound, Ubound : indices of first and last vector elements + Lbound1, Lbound2 : indices of first matrix element in each dimension + Ubound1, Ubound2 : indices of last matrix element in each dimension + ********************************************************************** } + +procedure SwapRows(I, K : Integer; A : PMatrix; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Exchanges rows I and K of matrix A + ---------------------------------------------------------------------- } + +procedure SwapCols(J, K : Integer; A : PMatrix; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Exchanges columns J and K of matrix A + ---------------------------------------------------------------------- } + +procedure CopyVector(Dest, Source : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into vector Dest + ---------------------------------------------------------------------- } + +procedure CopyMatrix(Dest, Source : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Copies matrix Source into matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyRowFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Row : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into line Row of matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyColFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Col : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into column Col of matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyVectorFromRow(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Row : Integer); +{ ---------------------------------------------------------------------- + Copies line Row of matrix Source into vector Dest + ---------------------------------------------------------------------- } + +procedure CopyVectorFromCol(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Col : Integer); +{ ---------------------------------------------------------------------- + Copies column Col of matrix Source into vector Dest + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Vector and matrix functions + ********************************************************************** } + +function Min(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the lowest value of vector X + ---------------------------------------------------------------------- } + +function Max(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the highest value of vector X + ---------------------------------------------------------------------- } + +function IntMin(X : PIntVector; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + Returns the lowest value of integer vector X + ---------------------------------------------------------------------- } + +function IntMax(X : PIntVector; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + Returns the highest value of integer vector X + ---------------------------------------------------------------------- } + +procedure Transpose(A : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer; + A_t : PMatrix); +{ ---------------------------------------------------------------------- + Transposes a matrix + ---------------------------------------------------------------------- + Input parameters : A = original matrix + Lbound1, + Lbound2 = indices of 1st matrix elem. in each dim. + Ubound1, + Ubound2 = indices of last matrix elem. in each dim. + ---------------------------------------------------------------------- + Output parameter : A_t = transposed matrix + ---------------------------------------------------------------------- } + +function GaussJordan(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + A_inv : PMatrix; X : PVector) : Integer; +{ ---------------------------------------------------------------------- + Solves a system of linear equations by the Gauss-Jordan method + ---------------------------------------------------------------------- + Input parameters : A = system matrix + B = constant vector + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameters : A_inv = inverse matrix + X = solution vector + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- } + +function InvMat(A : PMatrix; Lbound, Ubound : Integer; + A_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Computes the inverse of a square matrix by the Gauss-Jordan method + ---------------------------------------------------------------------- + Parameters : as in Gauss-Jordan + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- } + +function Det(A : PMatrix; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Computes the determinant of a square matrix + ---------------------------------------------------------------------- + Parameters : as in Gauss-Jordan + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function Cholesky(A : PMatrix; Lbound, Ubound : Integer; + L : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Cholesky decomposition. Factors the symmetric positive definite matrix + A as a product L * L', where L is a lower triangular matrix. This + procedure may be used as a test of positive definiteness. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameter : L = Cholesky factor of matrix A + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NOT_PD + ---------------------------------------------------------------------- } + +function LU_Decomp(A : PMatrix; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + LU decomposition. Factors the square matrix A as a product L * U, + where L is a lower triangular matrix (with unit diagonal terms) and U + is an upper triangular matrix. This routine is used in conjunction + with LU_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of L and U + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure LU_Solve(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations whose matrix has been transformed by + LU_Decomp + ---------------------------------------------------------------------- + Input parameters : A = result from LU_Decomp + B = constant vector + Lbound, + Ubound = as in LU_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + ---------------------------------------------------------------------- } + +function SV_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + S : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Singular value decomposition. Factors the matrix A (n x m, with n >= m) + as a product U * S * V' where U is a (n x m) column-orthogonal matrix, + S a (m x m) diagonal matrix with elements >= 0 (the singular values) + and V a (m x m) orthogonal matrix. This routine is used in conjunction + with SV_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound1 = index of last matrix element in 1st dim. + Ubound2 = index of last matrix element in 2nd dim. + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of U + S = vector of singular values + V = orthogonal matrix + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure SV_SetZero(S : PVector; Lbound, Ubound : Integer; Tol : Float); +{ ---------------------------------------------------------------------- + Sets the singular values to zero if they are lower than a specified + threshold. + ---------------------------------------------------------------------- + Input parameters : S = vector of singular values + Tol = relative tolerance + Threshold value will be Tol * Max(S) + Lbound = index of first vector element + Ubound = index of last vector element + ---------------------------------------------------------------------- + Output parameter : S = modified singular values + ---------------------------------------------------------------------- } + +procedure SV_Solve(U : PMatrix; S : PVector; V : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations by singular value decomposition, after + the matrix has been transformed by SV_Decomp, and the lowest singular + values have been set to zero by SV_SetZero. + ---------------------------------------------------------------------- + Input parameters : U, S, V = vector and matrices from SV_Decomp + B = constant vector + Lbound, + Ubound1, + Ubound2 = as in SV_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + = V * Diag(1/s(i)) * U' * B, for s(i) <> 0 + ---------------------------------------------------------------------- } + +procedure SV_Approx(U : PMatrix; S : PVector; V : PMatrix; + Lbound, Ubound1, Ubound2 : Integer; + A : PMatrix); +{ ---------------------------------------------------------------------- + Approximates a matrix A by the product USV', after the lowest singular + values have been set to zero by SV_SetZero. + ---------------------------------------------------------------------- + Input parameters : U, S, V = vector and matrices from SV_Decomp + Lbound, + Ubound1, + Ubound2 = as in SV_Decomp + ---------------------------------------------------------------------- + Output parameter : A = approximated matrix + ---------------------------------------------------------------------- } + +function QR_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + R : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + QR decomposition. Factors the matrix A (n x m, with n >= m) as a + product Q * R where Q is a (n x m) column-orthogonal matrix, and R + a (m x m) upper triangular matrix. This routine is used in conjunction + with QR_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound1 = index of last matrix element in 1st dim. + Ubound2 = index of last matrix element in 2nd dim. + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of Q + R = upper triangular matrix + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SING + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure QR_Solve(Q, R : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations by the QR decomposition, + after the matrix has been transformed by QR_Decomp. + ---------------------------------------------------------------------- + Input parameters : Q, R = matrices from QR_Decomp + B = constant vector + Lbound, + Ubound1, + Ubound2 = as in QR_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + ---------------------------------------------------------------------- } + +implementation + +const + { Used by LU procedures } + LastDim : Integer = 1; { Dimension of the last system solved } + Index : PIntVector = nil; { Records the row permutations } + + procedure DimVector(var V : PVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_FLT) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Float)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := 0.0; + end; + + procedure DimIntVector(var V : PIntVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_INT) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Integer)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := 0; + end; + + procedure DimBoolVector(var V : PBoolVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_BOOL) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Boolean)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := False; + end; + + procedure DimStrVector(var V : PStrVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_STR) then + begin + showmessage('DIMstr error'); + V := nil; + Exit; + end; + + { Allocate vector } + + GetMem(V, Succ(Ubound) * sizeof(TStrVector) {256}); + + if V = nil then Exit; + { Initialize vector } + + for I := 0 to Ubound do + V^[I] := ''; + //showmessage(inttostr(Ubound)+'b'+inttostr(MAX_STR)); + end; + + procedure DimMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_FLT) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Float); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := 0.0; + end; + + procedure DimIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_INT) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PIntVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Integer); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := 0; + end; + + procedure DimBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_BOOL) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PBoolVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Boolean); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := False; + end; + + procedure DimStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_STR) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PStrVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * 256; + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := ''; + end; + + procedure DelVector(var V : PVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Float)); + V := nil; + end; + end; + + procedure DelIntVector(var V : PIntVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Integer)); + V := nil; + end; + end; + + procedure DelBoolVector(var V : PBoolVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Boolean)); + V := nil; + end; + end; + + procedure DelStrVector(var V : PStrVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V{, Succ(Ubound) * 256}); + V := nil; + end; + end; + + procedure DelMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Float); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PVector)); + A := nil; + end; + end; + + procedure DelIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Integer); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PIntVector)); + A := nil; + end; + end; + + procedure DelBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Boolean); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PBoolVector)); + A := nil; + end; + end; + + procedure DelStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * 256; + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PStrVector)); + A := nil; + end; + end; + + procedure SwapRows(I, K : Integer; A : PMatrix; Lbound, Ubound : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + FSwap(A^[I]^[J], A^[K]^[J]); + end; + + procedure SwapCols(J, K : Integer; A : PMatrix; Lbound, Ubound : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + FSwap(A^[I]^[J], A^[I]^[K]); + end; + + procedure CopyVector(Dest, Source : PVector; Lbound, Ubound : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I] := Source^[I]; + end; + + procedure CopyMatrix(Dest, Source : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer); + var + I, J : Integer; + begin + for I := Lbound1 to Ubound1 do + for J := Lbound2 to Ubound2 do + Dest^[I]^[J] := Source^[I]^[J]; + end; + + procedure CopyRowFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Row : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + Dest^[Row]^[J] := Source^[J]; + end; + + procedure CopyColFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Col : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I]^[Col] := Source^[I]; + end; + + procedure CopyVectorFromRow(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Row : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + Dest^[J] := Source^[Row]^[J]; + end; + + procedure CopyVectorFromCol(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Col : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I] := Source^[I]^[Col]; + end; + + function Min(X : PVector; Lbound, Ubound : Integer) : Float; + var + Xmin : Float; + I : Integer; + begin + Xmin := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] < Xmin then Xmin := X^[I]; + Min := Xmin; + end; + + function Max(X : PVector; Lbound, Ubound : Integer) : Float; + var + Xmax : Float; + I : Integer; + begin + Xmax := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] > Xmax then Xmax := X^[I]; + Max := Xmax; + end; + + function IntMin(X : PIntVector; Lbound, Ubound : Integer) : Integer; + var + I, Xmin : Integer; + begin + Xmin := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] < Xmin then Xmin := X^[I]; + IntMin := Xmin; + end; + + function IntMax(X : PIntVector; Lbound, Ubound : Integer) : Integer; + var + I, Xmax : Integer; + begin + Xmax := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] > Xmax then Xmax := X^[I]; + IntMax := Xmax; + end; + + procedure Transpose(A : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer; + A_t : PMatrix); + var + I, J : Integer; + begin + for I := Lbound1 to Ubound1 do + for J := Lbound2 to Ubound2 do + A_t^[J]^[I] := A^[I]^[J]; + end; + + function GaussJordan(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + A_inv : PMatrix; X : PVector) : Integer; + var + I, J, K : Integer; + Pvt, T : Float; + PRow, PCol : PIntVector; { Store line and column of pivot } + begin + DimIntVector(PRow, Ubound); + DimIntVector(PCol, Ubound); + + { Copy A into A_inv and B into X } + CopyMatrix(A_inv, A, Lbound, Lbound, Ubound, Ubound); + CopyVector(X, B, Lbound, Ubound); + + K := Lbound; + while K <= Ubound do + begin + { Search for largest pivot in submatrix A_inv[K..Ubound, K..Ubound] } + Pvt := A_inv^[K]^[K]; + PRow^[K] := K; + PCol^[K] := K; + for I := K to Ubound do + for J := K to Ubound do + if Abs(A_inv^[I]^[J]) > Abs(Pvt) then + begin + Pvt := A_inv^[I]^[J]; + PRow^[K] := I; + PCol^[K] := J; + end; + + { Pivot too weak ==> quasi-singular matrix } + if Abs(Pvt) < MACHEP then + begin + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + GaussJordan := MAT_SINGUL; + Exit; + end; + + { Exchange current row (K) with pivot row } + if PRow^[K] <> K then + begin + SwapRows(PRow^[K], K, A_inv, Lbound, Ubound); + FSwap(X^[PRow^[K]], X^[K]); + end; + + { Exchange current column (K) with pivot column } + if PCol^[K] <> K then + SwapCols(PCol^[K], K, A_inv, Lbound, Ubound); + + { Transform pivot row } + A_inv^[K]^[K] := 1.0; + for J := Lbound to Ubound do + A_inv^[K]^[J] := A_inv^[K]^[J] / Pvt; + X^[K] := X^[K] / Pvt; + + { Transform other rows } + for I := Lbound to Ubound do + if I <> K then + begin + T := A_inv^[I]^[K]; + A_inv^[I]^[K] := 0.0; + for J := Lbound to Ubound do + A_inv^[I]^[J] := A_inv^[I]^[J] - T * A_inv^[K]^[J]; + X^[I] := X^[I] - T * X^[K]; + end; + Inc(K); + end; + + { Rearrange inverse matrix } + for I := Ubound downto Lbound do + if PCol^[I] <> I then + begin + SwapRows(PCol^[I], I, A_inv, Lbound, Ubound); + FSwap(X^[PCol^[I]], X^[I]); + end; + for J := Ubound downto Lbound do + if PRow^[J] <> J then + SwapCols(PRow^[J], J, A_inv, Lbound, Ubound); + + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + GaussJordan := MAT_OK; + end; + + function InvMat(A : PMatrix; Lbound, Ubound : Integer; + A_inv : PMatrix) : Integer; + var + I, J, K : Integer; + Pvt, T : Float; + PRow, PCol : PIntVector; { Store line and column of pivot } + begin + DimIntVector(PRow, Ubound); + DimIntVector(PCol, Ubound); + + { Copy A into A_inv } + CopyMatrix(A_inv, A, Lbound, Lbound, Ubound, Ubound); + + K := Lbound; + while K <= Ubound do + begin + { Search for largest pivot in submatrix A_inv[K..Ubound, K..Ubound] } + Pvt := A_inv^[K]^[K]; + PRow^[K] := K; + PCol^[K] := K; + for I := K to Ubound do + for J := K to Ubound do + if Abs(A_inv^[I]^[J]) > Abs(Pvt) then + begin + Pvt := A_inv^[I]^[J]; + PRow^[K] := I; + PCol^[K] := J; + end; + + { Pivot too weak ==> quasi-singular matrix } + if Abs(Pvt) < MACHEP then + begin + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + InvMat := MAT_SINGUL; + Exit; + end; + + { Exchange current row (K) with pivot row } + if PRow^[K] <> K then + SwapRows(PRow^[K], K, A_inv, Lbound, Ubound); + + { Exchange current column (K) with pivot column } + if PCol^[K] <> K then + SwapCols(PCol^[K], K, A_inv, Lbound, Ubound); + + { Transform pivot row } + A_inv^[K]^[K] := 1.0; + for J := Lbound to Ubound do + A_inv^[K]^[J] := A_inv^[K]^[J] / Pvt; + + { Transform other rows } + for I := Lbound to Ubound do + if I <> K then + begin + T := A_inv^[I]^[K]; + A_inv^[I]^[K] := 0.0; + for J := Lbound to Ubound do + A_inv^[I]^[J] := A_inv^[I]^[J] - T * A_inv^[K]^[J]; + end; + Inc(K); + end; + + { Rearrange inverse matrix } + for I := Ubound downto Lbound do + if PCol^[I] <> I then + SwapRows(PCol^[I], I, A_inv, Lbound, Ubound); + for J := Ubound downto Lbound do + if PRow^[J] <> J then + SwapCols(PRow^[J], J, A_inv, Lbound, Ubound); + + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + InvMat := MAT_OK; + end; + + function Det(A : PMatrix; Lbound, Ubound : Integer) : Float; + var + D, T : Float; { Partial determinant & multiplier } + I, J, K : Integer; { Loop variables } + ZeroDet : Boolean; { Flags a null determinant } + begin + ZeroDet := False; + D := 1.0; + K := Lbound; + + { Make the matrix upper triangular } + while not(ZeroDet) and (K < Ubound) do + begin + { If diagonal element is zero then switch rows } + if Abs(A^[K]^[K]) < MACHEP then + begin + ZeroDet := True; + I := K; + + { Try to find a row with a non-zero element in this column } + while ZeroDet and (I < Ubound) do + begin + I := Succ(I); + if Abs(A^[I]^[K]) > MACHEP then + begin + { Switch these two rows } + SwapRows(I, K, A, Lbound, Ubound); + ZeroDet := False; + { Switching rows changes the sign of the determinant } + D := - D; + end; + end; + end; + + if not(ZeroDet) then + for I := Succ(K) to Ubound do + if Abs(A^[I]^[K]) > MACHEP then + begin + { Make the K element of this row zero } + T := - A^[I]^[K] / A^[K]^[K]; + for J := 1 to Ubound do + A^[I]^[J] := A^[I]^[J] + T * A^[K]^[J]; + end; + + D := D * A^[K]^[K]; { Multiply the diagonal term into D } + Inc(K); + end; + + if ZeroDet then + Det := 0.0 + else + Det := D * A^[Ubound]^[Ubound]; + end; + + function Cholesky(A : PMatrix; Lbound, Ubound : Integer; + L : PMatrix) : Integer; + var + I, J, K : Integer; + Sum : Float; + begin + for K := Lbound to Ubound do + begin + Sum := A^[K]^[K]; + for J := Lbound to K - 1 do + Sum := Sum - Sqr(L^[K]^[J]); + + if Sum <= 0.0 then + begin + Cholesky := MAT_NOT_PD; + Exit; + end; + + L^[K]^[K] := Sqrt(Sum); + for I := K + 1 to Ubound do + begin + Sum := A^[I]^[K]; + for J := Lbound to K - 1 do + Sum := Sum - L^[I]^[J] * L^[K]^[J]; + L^[I]^[K] := Sum / L^[K]^[K]; + end; + end; + Cholesky := MAT_OK; + end; + + function LU_Decomp(A : PMatrix; Lbound, Ubound : Integer) : Integer; + const + TINY = 1.0E-20; + var + I, Imax, J, K : Integer; + Pvt, T, Sum : Float; + V : PVector; + begin + DimVector(V, Ubound); + { Reallocate Index } + if Index <> nil then + DelIntVector(Index, LastDim); + DimIntVector(Index, Ubound); + LastDim := Ubound; + + for I := Lbound to Ubound do + begin + Pvt := 0.0; + for J := Lbound to Ubound do + if Abs(A^[I]^[J]) > Pvt then + Pvt := Abs(A^[I]^[J]); + if Pvt < MACHEP then + begin + DelVector(V, Ubound); + LU_Decomp := MAT_SINGUL; + Exit; + end; + V^[I] := 1.0 / Pvt; + end; + for J := Lbound to Ubound do + begin + for I := Lbound to Pred(J) do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(I) do + Sum := Sum - A^[I]^[K] * A^[K]^[J]; + A^[I]^[J] := Sum; + end; + Pvt := 0.0; + for I := J to Ubound do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(J) do + Sum := Sum - A^[I]^[K] * A^[K]^[J]; + A^[I]^[J] := Sum; + T := V^[I] * Abs(Sum); + if T > Pvt then + begin + Pvt := T; + Imax := I; + end; + end; + if J <> Imax then + begin + SwapRows(Imax, J, A, Lbound, Ubound); + V^[Imax] := V^[J]; + end; + Index^[J] := Imax; + if A^[J]^[J] = 0.0 then + A^[J]^[J] := TINY; + if J <> Ubound then + begin + T := 1.0 / A^[J]^[J]; + for I := Succ(J) to Ubound do + A^[I]^[J] := A^[I]^[J] * T; + end; + end; + DelVector(V, Ubound); + LU_Decomp := MAT_OK; + end; + + procedure LU_Solve(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + X : PVector); + var + I, Ip, J, K : Integer; + Sum : Float; + begin + K := Pred(Lbound); + CopyVector(X, B, Lbound, Ubound); + for I := Lbound to Ubound do + begin + Ip := Index^[I]; + Sum := X^[Ip]; + X^[Ip] := X^[I]; + if K >= Lbound then + for J := K to Pred(I) do + Sum := Sum - A^[I]^[J] * X^[J] + else if Sum <> 0.0 then + K := I; + X^[I] := Sum; + end; + for I := Ubound downto Lbound do + begin + Sum := X^[I]; + if I < Ubound then + for J := Succ(I) to Ubound do + Sum := Sum - A^[I]^[J] * X^[J]; + X^[I] := Sum / A^[I]^[I]; + end; + end; + + function SV_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + S : PVector; V : PMatrix) : Integer; + label + 1, 2, 3; + var + I, Its, J, JJ, K, L, N : Integer; + Anorm, C, F, G, H, Sum, Scale, T, X, Y, Z : Float; + R : PVector; + begin + G := 0.0; + Scale := 0.0; + Anorm := 0.0; + DimVector(R, Ubound2); + for I := Lbound to Ubound2 do + begin + L := I + 1; + R^[I] := Scale * G; + G := 0.0; + Sum := 0.0; + Scale := 0.0; + if I <= Ubound1 then + begin + for K := I to Ubound1 do + Scale := Scale + Abs(A^[K]^[I]); + if Scale <> 0.0 then + begin + for K := I to Ubound1 do + begin + A^[K]^[I] := A^[K]^[I] / Scale; + Sum := Sum + A^[K]^[I] * A^[K]^[I]; + end; + F := A^[I]^[I]; + G := - Sgn(F) * Sqrt(Sum); + H := F * G - Sum; + A^[I]^[I] := F - G; + if I <> Ubound2 then + begin + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := I to Ubound1 do + Sum := Sum + A^[K]^[I] * A^[K]^[J]; + F := Sum / H; + for K := I to Ubound1 do + A^[K]^[J] := A^[K]^[J] + F * A^[K]^[I]; + end; + end; + for K := I to Ubound1 do + A^[K]^[I] := Scale * A^[K]^[I]; + end; + end; + S^[I] := Scale * G; + G := 0.0; + Sum := 0.0; + Scale := 0.0; + if (I <= Ubound1) and (I <> Ubound2) then + begin + for K := L to Ubound2 do + Scale := Scale + Abs(A^[I]^[K]); + if Scale <> 0.0 then + begin + for K := L to Ubound2 do + begin + A^[I]^[K] := A^[I]^[K] / Scale; + Sum := Sum + A^[I]^[K] * A^[I]^[K]; + end; + F := A^[I]^[L]; + G := - Sgn(F) * Sqrt(Sum); + H := F * G - Sum; + A^[I]^[L] := F - G; + for K := L to Ubound2 do + R^[K] := A^[I]^[K] / H; + if I <> Ubound1 then + for J := L to Ubound1 do + begin + Sum := 0.0; + for K := L to Ubound2 do + Sum := Sum + A^[J]^[K] * A^[I]^[K]; + for K := L to Ubound2 do + A^[J]^[K] := A^[J]^[K] + Sum * R^[K]; + end; + for K := L to Ubound2 do + A^[I]^[K] := Scale * A^[I]^[K]; + end; + end; + Anorm := FMax(Anorm, Abs(S^[I]) + Abs(R^[I])); + end; + for I := Ubound2 downto Lbound do + begin + if I < Ubound2 then + begin + if G <> 0.0 then + begin + for J := L to Ubound2 do + V^[J]^[I] := (A^[I]^[J] / A^[I]^[L]) / G; + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := L to Ubound2 do + Sum := Sum + A^[I]^[K] * V^[K]^[J]; + for K := L to Ubound2 do + V^[K]^[J] := V^[K]^[J] + Sum * V^[K]^[I]; + end; + end; + for J := L to Ubound2 do + begin + V^[I]^[J] := 0.0; + V^[J]^[I] := 0.0; + end; + end; + V^[I]^[I] := 1.0; + G := R^[I]; + L := I; + end; + for I := Ubound2 downto Lbound do + begin + L := I + 1; + G := S^[I]; + if I < Ubound2 then + for J := L to Ubound2 do + A^[I]^[J] := 0.0; + if G <> 0.0 then + begin + G := 1.0 / G; + if I <> Ubound2 then + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := L to Ubound1 do + Sum := Sum + A^[K]^[I] * A^[K]^[J]; + F := (Sum / A^[I]^[I]) * G; + for K := I to Ubound1 do + A^[K]^[J] := A^[K]^[J] + F * A^[K]^[I]; + end; + for J := I to Ubound1 do + A^[J]^[I] := A^[J]^[I] * G; + end + else + for J := I to Ubound1 do + A^[J]^[I] := 0.0; + A^[I]^[I] := A^[I]^[I] + 1.0; + end; + for K := Ubound2 downto Lbound do + begin + for Its := 1 to 30 do + begin + for L := K downto Lbound do + begin + N := L - 1; + if (Abs(R^[L]) + Anorm) = Anorm then goto 2; + if (Abs(S^[N]) + Anorm) = Anorm then goto 1; + end; +1: T := 1.0; + for I := L to K do + begin + F := T * R^[I]; + if (Abs(F) + Anorm) <> Anorm then + begin + G := S^[I]; + H := Pythag(F, G); + S^[I] := H; + H := 1.0 / H; + C := G * H; + T := - (F * H); + for J := Lbound to Ubound1 do + begin + Y := A^[J]^[N]; + Z := A^[J]^[I]; + A^[J]^[N] := (Y * C) + (Z * T); + A^[J]^[I] := - (Y * T) + (Z * C); + end; + end; + end; +2: Z := S^[K]; + if L = K then + begin + if Z < 0.0 then + begin + S^[K] := - Z; + for J := Lbound to Ubound2 do + V^[J]^[K] := - V^[J]^[K]; + end; + goto 3 + end; + if Its = 30 then + begin + DelVector(R, Ubound2); + SV_Decomp := MAT_NON_CONV; + Exit; + end; + X := S^[L]; + N := K - 1; + Y := S^[N]; + G := R^[N]; + H := R^[K]; + F := ((Y - Z) * (Y + Z) + (G - H) * (G + H)) / (2.0 * H * Y); + G := Pythag(F, 1.0); + F := ((X - Z) * (X + Z) + H * ((Y / (F + Sgn(F) * Abs(G))) - H)) / X; + C := 1.0; + T := 1.0; + for J := L to N do + begin + I := J + 1; + G := R^[I]; + Y := S^[I]; + H := T * G; + G := C * G; + Z := Pythag(F, H); + R^[J] := Z; + C := F / Z; + T := H / Z; + F := (X * C) + (G * T); + G := - (X * T) + (G * C); + H := Y * T; + Y := Y * C; + for JJ := Lbound to Ubound2 do + begin + X := V^[JJ]^[J]; + Z := V^[JJ]^[I]; + V^[JJ]^[J] := (X * C) + (Z * T); + V^[JJ]^[I] := - (X * T) + (Z * C); + end; + Z := Pythag(F, H); + S^[J] := Z; + if Z <> 0.0 then + begin + Z := 1.0 / Z; + C := F * Z; + T := H * Z; + end; + F := (C * G) + (T * Y); + X := - (T * G) + (C * Y); + for JJ := Lbound to Ubound1 do + begin + Y := A^[JJ]^[J]; + Z := A^[JJ]^[I]; + A^[JJ]^[J] := (Y * C) + (Z * T); + A^[JJ]^[I] := - (Y * T) + (Z * C); + end + end; + R^[L] := 0.0; + R^[K] := F; + S^[K] := X; + end; +3: + end; + DelVector(R, Ubound2); + SV_Decomp := MAT_OK; + end; + + procedure SV_SetZero(S : PVector; Lbound, Ubound : Integer; Tol : Float); + var + Threshold : Float; + I : Integer; + begin + Threshold := Tol * Max(S, Lbound, Ubound); + for I := Lbound to Ubound do + if S^[I] < Threshold then S^[I] := 0.0; + end; + + procedure SV_Solve(U : PMatrix; S : PVector; V : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); + var + I, J, JJ : Integer; + Sum : Float; + Tmp : PVector; + begin + DimVector(Tmp, Ubound2); + for J := Lbound to Ubound2 do + begin + Sum := 0.0; + if S^[J] > 0.0 then + begin + for I := Lbound to Ubound1 do + Sum := Sum + U^[I]^[J] * B^[I]; + Sum := Sum / S^[J]; + end; + Tmp^[J] := Sum; + end; + for J := Lbound to Ubound2 do + begin + Sum := 0.0; + for JJ := Lbound to Ubound2 do + Sum := Sum + V^[J]^[JJ] * Tmp^[JJ]; + X^[J] := Sum; + end; + DelVector(Tmp, Ubound2); + end; + + procedure SV_Approx(U : PMatrix; S : PVector; V : PMatrix; + Lbound, Ubound1, Ubound2 : Integer; A : PMatrix); + var + I, J, K : Integer; + begin + for I := Lbound to Ubound1 do + for J := Lbound to Ubound2 do + begin + A^[I]^[J] := 0.0; + for K := Lbound to Ubound2 do + if S^[K] > 0.0 then + A^[I]^[J] := A^[I]^[J] + U^[I]^[K] * V^[J]^[K]; + end; + end; + + function QR_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + R : PMatrix) : Integer; + var + I, J, K : Integer; + Sum : Float; + begin + for K := Lbound to Ubound2 do + begin + { Compute the "k"th diagonal entry in R } + Sum := 0.0; + for I := Lbound to Ubound1 do + Sum := Sum + Sqr(A^[I]^[K]); + + if Sum = 0.0 then + begin + QR_Decomp := MAT_SINGUL; + Exit; + end; + + R^[K]^[K] := Sqrt(Sum); + + { Divide the entries in the "k"th column of A by the computed "k"th } + { diagonal element of R. this begins the process of overwriting A } + { with Q . . . } + for I := Lbound to Ubound1 do + A^[I]^[K] := A^[I]^[K] / R^[K]^[K]; + + for J := (K + 1) to Ubound2 do + begin + { Complete the remainder of the row entries in R } + Sum := 0.0; + for I := Lbound to Ubound1 do + Sum := Sum + A^[I]^[K] * A^[I]^[J]; + R^[K]^[J] := Sum; + + { Update the column entries of the Q/A matrix } + for I := Lbound to Ubound1 do + A^[I]^[J] := A^[I]^[J] - A^[I]^[K] * R^[K]^[J]; + end; + end; + + QR_Decomp := MAT_OK; + end; + + procedure QR_Solve(Q, R : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); + var + I, J : Integer; + Sum : Float; + begin + { Form Q'B and store the result in X } + for J := Lbound to Ubound2 do + begin + X^[J] := 0.0; + for I := Lbound to Ubound1 do + X^[J] := X^[J] + Q^[I]^[J] * B^[I]; + end; + + { Update X with the solution vector } + X^[Ubound2] := X^[Ubound2] / R^[Ubound2]^[Ubound2]; + for I := (Ubound2 - 1) downto Lbound do + begin + Sum := 0.0; + for J := (I + 1) to Ubound2 do + Sum := Sum + R^[I]^[J] * X^[J]; + X^[I] := (X^[I] - Sum) / R^[I]^[I]; + end; + end; + +end. diff --git a/npm/dmath/Regress.pas b/npm/dmath/Regress.pas new file mode 100755 index 0000000..3ed2bd3 --- /dev/null +++ b/npm/dmath/Regress.pas @@ -0,0 +1,1323 @@ +{ ********************************************************************** + * Unit REGRESS.PAS * + * Version 2.2 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Regression routines + ********************************************************************** } + +unit Regress; + +interface + +uses + FMath, Matrices, Eigen, Optim, SimOpt, Stat,dialogs; + +{ ********************************************************************** + Type definitions + ********************************************************************** } + +{ Algorithm for linear regression } +type + TRegAlgo = ( + GAUSS_JORDAN, { Gauss-Jordan solution of normal equations } + SVD); { Singular value decomposition } + +{ Optimization algorithm for nonlinear regression } +type + TOptAlgo = ( + NL_MARQ, { Marquardt algorithm } + NL_SIMP, { Simplex algorithm } + NL_BFGS, { BFGS algorithm } + NL_SA); { Simulated annealing } + +{ Regression modes } +type + TRegMode = (UNWEIGHTED, WEIGHTED); + +{ Regression function } +type + TRegFunc = function(X : Float; B : PVector) : Float; + +{ Procedure to compute the derivatives of the regression function + with respect to the regression parameters } +type + TDerivProc = procedure(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + +{ Test of regression } +type + TRegTest = record + Vr, { Residual variance } + R2, { Coefficient of determination } + R2a, { Adjusted coeff. of determination } + F, { Variance ratio (explained/residual) } + Prob : Float; { Probability of F } + end; + +{ ********************************************************************** + Procedures to modify the regression settings + ********************************************************************** } + +procedure SetRegAlgo(Algo : TRegAlgo); +{ ---------------------------------------------------------------------- + Sets the linear regression algorithm according to Algo, which must be + GAUSS_JORDAN or SVD. The default algorithm is SVD. + ---------------------------------------------------------------------- } + +procedure SetOptAlgo(Algo : TOptAlgo); +{ ---------------------------------------------------------------------- + Sets the optimization algorithm according to Algo, which must be + NL_MARQ, NL_SIMP, NL_BFGS or NL_SA. The default algorithm is NL_MARQ. + ---------------------------------------------------------------------- } + +procedure SetFirstPoint(Index : Integer); +{ ---------------------------------------------------------------------- + Sets the index of the first data point (usually 0 or 1). The default + value is 1. + ---------------------------------------------------------------------- } + +function GetRegAlgo : TRegAlgo; +{ ---------------------------------------------------------------------- + Returns the linear regression algorithm + ---------------------------------------------------------------------- } + +function GetOptAlgo : TOptAlgo; +{ ---------------------------------------------------------------------- + Returns the optimization algorithm + ---------------------------------------------------------------------- } + +function GetFirstPoint : Integer; +{ ---------------------------------------------------------------------- + Returns the index of the first data point + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Unweighted regression routines + ********************************************************************** + These routines fit equations to data by minimizing the sum of squared + residuals : + SS = Sum [y(k) - ycalc(k)]^2 + + where y(k) and ycalc(k) are respectively the observed and calculated + value of the dependent variable for observation k. ycalc(k) is a + function of the regression parameters b(0), b(1) ... + + The following regression types are implemented : + + * Simple linear regression : + + y(k) = b(0) + b(1) * x(k) + + * Multiple linear regression : + + y(k) = b(0) + b(1) * x(1,k) + b(2) * x(2,k) + ... + b(Nvar) * x(Nvar,k) + + * Polynomial regression : + + y(k) = b(0) + b(1) * x(k) + b(2) * x(k)^2 + ... + b(Deg) * x(k)^Deg + + * Nonlinear regression : + + y(k) = f[x(k), b(0), b(1), ... ] + + where f is a user-specified function. + + The following parameters are common to all routines : + + Input : X = Vector or matrix of independent variables + Y = Vector of dependent variable + N = Index of the last observation + Output : B = Regression parameters + V = Inverse matrix of normal equations + ********************************************************************** } + +function LinFit(X, Y : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Simple linear regression + ---------------------------------------------------------------------- } + +function MulFit(X : PMatrix; Y : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Multiple linear regression + ---------------------------------------------------------------------- + Additional input parameters : + Nvar = Index of the last independent variable + ConsTerm = Flags the presence of a constant term b(0) + ---------------------------------------------------------------------- } + +function PolFit(X, Y : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Polynomial regression + ---------------------------------------------------------------------- + Additional input parameter : + Deg = Degree of polynomial + ---------------------------------------------------------------------- } + +function NLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Nonlinear regression + ---------------------------------------------------------------------- + Additional input parameters : + RegFunc = Regression function + DerivProc = Procedure to compute the derivatives of RegFunc + Lbound, Ubound = Indices of first and last function parameters + MaxIter = Maximum number of iterations + Tol = Required parameter precision + B = Initial parameter values + B_min, B_max = Lower and upper parameter bounds + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Weighted regression routines + ********************************************************************** + These routines fit equations to data by minimizing the sum of weighted + squared residuals : + + SWS = Sum w(k)*[y(k) - ycalc(k)]^2 + + where the "weight" w(k) is inversely proportional to the variance v(k) + of the observation y(k). v(k) is usually computed as : + + v(k) = Vr * g[y(k)] = Vr / w(k) + + where Vr is the residual variance and g is a user-specified function + (e.g. g[y(k)] = y(k)^2 for a constant coefficient of variation). + + Function syntax and results are the same than for unweighted regression + except that the vector of weights (W) is passed as an additional input + parameter. + ********************************************************************** } + +function WLinFit(X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + +function WMulFit(X : PMatrix; Y, W : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + +function WPolFit(X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + +function WNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y, W : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + +{ ********************************************************************** + Procedure to compute the derivatives of the regression function by + numerical differentiation. + ********************************************************************** } + +procedure NumDeriv(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); +{ ---------------------------------------------------------------------- + Input parameters : RegFunc = Regression function + X, Y = Coordinates of point + B = Regression parameters + + Output parameter : D = Derivatives (D^[I] contains the + derivative w.r.t. parameter B^[I]) + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Routines to test the quality of the regression + ********************************************************************** + These routines compute the variance-covariance matrix of the fitted + parameters and the different statistics used to test the quality of + the fit. + + Input parameters : Y = Vector of dependent variable + Ycalc = Computed Y values + W = Vector of weights (if any) + N = Index of the last observation + Lbound, + Ubound = Indices of first & last fitted parameters + V = Inverse normal equations matrix + + Output parameters : V = Variance-covariance matrix + Test = Test statistics (Vr, R2, R2a, F, Prob) + ********************************************************************** } + +procedure RegTest(Y, Ycalc : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); +{ ---------------------------------------------------------------------- + Test of unweighted regression + ---------------------------------------------------------------------- } + +procedure WRegTest(Y, Ycalc, W : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); +{ ---------------------------------------------------------------------- + Test of weighted regression + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Test of regression parameters + ********************************************************************** } + +procedure ParamTest(B : PVector; V : PMatrix; N, Lbound, Ubound : Integer; + S, T, Prob : PVector); +{ ---------------------------------------------------------------------- + This routine tests the significance of the parameters. It must be + called AFTER RegTest or WRegTest since it uses the variance-covariance + matrix. + ---------------------------------------------------------------------- + Input parameters : B = Regression parameters + V = Variance-covariance matrix + N = Index of the last observation + Lbound, + Ubound = Indices of first & last fitted parameters + ---------------------------------------------------------------------- + Output parameters : S = Standard deviations of parameters + T = Student's t + Prob = Probabilities + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Correlation and principal component analysis + + Common parameters: + + X = matrix of variables (X^[I] contains the I-th variable) + N = Index of the last observation + Lbound, Ubound = Indices of first & last variables + M = Mean vector (M^[I] = mean of X^[I]) + S = Vector of standard deviations + V = Variance-covariance matrix + R = Correlation matrix + ********************************************************************** } + +procedure VecMean(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector); +{ ---------------------------------------------------------------------- + Computes the mean vector (M) from matrix X + + Input : X, Lbound, Ubound + Output : M + ---------------------------------------------------------------------- } + +procedure VecSD(X : PMatrix; N, Lbound, Ubound : Integer; M, S : PVector); +{ ---------------------------------------------------------------------- + Computes the vector of standard deviations (S) from matrix X + + Input : X, Lbound, Ubound, M + Output : S + ---------------------------------------------------------------------- } + +procedure MatVarCov(X : PMatrix; N, Lbound, Ubound : Integer; + M : PVector; V : PMatrix); +{ ---------------------------------------------------------------------- + Computes the variance-covariance matrix (V) from matrix X + + Input : X, Lbound, Ubound, M + Output : V + ---------------------------------------------------------------------- } + +procedure MatCorrel(V : PMatrix; Lbound, Ubound : Integer; R : PMatrix); +{ ---------------------------------------------------------------------- + Computes the correlation matrix (R) from the variance-covariance + matrix (V) + + Input : V, Lbound, Ubound + Output : R + ---------------------------------------------------------------------- } + +function PCA(R : PMatrix; Lbound, Ubound : Integer; + Lambda : PVector; C, Rc : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Performs a principal component analysis of the correlation matrix R + ---------------------------------------------------------------------- + Input : R, Lbound, Ubound + Output : Lambda = Eigenvalues of the correlation matrix + (in descending order) + C = Eigenvectors of the correlation matrix + (C^[I] is the I-th eigenvector) + Rc = Correlations between principal factors and variables + (R^[I]^[J] is the correlation coefficient between + factor I and variable J) + ---------------------------------------------------------------------- + Possible results : MAT_OK : No error + MAT_NON_CONV : Non-convergence of eigenvalue + determination + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix R + ---------------------------------------------------------------------- } + +procedure ScaleVar(X : PMatrix; N, Lbound, Ubound : Integer; + M, S : PVector; Z : PMatrix); +{ ---------------------------------------------------------------------- + Scales a set of variables by subtracting means and dividing by SD's + ---------------------------------------------------------------------- + Input : X, N, Lbound, Ubound, M, S + Output : Z = matrix of scaled variables (Z^[I] contains the I-th var.) + ---------------------------------------------------------------------- } + +procedure PrinFac(Z : PMatrix; N, Lbound, Ubound : Integer; C, F : PMatrix); +{ ---------------------------------------------------------------------- + Computes principal factors + ---------------------------------------------------------------------- + Input : Z, N, Lbound, Ubound + C = matrix of eigenvectors from PCA + Output : F = matrix of principal factors (F^[I] contains the I-th factor) + ---------------------------------------------------------------------- } + +implementation + +{ Constants for eigenvalue determination in PCA } +const + PCA_MAXITER = 100; { Max number of iterations } + PCA_TOL = 1.0E-6; { Required precision } + MAX_FUNC = 1.0E+30; { Max. value for objective function + (used to prevent overflow) } +{ Default settings } +const + RegAlgo : TRegAlgo = SVD; { Linear regression algorithm } + OptAlgo : TOptAlgo = NL_MARQ; { Optimization algorithms } + FirstPoint : Integer = 1; { Index of first data point } + +{ Global variables used by the nonlinear regression routines } +const + NN : Integer = 1; { Number of observations } + XX : PVector = nil; { X coordinates } + YY : PVector = nil; { Y coordinates } + WW : PVector = nil; { Weights } + YYcalc : PVector = nil; { Estimated Y values } + FirstParam : Integer = 0; { Index of first fitted parameter } + LastParam : Integer = 1; { Index of last fitted parameter } + ParamMin : PVector = nil; { Lower bounds on parameters } + ParamMax : PVector = nil; { Higher bounds on parameters } + +var + RegFunc1 : TRegFunc; { Regression function } + DerivProc1 : TDerivProc; { Derivation procedure } + + function TolSVD(N : Integer) : Float; + { This function sets the relative threshold below which a singular value + is considered zero. N is the number of observations. } + begin + TolSVD := N * MACHEP; + end; + + procedure SetRegAlgo(Algo : TRegAlgo); + begin + RegAlgo := Algo; + end; + + procedure SetOptAlgo(Algo : TOptAlgo); + begin + OptAlgo := Algo; + end; + + procedure SetFirstPoint(Index : Integer); + begin + if Index >= 0 then + FirstPoint := Index; + end; + + function GetRegAlgo : TRegAlgo; + begin + GetRegAlgo := RegAlgo; + end; + + function GetOptAlgo : TOptAlgo; + begin + GetOptAlgo := OptAlgo; + end; + + function GetFirstPoint : Integer; + begin + GetFirstPoint := FirstPoint; + end; + + function GenLinFit(Mode : TRegMode; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General linear regression routine + ---------------------------------------------------------------------- } + var + WX, S, SX, SY, SX2, SXY, D : Float; + K : Integer; + begin + S := 0.0; + SX := 0.0; + SY := 0.0; + SX2 := 0.0; + SXY := 0.0; + if Mode = UNWEIGHTED then + begin + S := N - FirstPoint + 1; + for K := FirstPoint to N do + begin + SX := SX + X^[K]; + SY := SY + Y^[K]; + SX2 := SX2 + Sqr(X^[K]); + SXY := SXY + X^[K] * Y^[K]; + end; + end + else + begin + for K := FirstPoint to N do + begin + WX := W^[K] * X^[K]; + S := S + W^[K]; + SX := SX + WX; + SY := SY + W^[K] * Y^[K]; + SX2 := SX2 + WX * X^[K]; + SXY := SXY + WX * Y^[K]; + end; + end; + D := S * SX2 - Sqr(SX); + if D <= 0.0 then + GenLinFit := MAT_SINGUL + else + begin + V^[0]^[0] := SX2 / D; + V^[0]^[1] := - SX / D; + V^[1]^[0] := V^[0]^[1]; + V^[1]^[1] := S / D; + B^[0] := V^[0]^[0] * SY + V^[0]^[1] * SXY; + B^[1] := V^[1]^[0] * SY + V^[1]^[1] * SXY; + GenLinFit := MAT_OK; + end; + end; + + function LinFit(X, Y : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + LinFit := GenLinFit(UNWEIGHTED, X, Y, W, N, B, V); + end; + + function WLinFit(X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + begin + WLinFit := GenLinFit(WEIGHTED, X, Y, W, N, B, V); + end; + + function Gauss_GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine (Gauss-Jordan algorithm) + ---------------------------------------------------------------------- } + var + A : PMatrix; { Matrix of normal equations } + G : PVector; { Constant vector } + I, J, K : Integer; { Loop variables } + WX : Float; + begin + DimMatrix(A, Nvar, Nvar); + DimVector(G, Nvar); + + { If constant term, set line 0 and column 0 of matrix A, + and element 0 of vecteur G } + if ConsTerm then + begin + if Mode = UNWEIGHTED then + begin + A^[0]^[0] := Int(N - FirstPoint + 1); + for K := FirstPoint to N do + begin + for J := 1 to Nvar do + A^[0]^[J] := A^[0]^[J] + X^[J]^[K]; + G^[0] := G^[0] + Y^[K]; + end; + end + else + begin + for K := FirstPoint to N do + begin + A^[0]^[0] := A^[0]^[0] + W^[K]; + for J := 1 to Nvar do + A^[0]^[J] := A^[0]^[J] + W^[K] * X^[J]^[K]; + G^[0] := G^[0] + W^[K] * Y^[K]; + end; + end; + for J := 1 to Nvar do + A^[J]^[0] := A^[0]^[J]; + end; + + { Set other elements of A and G } + if Mode = UNWEIGHTED then + for K := FirstPoint to N do + for I := 1 to Nvar do + begin + for J := I to Nvar do + A^[I]^[J] := A^[I]^[J] + X^[I]^[K] * X^[J]^[K]; + G^[I] := G^[I] + X^[I]^[K] * Y^[K]; + end + else + for K := FirstPoint to N do + for I := 1 to Nvar do + begin + WX := W^[K] * X^[I]^[K]; + for J := I to Nvar do + A^[I]^[J] := A^[I]^[J] + WX * X^[J]^[K]; + G^[I] := G^[I] + WX * Y^[K]; + end; + + { Fill in symmetric matrix } + for I := 2 to Nvar do + for J := 1 to Pred(I) do + A^[I]^[J] := A^[J]^[I]; + + { Solve normal equations } + if ConsTerm then + Gauss_GenMulFit := GaussJordan(A, G, 0, Nvar, V, B) + else + Gauss_GenMulFit := GaussJordan(A, G, 1, Nvar, V, B); + + DelMatrix(A, Nvar, Nvar); + DelVector(G, Nvar); + end; + + function SVD_GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine (SVD algorithm) + ---------------------------------------------------------------------- } + var + U : PMatrix; { Matrix of independent variables for SVD } + Z : PVector; { Vector of dependent variables for SVD } + S : PVector; { Singular values } + S2inv : PVector; { Inverses of squared singular values } + V1 : PMatrix; { Orthogonal matrix from SVD } + Lbound : Integer; { Lower bound of U matrix in both dims. } + Ubound : Integer; { Upper bound of U matrix in 1st dim. } + I, J, K : Integer; { Loop variables } + Sigma : Float; { Square root of weight } + Sum : Float; { Element of variance-covariance matrix } + ErrCode : Integer; { Error code } + begin + if ConsTerm then + begin + Lbound := 0; + Ubound := N - FirstPoint; + end + else + begin + Lbound := 1; + Ubound := N - FirstPoint + 1; + end; + + { Dimension arrays } + DimMatrix(U, Ubound, Nvar); + DimVector(Z, Ubound); + DimVector(S, Nvar); + DimVector(S2inv, Nvar); + DimMatrix(V1, Nvar, Nvar); + + { ---------------------------------------------------------- + Prepare arrays for SVD : + If constant term, use U[0..(N - FirstPoint), 0..Nvar] + and Z[0..(N - FirstPoint)] + Else use U[1..(N - FirstPoint + 1), 1..Nvar] + and Z[1..(N - FirstPoint + 1)] + ---------------------------------------------------------- } + if Mode = UNWEIGHTED then + for I := Lbound to Ubound do + begin + K := I - Lbound + FirstPoint; + Z^[I] := Y^[K]; + if ConsTerm then + U^[I]^[0] := 1.0; + for J := 1 to Nvar do + U^[I]^[J] := X^[J]^[K]; + end + else + for I := Lbound to Ubound do + begin + K := I - Lbound + FirstPoint; + Sigma := Sqrt(W^[K]); + Z^[I] := Y^[K] * Sigma; + if ConsTerm then + U^[I]^[0] := Sigma; + for J := 1 to Nvar do + U^[I]^[J] := X^[J]^[K] * Sigma; + end; + + { Perform singular value decomposition } + ErrCode := SV_Decomp(U, Lbound, Ubound, Nvar, S, V1); + + if ErrCode = MAT_OK then + begin + { Set the lowest singular values to zero } + SV_SetZero(S, Lbound, Nvar, TolSVD(N - FirstPoint + 1)); + + { Solve the system } + SV_Solve(U, S, V1, Z, Lbound, Ubound, Nvar, B); + + { Compute variance-covariance matrix } + for I := Lbound to Nvar do + if S^[I] > 0.0 then + S2inv^[I] := 1.0 / Sqr(S^[I]) + else + S2inv^[I] := 0.0; + for I := Lbound to Nvar do + for J := Lbound to I do + begin + Sum := 0.0; + for K := Lbound to Nvar do + Sum := Sum + V1^[I]^[K] * V1^[J]^[K] * S2inv^[K]; + V^[I]^[J] := Sum; + V^[J]^[I] := Sum; + end; + end; + + SVD_GenMulFit := ErrCode; + + DelMatrix(U, Ubound, Nvar); + DelVector(Z, Ubound); + DelVector(S, Nvar); + DelVector(S2inv, Nvar); + DelMatrix(V1, Nvar, Nvar); + end; + + function GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine + ---------------------------------------------------------------------- } + begin + case RegAlgo of + GAUSS_JORDAN : GenMulFit := Gauss_GenMulFit(Mode, X, Y, W, N, Nvar, + ConsTerm, B, V); + SVD : GenMulFit := SVD_GenMulFit(Mode, X, Y, W, N, Nvar, + ConsTerm, B, V); + end; + end; + + function MulFit(X : PMatrix; Y : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + MulFit := GenMulFit(UNWEIGHTED, X, Y, W, N, Nvar, ConsTerm, B, V); + end; + + function WMulFit(X : PMatrix; Y, W : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + begin + WMulFit := GenMulFit(WEIGHTED, X, Y, W, N, Nvar, ConsTerm, B, V); + end; + + procedure PowMat(X : PVector; N, Deg : Integer; U : PMatrix); +{ ---------------------------------------------------------------------- + Computes matrix of increasing powers of X for polynomial regression + ---------------------------------------------------------------------- } + var + I, K : Integer; + begin + for K := FirstPoint to N do + begin + U^[1]^[K] := X^[K]; + for I := 2 to Deg do + U^[I]^[K] := U^[I - 1]^[K] * X^[K]; + end; + end; + + function GenPolFit(Mode : TRegMode; X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General polynomial regression routine + ---------------------------------------------------------------------- } + var + U : PMatrix; + begin + DimMatrix(U, Deg, N); + PowMat(X, N, Deg, U); + GenPolFit := GenMulFit(Mode, U, Y, W, N, Deg, True, B, V); + DelMatrix(U, Deg, N); + end; + + function PolFit(X, Y : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + PolFit := GenPolFit(UNWEIGHTED, X, Y, W, N, Deg, B, V); + end; + + function WPolFit(X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + begin + WPolFit := GenPolFit(WEIGHTED, X, Y, W, N, Deg, B, V); + end; + + procedure SetGlobalVar(RegFunc : TRegFunc; DerivProc : TDerivProc; + Mode : TRegMode; X, Y, W : PVector; + N, Lbound, Ubound : Integer; + B_min, B_max : PVector); + { Sets the global variables used by the nonlinear regression routines } + begin + DelVector(XX, NN); + DelVector(YY, NN); + DelVector(YYcalc, NN); + + DimVector(XX, N); + DimVector(YY, N); + DimVector(YYcalc, N); + + CopyVector(XX, X, FirstPoint, N); + CopyVector(YY, Y, FirstPoint, N); + + if Mode = WEIGHTED then + begin + DelVector(WW, NN); + DimVector(WW, N); + CopyVector(WW, W, FirstPoint, N); + end; + + NN := N; + + DelVector(ParamMin, LastParam); + DelVector(ParamMax, LastParam); + + DimVector(ParamMin, Ubound); + DimVector(ParamMax, Ubound); + + CopyVector(ParamMin, B_min, Lbound, Ubound); + CopyVector(ParamMax, B_max, Lbound, Ubound); + + FirstParam := Lbound; + LastParam := Ubound; + + RegFunc1 := RegFunc; + DerivProc1 := DerivProc; + end; + + {$F+} + + procedure NumDeriv(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + var + I : Integer; + Eps, Temp, Y1 : Float; + begin + Eps := Sqrt(MACHEP); + for I := FirstParam to LastParam do + begin + Temp := B^[I]; { Save parameter } + B^[I] := B^[I] + Eps * Abs(B^[I]); { Modified parameter } + Y1 := RegFunc(X, B); + D^[I] := (Y1 - Y) / (B^[I] - Temp); { Derivative } + B^[I] := Temp; { Restore parameter } + end; + end; + + function OutOfBounds(B, B_min, B_max : PVector) : Boolean; + { Check if the parameters are inside the bounds } + var + I : Integer; + OoB : Boolean; + begin + I := FirstParam; + OoB := False; + repeat + OoB := (B^[I] < B_min^[I]) or (B^[I] > B_max^[I]); + Inc(I); + until OoB or (I > LastParam); + OutOfBounds := OoB; + end; + + function OLS_ObjFunc(B : PVector) : Float; + { Objective function for unweighted nonlinear regression } + var + K : Integer; + S : Float; + begin + if OutOfBounds(B, ParamMin, ParamMax) then + begin + OLS_ObjFunc := MAX_FUNC; + Exit; + end; + S := 0.0; + K := FirstPoint; + repeat + YYcalc^[K] := RegFunc1(XX^[K], B); + S := S + Sqr(YY^[K] - YYcalc^[K]); + Inc(K); + until (K > NN) or (S > MAX_FUNC); + if S > MAX_FUNC then S := MAX_FUNC; + OLS_ObjFunc := S; + end; + + procedure OLS_Gradient(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; G : PVector); + { Gradient for unweighted nonlinear regression. + Func is a dummy parameter here. } + var + I, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + G^[I] := 0.0; + + { Compute Gradient } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + G^[I] := G^[I] - D^[I] * R; + end; + + for I := Lbound to Ubound do + G^[I] := 2.0 * G^[I]; + + DelVector(D, Ubound); + end; + + procedure OLS_HessGrad(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; + G : PVector; H : PMatrix); + { Gradient and Hessian for unweighted nonlinear regression. + Func is a dummy parameter here. } + var + I, J, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + begin + DimVector(D, Ubound); + + { Initializations } + for I := Lbound to Ubound do + begin + G^[I] := 0.0; + for J := I to Ubound do + H^[I]^[J] := 0.0; + end; + + { Compute Gradient & Hessian } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + G^[I] := G^[I] - D^[I] * R; + for J := I to Ubound do + H^[I]^[J] := H^[I]^[J] + D^[I] * D^[J]; + end; + end; + + { Fill in symmetric matrix } + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + H^[I]^[J] := H^[J]^[I]; + + DelVector(D, Ubound); + end; + + function WLS_ObjFunc(B : PVector) : Float; + { Objective function for weighted nonlinear regression } + var + K : Integer; + S : Float; + begin + if OutOfBounds(B, ParamMin, ParamMax) then + begin + WLS_ObjFunc := MAX_FUNC; + Exit; + end; + S := 0.0; + K := FirstPoint; + repeat + YYcalc^[K] := RegFunc1(XX^[K], B); + S := S + WW^[K] * Sqr(YY^[K] - YYcalc^[K]); + Inc(K); + until (K > NN) or (S > MAX_FUNC); + if S > MAX_FUNC then S := MAX_FUNC; + WLS_ObjFunc := S; + end; + + procedure WLS_Gradient(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; G : PVector); + { Gradient for weighted nonlinear regression. + Func is a dummy parameter here. } + var + I, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + WD : Float; { Weighted derivative } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + G^[I] := 0.0; + + { Compute Gradient } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + WD := WW^[K] * D^[I]; + G^[I] := G^[I] - WD * R; + end; + end; + + for I := Lbound to Ubound do + G^[I] := 2.0 * G^[I]; + + DelVector(D, Ubound); + end; + + procedure WLS_HessGrad(Func: TFuncNVar; B : PVector; + Lbound, Ubound : Integer; + G : PVector; H : PMatrix); + { Gradient and Hessian for weighted nonlinear regression. + Func is a dummy parameter here. } + var + I, J, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + WD : Float; { Weighted derivative } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + begin + G^[I] := 0.0; + for J := I to Ubound do + H^[I]^[J] := 0.0; + end; + + { Compute Gradient & Hessian } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + WD := WW^[K] * D^[I]; + G^[I] := G^[I] - WD * R; + for J := I to Ubound do + H^[I]^[J] := H^[I]^[J] + WD * D^[J]; + end; + end; + + { Fill in symmetric matrix } + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + H^[I]^[J] := H^[J]^[I]; + DelVector(D, Ubound); + end; + + {$F-} + + function GenNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + Mode : TRegMode; X, Y, W : PVector; + N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; + V : PMatrix) : Integer; + { -------------------------------------------------------------------- + General nonlinear regression routine + -------------------------------------------------------------------- } + var + F_min : Float; { Value of objective function at minimum } + ErrCode : Integer; { Error code } + G : PVector; { Gradient vector } + H : PMatrix; { Hessian matrix } + ObjFunc : TFuncNVar; { Objective function } + GradProc : TGradient; { Procedure to compute gradient } + HessProc : THessGrad; { Procedure to compute gradient and hessian } + begin + SetGlobalVar(RegFunc, DerivProc, Mode, X, Y, W, + N, Lbound, Ubound, B_min, B_max); + + case Mode of + UNWEIGHTED : begin + ObjFunc := {$IFDEF FPK}@{$ENDIF}OLS_ObjFunc; + GradProc := {$IFDEF FPK}@{$ENDIF}OLS_Gradient; + HessProc := {$IFDEF FPK}@{$ENDIF}OLS_HessGrad; + end; + WEIGHTED : begin + ObjFunc := {$IFDEF FPK}@{$ENDIF}WLS_ObjFunc; + GradProc := {$IFDEF FPK}@{$ENDIF}WLS_Gradient; + HessProc := {$IFDEF FPK}@{$ENDIF}WLS_HessGrad; + end; + end; + + case OptAlgo of + NL_MARQ : ErrCode := Marquardt(ObjFunc, HessProc, B, Lbound, Ubound, + MaxIter, Tol, F_min, V); + NL_SIMP : ErrCode := Simplex(ObjFunc, B, Lbound, Ubound, + MaxIter, Tol, F_min); + NL_BFGS : ErrCode := BFGS(ObjFunc, GradProc, B, Lbound, Ubound, + MaxIter, Tol, F_min, V); + NL_SA : ErrCode := SimAnn(ObjFunc, B, B_min, B_max, Lbound, Ubound, + MaxIter, Tol, F_min); + end; + + if (OptAlgo <> NL_MARQ) and (OptAlgo <> NL_BFGS) and (ErrCode = OPT_OK) then + begin + { Compute the Hessian matrix and its inverse } + DimVector(G, Ubound); + DimMatrix(H, Ubound, Ubound); + case Mode of + UNWEIGHTED : OLS_HessGrad(ObjFunc, B, Lbound, Ubound, G, H); + WEIGHTED : WLS_HessGrad(ObjFunc, B, Lbound, Ubound, G, H); + end; + if InvMat(H, Lbound, Ubound, V) = 0 then + ErrCode := OPT_OK + else + ErrCode := OPT_SING; + DelVector(G, Ubound); + DelMatrix(H, Ubound, Ubound); + end; + + GenNLFit := ErrCode; + end; + + function NLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + NLFit := GenNLFit(RegFunc, DerivProc, UNWEIGHTED, X, Y, W, N, + Lbound, Ubound, MaxIter, Tol, B, B_min, B_max, V); + end; + + function WNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y, W : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + begin + WNLFit := GenNLFit(RegFunc, DerivProc, WEIGHTED, X, Y, W, N, + Lbound, Ubound, MaxIter, Tol, B, B_min, B_max, V); + end; + + procedure GenRegTest(Mode : TRegMode; Y, Ycalc, W : PVector; + N, Lbound, Ubound : Integer; V : PMatrix; + var Test : TRegTest); + var + Ybar : Float; { Average Y value } + SSt : Float; { Total sum of squares } + SSe : Float; { Explained sum of squares } + SSr : Float; { Residual sum of squares } + Nobs : Integer; { Number of observations } + Npar : Integer; { Number of fitted parameters } + Nu1, Nu2 : Integer; { Degrees of freedom } + I, J : Integer; { Loop variables } + begin + Nobs := N - FirstPoint + 1; + Npar := Ubound - Lbound + 1; + with Test do + if Nobs > Npar then + begin + Ybar := Average(Y, FirstPoint, N); + if Mode = UNWEIGHTED then + begin + SSt := SumSqrDif(Y, FirstPoint, N, Ybar); + SSe := SumSqrDif(Ycalc, FirstPoint, N, Ybar); + SSr := SumSqrDifVect(Y, Ycalc, FirstPoint, N); + end + else + begin + SSt := SumWSqrDif(Y, W, FirstPoint, N, Ybar); + SSe := SumWSqrDif(Ycalc, W, FirstPoint, N, Ybar); + SSr := SumWSqrDifVect(Y, Ycalc, W, FirstPoint, N); + end; + Nu1 := Npar - 1; + Nu2 := Nobs - Npar; + if (SSt = 0) or (Nu2=0) then begin + //showmessage('Error: are all you data points in the same plane?'); + exit; + end; + R2 := SSe / SSt; + R2a := 1.0 - (1.0 - R2) * (Nobs - 1) / Nu2; + Vr := SSr / Nu2; + if (Vr > 0.0) and (Nu1 > 0.0) then + begin + F := (SSe / Nu1) / Vr; + Prob := PSnedecor(Nu1, Nu2, F); + end + else + begin + F := MAXNUM; + Prob := 0.0; + end; + end + else + begin + Vr := 0.0; + R2 := 1.0; + R2a := 0.0; + F := 0.0; + Prob := 1.0; + end; + + { Compute variance-covariance matrix } + for I := Lbound to Ubound do + for J := I to Ubound do + V^[I]^[J] := V^[I]^[J] * Test.Vr; + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + end; + + procedure RegTest(Y, Ycalc : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); + var + W : PVector; + begin + GenRegTest(UNWEIGHTED, Y, Ycalc, W, N, Lbound, Ubound, V, Test); + end; + + procedure WRegTest(Y, Ycalc, W : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); + begin + GenRegTest(WEIGHTED, Y, Ycalc, W, N, Lbound, Ubound, V, Test); + end; + + procedure ParamTest(B : PVector; V : PMatrix; N, Lbound, Ubound : Integer; + S, T, Prob : PVector); + var + I : Integer; + Nu : Integer; { Degrees of freedom } + Nobs : Integer; { Number of observations } + Nvar : Integer; { Number of indep. variables } + begin + Nobs := N - FirstPoint + 1; + Nvar := Ubound - Lbound + 1; + Nu := Nobs - Nvar; { DoF = Nb points - Nb parameters } + for I := Lbound to Ubound do + if V^[I]^[I] > 0.0 then + begin + S^[I] := Sqrt(V^[I]^[I]); + T^[I] := B^[I] / S^[I]; + Prob^[I] := PStudent(Nu, T^[I]); + end + else + begin + S^[I] := 0.0; + T^[I] := 0.0; + Prob^[I] := 1.0; + end; + end; + + procedure VecMean(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector); + var + I, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + X^[I]^[K]; + M^[I] := Sum / Nobs; + end; + end; + + procedure VecSD(X : PMatrix; N, Lbound, Ubound : Integer; M, S : PVector); + var + I, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + Sqr(X^[I]^[K] - M^[I]); + S^[I] := Sqrt(Sum / Nobs); + end; + end; + + procedure MatVarCov(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector; V : PMatrix); + var + I, J, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + for J := I to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + (X^[I]^[K] - M^[I]) * (X^[J]^[K] - M^[J]); + V^[I]^[J] := Sum / Nobs; + end; + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + end; + + procedure MatCorrel(V : PMatrix; Lbound, Ubound : Integer; R : PMatrix); + var + I, J : Integer; + begin + for I := Lbound to Ubound do + begin + R^[I]^[I] := 1.0; + for J := Succ(I) to Ubound do + begin + R^[I]^[J] := V^[I]^[J] / Sqrt(V^[I]^[I] * V^[J]^[J]); + R^[J]^[I] := R^[I]^[J]; + end; + end; + end; + + function PCA(R : PMatrix; Lbound, Ubound : Integer; + Lambda : PVector; C, Rc : PMatrix) : Integer; + var + I, J, ErrCode : Integer; + Rac : Float; + begin + { Compute eigenvalues and eigenvectors of correlation matrix } + ErrCode := Jacobi(R, Lbound, Ubound, PCA_MAXITER, PCA_TOL, C, Lambda); + + if ErrCode <> 0 then + begin + PCA := ErrCode; + Exit; + end; + + { Compute correlations between principal factors and reduced variables } + for I := Lbound to Ubound do + begin + Rac := Sqrt(Lambda^[I]); + for J := Lbound to Ubound do + Rc^[I]^[J] := C^[I]^[J] * Rac; + end; + + PCA := ErrCode; + end; + + procedure ScaleVar(X : PMatrix; N, Lbound, Ubound : Integer; + M, S : PVector; Z : PMatrix); + var + I, K : Integer; + begin + for I := Lbound to Ubound do + for K := FirstPoint to N do + Z^[I]^[K] := (X^[I]^[K] - M^[I]) / S^[I]; + end; + + procedure PrinFac(Z : PMatrix; N, Lbound, Ubound : Integer; + C, F : PMatrix); + var + I, J, K : Integer; + begin + for I := Lbound to Ubound do + for K := FirstPoint to N do + begin + F^[I]^[K] := 0.0; + for J := Lbound to Ubound do + F^[I]^[K] := F^[I]^[K] + C^[I]^[J] * Z^[J]^[K]; + end; + end; + +end. diff --git a/npm/dmath/_clean.bat b/npm/dmath/_clean.bat new file mode 100755 index 0000000..f4eb821 --- /dev/null +++ b/npm/dmath/_clean.bat @@ -0,0 +1,10 @@ +del /S *.~* +del /S *.dcu +del /S *.dsk +del /S *.cfg +del /S *.dof +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt diff --git a/npm/dmath/eigen.pas b/npm/dmath/eigen.pas new file mode 100755 index 0000000..0de4df1 --- /dev/null +++ b/npm/dmath/eigen.pas @@ -0,0 +1,715 @@ +{ ********************************************************************** + * Unit EIGEN.PAS * + * Version 1.8 * + * (c) J. Debord, May 2001 * + ********************************************************************** + Procedures for computing eigenvalues and eigenvectors + ********************************************************************** + References: + 1) Borland's Numerical Methods Toolbox : Jacobi + 2) 'Numerical Recipes' by Press et al. : EigenVals, RootPol + ********************************************************************** } + +unit Eigen; + +interface + +uses + FMath, Matrices; + +function Jacobi(A : PMatrix; Lbound, Ubound, MaxIter : Integer; + Tol : Float; V : PMatrix; Lambda : PVector) : Integer; +{ ---------------------------------------------------------------------- + Eigenvalues and eigenvectors of a symmetric matrix by the iterative + method of Jacobi + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : V = matrix of eigenvectors (stored by lines) + Lambda = eigenvalues in decreasing order + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : 1. The eigenvectors are normalized, with their first component > 0 + 2. This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function EigenVals(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Eigenvalues of a general square matrix + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameters : Lambda_Re = real part of eigenvalues + Lambda_Im = imaginary part of eigenvalues + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function EigenVect(A : PMatrix; Lbound, Ubound : Integer; + Lambda, Tol : Float; V : PVector) : Integer; +{ ---------------------------------------------------------------------- + Computes the eigenvector associated to a real eigenvalue + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + Lambda = eigenvalue + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : V = eigenvector + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : 1. The eigenvector is normalized, with its first component > 0 + 2. The function returns only one eigenvector, even if the + eigenvalue has a multiplicity greater than 1. + ---------------------------------------------------------------------- } + +procedure DivLargest(V : PVector; Lbound, Ubound : Integer; + var Largest : Float); +{ ---------------------------------------------------------------------- + Normalizes an eigenvector V by dividing by the element with the + largest absolute value + ---------------------------------------------------------------------- } + +function RootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Real and complex roots of a real polynomial by the method of the + companion matrix + ---------------------------------------------------------------------- + Input parameters : Coef = coefficients of polynomial + Deg = degree of polynomial + ---------------------------------------------------------------------- + Output parameters : X_Re = real parts of root (in increasing order) + X_Im = imaginary parts of root + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + + function Jacobi(A : PMatrix; Lbound, Ubound, MaxIter : Integer; + Tol : Float; V : PMatrix; Lambda : PVector) : Integer; + var + SinTheta, CosTheta, TanTheta, Tan2Theta : Float; + CosSqr, SinSqr, SinCos, SumSqrDiag : Float; + AII, AJJ, AIJ, AIK, AJK, VIK, VJK, D : Float; + I, J, K, Iter : Integer; + Done : Boolean; + begin + Iter := 0; + for I := Lbound to Ubound do + for J := Lbound to Ubound do + if I = J then + V^[I]^[J] := 1.0 + else + V^[I]^[J] := 0.0; + + repeat + Iter := Succ(Iter); + SumSqrDiag := 0.0; + for I := Lbound to Ubound do + SumSqrDiag := SumSqrDiag + Sqr(A^[I]^[I]); + Done := True; + + for I := Lbound to Pred(Ubound) do + for J := Succ(I) to Ubound do + if Abs(A^[I]^[J]) > Tol * SumSqrDiag then + begin + Done := False; + + { Calculate rotation } + D := A^[I]^[I] - A^[J]^[J]; + if Abs(D) > MACHEP then + begin + Tan2Theta := D / (2.0 * A^[I]^[J]); + TanTheta := - Tan2Theta + Sgn(Tan2Theta) * + Sqrt(1.0 + Sqr(Tan2Theta)); + CosTheta := 1.0 / Sqrt(1.0 + Sqr(TanTheta)); + SinTheta := CosTheta * TanTheta; + end + else + begin + CosTheta := SQRT2DIV2; { Sqrt(2)/2 } + SinTheta := Sgn(A^[I]^[J]) * SQRT2DIV2; + end; + + { Rotate matrix } + CosSqr := Sqr(CosTheta); + SinSqr := Sqr(SinTheta); + SinCos := SinTheta * CosTheta; + AII := A^[I]^[I] * CosSqr + 2.0 * A^[I]^[J] * SinCos + + A^[J]^[J] * SinSqr; + AJJ := A^[I]^[I] * SinSqr - 2.0 * A^[I]^[J] * SinCos + + A^[J]^[J] * CosSqr; + AIJ := (A^[J]^[J] - A^[I]^[I]) * SinCos + + A^[I]^[J] * (CosSqr - SinSqr); + for K := Lbound to Ubound do + if not(K in [I, J]) then + begin + AIK := A^[I]^[K] * CosTheta + A^[J]^[K] * SinTheta; + AJK := - A^[I]^[K] * SinTheta + A^[J]^[K] * CosTheta; + A^[I]^[K] := AIK; + A^[K]^[I] := AIK; + A^[J]^[K] := AJK; + A^[K]^[J] := AJK; + end; + A^[I]^[I] := AII; + A^[J]^[J] := AJJ; + A^[I]^[J] := AIJ; + A^[J]^[I] := AIJ; + + { Rotate eigenvectors } + for K := Lbound to Ubound do + begin + VIK := CosTheta * V^[I]^[K] + SinTheta * V^[J]^[K]; + VJK := - SinTheta * V^[I]^[K] + CosTheta * V^[J]^[K]; + V^[I]^[K] := VIK; + V^[J]^[K] := VJK; + end; + end; + until Done or (Iter > MaxIter); + + { The diagonal terms of the transformed matrix are the eigenvalues } + for I := Lbound to Ubound do + Lambda^[I] := A^[I]^[I]; + + if Iter > MaxIter then + begin + Jacobi := MAT_NON_CONV; + Exit; + end; + + { Sort eigenvalues and eigenvectors } + for I := Lbound to Pred(Ubound) do + begin + K := I; + D := Lambda^[I]; + for J := Succ(I) to Ubound do + if Lambda^[J] > D then + begin + K := J; + D := Lambda^[J]; + end; + FSwap(Lambda^[I], Lambda^[K]); + SwapRows(I, K, V, Lbound, Ubound); + end; + + { Make sure that the first component of each eigenvector is > 0 } + for I := Lbound to Ubound do + if V^[I]^[Lbound] < 0.0 then + for J := Lbound to Ubound do + V^[I]^[J] := - V^[I]^[J]; + + Jacobi := MAT_OK; + end; + + procedure Balance(A : PMatrix; Lbound, Ubound : Integer); + { Balances the matrix, i.e. reduces norm without affecting eigenvalues } + const + RADIX = 2; { Base used for machine computations } + var + I, J, Last : Integer; + C, F, G, R, S, Sqrdx : Float; + begin + Sqrdx := Sqr(RADIX); + repeat + Last := 1; + for I := Lbound to Ubound do + begin + C := 0.0; + R := 0.0; + for J := Lbound to Ubound do + if J <> I then + begin + C := C + Abs(A^[J]^[I]); + R := R + Abs(A^[I]^[J]); + end; + if (C <> 0.0) and (R <> 0.0) then + begin + G := R / RADIX; + F := 1.0; + S := C + R; + while C < G do + begin + F := F * RADIX; + C := C * Sqrdx; + end; + G := R * RADIX; + while C > G do + begin + F := F / RADIX; + C := C / Sqrdx; + end; + if (C + R) / F < 0.95 * S then + begin + Last := 0; + G := 1.0 / F; + for J := Lbound to Ubound do + A^[I]^[J] := A^[I]^[J] * G; + for J := Lbound to Ubound do + A^[J]^[I] := A^[J]^[I] * F; + end; + end; + end; + until Last <> 0; + end; + + procedure ElmHes(A : PMatrix; Lbound, Ubound : Integer); + { Reduces the matrix to upper Hessenberg form by elimination } + var + I, J, M : Integer; + X, Y : Float; + begin + for M := Succ(Lbound) to Pred(Ubound) do + begin + X := 0.0; + I := M; + for J := M to Ubound do + if Abs(A^[J]^[M - 1]) > Abs(X) then + begin + X := A^[J]^[M - 1]; + I := J; + end; + if I <> M then + begin + for J := Pred(M) to Ubound do + FSwap(A^[I]^[J], A^[M]^[J]); + for J := Lbound to Ubound do + FSwap(A^[J]^[I], A^[J]^[M]); + end; + if X <> 0.0 then + for I := Succ(M) to Ubound do + begin + Y := A^[I]^[M - 1]; + if Y <> 0.0 then + begin + Y := Y / X; + A^[I]^[M - 1] := Y; + for J := M to Ubound do + A^[I]^[J] := A^[I]^[J] - Y * A^[M]^[J]; + for J := Lbound to Ubound do + A^[J]^[M] := A^[J]^[M] + Y * A^[J]^[I]; + end; + end; + end; + for I := (Lbound + 2) to Ubound do + for J := Lbound to (I - 2) do + A^[I]^[J] := 0.0; + end; + + function Hqr(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; + { Finds the eigenvalues of an upper Hessenberg matrix } + label 2, 3, 4; + var + I, Its, J, K, L, M, N : Integer; + Anorm, P, Q, R, S, T, U, V, W, X, Y, Z : Float; + + function Sign(A, B : Float) : Float; + begin + if B < 0.0 then Sign := - Abs(A) else Sign := Abs(A) + end; + + begin + Anorm := Abs(A^[1]^[1]); + for I := Succ(Lbound) to Ubound do + for J := I - 1 to Ubound do + Anorm := Anorm + Abs(A^[I]^[J]); + N := Ubound; + T := 0.0; + while N >= Lbound do + begin + Its := 0; +2: for L := N downto Succ(Lbound) do + begin + S := Abs(A^[L - 1]^[L - 1]) + Abs(A^[L]^[L]); + if S = 0.0 then S := Anorm; + if Abs(A^[L]^[L - 1]) <= MACHEP * S then goto 3 + end; + L := Lbound; +3: X := A^[N]^[N]; + if L = N then + begin + Lambda_Re^[N] := X + T; + Lambda_Im^[N] := 0.0; + N := N - 1 + end + else + begin + Y := A^[N - 1]^[N - 1]; + W := A^[N]^[N - 1] * A^[N - 1]^[N]; + if L = N - 1 then + begin + P := 0.5 * (Y - X); + Q := Sqr(P) + W; + Z := Sqrt(Abs(Q)); + X := X + T; + if Q >= 0.0 then + begin + Z := P + Sign(Z, P); + Lambda_Re^[N] := X + Z; + Lambda_Re^[N - 1] := Lambda_Re^[N]; + if Z <> 0.0 then Lambda_Re^[N] := X - W / Z; + Lambda_Im^[N] := 0.0; + Lambda_Im^[N - 1] := 0.0 + end + else + begin + Lambda_Re^[N] := X + P; + Lambda_Re^[N - 1] := Lambda_Re^[N]; + Lambda_Im^[N] := Z; + Lambda_Im^[N - 1] := - Z + end; + N := N - 2 + end + else + begin + if Its = 30 then + begin + Hqr := MAT_NON_CONV; + Exit; + end; + if (Its = 10) or (Its = 20) then + begin + T := T + X; + for I := Lbound to N do + A^[I]^[I] := A^[I]^[I] - X; + S := Abs(A^[N]^[N - 1]) + Abs(A^[N - 1]^[N - 2]); + X := 0.75 * S; + Y := X; + W := - 0.4375 * Sqr(S) + end; + Its := Its + 1; + for M := N - 2 downto L do + begin + Z := A^[M]^[M]; + R := X - Z; + S := Y - Z; + P := (R * S - W) / A^[M + 1]^[M] + A^[M]^[M + 1]; + Q := A^[M + 1]^[M + 1] - Z - R - S; + R := A^[M + 2]^[M + 1]; + S := Abs(P) + Abs(Q) + Abs(R); + P := P / S; + Q := Q / S; + R := R / S; + if M = L then goto 4; + U := Abs(A^[M]^[M - 1]) * (Abs(Q) + Abs(R)); + V := Abs(P) * (Abs(A^[M - 1]^[M - 1]) + Abs(Z) + + Abs(A^[M + 1]^[M + 1])); + if U <= MACHEP * V then goto 4 + end; +4: for I := M + 2 to N do + begin + A^[I]^[I - 2] := 0.0; + if I <> (M + 2) then A^[I]^[I - 3] := 0.0 + end; + for K := M to N - 1 do + begin + if K <> M then + begin + P := A^[K]^[K - 1]; + Q := A^[K + 1]^[K - 1]; + R := 0.0; + if K <> (N - 1) then + R := A^[K + 2]^[K - 1]; + X := Abs(P) + Abs(Q) + Abs(R); + if X <> 0.0 then + begin + P := P / X; + Q := Q / X; + R := R / X + end + end; + S := Sign(Sqrt(Sqr(P) + Sqr(Q) + Sqr(R)), P); + if S <> 0.0 then + begin + if K = M then + begin + if L <> M then + A^[K]^[K - 1] := - A^[K]^[K - 1]; + end + else + begin + A^[K]^[K - 1] := - S * X + end; + P := P + S; + X := P / S; + Y := Q / S; + Z := R / S; + Q := Q / P; + R := R / P; + for J := K to N do + begin + P := A^[K]^[J] + Q * A^[K + 1]^[J]; + if K <> (N - 1) then + begin + P := P + R * A^[K + 2]^[J]; + A^[K + 2]^[J] := A^[K + 2]^[J] - P * Z + end; + A^[K + 1]^[J] := A^[K + 1]^[J] - P * Y; + A^[K]^[J] := A^[K]^[J] - P * X + end; + for I := L to IMin(N, K + 3) do + begin + P := X * A^[I]^[K] + Y * A^[I]^[K + 1]; + if K <> (N - 1) then + begin + P := P + Z * A^[I]^[K + 2]; + A^[I]^[K + 2] := A^[I]^[K + 2] - P * R + end; + A^[I]^[K + 1] := A^[I]^[K + 1] - P * Q; + A^[I]^[K] := A^[I]^[K] - P + end + end + end; + goto 2 + end + end + end; + Hqr := MAT_OK; + end; + + function EigenVals(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; + begin + Balance(A, Lbound, Ubound); + ElmHes(A, Lbound, Ubound); + EigenVals := Hqr(A, Lbound, Ubound, Lambda_Re, Lambda_Im); + end; + + procedure DivLargest(V : PVector; Lbound, Ubound : Integer; + var Largest : Float); + var + I : Integer; + begin + Largest := V^[Lbound]; + for I := Succ(Lbound) to Ubound do + if Abs(V^[I]) > Abs(Largest) then + Largest := V^[I]; + for I := Lbound to Ubound do + V^[I] := V^[I] / Largest; + end; + + function EigenVect(A : PMatrix; Lbound, Ubound : Integer; + Lambda, Tol : Float; V : PVector) : Integer; + + procedure SetMatrix(A, A1 : PMatrix; Lbound, Ubound : Integer; Lambda : Float); + { Form A1 = A - Lambda * I } + var + I : Integer; + begin + CopyMatrix(A1, A, Lbound, Lbound, Ubound, Ubound); + for I := Lbound to Ubound do + A1^[I]^[I] := A^[I]^[I] - Lambda; + end; + + function Solve(A : PMatrix; Lbound, Ubound, N : Integer; + Tol : Float; V : PVector) : Integer; + { Solve the system A*X = 0 after fixing the N-th unknown to 1 } + var + A1, W : PMatrix; + B, S, X : PVector; + ErrCode, I, I1, J, J1, Ubound1 : Integer; + begin + Ubound1 := Pred(Ubound); + + DimMatrix(A1, Ubound1, Ubound1); + DimMatrix(W, Ubound1, Ubound1); + DimVector(B, Ubound1); + DimVector(S, Ubound1); + DimVector(X, Ubound1); + + I1 := Pred(Lbound); + for I := Lbound to Ubound do + if I <> N then + begin + Inc(I1); + J1 := 0; + for J := Lbound to Ubound do + if J <> N then + begin + Inc(J1); + A1^[I1]^[J1] := A^[I]^[J]; + end + else + B^[I1] := - A^[I]^[J]; + end; + + ErrCode := SV_Decomp(A1, Lbound, Ubound1, Ubound1, S, W); + + if ErrCode = 0 then + begin + SV_SetZero(S, Lbound, Ubound1, Tol); + SV_Solve(A1, S, W, B, Lbound, Ubound1, Ubound1, X); + + { Update eigenvector } + I1 := 0; + for I := Lbound to Ubound do + if I = N then + V^[I] := 1.0 + else + begin + Inc(I1); + V^[I] := X^[I1]; + end; + end; + + DelMatrix(A1, Ubound1, Ubound1); + DelMatrix(W, Ubound1, Ubound1); + DelVector(B, Ubound1); + DelVector(S, Ubound1); + DelVector(X, Ubound1); + + Solve := ErrCode; + end; + + function ZeroVector(B : PVector; Lbound, Ubound : Integer; Tol : Float) : Boolean; + { Check if vector B is zero } + var + I : Integer; + Z : Boolean; + begin + Z := True; + for I := Lbound to Ubound do + Z := Z and (Abs(B^[I]) < Tol); + ZeroVector := Z; + end; + + function CheckEigenVector(A1 : PMatrix; V : PVector; + Lbound, Ubound : Integer; Tol : Float) : Boolean; + { Check if the equation A1 * V = 0 holds } + var + I, K : Integer; + B : PVector; + begin + DimVector(B, Ubound); + + { Form B = A1 * V } + for I := Lbound to Ubound do + for K := Lbound to Ubound do + B^[I] := B^[I] + A1^[I]^[K] * V^[K]; + + { Check if B is zero } + CheckEigenVector := ZeroVector(B, Lbound, Ubound, Tol); + + DelVector(B, Ubound); + end; + + procedure Normalize(V : PVector; Lbound, Ubound : Integer); + { Normalize eigenvector and make sure that the first component is >= 0 } + var + Sum, Norm : Float; + I : Integer; + begin + Sum := 0.0; + for I := Lbound to Ubound do + Sum := Sum + Sqr(V^[I]); + Norm := Sqrt(Sum); + for I := Lbound to Ubound do + if V^[I] <> 0.0 then V^[I] := V^[I] / Norm; + if V^[Lbound] < 0.0 then + for I := Lbound to Ubound do + if V^[I] <> 0.0 then V^[I] := - V^[I]; + end; + + var + ErrCode, I : Integer; + A1 : PMatrix; + + begin + DimMatrix(A1, Ubound, Ubound); + + { Form A1 = A - Lambda * I } + SetMatrix(A, A1, Lbound, Ubound, Lambda); + + { Try to solve the system A1*V=0 by eliminating 1 equation } + I := Lbound; + repeat + if (Solve(A1, Lbound, Ubound, I, Tol, V) = 0) and + CheckEigenVector(A1, V, Lbound, Ubound, Tol) + then + ErrCode := 0 + else + ErrCode := - 1; + Inc(I); + until (ErrCode = 0) or (I > Ubound); + + if ErrCode = 0 then + begin + Normalize(V, Lbound, Ubound); + EigenVect := MAT_OK; + end + else + EigenVect := MAT_NON_CONV; + + DelMatrix(A1, Ubound, Ubound); + end; + + function RootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; + var + A : PMatrix; { Companion matrix } + N : Integer; { Size of matrix } + I, J, K : Integer; { Loop variables } + ErrCode : Integer; { Error code } + Temp : Float; + begin + N := Pred(Deg); + DimMatrix(A, N, N); + + { Set up the companion matrix (to save space, begin at index 0) } + for J := 0 to N do + A^[0]^[J] := - Coef^[Deg - J - 1] / Coef^[Deg]; + for J := 0 to Pred(N) do + A^[J + 1]^[J] := 1.0; + + { The roots of the polynomial are the eigenvalues of the companion matrix } + Balance(A, 0, N); + ErrCode := Hqr(A, 0, N, X_Re, X_Im); + + if ErrCode = MAT_OK then + begin + { Sort roots in increasing order of real parts } + for I := 0 to N - 1 do + begin + K := I; + Temp := X_Re^[I]; + for J := Succ(I) to N do + if X_Re^[J] < Temp then + begin + K := J; + Temp := X_Re^[J]; + end; + FSwap(X_Re^[I], X_Re^[K]); + FSwap(X_Im^[I], X_Im^[K]); + end; + + { Transfer roots from 0..(Deg - 1) to 1..Deg } + for J := N downto 0 do + begin + X_Re^[J + 1] := X_Re^[J]; + X_Im^[J + 1] := X_Im^[J]; + end; + end; + + DelMatrix(A, N, N); + RootPol := ErrCode; + end; + +end. diff --git a/npm/dmath/fcomp.pas b/npm/dmath/fcomp.pas new file mode 100755 index 0000000..fa5a1a5 --- /dev/null +++ b/npm/dmath/fcomp.pas @@ -0,0 +1,649 @@ +{ ********************************************************************** + * Unit FCOMP.PAS * + * Version 1.1 * + * (c) J. Debord, July 2000 * + ********************************************************************** + Complex functions for TPMATH + (Based on CMPLX.ZIP by E.F. Glynn) + ********************************************************************** } + +unit FComp; + +interface + +uses + FMath; + +{ ********************************************************************** + Complex type + ********************************************************************** } + +type + ComplexForm = (Rec, Pol); { Rectangular or Polar form } + + Complex = record + case Form : ComplexForm of + Rec : (X, Y : Float); + Pol : (R, Theta : Float); + end; + +const + C_infinity : Complex = (Form : Rec; X : MAXNUM; Y : 0.0); + C_zero : Complex = (Form : Rec; X : 0.0; Y : 0.0); + C_one : Complex = (Form : Rec; X : 1.0; Y : 0.0); + C_i : Complex = (Form : Rec; X : 0.0; Y : 1.0); + C_pi : Complex = (Form : Rec; X : PI; Y : 0.0); + C_pi_div_2 : Complex = (Form : Rec; X : PIDIV2; Y : 0.0); + +{ ********************************************************************** + Complex number initialization and conversion + ********************************************************************** } + +procedure CSet(var Z : Complex; A, B : Float; F : ComplexForm); +{ ---------------------------------------------------------------------- + Initializes a complex number according to the form specified by F + F = Rec ==> Z = A + i * B + F = Pol ==> Z = A * Exp(i * B) + ---------------------------------------------------------------------- } + +procedure CConvert(var Z : Complex; F : ComplexForm); +{ Converts the complex number Z to the form specified by F } + +procedure CSwap(var X, Y : Complex); +{ Exchanges two complex numbers } + +{ ********************************************************************** + Complex functions + ********************************************************************** } + +function CReal(Z : Complex) : Float; { Re(Z) } +function CImag(Z : Complex) : Float; { Im(Z) } +function CAbs(Z : Complex) : Float; { |Z| } +function CArg(Z : Complex) : Float; { Arg(Z) } +function CSgn(Z : Complex) : Integer; { Complex sign } + +procedure CNeg(A : Complex; var Z : Complex); { Z = -A } +procedure CConj(A : Complex; var Z : Complex); { Z = A* } +procedure CAdd(A, B : Complex; var Z : Complex); { Z = A + B } +procedure CSub(A, B : Complex; var Z : Complex); { Z = A - B } +procedure CDiv(A, B : Complex; var Z : Complex); { Z = A / B } +procedure CMult(A, B : Complex; var Z : Complex); { Z = A * B } +procedure CLn(A : Complex; var Z : Complex); { Z = Ln(A) } +procedure CExp(A : Complex; var Z : Complex); { Z = Exp(A) } +procedure CPower(A, B : Complex; var Z : Complex); { Z = A^B } + +procedure CIntPower(A : Complex; N : Integer; var Z : Complex); { Z = A^N } +procedure CRealPower(A : Complex; X : Float; var Z : Complex); { Z = A^X } +procedure CSqrt(A : Complex; var Z : Complex); { Z = Sqrt(A) } +procedure CRoot(A : Complex; K, N : Integer; var Z : Complex); { Z = A^(1/N) } + +procedure CSin(A : Complex; var Z : Complex); { Z = Sin(A) } +procedure CCos(A : Complex; var Z : Complex); { Z = Cos(A) } +procedure CTan(A : Complex; var Z : Complex); { Z = Tan(A) } + +procedure CArcSin(A : Complex; var Z : Complex); { Z = ArcSin(A) } +procedure CArcCos(A : Complex; var Z : Complex); { Z = ArcCos(A) } +procedure CArcTan(A : Complex; var Z : Complex); { Z = ArcTan(A) } + +procedure CSinh(A : Complex; var Z : Complex); { Z = Sinh(A) } +procedure CCosh(A : Complex; var Z : Complex); { Z = Cosh(A) } +procedure CTanh(A : Complex; var Z : Complex); { Z = Tanh(A) } + +procedure CArcSinh(A : Complex; var Z : Complex); { Z = ArcSinh(A) } +procedure CArcCosh(A : Complex; var Z : Complex); { Z = ArcCosh(A) } +procedure CArcTanh(A : Complex; var Z : Complex); { Z = ArcTanh(A) } + +procedure CLnGamma(A : Complex; var Z : Complex); { Z = Ln(Gamma(A)) } + +implementation + +{$IFDEF CPU387} + {$DEFINE USE_ASM} +{$ENDIF} + +{$IFDEF CPUP2} + {$DEFINE USE_ASM} +{$ENDIF} + + procedure CSet(var Z : Complex; A, B : Float; F : ComplexForm); + begin + Z.Form := F; + if F = Pol then + begin + Z.R := A; + Z.Theta := B; + end + else + begin + Z.X := A; + Z.Y := B; + end; + end; + + function CAbs(Z : Complex) : Float; + begin + if Z.Form = Rec then + CAbs := Pythag(Z.X, Z.Y) + else + CAbs := Z.R; + end; + + function CArg(Z : Complex) : Float; + begin + if Z.Form = Rec then + CArg := ArcTan2(Z.Y, Z.X) + else + CArg := Z.Theta; + end; + + function CReal(Z : Complex) : Float; + begin + if Z.Form = Rec then + CReal := Z.X + else + CReal := Z.R * {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(Z.Theta); + end; + + function CImag(Z : Complex) : Float; + begin + if Z.Form = Rec then + CImag := Z.Y + else + CImag := Z.R * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(Z.Theta); + end; + + function CSgn(Z : Complex) : Integer; + var + Re, Im : Float; + begin + Re := CReal(Z); + if Re > 0.0 then + CSgn := 1 + else if Re < 0.0 then + CSgn := - 1 + else + begin + Im := CImag(Z); + if Im > 0.0 then + CSgn := 1 + else if Im < 0.0 then + CSgn := - 1 + else + CSgn := 0; + end; + end; + + procedure CConvert(var Z : Complex; F : ComplexForm); + var + A : Complex; + begin + if Z.Form = F then Exit; + if Z.Form = Pol then + begin { Polar-to-rectangular conversion } + A.Form := Rec; + A.X := Z.R * {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(Z.Theta); + A.Y := Z.R * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(Z.Theta); + end + else + begin { Rectangular-to-polar conversion } + A.Form := Pol; + if Z.X = 0.0 then + if Z.Y = 0.0 then + A.R := 0.0 + else if Z.Y > 0.0 then + A.R := Z.Y + else + A.R := - Z.Y + else + A.R := CAbs(Z); + A.Theta := ArcTan2(Z.Y, Z.X); + end; + Z := A; + end; + + procedure CSwap(var X, Y : Complex); + var + Temp : Complex; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + procedure CNeg(A : Complex; var Z : Complex); + begin + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R; + Z.Theta := FixAngle(A.Theta + PI) + end + else + begin + Z.X := - A.X; + Z.Y := - A.Y + end; + end; + + procedure CConj(A : Complex; var Z : Complex); + begin + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R; + Z.Theta := FixAngle(- A.Theta) + end + else + begin + Z.X := A.X; + Z.Y := - A.Y + end + end; + + procedure CAdd(A, B : Complex; var Z : Complex); + begin + CConvert(A, Rec); + CConvert(B, Rec); + Z.Form := Rec; + Z.X := A.X + B.X; + Z.Y := A.Y + B.Y; + end; + + procedure CSub(A, B : Complex; var Z : Complex); + begin + CConvert(A, Rec); + CConvert(B, Rec); + Z.Form := Rec; + Z.X := A.X - B.X; + Z.Y := A.Y - B.Y; + end; + + procedure CMult(A, B : Complex; var Z : Complex); + begin + CConvert(B, A.Form); { arbitrarily convert one to type of other } + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R * B.R; + Z.Theta := FixAngle(A.Theta + B.Theta) + end + else + begin + Z.X := A.X * B.X - A.Y * B.Y; + Z.Y := A.X * B.Y + A.Y * B.X + end; + end; + + procedure CDiv(A, B : Complex; var Z : Complex); + var + Temp : Float; + begin + if ((B.Form = Rec) and (B.X = 0.0) and (B.Y = 0.0)) or + ((B.Form = Pol) and (B.R = 0.0)) then + begin + MathErr := FN_OVERFLOW; + Z := C_infinity; + Exit; + end; + + CConvert(B, A.Form); { arbitrarily convert one to type of other } + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R / B.R; + Z.Theta := FixAngle(A.Theta - B.Theta); + end + else + begin + Temp := Sqr(B.X) + Sqr(B.Y); + Z.X := (A.X * B.X + A.Y * B.Y) / Temp; + Z.Y := (A.Y * B.X - A.X * B.Y) / Temp; + end; + end; + + procedure CLn(A : Complex; var Z : Complex); + var + LnR : Float; + begin + CConvert(A, Pol); + LnR := Log(A.R); + if MathErr = FN_OK then + CSet(Z, LnR, FixAngle(A.Theta), Rec) + else + CSet(Z, - MAXNUM, 0.0, Rec); + end; + + procedure CExp(A : Complex; var Z : Complex); + var + ExpX, SinY, CosY : Float; + begin + CConvert(A, Rec); + ExpX := Expo(A.X); + if MathErr = FN_OK then + begin + SinY := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(A.Y); + CosY := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(A.Y); + CSet(Z, ExpX * CosY, ExpX * SinY, Rec); + end + else + CSet(Z, ExpX, 0.0, Rec); + end; + + procedure CPower(A, B : Complex; var Z : Complex); + var + BLnA, LnA : Complex; + begin + CConvert(A, Rec); + CConvert(B, Rec); + if (A.X = 0.0) and (A.Y = 0.0) then + if (B.X = 0.0) and (B.Y = 0.0) then + Z := C_one { lim a^a = 1 as a -> 0 } + else + Z := C_zero { 0^b = 0, b > 0 } + else + begin + CLn(A, LnA); + CMult(B, LnA, BLnA); + CExp(BLnA, Z); + end; + end; + + procedure CIntPower(A : Complex; N : Integer; var Z : Complex); + { CIntPower directly applies DeMoivre's theorem to calculate an integer + power of a complex number. The formula holds for both positive and + negative values of N } + begin + CConvert(A, Pol); + if A.R = 0.0 then + if N = 0 then + Z := C_one + else if N > 0 then + Z := C_zero + else + begin + MathErr := FN_SING; + Z := C_infinity; + end + else + CSet(Z, IntPower(A.R, N), FixAngle(N * A.Theta), Pol); + end; + + procedure CRealPower(A : Complex; X : Float; var Z : Complex); + begin + CConvert(A, Pol); + if A.R = 0.0 then + if X = 0.0 then + Z := C_one + else if X > 0.0 then + Z := C_zero + else + begin + MathErr := FN_SING; + Z := C_infinity; + end + else + CSet(Z, Power(A.R, X), FixAngle(X * A.Theta), Pol); + end; + + procedure CRoot(A : Complex; K, N : Integer; var Z : Complex); + { CRoot can calculate all 'N' roots of 'A' by varying 'K' from 0..N-1 } + { This is another application of DeMoivre's theorem. See CIntPower. } + begin + if (N <= 0) or (K < 0) or (K >= N) then + begin + MathErr := FN_DOMAIN; + Z := C_zero; + Exit; + end; + CConvert(A, Pol); + if A.R = 0.0 then + Z := C_zero + else + CSet(Z, Power(A.R, 1.0 / N), FixAngle((A.Theta + K * TWOPI) / N), Pol); + end; + + procedure CSqrt(A : Complex; var Z : Complex); + begin + CConvert(A, Pol); + if A.R = 0.0 then + Z := C_zero + else + CSet(Z, Sqrt(A.R), FixAngle(0.5 * A.Theta), Pol); + end; + + procedure CCos(A : Complex; var Z : Complex); + var + SinX, CosX, SinhY, CoshY : Float; + begin + CConvert(A, Rec); + SinCos(A.X, SinX, CosX); + SinhCosh(A.Y, SinhY, CoshY); { Called here to set MathErr } + CSet(Z, CosX * CoshY, - SinX * SinhY, Rec) + end; + + procedure CSin(A : Complex; var Z : Complex); + var + SinX, CosX, SinhY, CoshY : Float; + begin + CConvert(A, Rec); + SinCos(A.X, SinX, CosX); + SinhCosh(A.Y, SinhY, CoshY); { Called here to set MathErr } + CSet(Z, SinX * CoshY, CosX * SinhY, Rec) + end; + + procedure CTan(A : Complex; var Z : Complex); + var + X2, Y2, SinX2, CosX2, SinhY2, CoshY2, Temp : Float; + begin + CConvert(A, Rec); + X2 := 2.0 * A.X; + Y2 := 2.0 * A.Y; + SinCos(X2, SinX2, CosX2); + SinhCosh(Y2, SinhY2, CoshY2); + if MathErr = FN_OK then + Temp := CosX2 + CoshY2 + else + Temp := CoshY2; + if Temp <> 0.0 then + CSet(Z, SinX2 / Temp, SinhY2 / Temp, Rec) + else + begin { A = Pi/2 + k*Pi } + MathErr := FN_SING; + CSet(Z, MAXNUM, 0.0, Rec); + end; + end; + + procedure CCosh(A : Complex; var Z : Complex); + var + SinhX, CoshX, SinY, CosY : Float; + begin + CConvert(A, Rec); + SinCos(A.Y, SinY, CosY); + SinhCosh(A.X, SinhX, CoshX); + CSet(Z, CoshX * CosY, SinhX * SinY, Rec) + end; + + procedure CSinh(A : Complex; var Z : Complex); + var + SinhX, CoshX, SinY, CosY : Float; + begin + CConvert(A, Rec); + SinCos(A.Y, SinY, CosY); + SinhCosh(A.X, SinhX, CoshX); + CSet(Z, SinhX * CosY, CoshX * SinY, Rec) + end; + + procedure CTanh(A : Complex; var Z : Complex); + var + X2, Y2, SinY2, CosY2, SinhX2, CoshX2, Temp : Float; + begin + CConvert(A, Rec); + X2 := 2.0 * A.X; + Y2 := 2.0 * A.Y; + SinCos(Y2, SinY2, CosY2); + SinhCosh(X2, SinhX2, CoshX2); + if MathErr = FN_OK then + Temp := CoshX2 + CosY2 + else + Temp := CoshX2; + if Temp <> 0.0 then + CSet(Z, SinhX2 / Temp, SinY2 / Temp, Rec) + else + begin { A = i * (Pi/2 + k*Pi) } + MathErr := FN_SING; + CSet(Z, 0.0, MAXNUM, Rec); + end; + end; + + procedure CArcSin(A : Complex; var Z : Complex); + var + Rp, Rm, S, T, X2, XX, YY : Float; + B : Complex; + begin + CConvert(A, Rec); + CSet(B, A.Y, - A.X, Rec); { Y - i*X } + X2 := 2.0 * A.X; + XX := Sqr(A.X); + YY := Sqr(A.Y); + S := XX + YY + 1.0; + Rp := 0.5 * Sqrt(S + X2); + Rm := 0.5 * Sqrt(S - X2); + T := Rp + Rm; + Z.Form := Rec; + Z.X := ArcSin(Rp - Rm); + Z.Y := CSgn(B) * Log(T + Sqrt(Sqr(T) - 1.0)); + end; + + procedure CArcCos(A : Complex; var Z : Complex); + begin + CArcSin(A, Z); + CSub(C_pi_div_2, Z, Z); { Pi/2 - ArcSin(Z) } + end; + + procedure CArcTan(A : Complex; var Z : Complex); + var + XX, Yp1, Ym1 : Float; + begin + CConvert(A, Rec); + if (A.X = 0.0) and (Abs(A.Y) = 1.0) then { A = +/- i } + begin + MathErr := FN_SING; + CSet(Z, 0.0, Sgn(A.Y) * MAXNUM, Rec); + Exit; + end; + XX := Sqr(A.X); + Yp1 := A.Y + 1.0; + Ym1 := A.Y - 1.0; + Z.Form := Rec; + Z.X := 0.5 * (ArcTan2(A.X, - Ym1) - ArcTan2(- A.X, Yp1)); + Z.Y := 0.25 * Log((XX + Sqr(Yp1)) / (XX + Sqr(Ym1))); + end; + + procedure CArcSinh(A : Complex; var Z : Complex); + { ArcSinH(A) = -i*ArcSin(i*A) } + begin + CMult(C_i, A, Z); + CArcSin(Z, Z); + CMult(C_i, Z, Z); + CNeg(Z, Z); + end; + + procedure CArcCosh(A : Complex; var Z : Complex); + { ArcCosH(A) = CSgn(Y + i(1-X))*i*ArcCos(A) where A = X+iY } + var + B : Complex; + begin + CArcCos(A, Z); + CMult(C_i, Z, Z); + CSet(B, A.Y, 1.0 - A.X, Rec); { Y + i*(1-X) } + if CSgn(B) = -1 then CNeg(Z, Z); + end; + + procedure CArcTanh(A : Complex; var Z : Complex); + { ArcTanH(A) = -i*ArcTan(i*A) } + begin + CConvert(A, Rec); + if (Abs(A.X) = 1.0) and (A.Y = 0.0) then { A = +/- 1 } + begin + MathErr := FN_SING; + CSet(Z, Sgn(A.X) * MAXNUM, 0.0, Rec); + Exit; + end; + CMult(C_i, A, Z); + CArcTan(Z, Z); + CMult(C_i, Z, Z); + CNeg(Z, Z); + end; + + procedure CApproxLnGamma(Z : Complex; var Sum : Complex); + { This is the approximation used in the National Bureau of + Standards "Table of the Gamma Function for Complex Arguments," + Applied Mathematics Series 34, 1954. The NBS table was created + using this approximation over the area 9 < Re(z) < 10 and + 0 < Im(z) < 10. Other table values were computed using the + relationship: + _ _ + ln | (z+1) = ln z + ln | (z) } + + const + C : array[1..8] of Float = + (8.33333333333333E-02, - 2.77777777777778E-03, + 7.93650793650794E-04, - 5.95238095238095E-04, + 8.41750841750842E-04, - 1.91752691752692E-03, + 6.41025641025641E-03, - 2.95506535947712E-02); + var + I : Integer; + Powers : array[1..8] of Complex; + Temp1, Temp2 : Complex; + begin + CConvert(Z, Rec); + CLn(Z, Temp1); { Ln(Z) } + CSet(Temp2, Z.X - 0.5, Z.Y, Rec); { Z - 0.5 } + CMult(Temp1, Temp2, Sum); { (Z - 0.5)*Ln(Z) } + CSub(Sum, Z, Sum); { (Z - 0.5)*ln(Z) - Z } + Sum.X := Sum.X + LN2PIDIV2; + Temp1 := C_one; + CDiv(Temp1, Z, Powers[1]); { Z^(-1) } + CMult(Powers[1], Powers[1], Temp2); { Z^(-2) } + for I := 2 to 8 do + CMult(Powers[I - 1], Temp2, Powers[I]); + for I := 8 downto 1 do + begin + CSet(Temp1, C[I] * Powers[I].X, C[I] * Powers[I].Y, Rec); + CAdd(Sum, Temp1, Sum); + end + end; + + procedure CLnGamma(A : Complex; var Z : Complex); + var + LnA, Temp : Complex; + begin + CConvert(A, Rec); + if (A.X <= 0.0) and (A.Y = 0.0) then + if (Int(A.X - 1E-8) - A.X) = 0.0 then { Negative integer? } + begin + MathErr := FN_SING; + Z := C_infinity; + Exit + end; + if A.Y < 0.0 then { 3rd or 4th quadrant? } + begin + CConj(A, A); + CLnGamma(A, Z); { Try again in 1st or 2nd quadrant } + CConj(Z, Z) { Left this out! 1/3/91 } + end + else + begin + if A.X < 9.0 then { "left" of NBS table range } + begin + CLn(A, LnA); + CSet(A, A.X + 1.0, A.Y, Rec); + CLnGamma(A, Temp); + CSub(Temp, LnA, Z) + end + else + CApproxLnGamma(A, Z) { NBS table range: 9 < Re(z) < 10 } + end + end; + +end. diff --git a/npm/dmath/fitexlin.pas b/npm/dmath/fitexlin.pas new file mode 100755 index 0000000..06f798a --- /dev/null +++ b/npm/dmath/fitexlin.pas @@ -0,0 +1,129 @@ +{ ********************************************************************** + * Unit FITEXLIN.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the "exponential + linear" model: + + y = A.[1 - exp(-k.x)] + B.x + + ********************************************************************** } + +unit FitExLin; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A[1 - exp(-k.x)] + B.x'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'k'; + 2 : ParamName := 'B'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = A B^[1] = k B^[2] = B + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * (1.0 - Expo(- B^[1] * X)) + B^[2] * X; + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + E : Float; + begin + E := Expo(- B^[1] * X); { exp(-k.x) } + D^[0] := 1.0 - E; { dy/dA = 1 - exp(-k.x) } + D^[1] := B^[0] * X * E; { dy/dk = A.x.exp(-k.x) } + D^[2] := X; { dy/dB = x } + end; + + function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Computes initial estimates of the regression parameters + -------------------------------------------------------------------- + Input : N = number of points + X, Y = point coordinates + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + K : Integer; + D : Float; + begin + { B is the slope of the last (linear) part of the curve } + K := Round(0.9 * N); + if K = N then K := Pred(N); + B^[2] := (Y^[N] - Y^[K]) / (X^[N] - X^[K]); + + { A is the intercept of the linear part } + B^[0] := Y^[N] - B^[2] * X^[N]; + + { Slope of the tangent at origin = B + k.A } + K := Round(0.1 * N); + if K = 1 then K := 2; + D := (Y^[K] - Y^[1]) / (X^[K] - X^[1]); + B^[1] := (D - B^[1]) / B^[0]; + + FitModel := 0; + end; + + end. diff --git a/npm/dmath/fitexpo.pas b/npm/dmath/fitexpo.pas new file mode 100755 index 0000000..218d092 --- /dev/null +++ b/npm/dmath/fitexpo.pas @@ -0,0 +1,316 @@ +{ ********************************************************************** + * Unit FITEXPO.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits a sum of decreasing exponentials : + + y = Ymin + A1.exp(-a1.x) + A2.exp(-a2.x) + A3.exp(-a3.x) + ... + + ********************************************************************** } + +unit FitExpo; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Stat, Regress; + +const + NO_REAL_ROOT = - 2; { No real exponent } + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + N_exp : Integer = 1; { Number of exponentials } + ConsTerm : Boolean = True; { Flags the presence of a constant term Ymin } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + I : Integer; + Name, S : String; + begin + Name := 'y = '; + if ConsTerm then + Name := Name + 'Ymin + '; + Name := Name + 'A1.exp(-a1.x)'; + for I := 2 to N_exp do + begin + Str(I, S); + Name := Name + ' + A' + S + '.exp(-a' + S + '.x)'; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term Ymin, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2 * N_exp; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + if I = 0 then + ParamName := 'Ymin' + else if Odd(I) then + begin + Str(Succ(I) div 2, S); + ParamName := 'A' + S; + end + else + begin + Str(I div 2, S); + ParamName := 'a' + S; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + B^[0] = Ymin + B^[1] = A1 B^[2] = a1 + ............................... + B^[2*i-1] = Ai B^[2*i] = ai i = 1..N_exp + -------------------------------------------------------------------- } + var + I : Integer; + S : Float; + begin + if ConsTerm then + S := B^[0] + else + S := 0.0; + for I := 1 to N_exp do + S := S + B^[2 * I - 1] * Expo(- B^[2 * I] * X); + RegFunc := S; + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + I, P, Q : Integer; + E : Float; + begin + D^[0] := 1.0; { dy/dYmin = 1 } + for I := 1 to N_exp do + begin + Q := 2 * I; + P := Pred(Q); + E := Expo(- B^[Q] * X); + D^[P] := E; { dy/dAi = exp(-ai.x) } + D^[Q] := - X * B^[P] * E; { dy/dai = -x.Ai.exp(-ai.x) } + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a sum of exponentials by linear regression + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- + Ref. : R. GOMENI & C. GOMENI, Automod : A polyalgorithm for an + integrated analysis of linear pharmacokinetic models + Comput. Biol. Med., 1979, 9, 39-48 + -------------------------------------------------------------------- } + var + I, K, M : Integer; + X1, Y1 : PVector; { Modified coordinates } + U : PMatrix; { Variables for linear regression } + P : PVector; { Linear regression parameters } + C, Z : PVector; { Coefficients and roots of polynomial } + V : PMatrix; { Variance-covariance matrix } + H : Float; { Integration step } + ErrCode : Integer; { Error code } + begin + M := Pred(2 * N_exp); + DimVector(X1, N); + DimVector(Y1, N); + DimMatrix(U, M, N); + DimMatrix(V, M, M); + DimVector(P, M); + DimVector(C, N_exp); + DimVector(Z, N_exp); + CopyVector(X1, X, 1, N); + CopyVector(Y1, Y, 1, N); + + { Change scale so that the X's begin at zero } + if X^[1] <> 0.0 then + for K := 1 to N do + X1^[K] := X1^[K] - X^[1]; + + { Estimate the constant term at 90% of the lowest observed value, + then subtract it from each Y value } + if ConsTerm then + begin + B^[0] := 0.9 * Min(Y1, 1, N); + for K := 1 to N do + Y1^[K] := Y1^[K] - B^[0]; + end; + + { ------------------------------------------------------------------ + Fit the linearized form of the function : + + y = p(0) + p(1) * x + p(2) * x^2 + ... + p(N_exp-1) * x^(N_exp-1) + + (x (x (x + + p(N_exp) | y dx + ... + p(2*N_exp-1) | ....| y dx + )0 )0 )0 + ------------------------------------------------------------------ } + + { Compute increasing powers of X } + if N_exp > 1 then + for K := 2 to N do + begin + U^[1]^[K] := X1^[K]; + for I := 2 to Pred(N_exp) do + U^[I]^[K] := U^[I - 1]^[K] * X1^[K]; + end; + + { Compute integrals by the trapezoidal rule } + for K := 2 to N do + begin + H := 0.5 * (X1^[K] - X1^[K - 1]); + U^[N_exp]^[K] := U^[N_exp]^[K - 1] + (Y1^[K] + Y1^[K - 1]) * H; + for I := Succ(N_exp) to M do + U^[I]^[K] := U^[I]^[K - 1] + (U^[I - 1]^[K] + U^[I - 1]^[K - 1]) * H; + end; + + { Fit the equation } + case Method of + 0 : ErrCode := MulFit(U, Y1, N, M, True, P, V); + 1 : ErrCode := WMulFit(U, Y1, W, N, M, True, P, V); + end; + + if ErrCode = MAT_SINGUL then + FitModel := ErrCode + else + begin + { ---------------------------------------------------------------- + The exponents are the roots of the polynomial : + x^N_exp + p(N_exp) * x^(N_exp-1) - p(N_exp+1) * x^(N_exp-2) +... + ---------------------------------------------------------------- } + + { Compute polynomial coefficients } + C^[N_exp] := 1.0; + for I := 1 to N_exp do + if Odd(I) then + C^[N_exp - I] := P^[N_exp + I - 1] + else + C^[N_exp - I] := - P^[N_exp + I - 1]; + + { Solve polynomial } + if RRootPol(C, N_exp, Z) <> N_exp then + FitModel := NO_REAL_ROOT + else + begin + { Sort exponents in decreasing order } + DQSort(Z, 1, N_exp); + + { Compute the coefficients of the exponentials by + linear regression on the exponential terms } + for I := 1 to N_exp do + for K := 1 to N do + U^[I]^[K] := Expo(- Z^[I] * X1^[K]); + + case Method of + 0 : ErrCode := MulFit(U, Y1, N, N_exp, False, P, V); + 1 : ErrCode := WMulFit(U, Y1, W, N, N_exp, False, P, V); + end; + + if ErrCode = MAT_SINGUL then + FitModel := ErrCode + else + begin + { Extract model parameters } + for I := 1 to N_exp do + begin + { Correct for scale change if necessary } + if X^[1] <> 0.0 then + P^[I] := P^[I] * Expo(Z^[I] * X^[1]); + + { Extract coefficients and exponents } + B^[2 * I - 1] := P^[I]; { Coefficients } + B^[2 * I] := Z^[I]; { Exponents } + end; + FitModel := MAT_OK; + end; + end; + end; + + DelVector(X1, N); + DelVector(Y1, N); + DelMatrix(U, M, N); + DelMatrix(V, M, M); + DelVector(P, M); + DelVector(C, N_exp); + DelVector(Z, N_exp); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = number of exponentials + CstPar^[1] = 1 to include a constant term (Ymin) + -------------------------------------------------------------------- } + var + N : Integer; + begin + N := Round(CstPar^[0]); + if N > 0 then N_exp := N; + ConsTerm := (CstPar^[1] = 1); + end; + +end. diff --git a/npm/dmath/fitfrac.pas b/npm/dmath/fitfrac.pas new file mode 100755 index 0000000..156db73 --- /dev/null +++ b/npm/dmath/fitfrac.pas @@ -0,0 +1,220 @@ +{ ********************************************************************** + * Unit FITFRAC.PAS * + * Version 1.2 * + * (c) J. Debord, April 1999 * + ********************************************************************** + This unit fits a rational fraction : + + p0 + p1.x + p2.x^2 + ... + y = ------------------------ + 1 + q1.x + q2.x^2 + ... + + ********************************************************************** } + +unit FitFrac; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Deg1 : Integer = 1; { Degree of numerator } + Deg2 : Integer = 1; { Degree of denominator } + ConsTerm : Boolean = True; { Flags the presence of a constant term p0 } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = ('; + if ConsTerm then + Name := Name + 'p0 + '; + Name := Name + 'p1.x'; + for I := 2 to Deg1 do + begin + Str(I, S); + Name := Name + ' + p' + S + '.x^' + S; + end; + Name := Name + ') / (1 + q1.x'; + for I := (Deg1 + 2) to (Deg1 + Deg2) do + begin + Str(I - Deg1, S); + Name := Name + ' + q' + S + '.x^' + S; + end; + Name := Name + ')'; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term p0, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := Deg1 + Deg2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + if I <= Deg1 then + begin + Str(I, S); + ParamName := 'p' + S; + end + else + begin + Str(I - Deg1, S); + ParamName := 'q' + S; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = p0 + B^[1] = p1 B^[2] = p2 ... + + B^[Deg1 + 1] = q1 B^[Deg1 + 2] = q2 ... + -------------------------------------------------------------------- } + begin + RegFunc := RFrac(X, B, Deg1, Deg2); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + I : Integer; + Den : Float; + begin + { Compute denominator (1 + q1.x + q2.x^2 + ...) } + Den := 0.0; + for I := (Deg1 + Deg2) downto Succ(Deg1) do + Den := (Den + B^[I]) * X; + Den := 1.0 + Den; + + { dy/dp0 = 1 / (1 + q1.x + q2.x^2 + ...) } + D^[0] := 1.0 / Den; + + { dy/dpi = x^i / (1 + q1.x + q2.x^2 + ...) } + for I := 1 to Deg1 do + D^[I] := D^[I - 1] * X; + + { dy/dq1 = -x.y / (1 + q1.x + q2.x^2 + ...) } + D^[Deg1 + 1] := - X * Y / Den; + + { dy/dqi = -x^i.y / (1 + q1.x + q2.x^2 + ...) } + for I := (Deg1 + 2) to (Deg1 + Deg2) do + D^[I] := D^[I - 1] * X; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a rational fraction by linear regression: + y = p0 + p1.x + p2.x^2 + ... - q1.(x.y) - q2.(x^2.y) - ... + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + I, J : Integer; { Loop variables } + M : Integer; { Index of last fitted parameter } + U : PMatrix; { Matrix of independent variables } + V : PMatrix; { Variance-covariance matrix } + begin + M := LastParam; + DimMatrix(U, M, N); + DimMatrix(V, M, M); + + for J := 1 to N do + begin + U^[1]^[J] := X^[J]; + for I := 2 to Deg1 do + U^[I]^[J] := U^[I - 1]^[J] * X^[J]; + U^[Deg1 + 1]^[J] := - X^[J] * Y^[J]; + for I := (Deg1 + 2) to M do + U^[I]^[J] := U^[I - 1]^[J] * X^[J]; + end; + + case Method of + 0 : FitModel := MulFit(U, Y, N, M, ConsTerm, B, V); + 1 : FitModel := WMulFit(U, Y, W, N, M, ConsTerm, B, V); + end; + + if not ConsTerm then B^[0] := 0.0; + + DelMatrix(U, M, N); + DelMatrix(V, M, M); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = Degree of numerator + CstPar^[1] = Degree of denominator + CstPar^[2] = 1 to include a constant term (p0) + -------------------------------------------------------------------- } + var + D1, D2 : Integer; + begin + D1 := Round(CstPar^[0]); + D2 := Round(CstPar^[1]); + if D1 > 0 then Deg1 := D1; + if D2 > 0 then Deg2 := D2; + ConsTerm := (CstPar^[2] = 1); + end; + +end. diff --git a/npm/dmath/fithill.pas b/npm/dmath/fithill.pas new file mode 100755 index 0000000..69c1eee --- /dev/null +++ b/npm/dmath/fithill.pas @@ -0,0 +1,182 @@ +{ ********************************************************************** + * Unit FITHILL.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the Hill equation : + + Ymax . x^n + y = ---------- + K^n + x^n + + ********************************************************************** } + +unit FitHill; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = Ymax . x^n / (K^n + x^n)'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'Ymax'; + 1 : ParamName := 'K '; + 2 : ParamName := 'n '; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = Ymax B^[1] = K B^[2] = n + -------------------------------------------------------------------- } + begin + if X = 0.0 then + if B^[2] > 0.0 then RegFunc := 0.0 else RegFunc := B^[0] + else + { Compute function according to y = Ymax / [1 + (K/x)^n] } + RegFunc := B^[0] / (1.0 + Power(B^[1] / X, B^[2])); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + Q, R, S : Float; + begin + if X = 0.0 then + begin + if B^[2] > 0.0 then D^[0] := 0.0 else D^[0] := 1.0; + D^[1] := 0.0; + D^[2] := 0.0; + end + else + begin + Q := Power(B^[1] / X, B^[2]); { (K/x)^n } + R := 1.0 / (1.0 + Q); { 1 / [1 + (K/x)^n] } + S := - Y * R * Q; { -Ymax.(K/x)^n / [1 + (K/x)^n]^2 } + + { dy/dYmax = 1 / [1 + (K/x)^n] } + D^[0] := R; + + { dy/dK = -Ymax.(K/x)^n.(n/K)/[1 + (K/x)^n]^2 } + D^[1] := S * B^[2] / B^[1]; + + { dy/dn = -Ymax.(K/x)^n.Ln(K/x)/[1 + (K/x)^n]^2 } + D^[2] := S * Log(B^[1] / X); + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the Hill equation by linear regression: + Ln(Ymax/y - 1) = n.Ln(K) - n.Ln(x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + Ymax : Float; { Estimated value of Ymax } + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + Ymax := Max(Y, 1, N); + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) and (Y^[K] < Ymax) then + begin + Inc(P); + X1^[P] := Log(X^[K]); + Y1^[P] := Log(Ymax / Y^[K] - 1.0); + W1^[P] := Sqr(Y^[K] * (1.0 - Y^[K] / Ymax)); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := Ymax; + B^[1] := Expo(- A^[0] / A^[1]); + B^[2] := - A^[1]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/npm/dmath/fitiexpo.pas b/npm/dmath/fitiexpo.pas new file mode 100755 index 0000000..153de74 --- /dev/null +++ b/npm/dmath/fitiexpo.pas @@ -0,0 +1,147 @@ +{ ********************************************************************** + * Unit FITIEXPO.PAS * + * Version 1.2 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the increasing exponential : + + y = A.[1 - exp(-k.x)] + + ********************************************************************** } + +unit FitIExpo; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A[1 - exp(-k.x)]'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'k'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = A B^[1] = k + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * (1.0 - Expo(- B^[1] * X)); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + E : Float; + begin + E := Expo(- B^[1] * X); { exp(-k.x) } + D^[0] := 1.0 - E; { dy/dA = 1 - exp(-k.x) } + D^[1] := B^[0] * X * E; { dy/dk = A.x.exp(-k.x) } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the increasing exponential by linear regression: + Ln(1 - y/A) = -k.x + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + Y1 : PVector; { Transformed ordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + { Estimation of A } + B^[0] := 1.1 * Max(Y, 1, N); + + for K := 1 to N do + begin + Y1^[K] := Log(1.0 - Y^[K] / B^[0]); + W1^[K] := Sqr(Y^[K] - B^[0]); + if Method = 1 then W1^[K] := W1^[K] * W^[K]; + end; + + ErrCode := WLinFit(X, Y1, W1, N, A, V); + + if ErrCode = MAT_OK then + B^[1] := - A^[1]; + + FitModel := ErrCode; + + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/npm/dmath/fitlin.pas b/npm/dmath/fitlin.pas new file mode 100755 index 0000000..415d7ff --- /dev/null +++ b/npm/dmath/fitlin.pas @@ -0,0 +1,102 @@ +{ ********************************************************************** + * Unit FITLIN.PAS * + * Version 1.0 * + * (c) J. Debord, April 1998 * + ********************************************************************** + This unit fits a linear function : + + y = a + b.x + + ********************************************************************** } + +unit FitLin; + +{$F+} + +interface + +uses + FMath, Matrices, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = a + b.x'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'a'; + 1 : ParamName := 'b'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = a B^[1] = b + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] + B^[1] * X; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Fit the straight line + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + V = variance-covariance matrix of the parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := LinFit(X, Y, N, B, V); + 1 : FitModel := WLinFit(X, Y, W, N, B, V); + end; + end; + +end. diff --git a/npm/dmath/fitlogis.pas b/npm/dmath/fitlogis.pas new file mode 100755 index 0000000..4452f4b --- /dev/null +++ b/npm/dmath/fitlogis.pas @@ -0,0 +1,224 @@ +{ ********************************************************************** + * Unit FITLOGIS.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the logistic function : + + B - A + y = A + ----------------- + 1 + exp(-a.x + b) + + ********************************************************************** } + +unit FitLogis; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + ConsTerm : Boolean = True; { Flags the presence of a constant term A } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + begin + if ConsTerm then + FuncName := 'y = A + (B - A) / [1 + exp(-a.x + b)]' + else + FuncName := 'y = B / [1 + exp(-a.x + b)]'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term A, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 3; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'B'; + 2 : ParamName := 'a'; + 3 : ParamName := 'b'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters, such that : + B^[0] = A B^[1] = B B^[2] = a B^[3] = b + -------------------------------------------------------------------- } + begin + if ConsTerm then + RegFunc := B^[0] + (B^[1] - B^[0]) / (1.0 + Expo(- B^[2] * X + B^[3])) + else + RegFunc := B^[1] / (1.0 + Expo(- B^[2] * X + B^[3])); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + Q, R : Float; + begin + Q := Expo(- B^[2] * X + B^[3]); { exp(-ax+b) } + R := 1.0 / (1.0 + Q); { 1 / [1 + exp(-ax+b)] } + + D^[0] := 1.0 - R; { dy/dA = 1 - 1 / [1 + exp(-ax+b)] } + D^[1] := R; { dy/dB = 1 / [1 + exp(-ax+b)] } + + { dy/db = (A-B).exp(-ax+b) / [1 + exp(-ax+b)]^2 } + D^[3] := (B^[0] - B^[1]) * Q * Sqr(R); + + { dy/da = (B-A).x.exp(-ax+b) / [1 + exp(-ax+b)]^2 } + D^[2] := - D^[3] * X; + end; + + procedure SortPoints(X, Y : PVector; N : Integer); + { ---------------------------------------------------------------------- + Sort points by increasing X values + ---------------------------------------------------------------------- } + var + I, J, K : Integer; + A : Float; + begin + for I := 1 to Pred(N) do + begin + K := I; + A := X^[I]; + for J := Succ(I) to N do + if X^[J] < A then + begin + K := J; + A := X^[J]; + end; + FSwap(X^[I], X^[K]); + FSwap(Y^[I], Y^[K]); + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a logistic function by linear regression: + Ln[(B - A)/(y - A) - 1] = -ax + b + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + XX : PVector; { Transformed X coordinates } + YY : PVector; { Transformed Y coordinates } + WW : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + D : Float; { B - A } + begin + DimVector(XX, N); + DimVector(YY, N); + DimVector(WW, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + SortPoints(X, Y, N); + + if ConsTerm then + B^[0] := Y^[1] + else + B^[0] := 0.0; + B^[1] := Y^[N]; + + P := 0; + D := B^[1] - B^[0]; + for K := 1 to N do + if (X^[K] > X^[1]) and (X^[K] < X^[N]) then + begin + Inc(P); + XX^[P] := X^[K]; + YY^[P] := Log(D / (Y^[K] - B^[0]) - 1.0); + WW^[P] := Sqr((Y^[K] - B^[0]) * (Y^[K] - B^[1]) / D); + if Method = 1 then WW^[P] := WW^[P] * W^[K]; + end; + + ErrCode := WLinFit(XX, YY, WW, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[2] := - A^[1]; + B^[3] := A^[0]; + end; + + FitModel := ErrCode; + + DelVector(XX, N); + DelVector(YY, N); + DelVector(WW, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit. + -------------------------------------------------------------------- + CstPar^[0] = 1 to include a constant term (A) + -------------------------------------------------------------------- } + begin + ConsTerm := (CstPar^[0] = 1); + end; + + end. diff --git a/npm/dmath/fitmich.pas b/npm/dmath/fitmich.pas new file mode 100755 index 0000000..1f80644 --- /dev/null +++ b/npm/dmath/fitmich.pas @@ -0,0 +1,152 @@ +{ ********************************************************************** + * Unit FITMICH.PAS * + * Version 1.0 * + * (c) J. Debord, April 1998 * + ********************************************************************** + This unit fits the Michaelis equation : + + Ymax . x + y = -------- + Km + x + + ********************************************************************** } + +unit FitMich; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = Ymax . x / (Km + x)'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'Ymax'; + 1 : ParamName := 'Km '; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = Ymax B^[1] = Km + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * X / (B^[1] + X); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + begin + D^[0] := Y / B^[0]; { dy/dYmax = x / (Km + x) } + D^[1] := - Y / (B^[1] + X); { dy/dKm = - Ymax.x / (Km + x)^2 } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the Michaelis equation by linear regression: + 1/y = 1/Ymax + (Km/Ymax) * (1/x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) then + begin + Inc(P); + X1^[P] := 1.0 / X^[K]; + Y1^[P] := 1.0 / Y^[K]; + W1^[P] := Sqr(Sqr(Y^[K])); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := 1.0 / A^[0]; + B^[1] := A^[1] / A^[0]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/npm/dmath/fitmult.pas b/npm/dmath/fitmult.pas new file mode 100755 index 0000000..4ac787b --- /dev/null +++ b/npm/dmath/fitmult.pas @@ -0,0 +1,140 @@ +{ ********************************************************************** + * Unit FITMULT.PAS * + * Version 1.1 * + * (c) J. Debord, October 1998 * + ********************************************************************** + This unit fits the multiple linear equation: + + y = b0 + b1.x1 + b2.x2 + ... + + ********************************************************************** } + +unit FitMult; + +{$F+} + +interface + +uses + FMath, Matrices, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X, B : PVector) : Float; + +function FitModel(Method : Integer; X : PMatrix; Y, W : PVector; + N : Integer; B : PVector; V : PMatrix) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Nvar : Integer = 2; { Number of independent variables } + ConsTerm : Boolean = True; { Flags the presence of a constant term b0 } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = '; + if ConsTerm then + Name := Name + 'b0 + '; + Name := Name + 'b1.x1'; + for I := 2 to Nvar do + begin + Str(I, S); + Name := Name + ' + b' + S + '.x' + S; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := Nvar; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + Str(I, S); + ParamName := 'b' + S; + end; + + function RegFunc(X, B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at observation X + B is the vector of parameters. + -------------------------------------------------------------------- } + var + I : Integer; + Y : Float; + begin + if ConsTerm then Y := B^[0] else Y := 0.0; + for I := 1 to Nvar do + Y := Y + B^[I] * X^[I]; + RegFunc := Y; + end; + + function FitModel(Method : Integer; X : PMatrix; Y, W : PVector; + N : Integer; B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Multiple linear regression + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X = matrix of independent variables + Y = vector of dependent variable + W = vector of weights + N = number of observations + Output : B = estimated regression parameters + V = variance-covariance matrix of parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := MulFit(X, Y, N, Nvar, ConsTerm, B, V); + 1 : FitModel := WMulFit(X, Y, W, N, Nvar, ConsTerm, B, V); + end; + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = number of independent variables + CstPar^[1] = 1 to include a constant term (b0) + -------------------------------------------------------------------- } + begin + Nvar := Round(CstPar^[0]); + ConsTerm := (CstPar^[1] = 1); + end; + +end. diff --git a/npm/dmath/fitpka.pas b/npm/dmath/fitpka.pas new file mode 100755 index 0000000..2781082 --- /dev/null +++ b/npm/dmath/fitpka.pas @@ -0,0 +1,163 @@ +{ ********************************************************************** + * Unit FITPKA.PAS * + * Version 1.1 * + * (c) J. Debord, July 1999 * + ********************************************************************** + This unit fits the acid/base titration function : + + B - A + y = A + ---------------- + 1 + 10^(pKa - x) + + where x is pH + y is some property (e.g. absorbance) which depends on the + ratio of the acidic and basic forms of the compound + A is the property for the pure acidic form + B is the property for the pure basic form + pKa is the acidity constant + ********************************************************************** } + +unit FitPKa; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A + (B - A) / [1 + 10^(pKa - x)]' + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term A, 1 otherwise) + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'B'; + 2 : ParamName := 'pKa'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + B^[0] = A B^[1] = B B^[2] = pKa + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] + (B^[1] - B^[0]) / (1.0 + Exp10(B^[2] - X)); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + Q, R : Float; + begin + Q := Exp10(B^[2] - X); { 10^(pKa - x) } + R := 1.0 / (1.0 + Q); { 1/[1 + 10^(pKa - x)] } + + D^[0] := 1.0 - R; { dy/dA = 1 - 1/[1 + 10^(pKa - x)] } + D^[1] := R; { dy/dB = 1/[1 + 10^(pKa - x)] } + + { dy/dpKa = (A-B).10^(pKa - x).Ln(10) / [1 + 10^(pKa - x)]^2 } + D^[2] := (B^[0] - B^[1]) * Q * LN10 * Sqr(R); + end; + + procedure SortPoints(X, Y : PVector; N : Integer); + { ---------------------------------------------------------------------- + Sort points by increasing X values + ---------------------------------------------------------------------- } + var + I, J, K : Integer; + A : Float; + begin + for I := 1 to Pred(N) do + begin + K := I; + A := X^[I]; + for J := Succ(I) to N do + if X^[J] < A then + begin + K := J; + A := X^[J]; + end; + FSwap(X^[I], X^[K]); + FSwap(Y^[I], Y^[K]); + end; + end; + + function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the acid/base titration function + -------------------------------------------------------------------- + Input : X, Y = point coordinates + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + K : Integer; { Loop variable } + Z : Float; { (A + B) / 2 } + begin + SortPoints(X, Y, N); + + B^[0] := Y^[1]; + B^[1] := Y^[N]; + + Z := 0.5 * (B^[0] + B^[1]); + for K := 2 to N - 1 do + if Y^[K] = Z then + B^[2] := X^[K] + else if ((Y^[K] < Z) and (Y^[K + 1] > Z)) or + ((Y^[K] > Z) and (Y^[K + 1] < Z)) then + B^[2] := 0.5 * (X^[K] + X^[K + 1]); + + FitModel := 0; + end; + +end. diff --git a/npm/dmath/fitpoly.pas b/npm/dmath/fitpoly.pas new file mode 100755 index 0000000..d88903d --- /dev/null +++ b/npm/dmath/fitpoly.pas @@ -0,0 +1,127 @@ +{ ********************************************************************** + * Unit FITPOLY.PAS * + * Version 1.2 * + * (c) J. Debord, March 1999 * + ********************************************************************** + This unit fits a polynomial : + + y = b0 + b1.x + b2.x^2 + ... + + ********************************************************************** } + +unit FitPoly; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Deg : Integer = 2; { Degree of polynomial } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = b0 + b1.x'; + for I := 2 to Deg do + begin + Str(I, S); + Name := Name + ' + b' + S + '.x^' + S; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted. + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted. + -------------------------------------------------------------------- } + begin + LastParam := Deg; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + var + S : String; + begin + Str(I, S); + ParamName := 'b' + S; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters (coefficients of polynomial). + -------------------------------------------------------------------- } + begin + RegFunc := Poly(X, B, Deg); + end; + + function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Fit of polynomial. + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + V = variance-covariance matrix of parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := PolFit(X, Y, N, Deg, B, V); + 1 : FitModel := WPolFit(X, Y, W, N, Deg, B, V); + end; + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit. + -------------------------------------------------------------------- + CstPar^[0] = Degree of polynomial + -------------------------------------------------------------------- } + var + D : Integer; + begin + D := Round(CstPar^[0]); + if D > 1 then Deg := D; + end; + +end. diff --git a/npm/dmath/fitpower.pas b/npm/dmath/fitpower.pas new file mode 100755 index 0000000..c4f5ca4 --- /dev/null +++ b/npm/dmath/fitpower.pas @@ -0,0 +1,150 @@ +{ ********************************************************************** + * Unit FITPOWER.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits a power function : + + y = A.x^n + + ********************************************************************** } + +unit FitPower; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + begin + FuncName := 'y = A.x^n'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted. + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted. + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'n'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters, such that : + + B^[0] = A B^[1] = n + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * Power(X, B^[1]); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + begin + D^[0] := Y / B^[0]; { dy/dA = x^n } + D^[1] := Y * Log(X); { dy/dk = A.x^n.Ln(x) } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a power function by linear regression: + Ln(y) = Ln(A) + n.Ln(x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) then + begin + Inc(P); + X1^[P] := Log(X^[K]); + Y1^[P] := Log(Y^[K]); + W1^[P] := Sqr(Y^[K]); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := Expo(A^[0]); + B^[1] := A^[1]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/npm/dmath/fmath.pas b/npm/dmath/fmath.pas new file mode 100755 index 0000000..9e33f72 --- /dev/null +++ b/npm/dmath/fmath.pas @@ -0,0 +1,2222 @@ +{ ********************************************************************** + * Unit FMATH.PAS * + * Version 2.4 * + * (c) J. Debord, June 2001 * + ********************************************************************** + This unit implements some mathematical functions in Pascal + ********************************************************************** + Notes: + + 1) The default real type is DOUBLE (8-byte real). Depending on the + compiler, other types may be selected by defining the symbols: + + ------------------------------------------------------- + Symbol Type TP-BP-Delphi FPC GPC + ------------------------------------------------------- + SINGLEREAL Single X X X + PASCALREAL Real X + EXTENDEDREAL Extended X X X + ------------------------------------------------------- + Note: "Real" is equivalent to "Double" in FPC and GPC + + 2) Error handling: The function MathError returns the error code from + the last function evaluation. It must be checked immediately after + a function call: + + Y := f(X); (* f is one of the functions of the library *) + if MathError = FN_OK then ... + + The possible error codes, and the default values attributed to the + function, are the following: + + ------------------------------------------------------------------ + Error code Value Significance Function default value + ------------------------------------------------------------------ + FN_OK 0 No error + FN_DOMAIN -1 Argument domain error 0 + FN_SING -2 Function singularity +/- MAXNUM + FN_OVERFLOW -3 Overflow range error MAXNUM + FN_UNDERFLOW -4 Underflow range error 0 + ------------------------------------------------------------------ + + where MAXNUM is a constant defining the highest number which may be + represented within the chosen floating point type. + + The standard functions Exp and Ln have been redefined according to + the above conventions as Expo and Log. + + 3) Assembler functions: some functions are written in assembler. There + are two versions: + + * One for BP 7 or Delphi 1 with a 387, 486 or Pentium processor. + This version may be selected by defining the symbol CPU387 + + * The other for FPC with a Pentium II or Pentium III processor. + This version may be selected by defining the symbol CPUP2 + Units and programs must be compiled with the options -Si + and -Rintel (e.g. ppc386 -Si -Rintel -dCPUP2 fmath) + + Once you have selected a version you have two possibilities: + + * Call the Pascal functions (e.g. Expo, ArcSin...). This will + provide some acceleration while keeping the error handling. + + * Call the assembler functions directly (e.g. fExp, fArcSin...) + This will provide further acceleration but without error handling. + Thus it is the responsibility of the calling program to check the + arguments passed to the function. See the interface files + MATH387.INT and MATHP2.INT for a list of available functions. + + ********************************************************************** } + +unit FMath; + +interface + +{ ---------------------------------------------------------------------- + Floating point type (Default = Double) + ---------------------------------------------------------------------- } + +{$IFDEF __GPC__} + {$UNDEF PASCALREAL} +{$ENDIF} + +{$IFDEF FPK} + {$UNDEF PASCALREAL} +{$ENDIF} + +{$IFDEF PASCALREAL} + {$IFDEF VER120} + type Float = Real48; { Delphi 4 } + {$ELSE} + type Float = Real; + {$ENDIF} +{$ELSE} +{$IFDEF SINGLEREAL} + type Float = Single; +{$ELSE} +{$IFDEF EXTENDEDREAL} + type Float = Extended; +{$ELSE} + {$DEFINE DOUBLEREAL} + type Float = Double; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Mathematical constants + ---------------------------------------------------------------------- } + +const + PI = 3.14159265358979323846; { Pi } + LN2 = 0.69314718055994530942; { Ln(2) } + LN10 = 2.30258509299404568402; { Ln(10) } + LNPI = 1.14472988584940017414; { Ln(Pi) } + INVLN2 = 1.44269504088896340736; { 1/Ln(2) } + INVLN10 = 0.43429448190325182765; { 1/Ln(10) } + TWOPI = 6.28318530717958647693; { 2*Pi } + PIDIV2 = 1.57079632679489661923; { Pi/2 } + SQRTPI = 1.77245385090551602730; { Sqrt(Pi) } + SQRT2PI = 2.50662827463100050242; { Sqrt(2*Pi) } + INVSQRT2PI = 0.39894228040143267794; { 1/Sqrt(2*Pi) } + LNSQRT2PI = 0.91893853320467274178; { Ln(Sqrt(2*Pi)) } + LN2PIDIV2 = 0.91893853320467274178; { Ln(2*Pi)/2 } + SQRT2 = 1.41421356237309504880; { Sqrt(2) } + SQRT2DIV2 = 0.70710678118654752440; { Sqrt(2)/2 } + GOLD = 1.61803398874989484821; { Golden Mean = (1 + Sqrt(5))/2 } + CGOLD = 0.38196601125010515179; { 2 - GOLD } + +{ ---------------------------------------------------------------------- + Machine-dependent constants + ---------------------------------------------------------------------- } + +{$IFDEF SINGLEREAL} +const + MACHEP = 1.192093E-7; { Floating point precision: 2^(-23) } + MAXNUM = 3.402823E+38; { Max. floating point number: 2^128 } + MINNUM = 1.175495E-38; { Min. floating point number: 2^(-126) } + MAXLOG = 88.72283; { Max. argument for Exp = Ln(MAXNUM) } + MINLOG = -87.33655; { Min. argument for Exp = Ln(MINNUM) } + MAXFAC = 33; { Max. argument for Factorial } + MAXGAM = 34.648; { Max. argument for Gamma } + MAXLGM = 1.0383E+36; { Max. argument for LnGamma } +{$ELSE} +{$IFDEF DOUBLEREAL} +const + MACHEP = 2.220446049250313E-16; { 2^(-52) } + MAXNUM = 1.797693134862315E+308; { 2^1024 } + MINNUM = 2.225073858507202E-308; { 2^(-1022) } + MAXLOG = 709.7827128933840; + MINLOG = -708.3964185322641; + MAXFAC = 170; + MAXGAM = 171.624376956302; + MAXLGM = 2.556348E+305; +{$ELSE} +{$IFDEF EXTENDEDREAL} +const + MACHEP = 1.08420217248550444E-19; { 2^(-63) } + MAXNUM = 1.18973149535723103E+4932; { 2^16384 } + MINNUM = 3.36210314311209558E-4932; { 2^(-16382) } + MAXLOG = 11356.5234062941439; + MINLOG = - 11355.137111933024; + MAXFAC = 1754; + MAXGAM = 1755.455; + MAXLGM = 1.04848146839019521E+4928; +{$ELSE} +{$IFDEF PASCALREAL} +const + MACHEP = 1.818989404E-12; { 2^(-39) } + MAXNUM = 4.253529586E+37; { 2^126 } + MINNUM = 2.350988703E-38; { 2^(-125) } + MAXLOG = 8.664339757E+01; + MINLOG = - 4.253529586E+01; + MAXFAC = 33; + MAXGAM = 34.64809785; + MAXLGM = 1.038324114E+36; +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Error codes for mathematical functions + ---------------------------------------------------------------------- } + +const + FN_OK = 0; { No error } + FN_DOMAIN = - 1; { Argument domain error } + FN_SING = - 2; { Function singularity } + FN_OVERFLOW = - 3; { Overflow range error } + FN_UNDERFLOW = - 4; { Underflow range error } + FN_TLOSS = - 5; { Total loss of precision } + FN_PLOSS = - 6; { Partial loss of precision } + +{ ---------------------------------------------------------------------- + Global variables and constants + ---------------------------------------------------------------------- } + +const + NFACT = 33; { The factorials of the first NFACT integers are stored + in a table } +var + MathErr : Integer; { Error code from the latest function evaluation } + + FactArray : array[0..NFACT] of Float; { Table of factorials } + +{ ---------------------------------------------------------------------- + Functional type + ---------------------------------------------------------------------- } + +type + TFunc = function(X : Float) : Float; + +{ ---------------------------------------------------------------------- + Error handling function + ---------------------------------------------------------------------- } + +function MathError : Integer; { Error code from the last function call } + +{ ---------------------------------------------------------------------- + Minimum, maximum, sign and exchange + ---------------------------------------------------------------------- } + +function FMin(X, Y : Float) : Float; { Minimum of 2 reals } +function FMax(X, Y : Float) : Float; { Maximum of 2 reals } +function IMin(X, Y : Integer) : Integer; { Minimum of 2 integers } +function IMax(X, Y : Integer) : Integer; { Maximum of 2 integers } +function Sgn(X : Float) : Integer; { Sign (returns 1 if X = 0) } +function Sgn0(X : Float) : Integer; { Sign (returns 0 if X = 0) } + +procedure FSwap(var X, Y : Float); { Exchange 2 reals } +procedure ISwap(var X, Y : Integer); { Exchange 2 integers } + +{ ---------------------------------------------------------------------- + Assembler functions + ---------------------------------------------------------------------- } + +{$IFDEF CPU387} + {$UNDEF CPUP2} + {$I MATH387.INT} +{$ENDIF} + +{$IFDEF CPUP2} + {$UNDEF CPU387} + {$I MATHP2.INT} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Sign, logarithms, exponentials and power + ---------------------------------------------------------------------- } + +function Expo(X : Float) : Float; { Exponential } +function Exp2(X : Float) : Float; { 2^X } +function Exp10(X : Float) : Float; { 10^X } +function Log(X : Float) : Float; { Natural log } +function Log2(X : Float) : Float; { Log, base 2 } +function Log10(X : Float) : Float; { Decimal log } +function LogA(X, A : Float) : Float; { Log, base A } +function IntPower(X : Float; N : Integer) : Float; { X^N } +function Power(X, Y : Float) : Float; { X^Y, X >= 0 } +function Pythag(X, Y : Float) : Float; { Sqrt(X^2 + Y^2) } + +{ ---------------------------------------------------------------------- + Trigonometric and inverse trigonometric functions + ---------------------------------------------------------------------- } + +function FixAngle(Theta : Float) : Float; { Set Theta in -Pi..Pi } +function Tan(X : Float) : Float; { Tangent } +function ArcSin(X : Float) : Float; { Arc sinus } +function ArcCos(X : Float) : Float; { Arc cosinus } +function ArcTan2(Y, X : Float) : Float; { Angle (Ox, OM) with M(X,Y) } + +procedure SinCos(X : Float; var SinX, CosX : Float); { Sin & Cos } + +{ ---------------------------------------------------------------------- + Hyperbolic and inverse hyperbolic functions + ---------------------------------------------------------------------- } + +function Sinh(X : Float) : Float; { Hyperbolic sine } +function Cosh(X : Float) : Float; { Hyperbolic cosine } +function Tanh(X : Float) : Float; { Hyperbolic tangent } +function ArcSinh(X : Float) : Float; { Inverse hyperbolic sine } +function ArcCosh(X : Float) : Float; { Inverse hyperbolic cosine } +function ArcTanh(X : Float) : Float; { Inverse hyperbolic tangent } + +procedure SinhCosh(X : Float; var SinhX, CoshX : Float); { Sinh & Cosh } + +{ ---------------------------------------------------------------------- + Special functions + ---------------------------------------------------------------------- } + +function Fact(N : Integer) : Float; { Factorial } +function Binomial(N, K : Integer) : Float; { Binomial coef. C(N,K) } +function Gamma(X : Float) : Float; { Gamma function } +function SgnGamma(X : Float) : Integer; { Sign of Gamma function } +function LnGamma(X : Float) : Float; { Log(|Gamma(X)|) } +function IGamma(A, X : Float) : Float; { Incomplete Gamma function } +function JGamma(A, X : Float) : Float; { Complement of IGamma } +function Beta(X, Y : Float) : Float; { Beta function } +function IBeta(A, B, X : Float) : Float; { Incomplete Beta function } +function Erf(X : Float) : Float; { Error function } +function Erfc(X : Float) : Float; { Complement of Erf } + +{ ---------------------------------------------------------------------- + Binomial distribution with probability P and number of repetitions N + ---------------------------------------------------------------------- } + +function PBinom(N : Integer; P : Float; K : Integer) : Float; { Prob(X = K) } +function FBinom(N : Integer; P : Float; K : Integer) : Float; { Prob(X <= K) } + +{ ---------------------------------------------------------------------- + Poisson distribution with mean Mu + ---------------------------------------------------------------------- } + +function PPoisson(Mu : Float; K : Integer) : Float; { Prob(X = K) } +function FPoisson(Mu : Float; K : Integer) : Float; { Prob(X <= K) } + +{ ---------------------------------------------------------------------- + Standard normal distribution + ---------------------------------------------------------------------- } + +function DNorm(X : Float) : Float; { Density of standard normal } +function FNorm(X : Float) : Float; { Prob(U <= X) } +function PNorm(X : Float) : Float; { Prob(|U| >= |X|) } +function InvNorm(P : Float) : Float; { Inverse of FNorm : returns X + such that Prob(U <= X) = P} + +{ ---------------------------------------------------------------------- + Student distribution with Nu d.o.f. + ---------------------------------------------------------------------- } + +function DStudent(Nu : Integer; X : Float) : Float; { Density of t } +function FStudent(Nu : Integer; X : Float) : Float; { Prob(t <= X) } +function PStudent(Nu : Integer; X : Float) : Float; { Prob(|t| >= |X|) } + +{ ---------------------------------------------------------------------- + Khi-2 distribution with Nu d.o.f. + ---------------------------------------------------------------------- } + +function DKhi2(Nu : Integer; X : Float) : Float; { Density of Khi2 } +function FKhi2(Nu : Integer; X : Float) : Float; { Prob(Khi2 <= X) } +function PKhi2(Nu : Integer; X : Float) : Float; { Prob(Khi2 >= X) } + +{ ---------------------------------------------------------------------- + Fisher-Snedecor distribution with Nu1 and Nu2 d.o.f. + ---------------------------------------------------------------------- } + +function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Density of F } +function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Prob(F <= X) } +function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Prob(F >= X) } + +{ ---------------------------------------------------------------------- + Exponential distribution + ---------------------------------------------------------------------- } + +function DExpo(A, X : Float) : Float; { Density of exponential distrib. } +function FExpo(A, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Beta distribution + ---------------------------------------------------------------------- } + +function DBeta(A, B, X : Float) : Float; { Density of Beta distribution } +function FBeta(A, B, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Gamma distribution + ---------------------------------------------------------------------- } + +function DGamma(A, B, X : Float) : Float; { Density of Gamma distribution } +function FGamma(A, B, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Random numbers + ---------------------------------------------------------------------- } + +procedure RMarIn(Seed1, Seed2 : Integer); +{ Initializes the random number generator. + The default initialization corresponds to RMarIn(1802, 9373) } + +function IRanMar : LongInt; +{ Returns a 32 bit random number in [ -2,147,483,648 ; 2,147,483,647 ] } + +function RanMar : Float; +{ Returns a random number in [0, 1[ } + +function RanGaussStd : Float; +{ Returns a random number from the standard normal distribution + (i.e. the Gaussian distribution with zero mean and unit variance) } + +function RanGauss(Mu, Sigma : Float) : Float; +{ Returns a random number from a Gaussian distribution + with mean Mu and standard deviation Sigma } + +{ ********************************************************************** } + +implementation + +{ ---------------------------------------------------------------------- + Error handling functions + ---------------------------------------------------------------------- } + + function DefaultVal(ErrCode : Integer) : Float; + { Sets the global variable MathErr and the function default value + according to the error code } + begin + MathErr := ErrCode; + case ErrCode of + FN_DOMAIN : DefaultVal := 0.0; + FN_SING : DefaultVal := MAXNUM; + FN_OVERFLOW : DefaultVal := MAXNUM; + FN_UNDERFLOW : DefaultVal := 0.0; + else + DefaultVal := 0.0; + end; + end; + + function MathError : Integer; + begin + MathError := MathErr; + end; + +{ ---------------------------------------------------------------------- + Minimum, maximum and sign + ---------------------------------------------------------------------- } + + function FMin(X, Y : Float) : Float; + begin + if X <= Y then + FMin := X + else + FMin := Y; + end; + + function FMax(X, Y : Float) : Float; + begin + if X >= Y then + FMax := X + else + FMax := Y; + end; + + function IMin(X, Y : Integer) : Integer; + begin + if X <= Y then + IMin := X + else + IMin := Y; + end; + + function IMax(X, Y : Integer) : Integer; + begin + if X >= Y then + IMax := X + else + IMax := Y; + end; + + procedure FSwap(var X, Y : Float); + var + Temp : Float; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + procedure ISwap(var X, Y : Integer); + var + Temp : Integer; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + function Sgn(X : Float) : Integer; + begin + if X >= 0.0 then + Sgn := 1 + else + Sgn := - 1; + end; + + function Sgn0(X : Float) : Integer; + begin + if X > 0.0 then + Sgn0 := 1 + else if X = 0.0 then + Sgn0 := 0 + else + Sgn0 := - 1; + end; + +{ ---------------------------------------------------------------------- + Assembler functions + ---------------------------------------------------------------------- } + +{$IFDEF CPU387} + {$I MATH387.INC} + {$DEFINE USE_ASM} +{$ENDIF} + +{$IFDEF CPUP2} + {$I MATHP2.INC} + {$DEFINE USE_ASM} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Elementary functions + ---------------------------------------------------------------------- } + + function Expo(X : Float) : Float; + begin + MathErr := FN_OK; + if X < MINLOG then + Expo := DefaultVal(FN_UNDERFLOW) + else if X > MAXLOG then + Expo := DefaultVal(FN_OVERFLOW) + else + Expo := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + end; + + function Exp2(X : Float) : Float; + var + XLn2 : Float; + begin + MathErr := FN_OK; + XLn2 := X * LN2; + if XLn2 < MINLOG then + Exp2 := DefaultVal(FN_UNDERFLOW) + else if XLn2 > MAXLOG then + Exp2 := DefaultVal(FN_OVERFLOW) + else + Exp2 := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(XLn2); + end; + + function Exp10(X : Float) : Float; + var + XLn10 : Float; + begin + MathErr := FN_OK; + XLn10 := X * LN10; + if XLn10 < MINLOG then + Exp10 := DefaultVal(FN_UNDERFLOW) + else if XLn10 > MAXLOG then + Exp10 := DefaultVal(FN_OVERFLOW) + else + Exp10 := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(XLn10); + end; + + function Log(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log := DefaultVal(FN_SING) + else + Log := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + end; + + function Log10(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log10 := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log10 := DefaultVal(FN_SING) + else + Log10 := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * INVLN10; + end; + + function Log2(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log2 := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log2 := DefaultVal(FN_SING) + else + Log2 := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * INVLN2; + end; + + function LogA(X, A : Float) : Float; + begin + MathErr := FN_OK; + if (X < 0.0) or (A <= 0.0) or (A = 1.0) then + LogA := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + LogA := Sgn(1.0 - A) * DefaultVal(FN_SING) + else + {$IFDEF USE_ASM} + LogA := fLn(X) / fLn(A); + {$ELSE} + LogA := Ln(X) / Ln(A); + {$ENDIF} + end; + + function IntPower(X : Float; N : Integer) : Float; + { Computes X^N by repeated multiplications } + var + M : Integer; + T : Float; + begin + MathErr := FN_OK; + + if X = 0.0 then + begin + if N = 0 then { 0^0 = lim x^x = 1 } + IntPower := 1.0 { x->0 } + else if N > 0 then + IntPower := 0.0 { 0^N = 0 } + else + IntPower := DefaultVal(FN_SING); + Exit; + end; + + if N = 0 then + begin + IntPower := 1.0; + Exit; + end; + + { Legendre's algorithm for minimizing the number of multiplications } + T := 1.0; + M := Abs(N); + repeat + if Odd(M) then + begin + Dec(M); + T := T * X; + end + else + begin + M := M div 2; + X := Sqr(X); + end; + until M = 0; + + if N > 0 then IntPower := T else IntPower := 1.0 / T; + end; + + function Power(X, Y : Float) : Float; + { Computes X^Y = Exp(Y * Ln(X)), for X >= 0 } + var + YLnX : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + begin + Power := DefaultVal(FN_DOMAIN); + Exit; + end; + + if X = 0.0 then + begin + if Y = 0.0 then { 0^0 = lim x^x = 1 } + Power := 1.0 { x->0 } + else if Y > 0.0 then + Power := 0.0 { 0^Y = 0 } + else + Power := DefaultVal(FN_SING); + Exit; + end; + + if Y = 0.0 then + begin + Power := 1.0; + Exit; + end; + + YLnX := Y * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + + if YLnX < MINLOG then + Power := DefaultVal(FN_UNDERFLOW) + else if YLnX > MAXLOG then + Power := DefaultVal(FN_OVERFLOW) + else + Power := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(YLnX); + end; + + function Pythag(X, Y : Float) : Float; + { Computes Sqrt(X^2 + Y^2) without destructive underflow or overflow } + var + AbsX, AbsY : Float; + begin + MathErr := FN_OK; + AbsX := Abs(X); + AbsY := Abs(Y); + if AbsX > AbsY then + Pythag := AbsX * Sqrt(1.0 + Sqr(AbsY / AbsX)) + else if AbsY = 0.0 then + Pythag := 0.0 + else + Pythag := AbsY * Sqrt(1.0 + Sqr(AbsX / AbsY)); + end; + + procedure SinCos(X : Float; var SinX, CosX : Float); + begin + MathErr := FN_OK; + SinX := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(X); + CosX := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(X); + end; + + function FixAngle(Theta : Float) : Float; + begin + MathErr := FN_OK; + while Theta > PI do + Theta := Theta - TWOPI; + while Theta <= - PI do + Theta := Theta + TWOPI; + FixAngle := Theta; + end; + + function Tan(X : Float) : Float; + var + SinX, CosX : Float; + begin + MathErr := FN_OK; + SinX := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(X); + CosX := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(X); + if CosX = 0.0 then + Tan := Sgn(SinX) * DefaultVal(FN_SING) + else + Tan := SinX / CosX; + end; + + function ArcSin(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcSin := DefaultVal(FN_DOMAIN) + else if X = 1.0 then + ArcSin := PIDIV2 + else if X = - 1.0 then + ArcSin := - PIDIV2 + else + ArcSin := {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcCos(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcCos := DefaultVal(FN_DOMAIN) + else if X = 1.0 then + ArcCos := 0.0 + else if X = - 1.0 then + ArcCos := PI + else + ArcCos := PIDIV2 - {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcTan2(Y, X : Float) : Float; + var + Theta : Float; + begin + MathErr := FN_OK; + if X = 0.0 then + if Y = 0.0 then + ArcTan2 := 0.0 + else if Y > 0.0 then + ArcTan2 := PIDIV2 + else + ArcTan2 := - PIDIV2 + else + begin + { 4th/1st quadrant -PI/2..PI/2 } + Theta := {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(Y / X); + + { 2nd/3rd quadrants } + if X < 0.0 then + if Y >= 0.0 then + Theta := Theta + PI { 2nd quadrant: PI/2..PI } + else + Theta := Theta - PI; { 3rd quadrant: -PI..-PI/2 } + ArcTan2 := Theta; + end; + end; + +{ ---------------------------------------------------------------------- + Hyperbolic functions + ---------------------------------------------------------------------- } + + function Sinh(X : Float) : Float; + var + ExpX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + Sinh := Sgn(X) * DefaultVal(FN_OVERFLOW) + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + Sinh := 0.5 * (ExpX - 1.0 / ExpX); + end; + end; + + function Cosh(X : Float) : Float; + var + ExpX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + Cosh := DefaultVal(FN_OVERFLOW) + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + Cosh := 0.5 * (ExpX + 1.0 / ExpX); + end; + end; + + procedure SinhCosh(X : Float; var SinhX, CoshX : Float); + var + ExpX, ExpMinusX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + begin + CoshX := DefaultVal(FN_OVERFLOW); + SinhX := Sgn(X) * CoshX; + end + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + ExpMinusX := 1.0 / ExpX; + SinhX := 0.5 * (ExpX - ExpMinusX); + CoshX := 0.5 * (ExpX + ExpMinusX); + end; + end; + + function Tanh(X : Float) : Float; + var + SinhX, CoshX : Float; + begin + SinhCosh(X, SinhX, CoshX); + Tanh := SinhX / CoshX; + end; + + function ArcSinh(X : Float) : Float; + begin + MathErr := FN_OK; + ArcSinh := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X + Sqrt(Sqr(X) + 1.0)); + end; + + function ArcCosh(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 1.0 then + ArcCosh := DefaultVal(FN_DOMAIN) + else + ArcCosh := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X + Sqrt(Sqr(X) - 1.0)); + end; + + function ArcTanh(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcTanh := DefaultVal(FN_DOMAIN) + else if (X = - 1.0) or (X = 1.0) then + ArcTanh := Sgn(X) * DefaultVal(FN_SING) + else + ArcTanh := 0.5 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}((1.0 + X) / (1.0 - X)); + end; + +{ ---------------------------------------------------------------------- + Special functions (translated from Cephes math library by S. Moshier: + http://www.netlib.org/cephes) + ---------------------------------------------------------------------- } + +const { Used by IGamma and IBeta } + BIG = 9.223372036854775808E18; + BIGINV = 1.084202172485504434007E-19; + +type + TabCoef = array[0..9] of Float; + + function PolEvl(var X : Float; var Coef : TabCoef; N : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates polynomial of degree N: + + 2 N + y = C + C x + C x +...+ C x + 0 1 2 N + + Coefficients are stored in reverse order: + + Coef[0] = C , ..., Coef[N] = C + N 0 + + The function P1Evl() assumes that Coef[N] = 1.0 and is + omitted from the array. Its calling arguments are + otherwise the same as PolEvl(). + ---------------------------------------------------------------------- } + var + Ans : Float; + I : Integer; + begin + Ans := Coef[0]; + for I := 1 to N do + Ans := Ans * X + Coef[I]; + PolEvl := Ans; + end; + + function P1Evl(var X : Float; var Coef : TabCoef; N : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluate polynomial when coefficient of X is 1.0. + Otherwise same as PolEvl. + ---------------------------------------------------------------------- } + var + Ans : Float; + I : Integer; + begin + Ans := X + Coef[0]; + for I := 1 to N - 1 do + Ans := Ans * X + Coef[I]; + P1Evl := Ans; + end; + + function SgnGamma(X : Float) : Integer; + begin + if X > 0.0 then + SgnGamma := 1 + else if Odd(Trunc(Abs(X))) then + SgnGamma := 1 + else + SgnGamma := - 1; + end; + + function Stirf(X : Float) : Float; + { Stirling's formula for the gamma function + Gamma(x) = Sqrt(2*Pi) x^(x-.5) exp(-x) (1 + 1/x P(1/x)) + where P(x) is a polynomial } + const + STIR : TabCoef = ( + 7.147391378143610789273E-4, + - 2.363848809501759061727E-5, + - 5.950237554056330156018E-4, + 6.989332260623193171870E-5, + 7.840334842744753003862E-4, + - 2.294719747873185405699E-4, + - 2.681327161876304418288E-3, + 3.472222222230075327854E-3, + 8.333333333333331800504E-2, + 0); + + var + W, P : Float; + begin + W := 1.0 / X; + if X > 1024.0 then + begin + P := 6.97281375836585777429E-5 * W + 7.84039221720066627474E-4; + P := P * W - 2.29472093621399176955E-4; + P := P * W - 2.68132716049382716049E-3; + P := P * W + 3.47222222222222222222E-3; + P := P * W + 8.33333333333333333333E-2; + end + else + P := PolEvl(W, STIR, 8); + {$IFDEF USE_ASM} + Stirf := SQRT2PI * fExp((X - 0.5) * fLn(X) - X) * (1.0 + W * P); + {$ELSE} + Stirf := SQRT2PI * Exp((X - 0.5) * Ln(X) - X) * (1.0 + W * P); + {$ENDIF} + end; + + function GamSmall(X1, Z : Float) : Float; + { Gamma function for small values of the argument } + const + S : TabCoef = ( + - 1.193945051381510095614E-3, + 7.220599478036909672331E-3, + - 9.622023360406271645744E-3, + - 4.219773360705915470089E-2, + 1.665386113720805206758E-1, + - 4.200263503403344054473E-2, + - 6.558780715202540684668E-1, + 5.772156649015328608253E-1, + 1.000000000000000000000E0, + 0); + + SN : TabCoef = ( + 1.133374167243894382010E-3, + 7.220837261893170325704E-3, + 9.621911155035976733706E-3, + - 4.219773343731191721664E-2, + - 1.665386113944413519335E-1, + - 4.200263503402112910504E-2, + 6.558780715202536547116E-1, + 5.772156649015328608727E-1, + - 1.000000000000000000000E0, + 0); + + var + P : Float; + begin + if X1 = 0.0 then + begin + GamSmall := DefaultVal(FN_SING); + Exit; + end; + if X1 < 0.0 then + begin + X1 := - X1; + P := PolEvl(X1, SN, 8); + end + else + P := PolEvl(X1, S, 8); + GamSmall := Z / (X1 * P); + end; + + function StirfL(X : Float) : Float; + { Approximate Ln(Gamma) by Stirling's formula, for X >= 13 } + const + P : TabCoef = ( + 4.885026142432270781165E-3, + - 1.880801938119376907179E-3, + 8.412723297322498080632E-4, + - 5.952345851765688514613E-4, + 7.936507795855070755671E-4, + - 2.777777777750349603440E-3, + 8.333333333333331447505E-2, + 0, 0, 0); + + var + Q, W : Float; + begin + Q := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * (X - 0.5) - X; + Q := Q + LNSQRT2PI; + if X > 1.0E+10 then + StirfL := Q + else + begin + W := 1.0 / Sqr(X); + StirfL := Q + PolEvl(W, P, 6) / X; + end; + end; + + function Gamma(X : Float) : Float; + const + P : TabCoef = ( + 4.212760487471622013093E-5, + 4.542931960608009155600E-4, + 4.092666828394035500949E-3, + 2.385363243461108252554E-2, + 1.113062816019361559013E-1, + 3.629515436640239168939E-1, + 8.378004301573126728826E-1, + 1.000000000000000000009E0, + 0, 0); + + Q : TabCoef = ( + - 1.397148517476170440917E-5, + 2.346584059160635244282E-4, + - 1.237799246653152231188E-3, + - 7.955933682494738320586E-4, + 2.773706565840072979165E-2, + - 4.633887671244534213831E-2, + - 2.243510905670329164562E-1, + 4.150160950588455434583E-1, + 9.999999999999999999908E-1, + 0); + + var + SgnGam, N : Integer; + A, X1, Z : Float; + begin + MathErr := FN_OK; + SgnGam := SgnGamma(X); + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + Gamma := SgnGam * DefaultVal(FN_SING); + Exit; + end; + + if X > MAXGAM then + begin + Gamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + + A := Abs(X); + if A > 13.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := A - N; + end; + Z := Abs(A * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(PI * Z)) * Stirf(A); + if Z <= PI / MAXNUM then + begin + Gamma := SgnGam * DefaultVal(FN_OVERFLOW); + Exit; + end; + Z := PI / Z; + end + else + Z := Stirf(X); + Gamma := SgnGam * Z; + end + else + begin + Z := 1.0; + X1 := X; + while X1 >= 3.0 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < - 0.03125 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if X1 <= 0.03125 then + Gamma := GamSmall(X1, Z) + else + begin + while X1 < 2.0 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if (X1 = 2.0) or (X1 = 3.0) then + Gamma := Z + else + begin + X1 := X1 - 2.0; + Gamma := Z * PolEvl(X1, P, 7) / PolEvl(X1, Q, 8); + end; + end; + end; + end; + + function LnGamma(X : Float) : Float; + const + P : TabCoef = ( + - 2.163690827643812857640E3, + - 8.723871522843511459790E4, + - 1.104326814691464261197E6, + - 6.111225012005214299996E6, + - 1.625568062543700591014E7, + - 2.003937418103815175475E7, + - 8.875666783650703802159E6, + 0, 0, 0); + + Q : TabCoef = ( + - 5.139481484435370143617E2, + - 3.403570840534304670537E4, + - 6.227441164066219501697E5, + - 4.814940379411882186630E6, + - 1.785433287045078156959E7, + - 3.138646407656182662088E7, + - 2.099336717757895876142E7, + 0, 0, 0); + + var + N : Integer; + A, X1, Z : Float; + begin + MathErr := FN_OK; + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + LnGamma := DefaultVal(FN_SING); + Exit; + end; + + if X > MAXLGM then + begin + LnGamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + + A := Abs(X); + if A > 34.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := N - A; + end; + Z := A * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(PI * Z); + if Z = 0.0 then + begin + LnGamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + Z := LNPI - {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z) - StirfL(A); + end + else + Z := StirfL(X); + LnGamma := Z; + end + else if X < 13.0 then + begin + Z := 1.0; + X1 := X; + while X1 >= 3 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < 2.0 do + begin + if Abs(X1) <= 0.03125 then + begin + LnGamma := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Abs(GamSmall(X1, Z))); + Exit; + end; + Z := Z / X1; + X1 := X1 + 1.0; + end; + if Z < 0.0 then Z := - Z; + if X1 = 2.0 then + LnGamma := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z) + else + begin + X1 := X1 - 2.0; + LnGamma := X1 * PolEvl(X1, P, 6) / P1Evl(X1, Q, 7) + + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z); + end; + end + else + LnGamma := StirfL(X); + end; + + function IGamma(A, X : Float) : Float; + var + Ans, Ax, C, R : Float; + begin + MathErr := FN_OK; + + if (X <= 0.0) or (A <= 0.0) then + begin + IGamma := 0.0; + Exit; + end; + + if (X > 1.0) and (X > A) then + begin + IGamma := 1.0 - JGamma(A, X); + Exit; + end; + + Ax := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - X - LnGamma(A); + if Ax < MINLOG then + begin + IGamma := DefaultVal(FN_UNDERFLOW); + Exit; + end; + + Ax := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Ax); + + { power series } + R := A; + C := 1.0; + Ans := 1.0; + + repeat + R := R + 1.0; + C := C * X / R; + Ans := Ans + C; + until C / Ans <= MACHEP; + + IGamma := Ans * Ax / A; + end; + + function JGamma(A, X : Float) : Float; + var + Ans, C, Yc, Ax, Y, Z, R, T, + Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2 : Float; + begin + MathErr := FN_OK; + + if (X <= 0.0) or (A <= 0.0) then + begin + JGamma := 1.0; + Exit; + end; + + if (X < 1.0) or (X < A) then + begin + JGamma := 1.0 - IGamma(A, X); + Exit; + end; + + Ax := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - X - LnGamma(A); + + if Ax < MINLOG then + begin + JGamma := DefaultVal(FN_UNDERFLOW); + Exit; + end; + + Ax := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Ax); + + { continued fraction } + Y := 1.0 - A; + Z := X + Y + 1.0; + C := 0.0; + Pkm2 := 1.0; + Qkm2 := X; + Pkm1 := X + 1.0; + Qkm1 := Z * X; + Ans := Pkm1 / Qkm1; + + repeat + C := C + 1.0; + Y := Y + 1.0; + Z := Z + 2.0; + Yc := Y * C; + Pk := Pkm1 * Z - Pkm2 * Yc; + Qk := Qkm1 * Z - Qkm2 * Yc; + if Qk <> 0.0 then + begin + R := Pk / Qk; + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + if Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 / BIG; + Pkm1 := Pkm1 / BIG; + Qkm2 := Qkm2 / BIG; + Qkm1 := Qkm1 / BIG; + end; + until T <= MACHEP; + + JGamma := Ans * Ax; + end; + + function Fact(N : Integer) : Float; + begin + MathErr := FN_OK; + if N < 0 then + Fact := DefaultVal(FN_DOMAIN) + else if N > MAXFAC then + Fact := DefaultVal(FN_OVERFLOW) + else if N <= NFACT then + Fact := FactArray[N] + else + Fact := Gamma(N + 1); + end; + + function Binomial(N, K : Integer) : Float; + var + I, N1 : Integer; + Prod : Float; + begin + MathErr := FN_OK; + if K < 0 then + Binomial := 0.0 + else if (K = 0) or (K = N) then + Binomial := 1.0 + else if (K = 1) or (K = N - 1) then + Binomial := N + else + begin + if K > N - K then K := N - K; + N1 := Succ(N); + Prod := N; + for I := 2 to K do + Prod := Prod * (Int(N1 - I) / Int(I)); + Binomial := Int(0.5 + Prod); + end; + end; + + function Beta(X, Y : Float) : Float; + { Computes Beta(X, Y) = Gamma(X) * Gamma(Y) / Gamma(X + Y) } + var + Lx, Ly, Lxy : Float; + SgnBeta : Integer; + begin + MathErr := FN_OK; + SgnBeta := SgnGamma(X) * SgnGamma(Y) * SgnGamma(X + Y); + Lxy := LnGamma(X + Y); + if MathErr <> FN_OK then + begin + Beta := 0.0; + Exit; + end; + Lx := LnGamma(X); + if MathErr <> FN_OK then + begin + Beta := SgnBeta * MAXNUM; + Exit; + end; + Ly := LnGamma(Y); + if MathErr <> FN_OK then + begin + Beta := SgnBeta * MAXNUM; + Exit; + end; + Beta := SgnBeta * {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Lx + Ly - Lxy); + end; + + function PSeries(A, B, X : Float) : Float; + { Power series for incomplete beta integral. Use when B*X is small } + var + S, T, U, V, T1, Z, Ai : Float; + N : Integer; + begin + Ai := 1.0 / A; + U := (1.0 - B) * X; + V := U / (A + 1.0); + T1 := V; + T := U; + N := 2; + S := 0.0; + Z := MACHEP * Ai; + while Abs(V) > Z do + begin + U := (N - B) * X / N; + T := T * U; + V := T / (A + N); + S := S + V; + N := N + 1; + end; + S := S + T1; + S := S + Ai; + + U := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + if (A + B < MAXGAM) and (Abs(U) < MAXLOG) then + begin + T := Gamma(A + B) / (Gamma(A) * Gamma(B)); + S := S * T * Power(X, A); + end + else + begin + T := LnGamma(A + B) - LnGamma(A) - LnGamma(B) + + U + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(S); + if T < MINLOG then + S := 0.0 + else + S := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(T); + end; + PSeries := S; + end; + + function CFrac1(A, B, X : Float) : Float; + { Continued fraction expansion #1 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := A + B; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := B - 1.0; + K7 := K4; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MACHEP; + + repeat + Xk := - (X * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (X * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 + 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 - 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 * BIGINV; + Pkm1 := Pkm1 * BIGINV; + Qkm2 := Qkm2 * BIGINV; + Qkm1 := Qkm1 * BIGINV; + end; + + if (Abs(Qk) < BIGINV) or (Abs(Pk) < BIGINV) then + begin + Pkm2 := Pkm2 * BIG; + Pkm1 := Pkm1 * BIG; + Qkm2 := Qkm2 * BIG; + Qkm1 := Qkm1 * BIG; + end; + N := N + 1; + until N > 400; + MathErr := FN_PLOSS; + +CDone: + CFrac1 := Ans; + end; + + function CFrac2(A, B, X : Float) : Float; + { Continued fraction expansion #2 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Z, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := B - 1.0; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := A + B; + K7 := A + 1.0; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Z := X / (1.0 - X); + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MACHEP; + + repeat + Xk := - (Z * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (Z * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 - 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 + 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 * BIGINV; + Pkm1 := Pkm1 * BIGINV; + Qkm2 := Qkm2 * BIGINV; + Qkm1 := Qkm1 * BIGINV; + end; + + if (Abs(Qk) < BIGINV) or (Abs(Pk) < BIGINV) then + begin + Pkm2 := Pkm2 * BIG; + Pkm1 := Pkm1 * BIG; + Qkm2 := Qkm2 * BIG; + Qkm1 := Qkm1 * BIG; + end; + N := N + 1; + until N > 400; + MathErr := FN_PLOSS; + +CDone: + CFrac2 := Ans; + end; + + function IBeta(A, B, X : Float) : Float; + var + A1, B1, X1, T, W, Xc, Y : Float; + Flag : Boolean; + label + Done; + begin + MathErr := FN_OK; + + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + begin + IBeta := DefaultVal(FN_DOMAIN); + Exit; + end; + + if (X = 0.0) or (X = 1.0) then + begin + IBeta := X; + Exit; + end; + + Flag := False; + if (B * X <= 1.0) and (X <= 0.95) then + begin + T := PSeries(A, B, X); + goto Done; + end; + + W := 1.0 - X; + + { Reverse a and b if x is greater than the mean. } + if X > A / (A + B) then + begin + Flag := True; + A1 := B; + B1 := A; + Xc := X; + X1 := W; + end + else + begin + A1 := A; + B1 := B; + Xc := W; + X1 := X; + end; + + if Flag and (B1 * X1 <= 1.0) and (X1 <= 0.95) then + begin + T := PSeries(A1, B1, X1); + goto Done; + end; + + { Choose expansion for optimal convergence } + Y := X1 * (A1 + B1 - 2.0) - (A1 - 1.0); + if Y < 0.0 then + W := CFrac1(A1, B1, X1) + else + W := CFrac2(A1, B1, X1) / Xc; + + { Multiply w by the factor + a b _ _ _ + x (1-x) | (a+b) / ( a | (a) | (b) ) } + + Y := A1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X1); + T := B1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Xc); + if (A1 + B1 < MAXGAM) and (Abs(Y) < MAXLOG) and (Abs(T) < MAXLOG) then + begin + T := Power(Xc, B1) ; + T := T * Power(X1, A1); + T := T / A1; + T := T * W; + T := T * Gamma(A1 + B1) / (Gamma(A1) * Gamma(B1)); + end + else + begin + { Resort to logarithms } + Y := Y + T + LnGamma(A1 + B1) - LnGamma(A1) - LnGamma(B1) + + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(W / A1); + if Y < MINLOG then + T := 0.0 + else + T := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Y); + end; + +Done: + if Flag then + if T <= MACHEP then + T := 1.0 - MACHEP + else + T := 1.0 - T; + + IBeta := T; + end; + + function Erf(X : Float) : Float; + begin + if X < 0.0 then + Erf := - IGamma(0.5, Sqr(X)) + else + Erf := IGamma(0.5, Sqr(X)); + end; + + function Erfc(X : Float) : Float; + begin + if X < 0.0 then + Erfc := 1.0 + IGamma(0.5, Sqr(X)) + else + Erfc := JGamma(0.5, Sqr(X)); + end; + +{ ---------------------------------------------------------------------- + Probability functions + ---------------------------------------------------------------------- } + + function PBinom(N : Integer; P : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + PBinom := DefaultVal(FN_DOMAIN) + else if K = 0 then + PBinom := IntPower(1.0 - P, N) + else if K = N then + PBinom := IntPower(P, N) + else + PBinom := Binomial(N, K) * IntPower(P, K) * IntPower(1.0 - P, N - K); + end; + + function FBinom(N : Integer; P : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + FBinom := DefaultVal(FN_DOMAIN) + else if K = 0 then + FBinom := IntPower(1.0 - P, N) + else if K = N then + FBinom := 1.0 + else + FBinom := 1.0 - IBeta(K + 1, N - K, P); + end; + + function PPoisson(Mu : Float; K : Integer) : Float; + var + P : Float; + I : Integer; + begin + MathErr := FN_OK; + if (Mu <= 0.0) or (K < 0) then + PPoisson := DefaultVal(FN_DOMAIN) + else if K = 0 then + PPoisson := Expo(- Mu) + else + begin + P := Mu; + for I := 2 to K do + P := P * Mu / I; + PPoisson := Expo(- Mu) * P; + end; + end; + + function FPoisson(Mu : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (Mu <= 0.0) or (K < 0) then + FPoisson := DefaultVal(FN_DOMAIN) + else if K = 0 then + FPoisson := Expo(- Mu) + else + FPoisson := JGamma(K + 1, Mu); + end; + + function DNorm(X : Float) : Float; + begin + DNorm := INVSQRT2PI * Expo(- 0.5 * Sqr(X)); + end; + + function FNorm(X : Float) : Float; + begin + FNorm := 0.5 * (1.0 + Erf(X * SQRT2DIV2)); + end; + + function InvNorm(P : Float) : Float; +{ ---------------------------------------------------------------------- + Inverse of Normal distribution function + + Returns the argument, X, for which the area under the Gaussian + probability density function (integrated from minus infinity to X) + is equal to P. + + Translated from Cephes library. + ---------------------------------------------------------------------- } + const + P0 : TabCoef = ( + 8.779679420055069160496E-3, + - 7.649544967784380691785E-1, + 2.971493676711545292135E0, + - 4.144980036933753828858E0, + 2.765359913000830285937E0, + - 9.570456817794268907847E-1, + 1.659219375097958322098E-1, + - 1.140013969885358273307E-2, + 0, 0); + + Q0 : TabCoef = ( + - 5.303846964603721860329E0, + 9.908875375256718220854E0, + - 9.031318655459381388888E0, + 4.496118508523213950686E0, + - 1.250016921424819972516E0, + 1.823840725000038842075E-1, + - 1.088633151006419263153E-2, + 0, 0, 0); + + P1 : TabCoef = ( + 4.302849750435552180717E0, + 4.360209451837096682600E1, + 9.454613328844768318162E1, + 9.336735653151873871756E1, + 5.305046472191852391737E1, + 1.775851836288460008093E1, + 3.640308340137013109859E0, + 3.691354900171224122390E-1, + 1.403530274998072987187E-2, + 1.377145111380960566197E-4); + + Q1 : TabCoef = ( + 2.001425109170530136741E1, + 7.079893963891488254284E1, + 8.033277265194672063478E1, + 5.034715121553662712917E1, + 1.779820137342627204153E1, + 3.845554944954699547539E0, + 3.993627390181238962857E-1, + 1.526870689522191191380E-2, + 1.498700676286675466900E-4, + 0); + + P2 : TabCoef = ( + 3.244525725312906932464E0, + 6.856256488128415760904E0, + 3.765479340423144482796E0, + 1.240893301734538935324E0, + 1.740282292791367834724E-1, + 9.082834200993107441750E-3, + 1.617870121822776093899E-4, + 7.377405643054504178605E-7, + 0, 0); + + Q2 : TabCoef = ( + 6.021509481727510630722E0, + 3.528463857156936773982E0, + 1.289185315656302878699E0, + 1.874290142615703609510E-1, + 9.867655920899636109122E-3, + 1.760452434084258930442E-4, + 8.028288500688538331773E-7, + 0, 0, 0); + + P3 : TabCoef = ( + 2.020331091302772535752E0, + 2.133020661587413053144E0, + 2.114822217898707063183E-1, + - 6.500909615246067985872E-3, + - 7.279315200737344309241E-4, + - 1.275404675610280787619E-5, + - 6.433966387613344714022E-8, + - 7.772828380948163386917E-11, + 0, 0); + + Q3 : TabCoef = ( + 2.278210997153449199574E0, + 2.345321838870438196534E-1, + - 6.916708899719964982855E-3, + - 7.908542088737858288849E-4, + - 1.387652389480217178984E-5, + - 7.001476867559193780666E-8, + - 8.458494263787680376729E-11, + 0, 0, 0); + + var + X, Y, Z, Y2, X0, X1 : Float; + Code : Integer; + begin + if (P <= 0.0) or (P >= 1.0) then + begin + InvNorm := DefaultVal(FN_DOMAIN); + Exit; + end; + + Code := 1; + Y := P; + if Y > (1.0 - 0.13533528323661269189) then { 0.135... = exp(-2) } + begin + Y := 1.0 - Y; + Code := 0; + end; + if Y > 0.13533528323661269189 then + begin + Y := Y - 0.5; + Y2 := Y * Y; + X := Y + Y * (Y2 * PolEvl(Y2, P0, 7) / P1Evl(Y2, Q0, 7)); + X := X * SQRT2PI; + InvNorm := X; + Exit; + end; + + X := Sqrt(- 2.0 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Y)); + X0 := X - {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) / X; + Z := 1.0 / X; + if X < 8.0 then + X1 := Z * PolEvl(Z, P1, 9) / P1Evl(Z, Q1, 9) + else if X < 32.0 then + X1 := Z * PolEvl(Z, P2, 7) / P1Evl(Z, Q2, 7) + else + X1 := Z * PolEvl(Z, P3, 7) / P1Evl(Z, Q3, 7); + X := X0 - X1; + if Code <> 0 then + X := - X; + InvNorm := X; + end; + + function PNorm(X : Float) : Float; + var + A : Float; + begin + A := Abs(X); + MathErr := FN_OK; + if A = 0.0 then + PNorm := 1.0 + else if A < 1.0 then + PNorm := 1.0 - Erf(A * SQRT2DIV2) + else + PNorm := Erfc(A * SQRT2DIV2); + end; + + function DStudent(Nu : Integer; X : Float) : Float; + var + L, P, Q : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + DStudent := DefaultVal(FN_DOMAIN) + else + begin + P := 0.5 * (Nu + 1); + Q := 0.5 * Nu; + L := LnGamma(P) - LnGamma(Q) + - 0.5 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Nu * PI) + - P * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 + Sqr(X) / Nu); + DStudent := Expo(L); + end; + end; + + function FStudent(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + FStudent := DefaultVal(FN_DOMAIN) + else + FStudent := 1.0 - IBeta(0.5 * Nu, 0.5, Nu / (Nu + Sqr(X))); + end; + + function PStudent(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + PStudent := DefaultVal(FN_DOMAIN) + else + PStudent := IBeta(0.5 * Nu, 0.5, Nu / (Nu + Sqr(X))); + end; + + function DKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + DKhi2 := DGamma(0.5 * Nu, 0.5, X); + end; + + function FKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu < 1) or (X <= 0.0) then + FKhi2 := DefaultVal(FN_DOMAIN) + else + FKhi2 := IGamma(0.5 * Nu, 0.5 * X); + end; + + function PKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu < 1) or (X <= 0.0) then + PKhi2 := DefaultVal(FN_DOMAIN) + else + PKhi2 := JGamma(0.5 * Nu, 0.5 * X); + end; + + function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + var + P1, P2, R, S, L : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + DSnedecor := DefaultVal(FN_DOMAIN) + else + begin + R := Int(Nu1) / Int(Nu2); + P1 := 0.5 * Nu1; + P2 := 0.5 * Nu2; + S := P1 + P2; + L := LnGamma(S) - LnGamma(P1) - LnGamma(P2) + + P1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(R); + L := L + (P1 - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) + - S * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 + R * X); + DSnedecor := Expo(L); + end; + end; + + function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + FSnedecor := DefaultVal(FN_DOMAIN) + else + FSnedecor := 1.0 - IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); + end; + + function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + PSnedecor := DefaultVal(FN_DOMAIN) + else + PSnedecor := IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); + end; + + function DExpo(A, X : Float) : Float; + begin + if (A <= 0.0) or (X < 0.0) then + DExpo := DefaultVal(FN_DOMAIN) + else + DExpo := A * Expo(- A * X); + end; + + function FExpo(A, X : Float) : Float; + begin + if (A <= 0.0) or (X < 0.0) then + FExpo := DefaultVal(FN_DOMAIN) + else + FExpo := 1.0 - Expo(- A * X); + end; + + function DBeta(A, B, X : Float) : Float; + var + L : Float; + begin + MathErr := FN_OK; + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + DBeta := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + if A < 1.0 then DBeta := DefaultVal(FN_SING) else DBeta := 0.0 + else if X = 1.0 then + if B < 1.0 then DBeta := DefaultVal(FN_SING) else DBeta := 0.0 + else + begin + L := LnGamma(A + B) - LnGamma(A) - LnGamma(B); + L := L + (A - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) + + (B - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 - X); + DBeta := Expo(L); + end; + end; + + function FBeta(A, B, X : Float) : Float; + begin + FBeta := IBeta(A, B, X); + end; + + function DGamma(A, B, X : Float) : Float; + var + L : Float; + begin + MathErr := FN_OK; + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) then + DGamma := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + if A < 1.0 then + DGamma := DefaultVal(FN_SING) + else if A = 1.0 then + DGamma := B + else + DGamma := 0.0 + else + begin + L := A * Ln(B) - LnGamma(A) + + (A - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - B * X; + DGamma := Expo(L); + end; + end; + + function FGamma(A, B, X : Float) : Float; + begin + FGamma := IGamma(A, B * X); + end; + +{ ---------------------------------------------------------------------- + Random numbers + ---------------------------------------------------------------------- } + +var + X1, X2, C1, C2 : LongInt; + + procedure RMarIn(Seed1, Seed2 : Integer); + begin + X1 := Seed1; + X2 := Seed2; + C1 := 0; + C2 := 0; + end; + + function IRanMar : LongInt; + var + Y1, Y2 : LongInt; + begin + Y1 := 18000 * X1 + C1; + X1 := Y1 and 65535; + C1 := Y1 shr 16; + Y2 := 30903 * X2 + C2; + X2 := Y2 and 65535; + C2 := Y2 shr 16; + IRanMar := (X1 shl 16) + (X2 and 65535); + end; + + function RanMar : Float; + begin + RanMar := (IRanMar + 2147483648.0) / 4294967296.0; + end; + + function RanGaussStd : Float; + { Computes 2 random numbers from the standard normal distribution, + returns one and saves the other for the next call } + const + Gauss_Save : Float = 0.0; { Saves a random number } + Gauss_Set : Boolean = False; { Flags if a number has been saved } + var + R, Theta, SinTheta, CosTheta : Float; + begin + if not Gauss_Set then + begin + R := Sqrt(- 2.0 * Log(RanMar)); + Theta := TWOPI * RanMar; + SinCos(Theta, SinTheta, CosTheta); + RanGaussStd := R * CosTheta; { Return 1st number } + Gauss_Save := R * SinTheta; { Save 2nd number } + end + else + RanGaussStd := Gauss_Save; { Return saved number } + Gauss_Set := not Gauss_Set; + end; + + function RanGauss(Mu, Sigma : Float) : Float; + { Returns a random number from the normal distribution + with mean Mu and standard deviation Sigma } + begin + RanGauss := Mu + Sigma * RanGaussStd; + end; + +{ ---------------------------------------------------------------------- + Initialization code + ---------------------------------------------------------------------- } + +var + I : Integer; + +begin + { Initialize MathErr } + MathErr := FN_OK; + + { Store the factorials of the first NFACT integers in a table } + FactArray[0] := 1.0; + FactArray[1] := 1.0; + FactArray[2] := 2.0; + for I := 3 to NFACT do + FactArray[I] := FactArray[I - 1] * I; + + { Initialize random number generator } + RMarIn(1802, 9373); +end. diff --git a/npm/dmath/fourier.pas b/npm/dmath/fourier.pas new file mode 100755 index 0000000..b395165 --- /dev/null +++ b/npm/dmath/fourier.pas @@ -0,0 +1,336 @@ +(*========================================================================== + + fourier.pas - Don Cross <dcross@intersrv.com> + + Modified by Jean Debord <JDebord@compuserve.com> for use with TP Math. + + This is a Turbo Pascal Unit for calculating the Fast Fourier Transform + (FFT) and the Inverse Fast Fourier Transform (IFFT). + Visit the following URL for the latest version of this code. + This page also has a C/C++ version, and a brief discussion of the + theory behind the FFT algorithm. + + http://www.intersrv.com/~dcross/fft.html#pascal + + Revision history [most recent first]: + +1998 November 27 [Jean Debord] + Replaced the constant MAXPOWER by a variable which is initialized + according to the value of MAX_FLT defined in MATRICES.PAS + +1997 March 1 [Jean Debord] + Modifications for use with the TP Math library: + 1. Added a USES clause for the TP Math units. + 2. Set real type to Float (defined in FMATH.PAS) + 3. Added a constant MAXPOWER to define the maximum number of points. + Modified functions IsPowerOfTwo and NumberOfBitsNeeded accordingly. + 4. Changed array types to those defined in TP Math. Modified array + allocation, deallocation and reference accordingly. + 5. Removed compiler directives, which were no longer necessary. + 6. Modified some typographical and formatting options so that the + code looks like the other TP Math units. + No modification was made to the original algorithm. + +1996 December 11 [Don Cross] + Improved documentation of the procedure CalcFrequency. + Fixed some messed up comments in procedure IFFT. + +1996 December 6 [Don Cross] + Made procedure 'fft_integer' more efficient when buffer size changes + in successive calls: the buffer is now only resized when the input + has more samples, not a differing number of samples. + Also changed the way 'fft_integer_cleanup' works so that it is + more "bullet-proof". + +1996 December 4 [Don Cross] + Adding the procedure 'CalcFrequency', which calculates the FFT + at a specific frequency index p=0..n-1, instead of the whole + FFT. This is O(n^2) instead of O(n*log(n)). + +1996 November 30 [Don Cross] + Adding a routine to allow FFT of an input array of integers. + It is called 'fft_integer'. + +1996 November 18 [Don Cross] + Added some comments. + +1996 November 17 [Don Cross] + Wrote and debugged first version. + +==========================================================================*) + +unit Fourier; + +interface + +uses + FMath, Matrices; + +(*--------------------------------------------------------------------------- + procedure FFT + + Calculates the Fast Fourier Transform of the array of complex numbers + represented by 'RealIn' and 'ImagIn' to produce the output complex + numbers in 'RealOut' and 'ImagOut'. +---------------------------------------------------------------------------*) +procedure FFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + + +(*--------------------------------------------------------------------------- + procedure IFFT + + Calculates the Inverse Fast Fourier Transform of the array of complex + numbers represented by 'RealIn' and 'ImagIn' to produce the output complex + numbers in 'RealOut' and 'ImagOut'. +---------------------------------------------------------------------------*) +procedure IFFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + + +(*--------------------------------------------------------------------------- + procedure FFT_Integer + + Same as procedure FFT, but uses Integer input arrays instead of + double. Make sure you call FFT_Integer_Cleanup after the last + time you call FFT_Integer to free up memory it allocates. +---------------------------------------------------------------------------*) +procedure FFT_Integer(NumSamples : Integer; RealIn, ImagIn : PIntVector; + RealOut, ImagOut : PVector); + + +(*-------------------------------------------------------------------------- + procedure FFT_Integer_Cleanup + + If you call the procedure 'FFT_Integer', you must call + 'FFT_Integer_Cleanup' after the last time you call 'FFT_Integer' + in order to free up dynamic memory. +--------------------------------------------------------------------------*) +procedure FFT_Integer_Cleanup; + + +(*-------------------------------------------------------------------------- + procedure CalcFrequency + + This procedure calculates the complex frequency sample at a given + index directly. Use this instead of 'FFT' when you only need one + or two frequency samples, not the whole spectrum. + + It is also useful for calculating the Discrete Fourier Transform (DFT) + of a number of data which is not an integer power of 2. For example, + you could calculate the DFT of 100 points instead of rounding up to + 128 and padding the extra 28 array slots with zeroes. +--------------------------------------------------------------------------*) +procedure CalcFrequency(NumSamples, FrequencyIndex : Integer; + RealIn, ImagIn : PVector; + var RealOut, ImagOut : Float); + +implementation + +var + MaxPower : Integer; + + function IsPowerOfTwo(X : Integer) : Boolean; + var + I, Y : Integer; + begin + Y := 2; + for I := 1 to Pred(MaxPower) do + begin + if X = Y then + begin + IsPowerOfTwo := True; + Exit; + end; + Y := Y shl 1; + end; + IsPowerOfTwo := False; + end; + + function NumberOfBitsNeeded(PowerOfTwo : Integer) : Integer; + var + I : Integer; + begin + for I := 0 to MaxPower do + begin + if (PowerOfTwo and (1 shl I)) <> 0 then + begin + NumberOfBitsNeeded := I; + Exit; + end; + end; + end; + + function ReverseBits(Index, NumBits : Integer) : Integer; + var + I, Rev : Integer; + begin + Rev := 0; + for I := 0 to NumBits - 1 do + begin + Rev := (Rev shl 1) or (Index and 1); + Index := Index shr 1; + end; + ReverseBits := Rev; + end; + + procedure FourierTransform(AngleNumerator : Float; NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + var + NumBits, I, J, K, N, BlockSize, BlockEnd : Integer; + Delta_angle, Delta_ar : Float; + Alpha, Beta : Float; + Tr, Ti, Ar, Ai : Float; + begin + if not IsPowerOfTwo(NumSamples) or (NumSamples < 2) then + begin + Write('Error in procedure Fourier: NumSamples=', NumSamples); + WriteLn(' is not a positive integer power of 2.'); + Halt; + end; + + NumBits := NumberOfBitsNeeded(NumSamples); + for I := 0 to NumSamples - 1 do + begin + J := ReverseBits(I, NumBits); + RealOut^[J] := RealIn^[I]; + ImagOut^[J] := ImagIn^[I]; + end; + + BlockEnd := 1; + BlockSize := 2; + while BlockSize <= NumSamples do + begin + Delta_angle := AngleNumerator / BlockSize; + Alpha := Sin(0.5 * Delta_angle); + Alpha := 2.0 * Alpha * Alpha; + Beta := Sin(Delta_angle); + + I := 0; + while I < NumSamples do + begin + Ar := 1.0; (* cos(0) *) + Ai := 0.0; (* sin(0) *) + + J := I; + for N := 0 to BlockEnd - 1 do + begin + K := J + BlockEnd; + Tr := Ar * RealOut^[K] - Ai * ImagOut^[K]; + Ti := Ar * ImagOut^[K] + Ai * RealOut^[K]; + RealOut^[K] := RealOut^[J] - Tr; + ImagOut^[K] := ImagOut^[J] - Ti; + RealOut^[J] := RealOut^[J] + Tr; + ImagOut^[J] := ImagOut^[J] + Ti; + Delta_ar := Alpha * Ar + Beta * Ai; + Ai := Ai - (Alpha * Ai - Beta * Ar); + Ar := Ar - Delta_ar; + Inc(J); + end; + + I := I + BlockSize; + end; + + BlockEnd := BlockSize; + BlockSize := BlockSize shl 1; + end; + end; + + procedure FFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + begin + FourierTransform(2 * PI, NumSamples, RealIn, ImagIn, RealOut, ImagOut); + end; + + procedure IFFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + var + I : Integer; + begin + FourierTransform(- 2 * PI, NumSamples, RealIn, ImagIn, RealOut, ImagOut); + + { Normalize the resulting time samples } + for I := 0 to NumSamples - 1 do + begin + RealOut^[I] := RealOut^[I] / NumSamples; + ImagOut^[I] := ImagOut^[I] / NumSamples; + end; + end; + +var + RealTemp, ImagTemp : PVector; + TempArraySize : Integer; + + procedure FFT_Integer(NumSamples : Integer; + RealIn, ImagIn : PIntVector; + RealOut, ImagOut : PVector); + var + I : Integer; + begin + if NumSamples > TempArraySize then + begin + FFT_Integer_Cleanup; { free up memory in case we already have some } + DimVector(RealTemp, NumSamples); + DimVector(ImagTemp, NumSamples); + TempArraySize := NumSamples; + end; + + for I := 0 to NumSamples - 1 do + begin + RealTemp^[I] := RealIn^[I]; + ImagTemp^[I] := ImagIn^[I]; + end; + + FourierTransform(2 * PI, NumSamples, RealTemp, ImagTemp, RealOut, ImagOut); + end; + + procedure FFT_Integer_Cleanup; + begin + if TempArraySize > 0 then + begin + if RealTemp <> nil then + DelVector(RealTemp, TempArraySize); + if ImagTemp <> nil then + DelVector(ImagTemp, TempArraySize); + TempArraySize := 0; + end; + end; + + procedure CalcFrequency(NumSamples, FrequencyIndex : Integer; + RealIn, ImagIn : PVector; + var RealOut, ImagOut : Float); + var + K : Integer; + Cos1, Cos2, Cos3, Theta, Beta : Float; + Sin1, Sin2, Sin3 : Float; + begin + RealOut := 0.0; + ImagOut := 0.0; + Theta := 2 * PI * FrequencyIndex / NumSamples; + Sin1 := Sin(- 2 * Theta); + Sin2 := Sin(- Theta); + Cos1 := Cos(- 2 * Theta); + Cos2 := Cos(- Theta); + Beta := 2 * Cos2; + for K := 0 to NumSamples - 1 do + begin + { Update trig values } + Sin3 := Beta * Sin2 - Sin1; + Sin1 := Sin2; + Sin2 := Sin3; + + Cos3 := Beta * Cos2 - Cos1; + Cos1 := Cos2; + Cos2 := Cos3; + + RealOut := RealOut + RealIn^[K] * Cos3 - ImagIn^[K] * Sin3; + ImagOut := ImagOut + ImagIn^[K] * Cos3 + RealIn^[K] * Sin3; + end; + end; + +begin { Unit initialization code } + MaxPower := Trunc(Log2(MAX_FLT)); { Max power of two } + TempArraySize := 0; { flag that buffers RealTemp, RealImag not allocated } + RealTemp := nil; + ImagTemp := nil; +end. diff --git a/npm/dmath/matcomp.pas b/npm/dmath/matcomp.pas new file mode 100755 index 0000000..3d3c33e --- /dev/null +++ b/npm/dmath/matcomp.pas @@ -0,0 +1,302 @@ +{ ********************************************************************** + * Unit MATCOMP.PAS * + * Version 1.3 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Matrices with complex elements. See MATRICES.PAS for details + concerning the dynamic allocation and use of matrices. + ********************************************************************** + References: + 1) 'Basic Programs for Scientists and Engineers' by A.R. Miller + 2) 'Numerical Recipes' by Press et al. + ********************************************************************** } + +unit MatComp; + +interface + +uses + FMath, FComp, Matrices; + +{ ********************************************************************** + This section defines the vector and matrix types. Maximal sizes are + given for a 16-bit compiler (TP/BP). Higher values may be used with + a 32-bit compiler such as FPC. + ********************************************************************** } + +const +{$IFDEF DOUBLEREAL} + MAX_COMP = 3854; { Max size of complex vector } +{$ELSE} +{$IFDEF SINGLEREAL} + MAX_COMP = 7280; +{$ELSE} +{$IFDEF PASCALREAL} + MAX_COMP = 5040; +{$ELSE} + {$DEFINE EXTENDEDREAL} + MAX_COMP = 3119; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +type + TCompVector = array[0..MAX_COMP] of Complex; + PCompVector = ^TCompVector; + + TCompMatrix = array[0..MAX_VEC] of PCompVector; + PCompMatrix = ^TCompMatrix; + +{ ********************************************************************** + Memory allocation routines + ********************************************************************** } + +procedure DimCompVector(var V : PCompVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates complex vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimCompMatrix(var A : PCompMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates complex matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Memory deallocation routines + ********************************************************************** } + +procedure DelCompVector(V : PCompVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes complex vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelCompMatrix(A : PCompMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes complex matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Complex matrix functions + ********************************************************************** } + +function C_LU_Decomp(A : PCompMatrix; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + LU decomposition + ---------------------------------------------------------------------- } + +procedure C_LU_Solve(A : PCompMatrix; B : PCompVector; + Lbound, Ubound : Integer; X : PCompVector); +{ ---------------------------------------------------------------------- + Solves a system of equations whose matrix has been transformed by + C_LU_Decomp + ---------------------------------------------------------------------- } + +implementation + +const + { Used by LU procedures } + LastDim : Integer = 1; { Dimension of the last system solved } + Index : PIntVector = nil; { Records the row permutations } + + procedure DimCompVector(var V : PCompVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_COMP) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Complex)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := C_zero; + end; + + procedure DimCompMatrix(var A : PCompMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_COMP) then + begin + A := nil; + Exit; + end; + + { Size of a row } + GetMem(A, Succ(Ubound1) * SizeOf(PCompVector)); + if A = nil then Exit; + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := C_zero; + end; + + procedure DelCompVector(V : PCompVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Complex)); + V := nil; + end; + end; + + procedure DelCompMatrix(A : PCompMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Complex); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PCompVector)); + A := nil; + end; + end; + + function C_LU_Decomp(A : PCompMatrix; Lbound, Ubound : Integer) : Integer; + const + TINY = 1.0E-20; + var + I, Imax, J, K : Integer; + C, Pvt, T : Float; + Sum, Z : Complex; + V : PVector; + begin + DimVector(V, Ubound); + { Reallocate Index } + if Index <> nil then + DelIntVector(Index, LastDim); + DimIntVector(Index, Ubound); + LastDim := Ubound; + + for I := Lbound to Ubound do + begin + Pvt := 0.0; + for J := Lbound to Ubound do + begin + C := CAbs(A^[I]^[J]); + if C > Pvt then Pvt := C; + end; + if Pvt < MACHEP then + begin + DelVector(V, Ubound); + C_LU_Decomp := MAT_SINGUL; + Exit; + end; + V^[I] := 1.0 / Pvt; + end; + for J := Lbound to Ubound do + begin + for I := Lbound to Pred(J) do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(I) do + begin + { Sum := Sum - A^[I]^[K] * A^[K]^[J]; } + CMult(A^[I]^[K], A^[K]^[J], Z); + CSub(Sum, Z, Sum); + end; + A^[I]^[J] := Sum; + end; + Pvt := 0.0; + for I := J to Ubound do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(J) do + begin + { Sum := Sum - A^[I]^[K] * A^[K]^[J]; } + CMult(A^[I]^[K], A^[K]^[J], Z); + CSub(Sum, Z, Sum); + end; + A^[I]^[J] := Sum; + T := V^[I] * CAbs(Sum); + if T > Pvt then + begin + Pvt := T; + Imax := I; + end; + end; + if J <> Imax then + begin + { SwapRows(Imax, J, A, Lbound, Ubound); } + for K := Lbound to Ubound do + CSwap(A^[Imax]^[K], A^[J]^[K]); + V^[Imax] := V^[J]; + end; + Index^[J] := Imax; + if CAbs(A^[J]^[J]) = 0.0 then + CSet(A^[J]^[J], TINY, TINY, Rec); + if J <> Ubound then + for I := Succ(J) to Ubound do + { A^[I]^[J] := A^[I]^[J] / A^[J]^[J]; } + CDiv(A^[I]^[J], A^[J]^[J], A^[I]^[J]); + end; + DelVector(V, Ubound); + C_LU_Decomp := MAT_OK; + end; + + procedure C_LU_Solve(A : PCompMatrix; B : PCompVector; + Lbound, Ubound : Integer; X : PCompVector); + var + I, Ip, J, K : Integer; + Sum, Z : Complex; + begin + K := Pred(Lbound); + { CopyVector(X, B, Lbound, Ubound); } + for I := Lbound to Ubound do + X^[I] := B^[I]; + for I := Lbound to Ubound do + begin + Ip := Index^[I]; + Sum := X^[Ip]; + X^[Ip] := X^[I]; + if K >= Lbound then + for J := K to Pred(I) do + begin + { Sum := Sum - A^[I]^[J] * X^[J] } + CMult(A^[I]^[J], X^[J], Z); + CSub(Sum, Z, Sum); + end + else if CAbs(Sum) <> 0.0 then + K := I; + X^[I] := Sum; + end; + for I := Ubound downto Lbound do + begin + Sum := X^[I]; + if I < Ubound then + for J := Succ(I) to Ubound do + begin + { Sum := Sum - A^[I]^[J] * X^[J]; } + CMult(A^[I]^[J], X^[J], Z); + CSub(Sum, Z, Sum); + end; + { X^[I] := Sum / A^[I]^[I]; } + CDiv(Sum, A^[I]^[I], X^[I]); + end; + end; + +end. diff --git a/npm/dmath/math387.inc b/npm/dmath/math387.inc new file mode 100755 index 0000000..fb4c86c --- /dev/null +++ b/npm/dmath/math387.inc @@ -0,0 +1,314 @@ +{ ********************************************************************** + * MATH387.INC * + ********************************************************************** + Mathematical functions for TPMATH + (Assembler version for 387/486/Pentium with BP7 and Delphi1) + ********************************************************************** } + + +(* Bibliotheque mathematique pour utilisation du coprocesseur flottant + JD GAYRARD Sept. 95 + + ---------------------------------------------------------------------- + Unite d'origine : MATH387.PAS, disponible dans MATHLIB2.ZIP + (http://wcarchive.cdrom.com/pub/delphi_www/) + Convertie en fichier Include par J. DEBORD, Juin 97 + avec ajout des fonctions fexp2 et flog2 + ---------------------------------------------------------------------- + + la bibliotheque est batie … partir des fonctions du coprocesseur + du type 386, elle fournit les fonctions suivantes: + fsin, fcos, ftan, farctan, farctan2, + farcsin, farccos, fmod, mod_2PI, + ften_to, fy_to_x, fexp, fexp2, fln, flog, flog2... + +Aucune verification du domaine de definition des fonctions n'est faite, +pas plus qu'un controle de la validite des operandes. Il est conseille +d'utiliser cette bibliotheque pour les types single et double exclusivement *) + +{ table opcode du 387 non comprise par turbo pascal V7 } +{ FSIN : D9 FE + FCOS : D9 FF + FSINCOS : D9 FB + FPREM1 : D9 F5 } + +(* use only with 80387, 80486 or pentium for type single, double and extended, +no check of definition domain of the function or range (FPU limitation). +The f prefix avoids function redefinition of system runtime library *) + +function fsin(x : Float): Float; assembler; +{if x < pi.2^62, then C2 is set to 0 and ST = sin(x) + else C2 is set to 1 and ST = x } +{no check range validity is performed in this function} +asm + FLD x { load x } + DB $D9, $FE { opcode for FSIN } +end; + +function fcos(x : Float): Float; assembler; +{ if x < pi.2^62, then C2 is set to 0 and ST = sin(x) + else C2 is set to 1 and ST = x } +{no range validity check is performed in this function} +asm + FLD x { load angle } + DB $D9, $FF { opcode for FCOS } +end; +(* +procedure dsincos(x : Float; var sinus, cosinus : double); assembler; +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80468 et pentium et type double } +asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + LES DI,cosinus { } + FSTP ES:QWORD PTR [DI] { sin(x) - } + LES DI,sinus { } + FSTP ES:QWORD PTR [DI] { - - } +end; + +procedure ssincos(x : Float; var sinus, cosinus : single); assembler; +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80468 et pentium et type single } +asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + LES DI,cosinus { } + FSTP ES:DWORD PTR [DI] { sin(x) - } + LES DI,sinus { } + FSTP ES:DWORD PTR [DI] { - - } +end; + +procedure fsincos(x : Float; var sinus, cosinus : Float); +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80486 et pentium } +var lcos, lsin : Float; +begin + asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + FSTP lcos { sin(x) - } + FSTP lsin { - - } + end; +cosinus := lcos; +sinus := lsin +end; +*) +function ftan(x : Float): Float; assembler; +{ if x < pi.2^62, then C2 is set to 0 and ST = 1 and ST(1) = tan(x) + else C2 is set to 1 and ST = x } +{no range validity check is performed in this function} +asm { ST(0) ST(1) } + FLD x { x - } + FPTAN { 1 tan(x) } + FSTP ST(0) { tan(x) - } +end; + +function farcsin(x : Float): Float; assembler; +(* retourne l'arcsin de x *) +{ methode : ________ + arcsin(x) = arctan( x / V 1 - x.x ) } +{no range validity check is performed in this function |x| > 1 } +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLD ST(0) { x x - } + FMUL ST(0), ST { x.x x - } + FLD1 { 1 x.x x } + FSUBRP ST(1), ST { 1 - xý x - } + FSQRT { sqrt(1-xý) x - } + FPATAN { arcsin(x) - - } +end; + +function farccos(x : Float): Float; assembler; +{ retourne arccos(x) + methode : ________ + arcsin(x) = arctan( V 1 - x.x / x ) } +{ pas de controle de domaine de definition |x| > 1 } +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLD ST(0) { x x - } + FMUL ST(0), ST { x.x x - } + FLD1 { 1 x.x x } + FSUBRP ST(1), ST { 1 - xý x - } + FSQRT { sqrt(1-xý) x - } + FXCH { x z - } + FPATAN { arccos(x) - - } +end; + +function farctan(x : Float): Float; assembler; +asm { ST(0) ST(1) } + FLD x { x - } + FLD1 { 1 x } + FPATAN { atan(x/1) - } +end; + +function farctan2(y, x : Float): Float; assembler; +{ retourne arctan (y / x) } +asm { ST(0) ST(1) } + FLD y { y - } + FLD x { x y } + FPATAN { atan(y/x) - } +end; +(* +function fmod(x, y : Float): Float; assembler; +{ retourne x mod y } +asm { ST(0) ST(1) } + FLD Y { y - } + FLD X { x y } +@repeat_mod: + FPREM { x mod y y } + FSTSW AX + SAHF + JP @repeat_mod + FSTP ST(1) { x mod y - } +end; + +function fmod_2PI( x : Float): Float; assembler; +{ retourne x mod 2.pi } +asm { ST(0) ST(1) } + FLDPI { pi - } + FADD ST, ST { 2.pi - } + FLD x { x 2.pi } +@unit_circle: + FPREM { x mod 2pi 2pi } + FSTSW AX + SAHF + JP @unit_circle + FSTP ST(1) { x mod 2pi - } +end; +*) +function fln(x : Float): Float; assembler; +{ retourne le logarithme naturel de x, utilise + la methode loge(x) = loge(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLN2 { ln(2) - } + FLD X { x ln(2) } + FYL2X { ln(2).log2(x) - } +end; + +function flog2(x : Float): Float; assembler; +{ retourne le logarithme de base 2 de x } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLD1 { 1 - } + FLD X { x 1 } + FYL2X { log2(x) - } +end; + +function flog10(x : Float): Float; assembler; +{ retourne le logarithme base 10 de x, utilise + la methode log10(x) = log10(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLG2 { log10(2) - } + FLD X { x log10(2) } + FYL2X {log2(x).log10(2) - } +end; + +function fexp(x : Float): Float; assembler; +{ retourne e^x, par la methode e^x = 2^(x.log2(e)) } +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) } +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLDL2E { log2(e) x - } + FMULP ST(1), ST { x.log2(e) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { e^x - - } +end; + +function fexp2(x : Float): Float; assembler; +{ retourne 2^x par la methode 2^z = 2^f.2^i } +{ with f = frac(z) and i = int(z) } +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { x x - } + FRNDINT { int(x) x - } + FLDCW control_ww + FXCH { x i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { 2^x - - } +end; + +function fexp10(x : Float): Float; assembler; +{ retourne 10^x, par la methode 10^x = 2^(x.log2(10)) +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLDL2T { log2(10) x - } + FMULP ST(1), ST { x.log2(10) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { 10^x - - } +end; +(* +function fpower(y, x : Float): Float; assembler; +{ retourne y^x, par la methode y^x = 2^(y.log2(y)) +{no range validity check is performed in this function (y > 0) } +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD Y { y - - } + FLD X { x y - } + FYL2X { x.log2(y) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { y^x - - } +end; + +function module(x, y : Float): Float; assembler; +{ retourne le module du complexe (x,y) } +asm { ST(0) ST(1) } + FLD Y { y - } + FMUL ST(0), ST { y.y - } + FLD X { x y.y } + FMUL ST(0), ST { x.x y.y } + FADDP ST(1), ST { d.d - } + FSQRT { d - } +end; +*) + diff --git a/npm/dmath/mathp2.inc b/npm/dmath/mathp2.inc new file mode 100755 index 0000000..969ecec --- /dev/null +++ b/npm/dmath/mathp2.inc @@ -0,0 +1,582 @@ +{ ********************************************************************** + * MATHP2.INC * + ********************************************************************** + Mathematical functions for TPMATH + (Assembler version for Pentium II/III with FPC) + ********************************************************************** } + + +{ Bibliotheque mathematique pour utilisation du coprocesseur flottant + JD GAYRARD Sept. 95 + + ---------------------------------------------------------------------- + Unite d'origine : MATH387.PAS, disponible dans MATHLIB2.ZIP + (http://wcarchive.cdrom.com/pub/delphi_www/) + Adapte aux pentiums II/III et complete par P. NOGARET (2000) + ---------------------------------------------------------------------- } + + + +{***********************************************************************} +{* function fexp(x : Float): Float;assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne e^x, par la methode e^x = 2^(x.log2(e)) *} +{* 2^z = 2^f.2^i avec f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1, *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{***********************************************************************} + function fexp(x : Float): Float;assembler; + var + round_z : dword; + temp : extended; + asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['eax']; + + +{***********************************************************************} +{* function fexp2(x : Float): Float; assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne 2^x par la methode 2^z = 2^f.2^i *} +{* avec f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1, *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* x - *} +{* z:=x - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{***********************************************************************} + function fexp2(x : Float): Float; assembler; + var + round_z : dword; + temp : extended; + asm + FLD x + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z { round_zmax := 16384 } + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['EAX']; + +{***********************************************************************} +{* function fexp10(x : Float): Float; assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne 10^x, par la methode 10^x = 2^(x.log2(10)) *} +{* 2^z = 2^f.2^i with f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1 *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* log2(10) - *} +{* x log2(10) *} +{* z:=x.log2(10) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* 10^x - *} +{***********************************************************************} + function fexp10(x : Float): Float; assembler; + var + round_z : dword; + temp : extended; + asm + FLDL2T + FLD X + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['EAX']; + +function fln(x : Float): Float; assembler; +{ retourne le logarithme naturel de x, utilise + la methode loge(x) = loge(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLN2 { ln(2) - } + FLD X { x ln(2) } + FYL2X { ln(2).log2(x) - } +end; + +function flog2(x : Float): Float; assembler; +{ retourne le logarithme de base 2 de x } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLD1 { 1 - } + FLD X { x 1 } + FYL2X { log2(x) - } +end; + +{***********************************************************************} +{* function flog10(X : Float) : Float; *} +{***********************************************************************} +{* Compute a common (base 10) logarithm. If X is near 1.0, then we *} +{* use the FYL2XP1 instruction instead of FYL2X. "Near" means between *} +{* 1.0 and 1+Sqrt(2)/2. We use an approximation for Sqrt(2)/2, so we *} +{* don't have to compute it. The exact value isn't important, since *} +{* FYL2X works fine for values near the transition. *} +{***********************************************************************} + function flog10(x : Float): Float; assembler; + const + HalfSqrt2p1: Extended = 1.7071; + asm + fldlg2 { push Log2 } + fld X { push X } + fld1 { push 1.0 } + fcomp ST(1) { if (X < 1.0) } + jl @@1 { goto @@1 } + fld HalfSqrt2p1 { push 1.707 } + fcomp ST(1) { if (X > 1.707) } + jg @@1 { goto @@1 } + fld1 { X is small, so subtract 1.0 } + fsubrp { X := X - 1.0 } + fyl2xp1 { Log10(2) * Log2(X+1) } + jmp @@2 + @@1: { X is not near 1.0 } + fyl2x { Log10(2) * Log2(X) } + @@2: + end; + +{***********************************************************************} +{* function fsin(X : Float) : Float; *} +{***********************************************************************} +{* if x < pi.2^62, then C2 is set to 0 and ST = sin(x) *} +{* else C2 is set to 1 and ST = x *} +{* no check range validity is performed in this function *} +{***********************************************************************} + function fsin(X : Float) : Float; assembler; + asm + FLD x + fsin + end; + +{***********************************************************************} +{* function fcos(X : Float) : Float; *} +{***********************************************************************} + function fcos(X : Float) : Float; assembler; + asm + FLD x + fcos + end; + +{***********************************************************************} +{* function ftan(X : Float) : Float;assembler; *} +{***********************************************************************} + function ftan(X : Float) : Float; assembler; + asm { ST(0) ST(1) } + FLD x { x - } + FPTAN { 1 tan(x) } + FSTP ST(0) { tan(x) - } + end; + +{***********************************************************************} +{* function farctan(X : Float) : Float; *} +{***********************************************************************} + function farctan(x : Float): Float; assembler; + asm { ST(0) ST(1) } + FLD x { x - } + FLD1 { 1 x } + FPATAN { atan(x/1) - } + end; + +{***********************************************************************} +{* function farctan2(Y, X : Float) : Float; *} +{***********************************************************************} +function farctan2(y, x : Float): Float; assembler; +{ retourne arctan (y / x) } +asm { ST(0) ST(1) } + FLD y { y - } + FLD x { x y } + FPATAN { atan(y/x) - } +end; + +{***********************************************************************} +{* function farcsin(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arcsin de x *} +{* methode : ________ *} +{* arcsin(x) = arctan( x / V 1 - x.x ) *} +{* no range validity check is performed in this function |x| > 1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* x - - *} +{* x x - *} +{* x.x x - *} +{* 1 x.x x *} +{* 1 - xý x - *} +{* sqrt(1-xý) x - *} +{* arcsin(x) - - *} +{***********************************************************************} +function farcsin(x : Float): Float; assembler; +asm + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBRP ST(1), ST + FSQRT + FPATAN +end; + +{***********************************************************************} +{* function farccos(x : Float): Float; assembler; *} +{***********************************************************************} +{* retourne l'arccos de x *} +{* methode : ________ *} +{* arccos(x) = arctan( V 1 - x.x / x) *} +{* pas de controle de domaine de definition |x| > 1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* x - - *} +{* x x - *} +{* x.x x - *} +{* 1 x.x x *} +{* 1 - xý x - *} +{* sqrt(1-xý) x - *} +{* x z - *} +{* arccos(x) - - *} +{***********************************************************************} +function farccos(x : Float): Float; assembler; +asm + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBRP ST(1), ST + FSQRT + FXCH + FPATAN +end; + +{***********************************************************************} +{* function fsinh(X : Float) : Float; *} +{***********************************************************************} +{* retourne le sinus hyperbolique de l'argument *} +{* sh(x) = [exp(x) - exp(-x)] / 2 *} +{* methode : z = exp(x), ch(x) = 1/2 (z - 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* log2(e) - - *} +{* x log2(e) - *} +{* z:=x.log2(e) - - *} +{* z - - *} +{* z - round(z) - - *} +{* 2^(z - round(z)) - 1 - - *} +{* 1 2^(z - round(z)) - 1 - *} +{* 2^(z - round(z)) - - *} +{* temp:=2^i 2^f:=2^(z - round(z)) - *} +{* e^x - - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z - *} +{* z-1/z - - *} +{* 0.5 z-1/z - *} +{* sh(x) - - *} +{***********************************************************************} +function fsinh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIVRP ST(1), ST + FSUBP ST(1), ST + FLD one_half + FMULP ST(1), ST +end; + +{***********************************************************************} +{* function fcosh(X : Float) : Float; *} +{***********************************************************************} +{* retourne le cosinus hyperbolique de l'argument *} +{* ch(x) = [exp(x) + exp(-x)] / 2 *} +{* methode : z = exp(x), ch(x) = 1/2 (z + 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* st(0) st(1) st(2) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z - *} +{* z+1/z - - *} +{* 0.5 z+1/z - *} +{* ch(x) - - *} +{***********************************************************************} +function fcosh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIVRP ST(1), ST + FADDP ST(1), ST + FLD one_half + FMULP ST(1), ST +end; + +{***********************************************************************} +{* function ftanh(X : Float) : Float; *} +{***********************************************************************} +{* retourne la tangente hyperbolique de l'argument *} +{* th(x) = sh(x) / ch(x) *) *} +{* th(x) = [exp(x) - exp(-x)] / [exp(x) + exp(-x)] *} +{* methode : z = exp(x), ch(x) = (z - 1/z) / (z + 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* st(0) st(1) st(2) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z z *} +{* 1/z z z-1/z *} +{* z+1/z z-1/z - *} +{* th(x) - - *} +{***********************************************************************} +function ftanh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIV ST, ST(1) + FSUB ST(2), ST + FADDP ST(1), ST + FDIVP ST(1), ST +end; + +{***********************************************************************} +{* function farcsinh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc sinus hyperbolique de l'argument *} +{* _________ *} +{* arg sh(x) = ln ( x + V x.x + 1 ) *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* x.x x ln(2) - *} +{* 1 x.x x ln(2) *} +{* x.x + 1 x ln(2) - *} +{* sqrt(x.x+1) x ln(2) - *} +{* x + z ln(2) - - *} +{* arg_sh(x) - - - *} +{***********************************************************************} +function farcsinh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FADDP ST(1), ST + FSQRT + FADDP ST(1), ST + FYL2X +end; + +{***********************************************************************} +{* function farccosh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc cosinus hyperbolique de l'argument *} +{* ________ *} +{* arg ch(x) = ln ( x + V x.x - 1 ) x >=1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* x.x x ln(2) - *} +{* 1 x.x x ln(2) *} +{* x.x - 1 x ln(2) - *} +{* sqrt(x2-1) x ln(2) - *} +{* x + z ln(2) - - *} +{* arg_ch(x) - - - *} +{***********************************************************************} +function farccosh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBP ST(1), ST + FSQRT + FADDP ST(1), ST + FYL2X +end; + +{***********************************************************************} +{* function farctanh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc tangente hyperbolique de l'argument *} +{* arg th(x) = 1/2 ln [ (1 + x) / (1 - x) ] *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* 1 x x ln(2) *} +{* 1 x 1 + x ln(2) *} +{* 1 - x 1 + x ln(2) - *} +{* 1+x/1-x ln(2) - - *} +{* ln(z) - - - *} +{***********************************************************************} +function farctanh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FLD1 + FADD ST(2),ST + FSUBRP ST(1),ST + FDIVP ST(1),ST + FYL2X +end; diff --git a/npm/dmath/mcmc.pas b/npm/dmath/mcmc.pas new file mode 100755 index 0000000..4536521 --- /dev/null +++ b/npm/dmath/mcmc.pas @@ -0,0 +1,273 @@ +{ ********************************************************************** + * Unit MCMC.PAS * + * Version 1.2 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Simulation by Markov Chain Monte Carlo (MCMC) with the + Metropolis-Hastings algorithm. + + This algorithm simulates the probability density function (pdf) of a + vector X. The pdf P(X) is written as: + + P(X) = C * Exp(- F(X) / T) + + Simulating P by the Metropolis-Hastings algorithm is equivalent to + minimizing F by simulated annealing at the constant temperature T. + The constant C is not used in the simulation. + + The series of random vectors generated during the annealing step + constitutes a Markov chain which tends towards the pdf to be simulated. + + It is possible to run several cycles of the algorithm. + The variance-covariance matrix of the simulated distribution is + re-evaluated at the end of each cycle and used for the next cycle. + ********************************************************************** } + +unit MCMC; + +interface + +uses + FMath, Matrices, Optim, Regress; + + +{ ********************************************************************** + Metropolis-Hastings parameters + ********************************************************************** } + +const + MH_NCycles : Integer = 1; { Number of cycles } + MH_MaxSim : Integer = 1000; { Max nb of simulations at each cycle } + MH_SavedSim : Integer = 200; { Nb of simulations to be saved } + +{ ********************************************************************** + Simulation routine + ********************************************************************** } + + function Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Simulation of a probability density function by the + Metropolis-Hastings algorithm + ---------------------------------------------------------------------- + Input parameters : Func = Function such that the pdf is + P(X) = C * Exp(- Func(X) / T) + T = Temperature + X = Initial mean vector + V = Initial variance-covariance matrix + Lbound, + Ubound = Indices of first and last variables + ---------------------------------------------------------------------- + Output parameters : Xmat = Matrix of simulated vectors, stored + columnwise, i.e. + Xmat[Lbound..Ubound, 1..MH_SavedSim] + X = Mean of distribution + V = Variance-covariance matrix of distribution + X_min = Coordinates of minimum of F(X) + (mode of the distribution) + F_min = Value of F(X) at minimum + ---------------------------------------------------------------------- + Possible results : MAT_OK : No error + MAT_NOT_PD : The variance-covariance matrix + is not positive definite + ---------------------------------------------------------------------- } + +implementation + + function CalcSD(V : PMatrix; + Lbound, Ubound : Integer; + L : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Computes the standard deviations for independent random numbers + from the variance-covariance matrix. + ---------------------------------------------------------------------- } + var + I, ErrCode : Integer; + begin + I := LBound; + ErrCode := 0; + repeat + if V^[I]^[I] > 0.0 then + L^[I]^[I] := Sqrt(V^[I]^[I]) + else + ErrCode := MAT_NOT_PD; + Inc(I); + until (ErrCode <> 0) or (I > Ubound); + CalcSD := ErrCode; + end; + + procedure GenIndepRandomVector(X : PVector; + L : PMatrix; + Lbound, Ubound : Integer; + X1 : PVector); +{ ---------------------------------------------------------------------- + Generates a random vector X1 from X, using independent gaussian random + increments. L is the diagonal matrix of the standard deviations. + ---------------------------------------------------------------------- } + var + I : Integer; + begin + for I := Lbound to Ubound do + X1^[I] := RanGauss(X^[I], L^[I]^[I]); + end; + + procedure GenRandomVector(X : PVector; + L : PMatrix; + Lbound, Ubound : Integer; + X1 : PVector); +{ ---------------------------------------------------------------------- + Generates a random vector X1 from X, using correlated gaussian random + increments. L is the Cholesky factor of the variance-covariance matrix + ---------------------------------------------------------------------- } + var + U : PVector; + I, J : Integer; + begin + { Form a vector U of independent standard normal variates } + DimVector(U, Ubound); + for I := Lbound to Ubound do + U^[I] := RanGaussStd; + + { Form X1 = X + L*U, which follows the multinormal distribution } + for I := Lbound to Ubound do + begin + X1^[I] := X^[I]; + for J := Lbound to I do + X1^[I] := X1^[I] + L^[I]^[J] * U^[J]; + end; + DelVector(U, Ubound); + end; + + function Accept(DeltaF, T : Float) : Boolean; +{ ---------------------------------------------------------------------- + Checks if a variation DeltaF of the function at temperature T is + acceptable. + ---------------------------------------------------------------------- } + begin + Accept := (DeltaF < 0.0) or (Expo(- DeltaF / T) > RanMar); + end; + + function HastingsCycle(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Indep : Boolean; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs one cycle of the Metropolis-Hastings algorithm + ---------------------------------------------------------------------- } + var + F, F1 : Float; { Function values } + DeltaF : Float; { Variation of function } + X1 : PVector; { New coordinates } + L : PMatrix; { Standard dev. or Cholesky factor } + I, K : Integer; { Loop variable } + Iter : Integer; { Iteration count } + FirstSavedSim : Integer; { Index of first simulation to be saved } + ErrCode : Integer; { Error code } + begin + { Dimension arrays } + DimVector(X1, Ubound); + DimMatrix(L, Ubound, Ubound); + + { Compute SD's or Cholesky factor } + if Indep then + ErrCode := CalcSD(V, Lbound, Ubound, L) + else + ErrCode := Cholesky(V, Lbound, Ubound, L); + + HastingsCycle := ErrCode; + if ErrCode = MAT_NOT_PD then Exit; + + { Compute initial function value } + F := Func(X); + + { Perform MH_MaxSim simulations at constant temperature } + FirstSavedSim := MH_MaxSim - MH_SavedSim + 1; + Iter := 1; + K := 1; + + repeat + { Generate new vector } + if Indep then + GenIndepRandomVector(X, L, Lbound, Ubound, X1) + else + GenRandomVector(X, L, Lbound, Ubound, X1); + + { Compute new function value } + F1 := Func(X1); + DeltaF := F1 - F; + + { Check for acceptance } + if Accept(DeltaF, T) then + begin + CopyVector(X, X1, Lbound, Ubound); + + if Iter >= FirstSavedSim then + begin + { Save simulated vector into column K of matrix Xmat } + CopyColFromVector(Xmat, X1, Lbound, Ubound, K); + Inc(K); + end; + + if F1 < F_min then + begin + { Update minimum } + CopyVector(X_min, X1, Lbound, Ubound); + F_min := F1; + end; + + F := F1; + Inc(Iter); + end; + until Iter > MH_MaxSim; + + { Update mean vector and variance-covariance matrix } + VecMean(Xmat, MH_SavedSim, Lbound, Ubound, X); + MatVarCov(Xmat, MH_SavedSim, Lbound, Ubound, X, V); + + DelVector(X1, Ubound); + DelMatrix(L, Ubound, Ubound); + end; + + function Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; + var + K, ErrCode : Integer; + Indep : Boolean; + begin + { Initialize the Marsaglia random number generator + using the standard Pascal generator } + Randomize; + RMarIn(System.Random(10000), System.Random(10000)); + + K := 1; + Indep := True; + F_min := MAXNUM; + + repeat + ErrCode := HastingsCycle(Func, T, X, V, Lbound, Ubound, + Indep, Xmat, X_min, F_min); + Indep := False; + Inc(K); + until (ErrCode <> 0) or (K > MH_NCycles); + + Hastings := ErrCode; + end; + +end. \ No newline at end of file diff --git a/npm/dmath/models.pas b/npm/dmath/models.pas new file mode 100755 index 0000000..7dfd892 --- /dev/null +++ b/npm/dmath/models.pas @@ -0,0 +1,530 @@ +{ ********************************************************************** + * Unit MODELS.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Library of regression and variance models + ********************************************************************** } + +unit Models; + +{$F+} + +interface + +uses + FMath, + Matrices, + Regress, + FitLin, + FitMult, + FitPoly, + FitFrac, + FitExpo, + FitIExpo, + FitExLin, + FitPower, + FitMich, + FitHill, + FitLogis, + FitPKa; + +{ --------------------------------------------------------------------- + Highest index of regression models + --------------------------------------------------------------------- } +const + MAXMODEL = 11; + +{ --------------------------------------------------------------------- + Highest index of variance models + --------------------------------------------------------------------- } +const + MAXVARMODEL = 5; + +{ --------------------------------------------------------------------- + Definition of regression models + --------------------------------------------------------------------- } +const + REG_LIN = 0; { Linear } + REG_MULT = 1; { Multiple linear } + REG_POL = 2; { Polynomial } + REG_FRAC = 3; { Rational fraction } + REG_EXPO = 4; { Sum of exponentials } + REG_IEXPO = 5; { Increasing exponential } + REG_EXLIN = 6; { Exponential + linear } + REG_POWER = 7; { Power } + REG_MICH = 8; { Michaelis } + REG_HILL = 9; { Hill } + REG_LOGIS = 10; { Logistic } + REG_PKA = 11; { Acid/Base titration curve } + +{ --------------------------------------------------------------------- + Definition of variance models + --------------------------------------------------------------------- } +const + VAR_CONST = 0; { Constant } + VAR_LIN = 1; { Linear } + VAR_POL2 = 2; { 2nd degree polynomial } + VAR_POL3 = 3; { 3rd degree polynomial } + VAR_EXPO = 4; { Exponential } + VAR_POWER = 5; { Power } + +{ --------------------------------------------------------------------- + Names of regression models + --------------------------------------------------------------------- } + +const + MODELNAME : array[0..MAXMODEL] of String = +{$IFDEF FRENCH} + ('Lineaire', + 'Lineaire multiple', + 'Polynomial', + 'Fraction rationnelle', + 'Somme d''exponentielles', + 'Exponentielle croissante', + 'Exponentielle + lineaire', + 'Puissance', + 'Michaelis', + 'Hill', + 'Logistique', + 'Titrage acide/base'); +{$ELSE} + ('Linear', + 'Multiple linear', + 'Polynomial', + 'Rational fraction', + 'Sum of exponentials', + 'Increasing exponential', + 'Exponential + linear', + 'Power', + 'Michaelis', + 'Hill', + 'Logistic', + 'Acid/Base titration curve'); +{$ENDIF} + +{ --------------------------------------------------------------------- + Names of variance models + --------------------------------------------------------------------- } + +const + VARMODELNAME : array[0..MAXVARMODEL] of String = +{$IFDEF FRENCH} + ('Constante', + 'Lineaire', + 'Polynome de degre 2', + 'Polynome de degre 3', + 'Exponentielle', + 'Puissance'); +{$ELSE} + ('Constant', + 'Linear', + '2nd degree polynomial', + '3rd degree polynomial', + 'Exponential', + 'Power'); +{$ENDIF} + +function FuncName : String; +{ -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + +function FirstParam : Integer; +{ -------------------------------------------------------------------- + Returns the index of the first fitted parameter + -------------------------------------------------------------------- } + +function LastParam : Integer; +{ -------------------------------------------------------------------- + Returns the index of the last fitted parameter + -------------------------------------------------------------------- } + +function ParamName(I : Integer) : String; +{ -------------------------------------------------------------------- + Returns the name of the I-th fitted parameter + -------------------------------------------------------------------- } + +function RegFunc(X : Float; B : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the regression function for one independent variable + B is the vector of parameters + -------------------------------------------------------------------- } + +function RegFuncNVar(X, B : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the regression function for several independent variables + B is the vector of parameters + -------------------------------------------------------------------- } + +procedure DerivProc(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); +{ -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + +procedure InitModel(Reg_Model, Var_Model : Integer; CstPar : PVector); +{ -------------------------------------------------------------------- + Initializes the regression and variance models. Constant parameters + (e.g. degree of polynomial) are passed in vector CstPar. + -------------------------------------------------------------------- } + +function WLSFit(X : PVector; + U : PMatrix; + Y : PVector; + N : Integer; + Init : Boolean; + MaxIter : Integer; + Tol : Float; + Theta, B : PVector; + B_min, B_max : PVector; + V : PMatrix; + Ycalc, S : PVector; + var Test : TRegTest) : Integer; +{ ---------------------------------------------------------------------- + Fits the regression function and computes the regression tests + ---------------------------------------------------------------------- + Input : X, U = vector or matrix of independent variable(s) + Y = vector of dependent variable + N = number of observations + Init = TRUE to compute initial parameter estimates + FALSE to use the current values + MaxIter = maximum number of iterations + (if 0 the parameters will not be refined) + Tol = required parameter precision + Theta = variance parameters + B = initial parameters values + B_min, B_max = parameter bounds + -------------------------------------------------------------------- + Output : Theta = updated variance parameters + (residual variance stored in Theta^[0]) + B = regression parameters + V = variance-covariance matrix + Ycalc = estimated Y values + S = standard deviations of Y + Test = regression tests + -------------------------------------------------------------------- + Possible results = OPT_OK : no error + OPT_SING : singular matrix + OPT_BIG_LAMBDA : too high Marquardt's parameter + OPT_NON_CONV : non-convergence + -------------------------------------------------------------------- } + +function VarFuncName : String; +{ -------------------------------------------------------------------- + Returns the name of the variance function + -------------------------------------------------------------------- } + +function LastVarParam : Integer; +{ ---------------------------------------------------------------------- + Returns the index of the last variance parameter (upper bound of Theta) + ---------------------------------------------------------------------- } + +function VarFunc(Y : Float; Theta : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the variance of an observation Y. The parameters are + Theta^[1], Theta^[2],... The true variance is Theta^[0] * VarFunc, + where Theta^[0] (equal to the residual variance Vr) is estimated by + the regression program. + -------------------------------------------------------------------- } + +implementation + +const + RegModel : Integer = 0; { Index of regression model } + VarModel : Integer = 0; { Index of variance model } + + function FuncName : String; + begin + case RegModel of + REG_LIN : FuncName := FitLin.FuncName; + REG_MULT : FuncName := FitMult.FuncName; + REG_POL : FuncName := FitPoly.FuncName; + REG_FRAC : FuncName := FitFrac.FuncName; + REG_EXPO : FuncName := FitExpo.FuncName; + REG_IEXPO : FuncName := FitIExpo.FuncName; + REG_EXLIN : FuncName := FitExLin.FuncName; + REG_POWER : FuncName := FitPower.FuncName; + REG_MICH : FuncName := FitMich.FuncName; + REG_HILL : FuncName := FitHill.FuncName; + REG_LOGIS : FuncName := FitLogis.FuncName; + REG_PKA : FuncName := FitPKa.FuncName; + end; + end; + + function FirstParam : Integer; + begin + case RegModel of + REG_LIN : FirstParam := FitLin.FirstParam; + REG_MULT : FirstParam := FitMult.FirstParam; + REG_POL : FirstParam := FitPoly.FirstParam; + REG_FRAC : FirstParam := FitFrac.FirstParam; + REG_EXPO : FirstParam := FitExpo.FirstParam; + REG_IEXPO : FirstParam := FitIExpo.FirstParam; + REG_EXLIN : FirstParam := FitExLin.FirstParam; + REG_POWER : FirstParam := FitPower.FirstParam; + REG_MICH : FirstParam := FitMich.FirstParam; + REG_HILL : FirstParam := FitHill.FirstParam; + REG_LOGIS : FirstParam := FitLogis.FirstParam; + REG_PKA : FirstParam := FitPKa.FirstParam; + end; + end; + + function LastParam : Integer; + begin + case RegModel of + REG_LIN : LastParam := FitLin.LastParam; + REG_MULT : LastParam := FitMult.LastParam; + REG_POL : LastParam := FitPoly.LastParam; + REG_FRAC : LastParam := FitFrac.LastParam; + REG_EXPO : LastParam := FitExpo.LastParam; + REG_IEXPO : LastParam := FitIExpo.LastParam; + REG_EXLIN : LastParam := FitExLin.LastParam; + REG_POWER : LastParam := FitPower.LastParam; + REG_MICH : LastParam := FitMich.LastParam; + REG_HILL : LastParam := FitHill.LastParam; + REG_LOGIS : LastParam := FitLogis.LastParam; + REG_PKA : LastParam := FitPKa.LastParam; + end; + end; + + function ParamName(I : Integer) : String; + begin + case RegModel of + REG_LIN : ParamName := FitLin.ParamName(I); + REG_MULT : ParamName := FitMult.ParamName(I); + REG_POL : ParamName := FitPoly.ParamName(I); + REG_FRAC : ParamName := FitFrac.ParamName(I); + REG_EXPO : ParamName := FitExpo.ParamName(I); + REG_IEXPO : ParamName := FitIExpo.ParamName(I); + REG_EXLIN : ParamName := FitExLin.ParamName(I); + REG_POWER : ParamName := FitPower.ParamName(I); + REG_MICH : ParamName := FitMich.ParamName(I); + REG_HILL : ParamName := FitHill.ParamName(I); + REG_LOGIS : ParamName := FitLogis.ParamName(I); + REG_PKA : ParamName := FitPKa.ParamName(I); + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + begin + case RegModel of + REG_LIN : RegFunc := FitLin.RegFunc(X, B); + REG_POL : RegFunc := FitPoly.RegFunc(X, B); + REG_FRAC : RegFunc := FitFrac.RegFunc(X, B); + REG_EXPO : RegFunc := FitExpo.RegFunc(X, B); + REG_IEXPO : RegFunc := FitIExpo.RegFunc(X, B); + REG_EXLIN : RegFunc := FitExLin.RegFunc(X, B); + REG_POWER : RegFunc := FitPower.RegFunc(X, B); + REG_MICH : RegFunc := FitMich.RegFunc(X, B); + REG_HILL : RegFunc := FitHill.RegFunc(X, B); + REG_LOGIS : RegFunc := FitLogis.RegFunc(X, B); + REG_PKA : RegFunc := FitPKa.RegFunc(X, B); + end; + end; + + function RegFuncNVar(X, B : PVector) : Float; + begin + case RegModel of + REG_MULT : RegFuncNVar := FitMult.RegFunc(X, B); + end; + end; + + procedure DerivProc(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + begin + case RegModel of + REG_FRAC : FitFrac.DerivProc(X, Y, B, D); + REG_EXPO : FitExpo.DerivProc(X, B, D); + REG_IEXPO : FitIExpo.DerivProc(X, B, D); + REG_EXLIN : FitExLin.DerivProc(X, B, D); + REG_POWER : FitPower.DerivProc(X, Y, B, D); + REG_MICH : FitMich.DerivProc(X, Y, B, D); + REG_HILL : FitHill.DerivProc(X, Y, B, D); + REG_LOGIS : FitLogis.DerivProc(X, B, D); + REG_PKA : FitPKa.DerivProc(X, B, D); + else + NumDeriv(RegFunc, X, Y, B, D); + end; + end; + + procedure InitModel(Reg_Model, Var_Model : Integer; CstPar : PVector); + begin + RegModel := Reg_Model; + VarModel := Var_Model; + case RegModel of + REG_MULT : FitMult.InitModel(CstPar); + REG_POL : FitPoly.InitModel(CstPar); + REG_FRAC : FitFrac.InitModel(CstPar); + REG_EXPO : FitExpo.InitModel(CstPar); + REG_LOGIS : FitLogis.InitModel(CstPar); + end; + end; + + function FitModel(Method : Integer; + X : PVector; + U : PMatrix; + Y, W : PVector; + N : Integer; + B : PVector; + V : PMatrix) : Integer; +{ -------------------------------------------------------------------- + Fits the regression model by unweighted linear least squares. For + nonlinear models, this is only an approximate fit, to be refined by + the nonlinear regression procedure WLSFit + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, U = vector or matrix of independent variable(s) + Y = vector of dependent variable + W = weights + N = number of observations + -------------------------------------------------------------------- + Output : B = estimated regression parameters + V = unscaled variance-covariance matrix (for linear + and polynomial models only). The true matrix will + be Vr * V, where Vr is the residual variance. + -------------------------------------------------------------------- + The function returns 0 if no error occurred + -------------------------------------------------------------------- } + begin + case RegModel of + REG_LIN : FitModel := FitLin.FitModel(Method, X, Y, W, N, B, V); + REG_MULT : FitModel := FitMult.FitModel(Method, U, Y, W, N, B, V); + REG_POL : FitModel := FitPoly.FitModel(Method, X, Y, W, N, B, V); + REG_FRAC : FitModel := FitFrac.FitModel(Method, X, Y, W, N, B); + REG_EXPO : FitModel := FitExpo.FitModel(Method, X, Y, W, N, B); + REG_IEXPO : FitModel := FitIExpo.FitModel(Method, X, Y, W, N, B); + REG_EXLIN : FitModel := FitExLin.FitModel(X, Y, N, B); + REG_POWER : FitModel := FitPower.FitModel(Method, X, Y, W, N, B); + REG_MICH : FitModel := FitMich.FitModel(Method, X, Y, W, N, B); + REG_HILL : FitModel := FitHill.FitModel(Method, X, Y, W, N, B); + REG_LOGIS : FitModel := FitLogis.FitModel(Method, X, Y, W, N, B); + REG_PKA : FitModel := FitPKa.FitModel(X, Y, N, B); + end; + end; + + function WLSFit(X : PVector; + U : PMatrix; + Y : PVector; + N : Integer; + Init : Boolean; + MaxIter : Integer; + Tol : Float; + Theta, B : PVector; + B_min, B_max : PVector; + V : PMatrix; + Ycalc, S : PVector; + var Test : TRegTest) : Integer; + var + Method : Integer; { Regression method } + W : PVector; { Weights } + Xk : PVector; { Vector of variables for observation k } + Sr : Float; { Residual standard deviation } + ErrCode : Integer; { Error code } + K : Integer; { Loop variable } + begin + DimVector(W, N); + DimVector(Xk, LastParam); + + { Determine regression method } + if VarModel = VAR_CONST then Method := 0 else Method := 1; + + { Compute weights if necessary } + if Method = 1 then + for K := 1 to N do + W^[K] := 1.0 / VarFunc(Y^[K], Theta); + + { Compute initial parameter estimates if necessary } + if Init then + ErrCode := FitModel(Method, X, U, Y, W, N, B, V) + else + ErrCode := 0; + + { Refine parameters if necessary } + if not(RegModel in [REG_LIN, REG_MULT, REG_POL]) and + (MaxIter > 0) and (ErrCode = 0) then + if VarModel = VAR_CONST then + ErrCode := NLFit({$IFDEF FPK}@{$ENDIF}RegFunc, + {$IFDEF FPK}@{$ENDIF}DerivProc, + X, Y, N, FirstParam, LastParam, + MaxIter, Tol, B, B_min, B_max, V) + else + ErrCode := WNLFit({$IFDEF FPK}@{$ENDIF}RegFunc, + {$IFDEF FPK}@{$ENDIF}DerivProc, + X, Y, W, N, FirstParam, LastParam, + MaxIter, Tol, B, B_min, B_max, V); + + if ErrCode = 0 then + begin + { Estimate Y values } + if RegModel = REG_MULT then + for K := 1 to N do + begin + CopyVectorFromCol(Xk, U, FirstParam, LastParam, K); + Ycalc^[K] := RegFuncNVar(Xk, B); + end + else + for K := 1 to N do + Ycalc^[K] := RegFunc(X^[K], B); + + { Compute regression tests and update variance-covariance matrix } + if VarModel = VAR_CONST then + RegTest(Y, Ycalc, N, FirstParam, LastParam, V, Test) + else + WRegTest(Y, Ycalc, W, N, FirstParam, LastParam, V, Test); + + { Store residual variance in Theta^[0] } + Theta^[0] := Test.Vr; + + { Compute standard deviations } + Sr := Sqrt(Test.Vr); + for K := 1 to N do + S^[K] := Sr; + if VarModel <> VAR_CONST then + for K := 1 to N do + S^[K] := S^[K] / Sqrt(W^[K]); + end; + + DelVector(W, N); + DelVector(Xk, LastParam); + + WLSFit := ErrCode; + end; + + function VarFuncName : String; + begin + case VarModel of + VAR_CONST : VarFuncName := 'v = e0'; + VAR_LIN : VarFuncName := 'v = e0.(1 + e1.y)'; + VAR_POL2 : VarFuncName := 'v = e0.(1 + e1.y + e2.y^2)'; + VAR_POL3 : VarFuncName := 'v = e0.(1 + e1.y + e2.y^2 + e3.y^3)'; + VAR_EXPO : VarFuncName := 'v = e0.exp(e1.y)'; + VAR_POWER : VarFuncName := 'v = e0.y^e1'; + end; + end; + + function VarFunc(Y : Float; Theta : PVector) : Float; + begin + case VarModel of + VAR_CONST : VarFunc := 1.0; + VAR_LIN : VarFunc := 1.0 + Theta^[1] * Y; + VAR_POL2 : VarFunc := 1.0 + Y * (Theta^[1] + Theta^[2] * Y); + VAR_POL3 : VarFunc := 1.0 + Y * (Theta^[1] + Y * (Theta^[2] + Theta^[3] * Y)); + VAR_EXPO : VarFunc := Exp(Theta^[1] * Y); + VAR_POWER : VarFunc := Power(Y, Theta^[1]); + end; + end; + + function LastVarParam : Integer; + begin + case VarModel of + VAR_CONST : LastVarParam := 0; + VAR_LIN : LastVarParam := 1; + VAR_POL2 : LastVarParam := 2; + VAR_POL3 : LastVarParam := 3; + VAR_EXPO : LastVarParam := 1; + VAR_POWER : LastVarParam := 1; + end; + end; + +end. diff --git a/npm/dmath/optim.pas b/npm/dmath/optim.pas new file mode 100755 index 0000000..17575b0 --- /dev/null +++ b/npm/dmath/optim.pas @@ -0,0 +1,972 @@ +{ ********************************************************************** + * Unit OPTIM.PAS * + * Version 2.1 * + * (c) J. Debord, June 2001 * + ********************************************************************** + This unit implements the following methods for function minimization: + + * Golden search for a function of one variable + * Simplex, Marquardt, BFGS for a function of several variables + ********************************************************************** + References: + 1) 'Numerical Recipes' by Press et al. + 2) D. W. MARQUARDT, J. Soc. Indust. Appl. Math., 1963, 11, 431-441 + 3) J. A. NELDER & R. MEAD, Comput. J., 1964, 7, 308-313 + 4) R. O'NEILL, Appl. Statist., 1971, 20, 338-345 + ********************************************************************** } + +unit Optim; + +interface + +uses + FMath, Matrices; + +{ ********************************************************************** + Error codes + ********************************************************************** } + +const + OPT_OK = 0; { No error } + OPT_SING = - 1; { Singular hessian matrix } + OPT_BIG_LAMBDA = - 2; { Too high Marquardt's parameter } + OPT_NON_CONV = - 3; { Non-convergence } + +{ ********************************************************************** + Functional types + ********************************************************************** } + +type + { Function of several variables } + TFuncNVar = function(X : PVector) : Float; + + { Procedure to compute gradient vector } + TGradient = procedure(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); + + { Procedure to compute gradient vector and hessian matrix } + THessGrad = procedure(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); + +{ ********************************************************************** + Log file + ********************************************************************** } + +const + WriteLogFile : Boolean = False; { Write iteration info to log file } + LogFileName : String = 'optim.log'; { Name of log file } + +{ ********************************************************************** + Minimization routines + ********************************************************************** } + +function GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs a golden search for the minimum of function Func + ---------------------------------------------------------------------- + Input parameters : Func = objective function + A, B = two points near the minimum + MaxIter = maximum number of iterations + Tol = required precision (should not be less than + the square root of the machine precision) + ---------------------------------------------------------------------- + Output parameters : Xmin, Ymin = coordinates of minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + +{ ---------------------------------------------------------------------- + Minimizes function Func from point X in the direction specified by + DeltaX + ---------------------------------------------------------------------- + Input parameters : Func = objective function + X = initial minimum coordinates + DeltaX = direction in which minimum is searched + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function Simplex(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by the simplex method + of Nelder and Mead + ---------------------------------------------------------------------- + Input parameters : Func = objective function + X = initial minimum coordinates + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +procedure NumGradient(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); +{ ---------------------------------------------------------------------- + Computes the gradient vector of a function of several variables by + numerical differentiation + ---------------------------------------------------------------------- + Input parameters : Func = function of several variables + X = vector of variables + Lbound, + Ubound = indices of first and last variables + ---------------------------------------------------------------------- + Output parameter : G = gradient vector + ---------------------------------------------------------------------- } + +procedure NumHessGrad(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); +{ ---------------------------------------------------------------------- + Computes gradient vector & hessian matrix by numerical differentiation + ---------------------------------------------------------------------- + Input parameters : as in NumGradient + ---------------------------------------------------------------------- + Output parameters : G = gradient vector + H = hessian matrix + ---------------------------------------------------------------------- } + +function Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by Marquardt's method + ---------------------------------------------------------------------- + Input parameters : Func = objective function + HessGrad = procedure to compute gradient & hessian + X = initial minimum coordinates + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + H_inv = inverse hessian matrix + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_SING + OPT_BIG_LAMBDA + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by the + Broyden-Fletcher-Goldfarb-Shanno method + ---------------------------------------------------------------------- + Parameters : Gradient = procedure to compute gradient vector + Other parameters as in Marquardt + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + +var + Eps : Float; { Fractional increment for numer. derivation } + X1 : PVector; { Initial point for line minimization } + DeltaX1 : PVector; { Direction for line minimization } + Lbound1, Ubound1 : Integer; { Bounds of X1 and DeltaX1 } + LinObjFunc : TFuncNVar; { Objective function for line minimization } + LogFile : Text; { Stores the result of each minimization step } + + + procedure MinBrack(Func : TFunc; var A, B, C, Fa, Fb, Fc : Float); +{ ---------------------------------------------------------------------- + Given two points (A, B) this procedure finds a triplet (A, B, C) + such that: + + 1) A < B < C + 2) A, B, C are within the golden ratio + 3) Func(B) < Func(A) and Func(B) < Func(C). + + The corresponding function values are returned in Fa, Fb, Fc + ---------------------------------------------------------------------- } + + begin + if A > B then + FSwap(A, B); + Fa := Func(A); + Fb := Func(B); + if Fb > Fa then + begin + FSwap(A, B); + FSwap(Fa, Fb); + end; + C := B + GOLD * (B - A); + Fc := Func(C); + while Fc < Fb do + begin + A := B; + B := C; + Fa := Fb; + Fb := Fc; + C := B + GOLD * (B - A); + Fc := Func(C); + end; + if A > C then + begin + FSwap(A, C); + FSwap(Fa, Fc); + end; + end; + + function GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float) : Integer; + var + C, Fa, Fb, Fc, F1, F2, MinTol, X0, X1, X2, X3 : Float; + Iter : Integer; + begin + MinTol := Sqrt(MACHEP); + if Tol < MinTol then Tol := MinTol; + MinBrack(Func, A, B, C, Fa, Fb, Fc); + X0 := A; + X3 := C; + if (C - B) > (B - A) then + begin + X1 := B; + X2 := B + CGOLD * (C - B); + F1 := Fb; + F2 := Func(X2); + end + else + begin + X1 := B - CGOLD * (B - A); + X2 := B; + F1 := Func(X1); + F2 := Fb; + end; + Iter := 0; + while (Iter <= MaxIter) and (Abs(X3 - X0) > Tol * (Abs(X1) + Abs(X2))) do + if F2 < F1 then + begin + X0 := X1; + X1 := X2; + F1 := F2; + X2 := X1 + CGOLD * (X3 - X1); + F2 := Func(X2); + Inc(Iter); + end + else + begin + X3 := X2; + X2 := X1; + F2 := F1; + X1 := X2 - CGOLD * (X2 - X0); + F1 := Func(X1); + Inc(Iter); + end; + if F1 < F2 then + begin + Xmin := X1; + Ymin := F1; + end + else + begin + Xmin := X2; + Ymin := F2; + end; + if Iter > MaxIter then + GoldSearch := OPT_NON_CONV + else + GoldSearch := OPT_OK; + end; + + procedure CreateLogFile; + begin + Assign(LogFile, LogFileName); + Rewrite(LogFile); + end; + + function Simplex(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + const + STEP = 1.50; { Step used to construct the initial simplex } + var + P : PMatrix; { Simplex coordinates } + F : PVector; { Function values } + Pbar : PVector; { Centroid coordinates } + Pstar, P2star : PVector; { New vertices } + Ystar, Y2star : Float; { New function values } + F0 : Float; { Function value at minimum } + N : Integer; { Number of parameters } + M : Integer; { Index of last vertex } + L, H : Integer; { Vertices with lowest & highest F values } + I, J : Integer; { Loop variables } + Iter : Integer; { Iteration count } + Corr, MaxCorr : Float; { Corrections } + Sum : Float; + Flag : Boolean; + + procedure UpdateSimplex(Y : Float; Q : PVector); + { Update "worst" vertex and function value } + begin + F^[H] := Y; + CopyVector(P^[H], Q, Lbound, Ubound); + end; + + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'Simplex'); + WriteLn(LogFile, 'Iter F'); + end; + + N := Ubound - Lbound + 1; + M := Succ(Ubound); + + DimMatrix(P, M, Ubound); + DimVector(F, M); + DimVector(Pbar, Ubound); + DimVector(Pstar, Ubound); + DimVector(P2star, Ubound); + + Iter := 1; + F0 := MAXNUM; + + { Construct initial simplex } + for I := Lbound to M do + CopyVector(P^[I], X, Lbound, Ubound); + for I := Lbound to Ubound do + P^[I]^[I] := P^[I]^[I] * STEP; + + { Evaluate function at each vertex } + for I := Lbound to M do + F^[I] := Func(P^[I]); + + repeat + { Find vertices (L,H) having the lowest and highest + function values, i.e. "best" and "worst" vertices } + L := Lbound; + H := Lbound; + for I := Succ(Lbound) to M do + if F^[I] < F^[L] then + L := I + else if F^[I] > F^[H] then + H := I; + if F^[L] < F0 then + F0 := F^[L]; + + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F0:12); + + { Find centroid of points other than P(H) } + for J := Lbound to Ubound do + begin + Sum := 0.0; + for I := Lbound to M do + if I <> H then Sum := Sum + P^[I]^[J]; + Pbar^[J] := Sum / N; + end; + + { Reflect worst vertex through centroid } + for J := Lbound to Ubound do + Pstar^[J] := 2.0 * Pbar^[J] - P^[H]^[J]; + Ystar := Func(Pstar); + + { If reflection successful, try extension } + if Ystar < F^[L] then + begin + for J := Lbound to Ubound do + P2star^[J] := 3.0 * Pstar^[J] - 2.0 * Pbar^[J]; + Y2star := Func(P2star); + + { Retain extension or contraction } + if Y2star < F^[L] then + UpdateSimplex(Y2star, P2star) + else + UpdateSimplex(Ystar, Pstar); + end + else + begin + I := Lbound; + Flag := False; + repeat + if (I <> H) and (F^[I] > Ystar) then Flag := True; + Inc(I); + until Flag or (I > M); + if Flag then + UpdateSimplex(Ystar, Pstar) + else + begin + { Contraction on the reflection side of the centroid } + if Ystar <= F^[H] then + UpdateSimplex(Ystar, Pstar); + + { Contraction on the opposite side of the centroid } + for J := Lbound to Ubound do + P2star^[J] := 0.5 * (P^[H]^[J] + Pbar^[J]); + Y2star := Func(P2star); + if Y2star <= F^[H] then + UpdateSimplex(Y2star, P2star) + else + { Contract whole simplex } + for I := Lbound to M do + for J := Lbound to Ubound do + P^[I]^[J] := 0.5 * (P^[I]^[J] + P^[L]^[J]); + end; + end; + + { Test convergence } + MaxCorr := 0.0; + for J := Lbound to Ubound do + begin + Corr := Abs(P^[H]^[J] - P^[L]^[J]); + if Corr > MaxCorr then MaxCorr := Corr; + end; + Inc(Iter); + until (MaxCorr < Tol) or (Iter > MaxIter); + + CopyVector(X, P^[L], Lbound, Ubound); + F_min := F^[L]; + + DelMatrix(P, M, Ubound); + DelVector(F, M); + DelVector(Pbar, Ubound); + DelVector(Pstar, Ubound); + DelVector(P2star, Ubound); + + if WriteLogFile then + Close(LogFile); + + if Iter > MaxIter then + Simplex := OPT_NON_CONV + else + Simplex := OPT_OK; + end; + + {$F+} + function F1dim(R : Float) : Float; +{ ---------------------------------------------------------------------- + Function used by LinMin to find the minimum of the objective function + LinObjFunc in the direction specified by the global variables X1 and + DeltaX1. R is the step in this direction. + ---------------------------------------------------------------------- } + const + Xt : PVector = nil; + var + I : Integer; + begin + if Xt = nil then + DimVector(Xt, Ubound1); + for I := Lbound1 to Ubound1 do + Xt^[I] := X1^[I] + R * DeltaX1^[I]; + F1dim := LinObjFunc(Xt); + end; + {$F-} + + function LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + var + I, ErrCode : Integer; + R : Float; + begin + { Redimension global vectors } + DelVector(X1, Ubound1); + DelVector(DeltaX1, Ubound1); + DimVector(X1, Ubound); + DimVector(DeltaX1, Ubound); + + Lbound1 := Lbound; + Ubound1 := Ubound; + + { Initialize global variables } + LinObjFunc := Func; + for I := Lbound to Ubound do + begin + X1^[I] := X^[I]; + DeltaX1^[I] := DeltaX^[I] + end; + + { Perform golden search } + ErrCode := GoldSearch({$IFDEF FPK}@{$ENDIF}F1dim, + 0.0, 1.0, MaxIter, Tol, R, F_min); + + { Update variables } + if ErrCode = OPT_OK then + for I := Lbound to Ubound do + X^[I] := X^[I] + R * DeltaX^[I]; + + LinMin := ErrCode; + end; + + {$F+} + procedure NumGradient(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); + var + Temp, Delta, Fplus, Fminus : Float; + I : Integer; + begin + for I := Lbound to Ubound do + begin + Temp := X^[I]; + if Temp <> 0.0 then Delta := Eps * Abs(Temp) else Delta := Eps; + X^[I] := Temp - Delta; + Fminus := Func(X); + X^[I] := Temp + Delta; + Fplus := Func(X); + G^[I] := (Fplus - Fminus) / (2.0 * Delta); + X^[I] := Temp; + end; + end; + {$F-} + + {$F+} + procedure NumHessGrad(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); + var + Delta, Xminus, Xplus, Fminus, Fplus : PVector; + Temp1, Temp2, F, F2plus : Float; + I, J : Integer; + begin + DimVector(Delta, Ubound); { Increments } + DimVector(Xminus, Ubound); { X - Delta } + DimVector(Xplus, Ubound); { X + Delta } + DimVector(Fminus, Ubound); { F(X - Delta) } + DimVector(Fplus, Ubound); { F(X + Delta) } + + F := Func(X); + + for I := Lbound to Ubound do + begin + if X^[I] <> 0.0 then + Delta^[I] := Eps * Abs(X^[I]) + else + Delta^[I] := Eps; + Xplus^[I] := X^[I] + Delta^[I]; + Xminus^[I] := X^[I] - Delta^[I]; + end; + + for I := Lbound to Ubound do + begin + Temp1 := X^[I]; + X^[I] := Xminus^[I]; + Fminus^[I] := Func(X); + X^[I] := Xplus^[I]; + Fplus^[I] := Func(X); + X^[I] := Temp1; + end; + + for I := Lbound to Ubound do + begin + G^[I] := (Fplus^[I] - Fminus^[I]) / (2.0 * Delta^[I]); + H^[I]^[I] := (Fplus^[I] + Fminus^[I] - 2.0 * F) / Sqr(Delta^[I]); + end; + + for I := Lbound to Pred(Ubound) do + begin + Temp1 := X^[I]; + X^[I] := Xplus^[I]; + for J := Succ(I) to Ubound do + begin + Temp2 := X^[J]; + X^[J] := Xplus^[J]; + F2plus := Func(X); + H^[I]^[J] := (F2plus - Fplus^[I] - Fplus^[J] + F) / (Delta^[I] * Delta^[J]); + H^[J]^[I] := H^[I]^[J]; + X^[J] := Temp2; + end; + X^[I] := Temp1; + end; + + DelVector(Delta, Ubound); + DelVector(Xminus, Ubound); + DelVector(Xplus, Ubound); + DelVector(Fminus, Ubound); + DelVector(Fplus, Ubound); + end; + {$F-} + + function ParamConv(OldX, X : PVector; + Lbound, Ubound : Integer; + Tol : Float) : Boolean; +{ ---------------------------------------------------------------------- + Check for convergence on parameters + ---------------------------------------------------------------------- } + var + I : Integer; + Conv : Boolean; + begin + I := Lbound; + Conv := True; + repeat + Conv := Conv and (Abs(X^[I] - OldX^[I]) < FMax(Tol, Tol * Abs(OldX^[I]))); + Inc(I); + until (Conv = False) or (I > Ubound); + ParamConv := Conv; + end; + + function Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; + const + LAMBDA0 = 1.0E-2; { Initial lambda value } + LAMBDAMAX = 1.0E+3; { Highest lambda value } + FTOL = 1.0E-10; { Tolerance on function decrease } + var + Lambda, + Lambda1 : Float; { Marquardt's lambda } + I : Integer; { Loop variable } + OldX : PVector; { Old parameters } + G : PVector; { Gradient vector } + H : PMatrix; { Hessian matrix } + A : PMatrix; { Modified Hessian matrix } + DeltaX : PVector; { New search direction } + F1 : Float; { New minimum } + Lambda_Ok : Boolean; { Successful Lambda decrease } + Conv : Boolean; { Convergence reached } + Done : Boolean; { Iterations done } + Iter : Integer; { Iteration count } + ErrCode : Integer; { Error code } + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'Marquardt'); + WriteLn(LogFile, 'Iter F Lambda'); + end; + + Lambda := LAMBDA0; + ErrCode := OPT_OK; + + DimVector(OldX, Ubound); + DimVector(G, Ubound); + DimMatrix(H, Ubound, Ubound); + DimMatrix(A, Ubound, Ubound); + DimVector(DeltaX, Ubound); + + F_min := Func(X); { Initial function value } + LinObjFunc := Func; { Function for line minimization } + + Iter := 1; + Conv := False; + Done := False; + + repeat + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12, ' ', Lambda:12); + + { Save current parameters } + CopyVector(OldX, X, Lbound, Ubound); + + { Compute Gradient and Hessian } + HessGrad(Func, X, Lbound, Ubound, G, H); + CopyMatrix(A, H, Lbound, Lbound, Ubound, Ubound); + + { Change sign of gradient } + for I := Lbound to Ubound do + G^[I] := - G^[I]; + + if Conv then { Newton-Raphson iteration } + begin + ErrCode := GaussJordan(A, G, Lbound, Ubound, H_inv, DeltaX); + if ErrCode = MAT_OK then + for I := Lbound to Ubound do + X^[I] := OldX^[I] + DeltaX^[I]; + Done := True; + end + else { Marquardt iteration } + begin + repeat + { Multiply each diagonal term of H by (1 + Lambda) } + Lambda1 := 1.0 + Lambda; + for I := Lbound to Ubound do + A^[I]^[I] := Lambda1 * H^[I]^[I]; + + ErrCode := GaussJordan(A, G, Lbound, Ubound, H_inv, DeltaX); + + if ErrCode = MAT_OK then + begin + { Initialize parameters } + CopyVector(X, OldX, Lbound, Ubound); + + { Minimize in the direction specified by DeltaX } + ErrCode := LinMin(Func, X, DeltaX, + Lbound, Ubound, 100, 0.01, F1); + + { Check that the function has decreased. Otherwise + increase Lambda, without exceeding LAMBDAMAX } + Lambda_Ok := (F1 - F_min) < F_min * FTOL; + if not Lambda_Ok then Lambda := 10.0 * Lambda; + if Lambda > LAMBDAMAX then ErrCode := OPT_BIG_LAMBDA; + end; + until Lambda_Ok or (ErrCode <> MAT_OK); + + { Check for convergence } + Conv := ParamConv(OldX, X, Lbound, Ubound, Tol); + + { Prepare next iteration } + Lambda := 0.1 * Lambda; + F_min := F1; + end; + + Inc(Iter); + if Iter > MaxIter then ErrCode := OPT_NON_CONV; + until Done or (ErrCode <> OPT_OK); + + DelVector(OldX, Ubound); + DelVector(G, Ubound); + DelMatrix(H, Ubound, Ubound); + DelMatrix(A, Ubound, Ubound); + DelVector(DeltaX, Ubound); + + if WriteLogFile then + Close(LogFile); + + if ErrCode = MAT_SINGUL then ErrCode := OPT_SING; + Marquardt := ErrCode; + end; + + function BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; + var + I, J, Iter, ErrCode : Integer; + DeltaXmax, Gmax, P1, P2, R1, R2 : Float; + OldX, DeltaX, dX, G, OldG, dG, HdG, R1dX, R2HdG, U, P2U : PVector; + Conv : Boolean; + + function AbsMax(V : PVector; Lbound, Ubound : Integer) : Float; + { Returns the component with maximum absolute value } + var + I : Integer; + AbsV : PVector; + begin + DimVector(AbsV, Ubound); + for I := Lbound to Ubound do + AbsV^[I] := Abs(V^[I]); + AbsMax := Max(AbsV, Lbound, Ubound); + DelVector(AbsV, Ubound); + end; + + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'BFGS'); + WriteLn(LogFile, 'Iter F'); + end; + + DimVector(OldX, Ubound); + DimVector(DeltaX, Ubound); + DimVector(dX, Ubound); + DimVector(G, Ubound); + DimVector(OldG, Ubound); + DimVector(dG, Ubound); + DimVector(HdG, Ubound); + DimVector(R1dX, Ubound); + DimVector(R2HdG, Ubound); + DimVector(U, Ubound); + DimVector(P2U, Ubound); + + Iter := 0; + Conv := False; + LinObjFunc := Func; { Function for line minimization } + + { Initialize function } + F_min := Func(X); + + { Initialize inverse hessian to unit matrix } + for I := Lbound to Ubound do + for J := Lbound to Ubound do + if I = J then H_inv^[I]^[J] := 1.0 else H_inv^[I]^[J] := 0.0; + + { Initialize gradient } + Gradient(Func, X, Lbound, Ubound, G); + Gmax := AbsMax(G, Lbound, Ubound); + + { Initialize search direction } + if Gmax > MACHEP then + for I := Lbound to Ubound do + DeltaX^[I] := - G^[I] + else + Conv := True; { Quit if gradient is already small } + + while (not Conv) and (Iter < MaxIter) do + begin + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12); + + { Normalize search direction to avoid excessive displacements } + DeltaXmax := AbsMax(DeltaX, Lbound, Ubound); + if DeltaXmax > 1.0 then + for I := Lbound to Ubound do + DeltaX^[I] := DeltaX^[I] / DeltaXmax; + + { Save old parameters and gradient } + CopyVector(OldX, X, Lbound, Ubound); + CopyVector(OldG, G, Lbound, Ubound); + + { Minimize along the direction specified by DeltaX } + ErrCode := LinMin(Func, X, DeltaX, Lbound, Ubound, 100, 0.01, F_min); + + { Compute new gradient } + Gradient(Func, X, Lbound, Ubound, G); + + { Compute differences between two successive + estimations of parameter vector and gradient vector } + for I := Lbound to Ubound do + begin + dX^[I] := X^[I] - OldX^[I]; + dG^[I] := G^[I] - OldG^[I]; + end; + + { Multiply by inverse hessian } + for I := Lbound to Ubound do + begin + HdG^[I] := 0.0; + for J := Lbound to Ubound do + HdG^[I] := HdG^[I] + H_inv^[I]^[J] * dG^[J]; + end; + + { Scalar products in denominator of BFGS formula } + P1 := 0.0; P2 := 0.0; + for I := Lbound to Ubound do + begin + P1 := P1 + dX^[I] * dG^[I]; + P2 := P2 + dG^[I] * HdG^[I]; + end; + + if (P1 = 0.0) or (P2 = 0.0) then + Conv := True + else + begin + { Inverses of scalar products } + R1 := 1.0 / P1; R2 := 1.0 / P2; + + { Compute BFGS correction terms } + for I := Lbound to Ubound do + begin + R1dX^[I] := R1 * dX^[I]; + R2HdG^[I] := R2 * HdG^[I]; + U^[I] := R1dX^[I] - R2HdG^[I]; + P2U^[I] := P2 * U^[I]; + end; + + { Update inverse hessian } + for I := Lbound to Ubound do + for J := Lbound to Ubound do + H_inv^[I]^[J] := H_inv^[I]^[J] + R1dX^[I] * dX^[J] + - R2HdG^[I] * HdG^[J] + P2U^[I] * U^[J]; + + { Update search direction } + for I := Lbound to Ubound do + begin + DeltaX^[I] := 0.0; + for J := Lbound to Ubound do + DeltaX^[I] := DeltaX^[I] - H_inv^[I]^[J] * G^[J]; + end; + + { Test convergence and update iteration count } + Conv := ParamConv(OldX, X, Lbound, Ubound, Tol); + Inc(Iter); + end; + end; + + DelVector(OldX, Ubound); + DelVector(DeltaX, Ubound); + DelVector(dX, Ubound); + DelVector(G, Ubound); + DelVector(OldG, Ubound); + DelVector(dG, Ubound); + DelVector(HdG, Ubound); + DelVector(R1dX, Ubound); + DelVector(R2HdG, Ubound); + DelVector(U, Ubound); + DelVector(P2U, Ubound); + + if WriteLogFile then + Close(LogFile); + + if Iter > MaxIter then + BFGS := OPT_NON_CONV + else + BFGS := OPT_OK; + end; + +begin + X1 := nil; + DeltaX1 := nil; + Ubound1 := 1; + Eps := Power(MACHEP, 0.333); +end. diff --git a/npm/dmath/pastring.pas b/npm/dmath/pastring.pas new file mode 100755 index 0000000..97881ab --- /dev/null +++ b/npm/dmath/pastring.pas @@ -0,0 +1,275 @@ +{ ********************************************************************** + * Unit PASTRING.PAS * + * Version 1.8 * + * (c) J. Debord, December 2000 * + ********************************************************************** + Turbo Pascal string routines + ********************************************************************** } + +unit PaString; + +interface + +uses + FMath, FComp, Matrices; + +{ *** Global variables controlling the appearance of a numeric string ** } + +const + NumLength : Integer = 10; { Length of a numeric field } + MaxDec : Integer = 4; { Max. number of decimal places } + FloatPoint : Boolean = False; { Floating point notation } + NSZero : Boolean = True; { Write non significant zero's } + +{ ************************** String routines *************************** } + +function LTrim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes leading blanks + ---------------------------------------------------------------------- } + +function RTrim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes trailing blanks + ---------------------------------------------------------------------- } + +function Trim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes leading and trailing blanks + ---------------------------------------------------------------------- } + +function StrChar(N : Byte; C : Char) : String; +{ ---------------------------------------------------------------------- + Returns a string made of character C repeated N times + ---------------------------------------------------------------------- } + +function RFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with trailing blanks for a total length L + ---------------------------------------------------------------------- } + +function LFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with leading blanks for a total length L + ---------------------------------------------------------------------- } + +function CFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with leading blanks + to center the string on a total length L + ---------------------------------------------------------------------- } + +function Replace(S : String; C1, C2 : Char) : String; +{ ---------------------------------------------------------------------- + Replaces in string S all the occurences + of character C1 by character C2 + ---------------------------------------------------------------------- } + +function Extract(S : String; var Index : Byte; Delim : Char) : String; +{ ---------------------------------------------------------------------- + Extracts a field from a string. Index is the position of the first + character of the field. Delim is the character used to separate + fields (e.g. blank, comma or tabulation). Blanks immediately + following Delim are ignored. Index is updated to the position of + the next field. + ---------------------------------------------------------------------- } + +procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); +{ ---------------------------------------------------------------------- + Parses a string into its constitutive fields. Delim is the field + separator. The number of fields is returned in N. The fields are + returned in Field^[0]..Field^[N - 1]. Field must be dimensioned in + the calling program. + ---------------------------------------------------------------------- } + +function FloatToStr(X : Float) : String; +{ ---------------------------------------------------------------------- + Converts a real to a string according to the values of the global + variables NumLength, MaxDec, FloatPoint and NSZero + ---------------------------------------------------------------------- } + +function IntToStr(N : LongInt) : String; +{ ---------------------------------------------------------------------- + Converts an integer to a string according to the values of the global + variables NumLength and MaxDec. + ---------------------------------------------------------------------- } + +function CompToStr(Z : Complex) : String; +{ ---------------------------------------------------------------------- + Converts a complex number to a string. + ---------------------------------------------------------------------- } + +implementation + + function LTrim(S : String) : String; + begin + if S <> '' then + repeat + if S[1] = ' ' then Delete(S, 1, 1); + until S[1] <> ' '; + LTrim := S; + end; + + function RTrim(S : String) : String; + var + L1 : Byte; + begin + if S <> '' then + repeat + L1 := Length(S); + if S[L1] = ' ' then Delete(S, L1, 1); + until S[L1] <> ' '; + RTrim := S; + end; + + function Trim(S : String) : String; + begin + Trim := LTrim(RTrim(S)); + end; + + function StrChar(N : Byte; C : Char) : String; + var + I : Byte; + S : String; + begin + S := ''; + for I := 1 to N do + S := S + C; + StrChar := S; + end; + + function RFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + RFill := S + else + RFill := S + StrChar(L - L1, ' '); + end; + + function LFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + LFill := S + else + LFill := StrChar(L - L1, ' ') + S; + end; + + function CFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + CFill := S + else + CFill := StrChar((L - L1) div 2, ' ') + S; + end; + + function Replace(S : String; C1, C2 : Char) : String; + var + S1 : String; + K : Byte; + begin + S1 := S; + K := Pos(C1, S1); + while K > 0 do + begin + S1[K] := C2; + K := Pos(C1, S1); + end; + Replace := S1; + end; + + function Extract(S : String; var Index : Byte; Delim : Char) : String; + var + I, L : Byte; + begin + I := Index; + L := Length(S); + + { Search for Delim } + while (I <= L) and (S[I] <> Delim) do + Inc(I); + + { Extract field } + if I = Index then + Extract := '' + else + Extract := Copy(S, Index, I - Index); + + { Skip blanks after Delim } + repeat + Inc(I); + until (I > L) or (S[I] <> ' '); + + { Update Index } + Index := I; + end; + + procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); + var + I, Index, L : Byte; + begin + I := 0; + Index := 1; + L := Length(S); + repeat + Field^[I] := Extract(S, Index, Delim); + Inc(I); + until Index > L; + N := I; + end; + + function FloatToStr(X : Float) : String; + var + S : String; + C : Char; + L : Byte; + begin + if FloatPoint then + begin + Str(X:Pred(NumLength), S); + S := ' ' + S; + end + else + begin + Str(X:NumLength:MaxDec, S); + if not NSZero then + repeat + L := Length(S); + C := S[L]; + if (C = '0') or (C = '.') then Delete(S, L, 1); + until C <> '0'; + end; + FloatToStr := S; + end; + + function IntToStr(N : LongInt) : String; + var + S : String; + begin + Str(N:(NumLength - MaxDec - 1), S); + IntToStr := S; + end; + + function CompToStr(Z : Complex) : String; + var + S : String; + begin + if Z.Form = Rec then + begin + if Z.Y >= 0.0 then S := ' + ' else S := ' - '; + CompToStr := FloatToStr(Z.X) + S + FloatToStr(Abs(Z.Y)) + ' * i'; + end + else + CompToStr := FloatToStr(Z.R) + ' * Exp(' + FloatToStr(Z.Theta) + ' * i)'; + end; + +end. + diff --git a/npm/dmath/plot.inc b/npm/dmath/plot.inc new file mode 100755 index 0000000..ef9e6a8 --- /dev/null +++ b/npm/dmath/plot.inc @@ -0,0 +1,94 @@ +{ ********************************************************************** + * PLOT.INC * + ********************************************************************** + Variables and routines common to PLOT.PAS and WINPLOT.PAS + ********************************************************************** } + +var + XminPixel, YminPixel : Integer; { Pixel coord. of upper left corner } + XmaxPixel, YmaxPixel : Integer; { Pixel coord. of lower right corner } + FactX, FactY : Float; { Scaling factors } + + function Xpixel(X : Float) : Integer; + var + P : Float; + begin + P := FactX * (X - XAxis.Min); + if Abs(P) > 30000 then + Xpixel := 30000 + else + Xpixel := Round(P) + XminPixel; + end; + + function Ypixel(Y : Float) : Integer; + var + P : Float; + begin + P := FactY * (YAxis.Max - Y); + if Abs(P) > 30000 then + Ypixel := 30000 + else + Ypixel := Round(P) + YminPixel; + end; + + function Xuser(X : Integer) : Float; + begin + Xuser := XAxis.Min + (X - XminPixel) / FactX; + end; + + function Yuser(Y : Integer) : Float; + begin + Yuser := YAxis.Max - (Y - YminPixel) / FactY; + end; + + procedure Interval(X1, X2 : Float; MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); + var + H, R, K : Float; + begin + if X1 >= X2 then Exit; + H := X2 - X1; + R := Int(Log10(H)); + if H < 1.0 then R := R - 1.0; + Step := Exp10(R); + + repeat + K := Int(H / Step); + if K < MinDiv then Step := 0.5 * Step; + if K > MaxDiv then Step := 2.0 * Step; + until (K >= MinDiv) and (K <= MaxDiv); + + Min := Step * Int(X1 / Step); + Max := Step * Int(X2 / Step); + while Min > X1 do Min := Min - Step; + while Max < X2 do Max := Max + Step; + end; + + procedure AutoScale(Z : PVector; Lbound, Ubound : Integer; + var Axis : TAxis); + var + I : Integer; + Zmin, Zmax, Z1, Z2 : Float; + begin + if Axis.Scale = LIN_SCALE then + Interval(Min(Z, Lbound, Ubound), Max(Z, Lbound, Ubound), + 2, 6, Axis.Min, Axis.Max, Axis.Step) + else + begin + Zmin := MAXNUM; Zmax := 0.0; + for I := Lbound to Ubound do + if Z^[I] > 0.0 then + if Z^[I] < Zmin then + Zmin := Z^[I] + else if Z^[I] > Zmax then + Zmax := Z^[I]; + Z1 := Int(Log10(Zmin)); + Z2 := Int(Log10(Zmax)); + if Zmin < 1.0 then Z1 := Z1 - 1.0; + if Zmax > 1.0 then Z2 := Z2 + 1.0; + Axis.Min := Z1; + Axis.Max := Z2; + Axis.Step := 1.0; + end; + end; + diff --git a/npm/dmath/plot.pas b/npm/dmath/plot.pas new file mode 100755 index 0000000..d0357e1 --- /dev/null +++ b/npm/dmath/plot.pas @@ -0,0 +1,473 @@ +{ ********************************************************************** + * Unit PLOT.PAS * + * Version 1.7 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Plotting routines for Turbo Pascal + ********************************************************************** } + +unit Plot; + +interface + +uses + Graph, FMath, Matrices, PaString; + +const + BGIPath : String = 'C:\BP\BGI'; { Access path for graphic drivers } + DefSymbSize : Integer = 3; { Default symbol size } + + +{ ********************** Include global variables ********************** } + + {$I PLOTVAR.INC} + +{ ************************** Graphic routines ************************** } + +function GraphOk : Boolean; +{ ---------------------------------------------------------------------- + Initializes high resolution graphics and plots the axes + ---------------------------------------------------------------------- } + +procedure PlotGrid; +{ ---------------------------------------------------------------------- + Plots a grid on the graph + ---------------------------------------------------------------------- } + +procedure WriteLegend(NCurv : Integer); +{ ---------------------------------------------------------------------- + Writes the graph title and the legends for the plotted curves + Input parameter : NCurv = number of curves (1 to MAXCURV) + ---------------------------------------------------------------------- } + +procedure SetClipping(Clip : Boolean); +{ ---------------------------------------------------------------------- + Determines whether drawings are clipped at the current viewport + boundaries, according to the value of the Boolean parameter Clip + ---------------------------------------------------------------------- } + +procedure PlotPoint(Xp, Yp, Symbol, Size, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a point on the screen + ---------------------------------------------------------------------- + Input parameters : Xp, Yp : point coordinates in pixels + Symbol : 0 = point (.) + 1 = solid circle 2 = open circle + 3 = solid square 4 = open square + 5 = solid triangle 6 = open triangle + 7 = plus (+) 8 = multiply (x) + 9 = star (*) + Size : symbol size + Trace : type of line between points + 0 = none + 1 = solid + 2 = dotted + 3 = centered + 4 = dashed + ---------------------------------------------------------------------- } + +procedure PlotCurve(X, Y : PVector; Lbound, Ubound, Symbol, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a curve + ---------------------------------------------------------------------- + Input parameters : X, Y = point coordinates + Lbound, Ubound = indices of first and last points + Symbol, Trace = as in PlotPoint + ---------------------------------------------------------------------- } + +procedure PlotCurveWithErrorBars(X, Y, S : PVector; + Lbound, Ubound, Symbol, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a curve with error bars + ---------------------------------------------------------------------- + Input parameters : X, Y = point coordinates + S = errors (standard deviations) + Lbound, Ubound = indices of first and last points + Symbol, Trace = as in PlotPoint + ---------------------------------------------------------------------- } + +procedure PlotFunc(Func : TFunc; X1, X2 : Float; Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a function + ---------------------------------------------------------------------- + Input parameters : Func = function to be plotted + X1, X2 = abscissae of 1st and last point to plot + Trace = as in PlotPoint + ---------------------------------------------------------------------- + The function must be programmed as : function Func(X : Float) : Float; + ---------------------------------------------------------------------- } + +{ *********** The following routines are defined in PLOT.INC *********** } + +procedure Interval(X1, X2 : Float; MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); +{ ---------------------------------------------------------------------- + Determines an interval [Min, Max] including the values from X1 to X2, + and a subdivision Step of this interval + ---------------------------------------------------------------------- + Input parameters : X1, X2 = min. & max. values to be included + MinDiv = minimum nb of subdivisions + MaxDiv = maximum nb of subdivisions + ---------------------------------------------------------------------- + Output parameters : Min, Max, Step + ---------------------------------------------------------------------- } + +procedure AutoScale(Z : PVector; Lbound, Ubound : Integer; + var Axis : TAxis); +{ ---------------------------------------------------------------------- + Determines the scale of an axis + ---------------------------------------------------------------------- + Input parameters : Z = array of values to be plotted + Lbound, + Ubound = indices of first and last elements of Z + ---------------------------------------------------------------------- + Output parameters : Axis + ---------------------------------------------------------------------- } + +function Xpixel(X : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user abscissa X to screen coordinate + ---------------------------------------------------------------------- } + +function Ypixel(Y : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user ordinate Y to screen coordinate + ---------------------------------------------------------------------- } + +function Xuser(X : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate X to user abscissa + ---------------------------------------------------------------------- } + +function Yuser(Y : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate Y to user ordinate + ---------------------------------------------------------------------- } + +implementation + +{ ---------------------------------------------------------------------- + Include the variables and routines common to PLOT.PAS and WINPLOT.PAS + ---------------------------------------------------------------------- } + + {$I PLOT.INC} + +{ ---------------------------------------------------------------------- } + + procedure PlotXAxis; + var + W, X, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + Line(XminPixel, YmaxPixel, XmaxPixel, YmaxPixel); + SetTextStyle(XTitle.Font, HorizDir, 1); + SetUserCharSize(XTitle.CharWidth, 100, XTitle.CharHeight, 100); + SetTextJustify(CenterText, TopText); + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + X := XAxis.Min; { Tick mark position } + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + MoveTo(Xpixel(X), YmaxPixel); + LineRel(0, 5); { Plot tick mark } + if XAxis.Scale = LIN_SCALE then Z := X else Z := Exp10(X); + OutText(Trim(FloatToStr(Z))); + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do { Plot minor divisions } + begin { on logarithmic scale } + W := X + Log10(J); + MoveTo(Xpixel(W), YmaxPixel); + LineRel(0, 3); + end; + X := X + XAxis.Step; + end; + if XTitle.Text <> '' then { Plot axis title } + OutTextXY((XminPixel + XmaxPixel) div 2, + YmaxPixel + GetMaxY div 12, XTitle.Text); + NSZero := NSZ; + end; + + procedure PlotYAxis; + var + W, Y, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + Line(XminPixel, YminPixel, XminPixel, YmaxPixel); + SetTextStyle(YTitle.Font, HorizDir, 1); + SetUserCharSize(YTitle.CharWidth, 100, YTitle.CharHeight, 100); + SetTextJustify(RightText, CenterText); + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); + Y := YAxis.Min; + NSZ := NSZero; + NSZero := False; + for I := 0 to N do + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + MoveTo(XminPixel, Ypixel(Y)); + LineRel(- 5, 0); + MoveRel(- 2, - 2); + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + OutText(Trim(FloatToStr(Z))); + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + MoveTo(XminPixel, Ypixel(W)); + LineRel(- 3, 0); + end; + Y := Y + YAxis.Step; + end; + if YTitle.Text <> '' then + begin + SetTextStyle(YTitle.Font, VertDir, 1); + SetUserCharSize(YTitle.CharWidth, 100, YTitle.CharHeight, 100); + OutTextXY(XminPixel - GetMaxX div 8, + (YminPixel + YmaxPixel) div 2, YTitle.Text); + end; + NSZero := NSZ; + end; + + function GraphOk : Boolean; + var + Pilot, Mode : Integer; + begin + Pilot := Detect; + InitGraph(Pilot, Mode, BGIPath); + if GraphResult <> 0 then + begin + GraphOk := False; + Exit; + end; + GraphOk := True; + XminPixel := Round(Xwin1 / 100 * GetMaxX); + YminPixel := Round(Ywin1 / 100 * GetMaxY); + XmaxPixel := Round(Xwin2 / 100 * GetMaxX); + YmaxPixel := Round(Ywin2 / 100 * GetMaxY); + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); + if GraphBorder then + Rectangle(XminPixel, YminPixel, XmaxPixel, YmaxPixel); + PlotXAxis; + PlotYAxis; + end; + + procedure PlotGrid; + var + X, Y : Float; + I, N, Xp, Yp : Integer; + begin + SetLineStyle(DottedLn, 0, NormWidth); + if Grid in [HORIZ_GRID, BOTH_GRID] then { Horizontal lines } + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yp := Ypixel(Y); + Line(XminPixel, Yp, XmaxPixel, Yp); + end; + end; + if Grid in [VERTIC_GRID, BOTH_GRID] then { Vertical lines } + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xp := Xpixel(X); + Line(Xp, YminPixel, Xp, YmaxPixel); + end; + end; + SetLineStyle(SolidLn, 0, NormWidth); + end; + + procedure PlotPoint(Xp, Yp, Symbol, Size, Trace : Integer); + var + Xasp, Yasp, Xp1, Xp2, Yp1, Yp2, Dx, Dy : Word; + R : Float; + Triangle : array[1..4] of PointType; + Square : array[1..5] of PointType; + begin + if Trace = 0 then + MoveTo(Xp, Yp) + else + begin + SetLineStyle(Pred(Trace), 0, NormWidth); + LineTo(Xp, Yp); + SetLineStyle(0, 0, 1); + end; + GetAspectRatio(Xasp, Yasp); + R := 0.0001 * Size; + Dx := Round(R * Yasp); + Dy := Round(R * Xasp); + Xp1 := Xp - Size; Xp2 := Xp + Size; + Yp1 := Yp - Size; Yp2 := Yp + Size; + if Symbol in [3, 4] then + begin + Square[1].X := Xp1; Square[1].Y := Yp1; + Square[2].X := Xp1; Square[2].Y := Yp2; + Square[3].X := Xp2; Square[3].Y := Yp2; + Square[4].X := Xp2; Square[4].Y := Yp1; + Square[5].X := Xp1; Square[5].Y := Yp1; + end; + if Symbol in [5, 6] then + begin + Triangle[1].X := Xp; Triangle[1].Y := Yp1; + Triangle[2].X := Xp2; Triangle[2].Y := Yp2; + Triangle[3].X := Xp1; Triangle[3].Y := Yp2; + Triangle[4].X := Xp; Triangle[4].Y := Yp1; + end; + case Symbol of + 0 : PutPixel(Xp, Yp, GetColor); { ù } + 1 : PieSlice(Xp, Yp, 0, 360, Dx); { Solid circle } + 2 : Ellipse(Xp, Yp, 0, 360, Dx, Dy); { Open circle } + 3 : FillPoly(5, Square); { Solid square } + 4 : DrawPoly(5, Square); { Open square } + 5 : FillPoly(4, Triangle); { Solid triangle } + 6 : DrawPoly(4, Triangle); { Open triangle } + 7 : begin { + } + Line(Xp, Yp1, Xp, Yp2); + Line(Xp1, Yp, Xp2, Yp); + end; + 8 : begin { x } + Line(Xp1, Yp1, Xp2, Yp2); + Line(Xp1, Yp2, Xp2, Yp1); + end; + 9 : begin + Line(Xp, Yp1, Xp, Yp2); { * } + Line(Xp1, Yp, Xp2, Yp); + Line(Xp1, Yp1, Xp2, Yp2); + Line(Xp1, Yp2, Xp2, Yp1); + end; + end; + end; + + procedure WriteLegend(NCurv : Integer); + var + I, Xp, Yp, Dy : Integer; + begin + with GraphTitle do + if Text <> '' then + begin + SetTextStyle(Font, HorizDir, 1); + SetUserCharSize(CharWidth, 100, CharHeight, 100); + SetTextJustify(CenterText, TopText); + OutTextXY((XminPixel + XmaxPixel) div 2, + YminPixel - GetMaxY div 10, Text); + end; + with Legend do + begin + SetTextStyle(Font, HorizDir, 1); + SetUserCharSize(CharWidth, 100, CharHeight, 100); + SetTextJustify(LeftText, CenterText); + Dy := (YmaxPixel - YminPixel) div 10; + Xp := XmaxPixel + 30; + Yp := YminPixel + Dy; + for I := 1 to NCurv do + if Text[I] <> '' then + begin + PlotPoint(Xp, Yp, I, SymbolSize, 0); + OutTextXY(Xp + 20, Yp, Text[I]); + Yp := Yp + Dy; + end; + end; + end; + + procedure SetClipping(Clip : Boolean); + begin + if XminPixel = 0 then + begin + XminPixel := Round(Xwin1 / 100 * GetMaxX); + YminPixel := Round(Ywin1 / 100 * GetMaxY); + XmaxPixel := Round(Xwin2 / 100 * GetMaxX); + YmaxPixel := Round(Ywin2 / 100 * GetMaxY); + end; + SetViewPort(XminPixel, YminPixel, XmaxPixel, YmaxPixel, Clip); + XmaxPixel := XmaxPixel - XminPixel; XminPixel := 0; + YmaxPixel := YmaxPixel - YminPixel; YminPixel := 0; + end; + + procedure PlotCurve(X, Y : PVector; + Lbound, Ubound, Symbol, Trace : Integer); + var + XI, YI : Float; + I, NL : Integer; + begin + NL := 0; + for I := Lbound to Ubound do + begin + XI := X^[I]; + if XAxis.Scale = LOG_SCALE then XI := Log10(XI); + YI := Y^[I]; + if YAxis.Scale = LOG_SCALE then YI := Log10(YI); + PlotPoint(Xpixel(XI), Ypixel(YI), Symbol, DefSymbSize, NL); + NL := Trace; + end; + end; + + procedure PlotCurveWithErrorBars(X, Y, S : PVector; + Lbound, Ubound, Symbol, Trace : Integer); + var + XI, YI, Y1, Y2 : Float; + I, NL, Xp, Yp, Yp1, Yp2 : Integer; + begin + NL := 0; + for I := Lbound to Ubound do + begin + XI := X^[I]; + if XAxis.Scale = LOG_SCALE then XI := Log10(XI); + YI := Y^[I]; + if YAxis.Scale = LOG_SCALE then YI := Log10(YI); + Xp := Xpixel(XI); Yp := Ypixel(YI); + PlotPoint(Xp, Yp, Symbol, DefSymbSize, NL); + if S^[I] > 0 then + begin + Y1 := Y^[I] - S^[I]; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Y2 := Y^[I] + S^[I]; + if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Yp1 := Ypixel(Y1); Yp2 := Ypixel(Y2); + Line(Xp - 5, Yp1, Xp + 5, Yp1); + Line(Xp - 5, Yp2, Xp + 5, Yp2); + Line(Xp, Yp1, Xp, Yp2); + end; + NL := Trace; + end; + end; + + procedure PlotFunc(Func : TFunc; X1, X2 : Float; Trace : Integer); + var + X, Y, H : Float; + I, Npt, NL, Xp, Yp : Integer; + begin + NL := 0; { Indicates if a line must be drawn from the previous point } + X := X1; + + { Nb of points to be plotted = number of pixels between X1 and X2 } + Npt := Xpixel(X2) - Xpixel(X1); + + H := (X2 - X1) / Npt; + for I := 0 to Npt do + begin + X := X1 + I * H; + if XAxis.Scale = LIN_SCALE then + Y := Func(X) + else + Y := Func(Exp10(X)); + if MathError <> FN_OK then + NL := 0 + else + begin + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + Xp := Xpixel(X); + Yp := Ypixel(Y); + PlotPoint(Xp, Yp, 0, 0, NL); + NL := Trace; + end; + end; + end; + +end. diff --git a/npm/dmath/plotvar.inc b/npm/dmath/plotvar.inc new file mode 100755 index 0000000..7b3ee09 --- /dev/null +++ b/npm/dmath/plotvar.inc @@ -0,0 +1,93 @@ +{ ********************************************************************** + * PLOTVAR.INC * + ********************************************************************** + Constants, types and global variables + common to PLOT.PAS and TEXPLOT.PAS + ********************************************************************** } + +const + MAXSYMBOL = 9; { Max. number of graphic symbols } + EPS = 1.0E-10; { Lower limit for an axis label } + +type + TScale = (LIN_SCALE, { Scale } + LOG_SCALE); + + TGrid = (NO_GRID, { Grid } + HORIZ_GRID, + VERTIC_GRID, + BOTH_GRID); + + TAxis = record { Coordinate axis } + Scale : TScale; + Min : Float; + Max : Float; + Step : Float; + end; + + TTitle = record { Title for main graph or axis } + Text : String[70]; + Font : Integer; + CharWidth : Integer; + CharHeight : Integer; + end; + + TLegend = record { Legends of plotted curves } + Text : array[1..MAXSYMBOL] of String[40]; + Font : Integer; + CharWidth : Integer; + CharHeight : Integer; + SymbolSize : Integer; + end; + +{ ******** Global variables defining the appearance of the graph ******* } + +const + Xwin1 : Integer = 15; { Window limits in % } + Ywin1 : Integer = 15; + Xwin2 : Integer = 85; + Ywin2 : Integer = 85; + + GraphBorder : Boolean = True; { Plot graph border } + + XAxis : TAxis = (Scale : LIN_SCALE; { Horizontal axis } + Min : 0.0; + Max : 1.0; + Step : 0.2); + + YAxis : TAxis = (Scale : LIN_SCALE; { Vertical axis } + Min : 0.0; + Max : 1.0; + Step : 0.2); + + Grid : TGrid = NO_GRID; { Grid } + + GraphTitle : TTitle = (Text : ''; { Title of graph } + Font : 2; + CharWidth : 300; + CharHeight : 350); + + XTitle : TTitle = (Text : 'X'; { Title of X axis } + Font : 2; + CharWidth : 200; + CharHeight : 250); + + YTitle : TTitle = (Text : 'Y'; { Title of Y axis } + Font : 2; + CharWidth : 200; + CharHeight : 250); + + Legend : TLegend = (Text : ('A', { Legends of curves } + 'B', + 'C', + 'D', + 'E', + 'F', + 'G', + 'H', + 'I'); + Font : 2; + CharWidth : 50; + CharHeight : 50; + SymbolSize : 3); + diff --git a/npm/dmath/polynom.pas b/npm/dmath/polynom.pas new file mode 100755 index 0000000..87009e3 --- /dev/null +++ b/npm/dmath/polynom.pas @@ -0,0 +1,194 @@ +{ ********************************************************************** + * Unit POLYNOM.PAS * + * Version 1.3 * + * (c) J. Debord, January 1998 * + ********************************************************************** + This unit implements routines for polynomials and rational fractions. + ********************************************************************** + Reference: 'Numerical Recipes' by Press et al. + ********************************************************************** } + +unit Polynom; + +interface + +uses + FMath, Matrices, Eigen, Stat; + +function Poly(X : Float; Coef : PVector; Deg : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates the polynomial : + P(X) = Coef[0] + Coef[1] * X + Coef[2] * X^2 +...+ Coef[Deg] * X^Deg + ---------------------------------------------------------------------- } + +function RRootPol(Coef : PVector; Deg : Integer; X : PVector) : Integer; +{ ---------------------------------------------------------------------- + Real roots of a polynomial. The roots are computed analytically if + Deg <= 3, otherwise they are computed numerically from the eigenvalues + of the companion matrix (function RootPol in EIGEN.PAS). The roots are + returned in X (in increasing order). The function returns the number + of real roots found. + ---------------------------------------------------------------------- } + +function CRootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Complex roots of a polynomial. The roots are computed numerically + from the eigenvalues of the companion matrix (function RootPol in + EIGEN.PAS). The real and imaginary parts of the roots are returned + in X_Re and X_Im (in increasing order of the real parts). The function + returns the number of roots found, which may be Deg or zero if the + method did not converge. + ---------------------------------------------------------------------- } + +function RFrac(X : Float; Coef : PVector; Deg1, Deg2 : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates the rational fraction : + + Coef[0] + Coef[1] * X + ... + Coef[Deg1] * X^Deg1 + F(X) = ----------------------------------------------------- + 1 + Coef[Deg1+1] * X + ... + Coef[Deg1+Deg2] * X^Deg2 + ---------------------------------------------------------------------- } + +implementation + +const + MAXDEG = 3; { Maximal degree for analytical solution of polynomial } + + function Poly(X : Float; Coef : PVector; Deg : Integer) : Float; + var + I : Integer; + Y : Float; + begin + Y := Coef^[Deg]; + for I := Pred(Deg) downto 0 do + Y := Y * X + Coef^[I]; + Poly := Y; + end; + + function RFrac(X : Float; Coef : PVector; Deg1, Deg2 : Integer) : Float; + var + I : Integer; + Sum : Float; { Denominator sum } + begin + Sum := 0.0; + for I := (Deg1 + Deg2) downto Succ(Deg1) do + Sum := (Sum + Coef^[I]) * X; + RFrac := Poly(X, Coef, Deg1) / (1.0 + Sum); + end; + + function RootPol3(Coef : PVector; Deg : Integer; X : PVector) : Integer; + { Real roots of polynomial up to degree 3 (Analytical solution) } + const + PI2DIV3 = 2.0943951023931954923; { 2*pi/3 } + var + NR : Integer; { Number of roots } + R, R2, Q, Q3, Delta, A0, A1, A2, A22, A3, AA, BB, Theta, Z : Float; + begin + if (Deg < 1) or (Deg > MAXDEG) then + begin + RootPol3 := 0; + Exit; + end; + case Deg of + 1 : begin + NR := 1; + X^[1] := - Coef^[0] / Coef^[1]; + end; + 2 : begin + Delta := Sqr(Coef^[1]) - 4.0 * Coef^[0] * Coef^[2]; + if Delta < 0 then + NR := 0 + else + begin + NR := 2; + if Coef^[1] >= 0 then + Q := - 0.5 * (Coef^[1] + Sqrt(Delta)) + else + Q := - 0.5 * (Coef^[1] - Sqrt(Delta)); + X^[1] := Q / Coef^[2]; + X^[2] := Coef^[0] / Q; + end; + end; + 3 : begin + A0 := Coef^[0] / Coef^[3]; + A1 := Coef^[1] / Coef^[3]; + A2 := Coef^[2] / Coef^[3]; + A3 := A2 / 3.0; + A22 := Sqr(A2); + Q := (A22 - 3.0 * A1) / 9.0; + R := (A2 * (2.0 * A22 - 9.0 * A1) + 27.0 * A0) / 54.0; + R2 := R * R; + Q3 := Q * Q * Q; + Delta := Q3 - R2; + if Delta < 0 then + begin + NR := 1; + AA := Power(Abs(R) + Sqrt(- Delta), 0.333333333333333); + if R >= 0 then AA := - AA; + if AA <> 0 then BB := Q / AA else BB := 0.0; + X^[1] := (AA + BB) - A3; + end + else + begin + NR := 3; + Theta := ArcCos(R / Sqrt(Q3)) / 3.0; + Z := - 2.0 * Sqrt(Q); + X^[1] := Z * Cos(Theta) - A3; + X^[2] := Z * Cos(Theta + PI2DIV3) - A3; + X^[3] := Z * Cos(Theta - PI2DIV3) - A3; + end; + end; + end; + QSort(X, 1, Deg); + RootPol3 := NR; + end; + + function RRootPol(Coef : PVector; Deg : Integer; X : PVector) : Integer; + var + N : Integer; { Number of real roots } + X_Re, X_Im : PVector; { Real and imaginary parts } + ErrCode : Integer; { Error code } + I : Integer; { Loop variable } + begin + DimVector(X_Re, Deg); + DimVector(X_Im, Deg); + + if Deg <= MAXDEG then + RRootPol := RootPol3(Coef, Deg, X) + else + begin + ErrCode := RootPol(Coef, Deg, X_Re, X_Im); + if ErrCode = MAT_OK then + begin + { Get real roots } + N := 0; + for I := 1 to Deg do + if Abs(X_Im^[I]) <= MACHEP then + begin + Inc(N); + X^[N] := X_Re^[I]; + end; + { Set other roots to zero } + for I := Succ(N) to Deg do + X^[I] := 0.0; + RRootPol := N; + end + else + RRootPol := 0; + end; + + DelVector(X_Re, Deg); + DelVector(X_Im, Deg); + end; + + function CRootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; + begin + if RootPol(Coef, Deg, X_Re, X_Im) = MAT_OK then + CRootPol := Deg + else + CRootPol := 0; + end; + +end. diff --git a/npm/dmath/regmultdelphi.pas b/npm/dmath/regmultdelphi.pas new file mode 100755 index 0000000..b07be2f --- /dev/null +++ b/npm/dmath/regmultdelphi.pas @@ -0,0 +1,518 @@ +{ ********************************************************************** + * Program REGMULT.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This program performs a weighted multiple linear least squares fit : + + y = b0 + b1 * x1 + b2 * x2 + ... + + The following parameters are passed on the command line : + + 1st parameter = name of input file (default extension = .DAT) + 2nd parameter = 1 if the equation includes a constant term b0 + + Input files are ASCII files with the following structure : + + Line 1 : Title of study + Line 2 : Number of variables (must be >= 2 here !) + Next lines : Names of variables x1, x2, ..., y + Next line : Number of observations (must be > number of variables !) + + The next lines contain the coordinates (x1, x2, ..., y) of the + observations (1 observation by line). The coordinates must be + separated by spaces or tabulations. + + The file INHIB.DAT is an example of data relating the inhibition of an + enzyme to the physico-chemical properties of the inhibitors (J. DEBORD, + P. N'DIAYE, J. C. BOLLINGER et al, J. Enzyme Inhib., 1997, 12, 13-26). + The program parameters are : INHIB 1 + + The program may be executed from Turbo Pascal's integrated environment, + in which case the parameters are entered through the "Parameters" option + of the menu, or from DOS (after compilation into an executable file), + in which case the parameters are entered on the command line (e.g. + REGMULT INHIB 1). + ********************************************************************** } + +unit RegMultDelphi; +interface +uses + SysUtils,FMath, Matrices, Regress, Models, PaString,messages,dialogs,classes,define_types; +const +kMaxRA = 127; +kCR = chr (13); +kMaxObs = 100; +kMaxFact = 64; +//type +// TIVra = array [1..kMaxFact,1..kMaxObs] of integer; + {SpaceType = record + mrix,mriy,mriz,fobx,foby,fobz: integer; + end;} +function MultipleRegression (lnObservations,lnFactors: integer; var X: PMatrix; var lImgIntensity: DoubleP0; var lOutT: DoubleP0): boolean; +function MultipleRegressionVec (lnObservations,lnFactors: integer; var X: PMatrix; var Y: PVector; var lOutT,lOutSlope: DoubleP0): boolean; + +//var +// gMRIFOBra: array [1..kMaxRA] of SpaceType; +// gCoregRA: array[1..3,0..3] of double; {MRIx,y,z, Offset,FOBx,FOBy,FOBz} + +implementation +(*var + InFName : String; { Name of input file } + Title : String; { Title of study } + XName : PStrVector; { Names of independent variables } + YName : String; { Name of dependent variable } + N : Integer; { Number of observations } + X : PMatrix; { Matrix of independent variables } + Y : PVector; { Vector of dependent variable } + Z : PVector; { Vector of independent variable (not used here) } + Ycalc : PVector; { Expected Y values } + S : PVector; { Standard deviations of Y values } + CstPar : PVector; { Constant parameters } + B : PVector; { Regression parameters } + B_min, B_max : PVector; { Parameter bounds (not used, but must be + declared in order to use the WLSFit routine ) } + V : PMatrix; { Variance-covariance matrix of regression parameters } + Theta : PVector; { Variance parameters } + RegTest : TRegTest; { Regression tests } + gErrCode : Integer; { Error code } + *) + +(* procedure ReadCmdLine(var InFName : String; var CstPar : PVector); +{ ---------------------------------------------------------------------- + Reads command line parameters. Stores constant parameters in CstPar, + such that : + + CstPar^[0] = Number of independent variables + (this one is set by ReadInputFile) + CstPar^[1] = 1 to include a constant term (b0) + + The contents of CstPar are defined in the unit FITMULT.PAS, + in the subdirectory REG of the TP Math units directory. + ---------------------------------------------------------------------- } + var + I : Integer; + begin + DimVector(CstPar, 1); + + { Name of input file } + InFName := ParamStr(1); + if Pos('.', InFName) = 0 then InFName := InFName + '.dat'; + + { Presence of constant term } + //I := 0; + Val(ParamStr(2), I, gErrCode); + CstPar^[1] := I; + end; + + function ReadInputFile(InFName : String; + var Title : String; + var XName : PStrVector; + var YName : String; + var N : Integer; + var X : PMatrix; + var Y : PVector; + CstPar : PVector) : Integer; + var + InF : Textfile; { Input file } + Nvar : Integer; { Nb of independent variables } + I, K : Integer; { Loop variables } + begin + Assign(InF, InFName); + Reset(InF); + + ReadLn(InF, Title); + ReadLn(InF, Nvar); { Total number of variables } + if Nvar < 2 then + begin + showmessage('Data file must contain at least 2 variables !'); + ReadInputFile := - 1; + Exit; + end; + Nvar := Pred(Nvar); + showmessage('trap3x'+inttostr(NVar)); + DimStrVector(XName, Nvar);{crashes here} + showmessage('trap4x'+inttostr(NVar)); + for I := 1 to Nvar do begin + ReadLn(InF, XName^[I]); + showmessage(XName^[I]); + end; + + ReadLn(InF, YName); + ReadLn(InF, N); + + DimMatrix(X, Nvar, N); + DimVector(Y, N); + + for K := 1 to N do + begin + for I := 1 to Nvar do + Read(InF, X^[I]^[K]); + Read(InF, Y^[K]); + end; + + Close(InF); + CstPar^[0] := Nvar; + ReadInputFile := 0; + end; + + procedure WriteOutputFile(InFName, Title : String; + XName : PStrVector; + YName : String; + N : Integer; + Y, CstPar, Ycalc, S, B : PVector; + V : PMatrix; + Test : TRegTest); + var + OutFName : String; { Name of output file } + OutF : TextFile; { Output file } + Line1, + Line2 : String; { Separating lines } + Nvar : Integer; { Nb of independent variables } + Delta : Float; { Residual } + Sr : Float; { Residual error } + SB : PVector; { Standard deviations of parameters } + T : PVector; { Student's t } + Prob : PVector; { Probabilities } + I, K : Integer; { Loop variables } + begin + Nvar := Round(CstPar^[0]); + + DimVector(SB, LastParam); + DimVector(T, LastParam); + DimVector(Prob, LastParam); + + K := Pos('.', InFName); + OutFName := Copy(InFName, 1, Pred(K)) + '.out'; + Assign(OutF, OutFName); + Rewrite(OutF); + + Line1 := StrChar(73, '-'); + Line2 := StrChar(73, '='); + + WriteLn(OutF, Line2); + WriteLn(OutF, 'Data file : ', InFName); + WriteLn(OutF, 'Study name : ', Title); + for I := 1 to Nvar do + WriteLn(OutF, 'x', I:1, ' : ', XName^[I]); + WriteLn(OutF, 'y : ', YName); + WriteLn(OutF, 'Function : ', FuncName); + + { Perform tests on parameters } + ParamTest(B, V, N, FirstParam, LastParam, SB, T, Prob); + + WriteLn(OutF, Line1); + WriteLn(OutF, 'Parameter Est.value Std.dev. t Student Prob(>|t|)'); + WriteLn(OutF, Line1); + showmessage(inttostr(nVar)+':'+inttostr(FirstParam)+':'+inttostr(LastParam)); + for I := FirstParam to LastParam do + if SB^[I] > 0.0 then + WriteLn(OutF, ParamName(I):5, B^[I]:17:8, SB^[I]:17:8, T^[I]:17:2, Prob^[I]:17:4) + else + WriteLn(OutF, ParamName(I):5, B^[I]:17:8); + + WriteLn(OutF, Line1); + WriteLn(OutF, 'Number of observations : n = ', N:5); + + with Test do + begin + Sr := Sqrt(Vr); + WriteLn(OutF, 'Residual error : s = ', Sr:10:8); + if (R2 >= 0.0) and (R2 <= 1.0) then + WriteLn(OutF, 'Coefficient of determination : r2 = ', R2:10:8); + if (R2a >= 0.0) and (R2a <= 1.0) then + WriteLn(OutF, 'Adjusted coeff. of determination : r2a = ', R2a:10:8); + Write(OutF, 'Variance ratio (explained/resid.) : F = ', F:10:4); + WriteLn(OutF, ' Prob(>F) = ', Prob:6:4); + end; + + WriteLn(OutF, Line1); + WriteLn(OutF, ' i Y obs. Y calc. Residual Std.dev. Std.res.'); + WriteLn(OutF, Line1); + + for K := 1 to N do + begin + Delta := Y^[K] - Ycalc^[K]; + WriteLn(OutF, K:3, Y^[K]:14:4, Ycalc^[K]:14:4, Delta:14:4, S^[K]:14:4, (Delta / S^[K]):14:4); + end; + WriteLn(OutF, Line2); + + Close(OutF); + Showmessage('Results written to file '+OutFName); + + DelVector(SB, LastParam); + DelVector(T, LastParam); + DelVector(Prob, LastParam); + end; + +{ *************************** Main program ***************************** } +procedure RunReg; +begin + { Read command line parameters } + //ReadCmdLine(InFName, CstPar); + InFName := 'C:\inhib.dat'; + DimVector(CstPar, 1); + CstPar^[1] := 1; + { Read input file } + + if ReadInputFile(InFName, Title, XName, YName, N, X, Y, CstPar) <> 0 then + begin + showmessage('Error reading file '+ InFName); + exit; + end; + { Initialize regression and variance models. + See MODELS.PAS in the REG subdirectory for a list of available models } + InitModel(REG_MULT, + VAR_CONST, { Here we use a constant variance } + CstPar); + + { Set the regression algorithm which must be GAUSS_JORDAN or SVD. + The default algorithm is SVD. Comment off the following line if + you wish to change the algorithm. } + + { SetRegAlgo(GAUSS_JORDAN); } + + { Dimension arrays. + Note: the variance parameters Theta^[1]..Theta^[LastVarParam] + must be supplied if we use a non-constant variance model } + DimVector(Theta, LastVarParam); + DimVector(B, LastParam); + DimMatrix(V, LastParam, LastParam); + DimVector(Ycalc, N); + DimVector(S, N); + + { Perform regression. The numbers 1 and 0.1 denote the maximal number + of iterations and the tolerance on the parameters. They are purely + formal values here since the multiple linear regression does not use + an iterative minimization algorithm. } + gErrCode := WLSFit(Z, X, Y, N, True, 1, 0.1, Theta, B, + B_min, B_max, V, Ycalc, S, RegTest); + + { Write results } + case gErrCode of + MAT_OK : WriteOutputFile(InFName, Title, XName, YName, + N, Y, CstPar, Ycalc, S, B, V, RegTest); + MAT_SINGUL : WriteLn('Singular matrix !'); + MAT_NON_CONV : WriteLn('Non-convergence of SVD algorithm !'); + end; +end; + *) + + //ComputeRegress(lnObservations,lnFactors, Y, CstPar, Ycalc, S, B, V, lRegTest); +procedure ComputeRegress (N,lnFactors : Integer; + var Y, CstPar, Ycalc, S, B : PVector; + var V : PMatrix; + var Test : TRegTest; var lOutT: DoubleP0); +var + I: integer; + SB : PVector; { Standard deviations of parameters } + T : PVector; { Student's t } + Prob : PVector; { Probabilities } +begin + DimVector(SB, LastParam); + DimVector(T, LastParam); + DimVector(Prob, LastParam); + { Perform tests on parameters } + ParamTest(B, V, N, FirstParam, LastParam, SB, T, Prob); + for I := 0 to (lnFactors-1) do + lOutT[I] := T^[FirstParam+I+1];//first parameter is global fit + + lOutT[lnFactors] := T^[FirstParam];//global fit + + //for I := FirstParam to LastParam do + // Showmessage(floattostr(T^[I]) ); + DelVector(SB, LastParam); + DelVector(T, LastParam); + DelVector(Prob, LastParam); + +end; + +(* procedure ScreenOutputFile( + var YName : String; + N,ldimension : Integer; + var Y, CstPar, Ycalc, S, B : PVector; + var V : PMatrix; + var Test : TRegTest; + var lDynStr: String); + var + lA,lB,lC,lD : String; { Name of output file } + Nvar : Integer; { Nb of independent variables } + Delta : Float; { Residual } + Sr : Float; { Residual error } + SB : PVector; { Standard deviations of parameters } + T : PVector; { Student's t } + Prob : PVector; { Probabilities } + I, K : Integer; { Loop variables } + begin + Nvar := Round(CstPar^[0]); + + DimVector(SB, LastParam); + DimVector(T, LastParam); + DimVector(Prob, LastParam); + { Perform tests on parameters } + ParamTest(B, V, N, FirstParam, LastParam, SB, T, Prob); + lDynStr:=lDynStr+'|'+( 'Parameter Est.value Std.dev. t Student Prob(>|t|)'); + //showmessage(inttostr(nVar)+':'+inttostr(FirstParam)+':'+inttostr(LastParam)); + for I := FirstParam to LastParam do begin + if SB^[I] > 0.0 then begin + Str(B^[I]:17:8,lA); + Str(SB^[I]:17:8,lB); + Str(T^[I]:17:2,lC); + Str(Prob^[I]:17:4,lD); + lDynStr:=lDynStr+'|'+(ParamName(I)+lA+lB+'T='+lC+lD); + end else begin + B^[I]:= 0; + Str(B^[I]:17:8,lA); + lDynStr:=lDynStr+'|'+(ParamName(I)+lA); + end; + //gCoregRA[lDImension,I]:= B^[I]; + end; + DelVector(SB, LastParam); + DelVector(T, LastParam); + DelVector(Prob, LastParam); + end; *) + + +//function PredictData(lnObservations: integer; var lStr: tstringlist): boolean; +function MultipleRegression (lnObservations,lnFactors: integer; var X: PMatrix; var lImgIntensity: DoubleP0; var lOutT: DoubleP0): boolean; +var + K : Integer; { Nb of independent variables } + //X : PMatrix; { Matrix of independent variables } + Y : PVector; { Vector of dependent variable } + Z : PVector; { Vector of independent variable (not used here) } + Ycalc : PVector; { Expected Y values } + S : PVector; { Standard deviations of Y values } + CstPar : PVector; { Constant parameters } + B : PVector; { Regression parameters } + B_min, B_max : PVector; { Parameter bounds (not used, but must be + declared in order to use the WLSFit routine ) } + V : PMatrix; { Variance-covariance matrix of regression parameters } + Theta : PVector; { Variance parameters } + lRegTest : TRegTest; { Regression tests } + gErrCode : Integer; { Error code } +begin + result := false; + if lnObservations < 5 then begin + showmessage('At least 5 samples required for 3D registration.'); + exit; + end; + DimVector(CstPar, 1); + DimVector(Y, lnObservations); + CstPar^[1] := 1; + CstPar^[0] := lnFactors; + for K := 1 to lnObservations do + Y^[K] := lImgIntensity[K-1]; + { Initialize regression and variance models.} + InitModel(REG_MULT,VAR_CONST,{ Here we use a constant variance }CstPar); + { Set the regression algorithm which must be GAUSS_JORDAN or SVD. + The default algorithm is SVD. Comment off the following line if + you wish to change the algorithm. } + { SetRegAlgo(GAUSS_JORDAN); } + DimVector(Theta, LastVarParam); + DimVector(B, LastParam); + DimMatrix(V, LastParam, LastParam); + DimVector(Ycalc, lnObservations); + DimVector(S, lnObservations); + { Perform regression. The numbers 1 and 0.1 denote the maximal number + of iterations and the tolerance on the parameters. They are purely + formal values here since the multiple linear regression does not use + an iterative minimization algorithm. } + gErrCode := WLSFit(Z, X, Y, lnObservations, True, 1, 0.1, Theta, B,B_min, B_max, V, Ycalc, S, lRegTest); + { Write results } + //showmessage(inttostr(xx)); + case gErrCode of + MAT_OK : begin + //ScreenOutputFile({XName,}YName,lnObservations,lDim, Y, CstPar, Ycalc, S, B, V, lRegTest,lStr); + //Showmessage(lStr); + ComputeRegress(lnObservations,lnFactors, Y, CstPar, Ycalc, S, B, V, lRegTest,lOutT); + end; +{ MAT_OK : WriteOutputFile(InFName, Title, XName, YName, + N, Y, CstPar, Ycalc, S, B, V, RegTest); + } MAT_SINGUL : Showmessage('Singular matrix !'); + MAT_NON_CONV : Showmessage('Non-convergence of SVD algorithm !'); + end; + DelVector(CstPar, 1); + DelVector(Y, lnObservations); + //DelStrVector(XName,lnXFactors); + + DelVector(Theta, LastVarParam); + DelVector(B, LastParam); + DelMatrix(V, LastParam, LastParam); + DelVector(Ycalc, lnObservations); + DelVector(S, lnObservations); + result := true; + +end; + +function MultipleRegressionVec (lnObservations,lnFactors: integer; var X: PMatrix; var Y: PVector; var lOutT,lOutSlope: DoubleP0): boolean; +var + K : Integer; { Nb of independent variables } + Z : PVector; { Vector of independent variable (not used here) } + Ycalc : PVector; { Expected Y values } + S : PVector; { Standard deviations of Y values } + CstPar : PVector; { Constant parameters } + B : PVector; { Regression parameters } + B_min, B_max : PVector; { Parameter bounds (not used, but must be + declared in order to use the WLSFit routine ) } + V : PMatrix; { Variance-covariance matrix of regression parameters } + Theta : PVector; { Variance parameters } + lRegTest : TRegTest; { Regression tests } + gErrCode : Integer; { Error code } +begin + result := false; + if lnObservations < 5 then begin + showmessage('At least 5 samples required for 3D registration.'); + exit; + end; + DimVector(CstPar, 1); + CstPar^[1] := 1; + CstPar^[0] := lnFactors; + { Initialize regression and variance models.} + InitModel(REG_MULT,VAR_CONST,{ Here we use a constant variance }CstPar); + { Set the regression algorithm which must be GAUSS_JORDAN or SVD. + The default algorithm is SVD. Comment off the following line if + you wish to change the algorithm. } + { SetRegAlgo(GAUSS_JORDAN); } + DimVector(Theta, LastVarParam); + DimVector(B, LastParam); + DimMatrix(V, LastParam, LastParam); + DimVector(Ycalc, lnObservations); + DimVector(S, lnObservations); + { Perform regression. The numbers 1 and 0.1 denote the maximal number + of iterations and the tolerance on the parameters. They are purely + formal values here since the multiple linear regression does not use + an iterative minimization algorithm. } + gErrCode := WLSFit(Z, X, Y, lnObservations, True, 1, 0.1, Theta, B,B_min, B_max, V, Ycalc, S, lRegTest); + { Write results } + //showmessage(inttostr(xx)); + case gErrCode of + MAT_OK : begin + //ScreenOutputFile({XName,}YName,lnObservations,lDim, Y, CstPar, Ycalc, S, B, V, lRegTest,lStr); + //Showmessage(lStr); + ComputeRegress(lnObservations,lnFactors, Y, CstPar, Ycalc, S, B, V, lRegTest,lOutT); + end; +{ MAT_OK : WriteOutputFile(InFName, Title, XName, YName, + N, Y, CstPar, Ycalc, S, B, V, RegTest); + } MAT_SINGUL : Showmessage('Singular matrix !'); + MAT_NON_CONV : Showmessage('Non-convergence of SVD algorithm !'); + end; + for K := 0 to (lnFactors-1) do + lOutSlope^[K] := B^[FirstParam+K+1];//first parameter is global fit + + lOutSlope^[lnFactors] := B^[FirstParam];//global fit + + DelVector(CstPar, 1); + //DelVector(Y, lnObservations); + //DelStrVector(XName,lnXFactors); + + DelVector(Theta, LastVarParam); + DelVector(B, LastParam); + DelMatrix(V, LastParam, LastParam); + DelVector(Ycalc, lnObservations); + DelVector(S, lnObservations); + result := true; + +end; + + +end. diff --git a/npm/dmath/simopt.pas b/npm/dmath/simopt.pas new file mode 100755 index 0000000..e7c7168 --- /dev/null +++ b/npm/dmath/simopt.pas @@ -0,0 +1,308 @@ +{ ********************************************************************** + * Unit SIMOPT.PAS * + * Version 1.0 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit implements simulated annealing for function minimization + ********************************************************************** + Reference: Program SIMANN.FOR by Bill Goffe + (http://www.netlib.org/simann) + ********************************************************************** } + +unit SimOpt; + +interface + +uses + FMath, Matrices, Optim, Stat; + +const + SA_Nt : Integer = 5; { Number of loops at constant temperature } + SA_Ns : Integer = 15; { Number of loops before step adjustment } + SA_Rt : Float = 0.9; { Temperature reduction factor } + SA_NCycles : Integer = 1; { Number of cycles } + +function SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by simulated annealing + ---------------------------------------------------------------------- + Input parameters : Func = objective function to be minimized + X = initial minimum coordinates + Xmin = minimum value of X + Xmax = maximum value of X + Lbound, + Ubound = indices of first and last variables + MaxIter = max number of annealing steps + Tol = required precision + ---------------------------------------------------------------------- + Output parameter : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + +var + LogFile : Text; { Stores the result of each minimization step } + + procedure CreateLogFile; + begin + Assign(LogFile, LogFileName); + Rewrite(LogFile); + end; + + function InitTemp(Func : TFuncNVar; + X, Xmin, Range : PVector; + Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Computes the initial temperature so that the probability + of accepting an increase of the function is about 0.5 + ---------------------------------------------------------------------- } + const + N_EVAL = 50; { Number of function evaluations } + var + T : Float; { Temperature } + F, F1 : Float; { Function values } + DeltaF : PVector; { Function increases } + N_inc : Integer; { Number of function increases } + I : Integer; { Index of function evaluation } + K : Integer; { Index of parameter } + begin + DimVector(DeltaF, N_EVAL); + + T := 0.0; + N_inc := 0; + F := Func(X); + + { Compute N_EVAL function values, changing each parameter in turn } + K := Lbound; + for I := 1 to N_EVAL do + begin + X^[K] := Xmin^[K] + RanMar * Range^[K]; + F1 := Func(X); + if F1 > F then + begin + Inc(N_inc); + DeltaF^[N_inc] := F1 - F; + end; + F := F1; + Inc(K); + if K > Ubound then K := Lbound; + end; + + { The median M of these N_eval values has a probability of 1/2. + From Boltzmann's formula: Exp(-M/T) = 1/2 ==> T = M / Ln(2) } + T := Median(DeltaF, 1, N_inc) / LN2; + if T = 0.0 then T := 1.0; + InitTemp := T; + + DelVector(DeltaF, N_EVAL); + end; + + function ParamConv(X, Step : PVector; + Lbound, Ubound : Integer; + Tol : Float) : Boolean; +{ ---------------------------------------------------------------------- + Checks for convergence on parameters + ---------------------------------------------------------------------- } + var + I : Integer; + Conv : Boolean; + begin + I := Lbound; + Conv := True; + repeat + Conv := Conv and (Step^[I] < FMax(Tol, Tol * Abs(X^[I]))); + Inc(I); + until (Conv = False) or (I > Ubound); + ParamConv := Conv; + end; + + function Accept(DeltaF, T : Float; + var N_inc, N_acc : Integer) : Boolean; +{ ---------------------------------------------------------------------- + Checks if a variation DeltaF of the function at temperature T is + acceptable. Updates the counters N_inc (number of increases of the + function) and N_acc (number of accepted increases). + ---------------------------------------------------------------------- } + begin + if DeltaF < 0.0 then + Accept := True + else + begin + Inc(N_inc); + if Expo(- DeltaF / T) > RanMar then + begin + Accept := True; + Inc(N_acc); + end + else + Accept := False; + end; + end; + + function SimAnnCycle(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var LogFile : Text; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs one cycle of simulated annealing + ---------------------------------------------------------------------- } + const + N_FACT = 2.0; { Factor for step reduction } + var + I, Iter, J, K, N_inc, N_acc : Integer; + F, F1, DeltaF, Ratio, T, OldX : Float; + Range, Step, Xopt : PVector; + Nacc : PIntVector; + begin + DimVector(Step, Ubound); + DimVector(Xopt, Ubound); + DimVector(Range, Ubound); + DimIntVector(Nacc, Ubound); + + { Determine parameter range, step and optimum } + for K := Lbound to Ubound do + begin + Range^[K] := Xmax^[K] - Xmin^[K]; + Step^[K] := 0.5 * Range^[K]; + Xopt^[K] := X^[K]; + end; + + { Initialize function values } + F := Func(X); + F_min := F; + + { Initialize temperature and iteration count } + T := InitTemp(Func, X, Xmin, Range, Lbound, Ubound); + Iter := 0; + + repeat + { Perform SA_Nt evaluations at constant temperature } + N_inc := 0; N_acc := 0; + for I := 1 to SA_Nt do + begin + for J := 1 to SA_Ns do + for K := Lbound to Ubound do + begin + { Save current parameter value } + OldX := X^[K]; + + { Pick new value, keeping it within Range } + X^[K] := X^[K] + (2.0 * RanMar - 1.0) * Step^[K]; + if (X^[K] < Xmin^[K]) or (X^[K] > Xmax^[K]) then + X^[K] := Xmin^[K] + RanMar * Range^[K]; + + { Compute new function value } + F1 := Func(X); + DeltaF := F1 - F; + + { Check for acceptance } + if Accept(DeltaF, T, N_inc, N_acc) then + begin + Inc(Nacc^[K]); + F := F1; + end + else + { Restore parameter value } + X^[K] := OldX; + + { Update minimum if necessary } + if F < F_min then + begin + Xopt^[K] := X^[K]; + F_min := F; + end; + end; + + { Ajust step length to maintain an acceptance + ratio of about 50% for each parameter } + for K := Lbound to Ubound do + begin + Ratio := Int(Nacc^[K]) / Int(SA_Ns); + if Ratio > 0.6 then + begin + { Increase step length, keeping it within Range } + Step^[K] := Step^[K] * (1.0 + ((Ratio - 0.6) / 0.4) * N_FACT); + if Step^[K] > Range^[K] then Step^[K] := Range^[K]; + end + else if Ratio < 0.4 then + { Reduce step length } + Step^[K] := Step^[K] / (1.0 + ((0.4 - Ratio) / 0.4) * N_FACT); + + { Restore counter } + Nacc^[K] := 0; + end; + end; + + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', T:12, ' ', F:12, N_inc:6, N_acc:6); + + { Update temperature and iteration count } + T := T * SA_Rt; + Inc(Iter); + until ParamConv(Xopt, Step, Lbound, Ubound, Tol) or (Iter > MaxIter); + + for K := Lbound to Ubound do + X^[K] := Xopt^[K]; + + DelVector(Step, Ubound); + DelVector(Xopt, Ubound); + DelVector(Range, Ubound); + DelIntVector(Nacc, Ubound); + + if Iter > MaxIter then + SimAnnCycle := OPT_NON_CONV + else + SimAnnCycle := OPT_OK; + end; + + function SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + var + Cycle, ErrCode : Integer; + begin + if WriteLogFile then + CreateLogFile; + + { Initialize the Marsaglia random number generator + using the standard Pascal generator } + Randomize; + RMarIn(System.Random(10000), System.Random(10000)); + + Cycle := 1; + repeat + if WriteLogFile then + begin + WriteLn(LogFile, 'Simulated annealing: Cycle ', Cycle); + WriteLn(LogFile); + WriteLn(LogFile, 'Iter T F Inc Acc'); + end; + + ErrCode := SimAnnCycle(Func, X, Xmin, Xmax, Lbound, Ubound, + MaxIter, Tol, LogFile, F_min); + + Inc(Cycle); + until (Cycle > SA_NCycles) or (ErrCode <> OPT_OK); + + if WriteLogFile then + Close(LogFile); + + SimAnn := ErrCode; + end; + +end. diff --git a/npm/dmath/stat.pas b/npm/dmath/stat.pas new file mode 100755 index 0000000..4fc81b3 --- /dev/null +++ b/npm/dmath/stat.pas @@ -0,0 +1,333 @@ +{ ********************************************************************** + * Unit STAT.PAS * + * Version 1.5 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Statistical routines + ********************************************************************** } + +unit Stat; + +interface + +uses + FMath, Matrices; + +{ ---------------------------------------------------------------------- + Common input parameters : X : Vector of statistical variable + Lbound, + Ubound : Indices of first and last + elements of X + W : Vector of weights + ---------------------------------------------------------------------- } + +procedure QSort(X : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Sorts the elements of vector X in increasing order (quick sort) + ---------------------------------------------------------------------- } + +procedure DQSort(X : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Sorts the elements of vector X in decreasing order (quick sort) + ---------------------------------------------------------------------- } + +function Median(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Sorts vector X is ascending order and returns its median value + ---------------------------------------------------------------------- } + +function Sum(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of the elements of vector X + ---------------------------------------------------------------------- } + +function SumSqr(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared elements of vector X + ---------------------------------------------------------------------- } + +function SumSqrDif(X : PVector; Lbound, Ubound : Integer; + A : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared differences between + the elements of vector X and the constant A + ---------------------------------------------------------------------- } + +function SumSqrDifVect(X, Y : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared differences between two vectors + ---------------------------------------------------------------------- } + +function SumWSqr(X, W : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared elements of vector X + ---------------------------------------------------------------------- } + +function SumWSqrDif(X, W : PVector; Lbound, Ubound : Integer; + A : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared differences between + the elements of vector X and the constant A + ---------------------------------------------------------------------- } + +function SumWSqrDifVect(X, Y, W : PVector; + Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared differences between two vectors + ---------------------------------------------------------------------- } + +function Average(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the average value of vector X + ---------------------------------------------------------------------- } + +function Variance(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the variance of vector X, with average Avg + ---------------------------------------------------------------------- } + +function EstVar(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the estimated variance of the population + to which vector X belongs + ---------------------------------------------------------------------- } + +function Skewness(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the skewness of vector X, + with average Avg and standard deviation Sigma + ---------------------------------------------------------------------- } + +function Kurtosis(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the kurtosis of vector X, + with average Avg and standard deviation Sigma + ---------------------------------------------------------------------- } + +procedure RanMult(M : PVector; L : PMatrix; N : Integer; X : PVector); +{ ---------------------------------------------------------------------- + Samples a vector X from the N-dimensioned multinormal distribution + with mean vector M. L is the Cholesky factor of the variance-covariance + matrix. + ---------------------------------------------------------------------- } + +implementation + + procedure QSort(X : PVector; Lbound, Ubound : Integer); + { Quick sort in ascending order - Adapted from Borland's BP7 demo } + procedure Sort(L, R : Integer); + var + I, J : Integer; + U, V : Float; + begin + I := L; + J := R; + U := X^[(L + R) div 2]; + repeat + while X^[I] < U do I := I + 1; + while U < X^[J] do J := J - 1; + if I <= J then + begin + V := X^[I]; X^[I] := X^[J]; X^[J] := V; + I := I + 1; J := J - 1; + end; + until I > J; + if L < J then Sort(L, J); + if I < R then Sort(I, R); + end; + + begin + Sort(Lbound, Ubound); + end; + + procedure DQSort(X : PVector; Lbound, Ubound : Integer); + { Quick sort in descending order - Adapted from Borland's BP7 demo } + procedure Sort(L, R : Integer); + var + I, J : Integer; + U, V : Float; + begin + I := L; + J := R; + U := X^[(L + R) div 2]; + repeat + while X^[I] > U do I := I + 1; + while U > X^[J] do J := J - 1; + if I <= J then + begin + V := X^[I]; X^[I] := X^[J]; X^[J] := V; + I := I + 1; J := J - 1; + end; + until I > J; + if L < J then Sort(L, J); + if I < R then Sort(I, R); + end; + + begin + Sort(Lbound, Ubound); + end; + + function Median(X : PVector; Lbound, Ubound : Integer) : Float; + var + N, N2 : Integer; + begin + N := Ubound - Lbound + 1; + N2 := N div 2 + Lbound - 1; + QSort(X, Lbound, Ubound); + if Odd(N) then + Median := X^[N2 + 1] + else + Median := 0.5 * (X^[N2] + X^[N2 + 1]); + end; + + function Sum(X : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + X^[I]; + Sum := S; + end; + + function SumSqr(X : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I]); + SumSqr := S; + end; + + function SumSqrDif(X : PVector; Lbound, Ubound : Integer; + A : Float) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I] - A); + SumSqrDif := S; + end; + + function SumSqrDifVect(X, Y : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I] - Y^[I]); + SumSqrDifVect := S; + end; + + function SumWSqr(X, W : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I]); + SumWSqr := S; + end; + + function SumWSqrDif(X, W : PVector; Lbound, Ubound : Integer; A : Float) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I] - A); + SumWSqrDif := S; + end; + + function SumWSqrDifVect(X, Y, W : PVector; + Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I] - Y^[I]); + SumWSqrDifVect := S; + end; + + function Average(X : PVector; Lbound, Ubound : Integer) : Float; + begin + Average := Sum(X, Lbound, Ubound) / (Ubound - Lbound + 1); + end; + + function Variance(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; + begin + Variance := SumSqrDif(X, Lbound, Ubound, Avg) / (Ubound - Lbound + 1); + end; + + function EstVar(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; + begin + EstVar := SumSqrDif(X, Lbound, Ubound, Avg) / (Ubound - Lbound); + end; + + function Skewness(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; + var + S, T : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + begin + T := (X^[I] - Avg) / Sigma; + S := S + T * Sqr(T); + end; + Skewness := S / (Ubound - Lbound + 1); + end; + + function Kurtosis(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; + var + S, T : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + begin + T := (X^[I] - Avg) / Sigma; + S := S + Sqr(Sqr(T)); + end; + Kurtosis := S / (Ubound - Lbound + 1) - 3.0; + end; + + procedure RanMult(M : PVector; L : PMatrix; N : Integer; X : PVector); + var + U : PVector; + I, J : Integer; + begin + { Form a vector of N independent standard normal variates } + DimVector(U, N); + for I := 1 to N do + U^[I] := RanGaussStd; + + { Form X = M + L*U, which follows the multinormal distribution } + for I := 1 to N do + begin + X^[I] := M^[I]; + for J := 1 to I do + X^[I] := X^[I] + L^[I]^[J] * U^[J]; + end; + DelVector(U, N); + end; + +end. diff --git a/npm/dmath/texplot.pas b/npm/dmath/texplot.pas new file mode 100755 index 0000000..b918b28 --- /dev/null +++ b/npm/dmath/texplot.pas @@ -0,0 +1,488 @@ +{ ********************************************************************** + * Unit TEXPLOT.PAS * + * Version 1.1 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Plotting routines for TeX/PSTricks + ********************************************************************** } + +unit TexPlot; + +interface + +uses + FMath, Matrices, PaString; + +{ ********************** Include global variables ********************** } + + {$I PLOTVAR.INC} + +{ ************************** Graphic routines ************************** } + +procedure InitTexGraph(var F : Text; FileName : String); +{ ---------------------------------------------------------------------- + Initializes TeX graphics. + Writes a border around the graph according to the value + of the global variable GraphBorder (defined in PLOTVAR.INC) + ---------------------------------------------------------------------- + F : file to be written + FileName : name of TeX file (e.g. 'figure.tex') + ---------------------------------------------------------------------- } + +function Xcm(X : Float) : Float; +{ ---------------------------------------------------------------------- + Converts user coordinate X to cm + ---------------------------------------------------------------------- } + +function Ycm(Y : Float) : Float; +{ ---------------------------------------------------------------------- + Converts user coordinate Y to cm + ---------------------------------------------------------------------- } + +procedure WriteXAxis(var F : Text); +{ ---------------------------------------------------------------------- + Writes horizontal axis (global variable XAxis in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteYAxis(var F : Text); +{ ---------------------------------------------------------------------- + Writes vertical axis (global variable YAxis in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteGrid(var F : Text); +{ ---------------------------------------------------------------------- + Writes a grid (global variable Grid in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteLine(var F : Text; X1, Y1, X2, Y2 : Float; Style : String); +{ ---------------------------------------------------------------------- + Writes a line between two points + ---------------------------------------------------------------------- + F : output file + + X1, Y1 : coordinates of first point + + X2, Y2 : coordinates of second point + + Style : line style (must be 'solid', 'dotted' or 'dashed') + ---------------------------------------------------------------------- } + +procedure WritePoints(var F : Text; X, Y : PVector; + Lbound, Ubound, Symbol, Size : Integer); +{ ---------------------------------------------------------------------- + Writes a set of points + ---------------------------------------------------------------------- + F : output file + + X, Y : point coordinates + + Lbound, Ubound : indices of first and last point + + Symbol : 1 = solid circle 2 = open circle + 3 = solid square 4 = open square + 5 = solid triangle 6 = open triangle + 7 = plus (+) 8 = multiply (x) + 9 = star (*) + + Size : size of points + ---------------------------------------------------------------------- } + +procedure WriteText(var F : Text; Place : String; X, Y : Float; S : String); +{ ---------------------------------------------------------------------- + Writes a text + ---------------------------------------------------------------------- + F : output file + + Place : defines the position of point (X,Y) with respect + to the box enclosing the text + + the possible values are + 'tl', 't', 'tr', 'l', 'r', 'Bl', 'B', 'Br', 'bl', 'b', 'br' + according to the following scheme: + + t + tl +---------------------+ tr + | | + | | + l | | r + | | + Bl |----------B----------| Br + bl +---------------------+ br + b + + X, Y : position of text + + S : text to be written + ---------------------------------------------------------------------- } + +procedure WriteNumber(var F : Text; Place : String; X, Y, Z : Float); +{ ---------------------------------------------------------------------- + Writes a number + ---------------------------------------------------------------------- + Z is the number to be written + Other parameters as in WriteText + ---------------------------------------------------------------------- } + +procedure WriteCurve(var F : Text; X, Y : PVector; + Lbound, Ubound, Width : Integer; + Style : String; Smooth : Boolean); +{ ---------------------------------------------------------------------- + Writes a curve + ---------------------------------------------------------------------- + F : output file + + X, Y : point coordinates + + Lbound, Ubound : indices of first and last point + + Width : curve width in units of 0.01 cm + + Style : curve style (must be 'solid', 'dotted' or 'dashed') + + Smooth : indicates if the curve must be smoothed + ---------------------------------------------------------------------- } + +procedure WriteFunc(var F : Text; Func : TFunc; X1, X2 : Float; + Npt, Width : Integer; Style : String); +{ ---------------------------------------------------------------------- + Writes the curve representing a function + ---------------------------------------------------------------------- + F : output file + + Func : function to be plotted + + X1, X2 : abscissae of 1st and last point to plot + + Npt : number of points + + Width, Style : width of curve (as in WriteCurve) + ---------------------------------------------------------------------- + The function must be programmed as: function Func(X : Float) : Float; + ---------------------------------------------------------------------- } + +procedure CloseTexGraph(var F : Text); +{ ---------------------------------------------------------------------- + Close graphics + ---------------------------------------------------------------------- } + +implementation + +const + PAGEWIDTH = 13; { Graph width in cm } + PAGEHEIGHT = 10; { Graph height in cm } + +var + XminCm, YminCm : Float; { Coord. of lower left corner in cm } + XmaxCm, YmaxCm : Float; { Coord. of upper right corner in cm } + FactX, FactY : Float; { Scaling factors } + + function Xcm(X : Float) : Float; + { Converts user coordinate X to cm } + begin + Xcm := XminCm + FactX * (X - XAxis.Min); + end; + + function Ycm(Y : Float) : Float; + { Converts user coordinate Y to cm } + begin + Ycm := YminCm + FactY * (Y - YAxis.Min); + end; + + procedure WriteHeader(var F : Text); + begin + WriteLn(F, '\documentclass[12pt,a4paper]{article}'); + WriteLn(F, '\usepackage{t1enc}'); + WriteLn(F, '\usepackage{pst-plot}'); + WriteLn(F, '\begin{document}'); + WriteLn(F); + WriteLn(F, '\begin{pspicture}(', PAGEWIDTH, ',', PAGEHEIGHT, ')'); + end; + + procedure WriteCoord(var F : Text; X, Y : Float); + { Writes the coordinates (in cm) of a point } + var + NSZ : Boolean; + begin + NSZ := NSZEro; + NSZero := False; + Write(F, '(', Trim(FloatToStr(X)), ',', Trim(FloatToStr(Y)), ')'); + NSZEro := NSZ; + end; + + procedure WriteLine(var F : Text; X1, Y1, X2, Y2 : Float; Style : String); + begin + Write(F, '\psline'); + if Style <> '' then + Write(F, '[linestyle=', Style, ']'); + WriteCoord(F, X1, Y1); + WriteCoord(F, X2, Y2); + WriteLn(F); + end; + + procedure WriteText(var F : Text; Place : String; X, Y : Float; S : String); + begin + Write(F, '\rput[', Place, ']'); + WriteCoord(F, X, Y); + WriteLn(F, '{', S, '}'); + end; + + procedure WriteNumber(var F : Text; Place : String; X, Y, Z : Float); + begin + Write(F, '\rput[', Place, ']'); + WriteCoord(F, X, Y); + WriteLn(F, '{', Trim(FloatToStr(Z)), '}'); + end; + + procedure WriteXAxis(var F: Text); + var + W, X, Xc, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + WriteLine(F, XminCm, YminCm, XmaxCm, YminCm, ''); + + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + X := XAxis.Min; { Tick mark position } + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + + Xc := Xcm(X); + WriteLine(F, Xc, YminCm, Xc, YminCm - 0.25, ''); { Tick mark } + + if XAxis.Scale = LIN_SCALE then + Z := X + else + Z := Exp10(X); + WriteNumber(F, 't', Xc, YminCm - 0.35, Z); { Label } + + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do { Plot minor divisions } + begin { on logarithmic scale } + W := X + Log10(J); + Xc := Xcm(W); + WriteLine(F, Xc, YminCm, Xc, YminCm - 0.15, ''); + end; + + X := X + XAxis.Step; + end; + + { Write axis title } + if XTitle.Text <> '' then + WriteText(F, 't', 0.5 * (XminCm + XmaxCm), YminCm - 1.0, XTitle.Text); + + NSZero := NSZ; + end; + + procedure WriteYAxis(var F : Text); + var + W, Y, Yc, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + WriteLine(F, XminCm, YminCm, XminCm, YmaxCm, ''); + + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); + Y := YAxis.Min; + + NSZ := NSZero; + NSZero := False; + + for I := 0 to N do + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + + Yc := Ycm(Y); + WriteLine(F, XminCm, Yc, XminCm - 0.25, Yc, ''); + + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + WriteNumber(F, 'r', XminCm - 0.35, Yc, Z); + + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + Yc := Ycm(W); + WriteLine(F, XminCm, Yc, XminCm - 0.15, Yc, ''); + end; + + Y := Y + YAxis.Step; + end; + + { Write axis title } + if YTitle.Text <> '' then + WriteText(F, 'l', XminCm, YmaxCm + 0.5, YTitle.Text); + + NSZero := NSZ; + end; + + procedure WriteGrid(var F : Text); + var + X, Y, Xc, Yc : Float; + I, N : Integer; + begin + { Horizontal lines } + if Grid in [HORIZ_GRID, BOTH_GRID] then + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yc := Ycm(Y); + WriteLine(F, XminCm, Yc, XmaxCm, Yc, 'dotted'); + end; + end; + + { Vertical lines } + if Grid in [VERTIC_GRID, BOTH_GRID] then + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xc := Xcm(X); + WriteLine(F, Xc, YminCm, Xc, YmaxCm, 'dotted'); + end; + end; + end; + + procedure InitTexGraph(var F : Text; Filename : String); + begin + XminCm := 0.01 * Xwin1 * PAGEWIDTH; + XmaxCm := 0.01 * Xwin2 * PAGEWIDTH; + YminCm := 0.01 * Ywin1 * PAGEHEIGHT; + YmaxCm := 0.01 * Ywin2 * PAGEHEIGHT; + + FactX := (XmaxCm - XminCm) / (XAxis.Max - XAxis.Min); + FactY := (YmaxCm - YminCm) / (YAxis.Max - YAxis.Min); + + Assign(F, FileName); + Rewrite(F); + + WriteHeader(F); + + if GraphBorder then + begin + Write(F, '\pspolygon'); + WriteCoord(F, XminCm, YminCm); + WriteCoord(F, XmaxCm, YminCm); + WriteCoord(F, XmaxCm, YmaxCm); + WriteCoord(F, XminCm, YmaxCm); + WriteLn(F); + end; + end; + + procedure WritePoint(var F : Text; X, Y : Float); + var + Xc, Yc : Float; + begin + if XAxis.Scale = LOG_SCALE then X := Log10(X); + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + + Xc := Xcm(X); + Yc := Ycm(Y); + + if (Xc >= XminCm) and (Xc <= XmaxCm) and + (Yc >= YminCm) and (Yc <= YmaxCm) then + WriteCoord(F, Xc, Yc); + end; + + procedure WritePoints(var F : Text; X, Y : PVector; + Lbound, Ubound, Symbol, Size : Integer); + var + I, N : Integer; + begin + Write(F, '\psdots[dotscale=', Size, ' ', Size, ', dotstyle='); + case Symbol of + 1 : Write(F, '*'); + 2 : Write(F, 'o'); + 3 : Write(F, 'square*'); + 4 : Write(F, 'square'); + 5 : Write(F, 'triangle*'); + 6 : Write(F, 'triangle'); + 7 : Write(F, '+'); + 8 : Write(F, 'x'); + 9 : Write(F, 'asterisk'); + end; + WriteLn(F, ']%'); + + I := Lbound; + repeat + WritePoint(F, X^[I], Y^[I]); + if (I > 0) and (I < Ubound) and (I mod 5 = 0) then WriteLn(F, '%'); + Inc(I); + until I > Ubound; + WriteLn(F); + end; + + procedure WriteCurve(var F : Text; X, Y : PVector; + Lbound, Ubound, Width : Integer; + Style : String; Smooth : Boolean); + var + I, N : Integer; + W : Float; + Ws : String; + begin + W := 0.01 * Width; + Str(W:5:2, Ws); + Ws := Trim(Ws); + + if Smooth then Write(F, '\pscurve') else Write(F, '\psline'); + WriteLn(F, '[linewidth=', Ws, ', linestyle=', Style, ']%'); + + I := Lbound; + repeat + WritePoint(F, X^[I], Y^[I]); + if (I > 0) and (I < Ubound) and (I mod 5 = 0) then WriteLn(F, '%'); + Inc(I); + until I > Ubound; + WriteLn(F); + end; + + procedure WriteFunc(var F : Text; Func : TFunc; X1, X2 : Float; + Npt, Width : Integer; Style : String); + const + X : PVector = nil; + Y : PVector = nil; + N : Integer = 0; + var + H : Float; + I : Integer; + begin + if Npt <> N then + begin + DelVector(X, N); + DelVector(Y, N); + DimVector(X, Npt); + DimVector(Y, Npt); + N := Npt; + end; + + H := (X2 - X1) / N; + for I := 0 to N do + begin + X^[I] := X1 + I * H; + if XAxis.Scale = LIN_SCALE then + Y^[I] := Func(X^[I]) + else + Y^[I] := Func(Exp10(X^[I])); + end; + + WriteCurve(F, X, Y, 0, N, Width, Style, True); + end; + + procedure CloseTexGraph(var F: Text); + begin + WriteLn(F, '\end{pspicture}'); + WriteLn(F); + WriteLn(F, '\end{document}'); + Close(F); + end; + +end. + + diff --git a/npm/dmath/winplot.pas b/npm/dmath/winplot.pas new file mode 100755 index 0000000..4376db5 --- /dev/null +++ b/npm/dmath/winplot.pas @@ -0,0 +1,856 @@ +{ ********************************************************************** + * Unit WINPLOT.PAS * + * Version 1.1 * + * (c) J. Debord, October 1999 * + ********************************************************************** + Plotting routines for DELPHI + ********************************************************************** } + +unit WinPlot; + +interface + +uses + { DELPHI units } + WinTypes, + Graphics, + { TPMath units } + FMath, + Matrices, + Stat, + PaString; + +{ ************************* Constants and types ************************ } + +const + MAXCURV = 255; { Max. number of curves which may be plotted } + MAXSYMBOL = 9; { Max. number of symbols for plotting curves } + EPS = 1.0E-10; { Lower limit for an axis label } + +type + TScale = (LIN_SCALE, { Scale } + LOG_SCALE); + + TGrid = (NO_GRID, { Grid } + HORIZ_GRID, + VERTIC_GRID, + BOTH_GRID); + + TAxis = record { Coordinate axis } + Scale : TScale; + Min, Max, Step : Float; + Title : String; + end; + + TPointParam = record { Point parameters } + Symbol : Integer; { Symbol index } + Size : Integer; { Symbol size in 1/250 of graphic width } + Color : TColor; + end; + + TLineParam = record { Line parameters } + Width : Integer; + Style : TPenStyle; + Color : TColor; + end; + + TCurvParam = record { Curve parameters } + PointParam : TPointParam; + LineParam : TLineParam; + Legend : String[30]; { Legend of curve } + Step : Integer; { Plot 1 point every Step points } + Connect : Boolean; { Connect points with line? } + end; + + TCurvParamArray = array[1..MAXCURV] of TCurvParam; + + PCurvParamArray = ^TCurvParamArray; + +{ ******** Global variables defining the appearance of the graph ******* } + +const + Xwin1 : Integer = 15; { Window coordinates in percent of maximum } + Ywin1 : Integer = 15; + Xwin2 : Integer = 75; + Ywin2 : Integer = 75; + + GraphBorder : Boolean = True; { For plotting a rectangle around the graph } + + XAxis : TAxis = (Scale : LIN_SCALE; { Horizontal axis } + Min : 0.0; + Max : 1.0; + Step : 0.2; + Title : 'X'); + + YAxis : TAxis = (Scale : LIN_SCALE; { Vertical axis } + Min : 0.0; + Max : 1.0; + Step : 0.2; + Title : 'Y'); + + Grid : TGrid = BOTH_GRID; { Grid } + + GraphTitle : String = ''; { Title of graph } + +{ ************************** Graphic routines ************************** } + +procedure InitGraph(Canvas : TCanvas; + Width, Height : Integer); +{ ---------------------------------------------------------------------- + Initializes the graphic + ---------------------------------------------------------------------- + The parameters refer to the object on which the graphic is plotted. + + Examples: + + To draw on a TImage object: + InitGraph(Image1.Canvas, Image1.Width, Image1.Height); + + To print the graphic: + InitGraph(Printer.Canvas, Printer.PageWidth, Printer.PageHeight); + ---------------------------------------------------------------------- } + +procedure PlotXAxis(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots the X axis + ---------------------------------------------------------------------- } + +procedure PlotYAxis(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots the Y axis + ---------------------------------------------------------------------- } + +procedure WriteTitle(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Writes the title of the graph + ---------------------------------------------------------------------- } + +procedure PlotGrid(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots a grid on the graph + ---------------------------------------------------------------------- } + +procedure PlotPoint(Canvas : TCanvas; + X, Y : Float; + PointParam : TPointParam); +{ ---------------------------------------------------------------------- + Plots a point + ---------------------------------------------------------------------- + X, Y : point coordinates + PointParam : point parameters + ---------------------------------------------------------------------- } + +procedure PlotCurve(Canvas : TCanvas; + X, Y : PVector; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); +{ ---------------------------------------------------------------------- + Plots a curve + ---------------------------------------------------------------------- + X, Y : point coordinates + Lbound, Ubound : indices of first and last points + CurvParam : curve parameters + ---------------------------------------------------------------------- } + +procedure PlotCurveWithErrorBars(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); +{ ---------------------------------------------------------------------- + Plots a curve with error bars + ---------------------------------------------------------------------- + X, Y : point coordinates + S : errors (e.g. standard deviations) + Ns : error multiplier (e.g. 2 for plotting 2 SD's) + Lbound, Ubound : indices of first and last points + CurvParam : curve parameters + ---------------------------------------------------------------------- } + +procedure PlotFunc(Canvas : TCanvas; + Func : TFunc; + Xmin, Xmax : Float; + Npt : Integer; + LineParam : TLineParam); +{ ---------------------------------------------------------------------- + Plots a function + ---------------------------------------------------------------------- + Func : function to be plotted + must be programmed as: function Func(X : Float) : Float; + Xmin, Xmax : abscissae of 1st and last point to plot + Npt : number of points + LineParam : line parameters + ---------------------------------------------------------------------- } + +procedure WriteLegend(Canvas : TCanvas; + NCurv : Integer; + CurvParam : PCurvParamArray; + ShowPoints, + ShowLines : Boolean); +{ ---------------------------------------------------------------------- + Writes the legends for the plotted curves + ---------------------------------------------------------------------- + NCurv : number of curves (1 to MAXCURV) + CurvParam : curve parameters + ShowPoints : for displaying points + ShowLines : for displaying lines + ---------------------------------------------------------------------- } + + +{ *********** The following routines are defined in PLOT.INC *********** } + +procedure Interval(X1, X2 : Float; + MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); +{ ---------------------------------------------------------------------- + Determines an interval [Min, Max] including the values from X1 to X2, + and a subdivision Step of this interval + ---------------------------------------------------------------------- + Input parameters : X1, X2 = min. & max. values to be included + MinDiv = minimum nb of subdivisions + MaxDiv = maximum nb of subdivisions + ---------------------------------------------------------------------- + Output parameters : Min, Max, Step + ---------------------------------------------------------------------- } + +procedure AutoScale(Z : PVector; + Lbound, Ubound : Integer; + var Axis : TAxis); +{ ---------------------------------------------------------------------- + Determines the scale of an axis + ---------------------------------------------------------------------- + Input parameters : Z = array of values to be plotted + Lbound, + Ubound = indices of first and last elements of Z + ---------------------------------------------------------------------- + Output parameters : Axis + ---------------------------------------------------------------------- } + +function Xpixel(X : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user abscissa X to screen coordinate + ---------------------------------------------------------------------- } + +function Ypixel(Y : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user ordinate Y to screen coordinate + ---------------------------------------------------------------------- } + +function Xuser(X : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate X to user abscissa + ---------------------------------------------------------------------- } + +function Yuser(Y : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate Y to user ordinate + ---------------------------------------------------------------------- } + +implementation + +uses + Classes; + +var + GraphWidth, GraphHeight, SymbolSizeUnit : Integer; + +{ ---------------------------------------------------------------------- + Include the variables and routines common to PLOT.PAS and WINPLOT.PAS + ---------------------------------------------------------------------- } + + {$I PLOT.INC} + +{ ---------------------------------------------------------------------- } + +procedure PlotXAxis(Canvas : TCanvas); + var + W, X, Z : Float; + N, I, J, TickLength, MinorTickLength, Wp, Xp : Integer; + XLabel : String; + NSZ : Boolean; + begin + TickLength := Canvas.TextHeight('M') div 2; + MinorTickLength := Round(0.67 * TickLength); { For log scale } + + { Draw axis } + Canvas.MoveTo(XminPixel, YmaxPixel); + Canvas.LineTo(XmaxPixel, YmaxPixel); + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + + X := XAxis.Min; { Tick mark position } + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + Xp := Xpixel(X); + + { Draw tick mark } + Canvas.MoveTo(Xp, YmaxPixel); + Canvas.LineTo(Xp, YmaxPixel + TickLength); + + { Write label } + if XAxis.Scale = LIN_SCALE then Z := X else Z := Exp10(X); + XLabel := Trim(PaString.FloatToStr(Z)); + Canvas.TextOut(Xp - Canvas.TextWidth(XLabel) div 2, + YmaxPixel + TickLength, XLabel); + + { Plot minor divisions on logarithmic scale } + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := X + Log10(J); + Wp := Xpixel(W); + Canvas.MoveTo(Wp, YmaxPixel); + Canvas.LineTo(Wp, YmaxPixel + MinorTickLength); + end; + X := X + XAxis.Step; + end; + + NSZero := NSZ; + + { Write axis title } + if XAxis.Title <> '' then + Canvas.TextOut(XminPixel + (XmaxPixel - XminPixel - + Canvas.TextWidth(XAxis.Title)) div 2, + YmaxPixel + 2 * Canvas.TextHeight('M'), + XAxis.Title); + end; + + procedure PlotYAxis(Canvas : TCanvas); + var + W, Y, Z : Float; + N, I, J, Wp, Yp : Integer; + TickLength, MinorTickLength, Yoffset : Integer; + YLabel : String; + NSZ : Boolean; + begin + TickLength := Canvas.TextWidth('M') div 2; + MinorTickLength := Round(0.67 * TickLength); { For log scale } + + Yoffset := Canvas.TextHeight('M') div 2; + + { Draw axis } + Canvas.MoveTo(XminPixel, YminPixel); + Canvas.LineTo(XminPixel, YmaxPixel); + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + + Y := YAxis.Min; { Tick mark position } + for I := 0 to N do { Label axis } + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + Yp := Ypixel(Y); + + { Draw tick mark } + Canvas.MoveTo(XminPixel, Yp); + Canvas.LineTo(XminPixel - TickLength, Yp); + + { Write label } + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + YLabel := Trim(PaString.FloatToStr(Z)); + Canvas.TextOut(XminPixel - TickLength - Canvas.TextWidth(YLabel), + Yp - Yoffset, YLabel); + + { Plot minor divisions on logarithmic scale } + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + Wp := Ypixel(W); + Canvas.MoveTo(XminPixel, Wp); + Canvas.LineTo(XminPixel - MinorTickLength, Wp); + end; + Y := Y + YAxis.Step; + end; + + NSZero := NSZ; + + { Write axis title } + if YAxis.Title <> '' then + Canvas.TextOut(XminPixel, YminPixel - 3 * Yoffset, YAxis.Title); + end; + + procedure InitGraph(Canvas : TCanvas; Width, Height : Integer); + begin + GraphWidth := Width; + GraphHeight := Height; + SymbolSizeUnit := GraphWidth div 250; + + XminPixel := Round(Xwin1 / 100 * Width); + YminPixel := Round(Ywin1 / 100 * Height); + XmaxPixel := Round(Xwin2 / 100 * Width); + YmaxPixel := Round(Ywin2 / 100 * Height); + + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); + + if GraphBorder then + Canvas.Rectangle(XminPixel, YminPixel, Succ(XmaxPixel), Succ(YmaxPixel)); + end; + + procedure WriteTitle(Canvas : TCanvas); + begin + if GraphTitle <> '' then + with Canvas do + TextOut((XminPixel + XmaxPixel - TextWidth(GraphTitle)) div 2, + YminPixel - 2 * TextHeight(GraphTitle), GraphTitle); + end; + + procedure PlotGrid(Canvas : TCanvas); + var + X, Y : Float; + I, N, Xp, Yp : Integer; + PenStyle : TpenStyle; + begin + { Save current settings } + PenStyle := Canvas.Pen.Style; + Canvas.Pen.Style := psDot; + + if Grid in [HORIZ_GRID, BOTH_GRID] then { Horizontal lines } + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yp := Ypixel(Y); + Canvas.MoveTo(XminPixel, Yp); + Canvas.LineTo(XmaxPixel, Yp); + end; + end; + + if Grid in [VERTIC_GRID, BOTH_GRID] then { Vertical lines } + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xp := Xpixel(X); + Canvas.MoveTo(Xp, YminPixel); + Canvas.LineTo(Xp, YmaxPixel); + end; + end; + + { Restore settings } + Canvas.Pen.Style := PenStyle; + end; + + function XOutOfBounds(X : Integer) : Boolean; + { Checks if an absissa is outside the graphic bounds } + begin + XOutOfBounds := (X < XminPixel) or (X > XmaxPixel); + end; + + function YOutOfBounds(Y : Integer) : Boolean; + { Checks if an ordinate is outside the graphic bounds } + begin + YOutOfBounds := (Y < YminPixel) or (Y > YmaxPixel); + end; + + function CheckPoint(X, Y : Float; + var Xp, Yp : Integer) : Boolean; + { Computes the pixel coordinates of a point and + checks if it is enclosed within the graph limits } + begin + Xp := Xpixel(X); + Yp := Ypixel(Y); + CheckPoint := not(XOutOfBounds(Xp) or YOutOfBounds(Yp)); + end; + + procedure PlotSymbol(Canvas : TCanvas; + Xp, Yp : Integer; + Symbol, Size : Integer); + { Plots a symbol at pixel coordinates (Xp, Yp) + with the current canvas settings } + var + Xp1, Xp2, Yp1, Yp2 : Integer; + begin + if Symbol > 0 then + begin + Size := Size * SymbolSizeUnit; + Xp1 := Xp - Size; + Yp1 := Yp - Size; + Xp2 := Xp + Size + 1; + Yp2 := Yp + Size + 1; + end; + + with Canvas do + case Symbol of + 0 : Pixels[Xp, Yp] := Brush.Color; + 1, 2 : Ellipse(Xp1, Yp1, Xp2, Yp2); { Circle } + 3, 4 : Rectangle(Xp1, Yp1, Xp2, Yp2); { Square } + 5, 6 : Polygon([Point(Xp1, Yp2 - 1), + Point(Xp2, Yp2 - 1), + Point(Xp, Yp1 - 1)]); { Triangle } + 7 : begin { + } + MoveTo(Xp, Yp1); + LineTo(Xp, Yp2); + MoveTo(Xp1, Yp); + LineTo(Xp2, Yp); + end; + 8 : begin { x } + MoveTo(Xp1, Yp1); + LineTo(Xp2, Yp2); + MoveTo(Xp1, Yp2 - 1); + LineTo(Xp2, Yp1 - 1); + end; + 9 : begin { * } + MoveTo(Xp, Yp1); + LineTo(Xp, Yp2); + MoveTo(Xp1, Yp); + LineTo(Xp2, Yp); + MoveTo(Xp1, Yp1); + LineTo(Xp2, Yp2); + MoveTo(Xp1, Yp2 - 1); + LineTo(Xp2, Yp1 - 1); + end; + end; + end; + + procedure PlotLine(Canvas : TCanvas; + Xp1, Yp1, Xp2, Yp2 : Integer); + { Plots a line with the current canvas settings } + begin + Canvas.MoveTo(Xp1, Yp1); + Canvas.LineTo(Xp2, Yp2); + end; + + procedure PlotPoint(Canvas : TCanvas; + X, Y : Float; + PointParam : TPointParam); + var + Xp, Yp : Integer; + BrushStyle : TBrushStyle; + PenColor, BrushColor : TColor; + begin + if XAxis.Scale = LOG_SCALE then X := Log10(X); + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + + if not CheckPoint(X, Y, Xp, Yp) then Exit; + + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + + Pen.Color := PointParam.Color; + Brush.Color := PointParam.Color; + if PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + PlotSymbol(Canvas, Xp, Yp, PointParam.Symbol, PointParam.Size); + + { Restore settings } + Pen.Color := PenColor; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + + procedure PlotErrorBar(Canvas : TCanvas; + Y, S : Float; + Ns : Integer; + Xp, Yp, Size : Integer); + { Plots an error bar with the current canvas settings } + var + Delta, Y1 : Float; + Yp1 : Integer; + begin + Size := Size * SymbolSizeUnit; + + Delta := Ns * S; + Y1 := Y - Delta; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Yp1 := Ypixel(Y1); + + if Yp1 <= YmaxPixel then + begin + PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1); + PlotLine(Canvas, Xp, Yp, Xp, Yp1); + end + else + PlotLine(Canvas, Xp, Yp, Xp, YmaxPixel); + + Y1 := Y + Delta; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Yp1 := Ypixel(Y1); + + if Yp1 >= YminPixel then + begin + PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1); + PlotLine(Canvas, Xp, Yp, Xp, Yp1); + end + else + PlotLine(Canvas, Xp, Yp, Xp, YminPixel); + end; + + procedure GenPlotCurve(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam; + ErrorBars : Boolean); + { General curve plotting routine } + var + X1, Y1, X2, Y2 : Float; + Xp1, Yp1, Xp2, Yp2 : Integer; + I : Integer; + Flag1, Flag2 : Boolean; + PenWidth : Integer; + PenStyle : TpenStyle; + PenColor, BrushColor : TColor; + BrushStyle : TBrushStyle; + begin + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + + Pen.Color := CurvParam.LineParam.Color; + Pen.Style := CurvParam.LineParam.Style; + Pen.Width := CurvParam.LineParam.Width; + Brush.Color := CurvParam.PointParam.Color; + + if CurvParam.PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + { Plot first point } + X1 := X^[Lbound]; if XAxis.Scale = LOG_SCALE then X1 := Log10(X1); + Y1 := Y^[Lbound]; if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Flag1 := CheckPoint(X1, Y1, Xp1, Yp1); + if Flag1 then + begin + PlotSymbol(Canvas, Xp1, Yp1, CurvParam.PointParam.Symbol, + CurvParam.PointParam.Size); + if ErrorBars and (S^[Lbound] > 0.0) then + PlotErrorBar(Canvas, Y^[Lbound], S^[Lbound], Ns, Xp1, Yp1, + CurvParam.PointParam.Size); + end; + + { Plot other points and connect them by lines if necessary } + I := Lbound + CurvParam.Step; + while I <= Ubound do + begin + X2 := X^[I]; if XAxis.Scale = LOG_SCALE then X2 := Log10(X2); + Y2 := Y^[I]; if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Flag2 := CheckPoint(X2, Y2, Xp2, Yp2); + if Flag2 then + begin + PlotSymbol(Canvas, Xp2, Yp2, CurvParam.PointParam.Symbol, + CurvParam.PointParam.Size); + if ErrorBars and (S^[I] > 0.0) then + PlotErrorBar(Canvas, Y^[I], S^[I], Ns, Xp2, Yp2, + CurvParam.PointParam.Size); + if CurvParam.Connect and Flag1 then + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + end; + + Xp1 := Xp2; + Yp1 := Yp2; + Flag1 := Flag2; + Inc(I, CurvParam.Step); + end; + + { Restore settings } + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + + procedure PlotCurve(Canvas : TCanvas; + X, Y : PVector; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); + var + Ns : Integer; { Dummy variables } + S : PVector; + begin + GenPlotCurve(Canvas, X, Y, S, Ns, Lbound, Ubound, CurvParam, False); + end; + + procedure PlotCurveWithErrorBars(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); + begin + GenPlotCurve(Canvas, X, Y, S, Ns, Lbound, Ubound, CurvParam, True); + end; + + procedure PlotFunc(Canvas : TCanvas; + Func : TFunc; + Xmin, Xmax : Float; + Npt : Integer; + LineParam : TLineParam); + var + PenColor : TColor; + PenStyle : TpenStyle; + PenWidth : Integer; + X1, Y1, X2, Y2, H : Float; + Xp1, Yp1, Xp2, Yp2 : Integer; + Flag1, Flag2 : Boolean; + I : Integer; + begin + if (Npt < 2) or (LineParam.Style = psClear) then Exit; + + if Xmin >= Xmax then + begin + Xmin := XAxis.Min; + Xmax := XAxis.Max; + end; + + H := (Xmax - Xmin) / Npt; + + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + + Pen.Color := LineParam.Color; + Pen.Style := LineParam.Style; + Pen.Width := LineParam.Width; + + { Check first point } + X1 := Xmin; + if XAxis.Scale = LIN_SCALE then + Y1 := Func(X1) + else + Y1 := Func(Exp10(X1)); + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Flag1 := CheckPoint(X1, Y1, Xp1, Yp1); + + { Check other points and plot lines if possible } + for I := 1 to Npt do + begin + X2 := X1 + H; + if XAxis.Scale = LIN_SCALE then + Y2 := Func(X2) + else + Y2 := Func(Exp10(X2)); + if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Flag2 := CheckPoint(X2, Y2, Xp2, Yp2); + if Flag1 and Flag2 then + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + X1 := X2; + Xp1 := Xp2; + Yp1 := Yp2; + Flag1 := Flag2; + end; + + { Restore settings } + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + end; + end; + + procedure WriteLegend(Canvas : TCanvas; + NCurv : Integer; + CurvParam : PCurvParamArray; + ShowPoints, + ShowLines : Boolean); + + var + CharHeight, I, L, Lmax, N, Nmax, Xp, Xl, Y : Integer; + PenWidth : Integer; + PenStyle : TpenStyle; + PenColor, BrushColor : TColor; + BrushStyle : TBrushStyle; + begin + N := 0; { Nb of legends to be plotted } + Lmax := 0; { Length of the longest legend } + + for I := 1 to NCurv do + if CurvParam^[I].Legend <> '' then + begin + Inc(N); + L := Canvas.TextWidth(CurvParam^[I].Legend); + if L > Lmax then Lmax := L; + end; + + if (N = 0) or (Lmax = 0) then Exit; + + { Character height } + CharHeight := Canvas.TextHeight('M'); + + { Max. number of legends which may be plotted } + Nmax := Round((YmaxPixel - YminPixel) / CharHeight) - 1; + if N > Nmax then N := Nmax; + + { Draw rectangle around the legends } + Canvas.Rectangle(XmaxPixel + Round(0.02 * GraphWidth), YminPixel, + XmaxPixel + Round(0.12 * GraphWidth) + Lmax, + YminPixel + (N + 1) * CharHeight); + + L := Round(0.02 * GraphWidth); { Half-length of line } + Xp := XmaxPixel + 3 * L; { Position of symbol } + Xl := XmaxPixel + 5 * L; { Position of legend } + + { Save current settings } + with Canvas do + begin + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + end; + + for I := 1 to IMin(NCurv, Nmax) do + with Canvas do + begin + Pen.Color := CurvParam^[I].LineParam.Color; + Pen.Style := CurvParam^[I].LineParam.Style; + Pen.Width := CurvParam^[I].LineParam.Width; + Brush.Color := CurvParam^[I].PointParam.Color; + + if CurvParam^[I].PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + { Plot point and line } + Y := YminPixel + I * CharHeight; + if ShowPoints then + PlotSymbol(Canvas, Xp, Y, CurvParam^[I].PointParam.Symbol, + CurvParam^[I].PointParam.Size); + if ShowLines then + PlotLine(Canvas, Xp - L, Y, Xp + L, Y); + + { Write legend } + Brush.Style := bsClear; + Canvas.TextOut(Xl, Y - CharHeight div 2, CurvParam^[I].Legend); + end; + + { Restore settings } + with Canvas do + begin + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + +end. diff --git a/npm/extrafpc.cfg b/npm/extrafpc.cfg new file mode 100755 index 0000000..4c13c40 --- /dev/null +++ b/npm/extrafpc.cfg @@ -0,0 +1,4 @@ +#IFDEF Darwin +-k-macosx_version_min -k10.4 +-XR/Developer/SDKs/MacOSX10.4u.sdk/ +#ENDIF \ No newline at end of file diff --git a/npm/filename.o b/npm/filename.o new file mode 100644 index 0000000..b57561b Binary files /dev/null and b/npm/filename.o differ diff --git a/npm/filename.pas b/npm/filename.pas new file mode 100755 index 0000000..ff04bd8 --- /dev/null +++ b/npm/filename.pas @@ -0,0 +1,28 @@ +unit filename; + +interface +{$H+} + +function LegitFilename(var lInName: string; lIndex: integer): string; + + +implementation +uses SysUtils; + +function LegitFilename(var lInName: string; lIndex: integer): string; +var + I: integer; +begin + if length(lInName) < 1 then begin + result := inttostr(lIndex); + exit; + end; + result := ''; + for I := 1 to length(lInName) do + if lInName[I] in [ '0'..'9','a'..'z','A'..'Z'] then + result := result + lInName[I]; + if length(result) < 1 then + result := inttostr(lIndex); +end; + +end. diff --git a/npm/filename.ppu b/npm/filename.ppu new file mode 100644 index 0000000..006a07f Binary files /dev/null and b/npm/filename.ppu differ diff --git a/npm/firth.o b/npm/firth.o new file mode 100644 index 0000000..d97abaa Binary files /dev/null and b/npm/firth.o differ diff --git a/npm/firth.pas b/npm/firth.pas new file mode 100755 index 0000000..572350c --- /dev/null +++ b/npm/firth.pas @@ -0,0 +1,486 @@ +unit firth; + +interface +uses + {$Include ..\common\isgui.inc} + //ComCtrls,Classes, Graphics, ExtCtrls, + //{$IFDEF FPC}ComCtrls, {$ENDIF} + {$IFDEF GUI} ComCtrls,{$ENDIF} //progressbar + classes,define_types,{stats,}StatThdsUtil,lesion_pattern,Mat,Math,Distr,Vector,dialogsx, unpm, SysUtils; + +procedure FirthAnalyzeNoThread(lnCond, lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); + +implementation + +procedure VisualProg(lPos,lTestNumber: Integer); +begin + NPMTitleMsg(inttostr(lTestNumber)); + NPMProgressBar( lPos); +end; + +var + finalloglik: SingleP0; + KxKA1,KxKB1,KxKA,KxKB :TMatrix; +Kvec,Kvec1 : TVector; +Kveci,kVeci1 : TVectori; + betak,xbeta,yin,pi,ustar, + XXx,XXXW2,XXFisher,XXcovs,XXXWPrime, + deltahalfs,deltat,delta,covs,x,Fisher,XW2,W,XWprime,Hprime,H,ustarmat,negx: TMatrix; + lBarX: TProgressBar; + lnCondx,lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx : integer; + lPlankImgx: byteP;lOutImgMnx,lSymptomRAx: SingleP; + lOutImgX: SingleRAp; + + +procedure logistfx (xin: SingleP; var lZvals: SingleP0; numSubj,numCond: integer; lComputeIntercept: boolean); +//todo zero output incase exit +//yin = 1..numSubj binary 0/1 values +//xin = numSubj*numCond predictors +//Chivals = 0..numCond p-values - the 0th Khi-value is the intercept +// [0th value will not be computed if ; lComputeIntercept= false] +label + 123,666; +const + maxit = 25; + maxhs = 5; + epsilon = 0.0001; + maxstep = 10; +var + SumY0,SumY1,mx, beta0,loglik,loglikold: double; + sumy, n, i,j, k, iter,halfs,lCond,dropCond: integer; + variability,firth: boolean; +procedure crossprodustar; +var + inc,row: integer; +begin + for row := 1 to k do begin + ustarmat[row,1] := 0; + for inc := 1 to ustar.r do + ustarmat[row,1] := ustarmat[row,1] + (x[row,inc]*ustar[inc,1]); + end; +end; +procedure Diag2Vec; +var + inc: integer; +begin + for inc := 1 to pi.r do + ustar[inc,1] := ustar[inc,1]+ H[inc,inc]*(0.5-pi[inc,1]); +end; //nested DiagP2 +procedure DiagP2 (var W, P: TMatrix); +var + inc: integer; +begin + W.Zero; + for inc := 1 to P.r do + W[inc,inc] := Power((P[inc,1] * (1-P[inc,1])),0.5) ; +end; //nested DiagP2 +procedure ComputeFisher; +begin + DiagP2(W,pi); + XW2.mult(x,W); + //XWPrime.copy( XW2); + //XWPrime.transpose; + XWPrime.transpose(XW2); + Fisher.mult(XW2,XWPrime); + covs.copy( Fisher); + covs.Invert2(KxKA,KxKB,Kvec,Kveci) +end; //nested computeFisher + +procedure computedropdelta; +var + jinc,iinc,ii,jj: integer; +begin + DiagP2(W,pi); + XXXW2.mult(XXx,W); + //XXXWPrime.copy( XXXW2); + //XXXWPrime.transpose; + XXXWPrime.transpose(XXXW2); + XXFisher.mult(XXXW2,XXXWPrime); + XXcovs.copy( XXFisher); + //XXcovs.Invert; + XXcovs.Invert2(KxKA1,KxKB1,Kvec1,Kveci1); + covs.Zero; + ii := 0; + for iinc := 1 to (k) do begin + if iinc <> (dropCond+1) then begin //leave the specified column zeros... + inc(ii); + jj := 0; + for jinc := 1 to (k) do begin + if jinc <> (dropCond+1) then begin + inc(jj); + covs[iinc,jinc] := xxCovs[ii,jj]; + end; + end; + end; + end; +end; +function firthpenalty: double; +begin + ComputeFisher; + //result := 0.5 * ln(abs(Fisher.det)); + result := 0.5 * ln(abs(Fisher.Det2(KxKA,kVeci,kVec))); +end; //nested firthpenalty +function ComputeLogLik: double; +var + inc: integer; + lDenom: double; +begin + xbeta.mult(betak,negx); + for inc := 1 to n do begin + lDenom := (1 + exp( xbeta[inc,1])); + if lDenom = 0 then + showMsg('yikes') + else + pi[inc,1] := 1/lDenom; + end; + result := 0; + for inc := 1 to n do + if yin[inc,1] = 1 then + //if pi[inc,1] <> 1 then + result := result+ln(pi[inc,1]); + for inc := 1 to n do + if yin[inc,1] = 0 then + //if pi[inc,1] <> 1 then + result := result+ln(1-pi[inc,1]); + if firth then + result := result + firthpenalty; +end;//nested ComputeLogLik +begin + for i := 0 to (numCond) do + lZVals^[i] := 0; // + if (numSubj < 2) or (numCond < 1) then + exit; + //ensure there is some variability in the input data... + variability := false; + i := 1; + repeat + inc(i); + if xin^[i] <> xin^[1] then + variability := true; + until (i= (numSubj*numCond)) or (variability); + if not variability then + exit; //no variance in the regressors... + variability := false; + i := 1; + repeat + inc(i); + if yin[i,1] <> yin[1,1] then + variability := true; + until (i= (numSubj)) or (variability); + if not variability then + exit; //no variance in the dependent variable... + dropCond := -1; //initially compute full model, then compute effect of removing individual conditions + firth := true; + n := numSubj; + k := numCond + 1; + //get memory + //beta := TMatrix.Create(n,1); + //design our model + //first row = 1: ell samples have equal weight + for i := 1 to n do + x.M[1,i] := 1; + //next load model into x + iter := 0; + for j := 2 to k do + for i := 1 to n do begin + inc(iter); + x.M[j,i] := xin^[iter]; + end; + //WriteMatrix('Observations',y); + //WriteMatrix('Model',x); + //negx is just sing-swapped - we will generate this as we use it a lot... + for j := 1 to k do + for i := 1 to n do begin + negx.M[j,i] := -x.M[j,i]; + end; + //now start computations + sumy := 0; + for i := 1 to n do + sumy := sumy + round(yin[i,1]); + if (sumy <= 0) or (sumy >= n) then begin + //serious error: no variability. This should have been detected earlier in the procedure when yin was tested for variability + goto 666; + end; + beta0 := ln((sumy/n)/(1 - sumy/n));//initial estimate +123: //go here for each dropcond + if DropCond >= 0 then begin + betak.Ones; + betak.mult( 0) //start with a null model... does not really make sense + end else begin + betak.zero; + betak[1,1] := (beta0); + end; + iter := 0; + if DropCond >= 0 then begin //drop one of the factors... + if dropCond <> 0 then begin//include intercept + for i := 1 to n do + XXx.M[1,i] := 1; + lCond := 1; + end else + lCond := 0; + for j := 1 to NumCond do begin + if j <> DropCond then begin + inc(lCond); + for i := 1 to n do + XXx.M[lCond,i] := x.M[j+1,i]; + end; //if j <> dropCond + end; + end;//if lDropCond >= 0 + loglik := ComputeLogLik; + repeat + inc(iter); + ComputeFisher; + HPrime.mult(XWPrime,covs); + H.mult(HPrime,XW2); + //WriteMatrix(covs); + ustar.Sub(yin,pi); + if firth then + Diag2Vec; + crossprodustar; + if dropCond >= 0 then // model with dropped factor + computedropdelta; + deltat.mult(covs,ustarmat); + delta.transpose(deltat); + mx := delta.MatAbsMax/MaxStep; + if mx > 1 then + delta.mult(mx);//scale delta + betak.add(delta); + loglikold := loglik; + halfs := 1; + while halfs <= maxhs do begin // Half-Steps + //fx(iter,halfs,loglik); + loglik := ComputeLogLik; + deltahalfs.mult(delta,power(2,-halfs)); + betak.sub(deltahalfs); + if (loglik > loglikold) then + break; + inc(halfs); + end; + if delta.MatAbsMax <= epsilon then break; + until (iter >= maxit); + //fx(DropCond,loglik); + //done with this model - record model fit + if DropCond < 0 then + finalloglik^[k] := loglik //full model + else begin + finalloglik^[DropCond] := loglik; //model with a factor removed + end; + if DropCond < numCond then begin + inc(DropCond); + if (DropCond = 0) and (not lComputeIntercept) then //only compute intercept model if requested + inc(DropCond); + goto 123; + + end; + //finally - results + + //ResultsForm.Memo1.lines.add (inttostr(j)+' cases have Y=0, '+inttostr(n-j)+' cases have Y=1'); + if lComputeIntercept then + J := 0 + else + J := 1; + for i := J to (k-1) do begin + lZVals^[i] := abs(2*(finalloglik^[i]-finalloglik^[k])); + //find direction of effect - does a larger value of the IV predict more zeros or ones + lZVals^[i] := pNormalInv(ChiSq(lZVals^[i],1)); + //we have now computed a Z scores - but Chi is one tailed, so all Z > 0... lets check direction + Sumy0 := 0; + Sumy1 := 0; + for iter := 1 to n do begin + if yin[iter,1] = 0 then + Sumy0 := Sumy0 + x.M[i+1,iter] //+1: M indexed from 1, ZVal indexed from 0 + else + Sumy1 := Sumy1 + x.M[i+1,iter]; //+1 M indexed from 1 + end; + //compute means + Sumy1 := Sumy1/sumy; + Sumy0 := Sumy0/(n-sumy); + if Sumy0 < Sumy1 then //negative z-scores: damage here predicts performance is BETTER + lZVals^[i] := -lZVals^[i]; + end; + (*if lComputeIntercept then //intercept is the 0th value + lChiVals[0] := abs(2*(finalloglik[0]-finalloglik[k])); + for i := 1 to (k-1) do //k-1 as this is indexed from 0 + lChiVals[i] := abs(2*(finalloglik[i]-finalloglik[k])); *) + +666: +end; + +//FirthAnalyzeNoThread (lnCond,lnCrit, lnPermute,1,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg); + +procedure FirthAnalyzeNoThread(lnCond, lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); +//calls logistf (yin,xin: SingleP; var lChivals: SingleP0; numSubj,numCond: integer); +label +666; +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lObs: Bytep; + lPrevZVals: array [1..knPrevPattern] of SingleP0; + lZVals: SingleP0; + lPatternPos,lC,lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnCritLocal,n,k: integer; +(* myFile : TextFile; +procedure Hdr2File; +var + myI: integer; +begin + for myI := 1 to (lImagesCount*lnCond ) do begin + write(myFile, floattostr(lSymptomRA^[myI])+kTab); + end; + WriteLn(myFile, ''); +end; + +procedure Data2File; +var + myI: integer; +begin + for myI := 1 to (lImagesCount ) do begin + write(myFile, inttostr(round(yIn[myI,1]))+kTab); + end; + WriteLn(myFile, ''); +end; *) + +begin //statthread + (*Assign(myFile,'/Users/rorden/logreg.txt'); + ReWrite(myFile); + Hdr2File; *) + lnCritLocal := lnCrit; + if lnCritLocal < 1 then + lnCritLocal := 1; + Getmem(lObs,lImagesCount*sizeof(byte)); + Getmem(lZVals,(lnCond+1)*sizeof(single)); + for lPos := 1 to knPrevPattern do + Getmem(lPrevZVals[lPos],(lnCond+1)*sizeof(single)); + n := lImagesCount; + k := lnCond + 1; + yin:= TMatrix.Create(n,1); + GetMem(finalloglik,(k+1)*sizeof(single));//finalloglik := TVector.Create(k+1); + x := TMatrix.Create (k, n); +betak:=TMatrix.Create(1,k); +covs:=TMatrix.Create(k,k); +delta:=TMatrix.Create(1,k); +deltahalfs:=TMatrix.Create(1,k); +deltat:=TMatrix.Create(k,1); +Fisher:=TMatrix.Create(k,k); +H:=TMatrix.Create(n,n); +HPrime:=TMatrix.Create(n,k); +negx:=TMatrix.Create(k,n); +pi:=TMatrix.Create(n,1); +ustar:=TMatrix.Create(n,1); +ustarmat:=TMatrix.create(k,1); +W:=TMatrix.Create(n,n); +xbeta:=TMatrix.Create(1,n); +XW2:=TMatrix.Create(k,n); +//XWPrime:=TMatrix.Create(k,n); +XWPrime:=TMatrix.Create(n,k); +XXcovs:=TMatrix.Create(k-1,k-1); +XXFisher:=TMatrix.Create(k-1,k-1); +XXx:=TMatrix.Create(k-1,n); +XXXW2:=TMatrix.Create(k-1,n); +//XXXWPrime:=TMatrix.Create(k-1,n); +XXXWPrime := TMatrix.Create ( n, k-1); +KxKA := TMatrix.Create(k,k); +KxKB := TMatrix.Create(k,k); +Kvec := TVector.Create(k); +Kveci := TVectori.Create(k); +KxKA1 := TMatrix.Create(k-1,k-1); +KxKB1 := TMatrix.Create(k-1,k-1); +Kvec1 := TVector.Create(k-1); +Kveci1 := TVectori.Create(k-1); + + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) or ((gnVoxTestedRA[lThread] mod 100) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100), gnVoxTestedRA[lThread]); + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + + for lPos := 1 to lImagesCount do begin + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] = 0 then begin + //no lesion + yin[lPos,1] := 0; + lObs^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lObs^[lPos] := 1; + yin[lPos,1] := 1; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCritLocal) and (lnLesion < lImagesCount) then begin + lPattern := SetOrderX (lObs,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin + + //logistfx(lObs,lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lPrevZvals[lPos]^[lC]; + end else begin //new pattern - need to compute + inc(gnVoxTestedRA[lThread]); + //logistfx(lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lZvals^[lC]; + lPrevPatternRA[lPatternPos] := lPattern; + for lC := 1 to lnCond do + lPrevZVals[lPatternPos]^[lC] := lZvals^[lC]; + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + + end; //new pattern + end; //nlesion > nCritical + + end; //for each voxel + //gMat := false; +666: + freemem(lObs); + for lPos := 1 to knPrevPattern do + freemem(lPrevZVals[lPos]); + freemem(lZVals); + +yin.free; +x.free; +betak.free; +covs.free; +delta.free; +deltahalfs.free; +deltat.free; +Fisher.free; +H.free; +HPrime.free; +negx.free; +pi.free; +ustar.free; +ustarmat.Free; +W.free; +xbeta.free; +XW2.free; +XWPrime.free; +XXcovs.free; +XXFisher.free; +XXx.free; +XXXW2.free; +XXXWPrime.free; +KxKA.free; +KxKB.free; +Kvec.free; +Kveci.free; +KxKA1.free; +KxKB1.free; +Kvec1.free; +Kveci1.free; + + freemem(finalloglik); + +end; + +end. + \ No newline at end of file diff --git a/npm/firth.ppu b/npm/firth.ppu new file mode 100644 index 0000000..8a4cc7a Binary files /dev/null and b/npm/firth.ppu differ diff --git a/npm/firthThds.o b/npm/firthThds.o new file mode 100644 index 0000000..a4714a3 Binary files /dev/null and b/npm/firthThds.o differ diff --git a/npm/firthThds.pas b/npm/firthThds.pas new file mode 100755 index 0000000..70eb78f --- /dev/null +++ b/npm/firthThds.pas @@ -0,0 +1,648 @@ +unit firthThds; +//Unit for running penalized multiple logistic regression +//creates multiple threads +//Requires firth +interface +{$Include ..\common\isgui.inc} +uses + //ComCtrls,Graphics, ExtCtrls, + {$IFDEF GUI}ComCtrls, {$ENDIF} + Classes, define_types,{stats,}StatThdsUtil,lesion_pattern,Mat,Math,Distr,Vector,dialogsx,Forms,SysUtils; + +type + + TMultiRegThread = class(TThread) + private + finalloglik: SingleP0; + KxKA1,KxKB1,KxKA,KxKB :TMatrix; + Kvec,Kvec1 : TVector; + Kveci,kVeci1 : TVectori; + betak,xbeta,y,pi,ustar, + XXx,XXXW2,XXFisher,XXcovs,XXXWPrime, + deltahalfs,deltat,delta,covs,x,Fisher,XW2,W,XWprime,Hprime,H,ustarmat,negx: TMatrix; + lBarX: TProgressBar; + lFormX: TForm; + lShowProgressX: boolean; + lnCondx,lnCritx,lBarPosX,lTestPosX, lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx : integer; + lPlankImgx: byteP;lOutImgMnx,lSymptomRAx: SingleP; + lOutImgX: SingleRAp; + //lBarX: TProgressBar; + procedure DoVisualSwap; + protected + procedure Execute; override; + + procedure VisualProg(lPos,lTestNumber: Integer); + procedure Analyze(lnCond,lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP; lOutImg: SingleRAp); virtual; abstract; + public + constructor Create(lShowProgress: boolean; lForm: TForm; lBar: TProgressBar; lnCond,lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: byteP;lOutImgMn,lSymptomRA: SingleP; lOutImg: SingleRAp); + end; + + TFirthThreadStat = class(TMultiRegThread ) + protected + procedure Analyze(lnCond,lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP; lOutImg: SingleRAp); override; + procedure logistfx (xin: SingleP; var lZvals: SingleP0; numSubj,numCond: integer; lComputeIntercept: boolean); + + end; + + +implementation + +procedure TMultiRegThread .DoVisualSwap; +begin + lBarX.Position := lBarPosX; + lFormX.Caption := inttostr(lTestPosX); +end; + +procedure TMultiRegThread.VisualProg(lPos,lTestNumber: Integer); +begin + lBarPosX := lPos; + lTestPosX := lTestNumber; + //NPMTitleMsg(inttostr(lTestNumber)); + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} +end; + +constructor TMultiRegThread.Create(lShowProgress: boolean; lForm: TForm; lBar: TProgressBar; lnCond,lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); +begin + lShowProgressX := lShowProgress; + lBarX := lBar; + lFormX := lForm; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgX := lOutImg; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + lnCondX := lnCond; + FreeOnTerminate := True; + inherited Create(False); +end; + +{ The Execute method is called when the thread starts } + +procedure TMultiRegThread .Execute; +begin + Analyze(lnCondX,lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lPlankImgX,lOutImgMnx,lSymptomRAx,lOutImgX); +end; + + +procedure TFirthThreadStat.logistfx (xin: SingleP; var lZvals: SingleP0; numSubj,numCond: integer; lComputeIntercept: boolean); +//todo zero output incase exit +//yin = 1..numSubj binary 0/1 values +//xin = numSubj*numCond predictors +//Chivals = 0..numCond p-values - the 0th Khi-value is the intercept +// [0th value will not be computed if ; lComputeIntercept= false] +label + 123,666; +const + maxit = 25; + maxhs = 5; + epsilon = 0.0001; + maxstep = 10; +var + SumY0,SumY1,mx, beta0,loglik,loglikold: double; + sumy, n, i,j, k, iter,halfs,lCond,dropCond: integer; + variability,firth: boolean; +procedure crossprodustar; +var + inc,row: integer; +begin + for row := 1 to k do begin + ustarmat[row,1] := 0; + for inc := 1 to ustar.r do + ustarmat[row,1] := ustarmat[row,1] + (x[row,inc]*ustar[inc,1]); + end; +end; +procedure Diag2Vec; +var + inc: integer; +begin + for inc := 1 to pi.r do + ustar[inc,1] := ustar[inc,1]+ H[inc,inc]*(0.5-pi[inc,1]); +end; //nested DiagP2 +procedure DiagP2 (var W, P: TMatrix); +var + inc: integer; +begin + W.Zero; + for inc := 1 to P.r do + W[inc,inc] := Power((P[inc,1] * (1-P[inc,1])),0.5) ; +end; //nested DiagP2 +procedure ComputeFisher; +begin + DiagP2(W,pi); + XW2.mult(x,W); + //XWPrime.copy( XW2); + //XWPrime.transpose; + XWPrime.transpose(XW2); + Fisher.mult(XW2,XWPrime); + covs.copy( Fisher); + covs.Invert2(KxKA,KxKB,Kvec,Kveci) +end; //nested computeFisher + +procedure computedropdelta; +var + jinc,iinc,ii,jj: integer; +begin + DiagP2(W,pi); + XXXW2.mult(XXx,W); + //XXXWPrime.copy( XXXW2); + //XXXWPrime.transpose; + XXXWPrime.transpose(XXXW2); + XXFisher.mult(XXXW2,XXXWPrime); + XXcovs.copy( XXFisher); + //XXcovs.Invert; + XXcovs.Invert2(KxKA1,KxKB1,Kvec1,Kveci1); + covs.Zero; + ii := 0; + for iinc := 1 to (k) do begin + if iinc <> (dropCond+1) then begin //leave the specified column zeros... + inc(ii); + jj := 0; + for jinc := 1 to (k) do begin + if jinc <> (dropCond+1) then begin + inc(jj); + covs[iinc,jinc] := xxCovs[ii,jj]; + end; + end; + end; + end; +end; +function firthpenalty: double; +begin + ComputeFisher; + //result := 0.5 * ln(abs(Fisher.det)); + result := 0.5 * ln(abs(Fisher.Det2(KxKA,kVeci,kVec))); +end; //nested firthpenalty +function ComputeLogLik: double; +var + inc: integer; +begin + xbeta.mult(betak,negx); + for inc := 1 to n do + pi[inc,1] := (1/(1 + exp( xbeta[inc,1]))); + result := 0; + for inc := 1 to n do + if y[inc,1] = 1 then + result := result+ln(pi[inc,1]); + for inc := 1 to n do + if y[inc,1] = 0 then + result := result+ln(1-pi[inc,1]); + if firth then + result := result + firthpenalty; +end;//nested ComputeLogLik +begin + for i := 0 to (numCond) do + lZVals^[i] := 0; // + if (numSubj < 2) or (numCond < 1) then + exit; + //ensure there is some variability in the input data... + variability := false; + i := 1; + repeat + inc(i); + if xin^[i] <> xin^[1] then + variability := true; + until (i= (numSubj*numCond)) or (variability); + if not variability then + exit; //no variance in the regressors... + variability := false; + i := 1; + repeat + inc(i); + if y[i,1] <> y[1,1] then + variability := true; + until (i= (numSubj)) or (variability); + if not variability then + exit; //no variance in the dependent variable... + dropCond := -1; //initially compute full model, then compute effect of removing individual conditions + firth := true; + n := numSubj; + k := numCond + 1; + //get memory + //beta := TMatrix.Create(n,1); + //design our model + //first row = 1: ell samples have equal weight + for i := 1 to n do + x.M[1,i] := 1; + //next load model into x + iter := 0; + for j := 2 to k do + for i := 1 to n do begin + inc(iter); + x.M[j,i] := xin^[iter]; + end; + //WriteMatrix('Observations',y); + //WriteMatrix('Model',x); + //negx is just sing-swapped - we will generate this as we use it a lot... + for j := 1 to k do + for i := 1 to n do begin + negx.M[j,i] := -x.M[j,i]; + end; + //now start computations + sumy := 0; + for i := 1 to n do + sumy := sumy + round(y[i,1]); + if (sumy <= 0) or (sumy >= n) then begin + //serious error: no variability. This should have been detected earlier in the procedure when yin was tested for variability + goto 666; + end; + beta0 := ln((sumy/n)/(1 - sumy/n));//initial estimate +123: //go here for each dropcond + if DropCond >= 0 then begin + betak.Ones; + betak.mult( 0) //start with a null model... does not really make sense + end else begin + betak.zero; + betak[1,1] := (beta0); + end; + iter := 0; + if DropCond >= 0 then begin //drop one of the factors... + if dropCond <> 0 then begin//include intercept + for i := 1 to n do + XXx.M[1,i] := 1; + lCond := 1; + end else + lCond := 0; + for j := 1 to NumCond do begin + if j <> DropCond then begin + inc(lCond); + for i := 1 to n do + XXx.M[lCond,i] := x.M[j+1,i]; + end; //if j <> dropCond + end; + end;//if lDropCond >= 0 + loglik := ComputeLogLik; + repeat + inc(iter); + ComputeFisher; + HPrime.mult(XWPrime,covs); + H.mult(HPrime,XW2); + //WriteMatrix(covs); + ustar.Sub(y,pi); + if firth then + Diag2Vec; + crossprodustar; + if dropCond >= 0 then // model with dropped factor + computedropdelta; + deltat.mult(covs,ustarmat); + delta.transpose(deltat); + mx := delta.MatAbsMax/MaxStep; + if mx > 1 then + delta.mult(mx);//scale delta + betak.add(delta); + loglikold := loglik; + halfs := 1; + while halfs <= maxhs do begin // Half-Steps + //fx(iter,halfs,loglik); + loglik := ComputeLogLik; + deltahalfs.mult(delta,power(2,-halfs)); + betak.sub(deltahalfs); + if (loglik > loglikold) then + break; + inc(halfs); + end; + if delta.MatAbsMax <= epsilon then break; + until (iter >= maxit); + //fx(DropCond,loglik); + //done with this model - record model fit + if DropCond < 0 then + finalloglik^[k] := loglik //full model + else begin + finalloglik^[DropCond] := loglik; //model with a factor removed + end; + if DropCond < numCond then begin + inc(DropCond); + if (DropCond = 0) and (not lComputeIntercept) then //only compute intercept model if requested + inc(DropCond); + goto 123; + + end; + //finally - results + + //ResultsForm.Memo1.lines.add (inttostr(j)+' cases have Y=0, '+inttostr(n-j)+' cases have Y=1'); + if lComputeIntercept then + J := 0 + else + J := 1; + for i := J to (k-1) do begin + lZVals^[i] := abs(2*(finalloglik^[i]-finalloglik^[k])); + //find direction of effect - does a larger value of the IV predict more zeros or ones + lZVals^[i] := pNormalInv(ChiSq(lZVals^[i],1)); + //we have now computed a Z scores - but Chi is one tailed, so all Z > 0... lets check direction + Sumy0 := 0; + Sumy1 := 0; + for iter := 1 to n do begin + if y[iter,1] = 0 then + Sumy0 := Sumy0 + x.M[i+1,iter] //+1: M indexed from 1, ZVal indexed from 0 + else + Sumy1 := Sumy1 + x.M[i+1,iter]; //+1 M indexed from 1 + end; + //compute means + Sumy1 := Sumy1/sumy; + Sumy0 := Sumy0/(n-sumy); + if Sumy0 < Sumy1 then //negative z-scores: damage here predicts performance is BETTER + lZVals^[i] := -lZVals^[i]; + end; + (*if lComputeIntercept then //intercept is the 0th value + lChiVals[0] := abs(2*(finalloglik[0]-finalloglik[k])); + for i := 1 to (k-1) do //k-1 as this is indexed from 0 + lChiVals[i] := abs(2*(finalloglik[i]-finalloglik[k])); *) + +666: +end; + +{Firth penalized logisitic regression} +procedure TFirthThreadStat.Analyze(lnCond, lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); +//calls logistf (yin,xin: SingleP; var lChivals: SingleP0; numSubj,numCond: integer); +label +666; +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lObs: Bytep; + lPrevZVals: array [1..knPrevPattern] of SingleP0; + lZVals: SingleP0; + lPatternPos,lC,lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnCritLocal,n,k: integer; +begin //statthread + + lnCritLocal := lnCrit; + if lnCritLocal < 1 then + lnCritLocal := 1; + Getmem(lObs,lImagesCount*sizeof(byte)); + Getmem(lZVals,(lnCond+1)*sizeof(single)); + for lPos := 1 to knPrevPattern do + Getmem(lPrevZVals[lPos],(lnCond+1)*sizeof(single)); + n := lImagesCount; + k := lnCond + 1; + y := TMatrix.Create(n,1); + GetMem(finalloglik,(k+1)*sizeof(single));//finalloglik := TVector.Create(k+1); + x := TMatrix.Create (k, n); +betak:=TMatrix.Create(1,k); +covs:=TMatrix.Create(k,k); +delta:=TMatrix.Create(1,k); +deltahalfs:=TMatrix.Create(1,k); +deltat:=TMatrix.Create(k,1); +Fisher:=TMatrix.Create(k,k); +H:=TMatrix.Create(n,n); +HPrime:=TMatrix.Create(n,k); +negx:=TMatrix.Create(k,n); +pi:=TMatrix.Create(n,1); +ustar:=TMatrix.Create(n,1); +ustarmat:=TMatrix.create(k,1); +W:=TMatrix.Create(n,n); +xbeta:=TMatrix.Create(1,n); +XW2:=TMatrix.Create(k,n); +//XWPrime:=TMatrix.Create(k,n); +XWPrime:=TMatrix.Create(n,k); +XXcovs:=TMatrix.Create(k-1,k-1); +XXFisher:=TMatrix.Create(k-1,k-1); +XXx:=TMatrix.Create(k-1,n); +XXXW2:=TMatrix.Create(k-1,n); +//XXXWPrime:=TMatrix.Create(k-1,n); +XXXWPrime := TMatrix.Create ( n, k-1); +KxKA := TMatrix.Create(k,k); +KxKB := TMatrix.Create(k,k); +Kvec := TVector.Create(k); +Kveci := TVectori.Create(k); +KxKA1 := TMatrix.Create(k-1,k-1); +KxKB1 := TMatrix.Create(k-1,k-1); +Kvec1 := TVector.Create(k-1); +Kveci1 := TVectori.Create(k-1); + + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lShowProgressX) and ( ((lPos2 mod lPosPct) = 0) or ((lPos2 mod 200) = 0) ) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100),lPos2); + if Terminated then exit; + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] = 0 then begin + //no lesion + y[lPos,1] := 0; + lObs^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lObs^[lPos] := 1; + y[lPos,1] := 1; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCritLocal) and (lnLesion < lImagesCount) then begin + lPattern := SetOrderX (lObs,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin + inc(gnVoxTestedRA[lThread]); + //logistf(lObs,lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lPrevZvals[lPos]^[lC]; + end else begin //new pattern - need to compute + inc(gnVoxTestedRA[lThread]); + logistfx(lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lZvals^[lC]; + lPrevPatternRA[lPatternPos] := lPattern; + for lC := 1 to lnCond do + lPrevZVals[lPatternPos]^[lC] := lZvals^[lC]; + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + + end; //new pattern + end; //nlesion > nCritical + end; //for each voxel + //gMat := false; +666: + freemem(lObs); + for lPos := 1 to knPrevPattern do + freemem(lPrevZVals[lPos]); + freemem(lZVals); + +y.free; +x.free; +betak.free; +covs.free; +delta.free; +deltahalfs.free; +deltat.free; +Fisher.free; +H.free; +HPrime.free; +negx.free; +pi.free; +ustar.free; +ustarmat.Free; +W.free; +xbeta.free; +XW2.free; +XWPrime.free; +XXcovs.free; +XXFisher.free; +XXx.free; +XXXW2.free; +XXXWPrime.free; +KxKA.free; +KxKB.free; +Kvec.free; +Kveci.free; +KxKA1.free; +KxKB1.free; +Kvec1.free; +Kveci1.free; + + freemem(finalloglik); + +end; (* + +{Firth penalized logisitic regression} +procedure TFirthThreadStat .Analyze(lnCond, lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg,lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); +//calls logistf (yin,xin: SingleP; var lChivals: SingleP0; numSubj,numCond: integer); +var + lPattern,lPrevPattern: TLesionPattern; + lObs: Singlep; + lZVals,lPrevZVals: SingleP0; + lC,lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnCritLocal,n,k: integer; +begin //statthread + lnCritLocal := lnCrit; + if lnCritLocal < 1 then + lnCritLocal := 1; + Getmem(lObs,lImagesCount*sizeof(single)); + Getmem(lZVals,(lnCond+1)*sizeof(single)); + Getmem(lPrevZVals,(lnCond+1)*sizeof(single)); + n := lImagesCount; + k := lnCond + 1; + y := TMatrix.Create(n,1); + GetMem(finalloglik,(k+1)*sizeof(single));//finalloglik := TVector.Create(k+1); + x := TMatrix.Create (k, n); +betak:=TMatrix.Create(1,k); +covs:=TMatrix.Create(k,k); +delta:=TMatrix.Create(1,k); +deltahalfs:=TMatrix.Create(1,k); +deltat:=TMatrix.Create(k,1); +Fisher:=TMatrix.Create(k,k); +H:=TMatrix.Create(n,n); +HPrime:=TMatrix.Create(n,k); +negx:=TMatrix.Create(k,n); +pi:=TMatrix.Create(n,1); +ustar:=TMatrix.Create(n,1); +ustarmat:=TMatrix.create(k,1); +W:=TMatrix.Create(n,n); +xbeta:=TMatrix.Create(1,n); +XW2:=TMatrix.Create(k,n); +//XWPrime:=TMatrix.Create(k,n); +XWPrime:=TMatrix.Create(n,k); +XXcovs:=TMatrix.Create(k-1,k-1); +XXFisher:=TMatrix.Create(k-1,k-1); +XXx:=TMatrix.Create(k-1,n); +XXXW2:=TMatrix.Create(k-1,n); +//XXXWPrime:=TMatrix.Create(k-1,n); +XXXWPrime := TMatrix.Create ( n, k-1); +KxKA := TMatrix.Create(k,k); +KxKB := TMatrix.Create(k,k); +Kvec := TVector.Create(k); +Kveci := TVectori.Create(k); +KxKA1 := TMatrix.Create(k-1,k-1); +KxKB1 := TMatrix.Create(k-1,k-1); +Kvec1 := TVector.Create(k-1); +Kveci1 := TVectori.Create(k-1); + //gMat := true; + lPosPct := (lThreadEnd-lThreadStart) div 100; + lPrevPattern := EmptyOrder; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + y[lPos,1] := 0; + lObs[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lObs[lPos] := 1; + y[lPos,1] := 1; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCritLocal) and (lnLesion < lImagesCount) then begin + lPattern := SetOrder (lObs,lImagesCount); + if SameOrder(lPattern,lPrevPattern,lImagesCount) then begin + inc(gnVoxTestedRA[lThread]); + //logistf(lObs,lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lPrevZvals[lC]; + end else begin //new pattern - need to compute + inc(gnVoxTestedRA[lThread]); + logistfx(lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lZvals[lC]; + end; + lPrevPattern := lPattern; + for lC := 1 to lnCond do + lPrevZVals[lC] := lZvals[lC]; + end; + end; //for each voxel + //gMat := false; + freemem(lObs); + freemem(lPrevZVals); + freemem(lZVals); +y.free; +x.free; +betak.free; +covs.free; +delta.free; +deltahalfs.free; +deltat.free; +Fisher.free; +H.free; +HPrime.free; +negx.free; +pi.free; +ustar.free; +ustarmat.Free; +W.free; +xbeta.free; +XW2.free; +XWPrime.free; +XXcovs.free; +XXFisher.free; +XXx.free; +XXXW2.free; +XXXWPrime.free; +KxKA.free; +KxKB.free; +Kvec.free; +Kveci.free; +KxKA1.free; +KxKB1.free; +Kvec1.free; +Kveci1.free; + + freemem(finalloglik); + +end; (**) + + + + + + +end. \ No newline at end of file diff --git a/npm/firthThds.ppu b/npm/firthThds.ppu new file mode 100644 index 0000000..f17a17f Binary files /dev/null and b/npm/firthThds.ppu differ diff --git a/npm/fpc-res.or b/npm/fpc-res.or new file mode 100755 index 0000000..9675a09 Binary files /dev/null and b/npm/fpc-res.or differ diff --git a/npm/fpc-res.res b/npm/fpc-res.res new file mode 100755 index 0000000..e521788 Binary files /dev/null and b/npm/fpc-res.res differ diff --git a/npm/hdr.o b/npm/hdr.o new file mode 100644 index 0000000..e7c01d2 Binary files /dev/null and b/npm/hdr.o differ diff --git a/npm/hdr.pas b/npm/hdr.pas new file mode 100755 index 0000000..c952df6 --- /dev/null +++ b/npm/hdr.pas @@ -0,0 +1,587 @@ +unit hdr; +interface +{$H+} +{$Include ..\common\isgui.inc} +uses nifti_hdr,define_types,classes, unpm, nifti_types; + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TniftiHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +procedure MakeHdr (var lBGHdr,lStatHdr: TniftiHdr); +function NIFTIhdr_SaveHdrImg (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2,lSingleFile: boolean;var lImg: SingleP; lnVol: integer): boolean; +function NIFTIhdr_SaveHdrImg8 (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2,lSingleFile: boolean;var lImg: ByteP; lnVol: integer): boolean; + +function Files4D (lFilename: string): boolean; +function Vol4D (lFilename: string): integer; +function FileExists4D (lFilename: string): boolean; +function Filename4D(lFilename: string): string; +function FilenameVol4D (lFilename: string; var lBaseName: string; var lVol: integer): boolean; +function NIFTIhdr_HdrVolumes (lFilenameIn: string): integer; +function BPP (lDataType: integer): integer; +function CreateDecompressed4D(var lImageNames: TStrings): string; +function CheckVoxels(var lHdrNameIn : string; lMaskVoxels, lImageNumber: integer):boolean; +//function CheckVoxelsGroupX(var lG: TStrings; lMaskVoxels: integer):boolean; +function CheckVoxelsGroupX(var lG: TStrings; lMaskHdr: TMRIcroHdr): boolean; +//function CheckVoxelsGroupY(var lG: TStrings):boolean; + +procedure DeleteDecompressed4D(lDecomName: string); +implementation +uses +{$IFDEF FPC} gzio2,Controls, +{$ELSE} {gzio,ZLib,}DiskSpaceKludge,gziod,{$ENDIF} +{$IFNDEF UNIX}Windows, {$ENDIF} +{$IFDEF GUI}Dialogs,{$ENDIF} + Dialogsx ,SysUtils,StatThdsUtil; +//define_types,GraphicsMathLibrary; +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} + + +procedure DeleteDecompressed4D(lDecomName: string); +begin + if lDecomName = '' then + exit; + if not fileexists(lDecomName) then + exit; + sysutils.deletefile(lDecomName); +end; + +function CheckVoxels(var lHdrNameIn : string; lMaskVoxels, lImageNumber: integer):boolean; +var + lHdr: TMRIcroHdr; + lHdrName: string; + lVox: integer; +begin + result := false; + lHdrName := Filename4D(lHdrNameIn); + if not NIFTIhdr_LoadHdr(lHdrName,lHdr) then begin + NPMmsg('Unable to load image '+lHdrName); + exit; + end; + lVox := ComputeImageDataBytes8bpp(lHdr); + if lVox <> lMaskVoxels then begin + NPMmsg('Voxels differ for '+lHdrName+' expected '+inttostr(lMaskVoxels)+' described '+inttostr(lVox)); + exit; + end; + if UpCaseExt(lHdrName) = '.HDR' then + lHdrName := changefileext(lHdrName,'.img'); + if (not GzExt(lHdrName) ) and (FSize(lHdrName) < lMaskVoxels) then begin + ShowMsg('The uncompressed image data should be at least '+inttostr(lMaskVoxels)+' bytes. '+lHdrName); + exit; + end; + result := true; + + if (lImageNumber < 0) or (lImageNumber > kMaxImages) then exit; + gDataTypeRA[lImageNumber] := lHdr.NIFTIhdr.datatype; + gOffsetRA[lImageNumber] := lHdr.NIFTIhdr.vox_offset; + gScaleRA[lImageNumber] := lHdr.NIFTIhdr.scl_slope; + gInterceptRA[lImageNumber] := lHdr.NIFTIhdr.scl_inter; +end; + +(*function CheckVoxelsGroup(var lG: TStrings; lMaskVoxels: integer):boolean; +var + lC: integer; + lHdrName : string; +begin + result := false; + if lG.count < 1 then exit; + for lC := 1 to lG.count do begin + lHdrName:= lG[lC-1]; + result := CheckVoxels(lHdrName, lMaskVoxels,lC); + end; +end;*) +(*function CheckVoxelsGroup(var lG: TStrings; lMaskVoxels: integer):boolean; +var + lC: integer; + lHdrName : string; +begin + result := false; + if lG.count < 1 then exit; + + for lC := 1 to lG.count do begin + lHdrName:= lG[lC-1]; + if not CheckVoxels(lHdrName, lMaskVoxels,lC) then begin + if not fileexists (lHdrName) then + MainForm.NPMmsg('File not found "'+lHdrName+'"') + + else + MainForm.NPMmsg('Problem with "'+lHdrName+'" expected '+inttostr(lMaskVoxels)); + exit; + end; + end; + result := true; +end;*) +function SameTransform (A,B:TNIFTIhdr): boolean; +var + lDim: integer; +begin + result := false; + for lDim := 0 to 3 do begin + if A.srow_x[lDim] <> B.srow_x[lDim] then + exit; + if A.srow_y[lDim] <> B.srow_y[lDim] then + exit; + if A.srow_z[lDim] <> B.srow_z[lDim] then + exit; + end; + result := true; +end; + +function TransformTxt (A:TNIFTIhdr): string; +var + lDim: integer; +begin + result := '['; + for lDim := 0 to 3 do + result := result + ' '+floattostr(A.srow_x[lDim]); + result := result + ';'; + for lDim := 0 to 3 do + result := result + ' '+floattostr(A.srow_y[lDim]); + result := result + ';'; + for lDim := 0 to 3 do + result := result + ' '+floattostr(A.srow_z[lDim]); + result := result + ']'; +end; + +function CheckVoxelsX(var lHdrNameIn : string; lMaskHdr: TMRIcroHdr; lImageNumber: integer):boolean; +var + lHdr: TMRIcroHdr; + lHdrName: string; + lDim: integer; +begin + result := false; + lHdrName := Filename4D(lHdrNameIn); + if not NIFTIhdr_LoadHdr(lHdrName,lHdr) then begin + NPMmsg('Unable to load image '+lHdrName+' Possible solution: make sure VAL file and images are in the same folder'); + exit; + end; + (*lVox := ComputeImageDataBytes8bpp(lHdr); + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if lVox <> lMaskVoxels then begin + NPMmsg('Voxels differ for '+lHdrName+' expected '+inttostr(lMaskVoxels)+' described '+inttostr(lVox)); + exit; + end; *) + for lDim := 1 to 3 do begin + if (lHdr.NIFTIhdr.dim[lDim] <> lMaskHdr.NIFTIhdr.dim[lDim]) then begin + NPMmsg('Dimension '+inttostr(lDim)+' of '+lHdrName+' does not match '+lMaskHdr.HdrFileName); + exit; + end; + end; + if (not lHdr.NIfTItransform) then + NPMmsg('Warning: no spatial transform for '+lHdrName+' (Analyze not NIfTI). Please ensure images are coregistered.') + else if (not lMaskHdr.NIfTItransform) then + NPMmsg('Warning: no spatial transform for '+lMaskHdr.HdrFileName+' (Analyze not NIfTI). Please ensure images are coregistered.') + else begin + if not SameTransform (lHdr.NIFTIhdr, lMaskHdr.NIFTIhdr) then begin + NPMmsg('Warning: spatial transforms differ for '+lHdrName+' and '+lMaskHdr.HdrFileName); + NPMmsg(TransformTxt(lHdr.NIFTIhdr)+' <> '+ TransformTxt(lMaskHdr.NIFTIhdr)); + end; + end; + (*if (lHdr.NIFTIhdr.bitpix <> 8) and (lHdr.NIFTIhdr.datatype <> kDT_FLOAT) and (lHdr.NIFTIhdr.datatype <> kDT_SIGNED_INT) then begin + showmessage('Error: This software can only read uncompressed images that are either 8-bit integer or 32-bit real precision.'); + exit; + end; //beta *) + if UpCaseExt(lHdrName) = '.HDR' then + lHdrName := changefileext(lHdrName,'.img'); + if (not GzExt(lHdrName) ) and (FSize(lHdrName) < (lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]*lHdr.NIFTIhdr.dim[3])) then begin + ShowMsg('The file size appears too small '+lHdrName); + exit; + end; + result := true; + //gBitPixRA[lImageNumber] := lHdr.NIFTIhdr.bitpix; + gDataTypeRA[lImageNumber] := lHdr.NIFTIhdr.datatype; + gOffsetRA[lImageNumber] := lHdr.NIFTIhdr.vox_offset; + gScaleRA[lImageNumber] := lHdr.NIFTIhdr.scl_slope; + gInterceptRA[lImageNumber] := lHdr.NIFTIhdr.scl_inter; +end; + +function CheckVoxelsGroupX(var lG: TStrings; lMaskHdr: TMRIcroHdr):boolean; +var + lC: integer; + lHdrName : string; +begin + result := false; + if lG.count < 1 then exit; + + for lC := 1 to lG.count do begin + lHdrName:= lG[lC-1]; + if not CheckVoxelsX(lHdrName, lMaskHdr,lC) then begin + if not fileexists (lHdrName) then + NPMmsg('File not found "'+lHdrName+'". Possible solution: make sure VAL file and images are in the same folder') + + else + NPMmsg('Problem with "'+lHdrName); + exit; + end; + end; + result := true; +end; + +(*function CheckVoxelsGroupY(var lG: TStrings):boolean; +var + lMaskHdr: TMRIcroHdr; + lS: string; +begin + result := false; + if lG.count < 1 then exit; + lS := lG[0]; + if not NIFTIhdr_LoadHdr(lS,lMaskHdr) then begin + NPMmsg('Unable to load image '+lS); + exit; + end; + result := CheckVoxelsGroupX(lG,lMaskHdr); +end; *) + +function BPP (lDataType: integer): integer; +begin + result := 0; + case lDataType of + kDT_UNSIGNED_CHAR: result := 1; + kDT_SIGNED_SHORT: result := 2; // signed short (16 bits/voxel) + kDT_SIGNED_INT : result := 4; // signed int (32 bits/voxel) + kDT_FLOAT : result := 4; // float (32 bits/voxel) + kDT_COMPLEX : result := 8; // complex (64 bits/voxel) + end; +end; + + +function NIFTIhdr_HdrVolumes (lFilenameIn: string): integer; +var + lFilename: string; + lHdr: TMRIcroHdr; +begin + result := 0; + lFilename := lFilenameIn; + if not NIFTIhdr_LoadHdr (lFilename, lHdr)then exit; + result := lHdr.niftiHdr.dim[4]; +end; + +function FileExists4D (lFilename: string): boolean; +var +lBaseName: string; var lVol: integer; +begin + FilenameVol4D (lFilename, lBasename,lVol); + result := fileexists(lBasename); +end; + +function FilenameVol4D (lFilename: string; var lBaseName: string; var lVol: integer): boolean; +//4D files end with the image index number c:\dir\filename:1 +//returns true if 4D file (with lVol = volume), otherwise returns false with lvol = 1 +var + lLen,lP: integer; + lNumStr: string; +begin + lVol := 1; + lBasename := lFilename; + result := false; + lLen := length(lFilename); + if lLen < 1 then exit; + lP := lLen; + lNumStr := ''; + while (lP > 0) and (lFilename[lP] in ['0'..'9']) do begin + lNumStr := lFilename[lP]+lNumStr; + dec(lP); + end; + //showmessage(lNumStr + '*'+lFilename[lP]); + if (lNumStr = '') or (lP < 2) or (lFilename[lP] <> ':') then exit; + lVol := strtoint(lNumStr); + lLen := lP -1; + lBasename := ''; + for lP := 1 to lLen do + lBasename := lBasename + lFilename[lP]; + result := true; +end; + +function Filename4D(lFilename: string): string; +var lVol: integer; +begin + FilenameVol4D (lFilename, result,lVol); +end; + +function Vol4D (lFilename: string): integer; +var +lBaseName: string; +begin + FilenameVol4D (lFilename, lBasename,result); +end; + +function Files4D (lFilename: string): boolean; +var +lBaseName: string; var lVol: integer; +begin + result := FilenameVol4D (lFilename, lBasename,lVol); +end; + +function CreateDecompressed4D(var lImageNames: TStrings): string; +//returns temp filename if all imagenames are a single compressed 4D datafile +//this means that a nii.gz file is only decompressed once, instead of once per volume*plank +var + lP: integer; + lFilename : string; +begin + result := ''; + if lImageNames.Count < 2 then + exit; + if not Files4D(lImageNames.Strings[0]) then exit; + lFilename := Filename4D(lImageNames.Strings[0]); + if not Fileexists(lFilename) then + exit; + if not GzExt(lFilename) then + exit; //not a decompressed file + //see if single 4D image + for lP := 2 to lImageNames.Count do + if not Files4D(lImageNames.Strings[lP-1]) then + exit; + for lP := 2 to lImageNames.Count do + if lFilename <> Filename4D(lImageNames.Strings[lP-1]) then + exit; + //find unique filename for extracted file + result := lFilename +'.nii'; + while fileexists(result) do //make sure we do not overwrite anything + result := lFilename +inttostr(random(9999))+'.nii'; + //unzip + Gunzip(lFilename,result); + //set image names to point to uncompressed volume + for lP := 1 to lImageNames.Count do + lImageNames.Strings[lP-1] := result +':'+inttostr(Vol4D(lImageNames.Strings[lP-1]) ); +end; + + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TniftiHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +var lIntentNameLen,lPos: integer; + lStr: string; +begin + move(lBGHdr,lStatHdr,sizeof(TniftiHdr)); + with lStatHdr do begin + magic :=kNIFTI_MAGIC_SEPARATE_HDR; + bitpix := 32; //32-bit real data + datatype := kDT_FLOAT; + scl_slope:= 1; + scl_inter:= 0; + glmin := round(lMinIntensity); + glmax := round(lMaxIntensity); + intent_code := lIntent_Code;// kNIFTI_INTENT_ESTIMATE; + intent_p1 := lIntent_p1; + intent_p2 := lIntent_p2; + intent_p3 := lIntent_p3; + lIntentNameLen := length(lIntentName); + descrip[1] := 'N'; + descrip[2] := 'P'; + descrip[3] := 'M'; + if lIntent_code=kNIFTI_INTENT_TTEST then begin + descrip[4] := 't' ; + lStr := inttostr(trunc(lIntent_p1)); + for lPos := 1 to length (lStr) do + descrip[4+lPos] := lStr[lPos] ; + end else + descrip[4] := 'z'; + if lIntentNameLen > sizeof(intent_name) then + lIntentNameLen := sizeof(intent_name); + if lIntentNameLen > 0 then + for lPos := 1 to lIntentNameLen do + intent_name[lPos] := lIntentName[lPos]; + end; +end; + + + +procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lNiftiHdr: TNIFTIHdr; var lImg: SingleP; lnVolIn,lImgBufferBPP: integer); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +var + lHdr: TNIFTIhdr; + lBuff: ByteP; + lF: File; + lCompressedFilename,lExt: string; + lnVol,lC,lFSize: integer; + lImgBuffer: ByteP; lImgBufferItems{, lImgBufferBPP}: integer; +begin + lnVol := lnVolIn; + move(lNiftiHdr,lHdr,sizeof(lHdr)); + lImgBufferItems := lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3]; + //lImgBufferBPP:= 4; + lImgBuffer := ByteP(lImg); + lExt := UpCaseExt(lFileName); + if DiskFreeEx(lFilename) < (kImgOffset+(lImgBufferItems*lImgBufferBPP*lnVol)) then begin + {$IFDEF GUI} + + case MsgDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation,[mbYes, mbCancel], 0) of + {$IFDEF FPC}mrCancel: exit; {$ELSE} id_Cancel: exit;{$ENDIF} + end; //case + {$ELSE} + ShowMsg('Very little space on the selected drive. Data may be lost.'); + {$ENDIF} + end; + if FileExistsEX(lFileName) then begin + {$IFDEF GUI} + if (ParamCount < 1) then begin + case MsgDlg('Overwrite the file named '+lFileName+'?', mtConfirmation,[mbYes, mbCancel], 0) of //MessageDlg + {$IFDEF FPC}mrCancel: exit; {$ELSE} id_Cancel: exit;{$ENDIF} //requires Uses Controls + end; //case + end else begin + NPMMsg('Warning: overwriting '+lFilename); + + end; + {$ELSE} + ShowMsg('Warning: overwriting '+lFilename); + {$ENDIF} + DeleteFile(lFilename); + end; //file exists + if (lExt='.VOI') then begin + lHdr.intent_name[1] := 'B';//Binary + lHdr.scl_slope := 1/kVOI8bit; + lHdr.scl_inter := 0; + end; + if lnVol < 2 then begin + lHdr.dim[0] := 3;//3D july2006 + lHdr.dim[4] := 1;//3D Aug 2007 + lnVol := 1; + end else begin + lHdr.dim[0] := 4;//3D july2006 + lHdr.dim[4] := lnVol;//3D july2006 + end; + (*if not (lImgBufferItems = (lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3])) then begin //july2006 + lHdr.sform_code := 1; + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + end;*) + if not IsNifTiMagic(lHdr) then begin + {lHdr.sform_code := 1; + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + } + end; + case lImgBufferBPP of + 4: begin + lHdr.bitpix := 32; + lHdr.datatype := kDT_FLOAT;//note 32-bit integers saved internally as 32-bit float + end; + 2: begin + lHdr.bitpix := 16; + lHdr.datatype := kDT_SIGNED_SHORT; + end; + 1: begin + lHdr.bitpix := 8; + lHdr.datatype := kDT_UNSIGNED_CHAR; + //lHdr.scl_inter := lHdr.WindowScaledMin; + //lHdr.scl_slope := (lHdr.WindowScaledMax-lHdr.WindowScaledMin) /255; + end; + else begin + showmsg('Error: Unsupported bytes per voxel: '+inttostr(lImgBufferBPP)); + exit; + end; + end; + if (lExt='.IMG') or (lExt ='.HDR') then begin + //done previously lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + lHdr.vox_offset := 0; + Filemode := 1; + //next write header data as .hdr + lFilename := changeFileExt(lFilename,'.hdr'); + AssignFile(lF, lFileName); + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lHdr, 1); + CloseFile(lF); + //next write image data as .img + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lImgBufferItems*lImgBufferBPP*lnVol); + BlockWrite(lF,lImgBuffer^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //separate header + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lHdr.vox_offset := kImgOffset;//352 bytes + lFSize := kImgOffset+(lImgBufferItems*lImgBufferBPP*lnVol); + getmem(lBuff,lFSize); + move(lHdr,lBuff^,sizeof(lHdr)); + //Next: NIfTI 1.1 requires bytes 349..352 set to zero when no XML information + lC := kImgOffset; + lBuff^[lC-3] := 0; + lBuff^[lC-2] := 0; + lBuff^[lC-1] := 0; + lBuff^[lC] := 0; + lC := kImgOffset+1; + move(lImgBuffer^[1],lBuff^[lC],lImgBufferItems*lImgBufferBPP*lnVol); + if (lExt='.NII') then begin + Filemode := 1; + AssignFile(lF, lFileName); + Rewrite(lF,lFSize); + BlockWrite(lF,lBuff^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //uncompressed + if (lExt<>'.VOI') then + lCompressedFilename := changefileextX(lFilename,'.nii.gz') + else + lCompressedFilename := lFilename; + + + GZipBuffer(lCompressedFilename,lBuff,lFSize,false); + freemem(lBuff); +end; + + +procedure MakeHdr (var lBGHdr,lStatHdr: TniftiHdr); +//lIntent kNIFTI_INTENT_CHISQ lIntent_p1 = DOF +//lIntent kNIFTI_INTENT_ZSCORE no params +//lIntent kNIFTI_INTENT_TTEST lIntent_p1 = DOF +begin + move(lBGHdr,lStatHdr,sizeof(TniftiHdr)); + with lStatHdr do begin + magic :=kNIFTI_MAGIC_SEPARATE_HDR; + bitpix := 32; //32-bit real data + datatype := kDT_FLOAT; + scl_slope:= 1; + scl_inter:= 0; + descrip[1] := 'X';//can not be npm + end; +end; + +function NIFTIhdr_SaveHdrImg (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2,lSingleFile: boolean;var lImg: SingleP; lnVol: integer): boolean; +var + lOutNameMod: string; + lSPM2output: boolean; +begin + lOutNameMod := lFilename; + lOutNameMod := changefileextX(lOutNameMod,'.hdr'); + lSPM2output := lSPM2; + //fx(lHdr.srow_x[3],lHdr.srow_y[3],lHdr.srow_z[3]); + (*if not IsNifTiMagic(lHdr) then + lSPM2output := true;*) + if (lSingleFile) and (not lSPM2output) then begin + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lOutNameMod := changefileextX(lOutNameMod,'.nii.gz'); + //HACK lOutNameMod := changefileextX(lOutNameMod,'.nii'); + + end else if (not lSPM2output) then + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR + else //the nifti_hdr reader converts the Analyze to NIfTI, so we need to save as NIfTI with NPM + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + //lHdr.magic := 1984; + SaveAsVOIorNIFTIcore (lOutNameMod, lHdr, lImg,lnVol,4); +end; + +function NIFTIhdr_SaveHdrImg8 (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2,lSingleFile: boolean;var lImg: ByteP; lnVol: integer): boolean; +var + lOutNameMod: string; +begin + lOutNameMod := lFilename; + if IsVOIExt (lOutNameMod) then begin + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + end else begin + lOutNameMod := changefileextX(lOutNameMod,'.hdr'); + if (lSingleFile) and (not lSPM2) then begin + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lOutNameMod := changefileextX(lOutNameMod,'.nii.gz'); + end else if (not lSPM2) then + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR + else + lHdr.magic := 1984; + end; + SaveAsVOIorNIFTIcore (lOutNameMod, lHdr, SingleP(lImg),lnVol,1); +end; + +end. \ No newline at end of file diff --git a/npm/hdr.ppu b/npm/hdr.ppu new file mode 100644 index 0000000..a063d16 Binary files /dev/null and b/npm/hdr.ppu differ diff --git a/npm/lesion_pattern.o b/npm/lesion_pattern.o new file mode 100644 index 0000000..4924123 Binary files /dev/null and b/npm/lesion_pattern.o differ diff --git a/npm/lesion_pattern.pas b/npm/lesion_pattern.pas new file mode 100755 index 0000000..bab15c1 --- /dev/null +++ b/npm/lesion_pattern.pas @@ -0,0 +1,107 @@ +unit lesion_pattern; + +interface +uses define_types; + +Type + TLesionPattern = RECORD + lowest, lo,hi,highest : int64; + end; + +function SetOrderX (var lObs: Bytep; var lObsCount: integer): TLesionPattern ; +function SameOrder(lO1,lO2: TLesionPattern; lObsCount: integer): boolean; +function EmptyOrder: TLesionPattern; +procedure SetBit(lPos: integer; var lVal: TLesionPattern); + +const + kMaxBit = 63; + kMaxBitx2 = 2*kMaxBit; + kMaxBitx3 = 3*kMaxBit; + + kMaxObs = {126}kMaxBit*4; +implementation + + + +var + lPowerRA: array [1..kMaxBit] of int64; + + + +procedure SetBit(lPos: integer; var lVal: TLesionPattern); +begin + if (lPos <= kMaxBit) then + lVal.Lowest := lVal.Lowest + lPowerRA[lPos] + else if (lPos <= kMaxBitx2) then + lVal.Lo := lVal.Lo + lPowerRA[lPos-kMaxBit] + else if (lPos <= kMaxBitx3) then + lVal.Hi := lVal.Hi + lPowerRA[lPos-kMaxBitx2] + else + lVal.Highest := lVal.Highest + lPowerRA[lPos-kMaxBitx3]; +end; + +function EmptyOrder: TLesionPattern; +begin + result.lowest := 0; + result.lo := 0; + result.hi := 0; + result.highest := 0; +end; + +function SameOrder(lO1,lO2: TLesionPattern; lObsCount: integer): boolean; +begin + result := false; + if lObsCount > kMaxObs then + exit; + if (lO1.lowest = lo2.lowest) and (lO1.highest = lO2.highest) and (lO1.lo = lo2.lo) and (lO1.hi = lO2.hi) then + result := true + else + result := false; +end; + +(*function SetOrder (var lObs: Singlep; var lObsCount: integer): TLesionPattern ; +var + lPos: integer; +begin + result := EmptyOrder; + if ( lObsCount > kMaxObs) or (lObsCount < 1) then + exit; + for lPos := 1 to lObsCount do + if lObs[lPos] <> 0 then + SetBit(lPos,result); +end; + +function SetOrderI (var lObs: LongIntp; var lObsCount: integer): TLesionPattern ; +var + lPos: integer; +begin + result := EmptyOrder; + if ( lObsCount > kMaxObs) or (lObsCount < 1) then + exit; + for lPos := 1 to lObsCount do + if lObs[lPos] <> 0 then + SetBit(lPos,result); +end;*) + +function SetOrderX (var lObs: Bytep; var lObsCount: integer): TLesionPattern ; +var + lPos: integer; +begin + result := EmptyOrder; + if ( lObsCount > kMaxObs) or (lObsCount < 1) then + exit; + for lPos := 1 to (lObsCount) do + if lObs^[lPos] <> 0 then + SetBit(lPos,result); +end; + + + +var +lPowerPos: integer; +initialization + lPowerRA[1] := 1; + for lPowerPos := 2 to kMaxBit do + lPowerRA[lPowerPos] := lPowerRA[lPowerPos-1]*2; + +end. diff --git a/npm/lesion_pattern.ppu b/npm/lesion_pattern.ppu new file mode 100644 index 0000000..827f83c Binary files /dev/null and b/npm/lesion_pattern.ppu differ diff --git a/npm/montecarlo.pas b/npm/montecarlo.pas new file mode 100755 index 0000000..fdd1d5e --- /dev/null +++ b/npm/montecarlo.pas @@ -0,0 +1,197 @@ +unit montecarlo; +interface +{$H+} +{$DEFINE anacom} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogsx, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes{$IFDEF anacom} ,anacom{$ENDIF}; + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); + +implementation + +uses npmform,filename,turbolesion; + +procedure RandomGroup(kSamplesPerTest: integer;lImageNames: TStrings;lSymptomRA: SingleP;var lPartImageNames: TStrings; var lPartSymptomRA: SingleP); +var + lTotal,lInc,lRand,lSwap: integer; + lRanOrder: longintP; +begin + lPartImageNames.Clear; + lTotal := lImageNames.Count; + if kSamplesPerTest > lTotal then begin + showmessage('Monte carlo error: population must be larger than sample size.'); + exit; + end; + Getmem(lRanOrder,lTotal*sizeof(longint)); + for lInc := 1 to lTotal do + lRanOrder^[lInc] := lInc; + for lInc := lTotal downto 2 do begin + lRand := Random(lInc)+1; + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc]; + lRanOrder^[lInc] := lSwap; + end; + for lInc := 1 to kSamplesPerTest do begin + lPartImageNames.Add(lImageNames.Strings[lRanOrder^[lInc]-1]);//indexed from 0 + lPartSymptomRA^[lInc] := lSymptomRA^[lRanOrder^[lInc]]; + end; + Freemem(lRanOrder); +end; + + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); +label + 666; +const + kSimSampleSize = 64; + knSim = 2; + kCrit = 3; + {$IFDEF anacom} + knControls = 64; + {$ENDIF} +var + lPrefs: TLDMPrefs ; + lSim,lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lPartImageNames,lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname,lOutNameSim: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA,lPartSymptomRA: singleP; + {$IFDEF anacom} + lnControlObservations: integer; + lControlSymptomRA: singleP; + {$ENDIF} +begin + //lBinomial := not odd( (Sender as tMenuItem).tag); + lPrefs.NULP := true{gNULP false}; + if not lBinomial then begin + lPrefs.BMtest := lbm;//BMmenu.checked; + lPrefs.Ttest := lttest;//ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.nCrit := kCrit; + lPrefs.nPermute := 0;//MainForm.ReadPermute;; + lPrefs.Run := 0;{0 except for montecarlo} + if (not lBinomial) and (not lTTest) and (not lBM) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPartImageNames := TStringList.Create; + getmem(lPartSymptomRA,kSimSampleSize*sizeof(single)); + {$IFDEF anacom} + lnControlObservations := knControls; + getmem(lControlSymptomRA,lnControlObservations*sizeof(single)); + for lSim := 1 to lnControlObservations do + lControlSymptomRA^[lSim] := 1000; + {$ENDIF} + //next, get 1st group + if not MainForm.GetValX(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit{,binom},lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) or (lnSubjAll < kSimSampleSize) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') [sample size is '+inttostr(kSimSampleSize)+']or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + //randomization loop.... + for lSim := 1 to knSim do begin + RandomGroup(kSimSampleSize, lImageNames,lSymptomRA, lPartImageNames, lPartSymptomRA); + lOutNameSim := AddIndexToFilename(lOutName,lSim); + lnCrit := kCrit; + MainForm.NPMMsgClear; + //Msg(GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to kSimSampleSize do + MainForm.NPMMsg (lPartImageNames.Strings[lSubj-1] + ' = '+realtostr(lPartSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(kSimSampleSize)); + if not CheckVoxelsGroup(lPartImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lPrefs.Run := lSim; + if lBinomial then + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim) + else begin + MainForm.ReportDescriptives(lPartSymptomRA,lnSubj); + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim); + {$IFDEF anacom} + AnacomLesionNPMAnalyze (lPartImageNames, lMaskHdr, lnCrit,lSim,lnControlObservations, lPartSymptomRA,lControlSymptomRA, lFactname,lOutNameSim,true,false); + {$ENDIF} + end; + end; //for each simulation... + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lPartImageNames.free; + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + freemem(lPartSymptomRA); + {$IFDEF anacom} + freemem(lControlSymptomRA); + {$ENDIF} + DeleteDecompressed4D(lTemp4D); +end; + + + +end. + + diff --git a/npm/nifti_img.o b/npm/nifti_img.o new file mode 100644 index 0000000..2d47756 Binary files /dev/null and b/npm/nifti_img.o differ diff --git a/npm/nifti_img.pas b/npm/nifti_img.pas new file mode 100755 index 0000000..2cf59f0 --- /dev/null +++ b/npm/nifti_img.pas @@ -0,0 +1,425 @@ +unit nifti_img; +interface +{$Include ..\common\isgui.inc} +uses hdr,define_types,Classes,nifti_hdr,sysutils,dialogsx, unpm, nifti_types +{$IFDEF FPC},gzio2 +{$ELSE} +,gziod +{$ENDIF} +; + +{$H+} +function LoadImg(lInName: string; lImgData: SingleP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; + +function LoadImg8(lInName: string; lImgData: ByteP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; + + +implementation + + +function LoadImg(lInName: string; lImgData: SingleP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +var + lvox_offset,lInc,lFSize,lP2: integer; + lFData: file; + lImgName: string; + lByteP: ByteP; + lSmallIntP: SmallIntP; + lV,lMin,lMax: single; +begin + result := false; + + if (lStart >= lEnd) or (lStart < 1) or (lEnd < 1) then begin + NPMmsg('Error: LoadImg '+inttostr(lStart)+'>='+inttostr(lEnd)+' or zero'); + exit; + end; + if Files4D(lInName) then begin + lImgName := Filename4D(lInName); + lP2 := BPP (lDataType); + if lP2 = 0 then begin + ShowMsg(lImgName +' is an unsupported file type'); + exit; + end; + lvox_offset := linvox_offset+ ((Vol4D(lInName)-1)* (lP2 * lVolVox)); + end else begin + lImgName := lInName; + lvox_offset := linvox_offset; + end; + if UpCaseExt(lImgName) = '.HDR' then + lImgName := changefileext(lImgName,'.img'); + lFSize := FSize(lImgName); + if (not GzExt(lImgName)) and (lFSize < (lEnd+ lvox_offset)) then begin + NPMmsg('Error: LoadImg '+lImgName+' FSize = '+inttostr(lFSize)+' Expected '+inttostr(lEnd+ lvox_offset)); + exit; + end; + filemode := 0; + if GzExt(lImgName) then begin + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + UnGZip(lImgName,lByteP,lvox_offset+lStart-1,(lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + //getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(smallint)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(smallint)),((lEnd+1)-lStart)*sizeof(smallint)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*2)+1 ; + lImgData^[lRApos+lInc-1] := makesmallint(lByteP^[lP2],lByteP^[lP2+1]); + end; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + lByteP := ByteP(@lImgData^[lRApos]); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + + (*getmem(lByteP, ((lEnd+1)-lStart)*sizeof(single)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lImgData^[lRApos+lInc-1] := makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + //lImgData^[lRApos+lInc-1] := makesingle(lByteP^[lP2+3],lByteP^[lP2+2],lByteP^[lP2+1],lByteP^[lP2]); + end; + freemem(lByteP); *) + //test range + (*lINc := 1; + lMin := lImgData^[lRApos+lInc-1]; + lMax := lMin; + for lInc := 1 to ((lEnd+1)-lStart) do begin + lV := lImgData^[lRApos+lInc-1]; + if lV > lMax then + lMax := lV; + if lV < lMin then + lMin := lMax; + end; + MainForm.NPMmsg(inttostr(lvox_offset)+' '+realtostr(lMin,8)+' '+realtostr(lMax,8)); *) + + + //end + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := conv4r4i (lImgData^[lRApos+lInc-1]); + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do + if specialsingle(lImgData^[lRApos+lInc-1])then + lImgData^[lRApos+lInc-1] := 0; + end; + end else begin + ShowMsg(lImgName + ' is an unsupported compressed data type '+inttostr(lDataType)); + exit; + end; + end else begin + assignfile(lFdata,lImgName); + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + reset(lFdata,1); //12/2010 + seek(lFdata,lvox_offset+lStart-1); + BlockRead(lFdata, lByteP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + reset(lFdata,2); + if (lvox_offset mod 2) <> 0 then begin + ShowMsg('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 2)+ (lStart-1)); + BlockRead(lFdata, lSmallIntP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lSmallIntP^[lInc]; + freemem(lSmallIntP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + //next: 4 byte data + reset(lFdata,4); + if (lvox_offset mod 4) <> 0 then begin + ShowMsg('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 4)+ (lStart-1) ); + BlockRead(lFdata, lImgData[lRApos], (lEnd+1)-lStart); + + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := conv4r4i (lImgData^[lRApos+lInc-1]); + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do + if specialsingle(lImgData^[lRApos+lInc-1]) then + lImgData^[lRApos+lInc-1] := 0; + end; + end else + ShowMsg('Unsupported COMPRESSED data type '+inttostr(lDataType)); + closefile(lFdata); + end; //not gz + result := true; +end; + +(*function LoadImgx(lInName: string; lImgData: SingleP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +var + lvox_offset,lInc,lFSize,lP2: integer; + lFData: file; + lImgName: string; + lByteP: ByteP; + lSmallIntP: SmallIntP; + lV,lMin,lMax: single; +begin + + result := false; + if (lStart >= lEnd) or (lStart < 1) or (lEnd < 1) then begin + MainForm.NPMmsg('Error: LoadImg '+inttostr(lStart)+'>='+inttostr(lEnd)+' or zero'); + exit; + end; + if Files4D(lInName) then begin + lImgName := Filename4D(lInName); + lP2 := BPP (lDataType); + if lP2 = 0 then begin + ShowMsg(lImgName +' is an unsupported file type'); + exit; + end; + lvox_offset := linvox_offset+ ((Vol4D(lInName)-1)* (lP2 * lVolVox)); + end else begin + lImgName := lInName; + lvox_offset := linvox_offset; + end; + if UpCaseExt(lImgName) = '.HDR' then + lImgName := changefileext(lImgName,'.img'); + lFSize := FSize(lImgName); + if (not GzExt(lImgName)) and (lFSize < (lEnd+ lvox_offset)) then begin + MainForm.NPMmsg('Error: LoadImg '+lImgName+' FSize = '+inttostr(lFSize)+' Expected '+inttostr(lEnd+ lvox_offset)); + exit; + end; + filemode := 0; + if GzExt(lImgName) then begin + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + UnGZip(lImgName,lByteP,lvox_offset+lStart-1,(lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + //getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(smallint)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(smallint)),((lEnd+1)-lStart)*sizeof(smallint)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*2)+1 ; + lImgData^[lRApos+lInc-1] := makesmallint(lByteP^[lP2],lByteP^[lP2+1]); + end; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + lByteP := ByteP(@lImgData^[lRApos]); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + + {getmem(lByteP, ((lEnd+1)-lStart)*sizeof(single)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lImgData^[lRApos+lInc-1] := makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + //lImgData^[lRApos+lInc-1] := makesingle(lByteP^[lP2+3],lByteP^[lP2+2],lByteP^[lP2+1],lByteP^[lP2]); + end; + freemem(lByteP);} + //test range + {lINc := 1; + lMin := lImgData^[lRApos+lInc-1]; + lMax := lMin; + for lInc := 1 to ((lEnd+1)-lStart) do begin + lV := lImgData^[lRApos+lInc-1]; + if lV > lMax then + lMax := lV; + if lV < lMin then + lMin := lMax; + end; + MainForm.NPMmsg(inttostr(lvox_offset)+' '+realtostr(lMin,8)+' '+realtostr(lMax,8)); } + + + //end + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := conv4r4i (lImgData^[lRApos+lInc-1]); + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do + if specialsingle(lImgData^[lRApos+lInc-1])then + lImgData^[lRApos+lInc-1] := 0; + end; + end else begin + ShowMsg(lImgName + ' is an unsupported compressed data type '+inttostr(lDataType)); + exit; + end; + end else begin + assignfile(lFdata,lImgName); + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + reset(lFdata,1); + seek(lFdata,lvox_offset+lStart-1); + BlockRead(lFdata, lByteP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + reset(lFdata,2); + if (lvox_offset mod 2) <> 0 then begin + ShowMsg('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 2)+ (lStart-1)); + BlockRead(lFdata, lSmallIntP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lSmallIntP^[lInc]; + freemem(lSmallIntP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + //next: 4 byte data + reset(lFdata,4); + if (lvox_offset mod 4) <> 0 then begin + ShowMsg('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 4)+ (lStart-1) ); + BlockRead(lFdata, lImgData[lRApos], (lEnd+1)-lStart); + + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := conv4r4i (lImgData^[lRApos+lInc-1]); + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do + if specialsingle(lImgData^[lRApos+lInc-1]) then + lImgData^[lRApos+lInc-1] := 0; + end; + end else + ShowMsg('Unsupported COMPRESSED data type '+inttostr(lDataType)); + closefile(lFdata); + end; //not gz + result := true; +end; *) + +function LoadImg8(lInName: string; lImgData: ByteP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +//loads BINARY data - ignore scaling: zero or not zero +var + lvox_offset,lInc,lFSize,lP2: integer; + lFData: file; + lImgName: string; + lByteP: ByteP; + lSmallIntP: SmallIntP; + lSingle: single; +begin + result := false; + if (lStart >= lEnd) or (lStart < 1) or (lEnd < 1) then begin + NPMmsg('Error: LoadImg '+inttostr(lStart)+'>='+inttostr(lEnd)+' or zero'); + exit; + end; + if Files4D(lInName) then begin + lImgName := Filename4D(lInName); + lP2 := BPP (lDataType); + if lP2 = 0 then begin + ShowMsg(lImgName +' is an unsupported file type'); + exit; + end; + lvox_offset := linvox_offset+ ((Vol4D(lInName)-1)* (lP2 * lVolVox)); + end else begin + lImgName := lInName; + lvox_offset := linvox_offset; + end; + if UpCaseExt(lImgName) = '.HDR' then + lImgName := changefileext(lImgName,'.img'); + lFSize := FSize(lImgName); + if (not GzExt(lImgName)) and (lFSize < (lEnd+ lvox_offset)) then begin + NPMmsg('Error: LoadImg '+lImgName+' FSize = '+inttostr(lFSize)+' Expected '+inttostr(lEnd+ lvox_offset)); + exit; + end; + filemode := 0; + //zero array + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := 0;//makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + + if GzExt(lImgName) then begin + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + UnGZip(lImgName,lByteP,lvox_offset+lStart-1,(lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + //getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(smallint)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(smallint)),((lEnd+1)-lStart)*sizeof(smallint)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*2)+1 ; + lImgData^[lRApos+lInc-1] := makesmallint(lByteP^[lP2],lByteP^[lP2+1]); + end; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(single)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lSingle := conv4r4i (makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3])); + if lSingle <> 0 then + lImgData^[lRApos+lInc-1] := 1; + end; + end else begin //32 bit float + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lSingle := makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + if (not specialsingle(lSingle)) and (lSingle <> 0) then + lImgData^[lRApos+lInc-1] := 1; + end; + end; + freemem(lByteP); + end else begin + ShowMsg(lImgName + ' is an unsupported compressed data type '+inttostr(lDataType)); + exit; + end; + end else begin + assignfile(lFdata,lImgName); + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + reset(lFdata,1); + seek(lFdata,lvox_offset+lStart-1); + BlockRead(lFdata, lByteP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + reset(lFdata,2); + if (lvox_offset mod 2) <> 0 then begin + ShowMsg('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 2)+ (lStart-1)); + BlockRead(lFdata, lSmallIntP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lSmallIntP^[lInc]; + freemem(lSmallIntP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + //next: 4 byte data + reset(lFdata,4); + if (lvox_offset mod 4) <> 0 then begin + ShowMsg('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 4)+ (lStart-1) ); + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(single)); + //fx(((lEnd+1)-lStart)*sizeof(single)); + BlockRead(lFdata, lByteP^, ((lEnd+1)-lStart)); + //April 2009 + //UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lSingle := conv4r4i (makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3])); + if lSingle <> 0 then + lImgData^[lRApos+lInc-1] := 1; + end; + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lSingle := makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + if (not specialsingle(lSingle)) and (lSingle <> 0) then + lImgData^[lRApos+lInc-1] := 1; + end; + end; + freemem(lByteP); + + end else + ShowMsg('Unsupported COMPRESSED data type '+inttostr(lDataType)); + closefile(lFdata); + end; //not gz + result := true; +end; + +end. \ No newline at end of file diff --git a/npm/nifti_img.ppu b/npm/nifti_img.ppu new file mode 100644 index 0000000..45dc024 Binary files /dev/null and b/npm/nifti_img.ppu differ diff --git a/npm/npm b/npm/npm new file mode 100755 index 0000000..04aa3c5 Binary files /dev/null and b/npm/npm differ diff --git a/npm/npm.app/Contents/Info.plist b/npm/npm.app/Contents/Info.plist new file mode 100644 index 0000000..d57d9df --- /dev/null +++ b/npm/npm.app/Contents/Info.plist @@ -0,0 +1,45 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>CFBundleDevelopmentRegion</key> + <string>English</string> + <key>CFBundleExecutable</key> + <string>npm</string> + <key>CFBundleName</key> + <string>npm</string> + <key>CFBundleIdentifier</key> + <string>com.company.npm</string> + <key>CFBundleInfoDictionaryVersion</key> + <string>6.0</string> + <key>CFBundlePackageType</key> + <string>APPL</string> + <key>CFBundleSignature</key> + <string>npm?</string> + <key>CFBundleShortVersionString</key> + <string>0.1</string> + <key>CFBundleVersion</key> + <string>1</string> + <key>CSResourcesFileMapped</key> + <true/> + <key>CFBundleDocumentTypes</key> + <array> + <dict> + <key>CFBundleTypeRole</key> + <string>Viewer</string> + <key>CFBundleTypeExtensions</key> + <array> + <string>*</string> + </array> + <key>CFBundleTypeOSTypes</key> + <array> + <string>fold</string> + <string>disk</string> + <string>****</string> + </array> + </dict> + </array> + <key>NSHighResolutionCapable</key> + <true/> +</dict> +</plist> diff --git a/npm/npm.app/Contents/MacOS/npm b/npm/npm.app/Contents/MacOS/npm new file mode 120000 index 0000000..20acbf9 --- /dev/null +++ b/npm/npm.app/Contents/MacOS/npm @@ -0,0 +1 @@ +../../../npm \ No newline at end of file diff --git a/npm/npm.app/Contents/PkgInfo b/npm/npm.app/Contents/PkgInfo new file mode 100644 index 0000000..6f749b0 --- /dev/null +++ b/npm/npm.app/Contents/PkgInfo @@ -0,0 +1 @@ +APPL???? diff --git a/npm/npm.cfg b/npm/npm.cfg new file mode 100755 index 0000000..b8a3ee8 --- /dev/null +++ b/npm/npm.cfg @@ -0,0 +1,39 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-LN"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-U"..\common;..\delphionly;C:\pas\mricron\fpmath" +-O"..\common;..\delphionly;C:\pas\mricron\fpmath" +-I"..\common;..\delphionly;C:\pas\mricron\fpmath" +-R"..\common;..\delphionly;C:\pas\mricron\fpmath" diff --git a/npm/npm.compiled b/npm/npm.compiled new file mode 100755 index 0000000..ecff007 --- /dev/null +++ b/npm/npm.compiled @@ -0,0 +1,5 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <Compiler Value="/usr/local/bin/ppc386" Date="1393445779"/> + <Params Value=" -MObjFPC -Scgi -O1 -Xs -XX -k-framework -kCarbon -k-framework -kOpenGL -k-dylib_file -k/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib -l -vewnhibq -Fu/Users/rorden/Documents/pas/mricron/fpmath -Fu/Users/rorden/Documents/pas/mricron/common -Fu/Developer/lazarus/lcl/units/i386-darwin/carbon -Fu/Developer/lazarus/lcl/units/i386-darwin -Fu/Developer/lazarus/components/lazutils/lib/i386-darwin -Fu/Developer/lazarus/packager/units/i386-darwin -Fu/Users/rorden/Documents/pas/mricron/npm/ -dLCL -dLCLcarbon npm.lpr"/> +</CONFIG> diff --git a/npm/npm.dof b/npm/npm.dof new file mode 100755 index 0000000..6f2cb20 --- /dev/null +++ b/npm/npm.dof @@ -0,0 +1,144 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=1 +UnsafeCode=1 +UnsafeCast=1 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath=..\common;..\delphionly;C:\pas\mricron\fpmath +Packages=Vcl40;Vclx40;VclSmp40;Qrpt40;Vcldb40;RxCtl4 +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= +[HistoryLists\hlUnitAliases] +Count=1 +Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[HistoryLists\hlSearchPath] +Count=3 +Item0=..\common;..\delphionly;C:\pas\mricron\fpmath +Item1=C:\pas\mricron\common;C:\pas\mricron\fpmath +Item2=C:\pas\mricron\common diff --git a/npm/npm.dpr b/npm/npm.dpr new file mode 100755 index 0000000..3c2dcbe --- /dev/null +++ b/npm/npm.dpr @@ -0,0 +1,29 @@ +program npm; + +uses + Forms, + npmform in 'npmform.pas' {MainForm}, + stats in 'stats.pas', + spread in 'spread.pas' {SpreadForm}, + design in 'design.pas' {DesignForm}, + valformat in 'valformat.pas', + ReadInt in 'ReadInt.pas' {ReadIntForm}, + firth in 'firth.pas', + roc in 'roc.pas', + prefs in 'prefs.pas'; + +{$R *.RES} +{$IFNDEF FPC} +{$R windowsxp.res} + +{$ENDIF} + +begin + Application.Initialize; + Application.Title := 'NPM'; + Application.CreateForm(TMainForm, MainForm); + Application.CreateForm(TSpreadForm, SpreadForm); + Application.CreateForm(TDesignForm, DesignForm); + Application.CreateForm(TReadIntForm, ReadIntForm); + Application.Run; +end. diff --git a/npm/npm.ini b/npm/npm.ini new file mode 100755 index 0000000..72a7f95 --- /dev/null +++ b/npm/npm.ini @@ -0,0 +1,11 @@ +[BOOL] +computettest=1 +computebm=0 +countlesionpatterns=1 +ROI=1 + +[INT] +CacheMB=888 +nPermute=4000 +nThread=2 +TFCE=0 diff --git a/npm/npm.lpi b/npm/npm.lpi new file mode 100755 index 0000000..8767ac1 --- /dev/null +++ b/npm/npm.lpi @@ -0,0 +1,649 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <LRSInOutputDirectory Value="False"/> + </Flags> + <MainUnit Value="0"/> + </General> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="70"> + <Unit0> + <Filename Value="npm.lpr"/> + <IsPartOfProject Value="True"/> + <CursorPos X="34" Y="11"/> + <UsageCount Value="111"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit0> + <Unit1> + <Filename Value="npmform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MainForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="1"/> + <TopLine Value="2177"/> + <CursorPos X="16" Y="2191"/> + <UsageCount Value="111"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit1> + <Unit2> + <Filename Value="nifti_hdr.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="358"/> + <CursorPos X="49" Y="368"/> + <UsageCount Value="107"/> + </Unit2> + <Unit3> + <Filename Value="define_types.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="945"/> + <CursorPos X="38" Y="959"/> + <UsageCount Value="107"/> + </Unit3> + <Unit4> + <Filename Value="GraphicsMathLibrary.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="681"/> + <CursorPos Y="738"/> + <UsageCount Value="107"/> + </Unit4> + <Unit5> + <Filename Value="distr.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="99"/> + <CursorPos Y="107"/> + <UsageCount Value="107"/> + </Unit5> + <Unit6> + <Filename Value="statcr.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="4"/> + <CursorPos X="11" Y="25"/> + <UsageCount Value="107"/> + </Unit6> + <Unit7> + <Filename Value="stats.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="615"/> + <CursorPos Y="635"/> + <UsageCount Value="107"/> + </Unit7> + <Unit8> + <Filename Value="brunner.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="500"/> + <CursorPos X="29" Y="517"/> + <UsageCount Value="107"/> + </Unit8> + <Unit9> + <Filename Value="StatThdsUtil.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="49"/> + <CursorPos X="38" Y="4"/> + <UsageCount Value="107"/> + </Unit9> + <Unit10> + <Filename Value="StatThds.pas"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="3"/> + <TopLine Value="488"/> + <CursorPos X="45" Y="493"/> + <UsageCount Value="107"/> + <Loaded Value="True"/> + </Unit10> + <Unit11> + <Filename Value="valformat.pas"/> + <IsPartOfProject Value="True"/> + <CursorPos X="9" Y="12"/> + <UsageCount Value="107"/> + </Unit11> + <Unit12> + <Filename Value="design.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="DesignForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="37"/> + <CursorPos X="36" Y="58"/> + <UsageCount Value="106"/> + </Unit12> + <Unit13> + <Filename Value="spread.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="SpreadForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <EditorIndex Value="4"/> + <TopLine Value="547"/> + <CursorPos X="15" Y="559"/> + <UsageCount Value="106"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit13> + <Unit14> + <Filename Value="gzio2.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="774"/> + <CursorPos X="22" Y="793"/> + <UsageCount Value="107"/> + </Unit14> + <Unit15> + <Filename Value="part.pas"/> + <IsPartOfProject Value="True"/> + <TopLine Value="91"/> + <CursorPos X="38" Y="108"/> + <UsageCount Value="107"/> + </Unit15> + <Unit16> + <Filename Value="markorder.pas"/> + <TopLine Value="8"/> + <CursorPos X="44" Y="23"/> + <UsageCount Value="6"/> + </Unit16> + <Unit17> + <Filename Value="ztopform.pas"/> + <ComponentName Value="ZForm"/> + <TopLine Value="9"/> + <CursorPos X="18" Y="23"/> + <UsageCount Value="18"/> + </Unit17> + <Unit18> + <Filename Value="..\examples\opendialogcrash\unit1.pas"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <UnitName Value="Unit1"/> + <TopLine Value="19"/> + <CursorPos X="40" Y="14"/> + <UsageCount Value="6"/> + </Unit18> + <Unit19> + <Filename Value="nifti_img.pas"/> + <CursorPos X="77" Y="4"/> + <UsageCount Value="10"/> + </Unit19> + <Unit20> + <Filename Value="lesion_pattern.pas"/> + <CursorPos X="13" Y="21"/> + <UsageCount Value="11"/> + </Unit20> + <Unit21> + <Filename Value="ReadInt.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ReadIntForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <TopLine Value="23"/> + <CursorPos X="9" Y="50"/> + <UsageCount Value="105"/> + </Unit21> + <Unit22> + <Filename Value="ReadInt.lrs"/> + <IsPartOfProject Value="True"/> + <CursorPos Y="3"/> + <UsageCount Value="103"/> + </Unit22> + <Unit23> + <Filename Value="LesionStatThds.pas"/> + <TopLine Value="319"/> + <CursorPos X="28" Y="335"/> + <UsageCount Value="35"/> + </Unit23> + <Unit24> + <Filename Value="power.pas"/> + <UsageCount Value="7"/> + </Unit24> + <Unit25> + <Filename Value="Mat.pas"/> + <TopLine Value="225"/> + <CursorPos X="18" Y="239"/> + <UsageCount Value="7"/> + </Unit25> + <Unit26> + <Filename Value="Vector.pas"/> + <UsageCount Value="6"/> + </Unit26> + <Unit27> + <Filename Value="firth.pas"/> + <TopLine Value="294"/> + <CursorPos X="38" Y="23"/> + <UsageCount Value="34"/> + </Unit27> + <Unit28> + <Filename Value="overlap.pas"/> + <TopLine Value="280"/> + <CursorPos X="23" Y="301"/> + <UsageCount Value="8"/> + </Unit28> + <Unit29> + <Filename Value="firthThds.pas"/> + <TopLine Value="604"/> + <CursorPos X="52" Y="36"/> + <UsageCount Value="29"/> + </Unit29> + <Unit30> + <Filename Value="design.lfm"/> + <UsageCount Value="6"/> + <DefaultSyntaxHighlighter Value="LFM"/> + </Unit30> + <Unit31> + <Filename Value="options.inc"/> + <CursorPos X="21" Y="3"/> + <UsageCount Value="7"/> + </Unit31> + <Unit32> + <Filename Value="userdir.pas"/> + <CursorPos X="64" Y="45"/> + <UsageCount Value="7"/> + </Unit32> + <Unit33> + <Filename Value="..\..\lcl\forms.pp"/> + <UnitName Value="Forms"/> + <TopLine Value="642"/> + <CursorPos X="14" Y="661"/> + <UsageCount Value="7"/> + </Unit33> + <Unit34> + <Filename Value="..\gzio2.pas"/> + <TopLine Value="627"/> + <CursorPos X="22" Y="635"/> + <UsageCount Value="6"/> + </Unit34> + <Unit35> + <Filename Value="..\..\fpc\2.0.4\source\rtl\objpas\sysutils\finah.inc"/> + <TopLine Value="17"/> + <CursorPos X="22" Y="27"/> + <UsageCount Value="6"/> + </Unit35> + <Unit36> + <Filename Value="..\define_types.pas"/> + <CursorPos X="31" Y="5"/> + <UsageCount Value="6"/> + </Unit36> + <Unit37> + <Filename Value="..\..\fpc\2.0.4\source\rtl\win32\wininc\messages.inc"/> + <TopLine Value="1191"/> + <CursorPos X="6" Y="1201"/> + <UsageCount Value="6"/> + </Unit37> + <Unit38> + <Filename Value="regression.pas"/> + <EditorIndex Value="8"/> + <CursorPos X="69" Y="13"/> + <UsageCount Value="42"/> + <Loaded Value="True"/> + </Unit38> + <Unit39> + <Filename Value="Regmult.pas"/> + <UnitName Value="RegMult"/> + <TopLine Value="30"/> + <CursorPos X="27" Y="43"/> + <UsageCount Value="6"/> + </Unit39> + <Unit40> + <Filename Value="..\fpmath\regmult.pas"/> + <TopLine Value="39"/> + <CursorPos X="69" Y="45"/> + <UsageCount Value="6"/> + </Unit40> + <Unit41> + <Filename Value="..\common\distr.pas"/> + <TopLine Value="296"/> + <CursorPos Y="308"/> + <UsageCount Value="7"/> + </Unit41> + <Unit42> + <Filename Value="..\common\define_types.pas"/> + <EditorIndex Value="7"/> + <TopLine Value="8"/> + <CursorPos X="57" Y="25"/> + <UsageCount Value="36"/> + <Loaded Value="True"/> + </Unit42> + <Unit43> + <Filename Value="hdr.pas"/> + <CursorPos X="42" Y="5"/> + <UsageCount Value="34"/> + </Unit43> + <Unit44> + <Filename Value="..\common\gzio2.pas"/> + <TopLine Value="1770"/> + <CursorPos X="11" Y="1778"/> + <UsageCount Value="12"/> + </Unit44> + <Unit45> + <Filename Value="..\common\nifti_hdr.pas"/> + <CursorPos X="52" Y="14"/> + <UsageCount Value="9"/> + </Unit45> + <Unit46> + <Filename Value="..\common\GraphicsMathLibrary.pas"/> + <CursorPos X="17" Y="8"/> + <UsageCount Value="6"/> + </Unit46> + <Unit47> + <Filename Value="..\fpmath\utypes.pas"/> + <TopLine Value="470"/> + <CursorPos X="41" Y="482"/> + <UsageCount Value="8"/> + </Unit47> + <Unit48> + <Filename Value="lesion.pas"/> + <TopLine Value="299"/> + <CursorPos X="64" Y="313"/> + <UsageCount Value="6"/> + </Unit48> + <Unit49> + <Filename Value="anacom.pas"/> + <TopLine Value="579"/> + <CursorPos X="32" Y="593"/> + <UsageCount Value="6"/> + </Unit49> + <Unit50> + <Filename Value="filename.pas"/> + <CursorPos X="6" Y="4"/> + <UsageCount Value="6"/> + </Unit50> + <Unit51> + <Filename Value="montecarlo.pas"/> + <CursorPos X="6" Y="3"/> + <UsageCount Value="7"/> + </Unit51> + <Unit52> + <Filename Value="roc.pas"/> + <TopLine Value="2"/> + <CursorPos X="41" Y="14"/> + <UsageCount Value="7"/> + </Unit52> + <Unit53> + <Filename Value="..\fpmath\types.inc"/> + <TopLine Value="153"/> + <CursorPos X="3" Y="174"/> + <UsageCount Value="11"/> + </Unit53> + <Unit54> + <Filename Value="C:\Developer\lazarus\lcl\interfaces\carbon\carbonprivatecommon.inc"/> + <TopLine Value="170"/> + <CursorPos Y="184"/> + <UsageCount Value="6"/> + </Unit54> + <Unit55> + <Filename Value="tfce_clustering.pas"/> + <TopLine Value="8"/> + <CursorPos X="75" Y="11"/> + <UsageCount Value="10"/> + </Unit55> + <Unit56> + <Filename Value="C:\Developer\lazarus\lcl\include\menuitem.inc"/> + <TopLine Value="61"/> + <CursorPos Y="83"/> + <UsageCount Value="8"/> + </Unit56> + <Unit57> + <Filename Value="..\common\isgui.inc"/> + <CursorPos X="10"/> + <UsageCount Value="36"/> + </Unit57> + <Unit58> + <Filename Value="..\common\dialogsx.pas"/> + <TopLine Value="8"/> + <CursorPos X="10" Y="35"/> + <UsageCount Value="31"/> + </Unit58> + <Unit59> + <Filename Value="..\common\dicomhdr.pas"/> + <CursorPos X="13" Y="7"/> + <UsageCount Value="6"/> + </Unit59> + <Unit60> + <Filename Value="unpm.pas"/> + <EditorIndex Value="6"/> + <CursorPos X="49" Y="8"/> + <UsageCount Value="40"/> + <Loaded Value="True"/> + </Unit60> + <Unit61> + <Filename Value="turbolesion.pas"/> + <EditorIndex Value="5"/> + <CursorPos X="63" Y="8"/> + <UsageCount Value="35"/> + <Loaded Value="True"/> + </Unit61> + <Unit62> + <Filename Value="prefs.pas"/> + <TopLine Value="129"/> + <CursorPos X="22" Y="134"/> + <UsageCount Value="33"/> + </Unit62> + <Unit63> + <Filename Value="C:\usr\local\share\fpcsrc\rtl\objpas\sysutils\sysstrh.inc"/> + <CursorPos X="10" Y="107"/> + <UsageCount Value="7"/> + </Unit63> + <Unit64> + <Filename Value="..\common\cpucount.pas"/> + <CursorPos X="10" Y="5"/> + <UsageCount Value="31"/> + </Unit64> + <Unit65> + <Filename Value="C:\Developer\lazarus\lcl\include\progressbar.inc"/> + <TopLine Value="155"/> + <CursorPos Y="178"/> + <UsageCount Value="8"/> + </Unit65> + <Unit66> + <Filename Value="C:\Developer\lazarus\lcl\dialogs.pp"/> + <UnitName Value="Dialogs"/> + <TopLine Value="486"/> + <CursorPos X="10" Y="500"/> + <UsageCount Value="31"/> + </Unit66> + <Unit67> + <Filename Value="..\..\..\..\..\..\usr\local\share\fpcsrc\packages\paszlib\src\zdeflate.pas"/> + <TopLine Value="1035"/> + <CursorPos X="10" Y="1049"/> + <UsageCount Value="12"/> + </Unit67> + <Unit68> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\menuitem.inc"/> + <TopLine Value="5"/> + <CursorPos Y="83"/> + <UsageCount Value="10"/> + </Unit68> + <Unit69> + <Filename Value="upower.pas"/> + <EditorIndex Value="2"/> + <TopLine Value="3"/> + <CursorPos X="10" Y="31"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit69> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="npmform.pas"/> + <Caret Line="799" Column="35" TopLine="786"/> + </Position1> + <Position2> + <Filename Value="npmform.pas"/> + <Caret Line="800" Column="58" TopLine="786"/> + </Position2> + <Position3> + <Filename Value="npmform.pas"/> + <Caret Line="801" Column="29" TopLine="786"/> + </Position3> + <Position4> + <Filename Value="npmform.pas"/> + <Caret Line="805" Column="26" TopLine="786"/> + </Position4> + <Position5> + <Filename Value="npmform.pas"/> + <Caret Line="906" Column="26" TopLine="886"/> + </Position5> + <Position6> + <Filename Value="npmform.pas"/> + <Caret Line="2" Column="127"/> + </Position6> + <Position7> + <Filename Value="npmform.pas"/> + <Caret Line="130" Column="21" TopLine="110"/> + </Position7> + <Position8> + <Filename Value="npmform.pas"/> + <Caret Line="2" Column="129"/> + </Position8> + <Position9> + <Filename Value="npmform.pas"/> + <Caret Line="25" Column="18" TopLine="5"/> + </Position9> + <Position10> + <Filename Value="npmform.pas"/> + <Caret Line="3" Column="130"/> + </Position10> + <Position11> + <Filename Value="npmform.pas"/> + <Caret Line="82" Column="17" TopLine="62"/> + </Position11> + <Position12> + <Filename Value="npmform.pas"/> + <Caret Line="94" Column="15" TopLine="74"/> + </Position12> + <Position13> + <Filename Value="npmform.pas"/> + <Caret Line="119" Column="25" TopLine="99"/> + </Position13> + <Position14> + <Filename Value="npmform.pas"/> + <Caret Line="3" Column="129"/> + </Position14> + <Position15> + <Filename Value="npmform.pas"/> + <Caret Line="104" Column="30" TopLine="84"/> + </Position15> + <Position16> + <Filename Value="npmform.pas"/> + <Caret Line="414" Column="49" TopLine="394"/> + </Position16> + <Position17> + <Filename Value="npmform.pas"/> + <Caret Line="992" Column="7" TopLine="991"/> + </Position17> + <Position18> + <Filename Value="npmform.pas"/> + <Caret Line="991" Column="7" TopLine="990"/> + </Position18> + <Position19> + <Filename Value="npmform.pas"/> + <Caret Line="5" Column="105"/> + </Position19> + <Position20> + <Filename Value="npmform.pas"/> + <Caret Line="103" Column="7" TopLine="83"/> + </Position20> + <Position21> + <Filename Value="npmform.pas"/> + <Caret Line="118" Column="32" TopLine="98"/> + </Position21> + <Position22> + <Filename Value="npmform.pas"/> + <Caret Line="434" Column="8" TopLine="410"/> + </Position22> + <Position23> + <Filename Value="spread.pas"/> + <Caret Line="584" TopLine="555"/> + </Position23> + <Position24> + <Filename Value="npmform.pas"/> + <Caret Line="1049" Column="75" TopLine="1046"/> + </Position24> + <Position25> + <Filename Value="npmform.pas"/> + <Caret Line="1295" Column="19" TopLine="1283"/> + </Position25> + <Position26> + <Filename Value="upower.pas"/> + <Caret Line="51" Column="47" TopLine="38"/> + </Position26> + <Position27> + <Filename Value="StatThds.pas"/> + <Caret Line="6" Column="24"/> + </Position27> + <Position28> + <Filename Value="npmform.pas"/> + <Caret Line="5" Column="35"/> + </Position28> + <Position29> + <Filename Value="npmform.pas"/> + <Caret Line="102" Column="36" TopLine="78"/> + </Position29> + <Position30> + <Filename Value="npmform.pas"/> + <Caret Line="107" Column="57" TopLine="83"/> + </Position30> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <OtherUnitFiles Value="..\fpmath;..\common"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + <UseLineInfoUnit Value="False"/> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <LinkerOptions Value=" -macosx_version_min 10.4 "/> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions Count="2"> + <Item1> + <Name Value="ECodetoolError"/> + </Item1> + <Item2> + <Name Value="EFOpenError"/> + </Item2> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/npm/npm.lpr b/npm/npm.lpr new file mode 100755 index 0000000..e0cf089 --- /dev/null +++ b/npm/npm.lpr @@ -0,0 +1,27 @@ +program npm; + +{$mode objfpc}{$H+} +{$I options.inc} +uses + {$IFDEF UNIX}cthreads,{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, npmform,stats +,nifti_hdr,valformat, part, gzio2, StatThds, + StatThdsUtil, brunner, statcr, distr, GraphicsMathLibrary, define_types, + ReadInt + {$IFDEF SPREADSHEET} ,design,spread{$ENDIF}; + {$IFNDEF FPC} +{$R npm.res} +{$ENDIF} + +begin + Application.Initialize; + Application.CreateForm(TMainForm, MainForm); + {$IFDEF SPREADSHEET} + Application.CreateForm(TSpreadForm, SpreadForm); + Application.CreateForm(TDesignForm, DesignForm); + {$ENDIF} + Application.CreateForm(TReadIntForm, ReadIntForm); + Application.Run; +end. + diff --git a/npm/npm.o b/npm/npm.o new file mode 100644 index 0000000..82d0d1e Binary files /dev/null and b/npm/npm.o differ diff --git a/npm/npm.or b/npm/npm.or new file mode 100755 index 0000000..e980d9f Binary files /dev/null and b/npm/npm.or differ diff --git a/npm/npm.res b/npm/npm.res new file mode 100755 index 0000000..80a54cd Binary files /dev/null and b/npm/npm.res differ diff --git a/npm/npmcl.lpi b/npm/npmcl.lpi new file mode 100755 index 0000000..bbb2fa4 --- /dev/null +++ b/npm/npmcl.lpi @@ -0,0 +1,77 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="NPMcl"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="2"> + <Unit0> + <Filename Value="npmcl.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="npmcl"/> + </Unit0> + <Unit1> + <Filename Value="unpm.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="unpm"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="npmcl"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="../common;../fpmath"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/npm/npmcl.lpr b/npm/npmcl.lpr new file mode 100755 index 0000000..31ed43c --- /dev/null +++ b/npm/npmcl.lpr @@ -0,0 +1,187 @@ +program npmcl; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + //cthreads, + {$ENDIF}{$ENDIF} + cthreads, + + Classes, SysUtils, CustApp,prefs, unpm, userdir,StatThdsUtil, cpucount, define_types, turbolesion; + +type + TNPMcl = class(TCustomApplication) + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + function GetOptionValueInt(lCmd: string; lDefault: integer): integer; + //procedure WriteHelp; virtual; + procedure ThreadDone(Sender: TObject); + end; + +var + Application: TNPMcl; + +procedure msg(s: string); +begin + { add your help code here } + writeln(s); +end; + + + + +procedure ShowOptions (lTestInt: integer; lMaskFilename,lOutFilename: string); +begin + msg(' -c : CPU threads, Default : '+inttostr(gnCPUThreads)); + msg(' -m : mask name. Default "' +lMaskFilename+'"'); + msg(' -n : neighbors for TFCE, 0 for none. Default ' +inttostr(gNPMprefs.TFCE)); + msg(' -o : output name. Default "' +lOutFilename+'"'); + msg(' -p : Permutations, 0 for none. Default '+inttostr(gNPMprefs.nPermute)); + msg(' -r : RAM for processing (Mb). Default '+inttostr(kPlankMB)); + msg(' -t : test (0=continuous,1=binomial,2=regress,3=multiregress). Default '+inttostr(lTestInt)); + +end; + +procedure WriteHelp ; +begin + msg(GetKVers); + msg(' usage: '+ExtractFileName(FileNameNoExt(paramstr(0)))+' [options] [-t test] [valfilename]' ); + msg('Examples:'); + msg(' '+ ExtractFileName(FileNameNoExt(paramstr(0)))+' -t 0 test.val'); + msg(' '+ ExtractFileName(FileNameNoExt(paramstr(0)))+' -r 1024 -p 1000 -m mymask.nii -t 0 test.val'); + msg('Options:'); + msg(' -h : Help displayed'); +end; + +procedure TNPMcl.ThreadDone(Sender: TObject); +begin + Dec(gThreadsRunning); +end; +function TNPMcl.GetOptionValueInt(lCmd: string; lDefault: integer): integer; +var + lResp : string; +begin + lResp := GetOptionValue(lCmd); + if length(lResp) < 1 then result := lDefault; + try + result := strtoint(lResp); + except + Writeln('Error '+(lResp)+' is not a valid integer.'); + result := lDefault; + end; + + +end; + +procedure doVLSM(lBinomial: boolean; VALFilename, lMaskFilename,lOutFilename: string); + var + lPrefs: TLDMPrefs ; +begin + lPrefs.NULP := gNPMPrefs.NULP; + if (not lBinomial) then begin //continuous + lPrefs.BMtest := true; + lPrefs.Ttest := true; + lPrefs.Ltest:= false; + end else begin //binomial + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.CritPct := -1; + lPrefs.nPermute := gNPMprefs.nPermute; + lPrefs.Run := 0;{0 except for montecarlo} + lPrefs.VALFilename := VALFilename; + lPrefs.OutName := lOutFilename; + lPrefs.ExplicitMaskName := lMaskFilename; + DoLesion (lPrefs); +end; + + + +procedure TNPMcl.DoRun; +label + 666; +var + lTestInt: integer = 0; + lMaskFilename : string = ''; + lValFilename : string = ''; + lOutFilename : string = ''; +begin + gnCPUThreads := GetLogicalCpuCount; + ReadIniFile; + // parse parameters + if (HasOption('h','help')) or (ParamCount = 0) then begin + WriteHelp; + ShowOptions(lTestInt, lMaskFilename, lOutFilename); + goto 666; + end; + if (HasOption('c')) then gnCPUThreads := GetOptionValueInt('c', gnCPUThreads); + if (HasOption('m')) then begin + lMaskFilename := GetOptionValue('m'); + if not (not FileExistsEX(lMaskFilename)) then begin + writeln('Can not fine masking image '+ lMaskFilename); + goto 666; + end; + end; + if (HasOption('n')) then gnCPUThreads := GetOptionValueInt('n', gNPMprefs.TFCE); + if (HasOption('o')) then begin + lOutFilename := GetOptionValue('o'); + end; + if (HasOption('p')) then gNPMprefs.nPermute := GetOptionValueInt('p', gNPMprefs.nPermute); + if (HasOption('r')) then begin + kPlankMB := GetOptionValueInt('r', kPlankMB); + ComputePlankSize(kPlankMB); + end; + if (HasOption('t')) then lTestInt := GetOptionValueInt('t', lTestInt); + + + lValFilename := (paramstr(ParamCount)); + if (UpCaseExt(lValFilename) <> '.VAL') or (not FileExistsEX(lValFilename)) then begin + Writeln('Error: final option should be an existing file with the .val extension'); + goto 666; + end; + + if (lOutFilename = '') then begin + lOutFilename := ChangeFileExtX( lValFilename,''); + end; + //show settings + ShowOptions(lTestInt,lMaskFilename,lOutFilename); + Writeln('VAL File: '+lValFilename); + //run test + case lTestInt of + 0: doVLSM(false, lVALFilename, lMaskFilename,lOutFilename);//continuous : t-test + 1: doVLSM(true, lVALFilename, lMaskFilename,lOutFilename);//binomial: Liebermeister + 2: NPMSingleRegress ( lVALFilename, lMaskFilename,lOutFilename); + 3: NPMMultipleRegressClick( lVALFilename, lMaskFilename,lOutFilename); + end; + + + WriteIniFile; + // stop program loop + 666: + Terminate; +end; + +constructor TNPMcl.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; +end; + +destructor TNPMcl.Destroy; +begin + inherited Destroy; +end; + + +begin + Application:=TNPMcl.Create(nil); + Application.Title:='NPMcl'; + Application.Run; + Application.Free; +end. + diff --git a/npm/npmform.dfm b/npm/npmform.dfm new file mode 100755 index 0000000..65aca4d Binary files /dev/null and b/npm/npmform.dfm differ diff --git a/npm/npmform.lfm b/npm/npmform.lfm new file mode 100755 index 0000000..db4814d --- /dev/null +++ b/npm/npmform.lfm @@ -0,0 +1,288 @@ +object MainForm: TMainForm + Left = 468 + Height = 418 + Top = 213 + Width = 542 + ActiveControl = Memo1 + Caption = 'Non-Parametric Mapping' + ClientHeight = 418 + ClientWidth = 542 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object Memo1: TMemo + Left = 0 + Height = 393 + Top = 0 + Width = 542 + Align = alClient + ScrollBars = ssAutoBoth + TabOrder = 0 + end + object Panel1: TPanel + Left = 0 + Height = 25 + Top = 393 + Width = 542 + Align = alBottom + ClientHeight = 25 + ClientWidth = 542 + TabOrder = 1 + object ProgressBar1: TProgressBar + Left = 1 + Height = 23 + Top = 1 + Width = 540 + Align = alClient + TabOrder = 0 + end + end + object MainMenu1: TMainMenu + left = 8 + top = 8 + object File1: TMenuItem + Caption = 'File' + object SaveText1: TMenuItem + Caption = 'Save text...' + OnClick = Savetext1Click + end + object Exit1: TMenuItem + Caption = 'Exit' + OnClick = Exit1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + end + object VLSM1: TMenuItem + Caption = 'VLSM' + object BinomialAnalysislesions1: TMenuItem + Caption = 'Binary images, binary groups (lesions) ' + ShortCut = 16450 + OnClick = LesionBtnClick + end + object Binaryimagescontinuousgroupsfast1: TMenuItem + Tag = 1 + Caption = 'Binary images, continuous groups (vlsm)' + ShortCut = 16460 + OnClick = LesionBtnClick + end + object PenalizedLogisticRegerssion1: TMenuItem + Caption = 'Binary images, multiple factors' + OnClick = PenalizedLogisticRegerssion1Click + end + object ROIanalysis1: TMenuItem + Caption = 'ROI analysis' + OnClick = ROIanalysis1Click + end + object Design1: TMenuItem + Caption = 'Design...' + ShortCut = 16452 + OnClick = Design1Click + end + end + object VBM1: TMenuItem + Caption = 'VBM' + object ContinuousanalysisVBM1: TMenuItem + Caption = 'Continuous images, binary groups (VBM)' + ShortCut = 16470 + OnClick = NPMclick + end + object PairedTMenu: TMenuItem + Caption = 'Paired Measures T-test' + OnClick = PairedTMenuClick + end + object MultipleRegress: TMenuItem + Caption = 'Multiple WLS Regression' + Visible = False + OnClick = MultipleRegressClick + end + object SingleRegress: TMenuItem + Caption = 'Single WLS Regression' + Visible = False + OnClick = SingleRegressClick + end + object DualImageCorrelation1: TMenuItem + Caption = 'Dual image correlation' + Visible = False + OnClick = DualImageCorrelation1Click + end + end + object Options1: TMenuItem + Caption = 'Options' + object Permutations1: TMenuItem + Caption = 'Permutations' + object N0: TMenuItem + AutoCheck = True + Caption = 'None' + Checked = True + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N1000: TMenuItem + Tag = 1000 + AutoCheck = True + Caption = '1000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N2000: TMenuItem + Tag = 2000 + AutoCheck = True + Caption = '2000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N3000: TMenuItem + Tag = 3000 + AutoCheck = True + Caption = '3000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N4000: TMenuItem + Tag = 4000 + AutoCheck = True + Caption = '4000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + end + object Tests1: TMenuItem + Caption = 'Tests' + object ttestmenu: TMenuItem + Caption = 't-test' + OnClick = testmenuclick + end + object BMmenu: TMenuItem + Caption = 'Brunner Munzel' + Checked = True + OnClick = testmenuclick + end + end + object Threads1: TMenuItem + Caption = 'Threads' + object T1: TMenuItem + AutoCheck = True + Caption = '1' + Checked = True + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T2: TMenuItem + AutoCheck = True + Caption = '2' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T3: TMenuItem + AutoCheck = True + Caption = '3' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T4: TMenuItem + AutoCheck = True + Caption = '4' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T7: TMenuItem + AutoCheck = True + Caption = '7' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T8: TMenuItem + AutoCheck = True + Caption = '8' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T15: TMenuItem + AutoCheck = True + Caption = '15' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T16: TMenuItem + AutoCheck = True + Caption = '16' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + end + object PlankSzMenuItem1: TMenuItem + Caption = 'Plank Size' + OnClick = PlankSzMenuItem1Click + end + end + object Utilities1: TMenuItem + Caption = 'Utilities' + object Variance1: TMenuItem + Caption = 'Variance image' + OnClick = Variance1Click + end + object Makemeanimage2: TMenuItem + Tag = 1 + Caption = 'Make binarized mean' + OnClick = Makemeanimage1Click + end + object Makemeanimage1: TMenuItem + Caption = 'Make mean/StDev image' + OnClick = Makemeanimage1Click + end + object SingleSubjectZScores1: TMenuItem + Caption = 'Single Subject Z-Score' + OnClick = SingleSubjectZScores1Click + end + object IntensitynormalizationA1: TMenuItem + Tag = 1 + Caption = 'Intensity normalization A' + OnClick = Balance1Click + end + object Balance1: TMenuItem + Caption = 'Intensity normalization B' + OnClick = Balance1Click + end + end + object Help1: TMenuItem + Caption = 'Help' + Visible = False + object About1: TMenuItem + Caption = 'About' + OnClick = About1Click + end + end + end + object SaveHdrDlg: TSaveDialog + FilterIndex = 0 + left = 8 + top = 40 + end + object OpenHdrDlg: TOpenDialog + FilterIndex = 0 + left = 8 + top = 72 + end +end diff --git a/npm/npmform.lrs b/npm/npmform.lrs new file mode 100755 index 0000000..d2af90b --- /dev/null +++ b/npm/npmform.lrs @@ -0,0 +1,82 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TMainForm','FORMDATA',[ + 'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3#212#1#6'Height'#3#162#1#3'Top'#3#213 + +#0#5'Width'#3#30#2#13'ActiveControl'#7#5'Memo1'#7'Caption'#6#22'Non-Parametr' + +'ic Mapping'#12'ClientHeight'#3#162#1#11'ClientWidth'#3#30#2#4'Menu'#7#9'Mai' + +'nMenu1'#7'OnClose'#7#9'FormClose'#8'OnCreate'#7#10'FormCreate'#6'OnShow'#7#8 + +'FormShow'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#3'1.5'#0#5'TMem' + +'o'#5'Memo1'#4'Left'#2#0#6'Height'#3#137#1#3'Top'#2#0#5'Width'#3#30#2#5'Alig' + +'n'#7#8'alClient'#10'ScrollBars'#7#10'ssAutoBoth'#8'TabOrder'#2#0#0#0#6'TPan' + +'el'#6'Panel1'#4'Left'#2#0#6'Height'#2#25#3'Top'#3#137#1#5'Width'#3#30#2#5'A' + +'lign'#7#8'alBottom'#12'ClientHeight'#2#25#11'ClientWidth'#3#30#2#8'TabOrder' + +#2#1#0#12'TProgressBar'#12'ProgressBar1'#4'Left'#2#1#6'Height'#2#23#3'Top'#2 + +#1#5'Width'#3#28#2#5'Align'#7#8'alClient'#8'TabOrder'#2#0#0#0#0#9'TMainMenu' + +#9'MainMenu1'#4'left'#2#8#3'top'#2#8#0#9'TMenuItem'#5'File1'#7'Caption'#6#4 + +'File'#0#9'TMenuItem'#9'SaveText1'#7'Caption'#6#12'Save text...'#7'OnClick'#7 + +#14'Savetext1Click'#0#0#9'TMenuItem'#5'Exit1'#7'Caption'#6#4'Exit'#7'OnClick' + +#7#10'Exit1Click'#0#0#0#9'TMenuItem'#5'Edit1'#7'Caption'#6#4'Edit'#0#9'TMenu' + +'Item'#5'Copy1'#7'Caption'#6#4'Copy'#7'OnClick'#7#10'Copy1Click'#0#0#0#9'TMe' + +'nuItem'#5'VLSM1'#7'Caption'#6#4'VLSM'#0#9'TMenuItem'#24'BinomialAnalysisles' + +'ions1'#7'Caption'#6'''Binary images, binary groups (lesions) '#8'ShortCut'#3 + +'B@'#7'OnClick'#7#14'LesionBtnClick'#0#0#9'TMenuItem!Binaryimagescontinuousg' + +'roupsfast1'#3'Tag'#2#1#7'Caption'#6'''Binary images, continuous groups (vls' + +'m)'#8'ShortCut'#3'L@'#7'OnClick'#7#14'LesionBtnClick'#0#0#9'TMenuItem'#28'P' + +'enalizedLogisticRegerssion1'#7'Caption'#6#31'Binary images, multiple factor' + +'s'#7'OnClick'#7'!PenalizedLogisticRegerssion1Click'#0#0#9'TMenuItem'#12'ROI' + +'analysis1'#7'Caption'#6#12'ROI analysis'#7'OnClick'#7#17'ROIanalysis1Click' + +#0#0#9'TMenuItem'#7'Design1'#7'Caption'#6#9'Design...'#8'ShortCut'#3'D@'#7'O' + +'nClick'#7#12'Design1Click'#0#0#0#9'TMenuItem'#4'VBM1'#7'Caption'#6#3'VBM'#0 + +#9'TMenuItem'#22'ContinuousanalysisVBM1'#7'Caption'#6'&Continuous images, bi' + +'nary groups (VBM)'#8'ShortCut'#3'V@'#7'OnClick'#7#8'NPMclick'#0#0#9'TMenuIt' + +'em'#11'PairedTMenu'#7'Caption'#6#22'Paired Measures T-test'#7'OnClick'#7#16 + +'PairedTMenuClick'#0#0#9'TMenuItem'#15'MultipleRegress'#7'Caption'#6#23'Mult' + +'iple WLS Regression'#7'Visible'#8#7'OnClick'#7#20'MultipleRegressClick'#0#0 + +#9'TMenuItem'#13'SingleRegress'#7'Caption'#6#21'Single WLS Regression'#7'Vis' + +'ible'#8#7'OnClick'#7#18'SingleRegressClick'#0#0#9'TMenuItem'#21'DualImageCo' + +'rrelation1'#7'Caption'#6#22'Dual image correlation'#7'Visible'#8#7'OnClick' + +#7#26'DualImageCorrelation1Click'#0#0#0#9'TMenuItem'#8'Options1'#7'Caption'#6 + +#7'Options'#0#9'TMenuItem'#13'Permutations1'#7'Caption'#6#12'Permutations'#0 + +#9'TMenuItem'#2'N0'#9'AutoCheck'#9#7'Caption'#6#4'None'#7'Checked'#9#10'Grou' + +'pIndex'#2'{'#9'RadioItem'#9#7'OnClick'#7#14'radiomenuclick'#0#0#9'TMenuItem' + +#5'N1000'#3'Tag'#3#232#3#9'AutoCheck'#9#7'Caption'#6#4'1000'#10'GroupIndex'#2 + +'{'#9'RadioItem'#9#7'OnClick'#7#14'radiomenuclick'#0#0#9'TMenuItem'#5'N2000' + +#3'Tag'#3#208#7#9'AutoCheck'#9#7'Caption'#6#4'2000'#10'GroupIndex'#2'{'#9'Ra' + +'dioItem'#9#7'OnClick'#7#14'radiomenuclick'#0#0#9'TMenuItem'#5'N3000'#3'Tag' + +#3#184#11#9'AutoCheck'#9#7'Caption'#6#4'3000'#10'GroupIndex'#2'{'#9'RadioIte' + +'m'#9#7'OnClick'#7#14'radiomenuclick'#0#0#9'TMenuItem'#5'N4000'#3'Tag'#3#160 + +#15#9'AutoCheck'#9#7'Caption'#6#4'4000'#10'GroupIndex'#2'{'#9'RadioItem'#9#7 + +'OnClick'#7#14'radiomenuclick'#0#0#0#9'TMenuItem'#6'Tests1'#7'Caption'#6#5'T' + +'ests'#0#9'TMenuItem'#9'ttestmenu'#7'Caption'#6#6't-test'#7'OnClick'#7#13'te' + +'stmenuclick'#0#0#9'TMenuItem'#6'BMmenu'#7'Caption'#6#14'Brunner Munzel'#7'C' + +'hecked'#9#7'OnClick'#7#13'testmenuclick'#0#0#0#9'TMenuItem'#8'Threads1'#7'C' + +'aption'#6#7'Threads'#0#9'TMenuItem'#2'T1'#9'AutoCheck'#9#7'Caption'#6#1'1'#7 + +'Checked'#9#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnClick'#7#12'threadChan' + +'ge'#0#0#9'TMenuItem'#2'T2'#9'AutoCheck'#9#7'Caption'#6#1'2'#10'GroupIndex'#3 + +#131#0#9'RadioItem'#9#7'OnClick'#7#12'threadChange'#0#0#9'TMenuItem'#2'T3'#9 + +'AutoCheck'#9#7'Caption'#6#1'3'#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnCl' + +'ick'#7#12'threadChange'#0#0#9'TMenuItem'#2'T4'#9'AutoCheck'#9#7'Caption'#6#1 + +'4'#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnClick'#7#12'threadChange'#0#0#9 + +'TMenuItem'#2'T7'#9'AutoCheck'#9#7'Caption'#6#1'7'#10'GroupIndex'#3#131#0#9 + +'RadioItem'#9#7'OnClick'#7#12'threadChange'#0#0#9'TMenuItem'#2'T8'#9'AutoChe' + +'ck'#9#7'Caption'#6#1'8'#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnClick'#7 + +#12'threadChange'#0#0#9'TMenuItem'#3'T15'#9'AutoCheck'#9#7'Caption'#6#2'15' + +#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnClick'#7#12'threadChange'#0#0#9'T' + +'MenuItem'#3'T16'#9'AutoCheck'#9#7'Caption'#6#2'16'#10'GroupIndex'#3#131#0#9 + +'RadioItem'#9#7'OnClick'#7#12'threadChange'#0#0#0#9'TMenuItem'#16'PlankSzMen' + +'uItem1'#7'Caption'#6#10'Plank Size'#7'OnClick'#7#21'PlankSzMenuItem1Click'#0 + ,#0#0#9'TMenuItem'#10'Utilities1'#7'Caption'#6#9'Utilities'#0#9'TMenuItem'#9 + +'Variance1'#7'Caption'#6#14'Variance image'#7'OnClick'#7#14'Variance1Click'#0 + +#0#9'TMenuItem'#14'Makemeanimage2'#3'Tag'#2#1#7'Caption'#6#19'Make binarized' + +' mean'#7'OnClick'#7#19'Makemeanimage1Click'#0#0#9'TMenuItem'#14'Makemeanima' + +'ge1'#7'Caption'#6#21'Make mean/StDev image'#7'OnClick'#7#19'Makemeanimage1C' + +'lick'#0#0#9'TMenuItem'#21'SingleSubjectZScores1'#7'Caption'#6#22'Single Sub' + +'ject Z-Score'#7'OnClick'#7#26'SingleSubjectZScores1Click'#0#0#9'TMenuItem' + +#24'IntensitynormalizationA1'#3'Tag'#2#1#7'Caption'#6#25'Intensity normaliza' + +'tion A'#7'OnClick'#7#13'Balance1Click'#0#0#9'TMenuItem'#8'Balance1'#7'Capti' + +'on'#6#25'Intensity normalization B'#7'OnClick'#7#13'Balance1Click'#0#0#0#9 + +'TMenuItem'#5'Help1'#7'Caption'#6#4'Help'#7'Visible'#8#0#9'TMenuItem'#6'Abou' + +'t1'#7'Caption'#6#5'About'#7'OnClick'#7#11'About1Click'#0#0#0#0#11'TSaveDial' + +'og'#10'SaveHdrDlg'#11'FilterIndex'#2#0#4'left'#2#8#3'top'#2'('#0#0#11'TOpen' + +'Dialog'#10'OpenHdrDlg'#11'FilterIndex'#2#0#4'left'#2#8#3'top'#2'H'#0#0#0 +]); diff --git a/npm/npmform.o b/npm/npmform.o new file mode 100644 index 0000000..e37180a Binary files /dev/null and b/npm/npmform.o differ diff --git a/npm/npmform.pas b/npm/npmform.pas new file mode 100755 index 0000000..fc70516 --- /dev/null +++ b/npm/npmform.pas @@ -0,0 +1,2206 @@ +unit npmform; +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} +{$DEFINE SINGLETHREAD} +//{$DEFINE FIRTHNOTHREAD} +interface +{$I options.inc} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, + Messages, userDir, + Classes, Graphics, Controls, Forms, DialogsX,Dialogs, nifti_types , + Menus, ComCtrls, ExtCtrls, StdCtrls, +overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, + {$ELSE} + LCLType, + {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,math, +regmult,utypes,turbolesion +{$IFDEF compileANACOM}, anacom{$ENDIF} + +{$IFDEF benchmark}, montecarlo{$ENDIF} +; +//regmultdelphi,matrices; +type + + { TMainForm } + + TMainForm = class(TForm) + Binaryimagescontinuousgroupsfast1: TMenuItem; + Memo1: TMemo; + + Design1: TMenuItem; + //PlankSzMenuItem1: TMenuItem; + DualImageCorrelation1: TMenuItem; + MultipleRegress: TMenuItem; + SaveText1: TMenuItem; + ROIanalysis1: TMenuItem; + OpenHdrDlg: TOpenDialog; + SaveHdrDlg: TSaveDialog; + Panel1: TPanel; + ProgressBar1: TProgressBar; + MainMenu1: TMainMenu; + About1: TMenuItem; + AssociatevalfileswithNPM1: TMenuItem; + Balance1: TMenuItem; + BinomialAnalysislesions1: TMenuItem; + BMmenu: TMenuItem; + ContinuousanalysisVBM1: TMenuItem; + Copy1: TMenuItem; + Edit1: TMenuItem; + Exit1: TMenuItem; + File1: TMenuItem; + Help1: TMenuItem; + IntensitynormalizationA1: TMenuItem; + Makemeanimage1: TMenuItem; + Makemeanimage2: TMenuItem; + N0: TMenuItem; + N1000: TMenuItem; + N2000: TMenuItem; + N3000: TMenuItem; + N4000: TMenuItem; + Options1: TMenuItem; + PairedTMenu: TMenuItem; + PenalizedLogisticRegerssion1: TMenuItem; + Permutations1: TMenuItem; + SingleRegress: TMenuItem; + SingleSubjectZScores1: TMenuItem; + T1: TMenuItem; + T15: TMenuItem; + T16: TMenuItem; + T2: TMenuItem; + T3: TMenuItem; + T4: TMenuItem; + T7: TMenuItem; + T8: TMenuItem; + Tests1: TMenuItem; + Threads1: TMenuItem; + //StartTimer: TTimer; + ttestmenu: TMenuItem; + Utilities1: TMenuItem; + Variance1: TMenuItem; + VBM1: TMenuItem; + VLSM1: TMenuItem; + Intensitynormalization1: TMenuItem; + Masked1: TMenuItem; + MaskedintensitynormalizationA1: TMenuItem; + MaskedintensitynormalizationB1: TMenuItem; + Binarizeimages1: TMenuItem; + PlankSzMenuItem1: TMenuItem; + //Setnonseroto1001: TMenuItem; + //AnaCOMmenu: TMenuItem; + //MonteCarloSimulation1: TMenuItem; + //Subtract1: TMenuItem; + //LogPtoZ1: TMenuItem; + procedure PlankSzMenuItem1Click(Sender: TObject); + procedure NPMmsgUI( lStr: string); + procedure NPMmsgClearUI; + procedure NPMmsgSaveUI(lFilename: string); + //procedure ProcessParamStr; + function GetValX (var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean; + function FirthNPMAnalyze (var lImages: TStrings; var lPredictorList: TStringList; var lMaskHdr: TMRIcroHdr; lnCond,lnCrit: integer; var lSymptomRA: SingleP; var lOutName: string): boolean; + procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); + function SaveHdrName (lCaption: string; var lFilename: string): boolean; + procedure NPMclick(Sender: TObject); + function OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; + //function NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels,lnGroup1: integer): boolean; + //function NPMAnalyzePaired (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels: integer): boolean; + procedure FormCreate(Sender: TObject); + //function MakeSubtract (lPosName,lNegName: string): boolean; + //function MakeMean (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lBinarize,lVariance: boolean): boolean; + //function Balance (var lImageName,lMaskName: String; lMethod: integer{lInflection: boolean}): boolean; + procedure LesionBtnClick(Sender: TObject); + procedure Copy1Click(Sender: TObject); + //procedure StartTimerTimer(Sender: TObject); + procedure testmenuclick(Sender: TObject); + procedure radiomenuclick(Sender: TObject); + procedure Makemeanimage1Click(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure Balance1Click(Sender: TObject); + + procedure Variance1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure Design1Click(Sender: TObject); + procedure DualImageCorrelation1Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure PairedTMenuClick(Sender: TObject); + procedure SingleSubjectZScores1Click(Sender: TObject); + procedure MultipleRegressClick(Sender: TObject); + function ReadPermute: integer; + procedure SingleRegressClick(Sender: TObject); + procedure AssociatevalfileswithNPM1Click(Sender: TObject); + procedure threadChange(Sender: TObject); + //procedure Countlesionoverlaps1Click(Sender: TObject); + procedure PenalizedLogisticRegerssion1Click(Sender: TObject); + //procedure ROCbinomialdeficit1Click(Sender: TObject); + //procedure ROCcontinuousdeficit1Click(Sender: TObject); + procedure ThreadDone(Sender: TObject); + procedure ROIanalysis1Click(Sender: TObject); + procedure Masked1Click(Sender: TObject); + procedure Binarizeimages1Click(Sender: TObject); + procedure Setnonseroto1001Click(Sender: TObject); + procedure Savetext1Click(Sender: TObject); + //procedure Subtract1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + MainForm: TMainForm; +implementation + +uses unpm, prefs,hdr,roc,regression,valformat {$IFDEF SPREADSHEET} ,design,spread{$ENDIF} +{$IFNDEF UNIX},ActiveX {$ENDIF}; +{$IFNDEF FPC} +{$R *.DFM} + {$ENDIF} + +(*function WarnIfLowNCrit(lnSubj,lnCrit: integer): boolean; +//returns true if warning generated +begin + result := (round(lnSubj * 0.15) ) > lnCrit; //15% + if result then + Showmessage('Warning: low statistical power as tests computed for voxels damaged in at least '+inttostr(lnCrit) +' people. Solution: change Design value "Ignore voxels damaged in less than N%".'); + +end; *) + +procedure TMainForm.NPMmsgUI( lStr: string); +begin + Memo1.Lines.add(lStr); +end; + +procedure TMainForm.PlankSzMenuItem1Click(Sender: TObject); +var + str : string; + v,max: integer; +begin + {$IFDEF CPU32} + max := 1536; + {$ELSE} + max := 8000; + {$ENDIF} + + str := inttostr(gNPMPrefs.PlankMB); + if not InputQuery('Specify cache size', 'Mb for computation (256..'+inttostr(max)+')', str) then exit; + try + v := StrToInt(str); // Trailing blanks are not supported + except + on Exception : EConvertError do begin + ShowMessage(Exception.Message); + exit; + end; + end; + if (v < 256) then + v := 256; + if v > max then + v := max; + gNPMPrefs.PlankMB := v; + NPMMsgClear; + NPMMsg(GetKVers); + ComputePlankSize(gNPMPrefs.PlankMB); +end; + +procedure TMainForm.NPMmsgClearUI; +begin + Memo1.Lines.Clear; +end; + + +procedure TMainForm.NPMMsgSaveUI(lFilename: string); +var + i: integer; + f: textfile; +begin + if (Memo1.Lines.Count < 1) then exit; + if fileexists(lFilename) then begin + AssignFile(f, lFilename); + {$I-} + append(f); + {$I+} + if IOResult= 0 then + for i:= 0 to Memo1.Lines.Count- 1 do + WriteLn(f, Memo1.Lines[i]); + CloseFile(f); + end else + MainForm.Memo1.Lines.SaveToFile(lFilename); +end; + +procedure TMainForm.ThreadDone(Sender: TObject); +begin + Dec(gThreadsRunning); +end; + +function TMainForm.SaveHdrName (lCaption: string; var lFilename: string): boolean; +begin + result := false; + SaveHdrDlg.InitialDir := lFilename; + SaveHdrDlg.Title := lCaption; + SaveHdrDlg.Filter := kAnaHdrFilter; + if not SaveHdrDlg.Execute then exit; + lFilename := SaveHdrDlg.Filename; + result := true; +end; + +procedure TMainForm.FormClose(Sender: TObject; var CloseAction: TCloseAction); +begin + WriteIniFile; +end; + +procedure WriteThread( lnThread: integer); +begin + case lnThread of + 2: MainForm.T2.checked := true; + 3: MainForm.T3.checked := true; + 4: MainForm.T4.checked := true; + 7: MainForm.T7.checked := true; + 8: MainForm.T8.checked := true; + 15: MainForm.T15.checked := true; + 16: MainForm.T16.checked := true; + else MainForm.T1.checked := true; + end; + gnCPUThreads := lnThread; +end; + +function ReadThread: integer; +begin + if MainForm.T16.checked then result := 16 + else if MainForm.T15.checked then result := 15 + else if MainForm.T8.checked then result := 8 + else if MainForm.T7.checked then result := 7 + else if MainForm.T4.checked then result := 4 + else if MainForm.T3.checked then result := 3 + else if MainForm.T2.checked then result := 2 + else result := 1; + gnCPUThreads := result; +end; + +procedure WritePermute( lnPermute: integer); +begin + case lnPermute of + 4000: MainForm.N4000.checked := true; + 3000: MainForm.N3000.checked := true; + 2000: MainForm.N2000.checked := true; + 1000: MainForm.N1000.checked := true; + else MainForm.N0.checked := true; + end; +end; + +function TMainForm.ReadPermute: integer; +begin + if MainForm.N4000.checked then result := 4000 + else if MainForm.N3000.checked then result := 3000 + else if MainForm.N2000.checked then result := 2000 + else if MainForm.N1000.checked then result := 1000 + else result := 0; +end; + +function TMainForm.OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; +var + lNumberofFiles: integer; +begin + OpenHdrDlg.Filter := lFilter;//kAnaHdrFilter;//lFilter; + OpenHdrDlg.FilterIndex := 1; + OpenHdrDlg.Title := lCaption; + if lAllowMultiSelect then + OpenHdrDlg.Options := [ofAllowMultiSelect,ofFileMustExist] + else + OpenHdrDlg.Options := [ofFileMustExist]; + result := OpenHdrDlg.Execute; + if not result then exit; + if lForceMultiSelect then begin + lNumberofFiles:= OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + ShowMsg('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + result := false; + end; + end; +end; + +procedure TMainForm.NPMclick(Sender: TObject); +label + 666; +var + lnGroup1,lMaskVoxels: integer; + lG: TStrings; + lMaskname, lOutName: string; + lMaskHdr: TMRIcroHdr; +begin + if (not ttestmenu.checked) and (not BMmenu.checked) then begin + ShowMsg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: mask selection failed.'); + exit; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + (*if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showMsg('Error reading mask.'); + exit; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + exit; + end; *) + + //next, get 1st group + if not OpenDialogExecute('Select postive group (Z scores positive if this group is brighter)',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; //not sure why TStrings.Create does not work??? + lG.addstrings(OpenHdrDlg.Files); + lnGroup1 :=OpenHdrDlg.Files.Count; + + //next, get 2nd group + if not OpenDialogExecute('Select negative group (Z scores negative if this group is brighter)',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + goto 666; + end; //if not selected + lG.addstrings(OpenHdrDlg.Files); + if not CheckVoxelsGroupX(lG,lMaskHdr {lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + lOutName := lMaskHdr.ImgFileName; + if not SaveHdrName ('Statistical Map', lOutName) then exit; + NPMAnalyze(lG,lMaskName,lMaskVoxels,lnGroup1,gNPMPrefs,lOutName); + 666: + lG.Free; +end; + +function TMainForm.GetValX (var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit: integer; var lPredictorList: TStringList):boolean; +//warning: you MUST free lPredictorList +var + lVALFilename: string; + lCritPct: integer; +begin + lPredictorList := TStringList.Create; + result := false; + lnSubj := 0; + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + ShowMsg('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lVALFilename := MainForm.OpenHdrDlg.Filename; + result := GetValCore ( lVALFilename, lnSubj, lnFactors, lSymptomRA, lImageNames, lCrit,lCritPct{,binom},lPredictorList); +end; + +procedure TMainForm.Copy1Click(Sender: TObject); +begin + Memo1.SelectAll; + Memo1.CopyToClipboard; + +end; + +(*procedure TMainForm.StartTimerTimer(Sender: TObject); +begin + if StartTimer.Tag < 2 then begin + StartTimer.tag := StartTimer.tag + 1; + exit; + + end; + + StartTimer.Enabled := false; + //if (ParamCount > 0) then ProcessParamStr; + +end; *) + +procedure TMainForm.testmenuclick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gNPMprefs.BMtest := BMmenu.Checked; + gNPMprefs.ttest := TTestmenu.Checked; +end; + +procedure TMainForm.radiomenuclick(Sender: TObject); +begin + (sender as tmenuitem).checked := true; + gNPMprefs.nPermute:= readPermute; +end; + +procedure TMainForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + File1.visible := false;//for OSX, exit is in the application's menu + //Edit1.visible := false;//clipboard note yet working for OSX + {$ENDIF} + {$IFDEF FPC} + Application.ShowButtonGlyphs := sbgNever; + {$ENDIF} + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + BinomialAnalysislesions1.ShortCut := ShortCut(Word('B'), [ssMeta]); + Binaryimagescontinuousgroupsfast1.ShortCut := ShortCut(Word('L'), [ssMeta]); + Design1.ShortCut := ShortCut(Word('D'), [ssMeta]); + ContinuousanalysisVBM1.ShortCut := ShortCut(Word('V'), [ssMeta]); + MultipleRegress.ShortCut := ShortCut(Word('R'), [ssMeta]); + Makemeanimage1.ShortCut := ShortCut(Word('M'), [ssMeta]); + About1.ShortCut := ShortCut(Word('A'), [ssMeta]); + {$ENDIF}//Carbon + {$ENDIF}//Darwin + gnCPUThreads := GetLogicalCpuCount; + (*if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + case MessageDlg('Shift key down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrNo: ReadIniFile; + end; //case + end else *) + if not ResetDefaults then + ReadIniFile; + + ttestmenu.checked := gNPMprefs.ttest; + bmmenu.Checked:= gNPMprefs.BMtest; + WritePermute(gNPMprefs.nPermute); + WriteThread(gnCPUThreads); +end; + +(*procedure TMainForm.Makemeanimage1Click(Sender: TObject); +label + 666; +var + lG: TStrings; + loutname: string; +begin + + if not OpenDialogExecute('Select images to average',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if not SaveHdrName ('Output image', lOutName) then exit; + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + + + MakeMean(lG,odd((Sender as TMenuItem).tag),false,loutname); + 666: + lG.Free; +end; *) +procedure TMainForm.Makemeanimage1Click(Sender: TObject); +var + loutname: string; +begin + + if not OpenDialogExecute('Select images to average666',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if not SaveHdrName ('Output image', lOutName) then exit; + MakeMean(OpenHdrDlg.Files,odd((Sender as TMenuItem).tag),false,loutname); +end; + + +procedure TMainForm.Exit1Click(Sender: TObject); +begin + Close; +end; + +(*procedure CopyFileEXoverwrite (lInName,lOutName: string); +var lFSize: Integer; + lBuff: bytep0; + lFData: file; +begin + lFSize := FSize(lInName); + if (lFSize < 1) then exit; + assignfile(lFdata,lInName); + filemode := 0; + reset(lFdata,lFSize{1}); + GetMem( lBuff, lFSize); + BlockRead(lFdata, lBuff^, 1{lFSize}); + closefile(lFdata); + assignfile(lFdata,lOutName); + filemode := 2; + Rewrite(lFdata,lFSize); + BlockWrite(lFdata,lBuff^, 1 {, NumWritten}); + closefile(lFdata); + freemem(lBuff); +end;*) + +procedure TMainForm.Balance1Click(Sender: TObject); +var + lFilename,lMaskName: string; + lPos: Integer; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + lMaskName := ''; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + balance(lFilename,lMaskname,(Sender as TMenuItem).tag); + end; +end; + + +procedure TMainForm.Variance1Click(Sender: TObject); +label + 666; +var + lMaskVoxels: integer; + lG: TStrings; + lMaskname,loutname: string; + lMaskHdr: TMRIcroHdr; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select 2 images)',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + if lG.count <> 2 then begin + ShowMsg('You must select exactly two image.'); + goto 666; + end; + if not SaveHdrName ('Output image', lOutName) then exit; + MakeMean(lG, odd((Sender as TMenuItem).tag),true,loutname); + 666: + lG.Free; +end; + +procedure TMainForm.About1Click(Sender: TObject); +begin + ShowMsg(GetkVers ); +end; + +procedure TMainForm.Design1Click(Sender: TObject); +begin +{$IFDEF SPREADSHEET} SpreadForm.Show; {$ELSE} ShowMsg('Spreadsheet not yet supported on the Operating System');{$ENDIF} +end; + +function AddNumStr(var X : PMatrix; var lNumStr: string; lRow,lCol: integer):boolean; +var + lTempFloat: double; +begin + + result := false; + if (lNumStr = '') or (lRow < 1) or (lCol < 1) then exit; + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + ShowMsg('Empty cells? Error reading TXT file row:'+inttostr(lRow)+' col:'+inttostr(lCol)+' - Unable to convert the string '+lNumStr+' to a number'); + exit; + end; + end; + //fx(lRow,lCol,lTempFloat); + X^[lCol]^[lRow] := lTempFloat; + lNumStr := ''; + result := true; +end; + +function ReadPairedFilenamesReg(var lImageNames: TStrings; var X : PMatrix; var lnAdditionalFactors: integer): boolean; +var + lLen,lPos,lSep,lMaxSep,lLine: integer; + lFilenames,lF1,lF2,lNumStr: string; + lImageNames2: TStrings; + lF: TextFile; +begin + result := false; + + ShowMsg('Please select a text file with the image names. '+kCR+ + 'Each line of the file should specify the control and experimental filenames, separated by an *'+kCR+ + 'C:\vbmdata\c1.nii.gz*C:\vbmdata\e1.nii.gz'+kCR + + 'C:\vbmdata\c2.nii.gz*C:\vbmdata\e2.nii.gz'+kCR+ + 'C:\vbmdata\c3.nii.gz*C:\vbmdata\e3.nii.gz'+kCR+ + '...' ); + if not MainForm.OpenDialogExecute('Select asterix separated filenames ',false,false,kTxtFilter) then + exit; + lImageNames2:= TStringList.Create; //not sure why TStrings.Create does not work??? + //xxx + assignfile(lF,MainForm.OpenHdrDlg.FileName ); + FileMode := 0; //read only + reset(lF); + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + + if lLen > 0 then begin + lF1:= ''; + lF2 := ''; + lPos := 1; + while (lPos <= lLen) and (lFilenames[lPos] <> '*') do begin + lF1 := lF1 + lFilenames[lPos]; + inc(lPos); + end; + inc(lPos); + while (lPos <= lLen) and (lFilenames[lPos] <> '*') do begin + lF2 := lF2 + lFilenames[lPos]; + inc(lPos); + end; + if (length(lF1) > 0) and (length(lF2)>0) then begin + if Fileexists4D(lF1) then begin + if Fileexists4D(lF2) then begin + lImageNames.add(lF1); + lImageNames2.add(lF2); + end else //F2exists + ShowMsg('Can not find image '+lF2); + end else //F1 exists + ShowMsg('Can not find image '+lF1); + end; + end;//len>0 + end; //while not EOF + + //fx(lImageNames.count); + //next - count additional factors + lnAdditionalFactors := 0; + reset(lF); + lMaxSep := 0; + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + lSep := 0; + if lLen > 0 then begin + for lPos := 1 to lLen do + if lFilenames[lPos] = '*' then + inc(lSep) + end;//len>0 + if lSep > lMaxSep then + lMaxSep := lSep; + end; //while not EOF + if (lMaxSep > 1) and (lImageNames2.count > 1) then begin //additional factors present + //final pas - load additional factors + lnAdditionalFactors := lMaxSep - 1; + + DimMatrix(X, lnAdditionalFactors, lImageNames2.count); + reset(lF); + lLine := 0; + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + lSep := 0; + + if lLen > 0 then begin + inc(lLine); + lPos := 1; + lNumStr := ''; + while lPos <= lLen do begin + if (lFilenames[lPos] = '*') then begin + AddNumStr(X,lNumStr,lLine,lSep-1); + inc(lSep); + end else if (lSep >= 2) and (not (lFilenames[lPos] in [#10,#13,#9]) ) then begin + lNumStr := lNumStr+lFilenames[lPos]; + //ShowMsg(lNumStr); + end; + inc(lPos); + end; //while not EOLN + AddNumStr(X,lNumStr,lLine,lSep-1); + end;//len>0 + end; //while not EOF + //next - read final line of unterminated string... + end;//maxsepa > 1 + //2nd pass vals + closefile(lF); + FileMode := 2; //read/write + if (lImageNames.count > 0) and (lImageNames2.count = lImageNames.count) then begin + lImageNames.AddStrings(lImageNames2); + + result := true; + end; + lImageNames2.Free; + result := true; +end; + +procedure TMainForm.DualImageCorrelation1Click(Sender: TObject); +label + 666; +var + lnSubj,lSubj,lMaskVoxels,lnAdditionalFactors,lI: integer; + lImageNames: TStrings; + X: PMatrix; + lMaskname,lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + NPMMsgClear; + NPMMsg(GetKVers); + + NPMMsg('Dual-image Linear Regression [Weighted Least Squares]'); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: mask selection failed.'); + goto 666; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + ShowMsg('Error reading Mask image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + goto 666; + end; + if not ReadPairedFilenamesReg(lImageNames,X,lnAdditionalFactors) then exit; + lnSubj :=lImageNames.Count div 2; + + //fx(lnAdditionalFactors); + //show matrix + //MsgStrings (lImageNames); + NPMMsg ('n Subjects = '+inttostr(lnSubj)); + for lSubj := 0 to (lnSubj-1) do begin + lStr := lImageNames[lSubj]+' <-> '+lImageNames[lSubj+lnSubj]; + if lnAdditionalFactors > 0 then + for lI := 1 to lnAdditionalFactors do + lStr := lStr+','+floattostr(X^[lI]^[lSubj+1]); + + + NPMMsg(lStr); + end; + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + + + NPMMsg('Mask = '+lMaskname); + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Number of observations = '+inttostr(lnSubj)); + + if lnSubj < 5 then begin + ShowMsg('Paired regression error: Requires at least 5 images per group.'); + goto 666; + end; + lOutName := lMaskName; + if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + //ShowMsg('Unimplemented Regress');// + Regress2NPMAnalyze (lImageNames, lMaskHdr, lOutname,X,lnAdditionalFactors,gNPMprefs.nPermute); + if lnAdditionalFactors > 1 then + DelMatrix(X, lnAdditionalFactors, lnSubj); + 666: + lImageNames.Free; +end; + +procedure TMainForm.LesionBtnClick(Sender: TObject); + label + 666; +var + lPrefs: TLDMPrefs ; +begin + lPrefs.NULP := gNPMPrefs.NULP; + if (1= (Sender as tMenuItem).tag) then begin //continuous + lPrefs.BMtest := BMmenu.checked; + lPrefs.Ttest := ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin //binomial + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.CritPct := -1; + lPrefs.nPermute := ReadPermute; + lPrefs.Run := 0;{0 except for montecarlo} + {if (not lPrefs.Ltest) and (not lPrefs.Ttest) and (not lPrefs.BMtest) then begin + ShowMsg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; code above defaults to t-test} + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + ShowMsg('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lPrefs.VALFilename := MainForm.OpenHdrDlg.Filename; + lPrefs.OutName := ExtractFileDirWithPathDelim(lPrefs.VALFilename)+'results'; + lPrefs.OutName := lPrefs.OutName+'.nii.gz'; + SaveHdrDlg.Filename := lPrefs.Outname; + if not SaveHdrName ('Base Statistical Map', lPrefs.OutName) then exit; + //Explicit mask + if not OpenDialogExecute('Select explicit mask [optional]',false,false,kImgPlusVOIFilter) then + lPrefs.ExplicitMaskName := '' + else + lPrefs.ExplicitMaskName := OpenHdrDlg.FileName; + + DoLesion (lPrefs); //Prefs.pas +end; + +function HasOption(const S: string):Boolean; +var + i: integer; +begin + result := false; + if (ParamCount < 1) then exit; + for i := 1 to ParamCount do + if ParamStr(i) = ('-'+S) then result := true; +end; + +procedure msg (s: string); +begin + writeln(s); +end; + +procedure ShowOptions (lTestInt: integer; lMaskFilename,lOutFilename: string); +begin + msg(' -c : CPU threads, Default : '+inttostr(gnCPUThreads)); + msg(' -m : mask name. Default "' +lMaskFilename+'"'); + msg(' -n : neighbors for TFCE, 0 for none. Default ' +inttostr(gNPMprefs.TFCE)); + msg(' -o : output name. Default "' +lOutFilename+'"'); + msg(' -p : Permutations, 0 for none. Default '+inttostr(gNPMprefs.nPermute)); + msg(' -r : RAM for processing (Mb). Default '+inttostr(gNPMPrefs.PlankMB)); + msg(' -t : test (0=continuous,1=binomial,2=regress,3=multiregress). Default '+inttostr(lTestInt)); + +end; + +procedure WriteHelp ; +begin + msg(GetKVers); + msg(' usage: '+ExtractFileName(ParseFileName(paramstr(0)))+' [options] [-t test] [valfilename]' ); + msg('Examples:'); + msg(' '+ ExtractFileName(ParseFileName(paramstr(0)))+' -t 0 test.val'); + msg(' '+ ExtractFileName(ParseFileName(paramstr(0)))+' -r 1024 -p 1000 -m mymask.nii -t 0 test.val'); + msg('Options:'); + msg(' -h : Help displayed'); +end; + +function GetOptionValue(const S: string):string; +var + i: integer; +begin + result := ''; + if (ParamCount < 2) then exit; + for i := 1 to (ParamCount-1) do + if ParamStr(i) = ('-'+S) then begin + result := ParamStr(i+1); + exit; + + end; +end; + +function GetOptionValueInt(lCmd: string; lDefault: integer): integer; +var + lResp : string; +begin + lResp := GetOptionValue(lCmd); + if length(lResp) < 1 then result := lDefault; + try + result := strtoint(lResp); + except + Writeln('Error '+(lResp)+' is not a valid integer.'); + result := lDefault; + end; +end; + +procedure doVLSM(lBinomial: boolean; VALFilename, lMaskFilename,lOutFilename: string); + var + lPrefs: TLDMPrefs ; +begin + lPrefs.NULP := gNPMPrefs.NULP; + if (not lBinomial) then begin //continuous + lPrefs.BMtest := true; + lPrefs.Ttest := true; + lPrefs.Ltest:= false; + end else begin //binomial + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.CritPct := -1; + lPrefs.nPermute := gNPMprefs.nPermute; + lPrefs.Run := 0;{0 except for montecarlo} + lPrefs.VALFilename := VALFilename; + lPrefs.OutName := lOutFilename; + lPrefs.ExplicitMaskName := lMaskFilename; + DoLesion (lPrefs); +end; + +(*procedure TMainForm.ProcessParamStr; +label + 666; +var + lTestInt: integer; + lMaskFilename : string; + lValFilename : string; + lOutFilename : string; +begin + lTestInt := 0; + lMaskFilename := ''; + lValFilename := ''; + lOutFilename := ''; + gnCPUThreads := GetLogicalCpuCount; + ReadIniFile; + // parse parameters + if (HasOption('h')) or (ParamCount = 0) then begin + WriteHelp; + ShowOptions(lTestInt, lMaskFilename, lOutFilename); + goto 666; + end; + if (HasOption('c')) then gnCPUThreads := GetOptionValueInt('c', gnCPUThreads); + if (HasOption('m')) then begin + lMaskFilename := GetOptionValue('m'); + if (not FileExistsEX(lMaskFilename)) then begin + WriteHelp ; + writeln('Can not find masking image '+ lMaskFilename); + + ShowOptions(lTestInt,lMaskFilename,lOutFilename); + goto 666; + end; + end; + if (HasOption('n')) then gnCPUThreads := GetOptionValueInt('n', gNPMprefs.TFCE); + if (HasOption('o')) then begin + lOutFilename := GetOptionValue('o'); + end; + if (HasOption('p')) then gNPMprefs.nPermute := GetOptionValueInt('p', gNPMprefs.nPermute); + if (HasOption('r')) then begin + gNPMPrefs.PlankMB := GetOptionValueInt('r', gNPMPrefs.PlankMB); + ComputePlankSize(gNPMPrefs.PlankMB); + end; + if (HasOption('t')) then lTestInt := GetOptionValueInt('t', lTestInt); + + + lValFilename := (paramstr(ParamCount)); + if (UpCaseExt(lValFilename) <> '.VAL') or (not FileExistsEX(lValFilename)) then begin + Writeln('Error: final option should be an existing file with the .val extension'); + WriteHelp ; + ShowOptions(lTestInt,lMaskFilename,lOutFilename); + goto 666; + end; + + if (lOutFilename = '') then begin + lOutFilename := ChangeFileExtX( lValFilename,'res.nii'); + end; + //show settings + ShowOptions(lTestInt,lMaskFilename,lOutFilename); + Writeln('VAL File: '+lValFilename); + if (lTestInt > 1) and (lMaskFilename = '') then begin + Writeln('Error: this test require you to specify a mask image'); + goto 666; + end; + //run test + Application.ProcessMessages; + case lTestInt of + 0: doVLSM(false, lVALFilename, lMaskFilename,lOutFilename);//continuous : t-test + 1: doVLSM(true, lVALFilename, lMaskFilename,lOutFilename);//binomial: Liebermeister + 2: NPMSingleRegress ( lVALFilename, lMaskFilename,lOutFilename); + 3: NPMMultipleRegressClick( lVALFilename, lMaskFilename,lOutFilename); + + end; + Writeln('Goodbye'); + Application.ProcessMessages; + + + //WriteIniFile; + // stop program loop + 666: + Close; +end; *) + +(*function TestT: string; +var + T: double; + l1,l0,lN: integer; + + lIn: DoubleP0; + lInp: pointer; + //TStat2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +begin + T := 666; + l1 := 16; + l0 := 8; + lN := l0+l1; + createArray64(lInp,lIn,lN); + lIn^[0] := 44 ; + lIn^[1] := 23 ; + lIn^[2] := 41 ; + lIn^[3] := 32 ; + lIn^[4] := 60 ; + lIn^[5] := 58 ; + lIn^[6] := 57 ; + lIn^[7] := 57 ; + lIn^[8] := 55 ; + lIn^[9] := 56 ; + lIn^[10] := 60; + lIn^[11] := 59; + lIn^[12] := 57; + lIn^[13] := 58; + lIn^[14] := 56; + lIn^[15] := 57; + lIn^[16] := 2 ; + lIn^[17] := 22; + lIn^[18] := 24; + lIn^[19] := 22; + lIn^[20] := 18; + lIn^[21] := 12; + lIn^[22] := 15 ; + lIn^[23] := 22; + + TStat2 (lN, l1, lIn, T); + result := floattostr(T); + freemem(lInp); + +end; *) + +procedure TMainForm.FormShow(Sender: TObject); +begin + NPMMsgClear; + NPMMsg(GetkVers); + {$IFNDEF UNIX} {GUILaunch;}{$ENDIF} + LongTimeFormat := 'YYYY-MMM-DD hh:nn:ss'; //delphi TimeToStr + ShortTimeFormat := 'YYYY-MMM-DD hh:nn:ss'; //freepascal TimeToStr + {$IFDEF FPC}{$IFNDEF UNIX} ReadParamStr; {$ENDIF} {$ENDIF} + {$IFDEF benchmark} + //MonteCarloSimulation1.visible := true; + {$ENDIF} + //StartTimer.enabled := true; +end; + +procedure TMainForm.PairedTMenuClick(Sender: TObject); +label + 666; +var + lnSubj,lSubj,lMaskVoxels: integer; + lImageNames: TStrings; + lMaskname,lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Paired T-test [Repeated Measures]'); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: mask selection failed.'); + goto 666; + end; //if not selected + //OpenHdrDlg.FileName := 'c:\vbmdata\mask50.nii.gz'; + lMaskname := OpenHdrDlg.Filename; + + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + ShowMsg('Error reading Mask image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + goto 666; + end; + if not ReadPairedFilenames(lImageNames) then exit; + lnSubj :=lImageNames.Count div 2; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + NPMMsg('Mask = '+lMaskname); + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Number of observations = '+inttostr(lnSubj)); + NPMMsg('Degrees of Freedom = '+inttostr(lnSubj-1)); + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + //show matrix + //MsgStrings (lImageNames); + NPMMsg ('n Subjects = '+inttostr(lnSubj)); + lStr := 'Image,'; + for lSubj := 0 to (lnSubj-1) do + NPMMsg(lImageNames[lSubj]+' <-> '+lImageNames[lSubj+lnSubj]); + if lnSubj < 4 then begin + ShowMsg('Paired t-test error: Requires at least 4 images per group.'); + goto 666; + end; + lOutName := lMaskName; + if not SaveHdrName ('Statistical Map', lOutName) then exit; + //if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + NPMAnalyzePaired (lImageNames, lMaskHdr, lMaskVoxels,lOutName); + //Regress2NPMAnalyze (lImageNames, lMaskHdr, lOutname); + 666: + lImageNames.Free; +end; + +procedure TMainForm.SingleSubjectZScores1Click(Sender: TObject); +label + 666; +var + lnSubj,lMnVoxels: integer; + lG: TStrings; + lMn,lStDev: string; + lMnHdr,lStDevHdr: TMRIcroHdr; +begin + if (not ttestmenu.checked) and (not BMmenu.checked) then begin + ShowMsg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Threads: '+inttostr(gnCPUThreads)); + if not OpenDialogExecute('Select mean image ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: mean selection failed.'); + exit; + end; //if not selected + lMn := OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr(lMn,lMnHdr) then begin + ShowMsg('Error reading mask.'); + exit; + end; + lMnVoxels := ComputeImageDataBytes8bpp(lMnHdr); + if (lMnVoxels < 2) or (not CheckVoxels(lMn,lMnVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mean file size too small.'); + exit; + end; + + if not OpenDialogExecute('Select StDev image ',false,false,kImgFilter) then begin + ShowMsg('NPM aborted: StDev selection failed.'); + exit; + end; //if not selected + lStDev := OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr(lStDev,lStDevHdr) then begin + showmessage('Error reading StDev.'); + exit; + end; + if not CheckVoxels(lStDev, lMnVoxels,kMaxImages) then begin + showmessage('Error Mean and StDev must have same size.'); + exit; + end; + NPMMsg('Mean name = '+ lMn); + NPMMsg('Total voxels = '+inttostr(lMnVoxels)); + //next, get 1st group + if not OpenDialogExecute('Select postive group (Z scores positive if this group is brighter)',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; //not sure why TStrings.Create does not work??? + lG.addstrings(OpenHdrDlg.Files); + lnSubj :=OpenHdrDlg.Files.Count; + NPMMsg('Subjects= '+inttostr(lnSubj)); + if not CheckVoxelsGroupX(lG,lMnHdr {lMnVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + NPMzscore (lG, lMnHdr,lStDevHdr); + 666: + lG.Free; +end; + +procedure TMainForm.MultipleRegressClick(Sender: TObject); +var lVALFilename, lMaskname,lOutname: string; +begin + Showmessage('This function has been superceded by nii_stat'); + exit; + + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + ShowMsg('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lVALFilename := MainForm.OpenHdrDlg.Filename; + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + exit; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + lOutName := lMaskName; + if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + NPMMultipleRegressClick(lVALFilename, lMaskname,lOutname); +end; + +procedure TMainForm.SingleRegressClick(Sender: TObject); +var lVALFilename, lMaskname,lOutname: string; +begin + showmessage('This function has been superceded with nii_stat'); + exit; + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then exit; + lVALFilename := MainForm.OpenHdrDlg.Filename; + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then exit; + lMaskname := OpenHdrDlg.Filename; + lOutname := lVALFilename; + NPMSingleRegress (lVALFilename, lMaskname,lOutname); +end; + +procedure TMainForm.AssociatevalfileswithNPM1Click(Sender: TObject); +begin +{$IFNDEF FPC}//unsupported by FreePascal + case MessageDlg('NPM installation:'+kCR+'Do you want .val fiels to automatically open NPM when you double click on their icons?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + id_No: exit; + end; + registerfiletype(kVALNativeExt,'NPM'{key},'NPM',Application.ExeName+',1'); +{$ENDIF} +end; + +procedure TMainForm.threadChange(Sender: TObject); +begin + (sender as tmenuitem).checked := true; + ReadThread; +end; + +(*procedure TMainForm.Countlesionoverlaps1Click(Sender: TObject); +label + 666; +var + lReps,lMax,lInc,lMaskVoxels,lDefault,lTotal,lPct: integer; + lG: TStrings; + lMaskname: string; + lMaskHdr: TMRIcroHdr; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select images to overlap',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if MainForm.OpenHdrDlg.Files.Count < 2 then begin + lTotal := NIFTIhdr_HdrVolumes(MainForm.OpenHdrDlg.Filename); + if lTotal < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE volumes. You selected less than two images.'); + exit; + end; + lG:= TStringList.Create; + for lReps := 1 to lTotal do + lG.Add(MainForm.OpenHdrDlg.Filename+':'+inttostr(lReps) ); + end else begin + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + end; + lMaskname := lG[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lG,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lTotal := lG.Count; + if lTotal > kMaxObs then + lTotal := kMaxObs; //this implemmentation uses 126 bits per voxel - we can not test more than this! + if lTotal > 100 then + lDefault := 100 + else + lDefault := lTotal; + lMax := ReadIntForm.GetInt('Enter maximum number of overlaps to test ', 3,lDefault,lTotal); + lDefault := lMax div 10; + if lDefault < 1 then + lDefault := 1; + lInc := ReadIntForm.GetInt('Enter overlap increment (e.g. if 5; then 5, 10, 15...) ', 1,lDefault,lMax); + lReps := ReadIntForm.GetInt('Enter number of times each increment is tested ', 1,10,100); + lPct := ReadIntForm.GetInt('Only include voxels damaged in N% of patients ', 0,5,100); + + NPMMsg('Voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Scans to permute = '+inttostr(lG.count)); + EvaluatePower (lG,lInc,lMax,lReps,lPct); + + //MakeMean(lG,lMaskHdr, odd((Sender as TMenuItem).tag),false); + 666: + lG.Free; +end; *) + + + +function TMainForm.FirthNPMAnalyze (var lImages: TStrings; var lPredictorList: TStringList; var lMaskHdr: TMRIcroHdr; lnCond,lnCrit: integer; var lSymptomRA: SingleP; var lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: bytep; + lOutImgSum : singleP; + lOutImg: SingleRAp; + {$IFDEF SINGLETHREAD}lnCPUThreads,{$ENDIF} + lCond,lPos,lPlank,lThread,lnDeficit: integer; + lTotalMemory,lVolVox,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadInc,lThreadEnd, lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT, lSum: double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if lnCond < 1 then + exit; + lnPermute := ReadPermute; + if lnPermute > 1 then begin + NPMMsg('NPM does not (yet) support permutation thresholding with Logisitic Regression.'); + lnPermute := 0; + end; + {$IFDEF SINGLETHREAD} + lnCPUThreads := gnCPUThreads; + if gnCPUThreads > 1 then + NPMMsg('July 2007 logistic regression will only use 1 thread. You may want to check for a software update'); + gnCPUThreads := 1; + {$ENDIF} + NPMMsg('Permutations = ' +IntToStr(lnPermute)); + NPMMsg('Logisitic Regression began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + NPMMsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + NPMMsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + //getmem(lOutImgL,lVolVox* sizeof(single)); + getmem(lOutImg,lnCond*sizeof(Singlep)); + for lCond := 1 to lnCond do begin + getmem(lOutImg^[lCond],lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImg^[lCond]^[lPos] := 0; + end; + //InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do + lOutImgSum^[lPos] := 0; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + ProgressBar1.Position := 1; + NPMMsg('Computing plank = ' +Inttostr(lPlank)); + Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + {$IFDEF FIRTHNOTHREAD} + FirthAnalyzeNoThread (lnCond, lnCrit,lnPermute,1,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg); + {$ELSE} + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TFirthThreadStat.Create ((lThread = ((gnCPUThreads+1) div 2)),MainForm, ProgressBar1,lnCond,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + NPMMsg('Thread ' +Inttostr(gThreadsRunning)+' = '+inttostr(lThreadStart)+'..'+inttostr(lThreadEnd)); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + + repeat + Application.processmessages; + until gThreadsRunning = 0; + {$ENDIF} //THREADED + Application.processmessages; + //showmessage('Threads done'); + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadDataLite(gnCPUThreads); //not yet lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + if lnVoxTested < 1 then begin + NPMMsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + //next report findings + NPMMsg('Voxels tested = ' +Inttostr(lnVoxTested)); + NPMMsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + reportBonferroni('Std',lnVoxTested); + //next: save data +(*savedata *) + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + for lCond := 1 to lnCond do begin + reportFDR (lPredictorList[lCond-1]+inttostr(lCond), lVolVox, lnVoxTested, lOutImg^[lCond]); + //reportPermute('L',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,lPredictorList[lCond-1]+inttostr(lCond),'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImg^[lCond],1); + end; +123: +//next: free dynamic memory + //FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + for lCond := 1 to lnCond do + freemem(lOutImg^[lCond]); + freemem(lOutImg); + + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + NPMMsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + NPMMsgSave(lOutNameMod); + + ProgressBar1.Position := 0; + {$IFDEF SINGLETHREAD} + gnCPUThreads := lnCPUThreads; + {$ENDIF} + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + NPMMsg('Unable to complete analysis.'); + ProgressBar1.Position := 0; + {$IFDEF SINGLETHREAD} + gnCPUThreads := lnCPUThreads; + {$ENDIF} +end; + +procedure TMainForm.PenalizedLogisticRegerssion1Click(Sender: TObject); +label + 666; +var + lVol,lMin,lMax,lI,lFact,lnFactors,lSubj,lnSubj,lMaskVoxels,lnCrit: integer; + lImageNames: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lStr: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lTempRA: singleP; + //lBinomial: boolean; +begin + Showmessage('This function has been superceded by nii_stat'); + exit; + // lBinomial := false; + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not GetValX(lnSubj,lnFactors,lMultiSymptomRA,lImageNames,lnCrit{,binom},lPredictorList) then + goto 666; + if (lnSubj < 2) or (lnFactors < 1) then begin + showmessage('This analysis requires at least 2 participants and one factor'); + goto 666; + end; + WarnIfLowNCrit(lnSubj,lnCrit); + lTemp4D := CreateDecompressed4D(lImageNames); + lMaskname := lImageNames[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st image: '+lMaskname); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + case MessageDlg('Do you want to add lesion volume as a regressor?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrYes: begin + //add a new condition called lesionvolume - create a new larger array for data + NPMMsg('Computing lesion volumes...'); + lPredictorList.Add('LesionVolume'); + GetMem(lTempRA,lnSubj*lnFactors*sizeof(single)); + for lI := 1 to (lnSubj*lnFactors) do + lTempRA^[lI] := lMultiSymptomRA^[lI]; + Freemem(lMultiSymptomRA); + GetMem(lMultiSymptomRA,lnSubj*(lnFactors+1)*sizeof(single)); + for lI := 1 to (lnSubj*lnFactors) do + lMultiSymptomRA^[lI] := lTempRA^[lI]; + Freemem(lTempRA); + //now create the new factor + lI := lnSubj*lnFactors; + for lSubj := 1 to lnSubj do + lMultiSymptomRA^[lI+lSubj] := ComputeLesionVolume(lImageNames[lSubj-1]); + //ensure there is variability in this regressor + lMin := round(lMultiSymptomRA^[lI+1]); + lMax := round(lMultiSymptomRA^[lI+1]); + for lSubj := 1 to lnSubj do begin + lVol := round(lMultiSymptomRA^[lI+lSubj]); + if lVol < lMin then lMin := lVol; + if lVol > lMax then lMax := lVol; + end; + if (lMin < 0) then begin + showmessage('Regression aborted: Error computing lesion volumes.'); + goto 666; + end; + if (lMin = lMax) then begin + showmessage('Regression aborted: no variability in lesion volume.'); + goto 666; + end; + inc(lnFactors); + end; //if user decides to include lesion volume + end; //case + + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + SaveHdrDlg.Filename := loutname; + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Firth Penalized regression is still beta software...'); + NPMMsg('Number of participants: '+inttostr(lnSubj)); + NPMMsg('Number of factors: '+inttostr(lnFactors)); + NPMMsg('Threads: '+inttostr(gnCPUThreads)); + //next - header shows factor names + lStr :='imagename'; + for lFact := 1 to lnFactors do + lStr := lStr+','+lPredictorList[lFact-1]; + NPMMsg(lStr); + For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lStr := lStr+','+realtostr(lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)],2); + end; + NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+lStr ); + end; + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + lOutName := lOutName+'.nii.gz'; + if not SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + FirthNPMAnalyze (lImageNames,lPredictorList,lMaskHdr,lnFactors,lnCrit, lMultiSymptomRA, lOutName); + 666: + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); +end; + +(*function ComputeIntersection ( lAname,lBname: string; var lUnion,lIntersection,lAnotB,lBnotA: integer): boolean; +label 667; +var + lOutName,lOutNameMod: string; + lVolVox,lVolVoxA,lVox: integer; + lImgA,lImgB: SingleP; + + lMaskHdr: TMRIcroHdr; + lA,lB: boolean; +begin + lUnion:= 0; + lIntersection := 0; + lAnotB := 0; + lBnotA := 0; + result := false; + //read A + if not NIFTIhdr_LoadHdr(lAname,lMaskHdr) then begin + showmessage('Error reading image A - '+lAname); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + getmem(lImgA,lVolVox*sizeof(single)); + if not LoadImg(lAname, lImgA, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + lVolVoxA := lVolVox; + //read B + if not NIFTIhdr_LoadHdr(lBname,lMaskHdr) then begin + showmessage('Error reading image B - '+lBname); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVoxA <> lVolVox) or (lVolVox < 1) then goto 667; + getmem(lImgB,lVolVox*sizeof(single)); + if not LoadImg(lBname, lImgB, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + for lVox := 1 to lVolVox do begin + lA := (lImgA^[lVox] <> 0); + lB := (lImgB^[lVox] <> 0); + if lA and lB then begin + //fx(lVox,lImgA^[lVox],lImgB^[lVox]); + inc(lIntersection); + end; + if lA or lB then + inc(lUnion); + if lA and not lB then + inc(lAnotB); + if lB and not lA then + inc(lBnotA); + + end; + freemem(lImgA); + freemem(lImgB); + result := true; + 667: +end; + +procedure TMainForm.ZtoP1Click(Sender: TObject); +var +lAname,lBname: string; var lUnion,lIntersection,lAnotB,lBnotA: integer; +begin +//removed + lAName := 'C:\mri\roc\p2.nii.gz'; + lBName := 'C:\mri\roc\RBD35.voi'; + if not ComputeIntersection ( lAName,lBName,lUnion,lIntersection,lAnotB,lBnotA) then + NPMMsg('Error'); + NPMMsg( lAName+' '+lBName+' I'+inttostr(lIntersection)+' U'+inttostr(lUnion)+' AnotB'+inttostr(lAnotB)+' BnotA'+inttostr(lBnotA)); + +end; *) + + +(*procedure TMainForm.ComputeIntersectionandUnion1Click(Sender: TObject); +label + 666; +var + lUnion,lIntersection,lAnotB,lBnotA, + lnSubj,lSubj,lMaskVoxels,lnAdditionalFactors: integer; + lImageNames: TStrings; + lMaskname, + lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; + X: PMatrix; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Compute intersection [A and B] and union [A or B] for a series of images'); + + + if not ReadPairedFilenamesReg(lImageNames,X,lnAdditionalFactors) then exit; + lnSubj :=lImageNames.Count div 2; + if lnAdditionalFactors > 1 then + DelMatrix(X, lnAdditionalFactors, lnSubj); + + lMaskname :=lImageNames[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading first image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Image file size too small.'); + goto 666; + end; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from first image.'); + goto 666; + end; + + + NPMMsg ('n Subjects = '+inttostr(lnSubj)); + for lSubj := 0 to (lnSubj-1) do begin + lStr := 'A=,'+lImageNames[lSubj]+',B=,'+lImageNames[lSubj+lnSubj]; + ComputeIntersection ( lImageNames[lSubj],lImageNames[lSubj+lnSubj],lUnion,lIntersection,lAnotB,lBnotA); + lStr := lStr + ',A and B=,'+inttostr(lIntersection); + lStr := lStr + ',A or B=,'+inttostr(lUnion); + lStr := lStr + ',A not B=,'+inttostr(lAnotB); + lStr := lStr + ',B not A=,'+inttostr(lBnotA); + NPMMsg(lStr); + end; + + //Msg('Mask = '+lMaskname); + //Msg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Number of observations = '+inttostr(lnSubj)); + 666: + lImageNames.Free; +end; //compute intersection and union + *) + +(*procedure TMainForm.ROCbinomialdeficit1Click(Sender: TObject); +begin + testROC; +end; + +procedure TMainForm.ROCcontinuousdeficit1Click(Sender: TObject); +begin + testROC2; +end; *) + +function isBinom ( lRA: singleP; lnObs: integer): boolean; +var + lI: integer; +begin + result := false; + if lnObs < 1 then exit; + for lI := 1 to lnObs do + if (lRA^[lI] <> 0) and (lRA^[lI] <> 1) then + exit; + result := true; +end; + +procedure Means ( lBinomRA,lContRA: singleP; lnObs: integer); +var + lI,ln0: integer; + lMeans0, lMeans1: double; +begin + lMeans0 := 0; + lMeans1 := 0; + ln0 := 0; + if lnObs < 1 then exit; + for lI := 1 to lnObs do begin + if (lBinomRA^[lI] = 0) then begin + inc(ln0); + lMeans0 := lMeans0 + lContRA^[lI]; + end else + lMeans1 := lMeans1 + lContRA^[lI]; + end; + if ln0 > 0 then + lMeans0 := lMeans0 / ln0; + if ln0 < lnObs then + lMeans1 := lMeans1 / (lnObs-ln0); + npmform.MainForm.memo1.lines.add('mean volume for '+inttostr(ln0)+' people who scored 0 is = '+floattostr(lmeans0)); + npmform.MainForm.memo1.lines.add('mean volume for '+inttostr(lnObs-ln0)+' people who scored 1 is = '+floattostr(lmeans1)); +end; + +function AUCbinomcontT (lBinomdataRA,lContdataRA: singlep; lnSubj :integer; var lT: double): double; +var + lIn : DoubleP0; + lnGroup0,lnGroup1,lI: integer; +begin + result := 0.5; + if lnSubj < 1 then + exit; + Getmem(lIn,lnSubj*sizeof(double)); + lnGroup0 := 0; + lnGroup1 := 0; + for lI := 1 to lnSubj do begin + if lBinomdataRA^[lI] = 0 then begin + lIn^[lnGroup0] := lContdataRA^[lI]; + inc (lnGroup0); + end else begin + inc (lnGroup1); + lIn^[lnSubj-lnGroup1] := lContdataRA^[lI]; + + end; + end; + result := continROC (lnSubj, lnGroup0, lIn); + TStat2 (lnSubj, lnGroup0, lIn,lT); + freemem(lIn); +end; + + +procedure Contrast(lBehavName,lROIname: string; lBehavRA,lLesionVolRA: singleP; lnSubj: integer); +var + lDF: integer; + lROC,lT,lP: double; +begin + if isBinom (lBehavRA,lnSubj) then begin + lROC := AUCbinomcontT (lBehavRA,lLesionVolRA, lnSubj,lT); + lDF := lnSubj-2; + lP := pTdistr(lDF,lT); + Means ( lBehavRA,lLesionVolRA, lnSubj); + + npmform.MainForm.memo1.lines.add('ROI=,'+lROIname+',Behav=,'+lBehavName+', Area Under Curve=,'+floattostr(lROC)+', T('+inttostr(lDF)+')=,'+floattostr(lT)+',p<,'+floattostr(lp)); + end else begin + lROC := AUCcontcont (lBehavRA,lLesionVolRA, lnSubj); + npmform.MainForm.memo1.lines.add('ROI=,'+lROIname+',Behav=,'+lBehavName+', Area Under Curve = '+floattostr(lROC)); + end; + //xxx +end; + (* +procedure ROIanalysis(var lROInames,lImageNames: TStrings; var lVALFilename: string); +label + 666; +var + lROI,lnROI,lVol,lMin,lMax,lI,lFact,lnFactors,lSubj,lnSubj,lMaskVoxels,lnCrit: integer; + //lROInames,lImageNames: TStrings; + lPredictorList: TStringList; + lVolStr,lTemp4D,lOutName,lStr: string; + lBehav: single; + lROIvolRA: doubleP; + lMultiSymptomRA,lLesionVolRA,lBehavRA: singleP; + lError: boolean; +begin + lnROI := lROINames.Count; + if lnROI < 1 then begin + showmessage('You need to select at least one ROI.'); + goto 666; + end; + //lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + if not GetValCore ( lVALFilename,lnSubj,lnFactors,lMultiSymptomRA,lImageNames,lnCrit,lPredictorList) then + goto 666; + lTemp4D := CreateDecompressed4D(lImageNames); + if (lnSubj < 1) or (lnFactors < 1) then begin + showmessage('This analysis requires at least 1 participant and one factor'); + goto 666; + end; + NPMMsgClear; + NPMMsg(GetKVers); + NPMmsg('Analysis began = ' +TimeToStr(Now)); + NPMMsg('VAL file name: '+MainForm.OpenHdrDlg.Filename); + NPMMsg('Number of participants: '+inttostr(lnSubj)); + NPMMsg('Number of factors: '+inttostr(lnFactors)); + NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + //next - header shows factor names + lStr :='imagename'; + for lFact := 1 to lnFactors do + lStr := lStr+','+lPredictorList[lFact-1]; + for lROI := 1 to lnROI do + lStr := lStr+','+lROInames[lROI-1]; + NPMMsg(lStr+',LesionVolume'); + lError := false; + Getmem(lROIVolRA, lnSubj*lnROI*sizeof(double)); + Getmem(lLesionVolRA, lnSubj*lnROI*sizeof(single)); + Getmem(lBehavRA, lnSubj*lnFactors*sizeof(single)); + for lROI := 1 to lnROI do begin + //if not ComputeIntersection ( lImageNames.Strings[lSubj-1],lROInames[lROI-1],lUnion,lIntersection,lAnotB,lBnotA) then + if not ComputeOverlap (lROInames[lROI-1],lImageNames, lROIvolRA^[lROI], singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1])) then begin + NPMmsg('Error computing overlap'); + goto 666; + end; + end; + For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lBehav := lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)]; + lStr := lStr+','+realtostr(lBehav,2); + lBehavRA^[((lFact-1)*lnSubj) +lSubj] := lBehav; + end; + for lROI := 1 to lnROI do + lStr := lStr+','+floattostr(lLesionVolRA^[((lROI-1)*lnSubj) +lSubj]); + lVolStr := floattostr(ComputeLesionVolume(lImageNames.Strings[lSubj-1])); + NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+lStr +','+lVolStr ); + end; + for lROI := 1 to lnROI do begin + for lFact := 1 to lnFactors do begin + Contrast(lPredictorList[lFact-1],lROInames[lROI-1],singlep(@lBehavRA^[((lFact-1)*lnSubj)+1]),singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1]),lnSubj);//,((lFact-1)*lnSubj),((lROI-1)*lnSubj)); + end; //for each factor + end; //for each ROI + for lROI := 1 to lnROI do begin + NPMMsg( lROInames[lROI-1] +' volume = '+floattostr(lROIvolRA^[lROI]) ) + end; //for each ROI + Freemem(lLesionVolRA); + Freemem(lBehavRA); + Freemem(lROIvolRA); +666: + lROInames.free; + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + NPMmsg('Analysis finished = ' +TimeToStr(Now)); +end; *) + + +procedure TMainForm.ROIanalysis1Click(Sender: TObject); +label + 666; +var + lROI,lnROI,lVol,lMin,lMax,lI,lFact,lnFactors,lSubj,lnSubj,lMaskVoxels,lnCrit: integer; + lROInames,lImageNames: TStrings; + lPredictorList: TStringList; + lVolStr,lTemp4D,lOutName,lStr: string; + lBehav: single; + lROIvolRA: doubleP; + lMultiSymptomRA,lLesionVolRA,lBehavRA: singleP; + lError: boolean; +begin + if not OpenDialogExecute('Select regions of interest',true,false,kImgPlusVOIFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lROInames:= TStringList.Create; + lROInames.addstrings(OpenHdrDlg.Files); + lnROI := lROINames.Count; + if lnROI < 1 then begin + showmessage('You need to select at least one ROI.'); + exit; + end; + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + if not GetValX(lnSubj,lnFactors,lMultiSymptomRA,lImageNames,lnCrit,lPredictorList) then + goto 666; + lTemp4D := CreateDecompressed4D(lImageNames); + if (lnSubj < 1) or (lnFactors < 1) then begin + showmessage('This analysis requires at least 1 participant and one factor'); + goto 666; + end; + NPMMsgClear; + NPMMsg(GetKVers); + NPMmsg('Analysis began = ' +TimeToStr(Now)); + NPMMsg('VAL file name: '+MainForm.OpenHdrDlg.Filename); + NPMMsg('Number of participants: '+inttostr(lnSubj)); + NPMMsg('Number of factors: '+inttostr(lnFactors)); + NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + //next - header shows factor names + lStr :='imagename'; + for lFact := 1 to lnFactors do + lStr := lStr+','+lPredictorList[lFact-1]; + for lROI := 1 to lnROI do + lStr := lStr+','+lROInames[lROI-1]; + NPMMsg(lStr+',LesionVolume'); + lError := false; + Getmem(lROIVolRA, lnSubj*lnROI*sizeof(double)); + Getmem(lLesionVolRA, lnSubj*lnROI*sizeof(single)); + Getmem(lBehavRA, lnSubj*lnFactors*sizeof(single)); + for lROI := 1 to lnROI do begin + //if not ComputeIntersection ( lImageNames.Strings[lSubj-1],lROInames[lROI-1],lUnion,lIntersection,lAnotB,lBnotA) then + if not ComputeOverlap (lROInames[lROI-1],lImageNames, lROIvolRA^[lROI], singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1])) then begin + NPMmsg('Error computing overlap'); + goto 666; + end; + end; + For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lBehav := lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)]; + lStr := lStr+','+realtostr(lBehav,2); + lBehavRA^[((lFact-1)*lnSubj) +lSubj] := lBehav; + end; + for lROI := 1 to lnROI do + lStr := lStr+','+floattostr(lLesionVolRA^[((lROI-1)*lnSubj) +lSubj]); + lVolStr := floattostr(ComputeLesionVolume(lImageNames.Strings[lSubj-1])); + NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+lStr +','+lVolStr ); + end; + for lROI := 1 to lnROI do begin + for lFact := 1 to lnFactors do begin + Contrast(lPredictorList[lFact-1],lROInames[lROI-1],singlep(@lBehavRA^[((lFact-1)*lnSubj)+1]),singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1]),lnSubj);//,((lFact-1)*lnSubj),((lROI-1)*lnSubj)); + end; //for each factor + end; //for each ROI + for lROI := 1 to lnROI do begin + NPMMsg( lROInames[lROI-1] +' volume = '+floattostr(lROIvolRA^[lROI]) ) + end; //for each ROI + Freemem(lLesionVolRA); + Freemem(lBehavRA); + Freemem(lROIvolRA); +666: + lROInames.free; + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + NPMmsg('Analysis finished = ' +TimeToStr(Now)); +end; + + +procedure TMainForm.Masked1Click(Sender: TObject); +var + lFilename,lMaskname: string; + lPos: Integer; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + exit; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + balance(lFilename,lMaskname,(Sender as TMenuItem).tag); + end; +end; + +function Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; +var + lImg8: ByteP; + lImg: SingleP; + lHdr: TMRIcroHdr; + lVolVox,lVox: integer; + lMin,lMax: single; + lModeLo,lModeHi,lIntercept,lSlope: single; + lOutNameMod: string; +begin + //lOutName := lMaskHdr.ImgFileName; + result := false; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + if not NIFTIhdr_LoadHdr(lImageName,lHdr) then begin + showmessage('Error reading '+lImageName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + getmem(lImg8,lVolVox*sizeof(byte)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; +if lZeroThresh then begin + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.nii'); + + lMin := 0; + lMax := 0 +end else begin + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.voi'); + + lMin := lIMg^[1]; + for lVox := 1 to lVolVox do + if lImg^[lVox] < lMin then lMin := lIMg^[lVox]; + + lMax := lIMg^[1]; + for lVox := 1 to lVolVox do + if lImg^[lVox] > lMax then lMax := lIMg^[lVox]; + for lVox := 1 to lVolVox do + lImg8^[lVox] := 0; + lMax := ((lMax-lMin) / 2)+lMin; +end; + for lVox := 1 to lVolVox do + if lImg^[lVox] > lMax then + lImg8^[lVox] := lNonZeroVal; + NPMMsg('Creating ' +lOutNameMod+' Threshold = '+floattostr(lMax)); + NIFTIhdr_SaveHdrImg8(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lImg8,1); + freemem(lIMg8); + freemem(lImg); +end; + + +procedure TMainForm.Binarizeimages1Click(Sender: TObject); +var + lFilename: string; + lPos: Integer; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + Binarize(lFilename,1,false); + //Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; + end; + NPMMsg('Done'); +end; + + + +procedure TMainForm.Setnonseroto1001Click(Sender: TObject); +var + lFilename: string; + lPos: Integer; +begin + NPMMsgClear; + NPMMsg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + Binarize(lFilename,100,true); + //Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; + end; +end; + +procedure TMainForm.Savetext1Click(Sender: TObject); +begin + SaveHdrDlg.Title := 'Save file as comma separated values (to open with Excel)'; + SaveHdrDlg.Filter := 'Comma Separated (*.csv)|*.csv|Text (*.txt)|*.txt'; + SaveHdrDlg.DefaultExt := '*.csv'; + if not SaveHdrDlg.Execute then exit; + Memo1.Lines.SaveToFile(SaveHdrDlg.Filename); +end; + +(* +function TMainForm.MakeSubtract (lPosName,lNegName: string): boolean; +var + lNegImg,lImg,lOutImg: SingleP; + lHdr,lNegHdr: TMRIcroHdr; + lVolVox,lVox: integer; + lOutNameMod: string; +begin + result := false; + if not NIFTIhdr_LoadHdr(lPosName,lHdr) then begin + ShowMsg('Error reading '+lPosName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + + if not NIFTIhdr_LoadHdr(lNegName,lNegHdr) then begin + showmessage('Error reading '+lNegName); + exit; + end; + if lVolVox <> (lNegHdr.NIFTIhdr.dim[1]*lNegHdr.NIFTIhdr.dim[2]* lNegHdr.NIFTIhdr.dim[3]) then begin + ShowMsg('Volumes differ'); + exit; + + end; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + getmem(lNegImg,lVolVox*sizeof(single)); + if not LoadImg(lNegHdr.ImgFileName, lNegImg, 1, lVolVox,round(lNegHdr.NIFTIhdr.vox_offset),1,lNegHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lNegHdr.ImgFileName); + exit; + end; + getmem(lOutImg,lVolVox*sizeof(single)); + for lVox := 1 to lVolVox do + lOutImg^[lVox] := lImg^[lVox] - lNegImg^[lVox]; + + + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; + lOutNameMod := ChangeFilePrefixExt(lPosName,'subtract_','.hdr'); + NPMMsg(lPosName+' - ' + lNegName+ ' = '+lOutNameMod); + NIFTIhdr_SaveHdrImg(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lOutImg,1); + + + freemem(lImg); + freemem(lOutImg); + freemem(lNegImg); +end;//makesubtract +*) + +(*procedure TMainForm.Subtract1Click(Sender: TObject); +var + lPosName,lNegName: string; +begin + if not OpenDialogExecute('Select positive',false,false,kImgPlusVOIFilter) then + exit; + lPosName := OpenHdrDlg.FileName; + if not OpenDialogExecute('Select negative',false,false,kImgPlusVOIFilter) then + exit; + lNegName := OpenHdrDlg.FileName; + MakeSubtract (lPosName,lNegName); + +end; *) + + + + + + {$IFDEF UNIX} +initialization + {$I npmform.lrs} +{$ELSE} //not unix: windows +initialization +{$IFDEF FPC} + {$I npmform.lrs} + {$ENDIF}//FPC + OleInitialize(nil); + +finalization + OleUninitialize +{$ENDIF} //Windows + +end. + diff --git a/npm/npmform.ppu b/npm/npmform.ppu new file mode 100644 index 0000000..1ac6c1a Binary files /dev/null and b/npm/npmform.ppu differ diff --git a/npm/old/anacom.pas b/npm/old/anacom.pas new file mode 100755 index 0000000..f551127 --- /dev/null +++ b/npm/old/anacom.pas @@ -0,0 +1,632 @@ +unit anacom; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr,filename, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +//procedure DoAnaCOM; +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; + + + +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lCombinedSymptomRA: singleP; + lPos,lPlank,lThread,lnControlsPlusPatients: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshBonf,lThreshPermute,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lBM,lttest,lLtest: boolean; + lnControlNeg: integer; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + lnControlNeg := lnControl; //negative for binomial test + lttest := lttestin; + lbm := lbmin; + if (not (lttest)) and (not (lbm)) then begin + lLtest := true; + lBM := true; + lnControlNeg := -lnControl; + end; + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + if lnControl < 1 then begin + MainForm.NPMmsg('AnaCom aborted - need data from at least 1 control individual'); + exit; + end; + lnPermute := 0;//MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + lnControlsPlusPatients := lImages.Count+lnControl; + createArray64(lObsp,lObs,lnControlsPlusPatients); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + //sumptom array for lesions AND controls + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + for lPos := 1 to lnControl do + lObs^[lPos-1+lImages.Count] := lControlSymptomRA^[lPos]; + getmem(lCombinedSymptomRA,lnControlsPlusPatients* sizeof(single)); + for lPos := 1 to lnControlsPlusPatients do + lCombinedSymptomRA^[lPos] := lObs^[lPos-1]; + //next create permuted BM bounds + if lBM then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + //for lPos := 1 to lImages.Count do + // lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lnControlsPlusPatients, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + + with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lnControlNeg,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,nil,lCombinedSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + //Next: NULPS + if lRun > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lnCrit,lnVoxTested,lPlankImg)); + + //lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit)); + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if (lRun < 1) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lRun < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + if lnControl < 1 then + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('attest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'attest'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaComthreshtt,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Mann Whitney + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('aBM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'aBM'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaCOMthreshbm,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + + + +(*function readCSV2 (lFilename: string; lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) or (MaxC < (kHdrCol+lCol2)) then begin + showmessage('problems reading CSV - not enough columns/rows '+inttostr(lCol1)+' '+inttostr(lCol2)); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := MaxC-1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + getmem(ldataRA2,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) or ((C-kHdrCol) = lCol2) then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then + ldataRA1^[R-kHdrRow] := lTempFloat + else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat; + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + ldataRA2^[R-1] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; *) + +function readTxt (lFilename: string; var lnObservations : integer; var ldataRA1: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lCol1: integer; + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lCol1:= 1; + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) then begin + showmessage('problems reading CSV - not enough columns/rows '); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := kHdrCol+lCol1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) {or ((C-kHdrCol) = lCol2)} then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then begin + //showmessage(lNumStr); + ldataRA1^[R-kHdrRow] := lTempFloat; + end; + {else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat;} + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + //showmessage(lNumStr+' '+inttostr(lnFactors)+' '+inttostr(C)); + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(inttostr(R)+' '+floattostr(lTempFLoat)); + ldataRA1^[R] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; + +(*procedure DoAnaCOM; +label + 666; +var + lControlFilename: string; + lI, lnControlObservations : integer; + lControldata: singlep; + lBinomial: boolean; + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('AnaCOM analysis requires TXT/CSV format text file.'); + npmform.MainForm.memo1.lines.add('One row per control participant.'); + npmform.MainForm.memo1.lines.add('First column is performance of that participant.'); + npmform.MainForm.memo1.lines.add('Example file:'); + //npmform.MainForm.memo1.lines.add('deficit, voxels'); + npmform.MainForm.memo1.lines.add('11'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('2'); + npmform.MainForm.memo1.lines.add('22'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('6'); + lControlFilename := 'c:\fx.txt'; + if (not readTxt (lControlFilename, lnControlObservations,lControldata)) or (lnControlObservations < 1) then begin + showmessage('Error reading file '+lControlFilename); + exit; + end; + npmform.MainForm.memo1.lines.add('Control (n='+inttostr(lnControlObservations)+')performance: '); + for lI := 1 to lnControlObservations do begin + npmform.MainForm.memo1.lines.add(inttostr(lI)+' '+floattostr(lControldata^[lI])); + + end; + //begin - copy + + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not MainForm.GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit,{,binom}lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + + + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then exit; + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + MainForm.NPMmsgClear; + MainForm.NPMMsg(MainForm.GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to lnSubj do + MainForm.NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroup(lImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + MainForm.ReportDescriptives(lSymptomRA,lnSubj); + AnacomLesionNPMAnalyze(lImageNames,lMaskHdr,lnCrit,-1,lnControlObservations,lSymptomRA,lControldata,lFactName,lOutname,true {ttest},false{BM}); + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + + Freemem(lMultiSymptomRA); + end; + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + ///end + //AnacomLesionNPMAnalyze ( lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttest,lBM: boolean): boolean; + freemem(lControldata); + + + +end;*) + +end. diff --git a/npm/old/lesion.pas b/npm/old/lesion.pas new file mode 100755 index 0000000..46b646b --- /dev/null +++ b/npm/old/lesion.pas @@ -0,0 +1,416 @@ +unit lesion; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; + + +function LesionNPMAnalyze2 (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnPermute: integer; var lSymptomRA: SingleP;var lFactname,lOutName: string; lttest,lBM: boolean): boolean; +function LesionNPMAnalyzeBinomial2 (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lnPermute: integer; var lSymptomRA: SingleP; var lFactname,lOutName: string): boolean; +var + gNULP,gROI: boolean; +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} +function LesionNPMAnalyze2 (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnPermute: integer; var lSymptomRA: SingleP;var lFactname,lOutName: string; lttest,lBM: boolean): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lPos,lPlank,lThread: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,//,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshPermute,lThreshBonf,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lPlankAllocated: boolean; + //lttest,lBM: boolean; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + lPlankAllocated := false; + //lnPermute := MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lPlankAllocated := true; + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + getmem(lOutImgAUC,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + //next create permuted BM bounds + if lBM then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lImages.Count, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA) do + //with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + //freemem(lPlankImg); + //lPlankAllocated := false; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if lRun < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + //save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + if lRun < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lRun < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + if lRun > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lnCrit,lnVoxTested,lPlankImg)); + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('ttest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('threshtt,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Brunner Munzel + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('BM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('threshbm,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgAUC); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + if lPlankAllocated then + freemem(lPlankImg); + //Next: NULPS - do this after closing all memory - this is a memory hog + if gNULP then + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit,lnVoxTested)); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + //if lRun > 0 then + // AX(freeram,freeram,freeram,freeram,freeram,freeram); + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + +function LesionNPMAnalyzeBinomial2 (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lnPermute: integer; var lSymptomRA: SingleP; var lFactname,lOutName: string): boolean; +label + 123,667; +var + lVal: single; + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgL,lOutImgAUC,lDummyImg, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lPos,lPlank,lThread,lnDeficit: integer; + lTotalMemory,lVolVox,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadInc,lThreadEnd, lnLesion, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT, lSum: double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + //lOutName := lMaskHdr.ImgFileName; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgL,lVolVox* sizeof(single)); + getmem(lOutImgAUC,lVolVox* sizeof(single)); + + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgL^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + ClearThreadDataPvals(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.ProgressBar1.Position := 1; + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + //with TLesionBinomial.Create (ProgressBar1,false,true,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,666, lDummyImg,lPlankImg,lOutImgSum,lOutImgL,lDummyImg,lSymptomRA) do + with TLesionBinom.Create (MainForm.ProgressBar1,false,true,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgL,lDummyImg,lOutImgAUC,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + MainForm.NPMmsg('Thread ' +Inttostr(gThreadsRunning)+' = '+inttostr(lThreadStart)+'..'+inttostr(lThreadEnd)); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + for lPos := 1 to lnPermute do begin + if (lPermuteMinT^[lPos] > 1.1) or (lPermuteMinT^[lPos] < -1.1) then + lPermuteMinT^[lPos] := 0.5; + if (lPermuteMaxT^[lPos] > 1.1) or (lPermuteMaxT^[lPos] < -1.1) then + lPermuteMaxT^[lPos] := 0.5; + lVal := lPermuteMaxT^[lPos]; + lPermuteMaxT^[lPos] := lPermuteMinT^[lPos]; + lPermuteMinT^[lPos] := lVal; + if lPermuteMaxT^[lPos] < 0 then + lPermuteMaxT^[lPos] := -pNormalInv(abs(lPermuteMaxT^[lPos])) + else + lPermuteMaxT^[lPos] := pNormalInv(lPermuteMaxT^[lPos]); + if lPermuteMinT^[lPos] < 0 then + lPermuteMinT^[lPos] := -pNormalInv(abs(lPermuteMinT^[lPos])) + else + lPermuteMinT^[lPos] := pNormalInv(lPermuteMinT^[lPos]); + end; + + + + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + //next report findings + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + MainForm.reportBonferroni('Std',lnVoxTested); + + //next: save data +//savedata + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); + +//future images will store Z-scores... + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +//save power map + lnDeficit := 0; + for lPos := 1 to lImages.Count do + if lSymptomRA^[lPos] = 0 then + inc(lnDeficit); + if Sum2PowerBinom(lOutImgSum,lVolVox,lImages.Count,lnDeficit) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + //save Liebermeister + + lOutNameMod := ChangeFilePostfixExt(lOutName,'L'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgL,1); + //save end + MainForm.reportFDR ('L', lVolVox, lnVoxTested, lOutImgL); + MainForm.reportPermute('L',lnPermute,lPermuteMaxT, lPermuteMinT); + +123: +//next: free dynamic memory + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgL); + freemem(lOutImgAUC); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + //Next: NULPS - do this at the end, it is a memory hog! + if gNULP then + MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit,lnVoxTested)); + + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + + MainForm.ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; + + + + + +end. diff --git a/npm/old/montecarlo.pas b/npm/old/montecarlo.pas new file mode 100755 index 0000000..726fba2 --- /dev/null +++ b/npm/old/montecarlo.pas @@ -0,0 +1,197 @@ +unit montecarlo; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); + +implementation + +uses npmform,filename,turbolesion; + +procedure RandomGroup(kSamplesPerTest: integer;lImageNames: TStrings;lSymptomRA: SingleP;var lPartImageNames: TStrings; var lPartSymptomRA: SingleP); +var + lTotal,lInc,lRand,lSwap: integer; + lRanOrder: longintP; +begin + lPartImageNames.Clear; + lTotal := lImageNames.Count; + if kSamplesPerTest > lTotal then begin + showmessage('Monte carlo error: population must be larger than sample size.'); + exit; + end; + //fx(lTOtal); + Getmem(lRanOrder,lTotal*sizeof(longint)); + for lInc := 1 to lTotal do + lRanOrder^[lInc] := lInc; + for lInc := lTotal downto 2 do begin + lRand := Random(lInc)+1; + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc]; + lRanOrder^[lInc] := lSwap; + end; + for lInc := 1 to kSamplesPerTest do begin + lPartImageNames.Add(lImageNames.Strings[lRanOrder^[lInc]-1]);//indexed from 0 + lPartSymptomRA^[lInc] := lSymptomRA^[lRanOrder^[lInc]]; + end; + Freemem(lRanOrder); +end; + +{$DEFINE notanacom} +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); +label + 666; +const + kSimSampleSize = 64; + knSim = 5; + kCrit = 3; + {$IFDEF anacom} + knControls = 64; + {$ENDIF} +var + lPrefs: TLDMPrefs ; + lSim,lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lPartImageNames,lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname,lOutNameSim: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA,lPartSymptomRA: singleP; + {$IFDEF anacom} + lnControlObservations: integer; + lControlSymptomRA: singleP; + {$ENDIF} +begin + //lBinomial := not odd( (Sender as tMenuItem).tag); + lPrefs.NULP := true{gNULP false}; + if not lBinomial then begin + lPrefs.BMtest := lbm;//BMmenu.checked; + lPrefs.Ttest := lttest;//ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.nCrit := kCrit; + lPrefs.nPermute := MainForm.ReadPermute;; + lPrefs.Run := 0;{0 except for montecarlo} + if (not lBinomial) and (not lTTest) and (not lBM) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPartImageNames := TStringList.Create; + getmem(lPartSymptomRA,kSimSampleSize*sizeof(single)); + {$IFDEF anacom} + lnControlObservations := knControls; + getmem(lControlSymptomRA,lnControlObservations*sizeof(single)); + for lSim := 1 to lnControlObservations do + lControlSymptomRA^[lSim] := 5; + {$ENDIF} + //next, get 1st group + if not MainForm.GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit{,binom},lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) or (lnSubjAll < kSimSampleSize) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') [sample size is '+inttostr(kSimSampleSize)+']or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + //randomization loop.... + for lSim := 1 to knSim do begin + RandomGroup(kSimSampleSize, lImageNames,lSymptomRA, lPartImageNames, lPartSymptomRA); + lOutNameSim := AddIndexToFilename(lOutName,lSim); + lnCrit := kCrit; + MainForm.NPMMsgClear; + //Msg(GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to kSimSampleSize do + MainForm.NPMMsg (lPartImageNames.Strings[lSubj-1] + ' = '+realtostr(lPartSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(kSimSampleSize)); + if not CheckVoxelsGroup(lPartImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lPrefs.Run := lSim; + if lBinomial then + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim) + else begin + MainForm.ReportDescriptives(lPartSymptomRA,lnSubj); + //TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim); + {$IFDEF anacom} + AnacomLesionNPMAnalyze (lPartImageNames, lMaskHdr, lnCrit,lSim,lnControlObservations, lPartSymptomRA,lControlSymptomRA, lFactname,lOutNameSim,lPrefs.Ttest,lPrefs.BMtest {lttest,lBM}); + {$ENDIF} + end; + end; //for each simulation... + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lPartImageNames.free; + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + freemem(lPartSymptomRA); + {$IFDEF anacom} + freemem(lControlSymptomRA); + {$ENDIF} + DeleteDecompressed4D(lTemp4D); +end; + + + +end. + + diff --git a/npm/options.inc b/npm/options.inc new file mode 100755 index 0000000..7cb7052 --- /dev/null +++ b/npm/options.inc @@ -0,0 +1,7 @@ +{ -------------------------------------------------------------------- } + +{$DEFINE SPREADSHEET} + +{If "DEFINE SPREADSHEET" then the VAL file design for will be created.} +{This uses the spread.* and design.* files} + diff --git a/npm/overlap.o b/npm/overlap.o new file mode 100644 index 0000000..6d4b7db Binary files /dev/null and b/npm/overlap.o differ diff --git a/npm/overlap.pas b/npm/overlap.pas new file mode 100755 index 0000000..6744ebc --- /dev/null +++ b/npm/overlap.pas @@ -0,0 +1,446 @@ +unit overlap; +{$H+} +{$Include ..\common\isgui.inc} +interface +uses +// Graphics, Controls, Forms, StdCtrls, ComCtrls,ExtCtrls, +Classes,nifti_hdr,define_types,SysUtils,dialogsx, +StatThdsUtil,Brunner,nifti_img,lesion_pattern, unpm; + + +Type + OverlapRA = array [1..1] of TLesionPattern;//Toverlap; + Overlapp = ^OverlapRA; + +function CountOverlap (var lImages: TStrings; lMinDeficits,lnVoxTested: integer): integer; +procedure EvaluatePower(var lFilenames: TStrings; lOverlapInc,lOverlapMax,lReps,lPct: integer); +function CountOverlap2(var lImages: TStrings; lMinDeficits, lnVoxTested: integer; lPlankImg: bytep): integer; + + +implementation + + +function SelectFiles (var lIn,lOut: TStrings; lN: integer): boolean; +//select (without replacement) lN filenames from the population lIn +var + lnFound,lTrial,lRan,lSwap: integer; + lRandRA: longintP; +begin + result := false; + lnFound := lIn.count; + + if (lnFound < lN) then + exit; //not enough items found + getmem(lRandRA,lnFound*sizeof(longint)); + for lTrial := 1 to lnFound do + lRandRA^[lTrial] := lTrial-1; //index to each strong + for lTrial := lnFound downto 2 do begin + //jumble order + lRan := random(lTrial)+1; + lSwap := lRandRA^[lTrial]; + lRandRA^[lTrial] := lRandRA^[lRan]; + lRandRA^[lRan] := lSwap; + end; + for lTrial := 1 to lN do + lOut.Add(lIn[lRandRA^[lTrial]]); + freemem(lRandRA); + result := true; +end; + +procedure EvaluatePower(var lFilenames: TStrings; lOverlapInc,lOverlapMax,lReps,lPct: integer); +label + 666; +var + lG: TStrings; + lSize,lRep: integer; +begin + if (lReps < 1) or (lOverlapMax < 1) or (lOverlapInc < 1) or (lOverlapMax > lFilenames.count) or (lOverlapInc > lOverlapMax) then begin + ShowMsg('Error with EvaluatePower inputs...'); + exit; + end; + + NPMMsgClear; + //MainForm.NPMmsg(kVers); + randomize; + NPMmsg('Power Analysis began = ' +TimeToStr(Now)); + lSize := lOverlapInc; + while lSize <= lOverlapMax do begin + for lRep := 1 to lReps do begin + lG:= TStringList.Create; + if not SelectFiles(lFilenames,lG,lSize) then begin + ShowMsg('Error selecting '+inttostr(lSize)+'files!'); + goto 666; + end; + CountOverlap(lG, round((lPct/100)*lSize),-1 ); + lG.Free; + end; //for lLoop + lSize := lSize + lOverlapInc; + end; //for lRep + NPMmsg('Analysis finished = ' +TimeToStr(Now)); + exit; + 666: //there has been a critical failure! + lG.Free; +end; + +(*function SelectFiles (lN: integer; var lOut: TStrings): boolean; +var + lnFound,lTrial,lRan,lSwap: integer; + lMaskExt,lFilePath: string; + lSearchRec: TSearchRec; + lF: TStrings; + lRandRA: longintP; +begin + result := false; + lF:= TStringList.Create; + lFilepath := 'C:\140\'; + lMaskExt := '*.voi'; + if FindFirst(lFilePath{+PathDelim}+lMaskExt, faAnyFile-faSysFile-faDirectory, lSearchRec) = 0 then begin + repeat + lF.add(lFilePath+lSearchRec.Name); + until (FindNext(lSearchRec) <> 0); + end; + lnFound := lF.count; + if (lnFound < lN) then begin + lF.free; + exit; + end; //not enough items found + getmem(lRandRA,lnFound*sizeof(longint)); + for lTrial := 1 to lnFound do + lRandRA[lTrial] := lTrial-1; //index to each strong + for lTrial := lnFound downto 2 do begin + //jumble order + lRan := random(lTrial)+1; + lSwap := lRandRA[lTrial]; + lRandRA[lTrial] := lRandRA[lRan]; + lRandRA[lRan] := lSwap; + end; + for lTrial := 1 to lN do + lOut.Add(lF[lRandRA[lTrial]]); + freemem(lRandRA); + lF.Free; + result := true; +end; + +procedure EvaluatePower; +label + 666; +var + lG: TStrings; + lMaskname: string; + lMaskHdr: TMRIcroHdr; + lMaskVoxels,lN,lLoop,lRep: integer; +begin + MainForm.NPMMsgClear; + //MainForm.NPMmsg(kVers); + randomize; + MainForm.NPMmsg('Power Analysis began = ' +TimeToStr(Now)); + for lRep := 7 to 10 do begin + for lLoop := 1 to 10 do begin + lN := lRep * 10; + lG:= TStringList.Create; + if not SelectFiles(lN,lG) then begin + ShowMsg('Error selecting '+inttostr(lN)+'files!'); + goto 666; + end; + {if not OpenDialogExecute('Select images to average',true,true,kImgFilter) then begin + ShowMsg('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files);} + + {$IFDEF FORMATVARIES} + //this next bit allows different types of scans to be read, but it is slow.... + lMaskname := lG[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + ShowMsg('Error reading mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not MainForm.CheckVoxelsGroup(lG,lMaskVoxels) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + {$ENDIF} + CountOverlap(lG, {round(0.1*lN)} 0); + lG.Free; + end; //for lLoop + end; //for lRep + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + exit; + 666: //there has been a critical failure! + lG.Free; +end; *) + + + + +function CountOverlap2(var lImages: TStrings; lMinDeficits, lnVoxTested: integer; lPlankImg: bytep): integer; +label + 123,667; +const + kMaxBit = 63; +var + lMaskName: string; + //lPlankImg: byteP; + lDouble,lTotalMemory: double; + lVoxPerPlankDiv10,lOffset,lnDeficits,lUniqueOrders, + lVolVox,lPos,lPlank,lVox,lDataType,lnVoxels,lImagesCount: integer; + lnPlanks,lVoxPerPlank,lStartVox,lEndVox,lPlankImgPos: int64; + lOverlapRA: Overlapp; + lOrder,lPrevOrder: TLesionPattern;//x TOverlap; + lMaskHdr: TMRIcroHdr; + //lPowerRA: array [1..kMaxBit] of int64; +procedure CheckOrder(var lObservedOrder: TLesionPattern); +var + lInc: integer; +begin + if lUniqueOrders > 0 then begin //see if this is unique + for lInc := 1 to lUniqueOrders do + if SameOrder(lObservedOrder,lOverlapRA^[lInc],lImagesCount) then + exit; //not unique + end; //UniqueOrders > 0 + //if we have not exited yet, we have found a new ordering! + lUniqueOrders := lUniqueOrders + 1; + lOverlapRA^[lUniqueOrders] := lObservedOrder; +end; +begin + result := -1; + //MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + //lMinDeficits := 0; + lUniqueOrders := 0; + lTotalMemory := 0; + lMaskName := lImages[0]; + lImagesCount := lImages.Count; + if lImagesCount < 1 then + goto 667; + if lImages.Count > (kMaxObs) then begin + NPMmsg('Only able to compute tests for <= '+inttostr(kMaxObs)+' overlays.'); + goto 667; + end; + if not NIFTIhdr_LoadHdr(lMaskName,lMaskHdr) then begin + NPMmsg('Error reading 1st image.'); + goto 667; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + lDataType := lMaskHdr.NIFTIhdr.datatype; + lOffset := round(lMaskHdr.NIFTIhdr.vox_offset); + //ShowMsg(inttostr(lVolVox)); + if (lVolVox < 1) then goto 667; + lVoxPerPlank := kPlankSz div lImages.Count {div sizeof(single)} ; + if (lVoxPerPlank = 0) then goto 667; //no data + lDouble := lVolVox;//force floating point multiplication in next step... + lTotalMemory := lDouble * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + lnVoxels := 0; + lStartVox := 1; + lEndVox := 0; + if lnVoxTested <= 0 then + getmem(lOverlapRA,lVolVox* sizeof(TLesionPattern)) + else + getmem(lOverlapRA,lnVoxTested* sizeof(TLesionPattern)); + for lPlank := 1 to lnPlanks do begin + NPMProgressBar(1); + + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lVolVox then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lVolVox); + lEndVox := lVolVox; + end; + lVoxPerPlankDiv10 := lVoxPerPlank div 10; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + {$IFDEF FORMATVARIES} + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + {$ELSE} + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,lOffset,lPlankImgPos,lDataType,lVolVox) then + {$ENDIF} + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lPrevOrder := EmptyOrder;//impossible: forces first voxel of each order to be checked + for lVox := 1 to lVoxPerPlank do begin + if (lVox mod lVoxPerPlankDiv10) = 0 then begin + NPMProgressBar((lVox div lVoxPerPlankDiv10)*10); + + end; + lOrder := EmptyOrder; + lPlankImgPos := 0; + lnDeficits := 0; + for lPos := 1 to lImages.Count do begin + if (lPlankImg^[lPlankImgPos + lVox] > 0) then begin + inc(lnDeficits); + SetBit(lPos,lOrder); + end; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end; + if (lnDeficits >= lminDeficits) then begin //this is different from the last voxel: perhaps this is a new ordering + if (not SameOrder(lOrder,lPrevOrder,lImagesCount)) then + CheckOrder(lOrder); + inc(lnVoxels); + end; + lPrevOrder := lOrder; + end; + lStartVox := lEndVox + 1; + end; + NPMmsg('n=,'+inttostr( lImages.Count)+',minN=,'+inttostr(lMinDeficits) +',unique overlap patterns,' +Inttostr(lUniqueOrders) +',voxels tested,' +Inttostr(lnVoxels)); +123: +//next: free dynamic memory + + freemem(lOverlapRA); + NPMProgressBar(0); + result := lUniqueOrders; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 0 then begin + freemem(lPlankImg); + freemem(lOverlapRA); + end; + NPMmsg('Unable to complete analysis.'); + NPMProgressBar( 0); +end; + +function CountOverlap(var lImages: TStrings; lMinDeficits,lnVoxTested: integer): integer; +var + lPlankImg: byteP; +begin + getmem(lPlankImg,kPlankSz); + result := CountOverlap2( lImages, lMinDeficits,lnVoxTested,lPlankImg); + freemem(lPlankImg); +end; + +(*function CountOverlap2(var lImages: TStrings; lMinDeficits: integer; lPlankImg: bytep): integer; +label + 123,667; + +var + lMaskName: string; + lVoxPerPlankDiv10,lOffset,lnDeficits,lUniqueOrders,lTotalMemory, + lImagesCount,lVolVox,lPos,lPlank,lVox,lDataType,lnVoxels: integer; + lnPlanks,lVoxPerPlank,lStartVox,lEndVox,lPlankImgPos: int64; + lOverlapRA: Overlapp; + lOrder,lPrevOrder: TLesionPattern; + lMaskHdr: TMRIcroHdr; + //lPowerRA: array [1..kMaxBit] of int64; + + +procedure CheckOrder(var lObservedOrder: TLesionPattern); +var + lInc: integer; +begin + if lUniqueOrders > 0 then begin //see if this is unique + for lInc := 1 to lUniqueOrders do + if SameOrder(lObservedOrder,lOverlapRA^[lInc],lImagesCount) then + exit; //not unique + end; //UniqueOrders > 0 + //if we have not exited yet, we have found a new ordering! + lUniqueOrders := lUniqueOrders + 1; + lOverlapRA^[lUniqueOrders] := lObservedOrder; +end; +begin + result := -1; + //NPMmsg('Analysis began = ' +TimeToStr(Now)); + //lMinDeficits := 0; + lUniqueOrders := 0; + lTotalMemory := 0; + lImagesCount := lImages.Count; + lMaskName := lImages[0]; + if lImages.Count < 1 then + goto 667; + if lImages.Count > (kMaxObs) then begin + NPMmsg('Only able to compute tests for <= '+inttostr(kMaxObs)+' overlays.'); + goto 667; + end; + if not NIFTIhdr_LoadHdr(lMaskName,lMaskHdr) then begin + NPMmsg('Error reading 1st image.'); + goto 667; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + lDataType := lMaskHdr.NIFTIhdr.datatype; + lOffset := round(lMaskHdr.NIFTIhdr.vox_offset); + //ShowMsg(inttostr(lVolVox)); + if (lVolVox < 1) then goto 667; + lVoxPerPlank := kPlankSz div lImages.Count ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := lVolVox * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + //ShowMsg('xx'); + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + //NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + //NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + //if lTotalMemory > kPLankSz then + + // getmem(lPlankImg,kPlankSz); + //else + // getmem(lPlankImg,lTotalMemory); + lnVoxels := 0; + lStartVox := 1; + lEndVox := 0; + getmem(lOverlapRA,lVolVox* sizeof(TLesionPattern)); + for lPlank := 1 to lnPlanks do begin + MainForm.ProgressBar1.Position := 1; + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lVolVox then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lVolVox); + lEndVox := lVolVox; + end; + lVoxPerPlankDiv10 := lVoxPerPlank div 10; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + {$IFDEF FORMATVARIES} + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + {$ELSE} + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,lOffset,lPlankImgPos,lDataType,lVolVox) then + {$ENDIF} + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lPrevOrder := EmptyOrder;//impossible: forces first voxel of each order to be checked + for lVox := 1 to lVoxPerPlank do begin + if (lVox mod lVoxPerPlankDiv10) = 0 then begin + MainForm.ProgressBar1.Position := (lVox div lVoxPerPlankDiv10)*10; + MainForm.Refresh; + Application.processmessages; + end; + lOrder := EmptyOrder; + lPlankImgPos := 0; + lnDeficits := 0; + for lPos := 1 to lImages.Count do begin + if (lPlankImg^[lPlankImgPos + lVox] > 0) then begin + inc(lnDeficits); + SetBit(lPos,lOrder); + end; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end; + if (lnDeficits >= lminDeficits) then begin //this is different from the last voxel: perhaps this is a new ordering + if (not SameOrder(lOrder,lPrevOrder,lImagesCount)) then + CheckOrder(lOrder); + inc(lnVoxels); + end; + lPrevOrder := lOrder; + end; + lStartVox := lEndVox + 1; + end; + NPMmsg('n=,'+inttostr( lImagesCount)+',minN=,'+inttostr(lMinDeficits) +',unique overlap patterns,' +Inttostr(lUniqueOrders) +',voxels tested,' +Inttostr(lnVoxels)); +123: +//next: free dynamic memory + //freemem(lPlankImg); + freemem(lOverlapRA); + //NPMmsg('Analysis finished = ' +TimeToStr(Now)); + MainForm.ProgressBar1.Position := 0; + result := lUniqueOrders; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 0 then begin + freemem(lPlankImg); + freemem(lOverlapRA); + end; + NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; *) + + +end. \ No newline at end of file diff --git a/npm/overlap.ppu b/npm/overlap.ppu new file mode 100644 index 0000000..09e7e2b Binary files /dev/null and b/npm/overlap.ppu differ diff --git a/npm/part.o b/npm/part.o new file mode 100644 index 0000000..3911ee8 Binary files /dev/null and b/npm/part.o differ diff --git a/npm/part.pas b/npm/part.pas new file mode 100755 index 0000000..1c2a991 --- /dev/null +++ b/npm/part.pas @@ -0,0 +1,555 @@ +unit part; +//Physiological Artifact Removal Tool +{$H+} +interface +uses + define_types,dialogsx,SysUtils; + +function ApplyPart( lFilename: string;lImgData: singleP; lBins,lVolVox,lSlices, lImgVol : integer; lTRsec: single): string; + +implementation +type + TPhysioT = RECORD + Triggers,InterpolatedTriggers: integer; + TriggerMedian,TriggerQ1,TriggerQ3: Double; + TriggerRA: singleP; + END; +function SaveTriggersAs3ColumnFSL(lPhysioIn: TPhysioT; lOutName: string): boolean; +var + lF: textfile; + lPos: integer; +begin + result := false; + if (lPhysioIn.Triggers < 1) then + exit; + assignfile(lF,lOutName+'.txt'); + Filemode := 0; + rewrite(lF); + for lPos := 1 to lPhysioIn.Triggers do + Writeln(lf,realtostr(lPhysioIn.TriggerRA^[lPos],3)+' 1 1'); + closefile(lF); + Filemode := 2; + result := true; +end; + +procedure qsort(lower, upper : integer; var Data:SingleP); +//40ms - fast but very recursive... +var + left, right : integer; + pivot,lswap: single; +begin + pivot:=Data^[(lower+upper) div 2]; + left:=lower; + right:=upper; + while left<=right do begin + while Data^[left] < pivot do left:=left+1; { Parting for left } + while Data^[right] > pivot do right:=right-1;{ Parting for right} + if left<=right then begin { Validate the change } + lswap := Data^[left]; + Data^[left] := Data^[right]; + Data^[right] := lswap; + left:=left+1; + right:=right-1; + end; //validate + end;//while left <=right + if right>lower then qsort(lower,right,Data); { Sort the LEFT part } + if upper>left then qsort(left ,upper,data); { Sort the RIGHT part } +end; + +procedure QuartileTriggerSpacing(var lPhysio: TPhysioT); +var + lTriggerDelayRA: singleP; + lPos: integer; +begin + lPhysio.TriggerQ1 := 0; + lPhysio.TriggerMedian := 0; + lPhysio.TriggerQ3 := 0; + if lPhysio.Triggers < 4 then + exit; + getmem(lTriggerDelayRA,(lPhysio.Triggers-1)*sizeof(single)); + for lPos := 1 to (lPhysio.Triggers-1) do + lTriggerDelayRA^[lPos] := abs(lPhysio.TriggerRA^[lPos]-lPhysio.TriggerRA^[lPos+1]); + qsort(1,lPhysio.Triggers-1,lTriggerDelayRA);//-1 : fence post vs wire + lPos := lPhysio.Triggers div 2; + lPhysio.TriggerMedian := lTriggerDelayRA^[lPos]; + lPos := lPhysio.Triggers div 4; + lPhysio.TriggerQ1 := lTriggerDelayRA^[lPos]; + lPos := round(0.75*lPhysio.Triggers ); + lPhysio.TriggerQ3 := lTriggerDelayRA^[lPos]; + freemem(lTriggerDelayRA); +end; + +function PARTool (var lPhysio: TPhysioT; lImgData: singleP; lTRsec: single; lnVolVox,lnSlices, lImgVol, lBinIn : integer): string; +const + kMinSamplesPerBin = 4; +var + lV,lSliceTime,lMeanSignal,lOnsetTime,lBinWidth,lBinMin,lBinMax,lTimeSinceTrigger,lPrevTriggerTime: double; + lSlice,lSlicePos,lnSliceVox,lnSlicePos,lVoxel,lBin,lSample,lnBin,lnBinDiv2,lNextTrigger,lSamplesWithVariance,lCorrectedSamples,lVolOffset: integer; + lBinCountRA,lVolBinRA: longintp; + lVariance : boolean; + lBinEstimateRA: doublep; +begin + result := ''; + if (lPhysio.Triggers < 4) or (lnVolVox < 4) or (lImgVol < 4) then begin + ShowMsg('PART requires at least 4 triggers and at least 4 volumes each with at least 4 voxels'); + exit; + end; + if (lBinIn < 4) then begin + ShowMsg('PART requires at least 4 data bins'); + exit; + end; + lnSliceVox := lnVolVox div lnSlices; + if (lnVolVox mod lnSlices) <> 0 then begin + ShowMsg('PART requires volvox to be evenly divisible by number of slices.'); + exit; + end; + lSamplesWithVariance := 0; + lCorrectedSamples := 0; + QuartileTriggerSpacing(lPhysio); + //find number bin range - this is median-1.5IQR..median+1.5IQR + lBinMin := -lPhysio.TriggerMedian/2-(abs(lPhysio.TriggerQ1-lPhysio.TriggerQ3)*0.75); + lBinMax := +lPhysio.TriggerMedian/2+abs(lPhysio.TriggerQ1-lPhysio.TriggerQ3)*0.75; + //next - create bins + lnBin := lBinIn; + //could adjust number of bins and return here wth a label + lBinWidth := abs((lBinMax-lBinMin)/(lnBin-1));//lnBin-1: fenceposts vs wire + lnBinDiv2 := (lnBin div 2)+1; + getmem(lBinCountRA,lnBin*sizeof(integer)); + getmem(lBinEstimateRA,lnBin*sizeof(double)); + getmem(lVolBinRA,lImgVol*sizeof(integer)); + lVoxel := 0; + for lSlice := 1 to lnSlices do begin + //adjust slices so slice 1 occurs at 0, slice 2 at 1/nslices... + lSliceTime := ((lSlice-1)/lnSlices)-1; //-1 as 1st volume starts at zero, not 1 + //do next step for each slice - different slices have different bin distributions due to different slicetime + //next count number of samples in each bin + for lBin := 1 to lnBin do + lBinCountRA^[lBin] := 0; + lPrevTriggerTime := -MaxInt; + lNextTrigger := 1; + for lSample := 1 to lImgVol do begin + //for each sample, find nearest trigger + lOnsetTime := lSample+lSliceTime; + if lOnsetTime > lPhysio.TriggerRA^[lNextTrigger] then begin + while (lNextTrigger <= lPhysio.Triggers ) and (lOnsetTime > lPhysio.TriggerRA^[lNextTrigger]) do begin + lPrevTriggerTime := lPhysio.TriggerRA^[lNextTrigger]; + inc(lNextTrigger); + end; //while + end;//if onset > + lTimeSinceTrigger := lOnsetTime-lPrevTriggerTime; + if lTimeSinceTrigger > abs(lPhysio.TriggerRA^[lNextTrigger]-lOnsetTime) then + lTimeSinceTrigger := -abs(lPhysio.TriggerRA^[lNextTrigger]-lOnsetTime);//use abs in case we are past final trigger + //now compute bin... + //inc(lCorrectedSamples); + if (lTimeSinceTrigger > lBinMin) and (lTimeSinceTrigger < lBinMax) then begin + lBin := round( (lTimeSinceTrigger)/ lBinWidth)+lnBinDiv2; + lVolBinRA^[lSample] := lBin; + if (lBin < 1) or (lBin > lnBin) then + fx(-661,lBin,lTimeSinceTrigger) + else + inc(lBinCountRA^[lBin]); + end else + lVolBinRA^[lSample] := 0; + end; //for each volume + for lSlicePos := 1 to lnSliceVox do begin + inc(lVoxel); + //first - only correct voxels with variability - do not waste time outside brain + lVolOffset := lVoxel; + lVariance := false; + lSample := 1; + lV := lImgData^[lVolOffset]; + while (not lVariance) and (lSample <= lImgVol) do begin + if lV <> lImgData^[lVolOffset] then + lVariance := true; + inc(lSample); + lVolOffset := lVolOffset+lnVolVox; + end; //while no variance + if lVariance then begin //voxel intensity varies accross time - attempt to remove artifact + lSamplesWithVariance := lSamplesWithVariance +lImgVol; + //1st - sum effects + for lBin := 1 to lnBin do + lBinEstimateRA^[lBin] := 0; + lMeanSignal := 0; + lVolOffset := lVoxel; + for lSample := 1 to lImgVol do begin + lMeanSignal := lImgData^[lVolOffset] + lMeanSignal; + lBin := lVolBinRA^[lSample]; + if (lBin > 0) and (lBinCountRA^[lBin] > kMinSamplesPerBin) then + lBinEstimateRA^[lBin] := lBinEstimateRA^[lBin]+ lImgData^[lVolOffset]; + lVolOffset := lVolOffset+lnVolVox; + end; //for each volume + lMeanSignal := lMeanSignal /lImgVol; + //next compute correction... average signal in bin - average voxel intensity irrelevant of bin + for lBin := 1 to lnBin do + if lBinCountRA^[lBin] > kMinSamplesPerBin then + lBinEstimateRA^[lBin] := (lBinEstimateRA^[lBin]/lBinCountRA^[lBin])-lMeanSignal; + //lBinEstimateRA[lBin] := lBinEstimateRA[lBin]-lBinMeanCount; + //next apply correction - inner loop complete for each voxel! + lVolOffset := lVoxel; + for lSample := 1 to lImgVol do begin + //for each sample, find nearest trigger + lBin := lVolBinRA^[lSample]; + if (lBin > 0) and (lBinCountRA^[lBin] > kMinSamplesPerBin) then begin + lImgData^[lVolOffset] := (lImgData^[lVolOffset]-lBinEstimateRA^[lBin]); + inc(lCorrectedSamples) + end; + lVolOffset := lVolOffset+lnVolVox; + end; //for each volume + end; //if variance + end;//for each voxel in slice + end; //for slice + //**INNER LOOP end - + //next - report results + result :=' Time per vol (TR) [sec] '+realtostr(lTRsec,4)+kCR; + result :=result +' fMRI Volumes '+inttostr(lImgVol)+kCR; + result :=result +' Triggers n/First...Last [vol] '+realtostr(lPhysio.Triggers,0)+'/'+realtostr(lPhysio.TriggerRA^[1],2)+'...'+realtostr(lPhysio.TriggerRA^[lPhysio.Triggers],2)+kCR; + if abs(lImgVol-lPhysio.TriggerRA^[lPhysio.Triggers]) > 10 then begin + result :=result +'******* WARNING: Duration of fMRI session and duration of triggers is very different *******'; + result :=result +'******* Please ensure specified TR is correct, files are correct and onset of fMRI was synchronized with physio data *******'; + end; + result := result + ' Q1/Median/Q2 [sec] '+realtostr(lTRsec*lPhysio.TriggerQ1,2)+'/'+realtostr(lTRsec*lPhysio.TriggerMedian,2)+'/'+realtostr(lTRsec*lPhysio.TriggerQ3,2)+kCR; + result := result + ' Bin n/Range [sec] '+inttostr(lnBin)+'/'+realtostr(lTRsec*lBinMin,2)+ '...'+realtostr(lTRsec*lBinMax,2)+kCR; + result := result+ ' voxels without variance (outside brain) %: '+realtostr(100*( (lnVolVox-(lSamplesWithVariance/lImgVol))/lnVolVox),2)+kCR; + if lSamplesWithVariance > 0 then + result := result+ ' voxels with variance which were corrected %: '+realtostr(100*(lCorrectedSamples/lSamplesWithVariance),2)+kCR; + for lBin := 1 to lnBin do + result := result+(' Bin '+inttostr(lBin)+ ' '+realtostr(lBin*lBinWidth+lBinMin ,2) +' '+inttostr(lBinCountRA^[lBin]) )+kCR; + freemem(lBinCountRA); + freemem(lBinEstimateRA); + freemem(lVolBinRA); +end; + + +function StrVal (var lNumStr: string): integer; +begin + try + result := strtoint(lNumStr); + except + on EConvertError do begin + ShowMsg('StrVal Error - Unable to convert the string '+lNumStr+' to a number'); + result := MaxInt; + end; + end; +end; + +procedure AddSample(var lNumStr: string; var lnTotal,lnSample, lnTrigger: integer; var lPhysio: TPhysioT); +var + lVal: integer; +begin + lVal := StrVal(lNumStr); + if lVal = 5003 then + exit; + lNumStr := ''; + inc(lnTotal); + if lnTotal < 5 then exit; + if lVal > 4096 then begin + if lVal <> 5000 then begin + ShowMsg('Potentially serious error: unknown trigger type : '+inttostr(lVal)); + end; + inc(lnTrigger); + if (lPhysio.Triggers <> 0) then + lPhysio.TriggerRA^[lnTrigger] := lnSample; + end else begin + inc(lnSample); + end; +end; + +function AdjustStartPos (var lStr: string; var lStartPos: integer): boolean; +//Some Siemens physio files appear to have nonsense characters befor real data<bh:ef><bh:bb><bh:bf>1 +var + lLen: integer; +begin + lLen := length(lStr); + result := false; + if (lLen-lStartPos)<2 then + exit; + result := true; + repeat + if lStr[lStartPos] in [ '0'..'9'] then + exit; + inc(lStartPos); + until (lStartPos = lLen); + result := false; +end; + +procedure CountValidItems(var lStr: string; var lStartPos,lnSample, lnTrigger: integer; var lPhysio: TPhysioT); +label + 123; +var + lPos,lnTotal: integer; + lNumStr: string; +begin + lnTotal:= 0; + lnSample := 0; + lnTrigger := 0; + lNumStr := ''; + if length(lStr)<2 then exit; + if not AdjustStartPos ( lStr, lStartPos) then exit; //Oct 2009 + for lPos := lStartPos to length(lStr) do begin + if (lStr[lPos] = ' ') and (lNumStr <> '') then begin + if lNumStr = '5003' then begin + lNumStr := ''; + goto 123; //end of recording + end else + AddSample(lNumStr, lnTotal,lnSample, lnTrigger, lPhysio); + end else begin + if lStr[lPos] in [ '0'..'9'] then + lNumStr := lNumStr + lStr[lPos] + else if lStr[lPos] in [' '] then + + else begin + //Showmessage(lStr[lPos]); + goto 123; + end; + end; + end; //for length +123: + if (lNumStr <> '') then + AddSample(lNumStr, lnTotal,lnSample, lnTrigger, lPhysio); + lStartPos := lPos; + while (lStartPos < length(lStr)) and ( lStr[lStartPos] <> ' ') do begin + inc(lStartPos); + end; +end; + +procedure CreatePhysio (var lPhysio: TPhysioT); +begin + lPhysio.Triggers := 0; + +end; + +procedure ClosePhysio (var lPhysio: TPhysioT); +begin + with lPhysio do begin + if Triggers > 0 then + freemem(TriggerRA); + Triggers := 0; + end; +end; + +procedure InitPhysio(lnTrigger: integer; var lPhysio: TPhysioT); +begin + ClosePhysio (lPhysio); + with lPhysio do begin + Triggers := lnTrigger; + InterpolatedTriggers := 0; + if Triggers > 0 then + getmem(TriggerRA,Triggers*sizeof(single)); + end; +end; + +function load3ColTxtPhysio (lFilename: string; var lPhysio: TPhysioT): boolean; +var + F: TextFile; + lnTrigger: integer; + lFloat,lFloat2,lFloat3: single; +begin + result := false; + if not fileexists(lFilename) then exit; + ClosePhysio(lPhysio); + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //pass 1 - count number of triggers + lnTrigger := 0; + Reset(F); + while not EOF(F) do begin + {$I-} + read(F,lFloat,lFloat2,lFloat3); //read triplets instead of readln: this should load UNIX files + {$I+} + if (ioresult = 0) and (lFloat > 0) then + inc(lnTrigger); + end; + //pass 2 - load array + InitPhysio(lnTrigger, lPhysio); + lnTrigger := 0; + Reset(F); + while not EOF(F) do begin + {$I-} + read(F,lFloat,lFloat2,lFloat3); //read triplets instead of readln: this should load UNIX files + {$I+} + if (ioresult = 0) and (lFloat > 0) then begin + inc(lnTrigger); + lPhysio.TriggerRA^[lnTrigger] := lFloat; + end; + end; + FileMode := 2; //Set file access to read/write + CloseFile(F); + result := true; +end; + +procedure ReadlnX (var F: TextFile; var lResult: string); +var + lCh: char; +begin + lResult := ''; + while not Eof(F) do begin + Read(F, lCh); + if (lCh in [#10,#13]) then begin + if lResult <> '' then begin + //Showmessage(lResult); + exit; + end; + end else + lResult := lResult + lCh; + end; +end; //ReadlnX + + +function loadSiemensPhysio (lFilename: string; var lPhysio: TPhysioT): boolean; +var + F: TextFile; + lStr: string; + lPos,lnSample,lnTrigger: integer; +begin + result := false; + if not fileexists(lFilename) then exit; + ClosePhysio(lPhysio); + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + Reset(F); + ReadlnX(F,lStr);//ColNames + if length(lStr) < 1 then begin + CloseFile(F); + exit; + end; + //first pass - count items + lPos := 1; + CountValidItems(lStr,lPos,lnSample,lnTrigger,lPhysio); + //second pass - load array + if (lnSample < 1) and (lnTrigger < 1) then begin + CloseFile(F); + exit; + end; + //2nd pass... + InitPhysio(lnTrigger, lPhysio); + lPos := 1; + CountValidItems(lStr,lPos,lnSample,lnTrigger,lPhysio); + FileMode := 2; //Set file access to read/write + CloseFile(F); + result := true; +end; + +function InterpolateGaps (var lPhysioIn: TPhysioT): boolean; +//attempts to fill missing trigger pulses +//you must call QuartileTriggerSpacing before this function! +// it assumes q1/median/q3 are filled +var + lGap,l2Min,l2Max,l3Min,l3Max: double; + lnReplace,lTrigger,lTrigger2: integer; + lTempPhysio: TPhysioT; +begin + result := false; + if (lPhysioIn.Triggers < 4) then begin + ShowMsg('InterpolateGaps requires at least 4 triggers.'); + exit; + end; + l2Min := 2*lPhysioIn.TriggerMedian-(abs(lPhysioIn.TriggerQ1-lPhysioIn.TriggerQ3)*1.5); + l2Max := 2*lPhysioIn.TriggerMedian+(abs(lPhysioIn.TriggerQ1-lPhysioIn.TriggerQ3)*1.5); + + l3Min := 3*lPhysioIn.TriggerMedian-(abs(lPhysioIn.TriggerQ1-lPhysioIn.TriggerQ3)*1.5); + l3Max := 3*lPhysioIn.TriggerMedian+(abs(lPhysioIn.TriggerQ1-lPhysioIn.TriggerQ3)*1.5); + if l2Max > l3Min then + exit; //variability too high to determine gaps + lnReplace := 0; + for lTrigger := 2 to lPhysioIn.Triggers do begin + lGap := lPhysioIn.TriggerRA^[lTrigger] - lPhysioIn.TriggerRA^[lTrigger-1]; + if (lGap > l2Min) and (lGap < l2Max) then + inc(lnReplace); + if (lGap > l3Min) and (lGap < l3Max) then + inc(lnReplace,2); + end; + if lnReplace = 0 then begin + result := true; + exit; + end; + //create temp backup + CreatePhysio(lTempPhysio); + InitPhysio(lPhysioIn.Triggers, lTempPhysio); + for lTrigger := 1 to lPhysioIn.Triggers do + lTempPhysio.TriggerRA[lTrigger] := lPhysioIn.TriggerRA[lTrigger]; + //create resized array + InitPhysio(lTempPhysio.Triggers+lnReplace, lPhysioIn); + //fill gaps + lPhysioIn.TriggerRA[1] := lTempPhysio.TriggerRA[1]; + lTrigger2 := 1; + for lTrigger := 2 to lTempPhysio.Triggers do begin + inc(lTrigger2); + lGap := lTempPhysio.TriggerRA^[lTrigger] - lTempPhysio.TriggerRA^[lTrigger-1]; + if ((lGap > l2Min) and (lGap < l2Max)) then begin //1 beat + lPhysioIn.TriggerRA^[lTrigger2] := lTempPhysio.TriggerRA^[lTrigger-1]+(lgap / 2); + inc(lTrigger2); + end; + if ((lGap > l3Min) and (lGap < l3Max)) then begin //2 beats + lPhysioIn.TriggerRA^[lTrigger2] := lTempPhysio.TriggerRA^[lTrigger-1]+(lgap / 3); + inc(lTrigger2); + lPhysioIn.TriggerRA^[lTrigger2] := lTempPhysio.TriggerRA^[lTrigger-1]+(2*lgap / 3); + inc(lTrigger2); + end; + lPhysioIn.TriggerRA^[lTrigger2] := lTempPhysio.TriggerRA^[lTrigger]; + end; + ClosePhysio (lTempPhysio); + lPhysioIn.InterpolatedTriggers := lnReplace; + result := true; +end; + +function ScalePhysioToTime(lPhysio: TPhysioT; lSamplesPerUnit: single): boolean; +var + lScale: single; + lTrigger: integer; +begin + result := false; + if (lPhysio.Triggers < 4) then begin + ShowMsg('ScalePhysioToTR requires at least 4 triggers.'); + exit; + end; + if (lSamplesPerUnit <= 0) then begin + ShowMsg('ScalePhysioToTime requires TR(sec) and samples/sec >0.'); + exit; + end; + lScale := 1/(lSamplesPerUnit); //use reciprocal: mults faster than divides + for lTrigger := 1 to lPhysio.Triggers do + lPhysio.TriggerRA^[lTrigger] := lPhysio.TriggerRA^[lTrigger] * lScale; + result := true; +end; + +procedure EnsureAscending(lPhysio: TPhysioT); +//check if order is correct - if not the sort... +//an alternative is to always sort, but this method is faster and less resource intensive for sorted data +var + lPos: integer; +begin + if lPhysio.Triggers < 2 then exit; + for lPos := 2 to lPhysio.Triggers do begin + if lPhysio.TriggerRA^[lPos] < lPhysio.TriggerRA^[lPos-1] then begin + ShowMsg('Warning: input times are not in ascending order - data will be sorted.'); + qsort(1,lPhysio.Triggers,lPhysio.TriggerRA); //ensure trigger timings are in order... + exit; + end; + end; +end; + +function ApplyPart( lFilename: string;lImgData: singleP; lBins,lVolVox,lSlices, lImgVol : integer; lTRsec: single): string; +var + lPhysio: TPhysioT; +begin + result := ''; + if not fileexists (lFilename) then exit; + CreatePhysio(lPhysio); + if UpCaseExt(lFilename) = '.TXT' then begin + if not load3ColTxtPhysio(lFilename,lPhysio) then exit; + end else + if not loadSiemensPhysio(lFilename,lPhysio) then exit; + EnsureAscending(lPhysio); + QuartileTriggerSpacing(lPhysio); + if not InterpolateGaps (lPhysio) then + exit; + if UpCaseExt(lFilename) <> '.TXT' then begin//export Siemens file as 3-column text + ScalePhysioToTime(lPhysio,50); //50: siemens files use 50 Hz sampling -> convert to sec + SaveTriggersAs3ColumnFSL(lPhysio,lFilename); //do this before TR conversion... + end; + ScalePhysioToTime(lPhysio,lTRsec); //Convert sec to volumes + result := PARTool (lPhysio,lImgData,lTRsec,lVolVox,lSlices, lImgVol, lBins); + ClosePhysio(lPhysio); +end; + +end. \ No newline at end of file diff --git a/npm/part.ppu b/npm/part.ppu new file mode 100644 index 0000000..b291cee Binary files /dev/null and b/npm/part.ppu differ diff --git a/npm/prefs.o b/npm/prefs.o new file mode 100644 index 0000000..d62aa5b Binary files /dev/null and b/npm/prefs.o differ diff --git a/npm/prefs.pas b/npm/prefs.pas new file mode 100755 index 0000000..83c83c6 --- /dev/null +++ b/npm/prefs.pas @@ -0,0 +1,248 @@ +unit prefs; + +{$H+} +interface +uses + inifiles, define_types,SysUtils,classes,turbolesion,dialogsx; + +function DoLesion (var lPrefs: TLDMPrefs): boolean; +procedure SetDefaultPrefs (var lPrefs: TLDMPrefs); +function WarnIfLowNCrit(lnSubj,lnCrit: integer): boolean; +//procedure ReadParamStr; + +implementation + +uses nifti_img, hdr,nifti_hdr, valformat,StatThdsUtil,filename, unpm; + +procedure SetDefaultPrefs (var lPrefs: TLDMPrefs); +begin + lPrefs.tTest := true; + lPrefs.BMtest := false; + lPrefs.Ltest := false; + lPrefs.nPermute := 0; + lPrefs.CritPct := -1;//use default in val file + lPrefs.ExplicitMaskName := ''; + lPrefs.ValFilename := ''; + lPrefs.Outname := ''; +end; + +function noVariance (lRA: singlep; lnSubj: integer): boolean; +var + lI : integer; +begin + result := false; + if lnSubj < 2 then exit; + for lI := 2 to lnSubj do + if lRA^[1] <> lRA^[lI] then + exit; + result := true; +end; + +function WarnIfLowNCrit(lnSubj,lnCrit: integer): boolean; +//returns true if warning generated +begin + result := (round(lnSubj * 0.15) ) > lnCrit; //15% + if result then + Showmsg('Warning: low statistical power as tests computed for voxels damaged in at least '+inttostr(lnCrit) +' people. Solution: change Design value "Ignore voxels damaged in less than N%".'); + +end; + +function DoLesion (var lPrefs: TLDMPrefs): boolean; + label + 666; +var + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCritV,lCritPctV: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + if (not lPrefs.BMtest) and (not lPrefs.ttest) and (not lPrefs.LTest) then begin + NPMmsg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + if not GetValCore(lPrefs.ValFilename, lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCritV,lCritPctV,lPredictorList) then begin + NPMmsg('Error with VAL file'); + goto 666; + end; + if lPrefs.critPct < 0 then //-1 denotes using the values specified in the VAL file + lPrefs.critPct := lCritPctV; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + NPMmsg('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + WarnIfLowNCrit(lnSubjAll, round( (lnSubjAll*lPrefs.CritPct)/100)); + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + NPMmsg('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + NPMmsg('Mask file size too small.'); + goto 666; + end; + if (lPrefs.OutName = '') or (not DirExists(extractfiledir(lPrefs.Outname))) then begin + lPrefs.Outname := extractfiledir(lPrefs.ValFilename)+pathdelim+'results.nii.gz'; + NPMmsg('Output stored as '+lPrefs.Outname); + end; + for lFact := 1 to lnFactors do begin + NPMMsgClear; + NPMMsg(GetKVers); + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + if (not lPrefs.LTest) or (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 0) OR (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 1) THEN begin + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + end else begin + NPMMsg('Data rejected: behavior must be zero or one for binomial test '+lImageNamesAll.Strings[lSubj-1]); + end; + lnSubj := lImageNames.Count; + if lnSubj > 2 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do begin + if (not lPrefs.LTest) or (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 0) OR (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 1) THEN begin + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; //valid value + end; //not binomial, or 1/0 + end; //for each subject + NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + NPMMsg('Factor = '+lFactname); + For lSubj := 1 to lnSubj do + NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + lPrefs.nCrit := round( (lnSubj*lPrefs.CritPct)/100); + NPMMsg('Only testing voxels damaged in at least '+inttostr(lPrefs.nCrit)+' individual[s]'); + NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroupX(lImageNames,lMaskHdr {lMaskVoxels}) then begin + NPMMsg('Error: File dimensions differ from mask.'); + goto 666; + end; + if noVariance (lSymptomRA,lnSubj) then + NPMMsg('Error no variability in behavioral data ') + else + TurboLDM (lImageNames, lMaskHdr, lPrefs, lSymptomRA, lFactname,lPrefs.OutName); + Freemem(lSymptomRA); + end else begin + NPMMsg('At least 2 individuals required to compute statistics for '+lPredictorList.Strings[lFact-1]); + end; //lnsubj > 2 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); +end; + +(*procedure ShowHelp; +begin + NPMMsg('usage ''npm [options] -o resultsfilname valfilename'' '); + NPMMsg(' Options '); + NPMMsg(' -c: critical percent 0..100 '); + NPMMsg(' -p: permutations 0..4000 '); + NPMMsg(' -t: Test [1=Liebermeister, 2=TTest, 4=BMtest, 6=t&BMtests'); + NPMMsg(' -o: Output filename'); + NPMMsg('examples:'); + NPMMsg(' npm -c 25 -p 1000 -o c:\results.nii.gz c:\mri\data.val'); + NPMMsg(' npm -c 25 -o "c:\program files\results.hdr" c:\mri\data.val'); +end; + +procedure ReadParamStr; +var + lStr: String; + I,lError: integer; + lCommandChar: Char; + lSingle: single; + lHelpShown: boolean; + lPrefs: TLDMPrefs; +begin + if (ParamCount < 1) then exit; + SetDefaultPrefs(lPrefs); + lHelpShown := false; + lStr := paramstr(0); + lStr := extractfilename(lStr); + lStr := string(StrUpper(PChar(lStr))) ; + if (ParamCount > 0) then begin + I := 0; + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') and (ParamCount > I) then begin //special command + //-z= zoom, -f= format [png,jpeg,bmp], -o= output directory + lCommandChar := UpCase(lStr[2]); + inc(I); + lStr := ParamStr(I); + lStr := string(StrUpper(PChar(lStr))) ; + case lCommandChar of + 'C','P','T': begin //CritPct + Val(lStr,lSingle,lError); + if lError = 0 then begin + if lCommandChar = 'C' then + lPrefs.CritPct := round(lSingle) + else if lCOmmandChar = 'P' then + lPrefs.nPermute := round(lSingle) + else if lCOmmandChar = 'T' then begin + case round(lSingle) of + 1: begin lPrefs.LTest := true; lPrefs.Ttest := false; lPrefs.BMtest := false; end; + 2: begin lPrefs.LTest := false; lPrefs.Ttest := true; lPrefs.BMtest := false; end; + 4: begin lPrefs.LTest := false; lPrefs.Ttest := false; lPrefs.BMtest := true; end; + 6: begin lPrefs.LTest := false; lPrefs.Ttest := true; lPrefs.BMtest := true; end; + //1=Liebermeister, 2=TTest, 4=BMtest, 6=t&BMtests + end;//xxx + end; + end; //not lError + end; //C= CritPct,P=permutations,T=test + 'O': begin //output filename + lPrefs.OutName :=lStr; + end; + + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + if fileexists(lStr) then begin + //lStr := GetLongFileName(lStr); + lPrefs.ValFilename := lStr; + //if lPrefs.OutName = '' then + // lPrefs.Outname := extractfiledir(paramstr(0))+pathdelim+'results.nii.gz'; + NPMMsg ('output ' + lPrefs.Outname); + NPMMsg ('val file: '+lPrefs.ValFilename); + + DoLesion(lPrefs); + //MainForm.close; + end else begin + NPMMsg('Error: unable to find '+lStr); + if not lHelpShown then + Showhelp; + lHelpShown := true; + end; + until I >= ParamCount; + end else begin + ShowHelp; + end;{param count > 0} +end; *) + +end. + \ No newline at end of file diff --git a/npm/prefs.ppu b/npm/prefs.ppu new file mode 100644 index 0000000..6d4047e Binary files /dev/null and b/npm/prefs.ppu differ diff --git a/npm/regression.o b/npm/regression.o new file mode 100644 index 0000000..1ba170e Binary files /dev/null and b/npm/regression.o differ diff --git a/npm/regression.pas b/npm/regression.pas new file mode 100755 index 0000000..b802ca9 --- /dev/null +++ b/npm/regression.pas @@ -0,0 +1,678 @@ +unit regression; +//only for Delphi - not Freepascal +//Unit for running multiple regression +interface +{$Include ..\common\isgui.inc} +uses +{$H+} +{$IFDEF GUI} Forms, {$ENDIF} +{$IFNDEF UNIX} Windows, {$ENDIF} +{$IFDEF FPC} utypes,regmult,{$ELSE} +utypes,regmult, +{$ENDIF}define_types,Classes,nifti_hdr,sysutils,nifti_img, + StatThdsUtil,Distr,Dialogsx, tfce_clustering, unpm, nifti_types; + +function GetValReg (var lVALFilename: string; var lnSubj,lnFactors: integer; var X : PMatrix; var lImageNames: TStrings; var lPredictorList: TStringList): boolean; +function ARegressNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var X: PMatrix; lnFactors: integer; var lPredictorList: TStringList; lOutname: string; lnPermute, TFCEconn: integer): boolean; +function Regress2NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lOutname: string; var lXadditional: PMatrix; lnAdditionalFactors, lnPermute: integer ): boolean; +function TtoR(t,df: double): double; + + +implementation +uses valformat,hdr,math; + + + +function Sign(value: double): double; +begin + if value > 0 then + result := 1 + else if value < 0 then + result := -1 + else + result := 0; +end; + +function TtoR(t,df: double): double; +CONST + eps=3.0e-7; +begin + result := 0; + if (t = 0) or (df = 0) then + exit; + result := sign(t)/ sqrt( (df/(t*t+eps)) +1 ); +end; + +{$DEFINE SaveT} //if SaveT then t-score map will be saved +{$DEFINE SaveRnotZ} //if SaveRnotZ then r-value map will be saved, but not Z-score map +function Regress2NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lOutname: string; var lXadditional: PMatrix; lnAdditionalFactors, lnPermute: integer ): boolean; +//lImages is list 1..N of 1st images followed by 1..N of corresponding control images +//example c1.img, c2.img,c3.img,e1.img,e2.img,e3.img +//lImages.Count must be even +label + 667; +const + kMaxFact = 80; +var + lOutNameMod,lFactName,lRunName: string; + lMaskImg,lPlankImg,lOutImgMn: SingleP; + lOutImgR: array [1..kMaxFact] of SingleP; + lTotalMemory: int64; + lnFactors,lnObservations,lnObservationsDiv2,lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lDF,lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct,lFact,lnStatFact: integer; + l1st, lSum, lMn: double; + lVar: boolean; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + + lRanOrderp: pointer; + lRanOrder: Doublep0; + lZP: Pointer; + lZra : DoubleP0; + X : PMatrix; +begin + lnFactors := 1+lnAdditionalFactors; + if odd(lImages.Count) then begin + ShowMsg('Regress2NPMAnalyze must be passed an even number of images: the first half of the list is the experimental images, followed by corresponding control images.'); + exit; + end; + lnObservations := lImages.Count; + lnObservationsDiv2 := lImages.Count div 2; + lDF := lnObservationsDiv2-lnFactors-1; + if lDF < 1 then begin + ShowMsg('Regress2NPMAnalyze: DF must be >0 (DF=[Num-Factors-1]) Num='+inttostr(lnObservationsDiv2)+' Factors='+inttostr(lnFactors) ); + exit; + end; + DimMatrix(X, lnFactors, lnObservationsDiv2); + //fx(lnAdditionalFactors); + + if lnAdditionalFactors > 0 then begin + for lPos2 := 1 to lnAdditionalFactors do begin + for lPos := 1 to lnObservationsDiv2 do begin + X^[lPos2+1]^[lPos] := lXadditional^[lPos2]^[lPos]; + //fx(lPos2+1,lPos, X^[lPos2+1]^[lPos]); + end; + end; //pos 2 + end; //additional factros + //Memo1.Lines.Add('Permutations = ' +IntToStr(lnPermute)); + NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lnStatFact := lnFactors + 1; //factors + overall model + if lnStatFact > (kMaxFact-1) then begin //-1 because factors + model + NPMmsg('ERROR: Can not analyze more than = ' +inttostr(kMaxFact-1)+' factors'); + goto 667; + end; + //load mask + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(gOffsetRA[0]),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMmsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + //next find start and end of mask + lPos := 0; + repeat + inc(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = lVolVox); + lMinMask := lPos; + lPos := lVolVox+1; + repeat + dec(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = 1); + lMaxMask := lPos; + if lMaxMask = 1 then begin + NPMmsg('Mask appears empty' +lMaskHdr.ImgFileName); + goto 667; + end; + NPMmsg('Mask has voxels from '+inttostr(lMinMask)+'..'+inttostr(lMaxMask)); + lVoxPerPlank := kPlankSz div lnObservations div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lnObservations; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lnObservations) ) + 1; + NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lnObservations))); + NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory*sizeof(single)) //assumes 4bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + lnVoxTested := 0; + for lPos := 1 to lnObservations do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lnObservations); + getmem(lOutImgMn,lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImgMn^[lPos] := 0; + for lFact := 1 to (lnStatFact) do begin //+1 as we include full model + getmem(lOutImgR[lFact],lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := 0; + + end; + createArray64(lZp,lZra,lnFactors+1); //+1 as we include full model + //InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxTW, lPermuteMinTW,lPermuteMaxWMW, lPermuteMinWMW, lRanOrderp, lRanOrder); + for lPlank := 1 to lnPlanks do begin + NPMmsg('Computing plank = ' +Inttostr(lPlank)); + Refresher; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lnObservations do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lPosPct := lVoxPerPlank div 100; + for lPos2 := 1 to lVoxPerPlank do begin + if (lPos2 mod lPosPct) = 0 then begin + NPMProgressBar( round((lPos2/lVoxPerPlank)*100) ); + end; + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(lnVoxTested); + lSum := 0; + //check for variance + lVar := false; + lPos := 1; + l1st := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + for lPos := 1 to lnObservations do + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + for lPos := 1 to lnObservationsDiv2 do begin + lSum := lSum + lObs^[lPos-1]; + if (not lVar) and (lObs^[lPos-1]<>l1st) then + lVar := true; + //lSumOfSqrs := lSumOfSqrs + sqr(lObs[lPos-1]); + X^[1]^[lPos] := lObs^[lnObservationsDiv2+lPos-1]; + end; + lOutImgMn^[lPos2Offset] := lSum/lnObservationsDiv2; + if lVar then begin + MultipleRegression (lnObservationsDiv2,lnFactors, X, lObs, lZra); + //if lPos2Offset = 359948 then rx(lnObservationsDiv2,lnFactors,X,lObs); + for lFact := 1 to lnStatFact do + lOutImgR[lFact]^[lPos2Offset] := lZra^[lFact-1]; + end; + //StatPermute (lttest,lwelch,lWMW,lImages.Count, lnGroup1,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxTW, lPermuteMinTW,lPermuteMaxWMW, lPermuteMinWMW, lObs,lRanOrder); + end; //in brain mask - compute + end; + lStartVox := lEndVox + 1; + end; + //next report findings + NPMMsg('Voxels tested = ' +Inttostr(lnVoxTested)); + reportBonferroni('Std',lnVoxTested); + //next: save data + if lnFactors = 1 then + lRunName := 'reg' + else + lRunName := ''; +//savedata + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save mean + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mn'+lRunName,'.hdr'); + if not FileExistsEX(lOutNameMod) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); +//save regression + for lFact := 1 to (lnStatFact) do begin + if (lFact > lnFactors) and (lnFactors = 1) then + lFactName := 'intercept'+'reg' //for analysis of multiple single regressions + else if (lFact > lnFactors) then + lFactName := 'intercept' + else + lFactName := 'reg'+inttostr(lFact); + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + {$IFDEF SaveT} //if SaveTRnotZ then t-score and r-score maps will be created, but no Z-score maps + //the next bit is optional - save data as T-values instead of Z-scores + // this allows direct comparison with SPM... + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_TTEST,inttostr(lnVoxTested) ); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'wlsT'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + {$ENDIF} + {$IFDEF SaveRnotZ} + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_CORREL,inttostr(lnVoxTested) ); + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := TtoR (lOutImgR[lFact]^[lPos],lDF); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'wlsR'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + {$ELSE} + //next - save Zscores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + //{ DoF = Nb points - Nb parameters } + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := TtoZ (lOutImgR[lFact]^[lPos],lDF); + MainForm.reportFDR ('wls'+lFactName, lVolVox, lnVoxTested, lOutImgR[lFact]); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'wls'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + {$ENDIF} + freemem(lOutImgR[lFact]); + end; + //next: close images + Freemem(lZp); + freemem(lOutImgMn); + freemem(lObsp); + freemem(lMaskImg); + freemem(lPlankImg); + NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lRunName,'.txt'); + NPMMsgSave(lOutNameMod); + NPMProgressBar(0); + DelMatrix(X, lnFactors, lnObservationsDiv2); + exit; +667: //you only get here if you aborted ... free memory and report error + DelMatrix(X, 1, lnObservationsDiv2); + if lVolVox > 1 then freemem(lMaskImg); + if lTotalMemory > 1 then freemem(lPlankImg); + NPMmsg('Unable to complete analysis.'); + NPMProgressBar(0); +end; + + + +{$DEFINE NoThread} +function InnerARegressNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var X: PMatrix; lnFactors: integer; var lPredictorList: TStringList; lOutname: string; lSaveData: boolean; var lMinZ,lMaxZ: double; var lMaxNegTFCEZ, lMaxTFCEZ:single; TFCEconn: integer): boolean; +//TFCEmode 0 = no TFCE, 1 = only report min/maxTFCE, 2 = save TFCE map to disk +{$IFNDEF Thread} +const + kMaxFact = 80; +{$ENDIF} +label + 667; +var + lOutNameMod,lFactName,lRunName: string; + lMaskImg,lPlankImg,lOutImgMn: SingleP; + {$IFDEF Thread} + lOutImgR: TRegRA; + {$ELSE} + lOutImgR: array [1..kMaxFact] of SingleP; + {$ENDIF} + lTotalMemory: int64; + lnObservations,lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + //lPos2,lPos2Offset, + lDF,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lFact,lnStatFact: integer; + //l1st, lSum, lMn: double; + //lVar: boolean; + //lObsp: pointer;lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + {$IFDEF Thread} + lThread,lThreadStart,lThreadEnd,lThreadInc: integer; + {$ELSE} + lObsP,lZP: Pointer; + lObs,lZra : DoubleP0; + lSum,l1st: double; + lVar: boolean; + lPos2,lPosPct,lPos2Offset: integer; + + {$ENDIF} +begin + + + lnObservations := lImages.Count; + lDF := lnObservations-lnFactors-1; + if lDF < 1 then begin + ShowMsg('Regress2NPMAnalyze: DF must be >0 (DF=[Num-Factors-1]) Num='+inttostr(lnObservations)+' Factors='+inttostr(lnFactors) ); + exit; + end; + if (lSaveData) then NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + + lnStatFact := lnFactors + 1; //factors + overall model + if lnStatFact > (kMaxFact-1) then begin //-1 because factors + model + NPMmsg('ERROR: Can not analyze more than = ' +inttostr(kMaxFact-1)+' factors'); + goto 667; + end; + //load mask + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(gOffsetRA[0]),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMmsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + //next find start and end of mask + lPos := 0; + repeat + inc(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = lVolVox); + lMinMask := lPos; + lPos := lVolVox+1; + repeat + dec(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = 1); + lMaxMask := lPos; + if lMaxMask = 1 then begin + NPMmsg('Mask appears empty' +lMaskHdr.ImgFileName); + goto 667; + end; + if (lSaveData) then NPMmsg('Mask has voxels from '+inttostr(lMinMask)+'..'+inttostr(lMaxMask)); + lVoxPerPlank := kPlankSz div lnObservations div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lnObservations; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lnObservations) ) + 1; + if (lSaveData) then NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lnObservations))); + if (lSaveData) then NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory* sizeof(single)) //assumes 4bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + //lnVoxTested := 0; + for lPos := 1 to lnObservations do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + //createArray64(lObsp,lObs,lnObservations); + getmem(lOutImgMn,lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImgMn^[lPos] := 0; + for lFact := 1 to (lnStatFact) do begin //+1 as we include full model + getmem(lOutImgR[lFact],lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := 0; + end; + //createArray64(lZp,lZra,lnFactors+1); //+1 as we include full model + {$IFDEF Thread} + + ClearThreadDataPvals(gnCPUThreads,0) ; + {$ELSE} + lnVoxTested := 0; + {$ENDIF} + for lPlank := 1 to lnPlanks do begin + if (lSaveData) then NPMmsg('Computing plank = ' +Inttostr(lPlank)); + Refresher; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lnObservations do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + {$IFDEF Thread} + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TLinThreadStat.Create (X,ProgressBar1, lnFactors,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lnObservations, lMaskImg,lPlankImg,lOutImgMn,lOutImgR) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + Msg('Thread ' +Inttostr(gThreadsRunning)+' = '+inttostr(lThreadStart)+'..'+inttostr(lThreadEnd)); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + {$ELSE} //not threaded + createArray64(lZp,lZra,lnFactors+1); //+1 as we include full model + createArray64(lObsp,lObs,lnObservations); + lPosPct := lVoxPerPlank div 100; + for lPos2 := 1 to lVoxPerPlank do begin + if (lPos2 mod lPosPct) = 0 then begin + NPMProgressBar(round((lPos2/lVoxPerPlank)*100)); + end; + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(lnVoxTested); + lSum := 0; + //check for variance + lVar := false; + lPos := 1; + l1st := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + for lPos := 1 to lnObservations do begin + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSum := lSum + lObs^[lPos-1]; + if (not lVar) and (lObs^[lPos-1]<>l1st) then + lVar := true; + end; + lOutImgMn^[lPos2Offset] := lSum/lnObservations; + if lVar then begin + MultipleRegression (lnObservations,lnFactors, X, lObs, lZra); + //if {lZra^[0] < -5.548} lPos2Offset = 762287 then + // ReportRegression (lPos2Offset,lnObservations,lnFactors, X, lObs, lZra ); + for lFact := 1 to lnStatFact do + lOutImgR[lFact]^[lPos2Offset] := lZra^[lFact-1]; + end; + end; //in brain mask - compute + end; //for each voxel + Freemem(lZp); + Freemem(lObsp); + {$ENDIF} //if threaded else not threaded + lStartVox := lEndVox + 1; + end; //for each plank + {$IFDEF Thread} + lnVoxTested := SumThreadDataLite(gnCPUThreads); + {$ENDIF} + //FACTOR 1 MinMax + lFact := 1; + lMinZ := lOutImgR[lFact]^[1]; + for lPos := 1 to lVolVox do + if (lOutImgR[lFact]^[lPos] < lMinZ) then lMinZ :=lOutImgR[lFact]^[lPos]; + lMinZ := TtoZ (lMinZ,lDF); + lMaxZ := lOutImgR[lFact]^[1]; + for lPos := 1 to lVolVox do + if (lOutImgR[lFact]^[lPos] > lMaxZ) then lMaxZ :=lOutImgR[lFact]^[lPos]; + lMaxZ := TtoZ (lMaxZ,lDF); + //NPMmsg('Factor1MinMax ' +floattostr(lMinZ)+' '+floattostr(lMaxZ)); + + if (lSaveData) then begin + //next report findings + NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + reportBonferroni('Std',lnVoxTested); + //next: save data + if lnFactors = 1 then + lRunName := lPredictorList[0] + else + lRunName := ''; + + //savedata + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + + + + //save mean + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mean'+lRunName,'.hdr'); + + if not FileExistsEX(lOutNameMod) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); + //save regression + + for lFact := 1 to (lnStatFact) do begin + if (lFact > lnFactors) and (lnFactors = 1) then begin + //nothing + end else begin + if (lFact > lnFactors) and (lnFactors = 1) then + lFactName := 'intercept'+lPredictorList[0] //for analysis of multiple single regressions + else if (lFact > lnFactors) then + lFactName := 'model' + else + lFactName := lPredictorList[lFact-1]; + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + //NEXT : optional save t-maps + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_TTEST,inttostr(lnVoxTested) ); + //lOutNameMod := ChangeFilePostfixExt(lOutName, 'wlsT'+lFactName,'.hdr'); + //NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + //END: t-maps + //next - Z scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + //{ DoF = Nb points - Nb parameters } + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := TtoZ (lOutImgR[lFact]^[lPos],lDF); + reportFDR ('wls'+lFactName, lVolVox, lnVoxTested, lOutImgR[lFact]); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'wls'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + if (lFact = 1) and (TFCEconn > 0) then begin //TFCE + //lMinZ := lOutImgR[lFact]^[1]; + + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + doTFCEbothPolarities (lStatHdr, lOutImgR[lFact], TFCEconn {NumConn}, 2.0{H}, 0.5 {E}, 0, lMaxZ/100, 0, lMinZ/100, lMaxTFCEZ, lMaxNegTFCEZ); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'tfce'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + end; //TFCE + + end;//if..else intercept and lnFactors = 1 + end;//for each statfactor + end; //if lSaveData + + + if (not (lSaveData)) and (TFCEconn > 0) and ((lMaxTFCEZ <> 0) or (lMaxNegTFCEZ <> 0)) then begin + //lMinZ := lOutImgR[lFact]^[1]; + lFact := 1; + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + doTFCEbothPolarities (lStatHdr, lOutImgR[lFact], TFCEconn {NumConn}, 2.0{H}, 0.5 {E}, 0, lMaxTFCEZ, 0, lMaxNegTFCEZ, lMaxTFCEZ, lMaxNegTFCEZ) + + end; //xxx + //next: close images + for lFact := 1 to (lnStatFact) do + freemem(lOutImgR[lFact]); + + //Freemem(lZp); + freemem(lOutImgMn); + //freemem(lObsp); + freemem(lMaskImg); + freemem(lPlankImg); + + //lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lRunName,'.txt'); + //MainForm.MsgSave(lOutNameMod); + NPMProgressBar(0); +exit; +667: //you only get here if you aborted ... free memory and report error + if lVolVox > 1 then freemem(lMaskImg); + if lTotalMemory > 1 then freemem(lPlankImg); + NPMmsg('Unable to complete analysis.'); + NPMProgressBar(0); +end; + +procedure PermuteMatrix(var Src, Dest: PMatrix; lnSubj: integer); //assumes only one column/factor!!! +var + lRow,lPos: integer; + lSwap: double; +begin + for lRow := 1 to lnSubj do + Dest^[1]^[lRow] := Src^[1]^[lRow]; + for lRow := lnSubj downto 1 do begin + lPos := random(lRow)+1; + lSwap := Dest^[1]^[lRow]; + Dest^[1]^[lRow] := Dest^[1]^[lPos]; + Dest^[1]^[lPos] := lSwap; + end; + +end; + +function ARegressNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var X: PMatrix; lnFactors: integer; var lPredictorList: TStringList; lOutname: string; lnPermute, TFCEconn: integer ): boolean; +label + 777; +var + //SaveData: boolean; var + lMaxTFCEZ, lMaxNegTFCEZ: single; + lMinZ,lMaxZ,lTFCEdh,lNegTFCEdh:double; + Xp : PMatrix; + lp,lnSubj,lRow : integer; + lPermuteMaxZ, lPermuteMinZ,lPermuteMaxTFCEZ, lPermuteMinTFCEZ: singleP; +begin + InnerARegressNPMAnalyze (lImages, lMaskHdr, X, lnFactors, lPredictorList, lOutname, TRUE,lMinZ,lMaxZ, lMaxNegTFCEZ, lMaxTFCEZ, TFCEconn ); + if lnFactors > 1 then goto 777; + if (lnPermute < 1) then goto 777; + //NPMmsg('0 ObservedzMinMax ' +floattostr(lMinZ)+' '+floattostr(lMaxZ)); + NPMmsg('OBSERVED Factor1 zMin zMax zMinTFCE zMaxTFCE ' +floattostr(lMinZ)+' '+floattostr(lMaxZ) +' ' +floattostr(lMaxNegTFCEZ)+' '+floattostr(lMaxTFCEZ)); + + lnSubj := lImages.Count; + DimMatrix(Xp, lnFactors, lnSubj); + randomize; + getmem(lPermuteMaxZ,lnPermute* sizeof(single)); + getmem(lPermuteMinZ,lnPermute* sizeof(single)); + getmem(lPermuteMaxTFCEZ,lnPermute* sizeof(single)); + getmem(lPermuteMinTFCEZ,lnPermute* sizeof(single)); + lTFCEdh := lMaxZ / 100; + lNegTFCEdh := abs(lMinZ) / 100; + for lp := 1 to lnPermute do begin + //for lRow := 1 to lnSubj do + // Xp^[1]^[lRow] := X^[1]^[lRow]; + lMaxNegTFCEZ := lNegTFCEdh; + lMaxTFCEZ := lTFCEdh; + PermuteMatrix(X,Xp,lnSubj); + InnerARegressNPMAnalyze (lImages, lMaskHdr, Xp, lnFactors, lPredictorList, lOutname, FALSE,lMinZ,lMaxZ,lMaxNegTFCEZ, lMaxTFCEZ, TFCEconn); + NPMmsg(inttostr(lp)+' Factor1 zMin zMax zMinTFCE zMaxTFCE ' +floattostr(lMinZ)+' '+floattostr(lMaxZ) +' ' +floattostr(lMaxNegTFCEZ)+' '+floattostr(lMaxTFCEZ)); + lPermuteMaxZ^[lp] := lMaxZ; + lPermuteMinZ^[lp] := lMinZ; + lPermuteMaxTFCEZ^[lp] := lMaxTFCEZ; + lPermuteMinTFCEZ^[lp] := lMaxNegTFCEZ; + end; + DelMatrix(Xp, lnFactors, lnSubj); + reportPermute ('Permutation', lnPermute, lPermuteMaxZ, lPermuteMinZ); + reportPermute ('TFCEPermutation', lnPermute, lPermuteMaxTFCEZ, lPermuteMinTFCEZ); + Freemem(lPermuteMaxZ); + Freemem(lPermuteMinZ); + Freemem(lPermuteMaxTFCEZ); + Freemem(lPermuteMinTFCEZ); + 777: + NPMmsg('Analysis finished = ' +TimeToStr(Now)); + NPMMsgSave( ChangeFilePostfixExt(lOutName,'Notes','.txt')); + +end; + +function GetValReg (var lVALFilename: string; var lnSubj,lnFactors: integer; var X : PMatrix; var lImageNames: TStrings; var lPredictorList: TStringList): boolean; +var + lTemplateName: string; + lnRow,lnColWObs,lnCritPct,lInc,lRow,lCol: integer; + lDesignUnspecified : boolean; + lFileList:TStringList; + lInRA: DoubleP0; + lInP: Pointer; +begin + result := false; + + lnSubj := 0; + if not FileExistsEX(lVALFilename) then begin + ShowMsg('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + + NPMmsg( 'VAL filename: '+lVALFilename); + + lFileList := TStringList.Create; + if not OpenValFile (lVALFilename,lTemplateName, lnRow,lnFactors,lnColWObs,lnCritPct, + lDesignUnspecified,lPredictorList,lFileList, lInP) then + exit; + if lnRow > 1 then begin + lnSubj := lnRow -1; //top row is predictor + {$IFDEF FPC} + lInRA := align(lInP,16); + {$ELSE} + lInRA := DoubleP0($fffffff0 and (integer(lInP)+15)); + //lInRA := DoubleP0((integer(lInP) and $FFFFFFF0)+16); + {$ENDIF} + DimMatrix(X, lnFactors, lnSubj); + for lCol := 1 to lnFactors do begin + for lRow := 1 to lnSubj do begin + //NPMmsg(inttostr( (lRow*lnColWObsAndCovary)-4+lCol )); + X^[lCol]^[lRow] := lInRA^[(lRow*lnColWObs)-lnColWObs-1+lCol]; + end; + end; + NPMmsg(inttostr(lnFactors)+' '+inttostr(lnSubj)); + for lInc := 1 to lnSubj do + lImageNames.add(ExtractFileDirWithPathDelim(lVALFilename)+lFileList.Strings[lInc-1]); + result := true; + end else + result := false; + lFileList.free; + Freemem(lInP); +end; + + +end. \ No newline at end of file diff --git a/npm/regression.ppu b/npm/regression.ppu new file mode 100644 index 0000000..3ad33b9 Binary files /dev/null and b/npm/regression.ppu differ diff --git a/npm/results.niiNotesseverity.txt b/npm/results.niiNotesseverity.txt new file mode 100755 index 0000000..879c1b3 --- /dev/null +++ b/npm/results.niiNotesseverity.txt @@ -0,0 +1,72 @@ +Threads: 2 +Factor = severity +c:\mri\anacom\n01.voi = 4.00 +c:\mri\anacom\n02.voi = 4.50 +c:\mri\anacom\n03.voi = 0.00 +c:\mri\anacom\n04.voi = 2.50 +c:\mri\anacom\n05.voi = 5.00 +c:\mri\anacom\n06.voi = 4.00 +c:\mri\anacom\n07.voi = 3.25 +c:\mri\anacom\n08.voi = 0.75 +c:\mri\anacom\n09.voi = 4.50 +c:\mri\anacom\n10.voi = 4.50 +c:\mri\anacom\n11.voi = 0.50 +c:\mri\anacom\n12.voi = 1.63 +c:\mri\anacom\n13.voi = 0.00 +c:\mri\anacom\n14.voi = 3.50 +c:\mri\anacom\n15.voi = 3.00 +c:\mri\anacom\n17.voi = 4.00 +c:\mri\anacom\n18.voi = 2.00 +c:\mri\anacom\n19.voi = 4.50 +c:\mri\anacom\n20.voi = 5.00 +c:\mri\anacom\n21.voi = 0.00 +c:\mri\anacom\n22.voi = 1.50 +c:\mri\anacom\n23.voi = 5.00 +c:\mri\anacom\n24.voi = 2.50 +c:\mri\anacom\n25.voi = 5.00 +c:\mri\anacom\n26.voi = 4.00 +c:\mri\anacom\n27.voi = 0.00 +c:\mri\anacom\n28.voi = 0.00 +c:\mri\anacom\n29.voi = 2.00 +c:\mri\anacom\n30.voi = 1.50 +c:\mri\anacom\n31.voi = 1.75 +c:\mri\anacom\n32.voi = 0.00 +c:\mri\anacom\n33.voi = 2.50 +c:\mri\anacom\n34.voi = 5.00 +c:\mri\anacom\n35.voi = 0.00 +c:\mri\anacom\n37.voi = 0.00 +c:\mri\anacom\n38.voi = 3.25 +c:\mri\anacom\n39.voi = 4.38 +c:\mri\anacom\n40.voi = 0.00 +c:\mri\anacom\n41.voi = 3.75 +c:\mri\anacom\n42.voi = 0.25 +c:\mri\anacom\n43.voi = 0.00 +c:\mri\anacom\n44.voi = 2.00 +c:\mri\anacom\n45.voi = 5.00 +c:\mri\anacom\n46.voi = 0.00 +c:\mri\anacom\n47.voi = 0.50 +c:\mri\anacom\n48.voi = 0.00 +c:\mri\anacom\n49.voi = 2.25 +c:\mri\anacom\n50.voi = 0.00 +c:\mri\anacom\n51.voi = 2.25 +c:\mri\anacom\n52.voi = 2.00 +c:\mri\anacom\n53.voi = 0.00 +c:\mri\anacom\n54.voi = 0.25 +c:\mri\anacom\n55.voi = 0.00 +Total voxels = 7109137 +Only testing voxels damaged in at least 5 individual[s] +Number of Lesion maps = 53 +Permutations = 0 +Analysis began = 2008-Mar-24 14:41:02 +Memory planks = 0.701815434883711 +Max voxels per Plank = 10129639 +Computing plank = 1 +Voxels tested = 40826 +Only tested voxels with more than 5 lesions +40826 test Std Bonferroni FWE Z 0.050=4.712, 0.025=4.852, 0.01=5.030 +n=,53,minN=,5,unique overlap patterns,9785,voxels tested,20016 +9785 test Unique overlap Bonferroni FWE Z 0.050=4.412, 0.025=4.560, 0.01=4.749 +ttest Range -3.936...5.118 +ttest +FDR Z 0.050=2.085, 0.01=3.152 +ttest -FDR Z 0.050=-3.440, 0.01=9.200 +Analysis finished = 2008-Mar-24 14:41:50 diff --git a/npm/roc.o b/npm/roc.o new file mode 100644 index 0000000..0d97550 Binary files /dev/null and b/npm/roc.o differ diff --git a/npm/roc.pas b/npm/roc.pas new file mode 100755 index 0000000..05de27f --- /dev/null +++ b/npm/roc.pas @@ -0,0 +1,355 @@ +unit roc; +interface +//demonstrates the ROC tests that are in the Brunner.pas file +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,//Brunner,nifti_img, DISTR + Messages, Classes, Graphics, Controls, Forms, Dialogsx, +StdCtrls, ComCtrls,ExtCtrls,Menus, //overlap,ReadInt,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,IniFiles,cpucount,userdir,math, +regmult,utypes; +procedure testROC; +procedure testROC2; +function AUCbinomcont (lBinomdataRA,lContdataRA: singlep; lnSubj :integer): double; +function AUCcontcont (ldatara1,ldatara2: singlep; lnSubj :integer): double; +implementation + +uses npmform; + +function readCSV2 (lFilename: string; lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lError := false; + result := false; + if not fileexists(lFilename) then begin + ShowMsg('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) or (MaxC < (kHdrCol+lCol2)) then begin + ShowMsg('problems reading CSV - not enough columns/rows '+inttostr(lCol1)+' '+inttostr(lCol2)); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := MaxC-1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + getmem(ldataRA2,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) or ((C-kHdrCol) = lCol2) then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + ShowMsg('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then + ldataRA1^[R-kHdrRow] := lTempFloat + else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat; + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + ShowMsg('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + ldataRA2^[R-1] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; + +function AUCcontcont (ldatara1,ldatara2: singlep; lnSubj :integer): double; +var + lIn,lInDX : DoubleP0; + lnGroup0,lnGroup1,lI: integer; +begin + result := 0.5; + if lnSubj < 1 then + exit; + Getmem(lIn,lnSubj*sizeof(double)); + Getmem(lInDX,lnSubj*sizeof(double)); + for lI := 1 to lnSubj do begin + lIn^[lI-1] := ldatara2^[lI]; + lInDX^[lI-1] := ldatara1^[lI]; + end; + result := continROC2 (lnSubj, lIn, lInDX); + freemem(lIn); + freemem(lInDX); +end; + +function AUCbinomcont (lBinomdataRA,lContdataRA: singlep; lnSubj :integer): double; +var + lIn : DoubleP0; + lnGroup0,lnGroup1,lI: integer; +begin + result := 0.5; + if lnSubj < 1 then + exit; + Getmem(lIn,lnSubj*sizeof(double)); + lnGroup0 := 0; + lnGroup1 := 0; + for lI := 1 to lnSubj do begin + if lBinomdataRA^[lI] = 0 then begin + lIn^[lnGroup0] := lContdataRA^[lI]; + inc (lnGroup0); + end else begin + inc (lnGroup1); + lIn^[lnSubj-lnGroup1] := lContdataRA^[lI]; + + end; + end; + result := continROC (lnSubj, lnGroup0, lIn); + freemem(lIn); +end; + +procedure testROC; +var + lROC : single; + lI,lnSubj,lnGroup0: integer; + //lIn : DoubleP0; + //csv + lnGroup1,lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep ; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('ROC analysis requires CSV format text file.'); + npmform.MainForm.memo1.lines.add('First column is the filename (ignored).'); + npmform.MainForm.memo1.lines.add('Second column is 0 [deficit present] or 1 [no deficit].'); + npmform.MainForm.memo1.lines.add('Third column is number of voxels injured in ROI [0 or greater]:'); + npmform.MainForm.memo1.lines.add('Example file:'); + //npmform.MainForm.memo1.lines.add('deficit, voxels'); + npmform.MainForm.memo1.lines.add('c:\c01.voi,0, 121'); + npmform.MainForm.memo1.lines.add('c:\c02.voi,1, 33'); + npmform.MainForm.memo1.lines.add('c:\c03.voi,0, 222'); + npmform.MainForm.memo1.lines.add('c:\c04.voi,1, 56'); + npmform.MainForm.memo1.lines.add('c:\c05.voi,1, 96'); + npmform.MainForm.memo1.lines.add('c:\c06.voi,0, 100'); + //get csv + npmform.MainForm.memo1.lines.add(' ...requesting CSV file'); + + if not MainForm.OpenDialogExecute('Select comma separated filenames ',false,false,kTxtFilter) then + exit; + npmform.MainForm.memo1.lines.add(' ...reading CSV file'); + if not readCSV2 (MainForm.OpenHdrDlg.Filename, 2,3, lnObservations, ldataRA1,ldataRA2) then + exit; + npmform.MainForm.memo1.lines.add(' ...observations: '+inttostr(lnObservations)); + if lnObservations < 3 then begin + ShowMsg('At least 3 subjects required.'); + exit; + end; + lnSubj := lnObservations; + lnGroup0 := 0; + for lI := 1 to lnSubj do + if ldatara1^[lI] = 0 then + inc (lnGroup0); + npmform.MainForm.memo1.lines.add(' ...observations with deficit [0]: '+inttostr(lnGroup0)); + if (lnGroup0 = lnSubj) or (lnGroup0 = 0) then begin + ShowMsg('Some values in the first column must be zero, some must be non-zero.'); + exit; + end; + lROC := AUCbinomcont (ldatara1,ldatara2, lnSubj); + (*Getmem(lIn,lnSubj*sizeof(double)); + lnGroup0 := 0; + lnGroup1 := 0; + for lI := 1 to lnSubj do begin + if ldatara1[lI] = 0 then begin + lIn[lnGroup0] := ldatara2[lI]; + inc (lnGroup0); + end else begin + inc (lnGroup1); + lIn[lnSubj-lnGroup1] := ldatara2[lI]; + + end; + end; + lROC := continROC (lnSubj, lnGroup0, lIn); + freemem(lIn); + *) + + freemem(ldataRA1); + freemem(ldataRA2); + //now analyze + npmform.MainForm.memo1.lines.add('ROC = '+floattostr(lROC)); + //fx(lROC); +end; + + +procedure testROC2; +var + //lDouble: double; + lVariable: boolean; + lF,lROC : single; + lI,lnSubj: integer; + lIn,lInDX : DoubleP0; + //csv + lnGroup1,lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep ; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('ROC analysis requires CSV format text file.'); + npmform.MainForm.memo1.lines.add('First column is the filename (ignored).'); + npmform.MainForm.memo1.lines.add('Second column is degree of deficit [lower value = more impaired].'); + npmform.MainForm.memo1.lines.add('Third column is number of voxels injured in ROI [0 or greater]:'); + npmform.MainForm.memo1.lines.add('Example file:'); + //npmform.MainForm.memo1.lines.add('deficit, voxels'); + npmform.MainForm.memo1.lines.add('c:\c01.voi,0.3, 121'); + npmform.MainForm.memo1.lines.add('c:\c02.voi,0.1, 33'); + npmform.MainForm.memo1.lines.add('c:\c03.voi,0.2, 222'); + npmform.MainForm.memo1.lines.add('c:\c04.voi,1.3, 56'); + npmform.MainForm.memo1.lines.add('c:\c05.voi,1.7, 96'); + npmform.MainForm.memo1.lines.add('c:\c06.voi,1.5, 100'); + //get csv + npmform.MainForm.memo1.lines.add(' ...requesting CSV file'); + + if not MainForm.OpenDialogExecute('Select comma separated filenames ',false,false,kTxtFilter) then + exit; + npmform.MainForm.memo1.lines.add(' ...reading CSV file'); + if not readCSV2 (MainForm.OpenHdrDlg.Filename, 2,3, lnObservations, ldataRA1,ldataRA2) then + exit; + npmform.MainForm.memo1.lines.add(' ...observations: '+inttostr(lnObservations)); + if lnObservations < 3 then begin + ShowMsg('At least 3 subjects required.'); + exit; + end; + lnSubj := lnObservations; + lF := ldatara1^[1]; + lVariable := false; + for lI := 1 to lnSubj do + if ldatara1^[lI] <> lF then + lVariable := true; + if (not lVariable) then begin + ShowMsg('The columns must have some variability.'); + exit; + end; + Getmem(lIn,lnSubj*sizeof(double)); + Getmem(lInDX,lnSubj*sizeof(double)); + for lI := 1 to lnSubj do begin + lIn^[lI-1] := ldatara2^[lI]; + lInDX^[lI-1] := ldatara1^[lI]; + end; + freemem(ldataRA1); + freemem(ldataRA2); + //now analyze + (*lnSubj := 10; + lnGroup0 := 5; + Getmem(lIn,lnSubj*sizeof(double)); + for lI := 0 to (lnSubj-1) do + lIn[lI] := -lI;//random(99); *) + lROC := continROC2 (lnSubj, lIn, lInDX); + npmform.MainForm.memo1.lines.add('ROC = '+floattostr(lROC)); + freemem(lIn); + freemem(lInDX); + +end; + +(*procedure testROC; +var + lROC : single; + lI,lnSubj,lnGroup0: integer; + lIn : DoubleP0; +begin + lnSubj := 10; + lnGroup0 := 5; + Getmem(lIn,lnSubj*sizeof(double)); + for lI := 0 to (lnSubj-1) do + lIn[lI] := -lI;//random(99); + lROC := continROC (lnSubj, lnGroup0, lIn); + npmform.MainForm.memo1.lines.add('ROC = '+floattostr(lROC)); + //fx(lROC); + freemem(lIn); + +end; *) + + +end. \ No newline at end of file diff --git a/npm/roc.ppu b/npm/roc.ppu new file mode 100644 index 0000000..1ec1af6 Binary files /dev/null and b/npm/roc.ppu differ diff --git a/npm/spread.dfm b/npm/spread.dfm new file mode 100755 index 0000000..f7aaee9 Binary files /dev/null and b/npm/spread.dfm differ diff --git a/npm/spread.lfm b/npm/spread.lfm new file mode 100755 index 0000000..c55233f --- /dev/null +++ b/npm/spread.lfm @@ -0,0 +1,195 @@ +object SpreadForm: TSpreadForm + Left = 401 + Height = 538 + Top = 183 + Width = 326 + ActiveControl = DataGrid + Caption = 'Voxelwise Analysis of Lesions' + ClientHeight = 538 + ClientWidth = 326 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnResize = FormResize + Position = poScreenCenter + LCLVersion = '1.2.4.0' + object DataGrid: TStringGrid + Left = 0 + Height = 498 + Top = 25 + Width = 326 + Align = alClient + FixedRows = 2 + Options = [goFixedVertLine, goVertLine, goHorzLine, goRangeSelect, goDrawFocusSelected, goTabs, goThumbTracking] + RowCount = 12 + TabOrder = 0 + OnDrawCell = DataGridDrawCell + OnKeyPress = DataGridKeyPress + OnMouseDown = DataGridMouseDown + OnMouseMove = DataGridMouseMove + OnSelectCell = DataGridSelectCell + end + object ToolBar1: TToolBar + Left = 0 + Height = 25 + Top = 0 + Width = 326 + EdgeBorders = [] + TabOrder = 1 + object DesignBtn: TSpeedButton + Left = 1 + Height = 22 + Hint = 'ANOVA' + Top = 0 + Width = 120 + Caption = 'Design' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00337333733373 + 3373337F3F7F3F7F3F7F33737373737373733F7F7F7F7F7F7F7F770000000000 + 00007777777777777777330333333C333333337FFF3337F3333F370993333C33 + 3399377773F337F33377330339333C3339333F7FF7FFF7FFF7FF770777977C77 + 97777777777777777777330333933C339333337F3373F7F37333370333393C39 + 3333377F333737F7333333033333999333333F7FFFFF777FFFFF770777777C77 + 77777777777777777777330333333C330333337F333337FF7FF3370333333C00 + 003C377F333337777737330333333C3303333F7FFFFFF7FF7FFF770777777777 + 7777777777777777777733333333333333333333333333333333 + } + NumGlyphs = 2 + OnClick = DesignBtnClick + ShowHint = True + ParentShowHint = False + end + end + object StatusBar1: TStatusBar + Left = 0 + Height = 15 + Top = 523 + Width = 326 + Panels = < + item + Width = 140 + end + item + Width = 50 + end> + SimplePanel = False + end + object MainMenu1: TMainMenu + left = 108 + top = 44 + object File1: TMenuItem + Caption = '&File' + object New1: TMenuItem + Caption = 'New...' + ShortCut = 16462 + OnClick = NewBtnClick + end + object Open1: TMenuItem + Caption = 'Open...' + ShortCut = 16463 + OnClick = OpenBtnClick + end + object Save1: TMenuItem + Caption = 'Save' + ShortCut = 16467 + OnClick = SaveBtnClick + end + object Quit1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Quit1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + ShortCut = 16451 + OnClick = Copy1Click + end + object Paste1: TMenuItem + Caption = 'Paste' + ShortCut = 16470 + OnClick = Paste1Click + end + object Selectall1: TMenuItem + Caption = 'Select all cells' + ShortCut = 16449 + OnClick = Selectall1Click + end + object Clearallcells1: TMenuItem + Caption = 'Clear all cells...' + OnClick = Clearallcells1Click + end + object DescriptiveMenu: TMenuItem + Caption = 'Descriptives' + OnClick = DescriptiveClick + end + end + object View: TMenuItem + Caption = 'View' + object Font1: TMenuItem + Caption = 'Font' + object N81: TMenuItem + Tag = 8 + Caption = '8' + Checked = True + GroupIndex = 111 + RadioItem = True + OnClick = FontSizeChange + end + object N101: TMenuItem + Tag = 10 + Caption = '10' + GroupIndex = 111 + RadioItem = True + OnClick = FontSizeChange + end + object N121: TMenuItem + Tag = 12 + Caption = '12' + GroupIndex = 111 + RadioItem = True + OnClick = FontSizeChange + end + object N141: TMenuItem + Tag = 14 + Caption = '14' + GroupIndex = 111 + RadioItem = True + OnClick = FontSizeChange + end + end + object Design1: TMenuItem + Caption = 'Design' + ShortCut = 16452 + OnClick = DesignBtnClick + end + end + object Help1: TMenuItem + Caption = '&Help' + object Aboutthissoftware1: TMenuItem + Caption = '&About this software' + OnClick = Aboutthissoftware1Click + end + end + end + object OpenDialog1: TOpenDialog + DefaultExt = '.val' + Filter = 'Native [val]|.val|Tab delimited text [txt]|.txt|All files|.*' + FilterIndex = 0 + left = 36 + top = 44 + end + object SaveDialog1: TSaveDialog + DefaultExt = '.val' + Filter = 'Native format [val]|*.val|Tab delimited text [txt]|*.txt' + FilterIndex = 0 + Options = [ofOverwritePrompt, ofHideReadOnly] + left = 74 + top = 44 + end +end diff --git a/npm/spread.lrs b/npm/spread.lrs new file mode 100755 index 0000000..c592a3f --- /dev/null +++ b/npm/spread.lrs @@ -0,0 +1,63 @@ +LazarusResources.Add('TSpreadForm','FORMDATA',[ + 'TPF0'#11'TSpreadForm'#10'SpreadForm'#4'Left'#3#145#1#6'Height'#3#26#2#3'Top' + +#3#183#0#5'Width'#3'F'#1#13'ActiveControl'#7#8'DataGrid'#7'Caption'#6#29'Vox' + +'elwise Analysis of Lesions'#12'ClientHeight'#3#26#2#11'ClientWidth'#3'F'#1#4 + +'Menu'#7#9'MainMenu1'#7'OnClose'#7#9'FormClose'#8'OnCreate'#7#10'FormCreate' + +#8'OnResize'#7#10'FormResize'#8'Position'#7#14'poScreenCenter'#10'LCLVersion' + +#6#7'1.2.4.0'#0#11'TStringGrid'#8'DataGrid'#4'Left'#2#0#6'Height'#3#242#1#3 + +'Top'#2#25#5'Width'#3'F'#1#5'Align'#7#8'alClient'#9'FixedRows'#2#2#7'Options' + +#11#15'goFixedVertLine'#10'goVertLine'#10'goHorzLine'#13'goRangeSelect'#19'g' + +'oDrawFocusSelected'#6'goTabs'#15'goThumbTracking'#0#8'RowCount'#2#12#8'TabO' + +'rder'#2#0#10'OnDrawCell'#7#16'DataGridDrawCell'#10'OnKeyPress'#7#16'DataGri' + +'dKeyPress'#11'OnMouseDown'#7#17'DataGridMouseDown'#11'OnMouseMove'#7#17'Dat' + +'aGridMouseMove'#12'OnSelectCell'#7#18'DataGridSelectCell'#0#0#8'TToolBar'#8 + +'ToolBar1'#4'Left'#2#0#6'Height'#2#25#3'Top'#2#0#5'Width'#3'F'#1#11'EdgeBord' + +'ers'#11#0#8'TabOrder'#2#1#0#12'TSpeedButton'#9'DesignBtn'#4'Left'#2#1#6'Hei' + +'ght'#2#22#4'Hint'#6#5'ANOVA'#3'Top'#2#0#5'Width'#2'x'#7'Caption'#6#6'Design' + +#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' ' + +#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0 + +#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#127 + +#127#127#0#191#191#191#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255 + +#0#255#255#0#0#255#255#255#0'3s3s3s3s3'#127'?'#127'?'#127'?'#127'3sssssss?' + +#127#127#127#127#127#127#127'w'#0#0#0#0#0#0#0'wwwwwwww3'#3'33<3333'#127#255 + +'37'#243'3?7'#9#147'3<33'#153'7ws'#243'7'#243'3w3'#3'93<393?'#127#247#255#247 + +#255#247#255'w'#7'w'#151'|w'#151'wwwwwwwww3'#3'3'#147'<3'#147'33'#127'3s'#247 + +#243's37'#3'39<9337'#127'377'#247'333'#3'33'#153#147'33?'#127#255#255'w'#127 + +#255#255'w'#7'ww|wwwwwwwwwww3'#3'33<3'#3'33'#127'337'#255#127#243'7'#3'33<'#0 + +#0'<7'#127'337ww73'#3'33<3'#3'3?'#127#255#255#247#255#127#255'w'#7'wwwwwwwww' + +'wwwww3333333333333333'#9'NumGlyphs'#2#2#7'OnClick'#7#14'DesignBtnClick'#8'S' + +'howHint'#9#14'ParentShowHint'#8#0#0#0#10'TStatusBar'#10'StatusBar1'#4'Left' + +#2#0#6'Height'#2#15#3'Top'#3#11#2#5'Width'#3'F'#1#6'Panels'#14#1#5'Width'#3 + +#140#0#0#1#5'Width'#2'2'#0#0#11'SimplePanel'#8#0#0#9'TMainMenu'#9'MainMenu1' + +#4'left'#2'l'#3'top'#2','#0#9'TMenuItem'#5'File1'#7'Caption'#6#5'&File'#0#9 + +'TMenuItem'#4'New1'#7'Caption'#6#6'New...'#8'ShortCut'#3'N@'#7'OnClick'#7#11 + +'NewBtnClick'#0#0#9'TMenuItem'#5'Open1'#7'Caption'#6#7'Open...'#8'ShortCut'#3 + +'O@'#7'OnClick'#7#12'OpenBtnClick'#0#0#9'TMenuItem'#5'Save1'#7'Caption'#6#4 + +'Save'#8'ShortCut'#3'S@'#7'OnClick'#7#12'SaveBtnClick'#0#0#9'TMenuItem'#5'Qu' + +'it1'#7'Caption'#6#12'Close window'#8'ShortCut'#3'W@'#7'OnClick'#7#10'Quit1C' + +'lick'#0#0#0#9'TMenuItem'#5'Edit1'#7'Caption'#6#4'Edit'#0#9'TMenuItem'#5'Cop' + +'y1'#7'Caption'#6#4'Copy'#8'ShortCut'#3'C@'#7'OnClick'#7#10'Copy1Click'#0#0#9 + +'TMenuItem'#6'Paste1'#7'Caption'#6#5'Paste'#8'ShortCut'#3'V@'#7'OnClick'#7#11 + +'Paste1Click'#0#0#9'TMenuItem'#10'Selectall1'#7'Caption'#6#16'Select all cel' + +'ls'#8'ShortCut'#3'A@'#7'OnClick'#7#15'Selectall1Click'#0#0#9'TMenuItem'#14 + +'Clearallcells1'#7'Caption'#6#18'Clear all cells...'#7'OnClick'#7#19'Clearal' + +'lcells1Click'#0#0#9'TMenuItem'#15'DescriptiveMenu'#7'Caption'#6#12'Descript' + +'ives'#7'OnClick'#7#16'DescriptiveClick'#0#0#0#9'TMenuItem'#4'View'#7'Captio' + +'n'#6#4'View'#0#9'TMenuItem'#5'Font1'#7'Caption'#6#4'Font'#0#9'TMenuItem'#3 + +'N81'#3'Tag'#2#8#7'Caption'#6#1'8'#7'Checked'#9#10'GroupIndex'#2'o'#9'RadioI' + +'tem'#9#7'OnClick'#7#14'FontSizeChange'#0#0#9'TMenuItem'#4'N101'#3'Tag'#2#10 + +#7'Caption'#6#2'10'#10'GroupIndex'#2'o'#9'RadioItem'#9#7'OnClick'#7#14'FontS' + +'izeChange'#0#0#9'TMenuItem'#4'N121'#3'Tag'#2#12#7'Caption'#6#2'12'#10'Group' + +'Index'#2'o'#9'RadioItem'#9#7'OnClick'#7#14'FontSizeChange'#0#0#9'TMenuItem' + +#4'N141'#3'Tag'#2#14#7'Caption'#6#2'14'#10'GroupIndex'#2'o'#9'RadioItem'#9#7 + +'OnClick'#7#14'FontSizeChange'#0#0#0#9'TMenuItem'#7'Design1'#7'Caption'#6#6 + +'Design'#8'ShortCut'#3'D@'#7'OnClick'#7#14'DesignBtnClick'#0#0#0#9'TMenuItem' + +#5'Help1'#7'Caption'#6#5'&Help'#0#9'TMenuItem'#18'Aboutthissoftware1'#7'Capt' + +'ion'#6#20'&About this software'#7'OnClick'#7#23'Aboutthissoftware1Click'#0#0 + +#0#0#11'TOpenDialog'#11'OpenDialog1'#10'DefaultExt'#6#4'.val'#6'Filter'#6'<N' + +'ative [val]|.val|Tab delimited text [txt]|.txt|All files|.*'#11'FilterIndex' + +#2#0#4'left'#2'$'#3'top'#2','#0#0#11'TSaveDialog'#11'SaveDialog1'#10'Default' + +'Ext'#6#4'.val'#6'Filter'#6'8Native format [val]|*.val|Tab delimited text [t' + +'xt]|*.txt'#11'FilterIndex'#2#0#7'Options'#11#17'ofOverwritePrompt'#14'ofHid' + +'eReadOnly'#0#4'left'#2'J'#3'top'#2','#0#0#0 +]); diff --git a/npm/spread.o b/npm/spread.o new file mode 100644 index 0000000..e9bf25a Binary files /dev/null and b/npm/spread.o differ diff --git a/npm/spread.pas b/npm/spread.pas new file mode 100755 index 0000000..05bc43b --- /dev/null +++ b/npm/spread.pas @@ -0,0 +1,1036 @@ +unit spread; +interface +{$H+} +uses +{$IFNDEF FPC} +//Utils, +Toolwin,shlobj,Spin,ShellApi,windows,messages, +{$ELSE} +LResources, +{$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Grids, Menus, ComCtrls, Buttons,Clipbrd,design, StdCtrls, + define_types,valformat;//Registry, + +type + + { TSpreadForm } + + TSpreadForm = class(TForm) + DataGrid: TStringGrid; + MainMenu1: TMainMenu; + File1: TMenuItem; + //DescriptiveMenu: TMenuItem; + New1: TMenuItem; + Open1: TMenuItem; + Design1:TMenuItem; + Quit1: TMenuItem; + ToolBar1: TToolBar; + Help1: TMenuItem; + Aboutthissoftware1: TMenuItem; + StatusBar1: TStatusBar; + Save1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Paste1: TMenuItem; + OpenDialog1: TOpenDialog; + SaveDialog1: TSaveDialog; + Selectall1: TMenuItem; + View: TMenuItem; + Font1: TMenuItem; + N81: TMenuItem; + N101: TMenuItem; + N121: TMenuItem; + N141: TMenuItem; + DesignBtn: TSpeedButton; + Clearallcells1: TMenuItem; + DescriptiveMenu: TMenuItem; + procedure UpdateLabels; + function GetVal (lC,lR: integer; var lVal: double): boolean; + procedure Quit1Click(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure Aboutthissoftware1Click(Sender: TObject); + procedure OpenBtnClick(Sender: TObject); + procedure DataGridSelectCell(Sender: TObject; ACol, ARow: Integer; + var CanSelect: Boolean); + procedure NewBtnClick(Sender: TObject); + procedure Save1Click(var NoCancel: boolean); + procedure FormCreate(Sender: TObject); + procedure DataGridMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure OpenTextFile (var lFilename:string); + function CheckSave2Close (lAllowCancel: boolean): boolean; + procedure DataGridKeyPress(Sender: TObject; var Key: Char); + procedure Copy1Click(Sender: TObject); + procedure Paste1Click(Sender: TObject); + procedure SaveBtnClick(Sender: TObject); + procedure ShowStatus; + procedure ReadCells2Buffer; + procedure Selectall1Click(Sender: TObject); + procedure FontSizeChange(Sender: TObject); + procedure DataGridMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure DataGridDrawCell(Sender: TObject; Col, Row: Integer; + Rect: TRect; State: TGridDrawState); + procedure Clearallcells1Click(Sender: TObject); + procedure DesignBtnClick(Sender: TObject); + procedure AddMRIScansClick(Sender: TObject); + procedure DescriptiveClick(Sender: TObject); + function SOpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean; +{$IFNDEF FPC} + procedure FormClose(Sender: TObject; var Action: TCloseAction); +{$ELSE} + procedure FormClose(Sender: TObject); + //procedure SpeedButton3Click(Sender: TObject); +{$ENDIF} + + private + //procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES; + { Private declarations } + public + { Public declarations } + end; + +var + SpreadForm: TSpreadForm; +const + kRegressSWName = 'VAL'; + kRegressSWVers = kRegressSWName+' v1.0'; + kMaxFactors = 1; + gVALChanges: boolean = false; + gDesignUnspecified : boolean = true; + gEnterCell : boolean= false; + gVALFontSize: integer = 8; + kMagicDouble : double = -111666222; + //kVALNativeSignature = 'abba'; + //kTxtExt = '.txt'; + //kVALNativeExt = '.val'; +implementation +uses statcr,hdr; + +{$IFNDEF FPC} + +{$R *.DFM} +{$ENDIF} +function TSpreadForm.SOpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; +var + lNumberofFiles: integer; +begin + OpenDialog1.Filter := lFilter;//kAnaHdrFilter;//lFilter; + OpenDialog1.FilterIndex := 1; + OpenDialog1.Title := lCaption; + if lAllowMultiSelect then + OpenDialog1.Options := [ofAllowMultiSelect,ofFileMustExist] + else + OpenDialog1.Options := [ofFileMustExist]; + result := OpenDialog1.Execute; + if not result then exit; + if lForceMultiSelect then begin + lNumberofFiles:= OpenDialog1.Files.Count; + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + result := false; + end; + end; +end; +(*procedure TSpreadForm.WMDropFiles(var Msg: TWMDropFiles); +var + lStr: string; + CFileName: array[0..MAX_PATH] of Char; +begin + try + if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then //requires ShellAPI in 'uses' clause + begin + if gChanges then begin + if not CheckSave2Close(true) then exit; + end; + lStr := CFilename; + OpenTextFile(lStr); + OpenDialog1.FileName := lStr; + Msg.Result := 0; + end; + finally + DragFinish(Msg.Drop); + end; +end; *) + +procedure TSpreadForm.Quit1Click(Sender: TObject); +begin + if not CheckSave2Close(true) then exit; + gVALChanges := false; + SpreadForm.Close; +end; + + + +procedure TSpreadForm.FormResize(Sender: TObject); +var lClient,lWid,lCount: integer; +begin + lCount := DataGrid.ColCount; + lClient := DataGrid.ClientWidth; + if lCount < 1 then begin + DataGrid.ColWidths[0] := lClient; + exit; + end; + lWid := ((lClient) div lCount); + DataGrid.DefaultColWidth := lWid-1; + (*if lWid <> lCol1Wid then begin + lCol1Wid := (lClient-((lCount) * lWid))-lCount{-14}; + lGrid.ColWidths[0] := lCol1Wid; + end;*) +end; + +function ColLabel (lCol: integer): string; //first column= A, 26th=Z,27th AA, etc... +var lColDiv,lColMod: integer; +begin + result := ''; + lColDiv := lCol; + repeat + lColMod := lColDiv mod 26; + if lColMod = 0 then lColMod := 26; + result := chr(ord('A')+lColMod-1)+result; + {if lColDiv = 26 then + lColDiv := 0 + else} + lColDiv := (lColDiv-1) div 26; + until lColDiv <= 0; +end; + +procedure UpdateGridLabels(lGrid: TStringGrid); +var + lA,lInc,lInc2: integer; +begin + if lGrid.RowCount < 2 then exit; + //for lInc := (lGrid.RowCount -1) downto 1 do + // lGrid.Cells[0,kMaxFactors+lInc] := inttostr(lInc); + if (lGrid.ColCount) < 1 then exit; + + //Next enter ANOVA labels for each row + for lInc := (lGrid.ColCount-1 {-1 for Lazarus 999}) downto 0 do + for lInc2 := 0 to kMaxFactors do + lGrid.Cells[lInc,lInc2] := ''; + lA := DesignForm.AVal.value; +//999 showmessage(inttostr(lGrid.RowCount)+'x'+inttostr(lGrid.ColCount)+'alpha'+inttostr(lA)); + //lGrid.Cells[0,0] := ''; + for lInc := 1 to lA do + lGrid.Cells[lInc,0] := DesignForm.ALevelNames.Cells[lInc-1,0]; +{$IFDEF FPC} + for lInc := (lGrid.ColCount -2) downto 0 do + lGrid.Cells[lInc +1 ,kMaxFactors] := ColLabel(lInc+1); +{$ELSE} + for lInc := (lGrid.ColCount -1) downto 0 do + lGrid.Cells[lInc+1,kMaxFactors] := ColLabel(lInc+1);//chr(ord('A')+lInc); +{$ENDIF} + +end; + +procedure TSpreadForm.UpdateLabels; +begin + DataGrid.ColCount := DesignForm.AVal.value+1; //2007 For FPC + UpdateGridLabels(DataGrid); + DataGrid.ColCount := DesignForm.AVal.value+1; +end; + +procedure TSpreadForm.Aboutthissoftware1Click(Sender: TObject); +begin + Showmessage(kRegressSWVers); // AboutForm.Showmodal; +end; + + +procedure ClearDesignMatrix; +begin + + gDesignUnspecified := true; + SpreadForm.DesignBtn.Caption := 'Design: not specified'; +end; + +procedure DesignBtnLabelUpdate; +begin + SpreadForm.DesignBtn.Caption := 'Design IVs: '+inttostr(DesignForm.AVal.Value) ; + SpreadForm.UpdateLabels; + SpreadForm.FormResize(nil); +end; + +{$ifdef fpc} +function alignx(addr : Pointer;alignment : PtrUInt) : Pointer; +begin + + result:=align(addr,alignment); +end; +{$endif} + +procedure TSpreadForm.OpenTextFile (var lFilename:string); +var lTemplateName:string; + lnCritPct,lnRow,lnCol,lnColWObs,lCol,lRow: integer; + //lLesionCovary : boolean; + lPredictorList,lFileList:TStringList; + lDoublePtr: Pointer; + lDoubleBuf : DoubleP; +begin + Self.Caption := kRegressSWVers+': '+extractfilename(lFilename); + ClearDesignMatrix; + lPredictorList := TStringList.Create; + lFileList := TStringList.Create; + gVALChanges := false; + OpenValFile (lFilename,lTemplateName, lnRow,lnCol,lnColWObs,lnCritPct,gDesignUnspecified,lPredictorList,lFileList,lDoublePtr); + {$IFDEF FPC} + DataGrid.RowCount := kMaxFactors+lnRow{-1}; + {$ELSE} + DataGrid.RowCount := kMaxFactors+lnRow; + {$ENDIF} + DataGrid.ColCount := lnCol+1; + DataGrid.refresh; + {$IFDEF FPC} + lDoubleBuf := alignx(lDoublePtr, 16); // note: lDoubleBuf > lDoublePtr always (VSDS); + {$ELSE} + lDoubleBuf := DoubleP($fffffff0 and (integer(lDoublePtr)+15)); + {$ENDIF} + if lFileList.Count < lnRow then + lnRow := lFileList.Count; + for lRow := 1 to lnRow do begin + + DataGrid.Cells[ 0, kMaxFactors+lRow ] := lFileList.Strings[lRow-1]; + for lCol := 1 to lnCol do begin + if lDoubleBuf^[RowColPos (lRow,lCol,lnColWObs)] = kMagicDouble then + DataGrid.Cells[ lCol, kMaxFactors+lRow ] := '' + else + DataGrid.Cells[ lCol, kMaxFactors+lRow ] := floattostr((lDoubleBuf^[RowColPos (lRow,lCol,lnColWObs)])); + end; + + end; + +if lPredictorList.Count < lnRow then + for lCol := (lPredictorList.Count+1) to lnRow do + lPredictorList.Add( 'Pred'+inttostr(lCol) ); + DesignForm.ALevelNames.ColCount := lnCol; + for lCol := 1 to lnCol do + DesignForm.ALevelNames.Cells[lCol-1,0] := lPredictorList.Strings[lCol-1]; + Freemem(lDoublePtr); + lPredictorList.Free; + lFileList.free; + //DesignForm.LesionCovaryCheck.Checked := lLesionCovary; + DesignForm.CritPctEdit.value := lnCritPct; + DesignForm.TemplateLabel.Caption := lTemplateName; + //Tidy Up... + DesignForm.AVal.Value := lnCol; + UpdateLabels; + + DesignBtnLabelUpdate; + + FormResize(nil); + if gDesignUnspecified then + Showmessage('You need to define the experiment design [press the ''Design'' button]'); + +end; + +procedure TSpreadForm.OpenBtnClick(Sender: TObject); +var lFileName: string; +begin + if gVALChanges then begin + if not CheckSave2Close(true) then exit; + end; + if not SOpenDialogExecute('Select VAL design file',false,false, kValFilter) then exit; + lFilename := OpenDialog1.filename; + if not fileexists(lFilename) then exit; + OpenTextFile(lFilename); +end; + +procedure GridToStatusBar(lGrid: TStringGrid; lStatus: TStatusBar); +begin +{$IFDEF FPC} + //SpreadForm.StatusBar1.Panels[1].Text := inttostr(random(888)); + if (lGrid.Selection.Top <= kMaxFactors) or (lGrid.Selection.Left <= 0) then begin + lGrid.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + SpreadForm.Caption := ''; + exit; + end; + if lGrid.Selection.Top < 0 then exit; + if((lGrid.Selection.Top = lGrid.Selection.Bottom ) and ( lGrid.Selection.Left = lGrid.Selection.Right )) then begin + SpreadForm.Caption := + lGrid.Cells[0,lGrid.Selection.Top]+' = '+lGrid.Cells[lGrid.Selection.Left,lGrid.Selection.Top]+' '+ + lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+inttostr(lGrid.Selection.Top-kMaxFactors); + end else begin + SpreadForm.Caption := inttostr(lGrid.Selection.Bottom-lGrid.Selection.Top + 1)+'R x '+ inttostr(lGrid.Selection.Right-lGrid.Selection.Left + 1)+'C'; + end; + + (*if((lGrid.Selection.Top <> lGrid.Selection.Bottom ) or ( lGrid.Selection.Left <> lGrid.Selection.Right )) then exit; + + if (lGrid.Selection.Top <= kMaxFactors) or (lGrid.Selection.Left <= 0) then begin + lGrid.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + lStatus.Panels[0].Text := ''; + exit; + end; + if (lGrid.Selection.Top < 0) then exit; + + //lStatus.Panels[1].Text := inttostr(lGrid.Selection.Bottom-lGrid.Selection.Top + 1)+'R x '+ inttostr(lGrid.Selection.Right-lGrid.Selection.Left + 1)+'C'; + //lStatus.Panels[1].Text := inttostr(lGrid.Selection.Top)+'R x '+ inttostr(lGrid.Selection.Bottom)+'C'; + SpreadForm.Caption := inttostr(lGrid.Selection.Top)+'R x '+ inttostr(lGrid.Selection.Left)+'C'; + exit; + if((lGrid.Selection.Top = lGrid.Selection.Bottom ) and ( lGrid.Selection.Left = lGrid.Selection.Right )) then begin + lStatus.Panels[1].Text := {ColLabel(lGrid.Selection.Left)+}lGrid.Cells[0,lGrid.Selection.Top]{inttostr(lGrid.Selection.Top-kMaxFactors)}+' = '+lGrid.Cells[lGrid.Selection.Left,lGrid.Selection.Top]; +// lStatus.Panels[0].Text := lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+' '+lGrid.Cells[lGrid.Selection.Left,2]; +// lStatus.Panels[0].Text := lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+inttostr(lGrid.Selection.Top-kMaxFactors); + //lStatus.Panels[0].Text := lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+inttostr(lGrid.Selection.Top-kMaxFactors); + + end else begin + lStatus.Panels[0].Text := inttostr(lGrid.Selection.Bottom-lGrid.Selection.Top + 1)+'R x '+ inttostr(lGrid.Selection.Right-lGrid.Selection.Left + 1)+'C'; + lStatus.Panels[1].Text := ''; + end; *) +{$ELSE} //Delphi + if (lGrid.Selection.Top <= kMaxFactors) or (lGrid.Selection.Left <= 0) then begin + lGrid.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + lStatus.Panels[0].Text := ''; + exit; + end; + if lGrid.Selection.Top < 0 then exit; + if((lGrid.Selection.Top = lGrid.Selection.Bottom ) and ( lGrid.Selection.Left = lGrid.Selection.Right )) then begin + lStatus.Panels[1].Text := lGrid.Cells[0,lGrid.Selection.Top]+' = '+lGrid.Cells[lGrid.Selection.Left,lGrid.Selection.Top]; + lStatus.Panels[0].Text := lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+inttostr(lGrid.Selection.Top-kMaxFactors); + end else begin + lStatus.Panels[0].Text := inttostr(lGrid.Selection.Bottom-lGrid.Selection.Top + 1)+'R x '+ inttostr(lGrid.Selection.Right-lGrid.Selection.Left + 1)+'C'; + lStatus.Panels[1].Text := ''; + end; +{$ENDIF} + +end; + +procedure TSpreadForm.ShowStatus; +begin +//SpreadForm.Caption := inttostr(random(888)); + GridToStatusBar(DataGrid,StatusBar1); +end; + +procedure TSpreadForm.DataGridSelectCell(Sender: TObject; ACol, ARow: Integer; + var CanSelect: Boolean); +begin + //ShowStatus; //bxxx + gEnterCell := true; +end; + +procedure TSpreadForm.NewBtnClick(Sender: TObject); +begin + DesignForm.Showmodal; + gDesignUnspecified := false; + DesignBtnLabelUpdate; +end; + +function RemoveColons( lStr: string): string; +var lLen,lPos: integer; +begin + result := lStr; + lLen := length(lStr); + if lLen < 1 then exit; + for lPos := 1 to lLen do + if result[lPos] = ':' then + result[lPos] := ';'; +end; + +function Str2Float (var lStr: string; var lError: boolean): single; +begin + lError := false; + try + result := Strtofloat(lStr); + except + on EConvertError do + lError := true; + end; //except +end; + +procedure TSpreadForm.Save1Click(var NoCancel: boolean); +const + kNative = 1; + kTxt = 2; +var + f: TextFile; + lFormat,C, R,lLen,lPos,ColStart,ColEnd,RowStart,RowEnd : integer ; + lLevelStr,lFilename,S,lCell,lExt : string ; + kSpacer,lDecimalSep : char; + lError: boolean; +begin + NoCancel := false; + if not SaveDialog1.Execute then exit; + lFormat := SaveDialog1.FilterIndex; + if (lFormat < kNative) or (lFormat > kTxt) then + lFormat := kNative; + case lFormat of + kTxt: lExt := kTXText; + else lExt := kValNativeExt; + end; + if lFormat <> kNative then begin + case MessageDlg( 'Export file as a text format? Note you will lose information about the experiment design [save to Native format to preserve condition information]', mtWarning, [mbYes, mbCancel], 0 ) of + mrCancel : exit ; + end ; + end; //not native + if (lFormat = kNative) and (gDesignUnspecified) then begin + showmessage('Unable to save this data as '+kRegressSWVers+' format file until you have specified the conditions [press the ''Design'' button]'); + exit; + end; + //lExt := StrUpper(PChar(extractfileext(SaveDialog1.Filename))); + lFilename := SaveDialog1.Filename; + lDecimalSep := DecimalSeparator; + DecimalSeparator := '.'; + ChangeFileExt(lFilename,lExt); + // Setup... + kSpacer := #9; //tab + S := '' ; + RowStart := kMaxFactors+1 ; + RowEnd := DataGrid.RowCount - 1; + ColStart := 0 ; + ColEnd := DataGrid.ColCount - 1; + if (ColEnd < ColStart) or (RowEnd < RowStart) then exit; + // Copy to string + for R := RowStart to RowEnd do + begin + for C := ColStart to ColEnd do begin + + lCell := DataGrid.Cells[ C, R ]; + if C <> ColStart then begin + if lCell = '' then //this simply prevents error reports when run from debugger + lError := true + else + Str2Float (lCell, lError); + if (lError) then + lCell := '-'; + end; + S := S + lCell; + if( C < DataGrid.ColCount - 1 ) then + S := S + kSpacer{#9} ; // Tab + end ; + if R <> (DataGrid.RowCount - 1) then //all except last line + S := S + #13#10 ; // End line + end ; + AssignFile(f, lFileName); + rewrite(f); + if lFormat = kNative then begin + Self.Caption := kRegressSWVers+': '+extractfilename(SaveDialog1.Filename);//remove any previous filename + if Files4D(DataGrid.Cells[ ColStart, RowStart ]) then + writeln(f,kVALNativeSignatureBase + '1')//version 1 supports 4D images + else + writeln(f,kVALNativeSignatureBase + '0');//version 0 supports 3D images only + + //Details for 1st factor + //writeln(f,'#Predictors:'+inttostr(lLen)+lLevelStr+lWithinSubjStr); + writeln(f,'#Covary Volume'+kSpacer+bool2char(DesignForm.LesionCovaryCheck.Checked)); + writeln(f,'#Template'+kSpacer+DesignForm.TemplateLabel.Caption); + writeln(f,'#CritPct'+kSpacer+inttostr(DesignForm.CritPctEdit.value)); + lLevelStr := 'ImageName'; + lLen := DesignForm.AVal.value; + if lLen >= 1 then + for lPos := 1 to lLen do + lLevelStr := lLevelStr+kTab+(DesignForm.ALevelNames.Cells[lPos-1,0]); + writeln(f,lLevelStr); + gVALChanges := false; + end; + Writeln(f, S); + Flush(f); { ensures that the text was actually written to file } + CloseFile(f); + NoCancel := true; + DecimalSeparator :=lDecimalSep; +end; + +(* +procedure registerfiletype(inft,inkey,desc,icon:string); +var myreg : treginifile; + ct : integer; + ft,key: string; +begin + ft := inft; + key := inkey; + ct := pos('.',ft); + while ct > 0 do begin + delete(ft,ct,1); + ct := pos('.',ft); + end; + if (ft = '') or (Application.ExeName = '') then exit; //not a valid file-ext or ass. app + ft := '.'+ft; + myreg := treginifile.create(''); + try + myreg.rootkey := hkey_classes_root; // where all file-types are described + if key = '' then key := copy(ft,2,maxint)+'_auto_file'; // if no key-name is given, create one + myreg.writestring(ft,'',key); // set a pointer to the description-key + myreg.writestring(key,'',desc); // write the description + myreg.writestring(key+'\DefaultIcon','',icon); // write the def-icon if given + myreg.writestring(key+'\shell\open\command','',Application.ExeName+' %1'); //association + finally + myreg.free; + end; +end; *) + +procedure TSpreadForm.FormCreate(Sender: TObject); +begin + SpreadForm.Caption := kRegressSWName; +(* registerfiletype(kNativeExt,kRegressSWName{key},kRegressSWName,Application.ExeName+',1'); + DragAcceptFiles(Handle, True); *) + DataGrid.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + gVALFontSize := 8; + //DecSeparator := DecimalSeparator; + //l64rBufP := nil; + gEnterCell := false; + gVALChanges := false; + DataGrid.ColCount := 9; + DataGrid.RowCount := 15; + FormResize(nil); + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + +New1.ShortCut := ShortCut(Word('N'), [ssMeta]); + Open1.ShortCut := ShortCut(Word('O'), [ssMeta]); + Save1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Quit1.ShortCut := ShortCut(Word('W'), [ssMeta]); + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Paste1.ShortCut := ShortCut(Word('V'), [ssMeta]); + Selectall1.ShortCut := ShortCut(Word('A'), [ssMeta]); + DescriptiveMenu.ShortCut := ShortCut(Word('L'), [ssMeta]); + + {$ENDIF}//Carbon + {$ENDIF}//Darwin +end; + +procedure TSpreadForm.DataGridMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var C, R : integer ; + Rect : TGridRect ; + +begin + + DataGrid.MouseToCell( X, Y, C, R ) ; + Rect.Left := C ; + Rect.Right := C ; + Rect.Top := R ; + Rect.Bottom := R ; + DataGrid.Selection := Rect ; +end; + +procedure TSpreadForm.DataGridKeyPress(Sender: TObject; var Key: Char); +var S : string ; + +begin + if (Key in ['0'..'9','.',kBS,kDel,kCR]) or ((Key='-') and (gEnterCell)) then + else + exit; + if(( DataGrid.Selection.Top = DataGrid.Selection.Bottom ) and + ( DataGrid.Selection.Left = DataGrid.Selection.Right )) then begin + gVALChanges := true; + if gEnterCell then begin + S := '' + end else + S := DataGrid.Cells[ DataGrid.Selection.Left,DataGrid.Selection.Top ] ; + gEnterCell := false; + if ( ( Key = kDEL ) or ( Key = kBS ) )then + begin + if( length( S ) > 0 ) then + begin + setlength( S, length( S ) - 1 ) ; + end ; + end else + if ( Key = kCR ) then + begin + //Edit_Box.Text := S ; + exit ; + end else + begin + S := S + Key ; + end ; + DataGrid.Cells[ DataGrid.Selection.Left, DataGrid.Selection.Top ] := S ; + //Format_Grid.Cells[ DataGrid.Selection.Left, DataGrid.Selection.Top ] := '' ; + end ; +end; + +procedure TSpreadForm.Copy1Click(Sender: TObject); +var C, R : integer ; + P: PChar; + S : string ; + RStart,CStart,REnd,CEnd : integer ; +begin + // Setup... + S := '' ; + if (DataGrid.Selection.Left < 0) or (DataGrid.Selection.Top < 0) then begin + DataGrid.Selection:= TGridRect(Rect(1,1+kMaxFactors,DataGrid.ColCount-1,DataGrid.RowCount-1)); + end; + CStart := DataGrid.Selection.Left; + CEnd := DataGrid.Selection.Right; + RStart := DataGrid.Selection.Top; + REnd := DataGrid.Selection.Bottom; + // Copy to string + for R := RStart to REnd do + begin + for C := CStart to CEnd do + begin + S := S + DataGrid.Cells[ C, R ] ; + if( C < CEnd ) then begin + S := S + #9 ; // Tab + end ; + end ; + S := S + #13#10 ; // End line + end ; + // Set clipboard + {$IFNDEF FPC} + Clipboard.SetTextBuf( PChar( S ) ) ; +{$ELSE} + p:=StrAlloc (length(S)+1); + if StrPCopy (P,S)=P then + Clipboard.SetTextBuf(P); + +{$ENDIF} +end; + +procedure TSpreadForm.Paste1Click(Sender: TObject); +const + BS = #8 ; { Backspace } + CR = #13 ; { Carriage return } + DEL = #127 ; { Delete } + //HT = #9 ; { Horizontal Tab } + //LF = #10 ; { Line Feed } + //VT = #11 ; { Vertical Tab } +var StartC,C, R,I : integer ; + Dummy : integer ; + lSciNotation,EOF: boolean; + lValue: double; + DecSeparator : char; + Line, S, Work,WorkFilter : string ; +begin + // Setup... + DecSeparator := DecimalSeparator; + S := Clipboard.AsText ; + EOF:= false; + if (DataGrid.Selection.Left < 0) or (DataGrid.Selection.Top < 0) then begin + Selectall1Click(nil); + end; + //gChanges := true; + StartC := DataGrid.Selection.Left; + R := DataGrid.Selection.Top; + C := StartC; + while( length( S ) > 0 ) do begin + // Extract next line... + {$IFDEF UNIX} + Dummy := pos( #13, S + #13 ) ; + {$ELSE} + Dummy := pos( #13#10, S + #13#10 ) ; + {$ENDIF} + Line := copy( S, 1, Dummy - 1 ) ; + if (Dummy+1) < length(S) then //last line may not have eol + S := copy( S, Dummy + 1, length( S ) ) + else + EOF := true; + while( length( Line ) > 0 ) do begin + // Extract next cell... + lSciNotation := false; + Dummy := pos( #9, Line + #9 ) ; + Work := copy( Line, 1, Dummy - 1 ) ; + Line := copy( Line, Dummy + 1, length( S ) ) ; + WorkFilter := ''; + if length(Work) > 0 then begin + for I := length(Work) downto 1 do begin + if (Work[i] in ['-','0'..'9','E','e',DecSeparator,BS,DEL,CR]) then + WorkFilter := Work[i]+WorkFilter; + if (Work[i] in ['E','e']) then + lSciNotation := true; + end; + end; + if lSciNotation then begin + try + lValue := strtofloat(Workfilter); + except + on EConvertError do + lValue := NaN + else + lValue := NaN; + end; //try..except + if lValue <> NaN then + DataGrid.Cells[ C, R ] :=(floattostr(lValue)); + end else if(length(WorkFilter) > 0) and ( C < DataGrid.ColCount ) then begin + DataGrid.Cells[ C, R ] := WorkFilter ; + //Format_Grid.Cells[ C, R ] := '' ; + end ; + inc( C ) ; + end ; + inc( R ) ; // Move to next row + if( R >= DataGrid.RowCount ) or (EOF) then begin + break ; // All done with paste + end ; + C := StartC; + end ; // While length(S) > 0 +end; //proc Paste1Click +(*var StartC,C, R,I : integer ; + Dummy : integer ; + lSciNotation,EOF,lData: boolean; + lValue: double; + Line, S, Work,WorkFilter : string ; +begin + // Setup... + lValue := 0; //only to prevent compiler warning... + S := Clipboard.AsText ; + EOF:= false; + if (DataGrid.Selection.Left < 0) or (DataGrid.Selection.Top < 0) then begin + Selectall1Click(nil); + end; + //R := 1 ; + //StartC := 1 ; + StartC := DataGrid.Selection.Left; + //CEnd := DataGrid.Selection.Right; + R := DataGrid.Selection.Top; + //REnd := DataGrid.Selection.Bottom; + // Do the paste + C := StartC; + while( length( S ) > 0 ) do begin + // Extract next line... + Dummy := pos( #13#10, S + #13#10 ) ; + Line := copy( S, 1, Dummy - 1 ) ; + if (Dummy+1) < length(S) then //last line may not have eol + S := copy( S, Dummy + 1, length( S ) ) + else + EOF := true; + //showmessage(inttostr(C)+'x'+Line); + while( length( Line ) > 0 ) do begin + // Extract next cell... + lSciNotation := false; + //old + //Dummy := pos( #9, Line + #9 ) ; + //new - comma separated, etc + lData := false; + Dummy := length(line)+1; + I := 1; + repeat + if (Line[i] in ['-','0'..'9','E','e']) then + lData := true + else begin + if lData then Dummy := I; + end; + inc(I); + until (I > length(Line)) or (Dummy = (I-1)); + //end new + + Work := copy( Line, 1, Dummy - 1 ); + //showmessage(inttostr(Dummy)+'x'+Work); + + Line := copy( Line, Dummy + 1, length( S ) ) ; + //showmessage(Line); + WorkFilter := ''; + if length(Work) > 0 then begin + for I := length(Work) downto 1 do begin + if (Work[i] in ['-','0'..'9','E','e','.',kBS,kDEL,kCR]) then + WorkFilter := Work[i]+WorkFilter; + if (Work[i] in ['E','e']) then + lSciNotation := true; + end; + end; + if lSciNotation then begin + try + lValue := strtofloat(Workfilter); + except + on EConvertError do + lValue := NaN; + end; //try..except + if lValue <> NaN then + DataGrid.Cells[ C, R ] :=(floattostr(lValue)); + end else if(length(WorkFilter) > 0) and ( C < DataGrid.ColCount ) then begin + DataGrid.Cells[ C, R ] := WorkFilter ; + //Format_Grid.Cells[ C, R ] := '' ; + end ; + inc( C ) ; + end ; + inc( R ) ; // Move to next row + if( R >= DataGrid.RowCount ) or (EOF) then begin + break ; // All done with paste + end ; + //Showmessage(inttostr(StartC)); + C := StartC; + end ; // TMainForm.Paste1Click +end; *) + + +procedure TSpreadForm.SaveBtnClick(Sender: TObject); +var + b: boolean; +begin + Save1Click(b); +end; + +function TSpreadForm.CheckSave2Close (lAllowCancel: boolean): boolean; +begin + result := true; + if not gVALChanges then exit; + result := false; + if lAllowCancel then begin + case MessageDlg( 'Save changes?', mtWarning, [mbYes, mbNo, mbCancel], 0 ) of + mrYes : begin + Save1Click( result ) ; + end ; + mrCancel : exit ; + end ; + end else + case MessageDlg( 'Save changes?', mtWarning, [mbYes, mbNo], 0 ) of + mrYes : begin + Save1Click( result ) ; + end ; + end; + result := true; +end; + +procedure TSpreadForm.ReadCells2Buffer; +var + lDbl: double; + lRend,lRStart,lCStart,lCEnd,lC,lR,lPos: integer; + lStr: string; + l64rBufP: pointer; + l64rBuf: DoubleP; +begin + //if l64rBufP <> nil then + // freemem(l64rBufP); + GetMem(l64rBufP,(DataGrid.ColCount*DataGrid.RowCount*sizeof(double))+16); + {$IFDEF FPC} + l64rBuf := alignx(l64rBufP, 16); + {$ELSE} + l64rBuf := DoubleP((integer(l64rBufP) and $FFFFFFF0)+16); + {$ENDIF} + lRStart := {1}kMaxFactors+1; + lREnd := DataGrid.RowCount - 1; + lCstart := 1; + lCend := DataGrid.ColCount - 1; + //gnCol := lCEnd; + //gnRow := lREnd-lRStart+1; + // Copy to string + lPos := 0; + for lR := lRStart to lREnd do begin + for lC := lCStart to lCEnd do begin + inc(lPos); + lStr := (DataGrid.Cells[ lC, lR ]); + lDbl := NaN; + if length(lStr) > 0 then begin + try + lDbl := Strtofloat(lStr); + except + on EConvertError do begin + showmessage('Cell '+ColLabel(lC)+inttostr(lR-kMaxFactors)+ ': Unable to convert the string '+lStr+' to a number'); + DataGrid.Cells[ lC, lR ] := ''; + lDbl := NaN; //NAN? Not-A-Number + end; //Error + end; //except + end; //length > 0 + l64rBuf^[lPos] :=lDbl; + end ; //for each col + end ; //for each row + freemem(l64rBufP); +end; + +procedure TSpreadForm.Selectall1Click(Sender: TObject); +begin + DataGrid.Selection:= TGridRect(Rect(1,1+kMaxFactors,DataGrid.ColCount-1,DataGrid.RowCount-1)); +end; + +procedure TSpreadForm.FontSizeChange(Sender: TObject); +begin + (sender as TMenuItem).Checked := true; + gVALFontSize := (sender as TMenuItem).tag; + DataGrid.Font.Size := (sender as TMenuItem).tag; + DataGrid.DefaultRowHeight := (sender as TMenuItem).tag+12; + FormResize(nil); +end; + +procedure TSpreadForm.DataGridMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + ShowStatus; +end; + +procedure TSpreadForm.DataGridDrawCell(Sender: TObject; Col, Row: Integer; + Rect: TRect; State: TGridDrawState); +begin + ShowStatus; +end; + +procedure TSpreadForm.Clearallcells1Click(Sender: TObject); +var + lR,lC,lRi,lCi: integer; +begin + lR := DataGrid.RowCount-1; + lC := DataGrid.ColCount-1; + for lRi := 1 to lR do begin + for lCi := 1 to lC do begin + DataGrid.Cells[lCi,kMaxFactors+lRi] := ''; + end;//for cols + end;//for rows +end; + +procedure TSpreadForm.DesignBtnClick(Sender: TObject); +begin + DesignForm.Showmodal; + gDesignUnspecified := false; + DesignBtnLabelUpdate; +end; + +procedure TSpreadForm.AddMRIScansClick(Sender: TObject); +begin +DesignForm.AddMRIBtnClick(nil); +end; + +function TSpreadForm.GetVal (lC,lR: integer; var lVal: double): boolean; +var + lStr: string; + lDbl: double; +begin + result := false; + lVal := 0; + lStr := (DataGrid.Cells[ lC, lR ]); + if lStr = '' then + exit; + try + lDbl := Strtofloat(lStr); + except + on EConvertError do begin + showmessage('Cell '+ColLabel(lC)+inttostr(lR-kMaxFactors)+ ': Unable to convert the string '+lStr+' to a number'); + exit; + end; + end; //try..except + lVal := lDbl; + result := true; +end;//GetVal + +procedure TSpreadForm.DescriptiveClick(Sender: TObject); +var + lMn,lSD,lSE,lSkew,lZSkew: double; + n,lR,lC,lRi,lCi: integer; + lVal: double; + RA: SingleP; +begin + lR := DataGrid.RowCount-1; + if (lR <= kMaxFactors+1) then + exit; + lC := DataGrid.ColCount-1; + Getmem(RA,lR * sizeof(single)); + for lCi := 1 to lC do begin + n := 0; + for lRi := (kMaxFactors+1) to lR do begin + if GetVal (lCi,lRi,lVal) then begin + inc(n); + RA^[n] := lVal; + end; + + end;//for rows + if n > 0 then begin + SuperDescriptive (RA, n, lMn,lSD,lSE,lSkew,lZSkew); + Showmessage('"'+DataGrid.Cells[ lC, 0]+'" mean='+floattostr(lMn)+',StDev='+floattostr(lSD)+',StEr='+floattostr(lSE)+',Skew='+floattostr(lSkew)+',ZSkew='+floattostr(lZSkew)); + + end; //n > 0 + end;//for cols + Freemem(RA); +end; + + +{$IFNDEF FPC} + procedure TSpreadForm.FormClose(Sender: TObject; var Action: TCloseAction); +{$ELSE} + procedure TSpreadForm.FormClose(Sender: TObject); +{$ENDIF} +begin + CheckSave2Close(false); +end; + + + +{$IFDEF FPC} +initialization + {$I spread.lrs} +{$ENDIF} + +end. \ No newline at end of file diff --git a/npm/spread.ppu b/npm/spread.ppu new file mode 100644 index 0000000..3bdc256 Binary files /dev/null and b/npm/spread.ppu differ diff --git a/npm/statcr.o b/npm/statcr.o new file mode 100644 index 0000000..f1fd24f Binary files /dev/null and b/npm/statcr.o differ diff --git a/npm/statcr.pas b/npm/statcr.pas new file mode 100755 index 0000000..2a2c27c --- /dev/null +++ b/npm/statcr.pas @@ -0,0 +1,631 @@ +Unit statcr; +interface +uses dialogsx,define_types; + +const + ITMAX = 300; + EPS = 3.0e-7; + kMaxFact = 1700; {<= 1754} + gFactRAready : boolean = false; +type + FactRA = array[0..kMaxFact] of extended; +var + gFactRA : FactRA; +FUNCTION betai(a,b,x: double): double; +procedure AlertMsg (pWarningStr: String); +function gammq( a,x: real): real; +function Fisher (A,B,C,D: integer): double; +procedure Chi2x2 (A, B, C, D: integer; var pMinExp, pChi, p, puChi, pup: double); +function Liebermeister (A,B,C,D: integer): extended; +procedure EstimateFDR(lnTests: integer; Ps: SingleP; var lFDR05, lFDR01: double); +function Fisher1TailMidP (A,B,C,D: integer): double; { use instead of chi2x2: returns p-value} +procedure InitFact; +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +procedure Descriptive (nV, SumOfSqrs, Sum: double; var lMn,lSD,lSE: double); +procedure SuperDescriptive (var RA: SingleP; n: integer; var lMn,lSD,lSE,lSkew,lZSkew: double); + +implementation +uses Math{power}; +procedure Descriptive (nV, SumOfSqrs, Sum: double; var lMn,lSD,lSE: double); +//given nV,SumOfSqrs,and Sum, returns Mean, StandardDeviation,StandardError and Skew +begin + //first: initialize values + lSD := 0; + lSE := 0; + lMn := 0; + if nV < 1 then + exit; + //next: compute mean + lMn := Sum / nV; + if (nV < 2) then + exit; + lSD := SumOfSqrs-(Sum*Sum/nV); + lSD := sqrt((lSD)/(nV-1) ); + lSE := lSD/ sqrt(nV); +end; + +procedure SuperDescriptive (var RA: SingleP; n: integer; var lMn,lSD,lSE,lSkew,lZSkew: double); +var + i: integer; + SumOfSqrs,Sum,Sigma: double; +begin + lMn:= 0; + lSD := 0; + lSE := 0; + lSkew := 0; + lZSkew := 0; + if n < 1 then exit; + Sum := 0; + SumOfSqrs := 0; + for i := 1 to n do begin + Sum := Sum + RA^[i]; + SumOfSqrs := SumOfSqrs + sqr(RA^[i]); + end; + Descriptive (n, SumOfSqrs, Sum,lMn,lSD,lSE); + if (n < 3) or (lSD = 0) then + lSkew := 0 + else begin + Sigma := 0; + for i := 1 to n do + Sigma := Sigma + Power( ((RA^[i]-lMn) / lSD) ,3); + lSkew := (n/ ( (n-1)*(n-2) ) ) * Sigma; + end; + lZSkew := lSkew/(sqrt(6/N)); +end; + +procedure InitFact; +var lX: word; +begin + gFactRA[0]:= 1; + gFactRA[1] := 1; + for lx := 2 to kMaxFact do + gFactRA[lx] := lx * gFactRA[lx-1]; + gFactRAready := true; +end; + +function FisherX (A,B,C,D: integer): double; {FisherExactTest, use instead of chi} +{FisherX computes odds for this specific config only, not more extreme cases} +{alternate to Chi Square, see Siegel & Castellan, Nonparametric Statistics} +{use instead of Chi when n <= 20} +{A= X hits, B= control hits, C = X misses, D = control misses} +var + N: word; +begin + N := A+B+C+D; + if (N <= kMaxFact) and (A>=0) and (B>=0) and (C>=0) and (D>=0) and (N > 0) then begin + FisherX := ( + (gFactRA[A+B]/gFactRA[A])* + (gFactRA[B+D]/gFactRA[B])* + (gFactRA[A+C]/gFactRA[C])* + (gFactRA[C+D]/gFactRA[D]) + )/ gFactRA[N]; + end else FisherX := 0; +end; +function MidPKingFisher (lSmal,lCross1,lCross2,lSmalDiag: integer): extended; +var + lProb1, lProb2: extended; + lA,lB,lC,lD,lCnt: integer; + l1st : boolean; +begin + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb1:=0; + l1st := true; //set to true for midP + for lCnt := lA downto 0 do begin + if l1st then + lProb1 := 0.5* FisherX(lA,lB,lC,lD) + else + lProb1 := lProb1 + FisherX(lA,lB,lC,lD); + l1st := false; + dec(lA); + dec(lD); + inc(lB); + inc(lC); + end; + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb2:=0; + l1st := true; //alfa -set to true for MidP + while (lB >= 0) and (lC >= 0) do begin + if l1st then + lProb2 := 0.5* FisherX(lA,lB,lC,lD) + else + lProb2 := lProb2 + FisherX(lA,lB,lC,lD); + l1st := false; + inc(lA); + inc(lD); + dec(lB); + dec(lC); + end; + if lProb1 < lProb2 then + result := lProb1 + else + result := lProb2; + //result := lprob1; +end; + +function KingFisher (lSmal,lCross1,lCross2,lSmalDiag: integer): double; +var + lProb1, lProb2: double; + lA,lB,lC,lD,lCnt: integer; + +begin + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb1:=0; + for lCnt := lA downto 0 do begin + lProb1 := lProb1 + FisherX(lA,lB,lC,lD); + dec(lA); + dec(lD); + inc(lB); + inc(lC); + end; + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb2:=0; + while (lB >= 0) and (lC >= 0) do begin + lProb2 := lProb2 + FisherX(lA,lB,lC,lD); + inc(lA); + inc(lD); + dec(lB); + dec(lC); + end; + if lProb1 < lProb2 then + result := lProb1 + else + result := lProb2; +end; + +function Lieber (lSmal,lCross1,lCross2,lSmalDiag: integer): extended; +var + lA,lB,lC,lD,lCnt: integer; +begin + lA :=lSmal; + lB:=lCross1+1; + lC:=lCross2+1; + lD:=lSmalDiag; + result :=0; + for lCnt := lA downto 0 do begin + result := result + FisherX(lA,lB,lC,lD); + dec(lA); + dec(lD); + inc(lB); + inc(lC); + end; + //TabbedNotebookDlg.caption := realtostr(result,6) ; + //TabbedNotebookDlg.caption := realtostr(result,6) ; + if result <= 0.5 then + exit; + + lA :=lSmal+1; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag+1; + result:=0; + while (lB >= 0) and (lC >= 0) do begin + result := result + FisherX(lA,lB,lC,lD); + inc(lA); + inc(lD); + dec(lB); + dec(lC); + end; +end; + +function Liebermeister (A,B,C,D: integer): extended; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + result := 1; + if (A+B+C+D)<1 then + exit; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=Lieber(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=Lieber(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=Lieber(C,D,A,B) + else {d smallest} + result :=Lieber(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end; + +(*function Liebermeister (Ain,Bin,Cin,Din: integer): extended; +var + A,B,C,D: integer; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + A := Ain; + B := Bin; + C := Cin; + D := Din; + if (A+B+C+D)<1 then begin + result := 1; + exit; + end; + //easy way to calculate Lieberman - make more extreme, then calculate Fisher + if abs(A-D) > abs(B-C) then begin + inc(A); + inc(D); + end else begin + inc(B); + inc(C); + end; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=KingFisher(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=KingFisher(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=KingFisher(C,D,A,B) + else {d smallest} + result :=KingFisher(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end;*) +function Fisher (A,B,C,D: integer): double; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + if (A+B+C+D)<1 then begin + result := 1; + exit + end; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=KingFisher(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=KingFisher(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=KingFisher(C,D,A,B) + else {d smallest} + result :=KingFisher(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end; + + +function Fisher1TailMidP (A,B,C,D: integer): double; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + if (A+B+C+D)<1 then begin + result := 1; + exit + end; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=MidPKingFisher(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=MidPKingFisher(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=MidPKingFisher(C,D,A,B) + else {d smallest} + result :=MidPKingFisher(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end; + +procedure Sort (first, last: integer; var DynDataRA:SingleP); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 1 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + i := i - m; + if (i >= 1) then + goto 555; + end + end + end +end;//sort + +procedure EstimateFDR(lnTests: integer; Ps: SingleP; var lFDR05, lFDR01: double); +var + lInc: integer; + Qs: SingleP; +begin + //rank Pvalues + Sort(1,lnTests,Ps); + {lStr := 'sort='; + for lInc := 1 to knTests do + lStr := lStr+realtostr(Ps[lInc],4)+','; + Memo1.Lines.Add(lStr); } + GetMem(Qs,lnTests*sizeof(single)); + //next findcrit FDR05 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lFDR05 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR05 := Ps^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lFDR01 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR01 := Ps^[lInc]; + Freemem(Qs); +end; + +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +var + lInc: integer; + lrPs,Qs: SingleP; +begin + //rank Pvalues + Sort(1,lnTests,Ps); + {lStr := 'sort='; + for lInc := 1 to knTests do + lStr := lStr+realtostr(Ps[lInc],4)+','; + Memo1.Lines.Add(lStr); } + GetMem(Qs,lnTests*sizeof(single)); + //next findcrit FDR05 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lFDR05 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR05 := Ps^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lFDR01 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR01 := Ps^[lInc]; + + //reverse + GetMem(lrPs,lnTests*sizeof(single)); + for lInc := 1 to lnTests do + lrPs^[lInc] := 1- Ps^[lnTests-lInc+1]; + //for lInc := 1 to lnTests do + // Ps[lInc] := lR[lnTests-lInc+1]; + + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lnegFDR05 := 0; + for lInc := 1 to lnTests do + if lrPs^[lInc] <= Qs^[lInc] then + lnegFDR05 := lrPs^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lnegFDR01 := 0; + for lInc := 1 to lnTests do + if lrPs^[lInc] <= Qs^[lInc] then + lnegFDR01 := lrPs^[lInc]; + FreeMem(lrPs); + Freemem(Qs); +end; + + +procedure AlertMsg (pWarningStr: String); +begin + ShowMsg(pWarningStr); +end; + +function gammln (xx: double): double; {Numerical Recipes for Pascal, p 177} + const + stp = 2.50662827465; + var + x, tmp, ser: double; +begin + x := xx - 1.0; + tmp := x + 5.5; + tmp := (x + 0.5) * ln(tmp) - tmp; + ser := 1.0 + 76.18009173 / (x + 1.0) - 86.50532033 / + (x + 2.0) + 24.01409822 / (x + 3.0) - 1.231739516 / (x + 4.0) + 0.120858003e-2 / (x + 5.0) - 0.536382e-5 / (x + 6.0); + gammln := tmp + ln(stp * ser) +end; {procedure gammln} + +FUNCTION betacf(a,b,x: double): double; +LABEL 1; +CONST + itmax=100; + eps=3.0e-7; +VAR + tem,qap,qam,qab,em,d: double; + bz,bpp,bp,bm,az,app: double; + am,aold,ap: double; + m: integer; +BEGIN + am := 1.0; + bm := 1.0; + az := 1.0; + qab := a+b; + qap := a+1.0; + qam := a-1.0; + bz := 1.0-qab*x/qap; + FOR m := 1 TO itmax DO BEGIN + em := m; + tem := em+em; + d := em*(b-m)*x/((qam+tem)*(a+tem)); + ap := az+d*am; + bp := bz+d*bm; + d := -(a+em)*(qab+em)*x/((a+tem)*(qap+tem)); + app := ap+d*az; + bpp := bp+d*bz; + aold := az; + am := ap/bpp; + bm := bp/bpp; + az := app/bpp; + bz := 1.0; + IF ((abs(az-aold)) < (eps*abs(az))) THEN GOTO 1 + END; + writeln('pause in BETACF'); + writeln('a or b too big, or itmax too small'); readln; +1: betacf := az +END; + + +FUNCTION betai(a,b,x: double): double; +VAR + bt: double; +BEGIN + IF ((x < 0.0) OR (x > 1.0)) THEN BEGIN + writeln('pause in routine BETAI'); readln + END; + IF ((x = 0.0) OR (x = 1.0)) THEN bt := 0.0 + ELSE bt := exp(gammln(a+b)-gammln(a)-gammln(b) + +a*ln(x)+b*ln(1.0-x)); + IF (x < ((a+1.0)/(a+b+2.0))) THEN + betai := bt*betacf(a,b,x)/a + ELSE betai := 1.0-bt*betacf(b,a,1.0-x)/b +END; + +procedure gser(var gamser, a,x, gln: real); +var n: integer; + sum, del, ap: real; +begin + gln := gammln(a); + if x <= 0.0 then begin + if x < 0.0 then AlertMsg('x less then 0 in routine GSER'); + gamser:= 0.0; + end else begin + ap := a; + sum := 1.0/a; + del := sum; + for n := 1 to ITMAX do begin + ap := ap + 1; + del := del * (x/ap); + sum := sum + del; + if (abs(del) < abs((sum)*EPS) )then begin + gamser := sum * exp(-x+a*ln(x)-gln); + exit; + end; + end; + Alertmsg('GSER error: ITMAX too small for requested a-value'); + end; +end; + +procedure gcf(var gammcf: real; a,x, gln: real); +var n: integer; + gold,fac,b1,b0,a0,g,ana,anf,an,a1: real; +begin + fac := 1.0; + b1 := 1.0; + b0 := 0.0; + a0 := 1.0; + gold := 0.0; + gln := gammln(a); + a1 := x; + for n := 1 to ITMAX do begin + an :=(n); + ana := an - a; + a0 := (a1 + a0*ana)*fac; + b0 := (b1 + b0*ana)*fac; + anf := an * fac; + a1 := x*a0+anf*a1; + b1 := x*b0+anf*b1; + if a1 <> 0 then begin + fac := 1.0/a1; + g := b1*fac; + if (abs((g-gold)/g)<EPS) then begin + gammcf := exp(-x+a*ln(x)-gln)*g; + exit; + end; + gold := g; + end; + end; + Alertmsg('GCF error: ITMAX too small for requested a-value'); +end; + +function gammq( a,x: real): real; + var gamser, gammcf, gln: real; +begin + gammq := 0; + if (x < 0) or (a <= 0.0) then alertmsg('Invalid arguments in routine GAMMQ') + else begin + if (x < (a+1.0)) then begin + gser(gamser,a,x,gln); + gammq := 1.0 - gamser; + end else begin + gcf(gammcf,a,x,gln); + gammq := gammcf; + end; + end; +end; + + +procedure Chi2x2 (A, B, C, D: integer; var pMinExp, pChi, p, puChi, pup: double); + {A= X hits, B= control hits, C = X misses, D = control misses} + var + lA, lB, lC, lD, lN: extended; {AEXp, BExp, CExp, Dexp, } + lSameOdds: boolean; + begin + lA := A; {convert to extended} + lB := B; + lC := C; + lD := D; + ln := lA + lB + lC + lD; + if lN > 0 then begin {avoid divide by 0} + pMinExp := ((lA + lB) * (lA + lC)) / lN; + if (((lA + lB) * (lB + lD)) / lN) < pMinExp then + pMinExp := ((lA + lB) * (lB + lD)) / lN; + if (((lC + lD) * (lA + lC)) / lN) < pMinExp then + pMinExp := ((lC + lD) * (lA + lC)) / lN; + if (((lC + lD) * (lB + lD)) / lN) < pMinExp then + pMinExp := ((lC + lD) * (lB + lD)) / lN; + end else + pMinExp := 0; + lSameOdds := false; + if (lC > 0) and (lD > 0) then begin + if (lA / lC) = (lB / lD) then + lSameOdds := true; + end; + if (lC = 0) and (lD = 0) then + lSameOdds := true; + if ((lA+lC) = 0) or ((lB+lD) = 0) then + lSameOdds := true; + if (lSameOdds = true) then begin + pChi := 0; {same odds} + p := 1.0; + puChi := 0; + pup := 1.0; + end else begin + puChi := ((sqr((lA * lD) - (lB * lC))) * lN) / ((la + lb) * (lc + ld) * (lb + ld) * (la + lc)); + pup := gammq(0.5, 0.5 * puChi); {half df} + pChi := ((sqr(abs((lA * lD) - (lB * lC)) - (0.5 * lN))) * lN) / ((la + lb) * (lc + ld) * (lb + ld) * (la + lc)); + p := gammq(0.5, 0.5 * pChi); + end; + end; + + +END. + \ No newline at end of file diff --git a/npm/statcr.ppu b/npm/statcr.ppu new file mode 100644 index 0000000..733bb00 Binary files /dev/null and b/npm/statcr.ppu differ diff --git a/npm/stats.o b/npm/stats.o new file mode 100644 index 0000000..006629b Binary files /dev/null and b/npm/stats.o differ diff --git a/npm/stats.pas b/npm/stats.pas new file mode 100755 index 0000000..28f96cc --- /dev/null +++ b/npm/stats.pas @@ -0,0 +1,1009 @@ +unit stats; + + +interface +uses define_types,statcr,DISTR +,SysUtils,Dialogsx; +procedure TStat2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +//procedure TStatAbs (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +procedure PairedTStat (lnSubj: integer; var lIn: DoubleP0; var lOutT: double); +procedure TStatWelch (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +procedure WilcoxonMW2 (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +procedure MeanMedian(lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lMeanFX,lMedianFX: double); +procedure TStat2Z (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +procedure BMTest (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +procedure Liebermeister2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutZ: double); +procedure Liebermeister2b (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lAUC,lOutZ: double); +procedure Liebermeister2bP (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lOutP: double); +//procedure Liebermeister2bPlus (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lAUC, lOutP: double); +//function Aprime (lHit,lFA: double): double; +//function AUC (lHit,lFA: double): double; +//function rocAUC (lHit,lFA: double): double; +function rocAUC (lnYesDeficitYesLesion,lnNoDeficitYesLesion,lnYesDeficitNoLesion,lnNoDeficitNoLesion: integer): double; + +procedure Chi2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutZ: double); + +implementation + +procedure Chi2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutZ: double); +var + lVal: double; + // luChiP: double; + i,lnYesDeficit1,lnYesDeficit0,lnNoDeficit1,lnNoDeficit0, + lnYesDeficit,lnNoDeficit: integer; +begin + lnYesDeficit0 := 0; + lnYesDeficit1 := 0; + lnNoDeficit0 := 0; + lnNoDeficit1 := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit0) + else + inc(lnNoDeficit0); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit1) + else + inc(lnNoDeficit1); + end; //for each sub + lnYesDeficit :=lnYesDeficit0+lnYesDeficit1; + lnNoDeficit := lnNoDeficit0+lnNoDeficit1; + if (lnYesDeficit<1) or (lnNoDeficit<1) then + lOutZ := 0 + else begin + lVal := Fisher(lnYesDeficit0, lnYesDeficit1, lnNoDeficit0, lnNoDeficit1); + if lVal < 0 then + lOutZ := -pNormalInv(abs(lVal)) + else + lOutZ := pNormalInv(lVal) + (*Chi2x2 (lnYesDeficit0, lnYesDeficit1, lnNoDeficit0, lnNoDeficit1,lMinExp,lChi,lChip,luChi, luChiP); + if (lnYesDeficit1/lnYesDeficit) > (lnNoDeficit1/lnNoDeficit) then + lOutZ := -luChi//t = m / d; + else + lOutZ := luChi;//t = m / d; *) + end; //compute chi +end; + +function rocAz (lHit,lFA: double): double; +//see Zhang and Mueller, 2005, Psychometrika 70, 145-154 +var + lH,lF: double; +begin + if (lHit = 1) and (lFA = 0) then begin + result := 1; + exit; + end; + if (lHit = 0) and (lFA = 1) then begin + result := 0; + exit; + end; + + if lHit >= lFA then begin//normal: better than chance + lH := lHit; + lF := lFA; + end else begin //..else worse than chance + lF := lHit; + lH := lFA; + + end; + if (lF <= 0.5) and (0.5 <= lH) then + result := 0.75+ ((lH-lF)*0.25)- lF*(1-lH) + else if (lF <= lH) and (lH < 0.5) then begin + if (4*lH) = 0 then + result := 0.5 + else + result := 0.75+ ((lH-lF)*0.25)- (lF/(4*lH)) + end else if (0.5 < lF) and (lF <= lH) then begin + if (4*(1-lF)) = 0 then + result := 0.5 + else + result := 0.75 + ((lH-lF)*0.25) - ((1-lH)/(4*(1-lF))) + end else + ShowMsg('error in Zhang and Mueller, 2005 (func rocA)'); + + if lHit < lFA then //worse than chance + result := 1 - result; +end; + +function rocAUC (lnYesDeficitYesLesion,lnNoDeficitYesLesion,lnYesDeficitNoLesion,lnNoDeficitNoLesion: integer): double; +var + lHitRate,lFalseAlarmRate: double; +begin + result := 0.5; + if ((lnYesDeficitYesLesion+lnNoDeficitYesLesion)=0) or ((lnYesDeficitNoLesion+lnNoDeficitNoLesion)=0) then + exit; + lHitRate := lnYesDeficitYesLesion/(lnYesDeficitYesLesion+lnNoDeficitYesLesion); + lFalseAlarmRate := lnYesDeficitNoLesion/(lnYesDeficitNoLesion+lnNoDeficitNoLesion); + result := rocAz(lHitRate,lFalseAlarmRate); +end; + +(*function Aprime (lHit,lFA: double): double; +//see Wickens Elementary Signal Detection, equation 4.11, page 71 +//problem - not symetrical: values less than 0.5 extreme - +// does not deal with lFA > lHit +begin + if (lFA=1) or (lHit = 0) then + result := 0.5 //avoid divide by zero + else + result := 1 - 0.25*( ((1-lHit)/(1-lFA)) + lFA/lHit); +end;*) + +(*function AUC (lHit,lFA: double): double; +var + lNum,lDenom: double; +begin + + if (lHit> lFA) then begin + lNum := (lHit-lFA)*(1+lHit-lFA); + lDenom := 4 * lHit * (1 - lFA); + if lDenom = 0 then + result := 0 + else + result := 0.5+ (lNum/lDenom); + end else begin + lNum := (lFA-lHit)*(1+lFA-lHit); + lDenom := 4 * lFA * (1 - lHit); + if lDenom = 0 then + result := 0 + else + result := 0.5- (lNum/lDenom); + end; +end; *) + +procedure ROCbinomialAUC (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lAUC: double); +//Receiver operating characteristic area under curve for binimial data +//Liebermeister QuasiExact - excellent power +var + i,lnYesDeficit1,lnYesDeficit0,lnNoDeficit1,lnNoDeficit0, + lnYesDeficit,lnNoDeficit: integer; + //lHitRate,lFalseAlarmRate: double; +begin + lnYesDeficit0 := 0; + lnYesDeficit1 := 0; + lnNoDeficit0 := 0; + lnNoDeficit1 := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit0) + else + inc(lnNoDeficit0); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit1) + else + inc(lnNoDeficit1); + end; //for each sub + lAUC := rocAUC (lnYesDeficit1,lnNoDeficit1,lnYesDeficit0,lnNoDeficit0); + (*lHitRate := lnYesDeficit1/(lnYesDeficit1+lnNoDeficit1); + lFalseAlarmRate := lnYesDeficit0/(lnYesDeficit0+lnNoDeficit0); + lAUC := rocA {AUC} (lHitRate,lFalseAlarmRate); *) +end; + +procedure Liebermeister2bP (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lOutP: double); +//Liebermeister QuasiExact - excellent power +var + i,lnYesDeficit1,lnYesDeficit0,lnNoDeficit1,lnNoDeficit0, + lnYesDeficit,lnNoDeficit: integer; + //lMaxChi,lMinChi: single; +begin + lnYesDeficit0 := 0; + lnYesDeficit1 := 0; + lnNoDeficit0 := 0; + lnNoDeficit1 := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit0) + else + inc(lnNoDeficit0); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit1) + else + inc(lnNoDeficit1); + end; //for each sub + lnYesDeficit :=lnYesDeficit0+lnYesDeficit1; + lnNoDeficit := lnNoDeficit0+lnNoDeficit1; + if (lnYesDeficit<1) or (lnNoDeficit<1) then + lOutP := 0 + else begin + lOutP := Liebermeister(lnYesDeficit0, lnYesDeficit1, lnNoDeficit0, lnNoDeficit1); + end; //compute chi +end; + + +procedure Liebermeister2b (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lAUC,lOutZ: double); +//(lnRow,lnCol: integer; var lIn,lOutZ: DoubleP0); +//Liebermeister QuasiExact - excellent power +var + lVal: double; + i,lnYesDeficitNoLesion,lnYesDeficitYesLesion,lnNoDeficitNoLesion,lnNoDeficitYesLesion, + lnYesDeficit,lnNoDeficit: integer; + //lHitRate,lFalseAlarmRate: double; + //lMaxChi,lMinChi: single; +begin + lnYesDeficitYesLesion := 0; + lnYesDeficitNoLesion := 0; + lnNoDeficitYesLesion := 0; + lnNoDeficitNoLesion := 0; + for i := 0 to (lnGroupX-1) do begin //for each lesioned subject + if lIn^[i] = 0 then + inc(lnYesDeficitYesLesion) + else + inc(lnNoDeficitYesLesion); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each unlesioned subject + if lIn^[i] = 0 then + inc(lnYesDeficitNoLesion) + else + inc(lnNoDeficitNoLesion); + end; //for each sub + lnYesDeficit :=lnYesDeficitYesLesion+lnYesDeficitNoLesion; + lnNoDeficit := lnNoDeficitYesLesion+lnNoDeficitNoLesion; + if (lnYesDeficit<1) or (lnNoDeficit<1) then + lOutZ := 0 + else begin + lVal := Liebermeister(lnYesDeficitYesLesion, lnYesDeficitNoLesion, lnNoDeficitYesLesion, lnNoDeficitNoLesion); + if lVal < 0 then + lOutZ := -pNormalInv(abs(lVal)) + else + lOutZ := pNormalInv(lVal) + end; //compute chi + lAUC := rocAUC (lnYesDeficitYesLesion,lnNoDeficitYesLesion,lnYesDeficitNoLesion,lnNoDeficitNoLesion); + {lFalseAlarmRate := lnYesDeficitNoLesion/(lnYesDeficitNoLesion+lnNoDeficitNoLesion); + lHitRate := lnYesDeficitYesLesion/(lnYesDeficitYesLesion+lnNoDeficitYesLesion); + lAUC := rocAz (lHitRate,lFalseAlarmRate); + } + //if lOutZ > 4 then ax(lnYesDeficitYesLesion,lnNoDeficitYesLesion,lnYesDeficitNoLesion,lnNoDeficitNoLesion,lauc,lOutZ); +end; + +procedure Liebermeister2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutZ: double); +//(lnRow,lnCol: integer; var lIn,lOutZ: DoubleP0); +//Liebermeister QuasiExact - excellent power +var + lVal: double; + i,lnYesDeficit1,lnYesDeficit0,lnNoDeficit1,lnNoDeficit0, + lnYesDeficit,lnNoDeficit: integer; + //lMaxChi,lMinChi: single; +begin + lnYesDeficit0 := 0; + lnYesDeficit1 := 0; + lnNoDeficit0 := 0; + lnNoDeficit1 := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit0) + else + inc(lnNoDeficit0); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit1) + else + inc(lnNoDeficit1); + end; //for each sub + lnYesDeficit :=lnYesDeficit0+lnYesDeficit1; + lnNoDeficit := lnNoDeficit0+lnNoDeficit1; + if (lnYesDeficit<1) or (lnNoDeficit<1) then + lOutZ := 0 + else begin + lVal := Liebermeister(lnYesDeficit0, lnYesDeficit1, lnNoDeficit0, lnNoDeficit1); + if lVal < 0 then + lOutZ := -pNormalInv(abs(lVal)) + else + lOutZ := pNormalInv(lVal) + end; //compute chi +end; + + + + + +procedure SortDouble (first, last: integer; var DynDataRA:DoubleP0; var lGroupRA: Bytep0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; + swapbyte: byte; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 0 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + swapbyte := lGroupRA^[i]; + lGroupRA^[i] := lGroupRA^[l]; + lGroupRA^[l] := swapbyte; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + +procedure RankArray (first, last: integer; var DynDataRA:DoubleP0; var lGSum: double); +var + lnTies,lPos,lStartPos,lRankPos: integer; + lScore,lTie : double; +begin + lGSum := 0; + lPos := first; + while lPos <= last do begin + lStartPos := lPos; + lScore := DynDataRA^[lPos]; + while (lPos < last) and (lScore = DynDataRA^[lPos+1]) do + inc(lPos); //count ties + lnTies := lPos - lStartPos; + lTie := (lnTies) *0.5; + if lnTies > 0 then begin + lnTies := lnTies+1;//tj on page 135 of Siegel + lGSum := lGSum + (( (lnTies*lnTies*lnTies) - lnTies)/12); + //showmessage(inttostr(lnTies)+' '+realtostr(lGSum,4)); + end; + for lRankPos := lStartPos to lPos do + DynDataRA^[lRankPos] := lStartPos+1+lTie; + inc(lPos);//start with next value + end; +end; + +function k_out_n (k,n: integer): double; //total possible permutations +//k= smaller group, n=sum of both groups +var + lVal: double; +begin + + if not gFactRAready then InitFact; + if (k < 1) or (n <0) then begin + result := 20000001; + ShowMsg('error k_out_n: k and n must be positive '+inttostr(n)+':'+inttostr(k)) + end else if (n > kMaxFact) or (k > kMaxFact) then + result := 20000001 + else begin + lVal := gFactRA[n] / (gFactRA[k]*gFactRA[n-k] ); + if lVal > 20000001 then + result := 20000001 + else + result := round(lVal); + //result := round(gFactRA[n] / (gFactRA[k]*gFactRA[n-k] ) ); + end; +// k out n = n!/(k!*(n-k)! which is equal to the PROD(i=k; 1){(n-i+1)/i} +end; //k_out_n +//http://www.fon.hum.uva.nl/rob/ +//# samples for which the sum of the ranks in the smaller sample is smaller than or +//# equal to a given upper bound W. +//# $W = the bound, $Sum = the sum of ranks upto now, $m-1 = one less than the +//# number of elements in the smaller sample that still have to be done, +//# $Start = the current position in the ranks list, *RankList = the array +//# with all the ranks (this is NOT just the numbers from 1 - N because of ties). +//# The list with ranks MUST be sorted in INCREASING order. +function CountSmallerRanks(var W,Sum: double; lm, Start,N: integer; var RankList: DoubleP0): integer; +var + Temp: double; + i, mminus1: integer; +begin + Temp:= 0; + result := 0; + if(Sum > W) then + exit; + //Check all subsets of the remaining of RankList + mminus1 := lm-1; + if(mminus1 > 0) then begin + for i := Start to (N-mminus1) do begin + Temp := Sum + RankList^[i]; + if(Temp > W) then + exit;// No smaller values expected anymore + result := result +CountSmallerRanks(W,Temp, mminus1, i+1, N, RankList); + end; + end else begin + //If even adding the highest rank doesn't reach $W, + //return the remaining number of items + if( (Sum + N + 1) <= W) then begin + result := N - Start + 1; + exit; + end; + for i := Start to N do begin + Temp := Sum + RankList^[i]; + if(Temp <= W) then + inc(result) + else // No smaller values expected anymore + exit; + end; //for + end; //m = 0 +end; + +procedure SortD (first, last: integer; var DynDataRA:DoubleP0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 1 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + +function Median (var lObs: DoubleP0; lnSubj: integer): double; +begin + SortD(0,lnSubj-1,lObs); + if odd(lnSubj) then + result := lObs^[lnSubj div 2] + else + result := 0.5* (lObs^[(lnSubj div 2)-1]+lObs^[lnSubj div 2]); +end; +(* getmem(lGroupRA,lnSubj*sizeof(Byte)); + createArray64(lObspX,lObsX,lnSubj); + ln0 := 0; + ln1 := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lObs[i] := lIn[i]; + if i < lnGroup0 then //group0 + lGroupRA[i] := 0 + else + lGroupRA[i] := 1; + end; //for each sub + for i := 0 to (lnSubj-1) do + if lGroupRA[i] = 0 then + inc(ln0) //number of observations in group zero + else + inc(ln1); //number of observations in group one + if (ln0 > 1) and (ln1 > 1) then begin + SortDouble(0,lnSubj-1,lObs,lGroupRA); + *) + +procedure MeanMedian(lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lMeanFX,lMedianFX: double); +//compute mean and median effect size +var + i: integer; + lMeanY,lMeanX,lMedianY,lMedianX: double; + lObsp: pointer; + lObs: Doublep0; + +begin + lMeanFX := 0; + lMedianFX := 0; + if (lnSubj=lnGroupX) or (lnSubj < 2) or (lnGroupX = 0) then + exit; //at least one empty group - no effect size + //next compute mean/median for groupX + lMeanX := 0; + createArray64(lObsp,lObs,lnSubj); + for i := 0 to (lnGroupX-1) do begin //for each subject + lMeanX := lMeanX + lIn^[i]; + lObs[i] := lIn[i]; + end; + lMeanX := lMeanX/lnGroupX; + lMedianX := Median (lObs,lnGroupX); + freemem(lObsp); + //next compute mean/median for groupY + lMeanY := 0; + createArray64(lObsp,lObs,(lnSubj-lnGroupX)); + for i := lnGroupX to (lnSubj-1) do begin //for each subject + lMeanY := lMeany + lIn^[i]; + lObs^[i-lnGroupX] := lIn^[i]; + end; + lMeanY := lMeanY/ (lnSubj-lnGroupX); + lMedianY := Median (lObs,(lnSubj-lnGroupX)); + freemem(lObsp); + //finally, compute effect sizes + lMeanFX := lMeanX-lMeanY; + lMedianFX := lMedianX-lMedianY; +end; + +procedure PairedTStat (lnSubj: integer; var lIn: DoubleP0; var lOutT: double); +//lIn has data for controls 1...n followed by 1..n paired measures. +//e.g. if three observations, 1x,2x,3x,1c,2c,3c +var + i,lnObs: integer; + lSqrSumDif,lSumDif,lSumDifSqr,lDF,lDif,lmeanDif,lVar: double; +begin + lOutT := 0; + if (odd(lnSubj)) or (lnSubj < 4) then + exit; //must have even number + lnObs := lnSubj shr 1; + lSumDif := 0; + lSumDifSqr := 0; + for i := 0 to (lnObs-1) do begin //for each subject + lDif := lIn^[i]-(lIn^[lnObs+i]) ; + lSumDif := lSumDif + lDif; + lSumDifSqr := lSumDifSqr + sqr(lDif); + end; + lDF := lnObs - 1; + + if (lSumDifSqr <> 0)and (lSumDif <> 0){and (lDF <> 0) and (lnObs <> 0)} then begin + lmeanDif := lSumDif / lnObs; + lSqrSumDif := sqr(lSumDif); + lVar := lSumDifSqr - (lSqrSumDif / lnObs); + lVar := lVar / (lnObs * lDF); + lVar := sqrt(lVar); + if lVar <> 0 then + lOutT := lmeanDif / lVar; + end; + +end; + +(*procedure ReportError (lnSubj, lnGroupX: integer; var lIn: DoubleP0; lS: double); +var + myFile : TextFile; + text : string; + i: integer; +begin + AssignFile(myFile, 'c:\Test666.txt'); + ReWrite(myFile); + WriteLn(myFile,'Subj = '+INTTOSTR(lnSubj)); + WriteLn(myFile,'Group1 = '+INTTOSTR(lnGroupX)); + WriteLn(myFile,'Var = '+FLOATTOSTR(lS)); + for i := 0 to (lnSubj-1) do + WriteLn(myFile,floattostr(lIn^[i])); + CloseFile(myFile); +end;*) + +procedure TStat2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +//pooled variance t-test http://www.okstate.edu/ag/agedcm4h/academic/aged5980a/5980/newpage26.htm +const + tiny = 1.0e-5; +var + i,lnGroupY: integer; + lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lS: double; +begin + lnGroupY := lnSubj - lnGroupX; + lOutT := 0; + if (lnGroupX < 1) or (lnGroupY < 1) or (lnSubj < 3) then //need at least 1 subj in each group + exit; + lSumx := 0; + lSumSqrX := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + //lVal := lIn[i]; + lsumx := lsumx + lIn^[i]; + lSumSqrX := lSumSqrX + sqr(lIn^[i]); + end; + lVarx := (lnGroupX*lSumSqrX) - Sqr(lsumx); + if lnGroupX > 1 then + lVarX := lVarX / (lnGroupX*(lnGroupX-1)) + else + lVarx := 0; + lSumy := 0; + lSumSqry := 0; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + lsumy := lsumy + lIn^[i]; + lSumSqry := lSumSqry + sqr(lIn^[i]); + end; //for each sub + //lMnY := lsumy/lnGroupY; + lVary := (lnGroupY*lSumSqrY) - Sqr(lsumy); + if lnGroupY > 1 then + lVary := lVary / (lnGroupY*(lnGroupY-1)) + else + lVary := 0; + //lm := (lsumx/lnGroupX)-(lsumy/lnGroupY); //mean effect size lmnx - lmny; + //ldf := lnSubj - 2; + ls := ( ((lnGroupX - 1) * lvarx + (lnGroupY - 1) * lvary) / (lnSubj - 2){ldf}) ; + if abs(ls) < tiny then + exit; + if ls < 0 then + ShowMsg('Error: t-test variance should not be zero.'); + //deepshit (lnSubj, lnGroupX, lIn,lS); + //if ls <= 0 then + // exit; xxx + ls := sqrt( ls) ; + ls := ls * sqrt(1 / lnGroupX + 1 / lnGroupY); //note - to get here both lnx and lny > 0 + if ls = 0 then + lOutT := 0 + else + lOutT := ( ((lsumx/lnGroupX)-(lsumy/lnGroupY))/ls);//t = lm / ls; +end; + +(*procedure TStatAbs (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +var + i,lnGroupY: integer; + lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lS: double; +begin + lnGroupY := lnSubj - lnGroupX; + if (lnGroupX < 1) or (lnGroupY < 1) then begin //need at least 1 subj in each group + lOutT := 0; + exit; + end; + lSumx := 0; + lSumSqrX := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + lsumx := lsumx + lIn[i]; + lSumSqrX := lSumSqrX + sqr(lIn[i]); + end; + lVarx := (lnGroupX*lSumSqrX) - Sqr(lsumx); + if lnGroupX > 1 then + lVarX := lVarX / (lnGroupX*(lnGroupX-1)) + else + lVarx := 0; + lSumy := 0; + lSumSqry := 0; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lsumy := lsumy + lIn[i]; + lSumSqry := lSumSqry + sqr(lIn[i]); + end; //for each sub + lVary := (lnGroupY*lSumSqrY) - Sqr(lsumy); + if lnGroupY > 1 then + lVary := lVary / (lnGroupY*(lnGroupY-1)) + else + lVary := 0; + ls := sqrt( ( ((lnGroupX - 1) * lvarx + (lnGroupY - 1) * lvary) / (lnSubj - 2)) ) ; + ls := ls * sqrt(1 / lnGroupX + 1 / lnGroupY); //note - to get here both lnx and lny > 0 + if ls = 0 then + lOutT := 0 + else + lOutT := ( ((lsumx/lnGroupX)-(lsumy/lnGroupY))/ls);//t = lm / ls; + //next - create direction map + if (abs(lOutT) >= 1.96) then begin + if abs (lsumx/lnGroupX) > abs(lsumy/lnGroupY) then + lOutT := 4 + else + lOutT := -4 + + end else + lOutT := 0; +end;*) + +procedure TStat2Z (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +var + i,lnGroupY: integer; + lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lS: double; +begin + lnGroupY := lnSubj - lnGroupX; + if (lnGroupX < 1) or (lnGroupY < 1) then begin //need at least 1 subj in each group + lOutT := 0; + exit; + end; + lSumx := 0; + lSumSqrX := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + //lVal := lIn[i]; + lsumx := lsumx + lIn^[i]; + lSumSqrX := lSumSqrX + sqr(lIn^[i]); + end; + lVarx := (lnGroupX*lSumSqrX) - Sqr(lsumx); + if lnGroupX > 1 then + lVarX := lVarX / (lnGroupX*(lnGroupX-1)) + else + lVarx := 0; + lSumy := 0; + lSumSqry := 0; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lsumy := lsumy + lIn^[i]; + lSumSqry := lSumSqry + sqr(lIn^[i]); + end; //for each sub + //lMnY := lsumy/lnGroupY; + lVary := (lnGroupY*lSumSqrY) - Sqr(lsumy); + if lnGroupY > 1 then + lVary := lVary / (lnGroupY*(lnGroupY-1)) + else + lVary := 0; + //lm := (lsumx/lnGroupX)-(lsumy/lnGroupY); //mean effect size lmnx - lmny; + //ldf := lnSubj - 2; + ls := sqrt( ( ((lnGroupX - 1) * lvarx + (lnGroupY - 1) * lvary) / (lnSubj - 2){ldf}) ) ; + ls := ls * sqrt(1 / lnGroupX + 1 / lnGroupY); //note - to get here both lnx and lny > 0 + if ls = 0 then + lOutT := 0 + else begin + lOutT := ( ((lsumx/lnGroupX)-(lsumy/lnGroupY))/ls);//t = lm / ls; + lOutT := TtoZ (lOutT,lnSubj-2); + //fx((lsumx/lnGroupX),(lsumy/lnGroupY)); + end; +end; + + + +procedure TStatWelch (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +//see R. D. DeVeaux 'The t -test: Some details' for details +//uses Welch's Test to protect against unequal variances +//uses true [often fractional] Degrees of Freedom +label + 129; +var + i,lNx,lNy: integer; + lVal,lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lMnX,lMnY,lM,lDF,lDenom,lZ,lT: double; +begin + lZ := 0; + lNx := 0; + lSumx := 0; + lSumSqrX := 0; + lNy := 0; + lSumy := 0; + lSumSqry := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + lVal := lIn^[i]; + if i < lnGroup0 then begin //group0 + inc(lNx); + lsumx := lsumx + lVal; + lSumSqrX := lSumSqrX + sqr(lVal); + end else begin //else group1 + inc(lNy); + lsumy := lsumy + lVal; + lSumSqry := lSumSqry + sqr(lVal); + end;//group1 + end; //for each sub + if (lNy < 2) or (lNx < 2) then + goto 129; //unable to calculate + lVarX := (lNx*lSumSqrX) - Sqr(lSumX); + lVarX := lVarX / (lNx*(lNx-1)); + lMnX := lSumX/lNx; + lVary := (lNy*lSumSqrY) - Sqr(lsumy); + lVary := lVary / (lNy*(lNy-1)); + lMnY := lSumY/lNy; + lm := lMnX - lMnY; //difference between means = t-Numerator + if (lm = 0) {or (lVarY=0) or (lVarX = 0)} then + goto 129; //no difference in proportions - do not waste time computing DF + //next compute true Degrees of Freedom + lDF := sqr( (lVarX/lNx)+(lVarY/lNy)); + //lDF := lDF /( ((Sqr(lVarX/lNx)) / (lnx-1) ) + ((Sqr(lVarY/lNy)) / (lny-1) ) ); + if (lVarX=0) or (lVarY=0) then begin //forced to estimate based on pooled variance + lDF := lnx+lny -2; + lDenom:= ( ((lnx - 1) * lvarx + (lny - 1) * lvary) / (lNx+lNy-2)); + lDenom := sqrt(lDenom / lnx + lDenom / lny); + end else begin + lDF := lDF /( ((Sqr(lVarX/lNx)) / (lnx-1) ) + ((Sqr(lVarY/lNy)) / (lny-1) ) ); + lDenom := sqrt(lVarX/lNx + lVary/lNy);//assume Unequal variances "Welch's Test" + end; + if lDenom = 0 then + goto 129; + lT := ( lm/lDenom);//t = m / d; + lZ := TtoZ(lT,lDF); //az + //lP := pNormal(TtoZ(lT,lDF)); + 129: + lOutT := lZ; + //vlsm compatible = lOutT[lColX] := ( lm/lD);//t = m / d; +end; + +FUNCTION specialdouble (d:double): boolean; +//returns true if s is Infinity, NAN or Indeterminate +//8byte IEEE: msb[63] = signbit, bits[52-62] exponent, bits[0..51] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +CONST kSpecialExponent = 2047 shl 20; +VAR Overlay: ARRAY[1..2] OF LongInt ABSOLUTE d; +BEGIN + IF ((Overlay[2] AND kSpecialExponent) = kSpecialExponent) THEN + RESULT := true + ELSE + RESULT := false; +END; + +procedure LocalRank (first, last: integer; var DynDataRA,DynDataRAX:DoubleP0; var lGroupRA: Bytep0); +var + lGroup,lnTies,lPos,lStartPos,lRankPos,lLocalRank: integer; + lScore,lTie : double; +begin + for lGroup := 0 to 1 do begin + lPos := first; + lLocalRank := 0; + while lPos <= last do begin + if lGroupRA^[lPos] = lGroup then begin// + inc(lLocalRank); + lStartPos := lPos; + lScore := DynDataRA^[lPos]; + lnTies := 0; + while (lPos < last) and (0.001 > abs (lScore - DynDataRA^[lPos+1]) ) do begin + inc(lPos); //count ties + if lGroupRA^[lPos] = lGroup then + inc(lnTies); + end; + lTie := (lnTies) *0.5; + for lRankPos := lStartPos to lPos do begin + if lGroupRA^[lRankPos] = lGroup then + DynDataRAX^[lRankPos] := (lLocalRank+lTie); + end; + lLocalRank := lLocalRank + lnTies; + end; //if in group + inc(lPos);//start with next value + end; //while... for each observation + end; //for each group +end; + +procedure BMTest (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +//procedure BMtest (lnRow,lnCol: integer; var lIn,lOutT: DoubleP0); +var + lObspX,lObsp: pointer; + lObsX,lObs: Doublep0; + lGroupRA: Bytep0; + i,ln0,ln1,lColX: integer; + lDF,lZ,lGSum: double; + lSum0,lSum1,lMean0,lMean1,lSqr0,lSqr1,lk0,lk1: double; +begin + createArray64(lObsp,lObs,lnSubj); + getmem(lGroupRA,lnSubj*sizeof(Byte)); + createArray64(lObspX,lObsX,lnSubj); + ln0 := 0; + ln1 := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lObs^[i] := lIn^[i]; + if i < lnGroup0 then //group0 + lGroupRA^[i] := 0 + else + lGroupRA^[i] := 1; + end; //for each sub + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + inc(ln0) //number of observations in group zero + else + inc(ln1); //number of observations in group one + if (ln0 > 1) and (ln1 > 1) then begin + SortDouble(0,lnSubj-1,lObs,lGroupRA); + RankArray(0,lnSubj-1,lObs,lGSum); + lSum0 := 0; + lSum1 := 0; + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lSum0 := lSum0 + lObs^[i] + else + lSum1 := lSum1 + lObs^[i]; + lMean0 := lSum0 / ln0; + lMean1 := lSum1 / ln1; + //fx(lmean0,lMean1); + lSqr0 := 0; + lSqr1 := 1; + lk0 := (ln0+1)/2; + lk1 := (ln1+1)/2; + LocalRank(0,lnSubj-1,lObs,lObsX,lGroupRA); + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lSqr0 := lSqr0 + Sqr(lObs^[i]-lObsX^[i]-lMean0+lk0) + else + lSqr1 := lSqr1 + Sqr(lObs^[i]-lObsX^[i]-lMean1+lk1); + lSqr0 := (1/(ln0-1))*lSqr0; + lSqr1 := (1/(ln1-1))*lSqr1; + + lZ := -(ln0*ln1*(lMean1-lMean0))/((ln0+ln1)*sqrt((ln0*lSqr0)+(ln1*lSqr1) ) ); + lDF := sqr(ln0*lSqr0+ln1*lSqr1) / ( (sqr(ln0*lSqr0)/(ln0-1)) + (sqr(ln1*lSqr1)/(ln1-1)) ) ; + lZ := TtoZ(lZ,lDF); //az + lOutT := lZ; + //fx(lZ,lDF); + end else //>1 + lOutT := 0; + freemem(lObsp); + freemem(lObspX); + freemem(lGroupRA); +end; //bmtest + + +procedure WilcoxonMW2 (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +var + lObsp: pointer; + lObs: Doublep0; + lGroupRA: Bytep0; + m,n,i,ln0,ln1,mplusn: integer; + lPermutations,lVal,lWsmalln,lZ,lZi,lTail,lGSum,lWTotal,lH0,lSum: double; + +begin + createArray64(lObsp,lObs,lnSubj); + getmem(lGroupRA,lnSubj*sizeof(Byte)); + ln0 := 0; + ln1 := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lObs[i] := lIn[i]; + if i < lnGroup0 then //group0 + lGroupRA^[i] := 0 + else + lGroupRA^[i] := 1; + end; //for each sub + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + inc(ln0) //number of observations in group zero + else + inc(ln1); //number of observations in group one + SortDouble(0,lnSubj-1,lObs,lGroupRA); + RankArray(0,lnSubj-1,lObs,lGSum); + + lWsmalln := 0; + if ln1 < ln0 then begin //Group1 smaller than Group0 + m := ln1; + n := ln0; + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 1 then + lWsmalln := lWsmalln + lObs^[i]; + end else begin//Group0 smaller than Group1 + m := ln0; + n := ln1; + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lWsmalln := lWsmalln + lObs^[i]; + end; + mplusn := m + n; + lZ := 0; + if lWsmalln > (mplusn*(mplusn+1)/4) then + lTail := -0.5 + else + lTail := 0.5; + if m < 1 then + lZ := 0 + else if lGSum = 0 then begin //no ties + lZ := ( lWsmalln + lTail - m * ( m + n + 1 ) / 2 ) / sqrt( m * n * ( m + n + 1 ) / 12 ); + end else begin //correct for ties, see Siegel page 135 + if ((12-lGSum)<>0) and (((lnSubj*(lnSubj-1)) * (((lnSubj*lnSubj*lnSubj) -lnSubj) /12-lGSum))<> 0) then begin + lZ := lWsmalln + lTail - (m * ( lnSubj + 1 ) / 2 ); + lZ := lZ/sqrt ( (m*n)/ (lnSubj*(lnSubj-1)) * (((lnSubj*lnSubj*lnSubj) -lnSubj) /12-lGSum)); + end else begin + lZ := ( lWsmalln + lTail - m * ( m + n + 1 ) / 2 ) / sqrt( m * n * ( m + n + 1 ) / 12 ); + end; + end; + {if lStr = '' then begin + for i := 0 to (lnSubj-1) do + lStr := lStr+inttostr(lGroupRA[i])+', '+floattostr( lObs[i])+';'; + lStr := ('w'+floattostr(lWsmalln)+'Z'+floattostr(lZ)+'ties'+floattostr(lgSum)+'m'+inttostr(m)+'n'+inttostr(n)+':'+lStr); + end; } + if m < 10 then + lPermutations := k_out_n(m,mplusn); + if (m < 10) and (lPermutations < 20000000) and (abs(lZ) > 1) {}then begin + lWTotal :=mplusn*(mplusn+1)/2; //sum ranks for both groups m and n + lH0 := lWTotal * (m/mplusn); //null hypothesis + lSum := 0; + //next - use smallest value of W + if lWSmallN > lH0 then begin + lWSmallN := lH0 - (lWSmallN-lH0); + //Due to ties, we need to flip the order as well, as we are searching smaller + for i := 0 to (lnSubj-1) do + lObs^[i] := (lnSubj+1)-lObs^[i]; + for i := 0 to ((lnSubj-2) div 2) do begin //swap + lVal := lObs^[i]; + lObs^[i] := lObs^[lnSubj-1-i]; + lObs^[lnSubj-1-i] := lVal; + end; + end; + lVal := CountSmallerRanks(lWSmallN, lSum, m, 0,(mplusn-1), lObs); + lZi := lZ; + lZ :=pNormalInvQuickApprox(lVal/lPermutations); + if ((lZ > 0) and (lZi < -1)) or ((lZ < 0) and (lZi > 1)) then + lZ := -lZ; + end; + if ln1 < ln0 then //we computed unexpected tail + lOutT := -lZ + else + lOutT := lZ;//t = m / d; + freemem(lObsp); + freemem(lGroupRA); +end; + + + +end. + \ No newline at end of file diff --git a/npm/stats.ppu b/npm/stats.ppu new file mode 100644 index 0000000..f20406c Binary files /dev/null and b/npm/stats.ppu differ diff --git a/npm/tfce_clustering.7z b/npm/tfce_clustering.7z new file mode 100755 index 0000000..0287bcc Binary files /dev/null and b/npm/tfce_clustering.7z differ diff --git a/npm/tfce_clustering.o b/npm/tfce_clustering.o new file mode 100644 index 0000000..82087b8 Binary files /dev/null and b/npm/tfce_clustering.o differ diff --git a/npm/tfce_clustering.pas b/npm/tfce_clustering.pas new file mode 100755 index 0000000..aa3c4fa --- /dev/null +++ b/npm/tfce_clustering.pas @@ -0,0 +1,273 @@ +unit tfce_clustering; +//USED by stats to select only regions with a given number of connected/contiguous voxels +{$IFDEF FPC} {$mode delphi}{$H+} {$ENDIF} +{$Include ..\common\isgui.inc} +interface +uses +{$IFNDEF UNIX} Windows, + {$ELSE} + {$IFDEF GUI} LCLType, LCLintf,{$ENDIF} + {$ENDIF} +define_types,dialogsx,SysUtils,nifti_hdr,nifti_img, math,unpm, nifti_types; + +//procedure FindClusters (lMultiBuf: SingleP; lXdim, lYDim, lZDim, lThreshClusterSz: integer; lMinNeg, lMinPos: single); + +//function ClusterTFCE (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double ): boolean; + +function doTFCE (var lHdr: TNIFTIhdr; lImg: SingleP; NumConn: integer; H, E, minT, deltaT: single ): boolean; +//mimics FSL's function "TFCE" in newimagefns.h + +function doTFCEbothPolarities (var lHdr: TNIFTIhdr; lImg: SingleP; NumConn: integer; H, E, minT, deltaT, minNegT, NegdeltaT: single; var maxTFCE, maxNegTFCE: single): boolean; +//both polarities computes TFCE for both positive and negative values + +implementation + + +procedure countClusterSize (lX,lY,lZ, lnumConnIn: integer; var lClusterBuff: LongIntP); +//input CountImg is volume X*Y*Z where voxels are either 0 or 1 +// output: CountImg voxels report number of connected neighbors +const + lClusterSign = 1; //input CountImg has this value set to 1 + lClusterFillValue = -1; //impossible cluster size - used to denote actively growing cluster +var + lQHead,lV,lXY, lXYZ,lClusterSz, lQTail,lnumConn,lI,lNeighbor: integer; + lQra: LongIntP; + ConnOffset : ARRAY [1..26] of integer; +procedure InitConn; +begin + //first 6 share face + ConnOffset[1] := -1;//L + ConnOffset[2] := 1; //R + ConnOffset[3] := -lX; //A + ConnOffset[4] := lX; //P + ConnOffset[5] := -lXY;//I + ConnOffset[6] := lXY;//S + if lnumConnIn < 7 then begin + lnumConn := 6; + exit; + end; + //share edge + //..check plane above + ConnOffset[7] := (lXY-1); //left + ConnOffset[8] := (lXY+1); //right + ConnOffset[9] := (lXY-lX); //up + ConnOffset[10] := (lXY+lX); //down + //..check plane below + ConnOffset[11] := (-lXY-1); //left + ConnOffset[12] := (-lXY+1); //right + ConnOffset[13] := (-lXY-lX); //up + ConnOffset[14] := (-lXY+lX); //down + //..check diagonals of current plane + ConnOffset[15] := (-lX-1); //up, left + ConnOffset[16] := (-lX+1); //up, right + ConnOffset[17] := (+lX-1); //down, left + ConnOffset[18] := (+lX+1); //down, right + if lnumConnIn < 19 then begin + lnumConn := 18; + exit; + end; + //share corner + //..check plane above + ConnOffset[19] := (lXY-1-lX); //left + ConnOffset[20] := (lXY-1+lX); //right + ConnOffset[21] := (lXY+1-lX); //up + ConnOffset[22] := (lXY+1+lX); //down + //..check plane BELOW + ConnOffset[23] := (-lXY-1-lX); //left + ConnOffset[24] := (-lXY-1+lX); //right + ConnOffset[25] := (-lXY+1-lX); //up + ConnOffset[26] := (-lXY+1+lX); //down + lnumConn := 26; +end; //InitConn +begin + lXY := lX * lY; + lXYZ := lX*lY*lZ; + InitConn; + if lXYZ < 1 then exit; + GetMem(lQra,lXYZ * sizeof(longint) ); + //check every voxel to see if it is isolated + for lV := 1 to lXYZ do begin + if (lClusterBuff^[lV]=lClusterSign) then begin //new cluster detected + lClusterSz := 1; + lQHead := 1; + lQTail := 1; + lQra^[lQTail] := lV; + lClusterBuff^[lV] := lClusterFillValue; + while (lQHead >= lQTail) do begin + //RetirePixel: lQTail incremented once, lQHead is incremented 0..nummConn + for lI := 1 to lnumConn do begin + lNeighbor := lQra^[lQTail]+ConnOffset[lI]; + if (lClusterBuff^[lNeighbor]=lClusterSign) then begin//add item + inc(lQHead); + inc(lClusterSz); + lClusterBuff^[lNeighbor] := lClusterFillValue; + lQra^[lQHead] := lNeighbor; + end; //if new item detected + end; //for each connector + inc(lQTail); //done with this pixel + end; //while items in Queue + for lI := lV to lXYZ do + if (lClusterBuff^[lI]=lClusterFillValue) then + lClusterBuff^[lI] := lClusterSz; + end; //new item found + end; //for each voxel + freemem(lQra); +end; + +procedure ZeroFaces (var lHdr: TNIFTIhdr; lImg: SingleP ); +var + lV,lX,lY,lZ,lZi,lYi,lXi: integer; +begin + lX := lHdr.Dim[1]; + lY := lHdr.Dim[2]; + lZ := lHdr.Dim[3]; + if (lX < 3) or (lY < 3) or (lZ < 3) then exit; + for lV := 1 to (lX*lY) do lImg[lV] := 0; //bottom slice + for lV := ((lX*lY*lZ)-(lX*lY)) to (lX*lY*lZ) do lImg[lV] := 0; //top slice + //left side + lV := 1; + for lZi := 1 to lZ do begin + for lYi := 1 to lY do begin + lImg[lV] := 0; + lV := lV+lX; + end; + end; + //right side + lV := lX; + for lZi := 1 to lZ do begin + for lYi := 1 to lY do begin + lImg[lV] := 0; + lV := lV+lX; + end; + end; + //anterior + for lZi := 1 to lZ do begin + lV := (lZi-1) * lX*lY; + for lXi := 1 to lX do begin + lV := lV+1; + lImg[lV] := 0; + end; + end; + //posterior + for lZi := 1 to lZ do begin + lV := (lZi-1) * lX*lY; + lV := lV + ((lY-1) *lX); + for lXi := 1 to lX do begin + lV := lV+1; + lImg[lV] := 0; + end; + end; +end; + + +function doTFCEbothPolarities (var lHdr: TNIFTIhdr; lImg: SingleP; NumConn: integer; H, E, minT, deltaT, minNegT, NegdeltaT: single; var maxTFCE, maxNegTFCE: single): boolean; +var + lV,lXYZ,lX,lY,lZ: integer; + + lNegImg: SingleP; + +begin + result := false; + lX := lHdr.Dim[1]; + lY := lHdr.Dim[2]; + lZ := lHdr.Dim[3]; + lXYZ := lX*lY*lZ; + if lXYZ < 1 then exit; + getmem(lNegImg,lXYZ*sizeof(single)); + for lV := 1 to lXYZ do + lNegImg[lV] := -lImg[lV]; + + + doTFCE (lHdr, lImg, NumConn, H, E, minT, deltaT); + maxTFCE :=lImg[lV]; + for lV := 1 to lXYZ do + if (maxTFCE < lImg[lV]) then + maxTFCE:= lImg[lV]; + + + doTFCE (lHdr, lNegImg, NumConn, H, E, abs(minNegT), abs(NegdeltaT)); + maxNegTFCE :=lImg[lV]; + for lV := 1 to lXYZ do + if (maxNegTFCE < lNegImg[lV]) then + maxNegTFCE:= lNegImg[lV]; + maxNegTFCE := -maxNegTFCE; + + for lV := 1 to lXYZ do begin + if (lNegImg[lV] > 0) then + lImg[lV] := -lNegImg[lV]; + end; + + freemem(lNegImg); +end; + + + +function doTFCE (var lHdr: TNIFTIhdr; lImg: SingleP; NumConn: integer; H, E, minT, deltaT: single ): boolean; +const + kSteps = 100; +label + 777; +var + lV,lXYZ,lX,lY,lZ: integer; + maxval, lThresh, ThreshPowerHxdh, dh: single; + lThreshImg: SingleP; + lCountImg: LongIntP; + lStartTime: DWord; +begin + lX := lHdr.Dim[1]; + lY := lHdr.Dim[2]; + lZ := lHdr.Dim[3]; + {$IFDEF GUI} lStartTime := GetTickCount; {$ENDIF} + result := false;//assume failure + lXYZ := lX*lY*lZ; + if lXYZ < 1 then exit; + //E := 0.5; //0.5 + //H := 2;//2 + getmem(lThreshImg,lXYZ*sizeof(single)); + getmem(lCountImg,lXYZ*sizeof(longint)); + ZeroFaces (lHdr, lImg ); + maxval := lImg[1]; + for lV := 1 to lXYZ do begin + lThreshImg[lV] := lImg[lV]; + if lImg[lV] > maxval then maxval := lImg[lV]; + lImg[lV] := 0; //initialize sum map to zero + end; + + if (maxval <= 0) then goto 777; + if (maxval < minT) then goto 777; + if (deltaT = 0) then + dh := (maxval-minT) / kSteps + else + dh := deltaT; + NPMmsg('max = '+floattostr(maxval)+' deltaT = '+floattostr(dh)); + lThresh := minT+dh; + while lThresh < maxval do begin + + + for lV := 1 to lXYZ do begin + if (lThreshImg[lV] <= lThresh) then + lCountImg[lV] := 0 + else + lCountImg[lV] := 1; + end; + countClusterSize (lX,lY,lZ,NumConn, lCountImg); + ThreshPowerHxdh := power(lThresh,H)*dh; + for lV := 1 to lXYZ do + if (lCountImg[lV] > 0) then + lImg[lV] := lImg[lV] + (exp(E*ln(lCountImg[lV])) * ThreshPowerHxdh); //faster than power + (*for lV := 1 to lXYZ do + if (lCountImg[lV] > 0) then + lImg[lV] := lImg[lV] + (power(lCountImg[lV],E) * ThreshPowerHxdh); *) + lThresh := lThresh + dh; + end; +777: + {$IFDEF GUI} NPMmsg('Time = '+inttostr(GetTickCount - lStartTime)); {$ENDIF} + freemem(lCountImg); + freemem(lThreshImg); + result := true; //report success! +end; + + + + +end. \ No newline at end of file diff --git a/npm/tfce_clustering.ppu b/npm/tfce_clustering.ppu new file mode 100644 index 0000000..2d7866b Binary files /dev/null and b/npm/tfce_clustering.ppu differ diff --git a/npm/tfce_clustering.zip b/npm/tfce_clustering.zip new file mode 100755 index 0000000..c22aed6 Binary files /dev/null and b/npm/tfce_clustering.zip differ diff --git a/npm/turbolesion.o b/npm/turbolesion.o new file mode 100644 index 0000000..956ff72 Binary files /dev/null and b/npm/turbolesion.o differ diff --git a/npm/turbolesion.pas b/npm/turbolesion.pas new file mode 100755 index 0000000..42a7c3a --- /dev/null +++ b/npm/turbolesion.pas @@ -0,0 +1,512 @@ +unit turbolesion; +interface +{$H+} +{$Include ..\common\isgui.inc} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, nifti_types, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, unpm, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +Type + TLDMPrefs = record + NULP,BMtest,Ttest,Ltest: boolean; + CritPct,nCrit,nPermute,Run: integer; + ValFilename, OutName, ExplicitMaskName: string; + end; +function TurboLDM (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var lPrefs: TLDMPrefs ; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; + + + +implementation + +{$IFDEF GUI} + uses npmform; +{$ELSE} + // uses npmcl; +{$ENDIF} + +(*procedure Debog (var lSumImg: Smallintp; lVox: integer); +var + lInName : string; + lFData: file; +begin + lInName := 'c:\16.img'; + assignfile(lFdata,lInName); + filemode := 2; + Rewrite(lFdata,lVox*sizeof(smallint)); + BlockWrite(lFdata,lSumImg^, 1 {, NumWritten}); + closefile(lFdata); +end;*) + +function MakeSum (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var lSumImg: Smallintp): boolean; +//if successful, you MUST freemem(lSumImg)... +label + 667; +var + lVolVox,lVox,lImg,lPosPct: integer; + lVolImg: byteP; + +begin + result := false; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lVolImg,lVolVox* sizeof(byte)); + getmem(lSumImg,lVolVox* sizeof(smallint)); + for lVox := 1 to lVolVox do //June 2009 init array + lSumImg^[lVox] := 0; +(* for lVox := 1 to lVolVox do + if lVolImg^[lVox] <> 0 then + lSumImg^[lVox] := lSumImg^[lVox]+1;*) + for lImg := 1 to lImages.Count do begin + lPosPct := round(100*(lImg / lImages.Count)); + NPMProgressBar( lPosPct); + Application.Processmessages; + if not LoadImg8(lImages[lImg-1], lVolImg, 1, lVolVox,round(gOffsetRA[lImg]),1,gDataTypeRA[lImg],lVolVox) then + goto 667; + for lVox := 1 to lVolVox do + if lVolImg^[lVox] <> 0 then + lSumImg^[lVox] := lSumImg^[lVox]+1; + end;//for each image + NPMmsg('Sum image finished = ' +TimeToStr(Now)); + NPMProgressBar(0); + //Debog(lSumImg, lVolVox); + freemem(lVolImg); + result := true; + exit; +667: //you only get here if you aborted ... free memory and report error + freemem(lVolImg); + freemem(lSumImg); + NPMMsg('Unable to complete analysis.'); + NPMProgressBar(0); +end; + + +function ThreshSumImg (var lSumImg: Smallintp; lVolVox,lThresh: integer): integer; +//sets all voxels with values < lThresh to zero, returns number of voxels to survive threshold. +var + lPos: integer; +begin + result := 0; + if lVolVox < 1 then + exit; + for lPos := 1 to lVolVox do + if lSumImg^[lPos] < lThresh then + lSumImg^[lPos] := 0 + else + inc(result); +end; + +function ExplicitMaskSumImg (lMaskName: string; var lSumImg: Smallintp; lVolVox: integer): integer; +//Any voxels in MaskImg that are 0 are zeroed in the SumImg +var + lOK: boolean; + lPos: integer; + lMaskHdr: TMRIcroHdr; + lMaskData: bytep; +label + 666; +begin + result := 0; + if (lVolVox < 1) or (not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr)) then begin + NPMmsg('Error: unable to load explicit mask named '+lMaskName); + exit; + end; + if lVolVox <> (lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]) then begin + NPMmsg('Error: data and explicit mask have different sizes '+lMaskName); + exit; + end; + + getmem(lMaskData,lVolVox* sizeof(byte)); + lOK := LoadImg8(lMaskName, lMaskData, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.DataType,lVolVox); + if not lOK then goto 666; + if lVolVox < 1 then + exit; + for lPos := 1 to lVolVox do + if lMaskData^[lPos] < 1 then + lSumImg^[lPos] := 0 + else + inc(result); + 666: + freemem(lMaskData); +end; + +function LoadImg8Masked(lInName: string; lImgData: bytep; lMaskData: SmallIntP; lStartMaskPos, lEndMaskPos,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +label + 111; +var + lFullImgData: bytep; + lMaskPos,lPos: integer; +begin + result := false; + if (lVolVox < 1) or (lEndMaskPos < lStartMaskPos) then + exit; + getmem(lFullImgData,lVolVox* sizeof(byte)); + result := LoadImg8(lInName, lFullImgData, 1, lVolVox,linvox_offset,1,lDataType,lVolVox); + if result then begin + lMaskPos := 0; + for lPos := 1 to lVolVox do begin + if lMaskData^[lPos] <> 0 then begin + inc(lMaskPos); + if (lMaskPos >=lStartMaskPos) then + lImgData^[lRApos+lMaskPos-1] := lFullImgData^[lPos]; + if lMaskPos = lEndMaskPos then goto 111; + + end;//voxel in mask + end; //for each voxel in image + + end;//if LoadImg8 success +111: + freemem(lFullImgData); +end; + +function reformat(var lStatImg: singlep; lMaskImg: smallintp; lVolVox: integer): boolean; +var + lPos,lStatPos,lMaskItems: integer; +begin + result := false; + if lVolVox < 1 then + exit; + lMaskItems := 0; + for lPos := 1 to lVolVox do + if lMaskImg^[lPos] <> 0 then + inc(lMaskItems); + result := true; + if (lMaskItems < 1) or (lMaskItems >= lVolVox) then + exit;//no need to reformat + //note that we do this in descending order, so we do not overwrite... + lStatPos := lMaskItems; + for lPos := lVolVox downto 1 do + if lMaskImg^[lPos] <> 0 then begin + lStatImg^[lPos] := lStatImg^[lStatPos]; + dec(lStatPos); + end else + lStatImg^[lPos] := 0; +end;//reformat + + +function NULPcount (lPlankImg: bytep; lVoxPerPlank,lImagesCount,lnCrit: integer; var lUniqueOrders: integer; var lOverlapRA: Overlapp): boolean; +procedure CheckOrder(var lObservedOrder: TLesionPattern); +var + lInc: integer; +begin + if lUniqueOrders > 0 then begin //see if this is unique + for lInc := lUniqueOrders downto 1 do //check most recent patterns first + if SameOrder(lObservedOrder,lOverlapRA^[lInc],lImagesCount) then + exit; //not unique + end; //UniqueOrders > 0 + //if we have not exited yet, we have found a new ordering! + lUniqueOrders := lUniqueOrders + 1; + lOverlapRA^[lUniqueOrders] := lObservedOrder; +end; + +var + lVox,lPlankImgPos,lPos,lnLesion: integer; + lOrder,lPrevOrder: TLesionPattern; +begin + result := false; + if lImagesCount > kMaxObs then begin + NPMmsg('Warning: unable to count unique lesion patterns for so many participants'); + exit; + end; + if lImagesCount > 64 then + NPMMsg('Counting unique lesion patterns - this may take a while (edit preferences to skip this step)'); + Application.Processmessages; + NPMProgressBar(0); //this forces a refresh for GUI applications + Sleep(30); + + lPrevOrder := EmptyOrder;//impossible: forces first voxel of each order to be checked + for lVox := 1 to lVoxPerPlank do begin + (*if (lVox mod lVoxPerPlankDiv10) = 0 then begin + MainForm.ProgressBar1.Position := (lVox div lVoxPerPlankDiv10)*10; + MainForm.Refresh; + Application.processmessages; + end;*) + lOrder := EmptyOrder; + lnLesion := 0; + lPlankImgPos := 0; + //lnDeficits := 0; + for lPos := 1 to lImagesCount do begin + if (lPlankImg^[lPlankImgPos + lVox] > 0) then begin + inc(lnLesion); + SetBit(lPos,lOrder); + end; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end; + if (lnLesion >= lnCrit) then begin //statistics computed - more than nCrit injured + if (not SameOrder(lOrder,lPrevOrder,lImagesCount)) then + CheckOrder(lOrder); + //inc(lnVoxels); + end;//lnLesion + lPrevOrder := lOrder; + end;//for lVox + result := true; +end; + +procedure PtoZpermute (lnPermute: integer; lPermuteMaxT, lPermuteMinT: singlep); +var + lPos: integer; + lVal : single; +begin + if lPos < 1 then exit; + for lPos := 1 to lnPermute do begin + if (lPermuteMinT^[lPos] > 1.1) or (lPermuteMinT^[lPos] < -1.1) then + lPermuteMinT^[lPos] := 0.5; + if (lPermuteMaxT^[lPos] > 1.1) or (lPermuteMaxT^[lPos] < -1.1) then + lPermuteMaxT^[lPos] := 0.5; + lVal := lPermuteMaxT^[lPos]; + lPermuteMaxT^[lPos] := lPermuteMinT^[lPos]; + lPermuteMinT^[lPos] := lVal; + if lPermuteMaxT^[lPos] < 0 then + lPermuteMaxT^[lPos] := -pNormalInv(abs(lPermuteMaxT^[lPos])) + else + lPermuteMaxT^[lPos] := pNormalInv(lPermuteMaxT^[lPos]); + if lPermuteMinT^[lPos] < 0 then + lPermuteMinT^[lPos] := -pNormalInv(abs(lPermuteMinT^[lPos])) + else + lPermuteMinT^[lPos] := pNormalInv(lPermuteMinT^[lPos]); + end; +end; + + +function TurboLDM (var lImages: TStrings; var lMaskHdr: TMRIcroHdr;var lPrefs: TLDMPrefs ; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lNULPcalculated: boolean; + lStatHdr: TNIfTIhdr; + lThreshFDR,lThreshPermute,lThreshBonf,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC: singlep; + lSumImg: Smallintp; + lPlankImg: byteP; + lVoxPerPlank,lnPlanks,lTotalMemory,lnVoxTested,lVolVox: int64; + lUniqueOrders,lThread,lThreadStart,lThreadInc,lThreadEnd, + lPos2,lPosPct,lPos,lPlankImgPos,lPlank,lStartVox,lEndVox: integer; + lOverlapRA: Overlapp; + lPrevThreadsRunning: integer; + {$IFNDEF FPC} lStartTime :DWord;{$ENDIF} +begin + {$IFNDEF FPC} lStartTime := GetTickCount;{$ENDIF} + result := false; + lNULPcalculated := false; + lSumImg := nil; + lPlankImg := nil; + lOutImgSum := nil; + lOutImgBM := nil; + lOutImgT := nil; + lOutImgAUC := nil; + lOverlapRA := nil; + lUniqueOrders := 0; + if lPrefs.Ltest then begin + lPrefs.Ttest := false; + lPrefs.BMtest := false; + end else if (not lPrefs.Ttest) and (not lPrefs.BMtest) then begin//not binomial + NPMmsg('Error no tests specified'); + exit; + end; + NPMmsg('Permutations = ' +IntToStr(lPrefs.nPermute)); + NPMmsg('Analysis began = ' +TimeToStr(Now)); + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + if not MakeSum( lImages, lMaskHdr, lSumImg) then goto 667; + lnVoxTested := ThreshSumImg(lSumImg,lVolVox,lPrefs.nCrit); + NPMmsg('Voxels damaged in at least '+inttostr(lPrefs.nCrit)+' individuals = ' +Floattostr(lnVoxTested)); + if lnVoxTested < 1 then begin + NPMmsg('Error: no voxels damaged in at least '+inttostr(lPrefs.nCrit)+' individuals.'); + goto 667; + end; + if (lPrefs.ExplicitMaskName <> '') then begin + lnVoxTested := ExplicitMaskSumImg (lPrefs.ExplicitMaskName, lSumImg, lVolVox); + NPMmsg('Voxels also non-zero in mask '+lPrefs.ExplicitMaskName+' = ' +Floattostr(lnVoxTested)); + if lnVoxTested < 1 then begin + NPMmsg('Error: no remaing voxels also non-zero in mask '+lPrefs.ExplicitMaskName); + goto 667; + end; + end; + + //compute planks and acquire memory + lTotalMemory := lnVoxTested * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/kPlankSz ) + 1; + NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/kPlankSz)); + if (lnPlanks = 1) then begin + lVoxPerPlank := lnVoxTested; //we can do this in a single pass + getmem(lPlankImg,lTotalMemory) + end else begin + getmem(lPlankImg,kPlankSz); + lVoxPerPlank := kPlankSz div lImages.Count; + end; + //spatial maps for results + getmem(lOutImgSum,lVolVox*sizeof(single)); + getmem(lOutImgBM,lVolVox*sizeof(single)); + getmem(lOutImgT,lVolVox*sizeof(single)); + getmem(lOutImgAUC,lVolVox*sizeof(single)); + //initialize memory + InitPermute (lImages.Count, lPrefs.nPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + //next create permuted BM bounds + if lPrefs.BMtest then begin + NPMmsg('Generating BM permutation thresholds'); + //MainForm.Refresh; + createArray64(lObsp,lObs,lImages.Count); + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lImages.Count, lObs); + freemem(lObsp); + end; + if lPrefs.NULP then + getmem(lOverlapRA,lnVoxTested* sizeof(TLesionPattern)); + if lPrefs.Ltest then + ClearThreadDataPvals(gnCPUThreads,lPrefs.nPermute) + else + ClearThreadData(gnCPUThreads,lPrefs.nPermute) ; + //load and process data + lStartVox := 1; + lEndVox := 0; + for lPlank := 1 to lnPlanks do begin + NPMmsg('Computing plank = ' +Inttostr(lPlank)+' of '+inttostr(lnPlanks)); + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lnVoxTested then begin + lVoxPerPlank := lnVoxTested-lStartVox+1{lVoxPerPlank - (lEndVox-lVolVox)}; + lEndVox := lnVoxTested; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8Masked(lImages[lPos-1], lPlankImg,lSumImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + if lPrefs.Ltest then begin + with TLesionBinom.Create (MainForm.ProgressBar1,false,true,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutIMgT{not used},lOutImgAUC,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + end else begin + with TLesionContinuous.Create (MainForm.ProgressBar1,lPrefs.ttest,lPrefs.BMtest,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA) do + //with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + end; + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + lPrevThreadsRunning := gThreadsRunning; + repeat + Application.processmessages; + sleep(30); + if (gThreadsRunning <> lPrevThreadsRunning) then begin + NPMmsg(' '+inttostr(gThreadsRunning)+' threads still running ' +TimeToStr(Now)); + lPrevThreadsRunning := gThreadsRunning; + end; + until gThreadsRunning = 0; + Application.processmessages; + //end of threading + if lPrefs.NULP then + lNULPcalculated := NULPcount (lPlankImg, lVoxPerPlank,lImages.Count,lPrefs.nCrit, lUniqueOrders, lOverlapRA); + lStartVox := lEndVox + 1; + end; + //calculate max per thread x + SumThreadData(gnCPUThreads,lPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //data in maps is stored in voxels 1..lnVoxTested - put in spatial order + reformat(lOutImgSum,lSumImg,lVolVox); + reformat(lOutImgBM,lSumImg,lVolVox); + reformat(lOutImgT,lSumImg,lVolVox); + reformat(lOutImgAUC,lSumImg,lVolVox); + lThreshBonf := reportBonferroni('Std',lnVoxTested); + if lNULPcalculated {lPrefs.NULP} then + lThreshBonf := reportBonferroni('(Number of Unique Lesion Patterns with at least '+inttostr(lPrefs.nCrit)+' lesions)',lUniqueOrders); + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + //save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + //save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); + //create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lPrefs.Run < 1) and (Sum2Power(lOutImgSum,lVolVox,lImages.Count,lPrefs.nCrit, lPrefs.LTest)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + //if lPrefs.Run > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + // lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lPrefs.nCrit,lnVoxTested,lPlankImg)); + if lPrefs.ttest then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lPrefs.nPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThreshFDR := reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := reportPermute('ttest',lPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest'+lFactName,'.hdr'); + {$IFNDEF FPC} + //if lPrefs.Run > 0 then begin + // NPMmsg('threshtt,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshBonf,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)+','+inttostr(round((GetTickCount - lStartTime)/1000))); + //end; + {$ENDIF} + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + end; + if lPrefs.LTest then begin + PtoZpermute (lPrefs.nPermute, lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'L'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + reportFDR ('L', lVolVox, lnVoxTested, lOutImgBM); + reportPermute('L',lPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + end;//Liebermeister + if lPrefs.BMtest then begin //save Brunner Munzel + lThreshFDR := reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := reportPermute('BM',lPrefs.nPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM'+lFactName,'.hdr'); + if lPrefs.Run > 0 then + NPMmsg('threshbm,'+inttostr(lPrefs.Run)+','+inttostr(ThreshMap(lThreshBonf,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + + //NPMmsgAppend('threshbm,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshBonf,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + end; + NPMmsg('Analysis finished = ' +TimeToStr(Now)); + {$IFNDEF FPC} NPMmsg('Processing Time = ' +inttostr(round((GetTickCount - lStartTime)/1000)));{$ENDIF} + + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + NPMMsgSave(lOutNameMod); + //all done + result := true;//all done without aborting +667: // free memory and report error + if lPlankImg <> nil then freemem(lPlankImg); + if lSumImg <> nil then freemem(lSumImg); + if lOutImgSum <> nil then freemem(lOutImgSum); + if lOutImgBM <> nil then freemem(lOutImgBM); + if lOutImgT <> nil then freemem(lOutImgT); + if lOutImgAUC <> nil then freemem(lOutImgAUC); + if lOverlapRA <> nil then freemem(lOverlapRA); + + if not result then + NPMmsg('Unable to complete analysis.'); + NPMProgressBar( 0); +end; //TurboLDM + +end. \ No newline at end of file diff --git a/npm/turbolesion.ppu b/npm/turbolesion.ppu new file mode 100644 index 0000000..4d89318 Binary files /dev/null and b/npm/turbolesion.ppu differ diff --git a/npm/turbolesion_cmdLine.pas b/npm/turbolesion_cmdLine.pas new file mode 100755 index 0000000..af4be89 --- /dev/null +++ b/npm/turbolesion_cmdLine.pas @@ -0,0 +1,525 @@ +unit turbolesion; +interface +{$H+} +{$Include ..\common\isgui.inc} +uses + // Messages, Graphics, Controls, Forms, Dialogs,StdCtrls, ComCtrls,ExtCtrls,Menus, + {$IFDEF GUI} ComCtrls,ReadInt,Forms, {$ENDIF} + Classes,dialogsx, define_types,SysUtils,unpm, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + +overlap,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} {$IFDEF GUI} LResources,{$ENDIF} gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +Type + TLDMPrefs = record + NULP,BMtest,Ttest,Ltest: boolean; + CritPct,nCrit,nPermute,Run: integer; + ValFilename, OutName, ExplicitMaskName: string; + end; +function TurboLDM (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var lPrefs: TLDMPrefs ; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; + + + +implementation +{$IFDEF GUI} + uses npmform; +{$ELSE} + // uses npmcl; +{$ENDIF} + +(*procedure Debog (var lSumImg: Smallintp; lVox: integer); +var + lInName : string; + lFData: file; +begin + lInName := 'c:\16.img'; + assignfile(lFdata,lInName); + filemode := 2; + Rewrite(lFdata,lVox*sizeof(smallint)); + BlockWrite(lFdata,lSumImg^, 1 {, NumWritten}); + closefile(lFdata); +end;*) + +function MakeSum (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var lSumImg: Smallintp): boolean; +//if successful, you MUST freemem(lSumImg)... +label + 667; +var + lVolVox,lVox,lImg,lPosPct: integer; + lVolImg: byteP; + +begin + result := false; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lVolImg,lVolVox* sizeof(byte)); + getmem(lSumImg,lVolVox* sizeof(smallint)); + for lVox := 1 to lVolVox do //June 2009 init array + lSumImg^[lVox] := 0; +(* for lVox := 1 to lVolVox do + if lVolImg^[lVox] <> 0 then + lSumImg^[lVox] := lSumImg^[lVox]+1;*) + for lImg := 1 to lImages.Count do begin + lPosPct := round(100*(lImg / lImages.Count)); + NPMProgressBar(lPosPct); + if not LoadImg8(lImages[lImg-1], lVolImg, 1, lVolVox,round(gOffsetRA[lImg]),1,gDataTypeRA[lImg],lVolVox) then + goto 667; + for lVox := 1 to lVolVox do + if lVolImg^[lVox] <> 0 then + lSumImg^[lVox] := lSumImg^[lVox]+1; + end;//for each image + NPMmsg('Sum image finished = ' +TimeToStr(Now)); + NPMProgressBar( 0); + //Debog(lSumImg, lVolVox); + freemem(lVolImg); + result := true; + exit; +667: //you only get here if you aborted ... free memory and report error + freemem(lVolImg); + freemem(lSumImg); + NPMMsg('Unable to complete analysis.'); + NPMProgressBar( 0 ); +end; + + +function ThreshSumImg (var lSumImg: Smallintp; lVolVox,lThresh: integer): integer; +//sets all voxels with values < lThresh to zero, returns number of voxels to survive threshold. +var + lPos: integer; +begin + result := 0; + if lVolVox < 1 then + exit; + for lPos := 1 to lVolVox do + if lSumImg^[lPos] < lThresh then + lSumImg^[lPos] := 0 + else + inc(result); +end; + +function ExplicitMaskSumImg (lMaskName: string; var lSumImg: Smallintp; lVolVox: integer): integer; +//Any voxels in MaskImg that are 0 are zeroed in the SumImg +var + lOK: boolean; + lPos: integer; + lMaskHdr: TMRIcroHdr; + lMaskData: bytep; +label + 666; +begin + result := 0; + if (lVolVox < 1) or (not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr)) then begin + NPMmsg('Error: unable to load explicit mask named '+lMaskName); + exit; + end; + if lVolVox <> (lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]) then begin + NPMmsg('Error: data and explicit mask have different sizes '+lMaskName); + exit; + end; + + getmem(lMaskData,lVolVox* sizeof(byte)); + lOK := LoadImg8(lMaskName, lMaskData, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.DataType,lVolVox); + if not lOK then goto 666; + if lVolVox < 1 then + exit; + for lPos := 1 to lVolVox do + if lMaskData^[lPos] < 1 then + lSumImg^[lPos] := 0 + else + inc(result); + + 666: + freemem(lMaskData); +end; + +function LoadImg8Masked(lInName: string; lImgData: bytep; lMaskData: SmallIntP; lStartMaskPos, lEndMaskPos,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +label + 111; +var + lFullImgData: bytep; + lMaskPos,lPos: integer; +begin + result := false; + if (lVolVox < 1) or (lEndMaskPos < lStartMaskPos) then + exit; + getmem(lFullImgData,lVolVox* sizeof(byte)); + result := LoadImg8(lInName, lFullImgData, 1, lVolVox,linvox_offset,1,lDataType,lVolVox); + if result then begin + lMaskPos := 0; + for lPos := 1 to lVolVox do begin + if lMaskData^[lPos] <> 0 then begin + inc(lMaskPos); + if (lMaskPos >=lStartMaskPos) then + lImgData^[lRApos+lMaskPos-1] := lFullImgData^[lPos]; + if lMaskPos = lEndMaskPos then goto 111; + + end;//voxel in mask + end; //for each voxel in image + + end;//if LoadImg8 success +111: + freemem(lFullImgData); +end; + +function reformat(var lStatImg: singlep; lMaskImg: smallintp; lVolVox: integer): boolean; +var + lPos,lStatPos,lMaskItems: integer; +begin + result := false; + if lVolVox < 1 then + exit; + lMaskItems := 0; + for lPos := 1 to lVolVox do + if lMaskImg^[lPos] <> 0 then + inc(lMaskItems); + result := true; + if (lMaskItems < 1) or (lMaskItems >= lVolVox) then + exit;//no need to reformat + //note that we do this in descending order, so we do not overwrite... + lStatPos := lMaskItems; + for lPos := lVolVox downto 1 do + if lMaskImg^[lPos] <> 0 then begin + lStatImg^[lPos] := lStatImg^[lStatPos]; + dec(lStatPos); + end else + lStatImg^[lPos] := 0; +end;//reformat + + +function NULPcount (lPlankImg: bytep; lVoxPerPlank,lImagesCount: integer; var lUniqueOrders: integer; var lOverlapRA: Overlapp): boolean; +procedure CheckOrder(var lObservedOrder: TLesionPattern); +var + lInc: integer; +begin + if lUniqueOrders > 0 then begin //see if this is unique + for lInc := 1 to lUniqueOrders do + if SameOrder(lObservedOrder,lOverlapRA^[lInc],lImagesCount) then + exit; //not unique + end; //UniqueOrders > 0 + //if we have not exited yet, we have found a new ordering! + lUniqueOrders := lUniqueOrders + 1; + lOverlapRA^[lUniqueOrders] := lObservedOrder; +end; + +var + lVox,lPlankImgPos,lPos: integer; + lOrder,lPrevOrder: TLesionPattern; +begin + result := false; + lPrevOrder := EmptyOrder;//impossible: forces first voxel of each order to be checked + for lVox := 1 to lVoxPerPlank do begin + (*if (lVox mod lVoxPerPlankDiv10) = 0 then begin + MainForm.ProgressBar1.Position := (lVox div lVoxPerPlankDiv10)*10; + MainForm.Refresh; + Application.processmessages; + end;*) + lOrder := EmptyOrder; + lPlankImgPos := 0; + //lnDeficits := 0; + for lPos := 1 to lImagesCount do begin + if (lPlankImg^[lPlankImgPos + lVox] > 0) then begin + //inc(lnDeficits); + SetBit(lPos,lOrder); + end; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end; + //if (lnDeficits >= lminDeficits) then begin //this is different from the last voxel: perhaps this is a new ordering + if (not SameOrder(lOrder,lPrevOrder,lImagesCount)) then + CheckOrder(lOrder); + //inc(lnVoxels); + //end;//nDeficies + lPrevOrder := lOrder; + end;//for lVox + result := true; +end; + +procedure PtoZpermute (lnPermute: integer; lPermuteMaxT, lPermuteMinT: singlep); +var + lPos: integer; + lVal : single; +begin + if lPos < 1 then exit; + for lPos := 1 to lnPermute do begin + if (lPermuteMinT^[lPos] > 1.1) or (lPermuteMinT^[lPos] < -1.1) then + lPermuteMinT^[lPos] := 0.5; + if (lPermuteMaxT^[lPos] > 1.1) or (lPermuteMaxT^[lPos] < -1.1) then + lPermuteMaxT^[lPos] := 0.5; + lVal := lPermuteMaxT^[lPos]; + lPermuteMaxT^[lPos] := lPermuteMinT^[lPos]; + lPermuteMinT^[lPos] := lVal; + if lPermuteMaxT^[lPos] < 0 then + lPermuteMaxT^[lPos] := -pNormalInv(abs(lPermuteMaxT^[lPos])) + else + lPermuteMaxT^[lPos] := pNormalInv(lPermuteMaxT^[lPos]); + if lPermuteMinT^[lPos] < 0 then + lPermuteMinT^[lPos] := -pNormalInv(abs(lPermuteMinT^[lPos])) + else + lPermuteMinT^[lPos] := pNormalInv(lPermuteMinT^[lPos]); + end; +end; + + +function TurboLDM (var lImages: TStrings; var lMaskHdr: TMRIcroHdr;var lPrefs: TLDMPrefs ; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lStatHdr: TNIfTIhdr; + lThreshFDR,lThreshPermute,lThreshBonf,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC: singlep; + lSumImg: Smallintp; + lPlankImg: byteP; + lVoxPerPlank,lnPlanks,lTotalMemory,lnVoxTested,lVolVox: int64; + lUniqueOrders,lThread,lThreadStart,lThreadInc,lThreadEnd, + lPos2,lPosPct,lPos,lPlankImgPos,lPlank,lStartVox,lEndVox: integer; + lOverlapRA: Overlapp; + + {$IFNDEF FPC} lStartTime :DWord;{$ENDIF} +begin + {$IFNDEF FPC} lStartTime := GetTickCount;{$ENDIF} + result := false; + lSumImg := nil; + lPlankImg := nil; + lOutImgSum := nil; + lOutImgBM := nil; + lOutImgT := nil; + lOutImgAUC := nil; + lOverlapRA := nil; + lUniqueOrders := 0; + if lPrefs.Ltest then begin + lPrefs.Ttest := false; + lPrefs.BMtest := false; + end else if (not lPrefs.Ttest) and (not lPrefs.BMtest) then begin//not binomial + NPMmsg('Error no tests specified'); + exit; + end; + NPMmsg('Permutations = ' +IntToStr(lPrefs.nPermute)); + NPMmsg('Analysis began = ' +TimeToStr(Now)); + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + if not MakeSum( lImages, lMaskHdr, lSumImg) then goto 667; + lnVoxTested := ThreshSumImg(lSumImg,lVolVox,lPrefs.nCrit); + NPMmsg('Voxels damaged in at least '+inttostr(lPrefs.nCrit)+' individuals = ' +Floattostr(lnVoxTested)); + if lnVoxTested < 1 then begin + NPMmsg('Error: no voxels damaged in at least '+inttostr(lPrefs.nCrit)+' individuals.'); + goto 667; + end; + if (lPrefs.ExplicitMaskName <> '') then begin + lnVoxTested := ExplicitMaskSumImg (lPrefs.ExplicitMaskName, lSumImg, lVolVox); + NPMmsg('Voxels also non-zero in mask '+lPrefs.ExplicitMaskName+' = ' +Floattostr(lnVoxTested)); + if lnVoxTested < 1 then begin + NPMmsg('Error: no remaing voxels also non-zero in mask '+lPrefs.ExplicitMaskName); + goto 667; + end; + end; + + //compute planks and acquire memory + lTotalMemory := lnVoxTested * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/kPlankSz ) + 1; + NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/kPlankSz)); + if (lnPlanks = 1) then begin + lVoxPerPlank := lnVoxTested; //we can do this in a single pass + getmem(lPlankImg,lTotalMemory) + end else begin + getmem(lPlankImg,kPlankSz); + lVoxPerPlank := kPlankSz div lImages.Count; + end; + //spatial maps for results + getmem(lOutImgSum,lVolVox*sizeof(single)); + getmem(lOutImgBM,lVolVox*sizeof(single)); + getmem(lOutImgT,lVolVox*sizeof(single)); + getmem(lOutImgAUC,lVolVox*sizeof(single)); + //initialize memory + InitPermute (lImages.Count, lPrefs.nPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + //next create permuted BM bounds + if lPrefs.BMtest then begin + NPMmsg('Generating BM permutation thresholds'); + createArray64(lObsp,lObs,lImages.Count); + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lImages.Count, lObs); + freemem(lObsp); + end; + if lPrefs.NULP then + getmem(lOverlapRA,lnVoxTested* sizeof(TLesionPattern)); + if lPrefs.Ltest then + ClearThreadDataPvals(gnCPUThreads,lPrefs.nPermute) + else + ClearThreadData(gnCPUThreads,lPrefs.nPermute) ; + //load and process data + lStartVox := 1; + lEndVox := 0; + for lPlank := 1 to lnPlanks do begin + NPMmsg('Computing plank = ' +Inttostr(lPlank)+' of '+inttostr(lnPlanks)); + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lnVoxTested then begin + lVoxPerPlank := lnVoxTested-lStartVox+1{lVoxPerPlank - (lEndVox-lVolVox)}; + lEndVox := lnVoxTested; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8Masked(lImages[lPos-1], lPlankImg,lSumImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + NPMmsg('starting threads '+inttostr(gnCPUThreads)); + {$IFDEF aaaaa} + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + ThreadArray[lThread]:= TLesionContinuous.Create (MainForm.ProgressBar1,lPrefs.ttest,lPrefs.BMtest,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA) ; + inc(gThreadsRunning); + + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; + + NPMmsg('started threads '+inttostr(gnCPUThreads)); + for lThread := 1 to gnCPUThreads do if not ThreadArray[lThread].Terminated then Sleep(100); + NPMmsg('done threads '+inttostr(gnCPUThreads)); + {$ELSE} + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + if lPrefs.Ltest then begin + with TLesionBinom.Create (MainForm.ProgressBar1,false,true,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutIMgT{not used},lOutImgAUC,lSymptomRA) do + {$IFDEF GUI} + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + {$ELSE} + NPMmsg(inttostr(gThreadsRunning)); + //OnTerminate := @NPMThreadDone; + {$ENDIF} + end else begin + with TLesionContinuous.Create (MainForm.ProgressBar1,lPrefs.ttest,lPrefs.BMtest,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA) do + //with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lSymptomRA) do + {$IFDEF GUI} + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + + {$ELSE} + + OnTerminate := @Application.ThreadDone; + NPMmsg('starting '+inttostr(gThreadsRunning)); + {$ENDIF} + end; + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Sleep(100); + refresher; + until gThreadsRunning = 0; + refresher; + {$ENDIF} + //end of threading + + if lPrefs.NULP then + NULPcount (lPlankImg, lVoxPerPlank,lImages.Count, lUniqueOrders, lOverlapRA); + + lStartVox := lEndVox + 1; + end; + //calculate max per thread + SumThreadData(gnCPUThreads,lPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + + //data in maps is stored in voxels 1..lnVoxTested - put in spatial order + reformat(lOutImgSum,lSumImg,lVolVox); + reformat(lOutImgBM,lSumImg,lVolVox); + reformat(lOutImgT,lSumImg,lVolVox); + reformat(lOutImgAUC,lSumImg,lVolVox); + lThreshBonf := reportBonferroni('Std',lnVoxTested); + if lPrefs.NULP then + lThreshBonf := reportBonferroni('Number of Unique Lesion Patterns',lUniqueOrders); + + + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + //save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + //save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); + //create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lPrefs.Run < 1) and (Sum2Power(lOutImgSum,lVolVox,lImages.Count,lPrefs.nCrit, lPrefs.LTest)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + //if lPrefs.Run > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + // lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lPrefs.nCrit,lnVoxTested,lPlankImg)); + if lPrefs.ttest then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lPrefs.nPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThreshFDR := reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := reportPermute('ttest',lPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest'+lFactName,'.hdr'); + {$IFNDEF FPC} + if lPrefs.Run > 0 then begin + MainForm.NPMmsgAppend('threshtt,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshBonf,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)+','+inttostr(round((GetTickCount - lStartTime)/1000))); + end; + {$ENDIF} + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + end; + if lPrefs.LTest then begin + PtoZpermute (lPrefs.nPermute, lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'L'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + reportFDR ('L', lVolVox, lnVoxTested, lOutImgBM); + reportPermute('L',lPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + end;//Liebermeister + if lPrefs.BMtest then begin //save Brunner Munzel + lThreshFDR := reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := reportPermute('BM',lPrefs.nPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM'+lFactName,'.hdr'); + if lPrefs.Run > 0 then + NPMmsg('threshbm,'+inttostr(lPrefs.Run)+','+inttostr(ThreshMap(lThreshBonf,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + end; + NPMmsg('Analysis finished = ' +TimeToStr(Now)); + {$IFNDEF FPC} MainForm.NPMmsg('Processing Time = ' +inttostr(round((GetTickCount - lStartTime)/1000)));{$ENDIF} + + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + NPMMsgSave(lOutNameMod); + //all done + result := true;//all done without aborting +667: // free memory and report error + if lPlankImg <> nil then freemem(lPlankImg); + if lSumImg <> nil then freemem(lSumImg); + if lOutImgSum <> nil then freemem(lOutImgSum); + if lOutImgBM <> nil then freemem(lOutImgBM); + if lOutImgT <> nil then freemem(lOutImgT); + if lOutImgAUC <> nil then freemem(lOutImgAUC); + if lOverlapRA <> nil then freemem(lOverlapRA); + + if not result then + NPMmsg('Unable to complete analysis.'); + NPMProgressBar( 0); +end; //TurboLDM + +end. \ No newline at end of file diff --git a/npm/unpm.o b/npm/unpm.o new file mode 100644 index 0000000..27610cf Binary files /dev/null and b/npm/unpm.o differ diff --git a/npm/unpm.pas b/npm/unpm.pas new file mode 100755 index 0000000..46de915 --- /dev/null +++ b/npm/unpm.pas @@ -0,0 +1,1674 @@ +unit unpm; +{$IFDEF FPC}{$mode objfpc}{$H+} {$ENDIF} +{$Include ..\common\isgui.inc} +interface + +uses + upower,math,utypes, +regmult,IniFiles,Classes, SysUtils , nifti_types, define_types,distr, statcr, StatThdsUtil, userdir, dialogsx, nifti_hdr, StatThds, lesion_pattern; +Type + TNPMPrefs = record + NULP,ROI,ttest,BMtest: boolean; + TFCE,PlankMB,nPermute: integer; + end; + + procedure ComputePlankSize (var lPlankMB: integer); + procedure InitPermute (lnSubj, lnPermute: integer; var lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; var lRanOrderp: pointer; var lRanOrder: Doublep0); + procedure NPMThreadDone; + function reportBonferroni(lLabel: string; lnTests: integer): double; //returns 5% Z score + function reportFDR (lLabel:string; lnVox, lnTests: integer; var lData: SingleP): double; + function reportPermute (lLabel:string; lnPermute: integer; var lPermuteMaxZ, lPermuteMinZ: singleP): double; + function ThreshMap(lThresh: single; lVolVox: integer;lOutImg: singleP): integer; + procedure NPMMsgSave(lFilename: string); + procedure NPMProgressBar(lPos: integer); + procedure NPMmsg(str: string); + procedure NPMMsgClear; + function GetKVers: string; + function ReportDescriptives (var RA: SingleP; n: integer): boolean; + procedure FreePermute (lnPermute: integer; var lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP;var lRanOrderp: pointer); + procedure ReadIniFile; + procedure WriteIniFile; + function Add2ndScans(var lImageNames: TStrings): boolean; + function ChangeName (lInName: string): string; + function NPMzscore (var lImages: TStrings; var lMnHdr,lStDevHdr: TMRIcroHdr): boolean; + function NPMAnalyze (var lImages: TStrings; var lMaskname: string; lMaskVoxels,lnGroup1: integer; lNPMPrefs: TNPMPrefs; var lOutName: string): boolean; + + //function NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels,lnGroup1: integer; lNPMPrefs: TNPMPrefs; var lOutName: string): boolean; + function ComputeLesionVolume (lImgName: string): integer; + procedure Refresher; + function MakeMean (lImages: TStrings; lBinarize,lVariance : boolean; lOutName: string): boolean; + procedure NPMTitleMsg (S: string); + //function MakeMean (var lImages: TStrings; lBinarize,lVariance : boolean; lOutName: string): boolean; + function NPMAnalyzePaired (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels: integer; lOutName: string): boolean; + procedure NPMMultipleRegressClick(var lVALFilename, lMaskname,lOutname: string); + procedure NPMSingleRegress (var lVALFilename, lMaskname,lOutname: string); + function ComputeOverlap ( lROIname: string; var lLesionNames: TStrings; var lROIvol: double; lFracROIinjured: singlep): boolean; + function Balance (var lImageName,lMaskName: String; {lInflection: boolean}lMethod: integer): boolean; + function ReadPairedFilenames(var lImageNames: TStrings): boolean; + var + gNPMPrefs: TNPMPrefs; + + +implementation +uses + {$IFDEF GUI}npmform,Forms,{$ENDIF} regression, valformat, + firthThds,firth,hdr, prefs, nifti_img, tfce_clustering; +{$IFNDEF GUI} +var + NPMmemo: TStringList; +{$ENDIF} + +var + gThreadsRunning: integer = 0; +procedure NPMTitleMsg (S: string); +begin + MainForm.Caption := S; +end; + + +procedure NPMProgressBar(lPos: integer); +begin + {$IFDEF GUI} + MainForm.ProgressBar1.Position := lPos; + MainForm.Refresh; + {$ENDIF} +end; + +procedure NPMMsgClear; +begin + {$IFDEF GUI} + MainForm.NPMMsgClearUI; + {$ELSE} + //shittt + {$ENDIF} +end; + +procedure NPMmsg(str: string); +begin + {$IFDEF GUI} + MainForm.NPMmsgUI(str); + {$ELSE} + writeln(str); + //shittt + {$ENDIF} +end; + +procedure NPMMsgSave(lFilename: string); +var + i: integer; + f: textfile; +begin + {$IFDEF GUI} + MainForm.NPMmsgSaveUI(lFilename); + {$ELSE} + ShowMsg('SHITTTT'); + {$ENDIF} +end; + + + +function GetKVers: string; +begin + result := 'Chris Rorden''s NPM '+kMRIcronVers+' :: '+inttostr(sizeof(integer)*8)+'-bit :: Threads used = '+inttostr(gnCPUThreads )+' :: plankSize = '+inttostr(gNPMPrefs.PlankMB)+'mb'; +end; + +procedure Refresher; +begin + {$IFDEF GUI} + Application.processmessages; + MainForm.Refresh; + {$ENDIF} +end; + + +function ReadPairedFilenames(var lImageNames: TStrings): boolean; +var + lLen,lPos: integer; + lFilenames,lF1,lF2: string; + lImageNames2: TStrings; + lF: TextFile; +begin + result := false; + ShowMsg('Please select a text file with the image names. '+kCR+ + 'Each line of the file should specify the control and experimental filenames, separated by an *'+kCR+ + 'C:\vbmdata\c1.nii.gz*C:\vbmdata\e1.nii.gz'+kCR + + 'C:\vbmdata\c2.nii.gz*C:\vbmdata\e2.nii.gz'+kCR+ + 'C:\vbmdata\c3.nii.gz*C:\vbmdata\e3.nii.gz'+kCR+ + '...' ); +(*SHITTT if not MainForm.OpenDialogExecute('Select asterix separated filenames ',false,false,kTxtFilter) then + exit; + lImageNames2:= TStringList.Create; //not sure why TStrings.Create does not work??? + //xxx + assignfile(lF,MainForm.OpenHdrDlg.FileName ); *) + FileMode := 0; //read only + reset(lF); + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + + if lLen > 0 then begin + lF1:= ''; + lF2 := ''; + lPos := 1; + while (lPos <= lLen) and (lFilenames[lPos] <> '*') do begin + lF1 := lF1 + lFilenames[lPos]; + inc(lPos); + end; + inc(lPos); + while (lPos <= lLen) do begin + lF2 := lF2 + lFilenames[lPos]; + inc(lPos); + end; + if (length(lF1) > 0) and (length(lF2)>0) then begin + if Fileexists4D(lF1) then begin + if Fileexists4D(lF2) then begin + lImageNames.add(lF1); + lImageNames2.add(lF2); + end else //F2exists + ShowMsg('Can not find image '+lF2); + end else //F1 exists + ShowMsg('Can not find image '+lF1); + end; + end;//len>0 + end; //while not EOF + closefile(lF); + FileMode := 2; //read/write + if (lImageNames.count > 0) and (lImageNames2.count = lImageNames.count) then begin + lImageNames.AddStrings(lImageNames2); + + result := true; + end; + lImageNames2.Free; +end; + + +function MinMax (var lImg: SingleP; var lVolVox: integer; var lMin, lMax: single): boolean; +var + lC: integer; +begin + result := false; + if lVolVox < 1 then + exit; + lMax := lImg^[1]; + for lC := 1 to lVolVox do + if lImg^[lC] > lMax then + lMax := lImg^[lC]; + //lCx := lC; + lMin := lImg^[1]; + for lC := 1 to lVolVox do + if lImg^[lC] < lMin then + lMin := lImg^[lC]; + result := true; +end; + +function DetectMode (var lImg: SingleP; var lVolVox: integer; var lMin, lMax, lModeLo,lModeHi: single; lInflection: boolean): boolean; +const + kHistoBins = 255;//numbers of bins for histogram/image balance +var + lSmooth,lPrevSmooth,lModeWid,lC,lMinPos,lMode,lModePos,lMaxModePos,lMode2NotInflection: integer; + lMod,lRng: single; + lHisto : array [0..kHistoBins] of longint; +begin + + result := false; + if (lVolVox < 1) or (lMax < lMin) then + exit; + //zero array + for lC := 1 to kHistoBins do + lHisto[lC] := 0; + //find scaling + lRng := abs(lMax-lMin); + if lRng > 0 then + lMod := (kHistoBins)/lRng + else + lMod := 0; + //fill histogram + for lC := 1 to lVolVox do + if lImg^[lC] <> 0 then + inc(lHisto[round((lImg^[lC]-lMin)*lMod)]); + + {for lC := 1 to lVolVox do + inc(lHisto[round((lImg^[lC]-lMin)*lMod)]); } + //smooth histogram + lPrevSmooth := lHisto[1]; + for lC := 2 to (kHistoBins-1) do begin + lSmooth := round( (lHisto[lC-1]+lHisto[lC]+lHisto[lC]+lHisto[lC+1])/4); + lHisto[lC-1] := lPrevSmooth; + lPrevSmooth := lSmooth; + end; + lHisto[kHistoBins-1] := lPrevSmooth; + //find mode + lMode := 0; + lMinPos := 1;//indexed from zero + //find highest peak + for lC := lMinPos to kHistoBins do begin + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //for each bin + if lMode > 0 then + lMaxModePos := lModePos + else + exit; + //find 2nd highest peak + //find 2nd highest peak + lModeWid := 25; + lModePos := lMinPos; + lMode := lHisto[lMinPos]; + if (lMaxModePos - lModeWid) > lMinPos then begin + for lC := lMinPos to (lMaxModePos - lModeWid) do begin + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //for each bin + end; //check below highest peak + if (lMaxModePos + lModeWid) < kHistoBins then begin + for lC := (lMaxModePos + lModeWid) to kHistoBins do begin + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //for each bin + end; //check above highest peak + //fx(lModePos); + //an alternative method to find mode is to look for inflection - less assumptions, more sensitive to noise + if lInflection then begin + lMode2NotInflection := lModePos; + lModePos := lMinPos; + + lMode := 0; + lC := lMaxModePos; + while ((lC-1) > lMinPos) and (lHisto[lC] > lHisto[lC-1]) do + dec(lC); //find inflection + while ((lC-1) > lMinPos) do begin + dec(lC); + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //look for mode + + lC := lMaxModePos; + while ((lC+1) <= kHistoBins) and (lHisto[lC] > lHisto[lC+1]) do + inc(lC); //find inflection + while ((lC+1) <= kHistoBins) do begin + inc(lC); + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //look for mode + + if abs(lMode2NotInflection-lModePos) > 3 then + ShowMsg('Warning: inflection and windowed algorithms find different 2nd modes. Using inflection 2nd mode. inflection ='+inttostr(lModePos)+' windowed: '+inttostr(lMode2NotInflection)); + + end; + //now, return scaled values... + if lMod = 0 then exit; + lModeLo := (lModePos/lMod)+lMin; + lModeHi := (lMaxModePos/lMod)+lMin; + if lModeLo > lModeHi then begin + lMod := lModeLo; + lModeLo := lModeHi; + lModeHi := lMod; + end; + result := true; +end; + +function DetectMeanStDev (var lImg: SingleP; var lVolVox: integer; var lMean,lStDev: double): boolean; +var + lIncVox,lVox: integer; + lSum,lSumSqr,lSE: double; +begin + lMean := 0; + lStDev := 0; + result := false; + if (lVolVox < 1) then + exit; + lSum := 0; + lSumSqr := 0; + lIncVox := 0; //voxels included - e.g. not masked + for lVox := 1 to lVolVox do begin + if lImg^[lVox] <> 0 then begin //not in mask + inc(lIncVox); + lSum := lSum + lImg^[lVox]; + lSumSqr := lSumSqr + sqr(lImg^[lVox]); + end; + end; + if lincVox < 3 then + exit; + Descriptive (lincVox, lSumSqr, lSum,lMean,lStDev,lSE); + result := true; +end; //DetectMeanStDev + + + +function Balance (var lImageName,lMaskName: String; {lInflection: boolean}lMethod: integer): boolean; +//0 = masked peak +//1 = inflection +//2 = mean =1, stdev=1 +var + lImg,lMaskImg: SingleP; + lHdr,lMaskHdr: TMRIcroHdr; + lVolVox,lVox,lMasked: integer; + lMaskedInten,lMean,lStDev: double; + lMin,lMax: single; + lModeLo,lModeHi,lIntercept,lSlope: single; + lOutNameMod: string; +begin + //lOutName := lMaskHdr.ImgFileName; + result := false; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + if not NIFTIhdr_LoadHdr(lImageName,lHdr) then begin + ShowMsg('Error reading '+lImageName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + if lMaskName <> '' then begin + if not NIFTIhdr_LoadHdr(lMaskName,lMaskHdr) then begin + ShowMsg('Error reading '+lMaskName); + exit; + end; + if lVolVox <> (lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]) then begin + ShowMsg('Mask and header must have identical dimensions '+lMaskName+ ' ' + lImageName); + exit; + + end; + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load mask ' +lMaskHdr.ImgFileName); + exit; + end; + lMasked := 0; + lMaskedInten := 0; + for lVox := 1 to lVolVox do + if lMaskImg^[lVox] = 0 then begin + lMaskedInten := lMaskedInten + lImg^[lVox]; + lImg^[lVox] := 0; + inc(lMasked); + end; + if lMasked < 1 then + NPMMsg('Warning: no voxels masked with image '+lMaskName) + else + NPMMsg('Mask='+ lMaskName+' Number of voxels masked= '+inttostr(lMasked)+' Mean unscaled intensity of masked voxels= '+floattostr(lMaskedInten/lMasked)); + freemem(lMaskImg); + end;//mask + + if not MinMax(lImg,lVolVox,lMin,lMax) then exit; + NPMMsg(lImageName+' -> '+lHdr.ImgFileName); + NPMMsg('min..max ' +floattostr(lMin)+'..'+floattostr(lMax)); + if (lMethod = 0) or (lMethod = 1) then begin + if not DetectMode(lImg,lVolVox,lMin,lMax,lModeLo,lModeHi, odd(lMethod)) then exit; + if odd(lMethod) then + NPMMsg('method for finding second mode: inflection') + else + NPMMsg('method for finding second mode: masked peak'); + NPMMsg('modes Lo Hi ' +floattostr(lModeLo)+'..'+floattostr(lModeHi)); + if lModeLo >= lModeHi then exit; + lSlope := 1/abs(lModeHi-lModeLo); + lIntercept := (abs(lModeHi-lModeLo)-(lModeLo))*lSlope ; //make mode lo = 1; + end else begin + DetectMeanStDev (lImg, lVolVox, lMean,lStDev); + if lStDev <>0 then + lSlope := 1/lStDev + else begin + NPMMsg('Warning: StDev = 0!!!!'); + lSlope := 1; + end; + lIntercept := (-lMean*lSlope)+2; //mean voxel has intensity of zero + + NPMMsg('method for intensity normalization: Mean = 2, StDev = 1'); + NPMMsg('raw_Mean = '+floattostr(lMean)+' '+' raw_StDev = '+floattostr(lStDev)); + + end; + NPMMsg('Slope/Intercept ' +floattostr(lSlope)+'..'+floattostr(lIntercept)); + lHdr.NIFTIhdr.scl_slope := lSlope; + lHdr.NIFTIhdr.scl_inter := lIntercept; + //CopyFileEX(lHdr.HdrFilename,changefileext( lHdr.HdrFilename,'.hdx')); + RenameFile(lHdr.HdrFilename,changefileext( lHdr.HdrFilename,'.hdx')); + //optional - save input + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lImg,1); + //end optional + NIFTIhdr_SaveHdr(lHdr.HdrFilename,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr)); + + freemem(lImg); +end; + +function ComputeOverlap ( lROIname: string; var lLesionNames: TStrings; var lROIvol: double; lFracROIinjured: singlep): boolean; +label 667; +var + lName: string; + lSum: double; + lLesion,lnLesions,lVolVox,lVolVoxA,lVox: integer; + lROIImg,lImgB: SingleP; + lMaskHdr: TMRIcroHdr; +begin + lROIvol := 0; + result := false; + lnLesions := lLesionNames.count; + if lnLesions < 1 then begin + ShowMsg('Error: no lesion names'); + exit; + end; + for lLesion := 1 to lnLesions do + lFracROIinjured^[lLesion] := 0; + //read A + if not NIFTIhdr_LoadHdr(lROIname,lMaskHdr) then begin + ShowMsg('Error reading ROI - '+lROIname); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then begin + ShowMsg('Error with Mask voxels ' + inttostr(lVolVox)); + exit; + end; + if not CheckVoxelsGroupX(lLesionNames, lMaskHdr) then begin + ShowMsg('Error image dimensions vary.'); + exit; + end; + getmem(lROIImg,lVolVox*sizeof(single)); + getmem(lImgB,lVolVox*sizeof(single)); + if not LoadImg(lROIname, lROIImg, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMmsg('Unable to load lesion ' +lMaskHdr.ImgFileName); + goto 667; + end; + lVolVoxA := lVolVox; + for lVox := 1 to lVolVox do + if (lROIImg^[lVox] > 0) then + lROIvol := lROIvol +lROIImg^[lVox]; + //read Lesion + if lROIvol < 1 then begin + NPMmsg('ROI volume < 1'); + goto 667; + end; + //for each lesion + //NPMmsg('Compute overlap started '+inttostr(lnLesions)+' '+floattostr(lROIvol)+' '+inttostr(lVolVoxA)); + NPMProgressBar( 0); + for lLesion := 1 to lnLesions do begin + NPMProgressBar(round((lLesion/lnLesions)*100)) ; + lSum := 0; + lName := lLesionNames.Strings[lLesion-1]; + if not NIFTIhdr_LoadHdr(lName,lMaskHdr) then begin + ShowMsg('Error reading lesion - '+lName); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVoxA <> lVolVox) or (lVolVox < 1) then begin + NPMmsg('Volume does not have expected number of voxels ' +lMaskHdr.ImgFileName +'<>'+lROIname+ ' found ' +inttostr(lVolVox)+' expected '+inttostr(lVolVoxA)); + goto 667; + end; + if not LoadImg(lName, lImgB, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMmsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + for lVox := 1 to lVolVox do begin + //if {(lImgB^[lVox] <> 0) and} (lROIImg^[lVox] <> 0) then fx(lROIImg^[lVox]); + + if (lROIImg^[lVox] > 0) and (lImgB^[lVox] <> 0) then + lSum := lSum + lROIImg^[lVox]; + end; + lFracROIinjured^[lLesion] := lSum/lROIvol; + end;//for each lesion + result := true; + NPMProgressBar( 0); + + (*for lLesion := 1 to lnLesions do begin + if lFracROIinjured^[lLesion] > 0 then + fx( lFracROIinjured^[lLesion], lLesion); + end; *) + + 667: + + freemem(lImgB); + freemem(lROIImg); +end; + +procedure NPMSingleRegress (var lVALFilename, lMaskname,lOutname: string); +label + 666; +var + lnSubj1,lnFactors,lnSubj,lMaskVoxels,lRow,lCol: integer; + lImageNames,lImageNames1: TStrings; + lPredictorList,lPredictorList1: TStringList; + lTemp4D: string; + lMaskHdr: TMRIcroHdr; + X,X1 : PMatrix; +begin + + lTemp4D := ''; + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPredictorList := TStringList.Create; + lPredictorList1 := TStringList.Create; + if not GetValReg(lVALFilename,lnSubj,lnFactors,X,lImageNames,lPredictorList) then + goto 666; + if (length(lMaskname) < 1) then + lMaskName := lImageNames[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + ShowMsg('Error reading mask image.'); + exit; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,-1)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + goto 666; + end; + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNames); + lImageNames1:= TStringList.Create; + for lCol := 1 to lnFactors do begin + lPredictorList1.Clear; + lPredictorList1.Add(lPredictorList[lCol-1]); + lImageNames1.clear; + for lRow := 1 to lnSubj do + if X^[lCol]^[lRow] <> kNaN then + lImageNames1.Add(lImageNames[lRow-1]); + DimMatrix(X1, 1, lImageNames1.Count); + lnSubj1 := 0; + + for lRow := 1 to lnSubj do + if X^[lCol]^[lRow] <> kNaN then begin + inc(lnSubj1); + X1^[1]^[lnSubj1] := X^[lCol]^[lRow]; + end; + if lnSubj1 <> lImageNames1.Count then //should be impossible + ShowMsg('NPMSingleRegress: serious error - number of participants does not match'); + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Single Linear Regression [Weighted Least Squares]'); + NPMMsg('Mask = '+lMaskname); + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Number of observations = '+inttostr(lnSubj1)); + NPMMsg('Image,'+ lPredictorList1.Strings[0]); + for lRow := 1 to lnSubj1 do + NPMMsg(lImageNames1[lRow-1]+','+floattostr(X1^[1]^[lRow]) ) ; + + ARegressNPMAnalyze(lImageNames1,lMaskHdr,X1,1,lPredictorList1,lOutName, gNPMPrefs.nPermute,gNPMPrefs.TFCE); + //PermuteRegressNPMAnalyze (lImageNames1,lMaskHdr,X1,1,lPredictorList1,lOutName); + DelMatrix(X1, 1, lnSubj1); + end; + lImageNames1.Free; + DelMatrix(X, lnFactors, lnSubj); + 666: +DeleteDecompressed4D(lTemp4D); + lImageNames.Free; + lPredictorList.Free; + lPredictorList1.Free; +end; + +procedure NPMMultipleRegressClick(var lVALFilename, lMaskname,lOutname: string); +label + 666; +var + lnFactors,lnSubj,lMaskVoxels,lRow,lCol: integer; + lImageNames: TStrings; + lPredictorList: TStringList; + lTemp4D,lStr: string; + lMaskHdr: TMRIcroHdr; + X : PMatrix; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPredictorList := TStringList.Create; + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Multiple Linear Regression [Weighted Least Squares]'); + if not GetValReg(lVALFilename,lnSubj,lnFactors,X,lImageNames,lPredictorList) then + goto 666; + lTemp4D := CreateDecompressed4D(lImageNames); + + //lMaskname := lImageNames[0]; + + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + ShowMsg('Error reading 1st image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,-1)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + goto 666; + end; + NPMMsg('Mask = '+lMaskname); + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Number of observations = '+inttostr(lnSubj)); + if not CheckVoxelsGroupX(lImageNames,lMaskHdr {lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + goto 666; + end; + //show matrix + lStr := 'Image,'; + for lCol := 1 to lnFactors do + lStr := lStr + lPredictorList.Strings[lCol-1]+', '; + NPMmsg(lStr); + for lRow := 1 to lnSubj do begin + lStr := lImageNames[lRow-1]+','; + for lCol := 1 to lnFactors do + lStr := lStr + floattostr(X^[lCol]^[lRow])+', '; + NPMmsg(lStr); + end; + + ARegressNPMAnalyze(lImageNames,lMaskHdr,X,lnFactors,lPredictorList,lOutName,0,0); + + DelMatrix(X, lnFactors, lnSubj); + 666: + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); +end; + +function NPMAnalyzePaired (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels: integer; lOutName: string): boolean; +label + 667; +var + //lOutName, + lOutNameMod: string; + lMaskImg,lPlankImg,lOutImgMn,lOutImgT,lDummy,lDummy2: SingleP; + lTotalMemory: double; //not integer - limit for 32bit int is 2Gb + lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lThreadStart,lThreadEnd,lThreadInc: integer; + lT, lSum, lMn: double; + lStatHdr: TNIfTIhdr; + lFdata: file; + lThread,lnPermute: integer; + lPermuteMaxT, lPermuteMinT: singleP; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + //lnPermute := ReadPermute; + lnPermute := 0;//not yet + NPMmsg('Permutations = ' +IntToStr(lnPermute)); + + NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + //load mask + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(gOffsetRA[0]),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMmsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + //next find start and end of mask + lPos := 0; + repeat + inc(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = lVolVox); + lMinMask := lPos; + lPos := lVolVox+1; + repeat + dec(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = 1); + lMaxMask := lPos; + if lMaxMask = 1 then begin + NPMmsg('Mask appears empty' +lMaskHdr.ImgFileName); + goto 667; + end; + NPMmsg('Mask has voxels from '+inttostr(lMinMask)+'..'+inttostr(lMaxMask)); + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + getmem(lOutImgMn,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + //not yet InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgMn^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + ClearThreadData(gnCPUThreads,lnPermute); + for lPlank := 1 to lnPlanks do begin + NPMmsg('Computing plank = ' +Inttostr(lPlank)); + Refresher; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + (**SHITTTT + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TPairedTStat.Create (ProgressBar1,false,false,0, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,666, lMaskImg,lPlankImg,lOutImgMn,lDummy2,lOutImgT,lDummy) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + *) + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadDataLite(gnCPUThreads);//not yet SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + reportBonferroni('Std',lnVoxTested); + //next: save data +(*savedata *) + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save mean + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mean','.hdr'); + if lnVoxTested > 1 then + + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + +if (lnVoxTestED > 1 ) then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],(lImages.Count div 2)-1); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + + reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + reportPermute('ttest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); +end; +//next: close images + //not yet FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgMn); + //freemem(lObsp); + freemem(lMaskImg); + freemem(lPlankImg); + NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + NPMMsgSave(lOutNameMod); + NPMProgressBar(0); + exit; +667: //you only get here if you aborted ... free memory and report error + if lVolVox > 1 then freemem(lMaskImg); + if lTotalMemory > 1 then freemem(lPlankImg); + NPMmsg('Unable to complete analysis.'); + NPMProgressBar(0); +end; + + +(*function ApplyTFCE (lImageName: string): boolean; +var + lImg: SingleP; + lHdr: TMRIcroHdr; + lVolVox: integer; + maxTFCE, maxNegTFCE: single; + lOutNameMod: string; +begin + result := false; + if not NIFTIhdr_LoadHdr(lImageName,lHdr) then begin + ShowMsg('Error reading '+lImageName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + //lHdr.NIFTIhdr.scl_slope := 1; lHdr.NIFTIhdr.scl_inter := 0; + doTFCEbothPolarities (lHdr.NIFTIhdr, lImg, 6 {NumConn}, 2.0 {H}, 0.5 { E}, 0, 0,0,0 ,maxTFCE, maxNegTFCE); + + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.hdr'); + NPMMsg('Creating ' +lOutNameMod); + NIFTIhdr_SaveHdrImg(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lImg,1); + freemem(lImg); +end;*) + + +function MakeMean ( lImages: TStrings; lBinarize,lVariance : boolean; lOutName: string): boolean; +label + 667; +var + lMaskname,lOutNameMod: string; + lMaskHdr: TMRIcroHdr; + lCountRA,lOutImgMn,lOutStDev,lPlankImg: SingleP; + lTotalMemory: double; + lMaskVoxels,lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: integer; + lStDev: boolean; + lT, lSum,lSumSqr,lSD, lMn,lTotalSum,lTotalN: double; + lStatHdr: TNIfTIhdr; + lFdata: file; +begin + + if lImages.count < 2 then begin + ShowMsg('Error: you must select at least two images'); + exit; + end; + lMaskname := lImages[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + ShowMsg('Error reading '+lMaskName); + exit; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lImages,lMaskHdr {lMaskVoxels}) then begin + ShowMsg('File dimensions differ from mask.'); + exit; + end; + + + result := false; + NPMMsgClear; + NPMMsg(GetKVers); + + if (not lVariance) and (not lBinarize) then + lStDev := true + else + lStDev := false; + NPMMsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + NPMMsg('Voxels = '+inttostr(lMaskVoxels)+' '+inttostr(kPlankSz)); + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + NPMMsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + NPMMsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + // fx(kPlankSz,8888); + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + NPMMsg('Number of scans = '+inttostr(lImages.count)); + NPMMsg(' Index,Filename,Intercept,Slope'); + if lBinarize then begin + getmem(lCountRA,lImages.Count*sizeof(single)); + for lPos := 1 to lImages.Count do begin + gInterceptRA[lPos] := 0; + gScaleRA[lPos] := 1; + lCountRA^[lPos] := 0; + end; + end else begin + for lPos := 1 to lImages.Count do begin + NPMMsg(' '+inttostr(lPos)+','+lImages[lPos-1]+','+realtostr(gInterceptRA[lPos],4)+','+realtostr(gScaleRA[lPos],4)); + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + end; + end; + + lTotalSum := 0; + lTotalN := 0; + //createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgMn,lVolVox* sizeof(single)); + if lStDev then + getmem(lOutStDev,lVolVox* sizeof(single)); + for lPlank := 1 to lnPlanks do begin + NPMMsg('Computing plank = ' +Inttostr(lPlank)); + Refresher; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lPosPct := lVoxPerPlank div 100; + for lPos2 := 1 to lVoxPerPlank do begin + if (lPos2 mod lPosPct) = 0 then begin + NPMProgressBar(round((lPos2/lVoxPerPlank)*100)); + refresher; + end; + lPos2Offset := lPos2+lStartVox-1; + lSum := 0; + if lVariance then begin + lSum := sqr(lPlankImg^[lPos2]-lPlankImg^[lVoxPerPlank+lPos2]);//actually variance... + //% signal + //if lPlankImg[lVoxPerPlank+lPos2] <> 0 then + + // lSum := lPlankImg[lPos2]/lPlankImg[lVoxPerPlank+lPos2] + //else + // lSum := 0;//pct signal... + //end % signal + lOutImgMn^[lPos2Offset] := lSum; + lTotalSum := lTotalSum + lOutImgMn^[lPos2Offset]; + lTotalN := lTotalN + 1; + end else begin //not variance + + if lBinarize then begin + for lPos := 1 to lImages.Count do + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] <> 0 then begin + lSum := lSum+1; + lCountRA^[lPos] := lCountRA^[lPos] + 1; + end; + end else + for lPos := 1 to lImages.Count do + lSum := lSum +(gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + // fx(lPos, gScaleRA[lPos],gInterceptRA[lPos]); + lOutImgMn^[lPos2Offset] := lSum/lImages.Count; + if lStDev then begin + //lSum := 0; + //for lPos := 1 to lImages.Count do + // lSum := lSum + (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSumSqr := 0; + for lPos := 1 to lImages.Count do + lSumSqr := lSumSqr + Sqr((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]); + lSD := (lSumSqr - ((Sqr(lSum))/lImages.Count)); + if (lSD > 0) then + lSD := Sqrt ( lSD/(lImages.Count-1)) + else begin + lSD := 0; + + end; + lOutStDev^[lPos2Offset] := lSD; + end; + end; //not variance + if lSum > 0 then begin + lTotalSum := lTotalSum + lOutImgMn^[lPos2Offset]; + lTotalN := lTotalN + 1; + end; + + end; + lStartVox := lEndVox + 1; + end; + if lBinarize then begin + for lPos := 1 to lImages.Count do begin + NPMMsg(' '+inttostr(lPos)+','+lImages[lPos-1]+','+inttostr(round(lCountRA^[lPos])) ); + + lCountRA^[lPos] := 0; + end; + freemem(lCountRA); + end; //if binar + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save mean + + +if lVariance then + lOutNameMod := ChangeFilePostfixExt(lOutName,'var','.hdr') +else + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mean','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); + freemem(lOutImgMn); + if lStDev then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'StDev','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutStDev,1); + freemem(lOutStDev); + end; + + //freemem(lObsp); + freemem(lPlankImg); + NPMMsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + NPMMsgSave(lOutNameMod); + if (lTotalN > 0) then + NPMMsg('num voxels >0 = ' +inttostr(round(lTotalN))+' mean value for voxels >0: '+floattostr(lTotalSum/lTotalN)); + + NPMProgressBar(0); + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + NPMMsg('Unable to complete analysis.'); + NPMProgressBar(0); +end; +function ComputeLesionVolume (lImgName: string): integer; +var + lHdr: TMRIcroHdr; + lImg: byteP; + lVolVox,lVox:integer; +begin + result := -1; //error + NIFTIhdr_LoadHdr(lImgName,lHdr); + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + getmem(lImg,lVolVox*sizeof(byte)); + if not LoadImg8(lImgName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load ' +lHdr.ImgFileName); + freemem(lImg); + exit; + end; + result := 0; + for lVox := 1 to lVolVox do + if (lImg^[lVox] <> 0) then + inc(result); + freemem(lImg); +end; + +function NPMAnalyze (var lImages: TStrings; var lMaskname: string; lMaskVoxels,lnGroup1: integer; lNPMPrefs: TNPMPrefs; var lOutName: string): boolean; + +label + 667; +var + //lOutName, + lOutNameMod: string; + lMaskHdr: TMRIcroHdr; + lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lDummy: SingleP; + lTotalMemory: double; //not integer - limit for 32bit int is 2Gb + lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lThreadStart,lThreadEnd,lThreadInc: integer; + lT, lSum, lMn: double; + lStatHdr: TNIfTIhdr; + lFdata: file; + lThread: integer; + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + result := false; + NPMMsgClear; + NPMMsg(GetKVers); + NPMMsg('Threads: '+inttostr(gnCPUThreads)); + + NPMMsg('Mask name = '+ lMaskname); + NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + NPMMsg('Scans in Group 1 = '+inttostr(lnGroup1)); + NPMMsg('Scans in Group 2 = '+inttostr(lImages.count-lnGroup1)); + if (lnGroup1 < 1) or ((lImages.count-lnGroup1) < 1) then begin + ShowMsg('Error: group size(s) too small'); + exit; + end; + + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showMsg('Error reading mask.'); + exit; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + ShowMsg('Mask file size too small.'); + exit; + end; + if not CheckVoxelsGroupX(lImages,lMaskHdr ) then begin + ShowMsg('File dimensions differ from mask.'); + exit; + end; + + + NPMmsg('Permutations = ' +IntToStr(lNPMPrefs.nPermute)); + NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + //load mask + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(gOffsetRA[0]),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMmsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + //next find start and end of mask + lPos := 0; + repeat + inc(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = lVolVox); + lMinMask := lPos; + lPos := lVolVox+1; + repeat + dec(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = 1); + lMaxMask := lPos; + if lMaxMask = 1 then begin + NPMmsg('Mask appears empty' +lMaskHdr.ImgFileName); + goto 667; + end; + NPMmsg('Mask has voxels from '+inttostr(lMinMask)+'..'+inttostr(lMaxMask)); + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + + getmem(lOutImgMn,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + InitPermute (lImages.Count, lNPMPrefs.nPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgMn^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + ClearThreadData(gnCPUThreads,lNPMPrefs.nPermute); + + for lPlank := 1 to lnPlanks do begin + NPMmsg('Computing plank = ' +Inttostr(lPlank)); + Refresher; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + (*SHITTTT Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TNNStat.Create (ProgressBar1,lttest,lBM,0, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lnGroup1, lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lDummy) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + *) + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadData(gnCPUThreads,lNPMPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + reportBonferroni('Std',lnVoxTested); + //next: save data +(*savedata*) + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save mean + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mean','.hdr'); + if lnVoxTested > 1 then + + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + +if (lNPMPrefs.ttest) and (lnVoxTestED > 1 ) then begin //save Ttest + //reportRange ('ttest', lVolVox, lnVoxTested, lOutImgT); + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lNPMPrefs.nPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + + reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + reportPermute('ttest',lNPMPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); +end; +if (lNPMPrefs.BMtest) and (lnVoxTested > 1 ) then begin //save Brunner Munzel + reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + reportPermute('BM',lNPMPrefs.nPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM','.hdr'); + + {reportFDR ('absT', lVolVox, lnVoxTested, lOutImgBM); + reportPermute('absT',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'absT','.hdr'); + } + //NIFTIhdr_SaveHdr(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr)); + lOutNameMod := changefileext(lOutNameMod,'.img'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); +end;(**) +//next: close images + FreePermute (lNPMPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgMn); + //freemem(lObsp); + freemem(lMaskImg); + freemem(lPlankImg); + NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + NPMMsgSave(lOutNameMod); + NPMProgressBar(0); + result := true; + exit; +667: //you only get here if you aborted ... free memory and report error + if lVolVox > 1 then freemem(lMaskImg); + if lTotalMemory > 1 then freemem(lPlankImg); + NPMmsg('Unable to complete analysis.'); + NPMProgressBar(0); +end; + +(*procedure MakeStatHdr (var lBGHdr,lStatHdr: TniftiHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +var lIntentNameLen,lPos: integer; + lStr: string; +begin + move(lBGHdr,lStatHdr,sizeof(TniftiHdr)); + with lStatHdr do begin + magic :=kNIFTI_MAGIC_SEPARATE_HDR; + bitpix := 32; //32-bit real data + datatype := kDT_FLOAT; + scl_slope:= 1; + scl_inter:= 0; + glmin := round(lMinIntensity); + glmax := round(lMaxIntensity); + intent_code := lIntent_Code;// kNIFTI_INTENT_ESTIMATE; + intent_p1 := lIntent_p1; + intent_p2 := lIntent_p2; + intent_p3 := lIntent_p3; + lIntentNameLen := length(lIntentName); + descrip[1] := 'N'; + descrip[2] := 'P'; + descrip[3] := 'M'; + if lIntent_code=kNIFTI_INTENT_TTEST then begin + descrip[4] := 't' ; + lStr := inttostr(trunc(lIntent_p1)); + for lPos := 1 to length (lStr) do + descrip[4+lPos] := lStr[lPos] ; + end else + descrip[4] := 'z'; + if lIntentNameLen > sizeof(intent_name) then + lIntentNameLen := sizeof(intent_name); + if lIntentNameLen > 0 then + for lPos := 1 to lIntentNameLen do + intent_name[lPos] := lIntentName[lPos]; + end; +end; *) + +function NPMzscore (var lImages: TStrings; var lMnHdr,lStDevHdr: TMRIcroHdr): boolean; +label + 667; +var + lOutNameMod: string; + lMnImg,lStDevImg,lSubjImg,lOutImg: SingleP; + lVal: single; + lSubj,lPos,lVolVox: integer; + lStatHdr: TNIfTIhdr; +begin + result := false; + NPMMsg('Analysis began = ' +TimeToStr(Now)); + lVolVox := lMnHdr.NIFTIhdr.dim[1]*lMnHdr.NIFTIhdr.dim[2]* lMnHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + //load mask + for lPos := 0 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + if gScaleRA[kMaxImages] = 0 then + gScaleRA[kMaxImages] := 1; + + getmem(lMnImg,lVolVox*sizeof(single)); + if not LoadImg(lMnHdr.ImgFileName, lMnImg, 1, lVolVox,round(gOffsetRA[0]),1,lMnHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load mean ' +lMnHdr.ImgFileName); + goto 667; + end; + //load StDev + getmem(lStDevImg,lVolVox*sizeof(single)); + if not LoadImg(lStDevHdr.ImgFileName, lStDevImg, 1, lVolVox,round(gOffsetRA[kMaxImages]),1,lStDevHdr.NIFTIhdr.datatype,lVolVox) then begin + NPMMsg('Unable to load StDev ' +lStDevHdr.ImgFileName); + goto 667; + end; + getmem(lOutImg,lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do begin + lMnImg^[lPos] := (gScaleRA[0]*lMnImg^[lPos])+gInterceptRA[0]; + lStDevImg^[lPos] := (gScaleRA[kMaxImages]*lStDevImg^[lPos])+gInterceptRA[kMaxImages]; + if lStDevImg^[lPos] = 0 then + lOutImg^[lPos] := 0; + end; + getmem(lSubjImg,lVolVox* sizeof(single)); + for lSubj := 1 to lImages.Count do begin + NPMProgressBar(round((lSubj/lImages.Count)*100)); + NPMMsg( lImages.Strings[lSubj-1]); + ShowMsg(inttostr(round(gOffsetRA[lSubj]))); + LoadImg(lImages.Strings[lSubj-1], lSubjImg, 1, lVolVox,round(gOffsetRA[lSubj]),1,gDataTypeRA[lSubj],lVolVox); + for lPos := 1 to lVolVox do begin + if lStDevImg^[lPos] <> 0 then begin + lVal := (gScaleRA[lSubj]*lSubjImg^[lPos])+gInterceptRA[lSubj]; + lOutImg^[lPos] := (lVal-lMnImg^[lPos])/lStDevImg^[lPos]; + end; //for each voxel with variance + end; //for each voxel + lOutNameMod := ChangeFilePostfixExt(lImages.Strings[lSubj-1],'Z','.hdr'); + MakeStatHdr (lMnHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lVolVox,kNIFTI_INTENT_ZSCORE,inttostr(lVolVox) ); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMnHdr.NIFTIhdr),true,lOutImg,1); + end; //for each subj + freemem(lSubjImg); + freemem(lOutImg); + freemem(lMnImg); + freemem(lStDevImg); + NPMMsg('Analysis finished = ' +TimeToStr(Now)); + NPMProgressBar(0); + result := true; + exit; +667: //you only get here if you aborted ... free memory and report error + if lVolVox > 1 then freemem(lMnImg); + NPMMsg('Unable to complete analysis.'); + NPMProgressBar(0); +end; + +function ChangeName (lInName: string): string; +var + lPath,lName,lExt: string; +begin + FilenameParts (lInName, lPath,lName,lExt); + if length(lName) > 0 then + lName[1] := 'e' + else + lName := 'Unable to convert '+lInName; + result := lPath+lName+lExt; +end; + +function Add2ndScans(var lImageNames: TStrings): boolean; +var + lnSubj,lSubj: integer; + lFilename: string; +begin + result := false; + lnSubj :=lImageNames.Count; + if lnSubj < 1 then + exit; + for lSubj := 1 to lnSubj do begin + lFilename := ChangeName(lImageNames[lSubj-1]); + if not (fileexists4D(lFilename)) then begin + ShowMsg('Unable to find a file named '+ lFilename); + exit; + end; + lImageNames.add(lFilename); + end; + result := true; +end; + +procedure ComputePlankSize (var lPlankMB: integer); +begin + if lPlankMB < 128 then + lPlankMB := 128; + {$IFDEF CPU32} + if lPlankMB > 1536 then + lPlankMB := 1536; //we use signed 32-bit pointers, so we can not exceed 2Gb + {$ELSE} + if lPlankMB > 8000 then + lPlankMB := 8000; //64-bit pointers, perhaps 8Gb is reasonable limit + {$ENDIF} + kPlankSz :=1024 {bytes/kb} * 1024 {bytes/mb} * lPlankMB; + //kVers := GetKVers + ' CacheMB = '+inttostr(kPlankMB); +end; + +procedure DefaultPrefs( var lNPMPrefs: TNPMPrefs); +begin + lNPMPrefs.NULP := true; + lNPMPrefs.ROI := true; + lNPMPrefs.TFCE := 0; + lNPMPrefs.ttest := true; + lNPMPrefs.BMtest := true; + lNPMPrefs.PlankMB := 512; + lNPMPrefs.nPermute := 0; + ComputePlankSize(lNPMPrefs.PlankMB); +end; + +procedure ReadIniFile; +var + lFilename: string; + lThreads: integer; + lIniFile: TIniFile; +begin + DefaultPrefs(gNPMprefs); + lFilename := IniName; + if not FileexistsEx(lFilename) then + exit; + + lIniFile := TIniFile.Create(lFilename); + //ttestmenu.checked := IniBool(lIniFile,'computettest',true); + //BMmenu.checked := IniBool(lIniFile,'computebm',false); + gNPMprefs.ttest := IniBool(lIniFile,'computettest',gNPMprefs.ttest); + gNPMprefs.BMtest := IniBool(lIniFile,'computebm',gNPMprefs.BMtest); + gNPMPrefs.NULP := IniBool(lIniFile,'countlesionpatterns',gNPMPrefs.NULP); + gNPMPrefs.ROI := IniBool(lIniFile,'ROI',gNPMPrefs.ROI); + gNPMPrefs.TFCE := IniInt(lIniFile,'TFCE',gNPMPrefs.TFCE); + gNPMPrefs.PlankMB := IniInt(lIniFile,'CacheMB',gNPMPrefs.PlankMB); + ComputePlankSize(gNPMPrefs.PlankMB); + gNPMPrefs.nPermute := IniInt(lIniFile,'nPermute',gNPMPrefs.nPermute); + //WritePermute(IniInt(lIniFile,'nPermute',0)); + lThreads := IniInt(lIniFile,'nThread', gnCPUThreads ); + if lThreads > gnCPUThreads then + lThreads := gnCPUThreads; + gnCPUThreads := lThreads; + ComputePlankSize(gNPMPrefs.PlankMB); + lIniFile.Free; +end; //ReadIniFile + +procedure WriteIniFile; +var + lIniName: string; + lIniFile: TIniFile; +begin + lIniName := IniName; + if (DiskFreeEx(lIniName) < 1) then + exit; + lIniFile := TIniFile.Create(lIniName); + lIniFile.WriteString('BOOL', 'computettest',Bool2Char(gNPMprefs.ttest)); + lIniFile.WriteString('BOOL', 'computebm',Bool2Char(gNPMprefs.BMtest)); + lIniFile.WriteString('BOOL', 'countlesionpatterns',Bool2Char(gNPMPrefs.NULP)); + lIniFile.WriteString('BOOL', 'ROI',Bool2Char(gNPMPrefs.ROI)); + lIniFile.WriteString('INT', 'TFCE',inttostr(gNPMPrefs.TFCE)); + lIniFile.WriteString('INT', 'CacheMB',inttostr(gNPMPrefs.PlankMB)); + lIniFile.WriteString('INT', 'nPermute',inttostr(gNPMPrefs.nPermute)); + lIniFile.WriteString('INT', 'nThread',inttostr(gnCPUThreads)); + lIniFile.Free; +end; + +procedure FreePermute (lnPermute: integer; var lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP;var lRanOrderp: pointer); +begin + if (lnPermute < 2) then + exit; + Freemem(lRanOrderp); + Freemem(lPermuteMaxT); + Freemem(lPermuteMinT); + Freemem(lPermuteMaxBM); + Freemem(lPermuteMinBM); +end; + +function ReportDescriptives (var RA: SingleP; n: integer): boolean; +var lMn,lSD,lSE,lSkew,lZSkew: double; +begin + SuperDescriptive (RA, n, lMn,lSD,lSE,lSkew,lZSkew); + NPMMsg('mean='+floattostr(lMn)+',StDev='+floattostr(lSD)+',StEr='+floattostr(lSE)+',Skew='+floattostr(lSkew)+',ZSkew='+floattostr(lZSkew)); +end; + + + +function ThreshMap(lThresh: single; lVolVox: integer;lOutImg: singleP): integer; +var + lVox: integer; +begin + result := 0; + for lVox := 1 to lVolVox do + if lOutImg^[lVox] >= lThresh then + inc(result); + + for lVox := 1 to lVolVox do + if lOutImg^[lVox] >= lThresh then + lOutImg^[lVox] := 1 + else + lOutImg^[lVox] := 0; +end; + +procedure sort (lo, up: integer; var r:SingleP); +//62ms Shell Sort http://www.dcc.uchile.cl/~rbaeza/handbook/algs/4/414.sort.p.html +label 999; +var d, i, j : integer; + tempr : single; +begin + d := up-lo+1; + while d>1 do begin + if d<5 then + d := 1 + else + d := trunc( 0.45454*d ); + //Do linear insertion sort in steps size d + for i:=up-d downto lo do begin + tempr := r^[i]; + j := i+d; + while j <= up do + if tempr > r^[j] then begin + r^[j-d] := r^[j]; + j := j+d + end + else goto 999; //break + 999: + r^[j-d] := tempr + end //for + end //while +end; //proc Sort + +function IndexPct(lnPermute: integer; lPct: single; lTop: boolean): integer; +begin + result := round(lnPermute * lPct); + if lTop then + result := (lnPermute - result)+1; + if (result < 1) then + result := 1; + if (result > lnPermute) then + result := lnPermute; +end; + +function ReportThresh (lLabel: string; lnPermute: integer; var lRankedData: singleP;lTop:boolean): double; +begin + result := lRankedData^[IndexPct(lnPermute,0.050,lTop)]; + NPMmsg(lLabel+': permutationFWE '+ + //'0.500='+realtostr(lRankedData[IndexPct(lnPermute,0.500,lTop)],3)+ + ', 0.050='+realtostr({lRankedData^[IndexPct(lnPermute,0.050,lTop)]} result,8)+ + ', 0.025='+realtostr(lRankedData^[IndexPct(lnPermute,0.025,lTop)],8)+ + ', 0.01='+realtostr(lRankedData^[IndexPct(lnPermute,0.010,lTop)],8)+ + ' '); +end; + +function reportPermute (lLabel:string; lnPermute: integer; var lPermuteMaxZ, lPermuteMinZ: singleP): double; +begin + result := 0; + if (lnPermute < 2) then + exit; + sort (1, lnPermute,lPermuteMaxZ); + result := ReportThresh(lLabel+'+',lnPermute,lPermuteMaxZ,true); + sort (1, lnPermute,lPermuteMinZ); + ReportThresh(lLabel+'-',lnPermute,lPermuteMinZ,false); + //for lPos := 1 to lnPermute do + // msg(inttostr(lPos)+', '+realtostr(lPermuteMinZ[lPos],4)); + +end; + +function reportFDR (lLabel:string; lnVox, lnTests: integer; var lData: SingleP): double; +var + lC,lN: integer; + lPs: SingleP; + lFDR05r, lFDR01r,lFDR05p, lFDR01p,lMin,lMax : double; +begin + result := 10000; + if (lnTests < 1) or (lnVox < 1) then + exit; + GetMem(lPs,lnTests*sizeof(single)); + for lC := 1 to lnTests do + lPs^[lC] := 0; + lN := 0; + lMin := 0; + lMax := 0; + for lC := 1 to lnVox do begin + if lData^[lC] <> 0 then begin + inc(lN); + if lData^[lC] > lMax then lMax := lData^[lC] + else if lData^[lC] < lMin then lMin := lData^[lC]; + if lN <= lnTests then + lPs^[lN] := pNormal(lData^[lC]); + end; + end; + EstimateFDR2(lnTests, lPs, lFDR05p, lFDR01p,lFDR05r, lFDR01r); + NPMmsg(lLabel+' Range ' + +realtostr(lMin,3)+ + '...'+realtostr(lMax,3)); + {Msg(lLabel+' Range ' + +realtostr(pNormalInv(lPs[lnTests]),3)+ + '...'+realtostr(pNormalInv(lPs[1]),3)+ + ' '); } //we could use this and save time computing lmin/lmax, but loss in precision + NPMmsg(lLabel+' +FDR Z '+ + '0.050='+realtostr(pNormalInv(lFDR05p),8)+ + ', 0.01='+realtostr(pNormalInv(lFDR01p),8)+ + ' '); + NPMmsg(lLabel+' -FDR Z '+ + '0.050='+realtostr(pNormalInv(1-lFDR05r),8)+ + ', 0.01='+realtostr(pNormalInv(1-lFDR01r),8)+ + ' '); + result := pNormalInv(lFDR01p); +end; + + +function reportBonferroni(lLabel: string; lnTests: integer): double; //returns 5% Z score +begin + if lnTests < 1 then exit; + result := pNormalInv(0.05/lnTests); + NPMmsg(inttostr(lnTests)+' test '+lLabel+' Bonferroni FWE Z '+ + '0.050='+realtostr(result,3)+ + ', 0.025='+realtostr(pNormalInv(0.025/lnTests),3)+ + ', 0.01='+realtostr(pNormalInv(0.01/lnTests),3)); +end; + + +procedure NPMThreadDone; +begin + Dec(gThreadsRunning); +end; + + +procedure InitRA (lnPermute: integer; var lRA: singleP); +var + lInc: integer; +begin + getmem(lRA,lnPermute* sizeof(single)); + for lInc := 1 to lnPermute do + lRA^[lInc] := 0; +end; + +procedure InitPermute (lnSubj, lnPermute: integer; var lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; var lRanOrderp: pointer; var lRanOrder: Doublep0); +begin + if (lnPermute < 2) then + exit; + InitRA(lnPermute,lPermuteMaxT); + InitRA(lnPermute,lPermuteMinT); + InitRA(lnPermute,lPermuteMaxBM); + InitRA(lnPermute,lPermuteMinBM); + createArray64(lRanOrderp,lRanOrder,lnSubj); +end; //init permute + +initialization + {$IFNDEF GUI} + NPMmemo:= TStringList.Create; + {$ENDIF} + +finalization +{$IFNDEF GUI} + NPMmemo.Free; +{$ENDIF} +end. + diff --git a/npm/unpm.ppu b/npm/unpm.ppu new file mode 100644 index 0000000..d0c91c9 Binary files /dev/null and b/npm/unpm.ppu differ diff --git a/npm/upower.o b/npm/upower.o new file mode 100644 index 0000000..d975cfd Binary files /dev/null and b/npm/upower.o differ diff --git a/npm/upower.pas b/npm/upower.pas new file mode 100755 index 0000000..da55d0e --- /dev/null +++ b/npm/upower.pas @@ -0,0 +1,116 @@ +unit upower; +interface + +uses define_types, statcr, distr, dialogsx; +function Sum2Power(lOutImgSum: SingleP; lVolVox,lnTotal,lnDeficit: integer; lBinomial: boolean): boolean; +function Sum2PowerCont(lOutImgSum: SingleP; lVolVox,lnTotal: integer): boolean; +function Sum2PowerBinom(lOutImgSum: SingleP; lVolVox,lnTotal,lnDeficit: integer): boolean; +function k_out_n (k,n: integer): double; //total possible permutations + +implementation + +function k_out_n (k,n: integer): double; //total possible permutations +//k= smaller group, n=sum of both groups +begin + if not gFactRAready then InitFact; + result := round(gFactRA[n] / (gFactRA[k]*gFactRA[n-k] ) ); +// k out n = n!/(k!*(n-k)! which is equal to the PROD(i=k; 1){(n-i+1)/i} +end; //k_out_n + +function Sum2Power(lOutImgSum: SingleP; lVolVox,lnTotal,lnDeficit: integer; lBinomial: boolean): boolean; +begin + if lBinomial then + result := Sum2PowerBinom(lOutImgSum, lVolVox,lnTotal,lnDeficit) + else + result := Sum2PowerCont(lOutImgSum, lVolVox,lnTotal) +end; + +function Sum2PowerCont(lOutImgSum: SingleP; lVolVox,lnTotal: integer): boolean; +//convert Sum image to power map showing maximum possible effect size +//'Cont' version is for continuous data +var + lDensity,lN,lRank: integer; + lDensityPowerRA: singleP; +begin + result := false; + if (lnTotal < 2) or (lVolVox < 1) then + exit; + getmem(lDensityPowerRA,lnTotal* sizeof(single)); + //no need to compute power for [lnTotal] and [0] - no variability when everyone or no one has a lesion + //lDensityPowerRA[lnTotal] := 0; //everyone has a lesion = no variability + lRank := 0; + for lN := 1 to (lnTotal -1) do begin + //most power when all participants with a lesion have most extreme behavioural data + //therefore, they will have the lowest ranks: rank 1,2,3,4 + lRank := lRank + lN; + if (lnTotal > 360) then //cannot calculate values this large... + lDensityPowerRA^[lN] := 0 + else if (lN > 10) and (lnTotal > 64) then //avoid overflow... + lDensityPowerRA^[lN] := pNormalInv ( 1/(k_out_n(10,lnTotal)) ) + else begin + lDensityPowerRA^[lN] := 1/(k_out_n(lN,lnTotal)); //compute Wilcoxon probability + lDensityPowerRA^[lN] := pNormalInv (lDensityPowerRA^[lN]);//convert p to z-score + end; + //max power when every possible person with a lesion has a defict, and everyone w/o lesion does not... + //lDensityPowerRA[lN] := Liebermeister (lLD,lnoLD,lLnoD,lnoLnoD); //probability of this observation + //lDensityPowerRA[lN] := pNormalInv (lDensityPowerRA[lN]);//convert p to z-score + //fx(lDensityPowerRA[lN]); + end; + //now use lookup table to convert overlay density to effective power + for lN := 1 to lVolVox do begin + lDensity := round( lOutImgSum^[lN]); + if (lDensity > 0) and (lDensity < lnTotal) then + lOutImgSum^[lN] := lDensityPowerRA^[lDensity] + else + lOutImgSum^[lN] := 0; + end; //for each voxel + freemem(lDensityPowerRA); + result := true; +end; + +function Sum2PowerBinom(lOutImgSum: SingleP; lVolVox,lnTotal,lnDeficit: integer): boolean; +//convert Sum image to power map showing maximum possible effect size +var + lDensity,lN,lLD,lLnoD,lnoLD,lnoLnoD: integer; + lDensityPowerRA: singleP; +begin + result := false; + if (lnTotal < 2) or (lnDeficit < 1) or (lVolVox < 1) then + exit; + if(lnDeficit >= lnTotal) then begin + ShowMsg('Sum2Power error: people with deficit must be less than sample size'); + exit; + end; + getmem(lDensityPowerRA,lnTotal* sizeof(single)); + //no need to compute power for lnTotal and 0 - no variability when everyone or no one has a lesion + //lDensityPowerRA[lnTotal] := 0; //everyone has a lesion = no variability + for lN := 1 to (lnTotal -1) do begin + //max power when every possible person with a lesion has a defict, and everyone w/o lesion does not... + if lN > lnDeficit then begin + lLD := lnDeficit; + lLnoD := lN - lnDeficit; + end else begin + lLD := lN; + lLnoD := 0; + end; + lnoLD := lnDeficit-lLD; //number of people with deficit who do not have a lesion - as close to zero as possible + lnoLnoD := lnTotal-lnoLD-lLnoD-lLD; + lDensityPowerRA^[lN] := Liebermeister (lLD,lnoLD,lLnoD,lnoLnoD); //probability of this observation + lDensityPowerRA^[lN] := pNormalInv (lDensityPowerRA^[lN]);//convert p to z-score + //fx(lLD,lnoLD,lLnoD,lnoLnoD,lDensityPowerRA[lN]); + end; + //now use lookup table to convert overlay density to effective power + for lN := 1 to lVolVox do begin + lDensity := round( lOutImgSum^[lN]); + if (lDensity > 0) and (lDensity < lnTotal) then + lOutImgSum^[lN] := lDensityPowerRA^[lDensity] + else + lOutImgSum^[lN] := 0; + + end; //for each voxel + freemem(lDensityPowerRA); + result := true; +end; + + +end. \ No newline at end of file diff --git a/npm/upower.ppu b/npm/upower.ppu new file mode 100644 index 0000000..551c752 Binary files /dev/null and b/npm/upower.ppu differ diff --git a/npm/valformat.o b/npm/valformat.o new file mode 100644 index 0000000..f4eb7ac Binary files /dev/null and b/npm/valformat.o differ diff --git a/npm/valformat.pas b/npm/valformat.pas new file mode 100755 index 0000000..3de7f47 --- /dev/null +++ b/npm/valformat.pas @@ -0,0 +1,301 @@ +unit valformat; +{$H+} +interface +uses + {$IFNDEF UNIX} Windows,{Registry,ShlObj,}{$ENDIF} + //Messages, Graphics, Controls, Forms, Dialogs, + SysUtils, Classes,dialogsx, + //Grids, Menus, ToolWin, ComCtrls, Buttons,Clipbrd, StdCtrls,Spin, ,npmform + define_types; +const +{$IFDEF FPC} + kNaN = -maxint; +{$ELSE} + kNaN : double = 1/0; +{$ENDIF} + kVALNativeSignatureBase = '#Version:'; + kValMaxVers = 1; //version 0 = 3D, version 1 = 4D, version 2 not yet supported + kTxtExt = '.txt'; + kVALNativeExt = '.val'; + kValFilter = 'Text description (*.val)|*.val'; +function RowColPos (lRow,lCol,lnCol: integer): integer; +function OpenValFile (var lFilename,lTemplateName:string; var lnRow,lnCol,lnColWObs,lnCritPct: integer; + var lDesignUnspecified : boolean; var lPredictorList,lFileList:TStringList; var lDoublePtr: Pointer): boolean; + +function GetValCore (var lVALFilename:string; var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit,lCritPct: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean; + +implementation + +procedure MsgX (lStr: string); +begin + //output something here + showmsg(lStr); +end; + + + +function VALNativeSignature (lStr: string): boolean; +var + lP,lLen: integer; + lVers: string; +begin + result := false; + lLen := length(lStr); + if lLen < (length(kVALNativeSignatureBase)+1) then + exit; + for lP := 1 to length(kVALNativeSignatureBase) do + if lStr[lP] <> kVALNativeSignatureBase[lP] then + exit; + //VAL format, but can we read this version? + for lP := (length(kVALNativeSignatureBase)+1) to lLen do + lVers := lVers + lStr[lP]; + if strtoint(lVers) <= kValMaxVers then + result := true; +end; + +function ReadTabStr (var lStr: string; var lPos: integer): string; +var + lLen: integer; +begin + result := ''; + if lPos < 1 then lPos := 1; + lLen := length(lStr); + while (lPos <= lLen) and (lStr[lPos] <> kTab) do begin + result := result + lStr[lPos]; + inc(lPos); + end; + inc(lPos); +end; + +function RowColPos (lRow,lCol,lnCol: integer): integer; +begin + result := ((lRow-1{alfa})*lnCol)+lCol; +end; + +//Replicates Readln, but works for Unix files... Delphi 4's readln fails for non-MSDOS EOLs +procedure ReadlnX (var F: TextFile; var lResult: string); +var + lCh: char; +begin + lResult := ''; + while not Eof(F) do begin + Read(F, lCh); + if (lCh in [#10,#13]) then begin + if lResult <> '' then begin + //Showmessage(lResult); + exit; + end; + end else + lResult := lResult + lCh; + end; +end; //ReadlnX + +function OpenValFile (var lFilename,lTemplateName:string; var lnRow,lnCol,lnColwObs,lnCritPct: integer; + var lDesignUnspecified : boolean; var lPredictorList,lFileList:TStringList; var lDoublePtr: Pointer): boolean; +var + lNumStr,lStr,lExt,lPrevNumStr,lCmdStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lPos,MaxC,R,C:integer; + lDoubleBuf: DoubleP; + lError: boolean; + lDecimalSep: char; +begin + lnRow := 0; + lnCol := 0; + result := false; + if not fileexists(lFilename) then exit; + lError:= false; + lnCritPct := 0; + lExt := StrLower(PChar(extractfileext(lFilename))); + if (lExt = kTxtExt) or (lExt = kVALNativeExt) then + else begin + ShowMsg('This version is unable to recognize the extension of the file: '+lFilename); + exit; + end; + lDecimalSep := DecimalSeparator; + DecimalSeparator := '.'; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + if lExt = kVALNativeExt then begin + ReadlnX(F,lStr);//Version + if not VALNativeSignature(lStr) then begin + showMsg('This software can not read this file. Perhaps you need to upgrade your software. The first line should read "'+kVALNativeSignatureBase+'x" where "x" is <'+inttostr(kValMaxVers+1)); + CloseFile(F); + FileMode := 2; //Set file access to read/write + exit; + end; + lDesignUnspecified := false; + lStr := '#'; + while (length(lStr)> 0) and (lStr[1] = '#') and (not Eof(F)) do begin + ReadlnX(F,lStr); + lPos := 0; //start at beginning of line + lCmdStr := ReadTabStr(lStr,lPos); + if lCmdStr = '#Template' then + lTemplateName := ReadTabStr(lStr,lPos); + if lCmdStr = '#CritPct' then + lnCritPct := StrToInt(ReadTabStr(lStr,lPos)); + end; + if (length(lStr)> 0) and (lStr[1] = '#') then showmsg(lCmdStr); + end else begin + lnCritPct := 0; + lDesignUnspecified := true; + lTemplateName := '-'; + end;//Ext=native version + Reset(F); + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9]) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); +lnRow:= R; +lnCol := MaxC-1; + lnColWObs := lnCol+1; + getmem(lDoublePtr,(lnRow*lnColWObs* sizeof(double))+16); + {$IFDEF FPC} + lDoubleBuf := align(lDoublePtr,16); + {$ELSE} + //lDoubleBuf := DoubleP((integer(lDoublePtr) and $FFFFFFF0)+16); + lDoubleBuf := DoubleP($fffffff0 and (integer(lDoublePtr)+15)); + {$ENDIF} + for C := 1 to (lnRow*lnColWObs) do + lDoubleBuf^[C] := 0; + //Second pass: fill values + Reset(F); + C := 0; + MaxC := 0; + R := 1; + lNumStr := ''; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9]) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + //read current entry + if R = 1 then begin //1st Row + if C > 0 then + lPredictorList.Add( lNumStr) + end else if C = 0 then begin //1st Row + //showmessage(lNumStr); + lFileList.Add( lNumStr) + end else begin //note: below -1 as we strip first header row for predictor names + if lNumStr = '-' then begin + lDoubleBuf^[RowColPos (R-1{ july 06 alfa},C,lnColWObs)] := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + + except + on EConvertError do begin + if not lError then + showmsg('Empty cells? Error reading VAL file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := knan; + end; + end; + lDoubleBuf^[RowColPos (R-1{ july 06 alfa},C,lnColWObs)] := lTempFloat;//DataGrid.Cells[ C, kMaxFactors+R-1 ] := (lNumStr) ; + end; + end; + lPrevNumStr := lNumStr; + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C>0) then //alfa read data immediately prior to EOF + lDoubleBuf^[RowColPos (R-1{alfa},C,lnColWObs)] := strtofloat(lNumStr); + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; + DecimalSeparator := lDecimalSep; + //fx(lPredictorList.Count,lnCol); + if lPredictorList.Count < lnCol then begin + for C := (lPredictorList.Count+1) to lnCol do + lPredictorList.Add('Predictor'+inttostr(C)); + end; +end; + + +function GetValCore (var lVALFilename:string; var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit,lCritPct: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean; +//warning: you MUST free lPredictorList +var + lTemplateName: string; + lnRow,lCol,lnColWObs,lInc,lRow: integer; + lDesignUnspecified : boolean; + lFileList:TStringList; + lInRA: DoubleP0; + lInP: Pointer; +begin + lPredictorList := TStringList.Create; + result := false; + lnSubj := 0; + if not Fileexists(lVALFilename) then begin + + MsgX('NPM aborted: VAL file selection failed:' +lValFilename); + exit; + end; //if not selected + lFileList := TStringList.Create; + //MsgX( 'VAL filename: '+lVALFilename); + if not OpenValFile (lVALFilename,lTemplateName, lnRow,lnFactors,lnColWObs,lCritPct, + lDesignUnspecified,lPredictorList,lFileList, lInP) then exit; + + if lnRow > 1 then begin + lnSubj := lnRow -1; //top row is predictor + {$IFDEF FPC} + lInRA := align(lInP,16); + {$ELSE} + lInRA := DoubleP0($fffffff0 and (integer(lInP)+15)); + {$ENDIF} + + getmem(lSymptomRA,lnSubj*lnFactors* sizeof(single)); + for lCol := 1 to lnFactors do begin + for lRow := 1 to lnSubj do begin + lSymptomRA^[lRow+ ((lCol-1)*lnSubj)] := lInRA^[(lRow*lnColWObs)-lnColWObs-1+lCol]; + end; + end; + for lInc := 1 to lnSubj do + lImageNames.add(ExtractFileDirWithPathDelim(lVALFilename)+lFileList.Strings[lInc-1]); + //end reverse + end; //for lRow = each subject + lFileList.free; + Freemem(lInP); + + lCrit := round( (lnSubj*lCritPct)/100); + result := true; +end; + + +end. + \ No newline at end of file diff --git a/npm/valformat.ppu b/npm/valformat.ppu new file mode 100644 index 0000000..decdbaf Binary files /dev/null and b/npm/valformat.ppu differ diff --git a/npm/windowsxp.res b/npm/windowsxp.res new file mode 100755 index 0000000..5f33505 Binary files /dev/null and b/npm/windowsxp.res differ diff --git a/npm/wlsFLU.nii.gz b/npm/wlsFLU.nii.gz new file mode 100755 index 0000000..6cfa648 Binary files /dev/null and b/npm/wlsFLU.nii.gz differ diff --git a/npm/xLesionStatThds.pas b/npm/xLesionStatThds.pas new file mode 100755 index 0000000..e4f6a5b --- /dev/null +++ b/npm/xLesionStatThds.pas @@ -0,0 +1,446 @@ +unit LesionStatThds; + +interface + +uses + SysUtils, + ComCtrls,Classes, Graphics, ExtCtrls, define_types,stats,StatThdsUtil,Brunner,lesion_pattern; + + + +type + + TLesionStatThread = class(TThread) + private + lBarX: TProgressBar; + lttestx,lBMx: boolean; + lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx, + lImagesCountx,lControlsx : integer; + lPlankImgx:ByteP; + lOutImgMnx,lOutImgBMx,lOutImgTx,lOutImgAUCX,lSymptomRAx: SingleP; + //lBarX: TProgressBar; + procedure DoVisualSwap; + protected + procedure Execute; override; + procedure VisualProg(lPos: Integer); + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg:bytep;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); virtual; abstract; + public + constructor Create(lBar: TProgressBar;lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg:ByteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); + end; + + { Lesion - image reveals value } + + TLesionContinuous = class(TLesionStatThread ) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); override; + end; + + TLesionBinom = class(TLesionStatThread ) + protected + procedure Analyze(lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgL,lOutImgX,lOutImgAUC,lSymptomRA: SingleP); override; + end; + +implementation + +(*procedure OutStr(lStr: string); +var + lOutname: string; + f: TextFile; +begin + lOutname:='c:\fx.txt'; + if fileexists(lOutname) then + begin { open a text file } + AssignFile(f, lOutname); + Append(f); + Writeln(f, lStr); + Flush(f); { ensures that the text was actually written to file } + { insert code here that would require a Flush before closing the file } + CloseFile(f); + end; +end; +*) + +Const Two32 = 4294967296.0 ; +function GenRandThreaded(lRange: integer; var lRandSeed:comp): integer; +//normal random function does not work well when threaded - randseed is changed by each thread +const lFactor = $08088405 ; lTerm = 1 ; +type lT = array [0..1] of longint ; +var + lX: extended; +begin + lRandSeed := lRandSeed*lFactor + lTerm; + lT(lRandSeed)[1] := 0 ; // < May'04 was: RS := RS - Trunc(RS/Two32)*Two32 ; + lX := lRandSeed/Two32 ; + result := trunc((lRange)*lX); +end; + +procedure GenPermuteThreaded (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: double; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + + +procedure StatPermuteThreaded (lttest,lBM: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT,lDF,lBMz: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lttest then begin + TStat2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lBM then begin + //BMTest (lnSubj, lnGroup0, lRanOrder,lOutT); + tBM (lnSubj, lnGroup0, lRanOrder,lBMz,lDF); + lBMz := BMzVal (lnSubj, lnGroup0,lBMz,lDF); + + if lBMz > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lBMz; + if lBMz < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lBMz; + end; //compute BM + end; + freemem(lRanOrderp); +end; + +procedure GenPermuteThreadedBinom (lnSubj: integer; var lOrigOrder,lRanOrder: ByteP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: byte; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteBinomialThreaded (lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: ByteP0); +var + lInc: integer; + lOutP: double; + lRS: Comp; + lRanOrder: byteP0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + //createArray64(lRanOrderp,lRanOrder,lnSubj); + getmem(lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreadedBinom(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + (*if lChi2 then begin + Chi2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lLieber then begin*) + //Liebermeister2bP (lnSubj, lnGroup0, lRanOrder,lOutP); + Liebermeister2bP (lnSubj, lnGroup0, lRanOrder,lOutP); + if (lOutP > 0) and (lOutP < gPermuteMinT[lThread,lInc]) then begin //negative correlation + //fx(lOutP, gPermuteMinBM[lThread,lInc]); + gPermuteMinT[lThread,lInc] := lOutP; + end; + if (lOutP < 0) and ( lOutP > gPermuteMaxT[lThread,lInc]) then //negative correlation + gPermuteMaxT[lThread,lInc] := lOutP; + //end; //compute BM + end; + freemem(lRanOrder); +end; + +procedure TLesionStatThread .DoVisualSwap; +begin + lBarX.Position := lBarPosX; +end; + +procedure TLesionStatThread .VisualProg(lPos: Integer); +begin + lBarPosX := lPos; + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} +end; + +constructor TLesionStatThread.Create(lBar: TProgressBar; lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); +begin + lBarX := lBar; + lttestx := lttest; + lBMx:= lBM; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lControlsX := lControlsIn; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgBMx := lOutImgBM; + lOutImgTx := lOutImgT; + lOutImgAUCx := lOutImgAUC; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + FreeOnTerminate := True; + inherited Create(False); +end; + + + +{ The Execute method is called when the thread starts } + +procedure TLesionStatThread .Execute; +begin + Analyze(lttestx,lBMx, lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lControlsx,lPlankImgX,lOutImgMnx,lOutImgBMx,lOutImgTx,lOutImgAUCx,lSymptomRAx); +end; + + +procedure TLesionContinuous.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIN : integer; lPlankImg:bytep;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); +//pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsT,lPrevZValsBM,lPrevAUCVals: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + lStr: string; + lObstp,lObsp: pointer; + lObst,lObs: Doublep0; + lT,lBMz,lDF: Double; + lObsB: bytep0; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnControl, + lnControlsPlusLesion,lnControlsPlusPatients : integer; +begin //statthread + //init patterns + lnControl := abs(lControlsIn); + if lControlsIn < 0 then begin //binomial + getmem(lObsB, lImagesCount+lnControl); + end; + lnControlsPlusPatients := lImagesCount+lnControl; + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + //lMaxLesion := lImagesCount-lnCrit; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lnControlsPlusPatients); + lPosPct := (lThreadEnd-lThreadStart) div 100; + //if lThread = 1 then + // OutStr( inttostr(lThreadStart)+':'+inttostr(lThreadEnd)); //xxxxx + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] = 0 then begin + //no lesion + inc(lnNoLesion); + lLesionOrderp^[lPos] := 0; + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + //lObs^[lImagesCount-lnLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) {and (lnLesion <= lMaxLesion)} then begin + inc(gnVoxTestedRA[lThread]); + //now check if we have seen this precise lesion order recently... + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + if lttest then + lOutImgT^[lPos2Offset] := lPrevZvalsT[lPos]; + if lBM then + lOutImgBM^[lPos2Offset] := lPrevZvalsBM[lPos]; + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lPrevAUCvals[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + lnControlsPlusLesion := lnControlsPlusPatients; + if (lControlsIn > 0) {and (lnLesion > 0)} then begin //anaCOm + createArray64(lObstp,lObst,lImagesCount); + for lPos := 1 to lImagesCount do + lObst^[lPos-1] := lObs^[lPos-1]; + for lPos := 1 to lnLesion do + lObs^[lPos-1+lnControl] := lObst^[lPos-1+lnNoLesion]; + freemem(lObstP); + for lPos := 1 to lnControl do + lObs^[lPos-1] := lSymptomRA^[lPos+lImagesCount]; + lnControlsPlusLesion := lnControl+lnLesion; + lnNoLesion := {lnNoLesion +} lnControl; + end;//controls + (*if lPos2 = 2570879 then begin //xxxx + for lPos := 1 to lImagesCount do begin + outstr(inttostr(lPos)+'>'+floattostr(lObs^[lPos-1]) ); + end; + end;*) + + if lttest then begin + if lControlsIn > 0 then begin//anacom + TStat2Z (lnControlsPlusLesion, lnControl {lnNoLesion},lObs,lT); +(* if lPos2 = 2570879 then begin + outstr( floattostr(lT)+ ' '+inttostr(lnControl)); //xxxx + for lPos := 1 to lnControlsPlusLesion do begin + outstr(inttostr(lPos)+', '+floattostr(lObs^[lPos-1]) ); + end; + + end; *) + end else + TStat2 (lnControlsPlusLesion, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + lPrevZValsT[lPatternPos] := lT; + end; + + if lBM then begin + tBM (lnControlsPlusLesion, lnNoLesion, lObs,lBMz,lDF); + lBMz := BMzVal (lnControlsPlusPatients, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + lPrevZValsBM[lPatternPos] := lBMz; + end; + if lOutImgAUC <> nil then begin + lOutImgAUC^[lPos2Offset] := continROC (lnControlsPlusLesion, lnNoLesion, lObs); + lPrevAUCVals[lPatternPos] := lOutImgAUC^[lPos2Offset]; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //novel lesion pattern + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp); + if lControlsIn < 0 then //binomial + freemem(lObsB); + + +end; + +procedure TLesionBinom.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: bytep;lOutImgMn,lOutImgL,lOutImgX,lOutImgAUC,lSymptomRA: SingleP); +//procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); + //pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsL ,lPrevAUCVals: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + //lObsp: pointer; + //lObs: Doublep0; lPrevZVals + lObs: ByteP0; + lAUC,lZ: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //Binomial StatThread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + //createArray64(lObsp,lObs,lImagesCount); + getmem(lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := round(lSymptomRA^[lPos]); + lLesionOrderp^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lnLesion-1] := round(lSymptomRA^[lPos]); //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + //next check patterns + //x lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + //if lChi2 then + // lOutImgX^[lPos2Offset] := lPrevZvalsX[lPos]; + //if lLieber then + lOutImgL^[lPos2Offset] := lPrevZvalsL[lPos]; + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lPrevAUCvals[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + {if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + lPrevZValsX[lPatternPos] := lT; + end; + if lLieber then begin} + Liebermeister2b(lImagesCount, lnLesion, lObs,lAUC,lZ); + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lAUC; + lPrevAUCVals[lPatternPos] := lAUC; + lOutImgL^[lPos2Offset] := lZ; + lPrevZValsL[lPatternPos] := lZ; + //end; + StatPermuteBinomialThreaded (lImagesCount, lnLesion,lnPermute,lThread, lObs); + + end; + end; //in brain mask - compute + end; //for each voxel + freemem(lObs); + freemem(lLesionOrderp) +end; + +end. diff --git a/npm/xanacom.pas b/npm/xanacom.pas new file mode 100755 index 0000000..667ff44 --- /dev/null +++ b/npm/xanacom.pas @@ -0,0 +1,630 @@ +unit anacom; +interface +{$H+} +uses + define_types,SysUtils,part,StatThds,statcr,StatThdsUtil,Brunner, + DISTR,nifti_img, hdr,filename,Messages, Classes, Graphics, + Controls, Forms, Dialogs,StdCtrls,ComCtrls,ExtCtrls,Menus, overlap, + ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + upower,firthThds,firth,IniFiles,cpucount,userdir,math, + {$IFDEF FPC} LResources,gzio2, + {$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math + {$IFNDEF UNIX} Windows, {$ENDIF} + regmult,utypes; + + function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; + procedure DoAnaCOM; + function readTxt (lFilename: string; var lnObservations : integer; var ldataRA1: singlep): boolean; + + +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lCombinedSymptomRA: singleP; + lPos,lPlank,lThread,lnControlsPlusPatients: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshBonf,lThreshPermute,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lSave,lBM,lttest,lLtest: boolean; + lnControlNeg: integer; + + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + lSave := true; + lnControlNeg := lnControl; //negative for binomial test + lttest := lttestin; + lbm := lbmin; + if (not (lttest)) and (not (lbm)) then begin + lLtest := true; + lBM := true; + lnControlNeg := -lnControl; + end; + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + if lnControl < 1 then begin + MainForm.NPMmsg('AnaCOM aborted - need data from at least 1 control individual'); + exit; + end; + lnPermute := 0;//MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + lnControlsPlusPatients := lImages.Count+lnControl; + createArray64(lObsp,lObs,lnControlsPlusPatients); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + //sumptom array for lesions AND controls + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + for lPos := 1 to lnControl do + lObs^[lPos-1+lImages.Count] := lControlSymptomRA^[lPos]; + getmem(lCombinedSymptomRA,lnControlsPlusPatients* sizeof(single)); + for lPos := 1 to lnControlsPlusPatients do + lCombinedSymptomRA^[lPos] := lObs^[lPos-1]; + //next create permuted BM bounds + if lBM then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + //for lPos := 1 to lImages.Count do + // lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lnControlsPlusPatients, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + + with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lnControlNeg,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,nil,lCombinedSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + //Next: NULPS + if lRun > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lnCrit,lnVoxTested,lPlankImg)); + + //lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit)); + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if (lSave) and (lRun < 1) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lSave) and (lRun < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + + if lnControl < 1 then //do not convert t-scores for anaCOM - numbers vary from voxel to voxel... + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('attest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'attest'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaComthreshtt,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + if lSave then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Mann Whitney + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('aBM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'aBM'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaCOMthreshbm,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + if lSave then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + freemem(lCombinedSymptomRA); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + if lSave then + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + + + +(*function readCSV2 (lFilename: string; lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) or (MaxC < (kHdrCol+lCol2)) then begin + showmessage('problems reading CSV - not enough columns/rows '+inttostr(lCol1)+' '+inttostr(lCol2)); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := MaxC-1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + getmem(ldataRA2,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) or ((C-kHdrCol) = lCol2) then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then + ldataRA1^[R-kHdrRow] := lTempFloat + else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat; + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + ldataRA2^[R-1] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; *) + +function readTxt (lFilename: string; var lnObservations : integer; var ldataRA1: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lCol1: integer; + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; +begin + lCol1:= 1; + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) then begin + showmessage('problems reading CSV - not enough columns/rows '); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := kHdrCol+lCol1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) {or ((C-kHdrCol) = lCol2)} then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then begin + //showmessage(lNumStr); + ldataRA1^[R-kHdrRow] := lTempFloat; + end; + {else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat;} + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + //showmessage(lNumStr+' '+inttostr(lnFactors)+' '+inttostr(C)); + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(inttostr(R)+' '+floattostr(lTempFLoat)); + ldataRA1^[R] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := not lError; +end; + +procedure DoAnaCOM; +label + 666; +var + lControlFilename: string; + lI, lnControlObservations : integer; + lControldata: singlep; + //lBinomial: boolean; + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('AnaCOM analysis requires TXT/CSV format text file.'); + npmform.MainForm.memo1.lines.add('One row per control participant.'); + npmform.MainForm.memo1.lines.add('First column is performance of that participant.'); + npmform.MainForm.memo1.lines.add('Example file:'); + npmform.MainForm.memo1.lines.add('11'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('2'); + npmform.MainForm.memo1.lines.add('22'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('6'); + if not MainForm.OpenDialogExecute('Select text file',false,false,'Text file (*.txt)|*.txt;*.csv') then begin + showmessage('AnaCOM aborted: Control data file selection failed.'); + exit; + end; //if not selected + lControlFilename := MainForm.OpenHdrDlg.Filename; + if (not readTxt (lControlFilename, lnControlObservations,lControldata)) or (lnControlObservations < 1) then begin + showmessage('Error reading file '+lControlFilename); + exit; + end; + npmform.MainForm.memo1.lines.add('Control (n='+inttostr(lnControlObservations)+')performance ['+lControlFilename+']'); + for lI := 1 to lnControlObservations do + npmform.MainForm.memo1.lines.add(inttostr(lI)+' '+floattostr(lControldata^[lI])); + //begin - copy + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not MainForm.GetValX(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit,{,binom}lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('AnaCOM error: not enough patients ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st file: '+lMaskName); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then exit; + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + MainForm.NPMmsgClear; + MainForm.NPMMsg(MainForm.GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + npmform.MainForm.memo1.lines.add('Control (n='+inttostr(lnControlObservations)+')performance ['+lControlFilename+']'); + for lI := 1 to lnControlObservations do + npmform.MainForm.memo1.lines.add(inttostr(lI)+' '+floattostr(lControldata^[lI])); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Patient performance, (n= '+inttostr(lnSubj)+') Factor = '+lFactname); + For lSubj := 1 to lnSubj do + MainForm.NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroup(lImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + MainForm.ReportDescriptives(lSymptomRA,lnSubj); + AnacomLesionNPMAnalyze(lImageNames,lMaskHdr,lnCrit,-1,lnControlObservations,lSymptomRA,lControldata,lFactName,lOutname,true {ttest},false{BM}); + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then + Freemem(lMultiSymptomRA); + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + freemem(lControldata); +end; + +end. diff --git a/npm/xmontecarlo.pas b/npm/xmontecarlo.pas new file mode 100755 index 0000000..08d36a1 --- /dev/null +++ b/npm/xmontecarlo.pas @@ -0,0 +1,210 @@ +unit montecarlo; +interface +{$H+} +{$DEFINE anacom} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes{$IFDEF anacom} ,anacom{$ENDIF}; + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); + +implementation + +uses npmform,filename,turbolesion; + +procedure RandomGroup(kSamplesPerTest: integer;lImageNames: TStrings;lSymptomRA: SingleP;var lPartImageNames: TStrings; var lPartSymptomRA: SingleP); +var + lTotal,lInc,lRand,lSwap: integer; + lRanOrder: longintP; +begin + lPartImageNames.Clear; + lTotal := lImageNames.Count; + if kSamplesPerTest > lTotal then begin + showmessage('Monte carlo error: population must be larger than sample size.'); + exit; + end; + Getmem(lRanOrder,lTotal*sizeof(longint)); + for lInc := 1 to lTotal do + lRanOrder^[lInc] := lInc; + for lInc := lTotal downto 2 do begin + lRand := Random(lInc)+1; + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc]; + lRanOrder^[lInc] := lSwap; + end; + for lInc := 1 to kSamplesPerTest do begin + lPartImageNames.Add(lImageNames.Strings[lRanOrder^[lInc]-1]);//indexed from 0 + lPartSymptomRA^[lInc] := lSymptomRA^[lRanOrder^[lInc]]; + end; + Freemem(lRanOrder); +end; + + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); +label + 666; +//const + //kSimSampleSize = 64; + //knSim = 2; + //kCrit = 3; + {$IFDEF anacom} + //knControls = 64; + {$ENDIF} +var + lPrefs: TLDMPrefs ; + lCrit,lnSim, lSimSampleSize,lSim,lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lPartImageNames,lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lControlFilename,lTemp4D,lMaskname,lOutName,lFactname,lOutNameSim: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA,lPartSymptomRA: singleP; + {$IFDEF anacom} + lnControlObservations: integer; + lControlSymptomRA: singleP; + {$ENDIF} +begin + lnSim := ReadIntForm.GetInt('Enter total numbers of simulations ', 10,25,1000); + lSimSampleSize := ReadIntForm.GetInt('Number of patients per simulation? ', 2,10,1000); + lCrit := ReadIntForm.GetInt('Only analyze voxels damaged in at least N patients ', 2,10,1000); + //lBinomial := not odd( (Sender as tMenuItem).tag); + lPrefs.NULP := true{gNULP false}; + if not lBinomial then begin + lPrefs.BMtest := lbm;//BMmenu.checked; + lPrefs.Ttest := lttest;//ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.nCrit := lCrit; + lPrefs.nPermute := 0;//MainForm.ReadPermute;; + lPrefs.Run := 0;{0 except for montecarlo} + if (not lBinomial) and (not lTTest) and (not lBM) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPartImageNames := TStringList.Create; + getmem(lPartSymptomRA,lSimSampleSize*sizeof(single)); + {$IFDEF anacom} + if not MainForm.OpenDialogExecute('Select text file',false,false,'Text file (*.txt)|*.txt;*.csv') then begin + showmessage('AnaCOM aborted: Control data file selection failed.'); + exit; + end; //if not selected + lControlFilename := MainForm.OpenHdrDlg.Filename; + if (not readTxt (lControlFilename, lnControlObservations,lControlSymptomRA)) or (lnControlObservations < 1) then begin + showmessage('Error reading file '+lControlFilename); + exit; + end; + + //lnControlObservations := knControls; + //getmem(lControlSymptomRA,lnControlObservations*sizeof(single)); + //for lSim := 1 to lnControlObservations do + // lControlSymptomRA^[lSim] := 1000; + {$ENDIF} + //next, get 1st group + if not MainForm.GetValX(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit{,binom},lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) or (lnSubjAll < lSimSampleSize) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') [sample size is '+inttostr(lSimSampleSize)+']or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + //randomization loop.... + for lSim := 1 to lnSim do begin + RandomGroup(lSimSampleSize, lImageNames,lSymptomRA, lPartImageNames, lPartSymptomRA); + lOutNameSim := AddIndexToFilename(lOutName,lSim); + lnCrit := lCrit; + MainForm.NPMMsgClear; + //Msg(GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to lSimSampleSize do + MainForm.NPMMsg (lPartImageNames.Strings[lSubj-1] + ' = '+realtostr(lPartSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(lSimSampleSize)); + if not CheckVoxelsGroup(lPartImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lPrefs.Run := lSim; + if lBinomial then + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim) + else begin + MainForm.ReportDescriptives(lPartSymptomRA,lnSubj); + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim); + {$IFDEF anacom} + AnacomLesionNPMAnalyze (lPartImageNames, lMaskHdr, lnCrit,lSim,lnControlObservations, lPartSymptomRA,lControlSymptomRA, lFactname,lOutNameSim,true,false); + {$ENDIF} + end; + end; //for each simulation... + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lPartImageNames.free; + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + freemem(lPartSymptomRA); + {$IFDEF anacom} + freemem(lControlSymptomRA); + {$ENDIF} + DeleteDecompressed4D(lTemp4D); +end; + + + +end. + + diff --git a/npm/zconf.inc b/npm/zconf.inc new file mode 100755 index 0000000..0f9e451 --- /dev/null +++ b/npm/zconf.inc @@ -0,0 +1,24 @@ +{ -------------------------------------------------------------------- } + +{$DEFINE MAX_MATCH_IS_258} + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{- $DEFINE MAXSEG_64K} +{$IFNDEF WIN32} + {$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } +{$ENDIF} + +{$UNDEF DYNAMIC_CRC_TABLE} +{$UNDEF FASTEST} +{$define patch112} { apply patch from the zlib home page } +{ -------------------------------------------------------------------- } +{$IFDEF FPC} + {$DEFINE Use32} + {$UNDEF DPMI} + {$UNDEF MSDOS} + {$UNDEF UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } + {$UNDEF MAXSEG_64K} +{$ENDIF} + diff --git a/npm_precl/Copy of npm.cfg b/npm_precl/Copy of npm.cfg new file mode 100755 index 0000000..22d5940 --- /dev/null +++ b/npm_precl/Copy of npm.cfg @@ -0,0 +1,38 @@ +-$A+ +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LN"c:\program files\borland\delphi4\Lib" +-U"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-O"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-I"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-R"C:\pas\mricron\common;C:\pas\mricron\fpmath" diff --git a/npm_precl/Copy of prefs.pas b/npm_precl/Copy of prefs.pas new file mode 100755 index 0000000..7f001c6 --- /dev/null +++ b/npm_precl/Copy of prefs.pas @@ -0,0 +1,249 @@ +unit prefs; + +{$H+} +interface +uses + inifiles, define_types,SysUtils,classes; + +type + TPrefs = record + UnusedBool: boolean; + Test, Permutations,CritPct: integer; + end; +const + knotest = 0; //no test specified + kltest = 1;//binomial Liebermeister test + kttest = 2; //t-test + kbmtest = 4;//Bruneer-Mnuzel test + klrtest = 8; //logisitic regression test + +//procedure ReadIni(var lIniName: string; var lPrefs: TPrefs); +procedure SetDefaultPrefs (var lPrefs: TPrefs); +//procedure SaveIni (var lIniName: string; var lPrefs: TPrefs); +//procedure CorrectPrefs (var lPrefs: TPrefs); //ensures only usable file types are created +procedure ReadParamStr; + +implementation + +uses nifti_img, hdr,nifti_hdr; + +procedure Msg(lStr: string); +begin + // +end; + +procedure SetDefaultPrefs (var lPrefs: TPrefs); +begin + lPrefs.unusedbool := true; + lPrefs.Test := knotest; + lPrefs.Permutations := 0; + lPrefs.CritPct := 0; +end; +function CheckBool (lPref, lFlag: integer): boolean; +//check if Flag is ni lPref. For example, if Flag is 1 then returns true for all odd lPrefs +begin + result := (lPref and lFlag) = lFlag; +end; + +function DoLesion (lPrefs: TPrefs): boolean; +label + 666; +const + kSimSampleSize = 64; + knSim = 100; + kCrit = 3; +var + //lBinomial: boolean; + lSim,lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit,lnControlObservations: integer; + lPartImageNames,lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname,lOutNameSim: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA,lPartSymptomRA,lControlSymptomRA: singleP; +begin + result := false; + //lBinomial := not odd( (Sender as tMenuItem).tag); + if (not CheckBool(lPrefs.test ,kltest)) and (not CheckBool(lPrefs.test, kttest)) and (not CheckBool(lPrefs.test, kbmtest)) then begin + Msg('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPartImageNames := TStringList.Create; + getmem(lPartSymptomRA,kSimSampleSize*sizeof(single)); + lnControlObservations := 20; + getmem(lControlSymptomRA,lnControlObservations*sizeof(single)); + for lSim := 1 to lnControlObservations do + lControlSymptomRA[lSim] := 5; + //next, get 1st group + if not MainForm.GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit,lBinomial,lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := MainForm.CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not MainForm.CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + //randomization loop.... + for lSim := 1 to knSim do begin + RandomGroup(kSimSampleSize, lImageNames,lSymptomRA, lPartImageNames, lPartSymptomRA); + lOutNameSim := AddIndexToFilename(lOutName,lSim); + lnCrit := kCrit; + MainForm.NPMMsgClear; + //Msg(GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := MainForm.LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to kSimSampleSize do + MainForm.NPMMsg (lPartImageNames.Strings[lSubj-1] + ' = '+realtostr(lPartSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(kSimSampleSize)); + if not MainForm.CheckVoxelsGroup(lPartImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + if lBinomial then + MainForm.LesionNPMAnalyzeBinomial(lPartImageNames,lMaskHdr,lnCrit,lPartSymptomRA,lFactname,lOutNameSim) + else begin + MainForm.ReportDescriptives(lPartSymptomRA,lnSubj); + //LesionNPMAnalyze2(lImageNames,lMaskHdr,lnCrit,-1,lSymptomRA,lFactName,lOutname); + LesionNPMAnalyze2(lPartImageNames,lMaskHdr,lnCrit,lSim{-1},MainForm.ReadPermute,lPartSymptomRA,lFactName,lOutNameSim,lTTest,lBM); + end; + end; //for each simulation... + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + result := true; + 666: + lPartImageNames.free; + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + freemem(lPartSymptomRA); + MainForm.DeleteDecompressed4D(lTemp4D); +end; + + +procedure ReadParamStr; +var + lStr: String; + I,lError: integer; + + //lResult,lHelpShown : boolean; + lCommandChar: Char; + //I,lError: integer; + lSingle: single; + //lOrigWinWid,lOrigWinCen: Integer;*) + lPrefs: TPrefs; +begin + SetDefaultPrefs(lPrefs); + lStr := paramstr(0); + lStr := extractfilename(lStr); + lStr := string(StrUpper(PChar(lStr))) ; + {$IFDEF PNG} + if (lStr = 'DCM2PNG.EXE') then + gOutputFormat := kPNG; + {$ENDIF} + + if (ParamCount > 0) then begin + I := 0; + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') and (ParamCount > I) then begin //special command + //-z= zoom, -f= format [png,jpeg,bmp], -o= output directory + lCommandChar := UpCase(lStr[2]); + inc(I); + lStr := ParamStr(I); + lStr := string(StrUpper(PChar(lStr))) ; + case lCommandChar of + 'C','P','T': begin //CritPct + Val(lStr,lSingle,lError); + if lError = 0 then begin + if lCommandChar = 'C' then + lPrefs.CritPct := round(lSingle) + else if lCOmmandChar = 'P' then + lPrefs.Permutations := round(lSingle) + else if lCOmmandChar = 'T' then + lPrefs.Test := round(lSingle); + end; //not lError + end; //C= CritPct + + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + if fileexists(lStr) then begin + //lStr := GetLongFileName(lStr); + xxx + end else if not (gSilent) then begin + MyWriteln('0 dcm2jpg ERROR: unable to find '+lStr); + if lHelpShown then + MyReadln + else + Showhelp; + lHelpShown := true; + end; + until I >= ParamCount; + end else begin + //begin test routines.... + (* + lStr := 'D:\yuv2.dcm'; + ResetDCMvalues; + lOrigWinWid := gWinWid; + lOrigWinCen := gWinCen; + LoadData(lStr); + gWinWid := lOrigWinWid; + gWinCen := lOrigWinCen; + //...end test routines(**) + ShowHelp; + end;{param count > 0} +end; + +end. + \ No newline at end of file diff --git a/npm_precl/Copy of turbolesion.pas b/npm_precl/Copy of turbolesion.pas new file mode 100755 index 0000000..9025fc6 --- /dev/null +++ b/npm_precl/Copy of turbolesion.pas @@ -0,0 +1,235 @@ +unit turbolesion; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +Type + TLDMPrefs = record + NULP,BMtest,Ttest,Ltest: boolean; + nCrit,nPermute,Run{0 except for montecarlo}: integer; + NameAppend: string; + end; + + + +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} + +function TurboLDM (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lPrefs: TLDMPrefs ; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lPos,lPlank,lThread: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,//,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshPermute,lThreshBonf,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lPlankAllocated: boolean; + //lttest,lBM: boolean; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + lPlankAllocated := false; + //lnPermute := MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lPrefs.nPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lPlankAllocated := true; + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + getmem(lOutImgAUC,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lPrefs.nPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + //next create permuted BM bounds + if lPrefs.BMtest then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lImages.Count, lObs); + end; + ClearThreadData(gnCPUThreads,lPrefs.nPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TLesionContinuous.Create (MainForm.ProgressBar1,lPrefs.ttest,lPrefs.BMtest,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA) do + //with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + //freemem(lPlankImg); + //lPlankAllocated := false; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lPrefs.nCrit)+' patients**'); + goto 123; + end; + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lPrefs.nCrit)+' lesions'); + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + //save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lPrefs.Run < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + if lPrefs.Run > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lPrefs.nCrit,lnVoxTested,lPlankImg)); + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lPrefs.ttest then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lPrefs.nPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('ttest',lPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest'+lFactName,'.hdr'); + if lPrefs.Run > 0 then + MainForm.NPMmsgAppend('threshtt,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lPrefs.BMtest then begin //save Brunner Munzel + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('BM',lPrefs.nPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM'+lFactName,'.hdr'); + if lPrefs.Run > 0 then + MainForm.NPMmsgAppend('threshbm,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgAUC); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + if lPlankAllocated then + freemem(lPlankImg); + //Next: NULPS - do this after closing all memory - this is a memory hog + if lPrefs.NULP then + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lPrefs.nCrit,lnVoxTested)); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + //if lRun > 0 then + // AX(freeram,freeram,freeram,freeram,freeram,freeram); + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + +end. diff --git a/npm_precl/LesionStatThds.pas b/npm_precl/LesionStatThds.pas new file mode 100755 index 0000000..1679d2e --- /dev/null +++ b/npm_precl/LesionStatThds.pas @@ -0,0 +1,447 @@ +unit LesionStatThds; + +interface + +uses + SysUtils, + ComCtrls,Classes, Graphics, ExtCtrls, define_types,stats,StatThdsUtil,Brunner,lesion_pattern; + + + +type + + TLesionStatThread = class(TThread) + private + lBarX: TProgressBar; + lttestx,lBMx: boolean; + lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx, + lImagesCountx,lControlsx : integer; + lPlankImgx:ByteP; + lOutImgMnx,lOutImgBMx,lOutImgTx,lOutImgAUCX,lSymptomRAx: SingleP; + //lBarX: TProgressBar; + procedure DoVisualSwap; + protected + procedure Execute; override; + procedure VisualProg(lPos: Integer); + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg:bytep;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); virtual; abstract; + public + constructor Create(lBar: TProgressBar;lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg:ByteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); + end; + + { Lesion - image reveals value } + + TLesionContinuous = class(TLesionStatThread ) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); override; + end; + + TLesionBinom = class(TLesionStatThread ) + protected + procedure Analyze(lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgL,lOutImgX,lOutImgAUC,lSymptomRA: SingleP); override; + end; + +implementation + +(*procedure OutStr(lStr: string); +var + lOutname: string; + f: TextFile; +begin + lOutname:='c:\fx.txt'; + if fileexists(lOutname) then + begin { open a text file } + AssignFile(f, lOutname); + Append(f); + Writeln(f, lStr); + Flush(f); { ensures that the text was actually written to file } + { insert code here that would require a Flush before closing the file } + CloseFile(f); + end; +end; +*) + +Const Two32 = 4294967296.0 ; +function GenRandThreaded(lRange: integer; var lRandSeed:comp): integer; +//normal random function does not work well when threaded - randseed is changed by each thread +const lFactor = $08088405 ; lTerm = 1 ; +type lT = array [0..1] of longint ; +var + lX: extended; +begin + lRandSeed := lRandSeed*lFactor + lTerm; + lT(lRandSeed)[1] := 0 ; // < May'04 was: RS := RS - Trunc(RS/Two32)*Two32 ; + lX := lRandSeed/Two32 ; + result := trunc((lRange)*lX); +end; + +procedure GenPermuteThreaded (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: double; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteThreaded (lttest,lBM: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT,lDF,lBMz: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lttest then begin + TStat2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lBM then begin + //BMTest (lnSubj, lnGroup0, lRanOrder,lOutT); + tBM (lnSubj, lnGroup0, lRanOrder,lBMz,lDF); + lBMz := BMzVal (lnSubj, lnGroup0,lBMz,lDF); + + if lBMz > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lBMz; + if lBMz < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lBMz; + end; //compute BM + end; + freemem(lRanOrderp); +end; + +procedure GenPermuteThreadedBinom (lnSubj: integer; var lOrigOrder,lRanOrder: ByteP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: byte; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteBinomialThreaded (lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: ByteP0); +var + lInc: integer; + lOutP: double; + lRS: Comp; + lRanOrder: byteP0; + //lRanOrderp: pointer; + //lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + //createArray64(lRanOrderp,lRanOrder,lnSubj); + getmem(lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreadedBinom(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + (*if lChi2 then begin + Chi2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lLieber then begin*) + //Liebermeister2bP (lnSubj, lnGroup0, lRanOrder,lOutP); + Liebermeister2bP (lnSubj, lnGroup0, lRanOrder,lOutP); + if (lOutP > 0) and (lOutP < gPermuteMinT[lThread,lInc]) then begin //negative correlation + //fx(lOutP, gPermuteMinBM[lThread,lInc]); + gPermuteMinT[lThread,lInc] := lOutP; + end; + if (lOutP < 0) and ( lOutP > gPermuteMaxT[lThread,lInc]) then //negative correlation + gPermuteMaxT[lThread,lInc] := lOutP; + //end; //compute BM + end; + freemem(lRanOrder); +end; + +procedure TLesionStatThread .DoVisualSwap; +begin + lBarX.Position := lBarPosX; +end; + +procedure TLesionStatThread .VisualProg(lPos: Integer); +begin + lBarPosX := lPos; + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} +end; + +constructor TLesionStatThread .Create(lBar: TProgressBar; lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); +begin + lBarX := lBar; + lttestx := lttest; + lBMx:= lBM; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lControlsX := lControlsIn; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgBMx := lOutImgBM; + lOutImgTx := lOutImgT; + lOutImgAUCx := lOutImgAUC; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + FreeOnTerminate := True; + inherited Create(False); +end; + +{ The Execute method is called when the thread starts } + +procedure TLesionStatThread .Execute; +begin + Analyze(lttestx,lBMx, lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lControlsx,lPlankImgX,lOutImgMnx,lOutImgBMx,lOutImgTx,lOutImgAUCx,lSymptomRAx); +end; + + +procedure TLesionContinuous.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIN : integer; lPlankImg:bytep;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); +//pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsT,lPrevZValsBM,lPrevAUCVals: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + lStr: string; + lObstp,lObsp: pointer; + lObst,lObs: Doublep0; + lT,lBMz,lDF: Double; + lObsB: bytep0; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnControl, + lnControlsPlusLesion,lnControlsPlusPatients : integer; +begin //statthread + //init patterns + lnControl := abs(lControlsIn); + if lControlsIn < 0 then begin //binomial + getmem(lObsB, lImagesCount+lnControl); + end; + lnControlsPlusPatients := lImagesCount+lnControl; + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + //lMaxLesion := lImagesCount-lnCrit; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lnControlsPlusPatients); + lPosPct := (lThreadEnd-lThreadStart) div 100; + //if lThread = 1 then + // OutStr( inttostr(lThreadStart)+':'+inttostr(lThreadEnd)); //xxxxx + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] = 0 then begin + //no lesion + inc(lnNoLesion); + lLesionOrderp^[lPos] := 0; + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + //lObs^[lImagesCount-lnLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) and (lnLesion < lImagesCount) then begin + //when there are 0 lesions or all lesions there is no variability! + inc(gnVoxTestedRA[lThread]); + //now check if we have seen this precise lesion order recently... + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + if lttest then + lOutImgT^[lPos2Offset] := lPrevZvalsT[lPos]; + if lBM then + lOutImgBM^[lPos2Offset] := lPrevZvalsBM[lPos]; + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lPrevAUCvals[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + lnControlsPlusLesion := lnControlsPlusPatients; + if (lControlsIn > 0) {and (lnLesion > 0)} then begin //anaCOm + createArray64(lObstp,lObst,lImagesCount); + for lPos := 1 to lImagesCount do + lObst^[lPos-1] := lObs^[lPos-1]; + for lPos := 1 to lnLesion do + lObs^[lPos-1+lnControl] := lObst^[lPos-1+lnNoLesion]; + freemem(lObstP); + for lPos := 1 to lnControl do + lObs^[lPos-1] := lSymptomRA^[lPos+lImagesCount]; + lnControlsPlusLesion := lnControl+lnLesion; + lnNoLesion := {lnNoLesion +} lnControl; + end;//controls + (*if lPos2 = 2570879 then begin //xxxx + for lPos := 1 to lImagesCount do begin + outstr(inttostr(lPos)+'>'+floattostr(lObs^[lPos-1]) ); + end; + end;*) + + if lttest then begin + if lControlsIn > 0 then begin//anacom + TStat2Z (lnControlsPlusLesion, lnControl {lnNoLesion},lObs,lT); +(* if lPos2 = 2570879 then begin + outstr( floattostr(lT)+ ' '+inttostr(lnControl)); //xxxx + for lPos := 1 to lnControlsPlusLesion do begin + outstr(inttostr(lPos)+', '+floattostr(lObs^[lPos-1]) ); + end; + + end; *) + end else + TStat2 (lnControlsPlusLesion, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + lPrevZValsT[lPatternPos] := lT; + end; + + if lBM then begin + tBM (lnControlsPlusLesion, lnNoLesion, lObs,lBMz,lDF); + lBMz := BMzVal (lnControlsPlusPatients, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + lPrevZValsBM[lPatternPos] := lBMz; + end; + if lOutImgAUC <> nil then begin + lOutImgAUC^[lPos2Offset] := continROC (lnControlsPlusLesion, lnNoLesion, lObs); + lPrevAUCVals[lPatternPos] := lOutImgAUC^[lPos2Offset]; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //novel lesion pattern + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp); + if lControlsIn < 0 then //binomial + freemem(lObsB); + + +end; + +procedure TLesionBinom.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: bytep;lOutImgMn,lOutImgL,lOutImgX,lOutImgAUC,lSymptomRA: SingleP); +//procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); + //pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsL ,lPrevAUCVals: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + //lObsp: pointer; + //lObs: Doublep0; lPrevZVals + lObs: ByteP0; + lAUC,lZ: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //Binomial StatThread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + //createArray64(lObsp,lObs,lImagesCount); + getmem(lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := round(lSymptomRA^[lPos]); + lLesionOrderp^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lnLesion-1] := round(lSymptomRA^[lPos]); //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) and (lnLesion < lImagesCount) then begin + //when there are 0 lesions or all lesions there is no variability! + inc(gnVoxTestedRA[lThread]); + //next check patterns + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + //if lChi2 then + // lOutImgX^[lPos2Offset] := lPrevZvalsX[lPos]; + //if lLieber then + lOutImgL^[lPos2Offset] := lPrevZvalsL[lPos]; + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lPrevAUCvals[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + + {if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + lPrevZValsX[lPatternPos] := lT; + end; + if lLieber then begin} + Liebermeister2b(lImagesCount, lnLesion, lObs,lAUC,lZ); + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lAUC; + lPrevAUCVals[lPatternPos] := lAUC; + lOutImgL^[lPos2Offset] := lZ; + lPrevZValsL[lPatternPos] := lZ; + //end; + StatPermuteBinomialThreaded (lImagesCount, lnLesion,lnPermute,lThread, lObs); + end; + end; //in brain mask - compute + end; //for each voxel + freemem(lObs); + freemem(lLesionOrderp) +end; + +end. diff --git a/npm_precl/Mat.pas b/npm_precl/Mat.pas new file mode 100755 index 0000000..d238441 --- /dev/null +++ b/npm_precl/Mat.pas @@ -0,0 +1,2396 @@ +unit Mat; + +{ Basic Matrix Unit for Delphi, May 1996. Implemented using original iMAP C matrix library } +{ Use this instead of matrix } + + +interface + +Uses SysUtils, Classes, Vector,dialogs; + +//var gMat: boolean = false; +type EMatrixError = class (Exception); + EMatrixSizeError = class (EMatrixError); + ESingularMatrix = class (EMatrixError); + ENonSquareMatrix = class (EMatrixError); + + TMatError = (Singular, NonSingular, NonSquare); + + + + { A Matrix is made up of a set of rows of type TRow, pTRow is + a pointer to a single row and a matrix is a row of pTRows, this + allows arrays larger then 65K to be built, the max size of + a matrix is roughly 4096 MBytes } + MatRA = array [1..1] of Double; + Matp = ^MatRA; + + { forward declare the Matrix class } + TMatrix = class; + + { Used by svdfit, supplies basis functions at x } + BasisProc = procedure (x : TMatElement; var BasisFunc : TVector); + + { Define a dynamic matrix type for holding doubles } + TMatrix = class (TObject) + private + + nr, nc : integer; + mx :matp;//: pTRowList; { pointer to a list of rows } + procedure SetSize (ri, ci : integer); + procedure FreeSpace; + public + constructor create (r, c : integer); overload; virtual; + constructor create (n : integer); overload; virtual; + constructor create (c : integer; d : array of TMatElement); overload; virtual; + destructor destroy; override; + procedure Setval (ri, ci : integer; v : TMatElement); + function Getval (ri, ci : integer) : TMatElement; + property M[x, y : Integer] : TMatElement read GetVal write SetVal; default; + property r : integer read nr; + property c : integer read nc; + function IsSquare : boolean; + function SameDimensions (m1, m2 : TMatrix) : boolean; + function Identity : TMatrix; + function Diagonal (k : TMatElement) : TMatrix; overload; + function Diagonal (v : TVector) : TMatrix; overload; + function Zero : TMatrix; + function Ones : TMatrix; + function L (ci :integer; d : array of TMatElement) : TMatrix; + function transpose : TMatrix; overload; + function transpose (m1 : TMatrix) : TMatrix; overload; + function add (m1, m2 : TMatrix) : TMatrix; overload; + function add (m1 : TMatrix) : TMatrix; overload; + function sub (m1, m2 : TMatrix) : TMatrix; overload; + function sub (m1 : TMatrix) : TMatrix; overload; + function mult (m1 : TMatrix; k : TMatElement) : TMatrix; overload; + function mult (k : TMatElement) : TMatrix; overload; + function mult (m1, m2 : TMatrix) : TMatrix; overload; + function copy (m1 : TMatrix) : TMatrix; + procedure ExtractColumn (var v : TVector; cc : integer); + procedure ExtractRow (var v : TVector; rr : integer); + function ExchangeRows (r1, r2 : integer) : TMatrix; + function ExchangeCols (c1, c2 : integer) : TMatrix; + function Rank (echelon : TMatrix; eps : double) : integer; + procedure Invert (inv : TMatrix); overload; + procedure Invert; overload; + procedure Invert2 (var dest, src : TMatrix; var col: TVector; var index : TVectori); + function Det2 (m1 : TMatrix; var index : TVectori; var v : TVector): double; + procedure SolveLinear (v, b : TVector; SelfToInv : boolean); + procedure LUSolve (index : TVectori; b : TVector); + procedure LUDecomp (m1 : TMatrix; index : TVectori); + procedure LUDecomp2 (var m1 : TMatrix; var index : TVectori; var v : TVector); + function MatMax: double; + function MatAbsMax: double; + function Det : double; + procedure NullSpace (var NullVectors : TMatrix; var BasisSize : integer; + var Echelon : TMatrix; var TheRank : integer); + + procedure svd (var u : TMatrix; var w : TVector; var v : TMatrix); + procedure svd2 (var u : TMatrix; var w : TVector; var v : TMatrix); + procedure svdSolve (var u : TMatrix; var w : TVector; var v : TMatrix; + b : TVector; var x : TVector); + function svdfit (x, y, yerr : TVector; var fit : TVector; + var u, v : TMatrix; var w : TVector; funcs : BasisProc): TMatElement; + procedure svdCovar (v : TMatrix; w : TVector; alpha : TMatrix); + + procedure eliminate_cms (S, Tk1 : TMatrix; var cr, N : integer); + procedure ElementaryModes (D : TVectori; var mf, mb, C1, k : integer; Tk : TMatrix); + class procedure Tableau (N, R1 : integer; var mf, mb, C1, k : integer; Tk, Tk1 : TMatrix); + class function grecodiv_of_vector (N, R1 : integer; vec : TVector) : integer; + class function grecodiv(P, Rest: integer) : integer; + procedure Conserve(st : TMatrix); + end; + + +{ ------------------------------------------------------------------------- } + +implementation + +const MATERROR = 'Matrix Operation Error:'; + + + +{ ------------------------------------------------------------------------- } +{ START OF MATRIX IMPLEMETATION } +{ ------------------------------------------------------------------------- } + + +{ ------------------------- Constructors first ---------------------------- } + + +{ ******************************************************************** } +{ Usage: A := TMatrix.create (3, 2); } +{ ******************************************************************** } +constructor TMatrix.create (r, c : integer); +begin + Inherited Create; nr := 0; nc := 0; mx := Nil; + Self.SetSize (r, c); + +end; + + + + +{ ******************************************************************** } +{ Create an identity matrix } +{ } +{ Usage: A := TMatrix.createI (3); } +{ ******************************************************************** } +constructor TMatrix.create (n : integer); +var i : integer; +begin + Inherited Create; nr := 0; nc := 0; mx := Nil; + Self.SetSize (n, n); + for i := 1 to n do Self[i,i] := 1.0; +end; + + +{ ******************************************************************** } +{ Create a matrix filled with values from array d given that the } +{ number of columns equals c. } +{ } +{ Usage: A := TMatrix.createLit (2, [1, 2, 3, 4]); } +{ Creates a 2 by 2 array } +{ ******************************************************************** } +constructor TMatrix.create (c : integer; d : array of TMatElement); +var i, j, ri, count : integer; +begin + Inherited Create; nr := 0; nc := 0; mx := Nil; + ri := (High(d)+1) div c; + Self.SetSize (ri, c); + count := 0; + for i := 1 to ri do + for j := 1 to c do + begin + Self[i,j] := d[count]; + inc (count); + end; +end; + + +{ ******************************************************************** } +{ Usage: A.destroy, use a.free in a program } +{ ******************************************************************** } +destructor TMatrix.destroy; +begin + FreeSpace; + Inherited Destroy; +end; + + + +{ Free the data space but not the object } +procedure TMatrix.FreeSpace; +//var i : integer; +begin + if mx <> Nil then + begin + FreeMem (mx); mx := Nil; + end; +end; + + +{ Internal routine used set size of matrix and allocate space } +procedure TMatrix.SetSize (ri, ci : integer); +//var i : integer; +begin + if (mx <> Nil) and ((ri*ci)= (nr*nc) ) then begin + nr := ri; nc := ci; + exit; + end; + //if gMat then beep; + FreeSpace; + nr := ri; nc := ci; + //if gMat then beep; + Getmem(mx,ri*ci*sizeof(TMatElement));//AllocMem (sizeof (pTRowList) * (nr+1)); { r+1 so that I can index from 1 } +end; + + +{ ---------------------------------------------------------------------------- } +{ BASIC ROUTINES } +{ ---------------------------------------------------------------------------- } + + +{ ******************************************************************** } +{ Used internally but is also accessible from the outside } +{ } +{ Normal Usage: A[2, 3] := 1.2; } +{ } +{ ******************************************************************** } +procedure TMatrix.Setval (ri, ci : integer; v : TMatElement); +begin + if ri > r then + raise EMatrixSizeError.Create ('ri index out of range: ' + inttostr (ri)); + + if ci > c then + raise EMatrixSizeError.Create ('ci index out of range: ' + inttostr (ci)); + + mx^[ri + ((ci-1)* r )] := v; +end; + + +{ ******************************************************************** } +{ Used internally but is also accessible from the outside } +{ } +{ Normal Usage: d := A[2, 3]; } +{ } +{ ******************************************************************** } +function TMatrix.Getval (ri, ci : integer) : TMatElement; +begin + result := mx^[ri + ((ci-1)* r )]; +end; + + + + +{ ******************************************************************** } +{ Fill an existing matrix with the array d of numbers. ci equals } +{ the number of columns. } +{ } +{ Usage: A.L(3, [1, 2, 3, 4, 5, 6, 7, 8, 9]); } +{ } +{ ******************************************************************** } +function TMatrix.L (ci :integer; d : array of TMatElement) : TMatrix; +var i, j, ri, count : integer; +begin + ri := (High(d)+1) div ci; + FreeMem (mx, sizeof (TMatElement) * nr * nc); + Self.SetSize (ri, ci); + count := 0; + for i := 1 to ri do + for j := 1 to ci do + begin + Self[i,j] := d[count]; + inc (count); + end; + result := Self; +end; +{ ******************************************************************** } +{ Set all elements to one } +{ } +{ Usage: A.Ones; } +{ } +{ ******************************************************************** } + +function TMatrix.Ones : TMatrix; +var i, j : integer; +begin + for i := 1 to r do + for j := 1 to c do + Self[i,j] := 1.0; + result := Self; +end; +{ ******************************************************************** } +{ Zero the Self matrix } +{ } +{ Usage: A.Zero; } +{ } +{ ******************************************************************** } +function TMatrix.Zero : TMatrix; +var i, j : integer; +begin + for i := 1 to r do + for j := 1 to c do + Self[i,j] := 0.0; + result := Self; +end; + + +{ ******************************************************************** } +{ Returns true if matrices m1 and m2 have the same dimensions } +{ } +{ Usage: if SameDimensions (A, B) then } +{ } +{ ******************************************************************** } +function TMatrix.SameDimensions (m1, m2 : TMatrix) : boolean; +begin + result := (m1.nr = m2.nr) and (m1.nc = m2.nc); { use nr, nc for direct access } +end; + + +{ ******************************************************************** } +{ Returns true if matrix m is square } +{ } +{ Usage: if IsSquare then } +{ } +{ ******************************************************************** } +function TMatrix.IsSquare : boolean; +begin + result := Self.nr = Self.nc; +end; + + +{ ******************************************************************** } +{ Turn the matrix Self into an identify matrix } +{ } +{ Usage: A.Identity } +{ } +{ ******************************************************************** } +function TMatrix.Identity : TMatrix; +var i : integer; +begin + if Self.IsSquare then + begin + Self.Zero; + for i := 1 to r do Self[i,i] := 1.0; + result := Self; + end + else + raise EMatrixSizeError.Create ('An identity matrix can only be formed from a square matrix'); +end; + + +{ ******************************************************************** } +{ Make the matrix object a diagonal matrix with the value, k } +{ } +{ Usage: A.Diagonal (3.1415); } +{ } +{ ******************************************************************** } +function TMatrix.Diagonal (k : TMatElement) : TMatrix; +var i : integer; +begin + if Self.IsSquare then + begin + Self.Zero; + for i := 1 to r do Self[i,i] := k; + result := Self; + end + else + raise EMatrixSizeError.Create ('Can only form a diagonal matrix from a square matrix'); +end; + + +{ ******************************************************************** } +{ This forms a diagonal matrix from the elements of vector v. } +{ } +{ Usage: A.Diagonal (v) } +{ } +{ ******************************************************************** } +function TMatrix.Diagonal (v : TVector) : TMatrix; +var i : integer; +begin + if Self.IsSquare then + begin + if v.size = Self.nr then + begin + Self.zero; + for i := 1 to r do Self[i,i] := v[i]; + result := Self; + end + else + raise EMatrixSizeError.Create ('Vector must be same size as matrix in DiagonalV'); + end + else + raise EMatrixSizeError.Create ('Can only form a diagonal matrix from a square matrix'); +end; + + +{ ******************************************************************** } +{ Transpose matrix 'Self', Self is thus destroyed and replaced } +{ } +{ Usage: A.transpose } +{ } +{ ******************************************************************** } +function TMatrix.Transpose : TMatrix; +var i, j : integer; tmp : TMatrix; +begin + if (r=1) or (c=1) then begin + i := nr; + nr := nc; + nc := i; + exit; + end; + tmp := TMatrix.create (c, r); + try + for i := 1 to r do + for j := 1 to c do + tmp [j,i] := Self[i,j]; + Self.FreeSpace; Self.SetSize (tmp.nr, tmp.nc); + { move data from transpose to Self } + Self.Copy (tmp); + finally + tmp.Destroy; + end; + result := Self; +end; + + +{ ******************************************************************** } +{ Transpose the matrix 'm' into Self } +{ } +{ Usage: T.transpose (A); Tranposes A and puts result into T } +{ Will also accept T.transpose (T) } +{ ******************************************************************** } +function TMatrix.Transpose (m1 : TMatrix) : TMatrix; +var i, j : integer; t : TMatrix; +begin + if (m1.r <> Self.c) and (m1.c <> Self.r) then + raise EMatrixSizeError.Create ('Destination matrix has incorrect dimensions for transpose'); + { If the user is trying to transpose itself.... } + if Self = m1 then + begin + t := TMatrix.Create (r, c); + try + t.Copy (m1); + for i := 1 to m1.r do + for j := 1 to m1.c do + Self[j,i] := t[i,j]; + finally + t.free; + result := Self; + end; + exit; + end; + + for i := 1 to m1.r do + for j := 1 to m1.c do + Self[j,i] := m1[i,j]; + result := Self; +end; + + +{ ******************************************************************** } +{ Copy matrix 'm' to Self, Self must exist and is overwritten } +{ in the process. This procedure does a fast deep copy of the matrix. } +{ } +{ Usage: B.Copy (A); performs the operation: B = A with deep copy } +{ } +{ ******************************************************************** } +function TMatrix.Copy (m1 : TMatrix) : TMatrix; +begin + + if ( r<> m1.r) or (c <> m1.c) then begin + (*if r <> m.r then + raise EMatrixSizeError.Create (MATERROR + #13#10'Cannot copy matrices with different sized rows: dest<' + + inttostr (r) + '> src<' + inttostr (m.r) + '>') + else + raise EMatrixSizeError.Create (MATERROR + #13#10'Cannot copy matrices with different sized columns: dest<' + + inttostr (c) + '> src<' + inttostr (m.c) + '>'); *) + SetSize (self.r, self.c); + end; + { Copy a whole row at a time using move } + //for i := 1 to r do move (m.mx^[i]^, Self.mx^[i]^, sizeof(TMatElement) * (c+1)); + move(m1.mx^,self.mx^,r*c*sizeof(double)); + // Copy over column and row names, clear destination first then copy + result := Self; +end; + + +{ ******************************************************************** } +{ Extract column cc from the Self matrix and return it as a TVector } +{ } +{ Usage: m.ExtractColumn (v, 1) extract column 1 from m and place in v} +{ } +{ ******************************************************************** } +procedure TMatrix.ExtractColumn (var v : TVector; cc : integer); +var i : integer; +begin + v.freeSpace; v.SetSize (Self.r); { Create result vector of appropriate size } + for i := 1 to Self.r do v[i] := Self[i, cc]; +end; + + +{ ******************************************************************** } +{ Extract rwo rr from the Self matrix and return it as a TVector } +{ } +{ Usage: m.ExtractRow (v, 1) extract row 1 from m and place in v } +{ } +{ ******************************************************************** } +procedure TMatrix.ExtractRow (var v : TVector; rr : integer); +var i : integer; +begin + v.freespace; v.SetSize (Self.c); + for i := 1 to Self.c do v[i] := Self[rr, i]; +end; + + +{ ******************************************************************** } +{ Add matrix 'm' to Self, giving a new Self } +{ } +{ Usage: A.addU (B); add B to A, giving A } +{ } +{ ******************************************************************** } +function TMatrix.add (m1 : TMatrix) : TMatrix; +var i, j : integer; +begin + if Not SameDimensions (m1, Self) then + raise EMatrixSizeError.Create ('Incorrectly sized result matrix for matrix addition'); + + for i := 1 to r do + for j := 1 to c do + Self[i,j] := Self[i,j] + m1[i,j]; + result := Self; +end; + + +{ ******************************************************************** } +{ Add matrix 'm1' and 'm2' and assign to Self } +{ } +{ Usage: A.add (A1, A2); add A1 to A2 giving A } +{ } +{ ******************************************************************** } +function TMatrix.add (m1, m2 : TMatrix) : TMatrix; +var i, j : integer; +begin + if Not SameDimensions (m1, m2) then + raise EMatrixSizeError.Create ('Incompatible matrix operands to add'); + + if Not SameDimensions (m1, Self) then + raise EMatrixSizeError.Create ('Incorrectly sized result matrix for matrix addition'); + + for i := 1 to r do + for j := 1 to c do + Self[i,j] := m1[i,j] + m2[i,j]; + result := Self; +end; + + + +{ ******************************************************************** } +{ Subtract matrix m from Self giving a new Self } +{ } +{ Usage: A.subU (B); subtract B from A giving A } +{ } +{ ******************************************************************** } +function TMatrix.sub (m1 : TMatrix) : TMatrix; +var i, j : integer; +begin + if Not SameDimensions (m1, Self) then + raise EMatrixSizeError.Create ('Incorrecly sized result matrix for matrix subtraction'); + + for i := 1 to r do + for j := 1 to c do + Self[i,j] := Self[i,j] - m1[i,j]; + result := Self; +end; + + + +{ ******************************************************************** } +{ Subtract m2 from m1 giving Self } +{ } +{ Usage: A.sub (A1, A2); subtract A2 from A1 giving A (A = A2 - A1) } +{ } +{ ******************************************************************** } +function TMatrix.sub (m1, m2 : TMatrix) : TMatrix; +var i, j : integer; +begin + if Not SameDimensions (m1, m2) then + raise EMatrixSizeError.Create ('Incompatible matrix operands to subtract'); + + if Not SameDimensions (m1, Self) then + raise EMatrixSizeError.Create ('Incorrectly sized result matrix for matrix subtraction'); + + for i := 1 to r do + for j := 1 to c do + Self[i,j] := m1[i,j] - m2[i,j]; + result := Self; +end; + + +{ ******************************************************************** } +{ Multiply a matrix 'm' by scalar constant k and assign result to Self } +{ } +{ Usage: A.multk (B, 0.5); multiply scalar, 0.5 by B giving A } +{ } +{ ******************************************************************** } +function TMatrix.mult (m1 : TMatrix; k : TMatElement) : TMatrix; +var i, j : integer; +begin + for i := 1 to m1.r do + for j := 1 to m1.c do + Self[i, j] := m1[i,j] * k; + result := Self; +end; + + +{ ******************************************************************** } +{ Multiply the Self matrix by the scalar constant k } +{ } +{ Usage: A.multKU (0.5); multiply scalar 0.5 by A giving A } +{ } +{ ******************************************************************** } +function TMatrix.mult (k : TMatElement) : TMatrix; +var i, j : integer; +begin + for i := 1 to r do + for j := 1 to c do + Self[i, j] := Self[i,j] * k; + result := Self; +end; + + + +{ ******************************************************************** } +{ Multiply matrix 'm1' by 'm2' to give result in Self } +{ } +{ Usage: A.mult (A1, A2); multiply A1 by A2 giving A } +{ } +{ ******************************************************************** } +function TMatrix.mult (m1, m2 : Tmatrix) : TMatrix; +var i, j, k, m1_Col : integer; sum : TMatElement; +begin + if m1.c = m2.r then + begin + m1_col := m1.c; + for i := 1 to Self.r do + for j := 1 to Self.c do + begin + sum := 0.0; + for k := 1 to m1_Col do + sum := sum + m1[i, k]* m2[k, j]; + Self[i,j] := sum; + end; + result := Self; + end + else + raise EMatrixSizeError.Create ('Incompatible matrix operands to multiply'); +end; + + +{ ******************************************************************** } +{ LU Solve. Solve the linear system represented by m and right-hand } +{ side b m is assumed have have been decomposed by LUDecomp } +{ } +{ Usage: m.LUSolve (index, b) } +{ } +{ ******************************************************************** } +procedure TMatrix.LUSolve (index : TVectori; b : TVector); +var i, j, ii, ip, nRows : integer; sum : TMatElement; +begin + ii := 0; + nRows := r; + for i := 1 to nRows do + begin + ip := index[i]; + sum := b[ip]; + b[ip] := b[i]; + if ii <> 0 then + for j := ii TO i-1 do sum := sum - Self[i,j]*b[j] + else if sum <> 0.0 then ii := i; + b[i] := sum; + end; + for i := nRows downto 1 do + begin + sum := b[i]; + if i < nRows then + for j := i+1 to nRows do sum := sum - Self[i,j]*b[j]; + b[i] := sum/Self[i,i]; + end +end; + + +{ ******************************************************************** } +{ Form LU decomposition of Self matrix. Result goes into m } +{ } +{ Usage: m.LUDecomp(result, index); } +{ } +{ ******************************************************************** } +procedure TMatrix.LUDecomp (m1 : TMatrix; index : TVectori); +var v : TVector; i, k, j, imax, nRows : integer; sum, big, tmp : TMatElement; +begin + if Self.r = m1.c then + begin + m1.Copy (Self); + v := TVector.Create (m1.r); + try + { Find the largest element in every row, and store its reciprocal in v[i] } + nRows := m1.r; + for i := 1 to nRows do + begin + big := 0.0; { needed to test for singularity } + { Although we're working across columns we can use nRows since m1 is square } + for j := 1 to nRows do if (abs(m[i,j]) > big) then big := abs(m[i,j]); + if big = 0.0 then raise ESingularMatrix.Create ('LUDecomp: Singular matrix in LUDecomp, found row of zeros'); + v[i] := 1.0/big + end; + + for j := 1 TO nRows do + begin + { Form beta = aij - sum_k=1^i-1 aik * bkj } + for i := 1 TO j-1 do + begin + sum := m[i,j]; + for k := 1 to i-1 do sum := sum - m[i,k]*m[k,j]; + m[i,j] := sum + end; + big := 0.0; + for i := j to nRows do + begin + sum := m[i,j]; + for k := 1 to j-1 do sum := sum - m[i,k]*m[k,j]; + m[i,j] := sum; + if v[i]*abs(sum) >= big then + begin + big := v[i]*abs(sum); + imax := i + end + end; + + { Interchange rows if necessary } + if j <> imax then + begin + { Swap row names aswell } + for k := 1 to nRows do + begin + tmp := m[imax,k]; + m[imax,k] := m[j,k]; + m[j,k] := tmp + end; + v[imax] := v[j] + end; + index[j] := imax; + { Get ready to divide by pivot element } + if m[j,j] = 0.0 then + raise ESingularMatrix.Create ('LUDecomp: Singular Matrix, pivot value is zero'); + if j <> nRows then + begin + tmp := 1.0/m[j,j]; + for i := j+1 to nRows do m[i,j] := m[i,j]*tmp + end + end; + finally + v.destroy; + end; + end + else + raise ENonSquareMatrix.Create ('LUDecomp: Matrix must be square'); +end; + +//return max value in a matrix +function TMatrix.MatMax : double; +var i,j : integer; +begin + if (r < 1) or (c<1) then begin + result := 0; + exit; + end; + result := m[1,1]; + for i := 1 to r do + for j := 1 to c do + if m[i, j] > result then + result := m[i,j]; +end; + +//return max value in a matrix +function TMatrix.MatAbsMax : double; +var i,j : integer; +begin + if (r < 1) or (c<1) then begin + result := 0; + exit; + end; + result := abs(m[1,1]); + for i := 1 to r do + for j := 1 to c do + if abs(m[i, j]) > result then + result := abs(m[i,j]); +end; +{ ******************************************************************** } +{ Find determinant of matrix } +{ } +{ Usage: d := m.det } +{ } +{ ******************************************************************** } +function TMatrix.Det : double; +var m1 : TMatrix; index : TVectori; i : integer; +begin + result := 1; + if r = c then + begin + index := TVectori.Create (r); + m1 := TMatrix.Create (r,r); + try + m1.copy (Self); + Self.LUDecomp (m1, index); + for i := 1 to r do result := result * m1[i,i]; + finally + m1.free; index.free; + end; + end + else + raise ENonSquareMatrix.Create ('Determinant: Matrix must be square'); +end; + +(*procedure wMatrix( lTitle: string; A : TMatrix); +var + lR,lC: integer; + lStr: string; +begin + if (A.r < 1) or (A.c < 1) then + exit; + lStr := (lTitle)+chr($0D)+chr($0A); + + for lR := 1 to (A.r) do begin + for lC := 1 to (A.c) do + lStr := lStr + floattostr(A.Getval(lr, lc))+' '; + lStr := lStr + chr($0D)+chr($0A); + end; //each row + showmessage(lStr); +end;*) + + +procedure TMatrix.LUDecomp2 (var m1 : TMatrix; var index : TVectori; var v : TVector); +var i, k, j, imax, nRows : integer; sum, big, tmp : TMatElement; +begin + if Self.r = m1.c then + begin + m1.Copy (Self); + //wmatrix('m1',m1); + //v := TVector.Create (m.r); + try + { Find the largest element in every row, and store its reciprocal in v[i] } + nRows := m1.r; + for i := 1 to nRows do + begin + big := 0.0; { needed to test for singularity } + { Although we're working across columns we can use nRows since m1 is square } + for j := 1 to nRows do if (abs(m1[i,j]) > big) then big := abs(m1[i,j]); + if big = 0.0 then raise ESingularMatrix.Create ('LUDecomp: Singular matrix in LUDecomp, found row of zeros'); + v[i] := 1.0/big + end; + + for j := 1 TO nRows do + begin + { Form beta = aij - sum_k=1^i-1 aik * bkj } + for i := 1 TO j-1 do + begin + sum := m1[i,j]; + for k := 1 to i-1 do sum := sum - m1[i,k]*m1[k,j]; + m1[i,j] := sum + end; + big := 0.0; + for i := j to nRows do + begin + sum := m1[i,j]; + for k := 1 to j-1 do sum := sum - m1[i,k]*m1[k,j]; + m1[i,j] := sum; + if v[i]*abs(sum) >= big then + begin + big := v[i]*abs(sum); + imax := i + end + end; + + { Interchange rows if necessary } + if j <> imax then + begin + { Swap row names aswell } + for k := 1 to nRows do + begin + tmp := m1[imax,k]; + m1[imax,k] := m1[j,k]; + m1[j,k] := tmp + end; + v[imax] := v[j] + end; + index[j] := imax; + { Get ready to divide by pivot element } + if m1[j,j] = 0.0 then + raise ESingularMatrix.Create ('LUDecomp: Singular Matrix, pivot value is zero'); + if j <> nRows then + begin + tmp := 1.0/m1[j,j]; + for i := j+1 to nRows do m1[i,j] := m1[i,j]*tmp + end + end; + finally + //v.destroy; + end; + end + else + raise ENonSquareMatrix.Create ('LUDecomp: Matrix must be square'); +end; + +function TMatrix.Det2 (m1 : TMatrix; var index : TVectori; var v : TVector): double; +var i : integer; +begin + result := 1; + if r = c then + begin + //index := TVectori.Create (r); + //m := TMatrix.Create (r,r); + try + m1.copy (Self); + Self.LUDecomp2 (m1, index,v); + for i := 1 to r do result := result * m1[i,i]; + finally + //m.free; index.free; + end; + end + else + raise ENonSquareMatrix.Create ('Determinant: Matrix must be square'); +end; + +{ ******************************************************************** } +{ Solve a linear system of equations: Self.v = b, i.e solve for v } +{ } +{ Usage: A.SolveLinear (v, b, t); } +{ Solution in v } +{ If the boolean t is true then self is replaced by the inverse } +{ ******************************************************************** } +procedure TMatrix.SolveLinear (v, b : TVector; SelfToInv : boolean); +var n, i, j : integer; + indx : TVectori; col : TVector; + dest, src : TMatrix; +begin + if Self.r = Self.c then + begin + n := Self.r; + { Make a copy and work on the copy } + dest := TMatrix.Create (n, n); + src := TMatrix.Create (n, n); + indx := TVectori.Create (n); + try + src.Copy (Self); + for i := 1 to n do v[i] := b[i]; + src.LUDecomp (dest, indx); + dest.LUSolve (indx, v); + if SelfToInv then + begin + col := TVector.Create (n); + try + for j := 1 to n do + begin + for i := 1 to n do col[i] := 0.0; + col[j] := 1.0; + dest.LUSolve (indx, col); + for i := 1 to n do Self[i,j] := col[i]; + end; + finally + col.free; + end; + end; + finally + indx.destroy; dest.destroy; src.destroy; + end; + end + else + raise ENonSquareMatrix.Create ('SolveLinear: Matrix must be square'); +end; + + + + +{ ******************************************************************** } +{ Fast method for inverting a matrix (Self) } +{ Result in inv } +{ } +{ Usage: A.Invert (inv); } +{ ******************************************************************** } +procedure TMatrix.Invert2 (var dest, src : TMatrix; var col: TVector; var index : TVectori); +var n, i, j : integer; +begin + n := Self.r; + try + src.Copy (Self); + try + //wmatrix('w1',src); + src.LUDecomp2 (dest, index,col); + //wmatrix('w2',src); + except + on ESingularMatrix do + raise ESingularMatrix.Create ('Invert: Singular Matrix'); + end; + for j := 1 to n do + begin + for i := 1 to n do col[i] := 0.0; + col[j] := 1.0; + dest.LUSolve (index, col); + for i := 1 to n do Self[i,j] := col[i]; + end; + finally + //col.destroy; dest.destroy; src.destroy; index.destroy; + end; +end; + +procedure TMatrix.Invert (inv : TMatrix); +var col : TVector; n, i, j : integer; + dest, src : TMatrix; indx : TVectori; +begin + n := Self.r; + col := TVector.Create (n); + dest := TMatrix.Create (n, n); + src := TMatrix.Create (n, n); + indx := TVectori.Create (n); + try + src.Copy (Self); + try + src.LUDecomp (dest, indx); + except + on ESingularMatrix do + raise ESingularMatrix.Create ('Invert: Singular Matrix'); + end; + for j := 1 to n do + begin + for i := 1 to n do col[i] := 0.0; + col[j] := 1.0; + dest.LUSolve (indx, col); + for i := 1 to n do inv[i,j] := col[i]; + end; + finally + col.destroy; dest.destroy; src.destroy; indx.destroy; + end; +end; + + +{ ******************************************************************** } +{ Fast method for inverting a matrix (Self) } +{ Result in Self } +{ } +{ Usage: A.Invert } +{ ******************************************************************** } + +procedure TMatrix.Invert; +var col : TVector; n, i, j : integer; + dest, src : TMatrix; index : TVectori; +begin + n := Self.r; + col := TVector.Create (n); + dest := TMatrix.Create (n, n); + src := TMatrix.Create (n, n); + index := TVectori.Create (n); + try + src.Copy (Self); + try + src.LUDecomp (dest, index); + except + on ESingularMatrix do + raise ESingularMatrix.Create ('Invert: Singular Matrix'); + end; + for j := 1 to n do + begin + for i := 1 to n do col[i] := 0.0; + col[j] := 1.0; + dest.LUSolve (index, col); + for i := 1 to n do Self[i,j] := col[i]; + end; + finally + col.destroy; dest.destroy; src.destroy; index.destroy; + end; +end; + + +{ Internal routine that sets any values less than eps to 0.0 } +procedure CleanUpMatrix (m : TMatrix; eps : double); +var i, j, ri, ci : integer; +begin + { Removes all numbers close to zero, i.e between -eps and +eps } + ri := m.r; ci := m.c; + for i := 1 to ri do + for j := 1 to ci do + if abs (m [i, j]) < eps then m [i, j] := 0.0; +end; + + +{ Internal routine to work out the rank of a matrix given the reduced row-echelon } +function ComputeRank (m : TMatrix; eps : double) : integer; +var i, j, ri, ci, rank : integer; +begin + ri := m.r; ci := m.c; + { find the rank - brute force algorithm } + rank := 0; + { search row by row for zero rows } + for i := 1 to ri do + begin + { search along the row looking for nonzero entry } + for j := 1 to ci do + if abs (m [i, j]) > eps then + begin + inc (rank); + break; + end; + + end; + result := rank; +end; + + +{ ******************************************************************** } +{ Routine to exchange two rows, r1 and r2 in matrix Self } +{ } +{ Usage: A.exchangeRows (1, 2); } +{ } +{ ******************************************************************** } +function TMatrix.ExchangeRows (r1, r2 : integer) : TMatrix; +var ci, i : integer; t : double; +begin + if (r1 > 0) and (r1 <= Self.r) and (r2 > 0) and (r2 <= Self.r) then + begin + ci := Self.c; + for i := 1 to ci do + begin + t := Self[r1, i]; + Self[r1, i] := Self[r2, i]; + Self[r2, i] := t; + end; + result := Self; + end + else + raise EMatrixSizeError.Create ('Rows not in range for exchange'); +end; + + + +{ ******************************************************************** } +{ Routine to exchange two columns, c1 and c2 in matrix Self } +{ } +{ Usage: A.exchangeCols (1, 2); } +{ } +{ ******************************************************************** } +function TMatrix.ExchangeCols (c1, c2 : integer) : TMatrix; +var ri, i : integer; t : double; +begin + if (c1 > 0) and (c1 <= Self.c) and (c2 > 0) and (c2 <= Self.c) then + begin + ri := Self.r; + for i := 1 to ri do + begin + t := Self[c1, i]; + Self[c1, i] := Self[c2, i]; + Self[c2, i] := t; + end; + result := Self; + end + else + raise EMatrixSizeError.Create ('Columns not in range for exchange'); +end; + + + +{ ******************************************************************** } +{ Find the rank r, of the matrix Self, The reduced Row } +{ echelon is returned in mat. eps is the magnitude of } +{ the largest number before it is assumed to be zero. } +{ } +{ Usage: r := A.Rank (echelon, 1e-8) } +{ Find the rank of A, place echelon in echelon } +{ } +{ ******************************************************************** } +function TMatrix.Rank (echelon : TMatrix; eps : double) : integer; +var Arow, Acol, i, j, n, m1, RowScan : integer; + factor : double; +begin + echelon.copy (Self); { we work on mat, not Self } + + if (eps = 0.0) then eps := 1.0E-14; + + n := echelon.r; m1 := echelon.c; + + Arow := 1; Acol := 1; + repeat + { locate a nonzero column } + if abs(echelon [Arow, Acol]) <= eps then { i.e equals zero } + begin + { First entry was zero, therefore work our way down the matrix + looking for a nonzero entry, when found, swap it for Arow } + RowScan := Arow; + repeat + { next row } + inc (RowScan); + { have we reached the end of the rows but we've still got columns left to scan } + if (RowScan > n) and (Acol < m1) then + begin + { reset row counter back to where it was and try next column } + RowScan := Arow; inc (Acol); + end; + + { If we've scanned the whole matrix, so lets get out... } + if (RowScan > n) then + begin + CleanUpMatrix (echelon, eps); + result := ComputeRank (echelon, eps); + exit; + end; + until abs (echelon [RowScan, Acol]) > eps; { keep searching until non-zero entry found } + + { We've found a nonzero row entry so swap it with + 'Arow' which did have a zero as its entry } + echelon.exchangeRows (Arow, RowScan); + end; + { Arow now holds the row of interest } + factor := 1.0/echelon [Arow, Acol]; + { reduce all the entries along the column by the factor } + for i := Acol to m1 do echelon[Arow,i] := echelon[Arow, i] * factor; + + { now eliminate all entries above and below Arow, this generates the reduced form } + for i := 1 to n do + { miss out Arow itself } + if (i <> Arow) and (abs (echelon [i, Acol]) > eps) then + begin + factor := echelon [i, Acol]; + { work your way along the column doing the same operation } + for j := Acol to m1 do + echelon[i,j] := echelon [i, j] - factor * echelon [Arow, j]; + end; + + inc (Arow); inc (Acol); + until (Arow > n) or (Acol > m1); + CleanUpMatrix (echelon, eps); + result := ComputeRank (echelon, eps); { This is just a patch for the moment } +end; + + +(* + Algorithm + + 1. Reduce matrix to reduced echelon form + 2. There will be as many null space vectors as there are + non-leading columns. Select one of these non-leading columns. + 3. Select the ith non-leading column and place a 1 at the ith + position in the growing null space vector + 4. Consider the remaining non-leading columns, say j,k,l... + and place zero's at positions j,k,l... in the growing null + vector. + 5. Consider now the column positions of the leading columns, say + l,m,n... The equivalent entries in the growing null space + are what remains to be filled in. Select each of these leading + columns in turn, say the lth first. Record which row the + leading one is in, say r. Then place at position l in the + growing null space vector, the element -1 * element (r, i) + where i is the original ith non-leading column selected in + step 3. Continue for leading columns m,n... until the growing + null space vector is complete. + 6. Go back to step 2 and pick another non-leading column to + compute the next null space vector. + +Does not disturb the matrix Self. Null space to be found in NullVectors, size of +the basis in BasisSize, the reduced row-echelon in Echelon and the rank in TheRank } + + Usage: A.NullSpace (N, b, Echelon, r); +*) +procedure TMatrix.NullSpace (var NullVectors : TMatrix; var BasisSize : integer; + var Echelon : TMatrix; var TheRank : integer); +var eps, x: double; + i, j, k : integer; + mask : TVectori; + tmpNullVectors : TMatrix; + VectorCounter, maskcount : integer; + minus999, minus888, EchelonCols : integer; +begin + try + eps := 0.000000001; + minus999 := -999; { leading column } + minus888 := -888; { non-leading column } + + if NullVectors <> Nil then NullVectors.free; + if Echelon <> Nil then Echelon.free; + + tmpNullVectors := TMatrix.Create (Self.c, Self.c); + Echelon := TMatrix.Create (Self.r, Self.c); + EchelonCols := Echelon.c; + mask := TVectori.create (EchelonCols); + + // STEP 1 + k := Self.Rank (Echelon, eps); + TheRank := k; + + k := Self.c - TheRank; + BasisSize := k; + if BasisSize > 0 then + begin + for i := 1 to EchelonCols do mask [i] := minus888; + + for i := 1 to Echelon.r do + begin + { scan along columns looking for a leading one } + j := 1; + repeat + x := Echelon[i, j]; + if (x > -eps) and (x < eps) then { check if its practically zero } + Echelon [i, j] := 0.0; + + if (x > 1.0-eps) and (x < 1.0+eps) then { x is then = 1.0 } + begin + mask [j] := minus999; { tag as leading column } + j := 0; { exit signal } + end + else + j := j + 1; + + until (j = 0) or (j > EchelonCols); + + end; { end row scan } + { Find non-leading columns } + VectorCounter := 1; + i := 1; { i = column counter, check all columns } + repeat + for j := 1 to EchelonCols do tmpNullVectors[j, VectorCounter] := minus888; + + { STEP 5 } + { remember, all minus888's in mask = non-leading columns } + if mask [i] = minus888 then { found a non-leading column } + begin + j := 1; + { move down mask } + for maskcount := 1 to EchelonCols do + if (mask [maskcount] = minus999) then + begin + tmpNullVectors[maskcount, VectorCounter] := -Echelon[j, i]; + inc (j); + end; + + { STEP 4 } + { zero all -888 (free) entries } + for j := 1 to EchelonCols do + if tmpNullVectors[j, VectorCounter] = minus888 then + tmpNullVectors[j, VectorCounter] := 0.0; + + { STEP 2 AND 3 } + { mark free variable } + tmpNullVectors[i, VectorCounter] := 1.0; + VectorCounter := VectorCounter + 1; + end; + inc (i); + until i > EchelonCols; + end + else + begin + BasisSize := 0; + NullVectors := Nil; + end; + finally + if BasisSize > 0 then + begin + NullVectors := TMatrix.Create (Self.c, BasisSize); + for i := 1 to Self.c do + for j := 1 to BasisSize do + NullVectors[i,j] := tmpNullVectors[i,j]; + end; + mask.free; + tmpNullVectors.free; + end; +end; + + +function sign (a, b : TMatElement) : TMatElement; +begin + if b >= 0.0 then + result := abs (a) + else + result := -abs(a); +end; + + +function max (a, b : TMatElement) : TMatElement; +begin + if a > b then + result := a + else + result := b; +end; + + +{ Compute sqrt (a^2 + b^2) using numerically more stable method. If x = sqrt(a^2 + b^2), +then, x/a^2 = 1/a^2 sqrt (a^2 + b^2), mult both sides by sqrt(..), so +x/a^2 * sqrt (a^2 + b^2) = 1/a^2 (a^2 + b^2) or +x/a^2 * sqrt (a^2 + b^2) = 1 + (b/a)^2 but on left side 1/a^2 sqrt(a^2 + b^2) equals +x/a^2, therefore x * x/a^2 = 1 + (b/a) ^2, take square roots on both side yields: +x/a := sqrt (1+(b/a)^2), or FINALLY: x := a sqrt (1 + (b/a)^2) } + +function pythag (a, b : TMatElement) : TMatElement; +var at, bt, ct : TMatElement; +begin + result := sqrt (a*a + b*b); + exit; + at := abs (a); bt := abs (b); + if at > bt then + begin + ct := bt/at; + result := at*sqrt (1 + ct*ct); + end + else + begin + if bt > 0 then + begin + ct := at/bt; + result := bt*sqrt (1 + ct*ct); + end + else + result := 0.0; + end; +end; + + function MyAbs (x : TMatElement) : TMatElement; + begin + if x < 0.0 then x := -x; + result := x; + end; + + +{procedure TMatrix.svd2 (var u : TMatrix; var w : TVector; var v : TMatrix);} +procedure TMatrix.svd2 (var u : TMatrix; var w : TVector; var v : TMatrix); +LABEL 1,2,3; +CONST + nmax=100; +VAR + n, m1, nm, l1, k, j, jj, its, i : integer; + z, y, x, scale, s, h, g, f, cc, anorm : real; + rv1 : TVector; //Aug : TMatrix; + AugMatrix : boolean; + + function sign(a,b: TMatElement): TMatElement; + begin + if (b >= 0.0) then sign := abs(a) else sign := -abs(a) + end; + + function max(a,b: TMatElement): TMatElement; + begin + if (a > b) then max := a else max := b + end; + +begin + m1 := r; n := c; AugMatrix := false; + (*if m < n then + begin + { More parameters than data ! Change structure of Self by augmenting + Self with additional rows (entries set to zero) so that m = n, don't change m or n though } + {Aug := TMatrix.Create (n, n); Aug.zero; + try + for i := 1 to m do + for j := 1 to n do + Aug[i,j] := Self[i,j]; + u.FreeSpace; u.SetSize (n, n); u.Copy (Aug); + AugMatrix := true; + finally + Aug.free; + end; + end + else*) + u.Copy(Self); { Work on U, don't destroy Self } + + + if AugMatrix then + rv1 := TVector.Create (n) { Make enough room } + else + rv1 := TVector.Create (m1); { Save some space } + g := 0.0; + scale := 0.0; + anorm := 0.0; + FOR i := 1 TO n DO BEGIN + l1 := i+1; + rv1[i] := scale*g; + g := 0.0; + s := 0.0; + scale := 0.0; + IF (i <= m1) THEN BEGIN + FOR k := i TO m1 DO scale := scale + Myabs(u[k,i]); + IF (Myabs(scale) > 1e-12) THEN BEGIN + {IF (scale <> 0.0) THEN BEGIN} + for k := i to m1 do + begin + u[k,i] := u[k,i]/scale; + s := s + u[k,i]*u[k,i] + end; + f := u[i,i]; + g := -sign(sqrt(s),f); + h := f*g-s; + u[i,i] := f-g; + if (i <> n) then + begin + for j := l1 to n do + begin + s := 0.0; + for k := i to m1 do s := s + u[k,i]*u[k,j]; + f := s/h; + for k := i to m1 do u[k,j] := u[k,j] + f*u[k,i]; + end + end; + for k := i to m1 do u[k,i] := scale*u[k,i] + END + END; + w[i] := scale*g; + g := 0.0; + s := 0.0; + scale := 0.0; + IF ((i <= m1) AND (i <> n)) THEN BEGIN + for k := l1 to n do scale := scale + Myabs(u[i,k]); + if (Myabs(scale) > 1e-12) then begin + {if (scale <> 0.0) then begin} + for k := l1 to n do + begin + u[i,k] := u[i,k]/scale; + s := s + u[i,k]*u[i,k] + end; + f := u[i,l1]; + g := -sign(sqrt(s),f); + h := f*g-s; + u[i,l1] := f-g; + for k := l1 to n do rv1[k] := u[i,k]/h; + if (i <> m1) then + begin + for j := l1 to m1 do + begin + s := 0.0; + for k := l1 to n do s := s + u[j,k]*u[i,k]; + for k := l1 to n do u[j,k] := u[j,k] + s*rv1[k]; + end + end; + for k := l1 to n do u[i,k] := scale*u[i,k]; + END + END; + anorm := max(anorm,(Myabs(w[i]) + Myabs(rv1[i]))) + END; + + FOR i := n DOWNTO 1 DO BEGIN + IF (i < n) THEN BEGIN + if (Myabs(g) > 1e-12) then + {IF (g <> 0.0) THEN} + begin + for j := l1 to n do v[j,i] := (u[i,j]/u[i,l1])/g; + for j := l1 to n do + begin + s := 0.0; + for k := l1 to n do s := s + u[i,k]*v[k,j]; + for k := l1 to n do v[k,j] := v[k,j] + s*v[k,i] + end + end; + for j := l1 to n do + begin + v[i,j] := 0.0; + v[j,i] := 0.0; + end + END; + v[i,i] := 1.0; + g := rv1[i]; + l1 := i + end; + FOR i := n DOWNTO 1 DO BEGIN + l1 := i+1; + g := w[i]; + if (i < n) then for j := l1 to n do u[i,j] := 0.0; + if (Myabs(g) > 1e-12) then + {IF (g <> 0.0) THEN} + begin + g := 1.0/g; + IF (i <> n) THEN + begin + for j := l1 to n do + begin + s := 0.0; + for k := l1 to m1 do s := s + u[k,i]*u[k,j]; + f := (s/u[i,i])*g; + for k := i to m1 do u[k,j] := u[k,j] + f*u[k,i]; + end + end; + for j := i to m1 do u[j,i] := u[j,i]*g; + end else + begin + for j := i to m1 do u[j,i] := 0.0; + end; + u[i,i] := u[i,i]+1.0 + END; + FOR k := n DOWNTO 1 DO BEGIN + FOR its := 1 TO 30 DO BEGIN + for l1 := k downto 1 do + begin + nm := l1-1; + if ((Myabs(rv1[l1]) + anorm) - anorm < 1e-12) then goto 2; + {if ((Myabs(rv1[l]) + anorm) = anorm) then goto 2;} + if ((Myabs(w[nm]) + anorm) - anorm < 1e-12) then goto 1 + {if ((Myabs(w[nm]) + anorm) = anorm) then goto 1} + end; +1: cc := 0.0; + s := 1.0; + for i := l1 to k do + begin + f := s*rv1[i]; + if ((Myabs(f) + anorm) - anorm > 1e-12) then + {if ((Myabs(f)+anorm) <> anorm) then} + begin + g := w[i]; + h := sqrt(f*f+g*g); + w[i] := h; + h := 1.0/h; + cc := (g*h); + s := -(f*h); + for j := 1 to m1 do + begin + y := u[j,nm]; + z := u[j,i]; + u[j,nm] := (y*cc)+(z*s); + u[j,i] := -(y*s)+(z*cc) + end + end + end; +2: z := w[k]; + if (l1 = k) then + begin + if (z < 0.0) then + begin + w[k] := -z; + for j := 1 to n do v[j,k] := -v[j,k]; + end; + GOTO 3 + end; + if (its = 30) then writeln ('no convergence in 30 SVDCMP iterations'); + x := w[l1]; + nm := k-1; + y := w[nm]; + g := rv1[nm]; + h := rv1[k]; + f := ((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y); + g := sqrt(f*f+1.0); + f := ((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x; + cc := 1.0; + s := 1.0; + for j := l1 to nm do + begin + i := j+1; + g := rv1[i]; + y := w[i]; + h := s*g; + g := cc*g; + z := sqrt(f*f+h*h); + rv1[j] := z; + cc := f/z; + s := h/z; + f := (x*cc)+(g*s); + g := -(x*s)+(g*cc); + h := y*s; + y := y*cc; + for jj := 1 to n do + begin + x := v[jj,j]; + z := v[jj,i]; + v[jj,j] := (x*cc)+(z*s); + v[jj,i] := -(x*s)+(z*cc) + end; + z := sqrt(f*f+h*h); + w[j] := z; + if (Myabs(z) > 1e-12) then + {if (z <> 0.0) then} + begin + z := 1.0/z; + cc := f*z; + s := h*z + end; + f := (cc*g)+(s*y); + x := -(s*g)+(cc*y); + for jj := 1 to m1 do + begin + y := u[jj,j]; + z := u[jj,i]; + u[jj,j] := (y*cc)+(z*s); + u[jj,i] := -(y*s)+(z*cc) + end + end; + rv1[l1] := 0.0; + rv1[k] := f; + w[k] := x + END; +3: END + + +END; + + +{ Perform a Singular Value Decompostion on self, returning u, w, and v, modified +from Numerical Recipes and Forsythe et al 1977, Computer methods for Math Calc } +procedure TMatrix.svd (var u : TMatrix; var w : TVector; var v : TMatrix); +label 3; +var i, j, k, l1, n, m1, its, flag, nm, jj : integer; rv1 : TVector; + scale, g, h, f, anorm, s, cc, x, y, z : TMatElement; Aug : TMatrix; + AugMatrix : boolean; +begin + m1:= r; n := c; AugMatrix := false; + if m1 < n then + begin + { More parameters than data ! Change structure of Self by augmenting + Self with additional rows (entries set to zero) so that m = n, don't change m or n though } + Aug := TMatrix.Create (n, n); Aug.zero; + try + for i := 1 to m1 do + for j := 1 to n do + Aug[i,j] := Self[i,j]; + u.FreeSpace; u.SetSize (n, n); u.Copy (Aug); + AugMatrix := true; + finally + Aug.free; + end; + end + else + u.Copy(Self); { Work on U, don't destroy Self } + + scale := 0.0; g := 0.0; anorm := 0.0; + if AugMatrix then + rv1 := TVector.Create (n) { Make enough room } + else + rv1 := TVector.Create (m1); { Save some space } + + try + for i := 1 to n do + begin + l1 := i + 1; + rv1[i] := scale * g; + g := 0.0; s := 0.0; scale := 0.0; + if i <= m1 then + begin + for k := i to m1 do scale := scale + abs (u[k,i]); + if scale <> 0.0 then + begin + for k := i to m1 do + begin + u[k, i] := u[k, i] / scale; + s := s + u[k,i]*u[k,i]; + end; + f := u[i,i]; + g := -sign (sqrt (s), f); + h := f*g - s; + u[i,i] := f - g; + if i <> n then + begin + for j := l1 to n do + begin + s := 0.0; + for k := i to m1 do s := s + u[k,i]*u[k,j]; + f := s/h; + for k := i to m1 do u[k,j] := u[k,j] + f*u[k,i]; + end; + end; + for k := i to m1 do u[k,i] := u[k,i] * scale; + end; + end; + w[i] := scale * g; + g := 0.0; s := 0.0; scale := 0.0; + if (i <= m1) and (i <> n) then + begin + for k := l1 to n do scale := scale + abs (u[i,k]); + if scale <> 0.0 then + begin + for k := l1 to n do + begin + u[i,k] := u[i,k] / scale; + s := s + u[i,k]*u[i,k]; + end; + f := u[i,l1]; + g := -sign(sqrt (s), f); + h := f*g - s; + u[i,l1] := f - g; + for k := l1 to n do rv1[k] := u[i,k]/h; + if i <> m1 then + begin + for j := l1 to m1 do + begin + s := 0.0; + for k := l1 to n do s := s + u[j,k]*u[i,k]; + for k := l1 to n do u[j,k] := u[j,k] + s*rv1[k]; + end; + end; + for k := l1 to n do u[i,k] := u[i,k] * scale; + end; + end; + anorm := max (anorm, abs(w[i]) + abs(rv1[i])); + end; + + { ------------------------------------------ } + { Accumulation of right-hand transformations } + for i := n downto 1 do + begin + if i < n then + begin + if g <> 0.0 then + begin + for j := l1 to n do v[j,i] := (u[i,j]/u[i,l1])/g; + for j := l1 to n do + begin + s := 0.0; + for k := l1 to n do s := s + u[i,k]*v[k,j]; + for k := l1 to n do v[k,j] := v[k,j] + s*v[k,i]; + end; + end; + for j := l1 to n do begin v[i,j] := 0.0; v[j,i] := 0.0; end; + end; + v[i,i] := 1.0; + g := rv1[i]; + l1 := i; + end; + + { ------------------------------------------ } + { Accumulation of left-hand transformations } + for i := n downto 1 do + begin + l1 := i + 1; + g := w[i]; + if i < n then for j := l1 to n do u[i,j] := 0.0; + if g <> 0.0 then + begin + g := 1.0/g; + if i <> n then + begin + for j := l1 to n do + begin + s := 0.0; + for k := l1 to m1 do s := s + u[k,i]*u[k,j]; + f := (s/u[i,i])*g; + for k := i to m1 do u[k,j] := u[k,j] + f*u[k,i]; + end; + end; + for j := i to m1 do u[j,i] := u[j,i] * g; + end + else + begin + for j := i to m1 do u[j,i] := 0.0; + end; + u[i,i] := u[i,i] + 1.0; + end; + + { --------------------------------------------- } + { Diagonalization of the bidiagonal form } + for k := n downto 1 do + begin + for its := 1 to 30 do + begin + flag := 1; + for l1 := k downto 1 do + begin + nm := l1 - 1; + if abs (rv1[l1] + anorm) = anorm then + begin + flag := 0; + break; + end; + if abs (w[nm] + anorm) = anorm then break; + end; + if flag <> 0 then + begin + cc := 0.0; s := 1.0; + for i := l1 to k do + begin + f := s * rv1[i]; + if (abs (f) + anorm) <> anorm then + begin + g := w[i]; + h := pythag (f, g); + w[i] := h; + h := 1.0/h; + cc := g*h; + s := -f*h; + for j := 1 to m1 do + begin + y := u[j,nm]; + z := u[j, i]; + u[j,nm] := y*cc + z*s; + u[j,i] := z*cc - y*s; + end; + end; + end; + end; + z := w[k]; + if l1 = k then + begin + if z < 0.0 then + begin + w[k] := -z; + for j := 1 to n do v[j,k] := -v[j,k]; + end; + {break;} goto 3; + end; + if (its = 30) then raise Exception.Create ('Exceeded iterations in SVD routine'); + x := w[l1]; + nm := k - 1; + y := w[nm]; g := rv1[nm]; + h := rv1[k]; + f := ((y - z)*(y + z) + (g - h)*(g + h))/(2.0*h*y); + g := pythag (f, 1.0); + f := ((x - z) * (x + z) + h*((y/(f + sign(g, f))) - h))/x; + + cc := 1.0; s := 1.0; + for j := l1 to nm do + begin + i := j + 1; + g := rv1[i]; + y := w[i]; h := s*g; + g := cc*g; + z := pythag (f, h); + rv1[j] := z; + cc := f/z; s := h/z; + f := x*cc + g*s; g := g*cc - x*s; + h := y*s; + y := y*cc; + for jj := 1 to n do + begin + x := v[jj,j]; z := v[jj,i]; + v[jj,j] := x*cc + z*s; + v[jj,i] := z*cc - x*s; + end; + z := pythag (f, h); + w[j] := z; + if z <> 0 then + begin + z := 1.0/z; cc := f*z; s := h*z; + end; + f := (cc*g) + (s*y); + x := (cc*y) - (s*g); + for jj := 1 to m1 do + begin + y := u[jj,j]; z := u[jj,i]; + u[jj,j] := y*cc + z*s; + u[jj,i] := z*cc - y*s; + end; + end; + rv1[l1] := 0.0; + rv1[k] := f; + w[k] := x; +3: end; + end; + finally + rv1.free; + end; + + if AugMatrix then + begin + { This means that originally m < n, therefore u has some junk rows, remove them here } + Aug := TMatrix.Create (m1, n); + try + for i := 1 to m1 do + for j := 1 to n do + Aug[i,j] := u[i,j]; + u.FreeSpace; u.SetSize (m1, n); u.Copy (Aug); + finally + Aug.free; + end; + end; +end; + + + +{ Call this after having called svd, computes x = V [diag (1/wj)]. U^t.b } +procedure TMatrix.svdSolve (var u : TMatrix; var w : TVector; var v : TMatrix; + b : TVector; var x : TVector); +var j, i, n, m1 : integer; s: TMatElement; tmp: TVector; +begin + m1 := u.r; n := u.c; + tmp := TVector.Create (u.c); + try + { Compute diag (1/wj) . U^t . b } + for j := 1 to n do + begin + s := 0.0; + if (w[j] <> 0.0) then + begin + for i := 1 to m1 do s := s + u[i,j]*b[i]; + s := s/w[j] + end; + tmp[j] := s + end; + { ...mult by V to get solution vector x } + for i := 1 to n do + begin + s := 0.0; + for j := 1 to w.size do s := s + v[i,j]*tmp[j]; + x[i] := s + end; + finally + tmp.free; + end; +end; + + +{ Solves the equation: (A.a - b)^2 = 0 for a. Where, A is the 'design matrix', +Aij = Xj(xi)/sigi, where Xj is the value of the jth basis function; b is the set +of weighted observed y values, b = yi/sigi; and a is the set of fitting coefficients +for the basis functions. Thus A.a - b expresses predicted - observed } + +{ BasisProc is a procedure which must return in an array the values for the +basis functions at a particular value of xi, i.e it computes, Xj(xi) } + +function TMatrix.svdfit (x, y, yerr : TVector; var fit : TVector; + var u, v : TMatrix; var w : TVector; funcs : BasisProc): TMatElement; +const + tol=1.0e-5; +var + i, j : integer; wmax, weight, thresh, sum: TMatElement; + BasisVal, b : TVector; A : TMatrix; +begin + BasisVal := TVector.Create (fit.size); b := TVector.Create (x.size); + A := TMatrix.Create (x.size, fit.size); + try + { Form the A matrix } + for i := 1 to x.size do + begin + funcs(x[i], BasisVal); + weight := 1.0/yerr[i]; + for j := 1 to fit.size do A[i,j] := BasisVal[j]*weight; + b[i] := y[i]*weight + end; + A.svd (u, w, v); + + wmax := 0.0; + for j := 1 to fit.size do if (w[j] > wmax) then wmax := w[j]; + thresh := tol*wmax; + for j := 1 to fit.size do if (w[j] < thresh) then w[j] := 0.0; + + svdSolve (u, w, v, b, fit); + + result := 0.0; { chisqr set to zero ready to accumulate } + for i := 1 to x.size do + begin + funcs(x[i], BasisVal); + sum := 0.0; + for j := 1 to fit.size do sum := sum + fit[j]*BasisVal[j]; + result := result + sqr((y[i]-sum)/yerr[i]); { Accumulate chisqr } + end; + finally + BasisVal.free; A.free; b.free; + end; +end; + + +procedure TMatrix.svdCovar (v : TMatrix; w : TVector; alpha : TMatrix); +var i, j, k : integer; wti : TVector; sum : TMatElement; +begin + wti := TVector.Create (w.size); + try + for i := 1 to w.size do + begin + wti[i] := 0.0; + if w[i] > 0.0 then wti[i] := 1.0/(w[i]*w[i]); + end; + for i := 1 to w.size do + begin + for j := 1 to i do + begin + sum := 0.0; + for k := 1 to w.size do sum := sum + v[i,k]*v[j,k]*wti[k]; + alpha[j,i] := sum; alpha[i,j] := alpha[j,i]; + end; + end; + finally + wti.free; + end; +end; + + +procedure TMatrix.eliminate_cms (S, Tk1 : TMatrix; var cr, N : integer); (* eliminating conserved moieties *) +var + i,j,x,y,crc,old_cr : byte; +begin + x := 0; cr := 0; (* cr - conservation relations *) + for i := 1 to N do + begin + old_cr := cr; + for j := i+1 to N do + begin + crc := 0; (* crc - cr counter *) + // S.c = number of reactions + for y := 1 to S.c do crc := crc + trunc (abs(S[i,y]+S[j,y])); + if crc = 0 then cr := cr+1; + end; + if cr = old_cr then + begin + x := x+1; + for y := 1 to S.c do + Tk1[x,y] := S[i,y]; + end; + end; +end; + + +procedure TMatrix.ElementaryModes (D : TVectori; var mf, mb, C1, k : integer; Tk : TMatrix); +var i, j, cr, N, k1 : integer; Tk1 : TMatrix; hlpRow : TVector; +begin + N := Self.r; + Tk1 := TMatrix.Create (Self.r, Self.c); + hlpRow := TVector.Create (Self.c); + try + {eliminate_cms; (* also transscribing S into Tk1 *) + N := N-cr; + + for i := 1 to R do + begin + for j := 1 to N do Tk[i,j] := Tk1[j,i]; (* transposing matrix *) + for j:=N+1 to N+R do + if i=j-N then + Tk[i,j]:=1 (* appending.. *) + else Tk[i,j]:=0; (*..unity matrix*) + end; + (* (preliminary) fund. rows to the top *) + i := 0; (* splitting indices into F/B *) + for j := 1 TO R DO + begin + if (D[j] <> 0) then + begin + i := i+1; + hlprow := Tk[i]; + Tk[i] := Tk[j]; + Tk[j] := hlprow; + end; + end; + mf := i; (* no. of fundamental rows *) + mb := R-mf;} + + + + eliminate_cms (Self, Tk1, cr, N); (* also transscribing S into Tk1 *) + N := N-cr; + + for i := 1 to Self.c do + begin + for j := 1 to N do Tk[i,j] := Tk1[j,i]; (* transposing matrix *) + for j := N+1 to N+Self.c do + if i=j-N then + Tk[i,j] := 1 (* appending.. *) + else Tk[i,j] := 0; (*..unity matrix*) + end; + (* (preliminary) fund. rows to the top *) + i := 0; (* splitting indices into F/B *) + for j := 1 TO Self.c DO + begin + if (D[j] <> 0) then + begin + i := i+1; + for k1 := 1 to Self.c do hlprow[k1] := Tk[i,k1]; + for k1 := 1 to Self.c do Tk[i,k1] := Tk[j,k1]; + for k1 := 1 to Self.c do Tk[j,k1] := hlprow[k1]; + //hlprow := Tk[i]; + //Tk[i] := Tk[j]; + //Tk[j] := hlprow; + end; + end; + mf := i; (* no. of fundamental rows *) + mb := Self.c-mf; (* no. of basis rows *) + + Tableau (N, Self.c, mf, mb, C1, k, Tk, Tk1); + finally + hlpRow.Free; + Tk1.Free; + end; +end; + + +class function TMatrix.grecodiv(P, Rest: integer) : integer; +var + old_Rest : integer; +begin + grecodiv := 1; + if (Rest*P <> 0) then + begin + if ABS(P) < ABS(Rest) then + begin + old_Rest := Rest; + Rest := P; + P := old_Rest; (* swap P 'n' R *) + end; + + repeat (* Euclidean Algorithm: *) + old_Rest := Rest; + Rest := P mod old_Rest; + P := old_Rest; + until (Rest = 0); + grecodiv := P; + end + else + if (P = 0) then + begin + if (Rest = 0) then grecodiv := 1 else grecodiv := Rest; + end + else grecodiv := P; +end; + + +class function TMatrix.grecodiv_of_vector (N, R1 : integer; vec : TVector) : integer; +var + x : byte; + coeff : integer; +begin + coeff := trunc (vec[1]); + for x := 2 to (N+R1) do + begin + if (vec[x] <> 0) then coeff := grecodiv(trunc (vec[x]), coeff); + end; + grecodiv_of_vector := coeff; +end; + + + + + +class procedure TMatrix.Tableau (N, R1 : integer; var mf, mb, C1, k : integer; Tk, Tk1 : TMatrix); +var + i,j,k1,x,xa,y,m1 : integer; + cf,dir,ifrom,iend : integer; + index,bool,allow_comb : boolean; + l1 : integer; + vec : TVector; +begin + C1 := R1; (* C: number of rows of the tableau *) + k := 0; (* k: tableau index *) + vec := TVector.Create (Tk1.c); + + repeat + + //output; (* HELPFUL MONITORING*) + //write(' k = ');writeln(k);writeln('cf=',cf); (* OF TABLEAU STEPS *) + {write(' Press <ENTER> to continue.'); readln;} + + l1 := 1; (* l: row index in the tableau k+1 *) + cf := 0; (* counter for f-rows in the tableau k+1*) + for dir :=1 to 2 do + BEGIN + IF dir=1 THEN + BEGIN + ifrom:=1; iend:=mf; + END + ELSE + BEGIN + ifrom:=mf+1; iend:=c1 + END; + FOR i := ifrom TO iend DO + BEGIN + IF Tk[i,k+1] = 0 THEN (* copying rows that *) + BEGIN (* have a zero element *) + for k1 := 1 to Tk1.c do + Tk1[l1, k1] := Tk[i, k1]; (* already *) + //Tk1[l] := Tk[i]; (* already *) + l1 := l1+1; + IF i <= mf THEN cf := cf+1; + END + END; + FOR i:=ifrom TO iend DO + BEGIN + IF Tk[i,k+1]<>0 THEN + BEGIN + FOR j := i+1 TO C1 DO + BEGIN + IF Tk[j,k+1] <> 0 THEN + BEGIN + IF Tk[i,k+1]*Tk[j,k+1] > 0 THEN + BEGIN (* not for f-rows with *) + IF j <= mf THEN + allow_comb := false (* same signum *) + ELSE + BEGIN + FOR y := 1 TO N+R1 DO Tk[j,y] := -1 * Tk[j,y]; (* invert b-row *) + allow_comb := true; + END; + END + ELSE allow_comb := true; + IF allow_comb THEN + BEGIN + index:=true; (* first simplicity (S) test: *) + IF (l1>1) THEN + BEGIN + IF dir=1 THEN x:=0 + ELSE x:=cf; + WHILE (x<l1-1) AND (INDEX) DO + BEGIN + x:=x+1; + y:=n; + bool:=true; + REPEAT + y:=y+1; + IF ((Tk[i,y] = 0) and (Tk[j,y] = 0)) THEN + IF Tk1[x,y] <> Tk[i,y] THEN bool:=false; + UNTIL (y=n+r1)or NOT bool; + IF (y=n+r1)and bool THEN index:=false; + END; + END; + IF index THEN + BEGIN (* combine rows *) + FOR y:=1 TO R1+N DO + Tk1[l1,y]:=abs(Tk[i,k+1])*Tk[j,y]+abs(Tk[j,k+1])*Tk[i,y]; + + for k1 := 1 to Tk1.c do + vec[i] := Tk1[l1,k1]; + + m1:= Grecodiv_of_vector(N, R1, vec) ; + //m:= Grecodiv_of_vector(Tk1[l]) ; + IF (ABS(m1)<>1) AND (m1<>0) THEN FOR y:=1 to R1+N DO + Tk1[l1,y]:= trunc (Tk1[l1,y]) DIV ABS(m1); + l1:= l1+1; + IF i <= mf THEN cf := cf+1; + (* second simplicity (S) test: *) + IF dir=1 THEN x:=0 + ELSE x:=cf; + bool:=true; + WHILE (X<L1-2) AND (bool=true) DO + BEGIN + x:=x+1; + y:=n; + bool:=false; + REPEAT + y:=y+1; + IF Tk1[x,y]=0 THEN + IF (Tk1[x,y]<>Tk[i,y]) OR (Tk1[x,y]<>Tk[j,y]) + THEN bool:=true; + UNTIL (y=n+r1)or bool; + IF (y=n+r1)and NOT(bool) THEN + BEGIN + {writeln('Jetzt hat folgende Zeile:'); + FOR Y:=n+1 to n+r DO + write(Tk1[x,y]:3); + writeln; writeln('x=',x); + writeln; writeln('l-1=',l-1); + writeln('verloren gegen folgende Zeilen:'); + FOR Y:=n+1 to n+r DO + write(Tk[i,y]:3); + writeln; writeln('i=',i); + FOR Y:=n+1 to n+r DO + write(Tk[j,y]:3); + writeln; writeln('j=',j); writeln; + writeln(x,'+1te Zeile:'); + FOR Y:=n+1 to n+r DO + write(Tk1[x+1,y]:3); + writeln;} + FOR xa:=x TO l1-2 DO + BEGIN + FOR y:=1 TO n+r1 DO + Tk1[xa,y]:=Tk1[xa+1,y]; + END; + l1:=l1-1; + IF x<=cf THEN cf:=cf-1; + END; + END; + END; + END; + END; + END; + END; + END; + END; + + C1 := l1-1; (* new no. of rows *) + mf := cf; + mb := C1-mf; + + k := k+1; (* next tableau *) + for i := 1 to C1 do + begin + for k1 := 1 to Tk.c do + Tk[i, k1] := Tk1[i, k1]; (* restarting with Tk1 *) + end; + //for i := 1 to C do Tk[i] := Tk1[i]; (* restarting with Tk1 *) + + until (k = N) or ((mb = 0) and (mf = 0)); + + //if ((mb = 0) and (mf = 0)) then + // writeln(' There exist neither irreversible nor reversible flux modes.') + //else + // output; + vec.Free; +end; + + +// Evaluate conservation relations, uses the algorthim: tr(ns(tr(m))) +procedure TMatrix.Conserve(st : TMatrix); +var tmp, ns, echelon : TMatrix; b, r1 : integer; +begin + tmp := TMatrix.Create (st.c, st.r); + ns := TMatrix.Create (1,1); + echelon := TMatrix.Create (1,1); + try + tmp.Transpose (st); + tmp.NullSpace (ns, b, Echelon, r1); + Self.SetSize (ns.c, ns.r); + Self.Transpose (ns); + finally + ns.free; + echelon.free; + tmp.free; + end; +end; + + +end. diff --git a/npm_precl/ReadFloat.dfm b/npm_precl/ReadFloat.dfm new file mode 100755 index 0000000..4c22c67 Binary files /dev/null and b/npm_precl/ReadFloat.dfm differ diff --git a/npm_precl/ReadFloat.pas b/npm_precl/ReadFloat.pas new file mode 100755 index 0000000..316fe92 --- /dev/null +++ b/npm_precl/ReadFloat.pas @@ -0,0 +1,45 @@ +unit ReadFloat; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin; + +type + TReadFloatForm = class(TForm) + OKBtn: TButton; + ReadFloatLabel: TLabel; + ReadFloatEdit: TRxSpinEdit; + function GetFloat(lStr: string; lMin,lDefault,lMax: double): double; + + procedure OKBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + ReadFloatForm: TReadFloatForm; + +implementation + +{$R *.DFM} + function TReadFloatForm.GetFloat(lStr: string; lMin,lDefault,lMax: double): double; + begin + //result := lDefault; + ReadFloatLabel.caption := lStr+' ['+floattostr(lMin)+'..'+floattostr(lMax)+']'; + ReadFloatEdit.MinValue := lMin; + ReadFloatEdit.MaxValue := lMax; + ReadFloatEdit.Value := lDefault; + ReadFloatForm.ShowModal; + result := ReadFloatEdit.Value; + end; + +procedure TReadFloatForm.OKBtnClick(Sender: TObject); +begin + ReadFloatForm.ModalResult := mrOK; +end; + +end. diff --git a/npm_precl/ReadInt.dfm b/npm_precl/ReadInt.dfm new file mode 100755 index 0000000..6dc59bd Binary files /dev/null and b/npm_precl/ReadInt.dfm differ diff --git a/npm_precl/ReadInt.lfm b/npm_precl/ReadInt.lfm new file mode 100755 index 0000000..110f4d6 --- /dev/null +++ b/npm_precl/ReadInt.lfm @@ -0,0 +1,48 @@ +object ReadIntForm: TReadIntForm + Left = 306 + Height = 80 + Top = 554 + Width = 469 + HorzScrollBar.Page = 468 + VertScrollBar.Page = 79 + ActiveControl = ReadIntEdit + BorderStyle = bsDialog + Caption = 'Integer required' + ClientHeight = 80 + ClientWidth = 469 + Constraints.MaxHeight = 80 + Constraints.MaxWidth = 469 + Constraints.MinHeight = 80 + Constraints.MinWidth = 469 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '0.9.28.2' + object ReadIntLabel: TLabel + Left = 16 + Height = 14 + Top = 12 + Width = 336 + Alignment = taRightJustify + AutoSize = False + Caption = 'Enter a number' + ParentColor = False + end + object ReadIntEdit: TSpinEdit + Left = 360 + Height = 27 + Top = 12 + Width = 93 + MaxValue = 0 + TabOrder = 0 + end + object OKBtn: TButton + Left = 368 + Height = 25 + Top = 44 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + OnClick = OKBtnClick + TabOrder = 1 + end +end diff --git a/npm_precl/ReadInt.lrs b/npm_precl/ReadInt.lrs new file mode 100755 index 0000000..99ed363 --- /dev/null +++ b/npm_precl/ReadInt.lrs @@ -0,0 +1,18 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TReadIntForm','FORMDATA',[ + 'TPF0'#12'TReadIntForm'#11'ReadIntForm'#4'Left'#3'2'#1#6'Height'#2'P'#3'Top'#3 + +'*'#2#5'Width'#3#213#1#18'HorzScrollBar.Page'#3#212#1#18'VertScrollBar.Page' + +#2'O'#13'ActiveControl'#7#11'ReadIntEdit'#11'BorderStyle'#7#8'bsDialog'#7'Ca' + +'ption'#6#16'Integer required'#12'ClientHeight'#2'P'#11'ClientWidth'#3#213#1 + +#21'Constraints.MaxHeight'#2'P'#20'Constraints.MaxWidth'#3#213#1#21'Constrai' + +'nts.MinHeight'#2'P'#20'Constraints.MinWidth'#3#213#1#9'Font.Name'#6#13'MS S' + +'ans Serif'#8'OnCreate'#7#10'FormCreate'#8'Position'#7#14'poScreenCenter'#10 + +'LCLVersion'#6#8'0.9.28.2'#0#6'TLabel'#12'ReadIntLabel'#4'Left'#2#16#6'Heigh' + +'t'#2#14#3'Top'#2#12#5'Width'#3'P'#1#9'Alignment'#7#14'taRightJustify'#8'Aut' + +'oSize'#8#7'Caption'#6#14'Enter a number'#11'ParentColor'#8#0#0#9'TSpinEdit' + +#11'ReadIntEdit'#4'Left'#3'h'#1#6'Height'#2#27#3'Top'#2#12#5'Width'#2']'#8'M' + +'axValue'#2#0#8'TabOrder'#2#0#0#0#7'TButton'#5'OKBtn'#4'Left'#3'p'#1#6'Heigh' + +'t'#2#25#3'Top'#2','#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Capti' + +'on'#6#2'OK'#7'OnClick'#7#10'OKBtnClick'#8'TabOrder'#2#1#0#0#0 +]); diff --git a/npm_precl/ReadInt.pas b/npm_precl/ReadInt.pas new file mode 100755 index 0000000..98813e4 --- /dev/null +++ b/npm_precl/ReadInt.pas @@ -0,0 +1,60 @@ +unit ReadInt; + +interface + +uses + {$IFDEF FPC} LResources,{$ENDIF} + Buttons{only Lazarus?},SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Spin; + +type + TReadIntForm = class(TForm) + ReadIntEdit: TSpinEdit; + ReadIntLabel: TLabel; + OKBtn: TButton; + function GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + procedure OKBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + public + + { Public declarations } + end; + +var + ReadIntForm: TReadIntForm; + +implementation + + + {$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + function TReadIntForm.GetInt(lStr: string; lMin,lDefault,lMax: integer): integer; + begin + //result := lDefault; + ReadIntLabel.caption := lStr+' ['+inttostr(lMin)+'..'+inttostr(lMax)+']'; + ReadIntEdit.MinValue := lMin; + ReadIntEdit.MaxValue := lMax; + ReadIntEdit.Value := lDefault; + ReadIntForm.ShowModal; + result := ReadIntEdit.Value; + end; + +procedure TReadIntForm.OKBtnClick(Sender: TObject); +begin + ReadIntForm.ModalResult := mrOK; +end; + + +procedure TReadIntForm.FormCreate(Sender: TObject); +begin +end; + +{$IFDEF FPC} +initialization + {$I ReadInt.lrs} +{$ENDIF} + +end. diff --git a/npm_precl/StatThds.pas b/npm_precl/StatThds.pas new file mode 100755 index 0000000..afd7927 --- /dev/null +++ b/npm_precl/StatThds.pas @@ -0,0 +1,565 @@ +unit StatThds; + +interface + +uses + ComCtrls,Classes, Graphics, ExtCtrls, define_types,stats,StatThdsUtil,Brunner,lesion_pattern; + + + +type + + TStatThread = class(TThread) + private + lBarX: TProgressBar; + lttestx,lBMx: boolean; + lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lnGroup1x : integer; + lMaskImgx,lPlankImgx,lOutImgMnx,lOutImgBMx,lOutImgTx,lSymptomRAx: SingleP; + //lBarX: TProgressBar; + procedure DoVisualSwap; + protected + procedure Execute; override; + procedure VisualProg(lPos: Integer); + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); virtual; abstract; + public + constructor Create(lBar: TProgressBar;lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); + end; + +{ VBM - two groups } + + TNNStat = class(TStatThread) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + + TPairedTStat = class(TStatThread) + protected + procedure Analyze(lunused1,lunused2: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + { Lesion - image reveals value } + + TLesionStat = class(TStatThread) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); override; + end; + + TLesionBinomial = class(TStatThread) + protected + procedure Analyze(lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); override; + end; + +implementation +//uses Stat; + + +{ TSortThread } + +(*tpIdle The thread executes only when the system is idle. The system will not interrupt other threads to execute a thread with tpIdle priority. +tpLowest The thread's priority is two points below normal. +tpLower The thread's priority is one point below normal. +tpNormal The thread has normal priority. +tpHigher The thread's priority is one point above normal. +tpHighest The thread's priority is two points above normal. +tpTimeCritical*) + +Const Two32 = 4294967296.0 ; +function GenRandThreaded(lRange: integer; var lRandSeed:comp): integer; +//normal random function does not work well when threaded - randseed is changed by each thread +const lFactor = $08088405 ; lTerm = 1 ; +type lT = array [0..1] of longint ; +var + lX: extended; +begin + lRandSeed := lRandSeed*lFactor + lTerm; + lT(lRandSeed)[1] := 0 ; // < May'04 was: RS := RS - Trunc(RS/Two32)*Two32 ; + lX := lRandSeed/Two32 ; + result := trunc((lRange)*lX); +end; + +procedure GenPermuteThreaded (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: double; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteThreaded (lttest,lBM: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lttest then begin + TStat2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lBM then begin + BMTest (lnSubj, lnGroup0, lRanOrder,lOutT); + if lOutT > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lOutT; + if lOutT < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lOutT; + end; //compute BM + end; + freemem(lRanOrderp); +end; + +procedure StatPermuteBinomialThreaded (lChi2,lLieber: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lChi2 then begin + Chi2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lLieber then begin + Liebermeister2 (lnSubj, lnGroup0, lRanOrder,lOutT); + if lOutT > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lOutT; + if lOutT < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lOutT; + end; //compute BM + end; + freemem(lRanOrderp); +end; + + +procedure TStatThread.DoVisualSwap; +begin + lBarX.Position := lBarPosX; +end; + +procedure TStatThread.VisualProg(lPos: Integer); +begin + lBarPosX := lPos; + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} +end; + +constructor TStatThread.Create(lBar: TProgressBar; lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +begin + lBarX := lBar; + lttestx := lttest; + lBMx:= lBM; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lnGroup1x := lnGroup1; + lMaskImgx := lMaskImg; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgBMx := lOutImgBM; + lOutImgTx := lOutImgT; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + FreeOnTerminate := True; + inherited Create(False); +end; + + + +{ The Execute method is called when the thread starts } + +procedure TStatThread.Execute; +begin + Analyze(lttestx,lBMx, lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lnGroup1x,lMaskImgx,lPlankImgX,lOutImgMnx,lOutImgBMx,lOutImgTx,lSymptomRAx); +end; + + + +{ Nearest Nighbor } +procedure TNNStat.Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + + lPosPct,lPos,lPos2,lPos2Offset: integer; + lSum: single; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(gnVoxTestedRA[lThread]); + lSum := 0; + for lPos := 1 to lImagesCount do begin + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSum := lSum + lObs^[lPos-1]; + end; + lOutImgMn^[lPos2Offset] := lSum/lImagesCount; + if lttest then begin + TStat2 (lImagesCount, lnGroup1, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + end; + if lBM then begin + BMTest(lImagesCount, lnGroup1, lObs,lT); + lOutImgBM^[lPos2Offset] := lT; + + //TStatAbs (lImagesCount, lnGroup1, lObs,lT); + //lOutImgBM[lPos2Offset] := lT; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnGroup1,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); +end; + + +{ Paired T-Test} +(*procedure PairedTTest (N, SumOfDifSqrs, SumDif: double;var t, p,DF: double); + var + meanDif, SumDifSqr, temp: double; + begin + df := n - 1; + t := 0; + p := 1; + + if (SumOfDifSqrs <> 0)and (SumDif <> 0)and (df <> 0) and (N <> 0) then begin + meanDif := SumDif / N; + SumDifSqr := sqr(SumDif); + temp := SumOfDifSqrs - (SumDifSqr / n); + temp := temp / (n * df); + temp := sqrt(temp); + if temp <> 0 then begin + t := meanDif / temp; + p := betai(0.5 * df, 0.5, df / (df + sqr(t))) + end else {t is infinitely big} + p := -1.0; + end; +end; {paired ttest} *) + + +procedure TPairedTStat.Analyze(lUnused1,lUnused2: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lPosPct,lPos,lPos2,lPos2Offset: integer; + lSum: single; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(gnVoxTestedRA[lThread]); + lSum := 0; + for lPos := 1 to lImagesCount do begin + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSum := lSum + lObs^[lPos-1]; + end; + lOutImgMn^[lPos2Offset] := lSum/lImagesCount; + PairedTStat (lImagesCount, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + //StatPermuteThreaded (lttest,lBM,lImagesCount, lnGroup1,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); +end; + +(*procedure TLesionStat.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT,lBMz,lDF: Double; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + inc(lnNoLesion); + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + + end else begin + //lesion + inc(lnLesion); + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + if lttest then begin + TStat2 (lImagesCount, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + end; + if lBM then begin + tBM (lImagesCount, lnNoLesion, lObs,lBMz,lDF); + BMzVal (lImagesCount, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); +end;*) + +procedure TLesionStat.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lSymptomRA: SingleP); +//pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsT,lPrevZValsBM: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + + lObsp: pointer; + lObs: Doublep0; + lT,lBMz,lDF: Double; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + inc(lnNoLesion); + lLesionOrderp^[lPos] := 0; + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + //now check if we have seen this precise lesion order recently... + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + if lttest then + lOutImgT^[lPos2Offset] := lPrevZvalsT[lPos]; + if lBM then + lOutImgBM^[lPos2Offset] := lPrevZvalsBM[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + + + if lttest then begin + TStat2 (lImagesCount, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + lPrevZValsT[lPatternPos] := lT; + end; + if lBM then begin + tBM (lImagesCount, lnNoLesion, lObs,lBMz,lDF); + BMzVal (lImagesCount, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + lPrevZValsBM[lPatternPos] := lBMz; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //novel lesion pattern + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp) + +end; + +procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); + //pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsL,lPrevZValsX: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //Binomial StatThread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := lSymptomRA^[lPos]; + lLesionOrderp^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lnLesion-1] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + //next check patterns + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + //if lChi2 then + // lOutImgX^[lPos2Offset] := lPrevZvalsX[lPos]; + //if lLieber then + lOutImgL^[lPos2Offset] := lPrevZvalsL[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + + {if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + lPrevZValsX[lPatternPos] := lT; + end; + if lLieber then begin} + Liebermeister2(lImagesCount, lnLesion, lObs,lT); + lOutImgL^[lPos2Offset] := lT; + lPrevZValsL[lPatternPos] := lT; + //end; + StatPermuteBinomialThreaded ({lChi2}false,lLieber,lImagesCount, lnLesion,lnPermute,lThread, lObs); + end; + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp) +end; + +(*procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); +var + lObsp: pointer; + lObs: Doublep0; + lT: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //statthread + createArray64(lObsp,lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lObs^[lnLesion-1] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + end; + if lLieber then begin + Liebermeister2(lImagesCount, lnLesion, lObs,lT); + lOutImgL^[lPos2Offset] := lT; + end; + StatPermuteBinomialThreaded (lChi2,lLieber,lImagesCount, lnLesion,lnPermute,lThread, lObs); + + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + +end;*) + + +end. diff --git a/npm_precl/StatThdsUtil.pas b/npm_precl/StatThdsUtil.pas new file mode 100755 index 0000000..d4b32b1 --- /dev/null +++ b/npm_precl/StatThdsUtil.pas @@ -0,0 +1,107 @@ +unit StatThdsUtil; +interface + + +uses + ComCtrls,Classes, Graphics, ExtCtrls, define_types,stats,dialogs; +const + kMaxThreads = 16; + kSh = 10; //bits to shift + kMaxImages = 1024; + kMaxPermute = 4000; + kPlankMB : integer = 512; + +var +gnCPUThreads, gThreadsRunning: Integer; + kPlankSz : integer;// =1024 {bytes/kb} * 1024 {bytes/mb} * kPlankMB; //e.g. 512 MB + gDataTypeRA: array [0..kMaxImages] of integer; + gOffsetRA,gScaleRA,gInterceptRA: array [0..kMaxImages] of single; + gnVoxTestedRA : array [0..kMaxThreads] of integer; + gPermuteMinT,gPermuteMaxT,gPermuteMinBM,gPermuteMaxBM : array [0..kMaxThreads,0..kMaxPermute ] of double; +procedure ClearThreadData(lnThreads,lnPermute: integer); +function SumThreadDataLite (lnThreads: integer): integer; +function SumThreadData (lnThreads,lnPermute: integer;lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP): integer; +procedure ClearThreadDataPvals (lnThreads,lnPermute: integer); + +implementation + +procedure ClearThreadDataPvals (lnThreads,lnPermute: integer); +var lT,lP: integer; +begin + if lnThreads < 1 then exit; + if lnPermute > kMaxPermute then + showmessage('Error: recompile with larger kMaxPermute'); + for lT := 1 to lnThreads do + gnVoxTestedRA[lT] := 0; + if lnPermute < 1 then exit; + for lT := 1 to lnThreads do begin + for lP := 1 to lnPermute do begin + gPermuteMinT[lT,lP] := 10; + gPermuteMaxT[lT,lP] := -10; + gPermuteMinBM[lT,lP] := 10; + gPermuteMaxBM[lT,lP] := -10; + end; + end; +end; + + +procedure ClearThreadData (lnThreads,lnPermute: integer); +var lT,lP: integer; +begin + if lnThreads < 1 then exit; + if lnPermute > kMaxPermute then + showmessage('Error: recompile with larger kMaxPermute'); + for lT := 1 to lnThreads do + gnVoxTestedRA[lT] := 0; + if lnPermute < 1 then exit; + for lT := 1 to lnThreads do begin + for lP := 1 to lnPermute do begin + gPermuteMinT[lT,lP] := 0; + gPermuteMaxT[lT,lP] := 0; + gPermuteMinBM[lT,lP] := 0; + gPermuteMaxBM[lT,lP] := 0; + end; + end; +end; + +function SumThreadDataLite (lnThreads: integer): integer; +var lT: integer; +begin + result := 0; + if lnThreads < 1 then exit; + for lT := 1 to lnThreads do + result := result + gnVoxTestedRA[lT]; +end; + +function SumThreadData (lnThreads,lnPermute: integer;lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP): integer; +var lT,lP: integer; +begin + result := 0; + if lnThreads < 1 then exit; + for lT := 1 to lnThreads do + result := result + gnVoxTestedRA[lT]; + if lnPermute < 1 then exit; + for lP := 1 to lnPermute do begin + lPermuteMinT^[lP] := gPermuteMinT[1,lP]; + lPermuteMaxT^[lP] := gPermuteMaxT[1,lP]; + lPermuteMinBM^[lP] := gPermuteMinBM[1,lP]; + lPermuteMaxBM^[lP] := gPermuteMaxBM[1,lP]; + end; + if lnThreads < 2 then exit; + for lT := 2 to lnThreads do begin + for lP := 1 to lnPermute do begin + if lPermuteMinT^[lP] > gPermuteMinT[lT,lP] then + lPermuteMinT^[lP] := gPermuteMinT[lT,lP]; + if lPermuteMinBM^[lP] > gPermuteMinBM[lT,lP] then + lPermuteMinBM^[lP] := gPermuteMinBM[lT,lP]; + if lPermuteMaxT^[lP] < gPermuteMaxT[lT,lP] then + lPermuteMaxT^[lP] := gPermuteMaxT[lT,lP]; + if lPermuteMaxBM^[lP] < gPermuteMaxBM[lT,lP] then + lPermuteMaxBM^[lP] := gPermuteMaxBM[lT,lP]; + + end; + end; +end; //SumThreadData + + +end. diff --git a/npm_precl/Thumbs.db b/npm_precl/Thumbs.db new file mode 100755 index 0000000..987d5b6 Binary files /dev/null and b/npm_precl/Thumbs.db differ diff --git a/npm_precl/Vector.pas b/npm_precl/Vector.pas new file mode 100755 index 0000000..109a8e6 --- /dev/null +++ b/npm_precl/Vector.pas @@ -0,0 +1,544 @@ +unit Vector; + +interface + +uses SysUtils; + + +//var gMat: boolean = false; + +type + EVectorSizeError = class (Exception); + TMatElement = double; //extended; + { The 1000 in the array types below does not impose a limit at runtime! + If you compile with range checking on then the compiled code will impose + an effective limit of 1000, but with range checking off the size of + vector is limited to 64K under 16bit OS or *much* greater under 32bit OS } + TArrayd = array[1..1000] of TMatElement; pTArrayd = ^TArrayd; + TArrayi = array[1..1000] of integer; pTArrayi = ^TArrayi; + + { Define a dynamic array type for holding integers } + TVectori = class (TObject) + private + s : integer; { size of vector } + vx : pTArrayi; { pointer to the data } + private + procedure SetSize (NewSize : integer); + public + constructor create (i : integer); virtual; + destructor destroy; override; + procedure EnlargeBy (n : integer); + procedure ReduceBy (n : integer); + procedure Enlarge; + procedure Reduce; + procedure Zero; + procedure Clear; + procedure Assign (v : TVectori); + procedure Setval (i : integer; v : integer); + function Getval (i : integer) : integer; + function GetSize : integer; + property Elem[x : Integer] : integer read GetVal write SetVal; default; + property Size : integer read s; + end; + + + { Define a dynamic array type for holding Extendeds } + TVector = class (TObject) + private + s : integer; { size of vector } + vx : pTArrayd; { pointer to the data } + Tmp : boolean; { set to true if temporary } + public + { Declare as a class method, saves having a self variable } + class function Dot (u, v : TVector) : TMatElement; + + constructor create (i : integer); virtual; + constructor createTmp (i : integer); + destructor destroy; override; + procedure FreeSpace; + procedure SetSize (i : integer); + procedure EnlargeBy (n : integer); + procedure ReduceBy (n : integer); + procedure Enlarge; + procedure Reduce; + procedure Zero; + procedure Clear; + procedure Setval (i : integer; v : TMatElement); + function Getval (i : integer) : TMatElement; + property Elem[x : Integer] : TMatElement read GetVal write SetVal; default; + property Size : integer read s; + procedure Assign (v : TVector); + function Add (v, u : TVector) : TVector; + function Sub (v, u : TVector) : TVector; + class function xAdd (v, u : TVector) : TVector; + class function xSub (v, u : TVector) : TVector; + function DotU (v : TVector) : TMatElement; + function CrossU (v : TVector) : TVector; + function Cross (v1, v2 : TVector) : TVector; + function Sum : TMatElement; + function Mean : TMatElement; + function SumofSquares : TMatElement; + function Norm : TMatElement; + function StdDev : TMatElement; + procedure Scale (factor : TMatElement); + end; + + +implementation + + +// ------------------------------------------------------------------------- +// START OF VECTOR TYPE IMPLEMETATION +// ------------------------------------------------------------------------- + + +{ The data space which holds the data for a vector is typed as [1..x] so that +indexing autmatically starts at one, therefore there is no need in the +following code to add 1 to the size of the vector when creating or destroying it } + +{ Create a vector of size i } +constructor TVector.create(i : integer); +begin + Inherited Create; + s := 0; vx := Nil; { vx set to Nil to indicate empty vector, used by SetSize } + if i > 0 then Self.SetSize (i); +end; + +constructor TVector.createTmp (i : integer); +begin + Inherited Create; + s := 0; vx := Nil; { vx set to Nil to indicate empty vector, used by SetSize } + if i > 0 then Self.SetSize (i); + Tmp := true; +end; + + +destructor TVector.destroy; +begin + FreeSpace; + Inherited Destroy; +end; + + +{ Private internal procedure } +procedure TVector.FreeSpace; +begin + if vx <> Nil then FreeMem (vx, sizeof (TMatElement) * s); vx := Nil; s := 0; +end; + + +{ Internal routine to allocate space. If space already exists then it frees it first } +procedure TVector.SetSize (i : integer); +begin + if vx <> Nil then FreeMem (vx, sizeof (TMatElement) * s); + s := i; vx := AllocMem (sizeof (TMatElement) * s); + //if gMat then beep; +end; + + + +{ Increase the size of the vector without destroying and existing data } +procedure TVector.EnLargeBy (n : integer); +begin + if n < 0 then raise EVectorSizeError.Create ('Argument to EnLargeBy must be positive'); + ReAllocMem (vx, sizeof (TMatElement)*(s+n)); inc (s,n); { Modified for D2 } +end; + + +{ Reduce the size of the vector } +procedure TVector.ReduceBy (n : integer); +begin + if n >= s then + raise EVectorSizeError.Create ('Can''t reduce size of vector to below zero elements'); + ReAllocMem (vx, sizeof (TMatElement)*(s-n)); dec (s,n); { modified for D2 } +end; + + +{ Enlarge the vector by one element without destroying any existing data } +procedure TVector.Enlarge; +begin + ReAllocMem (vx, sizeof (TMatElement)*(s+1)); inc (s); { Modified for D2 } +end; + + +{ Reduce the vector by one element, the top most element is destroyed } +procedure TVector.Reduce; +begin + ReAllocMem (vx, sizeof (TMatElement)*(s-1)); dec (s); { Modified for D2 } +end; + + +{ Clears the vector, sets all elements to zero } +procedure TVector.Zero; +var i : integer; +begin + for i := 1 to s do vx^[i] := 0.0; +end; + + +{ Clears the vector, sets all elements to zero } +procedure TVector.Clear; +begin + Zero; +end; + + + +{ used internally but is also accessible from the outside } +procedure TVector.Setval (i : integer; v : TMatElement); +begin + vx^[i] := v; +end; + + +{ used internally but is also accessible from the outside } +function TVector.Getval (i : integer) : TMatElement; +begin + result := vx^[i]; +end; + + +// ------------------------------------------------------------------------- +// Copies vector v, including contects to self. If self is not the same +// size as v then self is resized + +// Copy v to u: +// Usage: u.Assign (v) +// ------------------------------------------------------------------------- +procedure TVector.Assign (v : TVector); +begin + v.Tmp := False; { just in case its a temporary variable } + if v.s <> Self.s then Self.SetSize (v.s); + move (v.vx^, Self.vx^, sizeof(TMatElement) * s) +end; + + +// ------------------------------------------------------------------------- +// Add the vectors, 'v' and 'u' together to produce Self. Error if v and u are +// the the same size. If Self is not sized correctly, then Add will resize Self + +// Usage: w.Add (u, v) +// Add u to v giving result w +// ------------------------------------------------------------------------- + +function TVector.Add (v, u : TVector) : TVector; +var i : integer; +begin + if v.s <> u.s then + raise EVectorSizeError.Create ('Vectors must be the same size to sum them'); + if Self.s <> v.s then Self.SetSize (v.s); + for i := 1 to v.s do Self[i] := v[i] + u[i]; + if v.tmp then v.free; if u.tmp then u.free; + result := Self; +end; + + +// ------------------------------------------------------------------------- +// Add the vectors, 'v' and 'u' together and RETURN the result. An Error +// occurs if v and u are the the same size. xAdd returns the result to the +// caller therefore it is the responsibility of the caller to dispose of the +// memory allocated by xSub. Note, the variable which is used to store the +// returned result must not have been previously allocated, otherwise you'll +// get memory leak! + +// w must be unallocated +// Usage: w := Add (u, v) +// Add u to v giving result w +// ------------------------------------------------------------------------- + +class function TVector.xAdd (v, u : TVector) : TVector; +var i : integer; t : TVector; +begin + if v.s <> u.s then + raise EVectorSizeError.Create ('Vectors must be the same size to sum them'); + t := TVector.CreateTmp (v.s); + for i := 1 to v.s do t[i] := v[i] + u[i]; + result := t; +end; + + +// ------------------------------------------------------------------------- +// Subtract the vectors, 'v' and 'u' together to produce Self. Error if v and u are +// the the same size. If Self is not sized correctly, then Add will resize Self + +// Usage: w.Sub (u, v) +// Add u to v giving result w +// ------------------------------------------------------------------------- + +function TVector.Sub (v, u : TVector) : TVector; +var i : integer; +begin + if v.s <> u.s then + raise EVectorSizeError.Create ('Vectors must be the same size to subtract them'); + if Self.s <> v.s then Self.SetSize (v.s); + for i := 1 to v.s do Self[i] := v[i] - u[i]; + if v.tmp then v.free; if u.tmp then u.free; + result := Self; +end; + + +// ------------------------------------------------------------------------- +// Subtract the vectors, 'v' and 'u' together and RETURN the result. An Error +// occurs if v and u are the the same size. xSub returns the result to the +// caller therefore it is the responsibility of the caller to dispose of the +// memory allocated by xSub. Note, the variable which is used to store the +// returned result must not have been previously allocated, otherwise you'll +// get memory leak! + +// w must be unallocated +// Usage: w := Sub (u, v) +// Add u to v giving result w +// ------------------------------------------------------------------------- + + +class function TVector.xSub (v, u : TVector) : TVector; +var i : integer; t : TVector; +begin + if v.s <> u.s then + raise EVectorSizeError.Create ('Vectors must be the same size to subtract them'); + t := TVector.CreateTmp (v.s); + for i := 1 to v.s do t[i] := v[i] - u[i]; + result := t; +end; + + +// ------------------------------------------------------------------------- +// Compute the dot product of vectors 'u' and 'v' +// Usage: d := dot (u, v); +// ------------------------------------------------------------------------- +class function TVector.Dot (u, v : TVector) : TMatElement; +var i : integer; +begin + if u.Size <> v.Size then + raise EVectorSizeError.Create ('Vectors must be of the same size to compute dot product'); + + result := 0.0; + for i := 1 to u.Size do result := result + u[i]*v[i]; +end; + + +// ------------------------------------------------------------------------- +// Apply a dot product to Self and argument, 'v' +// Usage: d := u.dotU (v); +// ------------------------------------------------------------------------- +function TVector.DotU (v : TVector) : TMatElement; +var i : integer; +begin + if Self.Size <> v.Size then + raise EVectorSizeError.Create ('Vectors must be of the same size to compute dot product'); + + result := 0.0; + for i := 1 to Self.Size do + result := result + Self[i]*v[i]; +end; + + +// ------------------------------------------------------------------------- +// Compute the cross product of Self and vector 'v', replacing Self +// Usage: v.CrossU (u) +// ------------------------------------------------------------------------- +function TVector.CrossU (v : TVector) : TVector; +begin + if (v.Size = 3) and (Self.Size = 3) then + begin + Self[1] := Self[2]*v[3] - Self[3]*v[2]; + Self[2] := Self[3]*v[1] - Self[1]*v[3]; + Self[3] := Self[1]*v[2] - Self[2]*v[1]; + result := Self; + end + else + raise EVectorSizeError.Create ('Cross product can only be calculated for vectors in 3D'); +end; + + +// ------------------------------------------------------------------------- +// Compute the cross product of 'v1' and vector 'v2' giving Self +// Usage: v.Cross (v1, v2) +// ------------------------------------------------------------------------- +function TVector.Cross (v1, v2 : TVector) : TVector; +begin + if (v1.Size = 3) and (v2.Size = 3) and (Self.Size = 3) then + begin + Self[1] := v1[2]*v2[3] - v1[3]*v2[2]; + Self[2] := v1[3]*v2[1] - v1[1]*v2[3]; + Self[3] := v1[1]*v2[2] - v1[2]*v2[1]; + result := Self; + end + else + raise EVectorSizeError.Create ('Cross product can only be calculated for vectors in 3D'); +end; + + +// ------------------------------------------------------------------------- +// Returns the sum of values in the vector +// Usage: total := v.sum +// ------------------------------------------------------------------------- +function TVector.Sum : TMatElement; +var i : integer; +begin + result := 0.0; + for i := 1 to s do result := result + vx^[i]; +end; + +// ------------------------------------------------------------------------- +// Returns the mean of the elements of the vector +// Usage: average := v.mean; +// ------------------------------------------------------------------------- +function TVector.Mean : TMatElement; +begin + if s > 0 then result := sum / s + else raise Exception.Create ('Vector must have at least one element to compute mean'); +end; + + +// ------------------------------------------------------------------------- +// Returns the sum of the squares of values in Data +// Usage: s := v.SumOfSquares; +// ------------------------------------------------------------------------- +function TVector.SumOfSquares : TMatElement; +var i : integer; +begin + result := 0.0; + for i := 1 to s do result := result + sqr(vx^[i]); +end; + + +// ------------------------------------------------------------------------- +// Returns the Euclidean norm of the Self vector +// ------------------------------------------------------------------------- +function TVector.Norm : TMatElement; +begin + result := sqrt (Self.SumOfSquares); +end; + + +// ------------------------------------------------------------------------- +// Returns the sample standard deviation +// Usage: sd := v.StdDev; +// ------------------------------------------------------------------------- +function TVector.StdDev : TMatElement; +var sq, total : TMatElement; i : integer; +begin + sq := 0; total := 0; + if s > 1 then + begin + for i := 1 to s do + begin sq := sq + sqr(vx^[i]); total := total + vx^[i]; end; + result := sqrt ((sq - sqr(total)/s)/(s-1)); + // The following code is easier to read but slightly slower in execution: + // result := sqrt ((SumOfSquares - sqr (sum)/s)/(s-1));} + end + else + raise Exception.Create ('Can''t calculate stddev for vector with one or no elements'); +end; + + +// ------------------------------------------------------------------------- +// Scale the vector by factor +// Usage: v.Scale (2) Multiplies all elements by 2 +// ------------------------------------------------------------------------- +procedure TVector.Scale (factor : TMatElement); +var i : integer; +begin + for i := 1 to s do vx^[i] := vx^[i]*factor; +end; + + +{ ------------------------------------------------------------------------- } +{ START OF INTEGER VECTOR IMPLEMETATION } +{ ------------------------------------------------------------------------- } + + +{ Create a vector of size i } +constructor TVectori.create(i : integer); +begin + Inherited Create; vx := Nil; + Self.SetSize (i); +end; + + +destructor TVectori.destroy; +begin + if vx <> Nil then FreeMem (vx, sizeof (integer) * s); + Inherited Destroy; +end; + + +{ Internal routine used by define } +procedure TVectori.SetSize (NewSize : integer); +begin + if vx <> Nil then FreeMem (vx, sizeof (integer) * s); + s := NewSize; vx := AllocMem (sizeof (integer) * NewSize); +end; + +procedure TVectori.EnLargeBy (n : integer); +begin + ReAllocMem (vx, sizeof (integer)*(s+n)); inc (s,n); { Modified for D2 } +end; + + +procedure TVectori.ReduceBy (n : integer); +begin + if n >= s then + raise EVectorSizeError.Create ('Can''t reduce size of vector to below zero elements'); + ReAllocMem (vx, sizeof (integer)*(s-n)); dec (s,n); { Modified for D2 } +end; + + +{ Enlarge the vector by one element without destroying any existing data } +procedure TVectori.Enlarge; +begin + ReAllocMem (vx, sizeof (integer)*(s+1)); inc (s); { Modified for D2 } +end; + + +{ Reduce the vector by one element, the top most element is destroyed } +procedure TVectori.Reduce; +begin + ReAllocMem (vx, sizeof (integer)*(s-1)); dec (s); { Modified for D2 } +end; + + +{ Clear the vector, sets all elements to zero } +procedure TVectori.Zero; +var i : integer; +begin + for i := 1 to s do vx^[i] := 0; +end; + + +{ Clear the vector, sets all elements to zero } +procedure TVectori.Clear; +begin + Zero; +end; + + +procedure TVectori.Assign (v : TVectori); +begin + if v.s <> Self.s then Self.SetSize (v.s); + move (v.vx^, Self.vx^, sizeof(integer) * s) +end; + + +{ used internally but is also accessible from the outside } +procedure TVectori.Setval (i : integer; v : integer); +begin + vx^[i] := v; +end; + + +{ used internally but is also accessible from the outside } +function TVectori.Getval (i : integer) : integer; +begin + result := vx^[i]; +end; + + +function TVectori.GetSize : integer; +begin + result := s; +end; + + +end. diff --git a/npm_precl/anacom.pas b/npm_precl/anacom.pas new file mode 100755 index 0000000..f551127 --- /dev/null +++ b/npm_precl/anacom.pas @@ -0,0 +1,632 @@ +unit anacom; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr,filename, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +//procedure DoAnaCOM; +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; + + + +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lCombinedSymptomRA: singleP; + lPos,lPlank,lThread,lnControlsPlusPatients: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshBonf,lThreshPermute,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lBM,lttest,lLtest: boolean; + lnControlNeg: integer; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + lnControlNeg := lnControl; //negative for binomial test + lttest := lttestin; + lbm := lbmin; + if (not (lttest)) and (not (lbm)) then begin + lLtest := true; + lBM := true; + lnControlNeg := -lnControl; + end; + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + if lnControl < 1 then begin + MainForm.NPMmsg('AnaCom aborted - need data from at least 1 control individual'); + exit; + end; + lnPermute := 0;//MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + lnControlsPlusPatients := lImages.Count+lnControl; + createArray64(lObsp,lObs,lnControlsPlusPatients); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + //sumptom array for lesions AND controls + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + for lPos := 1 to lnControl do + lObs^[lPos-1+lImages.Count] := lControlSymptomRA^[lPos]; + getmem(lCombinedSymptomRA,lnControlsPlusPatients* sizeof(single)); + for lPos := 1 to lnControlsPlusPatients do + lCombinedSymptomRA^[lPos] := lObs^[lPos-1]; + //next create permuted BM bounds + if lBM then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + //for lPos := 1 to lImages.Count do + // lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lnControlsPlusPatients, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + + with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lnControlNeg,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,nil,lCombinedSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + //Next: NULPS + if lRun > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lnCrit,lnVoxTested,lPlankImg)); + + //lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit)); + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if (lRun < 1) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lRun < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + if lnControl < 1 then + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('attest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'attest'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaComthreshtt,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Mann Whitney + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('aBM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'aBM'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaCOMthreshbm,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + + + +(*function readCSV2 (lFilename: string; lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) or (MaxC < (kHdrCol+lCol2)) then begin + showmessage('problems reading CSV - not enough columns/rows '+inttostr(lCol1)+' '+inttostr(lCol2)); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := MaxC-1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + getmem(ldataRA2,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) or ((C-kHdrCol) = lCol2) then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then + ldataRA1^[R-kHdrRow] := lTempFloat + else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat; + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + ldataRA2^[R-1] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; *) + +function readTxt (lFilename: string; var lnObservations : integer; var ldataRA1: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lCol1: integer; + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lCol1:= 1; + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) then begin + showmessage('problems reading CSV - not enough columns/rows '); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := kHdrCol+lCol1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) {or ((C-kHdrCol) = lCol2)} then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then begin + //showmessage(lNumStr); + ldataRA1^[R-kHdrRow] := lTempFloat; + end; + {else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat;} + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + //showmessage(lNumStr+' '+inttostr(lnFactors)+' '+inttostr(C)); + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(inttostr(R)+' '+floattostr(lTempFLoat)); + ldataRA1^[R] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; + +(*procedure DoAnaCOM; +label + 666; +var + lControlFilename: string; + lI, lnControlObservations : integer; + lControldata: singlep; + lBinomial: boolean; + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('AnaCOM analysis requires TXT/CSV format text file.'); + npmform.MainForm.memo1.lines.add('One row per control participant.'); + npmform.MainForm.memo1.lines.add('First column is performance of that participant.'); + npmform.MainForm.memo1.lines.add('Example file:'); + //npmform.MainForm.memo1.lines.add('deficit, voxels'); + npmform.MainForm.memo1.lines.add('11'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('2'); + npmform.MainForm.memo1.lines.add('22'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('6'); + lControlFilename := 'c:\fx.txt'; + if (not readTxt (lControlFilename, lnControlObservations,lControldata)) or (lnControlObservations < 1) then begin + showmessage('Error reading file '+lControlFilename); + exit; + end; + npmform.MainForm.memo1.lines.add('Control (n='+inttostr(lnControlObservations)+')performance: '); + for lI := 1 to lnControlObservations do begin + npmform.MainForm.memo1.lines.add(inttostr(lI)+' '+floattostr(lControldata^[lI])); + + end; + //begin - copy + + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not MainForm.GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit,{,binom}lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + + + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then exit; + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + MainForm.NPMmsgClear; + MainForm.NPMMsg(MainForm.GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to lnSubj do + MainForm.NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroup(lImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + MainForm.ReportDescriptives(lSymptomRA,lnSubj); + AnacomLesionNPMAnalyze(lImageNames,lMaskHdr,lnCrit,-1,lnControlObservations,lSymptomRA,lControldata,lFactName,lOutname,true {ttest},false{BM}); + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + + Freemem(lMultiSymptomRA); + end; + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + ///end + //AnacomLesionNPMAnalyze ( lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttest,lBM: boolean): boolean; + freemem(lControldata); + + + +end;*) + +end. diff --git a/npm_precl/associate.pas b/npm_precl/associate.pas new file mode 100755 index 0000000..225aae7 --- /dev/null +++ b/npm_precl/associate.pas @@ -0,0 +1,42 @@ +unit associate; +interface +uses Windows,registry,Forms,dialogs,SysUtils; + +function registerfiletype(inft,inkey,desc,icon:string): boolean; + +implementation + +function registerfiletype(inft,inkey,desc,icon:string): boolean; +var myreg : treginifile; + ct : integer; + ft,key: string; +begin + result := true; + ft := inft; + key := inkey; + ct := pos('.',ft); + while ct > 0 do begin + delete(ft,ct,1); + ct := pos('.',ft); + end; + if (ft = '') or (Application.ExeName = '') then exit; //not a valid file-ext or ass. app + ft := '.'+ft; + myreg := treginifile.create(''); + try + myreg.rootkey := hkey_classes_root; // where all file-types are described + if key = '' then key := copy(ft,2,maxint)+'_auto_file'; // if no key-name is given, create one + myreg.writestring(ft,'',key); // set a pointer to the description-key + myreg.writestring(key,'',desc); // write the description + myreg.writestring(key+'\DefaultIcon','',icon); // write the def-icon if given + //showmessage(key); + myreg.writestring(key+'\shell\open\command','',Application.ExeName+' %1'); //association + except + result := false; + showmessage('Only administrators can change file associations. You are currently logged in as a restricted user.'); + end; + //finally + myreg.free; + //end; +end; + +end. \ No newline at end of file diff --git a/npm_precl/brunner.pas b/npm_precl/brunner.pas new file mode 100755 index 0000000..431eaec --- /dev/null +++ b/npm_precl/brunner.pas @@ -0,0 +1,547 @@ +unit brunner; + +interface +uses define_types,math,Distr; + +procedure tBM (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var ltBM,lDF: double); +procedure genBMsim (lnSubj: integer; var lOrigOrder: DoubleP0); +function BMzVal(lnSubj, lnGroup0: integer; ltBM,lDF: double): double; +function continROC (lnSubj, lnGroup0: integer; var lIn: DoubleP0): single; +function continROC2 (lnSubj: integer; var lInIV, lInDV: DoubleP0): single; + +const + knPermute= 20000; + knSim = 15; +var + gSimRA: array [1..knSim] of DoubleP; + gSimRAp: array [1..knSim] of pointer; +implementation + + +function BMzVal(lnSubj,lnGroup0 : integer; ltBM,lDF: double): double; +//can be approximated by result := TtoZ(ltBM,lDF); +var + lnSmallGroup,lJump,lEstimate,i,tie: integer; + ltBMs : double; + lSwap: boolean; +begin + //result := TtoZ(ltBM,lDF); exit; + lSwap := false; + ltBMs := ltBM; + result := 0; + tie := 0; + if (lnSubj div 2) > lnGroup0 then + lnSmallGroup := lnGroup0 + else + lnSmallGroup := lnSubj-lnGroup0; + if lnSmallGroup < 1 then exit; + if lnSmallGroup > knSim then begin + result := TtoZ(ltBMs,lDF); + exit; + end; + if (lnSubj div 2) < lnGroup0 then begin + ltBMs := -ltBMs; + lSwap := not lSwap; //distributions are not symetrical + end; + lEstimate := knPermute div 2; //start half way through data + lJump := lEstimate div 2; + for i := 1 to 9 do begin + if gSimRA[lnSmallGroup]^[lEstimate] > ltBMs then + lEstimate := lEstimate - lJump + else + lEstimate := lEstimate + lJump; + lJump := (lJump+1) div 2; + end; + if lEstimate < (knPermute div 2) then begin //p < 0.5 count up for less extreme + i := lEstimate-lJump-lJump; + if i < 1 then + i := 1; + while ltBMs > gSimRA[lnSmallGroup]^[i] do begin + inc(i); + end; + if ltBMs = gSimRA[lnSmallGroup]^[i] then begin + while ltBMs = gSimRA[lnSmallGroup]^[i] do begin + inc(i); + dec(tie); + end; + dec(tie); + end; + end else begin //p < 0.5 count down for less extreme + i := lEstimate+lJump+lJump; + if i >= knPermute then + i := knPermute; + while ltBMs < gSimRA[lnSmallGroup]^[i] do + dec(i); + if ltBMs = gSimRA[lnSmallGroup]^[i] then begin + while ltBMs = gSimRA[lnSmallGroup]^[i] do begin + dec(i); + inc(tie); + end; + inc(tie); + end; + i := i - 1; //indexed from 1 not 0 + end; + //result := (i+(tie/2)); + //result := (1-( (i+(tie/2))/knPermute)); + result := pNormalInv(1-( (i+(tie/2))/knPermute)); + if lSwap then + result := -result; +end; + +procedure Sort (lo, up: integer; var r:DoubleP); +//62ms Shell Sort http://www.dcc.uchile.cl/~rbaeza/handbook/algs/4/414.sort.p.html +label 999; +var + d, i, j : integer; + tempr : single; +begin + d := up-lo+1; + while d>1 do begin + if d<5 then + d := 1 + else + d := trunc( 0.45454*d ); // Do linear insertion sort in steps size d + for i:=up-d downto lo do begin + tempr := r^[i]; + j := i+d; + while j <= up do + if tempr > r^[j] then begin + r^[j-d] := r^[j]; + j := j+d + end else + goto 999; {*** break ***} + 999: + r^[j-d] := tempr + end + end +end; //sort + +procedure GenPermute (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0); +var + lInc,lRand: integer; + lSwap: double; +begin + //next lines commented out - this check should be done before inner loop + //if lnSubj < 2 then //can not randomize order of single value + // exit; + //Move(src,dest,count); + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + //for lInc := 1 to lnSubj do + // lRanOrder[lInc-1] := lOrigOrder[lInc-1]; + for lInc := lnSubj downto 2 do begin + lRand := Random(lInc); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure genBMsim (lnSubj: integer; var lOrigOrder: DoubleP0); +//1.) creates kSim random permutations of the data +//2.) sorts permutations +var + lRanOrderp: pointer; + lRanOrder: DoubleP0; + lInc,lnSmallGroup: integer; + lOutT,lDF: double; +begin + if (lnSubj < 1) or (knPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + //lnSmallGroup := lnGroup0; + //if lnSmallGroup > knSim then exit; + for lnSmallGroup := 1 to knSim do begin + //RandSeed := 128; //same order for all voxels + for lInc := 1 to knPermute do begin + GenPermute(lnSubj, lOrigOrder,lRanOrder); //generate random order of participants + tBM (lnSubj, lnSmallGroup, lRanOrder,lOutT,lDF); + gSimRA[lnSmallGroup]^[lInc] := lOutT; + end; + //next sort permutes... + Sort(1,knPermute,gSimRA[lnSmallGroup]); + end; + freemem(lRanOrderp); +end; + + + +procedure SortDouble (first, last: integer; var DynDataRA:DoubleP0; var lGroupRA: Bytep0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; + swapbyte: byte; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 0 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + swapbyte := lGroupRA^[i]; + lGroupRA^[i] := lGroupRA^[l]; + lGroupRA^[l] := swapbyte; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + +procedure RankArray (first, last: integer; var DynDataRA:DoubleP0; var lGSum: double); +var + lnTies,lPos,lStartPos,lRankPos: integer; + lScore,lTie : double; +begin + lGSum := 0; + lPos := first; + while lPos <= last do begin + lStartPos := lPos; + lScore := DynDataRA^[lPos]; + while (lPos < last) and (lScore = DynDataRA^[lPos+1]) do + inc(lPos); //count ties + lnTies := lPos - lStartPos; + lTie := (lnTies) *0.5; + if lnTies > 0 then begin + lnTies := lnTies+1;//tj on page 135 of Siegel + lGSum := lGSum + (( (lnTies*lnTies*lnTies) - lnTies)/12); + //showmessage(inttostr(lnTies)+' '+realtostr(lGSum,4)); + end; + for lRankPos := lStartPos to lPos do + DynDataRA^[lRankPos] := lStartPos+1+lTie; + inc(lPos);//start with next value + end; +end; + +procedure LocalRank (first, last: integer; var DynDataRA,DynDataRAX:DoubleP0; var lGroupRA: Bytep0); +var + lGroup,lnTies,lPos,lStartPos,lRankPos,lLocalRank: integer; + lScore,lTie : double; +begin + for lGroup := 0 to 1 do begin + lPos := first; + lLocalRank := 0; + while lPos <= last do begin + if lGroupRA^[lPos] = lGroup then begin// + inc(lLocalRank); + lStartPos := lPos; + lScore := DynDataRA^[lPos]; + lnTies := 0; + while (lPos < last) and (0.001 > abs (lScore - DynDataRA^[lPos+1]) ) do begin + inc(lPos); //count ties + if lGroupRA^[lPos] = lGroup then + inc(lnTies); + end; + lTie := (lnTies) *0.5; + for lRankPos := lStartPos to lPos do begin + if lGroupRA^[lRankPos] = lGroup then + DynDataRAX^[lRankPos] := (lLocalRank+lTie); + end; + lLocalRank := lLocalRank + lnTies; + end; //if in group + inc(lPos);//start with next value + end; //while... for each observation + end; //for each group +end; + +(*procedure tBM (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var ltBM,lDF: double); +//this is a t-test - only use to test BM!!! +var + i,lnGroupY,lnGroupX: integer; + lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lS: double; +begin + lnGroupX := lnGroup0; + lnGroupY := lnSubj - lnGroupX; + lDF := lnSubj -1; + if (lnGroupX < 1) or (lnGroupY < 1) then begin //need at least 1 subj in each group + ltBM := 0; + exit; + end; + lSumx := 0; + lSumSqrX := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + //lVal := lIn[i]; + lsumx := lsumx + lIn[i]; + lSumSqrX := lSumSqrX + sqr(lIn[i]); + end; + //lMnX := lsumx/lnGroupX; + lVarx := (lnGroupX*lSumSqrX) - Sqr(lsumx); + if lnGroupX > 1 then + lVarX := lVarX / (lnGroupX*(lnGroupX-1)) + else + lVarx := 0; + lSumy := 0; + lSumSqry := 0; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lsumy := lsumy + lIn[i]; + lSumSqry := lSumSqry + sqr(lIn[i]); + end; //for each sub + //lMnY := lsumy/lnGroupY; + lVary := (lnGroupY*lSumSqrY) - Sqr(lsumy); + if lnGroupY > 1 then + lVary := lVary / (lnGroupY*(lnGroupY-1)) + else + lVary := 0; + //lm := (lsumx/lnGroupX)-(lsumy/lnGroupY); //mean effect size lmnx - lmny; + //ldf := lnSubj - 2; + ls := sqrt( ( ((lnGroupX - 1) * lvarx + (lnGroupY - 1) * lvary) / (lnSubj - 2){ldf}) ) ; + ls := ls * sqrt(1 / lnGroupX + 1 / lnGroupY); //note - to get here both lnx and lny > 0 + if ls = 0 then + ltBM := 0 + else + ltBM := ( ((lsumx/lnGroupX)-(lsumy/lnGroupY))/ls);//t = lm / ls; +end; *) + +procedure tBM (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var ltBM,lDF: double); +var + lObspX,lObsp: pointer; + lObsX,lObs: Doublep0; + lGroupRA: Bytep0; + i,ln0,ln1: integer; + lZ,lGSum: double; + lSum0,lSum1,lMean0,lMean1,lSqr0,lSqr1,lk0,lk1: double; +begin + createArray64(lObsp,lObs,lnSubj); + getmem(lGroupRA,lnSubj*sizeof(Byte)); + createArray64(lObspX,lObsX,lnSubj); + ln0 := 0; + ln1 := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lObs[i] := lIn[i]; + if i < lnGroup0 then //group0 + lGroupRA^[i] := 0 + else + lGroupRA^[i] := 1; + end; //for each sub + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + inc(ln0) //number of observations in group zero + else + inc(ln1); //number of observations in group one + if (ln0 > 1) and (ln1 > 1) then begin + SortDouble(0,lnSubj-1,lObs,lGroupRA); + RankArray(0,lnSubj-1,lObs,lGSum); + lSum0 := 0; + lSum1 := 0; + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lSum0 := lSum0 + lObs^[i] + else + lSum1 := lSum1 + lObs^[i]; + lMean0 := lSum0 / ln0; + lMean1 := lSum1 / ln1; + //fx(lmean0,lMean1); + lSqr0 := 0; + lSqr1 := 1; + lk0 := (ln0+1)/2; + lk1 := (ln1+1)/2; + LocalRank(0,lnSubj-1,lObs,lObsX,lGroupRA); + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lSqr0 := lSqr0 + Sqr(lObs^[i]-lObsX^[i]-lMean0+lk0) + else + lSqr1 := lSqr1 + Sqr(lObs^[i]-lObsX^[i]-lMean1+lk1); + lSqr0 := (1/(ln0-1))*lSqr0; + lSqr1 := (1/(ln1-1))*lSqr1; + + lZ := -(ln0*ln1*(lMean1-lMean0))/((ln0+ln1)*sqrt((ln0*lSqr0)+(ln1*lSqr1) ) ); + lDF := sqr(ln0*lSqr0+ln1*lSqr1) / ( (sqr(ln0*lSqr0)/(ln0-1)) + (sqr(ln1*lSqr1)/(ln1-1)) ) ; + //lZ := TtoZ(lZ,lDF); + ltBM := lZ; + //fx(lZ,lDF); + end else //>1 + ltBM := 0; + freemem(lObsp); + freemem(lObspX); + freemem(lGroupRA); +end; //tBM (**) + +procedure SortDoubleP0 (first, last: integer; var DynDataRA:DoubleP0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; + //swapbyte: byte; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 0 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + + +function continROC (lnSubj, lnGroup0: integer; var lIn: DoubleP0): single; +//see equation 1 of Obuchiwski, Statistics in Medicine, 25: 481-493 +var + lSum,lV: double; + linc0,linc1,lnGroup1,i: integer; + lObsp0,lObsp1: pointer; + lObs0,lObs1: Doublep0; + +begin + result := -1; + lnGroup1 := lnSubj - lnGroup0; + if (lnGroup1 < 1) or (lnGroup0 < 1) then exit; + createArray64(lObsp1,lObs1,lnSubj); + createArray64(lObsp0,lObs0,lnSubj); + for i := 0 to (lnGroup0-1) do //for each subject without disease + lObs0[i] := lIn[i]; + SortDoubleP0(0,lnGroup0-1,lObs0); + + for i := lnGroup0 to (lnSubj-1) do //for each subject with disease + lObs1[i-lnGroup0] := lIn[i]; + SortDoubleP0(0,lnGroup1-1,lObs1); + lSum := 0; + for linc0 := 0 to (lnGroup0-1) do begin + for linc1 := 0 to (lnGroup1-1) do begin + if (lObs0^[linc0]) > (lObs1^[linc1]) then + lV := 1 + else if (lObs0^[linc0]) = (lObs1^[linc1]) then //tie + lV := 0.5 + else + lV := 0; + + lSum := lV + lSum; + end;//for group1 + end;//for group0 + lSum := lSum * (1/ (lnGroup0*lnGroup1 ) ); + result := lSum; + + freemem(lObsp1); + freemem(lObsp0); +end; //continROC + +procedure SortDoubleDouble (first, last: integer; var DynDataRA, lGroupRA: DoubleP0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap,swapbyte: double; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 0 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + swapbyte := lGroupRA^[i]; + lGroupRA^[i] := lGroupRA^[l]; + lGroupRA^[l] := swapbyte; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + + +function continROC2 (lnSubj: integer; var lInIV, lInDV: DoubleP0): single; +//see equation 9 of Obuchiwski, Statistics in Medicine, 25: 481-493 +var + lSum,lV: double; + linci,lincj,i: integer; + lObspIV,lObspDV: pointer; + lObsIV,lObsDV: Doublep0; + +begin + result := -1; + if (lnSubj < 1) then exit; + createArray64(lObspIV,lObsIV,lnSubj); + createArray64(lObspDV,lObsDV,lnSubj); + for i := 0 to (lnSubj-1) do //for each subject without disease + lObsIV[i] := lInIV[i]; + for i := 0 to (lnSubj-1) do //for each subject without disease + lObsDV[i] := lInDV[i]; + SortDoubleDouble(0,lnSubj-1,lObsIV,lObsDV); + + lSum := 0; + for linci := 0 to (lnSubj-1) do begin + for lincj := 0 to (lnSubj-1) do begin + if lincj <> linci then begin + if ((lObsDV^[linci] > lObsDV^[lincj]) and (lObsIV^[linci] > lObsIV^[lincj])) or + ((lObsDV^[linci] < lObsDV^[lincj]) and (lObsIV^[linci] < lObsIV^[lincj])) then + lV := 1 + else if (lObsDV^[linci] = lObsDV^[lincj]) or (lObsIV^[linci] = lObsIV^[lincj]) then //tie + lV := 0.5 + else + lV := 0; + lSum := lV + lSum; + end; + + end;//for group1 + end;//for group0 + lSum := lSum * (1/ (lnSubj* (lnSubj-1) ) ); + result := lSum; + freemem(lObspDV); + freemem(lObspIV); +end; //continROC2 + + + +var + i: integer; +initialization +begin + for i := 1 to knSim do + createArray64(gSimRAp[i],gSimRA[i],knPermute); +end; + +finalization +begin + for i := 1 to knSim do + freemem(gSimRAp[i]); +end; +end. diff --git a/npm_precl/design.dfm b/npm_precl/design.dfm new file mode 100755 index 0000000..d64e141 Binary files /dev/null and b/npm_precl/design.dfm differ diff --git a/npm_precl/design.lfm b/npm_precl/design.lfm new file mode 100755 index 0000000..b125fac --- /dev/null +++ b/npm_precl/design.lfm @@ -0,0 +1,135 @@ +object DesignForm: TDesignForm + Left = 481 + Height = 207 + Top = 179 + Width = 636 + HorzScrollBar.Page = 635 + VertScrollBar.Page = 206 + ActiveControl = AVal + BorderStyle = bsDialog + Caption = 'Design' + ClientHeight = 207 + ClientWidth = 636 + Constraints.MaxHeight = 207 + Constraints.MaxWidth = 636 + Constraints.MinHeight = 207 + Constraints.MinWidth = 636 + OnCreate = FormCreate + Position = poScreenCenter + LCLVersion = '0.9.28.2' + object Label4: TLabel + Left = 4 + Height = 18 + Top = 8 + Width = 70 + Caption = 'Predictors' + ParentColor = False + end + object Label5: TLabel + Left = 76 + Height = 18 + Top = 8 + Width = 114 + Caption = 'Predictor Names' + ParentColor = False + end + object Label1: TLabel + Left = 12 + Height = 18 + Top = 123 + Width = 81 + Caption = 'Participants' + ParentColor = False + end + object TemplateLabel: TLabel + Left = 148 + Height = 18 + Top = 95 + Width = 112 + Caption = 'C:\template.img' + ParentColor = False + end + object Label2: TLabel + Left = 12 + Height = 18 + Top = 168 + Width = 263 + Caption = 'Ignore voxels damaged in less than N%' + ParentColor = False + end + object OKBtn: TButton + Left = 527 + Height = 25 + Top = 168 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + ModalResult = 1 + TabOrder = 0 + end + object AVal: TSpinEdit + Left = 12 + Height = 27 + Top = 37 + Width = 70 + MaxValue = 99 + MinValue = 1 + OnChange = AValChange + TabOrder = 1 + Value = 2 + end + object ALevelNames: TStringGrid + Left = 98 + Height = 42 + Top = 30 + Width = 527 + ColCount = 2 + FixedCols = 0 + FixedRows = 0 + Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goDrawFocusSelected, goEditing] + RowCount = 1 + ScrollBars = ssHorizontal + TabOrder = 2 + TitleFont.Height = -11 + OnEnter = ALevelNamesEnter + OnExit = ALevelNamesExit + end + object LesionCovaryCheck: TCheckBox + Left = 255 + Height = 21 + Top = 123 + Width = 267 + Caption = 'Automatically Covary Lesion Volume' + TabOrder = 5 + Visible = False + end + object AddMRIBtn: TButton + Left = 93 + Height = 25 + Top = 118 + Width = 129 + BorderSpacing.InnerBorder = 4 + Caption = 'Select Images' + OnClick = AddMRIBtnClick + TabOrder = 4 + end + object TemplateBtn: TButton + Left = 12 + Height = 25 + Top = 89 + Width = 129 + BorderSpacing.InnerBorder = 4 + Caption = 'Select Template' + OnClick = TemplateBtnClick + TabOrder = 3 + end + object CritPctEdit: TSpinEdit + Left = 304 + Height = 27 + Top = 162 + Width = 76 + OnChange = AValChange + TabOrder = 6 + Value = 1 + end +end diff --git a/npm_precl/design.lrs b/npm_precl/design.lrs new file mode 100755 index 0000000..062ef9b --- /dev/null +++ b/npm_precl/design.lrs @@ -0,0 +1,41 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TDesignForm','FORMDATA',[ + 'TPF0'#11'TDesignForm'#10'DesignForm'#4'Left'#3#225#1#6'Height'#3#207#0#3'Top' + +#3#179#0#5'Width'#3'|'#2#18'HorzScrollBar.Page'#3'{'#2#18'VertScrollBar.Page' + +#3#206#0#13'ActiveControl'#7#4'AVal'#11'BorderStyle'#7#8'bsDialog'#7'Caption' + +#6#6'Design'#12'ClientHeight'#3#207#0#11'ClientWidth'#3'|'#2#21'Constraints.' + +'MaxHeight'#3#207#0#20'Constraints.MaxWidth'#3'|'#2#21'Constraints.MinHeight' + +#3#207#0#20'Constraints.MinWidth'#3'|'#2#9'Font.Name'#6#13'MS Sans Serif'#8 + +'OnCreate'#7#10'FormCreate'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6 + +#8'0.9.28.2'#0#6'TLabel'#6'Label4'#4'Left'#2#4#6'Height'#2#18#3'Top'#2#8#5'W' + +'idth'#2'F'#7'Caption'#6#10'Predictors'#11'ParentColor'#8#0#0#6'TLabel'#6'La' + +'bel5'#4'Left'#2'L'#6'Height'#2#18#3'Top'#2#8#5'Width'#2'r'#7'Caption'#6#15 + +'Predictor Names'#11'ParentColor'#8#0#0#6'TLabel'#6'Label1'#4'Left'#2#12#6'H' + +'eight'#2#18#3'Top'#2'{'#5'Width'#2'Q'#7'Caption'#6#12'Participants'#11'Pare' + +'ntColor'#8#0#0#6'TLabel'#13'TemplateLabel'#4'Left'#3#148#0#6'Height'#2#18#3 + +'Top'#2'_'#5'Width'#2'p'#7'Caption'#6#15'C:\template.img'#11'ParentColor'#8#0 + +#0#6'TLabel'#6'Label2'#4'Left'#2#12#6'Height'#2#18#3'Top'#3#168#0#5'Width'#3 + +#7#1#7'Caption'#6'%Ignore voxels damaged in less than N%'#11'ParentColor'#8#0 + +#0#7'TButton'#5'OKBtn'#4'Left'#3#15#2#6'Height'#2#25#3'Top'#3#168#0#5'Width' + +#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#2'OK'#11'ModalResult'#2 + +#1#8'TabOrder'#2#0#0#0#9'TSpinEdit'#4'AVal'#4'Left'#2#12#6'Height'#2#27#3'To' + +'p'#2'%'#5'Width'#2'F'#8'MaxValue'#2'c'#8'MinValue'#2#1#8'OnChange'#7#10'AVa' + +'lChange'#8'TabOrder'#2#1#5'Value'#2#2#0#0#11'TStringGrid'#11'ALevelNames'#4 + +'Left'#2'b'#6'Height'#2'*'#3'Top'#2#30#5'Width'#3#15#2#8'ColCount'#2#2#9'Fix' + +'edCols'#2#0#9'FixedRows'#2#0#7'Options'#11#15'goFixedVertLine'#15'goFixedHo' + +'rzLine'#10'goVertLine'#19'goDrawFocusSelected'#9'goEditing'#0#8'RowCount'#2 + +#1#10'ScrollBars'#7#12'ssHorizontal'#8'TabOrder'#2#2#16'TitleFont.Height'#2 + +#245#14'TitleFont.Name'#6#13'MS Sans Serif'#7'OnEnter'#7#16'ALevelNamesEnter' + +#6'OnExit'#7#15'ALevelNamesExit'#0#0#9'TCheckBox'#17'LesionCovaryCheck'#4'Le' + +'ft'#3#255#0#6'Height'#2#21#3'Top'#2'{'#5'Width'#3#11#1#7'Caption'#6'"Automa' + +'tically Covary Lesion Volume'#8'TabOrder'#2#5#7'Visible'#8#0#0#7'TButton'#9 + +'AddMRIBtn'#4'Left'#2']'#6'Height'#2#25#3'Top'#2'v'#5'Width'#3#129#0#25'Bord' + +'erSpacing.InnerBorder'#2#4#7'Caption'#6#13'Select Images'#7'OnClick'#7#14'A' + +'ddMRIBtnClick'#8'TabOrder'#2#4#0#0#7'TButton'#11'TemplateBtn'#4'Left'#2#12#6 + +'Height'#2#25#3'Top'#2'Y'#5'Width'#3#129#0#25'BorderSpacing.InnerBorder'#2#4 + +#7'Caption'#6#15'Select Template'#7'OnClick'#7#16'TemplateBtnClick'#8'TabOrd' + +'er'#2#3#0#0#9'TSpinEdit'#11'CritPctEdit'#4'Left'#3'0'#1#6'Height'#2#27#3'To' + +'p'#3#162#0#5'Width'#2'L'#8'OnChange'#7#10'AValChange'#8'TabOrder'#2#6#5'Val' + +'ue'#2#1#0#0#0 +]); diff --git a/npm_precl/design.pas b/npm_precl/design.pas new file mode 100755 index 0000000..4be34ce --- /dev/null +++ b/npm_precl/design.pas @@ -0,0 +1,200 @@ +unit design; + +interface + +uses +{$IFNDEF FPC} +//Utils, +{$ELSE} +LResources, +{$ENDIF} +//{$IFNDEF Unix} Windows,{$ENDIF} + + Buttons, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Spin, Grids,nifti_hdr; + +type + String10= String[10]; + + { TDesignForm } + + TDesignForm = class(TForm) + OKBtn: TButton; + AVal: TSpinEdit; + Label4: TLabel; + Label5: TLabel; + ALevelNames: TStringGrid; + LesionCovaryCheck: TCheckBox; + AddMRIBtn: TButton; + Label1: TLabel; + TemplateBtn: TButton; + TemplateLabel: TLabel; + CritPctEdit: TSpinEdit; + Label2: TLabel; + //procedure LRsetup (var NumColumns,Vars,L1,L2,L3: integer; var OK: boolean); + procedure AValChange(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure ALevelNamesEnter(Sender: TObject); + procedure ALevelNamesExit(Sender: TObject); + procedure AddMRIBtnClick(Sender: TObject); + procedure TemplateBtnClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + DesignForm: TDesignForm; + +implementation + +uses npmform,spread,hdr; +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + +const + kMaxColumns = 16; {for ANOVA} + //maxElements = kMaxColumns; {ANOVA} + MaxLen = 12; + //kCR = chr (13); + //kTab = chr(9); + kVALImgFilter = 'Image (*.hdr;*.nii;*.voi)|*.hdr;*.nii;*.nii.gz;*.voi'; + +procedure TDesignForm.AValChange(Sender: TObject); +{$IFDEF FPC} +var + lOrig,lP: integer; +begin + lOrig := ALevelNames.ColCount; + DesignForm.Caption := inttostr(AVal.Value); + ALevelNames.ColCount := AVal.Value; + if AVal.value > lOrig then + for lP := lOrig to (AVal.value-1) do + AlevelNames.Cells[lP,0] := 'Pred'+inttostr(lP+1); +end; + +{$ELSE} +begin + ALevelNames.ColCount := AVal.Value; +end; +{$ENDIF} + +procedure TDesignForm.FormCreate(Sender: TObject); +var lC: integer; +begin + ALevelNames.ColCount := 16 ; + AlevelNames.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + //AlevelNames.Cells[8,0] := 'Pred'; + for lC := 0 to 15 do begin + AlevelNames.Cells[lC,0] := 'Pred'+inttostr(lC+1); + end; + SpreadForm.UpdateLabels; + AValChange(nil); +end; + +procedure TDesignForm.ALevelNamesEnter(Sender: TObject); +begin + AlevelNames.Selection:=TGridRect(Rect(0,0,0,0)); +end; + +procedure TDesignForm.ALevelNamesExit(Sender: TObject); +begin + AlevelNames.Selection:=TGridRect(Rect(-1,-1,-1,-1)); +end; + +function LeadingZeroFilename (lInX: string): string; +var + lIn: string; + lC,lnPad,lPos,lnDec,lExtPos,lLen: integer; +begin + {$IFDEF Unix} + lIn := lInX; + {$ELSE} + lIn := Lowercase(lInX); + {$ENDIF} + lnPad := 8; + lLen := length(lIn); + result := lIn; + if lLen < 1 then exit; + lExtPos := 1; + while (lExtPos <= lLen) and (lIn[lExtPos] <> '.') do + inc(lExtPos); + if lExtPos <= 1 then + exit; + lnDec := 0; + lPos := lExtPos -1; + while (lPos > 0) and ( lIn[lPos] in ['0'..'9']) do + dec(lPos); + lnDec := (lExtPos-lPos)-1; + if (lnDec = 0) or (lnDec >= lnPad) then + exit; + result := ''; + if lPos > 0 then + for lC := 1 to lPos do + result := result + lIn[lC]; + for lC := 1 to (lnPad-lnDec) do + result := result + '0'; + for lC := (lPos+1) to lLen do + result := result+lIn[lC]; +end; + +procedure SortStrPadded (var lStr: TStringList); +{file1,file2...file10 not file1,file10..file2} +var counter, look:integer; temp:Tstrings; +begin + if lStr.Count < 2 then exit; + temp := TStringList.Create; + for counter:=0 to lStr.Count-1 do + temp.Append(LeadingZeroFilename{LowerCase}(lStr[counter])); + for counter:=0 to temp.Count-1 do + for look:=counter+1 to temp.Count-1 do + if temp[look]<temp[counter] then begin + lStr.Exchange(look, counter); + temp.Exchange(look,counter); + end; + temp.Free; +end; + +procedure TDesignForm.AddMRIBtnClick(Sender: TObject); +var + lNumberofFiles,lC: integer; + lFileStrs: TStringList; +begin + if not MainForm.OpenDialogExecute('Select VOIs you wish to analyze',true,false,kVALImgFilter) then exit; + lNumberofFiles:= MainForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + lNumberofFiles := NIFTIhdr_HdrVolumes(MainForm.OpenHdrDlg.Filename); + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + exit; + end; + lFileStrs := TStringList.Create; + for lC:= 1 to lNumberofFiles do + lFileStrs.Add(extractfilename(MainForm.OpenHdrDlg.Filename)+':'+inttostr(lC)); + end else begin + lFileStrs := TStringList.Create; + for lC:= 1 to lNumberofFiles do + lFileStrs.Add(extractfilename(MainForm.OpenHdrDlg.Files[lC-1])); + SortStrPadded (lFileStrs); + end; + SpreadForm.DataGrid.RowCount := lNumberofFiles+1+kMaxFactors; //10/10/2006 -must resize BEFORE to populating cells + for lC:= 1 to lNumberofFiles do + SpreadForm.DataGrid.Cells[0,kMaxFactors+lC] := lFileStrs[lC-1]; + lFileStrs.free; + +end; + +procedure TDesignForm.TemplateBtnClick(Sender: TObject); +begin + if not MainForm.OpenDialogExecute('Select Template image [determines bounding box and dimensions]',false,false,kVALImgFilter) then exit; + TemplateLabel.Caption := (MainForm.OpenHdrDlg.Filename); +end; + + {$IFDEF FPC} +initialization + {$I design.lrs} +{$ENDIF} + +end. diff --git a/npm_precl/dice.ico b/npm_precl/dice.ico new file mode 100755 index 0000000..bb844ee Binary files /dev/null and b/npm_precl/dice.ico differ diff --git a/npm_precl/dmath/GraphicsMathLibrary.pas b/npm_precl/dmath/GraphicsMathLibrary.pas new file mode 100755 index 0000000..173bca9 --- /dev/null +++ b/npm_precl/dmath/GraphicsMathLibrary.pas @@ -0,0 +1,738 @@ +// Graphics Math Library +// +// Copyright (C) 1982, 1985, 1992, 1995-1998 Earl F. Glynn, Overland Park, KS. +// All Rights Reserved. E-Mail Address: EarlGlynn@att.net + +UNIT GraphicsMathLibrary; // Matrix/Vector Operations for 2D/3D Graphics} + +INTERFACE + + USES + SysUtils,dialogs; {Exception} + + CONST + sizeUndefined = 1; + size2D = 3; // 'size' of 2D homogeneous vector or transform matrix + size3D = 4; // 'size' of 3D homogeneous vector or transform matrix + + TYPE + EVectorError = CLASS(Exception); + EMatrixError = CLASS(Exception); + + TAxis = (axisX, axisY, axisZ); + TCoordinate = (coordCartesian, coordSpherical, coordCylindrical); + TDimension = (dimen2D, dimen3D); // two- or three-dimensional TYPE + TIndex = 1..4; // index of 'TMatrix' and 'TVector' TYPEs + + TMatrix = // transformation 'matrix' + RECORD + size: TIndex; + matrix: ARRAY[TIndex,TIndex] OF single //azx DOUBLE + END; + + Trotation = (rotateClockwise, rotateCounterClockwise); + + // Normally the TVector TYPE is used to define 2D/3D homogenous + // cartesian coordinates for graphics, i.e., (x,y,1) for 2D and + // (x,y,z,1) for 3D. + // + // Cartesian coordinates can be converted to spherical (r, theta, phi), + // or cylindrical coordinates (r,theta, z). Spherical or cylindrical + // coordinates can be converted back to cartesian coordinates. + TVector = + RECORD + size: TIndex; + CASE INTEGER OF + 0: (vector: ARRAY[TIndex] OF single); + 1: (x: single; + y: single; + z: single; // contains 'h' for 2D cartesian vector + h: single) + END; + + TIntVector = + RECORD + size: TIndex; + CASE INTEGER OF + 0: (vector: ARRAY[TIndex] OF integer); + 1: (x: integer; + y: integer; + z: integer; // contains 'h' for 2D cartesian vector + h: integer) + END; + // Vector Operations + +// FUNCTION Vector2D (CONST xValue, yValue: DOUBLE): TVector; + FUNCTION Vector3D (CONST xValue, yValue, zValue: DOUBLE): TVector; +(* FUNCTION AddVectors (CONST u,v: TVector): TVector; +// FUNCTION Transform (CONST u: TVector; CONST a: TMatrix): TVector; + + FUNCTION DotProduct (CONST u,v: TVector): DOUBLE; + FUNCTION CrossProduct(CONST u,v: TVector): TVector; + *) + + // Basic Matrix Operations + + FUNCTION Matrix2D (CONST m11,m12,m13, // 2D "graphics" matrix + m21,m22,m23, + m31,m32,m33: DOUBLE): TMatrix; + + FUNCTION Matrix3D (CONST m11,m12,m13,m14, // 3D "graphics" matrix + m21,m22,m23,m24, + m31,m32,m33,m34, + m41,m42,m43,m44: DOUBLE): TMatrix; + + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + + FUNCTION InvertMatrix3D (CONST Input:TMatrix): TMatrix; + + FUNCTION InvertMatrix (CONST a,b: TMatrix; VAR determinant: DOUBLE): TMatrix; + + + // Transformation Matrices + + FUNCTION RotateMatrix (CONST dimension: TDimension; + CONST xyz : TAxis; + CONST angle : DOUBLE; + CONST rotation : Trotation): TMatrix; + +// FUNCTION ScaleMatrix (CONST s: TVector): TMatrix; + +// FUNCTION TranslateMatrix (CONST t: TVector): TMatrix; + + FUNCTION ViewTransformMatrix (CONST coordinate: TCoordinate; + CONST azimuth {or x}, elevation {or y}, distance {or z}: DOUBLE; + CONST ScreenX, ScreenY, ScreenDistance: DOUBLE): TMatrix; + + + // conversions + +// FUNCTION FromCartesian (CONST ToCoordinate: TCoordinate; CONST u: TVector): TVector; +// FUNCTION ToCartesian (CONST FromCoordinate: TCoordinate; CONST u: TVector): TVector; + + //FUNCTION ToDegrees(CONST angle {radians}: DOUBLE): DOUBLE {degrees}; + FUNCTION ToRadians(CONST angle {degrees}: DOUBLE): DOUBLE {radians}; + + + // miscellaneous + + FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; +{ FUNCTION GetFuzz: DOUBLE; + PROCEDURE SetFuzz(CONST x: DOUBLE); + } + +IMPLEMENTATION + + VAR + fuzz : DOUBLE; + + +// ************************* Vector Operations ************************* + + // This procedure defines two-dimensional homogeneous coordinates (x,y,1) + // as a single 'vector' data element 'u'. The 'size' of a two-dimensional + // homogenous vector is 3. + + + // This procedure defines three-dimensional homogeneous coordinates + // (x,y,z,1) as a single 'vector' data element 'u'. The 'size' of a + // three-dimensional homogenous vector is 4. + FUNCTION Vector3D (CONST xValue, yValue, zValue: DOUBLE): TVector; + BEGIN + WITH RESULT DO + BEGIN + x := xValue; + y := yValue; + z := zValue; + h := 1.0; // homogeneous coordinate + size := size3D + END + END {Vector3D}; + + + // AddVectors adds two vectors defined with homogeneous coordinates. + FUNCTION AddVectors (CONST u,v: TVector): TVector; + VAR + i: TIndex; + BEGIN + IF (u.size IN [size2D..size3D]) AND + (v.size IN [size2D..size3D]) AND + (u.size = v.size) + THEN BEGIN + RESULT.size := u.size; + FOR i := 1 TO u.size-1 DO {2D + 2D = 2D or 3D + 3D = 3D} + BEGIN + RESULT.vector[i] := u.vector[i] + v.vector[i] + END; + RESULT.vector[u.size] := 1.0 {homogeneous coordinate} + END + ELSE raise EVectorError.Create('Vector Addition Mismatch') + END {AddVectors}; + + +// *********************** Basic Matrix Operations ********************** + + FUNCTION Matrix2D (CONST m11,m12,m13, m21,m22,m23, m31,m32,m33: DOUBLE): + TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; matrix[1,3] := m13; + matrix[2,1] := m21; matrix[2,2] := m22; matrix[2,3] := m23; + matrix[3,1] := m31; matrix[3,2] := m32; matrix[3,3] := m33; + size := size2D + END + END {Matrix2D}; + + + FUNCTION Matrix3D (CONST m11,m12,m13,m14, m21,m22,m23,m24, + m31,m32,m33,m34, m41,m42,m43,m44: DOUBLE): TMatrix; + BEGIN + WITH RESULT DO + BEGIN + matrix[1,1] := m11; matrix[1,2] := m12; + matrix[1,3] := m13; matrix[1,4] := m14; + + matrix[2,1] := m21; matrix[2,2] := m22; + matrix[2,3] := m23; matrix[2,4] := m24; + + matrix[3,1] := m31; matrix[3,2] := m32; + matrix[3,3] := m33; matrix[3,4] := m34; + + matrix[4,1] := m41; matrix[4,2] := m42; + matrix[4,3] := m43; matrix[4,4] := m44; + size := size3D + END + END {Matrix3D}; + + + // Compound geometric transformation matrices can be formed by multiplying + // simple transformation matrices. This procedure only multiplies together + // matrices for two- or three-dimensional transformations, i.e., 3x3 or 4x4 + // matrices. The multiplier and multiplicand must be of the same dimension. + FUNCTION MultiplyMatrices (CONST a,b: TMatrix): TMatrix; + VAR + i,j,k: TIndex; + temp : DOUBLE; + BEGIN + RESULT.size := a.size; + IF a.size = b.size + THEN + + FOR i := 1 TO a.size DO + BEGIN + FOR j := 1 TO a.size DO + BEGIN + + temp := 0.0; + FOR k := 1 TO a.size DO + BEGIN + temp := temp + a.matrix[i,k]*b.matrix[k,j]; + END; + RESULT.matrix[i,j] := Defuzz(temp) + + END + END + ELSE Showmessage('shit'+inttostr(a.size)+'x'+inttostr(b.size)); + //ELSE EMatrixError.Create('MultiplyMatrices error') + END {MultiplyMatrices}; + +PROCEDURE lubksb(a: {glnpbynp}TMatrix; n: integer; indx: TIntVector; VAR b: TVector); +VAR + j,ip,ii,i: integer; + sum: double; +BEGIN + ii := 0; + FOR i := 1 TO n DO BEGIN + ip := indx.vector[i]; + sum := b.vector[ip]; + b.vector[ip] := b.vector[i]; + IF (ii <> 0) THEN BEGIN + FOR j := ii TO i-1 DO BEGIN + sum := sum-a.matrix[i,j]*b.vector[j] + END + END ELSE IF (sum <> 0.0) THEN BEGIN + ii := i + END; + b.vector[i] := sum + END; + FOR i := n DOWNTO 1 DO BEGIN + sum := b.vector[i]; + IF (i < n) THEN BEGIN + FOR j := i+1 TO n DO BEGIN + sum := sum-a.matrix[i,j]*b.vector[j] + END + END; + b.vector[i] := sum/a.matrix[i,i] + END +end; + + PROCEDURE ludcmp(VAR a: TMatrix; n: integer; + VAR indx: TIntVector; VAR d: double); +CONST + tiny=1.0e-20; +VAR + k,j,imax,i: integer; + sum,dum,big: real; + vv: TVector; +BEGIN + d := 1.0; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO IF (abs(a.matrix[i,j]) > big) THEN big := abs(a.matrix[i,j]); + IF (big = 0.0) THEN BEGIN + writeln('pause in LUDCMP - singular matrix'); readln + END; + vv.vector[i] := 1.0/big + END; + FOR j := 1 TO n DO BEGIN + FOR i := 1 TO j-1 DO BEGIN + sum := a.matrix[i,j]; + FOR k := 1 TO i-1 DO BEGIN + sum := sum-a.matrix[i,k]*a.matrix[k,j] + END; + a.matrix[i,j] := sum + END; + big := 0.0; + FOR i := j TO n DO BEGIN + sum := a.matrix[i,j]; + FOR k := 1 TO j-1 DO BEGIN + sum := sum-a.matrix[i,k]*a.matrix[k,j] + END; + a.matrix[i,j] := sum; + dum := vv.vector[i]*abs(sum); + IF (dum > big) THEN BEGIN + big := dum; + imax := i + END + END; + IF (j <> imax) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a.matrix[imax,k]; + a.matrix[imax,k] := a.matrix[j,k]; + a.matrix[j,k] := dum + END; + d := -d; + vv.vector[imax] := vv.vector[j] + END; + indx.vector[j] := imax; + IF (a.matrix[j,j] = 0.0) THEN a.matrix[j,j] := tiny; + IF (j <> n) THEN BEGIN + dum := 1.0/a.matrix[j,j]; + FOR i := j+1 TO n DO BEGIN + a.matrix[i,j] := a.matrix[i,j]*dum + END + END + END; +END; + + FUNCTION InvertMatrix3D (CONST Input:TMatrix): TMatrix; + var + n,i,j: integer; + d: double; + indx: tIntVector; + col: tvector; + a,y: TMatrix; + begin + a:= Input; + n := 3; + ludcmp(a,n,indx,d); + for j := 1 to n do begin + for i := 1 to n do col.vector[i] := 0; + col.vector[j] := 1.0; + lubksb(a,n,indx,col); + for i := 1 to n do y.matrix[i,j] := col.vector[i]; + end; + result := y; + end; + + // This procedure inverts a general transformation matrix. The user need + // not form an inverse geometric transformation by keeping a product of + // the inverses of simple geometric transformations: translations, rotations + // and scaling. A determinant of zero indicates no inverse is possible for + // a singular matrix. + FUNCTION InvertMatrix (CONST a,b: TMatrix; VAR determinant: DOUBLE): TMatrix; + VAR + c : TMatrix; + i,i_pivot: TIndex; + i_flag : ARRAY[TIndex] OF BOOLEAN; + j,j_pivot: TIndex; + j_flag : ARRAY[TIndex] OF BOOLEAN; + modulus : DOUBLE; + n : TIndex; + pivot : DOUBLE; + pivot_col: ARRAY[TIndex] OF TIndex; + pivot_row: ARRAY[TIndex] OF TIndex; + temporary: DOUBLE; + BEGIN + c := a; // The matrix inversion algorithm used here + WITH c DO // is similar to the "maximum pivot strategy" + BEGIN // described in "Applied Numerical Methods" + FOR i := 1 TO size DO // by Carnahan, Luther and Wilkes, + BEGIN // pp. 282-284. + i_flag[i] := TRUE; + j_flag[i] := TRUE + END; + modulus := 1.0; + i_pivot := 1; // avoid initialization warning + j_pivot := 1; // avoid initialization warning + + FOR n := 1 TO size DO + BEGIN + pivot := 0.0; + IF ABS(modulus) > 0.0 + THEN BEGIN + FOR i := 1 TO size DO + IF i_flag[i] + THEN + + FOR j := 1 TO size DO + IF j_flag[j] + THEN + IF ABS(matrix[i,j]) > ABS(pivot) + THEN BEGIN + pivot := matrix[i,j]; // largest value on which to pivot + i_pivot := i; // indices of pivot element + j_pivot := j + END; + + IF Defuzz(pivot) = 0 // If pivot is too small, consider + THEN modulus := 0 // the matrix to be singular + ELSE BEGIN + pivot_row[n] := i_pivot; + pivot_col[n] := j_pivot; + i_flag[i_pivot] := FALSE; + j_flag[j_pivot] := FALSE; + FOR i := 1 TO size DO + IF i <> i_pivot + THEN + FOR j := 1 TO size DO // pivot column unchanged for elements + IF j <> j_pivot // not in pivot row or column ... + THEN matrix[i,j] := (matrix[i,j]*matrix[i_pivot,j_pivot] - + matrix[i_pivot,j]*matrix[i,j_pivot]) + / modulus; // 2x2 minor / modulus + FOR j := 1 TO size DO + IF j <> j_pivot // change signs of elements in pivot row + THEN matrix[i_pivot,j] := -matrix[i_pivot,j]; + temporary := modulus; // exchange pivot element and modulus + modulus := matrix[i_pivot,j_pivot]; + matrix[i_pivot,j_pivot] := temporary + END + END + END {FOR n} + END {WITH}; + determinant := Defuzz(modulus); + IF determinant <> 0 + THEN BEGIN + RESULT.size := c.size; // The matrix inverse must be unscrambled + FOR i := 1 TO c.size DO // if pivoting was not along main diagonal. + FOR j := 1 TO c.size DO + RESULT.matrix[pivot_row[i],pivot_col[j]] := Defuzz(c.matrix[i,j]/determinant) + END + ELSE EMatrixError.Create('InvertMatrix error') + + END {InvertMatrix}; + + +// *********************** Transformation Matrices ******************** + + + // This procedure defines a matrix for a two- or three-dimensional rotation. + // To avoid possible confusion in the sense of the rotation, 'rotateClockwise' + // or 'roCounterlcockwise' must always be specified along with the axis + // of rotation. Two-dimensional rotations are assumed to be about the z-axis + // in the x-y plane. + // + // A rotation about an arbitrary axis can be performed with the following + // steps: + // (1) Translate the object into a new coordinate system where (x,y,z) + // maps into the origin (0,0,0). + // (2) Perform appropriate rotations about the x and y axes of the + // coordinate system so that the unit vector (a,b,c) is mapped into + // the unit vector along the z axis. + // (3) Perform the desired rotation about the z-axis of the new + // coordinate system. + // (4) Apply the inverse of step (2). + // (5) Apply the inverse of step (1). + FUNCTION RotateMatrix (CONST dimension: TDimension; + CONST xyz : TAxis; + CONST angle : DOUBLE; + CONST rotation : Trotation): TMatrix; + VAR + cosx : DOUBLE; + sinx : DOUBLE; + TempAngle: DOUBLE; + + BEGIN + TempAngle := angle; // Use TempAngle since "angle" is CONST parameter + + IF rotation = rotateCounterClockwise + THEN TempAngle := -TempAngle; + + cosx := Defuzz( COS(TempAngle) ); + sinx := Defuzz( SIN(TempAngle) ); + + CASE dimension OF + dimen2D: + CASE xyz OF + axisX,axisY: EMatrixError.Create('Invalid 2D rotation matrix. Specify axisZ'); + + axisZ: RESULT := Matrix2D ( cosx, -sinx, 0, + sinx, cosx, 0, + 0, 0, 1) + END; + + dimen3D: + CASE xyz OF + axisX: RESULT := Matrix3D ( 1, 0, 0, 0, + 0, cosx, -sinx, 0, + 0, sinx, cosx, 0, + 0, 0, 0, 1); + + axisY: RESULT := Matrix3D ( cosx, 0, sinx, 0, + 0, 1, 0, 0, + -sinx, 0, cosx, 0, + 0, 0, 0, 1); + + axisZ: RESULT := Matrix3D ( cosx, -sinx, 0, 0, + sinx, cosx, 0, 0, + 0, 0, 1, 0, + 0, 0, 0, 1); + END + END + END {RotateMatrix}; + + + // 'ScaleMatrix' accepts a 'vector' containing the scaling factors for + // each of the dimensions and creates a scaling matrix. The size + // of the vector dictates the size of the resulting matrix. + FUNCTION ScaleMatrix (CONST s: TVector): TMatrix; + BEGIN + CASE s.size OF + size2D: RESULT := Matrix2D (s.x, 0, 0, + 0, s.y, 0, + 0, 0, 1); + + size3D: RESULT := Matrix3D (s.x, 0, 0, 0, + 0, s.y, 0, 0, + 0, 0, s.z, 0, + 0, 0, 0, 1) + END + END {ScaleMatrix}; + // 'TranslateMatrix' defines a translation transformation matrix. The + // components of the vector 't' determine the translation components. + // (Note: 'Translate' here is from kinematics in physics.) + FUNCTION TranslateMatrix (CONST t: TVector): TMatrix; + BEGIN + CASE t.size OF + size2D: RESULT := Matrix2D ( 1, 0, 0, + 0, 1, 0, + t.x, t.y, 1); + + size3D: RESULT := Matrix3D ( 1, 0, 0, 0, + 0, 1, 0, 0, + 0, 0, 1, 0, + t.x, t.y, t.z, 1) + END + END {TranslateMatrix}; + // 'ViewTransformMatrix' creates a transformation matrix for changing + // from world coordinates to eye coordinates. The location of the 'eye' + // from the 'object' is given in spherical (azimuth,elevation,distance) + // coordinates or Cartesian (x,y,z) coordinates. The size of the screen + // is 'ScreenX' units horizontally and 'ScreenY' units vertically. The + // eye is 'ScreenDistance' units from the viewing screen. A large ratio + // 'ScreenDistance/ScreenX (or ScreenY)' specifies a narrow aperature + // -- a telephoto view. Conversely, a small ratio specifies a large + // aperature -- a wide-angle view. This view transform matrix is very + // useful as the default three-dimensional transformation matrix. Once + // set, all points are automatically transformed. + FUNCTION ViewTransformMatrix (CONST coordinate: TCoordinate; + CONST azimuth {or x}, elevation {or y}, distance {or z}: DOUBLE; + CONST ScreenX, ScreenY, ScreenDistance: DOUBLE): TMatrix; + + CONST + HalfPI = PI / 2.0; + + VAR + a : TMatrix; + b : TMatrix; + cosm : DOUBLE; // COS(-angle) + hypotenuse: DOUBLE; + sinm : DOUBLE; // SIN(-angle) + temporary : DOUBLE; + u : TVector; + x : DOUBLE ABSOLUTE azimuth; // x and azimuth are synonyms + y : DOUBLE ABSOLUTE elevation; // synonyms + z : DOUBLE ABSOLUTE distance; // synonyms + + BEGIN + CASE coordinate OF + coordCartesian: u := Vector3D (-x, -y, -z); + + coordSpherical: + BEGIN + temporary := -distance * COS(elevation); + u := Vector3D (temporary * COS(azimuth - HalfPI), + temporary * SIN(azimuth - HalfPI), + -distance * SIN(elevation)); + END + END; + a := TranslateMatrix(u); // translate origin to 'eye' + b := RotateMatrix (dimen3D, axisX, HalfPI, rotateClockwise); + a := MultiplyMatrices(a,b); + + CASE coordinate OF + coordCartesian: + BEGIN + temporary := SQR(x) + SQR(y); + hypotenuse := SQRT(temporary); + if hypotenuse <> 0 then begin + cosm := -y/hypotenuse; + sinm := x/hypotenuse; + end else begin + cosm := 1;//abba + sinm := 0; + end; + + b := Matrix3D ( cosm, 0, sinm, 0, + 0, 1, 0, 0, + -sinm, 0, cosm, 0, + 0, 0, 0, 1); + + a := MultiplyMatrices (a,b); + cosm := hypotenuse; + hypotenuse := SQRT(temporary + SQR(z)); + cosm := cosm/hypotenuse; + sinm := -z/hypotenuse; + + b := Matrix3D ( 1, 0, 0, 0, + 0, cosm, -sinm, 0, + 0, sinm, cosm, 0, + 0, 0, 0, 1) + END; + coordSpherical: + BEGIN + b := RotateMatrix (dimen3D,axisY,-azimuth,rotateCounterClockwise); + a := MultiplyMatrices(a,b); + b := RotateMatrix (dimen3D,axisX,elevation,rotateCounterClockwise); + END + END {CASE}; + + a := MultiplyMatrices (a,b); + u := Vector3D (ScreenDistance/(0.5*ScreenX), + ScreenDistance/(0.5*ScreenY),-1.0); + b := ScaleMatrix (u); // reverse sense of z-axis; screen transformation + + RESULT := MultiplyMatrices (a,b); + + END {ViewTransformMatrix}; + +// *************************** Conversions ************************** + // This function converts the vector parameter from Cartesian + // coordinates to the specified type of coordinates. + FUNCTION FromCartesian (CONST ToCoordinate: TCoordinate; CONST u: TVector): TVector; + VAR + phi : DOUBLE; + r : DOUBLE; + temp : DOUBLE; + theta: DOUBLE; + + BEGIN + IF ToCoordinate = coordCartesian + THEN RESULT := u + ELSE BEGIN + RESULT.size := u.size; + + IF (u.size = size3D) AND + (ToCoordinate = coordSpherical) + THEN BEGIN // spherical 3D + temp := SQR(u.x)+SQR(u.y); // (x,y,z) -> (r,theta,phi) + r := SQRT(temp+SQR(u.z)); + IF Defuzz(u.x) = 0.0 + THEN theta := PI/4 + ELSE theta := ARCTAN(u.y/u.x); + IF Defuzz(u.z) = 0.0 + THEN phi := PI/4 + ELSE phi := ARCTAN(SQRT(temp)/u.z); + RESULT.x := r; + RESULT.y := theta; + RESULT.z := phi + END + ELSE BEGIN // cylindrical 2D/3D or spherical 2D + // (x,y) -> (r,theta) or (x,y,z) -> (r,theta,z) + r := SQRT( SQR(u.x) + SQR(u.y) ); + IF Defuzz(u.x) = 0.0 + THEN theta := PI/4 + ELSE theta := ARCTAN(u.y/u.x); + RESULT.x := r; + RESULT.y := theta + END + + END + END {FromCartesian}; + + + // This function converts the vector parameter from specified coordinates + // into Cartesian coordinates. + FUNCTION ToCartesian (CONST FromCoordinate: TCoordinate; CONST u: TVector): TVector; + VAR + phi : DOUBLE; + r : DOUBLE; + sinphi: DOUBLE; + theta : DOUBLE; + + BEGIN + RESULT := u; + + IF FromCoordinate = coordCartesian + THEN RESULT := u + ELSE BEGIN + RESULT.size := u.size; + + IF (u.size = size3D) AND + (FromCoordinate = coordSpherical) + THEN BEGIN // spherical 3D + r := u.x; // (r,theta,phi) -> (x,y,z) + theta := u.y; + phi := u.z; + sinphi := SIN(phi); + RESULT.x := r * COS(theta) * sinphi; + RESULT.y := r * SIN(theta) * sinphi; + RESULT.z := r * COS(phi) + END + ELSE BEGIN // cylindrical 2D/3D or spherical 2D + r := u.x; // (r,theta) -> (x,y) or (r,theta,z) -> (x,y,z) + theta := u.y; + RESULT.x := r * COS(theta); + RESULT.y := r * SIN(theta) + END + END + END {ToCartesian}; + + + + + // Convert angle in degrees to radians. + FUNCTION ToRadians (CONST angle: DOUBLE): DOUBLE; + BEGIN + RESULT := PI/180.0 * angle + END; {ToRadians} + + +// *************************** Miscellaneous ************************** + + // 'Defuzz' is used for comparisons and to avoid propagation of 'fuzzy', + // nearly-zero values. DOUBLE calculations often result in 'fuzzy' values. + // The term 'fuzz' was adapted from the APL language. + FUNCTION Defuzz(CONST x: DOUBLE): DOUBLE; + BEGIN + IF ABS(x) < fuzz + THEN RESULT := 0.0 + ELSE RESULT := x + END {Defuzz}; + + +INITIALIZATION + fuzz := 1.0E-6; + +END. {GraphicsMath UNIT} diff --git a/npm_precl/dmath/Matrices.pas b/npm_precl/dmath/Matrices.pas new file mode 100755 index 0000000..2610107 --- /dev/null +++ b/npm_precl/dmath/Matrices.pas @@ -0,0 +1,1696 @@ +{ ********************************************************************** + * Unit MATRICES.PAS * + * Version 2.0 * + * (c) J. Debord, May 2001 * + ********************************************************************** + This unit implements dynamic allocation of vectors and matrices in + Pascal, together with various matrix operations. + + Dynamic allocation is allowed by declaring arrays as pointers. There + are 8 types available : + + PVector, PMatrix for floating point arrays + PIntVector, PIntMatrix for integer arrays + PBoolVector, PBoolMatrix for boolean arrays + PStrVector, PStrMatrix for string arrays (255 char.) + + To use these arrays in your programs, you must : + + (1) Declare variables of the appropriate type, e.g. + + var + V : PVector; + A : PMatrix; + + (2) Allocate each array BEFORE using it : + + DimVector(V, N); creates vector V[0..N] + DimMatrix(A, N, M); creates matrix A[0..N, 0..M] + where N, M are two integer variables + + If the allocation succeeds, all array elements are initialized + to zero (for numeric arrays), False (for boolean arrays), or + the null string (for string arrays). Otherwise, the pointer is + initialized to NIL. + + (3) Use arrays as in standard Turbo Pascal, with the following + exceptions : + + (a) You must use the indirection operator (^) to reference any + array element, i.e. write V^[I] and A^[I]^[J] instead of + V[I] and A[I,J]. + + (b) You cannot use the assignment operator (:=) to copy the + contents of an array into another array. Writing B := A + simply makes B point to the same memory block than A. You + must use one of the provided Copy... procedures (see their + documentation in the interface part of the unit). + + In addition, note that : + + (a) All arrays begin at index 0, so that the 0-indexed element + is always present, even if you don't use it. + + (b) A matrix is declared as an array of vectors, so that A^[I] + denotes the I-th vector of matrix A and may be used as any + vector. + + (4) Deallocate arrays when you no longer need them. This will free + the corresponding memory : + + DelVector(V, N); + DelMatrix(A, N, M); + + For more information, read the comments of each routine in the + interface part of the unit, and check the demo programs. + ********************************************************************** + References : + 1) 'Basic Programs for Scientists and Engineers' by A.R. Miller : + GaussJordan, InvMat + 2) Borland's Numerical Methods Toolbox : Det + 3) 'Numerical Recipes' by Press et al. : Cholesky, LU, SVD + 4) 'Matrix Computations' by Golub & Van Loan : QR_Decomp & QR_Solve + (Pascal implementation contributed by Mark Vaughan) + ********************************************************************** } + +unit Matrices; + +interface + +uses + FMath,dialogs,sysutils; + +{ ********************************************************************** + This section defines some error codes. + ********************************************************************** } + +const + MAT_OK = 0; { No error } + MAT_SINGUL = - 1; { Singular matrix } + MAT_NON_CONV = - 2; { Non convergence of iterative procedure } + MAT_NOT_PD = - 3; { Matrix not positive definite } + +{ ********************************************************************** + This section defines the vector and matrix types. Maximal sizes are + given for a 16-bit compiler (TP / BP / Delphi 1). Higher values may + be used with the 32-bit compilers (Delphi 2-4, FPK, GPC). + ********************************************************************** } + +const +{$IFDEF EXTENDEDREAL} + MAX_FLT = 6552; { Max size of real vector } +{$ELSE} +{$IFDEF SINGLEREAL} + MAX_FLT = 16382; +{$ELSE} +{$IFDEF PASCALREAL} + MAX_FLT = 10921; +{$ELSE} + {$DEFINE DOUBLEREAL} + MAX_FLT = 8190; +{$ENDIF} +{$ENDIF} +{$ENDIF} + + MAX_INT = 16382; { Max size of integer vector } + MAX_BOOL = 32766; { Max size of boolean vector } + MAX_STR = 254; { Max size of string vector } + MAX_VEC = 16382; { Max number of vectors in a matrix } + +type + Str255= string[255]; + TVector = array[0..MAX_FLT] of Float; + TIntVector = array[0..MAX_INT] of Integer; + TBoolVector = array[0..MAX_BOOL] of Boolean; + TStrVector = array[0..MAX_STR] of Str255; + + PVector = ^TVector; + PIntVector = ^TIntVector; + PBoolVector = ^TBoolVector; + PStrVector = ^TStrVector; + + TMatrix = array[0..MAX_VEC] of PVector; + TIntMatrix = array[0..MAX_VEC] of PIntVector; + TBoolMatrix = array[0..MAX_VEC] of PBoolVector; + TStrMatrix = array[0..MAX_VEC] of PStrVector; + + PMatrix = ^TMatrix; + PIntMatrix = ^TIntMatrix; + PBoolMatrix = ^TBoolMatrix; + PStrMatrix = ^TStrMatrix; + +{ ********************************************************************** + Memory allocation routines + ********************************************************************** } + +procedure DimVector(var V : PVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates floating point vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimIntVector(var V : PIntVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates integer vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimBoolVector(var V : PBoolVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates boolean vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimStrVector(var V : PStrVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates string vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates floating point matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates integer matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates boolean matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DimStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates string matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Memory deallocation routines + ********************************************************************** } + +procedure DelVector(var V : PVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes floating point vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelIntVector(var V : PIntVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes integer vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelBoolVector(var V : PBoolVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes boolean vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelStrVector(var V : PStrVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes string vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes floating point matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes integer matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes boolean matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +procedure DelStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes string matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Routines for copying vectors and matrices + ---------------------------------------------------------------------- + Lbound, Ubound : indices of first and last vector elements + Lbound1, Lbound2 : indices of first matrix element in each dimension + Ubound1, Ubound2 : indices of last matrix element in each dimension + ********************************************************************** } + +procedure SwapRows(I, K : Integer; A : PMatrix; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Exchanges rows I and K of matrix A + ---------------------------------------------------------------------- } + +procedure SwapCols(J, K : Integer; A : PMatrix; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Exchanges columns J and K of matrix A + ---------------------------------------------------------------------- } + +procedure CopyVector(Dest, Source : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into vector Dest + ---------------------------------------------------------------------- } + +procedure CopyMatrix(Dest, Source : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Copies matrix Source into matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyRowFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Row : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into line Row of matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyColFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Col : Integer); +{ ---------------------------------------------------------------------- + Copies vector Source into column Col of matrix Dest + ---------------------------------------------------------------------- } + +procedure CopyVectorFromRow(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Row : Integer); +{ ---------------------------------------------------------------------- + Copies line Row of matrix Source into vector Dest + ---------------------------------------------------------------------- } + +procedure CopyVectorFromCol(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Col : Integer); +{ ---------------------------------------------------------------------- + Copies column Col of matrix Source into vector Dest + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Vector and matrix functions + ********************************************************************** } + +function Min(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the lowest value of vector X + ---------------------------------------------------------------------- } + +function Max(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the highest value of vector X + ---------------------------------------------------------------------- } + +function IntMin(X : PIntVector; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + Returns the lowest value of integer vector X + ---------------------------------------------------------------------- } + +function IntMax(X : PIntVector; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + Returns the highest value of integer vector X + ---------------------------------------------------------------------- } + +procedure Transpose(A : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer; + A_t : PMatrix); +{ ---------------------------------------------------------------------- + Transposes a matrix + ---------------------------------------------------------------------- + Input parameters : A = original matrix + Lbound1, + Lbound2 = indices of 1st matrix elem. in each dim. + Ubound1, + Ubound2 = indices of last matrix elem. in each dim. + ---------------------------------------------------------------------- + Output parameter : A_t = transposed matrix + ---------------------------------------------------------------------- } + +function GaussJordan(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + A_inv : PMatrix; X : PVector) : Integer; +{ ---------------------------------------------------------------------- + Solves a system of linear equations by the Gauss-Jordan method + ---------------------------------------------------------------------- + Input parameters : A = system matrix + B = constant vector + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameters : A_inv = inverse matrix + X = solution vector + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- } + +function InvMat(A : PMatrix; Lbound, Ubound : Integer; + A_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Computes the inverse of a square matrix by the Gauss-Jordan method + ---------------------------------------------------------------------- + Parameters : as in Gauss-Jordan + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- } + +function Det(A : PMatrix; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Computes the determinant of a square matrix + ---------------------------------------------------------------------- + Parameters : as in Gauss-Jordan + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function Cholesky(A : PMatrix; Lbound, Ubound : Integer; + L : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Cholesky decomposition. Factors the symmetric positive definite matrix + A as a product L * L', where L is a lower triangular matrix. This + procedure may be used as a test of positive definiteness. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameter : L = Cholesky factor of matrix A + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NOT_PD + ---------------------------------------------------------------------- } + +function LU_Decomp(A : PMatrix; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + LU decomposition. Factors the square matrix A as a product L * U, + where L is a lower triangular matrix (with unit diagonal terms) and U + is an upper triangular matrix. This routine is used in conjunction + with LU_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of L and U + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SINGUL + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure LU_Solve(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations whose matrix has been transformed by + LU_Decomp + ---------------------------------------------------------------------- + Input parameters : A = result from LU_Decomp + B = constant vector + Lbound, + Ubound = as in LU_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + ---------------------------------------------------------------------- } + +function SV_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + S : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Singular value decomposition. Factors the matrix A (n x m, with n >= m) + as a product U * S * V' where U is a (n x m) column-orthogonal matrix, + S a (m x m) diagonal matrix with elements >= 0 (the singular values) + and V a (m x m) orthogonal matrix. This routine is used in conjunction + with SV_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound1 = index of last matrix element in 1st dim. + Ubound2 = index of last matrix element in 2nd dim. + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of U + S = vector of singular values + V = orthogonal matrix + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure SV_SetZero(S : PVector; Lbound, Ubound : Integer; Tol : Float); +{ ---------------------------------------------------------------------- + Sets the singular values to zero if they are lower than a specified + threshold. + ---------------------------------------------------------------------- + Input parameters : S = vector of singular values + Tol = relative tolerance + Threshold value will be Tol * Max(S) + Lbound = index of first vector element + Ubound = index of last vector element + ---------------------------------------------------------------------- + Output parameter : S = modified singular values + ---------------------------------------------------------------------- } + +procedure SV_Solve(U : PMatrix; S : PVector; V : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations by singular value decomposition, after + the matrix has been transformed by SV_Decomp, and the lowest singular + values have been set to zero by SV_SetZero. + ---------------------------------------------------------------------- + Input parameters : U, S, V = vector and matrices from SV_Decomp + B = constant vector + Lbound, + Ubound1, + Ubound2 = as in SV_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + = V * Diag(1/s(i)) * U' * B, for s(i) <> 0 + ---------------------------------------------------------------------- } + +procedure SV_Approx(U : PMatrix; S : PVector; V : PMatrix; + Lbound, Ubound1, Ubound2 : Integer; + A : PMatrix); +{ ---------------------------------------------------------------------- + Approximates a matrix A by the product USV', after the lowest singular + values have been set to zero by SV_SetZero. + ---------------------------------------------------------------------- + Input parameters : U, S, V = vector and matrices from SV_Decomp + Lbound, + Ubound1, + Ubound2 = as in SV_Decomp + ---------------------------------------------------------------------- + Output parameter : A = approximated matrix + ---------------------------------------------------------------------- } + +function QR_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + R : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + QR decomposition. Factors the matrix A (n x m, with n >= m) as a + product Q * R where Q is a (n x m) column-orthogonal matrix, and R + a (m x m) upper triangular matrix. This routine is used in conjunction + with QR_Solve to solve a system of equations. + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound1 = index of last matrix element in 1st dim. + Ubound2 = index of last matrix element in 2nd dim. + ---------------------------------------------------------------------- + Output parameter : A = contains the elements of Q + R = upper triangular matrix + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_SING + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +procedure QR_Solve(Q, R : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); +{ ---------------------------------------------------------------------- + Solves a system of equations by the QR decomposition, + after the matrix has been transformed by QR_Decomp. + ---------------------------------------------------------------------- + Input parameters : Q, R = matrices from QR_Decomp + B = constant vector + Lbound, + Ubound1, + Ubound2 = as in QR_Decomp + ---------------------------------------------------------------------- + Output parameter : X = solution vector + ---------------------------------------------------------------------- } + +implementation + +const + { Used by LU procedures } + LastDim : Integer = 1; { Dimension of the last system solved } + Index : PIntVector = nil; { Records the row permutations } + + procedure DimVector(var V : PVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_FLT) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Float)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := 0.0; + end; + + procedure DimIntVector(var V : PIntVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_INT) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Integer)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := 0; + end; + + procedure DimBoolVector(var V : PBoolVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_BOOL) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Boolean)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := False; + end; + + procedure DimStrVector(var V : PStrVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_STR) then + begin + showmessage('DIMstr error'); + V := nil; + Exit; + end; + + { Allocate vector } + + GetMem(V, Succ(Ubound) * sizeof(TStrVector) {256}); + + if V = nil then Exit; + { Initialize vector } + + for I := 0 to Ubound do + V^[I] := ''; + //showmessage(inttostr(Ubound)+'b'+inttostr(MAX_STR)); + end; + + procedure DimMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_FLT) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Float); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := 0.0; + end; + + procedure DimIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_INT) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PIntVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Integer); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := 0; + end; + + procedure DimBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_BOOL) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PBoolVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * SizeOf(Boolean); + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := False; + end; + + procedure DimStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_STR) then + begin + A := nil; + Exit; + end; + + { Allocate matrix } + GetMem(A, Succ(Ubound1) * SizeOf(PStrVector)); + if A = nil then Exit; + + { Size of a row } + RowSize := Succ(Ubound2) * 256; + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := ''; + end; + + procedure DelVector(var V : PVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Float)); + V := nil; + end; + end; + + procedure DelIntVector(var V : PIntVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Integer)); + V := nil; + end; + end; + + procedure DelBoolVector(var V : PBoolVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Boolean)); + V := nil; + end; + end; + + procedure DelStrVector(var V : PStrVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V{, Succ(Ubound) * 256}); + V := nil; + end; + end; + + procedure DelMatrix(var A : PMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Float); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PVector)); + A := nil; + end; + end; + + procedure DelIntMatrix(var A : PIntMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Integer); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PIntVector)); + A := nil; + end; + end; + + procedure DelBoolMatrix(var A : PBoolMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Boolean); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PBoolVector)); + A := nil; + end; + end; + + procedure DelStrMatrix(var A : PStrMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * 256; + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PStrVector)); + A := nil; + end; + end; + + procedure SwapRows(I, K : Integer; A : PMatrix; Lbound, Ubound : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + FSwap(A^[I]^[J], A^[K]^[J]); + end; + + procedure SwapCols(J, K : Integer; A : PMatrix; Lbound, Ubound : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + FSwap(A^[I]^[J], A^[I]^[K]); + end; + + procedure CopyVector(Dest, Source : PVector; Lbound, Ubound : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I] := Source^[I]; + end; + + procedure CopyMatrix(Dest, Source : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer); + var + I, J : Integer; + begin + for I := Lbound1 to Ubound1 do + for J := Lbound2 to Ubound2 do + Dest^[I]^[J] := Source^[I]^[J]; + end; + + procedure CopyRowFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Row : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + Dest^[Row]^[J] := Source^[J]; + end; + + procedure CopyColFromVector(Dest : PMatrix; Source : PVector; + Lbound, Ubound, Col : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I]^[Col] := Source^[I]; + end; + + procedure CopyVectorFromRow(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Row : Integer); + var + J : Integer; + begin + for J := Lbound to Ubound do + Dest^[J] := Source^[Row]^[J]; + end; + + procedure CopyVectorFromCol(Dest : PVector; Source : PMatrix; + Lbound, Ubound, Col : Integer); + var + I : Integer; + begin + for I := Lbound to Ubound do + Dest^[I] := Source^[I]^[Col]; + end; + + function Min(X : PVector; Lbound, Ubound : Integer) : Float; + var + Xmin : Float; + I : Integer; + begin + Xmin := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] < Xmin then Xmin := X^[I]; + Min := Xmin; + end; + + function Max(X : PVector; Lbound, Ubound : Integer) : Float; + var + Xmax : Float; + I : Integer; + begin + Xmax := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] > Xmax then Xmax := X^[I]; + Max := Xmax; + end; + + function IntMin(X : PIntVector; Lbound, Ubound : Integer) : Integer; + var + I, Xmin : Integer; + begin + Xmin := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] < Xmin then Xmin := X^[I]; + IntMin := Xmin; + end; + + function IntMax(X : PIntVector; Lbound, Ubound : Integer) : Integer; + var + I, Xmax : Integer; + begin + Xmax := X^[Lbound]; + for I := Succ(Lbound) to Ubound do + if X^[I] > Xmax then Xmax := X^[I]; + IntMax := Xmax; + end; + + procedure Transpose(A : PMatrix; + Lbound1, Lbound2, Ubound1, Ubound2 : Integer; + A_t : PMatrix); + var + I, J : Integer; + begin + for I := Lbound1 to Ubound1 do + for J := Lbound2 to Ubound2 do + A_t^[J]^[I] := A^[I]^[J]; + end; + + function GaussJordan(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + A_inv : PMatrix; X : PVector) : Integer; + var + I, J, K : Integer; + Pvt, T : Float; + PRow, PCol : PIntVector; { Store line and column of pivot } + begin + DimIntVector(PRow, Ubound); + DimIntVector(PCol, Ubound); + + { Copy A into A_inv and B into X } + CopyMatrix(A_inv, A, Lbound, Lbound, Ubound, Ubound); + CopyVector(X, B, Lbound, Ubound); + + K := Lbound; + while K <= Ubound do + begin + { Search for largest pivot in submatrix A_inv[K..Ubound, K..Ubound] } + Pvt := A_inv^[K]^[K]; + PRow^[K] := K; + PCol^[K] := K; + for I := K to Ubound do + for J := K to Ubound do + if Abs(A_inv^[I]^[J]) > Abs(Pvt) then + begin + Pvt := A_inv^[I]^[J]; + PRow^[K] := I; + PCol^[K] := J; + end; + + { Pivot too weak ==> quasi-singular matrix } + if Abs(Pvt) < MACHEP then + begin + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + GaussJordan := MAT_SINGUL; + Exit; + end; + + { Exchange current row (K) with pivot row } + if PRow^[K] <> K then + begin + SwapRows(PRow^[K], K, A_inv, Lbound, Ubound); + FSwap(X^[PRow^[K]], X^[K]); + end; + + { Exchange current column (K) with pivot column } + if PCol^[K] <> K then + SwapCols(PCol^[K], K, A_inv, Lbound, Ubound); + + { Transform pivot row } + A_inv^[K]^[K] := 1.0; + for J := Lbound to Ubound do + A_inv^[K]^[J] := A_inv^[K]^[J] / Pvt; + X^[K] := X^[K] / Pvt; + + { Transform other rows } + for I := Lbound to Ubound do + if I <> K then + begin + T := A_inv^[I]^[K]; + A_inv^[I]^[K] := 0.0; + for J := Lbound to Ubound do + A_inv^[I]^[J] := A_inv^[I]^[J] - T * A_inv^[K]^[J]; + X^[I] := X^[I] - T * X^[K]; + end; + Inc(K); + end; + + { Rearrange inverse matrix } + for I := Ubound downto Lbound do + if PCol^[I] <> I then + begin + SwapRows(PCol^[I], I, A_inv, Lbound, Ubound); + FSwap(X^[PCol^[I]], X^[I]); + end; + for J := Ubound downto Lbound do + if PRow^[J] <> J then + SwapCols(PRow^[J], J, A_inv, Lbound, Ubound); + + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + GaussJordan := MAT_OK; + end; + + function InvMat(A : PMatrix; Lbound, Ubound : Integer; + A_inv : PMatrix) : Integer; + var + I, J, K : Integer; + Pvt, T : Float; + PRow, PCol : PIntVector; { Store line and column of pivot } + begin + DimIntVector(PRow, Ubound); + DimIntVector(PCol, Ubound); + + { Copy A into A_inv } + CopyMatrix(A_inv, A, Lbound, Lbound, Ubound, Ubound); + + K := Lbound; + while K <= Ubound do + begin + { Search for largest pivot in submatrix A_inv[K..Ubound, K..Ubound] } + Pvt := A_inv^[K]^[K]; + PRow^[K] := K; + PCol^[K] := K; + for I := K to Ubound do + for J := K to Ubound do + if Abs(A_inv^[I]^[J]) > Abs(Pvt) then + begin + Pvt := A_inv^[I]^[J]; + PRow^[K] := I; + PCol^[K] := J; + end; + + { Pivot too weak ==> quasi-singular matrix } + if Abs(Pvt) < MACHEP then + begin + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + InvMat := MAT_SINGUL; + Exit; + end; + + { Exchange current row (K) with pivot row } + if PRow^[K] <> K then + SwapRows(PRow^[K], K, A_inv, Lbound, Ubound); + + { Exchange current column (K) with pivot column } + if PCol^[K] <> K then + SwapCols(PCol^[K], K, A_inv, Lbound, Ubound); + + { Transform pivot row } + A_inv^[K]^[K] := 1.0; + for J := Lbound to Ubound do + A_inv^[K]^[J] := A_inv^[K]^[J] / Pvt; + + { Transform other rows } + for I := Lbound to Ubound do + if I <> K then + begin + T := A_inv^[I]^[K]; + A_inv^[I]^[K] := 0.0; + for J := Lbound to Ubound do + A_inv^[I]^[J] := A_inv^[I]^[J] - T * A_inv^[K]^[J]; + end; + Inc(K); + end; + + { Rearrange inverse matrix } + for I := Ubound downto Lbound do + if PCol^[I] <> I then + SwapRows(PCol^[I], I, A_inv, Lbound, Ubound); + for J := Ubound downto Lbound do + if PRow^[J] <> J then + SwapCols(PRow^[J], J, A_inv, Lbound, Ubound); + + DelIntVector(PRow, Ubound); + DelIntVector(PCol, Ubound); + InvMat := MAT_OK; + end; + + function Det(A : PMatrix; Lbound, Ubound : Integer) : Float; + var + D, T : Float; { Partial determinant & multiplier } + I, J, K : Integer; { Loop variables } + ZeroDet : Boolean; { Flags a null determinant } + begin + ZeroDet := False; + D := 1.0; + K := Lbound; + + { Make the matrix upper triangular } + while not(ZeroDet) and (K < Ubound) do + begin + { If diagonal element is zero then switch rows } + if Abs(A^[K]^[K]) < MACHEP then + begin + ZeroDet := True; + I := K; + + { Try to find a row with a non-zero element in this column } + while ZeroDet and (I < Ubound) do + begin + I := Succ(I); + if Abs(A^[I]^[K]) > MACHEP then + begin + { Switch these two rows } + SwapRows(I, K, A, Lbound, Ubound); + ZeroDet := False; + { Switching rows changes the sign of the determinant } + D := - D; + end; + end; + end; + + if not(ZeroDet) then + for I := Succ(K) to Ubound do + if Abs(A^[I]^[K]) > MACHEP then + begin + { Make the K element of this row zero } + T := - A^[I]^[K] / A^[K]^[K]; + for J := 1 to Ubound do + A^[I]^[J] := A^[I]^[J] + T * A^[K]^[J]; + end; + + D := D * A^[K]^[K]; { Multiply the diagonal term into D } + Inc(K); + end; + + if ZeroDet then + Det := 0.0 + else + Det := D * A^[Ubound]^[Ubound]; + end; + + function Cholesky(A : PMatrix; Lbound, Ubound : Integer; + L : PMatrix) : Integer; + var + I, J, K : Integer; + Sum : Float; + begin + for K := Lbound to Ubound do + begin + Sum := A^[K]^[K]; + for J := Lbound to K - 1 do + Sum := Sum - Sqr(L^[K]^[J]); + + if Sum <= 0.0 then + begin + Cholesky := MAT_NOT_PD; + Exit; + end; + + L^[K]^[K] := Sqrt(Sum); + for I := K + 1 to Ubound do + begin + Sum := A^[I]^[K]; + for J := Lbound to K - 1 do + Sum := Sum - L^[I]^[J] * L^[K]^[J]; + L^[I]^[K] := Sum / L^[K]^[K]; + end; + end; + Cholesky := MAT_OK; + end; + + function LU_Decomp(A : PMatrix; Lbound, Ubound : Integer) : Integer; + const + TINY = 1.0E-20; + var + I, Imax, J, K : Integer; + Pvt, T, Sum : Float; + V : PVector; + begin + DimVector(V, Ubound); + { Reallocate Index } + if Index <> nil then + DelIntVector(Index, LastDim); + DimIntVector(Index, Ubound); + LastDim := Ubound; + + for I := Lbound to Ubound do + begin + Pvt := 0.0; + for J := Lbound to Ubound do + if Abs(A^[I]^[J]) > Pvt then + Pvt := Abs(A^[I]^[J]); + if Pvt < MACHEP then + begin + DelVector(V, Ubound); + LU_Decomp := MAT_SINGUL; + Exit; + end; + V^[I] := 1.0 / Pvt; + end; + for J := Lbound to Ubound do + begin + for I := Lbound to Pred(J) do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(I) do + Sum := Sum - A^[I]^[K] * A^[K]^[J]; + A^[I]^[J] := Sum; + end; + Pvt := 0.0; + for I := J to Ubound do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(J) do + Sum := Sum - A^[I]^[K] * A^[K]^[J]; + A^[I]^[J] := Sum; + T := V^[I] * Abs(Sum); + if T > Pvt then + begin + Pvt := T; + Imax := I; + end; + end; + if J <> Imax then + begin + SwapRows(Imax, J, A, Lbound, Ubound); + V^[Imax] := V^[J]; + end; + Index^[J] := Imax; + if A^[J]^[J] = 0.0 then + A^[J]^[J] := TINY; + if J <> Ubound then + begin + T := 1.0 / A^[J]^[J]; + for I := Succ(J) to Ubound do + A^[I]^[J] := A^[I]^[J] * T; + end; + end; + DelVector(V, Ubound); + LU_Decomp := MAT_OK; + end; + + procedure LU_Solve(A : PMatrix; B : PVector; Lbound, Ubound : Integer; + X : PVector); + var + I, Ip, J, K : Integer; + Sum : Float; + begin + K := Pred(Lbound); + CopyVector(X, B, Lbound, Ubound); + for I := Lbound to Ubound do + begin + Ip := Index^[I]; + Sum := X^[Ip]; + X^[Ip] := X^[I]; + if K >= Lbound then + for J := K to Pred(I) do + Sum := Sum - A^[I]^[J] * X^[J] + else if Sum <> 0.0 then + K := I; + X^[I] := Sum; + end; + for I := Ubound downto Lbound do + begin + Sum := X^[I]; + if I < Ubound then + for J := Succ(I) to Ubound do + Sum := Sum - A^[I]^[J] * X^[J]; + X^[I] := Sum / A^[I]^[I]; + end; + end; + + function SV_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + S : PVector; V : PMatrix) : Integer; + label + 1, 2, 3; + var + I, Its, J, JJ, K, L, N : Integer; + Anorm, C, F, G, H, Sum, Scale, T, X, Y, Z : Float; + R : PVector; + begin + G := 0.0; + Scale := 0.0; + Anorm := 0.0; + DimVector(R, Ubound2); + for I := Lbound to Ubound2 do + begin + L := I + 1; + R^[I] := Scale * G; + G := 0.0; + Sum := 0.0; + Scale := 0.0; + if I <= Ubound1 then + begin + for K := I to Ubound1 do + Scale := Scale + Abs(A^[K]^[I]); + if Scale <> 0.0 then + begin + for K := I to Ubound1 do + begin + A^[K]^[I] := A^[K]^[I] / Scale; + Sum := Sum + A^[K]^[I] * A^[K]^[I]; + end; + F := A^[I]^[I]; + G := - Sgn(F) * Sqrt(Sum); + H := F * G - Sum; + A^[I]^[I] := F - G; + if I <> Ubound2 then + begin + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := I to Ubound1 do + Sum := Sum + A^[K]^[I] * A^[K]^[J]; + F := Sum / H; + for K := I to Ubound1 do + A^[K]^[J] := A^[K]^[J] + F * A^[K]^[I]; + end; + end; + for K := I to Ubound1 do + A^[K]^[I] := Scale * A^[K]^[I]; + end; + end; + S^[I] := Scale * G; + G := 0.0; + Sum := 0.0; + Scale := 0.0; + if (I <= Ubound1) and (I <> Ubound2) then + begin + for K := L to Ubound2 do + Scale := Scale + Abs(A^[I]^[K]); + if Scale <> 0.0 then + begin + for K := L to Ubound2 do + begin + A^[I]^[K] := A^[I]^[K] / Scale; + Sum := Sum + A^[I]^[K] * A^[I]^[K]; + end; + F := A^[I]^[L]; + G := - Sgn(F) * Sqrt(Sum); + H := F * G - Sum; + A^[I]^[L] := F - G; + for K := L to Ubound2 do + R^[K] := A^[I]^[K] / H; + if I <> Ubound1 then + for J := L to Ubound1 do + begin + Sum := 0.0; + for K := L to Ubound2 do + Sum := Sum + A^[J]^[K] * A^[I]^[K]; + for K := L to Ubound2 do + A^[J]^[K] := A^[J]^[K] + Sum * R^[K]; + end; + for K := L to Ubound2 do + A^[I]^[K] := Scale * A^[I]^[K]; + end; + end; + Anorm := FMax(Anorm, Abs(S^[I]) + Abs(R^[I])); + end; + for I := Ubound2 downto Lbound do + begin + if I < Ubound2 then + begin + if G <> 0.0 then + begin + for J := L to Ubound2 do + V^[J]^[I] := (A^[I]^[J] / A^[I]^[L]) / G; + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := L to Ubound2 do + Sum := Sum + A^[I]^[K] * V^[K]^[J]; + for K := L to Ubound2 do + V^[K]^[J] := V^[K]^[J] + Sum * V^[K]^[I]; + end; + end; + for J := L to Ubound2 do + begin + V^[I]^[J] := 0.0; + V^[J]^[I] := 0.0; + end; + end; + V^[I]^[I] := 1.0; + G := R^[I]; + L := I; + end; + for I := Ubound2 downto Lbound do + begin + L := I + 1; + G := S^[I]; + if I < Ubound2 then + for J := L to Ubound2 do + A^[I]^[J] := 0.0; + if G <> 0.0 then + begin + G := 1.0 / G; + if I <> Ubound2 then + for J := L to Ubound2 do + begin + Sum := 0.0; + for K := L to Ubound1 do + Sum := Sum + A^[K]^[I] * A^[K]^[J]; + F := (Sum / A^[I]^[I]) * G; + for K := I to Ubound1 do + A^[K]^[J] := A^[K]^[J] + F * A^[K]^[I]; + end; + for J := I to Ubound1 do + A^[J]^[I] := A^[J]^[I] * G; + end + else + for J := I to Ubound1 do + A^[J]^[I] := 0.0; + A^[I]^[I] := A^[I]^[I] + 1.0; + end; + for K := Ubound2 downto Lbound do + begin + for Its := 1 to 30 do + begin + for L := K downto Lbound do + begin + N := L - 1; + if (Abs(R^[L]) + Anorm) = Anorm then goto 2; + if (Abs(S^[N]) + Anorm) = Anorm then goto 1; + end; +1: T := 1.0; + for I := L to K do + begin + F := T * R^[I]; + if (Abs(F) + Anorm) <> Anorm then + begin + G := S^[I]; + H := Pythag(F, G); + S^[I] := H; + H := 1.0 / H; + C := G * H; + T := - (F * H); + for J := Lbound to Ubound1 do + begin + Y := A^[J]^[N]; + Z := A^[J]^[I]; + A^[J]^[N] := (Y * C) + (Z * T); + A^[J]^[I] := - (Y * T) + (Z * C); + end; + end; + end; +2: Z := S^[K]; + if L = K then + begin + if Z < 0.0 then + begin + S^[K] := - Z; + for J := Lbound to Ubound2 do + V^[J]^[K] := - V^[J]^[K]; + end; + goto 3 + end; + if Its = 30 then + begin + DelVector(R, Ubound2); + SV_Decomp := MAT_NON_CONV; + Exit; + end; + X := S^[L]; + N := K - 1; + Y := S^[N]; + G := R^[N]; + H := R^[K]; + F := ((Y - Z) * (Y + Z) + (G - H) * (G + H)) / (2.0 * H * Y); + G := Pythag(F, 1.0); + F := ((X - Z) * (X + Z) + H * ((Y / (F + Sgn(F) * Abs(G))) - H)) / X; + C := 1.0; + T := 1.0; + for J := L to N do + begin + I := J + 1; + G := R^[I]; + Y := S^[I]; + H := T * G; + G := C * G; + Z := Pythag(F, H); + R^[J] := Z; + C := F / Z; + T := H / Z; + F := (X * C) + (G * T); + G := - (X * T) + (G * C); + H := Y * T; + Y := Y * C; + for JJ := Lbound to Ubound2 do + begin + X := V^[JJ]^[J]; + Z := V^[JJ]^[I]; + V^[JJ]^[J] := (X * C) + (Z * T); + V^[JJ]^[I] := - (X * T) + (Z * C); + end; + Z := Pythag(F, H); + S^[J] := Z; + if Z <> 0.0 then + begin + Z := 1.0 / Z; + C := F * Z; + T := H * Z; + end; + F := (C * G) + (T * Y); + X := - (T * G) + (C * Y); + for JJ := Lbound to Ubound1 do + begin + Y := A^[JJ]^[J]; + Z := A^[JJ]^[I]; + A^[JJ]^[J] := (Y * C) + (Z * T); + A^[JJ]^[I] := - (Y * T) + (Z * C); + end + end; + R^[L] := 0.0; + R^[K] := F; + S^[K] := X; + end; +3: + end; + DelVector(R, Ubound2); + SV_Decomp := MAT_OK; + end; + + procedure SV_SetZero(S : PVector; Lbound, Ubound : Integer; Tol : Float); + var + Threshold : Float; + I : Integer; + begin + Threshold := Tol * Max(S, Lbound, Ubound); + for I := Lbound to Ubound do + if S^[I] < Threshold then S^[I] := 0.0; + end; + + procedure SV_Solve(U : PMatrix; S : PVector; V : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); + var + I, J, JJ : Integer; + Sum : Float; + Tmp : PVector; + begin + DimVector(Tmp, Ubound2); + for J := Lbound to Ubound2 do + begin + Sum := 0.0; + if S^[J] > 0.0 then + begin + for I := Lbound to Ubound1 do + Sum := Sum + U^[I]^[J] * B^[I]; + Sum := Sum / S^[J]; + end; + Tmp^[J] := Sum; + end; + for J := Lbound to Ubound2 do + begin + Sum := 0.0; + for JJ := Lbound to Ubound2 do + Sum := Sum + V^[J]^[JJ] * Tmp^[JJ]; + X^[J] := Sum; + end; + DelVector(Tmp, Ubound2); + end; + + procedure SV_Approx(U : PMatrix; S : PVector; V : PMatrix; + Lbound, Ubound1, Ubound2 : Integer; A : PMatrix); + var + I, J, K : Integer; + begin + for I := Lbound to Ubound1 do + for J := Lbound to Ubound2 do + begin + A^[I]^[J] := 0.0; + for K := Lbound to Ubound2 do + if S^[K] > 0.0 then + A^[I]^[J] := A^[I]^[J] + U^[I]^[K] * V^[J]^[K]; + end; + end; + + function QR_Decomp(A : PMatrix; Lbound, Ubound1, Ubound2 : Integer; + R : PMatrix) : Integer; + var + I, J, K : Integer; + Sum : Float; + begin + for K := Lbound to Ubound2 do + begin + { Compute the "k"th diagonal entry in R } + Sum := 0.0; + for I := Lbound to Ubound1 do + Sum := Sum + Sqr(A^[I]^[K]); + + if Sum = 0.0 then + begin + QR_Decomp := MAT_SINGUL; + Exit; + end; + + R^[K]^[K] := Sqrt(Sum); + + { Divide the entries in the "k"th column of A by the computed "k"th } + { diagonal element of R. this begins the process of overwriting A } + { with Q . . . } + for I := Lbound to Ubound1 do + A^[I]^[K] := A^[I]^[K] / R^[K]^[K]; + + for J := (K + 1) to Ubound2 do + begin + { Complete the remainder of the row entries in R } + Sum := 0.0; + for I := Lbound to Ubound1 do + Sum := Sum + A^[I]^[K] * A^[I]^[J]; + R^[K]^[J] := Sum; + + { Update the column entries of the Q/A matrix } + for I := Lbound to Ubound1 do + A^[I]^[J] := A^[I]^[J] - A^[I]^[K] * R^[K]^[J]; + end; + end; + + QR_Decomp := MAT_OK; + end; + + procedure QR_Solve(Q, R : PMatrix; B : PVector; + Lbound, Ubound1, Ubound2 : Integer; + X : PVector); + var + I, J : Integer; + Sum : Float; + begin + { Form Q'B and store the result in X } + for J := Lbound to Ubound2 do + begin + X^[J] := 0.0; + for I := Lbound to Ubound1 do + X^[J] := X^[J] + Q^[I]^[J] * B^[I]; + end; + + { Update X with the solution vector } + X^[Ubound2] := X^[Ubound2] / R^[Ubound2]^[Ubound2]; + for I := (Ubound2 - 1) downto Lbound do + begin + Sum := 0.0; + for J := (I + 1) to Ubound2 do + Sum := Sum + R^[I]^[J] * X^[J]; + X^[I] := (X^[I] - Sum) / R^[I]^[I]; + end; + end; + +end. diff --git a/npm_precl/dmath/Regress.pas b/npm_precl/dmath/Regress.pas new file mode 100755 index 0000000..3ed2bd3 --- /dev/null +++ b/npm_precl/dmath/Regress.pas @@ -0,0 +1,1323 @@ +{ ********************************************************************** + * Unit REGRESS.PAS * + * Version 2.2 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Regression routines + ********************************************************************** } + +unit Regress; + +interface + +uses + FMath, Matrices, Eigen, Optim, SimOpt, Stat,dialogs; + +{ ********************************************************************** + Type definitions + ********************************************************************** } + +{ Algorithm for linear regression } +type + TRegAlgo = ( + GAUSS_JORDAN, { Gauss-Jordan solution of normal equations } + SVD); { Singular value decomposition } + +{ Optimization algorithm for nonlinear regression } +type + TOptAlgo = ( + NL_MARQ, { Marquardt algorithm } + NL_SIMP, { Simplex algorithm } + NL_BFGS, { BFGS algorithm } + NL_SA); { Simulated annealing } + +{ Regression modes } +type + TRegMode = (UNWEIGHTED, WEIGHTED); + +{ Regression function } +type + TRegFunc = function(X : Float; B : PVector) : Float; + +{ Procedure to compute the derivatives of the regression function + with respect to the regression parameters } +type + TDerivProc = procedure(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + +{ Test of regression } +type + TRegTest = record + Vr, { Residual variance } + R2, { Coefficient of determination } + R2a, { Adjusted coeff. of determination } + F, { Variance ratio (explained/residual) } + Prob : Float; { Probability of F } + end; + +{ ********************************************************************** + Procedures to modify the regression settings + ********************************************************************** } + +procedure SetRegAlgo(Algo : TRegAlgo); +{ ---------------------------------------------------------------------- + Sets the linear regression algorithm according to Algo, which must be + GAUSS_JORDAN or SVD. The default algorithm is SVD. + ---------------------------------------------------------------------- } + +procedure SetOptAlgo(Algo : TOptAlgo); +{ ---------------------------------------------------------------------- + Sets the optimization algorithm according to Algo, which must be + NL_MARQ, NL_SIMP, NL_BFGS or NL_SA. The default algorithm is NL_MARQ. + ---------------------------------------------------------------------- } + +procedure SetFirstPoint(Index : Integer); +{ ---------------------------------------------------------------------- + Sets the index of the first data point (usually 0 or 1). The default + value is 1. + ---------------------------------------------------------------------- } + +function GetRegAlgo : TRegAlgo; +{ ---------------------------------------------------------------------- + Returns the linear regression algorithm + ---------------------------------------------------------------------- } + +function GetOptAlgo : TOptAlgo; +{ ---------------------------------------------------------------------- + Returns the optimization algorithm + ---------------------------------------------------------------------- } + +function GetFirstPoint : Integer; +{ ---------------------------------------------------------------------- + Returns the index of the first data point + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Unweighted regression routines + ********************************************************************** + These routines fit equations to data by minimizing the sum of squared + residuals : + SS = Sum [y(k) - ycalc(k)]^2 + + where y(k) and ycalc(k) are respectively the observed and calculated + value of the dependent variable for observation k. ycalc(k) is a + function of the regression parameters b(0), b(1) ... + + The following regression types are implemented : + + * Simple linear regression : + + y(k) = b(0) + b(1) * x(k) + + * Multiple linear regression : + + y(k) = b(0) + b(1) * x(1,k) + b(2) * x(2,k) + ... + b(Nvar) * x(Nvar,k) + + * Polynomial regression : + + y(k) = b(0) + b(1) * x(k) + b(2) * x(k)^2 + ... + b(Deg) * x(k)^Deg + + * Nonlinear regression : + + y(k) = f[x(k), b(0), b(1), ... ] + + where f is a user-specified function. + + The following parameters are common to all routines : + + Input : X = Vector or matrix of independent variables + Y = Vector of dependent variable + N = Index of the last observation + Output : B = Regression parameters + V = Inverse matrix of normal equations + ********************************************************************** } + +function LinFit(X, Y : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Simple linear regression + ---------------------------------------------------------------------- } + +function MulFit(X : PMatrix; Y : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Multiple linear regression + ---------------------------------------------------------------------- + Additional input parameters : + Nvar = Index of the last independent variable + ConsTerm = Flags the presence of a constant term b(0) + ---------------------------------------------------------------------- } + +function PolFit(X, Y : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Polynomial regression + ---------------------------------------------------------------------- + Additional input parameter : + Deg = Degree of polynomial + ---------------------------------------------------------------------- } + +function NLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Nonlinear regression + ---------------------------------------------------------------------- + Additional input parameters : + RegFunc = Regression function + DerivProc = Procedure to compute the derivatives of RegFunc + Lbound, Ubound = Indices of first and last function parameters + MaxIter = Maximum number of iterations + Tol = Required parameter precision + B = Initial parameter values + B_min, B_max = Lower and upper parameter bounds + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Weighted regression routines + ********************************************************************** + These routines fit equations to data by minimizing the sum of weighted + squared residuals : + + SWS = Sum w(k)*[y(k) - ycalc(k)]^2 + + where the "weight" w(k) is inversely proportional to the variance v(k) + of the observation y(k). v(k) is usually computed as : + + v(k) = Vr * g[y(k)] = Vr / w(k) + + where Vr is the residual variance and g is a user-specified function + (e.g. g[y(k)] = y(k)^2 for a constant coefficient of variation). + + Function syntax and results are the same than for unweighted regression + except that the vector of weights (W) is passed as an additional input + parameter. + ********************************************************************** } + +function WLinFit(X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + +function WMulFit(X : PMatrix; Y, W : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + +function WPolFit(X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + +function WNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y, W : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + +{ ********************************************************************** + Procedure to compute the derivatives of the regression function by + numerical differentiation. + ********************************************************************** } + +procedure NumDeriv(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); +{ ---------------------------------------------------------------------- + Input parameters : RegFunc = Regression function + X, Y = Coordinates of point + B = Regression parameters + + Output parameter : D = Derivatives (D^[I] contains the + derivative w.r.t. parameter B^[I]) + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Routines to test the quality of the regression + ********************************************************************** + These routines compute the variance-covariance matrix of the fitted + parameters and the different statistics used to test the quality of + the fit. + + Input parameters : Y = Vector of dependent variable + Ycalc = Computed Y values + W = Vector of weights (if any) + N = Index of the last observation + Lbound, + Ubound = Indices of first & last fitted parameters + V = Inverse normal equations matrix + + Output parameters : V = Variance-covariance matrix + Test = Test statistics (Vr, R2, R2a, F, Prob) + ********************************************************************** } + +procedure RegTest(Y, Ycalc : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); +{ ---------------------------------------------------------------------- + Test of unweighted regression + ---------------------------------------------------------------------- } + +procedure WRegTest(Y, Ycalc, W : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); +{ ---------------------------------------------------------------------- + Test of weighted regression + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Test of regression parameters + ********************************************************************** } + +procedure ParamTest(B : PVector; V : PMatrix; N, Lbound, Ubound : Integer; + S, T, Prob : PVector); +{ ---------------------------------------------------------------------- + This routine tests the significance of the parameters. It must be + called AFTER RegTest or WRegTest since it uses the variance-covariance + matrix. + ---------------------------------------------------------------------- + Input parameters : B = Regression parameters + V = Variance-covariance matrix + N = Index of the last observation + Lbound, + Ubound = Indices of first & last fitted parameters + ---------------------------------------------------------------------- + Output parameters : S = Standard deviations of parameters + T = Student's t + Prob = Probabilities + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Correlation and principal component analysis + + Common parameters: + + X = matrix of variables (X^[I] contains the I-th variable) + N = Index of the last observation + Lbound, Ubound = Indices of first & last variables + M = Mean vector (M^[I] = mean of X^[I]) + S = Vector of standard deviations + V = Variance-covariance matrix + R = Correlation matrix + ********************************************************************** } + +procedure VecMean(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector); +{ ---------------------------------------------------------------------- + Computes the mean vector (M) from matrix X + + Input : X, Lbound, Ubound + Output : M + ---------------------------------------------------------------------- } + +procedure VecSD(X : PMatrix; N, Lbound, Ubound : Integer; M, S : PVector); +{ ---------------------------------------------------------------------- + Computes the vector of standard deviations (S) from matrix X + + Input : X, Lbound, Ubound, M + Output : S + ---------------------------------------------------------------------- } + +procedure MatVarCov(X : PMatrix; N, Lbound, Ubound : Integer; + M : PVector; V : PMatrix); +{ ---------------------------------------------------------------------- + Computes the variance-covariance matrix (V) from matrix X + + Input : X, Lbound, Ubound, M + Output : V + ---------------------------------------------------------------------- } + +procedure MatCorrel(V : PMatrix; Lbound, Ubound : Integer; R : PMatrix); +{ ---------------------------------------------------------------------- + Computes the correlation matrix (R) from the variance-covariance + matrix (V) + + Input : V, Lbound, Ubound + Output : R + ---------------------------------------------------------------------- } + +function PCA(R : PMatrix; Lbound, Ubound : Integer; + Lambda : PVector; C, Rc : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Performs a principal component analysis of the correlation matrix R + ---------------------------------------------------------------------- + Input : R, Lbound, Ubound + Output : Lambda = Eigenvalues of the correlation matrix + (in descending order) + C = Eigenvectors of the correlation matrix + (C^[I] is the I-th eigenvector) + Rc = Correlations between principal factors and variables + (R^[I]^[J] is the correlation coefficient between + factor I and variable J) + ---------------------------------------------------------------------- + Possible results : MAT_OK : No error + MAT_NON_CONV : Non-convergence of eigenvalue + determination + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix R + ---------------------------------------------------------------------- } + +procedure ScaleVar(X : PMatrix; N, Lbound, Ubound : Integer; + M, S : PVector; Z : PMatrix); +{ ---------------------------------------------------------------------- + Scales a set of variables by subtracting means and dividing by SD's + ---------------------------------------------------------------------- + Input : X, N, Lbound, Ubound, M, S + Output : Z = matrix of scaled variables (Z^[I] contains the I-th var.) + ---------------------------------------------------------------------- } + +procedure PrinFac(Z : PMatrix; N, Lbound, Ubound : Integer; C, F : PMatrix); +{ ---------------------------------------------------------------------- + Computes principal factors + ---------------------------------------------------------------------- + Input : Z, N, Lbound, Ubound + C = matrix of eigenvectors from PCA + Output : F = matrix of principal factors (F^[I] contains the I-th factor) + ---------------------------------------------------------------------- } + +implementation + +{ Constants for eigenvalue determination in PCA } +const + PCA_MAXITER = 100; { Max number of iterations } + PCA_TOL = 1.0E-6; { Required precision } + MAX_FUNC = 1.0E+30; { Max. value for objective function + (used to prevent overflow) } +{ Default settings } +const + RegAlgo : TRegAlgo = SVD; { Linear regression algorithm } + OptAlgo : TOptAlgo = NL_MARQ; { Optimization algorithms } + FirstPoint : Integer = 1; { Index of first data point } + +{ Global variables used by the nonlinear regression routines } +const + NN : Integer = 1; { Number of observations } + XX : PVector = nil; { X coordinates } + YY : PVector = nil; { Y coordinates } + WW : PVector = nil; { Weights } + YYcalc : PVector = nil; { Estimated Y values } + FirstParam : Integer = 0; { Index of first fitted parameter } + LastParam : Integer = 1; { Index of last fitted parameter } + ParamMin : PVector = nil; { Lower bounds on parameters } + ParamMax : PVector = nil; { Higher bounds on parameters } + +var + RegFunc1 : TRegFunc; { Regression function } + DerivProc1 : TDerivProc; { Derivation procedure } + + function TolSVD(N : Integer) : Float; + { This function sets the relative threshold below which a singular value + is considered zero. N is the number of observations. } + begin + TolSVD := N * MACHEP; + end; + + procedure SetRegAlgo(Algo : TRegAlgo); + begin + RegAlgo := Algo; + end; + + procedure SetOptAlgo(Algo : TOptAlgo); + begin + OptAlgo := Algo; + end; + + procedure SetFirstPoint(Index : Integer); + begin + if Index >= 0 then + FirstPoint := Index; + end; + + function GetRegAlgo : TRegAlgo; + begin + GetRegAlgo := RegAlgo; + end; + + function GetOptAlgo : TOptAlgo; + begin + GetOptAlgo := OptAlgo; + end; + + function GetFirstPoint : Integer; + begin + GetFirstPoint := FirstPoint; + end; + + function GenLinFit(Mode : TRegMode; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General linear regression routine + ---------------------------------------------------------------------- } + var + WX, S, SX, SY, SX2, SXY, D : Float; + K : Integer; + begin + S := 0.0; + SX := 0.0; + SY := 0.0; + SX2 := 0.0; + SXY := 0.0; + if Mode = UNWEIGHTED then + begin + S := N - FirstPoint + 1; + for K := FirstPoint to N do + begin + SX := SX + X^[K]; + SY := SY + Y^[K]; + SX2 := SX2 + Sqr(X^[K]); + SXY := SXY + X^[K] * Y^[K]; + end; + end + else + begin + for K := FirstPoint to N do + begin + WX := W^[K] * X^[K]; + S := S + W^[K]; + SX := SX + WX; + SY := SY + W^[K] * Y^[K]; + SX2 := SX2 + WX * X^[K]; + SXY := SXY + WX * Y^[K]; + end; + end; + D := S * SX2 - Sqr(SX); + if D <= 0.0 then + GenLinFit := MAT_SINGUL + else + begin + V^[0]^[0] := SX2 / D; + V^[0]^[1] := - SX / D; + V^[1]^[0] := V^[0]^[1]; + V^[1]^[1] := S / D; + B^[0] := V^[0]^[0] * SY + V^[0]^[1] * SXY; + B^[1] := V^[1]^[0] * SY + V^[1]^[1] * SXY; + GenLinFit := MAT_OK; + end; + end; + + function LinFit(X, Y : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + LinFit := GenLinFit(UNWEIGHTED, X, Y, W, N, B, V); + end; + + function WLinFit(X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + begin + WLinFit := GenLinFit(WEIGHTED, X, Y, W, N, B, V); + end; + + function Gauss_GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine (Gauss-Jordan algorithm) + ---------------------------------------------------------------------- } + var + A : PMatrix; { Matrix of normal equations } + G : PVector; { Constant vector } + I, J, K : Integer; { Loop variables } + WX : Float; + begin + DimMatrix(A, Nvar, Nvar); + DimVector(G, Nvar); + + { If constant term, set line 0 and column 0 of matrix A, + and element 0 of vecteur G } + if ConsTerm then + begin + if Mode = UNWEIGHTED then + begin + A^[0]^[0] := Int(N - FirstPoint + 1); + for K := FirstPoint to N do + begin + for J := 1 to Nvar do + A^[0]^[J] := A^[0]^[J] + X^[J]^[K]; + G^[0] := G^[0] + Y^[K]; + end; + end + else + begin + for K := FirstPoint to N do + begin + A^[0]^[0] := A^[0]^[0] + W^[K]; + for J := 1 to Nvar do + A^[0]^[J] := A^[0]^[J] + W^[K] * X^[J]^[K]; + G^[0] := G^[0] + W^[K] * Y^[K]; + end; + end; + for J := 1 to Nvar do + A^[J]^[0] := A^[0]^[J]; + end; + + { Set other elements of A and G } + if Mode = UNWEIGHTED then + for K := FirstPoint to N do + for I := 1 to Nvar do + begin + for J := I to Nvar do + A^[I]^[J] := A^[I]^[J] + X^[I]^[K] * X^[J]^[K]; + G^[I] := G^[I] + X^[I]^[K] * Y^[K]; + end + else + for K := FirstPoint to N do + for I := 1 to Nvar do + begin + WX := W^[K] * X^[I]^[K]; + for J := I to Nvar do + A^[I]^[J] := A^[I]^[J] + WX * X^[J]^[K]; + G^[I] := G^[I] + WX * Y^[K]; + end; + + { Fill in symmetric matrix } + for I := 2 to Nvar do + for J := 1 to Pred(I) do + A^[I]^[J] := A^[J]^[I]; + + { Solve normal equations } + if ConsTerm then + Gauss_GenMulFit := GaussJordan(A, G, 0, Nvar, V, B) + else + Gauss_GenMulFit := GaussJordan(A, G, 1, Nvar, V, B); + + DelMatrix(A, Nvar, Nvar); + DelVector(G, Nvar); + end; + + function SVD_GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine (SVD algorithm) + ---------------------------------------------------------------------- } + var + U : PMatrix; { Matrix of independent variables for SVD } + Z : PVector; { Vector of dependent variables for SVD } + S : PVector; { Singular values } + S2inv : PVector; { Inverses of squared singular values } + V1 : PMatrix; { Orthogonal matrix from SVD } + Lbound : Integer; { Lower bound of U matrix in both dims. } + Ubound : Integer; { Upper bound of U matrix in 1st dim. } + I, J, K : Integer; { Loop variables } + Sigma : Float; { Square root of weight } + Sum : Float; { Element of variance-covariance matrix } + ErrCode : Integer; { Error code } + begin + if ConsTerm then + begin + Lbound := 0; + Ubound := N - FirstPoint; + end + else + begin + Lbound := 1; + Ubound := N - FirstPoint + 1; + end; + + { Dimension arrays } + DimMatrix(U, Ubound, Nvar); + DimVector(Z, Ubound); + DimVector(S, Nvar); + DimVector(S2inv, Nvar); + DimMatrix(V1, Nvar, Nvar); + + { ---------------------------------------------------------- + Prepare arrays for SVD : + If constant term, use U[0..(N - FirstPoint), 0..Nvar] + and Z[0..(N - FirstPoint)] + Else use U[1..(N - FirstPoint + 1), 1..Nvar] + and Z[1..(N - FirstPoint + 1)] + ---------------------------------------------------------- } + if Mode = UNWEIGHTED then + for I := Lbound to Ubound do + begin + K := I - Lbound + FirstPoint; + Z^[I] := Y^[K]; + if ConsTerm then + U^[I]^[0] := 1.0; + for J := 1 to Nvar do + U^[I]^[J] := X^[J]^[K]; + end + else + for I := Lbound to Ubound do + begin + K := I - Lbound + FirstPoint; + Sigma := Sqrt(W^[K]); + Z^[I] := Y^[K] * Sigma; + if ConsTerm then + U^[I]^[0] := Sigma; + for J := 1 to Nvar do + U^[I]^[J] := X^[J]^[K] * Sigma; + end; + + { Perform singular value decomposition } + ErrCode := SV_Decomp(U, Lbound, Ubound, Nvar, S, V1); + + if ErrCode = MAT_OK then + begin + { Set the lowest singular values to zero } + SV_SetZero(S, Lbound, Nvar, TolSVD(N - FirstPoint + 1)); + + { Solve the system } + SV_Solve(U, S, V1, Z, Lbound, Ubound, Nvar, B); + + { Compute variance-covariance matrix } + for I := Lbound to Nvar do + if S^[I] > 0.0 then + S2inv^[I] := 1.0 / Sqr(S^[I]) + else + S2inv^[I] := 0.0; + for I := Lbound to Nvar do + for J := Lbound to I do + begin + Sum := 0.0; + for K := Lbound to Nvar do + Sum := Sum + V1^[I]^[K] * V1^[J]^[K] * S2inv^[K]; + V^[I]^[J] := Sum; + V^[J]^[I] := Sum; + end; + end; + + SVD_GenMulFit := ErrCode; + + DelMatrix(U, Ubound, Nvar); + DelVector(Z, Ubound); + DelVector(S, Nvar); + DelVector(S2inv, Nvar); + DelMatrix(V1, Nvar, Nvar); + end; + + function GenMulFit(Mode : TRegMode; X : PMatrix; Y, W : PVector; + N, Nvar : Integer; ConsTerm : Boolean; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General multiple linear regression routine + ---------------------------------------------------------------------- } + begin + case RegAlgo of + GAUSS_JORDAN : GenMulFit := Gauss_GenMulFit(Mode, X, Y, W, N, Nvar, + ConsTerm, B, V); + SVD : GenMulFit := SVD_GenMulFit(Mode, X, Y, W, N, Nvar, + ConsTerm, B, V); + end; + end; + + function MulFit(X : PMatrix; Y : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + MulFit := GenMulFit(UNWEIGHTED, X, Y, W, N, Nvar, ConsTerm, B, V); + end; + + function WMulFit(X : PMatrix; Y, W : PVector; N, Nvar : Integer; + ConsTerm : Boolean; B : PVector; V : PMatrix) : Integer; + begin + WMulFit := GenMulFit(WEIGHTED, X, Y, W, N, Nvar, ConsTerm, B, V); + end; + + procedure PowMat(X : PVector; N, Deg : Integer; U : PMatrix); +{ ---------------------------------------------------------------------- + Computes matrix of increasing powers of X for polynomial regression + ---------------------------------------------------------------------- } + var + I, K : Integer; + begin + for K := FirstPoint to N do + begin + U^[1]^[K] := X^[K]; + for I := 2 to Deg do + U^[I]^[K] := U^[I - 1]^[K] * X^[K]; + end; + end; + + function GenPolFit(Mode : TRegMode; X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + General polynomial regression routine + ---------------------------------------------------------------------- } + var + U : PMatrix; + begin + DimMatrix(U, Deg, N); + PowMat(X, N, Deg, U); + GenPolFit := GenMulFit(Mode, U, Y, W, N, Deg, True, B, V); + DelMatrix(U, Deg, N); + end; + + function PolFit(X, Y : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + PolFit := GenPolFit(UNWEIGHTED, X, Y, W, N, Deg, B, V); + end; + + function WPolFit(X, Y, W : PVector; N, Deg : Integer; + B : PVector; V : PMatrix) : Integer; + begin + WPolFit := GenPolFit(WEIGHTED, X, Y, W, N, Deg, B, V); + end; + + procedure SetGlobalVar(RegFunc : TRegFunc; DerivProc : TDerivProc; + Mode : TRegMode; X, Y, W : PVector; + N, Lbound, Ubound : Integer; + B_min, B_max : PVector); + { Sets the global variables used by the nonlinear regression routines } + begin + DelVector(XX, NN); + DelVector(YY, NN); + DelVector(YYcalc, NN); + + DimVector(XX, N); + DimVector(YY, N); + DimVector(YYcalc, N); + + CopyVector(XX, X, FirstPoint, N); + CopyVector(YY, Y, FirstPoint, N); + + if Mode = WEIGHTED then + begin + DelVector(WW, NN); + DimVector(WW, N); + CopyVector(WW, W, FirstPoint, N); + end; + + NN := N; + + DelVector(ParamMin, LastParam); + DelVector(ParamMax, LastParam); + + DimVector(ParamMin, Ubound); + DimVector(ParamMax, Ubound); + + CopyVector(ParamMin, B_min, Lbound, Ubound); + CopyVector(ParamMax, B_max, Lbound, Ubound); + + FirstParam := Lbound; + LastParam := Ubound; + + RegFunc1 := RegFunc; + DerivProc1 := DerivProc; + end; + + {$F+} + + procedure NumDeriv(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + var + I : Integer; + Eps, Temp, Y1 : Float; + begin + Eps := Sqrt(MACHEP); + for I := FirstParam to LastParam do + begin + Temp := B^[I]; { Save parameter } + B^[I] := B^[I] + Eps * Abs(B^[I]); { Modified parameter } + Y1 := RegFunc(X, B); + D^[I] := (Y1 - Y) / (B^[I] - Temp); { Derivative } + B^[I] := Temp; { Restore parameter } + end; + end; + + function OutOfBounds(B, B_min, B_max : PVector) : Boolean; + { Check if the parameters are inside the bounds } + var + I : Integer; + OoB : Boolean; + begin + I := FirstParam; + OoB := False; + repeat + OoB := (B^[I] < B_min^[I]) or (B^[I] > B_max^[I]); + Inc(I); + until OoB or (I > LastParam); + OutOfBounds := OoB; + end; + + function OLS_ObjFunc(B : PVector) : Float; + { Objective function for unweighted nonlinear regression } + var + K : Integer; + S : Float; + begin + if OutOfBounds(B, ParamMin, ParamMax) then + begin + OLS_ObjFunc := MAX_FUNC; + Exit; + end; + S := 0.0; + K := FirstPoint; + repeat + YYcalc^[K] := RegFunc1(XX^[K], B); + S := S + Sqr(YY^[K] - YYcalc^[K]); + Inc(K); + until (K > NN) or (S > MAX_FUNC); + if S > MAX_FUNC then S := MAX_FUNC; + OLS_ObjFunc := S; + end; + + procedure OLS_Gradient(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; G : PVector); + { Gradient for unweighted nonlinear regression. + Func is a dummy parameter here. } + var + I, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + G^[I] := 0.0; + + { Compute Gradient } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + G^[I] := G^[I] - D^[I] * R; + end; + + for I := Lbound to Ubound do + G^[I] := 2.0 * G^[I]; + + DelVector(D, Ubound); + end; + + procedure OLS_HessGrad(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; + G : PVector; H : PMatrix); + { Gradient and Hessian for unweighted nonlinear regression. + Func is a dummy parameter here. } + var + I, J, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + begin + DimVector(D, Ubound); + + { Initializations } + for I := Lbound to Ubound do + begin + G^[I] := 0.0; + for J := I to Ubound do + H^[I]^[J] := 0.0; + end; + + { Compute Gradient & Hessian } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + G^[I] := G^[I] - D^[I] * R; + for J := I to Ubound do + H^[I]^[J] := H^[I]^[J] + D^[I] * D^[J]; + end; + end; + + { Fill in symmetric matrix } + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + H^[I]^[J] := H^[J]^[I]; + + DelVector(D, Ubound); + end; + + function WLS_ObjFunc(B : PVector) : Float; + { Objective function for weighted nonlinear regression } + var + K : Integer; + S : Float; + begin + if OutOfBounds(B, ParamMin, ParamMax) then + begin + WLS_ObjFunc := MAX_FUNC; + Exit; + end; + S := 0.0; + K := FirstPoint; + repeat + YYcalc^[K] := RegFunc1(XX^[K], B); + S := S + WW^[K] * Sqr(YY^[K] - YYcalc^[K]); + Inc(K); + until (K > NN) or (S > MAX_FUNC); + if S > MAX_FUNC then S := MAX_FUNC; + WLS_ObjFunc := S; + end; + + procedure WLS_Gradient(Func : TFuncNVar; B : PVector; + Lbound, Ubound : Integer; G : PVector); + { Gradient for weighted nonlinear regression. + Func is a dummy parameter here. } + var + I, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + WD : Float; { Weighted derivative } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + G^[I] := 0.0; + + { Compute Gradient } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + WD := WW^[K] * D^[I]; + G^[I] := G^[I] - WD * R; + end; + end; + + for I := Lbound to Ubound do + G^[I] := 2.0 * G^[I]; + + DelVector(D, Ubound); + end; + + procedure WLS_HessGrad(Func: TFuncNVar; B : PVector; + Lbound, Ubound : Integer; + G : PVector; H : PMatrix); + { Gradient and Hessian for weighted nonlinear regression. + Func is a dummy parameter here. } + var + I, J, K : Integer; { Loop variables } + R : Float; { Residual } + D : PVector; { Derivatives of the regression function } + WD : Float; { Weighted derivative } + begin + DimVector(D, Ubound); + + { Initialization } + for I := Lbound to Ubound do + begin + G^[I] := 0.0; + for J := I to Ubound do + H^[I]^[J] := 0.0; + end; + + { Compute Gradient & Hessian } + for K := FirstPoint to NN do + begin + R := YY^[K] - YYcalc^[K]; + DerivProc1(RegFunc1, XX^[K], YYcalc^[K], B, D); + for I := Lbound to Ubound do + begin + WD := WW^[K] * D^[I]; + G^[I] := G^[I] - WD * R; + for J := I to Ubound do + H^[I]^[J] := H^[I]^[J] + WD * D^[J]; + end; + end; + + { Fill in symmetric matrix } + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + H^[I]^[J] := H^[J]^[I]; + DelVector(D, Ubound); + end; + + {$F-} + + function GenNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + Mode : TRegMode; X, Y, W : PVector; + N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; + V : PMatrix) : Integer; + { -------------------------------------------------------------------- + General nonlinear regression routine + -------------------------------------------------------------------- } + var + F_min : Float; { Value of objective function at minimum } + ErrCode : Integer; { Error code } + G : PVector; { Gradient vector } + H : PMatrix; { Hessian matrix } + ObjFunc : TFuncNVar; { Objective function } + GradProc : TGradient; { Procedure to compute gradient } + HessProc : THessGrad; { Procedure to compute gradient and hessian } + begin + SetGlobalVar(RegFunc, DerivProc, Mode, X, Y, W, + N, Lbound, Ubound, B_min, B_max); + + case Mode of + UNWEIGHTED : begin + ObjFunc := {$IFDEF FPK}@{$ENDIF}OLS_ObjFunc; + GradProc := {$IFDEF FPK}@{$ENDIF}OLS_Gradient; + HessProc := {$IFDEF FPK}@{$ENDIF}OLS_HessGrad; + end; + WEIGHTED : begin + ObjFunc := {$IFDEF FPK}@{$ENDIF}WLS_ObjFunc; + GradProc := {$IFDEF FPK}@{$ENDIF}WLS_Gradient; + HessProc := {$IFDEF FPK}@{$ENDIF}WLS_HessGrad; + end; + end; + + case OptAlgo of + NL_MARQ : ErrCode := Marquardt(ObjFunc, HessProc, B, Lbound, Ubound, + MaxIter, Tol, F_min, V); + NL_SIMP : ErrCode := Simplex(ObjFunc, B, Lbound, Ubound, + MaxIter, Tol, F_min); + NL_BFGS : ErrCode := BFGS(ObjFunc, GradProc, B, Lbound, Ubound, + MaxIter, Tol, F_min, V); + NL_SA : ErrCode := SimAnn(ObjFunc, B, B_min, B_max, Lbound, Ubound, + MaxIter, Tol, F_min); + end; + + if (OptAlgo <> NL_MARQ) and (OptAlgo <> NL_BFGS) and (ErrCode = OPT_OK) then + begin + { Compute the Hessian matrix and its inverse } + DimVector(G, Ubound); + DimMatrix(H, Ubound, Ubound); + case Mode of + UNWEIGHTED : OLS_HessGrad(ObjFunc, B, Lbound, Ubound, G, H); + WEIGHTED : WLS_HessGrad(ObjFunc, B, Lbound, Ubound, G, H); + end; + if InvMat(H, Lbound, Ubound, V) = 0 then + ErrCode := OPT_OK + else + ErrCode := OPT_SING; + DelVector(G, Ubound); + DelMatrix(H, Ubound, Ubound); + end; + + GenNLFit := ErrCode; + end; + + function NLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + var + W : PVector; + begin + NLFit := GenNLFit(RegFunc, DerivProc, UNWEIGHTED, X, Y, W, N, + Lbound, Ubound, MaxIter, Tol, B, B_min, B_max, V); + end; + + function WNLFit(RegFunc : TRegFunc; DerivProc : TDerivProc; + X, Y, W : PVector; N, Lbound, Ubound, MaxIter : Integer; + Tol : Float; B, B_min, B_max : PVector; V : PMatrix) : Integer; + begin + WNLFit := GenNLFit(RegFunc, DerivProc, WEIGHTED, X, Y, W, N, + Lbound, Ubound, MaxIter, Tol, B, B_min, B_max, V); + end; + + procedure GenRegTest(Mode : TRegMode; Y, Ycalc, W : PVector; + N, Lbound, Ubound : Integer; V : PMatrix; + var Test : TRegTest); + var + Ybar : Float; { Average Y value } + SSt : Float; { Total sum of squares } + SSe : Float; { Explained sum of squares } + SSr : Float; { Residual sum of squares } + Nobs : Integer; { Number of observations } + Npar : Integer; { Number of fitted parameters } + Nu1, Nu2 : Integer; { Degrees of freedom } + I, J : Integer; { Loop variables } + begin + Nobs := N - FirstPoint + 1; + Npar := Ubound - Lbound + 1; + with Test do + if Nobs > Npar then + begin + Ybar := Average(Y, FirstPoint, N); + if Mode = UNWEIGHTED then + begin + SSt := SumSqrDif(Y, FirstPoint, N, Ybar); + SSe := SumSqrDif(Ycalc, FirstPoint, N, Ybar); + SSr := SumSqrDifVect(Y, Ycalc, FirstPoint, N); + end + else + begin + SSt := SumWSqrDif(Y, W, FirstPoint, N, Ybar); + SSe := SumWSqrDif(Ycalc, W, FirstPoint, N, Ybar); + SSr := SumWSqrDifVect(Y, Ycalc, W, FirstPoint, N); + end; + Nu1 := Npar - 1; + Nu2 := Nobs - Npar; + if (SSt = 0) or (Nu2=0) then begin + //showmessage('Error: are all you data points in the same plane?'); + exit; + end; + R2 := SSe / SSt; + R2a := 1.0 - (1.0 - R2) * (Nobs - 1) / Nu2; + Vr := SSr / Nu2; + if (Vr > 0.0) and (Nu1 > 0.0) then + begin + F := (SSe / Nu1) / Vr; + Prob := PSnedecor(Nu1, Nu2, F); + end + else + begin + F := MAXNUM; + Prob := 0.0; + end; + end + else + begin + Vr := 0.0; + R2 := 1.0; + R2a := 0.0; + F := 0.0; + Prob := 1.0; + end; + + { Compute variance-covariance matrix } + for I := Lbound to Ubound do + for J := I to Ubound do + V^[I]^[J] := V^[I]^[J] * Test.Vr; + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + end; + + procedure RegTest(Y, Ycalc : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); + var + W : PVector; + begin + GenRegTest(UNWEIGHTED, Y, Ycalc, W, N, Lbound, Ubound, V, Test); + end; + + procedure WRegTest(Y, Ycalc, W : PVector; N, Lbound, Ubound : Integer; + V : PMatrix; var Test : TRegTest); + begin + GenRegTest(WEIGHTED, Y, Ycalc, W, N, Lbound, Ubound, V, Test); + end; + + procedure ParamTest(B : PVector; V : PMatrix; N, Lbound, Ubound : Integer; + S, T, Prob : PVector); + var + I : Integer; + Nu : Integer; { Degrees of freedom } + Nobs : Integer; { Number of observations } + Nvar : Integer; { Number of indep. variables } + begin + Nobs := N - FirstPoint + 1; + Nvar := Ubound - Lbound + 1; + Nu := Nobs - Nvar; { DoF = Nb points - Nb parameters } + for I := Lbound to Ubound do + if V^[I]^[I] > 0.0 then + begin + S^[I] := Sqrt(V^[I]^[I]); + T^[I] := B^[I] / S^[I]; + Prob^[I] := PStudent(Nu, T^[I]); + end + else + begin + S^[I] := 0.0; + T^[I] := 0.0; + Prob^[I] := 1.0; + end; + end; + + procedure VecMean(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector); + var + I, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + X^[I]^[K]; + M^[I] := Sum / Nobs; + end; + end; + + procedure VecSD(X : PMatrix; N, Lbound, Ubound : Integer; M, S : PVector); + var + I, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + Sqr(X^[I]^[K] - M^[I]); + S^[I] := Sqrt(Sum / Nobs); + end; + end; + + procedure MatVarCov(X : PMatrix; N, Lbound, Ubound : Integer; M : PVector; V : PMatrix); + var + I, J, K, Nobs : Integer; + Sum : Float; + begin + Nobs := N - FirstPoint + 1; + for I := Lbound to Ubound do + for J := I to Ubound do + begin + Sum := 0.0; + for K := FirstPoint to N do + Sum := Sum + (X^[I]^[K] - M^[I]) * (X^[J]^[K] - M^[J]); + V^[I]^[J] := Sum / Nobs; + end; + for I := Succ(Lbound) to Ubound do + for J := Lbound to Pred(I) do + V^[I]^[J] := V^[J]^[I]; + end; + + procedure MatCorrel(V : PMatrix; Lbound, Ubound : Integer; R : PMatrix); + var + I, J : Integer; + begin + for I := Lbound to Ubound do + begin + R^[I]^[I] := 1.0; + for J := Succ(I) to Ubound do + begin + R^[I]^[J] := V^[I]^[J] / Sqrt(V^[I]^[I] * V^[J]^[J]); + R^[J]^[I] := R^[I]^[J]; + end; + end; + end; + + function PCA(R : PMatrix; Lbound, Ubound : Integer; + Lambda : PVector; C, Rc : PMatrix) : Integer; + var + I, J, ErrCode : Integer; + Rac : Float; + begin + { Compute eigenvalues and eigenvectors of correlation matrix } + ErrCode := Jacobi(R, Lbound, Ubound, PCA_MAXITER, PCA_TOL, C, Lambda); + + if ErrCode <> 0 then + begin + PCA := ErrCode; + Exit; + end; + + { Compute correlations between principal factors and reduced variables } + for I := Lbound to Ubound do + begin + Rac := Sqrt(Lambda^[I]); + for J := Lbound to Ubound do + Rc^[I]^[J] := C^[I]^[J] * Rac; + end; + + PCA := ErrCode; + end; + + procedure ScaleVar(X : PMatrix; N, Lbound, Ubound : Integer; + M, S : PVector; Z : PMatrix); + var + I, K : Integer; + begin + for I := Lbound to Ubound do + for K := FirstPoint to N do + Z^[I]^[K] := (X^[I]^[K] - M^[I]) / S^[I]; + end; + + procedure PrinFac(Z : PMatrix; N, Lbound, Ubound : Integer; + C, F : PMatrix); + var + I, J, K : Integer; + begin + for I := Lbound to Ubound do + for K := FirstPoint to N do + begin + F^[I]^[K] := 0.0; + for J := Lbound to Ubound do + F^[I]^[K] := F^[I]^[K] + C^[I]^[J] * Z^[J]^[K]; + end; + end; + +end. diff --git a/npm_precl/dmath/_clean.bat b/npm_precl/dmath/_clean.bat new file mode 100755 index 0000000..f4eb821 --- /dev/null +++ b/npm_precl/dmath/_clean.bat @@ -0,0 +1,10 @@ +del /S *.~* +del /S *.dcu +del /S *.dsk +del /S *.cfg +del /S *.dof +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt diff --git a/npm_precl/dmath/eigen.pas b/npm_precl/dmath/eigen.pas new file mode 100755 index 0000000..0de4df1 --- /dev/null +++ b/npm_precl/dmath/eigen.pas @@ -0,0 +1,715 @@ +{ ********************************************************************** + * Unit EIGEN.PAS * + * Version 1.8 * + * (c) J. Debord, May 2001 * + ********************************************************************** + Procedures for computing eigenvalues and eigenvectors + ********************************************************************** + References: + 1) Borland's Numerical Methods Toolbox : Jacobi + 2) 'Numerical Recipes' by Press et al. : EigenVals, RootPol + ********************************************************************** } + +unit Eigen; + +interface + +uses + FMath, Matrices; + +function Jacobi(A : PMatrix; Lbound, Ubound, MaxIter : Integer; + Tol : Float; V : PMatrix; Lambda : PVector) : Integer; +{ ---------------------------------------------------------------------- + Eigenvalues and eigenvectors of a symmetric matrix by the iterative + method of Jacobi + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : V = matrix of eigenvectors (stored by lines) + Lambda = eigenvalues in decreasing order + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : 1. The eigenvectors are normalized, with their first component > 0 + 2. This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function EigenVals(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Eigenvalues of a general square matrix + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + ---------------------------------------------------------------------- + Output parameters : Lambda_Re = real part of eigenvalues + Lambda_Im = imaginary part of eigenvalues + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : This procedure destroys the original matrix A + ---------------------------------------------------------------------- } + +function EigenVect(A : PMatrix; Lbound, Ubound : Integer; + Lambda, Tol : Float; V : PVector) : Integer; +{ ---------------------------------------------------------------------- + Computes the eigenvector associated to a real eigenvalue + ---------------------------------------------------------------------- + Input parameters : A = matrix + Lbound = index of first matrix element + Ubound = index of last matrix element + Lambda = eigenvalue + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : V = eigenvector + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- + NB : 1. The eigenvector is normalized, with its first component > 0 + 2. The function returns only one eigenvector, even if the + eigenvalue has a multiplicity greater than 1. + ---------------------------------------------------------------------- } + +procedure DivLargest(V : PVector; Lbound, Ubound : Integer; + var Largest : Float); +{ ---------------------------------------------------------------------- + Normalizes an eigenvector V by dividing by the element with the + largest absolute value + ---------------------------------------------------------------------- } + +function RootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Real and complex roots of a real polynomial by the method of the + companion matrix + ---------------------------------------------------------------------- + Input parameters : Coef = coefficients of polynomial + Deg = degree of polynomial + ---------------------------------------------------------------------- + Output parameters : X_Re = real parts of root (in increasing order) + X_Im = imaginary parts of root + ---------------------------------------------------------------------- + Possible results : MAT_OK + MAT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + + function Jacobi(A : PMatrix; Lbound, Ubound, MaxIter : Integer; + Tol : Float; V : PMatrix; Lambda : PVector) : Integer; + var + SinTheta, CosTheta, TanTheta, Tan2Theta : Float; + CosSqr, SinSqr, SinCos, SumSqrDiag : Float; + AII, AJJ, AIJ, AIK, AJK, VIK, VJK, D : Float; + I, J, K, Iter : Integer; + Done : Boolean; + begin + Iter := 0; + for I := Lbound to Ubound do + for J := Lbound to Ubound do + if I = J then + V^[I]^[J] := 1.0 + else + V^[I]^[J] := 0.0; + + repeat + Iter := Succ(Iter); + SumSqrDiag := 0.0; + for I := Lbound to Ubound do + SumSqrDiag := SumSqrDiag + Sqr(A^[I]^[I]); + Done := True; + + for I := Lbound to Pred(Ubound) do + for J := Succ(I) to Ubound do + if Abs(A^[I]^[J]) > Tol * SumSqrDiag then + begin + Done := False; + + { Calculate rotation } + D := A^[I]^[I] - A^[J]^[J]; + if Abs(D) > MACHEP then + begin + Tan2Theta := D / (2.0 * A^[I]^[J]); + TanTheta := - Tan2Theta + Sgn(Tan2Theta) * + Sqrt(1.0 + Sqr(Tan2Theta)); + CosTheta := 1.0 / Sqrt(1.0 + Sqr(TanTheta)); + SinTheta := CosTheta * TanTheta; + end + else + begin + CosTheta := SQRT2DIV2; { Sqrt(2)/2 } + SinTheta := Sgn(A^[I]^[J]) * SQRT2DIV2; + end; + + { Rotate matrix } + CosSqr := Sqr(CosTheta); + SinSqr := Sqr(SinTheta); + SinCos := SinTheta * CosTheta; + AII := A^[I]^[I] * CosSqr + 2.0 * A^[I]^[J] * SinCos + + A^[J]^[J] * SinSqr; + AJJ := A^[I]^[I] * SinSqr - 2.0 * A^[I]^[J] * SinCos + + A^[J]^[J] * CosSqr; + AIJ := (A^[J]^[J] - A^[I]^[I]) * SinCos + + A^[I]^[J] * (CosSqr - SinSqr); + for K := Lbound to Ubound do + if not(K in [I, J]) then + begin + AIK := A^[I]^[K] * CosTheta + A^[J]^[K] * SinTheta; + AJK := - A^[I]^[K] * SinTheta + A^[J]^[K] * CosTheta; + A^[I]^[K] := AIK; + A^[K]^[I] := AIK; + A^[J]^[K] := AJK; + A^[K]^[J] := AJK; + end; + A^[I]^[I] := AII; + A^[J]^[J] := AJJ; + A^[I]^[J] := AIJ; + A^[J]^[I] := AIJ; + + { Rotate eigenvectors } + for K := Lbound to Ubound do + begin + VIK := CosTheta * V^[I]^[K] + SinTheta * V^[J]^[K]; + VJK := - SinTheta * V^[I]^[K] + CosTheta * V^[J]^[K]; + V^[I]^[K] := VIK; + V^[J]^[K] := VJK; + end; + end; + until Done or (Iter > MaxIter); + + { The diagonal terms of the transformed matrix are the eigenvalues } + for I := Lbound to Ubound do + Lambda^[I] := A^[I]^[I]; + + if Iter > MaxIter then + begin + Jacobi := MAT_NON_CONV; + Exit; + end; + + { Sort eigenvalues and eigenvectors } + for I := Lbound to Pred(Ubound) do + begin + K := I; + D := Lambda^[I]; + for J := Succ(I) to Ubound do + if Lambda^[J] > D then + begin + K := J; + D := Lambda^[J]; + end; + FSwap(Lambda^[I], Lambda^[K]); + SwapRows(I, K, V, Lbound, Ubound); + end; + + { Make sure that the first component of each eigenvector is > 0 } + for I := Lbound to Ubound do + if V^[I]^[Lbound] < 0.0 then + for J := Lbound to Ubound do + V^[I]^[J] := - V^[I]^[J]; + + Jacobi := MAT_OK; + end; + + procedure Balance(A : PMatrix; Lbound, Ubound : Integer); + { Balances the matrix, i.e. reduces norm without affecting eigenvalues } + const + RADIX = 2; { Base used for machine computations } + var + I, J, Last : Integer; + C, F, G, R, S, Sqrdx : Float; + begin + Sqrdx := Sqr(RADIX); + repeat + Last := 1; + for I := Lbound to Ubound do + begin + C := 0.0; + R := 0.0; + for J := Lbound to Ubound do + if J <> I then + begin + C := C + Abs(A^[J]^[I]); + R := R + Abs(A^[I]^[J]); + end; + if (C <> 0.0) and (R <> 0.0) then + begin + G := R / RADIX; + F := 1.0; + S := C + R; + while C < G do + begin + F := F * RADIX; + C := C * Sqrdx; + end; + G := R * RADIX; + while C > G do + begin + F := F / RADIX; + C := C / Sqrdx; + end; + if (C + R) / F < 0.95 * S then + begin + Last := 0; + G := 1.0 / F; + for J := Lbound to Ubound do + A^[I]^[J] := A^[I]^[J] * G; + for J := Lbound to Ubound do + A^[J]^[I] := A^[J]^[I] * F; + end; + end; + end; + until Last <> 0; + end; + + procedure ElmHes(A : PMatrix; Lbound, Ubound : Integer); + { Reduces the matrix to upper Hessenberg form by elimination } + var + I, J, M : Integer; + X, Y : Float; + begin + for M := Succ(Lbound) to Pred(Ubound) do + begin + X := 0.0; + I := M; + for J := M to Ubound do + if Abs(A^[J]^[M - 1]) > Abs(X) then + begin + X := A^[J]^[M - 1]; + I := J; + end; + if I <> M then + begin + for J := Pred(M) to Ubound do + FSwap(A^[I]^[J], A^[M]^[J]); + for J := Lbound to Ubound do + FSwap(A^[J]^[I], A^[J]^[M]); + end; + if X <> 0.0 then + for I := Succ(M) to Ubound do + begin + Y := A^[I]^[M - 1]; + if Y <> 0.0 then + begin + Y := Y / X; + A^[I]^[M - 1] := Y; + for J := M to Ubound do + A^[I]^[J] := A^[I]^[J] - Y * A^[M]^[J]; + for J := Lbound to Ubound do + A^[J]^[M] := A^[J]^[M] + Y * A^[J]^[I]; + end; + end; + end; + for I := (Lbound + 2) to Ubound do + for J := Lbound to (I - 2) do + A^[I]^[J] := 0.0; + end; + + function Hqr(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; + { Finds the eigenvalues of an upper Hessenberg matrix } + label 2, 3, 4; + var + I, Its, J, K, L, M, N : Integer; + Anorm, P, Q, R, S, T, U, V, W, X, Y, Z : Float; + + function Sign(A, B : Float) : Float; + begin + if B < 0.0 then Sign := - Abs(A) else Sign := Abs(A) + end; + + begin + Anorm := Abs(A^[1]^[1]); + for I := Succ(Lbound) to Ubound do + for J := I - 1 to Ubound do + Anorm := Anorm + Abs(A^[I]^[J]); + N := Ubound; + T := 0.0; + while N >= Lbound do + begin + Its := 0; +2: for L := N downto Succ(Lbound) do + begin + S := Abs(A^[L - 1]^[L - 1]) + Abs(A^[L]^[L]); + if S = 0.0 then S := Anorm; + if Abs(A^[L]^[L - 1]) <= MACHEP * S then goto 3 + end; + L := Lbound; +3: X := A^[N]^[N]; + if L = N then + begin + Lambda_Re^[N] := X + T; + Lambda_Im^[N] := 0.0; + N := N - 1 + end + else + begin + Y := A^[N - 1]^[N - 1]; + W := A^[N]^[N - 1] * A^[N - 1]^[N]; + if L = N - 1 then + begin + P := 0.5 * (Y - X); + Q := Sqr(P) + W; + Z := Sqrt(Abs(Q)); + X := X + T; + if Q >= 0.0 then + begin + Z := P + Sign(Z, P); + Lambda_Re^[N] := X + Z; + Lambda_Re^[N - 1] := Lambda_Re^[N]; + if Z <> 0.0 then Lambda_Re^[N] := X - W / Z; + Lambda_Im^[N] := 0.0; + Lambda_Im^[N - 1] := 0.0 + end + else + begin + Lambda_Re^[N] := X + P; + Lambda_Re^[N - 1] := Lambda_Re^[N]; + Lambda_Im^[N] := Z; + Lambda_Im^[N - 1] := - Z + end; + N := N - 2 + end + else + begin + if Its = 30 then + begin + Hqr := MAT_NON_CONV; + Exit; + end; + if (Its = 10) or (Its = 20) then + begin + T := T + X; + for I := Lbound to N do + A^[I]^[I] := A^[I]^[I] - X; + S := Abs(A^[N]^[N - 1]) + Abs(A^[N - 1]^[N - 2]); + X := 0.75 * S; + Y := X; + W := - 0.4375 * Sqr(S) + end; + Its := Its + 1; + for M := N - 2 downto L do + begin + Z := A^[M]^[M]; + R := X - Z; + S := Y - Z; + P := (R * S - W) / A^[M + 1]^[M] + A^[M]^[M + 1]; + Q := A^[M + 1]^[M + 1] - Z - R - S; + R := A^[M + 2]^[M + 1]; + S := Abs(P) + Abs(Q) + Abs(R); + P := P / S; + Q := Q / S; + R := R / S; + if M = L then goto 4; + U := Abs(A^[M]^[M - 1]) * (Abs(Q) + Abs(R)); + V := Abs(P) * (Abs(A^[M - 1]^[M - 1]) + Abs(Z) + + Abs(A^[M + 1]^[M + 1])); + if U <= MACHEP * V then goto 4 + end; +4: for I := M + 2 to N do + begin + A^[I]^[I - 2] := 0.0; + if I <> (M + 2) then A^[I]^[I - 3] := 0.0 + end; + for K := M to N - 1 do + begin + if K <> M then + begin + P := A^[K]^[K - 1]; + Q := A^[K + 1]^[K - 1]; + R := 0.0; + if K <> (N - 1) then + R := A^[K + 2]^[K - 1]; + X := Abs(P) + Abs(Q) + Abs(R); + if X <> 0.0 then + begin + P := P / X; + Q := Q / X; + R := R / X + end + end; + S := Sign(Sqrt(Sqr(P) + Sqr(Q) + Sqr(R)), P); + if S <> 0.0 then + begin + if K = M then + begin + if L <> M then + A^[K]^[K - 1] := - A^[K]^[K - 1]; + end + else + begin + A^[K]^[K - 1] := - S * X + end; + P := P + S; + X := P / S; + Y := Q / S; + Z := R / S; + Q := Q / P; + R := R / P; + for J := K to N do + begin + P := A^[K]^[J] + Q * A^[K + 1]^[J]; + if K <> (N - 1) then + begin + P := P + R * A^[K + 2]^[J]; + A^[K + 2]^[J] := A^[K + 2]^[J] - P * Z + end; + A^[K + 1]^[J] := A^[K + 1]^[J] - P * Y; + A^[K]^[J] := A^[K]^[J] - P * X + end; + for I := L to IMin(N, K + 3) do + begin + P := X * A^[I]^[K] + Y * A^[I]^[K + 1]; + if K <> (N - 1) then + begin + P := P + Z * A^[I]^[K + 2]; + A^[I]^[K + 2] := A^[I]^[K + 2] - P * R + end; + A^[I]^[K + 1] := A^[I]^[K + 1] - P * Q; + A^[I]^[K] := A^[I]^[K] - P + end + end + end; + goto 2 + end + end + end; + Hqr := MAT_OK; + end; + + function EigenVals(A : PMatrix; Lbound, Ubound : Integer; + Lambda_Re, Lambda_Im : PVector) : Integer; + begin + Balance(A, Lbound, Ubound); + ElmHes(A, Lbound, Ubound); + EigenVals := Hqr(A, Lbound, Ubound, Lambda_Re, Lambda_Im); + end; + + procedure DivLargest(V : PVector; Lbound, Ubound : Integer; + var Largest : Float); + var + I : Integer; + begin + Largest := V^[Lbound]; + for I := Succ(Lbound) to Ubound do + if Abs(V^[I]) > Abs(Largest) then + Largest := V^[I]; + for I := Lbound to Ubound do + V^[I] := V^[I] / Largest; + end; + + function EigenVect(A : PMatrix; Lbound, Ubound : Integer; + Lambda, Tol : Float; V : PVector) : Integer; + + procedure SetMatrix(A, A1 : PMatrix; Lbound, Ubound : Integer; Lambda : Float); + { Form A1 = A - Lambda * I } + var + I : Integer; + begin + CopyMatrix(A1, A, Lbound, Lbound, Ubound, Ubound); + for I := Lbound to Ubound do + A1^[I]^[I] := A^[I]^[I] - Lambda; + end; + + function Solve(A : PMatrix; Lbound, Ubound, N : Integer; + Tol : Float; V : PVector) : Integer; + { Solve the system A*X = 0 after fixing the N-th unknown to 1 } + var + A1, W : PMatrix; + B, S, X : PVector; + ErrCode, I, I1, J, J1, Ubound1 : Integer; + begin + Ubound1 := Pred(Ubound); + + DimMatrix(A1, Ubound1, Ubound1); + DimMatrix(W, Ubound1, Ubound1); + DimVector(B, Ubound1); + DimVector(S, Ubound1); + DimVector(X, Ubound1); + + I1 := Pred(Lbound); + for I := Lbound to Ubound do + if I <> N then + begin + Inc(I1); + J1 := 0; + for J := Lbound to Ubound do + if J <> N then + begin + Inc(J1); + A1^[I1]^[J1] := A^[I]^[J]; + end + else + B^[I1] := - A^[I]^[J]; + end; + + ErrCode := SV_Decomp(A1, Lbound, Ubound1, Ubound1, S, W); + + if ErrCode = 0 then + begin + SV_SetZero(S, Lbound, Ubound1, Tol); + SV_Solve(A1, S, W, B, Lbound, Ubound1, Ubound1, X); + + { Update eigenvector } + I1 := 0; + for I := Lbound to Ubound do + if I = N then + V^[I] := 1.0 + else + begin + Inc(I1); + V^[I] := X^[I1]; + end; + end; + + DelMatrix(A1, Ubound1, Ubound1); + DelMatrix(W, Ubound1, Ubound1); + DelVector(B, Ubound1); + DelVector(S, Ubound1); + DelVector(X, Ubound1); + + Solve := ErrCode; + end; + + function ZeroVector(B : PVector; Lbound, Ubound : Integer; Tol : Float) : Boolean; + { Check if vector B is zero } + var + I : Integer; + Z : Boolean; + begin + Z := True; + for I := Lbound to Ubound do + Z := Z and (Abs(B^[I]) < Tol); + ZeroVector := Z; + end; + + function CheckEigenVector(A1 : PMatrix; V : PVector; + Lbound, Ubound : Integer; Tol : Float) : Boolean; + { Check if the equation A1 * V = 0 holds } + var + I, K : Integer; + B : PVector; + begin + DimVector(B, Ubound); + + { Form B = A1 * V } + for I := Lbound to Ubound do + for K := Lbound to Ubound do + B^[I] := B^[I] + A1^[I]^[K] * V^[K]; + + { Check if B is zero } + CheckEigenVector := ZeroVector(B, Lbound, Ubound, Tol); + + DelVector(B, Ubound); + end; + + procedure Normalize(V : PVector; Lbound, Ubound : Integer); + { Normalize eigenvector and make sure that the first component is >= 0 } + var + Sum, Norm : Float; + I : Integer; + begin + Sum := 0.0; + for I := Lbound to Ubound do + Sum := Sum + Sqr(V^[I]); + Norm := Sqrt(Sum); + for I := Lbound to Ubound do + if V^[I] <> 0.0 then V^[I] := V^[I] / Norm; + if V^[Lbound] < 0.0 then + for I := Lbound to Ubound do + if V^[I] <> 0.0 then V^[I] := - V^[I]; + end; + + var + ErrCode, I : Integer; + A1 : PMatrix; + + begin + DimMatrix(A1, Ubound, Ubound); + + { Form A1 = A - Lambda * I } + SetMatrix(A, A1, Lbound, Ubound, Lambda); + + { Try to solve the system A1*V=0 by eliminating 1 equation } + I := Lbound; + repeat + if (Solve(A1, Lbound, Ubound, I, Tol, V) = 0) and + CheckEigenVector(A1, V, Lbound, Ubound, Tol) + then + ErrCode := 0 + else + ErrCode := - 1; + Inc(I); + until (ErrCode = 0) or (I > Ubound); + + if ErrCode = 0 then + begin + Normalize(V, Lbound, Ubound); + EigenVect := MAT_OK; + end + else + EigenVect := MAT_NON_CONV; + + DelMatrix(A1, Ubound, Ubound); + end; + + function RootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; + var + A : PMatrix; { Companion matrix } + N : Integer; { Size of matrix } + I, J, K : Integer; { Loop variables } + ErrCode : Integer; { Error code } + Temp : Float; + begin + N := Pred(Deg); + DimMatrix(A, N, N); + + { Set up the companion matrix (to save space, begin at index 0) } + for J := 0 to N do + A^[0]^[J] := - Coef^[Deg - J - 1] / Coef^[Deg]; + for J := 0 to Pred(N) do + A^[J + 1]^[J] := 1.0; + + { The roots of the polynomial are the eigenvalues of the companion matrix } + Balance(A, 0, N); + ErrCode := Hqr(A, 0, N, X_Re, X_Im); + + if ErrCode = MAT_OK then + begin + { Sort roots in increasing order of real parts } + for I := 0 to N - 1 do + begin + K := I; + Temp := X_Re^[I]; + for J := Succ(I) to N do + if X_Re^[J] < Temp then + begin + K := J; + Temp := X_Re^[J]; + end; + FSwap(X_Re^[I], X_Re^[K]); + FSwap(X_Im^[I], X_Im^[K]); + end; + + { Transfer roots from 0..(Deg - 1) to 1..Deg } + for J := N downto 0 do + begin + X_Re^[J + 1] := X_Re^[J]; + X_Im^[J + 1] := X_Im^[J]; + end; + end; + + DelMatrix(A, N, N); + RootPol := ErrCode; + end; + +end. diff --git a/npm_precl/dmath/fcomp.pas b/npm_precl/dmath/fcomp.pas new file mode 100755 index 0000000..fa5a1a5 --- /dev/null +++ b/npm_precl/dmath/fcomp.pas @@ -0,0 +1,649 @@ +{ ********************************************************************** + * Unit FCOMP.PAS * + * Version 1.1 * + * (c) J. Debord, July 2000 * + ********************************************************************** + Complex functions for TPMATH + (Based on CMPLX.ZIP by E.F. Glynn) + ********************************************************************** } + +unit FComp; + +interface + +uses + FMath; + +{ ********************************************************************** + Complex type + ********************************************************************** } + +type + ComplexForm = (Rec, Pol); { Rectangular or Polar form } + + Complex = record + case Form : ComplexForm of + Rec : (X, Y : Float); + Pol : (R, Theta : Float); + end; + +const + C_infinity : Complex = (Form : Rec; X : MAXNUM; Y : 0.0); + C_zero : Complex = (Form : Rec; X : 0.0; Y : 0.0); + C_one : Complex = (Form : Rec; X : 1.0; Y : 0.0); + C_i : Complex = (Form : Rec; X : 0.0; Y : 1.0); + C_pi : Complex = (Form : Rec; X : PI; Y : 0.0); + C_pi_div_2 : Complex = (Form : Rec; X : PIDIV2; Y : 0.0); + +{ ********************************************************************** + Complex number initialization and conversion + ********************************************************************** } + +procedure CSet(var Z : Complex; A, B : Float; F : ComplexForm); +{ ---------------------------------------------------------------------- + Initializes a complex number according to the form specified by F + F = Rec ==> Z = A + i * B + F = Pol ==> Z = A * Exp(i * B) + ---------------------------------------------------------------------- } + +procedure CConvert(var Z : Complex; F : ComplexForm); +{ Converts the complex number Z to the form specified by F } + +procedure CSwap(var X, Y : Complex); +{ Exchanges two complex numbers } + +{ ********************************************************************** + Complex functions + ********************************************************************** } + +function CReal(Z : Complex) : Float; { Re(Z) } +function CImag(Z : Complex) : Float; { Im(Z) } +function CAbs(Z : Complex) : Float; { |Z| } +function CArg(Z : Complex) : Float; { Arg(Z) } +function CSgn(Z : Complex) : Integer; { Complex sign } + +procedure CNeg(A : Complex; var Z : Complex); { Z = -A } +procedure CConj(A : Complex; var Z : Complex); { Z = A* } +procedure CAdd(A, B : Complex; var Z : Complex); { Z = A + B } +procedure CSub(A, B : Complex; var Z : Complex); { Z = A - B } +procedure CDiv(A, B : Complex; var Z : Complex); { Z = A / B } +procedure CMult(A, B : Complex; var Z : Complex); { Z = A * B } +procedure CLn(A : Complex; var Z : Complex); { Z = Ln(A) } +procedure CExp(A : Complex; var Z : Complex); { Z = Exp(A) } +procedure CPower(A, B : Complex; var Z : Complex); { Z = A^B } + +procedure CIntPower(A : Complex; N : Integer; var Z : Complex); { Z = A^N } +procedure CRealPower(A : Complex; X : Float; var Z : Complex); { Z = A^X } +procedure CSqrt(A : Complex; var Z : Complex); { Z = Sqrt(A) } +procedure CRoot(A : Complex; K, N : Integer; var Z : Complex); { Z = A^(1/N) } + +procedure CSin(A : Complex; var Z : Complex); { Z = Sin(A) } +procedure CCos(A : Complex; var Z : Complex); { Z = Cos(A) } +procedure CTan(A : Complex; var Z : Complex); { Z = Tan(A) } + +procedure CArcSin(A : Complex; var Z : Complex); { Z = ArcSin(A) } +procedure CArcCos(A : Complex; var Z : Complex); { Z = ArcCos(A) } +procedure CArcTan(A : Complex; var Z : Complex); { Z = ArcTan(A) } + +procedure CSinh(A : Complex; var Z : Complex); { Z = Sinh(A) } +procedure CCosh(A : Complex; var Z : Complex); { Z = Cosh(A) } +procedure CTanh(A : Complex; var Z : Complex); { Z = Tanh(A) } + +procedure CArcSinh(A : Complex; var Z : Complex); { Z = ArcSinh(A) } +procedure CArcCosh(A : Complex; var Z : Complex); { Z = ArcCosh(A) } +procedure CArcTanh(A : Complex; var Z : Complex); { Z = ArcTanh(A) } + +procedure CLnGamma(A : Complex; var Z : Complex); { Z = Ln(Gamma(A)) } + +implementation + +{$IFDEF CPU387} + {$DEFINE USE_ASM} +{$ENDIF} + +{$IFDEF CPUP2} + {$DEFINE USE_ASM} +{$ENDIF} + + procedure CSet(var Z : Complex; A, B : Float; F : ComplexForm); + begin + Z.Form := F; + if F = Pol then + begin + Z.R := A; + Z.Theta := B; + end + else + begin + Z.X := A; + Z.Y := B; + end; + end; + + function CAbs(Z : Complex) : Float; + begin + if Z.Form = Rec then + CAbs := Pythag(Z.X, Z.Y) + else + CAbs := Z.R; + end; + + function CArg(Z : Complex) : Float; + begin + if Z.Form = Rec then + CArg := ArcTan2(Z.Y, Z.X) + else + CArg := Z.Theta; + end; + + function CReal(Z : Complex) : Float; + begin + if Z.Form = Rec then + CReal := Z.X + else + CReal := Z.R * {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(Z.Theta); + end; + + function CImag(Z : Complex) : Float; + begin + if Z.Form = Rec then + CImag := Z.Y + else + CImag := Z.R * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(Z.Theta); + end; + + function CSgn(Z : Complex) : Integer; + var + Re, Im : Float; + begin + Re := CReal(Z); + if Re > 0.0 then + CSgn := 1 + else if Re < 0.0 then + CSgn := - 1 + else + begin + Im := CImag(Z); + if Im > 0.0 then + CSgn := 1 + else if Im < 0.0 then + CSgn := - 1 + else + CSgn := 0; + end; + end; + + procedure CConvert(var Z : Complex; F : ComplexForm); + var + A : Complex; + begin + if Z.Form = F then Exit; + if Z.Form = Pol then + begin { Polar-to-rectangular conversion } + A.Form := Rec; + A.X := Z.R * {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(Z.Theta); + A.Y := Z.R * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(Z.Theta); + end + else + begin { Rectangular-to-polar conversion } + A.Form := Pol; + if Z.X = 0.0 then + if Z.Y = 0.0 then + A.R := 0.0 + else if Z.Y > 0.0 then + A.R := Z.Y + else + A.R := - Z.Y + else + A.R := CAbs(Z); + A.Theta := ArcTan2(Z.Y, Z.X); + end; + Z := A; + end; + + procedure CSwap(var X, Y : Complex); + var + Temp : Complex; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + procedure CNeg(A : Complex; var Z : Complex); + begin + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R; + Z.Theta := FixAngle(A.Theta + PI) + end + else + begin + Z.X := - A.X; + Z.Y := - A.Y + end; + end; + + procedure CConj(A : Complex; var Z : Complex); + begin + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R; + Z.Theta := FixAngle(- A.Theta) + end + else + begin + Z.X := A.X; + Z.Y := - A.Y + end + end; + + procedure CAdd(A, B : Complex; var Z : Complex); + begin + CConvert(A, Rec); + CConvert(B, Rec); + Z.Form := Rec; + Z.X := A.X + B.X; + Z.Y := A.Y + B.Y; + end; + + procedure CSub(A, B : Complex; var Z : Complex); + begin + CConvert(A, Rec); + CConvert(B, Rec); + Z.Form := Rec; + Z.X := A.X - B.X; + Z.Y := A.Y - B.Y; + end; + + procedure CMult(A, B : Complex; var Z : Complex); + begin + CConvert(B, A.Form); { arbitrarily convert one to type of other } + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R * B.R; + Z.Theta := FixAngle(A.Theta + B.Theta) + end + else + begin + Z.X := A.X * B.X - A.Y * B.Y; + Z.Y := A.X * B.Y + A.Y * B.X + end; + end; + + procedure CDiv(A, B : Complex; var Z : Complex); + var + Temp : Float; + begin + if ((B.Form = Rec) and (B.X = 0.0) and (B.Y = 0.0)) or + ((B.Form = Pol) and (B.R = 0.0)) then + begin + MathErr := FN_OVERFLOW; + Z := C_infinity; + Exit; + end; + + CConvert(B, A.Form); { arbitrarily convert one to type of other } + Z.Form := A.Form; + if A.Form = Pol then + begin + Z.R := A.R / B.R; + Z.Theta := FixAngle(A.Theta - B.Theta); + end + else + begin + Temp := Sqr(B.X) + Sqr(B.Y); + Z.X := (A.X * B.X + A.Y * B.Y) / Temp; + Z.Y := (A.Y * B.X - A.X * B.Y) / Temp; + end; + end; + + procedure CLn(A : Complex; var Z : Complex); + var + LnR : Float; + begin + CConvert(A, Pol); + LnR := Log(A.R); + if MathErr = FN_OK then + CSet(Z, LnR, FixAngle(A.Theta), Rec) + else + CSet(Z, - MAXNUM, 0.0, Rec); + end; + + procedure CExp(A : Complex; var Z : Complex); + var + ExpX, SinY, CosY : Float; + begin + CConvert(A, Rec); + ExpX := Expo(A.X); + if MathErr = FN_OK then + begin + SinY := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(A.Y); + CosY := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(A.Y); + CSet(Z, ExpX * CosY, ExpX * SinY, Rec); + end + else + CSet(Z, ExpX, 0.0, Rec); + end; + + procedure CPower(A, B : Complex; var Z : Complex); + var + BLnA, LnA : Complex; + begin + CConvert(A, Rec); + CConvert(B, Rec); + if (A.X = 0.0) and (A.Y = 0.0) then + if (B.X = 0.0) and (B.Y = 0.0) then + Z := C_one { lim a^a = 1 as a -> 0 } + else + Z := C_zero { 0^b = 0, b > 0 } + else + begin + CLn(A, LnA); + CMult(B, LnA, BLnA); + CExp(BLnA, Z); + end; + end; + + procedure CIntPower(A : Complex; N : Integer; var Z : Complex); + { CIntPower directly applies DeMoivre's theorem to calculate an integer + power of a complex number. The formula holds for both positive and + negative values of N } + begin + CConvert(A, Pol); + if A.R = 0.0 then + if N = 0 then + Z := C_one + else if N > 0 then + Z := C_zero + else + begin + MathErr := FN_SING; + Z := C_infinity; + end + else + CSet(Z, IntPower(A.R, N), FixAngle(N * A.Theta), Pol); + end; + + procedure CRealPower(A : Complex; X : Float; var Z : Complex); + begin + CConvert(A, Pol); + if A.R = 0.0 then + if X = 0.0 then + Z := C_one + else if X > 0.0 then + Z := C_zero + else + begin + MathErr := FN_SING; + Z := C_infinity; + end + else + CSet(Z, Power(A.R, X), FixAngle(X * A.Theta), Pol); + end; + + procedure CRoot(A : Complex; K, N : Integer; var Z : Complex); + { CRoot can calculate all 'N' roots of 'A' by varying 'K' from 0..N-1 } + { This is another application of DeMoivre's theorem. See CIntPower. } + begin + if (N <= 0) or (K < 0) or (K >= N) then + begin + MathErr := FN_DOMAIN; + Z := C_zero; + Exit; + end; + CConvert(A, Pol); + if A.R = 0.0 then + Z := C_zero + else + CSet(Z, Power(A.R, 1.0 / N), FixAngle((A.Theta + K * TWOPI) / N), Pol); + end; + + procedure CSqrt(A : Complex; var Z : Complex); + begin + CConvert(A, Pol); + if A.R = 0.0 then + Z := C_zero + else + CSet(Z, Sqrt(A.R), FixAngle(0.5 * A.Theta), Pol); + end; + + procedure CCos(A : Complex; var Z : Complex); + var + SinX, CosX, SinhY, CoshY : Float; + begin + CConvert(A, Rec); + SinCos(A.X, SinX, CosX); + SinhCosh(A.Y, SinhY, CoshY); { Called here to set MathErr } + CSet(Z, CosX * CoshY, - SinX * SinhY, Rec) + end; + + procedure CSin(A : Complex; var Z : Complex); + var + SinX, CosX, SinhY, CoshY : Float; + begin + CConvert(A, Rec); + SinCos(A.X, SinX, CosX); + SinhCosh(A.Y, SinhY, CoshY); { Called here to set MathErr } + CSet(Z, SinX * CoshY, CosX * SinhY, Rec) + end; + + procedure CTan(A : Complex; var Z : Complex); + var + X2, Y2, SinX2, CosX2, SinhY2, CoshY2, Temp : Float; + begin + CConvert(A, Rec); + X2 := 2.0 * A.X; + Y2 := 2.0 * A.Y; + SinCos(X2, SinX2, CosX2); + SinhCosh(Y2, SinhY2, CoshY2); + if MathErr = FN_OK then + Temp := CosX2 + CoshY2 + else + Temp := CoshY2; + if Temp <> 0.0 then + CSet(Z, SinX2 / Temp, SinhY2 / Temp, Rec) + else + begin { A = Pi/2 + k*Pi } + MathErr := FN_SING; + CSet(Z, MAXNUM, 0.0, Rec); + end; + end; + + procedure CCosh(A : Complex; var Z : Complex); + var + SinhX, CoshX, SinY, CosY : Float; + begin + CConvert(A, Rec); + SinCos(A.Y, SinY, CosY); + SinhCosh(A.X, SinhX, CoshX); + CSet(Z, CoshX * CosY, SinhX * SinY, Rec) + end; + + procedure CSinh(A : Complex; var Z : Complex); + var + SinhX, CoshX, SinY, CosY : Float; + begin + CConvert(A, Rec); + SinCos(A.Y, SinY, CosY); + SinhCosh(A.X, SinhX, CoshX); + CSet(Z, SinhX * CosY, CoshX * SinY, Rec) + end; + + procedure CTanh(A : Complex; var Z : Complex); + var + X2, Y2, SinY2, CosY2, SinhX2, CoshX2, Temp : Float; + begin + CConvert(A, Rec); + X2 := 2.0 * A.X; + Y2 := 2.0 * A.Y; + SinCos(Y2, SinY2, CosY2); + SinhCosh(X2, SinhX2, CoshX2); + if MathErr = FN_OK then + Temp := CoshX2 + CosY2 + else + Temp := CoshX2; + if Temp <> 0.0 then + CSet(Z, SinhX2 / Temp, SinY2 / Temp, Rec) + else + begin { A = i * (Pi/2 + k*Pi) } + MathErr := FN_SING; + CSet(Z, 0.0, MAXNUM, Rec); + end; + end; + + procedure CArcSin(A : Complex; var Z : Complex); + var + Rp, Rm, S, T, X2, XX, YY : Float; + B : Complex; + begin + CConvert(A, Rec); + CSet(B, A.Y, - A.X, Rec); { Y - i*X } + X2 := 2.0 * A.X; + XX := Sqr(A.X); + YY := Sqr(A.Y); + S := XX + YY + 1.0; + Rp := 0.5 * Sqrt(S + X2); + Rm := 0.5 * Sqrt(S - X2); + T := Rp + Rm; + Z.Form := Rec; + Z.X := ArcSin(Rp - Rm); + Z.Y := CSgn(B) * Log(T + Sqrt(Sqr(T) - 1.0)); + end; + + procedure CArcCos(A : Complex; var Z : Complex); + begin + CArcSin(A, Z); + CSub(C_pi_div_2, Z, Z); { Pi/2 - ArcSin(Z) } + end; + + procedure CArcTan(A : Complex; var Z : Complex); + var + XX, Yp1, Ym1 : Float; + begin + CConvert(A, Rec); + if (A.X = 0.0) and (Abs(A.Y) = 1.0) then { A = +/- i } + begin + MathErr := FN_SING; + CSet(Z, 0.0, Sgn(A.Y) * MAXNUM, Rec); + Exit; + end; + XX := Sqr(A.X); + Yp1 := A.Y + 1.0; + Ym1 := A.Y - 1.0; + Z.Form := Rec; + Z.X := 0.5 * (ArcTan2(A.X, - Ym1) - ArcTan2(- A.X, Yp1)); + Z.Y := 0.25 * Log((XX + Sqr(Yp1)) / (XX + Sqr(Ym1))); + end; + + procedure CArcSinh(A : Complex; var Z : Complex); + { ArcSinH(A) = -i*ArcSin(i*A) } + begin + CMult(C_i, A, Z); + CArcSin(Z, Z); + CMult(C_i, Z, Z); + CNeg(Z, Z); + end; + + procedure CArcCosh(A : Complex; var Z : Complex); + { ArcCosH(A) = CSgn(Y + i(1-X))*i*ArcCos(A) where A = X+iY } + var + B : Complex; + begin + CArcCos(A, Z); + CMult(C_i, Z, Z); + CSet(B, A.Y, 1.0 - A.X, Rec); { Y + i*(1-X) } + if CSgn(B) = -1 then CNeg(Z, Z); + end; + + procedure CArcTanh(A : Complex; var Z : Complex); + { ArcTanH(A) = -i*ArcTan(i*A) } + begin + CConvert(A, Rec); + if (Abs(A.X) = 1.0) and (A.Y = 0.0) then { A = +/- 1 } + begin + MathErr := FN_SING; + CSet(Z, Sgn(A.X) * MAXNUM, 0.0, Rec); + Exit; + end; + CMult(C_i, A, Z); + CArcTan(Z, Z); + CMult(C_i, Z, Z); + CNeg(Z, Z); + end; + + procedure CApproxLnGamma(Z : Complex; var Sum : Complex); + { This is the approximation used in the National Bureau of + Standards "Table of the Gamma Function for Complex Arguments," + Applied Mathematics Series 34, 1954. The NBS table was created + using this approximation over the area 9 < Re(z) < 10 and + 0 < Im(z) < 10. Other table values were computed using the + relationship: + _ _ + ln | (z+1) = ln z + ln | (z) } + + const + C : array[1..8] of Float = + (8.33333333333333E-02, - 2.77777777777778E-03, + 7.93650793650794E-04, - 5.95238095238095E-04, + 8.41750841750842E-04, - 1.91752691752692E-03, + 6.41025641025641E-03, - 2.95506535947712E-02); + var + I : Integer; + Powers : array[1..8] of Complex; + Temp1, Temp2 : Complex; + begin + CConvert(Z, Rec); + CLn(Z, Temp1); { Ln(Z) } + CSet(Temp2, Z.X - 0.5, Z.Y, Rec); { Z - 0.5 } + CMult(Temp1, Temp2, Sum); { (Z - 0.5)*Ln(Z) } + CSub(Sum, Z, Sum); { (Z - 0.5)*ln(Z) - Z } + Sum.X := Sum.X + LN2PIDIV2; + Temp1 := C_one; + CDiv(Temp1, Z, Powers[1]); { Z^(-1) } + CMult(Powers[1], Powers[1], Temp2); { Z^(-2) } + for I := 2 to 8 do + CMult(Powers[I - 1], Temp2, Powers[I]); + for I := 8 downto 1 do + begin + CSet(Temp1, C[I] * Powers[I].X, C[I] * Powers[I].Y, Rec); + CAdd(Sum, Temp1, Sum); + end + end; + + procedure CLnGamma(A : Complex; var Z : Complex); + var + LnA, Temp : Complex; + begin + CConvert(A, Rec); + if (A.X <= 0.0) and (A.Y = 0.0) then + if (Int(A.X - 1E-8) - A.X) = 0.0 then { Negative integer? } + begin + MathErr := FN_SING; + Z := C_infinity; + Exit + end; + if A.Y < 0.0 then { 3rd or 4th quadrant? } + begin + CConj(A, A); + CLnGamma(A, Z); { Try again in 1st or 2nd quadrant } + CConj(Z, Z) { Left this out! 1/3/91 } + end + else + begin + if A.X < 9.0 then { "left" of NBS table range } + begin + CLn(A, LnA); + CSet(A, A.X + 1.0, A.Y, Rec); + CLnGamma(A, Temp); + CSub(Temp, LnA, Z) + end + else + CApproxLnGamma(A, Z) { NBS table range: 9 < Re(z) < 10 } + end + end; + +end. diff --git a/npm_precl/dmath/fitexlin.pas b/npm_precl/dmath/fitexlin.pas new file mode 100755 index 0000000..06f798a --- /dev/null +++ b/npm_precl/dmath/fitexlin.pas @@ -0,0 +1,129 @@ +{ ********************************************************************** + * Unit FITEXLIN.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the "exponential + linear" model: + + y = A.[1 - exp(-k.x)] + B.x + + ********************************************************************** } + +unit FitExLin; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A[1 - exp(-k.x)] + B.x'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'k'; + 2 : ParamName := 'B'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = A B^[1] = k B^[2] = B + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * (1.0 - Expo(- B^[1] * X)) + B^[2] * X; + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + E : Float; + begin + E := Expo(- B^[1] * X); { exp(-k.x) } + D^[0] := 1.0 - E; { dy/dA = 1 - exp(-k.x) } + D^[1] := B^[0] * X * E; { dy/dk = A.x.exp(-k.x) } + D^[2] := X; { dy/dB = x } + end; + + function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Computes initial estimates of the regression parameters + -------------------------------------------------------------------- + Input : N = number of points + X, Y = point coordinates + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + K : Integer; + D : Float; + begin + { B is the slope of the last (linear) part of the curve } + K := Round(0.9 * N); + if K = N then K := Pred(N); + B^[2] := (Y^[N] - Y^[K]) / (X^[N] - X^[K]); + + { A is the intercept of the linear part } + B^[0] := Y^[N] - B^[2] * X^[N]; + + { Slope of the tangent at origin = B + k.A } + K := Round(0.1 * N); + if K = 1 then K := 2; + D := (Y^[K] - Y^[1]) / (X^[K] - X^[1]); + B^[1] := (D - B^[1]) / B^[0]; + + FitModel := 0; + end; + + end. diff --git a/npm_precl/dmath/fitexpo.pas b/npm_precl/dmath/fitexpo.pas new file mode 100755 index 0000000..218d092 --- /dev/null +++ b/npm_precl/dmath/fitexpo.pas @@ -0,0 +1,316 @@ +{ ********************************************************************** + * Unit FITEXPO.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits a sum of decreasing exponentials : + + y = Ymin + A1.exp(-a1.x) + A2.exp(-a2.x) + A3.exp(-a3.x) + ... + + ********************************************************************** } + +unit FitExpo; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Stat, Regress; + +const + NO_REAL_ROOT = - 2; { No real exponent } + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + N_exp : Integer = 1; { Number of exponentials } + ConsTerm : Boolean = True; { Flags the presence of a constant term Ymin } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + I : Integer; + Name, S : String; + begin + Name := 'y = '; + if ConsTerm then + Name := Name + 'Ymin + '; + Name := Name + 'A1.exp(-a1.x)'; + for I := 2 to N_exp do + begin + Str(I, S); + Name := Name + ' + A' + S + '.exp(-a' + S + '.x)'; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term Ymin, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2 * N_exp; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + if I = 0 then + ParamName := 'Ymin' + else if Odd(I) then + begin + Str(Succ(I) div 2, S); + ParamName := 'A' + S; + end + else + begin + Str(I div 2, S); + ParamName := 'a' + S; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + B^[0] = Ymin + B^[1] = A1 B^[2] = a1 + ............................... + B^[2*i-1] = Ai B^[2*i] = ai i = 1..N_exp + -------------------------------------------------------------------- } + var + I : Integer; + S : Float; + begin + if ConsTerm then + S := B^[0] + else + S := 0.0; + for I := 1 to N_exp do + S := S + B^[2 * I - 1] * Expo(- B^[2 * I] * X); + RegFunc := S; + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + I, P, Q : Integer; + E : Float; + begin + D^[0] := 1.0; { dy/dYmin = 1 } + for I := 1 to N_exp do + begin + Q := 2 * I; + P := Pred(Q); + E := Expo(- B^[Q] * X); + D^[P] := E; { dy/dAi = exp(-ai.x) } + D^[Q] := - X * B^[P] * E; { dy/dai = -x.Ai.exp(-ai.x) } + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a sum of exponentials by linear regression + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- + Ref. : R. GOMENI & C. GOMENI, Automod : A polyalgorithm for an + integrated analysis of linear pharmacokinetic models + Comput. Biol. Med., 1979, 9, 39-48 + -------------------------------------------------------------------- } + var + I, K, M : Integer; + X1, Y1 : PVector; { Modified coordinates } + U : PMatrix; { Variables for linear regression } + P : PVector; { Linear regression parameters } + C, Z : PVector; { Coefficients and roots of polynomial } + V : PMatrix; { Variance-covariance matrix } + H : Float; { Integration step } + ErrCode : Integer; { Error code } + begin + M := Pred(2 * N_exp); + DimVector(X1, N); + DimVector(Y1, N); + DimMatrix(U, M, N); + DimMatrix(V, M, M); + DimVector(P, M); + DimVector(C, N_exp); + DimVector(Z, N_exp); + CopyVector(X1, X, 1, N); + CopyVector(Y1, Y, 1, N); + + { Change scale so that the X's begin at zero } + if X^[1] <> 0.0 then + for K := 1 to N do + X1^[K] := X1^[K] - X^[1]; + + { Estimate the constant term at 90% of the lowest observed value, + then subtract it from each Y value } + if ConsTerm then + begin + B^[0] := 0.9 * Min(Y1, 1, N); + for K := 1 to N do + Y1^[K] := Y1^[K] - B^[0]; + end; + + { ------------------------------------------------------------------ + Fit the linearized form of the function : + + y = p(0) + p(1) * x + p(2) * x^2 + ... + p(N_exp-1) * x^(N_exp-1) + + (x (x (x + + p(N_exp) | y dx + ... + p(2*N_exp-1) | ....| y dx + )0 )0 )0 + ------------------------------------------------------------------ } + + { Compute increasing powers of X } + if N_exp > 1 then + for K := 2 to N do + begin + U^[1]^[K] := X1^[K]; + for I := 2 to Pred(N_exp) do + U^[I]^[K] := U^[I - 1]^[K] * X1^[K]; + end; + + { Compute integrals by the trapezoidal rule } + for K := 2 to N do + begin + H := 0.5 * (X1^[K] - X1^[K - 1]); + U^[N_exp]^[K] := U^[N_exp]^[K - 1] + (Y1^[K] + Y1^[K - 1]) * H; + for I := Succ(N_exp) to M do + U^[I]^[K] := U^[I]^[K - 1] + (U^[I - 1]^[K] + U^[I - 1]^[K - 1]) * H; + end; + + { Fit the equation } + case Method of + 0 : ErrCode := MulFit(U, Y1, N, M, True, P, V); + 1 : ErrCode := WMulFit(U, Y1, W, N, M, True, P, V); + end; + + if ErrCode = MAT_SINGUL then + FitModel := ErrCode + else + begin + { ---------------------------------------------------------------- + The exponents are the roots of the polynomial : + x^N_exp + p(N_exp) * x^(N_exp-1) - p(N_exp+1) * x^(N_exp-2) +... + ---------------------------------------------------------------- } + + { Compute polynomial coefficients } + C^[N_exp] := 1.0; + for I := 1 to N_exp do + if Odd(I) then + C^[N_exp - I] := P^[N_exp + I - 1] + else + C^[N_exp - I] := - P^[N_exp + I - 1]; + + { Solve polynomial } + if RRootPol(C, N_exp, Z) <> N_exp then + FitModel := NO_REAL_ROOT + else + begin + { Sort exponents in decreasing order } + DQSort(Z, 1, N_exp); + + { Compute the coefficients of the exponentials by + linear regression on the exponential terms } + for I := 1 to N_exp do + for K := 1 to N do + U^[I]^[K] := Expo(- Z^[I] * X1^[K]); + + case Method of + 0 : ErrCode := MulFit(U, Y1, N, N_exp, False, P, V); + 1 : ErrCode := WMulFit(U, Y1, W, N, N_exp, False, P, V); + end; + + if ErrCode = MAT_SINGUL then + FitModel := ErrCode + else + begin + { Extract model parameters } + for I := 1 to N_exp do + begin + { Correct for scale change if necessary } + if X^[1] <> 0.0 then + P^[I] := P^[I] * Expo(Z^[I] * X^[1]); + + { Extract coefficients and exponents } + B^[2 * I - 1] := P^[I]; { Coefficients } + B^[2 * I] := Z^[I]; { Exponents } + end; + FitModel := MAT_OK; + end; + end; + end; + + DelVector(X1, N); + DelVector(Y1, N); + DelMatrix(U, M, N); + DelMatrix(V, M, M); + DelVector(P, M); + DelVector(C, N_exp); + DelVector(Z, N_exp); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = number of exponentials + CstPar^[1] = 1 to include a constant term (Ymin) + -------------------------------------------------------------------- } + var + N : Integer; + begin + N := Round(CstPar^[0]); + if N > 0 then N_exp := N; + ConsTerm := (CstPar^[1] = 1); + end; + +end. diff --git a/npm_precl/dmath/fitfrac.pas b/npm_precl/dmath/fitfrac.pas new file mode 100755 index 0000000..156db73 --- /dev/null +++ b/npm_precl/dmath/fitfrac.pas @@ -0,0 +1,220 @@ +{ ********************************************************************** + * Unit FITFRAC.PAS * + * Version 1.2 * + * (c) J. Debord, April 1999 * + ********************************************************************** + This unit fits a rational fraction : + + p0 + p1.x + p2.x^2 + ... + y = ------------------------ + 1 + q1.x + q2.x^2 + ... + + ********************************************************************** } + +unit FitFrac; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Deg1 : Integer = 1; { Degree of numerator } + Deg2 : Integer = 1; { Degree of denominator } + ConsTerm : Boolean = True; { Flags the presence of a constant term p0 } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = ('; + if ConsTerm then + Name := Name + 'p0 + '; + Name := Name + 'p1.x'; + for I := 2 to Deg1 do + begin + Str(I, S); + Name := Name + ' + p' + S + '.x^' + S; + end; + Name := Name + ') / (1 + q1.x'; + for I := (Deg1 + 2) to (Deg1 + Deg2) do + begin + Str(I - Deg1, S); + Name := Name + ' + q' + S + '.x^' + S; + end; + Name := Name + ')'; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term p0, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := Deg1 + Deg2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + if I <= Deg1 then + begin + Str(I, S); + ParamName := 'p' + S; + end + else + begin + Str(I - Deg1, S); + ParamName := 'q' + S; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = p0 + B^[1] = p1 B^[2] = p2 ... + + B^[Deg1 + 1] = q1 B^[Deg1 + 2] = q2 ... + -------------------------------------------------------------------- } + begin + RegFunc := RFrac(X, B, Deg1, Deg2); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + I : Integer; + Den : Float; + begin + { Compute denominator (1 + q1.x + q2.x^2 + ...) } + Den := 0.0; + for I := (Deg1 + Deg2) downto Succ(Deg1) do + Den := (Den + B^[I]) * X; + Den := 1.0 + Den; + + { dy/dp0 = 1 / (1 + q1.x + q2.x^2 + ...) } + D^[0] := 1.0 / Den; + + { dy/dpi = x^i / (1 + q1.x + q2.x^2 + ...) } + for I := 1 to Deg1 do + D^[I] := D^[I - 1] * X; + + { dy/dq1 = -x.y / (1 + q1.x + q2.x^2 + ...) } + D^[Deg1 + 1] := - X * Y / Den; + + { dy/dqi = -x^i.y / (1 + q1.x + q2.x^2 + ...) } + for I := (Deg1 + 2) to (Deg1 + Deg2) do + D^[I] := D^[I - 1] * X; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a rational fraction by linear regression: + y = p0 + p1.x + p2.x^2 + ... - q1.(x.y) - q2.(x^2.y) - ... + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + I, J : Integer; { Loop variables } + M : Integer; { Index of last fitted parameter } + U : PMatrix; { Matrix of independent variables } + V : PMatrix; { Variance-covariance matrix } + begin + M := LastParam; + DimMatrix(U, M, N); + DimMatrix(V, M, M); + + for J := 1 to N do + begin + U^[1]^[J] := X^[J]; + for I := 2 to Deg1 do + U^[I]^[J] := U^[I - 1]^[J] * X^[J]; + U^[Deg1 + 1]^[J] := - X^[J] * Y^[J]; + for I := (Deg1 + 2) to M do + U^[I]^[J] := U^[I - 1]^[J] * X^[J]; + end; + + case Method of + 0 : FitModel := MulFit(U, Y, N, M, ConsTerm, B, V); + 1 : FitModel := WMulFit(U, Y, W, N, M, ConsTerm, B, V); + end; + + if not ConsTerm then B^[0] := 0.0; + + DelMatrix(U, M, N); + DelMatrix(V, M, M); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = Degree of numerator + CstPar^[1] = Degree of denominator + CstPar^[2] = 1 to include a constant term (p0) + -------------------------------------------------------------------- } + var + D1, D2 : Integer; + begin + D1 := Round(CstPar^[0]); + D2 := Round(CstPar^[1]); + if D1 > 0 then Deg1 := D1; + if D2 > 0 then Deg2 := D2; + ConsTerm := (CstPar^[2] = 1); + end; + +end. diff --git a/npm_precl/dmath/fithill.pas b/npm_precl/dmath/fithill.pas new file mode 100755 index 0000000..69c1eee --- /dev/null +++ b/npm_precl/dmath/fithill.pas @@ -0,0 +1,182 @@ +{ ********************************************************************** + * Unit FITHILL.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the Hill equation : + + Ymax . x^n + y = ---------- + K^n + x^n + + ********************************************************************** } + +unit FitHill; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = Ymax . x^n / (K^n + x^n)'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'Ymax'; + 1 : ParamName := 'K '; + 2 : ParamName := 'n '; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = Ymax B^[1] = K B^[2] = n + -------------------------------------------------------------------- } + begin + if X = 0.0 then + if B^[2] > 0.0 then RegFunc := 0.0 else RegFunc := B^[0] + else + { Compute function according to y = Ymax / [1 + (K/x)^n] } + RegFunc := B^[0] / (1.0 + Power(B^[1] / X, B^[2])); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + Q, R, S : Float; + begin + if X = 0.0 then + begin + if B^[2] > 0.0 then D^[0] := 0.0 else D^[0] := 1.0; + D^[1] := 0.0; + D^[2] := 0.0; + end + else + begin + Q := Power(B^[1] / X, B^[2]); { (K/x)^n } + R := 1.0 / (1.0 + Q); { 1 / [1 + (K/x)^n] } + S := - Y * R * Q; { -Ymax.(K/x)^n / [1 + (K/x)^n]^2 } + + { dy/dYmax = 1 / [1 + (K/x)^n] } + D^[0] := R; + + { dy/dK = -Ymax.(K/x)^n.(n/K)/[1 + (K/x)^n]^2 } + D^[1] := S * B^[2] / B^[1]; + + { dy/dn = -Ymax.(K/x)^n.Ln(K/x)/[1 + (K/x)^n]^2 } + D^[2] := S * Log(B^[1] / X); + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the Hill equation by linear regression: + Ln(Ymax/y - 1) = n.Ln(K) - n.Ln(x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + Ymax : Float; { Estimated value of Ymax } + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + Ymax := Max(Y, 1, N); + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) and (Y^[K] < Ymax) then + begin + Inc(P); + X1^[P] := Log(X^[K]); + Y1^[P] := Log(Ymax / Y^[K] - 1.0); + W1^[P] := Sqr(Y^[K] * (1.0 - Y^[K] / Ymax)); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := Ymax; + B^[1] := Expo(- A^[0] / A^[1]); + B^[2] := - A^[1]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/npm_precl/dmath/fitiexpo.pas b/npm_precl/dmath/fitiexpo.pas new file mode 100755 index 0000000..153de74 --- /dev/null +++ b/npm_precl/dmath/fitiexpo.pas @@ -0,0 +1,147 @@ +{ ********************************************************************** + * Unit FITIEXPO.PAS * + * Version 1.2 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the increasing exponential : + + y = A.[1 - exp(-k.x)] + + ********************************************************************** } + +unit FitIExpo; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A[1 - exp(-k.x)]'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'k'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = A B^[1] = k + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * (1.0 - Expo(- B^[1] * X)); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + E : Float; + begin + E := Expo(- B^[1] * X); { exp(-k.x) } + D^[0] := 1.0 - E; { dy/dA = 1 - exp(-k.x) } + D^[1] := B^[0] * X * E; { dy/dk = A.x.exp(-k.x) } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the increasing exponential by linear regression: + Ln(1 - y/A) = -k.x + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + Y1 : PVector; { Transformed ordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + { Estimation of A } + B^[0] := 1.1 * Max(Y, 1, N); + + for K := 1 to N do + begin + Y1^[K] := Log(1.0 - Y^[K] / B^[0]); + W1^[K] := Sqr(Y^[K] - B^[0]); + if Method = 1 then W1^[K] := W1^[K] * W^[K]; + end; + + ErrCode := WLinFit(X, Y1, W1, N, A, V); + + if ErrCode = MAT_OK then + B^[1] := - A^[1]; + + FitModel := ErrCode; + + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/npm_precl/dmath/fitlin.pas b/npm_precl/dmath/fitlin.pas new file mode 100755 index 0000000..415d7ff --- /dev/null +++ b/npm_precl/dmath/fitlin.pas @@ -0,0 +1,102 @@ +{ ********************************************************************** + * Unit FITLIN.PAS * + * Version 1.0 * + * (c) J. Debord, April 1998 * + ********************************************************************** + This unit fits a linear function : + + y = a + b.x + + ********************************************************************** } + +unit FitLin; + +{$F+} + +interface + +uses + FMath, Matrices, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = a + b.x'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'a'; + 1 : ParamName := 'b'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = a B^[1] = b + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] + B^[1] * X; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Fit the straight line + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + V = variance-covariance matrix of the parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := LinFit(X, Y, N, B, V); + 1 : FitModel := WLinFit(X, Y, W, N, B, V); + end; + end; + +end. diff --git a/npm_precl/dmath/fitlogis.pas b/npm_precl/dmath/fitlogis.pas new file mode 100755 index 0000000..4452f4b --- /dev/null +++ b/npm_precl/dmath/fitlogis.pas @@ -0,0 +1,224 @@ +{ ********************************************************************** + * Unit FITLOGIS.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits the logistic function : + + B - A + y = A + ----------------- + 1 + exp(-a.x + b) + + ********************************************************************** } + +unit FitLogis; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + ConsTerm : Boolean = True; { Flags the presence of a constant term A } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + begin + if ConsTerm then + FuncName := 'y = A + (B - A) / [1 + exp(-a.x + b)]' + else + FuncName := 'y = B / [1 + exp(-a.x + b)]'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term A, 1 otherwise) + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 3; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'B'; + 2 : ParamName := 'a'; + 3 : ParamName := 'b'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters, such that : + B^[0] = A B^[1] = B B^[2] = a B^[3] = b + -------------------------------------------------------------------- } + begin + if ConsTerm then + RegFunc := B^[0] + (B^[1] - B^[0]) / (1.0 + Expo(- B^[2] * X + B^[3])) + else + RegFunc := B^[1] / (1.0 + Expo(- B^[2] * X + B^[3])); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + var + Q, R : Float; + begin + Q := Expo(- B^[2] * X + B^[3]); { exp(-ax+b) } + R := 1.0 / (1.0 + Q); { 1 / [1 + exp(-ax+b)] } + + D^[0] := 1.0 - R; { dy/dA = 1 - 1 / [1 + exp(-ax+b)] } + D^[1] := R; { dy/dB = 1 / [1 + exp(-ax+b)] } + + { dy/db = (A-B).exp(-ax+b) / [1 + exp(-ax+b)]^2 } + D^[3] := (B^[0] - B^[1]) * Q * Sqr(R); + + { dy/da = (B-A).x.exp(-ax+b) / [1 + exp(-ax+b)]^2 } + D^[2] := - D^[3] * X; + end; + + procedure SortPoints(X, Y : PVector; N : Integer); + { ---------------------------------------------------------------------- + Sort points by increasing X values + ---------------------------------------------------------------------- } + var + I, J, K : Integer; + A : Float; + begin + for I := 1 to Pred(N) do + begin + K := I; + A := X^[I]; + for J := Succ(I) to N do + if X^[J] < A then + begin + K := J; + A := X^[J]; + end; + FSwap(X^[I], X^[K]); + FSwap(Y^[I], Y^[K]); + end; + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a logistic function by linear regression: + Ln[(B - A)/(y - A) - 1] = -ax + b + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + XX : PVector; { Transformed X coordinates } + YY : PVector; { Transformed Y coordinates } + WW : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + D : Float; { B - A } + begin + DimVector(XX, N); + DimVector(YY, N); + DimVector(WW, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + SortPoints(X, Y, N); + + if ConsTerm then + B^[0] := Y^[1] + else + B^[0] := 0.0; + B^[1] := Y^[N]; + + P := 0; + D := B^[1] - B^[0]; + for K := 1 to N do + if (X^[K] > X^[1]) and (X^[K] < X^[N]) then + begin + Inc(P); + XX^[P] := X^[K]; + YY^[P] := Log(D / (Y^[K] - B^[0]) - 1.0); + WW^[P] := Sqr((Y^[K] - B^[0]) * (Y^[K] - B^[1]) / D); + if Method = 1 then WW^[P] := WW^[P] * W^[K]; + end; + + ErrCode := WLinFit(XX, YY, WW, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[2] := - A^[1]; + B^[3] := A^[0]; + end; + + FitModel := ErrCode; + + DelVector(XX, N); + DelVector(YY, N); + DelVector(WW, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit. + -------------------------------------------------------------------- + CstPar^[0] = 1 to include a constant term (A) + -------------------------------------------------------------------- } + begin + ConsTerm := (CstPar^[0] = 1); + end; + + end. diff --git a/npm_precl/dmath/fitmich.pas b/npm_precl/dmath/fitmich.pas new file mode 100755 index 0000000..1f80644 --- /dev/null +++ b/npm_precl/dmath/fitmich.pas @@ -0,0 +1,152 @@ +{ ********************************************************************** + * Unit FITMICH.PAS * + * Version 1.0 * + * (c) J. Debord, April 1998 * + ********************************************************************** + This unit fits the Michaelis equation : + + Ymax . x + y = -------- + Km + x + + ********************************************************************** } + +unit FitMich; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = Ymax . x / (Km + x)'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'Ymax'; + 1 : ParamName := 'Km '; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + + B^[0] = Ymax B^[1] = Km + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * X / (B^[1] + X); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter + -------------------------------------------------------------------- } + begin + D^[0] := Y / B^[0]; { dy/dYmax = x / (Km + x) } + D^[1] := - Y / (B^[1] + X); { dy/dKm = - Ymax.x / (Km + x)^2 } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the Michaelis equation by linear regression: + 1/y = 1/Ymax + (Km/Ymax) * (1/x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) then + begin + Inc(P); + X1^[P] := 1.0 / X^[K]; + Y1^[P] := 1.0 / Y^[K]; + W1^[P] := Sqr(Sqr(Y^[K])); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := 1.0 / A^[0]; + B^[1] := A^[1] / A^[0]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/npm_precl/dmath/fitmult.pas b/npm_precl/dmath/fitmult.pas new file mode 100755 index 0000000..4ac787b --- /dev/null +++ b/npm_precl/dmath/fitmult.pas @@ -0,0 +1,140 @@ +{ ********************************************************************** + * Unit FITMULT.PAS * + * Version 1.1 * + * (c) J. Debord, October 1998 * + ********************************************************************** + This unit fits the multiple linear equation: + + y = b0 + b1.x1 + b2.x2 + ... + + ********************************************************************** } + +unit FitMult; + +{$F+} + +interface + +uses + FMath, Matrices, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X, B : PVector) : Float; + +function FitModel(Method : Integer; X : PMatrix; Y, W : PVector; + N : Integer; B : PVector; V : PMatrix) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Nvar : Integer = 2; { Number of independent variables } + ConsTerm : Boolean = True; { Flags the presence of a constant term b0 } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = '; + if ConsTerm then + Name := Name + 'b0 + '; + Name := Name + 'b1.x1'; + for I := 2 to Nvar do + begin + Str(I, S); + Name := Name + ' + b' + S + '.x' + S; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + -------------------------------------------------------------------- } + begin + if ConsTerm then + FirstParam := 0 + else + FirstParam := 1; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := Nvar; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + var + S : String; + begin + Str(I, S); + ParamName := 'b' + S; + end; + + function RegFunc(X, B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at observation X + B is the vector of parameters. + -------------------------------------------------------------------- } + var + I : Integer; + Y : Float; + begin + if ConsTerm then Y := B^[0] else Y := 0.0; + for I := 1 to Nvar do + Y := Y + B^[I] * X^[I]; + RegFunc := Y; + end; + + function FitModel(Method : Integer; X : PMatrix; Y, W : PVector; + N : Integer; B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Multiple linear regression + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X = matrix of independent variables + Y = vector of dependent variable + W = vector of weights + N = number of observations + Output : B = estimated regression parameters + V = variance-covariance matrix of parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := MulFit(X, Y, N, Nvar, ConsTerm, B, V); + 1 : FitModel := WMulFit(X, Y, W, N, Nvar, ConsTerm, B, V); + end; + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit + -------------------------------------------------------------------- + CstPar^[0] = number of independent variables + CstPar^[1] = 1 to include a constant term (b0) + -------------------------------------------------------------------- } + begin + Nvar := Round(CstPar^[0]); + ConsTerm := (CstPar^[1] = 1); + end; + +end. diff --git a/npm_precl/dmath/fitpka.pas b/npm_precl/dmath/fitpka.pas new file mode 100755 index 0000000..2781082 --- /dev/null +++ b/npm_precl/dmath/fitpka.pas @@ -0,0 +1,163 @@ +{ ********************************************************************** + * Unit FITPKA.PAS * + * Version 1.1 * + * (c) J. Debord, July 1999 * + ********************************************************************** + This unit fits the acid/base titration function : + + B - A + y = A + ---------------- + 1 + 10^(pKa - x) + + where x is pH + y is some property (e.g. absorbance) which depends on the + ratio of the acidic and basic forms of the compound + A is the property for the pure acidic form + B is the property for the pure basic form + pKa is the acidity constant + ********************************************************************** } + +unit FitPKa; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X : Float; B, D : PVector); + +function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + begin + FuncName := 'y = A + (B - A) / [1 + 10^(pKa - x)]' + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted + (0 if there is a constant term A, 1 otherwise) + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted + -------------------------------------------------------------------- } + begin + LastParam := 2; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'B'; + 2 : ParamName := 'pKa'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X + B is the vector of parameters, such that : + B^[0] = A B^[1] = B B^[2] = pKa + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] + (B^[1] - B^[0]) / (1.0 + Exp10(B^[2] - X)); + end; + + procedure DerivProc(X : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point X + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + var + Q, R : Float; + begin + Q := Exp10(B^[2] - X); { 10^(pKa - x) } + R := 1.0 / (1.0 + Q); { 1/[1 + 10^(pKa - x)] } + + D^[0] := 1.0 - R; { dy/dA = 1 - 1/[1 + 10^(pKa - x)] } + D^[1] := R; { dy/dB = 1/[1 + 10^(pKa - x)] } + + { dy/dpKa = (A-B).10^(pKa - x).Ln(10) / [1 + 10^(pKa - x)]^2 } + D^[2] := (B^[0] - B^[1]) * Q * LN10 * Sqr(R); + end; + + procedure SortPoints(X, Y : PVector; N : Integer); + { ---------------------------------------------------------------------- + Sort points by increasing X values + ---------------------------------------------------------------------- } + var + I, J, K : Integer; + A : Float; + begin + for I := 1 to Pred(N) do + begin + K := I; + A := X^[I]; + for J := Succ(I) to N do + if X^[J] < A then + begin + K := J; + A := X^[J]; + end; + FSwap(X^[I], X^[K]); + FSwap(Y^[I], Y^[K]); + end; + end; + + function FitModel(X, Y : PVector; N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of the acid/base titration function + -------------------------------------------------------------------- + Input : X, Y = point coordinates + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + K : Integer; { Loop variable } + Z : Float; { (A + B) / 2 } + begin + SortPoints(X, Y, N); + + B^[0] := Y^[1]; + B^[1] := Y^[N]; + + Z := 0.5 * (B^[0] + B^[1]); + for K := 2 to N - 1 do + if Y^[K] = Z then + B^[2] := X^[K] + else if ((Y^[K] < Z) and (Y^[K + 1] > Z)) or + ((Y^[K] > Z) and (Y^[K + 1] < Z)) then + B^[2] := 0.5 * (X^[K] + X^[K + 1]); + + FitModel := 0; + end; + +end. diff --git a/npm_precl/dmath/fitpoly.pas b/npm_precl/dmath/fitpoly.pas new file mode 100755 index 0000000..d88903d --- /dev/null +++ b/npm_precl/dmath/fitpoly.pas @@ -0,0 +1,127 @@ +{ ********************************************************************** + * Unit FITPOLY.PAS * + * Version 1.2 * + * (c) J. Debord, March 1999 * + ********************************************************************** + This unit fits a polynomial : + + y = b0 + b1.x + b2.x^2 + ... + + ********************************************************************** } + +unit FitPoly; + +{$F+} + +interface + +uses + FMath, Matrices, Polynom, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + +procedure InitModel(CstPar : PVector); + + +implementation + +const + Deg : Integer = 2; { Degree of polynomial } + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + var + Name, S : String; + I : Integer; + begin + Name := 'y = b0 + b1.x'; + for I := 2 to Deg do + begin + Str(I, S); + Name := Name + ' + b' + S + '.x^' + S; + end; + FuncName := Name; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted. + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted. + -------------------------------------------------------------------- } + begin + LastParam := Deg; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + var + S : String; + begin + Str(I, S); + ParamName := 'b' + S; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters (coefficients of polynomial). + -------------------------------------------------------------------- } + begin + RegFunc := Poly(X, B, Deg); + end; + + function FitModel(Method : Integer; X, Y, W : PVector; N : Integer; + B : PVector; V : PMatrix) : Integer; + { -------------------------------------------------------------------- + Fit of polynomial. + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + V = variance-covariance matrix of parameters + -------------------------------------------------------------------- } + begin + case Method of + 0 : FitModel := PolFit(X, Y, N, Deg, B, V); + 1 : FitModel := WPolFit(X, Y, W, N, Deg, B, V); + end; + end; + + procedure InitModel(CstPar : PVector); + { -------------------------------------------------------------------- + Initializes the global variables of the unit. + -------------------------------------------------------------------- + CstPar^[0] = Degree of polynomial + -------------------------------------------------------------------- } + var + D : Integer; + begin + D := Round(CstPar^[0]); + if D > 1 then Deg := D; + end; + +end. diff --git a/npm_precl/dmath/fitpower.pas b/npm_precl/dmath/fitpower.pas new file mode 100755 index 0000000..c4f5ca4 --- /dev/null +++ b/npm_precl/dmath/fitpower.pas @@ -0,0 +1,150 @@ +{ ********************************************************************** + * Unit FITPOWER.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit fits a power function : + + y = A.x^n + + ********************************************************************** } + +unit FitPower; + +{$F+} + +interface + +uses + FMath, Matrices, Stat, Regress; + +function FuncName : String; + +function FirstParam : Integer; + +function LastParam : Integer; + +function ParamName(I : Integer) : String; + +function RegFunc(X : Float; B : PVector) : Float; + +procedure DerivProc(X, Y : Float; B, D : PVector); + +function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + +implementation + + function FuncName : String; + { -------------------------------------------------------------------- + Returns the name of the regression function. + -------------------------------------------------------------------- } + begin + FuncName := 'y = A.x^n'; + end; + + function FirstParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the first parameter to be fitted. + -------------------------------------------------------------------- } + begin + FirstParam := 0; + end; + + function LastParam : Integer; + { -------------------------------------------------------------------- + Returns the index of the last parameter to be fitted. + -------------------------------------------------------------------- } + begin + LastParam := 1; + end; + + function ParamName(I : Integer) : String; + { -------------------------------------------------------------------- + Returns the name of the I-th parameter. + -------------------------------------------------------------------- } + begin + case I of + 0 : ParamName := 'A'; + 1 : ParamName := 'n'; + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + { -------------------------------------------------------------------- + Computes the regression function at point X. + B is the vector of parameters, such that : + + B^[0] = A B^[1] = n + -------------------------------------------------------------------- } + begin + RegFunc := B^[0] * Power(X, B^[1]); + end; + + procedure DerivProc(X, Y : Float; B, D : PVector); + { -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + begin + D^[0] := Y / B^[0]; { dy/dA = x^n } + D^[1] := Y * Log(X); { dy/dk = A.x^n.Ln(x) } + end; + + function FitModel(Method : Integer; X, Y, W : PVector; + N : Integer; B : PVector) : Integer; + { -------------------------------------------------------------------- + Approximate fit of a power function by linear regression: + Ln(y) = Ln(A) + n.Ln(x) + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, Y = point coordinates + W = weights + N = number of points + Output : B = estimated regression parameters + -------------------------------------------------------------------- } + var + X1, Y1 : PVector; { Transformed coordinates } + W1 : PVector; { Weights } + A : PVector; { Linear regression parameters } + V : PMatrix; { Variance-covariance matrix } + P : Integer; { Number of points for linear regression } + K : Integer; { Loop variable } + ErrCode : Integer; { Error code } + begin + DimVector(X1, N); + DimVector(Y1, N); + DimVector(W1, N); + DimVector(A, 1); + DimMatrix(V, 1, 1); + + P := 0; + for K := 1 to N do + if (X^[K] > 0.0) and (Y^[K] > 0.0) then + begin + Inc(P); + X1^[P] := Log(X^[K]); + Y1^[P] := Log(Y^[K]); + W1^[P] := Sqr(Y^[K]); + if Method = 1 then W1^[P] := W1^[P] * W^[K]; + end; + + ErrCode := WLinFit(X1, Y1, W1, P, A, V); + + if ErrCode = MAT_OK then + begin + B^[0] := Expo(A^[0]); + B^[1] := A^[1]; + end; + + FitModel := ErrCode; + + DelVector(X1, N); + DelVector(Y1, N); + DelVector(W1, N); + DelVector(A, 1); + DelMatrix(V, 1, 1); + end; + + end. diff --git a/npm_precl/dmath/fmath.pas b/npm_precl/dmath/fmath.pas new file mode 100755 index 0000000..9e33f72 --- /dev/null +++ b/npm_precl/dmath/fmath.pas @@ -0,0 +1,2222 @@ +{ ********************************************************************** + * Unit FMATH.PAS * + * Version 2.4 * + * (c) J. Debord, June 2001 * + ********************************************************************** + This unit implements some mathematical functions in Pascal + ********************************************************************** + Notes: + + 1) The default real type is DOUBLE (8-byte real). Depending on the + compiler, other types may be selected by defining the symbols: + + ------------------------------------------------------- + Symbol Type TP-BP-Delphi FPC GPC + ------------------------------------------------------- + SINGLEREAL Single X X X + PASCALREAL Real X + EXTENDEDREAL Extended X X X + ------------------------------------------------------- + Note: "Real" is equivalent to "Double" in FPC and GPC + + 2) Error handling: The function MathError returns the error code from + the last function evaluation. It must be checked immediately after + a function call: + + Y := f(X); (* f is one of the functions of the library *) + if MathError = FN_OK then ... + + The possible error codes, and the default values attributed to the + function, are the following: + + ------------------------------------------------------------------ + Error code Value Significance Function default value + ------------------------------------------------------------------ + FN_OK 0 No error + FN_DOMAIN -1 Argument domain error 0 + FN_SING -2 Function singularity +/- MAXNUM + FN_OVERFLOW -3 Overflow range error MAXNUM + FN_UNDERFLOW -4 Underflow range error 0 + ------------------------------------------------------------------ + + where MAXNUM is a constant defining the highest number which may be + represented within the chosen floating point type. + + The standard functions Exp and Ln have been redefined according to + the above conventions as Expo and Log. + + 3) Assembler functions: some functions are written in assembler. There + are two versions: + + * One for BP 7 or Delphi 1 with a 387, 486 or Pentium processor. + This version may be selected by defining the symbol CPU387 + + * The other for FPC with a Pentium II or Pentium III processor. + This version may be selected by defining the symbol CPUP2 + Units and programs must be compiled with the options -Si + and -Rintel (e.g. ppc386 -Si -Rintel -dCPUP2 fmath) + + Once you have selected a version you have two possibilities: + + * Call the Pascal functions (e.g. Expo, ArcSin...). This will + provide some acceleration while keeping the error handling. + + * Call the assembler functions directly (e.g. fExp, fArcSin...) + This will provide further acceleration but without error handling. + Thus it is the responsibility of the calling program to check the + arguments passed to the function. See the interface files + MATH387.INT and MATHP2.INT for a list of available functions. + + ********************************************************************** } + +unit FMath; + +interface + +{ ---------------------------------------------------------------------- + Floating point type (Default = Double) + ---------------------------------------------------------------------- } + +{$IFDEF __GPC__} + {$UNDEF PASCALREAL} +{$ENDIF} + +{$IFDEF FPK} + {$UNDEF PASCALREAL} +{$ENDIF} + +{$IFDEF PASCALREAL} + {$IFDEF VER120} + type Float = Real48; { Delphi 4 } + {$ELSE} + type Float = Real; + {$ENDIF} +{$ELSE} +{$IFDEF SINGLEREAL} + type Float = Single; +{$ELSE} +{$IFDEF EXTENDEDREAL} + type Float = Extended; +{$ELSE} + {$DEFINE DOUBLEREAL} + type Float = Double; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Mathematical constants + ---------------------------------------------------------------------- } + +const + PI = 3.14159265358979323846; { Pi } + LN2 = 0.69314718055994530942; { Ln(2) } + LN10 = 2.30258509299404568402; { Ln(10) } + LNPI = 1.14472988584940017414; { Ln(Pi) } + INVLN2 = 1.44269504088896340736; { 1/Ln(2) } + INVLN10 = 0.43429448190325182765; { 1/Ln(10) } + TWOPI = 6.28318530717958647693; { 2*Pi } + PIDIV2 = 1.57079632679489661923; { Pi/2 } + SQRTPI = 1.77245385090551602730; { Sqrt(Pi) } + SQRT2PI = 2.50662827463100050242; { Sqrt(2*Pi) } + INVSQRT2PI = 0.39894228040143267794; { 1/Sqrt(2*Pi) } + LNSQRT2PI = 0.91893853320467274178; { Ln(Sqrt(2*Pi)) } + LN2PIDIV2 = 0.91893853320467274178; { Ln(2*Pi)/2 } + SQRT2 = 1.41421356237309504880; { Sqrt(2) } + SQRT2DIV2 = 0.70710678118654752440; { Sqrt(2)/2 } + GOLD = 1.61803398874989484821; { Golden Mean = (1 + Sqrt(5))/2 } + CGOLD = 0.38196601125010515179; { 2 - GOLD } + +{ ---------------------------------------------------------------------- + Machine-dependent constants + ---------------------------------------------------------------------- } + +{$IFDEF SINGLEREAL} +const + MACHEP = 1.192093E-7; { Floating point precision: 2^(-23) } + MAXNUM = 3.402823E+38; { Max. floating point number: 2^128 } + MINNUM = 1.175495E-38; { Min. floating point number: 2^(-126) } + MAXLOG = 88.72283; { Max. argument for Exp = Ln(MAXNUM) } + MINLOG = -87.33655; { Min. argument for Exp = Ln(MINNUM) } + MAXFAC = 33; { Max. argument for Factorial } + MAXGAM = 34.648; { Max. argument for Gamma } + MAXLGM = 1.0383E+36; { Max. argument for LnGamma } +{$ELSE} +{$IFDEF DOUBLEREAL} +const + MACHEP = 2.220446049250313E-16; { 2^(-52) } + MAXNUM = 1.797693134862315E+308; { 2^1024 } + MINNUM = 2.225073858507202E-308; { 2^(-1022) } + MAXLOG = 709.7827128933840; + MINLOG = -708.3964185322641; + MAXFAC = 170; + MAXGAM = 171.624376956302; + MAXLGM = 2.556348E+305; +{$ELSE} +{$IFDEF EXTENDEDREAL} +const + MACHEP = 1.08420217248550444E-19; { 2^(-63) } + MAXNUM = 1.18973149535723103E+4932; { 2^16384 } + MINNUM = 3.36210314311209558E-4932; { 2^(-16382) } + MAXLOG = 11356.5234062941439; + MINLOG = - 11355.137111933024; + MAXFAC = 1754; + MAXGAM = 1755.455; + MAXLGM = 1.04848146839019521E+4928; +{$ELSE} +{$IFDEF PASCALREAL} +const + MACHEP = 1.818989404E-12; { 2^(-39) } + MAXNUM = 4.253529586E+37; { 2^126 } + MINNUM = 2.350988703E-38; { 2^(-125) } + MAXLOG = 8.664339757E+01; + MINLOG = - 4.253529586E+01; + MAXFAC = 33; + MAXGAM = 34.64809785; + MAXLGM = 1.038324114E+36; +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Error codes for mathematical functions + ---------------------------------------------------------------------- } + +const + FN_OK = 0; { No error } + FN_DOMAIN = - 1; { Argument domain error } + FN_SING = - 2; { Function singularity } + FN_OVERFLOW = - 3; { Overflow range error } + FN_UNDERFLOW = - 4; { Underflow range error } + FN_TLOSS = - 5; { Total loss of precision } + FN_PLOSS = - 6; { Partial loss of precision } + +{ ---------------------------------------------------------------------- + Global variables and constants + ---------------------------------------------------------------------- } + +const + NFACT = 33; { The factorials of the first NFACT integers are stored + in a table } +var + MathErr : Integer; { Error code from the latest function evaluation } + + FactArray : array[0..NFACT] of Float; { Table of factorials } + +{ ---------------------------------------------------------------------- + Functional type + ---------------------------------------------------------------------- } + +type + TFunc = function(X : Float) : Float; + +{ ---------------------------------------------------------------------- + Error handling function + ---------------------------------------------------------------------- } + +function MathError : Integer; { Error code from the last function call } + +{ ---------------------------------------------------------------------- + Minimum, maximum, sign and exchange + ---------------------------------------------------------------------- } + +function FMin(X, Y : Float) : Float; { Minimum of 2 reals } +function FMax(X, Y : Float) : Float; { Maximum of 2 reals } +function IMin(X, Y : Integer) : Integer; { Minimum of 2 integers } +function IMax(X, Y : Integer) : Integer; { Maximum of 2 integers } +function Sgn(X : Float) : Integer; { Sign (returns 1 if X = 0) } +function Sgn0(X : Float) : Integer; { Sign (returns 0 if X = 0) } + +procedure FSwap(var X, Y : Float); { Exchange 2 reals } +procedure ISwap(var X, Y : Integer); { Exchange 2 integers } + +{ ---------------------------------------------------------------------- + Assembler functions + ---------------------------------------------------------------------- } + +{$IFDEF CPU387} + {$UNDEF CPUP2} + {$I MATH387.INT} +{$ENDIF} + +{$IFDEF CPUP2} + {$UNDEF CPU387} + {$I MATHP2.INT} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Sign, logarithms, exponentials and power + ---------------------------------------------------------------------- } + +function Expo(X : Float) : Float; { Exponential } +function Exp2(X : Float) : Float; { 2^X } +function Exp10(X : Float) : Float; { 10^X } +function Log(X : Float) : Float; { Natural log } +function Log2(X : Float) : Float; { Log, base 2 } +function Log10(X : Float) : Float; { Decimal log } +function LogA(X, A : Float) : Float; { Log, base A } +function IntPower(X : Float; N : Integer) : Float; { X^N } +function Power(X, Y : Float) : Float; { X^Y, X >= 0 } +function Pythag(X, Y : Float) : Float; { Sqrt(X^2 + Y^2) } + +{ ---------------------------------------------------------------------- + Trigonometric and inverse trigonometric functions + ---------------------------------------------------------------------- } + +function FixAngle(Theta : Float) : Float; { Set Theta in -Pi..Pi } +function Tan(X : Float) : Float; { Tangent } +function ArcSin(X : Float) : Float; { Arc sinus } +function ArcCos(X : Float) : Float; { Arc cosinus } +function ArcTan2(Y, X : Float) : Float; { Angle (Ox, OM) with M(X,Y) } + +procedure SinCos(X : Float; var SinX, CosX : Float); { Sin & Cos } + +{ ---------------------------------------------------------------------- + Hyperbolic and inverse hyperbolic functions + ---------------------------------------------------------------------- } + +function Sinh(X : Float) : Float; { Hyperbolic sine } +function Cosh(X : Float) : Float; { Hyperbolic cosine } +function Tanh(X : Float) : Float; { Hyperbolic tangent } +function ArcSinh(X : Float) : Float; { Inverse hyperbolic sine } +function ArcCosh(X : Float) : Float; { Inverse hyperbolic cosine } +function ArcTanh(X : Float) : Float; { Inverse hyperbolic tangent } + +procedure SinhCosh(X : Float; var SinhX, CoshX : Float); { Sinh & Cosh } + +{ ---------------------------------------------------------------------- + Special functions + ---------------------------------------------------------------------- } + +function Fact(N : Integer) : Float; { Factorial } +function Binomial(N, K : Integer) : Float; { Binomial coef. C(N,K) } +function Gamma(X : Float) : Float; { Gamma function } +function SgnGamma(X : Float) : Integer; { Sign of Gamma function } +function LnGamma(X : Float) : Float; { Log(|Gamma(X)|) } +function IGamma(A, X : Float) : Float; { Incomplete Gamma function } +function JGamma(A, X : Float) : Float; { Complement of IGamma } +function Beta(X, Y : Float) : Float; { Beta function } +function IBeta(A, B, X : Float) : Float; { Incomplete Beta function } +function Erf(X : Float) : Float; { Error function } +function Erfc(X : Float) : Float; { Complement of Erf } + +{ ---------------------------------------------------------------------- + Binomial distribution with probability P and number of repetitions N + ---------------------------------------------------------------------- } + +function PBinom(N : Integer; P : Float; K : Integer) : Float; { Prob(X = K) } +function FBinom(N : Integer; P : Float; K : Integer) : Float; { Prob(X <= K) } + +{ ---------------------------------------------------------------------- + Poisson distribution with mean Mu + ---------------------------------------------------------------------- } + +function PPoisson(Mu : Float; K : Integer) : Float; { Prob(X = K) } +function FPoisson(Mu : Float; K : Integer) : Float; { Prob(X <= K) } + +{ ---------------------------------------------------------------------- + Standard normal distribution + ---------------------------------------------------------------------- } + +function DNorm(X : Float) : Float; { Density of standard normal } +function FNorm(X : Float) : Float; { Prob(U <= X) } +function PNorm(X : Float) : Float; { Prob(|U| >= |X|) } +function InvNorm(P : Float) : Float; { Inverse of FNorm : returns X + such that Prob(U <= X) = P} + +{ ---------------------------------------------------------------------- + Student distribution with Nu d.o.f. + ---------------------------------------------------------------------- } + +function DStudent(Nu : Integer; X : Float) : Float; { Density of t } +function FStudent(Nu : Integer; X : Float) : Float; { Prob(t <= X) } +function PStudent(Nu : Integer; X : Float) : Float; { Prob(|t| >= |X|) } + +{ ---------------------------------------------------------------------- + Khi-2 distribution with Nu d.o.f. + ---------------------------------------------------------------------- } + +function DKhi2(Nu : Integer; X : Float) : Float; { Density of Khi2 } +function FKhi2(Nu : Integer; X : Float) : Float; { Prob(Khi2 <= X) } +function PKhi2(Nu : Integer; X : Float) : Float; { Prob(Khi2 >= X) } + +{ ---------------------------------------------------------------------- + Fisher-Snedecor distribution with Nu1 and Nu2 d.o.f. + ---------------------------------------------------------------------- } + +function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Density of F } +function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Prob(F <= X) } +function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; { Prob(F >= X) } + +{ ---------------------------------------------------------------------- + Exponential distribution + ---------------------------------------------------------------------- } + +function DExpo(A, X : Float) : Float; { Density of exponential distrib. } +function FExpo(A, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Beta distribution + ---------------------------------------------------------------------- } + +function DBeta(A, B, X : Float) : Float; { Density of Beta distribution } +function FBeta(A, B, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Gamma distribution + ---------------------------------------------------------------------- } + +function DGamma(A, B, X : Float) : Float; { Density of Gamma distribution } +function FGamma(A, B, X : Float) : Float; { Prob( <= X) } + +{ ---------------------------------------------------------------------- + Random numbers + ---------------------------------------------------------------------- } + +procedure RMarIn(Seed1, Seed2 : Integer); +{ Initializes the random number generator. + The default initialization corresponds to RMarIn(1802, 9373) } + +function IRanMar : LongInt; +{ Returns a 32 bit random number in [ -2,147,483,648 ; 2,147,483,647 ] } + +function RanMar : Float; +{ Returns a random number in [0, 1[ } + +function RanGaussStd : Float; +{ Returns a random number from the standard normal distribution + (i.e. the Gaussian distribution with zero mean and unit variance) } + +function RanGauss(Mu, Sigma : Float) : Float; +{ Returns a random number from a Gaussian distribution + with mean Mu and standard deviation Sigma } + +{ ********************************************************************** } + +implementation + +{ ---------------------------------------------------------------------- + Error handling functions + ---------------------------------------------------------------------- } + + function DefaultVal(ErrCode : Integer) : Float; + { Sets the global variable MathErr and the function default value + according to the error code } + begin + MathErr := ErrCode; + case ErrCode of + FN_DOMAIN : DefaultVal := 0.0; + FN_SING : DefaultVal := MAXNUM; + FN_OVERFLOW : DefaultVal := MAXNUM; + FN_UNDERFLOW : DefaultVal := 0.0; + else + DefaultVal := 0.0; + end; + end; + + function MathError : Integer; + begin + MathError := MathErr; + end; + +{ ---------------------------------------------------------------------- + Minimum, maximum and sign + ---------------------------------------------------------------------- } + + function FMin(X, Y : Float) : Float; + begin + if X <= Y then + FMin := X + else + FMin := Y; + end; + + function FMax(X, Y : Float) : Float; + begin + if X >= Y then + FMax := X + else + FMax := Y; + end; + + function IMin(X, Y : Integer) : Integer; + begin + if X <= Y then + IMin := X + else + IMin := Y; + end; + + function IMax(X, Y : Integer) : Integer; + begin + if X >= Y then + IMax := X + else + IMax := Y; + end; + + procedure FSwap(var X, Y : Float); + var + Temp : Float; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + procedure ISwap(var X, Y : Integer); + var + Temp : Integer; + begin + Temp := X; + X := Y; + Y := Temp; + end; + + function Sgn(X : Float) : Integer; + begin + if X >= 0.0 then + Sgn := 1 + else + Sgn := - 1; + end; + + function Sgn0(X : Float) : Integer; + begin + if X > 0.0 then + Sgn0 := 1 + else if X = 0.0 then + Sgn0 := 0 + else + Sgn0 := - 1; + end; + +{ ---------------------------------------------------------------------- + Assembler functions + ---------------------------------------------------------------------- } + +{$IFDEF CPU387} + {$I MATH387.INC} + {$DEFINE USE_ASM} +{$ENDIF} + +{$IFDEF CPUP2} + {$I MATHP2.INC} + {$DEFINE USE_ASM} +{$ENDIF} + +{ ---------------------------------------------------------------------- + Elementary functions + ---------------------------------------------------------------------- } + + function Expo(X : Float) : Float; + begin + MathErr := FN_OK; + if X < MINLOG then + Expo := DefaultVal(FN_UNDERFLOW) + else if X > MAXLOG then + Expo := DefaultVal(FN_OVERFLOW) + else + Expo := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + end; + + function Exp2(X : Float) : Float; + var + XLn2 : Float; + begin + MathErr := FN_OK; + XLn2 := X * LN2; + if XLn2 < MINLOG then + Exp2 := DefaultVal(FN_UNDERFLOW) + else if XLn2 > MAXLOG then + Exp2 := DefaultVal(FN_OVERFLOW) + else + Exp2 := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(XLn2); + end; + + function Exp10(X : Float) : Float; + var + XLn10 : Float; + begin + MathErr := FN_OK; + XLn10 := X * LN10; + if XLn10 < MINLOG then + Exp10 := DefaultVal(FN_UNDERFLOW) + else if XLn10 > MAXLOG then + Exp10 := DefaultVal(FN_OVERFLOW) + else + Exp10 := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(XLn10); + end; + + function Log(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log := DefaultVal(FN_SING) + else + Log := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + end; + + function Log10(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log10 := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log10 := DefaultVal(FN_SING) + else + Log10 := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * INVLN10; + end; + + function Log2(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + Log2 := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + Log2 := DefaultVal(FN_SING) + else + Log2 := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * INVLN2; + end; + + function LogA(X, A : Float) : Float; + begin + MathErr := FN_OK; + if (X < 0.0) or (A <= 0.0) or (A = 1.0) then + LogA := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + LogA := Sgn(1.0 - A) * DefaultVal(FN_SING) + else + {$IFDEF USE_ASM} + LogA := fLn(X) / fLn(A); + {$ELSE} + LogA := Ln(X) / Ln(A); + {$ENDIF} + end; + + function IntPower(X : Float; N : Integer) : Float; + { Computes X^N by repeated multiplications } + var + M : Integer; + T : Float; + begin + MathErr := FN_OK; + + if X = 0.0 then + begin + if N = 0 then { 0^0 = lim x^x = 1 } + IntPower := 1.0 { x->0 } + else if N > 0 then + IntPower := 0.0 { 0^N = 0 } + else + IntPower := DefaultVal(FN_SING); + Exit; + end; + + if N = 0 then + begin + IntPower := 1.0; + Exit; + end; + + { Legendre's algorithm for minimizing the number of multiplications } + T := 1.0; + M := Abs(N); + repeat + if Odd(M) then + begin + Dec(M); + T := T * X; + end + else + begin + M := M div 2; + X := Sqr(X); + end; + until M = 0; + + if N > 0 then IntPower := T else IntPower := 1.0 / T; + end; + + function Power(X, Y : Float) : Float; + { Computes X^Y = Exp(Y * Ln(X)), for X >= 0 } + var + YLnX : Float; + begin + MathErr := FN_OK; + if X < 0.0 then + begin + Power := DefaultVal(FN_DOMAIN); + Exit; + end; + + if X = 0.0 then + begin + if Y = 0.0 then { 0^0 = lim x^x = 1 } + Power := 1.0 { x->0 } + else if Y > 0.0 then + Power := 0.0 { 0^Y = 0 } + else + Power := DefaultVal(FN_SING); + Exit; + end; + + if Y = 0.0 then + begin + Power := 1.0; + Exit; + end; + + YLnX := Y * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + + if YLnX < MINLOG then + Power := DefaultVal(FN_UNDERFLOW) + else if YLnX > MAXLOG then + Power := DefaultVal(FN_OVERFLOW) + else + Power := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(YLnX); + end; + + function Pythag(X, Y : Float) : Float; + { Computes Sqrt(X^2 + Y^2) without destructive underflow or overflow } + var + AbsX, AbsY : Float; + begin + MathErr := FN_OK; + AbsX := Abs(X); + AbsY := Abs(Y); + if AbsX > AbsY then + Pythag := AbsX * Sqrt(1.0 + Sqr(AbsY / AbsX)) + else if AbsY = 0.0 then + Pythag := 0.0 + else + Pythag := AbsY * Sqrt(1.0 + Sqr(AbsX / AbsY)); + end; + + procedure SinCos(X : Float; var SinX, CosX : Float); + begin + MathErr := FN_OK; + SinX := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(X); + CosX := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(X); + end; + + function FixAngle(Theta : Float) : Float; + begin + MathErr := FN_OK; + while Theta > PI do + Theta := Theta - TWOPI; + while Theta <= - PI do + Theta := Theta + TWOPI; + FixAngle := Theta; + end; + + function Tan(X : Float) : Float; + var + SinX, CosX : Float; + begin + MathErr := FN_OK; + SinX := {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(X); + CosX := {$IFDEF USE_ASM}fCos{$ELSE}Cos{$ENDIF}(X); + if CosX = 0.0 then + Tan := Sgn(SinX) * DefaultVal(FN_SING) + else + Tan := SinX / CosX; + end; + + function ArcSin(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcSin := DefaultVal(FN_DOMAIN) + else if X = 1.0 then + ArcSin := PIDIV2 + else if X = - 1.0 then + ArcSin := - PIDIV2 + else + ArcSin := {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcCos(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcCos := DefaultVal(FN_DOMAIN) + else if X = 1.0 then + ArcCos := 0.0 + else if X = - 1.0 then + ArcCos := PI + else + ArcCos := PIDIV2 - {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(X / Sqrt(1.0 - Sqr(X))); + end; + + function ArcTan2(Y, X : Float) : Float; + var + Theta : Float; + begin + MathErr := FN_OK; + if X = 0.0 then + if Y = 0.0 then + ArcTan2 := 0.0 + else if Y > 0.0 then + ArcTan2 := PIDIV2 + else + ArcTan2 := - PIDIV2 + else + begin + { 4th/1st quadrant -PI/2..PI/2 } + Theta := {$IFDEF USE_ASM}fArcTan{$ELSE}ArcTan{$ENDIF}(Y / X); + + { 2nd/3rd quadrants } + if X < 0.0 then + if Y >= 0.0 then + Theta := Theta + PI { 2nd quadrant: PI/2..PI } + else + Theta := Theta - PI; { 3rd quadrant: -PI..-PI/2 } + ArcTan2 := Theta; + end; + end; + +{ ---------------------------------------------------------------------- + Hyperbolic functions + ---------------------------------------------------------------------- } + + function Sinh(X : Float) : Float; + var + ExpX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + Sinh := Sgn(X) * DefaultVal(FN_OVERFLOW) + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + Sinh := 0.5 * (ExpX - 1.0 / ExpX); + end; + end; + + function Cosh(X : Float) : Float; + var + ExpX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + Cosh := DefaultVal(FN_OVERFLOW) + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + Cosh := 0.5 * (ExpX + 1.0 / ExpX); + end; + end; + + procedure SinhCosh(X : Float; var SinhX, CoshX : Float); + var + ExpX, ExpMinusX : Float; + begin + MathErr := FN_OK; + if (X < MINLOG) or (X > MAXLOG) then + begin + CoshX := DefaultVal(FN_OVERFLOW); + SinhX := Sgn(X) * CoshX; + end + else + begin + ExpX := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(X); + ExpMinusX := 1.0 / ExpX; + SinhX := 0.5 * (ExpX - ExpMinusX); + CoshX := 0.5 * (ExpX + ExpMinusX); + end; + end; + + function Tanh(X : Float) : Float; + var + SinhX, CoshX : Float; + begin + SinhCosh(X, SinhX, CoshX); + Tanh := SinhX / CoshX; + end; + + function ArcSinh(X : Float) : Float; + begin + MathErr := FN_OK; + ArcSinh := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X + Sqrt(Sqr(X) + 1.0)); + end; + + function ArcCosh(X : Float) : Float; + begin + MathErr := FN_OK; + if X < 1.0 then + ArcCosh := DefaultVal(FN_DOMAIN) + else + ArcCosh := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X + Sqrt(Sqr(X) - 1.0)); + end; + + function ArcTanh(X : Float) : Float; + begin + MathErr := FN_OK; + if (X < - 1.0) or (X > 1.0) then + ArcTanh := DefaultVal(FN_DOMAIN) + else if (X = - 1.0) or (X = 1.0) then + ArcTanh := Sgn(X) * DefaultVal(FN_SING) + else + ArcTanh := 0.5 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}((1.0 + X) / (1.0 - X)); + end; + +{ ---------------------------------------------------------------------- + Special functions (translated from Cephes math library by S. Moshier: + http://www.netlib.org/cephes) + ---------------------------------------------------------------------- } + +const { Used by IGamma and IBeta } + BIG = 9.223372036854775808E18; + BIGINV = 1.084202172485504434007E-19; + +type + TabCoef = array[0..9] of Float; + + function PolEvl(var X : Float; var Coef : TabCoef; N : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates polynomial of degree N: + + 2 N + y = C + C x + C x +...+ C x + 0 1 2 N + + Coefficients are stored in reverse order: + + Coef[0] = C , ..., Coef[N] = C + N 0 + + The function P1Evl() assumes that Coef[N] = 1.0 and is + omitted from the array. Its calling arguments are + otherwise the same as PolEvl(). + ---------------------------------------------------------------------- } + var + Ans : Float; + I : Integer; + begin + Ans := Coef[0]; + for I := 1 to N do + Ans := Ans * X + Coef[I]; + PolEvl := Ans; + end; + + function P1Evl(var X : Float; var Coef : TabCoef; N : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluate polynomial when coefficient of X is 1.0. + Otherwise same as PolEvl. + ---------------------------------------------------------------------- } + var + Ans : Float; + I : Integer; + begin + Ans := X + Coef[0]; + for I := 1 to N - 1 do + Ans := Ans * X + Coef[I]; + P1Evl := Ans; + end; + + function SgnGamma(X : Float) : Integer; + begin + if X > 0.0 then + SgnGamma := 1 + else if Odd(Trunc(Abs(X))) then + SgnGamma := 1 + else + SgnGamma := - 1; + end; + + function Stirf(X : Float) : Float; + { Stirling's formula for the gamma function + Gamma(x) = Sqrt(2*Pi) x^(x-.5) exp(-x) (1 + 1/x P(1/x)) + where P(x) is a polynomial } + const + STIR : TabCoef = ( + 7.147391378143610789273E-4, + - 2.363848809501759061727E-5, + - 5.950237554056330156018E-4, + 6.989332260623193171870E-5, + 7.840334842744753003862E-4, + - 2.294719747873185405699E-4, + - 2.681327161876304418288E-3, + 3.472222222230075327854E-3, + 8.333333333333331800504E-2, + 0); + + var + W, P : Float; + begin + W := 1.0 / X; + if X > 1024.0 then + begin + P := 6.97281375836585777429E-5 * W + 7.84039221720066627474E-4; + P := P * W - 2.29472093621399176955E-4; + P := P * W - 2.68132716049382716049E-3; + P := P * W + 3.47222222222222222222E-3; + P := P * W + 8.33333333333333333333E-2; + end + else + P := PolEvl(W, STIR, 8); + {$IFDEF USE_ASM} + Stirf := SQRT2PI * fExp((X - 0.5) * fLn(X) - X) * (1.0 + W * P); + {$ELSE} + Stirf := SQRT2PI * Exp((X - 0.5) * Ln(X) - X) * (1.0 + W * P); + {$ENDIF} + end; + + function GamSmall(X1, Z : Float) : Float; + { Gamma function for small values of the argument } + const + S : TabCoef = ( + - 1.193945051381510095614E-3, + 7.220599478036909672331E-3, + - 9.622023360406271645744E-3, + - 4.219773360705915470089E-2, + 1.665386113720805206758E-1, + - 4.200263503403344054473E-2, + - 6.558780715202540684668E-1, + 5.772156649015328608253E-1, + 1.000000000000000000000E0, + 0); + + SN : TabCoef = ( + 1.133374167243894382010E-3, + 7.220837261893170325704E-3, + 9.621911155035976733706E-3, + - 4.219773343731191721664E-2, + - 1.665386113944413519335E-1, + - 4.200263503402112910504E-2, + 6.558780715202536547116E-1, + 5.772156649015328608727E-1, + - 1.000000000000000000000E0, + 0); + + var + P : Float; + begin + if X1 = 0.0 then + begin + GamSmall := DefaultVal(FN_SING); + Exit; + end; + if X1 < 0.0 then + begin + X1 := - X1; + P := PolEvl(X1, SN, 8); + end + else + P := PolEvl(X1, S, 8); + GamSmall := Z / (X1 * P); + end; + + function StirfL(X : Float) : Float; + { Approximate Ln(Gamma) by Stirling's formula, for X >= 13 } + const + P : TabCoef = ( + 4.885026142432270781165E-3, + - 1.880801938119376907179E-3, + 8.412723297322498080632E-4, + - 5.952345851765688514613E-4, + 7.936507795855070755671E-4, + - 2.777777777750349603440E-3, + 8.333333333333331447505E-2, + 0, 0, 0); + + var + Q, W : Float; + begin + Q := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) * (X - 0.5) - X; + Q := Q + LNSQRT2PI; + if X > 1.0E+10 then + StirfL := Q + else + begin + W := 1.0 / Sqr(X); + StirfL := Q + PolEvl(W, P, 6) / X; + end; + end; + + function Gamma(X : Float) : Float; + const + P : TabCoef = ( + 4.212760487471622013093E-5, + 4.542931960608009155600E-4, + 4.092666828394035500949E-3, + 2.385363243461108252554E-2, + 1.113062816019361559013E-1, + 3.629515436640239168939E-1, + 8.378004301573126728826E-1, + 1.000000000000000000009E0, + 0, 0); + + Q : TabCoef = ( + - 1.397148517476170440917E-5, + 2.346584059160635244282E-4, + - 1.237799246653152231188E-3, + - 7.955933682494738320586E-4, + 2.773706565840072979165E-2, + - 4.633887671244534213831E-2, + - 2.243510905670329164562E-1, + 4.150160950588455434583E-1, + 9.999999999999999999908E-1, + 0); + + var + SgnGam, N : Integer; + A, X1, Z : Float; + begin + MathErr := FN_OK; + SgnGam := SgnGamma(X); + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + Gamma := SgnGam * DefaultVal(FN_SING); + Exit; + end; + + if X > MAXGAM then + begin + Gamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + + A := Abs(X); + if A > 13.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := A - N; + end; + Z := Abs(A * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(PI * Z)) * Stirf(A); + if Z <= PI / MAXNUM then + begin + Gamma := SgnGam * DefaultVal(FN_OVERFLOW); + Exit; + end; + Z := PI / Z; + end + else + Z := Stirf(X); + Gamma := SgnGam * Z; + end + else + begin + Z := 1.0; + X1 := X; + while X1 >= 3.0 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < - 0.03125 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if X1 <= 0.03125 then + Gamma := GamSmall(X1, Z) + else + begin + while X1 < 2.0 do + begin + Z := Z / X1; + X1 := X1 + 1.0; + end; + if (X1 = 2.0) or (X1 = 3.0) then + Gamma := Z + else + begin + X1 := X1 - 2.0; + Gamma := Z * PolEvl(X1, P, 7) / PolEvl(X1, Q, 8); + end; + end; + end; + end; + + function LnGamma(X : Float) : Float; + const + P : TabCoef = ( + - 2.163690827643812857640E3, + - 8.723871522843511459790E4, + - 1.104326814691464261197E6, + - 6.111225012005214299996E6, + - 1.625568062543700591014E7, + - 2.003937418103815175475E7, + - 8.875666783650703802159E6, + 0, 0, 0); + + Q : TabCoef = ( + - 5.139481484435370143617E2, + - 3.403570840534304670537E4, + - 6.227441164066219501697E5, + - 4.814940379411882186630E6, + - 1.785433287045078156959E7, + - 3.138646407656182662088E7, + - 2.099336717757895876142E7, + 0, 0, 0); + + var + N : Integer; + A, X1, Z : Float; + begin + MathErr := FN_OK; + + if (X = 0.0) or ((X < 0.0) and (Frac(X) = 0.0)) then + begin + LnGamma := DefaultVal(FN_SING); + Exit; + end; + + if X > MAXLGM then + begin + LnGamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + + A := Abs(X); + if A > 34.0 then + begin + if X < 0.0 then + begin + N := Trunc(A); + Z := A - N; + if Z > 0.5 then + begin + N := N + 1; + Z := N - A; + end; + Z := A * {$IFDEF USE_ASM}fSin{$ELSE}Sin{$ENDIF}(PI * Z); + if Z = 0.0 then + begin + LnGamma := DefaultVal(FN_OVERFLOW); + Exit; + end; + Z := LNPI - {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z) - StirfL(A); + end + else + Z := StirfL(X); + LnGamma := Z; + end + else if X < 13.0 then + begin + Z := 1.0; + X1 := X; + while X1 >= 3 do + begin + X1 := X1 - 1.0; + Z := Z * X1; + end; + while X1 < 2.0 do + begin + if Abs(X1) <= 0.03125 then + begin + LnGamma := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Abs(GamSmall(X1, Z))); + Exit; + end; + Z := Z / X1; + X1 := X1 + 1.0; + end; + if Z < 0.0 then Z := - Z; + if X1 = 2.0 then + LnGamma := {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z) + else + begin + X1 := X1 - 2.0; + LnGamma := X1 * PolEvl(X1, P, 6) / P1Evl(X1, Q, 7) + + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Z); + end; + end + else + LnGamma := StirfL(X); + end; + + function IGamma(A, X : Float) : Float; + var + Ans, Ax, C, R : Float; + begin + MathErr := FN_OK; + + if (X <= 0.0) or (A <= 0.0) then + begin + IGamma := 0.0; + Exit; + end; + + if (X > 1.0) and (X > A) then + begin + IGamma := 1.0 - JGamma(A, X); + Exit; + end; + + Ax := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - X - LnGamma(A); + if Ax < MINLOG then + begin + IGamma := DefaultVal(FN_UNDERFLOW); + Exit; + end; + + Ax := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Ax); + + { power series } + R := A; + C := 1.0; + Ans := 1.0; + + repeat + R := R + 1.0; + C := C * X / R; + Ans := Ans + C; + until C / Ans <= MACHEP; + + IGamma := Ans * Ax / A; + end; + + function JGamma(A, X : Float) : Float; + var + Ans, C, Yc, Ax, Y, Z, R, T, + Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2 : Float; + begin + MathErr := FN_OK; + + if (X <= 0.0) or (A <= 0.0) then + begin + JGamma := 1.0; + Exit; + end; + + if (X < 1.0) or (X < A) then + begin + JGamma := 1.0 - IGamma(A, X); + Exit; + end; + + Ax := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - X - LnGamma(A); + + if Ax < MINLOG then + begin + JGamma := DefaultVal(FN_UNDERFLOW); + Exit; + end; + + Ax := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Ax); + + { continued fraction } + Y := 1.0 - A; + Z := X + Y + 1.0; + C := 0.0; + Pkm2 := 1.0; + Qkm2 := X; + Pkm1 := X + 1.0; + Qkm1 := Z * X; + Ans := Pkm1 / Qkm1; + + repeat + C := C + 1.0; + Y := Y + 1.0; + Z := Z + 2.0; + Yc := Y * C; + Pk := Pkm1 * Z - Pkm2 * Yc; + Qk := Qkm1 * Z - Qkm2 * Yc; + if Qk <> 0.0 then + begin + R := Pk / Qk; + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + if Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 / BIG; + Pkm1 := Pkm1 / BIG; + Qkm2 := Qkm2 / BIG; + Qkm1 := Qkm1 / BIG; + end; + until T <= MACHEP; + + JGamma := Ans * Ax; + end; + + function Fact(N : Integer) : Float; + begin + MathErr := FN_OK; + if N < 0 then + Fact := DefaultVal(FN_DOMAIN) + else if N > MAXFAC then + Fact := DefaultVal(FN_OVERFLOW) + else if N <= NFACT then + Fact := FactArray[N] + else + Fact := Gamma(N + 1); + end; + + function Binomial(N, K : Integer) : Float; + var + I, N1 : Integer; + Prod : Float; + begin + MathErr := FN_OK; + if K < 0 then + Binomial := 0.0 + else if (K = 0) or (K = N) then + Binomial := 1.0 + else if (K = 1) or (K = N - 1) then + Binomial := N + else + begin + if K > N - K then K := N - K; + N1 := Succ(N); + Prod := N; + for I := 2 to K do + Prod := Prod * (Int(N1 - I) / Int(I)); + Binomial := Int(0.5 + Prod); + end; + end; + + function Beta(X, Y : Float) : Float; + { Computes Beta(X, Y) = Gamma(X) * Gamma(Y) / Gamma(X + Y) } + var + Lx, Ly, Lxy : Float; + SgnBeta : Integer; + begin + MathErr := FN_OK; + SgnBeta := SgnGamma(X) * SgnGamma(Y) * SgnGamma(X + Y); + Lxy := LnGamma(X + Y); + if MathErr <> FN_OK then + begin + Beta := 0.0; + Exit; + end; + Lx := LnGamma(X); + if MathErr <> FN_OK then + begin + Beta := SgnBeta * MAXNUM; + Exit; + end; + Ly := LnGamma(Y); + if MathErr <> FN_OK then + begin + Beta := SgnBeta * MAXNUM; + Exit; + end; + Beta := SgnBeta * {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Lx + Ly - Lxy); + end; + + function PSeries(A, B, X : Float) : Float; + { Power series for incomplete beta integral. Use when B*X is small } + var + S, T, U, V, T1, Z, Ai : Float; + N : Integer; + begin + Ai := 1.0 / A; + U := (1.0 - B) * X; + V := U / (A + 1.0); + T1 := V; + T := U; + N := 2; + S := 0.0; + Z := MACHEP * Ai; + while Abs(V) > Z do + begin + U := (N - B) * X / N; + T := T * U; + V := T / (A + N); + S := S + V; + N := N + 1; + end; + S := S + T1; + S := S + Ai; + + U := A * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X); + if (A + B < MAXGAM) and (Abs(U) < MAXLOG) then + begin + T := Gamma(A + B) / (Gamma(A) * Gamma(B)); + S := S * T * Power(X, A); + end + else + begin + T := LnGamma(A + B) - LnGamma(A) - LnGamma(B) + + U + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(S); + if T < MINLOG then + S := 0.0 + else + S := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(T); + end; + PSeries := S; + end; + + function CFrac1(A, B, X : Float) : Float; + { Continued fraction expansion #1 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := A + B; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := B - 1.0; + K7 := K4; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MACHEP; + + repeat + Xk := - (X * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (X * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 + 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 - 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 * BIGINV; + Pkm1 := Pkm1 * BIGINV; + Qkm2 := Qkm2 * BIGINV; + Qkm1 := Qkm1 * BIGINV; + end; + + if (Abs(Qk) < BIGINV) or (Abs(Pk) < BIGINV) then + begin + Pkm2 := Pkm2 * BIG; + Pkm1 := Pkm1 * BIG; + Qkm2 := Qkm2 * BIG; + Qkm1 := Qkm1 * BIG; + end; + N := N + 1; + until N > 400; + MathErr := FN_PLOSS; + +CDone: + CFrac1 := Ans; + end; + + function CFrac2(A, B, X : Float) : Float; + { Continued fraction expansion #2 for incomplete beta integral } + var + Xk, Pk, Pkm1, Pkm2, Qk, Qkm1, Qkm2, + K1, K2, K3, K4, K5, K6, K7, K8, + R, T, Z, Ans, Thresh : Float; + N : Integer; + label + CDone; + begin + K1 := A; + K2 := B - 1.0; + K3 := A; + K4 := A + 1.0; + K5 := 1.0; + K6 := A + B; + K7 := A + 1.0; + K8 := A + 2.0; + + Pkm2 := 0.0; + Qkm2 := 1.0; + Pkm1 := 1.0; + Qkm1 := 1.0; + Z := X / (1.0 - X); + Ans := 1.0; + R := 1.0; + N := 0; + Thresh := 3.0 * MACHEP; + + repeat + Xk := - (Z * K1 * K2) / (K3 * K4); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + Xk := (Z * K5 * K6) / (K7 * K8); + Pk := Pkm1 + Pkm2 * Xk; + Qk := Qkm1 + Qkm2 * Xk; + Pkm2 := Pkm1; + Pkm1 := Pk; + Qkm2 := Qkm1; + Qkm1 := Qk; + + if Qk <> 0.0 then R := Pk / Qk; + + if R <> 0.0 then + begin + T := Abs((Ans - R) / R); + Ans := R; + end + else + T := 1.0; + + if T < Thresh then goto CDone; + + K1 := K1 + 1.0; + K2 := K2 - 1.0; + K3 := K3 + 2.0; + K4 := K4 + 2.0; + K5 := K5 + 1.0; + K6 := K6 + 1.0; + K7 := K7 + 2.0; + K8 := K8 + 2.0; + + if Abs(Qk) + Abs(Pk) > BIG then + begin + Pkm2 := Pkm2 * BIGINV; + Pkm1 := Pkm1 * BIGINV; + Qkm2 := Qkm2 * BIGINV; + Qkm1 := Qkm1 * BIGINV; + end; + + if (Abs(Qk) < BIGINV) or (Abs(Pk) < BIGINV) then + begin + Pkm2 := Pkm2 * BIG; + Pkm1 := Pkm1 * BIG; + Qkm2 := Qkm2 * BIG; + Qkm1 := Qkm1 * BIG; + end; + N := N + 1; + until N > 400; + MathErr := FN_PLOSS; + +CDone: + CFrac2 := Ans; + end; + + function IBeta(A, B, X : Float) : Float; + var + A1, B1, X1, T, W, Xc, Y : Float; + Flag : Boolean; + label + Done; + begin + MathErr := FN_OK; + + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + begin + IBeta := DefaultVal(FN_DOMAIN); + Exit; + end; + + if (X = 0.0) or (X = 1.0) then + begin + IBeta := X; + Exit; + end; + + Flag := False; + if (B * X <= 1.0) and (X <= 0.95) then + begin + T := PSeries(A, B, X); + goto Done; + end; + + W := 1.0 - X; + + { Reverse a and b if x is greater than the mean. } + if X > A / (A + B) then + begin + Flag := True; + A1 := B; + B1 := A; + Xc := X; + X1 := W; + end + else + begin + A1 := A; + B1 := B; + Xc := W; + X1 := X; + end; + + if Flag and (B1 * X1 <= 1.0) and (X1 <= 0.95) then + begin + T := PSeries(A1, B1, X1); + goto Done; + end; + + { Choose expansion for optimal convergence } + Y := X1 * (A1 + B1 - 2.0) - (A1 - 1.0); + if Y < 0.0 then + W := CFrac1(A1, B1, X1) + else + W := CFrac2(A1, B1, X1) / Xc; + + { Multiply w by the factor + a b _ _ _ + x (1-x) | (a+b) / ( a | (a) | (b) ) } + + Y := A1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X1); + T := B1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Xc); + if (A1 + B1 < MAXGAM) and (Abs(Y) < MAXLOG) and (Abs(T) < MAXLOG) then + begin + T := Power(Xc, B1) ; + T := T * Power(X1, A1); + T := T / A1; + T := T * W; + T := T * Gamma(A1 + B1) / (Gamma(A1) * Gamma(B1)); + end + else + begin + { Resort to logarithms } + Y := Y + T + LnGamma(A1 + B1) - LnGamma(A1) - LnGamma(B1) + + {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(W / A1); + if Y < MINLOG then + T := 0.0 + else + T := {$IFDEF USE_ASM}fExp{$ELSE}Exp{$ENDIF}(Y); + end; + +Done: + if Flag then + if T <= MACHEP then + T := 1.0 - MACHEP + else + T := 1.0 - T; + + IBeta := T; + end; + + function Erf(X : Float) : Float; + begin + if X < 0.0 then + Erf := - IGamma(0.5, Sqr(X)) + else + Erf := IGamma(0.5, Sqr(X)); + end; + + function Erfc(X : Float) : Float; + begin + if X < 0.0 then + Erfc := 1.0 + IGamma(0.5, Sqr(X)) + else + Erfc := JGamma(0.5, Sqr(X)); + end; + +{ ---------------------------------------------------------------------- + Probability functions + ---------------------------------------------------------------------- } + + function PBinom(N : Integer; P : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + PBinom := DefaultVal(FN_DOMAIN) + else if K = 0 then + PBinom := IntPower(1.0 - P, N) + else if K = N then + PBinom := IntPower(P, N) + else + PBinom := Binomial(N, K) * IntPower(P, K) * IntPower(1.0 - P, N - K); + end; + + function FBinom(N : Integer; P : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (P < 0.0) or (P > 1.0) or (N <= 0) or (N < K) then + FBinom := DefaultVal(FN_DOMAIN) + else if K = 0 then + FBinom := IntPower(1.0 - P, N) + else if K = N then + FBinom := 1.0 + else + FBinom := 1.0 - IBeta(K + 1, N - K, P); + end; + + function PPoisson(Mu : Float; K : Integer) : Float; + var + P : Float; + I : Integer; + begin + MathErr := FN_OK; + if (Mu <= 0.0) or (K < 0) then + PPoisson := DefaultVal(FN_DOMAIN) + else if K = 0 then + PPoisson := Expo(- Mu) + else + begin + P := Mu; + for I := 2 to K do + P := P * Mu / I; + PPoisson := Expo(- Mu) * P; + end; + end; + + function FPoisson(Mu : Float; K : Integer) : Float; + begin + MathErr := FN_OK; + if (Mu <= 0.0) or (K < 0) then + FPoisson := DefaultVal(FN_DOMAIN) + else if K = 0 then + FPoisson := Expo(- Mu) + else + FPoisson := JGamma(K + 1, Mu); + end; + + function DNorm(X : Float) : Float; + begin + DNorm := INVSQRT2PI * Expo(- 0.5 * Sqr(X)); + end; + + function FNorm(X : Float) : Float; + begin + FNorm := 0.5 * (1.0 + Erf(X * SQRT2DIV2)); + end; + + function InvNorm(P : Float) : Float; +{ ---------------------------------------------------------------------- + Inverse of Normal distribution function + + Returns the argument, X, for which the area under the Gaussian + probability density function (integrated from minus infinity to X) + is equal to P. + + Translated from Cephes library. + ---------------------------------------------------------------------- } + const + P0 : TabCoef = ( + 8.779679420055069160496E-3, + - 7.649544967784380691785E-1, + 2.971493676711545292135E0, + - 4.144980036933753828858E0, + 2.765359913000830285937E0, + - 9.570456817794268907847E-1, + 1.659219375097958322098E-1, + - 1.140013969885358273307E-2, + 0, 0); + + Q0 : TabCoef = ( + - 5.303846964603721860329E0, + 9.908875375256718220854E0, + - 9.031318655459381388888E0, + 4.496118508523213950686E0, + - 1.250016921424819972516E0, + 1.823840725000038842075E-1, + - 1.088633151006419263153E-2, + 0, 0, 0); + + P1 : TabCoef = ( + 4.302849750435552180717E0, + 4.360209451837096682600E1, + 9.454613328844768318162E1, + 9.336735653151873871756E1, + 5.305046472191852391737E1, + 1.775851836288460008093E1, + 3.640308340137013109859E0, + 3.691354900171224122390E-1, + 1.403530274998072987187E-2, + 1.377145111380960566197E-4); + + Q1 : TabCoef = ( + 2.001425109170530136741E1, + 7.079893963891488254284E1, + 8.033277265194672063478E1, + 5.034715121553662712917E1, + 1.779820137342627204153E1, + 3.845554944954699547539E0, + 3.993627390181238962857E-1, + 1.526870689522191191380E-2, + 1.498700676286675466900E-4, + 0); + + P2 : TabCoef = ( + 3.244525725312906932464E0, + 6.856256488128415760904E0, + 3.765479340423144482796E0, + 1.240893301734538935324E0, + 1.740282292791367834724E-1, + 9.082834200993107441750E-3, + 1.617870121822776093899E-4, + 7.377405643054504178605E-7, + 0, 0); + + Q2 : TabCoef = ( + 6.021509481727510630722E0, + 3.528463857156936773982E0, + 1.289185315656302878699E0, + 1.874290142615703609510E-1, + 9.867655920899636109122E-3, + 1.760452434084258930442E-4, + 8.028288500688538331773E-7, + 0, 0, 0); + + P3 : TabCoef = ( + 2.020331091302772535752E0, + 2.133020661587413053144E0, + 2.114822217898707063183E-1, + - 6.500909615246067985872E-3, + - 7.279315200737344309241E-4, + - 1.275404675610280787619E-5, + - 6.433966387613344714022E-8, + - 7.772828380948163386917E-11, + 0, 0); + + Q3 : TabCoef = ( + 2.278210997153449199574E0, + 2.345321838870438196534E-1, + - 6.916708899719964982855E-3, + - 7.908542088737858288849E-4, + - 1.387652389480217178984E-5, + - 7.001476867559193780666E-8, + - 8.458494263787680376729E-11, + 0, 0, 0); + + var + X, Y, Z, Y2, X0, X1 : Float; + Code : Integer; + begin + if (P <= 0.0) or (P >= 1.0) then + begin + InvNorm := DefaultVal(FN_DOMAIN); + Exit; + end; + + Code := 1; + Y := P; + if Y > (1.0 - 0.13533528323661269189) then { 0.135... = exp(-2) } + begin + Y := 1.0 - Y; + Code := 0; + end; + if Y > 0.13533528323661269189 then + begin + Y := Y - 0.5; + Y2 := Y * Y; + X := Y + Y * (Y2 * PolEvl(Y2, P0, 7) / P1Evl(Y2, Q0, 7)); + X := X * SQRT2PI; + InvNorm := X; + Exit; + end; + + X := Sqrt(- 2.0 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Y)); + X0 := X - {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) / X; + Z := 1.0 / X; + if X < 8.0 then + X1 := Z * PolEvl(Z, P1, 9) / P1Evl(Z, Q1, 9) + else if X < 32.0 then + X1 := Z * PolEvl(Z, P2, 7) / P1Evl(Z, Q2, 7) + else + X1 := Z * PolEvl(Z, P3, 7) / P1Evl(Z, Q3, 7); + X := X0 - X1; + if Code <> 0 then + X := - X; + InvNorm := X; + end; + + function PNorm(X : Float) : Float; + var + A : Float; + begin + A := Abs(X); + MathErr := FN_OK; + if A = 0.0 then + PNorm := 1.0 + else if A < 1.0 then + PNorm := 1.0 - Erf(A * SQRT2DIV2) + else + PNorm := Erfc(A * SQRT2DIV2); + end; + + function DStudent(Nu : Integer; X : Float) : Float; + var + L, P, Q : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + DStudent := DefaultVal(FN_DOMAIN) + else + begin + P := 0.5 * (Nu + 1); + Q := 0.5 * Nu; + L := LnGamma(P) - LnGamma(Q) + - 0.5 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(Nu * PI) + - P * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 + Sqr(X) / Nu); + DStudent := Expo(L); + end; + end; + + function FStudent(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + FStudent := DefaultVal(FN_DOMAIN) + else + FStudent := 1.0 - IBeta(0.5 * Nu, 0.5, Nu / (Nu + Sqr(X))); + end; + + function PStudent(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if Nu < 1 then + PStudent := DefaultVal(FN_DOMAIN) + else + PStudent := IBeta(0.5 * Nu, 0.5, Nu / (Nu + Sqr(X))); + end; + + function DKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + DKhi2 := DGamma(0.5 * Nu, 0.5, X); + end; + + function FKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu < 1) or (X <= 0.0) then + FKhi2 := DefaultVal(FN_DOMAIN) + else + FKhi2 := IGamma(0.5 * Nu, 0.5 * X); + end; + + function PKhi2(Nu : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu < 1) or (X <= 0.0) then + PKhi2 := DefaultVal(FN_DOMAIN) + else + PKhi2 := JGamma(0.5 * Nu, 0.5 * X); + end; + + function DSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + var + P1, P2, R, S, L : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + DSnedecor := DefaultVal(FN_DOMAIN) + else + begin + R := Int(Nu1) / Int(Nu2); + P1 := 0.5 * Nu1; + P2 := 0.5 * Nu2; + S := P1 + P2; + L := LnGamma(S) - LnGamma(P1) - LnGamma(P2) + + P1 * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(R); + L := L + (P1 - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) + - S * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 + R * X); + DSnedecor := Expo(L); + end; + end; + + function FSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + FSnedecor := DefaultVal(FN_DOMAIN) + else + FSnedecor := 1.0 - IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); + end; + + function PSnedecor(Nu1, Nu2 : Integer; X : Float) : Float; + begin + MathErr := FN_OK; + if (Nu1 < 1) or (Nu2 < 1) or (X <= 0.0) then + PSnedecor := DefaultVal(FN_DOMAIN) + else + PSnedecor := IBeta(0.5 * Nu2, 0.5 * Nu1, Nu2 / (Nu2 + Nu1 * X)); + end; + + function DExpo(A, X : Float) : Float; + begin + if (A <= 0.0) or (X < 0.0) then + DExpo := DefaultVal(FN_DOMAIN) + else + DExpo := A * Expo(- A * X); + end; + + function FExpo(A, X : Float) : Float; + begin + if (A <= 0.0) or (X < 0.0) then + FExpo := DefaultVal(FN_DOMAIN) + else + FExpo := 1.0 - Expo(- A * X); + end; + + function DBeta(A, B, X : Float) : Float; + var + L : Float; + begin + MathErr := FN_OK; + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) or (X > 1.0) then + DBeta := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + if A < 1.0 then DBeta := DefaultVal(FN_SING) else DBeta := 0.0 + else if X = 1.0 then + if B < 1.0 then DBeta := DefaultVal(FN_SING) else DBeta := 0.0 + else + begin + L := LnGamma(A + B) - LnGamma(A) - LnGamma(B); + L := L + (A - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) + + (B - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(1.0 - X); + DBeta := Expo(L); + end; + end; + + function FBeta(A, B, X : Float) : Float; + begin + FBeta := IBeta(A, B, X); + end; + + function DGamma(A, B, X : Float) : Float; + var + L : Float; + begin + MathErr := FN_OK; + if (A <= 0.0) or (B <= 0.0) or (X < 0.0) then + DGamma := DefaultVal(FN_DOMAIN) + else if X = 0.0 then + if A < 1.0 then + DGamma := DefaultVal(FN_SING) + else if A = 1.0 then + DGamma := B + else + DGamma := 0.0 + else + begin + L := A * Ln(B) - LnGamma(A) + + (A - 1.0) * {$IFDEF USE_ASM}fLn{$ELSE}Ln{$ENDIF}(X) - B * X; + DGamma := Expo(L); + end; + end; + + function FGamma(A, B, X : Float) : Float; + begin + FGamma := IGamma(A, B * X); + end; + +{ ---------------------------------------------------------------------- + Random numbers + ---------------------------------------------------------------------- } + +var + X1, X2, C1, C2 : LongInt; + + procedure RMarIn(Seed1, Seed2 : Integer); + begin + X1 := Seed1; + X2 := Seed2; + C1 := 0; + C2 := 0; + end; + + function IRanMar : LongInt; + var + Y1, Y2 : LongInt; + begin + Y1 := 18000 * X1 + C1; + X1 := Y1 and 65535; + C1 := Y1 shr 16; + Y2 := 30903 * X2 + C2; + X2 := Y2 and 65535; + C2 := Y2 shr 16; + IRanMar := (X1 shl 16) + (X2 and 65535); + end; + + function RanMar : Float; + begin + RanMar := (IRanMar + 2147483648.0) / 4294967296.0; + end; + + function RanGaussStd : Float; + { Computes 2 random numbers from the standard normal distribution, + returns one and saves the other for the next call } + const + Gauss_Save : Float = 0.0; { Saves a random number } + Gauss_Set : Boolean = False; { Flags if a number has been saved } + var + R, Theta, SinTheta, CosTheta : Float; + begin + if not Gauss_Set then + begin + R := Sqrt(- 2.0 * Log(RanMar)); + Theta := TWOPI * RanMar; + SinCos(Theta, SinTheta, CosTheta); + RanGaussStd := R * CosTheta; { Return 1st number } + Gauss_Save := R * SinTheta; { Save 2nd number } + end + else + RanGaussStd := Gauss_Save; { Return saved number } + Gauss_Set := not Gauss_Set; + end; + + function RanGauss(Mu, Sigma : Float) : Float; + { Returns a random number from the normal distribution + with mean Mu and standard deviation Sigma } + begin + RanGauss := Mu + Sigma * RanGaussStd; + end; + +{ ---------------------------------------------------------------------- + Initialization code + ---------------------------------------------------------------------- } + +var + I : Integer; + +begin + { Initialize MathErr } + MathErr := FN_OK; + + { Store the factorials of the first NFACT integers in a table } + FactArray[0] := 1.0; + FactArray[1] := 1.0; + FactArray[2] := 2.0; + for I := 3 to NFACT do + FactArray[I] := FactArray[I - 1] * I; + + { Initialize random number generator } + RMarIn(1802, 9373); +end. diff --git a/npm_precl/dmath/fourier.pas b/npm_precl/dmath/fourier.pas new file mode 100755 index 0000000..b395165 --- /dev/null +++ b/npm_precl/dmath/fourier.pas @@ -0,0 +1,336 @@ +(*========================================================================== + + fourier.pas - Don Cross <dcross@intersrv.com> + + Modified by Jean Debord <JDebord@compuserve.com> for use with TP Math. + + This is a Turbo Pascal Unit for calculating the Fast Fourier Transform + (FFT) and the Inverse Fast Fourier Transform (IFFT). + Visit the following URL for the latest version of this code. + This page also has a C/C++ version, and a brief discussion of the + theory behind the FFT algorithm. + + http://www.intersrv.com/~dcross/fft.html#pascal + + Revision history [most recent first]: + +1998 November 27 [Jean Debord] + Replaced the constant MAXPOWER by a variable which is initialized + according to the value of MAX_FLT defined in MATRICES.PAS + +1997 March 1 [Jean Debord] + Modifications for use with the TP Math library: + 1. Added a USES clause for the TP Math units. + 2. Set real type to Float (defined in FMATH.PAS) + 3. Added a constant MAXPOWER to define the maximum number of points. + Modified functions IsPowerOfTwo and NumberOfBitsNeeded accordingly. + 4. Changed array types to those defined in TP Math. Modified array + allocation, deallocation and reference accordingly. + 5. Removed compiler directives, which were no longer necessary. + 6. Modified some typographical and formatting options so that the + code looks like the other TP Math units. + No modification was made to the original algorithm. + +1996 December 11 [Don Cross] + Improved documentation of the procedure CalcFrequency. + Fixed some messed up comments in procedure IFFT. + +1996 December 6 [Don Cross] + Made procedure 'fft_integer' more efficient when buffer size changes + in successive calls: the buffer is now only resized when the input + has more samples, not a differing number of samples. + Also changed the way 'fft_integer_cleanup' works so that it is + more "bullet-proof". + +1996 December 4 [Don Cross] + Adding the procedure 'CalcFrequency', which calculates the FFT + at a specific frequency index p=0..n-1, instead of the whole + FFT. This is O(n^2) instead of O(n*log(n)). + +1996 November 30 [Don Cross] + Adding a routine to allow FFT of an input array of integers. + It is called 'fft_integer'. + +1996 November 18 [Don Cross] + Added some comments. + +1996 November 17 [Don Cross] + Wrote and debugged first version. + +==========================================================================*) + +unit Fourier; + +interface + +uses + FMath, Matrices; + +(*--------------------------------------------------------------------------- + procedure FFT + + Calculates the Fast Fourier Transform of the array of complex numbers + represented by 'RealIn' and 'ImagIn' to produce the output complex + numbers in 'RealOut' and 'ImagOut'. +---------------------------------------------------------------------------*) +procedure FFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + + +(*--------------------------------------------------------------------------- + procedure IFFT + + Calculates the Inverse Fast Fourier Transform of the array of complex + numbers represented by 'RealIn' and 'ImagIn' to produce the output complex + numbers in 'RealOut' and 'ImagOut'. +---------------------------------------------------------------------------*) +procedure IFFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + + +(*--------------------------------------------------------------------------- + procedure FFT_Integer + + Same as procedure FFT, but uses Integer input arrays instead of + double. Make sure you call FFT_Integer_Cleanup after the last + time you call FFT_Integer to free up memory it allocates. +---------------------------------------------------------------------------*) +procedure FFT_Integer(NumSamples : Integer; RealIn, ImagIn : PIntVector; + RealOut, ImagOut : PVector); + + +(*-------------------------------------------------------------------------- + procedure FFT_Integer_Cleanup + + If you call the procedure 'FFT_Integer', you must call + 'FFT_Integer_Cleanup' after the last time you call 'FFT_Integer' + in order to free up dynamic memory. +--------------------------------------------------------------------------*) +procedure FFT_Integer_Cleanup; + + +(*-------------------------------------------------------------------------- + procedure CalcFrequency + + This procedure calculates the complex frequency sample at a given + index directly. Use this instead of 'FFT' when you only need one + or two frequency samples, not the whole spectrum. + + It is also useful for calculating the Discrete Fourier Transform (DFT) + of a number of data which is not an integer power of 2. For example, + you could calculate the DFT of 100 points instead of rounding up to + 128 and padding the extra 28 array slots with zeroes. +--------------------------------------------------------------------------*) +procedure CalcFrequency(NumSamples, FrequencyIndex : Integer; + RealIn, ImagIn : PVector; + var RealOut, ImagOut : Float); + +implementation + +var + MaxPower : Integer; + + function IsPowerOfTwo(X : Integer) : Boolean; + var + I, Y : Integer; + begin + Y := 2; + for I := 1 to Pred(MaxPower) do + begin + if X = Y then + begin + IsPowerOfTwo := True; + Exit; + end; + Y := Y shl 1; + end; + IsPowerOfTwo := False; + end; + + function NumberOfBitsNeeded(PowerOfTwo : Integer) : Integer; + var + I : Integer; + begin + for I := 0 to MaxPower do + begin + if (PowerOfTwo and (1 shl I)) <> 0 then + begin + NumberOfBitsNeeded := I; + Exit; + end; + end; + end; + + function ReverseBits(Index, NumBits : Integer) : Integer; + var + I, Rev : Integer; + begin + Rev := 0; + for I := 0 to NumBits - 1 do + begin + Rev := (Rev shl 1) or (Index and 1); + Index := Index shr 1; + end; + ReverseBits := Rev; + end; + + procedure FourierTransform(AngleNumerator : Float; NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + var + NumBits, I, J, K, N, BlockSize, BlockEnd : Integer; + Delta_angle, Delta_ar : Float; + Alpha, Beta : Float; + Tr, Ti, Ar, Ai : Float; + begin + if not IsPowerOfTwo(NumSamples) or (NumSamples < 2) then + begin + Write('Error in procedure Fourier: NumSamples=', NumSamples); + WriteLn(' is not a positive integer power of 2.'); + Halt; + end; + + NumBits := NumberOfBitsNeeded(NumSamples); + for I := 0 to NumSamples - 1 do + begin + J := ReverseBits(I, NumBits); + RealOut^[J] := RealIn^[I]; + ImagOut^[J] := ImagIn^[I]; + end; + + BlockEnd := 1; + BlockSize := 2; + while BlockSize <= NumSamples do + begin + Delta_angle := AngleNumerator / BlockSize; + Alpha := Sin(0.5 * Delta_angle); + Alpha := 2.0 * Alpha * Alpha; + Beta := Sin(Delta_angle); + + I := 0; + while I < NumSamples do + begin + Ar := 1.0; (* cos(0) *) + Ai := 0.0; (* sin(0) *) + + J := I; + for N := 0 to BlockEnd - 1 do + begin + K := J + BlockEnd; + Tr := Ar * RealOut^[K] - Ai * ImagOut^[K]; + Ti := Ar * ImagOut^[K] + Ai * RealOut^[K]; + RealOut^[K] := RealOut^[J] - Tr; + ImagOut^[K] := ImagOut^[J] - Ti; + RealOut^[J] := RealOut^[J] + Tr; + ImagOut^[J] := ImagOut^[J] + Ti; + Delta_ar := Alpha * Ar + Beta * Ai; + Ai := Ai - (Alpha * Ai - Beta * Ar); + Ar := Ar - Delta_ar; + Inc(J); + end; + + I := I + BlockSize; + end; + + BlockEnd := BlockSize; + BlockSize := BlockSize shl 1; + end; + end; + + procedure FFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + begin + FourierTransform(2 * PI, NumSamples, RealIn, ImagIn, RealOut, ImagOut); + end; + + procedure IFFT(NumSamples : Integer; + RealIn, ImagIn, RealOut, ImagOut : PVector); + var + I : Integer; + begin + FourierTransform(- 2 * PI, NumSamples, RealIn, ImagIn, RealOut, ImagOut); + + { Normalize the resulting time samples } + for I := 0 to NumSamples - 1 do + begin + RealOut^[I] := RealOut^[I] / NumSamples; + ImagOut^[I] := ImagOut^[I] / NumSamples; + end; + end; + +var + RealTemp, ImagTemp : PVector; + TempArraySize : Integer; + + procedure FFT_Integer(NumSamples : Integer; + RealIn, ImagIn : PIntVector; + RealOut, ImagOut : PVector); + var + I : Integer; + begin + if NumSamples > TempArraySize then + begin + FFT_Integer_Cleanup; { free up memory in case we already have some } + DimVector(RealTemp, NumSamples); + DimVector(ImagTemp, NumSamples); + TempArraySize := NumSamples; + end; + + for I := 0 to NumSamples - 1 do + begin + RealTemp^[I] := RealIn^[I]; + ImagTemp^[I] := ImagIn^[I]; + end; + + FourierTransform(2 * PI, NumSamples, RealTemp, ImagTemp, RealOut, ImagOut); + end; + + procedure FFT_Integer_Cleanup; + begin + if TempArraySize > 0 then + begin + if RealTemp <> nil then + DelVector(RealTemp, TempArraySize); + if ImagTemp <> nil then + DelVector(ImagTemp, TempArraySize); + TempArraySize := 0; + end; + end; + + procedure CalcFrequency(NumSamples, FrequencyIndex : Integer; + RealIn, ImagIn : PVector; + var RealOut, ImagOut : Float); + var + K : Integer; + Cos1, Cos2, Cos3, Theta, Beta : Float; + Sin1, Sin2, Sin3 : Float; + begin + RealOut := 0.0; + ImagOut := 0.0; + Theta := 2 * PI * FrequencyIndex / NumSamples; + Sin1 := Sin(- 2 * Theta); + Sin2 := Sin(- Theta); + Cos1 := Cos(- 2 * Theta); + Cos2 := Cos(- Theta); + Beta := 2 * Cos2; + for K := 0 to NumSamples - 1 do + begin + { Update trig values } + Sin3 := Beta * Sin2 - Sin1; + Sin1 := Sin2; + Sin2 := Sin3; + + Cos3 := Beta * Cos2 - Cos1; + Cos1 := Cos2; + Cos2 := Cos3; + + RealOut := RealOut + RealIn^[K] * Cos3 - ImagIn^[K] * Sin3; + ImagOut := ImagOut + ImagIn^[K] * Cos3 + RealIn^[K] * Sin3; + end; + end; + +begin { Unit initialization code } + MaxPower := Trunc(Log2(MAX_FLT)); { Max power of two } + TempArraySize := 0; { flag that buffers RealTemp, RealImag not allocated } + RealTemp := nil; + ImagTemp := nil; +end. diff --git a/npm_precl/dmath/matcomp.pas b/npm_precl/dmath/matcomp.pas new file mode 100755 index 0000000..3d3c33e --- /dev/null +++ b/npm_precl/dmath/matcomp.pas @@ -0,0 +1,302 @@ +{ ********************************************************************** + * Unit MATCOMP.PAS * + * Version 1.3 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Matrices with complex elements. See MATRICES.PAS for details + concerning the dynamic allocation and use of matrices. + ********************************************************************** + References: + 1) 'Basic Programs for Scientists and Engineers' by A.R. Miller + 2) 'Numerical Recipes' by Press et al. + ********************************************************************** } + +unit MatComp; + +interface + +uses + FMath, FComp, Matrices; + +{ ********************************************************************** + This section defines the vector and matrix types. Maximal sizes are + given for a 16-bit compiler (TP/BP). Higher values may be used with + a 32-bit compiler such as FPC. + ********************************************************************** } + +const +{$IFDEF DOUBLEREAL} + MAX_COMP = 3854; { Max size of complex vector } +{$ELSE} +{$IFDEF SINGLEREAL} + MAX_COMP = 7280; +{$ELSE} +{$IFDEF PASCALREAL} + MAX_COMP = 5040; +{$ELSE} + {$DEFINE EXTENDEDREAL} + MAX_COMP = 3119; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +type + TCompVector = array[0..MAX_COMP] of Complex; + PCompVector = ^TCompVector; + + TCompMatrix = array[0..MAX_VEC] of PCompVector; + PCompMatrix = ^TCompMatrix; + +{ ********************************************************************** + Memory allocation routines + ********************************************************************** } + +procedure DimCompVector(var V : PCompVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Creates complex vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DimCompMatrix(var A : PCompMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Creates complex matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Memory deallocation routines + ********************************************************************** } + +procedure DelCompVector(V : PCompVector; Ubound : Integer); +{ ---------------------------------------------------------------------- + Deletes complex vector V[0..Ubound] + ---------------------------------------------------------------------- } + +procedure DelCompMatrix(A : PCompMatrix; Ubound1, Ubound2 : Integer); +{ ---------------------------------------------------------------------- + Deletes complex matrix A[0..Ubound1, 0..Ubound2] + ---------------------------------------------------------------------- } + +{ ********************************************************************** + Complex matrix functions + ********************************************************************** } + +function C_LU_Decomp(A : PCompMatrix; Lbound, Ubound : Integer) : Integer; +{ ---------------------------------------------------------------------- + LU decomposition + ---------------------------------------------------------------------- } + +procedure C_LU_Solve(A : PCompMatrix; B : PCompVector; + Lbound, Ubound : Integer; X : PCompVector); +{ ---------------------------------------------------------------------- + Solves a system of equations whose matrix has been transformed by + C_LU_Decomp + ---------------------------------------------------------------------- } + +implementation + +const + { Used by LU procedures } + LastDim : Integer = 1; { Dimension of the last system solved } + Index : PIntVector = nil; { Records the row permutations } + + procedure DimCompVector(var V : PCompVector; Ubound : Integer); + var + I : Integer; + begin + { Check bounds } + if (Ubound < 0) or (Ubound > MAX_COMP) then + begin + V := nil; + Exit; + end; + + { Allocate vector } + GetMem(V, Succ(Ubound) * SizeOf(Complex)); + if V = nil then Exit; + + { Initialize vector } + for I := 0 to Ubound do + V^[I] := C_zero; + end; + + procedure DimCompMatrix(var A : PCompMatrix; Ubound1, Ubound2 : Integer); + var + I, J : Integer; + RowSize : Word; + begin + { Check bounds } + if (Ubound1 < 0) or (Ubound1 > MAX_VEC) or + (Ubound2 < 0) or (Ubound2 > MAX_COMP) then + begin + A := nil; + Exit; + end; + + { Size of a row } + GetMem(A, Succ(Ubound1) * SizeOf(PCompVector)); + if A = nil then Exit; + + { Allocate each row } + for I := 0 to Ubound1 do + begin + GetMem(A^[I], RowSize); + if A^[I] = nil then + begin + A := nil; + Exit; + end; + end; + + { Initialize matrix } + for I := 0 to Ubound1 do + for J := 0 to Ubound2 do + A^[I]^[J] := C_zero; + end; + + procedure DelCompVector(V : PCompVector; Ubound : Integer); + begin + if V <> nil then + begin + FreeMem(V, Succ(Ubound) * SizeOf(Complex)); + V := nil; + end; + end; + + procedure DelCompMatrix(A : PCompMatrix; Ubound1, Ubound2 : Integer); + var + I : Integer; + RowSize : Word; + begin + if A <> nil then + begin + RowSize := Succ(Ubound2) * SizeOf(Complex); + for I := Ubound1 downto 0 do + FreeMem(A^[I], RowSize); + FreeMem(A, Succ(Ubound1) * SizeOf(PCompVector)); + A := nil; + end; + end; + + function C_LU_Decomp(A : PCompMatrix; Lbound, Ubound : Integer) : Integer; + const + TINY = 1.0E-20; + var + I, Imax, J, K : Integer; + C, Pvt, T : Float; + Sum, Z : Complex; + V : PVector; + begin + DimVector(V, Ubound); + { Reallocate Index } + if Index <> nil then + DelIntVector(Index, LastDim); + DimIntVector(Index, Ubound); + LastDim := Ubound; + + for I := Lbound to Ubound do + begin + Pvt := 0.0; + for J := Lbound to Ubound do + begin + C := CAbs(A^[I]^[J]); + if C > Pvt then Pvt := C; + end; + if Pvt < MACHEP then + begin + DelVector(V, Ubound); + C_LU_Decomp := MAT_SINGUL; + Exit; + end; + V^[I] := 1.0 / Pvt; + end; + for J := Lbound to Ubound do + begin + for I := Lbound to Pred(J) do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(I) do + begin + { Sum := Sum - A^[I]^[K] * A^[K]^[J]; } + CMult(A^[I]^[K], A^[K]^[J], Z); + CSub(Sum, Z, Sum); + end; + A^[I]^[J] := Sum; + end; + Pvt := 0.0; + for I := J to Ubound do + begin + Sum := A^[I]^[J]; + for K := Lbound to Pred(J) do + begin + { Sum := Sum - A^[I]^[K] * A^[K]^[J]; } + CMult(A^[I]^[K], A^[K]^[J], Z); + CSub(Sum, Z, Sum); + end; + A^[I]^[J] := Sum; + T := V^[I] * CAbs(Sum); + if T > Pvt then + begin + Pvt := T; + Imax := I; + end; + end; + if J <> Imax then + begin + { SwapRows(Imax, J, A, Lbound, Ubound); } + for K := Lbound to Ubound do + CSwap(A^[Imax]^[K], A^[J]^[K]); + V^[Imax] := V^[J]; + end; + Index^[J] := Imax; + if CAbs(A^[J]^[J]) = 0.0 then + CSet(A^[J]^[J], TINY, TINY, Rec); + if J <> Ubound then + for I := Succ(J) to Ubound do + { A^[I]^[J] := A^[I]^[J] / A^[J]^[J]; } + CDiv(A^[I]^[J], A^[J]^[J], A^[I]^[J]); + end; + DelVector(V, Ubound); + C_LU_Decomp := MAT_OK; + end; + + procedure C_LU_Solve(A : PCompMatrix; B : PCompVector; + Lbound, Ubound : Integer; X : PCompVector); + var + I, Ip, J, K : Integer; + Sum, Z : Complex; + begin + K := Pred(Lbound); + { CopyVector(X, B, Lbound, Ubound); } + for I := Lbound to Ubound do + X^[I] := B^[I]; + for I := Lbound to Ubound do + begin + Ip := Index^[I]; + Sum := X^[Ip]; + X^[Ip] := X^[I]; + if K >= Lbound then + for J := K to Pred(I) do + begin + { Sum := Sum - A^[I]^[J] * X^[J] } + CMult(A^[I]^[J], X^[J], Z); + CSub(Sum, Z, Sum); + end + else if CAbs(Sum) <> 0.0 then + K := I; + X^[I] := Sum; + end; + for I := Ubound downto Lbound do + begin + Sum := X^[I]; + if I < Ubound then + for J := Succ(I) to Ubound do + begin + { Sum := Sum - A^[I]^[J] * X^[J]; } + CMult(A^[I]^[J], X^[J], Z); + CSub(Sum, Z, Sum); + end; + { X^[I] := Sum / A^[I]^[I]; } + CDiv(Sum, A^[I]^[I], X^[I]); + end; + end; + +end. diff --git a/npm_precl/dmath/math387.inc b/npm_precl/dmath/math387.inc new file mode 100755 index 0000000..fb4c86c --- /dev/null +++ b/npm_precl/dmath/math387.inc @@ -0,0 +1,314 @@ +{ ********************************************************************** + * MATH387.INC * + ********************************************************************** + Mathematical functions for TPMATH + (Assembler version for 387/486/Pentium with BP7 and Delphi1) + ********************************************************************** } + + +(* Bibliotheque mathematique pour utilisation du coprocesseur flottant + JD GAYRARD Sept. 95 + + ---------------------------------------------------------------------- + Unite d'origine : MATH387.PAS, disponible dans MATHLIB2.ZIP + (http://wcarchive.cdrom.com/pub/delphi_www/) + Convertie en fichier Include par J. DEBORD, Juin 97 + avec ajout des fonctions fexp2 et flog2 + ---------------------------------------------------------------------- + + la bibliotheque est batie … partir des fonctions du coprocesseur + du type 386, elle fournit les fonctions suivantes: + fsin, fcos, ftan, farctan, farctan2, + farcsin, farccos, fmod, mod_2PI, + ften_to, fy_to_x, fexp, fexp2, fln, flog, flog2... + +Aucune verification du domaine de definition des fonctions n'est faite, +pas plus qu'un controle de la validite des operandes. Il est conseille +d'utiliser cette bibliotheque pour les types single et double exclusivement *) + +{ table opcode du 387 non comprise par turbo pascal V7 } +{ FSIN : D9 FE + FCOS : D9 FF + FSINCOS : D9 FB + FPREM1 : D9 F5 } + +(* use only with 80387, 80486 or pentium for type single, double and extended, +no check of definition domain of the function or range (FPU limitation). +The f prefix avoids function redefinition of system runtime library *) + +function fsin(x : Float): Float; assembler; +{if x < pi.2^62, then C2 is set to 0 and ST = sin(x) + else C2 is set to 1 and ST = x } +{no check range validity is performed in this function} +asm + FLD x { load x } + DB $D9, $FE { opcode for FSIN } +end; + +function fcos(x : Float): Float; assembler; +{ if x < pi.2^62, then C2 is set to 0 and ST = sin(x) + else C2 is set to 1 and ST = x } +{no range validity check is performed in this function} +asm + FLD x { load angle } + DB $D9, $FF { opcode for FCOS } +end; +(* +procedure dsincos(x : Float; var sinus, cosinus : double); assembler; +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80468 et pentium et type double } +asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + LES DI,cosinus { } + FSTP ES:QWORD PTR [DI] { sin(x) - } + LES DI,sinus { } + FSTP ES:QWORD PTR [DI] { - - } +end; + +procedure ssincos(x : Float; var sinus, cosinus : single); assembler; +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80468 et pentium et type single } +asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + LES DI,cosinus { } + FSTP ES:DWORD PTR [DI] { sin(x) - } + LES DI,sinus { } + FSTP ES:DWORD PTR [DI] { - - } +end; + +procedure fsincos(x : Float; var sinus, cosinus : Float); +{ retourne sinus et cosinus(x), utilisable uniquement + avec 80387, 80486 et pentium } +var lcos, lsin : Float; +begin + asm { ST(0) ST(1) } + FLD x { x - } + DB $D9, $FB { cos(x) sin(x) } + FSTP lcos { sin(x) - } + FSTP lsin { - - } + end; +cosinus := lcos; +sinus := lsin +end; +*) +function ftan(x : Float): Float; assembler; +{ if x < pi.2^62, then C2 is set to 0 and ST = 1 and ST(1) = tan(x) + else C2 is set to 1 and ST = x } +{no range validity check is performed in this function} +asm { ST(0) ST(1) } + FLD x { x - } + FPTAN { 1 tan(x) } + FSTP ST(0) { tan(x) - } +end; + +function farcsin(x : Float): Float; assembler; +(* retourne l'arcsin de x *) +{ methode : ________ + arcsin(x) = arctan( x / V 1 - x.x ) } +{no range validity check is performed in this function |x| > 1 } +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLD ST(0) { x x - } + FMUL ST(0), ST { x.x x - } + FLD1 { 1 x.x x } + FSUBRP ST(1), ST { 1 - xý x - } + FSQRT { sqrt(1-xý) x - } + FPATAN { arcsin(x) - - } +end; + +function farccos(x : Float): Float; assembler; +{ retourne arccos(x) + methode : ________ + arcsin(x) = arctan( V 1 - x.x / x ) } +{ pas de controle de domaine de definition |x| > 1 } +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLD ST(0) { x x - } + FMUL ST(0), ST { x.x x - } + FLD1 { 1 x.x x } + FSUBRP ST(1), ST { 1 - xý x - } + FSQRT { sqrt(1-xý) x - } + FXCH { x z - } + FPATAN { arccos(x) - - } +end; + +function farctan(x : Float): Float; assembler; +asm { ST(0) ST(1) } + FLD x { x - } + FLD1 { 1 x } + FPATAN { atan(x/1) - } +end; + +function farctan2(y, x : Float): Float; assembler; +{ retourne arctan (y / x) } +asm { ST(0) ST(1) } + FLD y { y - } + FLD x { x y } + FPATAN { atan(y/x) - } +end; +(* +function fmod(x, y : Float): Float; assembler; +{ retourne x mod y } +asm { ST(0) ST(1) } + FLD Y { y - } + FLD X { x y } +@repeat_mod: + FPREM { x mod y y } + FSTSW AX + SAHF + JP @repeat_mod + FSTP ST(1) { x mod y - } +end; + +function fmod_2PI( x : Float): Float; assembler; +{ retourne x mod 2.pi } +asm { ST(0) ST(1) } + FLDPI { pi - } + FADD ST, ST { 2.pi - } + FLD x { x 2.pi } +@unit_circle: + FPREM { x mod 2pi 2pi } + FSTSW AX + SAHF + JP @unit_circle + FSTP ST(1) { x mod 2pi - } +end; +*) +function fln(x : Float): Float; assembler; +{ retourne le logarithme naturel de x, utilise + la methode loge(x) = loge(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLN2 { ln(2) - } + FLD X { x ln(2) } + FYL2X { ln(2).log2(x) - } +end; + +function flog2(x : Float): Float; assembler; +{ retourne le logarithme de base 2 de x } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLD1 { 1 - } + FLD X { x 1 } + FYL2X { log2(x) - } +end; + +function flog10(x : Float): Float; assembler; +{ retourne le logarithme base 10 de x, utilise + la methode log10(x) = log10(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLG2 { log10(2) - } + FLD X { x log10(2) } + FYL2X {log2(x).log10(2) - } +end; + +function fexp(x : Float): Float; assembler; +{ retourne e^x, par la methode e^x = 2^(x.log2(e)) } +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) } +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLDL2E { log2(e) x - } + FMULP ST(1), ST { x.log2(e) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { e^x - - } +end; + +function fexp2(x : Float): Float; assembler; +{ retourne 2^x par la methode 2^z = 2^f.2^i } +{ with f = frac(z) and i = int(z) } +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { x x - } + FRNDINT { int(x) x - } + FLDCW control_ww + FXCH { x i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { 2^x - - } +end; + +function fexp10(x : Float): Float; assembler; +{ retourne 10^x, par la methode 10^x = 2^(x.log2(10)) +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD X { x - - } + FLDL2T { log2(10) x - } + FMULP ST(1), ST { x.log2(10) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { 10^x - - } +end; +(* +function fpower(y, x : Float): Float; assembler; +{ retourne y^x, par la methode y^x = 2^(y.log2(y)) +{no range validity check is performed in this function (y > 0) } +{ 2^z = 2^f.2^i with f = frac(z) and i = int(z) +{ 2^f is computed with F2XM1, 2^i with FSCALE } +const round_down : word = $177F; +var control_ww : word; +asm { ST(0) ST(1) ST(2) } + FLD Y { y - - } + FLD X { x y - } + FYL2X { x.log2(y) - - } + FSTCW control_ww + FLDCW round_down + FLD ST(0) { z z - } + FRNDINT { int(z) z - } + FLDCW control_ww + FXCH { z i - } + FSUB ST, ST(1) { f i - } + F2XM1 { 2^f-1 i - } + FLD1 { 1 2^f-1 i } + FADDP ST(1), ST { 2^f i - } + FSCALE { 2^f.2^i i - } + FSTP ST(1) { y^x - - } +end; + +function module(x, y : Float): Float; assembler; +{ retourne le module du complexe (x,y) } +asm { ST(0) ST(1) } + FLD Y { y - } + FMUL ST(0), ST { y.y - } + FLD X { x y.y } + FMUL ST(0), ST { x.x y.y } + FADDP ST(1), ST { d.d - } + FSQRT { d - } +end; +*) + diff --git a/npm_precl/dmath/mathp2.inc b/npm_precl/dmath/mathp2.inc new file mode 100755 index 0000000..969ecec --- /dev/null +++ b/npm_precl/dmath/mathp2.inc @@ -0,0 +1,582 @@ +{ ********************************************************************** + * MATHP2.INC * + ********************************************************************** + Mathematical functions for TPMATH + (Assembler version for Pentium II/III with FPC) + ********************************************************************** } + + +{ Bibliotheque mathematique pour utilisation du coprocesseur flottant + JD GAYRARD Sept. 95 + + ---------------------------------------------------------------------- + Unite d'origine : MATH387.PAS, disponible dans MATHLIB2.ZIP + (http://wcarchive.cdrom.com/pub/delphi_www/) + Adapte aux pentiums II/III et complete par P. NOGARET (2000) + ---------------------------------------------------------------------- } + + + +{***********************************************************************} +{* function fexp(x : Float): Float;assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne e^x, par la methode e^x = 2^(x.log2(e)) *} +{* 2^z = 2^f.2^i avec f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1, *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{***********************************************************************} + function fexp(x : Float): Float;assembler; + var + round_z : dword; + temp : extended; + asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['eax']; + + +{***********************************************************************} +{* function fexp2(x : Float): Float; assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne 2^x par la methode 2^z = 2^f.2^i *} +{* avec f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1, *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* x - *} +{* z:=x - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{***********************************************************************} + function fexp2(x : Float): Float; assembler; + var + round_z : dword; + temp : extended; + asm + FLD x + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z { round_zmax := 16384 } + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['EAX']; + +{***********************************************************************} +{* function fexp10(x : Float): Float; assembler; *} +{***********************************************************************} +{* Fonction d‚velopp‚e … partir du document de Agner Fog *} +{* www.agner.org/assem *} +{***********************************************************************} +{* retourne 10^x, par la methode 10^x = 2^(x.log2(10)) *} +{* 2^z = 2^f.2^i with f = frac(z) and i = int(z) *} +{* 2^f is computed with F2XM1 *} +{* 2^i pourrait ˆtre calcul‚ avec FSCALE mais cette instruction *} +{* est trŠs lente 56 micro-ops sur un pentium II *} +{* pour la m‚thode utilis‚ pour calculer 2^i voir Agner Fog *} +{***********************************************************************} +{* st(0) st(1) *} +{* log2(10) - *} +{* x log2(10) *} +{* z:=x.log2(10) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* 10^x - *} +{***********************************************************************} + function fexp10(x : Float): Float; assembler; + var + round_z : dword; + temp : extended; + asm + FLDL2T + FLD X + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + end ['EAX']; + +function fln(x : Float): Float; assembler; +{ retourne le logarithme naturel de x, utilise + la methode loge(x) = loge(2).log2(x) } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLDLN2 { ln(2) - } + FLD X { x ln(2) } + FYL2X { ln(2).log2(x) - } +end; + +function flog2(x : Float): Float; assembler; +{ retourne le logarithme de base 2 de x } +{ pas de verification du domaine de definition (x < 0) } +asm { ST(0) ST(1) } + FLD1 { 1 - } + FLD X { x 1 } + FYL2X { log2(x) - } +end; + +{***********************************************************************} +{* function flog10(X : Float) : Float; *} +{***********************************************************************} +{* Compute a common (base 10) logarithm. If X is near 1.0, then we *} +{* use the FYL2XP1 instruction instead of FYL2X. "Near" means between *} +{* 1.0 and 1+Sqrt(2)/2. We use an approximation for Sqrt(2)/2, so we *} +{* don't have to compute it. The exact value isn't important, since *} +{* FYL2X works fine for values near the transition. *} +{***********************************************************************} + function flog10(x : Float): Float; assembler; + const + HalfSqrt2p1: Extended = 1.7071; + asm + fldlg2 { push Log2 } + fld X { push X } + fld1 { push 1.0 } + fcomp ST(1) { if (X < 1.0) } + jl @@1 { goto @@1 } + fld HalfSqrt2p1 { push 1.707 } + fcomp ST(1) { if (X > 1.707) } + jg @@1 { goto @@1 } + fld1 { X is small, so subtract 1.0 } + fsubrp { X := X - 1.0 } + fyl2xp1 { Log10(2) * Log2(X+1) } + jmp @@2 + @@1: { X is not near 1.0 } + fyl2x { Log10(2) * Log2(X) } + @@2: + end; + +{***********************************************************************} +{* function fsin(X : Float) : Float; *} +{***********************************************************************} +{* if x < pi.2^62, then C2 is set to 0 and ST = sin(x) *} +{* else C2 is set to 1 and ST = x *} +{* no check range validity is performed in this function *} +{***********************************************************************} + function fsin(X : Float) : Float; assembler; + asm + FLD x + fsin + end; + +{***********************************************************************} +{* function fcos(X : Float) : Float; *} +{***********************************************************************} + function fcos(X : Float) : Float; assembler; + asm + FLD x + fcos + end; + +{***********************************************************************} +{* function ftan(X : Float) : Float;assembler; *} +{***********************************************************************} + function ftan(X : Float) : Float; assembler; + asm { ST(0) ST(1) } + FLD x { x - } + FPTAN { 1 tan(x) } + FSTP ST(0) { tan(x) - } + end; + +{***********************************************************************} +{* function farctan(X : Float) : Float; *} +{***********************************************************************} + function farctan(x : Float): Float; assembler; + asm { ST(0) ST(1) } + FLD x { x - } + FLD1 { 1 x } + FPATAN { atan(x/1) - } + end; + +{***********************************************************************} +{* function farctan2(Y, X : Float) : Float; *} +{***********************************************************************} +function farctan2(y, x : Float): Float; assembler; +{ retourne arctan (y / x) } +asm { ST(0) ST(1) } + FLD y { y - } + FLD x { x y } + FPATAN { atan(y/x) - } +end; + +{***********************************************************************} +{* function farcsin(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arcsin de x *} +{* methode : ________ *} +{* arcsin(x) = arctan( x / V 1 - x.x ) *} +{* no range validity check is performed in this function |x| > 1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* x - - *} +{* x x - *} +{* x.x x - *} +{* 1 x.x x *} +{* 1 - xý x - *} +{* sqrt(1-xý) x - *} +{* arcsin(x) - - *} +{***********************************************************************} +function farcsin(x : Float): Float; assembler; +asm + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBRP ST(1), ST + FSQRT + FPATAN +end; + +{***********************************************************************} +{* function farccos(x : Float): Float; assembler; *} +{***********************************************************************} +{* retourne l'arccos de x *} +{* methode : ________ *} +{* arccos(x) = arctan( V 1 - x.x / x) *} +{* pas de controle de domaine de definition |x| > 1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* x - - *} +{* x x - *} +{* x.x x - *} +{* 1 x.x x *} +{* 1 - xý x - *} +{* sqrt(1-xý) x - *} +{* x z - *} +{* arccos(x) - - *} +{***********************************************************************} +function farccos(x : Float): Float; assembler; +asm + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBRP ST(1), ST + FSQRT + FXCH + FPATAN +end; + +{***********************************************************************} +{* function fsinh(X : Float) : Float; *} +{***********************************************************************} +{* retourne le sinus hyperbolique de l'argument *} +{* sh(x) = [exp(x) - exp(-x)] / 2 *} +{* methode : z = exp(x), ch(x) = 1/2 (z - 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) *} +{* log2(e) - - *} +{* x log2(e) - *} +{* z:=x.log2(e) - - *} +{* z - - *} +{* z - round(z) - - *} +{* 2^(z - round(z)) - 1 - - *} +{* 1 2^(z - round(z)) - 1 - *} +{* 2^(z - round(z)) - - *} +{* temp:=2^i 2^f:=2^(z - round(z)) - *} +{* e^x - - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z - *} +{* z-1/z - - *} +{* 0.5 z-1/z - *} +{* sh(x) - - *} +{***********************************************************************} +function fsinh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIVRP ST(1), ST + FSUBP ST(1), ST + FLD one_half + FMULP ST(1), ST +end; + +{***********************************************************************} +{* function fcosh(X : Float) : Float; *} +{***********************************************************************} +{* retourne le cosinus hyperbolique de l'argument *} +{* ch(x) = [exp(x) + exp(-x)] / 2 *} +{* methode : z = exp(x), ch(x) = 1/2 (z + 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* st(0) st(1) st(2) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z - *} +{* z+1/z - - *} +{* 0.5 z+1/z - *} +{* ch(x) - - *} +{***********************************************************************} +function fcosh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIVRP ST(1), ST + FADDP ST(1), ST + FLD one_half + FMULP ST(1), ST +end; + +{***********************************************************************} +{* function ftanh(X : Float) : Float; *} +{***********************************************************************} +{* retourne la tangente hyperbolique de l'argument *} +{* th(x) = sh(x) / ch(x) *) *} +{* th(x) = [exp(x) - exp(-x)] / [exp(x) + exp(-x)] *} +{* methode : z = exp(x), ch(x) = (z - 1/z) / (z + 1/z) *} +{* z = 2^y, y = x.log2(e), *} +{* z = 2^f.2^i, f = frac(y), i = int(y) *} +{* 2^f est calcul‚ avec F2XM1, 2^i sans FSCALE *} +{***********************************************************************} +{* st(0) st(1) st(2) *} +{* log2(e) - *} +{* x log2(e) *} +{* z:=x.log2(e) - *} +{* z - *} +{* z - round(z) - *} +{* 2^(z - round(z)) - 1 - *} +{* 1 2^(z - round(z)) - 1 *} +{* 2^(z - round(z)) - *} +{* temp:=2^i 2^f:=2^(z - round(z)) *} +{* e^x - *} +{* e^x e^x - *} +{* 1 z z *} +{* 1/z z z *} +{* 1/z z z-1/z *} +{* z+1/z z-1/z - *} +{* th(x) - - *} +{***********************************************************************} +function ftanh(x : float): float; assembler; +const + one_half : float = 0.5; +var + round_z : dword; + temp : extended; +asm + FLDL2E + FLD x + FMULP + FIST round_z + MOV DWORD PTR [temp], 00000000H + MOV DWORD PTR [temp+4],80000000H + FISUB round_z + MOV EAX, round_z + ADD EAX, 00003FFFH + MOV DWORD PTR [temp+8],EAX + F2XM1 + FLD1 + FADDP + FLD TBYTE PTR [temp] + FMULP + FST ST(1) + FLD1 + FDIV ST, ST(1) + FSUB ST(2), ST + FADDP ST(1), ST + FDIVP ST(1), ST +end; + +{***********************************************************************} +{* function farcsinh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc sinus hyperbolique de l'argument *} +{* _________ *} +{* arg sh(x) = ln ( x + V x.x + 1 ) *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* x.x x ln(2) - *} +{* 1 x.x x ln(2) *} +{* x.x + 1 x ln(2) - *} +{* sqrt(x.x+1) x ln(2) - *} +{* x + z ln(2) - - *} +{* arg_sh(x) - - - *} +{***********************************************************************} +function farcsinh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FADDP ST(1), ST + FSQRT + FADDP ST(1), ST + FYL2X +end; + +{***********************************************************************} +{* function farccosh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc cosinus hyperbolique de l'argument *} +{* ________ *} +{* arg ch(x) = ln ( x + V x.x - 1 ) x >=1 *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* x.x x ln(2) - *} +{* 1 x.x x ln(2) *} +{* x.x - 1 x ln(2) - *} +{* sqrt(x2-1) x ln(2) - *} +{* x + z ln(2) - - *} +{* arg_ch(x) - - - *} +{***********************************************************************} +function farccosh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FMUL ST(0), ST + FLD1 + FSUBP ST(1), ST + FSQRT + FADDP ST(1), ST + FYL2X +end; + +{***********************************************************************} +{* function farctanh(X : Float) : Float; *} +{***********************************************************************} +{* retourne l'arc tangente hyperbolique de l'argument *} +{* arg th(x) = 1/2 ln [ (1 + x) / (1 - x) ] *} +{***********************************************************************} +{* ST(0) ST(1) ST(2) ST(3) *} +{* ln(2) - - - *} +{* x ln(2) - - *} +{* x x ln(2) - *} +{* 1 x x ln(2) *} +{* 1 x 1 + x ln(2) *} +{* 1 - x 1 + x ln(2) - *} +{* 1+x/1-x ln(2) - - *} +{* ln(z) - - - *} +{***********************************************************************} +function farctanh(x : float): float; assembler; +asm + FLDLN2 + FLD X + FLD ST(0) + FLD1 + FADD ST(2),ST + FSUBRP ST(1),ST + FDIVP ST(1),ST + FYL2X +end; diff --git a/npm_precl/dmath/mcmc.pas b/npm_precl/dmath/mcmc.pas new file mode 100755 index 0000000..4536521 --- /dev/null +++ b/npm_precl/dmath/mcmc.pas @@ -0,0 +1,273 @@ +{ ********************************************************************** + * Unit MCMC.PAS * + * Version 1.2 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Simulation by Markov Chain Monte Carlo (MCMC) with the + Metropolis-Hastings algorithm. + + This algorithm simulates the probability density function (pdf) of a + vector X. The pdf P(X) is written as: + + P(X) = C * Exp(- F(X) / T) + + Simulating P by the Metropolis-Hastings algorithm is equivalent to + minimizing F by simulated annealing at the constant temperature T. + The constant C is not used in the simulation. + + The series of random vectors generated during the annealing step + constitutes a Markov chain which tends towards the pdf to be simulated. + + It is possible to run several cycles of the algorithm. + The variance-covariance matrix of the simulated distribution is + re-evaluated at the end of each cycle and used for the next cycle. + ********************************************************************** } + +unit MCMC; + +interface + +uses + FMath, Matrices, Optim, Regress; + + +{ ********************************************************************** + Metropolis-Hastings parameters + ********************************************************************** } + +const + MH_NCycles : Integer = 1; { Number of cycles } + MH_MaxSim : Integer = 1000; { Max nb of simulations at each cycle } + MH_SavedSim : Integer = 200; { Nb of simulations to be saved } + +{ ********************************************************************** + Simulation routine + ********************************************************************** } + + function Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Simulation of a probability density function by the + Metropolis-Hastings algorithm + ---------------------------------------------------------------------- + Input parameters : Func = Function such that the pdf is + P(X) = C * Exp(- Func(X) / T) + T = Temperature + X = Initial mean vector + V = Initial variance-covariance matrix + Lbound, + Ubound = Indices of first and last variables + ---------------------------------------------------------------------- + Output parameters : Xmat = Matrix of simulated vectors, stored + columnwise, i.e. + Xmat[Lbound..Ubound, 1..MH_SavedSim] + X = Mean of distribution + V = Variance-covariance matrix of distribution + X_min = Coordinates of minimum of F(X) + (mode of the distribution) + F_min = Value of F(X) at minimum + ---------------------------------------------------------------------- + Possible results : MAT_OK : No error + MAT_NOT_PD : The variance-covariance matrix + is not positive definite + ---------------------------------------------------------------------- } + +implementation + + function CalcSD(V : PMatrix; + Lbound, Ubound : Integer; + L : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Computes the standard deviations for independent random numbers + from the variance-covariance matrix. + ---------------------------------------------------------------------- } + var + I, ErrCode : Integer; + begin + I := LBound; + ErrCode := 0; + repeat + if V^[I]^[I] > 0.0 then + L^[I]^[I] := Sqrt(V^[I]^[I]) + else + ErrCode := MAT_NOT_PD; + Inc(I); + until (ErrCode <> 0) or (I > Ubound); + CalcSD := ErrCode; + end; + + procedure GenIndepRandomVector(X : PVector; + L : PMatrix; + Lbound, Ubound : Integer; + X1 : PVector); +{ ---------------------------------------------------------------------- + Generates a random vector X1 from X, using independent gaussian random + increments. L is the diagonal matrix of the standard deviations. + ---------------------------------------------------------------------- } + var + I : Integer; + begin + for I := Lbound to Ubound do + X1^[I] := RanGauss(X^[I], L^[I]^[I]); + end; + + procedure GenRandomVector(X : PVector; + L : PMatrix; + Lbound, Ubound : Integer; + X1 : PVector); +{ ---------------------------------------------------------------------- + Generates a random vector X1 from X, using correlated gaussian random + increments. L is the Cholesky factor of the variance-covariance matrix + ---------------------------------------------------------------------- } + var + U : PVector; + I, J : Integer; + begin + { Form a vector U of independent standard normal variates } + DimVector(U, Ubound); + for I := Lbound to Ubound do + U^[I] := RanGaussStd; + + { Form X1 = X + L*U, which follows the multinormal distribution } + for I := Lbound to Ubound do + begin + X1^[I] := X^[I]; + for J := Lbound to I do + X1^[I] := X1^[I] + L^[I]^[J] * U^[J]; + end; + DelVector(U, Ubound); + end; + + function Accept(DeltaF, T : Float) : Boolean; +{ ---------------------------------------------------------------------- + Checks if a variation DeltaF of the function at temperature T is + acceptable. + ---------------------------------------------------------------------- } + begin + Accept := (DeltaF < 0.0) or (Expo(- DeltaF / T) > RanMar); + end; + + function HastingsCycle(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Indep : Boolean; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs one cycle of the Metropolis-Hastings algorithm + ---------------------------------------------------------------------- } + var + F, F1 : Float; { Function values } + DeltaF : Float; { Variation of function } + X1 : PVector; { New coordinates } + L : PMatrix; { Standard dev. or Cholesky factor } + I, K : Integer; { Loop variable } + Iter : Integer; { Iteration count } + FirstSavedSim : Integer; { Index of first simulation to be saved } + ErrCode : Integer; { Error code } + begin + { Dimension arrays } + DimVector(X1, Ubound); + DimMatrix(L, Ubound, Ubound); + + { Compute SD's or Cholesky factor } + if Indep then + ErrCode := CalcSD(V, Lbound, Ubound, L) + else + ErrCode := Cholesky(V, Lbound, Ubound, L); + + HastingsCycle := ErrCode; + if ErrCode = MAT_NOT_PD then Exit; + + { Compute initial function value } + F := Func(X); + + { Perform MH_MaxSim simulations at constant temperature } + FirstSavedSim := MH_MaxSim - MH_SavedSim + 1; + Iter := 1; + K := 1; + + repeat + { Generate new vector } + if Indep then + GenIndepRandomVector(X, L, Lbound, Ubound, X1) + else + GenRandomVector(X, L, Lbound, Ubound, X1); + + { Compute new function value } + F1 := Func(X1); + DeltaF := F1 - F; + + { Check for acceptance } + if Accept(DeltaF, T) then + begin + CopyVector(X, X1, Lbound, Ubound); + + if Iter >= FirstSavedSim then + begin + { Save simulated vector into column K of matrix Xmat } + CopyColFromVector(Xmat, X1, Lbound, Ubound, K); + Inc(K); + end; + + if F1 < F_min then + begin + { Update minimum } + CopyVector(X_min, X1, Lbound, Ubound); + F_min := F1; + end; + + F := F1; + Inc(Iter); + end; + until Iter > MH_MaxSim; + + { Update mean vector and variance-covariance matrix } + VecMean(Xmat, MH_SavedSim, Lbound, Ubound, X); + MatVarCov(Xmat, MH_SavedSim, Lbound, Ubound, X, V); + + DelVector(X1, Ubound); + DelMatrix(L, Ubound, Ubound); + end; + + function Hastings(Func : TFuncNVar; + T : Float; + X : PVector; + V : PMatrix; + Lbound, Ubound : Integer; + Xmat : PMatrix; + X_min : PVector; + var F_min : Float) : Integer; + var + K, ErrCode : Integer; + Indep : Boolean; + begin + { Initialize the Marsaglia random number generator + using the standard Pascal generator } + Randomize; + RMarIn(System.Random(10000), System.Random(10000)); + + K := 1; + Indep := True; + F_min := MAXNUM; + + repeat + ErrCode := HastingsCycle(Func, T, X, V, Lbound, Ubound, + Indep, Xmat, X_min, F_min); + Indep := False; + Inc(K); + until (ErrCode <> 0) or (K > MH_NCycles); + + Hastings := ErrCode; + end; + +end. \ No newline at end of file diff --git a/npm_precl/dmath/models.pas b/npm_precl/dmath/models.pas new file mode 100755 index 0000000..7dfd892 --- /dev/null +++ b/npm_precl/dmath/models.pas @@ -0,0 +1,530 @@ +{ ********************************************************************** + * Unit MODELS.PAS * + * Version 1.4 * + * (c) J. Debord, August 2000 * + ********************************************************************** + Library of regression and variance models + ********************************************************************** } + +unit Models; + +{$F+} + +interface + +uses + FMath, + Matrices, + Regress, + FitLin, + FitMult, + FitPoly, + FitFrac, + FitExpo, + FitIExpo, + FitExLin, + FitPower, + FitMich, + FitHill, + FitLogis, + FitPKa; + +{ --------------------------------------------------------------------- + Highest index of regression models + --------------------------------------------------------------------- } +const + MAXMODEL = 11; + +{ --------------------------------------------------------------------- + Highest index of variance models + --------------------------------------------------------------------- } +const + MAXVARMODEL = 5; + +{ --------------------------------------------------------------------- + Definition of regression models + --------------------------------------------------------------------- } +const + REG_LIN = 0; { Linear } + REG_MULT = 1; { Multiple linear } + REG_POL = 2; { Polynomial } + REG_FRAC = 3; { Rational fraction } + REG_EXPO = 4; { Sum of exponentials } + REG_IEXPO = 5; { Increasing exponential } + REG_EXLIN = 6; { Exponential + linear } + REG_POWER = 7; { Power } + REG_MICH = 8; { Michaelis } + REG_HILL = 9; { Hill } + REG_LOGIS = 10; { Logistic } + REG_PKA = 11; { Acid/Base titration curve } + +{ --------------------------------------------------------------------- + Definition of variance models + --------------------------------------------------------------------- } +const + VAR_CONST = 0; { Constant } + VAR_LIN = 1; { Linear } + VAR_POL2 = 2; { 2nd degree polynomial } + VAR_POL3 = 3; { 3rd degree polynomial } + VAR_EXPO = 4; { Exponential } + VAR_POWER = 5; { Power } + +{ --------------------------------------------------------------------- + Names of regression models + --------------------------------------------------------------------- } + +const + MODELNAME : array[0..MAXMODEL] of String = +{$IFDEF FRENCH} + ('Lineaire', + 'Lineaire multiple', + 'Polynomial', + 'Fraction rationnelle', + 'Somme d''exponentielles', + 'Exponentielle croissante', + 'Exponentielle + lineaire', + 'Puissance', + 'Michaelis', + 'Hill', + 'Logistique', + 'Titrage acide/base'); +{$ELSE} + ('Linear', + 'Multiple linear', + 'Polynomial', + 'Rational fraction', + 'Sum of exponentials', + 'Increasing exponential', + 'Exponential + linear', + 'Power', + 'Michaelis', + 'Hill', + 'Logistic', + 'Acid/Base titration curve'); +{$ENDIF} + +{ --------------------------------------------------------------------- + Names of variance models + --------------------------------------------------------------------- } + +const + VARMODELNAME : array[0..MAXVARMODEL] of String = +{$IFDEF FRENCH} + ('Constante', + 'Lineaire', + 'Polynome de degre 2', + 'Polynome de degre 3', + 'Exponentielle', + 'Puissance'); +{$ELSE} + ('Constant', + 'Linear', + '2nd degree polynomial', + '3rd degree polynomial', + 'Exponential', + 'Power'); +{$ENDIF} + +function FuncName : String; +{ -------------------------------------------------------------------- + Returns the name of the regression function + -------------------------------------------------------------------- } + +function FirstParam : Integer; +{ -------------------------------------------------------------------- + Returns the index of the first fitted parameter + -------------------------------------------------------------------- } + +function LastParam : Integer; +{ -------------------------------------------------------------------- + Returns the index of the last fitted parameter + -------------------------------------------------------------------- } + +function ParamName(I : Integer) : String; +{ -------------------------------------------------------------------- + Returns the name of the I-th fitted parameter + -------------------------------------------------------------------- } + +function RegFunc(X : Float; B : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the regression function for one independent variable + B is the vector of parameters + -------------------------------------------------------------------- } + +function RegFuncNVar(X, B : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the regression function for several independent variables + B is the vector of parameters + -------------------------------------------------------------------- } + +procedure DerivProc(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); +{ -------------------------------------------------------------------- + Computes the derivatives of the regression function at point (X,Y) + with respect to the parameters B. The results are returned in D. + D^[I] contains the derivative with respect to the I-th parameter. + -------------------------------------------------------------------- } + +procedure InitModel(Reg_Model, Var_Model : Integer; CstPar : PVector); +{ -------------------------------------------------------------------- + Initializes the regression and variance models. Constant parameters + (e.g. degree of polynomial) are passed in vector CstPar. + -------------------------------------------------------------------- } + +function WLSFit(X : PVector; + U : PMatrix; + Y : PVector; + N : Integer; + Init : Boolean; + MaxIter : Integer; + Tol : Float; + Theta, B : PVector; + B_min, B_max : PVector; + V : PMatrix; + Ycalc, S : PVector; + var Test : TRegTest) : Integer; +{ ---------------------------------------------------------------------- + Fits the regression function and computes the regression tests + ---------------------------------------------------------------------- + Input : X, U = vector or matrix of independent variable(s) + Y = vector of dependent variable + N = number of observations + Init = TRUE to compute initial parameter estimates + FALSE to use the current values + MaxIter = maximum number of iterations + (if 0 the parameters will not be refined) + Tol = required parameter precision + Theta = variance parameters + B = initial parameters values + B_min, B_max = parameter bounds + -------------------------------------------------------------------- + Output : Theta = updated variance parameters + (residual variance stored in Theta^[0]) + B = regression parameters + V = variance-covariance matrix + Ycalc = estimated Y values + S = standard deviations of Y + Test = regression tests + -------------------------------------------------------------------- + Possible results = OPT_OK : no error + OPT_SING : singular matrix + OPT_BIG_LAMBDA : too high Marquardt's parameter + OPT_NON_CONV : non-convergence + -------------------------------------------------------------------- } + +function VarFuncName : String; +{ -------------------------------------------------------------------- + Returns the name of the variance function + -------------------------------------------------------------------- } + +function LastVarParam : Integer; +{ ---------------------------------------------------------------------- + Returns the index of the last variance parameter (upper bound of Theta) + ---------------------------------------------------------------------- } + +function VarFunc(Y : Float; Theta : PVector) : Float; +{ -------------------------------------------------------------------- + Computes the variance of an observation Y. The parameters are + Theta^[1], Theta^[2],... The true variance is Theta^[0] * VarFunc, + where Theta^[0] (equal to the residual variance Vr) is estimated by + the regression program. + -------------------------------------------------------------------- } + +implementation + +const + RegModel : Integer = 0; { Index of regression model } + VarModel : Integer = 0; { Index of variance model } + + function FuncName : String; + begin + case RegModel of + REG_LIN : FuncName := FitLin.FuncName; + REG_MULT : FuncName := FitMult.FuncName; + REG_POL : FuncName := FitPoly.FuncName; + REG_FRAC : FuncName := FitFrac.FuncName; + REG_EXPO : FuncName := FitExpo.FuncName; + REG_IEXPO : FuncName := FitIExpo.FuncName; + REG_EXLIN : FuncName := FitExLin.FuncName; + REG_POWER : FuncName := FitPower.FuncName; + REG_MICH : FuncName := FitMich.FuncName; + REG_HILL : FuncName := FitHill.FuncName; + REG_LOGIS : FuncName := FitLogis.FuncName; + REG_PKA : FuncName := FitPKa.FuncName; + end; + end; + + function FirstParam : Integer; + begin + case RegModel of + REG_LIN : FirstParam := FitLin.FirstParam; + REG_MULT : FirstParam := FitMult.FirstParam; + REG_POL : FirstParam := FitPoly.FirstParam; + REG_FRAC : FirstParam := FitFrac.FirstParam; + REG_EXPO : FirstParam := FitExpo.FirstParam; + REG_IEXPO : FirstParam := FitIExpo.FirstParam; + REG_EXLIN : FirstParam := FitExLin.FirstParam; + REG_POWER : FirstParam := FitPower.FirstParam; + REG_MICH : FirstParam := FitMich.FirstParam; + REG_HILL : FirstParam := FitHill.FirstParam; + REG_LOGIS : FirstParam := FitLogis.FirstParam; + REG_PKA : FirstParam := FitPKa.FirstParam; + end; + end; + + function LastParam : Integer; + begin + case RegModel of + REG_LIN : LastParam := FitLin.LastParam; + REG_MULT : LastParam := FitMult.LastParam; + REG_POL : LastParam := FitPoly.LastParam; + REG_FRAC : LastParam := FitFrac.LastParam; + REG_EXPO : LastParam := FitExpo.LastParam; + REG_IEXPO : LastParam := FitIExpo.LastParam; + REG_EXLIN : LastParam := FitExLin.LastParam; + REG_POWER : LastParam := FitPower.LastParam; + REG_MICH : LastParam := FitMich.LastParam; + REG_HILL : LastParam := FitHill.LastParam; + REG_LOGIS : LastParam := FitLogis.LastParam; + REG_PKA : LastParam := FitPKa.LastParam; + end; + end; + + function ParamName(I : Integer) : String; + begin + case RegModel of + REG_LIN : ParamName := FitLin.ParamName(I); + REG_MULT : ParamName := FitMult.ParamName(I); + REG_POL : ParamName := FitPoly.ParamName(I); + REG_FRAC : ParamName := FitFrac.ParamName(I); + REG_EXPO : ParamName := FitExpo.ParamName(I); + REG_IEXPO : ParamName := FitIExpo.ParamName(I); + REG_EXLIN : ParamName := FitExLin.ParamName(I); + REG_POWER : ParamName := FitPower.ParamName(I); + REG_MICH : ParamName := FitMich.ParamName(I); + REG_HILL : ParamName := FitHill.ParamName(I); + REG_LOGIS : ParamName := FitLogis.ParamName(I); + REG_PKA : ParamName := FitPKa.ParamName(I); + end; + end; + + function RegFunc(X : Float; B : PVector) : Float; + begin + case RegModel of + REG_LIN : RegFunc := FitLin.RegFunc(X, B); + REG_POL : RegFunc := FitPoly.RegFunc(X, B); + REG_FRAC : RegFunc := FitFrac.RegFunc(X, B); + REG_EXPO : RegFunc := FitExpo.RegFunc(X, B); + REG_IEXPO : RegFunc := FitIExpo.RegFunc(X, B); + REG_EXLIN : RegFunc := FitExLin.RegFunc(X, B); + REG_POWER : RegFunc := FitPower.RegFunc(X, B); + REG_MICH : RegFunc := FitMich.RegFunc(X, B); + REG_HILL : RegFunc := FitHill.RegFunc(X, B); + REG_LOGIS : RegFunc := FitLogis.RegFunc(X, B); + REG_PKA : RegFunc := FitPKa.RegFunc(X, B); + end; + end; + + function RegFuncNVar(X, B : PVector) : Float; + begin + case RegModel of + REG_MULT : RegFuncNVar := FitMult.RegFunc(X, B); + end; + end; + + procedure DerivProc(RegFunc : TRegFunc; X, Y : Float; B, D : PVector); + begin + case RegModel of + REG_FRAC : FitFrac.DerivProc(X, Y, B, D); + REG_EXPO : FitExpo.DerivProc(X, B, D); + REG_IEXPO : FitIExpo.DerivProc(X, B, D); + REG_EXLIN : FitExLin.DerivProc(X, B, D); + REG_POWER : FitPower.DerivProc(X, Y, B, D); + REG_MICH : FitMich.DerivProc(X, Y, B, D); + REG_HILL : FitHill.DerivProc(X, Y, B, D); + REG_LOGIS : FitLogis.DerivProc(X, B, D); + REG_PKA : FitPKa.DerivProc(X, B, D); + else + NumDeriv(RegFunc, X, Y, B, D); + end; + end; + + procedure InitModel(Reg_Model, Var_Model : Integer; CstPar : PVector); + begin + RegModel := Reg_Model; + VarModel := Var_Model; + case RegModel of + REG_MULT : FitMult.InitModel(CstPar); + REG_POL : FitPoly.InitModel(CstPar); + REG_FRAC : FitFrac.InitModel(CstPar); + REG_EXPO : FitExpo.InitModel(CstPar); + REG_LOGIS : FitLogis.InitModel(CstPar); + end; + end; + + function FitModel(Method : Integer; + X : PVector; + U : PMatrix; + Y, W : PVector; + N : Integer; + B : PVector; + V : PMatrix) : Integer; +{ -------------------------------------------------------------------- + Fits the regression model by unweighted linear least squares. For + nonlinear models, this is only an approximate fit, to be refined by + the nonlinear regression procedure WLSFit + -------------------------------------------------------------------- + Input : Method = 0 for unweighted regression, 1 for weighted + X, U = vector or matrix of independent variable(s) + Y = vector of dependent variable + W = weights + N = number of observations + -------------------------------------------------------------------- + Output : B = estimated regression parameters + V = unscaled variance-covariance matrix (for linear + and polynomial models only). The true matrix will + be Vr * V, where Vr is the residual variance. + -------------------------------------------------------------------- + The function returns 0 if no error occurred + -------------------------------------------------------------------- } + begin + case RegModel of + REG_LIN : FitModel := FitLin.FitModel(Method, X, Y, W, N, B, V); + REG_MULT : FitModel := FitMult.FitModel(Method, U, Y, W, N, B, V); + REG_POL : FitModel := FitPoly.FitModel(Method, X, Y, W, N, B, V); + REG_FRAC : FitModel := FitFrac.FitModel(Method, X, Y, W, N, B); + REG_EXPO : FitModel := FitExpo.FitModel(Method, X, Y, W, N, B); + REG_IEXPO : FitModel := FitIExpo.FitModel(Method, X, Y, W, N, B); + REG_EXLIN : FitModel := FitExLin.FitModel(X, Y, N, B); + REG_POWER : FitModel := FitPower.FitModel(Method, X, Y, W, N, B); + REG_MICH : FitModel := FitMich.FitModel(Method, X, Y, W, N, B); + REG_HILL : FitModel := FitHill.FitModel(Method, X, Y, W, N, B); + REG_LOGIS : FitModel := FitLogis.FitModel(Method, X, Y, W, N, B); + REG_PKA : FitModel := FitPKa.FitModel(X, Y, N, B); + end; + end; + + function WLSFit(X : PVector; + U : PMatrix; + Y : PVector; + N : Integer; + Init : Boolean; + MaxIter : Integer; + Tol : Float; + Theta, B : PVector; + B_min, B_max : PVector; + V : PMatrix; + Ycalc, S : PVector; + var Test : TRegTest) : Integer; + var + Method : Integer; { Regression method } + W : PVector; { Weights } + Xk : PVector; { Vector of variables for observation k } + Sr : Float; { Residual standard deviation } + ErrCode : Integer; { Error code } + K : Integer; { Loop variable } + begin + DimVector(W, N); + DimVector(Xk, LastParam); + + { Determine regression method } + if VarModel = VAR_CONST then Method := 0 else Method := 1; + + { Compute weights if necessary } + if Method = 1 then + for K := 1 to N do + W^[K] := 1.0 / VarFunc(Y^[K], Theta); + + { Compute initial parameter estimates if necessary } + if Init then + ErrCode := FitModel(Method, X, U, Y, W, N, B, V) + else + ErrCode := 0; + + { Refine parameters if necessary } + if not(RegModel in [REG_LIN, REG_MULT, REG_POL]) and + (MaxIter > 0) and (ErrCode = 0) then + if VarModel = VAR_CONST then + ErrCode := NLFit({$IFDEF FPK}@{$ENDIF}RegFunc, + {$IFDEF FPK}@{$ENDIF}DerivProc, + X, Y, N, FirstParam, LastParam, + MaxIter, Tol, B, B_min, B_max, V) + else + ErrCode := WNLFit({$IFDEF FPK}@{$ENDIF}RegFunc, + {$IFDEF FPK}@{$ENDIF}DerivProc, + X, Y, W, N, FirstParam, LastParam, + MaxIter, Tol, B, B_min, B_max, V); + + if ErrCode = 0 then + begin + { Estimate Y values } + if RegModel = REG_MULT then + for K := 1 to N do + begin + CopyVectorFromCol(Xk, U, FirstParam, LastParam, K); + Ycalc^[K] := RegFuncNVar(Xk, B); + end + else + for K := 1 to N do + Ycalc^[K] := RegFunc(X^[K], B); + + { Compute regression tests and update variance-covariance matrix } + if VarModel = VAR_CONST then + RegTest(Y, Ycalc, N, FirstParam, LastParam, V, Test) + else + WRegTest(Y, Ycalc, W, N, FirstParam, LastParam, V, Test); + + { Store residual variance in Theta^[0] } + Theta^[0] := Test.Vr; + + { Compute standard deviations } + Sr := Sqrt(Test.Vr); + for K := 1 to N do + S^[K] := Sr; + if VarModel <> VAR_CONST then + for K := 1 to N do + S^[K] := S^[K] / Sqrt(W^[K]); + end; + + DelVector(W, N); + DelVector(Xk, LastParam); + + WLSFit := ErrCode; + end; + + function VarFuncName : String; + begin + case VarModel of + VAR_CONST : VarFuncName := 'v = e0'; + VAR_LIN : VarFuncName := 'v = e0.(1 + e1.y)'; + VAR_POL2 : VarFuncName := 'v = e0.(1 + e1.y + e2.y^2)'; + VAR_POL3 : VarFuncName := 'v = e0.(1 + e1.y + e2.y^2 + e3.y^3)'; + VAR_EXPO : VarFuncName := 'v = e0.exp(e1.y)'; + VAR_POWER : VarFuncName := 'v = e0.y^e1'; + end; + end; + + function VarFunc(Y : Float; Theta : PVector) : Float; + begin + case VarModel of + VAR_CONST : VarFunc := 1.0; + VAR_LIN : VarFunc := 1.0 + Theta^[1] * Y; + VAR_POL2 : VarFunc := 1.0 + Y * (Theta^[1] + Theta^[2] * Y); + VAR_POL3 : VarFunc := 1.0 + Y * (Theta^[1] + Y * (Theta^[2] + Theta^[3] * Y)); + VAR_EXPO : VarFunc := Exp(Theta^[1] * Y); + VAR_POWER : VarFunc := Power(Y, Theta^[1]); + end; + end; + + function LastVarParam : Integer; + begin + case VarModel of + VAR_CONST : LastVarParam := 0; + VAR_LIN : LastVarParam := 1; + VAR_POL2 : LastVarParam := 2; + VAR_POL3 : LastVarParam := 3; + VAR_EXPO : LastVarParam := 1; + VAR_POWER : LastVarParam := 1; + end; + end; + +end. diff --git a/npm_precl/dmath/optim.pas b/npm_precl/dmath/optim.pas new file mode 100755 index 0000000..17575b0 --- /dev/null +++ b/npm_precl/dmath/optim.pas @@ -0,0 +1,972 @@ +{ ********************************************************************** + * Unit OPTIM.PAS * + * Version 2.1 * + * (c) J. Debord, June 2001 * + ********************************************************************** + This unit implements the following methods for function minimization: + + * Golden search for a function of one variable + * Simplex, Marquardt, BFGS for a function of several variables + ********************************************************************** + References: + 1) 'Numerical Recipes' by Press et al. + 2) D. W. MARQUARDT, J. Soc. Indust. Appl. Math., 1963, 11, 431-441 + 3) J. A. NELDER & R. MEAD, Comput. J., 1964, 7, 308-313 + 4) R. O'NEILL, Appl. Statist., 1971, 20, 338-345 + ********************************************************************** } + +unit Optim; + +interface + +uses + FMath, Matrices; + +{ ********************************************************************** + Error codes + ********************************************************************** } + +const + OPT_OK = 0; { No error } + OPT_SING = - 1; { Singular hessian matrix } + OPT_BIG_LAMBDA = - 2; { Too high Marquardt's parameter } + OPT_NON_CONV = - 3; { Non-convergence } + +{ ********************************************************************** + Functional types + ********************************************************************** } + +type + { Function of several variables } + TFuncNVar = function(X : PVector) : Float; + + { Procedure to compute gradient vector } + TGradient = procedure(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); + + { Procedure to compute gradient vector and hessian matrix } + THessGrad = procedure(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); + +{ ********************************************************************** + Log file + ********************************************************************** } + +const + WriteLogFile : Boolean = False; { Write iteration info to log file } + LogFileName : String = 'optim.log'; { Name of log file } + +{ ********************************************************************** + Minimization routines + ********************************************************************** } + +function GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs a golden search for the minimum of function Func + ---------------------------------------------------------------------- + Input parameters : Func = objective function + A, B = two points near the minimum + MaxIter = maximum number of iterations + Tol = required precision (should not be less than + the square root of the machine precision) + ---------------------------------------------------------------------- + Output parameters : Xmin, Ymin = coordinates of minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + +{ ---------------------------------------------------------------------- + Minimizes function Func from point X in the direction specified by + DeltaX + ---------------------------------------------------------------------- + Input parameters : Func = objective function + X = initial minimum coordinates + DeltaX = direction in which minimum is searched + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function Simplex(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by the simplex method + of Nelder and Mead + ---------------------------------------------------------------------- + Input parameters : Func = objective function + X = initial minimum coordinates + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +procedure NumGradient(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); +{ ---------------------------------------------------------------------- + Computes the gradient vector of a function of several variables by + numerical differentiation + ---------------------------------------------------------------------- + Input parameters : Func = function of several variables + X = vector of variables + Lbound, + Ubound = indices of first and last variables + ---------------------------------------------------------------------- + Output parameter : G = gradient vector + ---------------------------------------------------------------------- } + +procedure NumHessGrad(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); +{ ---------------------------------------------------------------------- + Computes gradient vector & hessian matrix by numerical differentiation + ---------------------------------------------------------------------- + Input parameters : as in NumGradient + ---------------------------------------------------------------------- + Output parameters : G = gradient vector + H = hessian matrix + ---------------------------------------------------------------------- } + +function Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by Marquardt's method + ---------------------------------------------------------------------- + Input parameters : Func = objective function + HessGrad = procedure to compute gradient & hessian + X = initial minimum coordinates + Lbound, + Ubound = indices of first and last variables + MaxIter = maximum number of iterations + Tol = required precision + ---------------------------------------------------------------------- + Output parameters : X = refined minimum coordinates + F_min = function value at minimum + H_inv = inverse hessian matrix + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_SING + OPT_BIG_LAMBDA + OPT_NON_CONV + ---------------------------------------------------------------------- } + +function BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by the + Broyden-Fletcher-Goldfarb-Shanno method + ---------------------------------------------------------------------- + Parameters : Gradient = procedure to compute gradient vector + Other parameters as in Marquardt + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + +var + Eps : Float; { Fractional increment for numer. derivation } + X1 : PVector; { Initial point for line minimization } + DeltaX1 : PVector; { Direction for line minimization } + Lbound1, Ubound1 : Integer; { Bounds of X1 and DeltaX1 } + LinObjFunc : TFuncNVar; { Objective function for line minimization } + LogFile : Text; { Stores the result of each minimization step } + + + procedure MinBrack(Func : TFunc; var A, B, C, Fa, Fb, Fc : Float); +{ ---------------------------------------------------------------------- + Given two points (A, B) this procedure finds a triplet (A, B, C) + such that: + + 1) A < B < C + 2) A, B, C are within the golden ratio + 3) Func(B) < Func(A) and Func(B) < Func(C). + + The corresponding function values are returned in Fa, Fb, Fc + ---------------------------------------------------------------------- } + + begin + if A > B then + FSwap(A, B); + Fa := Func(A); + Fb := Func(B); + if Fb > Fa then + begin + FSwap(A, B); + FSwap(Fa, Fb); + end; + C := B + GOLD * (B - A); + Fc := Func(C); + while Fc < Fb do + begin + A := B; + B := C; + Fa := Fb; + Fb := Fc; + C := B + GOLD * (B - A); + Fc := Func(C); + end; + if A > C then + begin + FSwap(A, C); + FSwap(Fa, Fc); + end; + end; + + function GoldSearch(Func : TFunc; + A, B : Float; + MaxIter : Integer; + Tol : Float; + var Xmin, Ymin : Float) : Integer; + var + C, Fa, Fb, Fc, F1, F2, MinTol, X0, X1, X2, X3 : Float; + Iter : Integer; + begin + MinTol := Sqrt(MACHEP); + if Tol < MinTol then Tol := MinTol; + MinBrack(Func, A, B, C, Fa, Fb, Fc); + X0 := A; + X3 := C; + if (C - B) > (B - A) then + begin + X1 := B; + X2 := B + CGOLD * (C - B); + F1 := Fb; + F2 := Func(X2); + end + else + begin + X1 := B - CGOLD * (B - A); + X2 := B; + F1 := Func(X1); + F2 := Fb; + end; + Iter := 0; + while (Iter <= MaxIter) and (Abs(X3 - X0) > Tol * (Abs(X1) + Abs(X2))) do + if F2 < F1 then + begin + X0 := X1; + X1 := X2; + F1 := F2; + X2 := X1 + CGOLD * (X3 - X1); + F2 := Func(X2); + Inc(Iter); + end + else + begin + X3 := X2; + X2 := X1; + F2 := F1; + X1 := X2 - CGOLD * (X2 - X0); + F1 := Func(X1); + Inc(Iter); + end; + if F1 < F2 then + begin + Xmin := X1; + Ymin := F1; + end + else + begin + Xmin := X2; + Ymin := F2; + end; + if Iter > MaxIter then + GoldSearch := OPT_NON_CONV + else + GoldSearch := OPT_OK; + end; + + procedure CreateLogFile; + begin + Assign(LogFile, LogFileName); + Rewrite(LogFile); + end; + + function Simplex(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + const + STEP = 1.50; { Step used to construct the initial simplex } + var + P : PMatrix; { Simplex coordinates } + F : PVector; { Function values } + Pbar : PVector; { Centroid coordinates } + Pstar, P2star : PVector; { New vertices } + Ystar, Y2star : Float; { New function values } + F0 : Float; { Function value at minimum } + N : Integer; { Number of parameters } + M : Integer; { Index of last vertex } + L, H : Integer; { Vertices with lowest & highest F values } + I, J : Integer; { Loop variables } + Iter : Integer; { Iteration count } + Corr, MaxCorr : Float; { Corrections } + Sum : Float; + Flag : Boolean; + + procedure UpdateSimplex(Y : Float; Q : PVector); + { Update "worst" vertex and function value } + begin + F^[H] := Y; + CopyVector(P^[H], Q, Lbound, Ubound); + end; + + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'Simplex'); + WriteLn(LogFile, 'Iter F'); + end; + + N := Ubound - Lbound + 1; + M := Succ(Ubound); + + DimMatrix(P, M, Ubound); + DimVector(F, M); + DimVector(Pbar, Ubound); + DimVector(Pstar, Ubound); + DimVector(P2star, Ubound); + + Iter := 1; + F0 := MAXNUM; + + { Construct initial simplex } + for I := Lbound to M do + CopyVector(P^[I], X, Lbound, Ubound); + for I := Lbound to Ubound do + P^[I]^[I] := P^[I]^[I] * STEP; + + { Evaluate function at each vertex } + for I := Lbound to M do + F^[I] := Func(P^[I]); + + repeat + { Find vertices (L,H) having the lowest and highest + function values, i.e. "best" and "worst" vertices } + L := Lbound; + H := Lbound; + for I := Succ(Lbound) to M do + if F^[I] < F^[L] then + L := I + else if F^[I] > F^[H] then + H := I; + if F^[L] < F0 then + F0 := F^[L]; + + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F0:12); + + { Find centroid of points other than P(H) } + for J := Lbound to Ubound do + begin + Sum := 0.0; + for I := Lbound to M do + if I <> H then Sum := Sum + P^[I]^[J]; + Pbar^[J] := Sum / N; + end; + + { Reflect worst vertex through centroid } + for J := Lbound to Ubound do + Pstar^[J] := 2.0 * Pbar^[J] - P^[H]^[J]; + Ystar := Func(Pstar); + + { If reflection successful, try extension } + if Ystar < F^[L] then + begin + for J := Lbound to Ubound do + P2star^[J] := 3.0 * Pstar^[J] - 2.0 * Pbar^[J]; + Y2star := Func(P2star); + + { Retain extension or contraction } + if Y2star < F^[L] then + UpdateSimplex(Y2star, P2star) + else + UpdateSimplex(Ystar, Pstar); + end + else + begin + I := Lbound; + Flag := False; + repeat + if (I <> H) and (F^[I] > Ystar) then Flag := True; + Inc(I); + until Flag or (I > M); + if Flag then + UpdateSimplex(Ystar, Pstar) + else + begin + { Contraction on the reflection side of the centroid } + if Ystar <= F^[H] then + UpdateSimplex(Ystar, Pstar); + + { Contraction on the opposite side of the centroid } + for J := Lbound to Ubound do + P2star^[J] := 0.5 * (P^[H]^[J] + Pbar^[J]); + Y2star := Func(P2star); + if Y2star <= F^[H] then + UpdateSimplex(Y2star, P2star) + else + { Contract whole simplex } + for I := Lbound to M do + for J := Lbound to Ubound do + P^[I]^[J] := 0.5 * (P^[I]^[J] + P^[L]^[J]); + end; + end; + + { Test convergence } + MaxCorr := 0.0; + for J := Lbound to Ubound do + begin + Corr := Abs(P^[H]^[J] - P^[L]^[J]); + if Corr > MaxCorr then MaxCorr := Corr; + end; + Inc(Iter); + until (MaxCorr < Tol) or (Iter > MaxIter); + + CopyVector(X, P^[L], Lbound, Ubound); + F_min := F^[L]; + + DelMatrix(P, M, Ubound); + DelVector(F, M); + DelVector(Pbar, Ubound); + DelVector(Pstar, Ubound); + DelVector(P2star, Ubound); + + if WriteLogFile then + Close(LogFile); + + if Iter > MaxIter then + Simplex := OPT_NON_CONV + else + Simplex := OPT_OK; + end; + + {$F+} + function F1dim(R : Float) : Float; +{ ---------------------------------------------------------------------- + Function used by LinMin to find the minimum of the objective function + LinObjFunc in the direction specified by the global variables X1 and + DeltaX1. R is the step in this direction. + ---------------------------------------------------------------------- } + const + Xt : PVector = nil; + var + I : Integer; + begin + if Xt = nil then + DimVector(Xt, Ubound1); + for I := Lbound1 to Ubound1 do + Xt^[I] := X1^[I] + R * DeltaX1^[I]; + F1dim := LinObjFunc(Xt); + end; + {$F-} + + function LinMin(Func : TFuncNVar; + X, DeltaX : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + var + I, ErrCode : Integer; + R : Float; + begin + { Redimension global vectors } + DelVector(X1, Ubound1); + DelVector(DeltaX1, Ubound1); + DimVector(X1, Ubound); + DimVector(DeltaX1, Ubound); + + Lbound1 := Lbound; + Ubound1 := Ubound; + + { Initialize global variables } + LinObjFunc := Func; + for I := Lbound to Ubound do + begin + X1^[I] := X^[I]; + DeltaX1^[I] := DeltaX^[I] + end; + + { Perform golden search } + ErrCode := GoldSearch({$IFDEF FPK}@{$ENDIF}F1dim, + 0.0, 1.0, MaxIter, Tol, R, F_min); + + { Update variables } + if ErrCode = OPT_OK then + for I := Lbound to Ubound do + X^[I] := X^[I] + R * DeltaX^[I]; + + LinMin := ErrCode; + end; + + {$F+} + procedure NumGradient(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector); + var + Temp, Delta, Fplus, Fminus : Float; + I : Integer; + begin + for I := Lbound to Ubound do + begin + Temp := X^[I]; + if Temp <> 0.0 then Delta := Eps * Abs(Temp) else Delta := Eps; + X^[I] := Temp - Delta; + Fminus := Func(X); + X^[I] := Temp + Delta; + Fplus := Func(X); + G^[I] := (Fplus - Fminus) / (2.0 * Delta); + X^[I] := Temp; + end; + end; + {$F-} + + {$F+} + procedure NumHessGrad(Func : TFuncNVar; + X : PVector; + Lbound, Ubound : Integer; + G : PVector; + H : PMatrix); + var + Delta, Xminus, Xplus, Fminus, Fplus : PVector; + Temp1, Temp2, F, F2plus : Float; + I, J : Integer; + begin + DimVector(Delta, Ubound); { Increments } + DimVector(Xminus, Ubound); { X - Delta } + DimVector(Xplus, Ubound); { X + Delta } + DimVector(Fminus, Ubound); { F(X - Delta) } + DimVector(Fplus, Ubound); { F(X + Delta) } + + F := Func(X); + + for I := Lbound to Ubound do + begin + if X^[I] <> 0.0 then + Delta^[I] := Eps * Abs(X^[I]) + else + Delta^[I] := Eps; + Xplus^[I] := X^[I] + Delta^[I]; + Xminus^[I] := X^[I] - Delta^[I]; + end; + + for I := Lbound to Ubound do + begin + Temp1 := X^[I]; + X^[I] := Xminus^[I]; + Fminus^[I] := Func(X); + X^[I] := Xplus^[I]; + Fplus^[I] := Func(X); + X^[I] := Temp1; + end; + + for I := Lbound to Ubound do + begin + G^[I] := (Fplus^[I] - Fminus^[I]) / (2.0 * Delta^[I]); + H^[I]^[I] := (Fplus^[I] + Fminus^[I] - 2.0 * F) / Sqr(Delta^[I]); + end; + + for I := Lbound to Pred(Ubound) do + begin + Temp1 := X^[I]; + X^[I] := Xplus^[I]; + for J := Succ(I) to Ubound do + begin + Temp2 := X^[J]; + X^[J] := Xplus^[J]; + F2plus := Func(X); + H^[I]^[J] := (F2plus - Fplus^[I] - Fplus^[J] + F) / (Delta^[I] * Delta^[J]); + H^[J]^[I] := H^[I]^[J]; + X^[J] := Temp2; + end; + X^[I] := Temp1; + end; + + DelVector(Delta, Ubound); + DelVector(Xminus, Ubound); + DelVector(Xplus, Ubound); + DelVector(Fminus, Ubound); + DelVector(Fplus, Ubound); + end; + {$F-} + + function ParamConv(OldX, X : PVector; + Lbound, Ubound : Integer; + Tol : Float) : Boolean; +{ ---------------------------------------------------------------------- + Check for convergence on parameters + ---------------------------------------------------------------------- } + var + I : Integer; + Conv : Boolean; + begin + I := Lbound; + Conv := True; + repeat + Conv := Conv and (Abs(X^[I] - OldX^[I]) < FMax(Tol, Tol * Abs(OldX^[I]))); + Inc(I); + until (Conv = False) or (I > Ubound); + ParamConv := Conv; + end; + + function Marquardt(Func : TFuncNVar; + HessGrad : THessGrad; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; + const + LAMBDA0 = 1.0E-2; { Initial lambda value } + LAMBDAMAX = 1.0E+3; { Highest lambda value } + FTOL = 1.0E-10; { Tolerance on function decrease } + var + Lambda, + Lambda1 : Float; { Marquardt's lambda } + I : Integer; { Loop variable } + OldX : PVector; { Old parameters } + G : PVector; { Gradient vector } + H : PMatrix; { Hessian matrix } + A : PMatrix; { Modified Hessian matrix } + DeltaX : PVector; { New search direction } + F1 : Float; { New minimum } + Lambda_Ok : Boolean; { Successful Lambda decrease } + Conv : Boolean; { Convergence reached } + Done : Boolean; { Iterations done } + Iter : Integer; { Iteration count } + ErrCode : Integer; { Error code } + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'Marquardt'); + WriteLn(LogFile, 'Iter F Lambda'); + end; + + Lambda := LAMBDA0; + ErrCode := OPT_OK; + + DimVector(OldX, Ubound); + DimVector(G, Ubound); + DimMatrix(H, Ubound, Ubound); + DimMatrix(A, Ubound, Ubound); + DimVector(DeltaX, Ubound); + + F_min := Func(X); { Initial function value } + LinObjFunc := Func; { Function for line minimization } + + Iter := 1; + Conv := False; + Done := False; + + repeat + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12, ' ', Lambda:12); + + { Save current parameters } + CopyVector(OldX, X, Lbound, Ubound); + + { Compute Gradient and Hessian } + HessGrad(Func, X, Lbound, Ubound, G, H); + CopyMatrix(A, H, Lbound, Lbound, Ubound, Ubound); + + { Change sign of gradient } + for I := Lbound to Ubound do + G^[I] := - G^[I]; + + if Conv then { Newton-Raphson iteration } + begin + ErrCode := GaussJordan(A, G, Lbound, Ubound, H_inv, DeltaX); + if ErrCode = MAT_OK then + for I := Lbound to Ubound do + X^[I] := OldX^[I] + DeltaX^[I]; + Done := True; + end + else { Marquardt iteration } + begin + repeat + { Multiply each diagonal term of H by (1 + Lambda) } + Lambda1 := 1.0 + Lambda; + for I := Lbound to Ubound do + A^[I]^[I] := Lambda1 * H^[I]^[I]; + + ErrCode := GaussJordan(A, G, Lbound, Ubound, H_inv, DeltaX); + + if ErrCode = MAT_OK then + begin + { Initialize parameters } + CopyVector(X, OldX, Lbound, Ubound); + + { Minimize in the direction specified by DeltaX } + ErrCode := LinMin(Func, X, DeltaX, + Lbound, Ubound, 100, 0.01, F1); + + { Check that the function has decreased. Otherwise + increase Lambda, without exceeding LAMBDAMAX } + Lambda_Ok := (F1 - F_min) < F_min * FTOL; + if not Lambda_Ok then Lambda := 10.0 * Lambda; + if Lambda > LAMBDAMAX then ErrCode := OPT_BIG_LAMBDA; + end; + until Lambda_Ok or (ErrCode <> MAT_OK); + + { Check for convergence } + Conv := ParamConv(OldX, X, Lbound, Ubound, Tol); + + { Prepare next iteration } + Lambda := 0.1 * Lambda; + F_min := F1; + end; + + Inc(Iter); + if Iter > MaxIter then ErrCode := OPT_NON_CONV; + until Done or (ErrCode <> OPT_OK); + + DelVector(OldX, Ubound); + DelVector(G, Ubound); + DelMatrix(H, Ubound, Ubound); + DelMatrix(A, Ubound, Ubound); + DelVector(DeltaX, Ubound); + + if WriteLogFile then + Close(LogFile); + + if ErrCode = MAT_SINGUL then ErrCode := OPT_SING; + Marquardt := ErrCode; + end; + + function BFGS(Func : TFuncNVar; + Gradient : TGradient; + X : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float; + H_inv : PMatrix) : Integer; + var + I, J, Iter, ErrCode : Integer; + DeltaXmax, Gmax, P1, P2, R1, R2 : Float; + OldX, DeltaX, dX, G, OldG, dG, HdG, R1dX, R2HdG, U, P2U : PVector; + Conv : Boolean; + + function AbsMax(V : PVector; Lbound, Ubound : Integer) : Float; + { Returns the component with maximum absolute value } + var + I : Integer; + AbsV : PVector; + begin + DimVector(AbsV, Ubound); + for I := Lbound to Ubound do + AbsV^[I] := Abs(V^[I]); + AbsMax := Max(AbsV, Lbound, Ubound); + DelVector(AbsV, Ubound); + end; + + begin + if WriteLogFile then + begin + CreateLogFile; + WriteLn(LogFile, 'BFGS'); + WriteLn(LogFile, 'Iter F'); + end; + + DimVector(OldX, Ubound); + DimVector(DeltaX, Ubound); + DimVector(dX, Ubound); + DimVector(G, Ubound); + DimVector(OldG, Ubound); + DimVector(dG, Ubound); + DimVector(HdG, Ubound); + DimVector(R1dX, Ubound); + DimVector(R2HdG, Ubound); + DimVector(U, Ubound); + DimVector(P2U, Ubound); + + Iter := 0; + Conv := False; + LinObjFunc := Func; { Function for line minimization } + + { Initialize function } + F_min := Func(X); + + { Initialize inverse hessian to unit matrix } + for I := Lbound to Ubound do + for J := Lbound to Ubound do + if I = J then H_inv^[I]^[J] := 1.0 else H_inv^[I]^[J] := 0.0; + + { Initialize gradient } + Gradient(Func, X, Lbound, Ubound, G); + Gmax := AbsMax(G, Lbound, Ubound); + + { Initialize search direction } + if Gmax > MACHEP then + for I := Lbound to Ubound do + DeltaX^[I] := - G^[I] + else + Conv := True; { Quit if gradient is already small } + + while (not Conv) and (Iter < MaxIter) do + begin + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', F_min:12); + + { Normalize search direction to avoid excessive displacements } + DeltaXmax := AbsMax(DeltaX, Lbound, Ubound); + if DeltaXmax > 1.0 then + for I := Lbound to Ubound do + DeltaX^[I] := DeltaX^[I] / DeltaXmax; + + { Save old parameters and gradient } + CopyVector(OldX, X, Lbound, Ubound); + CopyVector(OldG, G, Lbound, Ubound); + + { Minimize along the direction specified by DeltaX } + ErrCode := LinMin(Func, X, DeltaX, Lbound, Ubound, 100, 0.01, F_min); + + { Compute new gradient } + Gradient(Func, X, Lbound, Ubound, G); + + { Compute differences between two successive + estimations of parameter vector and gradient vector } + for I := Lbound to Ubound do + begin + dX^[I] := X^[I] - OldX^[I]; + dG^[I] := G^[I] - OldG^[I]; + end; + + { Multiply by inverse hessian } + for I := Lbound to Ubound do + begin + HdG^[I] := 0.0; + for J := Lbound to Ubound do + HdG^[I] := HdG^[I] + H_inv^[I]^[J] * dG^[J]; + end; + + { Scalar products in denominator of BFGS formula } + P1 := 0.0; P2 := 0.0; + for I := Lbound to Ubound do + begin + P1 := P1 + dX^[I] * dG^[I]; + P2 := P2 + dG^[I] * HdG^[I]; + end; + + if (P1 = 0.0) or (P2 = 0.0) then + Conv := True + else + begin + { Inverses of scalar products } + R1 := 1.0 / P1; R2 := 1.0 / P2; + + { Compute BFGS correction terms } + for I := Lbound to Ubound do + begin + R1dX^[I] := R1 * dX^[I]; + R2HdG^[I] := R2 * HdG^[I]; + U^[I] := R1dX^[I] - R2HdG^[I]; + P2U^[I] := P2 * U^[I]; + end; + + { Update inverse hessian } + for I := Lbound to Ubound do + for J := Lbound to Ubound do + H_inv^[I]^[J] := H_inv^[I]^[J] + R1dX^[I] * dX^[J] + - R2HdG^[I] * HdG^[J] + P2U^[I] * U^[J]; + + { Update search direction } + for I := Lbound to Ubound do + begin + DeltaX^[I] := 0.0; + for J := Lbound to Ubound do + DeltaX^[I] := DeltaX^[I] - H_inv^[I]^[J] * G^[J]; + end; + + { Test convergence and update iteration count } + Conv := ParamConv(OldX, X, Lbound, Ubound, Tol); + Inc(Iter); + end; + end; + + DelVector(OldX, Ubound); + DelVector(DeltaX, Ubound); + DelVector(dX, Ubound); + DelVector(G, Ubound); + DelVector(OldG, Ubound); + DelVector(dG, Ubound); + DelVector(HdG, Ubound); + DelVector(R1dX, Ubound); + DelVector(R2HdG, Ubound); + DelVector(U, Ubound); + DelVector(P2U, Ubound); + + if WriteLogFile then + Close(LogFile); + + if Iter > MaxIter then + BFGS := OPT_NON_CONV + else + BFGS := OPT_OK; + end; + +begin + X1 := nil; + DeltaX1 := nil; + Ubound1 := 1; + Eps := Power(MACHEP, 0.333); +end. diff --git a/npm_precl/dmath/pastring.pas b/npm_precl/dmath/pastring.pas new file mode 100755 index 0000000..97881ab --- /dev/null +++ b/npm_precl/dmath/pastring.pas @@ -0,0 +1,275 @@ +{ ********************************************************************** + * Unit PASTRING.PAS * + * Version 1.8 * + * (c) J. Debord, December 2000 * + ********************************************************************** + Turbo Pascal string routines + ********************************************************************** } + +unit PaString; + +interface + +uses + FMath, FComp, Matrices; + +{ *** Global variables controlling the appearance of a numeric string ** } + +const + NumLength : Integer = 10; { Length of a numeric field } + MaxDec : Integer = 4; { Max. number of decimal places } + FloatPoint : Boolean = False; { Floating point notation } + NSZero : Boolean = True; { Write non significant zero's } + +{ ************************** String routines *************************** } + +function LTrim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes leading blanks + ---------------------------------------------------------------------- } + +function RTrim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes trailing blanks + ---------------------------------------------------------------------- } + +function Trim(S : String) : String; +{ ---------------------------------------------------------------------- + Removes leading and trailing blanks + ---------------------------------------------------------------------- } + +function StrChar(N : Byte; C : Char) : String; +{ ---------------------------------------------------------------------- + Returns a string made of character C repeated N times + ---------------------------------------------------------------------- } + +function RFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with trailing blanks for a total length L + ---------------------------------------------------------------------- } + +function LFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with leading blanks for a total length L + ---------------------------------------------------------------------- } + +function CFill(S : String; L : Byte) : String; +{ ---------------------------------------------------------------------- + Completes string S with leading blanks + to center the string on a total length L + ---------------------------------------------------------------------- } + +function Replace(S : String; C1, C2 : Char) : String; +{ ---------------------------------------------------------------------- + Replaces in string S all the occurences + of character C1 by character C2 + ---------------------------------------------------------------------- } + +function Extract(S : String; var Index : Byte; Delim : Char) : String; +{ ---------------------------------------------------------------------- + Extracts a field from a string. Index is the position of the first + character of the field. Delim is the character used to separate + fields (e.g. blank, comma or tabulation). Blanks immediately + following Delim are ignored. Index is updated to the position of + the next field. + ---------------------------------------------------------------------- } + +procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); +{ ---------------------------------------------------------------------- + Parses a string into its constitutive fields. Delim is the field + separator. The number of fields is returned in N. The fields are + returned in Field^[0]..Field^[N - 1]. Field must be dimensioned in + the calling program. + ---------------------------------------------------------------------- } + +function FloatToStr(X : Float) : String; +{ ---------------------------------------------------------------------- + Converts a real to a string according to the values of the global + variables NumLength, MaxDec, FloatPoint and NSZero + ---------------------------------------------------------------------- } + +function IntToStr(N : LongInt) : String; +{ ---------------------------------------------------------------------- + Converts an integer to a string according to the values of the global + variables NumLength and MaxDec. + ---------------------------------------------------------------------- } + +function CompToStr(Z : Complex) : String; +{ ---------------------------------------------------------------------- + Converts a complex number to a string. + ---------------------------------------------------------------------- } + +implementation + + function LTrim(S : String) : String; + begin + if S <> '' then + repeat + if S[1] = ' ' then Delete(S, 1, 1); + until S[1] <> ' '; + LTrim := S; + end; + + function RTrim(S : String) : String; + var + L1 : Byte; + begin + if S <> '' then + repeat + L1 := Length(S); + if S[L1] = ' ' then Delete(S, L1, 1); + until S[L1] <> ' '; + RTrim := S; + end; + + function Trim(S : String) : String; + begin + Trim := LTrim(RTrim(S)); + end; + + function StrChar(N : Byte; C : Char) : String; + var + I : Byte; + S : String; + begin + S := ''; + for I := 1 to N do + S := S + C; + StrChar := S; + end; + + function RFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + RFill := S + else + RFill := S + StrChar(L - L1, ' '); + end; + + function LFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + LFill := S + else + LFill := StrChar(L - L1, ' ') + S; + end; + + function CFill(S : String; L : Byte) : String; + var + L1 : Byte; + begin + L1 := Length(S); + if L1 >= L then + CFill := S + else + CFill := StrChar((L - L1) div 2, ' ') + S; + end; + + function Replace(S : String; C1, C2 : Char) : String; + var + S1 : String; + K : Byte; + begin + S1 := S; + K := Pos(C1, S1); + while K > 0 do + begin + S1[K] := C2; + K := Pos(C1, S1); + end; + Replace := S1; + end; + + function Extract(S : String; var Index : Byte; Delim : Char) : String; + var + I, L : Byte; + begin + I := Index; + L := Length(S); + + { Search for Delim } + while (I <= L) and (S[I] <> Delim) do + Inc(I); + + { Extract field } + if I = Index then + Extract := '' + else + Extract := Copy(S, Index, I - Index); + + { Skip blanks after Delim } + repeat + Inc(I); + until (I > L) or (S[I] <> ' '); + + { Update Index } + Index := I; + end; + + procedure Parse(S : String; Delim : Char; Field : PStrVector; var N : Byte); + var + I, Index, L : Byte; + begin + I := 0; + Index := 1; + L := Length(S); + repeat + Field^[I] := Extract(S, Index, Delim); + Inc(I); + until Index > L; + N := I; + end; + + function FloatToStr(X : Float) : String; + var + S : String; + C : Char; + L : Byte; + begin + if FloatPoint then + begin + Str(X:Pred(NumLength), S); + S := ' ' + S; + end + else + begin + Str(X:NumLength:MaxDec, S); + if not NSZero then + repeat + L := Length(S); + C := S[L]; + if (C = '0') or (C = '.') then Delete(S, L, 1); + until C <> '0'; + end; + FloatToStr := S; + end; + + function IntToStr(N : LongInt) : String; + var + S : String; + begin + Str(N:(NumLength - MaxDec - 1), S); + IntToStr := S; + end; + + function CompToStr(Z : Complex) : String; + var + S : String; + begin + if Z.Form = Rec then + begin + if Z.Y >= 0.0 then S := ' + ' else S := ' - '; + CompToStr := FloatToStr(Z.X) + S + FloatToStr(Abs(Z.Y)) + ' * i'; + end + else + CompToStr := FloatToStr(Z.R) + ' * Exp(' + FloatToStr(Z.Theta) + ' * i)'; + end; + +end. + diff --git a/npm_precl/dmath/plot.inc b/npm_precl/dmath/plot.inc new file mode 100755 index 0000000..ef9e6a8 --- /dev/null +++ b/npm_precl/dmath/plot.inc @@ -0,0 +1,94 @@ +{ ********************************************************************** + * PLOT.INC * + ********************************************************************** + Variables and routines common to PLOT.PAS and WINPLOT.PAS + ********************************************************************** } + +var + XminPixel, YminPixel : Integer; { Pixel coord. of upper left corner } + XmaxPixel, YmaxPixel : Integer; { Pixel coord. of lower right corner } + FactX, FactY : Float; { Scaling factors } + + function Xpixel(X : Float) : Integer; + var + P : Float; + begin + P := FactX * (X - XAxis.Min); + if Abs(P) > 30000 then + Xpixel := 30000 + else + Xpixel := Round(P) + XminPixel; + end; + + function Ypixel(Y : Float) : Integer; + var + P : Float; + begin + P := FactY * (YAxis.Max - Y); + if Abs(P) > 30000 then + Ypixel := 30000 + else + Ypixel := Round(P) + YminPixel; + end; + + function Xuser(X : Integer) : Float; + begin + Xuser := XAxis.Min + (X - XminPixel) / FactX; + end; + + function Yuser(Y : Integer) : Float; + begin + Yuser := YAxis.Max - (Y - YminPixel) / FactY; + end; + + procedure Interval(X1, X2 : Float; MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); + var + H, R, K : Float; + begin + if X1 >= X2 then Exit; + H := X2 - X1; + R := Int(Log10(H)); + if H < 1.0 then R := R - 1.0; + Step := Exp10(R); + + repeat + K := Int(H / Step); + if K < MinDiv then Step := 0.5 * Step; + if K > MaxDiv then Step := 2.0 * Step; + until (K >= MinDiv) and (K <= MaxDiv); + + Min := Step * Int(X1 / Step); + Max := Step * Int(X2 / Step); + while Min > X1 do Min := Min - Step; + while Max < X2 do Max := Max + Step; + end; + + procedure AutoScale(Z : PVector; Lbound, Ubound : Integer; + var Axis : TAxis); + var + I : Integer; + Zmin, Zmax, Z1, Z2 : Float; + begin + if Axis.Scale = LIN_SCALE then + Interval(Min(Z, Lbound, Ubound), Max(Z, Lbound, Ubound), + 2, 6, Axis.Min, Axis.Max, Axis.Step) + else + begin + Zmin := MAXNUM; Zmax := 0.0; + for I := Lbound to Ubound do + if Z^[I] > 0.0 then + if Z^[I] < Zmin then + Zmin := Z^[I] + else if Z^[I] > Zmax then + Zmax := Z^[I]; + Z1 := Int(Log10(Zmin)); + Z2 := Int(Log10(Zmax)); + if Zmin < 1.0 then Z1 := Z1 - 1.0; + if Zmax > 1.0 then Z2 := Z2 + 1.0; + Axis.Min := Z1; + Axis.Max := Z2; + Axis.Step := 1.0; + end; + end; + diff --git a/npm_precl/dmath/plot.pas b/npm_precl/dmath/plot.pas new file mode 100755 index 0000000..d0357e1 --- /dev/null +++ b/npm_precl/dmath/plot.pas @@ -0,0 +1,473 @@ +{ ********************************************************************** + * Unit PLOT.PAS * + * Version 1.7 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Plotting routines for Turbo Pascal + ********************************************************************** } + +unit Plot; + +interface + +uses + Graph, FMath, Matrices, PaString; + +const + BGIPath : String = 'C:\BP\BGI'; { Access path for graphic drivers } + DefSymbSize : Integer = 3; { Default symbol size } + + +{ ********************** Include global variables ********************** } + + {$I PLOTVAR.INC} + +{ ************************** Graphic routines ************************** } + +function GraphOk : Boolean; +{ ---------------------------------------------------------------------- + Initializes high resolution graphics and plots the axes + ---------------------------------------------------------------------- } + +procedure PlotGrid; +{ ---------------------------------------------------------------------- + Plots a grid on the graph + ---------------------------------------------------------------------- } + +procedure WriteLegend(NCurv : Integer); +{ ---------------------------------------------------------------------- + Writes the graph title and the legends for the plotted curves + Input parameter : NCurv = number of curves (1 to MAXCURV) + ---------------------------------------------------------------------- } + +procedure SetClipping(Clip : Boolean); +{ ---------------------------------------------------------------------- + Determines whether drawings are clipped at the current viewport + boundaries, according to the value of the Boolean parameter Clip + ---------------------------------------------------------------------- } + +procedure PlotPoint(Xp, Yp, Symbol, Size, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a point on the screen + ---------------------------------------------------------------------- + Input parameters : Xp, Yp : point coordinates in pixels + Symbol : 0 = point (.) + 1 = solid circle 2 = open circle + 3 = solid square 4 = open square + 5 = solid triangle 6 = open triangle + 7 = plus (+) 8 = multiply (x) + 9 = star (*) + Size : symbol size + Trace : type of line between points + 0 = none + 1 = solid + 2 = dotted + 3 = centered + 4 = dashed + ---------------------------------------------------------------------- } + +procedure PlotCurve(X, Y : PVector; Lbound, Ubound, Symbol, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a curve + ---------------------------------------------------------------------- + Input parameters : X, Y = point coordinates + Lbound, Ubound = indices of first and last points + Symbol, Trace = as in PlotPoint + ---------------------------------------------------------------------- } + +procedure PlotCurveWithErrorBars(X, Y, S : PVector; + Lbound, Ubound, Symbol, Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a curve with error bars + ---------------------------------------------------------------------- + Input parameters : X, Y = point coordinates + S = errors (standard deviations) + Lbound, Ubound = indices of first and last points + Symbol, Trace = as in PlotPoint + ---------------------------------------------------------------------- } + +procedure PlotFunc(Func : TFunc; X1, X2 : Float; Trace : Integer); +{ ---------------------------------------------------------------------- + Plots a function + ---------------------------------------------------------------------- + Input parameters : Func = function to be plotted + X1, X2 = abscissae of 1st and last point to plot + Trace = as in PlotPoint + ---------------------------------------------------------------------- + The function must be programmed as : function Func(X : Float) : Float; + ---------------------------------------------------------------------- } + +{ *********** The following routines are defined in PLOT.INC *********** } + +procedure Interval(X1, X2 : Float; MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); +{ ---------------------------------------------------------------------- + Determines an interval [Min, Max] including the values from X1 to X2, + and a subdivision Step of this interval + ---------------------------------------------------------------------- + Input parameters : X1, X2 = min. & max. values to be included + MinDiv = minimum nb of subdivisions + MaxDiv = maximum nb of subdivisions + ---------------------------------------------------------------------- + Output parameters : Min, Max, Step + ---------------------------------------------------------------------- } + +procedure AutoScale(Z : PVector; Lbound, Ubound : Integer; + var Axis : TAxis); +{ ---------------------------------------------------------------------- + Determines the scale of an axis + ---------------------------------------------------------------------- + Input parameters : Z = array of values to be plotted + Lbound, + Ubound = indices of first and last elements of Z + ---------------------------------------------------------------------- + Output parameters : Axis + ---------------------------------------------------------------------- } + +function Xpixel(X : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user abscissa X to screen coordinate + ---------------------------------------------------------------------- } + +function Ypixel(Y : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user ordinate Y to screen coordinate + ---------------------------------------------------------------------- } + +function Xuser(X : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate X to user abscissa + ---------------------------------------------------------------------- } + +function Yuser(Y : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate Y to user ordinate + ---------------------------------------------------------------------- } + +implementation + +{ ---------------------------------------------------------------------- + Include the variables and routines common to PLOT.PAS and WINPLOT.PAS + ---------------------------------------------------------------------- } + + {$I PLOT.INC} + +{ ---------------------------------------------------------------------- } + + procedure PlotXAxis; + var + W, X, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + Line(XminPixel, YmaxPixel, XmaxPixel, YmaxPixel); + SetTextStyle(XTitle.Font, HorizDir, 1); + SetUserCharSize(XTitle.CharWidth, 100, XTitle.CharHeight, 100); + SetTextJustify(CenterText, TopText); + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + X := XAxis.Min; { Tick mark position } + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + MoveTo(Xpixel(X), YmaxPixel); + LineRel(0, 5); { Plot tick mark } + if XAxis.Scale = LIN_SCALE then Z := X else Z := Exp10(X); + OutText(Trim(FloatToStr(Z))); + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do { Plot minor divisions } + begin { on logarithmic scale } + W := X + Log10(J); + MoveTo(Xpixel(W), YmaxPixel); + LineRel(0, 3); + end; + X := X + XAxis.Step; + end; + if XTitle.Text <> '' then { Plot axis title } + OutTextXY((XminPixel + XmaxPixel) div 2, + YmaxPixel + GetMaxY div 12, XTitle.Text); + NSZero := NSZ; + end; + + procedure PlotYAxis; + var + W, Y, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + Line(XminPixel, YminPixel, XminPixel, YmaxPixel); + SetTextStyle(YTitle.Font, HorizDir, 1); + SetUserCharSize(YTitle.CharWidth, 100, YTitle.CharHeight, 100); + SetTextJustify(RightText, CenterText); + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); + Y := YAxis.Min; + NSZ := NSZero; + NSZero := False; + for I := 0 to N do + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + MoveTo(XminPixel, Ypixel(Y)); + LineRel(- 5, 0); + MoveRel(- 2, - 2); + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + OutText(Trim(FloatToStr(Z))); + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + MoveTo(XminPixel, Ypixel(W)); + LineRel(- 3, 0); + end; + Y := Y + YAxis.Step; + end; + if YTitle.Text <> '' then + begin + SetTextStyle(YTitle.Font, VertDir, 1); + SetUserCharSize(YTitle.CharWidth, 100, YTitle.CharHeight, 100); + OutTextXY(XminPixel - GetMaxX div 8, + (YminPixel + YmaxPixel) div 2, YTitle.Text); + end; + NSZero := NSZ; + end; + + function GraphOk : Boolean; + var + Pilot, Mode : Integer; + begin + Pilot := Detect; + InitGraph(Pilot, Mode, BGIPath); + if GraphResult <> 0 then + begin + GraphOk := False; + Exit; + end; + GraphOk := True; + XminPixel := Round(Xwin1 / 100 * GetMaxX); + YminPixel := Round(Ywin1 / 100 * GetMaxY); + XmaxPixel := Round(Xwin2 / 100 * GetMaxX); + YmaxPixel := Round(Ywin2 / 100 * GetMaxY); + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); + if GraphBorder then + Rectangle(XminPixel, YminPixel, XmaxPixel, YmaxPixel); + PlotXAxis; + PlotYAxis; + end; + + procedure PlotGrid; + var + X, Y : Float; + I, N, Xp, Yp : Integer; + begin + SetLineStyle(DottedLn, 0, NormWidth); + if Grid in [HORIZ_GRID, BOTH_GRID] then { Horizontal lines } + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yp := Ypixel(Y); + Line(XminPixel, Yp, XmaxPixel, Yp); + end; + end; + if Grid in [VERTIC_GRID, BOTH_GRID] then { Vertical lines } + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xp := Xpixel(X); + Line(Xp, YminPixel, Xp, YmaxPixel); + end; + end; + SetLineStyle(SolidLn, 0, NormWidth); + end; + + procedure PlotPoint(Xp, Yp, Symbol, Size, Trace : Integer); + var + Xasp, Yasp, Xp1, Xp2, Yp1, Yp2, Dx, Dy : Word; + R : Float; + Triangle : array[1..4] of PointType; + Square : array[1..5] of PointType; + begin + if Trace = 0 then + MoveTo(Xp, Yp) + else + begin + SetLineStyle(Pred(Trace), 0, NormWidth); + LineTo(Xp, Yp); + SetLineStyle(0, 0, 1); + end; + GetAspectRatio(Xasp, Yasp); + R := 0.0001 * Size; + Dx := Round(R * Yasp); + Dy := Round(R * Xasp); + Xp1 := Xp - Size; Xp2 := Xp + Size; + Yp1 := Yp - Size; Yp2 := Yp + Size; + if Symbol in [3, 4] then + begin + Square[1].X := Xp1; Square[1].Y := Yp1; + Square[2].X := Xp1; Square[2].Y := Yp2; + Square[3].X := Xp2; Square[3].Y := Yp2; + Square[4].X := Xp2; Square[4].Y := Yp1; + Square[5].X := Xp1; Square[5].Y := Yp1; + end; + if Symbol in [5, 6] then + begin + Triangle[1].X := Xp; Triangle[1].Y := Yp1; + Triangle[2].X := Xp2; Triangle[2].Y := Yp2; + Triangle[3].X := Xp1; Triangle[3].Y := Yp2; + Triangle[4].X := Xp; Triangle[4].Y := Yp1; + end; + case Symbol of + 0 : PutPixel(Xp, Yp, GetColor); { ù } + 1 : PieSlice(Xp, Yp, 0, 360, Dx); { Solid circle } + 2 : Ellipse(Xp, Yp, 0, 360, Dx, Dy); { Open circle } + 3 : FillPoly(5, Square); { Solid square } + 4 : DrawPoly(5, Square); { Open square } + 5 : FillPoly(4, Triangle); { Solid triangle } + 6 : DrawPoly(4, Triangle); { Open triangle } + 7 : begin { + } + Line(Xp, Yp1, Xp, Yp2); + Line(Xp1, Yp, Xp2, Yp); + end; + 8 : begin { x } + Line(Xp1, Yp1, Xp2, Yp2); + Line(Xp1, Yp2, Xp2, Yp1); + end; + 9 : begin + Line(Xp, Yp1, Xp, Yp2); { * } + Line(Xp1, Yp, Xp2, Yp); + Line(Xp1, Yp1, Xp2, Yp2); + Line(Xp1, Yp2, Xp2, Yp1); + end; + end; + end; + + procedure WriteLegend(NCurv : Integer); + var + I, Xp, Yp, Dy : Integer; + begin + with GraphTitle do + if Text <> '' then + begin + SetTextStyle(Font, HorizDir, 1); + SetUserCharSize(CharWidth, 100, CharHeight, 100); + SetTextJustify(CenterText, TopText); + OutTextXY((XminPixel + XmaxPixel) div 2, + YminPixel - GetMaxY div 10, Text); + end; + with Legend do + begin + SetTextStyle(Font, HorizDir, 1); + SetUserCharSize(CharWidth, 100, CharHeight, 100); + SetTextJustify(LeftText, CenterText); + Dy := (YmaxPixel - YminPixel) div 10; + Xp := XmaxPixel + 30; + Yp := YminPixel + Dy; + for I := 1 to NCurv do + if Text[I] <> '' then + begin + PlotPoint(Xp, Yp, I, SymbolSize, 0); + OutTextXY(Xp + 20, Yp, Text[I]); + Yp := Yp + Dy; + end; + end; + end; + + procedure SetClipping(Clip : Boolean); + begin + if XminPixel = 0 then + begin + XminPixel := Round(Xwin1 / 100 * GetMaxX); + YminPixel := Round(Ywin1 / 100 * GetMaxY); + XmaxPixel := Round(Xwin2 / 100 * GetMaxX); + YmaxPixel := Round(Ywin2 / 100 * GetMaxY); + end; + SetViewPort(XminPixel, YminPixel, XmaxPixel, YmaxPixel, Clip); + XmaxPixel := XmaxPixel - XminPixel; XminPixel := 0; + YmaxPixel := YmaxPixel - YminPixel; YminPixel := 0; + end; + + procedure PlotCurve(X, Y : PVector; + Lbound, Ubound, Symbol, Trace : Integer); + var + XI, YI : Float; + I, NL : Integer; + begin + NL := 0; + for I := Lbound to Ubound do + begin + XI := X^[I]; + if XAxis.Scale = LOG_SCALE then XI := Log10(XI); + YI := Y^[I]; + if YAxis.Scale = LOG_SCALE then YI := Log10(YI); + PlotPoint(Xpixel(XI), Ypixel(YI), Symbol, DefSymbSize, NL); + NL := Trace; + end; + end; + + procedure PlotCurveWithErrorBars(X, Y, S : PVector; + Lbound, Ubound, Symbol, Trace : Integer); + var + XI, YI, Y1, Y2 : Float; + I, NL, Xp, Yp, Yp1, Yp2 : Integer; + begin + NL := 0; + for I := Lbound to Ubound do + begin + XI := X^[I]; + if XAxis.Scale = LOG_SCALE then XI := Log10(XI); + YI := Y^[I]; + if YAxis.Scale = LOG_SCALE then YI := Log10(YI); + Xp := Xpixel(XI); Yp := Ypixel(YI); + PlotPoint(Xp, Yp, Symbol, DefSymbSize, NL); + if S^[I] > 0 then + begin + Y1 := Y^[I] - S^[I]; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Y2 := Y^[I] + S^[I]; + if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Yp1 := Ypixel(Y1); Yp2 := Ypixel(Y2); + Line(Xp - 5, Yp1, Xp + 5, Yp1); + Line(Xp - 5, Yp2, Xp + 5, Yp2); + Line(Xp, Yp1, Xp, Yp2); + end; + NL := Trace; + end; + end; + + procedure PlotFunc(Func : TFunc; X1, X2 : Float; Trace : Integer); + var + X, Y, H : Float; + I, Npt, NL, Xp, Yp : Integer; + begin + NL := 0; { Indicates if a line must be drawn from the previous point } + X := X1; + + { Nb of points to be plotted = number of pixels between X1 and X2 } + Npt := Xpixel(X2) - Xpixel(X1); + + H := (X2 - X1) / Npt; + for I := 0 to Npt do + begin + X := X1 + I * H; + if XAxis.Scale = LIN_SCALE then + Y := Func(X) + else + Y := Func(Exp10(X)); + if MathError <> FN_OK then + NL := 0 + else + begin + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + Xp := Xpixel(X); + Yp := Ypixel(Y); + PlotPoint(Xp, Yp, 0, 0, NL); + NL := Trace; + end; + end; + end; + +end. diff --git a/npm_precl/dmath/plotvar.inc b/npm_precl/dmath/plotvar.inc new file mode 100755 index 0000000..7b3ee09 --- /dev/null +++ b/npm_precl/dmath/plotvar.inc @@ -0,0 +1,93 @@ +{ ********************************************************************** + * PLOTVAR.INC * + ********************************************************************** + Constants, types and global variables + common to PLOT.PAS and TEXPLOT.PAS + ********************************************************************** } + +const + MAXSYMBOL = 9; { Max. number of graphic symbols } + EPS = 1.0E-10; { Lower limit for an axis label } + +type + TScale = (LIN_SCALE, { Scale } + LOG_SCALE); + + TGrid = (NO_GRID, { Grid } + HORIZ_GRID, + VERTIC_GRID, + BOTH_GRID); + + TAxis = record { Coordinate axis } + Scale : TScale; + Min : Float; + Max : Float; + Step : Float; + end; + + TTitle = record { Title for main graph or axis } + Text : String[70]; + Font : Integer; + CharWidth : Integer; + CharHeight : Integer; + end; + + TLegend = record { Legends of plotted curves } + Text : array[1..MAXSYMBOL] of String[40]; + Font : Integer; + CharWidth : Integer; + CharHeight : Integer; + SymbolSize : Integer; + end; + +{ ******** Global variables defining the appearance of the graph ******* } + +const + Xwin1 : Integer = 15; { Window limits in % } + Ywin1 : Integer = 15; + Xwin2 : Integer = 85; + Ywin2 : Integer = 85; + + GraphBorder : Boolean = True; { Plot graph border } + + XAxis : TAxis = (Scale : LIN_SCALE; { Horizontal axis } + Min : 0.0; + Max : 1.0; + Step : 0.2); + + YAxis : TAxis = (Scale : LIN_SCALE; { Vertical axis } + Min : 0.0; + Max : 1.0; + Step : 0.2); + + Grid : TGrid = NO_GRID; { Grid } + + GraphTitle : TTitle = (Text : ''; { Title of graph } + Font : 2; + CharWidth : 300; + CharHeight : 350); + + XTitle : TTitle = (Text : 'X'; { Title of X axis } + Font : 2; + CharWidth : 200; + CharHeight : 250); + + YTitle : TTitle = (Text : 'Y'; { Title of Y axis } + Font : 2; + CharWidth : 200; + CharHeight : 250); + + Legend : TLegend = (Text : ('A', { Legends of curves } + 'B', + 'C', + 'D', + 'E', + 'F', + 'G', + 'H', + 'I'); + Font : 2; + CharWidth : 50; + CharHeight : 50; + SymbolSize : 3); + diff --git a/npm_precl/dmath/polynom.pas b/npm_precl/dmath/polynom.pas new file mode 100755 index 0000000..87009e3 --- /dev/null +++ b/npm_precl/dmath/polynom.pas @@ -0,0 +1,194 @@ +{ ********************************************************************** + * Unit POLYNOM.PAS * + * Version 1.3 * + * (c) J. Debord, January 1998 * + ********************************************************************** + This unit implements routines for polynomials and rational fractions. + ********************************************************************** + Reference: 'Numerical Recipes' by Press et al. + ********************************************************************** } + +unit Polynom; + +interface + +uses + FMath, Matrices, Eigen, Stat; + +function Poly(X : Float; Coef : PVector; Deg : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates the polynomial : + P(X) = Coef[0] + Coef[1] * X + Coef[2] * X^2 +...+ Coef[Deg] * X^Deg + ---------------------------------------------------------------------- } + +function RRootPol(Coef : PVector; Deg : Integer; X : PVector) : Integer; +{ ---------------------------------------------------------------------- + Real roots of a polynomial. The roots are computed analytically if + Deg <= 3, otherwise they are computed numerically from the eigenvalues + of the companion matrix (function RootPol in EIGEN.PAS). The roots are + returned in X (in increasing order). The function returns the number + of real roots found. + ---------------------------------------------------------------------- } + +function CRootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; +{ ---------------------------------------------------------------------- + Complex roots of a polynomial. The roots are computed numerically + from the eigenvalues of the companion matrix (function RootPol in + EIGEN.PAS). The real and imaginary parts of the roots are returned + in X_Re and X_Im (in increasing order of the real parts). The function + returns the number of roots found, which may be Deg or zero if the + method did not converge. + ---------------------------------------------------------------------- } + +function RFrac(X : Float; Coef : PVector; Deg1, Deg2 : Integer) : Float; +{ ---------------------------------------------------------------------- + Evaluates the rational fraction : + + Coef[0] + Coef[1] * X + ... + Coef[Deg1] * X^Deg1 + F(X) = ----------------------------------------------------- + 1 + Coef[Deg1+1] * X + ... + Coef[Deg1+Deg2] * X^Deg2 + ---------------------------------------------------------------------- } + +implementation + +const + MAXDEG = 3; { Maximal degree for analytical solution of polynomial } + + function Poly(X : Float; Coef : PVector; Deg : Integer) : Float; + var + I : Integer; + Y : Float; + begin + Y := Coef^[Deg]; + for I := Pred(Deg) downto 0 do + Y := Y * X + Coef^[I]; + Poly := Y; + end; + + function RFrac(X : Float; Coef : PVector; Deg1, Deg2 : Integer) : Float; + var + I : Integer; + Sum : Float; { Denominator sum } + begin + Sum := 0.0; + for I := (Deg1 + Deg2) downto Succ(Deg1) do + Sum := (Sum + Coef^[I]) * X; + RFrac := Poly(X, Coef, Deg1) / (1.0 + Sum); + end; + + function RootPol3(Coef : PVector; Deg : Integer; X : PVector) : Integer; + { Real roots of polynomial up to degree 3 (Analytical solution) } + const + PI2DIV3 = 2.0943951023931954923; { 2*pi/3 } + var + NR : Integer; { Number of roots } + R, R2, Q, Q3, Delta, A0, A1, A2, A22, A3, AA, BB, Theta, Z : Float; + begin + if (Deg < 1) or (Deg > MAXDEG) then + begin + RootPol3 := 0; + Exit; + end; + case Deg of + 1 : begin + NR := 1; + X^[1] := - Coef^[0] / Coef^[1]; + end; + 2 : begin + Delta := Sqr(Coef^[1]) - 4.0 * Coef^[0] * Coef^[2]; + if Delta < 0 then + NR := 0 + else + begin + NR := 2; + if Coef^[1] >= 0 then + Q := - 0.5 * (Coef^[1] + Sqrt(Delta)) + else + Q := - 0.5 * (Coef^[1] - Sqrt(Delta)); + X^[1] := Q / Coef^[2]; + X^[2] := Coef^[0] / Q; + end; + end; + 3 : begin + A0 := Coef^[0] / Coef^[3]; + A1 := Coef^[1] / Coef^[3]; + A2 := Coef^[2] / Coef^[3]; + A3 := A2 / 3.0; + A22 := Sqr(A2); + Q := (A22 - 3.0 * A1) / 9.0; + R := (A2 * (2.0 * A22 - 9.0 * A1) + 27.0 * A0) / 54.0; + R2 := R * R; + Q3 := Q * Q * Q; + Delta := Q3 - R2; + if Delta < 0 then + begin + NR := 1; + AA := Power(Abs(R) + Sqrt(- Delta), 0.333333333333333); + if R >= 0 then AA := - AA; + if AA <> 0 then BB := Q / AA else BB := 0.0; + X^[1] := (AA + BB) - A3; + end + else + begin + NR := 3; + Theta := ArcCos(R / Sqrt(Q3)) / 3.0; + Z := - 2.0 * Sqrt(Q); + X^[1] := Z * Cos(Theta) - A3; + X^[2] := Z * Cos(Theta + PI2DIV3) - A3; + X^[3] := Z * Cos(Theta - PI2DIV3) - A3; + end; + end; + end; + QSort(X, 1, Deg); + RootPol3 := NR; + end; + + function RRootPol(Coef : PVector; Deg : Integer; X : PVector) : Integer; + var + N : Integer; { Number of real roots } + X_Re, X_Im : PVector; { Real and imaginary parts } + ErrCode : Integer; { Error code } + I : Integer; { Loop variable } + begin + DimVector(X_Re, Deg); + DimVector(X_Im, Deg); + + if Deg <= MAXDEG then + RRootPol := RootPol3(Coef, Deg, X) + else + begin + ErrCode := RootPol(Coef, Deg, X_Re, X_Im); + if ErrCode = MAT_OK then + begin + { Get real roots } + N := 0; + for I := 1 to Deg do + if Abs(X_Im^[I]) <= MACHEP then + begin + Inc(N); + X^[N] := X_Re^[I]; + end; + { Set other roots to zero } + for I := Succ(N) to Deg do + X^[I] := 0.0; + RRootPol := N; + end + else + RRootPol := 0; + end; + + DelVector(X_Re, Deg); + DelVector(X_Im, Deg); + end; + + function CRootPol(Coef : PVector; Deg : Integer; + X_Re, X_Im : PVector) : Integer; + begin + if RootPol(Coef, Deg, X_Re, X_Im) = MAT_OK then + CRootPol := Deg + else + CRootPol := 0; + end; + +end. diff --git a/npm_precl/dmath/regmultdelphi.pas b/npm_precl/dmath/regmultdelphi.pas new file mode 100755 index 0000000..b07be2f --- /dev/null +++ b/npm_precl/dmath/regmultdelphi.pas @@ -0,0 +1,518 @@ +{ ********************************************************************** + * Program REGMULT.PAS * + * Version 1.1 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This program performs a weighted multiple linear least squares fit : + + y = b0 + b1 * x1 + b2 * x2 + ... + + The following parameters are passed on the command line : + + 1st parameter = name of input file (default extension = .DAT) + 2nd parameter = 1 if the equation includes a constant term b0 + + Input files are ASCII files with the following structure : + + Line 1 : Title of study + Line 2 : Number of variables (must be >= 2 here !) + Next lines : Names of variables x1, x2, ..., y + Next line : Number of observations (must be > number of variables !) + + The next lines contain the coordinates (x1, x2, ..., y) of the + observations (1 observation by line). The coordinates must be + separated by spaces or tabulations. + + The file INHIB.DAT is an example of data relating the inhibition of an + enzyme to the physico-chemical properties of the inhibitors (J. DEBORD, + P. N'DIAYE, J. C. BOLLINGER et al, J. Enzyme Inhib., 1997, 12, 13-26). + The program parameters are : INHIB 1 + + The program may be executed from Turbo Pascal's integrated environment, + in which case the parameters are entered through the "Parameters" option + of the menu, or from DOS (after compilation into an executable file), + in which case the parameters are entered on the command line (e.g. + REGMULT INHIB 1). + ********************************************************************** } + +unit RegMultDelphi; +interface +uses + SysUtils,FMath, Matrices, Regress, Models, PaString,messages,dialogs,classes,define_types; +const +kMaxRA = 127; +kCR = chr (13); +kMaxObs = 100; +kMaxFact = 64; +//type +// TIVra = array [1..kMaxFact,1..kMaxObs] of integer; + {SpaceType = record + mrix,mriy,mriz,fobx,foby,fobz: integer; + end;} +function MultipleRegression (lnObservations,lnFactors: integer; var X: PMatrix; var lImgIntensity: DoubleP0; var lOutT: DoubleP0): boolean; +function MultipleRegressionVec (lnObservations,lnFactors: integer; var X: PMatrix; var Y: PVector; var lOutT,lOutSlope: DoubleP0): boolean; + +//var +// gMRIFOBra: array [1..kMaxRA] of SpaceType; +// gCoregRA: array[1..3,0..3] of double; {MRIx,y,z, Offset,FOBx,FOBy,FOBz} + +implementation +(*var + InFName : String; { Name of input file } + Title : String; { Title of study } + XName : PStrVector; { Names of independent variables } + YName : String; { Name of dependent variable } + N : Integer; { Number of observations } + X : PMatrix; { Matrix of independent variables } + Y : PVector; { Vector of dependent variable } + Z : PVector; { Vector of independent variable (not used here) } + Ycalc : PVector; { Expected Y values } + S : PVector; { Standard deviations of Y values } + CstPar : PVector; { Constant parameters } + B : PVector; { Regression parameters } + B_min, B_max : PVector; { Parameter bounds (not used, but must be + declared in order to use the WLSFit routine ) } + V : PMatrix; { Variance-covariance matrix of regression parameters } + Theta : PVector; { Variance parameters } + RegTest : TRegTest; { Regression tests } + gErrCode : Integer; { Error code } + *) + +(* procedure ReadCmdLine(var InFName : String; var CstPar : PVector); +{ ---------------------------------------------------------------------- + Reads command line parameters. Stores constant parameters in CstPar, + such that : + + CstPar^[0] = Number of independent variables + (this one is set by ReadInputFile) + CstPar^[1] = 1 to include a constant term (b0) + + The contents of CstPar are defined in the unit FITMULT.PAS, + in the subdirectory REG of the TP Math units directory. + ---------------------------------------------------------------------- } + var + I : Integer; + begin + DimVector(CstPar, 1); + + { Name of input file } + InFName := ParamStr(1); + if Pos('.', InFName) = 0 then InFName := InFName + '.dat'; + + { Presence of constant term } + //I := 0; + Val(ParamStr(2), I, gErrCode); + CstPar^[1] := I; + end; + + function ReadInputFile(InFName : String; + var Title : String; + var XName : PStrVector; + var YName : String; + var N : Integer; + var X : PMatrix; + var Y : PVector; + CstPar : PVector) : Integer; + var + InF : Textfile; { Input file } + Nvar : Integer; { Nb of independent variables } + I, K : Integer; { Loop variables } + begin + Assign(InF, InFName); + Reset(InF); + + ReadLn(InF, Title); + ReadLn(InF, Nvar); { Total number of variables } + if Nvar < 2 then + begin + showmessage('Data file must contain at least 2 variables !'); + ReadInputFile := - 1; + Exit; + end; + Nvar := Pred(Nvar); + showmessage('trap3x'+inttostr(NVar)); + DimStrVector(XName, Nvar);{crashes here} + showmessage('trap4x'+inttostr(NVar)); + for I := 1 to Nvar do begin + ReadLn(InF, XName^[I]); + showmessage(XName^[I]); + end; + + ReadLn(InF, YName); + ReadLn(InF, N); + + DimMatrix(X, Nvar, N); + DimVector(Y, N); + + for K := 1 to N do + begin + for I := 1 to Nvar do + Read(InF, X^[I]^[K]); + Read(InF, Y^[K]); + end; + + Close(InF); + CstPar^[0] := Nvar; + ReadInputFile := 0; + end; + + procedure WriteOutputFile(InFName, Title : String; + XName : PStrVector; + YName : String; + N : Integer; + Y, CstPar, Ycalc, S, B : PVector; + V : PMatrix; + Test : TRegTest); + var + OutFName : String; { Name of output file } + OutF : TextFile; { Output file } + Line1, + Line2 : String; { Separating lines } + Nvar : Integer; { Nb of independent variables } + Delta : Float; { Residual } + Sr : Float; { Residual error } + SB : PVector; { Standard deviations of parameters } + T : PVector; { Student's t } + Prob : PVector; { Probabilities } + I, K : Integer; { Loop variables } + begin + Nvar := Round(CstPar^[0]); + + DimVector(SB, LastParam); + DimVector(T, LastParam); + DimVector(Prob, LastParam); + + K := Pos('.', InFName); + OutFName := Copy(InFName, 1, Pred(K)) + '.out'; + Assign(OutF, OutFName); + Rewrite(OutF); + + Line1 := StrChar(73, '-'); + Line2 := StrChar(73, '='); + + WriteLn(OutF, Line2); + WriteLn(OutF, 'Data file : ', InFName); + WriteLn(OutF, 'Study name : ', Title); + for I := 1 to Nvar do + WriteLn(OutF, 'x', I:1, ' : ', XName^[I]); + WriteLn(OutF, 'y : ', YName); + WriteLn(OutF, 'Function : ', FuncName); + + { Perform tests on parameters } + ParamTest(B, V, N, FirstParam, LastParam, SB, T, Prob); + + WriteLn(OutF, Line1); + WriteLn(OutF, 'Parameter Est.value Std.dev. t Student Prob(>|t|)'); + WriteLn(OutF, Line1); + showmessage(inttostr(nVar)+':'+inttostr(FirstParam)+':'+inttostr(LastParam)); + for I := FirstParam to LastParam do + if SB^[I] > 0.0 then + WriteLn(OutF, ParamName(I):5, B^[I]:17:8, SB^[I]:17:8, T^[I]:17:2, Prob^[I]:17:4) + else + WriteLn(OutF, ParamName(I):5, B^[I]:17:8); + + WriteLn(OutF, Line1); + WriteLn(OutF, 'Number of observations : n = ', N:5); + + with Test do + begin + Sr := Sqrt(Vr); + WriteLn(OutF, 'Residual error : s = ', Sr:10:8); + if (R2 >= 0.0) and (R2 <= 1.0) then + WriteLn(OutF, 'Coefficient of determination : r2 = ', R2:10:8); + if (R2a >= 0.0) and (R2a <= 1.0) then + WriteLn(OutF, 'Adjusted coeff. of determination : r2a = ', R2a:10:8); + Write(OutF, 'Variance ratio (explained/resid.) : F = ', F:10:4); + WriteLn(OutF, ' Prob(>F) = ', Prob:6:4); + end; + + WriteLn(OutF, Line1); + WriteLn(OutF, ' i Y obs. Y calc. Residual Std.dev. Std.res.'); + WriteLn(OutF, Line1); + + for K := 1 to N do + begin + Delta := Y^[K] - Ycalc^[K]; + WriteLn(OutF, K:3, Y^[K]:14:4, Ycalc^[K]:14:4, Delta:14:4, S^[K]:14:4, (Delta / S^[K]):14:4); + end; + WriteLn(OutF, Line2); + + Close(OutF); + Showmessage('Results written to file '+OutFName); + + DelVector(SB, LastParam); + DelVector(T, LastParam); + DelVector(Prob, LastParam); + end; + +{ *************************** Main program ***************************** } +procedure RunReg; +begin + { Read command line parameters } + //ReadCmdLine(InFName, CstPar); + InFName := 'C:\inhib.dat'; + DimVector(CstPar, 1); + CstPar^[1] := 1; + { Read input file } + + if ReadInputFile(InFName, Title, XName, YName, N, X, Y, CstPar) <> 0 then + begin + showmessage('Error reading file '+ InFName); + exit; + end; + { Initialize regression and variance models. + See MODELS.PAS in the REG subdirectory for a list of available models } + InitModel(REG_MULT, + VAR_CONST, { Here we use a constant variance } + CstPar); + + { Set the regression algorithm which must be GAUSS_JORDAN or SVD. + The default algorithm is SVD. Comment off the following line if + you wish to change the algorithm. } + + { SetRegAlgo(GAUSS_JORDAN); } + + { Dimension arrays. + Note: the variance parameters Theta^[1]..Theta^[LastVarParam] + must be supplied if we use a non-constant variance model } + DimVector(Theta, LastVarParam); + DimVector(B, LastParam); + DimMatrix(V, LastParam, LastParam); + DimVector(Ycalc, N); + DimVector(S, N); + + { Perform regression. The numbers 1 and 0.1 denote the maximal number + of iterations and the tolerance on the parameters. They are purely + formal values here since the multiple linear regression does not use + an iterative minimization algorithm. } + gErrCode := WLSFit(Z, X, Y, N, True, 1, 0.1, Theta, B, + B_min, B_max, V, Ycalc, S, RegTest); + + { Write results } + case gErrCode of + MAT_OK : WriteOutputFile(InFName, Title, XName, YName, + N, Y, CstPar, Ycalc, S, B, V, RegTest); + MAT_SINGUL : WriteLn('Singular matrix !'); + MAT_NON_CONV : WriteLn('Non-convergence of SVD algorithm !'); + end; +end; + *) + + //ComputeRegress(lnObservations,lnFactors, Y, CstPar, Ycalc, S, B, V, lRegTest); +procedure ComputeRegress (N,lnFactors : Integer; + var Y, CstPar, Ycalc, S, B : PVector; + var V : PMatrix; + var Test : TRegTest; var lOutT: DoubleP0); +var + I: integer; + SB : PVector; { Standard deviations of parameters } + T : PVector; { Student's t } + Prob : PVector; { Probabilities } +begin + DimVector(SB, LastParam); + DimVector(T, LastParam); + DimVector(Prob, LastParam); + { Perform tests on parameters } + ParamTest(B, V, N, FirstParam, LastParam, SB, T, Prob); + for I := 0 to (lnFactors-1) do + lOutT[I] := T^[FirstParam+I+1];//first parameter is global fit + + lOutT[lnFactors] := T^[FirstParam];//global fit + + //for I := FirstParam to LastParam do + // Showmessage(floattostr(T^[I]) ); + DelVector(SB, LastParam); + DelVector(T, LastParam); + DelVector(Prob, LastParam); + +end; + +(* procedure ScreenOutputFile( + var YName : String; + N,ldimension : Integer; + var Y, CstPar, Ycalc, S, B : PVector; + var V : PMatrix; + var Test : TRegTest; + var lDynStr: String); + var + lA,lB,lC,lD : String; { Name of output file } + Nvar : Integer; { Nb of independent variables } + Delta : Float; { Residual } + Sr : Float; { Residual error } + SB : PVector; { Standard deviations of parameters } + T : PVector; { Student's t } + Prob : PVector; { Probabilities } + I, K : Integer; { Loop variables } + begin + Nvar := Round(CstPar^[0]); + + DimVector(SB, LastParam); + DimVector(T, LastParam); + DimVector(Prob, LastParam); + { Perform tests on parameters } + ParamTest(B, V, N, FirstParam, LastParam, SB, T, Prob); + lDynStr:=lDynStr+'|'+( 'Parameter Est.value Std.dev. t Student Prob(>|t|)'); + //showmessage(inttostr(nVar)+':'+inttostr(FirstParam)+':'+inttostr(LastParam)); + for I := FirstParam to LastParam do begin + if SB^[I] > 0.0 then begin + Str(B^[I]:17:8,lA); + Str(SB^[I]:17:8,lB); + Str(T^[I]:17:2,lC); + Str(Prob^[I]:17:4,lD); + lDynStr:=lDynStr+'|'+(ParamName(I)+lA+lB+'T='+lC+lD); + end else begin + B^[I]:= 0; + Str(B^[I]:17:8,lA); + lDynStr:=lDynStr+'|'+(ParamName(I)+lA); + end; + //gCoregRA[lDImension,I]:= B^[I]; + end; + DelVector(SB, LastParam); + DelVector(T, LastParam); + DelVector(Prob, LastParam); + end; *) + + +//function PredictData(lnObservations: integer; var lStr: tstringlist): boolean; +function MultipleRegression (lnObservations,lnFactors: integer; var X: PMatrix; var lImgIntensity: DoubleP0; var lOutT: DoubleP0): boolean; +var + K : Integer; { Nb of independent variables } + //X : PMatrix; { Matrix of independent variables } + Y : PVector; { Vector of dependent variable } + Z : PVector; { Vector of independent variable (not used here) } + Ycalc : PVector; { Expected Y values } + S : PVector; { Standard deviations of Y values } + CstPar : PVector; { Constant parameters } + B : PVector; { Regression parameters } + B_min, B_max : PVector; { Parameter bounds (not used, but must be + declared in order to use the WLSFit routine ) } + V : PMatrix; { Variance-covariance matrix of regression parameters } + Theta : PVector; { Variance parameters } + lRegTest : TRegTest; { Regression tests } + gErrCode : Integer; { Error code } +begin + result := false; + if lnObservations < 5 then begin + showmessage('At least 5 samples required for 3D registration.'); + exit; + end; + DimVector(CstPar, 1); + DimVector(Y, lnObservations); + CstPar^[1] := 1; + CstPar^[0] := lnFactors; + for K := 1 to lnObservations do + Y^[K] := lImgIntensity[K-1]; + { Initialize regression and variance models.} + InitModel(REG_MULT,VAR_CONST,{ Here we use a constant variance }CstPar); + { Set the regression algorithm which must be GAUSS_JORDAN or SVD. + The default algorithm is SVD. Comment off the following line if + you wish to change the algorithm. } + { SetRegAlgo(GAUSS_JORDAN); } + DimVector(Theta, LastVarParam); + DimVector(B, LastParam); + DimMatrix(V, LastParam, LastParam); + DimVector(Ycalc, lnObservations); + DimVector(S, lnObservations); + { Perform regression. The numbers 1 and 0.1 denote the maximal number + of iterations and the tolerance on the parameters. They are purely + formal values here since the multiple linear regression does not use + an iterative minimization algorithm. } + gErrCode := WLSFit(Z, X, Y, lnObservations, True, 1, 0.1, Theta, B,B_min, B_max, V, Ycalc, S, lRegTest); + { Write results } + //showmessage(inttostr(xx)); + case gErrCode of + MAT_OK : begin + //ScreenOutputFile({XName,}YName,lnObservations,lDim, Y, CstPar, Ycalc, S, B, V, lRegTest,lStr); + //Showmessage(lStr); + ComputeRegress(lnObservations,lnFactors, Y, CstPar, Ycalc, S, B, V, lRegTest,lOutT); + end; +{ MAT_OK : WriteOutputFile(InFName, Title, XName, YName, + N, Y, CstPar, Ycalc, S, B, V, RegTest); + } MAT_SINGUL : Showmessage('Singular matrix !'); + MAT_NON_CONV : Showmessage('Non-convergence of SVD algorithm !'); + end; + DelVector(CstPar, 1); + DelVector(Y, lnObservations); + //DelStrVector(XName,lnXFactors); + + DelVector(Theta, LastVarParam); + DelVector(B, LastParam); + DelMatrix(V, LastParam, LastParam); + DelVector(Ycalc, lnObservations); + DelVector(S, lnObservations); + result := true; + +end; + +function MultipleRegressionVec (lnObservations,lnFactors: integer; var X: PMatrix; var Y: PVector; var lOutT,lOutSlope: DoubleP0): boolean; +var + K : Integer; { Nb of independent variables } + Z : PVector; { Vector of independent variable (not used here) } + Ycalc : PVector; { Expected Y values } + S : PVector; { Standard deviations of Y values } + CstPar : PVector; { Constant parameters } + B : PVector; { Regression parameters } + B_min, B_max : PVector; { Parameter bounds (not used, but must be + declared in order to use the WLSFit routine ) } + V : PMatrix; { Variance-covariance matrix of regression parameters } + Theta : PVector; { Variance parameters } + lRegTest : TRegTest; { Regression tests } + gErrCode : Integer; { Error code } +begin + result := false; + if lnObservations < 5 then begin + showmessage('At least 5 samples required for 3D registration.'); + exit; + end; + DimVector(CstPar, 1); + CstPar^[1] := 1; + CstPar^[0] := lnFactors; + { Initialize regression and variance models.} + InitModel(REG_MULT,VAR_CONST,{ Here we use a constant variance }CstPar); + { Set the regression algorithm which must be GAUSS_JORDAN or SVD. + The default algorithm is SVD. Comment off the following line if + you wish to change the algorithm. } + { SetRegAlgo(GAUSS_JORDAN); } + DimVector(Theta, LastVarParam); + DimVector(B, LastParam); + DimMatrix(V, LastParam, LastParam); + DimVector(Ycalc, lnObservations); + DimVector(S, lnObservations); + { Perform regression. The numbers 1 and 0.1 denote the maximal number + of iterations and the tolerance on the parameters. They are purely + formal values here since the multiple linear regression does not use + an iterative minimization algorithm. } + gErrCode := WLSFit(Z, X, Y, lnObservations, True, 1, 0.1, Theta, B,B_min, B_max, V, Ycalc, S, lRegTest); + { Write results } + //showmessage(inttostr(xx)); + case gErrCode of + MAT_OK : begin + //ScreenOutputFile({XName,}YName,lnObservations,lDim, Y, CstPar, Ycalc, S, B, V, lRegTest,lStr); + //Showmessage(lStr); + ComputeRegress(lnObservations,lnFactors, Y, CstPar, Ycalc, S, B, V, lRegTest,lOutT); + end; +{ MAT_OK : WriteOutputFile(InFName, Title, XName, YName, + N, Y, CstPar, Ycalc, S, B, V, RegTest); + } MAT_SINGUL : Showmessage('Singular matrix !'); + MAT_NON_CONV : Showmessage('Non-convergence of SVD algorithm !'); + end; + for K := 0 to (lnFactors-1) do + lOutSlope^[K] := B^[FirstParam+K+1];//first parameter is global fit + + lOutSlope^[lnFactors] := B^[FirstParam];//global fit + + DelVector(CstPar, 1); + //DelVector(Y, lnObservations); + //DelStrVector(XName,lnXFactors); + + DelVector(Theta, LastVarParam); + DelVector(B, LastParam); + DelMatrix(V, LastParam, LastParam); + DelVector(Ycalc, lnObservations); + DelVector(S, lnObservations); + result := true; + +end; + + +end. diff --git a/npm_precl/dmath/simopt.pas b/npm_precl/dmath/simopt.pas new file mode 100755 index 0000000..e7c7168 --- /dev/null +++ b/npm_precl/dmath/simopt.pas @@ -0,0 +1,308 @@ +{ ********************************************************************** + * Unit SIMOPT.PAS * + * Version 1.0 * + * (c) J. Debord, August 2000 * + ********************************************************************** + This unit implements simulated annealing for function minimization + ********************************************************************** + Reference: Program SIMANN.FOR by Bill Goffe + (http://www.netlib.org/simann) + ********************************************************************** } + +unit SimOpt; + +interface + +uses + FMath, Matrices, Optim, Stat; + +const + SA_Nt : Integer = 5; { Number of loops at constant temperature } + SA_Ns : Integer = 15; { Number of loops before step adjustment } + SA_Rt : Float = 0.9; { Temperature reduction factor } + SA_NCycles : Integer = 1; { Number of cycles } + +function SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Minimization of a function of several variables by simulated annealing + ---------------------------------------------------------------------- + Input parameters : Func = objective function to be minimized + X = initial minimum coordinates + Xmin = minimum value of X + Xmax = maximum value of X + Lbound, + Ubound = indices of first and last variables + MaxIter = max number of annealing steps + Tol = required precision + ---------------------------------------------------------------------- + Output parameter : X = refined minimum coordinates + F_min = function value at minimum + ---------------------------------------------------------------------- + Possible results : OPT_OK + OPT_NON_CONV + ---------------------------------------------------------------------- } + +implementation + +var + LogFile : Text; { Stores the result of each minimization step } + + procedure CreateLogFile; + begin + Assign(LogFile, LogFileName); + Rewrite(LogFile); + end; + + function InitTemp(Func : TFuncNVar; + X, Xmin, Range : PVector; + Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Computes the initial temperature so that the probability + of accepting an increase of the function is about 0.5 + ---------------------------------------------------------------------- } + const + N_EVAL = 50; { Number of function evaluations } + var + T : Float; { Temperature } + F, F1 : Float; { Function values } + DeltaF : PVector; { Function increases } + N_inc : Integer; { Number of function increases } + I : Integer; { Index of function evaluation } + K : Integer; { Index of parameter } + begin + DimVector(DeltaF, N_EVAL); + + T := 0.0; + N_inc := 0; + F := Func(X); + + { Compute N_EVAL function values, changing each parameter in turn } + K := Lbound; + for I := 1 to N_EVAL do + begin + X^[K] := Xmin^[K] + RanMar * Range^[K]; + F1 := Func(X); + if F1 > F then + begin + Inc(N_inc); + DeltaF^[N_inc] := F1 - F; + end; + F := F1; + Inc(K); + if K > Ubound then K := Lbound; + end; + + { The median M of these N_eval values has a probability of 1/2. + From Boltzmann's formula: Exp(-M/T) = 1/2 ==> T = M / Ln(2) } + T := Median(DeltaF, 1, N_inc) / LN2; + if T = 0.0 then T := 1.0; + InitTemp := T; + + DelVector(DeltaF, N_EVAL); + end; + + function ParamConv(X, Step : PVector; + Lbound, Ubound : Integer; + Tol : Float) : Boolean; +{ ---------------------------------------------------------------------- + Checks for convergence on parameters + ---------------------------------------------------------------------- } + var + I : Integer; + Conv : Boolean; + begin + I := Lbound; + Conv := True; + repeat + Conv := Conv and (Step^[I] < FMax(Tol, Tol * Abs(X^[I]))); + Inc(I); + until (Conv = False) or (I > Ubound); + ParamConv := Conv; + end; + + function Accept(DeltaF, T : Float; + var N_inc, N_acc : Integer) : Boolean; +{ ---------------------------------------------------------------------- + Checks if a variation DeltaF of the function at temperature T is + acceptable. Updates the counters N_inc (number of increases of the + function) and N_acc (number of accepted increases). + ---------------------------------------------------------------------- } + begin + if DeltaF < 0.0 then + Accept := True + else + begin + Inc(N_inc); + if Expo(- DeltaF / T) > RanMar then + begin + Accept := True; + Inc(N_acc); + end + else + Accept := False; + end; + end; + + function SimAnnCycle(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var LogFile : Text; + var F_min : Float) : Integer; +{ ---------------------------------------------------------------------- + Performs one cycle of simulated annealing + ---------------------------------------------------------------------- } + const + N_FACT = 2.0; { Factor for step reduction } + var + I, Iter, J, K, N_inc, N_acc : Integer; + F, F1, DeltaF, Ratio, T, OldX : Float; + Range, Step, Xopt : PVector; + Nacc : PIntVector; + begin + DimVector(Step, Ubound); + DimVector(Xopt, Ubound); + DimVector(Range, Ubound); + DimIntVector(Nacc, Ubound); + + { Determine parameter range, step and optimum } + for K := Lbound to Ubound do + begin + Range^[K] := Xmax^[K] - Xmin^[K]; + Step^[K] := 0.5 * Range^[K]; + Xopt^[K] := X^[K]; + end; + + { Initialize function values } + F := Func(X); + F_min := F; + + { Initialize temperature and iteration count } + T := InitTemp(Func, X, Xmin, Range, Lbound, Ubound); + Iter := 0; + + repeat + { Perform SA_Nt evaluations at constant temperature } + N_inc := 0; N_acc := 0; + for I := 1 to SA_Nt do + begin + for J := 1 to SA_Ns do + for K := Lbound to Ubound do + begin + { Save current parameter value } + OldX := X^[K]; + + { Pick new value, keeping it within Range } + X^[K] := X^[K] + (2.0 * RanMar - 1.0) * Step^[K]; + if (X^[K] < Xmin^[K]) or (X^[K] > Xmax^[K]) then + X^[K] := Xmin^[K] + RanMar * Range^[K]; + + { Compute new function value } + F1 := Func(X); + DeltaF := F1 - F; + + { Check for acceptance } + if Accept(DeltaF, T, N_inc, N_acc) then + begin + Inc(Nacc^[K]); + F := F1; + end + else + { Restore parameter value } + X^[K] := OldX; + + { Update minimum if necessary } + if F < F_min then + begin + Xopt^[K] := X^[K]; + F_min := F; + end; + end; + + { Ajust step length to maintain an acceptance + ratio of about 50% for each parameter } + for K := Lbound to Ubound do + begin + Ratio := Int(Nacc^[K]) / Int(SA_Ns); + if Ratio > 0.6 then + begin + { Increase step length, keeping it within Range } + Step^[K] := Step^[K] * (1.0 + ((Ratio - 0.6) / 0.4) * N_FACT); + if Step^[K] > Range^[K] then Step^[K] := Range^[K]; + end + else if Ratio < 0.4 then + { Reduce step length } + Step^[K] := Step^[K] / (1.0 + ((0.4 - Ratio) / 0.4) * N_FACT); + + { Restore counter } + Nacc^[K] := 0; + end; + end; + + if WriteLogFile then + WriteLn(LogFile, Iter:4, ' ', T:12, ' ', F:12, N_inc:6, N_acc:6); + + { Update temperature and iteration count } + T := T * SA_Rt; + Inc(Iter); + until ParamConv(Xopt, Step, Lbound, Ubound, Tol) or (Iter > MaxIter); + + for K := Lbound to Ubound do + X^[K] := Xopt^[K]; + + DelVector(Step, Ubound); + DelVector(Xopt, Ubound); + DelVector(Range, Ubound); + DelIntVector(Nacc, Ubound); + + if Iter > MaxIter then + SimAnnCycle := OPT_NON_CONV + else + SimAnnCycle := OPT_OK; + end; + + function SimAnn(Func : TFuncNVar; + X, Xmin, Xmax : PVector; + Lbound, Ubound : Integer; + MaxIter : Integer; + Tol : Float; + var F_min : Float) : Integer; + var + Cycle, ErrCode : Integer; + begin + if WriteLogFile then + CreateLogFile; + + { Initialize the Marsaglia random number generator + using the standard Pascal generator } + Randomize; + RMarIn(System.Random(10000), System.Random(10000)); + + Cycle := 1; + repeat + if WriteLogFile then + begin + WriteLn(LogFile, 'Simulated annealing: Cycle ', Cycle); + WriteLn(LogFile); + WriteLn(LogFile, 'Iter T F Inc Acc'); + end; + + ErrCode := SimAnnCycle(Func, X, Xmin, Xmax, Lbound, Ubound, + MaxIter, Tol, LogFile, F_min); + + Inc(Cycle); + until (Cycle > SA_NCycles) or (ErrCode <> OPT_OK); + + if WriteLogFile then + Close(LogFile); + + SimAnn := ErrCode; + end; + +end. diff --git a/npm_precl/dmath/stat.pas b/npm_precl/dmath/stat.pas new file mode 100755 index 0000000..4fc81b3 --- /dev/null +++ b/npm_precl/dmath/stat.pas @@ -0,0 +1,333 @@ +{ ********************************************************************** + * Unit STAT.PAS * + * Version 1.5 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Statistical routines + ********************************************************************** } + +unit Stat; + +interface + +uses + FMath, Matrices; + +{ ---------------------------------------------------------------------- + Common input parameters : X : Vector of statistical variable + Lbound, + Ubound : Indices of first and last + elements of X + W : Vector of weights + ---------------------------------------------------------------------- } + +procedure QSort(X : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Sorts the elements of vector X in increasing order (quick sort) + ---------------------------------------------------------------------- } + +procedure DQSort(X : PVector; Lbound, Ubound : Integer); +{ ---------------------------------------------------------------------- + Sorts the elements of vector X in decreasing order (quick sort) + ---------------------------------------------------------------------- } + +function Median(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Sorts vector X is ascending order and returns its median value + ---------------------------------------------------------------------- } + +function Sum(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of the elements of vector X + ---------------------------------------------------------------------- } + +function SumSqr(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared elements of vector X + ---------------------------------------------------------------------- } + +function SumSqrDif(X : PVector; Lbound, Ubound : Integer; + A : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared differences between + the elements of vector X and the constant A + ---------------------------------------------------------------------- } + +function SumSqrDifVect(X, Y : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of squared differences between two vectors + ---------------------------------------------------------------------- } + +function SumWSqr(X, W : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared elements of vector X + ---------------------------------------------------------------------- } + +function SumWSqrDif(X, W : PVector; Lbound, Ubound : Integer; + A : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared differences between + the elements of vector X and the constant A + ---------------------------------------------------------------------- } + +function SumWSqrDifVect(X, Y, W : PVector; + Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the sum of weighted squared differences between two vectors + ---------------------------------------------------------------------- } + +function Average(X : PVector; Lbound, Ubound : Integer) : Float; +{ ---------------------------------------------------------------------- + Returns the average value of vector X + ---------------------------------------------------------------------- } + +function Variance(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the variance of vector X, with average Avg + ---------------------------------------------------------------------- } + +function EstVar(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the estimated variance of the population + to which vector X belongs + ---------------------------------------------------------------------- } + +function Skewness(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the skewness of vector X, + with average Avg and standard deviation Sigma + ---------------------------------------------------------------------- } + +function Kurtosis(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; +{ ---------------------------------------------------------------------- + Returns the kurtosis of vector X, + with average Avg and standard deviation Sigma + ---------------------------------------------------------------------- } + +procedure RanMult(M : PVector; L : PMatrix; N : Integer; X : PVector); +{ ---------------------------------------------------------------------- + Samples a vector X from the N-dimensioned multinormal distribution + with mean vector M. L is the Cholesky factor of the variance-covariance + matrix. + ---------------------------------------------------------------------- } + +implementation + + procedure QSort(X : PVector; Lbound, Ubound : Integer); + { Quick sort in ascending order - Adapted from Borland's BP7 demo } + procedure Sort(L, R : Integer); + var + I, J : Integer; + U, V : Float; + begin + I := L; + J := R; + U := X^[(L + R) div 2]; + repeat + while X^[I] < U do I := I + 1; + while U < X^[J] do J := J - 1; + if I <= J then + begin + V := X^[I]; X^[I] := X^[J]; X^[J] := V; + I := I + 1; J := J - 1; + end; + until I > J; + if L < J then Sort(L, J); + if I < R then Sort(I, R); + end; + + begin + Sort(Lbound, Ubound); + end; + + procedure DQSort(X : PVector; Lbound, Ubound : Integer); + { Quick sort in descending order - Adapted from Borland's BP7 demo } + procedure Sort(L, R : Integer); + var + I, J : Integer; + U, V : Float; + begin + I := L; + J := R; + U := X^[(L + R) div 2]; + repeat + while X^[I] > U do I := I + 1; + while U > X^[J] do J := J - 1; + if I <= J then + begin + V := X^[I]; X^[I] := X^[J]; X^[J] := V; + I := I + 1; J := J - 1; + end; + until I > J; + if L < J then Sort(L, J); + if I < R then Sort(I, R); + end; + + begin + Sort(Lbound, Ubound); + end; + + function Median(X : PVector; Lbound, Ubound : Integer) : Float; + var + N, N2 : Integer; + begin + N := Ubound - Lbound + 1; + N2 := N div 2 + Lbound - 1; + QSort(X, Lbound, Ubound); + if Odd(N) then + Median := X^[N2 + 1] + else + Median := 0.5 * (X^[N2] + X^[N2 + 1]); + end; + + function Sum(X : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + X^[I]; + Sum := S; + end; + + function SumSqr(X : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I]); + SumSqr := S; + end; + + function SumSqrDif(X : PVector; Lbound, Ubound : Integer; + A : Float) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I] - A); + SumSqrDif := S; + end; + + function SumSqrDifVect(X, Y : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + Sqr(X^[I] - Y^[I]); + SumSqrDifVect := S; + end; + + function SumWSqr(X, W : PVector; Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I]); + SumWSqr := S; + end; + + function SumWSqrDif(X, W : PVector; Lbound, Ubound : Integer; A : Float) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I] - A); + SumWSqrDif := S; + end; + + function SumWSqrDifVect(X, Y, W : PVector; + Lbound, Ubound : Integer) : Float; + var + S : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + S := S + W^[I] * Sqr(X^[I] - Y^[I]); + SumWSqrDifVect := S; + end; + + function Average(X : PVector; Lbound, Ubound : Integer) : Float; + begin + Average := Sum(X, Lbound, Ubound) / (Ubound - Lbound + 1); + end; + + function Variance(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; + begin + Variance := SumSqrDif(X, Lbound, Ubound, Avg) / (Ubound - Lbound + 1); + end; + + function EstVar(X : PVector; Lbound, Ubound : Integer; + Avg : Float) : Float; + begin + EstVar := SumSqrDif(X, Lbound, Ubound, Avg) / (Ubound - Lbound); + end; + + function Skewness(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; + var + S, T : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + begin + T := (X^[I] - Avg) / Sigma; + S := S + T * Sqr(T); + end; + Skewness := S / (Ubound - Lbound + 1); + end; + + function Kurtosis(X : PVector; Lbound, Ubound : Integer; + Avg, Sigma : Float) : Float; + var + S, T : Float; + I : Integer; + begin + S := 0.0; + for I := Lbound to Ubound do + begin + T := (X^[I] - Avg) / Sigma; + S := S + Sqr(Sqr(T)); + end; + Kurtosis := S / (Ubound - Lbound + 1) - 3.0; + end; + + procedure RanMult(M : PVector; L : PMatrix; N : Integer; X : PVector); + var + U : PVector; + I, J : Integer; + begin + { Form a vector of N independent standard normal variates } + DimVector(U, N); + for I := 1 to N do + U^[I] := RanGaussStd; + + { Form X = M + L*U, which follows the multinormal distribution } + for I := 1 to N do + begin + X^[I] := M^[I]; + for J := 1 to I do + X^[I] := X^[I] + L^[I]^[J] * U^[J]; + end; + DelVector(U, N); + end; + +end. diff --git a/npm_precl/dmath/texplot.pas b/npm_precl/dmath/texplot.pas new file mode 100755 index 0000000..b918b28 --- /dev/null +++ b/npm_precl/dmath/texplot.pas @@ -0,0 +1,488 @@ +{ ********************************************************************** + * Unit TEXPLOT.PAS * + * Version 1.1 * + * (c) J. Debord, June 2001 * + ********************************************************************** + Plotting routines for TeX/PSTricks + ********************************************************************** } + +unit TexPlot; + +interface + +uses + FMath, Matrices, PaString; + +{ ********************** Include global variables ********************** } + + {$I PLOTVAR.INC} + +{ ************************** Graphic routines ************************** } + +procedure InitTexGraph(var F : Text; FileName : String); +{ ---------------------------------------------------------------------- + Initializes TeX graphics. + Writes a border around the graph according to the value + of the global variable GraphBorder (defined in PLOTVAR.INC) + ---------------------------------------------------------------------- + F : file to be written + FileName : name of TeX file (e.g. 'figure.tex') + ---------------------------------------------------------------------- } + +function Xcm(X : Float) : Float; +{ ---------------------------------------------------------------------- + Converts user coordinate X to cm + ---------------------------------------------------------------------- } + +function Ycm(Y : Float) : Float; +{ ---------------------------------------------------------------------- + Converts user coordinate Y to cm + ---------------------------------------------------------------------- } + +procedure WriteXAxis(var F : Text); +{ ---------------------------------------------------------------------- + Writes horizontal axis (global variable XAxis in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteYAxis(var F : Text); +{ ---------------------------------------------------------------------- + Writes vertical axis (global variable YAxis in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteGrid(var F : Text); +{ ---------------------------------------------------------------------- + Writes a grid (global variable Grid in PLOTVAR.INC) + ---------------------------------------------------------------------- } + +procedure WriteLine(var F : Text; X1, Y1, X2, Y2 : Float; Style : String); +{ ---------------------------------------------------------------------- + Writes a line between two points + ---------------------------------------------------------------------- + F : output file + + X1, Y1 : coordinates of first point + + X2, Y2 : coordinates of second point + + Style : line style (must be 'solid', 'dotted' or 'dashed') + ---------------------------------------------------------------------- } + +procedure WritePoints(var F : Text; X, Y : PVector; + Lbound, Ubound, Symbol, Size : Integer); +{ ---------------------------------------------------------------------- + Writes a set of points + ---------------------------------------------------------------------- + F : output file + + X, Y : point coordinates + + Lbound, Ubound : indices of first and last point + + Symbol : 1 = solid circle 2 = open circle + 3 = solid square 4 = open square + 5 = solid triangle 6 = open triangle + 7 = plus (+) 8 = multiply (x) + 9 = star (*) + + Size : size of points + ---------------------------------------------------------------------- } + +procedure WriteText(var F : Text; Place : String; X, Y : Float; S : String); +{ ---------------------------------------------------------------------- + Writes a text + ---------------------------------------------------------------------- + F : output file + + Place : defines the position of point (X,Y) with respect + to the box enclosing the text + + the possible values are + 'tl', 't', 'tr', 'l', 'r', 'Bl', 'B', 'Br', 'bl', 'b', 'br' + according to the following scheme: + + t + tl +---------------------+ tr + | | + | | + l | | r + | | + Bl |----------B----------| Br + bl +---------------------+ br + b + + X, Y : position of text + + S : text to be written + ---------------------------------------------------------------------- } + +procedure WriteNumber(var F : Text; Place : String; X, Y, Z : Float); +{ ---------------------------------------------------------------------- + Writes a number + ---------------------------------------------------------------------- + Z is the number to be written + Other parameters as in WriteText + ---------------------------------------------------------------------- } + +procedure WriteCurve(var F : Text; X, Y : PVector; + Lbound, Ubound, Width : Integer; + Style : String; Smooth : Boolean); +{ ---------------------------------------------------------------------- + Writes a curve + ---------------------------------------------------------------------- + F : output file + + X, Y : point coordinates + + Lbound, Ubound : indices of first and last point + + Width : curve width in units of 0.01 cm + + Style : curve style (must be 'solid', 'dotted' or 'dashed') + + Smooth : indicates if the curve must be smoothed + ---------------------------------------------------------------------- } + +procedure WriteFunc(var F : Text; Func : TFunc; X1, X2 : Float; + Npt, Width : Integer; Style : String); +{ ---------------------------------------------------------------------- + Writes the curve representing a function + ---------------------------------------------------------------------- + F : output file + + Func : function to be plotted + + X1, X2 : abscissae of 1st and last point to plot + + Npt : number of points + + Width, Style : width of curve (as in WriteCurve) + ---------------------------------------------------------------------- + The function must be programmed as: function Func(X : Float) : Float; + ---------------------------------------------------------------------- } + +procedure CloseTexGraph(var F : Text); +{ ---------------------------------------------------------------------- + Close graphics + ---------------------------------------------------------------------- } + +implementation + +const + PAGEWIDTH = 13; { Graph width in cm } + PAGEHEIGHT = 10; { Graph height in cm } + +var + XminCm, YminCm : Float; { Coord. of lower left corner in cm } + XmaxCm, YmaxCm : Float; { Coord. of upper right corner in cm } + FactX, FactY : Float; { Scaling factors } + + function Xcm(X : Float) : Float; + { Converts user coordinate X to cm } + begin + Xcm := XminCm + FactX * (X - XAxis.Min); + end; + + function Ycm(Y : Float) : Float; + { Converts user coordinate Y to cm } + begin + Ycm := YminCm + FactY * (Y - YAxis.Min); + end; + + procedure WriteHeader(var F : Text); + begin + WriteLn(F, '\documentclass[12pt,a4paper]{article}'); + WriteLn(F, '\usepackage{t1enc}'); + WriteLn(F, '\usepackage{pst-plot}'); + WriteLn(F, '\begin{document}'); + WriteLn(F); + WriteLn(F, '\begin{pspicture}(', PAGEWIDTH, ',', PAGEHEIGHT, ')'); + end; + + procedure WriteCoord(var F : Text; X, Y : Float); + { Writes the coordinates (in cm) of a point } + var + NSZ : Boolean; + begin + NSZ := NSZEro; + NSZero := False; + Write(F, '(', Trim(FloatToStr(X)), ',', Trim(FloatToStr(Y)), ')'); + NSZEro := NSZ; + end; + + procedure WriteLine(var F : Text; X1, Y1, X2, Y2 : Float; Style : String); + begin + Write(F, '\psline'); + if Style <> '' then + Write(F, '[linestyle=', Style, ']'); + WriteCoord(F, X1, Y1); + WriteCoord(F, X2, Y2); + WriteLn(F); + end; + + procedure WriteText(var F : Text; Place : String; X, Y : Float; S : String); + begin + Write(F, '\rput[', Place, ']'); + WriteCoord(F, X, Y); + WriteLn(F, '{', S, '}'); + end; + + procedure WriteNumber(var F : Text; Place : String; X, Y, Z : Float); + begin + Write(F, '\rput[', Place, ']'); + WriteCoord(F, X, Y); + WriteLn(F, '{', Trim(FloatToStr(Z)), '}'); + end; + + procedure WriteXAxis(var F: Text); + var + W, X, Xc, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + WriteLine(F, XminCm, YminCm, XmaxCm, YminCm, ''); + + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + X := XAxis.Min; { Tick mark position } + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + + Xc := Xcm(X); + WriteLine(F, Xc, YminCm, Xc, YminCm - 0.25, ''); { Tick mark } + + if XAxis.Scale = LIN_SCALE then + Z := X + else + Z := Exp10(X); + WriteNumber(F, 't', Xc, YminCm - 0.35, Z); { Label } + + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do { Plot minor divisions } + begin { on logarithmic scale } + W := X + Log10(J); + Xc := Xcm(W); + WriteLine(F, Xc, YminCm, Xc, YminCm - 0.15, ''); + end; + + X := X + XAxis.Step; + end; + + { Write axis title } + if XTitle.Text <> '' then + WriteText(F, 't', 0.5 * (XminCm + XmaxCm), YminCm - 1.0, XTitle.Text); + + NSZero := NSZ; + end; + + procedure WriteYAxis(var F : Text); + var + W, Y, Yc, Z : Float; + N, I, J : Integer; + NSZ : Boolean; + begin + WriteLine(F, XminCm, YminCm, XminCm, YmaxCm, ''); + + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); + Y := YAxis.Min; + + NSZ := NSZero; + NSZero := False; + + for I := 0 to N do + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + + Yc := Ycm(Y); + WriteLine(F, XminCm, Yc, XminCm - 0.25, Yc, ''); + + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + WriteNumber(F, 'r', XminCm - 0.35, Yc, Z); + + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + Yc := Ycm(W); + WriteLine(F, XminCm, Yc, XminCm - 0.15, Yc, ''); + end; + + Y := Y + YAxis.Step; + end; + + { Write axis title } + if YTitle.Text <> '' then + WriteText(F, 'l', XminCm, YmaxCm + 0.5, YTitle.Text); + + NSZero := NSZ; + end; + + procedure WriteGrid(var F : Text); + var + X, Y, Xc, Yc : Float; + I, N : Integer; + begin + { Horizontal lines } + if Grid in [HORIZ_GRID, BOTH_GRID] then + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yc := Ycm(Y); + WriteLine(F, XminCm, Yc, XmaxCm, Yc, 'dotted'); + end; + end; + + { Vertical lines } + if Grid in [VERTIC_GRID, BOTH_GRID] then + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xc := Xcm(X); + WriteLine(F, Xc, YminCm, Xc, YmaxCm, 'dotted'); + end; + end; + end; + + procedure InitTexGraph(var F : Text; Filename : String); + begin + XminCm := 0.01 * Xwin1 * PAGEWIDTH; + XmaxCm := 0.01 * Xwin2 * PAGEWIDTH; + YminCm := 0.01 * Ywin1 * PAGEHEIGHT; + YmaxCm := 0.01 * Ywin2 * PAGEHEIGHT; + + FactX := (XmaxCm - XminCm) / (XAxis.Max - XAxis.Min); + FactY := (YmaxCm - YminCm) / (YAxis.Max - YAxis.Min); + + Assign(F, FileName); + Rewrite(F); + + WriteHeader(F); + + if GraphBorder then + begin + Write(F, '\pspolygon'); + WriteCoord(F, XminCm, YminCm); + WriteCoord(F, XmaxCm, YminCm); + WriteCoord(F, XmaxCm, YmaxCm); + WriteCoord(F, XminCm, YmaxCm); + WriteLn(F); + end; + end; + + procedure WritePoint(var F : Text; X, Y : Float); + var + Xc, Yc : Float; + begin + if XAxis.Scale = LOG_SCALE then X := Log10(X); + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + + Xc := Xcm(X); + Yc := Ycm(Y); + + if (Xc >= XminCm) and (Xc <= XmaxCm) and + (Yc >= YminCm) and (Yc <= YmaxCm) then + WriteCoord(F, Xc, Yc); + end; + + procedure WritePoints(var F : Text; X, Y : PVector; + Lbound, Ubound, Symbol, Size : Integer); + var + I, N : Integer; + begin + Write(F, '\psdots[dotscale=', Size, ' ', Size, ', dotstyle='); + case Symbol of + 1 : Write(F, '*'); + 2 : Write(F, 'o'); + 3 : Write(F, 'square*'); + 4 : Write(F, 'square'); + 5 : Write(F, 'triangle*'); + 6 : Write(F, 'triangle'); + 7 : Write(F, '+'); + 8 : Write(F, 'x'); + 9 : Write(F, 'asterisk'); + end; + WriteLn(F, ']%'); + + I := Lbound; + repeat + WritePoint(F, X^[I], Y^[I]); + if (I > 0) and (I < Ubound) and (I mod 5 = 0) then WriteLn(F, '%'); + Inc(I); + until I > Ubound; + WriteLn(F); + end; + + procedure WriteCurve(var F : Text; X, Y : PVector; + Lbound, Ubound, Width : Integer; + Style : String; Smooth : Boolean); + var + I, N : Integer; + W : Float; + Ws : String; + begin + W := 0.01 * Width; + Str(W:5:2, Ws); + Ws := Trim(Ws); + + if Smooth then Write(F, '\pscurve') else Write(F, '\psline'); + WriteLn(F, '[linewidth=', Ws, ', linestyle=', Style, ']%'); + + I := Lbound; + repeat + WritePoint(F, X^[I], Y^[I]); + if (I > 0) and (I < Ubound) and (I mod 5 = 0) then WriteLn(F, '%'); + Inc(I); + until I > Ubound; + WriteLn(F); + end; + + procedure WriteFunc(var F : Text; Func : TFunc; X1, X2 : Float; + Npt, Width : Integer; Style : String); + const + X : PVector = nil; + Y : PVector = nil; + N : Integer = 0; + var + H : Float; + I : Integer; + begin + if Npt <> N then + begin + DelVector(X, N); + DelVector(Y, N); + DimVector(X, Npt); + DimVector(Y, Npt); + N := Npt; + end; + + H := (X2 - X1) / N; + for I := 0 to N do + begin + X^[I] := X1 + I * H; + if XAxis.Scale = LIN_SCALE then + Y^[I] := Func(X^[I]) + else + Y^[I] := Func(Exp10(X^[I])); + end; + + WriteCurve(F, X, Y, 0, N, Width, Style, True); + end; + + procedure CloseTexGraph(var F: Text); + begin + WriteLn(F, '\end{pspicture}'); + WriteLn(F); + WriteLn(F, '\end{document}'); + Close(F); + end; + +end. + + diff --git a/npm_precl/dmath/winplot.pas b/npm_precl/dmath/winplot.pas new file mode 100755 index 0000000..4376db5 --- /dev/null +++ b/npm_precl/dmath/winplot.pas @@ -0,0 +1,856 @@ +{ ********************************************************************** + * Unit WINPLOT.PAS * + * Version 1.1 * + * (c) J. Debord, October 1999 * + ********************************************************************** + Plotting routines for DELPHI + ********************************************************************** } + +unit WinPlot; + +interface + +uses + { DELPHI units } + WinTypes, + Graphics, + { TPMath units } + FMath, + Matrices, + Stat, + PaString; + +{ ************************* Constants and types ************************ } + +const + MAXCURV = 255; { Max. number of curves which may be plotted } + MAXSYMBOL = 9; { Max. number of symbols for plotting curves } + EPS = 1.0E-10; { Lower limit for an axis label } + +type + TScale = (LIN_SCALE, { Scale } + LOG_SCALE); + + TGrid = (NO_GRID, { Grid } + HORIZ_GRID, + VERTIC_GRID, + BOTH_GRID); + + TAxis = record { Coordinate axis } + Scale : TScale; + Min, Max, Step : Float; + Title : String; + end; + + TPointParam = record { Point parameters } + Symbol : Integer; { Symbol index } + Size : Integer; { Symbol size in 1/250 of graphic width } + Color : TColor; + end; + + TLineParam = record { Line parameters } + Width : Integer; + Style : TPenStyle; + Color : TColor; + end; + + TCurvParam = record { Curve parameters } + PointParam : TPointParam; + LineParam : TLineParam; + Legend : String[30]; { Legend of curve } + Step : Integer; { Plot 1 point every Step points } + Connect : Boolean; { Connect points with line? } + end; + + TCurvParamArray = array[1..MAXCURV] of TCurvParam; + + PCurvParamArray = ^TCurvParamArray; + +{ ******** Global variables defining the appearance of the graph ******* } + +const + Xwin1 : Integer = 15; { Window coordinates in percent of maximum } + Ywin1 : Integer = 15; + Xwin2 : Integer = 75; + Ywin2 : Integer = 75; + + GraphBorder : Boolean = True; { For plotting a rectangle around the graph } + + XAxis : TAxis = (Scale : LIN_SCALE; { Horizontal axis } + Min : 0.0; + Max : 1.0; + Step : 0.2; + Title : 'X'); + + YAxis : TAxis = (Scale : LIN_SCALE; { Vertical axis } + Min : 0.0; + Max : 1.0; + Step : 0.2; + Title : 'Y'); + + Grid : TGrid = BOTH_GRID; { Grid } + + GraphTitle : String = ''; { Title of graph } + +{ ************************** Graphic routines ************************** } + +procedure InitGraph(Canvas : TCanvas; + Width, Height : Integer); +{ ---------------------------------------------------------------------- + Initializes the graphic + ---------------------------------------------------------------------- + The parameters refer to the object on which the graphic is plotted. + + Examples: + + To draw on a TImage object: + InitGraph(Image1.Canvas, Image1.Width, Image1.Height); + + To print the graphic: + InitGraph(Printer.Canvas, Printer.PageWidth, Printer.PageHeight); + ---------------------------------------------------------------------- } + +procedure PlotXAxis(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots the X axis + ---------------------------------------------------------------------- } + +procedure PlotYAxis(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots the Y axis + ---------------------------------------------------------------------- } + +procedure WriteTitle(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Writes the title of the graph + ---------------------------------------------------------------------- } + +procedure PlotGrid(Canvas : TCanvas); +{ ---------------------------------------------------------------------- + Plots a grid on the graph + ---------------------------------------------------------------------- } + +procedure PlotPoint(Canvas : TCanvas; + X, Y : Float; + PointParam : TPointParam); +{ ---------------------------------------------------------------------- + Plots a point + ---------------------------------------------------------------------- + X, Y : point coordinates + PointParam : point parameters + ---------------------------------------------------------------------- } + +procedure PlotCurve(Canvas : TCanvas; + X, Y : PVector; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); +{ ---------------------------------------------------------------------- + Plots a curve + ---------------------------------------------------------------------- + X, Y : point coordinates + Lbound, Ubound : indices of first and last points + CurvParam : curve parameters + ---------------------------------------------------------------------- } + +procedure PlotCurveWithErrorBars(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); +{ ---------------------------------------------------------------------- + Plots a curve with error bars + ---------------------------------------------------------------------- + X, Y : point coordinates + S : errors (e.g. standard deviations) + Ns : error multiplier (e.g. 2 for plotting 2 SD's) + Lbound, Ubound : indices of first and last points + CurvParam : curve parameters + ---------------------------------------------------------------------- } + +procedure PlotFunc(Canvas : TCanvas; + Func : TFunc; + Xmin, Xmax : Float; + Npt : Integer; + LineParam : TLineParam); +{ ---------------------------------------------------------------------- + Plots a function + ---------------------------------------------------------------------- + Func : function to be plotted + must be programmed as: function Func(X : Float) : Float; + Xmin, Xmax : abscissae of 1st and last point to plot + Npt : number of points + LineParam : line parameters + ---------------------------------------------------------------------- } + +procedure WriteLegend(Canvas : TCanvas; + NCurv : Integer; + CurvParam : PCurvParamArray; + ShowPoints, + ShowLines : Boolean); +{ ---------------------------------------------------------------------- + Writes the legends for the plotted curves + ---------------------------------------------------------------------- + NCurv : number of curves (1 to MAXCURV) + CurvParam : curve parameters + ShowPoints : for displaying points + ShowLines : for displaying lines + ---------------------------------------------------------------------- } + + +{ *********** The following routines are defined in PLOT.INC *********** } + +procedure Interval(X1, X2 : Float; + MinDiv, MaxDiv : Integer; + var Min, Max, Step : Float); +{ ---------------------------------------------------------------------- + Determines an interval [Min, Max] including the values from X1 to X2, + and a subdivision Step of this interval + ---------------------------------------------------------------------- + Input parameters : X1, X2 = min. & max. values to be included + MinDiv = minimum nb of subdivisions + MaxDiv = maximum nb of subdivisions + ---------------------------------------------------------------------- + Output parameters : Min, Max, Step + ---------------------------------------------------------------------- } + +procedure AutoScale(Z : PVector; + Lbound, Ubound : Integer; + var Axis : TAxis); +{ ---------------------------------------------------------------------- + Determines the scale of an axis + ---------------------------------------------------------------------- + Input parameters : Z = array of values to be plotted + Lbound, + Ubound = indices of first and last elements of Z + ---------------------------------------------------------------------- + Output parameters : Axis + ---------------------------------------------------------------------- } + +function Xpixel(X : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user abscissa X to screen coordinate + ---------------------------------------------------------------------- } + +function Ypixel(Y : Float) : Integer; +{ ---------------------------------------------------------------------- + Converts user ordinate Y to screen coordinate + ---------------------------------------------------------------------- } + +function Xuser(X : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate X to user abscissa + ---------------------------------------------------------------------- } + +function Yuser(Y : Integer) : Float; +{ ---------------------------------------------------------------------- + Converts screen coordinate Y to user ordinate + ---------------------------------------------------------------------- } + +implementation + +uses + Classes; + +var + GraphWidth, GraphHeight, SymbolSizeUnit : Integer; + +{ ---------------------------------------------------------------------- + Include the variables and routines common to PLOT.PAS and WINPLOT.PAS + ---------------------------------------------------------------------- } + + {$I PLOT.INC} + +{ ---------------------------------------------------------------------- } + +procedure PlotXAxis(Canvas : TCanvas); + var + W, X, Z : Float; + N, I, J, TickLength, MinorTickLength, Wp, Xp : Integer; + XLabel : String; + NSZ : Boolean; + begin + TickLength := Canvas.TextHeight('M') div 2; + MinorTickLength := Round(0.67 * TickLength); { For log scale } + + { Draw axis } + Canvas.MoveTo(XminPixel, YmaxPixel); + Canvas.LineTo(XmaxPixel, YmaxPixel); + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); { Nb of intervals } + + X := XAxis.Min; { Tick mark position } + for I := 0 to N do { Label axis } + begin + if (XAxis.Scale = LIN_SCALE) and (Abs(X) < EPS) then X := 0.0; + Xp := Xpixel(X); + + { Draw tick mark } + Canvas.MoveTo(Xp, YmaxPixel); + Canvas.LineTo(Xp, YmaxPixel + TickLength); + + { Write label } + if XAxis.Scale = LIN_SCALE then Z := X else Z := Exp10(X); + XLabel := Trim(PaString.FloatToStr(Z)); + Canvas.TextOut(Xp - Canvas.TextWidth(XLabel) div 2, + YmaxPixel + TickLength, XLabel); + + { Plot minor divisions on logarithmic scale } + if (XAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := X + Log10(J); + Wp := Xpixel(W); + Canvas.MoveTo(Wp, YmaxPixel); + Canvas.LineTo(Wp, YmaxPixel + MinorTickLength); + end; + X := X + XAxis.Step; + end; + + NSZero := NSZ; + + { Write axis title } + if XAxis.Title <> '' then + Canvas.TextOut(XminPixel + (XmaxPixel - XminPixel - + Canvas.TextWidth(XAxis.Title)) div 2, + YmaxPixel + 2 * Canvas.TextHeight('M'), + XAxis.Title); + end; + + procedure PlotYAxis(Canvas : TCanvas); + var + W, Y, Z : Float; + N, I, J, Wp, Yp : Integer; + TickLength, MinorTickLength, Yoffset : Integer; + YLabel : String; + NSZ : Boolean; + begin + TickLength := Canvas.TextWidth('M') div 2; + MinorTickLength := Round(0.67 * TickLength); { For log scale } + + Yoffset := Canvas.TextHeight('M') div 2; + + { Draw axis } + Canvas.MoveTo(XminPixel, YminPixel); + Canvas.LineTo(XminPixel, YmaxPixel); + + NSZ := NSZero; + NSZero := False; { Don't write non significant zero's } + + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + + Y := YAxis.Min; { Tick mark position } + for I := 0 to N do { Label axis } + begin + if (YAxis.Scale = LIN_SCALE) and (Abs(Y) < EPS) then Y := 0.0; + Yp := Ypixel(Y); + + { Draw tick mark } + Canvas.MoveTo(XminPixel, Yp); + Canvas.LineTo(XminPixel - TickLength, Yp); + + { Write label } + if YAxis.Scale = LIN_SCALE then Z := Y else Z := Exp10(Y); + YLabel := Trim(PaString.FloatToStr(Z)); + Canvas.TextOut(XminPixel - TickLength - Canvas.TextWidth(YLabel), + Yp - Yoffset, YLabel); + + { Plot minor divisions on logarithmic scale } + if (YAxis.Scale = LOG_SCALE) and (I < N) then + for J := 2 to 9 do + begin + W := Y + Log10(J); + Wp := Ypixel(W); + Canvas.MoveTo(XminPixel, Wp); + Canvas.LineTo(XminPixel - MinorTickLength, Wp); + end; + Y := Y + YAxis.Step; + end; + + NSZero := NSZ; + + { Write axis title } + if YAxis.Title <> '' then + Canvas.TextOut(XminPixel, YminPixel - 3 * Yoffset, YAxis.Title); + end; + + procedure InitGraph(Canvas : TCanvas; Width, Height : Integer); + begin + GraphWidth := Width; + GraphHeight := Height; + SymbolSizeUnit := GraphWidth div 250; + + XminPixel := Round(Xwin1 / 100 * Width); + YminPixel := Round(Ywin1 / 100 * Height); + XmaxPixel := Round(Xwin2 / 100 * Width); + YmaxPixel := Round(Ywin2 / 100 * Height); + + FactX := (XmaxPixel - XminPixel) / (XAxis.Max - XAxis.Min); + FactY := (YmaxPixel - YminPixel) / (YAxis.Max - YAxis.Min); + + if GraphBorder then + Canvas.Rectangle(XminPixel, YminPixel, Succ(XmaxPixel), Succ(YmaxPixel)); + end; + + procedure WriteTitle(Canvas : TCanvas); + begin + if GraphTitle <> '' then + with Canvas do + TextOut((XminPixel + XmaxPixel - TextWidth(GraphTitle)) div 2, + YminPixel - 2 * TextHeight(GraphTitle), GraphTitle); + end; + + procedure PlotGrid(Canvas : TCanvas); + var + X, Y : Float; + I, N, Xp, Yp : Integer; + PenStyle : TpenStyle; + begin + { Save current settings } + PenStyle := Canvas.Pen.Style; + Canvas.Pen.Style := psDot; + + if Grid in [HORIZ_GRID, BOTH_GRID] then { Horizontal lines } + begin + N := Round((YAxis.Max - YAxis.Min) / YAxis.Step); { Nb of intervals } + for I := 1 to Pred(N) do + begin + Y := YAxis.Min + I * YAxis.Step; { Origin of line } + Yp := Ypixel(Y); + Canvas.MoveTo(XminPixel, Yp); + Canvas.LineTo(XmaxPixel, Yp); + end; + end; + + if Grid in [VERTIC_GRID, BOTH_GRID] then { Vertical lines } + begin + N := Round((XAxis.Max - XAxis.Min) / XAxis.Step); + for I := 1 to Pred(N) do + begin + X := XAxis.Min + I * XAxis.Step; + Xp := Xpixel(X); + Canvas.MoveTo(Xp, YminPixel); + Canvas.LineTo(Xp, YmaxPixel); + end; + end; + + { Restore settings } + Canvas.Pen.Style := PenStyle; + end; + + function XOutOfBounds(X : Integer) : Boolean; + { Checks if an absissa is outside the graphic bounds } + begin + XOutOfBounds := (X < XminPixel) or (X > XmaxPixel); + end; + + function YOutOfBounds(Y : Integer) : Boolean; + { Checks if an ordinate is outside the graphic bounds } + begin + YOutOfBounds := (Y < YminPixel) or (Y > YmaxPixel); + end; + + function CheckPoint(X, Y : Float; + var Xp, Yp : Integer) : Boolean; + { Computes the pixel coordinates of a point and + checks if it is enclosed within the graph limits } + begin + Xp := Xpixel(X); + Yp := Ypixel(Y); + CheckPoint := not(XOutOfBounds(Xp) or YOutOfBounds(Yp)); + end; + + procedure PlotSymbol(Canvas : TCanvas; + Xp, Yp : Integer; + Symbol, Size : Integer); + { Plots a symbol at pixel coordinates (Xp, Yp) + with the current canvas settings } + var + Xp1, Xp2, Yp1, Yp2 : Integer; + begin + if Symbol > 0 then + begin + Size := Size * SymbolSizeUnit; + Xp1 := Xp - Size; + Yp1 := Yp - Size; + Xp2 := Xp + Size + 1; + Yp2 := Yp + Size + 1; + end; + + with Canvas do + case Symbol of + 0 : Pixels[Xp, Yp] := Brush.Color; + 1, 2 : Ellipse(Xp1, Yp1, Xp2, Yp2); { Circle } + 3, 4 : Rectangle(Xp1, Yp1, Xp2, Yp2); { Square } + 5, 6 : Polygon([Point(Xp1, Yp2 - 1), + Point(Xp2, Yp2 - 1), + Point(Xp, Yp1 - 1)]); { Triangle } + 7 : begin { + } + MoveTo(Xp, Yp1); + LineTo(Xp, Yp2); + MoveTo(Xp1, Yp); + LineTo(Xp2, Yp); + end; + 8 : begin { x } + MoveTo(Xp1, Yp1); + LineTo(Xp2, Yp2); + MoveTo(Xp1, Yp2 - 1); + LineTo(Xp2, Yp1 - 1); + end; + 9 : begin { * } + MoveTo(Xp, Yp1); + LineTo(Xp, Yp2); + MoveTo(Xp1, Yp); + LineTo(Xp2, Yp); + MoveTo(Xp1, Yp1); + LineTo(Xp2, Yp2); + MoveTo(Xp1, Yp2 - 1); + LineTo(Xp2, Yp1 - 1); + end; + end; + end; + + procedure PlotLine(Canvas : TCanvas; + Xp1, Yp1, Xp2, Yp2 : Integer); + { Plots a line with the current canvas settings } + begin + Canvas.MoveTo(Xp1, Yp1); + Canvas.LineTo(Xp2, Yp2); + end; + + procedure PlotPoint(Canvas : TCanvas; + X, Y : Float; + PointParam : TPointParam); + var + Xp, Yp : Integer; + BrushStyle : TBrushStyle; + PenColor, BrushColor : TColor; + begin + if XAxis.Scale = LOG_SCALE then X := Log10(X); + if YAxis.Scale = LOG_SCALE then Y := Log10(Y); + + if not CheckPoint(X, Y, Xp, Yp) then Exit; + + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + + Pen.Color := PointParam.Color; + Brush.Color := PointParam.Color; + if PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + PlotSymbol(Canvas, Xp, Yp, PointParam.Symbol, PointParam.Size); + + { Restore settings } + Pen.Color := PenColor; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + + procedure PlotErrorBar(Canvas : TCanvas; + Y, S : Float; + Ns : Integer; + Xp, Yp, Size : Integer); + { Plots an error bar with the current canvas settings } + var + Delta, Y1 : Float; + Yp1 : Integer; + begin + Size := Size * SymbolSizeUnit; + + Delta := Ns * S; + Y1 := Y - Delta; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Yp1 := Ypixel(Y1); + + if Yp1 <= YmaxPixel then + begin + PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1); + PlotLine(Canvas, Xp, Yp, Xp, Yp1); + end + else + PlotLine(Canvas, Xp, Yp, Xp, YmaxPixel); + + Y1 := Y + Delta; + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Yp1 := Ypixel(Y1); + + if Yp1 >= YminPixel then + begin + PlotLine(Canvas, Xp - Size, Yp1, Xp + Size + 1, Yp1); + PlotLine(Canvas, Xp, Yp, Xp, Yp1); + end + else + PlotLine(Canvas, Xp, Yp, Xp, YminPixel); + end; + + procedure GenPlotCurve(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam; + ErrorBars : Boolean); + { General curve plotting routine } + var + X1, Y1, X2, Y2 : Float; + Xp1, Yp1, Xp2, Yp2 : Integer; + I : Integer; + Flag1, Flag2 : Boolean; + PenWidth : Integer; + PenStyle : TpenStyle; + PenColor, BrushColor : TColor; + BrushStyle : TBrushStyle; + begin + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + + Pen.Color := CurvParam.LineParam.Color; + Pen.Style := CurvParam.LineParam.Style; + Pen.Width := CurvParam.LineParam.Width; + Brush.Color := CurvParam.PointParam.Color; + + if CurvParam.PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + { Plot first point } + X1 := X^[Lbound]; if XAxis.Scale = LOG_SCALE then X1 := Log10(X1); + Y1 := Y^[Lbound]; if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Flag1 := CheckPoint(X1, Y1, Xp1, Yp1); + if Flag1 then + begin + PlotSymbol(Canvas, Xp1, Yp1, CurvParam.PointParam.Symbol, + CurvParam.PointParam.Size); + if ErrorBars and (S^[Lbound] > 0.0) then + PlotErrorBar(Canvas, Y^[Lbound], S^[Lbound], Ns, Xp1, Yp1, + CurvParam.PointParam.Size); + end; + + { Plot other points and connect them by lines if necessary } + I := Lbound + CurvParam.Step; + while I <= Ubound do + begin + X2 := X^[I]; if XAxis.Scale = LOG_SCALE then X2 := Log10(X2); + Y2 := Y^[I]; if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Flag2 := CheckPoint(X2, Y2, Xp2, Yp2); + if Flag2 then + begin + PlotSymbol(Canvas, Xp2, Yp2, CurvParam.PointParam.Symbol, + CurvParam.PointParam.Size); + if ErrorBars and (S^[I] > 0.0) then + PlotErrorBar(Canvas, Y^[I], S^[I], Ns, Xp2, Yp2, + CurvParam.PointParam.Size); + if CurvParam.Connect and Flag1 then + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + end; + + Xp1 := Xp2; + Yp1 := Yp2; + Flag1 := Flag2; + Inc(I, CurvParam.Step); + end; + + { Restore settings } + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + + procedure PlotCurve(Canvas : TCanvas; + X, Y : PVector; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); + var + Ns : Integer; { Dummy variables } + S : PVector; + begin + GenPlotCurve(Canvas, X, Y, S, Ns, Lbound, Ubound, CurvParam, False); + end; + + procedure PlotCurveWithErrorBars(Canvas : TCanvas; + X, Y, S : PVector; + Ns : Integer; + Lbound, Ubound : Integer; + CurvParam : TCurvParam); + begin + GenPlotCurve(Canvas, X, Y, S, Ns, Lbound, Ubound, CurvParam, True); + end; + + procedure PlotFunc(Canvas : TCanvas; + Func : TFunc; + Xmin, Xmax : Float; + Npt : Integer; + LineParam : TLineParam); + var + PenColor : TColor; + PenStyle : TpenStyle; + PenWidth : Integer; + X1, Y1, X2, Y2, H : Float; + Xp1, Yp1, Xp2, Yp2 : Integer; + Flag1, Flag2 : Boolean; + I : Integer; + begin + if (Npt < 2) or (LineParam.Style = psClear) then Exit; + + if Xmin >= Xmax then + begin + Xmin := XAxis.Min; + Xmax := XAxis.Max; + end; + + H := (Xmax - Xmin) / Npt; + + with Canvas do + begin + { Save current settings } + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + + Pen.Color := LineParam.Color; + Pen.Style := LineParam.Style; + Pen.Width := LineParam.Width; + + { Check first point } + X1 := Xmin; + if XAxis.Scale = LIN_SCALE then + Y1 := Func(X1) + else + Y1 := Func(Exp10(X1)); + if YAxis.Scale = LOG_SCALE then Y1 := Log10(Y1); + Flag1 := CheckPoint(X1, Y1, Xp1, Yp1); + + { Check other points and plot lines if possible } + for I := 1 to Npt do + begin + X2 := X1 + H; + if XAxis.Scale = LIN_SCALE then + Y2 := Func(X2) + else + Y2 := Func(Exp10(X2)); + if YAxis.Scale = LOG_SCALE then Y2 := Log10(Y2); + Flag2 := CheckPoint(X2, Y2, Xp2, Yp2); + if Flag1 and Flag2 then + PlotLine(Canvas, Xp1, Yp1, Xp2, Yp2); + X1 := X2; + Xp1 := Xp2; + Yp1 := Yp2; + Flag1 := Flag2; + end; + + { Restore settings } + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + end; + end; + + procedure WriteLegend(Canvas : TCanvas; + NCurv : Integer; + CurvParam : PCurvParamArray; + ShowPoints, + ShowLines : Boolean); + + var + CharHeight, I, L, Lmax, N, Nmax, Xp, Xl, Y : Integer; + PenWidth : Integer; + PenStyle : TpenStyle; + PenColor, BrushColor : TColor; + BrushStyle : TBrushStyle; + begin + N := 0; { Nb of legends to be plotted } + Lmax := 0; { Length of the longest legend } + + for I := 1 to NCurv do + if CurvParam^[I].Legend <> '' then + begin + Inc(N); + L := Canvas.TextWidth(CurvParam^[I].Legend); + if L > Lmax then Lmax := L; + end; + + if (N = 0) or (Lmax = 0) then Exit; + + { Character height } + CharHeight := Canvas.TextHeight('M'); + + { Max. number of legends which may be plotted } + Nmax := Round((YmaxPixel - YminPixel) / CharHeight) - 1; + if N > Nmax then N := Nmax; + + { Draw rectangle around the legends } + Canvas.Rectangle(XmaxPixel + Round(0.02 * GraphWidth), YminPixel, + XmaxPixel + Round(0.12 * GraphWidth) + Lmax, + YminPixel + (N + 1) * CharHeight); + + L := Round(0.02 * GraphWidth); { Half-length of line } + Xp := XmaxPixel + 3 * L; { Position of symbol } + Xl := XmaxPixel + 5 * L; { Position of legend } + + { Save current settings } + with Canvas do + begin + PenColor := Pen.Color; + PenStyle := Pen.Style; + PenWidth := Pen.Width; + BrushColor := Brush.Color; + BrushStyle := Brush.Style; + end; + + for I := 1 to IMin(NCurv, Nmax) do + with Canvas do + begin + Pen.Color := CurvParam^[I].LineParam.Color; + Pen.Style := CurvParam^[I].LineParam.Style; + Pen.Width := CurvParam^[I].LineParam.Width; + Brush.Color := CurvParam^[I].PointParam.Color; + + if CurvParam^[I].PointParam.Symbol in [0, 1, 3, 5] then + Brush.Style := bsSolid + else + Brush.Style := bsClear; + + { Plot point and line } + Y := YminPixel + I * CharHeight; + if ShowPoints then + PlotSymbol(Canvas, Xp, Y, CurvParam^[I].PointParam.Symbol, + CurvParam^[I].PointParam.Size); + if ShowLines then + PlotLine(Canvas, Xp - L, Y, Xp + L, Y); + + { Write legend } + Brush.Style := bsClear; + Canvas.TextOut(Xl, Y - CharHeight div 2, CurvParam^[I].Legend); + end; + + { Restore settings } + with Canvas do + begin + Pen.Color := PenColor; + Pen.Style := PenStyle; + Pen.Width := PenWidth; + Brush.Color := BrushColor; + Brush.Style := BrushStyle; + end; + end; + +end. diff --git a/npm_precl/extrafpc.cfg b/npm_precl/extrafpc.cfg new file mode 100755 index 0000000..4c13c40 --- /dev/null +++ b/npm_precl/extrafpc.cfg @@ -0,0 +1,4 @@ +#IFDEF Darwin +-k-macosx_version_min -k10.4 +-XR/Developer/SDKs/MacOSX10.4u.sdk/ +#ENDIF \ No newline at end of file diff --git a/npm_precl/filename.pas b/npm_precl/filename.pas new file mode 100755 index 0000000..ff04bd8 --- /dev/null +++ b/npm_precl/filename.pas @@ -0,0 +1,28 @@ +unit filename; + +interface +{$H+} + +function LegitFilename(var lInName: string; lIndex: integer): string; + + +implementation +uses SysUtils; + +function LegitFilename(var lInName: string; lIndex: integer): string; +var + I: integer; +begin + if length(lInName) < 1 then begin + result := inttostr(lIndex); + exit; + end; + result := ''; + for I := 1 to length(lInName) do + if lInName[I] in [ '0'..'9','a'..'z','A'..'Z'] then + result := result + lInName[I]; + if length(result) < 1 then + result := inttostr(lIndex); +end; + +end. diff --git a/npm_precl/firth.pas b/npm_precl/firth.pas new file mode 100755 index 0000000..bc3785e --- /dev/null +++ b/npm_precl/firth.pas @@ -0,0 +1,465 @@ +unit firth; + +interface +uses + ComCtrls,Classes, Graphics, ExtCtrls, define_types,{stats,}StatThdsUtil,lesion_pattern,Mat,Math,Distr,Vector; + +procedure FirthAnalyzeNoThread(lnCond, lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); + + + +implementation +uses npmform, dialogs; + +procedure VisualProg(lPos: Integer); +begin + MainForm.ProgressBar1.Position := lPos; + MainForm.Refresh; +end; + + +var + finalloglik: SingleP0; + KxKA1,KxKB1,KxKA,KxKB :TMatrix; +Kvec,Kvec1 : TVector; +Kveci,kVeci1 : TVectori; + betak,xbeta,y,pi,ustar, + XXx,XXXW2,XXFisher,XXcovs,XXXWPrime, + deltahalfs,deltat,delta,covs,x,Fisher,XW2,W,XWprime,Hprime,H,ustarmat,negx: TMatrix; + lBarX: TProgressBar; + lnCondx,lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx : integer; + lPlankImgx: byteP;lOutImgMnx,lSymptomRAx: SingleP; + lOutImgX: SingleRAp; + + +procedure logistfx (xin: SingleP; var lZvals: SingleP0; numSubj,numCond: integer; lComputeIntercept: boolean); +//todo zero output incase exit +//yin = 1..numSubj binary 0/1 values +//xin = numSubj*numCond predictors +//Chivals = 0..numCond p-values - the 0th Khi-value is the intercept +// [0th value will not be computed if ; lComputeIntercept= false] +label + 123,666; +const + maxit = 25; + maxhs = 5; + epsilon = 0.0001; + maxstep = 10; +var + SumY0,SumY1,mx, beta0,loglik,loglikold: double; + sumy, n, i,j, k, iter,halfs,lCond,dropCond: integer; + variability,firth: boolean; +procedure crossprodustar; +var + inc,row: integer; +begin + for row := 1 to k do begin + ustarmat[row,1] := 0; + for inc := 1 to ustar.r do + ustarmat[row,1] := ustarmat[row,1] + (x[row,inc]*ustar[inc,1]); + end; +end; +procedure Diag2Vec; +var + inc: integer; +begin + for inc := 1 to pi.r do + ustar[inc,1] := ustar[inc,1]+ H[inc,inc]*(0.5-pi[inc,1]); +end; //nested DiagP2 +procedure DiagP2 (var W, P: TMatrix); +var + inc: integer; +begin + W.Zero; + for inc := 1 to P.r do + W[inc,inc] := Power((P[inc,1] * (1-P[inc,1])),0.5) ; +end; //nested DiagP2 +procedure ComputeFisher; +begin + DiagP2(W,pi); + XW2.mult(x,W); + //XWPrime.copy( XW2); + //XWPrime.transpose; + XWPrime.transpose(XW2); + Fisher.mult(XW2,XWPrime); + covs.copy( Fisher); + covs.Invert2(KxKA,KxKB,Kvec,Kveci) +end; //nested computeFisher + +procedure computedropdelta; +var + jinc,iinc,ii,jj: integer; +begin + DiagP2(W,pi); + XXXW2.mult(XXx,W); + //XXXWPrime.copy( XXXW2); + //XXXWPrime.transpose; + XXXWPrime.transpose(XXXW2); + XXFisher.mult(XXXW2,XXXWPrime); + XXcovs.copy( XXFisher); + //XXcovs.Invert; + XXcovs.Invert2(KxKA1,KxKB1,Kvec1,Kveci1); + covs.Zero; + ii := 0; + for iinc := 1 to (k) do begin + if iinc <> (dropCond+1) then begin //leave the specified column zeros... + inc(ii); + jj := 0; + for jinc := 1 to (k) do begin + if jinc <> (dropCond+1) then begin + inc(jj); + covs[iinc,jinc] := xxCovs[ii,jj]; + end; + end; + end; + end; +end; +function firthpenalty: double; +begin + ComputeFisher; + //result := 0.5 * ln(abs(Fisher.det)); + result := 0.5 * ln(abs(Fisher.Det2(KxKA,kVeci,kVec))); +end; //nested firthpenalty +function ComputeLogLik: double; +var + inc: integer; + lDenom: double; +begin + xbeta.mult(betak,negx); + for inc := 1 to n do begin + lDenom := (1 + exp( xbeta[inc,1])); + if lDenom = 0 then + showmessage('yikes') + else + pi[inc,1] := 1/lDenom; + end; + result := 0; + for inc := 1 to n do + if y[inc,1] = 1 then + //if pi[inc,1] <> 1 then + result := result+ln(pi[inc,1]); + for inc := 1 to n do + if y[inc,1] = 0 then + //if pi[inc,1] <> 1 then + result := result+ln(1-pi[inc,1]); + if firth then + result := result + firthpenalty; +end;//nested ComputeLogLik +begin + for i := 0 to (numCond) do + lZVals^[i] := 0; // + if (numSubj < 2) or (numCond < 1) then + exit; + //ensure there is some variability in the input data... + variability := false; + i := 1; + repeat + inc(i); + if xin^[i] <> xin^[1] then + variability := true; + until (i= (numSubj*numCond)) or (variability); + if not variability then + exit; //no variance in the regressors... + variability := false; + i := 1; + repeat + inc(i); + if y[i,1] <> y[1,1] then + variability := true; + until (i= (numSubj)) or (variability); + if not variability then + exit; //no variance in the dependent variable... + dropCond := -1; //initially compute full model, then compute effect of removing individual conditions + firth := true; + n := numSubj; + k := numCond + 1; + //get memory + //beta := TMatrix.Create(n,1); + //design our model + //first row = 1: ell samples have equal weight + for i := 1 to n do + x.M[1,i] := 1; + //next load model into x + iter := 0; + for j := 2 to k do + for i := 1 to n do begin + inc(iter); + x.M[j,i] := xin^[iter]; + end; + //WriteMatrix('Observations',y); + //WriteMatrix('Model',x); + //negx is just sing-swapped - we will generate this as we use it a lot... + for j := 1 to k do + for i := 1 to n do begin + negx.M[j,i] := -x.M[j,i]; + end; + //now start computations + sumy := 0; + for i := 1 to n do + sumy := sumy + round(y[i,1]); + if (sumy <= 0) or (sumy >= n) then begin + //serious error: no variability. This should have been detected earlier in the procedure when yin was tested for variability + goto 666; + end; + beta0 := ln((sumy/n)/(1 - sumy/n));//initial estimate +123: //go here for each dropcond + if DropCond >= 0 then begin + betak.Ones; + betak.mult( 0) //start with a null model... does not really make sense + end else begin + betak.zero; + betak[1,1] := (beta0); + end; + iter := 0; + if DropCond >= 0 then begin //drop one of the factors... + if dropCond <> 0 then begin//include intercept + for i := 1 to n do + XXx.M[1,i] := 1; + lCond := 1; + end else + lCond := 0; + for j := 1 to NumCond do begin + if j <> DropCond then begin + inc(lCond); + for i := 1 to n do + XXx.M[lCond,i] := x.M[j+1,i]; + end; //if j <> dropCond + end; + end;//if lDropCond >= 0 + loglik := ComputeLogLik; + repeat + inc(iter); + ComputeFisher; + HPrime.mult(XWPrime,covs); + H.mult(HPrime,XW2); + //WriteMatrix(covs); + ustar.Sub(y,pi); + if firth then + Diag2Vec; + crossprodustar; + if dropCond >= 0 then // model with dropped factor + computedropdelta; + deltat.mult(covs,ustarmat); + delta.transpose(deltat); + mx := delta.MatAbsMax/MaxStep; + if mx > 1 then + delta.mult(mx);//scale delta + betak.add(delta); + loglikold := loglik; + halfs := 1; + while halfs <= maxhs do begin // Half-Steps + //fx(iter,halfs,loglik); + loglik := ComputeLogLik; + deltahalfs.mult(delta,power(2,-halfs)); + betak.sub(deltahalfs); + if (loglik > loglikold) then + break; + inc(halfs); + end; + if delta.MatAbsMax <= epsilon then break; + until (iter >= maxit); + //fx(DropCond,loglik); + //done with this model - record model fit + if DropCond < 0 then + finalloglik^[k] := loglik //full model + else begin + finalloglik^[DropCond] := loglik; //model with a factor removed + end; + if DropCond < numCond then begin + inc(DropCond); + if (DropCond = 0) and (not lComputeIntercept) then //only compute intercept model if requested + inc(DropCond); + goto 123; + + end; + //finally - results + + //ResultsForm.Memo1.lines.add (inttostr(j)+' cases have Y=0, '+inttostr(n-j)+' cases have Y=1'); + if lComputeIntercept then + J := 0 + else + J := 1; + for i := J to (k-1) do begin + lZVals^[i] := abs(2*(finalloglik^[i]-finalloglik^[k])); + //find direction of effect - does a larger value of the IV predict more zeros or ones + lZVals^[i] := pNormalInv(ChiSq(lZVals^[i],1)); + //we have now computed a Z scores - but Chi is one tailed, so all Z > 0... lets check direction + Sumy0 := 0; + Sumy1 := 0; + for iter := 1 to n do begin + if y[iter,1] = 0 then + Sumy0 := Sumy0 + x.M[i+1,iter] //+1: M indexed from 1, ZVal indexed from 0 + else + Sumy1 := Sumy1 + x.M[i+1,iter]; //+1 M indexed from 1 + end; + //compute means + Sumy1 := Sumy1/sumy; + Sumy0 := Sumy0/(n-sumy); + if Sumy0 < Sumy1 then //negative z-scores: damage here predicts performance is BETTER + lZVals^[i] := -lZVals^[i]; + end; + (*if lComputeIntercept then //intercept is the 0th value + lChiVals[0] := abs(2*(finalloglik[0]-finalloglik[k])); + for i := 1 to (k-1) do //k-1 as this is indexed from 0 + lChiVals[i] := abs(2*(finalloglik[i]-finalloglik[k])); *) + +666: +end; + +//FirthAnalyzeNoThread (lnCond,lnCrit, lnPermute,1,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg); + +procedure FirthAnalyzeNoThread(lnCond, lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); +//calls logistf (yin,xin: SingleP; var lChivals: SingleP0; numSubj,numCond: integer); +label +666; +const + knPrevPattern = 10; +var + + + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lObs: Bytep; + lPrevZVals: array [1..knPrevPattern] of SingleP0; + lZVals: SingleP0; + lPatternPos,lC,lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnCritLocal,n,k: integer; +begin //statthread + + lnCritLocal := lnCrit; + if lnCritLocal < 1 then + lnCritLocal := 1; + Getmem(lObs,lImagesCount*sizeof(byte)); + Getmem(lZVals,(lnCond+1)*sizeof(single)); + for lPos := 1 to knPrevPattern do + Getmem(lPrevZVals[lPos],(lnCond+1)*sizeof(single)); + n := lImagesCount; + k := lnCond + 1; + y := TMatrix.Create(n,1); + GetMem(finalloglik,(k+1)*sizeof(single));//finalloglik := TVector.Create(k+1); + x := TMatrix.Create (k, n); +betak:=TMatrix.Create(1,k); +covs:=TMatrix.Create(k,k); +delta:=TMatrix.Create(1,k); +deltahalfs:=TMatrix.Create(1,k); +deltat:=TMatrix.Create(k,1); +Fisher:=TMatrix.Create(k,k); +H:=TMatrix.Create(n,n); +HPrime:=TMatrix.Create(n,k); +negx:=TMatrix.Create(k,n); +pi:=TMatrix.Create(n,1); +ustar:=TMatrix.Create(n,1); +ustarmat:=TMatrix.create(k,1); +W:=TMatrix.Create(n,n); +xbeta:=TMatrix.Create(1,n); +XW2:=TMatrix.Create(k,n); +//XWPrime:=TMatrix.Create(k,n); +XWPrime:=TMatrix.Create(n,k); +XXcovs:=TMatrix.Create(k-1,k-1); +XXFisher:=TMatrix.Create(k-1,k-1); +XXx:=TMatrix.Create(k-1,n); +XXXW2:=TMatrix.Create(k-1,n); +//XXXWPrime:=TMatrix.Create(k-1,n); +XXXWPrime := TMatrix.Create ( n, k-1); +KxKA := TMatrix.Create(k,k); +KxKB := TMatrix.Create(k,k); +Kvec := TVector.Create(k); +Kveci := TVectori.Create(k); +KxKA1 := TMatrix.Create(k-1,k-1); +KxKB1 := TMatrix.Create(k-1,k-1); +Kvec1 := TVector.Create(k-1); +Kveci1 := TVectori.Create(k-1); + + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + + for lPos := 1 to lImagesCount do begin + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] = 0 then begin + //no lesion + y[lPos,1] := 0; + lObs^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lObs^[lPos] := 1; + y[lPos,1] := 1; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCritLocal) and (lnLesion < lImagesCount) then begin + lPattern := SetOrderX (lObs,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin + inc(gnVoxTestedRA[lThread]); + //logistfx(lObs,lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lPrevZvals[lPos]^[lC]; + end else begin //new pattern - need to compute + inc(gnVoxTestedRA[lThread]); + logistfx(lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lZvals^[lC]; + lPrevPatternRA[lPatternPos] := lPattern; + for lC := 1 to lnCond do + lPrevZVals[lPatternPos]^[lC] := lZvals^[lC]; + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + + end; //new pattern + end; //nlesion > nCritical + + end; //for each voxel + //gMat := false; +666: + freemem(lObs); + for lPos := 1 to knPrevPattern do + freemem(lPrevZVals[lPos]); + freemem(lZVals); + +y.free; +x.free; +betak.free; +covs.free; +delta.free; +deltahalfs.free; +deltat.free; +Fisher.free; +H.free; +HPrime.free; +negx.free; +pi.free; +ustar.free; +ustarmat.Free; +W.free; +xbeta.free; +XW2.free; +XWPrime.free; +XXcovs.free; +XXFisher.free; +XXx.free; +XXXW2.free; +XXXWPrime.free; +KxKA.free; +KxKB.free; +Kvec.free; +Kveci.free; +KxKA1.free; +KxKB1.free; +Kvec1.free; +Kveci1.free; + + freemem(finalloglik); + +end; + +end. + \ No newline at end of file diff --git a/npm_precl/firthThds.pas b/npm_precl/firthThds.pas new file mode 100755 index 0000000..bc865c9 --- /dev/null +++ b/npm_precl/firthThds.pas @@ -0,0 +1,639 @@ +unit firthThds; +//Unit for running penalized multiple logistic regression +//creates multiple threads +//Requires firth +interface +uses + ComCtrls,Classes, Graphics, ExtCtrls, define_types,{stats,}StatThdsUtil,lesion_pattern,Mat,Math,Distr,Vector; + +type + + TMultiRegThread = class(TThread) + private + finalloglik: SingleP0; + KxKA1,KxKB1,KxKA,KxKB :TMatrix; +Kvec,Kvec1 : TVector; +Kveci,kVeci1 : TVectori; + + + betak,xbeta,y,pi,ustar, + XXx,XXXW2,XXFisher,XXcovs,XXXWPrime, + deltahalfs,deltat,delta,covs,x,Fisher,XW2,W,XWprime,Hprime,H,ustarmat,negx: TMatrix; + lBarX: TProgressBar; + lnCondx,lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx : integer; + lPlankImgx: byteP;lOutImgMnx,lSymptomRAx: SingleP; + lOutImgX: SingleRAp; + //lBarX: TProgressBar; + procedure DoVisualSwap; + protected + procedure Execute; override; + procedure VisualProg(lPos: Integer); + procedure Analyze(lnCond,lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP; lOutImg: SingleRAp); virtual; abstract; + public + constructor Create(lBar: TProgressBar; lnCond,lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: byteP;lOutImgMn,lSymptomRA: SingleP; lOutImg: SingleRAp); + end; + + TFirthThreadStat = class(TMultiRegThread ) + protected + procedure Analyze(lnCond,lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP; lOutImg: SingleRAp); override; + procedure logistfx (xin: SingleP; var lZvals: SingleP0; numSubj,numCond: integer; lComputeIntercept: boolean); + + end; + + +implementation + +procedure TMultiRegThread .DoVisualSwap; +begin + lBarX.Position := lBarPosX; +end; + +procedure TMultiRegThread.VisualProg(lPos: Integer); +begin + lBarPosX := lPos; + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} +end; + +constructor TMultiRegThread.Create(lBar: TProgressBar; lnCond,lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); +begin + lBarX := lBar; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgX := lOutImg; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + lnCondX := lnCond; + FreeOnTerminate := True; + inherited Create(False); +end; + +{ The Execute method is called when the thread starts } + +procedure TMultiRegThread .Execute; +begin + Analyze(lnCondX,lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lPlankImgX,lOutImgMnx,lSymptomRAx,lOutImgX); +end; + + +procedure TFirthThreadStat.logistfx (xin: SingleP; var lZvals: SingleP0; numSubj,numCond: integer; lComputeIntercept: boolean); +//todo zero output incase exit +//yin = 1..numSubj binary 0/1 values +//xin = numSubj*numCond predictors +//Chivals = 0..numCond p-values - the 0th Khi-value is the intercept +// [0th value will not be computed if ; lComputeIntercept= false] +label + 123,666; +const + maxit = 25; + maxhs = 5; + epsilon = 0.0001; + maxstep = 10; +var + SumY0,SumY1,mx, beta0,loglik,loglikold: double; + sumy, n, i,j, k, iter,halfs,lCond,dropCond: integer; + variability,firth: boolean; +procedure crossprodustar; +var + inc,row: integer; +begin + for row := 1 to k do begin + ustarmat[row,1] := 0; + for inc := 1 to ustar.r do + ustarmat[row,1] := ustarmat[row,1] + (x[row,inc]*ustar[inc,1]); + end; +end; +procedure Diag2Vec; +var + inc: integer; +begin + for inc := 1 to pi.r do + ustar[inc,1] := ustar[inc,1]+ H[inc,inc]*(0.5-pi[inc,1]); +end; //nested DiagP2 +procedure DiagP2 (var W, P: TMatrix); +var + inc: integer; +begin + W.Zero; + for inc := 1 to P.r do + W[inc,inc] := Power((P[inc,1] * (1-P[inc,1])),0.5) ; +end; //nested DiagP2 +procedure ComputeFisher; +begin + DiagP2(W,pi); + XW2.mult(x,W); + //XWPrime.copy( XW2); + //XWPrime.transpose; + XWPrime.transpose(XW2); + Fisher.mult(XW2,XWPrime); + covs.copy( Fisher); + covs.Invert2(KxKA,KxKB,Kvec,Kveci) +end; //nested computeFisher + +procedure computedropdelta; +var + jinc,iinc,ii,jj: integer; +begin + DiagP2(W,pi); + XXXW2.mult(XXx,W); + //XXXWPrime.copy( XXXW2); + //XXXWPrime.transpose; + XXXWPrime.transpose(XXXW2); + XXFisher.mult(XXXW2,XXXWPrime); + XXcovs.copy( XXFisher); + //XXcovs.Invert; + XXcovs.Invert2(KxKA1,KxKB1,Kvec1,Kveci1); + covs.Zero; + ii := 0; + for iinc := 1 to (k) do begin + if iinc <> (dropCond+1) then begin //leave the specified column zeros... + inc(ii); + jj := 0; + for jinc := 1 to (k) do begin + if jinc <> (dropCond+1) then begin + inc(jj); + covs[iinc,jinc] := xxCovs[ii,jj]; + end; + end; + end; + end; +end; +function firthpenalty: double; +begin + ComputeFisher; + //result := 0.5 * ln(abs(Fisher.det)); + result := 0.5 * ln(abs(Fisher.Det2(KxKA,kVeci,kVec))); +end; //nested firthpenalty +function ComputeLogLik: double; +var + inc: integer; +begin + xbeta.mult(betak,negx); + for inc := 1 to n do + pi[inc,1] := (1/(1 + exp( xbeta[inc,1]))); + result := 0; + for inc := 1 to n do + if y[inc,1] = 1 then + result := result+ln(pi[inc,1]); + for inc := 1 to n do + if y[inc,1] = 0 then + result := result+ln(1-pi[inc,1]); + if firth then + result := result + firthpenalty; +end;//nested ComputeLogLik +begin + for i := 0 to (numCond) do + lZVals^[i] := 0; // + if (numSubj < 2) or (numCond < 1) then + exit; + //ensure there is some variability in the input data... + variability := false; + i := 1; + repeat + inc(i); + if xin^[i] <> xin^[1] then + variability := true; + until (i= (numSubj*numCond)) or (variability); + if not variability then + exit; //no variance in the regressors... + variability := false; + i := 1; + repeat + inc(i); + if y[i,1] <> y[1,1] then + variability := true; + until (i= (numSubj)) or (variability); + if not variability then + exit; //no variance in the dependent variable... + dropCond := -1; //initially compute full model, then compute effect of removing individual conditions + firth := true; + n := numSubj; + k := numCond + 1; + //get memory + //beta := TMatrix.Create(n,1); + //design our model + //first row = 1: ell samples have equal weight + for i := 1 to n do + x.M[1,i] := 1; + //next load model into x + iter := 0; + for j := 2 to k do + for i := 1 to n do begin + inc(iter); + x.M[j,i] := xin^[iter]; + end; + //WriteMatrix('Observations',y); + //WriteMatrix('Model',x); + //negx is just sing-swapped - we will generate this as we use it a lot... + for j := 1 to k do + for i := 1 to n do begin + negx.M[j,i] := -x.M[j,i]; + end; + //now start computations + sumy := 0; + for i := 1 to n do + sumy := sumy + round(y[i,1]); + if (sumy <= 0) or (sumy >= n) then begin + //serious error: no variability. This should have been detected earlier in the procedure when yin was tested for variability + goto 666; + end; + beta0 := ln((sumy/n)/(1 - sumy/n));//initial estimate +123: //go here for each dropcond + if DropCond >= 0 then begin + betak.Ones; + betak.mult( 0) //start with a null model... does not really make sense + end else begin + betak.zero; + betak[1,1] := (beta0); + end; + iter := 0; + if DropCond >= 0 then begin //drop one of the factors... + if dropCond <> 0 then begin//include intercept + for i := 1 to n do + XXx.M[1,i] := 1; + lCond := 1; + end else + lCond := 0; + for j := 1 to NumCond do begin + if j <> DropCond then begin + inc(lCond); + for i := 1 to n do + XXx.M[lCond,i] := x.M[j+1,i]; + end; //if j <> dropCond + end; + end;//if lDropCond >= 0 + loglik := ComputeLogLik; + repeat + inc(iter); + ComputeFisher; + HPrime.mult(XWPrime,covs); + H.mult(HPrime,XW2); + //WriteMatrix(covs); + ustar.Sub(y,pi); + if firth then + Diag2Vec; + crossprodustar; + if dropCond >= 0 then // model with dropped factor + computedropdelta; + deltat.mult(covs,ustarmat); + delta.transpose(deltat); + mx := delta.MatAbsMax/MaxStep; + if mx > 1 then + delta.mult(mx);//scale delta + betak.add(delta); + loglikold := loglik; + halfs := 1; + while halfs <= maxhs do begin // Half-Steps + //fx(iter,halfs,loglik); + loglik := ComputeLogLik; + deltahalfs.mult(delta,power(2,-halfs)); + betak.sub(deltahalfs); + if (loglik > loglikold) then + break; + inc(halfs); + end; + if delta.MatAbsMax <= epsilon then break; + until (iter >= maxit); + //fx(DropCond,loglik); + //done with this model - record model fit + if DropCond < 0 then + finalloglik^[k] := loglik //full model + else begin + finalloglik^[DropCond] := loglik; //model with a factor removed + end; + if DropCond < numCond then begin + inc(DropCond); + if (DropCond = 0) and (not lComputeIntercept) then //only compute intercept model if requested + inc(DropCond); + goto 123; + + end; + //finally - results + + //ResultsForm.Memo1.lines.add (inttostr(j)+' cases have Y=0, '+inttostr(n-j)+' cases have Y=1'); + if lComputeIntercept then + J := 0 + else + J := 1; + for i := J to (k-1) do begin + lZVals^[i] := abs(2*(finalloglik^[i]-finalloglik^[k])); + //find direction of effect - does a larger value of the IV predict more zeros or ones + lZVals^[i] := pNormalInv(ChiSq(lZVals^[i],1)); + //we have now computed a Z scores - but Chi is one tailed, so all Z > 0... lets check direction + Sumy0 := 0; + Sumy1 := 0; + for iter := 1 to n do begin + if y[iter,1] = 0 then + Sumy0 := Sumy0 + x.M[i+1,iter] //+1: M indexed from 1, ZVal indexed from 0 + else + Sumy1 := Sumy1 + x.M[i+1,iter]; //+1 M indexed from 1 + end; + //compute means + Sumy1 := Sumy1/sumy; + Sumy0 := Sumy0/(n-sumy); + if Sumy0 < Sumy1 then //negative z-scores: damage here predicts performance is BETTER + lZVals^[i] := -lZVals^[i]; + end; + (*if lComputeIntercept then //intercept is the 0th value + lChiVals[0] := abs(2*(finalloglik[0]-finalloglik[k])); + for i := 1 to (k-1) do //k-1 as this is indexed from 0 + lChiVals[i] := abs(2*(finalloglik[i]-finalloglik[k])); *) + +666: +end; + +{Firth penalized logisitic regression} +procedure TFirthThreadStat.Analyze(lnCond, lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg: bytep;lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); +//calls logistf (yin,xin: SingleP; var lChivals: SingleP0; numSubj,numCond: integer); +label +666; +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lObs: Bytep; + lPrevZVals: array [1..knPrevPattern] of SingleP0; + lZVals: SingleP0; + lPatternPos,lC,lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnCritLocal,n,k: integer; +begin //statthread + + lnCritLocal := lnCrit; + if lnCritLocal < 1 then + lnCritLocal := 1; + Getmem(lObs,lImagesCount*sizeof(byte)); + Getmem(lZVals,(lnCond+1)*sizeof(single)); + for lPos := 1 to knPrevPattern do + Getmem(lPrevZVals[lPos],(lnCond+1)*sizeof(single)); + n := lImagesCount; + k := lnCond + 1; + y := TMatrix.Create(n,1); + GetMem(finalloglik,(k+1)*sizeof(single));//finalloglik := TVector.Create(k+1); + x := TMatrix.Create (k, n); +betak:=TMatrix.Create(1,k); +covs:=TMatrix.Create(k,k); +delta:=TMatrix.Create(1,k); +deltahalfs:=TMatrix.Create(1,k); +deltat:=TMatrix.Create(k,1); +Fisher:=TMatrix.Create(k,k); +H:=TMatrix.Create(n,n); +HPrime:=TMatrix.Create(n,k); +negx:=TMatrix.Create(k,n); +pi:=TMatrix.Create(n,1); +ustar:=TMatrix.Create(n,1); +ustarmat:=TMatrix.create(k,1); +W:=TMatrix.Create(n,n); +xbeta:=TMatrix.Create(1,n); +XW2:=TMatrix.Create(k,n); +//XWPrime:=TMatrix.Create(k,n); +XWPrime:=TMatrix.Create(n,k); +XXcovs:=TMatrix.Create(k-1,k-1); +XXFisher:=TMatrix.Create(k-1,k-1); +XXx:=TMatrix.Create(k-1,n); +XXXW2:=TMatrix.Create(k-1,n); +//XXXWPrime:=TMatrix.Create(k-1,n); +XXXWPrime := TMatrix.Create ( n, k-1); +KxKA := TMatrix.Create(k,k); +KxKB := TMatrix.Create(k,k); +Kvec := TVector.Create(k); +Kveci := TVectori.Create(k); +KxKA1 := TMatrix.Create(k-1,k-1); +KxKB1 := TMatrix.Create(k-1,k-1); +Kvec1 := TVector.Create(k-1); +Kveci1 := TVectori.Create(k-1); + + lPosPct := (lThreadEnd-lThreadStart) div 100; + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] = 0 then begin + //no lesion + y[lPos,1] := 0; + lObs^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lObs^[lPos] := 1; + y[lPos,1] := 1; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCritLocal) and (lnLesion < lImagesCount) then begin + lPattern := SetOrderX (lObs,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin + inc(gnVoxTestedRA[lThread]); + //logistf(lObs,lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lPrevZvals[lPos]^[lC]; + end else begin //new pattern - need to compute + inc(gnVoxTestedRA[lThread]); + logistfx(lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lZvals^[lC]; + lPrevPatternRA[lPatternPos] := lPattern; + for lC := 1 to lnCond do + lPrevZVals[lPatternPos]^[lC] := lZvals^[lC]; + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + + end; //new pattern + end; //nlesion > nCritical + end; //for each voxel + //gMat := false; +666: + freemem(lObs); + for lPos := 1 to knPrevPattern do + freemem(lPrevZVals[lPos]); + freemem(lZVals); + +y.free; +x.free; +betak.free; +covs.free; +delta.free; +deltahalfs.free; +deltat.free; +Fisher.free; +H.free; +HPrime.free; +negx.free; +pi.free; +ustar.free; +ustarmat.Free; +W.free; +xbeta.free; +XW2.free; +XWPrime.free; +XXcovs.free; +XXFisher.free; +XXx.free; +XXXW2.free; +XXXWPrime.free; +KxKA.free; +KxKB.free; +Kvec.free; +Kveci.free; +KxKA1.free; +KxKB1.free; +Kvec1.free; +Kveci1.free; + + freemem(finalloglik); + +end; (* + +{Firth penalized logisitic regression} +procedure TFirthThreadStat .Analyze(lnCond, lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount : integer; lPlankImg,lOutImgMn,lSymptomRA: SingleP;lOutImg: SingleRAp); +//calls logistf (yin,xin: SingleP; var lChivals: SingleP0; numSubj,numCond: integer); +var + lPattern,lPrevPattern: TLesionPattern; + lObs: Singlep; + lZVals,lPrevZVals: SingleP0; + lC,lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnCritLocal,n,k: integer; +begin //statthread + lnCritLocal := lnCrit; + if lnCritLocal < 1 then + lnCritLocal := 1; + Getmem(lObs,lImagesCount*sizeof(single)); + Getmem(lZVals,(lnCond+1)*sizeof(single)); + Getmem(lPrevZVals,(lnCond+1)*sizeof(single)); + n := lImagesCount; + k := lnCond + 1; + y := TMatrix.Create(n,1); + GetMem(finalloglik,(k+1)*sizeof(single));//finalloglik := TVector.Create(k+1); + x := TMatrix.Create (k, n); +betak:=TMatrix.Create(1,k); +covs:=TMatrix.Create(k,k); +delta:=TMatrix.Create(1,k); +deltahalfs:=TMatrix.Create(1,k); +deltat:=TMatrix.Create(k,1); +Fisher:=TMatrix.Create(k,k); +H:=TMatrix.Create(n,n); +HPrime:=TMatrix.Create(n,k); +negx:=TMatrix.Create(k,n); +pi:=TMatrix.Create(n,1); +ustar:=TMatrix.Create(n,1); +ustarmat:=TMatrix.create(k,1); +W:=TMatrix.Create(n,n); +xbeta:=TMatrix.Create(1,n); +XW2:=TMatrix.Create(k,n); +//XWPrime:=TMatrix.Create(k,n); +XWPrime:=TMatrix.Create(n,k); +XXcovs:=TMatrix.Create(k-1,k-1); +XXFisher:=TMatrix.Create(k-1,k-1); +XXx:=TMatrix.Create(k-1,n); +XXXW2:=TMatrix.Create(k-1,n); +//XXXWPrime:=TMatrix.Create(k-1,n); +XXXWPrime := TMatrix.Create ( n, k-1); +KxKA := TMatrix.Create(k,k); +KxKB := TMatrix.Create(k,k); +Kvec := TVector.Create(k); +Kveci := TVectori.Create(k); +KxKA1 := TMatrix.Create(k-1,k-1); +KxKB1 := TMatrix.Create(k-1,k-1); +Kvec1 := TVector.Create(k-1); +Kveci1 := TVectori.Create(k-1); + //gMat := true; + lPosPct := (lThreadEnd-lThreadStart) div 100; + lPrevPattern := EmptyOrder; + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + y[lPos,1] := 0; + lObs[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lObs[lPos] := 1; + y[lPos,1] := 1; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCritLocal) and (lnLesion < lImagesCount) then begin + lPattern := SetOrder (lObs,lImagesCount); + if SameOrder(lPattern,lPrevPattern,lImagesCount) then begin + inc(gnVoxTestedRA[lThread]); + //logistf(lObs,lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lPrevZvals[lC]; + end else begin //new pattern - need to compute + inc(gnVoxTestedRA[lThread]); + logistfx(lSymptomRA, lZvals, lImagesCount,lnCond,false); + for lC := 1 to lnCond do + lOutImg^[lC]^[lPos2Offset] := lZvals[lC]; + end; + lPrevPattern := lPattern; + for lC := 1 to lnCond do + lPrevZVals[lC] := lZvals[lC]; + end; + end; //for each voxel + //gMat := false; + freemem(lObs); + freemem(lPrevZVals); + freemem(lZVals); +y.free; +x.free; +betak.free; +covs.free; +delta.free; +deltahalfs.free; +deltat.free; +Fisher.free; +H.free; +HPrime.free; +negx.free; +pi.free; +ustar.free; +ustarmat.Free; +W.free; +xbeta.free; +XW2.free; +XWPrime.free; +XXcovs.free; +XXFisher.free; +XXx.free; +XXXW2.free; +XXXWPrime.free; +KxKA.free; +KxKB.free; +Kvec.free; +Kveci.free; +KxKA1.free; +KxKB1.free; +Kvec1.free; +Kveci1.free; + + freemem(finalloglik); + +end; (**) + + + + + + +end. diff --git a/npm_precl/fpc-res.or b/npm_precl/fpc-res.or new file mode 100755 index 0000000..9675a09 Binary files /dev/null and b/npm_precl/fpc-res.or differ diff --git a/npm_precl/fpc-res.res b/npm_precl/fpc-res.res new file mode 100755 index 0000000..e521788 Binary files /dev/null and b/npm_precl/fpc-res.res differ diff --git a/npm_precl/hdr.pas b/npm_precl/hdr.pas new file mode 100755 index 0000000..76701b2 --- /dev/null +++ b/npm_precl/hdr.pas @@ -0,0 +1,579 @@ +unit hdr; +interface +{$H+} +uses nifti_hdr,define_types,classes; + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TniftiHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +procedure MakeHdr (var lBGHdr,lStatHdr: TniftiHdr); +function NIFTIhdr_SaveHdrImg (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2,lSingleFile: boolean;var lImg: SingleP; lnVol: integer): boolean; +function NIFTIhdr_SaveHdrImg8 (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2,lSingleFile: boolean;var lImg: ByteP; lnVol: integer): boolean; + +function Files4D (lFilename: string): boolean; +function Vol4D (lFilename: string): integer; +function FileExists4D (lFilename: string): boolean; +function Filename4D(lFilename: string): string; +function FilenameVol4D (lFilename: string; var lBaseName: string; var lVol: integer): boolean; +function NIFTIhdr_HdrVolumes (lFilenameIn: string): integer; +function BPP (lDataType: integer): integer; +function CreateDecompressed4D(var lImageNames: TStrings): string; +function CheckVoxels(var lHdrNameIn : string; lMaskVoxels, lImageNumber: integer):boolean; +//function CheckVoxelsGroupX(var lG: TStrings; lMaskVoxels: integer):boolean; +function CheckVoxelsGroupX(var lG: TStrings; lMaskHdr: TMRIcroHdr): boolean; +//function CheckVoxelsGroupY(var lG: TStrings):boolean; + +procedure DeleteDecompressed4D(lDecomName: string); +implementation +uses +{$IFDEF FPC} gzio2,Controls, + +{$ELSE} {gzio,ZLib,}DiskSpaceKludge,gziod,{$ENDIF} +{$IFNDEF UNIX}Windows, {$ENDIF} + + Dialogs ,SysUtils,StatThdsUtil,npmform; +//define_types,GraphicsMathLibrary; +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} +procedure MsgX (lStr: string); +begin + //msgx +end; + +procedure DeleteDecompressed4D(lDecomName: string); +begin + if lDecomName = '' then + exit; + if not fileexists(lDecomName) then + exit; + sysutils.deletefile(lDecomName); +end; + +function CheckVoxels(var lHdrNameIn : string; lMaskVoxels, lImageNumber: integer):boolean; +var + lHdr: TMRIcroHdr; + lHdrName: string; + lVox: integer; +begin + result := false; + lHdrName := Filename4D(lHdrNameIn); + if not NIFTIhdr_LoadHdr(lHdrName,lHdr) then begin + MainForm.NPMmsg('Unable to load image '+lHdrName); + exit; + end; + lVox := ComputeImageDataBytes8bpp(lHdr); + if lVox <> lMaskVoxels then begin + MainForm.NPMmsg('Voxels differ for '+lHdrName+' expected '+inttostr(lMaskVoxels)+' described '+inttostr(lVox)); + exit; + end; + (*if (lHdr.NIFTIhdr.bitpix <> 8) and (lHdr.NIFTIhdr.datatype <> kDT_FLOAT) and (lHdr.NIFTIhdr.datatype <> kDT_SIGNED_INT) then begin + showmessage('Error: This software can only read uncompressed images that are either 8-bit integer or 32-bit real precision.'); + exit; + end; //beta *) + if UpCaseExt(lHdrName) = '.HDR' then + lHdrName := changefileext(lHdrName,'.img'); + if (not GzExt(lHdrName) ) and (FSize(lHdrName) < lMaskVoxels) then begin + showmessage('The uncompressed image data should be at least '+inttostr(lMaskVoxels)+' bytes. '+lHdrName); + exit; + end; + result := true; + //gBitPixRA[lImageNumber] := lHdr.NIFTIhdr.bitpix; + gDataTypeRA[lImageNumber] := lHdr.NIFTIhdr.datatype; + gOffsetRA[lImageNumber] := lHdr.NIFTIhdr.vox_offset; + gScaleRA[lImageNumber] := lHdr.NIFTIhdr.scl_slope; + gInterceptRA[lImageNumber] := lHdr.NIFTIhdr.scl_inter; +end; + +(*function CheckVoxelsGroup(var lG: TStrings; lMaskVoxels: integer):boolean; +var + lC: integer; + lHdrName : string; +begin + result := false; + if lG.count < 1 then exit; + for lC := 1 to lG.count do begin + lHdrName:= lG[lC-1]; + result := CheckVoxels(lHdrName, lMaskVoxels,lC); + end; +end;*) +(*function CheckVoxelsGroup(var lG: TStrings; lMaskVoxels: integer):boolean; +var + lC: integer; + lHdrName : string; +begin + result := false; + if lG.count < 1 then exit; + + for lC := 1 to lG.count do begin + lHdrName:= lG[lC-1]; + if not CheckVoxels(lHdrName, lMaskVoxels,lC) then begin + if not fileexists (lHdrName) then + MainForm.NPMmsg('File not found "'+lHdrName+'"') + + else + MainForm.NPMmsg('Problem with "'+lHdrName+'" expected '+inttostr(lMaskVoxels)); + exit; + end; + end; + result := true; +end;*) +function SameTransform (A,B:TNIFTIhdr): boolean; +var + lDim: integer; +begin + result := false; + for lDim := 0 to 3 do begin + if A.srow_x[lDim] <> B.srow_x[lDim] then + exit; + if A.srow_y[lDim] <> B.srow_y[lDim] then + exit; + if A.srow_z[lDim] <> B.srow_z[lDim] then + exit; + end; + result := true; +end; + +function TransformTxt (A:TNIFTIhdr): string; +var + lDim: integer; +begin + result := '['; + for lDim := 0 to 3 do + result := result + ' '+floattostr(A.srow_x[lDim]); + result := result + ';'; + for lDim := 0 to 3 do + result := result + ' '+floattostr(A.srow_y[lDim]); + result := result + ';'; + for lDim := 0 to 3 do + result := result + ' '+floattostr(A.srow_z[lDim]); + result := result + ']'; +end; + +function CheckVoxelsX(var lHdrNameIn : string; lMaskHdr: TMRIcroHdr; lImageNumber: integer):boolean; +var + lHdr: TMRIcroHdr; + lHdrName: string; + lDim: integer; +begin + result := false; + lHdrName := Filename4D(lHdrNameIn); + if not NIFTIhdr_LoadHdr(lHdrName,lHdr) then begin + MainForm.NPMmsg('Unable to load image '+lHdrName+' Possible solution: make sure VAL file and images are in the same folder'); + exit; + end; + (*lVox := ComputeImageDataBytes8bpp(lHdr); + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if lVox <> lMaskVoxels then begin + MainForm.NPMmsg('Voxels differ for '+lHdrName+' expected '+inttostr(lMaskVoxels)+' described '+inttostr(lVox)); + exit; + end; *) + for lDim := 1 to 3 do begin + if (lHdr.NIFTIhdr.dim[lDim] <> lMaskHdr.NIFTIhdr.dim[lDim]) then begin + MainForm.NPMmsg('Dimension '+inttostr(lDim)+' of '+lHdrName+' does not match '+lMaskHdr.HdrFileName); + exit; + end; + end; + if (not lHdr.NIfTItransform) then + MainForm.NPMmsg('Warning: no spatial transform for '+lHdrName+' (Analyze not NIfTI). Please ensure images are coregistered.') + else if (not lMaskHdr.NIfTItransform) then + MainForm.NPMmsg('Warning: no spatial transform for '+lMaskHdr.HdrFileName+' (Analyze not NIfTI). Please ensure images are coregistered.') + else begin + if not SameTransform (lHdr.NIFTIhdr, lMaskHdr.NIFTIhdr) then begin + MainForm.NPMmsg('Warning: spatial transforms differ for '+lHdrName+' and '+lMaskHdr.HdrFileName); + MainForm.NPMmsg(TransformTxt(lHdr.NIFTIhdr)+' <> '+ TransformTxt(lMaskHdr.NIFTIhdr)); + end; + end; + (*if (lHdr.NIFTIhdr.bitpix <> 8) and (lHdr.NIFTIhdr.datatype <> kDT_FLOAT) and (lHdr.NIFTIhdr.datatype <> kDT_SIGNED_INT) then begin + showmessage('Error: This software can only read uncompressed images that are either 8-bit integer or 32-bit real precision.'); + exit; + end; //beta *) + if UpCaseExt(lHdrName) = '.HDR' then + lHdrName := changefileext(lHdrName,'.img'); + if (not GzExt(lHdrName) ) and (FSize(lHdrName) < (lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]*lHdr.NIFTIhdr.dim[3])) then begin + showmessage('The file size appears too small '+lHdrName); + exit; + end; + result := true; + //gBitPixRA[lImageNumber] := lHdr.NIFTIhdr.bitpix; + gDataTypeRA[lImageNumber] := lHdr.NIFTIhdr.datatype; + gOffsetRA[lImageNumber] := lHdr.NIFTIhdr.vox_offset; + gScaleRA[lImageNumber] := lHdr.NIFTIhdr.scl_slope; + gInterceptRA[lImageNumber] := lHdr.NIFTIhdr.scl_inter; +end; + +function CheckVoxelsGroupX(var lG: TStrings; lMaskHdr: TMRIcroHdr):boolean; +var + lC: integer; + lHdrName : string; +begin + result := false; + if lG.count < 1 then exit; + + for lC := 1 to lG.count do begin + lHdrName:= lG[lC-1]; + if not CheckVoxelsX(lHdrName, lMaskHdr,lC) then begin + if not fileexists (lHdrName) then + MainForm.NPMmsg('File not found "'+lHdrName+'". Possible solution: make sure VAL file and images are in the same folder') + + else + MainForm.NPMmsg('Problem with "'+lHdrName); + exit; + end; + end; + result := true; +end; + +(*function CheckVoxelsGroupY(var lG: TStrings):boolean; +var + lMaskHdr: TMRIcroHdr; + lS: string; +begin + result := false; + if lG.count < 1 then exit; + lS := lG[0]; + if not NIFTIhdr_LoadHdr(lS,lMaskHdr) then begin + MainForm.NPMmsg('Unable to load image '+lS); + exit; + end; + result := CheckVoxelsGroupX(lG,lMaskHdr); +end; *) + +function BPP (lDataType: integer): integer; +begin + result := 0; + case lDataType of + kDT_UNSIGNED_CHAR: result := 1; + kDT_SIGNED_SHORT: result := 2; // signed short (16 bits/voxel) + kDT_SIGNED_INT : result := 4; // signed int (32 bits/voxel) + kDT_FLOAT : result := 4; // float (32 bits/voxel) + kDT_COMPLEX : result := 8; // complex (64 bits/voxel) + end; +end; + + +function NIFTIhdr_HdrVolumes (lFilenameIn: string): integer; +var + lFilename: string; + lHdr: TMRIcroHdr; +begin + result := 0; + lFilename := lFilenameIn; + if not NIFTIhdr_LoadHdr (lFilename, lHdr)then exit; + result := lHdr.niftiHdr.dim[4]; +end; + +function FileExists4D (lFilename: string): boolean; +var +lBaseName: string; var lVol: integer; +begin + FilenameVol4D (lFilename, lBasename,lVol); + result := fileexists(lBasename); +end; + +function FilenameVol4D (lFilename: string; var lBaseName: string; var lVol: integer): boolean; +//4D files end with the image index number c:\dir\filename:1 +//returns true if 4D file (with lVol = volume), otherwise returns false with lvol = 1 +var + lLen,lP: integer; + lNumStr: string; +begin + lVol := 1; + lBasename := lFilename; + result := false; + lLen := length(lFilename); + if lLen < 1 then exit; + lP := lLen; + lNumStr := ''; + while (lP > 0) and (lFilename[lP] in ['0'..'9']) do begin + lNumStr := lFilename[lP]+lNumStr; + dec(lP); + end; + //showmessage(lNumStr + '*'+lFilename[lP]); + if (lNumStr = '') or (lP < 2) or (lFilename[lP] <> ':') then exit; + lVol := strtoint(lNumStr); + lLen := lP -1; + lBasename := ''; + for lP := 1 to lLen do + lBasename := lBasename + lFilename[lP]; + result := true; +end; + +function Filename4D(lFilename: string): string; +var lVol: integer; +begin + FilenameVol4D (lFilename, result,lVol); +end; + +function Vol4D (lFilename: string): integer; +var +lBaseName: string; +begin + FilenameVol4D (lFilename, lBasename,result); +end; + +function Files4D (lFilename: string): boolean; +var +lBaseName: string; var lVol: integer; +begin + result := FilenameVol4D (lFilename, lBasename,lVol); +end; + +function CreateDecompressed4D(var lImageNames: TStrings): string; +//returns temp filename if all imagenames are a single compressed 4D datafile +//this means that a nii.gz file is only decompressed once, instead of once per volume*plank +var + lP: integer; + lFilename : string; +begin + result := ''; + if lImageNames.Count < 2 then + exit; + if not Files4D(lImageNames.Strings[0]) then exit; + lFilename := Filename4D(lImageNames.Strings[0]); + if not Fileexists(lFilename) then + exit; + if not GzExt(lFilename) then + exit; //not a decompressed file + //see if single 4D image + for lP := 2 to lImageNames.Count do + if not Files4D(lImageNames.Strings[lP-1]) then + exit; + for lP := 2 to lImageNames.Count do + if lFilename <> Filename4D(lImageNames.Strings[lP-1]) then + exit; + //find unique filename for extracted file + result := lFilename +'.nii'; + while fileexists(result) do //make sure we do not overwrite anything + result := lFilename +inttostr(random(9999))+'.nii'; + //unzip + Msgx('Decompressing 4D image '+lFilename+ ' -> '+result); + Gunzip(lFilename,result); + //set image names to point to uncompressed volume + for lP := 1 to lImageNames.Count do + lImageNames.Strings[lP-1] := result +':'+inttostr(Vol4D(lImageNames.Strings[lP-1]) ); +end; + + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TniftiHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +var lIntentNameLen,lPos: integer; + lStr: string; +begin + move(lBGHdr,lStatHdr,sizeof(TniftiHdr)); + with lStatHdr do begin + magic :=kNIFTI_MAGIC_SEPARATE_HDR; + bitpix := 32; //32-bit real data + datatype := kDT_FLOAT; + scl_slope:= 1; + scl_inter:= 0; + glmin := round(lMinIntensity); + glmax := round(lMaxIntensity); + intent_code := lIntent_Code;// kNIFTI_INTENT_ESTIMATE; + intent_p1 := lIntent_p1; + intent_p2 := lIntent_p2; + intent_p3 := lIntent_p3; + lIntentNameLen := length(lIntentName); + descrip[1] := 'N'; + descrip[2] := 'P'; + descrip[3] := 'M'; + if lIntent_code=kNIFTI_INTENT_TTEST then begin + descrip[4] := 't' ; + lStr := inttostr(trunc(lIntent_p1)); + for lPos := 1 to length (lStr) do + descrip[4+lPos] := lStr[lPos] ; + end else + descrip[4] := 'z'; + if lIntentNameLen > sizeof(intent_name) then + lIntentNameLen := sizeof(intent_name); + if lIntentNameLen > 0 then + for lPos := 1 to lIntentNameLen do + intent_name[lPos] := lIntentName[lPos]; + end; +end; + + + +procedure SaveAsVOIorNIFTIcore (var lFilename: string; var lNiftiHdr: TNIFTIHdr; var lImg: SingleP; lnVolIn,lImgBufferBPP: integer); +const + kImgOffset = 352; //header is 348 bytes, but 352 is divisible by 8... +var + lHdr: TNIFTIhdr; + lBuff: ByteP; + lF: File; + lCompressedFilename,lExt: string; + lnVol,lC,lFSize: integer; + lImgBuffer: ByteP; lImgBufferItems{, lImgBufferBPP}: integer; +begin + lnVol := lnVolIn; + move(lNiftiHdr,lHdr,sizeof(lHdr)); + lImgBufferItems := lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3]; + //lImgBufferBPP:= 4; + lImgBuffer := ByteP(lImg); + lExt := UpCaseExt(lFileName); + if DiskFreeEx(lFilename) < (kImgOffset+(lImgBufferItems*lImgBufferBPP*lnVol)) then begin + case MessageDlg('Very little space on the selected drive. Attempt to save to this disk?', mtConfirmation, + [mbYes, mbCancel], 0) of + {$IFDEF FPC}mrCancel: exit; {$ELSE} id_Cancel: exit;{$ENDIF} + end; //case + end; + if FileExistsEX(lFileName) then begin + case MessageDlg('Overwrite the file named '+lFileName+'?', mtConfirmation, + [mbYes, mbCancel], 0) of + {$IFDEF FPC}mrCancel: exit; {$ELSE} id_Cancel: exit;{$ENDIF} //requires Uses Controls + end; //case + end; //file exists + if (lExt='.VOI') then begin + lHdr.intent_name[1] := 'B';//Binary + lHdr.scl_slope := 1/kVOI8bit; + lHdr.scl_inter := 0; + end; + if lnVol < 2 then begin + lHdr.dim[0] := 3;//3D july2006 + lHdr.dim[4] := 1;//3D Aug 2007 + lnVol := 1; + end else begin + lHdr.dim[0] := 4;//3D july2006 + lHdr.dim[4] := lnVol;//3D july2006 + end; + (*if not (lImgBufferItems = (lHdr.dim[1]*lHdr.dim[2]*lHdr.dim[3])) then begin //july2006 + lHdr.sform_code := 1; + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + end;*) + if not IsNifTiMagic(lHdr) then begin + {lHdr.sform_code := 1; + WriteNiftiMatrix ( lHdr, //must match MAGMA in nifti_hdr + gBGImg.ScrnMM[1],0,0,(gBGImg.ScrnOri[1]-1)*-gBGImg.ScrnMM[1], + 0,gBGImg.ScrnMM[2],0,(gBGImg.ScrnOri[2]-1)*-gBGImg.ScrnMM[2], + 0,0,gBGImg.ScrnMM[3],(gBGImg.ScrnOri[3]-1)*-gBGImg.ScrnMM[3]); + } + end; + case lImgBufferBPP of + 4: begin + lHdr.bitpix := 32; + lHdr.datatype := kDT_FLOAT;//note 32-bit integers saved internally as 32-bit float + end; + 2: begin + lHdr.bitpix := 16; + lHdr.datatype := kDT_SIGNED_SHORT; + end; + 1: begin + lHdr.bitpix := 8; + lHdr.datatype := kDT_UNSIGNED_CHAR; + //lHdr.scl_inter := lHdr.WindowScaledMin; + //lHdr.scl_slope := (lHdr.WindowScaledMax-lHdr.WindowScaledMin) /255; + end; + else begin + showmessage('Error: Unsupported bytes per voxel: '+inttostr(lImgBufferBPP)); + exit; + end; + end; + if (lExt='.IMG') or (lExt ='.HDR') then begin + //done previously lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + lHdr.vox_offset := 0; + Filemode := 1; + //next write header data as .hdr + lFilename := changeFileExt(lFilename,'.hdr'); + AssignFile(lF, lFileName); + Rewrite(lF,sizeof(TNIFTIhdr)); + BlockWrite(lF,lHdr, 1); + CloseFile(lF); + //next write image data as .img + lFilename := changeFileExt(lFilename,'.img'); + AssignFile(lF, lFileName); {WIN} + Rewrite(lF,lImgBufferItems*lImgBufferBPP*lnVol); + BlockWrite(lF,lImgBuffer^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //separate header + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lHdr.vox_offset := kImgOffset;//352 bytes + lFSize := kImgOffset+(lImgBufferItems*lImgBufferBPP*lnVol); + getmem(lBuff,lFSize); + move(lHdr,lBuff^,sizeof(lHdr)); + //Next: NIfTI 1.1 requires bytes 349..352 set to zero when no XML information + lC := kImgOffset; + lBuff^[lC-3] := 0; + lBuff^[lC-2] := 0; + lBuff^[lC-1] := 0; + lBuff^[lC] := 0; + lC := kImgOffset+1; + move(lImgBuffer^[1],lBuff^[lC],lImgBufferItems*lImgBufferBPP*lnVol); + if (lExt='.NII') then begin + Filemode := 1; + AssignFile(lF, lFileName); + Rewrite(lF,lFSize); + BlockWrite(lF,lBuff^,1); + CloseFile(lF); + Filemode := 2; + exit; + end; //uncompressed + if (lExt<>'.VOI') then + lCompressedFilename := changefileextX(lFilename,'.nii.gz') + else + lCompressedFilename := lFilename; + //FX(lFSize); + + GZipBuffer(lCompressedFilename,lBuff,lFSize,false); + freemem(lBuff); +end; + + +procedure MakeHdr (var lBGHdr,lStatHdr: TniftiHdr); +//lIntent kNIFTI_INTENT_CHISQ lIntent_p1 = DOF +//lIntent kNIFTI_INTENT_ZSCORE no params +//lIntent kNIFTI_INTENT_TTEST lIntent_p1 = DOF +begin + move(lBGHdr,lStatHdr,sizeof(TniftiHdr)); + with lStatHdr do begin + magic :=kNIFTI_MAGIC_SEPARATE_HDR; + bitpix := 32; //32-bit real data + datatype := kDT_FLOAT; + scl_slope:= 1; + scl_inter:= 0; + descrip[1] := 'X';//can not be npm + end; +end; + +function NIFTIhdr_SaveHdrImg (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2,lSingleFile: boolean;var lImg: SingleP; lnVol: integer): boolean; +var + lOutNameMod: string; + lSPM2output: boolean; +begin + lOutNameMod := lFilename; + lOutNameMod := changefileextX(lOutNameMod,'.hdr'); + lSPM2output := lSPM2; + //fx(lHdr.srow_x[3],lHdr.srow_y[3],lHdr.srow_z[3]); + (*if not IsNifTiMagic(lHdr) then + lSPM2output := true;*) + if (lSingleFile) and (not lSPM2output) then begin + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lOutNameMod := changefileextX(lOutNameMod,'.nii.gz'); + end else if (not lSPM2output) then + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR + else //the nifti_hdr reader converts the Analyze to NIfTI, so we need to save as NIfTI with NPM + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR; + //lHdr.magic := 1984; + SaveAsVOIorNIFTIcore (lOutNameMod, lHdr, lImg,lnVol,4); +end; + +function NIFTIhdr_SaveHdrImg8 (var lFilename: string; var lHdr: TNIFTIHdr; lAllowOverwrite,lSPM2,lSingleFile: boolean;var lImg: ByteP; lnVol: integer): boolean; +var + lOutNameMod: string; +begin + lOutNameMod := lFilename; + if IsVOIExt (lOutNameMod) then begin + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + end else begin + lOutNameMod := changefileextX(lOutNameMod,'.hdr'); + if (lSingleFile) and (not lSPM2) then begin + lHdr.magic := kNIFTI_MAGIC_EMBEDDED_HDR; + lOutNameMod := changefileextX(lOutNameMod,'.nii.gz'); + end else if (not lSPM2) then + lHdr.magic := kNIFTI_MAGIC_SEPARATE_HDR + else + lHdr.magic := 1984; + end; + SaveAsVOIorNIFTIcore (lOutNameMod, lHdr, SingleP(lImg),lnVol,1); +end; + +end. diff --git a/npm_precl/lesion_pattern.pas b/npm_precl/lesion_pattern.pas new file mode 100755 index 0000000..bab15c1 --- /dev/null +++ b/npm_precl/lesion_pattern.pas @@ -0,0 +1,107 @@ +unit lesion_pattern; + +interface +uses define_types; + +Type + TLesionPattern = RECORD + lowest, lo,hi,highest : int64; + end; + +function SetOrderX (var lObs: Bytep; var lObsCount: integer): TLesionPattern ; +function SameOrder(lO1,lO2: TLesionPattern; lObsCount: integer): boolean; +function EmptyOrder: TLesionPattern; +procedure SetBit(lPos: integer; var lVal: TLesionPattern); + +const + kMaxBit = 63; + kMaxBitx2 = 2*kMaxBit; + kMaxBitx3 = 3*kMaxBit; + + kMaxObs = {126}kMaxBit*4; +implementation + + + +var + lPowerRA: array [1..kMaxBit] of int64; + + + +procedure SetBit(lPos: integer; var lVal: TLesionPattern); +begin + if (lPos <= kMaxBit) then + lVal.Lowest := lVal.Lowest + lPowerRA[lPos] + else if (lPos <= kMaxBitx2) then + lVal.Lo := lVal.Lo + lPowerRA[lPos-kMaxBit] + else if (lPos <= kMaxBitx3) then + lVal.Hi := lVal.Hi + lPowerRA[lPos-kMaxBitx2] + else + lVal.Highest := lVal.Highest + lPowerRA[lPos-kMaxBitx3]; +end; + +function EmptyOrder: TLesionPattern; +begin + result.lowest := 0; + result.lo := 0; + result.hi := 0; + result.highest := 0; +end; + +function SameOrder(lO1,lO2: TLesionPattern; lObsCount: integer): boolean; +begin + result := false; + if lObsCount > kMaxObs then + exit; + if (lO1.lowest = lo2.lowest) and (lO1.highest = lO2.highest) and (lO1.lo = lo2.lo) and (lO1.hi = lO2.hi) then + result := true + else + result := false; +end; + +(*function SetOrder (var lObs: Singlep; var lObsCount: integer): TLesionPattern ; +var + lPos: integer; +begin + result := EmptyOrder; + if ( lObsCount > kMaxObs) or (lObsCount < 1) then + exit; + for lPos := 1 to lObsCount do + if lObs[lPos] <> 0 then + SetBit(lPos,result); +end; + +function SetOrderI (var lObs: LongIntp; var lObsCount: integer): TLesionPattern ; +var + lPos: integer; +begin + result := EmptyOrder; + if ( lObsCount > kMaxObs) or (lObsCount < 1) then + exit; + for lPos := 1 to lObsCount do + if lObs[lPos] <> 0 then + SetBit(lPos,result); +end;*) + +function SetOrderX (var lObs: Bytep; var lObsCount: integer): TLesionPattern ; +var + lPos: integer; +begin + result := EmptyOrder; + if ( lObsCount > kMaxObs) or (lObsCount < 1) then + exit; + for lPos := 1 to (lObsCount) do + if lObs^[lPos] <> 0 then + SetBit(lPos,result); +end; + + + +var +lPowerPos: integer; +initialization + lPowerRA[1] := 1; + for lPowerPos := 2 to kMaxBit do + lPowerRA[lPowerPos] := lPowerRA[lPowerPos-1]*2; + +end. diff --git a/npm_precl/montecarlo.pas b/npm_precl/montecarlo.pas new file mode 100755 index 0000000..01b9b76 --- /dev/null +++ b/npm_precl/montecarlo.pas @@ -0,0 +1,197 @@ +unit montecarlo; +interface +{$H+} +{$DEFINE anacom} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes{$IFDEF anacom} ,anacom{$ENDIF}; + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); + +implementation + +uses npmform,filename,turbolesion; + +procedure RandomGroup(kSamplesPerTest: integer;lImageNames: TStrings;lSymptomRA: SingleP;var lPartImageNames: TStrings; var lPartSymptomRA: SingleP); +var + lTotal,lInc,lRand,lSwap: integer; + lRanOrder: longintP; +begin + lPartImageNames.Clear; + lTotal := lImageNames.Count; + if kSamplesPerTest > lTotal then begin + showmessage('Monte carlo error: population must be larger than sample size.'); + exit; + end; + Getmem(lRanOrder,lTotal*sizeof(longint)); + for lInc := 1 to lTotal do + lRanOrder^[lInc] := lInc; + for lInc := lTotal downto 2 do begin + lRand := Random(lInc)+1; + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc]; + lRanOrder^[lInc] := lSwap; + end; + for lInc := 1 to kSamplesPerTest do begin + lPartImageNames.Add(lImageNames.Strings[lRanOrder^[lInc]-1]);//indexed from 0 + lPartSymptomRA^[lInc] := lSymptomRA^[lRanOrder^[lInc]]; + end; + Freemem(lRanOrder); +end; + + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); +label + 666; +const + kSimSampleSize = 64; + knSim = 2; + kCrit = 3; + {$IFDEF anacom} + knControls = 64; + {$ENDIF} +var + lPrefs: TLDMPrefs ; + lSim,lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lPartImageNames,lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname,lOutNameSim: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA,lPartSymptomRA: singleP; + {$IFDEF anacom} + lnControlObservations: integer; + lControlSymptomRA: singleP; + {$ENDIF} +begin + //lBinomial := not odd( (Sender as tMenuItem).tag); + lPrefs.NULP := true{gNULP false}; + if not lBinomial then begin + lPrefs.BMtest := lbm;//BMmenu.checked; + lPrefs.Ttest := lttest;//ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.nCrit := kCrit; + lPrefs.nPermute := 0;//MainForm.ReadPermute;; + lPrefs.Run := 0;{0 except for montecarlo} + if (not lBinomial) and (not lTTest) and (not lBM) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPartImageNames := TStringList.Create; + getmem(lPartSymptomRA,kSimSampleSize*sizeof(single)); + {$IFDEF anacom} + lnControlObservations := knControls; + getmem(lControlSymptomRA,lnControlObservations*sizeof(single)); + for lSim := 1 to lnControlObservations do + lControlSymptomRA^[lSim] := 1000; + {$ENDIF} + //next, get 1st group + if not MainForm.GetValX(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit{,binom},lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) or (lnSubjAll < kSimSampleSize) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') [sample size is '+inttostr(kSimSampleSize)+']or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + //randomization loop.... + for lSim := 1 to knSim do begin + RandomGroup(kSimSampleSize, lImageNames,lSymptomRA, lPartImageNames, lPartSymptomRA); + lOutNameSim := AddIndexToFilename(lOutName,lSim); + lnCrit := kCrit; + MainForm.NPMMsgClear; + //Msg(GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to kSimSampleSize do + MainForm.NPMMsg (lPartImageNames.Strings[lSubj-1] + ' = '+realtostr(lPartSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(kSimSampleSize)); + if not CheckVoxelsGroup(lPartImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lPrefs.Run := lSim; + if lBinomial then + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim) + else begin + MainForm.ReportDescriptives(lPartSymptomRA,lnSubj); + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim); + {$IFDEF anacom} + AnacomLesionNPMAnalyze (lPartImageNames, lMaskHdr, lnCrit,lSim,lnControlObservations, lPartSymptomRA,lControlSymptomRA, lFactname,lOutNameSim,true,false); + {$ENDIF} + end; + end; //for each simulation... + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lPartImageNames.free; + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + freemem(lPartSymptomRA); + {$IFDEF anacom} + freemem(lControlSymptomRA); + {$ENDIF} + DeleteDecompressed4D(lTemp4D); +end; + + + +end. + + diff --git a/npm_precl/nifti_img.pas b/npm_precl/nifti_img.pas new file mode 100755 index 0000000..327b405 --- /dev/null +++ b/npm_precl/nifti_img.pas @@ -0,0 +1,426 @@ +unit nifti_img; +//only for Delphi - not Freepascal +//Unit for running multiple regression +interface +uses define_types,Classes,nifti_hdr,sysutils,dialogs +{$IFDEF FPC},gzio2 +{$ELSE} +,gziod +{$ENDIF} +; + +{$H+} +function LoadImg(lInName: string; lImgData: SingleP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; + +function LoadImg8(lInName: string; lImgData: ByteP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; + + +implementation +uses npmform,hdr; + +function LoadImg(lInName: string; lImgData: SingleP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +var + lvox_offset,lInc,lFSize,lP2: integer; + lFData: file; + lImgName: string; + lByteP: ByteP; + lSmallIntP: SmallIntP; + lV,lMin,lMax: single; +begin + result := false; + + if (lStart >= lEnd) or (lStart < 1) or (lEnd < 1) then begin + MainForm.NPMmsg('Error: LoadImg '+inttostr(lStart)+'>='+inttostr(lEnd)+' or zero'); + exit; + end; + if Files4D(lInName) then begin + lImgName := Filename4D(lInName); + lP2 := BPP (lDataType); + if lP2 = 0 then begin + Showmessage(lImgName +' is an unsupported file type'); + exit; + end; + lvox_offset := linvox_offset+ ((Vol4D(lInName)-1)* (lP2 * lVolVox)); + end else begin + lImgName := lInName; + lvox_offset := linvox_offset; + end; + if UpCaseExt(lImgName) = '.HDR' then + lImgName := changefileext(lImgName,'.img'); + lFSize := FSize(lImgName); + if (not GzExt(lImgName)) and (lFSize < (lEnd+ lvox_offset)) then begin + MainForm.NPMmsg('Error: LoadImg '+lImgName+' FSize = '+inttostr(lFSize)+' Expected '+inttostr(lEnd+ lvox_offset)); + exit; + end; + filemode := 0; + if GzExt(lImgName) then begin + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + UnGZip(lImgName,lByteP,lvox_offset+lStart-1,(lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + //getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(smallint)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(smallint)),((lEnd+1)-lStart)*sizeof(smallint)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*2)+1 ; + lImgData^[lRApos+lInc-1] := makesmallint(lByteP^[lP2],lByteP^[lP2+1]); + end; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + lByteP := ByteP(@lImgData^[lRApos]); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + + (*getmem(lByteP, ((lEnd+1)-lStart)*sizeof(single)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lImgData^[lRApos+lInc-1] := makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + //lImgData^[lRApos+lInc-1] := makesingle(lByteP^[lP2+3],lByteP^[lP2+2],lByteP^[lP2+1],lByteP^[lP2]); + end; + freemem(lByteP); *) + //test range + (*lINc := 1; + lMin := lImgData^[lRApos+lInc-1]; + lMax := lMin; + for lInc := 1 to ((lEnd+1)-lStart) do begin + lV := lImgData^[lRApos+lInc-1]; + if lV > lMax then + lMax := lV; + if lV < lMin then + lMin := lMax; + end; + MainForm.NPMmsg(inttostr(lvox_offset)+' '+realtostr(lMin,8)+' '+realtostr(lMax,8)); *) + + + //end + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := conv4r4i (lImgData^[lRApos+lInc-1]); + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do + if specialsingle(lImgData^[lRApos+lInc-1])then + lImgData^[lRApos+lInc-1] := 0; + end; + end else begin + showmessage(lImgName + ' is an unsupported compressed data type '+inttostr(lDataType)); + exit; + end; + end else begin + assignfile(lFdata,lImgName); + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + reset(lFdata,1); //12/2010 + seek(lFdata,lvox_offset+lStart-1); + BlockRead(lFdata, lByteP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + reset(lFdata,2); + if (lvox_offset mod 2) <> 0 then begin + showmessage('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 2)+ (lStart-1)); + BlockRead(lFdata, lSmallIntP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lSmallIntP^[lInc]; + freemem(lSmallIntP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + //next: 4 byte data + reset(lFdata,4); + if (lvox_offset mod 4) <> 0 then begin + showmessage('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 4)+ (lStart-1) ); + BlockRead(lFdata, lImgData[lRApos], (lEnd+1)-lStart); + + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := conv4r4i (lImgData^[lRApos+lInc-1]); + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do + if specialsingle(lImgData^[lRApos+lInc-1]) then + lImgData^[lRApos+lInc-1] := 0; + end; + end else + showmessage('Unsupported COMPRESSED data type '+inttostr(lDataType)); + closefile(lFdata); + end; //not gz + result := true; +end; + +(*function LoadImgx(lInName: string; lImgData: SingleP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +var + lvox_offset,lInc,lFSize,lP2: integer; + lFData: file; + lImgName: string; + lByteP: ByteP; + lSmallIntP: SmallIntP; + lV,lMin,lMax: single; +begin + + result := false; + if (lStart >= lEnd) or (lStart < 1) or (lEnd < 1) then begin + MainForm.NPMmsg('Error: LoadImg '+inttostr(lStart)+'>='+inttostr(lEnd)+' or zero'); + exit; + end; + if Files4D(lInName) then begin + lImgName := Filename4D(lInName); + lP2 := BPP (lDataType); + if lP2 = 0 then begin + Showmessage(lImgName +' is an unsupported file type'); + exit; + end; + lvox_offset := linvox_offset+ ((Vol4D(lInName)-1)* (lP2 * lVolVox)); + end else begin + lImgName := lInName; + lvox_offset := linvox_offset; + end; + if UpCaseExt(lImgName) = '.HDR' then + lImgName := changefileext(lImgName,'.img'); + lFSize := FSize(lImgName); + if (not GzExt(lImgName)) and (lFSize < (lEnd+ lvox_offset)) then begin + MainForm.NPMmsg('Error: LoadImg '+lImgName+' FSize = '+inttostr(lFSize)+' Expected '+inttostr(lEnd+ lvox_offset)); + exit; + end; + filemode := 0; + if GzExt(lImgName) then begin + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + UnGZip(lImgName,lByteP,lvox_offset+lStart-1,(lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + //getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(smallint)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(smallint)),((lEnd+1)-lStart)*sizeof(smallint)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*2)+1 ; + lImgData^[lRApos+lInc-1] := makesmallint(lByteP^[lP2],lByteP^[lP2+1]); + end; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + lByteP := ByteP(@lImgData^[lRApos]); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + + {getmem(lByteP, ((lEnd+1)-lStart)*sizeof(single)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lImgData^[lRApos+lInc-1] := makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + //lImgData^[lRApos+lInc-1] := makesingle(lByteP^[lP2+3],lByteP^[lP2+2],lByteP^[lP2+1],lByteP^[lP2]); + end; + freemem(lByteP);} + //test range + {lINc := 1; + lMin := lImgData^[lRApos+lInc-1]; + lMax := lMin; + for lInc := 1 to ((lEnd+1)-lStart) do begin + lV := lImgData^[lRApos+lInc-1]; + if lV > lMax then + lMax := lV; + if lV < lMin then + lMin := lMax; + end; + MainForm.NPMmsg(inttostr(lvox_offset)+' '+realtostr(lMin,8)+' '+realtostr(lMax,8)); } + + + //end + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := conv4r4i (lImgData^[lRApos+lInc-1]); + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do + if specialsingle(lImgData^[lRApos+lInc-1])then + lImgData^[lRApos+lInc-1] := 0; + end; + end else begin + showmessage(lImgName + ' is an unsupported compressed data type '+inttostr(lDataType)); + exit; + end; + end else begin + assignfile(lFdata,lImgName); + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + reset(lFdata,1); + seek(lFdata,lvox_offset+lStart-1); + BlockRead(lFdata, lByteP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + reset(lFdata,2); + if (lvox_offset mod 2) <> 0 then begin + showmessage('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 2)+ (lStart-1)); + BlockRead(lFdata, lSmallIntP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lSmallIntP^[lInc]; + freemem(lSmallIntP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + //next: 4 byte data + reset(lFdata,4); + if (lvox_offset mod 4) <> 0 then begin + showmessage('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 4)+ (lStart-1) ); + BlockRead(lFdata, lImgData[lRApos], (lEnd+1)-lStart); + + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := conv4r4i (lImgData^[lRApos+lInc-1]); + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do + if specialsingle(lImgData^[lRApos+lInc-1]) then + lImgData^[lRApos+lInc-1] := 0; + end; + end else + showmessage('Unsupported COMPRESSED data type '+inttostr(lDataType)); + closefile(lFdata); + end; //not gz + result := true; +end; *) + +function LoadImg8(lInName: string; lImgData: ByteP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +//loads BINARY data - ignore scaling: zero or not zero +var + lvox_offset,lInc,lFSize,lP2: integer; + lFData: file; + lImgName: string; + lByteP: ByteP; + lSmallIntP: SmallIntP; + lSingle: single; +begin + result := false; + if (lStart >= lEnd) or (lStart < 1) or (lEnd < 1) then begin + MainForm.NPMmsg('Error: LoadImg '+inttostr(lStart)+'>='+inttostr(lEnd)+' or zero'); + exit; + end; + if Files4D(lInName) then begin + lImgName := Filename4D(lInName); + lP2 := BPP (lDataType); + if lP2 = 0 then begin + Showmessage(lImgName +' is an unsupported file type'); + exit; + end; + lvox_offset := linvox_offset+ ((Vol4D(lInName)-1)* (lP2 * lVolVox)); + end else begin + lImgName := lInName; + lvox_offset := linvox_offset; + end; + if UpCaseExt(lImgName) = '.HDR' then + lImgName := changefileext(lImgName,'.img'); + lFSize := FSize(lImgName); + if (not GzExt(lImgName)) and (lFSize < (lEnd+ lvox_offset)) then begin + MainForm.NPMmsg('Error: LoadImg '+lImgName+' FSize = '+inttostr(lFSize)+' Expected '+inttostr(lEnd+ lvox_offset)); + exit; + end; + filemode := 0; + //zero array + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := 0;//makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + + if GzExt(lImgName) then begin + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + UnGZip(lImgName,lByteP,lvox_offset+lStart-1,(lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + //getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(smallint)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(smallint)),((lEnd+1)-lStart)*sizeof(smallint)); + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*2)+1 ; + lImgData^[lRApos+lInc-1] := makesmallint(lByteP^[lP2],lByteP^[lP2+1]); + end; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(single)); + UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lSingle := conv4r4i (makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3])); + if lSingle <> 0 then + lImgData^[lRApos+lInc-1] := 1; + end; + end else begin //32 bit float + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lSingle := makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + if (not specialsingle(lSingle)) and (lSingle <> 0) then + lImgData^[lRApos+lInc-1] := 1; + end; + end; + freemem(lByteP); + end else begin + showmessage(lImgName + ' is an unsupported compressed data type '+inttostr(lDataType)); + exit; + end; + end else begin + assignfile(lFdata,lImgName); + if lDataType = kDT_UNSIGNED_CHAR then begin + getmem(lByteP, (lEnd+1)-lStart); + reset(lFdata,1); + seek(lFdata,lvox_offset+lStart-1); + BlockRead(lFdata, lByteP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lByteP^[lInc]; + freemem(lByteP); + end else if (lDataType = kDT_SIGNED_SHORT) then begin + getmem(lSmallIntP, sizeof(smallint)* ((lEnd+1)-lStart)); + reset(lFdata,2); + if (lvox_offset mod 2) <> 0 then begin + showmessage('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 2)+ (lStart-1)); + BlockRead(lFdata, lSmallIntP^, (lEnd+1)-lStart); + for lInc := 1 to ((lEnd+1)-lStart) do + lImgData^[lRApos+lInc-1] := lSmallIntP^[lInc]; + freemem(lSmallIntP); + end else if (lDataType = kDT_SIGNED_INT) or (lDataType = kDT_FLOAT) then begin + //next: 4 byte data + reset(lFdata,4); + if (lvox_offset mod 4) <> 0 then begin + showmessage('Error: this software can only read headers with dataoffsets that are divisible by 4.'); + end; + seek(lFdata,(lvox_offset div 4)+ (lStart-1) ); + getmem(lByteP, ((lEnd+1)-lStart)*sizeof(single)); + //fx(((lEnd+1)-lStart)*sizeof(single)); + BlockRead(lFdata, lByteP^, ((lEnd+1)-lStart)); + //April 2009 + //UnGZip(lImgName,lByteP,lvox_offset+((lStart-1)*sizeof(single)),((lEnd+1)-lStart)*sizeof(single)); + if lDataType = kDT_SIGNED_INT then begin + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lSingle := conv4r4i (makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3])); + if lSingle <> 0 then + lImgData^[lRApos+lInc-1] := 1; + end; + end else begin + for lInc := 1 to ((lEnd+1)-lStart) do begin + lP2 := ((lInc-1)*4)+1 ; + lSingle := makesingle(lByteP^[lP2],lByteP^[lP2+1],lByteP^[lP2+2],lByteP^[lP2+3]); + if (not specialsingle(lSingle)) and (lSingle <> 0) then + lImgData^[lRApos+lInc-1] := 1; + end; + end; + freemem(lByteP); + + end else + showmessage('Unsupported COMPRESSED data type '+inttostr(lDataType)); + closefile(lFdata); + end; //not gz + result := true; +end; + +end. diff --git a/npm_precl/npm.app/Contents/Info.plist b/npm_precl/npm.app/Contents/Info.plist new file mode 100755 index 0000000..faabe7e --- /dev/null +++ b/npm_precl/npm.app/Contents/Info.plist @@ -0,0 +1,43 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> +<plist version="1.0"> +<dict> + <key>CFBundleDevelopmentRegion</key> + <string>English</string> + <key>CFBundleExecutable</key> + <string>npm</string> + <key>CFBundleName</key> + <string>npm</string> + <key>CFBundleIdentifier</key> + <string>com.company.npm</string> + <key>CFBundleInfoDictionaryVersion</key> + <string>6.0</string> + <key>CFBundlePackageType</key> + <string>APPL</string> + <key>CFBundleSignature</key> + <string>npm?</string> + <key>CFBundleShortVersionString</key> + <string>0.1</string> + <key>CFBundleVersion</key> + <string>1</string> + <key>CSResourcesFileMapped</key> + <true/> + <key>CFBundleDocumentTypes</key> + <array> + <dict> + <key>CFBundleTypeRole</key> + <string>Viewer</string> + <key>CFBundleTypeExtensions</key> + <array> + <string>*</string> + </array> + <key>CFBundleTypeOSTypes</key> + <array> + <string>fold</string> + <string>disk</string> + <string>****</string> + </array> + </dict> + </array> +</dict> +</plist> diff --git a/npm_precl/npm.app/Contents/MacOS/npm b/npm_precl/npm.app/Contents/MacOS/npm new file mode 100755 index 0000000..20acbf9 --- /dev/null +++ b/npm_precl/npm.app/Contents/MacOS/npm @@ -0,0 +1 @@ +../../../npm \ No newline at end of file diff --git a/npm_precl/npm.app/Contents/PkgInfo b/npm_precl/npm.app/Contents/PkgInfo new file mode 100755 index 0000000..6f749b0 --- /dev/null +++ b/npm_precl/npm.app/Contents/PkgInfo @@ -0,0 +1 @@ +APPL???? diff --git a/npm_precl/npm.cfg b/npm_precl/npm.cfg new file mode 100755 index 0000000..c599db3 --- /dev/null +++ b/npm_precl/npm.cfg @@ -0,0 +1,39 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-LN"c:\program files (x86)\borland\delphi7\Projects\Bpl" +-U"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-O"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-I"C:\pas\mricron\common;C:\pas\mricron\fpmath" +-R"C:\pas\mricron\common;C:\pas\mricron\fpmath" diff --git a/npm_precl/npm.compiled b/npm_precl/npm.compiled new file mode 100755 index 0000000..3f746fe --- /dev/null +++ b/npm_precl/npm.compiled @@ -0,0 +1,5 @@ +<?xml version="1.0"?> +<CONFIG> + <Compiler Value="/usr/local/bin/ppc386" Date="1359911592"/> + <Params Value=" -MObjFPC -Scgi -O1 -Xs -XX -k-framework -kCarbon -k-framework -kOpenGL -k-dylib_file -k/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib -vewnhi -Fu../fpmath -Fu../common -Fu/Developer/lazarus/lcl/units/i386-darwin/carbon -Fu/Developer/lazarus/lcl/units/i386-darwin -Fu/Developer/lazarus/components/lazutils/lib/i386-darwin -Fu/Developer/lazarus/packager/units/i386-darwin -Fu. -l -dLCL -dLCLcarbon npm.lpr"/> +</CONFIG> diff --git a/npm_precl/npm.dof b/npm_precl/npm.dof new file mode 100755 index 0000000..7fdd741 --- /dev/null +++ b/npm_precl/npm.dof @@ -0,0 +1,143 @@ +[FileVersion] +Version=7.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +NamespacePrefix= +SymbolDeprecated=1 +SymbolLibrary=1 +SymbolPlatform=1 +UnitLibrary=1 +UnitPlatform=1 +UnitDeprecated=1 +HResultCompat=1 +HidingMember=1 +HiddenVirtual=1 +Garbage=1 +BoundsError=1 +ZeroNilCompat=1 +StringConstTruncated=1 +ForLoopVarVarPar=1 +TypedConstVarPar=1 +AsgToTypedConst=1 +CaseLabelRange=1 +ForVariable=1 +ConstructingAbstract=1 +ComparisonFalse=1 +ComparisonTrue=1 +ComparingSignedUnsigned=1 +CombiningSignedUnsigned=1 +UnsupportedConstruct=1 +FileOpen=1 +FileOpenUnitSrc=1 +BadGlobalSymbol=1 +DuplicateConstructorDestructor=1 +InvalidDirective=1 +PackageNoLink=1 +PackageThreadVar=1 +ImplicitImport=1 +HPPEMITIgnored=1 +NoRetVal=1 +UseBeforeDef=1 +ForLoopVarUndef=1 +UnitNameMismatch=1 +NoCFGFileFound=1 +MessageDirective=1 +ImplicitVariants=1 +UnicodeToLocale=1 +LocaleToUnicode=1 +ImagebaseMultiple=1 +SuspiciousTypecast=1 +PrivatePropAccessor=1 +UnsafeType=1 +UnsafeCode=1 +UnsafeCast=1 +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath=C:\pas\mricron\common;C:\pas\mricron\fpmath +Packages=Vcl40;Vclx40;VclSmp40;Qrpt40;Vcldb40;RxCtl4 +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1033 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= +[HistoryLists\hlUnitAliases] +Count=1 +Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[HistoryLists\hlSearchPath] +Count=2 +Item0=C:\pas\mricron\common;C:\pas\mricron\fpmath +Item1=C:\pas\mricron\common diff --git a/npm_precl/npm.dpr b/npm_precl/npm.dpr new file mode 100755 index 0000000..3c2dcbe --- /dev/null +++ b/npm_precl/npm.dpr @@ -0,0 +1,29 @@ +program npm; + +uses + Forms, + npmform in 'npmform.pas' {MainForm}, + stats in 'stats.pas', + spread in 'spread.pas' {SpreadForm}, + design in 'design.pas' {DesignForm}, + valformat in 'valformat.pas', + ReadInt in 'ReadInt.pas' {ReadIntForm}, + firth in 'firth.pas', + roc in 'roc.pas', + prefs in 'prefs.pas'; + +{$R *.RES} +{$IFNDEF FPC} +{$R windowsxp.res} + +{$ENDIF} + +begin + Application.Initialize; + Application.Title := 'NPM'; + Application.CreateForm(TMainForm, MainForm); + Application.CreateForm(TSpreadForm, SpreadForm); + Application.CreateForm(TDesignForm, DesignForm); + Application.CreateForm(TReadIntForm, ReadIntForm); + Application.Run; +end. diff --git a/npm_precl/npm.ini b/npm_precl/npm.ini new file mode 100755 index 0000000..f143f52 --- /dev/null +++ b/npm_precl/npm.ini @@ -0,0 +1,11 @@ +[BOOL] +computettest=1 +computebm=0 +countlesionpatterns=1 +ROI=1 + +[INT] +CacheMB=512 +nPermute=4000 +nThread=2 +TFCE=0 diff --git a/npm_precl/npm.lpi b/npm_precl/npm.lpi new file mode 100755 index 0000000..30c8664 --- /dev/null +++ b/npm_precl/npm.lpi @@ -0,0 +1,672 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <LRSInOutputDirectory Value="False"/> + </Flags> + <MainUnit Value="0"/> + <ActiveWindowIndexAtStart Value="0"/> + </General> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="57"> + <Unit0> + <Filename Value="npm.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="npm"/> + <EditorIndex Value="0"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="8" Y="13"/> + <UsageCount Value="45"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit0> + <Unit1> + <Filename Value="npmform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MainForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="npmform"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="4"/> + <WindowIndex Value="0"/> + <TopLine Value="224"/> + <CursorPos X="7" Y="250"/> + <UsageCount Value="45"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit1> + <Unit2> + <Filename Value="nifti_hdr.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="nifti_hdr"/> + <TopLine Value="358"/> + <CursorPos X="49" Y="368"/> + <UsageCount Value="41"/> + </Unit2> + <Unit3> + <Filename Value="define_types.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="define_types"/> + <TopLine Value="945"/> + <CursorPos X="38" Y="959"/> + <UsageCount Value="41"/> + </Unit3> + <Unit4> + <Filename Value="GraphicsMathLibrary.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="GraphicsMathLibrary"/> + <TopLine Value="681"/> + <CursorPos X="1" Y="738"/> + <UsageCount Value="41"/> + </Unit4> + <Unit5> + <Filename Value="distr.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="distr"/> + <TopLine Value="99"/> + <CursorPos X="1" Y="107"/> + <UsageCount Value="41"/> + </Unit5> + <Unit6> + <Filename Value="statcr.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="statcr"/> + <TopLine Value="1"/> + <CursorPos X="34" Y="6"/> + <UsageCount Value="41"/> + </Unit6> + <Unit7> + <Filename Value="stats.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="stats"/> + <TopLine Value="369"/> + <CursorPos X="41" Y="370"/> + <UsageCount Value="41"/> + </Unit7> + <Unit8> + <Filename Value="brunner.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="brunner"/> + <TopLine Value="500"/> + <CursorPos X="29" Y="517"/> + <UsageCount Value="41"/> + </Unit8> + <Unit9> + <Filename Value="StatThdsUtil.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="StatThdsUtil"/> + <TopLine Value="1"/> + <CursorPos X="69" Y="6"/> + <UsageCount Value="41"/> + </Unit9> + <Unit10> + <Filename Value="StatThds.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="StatThds"/> + <EditorIndex Value="9"/> + <WindowIndex Value="0"/> + <TopLine Value="17"/> + <CursorPos X="11" Y="127"/> + <UsageCount Value="41"/> + <Loaded Value="True"/> + </Unit10> + <Unit11> + <Filename Value="valformat.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="valformat"/> + <TopLine Value="64"/> + <CursorPos X="1" Y="91"/> + <UsageCount Value="41"/> + </Unit11> + <Unit12> + <Filename Value="design.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="DesignForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="design"/> + <EditorIndex Value="3"/> + <WindowIndex Value="0"/> + <TopLine Value="37"/> + <CursorPos X="24" Y="52"/> + <UsageCount Value="40"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit12> + <Unit13> + <Filename Value="spread.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="SpreadForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="spread"/> + <EditorIndex Value="2"/> + <WindowIndex Value="0"/> + <TopLine Value="557"/> + <CursorPos X="1" Y="584"/> + <UsageCount Value="40"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit13> + <Unit14> + <Filename Value="gzio2.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="gzio2"/> + <TopLine Value="774"/> + <CursorPos X="22" Y="793"/> + <UsageCount Value="41"/> + </Unit14> + <Unit15> + <Filename Value="part.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="part"/> + <TopLine Value="91"/> + <CursorPos X="38" Y="108"/> + <UsageCount Value="41"/> + </Unit15> + <Unit16> + <Filename Value="markorder.pas"/> + <UnitName Value="markorder"/> + <TopLine Value="8"/> + <CursorPos X="44" Y="23"/> + <UsageCount Value="10"/> + </Unit16> + <Unit17> + <Filename Value="ztopform.pas"/> + <ComponentName Value="ZForm"/> + <UnitName Value="ztopform"/> + <TopLine Value="9"/> + <CursorPos X="18" Y="23"/> + <UsageCount Value="22"/> + </Unit17> + <Unit18> + <Filename Value="..\examples\opendialogcrash\unit1.pas"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <UnitName Value="Unit1"/> + <TopLine Value="19"/> + <CursorPos X="40" Y="14"/> + <UsageCount Value="10"/> + </Unit18> + <Unit19> + <Filename Value="nifti_img.pas"/> + <UnitName Value="nifti_img"/> + <TopLine Value="52"/> + <CursorPos X="28" Y="54"/> + <UsageCount Value="11"/> + </Unit19> + <Unit20> + <Filename Value="lesion_pattern.pas"/> + <UnitName Value="lesion_pattern"/> + <TopLine Value="76"/> + <CursorPos X="25" Y="86"/> + <UsageCount Value="10"/> + </Unit20> + <Unit21> + <Filename Value="ReadInt.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="ReadIntForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="ReadInt"/> + <EditorIndex Value="1"/> + <WindowIndex Value="0"/> + <TopLine Value="33"/> + <CursorPos X="9" Y="50"/> + <UsageCount Value="39"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit21> + <Unit22> + <Filename Value="ReadInt.lrs"/> + <IsPartOfProject Value="True"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="3"/> + <UsageCount Value="37"/> + </Unit22> + <Unit23> + <Filename Value="LesionStatThds.pas"/> + <UnitName Value="LesionStatThds"/> + <EditorIndex Value="8"/> + <WindowIndex Value="0"/> + <TopLine Value="414"/> + <CursorPos X="77" Y="439"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit23> + <Unit24> + <Filename Value="power.pas"/> + <UnitName Value="power"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="1"/> + <UsageCount Value="11"/> + </Unit24> + <Unit25> + <Filename Value="Mat.pas"/> + <UnitName Value="Mat"/> + <TopLine Value="225"/> + <CursorPos X="18" Y="239"/> + <UsageCount Value="11"/> + </Unit25> + <Unit26> + <Filename Value="Vector.pas"/> + <UnitName Value="Vector"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="1"/> + <UsageCount Value="10"/> + </Unit26> + <Unit27> + <Filename Value="firth.pas"/> + <UnitName Value="firth"/> + <TopLine Value="382"/> + <CursorPos X="19" Y="383"/> + <UsageCount Value="10"/> + </Unit27> + <Unit28> + <Filename Value="overlap.pas"/> + <UnitName Value="overlap"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="6"/> + <UsageCount Value="10"/> + </Unit28> + <Unit29> + <Filename Value="firthThds.pas"/> + <UnitName Value="firthThds"/> + <TopLine Value="312"/> + <CursorPos X="123" Y="315"/> + <UsageCount Value="10"/> + </Unit29> + <Unit30> + <Filename Value="design.lfm"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="1"/> + <UsageCount Value="10"/> + <DefaultSyntaxHighlighter Value="LFM"/> + </Unit30> + <Unit31> + <Filename Value="options.inc"/> + <TopLine Value="1"/> + <CursorPos X="21" Y="3"/> + <UsageCount Value="11"/> + </Unit31> + <Unit32> + <Filename Value="userdir.pas"/> + <UnitName Value="userdir"/> + <TopLine Value="1"/> + <CursorPos X="64" Y="45"/> + <UsageCount Value="11"/> + </Unit32> + <Unit33> + <Filename Value="..\..\lcl\forms.pp"/> + <UnitName Value="Forms"/> + <TopLine Value="642"/> + <CursorPos X="14" Y="661"/> + <UsageCount Value="11"/> + </Unit33> + <Unit34> + <Filename Value="..\gzio2.pas"/> + <UnitName Value="gzio2"/> + <TopLine Value="627"/> + <CursorPos X="22" Y="635"/> + <UsageCount Value="10"/> + </Unit34> + <Unit35> + <Filename Value="..\..\fpc\2.0.4\source\rtl\objpas\sysutils\finah.inc"/> + <TopLine Value="17"/> + <CursorPos X="22" Y="27"/> + <UsageCount Value="10"/> + </Unit35> + <Unit36> + <Filename Value="..\define_types.pas"/> + <UnitName Value="define_types"/> + <TopLine Value="1"/> + <CursorPos X="31" Y="5"/> + <UsageCount Value="10"/> + </Unit36> + <Unit37> + <Filename Value="..\..\fpc\2.0.4\source\rtl\win32\wininc\messages.inc"/> + <TopLine Value="1191"/> + <CursorPos X="6" Y="1201"/> + <UsageCount Value="10"/> + </Unit37> + <Unit38> + <Filename Value="regression.pas"/> + <UnitName Value="regression"/> + <EditorIndex Value="10"/> + <WindowIndex Value="0"/> + <TopLine Value="725"/> + <CursorPos X="37" Y="731"/> + <UsageCount Value="14"/> + <Loaded Value="True"/> + </Unit38> + <Unit39> + <Filename Value="Regmult.pas"/> + <UnitName Value="RegMult"/> + <TopLine Value="30"/> + <CursorPos X="27" Y="43"/> + <UsageCount Value="10"/> + </Unit39> + <Unit40> + <Filename Value="..\fpmath\regmult.pas"/> + <UnitName Value="regmult"/> + <TopLine Value="39"/> + <CursorPos X="69" Y="45"/> + <UsageCount Value="10"/> + </Unit40> + <Unit41> + <Filename Value="..\common\distr.pas"/> + <UnitName Value="distr"/> + <TopLine Value="296"/> + <CursorPos X="1" Y="308"/> + <UsageCount Value="11"/> + </Unit41> + <Unit42> + <Filename Value="..\common\define_types.pas"/> + <UnitName Value="define_types"/> + <EditorIndex Value="11"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="24" Y="21"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit42> + <Unit43> + <Filename Value="hdr.pas"/> + <UnitName Value="hdr"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="3"/> + <UsageCount Value="10"/> + </Unit43> + <Unit44> + <Filename Value="..\common\gzio2.pas"/> + <UnitName Value="gzio2"/> + <TopLine Value="223"/> + <CursorPos X="16" Y="236"/> + <UsageCount Value="10"/> + </Unit44> + <Unit45> + <Filename Value="..\common\nifti_hdr.pas"/> + <UnitName Value="nifti_hdr"/> + <TopLine Value="119"/> + <CursorPos X="1" Y="121"/> + <UsageCount Value="11"/> + </Unit45> + <Unit46> + <Filename Value="..\common\GraphicsMathLibrary.pas"/> + <UnitName Value="GraphicsMathLibrary"/> + <TopLine Value="1"/> + <CursorPos X="17" Y="8"/> + <UsageCount Value="10"/> + </Unit46> + <Unit47> + <Filename Value="..\fpmath\utypes.pas"/> + <UnitName Value="utypes"/> + <TopLine Value="470"/> + <CursorPos X="41" Y="482"/> + <UsageCount Value="12"/> + </Unit47> + <Unit48> + <Filename Value="lesion.pas"/> + <UnitName Value="lesion"/> + <TopLine Value="299"/> + <CursorPos X="64" Y="313"/> + <UsageCount Value="10"/> + </Unit48> + <Unit49> + <Filename Value="anacom.pas"/> + <UnitName Value="anacom"/> + <TopLine Value="579"/> + <CursorPos X="32" Y="593"/> + <UsageCount Value="10"/> + </Unit49> + <Unit50> + <Filename Value="filename.pas"/> + <UnitName Value="filename"/> + <TopLine Value="1"/> + <CursorPos X="6" Y="4"/> + <UsageCount Value="10"/> + </Unit50> + <Unit51> + <Filename Value="montecarlo.pas"/> + <UnitName Value="montecarlo"/> + <EditorIndex Value="7"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="6" Y="3"/> + <UsageCount Value="11"/> + <Loaded Value="True"/> + </Unit51> + <Unit52> + <Filename Value="roc.pas"/> + <UnitName Value="roc"/> + <TopLine Value="317"/> + <CursorPos X="33" Y="344"/> + <UsageCount Value="10"/> + </Unit52> + <Unit53> + <Filename Value="..\fpmath\types.inc"/> + <EditorIndex Value="12"/> + <WindowIndex Value="0"/> + <TopLine Value="112"/> + <CursorPos X="3" Y="174"/> + <UsageCount Value="13"/> + <Loaded Value="True"/> + </Unit53> + <Unit54> + <Filename Value="C:\Developer\lazarus\lcl\interfaces\carbon\carbonprivatecommon.inc"/> + <TopLine Value="170"/> + <CursorPos X="1" Y="184"/> + <UsageCount Value="10"/> + </Unit54> + <Unit55> + <Filename Value="tfce_clustering.pas"/> + <UnitName Value="tfce_clustering"/> + <EditorIndex Value="6"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="27" Y="3"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit55> + <Unit56> + <Filename Value="..\..\..\..\..\..\Developer\lazarus\lcl\include\menuitem.inc"/> + <EditorIndex Value="5"/> + <WindowIndex Value="0"/> + <TopLine Value="1288"/> + <CursorPos X="1" Y="1317"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit56> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="regression.pas"/> + <Caret Line="714" Column="16" TopLine="696"/> + </Position1> + <Position2> + <Filename Value="regression.pas"/> + <Caret Line="454" Column="25" TopLine="428"/> + </Position2> + <Position3> + <Filename Value="regression.pas"/> + <Caret Line="663" Column="24" TopLine="470"/> + </Position3> + <Position4> + <Filename Value="npmform.pas"/> + <Caret Line="94" Column="7" TopLine="75"/> + </Position4> + <Position5> + <Filename Value="npmform.pas"/> + <Caret Line="99" Column="11" TopLine="80"/> + </Position5> + <Position6> + <Filename Value="tfce_clustering.pas"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position6> + <Position7> + <Filename Value="spread.pas"/> + <Caret Line="591" Column="34" TopLine="587"/> + </Position7> + <Position8> + <Filename Value="npmform.pas"/> + <Caret Line="2" Column="1" TopLine="1"/> + </Position8> + <Position9> + <Filename Value="npmform.pas"/> + <Caret Line="1521" Column="28" TopLine="1502"/> + </Position9> + <Position10> + <Filename Value="spread.pas"/> + <Caret Line="584" Column="3" TopLine="557"/> + </Position10> + <Position11> + <Filename Value="npmform.pas"/> + <Caret Line="1516" Column="14" TopLine="1502"/> + </Position11> + <Position12> + <Filename Value="npmform.pas"/> + <Caret Line="1521" Column="17" TopLine="1502"/> + </Position12> + <Position13> + <Filename Value="npmform.pas"/> + <Caret Line="1518" Column="20" TopLine="1502"/> + </Position13> + <Position14> + <Filename Value="npmform.pas"/> + <Caret Line="37" Column="40" TopLine="13"/> + </Position14> + <Position15> + <Filename Value="npmform.pas"/> + <Caret Line="25" Column="22" TopLine="1"/> + </Position15> + <Position16> + <Filename Value="npmform.pas"/> + <Caret Line="30" Column="28" TopLine="1"/> + </Position16> + <Position17> + <Filename Value="npmform.pas"/> + <Caret Line="89" Column="30" TopLine="43"/> + </Position17> + <Position18> + <Filename Value="npmform.pas"/> + <Caret Line="18" Column="79" TopLine="1"/> + </Position18> + <Position19> + <Filename Value="npmform.pas"/> + <Caret Line="183" Column="43" TopLine="156"/> + </Position19> + <Position20> + <Filename Value="npmform.pas"/> + <Caret Line="1434" Column="1" TopLine="1429"/> + </Position20> + <Position21> + <Filename Value="npmform.pas"/> + <Caret Line="1511" Column="8" TopLine="1476"/> + </Position21> + <Position22> + <Filename Value="npmform.pas"/> + <Caret Line="5" Column="152" TopLine="1"/> + </Position22> + <Position23> + <Filename Value="npmform.pas"/> + <Caret Line="144" Column="23" TopLine="98"/> + </Position23> + <Position24> + <Filename Value="npmform.pas"/> + <Caret Line="32" Column="5" TopLine="18"/> + </Position24> + <Position25> + <Filename Value="regression.pas"/> + <Caret Line="671" Column="129" TopLine="661"/> + </Position25> + <Position26> + <Filename Value="npmform.pas"/> + <Caret Line="3" Column="170" TopLine="1"/> + </Position26> + <Position27> + <Filename Value="npmform.pas"/> + <Caret Line="145" Column="22" TopLine="99"/> + </Position27> + <Position28> + <Filename Value="npmform.pas"/> + <Caret Line="147" Column="26" TopLine="121"/> + </Position28> + <Position29> + <Filename Value="npmform.pas"/> + <Caret Line="239" Column="40" TopLine="205"/> + </Position29> + <Position30> + <Filename Value="npmform.pas"/> + <Caret Line="241" Column="29" TopLine="214"/> + </Position30> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <SearchPaths> + <OtherUnitFiles Value="..\fpmath;..\common"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <Linking> + <Debugging> + <UseLineInfoUnit Value="False"/> + <StripSymbols Value="True"/> + </Debugging> + <LinkSmart Value="True"/> + <Options> + <LinkerOptions Value=" -macosx_version_min 10.4 "/> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <UseMsgFile Value="True"/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="2"> + <Item1> + <Name Value="ECodetoolError"/> + </Item1> + <Item2> + <Name Value="EFOpenError"/> + </Item2> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/npm_precl/npm.lpr b/npm_precl/npm.lpr new file mode 100755 index 0000000..e0cf089 --- /dev/null +++ b/npm_precl/npm.lpr @@ -0,0 +1,27 @@ +program npm; + +{$mode objfpc}{$H+} +{$I options.inc} +uses + {$IFDEF UNIX}cthreads,{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, npmform,stats +,nifti_hdr,valformat, part, gzio2, StatThds, + StatThdsUtil, brunner, statcr, distr, GraphicsMathLibrary, define_types, + ReadInt + {$IFDEF SPREADSHEET} ,design,spread{$ENDIF}; + {$IFNDEF FPC} +{$R npm.res} +{$ENDIF} + +begin + Application.Initialize; + Application.CreateForm(TMainForm, MainForm); + {$IFDEF SPREADSHEET} + Application.CreateForm(TSpreadForm, SpreadForm); + Application.CreateForm(TDesignForm, DesignForm); + {$ENDIF} + Application.CreateForm(TReadIntForm, ReadIntForm); + Application.Run; +end. + diff --git a/npm_precl/npm.or b/npm_precl/npm.or new file mode 100755 index 0000000..4a3628d Binary files /dev/null and b/npm_precl/npm.or differ diff --git a/npm_precl/npm.res b/npm_precl/npm.res new file mode 100755 index 0000000..80a54cd Binary files /dev/null and b/npm_precl/npm.res differ diff --git a/npm_precl/npmform.dfm b/npm_precl/npmform.dfm new file mode 100755 index 0000000..8f15e6e Binary files /dev/null and b/npm_precl/npmform.dfm differ diff --git a/npm_precl/npmform.lfm b/npm_precl/npmform.lfm new file mode 100755 index 0000000..fc916b1 --- /dev/null +++ b/npm_precl/npmform.lfm @@ -0,0 +1,297 @@ +object MainForm: TMainForm + Left = 517 + Height = 418 + Top = 321 + Width = 542 + ActiveControl = Memo1 + Caption = 'Non-Parametric Mapping' + ClientHeight = 418 + ClientWidth = 542 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '0.9.30.2' + object Memo1: TMemo + Left = 0 + Height = 393 + Top = 0 + Width = 542 + Align = alClient + ScrollBars = ssAutoBoth + TabOrder = 0 + end + object Panel1: TPanel + Left = 0 + Height = 25 + Top = 393 + Width = 542 + Align = alBottom + ClientHeight = 25 + ClientWidth = 542 + TabOrder = 1 + object ProgressBar1: TProgressBar + Left = 1 + Height = 23 + Top = 1 + Width = 540 + Align = alClient + TabOrder = 0 + end + end + object MainMenu1: TMainMenu + left = 8 + top = 8 + object File1: TMenuItem + Caption = 'File' + object SaveText1: TMenuItem + Caption = 'Save text...' + OnClick = Savetext1Click + end + object Exit1: TMenuItem + Caption = 'Exit' + OnClick = Exit1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + end + object VLSM1: TMenuItem + Caption = 'VLSM' + object BinomialAnalysislesions1: TMenuItem + Caption = 'Binary images, binary groups (lesions) ' + ShortCut = 16450 + OnClick = LesionBtnClick + end + object Binaryimagescontinuousgroupsfast1: TMenuItem + Tag = 1 + Caption = 'Binary images, continuous grooups (vlsm)' + ShortCut = 16460 + OnClick = LesionBtnClick + end + object PenalizedLogisticRegerssion1: TMenuItem + Caption = 'Binary images, multiple factors' + OnClick = PenalizedLogisticRegerssion1Click + end + object ROIanalysis1: TMenuItem + Caption = 'ROI analysis' + OnClick = ROIanalysis1Click + end + object Design1: TMenuItem + Caption = 'Design...' + ShortCut = 16452 + OnClick = Design1Click + end + end + object VBM1: TMenuItem + Caption = 'VBM' + object ContinuousanalysisVBM1: TMenuItem + Caption = 'Continuous images, binary groups (VBM)' + ShortCut = 16470 + OnClick = NPMclick + end + object PairedTMenu: TMenuItem + Caption = 'Paired Measures T-test' + OnClick = PairedTMenuClick + end + object MultipleRegress: TMenuItem + Caption = 'Multiple WLS Regression' + OnClick = MultipleRegressClick + end + object SingleRegress: TMenuItem + Caption = 'Single WLS Regression' + OnClick = SingleRegressClick + end + object MenuItem3: TMenuItem + Caption = 'Dual image correlation' + OnClick = DualImageCorrelation1Click + end + end + object Options1: TMenuItem + Caption = 'Options' + object Permutations1: TMenuItem + Caption = 'Permutations' + object N0: TMenuItem + AutoCheck = True + Caption = 'None' + Checked = True + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N1000: TMenuItem + Tag = 1000 + AutoCheck = True + Caption = '1000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N2000: TMenuItem + Tag = 2000 + AutoCheck = True + Caption = '2000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N3000: TMenuItem + Tag = 3000 + AutoCheck = True + Caption = '3000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + object N4000: TMenuItem + Tag = 4000 + AutoCheck = True + Caption = '4000' + GroupIndex = 123 + RadioItem = True + OnClick = radiomenuclick + end + end + object Tests1: TMenuItem + Caption = 'Tests' + object ttestmenu: TMenuItem + Caption = 't-test' + OnClick = testmenuclick + end + object BMmenu: TMenuItem + Caption = 'Brunner Munzel' + Checked = True + OnClick = testmenuclick + end + end + object Threads1: TMenuItem + Caption = 'Threads' + object T1: TMenuItem + AutoCheck = True + Caption = '1' + Checked = True + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T2: TMenuItem + AutoCheck = True + Caption = '2' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T3: TMenuItem + AutoCheck = True + Caption = '3' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T4: TMenuItem + AutoCheck = True + Caption = '4' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T7: TMenuItem + AutoCheck = True + Caption = '7' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T8: TMenuItem + AutoCheck = True + Caption = '8' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T15: TMenuItem + AutoCheck = True + Caption = '15' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + object T16: TMenuItem + AutoCheck = True + Caption = '16' + GroupIndex = 131 + RadioItem = True + OnClick = threadChange + end + end + end + object Utilities1: TMenuItem + Caption = 'Utilities' + object niiniigz1: TMenuItem + Caption = 'nii -> .nii.gz' + OnClick = niiniigz1Click + end + object Variance1: TMenuItem + Caption = 'Variance image' + OnClick = Variance1Click + end + object Makemeanimage2: TMenuItem + Tag = 1 + Caption = 'Make binarized mean' + OnClick = Makemeanimage1Click + end + object Makemeanimage1: TMenuItem + Caption = 'Make mean/StDev image' + OnClick = Makemeanimage1Click + end + object SingleSubjectZScores1: TMenuItem + Caption = 'Single Subject Z-Score' + OnClick = SingleSubjectZScores1Click + end + object IntensitynormalizationA1: TMenuItem + Tag = 1 + Caption = 'Intensity normalization A' + OnClick = Balance1Click + end + object Balance1: TMenuItem + Caption = 'Intensity normalization B' + OnClick = Balance1Click + end + object PhysiologicalArtifactCorrection1: TMenuItem + Caption = 'Physiological Correction' + OnClick = PhysiologicalArtifactCorrection1Click + end + object Countlesionoverlaps1: TMenuItem + Caption = 'Count lesion overlaps' + OnClick = Countlesionoverlaps1Click + end + object FCE1: TMenuItem + Caption = 'TFCE' + OnClick = FCE1Click + end + end + object Help1: TMenuItem + Caption = 'Help' + Visible = False + object About1: TMenuItem + Caption = 'About' + OnClick = About1Click + end + end + end + object SaveHdrDlg: TSaveDialog + FilterIndex = 0 + left = 8 + top = 40 + end + object OpenHdrDlg: TOpenDialog + FilterIndex = 0 + left = 8 + top = 72 + end +end \ No newline at end of file diff --git a/npm_precl/npmform.lrs b/npm_precl/npmform.lrs new file mode 100755 index 0000000..f2d8f12 --- /dev/null +++ b/npm_precl/npmform.lrs @@ -0,0 +1,86 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TMainForm','FORMDATA',[ + 'TPF0'#9'TMainForm'#8'MainForm'#4'Left'#3#5#2#6'Height'#3#162#1#3'Top'#3'A'#1 + +#5'Width'#3#30#2#13'ActiveControl'#7#5'Memo1'#7'Caption'#6#22'Non-Parametric' + +' Mapping'#12'ClientHeight'#3#162#1#11'ClientWidth'#3#30#2#4'Menu'#7#9'MainM' + +'enu1'#7'OnClose'#7#9'FormClose'#8'OnCreate'#7#10'FormCreate'#6'OnShow'#7#8 + +'FormShow'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#8'0.9.30.2'#0#5 + +'TMemo'#5'Memo1'#4'Left'#2#0#6'Height'#3#137#1#3'Top'#2#0#5'Width'#3#30#2#5 + +'Align'#7#8'alClient'#10'ScrollBars'#7#10'ssAutoBoth'#8'TabOrder'#2#0#0#0#6 + +'TPanel'#6'Panel1'#4'Left'#2#0#6'Height'#2#25#3'Top'#3#137#1#5'Width'#3#30#2 + +#5'Align'#7#8'alBottom'#12'ClientHeight'#2#25#11'ClientWidth'#3#30#2#8'TabOr' + +'der'#2#1#0#12'TProgressBar'#12'ProgressBar1'#4'Left'#2#1#6'Height'#2#23#3'T' + +'op'#2#1#5'Width'#3#28#2#5'Align'#7#8'alClient'#8'TabOrder'#2#0#0#0#0#9'TMai' + +'nMenu'#9'MainMenu1'#4'left'#2#8#3'top'#2#8#0#9'TMenuItem'#5'File1'#7'Captio' + +'n'#6#4'File'#0#9'TMenuItem'#9'SaveText1'#7'Caption'#6#12'Save text...'#7'On' + +'Click'#7#14'Savetext1Click'#0#0#9'TMenuItem'#5'Exit1'#7'Caption'#6#4'Exit'#7 + +'OnClick'#7#10'Exit1Click'#0#0#0#9'TMenuItem'#5'Edit1'#7'Caption'#6#4'Edit'#0 + +#9'TMenuItem'#5'Copy1'#7'Caption'#6#4'Copy'#7'OnClick'#7#10'Copy1Click'#0#0#0 + +#9'TMenuItem'#5'VLSM1'#7'Caption'#6#4'VLSM'#0#9'TMenuItem'#24'BinomialAnalys' + +'islesions1'#7'Caption'#6'''Binary images, binary groups (lesions) '#8'Short' + +'Cut'#3'B@'#7'OnClick'#7#14'LesionBtnClick'#0#0#9'TMenuItem!Binaryimagescont' + +'inuousgroupsfast1'#3'Tag'#2#1#7'Caption'#6'(Binary images, continuous groou' + +'ps (vlsm)'#8'ShortCut'#3'L@'#7'OnClick'#7#14'LesionBtnClick'#0#0#9'TMenuIte' + +'m'#28'PenalizedLogisticRegerssion1'#7'Caption'#6#31'Binary images, multiple' + +' factors'#7'OnClick'#7'!PenalizedLogisticRegerssion1Click'#0#0#9'TMenuItem' + +#12'ROIanalysis1'#7'Caption'#6#12'ROI analysis'#7'OnClick'#7#17'ROIanalysis1' + +'Click'#0#0#9'TMenuItem'#7'Design1'#7'Caption'#6#9'Design...'#8'ShortCut'#3 + +'D@'#7'OnClick'#7#12'Design1Click'#0#0#0#9'TMenuItem'#4'VBM1'#7'Caption'#6#3 + +'VBM'#0#9'TMenuItem'#22'ContinuousanalysisVBM1'#7'Caption'#6'&Continuous ima' + +'ges, binary groups (VBM)'#8'ShortCut'#3'V@'#7'OnClick'#7#8'NPMclick'#0#0#9 + +'TMenuItem'#11'PairedTMenu'#7'Caption'#6#22'Paired Measures T-test'#7'OnClic' + +'k'#7#16'PairedTMenuClick'#0#0#9'TMenuItem'#15'MultipleRegress'#7'Caption'#6 + +#23'Multiple WLS Regression'#7'OnClick'#7#20'MultipleRegressClick'#0#0#9'TMe' + +'nuItem'#13'SingleRegress'#7'Caption'#6#21'Single WLS Regression'#7'OnClick' + +#7#18'SingleRegressClick'#0#0#9'TMenuItem'#9'MenuItem3'#7'Caption'#6#22'Dual' + +' image correlation'#7'OnClick'#7#26'DualImageCorrelation1Click'#0#0#0#9'TMe' + +'nuItem'#8'Options1'#7'Caption'#6#7'Options'#0#9'TMenuItem'#13'Permutations1' + +#7'Caption'#6#12'Permutations'#0#9'TMenuItem'#2'N0'#9'AutoCheck'#9#7'Caption' + +#6#4'None'#7'Checked'#9#10'GroupIndex'#2'{'#9'RadioItem'#9#7'OnClick'#7#14'r' + +'adiomenuclick'#0#0#9'TMenuItem'#5'N1000'#3'Tag'#3#232#3#9'AutoCheck'#9#7'Ca' + +'ption'#6#4'1000'#10'GroupIndex'#2'{'#9'RadioItem'#9#7'OnClick'#7#14'radiome' + +'nuclick'#0#0#9'TMenuItem'#5'N2000'#3'Tag'#3#208#7#9'AutoCheck'#9#7'Caption' + +#6#4'2000'#10'GroupIndex'#2'{'#9'RadioItem'#9#7'OnClick'#7#14'radiomenuclick' + +#0#0#9'TMenuItem'#5'N3000'#3'Tag'#3#184#11#9'AutoCheck'#9#7'Caption'#6#4'300' + +'0'#10'GroupIndex'#2'{'#9'RadioItem'#9#7'OnClick'#7#14'radiomenuclick'#0#0#9 + +'TMenuItem'#5'N4000'#3'Tag'#3#160#15#9'AutoCheck'#9#7'Caption'#6#4'4000'#10 + +'GroupIndex'#2'{'#9'RadioItem'#9#7'OnClick'#7#14'radiomenuclick'#0#0#0#9'TMe' + +'nuItem'#6'Tests1'#7'Caption'#6#5'Tests'#0#9'TMenuItem'#9'ttestmenu'#7'Capti' + +'on'#6#6't-test'#7'OnClick'#7#13'testmenuclick'#0#0#9'TMenuItem'#6'BMmenu'#7 + +'Caption'#6#14'Brunner Munzel'#7'Checked'#9#7'OnClick'#7#13'testmenuclick'#0 + +#0#0#9'TMenuItem'#8'Threads1'#7'Caption'#6#7'Threads'#0#9'TMenuItem'#2'T1'#9 + +'AutoCheck'#9#7'Caption'#6#1'1'#7'Checked'#9#10'GroupIndex'#3#131#0#9'RadioI' + +'tem'#9#7'OnClick'#7#12'threadChange'#0#0#9'TMenuItem'#2'T2'#9'AutoCheck'#9#7 + +'Caption'#6#1'2'#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnClick'#7#12'threa' + +'dChange'#0#0#9'TMenuItem'#2'T3'#9'AutoCheck'#9#7'Caption'#6#1'3'#10'GroupIn' + +'dex'#3#131#0#9'RadioItem'#9#7'OnClick'#7#12'threadChange'#0#0#9'TMenuItem'#2 + +'T4'#9'AutoCheck'#9#7'Caption'#6#1'4'#10'GroupIndex'#3#131#0#9'RadioItem'#9#7 + +'OnClick'#7#12'threadChange'#0#0#9'TMenuItem'#2'T7'#9'AutoCheck'#9#7'Caption' + +#6#1'7'#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnClick'#7#12'threadChange'#0 + +#0#9'TMenuItem'#2'T8'#9'AutoCheck'#9#7'Caption'#6#1'8'#10'GroupIndex'#3#131#0 + +#9'RadioItem'#9#7'OnClick'#7#12'threadChange'#0#0#9'TMenuItem'#3'T15'#9'Auto' + +'Check'#9#7'Caption'#6#2'15'#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnClick' + +#7#12'threadChange'#0#0#9'TMenuItem'#3'T16'#9'AutoCheck'#9#7'Caption'#6#2'16' + +#10'GroupIndex'#3#131#0#9'RadioItem'#9#7'OnClick'#7#12'threadChange'#0#0#0#0 + +#9'TMenuItem'#10'Utilities1'#7'Caption'#6#9'Utilities'#0#9'TMenuItem'#9'niin' + +'iigz1'#7'Caption'#6#14'nii -> .nii.gz'#7'OnClick'#7#14'niiniigz1Click'#0#0#9 + ,'TMenuItem'#9'Variance1'#7'Caption'#6#14'Variance image'#7'OnClick'#7#14'Var' + +'iance1Click'#0#0#9'TMenuItem'#14'Makemeanimage2'#3'Tag'#2#1#7'Caption'#6#19 + +'Make binarized mean'#7'OnClick'#7#19'Makemeanimage1Click'#0#0#9'TMenuItem' + +#14'Makemeanimage1'#7'Caption'#6#21'Make mean/StDev image'#7'OnClick'#7#19'M' + +'akemeanimage1Click'#0#0#9'TMenuItem'#21'SingleSubjectZScores1'#7'Caption'#6 + +#22'Single Subject Z-Score'#7'OnClick'#7#26'SingleSubjectZScores1Click'#0#0#9 + +'TMenuItem'#24'IntensitynormalizationA1'#3'Tag'#2#1#7'Caption'#6#25'Intensit' + +'y normalization A'#7'OnClick'#7#13'Balance1Click'#0#0#9'TMenuItem'#8'Balanc' + +'e1'#7'Caption'#6#25'Intensity normalization B'#7'OnClick'#7#13'Balance1Clic' + +'k'#0#0#9'TMenuItem PhysiologicalArtifactCorrection1'#7'Caption'#6#24'Physio' + +'logical Correction'#7'OnClick'#7'%PhysiologicalArtifactCorrection1Click'#0#0 + +#9'TMenuItem'#20'Countlesionoverlaps1'#7'Caption'#6#21'Count lesion overlaps' + +#7'OnClick'#7#25'Countlesionoverlaps1Click'#0#0#9'TMenuItem'#4'FCE1'#7'Capti' + +'on'#6#4'TFCE'#7'OnClick'#7#9'FCE1Click'#0#0#0#9'TMenuItem'#5'Help1'#7'Capti' + +'on'#6#4'Help'#7'Visible'#8#0#9'TMenuItem'#6'About1'#7'Caption'#6#5'About'#7 + +'OnClick'#7#11'About1Click'#0#0#0#0#11'TSaveDialog'#10'SaveHdrDlg'#11'Filter' + +'Index'#2#0#4'left'#2#8#3'top'#2'('#0#0#11'TOpenDialog'#10'OpenHdrDlg'#11'Fi' + +'lterIndex'#2#0#4'left'#2#8#3'top'#2'H'#0#0#0 +]); \ No newline at end of file diff --git a/npm_precl/npmform.pas b/npm_precl/npmform.pas new file mode 100755 index 0000000..97cdc15 --- /dev/null +++ b/npm_precl/npmform.pas @@ -0,0 +1,4256 @@ +unit npmform; +{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF} +interface +{$I options.inc} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, + Messages, Classes, Graphics, Controls, Forms, Dialogs, + Menus, ComCtrls, ExtCtrls, StdCtrls, +overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr,tfce_clustering, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, + {$ELSE} + LCLType, + {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes,turbolesion +{$IFDEF compileANACOM}, anacom{$ENDIF} + +{$IFDEF benchmark}, montecarlo{$ENDIF} +; +//regmultdelphi,matrices; +type + + { TMainForm } + + TMainForm = class(TForm) + Binaryimagescontinuousgroupsfast1: TMenuItem; + Memo1: TMemo; + + Design1: TMenuItem; + FCE1: TMenuItem; + MultipleRegress: TMenuItem; + SaveText1: TMenuItem; + ROIanalysis1: TMenuItem; + OpenHdrDlg: TOpenDialog; + SaveHdrDlg: TSaveDialog; + Panel1: TPanel; + ProgressBar1: TProgressBar; + MainMenu1: TMainMenu; + About1: TMenuItem; + AssociatevalfileswithNPM1: TMenuItem; + Balance1: TMenuItem; + BinomialAnalysislesions1: TMenuItem; + BMmenu: TMenuItem; + ContinuousanalysisVBM1: TMenuItem; + Copy1: TMenuItem; + Countlesionoverlaps1: TMenuItem; + Edit1: TMenuItem; + Exit1: TMenuItem; + File1: TMenuItem; + Help1: TMenuItem; + IntensitynormalizationA1: TMenuItem; + Makemeanimage1: TMenuItem; + Makemeanimage2: TMenuItem; + N0: TMenuItem; + N1000: TMenuItem; + N2000: TMenuItem; + N3000: TMenuItem; + N4000: TMenuItem; + niiniigz1: TMenuItem; + Options1: TMenuItem; + PairedTMenu: TMenuItem; + PenalizedLogisticRegerssion1: TMenuItem; + Permutations1: TMenuItem; + PhysiologicalArtifactCorrection1: TMenuItem; + SingleRegress: TMenuItem; + SingleSubjectZScores1: TMenuItem; + T1: TMenuItem; + T15: TMenuItem; + T16: TMenuItem; + T2: TMenuItem; + T3: TMenuItem; + T4: TMenuItem; + T7: TMenuItem; + T8: TMenuItem; + Tests1: TMenuItem; + Threads1: TMenuItem; + ttestmenu: TMenuItem; + Utilities1: TMenuItem; + Variance1: TMenuItem; + VBM1: TMenuItem; + VLSM1: TMenuItem; + ComputeIntersectionandUnion1: TMenuItem; + Intensitynormalization1: TMenuItem; + Masked1: TMenuItem; + MaskedintensitynormalizationA1: TMenuItem; + MaskedintensitynormalizationB1: TMenuItem; + //Binaryimagescontinuousgroupsfast1: TMenuItem; + Binarizeimages1: TMenuItem; + Resliceimagetoneworientationandboundingbox1: TMenuItem; + Setnonseroto1001: TMenuItem; + AnaCOMmenu: TMenuItem; + MonteCarloSimulation1: TMenuItem; + Subtract1: TMenuItem; + LogPtoZ1: TMenuItem; + //FCE1: TMenuItem; + function GetKVers: string; + function GetValX (var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean; + function ThreshMap(lThresh: single; lVolVox: integer;lOutImg: singleP): integer; + function FirthNPMAnalyze (var lImages: TStrings; var lPredictorList: TStringList; var lMaskHdr: TMRIcroHdr; lnCond,lnCrit: integer; var lSymptomRA: SingleP; var lOutName: string): boolean; + procedure InitPermute (lnSubj, lnPermute: integer; var lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; var lRanOrderp: pointer; var lRanOrder: Doublep0); + function reportPermute (lLabel:string; lnPermute: integer; var lPermuteMaxZ, lPermuteMinZ: singleP): double; + procedure FreePermute (lnPermute: integer; var lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP;var lRanOrderp: pointer); + procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); + function SaveHdrName (lCaption: string; var lFilename: string): boolean; + procedure StrToMemo (lStr: string); + procedure NPMclick(Sender: TObject); + function OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; + function NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels,lnGroup1: integer): boolean; + function NPMAnalyzePaired (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels: integer): boolean; + function NPMzscore (var lImages: TStrings; var lMnHdr,lStDevHdr: TMRIcroHdr): boolean; + procedure FormCreate(Sender: TObject); + function ReportDescriptives (var RA: SingleP; n: integer): boolean; + function MakeSubtract (lPosName,lNegName: string): boolean; + function MakeMean (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lBinarize,lVariance: boolean): boolean; + function Balance (var lImageName,lMaskName: String; lMethod: integer{lInflection: boolean}): boolean; + procedure LesionBtnClick(Sender: TObject); + procedure Copy1Click(Sender: TObject); + procedure testmenuclick(Sender: TObject); + procedure radiomenuclick(Sender: TObject); + procedure ReadIniFile; + procedure WriteIniFile; + function reportBonferroni(lLabel: string; lnTests: integer): double; + function reportFDR (lLabel:string; lnVox, lnTests: integer; var lData: SingleP): double; + procedure Makemeanimage1Click(Sender: TObject); + procedure Exit1Click(Sender: TObject); + procedure Balance1Click(Sender: TObject); + procedure niiniigz1Click(Sender: TObject); + procedure Variance1Click(Sender: TObject); + procedure ZtoP1Click(Sender: TObject); + procedure About1Click(Sender: TObject); + procedure Design1Click(Sender: TObject); + procedure PhysiologicalArtifactCorrection1Click(Sender: TObject); + procedure DualImageCorrelation1Click(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure PairedTMenuClick(Sender: TObject); + procedure SingleSubjectZScores1Click(Sender: TObject); + procedure MultipleRegressClick(Sender: TObject); + function ReadPermute: integer; + procedure NPMmsg( lStr: string); + procedure NPMmsgClear; + procedure MsgSave(lFilename: string); + procedure SingleRegressClick(Sender: TObject); + procedure AssociatevalfileswithNPM1Click(Sender: TObject); + procedure threadChange(Sender: TObject); + procedure Countlesionoverlaps1Click(Sender: TObject); + procedure PenalizedLogisticRegerssion1Click(Sender: TObject); + procedure ComputeIntersectionandUnion1Click(Sender: TObject); + procedure ROCbinomialdeficit1Click(Sender: TObject); + procedure ROCcontinuousdeficit1Click(Sender: TObject); + procedure ThreadDone(Sender: TObject); + procedure NPMmsgAppend( lStr: string); + procedure ROIanalysis1Click(Sender: TObject); + procedure Masked1Click(Sender: TObject); + procedure Binarizeimages1Click(Sender: TObject); + procedure Resliceimagetoneworientationandboundingbox1Click( + Sender: TObject); + procedure Setnonseroto1001Click(Sender: TObject); + procedure Savetext1Click(Sender: TObject); + procedure AnaCOMmenuClick(Sender: TObject); + procedure MonteCarloSimulation1Click(Sender: TObject); + procedure Subtract1Click(Sender: TObject); + procedure LogPtoZ1Click(Sender: TObject); + procedure FCE1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + MainForm: TMainForm; +implementation + +uses filename,prefs,roc,hdr,regression,valformat {$IFDEF SPREADSHEET} ,design,spread{$ENDIF} +{$IFNDEF UNIX},ActiveX {$ENDIF}; +{$IFNDEF FPC} +{$R *.DFM} + + {$ENDIF} +const + kVers : string = 'Chris Rorden''s NPM :: '+kMRIcronVers; +var +gNULP: boolean = true; +gROI : boolean = false; +gTFCE: integer; +function TMainForm.GetKVers: string; +begin + result := kVers +'; Threads used = '+inttostr(gnCPUThreads ); +end; + + +procedure TMainForm.NPMmsgAppend( lStr: string); +var + lOutname: string; + f: TextFile; +begin + MainForm.Memo1.Lines.add(lStr); + lOutname:='c:\dx.txt'; + if fileexists(lOutname) then begin { open a text file } + AssignFile(f, lOutname); + Append(f); + Writeln(f, lStr); + Flush(f); { ensures that the text was actually written to file } + { insert code here that would require a Flush before closing the file } + CloseFile(f); + end; +end; + +procedure TMainForm.NPMmsg( lStr: string); +begin + MainForm.Memo1.Lines.add(lStr); +end; + +procedure Msg(lStr: string); +begin + MainForm.NPMmsg(lStr); +end; + +procedure MsgClear; +begin + MainForm.Memo1.Lines.Clear; +end; + +procedure TMainForm.NPMmsgClear; +begin + MsgClear; +end; + + +procedure TMainForm.MsgSave(lFilename: string); +var + i: integer; + f: textfile; +begin + if (Memo1.Lines.Count < 1) then exit; + if fileexists(lFilename) then begin + AssignFile(f, lFilename); + {$I-} + append(f); + {$I+} + if IOResult= 0 then + for i:= 0 to Memo1.Lines.Count- 1 do + WriteLn(f, Memo1.Lines[i]); + CloseFile(f); + end else + MainForm.Memo1.Lines.SaveToFile(lFilename); +end; + +procedure TMainForm.ThreadDone(Sender: TObject); +begin + Dec(gThreadsRunning); +end; + +procedure InitRA (lnPermute: integer; var lRA: singleP); +var + lInc: integer; +begin + getmem(lRA,lnPermute* sizeof(single)); + for lInc := 1 to lnPermute do + lRA^[lInc] := 0; +end; + +procedure TMainForm.InitPermute (lnSubj, lnPermute: integer; var lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; var lRanOrderp: pointer; var lRanOrder: Doublep0); +begin + if (lnPermute < 2) then + exit; + InitRA(lnPermute,lPermuteMaxT); + InitRA(lnPermute,lPermuteMinT); + InitRA(lnPermute,lPermuteMaxBM); + InitRA(lnPermute,lPermuteMinBM); + createArray64(lRanOrderp,lRanOrder,lnSubj); +end; //init permute + +procedure sort (lo, up: integer; var r:SingleP); +//62ms Shell Sort http://www.dcc.uchile.cl/~rbaeza/handbook/algs/4/414.sort.p.html +label 999; +var d, i, j : integer; + tempr : single; +begin + d := up-lo+1; + while d>1 do begin + if d<5 then + d := 1 + else + d := trunc( 0.45454*d ); + //Do linear insertion sort in steps size d + for i:=up-d downto lo do begin + tempr := r^[i]; + j := i+d; + while j <= up do + if tempr > r^[j] then begin + r^[j-d] := r^[j]; + j := j+d + end + else goto 999; //break + 999: + r^[j-d] := tempr + end //for + end //while +end; //proc Sort + +function IndexPct(lnPermute: integer; lPct: single; lTop: boolean): integer; +begin + result := round(lnPermute * lPct); + if lTop then + result := (lnPermute - result)+1; + if (result < 1) then + result := 1; + if (result > lnPermute) then + result := lnPermute; +end; + +function TMainForm.reportBonferroni(lLabel: string; lnTests: integer): double; //returns 5% Z score +begin + if lnTests < 1 then exit; + result := pNormalInv(0.05/lnTests); + msg(inttostr(lnTests)+' test '+lLabel+' Bonferroni FWE Z '+ + '0.050='+realtostr(result,3)+ + ', 0.025='+realtostr(pNormalInv(0.025/lnTests),3)+ + ', 0.01='+realtostr(pNormalInv(0.01/lnTests),3)); +end; + +function TMainForm.reportFDR (lLabel:string; lnVox, lnTests: integer; var lData: SingleP): double; +var + lC,lN: integer; + lPs: SingleP; + lFDR05r, lFDR01r,lFDR05p, lFDR01p,lMin,lMax : double; +begin + result := 10000; + if (lnTests < 1) or (lnVox < 1) then + exit; + GetMem(lPs,lnTests*sizeof(single)); + for lC := 1 to lnTests do + lPs^[lC] := 0; + lN := 0; + lMin := 0; + lMax := 0; + for lC := 1 to lnVox do begin + if lData^[lC] <> 0 then begin + inc(lN); + if lData^[lC] > lMax then lMax := lData^[lC] + else if lData^[lC] < lMin then lMin := lData^[lC]; + if lN <= lnTests then + lPs^[lN] := pNormal(lData^[lC]); + end; + end; + EstimateFDR2(lnTests, lPs, lFDR05p, lFDR01p,lFDR05r, lFDR01r); + msg(lLabel+' Range ' + +realtostr(lMin,3)+ + '...'+realtostr(lMax,3)); + {Msg(lLabel+' Range ' + +realtostr(pNormalInv(lPs[lnTests]),3)+ + '...'+realtostr(pNormalInv(lPs[1]),3)+ + ' '); } //we could use this and save time computing lmin/lmax, but loss in precision + msg(lLabel+' +FDR Z '+ + '0.050='+realtostr(pNormalInv(lFDR05p),8)+ + ', 0.01='+realtostr(pNormalInv(lFDR01p),8)+ + ' '); + msg(lLabel+' -FDR Z '+ + '0.050='+realtostr(pNormalInv(1-lFDR05r),8)+ + ', 0.01='+realtostr(pNormalInv(1-lFDR01r),8)+ + ' '); + result := pNormalInv(lFDR01p); +end; + +function ReportThresh (lLabel: string; lnPermute: integer; var lRankedData: singleP;lTop:boolean): double; +begin + result := lRankedData^[IndexPct(lnPermute,0.050,lTop)]; + msg(lLabel+': permutationFWE '+ + //'0.500='+realtostr(lRankedData[IndexPct(lnPermute,0.500,lTop)],3)+ + ', 0.050='+realtostr({lRankedData^[IndexPct(lnPermute,0.050,lTop)]} result,8)+ + ', 0.025='+realtostr(lRankedData^[IndexPct(lnPermute,0.025,lTop)],8)+ + ', 0.01='+realtostr(lRankedData^[IndexPct(lnPermute,0.010,lTop)],8)+ + ' '); +end; + +function TMainForm.reportPermute (lLabel:string; lnPermute: integer; var lPermuteMaxZ, lPermuteMinZ: singleP): double; +begin + result := 0; + if (lnPermute < 2) then + exit; + sort (1, lnPermute,lPermuteMaxZ); + result := ReportThresh(lLabel+'+',lnPermute,lPermuteMaxZ,true); + sort (1, lnPermute,lPermuteMinZ); + ReportThresh(lLabel+'-',lnPermute,lPermuteMinZ,false); + //for lPos := 1 to lnPermute do + // msg(inttostr(lPos)+', '+realtostr(lPermuteMinZ[lPos],4)); + +end; + +procedure TMainForm.FreePermute (lnPermute: integer; var lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP;var lRanOrderp: pointer); +begin + if (lnPermute < 2) then + exit; + Freemem(lRanOrderp); + Freemem(lPermuteMaxT); + Freemem(lPermuteMinT); + Freemem(lPermuteMaxBM); + Freemem(lPermuteMinBM); +end; + +function TMainForm.SaveHdrName (lCaption: string; var lFilename: string): boolean; +begin + result := false; + SaveHdrDlg.InitialDir := lFilename; + SaveHdrDlg.Title := lCaption; + SaveHdrDlg.Filter := kAnaHdrFilter; + if not SaveHdrDlg.Execute then exit; + lFilename := SaveHdrDlg.Filename; + result := true; +end; + +procedure TMainForm.FormClose(Sender: TObject; var CloseAction: TCloseAction); +begin + //showmessage('zz'); + WriteIniFile; +end; + +procedure MakeStatHdr (var lBGHdr,lStatHdr: TniftiHdr; lMinIntensity,lMaxIntensity,lIntent_p1,lIntent_p2,lIntent_p3: single; lIntent_code: smallint;lIntentName: string); +var lIntentNameLen,lPos: integer; + lStr: string; +begin + move(lBGHdr,lStatHdr,sizeof(TniftiHdr)); + with lStatHdr do begin + magic :=kNIFTI_MAGIC_SEPARATE_HDR; + bitpix := 32; //32-bit real data + datatype := kDT_FLOAT; + scl_slope:= 1; + scl_inter:= 0; + glmin := round(lMinIntensity); + glmax := round(lMaxIntensity); + intent_code := lIntent_Code;// kNIFTI_INTENT_ESTIMATE; + intent_p1 := lIntent_p1; + intent_p2 := lIntent_p2; + intent_p3 := lIntent_p3; + lIntentNameLen := length(lIntentName); + descrip[1] := 'N'; + descrip[2] := 'P'; + descrip[3] := 'M'; + if lIntent_code=kNIFTI_INTENT_TTEST then begin + descrip[4] := 't' ; + lStr := inttostr(trunc(lIntent_p1)); + for lPos := 1 to length (lStr) do + descrip[4+lPos] := lStr[lPos] ; + end else + descrip[4] := 'z'; + if lIntentNameLen > sizeof(intent_name) then + lIntentNameLen := sizeof(intent_name); + if lIntentNameLen > 0 then + for lPos := 1 to lIntentNameLen do + intent_name[lPos] := lIntentName[lPos]; + end; +end; + +procedure WriteThread( lnThread: integer); +begin + case lnThread of + 2: MainForm.T2.checked := true; + 3: MainForm.T3.checked := true; + 4: MainForm.T4.checked := true; + 7: MainForm.T7.checked := true; + 8: MainForm.T8.checked := true; + 15: MainForm.T15.checked := true; + 16: MainForm.T16.checked := true; + else MainForm.T1.checked := true; + end; + gnCPUThreads := lnThread; +end; + +function ReadThread: integer; +begin + if MainForm.T16.checked then result := 16 + else if MainForm.T15.checked then result := 15 + else if MainForm.T8.checked then result := 8 + else if MainForm.T7.checked then result := 7 + else if MainForm.T4.checked then result := 4 + else if MainForm.T3.checked then result := 3 + else if MainForm.T2.checked then result := 2 + else result := 1; + gnCPUThreads := result; +end; + + +procedure WritePermute( lnPermute: integer); +begin + case lnPermute of + 4000: MainForm.N4000.checked := true; + 3000: MainForm.N3000.checked := true; + 2000: MainForm.N2000.checked := true; + 1000: MainForm.N1000.checked := true; + else MainForm.N0.checked := true; + end; +end; + +function TMainForm.ReadPermute: integer; +begin + if MainForm.N4000.checked then result := 4000 + else if MainForm.N3000.checked then result := 3000 + else if MainForm.N2000.checked then result := 2000 + else if MainForm.N1000.checked then result := 1000 + else result := 0; +end; + +(*function LoadImgX(lInName: string; lImgData: SingleP; lStart, lEnd,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +var + lInc: integer; +begin + //LoadImgX(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox); + for lInc := 1 to ((lEnd{+1})-lStart) do + lImgData^[lRApos+lInc-1] := 123; + msg(inttostr(lRApos+1-1)+' '+inttostr(lRApos+((lEnd+1)-lStart)-1) ); +end;*) + +function TMainForm.NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels,lnGroup1: integer): boolean; + +label + 667; +var + lOutName,lOutNameMod: string; + lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lDummy: SingleP; + lTotalMemory: double; //not integer - limit for 32bit int is 2Gb + lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lThreadStart,lThreadEnd,lThreadInc: integer; + lT, lSum, lMn: double; + lStatHdr: TNIfTIhdr; + lFdata: file; + lThread,lnPermute: integer; + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lttest,lBM: boolean; +begin + + result := false; + lttest:= ttestmenu.checked; + lBM := BMmenu.checked; + lnPermute := ReadPermute; + //lnPermute := 100; + msg('Permutations = ' +IntToStr(lnPermute)); + lOutName := lMaskHdr.ImgFileName; + if not SaveHdrName ('Statistical Map', lOutName) then exit; + msg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + //load mask + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(gOffsetRA[0]),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + msg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + //next find start and end of mask + lPos := 0; + repeat + inc(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = lVolVox); + lMinMask := lPos; + lPos := lVolVox+1; + repeat + dec(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = 1); + lMaxMask := lPos; + if lMaxMask = 1 then begin + msg('Mask appears empty' +lMaskHdr.ImgFileName); + goto 667; + end; + msg('Mask has voxels from '+inttostr(lMinMask)+'..'+inttostr(lMaxMask)); + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + msg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + msg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + + getmem(lOutImgMn,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgMn^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + ClearThreadData(gnCPUThreads,lnPermute); + + for lPlank := 1 to lnPlanks do begin + msg('Computing plank = ' +Inttostr(lPlank)); + Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //showmessage('stop'); + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TNNStat.Create (ProgressBar1,lttest,lBM,0, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lnGroup1, lMaskImg,lPlankImg,lOutImgMn,lOutImgBM,lOutImgT,lDummy) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + msg('Voxels tested = ' +Inttostr(lnVoxTested)); + reportBonferroni('Std',lnVoxTested); + //next: save data +(*savedata*) + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save mean + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mean','.hdr'); + if lnVoxTested > 1 then + + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + +if (lttest) and (lnVoxTestED > 1 ) then begin //save Ttest + //reportRange ('ttest', lVolVox, lnVoxTested, lOutImgT); + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + + reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + reportPermute('ttest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); +end; +if (lBM) and (lnVoxTested > 1 ) then begin //save Brunner Munzel + reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + reportPermute('BM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM','.hdr'); + + {reportFDR ('absT', lVolVox, lnVoxTested, lOutImgBM); + reportPermute('absT',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'absT','.hdr'); + } + //NIFTIhdr_SaveHdr(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr)); + lOutNameMod := changefileext(lOutNameMod,'.img'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); +end;(**) +//next: close images + FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgMn); + //freemem(lObsp); + freemem(lMaskImg); + freemem(lPlankImg); + msg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + MsgSave(lOutNameMod); + ProgressBar1.Position := 0; + result := true; + exit; +667: //you only get here if you aborted ... free memory and report error + if lVolVox > 1 then freemem(lMaskImg); + if lTotalMemory > 1 then freemem(lPlankImg); + msg('Unable to complete analysis.'); + ProgressBar1.Position := 0; +end; + +function TMainForm.NPMAnalyzePaired (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lMaskVoxels: integer): boolean; +label + 667; +var + lOutName,lOutNameMod: string; + lMaskImg,lPlankImg,lOutImgMn,lOutImgT,lDummy,lDummy2: SingleP; + lTotalMemory: double; //not integer - limit for 32bit int is 2Gb + lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lThreadStart,lThreadEnd,lThreadInc: integer; + lT, lSum, lMn: double; + lStatHdr: TNIfTIhdr; + lFdata: file; + lThread,lnPermute: integer; + lPermuteMaxT, lPermuteMinT: singleP; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + //lnPermute := ReadPermute; + lnPermute := 0;//not yet + msg('Permutations = ' +IntToStr(lnPermute)); + lOutName := lMaskHdr.ImgFileName; + if not SaveHdrName ('Statistical Map', lOutName) then exit; + msg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + //load mask + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(gOffsetRA[0]),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + msg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + //next find start and end of mask + lPos := 0; + repeat + inc(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = lVolVox); + lMinMask := lPos; + lPos := lVolVox+1; + repeat + dec(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = 1); + lMaxMask := lPos; + if lMaxMask = 1 then begin + Msg('Mask appears empty' +lMaskHdr.ImgFileName); + goto 667; + end; + Msg('Mask has voxels from '+inttostr(lMinMask)+'..'+inttostr(lMaxMask)); + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + Msg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + Msg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + getmem(lOutImgMn,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + //not yet InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgMn^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + ClearThreadData(gnCPUThreads,lnPermute); + for lPlank := 1 to lnPlanks do begin + Msg('Computing plank = ' +Inttostr(lPlank)); + Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TPairedTStat.Create (ProgressBar1,false,false,0, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,666, lMaskImg,lPlankImg,lOutImgMn,lDummy2,lOutImgT,lDummy) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadDataLite(gnCPUThreads);//not yet SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + Msg('Voxels tested = ' +Inttostr(lnVoxTested)); + reportBonferroni('Std',lnVoxTested); + //next: save data +(*savedata *) + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save mean + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mean','.hdr'); + if lnVoxTested > 1 then + + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + +if (lnVoxTestED > 1 ) then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],(lImages.Count div 2)-1); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + + reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + reportPermute('ttest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); +end; +//next: close images + //not yet FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgMn); + //freemem(lObsp); + freemem(lMaskImg); + freemem(lPlankImg); + Msg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + MsgSave(lOutNameMod); + ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lVolVox > 1 then freemem(lMaskImg); + if lTotalMemory > 1 then freemem(lPlankImg); + Msg('Unable to complete analysis.'); + ProgressBar1.Position := 0; +end; + + + +function TMainForm.OpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; +var + lNumberofFiles: integer; +begin + OpenHdrDlg.Filter := lFilter;//kAnaHdrFilter;//lFilter; + OpenHdrDlg.FilterIndex := 1; + OpenHdrDlg.Title := lCaption; + if lAllowMultiSelect then + OpenHdrDlg.Options := [ofAllowMultiSelect,ofFileMustExist] + else + OpenHdrDlg.Options := [ofFileMustExist]; + result := OpenHdrDlg.Execute; + if not result then exit; + if lForceMultiSelect then begin + lNumberofFiles:= OpenHdrDlg.Files.Count; + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + result := false; + end; + end; +end; + + + +procedure TMainForm.NPMclick(Sender: TObject); +label + 666; +var + lnGroup1,lMaskVoxels: integer; + lG: TStrings; + lMaskname: string; + lMaskHdr: TMRIcroHdr; +begin + if (not ttestmenu.checked) and (not BMmenu.checked) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + MsgClear; + Msg(GetKVers); + Msg('Threads: '+inttostr(gnCPUThreads)); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + exit; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading mask.'); + exit; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + exit; + end; + Msg('Mask name = '+ lMaskname); + Msg('Total voxels = '+inttostr(lMaskVoxels)); + //next, get 1st group + if not OpenDialogExecute('Select postive group (Z scores positive if this group is brighter)',true,true,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; //not sure why TStrings.Create does not work??? + lG.addstrings(OpenHdrDlg.Files); + lnGroup1 :=OpenHdrDlg.Files.Count; + Msg('Scans in Group 1 = '+inttostr(lnGroup1)); + //next, get 2nd group + if not OpenDialogExecute('Select negative group (Z scores negative if this group is brighter)',true,true,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + goto 666; + end; //if not selected + lG.addstrings(OpenHdrDlg.Files); + if not CheckVoxelsGroupX(lG,lMaskHdr {lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + Msg('Scans in Group 2 = '+inttostr(lG.count-lnGroup1)); + NPMAnalyze(lG,lMaskHdr,lMaskVoxels,lnGroup1); + 666: + lG.Free; +end; + +function TMainForm.ThreshMap(lThresh: single; lVolVox: integer;lOutImg: singleP): integer; +var + lVox: integer; +begin + result := 0; + for lVox := 1 to lVolVox do + if lOutImg^[lVox] >= lThresh then + inc(result); + + for lVox := 1 to lVolVox do + if lOutImg^[lVox] >= lThresh then + lOutImg^[lVox] := 1 + else + lOutImg^[lVox] := 0; +end; + +{x$DEFINE NOTmedianfx} +(*function TMainForm.LesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun: integer; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lPos,lPlank,lThread: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lttest,lBM: boolean; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + lttest:= ttestmenu.checked; + lBM := BMmenu.checked; + lnPermute := ReadPermute; + Msg('Permutations = ' +IntToStr(lnPermute)); + Msg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + Msg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + Msg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + //next create permuted BM bounds + if lBM then begin + Msg('Generating BM permutation thresholds'); + Refresh; + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lImages.Count, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + Msg('Computing plank = ' +Inttostr(lPlank)); + Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TLesionContinuous.Create (ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,nil,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + Msg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + + Msg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + Msg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + Msg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + Msg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + reportBonferroni('Std',lnVoxTested); + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + reportPermute('ttest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest'+lFactName,'.hdr'); + if lRun > 0 then + Msg('threshtt,'+inttostr(lRun)+','+inttostr(ThreshMap(lThresh,lVolVox,lOutImgT))+','+realtostr(lThresh,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Mann Whitney + lThresh := reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + reportPermute('BM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM'+lFactName,'.hdr'); + if lRun > 0 then + Msg('threshbm,'+inttostr(lRun)+','+inttostr(ThreshMap(lThresh,lVolVox,lOutImgBM))+','+realtostr(lThresh,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + +end; +//next: free dynamic memory +123: + FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + Msg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MsgSave(lOutNameMod); + ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + Msg('Unable to complete analysis.'); + ProgressBar1.Position := 0; +end; //LesionNPMAnalyze *) + + +(*function TMainForm.LesionNPMAnalyzeBinomial (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit: integer; var lSymptomRA: SingleP; var lFactname,lOutName: string): boolean; +label + 123,667; +var + lVal: single; + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgL,lDummyImg, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lPos,lPlank,lThread,lnDeficit: integer; + lTotalMemory,lVolVox,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadInc,lThreadEnd, lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT, lSum: double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + lnPermute := ReadPermute; + Msg('Permutations = ' +IntToStr(lnPermute)); + //lOutName := lMaskHdr.ImgFileName; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + Msg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + Msg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + Msg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgL,lVolVox* sizeof(single)); + InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgL^[lPos] := 0; + end; + ClearThreadDataPvals(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + ProgressBar1.Position := 1; + Msg('Computing plank = ' +Inttostr(lPlank)); + Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + //with TLesionBinomial.Create (ProgressBar1,false,true,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,666, lDummyImg,lPlankImg,lOutImgSum,lOutImgL,lDummyImg,lSymptomRA) do + with TLesionBinom.Create (ProgressBar1,false,true,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgL,lDummyImg,nil,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + Msg('Thread ' +Inttostr(gThreadsRunning)+' = '+inttostr(lThreadStart)+'..'+inttostr(lThreadEnd)); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + for lPos := 1 to lnPermute do begin + if (lPermuteMinT^[lPos] > 1.1) or (lPermuteMinT^[lPos] < -1.1) then + lPermuteMinT^[lPos] := 0.5; + if (lPermuteMaxT^[lPos] > 1.1) or (lPermuteMaxT^[lPos] < -1.1) then + lPermuteMaxT^[lPos] := 0.5; + lVal := lPermuteMaxT^[lPos]; + lPermuteMaxT^[lPos] := lPermuteMinT^[lPos]; + lPermuteMinT^[lPos] := lVal; + if lPermuteMaxT^[lPos] < 0 then + lPermuteMaxT^[lPos] := -pNormalInv(abs(lPermuteMaxT^[lPos])) + else + lPermuteMaxT^[lPos] := pNormalInv(lPermuteMaxT^[lPos]); + if lPermuteMinT^[lPos] < 0 then + lPermuteMinT^[lPos] := -pNormalInv(abs(lPermuteMinT^[lPos])) + else + lPermuteMinT^[lPos] := pNormalInv(lPermuteMinT^[lPos]); + end; + + + + if lnVoxTested < 1 then begin + Msg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + //next report findings + Msg('Voxels tested = ' +Inttostr(lnVoxTested)); + Msg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + reportBonferroni('Std',lnVoxTested); + //next: save data +//savedata + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//future images will store Z-scores... + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +//save power map + lnDeficit := 0; + for lPos := 1 to lImages.Count do + if lSymptomRA^[lPos] = 0 then + inc(lnDeficit); + if Sum2Power(lOutImgSum,lVolVox,lImages.Count,lnDeficit) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + // MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + //save Liebermeister + + lOutNameMod := ChangeFilePostfixExt(lOutName,'L'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgL,1); + //save end + reportFDR ('L', lVolVox, lnVoxTested, lOutImgL); + reportPermute('L',lnPermute,lPermuteMaxT, lPermuteMinT); + +123: +//next: free dynamic memory + FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgL); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + Msg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MsgSave(lOutNameMod); + + ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + Msg('Unable to complete analysis.'); + ProgressBar1.Position := 0; +end; *) + + +function TMainForm.GetValX (var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean; +//warning: you MUST free lPredictorList +var + lVALFilename {,lTemplateName}: string; + lCritPct: integer; +begin + lPredictorList := TStringList.Create; + result := false; + lnSubj := 0; + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + showmessage('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lVALFilename := MainForm.OpenHdrDlg.Filename; + result := GetValCore ( lVALFilename, lnSubj, lnFactors, lSymptomRA, lImageNames, lCrit,lCritPct{,binom},lPredictorList); +end; + + +function TMainForm.ReportDescriptives (var RA: SingleP; n: integer): boolean; +var lMn,lSD,lSE,lSkew,lZSkew: double; +begin + SuperDescriptive (RA, n, lMn,lSD,lSE,lSkew,lZSkew); + Msg('mean='+floattostr(lMn)+',StDev='+floattostr(lSD)+',StEr='+floattostr(lSE)+',Skew='+floattostr(lSkew)+',ZSkew='+floattostr(lZSkew)); +end; + +(*function noVariance (lRA: singlep; lnSubj: integer): boolean; +var + lI : integer; +begin + result := false; + if lnSubj < 2 then exit; + for lI := 2 to lnSubj do + if lRA^[1] <> lRA^[lI] then + exit; + result := true; +end; *) + +(*procedure TMainForm.LesionBtnClick(Sender: TObject); +label + 666; +var + lBinomial: boolean; + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + lBinomial := not odd( (Sender as tMenuItem).tag); + if (not lBinomial) and (not ttestmenu.checked) and (not BMmenu.checked) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit{,binom},lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + if not CheckVoxelsGroup(lImageNamesAll,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + for lFact := 1 to lnFactors do begin + MsgClear; + Msg(GetKVers); + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + if (not lBinomial) or (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 0) OR (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 1) THEN begin + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + end else begin + Msg('Data rejected: behavior must be zero or one for binomial test '+lImageNamesAll.Strings[lSubj-1]); + end; + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + if (not lBinomial) or (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 0) OR (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 1) THEN + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + Msg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + Msg('Factor = '+lFactname); + For lSubj := 1 to lnSubj do + Msg (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + Msg('Total voxels = '+inttostr(lMaskVoxels)); + Msg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + Msg('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroup(lImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + if noVariance (lSymptomRA,lnSubj) then + Msg('Error no variability in behavioral data ') + else if lBinomial then + LesionNPMAnalyzeBinomial2(lImageNames,lMaskHdr,lnCrit,MainForm.ReadPermute,lSymptomRA,lFactname,lOutName) + else begin + ReportDescriptives(lSymptomRA,lnSubj); + LesionNPMAnalyze2(lImageNames,lMaskHdr,lnCrit,-1,MainForm.ReadPermute,lSymptomRA,lFactName,lOutname,ttestmenu.checked,BMmenu.checked); + end; + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); +end; *) + +procedure TMainForm.Copy1Click(Sender: TObject); +begin + Memo1.SelectAll; + Memo1.CopyToClipboard; + +end; + +procedure TMainForm.testmenuclick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; +end; + +procedure TMainForm.radiomenuclick(Sender: TObject); +begin + (sender as tmenuitem).checked := true; +end; + +procedure ComputePlankSize; +begin + if kPlankMB < 128 then + kPlankMB := 128; + if kPlankMB > 2000 then + kPlankMB := 2000; //we use signed 32-bit pointers, so we can not exceed 2Gb + kPlankSz :=1024 {bytes/kb} * 1024 {bytes/mb} * kPlankMB; + kVers := kVers + ' CacheMB = '+inttostr(kPlankMB); +end; + +procedure TMainForm.ReadIniFile; +var + lFilename: string; + lThreads: integer; + lIniFile: TIniFile; +begin + lFilename := IniName; + if not FileexistsEx(lFilename) then + exit; + lIniFile := TIniFile.Create(lFilename); + ttestmenu.checked := IniBool(lIniFile,'computettest',true); + //welchmenu.checked := IniBool(lIniFile,'computewelch',true); + BMmenu.checked := IniBool(lIniFile,'computebm',false); + gNULP := IniBool(lIniFile,'countlesionpatterns',false); + gROI := IniBool(lIniFile,'ROI',false); + gTFCE := IniInt(lIniFile,'TFCE',0); + kPlankMB := IniInt(lIniFile,'CacheMB',512); + + WritePermute(IniInt(lIniFile,'nPermute',0)); + lThreads := IniInt(lIniFile,'nThread', gnCPUThreads ); + if lThreads > gnCPUThreads then + lThreads := gnCPUThreads; + gnCPUThreads := lThreads; + lIniFile.Free; +end; //ReadIniFile + +procedure TMainForm.WriteIniFile; +var + lIniName: string; + lIniFile: TIniFile; +begin +//showmessage('aaa'); + lIniName := IniName; + if (DiskFreeEx(lIniName) < 1) then + exit; + lIniFile := TIniFile.Create(lIniName); + lIniFile.WriteString('BOOL', 'computettest',Bool2Char(ttestmenu.checked)); + lIniFile.WriteString('BOOL', 'countlesionpatterns',Bool2Char(gNULP)); + lIniFile.WriteString('BOOL', 'ROI',Bool2Char(gROI)); + + //lIniFile.WriteString('BOOL', 'computewelch',Bool2Char(welchmenu.checked)); + lIniFile.WriteString('BOOL', 'computebm',Bool2Char(BMmenu.checked)); + lIniFile.WriteString('INT', 'TFCE',inttostr(gTFCE)); + lIniFile.WriteString('INT', 'CacheMB',inttostr(kPlankMB)); + lIniFile.WriteString('INT', 'nPermute',inttostr(ReadPermute)); + lIniFile.WriteString('INT', 'nThread',inttostr(ReadThread)); + lIniFile.Free; +end; + + + +procedure TMainForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + File1.visible := false;//for OSX, exit is in the application's menu + //Edit1.visible := false;//clipboard note yet working for OSX + {$ENDIF} + {$IFDEF FPC} + Application.ShowButtonGlyphs := sbgNever; + {$ENDIF} + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + BinomialAnalysislesions1.ShortCut := ShortCut(Word('B'), [ssMeta]); + Binaryimagescontinuousgroupsfast1.ShortCut := ShortCut(Word('L'), [ssMeta]); + Design1.ShortCut := ShortCut(Word('D'), [ssMeta]); + ContinuousanalysisVBM1.ShortCut := ShortCut(Word('V'), [ssMeta]); + MultipleRegress.ShortCut := ShortCut(Word('R'), [ssMeta]); + Makemeanimage1.ShortCut := ShortCut(Word('M'), [ssMeta]); + About1.ShortCut := ShortCut(Word('A'), [ssMeta]); + {$ENDIF}//Carbon + {$ENDIF}//Darwin + gnCPUThreads := GetLogicalCpuCount; + (*if (ssShift in KeyDataToShiftState(vk_Shift)) then begin + case MessageDlg('Shift key down during launch: do you want to reset the default preferences?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrNo: ReadIniFile; + end; //case + end else *) + if not ResetDefaults then + ReadIniFile; + WriteThread(gnCPUThreads); + ComputePlankSize; + // ROIanalysis1.visible := gROI; + {$IFDEF compileANACOM} + AnaCOMmenu.visible := gROI; + {$ENDIF} +end; + + + + +function TMainForm.MakeMean (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lBinarize,lVariance : boolean): boolean; +label + 667; +var + lOutName,lOutNameMod: string; + lCountRA,lOutImgMn,lOutStDev,lPlankImg: SingleP; + lTotalMemory: double; + lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: integer; + lStDev: boolean; + lT, lSum,lSumSqr,lSD, lMn,lTotalSum,lTotalN: double; + lStatHdr: TNIfTIhdr; + lFdata: file; +begin + result := false; + if not SaveHdrName ('Output image', lOutName) then exit; + if (not lVariance) and (not lBinarize) then + lStDev := true + else + lStDev := false; + if lStDev then + lStDev := OKMsg('Create a standard deviation image as well as a mean image?'); + Msg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + Msg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + Msg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + // fx(kPlankSz,8888); + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + Msg('Number of scans = '+inttostr(lImages.count)); + Msg(' Index,Filename,Intercept,Slope'); + if lBinarize then begin + getmem(lCountRA,lImages.Count*sizeof(single)); + for lPos := 1 to lImages.Count do begin + gInterceptRA[lPos] := 0; + gScaleRA[lPos] := 1; + lCountRA^[lPos] := 0; + end; + end else begin + for lPos := 1 to lImages.Count do begin + Msg(' '+inttostr(lPos)+','+lImages[lPos-1]+','+realtostr(gInterceptRA[lPos],4)+','+realtostr(gScaleRA[lPos],4)); + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + end; + end; + + lTotalSum := 0; + lTotalN := 0; + //createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgMn,lVolVox* sizeof(single)); + if lStDev then + getmem(lOutStDev,lVolVox* sizeof(single)); + for lPlank := 1 to lnPlanks do begin + Msg('Computing plank = ' +Inttostr(lPlank)); + Refresh; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lPosPct := lVoxPerPlank div 100; + for lPos2 := 1 to lVoxPerPlank do begin + if (lPos2 mod lPosPct) = 0 then begin + ProgressBar1.Position := round((lPos2/lVoxPerPlank)*100); + Application.Processmessages; + end; + lPos2Offset := lPos2+lStartVox-1; + lSum := 0; + if lVariance then begin + lSum := sqr(lPlankImg^[lPos2]-lPlankImg^[lVoxPerPlank+lPos2]);//actually variance... + //% signal + //if lPlankImg[lVoxPerPlank+lPos2] <> 0 then + + // lSum := lPlankImg[lPos2]/lPlankImg[lVoxPerPlank+lPos2] + //else + // lSum := 0;//pct signal... + //end % signal + lOutImgMn^[lPos2Offset] := lSum; + lTotalSum := lTotalSum + lOutImgMn^[lPos2Offset]; + lTotalN := lTotalN + 1; + end else begin //not variance + + if lBinarize then begin + for lPos := 1 to lImages.Count do + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] <> 0 then begin + lSum := lSum+1; + lCountRA^[lPos] := lCountRA^[lPos] + 1; + end; + end else + for lPos := 1 to lImages.Count do + lSum := lSum +(gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + // fx(lPos, gScaleRA[lPos],gInterceptRA[lPos]); + lOutImgMn^[lPos2Offset] := lSum/lImages.Count; + if lStDev then begin + //lSum := 0; + //for lPos := 1 to lImages.Count do + // lSum := lSum + (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSumSqr := 0; + for lPos := 1 to lImages.Count do + lSumSqr := lSumSqr + Sqr((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]); + lSD := (lSumSqr - ((Sqr(lSum))/lImages.Count)); + if (lSD > 0) then + lSD := Sqrt ( lSD/(lImages.Count-1)) + else begin + lSD := 0; + (*if l1stError then begin + for lPos := 1 to lImages.Count do + Msg(floattostr( (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos])); + msg('---'); + msg(floattostr(lSum)); + msg(floattostr(lSumSqr)); + + l1stError := false; + end;*) + end; + lOutStDev^[lPos2Offset] := lSD; + end; + end; //not variance + if lSum > 0 then begin + lTotalSum := lTotalSum + lOutImgMn^[lPos2Offset]; + lTotalN := lTotalN + 1; + end; + + end; + lStartVox := lEndVox + 1; + end; + if lBinarize then begin + for lPos := 1 to lImages.Count do begin + Msg(' '+inttostr(lPos)+','+lImages[lPos-1]+','+inttostr(round(lCountRA^[lPos])) ); + + lCountRA^[lPos] := 0; + end; + freemem(lCountRA); + end; //if binar + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save mean + + +if lVariance then + lOutNameMod := ChangeFilePostfixExt(lOutName,'var','.hdr') +else + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mean','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); + freemem(lOutImgMn); + if lStDev then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'StDev','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutStDev,1); + freemem(lOutStDev); + end; + + //freemem(lObsp); + freemem(lPlankImg); + Msg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + MsgSave(lOutNameMod); + if (lTotalN > 0) then + Msg('num voxels >0 = ' +inttostr(round(lTotalN))+' mean value for voxels >0: '+floattostr(lTotalSum/lTotalN)); + + ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + Msg('Unable to complete analysis.'); + ProgressBar1.Position := 0; +end; + +function ApplyTFCE (lImageName: string): boolean; +var + lImg: SingleP; + lHdr: TMRIcroHdr; + lVolVox: integer; + maxTFCE, maxNegTFCE: single; + lOutNameMod: string; +begin + result := false; + if not NIFTIhdr_LoadHdr(lImageName,lHdr) then begin + showmessage('Error reading '+lImageName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + //lHdr.NIFTIhdr.scl_slope := 1; lHdr.NIFTIhdr.scl_inter := 0; + doTFCEbothPolarities (lHdr.NIFTIhdr, lImg, 6 {NumConn}, 2.0 {H}, 0.5 { E}, 0, 0,0,0 ,maxTFCE, maxNegTFCE); + + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.hdr'); + Msg('Creating ' +lOutNameMod); + NIFTIhdr_SaveHdrImg(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lImg,1); + + freemem(lImg); + + +end; + +procedure TMainForm.FCE1Click(Sender: TObject); +var + lFilename: string; + lPos: Integer; + lHdr: TMRIcroHdr; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select images for TFCE',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + //TFCE(lFilename,1,false); + //ClusterTFCE (lHdr, 666, 2); + ApplyTFCE(lFilename); + //Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; + end; + Msg('Done'); +end; + +procedure TMainForm.Makemeanimage1Click(Sender: TObject); +label + 666; +var + lMaskVoxels: integer; + lG: TStrings; + lMaskname: string; + lMaskHdr: TMRIcroHdr; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select images to average',true,true,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + lMaskname := lG[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading '+lMaskName); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lG,lMaskHdr {lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + Msg('Voxels = '+inttostr(lMaskVoxels)); + MakeMean(lG,lMaskHdr, odd((Sender as TMenuItem).tag),false); + 666: + lG.Free; +end; + +procedure TMainForm.Exit1Click(Sender: TObject); +begin + Close; +end; + +function MinMax (var lImg: SingleP; var lVolVox: integer; var lMin, lMax: single): boolean; +var + lC: integer; +begin + result := false; + if lVolVox < 1 then + exit; + lMax := lImg^[1]; + for lC := 1 to lVolVox do + if lImg^[lC] > lMax then + lMax := lImg^[lC]; + //lCx := lC; + lMin := lImg^[1]; + for lC := 1 to lVolVox do + if lImg^[lC] < lMin then + lMin := lImg^[lC]; + result := true; +end; + +function DetectMode (var lImg: SingleP; var lVolVox: integer; var lMin, lMax, lModeLo,lModeHi: single; lInflection: boolean): boolean; +const + kHistoBins = 255;//numbers of bins for histogram/image balance +var + lSmooth,lPrevSmooth,lModeWid,lC,lMinPos,lMode,lModePos,lMaxModePos,lMode2NotInflection: integer; + lMod,lRng: single; + lHisto : array [0..kHistoBins] of longint; +begin + + result := false; + if (lVolVox < 1) or (lMax < lMin) then + exit; + //zero array + for lC := 1 to kHistoBins do + lHisto[lC] := 0; + //find scaling + lRng := abs(lMax-lMin); + if lRng > 0 then + lMod := (kHistoBins)/lRng + else + lMod := 0; + //fill histogram + for lC := 1 to lVolVox do + if lImg^[lC] <> 0 then + inc(lHisto[round((lImg^[lC]-lMin)*lMod)]); + + {for lC := 1 to lVolVox do + inc(lHisto[round((lImg^[lC]-lMin)*lMod)]); } + //smooth histogram + lPrevSmooth := lHisto[1]; + for lC := 2 to (kHistoBins-1) do begin + lSmooth := round( (lHisto[lC-1]+lHisto[lC]+lHisto[lC]+lHisto[lC+1])/4); + lHisto[lC-1] := lPrevSmooth; + lPrevSmooth := lSmooth; + end; + lHisto[kHistoBins-1] := lPrevSmooth; + //find mode + lMode := 0; + lMinPos := 1;//indexed from zero + //find highest peak + for lC := lMinPos to kHistoBins do begin + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //for each bin + if lMode > 0 then + lMaxModePos := lModePos + else + exit; + //find 2nd highest peak + //find 2nd highest peak + lModeWid := 25; + lModePos := lMinPos; + lMode := lHisto[lMinPos]; + if (lMaxModePos - lModeWid) > lMinPos then begin + for lC := lMinPos to (lMaxModePos - lModeWid) do begin + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //for each bin + end; //check below highest peak + if (lMaxModePos + lModeWid) < kHistoBins then begin + for lC := (lMaxModePos + lModeWid) to kHistoBins do begin + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //for each bin + end; //check above highest peak + //fx(lModePos); + //an alternative method to find mode is to look for inflection - less assumptions, more sensitive to noise + if lInflection then begin + lMode2NotInflection := lModePos; + lModePos := lMinPos; + + lMode := 0; + lC := lMaxModePos; + while ((lC-1) > lMinPos) and (lHisto[lC] > lHisto[lC-1]) do + dec(lC); //find inflection + while ((lC-1) > lMinPos) do begin + dec(lC); + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //look for mode + + lC := lMaxModePos; + while ((lC+1) <= kHistoBins) and (lHisto[lC] > lHisto[lC+1]) do + inc(lC); //find inflection + while ((lC+1) <= kHistoBins) do begin + inc(lC); + if lHisto[lC] > lMode then begin + lModePos := lC; + lMode := lHisto[lC]; + end;//if new mode + end; //look for mode + + if abs(lMode2NotInflection-lModePos) > 3 then + Showmessage('Warning: inflection and windowed algorithms find different 2nd modes. Using inflection 2nd mode. inflection ='+inttostr(lModePos)+' windowed: '+inttostr(lMode2NotInflection)); + + end; + //now, return scaled values... + if lMod = 0 then exit; + lModeLo := (lModePos/lMod)+lMin; + lModeHi := (lMaxModePos/lMod)+lMin; + if lModeLo > lModeHi then begin + lMod := lModeLo; + lModeLo := lModeHi; + lModeHi := lMod; + end; + result := true; +end; + + +procedure CopyFileEXoverwrite (lInName,lOutName: string); +var lFSize: Integer; + lBuff: bytep0; + lFData: file; +begin + lFSize := FSize(lInName); + if (lFSize < 1) then exit; + assignfile(lFdata,lInName); + filemode := 0; + reset(lFdata,lFSize{1}); + GetMem( lBuff, lFSize); + BlockRead(lFdata, lBuff^, 1{lFSize}); + closefile(lFdata); + assignfile(lFdata,lOutName); + filemode := 2; + Rewrite(lFdata,lFSize); + BlockWrite(lFdata,lBuff^, 1 {, NumWritten}); + closefile(lFdata); + freemem(lBuff); +end; + +procedure CopyFileEX (lInName,lOutName: string); +var lFSize: Integer; +begin + lFSize := FSize(lInName); + if (lFSize < 1) or (fileexistsEX(lOutName)) then exit; + CopyFileEXoverwrite (lInName,lOutName); +end; + + +function DetectMeanStDev (var lImg: SingleP; var lVolVox: integer; var lMean,lStDev: double): boolean; +var + lIncVox,lVox: integer; + lSum,lSumSqr,lSE: double; +begin + lMean := 0; + lStDev := 0; + result := false; + if (lVolVox < 1) then + exit; + lSum := 0; + lSumSqr := 0; + lIncVox := 0; //voxels included - e.g. not masked + for lVox := 1 to lVolVox do begin + if lImg^[lVox] <> 0 then begin //not in mask + inc(lIncVox); + lSum := lSum + lImg^[lVox]; + lSumSqr := lSumSqr + sqr(lImg^[lVox]); + end; + end; + if lincVox < 3 then + exit; + Descriptive (lincVox, lSumSqr, lSum,lMean,lStDev,lSE); + result := true; +end; //DetectMeanStDev + //zero array + + + +function TMainForm.Balance (var lImageName,lMaskName: String; {lInflection: boolean}lMethod: integer): boolean; +//0 = masked peak +//1 = inflection +//2 = mean =1, stdev=1 +var + lImg,lMaskImg: SingleP; + lHdr,lMaskHdr: TMRIcroHdr; + lVolVox,lVox,lMasked: integer; + lMaskedInten,lMean,lStDev: double; + lMin,lMax: single; + lModeLo,lModeHi,lIntercept,lSlope: single; + lOutNameMod: string; +begin + //lOutName := lMaskHdr.ImgFileName; + result := false; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + if not NIFTIhdr_LoadHdr(lImageName,lHdr) then begin + showmessage('Error reading '+lImageName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + if lMaskName <> '' then begin + if not NIFTIhdr_LoadHdr(lMaskName,lMaskHdr) then begin + showmessage('Error reading '+lMaskName); + exit; + end; + if lVolVox <> (lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]) then begin + showmessage('Mask and header must have identical dimensions '+lMaskName+ ' ' + lImageName); + exit; + + end; + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load mask ' +lMaskHdr.ImgFileName); + exit; + end; + lMasked := 0; + lMaskedInten := 0; + for lVox := 1 to lVolVox do + if lMaskImg^[lVox] = 0 then begin + lMaskedInten := lMaskedInten + lImg^[lVox]; + lImg^[lVox] := 0; + inc(lMasked); + end; + if lMasked < 1 then + Msg('Warning: no voxels masked with image '+lMaskName) + else + Msg('Mask='+ lMaskName+' Number of voxels masked= '+inttostr(lMasked)+' Mean unscaled intensity of masked voxels= '+floattostr(lMaskedInten/lMasked)); + freemem(lMaskImg); + end;//mask + + if not MinMax(lImg,lVolVox,lMin,lMax) then exit; + Msg(lImageName+' -> '+lHdr.ImgFileName); + Msg('min..max ' +floattostr(lMin)+'..'+floattostr(lMax)); + if (lMethod = 0) or (lMethod = 1) then begin + if not DetectMode(lImg,lVolVox,lMin,lMax,lModeLo,lModeHi, odd(lMethod)) then exit; + if odd(lMethod) then + Msg('method for finding second mode: inflection') + else + Msg('method for finding second mode: masked peak'); + Msg('modes Lo Hi ' +floattostr(lModeLo)+'..'+floattostr(lModeHi)); + if lModeLo >= lModeHi then exit; + lSlope := 1/abs(lModeHi-lModeLo); + lIntercept := (abs(lModeHi-lModeLo)-(lModeLo))*lSlope ; //make mode lo = 1; + end else begin + DetectMeanStDev (lImg, lVolVox, lMean,lStDev); + if lStDev <>0 then + lSlope := 1/lStDev + else begin + Msg('Warning: StDev = 0!!!!'); + lSlope := 1; + end; + lIntercept := (-lMean*lSlope)+2; //mean voxel has intensity of zero + + Msg('method for intensity normalization: Mean = 2, StDev = 1'); + Msg('raw_Mean = '+floattostr(lMean)+' '+' raw_StDev = '+floattostr(lStDev)); + + end; + Msg('Slope/Intercept ' +floattostr(lSlope)+'..'+floattostr(lIntercept)); + lHdr.NIFTIhdr.scl_slope := lSlope; + lHdr.NIFTIhdr.scl_inter := lIntercept; + //CopyFileEX(lHdr.HdrFilename,changefileext( lHdr.HdrFilename,'.hdx')); + RenameFile(lHdr.HdrFilename,changefileext( lHdr.HdrFilename,'.hdx')); + //optional - save input + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lImg,1); + //end optional + NIFTIhdr_SaveHdr(lHdr.HdrFilename,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr)); + + freemem(lImg); +end; + +procedure TMainForm.Balance1Click(Sender: TObject); +var + lFilename,lMaskName: string; + lPos: Integer; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + lMaskName := ''; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + balance(lFilename,lMaskname,(Sender as TMenuItem).tag); + end; +end; + +procedure TMainForm.niiniigz1Click(Sender: TObject); +var + lFilename,lOutname,lPath,lName,lExt: string; + lPos: Integer; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select images',true,false,kNIIFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + FilenameParts(lFilename,lPath,lName,lExt); + lOutname := lPath+lName+'.nii.gz'; + msg('Compressing '+ lFilename+' -> '+lOutname); + GZipFile(lFilename, lOutname,false); + end; + msg('Compression completed'); +end; + +procedure TMainForm.Variance1Click(Sender: TObject); +label + 666; +var + lMaskVoxels: integer; + lG: TStrings; + lMaskname: string; + lMaskHdr: TMRIcroHdr; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select 2 images)',true,true,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + if lG.count <> 2 then begin + showmessage('You must select exactly two image.'); + goto 666; + end; + lMaskname := lG[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lG,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + Msg('Voxels = '+inttostr(lMaskVoxels)); + MakeMean(lG,lMaskHdr, odd((Sender as TMenuItem).tag),true); + 666: + lG.Free; +end; + +procedure BMX; +const + kN = 53; + knNoLesion = 48; + kSymptomRA: array[1..kn] of single = +(4,4.5,2.5,5,4,3.25,0.75,4.5,4.5,0.5,1.625,0,3.5,3,4,2,4.5,5,1.5,5,2.5,5,4,0,2, +1.5,1.75,2.5,5,0,3.25,4.375,0,3.75,0.25,0,2,5,0,0.5,0,2.25,0,2.25,2,0,0.25,0,0,0,0,0,0); +var + lObs: doublep0; + lI: integer; + lBMz,lBMzs,lDF: double; + +begin + getmem(lObs,kN * sizeof(double)); + for lI := 1 to kN do + lObs^[lI-1] := kSymptomRA[lI]; + + tBM (kN, knNoLesion, lObs,lBMz,lDF); + //simulate + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + genBMsim (kN, lObs); + + lBMzs := BMzVal (kN, knNoLesion,lBMz,lDF); + //end simulate + MainForm.NPMmsg('BMsim= '+floattostr(lBMzs)+' '+'BM= '+floattostr(lBMz)+' '+floattostr(lDF) ); + freemem(lObs); +end; + +(*procedure SX; +var + lVALFilename {,lTemplateName}: string; + lCritPct,lnSubj, lnFactors: integer; + var lSymptomRA: singleP; + var lImageNames: TStrings; + var lCrit: integer; {lBinomial : boolean;} + var lPredictorList: TStringList; + +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lVALFilename := 'c:\RT_norm.val';//MainForm.OpenHdrDlg.Filename; + lPredictorList := TStringList.Create; + GetValCore ( lVALFilename, lnSubj, lnFactors, lSymptomRA, lImageNames, lCrit,lCritPct{,binom},lPredictorList); + lImageNames.Free; + lPredictorList.Free; +end;*) + +(*procedure ComputeR; +var + lStr: string; + lT,lDF: double; +begin + inputquery('Enter value','Enter T score',lStr); + lT := strtofloat(lStr); + inputquery('Enter value','Enter DF',lStr); + lDF := strtofloat(lStr); + showmessage('The coresponding correlation Z score for t('+floattostr(lDF)+')='+floattostr(lT) +' is '+floattostr(TtoZ(lT,lDF) ) ); + //showmessage('The coresponding correlation R score for t('+floattostr(lDF)+')='+floattostr(lT) +' is '+floattostr(TtoR(lT,lDF) ) ); +end; + +function Log10x (lLogP: double): double; +begin + result := -Log10(lLogP); + fx(result); +end; + + +procedure LogPtoZ (lLogP: double); +var + lD,lZ: double; +begin + ///lD := Log10(lLogp); + lD := Power(10,-lLogP); + lZ := pNormalInv(lD); + fx(lD,lZ); +end; *) + +procedure TMainForm.About1Click(Sender: TObject); +begin +//Masked1Click(nil); exit; +//LogPtoZ (Log10x(0.02)); + //LogPtoZ(1.699); + //ComputeR; + showmessage(GetkVers ); +end; + +procedure TMainForm.Design1Click(Sender: TObject); +begin +{$IFDEF SPREADSHEET} SpreadForm.Show; {$ELSE} Showmessage('Spreadsheet not yet supported on the Operating System');{$ENDIF} +end; + +procedure TMainForm.StrToMemo(lStr: String); +var + lLen,lPos: integer; + lOutStr: string; +begin + lLen := length(lStr); + if lLen < 1 then exit; + lOutStr := ''; + for lPos := 1 to lLen do begin + if lStr[lPos] = kCR then begin + Msg(lOutStr); + lOutStr := ''; + end else + lOutStr := lOutStr + lStr[lPos]; + end; + if lOutStr <> '' then + Msg(lOutStr); +end; + + +procedure TMainForm.PhysiologicalArtifactCorrection1Click(Sender: TObject); +var + lInImgName,lPulsFile,lRespFile,lOutImgName,lStr: string; + l4Ddata: singlep; + lHdr: TMRIcroHdr; + lDim,lImgVox: integer; + lOutHdr: TniftiHdr; +begin + if not OpenDialogExecute('Select file with pulse onsets',false,false,'Siemens physio |*.puls|3-column text |*.txt') then + exit; + lPulsFile := OpenHdrDlg.Filename; + if UpCaseExt(lPulsFile) = '.PULS' then + lRespFile := changefileext(lPulsFile,'.resp') + else begin //text input + if not OpenDialogExecute('Select file with respiration onsets',false,false,'3-column text |*.txt') then + lRespFile := '' + else + lRespFile := OpenHdrDlg.Filename; + end; + if not OpenDialogExecute('Select 4D motion corrected data ',false,false,kImgFilter) then + exit; + lInImgName := OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr(lInImgName,lHdr) then begin + showmessage('Error reading image header.'); + exit; + end; + for lDim := 1 to 4 do + if lHdr.NIFTIhdr.Dim[lDim] < 4 then begin + Showmessage('You need to select a 4D image with at least 4 voxels/images in each dimension.'); + exit; + end; + lImgVox := lHdr.NIFTIhdr.Dim[1]*lHdr.NIFTIhdr.Dim[2]*lHdr.NIFTIhdr.Dim[3]; + lDim := lImgVox*lHdr.NIFTIhdr.Dim[4]; + MsgClear; + Msg(kVers); + Msg('Physiological Artifact Removal Tool started = ' +TimeToStr(Now)); + Msg('Assuming continuous fMRI ascending acquisition with TR = '+realtostr(lHdr.NIFTIhdr.PixDim[4],4)+'sec'); + MainForm.refresh; + getmem(l4Ddata,lDim*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, l4Ddata, 1, lDim,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lImgVox) then begin + Showmessage('Unable to load data'); + freemem(l4Ddata); + exit; + end; + lStr := ApplyPART( lPulsFile,l4Ddata,40, lImgVox,lHdr.NIFTIhdr.Dim[3], lHdr.NIFTIhdr.Dim[4], lHdr.NIFTIhdr.PixDim[4]); + if lStr = '' then begin + Showmessage('Unable to apply physio file. Physiological correction is being aborted.'); + exit; + end; + StrToMemo (lStr); + if (lRespFile <> '') and (fileexists(lRespFile)) then begin + lStr := ApplyPART( lRespFile,l4Ddata,20, lImgVox,lHdr.NIFTIhdr.Dim[3], lHdr.NIFTIhdr.Dim[4], lHdr.NIFTIhdr.PixDim[4]); + StrToMemo (lStr); + if lStr = '' then begin + Showmessage('Unable to read Respiration file. Hysiological correction is being aborted.'); + exit; + end; + + end; + + MakeHdr (lHdr.NIFTIhdr,lOutHdr); + Msg('Input = ' +lInImgName); + lOutImgName := ChangeFilePrefixExt(lInImgName,'i','.hdr'); + NIFTIhdr_SaveHdrImg(lOutImgName,lOutHdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,l4Ddata,lHdr.NIFTIhdr.Dim[4]); + Msg('Output = ' +lOutImgName); + Msg('Physiological Artifact Removal Tool finished = ' +TimeToStr(Now)); + lOutImgName := ChangeFilePostfixExt(lOutImgName,'Notes','.txt'); + MsgSave(lOutImgName); + freemem(l4Ddata); +end; + +function ChangeName (lInName: string): string; +var + lPath,lName,lExt: string; +begin + //lInName:= 'c:\vbm\ds\123'; + FilenameParts (lInName, lPath,lName,lExt); + //showmessage(lPath+'*'+lName+'*'+lExt); + if length(lName) > 0 then + lName[1] := 'e' + else + lName := 'Unable to convert '+lInName; + result := lPath+lName+lExt; +end; + +function Add2ndScans(var lImageNames: TStrings): boolean; +var + lnSubj,lSubj: integer; + lFilename: string; +begin + result := false; + lnSubj :=lImageNames.Count; + if lnSubj < 1 then + exit; + for lSubj := 1 to lnSubj do begin + lFilename := ChangeName(lImageNames[lSubj-1]); + if not (fileexists4D(lFilename)) then begin + showmessage('Unable to find a file named '+ lFilename); + exit; + end; + lImageNames.add(lFilename); + end; + result := true; +end; + +function ReadPairedFilenames(var lImageNames: TStrings): boolean; +var + lLen,lPos: integer; + lFilenames,lF1,lF2: string; + lImageNames2: TStrings; + lF: TextFile; +begin + result := false; + Showmessage('Please select a text file with the image names. '+kCR+ + 'Each line of the file should specify the control and experimental filenames, separated by an *'+kCR+ + 'C:\vbmdata\c1.nii.gz*C:\vbmdata\e1.nii.gz'+kCR + + 'C:\vbmdata\c2.nii.gz*C:\vbmdata\e2.nii.gz'+kCR+ + 'C:\vbmdata\c3.nii.gz*C:\vbmdata\e3.nii.gz'+kCR+ + '...' ); + if not MainForm.OpenDialogExecute('Select asterix separated filenames ',false,false,kTxtFilter) then + exit; + lImageNames2:= TStringList.Create; //not sure why TStrings.Create does not work??? + //xxx + assignfile(lF,MainForm.OpenHdrDlg.FileName ); + FileMode := 0; //read only + reset(lF); + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + + if lLen > 0 then begin + lF1:= ''; + lF2 := ''; + lPos := 1; + while (lPos <= lLen) and (lFilenames[lPos] <> '*') do begin + lF1 := lF1 + lFilenames[lPos]; + inc(lPos); + end; + inc(lPos); + while (lPos <= lLen) do begin + lF2 := lF2 + lFilenames[lPos]; + inc(lPos); + end; + if (length(lF1) > 0) and (length(lF2)>0) then begin + if Fileexists4D(lF1) then begin + if Fileexists4D(lF2) then begin + lImageNames.add(lF1); + lImageNames2.add(lF2); + end else //F2exists + showmessage('Can not find image '+lF2); + end else //F1 exists + showmessage('Can not find image '+lF1); + end; + end;//len>0 + end; //while not EOF + closefile(lF); + FileMode := 2; //read/write + if (lImageNames.count > 0) and (lImageNames2.count = lImageNames.count) then begin + lImageNames.AddStrings(lImageNames2); + + result := true; + end; + lImageNames2.Free; +end; + +function AddNumStr(var X : PMatrix; var lNumStr: string; lRow,lCol: integer):boolean; +var + lTempFloat: double; +begin + + result := false; + if (lNumStr = '') or (lRow < 1) or (lCol < 1) then exit; + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + showmessage('Empty cells? Error reading TXT file row:'+inttostr(lRow)+' col:'+inttostr(lCol)+' - Unable to convert the string '+lNumStr+' to a number'); + exit; + end; + end; + //fx(lRow,lCol,lTempFloat); + X^[lCol]^[lRow] := lTempFloat; + lNumStr := ''; + result := true; +end; + +{$DEFINE notRTEST} +function ReadPairedFilenamesReg(var lImageNames: TStrings; var X : PMatrix; var lnAdditionalFactors: integer): boolean; +var + lLen,lPos,lSep,lMaxSep,lLine: integer; + lFilenames,lF1,lF2,lNumStr: string; + lImageNames2: TStrings; + lF: TextFile; +begin + result := false; + {$IFDEF RTEST} + MainForm.OpenHdrDlg.FileName := 'c:\twins\dataplus.txt'; + {$ELSE} + Showmessage('Please select a text file with the image names. '+kCR+ + 'Each line of the file should specify the control and experimental filenames, separated by an *'+kCR+ + 'C:\vbmdata\c1.nii.gz*C:\vbmdata\e1.nii.gz'+kCR + + 'C:\vbmdata\c2.nii.gz*C:\vbmdata\e2.nii.gz'+kCR+ + 'C:\vbmdata\c3.nii.gz*C:\vbmdata\e3.nii.gz'+kCR+ + '...' ); + if not MainForm.OpenDialogExecute('Select asterix separated filenames ',false,false,kTxtFilter) then + exit; + {$ENDIF} + + lImageNames2:= TStringList.Create; //not sure why TStrings.Create does not work??? + //xxx + assignfile(lF,MainForm.OpenHdrDlg.FileName ); + FileMode := 0; //read only + reset(lF); + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + + if lLen > 0 then begin + lF1:= ''; + lF2 := ''; + lPos := 1; + while (lPos <= lLen) and (lFilenames[lPos] <> '*') do begin + lF1 := lF1 + lFilenames[lPos]; + inc(lPos); + end; + inc(lPos); + while (lPos <= lLen) and (lFilenames[lPos] <> '*') do begin + lF2 := lF2 + lFilenames[lPos]; + inc(lPos); + end; + if (length(lF1) > 0) and (length(lF2)>0) then begin + if Fileexists4D(lF1) then begin + if Fileexists4D(lF2) then begin + lImageNames.add(lF1); + lImageNames2.add(lF2); + end else //F2exists + showmessage('Can not find image '+lF2); + end else //F1 exists + showmessage('Can not find image '+lF1); + end; + end;//len>0 + end; //while not EOF + + //fx(lImageNames.count); + //next - count additional factors + lnAdditionalFactors := 0; + reset(lF); + lMaxSep := 0; + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + lSep := 0; + if lLen > 0 then begin + for lPos := 1 to lLen do + if lFilenames[lPos] = '*' then + inc(lSep) + end;//len>0 + if lSep > lMaxSep then + lMaxSep := lSep; + end; //while not EOF + if (lMaxSep > 1) and (lImageNames2.count > 1) then begin //additional factors present + //final pas - load additional factors + lnAdditionalFactors := lMaxSep - 1; + + DimMatrix(X, lnAdditionalFactors, lImageNames2.count); + reset(lF); + lLine := 0; + while not EOF(lF) do begin + readln(lF,lFilenames); + lLen := length(lFilenames); + lSep := 0; + + if lLen > 0 then begin + inc(lLine); + lPos := 1; + lNumStr := ''; + while lPos <= lLen do begin + if (lFilenames[lPos] = '*') then begin + AddNumStr(X,lNumStr,lLine,lSep-1); + inc(lSep); + end else if (lSep >= 2) and (not (lFilenames[lPos] in [#10,#13,#9]) ) then begin + lNumStr := lNumStr+lFilenames[lPos]; + //showmessage(lNumStr); + end; + inc(lPos); + end; //while not EOLN + AddNumStr(X,lNumStr,lLine,lSep-1); + end;//len>0 + end; //while not EOF + //next - read final line of unterminated string... + end;//maxsepa > 1 + + + //2nd pass vals + closefile(lF); + FileMode := 2; //read/write + if (lImageNames.count > 0) and (lImageNames2.count = lImageNames.count) then begin + lImageNames.AddStrings(lImageNames2); + + result := true; + end; + lImageNames2.Free; + result := true; +end; + +procedure TMainForm.DualImageCorrelation1Click(Sender: TObject); +label + 666; +var + lnSubj,lSubj,lMaskVoxels,lnAdditionalFactors,lI: integer; + lImageNames: TStrings; + X: PMatrix; + lMaskname,lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + MsgClear; + Msg(kVers); + {$IFDEF RTEST} + OpenHdrDlg.FileName := 'c:\twins\aameanMean.hdr'; + {$ELSE} + Msg('Dual-image Linear Regression [Weighted Least Squares]'); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + goto 666; + end; //if not selected + {$ENDIF} + + lMaskname := OpenHdrDlg.Filename; + + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading Mask image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + if not ReadPairedFilenamesReg(lImageNames,X,lnAdditionalFactors) then exit; + lnSubj :=lImageNames.Count div 2; + + //fx(lnAdditionalFactors); + //show matrix + //MsgStrings (lImageNames); + Msg ('n Subjects = '+inttostr(lnSubj)); + for lSubj := 0 to (lnSubj-1) do begin + lStr := lImageNames[lSubj]+' <-> '+lImageNames[lSubj+lnSubj]; + if lnAdditionalFactors > 0 then + for lI := 1 to lnAdditionalFactors do + lStr := lStr+','+floattostr(X^[lI]^[lSubj+1]); + + + Msg(lStr); + end; + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + + + Msg('Mask = '+lMaskname); + Msg('Total voxels = '+inttostr(lMaskVoxels)); + Msg('Number of observations = '+inttostr(lnSubj)); + (*if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end;*) + + if lnSubj < 5 then begin + showmessage('Paired regression error: Requires at least 5 images per group.'); + goto 666; + end; + lOutName := lMaskName; + if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + //showmessage('Unimplemented Regress');// + Regress2NPMAnalyze (lImageNames, lMaskHdr, lOutname,X,lnAdditionalFactors); + if lnAdditionalFactors > 1 then + DelMatrix(X, lnAdditionalFactors, lnSubj); + 666: + lImageNames.Free; +end; + +procedure TMainForm.LesionBtnClick(Sender: TObject); + label + 666; +var + lPrefs: TLDMPrefs ; +begin + lPrefs.NULP := gNULP; + if (1= (Sender as tMenuItem).tag) then begin //continuous + lPrefs.BMtest := BMmenu.checked; + lPrefs.Ttest := ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin //binomial + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.CritPct := -1; + lPrefs.nPermute := ReadPermute; + lPrefs.Run := 0;{0 except for montecarlo} + {if (not lPrefs.Ltest) and (not lPrefs.Ttest) and (not lPrefs.BMtest) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; code above defaults to t-test} + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + showmessage('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lPrefs.VALFilename := MainForm.OpenHdrDlg.Filename; + lPrefs.OutName := ExtractFileDirWithPathDelim(lPrefs.VALFilename)+'results'; + lPrefs.OutName := lPrefs.OutName+'.nii.gz'; + SaveHdrDlg.Filename := lPrefs.Outname; + if not SaveHdrName ('Base Statistical Map', lPrefs.OutName) then exit; + //Explicit mask + if not OpenDialogExecute('Select explicit mask [optional]',false,false,kImgPlusVOIFilter) then + lPrefs.ExplicitMaskName := '' + else + lPrefs.ExplicitMaskName := OpenHdrDlg.FileName; + + DoLesion (lPrefs); //Prefs.pas +end; + + +procedure TMainForm.FormShow(Sender: TObject); +begin + MsgClear; + Msg(GetkVers); + {$IFNDEF UNIX} {GUILaunch;}{$ENDIF} + LongTimeFormat := 'YYYY-MMM-DD hh:nn:ss'; //delphi TimeToStr + ShortTimeFormat := 'YYYY-MMM-DD hh:nn:ss'; //freepascal TimeToStr + //stax; + //MakeGZ; + //{x$IFNDEF UNIX} Threads1.visible := false;{x$ENDIF}//Windows can read actual CPU count + //TestMultReg; + //SingleRegressClick(nil); + //DualImageCorrelation1Click(nil); + //AnaCOM1Click(nil); + //msg(floattostr(pNormalInv(1/20000))); + //msg(floattostr(pNormalInv(0.01667))); + //msg(floattostr(pNormalInv(0.05/51700))); + //msg(floattostr(0.05/pNormal(4.76 ))); + {$IFNDEF UNIX} ReadParamStr; {$ENDIF} + //FX(rocA(0.2,0.4),AUC(0.7,0.4),rocA(0.4,0.7),AUC(0.4,0.7) ); + //LesionX; + {$IFDEF benchmark} + MonteCarloSimulation1.visible := true; + // LesionMonteCarlo (false,true,true); + {$ENDIF} +end; + + +procedure TMainForm.PairedTMenuClick(Sender: TObject); +label + 666; +var + lnSubj,lSubj,lMaskVoxels: integer; + lImageNames: TStrings; + lMaskname,lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + MsgClear; + Msg(kVers); + Msg('Paired T-test [Repeated Measures]'); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + goto 666; + end; //if not selected + //OpenHdrDlg.FileName := 'c:\vbmdata\mask50.nii.gz'; + lMaskname := OpenHdrDlg.Filename; + + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading Mask image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + if not ReadPairedFilenames(lImageNames) then exit; + lnSubj :=lImageNames.Count div 2; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + + + Msg('Mask = '+lMaskname); + Msg('Total voxels = '+inttostr(lMaskVoxels)); + Msg('Number of observations = '+inttostr(lnSubj)); + Msg('Degrees of Freedom = '+inttostr(lnSubj-1)); + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + //show matrix + //MsgStrings (lImageNames); + Msg ('n Subjects = '+inttostr(lnSubj)); + lStr := 'Image,'; + for lSubj := 0 to (lnSubj-1) do + Msg(lImageNames[lSubj]+' <-> '+lImageNames[lSubj+lnSubj]); + if lnSubj < 4 then begin + showmessage('Paired t-test error: Requires at least 4 images per group.'); + goto 666; + end; + lOutName := lMaskName; + //if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + NPMAnalyzePaired (lImageNames, lMaskHdr, lMaskVoxels); + //Regress2NPMAnalyze (lImageNames, lMaskHdr, lOutname); + 666: + lImageNames.Free; +end; + +function TMainForm.NPMzscore (var lImages: TStrings; var lMnHdr,lStDevHdr: TMRIcroHdr): boolean; +label + 667; +var + lOutNameMod: string; + lMnImg,lStDevImg,lSubjImg,lOutImg: SingleP; + lVal: single; + lSubj,lPos,lVolVox: integer; + lStatHdr: TNIfTIhdr; +begin + result := false; + //lOutName := lMnHdr.ImgFileName; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + Msg('Analysis began = ' +TimeToStr(Now)); + lVolVox := lMnHdr.NIFTIhdr.dim[1]*lMnHdr.NIFTIhdr.dim[2]* lMnHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + //load mask + for lPos := 0 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + if gScaleRA[kMaxImages] = 0 then + gScaleRA[kMaxImages] := 1; + + getmem(lMnImg,lVolVox*sizeof(single)); + if not LoadImg(lMnHdr.ImgFileName, lMnImg, 1, lVolVox,round(gOffsetRA[0]),1,lMnHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load mean ' +lMnHdr.ImgFileName); + goto 667; + end; + //load StDev + getmem(lStDevImg,lVolVox*sizeof(single)); + if not LoadImg(lStDevHdr.ImgFileName, lStDevImg, 1, lVolVox,round(gOffsetRA[kMaxImages]),1,lStDevHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load StDev ' +lStDevHdr.ImgFileName); + goto 667; + end; + getmem(lOutImg,lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do begin + lMnImg^[lPos] := (gScaleRA[0]*lMnImg^[lPos])+gInterceptRA[0]; + lStDevImg^[lPos] := (gScaleRA[kMaxImages]*lStDevImg^[lPos])+gInterceptRA[kMaxImages]; + if lStDevImg^[lPos] = 0 then + lOutImg^[lPos] := 0; + end; + getmem(lSubjImg,lVolVox* sizeof(single)); + for lSubj := 1 to lImages.Count do begin + ProgressBar1.Position := round((lSubj/lImages.Count)*100); + Msg( lImages.Strings[lSubj-1]); + showmessage(inttostr(round(gOffsetRA[lSubj]))); + LoadImg(lImages.Strings[lSubj-1], lSubjImg, 1, lVolVox,round(gOffsetRA[lSubj]),1,gDataTypeRA[lSubj],lVolVox); + for lPos := 1 to lVolVox do begin + if lStDevImg^[lPos] <> 0 then begin + lVal := (gScaleRA[lSubj]*lSubjImg^[lPos])+gInterceptRA[lSubj]; + lOutImg^[lPos] := (lVal-lMnImg^[lPos])/lStDevImg^[lPos]; + end; //for each voxel with variance + end; //for each voxel + lOutNameMod := ChangeFilePostfixExt(lImages.Strings[lSubj-1],'Z','.hdr'); + MakeStatHdr (lMnHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lVolVox,kNIFTI_INTENT_ZSCORE,inttostr(lVolVox) ); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMnHdr.NIFTIhdr),true,lOutImg,1); + end; //for each subj + freemem(lSubjImg); + freemem(lOutImg); + freemem(lMnImg); + freemem(lStDevImg); + Msg('Analysis finished = ' +TimeToStr(Now)); + ProgressBar1.Position := 0; + result := true; + exit; +667: //you only get here if you aborted ... free memory and report error + if lVolVox > 1 then freemem(lMnImg); + Msg('Unable to complete analysis.'); + ProgressBar1.Position := 0; +end; + + +procedure TMainForm.SingleSubjectZScores1Click(Sender: TObject); +label + 666; +var + lnSubj,lMnVoxels: integer; + lG: TStrings; + lMn,lStDev: string; + lMnHdr,lStDevHdr: TMRIcroHdr; +begin + if (not ttestmenu.checked) and (not BMmenu.checked) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + MsgClear; + Msg(kVers); + Msg('Threads: '+inttostr(gnCPUThreads)); + if not OpenDialogExecute('Select mean image ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mean selection failed.'); + exit; + end; //if not selected + lMn := OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr(lMn,lMnHdr) then begin + showmessage('Error reading mask.'); + exit; + end; + lMnVoxels := ComputeImageDataBytes8bpp(lMnHdr); + if (lMnVoxels < 2) or (not CheckVoxels(lMn,lMnVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mean file size too small.'); + exit; + end; + + if not OpenDialogExecute('Select StDev image ',false,false,kImgFilter) then begin + showmessage('NPM aborted: StDev selection failed.'); + exit; + end; //if not selected + lStDev := OpenHdrDlg.Filename; + if not NIFTIhdr_LoadHdr(lStDev,lStDevHdr) then begin + showmessage('Error reading StDev.'); + exit; + end; + if not CheckVoxels(lStDev, lMnVoxels,kMaxImages) then begin + showmessage('Error Mean and StDev must have same size.'); + exit; + end; + Msg('Mean name = '+ lMn); + Msg('Total voxels = '+inttostr(lMnVoxels)); + //next, get 1st group + if not OpenDialogExecute('Select postive group (Z scores positive if this group is brighter)',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; //not sure why TStrings.Create does not work??? + lG.addstrings(OpenHdrDlg.Files); + lnSubj :=OpenHdrDlg.Files.Count; + Msg('Subjects= '+inttostr(lnSubj)); + if not CheckVoxelsGroupX(lG,lMnHdr {lMnVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + NPMzscore (lG, lMnHdr,lStDevHdr); + //NPMAnalyze(lG,lMnHdr,lMnVoxels,lnSubj); + 666: + lG.Free; +end; + +procedure TMainForm.MultipleRegressClick(Sender: TObject); +label + 666; +var + lnFactors,lnSubj,lMaskVoxels,lRow,lCol: integer; + lImageNames: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; + X : PMatrix; +begin + + + {$IFDEF FPC} + showmessage('Regression routines not extensively tested: you may want to use the Windows compilation.'); + {$ENDIF} + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPredictorList := TStringList.Create; + Memo1.Lines.Clear; + Memo1.Lines.Add(kVers); + Memo1.Lines.Add('Multiple Linear Regression [Weighted Least Squares]'); + if not GetValReg(lnSubj,lnFactors,X,lImageNames,lPredictorList) then + goto 666; + lTemp4D := CreateDecompressed4D(lImageNames); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + goto 666; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + //lMaskname := lImageNames[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + Memo1.Lines.Add('Mask = '+lMaskname); + Memo1.Lines.Add('Total voxels = '+inttostr(lMaskVoxels)); + Memo1.Lines.Add('Number of observations = '+inttostr(lnSubj)); + if not CheckVoxelsGroupX(lImageNames,lMaskHdr {lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + //show matrix + lStr := 'Image,'; + for lCol := 1 to lnFactors do + lStr := lStr + lPredictorList.Strings[lCol-1]+', '; + MainForm.Memo1.Lines.Add(lStr); + for lRow := 1 to lnSubj do begin + lStr := lImageNames[lRow-1]+','; + for lCol := 1 to lnFactors do + lStr := lStr + floattostr(X^[lCol]^[lRow])+', '; + MainForm.Memo1.Lines.Add(lStr); + end; + lOutName := lMaskName; + if not SaveHdrName ('Base Statistical Map', lOutName) then exit; + ARegressNPMAnalyze(lImageNames,lMaskHdr,X,lnFactors,lPredictorList,lOutName,0,0); + + DelMatrix(X, lnFactors, lnSubj); + 666: + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); +end; + +{$DEFINE notRegTest} +procedure TMainForm.SingleRegressClick(Sender: TObject); +label + 666; +var + lnSubj1,lnFactors,lnSubj,lMaskVoxels,lRow,lCol: integer; + + lImageNames,lImageNames1: TStrings; + lPredictorList,lPredictorList1: TStringList; + lTemp4D,lMaskname,lOutName: string; + lMaskHdr: TMRIcroHdr; + X,X1 : PMatrix; +begin + + {$IFDEF FPC} + showmessage('Regression routines not extensively tested: you may want to use the Windows compilation.'); + {$ENDIF} + lTemp4D := ''; + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPredictorList := TStringList.Create; + lPredictorList1 := TStringList.Create; + if not GetValReg(lnSubj,lnFactors,X,lImageNames,lPredictorList) then + goto 666; + {$IFDEF regtest} + lMaskname := 'C:\Documents and Settings\Chris Rorden\Desktop\npmdata\npmdata\amask50.nii.gz'; + {$ELSE} + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + goto 666; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + {$ENDIF} + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lOutName := lMaskName; + {$IFNDEF regtest} + + if not SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + {$ENDIF} + lTemp4D := CreateDecompressed4D(lImageNames); + + lImageNames1:= TStringList.Create; + for lCol := 1 to lnFactors do begin + lPredictorList1.Clear; + lPredictorList1.Add(lPredictorList[lCol-1]); + lImageNames1.clear; + for lRow := 1 to lnSubj do + if X^[lCol]^[lRow] <> kNaN then + lImageNames1.Add(lImageNames[lRow-1]); + DimMatrix(X1, 1, lImageNames1.Count); + lnSubj1 := 0; + + for lRow := 1 to lnSubj do + if X^[lCol]^[lRow] <> kNaN then begin + inc(lnSubj1); + X1^[1]^[lnSubj1] := X^[lCol]^[lRow]; + end; + if lnSubj1 <> lImageNames1.Count then //should be impossible + showmessage('serious error'); + Memo1.Lines.Clear; + Memo1.Lines.Add(kVers); + Memo1.Lines.Add('Single Linear Regression [Weighted Least Squares]'); + Memo1.Lines.Add('Mask = '+lMaskname); + Memo1.Lines.Add('Total voxels = '+inttostr(lMaskVoxels)); + Memo1.Lines.Add('Number of observations = '+inttostr(lnSubj1)); + MainForm.Memo1.Lines.Add('Image,'+ lPredictorList1.Strings[0]); + for lRow := 1 to lnSubj1 do + MainForm.Memo1.Lines.Add(lImageNames1[lRow-1]+','+floattostr(X1^[1]^[lRow]) ) ; + ARegressNPMAnalyze(lImageNames1,lMaskHdr,X1,1,lPredictorList1,lOutName, ReadPermute,gTFCE); + //PermuteRegressNPMAnalyze (lImageNames1,lMaskHdr,X1,1,lPredictorList1,lOutName); + DelMatrix(X1, 1, lnSubj1); + end; + lImageNames1.Free; + DelMatrix(X, lnFactors, lnSubj); + 666: +DeleteDecompressed4D(lTemp4D); + lImageNames.Free; + lPredictorList.Free; + lPredictorList1.Free; +end; + +procedure TMainForm.AssociatevalfileswithNPM1Click(Sender: TObject); +begin +{$IFDEF FPC} + //unsupported by FreePascal +{$ELSE} + case MessageDlg('NPM installation:'+kCR+'Do you want .val fiels to automatically open NPM when you double click on their icons?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + id_No: exit; + end; + registerfiletype(kVALNativeExt,'NPM'{key},'NPM',Application.ExeName+',1'); +{$ENDIF} + +end; + +procedure TMainForm.threadChange(Sender: TObject); +begin + (sender as tmenuitem).checked := true; + ReadThread; +end; + +procedure TMainForm.Countlesionoverlaps1Click(Sender: TObject); +label + 666; +var + lReps,lMax,lInc,lMaskVoxels,lDefault,lTotal,lPct: integer; + lG: TStrings; + lMaskname: string; + lMaskHdr: TMRIcroHdr; +begin + MsgClear; + Msg(kVers); + if not OpenDialogExecute('Select images to overlap',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if MainForm.OpenHdrDlg.Files.Count < 2 then begin + lTotal := NIFTIhdr_HdrVolumes(MainForm.OpenHdrDlg.Filename); + if lTotal < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE volumes. You selected less than two images.'); + exit; + end; + lG:= TStringList.Create; + for lReps := 1 to lTotal do + lG.Add(MainForm.OpenHdrDlg.Filename+':'+inttostr(lReps) ); + end else begin + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files); + end; + lMaskname := lG[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lG,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lTotal := lG.Count; + if lTotal > kMaxObs then + lTotal := kMaxObs; //this implemmentation uses 126 bits per voxel - we can not test more than this! + if lTotal > 100 then + lDefault := 100 + else + lDefault := lTotal; + lMax := ReadIntForm.GetInt('Enter maximum number of overlaps to test ', 3,lDefault,lTotal); + lDefault := lMax div 10; + if lDefault < 1 then + lDefault := 1; + lInc := ReadIntForm.GetInt('Enter overlap increment (e.g. if 5; then 5, 10, 15...) ', 1,lDefault,lMax); + lReps := ReadIntForm.GetInt('Enter number of times each increment is tested ', 1,10,100); + lPct := ReadIntForm.GetInt('Only include voxels damaged in N% of patients ', 0,5,100); + + Msg('Voxels = '+inttostr(lMaskVoxels)); + Msg('Scans to permute = '+inttostr(lG.count)); + EvaluatePower (lG,lInc,lMax,lReps,lPct); + + //MakeMean(lG,lMaskHdr, odd((Sender as TMenuItem).tag),false); + 666: + lG.Free; +end; + +{$DEFINE SINGLETHREAD} +{$DEFINE NOTHREAD} + +function TMainForm.FirthNPMAnalyze (var lImages: TStrings; var lPredictorList: TStringList; var lMaskHdr: TMRIcroHdr; lnCond,lnCrit: integer; var lSymptomRA: SingleP; var lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: bytep; + lOutImgSum : singleP; + lOutImg: SingleRAp; + {$IFDEF SINGLETHREAD}lnCPUThreads,{$ENDIF} + lCond,lPos,lPlank,lThread,lnDeficit: integer; + lTotalMemory,lVolVox,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadInc,lThreadEnd, lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT, lSum: double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if lnCond < 1 then + exit; + lnPermute := ReadPermute; + if lnPermute > 1 then begin + Msg('NPM does not (yet) support permutation thresholding with Logisitic Regression.'); + lnPermute := 0; + end; + {$IFDEF SINGLETHREAD} + lnCPUThreads := gnCPUThreads; + if gnCPUThreads > 1 then + Msg('July 2007 logistic regression will only use 1 thread. You may want to check for a software update'); + gnCPUThreads := 1; + {$ENDIF} + Msg('Permutations = ' +IntToStr(lnPermute)); + Msg('Logisitic Regression began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + Msg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + Msg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + //getmem(lOutImgL,lVolVox* sizeof(single)); + getmem(lOutImg,lnCond*sizeof(Singlep)); + for lCond := 1 to lnCond do begin + getmem(lOutImg^[lCond],lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImg^[lCond]^[lPos] := 0; + end; + //InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do + lOutImgSum^[lPos] := 0; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + ProgressBar1.Position := 1; + Msg('Computing plank = ' +Inttostr(lPlank)); + Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + {$IFDEF NOTHREAD} + FirthAnalyzeNoThread (lnCond, lnCrit,lnPermute,1,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg); + //FirthAnalyzeNoThread (lnCond,lnCrit, lnPermute,1,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg); + {$ELSE} + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TFirthThreadStat.Create (ProgressBar1,lnCond,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lSymptomRA,lOutImg) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + Msg('Thread ' +Inttostr(gThreadsRunning)+' = '+inttostr(lThreadStart)+'..'+inttostr(lThreadEnd)); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + + repeat + Application.processmessages; + until gThreadsRunning = 0; + {$ENDIF} //THREADED + Application.processmessages; + //showmessage('Threads done'); + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadDataLite(gnCPUThreads); //not yet lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + if lnVoxTested < 1 then begin + Msg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + //next report findings + Msg('Voxels tested = ' +Inttostr(lnVoxTested)); + Msg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + reportBonferroni('Std',lnVoxTested); + //next: save data +(*savedata *) + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum','.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + for lCond := 1 to lnCond do begin + reportFDR (lPredictorList[lCond-1]+inttostr(lCond), lVolVox, lnVoxTested, lOutImg^[lCond]); + //reportPermute('L',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,lPredictorList[lCond-1]+inttostr(lCond),'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImg^[lCond],1); + end; +123: +//next: free dynamic memory + //FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + for lCond := 1 to lnCond do + freemem(lOutImg^[lCond]); + freemem(lOutImg); + + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + Msg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes','.txt'); + MsgSave(lOutNameMod); + + ProgressBar1.Position := 0; + {$IFDEF SINGLETHREAD} + gnCPUThreads := lnCPUThreads; + {$ENDIF} + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + Msg('Unable to complete analysis.'); + ProgressBar1.Position := 0; + {$IFDEF SINGLETHREAD} + gnCPUThreads := lnCPUThreads; + {$ENDIF} +end; + + +function ComputeLesionVolume (lImgName: string): integer; +var + lHdr: TMRIcroHdr; + lImg: byteP; + lVolVox,lVox:integer; +begin + result := -1; //error + NIFTIhdr_LoadHdr(lImgName,lHdr); + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + getmem(lImg,lVolVox*sizeof(byte)); + if not LoadImg8(lImgName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load ' +lHdr.ImgFileName); + freemem(lImg); + exit; + end; + result := 0; + for lVox := 1 to lVolVox do + if (lImg^[lVox] <> 0) then + inc(result); + freemem(lImg); +end; + + +procedure TMainForm.PenalizedLogisticRegerssion1Click(Sender: TObject); +label + 666; +var + lVol,lMin,lMax,lI,lFact,lnFactors,lSubj,lnSubj,lMaskVoxels,lnCrit: integer; + lImageNames: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lStr: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lTempRA: singleP; + //lBinomial: boolean; +begin + // lBinomial := false; + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not GetValX(lnSubj,lnFactors,lMultiSymptomRA,lImageNames,lnCrit{,binom},lPredictorList) then + goto 666; + lTemp4D := CreateDecompressed4D(lImageNames); + if (lnSubj < 2) or (lnFactors < 1) then begin + showmessage('This analysis requires at least 2 participants and one factor'); + goto 666; + end; + lMaskname := lImageNames[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st image: '+lMaskname); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + case MessageDlg('Do you want to add lesion volume as a regressor?', mtConfirmation, + [mbYes, mbNo], 0) of { produce the message dialog box } + mrYes: begin + //add a new condition called lesionvolume - create a new larger array for data + Msg('Computing lesion volumes...'); + lPredictorList.Add('LesionVolume'); + GetMem(lTempRA,lnSubj*lnFactors*sizeof(single)); + for lI := 1 to (lnSubj*lnFactors) do + lTempRA^[lI] := lMultiSymptomRA^[lI]; + Freemem(lMultiSymptomRA); + GetMem(lMultiSymptomRA,lnSubj*(lnFactors+1)*sizeof(single)); + for lI := 1 to (lnSubj*lnFactors) do + lMultiSymptomRA^[lI] := lTempRA^[lI]; + Freemem(lTempRA); + //now create the new factor + lI := lnSubj*lnFactors; + for lSubj := 1 to lnSubj do + lMultiSymptomRA^[lI+lSubj] := ComputeLesionVolume(lImageNames[lSubj-1]); + //ensure there is variability in this regressor + lMin := round(lMultiSymptomRA^[lI+1]); + lMax := round(lMultiSymptomRA^[lI+1]); + for lSubj := 1 to lnSubj do begin + lVol := round(lMultiSymptomRA^[lI+lSubj]); + if lVol < lMin then lMin := lVol; + if lVol > lMax then lMax := lVol; + end; + if (lMin < 0) then begin + showmessage('Regression aborted: Error computing lesion volumes.'); + goto 666; + end; + if (lMin = lMax) then begin + showmessage('Regression aborted: no variability in lesion volume.'); + goto 666; + end; + inc(lnFactors); + end; //if user decides to include lesion volume + end; //case + + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + SaveHdrDlg.Filename := loutname; + MsgClear; + Msg(kVers); + Msg('Firth Penalized regression is still beta software...'); + Msg('Number of participants: '+inttostr(lnSubj)); + Msg('Number of factors: '+inttostr(lnFactors)); + Msg('Threads: '+inttostr(gnCPUThreads)); + //next - header shows factor names + lStr :='imagename'; + for lFact := 1 to lnFactors do + lStr := lStr+','+lPredictorList[lFact-1]; + Msg(lStr); + For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lStr := lStr+','+realtostr(lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)],2); + end; + Msg (lImageNames.Strings[lSubj-1] + ' = '+lStr ); + end; + Msg('Total voxels = '+inttostr(lMaskVoxels)); + Msg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + Msg('Number of Lesion maps = '+inttostr(lnSubj)); + lOutName := lOutName+'.nii.gz'; + if not SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + FirthNPMAnalyze (lImageNames,lPredictorList,lMaskHdr,lnFactors,lnCrit, lMultiSymptomRA, lOutName); + 666: + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); +end; + +function ComputeIntersection ( lAname,lBname: string; var lUnion,lIntersection,lAnotB,lBnotA: integer): boolean; +label 667; +var + lOutName,lOutNameMod: string; + lVolVox,lVolVoxA,lVox: integer; + lImgA,lImgB: SingleP; + + lMaskHdr: TMRIcroHdr; + lA,lB: boolean; +begin + lUnion:= 0; + lIntersection := 0; + lAnotB := 0; + lBnotA := 0; + result := false; + //read A + if not NIFTIhdr_LoadHdr(lAname,lMaskHdr) then begin + showmessage('Error reading image A - '+lAname); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + getmem(lImgA,lVolVox*sizeof(single)); + if not LoadImg(lAname, lImgA, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + msg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + lVolVoxA := lVolVox; + //read B + if not NIFTIhdr_LoadHdr(lBname,lMaskHdr) then begin + showmessage('Error reading image B - '+lBname); + exit; + end; + //fx(666,round(gOffsetRA[0])); + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVoxA <> lVolVox) or (lVolVox < 1) then goto 667; + getmem(lImgB,lVolVox*sizeof(single)); + if not LoadImg(lBname, lImgB, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + msg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + for lVox := 1 to lVolVox do begin + lA := (lImgA^[lVox] <> 0); + lB := (lImgB^[lVox] <> 0); + if lA and lB then begin + //fx(lVox,lImgA^[lVox],lImgB^[lVox]); + inc(lIntersection); + end; + if lA or lB then + inc(lUnion); + if lA and not lB then + inc(lAnotB); + if lB and not lA then + inc(lBnotA); + + end; + freemem(lImgA); + freemem(lImgB); + result := true; + 667: +end; + +procedure TMainForm.ZtoP1Click(Sender: TObject); +var +lAname,lBname: string; var lUnion,lIntersection,lAnotB,lBnotA: integer; +begin +//removed + lAName := 'C:\mri\roc\p2.nii.gz'; + lBName := 'C:\mri\roc\RBD35.voi'; + if not ComputeIntersection ( lAName,lBName,lUnion,lIntersection,lAnotB,lBnotA) then + Msg('Error'); + Msg( lAName+' '+lBName+' I'+inttostr(lIntersection)+' U'+inttostr(lUnion)+' AnotB'+inttostr(lAnotB)+' BnotA'+inttostr(lBnotA)); + +end; + + +procedure TMainForm.ComputeIntersectionandUnion1Click(Sender: TObject); +label + 666; +var + lUnion,lIntersection,lAnotB,lBnotA, + lnSubj,lSubj,lMaskVoxels,lnAdditionalFactors: integer; + lImageNames: TStrings; + lMaskname, + lStr,lOutName: string; + lMaskHdr: TMRIcroHdr; + X: PMatrix; +begin + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + MsgClear; + Msg(kVers); + Msg('Compute intersection [A and B] and union [A or B] for a series of images'); + + + if not ReadPairedFilenamesReg(lImageNames,X,lnAdditionalFactors) then exit; + lnSubj :=lImageNames.Count div 2; + if lnAdditionalFactors > 1 then + DelMatrix(X, lnAdditionalFactors, lnSubj); + + lMaskname :=lImageNames[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading first image.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Image file size too small.'); + goto 666; + end; + + if not CheckVoxelsGroupX(lImageNames,lMaskHdr{lMaskVoxels}) then begin + showmessage('File dimensions differ from first image.'); + goto 666; + end; + + + Msg ('n Subjects = '+inttostr(lnSubj)); + for lSubj := 0 to (lnSubj-1) do begin + lStr := 'A=,'+lImageNames[lSubj]+',B=,'+lImageNames[lSubj+lnSubj]; + ComputeIntersection ( lImageNames[lSubj],lImageNames[lSubj+lnSubj],lUnion,lIntersection,lAnotB,lBnotA); + lStr := lStr + ',A and B=,'+inttostr(lIntersection); + lStr := lStr + ',A or B=,'+inttostr(lUnion); + lStr := lStr + ',A not B=,'+inttostr(lAnotB); + lStr := lStr + ',B not A=,'+inttostr(lBnotA); + + + + + Msg(lStr); + end; + + //Msg('Mask = '+lMaskname); + //Msg('Total voxels = '+inttostr(lMaskVoxels)); + Msg('Number of observations = '+inttostr(lnSubj)); + 666: + lImageNames.Free; +end; //compute intersection and union + + +procedure TMainForm.ROCbinomialdeficit1Click(Sender: TObject); +begin + testROC; +end; + +procedure TMainForm.ROCcontinuousdeficit1Click(Sender: TObject); +begin + testROC2; +end; + +function isBinom ( lRA: singleP; lnObs: integer): boolean; +var + lI: integer; +begin + result := false; + if lnObs < 1 then exit; + for lI := 1 to lnObs do + if (lRA^[lI] <> 0) and (lRA^[lI] <> 1) then + exit; + result := true; +end; + +procedure Means ( lBinomRA,lContRA: singleP; lnObs: integer); +var + lI,ln0: integer; + lMeans0, lMeans1: double; +begin + lMeans0 := 0; + lMeans1 := 0; + ln0 := 0; + if lnObs < 1 then exit; + for lI := 1 to lnObs do begin + if (lBinomRA^[lI] = 0) then begin + inc(ln0); + lMeans0 := lMeans0 + lContRA^[lI]; + end else + lMeans1 := lMeans1 + lContRA^[lI]; + end; + if ln0 > 0 then + lMeans0 := lMeans0 / ln0; + if ln0 < lnObs then + lMeans1 := lMeans1 / (lnObs-ln0); + npmform.MainForm.memo1.lines.add('mean volume for '+inttostr(ln0)+' people who scored 0 is = '+floattostr(lmeans0)); + npmform.MainForm.memo1.lines.add('mean volume for '+inttostr(lnObs-ln0)+' people who scored 1 is = '+floattostr(lmeans1)); + +end; + +function AUCbinomcontT (lBinomdataRA,lContdataRA: singlep; lnSubj :integer; var lT: double): double; +var + lIn : DoubleP0; + lnGroup0,lnGroup1,lI: integer; +begin + result := 0.5; + if lnSubj < 1 then + exit; + Getmem(lIn,lnSubj*sizeof(double)); + lnGroup0 := 0; + lnGroup1 := 0; + for lI := 1 to lnSubj do begin + if lBinomdataRA^[lI] = 0 then begin + lIn^[lnGroup0] := lContdataRA^[lI]; + inc (lnGroup0); + end else begin + inc (lnGroup1); + lIn^[lnSubj-lnGroup1] := lContdataRA^[lI]; + + end; + end; + result := continROC (lnSubj, lnGroup0, lIn); + TStat2 (lnSubj, lnGroup0, lIn,lT); + freemem(lIn); +end; + + +procedure Contrast(lBehavName,lROIname: string; lBehavRA,lLesionVolRA: singleP; lnSubj: integer); +var + lDF: integer; + lROC,lT,lP: double; +begin + if isBinom (lBehavRA,lnSubj) then begin + lROC := AUCbinomcontT (lBehavRA,lLesionVolRA, lnSubj,lT); + lDF := lnSubj-2; + lP := pTdistr(lDF,lT); + Means ( lBehavRA,lLesionVolRA, lnSubj); + + npmform.MainForm.memo1.lines.add('ROI=,'+lROIname+',Behav=,'+lBehavName+', Area Under Curve=,'+floattostr(lROC)+', T('+inttostr(lDF)+')=,'+floattostr(lT)+',p<,'+floattostr(lp)); + end else begin + lROC := AUCcontcont (lBehavRA,lLesionVolRA, lnSubj); + npmform.MainForm.memo1.lines.add('ROI=,'+lROIname+',Behav=,'+lBehavName+', Area Under Curve = '+floattostr(lROC)); + end; + //xxx +end; + +function ComputeOverlap ( lROIname: string; var lLesionNames: TStrings; var lROIvol: double; lFracROIinjured: singlep): boolean; +label 667; +var + lName: string; + lSum: double; + lLesion,lnLesions,lVolVox,lVolVoxA,lVox: integer; + lROIImg,lImgB: SingleP; + lMaskHdr: TMRIcroHdr; +begin + lROIvol := 0; + result := false; + lnLesions := lLesionNames.count; + if lnLesions < 1 then begin + showmessage('Error: no lesion names'); + exit; + end; + for lLesion := 1 to lnLesions do + lFracROIinjured^[lLesion] := 0; + //read A + if not NIFTIhdr_LoadHdr(lROIname,lMaskHdr) then begin + showmessage('Error reading ROI - '+lROIname); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then begin + showmessage('Error with Mask voxels ' + inttostr(lVolVox)); + exit; + end; + if not CheckVoxelsGroupX(lLesionNames, lMaskHdr) then begin + showmessage('Error image dimensions vary.'); + exit; + end; + getmem(lROIImg,lVolVox*sizeof(single)); + getmem(lImgB,lVolVox*sizeof(single)); + if not LoadImg(lROIname, lROIImg, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + MainForm.NPMmsg('Unable to load lesion ' +lMaskHdr.ImgFileName); + goto 667; + end; + lVolVoxA := lVolVox; + for lVox := 1 to lVolVox do + if (lROIImg^[lVox] > 0) then + lROIvol := lROIvol +lROIImg^[lVox]; + //read Lesion + if lROIvol < 1 then begin + MainForm.NPMmsg('ROI volume < 1'); + goto 667; + end; + //for each lesion + //MainForm.NPMmsg('Compute overlap started '+inttostr(lnLesions)+' '+floattostr(lROIvol)+' '+inttostr(lVolVoxA)); + MainForm.ProgressBar1.Position := 0; + for lLesion := 1 to lnLesions do begin + MainForm.ProgressBar1.Position := round((lLesion/lnLesions)*100) ; + lSum := 0; + lName := lLesionNames.Strings[lLesion-1]; + if not NIFTIhdr_LoadHdr(lName,lMaskHdr) then begin + showmessage('Error reading lesion - '+lName); + exit; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVoxA <> lVolVox) or (lVolVox < 1) then begin + MainForm.NPMmsg('Volume does not have expected number of voxels ' +lMaskHdr.ImgFileName +'<>'+lROIname+ ' found ' +inttostr(lVolVox)+' expected '+inttostr(lVolVoxA)); + goto 667; + end; + if not LoadImg(lName, lImgB, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + MainForm.NPMmsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + for lVox := 1 to lVolVox do begin + //if {(lImgB^[lVox] <> 0) and} (lROIImg^[lVox] <> 0) then fx(lROIImg^[lVox]); + + if (lROIImg^[lVox] > 0) and (lImgB^[lVox] <> 0) then + lSum := lSum + lROIImg^[lVox]; + end; + lFracROIinjured^[lLesion] := lSum/lROIvol; + end;//for each lesion + result := true; + MainForm.ProgressBar1.Position := 0; + + (*for lLesion := 1 to lnLesions do begin + if lFracROIinjured^[lLesion] > 0 then + fx( lFracROIinjured^[lLesion], lLesion); + end; *) + + 667: + + freemem(lImgB); + freemem(lROIImg); +end; + + +procedure TMainForm.ROIanalysis1Click(Sender: TObject); +label + 666; +var + lROI,lnROI,lVol,lMin,lMax,lI,lFact,lnFactors,lSubj,lnSubj,lMaskVoxels,lnCrit: integer; + lROInames,lImageNames: TStrings; + lPredictorList: TStringList; + lVolStr,lTemp4D,lOutName,lStr: string; + lBehav: single; + lROIvolRA: doubleP; + lMultiSymptomRA,lLesionVolRA,lBehavRA: singleP; + lError: boolean; +begin + if not OpenDialogExecute('Select regions of interest',true,false,kImgPlusVOIFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lROInames:= TStringList.Create; + lROInames.addstrings(OpenHdrDlg.Files); + lnROI := lROINames.Count; + if lnROI < 1 then begin + showmessage('You need to select at least one ROI.'); + exit; + end; + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + if not GetValX(lnSubj,lnFactors,lMultiSymptomRA,lImageNames,lnCrit,lPredictorList) then + goto 666; + lTemp4D := CreateDecompressed4D(lImageNames); + if (lnSubj < 1) or (lnFactors < 1) then begin + showmessage('This analysis requires at least 1 participant and one factor'); + goto 666; + end; + MsgClear; + Msg(kVers); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + Msg('VAL file name: '+MainForm.OpenHdrDlg.Filename); + Msg('Number of participants: '+inttostr(lnSubj)); + Msg('Number of factors: '+inttostr(lnFactors)); + Msg('Number of Lesion maps = '+inttostr(lnSubj)); + //next - header shows factor names + lStr :='imagename'; + for lFact := 1 to lnFactors do + lStr := lStr+','+lPredictorList[lFact-1]; + for lROI := 1 to lnROI do + lStr := lStr+','+lROInames[lROI-1]; + Msg(lStr+',LesionVolume'); + lError := false; + Getmem(lROIVolRA, lnSubj*lnROI*sizeof(double)); + Getmem(lLesionVolRA, lnSubj*lnROI*sizeof(single)); + Getmem(lBehavRA, lnSubj*lnFactors*sizeof(single)); + for lROI := 1 to lnROI do begin + //if not ComputeIntersection ( lImageNames.Strings[lSubj-1],lROInames[lROI-1],lUnion,lIntersection,lAnotB,lBnotA) then + if not ComputeOverlap (lROInames[lROI-1],lImageNames, lROIvolRA^[lROI], singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1])) then begin + MainForm.NPMmsg('Error computing overlap'); + goto 666; + end; + end; + For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lBehav := lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)]; + lStr := lStr+','+realtostr(lBehav,2); + lBehavRA^[((lFact-1)*lnSubj) +lSubj] := lBehav; + end; + for lROI := 1 to lnROI do + lStr := lStr+','+floattostr(lLesionVolRA^[((lROI-1)*lnSubj) +lSubj]); + lVolStr := floattostr(ComputeLesionVolume(lImageNames.Strings[lSubj-1])); + Msg (lImageNames.Strings[lSubj-1] + ' = '+lStr +','+lVolStr ); + end; + (* For lSubj := 1 to lnSubj do begin + lStr :=''; + for lFact := 1 to lnFactors do begin + lBehav := lMultiSymptomRA^[lSubj+ ((lFact-1)*lnSubj)]; + lStr := lStr+','+realtostr(lBehav,2); + lBehavRA^[((lFact-1)*lnSubj) +lSubj] := lBehav; + end; + for lROI := 1 to lnROI do begin + if ComputeIntersection ( lImageNames.Strings[lSubj-1],lROInames[lROI-1],lUnion,lIntersection,lAnotB,lBnotA) then begin + lStr := lStr+','+inttostr(lIntersection); + lLesionVolRA^[((lROI-1)*lnSubj) +lSubj] := lIntersection; + end else begin + lError:= true; + lStr := lStr+',error'; + end; + //Msg( lImageNames.Strings[lSubj-1]+' '+lROInames[lROI-1]+' I'+inttostr(lIntersection)+' U'+inttostr(lUnion)+' AnotB'+inttostr(lAnotB)+' BnotA'+inttostr(lBnotA)); + + end; + Msg (lImageNames.Strings[lSubj-1] + ' = '+lStr ); + end;*) + for lROI := 1 to lnROI do begin + for lFact := 1 to lnFactors do begin + Contrast(lPredictorList[lFact-1],lROInames[lROI-1],singlep(@lBehavRA^[((lFact-1)*lnSubj)+1]),singlep(@lLesionVolRA^[((lROI-1)*lnSubj)+1]),lnSubj);//,((lFact-1)*lnSubj),((lROI-1)*lnSubj)); + end; //for each factor + end; //for each ROI + for lROI := 1 to lnROI do begin + Msg( lROInames[lROI-1] +' volume = '+floattostr(lROIvolRA^[lROI]) ) + end; //for each ROI + Freemem(lLesionVolRA); + Freemem(lBehavRA); + Freemem(lROIvolRA); + +666: + lROInames.free; + lImageNames.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); +end; + + +procedure TMainForm.Masked1Click(Sender: TObject); +var + lFilename,lMaskname: string; + lPos: Integer; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select brain mask ',false,false,kImgFilter) then begin + showmessage('NPM aborted: mask selection failed.'); + exit; + end; //if not selected + lMaskname := OpenHdrDlg.Filename; + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + balance(lFilename,lMaskname,(Sender as TMenuItem).tag); + end; +end; + +function Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; +var + lImg8: ByteP; + lImg: SingleP; + lHdr: TMRIcroHdr; + lVolVox,lVox: integer; + lMin,lMax: single; + lModeLo,lModeHi,lIntercept,lSlope: single; + lOutNameMod: string; +begin + //lOutName := lMaskHdr.ImgFileName; + result := false; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + if not NIFTIhdr_LoadHdr(lImageName,lHdr) then begin + showmessage('Error reading '+lImageName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + getmem(lImg8,lVolVox*sizeof(byte)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; +if lZeroThresh then begin + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.nii'); + + lMin := 0; + lMax := 0 +end else begin + lOutNameMod := ChangeFilePrefixExt(lImageName,'i','.voi'); + + lMin := lIMg^[1]; + for lVox := 1 to lVolVox do + if lImg^[lVox] < lMin then lMin := lIMg^[lVox]; + + lMax := lIMg^[1]; + for lVox := 1 to lVolVox do + if lImg^[lVox] > lMax then lMax := lIMg^[lVox]; + for lVox := 1 to lVolVox do + lImg8^[lVox] := 0; + lMax := ((lMax-lMin) / 2)+lMin; +end; + for lVox := 1 to lVolVox do + if lImg^[lVox] > lMax then + lImg8^[lVox] := lNonZeroVal; + Msg('Creating ' +lOutNameMod+' Threshold = '+floattostr(lMax)); + NIFTIhdr_SaveHdrImg8(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lImg8,1); + freemem(lIMg8); + freemem(lImg); + +end; + + +procedure TMainForm.Binarizeimages1Click(Sender: TObject); +var + lFilename: string; + lPos: Integer; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + Binarize(lFilename,1,false); + //Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; + end; + Msg('Done'); +end; + +procedure TMainForm.Resliceimagetoneworientationandboundingbox1Click( + Sender: TObject); +begin +(* var + lSourcename,lTargetName: string; + lPos: integer; +begin + MsgClear; + Msg(GetKVers); + Msg('This function will transform a source image to match a target image.'); + Msg(' The resliced image will have the voxel size, orientation and bounding box of the target.'); + Msg('You will be prompted to select a target image as well as source images.'); + Msg(' The resliced image will have the prefix ''r'', e.g. c:\source.nii -> c:\rsource.nii.'); + if not OpenDialogExecute('Select target image (source images will be resliced to match target)',false,false,kImgFilter) then begin + showmessage('reslice aborted: target selection failed.'); + exit; + end; //if not selected + lTargetName := OpenHdrDlg.Filename; + if not OpenDialogExecute('Select source images for reslicing',true,false,kImgFilter) then begin + showmessage('reslice aborted: source selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lSourcename := OpenHdrDlg.Files[lPos-1]; + + xxBinarize(lFilename); + end; + Msg('Done'); + *) +end; + + +procedure TMainForm.Setnonseroto1001Click(Sender: TObject); +var + lFilename: string; + lPos: Integer; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + Binarize(lFilename,100,true); + //Binarize (var lImageName:String; lNonZeroVal: integer; lZeroThresh: boolean): boolean; + end; +end; + +procedure TMainForm.Savetext1Click(Sender: TObject); +begin + SaveHdrDlg.Title := 'Save file as comma separated values (to open with Excel)'; + SaveHdrDlg.Filter := 'Comma Separated (*.csv)|*.csv|Text (*.txt)|*.txt'; + SaveHdrDlg.DefaultExt := '*.csv'; + if not SaveHdrDlg.Execute then exit; + Memo1.Lines.SaveToFile(SaveHdrDlg.Filename); +end; + +procedure TMainForm.AnaCOMmenuClick(Sender: TObject); +begin +{$IFDEF compileANACOM} + DoAnaCOM; +{$ENDIF} +end; + +procedure TMainForm.MonteCarloSimulation1Click(Sender: TObject); +begin +{$IFDEF benchmark} + LesionMonteCarlo (false,true,true); +{$ENDIF} +end; + +function TMainForm.MakeSubtract (lPosName,lNegName: string): boolean; +var + lNegImg,lImg,lOutImg: SingleP; + lHdr,lNegHdr: TMRIcroHdr; + lVolVox,lVox: integer; + lOutNameMod: string; +begin + result := false; + if not NIFTIhdr_LoadHdr(lPosName,lHdr) then begin + showmessage('Error reading '+lPosName); + exit; + end; + lVolVox := lHdr.NIFTIhdr.dim[1]*lHdr.NIFTIhdr.dim[2]* lHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + + if not NIFTIhdr_LoadHdr(lNegName,lNegHdr) then begin + showmessage('Error reading '+lNegName); + exit; + end; + if lVolVox <> (lNegHdr.NIFTIhdr.dim[1]*lNegHdr.NIFTIhdr.dim[2]* lNegHdr.NIFTIhdr.dim[3]) then begin + showmessage('Volumes differ'); + exit; + + end; + getmem(lImg,lVolVox*sizeof(single)); + if not LoadImg(lHdr.ImgFileName, lImg, 1, lVolVox,round(lHdr.NIFTIhdr.vox_offset),1,lHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load ' +lHdr.ImgFileName); + exit; + end; + getmem(lNegImg,lVolVox*sizeof(single)); + if not LoadImg(lNegHdr.ImgFileName, lNegImg, 1, lVolVox,round(lNegHdr.NIFTIhdr.vox_offset),1,lNegHdr.NIFTIhdr.datatype,lVolVox) then begin + Msg('Unable to load ' +lNegHdr.ImgFileName); + exit; + end; + getmem(lOutImg,lVolVox*sizeof(single)); + for lVox := 1 to lVolVox do + lOutImg^[lVox] := lImg^[lVox] - lNegImg^[lVox]; + + + lHdr.NIFTIhdr.scl_slope := 1; + lHdr.NIFTIhdr.scl_inter := 0; + lOutNameMod := ChangeFilePrefixExt(lPosName,'subtract_','.hdr'); + Msg(lPosName+' - ' + lNegName+ ' = '+lOutNameMod); + NIFTIhdr_SaveHdrImg(lOutNameMod,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr),true,lOutImg,1); + //end optional + //NIFTIhdr_SaveHdr(lHdr.HdrFilename,lHdr.NIFTIhdr,true,not IsNifTiMagic(lHdr.NIFTIhdr)); + + freemem(lImg); + freemem(lOutImg); + freemem(lNegImg); +end;//makesubtract + +procedure TMainForm.Subtract1Click(Sender: TObject); +var + lPosName,lNegName: string; +begin + if not OpenDialogExecute('Select positive',false,false,kImgPlusVOIFilter) then + exit; + lPosName := OpenHdrDlg.FileName; + if not OpenDialogExecute('Select negative',false,false,kImgPlusVOIFilter) then + exit; + lNegName := OpenHdrDlg.FileName; + MakeSubtract (lPosName,lNegName); + +end; + + + + + + +procedure TMainForm.LogPtoZ1Click(Sender: TObject); +var + lFilename: string; + lPos: Integer; +begin + MsgClear; + Msg(GetKVers); + if not OpenDialogExecute('Select images for intensity normalization',true,false,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + if OpenHdrDlg.Files.Count < 1 then + exit; + for lPos := 1 to OpenHdrDlg.Files.Count do begin + lFilename := OpenHdrDlg.Files[lPos-1]; + //LogPToZ(lFilename,1,false); + + end; + Msg('Done'); +end; + + {$IFDEF UNIX} + + +initialization + {$I npmform.lrs} +{$ELSE} //not unix: windows +initialization +{$IFDEF FPC} + {$I npmform.lrs} + {$ENDIF}//FPC + OleInitialize(nil); + +finalization + OleUninitialize +{$ENDIF} //Windows + +end. + \ No newline at end of file diff --git a/npm_precl/old/anacom.pas b/npm_precl/old/anacom.pas new file mode 100755 index 0000000..f551127 --- /dev/null +++ b/npm_precl/old/anacom.pas @@ -0,0 +1,632 @@ +unit anacom; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr,filename, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +//procedure DoAnaCOM; +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; + + + +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lCombinedSymptomRA: singleP; + lPos,lPlank,lThread,lnControlsPlusPatients: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshBonf,lThreshPermute,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lBM,lttest,lLtest: boolean; + lnControlNeg: integer; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + lnControlNeg := lnControl; //negative for binomial test + lttest := lttestin; + lbm := lbmin; + if (not (lttest)) and (not (lbm)) then begin + lLtest := true; + lBM := true; + lnControlNeg := -lnControl; + end; + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + if lnControl < 1 then begin + MainForm.NPMmsg('AnaCom aborted - need data from at least 1 control individual'); + exit; + end; + lnPermute := 0;//MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + lnControlsPlusPatients := lImages.Count+lnControl; + createArray64(lObsp,lObs,lnControlsPlusPatients); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + //sumptom array for lesions AND controls + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + for lPos := 1 to lnControl do + lObs^[lPos-1+lImages.Count] := lControlSymptomRA^[lPos]; + getmem(lCombinedSymptomRA,lnControlsPlusPatients* sizeof(single)); + for lPos := 1 to lnControlsPlusPatients do + lCombinedSymptomRA^[lPos] := lObs^[lPos-1]; + //next create permuted BM bounds + if lBM then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + //for lPos := 1 to lImages.Count do + // lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lnControlsPlusPatients, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + + with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lnControlNeg,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,nil,lCombinedSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + //Next: NULPS + if lRun > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lnCrit,lnVoxTested,lPlankImg)); + + //lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit)); + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if (lRun < 1) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lRun < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + if lnControl < 1 then + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('attest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'attest'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaComthreshtt,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Mann Whitney + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('aBM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'aBM'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaCOMthreshbm,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + + + +(*function readCSV2 (lFilename: string; lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) or (MaxC < (kHdrCol+lCol2)) then begin + showmessage('problems reading CSV - not enough columns/rows '+inttostr(lCol1)+' '+inttostr(lCol2)); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := MaxC-1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + getmem(ldataRA2,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) or ((C-kHdrCol) = lCol2) then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then + ldataRA1^[R-kHdrRow] := lTempFloat + else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat; + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + ldataRA2^[R-1] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; *) + +function readTxt (lFilename: string; var lnObservations : integer; var ldataRA1: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lCol1: integer; + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lCol1:= 1; + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) then begin + showmessage('problems reading CSV - not enough columns/rows '); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := kHdrCol+lCol1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) {or ((C-kHdrCol) = lCol2)} then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then begin + //showmessage(lNumStr); + ldataRA1^[R-kHdrRow] := lTempFloat; + end; + {else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat;} + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + //showmessage(lNumStr+' '+inttostr(lnFactors)+' '+inttostr(C)); + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(inttostr(R)+' '+floattostr(lTempFLoat)); + ldataRA1^[R] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; + +(*procedure DoAnaCOM; +label + 666; +var + lControlFilename: string; + lI, lnControlObservations : integer; + lControldata: singlep; + lBinomial: boolean; + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('AnaCOM analysis requires TXT/CSV format text file.'); + npmform.MainForm.memo1.lines.add('One row per control participant.'); + npmform.MainForm.memo1.lines.add('First column is performance of that participant.'); + npmform.MainForm.memo1.lines.add('Example file:'); + //npmform.MainForm.memo1.lines.add('deficit, voxels'); + npmform.MainForm.memo1.lines.add('11'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('2'); + npmform.MainForm.memo1.lines.add('22'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('6'); + lControlFilename := 'c:\fx.txt'; + if (not readTxt (lControlFilename, lnControlObservations,lControldata)) or (lnControlObservations < 1) then begin + showmessage('Error reading file '+lControlFilename); + exit; + end; + npmform.MainForm.memo1.lines.add('Control (n='+inttostr(lnControlObservations)+')performance: '); + for lI := 1 to lnControlObservations do begin + npmform.MainForm.memo1.lines.add(inttostr(lI)+' '+floattostr(lControldata^[lI])); + + end; + //begin - copy + + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not MainForm.GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit,{,binom}lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + + + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then exit; + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + MainForm.NPMmsgClear; + MainForm.NPMMsg(MainForm.GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to lnSubj do + MainForm.NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroup(lImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + MainForm.ReportDescriptives(lSymptomRA,lnSubj); + AnacomLesionNPMAnalyze(lImageNames,lMaskHdr,lnCrit,-1,lnControlObservations,lSymptomRA,lControldata,lFactName,lOutname,true {ttest},false{BM}); + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + + Freemem(lMultiSymptomRA); + end; + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + ///end + //AnacomLesionNPMAnalyze ( lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttest,lBM: boolean): boolean; + freemem(lControldata); + + + +end;*) + +end. diff --git a/npm_precl/old/lesion.pas b/npm_precl/old/lesion.pas new file mode 100755 index 0000000..46b646b --- /dev/null +++ b/npm_precl/old/lesion.pas @@ -0,0 +1,416 @@ +unit lesion; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; + + +function LesionNPMAnalyze2 (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnPermute: integer; var lSymptomRA: SingleP;var lFactname,lOutName: string; lttest,lBM: boolean): boolean; +function LesionNPMAnalyzeBinomial2 (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lnPermute: integer; var lSymptomRA: SingleP; var lFactname,lOutName: string): boolean; +var + gNULP,gROI: boolean; +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} +function LesionNPMAnalyze2 (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnPermute: integer; var lSymptomRA: SingleP;var lFactname,lOutName: string; lttest,lBM: boolean): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lPos,lPlank,lThread: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,//,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshPermute,lThreshBonf,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lPlankAllocated: boolean; + //lttest,lBM: boolean; + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + lPlankAllocated := false; + //lnPermute := MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lPlankAllocated := true; + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + getmem(lOutImgAUC,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + //next create permuted BM bounds + if lBM then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lImages.Count, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA) do + //with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + //freemem(lPlankImg); + //lPlankAllocated := false; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if lRun < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + //save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + if lRun < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lRun < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + if lRun > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lnCrit,lnVoxTested,lPlankImg)); + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('ttest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('threshtt,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Brunner Munzel + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('BM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('threshbm,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgAUC); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + if lPlankAllocated then + freemem(lPlankImg); + //Next: NULPS - do this after closing all memory - this is a memory hog + if gNULP then + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit,lnVoxTested)); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + //if lRun > 0 then + // AX(freeram,freeram,freeram,freeram,freeram,freeram); + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + +function LesionNPMAnalyzeBinomial2 (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lnPermute: integer; var lSymptomRA: SingleP; var lFactname,lOutName: string): boolean; +label + 123,667; +var + lVal: single; + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgL,lOutImgAUC,lDummyImg, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM: singleP; + lPos,lPlank,lThread,lnDeficit: integer; + lTotalMemory,lVolVox,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadInc,lThreadEnd, lnLesion, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT, lSum: double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + //lOutName := lMaskHdr.ImgFileName; + //if not SaveHdrName ('Statistical Map', lOutName) then exit; + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lImages.Count); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgL,lVolVox* sizeof(single)); + getmem(lOutImgAUC,lVolVox* sizeof(single)); + + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgL^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + ClearThreadDataPvals(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.ProgressBar1.Position := 1; + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + //with TLesionBinomial.Create (ProgressBar1,false,true,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,666, lDummyImg,lPlankImg,lOutImgSum,lOutImgL,lDummyImg,lSymptomRA) do + with TLesionBinom.Create (MainForm.ProgressBar1,false,true,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgL,lDummyImg,lOutImgAUC,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + MainForm.NPMmsg('Thread ' +Inttostr(gThreadsRunning)+' = '+inttostr(lThreadStart)+'..'+inttostr(lThreadEnd)); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + for lPos := 1 to lnPermute do begin + if (lPermuteMinT^[lPos] > 1.1) or (lPermuteMinT^[lPos] < -1.1) then + lPermuteMinT^[lPos] := 0.5; + if (lPermuteMaxT^[lPos] > 1.1) or (lPermuteMaxT^[lPos] < -1.1) then + lPermuteMaxT^[lPos] := 0.5; + lVal := lPermuteMaxT^[lPos]; + lPermuteMaxT^[lPos] := lPermuteMinT^[lPos]; + lPermuteMinT^[lPos] := lVal; + if lPermuteMaxT^[lPos] < 0 then + lPermuteMaxT^[lPos] := -pNormalInv(abs(lPermuteMaxT^[lPos])) + else + lPermuteMaxT^[lPos] := pNormalInv(lPermuteMaxT^[lPos]); + if lPermuteMinT^[lPos] < 0 then + lPermuteMinT^[lPos] := -pNormalInv(abs(lPermuteMinT^[lPos])) + else + lPermuteMinT^[lPos] := pNormalInv(lPermuteMinT^[lPos]); + end; + + + + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + //next report findings + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + MainForm.reportBonferroni('Std',lnVoxTested); + + //next: save data +//savedata + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); + +//future images will store Z-scores... + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +//save power map + lnDeficit := 0; + for lPos := 1 to lImages.Count do + if lSymptomRA^[lPos] = 0 then + inc(lnDeficit); + if Sum2PowerBinom(lOutImgSum,lVolVox,lImages.Count,lnDeficit) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + //save Liebermeister + + lOutNameMod := ChangeFilePostfixExt(lOutName,'L'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgL,1); + //save end + MainForm.reportFDR ('L', lVolVox, lnVoxTested, lOutImgL); + MainForm.reportPermute('L',lnPermute,lPermuteMaxT, lPermuteMinT); + +123: +//next: free dynamic memory + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgL); + freemem(lOutImgAUC); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + //Next: NULPS - do this at the end, it is a memory hog! + if gNULP then + MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit,lnVoxTested)); + + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + + MainForm.ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; + + + + + +end. diff --git a/npm_precl/old/montecarlo.pas b/npm_precl/old/montecarlo.pas new file mode 100755 index 0000000..726fba2 --- /dev/null +++ b/npm_precl/old/montecarlo.pas @@ -0,0 +1,197 @@ +unit montecarlo; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); + +implementation + +uses npmform,filename,turbolesion; + +procedure RandomGroup(kSamplesPerTest: integer;lImageNames: TStrings;lSymptomRA: SingleP;var lPartImageNames: TStrings; var lPartSymptomRA: SingleP); +var + lTotal,lInc,lRand,lSwap: integer; + lRanOrder: longintP; +begin + lPartImageNames.Clear; + lTotal := lImageNames.Count; + if kSamplesPerTest > lTotal then begin + showmessage('Monte carlo error: population must be larger than sample size.'); + exit; + end; + //fx(lTOtal); + Getmem(lRanOrder,lTotal*sizeof(longint)); + for lInc := 1 to lTotal do + lRanOrder^[lInc] := lInc; + for lInc := lTotal downto 2 do begin + lRand := Random(lInc)+1; + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc]; + lRanOrder^[lInc] := lSwap; + end; + for lInc := 1 to kSamplesPerTest do begin + lPartImageNames.Add(lImageNames.Strings[lRanOrder^[lInc]-1]);//indexed from 0 + lPartSymptomRA^[lInc] := lSymptomRA^[lRanOrder^[lInc]]; + end; + Freemem(lRanOrder); +end; + +{$DEFINE notanacom} +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); +label + 666; +const + kSimSampleSize = 64; + knSim = 5; + kCrit = 3; + {$IFDEF anacom} + knControls = 64; + {$ENDIF} +var + lPrefs: TLDMPrefs ; + lSim,lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lPartImageNames,lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname,lOutNameSim: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA,lPartSymptomRA: singleP; + {$IFDEF anacom} + lnControlObservations: integer; + lControlSymptomRA: singleP; + {$ENDIF} +begin + //lBinomial := not odd( (Sender as tMenuItem).tag); + lPrefs.NULP := true{gNULP false}; + if not lBinomial then begin + lPrefs.BMtest := lbm;//BMmenu.checked; + lPrefs.Ttest := lttest;//ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.nCrit := kCrit; + lPrefs.nPermute := MainForm.ReadPermute;; + lPrefs.Run := 0;{0 except for montecarlo} + if (not lBinomial) and (not lTTest) and (not lBM) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPartImageNames := TStringList.Create; + getmem(lPartSymptomRA,kSimSampleSize*sizeof(single)); + {$IFDEF anacom} + lnControlObservations := knControls; + getmem(lControlSymptomRA,lnControlObservations*sizeof(single)); + for lSim := 1 to lnControlObservations do + lControlSymptomRA^[lSim] := 5; + {$ENDIF} + //next, get 1st group + if not MainForm.GetVal(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit{,binom},lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) or (lnSubjAll < kSimSampleSize) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') [sample size is '+inttostr(kSimSampleSize)+']or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + //randomization loop.... + for lSim := 1 to knSim do begin + RandomGroup(kSimSampleSize, lImageNames,lSymptomRA, lPartImageNames, lPartSymptomRA); + lOutNameSim := AddIndexToFilename(lOutName,lSim); + lnCrit := kCrit; + MainForm.NPMMsgClear; + //Msg(GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to kSimSampleSize do + MainForm.NPMMsg (lPartImageNames.Strings[lSubj-1] + ' = '+realtostr(lPartSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(kSimSampleSize)); + if not CheckVoxelsGroup(lPartImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lPrefs.Run := lSim; + if lBinomial then + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim) + else begin + MainForm.ReportDescriptives(lPartSymptomRA,lnSubj); + //TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim); + {$IFDEF anacom} + AnacomLesionNPMAnalyze (lPartImageNames, lMaskHdr, lnCrit,lSim,lnControlObservations, lPartSymptomRA,lControlSymptomRA, lFactname,lOutNameSim,lPrefs.Ttest,lPrefs.BMtest {lttest,lBM}); + {$ENDIF} + end; + end; //for each simulation... + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lPartImageNames.free; + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + freemem(lPartSymptomRA); + {$IFDEF anacom} + freemem(lControlSymptomRA); + {$ENDIF} + DeleteDecompressed4D(lTemp4D); +end; + + + +end. + + diff --git a/npm_precl/options.inc b/npm_precl/options.inc new file mode 100755 index 0000000..7cb7052 --- /dev/null +++ b/npm_precl/options.inc @@ -0,0 +1,7 @@ +{ -------------------------------------------------------------------- } + +{$DEFINE SPREADSHEET} + +{If "DEFINE SPREADSHEET" then the VAL file design for will be created.} +{This uses the spread.* and design.* files} + diff --git a/npm_precl/overlap.pas b/npm_precl/overlap.pas new file mode 100755 index 0000000..3f65a32 --- /dev/null +++ b/npm_precl/overlap.pas @@ -0,0 +1,452 @@ +unit overlap; +{$H+} + +interface +uses +nifti_hdr,define_types,SysUtils, +StatThdsUtil,Brunner,nifti_img, + Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,lesion_pattern; + + +Type + OverlapRA = array [1..1] of TLesionPattern;//Toverlap; + Overlapp = ^OverlapRA; + +//function CountOverlap2(var lImages: TStrings; lMinDeficits: integer; lPlankImg: bytep): integer; +function CountOverlap (var lImages: TStrings; lMinDeficits,lnVoxTested: integer): integer; +procedure EvaluatePower(var lFilenames: TStrings; lOverlapInc,lOverlapMax,lReps,lPct: integer); +function CountOverlap2(var lImages: TStrings; lMinDeficits, lnVoxTested: integer; lPlankImg: bytep): integer; + +//procedure EvaluatePower; + +implementation +uses npmform; + +function SelectFiles (var lIn,lOut: TStrings; lN: integer): boolean; +//select (without replacement) lN filenames from the population lIn +var + lnFound,lTrial,lRan,lSwap: integer; + lRandRA: longintP; +begin + result := false; + lnFound := lIn.count; + + if (lnFound < lN) then + exit; //not enough items found + getmem(lRandRA,lnFound*sizeof(longint)); + for lTrial := 1 to lnFound do + lRandRA^[lTrial] := lTrial-1; //index to each strong + for lTrial := lnFound downto 2 do begin + //jumble order + lRan := random(lTrial)+1; + lSwap := lRandRA^[lTrial]; + lRandRA^[lTrial] := lRandRA^[lRan]; + lRandRA^[lRan] := lSwap; + end; + for lTrial := 1 to lN do + lOut.Add(lIn[lRandRA^[lTrial]]); + freemem(lRandRA); + result := true; +end; + +procedure EvaluatePower(var lFilenames: TStrings; lOverlapInc,lOverlapMax,lReps,lPct: integer); +label + 666; +var + lG: TStrings; + lSize,lRep: integer; +begin + if (lReps < 1) or (lOverlapMax < 1) or (lOverlapInc < 1) or (lOverlapMax > lFilenames.count) or (lOverlapInc > lOverlapMax) then begin + showmessage('Error with EvaluatePower inputs...'); + exit; + end; + + MainForm.NPMMsgClear; + //MainForm.NPMmsg(kVers); + randomize; + MainForm.NPMmsg('Power Analysis began = ' +TimeToStr(Now)); + lSize := lOverlapInc; + while lSize <= lOverlapMax do begin + for lRep := 1 to lReps do begin + lG:= TStringList.Create; + if not SelectFiles(lFilenames,lG,lSize) then begin + showmessage('Error selecting '+inttostr(lSize)+'files!'); + goto 666; + end; + CountOverlap(lG, round((lPct/100)*lSize),-1 ); + lG.Free; + end; //for lLoop + lSize := lSize + lOverlapInc; + end; //for lRep + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + exit; + 666: //there has been a critical failure! + lG.Free; +end; + +(*function SelectFiles (lN: integer; var lOut: TStrings): boolean; +var + lnFound,lTrial,lRan,lSwap: integer; + lMaskExt,lFilePath: string; + lSearchRec: TSearchRec; + lF: TStrings; + lRandRA: longintP; +begin + result := false; + lF:= TStringList.Create; + lFilepath := 'C:\140\'; + lMaskExt := '*.voi'; + if FindFirst(lFilePath{+PathDelim}+lMaskExt, faAnyFile-faSysFile-faDirectory, lSearchRec) = 0 then begin + repeat + lF.add(lFilePath+lSearchRec.Name); + until (FindNext(lSearchRec) <> 0); + end; + lnFound := lF.count; + if (lnFound < lN) then begin + lF.free; + exit; + end; //not enough items found + getmem(lRandRA,lnFound*sizeof(longint)); + for lTrial := 1 to lnFound do + lRandRA[lTrial] := lTrial-1; //index to each strong + for lTrial := lnFound downto 2 do begin + //jumble order + lRan := random(lTrial)+1; + lSwap := lRandRA[lTrial]; + lRandRA[lTrial] := lRandRA[lRan]; + lRandRA[lRan] := lSwap; + end; + for lTrial := 1 to lN do + lOut.Add(lF[lRandRA[lTrial]]); + freemem(lRandRA); + lF.Free; + result := true; +end; + +procedure EvaluatePower; +label + 666; +var + lG: TStrings; + lMaskname: string; + lMaskHdr: TMRIcroHdr; + lMaskVoxels,lN,lLoop,lRep: integer; +begin + MainForm.NPMMsgClear; + //MainForm.NPMmsg(kVers); + randomize; + MainForm.NPMmsg('Power Analysis began = ' +TimeToStr(Now)); + for lRep := 7 to 10 do begin + for lLoop := 1 to 10 do begin + lN := lRep * 10; + lG:= TStringList.Create; + if not SelectFiles(lN,lG) then begin + showmessage('Error selecting '+inttostr(lN)+'files!'); + goto 666; + end; + {if not OpenDialogExecute('Select images to average',true,true,kImgFilter) then begin + showmessage('NPM aborted: file selection failed.'); + exit; + end; //if not selected + lG:= TStringList.Create; + lG.addstrings(OpenHdrDlg.Files);} + + {$IFDEF FORMATVARIES} + //this next bit allows different types of scans to be read, but it is slow.... + lMaskname := lG[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if not MainForm.CheckVoxelsGroup(lG,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + {$ENDIF} + CountOverlap(lG, {round(0.1*lN)} 0); + lG.Free; + end; //for lLoop + end; //for lRep + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + exit; + 666: //there has been a critical failure! + lG.Free; +end; *) + + + + +function CountOverlap2(var lImages: TStrings; lMinDeficits, lnVoxTested: integer; lPlankImg: bytep): integer; +label + 123,667; +const + kMaxBit = 63; +var + lMaskName: string; + //lPlankImg: byteP; + lDouble,lTotalMemory: double; + lVoxPerPlankDiv10,lOffset,lnDeficits,lUniqueOrders, + lVolVox,lPos,lPlank,lVox,lDataType,lnVoxels,lImagesCount: integer; + lnPlanks,lVoxPerPlank,lStartVox,lEndVox,lPlankImgPos: int64; + lOverlapRA: Overlapp; + lOrder,lPrevOrder: TLesionPattern;//x TOverlap; + lMaskHdr: TMRIcroHdr; + //lPowerRA: array [1..kMaxBit] of int64; +procedure CheckOrder(var lObservedOrder: TLesionPattern); +var + lInc: integer; +begin + if lUniqueOrders > 0 then begin //see if this is unique + for lInc := 1 to lUniqueOrders do + if SameOrder(lObservedOrder,lOverlapRA^[lInc],lImagesCount) then + exit; //not unique + end; //UniqueOrders > 0 + //if we have not exited yet, we have found a new ordering! + lUniqueOrders := lUniqueOrders + 1; + lOverlapRA^[lUniqueOrders] := lObservedOrder; +end; +begin + result := -1; + //MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + //lMinDeficits := 0; + lUniqueOrders := 0; + lTotalMemory := 0; + lMaskName := lImages[0]; + lImagesCount := lImages.Count; + if lImagesCount < 1 then + goto 667; + if lImages.Count > (kMaxObs) then begin + MainForm.NPMmsg('Only able to compute tests for <= '+inttostr(kMaxObs)+' overlays.'); + goto 667; + end; + if not NIFTIhdr_LoadHdr(lMaskName,lMaskHdr) then begin + MainForm.NPMmsg('Error reading 1st image.'); + goto 667; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + lDataType := lMaskHdr.NIFTIhdr.datatype; + lOffset := round(lMaskHdr.NIFTIhdr.vox_offset); + //showmessage(inttostr(lVolVox)); + if (lVolVox < 1) then goto 667; + lVoxPerPlank := kPlankSz div lImages.Count {div sizeof(single)} ; + if (lVoxPerPlank = 0) then goto 667; //no data + lDouble := lVolVox;//force floating point multiplication in next step... + lTotalMemory := lDouble * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + lnVoxels := 0; + lStartVox := 1; + lEndVox := 0; + if lnVoxTested <= 0 then + getmem(lOverlapRA,lVolVox* sizeof(TLesionPattern)) + else + getmem(lOverlapRA,lnVoxTested* sizeof(TLesionPattern)); + for lPlank := 1 to lnPlanks do begin + MainForm.ProgressBar1.Position := 1; + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lVolVox then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lVolVox); + lEndVox := lVolVox; + end; + lVoxPerPlankDiv10 := lVoxPerPlank div 10; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + {$IFDEF FORMATVARIES} + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + {$ELSE} + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,lOffset,lPlankImgPos,lDataType,lVolVox) then + {$ENDIF} + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lPrevOrder := EmptyOrder;//impossible: forces first voxel of each order to be checked + for lVox := 1 to lVoxPerPlank do begin + if (lVox mod lVoxPerPlankDiv10) = 0 then begin + MainForm.ProgressBar1.Position := (lVox div lVoxPerPlankDiv10)*10; + MainForm.Refresh; + Application.processmessages; + end; + lOrder := EmptyOrder; + lPlankImgPos := 0; + lnDeficits := 0; + for lPos := 1 to lImages.Count do begin + if (lPlankImg^[lPlankImgPos + lVox] > 0) then begin + inc(lnDeficits); + SetBit(lPos,lOrder); + end; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end; + if (lnDeficits >= lminDeficits) then begin //this is different from the last voxel: perhaps this is a new ordering + if (not SameOrder(lOrder,lPrevOrder,lImagesCount)) then + CheckOrder(lOrder); + inc(lnVoxels); + end; + lPrevOrder := lOrder; + end; + lStartVox := lEndVox + 1; + end; + MainForm.NPMmsg('n=,'+inttostr( lImages.Count)+',minN=,'+inttostr(lMinDeficits) +',unique overlap patterns,' +Inttostr(lUniqueOrders) +',voxels tested,' +Inttostr(lnVoxels)); +123: +//next: free dynamic memory + + freemem(lOverlapRA); + //MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + MainForm.ProgressBar1.Position := 0; + result := lUniqueOrders; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 0 then begin + freemem(lPlankImg); + freemem(lOverlapRA); + end; + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; + +function CountOverlap(var lImages: TStrings; lMinDeficits,lnVoxTested: integer): integer; +var + lPlankImg: byteP; +begin + getmem(lPlankImg,kPlankSz); + result := CountOverlap2( lImages, lMinDeficits,lnVoxTested,lPlankImg); + freemem(lPlankImg); +end; + +(*function CountOverlap2(var lImages: TStrings; lMinDeficits: integer; lPlankImg: bytep): integer; +label + 123,667; + +var + lMaskName: string; + lVoxPerPlankDiv10,lOffset,lnDeficits,lUniqueOrders,lTotalMemory, + lImagesCount,lVolVox,lPos,lPlank,lVox,lDataType,lnVoxels: integer; + lnPlanks,lVoxPerPlank,lStartVox,lEndVox,lPlankImgPos: int64; + lOverlapRA: Overlapp; + lOrder,lPrevOrder: TLesionPattern; + lMaskHdr: TMRIcroHdr; + //lPowerRA: array [1..kMaxBit] of int64; + + +procedure CheckOrder(var lObservedOrder: TLesionPattern); +var + lInc: integer; +begin + if lUniqueOrders > 0 then begin //see if this is unique + for lInc := 1 to lUniqueOrders do + if SameOrder(lObservedOrder,lOverlapRA^[lInc],lImagesCount) then + exit; //not unique + end; //UniqueOrders > 0 + //if we have not exited yet, we have found a new ordering! + lUniqueOrders := lUniqueOrders + 1; + lOverlapRA^[lUniqueOrders] := lObservedOrder; +end; +begin + result := -1; + //MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + //lMinDeficits := 0; + lUniqueOrders := 0; + lTotalMemory := 0; + lImagesCount := lImages.Count; + lMaskName := lImages[0]; + if lImages.Count < 1 then + goto 667; + if lImages.Count > (kMaxObs) then begin + MainForm.NPMmsg('Only able to compute tests for <= '+inttostr(kMaxObs)+' overlays.'); + goto 667; + end; + if not NIFTIhdr_LoadHdr(lMaskName,lMaskHdr) then begin + MainForm.NPMmsg('Error reading 1st image.'); + goto 667; + end; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + lDataType := lMaskHdr.NIFTIhdr.datatype; + lOffset := round(lMaskHdr.NIFTIhdr.vox_offset); + //showmessage(inttostr(lVolVox)); + if (lVolVox < 1) then goto 667; + lVoxPerPlank := kPlankSz div lImages.Count ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := lVolVox * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + //showmessage('xx'); + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + //MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + //MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + //if lTotalMemory > kPLankSz then + + // getmem(lPlankImg,kPlankSz); + //else + // getmem(lPlankImg,lTotalMemory); + lnVoxels := 0; + lStartVox := 1; + lEndVox := 0; + getmem(lOverlapRA,lVolVox* sizeof(TLesionPattern)); + for lPlank := 1 to lnPlanks do begin + MainForm.ProgressBar1.Position := 1; + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lVolVox then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lVolVox); + lEndVox := lVolVox; + end; + lVoxPerPlankDiv10 := lVoxPerPlank div 10; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + {$IFDEF FORMATVARIES} + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + {$ELSE} + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,lOffset,lPlankImgPos,lDataType,lVolVox) then + {$ENDIF} + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lPrevOrder := EmptyOrder;//impossible: forces first voxel of each order to be checked + for lVox := 1 to lVoxPerPlank do begin + if (lVox mod lVoxPerPlankDiv10) = 0 then begin + MainForm.ProgressBar1.Position := (lVox div lVoxPerPlankDiv10)*10; + MainForm.Refresh; + Application.processmessages; + end; + lOrder := EmptyOrder; + lPlankImgPos := 0; + lnDeficits := 0; + for lPos := 1 to lImages.Count do begin + if (lPlankImg^[lPlankImgPos + lVox] > 0) then begin + inc(lnDeficits); + SetBit(lPos,lOrder); + end; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end; + if (lnDeficits >= lminDeficits) then begin //this is different from the last voxel: perhaps this is a new ordering + if (not SameOrder(lOrder,lPrevOrder,lImagesCount)) then + CheckOrder(lOrder); + inc(lnVoxels); + end; + lPrevOrder := lOrder; + end; + lStartVox := lEndVox + 1; + end; + MainForm.NPMmsg('n=,'+inttostr( lImagesCount)+',minN=,'+inttostr(lMinDeficits) +',unique overlap patterns,' +Inttostr(lUniqueOrders) +',voxels tested,' +Inttostr(lnVoxels)); +123: +//next: free dynamic memory + //freemem(lPlankImg); + freemem(lOverlapRA); + //MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + MainForm.ProgressBar1.Position := 0; + result := lUniqueOrders; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 0 then begin + freemem(lPlankImg); + freemem(lOverlapRA); + end; + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; *) + + +end. diff --git a/npm_precl/part.pas b/npm_precl/part.pas new file mode 100755 index 0000000..85ff180 --- /dev/null +++ b/npm_precl/part.pas @@ -0,0 +1,555 @@ +unit part; +//Physiological Artifact Removal Tool +{$H+} +interface +uses + define_types,dialogs,SysUtils; + +function ApplyPart( lFilename: string;lImgData: singleP; lBins,lVolVox,lSlices, lImgVol : integer; lTRsec: single): string; + +implementation +type + TPhysioT = RECORD + Triggers,InterpolatedTriggers: integer; + TriggerMedian,TriggerQ1,TriggerQ3: Double; + TriggerRA: singleP; + END; +function SaveTriggersAs3ColumnFSL(lPhysioIn: TPhysioT; lOutName: string): boolean; +var + lF: textfile; + lPos: integer; +begin + result := false; + if (lPhysioIn.Triggers < 1) then + exit; + assignfile(lF,lOutName+'.txt'); + Filemode := 0; + rewrite(lF); + for lPos := 1 to lPhysioIn.Triggers do + Writeln(lf,realtostr(lPhysioIn.TriggerRA^[lPos],3)+' 1 1'); + closefile(lF); + Filemode := 2; + result := true; +end; + +procedure qsort(lower, upper : integer; var Data:SingleP); +//40ms - fast but very recursive... +var + left, right : integer; + pivot,lswap: single; +begin + pivot:=Data^[(lower+upper) div 2]; + left:=lower; + right:=upper; + while left<=right do begin + while Data^[left] < pivot do left:=left+1; { Parting for left } + while Data^[right] > pivot do right:=right-1;{ Parting for right} + if left<=right then begin { Validate the change } + lswap := Data^[left]; + Data^[left] := Data^[right]; + Data^[right] := lswap; + left:=left+1; + right:=right-1; + end; //validate + end;//while left <=right + if right>lower then qsort(lower,right,Data); { Sort the LEFT part } + if upper>left then qsort(left ,upper,data); { Sort the RIGHT part } +end; + +procedure QuartileTriggerSpacing(var lPhysio: TPhysioT); +var + lTriggerDelayRA: singleP; + lPos: integer; +begin + lPhysio.TriggerQ1 := 0; + lPhysio.TriggerMedian := 0; + lPhysio.TriggerQ3 := 0; + if lPhysio.Triggers < 4 then + exit; + getmem(lTriggerDelayRA,(lPhysio.Triggers-1)*sizeof(single)); + for lPos := 1 to (lPhysio.Triggers-1) do + lTriggerDelayRA^[lPos] := abs(lPhysio.TriggerRA^[lPos]-lPhysio.TriggerRA^[lPos+1]); + qsort(1,lPhysio.Triggers-1,lTriggerDelayRA);//-1 : fence post vs wire + lPos := lPhysio.Triggers div 2; + lPhysio.TriggerMedian := lTriggerDelayRA^[lPos]; + lPos := lPhysio.Triggers div 4; + lPhysio.TriggerQ1 := lTriggerDelayRA^[lPos]; + lPos := round(0.75*lPhysio.Triggers ); + lPhysio.TriggerQ3 := lTriggerDelayRA^[lPos]; + freemem(lTriggerDelayRA); +end; + +function PARTool (var lPhysio: TPhysioT; lImgData: singleP; lTRsec: single; lnVolVox,lnSlices, lImgVol, lBinIn : integer): string; +const + kMinSamplesPerBin = 4; +var + lV,lSliceTime,lMeanSignal,lOnsetTime,lBinWidth,lBinMin,lBinMax,lTimeSinceTrigger,lPrevTriggerTime: double; + lSlice,lSlicePos,lnSliceVox,lnSlicePos,lVoxel,lBin,lSample,lnBin,lnBinDiv2,lNextTrigger,lSamplesWithVariance,lCorrectedSamples,lVolOffset: integer; + lBinCountRA,lVolBinRA: longintp; + lVariance : boolean; + lBinEstimateRA: doublep; +begin + result := ''; + if (lPhysio.Triggers < 4) or (lnVolVox < 4) or (lImgVol < 4) then begin + showmessage('PART requires at least 4 triggers and at least 4 volumes each with at least 4 voxels'); + exit; + end; + if (lBinIn < 4) then begin + showmessage('PART requires at least 4 data bins'); + exit; + end; + lnSliceVox := lnVolVox div lnSlices; + if (lnVolVox mod lnSlices) <> 0 then begin + showmessage('PART requires volvox to be evenly divisible by number of slices.'); + exit; + end; + lSamplesWithVariance := 0; + lCorrectedSamples := 0; + QuartileTriggerSpacing(lPhysio); + //find number bin range - this is median-1.5IQR..median+1.5IQR + lBinMin := -lPhysio.TriggerMedian/2-(abs(lPhysio.TriggerQ1-lPhysio.TriggerQ3)*0.75); + lBinMax := +lPhysio.TriggerMedian/2+abs(lPhysio.TriggerQ1-lPhysio.TriggerQ3)*0.75; + //next - create bins + lnBin := lBinIn; + //could adjust number of bins and return here wth a label + lBinWidth := abs((lBinMax-lBinMin)/(lnBin-1));//lnBin-1: fenceposts vs wire + lnBinDiv2 := (lnBin div 2)+1; + getmem(lBinCountRA,lnBin*sizeof(integer)); + getmem(lBinEstimateRA,lnBin*sizeof(double)); + getmem(lVolBinRA,lImgVol*sizeof(integer)); + lVoxel := 0; + for lSlice := 1 to lnSlices do begin + //adjust slices so slice 1 occurs at 0, slice 2 at 1/nslices... + lSliceTime := ((lSlice-1)/lnSlices)-1; //-1 as 1st volume starts at zero, not 1 + //do next step for each slice - different slices have different bin distributions due to different slicetime + //next count number of samples in each bin + for lBin := 1 to lnBin do + lBinCountRA^[lBin] := 0; + lPrevTriggerTime := -MaxInt; + lNextTrigger := 1; + for lSample := 1 to lImgVol do begin + //for each sample, find nearest trigger + lOnsetTime := lSample+lSliceTime; + if lOnsetTime > lPhysio.TriggerRA^[lNextTrigger] then begin + while (lNextTrigger <= lPhysio.Triggers ) and (lOnsetTime > lPhysio.TriggerRA^[lNextTrigger]) do begin + lPrevTriggerTime := lPhysio.TriggerRA^[lNextTrigger]; + inc(lNextTrigger); + end; //while + end;//if onset > + lTimeSinceTrigger := lOnsetTime-lPrevTriggerTime; + if lTimeSinceTrigger > abs(lPhysio.TriggerRA^[lNextTrigger]-lOnsetTime) then + lTimeSinceTrigger := -abs(lPhysio.TriggerRA^[lNextTrigger]-lOnsetTime);//use abs in case we are past final trigger + //now compute bin... + //inc(lCorrectedSamples); + if (lTimeSinceTrigger > lBinMin) and (lTimeSinceTrigger < lBinMax) then begin + lBin := round( (lTimeSinceTrigger)/ lBinWidth)+lnBinDiv2; + lVolBinRA^[lSample] := lBin; + if (lBin < 1) or (lBin > lnBin) then + fx(-661,lBin,lTimeSinceTrigger) + else + inc(lBinCountRA^[lBin]); + end else + lVolBinRA^[lSample] := 0; + end; //for each volume + for lSlicePos := 1 to lnSliceVox do begin + inc(lVoxel); + //first - only correct voxels with variability - do not waste time outside brain + lVolOffset := lVoxel; + lVariance := false; + lSample := 1; + lV := lImgData^[lVolOffset]; + while (not lVariance) and (lSample <= lImgVol) do begin + if lV <> lImgData^[lVolOffset] then + lVariance := true; + inc(lSample); + lVolOffset := lVolOffset+lnVolVox; + end; //while no variance + if lVariance then begin //voxel intensity varies accross time - attempt to remove artifact + lSamplesWithVariance := lSamplesWithVariance +lImgVol; + //1st - sum effects + for lBin := 1 to lnBin do + lBinEstimateRA^[lBin] := 0; + lMeanSignal := 0; + lVolOffset := lVoxel; + for lSample := 1 to lImgVol do begin + lMeanSignal := lImgData^[lVolOffset] + lMeanSignal; + lBin := lVolBinRA^[lSample]; + if (lBin > 0) and (lBinCountRA^[lBin] > kMinSamplesPerBin) then + lBinEstimateRA^[lBin] := lBinEstimateRA^[lBin]+ lImgData^[lVolOffset]; + lVolOffset := lVolOffset+lnVolVox; + end; //for each volume + lMeanSignal := lMeanSignal /lImgVol; + //next compute correction... average signal in bin - average voxel intensity irrelevant of bin + for lBin := 1 to lnBin do + if lBinCountRA^[lBin] > kMinSamplesPerBin then + lBinEstimateRA^[lBin] := (lBinEstimateRA^[lBin]/lBinCountRA^[lBin])-lMeanSignal; + //lBinEstimateRA[lBin] := lBinEstimateRA[lBin]-lBinMeanCount; + //next apply correction - inner loop complete for each voxel! + lVolOffset := lVoxel; + for lSample := 1 to lImgVol do begin + //for each sample, find nearest trigger + lBin := lVolBinRA^[lSample]; + if (lBin > 0) and (lBinCountRA^[lBin] > kMinSamplesPerBin) then begin + lImgData^[lVolOffset] := (lImgData^[lVolOffset]-lBinEstimateRA^[lBin]); + inc(lCorrectedSamples) + end; + lVolOffset := lVolOffset+lnVolVox; + end; //for each volume + end; //if variance + end;//for each voxel in slice + end; //for slice + //**INNER LOOP end - + //next - report results + result :=' Time per vol (TR) [sec] '+realtostr(lTRsec,4)+kCR; + result :=result +' fMRI Volumes '+inttostr(lImgVol)+kCR; + result :=result +' Triggers n/First...Last [vol] '+realtostr(lPhysio.Triggers,0)+'/'+realtostr(lPhysio.TriggerRA^[1],2)+'...'+realtostr(lPhysio.TriggerRA^[lPhysio.Triggers],2)+kCR; + if abs(lImgVol-lPhysio.TriggerRA^[lPhysio.Triggers]) > 10 then begin + result :=result +'******* WARNING: Duration of fMRI session and duration of triggers is very different *******'; + result :=result +'******* Please ensure specified TR is correct, files are correct and onset of fMRI was synchronized with physio data *******'; + end; + result := result + ' Q1/Median/Q2 [sec] '+realtostr(lTRsec*lPhysio.TriggerQ1,2)+'/'+realtostr(lTRsec*lPhysio.TriggerMedian,2)+'/'+realtostr(lTRsec*lPhysio.TriggerQ3,2)+kCR; + result := result + ' Bin n/Range [sec] '+inttostr(lnBin)+'/'+realtostr(lTRsec*lBinMin,2)+ '...'+realtostr(lTRsec*lBinMax,2)+kCR; + result := result+ ' voxels without variance (outside brain) %: '+realtostr(100*( (lnVolVox-(lSamplesWithVariance/lImgVol))/lnVolVox),2)+kCR; + if lSamplesWithVariance > 0 then + result := result+ ' voxels with variance which were corrected %: '+realtostr(100*(lCorrectedSamples/lSamplesWithVariance),2)+kCR; + for lBin := 1 to lnBin do + result := result+(' Bin '+inttostr(lBin)+ ' '+realtostr(lBin*lBinWidth+lBinMin ,2) +' '+inttostr(lBinCountRA^[lBin]) )+kCR; + freemem(lBinCountRA); + freemem(lBinEstimateRA); + freemem(lVolBinRA); +end; + + +function StrVal (var lNumStr: string): integer; +begin + try + result := strtoint(lNumStr); + except + on EConvertError do begin + showmessage('StrVal Error - Unable to convert the string '+lNumStr+' to a number'); + result := MaxInt; + end; + end; +end; + +procedure AddSample(var lNumStr: string; var lnTotal,lnSample, lnTrigger: integer; var lPhysio: TPhysioT); +var + lVal: integer; +begin + lVal := StrVal(lNumStr); + if lVal = 5003 then + exit; + lNumStr := ''; + inc(lnTotal); + if lnTotal < 5 then exit; + if lVal > 4096 then begin + if lVal <> 5000 then begin + showmessage('Potentially serious error: unknown trigger type : '+inttostr(lVal)); + end; + inc(lnTrigger); + if (lPhysio.Triggers <> 0) then + lPhysio.TriggerRA^[lnTrigger] := lnSample; + end else begin + inc(lnSample); + end; +end; + +function AdjustStartPos (var lStr: string; var lStartPos: integer): boolean; +//Some Siemens physio files appear to have nonsense characters befor real data<bh:ef><bh:bb><bh:bf>1 +var + lLen: integer; +begin + lLen := length(lStr); + result := false; + if (lLen-lStartPos)<2 then + exit; + result := true; + repeat + if lStr[lStartPos] in [ '0'..'9'] then + exit; + inc(lStartPos); + until (lStartPos = lLen); + result := false; +end; + +procedure CountValidItems(var lStr: string; var lStartPos,lnSample, lnTrigger: integer; var lPhysio: TPhysioT); +label + 123; +var + lPos,lnTotal: integer; + lNumStr: string; +begin + lnTotal:= 0; + lnSample := 0; + lnTrigger := 0; + lNumStr := ''; + if length(lStr)<2 then exit; + if not AdjustStartPos ( lStr, lStartPos) then exit; //Oct 2009 + for lPos := lStartPos to length(lStr) do begin + if (lStr[lPos] = ' ') and (lNumStr <> '') then begin + if lNumStr = '5003' then begin + lNumStr := ''; + goto 123; //end of recording + end else + AddSample(lNumStr, lnTotal,lnSample, lnTrigger, lPhysio); + end else begin + if lStr[lPos] in [ '0'..'9'] then + lNumStr := lNumStr + lStr[lPos] + else if lStr[lPos] in [' '] then + + else begin + //Showmessage(lStr[lPos]); + goto 123; + end; + end; + end; //for length +123: + if (lNumStr <> '') then + AddSample(lNumStr, lnTotal,lnSample, lnTrigger, lPhysio); + lStartPos := lPos; + while (lStartPos < length(lStr)) and ( lStr[lStartPos] <> ' ') do begin + inc(lStartPos); + end; +end; + +procedure CreatePhysio (var lPhysio: TPhysioT); +begin + lPhysio.Triggers := 0; + +end; + +procedure ClosePhysio (var lPhysio: TPhysioT); +begin + with lPhysio do begin + if Triggers > 0 then + freemem(TriggerRA); + Triggers := 0; + end; +end; + +procedure InitPhysio(lnTrigger: integer; var lPhysio: TPhysioT); +begin + ClosePhysio (lPhysio); + with lPhysio do begin + Triggers := lnTrigger; + InterpolatedTriggers := 0; + if Triggers > 0 then + getmem(TriggerRA,Triggers*sizeof(single)); + end; +end; + +function load3ColTxtPhysio (lFilename: string; var lPhysio: TPhysioT): boolean; +var + F: TextFile; + lnTrigger: integer; + lFloat,lFloat2,lFloat3: single; +begin + result := false; + if not fileexists(lFilename) then exit; + ClosePhysio(lPhysio); + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //pass 1 - count number of triggers + lnTrigger := 0; + Reset(F); + while not EOF(F) do begin + {$I-} + read(F,lFloat,lFloat2,lFloat3); //read triplets instead of readln: this should load UNIX files + {$I+} + if (ioresult = 0) and (lFloat > 0) then + inc(lnTrigger); + end; + //pass 2 - load array + InitPhysio(lnTrigger, lPhysio); + lnTrigger := 0; + Reset(F); + while not EOF(F) do begin + {$I-} + read(F,lFloat,lFloat2,lFloat3); //read triplets instead of readln: this should load UNIX files + {$I+} + if (ioresult = 0) and (lFloat > 0) then begin + inc(lnTrigger); + lPhysio.TriggerRA^[lnTrigger] := lFloat; + end; + end; + FileMode := 2; //Set file access to read/write + CloseFile(F); + result := true; +end; + +procedure ReadlnX (var F: TextFile; var lResult: string); +var + lCh: char; +begin + lResult := ''; + while not Eof(F) do begin + Read(F, lCh); + if (lCh in [#10,#13]) then begin + if lResult <> '' then begin + //Showmessage(lResult); + exit; + end; + end else + lResult := lResult + lCh; + end; +end; //ReadlnX + + +function loadSiemensPhysio (lFilename: string; var lPhysio: TPhysioT): boolean; +var + F: TextFile; + lStr: string; + lPos,lnSample,lnTrigger: integer; +begin + result := false; + if not fileexists(lFilename) then exit; + ClosePhysio(lPhysio); + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + Reset(F); + ReadlnX(F,lStr);//ColNames + if length(lStr) < 1 then begin + CloseFile(F); + exit; + end; + //first pass - count items + lPos := 1; + CountValidItems(lStr,lPos,lnSample,lnTrigger,lPhysio); + //second pass - load array + if (lnSample < 1) and (lnTrigger < 1) then begin + CloseFile(F); + exit; + end; + //2nd pass... + InitPhysio(lnTrigger, lPhysio); + lPos := 1; + CountValidItems(lStr,lPos,lnSample,lnTrigger,lPhysio); + FileMode := 2; //Set file access to read/write + CloseFile(F); + result := true; +end; + +function InterpolateGaps (var lPhysioIn: TPhysioT): boolean; +//attempts to fill missing trigger pulses +//you must call QuartileTriggerSpacing before this function! +// it assumes q1/median/q3 are filled +var + lGap,l2Min,l2Max,l3Min,l3Max: double; + lnReplace,lTrigger,lTrigger2: integer; + lTempPhysio: TPhysioT; +begin + result := false; + if (lPhysioIn.Triggers < 4) then begin + showmessage('InterpolateGaps requires at least 4 triggers.'); + exit; + end; + l2Min := 2*lPhysioIn.TriggerMedian-(abs(lPhysioIn.TriggerQ1-lPhysioIn.TriggerQ3)*1.5); + l2Max := 2*lPhysioIn.TriggerMedian+(abs(lPhysioIn.TriggerQ1-lPhysioIn.TriggerQ3)*1.5); + + l3Min := 3*lPhysioIn.TriggerMedian-(abs(lPhysioIn.TriggerQ1-lPhysioIn.TriggerQ3)*1.5); + l3Max := 3*lPhysioIn.TriggerMedian+(abs(lPhysioIn.TriggerQ1-lPhysioIn.TriggerQ3)*1.5); + if l2Max > l3Min then + exit; //variability too high to determine gaps + lnReplace := 0; + for lTrigger := 2 to lPhysioIn.Triggers do begin + lGap := lPhysioIn.TriggerRA^[lTrigger] - lPhysioIn.TriggerRA^[lTrigger-1]; + if (lGap > l2Min) and (lGap < l2Max) then + inc(lnReplace); + if (lGap > l3Min) and (lGap < l3Max) then + inc(lnReplace,2); + end; + if lnReplace = 0 then begin + result := true; + exit; + end; + //create temp backup + CreatePhysio(lTempPhysio); + InitPhysio(lPhysioIn.Triggers, lTempPhysio); + for lTrigger := 1 to lPhysioIn.Triggers do + lTempPhysio.TriggerRA[lTrigger] := lPhysioIn.TriggerRA[lTrigger]; + //create resized array + InitPhysio(lTempPhysio.Triggers+lnReplace, lPhysioIn); + //fill gaps + lPhysioIn.TriggerRA[1] := lTempPhysio.TriggerRA[1]; + lTrigger2 := 1; + for lTrigger := 2 to lTempPhysio.Triggers do begin + inc(lTrigger2); + lGap := lTempPhysio.TriggerRA^[lTrigger] - lTempPhysio.TriggerRA^[lTrigger-1]; + if ((lGap > l2Min) and (lGap < l2Max)) then begin //1 beat + lPhysioIn.TriggerRA^[lTrigger2] := lTempPhysio.TriggerRA^[lTrigger-1]+(lgap / 2); + inc(lTrigger2); + end; + if ((lGap > l3Min) and (lGap < l3Max)) then begin //2 beats + lPhysioIn.TriggerRA^[lTrigger2] := lTempPhysio.TriggerRA^[lTrigger-1]+(lgap / 3); + inc(lTrigger2); + lPhysioIn.TriggerRA^[lTrigger2] := lTempPhysio.TriggerRA^[lTrigger-1]+(2*lgap / 3); + inc(lTrigger2); + end; + lPhysioIn.TriggerRA^[lTrigger2] := lTempPhysio.TriggerRA^[lTrigger]; + end; + ClosePhysio (lTempPhysio); + lPhysioIn.InterpolatedTriggers := lnReplace; + result := true; +end; + +function ScalePhysioToTime(lPhysio: TPhysioT; lSamplesPerUnit: single): boolean; +var + lScale: single; + lTrigger: integer; +begin + result := false; + if (lPhysio.Triggers < 4) then begin + showmessage('ScalePhysioToTR requires at least 4 triggers.'); + exit; + end; + if (lSamplesPerUnit <= 0) then begin + showmessage('ScalePhysioToTime requires TR(sec) and samples/sec >0.'); + exit; + end; + lScale := 1/(lSamplesPerUnit); //use reciprocal: mults faster than divides + for lTrigger := 1 to lPhysio.Triggers do + lPhysio.TriggerRA^[lTrigger] := lPhysio.TriggerRA^[lTrigger] * lScale; + result := true; +end; + +procedure EnsureAscending(lPhysio: TPhysioT); +//check if order is correct - if not the sort... +//an alternative is to always sort, but this method is faster and less resource intensive for sorted data +var + lPos: integer; +begin + if lPhysio.Triggers < 2 then exit; + for lPos := 2 to lPhysio.Triggers do begin + if lPhysio.TriggerRA^[lPos] < lPhysio.TriggerRA^[lPos-1] then begin + showmessage('Warning: input times are not in ascending order - data will be sorted.'); + qsort(1,lPhysio.Triggers,lPhysio.TriggerRA); //ensure trigger timings are in order... + exit; + end; + end; +end; + +function ApplyPart( lFilename: string;lImgData: singleP; lBins,lVolVox,lSlices, lImgVol : integer; lTRsec: single): string; +var + lPhysio: TPhysioT; +begin + result := ''; + if not fileexists (lFilename) then exit; + CreatePhysio(lPhysio); + if UpCaseExt(lFilename) = '.TXT' then begin + if not load3ColTxtPhysio(lFilename,lPhysio) then exit; + end else + if not loadSiemensPhysio(lFilename,lPhysio) then exit; + EnsureAscending(lPhysio); + QuartileTriggerSpacing(lPhysio); + if not InterpolateGaps (lPhysio) then + exit; + if UpCaseExt(lFilename) <> '.TXT' then begin//export Siemens file as 3-column text + ScalePhysioToTime(lPhysio,50); //50: siemens files use 50 Hz sampling -> convert to sec + SaveTriggersAs3ColumnFSL(lPhysio,lFilename); //do this before TR conversion... + end; + ScalePhysioToTime(lPhysio,lTRsec); //Convert sec to volumes + result := PARTool (lPhysio,lImgData,lTRsec,lVolVox,lSlices, lImgVol, lBins); + ClosePhysio(lPhysio); +end; + +end. diff --git a/npm_precl/prefs.pas b/npm_precl/prefs.pas new file mode 100755 index 0000000..60e5e17 --- /dev/null +++ b/npm_precl/prefs.pas @@ -0,0 +1,254 @@ +unit prefs; + +{$H+} +interface +uses + inifiles, define_types,SysUtils,classes,turbolesion; + +function DoLesion (var lPrefs: TLDMPrefs): boolean; +procedure SetDefaultPrefs (var lPrefs: TLDMPrefs); +procedure ReadParamStr; + +implementation + +uses nifti_img, hdr,nifti_hdr, valformat,StatThdsUtil,filename,npmform; + +procedure MsgX(lStr: string); +begin + MainForm.NPMmsg(lStr); +end; + +procedure ClearMsgX; +begin + MainForm.NPMmsgClear +end; + +procedure SetDefaultPrefs (var lPrefs: TLDMPrefs); +begin + //lPrefs.unusedbool := true; + lPrefs.tTest := true; + lPrefs.BMtest := false; + lPrefs.Ltest := false; + lPrefs.nPermute := 0; + lPrefs.CritPct := -1;//use default in val file + lPrefs.ExplicitMaskName := ''; + lPrefs.ValFilename := ''; + lPrefs.Outname := ''; +end; + +(*function CheckBool (lPref, lFlag: integer): boolean; +//check if Flag is in lPref. For example, if Flag is 1 then returns true for all odd lPrefs +begin + result := (lPref and lFlag) = lFlag; +end; *) + +function noVariance (lRA: singlep; lnSubj: integer): boolean; +var + lI : integer; +begin + result := false; + if lnSubj < 2 then exit; + for lI := 2 to lnSubj do + if lRA^[1] <> lRA^[lI] then + exit; + result := true; +end; + +function DoLesion (var lPrefs: TLDMPrefs): boolean; + label + 666; +var + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCritV,lCritPctV: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + if (not lPrefs.BMtest) and (not lPrefs.ttest) and (not lPrefs.LTest) then begin + MsgX('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + if not GetValCore(lPrefs.ValFilename, lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCritV,lCritPctV,lPredictorList) then begin + MsgX('Error with VAL file'); + goto 666; + end; + if lPrefs.critPct < 0 then //-1 denotes using the values specified in the VAL file + lPrefs.critPct := lCritPctV; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + MsgX('Not enough subjects ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + MsgX('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + MsgX('Mask file size too small.'); + goto 666; + end; + if (lPrefs.OutName = '') or (not DirExists(extractfiledir(lPrefs.Outname))) then begin + lPrefs.Outname := extractfiledir(lPrefs.ValFilename)+pathdelim+'results.nii.gz'; + MsgX('Output stored as '+lPrefs.Outname); + end; + for lFact := 1 to lnFactors do begin + ClearMsgX; + MsgX(MainForm.GetKVers); + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + if (not lPrefs.LTest) or (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 0) OR (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 1) THEN begin + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + end else begin + MsgX('Data rejected: behavior must be zero or one for binomial test '+lImageNamesAll.Strings[lSubj-1]); + end; + lnSubj := lImageNames.Count; + if lnSubj > 2 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do begin + if (not lPrefs.LTest) or (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 0) OR (lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] = 1) THEN begin + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; //valid value + end; //not binomial, or 1/0 + end; //for each subject + MsgX('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MsgX('Factor = '+lFactname); + For lSubj := 1 to lnSubj do + MsgX (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + MsgX('Total voxels = '+inttostr(lMaskVoxels)); + lPrefs.nCrit := round( (lnSubj*lPrefs.CritPct)/100); + MsgX('Only testing voxels damaged in at least '+inttostr(lPrefs.nCrit)+' individual[s]'); + MsgX('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroupX(lImageNames,lMaskHdr {lMaskVoxels}) then begin + MsgX('Error: File dimensions differ from mask.'); + goto 666; + end; + if noVariance (lSymptomRA,lnSubj) then + MsgX('Error no variability in behavioral data ') + else + TurboLDM (lImageNames, lMaskHdr, lPrefs, lSymptomRA, lFactname,lPrefs.OutName); + Freemem(lSymptomRA); + end else begin + MsgX('At least 2 individuals required to compute statistics for '+lPredictorList.Strings[lFact-1]); + end; //lnsubj > 2 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); +end; + +procedure ShowHelp; +begin + MsgX('usage ''npm [options] -o resultsfilname valfilename'' '); + MsgX(' Options '); + MsgX(' -c: critical percent 0..100 '); + MsgX(' -p: permutations 0..4000 '); + MsgX(' -t: Test [1=Liebermeister, 2=TTest, 4=BMtest, 6=t&BMtests'); + MsgX(' -o: Output filename'); + MsgX('examples:'); + MsgX(' npm -c 25 -p 1000 -o c:\results.nii.gz c:\mri\data.val'); + MsgX(' npm -c 25 -o "c:\program files\results.hdr" c:\mri\data.val'); +end; + +procedure ReadParamStr; +var + lStr: String; + I,lError: integer; + lCommandChar: Char; + lSingle: single; + lHelpShown: boolean; + lPrefs: TLDMPrefs; +begin + if (ParamCount < 1) then exit; + SetDefaultPrefs(lPrefs); + lHelpShown := false; + lStr := paramstr(0); + lStr := extractfilename(lStr); + lStr := string(StrUpper(PChar(lStr))) ; + if (ParamCount > 0) then begin + I := 0; + repeat + lStr := ''; + repeat + inc(I); + if I = 1 then + lStr := ParamStr(I) + else begin + if lStr <> '' then + lStr := lStr +' '+ ParamStr(I) + else + lStr := ParamStr(I); + end; + if (length(lStr)>1) and (lStr[1] = '-') and (ParamCount > I) then begin //special command + //-z= zoom, -f= format [png,jpeg,bmp], -o= output directory + lCommandChar := UpCase(lStr[2]); + inc(I); + lStr := ParamStr(I); + lStr := string(StrUpper(PChar(lStr))) ; + case lCommandChar of + 'C','P','T': begin //CritPct + Val(lStr,lSingle,lError); + if lError = 0 then begin + if lCommandChar = 'C' then + lPrefs.CritPct := round(lSingle) + else if lCOmmandChar = 'P' then + lPrefs.nPermute := round(lSingle) + else if lCOmmandChar = 'T' then begin + case round(lSingle) of + 1: begin lPrefs.LTest := true; lPrefs.Ttest := false; lPrefs.BMtest := false; end; + 2: begin lPrefs.LTest := false; lPrefs.Ttest := true; lPrefs.BMtest := false; end; + 4: begin lPrefs.LTest := false; lPrefs.Ttest := false; lPrefs.BMtest := true; end; + 6: begin lPrefs.LTest := false; lPrefs.Ttest := true; lPrefs.BMtest := true; end; + //1=Liebermeister, 2=TTest, 4=BMtest, 6=t&BMtests + end;//xxx + end; + end; //not lError + end; //C= CritPct,P=permutations,T=test + 'O': begin //output filename + lPrefs.OutName :=lStr; + end; + + end; //case lStr[2] + lStr := ''; + end; //special command + until (I=ParamCount) or (fileexists(lStr)) {or (gAbort)}; + if fileexists(lStr) then begin + //lStr := GetLongFileName(lStr); + lPrefs.ValFilename := lStr; + //if lPrefs.OutName = '' then + // lPrefs.Outname := extractfiledir(paramstr(0))+pathdelim+'results.nii.gz'; + MsgX ('output ' + lPrefs.Outname); + MsgX ('val file: '+lPrefs.ValFilename); + + DoLesion(lPrefs); + MainForm.close; + end else begin + MsgX('Error: unable to find '+lStr); + if not lHelpShown then + Showhelp; + lHelpShown := true; + end; + until I >= ParamCount; + end else begin + ShowHelp; + end;{param count > 0} +end; + +end. + \ No newline at end of file diff --git a/npm_precl/regression.pas b/npm_precl/regression.pas new file mode 100755 index 0000000..4fcc6b3 --- /dev/null +++ b/npm_precl/regression.pas @@ -0,0 +1,822 @@ +unit regression; +//only for Delphi - not Freepascal +//Unit for running multiple regression +interface +uses +{$H+} +{$IFNDEF UNIX} Windows, {$ENDIF} +{$IFDEF FPC} utypes,regmult,{$ELSE} +utypes,regmult, +{$ENDIF}define_types,Classes,nifti_hdr,sysutils,nifti_img, + StatThdsUtil,Forms,Distr,Dialogs,npmform, tfce_clustering; + +function GetValReg (var lnSubj,lnFactors: integer; var X : PMatrix; var lImageNames: TStrings; var lPredictorList: TStringList): boolean; +function ARegressNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var X: PMatrix; lnFactors: integer; var lPredictorList: TStringList; lOutname: string; lnPermute, TFCEconn: integer): boolean; +function Regress2NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lOutname: string; var lXadditional: PMatrix; lnAdditionalFactors: integer ): boolean; +function TtoR(t,df: double): double; + + +implementation +uses valformat,hdr,math; + +(*function readCSV (lFilename: string; var lnObservations,lnFactors : integer; var X : PMatrix; var Y: PVector): boolean; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lPos,MaxC,R,C:integer; + lError: boolean; + +begin + result := false; + if not fileexists(lFilename) then exit; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R < 2) or (MaxC < 5) then begin + showmessage('problems reading CSV'); + exit; + end; + lnObservations := MaxC; + lnFactors := R -1; + DimVector(Y, lnObservations); + DimMatrix(X, lnFactors, lnObservations); + //second pass + Reset(F); + C := 0; + MaxC := 0; + R := 1; + lNumStr := ''; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading VAL file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end; + if R = 1 then + Y^[C+1] := lTempFloat + else + X^[R-1]^[C+1] := lTempFloat; + //xxx := lTempFloat;//DataGrid.Cells[ C, kMaxFactors+R-1 ] := (lNumStr) ; + end; + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; + +function TestMultReg: boolean; +var +i,lnFactors, lnObservations: integer; +X : PMatrix; +Y: PVector; +lOutT,lOutSlope: DoubleP0; +lStart: dword; +begin + if not readCSV('C:\xio.csv',lnObservations,lnFactors,X,Y ) then exit; + //showmessage('alpha'); + getmem(lOutT, (lnFactors+1)* sizeof(double)); + getmem(lOutSlope, (lnFactors+1)* sizeof(double)); + + lStart := gettickcount; + for i := 1 to 10000 do + MultipleRegressionVec (lnObservations,lnFactors, X, Y, lOutT,lOutSlope); + fx(gettickcount-lstart); + + + if MultipleRegressionVec (lnObservations,lnFactors, X, Y, lOutT,lOutSlope) then begin + for i := 0 to lnFactors do + fx(lOutT^[i],lOutSlope^[i]); + + end; + freemem(lOutT); + freemem(lOutSlope); + DelMatrix(X, lnFactors, lnObservations); + DelVector(Y, lnObservations); +end; *) + +(*procedure rx(lnObs,lnFactors: integer; X: PMatrix; lObs: Doublep0); +var + n,f: integer; + str: string; +begin + for n := 1 to lnObs do begin + str := floattostr(lObs^[n-1]); + for f := 1 to lnFactors do + str := str+','+floattostr(X^[f]^[n]); + + MainForm.NPMmsg(str); + end;//each obs + str := '----------'; +end;//proc RX*) + +function Sign(value: double): double; +begin + if value > 0 then + result := 1 + else if value < 0 then + result := -1 + else + result := 0; +end; + +function TtoR(t,df: double): double; +CONST + eps=3.0e-7; +begin + result := 0; + if (t = 0) or (df = 0) then + exit; + result := sign(t)/ sqrt( (df/(t*t+eps)) +1 ); +end; + +{$DEFINE SaveT} //if SaveT then t-score map will be saved +{$DEFINE SaveRnotZ} //if SaveRnotZ then r-value map will be saved, but not Z-score map +function Regress2NPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lOutname: string; var lXadditional: PMatrix; lnAdditionalFactors: integer ): boolean; +//lImages is list 1..N of 1st images followed by 1..N of corresponding control images +//example c1.img, c2.img,c3.img,e1.img,e2.img,e3.img +//lImages.Count must be even +label + 667; +const + kMaxFact = 80; +var + lOutNameMod,lFactName,lRunName: string; + lMaskImg,lPlankImg,lOutImgMn: SingleP; + lOutImgR: array [1..kMaxFact] of SingleP; + lTotalMemory: int64; + lnFactors,lnObservations,lnObservationsDiv2,lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + lDF,lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct,lFact,lnStatFact: integer; + l1st, lSum, lMn: double; + lVar: boolean; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lnPermute: integer; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lZP: Pointer; + lZra : DoubleP0; + X : PMatrix; +begin + lnFactors := 1+lnAdditionalFactors; + lnPermute := MainForm.ReadPermute; + if odd(lImages.Count) then begin + showmessage('Regress2NPMAnalyze must be passed an even number of images: the first half of the list is the experimental images, followed by corresponding control images.'); + exit; + end; + lnObservations := lImages.Count; + lnObservationsDiv2 := lImages.Count div 2; + lDF := lnObservationsDiv2-lnFactors-1; + if lDF < 1 then begin + showmessage('Regress2NPMAnalyze: DF must be >0 (DF=[Num-Factors-1]) Num='+inttostr(lnObservationsDiv2)+' Factors='+inttostr(lnFactors) ); + exit; + end; + DimMatrix(X, lnFactors, lnObservationsDiv2); + //fx(lnAdditionalFactors); + + if lnAdditionalFactors > 0 then begin + for lPos2 := 1 to lnAdditionalFactors do begin + for lPos := 1 to lnObservationsDiv2 do begin + X^[lPos2+1]^[lPos] := lXadditional^[lPos2]^[lPos]; + //fx(lPos2+1,lPos, X^[lPos2+1]^[lPos]); + end; + end; //pos 2 + end; //additional factros + //Memo1.Lines.Add('Permutations = ' +IntToStr(lnPermute)); + MainForm.Memo1.Lines.Add('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lnStatFact := lnFactors + 1; //factors + overall model + if lnStatFact > (kMaxFact-1) then begin //-1 because factors + model + MainForm.Memo1.Lines.Add('ERROR: Can not analyze more than = ' +inttostr(kMaxFact-1)+' factors'); + goto 667; + end; + //load mask + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(gOffsetRA[0]),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + MainForm.Memo1.Lines.Add('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + //next find start and end of mask + lPos := 0; + repeat + inc(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = lVolVox); + lMinMask := lPos; + lPos := lVolVox+1; + repeat + dec(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = 1); + lMaxMask := lPos; + if lMaxMask = 1 then begin + MainForm.Memo1.Lines.Add('Mask appears empty' +lMaskHdr.ImgFileName); + goto 667; + end; + MainForm.Memo1.Lines.Add('Mask has voxels from '+inttostr(lMinMask)+'..'+inttostr(lMaxMask)); + lVoxPerPlank := kPlankSz div lnObservations div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lnObservations; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lnObservations) ) + 1; + MainForm.Memo1.Lines.Add('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lnObservations))); + MainForm.Memo1.Lines.Add('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory*sizeof(single)) //assumes 4bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + lnVoxTested := 0; + for lPos := 1 to lnObservations do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + createArray64(lObsp,lObs,lnObservations); + getmem(lOutImgMn,lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImgMn^[lPos] := 0; + for lFact := 1 to (lnStatFact) do begin //+1 as we include full model + getmem(lOutImgR[lFact],lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := 0; + + end; + createArray64(lZp,lZra,lnFactors+1); //+1 as we include full model + //InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxTW, lPermuteMinTW,lPermuteMaxWMW, lPermuteMinWMW, lRanOrderp, lRanOrder); + for lPlank := 1 to lnPlanks do begin + MainForm.Memo1.Lines.Add('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lnObservations do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lPosPct := lVoxPerPlank div 100; + for lPos2 := 1 to lVoxPerPlank do begin + if (lPos2 mod lPosPct) = 0 then begin + MainForm.ProgressBar1.Position := round((lPos2/lVoxPerPlank)*100); + Application.Processmessages; + end; + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(lnVoxTested); + lSum := 0; + //check for variance + lVar := false; + lPos := 1; + l1st := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + for lPos := 1 to lnObservations do + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + for lPos := 1 to lnObservationsDiv2 do begin + lSum := lSum + lObs^[lPos-1]; + if (not lVar) and (lObs^[lPos-1]<>l1st) then + lVar := true; + //lSumOfSqrs := lSumOfSqrs + sqr(lObs[lPos-1]); + X^[1]^[lPos] := lObs^[lnObservationsDiv2+lPos-1]; + end; + lOutImgMn^[lPos2Offset] := lSum/lnObservationsDiv2; + if lVar then begin + MultipleRegression (lnObservationsDiv2,lnFactors, X, lObs, lZra); + //if lPos2Offset = 359948 then rx(lnObservationsDiv2,lnFactors,X,lObs); + for lFact := 1 to lnStatFact do + lOutImgR[lFact]^[lPos2Offset] := lZra^[lFact-1]; + end; + //StatPermute (lttest,lwelch,lWMW,lImages.Count, lnGroup1,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxTW, lPermuteMinTW,lPermuteMaxWMW, lPermuteMinWMW, lObs,lRanOrder); + end; //in brain mask - compute + end; + lStartVox := lEndVox + 1; + end; + //next report findings + MainForm.Memo1.Lines.Add('Voxels tested = ' +Inttostr(lnVoxTested)); + MainForm.reportBonferroni('Std',lnVoxTested); + //next: save data + if lnFactors = 1 then + lRunName := 'reg' + else + lRunName := ''; +//savedata + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save mean + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mn'+lRunName,'.hdr'); + if not FileExistsEX(lOutNameMod) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); +//save regression + for lFact := 1 to (lnStatFact) do begin + if (lFact > lnFactors) and (lnFactors = 1) then + lFactName := 'intercept'+'reg' //for analysis of multiple single regressions + else if (lFact > lnFactors) then + lFactName := 'intercept' + else + lFactName := 'reg'+inttostr(lFact); + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + {$IFDEF SaveT} //if SaveTRnotZ then t-score and r-score maps will be created, but no Z-score maps + //the next bit is optional - save data as T-values instead of Z-scores + // this allows direct comparison with SPM... + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_TTEST,inttostr(lnVoxTested) ); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'wlsT'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + {$ENDIF} + {$IFDEF SaveRnotZ} + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_CORREL,inttostr(lnVoxTested) ); + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := TtoR (lOutImgR[lFact]^[lPos],lDF); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'wlsR'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + {$ELSE} + //next - save Zscores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + //{ DoF = Nb points - Nb parameters } + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := TtoZ (lOutImgR[lFact]^[lPos],lDF); + MainForm.reportFDR ('wls'+lFactName, lVolVox, lnVoxTested, lOutImgR[lFact]); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'wls'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + {$ENDIF} + freemem(lOutImgR[lFact]); + end; + //next: close images + Freemem(lZp); + freemem(lOutImgMn); + freemem(lObsp); + freemem(lMaskImg); + freemem(lPlankImg); + MainForm.Memo1.Lines.Add('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lRunName,'.txt'); + MainForm.Memo1.Lines.SaveToFile(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + DelMatrix(X, lnFactors, lnObservationsDiv2); + exit; +667: //you only get here if you aborted ... free memory and report error + DelMatrix(X, 1, lnObservationsDiv2); + if lVolVox > 1 then freemem(lMaskImg); + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.Memo1.Lines.Add('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; + + + +{$DEFINE NoThread} +function InnerARegressNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var X: PMatrix; lnFactors: integer; var lPredictorList: TStringList; lOutname: string; lSaveData: boolean; var lMinZ,lMaxZ: double; var lMaxNegTFCEZ, lMaxTFCEZ:single; TFCEconn: integer): boolean; +//TFCEmode 0 = no TFCE, 1 = only report min/maxTFCE, 2 = save TFCE map to disk +{$IFNDEF Thread} +const + kMaxFact = 80; +{$ENDIF} +label + 667; +var + lOutNameMod,lFactName,lRunName: string; + lMaskImg,lPlankImg,lOutImgMn: SingleP; + {$IFDEF Thread} + lOutImgR: TRegRA; + {$ELSE} + lOutImgR: array [1..kMaxFact] of SingleP; + {$ENDIF} + lTotalMemory: int64; + lnObservations,lPlank,lVolVox,lPos,lMinMask,lMaxMask,lnPlanks,lVoxPerPlank, + //lPos2,lPos2Offset, + lDF,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lFact,lnStatFact: integer; + //l1st, lSum, lMn: double; + //lVar: boolean; + //lObsp: pointer;lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + {$IFDEF Thread} + lThread,lThreadStart,lThreadEnd,lThreadInc: integer; + {$ELSE} + lObsP,lZP: Pointer; + lObs,lZra : DoubleP0; + lSum,l1st: double; + lVar: boolean; + lPos2,lPosPct,lPos2Offset: integer; + + {$ENDIF} +begin + + + lnObservations := lImages.Count; + lDF := lnObservations-lnFactors-1; + if lDF < 1 then begin + showmessage('Regress2NPMAnalyze: DF must be >0 (DF=[Num-Factors-1]) Num='+inttostr(lnObservations)+' Factors='+inttostr(lnFactors) ); + exit; + end; + if (lSaveData) then MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lnStatFact := lnFactors + 1; //factors + overall model + if lnStatFact > (kMaxFact-1) then begin //-1 because factors + model + MainForm.NPMmsg('ERROR: Can not analyze more than = ' +inttostr(kMaxFact-1)+' factors'); + goto 667; + end; + //load mask + getmem(lMaskImg,lVolVox*sizeof(single)); + if not LoadImg(lMaskHdr.ImgFileName, lMaskImg, 1, lVolVox,round(gOffsetRA[0]),1,lMaskHdr.NIFTIhdr.datatype,lVolVox) then begin + MainForm.NPMmsg('Unable to load mask ' +lMaskHdr.ImgFileName); + goto 667; + end; + + //next find start and end of mask + lPos := 0; + repeat + inc(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = lVolVox); + lMinMask := lPos; + lPos := lVolVox+1; + repeat + dec(lPos); + until (lMaskImg^[lPos] > 0) or (lPos = 1); + lMaxMask := lPos; + if lMaxMask = 1 then begin + MainForm.NPMmsg('Mask appears empty' +lMaskHdr.ImgFileName); + goto 667; + end; + if (lSaveData) then MainForm.NPMmsg('Mask has voxels from '+inttostr(lMinMask)+'..'+inttostr(lMaxMask)); + lVoxPerPlank := kPlankSz div lnObservations div sizeof(single) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lnObservations; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lnObservations) ) + 1; + if (lSaveData) then MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lnObservations))); + if (lSaveData) then MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory* sizeof(single)) //assumes 4bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + //lnVoxTested := 0; + for lPos := 1 to lnObservations do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + //createArray64(lObsp,lObs,lnObservations); + getmem(lOutImgMn,lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImgMn^[lPos] := 0; + for lFact := 1 to (lnStatFact) do begin //+1 as we include full model + getmem(lOutImgR[lFact],lVolVox* sizeof(single)); + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := 0; + end; + //createArray64(lZp,lZra,lnFactors+1); //+1 as we include full model + {$IFDEF Thread} + + ClearThreadDataPvals(gnCPUThreads,0) ; + {$ELSE} + lnVoxTested := 0; + {$ENDIF} + for lPlank := 1 to lnPlanks do begin + if (lSaveData) then MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lnObservations do begin + if not LoadImg(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + {$IFDEF Thread} + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + with TLinThreadStat.Create (X,ProgressBar1, lnFactors,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lnObservations, lMaskImg,lPlankImg,lOutImgMn,lOutImgR) do + {$IFDEF FPC} OnTerminate := @ThreadDone; {$ELSE}OnTerminate := ThreadDone;{$ENDIF} + inc(gThreadsRunning); + Msg('Thread ' +Inttostr(gThreadsRunning)+' = '+inttostr(lThreadStart)+'..'+inttostr(lThreadEnd)); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + {$ELSE} //not threaded + createArray64(lZp,lZra,lnFactors+1); //+1 as we include full model + createArray64(lObsp,lObs,lnObservations); + lPosPct := lVoxPerPlank div 100; + for lPos2 := 1 to lVoxPerPlank do begin + if (lPos2 mod lPosPct) = 0 then begin + MainForm.ProgressBar1.Position := round((lPos2/lVoxPerPlank)*100); + Application.Processmessages; + end; + lPos2Offset := lPos2+lStartVox-1; + if lMaskImg^[lPos2Offset] <> 0 then begin + inc(lnVoxTested); + lSum := 0; + //check for variance + lVar := false; + lPos := 1; + l1st := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + for lPos := 1 to lnObservations do begin + lObs^[lPos-1] := (gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]; + lSum := lSum + lObs^[lPos-1]; + if (not lVar) and (lObs^[lPos-1]<>l1st) then + lVar := true; + end; + lOutImgMn^[lPos2Offset] := lSum/lnObservations; + if lVar then begin + MultipleRegression (lnObservations,lnFactors, X, lObs, lZra); + //if {lZra^[0] < -5.548} lPos2Offset = 762287 then + // ReportRegression (lPos2Offset,lnObservations,lnFactors, X, lObs, lZra ); + for lFact := 1 to lnStatFact do + lOutImgR[lFact]^[lPos2Offset] := lZra^[lFact-1]; + end; + end; //in brain mask - compute + end; //for each voxel + Freemem(lZp); + Freemem(lObsp); + {$ENDIF} //if threaded else not threaded + lStartVox := lEndVox + 1; + end; //for each plank + {$IFDEF Thread} + lnVoxTested := SumThreadDataLite(gnCPUThreads); + {$ENDIF} + //FACTOR 1 MinMax + lFact := 1; + lMinZ := lOutImgR[lFact]^[1]; + for lPos := 1 to lVolVox do + if (lOutImgR[lFact]^[lPos] < lMinZ) then lMinZ :=lOutImgR[lFact]^[lPos]; + lMinZ := TtoZ (lMinZ,lDF); + lMaxZ := lOutImgR[lFact]^[1]; + for lPos := 1 to lVolVox do + if (lOutImgR[lFact]^[lPos] > lMaxZ) then lMaxZ :=lOutImgR[lFact]^[lPos]; + lMaxZ := TtoZ (lMaxZ,lDF); + //MainForm.NPMmsg('Factor1MinMax ' +floattostr(lMinZ)+' '+floattostr(lMaxZ)); + + if (lSaveData) then begin + //next report findings + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + MainForm.reportBonferroni('Std',lnVoxTested); + //next: save data + if lnFactors = 1 then + lRunName := lPredictorList[0] + else + lRunName := ''; + + //savedata + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + + + + //save mean + lOutNameMod := ChangeFilePostfixExt(lOutName,'Mean'+lRunName,'.hdr'); + if not FileExistsEX(lOutNameMod) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgMn,1); + //save regression + for lFact := 1 to (lnStatFact) do begin + if (lFact > lnFactors) and (lnFactors = 1) then begin + //nothing + end else begin + if (lFact > lnFactors) and (lnFactors = 1) then + lFactName := 'intercept'+lPredictorList[0] //for analysis of multiple single regressions + else if (lFact > lnFactors) then + lFactName := 'model' + else + lFactName := lPredictorList[lFact-1]; + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + //NEXT : optional save t-maps + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_TTEST,inttostr(lnVoxTested) ); + //lOutNameMod := ChangeFilePostfixExt(lOutName, 'wlsT'+lFactName,'.hdr'); + //NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + //END: t-maps + //next - Z scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + //{ DoF = Nb points - Nb parameters } + for lPos := 1 to lVolVox do + lOutImgR[lFact]^[lPos] := TtoZ (lOutImgR[lFact]^[lPos],lDF); + MainForm.reportFDR ('wls'+lFactName, lVolVox, lnVoxTested, lOutImgR[lFact]); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'wls'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + if (lFact = 1) and (TFCEconn > 0) then begin //TFCE + //lMinZ := lOutImgR[lFact]^[1]; + + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + doTFCEbothPolarities (lStatHdr, lOutImgR[lFact], TFCEconn {NumConn}, 2.0{H}, 0.5 {E}, 0, lMaxZ/100, 0, lMinZ/100, lMaxTFCEZ, lMaxNegTFCEZ); + lOutNameMod := ChangeFilePostfixExt(lOutName, 'tfce'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgR[lFact],1); + end; //TFCE + + end;//if..else intercept and lnFactors = 1 + end;//for each statfactor + end; //if lSaveData + + + if (not (lSaveData)) and (TFCEconn > 0) and ((lMaxTFCEZ <> 0) or (lMaxNegTFCEZ <> 0)) then begin + //lMinZ := lOutImgR[lFact]^[1]; + lFact := 1; + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,lDF,0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + doTFCEbothPolarities (lStatHdr, lOutImgR[lFact], TFCEconn {NumConn}, 2.0{H}, 0.5 {E}, 0, lMaxTFCEZ, 0, lMaxNegTFCEZ, lMaxTFCEZ, lMaxNegTFCEZ) + + end; //xxx + //next: close images + for lFact := 1 to (lnStatFact) do + freemem(lOutImgR[lFact]); + + //Freemem(lZp); + freemem(lOutImgMn); + //freemem(lObsp); + freemem(lMaskImg); + freemem(lPlankImg); + + //lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lRunName,'.txt'); + //MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; +exit; +667: //you only get here if you aborted ... free memory and report error + if lVolVox > 1 then freemem(lMaskImg); + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; + +procedure PermuteMatrix(var Src, Dest: PMatrix; lnSubj: integer); //assumes only one column/factor!!! +var + lRow,lPos: integer; + lSwap: double; +begin + for lRow := 1 to lnSubj do + Dest^[1]^[lRow] := Src^[1]^[lRow]; + for lRow := lnSubj downto 1 do begin + lPos := random(lRow)+1; + lSwap := Dest^[1]^[lRow]; + Dest^[1]^[lRow] := Dest^[1]^[lPos]; + Dest^[1]^[lPos] := lSwap; + end; + +end; + +function ARegressNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var X: PMatrix; lnFactors: integer; var lPredictorList: TStringList; lOutname: string; lnPermute, TFCEconn: integer ): boolean; +label + 777; +var + //SaveData: boolean; var + lMaxTFCEZ, lMaxNegTFCEZ: single; + lMinZ,lMaxZ,lTFCEdh,lNegTFCEdh:double; + Xp : PMatrix; + lp,lnSubj,lRow : integer; + lPermuteMaxZ, lPermuteMinZ,lPermuteMaxTFCEZ, lPermuteMinTFCEZ: singleP; +begin + InnerARegressNPMAnalyze (lImages, lMaskHdr, X, lnFactors, lPredictorList, lOutname, TRUE,lMinZ,lMaxZ, lMaxNegTFCEZ, lMaxTFCEZ, TFCEconn ); + if lnFactors > 1 then goto 777; + if (lnPermute < 1) then goto 777; + //MainForm.NPMmsg('0 ObservedzMinMax ' +floattostr(lMinZ)+' '+floattostr(lMaxZ)); + MainForm.NPMmsg('OBSERVED Factor1 zMin zMax zMinTFCE zMaxTFCE ' +floattostr(lMinZ)+' '+floattostr(lMaxZ) +' ' +floattostr(lMaxNegTFCEZ)+' '+floattostr(lMaxTFCEZ)); + + lnSubj := lImages.Count; + DimMatrix(Xp, lnFactors, lnSubj); + randomize; + getmem(lPermuteMaxZ,lnPermute* sizeof(single)); + getmem(lPermuteMinZ,lnPermute* sizeof(single)); + getmem(lPermuteMaxTFCEZ,lnPermute* sizeof(single)); + getmem(lPermuteMinTFCEZ,lnPermute* sizeof(single)); + lTFCEdh := lMaxZ / 100; + lNegTFCEdh := abs(lMinZ) / 100; + for lp := 1 to lnPermute do begin + //for lRow := 1 to lnSubj do + // Xp^[1]^[lRow] := X^[1]^[lRow]; + lMaxNegTFCEZ := lNegTFCEdh; + lMaxTFCEZ := lTFCEdh; + PermuteMatrix(X,Xp,lnSubj); + + InnerARegressNPMAnalyze (lImages, lMaskHdr, Xp, lnFactors, lPredictorList, lOutname, FALSE,lMinZ,lMaxZ,lMaxNegTFCEZ, lMaxTFCEZ, TFCEconn); + MainForm.NPMmsg(inttostr(lp)+' Factor1 zMin zMax zMinTFCE zMaxTFCE ' +floattostr(lMinZ)+' '+floattostr(lMaxZ) +' ' +floattostr(lMaxNegTFCEZ)+' '+floattostr(lMaxTFCEZ)); + lPermuteMaxZ^[lp] := lMaxZ; + lPermuteMinZ^[lp] := lMinZ; + lPermuteMaxTFCEZ^[lp] := lMaxTFCEZ; + lPermuteMinTFCEZ^[lp] := lMaxNegTFCEZ; + end; + DelMatrix(Xp, lnFactors, lnSubj); + MainForm.reportPermute ('Permutation', lnPermute, lPermuteMaxZ, lPermuteMinZ); + MainForm.reportPermute ('TFCEPermutation', lnPermute, lPermuteMaxTFCEZ, lPermuteMinTFCEZ); + Freemem(lPermuteMaxZ); + Freemem(lPermuteMinZ); + Freemem(lPermuteMaxTFCEZ); + Freemem(lPermuteMinTFCEZ); + 777: + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + MainForm.MsgSave( ChangeFilePostfixExt(lOutName,'Notes','.txt')); + +end; + + + +function GetValReg (var lnSubj,lnFactors: integer; var X : PMatrix; var lImageNames: TStrings; var lPredictorList: TStringList): boolean; +var + lVALFilename,lTemplateName: string; + lnRow,lnColWObs,lnCritPct,lInc,lRow,lCol: integer; + lDesignUnspecified : boolean; + lFileList:TStringList; + lInRA: DoubleP0; + lInP: Pointer; +begin + result := false; + + lnSubj := 0; + if not MainForm.OpenDialogExecute('Select MRIcron VAL file',false,false,'MRIcron VAL (*.val)|*.val') then begin + showmessage('NPM aborted: VAL file selection failed.'); + exit; + end; //if not selected + lVALFilename := MainForm.OpenHdrDlg.Filename; + MainForm.Memo1.Lines.Add( 'VAL filename: '+lVALFilename); + + lFileList := TStringList.Create; + if not OpenValFile (lVALFilename,lTemplateName, lnRow,lnFactors,lnColWObs,lnCritPct, + lDesignUnspecified,lPredictorList,lFileList, lInP) then + exit; + if lnRow > 1 then begin + lnSubj := lnRow -1; //top row is predictor + {$IFDEF FPC} + lInRA := align(lInP,16); + {$ELSE} + lInRA := DoubleP0($fffffff0 and (integer(lInP)+15)); + //lInRA := DoubleP0((integer(lInP) and $FFFFFFF0)+16); + {$ENDIF} + DimMatrix(X, lnFactors, lnSubj); + for lCol := 1 to lnFactors do begin + for lRow := 1 to lnSubj do begin + //MainForm.Memo1.Lines.Add(inttostr( (lRow*lnColWObsAndCovary)-4+lCol )); + X^[lCol]^[lRow] := lInRA^[(lRow*lnColWObs)-lnColWObs-1+lCol]; + end; + end; + MainForm.Memo1.Lines.Add(inttostr(lnFactors)+' '+inttostr(lnSubj)); + for lInc := 1 to lnSubj do + lImageNames.add(ExtractFileDirWithPathDelim(lVALFilename)+lFileList.Strings[lInc-1]); + result := true; + end else + result := false; + lFileList.free; + Freemem(lInP); +end; + + +end. \ No newline at end of file diff --git a/npm_precl/results.niiNotesseverity.txt b/npm_precl/results.niiNotesseverity.txt new file mode 100755 index 0000000..879c1b3 --- /dev/null +++ b/npm_precl/results.niiNotesseverity.txt @@ -0,0 +1,72 @@ +Threads: 2 +Factor = severity +c:\mri\anacom\n01.voi = 4.00 +c:\mri\anacom\n02.voi = 4.50 +c:\mri\anacom\n03.voi = 0.00 +c:\mri\anacom\n04.voi = 2.50 +c:\mri\anacom\n05.voi = 5.00 +c:\mri\anacom\n06.voi = 4.00 +c:\mri\anacom\n07.voi = 3.25 +c:\mri\anacom\n08.voi = 0.75 +c:\mri\anacom\n09.voi = 4.50 +c:\mri\anacom\n10.voi = 4.50 +c:\mri\anacom\n11.voi = 0.50 +c:\mri\anacom\n12.voi = 1.63 +c:\mri\anacom\n13.voi = 0.00 +c:\mri\anacom\n14.voi = 3.50 +c:\mri\anacom\n15.voi = 3.00 +c:\mri\anacom\n17.voi = 4.00 +c:\mri\anacom\n18.voi = 2.00 +c:\mri\anacom\n19.voi = 4.50 +c:\mri\anacom\n20.voi = 5.00 +c:\mri\anacom\n21.voi = 0.00 +c:\mri\anacom\n22.voi = 1.50 +c:\mri\anacom\n23.voi = 5.00 +c:\mri\anacom\n24.voi = 2.50 +c:\mri\anacom\n25.voi = 5.00 +c:\mri\anacom\n26.voi = 4.00 +c:\mri\anacom\n27.voi = 0.00 +c:\mri\anacom\n28.voi = 0.00 +c:\mri\anacom\n29.voi = 2.00 +c:\mri\anacom\n30.voi = 1.50 +c:\mri\anacom\n31.voi = 1.75 +c:\mri\anacom\n32.voi = 0.00 +c:\mri\anacom\n33.voi = 2.50 +c:\mri\anacom\n34.voi = 5.00 +c:\mri\anacom\n35.voi = 0.00 +c:\mri\anacom\n37.voi = 0.00 +c:\mri\anacom\n38.voi = 3.25 +c:\mri\anacom\n39.voi = 4.38 +c:\mri\anacom\n40.voi = 0.00 +c:\mri\anacom\n41.voi = 3.75 +c:\mri\anacom\n42.voi = 0.25 +c:\mri\anacom\n43.voi = 0.00 +c:\mri\anacom\n44.voi = 2.00 +c:\mri\anacom\n45.voi = 5.00 +c:\mri\anacom\n46.voi = 0.00 +c:\mri\anacom\n47.voi = 0.50 +c:\mri\anacom\n48.voi = 0.00 +c:\mri\anacom\n49.voi = 2.25 +c:\mri\anacom\n50.voi = 0.00 +c:\mri\anacom\n51.voi = 2.25 +c:\mri\anacom\n52.voi = 2.00 +c:\mri\anacom\n53.voi = 0.00 +c:\mri\anacom\n54.voi = 0.25 +c:\mri\anacom\n55.voi = 0.00 +Total voxels = 7109137 +Only testing voxels damaged in at least 5 individual[s] +Number of Lesion maps = 53 +Permutations = 0 +Analysis began = 2008-Mar-24 14:41:02 +Memory planks = 0.701815434883711 +Max voxels per Plank = 10129639 +Computing plank = 1 +Voxels tested = 40826 +Only tested voxels with more than 5 lesions +40826 test Std Bonferroni FWE Z 0.050=4.712, 0.025=4.852, 0.01=5.030 +n=,53,minN=,5,unique overlap patterns,9785,voxels tested,20016 +9785 test Unique overlap Bonferroni FWE Z 0.050=4.412, 0.025=4.560, 0.01=4.749 +ttest Range -3.936...5.118 +ttest +FDR Z 0.050=2.085, 0.01=3.152 +ttest -FDR Z 0.050=-3.440, 0.01=9.200 +Analysis finished = 2008-Mar-24 14:41:50 diff --git a/npm_precl/roc.pas b/npm_precl/roc.pas new file mode 100755 index 0000000..4b5a309 --- /dev/null +++ b/npm_precl/roc.pas @@ -0,0 +1,355 @@ +unit roc; +interface +//demonstrates the ROC tests that are in the Brunner.pas file +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,//Brunner,nifti_img, DISTR + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, //overlap,ReadInt,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,IniFiles,cpucount,userdir,math, +regmult,utypes; +procedure testROC; +procedure testROC2; +function AUCbinomcont (lBinomdataRA,lContdataRA: singlep; lnSubj :integer): double; +function AUCcontcont (ldatara1,ldatara2: singlep; lnSubj :integer): double; +implementation + +uses npmform; + +function readCSV2 (lFilename: string; lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) or (MaxC < (kHdrCol+lCol2)) then begin + showmessage('problems reading CSV - not enough columns/rows '+inttostr(lCol1)+' '+inttostr(lCol2)); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := MaxC-1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + getmem(ldataRA2,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) or ((C-kHdrCol) = lCol2) then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then + ldataRA1^[R-kHdrRow] := lTempFloat + else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat; + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + ldataRA2^[R-1] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; + +function AUCcontcont (ldatara1,ldatara2: singlep; lnSubj :integer): double; +var + lIn,lInDX : DoubleP0; + lnGroup0,lnGroup1,lI: integer; +begin + result := 0.5; + if lnSubj < 1 then + exit; + Getmem(lIn,lnSubj*sizeof(double)); + Getmem(lInDX,lnSubj*sizeof(double)); + for lI := 1 to lnSubj do begin + lIn^[lI-1] := ldatara2^[lI]; + lInDX^[lI-1] := ldatara1^[lI]; + end; + result := continROC2 (lnSubj, lIn, lInDX); + freemem(lIn); + freemem(lInDX); +end; + +function AUCbinomcont (lBinomdataRA,lContdataRA: singlep; lnSubj :integer): double; +var + lIn : DoubleP0; + lnGroup0,lnGroup1,lI: integer; +begin + result := 0.5; + if lnSubj < 1 then + exit; + Getmem(lIn,lnSubj*sizeof(double)); + lnGroup0 := 0; + lnGroup1 := 0; + for lI := 1 to lnSubj do begin + if lBinomdataRA^[lI] = 0 then begin + lIn^[lnGroup0] := lContdataRA^[lI]; + inc (lnGroup0); + end else begin + inc (lnGroup1); + lIn^[lnSubj-lnGroup1] := lContdataRA^[lI]; + + end; + end; + result := continROC (lnSubj, lnGroup0, lIn); + freemem(lIn); +end; + +procedure testROC; +var + lROC : single; + lI,lnSubj,lnGroup0: integer; + //lIn : DoubleP0; + //csv + lnGroup1,lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep ; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('ROC analysis requires CSV format text file.'); + npmform.MainForm.memo1.lines.add('First column is the filename (ignored).'); + npmform.MainForm.memo1.lines.add('Second column is 0 [deficit present] or 1 [no deficit].'); + npmform.MainForm.memo1.lines.add('Third column is number of voxels injured in ROI [0 or greater]:'); + npmform.MainForm.memo1.lines.add('Example file:'); + //npmform.MainForm.memo1.lines.add('deficit, voxels'); + npmform.MainForm.memo1.lines.add('c:\c01.voi,0, 121'); + npmform.MainForm.memo1.lines.add('c:\c02.voi,1, 33'); + npmform.MainForm.memo1.lines.add('c:\c03.voi,0, 222'); + npmform.MainForm.memo1.lines.add('c:\c04.voi,1, 56'); + npmform.MainForm.memo1.lines.add('c:\c05.voi,1, 96'); + npmform.MainForm.memo1.lines.add('c:\c06.voi,0, 100'); + //get csv + npmform.MainForm.memo1.lines.add(' ...requesting CSV file'); + + if not MainForm.OpenDialogExecute('Select comma separated filenames ',false,false,kTxtFilter) then + exit; + npmform.MainForm.memo1.lines.add(' ...reading CSV file'); + if not readCSV2 (MainForm.OpenHdrDlg.Filename, 2,3, lnObservations, ldataRA1,ldataRA2) then + exit; + npmform.MainForm.memo1.lines.add(' ...observations: '+inttostr(lnObservations)); + if lnObservations < 3 then begin + showmessage('At least 3 subjects required.'); + exit; + end; + lnSubj := lnObservations; + lnGroup0 := 0; + for lI := 1 to lnSubj do + if ldatara1^[lI] = 0 then + inc (lnGroup0); + npmform.MainForm.memo1.lines.add(' ...observations with deficit [0]: '+inttostr(lnGroup0)); + if (lnGroup0 = lnSubj) or (lnGroup0 = 0) then begin + showmessage('Some values in the first column must be zero, some must be non-zero.'); + exit; + end; + lROC := AUCbinomcont (ldatara1,ldatara2, lnSubj); + (*Getmem(lIn,lnSubj*sizeof(double)); + lnGroup0 := 0; + lnGroup1 := 0; + for lI := 1 to lnSubj do begin + if ldatara1[lI] = 0 then begin + lIn[lnGroup0] := ldatara2[lI]; + inc (lnGroup0); + end else begin + inc (lnGroup1); + lIn[lnSubj-lnGroup1] := ldatara2[lI]; + + end; + end; + lROC := continROC (lnSubj, lnGroup0, lIn); + freemem(lIn); + *) + + freemem(ldataRA1); + freemem(ldataRA2); + //now analyze + npmform.MainForm.memo1.lines.add('ROC = '+floattostr(lROC)); + //fx(lROC); +end; + + +procedure testROC2; +var + //lDouble: double; + lVariable: boolean; + lF,lROC : single; + lI,lnSubj: integer; + lIn,lInDX : DoubleP0; + //csv + lnGroup1,lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep ; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('ROC analysis requires CSV format text file.'); + npmform.MainForm.memo1.lines.add('First column is the filename (ignored).'); + npmform.MainForm.memo1.lines.add('Second column is degree of deficit [lower value = more impaired].'); + npmform.MainForm.memo1.lines.add('Third column is number of voxels injured in ROI [0 or greater]:'); + npmform.MainForm.memo1.lines.add('Example file:'); + //npmform.MainForm.memo1.lines.add('deficit, voxels'); + npmform.MainForm.memo1.lines.add('c:\c01.voi,0.3, 121'); + npmform.MainForm.memo1.lines.add('c:\c02.voi,0.1, 33'); + npmform.MainForm.memo1.lines.add('c:\c03.voi,0.2, 222'); + npmform.MainForm.memo1.lines.add('c:\c04.voi,1.3, 56'); + npmform.MainForm.memo1.lines.add('c:\c05.voi,1.7, 96'); + npmform.MainForm.memo1.lines.add('c:\c06.voi,1.5, 100'); + //get csv + npmform.MainForm.memo1.lines.add(' ...requesting CSV file'); + + if not MainForm.OpenDialogExecute('Select comma separated filenames ',false,false,kTxtFilter) then + exit; + npmform.MainForm.memo1.lines.add(' ...reading CSV file'); + if not readCSV2 (MainForm.OpenHdrDlg.Filename, 2,3, lnObservations, ldataRA1,ldataRA2) then + exit; + npmform.MainForm.memo1.lines.add(' ...observations: '+inttostr(lnObservations)); + if lnObservations < 3 then begin + showmessage('At least 3 subjects required.'); + exit; + end; + lnSubj := lnObservations; + lF := ldatara1^[1]; + lVariable := false; + for lI := 1 to lnSubj do + if ldatara1^[lI] <> lF then + lVariable := true; + if (not lVariable) then begin + showmessage('The columns must have some variability.'); + exit; + end; + Getmem(lIn,lnSubj*sizeof(double)); + Getmem(lInDX,lnSubj*sizeof(double)); + for lI := 1 to lnSubj do begin + lIn^[lI-1] := ldatara2^[lI]; + lInDX^[lI-1] := ldatara1^[lI]; + end; + freemem(ldataRA1); + freemem(ldataRA2); + //now analyze + (*lnSubj := 10; + lnGroup0 := 5; + Getmem(lIn,lnSubj*sizeof(double)); + for lI := 0 to (lnSubj-1) do + lIn[lI] := -lI;//random(99); *) + lROC := continROC2 (lnSubj, lIn, lInDX); + npmform.MainForm.memo1.lines.add('ROC = '+floattostr(lROC)); + freemem(lIn); + freemem(lInDX); + +end; + +(*procedure testROC; +var + lROC : single; + lI,lnSubj,lnGroup0: integer; + lIn : DoubleP0; +begin + lnSubj := 10; + lnGroup0 := 5; + Getmem(lIn,lnSubj*sizeof(double)); + for lI := 0 to (lnSubj-1) do + lIn[lI] := -lI;//random(99); + lROC := continROC (lnSubj, lnGroup0, lIn); + npmform.MainForm.memo1.lines.add('ROC = '+floattostr(lROC)); + //fx(lROC); + freemem(lIn); + +end; *) + + +end. diff --git a/npm_precl/spread.dfm b/npm_precl/spread.dfm new file mode 100755 index 0000000..f7aaee9 Binary files /dev/null and b/npm_precl/spread.dfm differ diff --git a/npm_precl/spread.lfm b/npm_precl/spread.lfm new file mode 100755 index 0000000..17df06f --- /dev/null +++ b/npm_precl/spread.lfm @@ -0,0 +1,195 @@ +object SpreadForm: TSpreadForm + Left = 401 + Height = 538 + Top = 183 + Width = 326 + ActiveControl = DataGrid + Caption = 'Voxelwise Analysis of Lesions' + ClientHeight = 538 + ClientWidth = 326 + Menu = MainMenu1 + OnClose = FormClose + OnCreate = FormCreate + OnResize = FormResize + Position = poScreenCenter + LCLVersion = '0.9.30.2' + object DataGrid: TStringGrid + Left = 0 + Height = 498 + Top = 25 + Width = 326 + Align = alClient + FixedRows = 2 + Options = [goFixedVertLine, goVertLine, goHorzLine, goRangeSelect, goDrawFocusSelected, goTabs, goThumbTracking] + RowCount = 12 + TabOrder = 0 + OnDrawCell = DataGridDrawCell + OnKeyPress = DataGridKeyPress + OnMouseDown = DataGridMouseDown + OnMouseMove = DataGridMouseMove + OnSelectCell = DataGridSelectCell + end + object ToolBar1: TToolBar + Left = 0 + Height = 25 + Top = 0 + Width = 326 + EdgeBorders = [] + TabOrder = 1 + object DesignBtn: TSpeedButton + Left = 1 + Height = 22 + Hint = 'ANOVA' + Top = 0 + Width = 120 + Caption = 'Design' + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 0400000000000001000000000000000000001000000010000000000000000000 + 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00337333733373 + 3373337F3F7F3F7F3F7F33737373737373733F7F7F7F7F7F7F7F770000000000 + 00007777777777777777330333333C333333337FFF3337F3333F370993333C33 + 3399377773F337F33377330339333C3339333F7FF7FFF7FFF7FF770777977C77 + 97777777777777777777330333933C339333337F3373F7F37333370333393C39 + 3333377F333737F7333333033333999333333F7FFFFF777FFFFF770777777C77 + 77777777777777777777330333333C330333337F333337FF7FF3370333333C00 + 003C377F333337777737330333333C3303333F7FFFFFF7FF7FFF770777777777 + 7777777777777777777733333333333333333333333333333333 + } + NumGlyphs = 2 + OnClick = DesignBtnClick + ShowHint = True + ParentShowHint = False + end + end + object StatusBar1: TStatusBar + Left = 0 + Height = 15 + Top = 523 + Width = 326 + Panels = < + item + Width = 140 + end + item + Width = 50 + end> + SimplePanel = False + end + object MainMenu1: TMainMenu + left = 108 + top = 44 + object File1: TMenuItem + Caption = '&File' + object New1: TMenuItem + Caption = 'New...' + ShortCut = 16462 + OnClick = NewBtnClick + end + object Open1: TMenuItem + Caption = 'Open...' + ShortCut = 16463 + OnClick = OpenBtnClick + end + object Save1: TMenuItem + Caption = 'Save' + ShortCut = 16467 + OnClick = SaveBtnClick + end + object Quit1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Quit1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + ShortCut = 16451 + OnClick = Copy1Click + end + object Paste1: TMenuItem + Caption = 'Paste' + ShortCut = 16470 + OnClick = Paste1Click + end + object Selectall1: TMenuItem + Caption = 'Select all cells' + ShortCut = 16449 + OnClick = Selectall1Click + end + object Clearallcells1: TMenuItem + Caption = 'Clear all cells...' + OnClick = Clearallcells1Click + end + object DescriptiveMenu: TMenuItem + Caption = 'Descriptives' + OnClick = DescriptiveClick + end + end + object View: TMenuItem + Caption = 'View' + object Font1: TMenuItem + Caption = 'Font' + object N81: TMenuItem + Tag = 8 + Caption = '8' + Checked = True + GroupIndex = 111 + RadioItem = True + OnClick = FontSizeChange + end + object N101: TMenuItem + Tag = 10 + Caption = '10' + GroupIndex = 111 + RadioItem = True + OnClick = FontSizeChange + end + object N121: TMenuItem + Tag = 12 + Caption = '12' + GroupIndex = 111 + RadioItem = True + OnClick = FontSizeChange + end + object N141: TMenuItem + Tag = 14 + Caption = '14' + GroupIndex = 111 + RadioItem = True + OnClick = FontSizeChange + end + end + object Design1: TMenuItem + Caption = 'Design' + ShortCut = 16452 + OnClick = DesignBtnClick + end + end + object Help1: TMenuItem + Caption = '&Help' + object Aboutthissoftware1: TMenuItem + Caption = '&About this software' + OnClick = Aboutthissoftware1Click + end + end + end + object OpenDialog1: TOpenDialog + DefaultExt = '.val' + Filter = 'Native [val]|.val|Tab delimited text [txt]|.txt|All files|.*' + FilterIndex = 0 + left = 36 + top = 44 + end + object SaveDialog1: TSaveDialog + DefaultExt = '.val' + Filter = 'Native format [val]|*.val|Tab delimited text [txt]|*.txt' + FilterIndex = 0 + Options = [ofOverwritePrompt, ofHideReadOnly] + left = 74 + top = 44 + end +end diff --git a/npm_precl/spread.lrs b/npm_precl/spread.lrs new file mode 100755 index 0000000..cf9ecb9 --- /dev/null +++ b/npm_precl/spread.lrs @@ -0,0 +1,66 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TSpreadForm','FORMDATA',[ + 'TPF0'#11'TSpreadForm'#10'SpreadForm'#4'Left'#3#145#1#6'Height'#3#26#2#3'Top' + +#3#183#0#5'Width'#3'F'#1#13'ActiveControl'#7#8'DataGrid'#7'Caption'#6#29'Vox' + +'elwise Analysis of Lesions'#12'ClientHeight'#3#26#2#11'ClientWidth'#3'F'#1#9 + +'Font.Name'#6#13'MS Sans Serif'#4'Menu'#7#9'MainMenu1'#7'OnClose'#7#9'FormCl' + +'ose'#8'OnCreate'#7#10'FormCreate'#8'OnResize'#7#10'FormResize'#8'Position'#7 + +#14'poScreenCenter'#10'LCLVersion'#6#8'0.9.30.2'#0#11'TStringGrid'#8'DataGri' + +'d'#4'Left'#2#0#6'Height'#3#242#1#3'Top'#2#25#5'Width'#3'F'#1#5'Align'#7#8'a' + +'lClient'#9'FixedRows'#2#2#7'Options'#11#15'goFixedVertLine'#10'goVertLine' + +#10'goHorzLine'#13'goRangeSelect'#19'goDrawFocusSelected'#6'goTabs'#15'goThu' + +'mbTracking'#0#8'RowCount'#2#12#8'TabOrder'#2#0#14'TitleFont.Name'#6#13'MS S' + +'ans Serif'#10'OnDrawCell'#7#16'DataGridDrawCell'#10'OnKeyPress'#7#16'DataGr' + +'idKeyPress'#11'OnMouseDown'#7#17'DataGridMouseDown'#11'OnMouseMove'#7#17'Da' + +'taGridMouseMove'#12'OnSelectCell'#7#18'DataGridSelectCell'#0#0#8'TToolBar'#8 + +'ToolBar1'#4'Left'#2#0#6'Height'#2#25#3'Top'#2#0#5'Width'#3'F'#1#11'EdgeBord' + +'ers'#11#0#8'TabOrder'#2#1#0#12'TSpeedButton'#9'DesignBtn'#4'Left'#2#1#6'Hei' + +'ght'#2#22#4'Hint'#6#5'ANOVA'#3'Top'#2#0#5'Width'#2'x'#7'Caption'#6#6'Design' + +#10'Glyph.Data'#10'z'#1#0#0'v'#1#0#0'BMv'#1#0#0#0#0#0#0'v'#0#0#0'('#0#0#0' ' + +#0#0#0#16#0#0#0#1#0#4#0#0#0#0#0#0#1#0#0#0#0#0#0#0#0#0#0#16#0#0#0#16#0#0#0#0#0 + +#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#127 + +#127#127#0#191#191#191#0#0#0#255#0#0#255#0#0#0#255#255#0#255#0#0#0#255#0#255 + +#0#255#255#0#0#255#255#255#0'3s3s3s3s3'#127'?'#127'?'#127'?'#127'3sssssss?' + +#127#127#127#127#127#127#127'w'#0#0#0#0#0#0#0'wwwwwwww3'#3'33<3333'#127#255 + +'37'#243'3?7'#9#147'3<33'#153'7ws'#243'7'#243'3w3'#3'93<393?'#127#247#255#247 + +#255#247#255'w'#7'w'#151'|w'#151'wwwwwwwww3'#3'3'#147'<3'#147'33'#127'3s'#247 + +#243's37'#3'39<9337'#127'377'#247'333'#3'33'#153#147'33?'#127#255#255'w'#127 + +#255#255'w'#7'ww|wwwwwwwwwww3'#3'33<3'#3'33'#127'337'#255#127#243'7'#3'33<'#0 + +#0'<7'#127'337ww73'#3'33<3'#3'3?'#127#255#255#247#255#127#255'w'#7'wwwwwwwww' + +'wwwww3333333333333333'#9'NumGlyphs'#2#2#7'OnClick'#7#14'DesignBtnClick'#8'S' + +'howHint'#9#14'ParentShowHint'#8#0#0#0#10'TStatusBar'#10'StatusBar1'#4'Left' + +#2#0#6'Height'#2#15#3'Top'#3#11#2#5'Width'#3'F'#1#6'Panels'#14#1#5'Width'#3 + +#140#0#0#1#5'Width'#2'2'#0#0#11'SimplePanel'#8#0#0#9'TMainMenu'#9'MainMenu1' + +#4'left'#2'l'#3'top'#2','#0#9'TMenuItem'#5'File1'#7'Caption'#6#5'&File'#0#9 + +'TMenuItem'#4'New1'#7'Caption'#6#6'New...'#8'ShortCut'#3'N@'#7'OnClick'#7#11 + +'NewBtnClick'#0#0#9'TMenuItem'#5'Open1'#7'Caption'#6#7'Open...'#8'ShortCut'#3 + +'O@'#7'OnClick'#7#12'OpenBtnClick'#0#0#9'TMenuItem'#5'Save1'#7'Caption'#6#4 + +'Save'#8'ShortCut'#3'S@'#7'OnClick'#7#12'SaveBtnClick'#0#0#9'TMenuItem'#5'Qu' + +'it1'#7'Caption'#6#12'Close window'#8'ShortCut'#3'W@'#7'OnClick'#7#10'Quit1C' + +'lick'#0#0#0#9'TMenuItem'#5'Edit1'#7'Caption'#6#4'Edit'#0#9'TMenuItem'#5'Cop' + +'y1'#7'Caption'#6#4'Copy'#8'ShortCut'#3'C@'#7'OnClick'#7#10'Copy1Click'#0#0#9 + +'TMenuItem'#6'Paste1'#7'Caption'#6#5'Paste'#8'ShortCut'#3'V@'#7'OnClick'#7#11 + +'Paste1Click'#0#0#9'TMenuItem'#10'Selectall1'#7'Caption'#6#16'Select all cel' + +'ls'#8'ShortCut'#3'A@'#7'OnClick'#7#15'Selectall1Click'#0#0#9'TMenuItem'#14 + +'Clearallcells1'#7'Caption'#6#18'Clear all cells...'#7'OnClick'#7#19'Clearal' + +'lcells1Click'#0#0#9'TMenuItem'#15'DescriptiveMenu'#7'Caption'#6#12'Descript' + +'ives'#7'OnClick'#7#16'DescriptiveClick'#0#0#0#9'TMenuItem'#4'View'#7'Captio' + +'n'#6#4'View'#0#9'TMenuItem'#5'Font1'#7'Caption'#6#4'Font'#0#9'TMenuItem'#3 + +'N81'#3'Tag'#2#8#7'Caption'#6#1'8'#7'Checked'#9#10'GroupIndex'#2'o'#9'RadioI' + +'tem'#9#7'OnClick'#7#14'FontSizeChange'#0#0#9'TMenuItem'#4'N101'#3'Tag'#2#10 + +#7'Caption'#6#2'10'#10'GroupIndex'#2'o'#9'RadioItem'#9#7'OnClick'#7#14'FontS' + +'izeChange'#0#0#9'TMenuItem'#4'N121'#3'Tag'#2#12#7'Caption'#6#2'12'#10'Group' + +'Index'#2'o'#9'RadioItem'#9#7'OnClick'#7#14'FontSizeChange'#0#0#9'TMenuItem' + +#4'N141'#3'Tag'#2#14#7'Caption'#6#2'14'#10'GroupIndex'#2'o'#9'RadioItem'#9#7 + +'OnClick'#7#14'FontSizeChange'#0#0#0#9'TMenuItem'#7'Design1'#7'Caption'#6#6 + +'Design'#8'ShortCut'#3'D@'#7'OnClick'#7#14'DesignBtnClick'#0#0#0#9'TMenuItem' + +#5'Help1'#7'Caption'#6#5'&Help'#0#9'TMenuItem'#18'Aboutthissoftware1'#7'Capt' + +'ion'#6#20'&About this software'#7'OnClick'#7#23'Aboutthissoftware1Click'#0#0 + +#0#0#11'TOpenDialog'#11'OpenDialog1'#10'DefaultExt'#6#4'.val'#6'Filter'#6'<N' + +'ative [val]|.val|Tab delimited text [txt]|.txt|All files|.*'#11'FilterIndex' + +#2#0#4'left'#2'$'#3'top'#2','#0#0#11'TSaveDialog'#11'SaveDialog1'#10'Default' + +'Ext'#6#4'.val'#6'Filter'#6'8Native format [val]|*.val|Tab delimited text [t' + +'xt]|*.txt'#11'FilterIndex'#2#0#7'Options'#11#17'ofOverwritePrompt'#14'ofHid' + +'eReadOnly'#0#4'left'#2'J'#3'top'#2','#0#0#0 +]); \ No newline at end of file diff --git a/npm_precl/spread.pas b/npm_precl/spread.pas new file mode 100755 index 0000000..0873ed9 --- /dev/null +++ b/npm_precl/spread.pas @@ -0,0 +1,1036 @@ +unit spread; +interface +{$H+} +uses +{$IFNDEF FPC} +//Utils, +Toolwin,shlobj,Spin,ShellApi,windows,messages, +{$ELSE} +LResources, +{$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Grids, Menus, ComCtrls, Buttons,Clipbrd,design, StdCtrls,Registry, + define_types,valformat; + +type + + { TSpreadForm } + + TSpreadForm = class(TForm) + DataGrid: TStringGrid; + MainMenu1: TMainMenu; + File1: TMenuItem; + //DescriptiveMenu: TMenuItem; + New1: TMenuItem; + Open1: TMenuItem; + Design1:TMenuItem; + Quit1: TMenuItem; + ToolBar1: TToolBar; + Help1: TMenuItem; + Aboutthissoftware1: TMenuItem; + StatusBar1: TStatusBar; + Save1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Paste1: TMenuItem; + OpenDialog1: TOpenDialog; + SaveDialog1: TSaveDialog; + Selectall1: TMenuItem; + View: TMenuItem; + Font1: TMenuItem; + N81: TMenuItem; + N101: TMenuItem; + N121: TMenuItem; + N141: TMenuItem; + DesignBtn: TSpeedButton; + Clearallcells1: TMenuItem; + DescriptiveMenu: TMenuItem; + procedure UpdateLabels; + function GetVal (lC,lR: integer; var lVal: double): boolean; + procedure Quit1Click(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure Aboutthissoftware1Click(Sender: TObject); + procedure OpenBtnClick(Sender: TObject); + procedure DataGridSelectCell(Sender: TObject; ACol, ARow: Integer; + var CanSelect: Boolean); + procedure NewBtnClick(Sender: TObject); + procedure Save1Click(var NoCancel: boolean); + procedure FormCreate(Sender: TObject); + procedure DataGridMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure OpenTextFile (var lFilename:string); + function CheckSave2Close (lAllowCancel: boolean): boolean; + procedure DataGridKeyPress(Sender: TObject; var Key: Char); + procedure Copy1Click(Sender: TObject); + procedure Paste1Click(Sender: TObject); + procedure SaveBtnClick(Sender: TObject); + procedure ShowStatus; + procedure ReadCells2Buffer; + procedure Selectall1Click(Sender: TObject); + procedure FontSizeChange(Sender: TObject); + procedure DataGridMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure DataGridDrawCell(Sender: TObject; Col, Row: Integer; + Rect: TRect; State: TGridDrawState); + procedure Clearallcells1Click(Sender: TObject); + procedure DesignBtnClick(Sender: TObject); + procedure AddMRIScansClick(Sender: TObject); + procedure DescriptiveClick(Sender: TObject); + function SOpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean; +{$IFNDEF FPC} + procedure FormClose(Sender: TObject; var Action: TCloseAction); +{$ELSE} + procedure FormClose(Sender: TObject); + //procedure SpeedButton3Click(Sender: TObject); +{$ENDIF} + + private + //procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES; + { Private declarations } + public + { Public declarations } + end; + +var + SpreadForm: TSpreadForm; +const + kRegressSWName = 'VAL'; + kRegressSWVers = kRegressSWName+' v1.0'; + kMaxFactors = 1; + gVALChanges: boolean = false; + gDesignUnspecified : boolean = true; + gEnterCell : boolean= false; + gVALFontSize: integer = 8; + kMagicDouble : double = -111666222; + //kVALNativeSignature = 'abba'; + //kTxtExt = '.txt'; + //kVALNativeExt = '.val'; +implementation +uses statcr,hdr; + +{$IFNDEF FPC} + +{$R *.DFM} +{$ENDIF} +function TSpreadForm.SOpenDialogExecute (lCaption: string;lAllowMultiSelect,lForceMultiSelect: boolean; lFilter: string): boolean;//; lAllowMultiSelect: boolean): boolean; +var + lNumberofFiles: integer; +begin + OpenDialog1.Filter := lFilter;//kAnaHdrFilter;//lFilter; + OpenDialog1.FilterIndex := 1; + OpenDialog1.Title := lCaption; + if lAllowMultiSelect then + OpenDialog1.Options := [ofAllowMultiSelect,ofFileMustExist] + else + OpenDialog1.Options := [ofFileMustExist]; + result := OpenDialog1.Execute; + if not result then exit; + if lForceMultiSelect then begin + lNumberofFiles:= OpenDialog1.Files.Count; + if lNumberofFiles < 2 then begin + Showmessage('Error: This function is designed to overlay MULTIPLE images. You selected less than two images.'); + result := false; + end; + end; +end; +(*procedure TSpreadForm.WMDropFiles(var Msg: TWMDropFiles); +var + lStr: string; + CFileName: array[0..MAX_PATH] of Char; +begin + try + if DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH) > 0 then //requires ShellAPI in 'uses' clause + begin + if gChanges then begin + if not CheckSave2Close(true) then exit; + end; + lStr := CFilename; + OpenTextFile(lStr); + OpenDialog1.FileName := lStr; + Msg.Result := 0; + end; + finally + DragFinish(Msg.Drop); + end; +end; *) + +procedure TSpreadForm.Quit1Click(Sender: TObject); +begin + if not CheckSave2Close(true) then exit; + gVALChanges := false; + SpreadForm.Close; +end; + + + +procedure TSpreadForm.FormResize(Sender: TObject); +var lClient,lWid,lCount: integer; +begin + lCount := DataGrid.ColCount; + lClient := DataGrid.ClientWidth; + if lCount < 1 then begin + DataGrid.ColWidths[0] := lClient; + exit; + end; + lWid := ((lClient) div lCount); + DataGrid.DefaultColWidth := lWid-1; + (*if lWid <> lCol1Wid then begin + lCol1Wid := (lClient-((lCount) * lWid))-lCount{-14}; + lGrid.ColWidths[0] := lCol1Wid; + end;*) +end; + +function ColLabel (lCol: integer): string; //first column= A, 26th=Z,27th AA, etc... +var lColDiv,lColMod: integer; +begin + result := ''; + lColDiv := lCol; + repeat + lColMod := lColDiv mod 26; + if lColMod = 0 then lColMod := 26; + result := chr(ord('A')+lColMod-1)+result; + {if lColDiv = 26 then + lColDiv := 0 + else} + lColDiv := (lColDiv-1) div 26; + until lColDiv <= 0; +end; + +procedure UpdateGridLabels(lGrid: TStringGrid); +var + lA,lInc,lInc2: integer; +begin + if lGrid.RowCount < 2 then exit; + //for lInc := (lGrid.RowCount -1) downto 1 do + // lGrid.Cells[0,kMaxFactors+lInc] := inttostr(lInc); + if (lGrid.ColCount) < 1 then exit; + + //Next enter ANOVA labels for each row + for lInc := (lGrid.ColCount-1 {-1 for Lazarus 999}) downto 0 do + for lInc2 := 0 to kMaxFactors do + lGrid.Cells[lInc,lInc2] := ''; + lA := DesignForm.AVal.value; +//999 showmessage(inttostr(lGrid.RowCount)+'x'+inttostr(lGrid.ColCount)+'alpha'+inttostr(lA)); + //lGrid.Cells[0,0] := ''; + for lInc := 1 to lA do + lGrid.Cells[lInc,0] := DesignForm.ALevelNames.Cells[lInc-1,0]; +{$IFDEF FPC} + for lInc := (lGrid.ColCount -2) downto 0 do + lGrid.Cells[lInc +1 ,kMaxFactors] := ColLabel(lInc+1); +{$ELSE} + for lInc := (lGrid.ColCount -1) downto 0 do + lGrid.Cells[lInc+1,kMaxFactors] := ColLabel(lInc+1);//chr(ord('A')+lInc); +{$ENDIF} + +end; + +procedure TSpreadForm.UpdateLabels; +begin + DataGrid.ColCount := DesignForm.AVal.value+1; //2007 For FPC + UpdateGridLabels(DataGrid); + DataGrid.ColCount := DesignForm.AVal.value+1; +end; + +procedure TSpreadForm.Aboutthissoftware1Click(Sender: TObject); +begin + Showmessage(kRegressSWVers); // AboutForm.Showmodal; +end; + + +procedure ClearDesignMatrix; +begin + + gDesignUnspecified := true; + SpreadForm.DesignBtn.Caption := 'Design: not specified'; +end; + +procedure DesignBtnLabelUpdate; +begin + SpreadForm.DesignBtn.Caption := 'Design IVs: '+inttostr(DesignForm.AVal.Value) ; + SpreadForm.UpdateLabels; + SpreadForm.FormResize(nil); +end; + +{$ifdef fpc} +function alignx(addr : Pointer;alignment : PtrUInt) : Pointer; +begin + + result:=align(addr,alignment); +end; +{$endif} + +procedure TSpreadForm.OpenTextFile (var lFilename:string); +var lTemplateName:string; + lnCritPct,lnRow,lnCol,lnColWObs,lCol,lRow: integer; + //lLesionCovary : boolean; + lPredictorList,lFileList:TStringList; + lDoublePtr: Pointer; + lDoubleBuf : DoubleP; +begin + Self.Caption := kRegressSWVers+': '+extractfilename(lFilename); + ClearDesignMatrix; + lPredictorList := TStringList.Create; + lFileList := TStringList.Create; + gVALChanges := false; + OpenValFile (lFilename,lTemplateName, lnRow,lnCol,lnColWObs,lnCritPct,gDesignUnspecified,lPredictorList,lFileList,lDoublePtr); + {$IFDEF FPC} + DataGrid.RowCount := kMaxFactors+lnRow{-1}; + {$ELSE} + DataGrid.RowCount := kMaxFactors+lnRow; + {$ENDIF} + DataGrid.ColCount := lnCol+1; + DataGrid.refresh; + {$IFDEF FPC} + lDoubleBuf := alignx(lDoublePtr, 16); // note: lDoubleBuf > lDoublePtr always (VSDS); + {$ELSE} + lDoubleBuf := DoubleP($fffffff0 and (integer(lDoublePtr)+15)); + {$ENDIF} + if lFileList.Count < lnRow then + lnRow := lFileList.Count; + for lRow := 1 to lnRow do begin + + DataGrid.Cells[ 0, kMaxFactors+lRow ] := lFileList.Strings[lRow-1]; + for lCol := 1 to lnCol do begin + if lDoubleBuf^[RowColPos (lRow,lCol,lnColWObs)] = kMagicDouble then + DataGrid.Cells[ lCol, kMaxFactors+lRow ] := '' + else + DataGrid.Cells[ lCol, kMaxFactors+lRow ] := floattostr((lDoubleBuf^[RowColPos (lRow,lCol,lnColWObs)])); + end; + + end; + +if lPredictorList.Count < lnRow then + for lCol := (lPredictorList.Count+1) to lnRow do + lPredictorList.Add( 'Pred'+inttostr(lCol) ); + DesignForm.ALevelNames.ColCount := lnCol; + for lCol := 1 to lnCol do + DesignForm.ALevelNames.Cells[lCol-1,0] := lPredictorList.Strings[lCol-1]; + Freemem(lDoublePtr); + lPredictorList.Free; + lFileList.free; + //DesignForm.LesionCovaryCheck.Checked := lLesionCovary; + DesignForm.CritPctEdit.value := lnCritPct; + DesignForm.TemplateLabel.Caption := lTemplateName; + //Tidy Up... + DesignForm.AVal.Value := lnCol; + UpdateLabels; + + DesignBtnLabelUpdate; + + FormResize(nil); + if gDesignUnspecified then + Showmessage('You need to define the experiment design [press the ''Design'' button]'); + +end; + +procedure TSpreadForm.OpenBtnClick(Sender: TObject); +var lFileName: string; +begin + if gVALChanges then begin + if not CheckSave2Close(true) then exit; + end; + if not SOpenDialogExecute('Select VAL design file',false,false, kValFilter) then exit; + lFilename := OpenDialog1.filename; + if not fileexists(lFilename) then exit; + OpenTextFile(lFilename); +end; + +procedure GridToStatusBar(lGrid: TStringGrid; lStatus: TStatusBar); +begin +{$IFDEF FPC} + //SpreadForm.StatusBar1.Panels[1].Text := inttostr(random(888)); + if (lGrid.Selection.Top <= kMaxFactors) or (lGrid.Selection.Left <= 0) then begin + lGrid.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + SpreadForm.Caption := ''; + exit; + end; + if lGrid.Selection.Top < 0 then exit; + if((lGrid.Selection.Top = lGrid.Selection.Bottom ) and ( lGrid.Selection.Left = lGrid.Selection.Right )) then begin + SpreadForm.Caption := + lGrid.Cells[0,lGrid.Selection.Top]+' = '+lGrid.Cells[lGrid.Selection.Left,lGrid.Selection.Top]+' '+ + lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+inttostr(lGrid.Selection.Top-kMaxFactors); + end else begin + SpreadForm.Caption := inttostr(lGrid.Selection.Bottom-lGrid.Selection.Top + 1)+'R x '+ inttostr(lGrid.Selection.Right-lGrid.Selection.Left + 1)+'C'; + end; + + (*if((lGrid.Selection.Top <> lGrid.Selection.Bottom ) or ( lGrid.Selection.Left <> lGrid.Selection.Right )) then exit; + + if (lGrid.Selection.Top <= kMaxFactors) or (lGrid.Selection.Left <= 0) then begin + lGrid.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + lStatus.Panels[0].Text := ''; + exit; + end; + if (lGrid.Selection.Top < 0) then exit; + + //lStatus.Panels[1].Text := inttostr(lGrid.Selection.Bottom-lGrid.Selection.Top + 1)+'R x '+ inttostr(lGrid.Selection.Right-lGrid.Selection.Left + 1)+'C'; + //lStatus.Panels[1].Text := inttostr(lGrid.Selection.Top)+'R x '+ inttostr(lGrid.Selection.Bottom)+'C'; + SpreadForm.Caption := inttostr(lGrid.Selection.Top)+'R x '+ inttostr(lGrid.Selection.Left)+'C'; + exit; + if((lGrid.Selection.Top = lGrid.Selection.Bottom ) and ( lGrid.Selection.Left = lGrid.Selection.Right )) then begin + lStatus.Panels[1].Text := {ColLabel(lGrid.Selection.Left)+}lGrid.Cells[0,lGrid.Selection.Top]{inttostr(lGrid.Selection.Top-kMaxFactors)}+' = '+lGrid.Cells[lGrid.Selection.Left,lGrid.Selection.Top]; +// lStatus.Panels[0].Text := lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+' '+lGrid.Cells[lGrid.Selection.Left,2]; +// lStatus.Panels[0].Text := lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+inttostr(lGrid.Selection.Top-kMaxFactors); + //lStatus.Panels[0].Text := lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+inttostr(lGrid.Selection.Top-kMaxFactors); + + end else begin + lStatus.Panels[0].Text := inttostr(lGrid.Selection.Bottom-lGrid.Selection.Top + 1)+'R x '+ inttostr(lGrid.Selection.Right-lGrid.Selection.Left + 1)+'C'; + lStatus.Panels[1].Text := ''; + end; *) +{$ELSE} //Delphi + if (lGrid.Selection.Top <= kMaxFactors) or (lGrid.Selection.Left <= 0) then begin + lGrid.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + lStatus.Panels[0].Text := ''; + exit; + end; + if lGrid.Selection.Top < 0 then exit; + if((lGrid.Selection.Top = lGrid.Selection.Bottom ) and ( lGrid.Selection.Left = lGrid.Selection.Right )) then begin + lStatus.Panels[1].Text := lGrid.Cells[0,lGrid.Selection.Top]+' = '+lGrid.Cells[lGrid.Selection.Left,lGrid.Selection.Top]; + lStatus.Panels[0].Text := lGrid.Cells[lGrid.Selection.Left,0]+' '+ lGrid.Cells[lGrid.Selection.Left,1]+inttostr(lGrid.Selection.Top-kMaxFactors); + end else begin + lStatus.Panels[0].Text := inttostr(lGrid.Selection.Bottom-lGrid.Selection.Top + 1)+'R x '+ inttostr(lGrid.Selection.Right-lGrid.Selection.Left + 1)+'C'; + lStatus.Panels[1].Text := ''; + end; +{$ENDIF} + +end; + +procedure TSpreadForm.ShowStatus; +begin +//SpreadForm.Caption := inttostr(random(888)); + GridToStatusBar(DataGrid,StatusBar1); +end; + +procedure TSpreadForm.DataGridSelectCell(Sender: TObject; ACol, ARow: Integer; + var CanSelect: Boolean); +begin + //ShowStatus; //bxxx + gEnterCell := true; +end; + +procedure TSpreadForm.NewBtnClick(Sender: TObject); +begin + DesignForm.Showmodal; + gDesignUnspecified := false; + DesignBtnLabelUpdate; +end; + +function RemoveColons( lStr: string): string; +var lLen,lPos: integer; +begin + result := lStr; + lLen := length(lStr); + if lLen < 1 then exit; + for lPos := 1 to lLen do + if result[lPos] = ':' then + result[lPos] := ';'; +end; + +function Str2Float (var lStr: string; var lError: boolean): single; +begin + lError := false; + try + result := Strtofloat(lStr); + except + on EConvertError do + lError := true; + end; //except +end; + +procedure TSpreadForm.Save1Click(var NoCancel: boolean); +const + kNative = 1; + kTxt = 2; +var + f: TextFile; + lFormat,C, R,lLen,lPos,ColStart,ColEnd,RowStart,RowEnd : integer ; + lLevelStr,lFilename,S,lCell,lExt : string ; + kSpacer,lDecimalSep : char; + lError: boolean; +begin + NoCancel := false; + if not SaveDialog1.Execute then exit; + lFormat := SaveDialog1.FilterIndex; + if (lFormat < kNative) or (lFormat > kTxt) then + lFormat := kNative; + case lFormat of + kTxt: lExt := kTXText; + else lExt := kValNativeExt; + end; + if lFormat <> kNative then begin + case MessageDlg( 'Export file as a text format? Note you will lose information about the experiment design [save to Native format to preserve condition information]', mtWarning, [mbYes, mbCancel], 0 ) of + mrCancel : exit ; + end ; + end; //not native + if (lFormat = kNative) and (gDesignUnspecified) then begin + showmessage('Unable to save this data as '+kRegressSWVers+' format file until you have specified the conditions [press the ''Design'' button]'); + exit; + end; + //lExt := StrUpper(PChar(extractfileext(SaveDialog1.Filename))); + lFilename := SaveDialog1.Filename; + lDecimalSep := DecimalSeparator; + DecimalSeparator := '.'; + ChangeFileExt(lFilename,lExt); + // Setup... + kSpacer := #9; //tab + S := '' ; + RowStart := kMaxFactors+1 ; + RowEnd := DataGrid.RowCount - 1; + ColStart := 0 ; + ColEnd := DataGrid.ColCount - 1; + if (ColEnd < ColStart) or (RowEnd < RowStart) then exit; + // Copy to string + for R := RowStart to RowEnd do + begin + for C := ColStart to ColEnd do begin + + lCell := DataGrid.Cells[ C, R ]; + if C <> ColStart then begin + if lCell = '' then //this simply prevents error reports when run from debugger + lError := true + else + Str2Float (lCell, lError); + if (lError) then + lCell := '-'; + end; + S := S + lCell; + if( C < DataGrid.ColCount - 1 ) then + S := S + kSpacer{#9} ; // Tab + end ; + if R <> (DataGrid.RowCount - 1) then //all except last line + S := S + #13#10 ; // End line + end ; + AssignFile(f, lFileName); + rewrite(f); + if lFormat = kNative then begin + Self.Caption := kRegressSWVers+': '+extractfilename(SaveDialog1.Filename);//remove any previous filename + if Files4D(DataGrid.Cells[ ColStart, RowStart ]) then + writeln(f,kVALNativeSignatureBase + '1')//version 1 supports 4D images + else + writeln(f,kVALNativeSignatureBase + '0');//version 0 supports 3D images only + + //Details for 1st factor + //writeln(f,'#Predictors:'+inttostr(lLen)+lLevelStr+lWithinSubjStr); + writeln(f,'#Covary Volume'+kSpacer+bool2char(DesignForm.LesionCovaryCheck.Checked)); + writeln(f,'#Template'+kSpacer+DesignForm.TemplateLabel.Caption); + writeln(f,'#CritPct'+kSpacer+inttostr(DesignForm.CritPctEdit.value)); + lLevelStr := 'ImageName'; + lLen := DesignForm.AVal.value; + if lLen >= 1 then + for lPos := 1 to lLen do + lLevelStr := lLevelStr+kTab+(DesignForm.ALevelNames.Cells[lPos-1,0]); + writeln(f,lLevelStr); + gVALChanges := false; + end; + Writeln(f, S); + Flush(f); { ensures that the text was actually written to file } + CloseFile(f); + NoCancel := true; + DecimalSeparator :=lDecimalSep; +end; + + +procedure registerfiletype(inft,inkey,desc,icon:string); +var myreg : treginifile; + ct : integer; + ft,key: string; +begin + ft := inft; + key := inkey; + ct := pos('.',ft); + while ct > 0 do begin + delete(ft,ct,1); + ct := pos('.',ft); + end; + if (ft = '') or (Application.ExeName = '') then exit; //not a valid file-ext or ass. app + ft := '.'+ft; + myreg := treginifile.create(''); + try + myreg.rootkey := hkey_classes_root; // where all file-types are described + if key = '' then key := copy(ft,2,maxint)+'_auto_file'; // if no key-name is given, create one + myreg.writestring(ft,'',key); // set a pointer to the description-key + myreg.writestring(key,'',desc); // write the description + myreg.writestring(key+'\DefaultIcon','',icon); // write the def-icon if given + myreg.writestring(key+'\shell\open\command','',Application.ExeName+' %1'); //association + finally + myreg.free; + end; +end; + +procedure TSpreadForm.FormCreate(Sender: TObject); +begin + SpreadForm.Caption := kRegressSWName; +(* registerfiletype(kNativeExt,kRegressSWName{key},kRegressSWName,Application.ExeName+',1'); + DragAcceptFiles(Handle, True); *) + DataGrid.Selection:=TGridRect(Rect(-1,-1,-1,-1)); + gVALFontSize := 8; + //DecSeparator := DecimalSeparator; + //l64rBufP := nil; + gEnterCell := false; + gVALChanges := false; + DataGrid.ColCount := 9; + DataGrid.RowCount := 15; + FormResize(nil); + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + +New1.ShortCut := ShortCut(Word('N'), [ssMeta]); + Open1.ShortCut := ShortCut(Word('O'), [ssMeta]); + Save1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Quit1.ShortCut := ShortCut(Word('W'), [ssMeta]); + Copy1.ShortCut := ShortCut(Word('C'), [ssMeta]); + Paste1.ShortCut := ShortCut(Word('V'), [ssMeta]); + Selectall1.ShortCut := ShortCut(Word('A'), [ssMeta]); + DescriptiveMenu.ShortCut := ShortCut(Word('L'), [ssMeta]); + + {$ENDIF}//Carbon + {$ENDIF}//Darwin +end; + +procedure TSpreadForm.DataGridMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var C, R : integer ; + Rect : TGridRect ; + +begin + + DataGrid.MouseToCell( X, Y, C, R ) ; + Rect.Left := C ; + Rect.Right := C ; + Rect.Top := R ; + Rect.Bottom := R ; + DataGrid.Selection := Rect ; +end; + +procedure TSpreadForm.DataGridKeyPress(Sender: TObject; var Key: Char); +var S : string ; + +begin + if (Key in ['0'..'9','.',kBS,kDel,kCR]) or ((Key='-') and (gEnterCell)) then + else + exit; + if(( DataGrid.Selection.Top = DataGrid.Selection.Bottom ) and + ( DataGrid.Selection.Left = DataGrid.Selection.Right )) then begin + gVALChanges := true; + if gEnterCell then begin + S := '' + end else + S := DataGrid.Cells[ DataGrid.Selection.Left,DataGrid.Selection.Top ] ; + gEnterCell := false; + if ( ( Key = kDEL ) or ( Key = kBS ) )then + begin + if( length( S ) > 0 ) then + begin + setlength( S, length( S ) - 1 ) ; + end ; + end else + if ( Key = kCR ) then + begin + //Edit_Box.Text := S ; + exit ; + end else + begin + S := S + Key ; + end ; + DataGrid.Cells[ DataGrid.Selection.Left, DataGrid.Selection.Top ] := S ; + //Format_Grid.Cells[ DataGrid.Selection.Left, DataGrid.Selection.Top ] := '' ; + end ; +end; + +procedure TSpreadForm.Copy1Click(Sender: TObject); +var C, R : integer ; + P: PChar; + S : string ; + RStart,CStart,REnd,CEnd : integer ; +begin + // Setup... + S := '' ; + if (DataGrid.Selection.Left < 0) or (DataGrid.Selection.Top < 0) then begin + DataGrid.Selection:= TGridRect(Rect(1,1+kMaxFactors,DataGrid.ColCount-1,DataGrid.RowCount-1)); + end; + CStart := DataGrid.Selection.Left; + CEnd := DataGrid.Selection.Right; + RStart := DataGrid.Selection.Top; + REnd := DataGrid.Selection.Bottom; + // Copy to string + for R := RStart to REnd do + begin + for C := CStart to CEnd do + begin + S := S + DataGrid.Cells[ C, R ] ; + if( C < CEnd ) then begin + S := S + #9 ; // Tab + end ; + end ; + S := S + #13#10 ; // End line + end ; + // Set clipboard + {$IFNDEF FPC} + Clipboard.SetTextBuf( PChar( S ) ) ; +{$ELSE} + p:=StrAlloc (length(S)+1); + if StrPCopy (P,S)=P then + Clipboard.SetTextBuf(P); + +{$ENDIF} +end; + +procedure TSpreadForm.Paste1Click(Sender: TObject); +const + BS = #8 ; { Backspace } + CR = #13 ; { Carriage return } + DEL = #127 ; { Delete } + //HT = #9 ; { Horizontal Tab } + //LF = #10 ; { Line Feed } + //VT = #11 ; { Vertical Tab } +var StartC,C, R,I : integer ; + Dummy : integer ; + lSciNotation,EOF: boolean; + lValue: double; + DecSeparator : char; + Line, S, Work,WorkFilter : string ; +begin + // Setup... + DecSeparator := DecimalSeparator; + S := Clipboard.AsText ; + EOF:= false; + if (DataGrid.Selection.Left < 0) or (DataGrid.Selection.Top < 0) then begin + Selectall1Click(nil); + end; + //gChanges := true; + StartC := DataGrid.Selection.Left; + R := DataGrid.Selection.Top; + C := StartC; + while( length( S ) > 0 ) do begin + // Extract next line... + {$IFDEF UNIX} + Dummy := pos( #13, S + #13 ) ; + {$ELSE} + Dummy := pos( #13#10, S + #13#10 ) ; + {$ENDIF} + Line := copy( S, 1, Dummy - 1 ) ; + if (Dummy+1) < length(S) then //last line may not have eol + S := copy( S, Dummy + 1, length( S ) ) + else + EOF := true; + while( length( Line ) > 0 ) do begin + // Extract next cell... + lSciNotation := false; + Dummy := pos( #9, Line + #9 ) ; + Work := copy( Line, 1, Dummy - 1 ) ; + Line := copy( Line, Dummy + 1, length( S ) ) ; + WorkFilter := ''; + if length(Work) > 0 then begin + for I := length(Work) downto 1 do begin + if (Work[i] in ['-','0'..'9','E','e',DecSeparator,BS,DEL,CR]) then + WorkFilter := Work[i]+WorkFilter; + if (Work[i] in ['E','e']) then + lSciNotation := true; + end; + end; + if lSciNotation then begin + try + lValue := strtofloat(Workfilter); + except + on EConvertError do + lValue := NaN + else + lValue := NaN; + end; //try..except + if lValue <> NaN then + DataGrid.Cells[ C, R ] :=(floattostr(lValue)); + end else if(length(WorkFilter) > 0) and ( C < DataGrid.ColCount ) then begin + DataGrid.Cells[ C, R ] := WorkFilter ; + //Format_Grid.Cells[ C, R ] := '' ; + end ; + inc( C ) ; + end ; + inc( R ) ; // Move to next row + if( R >= DataGrid.RowCount ) or (EOF) then begin + break ; // All done with paste + end ; + C := StartC; + end ; // While length(S) > 0 +end; //proc Paste1Click +(*var StartC,C, R,I : integer ; + Dummy : integer ; + lSciNotation,EOF,lData: boolean; + lValue: double; + Line, S, Work,WorkFilter : string ; +begin + // Setup... + lValue := 0; //only to prevent compiler warning... + S := Clipboard.AsText ; + EOF:= false; + if (DataGrid.Selection.Left < 0) or (DataGrid.Selection.Top < 0) then begin + Selectall1Click(nil); + end; + //R := 1 ; + //StartC := 1 ; + StartC := DataGrid.Selection.Left; + //CEnd := DataGrid.Selection.Right; + R := DataGrid.Selection.Top; + //REnd := DataGrid.Selection.Bottom; + // Do the paste + C := StartC; + while( length( S ) > 0 ) do begin + // Extract next line... + Dummy := pos( #13#10, S + #13#10 ) ; + Line := copy( S, 1, Dummy - 1 ) ; + if (Dummy+1) < length(S) then //last line may not have eol + S := copy( S, Dummy + 1, length( S ) ) + else + EOF := true; + //showmessage(inttostr(C)+'x'+Line); + while( length( Line ) > 0 ) do begin + // Extract next cell... + lSciNotation := false; + //old + //Dummy := pos( #9, Line + #9 ) ; + //new - comma separated, etc + lData := false; + Dummy := length(line)+1; + I := 1; + repeat + if (Line[i] in ['-','0'..'9','E','e']) then + lData := true + else begin + if lData then Dummy := I; + end; + inc(I); + until (I > length(Line)) or (Dummy = (I-1)); + //end new + + Work := copy( Line, 1, Dummy - 1 ); + //showmessage(inttostr(Dummy)+'x'+Work); + + Line := copy( Line, Dummy + 1, length( S ) ) ; + //showmessage(Line); + WorkFilter := ''; + if length(Work) > 0 then begin + for I := length(Work) downto 1 do begin + if (Work[i] in ['-','0'..'9','E','e','.',kBS,kDEL,kCR]) then + WorkFilter := Work[i]+WorkFilter; + if (Work[i] in ['E','e']) then + lSciNotation := true; + end; + end; + if lSciNotation then begin + try + lValue := strtofloat(Workfilter); + except + on EConvertError do + lValue := NaN; + end; //try..except + if lValue <> NaN then + DataGrid.Cells[ C, R ] :=(floattostr(lValue)); + end else if(length(WorkFilter) > 0) and ( C < DataGrid.ColCount ) then begin + DataGrid.Cells[ C, R ] := WorkFilter ; + //Format_Grid.Cells[ C, R ] := '' ; + end ; + inc( C ) ; + end ; + inc( R ) ; // Move to next row + if( R >= DataGrid.RowCount ) or (EOF) then begin + break ; // All done with paste + end ; + //Showmessage(inttostr(StartC)); + C := StartC; + end ; // TMainForm.Paste1Click +end; *) + + +procedure TSpreadForm.SaveBtnClick(Sender: TObject); +var + b: boolean; +begin + Save1Click(b); +end; + +function TSpreadForm.CheckSave2Close (lAllowCancel: boolean): boolean; +begin + result := true; + if not gVALChanges then exit; + result := false; + if lAllowCancel then begin + case MessageDlg( 'Save changes?', mtWarning, [mbYes, mbNo, mbCancel], 0 ) of + mrYes : begin + Save1Click( result ) ; + end ; + mrCancel : exit ; + end ; + end else + case MessageDlg( 'Save changes?', mtWarning, [mbYes, mbNo], 0 ) of + mrYes : begin + Save1Click( result ) ; + end ; + end; + result := true; +end; + +procedure TSpreadForm.ReadCells2Buffer; +var + lDbl: double; + lRend,lRStart,lCStart,lCEnd,lC,lR,lPos: integer; + lStr: string; + l64rBufP: pointer; + l64rBuf: DoubleP; +begin + //if l64rBufP <> nil then + // freemem(l64rBufP); + GetMem(l64rBufP,(DataGrid.ColCount*DataGrid.RowCount*sizeof(double))+16); + {$IFDEF FPC} + l64rBuf := alignx(l64rBufP, 16); + {$ELSE} + l64rBuf := DoubleP((integer(l64rBufP) and $FFFFFFF0)+16); + {$ENDIF} + lRStart := {1}kMaxFactors+1; + lREnd := DataGrid.RowCount - 1; + lCstart := 1; + lCend := DataGrid.ColCount - 1; + //gnCol := lCEnd; + //gnRow := lREnd-lRStart+1; + // Copy to string + lPos := 0; + for lR := lRStart to lREnd do begin + for lC := lCStart to lCEnd do begin + inc(lPos); + lStr := (DataGrid.Cells[ lC, lR ]); + lDbl := NaN; + if length(lStr) > 0 then begin + try + lDbl := Strtofloat(lStr); + except + on EConvertError do begin + showmessage('Cell '+ColLabel(lC)+inttostr(lR-kMaxFactors)+ ': Unable to convert the string '+lStr+' to a number'); + DataGrid.Cells[ lC, lR ] := ''; + lDbl := NaN; //NAN? Not-A-Number + end; //Error + end; //except + end; //length > 0 + l64rBuf^[lPos] :=lDbl; + end ; //for each col + end ; //for each row + freemem(l64rBufP); +end; + +procedure TSpreadForm.Selectall1Click(Sender: TObject); +begin + DataGrid.Selection:= TGridRect(Rect(1,1+kMaxFactors,DataGrid.ColCount-1,DataGrid.RowCount-1)); +end; + +procedure TSpreadForm.FontSizeChange(Sender: TObject); +begin + (sender as TMenuItem).Checked := true; + gVALFontSize := (sender as TMenuItem).tag; + DataGrid.Font.Size := (sender as TMenuItem).tag; + DataGrid.DefaultRowHeight := (sender as TMenuItem).tag+12; + FormResize(nil); +end; + +procedure TSpreadForm.DataGridMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + ShowStatus; +end; + +procedure TSpreadForm.DataGridDrawCell(Sender: TObject; Col, Row: Integer; + Rect: TRect; State: TGridDrawState); +begin + ShowStatus; +end; + +procedure TSpreadForm.Clearallcells1Click(Sender: TObject); +var + lR,lC,lRi,lCi: integer; +begin + lR := DataGrid.RowCount-1; + lC := DataGrid.ColCount-1; + for lRi := 1 to lR do begin + for lCi := 1 to lC do begin + DataGrid.Cells[lCi,kMaxFactors+lRi] := ''; + end;//for cols + end;//for rows +end; + +procedure TSpreadForm.DesignBtnClick(Sender: TObject); +begin + DesignForm.Showmodal; + gDesignUnspecified := false; + DesignBtnLabelUpdate; +end; + +procedure TSpreadForm.AddMRIScansClick(Sender: TObject); +begin +DesignForm.AddMRIBtnClick(nil); +end; + +function TSpreadForm.GetVal (lC,lR: integer; var lVal: double): boolean; +var + lStr: string; + lDbl: double; +begin + result := false; + lVal := 0; + lStr := (DataGrid.Cells[ lC, lR ]); + if lStr = '' then + exit; + try + lDbl := Strtofloat(lStr); + except + on EConvertError do begin + showmessage('Cell '+ColLabel(lC)+inttostr(lR-kMaxFactors)+ ': Unable to convert the string '+lStr+' to a number'); + exit; + end; + end; //try..except + lVal := lDbl; + result := true; +end;//GetVal + +procedure TSpreadForm.DescriptiveClick(Sender: TObject); +var + lMn,lSD,lSE,lSkew,lZSkew: double; + n,lR,lC,lRi,lCi: integer; + lVal: double; + RA: SingleP; +begin + lR := DataGrid.RowCount-1; + if (lR <= kMaxFactors+1) then + exit; + lC := DataGrid.ColCount-1; + Getmem(RA,lR * sizeof(single)); + for lCi := 1 to lC do begin + n := 0; + for lRi := (kMaxFactors+1) to lR do begin + if GetVal (lCi,lRi,lVal) then begin + inc(n); + RA^[n] := lVal; + end; + + end;//for rows + if n > 0 then begin + SuperDescriptive (RA, n, lMn,lSD,lSE,lSkew,lZSkew); + Showmessage('"'+DataGrid.Cells[ lC, 0]+'" mean='+floattostr(lMn)+',StDev='+floattostr(lSD)+',StEr='+floattostr(lSE)+',Skew='+floattostr(lSkew)+',ZSkew='+floattostr(lZSkew)); + + end; //n > 0 + end;//for cols + Freemem(RA); +end; + + +{$IFNDEF FPC} + procedure TSpreadForm.FormClose(Sender: TObject; var Action: TCloseAction); +{$ELSE} + procedure TSpreadForm.FormClose(Sender: TObject); +{$ENDIF} +begin + CheckSave2Close(false); +end; + + + +{$IFDEF FPC} +initialization + {$I spread.lrs} +{$ENDIF} + +end. \ No newline at end of file diff --git a/npm_precl/statcr.pas b/npm_precl/statcr.pas new file mode 100755 index 0000000..bb5b52a --- /dev/null +++ b/npm_precl/statcr.pas @@ -0,0 +1,631 @@ +Unit statcr; +interface +uses Dialogs,define_types; + +const + ITMAX = 300; + EPS = 3.0e-7; + kMaxFact = 1700; {<= 1754} + gFactRAready : boolean = false; +type + FactRA = array[0..kMaxFact] of extended; +var + gFactRA : FactRA; +FUNCTION betai(a,b,x: double): double; +procedure AlertMsg (pWarningStr: String); +function gammq( a,x: real): real; +function Fisher (A,B,C,D: integer): double; +procedure Chi2x2 (A, B, C, D: integer; var pMinExp, pChi, p, puChi, pup: double); +function Liebermeister (A,B,C,D: integer): extended; +procedure EstimateFDR(lnTests: integer; Ps: SingleP; var lFDR05, lFDR01: double); +function Fisher1TailMidP (A,B,C,D: integer): double; { use instead of chi2x2: returns p-value} +procedure InitFact; +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +procedure Descriptive (nV, SumOfSqrs, Sum: double; var lMn,lSD,lSE: double); +procedure SuperDescriptive (var RA: SingleP; n: integer; var lMn,lSD,lSE,lSkew,lZSkew: double); + +implementation +uses Math{power}; +procedure Descriptive (nV, SumOfSqrs, Sum: double; var lMn,lSD,lSE: double); +//given nV,SumOfSqrs,and Sum, returns Mean, StandardDeviation,StandardError and Skew +begin + //first: initialize values + lSD := 0; + lSE := 0; + lMn := 0; + if nV < 1 then + exit; + //next: compute mean + lMn := Sum / nV; + if (nV < 2) then + exit; + lSD := SumOfSqrs-(Sum*Sum/nV); + lSD := sqrt((lSD)/(nV-1) ); + lSE := lSD/ sqrt(nV); +end; + +procedure SuperDescriptive (var RA: SingleP; n: integer; var lMn,lSD,lSE,lSkew,lZSkew: double); +var + i: integer; + SumOfSqrs,Sum,Sigma: double; +begin + lMn:= 0; + lSD := 0; + lSE := 0; + lSkew := 0; + lZSkew := 0; + if n < 1 then exit; + Sum := 0; + SumOfSqrs := 0; + for i := 1 to n do begin + Sum := Sum + RA^[i]; + SumOfSqrs := SumOfSqrs + sqr(RA^[i]); + end; + Descriptive (n, SumOfSqrs, Sum,lMn,lSD,lSE); + if (n < 3) or (lSD = 0) then + lSkew := 0 + else begin + Sigma := 0; + for i := 1 to n do + Sigma := Sigma + Power( ((RA^[i]-lMn) / lSD) ,3); + lSkew := (n/ ( (n-1)*(n-2) ) ) * Sigma; + end; + lZSkew := lSkew/(sqrt(6/N)); +end; + +procedure InitFact; +var lX: word; +begin + gFactRA[0]:= 1; + gFactRA[1] := 1; + for lx := 2 to kMaxFact do + gFactRA[lx] := lx * gFactRA[lx-1]; + gFactRAready := true; +end; + +function FisherX (A,B,C,D: integer): double; {FisherExactTest, use instead of chi} +{FisherX computes odds for this specific config only, not more extreme cases} +{alternate to Chi Square, see Siegel & Castellan, Nonparametric Statistics} +{use instead of Chi when n <= 20} +{A= X hits, B= control hits, C = X misses, D = control misses} +var + N: word; +begin + N := A+B+C+D; + if (N <= kMaxFact) and (A>=0) and (B>=0) and (C>=0) and (D>=0) and (N > 0) then begin + FisherX := ( + (gFactRA[A+B]/gFactRA[A])* + (gFactRA[B+D]/gFactRA[B])* + (gFactRA[A+C]/gFactRA[C])* + (gFactRA[C+D]/gFactRA[D]) + )/ gFactRA[N]; + end else FisherX := 0; +end; +function MidPKingFisher (lSmal,lCross1,lCross2,lSmalDiag: integer): extended; +var + lProb1, lProb2: extended; + lA,lB,lC,lD,lCnt: integer; + l1st : boolean; +begin + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb1:=0; + l1st := true; //set to true for midP + for lCnt := lA downto 0 do begin + if l1st then + lProb1 := 0.5* FisherX(lA,lB,lC,lD) + else + lProb1 := lProb1 + FisherX(lA,lB,lC,lD); + l1st := false; + dec(lA); + dec(lD); + inc(lB); + inc(lC); + end; + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb2:=0; + l1st := true; //alfa -set to true for MidP + while (lB >= 0) and (lC >= 0) do begin + if l1st then + lProb2 := 0.5* FisherX(lA,lB,lC,lD) + else + lProb2 := lProb2 + FisherX(lA,lB,lC,lD); + l1st := false; + inc(lA); + inc(lD); + dec(lB); + dec(lC); + end; + if lProb1 < lProb2 then + result := lProb1 + else + result := lProb2; + //result := lprob1; +end; + +function KingFisher (lSmal,lCross1,lCross2,lSmalDiag: integer): double; +var + lProb1, lProb2: double; + lA,lB,lC,lD,lCnt: integer; + +begin + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb1:=0; + for lCnt := lA downto 0 do begin + lProb1 := lProb1 + FisherX(lA,lB,lC,lD); + dec(lA); + dec(lD); + inc(lB); + inc(lC); + end; + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb2:=0; + while (lB >= 0) and (lC >= 0) do begin + lProb2 := lProb2 + FisherX(lA,lB,lC,lD); + inc(lA); + inc(lD); + dec(lB); + dec(lC); + end; + if lProb1 < lProb2 then + result := lProb1 + else + result := lProb2; +end; + +function Lieber (lSmal,lCross1,lCross2,lSmalDiag: integer): extended; +var + lA,lB,lC,lD,lCnt: integer; +begin + lA :=lSmal; + lB:=lCross1+1; + lC:=lCross2+1; + lD:=lSmalDiag; + result :=0; + for lCnt := lA downto 0 do begin + result := result + FisherX(lA,lB,lC,lD); + dec(lA); + dec(lD); + inc(lB); + inc(lC); + end; + //TabbedNotebookDlg.caption := realtostr(result,6) ; + //TabbedNotebookDlg.caption := realtostr(result,6) ; + if result <= 0.5 then + exit; + + lA :=lSmal+1; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag+1; + result:=0; + while (lB >= 0) and (lC >= 0) do begin + result := result + FisherX(lA,lB,lC,lD); + inc(lA); + inc(lD); + dec(lB); + dec(lC); + end; +end; + +function Liebermeister (A,B,C,D: integer): extended; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + result := 1; + if (A+B+C+D)<1 then + exit; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=Lieber(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=Lieber(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=Lieber(C,D,A,B) + else {d smallest} + result :=Lieber(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end; + +(*function Liebermeister (Ain,Bin,Cin,Din: integer): extended; +var + A,B,C,D: integer; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + A := Ain; + B := Bin; + C := Cin; + D := Din; + if (A+B+C+D)<1 then begin + result := 1; + exit; + end; + //easy way to calculate Lieberman - make more extreme, then calculate Fisher + if abs(A-D) > abs(B-C) then begin + inc(A); + inc(D); + end else begin + inc(B); + inc(C); + end; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=KingFisher(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=KingFisher(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=KingFisher(C,D,A,B) + else {d smallest} + result :=KingFisher(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end;*) +function Fisher (A,B,C,D: integer): double; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + if (A+B+C+D)<1 then begin + result := 1; + exit + end; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=KingFisher(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=KingFisher(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=KingFisher(C,D,A,B) + else {d smallest} + result :=KingFisher(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end; + + +function Fisher1TailMidP (A,B,C,D: integer): double; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + if (A+B+C+D)<1 then begin + result := 1; + exit + end; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=MidPKingFisher(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=MidPKingFisher(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=MidPKingFisher(C,D,A,B) + else {d smallest} + result :=MidPKingFisher(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end; + +procedure Sort (first, last: integer; var DynDataRA:SingleP); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 1 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + i := i - m; + if (i >= 1) then + goto 555; + end + end + end +end;//sort + +procedure EstimateFDR(lnTests: integer; Ps: SingleP; var lFDR05, lFDR01: double); +var + lInc: integer; + Qs: SingleP; +begin + //rank Pvalues + Sort(1,lnTests,Ps); + {lStr := 'sort='; + for lInc := 1 to knTests do + lStr := lStr+realtostr(Ps[lInc],4)+','; + Memo1.Lines.Add(lStr); } + GetMem(Qs,lnTests*sizeof(single)); + //next findcrit FDR05 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lFDR05 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR05 := Ps^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lFDR01 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR01 := Ps^[lInc]; + Freemem(Qs); +end; + +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +var + lInc: integer; + lrPs,Qs: SingleP; +begin + //rank Pvalues + Sort(1,lnTests,Ps); + {lStr := 'sort='; + for lInc := 1 to knTests do + lStr := lStr+realtostr(Ps[lInc],4)+','; + Memo1.Lines.Add(lStr); } + GetMem(Qs,lnTests*sizeof(single)); + //next findcrit FDR05 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lFDR05 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR05 := Ps^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lFDR01 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR01 := Ps^[lInc]; + + //reverse + GetMem(lrPs,lnTests*sizeof(single)); + for lInc := 1 to lnTests do + lrPs^[lInc] := 1- Ps^[lnTests-lInc+1]; + //for lInc := 1 to lnTests do + // Ps[lInc] := lR[lnTests-lInc+1]; + + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lnegFDR05 := 0; + for lInc := 1 to lnTests do + if lrPs^[lInc] <= Qs^[lInc] then + lnegFDR05 := lrPs^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lnegFDR01 := 0; + for lInc := 1 to lnTests do + if lrPs^[lInc] <= Qs^[lInc] then + lnegFDR01 := lrPs^[lInc]; + FreeMem(lrPs); + Freemem(Qs); +end; + + +procedure AlertMsg (pWarningStr: String); +begin + MessageDLG(pWarningStr, mtWarning,[mbOK],0); +end; + +function gammln (xx: double): double; {Numerical Recipes for Pascal, p 177} + const + stp = 2.50662827465; + var + x, tmp, ser: double; +begin + x := xx - 1.0; + tmp := x + 5.5; + tmp := (x + 0.5) * ln(tmp) - tmp; + ser := 1.0 + 76.18009173 / (x + 1.0) - 86.50532033 / + (x + 2.0) + 24.01409822 / (x + 3.0) - 1.231739516 / (x + 4.0) + 0.120858003e-2 / (x + 5.0) - 0.536382e-5 / (x + 6.0); + gammln := tmp + ln(stp * ser) +end; {procedure gammln} + +FUNCTION betacf(a,b,x: double): double; +LABEL 1; +CONST + itmax=100; + eps=3.0e-7; +VAR + tem,qap,qam,qab,em,d: double; + bz,bpp,bp,bm,az,app: double; + am,aold,ap: double; + m: integer; +BEGIN + am := 1.0; + bm := 1.0; + az := 1.0; + qab := a+b; + qap := a+1.0; + qam := a-1.0; + bz := 1.0-qab*x/qap; + FOR m := 1 TO itmax DO BEGIN + em := m; + tem := em+em; + d := em*(b-m)*x/((qam+tem)*(a+tem)); + ap := az+d*am; + bp := bz+d*bm; + d := -(a+em)*(qab+em)*x/((a+tem)*(qap+tem)); + app := ap+d*az; + bpp := bp+d*bz; + aold := az; + am := ap/bpp; + bm := bp/bpp; + az := app/bpp; + bz := 1.0; + IF ((abs(az-aold)) < (eps*abs(az))) THEN GOTO 1 + END; + writeln('pause in BETACF'); + writeln('a or b too big, or itmax too small'); readln; +1: betacf := az +END; + + +FUNCTION betai(a,b,x: double): double; +VAR + bt: double; +BEGIN + IF ((x < 0.0) OR (x > 1.0)) THEN BEGIN + writeln('pause in routine BETAI'); readln + END; + IF ((x = 0.0) OR (x = 1.0)) THEN bt := 0.0 + ELSE bt := exp(gammln(a+b)-gammln(a)-gammln(b) + +a*ln(x)+b*ln(1.0-x)); + IF (x < ((a+1.0)/(a+b+2.0))) THEN + betai := bt*betacf(a,b,x)/a + ELSE betai := 1.0-bt*betacf(b,a,1.0-x)/b +END; + +procedure gser(var gamser, a,x, gln: real); +var n: integer; + sum, del, ap: real; +begin + gln := gammln(a); + if x <= 0.0 then begin + if x < 0.0 then AlertMsg('x less then 0 in routine GSER'); + gamser:= 0.0; + end else begin + ap := a; + sum := 1.0/a; + del := sum; + for n := 1 to ITMAX do begin + ap := ap + 1; + del := del * (x/ap); + sum := sum + del; + if (abs(del) < abs((sum)*EPS) )then begin + gamser := sum * exp(-x+a*ln(x)-gln); + exit; + end; + end; + Alertmsg('GSER error: ITMAX too small for requested a-value'); + end; +end; + +procedure gcf(var gammcf: real; a,x, gln: real); +var n: integer; + gold,fac,b1,b0,a0,g,ana,anf,an,a1: real; +begin + fac := 1.0; + b1 := 1.0; + b0 := 0.0; + a0 := 1.0; + gold := 0.0; + gln := gammln(a); + a1 := x; + for n := 1 to ITMAX do begin + an :=(n); + ana := an - a; + a0 := (a1 + a0*ana)*fac; + b0 := (b1 + b0*ana)*fac; + anf := an * fac; + a1 := x*a0+anf*a1; + b1 := x*b0+anf*b1; + if a1 <> 0 then begin + fac := 1.0/a1; + g := b1*fac; + if (abs((g-gold)/g)<EPS) then begin + gammcf := exp(-x+a*ln(x)-gln)*g; + exit; + end; + gold := g; + end; + end; + Alertmsg('GCF error: ITMAX too small for requested a-value'); +end; + +function gammq( a,x: real): real; + var gamser, gammcf, gln: real; +begin + gammq := 0; + if (x < 0) or (a <= 0.0) then alertmsg('Invalid arguments in routine GAMMQ') + else begin + if (x < (a+1.0)) then begin + gser(gamser,a,x,gln); + gammq := 1.0 - gamser; + end else begin + gcf(gammcf,a,x,gln); + gammq := gammcf; + end; + end; +end; + + +procedure Chi2x2 (A, B, C, D: integer; var pMinExp, pChi, p, puChi, pup: double); + {A= X hits, B= control hits, C = X misses, D = control misses} + var + lA, lB, lC, lD, lN: extended; {AEXp, BExp, CExp, Dexp, } + lSameOdds: boolean; + begin + lA := A; {convert to extended} + lB := B; + lC := C; + lD := D; + ln := lA + lB + lC + lD; + if lN > 0 then begin {avoid divide by 0} + pMinExp := ((lA + lB) * (lA + lC)) / lN; + if (((lA + lB) * (lB + lD)) / lN) < pMinExp then + pMinExp := ((lA + lB) * (lB + lD)) / lN; + if (((lC + lD) * (lA + lC)) / lN) < pMinExp then + pMinExp := ((lC + lD) * (lA + lC)) / lN; + if (((lC + lD) * (lB + lD)) / lN) < pMinExp then + pMinExp := ((lC + lD) * (lB + lD)) / lN; + end else + pMinExp := 0; + lSameOdds := false; + if (lC > 0) and (lD > 0) then begin + if (lA / lC) = (lB / lD) then + lSameOdds := true; + end; + if (lC = 0) and (lD = 0) then + lSameOdds := true; + if ((lA+lC) = 0) or ((lB+lD) = 0) then + lSameOdds := true; + if (lSameOdds = true) then begin + pChi := 0; {same odds} + p := 1.0; + puChi := 0; + pup := 1.0; + end else begin + puChi := ((sqr((lA * lD) - (lB * lC))) * lN) / ((la + lb) * (lc + ld) * (lb + ld) * (la + lc)); + pup := gammq(0.5, 0.5 * puChi); {half df} + pChi := ((sqr(abs((lA * lD) - (lB * lC)) - (0.5 * lN))) * lN) / ((la + lb) * (lc + ld) * (lb + ld) * (la + lc)); + p := gammq(0.5, 0.5 * pChi); + end; + end; + + +END. + diff --git a/npm_precl/stats.pas b/npm_precl/stats.pas new file mode 100755 index 0000000..9a10915 --- /dev/null +++ b/npm_precl/stats.pas @@ -0,0 +1,1010 @@ +unit stats; + + +interface +uses define_types,statcr,DISTR +,SysUtils,Dialogs,ClipBrd; +procedure TStat2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +//procedure TStatAbs (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +procedure PairedTStat (lnSubj: integer; var lIn: DoubleP0; var lOutT: double); +procedure TStatWelch (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +procedure WilcoxonMW2 (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +procedure MeanMedian(lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lMeanFX,lMedianFX: double); +procedure TStat2Z (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +procedure BMTest (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +procedure Liebermeister2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutZ: double); +procedure Liebermeister2b (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lAUC,lOutZ: double); +procedure Liebermeister2bP (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lOutP: double); +//procedure Liebermeister2bPlus (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lAUC, lOutP: double); +//function Aprime (lHit,lFA: double): double; +//function AUC (lHit,lFA: double): double; +//function rocAUC (lHit,lFA: double): double; +function rocAUC (lnYesDeficitYesLesion,lnNoDeficitYesLesion,lnYesDeficitNoLesion,lnNoDeficitNoLesion: integer): double; + +procedure Chi2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutZ: double); + +implementation + +procedure Chi2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutZ: double); +var + lVal: double; + // luChiP: double; + i,lnYesDeficit1,lnYesDeficit0,lnNoDeficit1,lnNoDeficit0, + lnYesDeficit,lnNoDeficit: integer; +begin + lnYesDeficit0 := 0; + lnYesDeficit1 := 0; + lnNoDeficit0 := 0; + lnNoDeficit1 := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit0) + else + inc(lnNoDeficit0); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit1) + else + inc(lnNoDeficit1); + end; //for each sub + lnYesDeficit :=lnYesDeficit0+lnYesDeficit1; + lnNoDeficit := lnNoDeficit0+lnNoDeficit1; + if (lnYesDeficit<1) or (lnNoDeficit<1) then + lOutZ := 0 + else begin + lVal := Fisher(lnYesDeficit0, lnYesDeficit1, lnNoDeficit0, lnNoDeficit1); + if lVal < 0 then + lOutZ := -pNormalInv(abs(lVal)) + else + lOutZ := pNormalInv(lVal) + (*Chi2x2 (lnYesDeficit0, lnYesDeficit1, lnNoDeficit0, lnNoDeficit1,lMinExp,lChi,lChip,luChi, luChiP); + if (lnYesDeficit1/lnYesDeficit) > (lnNoDeficit1/lnNoDeficit) then + lOutZ := -luChi//t = m / d; + else + lOutZ := luChi;//t = m / d; *) + end; //compute chi +end; + +function rocAz (lHit,lFA: double): double; +//see Zhang and Mueller, 2005, Psychometrika 70, 145-154 +var + lH,lF: double; +begin + if (lHit = 1) and (lFA = 0) then begin + result := 1; + exit; + end; + if (lHit = 0) and (lFA = 1) then begin + result := 0; + exit; + end; + + if lHit >= lFA then begin//normal: better than chance + lH := lHit; + lF := lFA; + end else begin //..else worse than chance + lF := lHit; + lH := lFA; + + end; + if (lF <= 0.5) and (0.5 <= lH) then + result := 0.75+ ((lH-lF)*0.25)- lF*(1-lH) + else if (lF <= lH) and (lH < 0.5) then begin + if (4*lH) = 0 then + result := 0.5 + else + result := 0.75+ ((lH-lF)*0.25)- (lF/(4*lH)) + end else if (0.5 < lF) and (lF <= lH) then begin + if (4*(1-lF)) = 0 then + result := 0.5 + else + result := 0.75 + ((lH-lF)*0.25) - ((1-lH)/(4*(1-lF))) + end else + showmessage('error in Zhang and Mueller, 2005 (func rocA)'); + + if lHit < lFA then //worse than chance + result := 1 - result; +end; + +function rocAUC (lnYesDeficitYesLesion,lnNoDeficitYesLesion,lnYesDeficitNoLesion,lnNoDeficitNoLesion: integer): double; +var + lHitRate,lFalseAlarmRate: double; +begin + result := 0.5; + if ((lnYesDeficitYesLesion+lnNoDeficitYesLesion)=0) or ((lnYesDeficitNoLesion+lnNoDeficitNoLesion)=0) then + exit; + lHitRate := lnYesDeficitYesLesion/(lnYesDeficitYesLesion+lnNoDeficitYesLesion); + lFalseAlarmRate := lnYesDeficitNoLesion/(lnYesDeficitNoLesion+lnNoDeficitNoLesion); + result := rocAz(lHitRate,lFalseAlarmRate); +end; + +(*function Aprime (lHit,lFA: double): double; +//see Wickens Elementary Signal Detection, equation 4.11, page 71 +//problem - not symetrical: values less than 0.5 extreme - +// does not deal with lFA > lHit +begin + if (lFA=1) or (lHit = 0) then + result := 0.5 //avoid divide by zero + else + result := 1 - 0.25*( ((1-lHit)/(1-lFA)) + lFA/lHit); +end;*) + +(*function AUC (lHit,lFA: double): double; +var + lNum,lDenom: double; +begin + + if (lHit> lFA) then begin + lNum := (lHit-lFA)*(1+lHit-lFA); + lDenom := 4 * lHit * (1 - lFA); + if lDenom = 0 then + result := 0 + else + result := 0.5+ (lNum/lDenom); + end else begin + lNum := (lFA-lHit)*(1+lFA-lHit); + lDenom := 4 * lFA * (1 - lHit); + if lDenom = 0 then + result := 0 + else + result := 0.5- (lNum/lDenom); + end; +end; *) + +procedure ROCbinomialAUC (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lAUC: double); +//Receiver operating characteristic area under curve for binimial data +//Liebermeister QuasiExact - excellent power +var + i,lnYesDeficit1,lnYesDeficit0,lnNoDeficit1,lnNoDeficit0, + lnYesDeficit,lnNoDeficit: integer; + //lHitRate,lFalseAlarmRate: double; +begin + lnYesDeficit0 := 0; + lnYesDeficit1 := 0; + lnNoDeficit0 := 0; + lnNoDeficit1 := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit0) + else + inc(lnNoDeficit0); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit1) + else + inc(lnNoDeficit1); + end; //for each sub + lAUC := rocAUC (lnYesDeficit1,lnNoDeficit1,lnYesDeficit0,lnNoDeficit0); + (*lHitRate := lnYesDeficit1/(lnYesDeficit1+lnNoDeficit1); + lFalseAlarmRate := lnYesDeficit0/(lnYesDeficit0+lnNoDeficit0); + lAUC := rocA {AUC} (lHitRate,lFalseAlarmRate); *) +end; + +procedure Liebermeister2bP (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lOutP: double); +//Liebermeister QuasiExact - excellent power +var + i,lnYesDeficit1,lnYesDeficit0,lnNoDeficit1,lnNoDeficit0, + lnYesDeficit,lnNoDeficit: integer; + //lMaxChi,lMinChi: single; +begin + lnYesDeficit0 := 0; + lnYesDeficit1 := 0; + lnNoDeficit0 := 0; + lnNoDeficit1 := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit0) + else + inc(lnNoDeficit0); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit1) + else + inc(lnNoDeficit1); + end; //for each sub + lnYesDeficit :=lnYesDeficit0+lnYesDeficit1; + lnNoDeficit := lnNoDeficit0+lnNoDeficit1; + if (lnYesDeficit<1) or (lnNoDeficit<1) then + lOutP := 0 + else begin + lOutP := Liebermeister(lnYesDeficit0, lnYesDeficit1, lnNoDeficit0, lnNoDeficit1); + end; //compute chi +end; + + +procedure Liebermeister2b (lnSubj, lnGroupX: integer; var lIn: ByteP0; var lAUC,lOutZ: double); +//(lnRow,lnCol: integer; var lIn,lOutZ: DoubleP0); +//Liebermeister QuasiExact - excellent power +var + lVal: double; + i,lnYesDeficitNoLesion,lnYesDeficitYesLesion,lnNoDeficitNoLesion,lnNoDeficitYesLesion, + lnYesDeficit,lnNoDeficit: integer; + //lHitRate,lFalseAlarmRate: double; + //lMaxChi,lMinChi: single; +begin + lnYesDeficitYesLesion := 0; + lnYesDeficitNoLesion := 0; + lnNoDeficitYesLesion := 0; + lnNoDeficitNoLesion := 0; + for i := 0 to (lnGroupX-1) do begin //for each lesioned subject + if lIn^[i] = 0 then + inc(lnYesDeficitYesLesion) + else + inc(lnNoDeficitYesLesion); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each unlesioned subject + if lIn^[i] = 0 then + inc(lnYesDeficitNoLesion) + else + inc(lnNoDeficitNoLesion); + end; //for each sub + lnYesDeficit :=lnYesDeficitYesLesion+lnYesDeficitNoLesion; + lnNoDeficit := lnNoDeficitYesLesion+lnNoDeficitNoLesion; + if (lnYesDeficit<1) or (lnNoDeficit<1) then + lOutZ := 0 + else begin + lVal := Liebermeister(lnYesDeficitYesLesion, lnYesDeficitNoLesion, lnNoDeficitYesLesion, lnNoDeficitNoLesion); + if lVal < 0 then + lOutZ := -pNormalInv(abs(lVal)) + else + lOutZ := pNormalInv(lVal) + end; //compute chi + lAUC := rocAUC (lnYesDeficitYesLesion,lnNoDeficitYesLesion,lnYesDeficitNoLesion,lnNoDeficitNoLesion); + {lFalseAlarmRate := lnYesDeficitNoLesion/(lnYesDeficitNoLesion+lnNoDeficitNoLesion); + lHitRate := lnYesDeficitYesLesion/(lnYesDeficitYesLesion+lnNoDeficitYesLesion); + lAUC := rocAz (lHitRate,lFalseAlarmRate); + } + //if lOutZ > 4 then ax(lnYesDeficitYesLesion,lnNoDeficitYesLesion,lnYesDeficitNoLesion,lnNoDeficitNoLesion,lauc,lOutZ); +end; + +procedure Liebermeister2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutZ: double); +//(lnRow,lnCol: integer; var lIn,lOutZ: DoubleP0); +//Liebermeister QuasiExact - excellent power +var + lVal: double; + i,lnYesDeficit1,lnYesDeficit0,lnNoDeficit1,lnNoDeficit0, + lnYesDeficit,lnNoDeficit: integer; + //lMaxChi,lMinChi: single; +begin + lnYesDeficit0 := 0; + lnYesDeficit1 := 0; + lnNoDeficit0 := 0; + lnNoDeficit1 := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit0) + else + inc(lnNoDeficit0); + end; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + if lIn^[i] = 0 then + inc(lnYesDeficit1) + else + inc(lnNoDeficit1); + end; //for each sub + lnYesDeficit :=lnYesDeficit0+lnYesDeficit1; + lnNoDeficit := lnNoDeficit0+lnNoDeficit1; + if (lnYesDeficit<1) or (lnNoDeficit<1) then + lOutZ := 0 + else begin + lVal := Liebermeister(lnYesDeficit0, lnYesDeficit1, lnNoDeficit0, lnNoDeficit1); + if lVal < 0 then + lOutZ := -pNormalInv(abs(lVal)) + else + lOutZ := pNormalInv(lVal) + end; //compute chi +end; + + + + + +procedure SortDouble (first, last: integer; var DynDataRA:DoubleP0; var lGroupRA: Bytep0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; + swapbyte: byte; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 0 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + swapbyte := lGroupRA^[i]; + lGroupRA^[i] := lGroupRA^[l]; + lGroupRA^[l] := swapbyte; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + +procedure RankArray (first, last: integer; var DynDataRA:DoubleP0; var lGSum: double); +var + lnTies,lPos,lStartPos,lRankPos: integer; + lScore,lTie : double; +begin + lGSum := 0; + lPos := first; + while lPos <= last do begin + lStartPos := lPos; + lScore := DynDataRA^[lPos]; + while (lPos < last) and (lScore = DynDataRA^[lPos+1]) do + inc(lPos); //count ties + lnTies := lPos - lStartPos; + lTie := (lnTies) *0.5; + if lnTies > 0 then begin + lnTies := lnTies+1;//tj on page 135 of Siegel + lGSum := lGSum + (( (lnTies*lnTies*lnTies) - lnTies)/12); + //showmessage(inttostr(lnTies)+' '+realtostr(lGSum,4)); + end; + for lRankPos := lStartPos to lPos do + DynDataRA^[lRankPos] := lStartPos+1+lTie; + inc(lPos);//start with next value + end; +end; + +function k_out_n (k,n: integer): double; //total possible permutations +//k= smaller group, n=sum of both groups +var + lVal: double; +begin + + if not gFactRAready then InitFact; + if (k < 1) or (n <0) then begin + result := 20000001; + showmessage('error k_out_n: k and n must be positive '+inttostr(n)+':'+inttostr(k)) + end else if (n > kMaxFact) or (k > kMaxFact) then + result := 20000001 + else begin + lVal := gFactRA[n] / (gFactRA[k]*gFactRA[n-k] ); + if lVal > 20000001 then + result := 20000001 + else + result := round(lVal); + //result := round(gFactRA[n] / (gFactRA[k]*gFactRA[n-k] ) ); + end; +// k out n = n!/(k!*(n-k)! which is equal to the PROD(i=k; 1){(n-i+1)/i} +end; //k_out_n +//http://www.fon.hum.uva.nl/rob/ +//# samples for which the sum of the ranks in the smaller sample is smaller than or +//# equal to a given upper bound W. +//# $W = the bound, $Sum = the sum of ranks upto now, $m-1 = one less than the +//# number of elements in the smaller sample that still have to be done, +//# $Start = the current position in the ranks list, *RankList = the array +//# with all the ranks (this is NOT just the numbers from 1 - N because of ties). +//# The list with ranks MUST be sorted in INCREASING order. +function CountSmallerRanks(var W,Sum: double; lm, Start,N: integer; var RankList: DoubleP0): integer; +var + Temp: double; + i, mminus1: integer; +begin + Temp:= 0; + result := 0; + if(Sum > W) then + exit; + //Check all subsets of the remaining of RankList + mminus1 := lm-1; + if(mminus1 > 0) then begin + for i := Start to (N-mminus1) do begin + Temp := Sum + RankList^[i]; + if(Temp > W) then + exit;// No smaller values expected anymore + result := result +CountSmallerRanks(W,Temp, mminus1, i+1, N, RankList); + end; + end else begin + //If even adding the highest rank doesn't reach $W, + //return the remaining number of items + if( (Sum + N + 1) <= W) then begin + result := N - Start + 1; + exit; + end; + for i := Start to N do begin + Temp := Sum + RankList^[i]; + if(Temp <= W) then + inc(result) + else // No smaller values expected anymore + exit; + end; //for + end; //m = 0 +end; + +procedure SortD (first, last: integer; var DynDataRA:DoubleP0); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 1 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + i := i - m; + if (i >= 0) then + goto 555; + end + end + end +end;//sort + +function Median (var lObs: DoubleP0; lnSubj: integer): double; +begin + SortD(0,lnSubj-1,lObs); + if odd(lnSubj) then + result := lObs^[lnSubj div 2] + else + result := 0.5* (lObs^[(lnSubj div 2)-1]+lObs^[lnSubj div 2]); +end; +(* getmem(lGroupRA,lnSubj*sizeof(Byte)); + createArray64(lObspX,lObsX,lnSubj); + ln0 := 0; + ln1 := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lObs[i] := lIn[i]; + if i < lnGroup0 then //group0 + lGroupRA[i] := 0 + else + lGroupRA[i] := 1; + end; //for each sub + for i := 0 to (lnSubj-1) do + if lGroupRA[i] = 0 then + inc(ln0) //number of observations in group zero + else + inc(ln1); //number of observations in group one + if (ln0 > 1) and (ln1 > 1) then begin + SortDouble(0,lnSubj-1,lObs,lGroupRA); + *) + +procedure MeanMedian(lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lMeanFX,lMedianFX: double); +//compute mean and median effect size +var + i: integer; + lMeanY,lMeanX,lMedianY,lMedianX: double; + lObsp: pointer; + lObs: Doublep0; + +begin + lMeanFX := 0; + lMedianFX := 0; + if (lnSubj=lnGroupX) or (lnSubj < 2) or (lnGroupX = 0) then + exit; //at least one empty group - no effect size + //next compute mean/median for groupX + lMeanX := 0; + createArray64(lObsp,lObs,lnSubj); + for i := 0 to (lnGroupX-1) do begin //for each subject + lMeanX := lMeanX + lIn^[i]; + lObs[i] := lIn[i]; + end; + lMeanX := lMeanX/lnGroupX; + lMedianX := Median (lObs,lnGroupX); + freemem(lObsp); + //next compute mean/median for groupY + lMeanY := 0; + createArray64(lObsp,lObs,(lnSubj-lnGroupX)); + for i := lnGroupX to (lnSubj-1) do begin //for each subject + lMeanY := lMeany + lIn^[i]; + lObs^[i-lnGroupX] := lIn^[i]; + end; + lMeanY := lMeanY/ (lnSubj-lnGroupX); + lMedianY := Median (lObs,(lnSubj-lnGroupX)); + freemem(lObsp); + //finally, compute effect sizes + lMeanFX := lMeanX-lMeanY; + lMedianFX := lMedianX-lMedianY; +end; + +procedure PairedTStat (lnSubj: integer; var lIn: DoubleP0; var lOutT: double); +//lIn has data for controls 1...n followed by 1..n paired measures. +//e.g. if three observations, 1x,2x,3x,1c,2c,3c +var + i,lnObs: integer; + lSqrSumDif,lSumDif,lSumDifSqr,lDF,lDif,lmeanDif,lVar: double; +begin + lOutT := 0; + if (odd(lnSubj)) or (lnSubj < 4) then + exit; //must have even number + lnObs := lnSubj shr 1; + lSumDif := 0; + lSumDifSqr := 0; + for i := 0 to (lnObs-1) do begin //for each subject + lDif := lIn^[i]-(lIn^[lnObs+i]) ; + lSumDif := lSumDif + lDif; + lSumDifSqr := lSumDifSqr + sqr(lDif); + end; + lDF := lnObs - 1; + + if (lSumDifSqr <> 0)and (lSumDif <> 0){and (lDF <> 0) and (lnObs <> 0)} then begin + lmeanDif := lSumDif / lnObs; + lSqrSumDif := sqr(lSumDif); + lVar := lSumDifSqr - (lSqrSumDif / lnObs); + lVar := lVar / (lnObs * lDF); + lVar := sqrt(lVar); + if lVar <> 0 then + lOutT := lmeanDif / lVar; + end; + +end; + +(*procedure ReportError (lnSubj, lnGroupX: integer; var lIn: DoubleP0; lS: double); +var + myFile : TextFile; + text : string; + i: integer; +begin + AssignFile(myFile, 'c:\Test666.txt'); + ReWrite(myFile); + WriteLn(myFile,'Subj = '+INTTOSTR(lnSubj)); + WriteLn(myFile,'Group1 = '+INTTOSTR(lnGroupX)); + WriteLn(myFile,'Var = '+FLOATTOSTR(lS)); + for i := 0 to (lnSubj-1) do + WriteLn(myFile,floattostr(lIn^[i])); + CloseFile(myFile); +end;*) + +procedure TStat2 (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +//pooled variance t-test http://www.okstate.edu/ag/agedcm4h/academic/aged5980a/5980/newpage26.htm +const + tiny = 1.0e-5; +var + i,lnGroupY: integer; + lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lS: double; +begin + lnGroupY := lnSubj - lnGroupX; + lOutT := 0; + if (lnGroupX < 1) or (lnGroupY < 1) or (lnSubj < 3) then //need at least 1 subj in each group + + exit; + lSumx := 0; + lSumSqrX := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + //lVal := lIn[i]; + lsumx := lsumx + lIn^[i]; + lSumSqrX := lSumSqrX + sqr(lIn^[i]); + end; + lVarx := (lnGroupX*lSumSqrX) - Sqr(lsumx); + if lnGroupX > 1 then + lVarX := lVarX / (lnGroupX*(lnGroupX-1)) + else + lVarx := 0; + lSumy := 0; + lSumSqry := 0; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + lsumy := lsumy + lIn^[i]; + lSumSqry := lSumSqry + sqr(lIn^[i]); + end; //for each sub + //lMnY := lsumy/lnGroupY; + lVary := (lnGroupY*lSumSqrY) - Sqr(lsumy); + if lnGroupY > 1 then + lVary := lVary / (lnGroupY*(lnGroupY-1)) + else + lVary := 0; + //lm := (lsumx/lnGroupX)-(lsumy/lnGroupY); //mean effect size lmnx - lmny; + //ldf := lnSubj - 2; + ls := ( ((lnGroupX - 1) * lvarx + (lnGroupY - 1) * lvary) / (lnSubj - 2){ldf}) ; + if abs(ls) < tiny then + exit; + if ls < 0 then + showmessage('Error: t-test variance should not be zero.'); + //deepshit (lnSubj, lnGroupX, lIn,lS); + //if ls <= 0 then + // exit; xxx + ls := sqrt( ls) ; + ls := ls * sqrt(1 / lnGroupX + 1 / lnGroupY); //note - to get here both lnx and lny > 0 + if ls = 0 then + lOutT := 0 + else + lOutT := ( ((lsumx/lnGroupX)-(lsumy/lnGroupY))/ls);//t = lm / ls; +end; + +(*procedure TStatAbs (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +var + i,lnGroupY: integer; + lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lS: double; +begin + lnGroupY := lnSubj - lnGroupX; + if (lnGroupX < 1) or (lnGroupY < 1) then begin //need at least 1 subj in each group + lOutT := 0; + exit; + end; + lSumx := 0; + lSumSqrX := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + lsumx := lsumx + lIn[i]; + lSumSqrX := lSumSqrX + sqr(lIn[i]); + end; + lVarx := (lnGroupX*lSumSqrX) - Sqr(lsumx); + if lnGroupX > 1 then + lVarX := lVarX / (lnGroupX*(lnGroupX-1)) + else + lVarx := 0; + lSumy := 0; + lSumSqry := 0; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lsumy := lsumy + lIn[i]; + lSumSqry := lSumSqry + sqr(lIn[i]); + end; //for each sub + lVary := (lnGroupY*lSumSqrY) - Sqr(lsumy); + if lnGroupY > 1 then + lVary := lVary / (lnGroupY*(lnGroupY-1)) + else + lVary := 0; + ls := sqrt( ( ((lnGroupX - 1) * lvarx + (lnGroupY - 1) * lvary) / (lnSubj - 2)) ) ; + ls := ls * sqrt(1 / lnGroupX + 1 / lnGroupY); //note - to get here both lnx and lny > 0 + if ls = 0 then + lOutT := 0 + else + lOutT := ( ((lsumx/lnGroupX)-(lsumy/lnGroupY))/ls);//t = lm / ls; + //next - create direction map + if (abs(lOutT) >= 1.96) then begin + if abs (lsumx/lnGroupX) > abs(lsumy/lnGroupY) then + lOutT := 4 + else + lOutT := -4 + + end else + lOutT := 0; +end;*) + +procedure TStat2Z (lnSubj, lnGroupX: integer; var lIn: DoubleP0; var lOutT: double); +var + i,lnGroupY: integer; + lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lS: double; +begin + lnGroupY := lnSubj - lnGroupX; + if (lnGroupX < 1) or (lnGroupY < 1) then begin //need at least 1 subj in each group + lOutT := 0; + exit; + end; + lSumx := 0; + lSumSqrX := 0; + for i := 0 to (lnGroupX-1) do begin //for each subject + //lVal := lIn[i]; + lsumx := lsumx + lIn^[i]; + lSumSqrX := lSumSqrX + sqr(lIn^[i]); + end; + lVarx := (lnGroupX*lSumSqrX) - Sqr(lsumx); + if lnGroupX > 1 then + lVarX := lVarX / (lnGroupX*(lnGroupX-1)) + else + lVarx := 0; + lSumy := 0; + lSumSqry := 0; + for i := lnGroupX to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lsumy := lsumy + lIn^[i]; + lSumSqry := lSumSqry + sqr(lIn^[i]); + end; //for each sub + //lMnY := lsumy/lnGroupY; + lVary := (lnGroupY*lSumSqrY) - Sqr(lsumy); + if lnGroupY > 1 then + lVary := lVary / (lnGroupY*(lnGroupY-1)) + else + lVary := 0; + //lm := (lsumx/lnGroupX)-(lsumy/lnGroupY); //mean effect size lmnx - lmny; + //ldf := lnSubj - 2; + ls := sqrt( ( ((lnGroupX - 1) * lvarx + (lnGroupY - 1) * lvary) / (lnSubj - 2){ldf}) ) ; + ls := ls * sqrt(1 / lnGroupX + 1 / lnGroupY); //note - to get here both lnx and lny > 0 + if ls = 0 then + lOutT := 0 + else begin + lOutT := ( ((lsumx/lnGroupX)-(lsumy/lnGroupY))/ls);//t = lm / ls; + lOutT := TtoZ (lOutT,lnSubj-2); + //fx((lsumx/lnGroupX),(lsumy/lnGroupY)); + end; +end; + + + +procedure TStatWelch (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +//see R. D. DeVeaux 'The t -test: Some details' for details +//uses Welch's Test to protect against unequal variances +//uses true [often fractional] Degrees of Freedom +label + 129; +var + i,lNx,lNy: integer; + lVal,lSumX,lSumY,lSumSqrx,lSumSqry,lVarx,lVary,lMnX,lMnY,lM,lDF,lDenom,lZ,lT: double; +begin + lZ := 0; + lNx := 0; + lSumx := 0; + lSumSqrX := 0; + lNy := 0; + lSumy := 0; + lSumSqry := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + lVal := lIn^[i]; + if i < lnGroup0 then begin //group0 + inc(lNx); + lsumx := lsumx + lVal; + lSumSqrX := lSumSqrX + sqr(lVal); + end else begin //else group1 + inc(lNy); + lsumy := lsumy + lVal; + lSumSqry := lSumSqry + sqr(lVal); + end;//group1 + end; //for each sub + if (lNy < 2) or (lNx < 2) then + goto 129; //unable to calculate + lVarX := (lNx*lSumSqrX) - Sqr(lSumX); + lVarX := lVarX / (lNx*(lNx-1)); + lMnX := lSumX/lNx; + lVary := (lNy*lSumSqrY) - Sqr(lsumy); + lVary := lVary / (lNy*(lNy-1)); + lMnY := lSumY/lNy; + lm := lMnX - lMnY; //difference between means = t-Numerator + if (lm = 0) {or (lVarY=0) or (lVarX = 0)} then + goto 129; //no difference in proportions - do not waste time computing DF + //next compute true Degrees of Freedom + lDF := sqr( (lVarX/lNx)+(lVarY/lNy)); + //lDF := lDF /( ((Sqr(lVarX/lNx)) / (lnx-1) ) + ((Sqr(lVarY/lNy)) / (lny-1) ) ); + if (lVarX=0) or (lVarY=0) then begin //forced to estimate based on pooled variance + lDF := lnx+lny -2; + lDenom:= ( ((lnx - 1) * lvarx + (lny - 1) * lvary) / (lNx+lNy-2)); + lDenom := sqrt(lDenom / lnx + lDenom / lny); + end else begin + lDF := lDF /( ((Sqr(lVarX/lNx)) / (lnx-1) ) + ((Sqr(lVarY/lNy)) / (lny-1) ) ); + lDenom := sqrt(lVarX/lNx + lVary/lNy);//assume Unequal variances "Welch's Test" + end; + if lDenom = 0 then + goto 129; + lT := ( lm/lDenom);//t = m / d; + lZ := TtoZ(lT,lDF); //az + //lP := pNormal(TtoZ(lT,lDF)); + 129: + lOutT := lZ; + //vlsm compatible = lOutT[lColX] := ( lm/lD);//t = m / d; +end; + +FUNCTION specialdouble (d:double): boolean; +//returns true if s is Infinity, NAN or Indeterminate +//8byte IEEE: msb[63] = signbit, bits[52-62] exponent, bits[0..51] mantissa +//exponent of all 1s = Infinity, NAN or Indeterminate +CONST kSpecialExponent = 2047 shl 20; +VAR Overlay: ARRAY[1..2] OF LongInt ABSOLUTE d; +BEGIN + IF ((Overlay[2] AND kSpecialExponent) = kSpecialExponent) THEN + RESULT := true + ELSE + RESULT := false; +END; + +procedure LocalRank (first, last: integer; var DynDataRA,DynDataRAX:DoubleP0; var lGroupRA: Bytep0); +var + lGroup,lnTies,lPos,lStartPos,lRankPos,lLocalRank: integer; + lScore,lTie : double; +begin + for lGroup := 0 to 1 do begin + lPos := first; + lLocalRank := 0; + while lPos <= last do begin + if lGroupRA^[lPos] = lGroup then begin// + inc(lLocalRank); + lStartPos := lPos; + lScore := DynDataRA^[lPos]; + lnTies := 0; + while (lPos < last) and (0.001 > abs (lScore - DynDataRA^[lPos+1]) ) do begin + inc(lPos); //count ties + if lGroupRA^[lPos] = lGroup then + inc(lnTies); + end; + lTie := (lnTies) *0.5; + for lRankPos := lStartPos to lPos do begin + if lGroupRA^[lRankPos] = lGroup then + DynDataRAX^[lRankPos] := (lLocalRank+lTie); + end; + lLocalRank := lLocalRank + lnTies; + end; //if in group + inc(lPos);//start with next value + end; //while... for each observation + end; //for each group +end; + +procedure BMTest (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +//procedure BMtest (lnRow,lnCol: integer; var lIn,lOutT: DoubleP0); +var + lObspX,lObsp: pointer; + lObsX,lObs: Doublep0; + lGroupRA: Bytep0; + i,ln0,ln1,lColX: integer; + lDF,lZ,lGSum: double; + lSum0,lSum1,lMean0,lMean1,lSqr0,lSqr1,lk0,lk1: double; +begin + createArray64(lObsp,lObs,lnSubj); + getmem(lGroupRA,lnSubj*sizeof(Byte)); + createArray64(lObspX,lObsX,lnSubj); + ln0 := 0; + ln1 := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lObs^[i] := lIn^[i]; + if i < lnGroup0 then //group0 + lGroupRA^[i] := 0 + else + lGroupRA^[i] := 1; + end; //for each sub + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + inc(ln0) //number of observations in group zero + else + inc(ln1); //number of observations in group one + if (ln0 > 1) and (ln1 > 1) then begin + SortDouble(0,lnSubj-1,lObs,lGroupRA); + RankArray(0,lnSubj-1,lObs,lGSum); + lSum0 := 0; + lSum1 := 0; + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lSum0 := lSum0 + lObs^[i] + else + lSum1 := lSum1 + lObs^[i]; + lMean0 := lSum0 / ln0; + lMean1 := lSum1 / ln1; + //fx(lmean0,lMean1); + lSqr0 := 0; + lSqr1 := 1; + lk0 := (ln0+1)/2; + lk1 := (ln1+1)/2; + LocalRank(0,lnSubj-1,lObs,lObsX,lGroupRA); + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lSqr0 := lSqr0 + Sqr(lObs^[i]-lObsX^[i]-lMean0+lk0) + else + lSqr1 := lSqr1 + Sqr(lObs^[i]-lObsX^[i]-lMean1+lk1); + lSqr0 := (1/(ln0-1))*lSqr0; + lSqr1 := (1/(ln1-1))*lSqr1; + + lZ := -(ln0*ln1*(lMean1-lMean0))/((ln0+ln1)*sqrt((ln0*lSqr0)+(ln1*lSqr1) ) ); + lDF := sqr(ln0*lSqr0+ln1*lSqr1) / ( (sqr(ln0*lSqr0)/(ln0-1)) + (sqr(ln1*lSqr1)/(ln1-1)) ) ; + lZ := TtoZ(lZ,lDF); //az + lOutT := lZ; + //fx(lZ,lDF); + end else //>1 + lOutT := 0; + freemem(lObsp); + freemem(lObspX); + freemem(lGroupRA); +end; //bmtest + + +procedure WilcoxonMW2 (lnSubj, lnGroup0: integer; var lIn: DoubleP0; var lOutT: double); +var + lObsp: pointer; + lObs: Doublep0; + lGroupRA: Bytep0; + m,n,i,ln0,ln1,mplusn: integer; + lPermutations,lVal,lWsmalln,lZ,lZi,lTail,lGSum,lWTotal,lH0,lSum: double; + +begin + createArray64(lObsp,lObs,lnSubj); + getmem(lGroupRA,lnSubj*sizeof(Byte)); + ln0 := 0; + ln1 := 0; + for i := 0 to (lnSubj-1) do begin //for each subject + //lVal := lIn[i]; + lObs[i] := lIn[i]; + if i < lnGroup0 then //group0 + lGroupRA^[i] := 0 + else + lGroupRA^[i] := 1; + end; //for each sub + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + inc(ln0) //number of observations in group zero + else + inc(ln1); //number of observations in group one + SortDouble(0,lnSubj-1,lObs,lGroupRA); + RankArray(0,lnSubj-1,lObs,lGSum); + + lWsmalln := 0; + if ln1 < ln0 then begin //Group1 smaller than Group0 + m := ln1; + n := ln0; + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 1 then + lWsmalln := lWsmalln + lObs^[i]; + end else begin//Group0 smaller than Group1 + m := ln0; + n := ln1; + for i := 0 to (lnSubj-1) do + if lGroupRA^[i] = 0 then + lWsmalln := lWsmalln + lObs^[i]; + end; + mplusn := m + n; + lZ := 0; + if lWsmalln > (mplusn*(mplusn+1)/4) then + lTail := -0.5 + else + lTail := 0.5; + if m < 1 then + lZ := 0 + else if lGSum = 0 then begin //no ties + lZ := ( lWsmalln + lTail - m * ( m + n + 1 ) / 2 ) / sqrt( m * n * ( m + n + 1 ) / 12 ); + end else begin //correct for ties, see Siegel page 135 + if ((12-lGSum)<>0) and (((lnSubj*(lnSubj-1)) * (((lnSubj*lnSubj*lnSubj) -lnSubj) /12-lGSum))<> 0) then begin + lZ := lWsmalln + lTail - (m * ( lnSubj + 1 ) / 2 ); + lZ := lZ/sqrt ( (m*n)/ (lnSubj*(lnSubj-1)) * (((lnSubj*lnSubj*lnSubj) -lnSubj) /12-lGSum)); + end else begin + lZ := ( lWsmalln + lTail - m * ( m + n + 1 ) / 2 ) / sqrt( m * n * ( m + n + 1 ) / 12 ); + end; + end; + {if lStr = '' then begin + for i := 0 to (lnSubj-1) do + lStr := lStr+inttostr(lGroupRA[i])+', '+floattostr( lObs[i])+';'; + lStr := ('w'+floattostr(lWsmalln)+'Z'+floattostr(lZ)+'ties'+floattostr(lgSum)+'m'+inttostr(m)+'n'+inttostr(n)+':'+lStr); + end; } + if m < 10 then + lPermutations := k_out_n(m,mplusn); + if (m < 10) and (lPermutations < 20000000) and (abs(lZ) > 1) {}then begin + lWTotal :=mplusn*(mplusn+1)/2; //sum ranks for both groups m and n + lH0 := lWTotal * (m/mplusn); //null hypothesis + lSum := 0; + //next - use smallest value of W + if lWSmallN > lH0 then begin + lWSmallN := lH0 - (lWSmallN-lH0); + //Due to ties, we need to flip the order as well, as we are searching smaller + for i := 0 to (lnSubj-1) do + lObs^[i] := (lnSubj+1)-lObs^[i]; + for i := 0 to ((lnSubj-2) div 2) do begin //swap + lVal := lObs^[i]; + lObs^[i] := lObs^[lnSubj-1-i]; + lObs^[lnSubj-1-i] := lVal; + end; + end; + lVal := CountSmallerRanks(lWSmallN, lSum, m, 0,(mplusn-1), lObs); + lZi := lZ; + lZ :=pNormalInvQuickApprox(lVal/lPermutations); + if ((lZ > 0) and (lZi < -1)) or ((lZ < 0) and (lZi > 1)) then + lZ := -lZ; + end; + if ln1 < ln0 then //we computed unexpected tail + lOutT := -lZ + else + lOutT := lZ;//t = m / d; + freemem(lObsp); + freemem(lGroupRA); +end; + + + +end. + diff --git a/npm_precl/tfce_clustering.7z b/npm_precl/tfce_clustering.7z new file mode 100755 index 0000000..0287bcc Binary files /dev/null and b/npm_precl/tfce_clustering.7z differ diff --git a/npm_precl/tfce_clustering.pas b/npm_precl/tfce_clustering.pas new file mode 100755 index 0000000..2e4f2b7 --- /dev/null +++ b/npm_precl/tfce_clustering.pas @@ -0,0 +1,273 @@ +unit tfce_clustering; +//USED by stats to select only regions with a given number of connected/contiguous voxels +{$IFDEF FPC} {$mode delphi}{$H+} {$ENDIF} +interface +uses +{$IFNDEF UNIX} Windows, + {$ELSE} + LCLType, LCLintf, + {$ENDIF} +define_types,dialogs,SysUtils,nifti_hdr,nifti_img, math; + +//procedure FindClusters (lMultiBuf: SingleP; lXdim, lYDim, lZDim, lThreshClusterSz: integer; lMinNeg, lMinPos: single); + +//function ClusterTFCE (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double ): boolean; + +function doTFCE (var lHdr: TNIFTIhdr; lImg: SingleP; NumConn: integer; H, E, minT, deltaT: single ): boolean; +//mimics FSL's function "TFCE" in newimagefns.h + +function doTFCEbothPolarities (var lHdr: TNIFTIhdr; lImg: SingleP; NumConn: integer; H, E, minT, deltaT, minNegT, NegdeltaT: single; var maxTFCE, maxNegTFCE: single): boolean; +//both polarities computes TFCE for both positive and negative values + +implementation +uses +npmform; + +procedure countClusterSize (lX,lY,lZ, lnumConnIn: integer; var lClusterBuff: LongIntP); +//input CountImg is volume X*Y*Z where voxels are either 0 or 1 +// output: CountImg voxels report number of connected neighbors +const + lClusterSign = 1; //input CountImg has this value set to 1 + lClusterFillValue = -1; //impossible cluster size - used to denote actively growing cluster +var + lQHead,lV,lXY, lXYZ,lClusterSz, lQTail,lnumConn,lI,lNeighbor: integer; + lQra: LongIntP; + ConnOffset : ARRAY [1..26] of integer; +procedure InitConn; +begin + //first 6 share face + ConnOffset[1] := -1;//L + ConnOffset[2] := 1; //R + ConnOffset[3] := -lX; //A + ConnOffset[4] := lX; //P + ConnOffset[5] := -lXY;//I + ConnOffset[6] := lXY;//S + if lnumConnIn < 7 then begin + lnumConn := 6; + exit; + end; + //share edge + //..check plane above + ConnOffset[7] := (lXY-1); //left + ConnOffset[8] := (lXY+1); //right + ConnOffset[9] := (lXY-lX); //up + ConnOffset[10] := (lXY+lX); //down + //..check plane below + ConnOffset[11] := (-lXY-1); //left + ConnOffset[12] := (-lXY+1); //right + ConnOffset[13] := (-lXY-lX); //up + ConnOffset[14] := (-lXY+lX); //down + //..check diagonals of current plane + ConnOffset[15] := (-lX-1); //up, left + ConnOffset[16] := (-lX+1); //up, right + ConnOffset[17] := (+lX-1); //down, left + ConnOffset[18] := (+lX+1); //down, right + if lnumConnIn < 19 then begin + lnumConn := 18; + exit; + end; + //share corner + //..check plane above + ConnOffset[19] := (lXY-1-lX); //left + ConnOffset[20] := (lXY-1+lX); //right + ConnOffset[21] := (lXY+1-lX); //up + ConnOffset[22] := (lXY+1+lX); //down + //..check plane BELOW + ConnOffset[23] := (-lXY-1-lX); //left + ConnOffset[24] := (-lXY-1+lX); //right + ConnOffset[25] := (-lXY+1-lX); //up + ConnOffset[26] := (-lXY+1+lX); //down + lnumConn := 26; +end; //InitConn +begin + lXY := lX * lY; + lXYZ := lX*lY*lZ; + InitConn; + if lXYZ < 1 then exit; + GetMem(lQra,lXYZ * sizeof(longint) ); + //check every voxel to see if it is isolated + for lV := 1 to lXYZ do begin + if (lClusterBuff^[lV]=lClusterSign) then begin //new cluster detected + lClusterSz := 1; + lQHead := 1; + lQTail := 1; + lQra^[lQTail] := lV; + lClusterBuff^[lV] := lClusterFillValue; + while (lQHead >= lQTail) do begin + //RetirePixel: lQTail incremented once, lQHead is incremented 0..nummConn + for lI := 1 to lnumConn do begin + lNeighbor := lQra^[lQTail]+ConnOffset[lI]; + if (lClusterBuff^[lNeighbor]=lClusterSign) then begin//add item + inc(lQHead); + inc(lClusterSz); + lClusterBuff^[lNeighbor] := lClusterFillValue; + lQra^[lQHead] := lNeighbor; + end; //if new item detected + end; //for each connector + inc(lQTail); //done with this pixel + end; //while items in Queue + for lI := lV to lXYZ do + if (lClusterBuff^[lI]=lClusterFillValue) then + lClusterBuff^[lI] := lClusterSz; + end; //new item found + end; //for each voxel + freemem(lQra); +end; + +procedure ZeroFaces (var lHdr: TNIFTIhdr; lImg: SingleP ); +var + lV,lX,lY,lZ,lZi,lYi,lXi: integer; +begin + lX := lHdr.Dim[1]; + lY := lHdr.Dim[2]; + lZ := lHdr.Dim[3]; + if (lX < 3) or (lY < 3) or (lZ < 3) then exit; + for lV := 1 to (lX*lY) do lImg[lV] := 0; //bottom slice + for lV := ((lX*lY*lZ)-(lX*lY)) to (lX*lY*lZ) do lImg[lV] := 0; //top slice + //left side + lV := 1; + for lZi := 1 to lZ do begin + for lYi := 1 to lY do begin + lImg[lV] := 0; + lV := lV+lX; + end; + end; + //right side + lV := lX; + for lZi := 1 to lZ do begin + for lYi := 1 to lY do begin + lImg[lV] := 0; + lV := lV+lX; + end; + end; + //anterior + for lZi := 1 to lZ do begin + lV := (lZi-1) * lX*lY; + for lXi := 1 to lX do begin + lV := lV+1; + lImg[lV] := 0; + end; + end; + //posterior + for lZi := 1 to lZ do begin + lV := (lZi-1) * lX*lY; + lV := lV + ((lY-1) *lX); + for lXi := 1 to lX do begin + lV := lV+1; + lImg[lV] := 0; + end; + end; +end; + + +function doTFCEbothPolarities (var lHdr: TNIFTIhdr; lImg: SingleP; NumConn: integer; H, E, minT, deltaT, minNegT, NegdeltaT: single; var maxTFCE, maxNegTFCE: single): boolean; +var + lV,lXYZ,lX,lY,lZ: integer; + + lNegImg: SingleP; + +begin + result := false; + lX := lHdr.Dim[1]; + lY := lHdr.Dim[2]; + lZ := lHdr.Dim[3]; + lXYZ := lX*lY*lZ; + if lXYZ < 1 then exit; + getmem(lNegImg,lXYZ*sizeof(single)); + for lV := 1 to lXYZ do + lNegImg[lV] := -lImg[lV]; + + + doTFCE (lHdr, lImg, NumConn, H, E, minT, deltaT); + maxTFCE :=lImg[lV]; + for lV := 1 to lXYZ do + if (maxTFCE < lImg[lV]) then + maxTFCE:= lImg[lV]; + + + doTFCE (lHdr, lNegImg, NumConn, H, E, abs(minNegT), abs(NegdeltaT)); + maxNegTFCE :=lImg[lV]; + for lV := 1 to lXYZ do + if (maxNegTFCE < lNegImg[lV]) then + maxNegTFCE:= lNegImg[lV]; + maxNegTFCE := -maxNegTFCE; + + for lV := 1 to lXYZ do begin + if (lNegImg[lV] > 0) then + lImg[lV] := -lNegImg[lV]; + end; + + freemem(lNegImg); +end; + + + +function doTFCE (var lHdr: TNIFTIhdr; lImg: SingleP; NumConn: integer; H, E, minT, deltaT: single ): boolean; +const + kSteps = 100; +label + 777; +var + lV,lXYZ,lX,lY,lZ: integer; + maxval, lThresh, ThreshPowerHxdh, dh: single; + lThreshImg: SingleP; + lCountImg: LongIntP; + lStartTime: DWord; +begin + lX := lHdr.Dim[1]; + lY := lHdr.Dim[2]; + lZ := lHdr.Dim[3]; + lStartTime := GetTickCount; + result := false;//assume failure + lXYZ := lX*lY*lZ; + if lXYZ < 1 then exit; + //E := 0.5; //0.5 + //H := 2;//2 + getmem(lThreshImg,lXYZ*sizeof(single)); + getmem(lCountImg,lXYZ*sizeof(longint)); + ZeroFaces (lHdr, lImg ); + maxval := lImg[1]; + for lV := 1 to lXYZ do begin + lThreshImg[lV] := lImg[lV]; + if lImg[lV] > maxval then maxval := lImg[lV]; + lImg[lV] := 0; //initialize sum map to zero + end; + + if (maxval <= 0) then goto 777; + if (maxval < minT) then goto 777; + if (deltaT = 0) then + dh := (maxval-minT) / kSteps + else + dh := deltaT; + MainForm.NPMmsg('max = '+floattostr(maxval)+' deltaT = '+floattostr(dh)); + lThresh := minT+dh; + while lThresh < maxval do begin + + + for lV := 1 to lXYZ do begin + if (lThreshImg[lV] <= lThresh) then + lCountImg[lV] := 0 + else + lCountImg[lV] := 1; + end; + countClusterSize (lX,lY,lZ,NumConn, lCountImg); + ThreshPowerHxdh := power(lThresh,H)*dh; + for lV := 1 to lXYZ do + if (lCountImg[lV] > 0) then + lImg[lV] := lImg[lV] + (exp(E*ln(lCountImg[lV])) * ThreshPowerHxdh); //faster than power + (*for lV := 1 to lXYZ do + if (lCountImg[lV] > 0) then + lImg[lV] := lImg[lV] + (power(lCountImg[lV],E) * ThreshPowerHxdh); *) + lThresh := lThresh + dh; + end; +777: + MainForm.NPMmsg('Time = '+inttostr(GetTickCount - lStartTime)); + freemem(lCountImg); + freemem(lThreshImg); + result := true; //report success! +end; + + + + +end. \ No newline at end of file diff --git a/npm_precl/tfce_clustering.zip b/npm_precl/tfce_clustering.zip new file mode 100755 index 0000000..c22aed6 Binary files /dev/null and b/npm_precl/tfce_clustering.zip differ diff --git a/npm_precl/turbolesion.pas b/npm_precl/turbolesion.pas new file mode 100755 index 0000000..133c57d --- /dev/null +++ b/npm_precl/turbolesion.pas @@ -0,0 +1,491 @@ +unit turbolesion; +interface +{$H+} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes; +Type + TLDMPrefs = record + NULP,BMtest,Ttest,Ltest: boolean; + CritPct,nCrit,nPermute,Run: integer; + ValFilename, OutName, ExplicitMaskName: string; + end; +function TurboLDM (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var lPrefs: TLDMPrefs ; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; + + + +implementation + +uses npmform; + +(*procedure Debog (var lSumImg: Smallintp; lVox: integer); +var + lInName : string; + lFData: file; +begin + lInName := 'c:\16.img'; + assignfile(lFdata,lInName); + filemode := 2; + Rewrite(lFdata,lVox*sizeof(smallint)); + BlockWrite(lFdata,lSumImg^, 1 {, NumWritten}); + closefile(lFdata); +end;*) + +function MakeSum (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; var lSumImg: Smallintp): boolean; +//if successful, you MUST freemem(lSumImg)... +label + 667; +var + lVolVox,lVox,lImg,lPosPct: integer; + lVolImg: byteP; + +begin + result := false; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then exit; + getmem(lVolImg,lVolVox* sizeof(byte)); + getmem(lSumImg,lVolVox* sizeof(smallint)); + for lVox := 1 to lVolVox do //June 2009 init array + lSumImg^[lVox] := 0; +(* for lVox := 1 to lVolVox do + if lVolImg^[lVox] <> 0 then + lSumImg^[lVox] := lSumImg^[lVox]+1;*) + for lImg := 1 to lImages.Count do begin + lPosPct := round(100*(lImg / lImages.Count)); + MainForm.ProgressBar1.Position := lPosPct; + Application.Processmessages; + if not LoadImg8(lImages[lImg-1], lVolImg, 1, lVolVox,round(gOffsetRA[lImg]),1,gDataTypeRA[lImg],lVolVox) then + goto 667; + for lVox := 1 to lVolVox do + if lVolImg^[lVox] <> 0 then + lSumImg^[lVox] := lSumImg^[lVox]+1; + end;//for each image + MainForm.NPMmsg('Sum image finished = ' +TimeToStr(Now)); + MainForm.ProgressBar1.Position := 0; + //Debog(lSumImg, lVolVox); + freemem(lVolImg); + result := true; + exit; +667: //you only get here if you aborted ... free memory and report error + freemem(lVolImg); + freemem(lSumImg); + MainForm.NPMMsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; + + +function ThreshSumImg (var lSumImg: Smallintp; lVolVox,lThresh: integer): integer; +//sets all voxels with values < lThresh to zero, returns number of voxels to survive threshold. +var + lPos: integer; +begin + result := 0; + if lVolVox < 1 then + exit; + for lPos := 1 to lVolVox do + if lSumImg^[lPos] < lThresh then + lSumImg^[lPos] := 0 + else + inc(result); +end; + +function ExplicitMaskSumImg (lMaskName: string; var lSumImg: Smallintp; lVolVox: integer): integer; +//Any voxels in MaskImg that are 0 are zeroed in the SumImg +var + lOK: boolean; + lPos: integer; + lMaskHdr: TMRIcroHdr; + lMaskData: bytep; +label + 666; +begin + result := 0; + if (lVolVox < 1) or (not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr)) then begin + MainForm.NPMmsg('Error: unable to load explicit mask named '+lMaskName); + exit; + end; + if lVolVox <> (lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]) then begin + MainForm.NPMmsg('Error: data and explicit mask have different sizes '+lMaskName); + exit; + end; + + getmem(lMaskData,lVolVox* sizeof(byte)); + lOK := LoadImg8(lMaskName, lMaskData, 1, lVolVox,round(lMaskHdr.NIFTIhdr.vox_offset),1,lMaskHdr.NIFTIhdr.DataType,lVolVox); + if not lOK then goto 666; + if lVolVox < 1 then + exit; + for lPos := 1 to lVolVox do + if lMaskData^[lPos] < 1 then + lSumImg^[lPos] := 0 + else + inc(result); + + 666: + freemem(lMaskData); +end; + +function LoadImg8Masked(lInName: string; lImgData: bytep; lMaskData: SmallIntP; lStartMaskPos, lEndMaskPos,linvox_offset,lRApos,lDataType,lVolVox: integer): boolean; +label + 111; +var + lFullImgData: bytep; + lMaskPos,lPos: integer; +begin + result := false; + if (lVolVox < 1) or (lEndMaskPos < lStartMaskPos) then + exit; + getmem(lFullImgData,lVolVox* sizeof(byte)); + result := LoadImg8(lInName, lFullImgData, 1, lVolVox,linvox_offset,1,lDataType,lVolVox); + if result then begin + lMaskPos := 0; + for lPos := 1 to lVolVox do begin + if lMaskData^[lPos] <> 0 then begin + inc(lMaskPos); + if (lMaskPos >=lStartMaskPos) then + lImgData^[lRApos+lMaskPos-1] := lFullImgData^[lPos]; + if lMaskPos = lEndMaskPos then goto 111; + + end;//voxel in mask + end; //for each voxel in image + + end;//if LoadImg8 success +111: + freemem(lFullImgData); +end; + +function reformat(var lStatImg: singlep; lMaskImg: smallintp; lVolVox: integer): boolean; +var + lPos,lStatPos,lMaskItems: integer; +begin + result := false; + if lVolVox < 1 then + exit; + lMaskItems := 0; + for lPos := 1 to lVolVox do + if lMaskImg^[lPos] <> 0 then + inc(lMaskItems); + result := true; + if (lMaskItems < 1) or (lMaskItems >= lVolVox) then + exit;//no need to reformat + //note that we do this in descending order, so we do not overwrite... + lStatPos := lMaskItems; + for lPos := lVolVox downto 1 do + if lMaskImg^[lPos] <> 0 then begin + lStatImg^[lPos] := lStatImg^[lStatPos]; + dec(lStatPos); + end else + lStatImg^[lPos] := 0; +end;//reformat + + +function NULPcount (lPlankImg: bytep; lVoxPerPlank,lImagesCount: integer; var lUniqueOrders: integer; var lOverlapRA: Overlapp): boolean; +procedure CheckOrder(var lObservedOrder: TLesionPattern); +var + lInc: integer; +begin + if lUniqueOrders > 0 then begin //see if this is unique + for lInc := 1 to lUniqueOrders do + if SameOrder(lObservedOrder,lOverlapRA^[lInc],lImagesCount) then + exit; //not unique + end; //UniqueOrders > 0 + //if we have not exited yet, we have found a new ordering! + lUniqueOrders := lUniqueOrders + 1; + lOverlapRA^[lUniqueOrders] := lObservedOrder; +end; + +var + lVox,lPlankImgPos,lPos: integer; + lOrder,lPrevOrder: TLesionPattern; +begin + result := false; + lPrevOrder := EmptyOrder;//impossible: forces first voxel of each order to be checked + for lVox := 1 to lVoxPerPlank do begin + (*if (lVox mod lVoxPerPlankDiv10) = 0 then begin + MainForm.ProgressBar1.Position := (lVox div lVoxPerPlankDiv10)*10; + MainForm.Refresh; + Application.processmessages; + end;*) + lOrder := EmptyOrder; + lPlankImgPos := 0; + //lnDeficits := 0; + for lPos := 1 to lImagesCount do begin + if (lPlankImg^[lPlankImgPos + lVox] > 0) then begin + //inc(lnDeficits); + SetBit(lPos,lOrder); + end; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end; + //if (lnDeficits >= lminDeficits) then begin //this is different from the last voxel: perhaps this is a new ordering + if (not SameOrder(lOrder,lPrevOrder,lImagesCount)) then + CheckOrder(lOrder); + //inc(lnVoxels); + //end;//nDeficies + lPrevOrder := lOrder; + end;//for lVox + result := true; +end; + +procedure PtoZpermute (lnPermute: integer; lPermuteMaxT, lPermuteMinT: singlep); +var + lPos: integer; + lVal : single; +begin + if lPos < 1 then exit; + for lPos := 1 to lnPermute do begin + if (lPermuteMinT^[lPos] > 1.1) or (lPermuteMinT^[lPos] < -1.1) then + lPermuteMinT^[lPos] := 0.5; + if (lPermuteMaxT^[lPos] > 1.1) or (lPermuteMaxT^[lPos] < -1.1) then + lPermuteMaxT^[lPos] := 0.5; + lVal := lPermuteMaxT^[lPos]; + lPermuteMaxT^[lPos] := lPermuteMinT^[lPos]; + lPermuteMinT^[lPos] := lVal; + if lPermuteMaxT^[lPos] < 0 then + lPermuteMaxT^[lPos] := -pNormalInv(abs(lPermuteMaxT^[lPos])) + else + lPermuteMaxT^[lPos] := pNormalInv(lPermuteMaxT^[lPos]); + if lPermuteMinT^[lPos] < 0 then + lPermuteMinT^[lPos] := -pNormalInv(abs(lPermuteMinT^[lPos])) + else + lPermuteMinT^[lPos] := pNormalInv(lPermuteMinT^[lPos]); + end; +end; + + +function TurboLDM (var lImages: TStrings; var lMaskHdr: TMRIcroHdr;var lPrefs: TLDMPrefs ; var lSymptomRA: SingleP;var lFactname,lOutName: string): boolean; +label + 123,667; +var + lOutNameMod: string; + lStatHdr: TNIfTIhdr; + lThreshFDR,lThreshPermute,lThreshBonf,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC: singlep; + lSumImg: Smallintp; + lPlankImg: byteP; + lVoxPerPlank,lnPlanks,lTotalMemory,lnVoxTested,lVolVox: int64; + lUniqueOrders,lThread,lThreadStart,lThreadInc,lThreadEnd, + lPos2,lPosPct,lPos,lPlankImgPos,lPlank,lStartVox,lEndVox: integer; + lOverlapRA: Overlapp; + {$IFNDEF FPC} lStartTime :DWord;{$ENDIF} +begin + {$IFNDEF FPC} lStartTime := GetTickCount;{$ENDIF} + result := false; + lSumImg := nil; + lPlankImg := nil; + lOutImgSum := nil; + lOutImgBM := nil; + lOutImgT := nil; + lOutImgAUC := nil; + lOverlapRA := nil; + lUniqueOrders := 0; + if lPrefs.Ltest then begin + lPrefs.Ttest := false; + lPrefs.BMtest := false; + end else if (not lPrefs.Ttest) and (not lPrefs.BMtest) then begin//not binomial + MainForm.NPMmsg('Error no tests specified'); + exit; + end; + MainForm.NPMmsg('Permutations = ' +IntToStr(lPrefs.nPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + if not MakeSum( lImages, lMaskHdr, lSumImg) then goto 667; + lnVoxTested := ThreshSumImg(lSumImg,lVolVox,lPrefs.nCrit); + MainForm.NPMmsg('Voxels damaged in at least '+inttostr(lPrefs.nCrit)+' individuals = ' +Floattostr(lnVoxTested)); + if lnVoxTested < 1 then begin + MainForm.NPMmsg('Error: no voxels damaged in at least '+inttostr(lPrefs.nCrit)+' individuals.'); + goto 667; + end; + if (lPrefs.ExplicitMaskName <> '') then begin + lnVoxTested := ExplicitMaskSumImg (lPrefs.ExplicitMaskName, lSumImg, lVolVox); + MainForm.NPMmsg('Voxels also non-zero in mask '+lPrefs.ExplicitMaskName+' = ' +Floattostr(lnVoxTested)); + if lnVoxTested < 1 then begin + MainForm.NPMmsg('Error: no remaing voxels also non-zero in mask '+lPrefs.ExplicitMaskName); + goto 667; + end; + end; + + //compute planks and acquire memory + lTotalMemory := lnVoxTested * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/kPlankSz ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/kPlankSz)); + if (lnPlanks = 1) then begin + lVoxPerPlank := lnVoxTested; //we can do this in a single pass + getmem(lPlankImg,lTotalMemory) + end else begin + getmem(lPlankImg,kPlankSz); + lVoxPerPlank := kPlankSz div lImages.Count; + end; + //spatial maps for results + getmem(lOutImgSum,lVolVox*sizeof(single)); + getmem(lOutImgBM,lVolVox*sizeof(single)); + getmem(lOutImgT,lVolVox*sizeof(single)); + getmem(lOutImgAUC,lVolVox*sizeof(single)); + //initialize memory + MainForm.InitPermute (lImages.Count, lPrefs.nPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + lOutImgAUC^[lPos] := 0; + end; + //next create permuted BM bounds + if lPrefs.BMtest then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + createArray64(lObsp,lObs,lImages.Count); + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lImages.Count, lObs); + freemem(lObsp); + end; + if lPrefs.NULP then + getmem(lOverlapRA,lnVoxTested* sizeof(TLesionPattern)); + if lPrefs.Ltest then + ClearThreadDataPvals(gnCPUThreads,lPrefs.nPermute) + else + ClearThreadData(gnCPUThreads,lPrefs.nPermute) ; + //load and process data + lStartVox := 1; + lEndVox := 0; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)+' of '+inttostr(lnPlanks)); + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lnVoxTested then begin + lVoxPerPlank := lnVoxTested-lStartVox+1{lVoxPerPlank - (lEndVox-lVolVox)}; + lEndVox := lnVoxTested; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8Masked(lImages[lPos-1], lPlankImg,lSumImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + if lPrefs.Ltest then begin + with TLesionBinom.Create (MainForm.ProgressBar1,false,true,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutIMgT{not used},lOutImgAUC,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + end else begin + with TLesionContinuous.Create (MainForm.ProgressBar1,lPrefs.ttest,lPrefs.BMtest,lPrefs.nCrit, lPrefs.nPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,0,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA) do + //with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,lSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + end; + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //end of threading + + if lPrefs.NULP then + NULPcount (lPlankImg, lVoxPerPlank,lImages.Count, lUniqueOrders, lOverlapRA); + + lStartVox := lEndVox + 1; + end; + //calculate max per thread + SumThreadData(gnCPUThreads,lPrefs.nPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + + //data in maps is stored in voxels 1..lnVoxTested - put in spatial order + reformat(lOutImgSum,lSumImg,lVolVox); + reformat(lOutImgBM,lSumImg,lVolVox); + reformat(lOutImgT,lSumImg,lVolVox); + reformat(lOutImgAUC,lSumImg,lVolVox); + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + if lPrefs.NULP then + lThreshBonf := MainForm.reportBonferroni('Number of Unique Lesion Patterns',lUniqueOrders); + + + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); + //save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + //save Area Under Curve + lOutNameMod := ChangeFilePostfixExt(lOutName,'rocAUC'+lFactName,'.hdr'); + if lPrefs.Run < 1 then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgAUC,1); + //create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lPrefs.Run < 1) and (Sum2Power(lOutImgSum,lVolVox,lImages.Count,lPrefs.nCrit, lPrefs.LTest)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + //if lPrefs.Run > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + // lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lPrefs.nCrit,lnVoxTested,lPlankImg)); + if lPrefs.ttest then begin //save Ttest + //next: convert t-scores to z scores + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lPrefs.nPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThreshFDR := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('ttest',lPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'ttest'+lFactName,'.hdr'); + {$IFNDEF FPC} + if lPrefs.Run > 0 then begin + MainForm.NPMmsgAppend('threshtt,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshBonf,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)+','+inttostr(round((GetTickCount - lStartTime)/1000))); + end; + {$ENDIF} + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + end; + if lPrefs.LTest then begin + PtoZpermute (lPrefs.nPermute, lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'L'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + MainForm.reportFDR ('L', lVolVox, lnVoxTested, lOutImgBM); + MainForm.reportPermute('L',lPrefs.nPermute,lPermuteMaxT, lPermuteMinT); + end;//Liebermeister + if lPrefs.BMtest then begin //save Brunner Munzel + lThreshFDR := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('BM',lPrefs.nPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'BM'+lFactName,'.hdr'); + if lPrefs.Run > 0 then + MainForm.NPMmsgAppend('threshbm,'+inttostr(lPrefs.Run)+','+inttostr(MainForm.ThreshMap(lThreshBonf,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); + end; + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + {$IFNDEF FPC} MainForm.NPMmsg('Processing Time = ' +inttostr(round((GetTickCount - lStartTime)/1000)));{$ENDIF} + + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + MainForm.MsgSave(lOutNameMod); + //all done + result := true;//all done without aborting +667: // free memory and report error + if lPlankImg <> nil then freemem(lPlankImg); + if lSumImg <> nil then freemem(lSumImg); + if lOutImgSum <> nil then freemem(lOutImgSum); + if lOutImgBM <> nil then freemem(lOutImgBM); + if lOutImgT <> nil then freemem(lOutImgT); + if lOutImgAUC <> nil then freemem(lOutImgAUC); + if lOverlapRA <> nil then freemem(lOverlapRA); + + if not result then + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //TurboLDM + +end. diff --git a/npm_precl/upower.pas b/npm_precl/upower.pas new file mode 100755 index 0000000..f0626d4 --- /dev/null +++ b/npm_precl/upower.pas @@ -0,0 +1,116 @@ +unit upower; +interface + +uses define_types, statcr, distr, dialogs; +function Sum2Power(lOutImgSum: SingleP; lVolVox,lnTotal,lnDeficit: integer; lBinomial: boolean): boolean; +function Sum2PowerCont(lOutImgSum: SingleP; lVolVox,lnTotal: integer): boolean; +function Sum2PowerBinom(lOutImgSum: SingleP; lVolVox,lnTotal,lnDeficit: integer): boolean; +function k_out_n (k,n: integer): double; //total possible permutations + +implementation + +function k_out_n (k,n: integer): double; //total possible permutations +//k= smaller group, n=sum of both groups +begin + if not gFactRAready then InitFact; + result := round(gFactRA[n] / (gFactRA[k]*gFactRA[n-k] ) ); +// k out n = n!/(k!*(n-k)! which is equal to the PROD(i=k; 1){(n-i+1)/i} +end; //k_out_n + +function Sum2Power(lOutImgSum: SingleP; lVolVox,lnTotal,lnDeficit: integer; lBinomial: boolean): boolean; +begin + if lBinomial then + result := Sum2PowerBinom(lOutImgSum, lVolVox,lnTotal,lnDeficit) + else + result := Sum2PowerCont(lOutImgSum, lVolVox,lnTotal) +end; + +function Sum2PowerCont(lOutImgSum: SingleP; lVolVox,lnTotal: integer): boolean; +//convert Sum image to power map showing maximum possible effect size +//'Cont' version is for continuous data +var + lDensity,lN,lRank: integer; + lDensityPowerRA: singleP; +begin + result := false; + if (lnTotal < 2) or (lVolVox < 1) then + exit; + getmem(lDensityPowerRA,lnTotal* sizeof(single)); + //no need to compute power for [lnTotal] and [0] - no variability when everyone or no one has a lesion + //lDensityPowerRA[lnTotal] := 0; //everyone has a lesion = no variability + lRank := 0; + for lN := 1 to (lnTotal -1) do begin + //most power when all participants with a lesion have most extreme behavioural data + //therefore, they will have the lowest ranks: rank 1,2,3,4 + lRank := lRank + lN; + if (lnTotal > 360) then //cannot calculate values this large... + lDensityPowerRA^[lN] := 0 + else if (lN > 10) and (lnTotal > 64) then //avoid overflow... + lDensityPowerRA^[lN] := pNormalInv ( 1/(k_out_n(10,lnTotal)) ) + else begin + lDensityPowerRA^[lN] := 1/(k_out_n(lN,lnTotal)); //compute Wilcoxon probability + lDensityPowerRA^[lN] := pNormalInv (lDensityPowerRA^[lN]);//convert p to z-score + end; + //max power when every possible person with a lesion has a defict, and everyone w/o lesion does not... + //lDensityPowerRA[lN] := Liebermeister (lLD,lnoLD,lLnoD,lnoLnoD); //probability of this observation + //lDensityPowerRA[lN] := pNormalInv (lDensityPowerRA[lN]);//convert p to z-score + //fx(lDensityPowerRA[lN]); + end; + //now use lookup table to convert overlay density to effective power + for lN := 1 to lVolVox do begin + lDensity := round( lOutImgSum^[lN]); + if (lDensity > 0) and (lDensity < lnTotal) then + lOutImgSum^[lN] := lDensityPowerRA^[lDensity] + else + lOutImgSum^[lN] := 0; + end; //for each voxel + freemem(lDensityPowerRA); + result := true; +end; + +function Sum2PowerBinom(lOutImgSum: SingleP; lVolVox,lnTotal,lnDeficit: integer): boolean; +//convert Sum image to power map showing maximum possible effect size +var + lDensity,lN,lLD,lLnoD,lnoLD,lnoLnoD: integer; + lDensityPowerRA: singleP; +begin + result := false; + if (lnTotal < 2) or (lnDeficit < 1) or (lVolVox < 1) then + exit; + if(lnDeficit >= lnTotal) then begin + showmessage('Sum2Power error: people with deficit must be less than sample size'); + exit; + end; + getmem(lDensityPowerRA,lnTotal* sizeof(single)); + //no need to compute power for lnTotal and 0 - no variability when everyone or no one has a lesion + //lDensityPowerRA[lnTotal] := 0; //everyone has a lesion = no variability + for lN := 1 to (lnTotal -1) do begin + //max power when every possible person with a lesion has a defict, and everyone w/o lesion does not... + if lN > lnDeficit then begin + lLD := lnDeficit; + lLnoD := lN - lnDeficit; + end else begin + lLD := lN; + lLnoD := 0; + end; + lnoLD := lnDeficit-lLD; //number of people with deficit who do not have a lesion - as close to zero as possible + lnoLnoD := lnTotal-lnoLD-lLnoD-lLD; + lDensityPowerRA^[lN] := Liebermeister (lLD,lnoLD,lLnoD,lnoLnoD); //probability of this observation + lDensityPowerRA^[lN] := pNormalInv (lDensityPowerRA^[lN]);//convert p to z-score + //fx(lLD,lnoLD,lLnoD,lnoLnoD,lDensityPowerRA[lN]); + end; + //now use lookup table to convert overlay density to effective power + for lN := 1 to lVolVox do begin + lDensity := round( lOutImgSum^[lN]); + if (lDensity > 0) and (lDensity < lnTotal) then + lOutImgSum^[lN] := lDensityPowerRA^[lDensity] + else + lOutImgSum^[lN] := 0; + + end; //for each voxel + freemem(lDensityPowerRA); + result := true; +end; + + +end. diff --git a/npm_precl/valformat.pas b/npm_precl/valformat.pas new file mode 100755 index 0000000..ed710d8 --- /dev/null +++ b/npm_precl/valformat.pas @@ -0,0 +1,300 @@ +unit valformat; +{$H+} +interface +uses + {$IFNDEF UNIX} Windows,{Registry,ShlObj,}{$ENDIF} + Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Grids, Menus, ToolWin, ComCtrls, Buttons,Clipbrd, StdCtrls, + Spin,define_types,npmform; +const +{$IFDEF FPC} + kNaN = -maxint; +{$ELSE} + kNaN : double = 1/0; +{$ENDIF} + kVALNativeSignatureBase = '#Version:'; + kValMaxVers = 1; //version 0 = 3D, version 1 = 4D, version 2 not yet supported + kTxtExt = '.txt'; + kVALNativeExt = '.val'; + kValFilter = 'Text description (*.val)|*.val'; +function RowColPos (lRow,lCol,lnCol: integer): integer; +function OpenValFile (var lFilename,lTemplateName:string; var lnRow,lnCol,lnColWObs,lnCritPct: integer; + var lDesignUnspecified : boolean; var lPredictorList,lFileList:TStringList; var lDoublePtr: Pointer): boolean; + +function GetValCore (var lVALFilename:string; var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit,lCritPct: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean; + +implementation + +procedure MsgX (lStr: string); +begin + //output something here + showmessage(lStr); +end; + + + +function VALNativeSignature (lStr: string): boolean; +var + lP,lLen: integer; + lVers: string; +begin + result := false; + lLen := length(lStr); + if lLen < (length(kVALNativeSignatureBase)+1) then + exit; + for lP := 1 to length(kVALNativeSignatureBase) do + if lStr[lP] <> kVALNativeSignatureBase[lP] then + exit; + //VAL format, but can we read this version? + for lP := (length(kVALNativeSignatureBase)+1) to lLen do + lVers := lVers + lStr[lP]; + if strtoint(lVers) <= kValMaxVers then + result := true; +end; + +function ReadTabStr (var lStr: string; var lPos: integer): string; +var + lLen: integer; +begin + result := ''; + if lPos < 1 then lPos := 1; + lLen := length(lStr); + while (lPos <= lLen) and (lStr[lPos] <> kTab) do begin + result := result + lStr[lPos]; + inc(lPos); + end; + inc(lPos); +end; + +function RowColPos (lRow,lCol,lnCol: integer): integer; +begin + result := ((lRow-1{alfa})*lnCol)+lCol; +end; + +//Replicates Readln, but works for Unix files... Delphi 4's readln fails for non-MSDOS EOLs +procedure ReadlnX (var F: TextFile; var lResult: string); +var + lCh: char; +begin + lResult := ''; + while not Eof(F) do begin + Read(F, lCh); + if (lCh in [#10,#13]) then begin + if lResult <> '' then begin + //Showmessage(lResult); + exit; + end; + end else + lResult := lResult + lCh; + end; +end; //ReadlnX + +function OpenValFile (var lFilename,lTemplateName:string; var lnRow,lnCol,lnColwObs,lnCritPct: integer; + var lDesignUnspecified : boolean; var lPredictorList,lFileList:TStringList; var lDoublePtr: Pointer): boolean; +var + lNumStr,lStr,lExt,lPrevNumStr,lCmdStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lPos,MaxC,R,C:integer; + lDoubleBuf: DoubleP; + lError: boolean; + lDecimalSep: char; +begin + lnRow := 0; + lnCol := 0; + result := false; + if not fileexists(lFilename) then exit; + lError:= false; + lnCritPct := 0; + lExt := StrLower(PChar(extractfileext(lFilename))); + if (lExt = kTxtExt) or (lExt = kVALNativeExt) then + else begin + Showmessage('This version is unable to recognize the extension of the file: '+lFilename); + exit; + end; + lDecimalSep := DecimalSeparator; + DecimalSeparator := '.'; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + if lExt = kVALNativeExt then begin + ReadlnX(F,lStr);//Version + if not VALNativeSignature(lStr) then begin + showmessage('This software can not read this file. Perhaps you need to upgrade your software. The first line should read "'+kVALNativeSignatureBase+'x" where "x" is <'+inttostr(kValMaxVers+1)); + CloseFile(F); + FileMode := 2; //Set file access to read/write + exit; + end; + lDesignUnspecified := false; + lStr := '#'; + while (length(lStr)> 0) and (lStr[1] = '#') and (not Eof(F)) do begin + ReadlnX(F,lStr); + lPos := 0; //start at beginning of line + lCmdStr := ReadTabStr(lStr,lPos); + if lCmdStr = '#Template' then + lTemplateName := ReadTabStr(lStr,lPos); + if lCmdStr = '#CritPct' then + lnCritPct := StrToInt(ReadTabStr(lStr,lPos)); + end; + if (length(lStr)> 0) and (lStr[1] = '#') then showmessage(lCmdStr); + end else begin + lnCritPct := 0; + lDesignUnspecified := true; + lTemplateName := '-'; + end;//Ext=native version + Reset(F); + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9]) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); +lnRow:= R; +lnCol := MaxC-1; + lnColWObs := lnCol+1; + getmem(lDoublePtr,(lnRow*lnColWObs* sizeof(double))+16); + {$IFDEF FPC} + lDoubleBuf := align(lDoublePtr,16); + {$ELSE} + //lDoubleBuf := DoubleP((integer(lDoublePtr) and $FFFFFFF0)+16); + lDoubleBuf := DoubleP($fffffff0 and (integer(lDoublePtr)+15)); + {$ENDIF} + for C := 1 to (lnRow*lnColWObs) do + lDoubleBuf^[C] := 0; + //Second pass: fill values + Reset(F); + C := 0; + MaxC := 0; + R := 1; + lNumStr := ''; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9]) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + //read current entry + if R = 1 then begin //1st Row + if C > 0 then + lPredictorList.Add( lNumStr) + end else if C = 0 then begin //1st Row + //showmessage(lNumStr); + lFileList.Add( lNumStr) + end else begin //note: below -1 as we strip first header row for predictor names + if lNumStr = '-' then begin + lDoubleBuf^[RowColPos (R-1{ july 06 alfa},C,lnColWObs)] := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading VAL file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := knan; + end; + end; + lDoubleBuf^[RowColPos (R-1{ july 06 alfa},C,lnColWObs)] := lTempFloat;//DataGrid.Cells[ C, kMaxFactors+R-1 ] := (lNumStr) ; + end; + end; + lPrevNumStr := lNumStr; + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C>0) then //alfa read data immediately prior to EOF + lDoubleBuf^[RowColPos (R-1{alfa},C,lnColWObs)] := strtofloat(lNumStr); + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; + DecimalSeparator := lDecimalSep; + //fx(lPredictorList.Count,lnCol); + if lPredictorList.Count < lnCol then begin + for C := (lPredictorList.Count+1) to lnCol do + lPredictorList.Add('Predictor'+inttostr(C)); + end; +end; + + +function GetValCore (var lVALFilename:string; var lnSubj, lnFactors: integer; var lSymptomRA: singleP; var lImageNames: TStrings; var lCrit,lCritPct: integer; {lBinomial : boolean;} var lPredictorList: TStringList):boolean; +//warning: you MUST free lPredictorList +var + lTemplateName: string; + lnRow,lCol,lnColWObs,lInc,lRow: integer; + lDesignUnspecified : boolean; + lFileList:TStringList; + lInRA: DoubleP0; + lInP: Pointer; +begin + lPredictorList := TStringList.Create; + result := false; + lnSubj := 0; + if not Fileexists(lVALFilename) then begin + + MsgX('NPM aborted: VAL file selection failed:' +lValFilename); + exit; + end; //if not selected + lFileList := TStringList.Create; + //MsgX( 'VAL filename: '+lVALFilename); + if not OpenValFile (lVALFilename,lTemplateName, lnRow,lnFactors,lnColWObs,lCritPct, + lDesignUnspecified,lPredictorList,lFileList, lInP) then exit; + + if lnRow > 1 then begin + lnSubj := lnRow -1; //top row is predictor + {$IFDEF FPC} + lInRA := align(lInP,16); + {$ELSE} + lInRA := DoubleP0($fffffff0 and (integer(lInP)+15)); + {$ENDIF} + + getmem(lSymptomRA,lnSubj*lnFactors* sizeof(single)); + for lCol := 1 to lnFactors do begin + for lRow := 1 to lnSubj do begin + lSymptomRA^[lRow+ ((lCol-1)*lnSubj)] := lInRA^[(lRow*lnColWObs)-lnColWObs-1+lCol]; + end; + end; + for lInc := 1 to lnSubj do + lImageNames.add(ExtractFileDirWithPathDelim(lVALFilename)+lFileList.Strings[lInc-1]); + //end reverse + end; //for lRow = each subject + lFileList.free; + Freemem(lInP); + + lCrit := round( (lnSubj*lCritPct)/100); + result := true; +end; + + +end. + diff --git a/npm_precl/windowsxp.res b/npm_precl/windowsxp.res new file mode 100755 index 0000000..5f33505 Binary files /dev/null and b/npm_precl/windowsxp.res differ diff --git a/npm_precl/xLesionStatThds.pas b/npm_precl/xLesionStatThds.pas new file mode 100755 index 0000000..e4f6a5b --- /dev/null +++ b/npm_precl/xLesionStatThds.pas @@ -0,0 +1,446 @@ +unit LesionStatThds; + +interface + +uses + SysUtils, + ComCtrls,Classes, Graphics, ExtCtrls, define_types,stats,StatThdsUtil,Brunner,lesion_pattern; + + + +type + + TLesionStatThread = class(TThread) + private + lBarX: TProgressBar; + lttestx,lBMx: boolean; + lnCritx,lBarPosX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx, + lImagesCountx,lControlsx : integer; + lPlankImgx:ByteP; + lOutImgMnx,lOutImgBMx,lOutImgTx,lOutImgAUCX,lSymptomRAx: SingleP; + //lBarX: TProgressBar; + procedure DoVisualSwap; + protected + procedure Execute; override; + procedure VisualProg(lPos: Integer); + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg:bytep;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); virtual; abstract; + public + constructor Create(lBar: TProgressBar;lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg:ByteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); + end; + + { Lesion - image reveals value } + + TLesionContinuous = class(TLesionStatThread ) + protected + procedure Analyze(lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); override; + end; + + TLesionBinom = class(TLesionStatThread ) + protected + procedure Analyze(lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgL,lOutImgX,lOutImgAUC,lSymptomRA: SingleP); override; + end; + +implementation + +(*procedure OutStr(lStr: string); +var + lOutname: string; + f: TextFile; +begin + lOutname:='c:\fx.txt'; + if fileexists(lOutname) then + begin { open a text file } + AssignFile(f, lOutname); + Append(f); + Writeln(f, lStr); + Flush(f); { ensures that the text was actually written to file } + { insert code here that would require a Flush before closing the file } + CloseFile(f); + end; +end; +*) + +Const Two32 = 4294967296.0 ; +function GenRandThreaded(lRange: integer; var lRandSeed:comp): integer; +//normal random function does not work well when threaded - randseed is changed by each thread +const lFactor = $08088405 ; lTerm = 1 ; +type lT = array [0..1] of longint ; +var + lX: extended; +begin + lRandSeed := lRandSeed*lFactor + lTerm; + lT(lRandSeed)[1] := 0 ; // < May'04 was: RS := RS - Trunc(RS/Two32)*Two32 ; + lX := lRandSeed/Two32 ; + result := trunc((lRange)*lX); +end; + +procedure GenPermuteThreaded (lnSubj: integer; var lOrigOrder,lRanOrder: DoubleP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: double; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj*sizeof(double)); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + + +procedure StatPermuteThreaded (lttest,lBM: boolean; lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: DoubleP0); +var + lInc: integer; + lOutT,lDF,lBMz: double; + lRS: Comp; + lRanOrderp: pointer; + lRanOrder: Doublep0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + createArray64(lRanOrderp,lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreaded(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + if lttest then begin + TStat2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lBM then begin + //BMTest (lnSubj, lnGroup0, lRanOrder,lOutT); + tBM (lnSubj, lnGroup0, lRanOrder,lBMz,lDF); + lBMz := BMzVal (lnSubj, lnGroup0,lBMz,lDF); + + if lBMz > gPermuteMaxBM[lThread,lInc] then + gPermuteMaxBM[lThread,lInc] := lBMz; + if lBMz < gPermuteMinBM[lThread,lInc] then + gPermuteMinBM[lThread,lInc] := lBMz; + end; //compute BM + end; + freemem(lRanOrderp); +end; + +procedure GenPermuteThreadedBinom (lnSubj: integer; var lOrigOrder,lRanOrder: ByteP0; var lRandSeed:comp); +var + lInc,lRand: integer; + lSwap: byte; +begin + Move(lOrigOrder^,lRanOrder^,lnSubj); + for lInc := lnSubj downto 2 do begin + lRand := GenRandThreaded(lInc,lRandSeed); + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc-1]; + lRanOrder^[lInc-1] := lSwap; + end; +end; + +procedure StatPermuteBinomialThreaded (lnSubj, lnGroup0,lnPermute,lThread: integer;var lOrigOrder: ByteP0); +var + lInc: integer; + lOutP: double; + lRS: Comp; + lRanOrder: byteP0; +begin + if (lnSubj < 1) or (lnPermute < 1) then + exit; + //createArray64(lRanOrderp,lRanOrder,lnSubj); + getmem(lRanOrder,lnSubj); + lRS := 128; + for lInc := 1 to lnPermute do begin + GenPermuteThreadedBinom(lnSubj, lOrigOrder,lRanOrder,lRS); //generate random order of participants + (*if lChi2 then begin + Chi2 (lnSubj, lnGroup0, lRanOrder, lOutT); + if lOutT > gPermuteMaxT[lThread,lInc] then + gPermuteMaxT[lThread,lInc] := lOutT; + if lOutT < gPermuteMinT[lThread,lInc] then + gPermuteMinT[lThread,lInc] := lOutT; + end; //compute ttest + if lLieber then begin*) + //Liebermeister2bP (lnSubj, lnGroup0, lRanOrder,lOutP); + Liebermeister2bP (lnSubj, lnGroup0, lRanOrder,lOutP); + if (lOutP > 0) and (lOutP < gPermuteMinT[lThread,lInc]) then begin //negative correlation + //fx(lOutP, gPermuteMinBM[lThread,lInc]); + gPermuteMinT[lThread,lInc] := lOutP; + end; + if (lOutP < 0) and ( lOutP > gPermuteMaxT[lThread,lInc]) then //negative correlation + gPermuteMaxT[lThread,lInc] := lOutP; + //end; //compute BM + end; + freemem(lRanOrder); +end; + +procedure TLesionStatThread .DoVisualSwap; +begin + lBarX.Position := lBarPosX; +end; + +procedure TLesionStatThread .VisualProg(lPos: Integer); +begin + lBarPosX := lPos; + {$IFDEF FPC}Synchronize(@DoVisualSwap); {$ELSE} Synchronize(DoVisualSwap);{$ENDIF} +end; + +constructor TLesionStatThread.Create(lBar: TProgressBar; lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: byteP;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); +begin + lBarX := lBar; + lttestx := lttest; + lBMx:= lBM; + lThreadX := lThread; + lThreadStartX := lThreadStart; + lThreadEndX := lThreadEnd; + lStartVoxx := lStartVox; + lVoxPerPlankx := lVoxPerPlank; + lImagesCountX := lImagesCount; + lControlsX := lControlsIn; + lPlankImgx := lPlankImg; + lOutImgMnx := lOutImgMn; + lOutImgBMx := lOutImgBM; + lOutImgTx := lOutImgT; + lOutImgAUCx := lOutImgAUC; + lSymptomRAx := lSymptomRA; + lnPermuteX := lnPermute; + lnCritX := lnCrit; + FreeOnTerminate := True; + inherited Create(False); +end; + + + +{ The Execute method is called when the thread starts } + +procedure TLesionStatThread .Execute; +begin + Analyze(lttestx,lBMx, lnCritX,lnPermuteX,lThreadx,lThreadStartx,lThreadEndx,lStartVoxx,lVoxPerPlankx,lImagesCountx,lControlsx,lPlankImgX,lOutImgMnx,lOutImgBMx,lOutImgTx,lOutImgAUCx,lSymptomRAx); +end; + + +procedure TLesionContinuous.Analyze (lttest,lBM: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIN : integer; lPlankImg:bytep;lOutImgMn,lOutImgBM,lOutImgT,lOutImgAUC,lSymptomRA: SingleP); +//pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsT,lPrevZValsBM,lPrevAUCVals: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + lStr: string; + lObstp,lObsp: pointer; + lObst,lObs: Doublep0; + lT,lBMz,lDF: Double; + lObsB: bytep0; + lnLesion,lnNoLesion,lPosPct,lPos,lPos2,lPos2Offset,lnControl, + lnControlsPlusLesion,lnControlsPlusPatients : integer; +begin //statthread + //init patterns + lnControl := abs(lControlsIn); + if lControlsIn < 0 then begin //binomial + getmem(lObsB, lImagesCount+lnControl); + end; + lnControlsPlusPatients := lImagesCount+lnControl; + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + //lMaxLesion := lImagesCount-lnCrit; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + createArray64(lObsp,lObs,lnControlsPlusPatients); + lPosPct := (lThreadEnd-lThreadStart) div 100; + //if lThread = 1 then + // OutStr( inttostr(lThreadStart)+':'+inttostr(lThreadEnd)); //xxxxx + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + lnNoLesion := 0; + for lPos := 1 to lImagesCount do begin + if lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2] = 0 then begin + //no lesion + inc(lnNoLesion); + lLesionOrderp^[lPos] := 0; + lObs^[lnNoLesion-1] := lSymptomRA^[lPos]; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + //lObs^[lImagesCount-lnLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + lObs^[lImagesCount-lPos+lnNoLesion] := lSymptomRA^[lPos]; //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) {and (lnLesion <= lMaxLesion)} then begin + inc(gnVoxTestedRA[lThread]); + //now check if we have seen this precise lesion order recently... + lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + if lttest then + lOutImgT^[lPos2Offset] := lPrevZvalsT[lPos]; + if lBM then + lOutImgBM^[lPos2Offset] := lPrevZvalsBM[lPos]; + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lPrevAUCvals[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + lnControlsPlusLesion := lnControlsPlusPatients; + if (lControlsIn > 0) {and (lnLesion > 0)} then begin //anaCOm + createArray64(lObstp,lObst,lImagesCount); + for lPos := 1 to lImagesCount do + lObst^[lPos-1] := lObs^[lPos-1]; + for lPos := 1 to lnLesion do + lObs^[lPos-1+lnControl] := lObst^[lPos-1+lnNoLesion]; + freemem(lObstP); + for lPos := 1 to lnControl do + lObs^[lPos-1] := lSymptomRA^[lPos+lImagesCount]; + lnControlsPlusLesion := lnControl+lnLesion; + lnNoLesion := {lnNoLesion +} lnControl; + end;//controls + (*if lPos2 = 2570879 then begin //xxxx + for lPos := 1 to lImagesCount do begin + outstr(inttostr(lPos)+'>'+floattostr(lObs^[lPos-1]) ); + end; + end;*) + + if lttest then begin + if lControlsIn > 0 then begin//anacom + TStat2Z (lnControlsPlusLesion, lnControl {lnNoLesion},lObs,lT); +(* if lPos2 = 2570879 then begin + outstr( floattostr(lT)+ ' '+inttostr(lnControl)); //xxxx + for lPos := 1 to lnControlsPlusLesion do begin + outstr(inttostr(lPos)+', '+floattostr(lObs^[lPos-1]) ); + end; + + end; *) + end else + TStat2 (lnControlsPlusLesion, lnNoLesion, lObs,lT); + lOutImgT^[lPos2Offset] := lT; + lPrevZValsT[lPatternPos] := lT; + end; + + if lBM then begin + tBM (lnControlsPlusLesion, lnNoLesion, lObs,lBMz,lDF); + lBMz := BMzVal (lnControlsPlusPatients, lnNoLesion,lBMz,lDF); + lOutImgBM^[lPos2Offset] := lBMz; + lPrevZValsBM[lPatternPos] := lBMz; + end; + if lOutImgAUC <> nil then begin + lOutImgAUC^[lPos2Offset] := continROC (lnControlsPlusLesion, lnNoLesion, lObs); + lPrevAUCVals[lPatternPos] := lOutImgAUC^[lPos2Offset]; + end; + StatPermuteThreaded (lttest,lBM,lImagesCount, lnNoLesion,lnPermute,lThread, lObs); + end; //novel lesion pattern + end; //in brain mask - compute + end; //for each voxel + freemem(lObsP); + freemem(lLesionOrderp); + if lControlsIn < 0 then //binomial + freemem(lObsB); + + +end; + +procedure TLesionBinom.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lControlsIn : integer; lPlankImg: bytep;lOutImgMn,lOutImgL,lOutImgX,lOutImgAUC,lSymptomRA: SingleP); +//procedure TLesionBinomial.Analyze (lChi2,lLieber: boolean; lnCrit,lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImagesCount,lnGroup1 : integer; lMaskImg,lPlankImg,lOutImgMn,lOutImgL,lOutImgX,lSymptomRA: SingleP); + //pattern variables +const + knPrevPattern = 10; +var + lPrevPatternRA: array[1..knPrevPattern] of TLesionPattern; + lPattern: TLesionPattern; + lPrevZValsL ,lPrevAUCVals: array [1..knPrevPattern] of Single; + lPatternPos: integer; + lLesionOrderp: bytep; +//standard variables +var + //lObsp: pointer; + //lObs: Doublep0; lPrevZVals + lObs: ByteP0; + lAUC,lZ: Double; + lnLesion,lPosPct,lPos,lPos2,lPos2Offset,lnVoxTested: integer; +begin //Binomial StatThread + //init patterns + for lPatternPos := 1 to knPrevPattern do + lPrevPatternRA[lPatternPos] := EmptyOrder; + lPatternPos := 1; + getmem(lLesionOrderp, lImagesCount *sizeof(byte)); + //now init standard variables + //createArray64(lObsp,lObs,lImagesCount); + getmem(lObs,lImagesCount); + lPosPct := (lThreadEnd-lThreadStart) div 100; + + for lPos2 := lThreadStart to lThreadEnd do begin + if (lThread = 1) and ((lPos2 mod lPosPct) = 0) then + VisualProg(round((lPos2/(lThreadEnd-lThreadStart))*100)); + if Terminated then exit; //goto 345;//abort + lPos2Offset := lPos2+lStartVox-1; + lnLesion := 0; + for lPos := 1 to lImagesCount do begin + if ((gScaleRA[lPos]*lPlankImg^[((lPos-1)* lVoxPerPlank)+lPos2])+gInterceptRA[lPos]) = 0 then begin + //no lesion + lObs^[lImagesCount-lPos+lnLesion] := round(lSymptomRA^[lPos]); + lLesionOrderp^[lPos] := 0; + end else begin + //lesion + inc(lnLesion); + lLesionOrderp^[lPos] := 1; + lObs^[lnLesion-1] := round(lSymptomRA^[lPos]); //note: lObs indexed from zero! + end; + end; + lOutImgMn^[lPos2Offset] := lnLesion;///lImages.Count; + if (lnLesion >= lnCrit) and (lnLesion > 0) then begin + inc(gnVoxTestedRA[lThread]); + //next check patterns + //x lPattern := SetOrderX (lLesionOrderp,lImagesCount); + lPos := 1; + while (lPos <= knPrevPattern) and not (SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount)) do + inc(lPos); + if SameOrder(lPattern,lPrevPatternRA[lPos],lImagesCount) then begin //lesion pattern is not novel + //if lChi2 then + // lOutImgX^[lPos2Offset] := lPrevZvalsX[lPos]; + //if lLieber then + lOutImgL^[lPos2Offset] := lPrevZvalsL[lPos]; + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lPrevAUCvals[lPos]; + end else begin //lesion pattern is novel + //record novel pattern + inc(lPatternPos); + if lPatternPos > knPrevPattern then + lPatternPos := 1; + lPrevPatternRA[lPatternPos] := lPattern; + {if lChi2 then begin + Chi2 (lImagesCount, lnLesion, lObs,lT); + lOutImgX^[lPos2Offset] := lT;//lT; + lPrevZValsX[lPatternPos] := lT; + end; + if lLieber then begin} + Liebermeister2b(lImagesCount, lnLesion, lObs,lAUC,lZ); + if lOutImgAUC <> nil then + lOutImgAUC^[lPos2Offset] := lAUC; + lPrevAUCVals[lPatternPos] := lAUC; + lOutImgL^[lPos2Offset] := lZ; + lPrevZValsL[lPatternPos] := lZ; + //end; + StatPermuteBinomialThreaded (lImagesCount, lnLesion,lnPermute,lThread, lObs); + + end; + end; //in brain mask - compute + end; //for each voxel + freemem(lObs); + freemem(lLesionOrderp) +end; + +end. diff --git a/npm_precl/xanacom.pas b/npm_precl/xanacom.pas new file mode 100755 index 0000000..667ff44 --- /dev/null +++ b/npm_precl/xanacom.pas @@ -0,0 +1,630 @@ +unit anacom; +interface +{$H+} +uses + define_types,SysUtils,part,StatThds,statcr,StatThdsUtil,Brunner, + DISTR,nifti_img, hdr,filename,Messages, Classes, Graphics, + Controls, Forms, Dialogs,StdCtrls,ComCtrls,ExtCtrls,Menus, overlap, + ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + upower,firthThds,firth,IniFiles,cpucount,userdir,math, + {$IFDEF FPC} LResources,gzio2, + {$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math + {$IFNDEF UNIX} Windows, {$ENDIF} + regmult,utypes; + + function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; + procedure DoAnaCOM; + function readTxt (lFilename: string; var lnObservations : integer; var ldataRA1: singlep): boolean; + + +implementation + +uses npmform; + +{$DEFINE NOTmedianfx} +function AnacomLesionNPMAnalyze (var lImages: TStrings; var lMaskHdr: TMRIcroHdr; lnCrit,lRun,lnControl: integer; var lSymptomRA,lControlSymptomRA: SingleP;var lFactname,lOutName: string; lttestIn,lBMIn: boolean): boolean; +label + 123,667; +var + lOutNameMod: string; + lPlankImg: byteP; + lOutImgSum,lOutImgBM,lOutImgT, + lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM,lCombinedSymptomRA: singleP; + lPos,lPlank,lThread,lnControlsPlusPatients: integer; + lVolVox,lMinMask,lMaxMask,lTotalMemory,lnPlanks,lVoxPerPlank, + lThreadStart,lThreadEnd,lThreadInc,lnLesion,lnPermute, + lPos2,lPos2Offset,lStartVox,lEndVox,lPlankImgPos,lnTests,lnVoxTested,lPosPct: int64; + lT,lBMz, lSum,lThresh,lThreshBonf,lThreshPermute,lThreshNULP :double; + lObsp: pointer; + lObs: Doublep0; + lStatHdr: TNIfTIhdr; + lFdata: file; + lRanOrderp: pointer; + lRanOrder: Doublep0; + lSave,lBM,lttest,lLtest: boolean; + lnControlNeg: integer; + + {$IFDEF medianfx} + lmedianFX,lmeanFX,lsummean,lsummedian: double; + lmediancount: integer; + {$ENDIF} +begin + lSave := true; + lnControlNeg := lnControl; //negative for binomial test + lttest := lttestin; + lbm := lbmin; + if (not (lttest)) and (not (lbm)) then begin + lLtest := true; + lBM := true; + lnControlNeg := -lnControl; + end; + //lttest:= ttestmenu.checked; + //lBM := BMmenu.checked; + if lnControl < 1 then begin + MainForm.NPMmsg('AnaCOM aborted - need data from at least 1 control individual'); + exit; + end; + lnPermute := 0;//MainForm.ReadPermute; + MainForm.NPMmsg('Permutations = ' +IntToStr(lnPermute)); + MainForm.NPMmsg('Analysis began = ' +TimeToStr(Now)); + lTotalMemory := 0; + lVolVox := lMaskHdr.NIFTIhdr.dim[1]*lMaskHdr.NIFTIhdr.dim[2]* lMaskHdr.NIFTIhdr.dim[3]; + if (lVolVox < 1) then goto 667; + lMinMask := 1; + lMaxMask := lVolVox; + lVoxPerPlank := kPlankSz div lImages.Count div sizeof(byte) ; + if (lVoxPerPlank = 0) then goto 667; //no data + lTotalMemory := ((lMaxMask+1)-lMinMask) * lImages.Count; + if (lTotalMemory = 0) then goto 667; //no data + lnPlanks := trunc(lTotalMemory/(lVoxPerPlank*lImages.Count) ) + 1; + MainForm.NPMmsg('Memory planks = ' +Floattostr(lTotalMemory/(lVoxPerPlank*lImages.Count))); + MainForm.NPMmsg('Max voxels per Plank = ' +Floattostr(lVoxPerPlank)); + if (lnPlanks = 1) then + getmem(lPlankImg,lTotalMemory) //assumes 1bpp + else + getmem(lPlankImg,kPlankSz); + lStartVox := lMinMask; + lEndVox := lMinMask-1; + {$IFDEF medianfx} + lsummean := 0; + lsummedian:= 0; + lmediancount := 0; + {$ENDIF} + for lPos := 1 to lImages.Count do + if gScaleRA[lPos] = 0 then + gScaleRA[lPos] := 1; + lnControlsPlusPatients := lImages.Count+lnControl; + createArray64(lObsp,lObs,lnControlsPlusPatients); + getmem(lOutImgSum,lVolVox* sizeof(single)); + getmem(lOutImgBM,lVolVox* sizeof(single)); + getmem(lOutImgT,lVolVox* sizeof(single)); + MainForm.InitPermute (lImages.Count, lnPermute, lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp, lRanOrder); + for lPos := 1 to lVolVox do begin + lOutImgSum^[lPos] := 0; + lOutImgBM^[lPos] := 0; + lOutImgT^[lPos] := 0; + end; + //sumptom array for lesions AND controls + for lPos := 1 to lImages.Count do + lObs^[lPos-1] := lSymptomRA^[lPos]; + for lPos := 1 to lnControl do + lObs^[lPos-1+lImages.Count] := lControlSymptomRA^[lPos]; + getmem(lCombinedSymptomRA,lnControlsPlusPatients* sizeof(single)); + for lPos := 1 to lnControlsPlusPatients do + lCombinedSymptomRA^[lPos] := lObs^[lPos-1]; + //next create permuted BM bounds + if lBM then begin + MainForm.NPMmsg('Generating BM permutation thresholds'); + MainForm.Refresh; + //for lPos := 1 to lImages.Count do + // lObs^[lPos-1] := lSymptomRA^[lPos]; + genBMsim (lnControlsPlusPatients, lObs); + end; + ClearThreadData(gnCPUThreads,lnPermute) ; + for lPlank := 1 to lnPlanks do begin + MainForm.NPMmsg('Computing plank = ' +Inttostr(lPlank)); + MainForm.Refresh; + Application.processmessages; + lEndVox := lEndVox + lVoxPerPlank; + if lEndVox > lMaxMask then begin + lVoxPerPlank := lVoxPerPlank - (lEndVox-lMaxMask); + lEndVox := lMaxMask; + end; + lPlankImgPos := 1; + for lPos := 1 to lImages.Count do begin + if not LoadImg8(lImages[lPos-1], lPlankImg, lStartVox, lEndVox,round(gOffsetRA[lPos]),lPlankImgPos,gDataTypeRA[lPos],lVolVox) then + goto 667; + lPlankImgPos := lPlankImgPos + lVoxPerPlank; + end;//for each image + //threading start + lThreadStart := 1; + lThreadInc := lVoxPerPlank div gnCPUThreads; + lThreadEnd := lThreadInc; + Application.processmessages; + for lThread := 1 to gnCPUThreads do begin + if lThread = gnCPUThreads then + lThreadEnd := lVoxPerPlank; //avoid integer rounding error + + with TLesionContinuous.Create (MainForm.ProgressBar1,lttest,lBM,lnCrit, lnPermute,lThread,lThreadStart,lThreadEnd,lStartVox,lVoxPerPlank,lImages.Count,lnControlNeg,lPlankImg,lOutImgSum,lOutImgBM,lOutImgT,nil,lCombinedSymptomRA) do + {$IFDEF FPC} OnTerminate := @MainForm.ThreadDone; {$ELSE}OnTerminate := MainForm.ThreadDone;{$ENDIF} + inc(gThreadsRunning); + lThreadStart := lThreadEnd + 1; + lThreadEnd :=lThreadEnd + lThreadInc; + end; //for each thread + repeat + Application.processmessages; + until gThreadsRunning = 0; + Application.processmessages; + //threading end + lStartVox := lEndVox + 1; + end; + lThreshPermute := 0; + lnVoxTested := SumThreadData(gnCPUThreads,lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM); + //next report findings + if lnVoxTested < 1 then begin + MainForm.NPMmsg('**Error: no voxels tested: no regions lesioned in at least '+inttostr(lnCrit)+' patients**'); + goto 123; + end; + + MainForm.NPMmsg('Voxels tested = ' +Inttostr(lnVoxTested)); + {$IFDEF medianfx} + MainForm.NPMmsg('Average MEAN effect size = ' +realtostr((lsummean/lmediancount),3)); + MainForm.NPMmsg('Average MEDIAN effect size = ' +realtostr((lsummedian/lmediancount),3)); + {$ENDIF} + MainForm.NPMmsg('Only tested voxels with more than '+inttostr(lnCrit)+' lesions'); + //Next: save results from permutation thresholding.... + //Next: save results from permutation thresholding.... + lThreshBonf := MainForm.reportBonferroni('Std',lnVoxTested); + //Next: NULPS + if lRun > 0 then //terrible place to do this - RAM problems, but need value to threshold maps + lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap2 (lImages, lnCrit,lnVoxTested,lPlankImg)); + + //lThreshNULP := MainForm.reportBonferroni('Unique overlap',CountOverlap (lImages, lnCrit)); + //next: save data + MakeHdr (lMaskHdr.NIFTIhdr,lStatHdr); +//save sum map + lOutNameMod := ChangeFilePostfixExt(lOutName,'Sum'+lFactName,'.hdr'); + if (lSave) and (lRun < 1) then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); +//create new header - subsequent images will use Z-scores + MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); + if (lSave) and (lRun < 1) and (Sum2PowerCont(lOutImgSum,lVolVox,lImages.Count)) then begin + lOutNameMod := ChangeFilePostfixExt(lOutName,'Power'+lFactName,'.hdr'); + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgSum,1); + end; + + //MakeStatHdr (lMaskHdr.NIFTIhdr,lStatHdr,-6, 6,1{df},0,lnVoxTested,kNIFTI_INTENT_ZSCORE,inttostr(lnVoxTested) ); +if lttest then begin //save Ttest + //next: convert t-scores to z scores + + if lnControl < 1 then //do not convert t-scores for anaCOM - numbers vary from voxel to voxel... + for lPos := 1 to lVolVox do + lOutImgT^[lPos] := TtoZ (lOutImgT^[lPos],lImages.Count-2); + for lPos := 1 to lnPermute do begin + lPermuteMaxT^[lPos] := TtoZ (lPermuteMaxT^[lPos],lImages.Count-2); + lPermuteMinT^[lPos] := TtoZ (lPermuteMinT^[lPos],lImages.Count-2); + end; + lThresh := MainForm.reportFDR ('ttest', lVolVox, lnVoxTested, lOutImgT); + lThreshPermute := MainForm.reportPermute('attest',lnPermute,lPermuteMaxT, lPermuteMinT); + lOutNameMod := ChangeFilePostfixExt(lOutName,'attest'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaComthreshtt,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgT))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + if lSave then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgT,1); + +end; +if lBM then begin //save Mann Whitney + lThresh := MainForm.reportFDR ('BM', lVolVox, lnVoxTested, lOutImgBM); + lThreshPermute := MainForm.reportPermute('aBM',lnPermute,lPermuteMaxBM, lPermuteMinBM); + lOutNameMod := ChangeFilePostfixExt(lOutName,'aBM'+lFactName,'.hdr'); + if lRun > 0 then + MainForm.NPMmsgAppend('AnaCOMthreshbm,'+inttostr(lRun)+','+inttostr(MainForm.ThreshMap(lThreshNULP,lVolVox,lOutImgBM))+','+realtostr(lThreshNULP,3)+','+realtostr(lThreshPermute,3)+','+realtostr(lThreshBonf,3)); + if lSave then + NIFTIhdr_SaveHdrImg(lOutNameMod,lStatHdr,true,not IsNifTiMagic(lMaskHdr.NIFTIhdr),true,lOutImgBM,1); +end; +//next: free dynamic memory +123: + MainForm.FreePermute (lnPermute,lPermuteMaxT, lPermuteMinT,lPermuteMaxBM, lPermuteMinBM, lRanOrderp); + freemem(lOutImgT); + freemem(lOutImgBM); + freemem(lOutImgSum); + freemem(lObsp); + freemem(lPlankImg); + freemem(lCombinedSymptomRA); + MainForm.NPMmsg('Analysis finished = ' +TimeToStr(Now)); + lOutNameMod := ChangeFilePostfixExt(lOutName,'Notes'+lFactName,'.txt'); + if lSave then + MainForm.MsgSave(lOutNameMod); + MainForm.ProgressBar1.Position := 0; + exit; +667: //you only get here if you aborted ... free memory and report error + if lTotalMemory > 1 then freemem(lPlankImg); + MainForm.NPMmsg('Unable to complete analysis.'); + MainForm.ProgressBar1.Position := 0; +end; //LesionNPMAnalyze + + + +(*function readCSV2 (lFilename: string; lCol1,lCol2: integer; var lnObservations : integer; var ldataRA1,ldataRA2: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; + +begin + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) or (MaxC < (kHdrCol+lCol2)) then begin + showmessage('problems reading CSV - not enough columns/rows '+inttostr(lCol1)+' '+inttostr(lCol2)); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := MaxC-1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + getmem(ldataRA2,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) or ((C-kHdrCol) = lCol2) then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then + ldataRA1^[R-kHdrRow] := lTempFloat + else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat; + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + ldataRA2^[R-1] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := true; +end; *) + +function readTxt (lFilename: string; var lnObservations : integer; var ldataRA1: singlep): boolean; +const + kHdrRow = 0;//1; + kHdrCol = 0;//1; +var + lCol1: integer; + lNumStr: string; + F: TextFile; + lTempFloat: double; + lCh: char; + lnFactors,MaxC,R,C:integer; + lError: boolean; +begin + lCol1:= 1; + lError := false; + result := false; + if not fileexists(lFilename) then begin + showmessage('Can not find '+lFilename); + exit; + end; + AssignFile(F, lFilename); + FileMode := 0; //Set file access to read only + //First pass: determine column height/width + Reset(F); + C := 0; + MaxC := 0; + R := 0; + while not Eof(F) do begin + //read next line + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 0; + inc(R); + + end; //eoln + end; //if lNumStr <> '' and not tab + end; + if lNumStr <> '' then //july06- read data immediately prior to EOF + inc(R); + + if (R <= (kHdrRow+1)) or (MaxC < (kHdrCol+lCol1)) then begin + showmessage('problems reading CSV - not enough columns/rows '); + exit; + end; + + lnObservations := R -kHdrRow ; //-1: first row is header.... + lnFactors := kHdrCol+lCol1;// -1: first column is Y values + //fx(lnObservations,lnFactors); + + //exit; + getmem(ldataRA1,lnObservations*sizeof(single)); + + //second pass + Reset(F); + C := 1; + MaxC := 0; + R := 1; + lNumStr := ''; + lTempfloat := 0; + while not Eof(F) do begin + //read next line + Read(F, lCh); + if lCh = '#' then + while not (lCh in [#10,#13]) do + Read(F, lCh) + else if not (lCh in [#10,#13,#9,',']) then begin + lNumStr := lNumStr + lCh; + end else if lNumStr <> '' then begin + if (R > kHdrRow) and (C > kHdrCol) then begin + if ((C-kHdrCol) = lCol1) {or ((C-kHdrCol) = lCol2)} then begin + if lNumStr = '-' then begin + lTempFloat := 0; + end else begin //number + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(lNumStr); + if (C-kHdrCol) = lCol1 then begin + //showmessage(lNumStr); + ldataRA1^[R-kHdrRow] := lTempFloat; + end; + {else if (C-kHdrCol) = lCol2 then + ldataRA2^[R-kHdrRow] := lTempFloat;} + end; //number + end; //col1 or col2 + end;// else //R > 1 + + lNumStr := ''; + inc(C); + if C > MaxC then + MaxC := C; + if (lCh in [#10,#13]) then begin + C := 1; + inc(R); + end; //eoln + end; //if lNumStr <> '' and not tab + end; + //showmessage(lNumStr+' '+inttostr(lnFactors)+' '+inttostr(C)); + if (lNumStr <> '') and (C = lnFactors) then begin //unterminated string + + try + lTempFloat := strtofloat(lNumStr); + except + on EConvertError do begin + if not lError then + showmessage('Empty cells? Error reading CSV file row:'+inttostr(R)+' col:'+inttostr(C)+' - Unable to convert the string '+lNumStr+' to a number'); + lError := true; + lTempFloat := nan; + end; + end;//except + //showmessage(inttostr(R)+' '+floattostr(lTempFLoat)); + ldataRA1^[R] := lTempFloat; + end;//unterminated string + //read finel item + CloseFile(F); + FileMode := 2; //Set file access to read/write + result := not lError; +end; + +procedure DoAnaCOM; +label + 666; +var + lControlFilename: string; + lI, lnControlObservations : integer; + lControldata: singlep; + //lBinomial: boolean; + lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lTemp4D,lMaskname,lOutName,lFactname: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA: singleP; +begin + npmform.MainForm.memo1.lines.clear; + npmform.MainForm.memo1.lines.add('AnaCOM analysis requires TXT/CSV format text file.'); + npmform.MainForm.memo1.lines.add('One row per control participant.'); + npmform.MainForm.memo1.lines.add('First column is performance of that participant.'); + npmform.MainForm.memo1.lines.add('Example file:'); + npmform.MainForm.memo1.lines.add('11'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('2'); + npmform.MainForm.memo1.lines.add('22'); + npmform.MainForm.memo1.lines.add('19'); + npmform.MainForm.memo1.lines.add('6'); + if not MainForm.OpenDialogExecute('Select text file',false,false,'Text file (*.txt)|*.txt;*.csv') then begin + showmessage('AnaCOM aborted: Control data file selection failed.'); + exit; + end; //if not selected + lControlFilename := MainForm.OpenHdrDlg.Filename; + if (not readTxt (lControlFilename, lnControlObservations,lControldata)) or (lnControlObservations < 1) then begin + showmessage('Error reading file '+lControlFilename); + exit; + end; + npmform.MainForm.memo1.lines.add('Control (n='+inttostr(lnControlObservations)+')performance ['+lControlFilename+']'); + for lI := 1 to lnControlObservations do + npmform.MainForm.memo1.lines.add(inttostr(lI)+' '+floattostr(lControldata^[lI])); + //begin - copy + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + //next, get 1st group + if not MainForm.GetValX(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit,{,binom}lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) then begin + Showmessage('AnaCOM error: not enough patients ('+inttostr(lnSubjAll)+') or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st file: '+lMaskName); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then exit; + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + MainForm.NPMmsgClear; + MainForm.NPMMsg(MainForm.GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + npmform.MainForm.memo1.lines.add('Control (n='+inttostr(lnControlObservations)+')performance ['+lControlFilename+']'); + for lI := 1 to lnControlObservations do + npmform.MainForm.memo1.lines.add(inttostr(lI)+' '+floattostr(lControldata^[lI])); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Patient performance, (n= '+inttostr(lnSubj)+') Factor = '+lFactname); + For lSubj := 1 to lnSubj do + MainForm.NPMMsg (lImageNames.Strings[lSubj-1] + ' = '+realtostr(lSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(lnSubj)); + if not CheckVoxelsGroup(lImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + MainForm.ReportDescriptives(lSymptomRA,lnSubj); + AnacomLesionNPMAnalyze(lImageNames,lMaskHdr,lnCrit,-1,lnControlObservations,lSymptomRA,lControldata,lFactName,lOutname,true {ttest},false{BM}); + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then + Freemem(lMultiSymptomRA); + 666: + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + DeleteDecompressed4D(lTemp4D); + freemem(lControldata); +end; + +end. diff --git a/npm_precl/xmontecarlo.pas b/npm_precl/xmontecarlo.pas new file mode 100755 index 0000000..08d36a1 --- /dev/null +++ b/npm_precl/xmontecarlo.pas @@ -0,0 +1,210 @@ +unit montecarlo; +interface +{$H+} +{$DEFINE anacom} +uses + define_types,SysUtils, +part,StatThds,statcr,StatThdsUtil,Brunner,DISTR,nifti_img, hdr, + Messages, Classes, Graphics, Controls, Forms, Dialogs, +StdCtrls, ComCtrls,ExtCtrls,Menus, overlap,ReadInt,lesion_pattern,stats,LesionStatThds,nifti_hdr, + +{$IFDEF FPC} LResources,gzio2, +{$ELSE} gziod,associate,{$ENDIF} //must be in search path, e.g. C:\pas\mricron\npm\math +{$IFNDEF UNIX} Windows, {$ENDIF} +upower,firthThds,firth,IniFiles,cpucount,userdir,math, +regmult,utypes{$IFDEF anacom} ,anacom{$ENDIF}; + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); + +implementation + +uses npmform,filename,turbolesion; + +procedure RandomGroup(kSamplesPerTest: integer;lImageNames: TStrings;lSymptomRA: SingleP;var lPartImageNames: TStrings; var lPartSymptomRA: SingleP); +var + lTotal,lInc,lRand,lSwap: integer; + lRanOrder: longintP; +begin + lPartImageNames.Clear; + lTotal := lImageNames.Count; + if kSamplesPerTest > lTotal then begin + showmessage('Monte carlo error: population must be larger than sample size.'); + exit; + end; + Getmem(lRanOrder,lTotal*sizeof(longint)); + for lInc := 1 to lTotal do + lRanOrder^[lInc] := lInc; + for lInc := lTotal downto 2 do begin + lRand := Random(lInc)+1; + lSwap := lRanOrder^[lRand]; + lRanOrder^[lRand] := lRanOrder^[lInc]; + lRanOrder^[lInc] := lSwap; + end; + for lInc := 1 to kSamplesPerTest do begin + lPartImageNames.Add(lImageNames.Strings[lRanOrder^[lInc]-1]);//indexed from 0 + lPartSymptomRA^[lInc] := lSymptomRA^[lRanOrder^[lInc]]; + end; + Freemem(lRanOrder); +end; + + +procedure LesionMonteCarlo (lBinomial,lTTest,lBM: boolean); +label + 666; +//const + //kSimSampleSize = 64; + //knSim = 2; + //kCrit = 3; + {$IFDEF anacom} + //knControls = 64; + {$ENDIF} +var + lPrefs: TLDMPrefs ; + lCrit,lnSim, lSimSampleSize,lSim,lFact,lnFactors,lSubj,lnSubj,lnSubjAll,lMaskVoxels,lnCrit: integer; + lPartImageNames,lImageNames,lImageNamesAll: TStrings; + lPredictorList: TStringList; + lControlFilename,lTemp4D,lMaskname,lOutName,lFactname,lOutNameSim: string; + lMaskHdr: TMRIcroHdr; + lMultiSymptomRA,lSymptomRA,lPartSymptomRA: singleP; + {$IFDEF anacom} + lnControlObservations: integer; + lControlSymptomRA: singleP; + {$ENDIF} +begin + lnSim := ReadIntForm.GetInt('Enter total numbers of simulations ', 10,25,1000); + lSimSampleSize := ReadIntForm.GetInt('Number of patients per simulation? ', 2,10,1000); + lCrit := ReadIntForm.GetInt('Only analyze voxels damaged in at least N patients ', 2,10,1000); + //lBinomial := not odd( (Sender as tMenuItem).tag); + lPrefs.NULP := true{gNULP false}; + if not lBinomial then begin + lPrefs.BMtest := lbm;//BMmenu.checked; + lPrefs.Ttest := lttest;//ttestmenu.checked; + if (not lPrefs.BMtest) and (not lPrefs.ttest) then + lPrefs.ttest := true; + lPrefs.Ltest:= false; + end else begin + lPrefs.BMtest := false; + lPrefs.Ttest := false; + lPrefs.Ltest:= true; + end; + lPrefs.nCrit := lCrit; + lPrefs.nPermute := 0;//MainForm.ReadPermute;; + lPrefs.Run := 0;{0 except for montecarlo} + if (not lBinomial) and (not lTTest) and (not lBM) then begin + Showmessage('Error: you need to compute at least on test [options/test menu]'); + exit; + end; + lImageNamesAll:= TStringList.Create; //not sure why TStrings.Create does not work??? + lImageNames:= TStringList.Create; //not sure why TStrings.Create does not work??? + lPartImageNames := TStringList.Create; + getmem(lPartSymptomRA,lSimSampleSize*sizeof(single)); + {$IFDEF anacom} + if not MainForm.OpenDialogExecute('Select text file',false,false,'Text file (*.txt)|*.txt;*.csv') then begin + showmessage('AnaCOM aborted: Control data file selection failed.'); + exit; + end; //if not selected + lControlFilename := MainForm.OpenHdrDlg.Filename; + if (not readTxt (lControlFilename, lnControlObservations,lControlSymptomRA)) or (lnControlObservations < 1) then begin + showmessage('Error reading file '+lControlFilename); + exit; + end; + + //lnControlObservations := knControls; + //getmem(lControlSymptomRA,lnControlObservations*sizeof(single)); + //for lSim := 1 to lnControlObservations do + // lControlSymptomRA^[lSim] := 1000; + {$ENDIF} + //next, get 1st group + if not MainForm.GetValX(lnSubjAll,lnFactors,lMultiSymptomRA,lImageNamesAll,lnCrit{,binom},lPredictorList) then begin + showmessage('Error with VAL file'); + goto 666; + end; + lTemp4D := CreateDecompressed4D(lImageNamesAll); + if (lnSubjAll < 1) or (lnFactors < 1) or (lnSubjAll < lSimSampleSize) then begin + Showmessage('Not enough subjects ('+inttostr(lnSubjAll)+') [sample size is '+inttostr(lSimSampleSize)+']or factors ('+inttostr(lnFactors)+').'); + goto 666; + end; + lMaskname := lImageNamesAll[0]; + if not NIFTIhdr_LoadHdr(lMaskname,lMaskHdr) then begin + showmessage('Error reading 1st mask.'); + goto 666; + end; + lMaskVoxels := ComputeImageDataBytes8bpp(lMaskHdr); + if (lMaskVoxels < 2) or (not CheckVoxels(lMaskname,lMaskVoxels,0)){make sure there is uncompressed .img file} then begin + showmessage('Mask file size too small.'); + goto 666; + end; + lOutName := ExtractFileDirWithPathDelim(lMaskName)+'results'; + MainForm.SaveHdrDlg.Filename := loutname; + lOutName := lOutName+'.nii.gz'; + if not MainForm.SaveHdrName ('Base Statistical Map', lOutName) then goto 666; + + for lFact := 1 to lnFactors do begin + lImageNames.clear; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then {$ENDIF} + lImageNames.Add(lImageNamesAll[lSubj-1]); + lnSubj := lImageNames.Count; + if lnSubj > 1 then begin + getmem(lSymptomRA,lnSubj * sizeof(single)); + lnSubj := 0; + for lSubj := 1 to lnSubjAll do + {$IFNDEF FPC}if lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)] <> NaN then begin + {$ELSE} begin{$ENDIF} + inc(lnSubj); + lSymptomRA^[lnSubj] := lMultiSymptomRA^[lSubj+((lFact-1)*lnSubjAll)]; + end; + //randomization loop.... + for lSim := 1 to lnSim do begin + RandomGroup(lSimSampleSize, lImageNames,lSymptomRA, lPartImageNames, lPartSymptomRA); + lOutNameSim := AddIndexToFilename(lOutName,lSim); + lnCrit := lCrit; + MainForm.NPMMsgClear; + //Msg(GetKVers); + MainForm.NPMMsg('Threads: '+inttostr(gnCPUThreads)); + lFactName := lPredictorList.Strings[lFact-1]; + lFactName := LegitFilename(lFactName,lFact); + MainForm.NPMMsg('Factor = '+lFactname); + For lSubj := 1 to lSimSampleSize do + MainForm.NPMMsg (lPartImageNames.Strings[lSubj-1] + ' = '+realtostr(lPartSymptomRA^[lSubj],2) ); + MainForm.NPMMsg('Total voxels = '+inttostr(lMaskVoxels)); + MainForm.NPMMsg('Only testing voxels damaged in at least '+inttostr(lnCrit)+' individual[s]'); + MainForm.NPMMsg('Number of Lesion maps = '+inttostr(lSimSampleSize)); + if not CheckVoxelsGroup(lPartImageNames,lMaskVoxels) then begin + showmessage('File dimensions differ from mask.'); + goto 666; + end; + lPrefs.Run := lSim; + if lBinomial then + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim) + else begin + MainForm.ReportDescriptives(lPartSymptomRA,lnSubj); + TurboLDM (lPartImageNames, lMaskHdr, lPrefs, lPartSymptomRA, lFactname,lOutNameSim); + {$IFDEF anacom} + AnacomLesionNPMAnalyze (lPartImageNames, lMaskHdr, lnCrit,lSim,lnControlObservations, lPartSymptomRA,lControlSymptomRA, lFactname,lOutNameSim,true,false); + {$ENDIF} + end; + end; //for each simulation... + Freemem(lSymptomRA); + end; //lnsubj > 1 + end; //for each factor + if lnSubjAll > 0 then begin + Freemem(lMultiSymptomRA); + end; + 666: + lPartImageNames.free; + lImageNames.Free; + lImageNamesAll.Free; + lPredictorList.Free; + freemem(lPartSymptomRA); + {$IFDEF anacom} + freemem(lControlSymptomRA); + {$ENDIF} + DeleteDecompressed4D(lTemp4D); +end; + + + +end. + + diff --git a/npm_precl/zconf.inc b/npm_precl/zconf.inc new file mode 100755 index 0000000..0f9e451 --- /dev/null +++ b/npm_precl/zconf.inc @@ -0,0 +1,24 @@ +{ -------------------------------------------------------------------- } + +{$DEFINE MAX_MATCH_IS_258} + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{- $DEFINE MAXSEG_64K} +{$IFNDEF WIN32} + {$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } +{$ENDIF} + +{$UNDEF DYNAMIC_CRC_TABLE} +{$UNDEF FASTEST} +{$define patch112} { apply patch from the zlib home page } +{ -------------------------------------------------------------------- } +{$IFDEF FPC} + {$DEFINE Use32} + {$UNDEF DPMI} + {$UNDEF MSDOS} + {$UNDEF UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } + {$UNDEF MAXSEG_64K} +{$ENDIF} + diff --git a/ortho_reorient.pas b/ortho_reorient.pas new file mode 100755 index 0000000..02e99eb --- /dev/null +++ b/ortho_reorient.pas @@ -0,0 +1,451 @@ +unit ortho_reorient; +//reorient image to nearest orthogonal plane +interface + +uses + SysUtils,define_types,GraphicsMathLibrary,prefs,nifti_hdr,dialogs, nifti_types; + +function OrthoReorientCore(var lHdr: TMRIcroHdr; l4D: boolean): boolean; + +implementation + + +function NIfTIAlignedM (var lM: TMatrix): boolean; +//check that diagonals are positive and all other cells are zero +//negative diagonals suggests flipping... +//non-negative other cells suggests the image is not pure axial +var + lr,lc: integer; +begin + result := false; + for lr := 1 to 3 do + for lc := 1 to 3 do begin + if (lr = lc) and (lM.matrix[lr,lc] <= 0) then + exit; + if (lr <> lc) and (lM.matrix[lr,lc] <> 0) then + exit; + end; + result := true; +end; + + +function NIfTIAligned (var lHdr: TNIFTIhdr): boolean; +//check that diagonals are positive and all other cells are zero +//negative diagonals suggests flipping... +//non-negative other cells suggests the image is not pure axial +var + lM: TMatrix; +begin + lM := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], + 0,0,0,1); + result := NIfTIAlignedM(lM); +end; + +procedure FromMatrix (M: TMatrix; var m11,m12,m13, m21,m22,m23, + m31,m32,m33: DOUBLE) ; + BEGIN + + m11 := M.Matrix[1,1]; + m12 := M.Matrix[1,2]; + m13 := M.Matrix[1,3]; + m21 := M.Matrix[2,1]; + m22 := M.Matrix[2,2]; + m23 := M.Matrix[2,3]; + m31 := M.Matrix[3,1]; + m32 := M.Matrix[3,2]; + m33 := M.Matrix[3,3]; +END {FromMatrix3D}; + +function nifti_mat44_orthogx( lR :TMatrix): TMatrix; +//returns rotation matrix required to orient image so it is aligned nearest to the identity matrix = +// 1 0 0 0 +// 0 1 0 0 +// 0 0 1 0 +// 0 0 0 1 +//Therefore, image is approximately oriented in space +var + lrow,lcol,lMaxRow,lMaxCol,l2ndMaxRow,l2ndMaxCol,l3rdMaxRow,l3rdMaxCol: integer; + r11,r12,r13 , r21,r22,r23 , r31,r32,r33, val,lAbsmax,lAbs: double; + Q: TMatrix; //3x3 +begin + // load 3x3 matrix into local variables + FromMatrix(lR,r11,r12,r13,r21,r22,r23,r31,r32,r33); + Q := Matrix2D( r11,r12,r13,r21,r22,r23,r31,r32,r33); + // normalize row 1 + val := Q.matrix[1,1]*Q.matrix[1,1] + Q.matrix[1,2]*Q.matrix[1,2] + Q.matrix[1,3]*Q.matrix[1,3] ; + if( val > 0.0 )then begin + val := 1.0 / sqrt(val) ; + Q.matrix[1,1] := Q.matrix[1,1]*val ; + Q.matrix[1,2] := Q.matrix[1,2]*val ; + Q.matrix[1,3] := Q.matrix[1,3]*val ; + end else begin + Q.matrix[1,1] := 1.0 ; Q.matrix[1,2] := 0.0; Q.matrix[1,3] := 0.0 ; + end; + // normalize row 2 + val := Q.matrix[2,1]*Q.matrix[2,1] + Q.matrix[2,2]*Q.matrix[2,2] + Q.matrix[2,3]*Q.matrix[2,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[2,1] := Q.matrix[2,1]* val ; + Q.matrix[2,2] := Q.matrix[2,2] * val ; + Q.matrix[2,3] := Q.matrix[2,3] * val ; + end else begin + Q.matrix[2,1] := 0.0 ; Q.matrix[2,2] := 1.0 ; Q.matrix[2,3] := 0.0 ; + end; + // normalize row 3 + val := Q.matrix[3,1]*Q.matrix[3,1] + Q.matrix[3,2]*Q.matrix[3,2] + Q.matrix[3,3]*Q.matrix[3,3] ; + if( val > 0.0 ) then begin + val := 1.0 / sqrt(val) ; + Q.matrix[3,1] := Q.matrix[3,1] *val ; + Q.matrix[3,2] := Q.matrix[3,2] *val ; + Q.matrix[3,3] := Q.matrix[3,3] *val ; + end else begin + Q.matrix[3,1] := Q.matrix[1,2]*Q.matrix[2,3] - Q.matrix[1,3]*Q.matrix[2,2] ; //* cross */ + Q.matrix[3,2] := Q.matrix[1,3]*Q.matrix[2,1] - Q.matrix[1,1]*Q.matrix[2,3] ; //* product */ + Q.matrix[3,3] := Q.matrix[1,1]*Q.matrix[2,2] - Q.matrix[1,2]*Q.matrix[2,1] ; + end; + //next - find closest orthogonal coordinates - each matrix cell must be 0,-1 or 1 + //First: find axis most aligned to a principal axis + lAbsmax := 0; + lMaxRow := 1; + lMaxCol := 1; + for lrow := 1 to 3 do begin + for lcol := 1 to 3 do begin + lAbs := abs(Q.matrix[lrow,lcol]); + if lAbs > lAbsMax then begin + lAbsmax := lAbs; + lMaxRow := lRow; + lMaxCol := lCol; + end; + end; //for rows + end; //for columns + //Second - find find axis that is 2nd closest to principal axis + lAbsmax := 0; + l2ndMaxRow := 2; + l2ndMaxCol := 2; + for lrow := 1 to 3 do begin + for lcol := 1 to 3 do begin + if (lrow <> lMaxRow) and (lCol <> lMaxCol) then begin + lAbs := abs(Q.matrix[lrow,lcol]); + if lAbs > lAbsMax then begin + lAbsmax := lAbs; + l2ndMaxRow := lRow; + l2ndMaxCol := lCol; + end; //new max + end; //do not check MaxRow/MaxCol + end; //for rows + end; //for columns + //next - no degrees of freedom left: third prinicple axis is the remaining axis + if ((lMaxRow = 1) or (l2ndMaxRow = 1)) and ((lMaxRow = 2) or (l2ndMaxRow = 2)) then + l3rdMaxRow := 3 + else if ((lMaxRow = 1) or (l2ndMaxRow = 1)) and ((lMaxRow = 3) or (l2ndMaxRow = 3)) then + l3rdMaxRow := 2 + else + l3rdMaxRow := 1; + if ((lMaxCol = 1) or (l2ndMaxCol = 1)) and ((lMaxCol = 2) or (l2ndMaxCol = 2)) then + l3rdMaxCol := 3 + else if ((lMaxCol = 1) or (l2ndMaxCol = 1)) and ((lMaxCol = 3) or (l2ndMaxCol = 3)) then + l3rdMaxCol := 2 + else + l3rdMaxCol := 1; + //finally, fill in our rotation matrix + //cells in the canonical rotation transform can only have values 0,1,-1 + result := Matrix3D( 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0); + if Q.matrix[lMaxRow,lMaxCol] < 0 then + result.matrix[lMaxRow,lMaxCol] := -1 + else + result.matrix[lMaxRow,lMaxCol] := 1; + + if Q.matrix[l2ndMaxRow,l2ndMaxCol] < 0 then + result.matrix[l2ndMaxRow,l2ndMaxCol] := -1 + else + result.matrix[l2ndMaxRow,l2ndMaxCol] := 1; + + if Q.matrix[l3rdMaxRow,l3rdMaxCol] < 0 then + result.matrix[l3rdMaxRow,l3rdMaxCol] := -1 + else + result.matrix[l3rdMaxRow,l3rdMaxCol] := 1; +end; + + +FUNCTION QuickInvertMatrix3D (CONST Input:TMatrix): TMatrix; +//http://www.cellperformance.com/articles/2006/06/a_4x4_matrix_inverse_1.html +//Most of the time in the video games, programmers are not doing a standard inverse matrix. +//It is too expensive. Instead, to inverse a matrix, they consider it as orthonormal +//and they just do a 3x3 transpose of the rotation part with a dot product for the translation. +//Sometimes the full inverse algorithm is necessary.... +var + i,j: integer; +begin + result.size := Input.size; + for i := 1 to 3 do + for j := 1 to 3 do + result.matrix[i,j] := input.matrix[j,i]; + //next - fill in edge if 3D + if result.size <> size3D then + exit; //do not fill in final column for 2D matrices + for i := 1 to 3 do + result.matrix[4,i] := 0; + for i := 1 to 3 do + result.matrix[i,4] := 0; + result.matrix[4,4] := 1; +end; + +procedure FindMatrixPt (lX,lY,lZ: single; var lXout,lYOut,lZOut: single; var lMatrix: TMatrix); +begin + lXOut := (lX*lMatrix.matrix[1,1])+(lY*lMatrix.matrix[1,2])+(lZ*lMatrix.matrix[1,3])+lMatrix.matrix[1,4]; + lYOut := (lX*lMatrix.matrix[2,1])+(lY*lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[2,3])+lMatrix.matrix[2,4]; + lZOut := (lX*lMatrix.matrix[3,1])+(lY*lMatrix.matrix[3,2])+(lZ*lMatrix.matrix[3,3])+lMatrix.matrix[3,4]; +end; + +procedure CheckMin(var lX,lY,lZ,lXMin,lYMin,lZMin: single); +begin + if lX < lXMin then lXMin := lX; + if lY < lYMin then lYMin := lY; + if lZ < lZMin then lZMin := lZ; +end; + +procedure Mins (var lMatrix: TMatrix; var lHdr: TNIFTIhdr; var lXMin,lYMin,lZMin: single); +var + lPos,lXc,lYc,lZc: integer; + lx,ly,lz: single; +begin + FindMatrixPt(0,0,0,lX,lY,lZ,lMatrix); + lXMin := lX; + lYMin := lY; + lZMin := lZ; + for lPos := 1 to 7 do begin + if odd(lPos) then + lXc := lHdr.Dim[1]-1 + else + lXc := 0; + if odd(lPos shr 1) then + lYc := lHdr.Dim[2]-1 + else + lYc := 0; + if odd(lPos shr 2) then + lZc := lHdr.Dim[3]-1 + else + lZc := 0; + FindMatrixPt(lXc,lYc,lZc,lX,lY,lZ,lMatrix); + CheckMin(lX,lY,lZ,lXMin,lYMin,lZMin); + end; +end; + +(*procedure ReportMatrix (lM:TMatrix); +const + kCR = chr (13); +begin + showmessage(RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+kCR+ + RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+kCR+ + RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+kCR + +RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6) + ); +end;*) + +function OrthoReorientCore(var lHdr: TMRIcrohdr; l4D: boolean): boolean; +var + //lF: File; + lOutHdr: TNIFTIhdr; + lOutName: string; + lResidualMat: TMatrix; + lInMinX,lInMinY,lInMinZ,lOutMinX,lOutMinY,lOutMinZ, + dx, dy, dz: single; //, QFac + //lStartY,lStartZ, + lStartX,lZ,lY,lX,lB, + lOutZ,lOutY, + lXInc, lYInc, lZInc,lBPP,lVol,lnVol: integer; + lInPos,lVolBytes,lOutPos,lInOffset: integer; + lBufferOut: bytep; + lByteSwap,lFlipX,lFlipY,lFlipZ: boolean; + lInMat,lRotMat: TMatrix; +begin + result := false; + if {(lhdr.NIfTIhdr.dim[4] > 1) or} (lhdr.NIfTIhdr.dim[3] < 2) then begin + //Showmessage('Can only orient 3D images '+inttostr(lhdr.NIfTIhdr.dim[3])+' '+inttostr(lhdr.NIfTIhdr.dim[4])); + exit; + end; + if (lHdr.ImgBufferItems < lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]*lhdr.NIfTIhdr.dim[3]) then + exit; + //Msg(lHdrName); + lInMat := Matrix3D ( + lhdr.NIfTIhdr.srow_x[0],lhdr.NIfTIhdr.srow_x[1],lhdr.NIfTIhdr.srow_x[2],lhdr.NIfTIhdr.srow_x[3], + lhdr.NIfTIhdr.srow_y[0],lhdr.NIfTIhdr.srow_y[1],lhdr.NIfTIhdr.srow_y[2],lhdr.NIfTIhdr.srow_y[3], + lhdr.NIfTIhdr.srow_z[0],lhdr.NIfTIhdr.srow_z[1],lhdr.NIfTIhdr.srow_z[2],lhdr.NIfTIhdr.srow_z[3], + 0,0,0,1); + //ReportMatrix(lInMat); + if (NIfTIAlignedM (lInMat)) then begin + //Msg('According to header, image is already canonically oriented'); + exit; + end; + lRotMat := nifti_mat44_orthogx( lInMat); + if NIfTIAlignedM (lRotMat) then begin + //Msg('According to header, image is already approximately canonically oriented'); + exit; //already as close as possible + end; + lOutHdr := lHdr.NIFTIhdr; + //Some software uses negative pixdims to represent a spatial flip - now that the image is canonical, all dimensions are positive + lOutHdr.pixdim[1] := abs(lhdr.NIfTIhdr.pixdim[1]); + lOutHdr.pixdim[2] := abs(lhdr.NIfTIhdr.pixdim[2]); + lOutHdr.pixdim[3] := abs(lhdr.NIfTIhdr.pixdim[3]); + //sort out dim1 + lFlipX := false; + if lRotMat.Matrix[1,2] <> 0 then begin + lXinc := lhdr.NIfTIhdr.dim[1]; + lOutHdr.dim[1] := lhdr.NIfTIhdr.dim[2]; + lOutHdr.pixdim[1] := abs(lhdr.NIfTIhdr.pixdim[2]); + if lRotMat.Matrix[1,2] < 0 then lFlipX := true + end else if lRotMat.Matrix[1,3] <> 0 then begin + lXinc := lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]; + lOutHdr.dim[1] := lhdr.NIfTIhdr.dim[3]; + lOutHdr.pixdim[1] := abs(lhdr.NIfTIhdr.pixdim[3]); + if lRotMat.Matrix[1,3] < 0 then lFlipX := true + end else begin + lXinc := 1; + if lRotMat.Matrix[1,1] < 0 then lFlipX := true + end; + //sort out dim2 + lFlipY := false; + if lRotMat.Matrix[2,2] <> 0 then begin + lYinc := lhdr.NIfTIhdr.dim[1]; + //lOutHdr.dim[2] := lhdr.NIfTIhdr.dim[2]; + //lOutHdr.pixdim[2] := lhdr.NIfTIhdr.pixdim[2]; + if lRotMat.Matrix[2,2] < 0 then lFlipY := true + end else if lRotMat.Matrix[2,3] <> 0 then begin + lYinc := lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]; + lOutHdr.dim[2] := lhdr.NIfTIhdr.dim[3]; + lOutHdr.pixdim[2] := abs(lhdr.NIfTIhdr.pixdim[3]); + if lRotMat.Matrix[2,3] < 0 then lFlipY := true + end else begin + lYinc := 1; + lOutHdr.dim[2] := lhdr.NIfTIhdr.dim[1]; + lOutHdr.pixdim[2] := abs(lhdr.NIfTIhdr.pixdim[1]); + if lRotMat.Matrix[2,1] < 0 then lFlipY := true + end; + //sort out dim3 + lFlipZ := false; + if lRotMat.Matrix[3,2] <> 0 then begin + lZinc := lhdr.NIfTIhdr.dim[1]; + lOutHdr.dim[3] := lhdr.NIfTIhdr.dim[2]; + lOutHdr.pixdim[3] := lhdr.NIfTIhdr.pixdim[2]; + if lRotMat.Matrix[3,2] < 0 then lFlipZ := true; + end else if lRotMat.Matrix[3,3] <> 0 then begin + lZinc := lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]; + //lOutHdr.dim[3] := lhdr.NIfTIhdr.dim[3]; + //lOutHdr.pixdim[3] := lhdr.NIfTIhdr.pixdim[3]; + if lRotMat.Matrix[3,3] < 0 then lFlipZ := true; + end else begin + lZinc := 1; + lOutHdr.dim[3] := lhdr.NIfTIhdr.dim[1]; + lOutHdr.pixdim[3] := lhdr.NIfTIhdr.pixdim[1]; + if lRotMat.Matrix[3,1] < 0 then lFlipZ := true; + end; + //details for writing... + lBPP := (lhdr.NIfTIhdr.bitpix div 8); //bytes per pixel + if lBPP > 4 then + lBPP := 4;//64bit data is stored as 32-bit precision June 2009 + lXinc := lXinc * lBPP; + lYinc := lYinc * lBPP; + lZinc := lZinc * lBPP; + lVolBytes := lhdr.NIfTIhdr.dim[1]*lhdr.NIfTIhdr.dim[2]*lhdr.NIfTIhdr.dim[3]*lBPP; + //now write header... + //create Matrix of residual orientation... + lResidualMat := QuickInvertMatrix3D(lRotMat); + //the next steps are inelegant - the translation values are computed by brute force + //at the moment, our lResidualMat looks like this + //lResidualMat = [ 0 -1 0 0; 0 0 1 0; 1 0 0 0; 0 0 0 1]; + //however, it should specify the dimensions in mm of the dimensions that are flipped + //However, note that whenever you reverse the direction of + //voxel coordinates, you need to include the appropriate offset + //in the 'a' matrix. That is: + //lResidualMat = [0 0 1 0; -1 0 0 Nx-1; 0 1 0 0; 0 0 0 1] + //where Nx is the number of voxels in the x direction. + //So, if you took Nx=256, then for your values before, you'd get: + //TransRot = [ 0 -1 0 255; 0 0 1 0; 1 0 0 0; 0 0 0 1]; + //Because we do not do this, we use the function mins to compute the translations... + //I have not implemented refined version yet - require sample volumes to check + //Ensure Nx is voxels not mm, etc.... + //start of kludge + lResidualMat := multiplymatrices(lInMat,lResidualMat); //source + lResidualMat.Matrix[1,4] := 0; + lResidualMat.Matrix[2,4] := 0; + lResidualMat.Matrix[3,4] := 0; + Mins (lInMat, lHdr.NIFTIHdr,lInMinX,lInMinY,lInMinZ); + Mins (lResidualMat, lOutHdr,lOutMinX,lOutMinY,lOutMinZ); + lResidualMat.Matrix[1,4] := lInMinX-lOutMinX; + lResidualMat.Matrix[2,4] := lInMinY-lOutMinY; + lResidualMat.Matrix[3,4] := lInMinZ-lOutMinZ; + //End of kuldge + lOutHdr.srow_x[0] := lResidualMat.Matrix[1,1]; + lOutHdr.srow_x[1] := lResidualMat.Matrix[1,2]; + lOutHdr.srow_x[2] := lResidualMat.Matrix[1,3]; + lOutHdr.srow_y[0] := lResidualMat.Matrix[2,1]; + lOutHdr.srow_y[1] := lResidualMat.Matrix[2,2]; + lOutHdr.srow_y[2] := lResidualMat.Matrix[2,3]; + lOutHdr.srow_z[0] := lResidualMat.Matrix[3,1]; + lOutHdr.srow_z[1] := lResidualMat.Matrix[3,2]; + lOutHdr.srow_z[2] := lResidualMat.Matrix[3,3]; + lOutHdr.srow_x[3] := lResidualMat.Matrix[1,4]; + lOutHdr.srow_y[3] := lResidualMat.Matrix[2,4]; + lOutHdr.srow_z[3] := lResidualMat.Matrix[3,4]; + nifti_mat44_to_quatern( lResidualMat, + lOutHdr.quatern_b,lOutHdr.quatern_c,lOutHdr.quatern_d, + lOutHdr.qoffset_x,lOutHdr.qoffset_y,lOutHdr.qoffset_z, + dx, dy, dz, lOutHdr.pixdim[0]); + GetMem(lBufferOut,lVolBytes); + lnVol := 1; + if (lhdr.NIfTIhdr.dim[4] > 1) and (l4D) then + lnVol := lhdr.NIfTIhdr.dim[4]; + //convert + (*if lFlipX then fx(1); + if lFlipY then fx(2); + if lFlipZ then fx(3);*) + + if lFlipX then + lXInc := -lXInc; + if lFlipY then + lYInc := -lYInc; + if lFlipZ then + lZInc := -lZInc; + for lVol := 1 to lnVol do begin + lOutPos := 0; + if lFlipX then + lStartX := (lOutHdr.dim[1]-1)*-lXInc + else + lStartX := 0; + if lFlipY then + lStartX := lStartX + (lOutHdr.dim[2]-1)*-lYInc; + if lFlipZ then + lStartX := lStartX + (lOutHdr.dim[3]-1)*-lZInc; + lStartX := lStartX+ ((lVol-1)*lVolBytes); + for lZ := 1 to lOutHdr.dim[3] do begin + lOutZ := lStartX + (lZ-1) * lZInc; + for lY := 1 to lOutHdr.dim[2] do begin + lOutY := ((lY-1) * lYInc) + lOutZ; + for lX := 1 to lOutHdr.dim[1] do begin + for lB := 1 to (lBPP) do begin + inc(lOutPos); + //lInPos := ((lX-1) * lXInc) + lOutY + lB; + lInPos := lOutY + lB; + lBufferOut^[lOutPos] := lHdr.ImgBuffer^[lInPos]; + end; + inc(lOutY,lXinc); + end; + end; //for Y + end; //for Z + Move(lBufferOut^,lHdr.ImgBuffer^[1+((lVol-1)*lVolBytes)],lVolBytes); + end; //for each volume + (* Filemode := 2; + AssignFile(lF,'C:\Documents and Settings\Admin\Desktop\rorden\perisample\shit.img'); {WIN} + Rewrite(lF,1); + BlockWrite(lF,lHdr.ImgBuffer^,lnVol*lVolBytes); + CloseFile(lF);*) + Freemem(lBufferOut); + lHdr.NIFTIhdr := lOutHdr; + //fx(lOutHdr.srow_x[3],lOutHdr.srow_y[3],lOutHdr.srow_z[3]); + result := true; +end;//ReorientCore + +end. \ No newline at end of file diff --git a/otsuml.pas b/otsuml.pas new file mode 100755 index 0000000..ad70861 --- /dev/null +++ b/otsuml.pas @@ -0,0 +1,319 @@ +unit otsuml; +//Multilevel Otsu's Method +//Otsu N (1979) A threshold selection method from gray-level histograms. IEEE Trans. Sys., Man., Cyber. 9: 62-66. +//Lookup Tables as suggested by Liao, Chen and Chung (2001) A fast algorithm for multilevel thresholding +//note that my "otsu.pas" is slightly faster and much simpler if you only want bi-level output + +interface +uses define_types, sysutils; + +function FindOtsu2 (var Img: Bytep; nVox: integer): byte; +//function ApplyOtsu2 (var Img: Bytep; nVox: integer): byte; +//function ApplyOtsu3 (var Img: Bytep; nVox: integer): byte; +//function ApplyOtsu4 (var Img: Bytep; nVox: integer): byte; +procedure ApplyOtsu (var Img: Bytep; nVox, levels: integer);//levels: 2=black/white, 3=3tone, 4=4tone +procedure ApplyOtsuBinary (var Img: Bytep; nVox,levels: integer); + +implementation + +Type +HistoRA = array [0..255] of longint; +HistoRAd = array [0..255] of double; +Histo2D = array [0..255] of HistoRAd; + +Function OtsuLUT(H: HistoRA): Histo2D; +var + Sum,Prob: double; + v,u: integer;//column/rom index + P,S: Histo2D; +begin + Sum := 0; + for v := 0 to 255 do + Sum := Sum + H[v]; + if Sum <= 0 then + exit; + P[0][0] := H[0]; + S[0][0] := H[0]; + for v := 1 to 255 do begin + prob := H[v]/Sum; + P[0][v] := P[0][v-1]+prob; + S[0][V] := S[0][v-1]+(v+1)*prob; + end; + for u := 1 to 255 do begin + for v := u to 255 do begin + P[u][v] := P[0][v]-P[0][u-1]; + S[u][v] := S[0][v]-S[0][u-1]; + end + end; + //result is eq 29 from Liao + for u := 0 to 255 do begin + for v := u to 255 do begin + if S[u][v] = 0 then //avoid divide by zero errors... + result[u][v] := 0 + else + result[u][v] := sqr(S[u][v]) /P[u][v]; + end + end; +end; + +Function OtsuCostFunc(H: HistoRA): integer; +//Otsu N (1979) A threshold selection method from gray-level histograms". IEEE Trans. Sys., Man., Cyber. 9: 62-66. +//http://en.wikipedia.org/wiki/Otsu's_method +//http://www.labbookpages.co.uk/software/imgProc/otsuThreshold.html +//returns threshold for binarizing an image +// all voxel <=Threshold are background +// all voxel >Threshold are object +const + kMaxBin = 255; +var + t,total: integer; + wB,wF,Sum,SumB,mF,mB,varBetween,varMax: double; +begin + result := 0; + wB := 0; + wF := 0; + SumB := 0; + Sum := 0; + Total := 0; + varMax := 0; + for t := 0 to kMaxBin do + Total := Total + H[t]; + if Total = 0 then exit; + for t := 0 to kMaxBin do + Sum := Sum + (t*H[t]); + for t :=0 to kMaxBin do begin + wB := wB + H[t]; // Weight Background + if (wB = 0) then continue; + wF := Total - wB; // Weight Foreground + if (wF = 0) then break; + sumB := sumB+(t * H[t]); + mB := sumB / wB; // Mean Background + mF := (sum - sumB) / wF; // Mean Foreground + // Calculate Between Class Variance + varBetween := (wB/Total) * (wF/Total) * sqr(mB - mF); + // Check if new maximum found + if (t=0) or (varBetween > varMax) then begin + varMax := varBetween; + result := t; + end; + end; +end; + +//OtsuCostFunc2 provides same answer as OtsuCostFunc, but is slightly slower and requires more RAM +function OtsuCostFunc2(lHisto: HistoRA): integer; +var + v,max: double; + h2d: Histo2D; + n: integer; +begin + h2d := OtsuLUT(lHisto); + //default solution + n := 128; + max := h2d[0,n]+h2d[n+1,255]; + result := n; + //exhaustively search + for n := 0 to (255-1) do begin + v := h2d[0,n]+h2d[n+1,255]; + if v > max then begin + result := n; + max := v; + end; //new max + end; //for n +end; //bilevel OtsuCostFunc2 + +procedure OtsuCostFunc3(lHisto: HistoRA; var Lo,Hi: integer); +var + v,max: double; + l,h: integer; + h2d: Histo2D; +begin + h2d := OtsuLUT(lHisto); + //default solution + lo := 85; + hi := 170; + max := h2d[0,lo]+h2d[lo+1,Hi]+h2d[Hi+1,255]; + //exhaustively search + for l := 0 to (255-2) do begin + for h := l+1 to (255-1) do begin + v := h2d[0,l]+h2d[l+1,h]+h2d[h+1,255]; + if v > max then begin + lo := l; + hi := h; + max := v; + end; //new max + end;//for h -> hi + end; //for l -> low +end; //trilevel OtsuCostFunc3 + +procedure OtsuCostFunc4(lHisto: HistoRA; var Lo,Mid,Hi: integer); +var + v,max: double; + l,m,h: integer; + h2d: Histo2D; +begin + h2d := OtsuLUT(lHisto); + //default solution + lo := 64; + mid := 128; + hi := 192; + max := h2d[0,lo]+h2d[lo+1,mid]+h2d[mid+1,hi]+h2d[Hi+1,255]; + //exhaustively search + for l := 0 to (255-3) do begin + for m := l+1 to (255-2) do begin + for h := m+1 to (255-1) do begin + v := h2d[0,l]+h2d[l+1,m]+h2d[m+1,h]+h2d[h+1,255]; + if v > max then begin + lo := l; + mid := m; + hi := h; + max := v; + end; //new max + end;//for h -> hi + end; //for mid + end; //for l -> low +end; //quad OtsuCostFunc4 + +function FindOtsu2 (var Img: Bytep; nVox: integer): byte; +var + n: integer; + lHisto: HistoRA; +begin + result := 128; + if nVox < 1 then exit; + //create histogram + for n := 0 to 255 do + lHisto[n] := 0; + for n := 0 to nVox do + inc(lHisto[Img^[n]]); + //now find minimum intraclass variance.... + //result := OtsuCostFunc(lHisto); + result := OtsuCostFunc2(lHisto); //same answer, just slower and more memory +end; + +procedure FindOtsu3 (var Img: Bytep; nVox: integer; var lo, hi: integer); +var + n: integer; + lHisto: HistoRA; +begin + lo := 85; + hi := 170; + if nVox < 1 then exit; + //create histogram + for n := 0 to 255 do + lHisto[n] := 0; + for n := 0 to nVox do + inc(lHisto[Img^[n]]); + //now find minimum intraclass variance.... + OtsuCostFunc3(lHisto,lo,hi); +end; + +procedure FindOtsu4 (var Img: Bytep; nVox: integer; var lo, med, hi: integer); +var + n: integer; + lHisto: HistoRA; +begin + lo := 64; + med := 128; + hi := 192; + if nVox < 1 then exit; + //create histogram + for n := 0 to 255 do + lHisto[n] := 0; + for n := 0 to nVox do + inc(lHisto[Img^[n]]); + //now find minimum intraclass variance.... + OtsuCostFunc4(lHisto,lo,med,hi); +end; + +function ApplyOtsu2 (var Img: Bytep; nVox: integer): byte; +var + n: integer; +begin + result := 128; + if nVox < 1 then exit; + result := FindOtsu2(Img,nVox); + for n := 1 to nVox do + if Img^[n] > result then + Img^[n] := 255 + else + Img^[n] := 0; +end; + +procedure ApplyOtsu3 (var Img: Bytep; nVox: integer); +var + n,lo,hi: integer; + h: histora; +begin + if nVox < 1 then exit; + FindOtsu3(Img,nVox,lo,hi); + for n := 0 to 255 do + if n <= Lo then + H[n] := 0 + else if n <= hi then + h[n] := 128 + else + h[n] := 255; + for n := 1 to nVox do + Img^[n] := H[Img^[n]]; +end; + +procedure ApplyOtsu4 (var Img: Bytep; nVox: integer); +var + n,lo,med,hi: integer; + h: histora; +begin + if nVox < 1 then exit; + FindOtsu4(Img,nVox,lo,med,hi); + for n := 0 to 255 do + if n <= Lo then + H[n] := 0 + else if n <= med then + h[n] := 85 + else if n <= hi then + h[n] := 170 + else + h[n] := 255; + for n := 1 to nVox do + Img^[n] := H[Img^[n]]; +end; + +procedure ApplyOtsu (var Img: Bytep; nVox,levels: integer); +begin + if levels <= 2 then + ApplyOtsu2(Img,nVox) + else if levels = 3 then + ApplyOtsu3(Img,nVox) + else + ApplyOtsu4(Img,nVox); +end; + +procedure ApplyOtsuBinary (var Img: Bytep; nVox,levels: integer); +//1=1/4, 2=1/3, 3=1/2, 4=2/3, 5=3/4 +var + n: integer; + h: histora; +begin + if nVox < 1 then exit; + if (levels <= 1) or (levels >= 5) then + ApplyOtsu4(Img,nVox) + else if (levels = 2) or (levels = 4) then + ApplyOtsu3(Img,nVox) + else //level = 3 + ApplyOtsu2(Img,nVox); + if levels <= 3 then begin //make dark: all except 255 equal 0 + for n := 0 to 254 do + H[n] := 0; + H[255] := 255; + end else begin //make bright: all except 0 equal 255 + H[0] := 0; + for n := 1 to 255 do + H[n] := 255; + end; + for n := 1 to nVox do + Img^[n] := H[Img^[n]]; + +end; + + +end. + \ No newline at end of file diff --git a/periplot.pas b/periplot.pas new file mode 100755 index 0000000..a344ed8 --- /dev/null +++ b/periplot.pas @@ -0,0 +1,706 @@ +unit periplot; +//peristimulus plotting routines + +interface +uses + nifti_hdr,define_types,metagraph,sysutils; + +function CreatePeristimulusPlot (var l4DHdr: TMRIcroHdr; var l4DTrace: T4DTrace; +var lPSPlot: TPSPlot): boolean; +function ROIoverlayNameShort(lROI: integer): string; +function numROI: integer; +function ROIoverlayNum(lROI: integer): integer; +function NCond ( var l4DTrace: T4DTrace): integer; +function ROImean (var l4DHdr: TMRIcroHdr; lROInum,lVol: integer): double; + +implementation + + +{$IFNDEF FPC} +{$DEFINE REMOVEREGRESS} +{$ENDIF} +uses nifti_img_view,dialogs,nifti_img,text,graphx,math +{$IFDEF REMOVEREGRESS},fmath, hrf, +matrices,Regmult{$ENDIF}; //need to specify path, e.g. C:\pas\mricron\npm\math + + +//var gOffsetError: array [1..kMaxCond] of double; + +function numROI: integer; +var + lR: integer; +begin + result := 0; + for lR := (kBGOverlayNum+1) to knMaxOverlay do + if gMRIcroOverlay[lR].ScrnBufferItems > 0 then + inc(result); +end; + +function ROIoverlayNum(lROI: integer): integer; +var + lR,lN: integer; +begin + result := 0; + lN := 0; + for lR := (kBGOverlayNum+1) to knMaxOverlay do begin + //fx(lR,gMRIcroOverlay[lR].ScrnBufferItems); + if gMRIcroOverlay[lR].ScrnBufferItems > 0 then begin + inc(lN); + if lROI = lN then begin + result := lR; + exit; + end; + end; //if ROI has items + end; +end; + + +function ROIoverlayNameShort(lROI: integer): string; +begin + if ROIoverlayNum(lROI) = 0 then +{$IFDEF FPC} + result := inttostr(ImgForm.XViewEdit.value)+'x'+inttostr(ImgForm.YViewEdit.value)+'x'+inttostr(ImgForm.ZViewEdit.value) +{$ELSE} + result := inttostr(ImgForm.XViewEdit.asinteger)+'x'+inttostr(ImgForm.YViewEdit.asinteger)+'x'+inttostr(ImgForm.ZViewEdit.asinteger) +{$ENDIF} + else + result := parsefilename(extractfilename(gMRIcroOverlay[ROIoverlayNum(lROI)].HdrFileName)); +end; + +function StDev (lSum, lSumSqr: single; lN: integer): single; +begin + result := 0; + if lN < 2 then + exit; //avoid divide by zero. We divide by N-1 + result:= (lSumSqr - ((Sqr(lSum))/lN)); + if (result > 0) then + result := Sqrt ( result/(lN-1)) +end; + + +function ROIoverlayNameLong(lROI: integer): string; +begin + if ROIoverlayNum(lROI) = 0 then +{$IFDEF FPC} + result := inttostr(ImgForm.XViewEdit.value)+'x'+inttostr(ImgForm.YViewEdit.value)+'x'+inttostr(ImgForm.ZViewEdit.value) +{$ELSE} + result := inttostr(ImgForm.XViewEdit.asinteger)+'x'+inttostr(ImgForm.YViewEdit.asinteger)+'x'+inttostr(ImgForm.ZViewEdit.asinteger) +{$ENDIF} + else + result := gMRIcroOverlay[ROIoverlayNum(lROI)].HdrFileName; +end; + + +function NCond ( var l4DTrace: T4DTrace): integer; +var + lCond: integer; +begin + result := 0; + for lCond := 1 to kMaxCond do + if l4DTrace.Conditions[lCond].Events > 0 then + inc(result); +end; + +function StError (lSum, lSumSqr: single; lN: integer): single; +//= STANDARD DEVIATION / SQUARE ROOT OF THE POPULATION SIZE +//= STDEV(range of values)/SQRT(lN) +begin + if lN > 1 then + result := StDev (lSum, lSumSqr, lN)/ sqrt(lN) + else + result := 0; +end; + +const + kMaxEvents = 2048; + +procedure TimecourseVoxinten (var l4DHdr: TMRIcroHdr; lVoxel: integer; lTimeCourse: DoubleP); +//could also use periutil's VoxInten, but this is faster... +var + lVol,lVolOffset,lImgVox,lMaxStatVol: integer; + l32Buf: singleP; + l16Buf: smallintp; +begin //if ROI else no ROI - single voxel + lImgVox := l4DHdr.NIFTIhdr.dim[1]*l4DHdr.NIFTIhdr.dim[2]*l4DHdr.NIFTIhdr.dim[3]; + lMaxStatVol := l4DHdr.NIFTIhdr.dim[4]; + if (l4DHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(l4DHdr.ImgBuffer ); + for lVol := 1 to lMaxStatVol do begin + lVolOffset := (lVol-1)*lImgVox; + lTimeCourse^[lVol] := l32Buf^[lVoxel+lVolOffset] + end; + end else if l4DHdr.ImgBufferBPP = 2 then begin + l16Buf := SmallIntP(l4DHdr.ImgBuffer ); + for lVol := 1 to lMaxStatVol do begin + lVolOffset := (lVol-1)*lImgVox; + lTimeCourse^[lVol] := l16Buf^[lVoxel+lVolOffset] + end; + end else if l4DHdr.ImgBufferBPP = 1 then begin + for lVol := 1 to lMaxStatVol do begin + lVolOffset := (lVol-1)*lImgVox; + lTimeCourse^[lVol] := l4DHdr.ImgBuffer^[lVoxel+lVolOffset]; + end; + end; //if 1 bpp +end; //GenerateVoxinten + +function ROImean (var l4DHdr: TMRIcroHdr; lROInum,lVol: integer): double; +var + l32Buf: singleP; + l16Buf: smallintp; + lSum: double; + lMaskVox: int64; + lInc,lVolOffset,lImgVox: integer; +begin + result := 0; + //compute number of voxels in mask + lImgVox := l4DHdr.NIFTIhdr.dim[1]*l4DHdr.NIFTIhdr.dim[2]*l4DHdr.NIFTIhdr.dim[3]; + + lMaskVox := 0; + for lInc := 1 to lImgVox do + if gMRIcroOverlay[lROInum].ScrnBuffer^[lInc] > 0 then //in mask + lMaskVox := lMaskVox + gMRIcroOverlay[lROInum].ScrnBuffer^[lInc]; + if lMaskVox < 1 then + exit; + lSum := 0; + lVolOffset := (lVol-1)*lImgVox; + if (l4DHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(l4DHdr.ImgBuffer ); + for lInc := 1 to lImgVox do begin + if gMRIcroOverlay[lROInum].ScrnBuffer^[lInc] > 0 then begin//in mask + lSum := lSum + (gMRIcroOverlay[lROInum].ScrnBuffer^[lInc]*l32Buf^[lInc+lVolOffset]); + end; //in mask + end; //for each vox + end else if (l4DHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(l4DHdr.ImgBuffer ); + for lInc := 1 to lImgVox do begin + if gMRIcroOverlay[lROInum].ScrnBuffer^[lInc] > 0 then begin//in mask + lSum := lSum + (gMRIcroOverlay[lROInum].ScrnBuffer^[lInc]*l16Buf^[lInc+lVolOffset]); + end; //in mask + end; //for each vox + end else if (l4DHdr.ImgBufferBPP = 1) then begin + for lInc := 1 to lImgVox do begin + if gMRIcroOverlay[lROInum].ScrnBuffer^[lInc] > 0 then begin//in mask + lSum := lSum + (gMRIcroOverlay[lROInum].ScrnBuffer^[lInc]*l4DHdr.ImgBuffer^[lInc+lVolOffset]); + end; //for each volume + end; //for each vox + end; //for image type + result := lSum/lMaskVox; +end; + +function TimecourseROIinten (var l4DHdr: TMRIcroHdr; lROInum: integer; lTimeCourse: DoubleP): boolean; +var + lVol,lMaxStatVol: integer; +begin + lMaxStatVol := l4DHdr.NIFTIhdr.dim[4]; + //result := false; + for lVol := 1 to lMaxStatVol do + lTimeCourse^[lVol] := ROImean (l4DHdr,lROInum,lVol); + //compute mean for each volume + result := true; +end; + +function ComputeMeanSE (lCountBin: longintp; lMnBin,lSEBin,lSumBin,lSumSqrBin: doublep; + lNegBins,lPosBins: integer): boolean; +var + lBin: integer; +begin + result := false; + + (*var + lBins,lBin,lnBinsWithSamples: integer; + lIntensitySum: double; +begin + result := false; + lIntensitySum := 0; + lnBinsWithSamples := 0; + lBins := lNegBins; + if lBins < 1 then + lBins := lNegBins+lPosBins; + for lBin := lBins downto 1 do begin //new only base pct on baseline + if lCountBin^[lBin] > 0 then begin + lIntensitySum := lIntensitySum+lMnBin^[lBin]; + inc(lnBinsWithSamples); + end; //samples in bin + end; //for each bin + if lnBinsWithSamples < 1 then + exit;*) + if (lNegBins + lPosBins) < 1 then + exit; + for lBin := (lNegBins + lPosBins) downto 1 do + lSEBin^[lBin] := StError(lSumBin^[lBin],lSumSqrBin^[lBin],lCountBin^[lBin]); + result := true; +end; //ifunc ComputeMeanSE + +{$IFDEF REMOVEREGRESS} + +{procedure OutCSV (lTimeCourseRaw,lTimeCourseRegress,lTimeCourseFilt: DoubleP; lnVol,lC: integer; lSlope,lInter: double); +var + lVol: integer; + lF: TextFile; + lStr: string; +begin + AssignFile(lF, 'C:\fatigue\td'+inttostr(lC)+'.csv'); + Rewrite(lF); + lStr := ''; + for lVol := 1 to lnVol do + lStr := lStr+floattostr(lTimeCourseRaw^[lVol])+','; + lStr := lStr + '666'; + writeln(lF,lStr); + + lStr := ''; + for lVol := 1 to lnVol do + lStr := lStr+floattostr(lTimeCourseRegress^[lVol])+','; + lStr := lStr + '666'; + writeln(lF,lStr); + lStr := ''; + for lVol := 1 to lnVol do + lStr := lStr+floattostr(lTimeCourseFilt^[lVol])+','; + lStr := lStr + '666'; + writeln(lF,lStr); + writeln(lF,''); + writeln(lF,''); + writeln(lF,floattostr(lSlope)+','+floattostr(lInter)); + CloseFile(lF); +end; } + +function RemoveRegressors(lTimeCourseRaw,lTimeCourseFilt: DoubleP; var l4DTrace: T4DTrace;lCond,lnVol: integer;var lPSPlot: TPSPlot): boolean; +var + lOK: boolean; + lKernelBins,lncond,lC,lVol,lnCondincludeTD: integer; + lHRFra, lTDra: doublep; + lInputSum,lOutputSum : double; + X: PMatrix; + Y: PVector; + //lDummy,lEstTimeCoursePrecise: DoubleP; + lOutT,lOutSlope: DoubleP0; +begin + result := false; + lncond := NCond (l4DTrace); + lnCondincludeTD := lnCond; + if lPSPlot.TemporalDeriv then + lnCondincludeTD := lnCondincludeTD * 2; + if (lnCondincludeTD < 2) or (lPSPlot.SPMDefaultsStatsFmriT < 1) then begin + Showmessage('You need at least two variables to remove regressors (you could add the temporal derivative)'); + exit; + end; //cond = 0 + if not CreateHRF (lPSPlot.TRsec, lKernelBins,lPSPlot.SPMDefaultsStatsFmriT, lHRFra, lTDra) then exit; + //getmem(lTimeCourseRegress,lnVol*sizeof(double)); + for lVol := 1 to lnVol do + lTimeCourseFilt^[lVol] := lTimeCourseRaw^[lVol]; + //compute sum intensity so we can adjust for shifts in the mean... + lInputSum := 0; + for lVol := 1 to lnVol do + lInputSum := lInputSum+lTimeCourseRaw^[lVol]; + //convolve each condition... + DimMatrix(X, lnCondincludeTD, lnVol); + //lDummy := nil; + //Getmem(lEstTimeCoursePrecise, lnVol *lPSPlot.SPMDefaultsStatsFmriT * sizeof(double)); + for lC := 1 to lnCond do begin + (*if lC = lCond then + ConvolveTimeCourse(X, lHRFra, lEstTimeCoursePrecise,l4DTrace, lC,lC,lnVol,lKernelBins,lPSPlot.SPMDefaultsStatsFmriT,lPSPlot.SPMDefaultsStatsFmriT0,lPSPlot.TRSec, lPSPlot.SliceTime) + else*) + ConvolveTimeCourse(X, lHRFra, l4DTrace, lC,lC,lnVol,lKernelBins,lPSPlot.SPMDefaultsStatsFmriT,lPSPlot.SPMDefaultsStatsFmriT0,lPSPlot.TRSec, lPSPlot.SliceTime); + end; + //convolve temporal derivatives for each condition + if lPSPlot.TemporalDeriv then + for lC := 1 to lnCond do + ConvolveTimeCourse(X, lTDra, l4DTrace, lC,lC+lnCond,lnVol,lKernelBins,lPSPlot.SPMDefaultsStatsFmriT,lPSPlot.SPMDefaultsStatsFmriT0,lPSPlot.TRSec, lPSPlot.SliceTime); + freemem(lHRFra); + freemem(lTDra); + DimVector(Y, lnVol); + for lVol := 1 to lnVol do + Y^[lVol] := lTimeCourseRaw^[lVol]; + getmem(lOutT, (lnCondincludeTD+1)* sizeof(double)); + getmem(lOutSlope, (lnCondincludeTD+1)* sizeof(double)); + lOK := MultipleRegressionVec (lnVol,lnCondincludeTD, X, Y, lOutT,lOutSlope); + freemem(lOutT); + DelVector(Y, lnVol); + //begin test - show responses... +if lPSPlot.PlotModel then begin + lC := lCond; //response for condition + //if lTemporalDeriv then lC := lCond + lnCond; //lCond + lnCond = TD + //if lPSPlot.TemporalDeriv then fx( lC,lOutSlope^[lC-1],lOutSlope^[lnCond+lC-1] ); + for lVol := 1 to lnVol do + lTimeCourseFilt^[lVol] := (X^[lC]^[lVol] *lOutSlope[lC-1]); +end else begin //not test + if lOK then begin + for lC := 1 to lnCondincludeTD do begin + if lC <> lCond then begin + for lVol := 1 to lnVol do + lTimeCourseFilt^[lVol] := lTimeCourseFilt^[lVol]- (X^[lC]^[lVol] *lOutSlope[lC-1]); + + end; //for each regressor + end; //for lC + result := true;//SUCCESS! + //next - search for optimal fit of model to data.. + //if (lPSPlot.TextOutput) and (lCond > 0) and (lCond <= kMaxCond) then + // gOffsetError[lCond] := (OptimalOffset(lOutSlope^[lCond-1],lOutSlope^[lnCondincludeTD], lPSPlot.SPMDefaultsStatsFmriT0,lPSPlot.SPMDefaultsStatsFmriT,lnVol, lTimeCourseFilt,lEstTimeCoursePrecise)/ lPSPlot.SPMDefaultsStatsFmriT ) * lPSPlot.TRsec; + end;//lOK +end; + //Freemem(lEstTimeCoursePrecise); + DelMatrix(X, lnCondincludeTD, lnVol); + + //adjust for shifts in the mean... + lOutputSum := 0; + for lVol := 1 to lnVol do + lOutputSum := lOutputSum+lTimeCourseFilt^[lVol]; + if lOutputSum <> lInputsum then begin + lOutputSum := (lOutputSum - lInputSum)/lnVol; + for lVol := 1 to lnVol do + lTimeCourseFilt^[lVol] := lTimeCourseFilt^[lVol] - lOutputSum; + end; //correct for changes... + freemem(lOutSlope); +end; + +{$ENDIF} //IFDEF REMOVEREGRESS +//old TimeCourseToPSPlot - each event can contribute to several samples e.g. both before and after stimulus +(*function TimeCourseToPSPlot(lTimeCourse: DoubleP; var l4DTrace: T4DTrace; + lCountBin: longintp; lMnBin,lSumBin,lSumSqrBin: doublep; + var lTRsec,lBinWidthSec: single; lCond,lnNegBins,lnPosBins,lMaxStatVol: integer; lSliceTime: boolean): boolean; +var + lOnsetRAx: doublep; + lEvent,lnEvent,lBin,lVol: integer; + lNegMS,lPosMS,lVolTime,lTRms,lHalfTRms,lPeristimulusTime,lmsPerBin: double; +begin + result := false; + if l4DTrace.Conditions[lCond].Events < 1 then exit; + lmsPerBin := lBinWidthSec * 1000; + lTRms := lTRsec * 1000; + if lTRms = 0 then begin + Showmessage('Unable to compute plots: You need to specify the TR in seconds.'); + exit; + end; + lHalfTRms := lTRms/2; + lNegMS := -lnNegBins * lmsPerBin; + lPosMS := lnPosBins * lmsPerBin; + lnEvent := l4DTrace.Conditions[lCond].Events; + getmem(lOnsetRAx,lnEvent*sizeof(double) ); + if lSliceTime then begin + for lEvent := 1 to lnEvent do begin + lOnsetRAx^[lEvent] := (l4DTrace.Conditions[lCond].EventRA^[lEvent]*1000)-lHalfTRms; + end; + end else + for lEvent := 1 to lnEvent do + lOnsetRAx^[lEvent] := (l4DTrace.Conditions[lCond].EventRA^[lEvent]*1000); + //initialize bins + for lBin := 1 to (lnNegBins + lnPosBins) do begin + lMnBin^[lBin] := 0; + lSumBin^[lBin] := 0; + lSumSqrBin^[lBin] := 0; + lCountBin^[lBin] := 0; //no samples in each cell + end; + for lVol := 1 to lMaxStatVol do begin + lVolTime := (lVol-1) * lTRms; + for lEvent := 1 to l4DTrace.Conditions[lCond].Events do begin + lPeristimulusTime := lVolTime-lOnsetRAx^[lEvent]; + if (lPeristimulusTime >= lNegMS) and (lPeristimulusTime < lPosMS) then begin + lBin := trunc((lPeristimulusTime - lNegMS) / lmsPerBin)+1; + inc(lCountBin^[lBin]); + lSumBin^[lBin] := lSumBin^[lBin] + lTimeCourse^[lVol]; + lSumSqrBin^[lBin] := lSumSqrBin^[lBin] + sqr(lTimeCourse^[lVol]); + end; //if lPeristimulusTime within mix/max temporal window + end; //for each event + end; //for each vol + //next compute mean + for lBin := 1 to (lnNegBins + lnPosBins) do + if lCountBin^[lBin] > 0 then + lMnBin^[lBin] := lSumBin^[lBin]/lCountBin^[lBin]; + freemem(lOnsetRAx); + result := true; +end;//func TimeCourseToPS +*) +function TimeCourseToPSPlot(lTimeCourse: DoubleP; var l4DTrace: T4DTrace; + lCountBin: longintp; lMnBin,lSumBin,lSumSqrBin: doublep; + var lPSPlot: TPSPlot; lCond,lMaxStatVol: integer): boolean; +var + lOnsetRAx: doublep; + lEvent,lnEvent,lBin,lVol: integer; + lNextEvent,lPrevEvent,lNegMS,lPosMS,lVolTime,lTRms,lHalfTRms,lPeristimulusTime,lmsPerBin: double; +begin + result := false; + if (l4DTrace.Conditions[lCond].Events < 1) or ((lPSPlot.nNegBins + lPSPlot.nPosBins)<1) then exit; + lmsPerBin := lPSPlot.BinWidthSec * 1000; + lTRms := lPSPlot.TRsec * 1000; + if lTRms = 0 then begin + Showmessage('Unable to compute plots: You need to specify the TR in seconds.'); + exit; + end; + lHalfTRms := lTRms/2; + lNegMS := -lPSPlot.nNegBins * lmsPerBin; + lPosMS := lPSPlot.nPosBins * lmsPerBin; + lnEvent := l4DTrace.Conditions[lCond].Events; + getmem(lOnsetRAx,lnEvent*sizeof(double) ); + if lPSPlot.SliceTime then begin + for lEvent := 1 to lnEvent do begin + lOnsetRAx^[lEvent] := (l4DTrace.Conditions[lCond].EventRA^[lEvent]*1000)-lHalfTRms; + end; + end else + for lEvent := 1 to lnEvent do + lOnsetRAx^[lEvent] := (l4DTrace.Conditions[lCond].EventRA^[lEvent]*1000); + //initialize bins + for lBin := 1 to (lPSPlot.nNegBins + lPSPlot.nPosBins) do begin + lMnBin^[lBin] := 0; + lSumBin^[lBin] := 0; + lSumSqrBin^[lBin] := 0; + lCountBin^[lBin] := 0; //no samples in each cell + end; + //find volume's peristimulus time + //note: we assume periutil's ReadCond ensures that Cond.Events are sorted in ascending order + lEvent := 1; + lPrevEvent := -MaxInt; + lNextEvent := lOnsetRAx^[lEvent]; + for lVol := 1 to lMaxStatVol do begin + lVolTime := (lVol-1) * lTRms; + while lVolTime > lNextEvent do begin + inc(lEvent); + lPrevEvent := lNextEvent; + if lEvent > lnEvent then + lNextEvent := MaxInt + else + lNextEvent := lOnsetRAx^[lEvent]; + end; + lPeristimulusTime := lVolTime-lPrevEvent; + if (lPeristimulusTime >= 0) and (lPeristimulusTime < lPosMS) then begin + lBin := trunc((lPeristimulusTime - lNegMS) / lmsPerBin)+1; + inc(lCountBin^[lBin]); + lSumBin^[lBin] := lSumBin^[lBin] + lTimeCourse^[lVol]; + lSumSqrBin^[lBin] := lSumSqrBin^[lBin] + sqr(lTimeCourse^[lVol]); + end else begin //if not after - check if before + lPeristimulusTime := lVolTime-lNextEvent; + if (lPeristimulusTime >= lNegMS) and (lPeristimulusTime < 0) then begin + lBin := trunc((lPeristimulusTime - lNegMS) / lmsPerBin)+1; + inc(lCountBin^[lBin]); + lSumBin^[lBin] := lSumBin^[lBin] + lTimeCourse^[lVol]; + lSumSqrBin^[lBin] := lSumSqrBin^[lBin] + sqr(lTimeCourse^[lVol]); + end; //if lPeristimulusTime within mix/max temporal window + end; //if else... not after stimuli + + (*for lEvent := 1 to l4DTrace.Conditions[lCond].Events do begin + lPeristimulusTime := lVolTime-lOnsetRAx^[lEvent]; + if (lPeristimulusTime >= lNegMS) and (lPeristimulusTime < lPosMS) then begin + lBin := trunc((lPeristimulusTime - lNegMS) / lmsPerBin)+1; + inc(lCountBin^[lBin]); + lSumBin^[lBin] := lSumBin^[lBin] + lTimeCourse^[lVol]; + lSumSqrBin^[lBin] := lSumSqrBin^[lBin] + sqr(lTimeCourse^[lVol]); + end; //if lPeristimulusTime within mix/max temporal window + end; //for each event*) + end; //for each vol + //next compute mean + for lBin := 1 to (lPSPlot.nNegBins + lPSPlot.nPosBins) do + if lCountBin^[lBin] > 0 then + lMnBin^[lBin] := lSumBin^[lBin]/lCountBin^[lBin]; + freemem(lOnsetRAx); + result := true; +end;//func TimeCourseToPS + +function TextOutput (lROI,lCond: integer; var lPSPlot : TPSPlot; var l4DTrace: T4DTrace; lCountBin: longintp; lMnROI,lSEROI: doublep): boolean; +var + lOutMnStr,lOutSDStr,lCondStr, lOutStr,lModelStr: string; + lNegMS,lmsPerBin: double; + lnBins,lBin,lMinBinCount,lMaxBinCount: integer; +begin + result := false; + lnBins := lPSPlot.nNegBins + lPSPlot.nPosBins; + if lnBins < 1 then + exit; + lmsPerBin := lPSPlot.BinWidthSec * 1000; + lNegMS := -lPSPlot.nNegBins * lmsPerBin; + lMinBinCount := lCountBin^[1]; + lMaxBinCount := lCountBin^[1]; + for lBin := 1 to lnBins do begin + if lCountBin^[lBin] < lMinBinCount then + lMinBinCount := lCountBin^[lBin]; + if lCountBin^[lBin] > lMaxBinCount then + lMaxBinCount := lCountBin^[lBin]; + end; + lModelStr := ', Processing=,'; + if lPSPlot.RemoveRegressorVariability then begin + if lPSPlot.PlotModel then + lModelStr := lModelStr+'MODEL[hrf' + else + lModelStr := lModelStr+'observed[hrf'; + if lPSPlot.TemporalDeriv then + lModelStr := lModelStr+'+TD'; + lModelStr := lModelStr+']'; + //if (lCond > 0) and (lCond <= kMaxCond) then lModelStr := lModelStr+ floattostr(gOffsetError[lCond]); + + end else + lModelStr := lModelStr+'observed[raw]'; + lModelStr := lModelStr+kTextSep; + lCondStr := 'Image=,'+gMRIcroOverlay[kBGOverlayNum].HdrFileName+', '+inttostr(lCond)+',Condition=,'+l4DTrace.Conditions[lCond].ELabel+lModelStr+'Events=, '+inttostr(l4DTrace.Conditions[lCond].Events)+', samples per bin= '+inttostr(lMinBinCount)+'..'+inttostr(lMaxBinCount); + lOutStr := kTextSep; + for lBin := 1 to 11 do + lOutStr := lOutStr+kTextSep; + + lOutStr := lOutStr+'Bin Starts At->'; + for lBin := 1 to lnBins do + lOutStr := lOutStr+kTextSep+ RealToStr((lNegMS+ ((lBin-1)* lmsPerBin)),0 ); + TextForm.MemoT.lines.add(lOutStr); + TextForm.MemoT.Lines.add('samples per bin '+inttostr(lMinBinCount)+'..'+inttostr(lMaxBinCount)); + //next report number of samples averaged + lOutStr := lCondStr+kTextSep+kTextSep+kTextSep+'samples in bin='; + for lBin := 1 to lnBins do + lOutStr := lOutStr+kTextSep+ inttostr(lCountBin^[lBin] ); + TextForm.MemoT.lines.add(lOutStr); + //next report mean signal + lOutMnStr := lCondStr+kTextSep+'roiMn'+kTextSep+'MaskROI['+ROIoverlayNameShort(lROI)+']='+kTextSep+ROIoverlayNameLong(lROI); + lOutSDStr := lCondStr+kTextSep+'roiSE'+kTextSep+'MaskROI['+ROIoverlayNameShort(lROI)+']='+kTextSep+ROIoverlayNameLong(lROI); + for lBin := 1 to (lnBins) do begin + lOutMnStr := lOutMnStr+kTextSep+ floattostr(lMnROI^[lBin]);//floattostr(lSumROI[lROI,lBin]/lBinCountRA[lBin]); + lOutSDStr := lOutSDStr+kTextSep+ floattostr(lSEROI^[lBin]);//StDev(lSumROI[lROI,lBin],lSumSqrROI[lROI,lBin],lBinCountRA[lBin]) ); + end; //for each bin + TextForm.MemoT.lines.add(lOutMnStr); + TextForm.MemoT.lines.add(lOutSDStr); + result := true; +end; //proc TextOutput + +function CalcMean (lTimeCourse: DoubleP;lnVol: integer): double; +var + lSum: double; + lVol: integer; +begin + result := 0; + if lnVol < 1 then + exit; + lSum := 0; + for lVol := 1 to lnVol do + lSum := lSum + lTimeCourse^[lVol]; //Sum + result := lSum / lnVol; +end; + +procedure PctSignal (lTimeCourse: DoubleP;lnVol: integer); +var + lMean,lScale: double; + lVol: integer; +begin + if lnVol < 1 then + exit; + lMean := CalcMean (lTimeCourse,lnVol); + if lMean = 0 then + exit; //can't compute % signal change... + lScale := abs(1/lMean); + for lVol := 1 to lnVol do + lTimeCourse^[lVol] := (lTimeCourse^[lVol]-lMean)*lScale; //Sum + +end; + +function CreatePeristimulusPlot (var l4DHdr: TMRIcroHdr; var l4DTrace: T4DTrace; var lPSPlot: TPSplot): boolean; +var + lBinData: T4DTrace; + lTimeCourse,lTimeCourseFilt: doublep; + lCountBin: longintp; + lMnBin,lSEBin,lSumBin,lSumSqrBin: doublep; + lCond,lncond,lnVol,lnROI,lROI,lnROImin1,lLine,lBin: integer; + lTR: double; +begin + result := false; + lncond := NCond (l4DTrace); + if lncond = 0 then begin + Showmessage('You need to specify event onset times before creating a peristimulus plot.'); + exit; + end; //cond = 0 + lnVol := l4DHdr.NIFTIhdr.dim[4]; + if lnVol < 3 then begin + Showmessage('Unable to compute plots: You need to analyze a 4D image.'); + exit; + end; + if (l4DHdr.ImgBufferItems = 0) then exit; + + lTR := lPSPlot.TRsec * 1000; + if lTR = 0 then begin + Showmessage('Unable to compute plots: You need to specify the TR in seconds.'); + exit; + end; + lnROI := 0; + for lROI := (kBGOverlayNum+1) to knMaxOverlay do + if gMRIcroOverlay[lROI].ScrnBufferItems > 0 then //current implementation only one ROI + inc(lnROI); + if lnROI < 1 then begin + lnROImin1 := 1; + end else begin + lnROImin1 := lnROI; + end; + //allocate memory + getmem(lTimeCourse,lnVol*sizeof(double)); + getmem(lTimeCourseFilt,lnVol*sizeof(double)); + getmem(lCountBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(integer)); + getmem(lMnBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(double)); + getmem(lSEBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(double)); + getmem(lSumSqrBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(double)); + getmem(lSumBin,(lPSPlot.nNegBins+lPSPlot.nPosBins)*sizeof(double)); + if lPSPlot.GraphOutput then begin + Create4DTrace (lBinData); + Init4DTrace(lPSPlot.nNegBins + lPSPlot.nPosBins,lnROImin1*lnCond,lBinData,true); + for lROI := 1 to lnROImin1 do + lBinData.Lines[lROI].ELabel := ROIoverlayNameShort(lROI); + end; //if graphoutput + //repeat for each Region of interest + for lROI := 1 to lnROImin1 do begin + //compute complete timecourse for all volumes... + if lnROI = 0 then begin + {$IFDEF FPC} + TimecourseVoxinten (l4DHdr, ImgForm.XViewEdit.value + + ((ImgForm.YViewEdit.value-1)*gBGImg.ScrnDim[1]) + +((ImgForm.ZViewEdit.value-1)*gBGImg.ScrnDim[1] + *gBGImg.ScrnDim[2]),lTimeCourse) + {$ELSE} + TimecourseVoxinten (l4DHdr, ImgForm.XViewEdit.asinteger + + ((ImgForm.YViewEdit.asinteger-1)*gBGImg.ScrnDim[1]) + +((ImgForm.ZViewEdit.asinteger-1)*gBGImg.ScrnDim[1] + *gBGImg.ScrnDim[2]),lTimeCourse) + {$ENDIF} + end else + TimecourseROIinten (l4DHdr, ROIoverlayNum(lROI), lTimeCourse); + //next normalize signal + if lPSPlot.PctSignal then + PctSignal(lTimeCourse,lnVol); + //next compute PSPlots + for lCond := 1 to lnCond do begin + //here is where we can remove variability predicted by regressors.... + {$IFDEF REMOVEREGRESS} + if lPSPlot.RemoveRegressorVariability then begin + RemoveRegressors(lTimeCourse,lTimeCourseFilt,l4DTrace,lCond,lnVol,lPSPlot); + TimeCourseToPSPlot(lTimeCourseFilt, l4DTrace,lCountBin, lMnBin,lSumBin,lSumSqrBin + ,lPSPlot, lCond,lnVol); + end else + {$ENDIF} + TimeCourseToPSPlot(lTimeCourse, l4DTrace,lCountBin, lMnBin,lSumBin,lSumSqrBin + ,lPSPlot,lCond,lnVol); + //percent signal change and std error + ComputeMeanSE (lCountBin, lMnBin,lSEBin,lSumBin,lSumSqrBin + ,lPSPlot.nNegBins,lPSPlot.nPosBins); + //report results + if lPSPlot.TextOutput then + TextOutput (lROI,lCond,lPSPlot, l4DTrace,lCountBin,lMnBin,lSEBin); + if (lPSPlot.GraphOutput) then begin + lLine := lROI + ((lCond-1)* lnROImin1); + for lBin := 1 to (lPSPlot.nNegBins + lPSPlot.nPosBins) do begin + lBinData.Lines[lLine].EventRA^[lBin] := lMnBin^[lBin]; + lBinData.Conditions[lLine].EventRA^[lBin] := lSEBin^[lBin]; + end;//for each bin + end; //if graphoutput + end; //for each cond + end; //for each ROI + freemem(lCountBin); //12/2007 + freemem(lTimeCourse); + freemem(lTimeCourseFilt); + freemem(lMnBin); + freemem(lSEBin); + freemem(lSumSqrBin); + freemem(lSumBin); + if lPSPlot.TextOutput then + TextForm.show; + if (lPSPlot.GraphOutput) then begin + MinMax4DTrace(lBinData); + for lCond := 1 to lnCond do + lBinData.Conditions[lCond].eLabel:= l4DTrace.Conditions[lCond].eLabel; + lBinData.HorzMin := (-lPSPlot.nNegBins+0.5)*lPSPlot.BinWidthSec; + lBinData.HorzWidPerBin := lPSPlot.BinWidthSec; + CorePlot4DTrace(lBinData,Graph4DForm.Image1,1,0,lnCond,lPSPlot.TRsec,Graph4DForm.MinEdit.value,Graph4DForm.MaxEdit.value,true); + Close4DTrace(lBinData,true); + end;//if graph + result := true; +end; + + +end. diff --git a/perisettings.lfm b/perisettings.lfm new file mode 100755 index 0000000..56c68a2 --- /dev/null +++ b/perisettings.lfm @@ -0,0 +1,140 @@ +object PSForm: TPSForm + Left = 1058 + Height = 398 + Top = 420 + Width = 370 + HorzScrollBar.Page = 369 + VertScrollBar.Page = 418 + ActiveControl = BinWidthEdit + Caption = 'Peristimulus Plot' + ClientHeight = 398 + ClientWidth = 370 + Constraints.MaxHeight = 398 + Constraints.MaxWidth = 370 + Constraints.MinHeight = 398 + Constraints.MinWidth = 370 + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '0.9.29' + object Label1: TLabel + Left = 40 + Height = 14 + Top = 25 + Width = 71 + Caption = 'Bin width (sec)' + ParentColor = False + end + object Label2: TLabel + Left = 40 + Height = 14 + Top = 62 + Width = 134 + Caption = 'Number of pre-stimulus bins' + ParentColor = False + end + object Label3: TLabel + Left = 40 + Height = 14 + Top = 101 + Width = 139 + Caption = 'Number of post-stimulus bins' + ParentColor = False + end + object BinWidthEdit: TFloatSpinEdit + Left = 232 + Height = 21 + Top = 16 + Width = 130 + DecimalPlaces = 4 + Increment = 1 + MaxValue = 100 + MinValue = 0 + TabOrder = 0 + Value = 0 + end + object PreBinEdit: TSpinEdit + Left = 232 + Height = 21 + Top = 53 + Width = 130 + MinValue = 1 + TabOrder = 1 + Value = 4 + end + object PostBinEdit: TSpinEdit + Left = 232 + Height = 21 + Top = 92 + Width = 130 + MinValue = 1 + TabOrder = 2 + Value = 14 + end + object SliceTImeCheck: TCheckBox + Left = 40 + Height = 17 + Top = 132 + Width = 139 + Caption = 'Data slice-time corrected' + TabOrder = 3 + end + object SavePSVolCheck: TCheckBox + Left = 40 + Height = 17 + Top = 164 + Width = 145 + Caption = 'Save peristimulus volumes' + TabOrder = 4 + end + object OKBtn: TButton + Left = 280 + Height = 25 + Top = 360 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + ModalResult = 1 + TabOrder = 5 + end + object PctSignalCheck: TCheckBox + Left = 40 + Height = 17 + Top = 200 + Width = 62 + Caption = '% Signal' + Checked = True + State = cbChecked + TabOrder = 6 + end + object ModelCheck: TCheckBox + Left = 80 + Height = 17 + Top = 320 + Width = 192 + Caption = 'Report modeled, not observed data' + TabOrder = 7 + Visible = False + end + object RegressCheck: TCheckBox + Left = 40 + Height = 17 + Top = 240 + Width = 116 + Caption = 'Remove Regressors' + Checked = True + OnClick = RegressCheckClick + State = cbChecked + TabOrder = 8 + end + object TDCheck: TCheckBox + Left = 80 + Height = 17 + Top = 280 + Width = 181 + Caption = 'Also Remove Temporal Derivative' + Checked = True + State = cbChecked + TabOrder = 9 + Visible = False + end +end diff --git a/perisettings.lrs b/perisettings.lrs new file mode 100644 index 0000000..b4de369 --- /dev/null +++ b/perisettings.lrs @@ -0,0 +1,37 @@ +LazarusResources.Add('TPSForm','FORMDATA',[ + 'TPF0'#7'TPSForm'#6'PSForm'#4'Left'#3'"'#4#6'Height'#3#142#1#3'Top'#3#164#1#5 + +'Width'#3'r'#1#18'HorzScrollBar.Page'#3'q'#1#18'VertScrollBar.Page'#3#162#1 + +#13'ActiveControl'#7#12'BinWidthEdit'#7'Caption'#6#17'Peristimulus Plot'#12 + +'ClientHeight'#3#142#1#11'ClientWidth'#3'r'#1#21'Constraints.MaxHeight'#3#142 + +#1#20'Constraints.MaxWidth'#3'r'#1#21'Constraints.MinHeight'#3#142#1#20'Cons' + +'traints.MinWidth'#3'r'#1#6'OnShow'#7#8'FormShow'#8'Position'#7#14'poScreenC' + +'enter'#10'LCLVersion'#6#6'0.9.29'#0#6'TLabel'#6'Label1'#4'Left'#2'('#6'Heig' + +'ht'#2#14#3'Top'#2#25#5'Width'#2'G'#7'Caption'#6#15'Bin width (sec)'#11'Pare' + +'ntColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2'('#6'Height'#2#14#3'Top'#2'>'#5 + +'Width'#3#134#0#7'Caption'#6#27'Number of pre-stimulus bins'#11'ParentColor' + +#8#0#0#6'TLabel'#6'Label3'#4'Left'#2'('#6'Height'#2#14#3'Top'#2'e'#5'Width'#3 + +#139#0#7'Caption'#6#28'Number of post-stimulus bins'#11'ParentColor'#8#0#0#14 + +'TFloatSpinEdit'#12'BinWidthEdit'#4'Left'#3#232#0#6'Height'#2#21#3'Top'#2#16 + +#5'Width'#3#130#0#13'DecimalPlaces'#2#4#9'Increment'#2#1#8'MaxValue'#2'd'#8 + +'MinValue'#2#0#8'TabOrder'#2#0#5'Value'#2#0#0#0#9'TSpinEdit'#10'PreBinEdit'#4 + +'Left'#3#232#0#6'Height'#2#21#3'Top'#2'5'#5'Width'#3#130#0#8'MinValue'#2#1#8 + +'TabOrder'#2#1#5'Value'#2#4#0#0#9'TSpinEdit'#11'PostBinEdit'#4'Left'#3#232#0 + +#6'Height'#2#21#3'Top'#2'\'#5'Width'#3#130#0#8'MinValue'#2#1#8'TabOrder'#2#2 + +#5'Value'#2#14#0#0#9'TCheckBox'#14'SliceTImeCheck'#4'Left'#2'('#6'Height'#2 + +#17#3'Top'#3#132#0#5'Width'#3#139#0#7'Caption'#6#25'Data slice-time correcte' + +'d'#8'TabOrder'#2#3#0#0#9'TCheckBox'#14'SavePSVolCheck'#4'Left'#2'('#6'Heigh' + +'t'#2#17#3'Top'#3#164#0#5'Width'#3#145#0#7'Caption'#6#25'Save peristimulus v' + +'olumes'#8'TabOrder'#2#4#0#0#7'TButton'#5'OKBtn'#4'Left'#3#24#1#6'Height'#2 + +#25#3'Top'#3'h'#1#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption' + +#6#2'OK'#11'ModalResult'#2#1#8'TabOrder'#2#5#0#0#9'TCheckBox'#14'PctSignalCh' + +'eck'#4'Left'#2'('#6'Height'#2#17#3'Top'#3#200#0#5'Width'#2'>'#7'Caption'#6#8 + +'% Signal'#7'Checked'#9#5'State'#7#9'cbChecked'#8'TabOrder'#2#6#0#0#9'TCheck' + +'Box'#10'ModelCheck'#4'Left'#2'P'#6'Height'#2#17#3'Top'#3'@'#1#5'Width'#3#192 + +#0#7'Caption'#6'!Report modeled, not observed data'#8'TabOrder'#2#7#7'Visibl' + +'e'#8#0#0#9'TCheckBox'#12'RegressCheck'#4'Left'#2'('#6'Height'#2#17#3'Top'#3 + +#240#0#5'Width'#2't'#7'Caption'#6#17'Remove Regressors'#7'Checked'#9#7'OnCli' + +'ck'#7#17'RegressCheckClick'#5'State'#7#9'cbChecked'#8'TabOrder'#2#8#0#0#9'T' + +'CheckBox'#7'TDCheck'#4'Left'#2'P'#6'Height'#2#17#3'Top'#3#24#1#5'Width'#3 + +#181#0#7'Caption'#6#31'Also Remove Temporal Derivative'#7'Checked'#9#5'State' + +#7#9'cbChecked'#8'TabOrder'#2#9#7'Visible'#8#0#0#0 +]); diff --git a/perisettings.pas b/perisettings.pas new file mode 100755 index 0000000..5843d56 --- /dev/null +++ b/perisettings.pas @@ -0,0 +1,96 @@ +unit perisettings; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Spin, + StdCtrls, define_types; + +type + + { TPSForm } + + TPSForm = class(TForm) + BinWidthEdit: TFloatSpinEdit; + OKBtn: TButton; + SavePSVolCheck: TCheckBox; + PctSignalCheck: TCheckBox; + ModelCheck: TCheckBox; + RegressCheck: TCheckBox; + TDCheck: TCheckBox; + SliceTImeCheck: TCheckBox; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + PreBinEdit: TSpinEdit; + PostBinEdit: TSpinEdit; + procedure FormShow(Sender: TObject); + function GetPeriSettings(var lPSPlot: TPSPlot): boolean; + procedure OKBtnClick(Sender: TObject); + procedure RegressCheckClick(Sender: TObject); + + private + { private declarations } + public + { public declarations } + end; + +var + PSForm: TPSForm; + +implementation +uses nifti_img_view; + + function TPSForm.GetPeriSettings(var lPSPlot: TPSPlot): boolean; + begin + result := false; + if lPSPlot.TRSec <= 0 then begin + showmessage('Please specify the TR (in seconds) before creating a peristimulus plot.'); + exit; + end; + if BinWidthEdit.value = 0 then + BinWidthEdit.value := lPSPlot.TRsec; + PSForm.ShowModal; + if BinWidthEdit.value = 0 then + BinWidthEdit.value := lPSPlot.TRsec + else + lPSPlot.BinWidthSec := BinWidthEdit.Value; + lPSPlot.nNegBins := PreBinEdit.value; + lPSPlot.nPosBins := PostBinEdit.value; + lPSPlot.SliceTime := SliceTimeCheck.checked; + lPSPlot.SavePSVol := SavePSVolCheck.checked; + lPSPlot.BaselineCorrect := ModelCheck.checked; + lPSPlot.PctSignal := PctSignalCheck.checked; + lPSPlot.RemoveRegressorVariability := RegressCheck.checked; + lPSPlot.TemporalDeriv := TDcheck.checked; + lPSPlot.PlotModel := ModelCheck.checked; + lPSPlot.SPMDefaultsStatsFmriT := gBGImg.SPMDefaultsStatsFmriT; + lPSPlot.SPMDefaultsStatsFmriT0 := gBGImg.SPMDefaultsStatsFmriT0; + result := true; + end; + + procedure TPSForm.FormShow(Sender: TObject); + begin + RegressCheckClick(nil); + end; + + + + procedure TPSForm.OKBtnClick(Sender: TObject); + begin + + end; + + procedure TPSForm.RegressCheckClick(Sender: TObject); + begin + TDCheck.visible := RegressCheck.checked; + ModelCheck.Visible := RegressCheck.checked; + end; + +initialization + {$I perisettings.lrs} + +end. + diff --git a/periutils.pas b/periutils.pas new file mode 100755 index 0000000..7b8281e --- /dev/null +++ b/periutils.pas @@ -0,0 +1,313 @@ +unit periutils; +interface +{$IFDEF FPC} {$H+} {$ENDIF} + +uses metagraph, define_types, sysutils,nifti_hdr, classes; + +function FSLMatName (lFeatDir: string): string; +function FSLFuncName (lFeatDir: string): string;//Given feat folder returns name of filtered data +function FSLReslicedVOIName (lFeatDir, lMNIVOIName: string): string; +procedure RegressTrace (var l4DTrace: T4DTrace); +function ConvertToTrace (var l4DHdr: TMRIcroHdr;var l4DTrace: T4DTrace; lX,lY,lZ: integer): boolean; +function ReadCond (l3ColTextFileName: string; var l4DTrace: T4DTrace; lCond: integer): boolean; +procedure FSLEVNames (lFeatDir: string; var lEVlist: TStringList); + +implementation + +uses nifti_img_view, text,dialogs,periplot; + +function ReadCond (l3ColTextFileName: string; var l4DTrace: T4DTrace; lCond: integer): boolean; +var + lOnsetText: TextFile; + lnEvents: integer; + lFloat,lFloat2,lFloat3: single; +begin + result := false; + if (lCond < 1) or (lCond > kMaxCond) then + exit; + CloseCond(l4DTrace,lCond); + + Filemode := 0; + assignfile(lOnsetText,l3ColTextFileName); + {I-} + reset(lOnsetText); + {$I+} + if ioresult <> 0 then begin + Showmessage('Unable to read file [may be in use by another program '+ l3ColTextFileName); + exit; + end; + lnEvents := 0; + while not EOF(lOnsetText) do begin + {$I-} + read(lOnsetText,lFloat,lFloat2,lFloat3); //read triplets instead of readln: this should load UNIX files + {$I+} + if (ioresult = 0) and (lFloat3 > 0) then + inc(lnEvents); + end; + if lnEvents < 1 then begin + closefile(lOnsetText); + showmessage('No events detected. Is this really a FSL-style 3 Column format file? '+l3ColTextFileName); + exit; + end; + InitCond (l4DTrace, lCond, lnEvents); + reset(lOnsetText); + lnEvents := 0; + while not EOF(lOnsetText) do begin + lFloat := 0; + {$I-} + read(lOnsetText,lFloat,lFloat2,lFloat3); //read triplets instead of readln: this should load UNIX files + {$I+} + if (ioresult = 0) and (lFloat3 > 0) then begin + inc(lnEvents); + l4DTrace.Conditions[lCond].EventRA^[lnEvents] := lFloat; + l4DTrace.Conditions[lCond].DurRA^[lnEvents] := lFloat2; + //l4DTrace.DurRA[lCond]^[lnEvents] := lFloat2; + end; + end; + closefile(lOnsetText); + l4DTrace.Conditions[lCond].ELabel := parsefilename(extractfilename(l3ColTextFileName)); + result := true; +end; + +function ConvertToTrace (var l4DHdr: TMRIcroHdr;var l4DTrace: T4DTrace; lX,lY,lZ: integer): boolean; +var + lVol,lVolSz,lPos,lSamples,lLine,lnLines,lROI: integer; + l16Buf : SmallIntP; + l32Buf : SingleP; +begin + result := false; + lSamples := l4DHdr.NIFTIhdr.dim[4]; + lVolSz := l4DHdr.NIFTIhdr.dim[1]*l4DHdr.NIFTIhdr.dim[2]*l4DHdr.NIFTIhdr.dim[3]; + if lSamples < 2 then + exit; + + lnLines := 0; + for lVol := (kBGOverlayNum+1) to knMaxOverlay do + if gMRIcroOverlay[lVol].ScrnBufferItems > 0 then //for each ROI + inc(lnLines); + if lnLines = 0 then begin //no ROIs + lLine := 1; + lPos := lX + ((lY-1)*gBGImg.ScrnDim[1])+((lZ-1)*gBGImg.ScrnDim[1]*gBGImg.ScrnDim[2]); + if (lPos > l4DHdr.ImgBufferItems) or (lPos < 1) then exit; + Init4DTrace(lSamples, 1,l4DTrace,false); + l4DTrace.Lines[1].ELabel := inttostr(lX)+'x'+inttostr(lY)+'x'+inttostr(lZ); + if (l4DHdr.ImgBufferBPP = 4) then begin + l32Buf := SingleP(l4DHdr.ImgBuffer ); + for lVol := 1 to lSamples do begin + l4DTrace.Lines[lLine].EventRA[lVol] := l32Buf[lPos]; + lPos := lPos + lVolSz; + end; + end else if (l4DHdr.ImgBufferBPP = 2) then begin + l16Buf := SmallIntP(l4DHdr.ImgBuffer ); + for lVol := 1 to lSamples do begin + l4DTrace.Lines[lLine].EventRA^[lVol] := l16Buf^[lPos]; + lPos := lPos + lVolSz; + end; + end else if l4DHdr.ImgBufferBPP = 1 then begin + for lVol := 1 to lSamples do begin + l4DTrace.Lines[lLine].EventRA^[lVol] := l4DHdr.ImgBuffer^[lPos]; + lPos := lPos + lVolSz; + end; + end else + showmessage('Serious error: unknown data size!'); + end else begin //>0 ROIS + Init4DTrace(lSamples, lnLines,l4DTrace,false); + for lLine := 1 to lnLines do begin + lROI := ROIoverlayNum(lLine); + l4DTrace.Lines[lLine].ELabel := ParseFileName(extractfilename(gMRIcroOverlay[lROI].HdrFileName)); + for lVol := 1 to lSamples do + l4DTrace.Lines[lLine].EventRA^[lVol] := ROImean(l4DHdr,lROI,lVol{,lVolSz}); + end; + end; + MinMax4DTrace(l4DTrace); + result := true; +end; + +function ComputeRegress (ldataRA: singlep; lndata: integer): string; +const + //kMax = 1000; + kCR = chr (13); +Var + gx : Array[1..4] of extended; + gy : Array[1..4] of extended; + Exy : Array[1..4] of extended; + Ex : Array[1..4] of extended; + Ey : Array[1..4] of extended; + Ex2 : Array[1..4] of extended; + Ey2 : Array[1..4] of extended; + a : Array[1..4] of extended; + b : Array[1..4] of extended; + r : Array[1..4] of extended; + chtX: Array[1..4] of extended; + chtY: Array[1..4] of extended; + no : Integer; + gInter, gSlope,gRSqr : extended; + +function calcit: string; +Var + q : Integer; +Begin + +For q := 1 To 4 Do Begin + b[q] := (no * Exy[q] - Ex[q] * Ey[q]) / (no * Ex2[q] - (Ex[q]*Ex[q]) ); + a[q] := (Ey[q] - b[q] * Ex[q]) / no; + r[q] := (no * Exy[q] - Ex[q] * Ey[q]) / (Sqrt((no * Ex2[q] - (Ex[q]*Ex[q]) ) * (no * Ey2[q] - (Ey[q]*Ey[q]) ) )); +End; // for +a[2] := Exp(a[2]); +a[4] := Exp(a[4]); +result := (' Linear Y=' + RealToStr(a[1],8) + ' +' + RealToStr(b[1],8) + ' * X'+' R=' + RealToStr(r[1],8)+' R^2=' + RealToStr(r[1]*r[1],8)); +gInter := a[1]; +gSlope := b[1]; +gRSqr := r[1]; +result := result + (', Exp Y=' + RealToStr(a[2],8) + ' * e ^' + RealToStr(b[2],8) + ' * X'+' R=' + RealToStr(r[2],8)+' R^2=' + RealToStr(r[2]*r[2],8)); +result := result + (', Log Y=' + RealToStr(a[3],8) + ' +' + RealToStr(b[3],8) + ' * LOG(X)'+' R=' + RealToStr(r[3],8)+' R^2=' + RealToStr(r[3]*r[3],8)); +result := result +(', Power Y=' + RealToStr(a[4],8) + ' * X ^' + RealToStr(b[4],8)+' R=' + RealToStr(r[4],8)+' R^2=' + RealToStr(r[4]*r[4],8)); +End; // nested calcit() +Procedure inpcalc (lX, lY: extended); +Var + q : Integer; +Begin +gx[1] := lX; +gy[1] := lY; +//inc(gnVal); +inc(no); + gx[2] := gx[1]; + gy[2] := Ln(gy[1]); // exp +gx[3] := Ln(gx[1]); + gy[3] := gy[1]; // log +gx[4] := Ln(gx[1]); + gy[4] := Ln(gy[1]); // power + +For q := 1 To 4 Do Begin + Exy[q] := Exy[q] + gx[q] * gy[q]; + Ex[q] := Ex[q] + gx[q]; + Ey[q] := Ey[q] + gy[q]; + Ex2[q] := Ex2[q] + (gx[q]*gx[q]); + Ey2[q] := Ey2[q] + (gy[q]*gy[q]); + End; // For +End; //nested inpcalc +procedure initReg; +var lC: byte; +begin +for lC := 1 to 4 do begin + gx [lC]:= 0; + gy [lC]:= 0; + Exy [lC]:= 0; + Ex[lC]:= 0; + Ey[lC]:= 0; + Ex2[lC]:= 0; + Ey2[lC]:= 0; + a[lC]:= 0; + b[lC]:= 0; + r[lC]:= 0; + chtX[lC]:= 0; + chtY[lC]:= 0; + end; //for lC +end;//nested inp calc +const + kDeleteVols = 3; +var + i: integer; +begin //computeRegress + result := ''; + no := 0; + if lndata < (kDeleteVols+5) then exit; + + //gnVal := 0; + initReg; + for i := kDeleteVols to lndata do begin + //fx(i,ldatara[i]); + inpcalc (i, ldataRA^[i]); + end; + result := calcit; +end; //func ComputeRegress + +procedure RegressTrace (var l4DTrace: T4DTrace); +var + lStr: string; + lE,lCond, lnCond,lnE: integer; + lMean : double; + ldataRA: singlep; +begin + lncond := 0; + for lCond := 1 to kMaxCond do + if l4DTrace.Lines[lCond].Events > 0 then + inc(lnCond); + if lncond = 0 then + exit; + for lCond := 1 to kMaxCond do begin + if l4DTrace.Lines[lCond].Events > 0 then begin + lnE := l4DTrace.Lines[lCond].Events; + getmem(ldataRA,lnE * sizeof(single)); + lStr := gMRIcroOverlay[kBGOverlayNum].HdrFileName+','+l4DTrace.Lines[lCond].ELabel; + //load data + lMean := 0; + for lE := 1 to lnE do begin + ldataRA[lE] := l4DTrace.Lines[lCond].EventRA[lE]; + lMean := ldataRA^[lE] + lMean; //sum + end; + + lMean := lMean / lnE; + //fx(lMean); + //normalize data... + for lE := 1 to lnE do + ldataRA^[lE] := ldataRA^[lE]/lMean; + //compute functions + lStr := lStr +kTextSep+ (ComputeRegress (ldataRA, lnE) ); + TextForm.MemoT.lines.add(lStr); + //TextForm.Memo1.lines.add(lStr); + freemem(ldataRA); + end; + end; + //TextForm.show; +end; + +//NEXT SECTION - FSL UTILITIES +procedure FSLEVNames (lFeatDir: string; var lEVlist: TStringList); +//Given feat folder returns name of matrix to reorient MNI image to functional data +var + lEVdir : string; + lSearchRec: TSearchRec; +begin + lEVList.clear; + lEVdir := lFEATDir+pathdelim+'custom_timing_files'; +//showmessage(lEVdir); + if not DirExists(lEVdir) then + exit; +//showmessage(lEVdir); + if FindFirst(lEVdir+pathdelim+'*'+'.txt', faAnyFile, lSearchRec) = 0 then begin + repeat + lEVlist.Add(lEVdir+pathdelim+lSearchRec.Name) + until (FindNext(lSearchRec) <> 0); + end; + FindClose(lSearchRec); +//fx(lEVlist.count); + //result := lFeatDir+PathDelim+'reg'+PathDelim+'example_func2standard.mat'; +end; //MatName + + + +function FSLMatName (lFeatDir: string): string; +//Given feat folder returns name of matrix to reorient MNI image to functional data +begin + result := lFeatDir+PathDelim+'reg'+PathDelim+'example_func2standard.mat'; +end; //MatName + +function FSLFuncName (lFeatDir: string): string;//Given feat folder returns name of filtered data +begin + result := lFeatDir+PathDelim+'filtered_func_data.nii.gz'; +end; //FuncName + +function FSLReslicedVOIName (lFeatDir, lMNIVOIName: string): string; +//Given FSL .feat folder name and source MNI volume name retuns resliced VOI name +begin + result := lFeatDir+PathDelim+extractfilename(lMNIVOIName); + + + (*result := extractfilename(lMNIVOIName); + result := lFeatDir+PathDelim+ChangeFileExtX(result,'.nii.gz'); //; + *) +end; //ReslicedVOIName + + +end. diff --git a/prefs.lfm b/prefs.lfm new file mode 100755 index 0000000..52dc60e --- /dev/null +++ b/prefs.lfm @@ -0,0 +1,155 @@ +object PrefForm: TPrefForm + Left = 932 + Height = 456 + Top = 200 + Width = 393 + ActiveControl = ResliceCheck + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'Preferences' + ClientHeight = 456 + ClientWidth = 393 + Constraints.MaxHeight = 456 + Constraints.MaxWidth = 393 + Constraints.MinHeight = 456 + Constraints.MinWidth = 393 + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.4.0.4' + object GroupBox1: TGroupBox + Left = 8 + Height = 280 + Top = 8 + Width = 368 + Caption = 'Image Display' + ClientHeight = 258 + ClientWidth = 360 + TabOrder = 0 + object Label1: TLabel + Left = 120 + Height = 16 + Top = 71 + Width = 189 + Caption = 'Maximum Dimension [Voxels]' + ParentColor = False + end + object Label2: TLabel + Left = 120 + Height = 16 + Top = 113 + Width = 119 + Caption = 'Rendering Threads' + ParentColor = False + end + object Label3: TLabel + Left = 120 + Height = 16 + Top = 145 + Width = 160 + Caption = 'Decimal places Displayed' + ParentColor = False + end + object ResliceCheck: TCheckBox + Left = 15 + Height = 18 + Top = 9 + Width = 206 + Caption = 'Reorient images when loading' + OnClick = ResliceCheckClick + TabOrder = 0 + end + object MaxDimEdit: TSpinEdit + Left = 14 + Height = 16 + Top = 64 + Width = 100 + MaxValue = 4096 + MinValue = 256 + TabOrder = 1 + Value = 256 + end + object ThreadEdit: TSpinEdit + Left = 14 + Height = 16 + Top = 101 + Width = 100 + MaxValue = 4096 + MinValue = 1 + TabOrder = 2 + Value = 1 + end + object SigDigEdit: TSpinEdit + Left = 14 + Height = 16 + Top = 138 + Width = 100 + MaxValue = 32 + TabOrder = 3 + end + object OrthoCheck: TCheckBox + Left = 43 + Height = 18 + Top = 37 + Width = 234 + Caption = 'Rotate to nearest orthogonal angle' + TabOrder = 4 + end + object SingleRowCheck: TCheckBox + Left = 16 + Height = 18 + Top = 208 + Width = 171 + Caption = 'All slices on a single row' + TabOrder = 5 + end + end + object GroupBox2: TGroupBox + Left = 8 + Height = 64 + Top = 296 + Width = 368 + Caption = 'Drawing' + ClientHeight = 42 + ClientWidth = 360 + TabOrder = 1 + object ThinPenCheck: TCheckBox + Left = 15 + Height = 18 + Top = 16 + Width = 74 + Caption = 'Thin Pen' + TabOrder = 0 + end + end + object OKBtn: TButton + Left = 296 + Height = 25 + Top = 416 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'OK' + OnClick = OKBtnClick + TabOrder = 2 + end + object CancelBtn: TButton + Left = 192 + Height = 25 + Top = 416 + Width = 75 + BorderSpacing.InnerBorder = 4 + Caption = 'Cancel' + OnClick = CancelBtnClick + TabOrder = 3 + end + object XBarClr: TButton + Left = 26 + Height = 25 + Top = 197 + Width = 178 + BorderSpacing.InnerBorder = 4 + Caption = 'Choose Cross-Bar Color' + OnClick = XBarClrClick + TabOrder = 4 + end +end diff --git a/prefs.lrs b/prefs.lrs new file mode 100644 index 0000000..d46c1ba --- /dev/null +++ b/prefs.lrs @@ -0,0 +1,41 @@ +LazarusResources.Add('TPrefForm','FORMDATA',[ + 'TPF0'#9'TPrefForm'#8'PrefForm'#4'Left'#3#164#3#6'Height'#3#200#1#3'Top'#3#200 + +#0#5'Width'#3#137#1#13'ActiveControl'#7#12'ResliceCheck'#11'BorderIcons'#11 + +#12'biSystemMenu'#0#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#11'Preference' + +'s'#12'ClientHeight'#3#200#1#11'ClientWidth'#3#137#1#21'Constraints.MaxHeigh' + +'t'#3#200#1#20'Constraints.MaxWidth'#3#137#1#21'Constraints.MinHeight'#3#200 + +#1#20'Constraints.MinWidth'#3#137#1#8'OnCreate'#7#10'FormCreate'#6'OnShow'#7 + +#8'FormShow'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#7'1.4.0.4'#0#9 + +'TGroupBox'#9'GroupBox1'#4'Left'#2#8#6'Height'#3#24#1#3'Top'#2#8#5'Width'#3 + +'p'#1#7'Caption'#6#13'Image Display'#12'ClientHeight'#3#2#1#11'ClientWidth'#3 + +'h'#1#8'TabOrder'#2#0#0#6'TLabel'#6'Label1'#4'Left'#2'x'#6'Height'#2#16#3'To' + +'p'#2'G'#5'Width'#3#189#0#7'Caption'#6#26'Maximum Dimension [Voxels]'#11'Par' + +'entColor'#8#0#0#6'TLabel'#6'Label2'#4'Left'#2'x'#6'Height'#2#16#3'Top'#2'q' + +#5'Width'#2'w'#7'Caption'#6#17'Rendering Threads'#11'ParentColor'#8#0#0#6'TL' + +'abel'#6'Label3'#4'Left'#2'x'#6'Height'#2#16#3'Top'#3#145#0#5'Width'#3#160#0 + +#7'Caption'#6#24'Decimal places Displayed'#11'ParentColor'#8#0#0#9'TCheckBox' + +#12'ResliceCheck'#4'Left'#2#15#6'Height'#2#18#3'Top'#2#9#5'Width'#3#206#0#7 + +'Caption'#6#28'Reorient images when loading'#7'OnClick'#7#17'ResliceCheckCli' + +'ck'#8'TabOrder'#2#0#0#0#9'TSpinEdit'#10'MaxDimEdit'#4'Left'#2#14#6'Height'#2 + +#16#3'Top'#2'@'#5'Width'#2'd'#8'MaxValue'#3#0#16#8'MinValue'#3#0#1#8'TabOrde' + +'r'#2#1#5'Value'#3#0#1#0#0#9'TSpinEdit'#10'ThreadEdit'#4'Left'#2#14#6'Height' + +#2#16#3'Top'#2'e'#5'Width'#2'd'#8'MaxValue'#3#0#16#8'MinValue'#2#1#8'TabOrde' + +'r'#2#2#5'Value'#2#1#0#0#9'TSpinEdit'#10'SigDigEdit'#4'Left'#2#14#6'Height'#2 + +#16#3'Top'#3#138#0#5'Width'#2'd'#8'MaxValue'#2' '#8'TabOrder'#2#3#0#0#9'TChe' + +'ckBox'#10'OrthoCheck'#4'Left'#2'+'#6'Height'#2#18#3'Top'#2'%'#5'Width'#3#234 + +#0#7'Caption'#6'"Rotate to nearest orthogonal angle'#8'TabOrder'#2#4#0#0#9'T' + +'CheckBox'#14'SingleRowCheck'#4'Left'#2#16#6'Height'#2#18#3'Top'#3#208#0#5'W' + +'idth'#3#171#0#7'Caption'#6#26'All slices on a single row'#8'TabOrder'#2#5#0 + +#0#0#9'TGroupBox'#9'GroupBox2'#4'Left'#2#8#6'Height'#2'@'#3'Top'#3'('#1#5'Wi' + +'dth'#3'p'#1#7'Caption'#6#7'Drawing'#12'ClientHeight'#2'*'#11'ClientWidth'#3 + +'h'#1#8'TabOrder'#2#1#0#9'TCheckBox'#12'ThinPenCheck'#4'Left'#2#15#6'Height' + +#2#18#3'Top'#2#16#5'Width'#2'J'#7'Caption'#6#8'Thin Pen'#8'TabOrder'#2#0#0#0 + +#0#7'TButton'#5'OKBtn'#4'Left'#3'('#1#6'Height'#2#25#3'Top'#3#160#1#5'Width' + +#2'K'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#2'OK'#7'OnClick'#7#10'O' + +'KBtnClick'#8'TabOrder'#2#2#0#0#7'TButton'#9'CancelBtn'#4'Left'#3#192#0#6'He' + +'ight'#2#25#3'Top'#3#160#1#5'Width'#2'K'#25'BorderSpacing.InnerBorder'#2#4#7 + +'Caption'#6#6'Cancel'#7'OnClick'#7#14'CancelBtnClick'#8'TabOrder'#2#3#0#0#7 + +'TButton'#7'XBarClr'#4'Left'#2#26#6'Height'#2#25#3'Top'#3#197#0#5'Width'#3 + +#178#0#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#22'Choose Cross-Bar Co' + +'lor'#7'OnClick'#7#12'XBarClrClick'#8'TabOrder'#2#4#0#0#0 +]); diff --git a/prefs.pas b/prefs.pas new file mode 100755 index 0000000..55604ad --- /dev/null +++ b/prefs.pas @@ -0,0 +1,109 @@ +unit prefs; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, + Spin, Buttons; + +type + + { TPrefForm } + + TPrefForm = class(TForm) + SingleRowCheck: TCheckBox; + OrthoCheck: TCheckBox; + XBarClr: TButton; + OKBtn: TButton; + CancelBtn: TButton; + ThinPenCheck: TCheckBox; + GroupBox2: TGroupBox; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + ResliceCheck: TCheckBox; + GroupBox1: TGroupBox; + MaxDimEdit: TSpinEdit; + ThreadEdit: TSpinEdit; + SigDigEdit: TSpinEdit; + procedure CancelBtnClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure OKBtnClick(Sender: TObject); + procedure ResliceCheckClick(Sender: TObject); + procedure XBarClrClick(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + PrefForm: TPrefForm; + +implementation + uses + nifti_img_view; +{ TPrefForm } + +procedure TPrefForm.CancelBtnClick(Sender: TObject); +begin + Close; +end; + +procedure TPrefForm.FormCreate(Sender: TObject); +begin + +end; + +procedure TPrefForm.FormShow(Sender: TObject); +begin + //RGBPlanarCheck.checked := gBGImg.isPlanarRGB; + ResliceCheck.checked := gBGImg.ResliceOnLoad; + //OrthoCheck.Visible := not gBGImg.ResliceOnLoad; + OrthoCheck.checked := gBGImg.OrthoReslice; + MaxDimEdit.value := gBGImg.MaxDim; + ThreadEdit.value := gnCPUThreads; + //DrawCheck.checked := ImgForm.ToolPanel.Visible; + ThinPenCheck.Checked := gBGImg.ThinPen; + SigDigEdit.value := gBGImg.SigDig; + SingleRowCheck.checked := gBGImg.SingleRow; +end; + +procedure TPrefForm.OKBtnClick(Sender: TObject); +begin + //gBGImg.isPlanarRGB := RGBPlanarCheck.checked; + gBGImg.ResliceOnLoad := ResliceCheck.checked; + gBGImg.OrthoReslice := OrthoCheck.checked; + gBGImg.MaxDim := MaxDimEdit.value; + gnCPUThreads := ThreadEdit.value; + //ImgForm.ToolPanel.Visible := DrawCheck.checked; + //ImgForm.DrawMenu.Visible := DrawCheck.checked; + gBGImg.ThinPen := ThinPenCheck.Checked; + gBGImg.SigDig := SigDigEdit.value; + if gBGImg.SingleRow <> SingleRowCheck.Checked then begin + gBGImg.SingleRow := SingleRowCheck.Checked; + ImgForm.DefaultControlPanel; + ImgForm.RefreshImagesTimer.enabled := true; + end; + Close; +end; + +procedure TPrefForm.ResliceCheckClick(Sender: TObject); +begin + OrthoCheck.Visible := not ResliceCheck.checked; +end; + +procedure TPrefForm.XBarClrClick(Sender: TObject); +begin + ImgForm.XBarColor; + PrefForm.BringToFront; +end; + +initialization + {$I prefs.lrs} + +end. + diff --git a/render.lfm b/render.lfm new file mode 100755 index 0000000..8cd2f3b --- /dev/null +++ b/render.lfm @@ -0,0 +1,574 @@ +object RenderForm: TRenderForm + Left = 461 + Height = 512 + Top = 140 + Width = 955 + ActiveControl = RenderBar + Caption = 'Volume Render' + ClientHeight = 512 + ClientWidth = 955 + Menu = MainMenu1 + OnCreate = FormCreate + OnHide = FormHide + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '1.5' + object RenderBar: TPanel + Left = 0 + Height = 32 + Top = 0 + Width = 955 + Align = alTop + BevelOuter = bvNone + ClientHeight = 32 + ClientWidth = 955 + TabOrder = 0 + object Label4: TLabel + Left = 152 + Height = 16 + Top = 5 + Width = 57 + Caption = 'Elevation' + ParentColor = False + end + object Label1: TLabel + Left = 4 + Height = 16 + Top = 5 + Width = 53 + Caption = 'Azimuth' + ParentColor = False + end + object RefreshBtn: TSpeedButton + Left = 296 + Height = 31 + Hint = 'Generate high-resolution rendering' + Top = 0 + Width = 40 + Glyph.Data = { + 76080000424D7608000000000000360000002800000018000000160000000100 + 2000000000004008000064000000640000000000000000000000FFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFF + FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 + FFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFFFFFFFFFFFFFFFFFFFFFF + FFFFFFFFFFFF0000FFFF0000FFFF0000FFFF0000FFFF0000FFFF + } + OnClick = RefreshClick + ShowHint = True + ParentShowHint = False + end + object RenderImageBUP: TImage + Tag = 2 + Cursor = crCross + Left = 360 + Height = 12 + Top = 8 + Width = 12 + AutoSize = True + Center = True + OnMouseDown = RenderImageMouseDown + OnMouseMove = RenderImageMouseMove + Stretch = True + Visible = False + end + object Label5: TLabel + Left = 616 + Height = 16 + Top = 5 + Width = 63 + Caption = 'Shading %' + ParentColor = False + end + object AzimuthEdit: TSpinEdit + Left = 72 + Height = 16 + Top = 2 + Width = 70 + Increment = 30 + MaxValue = 360 + OnChange = EditChange + TabOrder = 0 + Value = 120 + end + object ElevationEdit: TSpinEdit + Left = 216 + Height = 16 + Top = 2 + Width = 70 + Increment = 30 + MaxValue = 180 + MinValue = -180 + OnChange = EditChange + TabOrder = 1 + Value = 30 + end + object BiasTrack: TTrackBar + Left = 352 + Height = 29 + Top = 2 + Width = 120 + Max = 100 + OnChange = BiasTrackChange + Position = 50 + TickStyle = tsNone + TabOrder = 2 + end + object GainTrack: TTrackBar + Left = 480 + Height = 29 + Top = 2 + Width = 120 + Max = 100 + OnChange = BiasTrackChange + Position = 50 + TickStyle = tsNone + TabOrder = 3 + end + object ShadeEdit: TSpinEdit + Left = 690 + Height = 16 + Top = 2 + Width = 70 + Increment = 10 + OnChange = EditChange + TabOrder = 4 + end + object ClipTrack: TTrackBar + Left = 776 + Height = 29 + Top = 2 + Width = 120 + Max = 999 + OnChange = ClipTrackChange + Position = 0 + TickStyle = tsNone + TabOrder = 5 + end + end + object RenderPanel: TScrollBox + Left = 0 + Height = 480 + Top = 32 + Width = 955 + HorzScrollBar.Page = 14 + VertScrollBar.Page = 14 + Align = alClient + ClientHeight = 465 + ClientWidth = 940 + TabOrder = 1 + object RenderImage: TImage + Tag = 2 + Cursor = crCross + Left = 2 + Height = 12 + Top = 2 + Width = 12 + AutoSize = True + OnMouseDown = RenderImageMouseDown + OnMouseMove = RenderImageMouseMove + Stretch = True + end + end + object MainMenu1: TMainMenu + left = 16 + top = 32 + object FileMenu: TMenuItem + Caption = 'File' + object Settings1: TMenuItem + Caption = 'Open settings' + OnClick = Settings1Click + end + object Savesettings1: TMenuItem + Caption = 'Save settings...' + OnClick = Savesettings1Click + end + object Save1: TMenuItem + Caption = 'Save as bitmap...' + ShortCut = 16467 + OnClick = Save1Click + end + object RotationBMPMenu: TMenuItem + Caption = 'Save Rotation Bitmaps' + OnClick = RotationBMPMenuClick + end + object SaveClipMenu: TMenuItem + Caption = 'Save clip bitmaps' + OnClick = SaveClipMenuClick + end + object Close1: TMenuItem + Caption = 'Close window' + ShortCut = 16471 + OnClick = Close1Click + end + end + object Edit1: TMenuItem + Caption = 'Edit' + object Copy1: TMenuItem + Caption = 'Copy' + OnClick = Copy1Click + end + end + object Volume1: TMenuItem + Caption = 'Background' + object RenderBGSurfaceMenu: TMenuItem + Caption = 'Air/Skin Threshold' + object N1: TMenuItem + Caption = '0%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N101: TMenuItem + Tag = 25 + Caption = '10%' + Checked = True + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N401: TMenuItem + Tag = 51 + Caption = '20%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N601: TMenuItem + Tag = 76 + Caption = '30%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N801: TMenuItem + Tag = 101 + Caption = '40%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N403: TMenuItem + Tag = 128 + Caption = '50%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N404: TMenuItem + Tag = 152 + Caption = '60%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + object N405: TMenuItem + Tag = 178 + Caption = '70%' + GroupIndex = 119 + RadioItem = True + OnClick = N1Click + end + end + object RenderBGDepthMenu: TMenuItem + Caption = 'Search Depth' + object N1voxel1: TMenuItem + Tag = 1 + Caption = '1 voxel' + Checked = True + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N2voxels1: TMenuItem + Tag = 2 + Caption = '2 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N4voxels1: TMenuItem + Tag = 4 + Caption = '4 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N8voxels1: TMenuItem + Tag = 8 + Caption = '8 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N16voxels1: TMenuItem + Tag = 12 + Caption = '12 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object N16voxels: TMenuItem + Tag = 16 + Caption = '16 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object Infinite1: TMenuItem + Tag = 2147483647 + Caption = 'Infinite' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + object MIPItem: TMenuItem + Caption = 'MIP' + GroupIndex = 122 + RadioItem = True + OnClick = N1voxel1Click + end + end + end + object Overlay1: TMenuItem + Caption = 'Overlay' + object RenderOverlaySurfaceMenu: TMenuItem + Caption = 'Air/Skin Threshold' + object N01: TMenuItem + Caption = '0%' + Checked = True + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N102: TMenuItem + Tag = 25 + Caption = '10%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N201: TMenuItem + Tag = 51 + Caption = '20%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N301: TMenuItem + Tag = 76 + Caption = '30%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N402: TMenuItem + Tag = 101 + Caption = '40%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N501: TMenuItem + Tag = 128 + Caption = '50%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N602: TMenuItem + Tag = 152 + Caption = '60%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + object N701: TMenuItem + Tag = 178 + Caption = '70%' + GroupIndex = 120 + RadioItem = True + OnClick = N01Click + end + end + object RenderOverlayDepthMenu: TMenuItem + Caption = 'Search Depth' + object N1voxel2: TMenuItem + Tag = 1 + Caption = '1 voxel' + Checked = True + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N2voxels2: TMenuItem + Tag = 2 + Caption = '2 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N4voxels2: TMenuItem + Tag = 4 + Caption = '4 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N8voxels2: TMenuItem + Tag = 8 + Caption = '8 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N12voxels1: TMenuItem + Tag = 12 + Caption = '12 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object N16voxels2: TMenuItem + Tag = 16 + Caption = '16 voxels' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + object Infinite2: TMenuItem + Tag = 2147483647 + Caption = 'Infinite' + GroupIndex = 122 + RadioItem = True + OnClick = OverlayRenderDepthItem + end + end + object Search1: TMenuItem + Caption = 'Search' + object BehindBG1: TMenuItem + Caption = 'Any Depth' + GroupIndex = 17 + RadioItem = True + OnClick = SetSearch + end + object Infront1: TMenuItem + Tag = 1 + Caption = 'Below BG surface [max intensity]' + GroupIndex = 17 + RadioItem = True + OnClick = SetSearch + end + object Anydepth1: TMenuItem + Tag = 2 + Caption = 'Infront/below BG surface' + GroupIndex = 17 + RadioItem = True + OnClick = SetSearch + end + end + end + object Quality1: TMenuItem + Caption = 'View' + object CutoutMenu: TMenuItem + Caption = 'Cutout' + OnClick = Cutout1Click + end + object MenuItem1: TMenuItem + Caption = '-' + end + object RenderSmoothBG: TMenuItem + Caption = 'Smooth Background' + Checked = True + Hint = 'Blur rendering' + OnClick = RenderSmoothBGClick + end + object RenderSmoothOverlay: TMenuItem + Caption = 'Smooth Overlay' + Checked = True + Hint = 'Blur rendering' + OnClick = RenderSmoothBGClick + end + object RenderPreciseInterpolation: TMenuItem + Caption = 'Precise interpolation' + Hint = 'Use trilinear interpolation [slow]' + OnClick = RenderPreciseInterpolationClick + end + object N2: TMenuItem + Caption = '-' + end + object FlipLRcheck: TMenuItem + Caption = 'Flip L/R' + OnClick = RenderSmoothClick + end + end + end + object RenderRefreshTimer: TTimer + Enabled = False + Interval = 150 + OnTimer = RenderRefreshTimerTimer + left = 48 + top = 32 + end +end diff --git a/render.lrs b/render.lrs new file mode 100644 index 0000000..44df892 --- /dev/null +++ b/render.lrs @@ -0,0 +1,231 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TRenderForm','FORMDATA',[ + 'TPF0'#11'TRenderForm'#10'RenderForm'#4'Left'#3#205#1#6'Height'#3#0#2#3'Top'#3 + +#140#0#5'Width'#3#187#3#13'ActiveControl'#7#9'RenderBar'#7'Caption'#6#13'Vol' + +'ume Render'#12'ClientHeight'#3#0#2#11'ClientWidth'#3#187#3#4'Menu'#7#9'Main' + +'Menu1'#8'OnCreate'#7#10'FormCreate'#6'OnHide'#7#8'FormHide'#6'OnShow'#7#8'F' + +'ormShow'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#3'1.5'#0#6'TPane' + +'l'#9'RenderBar'#4'Left'#2#0#6'Height'#2' '#3'Top'#2#0#5'Width'#3#187#3#5'Al' + +'ign'#7#5'alTop'#10'BevelOuter'#7#6'bvNone'#12'ClientHeight'#2' '#11'ClientW' + +'idth'#3#187#3#8'TabOrder'#2#0#0#6'TLabel'#6'Label4'#4'Left'#3#152#0#6'Heigh' + +'t'#2#16#3'Top'#2#5#5'Width'#2'9'#7'Caption'#6#9'Elevation'#11'ParentColor'#8 + +#0#0#6'TLabel'#6'Label1'#4'Left'#2#4#6'Height'#2#16#3'Top'#2#5#5'Width'#2'5' + +#7'Caption'#6#7'Azimuth'#11'ParentColor'#8#0#0#12'TSpeedButton'#10'RefreshBt' + +'n'#4'Left'#3'('#1#6'Height'#2#31#4'Hint'#6'"Generate high-resolution render' + +'ing'#3'Top'#2#0#5'Width'#2'('#10'Glyph.Data'#10'z'#8#0#0'v'#8#0#0'BMv'#8#0#0 + +#0#0#0#0'6'#0#0#0'('#0#0#0#24#0#0#0#22#0#0#0#1#0' '#0#0#0#0#0'@'#8#0#0'd'#0#0 + +#0'd'#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0 + +#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0 + +#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255 + ,#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0 + +#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255 + +#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0 + +#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255 + +#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#0#0#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#0#0#255#255 + +#0#0#255#255#0#0#255#255#0#0#255#255#0#0#255#255#7'OnClick'#7#12'RefreshClic' + +'k'#8'ShowHint'#9#14'ParentShowHint'#8#0#0#6'TImage'#14'RenderImageBUP'#3'Ta' + +'g'#2#2#6'Cursor'#7#7'crCross'#4'Left'#3'h'#1#6'Height'#2#12#3'Top'#2#8#5'Wi' + +'dth'#2#12#8'AutoSize'#9#6'Center'#9#11'OnMouseDown'#7#20'RenderImageMouseDo' + +'wn'#11'OnMouseMove'#7#20'RenderImageMouseMove'#7'Stretch'#9#7'Visible'#8#0#0 + +#6'TLabel'#6'Label5'#4'Left'#3'h'#2#6'Height'#2#16#3'Top'#2#5#5'Width'#2'?'#7 + +'Caption'#6#9'Shading %'#11'ParentColor'#8#0#0#9'TSpinEdit'#11'AzimuthEdit'#4 + +'Left'#2'H'#6'Height'#2#16#3'Top'#2#2#5'Width'#2'F'#9'Increment'#2#30#8'MaxV' + +'alue'#3'h'#1#8'OnChange'#7#10'EditChange'#8'TabOrder'#2#0#5'Value'#2'x'#0#0 + +#9'TSpinEdit'#13'ElevationEdit'#4'Left'#3#216#0#6'Height'#2#16#3'Top'#2#2#5 + +'Width'#2'F'#9'Increment'#2#30#8'MaxValue'#3#180#0#8'MinValue'#3'L'#255#8'On' + +'Change'#7#10'EditChange'#8'TabOrder'#2#1#5'Value'#2#30#0#0#9'TTrackBar'#9'B' + +'iasTrack'#4'Left'#3'`'#1#6'Height'#2#29#3'Top'#2#2#5'Width'#2'x'#3'Max'#2'd' + +#8'OnChange'#7#15'BiasTrackChange'#8'Position'#2'2'#9'TickStyle'#7#6'tsNone' + +#8'TabOrder'#2#2#0#0#9'TTrackBar'#9'GainTrack'#4'Left'#3#224#1#6'Height'#2#29 + +#3'Top'#2#2#5'Width'#2'x'#3'Max'#2'd'#8'OnChange'#7#15'BiasTrackChange'#8'Po' + +'sition'#2'2'#9'TickStyle'#7#6'tsNone'#8'TabOrder'#2#3#0#0#9'TSpinEdit'#9'Sh' + ,'adeEdit'#4'Left'#3#178#2#6'Height'#2#16#3'Top'#2#2#5'Width'#2'F'#9'Incremen' + +'t'#2#10#8'OnChange'#7#10'EditChange'#8'TabOrder'#2#4#0#0#9'TTrackBar'#9'Cli' + +'pTrack'#4'Left'#3#8#3#6'Height'#2#29#3'Top'#2#2#5'Width'#2'x'#3'Max'#3#231#3 + +#8'OnChange'#7#15'ClipTrackChange'#8'Position'#2#0#9'TickStyle'#7#6'tsNone'#8 + +'TabOrder'#2#5#0#0#0#10'TScrollBox'#11'RenderPanel'#4'Left'#2#0#6'Height'#3 + +#224#1#3'Top'#2' '#5'Width'#3#187#3#18'HorzScrollBar.Page'#2#14#18'VertScrol' + +'lBar.Page'#2#14#5'Align'#7#8'alClient'#12'ClientHeight'#3#209#1#11'ClientWi' + +'dth'#3#172#3#8'TabOrder'#2#1#0#6'TImage'#11'RenderImage'#3'Tag'#2#2#6'Curso' + +'r'#7#7'crCross'#4'Left'#2#2#6'Height'#2#12#3'Top'#2#2#5'Width'#2#12#8'AutoS' + +'ize'#9#11'OnMouseDown'#7#20'RenderImageMouseDown'#11'OnMouseMove'#7#20'Rend' + +'erImageMouseMove'#7'Stretch'#9#0#0#0#9'TMainMenu'#9'MainMenu1'#4'left'#2#16 + +#3'top'#2' '#0#9'TMenuItem'#8'FileMenu'#7'Caption'#6#4'File'#0#9'TMenuItem'#9 + +'Settings1'#7'Caption'#6#13'Open settings'#7'OnClick'#7#14'Settings1Click'#0 + +#0#9'TMenuItem'#13'Savesettings1'#7'Caption'#6#16'Save settings...'#7'OnClic' + +'k'#7#18'Savesettings1Click'#0#0#9'TMenuItem'#5'Save1'#7'Caption'#6#17'Save ' + +'as bitmap...'#8'ShortCut'#3'S@'#7'OnClick'#7#10'Save1Click'#0#0#9'TMenuItem' + +#15'RotationBMPMenu'#7'Caption'#6#21'Save Rotation Bitmaps'#7'OnClick'#7#20 + +'RotationBMPMenuClick'#0#0#9'TMenuItem'#12'SaveClipMenu'#7'Caption'#6#17'Sav' + +'e clip bitmaps'#7'OnClick'#7#17'SaveClipMenuClick'#0#0#9'TMenuItem'#6'Close' + +'1'#7'Caption'#6#12'Close window'#8'ShortCut'#3'W@'#7'OnClick'#7#11'Close1Cl' + +'ick'#0#0#0#9'TMenuItem'#5'Edit1'#7'Caption'#6#4'Edit'#0#9'TMenuItem'#5'Copy' + +'1'#7'Caption'#6#4'Copy'#7'OnClick'#7#10'Copy1Click'#0#0#0#9'TMenuItem'#7'Vo' + +'lume1'#7'Caption'#6#10'Background'#0#9'TMenuItem'#19'RenderBGSurfaceMenu'#7 + +'Caption'#6#18'Air/Skin Threshold'#0#9'TMenuItem'#2'N1'#7'Caption'#6#2'0%'#10 + +'GroupIndex'#2'w'#9'RadioItem'#9#7'OnClick'#7#7'N1Click'#0#0#9'TMenuItem'#4 + +'N101'#3'Tag'#2#25#7'Caption'#6#3'10%'#7'Checked'#9#10'GroupIndex'#2'w'#9'Ra' + +'dioItem'#9#7'OnClick'#7#7'N1Click'#0#0#9'TMenuItem'#4'N401'#3'Tag'#2'3'#7'C' + +'aption'#6#3'20%'#10'GroupIndex'#2'w'#9'RadioItem'#9#7'OnClick'#7#7'N1Click' + +#0#0#9'TMenuItem'#4'N601'#3'Tag'#2'L'#7'Caption'#6#3'30%'#10'GroupIndex'#2'w' + +#9'RadioItem'#9#7'OnClick'#7#7'N1Click'#0#0#9'TMenuItem'#4'N801'#3'Tag'#2'e' + +#7'Caption'#6#3'40%'#10'GroupIndex'#2'w'#9'RadioItem'#9#7'OnClick'#7#7'N1Cli' + +'ck'#0#0#9'TMenuItem'#4'N403'#3'Tag'#3#128#0#7'Caption'#6#3'50%'#10'GroupInd' + +'ex'#2'w'#9'RadioItem'#9#7'OnClick'#7#7'N1Click'#0#0#9'TMenuItem'#4'N404'#3 + +'Tag'#3#152#0#7'Caption'#6#3'60%'#10'GroupIndex'#2'w'#9'RadioItem'#9#7'OnCli' + +'ck'#7#7'N1Click'#0#0#9'TMenuItem'#4'N405'#3'Tag'#3#178#0#7'Caption'#6#3'70%' + +#10'GroupIndex'#2'w'#9'RadioItem'#9#7'OnClick'#7#7'N1Click'#0#0#0#9'TMenuIte' + +'m'#17'RenderBGDepthMenu'#7'Caption'#6#12'Search Depth'#0#9'TMenuItem'#8'N1v' + +'oxel1'#3'Tag'#2#1#7'Caption'#6#7'1 voxel'#7'Checked'#9#10'GroupIndex'#2'z'#9 + +'RadioItem'#9#7'OnClick'#7#13'N1voxel1Click'#0#0#9'TMenuItem'#9'N2voxels1'#3 + +'Tag'#2#2#7'Caption'#6#8'2 voxels'#10'GroupIndex'#2'z'#9'RadioItem'#9#7'OnCl' + +'ick'#7#13'N1voxel1Click'#0#0#9'TMenuItem'#9'N4voxels1'#3'Tag'#2#4#7'Caption' + +#6#8'4 voxels'#10'GroupIndex'#2'z'#9'RadioItem'#9#7'OnClick'#7#13'N1voxel1Cl' + +'ick'#0#0#9'TMenuItem'#9'N8voxels1'#3'Tag'#2#8#7'Caption'#6#8'8 voxels'#10'G' + +'roupIndex'#2'z'#9'RadioItem'#9#7'OnClick'#7#13'N1voxel1Click'#0#0#9'TMenuIt' + +'em'#10'N16voxels1'#3'Tag'#2#12#7'Caption'#6#9'12 voxels'#10'GroupIndex'#2'z' + +#9'RadioItem'#9#7'OnClick'#7#13'N1voxel1Click'#0#0#9'TMenuItem'#9'N16voxels' + +#3'Tag'#2#16#7'Caption'#6#9'16 voxels'#10'GroupIndex'#2'z'#9'RadioItem'#9#7 + +'OnClick'#7#13'N1voxel1Click'#0#0#9'TMenuItem'#9'Infinite1'#3'Tag'#4#255#255 + +#255#127#7'Caption'#6#8'Infinite'#10'GroupIndex'#2'z'#9'RadioItem'#9#7'OnCli' + +'ck'#7#13'N1voxel1Click'#0#0#9'TMenuItem'#7'MIPItem'#7'Caption'#6#3'MIP'#10 + +'GroupIndex'#2'z'#9'RadioItem'#9#7'OnClick'#7#13'N1voxel1Click'#0#0#0#0#9'TM' + +'enuItem'#8'Overlay1'#7'Caption'#6#7'Overlay'#0#9'TMenuItem'#24'RenderOverla' + +'ySurfaceMenu'#7'Caption'#6#18'Air/Skin Threshold'#0#9'TMenuItem'#3'N01'#7'C' + +'aption'#6#2'0%'#7'Checked'#9#10'GroupIndex'#2'x'#9'RadioItem'#9#7'OnClick'#7 + +#8'N01Click'#0#0#9'TMenuItem'#4'N102'#3'Tag'#2#25#7'Caption'#6#3'10%'#10'Gro' + +'upIndex'#2'x'#9'RadioItem'#9#7'OnClick'#7#8'N01Click'#0#0#9'TMenuItem'#4'N2' + +'01'#3'Tag'#2'3'#7'Caption'#6#3'20%'#10'GroupIndex'#2'x'#9'RadioItem'#9#7'On' + +'Click'#7#8'N01Click'#0#0#9'TMenuItem'#4'N301'#3'Tag'#2'L'#7'Caption'#6#3'30' + +'%'#10'GroupIndex'#2'x'#9'RadioItem'#9#7'OnClick'#7#8'N01Click'#0#0#9'TMenuI' + +'tem'#4'N402'#3'Tag'#2'e'#7'Caption'#6#3'40%'#10'GroupIndex'#2'x'#9'RadioIte' + +'m'#9#7'OnClick'#7#8'N01Click'#0#0#9'TMenuItem'#4'N501'#3'Tag'#3#128#0#7'Cap' + +'tion'#6#3'50%'#10'GroupIndex'#2'x'#9'RadioItem'#9#7'OnClick'#7#8'N01Click'#0 + +#0#9'TMenuItem'#4'N602'#3'Tag'#3#152#0#7'Caption'#6#3'60%'#10'GroupIndex'#2 + +'x'#9'RadioItem'#9#7'OnClick'#7#8'N01Click'#0#0#9'TMenuItem'#4'N701'#3'Tag'#3 + ,#178#0#7'Caption'#6#3'70%'#10'GroupIndex'#2'x'#9'RadioItem'#9#7'OnClick'#7#8 + +'N01Click'#0#0#0#9'TMenuItem'#22'RenderOverlayDepthMenu'#7'Caption'#6#12'Sea' + +'rch Depth'#0#9'TMenuItem'#8'N1voxel2'#3'Tag'#2#1#7'Caption'#6#7'1 voxel'#7 + +'Checked'#9#10'GroupIndex'#2'z'#9'RadioItem'#9#7'OnClick'#7#22'OverlayRender' + +'DepthItem'#0#0#9'TMenuItem'#9'N2voxels2'#3'Tag'#2#2#7'Caption'#6#8'2 voxels' + +#10'GroupIndex'#2'z'#9'RadioItem'#9#7'OnClick'#7#22'OverlayRenderDepthItem'#0 + +#0#9'TMenuItem'#9'N4voxels2'#3'Tag'#2#4#7'Caption'#6#8'4 voxels'#10'GroupInd' + +'ex'#2'z'#9'RadioItem'#9#7'OnClick'#7#22'OverlayRenderDepthItem'#0#0#9'TMenu' + +'Item'#9'N8voxels2'#3'Tag'#2#8#7'Caption'#6#8'8 voxels'#10'GroupIndex'#2'z'#9 + +'RadioItem'#9#7'OnClick'#7#22'OverlayRenderDepthItem'#0#0#9'TMenuItem'#10'N1' + +'2voxels1'#3'Tag'#2#12#7'Caption'#6#9'12 voxels'#10'GroupIndex'#2'z'#9'Radio' + +'Item'#9#7'OnClick'#7#22'OverlayRenderDepthItem'#0#0#9'TMenuItem'#10'N16voxe' + +'ls2'#3'Tag'#2#16#7'Caption'#6#9'16 voxels'#10'GroupIndex'#2'z'#9'RadioItem' + +#9#7'OnClick'#7#22'OverlayRenderDepthItem'#0#0#9'TMenuItem'#9'Infinite2'#3'T' + +'ag'#4#255#255#255#127#7'Caption'#6#8'Infinite'#10'GroupIndex'#2'z'#9'RadioI' + +'tem'#9#7'OnClick'#7#22'OverlayRenderDepthItem'#0#0#0#9'TMenuItem'#7'Search1' + +#7'Caption'#6#6'Search'#0#9'TMenuItem'#9'BehindBG1'#7'Caption'#6#9'Any Depth' + +#10'GroupIndex'#2#17#9'RadioItem'#9#7'OnClick'#7#9'SetSearch'#0#0#9'TMenuIte' + +'m'#8'Infront1'#3'Tag'#2#1#7'Caption'#6' Below BG surface [max intensity]'#10 + +'GroupIndex'#2#17#9'RadioItem'#9#7'OnClick'#7#9'SetSearch'#0#0#9'TMenuItem'#9 + +'Anydepth1'#3'Tag'#2#2#7'Caption'#6#24'Infront/below BG surface'#10'GroupInd' + +'ex'#2#17#9'RadioItem'#9#7'OnClick'#7#9'SetSearch'#0#0#0#0#9'TMenuItem'#8'Qu' + +'ality1'#7'Caption'#6#4'View'#0#9'TMenuItem'#10'CutoutMenu'#7'Caption'#6#6'C' + +'utout'#7'OnClick'#7#12'Cutout1Click'#0#0#9'TMenuItem'#9'MenuItem1'#7'Captio' + +'n'#6#1'-'#0#0#9'TMenuItem'#14'RenderSmoothBG'#7'Caption'#6#17'Smooth Backgr' + +'ound'#7'Checked'#9#4'Hint'#6#14'Blur rendering'#7'OnClick'#7#19'RenderSmoot' + +'hBGClick'#0#0#9'TMenuItem'#19'RenderSmoothOverlay'#7'Caption'#6#14'Smooth O' + +'verlay'#7'Checked'#9#4'Hint'#6#14'Blur rendering'#7'OnClick'#7#19'RenderSmo' + +'othBGClick'#0#0#9'TMenuItem'#26'RenderPreciseInterpolation'#7'Caption'#6#21 + +'Precise interpolation'#4'Hint'#6'"Use trilinear interpolation [slow]'#7'OnC' + +'lick'#7#31'RenderPreciseInterpolationClick'#0#0#9'TMenuItem'#2'N2'#7'Captio' + +'n'#6#1'-'#0#0#9'TMenuItem'#11'FlipLRcheck'#7'Caption'#6#8'Flip L/R'#7'OnCli' + +'ck'#7#17'RenderSmoothClick'#0#0#0#0#6'TTimer'#18'RenderRefreshTimer'#7'Enab' + +'led'#8#8'Interval'#3#150#0#7'OnTimer'#7#23'RenderRefreshTimerTimer'#4'left' + +#2'0'#3'top'#2' '#0#0#0 +]); diff --git a/render.pas b/render.pas new file mode 100755 index 0000000..636a970 --- /dev/null +++ b/render.pas @@ -0,0 +1,825 @@ +unit render; +interface +{$include isthreaded.inc} +{$mode delphi} +uses +{$IFDEF Unix} +lclintf, //gettickcount +{$ELSE} +Windows, +{$ENDIF} +{$IFNDEF NoThreads} + RenderThds, +{$ELSE} +rendernothreads, +{$ENDIF} + LResources,SysUtils, GraphicsMathLibrary,Classes, Graphics, Controls, Forms, Dialogs,ExtCtrls,Buttons, + nifti_img, nifti_hdr,define_types,nifti_img_view,StdCtrls, Spin, Menus,ClipBrd,ReadInt,IniFiles, + ComCtrls,userdir,render_composite; +type + { TRenderForm } + TRenderForm = class(TForm) + CutoutMenu: TMenuItem; + ClipTrack: TTrackBar; + MenuItem1: TMenuItem; + SaveClipMenu: TMenuItem; + MIPItem: TMenuItem; + ShadeEdit: TSpinEdit; + Label5: TLabel; + RotationBMPMenu: TMenuItem; + RenderBar: TPanel; + AzimuthEdit: TSpinEdit; + ElevationEdit: TSpinEdit; + MainMenu1: TMainMenu; + FileMenu: TMenuItem; + Close1: TMenuItem; + Edit1: TMenuItem; + Copy1: TMenuItem; + Save1: TMenuItem; + Label4: TLabel; + RefreshBtn: TSpeedButton; + BiasTrack: TTrackBar; + GainTrack: TTrackBar; + Volume1: TMenuItem; + RenderBGSurfaceMenu: TMenuItem; + N1: TMenuItem; + N101: TMenuItem; + N401: TMenuItem; + N601: TMenuItem; + N801: TMenuItem; + N403: TMenuItem; + N404: TMenuItem; + N405: TMenuItem; + RenderBGDepthMenu: TMenuItem; + N1voxel1: TMenuItem; + N2voxels1: TMenuItem; + N4voxels1: TMenuItem; + N8voxels1: TMenuItem; + N16voxels1: TMenuItem; + N16voxels: TMenuItem; + RenderSmoothBG: TMenuItem; + RenderPreciseInterpolation: TMenuItem; + Label1: TLabel; + Overlay1: TMenuItem; + RenderOverlaySurfaceMenu: TMenuItem; + N701: TMenuItem; + N602: TMenuItem; + N501: TMenuItem; + N402: TMenuItem; + N301: TMenuItem; + N201: TMenuItem; + N102: TMenuItem; + N01: TMenuItem; + RenderOverlayDepthMenu: TMenuItem; + N16voxels2: TMenuItem; + N12voxels1: TMenuItem; + N8voxels2: TMenuItem; + N4voxels2: TMenuItem; + N2voxels2: TMenuItem; + N1voxel2: TMenuItem; + Quality1: TMenuItem; + RenderRefreshTimer: TTimer; + + RenderPanel: TScrollBox; + RenderImage: TImage; + RenderImageBUP: TImage; + //RenderImage2: TImage; + + RenderSmoothOverlay: TMenuItem; + FlipLRcheck: TMenuItem; + Settings1: TMenuItem; + Savesettings1: TMenuItem; + N2: TMenuItem; + Infinite1: TMenuItem; + Infinite2: TMenuItem; + Search1: TMenuItem; + BehindBG1: TMenuItem; + Infront1: TMenuItem; + Anydepth1: TMenuItem; + procedure BiasTrackChange(Sender: TObject); + procedure ClipTrackChange(Sender: TObject); + procedure RenderSmoothBGClick(Sender: TObject); + procedure RotationBMPMenuClick(Sender: TObject); + procedure SaveClipMenuClick(Sender: TObject); + procedure Settings1Click(Sender: TObject); + procedure SetSearch(Sender: TObject); + procedure Save1Click(Sender: TObject); + procedure RenderImageMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure Copy1Click(Sender: TObject); + procedure Close1Click(Sender: TObject); + procedure N1Click(Sender: TObject); + procedure N01Click(Sender: TObject); + procedure N1voxel1Click(Sender: TObject); + procedure N16voxels2Click(Sender: TObject); + procedure RenderSmoothClick(Sender: TObject); + procedure RenderPreciseInterpolationClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure RenderRefreshTimerTimer(Sender: TObject); + procedure EditChange(Sender: TObject); + procedure OverlayRenderDepthItem(Sender: TObject); + procedure RenderImageMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure Cutout1Click(Sender: TObject); + procedure Savesettings1Click(Sender: TObject); + procedure UpdateRenderMRU; + procedure OpenRenderMRU(Sender:TObject); + procedure UpdateRenderDisplay; + procedure FormHide(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure RefreshClick(Sender: TObject); + procedure RefreshRotation; + private + { Private declarations } + public + { Public declarations } + end; + +var + RenderForm: TRenderForm; + gZoom : single = 1; + gRenderDir,gRenderStartupFilename,gRenderDefaultsFilename:string; +implementation + +uses MultiSlice,math,cutout; + +{$IFDEF FPC} +{$R *.lfm} +{$ELSE} +{$R *.DFM} + {$ENDIF} +procedure MinMaxFilt (var lHdr: TMRIcroHdr; var lFiltMin8bit, lFiltMax8bit: integer);var lMin,lMax: single; +begin +ReturnMinMax (lHdr,lMin,lMax, lFiltMin8bit, lFiltMax8bit); +end; + +procedure TRenderForm.UpdateRenderDisplay; +begin + SetSubmenuWithTag(RenderBGSurfaceMenu,gRender.BGSurface); + SetSubmenuWithTag(RenderOverlaySurfaceMenu,gRender.OverlaySurface); + SetSubmenuWithTag(RenderBGDepthMenu,gRender.BGDepth); + SetSubmenuWithTag(RenderOverlayDepthMenu,gRender.OverlayDepth); + RenderSmoothBG.checked := gRender.SmoothBG; + RenderSmoothOverlay.checked := gRender.SmoothOverlay; + RenderPreciseInterpolation.Checked := gRender.Trilinear; + //RenderSurfaceOverlay.Checked := gRender.OverlayFromBGSurface; + SetSubmenuWithTag(Search1,gRender.OverlayFromBGSurface); + FlipLRCheck.Checked := gRender.FlipLR; + AzimuthEdit.value := gRender.Azimuth; + ElevationEdit.value := gRender.Elevation; + ShadeEdit.value := gRender.ShadePct; + RenderRefreshTimer.tag := -1; + RenderRefreshTimer.enabled := true; +end; + +procedure WriteRenderIniFile (lFilename: string); +var + lIniFile: TIniFile; + lInc: integer; +begin + if DiskFreeEx(lFilename) < 1 then + exit; + if not DirectoryExists(extractfiledir(lFilename)) then begin + mkDir(extractfiledir(lFilename)); + end; + lIniFile := TIniFile.Create(lFilename); + with gRender do begin + lIniFile.WriteString('BOOL', 'SmoothBG',Bool2Char( SmoothBG)); + lIniFile.WriteString('BOOL', 'SmoothOverlay',Bool2Char( SmoothOverlay)); + lIniFile.WriteString('BOOL', 'Trilinear',Bool2Char( Trilinear)); + lIniFile.WriteString('BOOL', 'ShowCutout',Bool2Char( ShowCutout)); + lIniFile.WriteString('BOOL', 'FlipLR',Bool2Char( FlipLR)); + lIniFile.WriteString('INT', 'OverlayFromBGSurface',IntToStr( OverlayFromBGSurface)); + //lIniFile.WriteString('INT', 'BGNearClip',IntToStr(BGNearClip)); + //lIniFile.WriteString('INT', 'OverlayNearClip',IntToStr(OverlayNearClip)); + lIniFile.WriteString('INT', 'Azimuth',IntToStr(Azimuth)); + lIniFile.WriteString('INT', 'Elevation',IntToStr(Elevation)); + lIniFile.WriteString('INT', 'BGSurface',IntToStr(BGSurface)); + lIniFile.WriteString('INT', 'OverlaySurface',IntToStr(OverlaySurface)); + lIniFile.WriteString('INT', 'BGDepth',IntToStr(BGDepth)); + lIniFile.WriteString('INT', 'OverlayDepth',IntToStr(OverlayDepth)); + lIniFile.WriteString('INT', 'CutoutBias',IntToStr(CutoutBias)); + lIniFile.WriteString('INT', 'cutoutLUTindex',IntToStr(cutoutLUTindex)); + lIniFile.WriteString('INT', 'ShadePct',IntToStr(ShadePct)); + for lInc := 1 to 3 do begin + lIniFile.WriteString('INT', 'CutoutLoFrac'+inttostr(lInc),IntToStr(CutoutFrac.Lo[lInc])); + lIniFile.WriteString('INT', 'CutoutHiFrac'+inttostr(lInc),IntToStr(CutoutFrac.Hi[lInc])); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure ReadRenderIniFile (lFilename: string); +var + lIniFile: TIniFile; + //lStr: string; + lInc: integer; +begin + if not FileexistsEx(lFilename) then begin + exit; + end; + lIniFile := TIniFile.Create(lFilename); + //lStr := lIniFile.ReadString('STR', 'Slices', '10,20,30');//file0 - last file viewed + with gRender do begin + //Booleans + //SmoothBG,SmoothOverlay,Trilinear,OverlayFromBGSurface,ShowCutout + SmoothBG := IniBool(lIniFile,'SmoothBG',SmoothBG); + SmoothOverlay := IniBool(lIniFile,'SmoothOverlay',SmoothOverlay); + Trilinear := IniBool(lIniFile,'Trilinear',Trilinear); + //OverlayFromBGSurface := IniBool(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + ShowCutout := IniBool(lIniFile,'ShowCutout',ShowCutout); + FlipLR := IniBool(lIniFile,'FlipLR',FlipLR); + OverlayFromBGSurface:= IniInt(lIniFile,'OverlayFromBGSurface',OverlayFromBGSurface); + //BGNearClip:= IniInt(lIniFile,'BGNearClip',BGNearClip); + //OverlayNearClip:= IniInt(lIniFile,'OverlayNearClip',OverlayNearClip); + Azimuth:= IniInt(lIniFile,'Azimuth',Azimuth); + Elevation:= IniInt(lIniFile,'Elevation',Elevation); + BGSurface:= IniInt(lIniFile,'BGSurface',BGSurface); + OverlaySurface:= IniInt(lIniFile,'OverlaySurface',OverlaySurface); + BGDepth:= IniInt(lIniFile,'BGDepth',BGDepth); + OverlayDepth:= IniInt(lIniFile,'OverlayDepth',OverlayDepth); + CutoutBias:= IniInt(lIniFile,'CutoutBias', CutoutBias); + ShadePct:= IniInt(lIniFile,'ShadePct', 0); + cutoutLUTindex:= IniInt(lIniFile,'cutoutLUTindex',cutoutLUTindex); + + for lInc := 1 to 3 do begin + Cutout.Lo[lInc] := IniInt(lIniFile,'CutoutLo'+inttostr(lInc),Cutout.Lo[lInc]); + Cutout.Hi[lInc] := IniInt(lIniFile,'CutoutHi'+inttostr(lInc),Cutout.Hi[lInc]); + end; + for lInc := 1 to 3 do begin + CutoutFrac.Lo[lInc] := IniInt(lIniFile,'CutoutLoFrac'+inttostr(lInc),-1); + CutoutFrac.Hi[lInc] := IniInt(lIniFile,'CutoutHiFrac'+inttostr(lInc),-1); + end; + end;//with gRender + lIniFile.Free; +end; + +procedure TRenderForm.OpenRenderMRU(Sender:TObject); +var + lFilename: string; +begin + lFilename := gRenderDir+(Sender as TMenuItem).caption+'.ini' ; + ReadRenderIniFile(lFilename); + //07 CutoutForm.Prep; + UpdateRenderDisplay; +end; + +procedure TRenderForm.UpdateRenderMRU; +var + NewItem: TMenuItem; + lSearchRec: TSearchRec; +begin + While Settings1.Count > 0 do Settings1.Items[0].Free; + if FindFirst(gRenderDir+'*.ini', faAnyFile, lSearchRec) = 0 then + repeat + NewItem := TMenuItem.Create(Self); + NewItem.Caption := ParseFileName(ExtractFileName(lSearchRec.Name)); + {$IFDEF FPC} + NewItem.onclick := OpenRenderMRU; //Lazarus + {$ELSE} + NewItem.onclick := OpenRenderMRU; + {$ENDIF} + Settings1.Add(NewItem); + until (FindNext(lSearchRec) <> 0); + FindClose(lSearchRec); +end; + +Function AziElevMatrix: TMatrix; +var + lLRFlipMatrix: TMatrix; +begin + gRender.Azimuth := RenderForm.AzimuthEdit.value; + gRender.Elevation := RenderForm.ElevationEdit.value; + result := ViewTransformMatrix( + coordSpherical, + ToRadians(RenderForm.AzimuthEdit.Value), + ToRadians(RenderForm.ElevationEdit.Value), + 3{Distance.Value},6{ScreenWidthHeight.Value},6{ScreenWidthHeight.Value},{ScreenToCamera.Value}3); + {The ViewTransformMatrix is all that is needed for other objects defined + in world coordinates.} + if {RenderForm.FlipLRcheck.checked} gRender.FlipLR then begin + lLRFlipMatrix := Matrix3D (-1,0,0,0, // 3D "graphics" matrix + 0,1,0,0, + 0,0,1,0, + 0,0,0,0); + result := MultiplyMatrices(lLRFlipMatrix,Result); + end; + +end; + + +procedure InvertMatrixPoint (var lBackgroundImg: TBGImg; var lInMatrix: TMatrix; var lXin,lYin,lZIn, lXout,lYout,lZout: integer); +//convert mouse click to position +var + lZ,lY,lX,lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn: integer; + lMatrix: TMatrix; +begin + //lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutDim := round(gBGImg.RenderDim/gRender.Zoom) + else + lOutDim :=gBGImg.RenderDim; //11/2007b + lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (lBackgroundImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (lBackgroundImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (lBackgroundImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lX := (lXin-lOutPivot); + lY := ({lYin-}lOutPivot-lYin); + lZ := (lZin-lOutPivot); + lMatrix := InvertMatrix3D(lInMatrix); + lXout := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYout := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZout := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXOut := (lXOut+lXPivotIn); + lYOut := (lYOut+lYPivotIn); + lZOut := (lZOut+lZPivotIn); +end; + +procedure TRenderForm.Save1Click(Sender: TObject); +//this code is required for OSX Lazarus, not sure about Windows/Delphi +var +lOutImg: TImage; +begin + lOutImg := TImage.Create(ImgForm); + lOutImg.Width := RenderImage.Width; + lOutImg.Height := RenderImage.Height; + lOutImg.Canvas.Draw(0,0,RenderImage.Picture.Graphic); + SaveImgAsPNGBMP (lOutImg); + FreeAndNil (lOutImg); +end; + +(*procedure TRenderForm.Save1Click(Sender: TObject); +begin + //if (RenderImage.Picture.Graphic = nil) then begin + SaveImgAsPNGBMP (RenderImage); + ///xxxx +end;*) + +procedure TRenderForm.RenderImageMouseMove(Sender: TObject; + Shift: TShiftState; X, Y: Integer); +begin +end; + +procedure TRenderForm.Copy1Click(Sender: TObject); +{$IFDEF FPC} +var +lOutImg: TImage; +begin + lOutImg := TImage.Create(ImgForm); + lOutImg.Width := RenderImage.Width; + lOutImg.Height := RenderImage.Height; + lOutImg.Canvas.Draw(0,0,RenderImage.Picture.Graphic); + lOutImg.Picture.Bitmap.SaveToClipboardFormat(2); + Clipboard.Assign(lOutImg.Picture.Graphic); + FreeAndNil (lOutImg); +end; + +(*begin + {$IFDEF zxDarwin} + Showmessage('Copy not yet supported with OSX: use File/Save'); + exit; + {$ENDIF} + if (RenderImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + RenderImage.Picture.Bitmap.SaveToClipboardFormat(2); +end;*) +{$ELSE} +var + MyFormat : Word; + AData: THandle; + APalette : HPalette; //For later versions of Delphi: APalette : THandle; +begin + if (RenderImage.Picture.Graphic = nil) then begin //1420z + Showmessage('You need to load an image before you can copy it to the clipboard.'); + exit; + end; + RenderImage.Picture.Bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette); + ClipBoard.SetAsHandle(MyFormat,AData); +end; +{$ENDIF} + + +procedure TRenderForm.RotationBMPMenuClick(Sender: TObject); +var + lnViews,lC,lAngle,lStartA: integer; + lZoom,lAzi: boolean; + lBaseFilename,lFilename: string; +begin + lnViews:= ReadIntForm.GetInt('How many bitmaps for a 360-degree rotation?', 4,24,72); + {$IFDEF ENDIAN_BIG} + ImgForm.SaveDialog1.Filter := 'Bitmap|*.xpm'; + ImgForm.SaveDialog1.DefaultExt := '.xpm'; + {$ELSE} + ImgForm.SaveDialog1.Filter := 'Bitmap|*.bmp'; + ImgForm.SaveDialog1.DefaultExt := '.bmp'; + {$ENDIF} + if not ImgForm.SaveDialog1.Execute then exit; + lBaseFilename := ImgForm.SaveDialog1.Filename; + lAzi := false; + case MessageDlg('Rotate azimuth?', mtConfirmation, + [mbYes, mbNo], 0) of + mrYes: lAzi := true; + end; //case + case MessageDlg('Generate super-sampled (high quality) renderings?', mtConfirmation, + [mbYes, mbNo], 0) of + mrYes: lZoom := true; + end; //case + + if lAzi then + lStartA := AzimuthEdit.value + else + lStartA := ElevationEdit.value; + for lC := 1 to lnViews do begin + lAngle := round((lC-1) * (360/lnviews)); + if lAzi then + AzimuthEdit.value := lAngle + else + ElevationEdit.value := lAngle - 180; + RenderRefreshTimer.enabled := false; + if lZoom then + gZoom := 2; + RefreshRotation; + DrawRender; + {$IFDEF ENDIAN_BIG} + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lAngle,3),'.xpm'); + {$ELSE} + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lAngle,3),'.bmp'); + {$ENDIF} + RenderImage.Picture.Bitmap.SaveToFile(lFilename); + //SaveImgAsPNGBMPCore(RenderImage,lFilename); + end; //for each of 36 views + if lAzi then + AzimuthEdit.value := lStartA + else + ElevationEdit.value := lStartA; + RenderRefreshTimer.enabled := false; + RefreshRotation; + DrawRender; +end; + +procedure TRenderForm.SaveClipMenuClick(Sender: TObject); +var + lStartClip,lnClips,lC: integer; + lBaseFilename,lFilename: string; + lStartTime: DWord; +begin + lStartClip := gRender.ClipFrac; + lnClips:= ReadIntForm.GetInt('How many bitmaps for a 360-degree rotation?', 4,24,200); + ImgForm.SaveDialog1.Filter := 'PNG bitmap|*.png'; + ImgForm.SaveDialog1.DefaultExt := '*.png'; + if not ImgForm.SaveDialog1.Execute then exit; + lBaseFilename := ImgForm.SaveDialog1.Filename; + lStartTime := GetTickCount; + for lC := 1 to lnClips do begin + gRender.ClipFrac := round( ((lC-1)/lnClips)*kMaxFrac ); + DrawRender; + refresh; + {$IFDEF ENDIAN_BIG} + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lC,3),'.xpm'); + {$ELSE} + lFilename := ChangeFilePostfixExt (lBaseFilename,PadStr(lC,3),'.bmp'); + {$ENDIF} + RenderImage.Picture.Bitmap.SaveToFile(lFilename); + + //SaveImgAsPNGBMPCore(RenderImage,lFilename); + end; //for each of 36 views + ImgForm.StatusLabel.caption :=('batchtime(ms): '+inttostr(GetTickCount-lStartTime)); + gRender.ClipFrac := lStartClip; +end; + + +procedure TRenderForm.Settings1Click(Sender: TObject); +begin + +end; + +procedure TRenderForm.BiasTrackChange(Sender: TObject); +begin + gRender.Bias := BiasTrack.position; + gRender.Gain := GainTrack.Position; + + RenderRefreshTimer.Enabled := true; + //RenderForm.caption := inttostr(BiasTrack.position)+'zzz'+inttostr(GainTrack.Position); +end; + +procedure TRenderForm.ClipTrackChange(Sender: TObject); +begin + gRender.ClipFrac := ClipTrack.Position; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderSmoothBGClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + + gRender.SmoothBG := RenderSmoothBG.checked; + gRender.SmoothOverlay := RenderSmoothOverlay.checked; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.Close1Click(Sender: TObject); +begin + RenderForm.Close; +end; + +procedure TRenderForm.N1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N01Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlaySurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N1voxel1Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.BGDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.N16voxels2Click(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderSmoothClick(Sender: TObject); +begin + (sender as TMenuItem).checked := not (sender as TMenuItem).checked; + gRender.FlipLR := FlipLRCheck.Checked; + //RenderSmoothSurface.checked := not RenderSmoothSurface.Checked; + gRender.SmoothBG := RenderSmoothBG.checked; + gRender.SmoothOverlay := RenderSmoothOverlay.checked; + RenderRefreshTimer.Tag := -1;//force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.RenderPreciseInterpolationClick(Sender: TObject); +begin + RenderPreciseInterpolation.Checked := not RenderPreciseInterpolation.Checked; + gRender.Trilinear := RenderPreciseInterpolation.Checked; + RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.FormShow(Sender: TObject); +var + lInc: integer; +begin + gRender.ClipFrac := 0; + gRender.Bias := 50; + gRender.Gain := 50; + gRender.cutoutLUTindex := 0; + gRender.BGSurface := 51; + gRender.OverlaySurface := 1; + gRender.BGDepth := 12; + gRender.OverlayDepth := 8; + gRender.Azimuth := 90; + gRender.Elevation := 45; + gRender.ShadePct := 0; + //gRender.OverlayNearClip := 0; + //gRender.BGNearClip := 0; + gRender.SmoothBG := true; + gRender.SmoothOverlay := false; + gRender.Trilinear := true; + gRender.FlipLR := false; + gRender.OverlayFromBGSurface := kBelow; + gRender.ShowCutout := false; + gRender.CutoutBias := 4; + {for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := gBGImg.ScrnDim[lInc] div 2; + gRender.Cutout.Hi[lInc] := gBGImg.ScrnDim[lInc]; + end;} + for lInc := 1 to 3 do begin + gRender.CutoutFrac.Lo[lInc] := kMaxFrac div 2; + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end; + ReadRenderIniFile (gRenderStartupFilename); + UpdateRenderMRU; + UpdateRenderDisplay; + RenderForm.BringToFront; +end; + + +function RAMok (var lBGImg: TBGImg): boolean; +var + lOutDim,lOutBytes,lBytesNeeded,lFreeRam: int64; + lBGSz,lC: integer; +begin + lBGSz := lBGImg.ScrnDim[1]*lBGImg.ScrnDim[2]*lBGImg.ScrnDim[3]; + lOutDim := round(MaxDim(lBGImg.ScrnDim[1],lBGImg.ScrnDim[2],lBGImg.ScrnDim[3]) * gRender.Zoom); + lOutBytes := lOutDim*lOutDim*lOutDim; + lBytesNeeded := 0; + for lC := 0 to knMaxOverlay do begin + if (gMRIcroOverlay[lC].ScrnBufferItems >= lBGSz) then begin + + lBytesNeeded := lBytesNeeded + (lOutBytes - gMRIcroOverlay[lC].RenderBufferItems); + end; + + end; + if (lBytesNeeded > freeRam) then begin + beep; + ImgForm.StatusLabel.Caption := 'Memory exhausted: unable to render at this quality'; + result := false; + + end else + result := true; +end; + +procedure TRenderForm.RefreshRotation; +var + lC: integer; + lMatrix: TMatrix; + lStartTime: DWord; +begin + lMatrix := AziElevMatrix; + {$IFNDEF FPC} //refresh causes flicker with lazarus + Application.processmessages; + Refresh; + {$ENDIF} + gRender.Zoom := gZoom; //11/2007b + gZoom := 1; + gRender.ClipFrac := ClipTrack.position; + gRender.Bias := BiasTrack.position; + gRender.Gain := GainTrack.Position; + gRender.Azimuth := round(AzimuthEdit.value); + gRender.Elevation := round(ElevationEdit.value); + + if not RAMok(gBGImg) then exit; + lStartTime := GetTickCount; + VolumeRotateMatrix (gBGImg, gMRIcroOverlay[0],lMatrix, gRender.Trilinear,gRender.ShowCutout,true{,round(gRender.BGNearClip*gRender.Zoom)}); + for lC := 1 to knMaxOverlay do + VolumeRotateMatrix (gBGImg, gMRIcroOverlay[lC],lMatrix, gRender.Trilinear,false,false{,round(gRender.OverlayNearClip*gRender.Zoom)}); +end; +var + gRendering: boolean = false; + +procedure TRenderForm.RenderRefreshTimerTimer(Sender: TObject); +begin + if gMRIcroOverlay[0].ScrnBufferItems=0 then begin + RenderRefreshTimer.Enabled := false; + RenderImage.Width := 0; + exit; + end; + if gRendering then exit; + RenderRefreshTimer.Enabled := false; + + gRender.ShadePct := ShadeEdit.value; + gRendering := true; + + if (gMRIcroOverlay[0].RenderBufferItems=0) or (RenderRefreshTimer.Tag <> 0) or (AzimuthEdit.value<>gRender.Azimuth) or (ElevationEdit.value<>gRender.Elevation) then + RefreshRotation; + //RenderRefreshTimer.Enabled := false; + (*if RenderRefreshTimer.Enabled then begin + gRendering := false; + exit; + end; *) + RenderRefreshTimer.Tag := 0; + + DrawRender; + //RenderRefreshTimer.Enabled := false; + gRendering := false; +end; + +procedure TRenderForm.EditChange(Sender: TObject); +begin + RenderRefreshTimer.Enabled := true; +end; + +procedure TRenderForm.OverlayRenderDepthItem(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayDepth := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + +procedure RenderDrawXBar ( lHorPos, lVerPos: integer;var lImage: TImage); +var lL,lT,lW,lH,lZoomPct: integer; +begin + lImage.Picture.Graphic := RenderForm.RenderImageBUP.Picture.Graphic; + {$IFNDEF Darwin} + //make sure next line required on this OS! + {$ENDIF} + lImage.Canvas.Draw(0,0,RenderForm.RenderImageBUP.Picture.Graphic); + //lImage.Picture.Bitmap := RenderForm.RenderImageBUP.Picture.Bitmap; //xxxx + //redraw image even if not drawing X-bar: hide visible X-bar if use toggles X-bars off. + if not ImgForm.XBarBtn.Down then + exit; //only draw xbars if requested + //lImage.Refresh; + lZoomPct := 100; //ImageZoomPct(lImage); + lL := (lHorPos * lZoomPct) div 100; + lT := (lVerPos * lZoomPct) div 100; + lW := lImage.Width;// div 100; + lH := lImage.Height;// div 100; + lImage.Canvas.Pen.Color:= gBGImg.XBarClr; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + //next horizontal lines + lImage.Canvas.MoveTo(0,lT); + lImage.Canvas.LineTo(lL-gBGImg.XBarGap,lT); + lImage.Canvas.MoveTo(lL+gBGImg.XBarGap,lT); + lImage.Canvas.LineTo(lW,lT); + //next vertical lines + lImage.Canvas.MoveTo(lL,0); + lImage.Canvas.LineTo(lL,lT-gBGImg.XBarGap); + lImage.Canvas.MoveTo(lL,lT+gBGImg.XBarGap); + lImage.Canvas.LineTo(lL,lH); +end; //Proc RenderDrawXBar + +procedure TRenderForm.RenderImageMouseDown(Sender: TObject; + Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var lXrender,lYrender,lZrender,lXout,lYout,lZOut,lPixelOffset,lZoom: integer; +lMatrix: TMatrix; +begin + + RenderDrawXBar ( X,Y,RenderImage); + //Next: find coordinates for orthogonal views: + lZoom := ImageZoomPct(RenderImage); + lXrender := round((X*100) / lZoom ); + lYrender := round(((Y)*100) / lZoom ); + lPixelOffset := lXrender+ ((gBGImg.RenderDim-lYrender)*gBGImg.RenderDim); + //ImgForm.StatusLabel.caption := inttostr(lXrender)+'x'+inttostr(lYrender)+' -> '+inttostr(gMRIcroOverlay[kBGOverlayNum].RenderDepthBufferItems ); + if (lPixelOffset < 1) or (lPixelOffset >gBGImg.RenderDepthBufferItems ) then exit; + lZrender := gBGImg.RenderDepthBuffer^[lPixelOffset]; + + lXrender := round(lXrender / gRender.Zoom); + lYrender := round(lYrender / gRender.Zoom); + lZrender := round(lZrender / gRender.Zoom); + lMatrix := AziElevMatrix; + InvertMatrixPoint (gBGImg,lMatrix,lXrender,lYrender,lZrender, lXout,lYout,lZOut); + ImgForm.XViewEdit.value := lXOut; + ImgForm.YViewEdit.value := lYOut; + ImgForm.ZViewEdit.value := lZOut; + {$IFDEF FPC} + ImgForm.XViewEditChange(nil); + {$ENDIF} +end; + +procedure TRenderForm.Cutout1Click(Sender: TObject); +begin + CutoutForm.Show; +end; + +procedure TRenderForm.Savesettings1Click(Sender: TObject); +begin + //showmessage(gRenderDir+' '+extractfiledir(gRenderDir)); + MultiSliceForm.MultiSaveDialog.InitialDir := extractfiledir(gRenderDir); + MultiSliceForm.MultiSaveDialog.FileName := 'a'+inttostr(gRender.Azimuth)+'e'+inttostr(gRender.Elevation); + if not MultiSliceForm.MultiSaveDialog.Execute then exit; + {$IFDEF Unix} + WriteRenderIniFile(extractfiledir(gRenderDir)+pathdelim+extractfilename(MultiSliceForm.MultiSaveDialog.Filename)); + {$ELSE} + WriteRenderIniFile(MultiSliceForm.MultiSaveDialog.Filename); + {$ENDIF} + UpdateRenderMRU; +end; + +procedure TRenderForm.FormHide(Sender: TObject); +begin + WriteRenderIniFile (gRenderDefaultsFilename); + //not sure how to make this safe for currently rendering threads... + if gBGImg.RenderDepthBufferItems > 0 then + Freemem(gBGImg.RenderDepthBuffer); + gBGImg.RenderDepthBufferItems := 0; +end; + +procedure TRenderForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + Save1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Close1.ShortCut := ShortCut(Word('W'), [ssMeta]); + {$ENDIF} + gRenderDir := DefaultsDir('render'); + //showmessage(gRenderDir); + //gRenderDir := extractfiledir(paramstr(0))+pathdelim+'render'+pathdelim; + gRenderDefaultsFilename := gRenderDir + 'default.ini'; + gRenderStartupFilename := gRenderDefaultsFilename; + RenderForm.DoubleBuffered := true; +end; + +procedure TRenderForm.RefreshClick(Sender: TObject); +begin + gZoom := 2; + RenderForm.RenderRefreshTimer.Tag := -1; //force a new rotation matrix to be generated + RenderForm.RenderRefreshTimer.enabled := true; +end; + +procedure TRenderForm.SetSearch(Sender: TObject); +begin + (sender as TMenuItem).checked := true; + gRender.OverlayFromBGSurface := (sender as TMenuItem).tag; + RenderRefreshTimer.Enabled := true; +end; + + + + +end. diff --git a/render/a0e90.ini b/render/a0e90.ini new file mode 100755 index 0000000..8f395f3 --- /dev/null +++ b/render/a0e90.ini @@ -0,0 +1,24 @@ +[BOOL] +SmoothBG=0 +SmoothOverlay=0 +Trilinear=1 +ShowCutout=0 +FlipLR=0 + +[INT] +OverlayFromBGSurface=1 +BGNearClip=0 +OverlayNearClip=0 +Azimuth=0 +Elevation=90 +BGSurface=0 +OverlaySurface=1 +BGDepth=12 +OverlayDepth=8 +CutoutBias=3 +CutoutLo1=96 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=87 +CutoutHi3=181 diff --git a/render/cut.ini b/render/cut.ini new file mode 100755 index 0000000..20ce387 --- /dev/null +++ b/render/cut.ini @@ -0,0 +1,24 @@ +[BOOL] +SmoothBG=0 +SmoothOverlay=0 +Trilinear=1 +ShowCutout=1 +FlipLR=0 + +[INT] +OverlayFromBGSurface=1 +BGNearClip=0 +OverlayNearClip=0 +Azimuth=110 +Elevation=30 +BGSurface=0 +OverlaySurface=1 +BGDepth=12 +OverlayDepth=8 +CutoutBias=3 +CutoutLo1=96 +CutoutHi1=181 +CutoutLo2=118 +CutoutHi2=217 +CutoutLo3=87 +CutoutHi3=181 diff --git a/render/default.ini b/render/default.ini new file mode 100755 index 0000000..4347f2d --- /dev/null +++ b/render/default.ini @@ -0,0 +1,26 @@ +[BOOL] +SmoothBG=1 +SmoothOverlay=1 +Trilinear=1 +ShowCutout=0 +FlipLR=0 + +[INT] +OverlayFromBGSurface=1 +BGNearClip=0 +OverlayNearClip=0 +Azimuth=90 +Elevation=45 +BGSurface=25 +OverlaySurface=1 +BGDepth=12 +OverlayDepth=8 +CutoutBias=3 +cutoutLUTindex=0 +ShadePct=0 +CutoutLoFrac1=530 +CutoutHiFrac1=1000 +CutoutLoFrac2=544 +CutoutHiFrac2=1000 +CutoutLoFrac3=481 +CutoutHiFrac3=1000 diff --git a/render_composite.pas b/render_composite.pas new file mode 100755 index 0000000..d2857c5 --- /dev/null +++ b/render_composite.pas @@ -0,0 +1,1075 @@ +unit render_composite; +interface +{$include isthreaded.inc} +uses +{$IFDEF Unix} +lclintf, //gettickcount +{$ELSE} +Windows, +{$ENDIF} +{$IFNDEF NoThreads} + RenderThds, +{$ELSE} +rendernothreads, +{$ENDIF} +{$IFDEF FPC} + LResources, //not sure if this is used... + {$ENDIF} + SysUtils, GraphicsMathLibrary,Classes, Graphics, Controls, Forms, Dialogs,ExtCtrls,Buttons, + nifti_img, nifti_hdr,define_types,nifti_img_view,StdCtrls, Menus,ClipBrd,ReadInt,cutout,IniFiles, + ComCtrls, nifti_types; +type + TRender = record + Zoom: single; + Cutout,CutoutFrac: TCutout; + //BGNearClipFrac, BGNearClip,OverlayNearClipFrac,OverlayNearClip, + ClipFrac, + Azimuth,Elevation,cutoutLUTindex,ShadePct, + OverlayFromBGSurface,BGSurface,OverlaySurface,BGDepth,OverlayDepth,CutoutBias,Gain,Bias: integer; + SmoothBG,SmoothOverlay,Trilinear,ShowCutout,FlipLR: boolean; + end; + procedure VolumeRotateMatrix (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean{;lNearSlicesClipIn: integer}); + procedure DrawRender; + procedure SliceToFrac(var lBGImg: TBGImg); + +var + + gRender:TRender; +const + kBelow = 1; + kInFront = 2; + +implementation + +uses math,render; + +procedure MinMaxFilt (var lHdr: TMRIcroHdr; var lFiltMin8bit, lFiltMax8bit: integer);var lMin,lMax: single; +begin +ReturnMinMax (lHdr,lMin,lMax, lFiltMin8bit, lFiltMax8bit); +end; + + +procedure Smooth2DImage (lX,lY: integer; lInBuffer: ByteP); +var + lSmoothBuffer: ByteP; + lLine,lLineStart,lInc,lOutPixel,lV: integer; +begin + GetMem (lSmoothBuffer , lX*lY); + FillChar(lSmoothBuffer^,lX*lY, 0); //zero array + for lLine:= (lY-1) downto 2 do begin + lLineStart := ((lLine-1)*(lX)); + for lInc := (lX-1) downto 2 do begin + lOutPixel := lLineStart+lInc; + lV := (lInBuffer^[lOutPixel] shl 3) + +(lInBuffer^[lOutPixel+1] shl 1)+(lInBuffer^[lOutPixel-1] shl 1) + +(lInBuffer^[lOutPixel+lX] shl 1)+(lInBuffer^[lOutPixel-lX] shl 1) + +(lInBuffer^[lOutPixel+lX+1])+(lInBuffer^[lOutPixel+lX-1]) + +(lInBuffer^[lOutPixel-lX+1])+(lInBuffer^[lOutPixel-lX-1]) + ; + lV := lV div 20; + lSmoothBuffer^[lOutPixel] := lV;//lV; + end; //for each column + end; //for each line (row) + Move(lSmoothBuffer^,lInBuffer^,lX*lY); + //Move(lSmoothBuffer^[1],lInBuffer[1]^,lX*lY); + FreeMem(lSmoothBuffer); +end; //proc Smooth2DImage + +procedure CreateOverlayRenderInfrontNear(var lBGHdr,lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDepth: Integer; var lQuadP: RGBQuadp; Smooth2D: boolean); +//changes Aug2007 - make sure search depth is not MAxInt - we get wrap around +var + lSrc,lOutBuffer: Bytep; + lLow,lHigh, + lIntensity,lDepth,lPixel,lSliceSz,lRenderSurface,lRenderDepth,lSamples: integer; +begin + if gBGImg.RenderDepthBufferItems < 1 then exit; + lSrc := lHdr.RenderBuffer;//lHdr.ScrnBuffer; + lSliceSz := lX*lY; + //lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lSliceSz); + fillchar(lOutBuffer^,lSliceSz,0); + lRenderSurface := lInRenderSurface; + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1; + for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lIntensity := 0; + lSamples := 0; + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+1 + else + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+lInRenderDepth; + if lRenderDepth >= lX then + lRenderDepth := lX-1; + lDepth := ((lPixel-1)* lX)+1; + lRenderDepth := lDepth + lRenderDepth; + while (lDepth < lRenderDepth) do begin + if (lSrc^[lDepth] > lRenderSurface) then begin + lIntensity := lIntensity+lSrc^[lDepth]; + inc(lSamples); + end; + + inc(lDepth); + end; + if lSamples > 0 then + lOutBuffer^[lPixel]:= lIntensity div lSamples; + end; //for each pixel with a background image +end; //for each pixel + (*for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lDepth := 0; + lIntensity := 0; + lSliceOffset := 0; + lSamples := 0; + lRenderDepth := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)+lInRenderDepth; + while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin + if (lSrc^[lSliceOffset+lPixel] > lRenderSurface) then begin + lIntensity := lIntensity+lSrc^[lSliceOffset+lPixel]; + inc(lSamples); + end; + inc(lSliceOffset,lSliceSz); + inc(lDepth); + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lDepth := lRenderDepth; //only show surface for cutout + end; + if lSamples > 0 then + lOutBuffer^[lPixel]:= lIntensity div lSamples; + end ; //if background + end; *) + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); +//Mar2007 start +if lHdr.LUTfromZero then begin + MinMaxFilt(lHdr,lLow,lHigh); + //fx(lLow,lHigh); + if lLow > 0 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lLow then + lOutBuffer^[lPixel] := 0; + if lHigh < 255 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lHigh then + lOutBuffer^[lPixel] := 0; +end; + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lHdr.LUT[lOutBuffer^[lPixel]]; + Freemem(lOutBuffer); +end; +procedure CreateOverlayRenderBehind(var lBGHdr,lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDepth: Integer; var lQuadP: RGBQuadp; Smooth2D: boolean); +var + lSrc,lOutBuffer: Bytep; + lLow,lHigh,lQ, + lSurfaceDepth,lIntensity,lDepth,lPixel,lSliceSz,lRenderSurface,lRenderDepth: integer; +begin + if gBGImg.RenderDepthBufferItems < 1 then exit; + lSrc := lHdr.RenderBuffer;//lHdr.ScrnBuffer; + lSliceSz := lX*lY; + //lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lSliceSz); + fillchar(lOutBuffer^,lSliceSz,0); + //lRenderDepth := lInRenderDepth; + //if (lRenderDepth < 1) or (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + // lRenderDepth := 1; + lRenderSurface := lInRenderSurface; + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1; + for lPixel := 1 to lSliceSz do begin + lSurfaceDepth := abs(gBGImg.RenderDepthBuffer^[lPixel]); + if (lSurfaceDepth > 0) and (lSurfaceDepth <= lX) then begin //background surface at this voxel + lIntensity := 0; + lRenderDepth := (lSurfaceDepth-1)+lInRenderDepth; + if lRenderDepth >= lX then + lRenderDepth := lX-1; + lDepth := ((lPixel-1)* lX)+1; + lRenderDepth := lDepth + lRenderDepth; + lDepth := lDepth + lSurfaceDepth-1; + lQ := 0; + while (lDepth < lRenderDepth) do begin + if (lSrc^[lDepth] > lRenderSurface) and (lSrc^[lDepth] > lIntensity) then + lIntensity := lSrc^[lDepth]; + //if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + if (gBGImg.RenderDepthBuffer^[lPixel] < 0) and (lQ > 3) then + lDepth := lRenderDepth; //only show surface for cutout + inc(lDepth); + inc(lQ); + end; + + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel with a background image +end; //for each pixel +//renderform.caption := inttostr(lQMax); + + (*for lPixel := 1 to lSliceSz do begin + if gBGImg.RenderDepthBuffer^[lPixel] <> 0 then begin //background surface at this voxel + lDepth := 0; + lIntensity := 0; + lSliceOffset := (abs(gBGImg.RenderDepthBuffer^[lPixel])-1)*lSliceSz; //start with nearest slice + while (lDepth < lRenderDepth) and (lSliceOffset < lVolSz) do begin + if (lSrc^[lSliceOffset+lPixel] > lRenderSurface) and (lSrc^[lSliceOffset+lPixel] > lIntensity) then + lIntensity := lSrc^[lSliceOffset+lPixel]; + inc(lSliceOffset,lSliceSz); + inc(lDepth); + if gBGImg.RenderDepthBuffer^[lPixel] < 0 then + lDepth := lRenderDepth; //only show surface for cutout + end; + lOutBuffer^[lPixel]:= lIntensity; + end; //background surface at this voxel + end; *) + + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); + +//Mar2007 start +if lHdr.LUTfromZero then begin + MinMaxFilt(lHdr,lLow,lHigh); + //fx(lLow,lHigh); + if lLow > 0 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lLow then + lOutBuffer^[lPixel] := 0; + if lHigh < 255 then + for lPixel := 1 to (lSliceSz) do + if lOutBuffer^[lPixel] < lHigh then + lOutBuffer^[lPixel] := 0; +end; +//Mar2007 end + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lHdr.LUT[lOutBuffer^[lPixel]]; + Freemem(lOutBuffer); +end; + + +Function AziElevMatrix : TMatrix; +var + lLRFlipMatrix: TMatrix; +begin + // gRender.Azimuth := RenderForm.AzimuthEdit.value; + //gRender.Elevation := RenderForm.ElevationEdit.value; + result := ViewTransformMatrix( + coordSpherical, + ToRadians(gRender.Azimuth), + ToRadians(gRender.Elevation), + 3{Distance.Value},6{ScreenWidthHeight.Value},6{ScreenWidthHeight.Value},{ScreenToCamera.Value}3); + {The ViewTransformMatrix is all that is needed for other objects defined + in world coordinates.} + if {RenderForm.FlipLRcheck.checked} gRender.FlipLR then begin + lLRFlipMatrix := Matrix3D (-1,0,0,0, // 3D "graphics" matrix + 0,1,0,0, + 0,0,1,0, + 0,0,0,0); + result := MultiplyMatrices(lLRFlipMatrix,Result); + end; +end; + +procedure ShadeCutoutCrease (var lRenderBuffer: bytep); +var +lZ,lY,lX: single; + lXin,lYin,lZIn,lXm,lYm,lZm,lPixel, + lOutDim,lOutPivot,lXPivotIn,lYPivotIn,lZPivotIn, + lXlo,lXhi,lYlo,lYhi,lZlo,lZhi,lYOffset: integer; + lClose,lScale: single; + lMatrix: TMatrix; +begin + lOutDim := gBGImg.RenderDim;//MaxDim(lBackgroundImg.ScrnDim[1],lBackgroundImg.ScrnDim[2],lBackgroundImg.ScrnDim[3]); + if gRender.Zoom > 0 then + lOutPivot := (round(gBGImg.RenderDim/gRender.Zoom)+1) shr 1 + else + lOutPivot :=(gBGImg.RenderDim+1) shr 1; //11/2007b + //lOutPivot := (lOutDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lXPivotIn := (gBGImg.ScrnDim[1]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lYPivotIn := (gBGImg.ScrnDim[2]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lZPivotIn := (gBGImg.ScrnDim[3]+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + lMatrix := InvertMatrix3D(AziElevMatrix); + //next: dilate borders by 1 pixel - draw crease INSIDE cutout + lXlo := gRender.CutOut.Lo[1]-1; + lXhi := gRender.CutOut.Hi[1]+1; + lYlo := gRender.CutOut.Lo[2]-1; + lYhi := gRender.CutOut.Hi[2]+1; + lZlo := gRender.CutOut.Lo[3]-1; + lZhi := gRender.CutOut.Hi[3]+1; +lScale := 1/gRender.Zoom; //11/2007 + + for lYin := 1 to lOutDim do begin + lYOffset := ((gBGImg.RenderDim-lYin)*gBGImg.RenderDim); + for lXin := 1 to lOutDim do begin + lPixel := lXin+ lYOffset; + if gBGImg.RenderDepthBuffer^[lPixel]<0 then begin + lZin := abs(gBGImg.RenderDepthBuffer^[lPixel]); + lX := (lXin *lScale)-lOutPivot ; + lY := lOutPivot -(lYin * lScale); + lZ := (lZin * lScale)-lOutPivot; + lXm := round( (lX*lMatrix.matrix[1,1])+(lY * lMatrix.matrix[2,1])+(lZ*lMatrix.matrix[3,1])); + lYm := round( (lX*(lMatrix.matrix[1,2]))+(lY * lMatrix.matrix[2,2])+(lZ*lMatrix.matrix[3,2])); + lZm := round( (lX*(lMatrix.matrix[1,3]))+(lY * lMatrix.matrix[2,3])+(lZ*lMatrix.matrix[3,3])); + lXm := (lXm+lXPivotIn); + lYm := (lYm+lYPivotIn); + lZm := (lZm+lZPivotIn); + if abs(lXlo-lXm) < abs(lXhi-lXm) then + lXm := abs(lXlo-lXm) + else + lXm := abs(lXhi-lXm); + if abs(lYlo-lYm) < abs(lYhi-lYm) then + lYm := abs(lYlo-lYm) + else + lYm := abs(lYhi-lYm); + if abs(lZlo-lZm) < abs(lZhi-lZm) then + lZm := abs(lZlo-lZm) + else + lZm := abs(lZhi-lZm); + if (lXm < lYm) and (lZm < lYm) then + lYm := lZm //Y is furthest, replace with Z + else if lZm < lXm then //X is furthest, replace with Z + lXm := lZm; + lClose := sqrt((lXm*lXm) + (lYm*lYm)); + if lClose < 8 then begin + lClose := 1-sqr(1-(lClose/8)); + lRenderBuffer^[lPixel] := round(lRenderBuffer^[lPixel]*(0.33+(0.67*lClose))); + end; + end; + end; //for lYin + end; //for lXin +end; + +procedure LUTbiasX (var lOutLUT : TLUT); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick +Graphics Gems IV, p379-382, April 1994 } +var + lIndex: integer; + lA,lT,lBias: single; + lLUT: TLUT; +begin + if gRender.CutoutBias = 4 then exit; + lA := (gRender.CutoutBias+1)/10; + + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[round(lBias)]; + {lHdr.LUT[lIndex].rgbRed := round(lBias*lHdr.LUT[lIndex].rgbRed); + lHdr.LUT[lIndex].rgbGreen := round(lBias*lHdr.LUT[lIndex].rgbGreen); + lHdr.LUT[lIndex].rgbBlue := round(lBias*lHdr.LUT[lIndex].rgbBlue);} + //lHdr.LUT[lIndex].rgbReserved := kLUTalpha; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + +procedure LUTgainX (var lOutLUT : TLUT; lBiasIn,lGainIn: integer {0..99}); +{http://dept-info.labri.fr/~schlick/DOC/gem2.html +http://dept-info.labri.fr/~schlick/publi.html +Fast Alternatives to Perlin's Bias and Gain Functions +Christophe Schlick Graphics Gems IV, p379-382, April 1994 } +var + lIndex,lV: integer; + lA,lG,lT,lGain: single; + lLUT: TLUT; +begin + if (lGainIn = 50) and (lBiasIn = 50){gRender.CutoutBias = 4} then exit; + lA := (lBiasIn)/100; + if lA = 0 then + lA := 0.000001; + lG := (lGainIn)/100; + if lG = 0 then + lG := 0.00001; + if lG = 1 then + lG := 0.99999; + for lIndex := 1 to 254 do begin + lT := lIndex/255; + //apply bias + lT := (lt/((1/la-2)*(1-lt)+1)) ; + //next apply gain + if lT < 0.5 then + lGain := (lT/((1/lG-2)*(1-2*lT)+1)) + else + lGain := (( (1/lG-2)*(1-2*lT)-lT ) / ( (1/lG-2)*(1-2*lT)-1 ) ); + lGain := lGain / lT; + lV := round(255*lT*lGain); + if lV > 255 then + lV := 255; + if lV < 0 then + lV := 0; + //lBias := 255*(lt/((1/la-2)*(1-lt)+1)) ; + lLUT[lIndex] := lOutLUT[lV]; + end; + for lIndex := 1 to 254 do + lOutLUT[lIndex] := lLUT[lIndex]; +end; + +function SmoothShading (lX,lY: integer; lRenderDepthBuffer: SmallintP): boolean; +var + kRenderInfiniteDepth,lPrevLineStart,lNextLineStart,lLineStart,lScanLines, + lGap,lDepthSum,lWeightSum,lFar,lClose,lCenter,lInc,lXmG: integer; + lRenderDepthBufferS: SmallIntP; +procedure AddPt (lI,lW: integer; var lSumI,lSumW: integer); +begin + if lI = kRenderInfiniteDepth then exit; + lSumI := lSumI + (lW*lI); //add scaled value + lSumW := lSumW + lW;//add weight +end; +//problem - smoothing gives embossed look! +begin //func Smoothshading + kRenderInfiniteDepth := 0; + result := false; + if (gRender.Zoom < 1) or (lY < 5) or (lX < 5) or (gBGImg.RenderDepthBufferItems <> (lX * lY)) then + exit; + lFar := 2; + lClose := 3; + lCenter := 5; + lGap := trunc((gRender.Zoom-0.001)/1)+1; //must be at least 1! + lXmG := lX-lGap; + Getmem(lRenderDepthBufferS,lX*lY*sizeof(smallint)); + for lInc := 1 to (lX*lY) do + lRenderDepthBufferS^[lInc] := lRenderDepthBuffer^[lInc]; + + for lScanlines := (1+lGap) to (lY - lGap) do begin //can not compute angle for 1st and last scanline + lLineStart := (lScanLines-1)*lX; //inc from 0 + lPrevLineStart := lLineStart-(lX*lGap); //inc from 0 + lNextLineStart := lLineStart+(lX*lGap); //inc from 0 + for lInc := (1+lGap) to (lXmG) do begin + lWeightSum := 0; + lDepthSum := 0; + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc-1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lPrevLineStart+lInc+1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc-1],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc],lCenter,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lLineStart+lInc+1],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc-1],lFar,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc],lClose,lDepthSum,lWeightSum); + AddPt (lRenderDepthBuffer^[lNextLineStart+lInc+1],lFar,lDepthSum,lWeightSum); + if lWeightSum > 0 then + lRenderDepthBufferS^[lLineStart+lInc] := round(lDepthSum/lWeightSum); + end; //columns + end; //for scanlines: rows + for lInc := 1 to (lX*lY) do + lRenderDepthBuffer^[lInc] := lRenderDepthBufferS^[lInc]; + freemem(lRenderDepthBufferS); + result := true; +end; //function SmoothShading + + +function IlluminationShading (lX,lY,lPct: integer; lImgBuffer: bytep; lRenderDepthBuffer: SmallintP): boolean; +var + kRenderInfiniteDepth,lXm1,lPrevLineStart,lNextLineStart,lLineStart,lScanLines, + lIntensity,lInc,lGrayMin,lGrayMax: integer; + lShadeFrac,lImgFrac, + lPhongMagic,lMagic,lYVal,lXVal,lNormalPlane,lXLight,lYLight,lZLight,lLightVectorNormalise: single; + lShadeBuffer: bytep; +begin //func illumination shading + + result := false; + if (lPct < 1) or (lY < 5) or (lX < 5) or (gBGImg.RenderDepthBufferItems <> (lX * lY)) then + exit; + lMagic := 1; + lPhongMagic := 1; + kRenderInfiniteDepth := 0; + lXLight := 0;//RenderForm.XL.value / 100;//lXLight / lLightVectorNormalise; + lYLight := -0.5;//Renderform.YL.value / 100;//lYLight / lLightVectorNormalise; + lZLight := -1;//RenderForm.ZL.value / 100;//lZLight / lLightVectorNormalise; + lLightVectorNormalise := sqrt(sqr(lXLight)+sqr(lYLight)+sqr(lZLight)); + lXLight := lXLight / lLightVectorNormalise; + lYLight := lYLight / lLightVectorNormalise; + lZLight := lZLight / lLightVectorNormalise; + lGrayMin := 0{64}; + lGrayMax := 255 - lGrayMin; + lXm1 := lX-1; + Getmem(lShadeBuffer,lX*lY*sizeof(byte)); + fillchar(lShadeBuffer^,lX*lY,0); + + for lScanlines := 2 to (lY - 1) do begin //can not compute angle for 1st and last scanline + lLineStart := (lScanLines-1)*lX; //inc from 0 + lPrevLineStart := lLineStart-lX; //inc from 0 + lNextLineStart := lLineStart+lX; //inc from 0 + for lInc := 2 to (lXm1) do begin + if lImgBuffer^[lLineStart+lInc] <> 0 then begin //only shade non-zero intensities + if ( lRenderDepthBuffer^[lPrevLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lPrevLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lPrevLineStart+lInc+1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lLineStart+lInc+1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc-1]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc]<>kRenderInfiniteDepth) + and (lRenderDepthBuffer^[lNextLineStart+lInc+1]<>kRenderInfiniteDepth) then begin + lYVal := lRenderDepthBuffer^[lPrevLineStart+lInc-1]+lRenderDepthBuffer^[lPrevLineStart+lInc]+lRenderDepthBuffer^[lPrevLineStart+lInc+1] + -lRenderDepthBuffer^[lNextLineStart+lInc-1]-lRenderDepthBuffer^[lNextLineStart+lInc]-lRenderDepthBuffer^[lNextLineStart+lInc+1]; + lXVal := lRenderDepthBuffer^[lPrevLineStart+lInc-1]+lRenderDepthBuffer^[lLineStart+lInc-1]+lRenderDepthBuffer^[lNextLineStart+lInc-1] + -lRenderDepthBuffer^[lPrevLineStart+lInc+1]-lRenderDepthBuffer^[lLineStart+lInc+1]-lRenderDepthBuffer^[lNextLineStart+lInc+1]; + lNormalPlane := sqrt(sqr(lXVal)+sqr(lYVal)+sqr(lMagic)); + if lNormalPlane <> 0 then begin + lNormalPlane := -((-lXLight*lXVal)-(lYLight*lYVal)+lMagic*lZLight)/lNormalPlane; + if {lImageAndShade} false then begin + lNormalPlane := Power(lNormalPlane,lPhongMagic); + //lIntensity := gProjBuffer[lLineStart+lInc]; + //lIntensity := lPropShadingPivot+round((lPctImage*(lIntensity-lPropShadingPivot))+(lPctShade*(lNormalPlane-0.5)) ); + if lIntensity > 254 then lIntensity := 254; + lShadeBuffer^[lLineStart+lInc] := lIntensity; + end else begin //shading only + //if lAbbaRandom then //abba + lNormalPlane := (lNormalPlane+1) / 2; + if lNormalPlane > 0 then begin + lNormalPlane := Power(lNormalPlane,lPhongMagic); + //if lAbbaRandom then //abba + //if lNormalPlane < 0.5 then lNormalPlane := 1-lNormalPlane; //backlighting + lShadeBuffer^[lLineStart+lInc] := lGrayMin{64}+ round(lNormalPlane*(lGrayMax)); + end else + lShadeBuffer^[lLineStart+lInc] := lGrayMin; + end; //Shading vs ImageAndShading + end; //NormalPlane = 0 + end else begin //samples for each pixel + if {lImageAndShade}false then + lShadeBuffer^[lLineStart+lInc] := 0//lPropShadingPivot+round((lPctImage*(gProjBuffer[lLineStart+lInc]-lPropShadingPivot))+(lPctShade*(-0.5)) )//1362 + else + lShadeBuffer^[lLineStart+lInc] := lGrayMin;//1363;'# 20{64}; + end; + end; //only shade non-zero intensities + end; //columns + end; //for scanlines: rows + if lPct > 99 then begin + for lInc := 1 to (lX*lY) do + lImgBuffer^[lInc] := lShadeBuffer^[lInc]; + + end else begin //partial shade + lImgFrac := (100-lPct)/100; + lShadeFrac := lPct/100; + for lInc := 1 to (lX*lY) do + lImgBuffer^[lInc] := round((lImgBuffer^[lInc]* lImgFrac) + (lShadeBuffer^[lInc]*lShadeFrac )); + end; + freemem(lShadeBuffer); + result := true; +end; //function illuminationshading + +procedure LUTLoad( lLUTindex: integer; var lLUT: TLUT); +var + lHdr: TMRIcroHdr; + lStr: string; + lInc: integer; +begin + //gMRIcroOverlay[lLayer].LUTindex := LUTdrop.ItemIndex; + if lLUTindex < knAutoLUT then begin + LoadMonochromeLUT(lLUTindex,gBGImg,lHdr); + end else begin //if B&W lut + lStr := gColorSchemeDir+pathdelim+ImgForm.LUTdrop.Items.Strings[lLUTindex]+'.lut'; + if not FileExistsEX(lStr) then + showmessage('Can not find '+lStr); + LoadColorScheme(lStr, lHdr); + end; + for lInc := 0 to 255 do + lLUT[lInc] := lHdr.LUT[lInc]; +end; + + +procedure CreateRender(var lBGHdr, lHdr: TMRIcroHdr; var lX,lY,lZ,lInRenderSurface,lInRenderDpeth: Integer; var lQuadP: RGBQuadp; Smooth2D, NormalizeIntensity,lCreateDepthBuffer: boolean;lUseDepthBuffer: integer); +var + lLUT : array [0..255] of byte; + lrgbLUT: TLUT;// array[0..255] of TRGBQuad; + //lTime: DWord; + lSrc,lOutBuffer: Bytep; + lShade,lShadePrecise: boolean; + lPreciseDepthBuffer: Smallintp; + lMaxInten,lDepth,lPixel,lSamples,lSliceOffset,lIntensity,lSliceSz,lSliceEnd,lSliceStart, + lVolSz,lRenderDepth,lRenderSurface,lTemp,lNear,lSubPixel,lClip: integer; +begin + + lShade := false; + lShadePrecise := false; + if {(gRender.BGNearClip<>0) or} (gRender.ShowCutout) then + lMaxInten := 254 + else + lMaxInten := 257; + lRenderDepth := lInRenderDpeth; + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderDepth := 1; + lRenderSurface := lInRenderSurface; + //if not lCreateDepthBuffer then + + if (lHdr.IMgBufferItems > 0) {2/2008} and (lHdr.NIFTIhdr.intent_code = kNIFTI_INTENT_LABEL) then + lRenderSurface := 1 + else begin + //make sure at least some voxels are below air-surface threshold + if (lHdr.WindowScaledMin <= (Raw2ScaledIntensity(lHdr,lHdr.GlMinUnscaledS) )) and (lHdr.WindowScaledMax <> 0 ) then begin + lTemp := round( (Raw2ScaledIntensity(lHdr,lHdr.GlMinUnscaledS)-lHdr.WindowScaledMin)/(lHdr.WindowScaledMax)*255); + //showmessage(inttostr(lTemp)); + if lTemp >= lRenderSurface then + lRenderSurface := lTemp + 1; + end; + end; + + if (lUseDepthBuffer=kBelow) then begin + CreateOverlayRenderBehind(lBGHdr,lHdr, lX,lY,lZ,lRenderSurface,lRenderDepth, lQuadP, Smooth2D); + exit; + end; + + if (lUseDepthBuffer=kInFront) then begin + CreateOverlayRenderInfrontNear(lBGHdr,lHdr, lX,lY,lZ,lRenderSurface,lRenderDepth, lQuadP, Smooth2D); + exit; + end; + lSrc := lHdr.RenderBuffer; + lSliceSz := lX*lY; + lVolSz := lSliceSz * lZ; + GetMem (lOutBuffer , lX*lY); + //gRender.ClipFrac := kMaxFrac div 2; + lClip := round(gRender.ClipFrac/kMaxFrac * lX); + if lClip >= lX then + lClip := 0; + if lCreateDepthBuffer then begin + if (gRender.ShadePct > 0) then begin + lShade := true; + if lRenderDepth > 0 then begin//not MIP + lShadePrecise := true; + getmem(lPreciseDepthBuffer,lSliceSz * sizeof(smallint)); + fillchar(lPreciseDepthBuffer^,lSliceSz* sizeof(smallint),0); + end; + end; + if gBGImg.RenderDepthBufferItems <> lSliceSz then begin + if gBGImg.RenderDepthBufferItems > 0 then + Freemem(gBGImg.RenderDepthBuffer); + gBGImg.RenderDepthBufferItems := lSliceSz; + GetMem(gBGImg.RenderDepthBuffer,lSliceSz*sizeof(smallint)); + end; + fillchar(gBGImg.RenderDepthBuffer^,lSliceSz* sizeof(smallint),0); + //lTime := gettickcount; + if lRenderDepth < 1 then begin//MIP + for lPixel := 1 to lSliceSz do begin + lIntensity := 0; + lSliceStart := ((lPixel-1)* lX)+1; + lSliceOffset := lSliceStart+lClip; //start with nearest slice + lSliceEnd := lSliceStart + lX; + while (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and (lSrc^[lSliceOffset] > lIntensity) then begin + lIntensity := lSrc^[lSliceOffset]; + gBGImg.RenderDepthBuffer^[lPixel] := lSliceOffset - lSliceStart; + end; + inc(lSliceOffset,1); + end; //while traversing front to back + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel + end else begin //if MIP else use opacity filter... + for lPixel := 1 to lSliceSz do begin + lDepth := 0; + lSamples := 0; + lIntensity := 0; + lSliceStart := ((lPixel-1)* lX)+1; + lSliceOffset := lSliceStart+lClip; //start with nearest slice + lSliceEnd := (lPixel* lX); + while (lDepth < lRenderDepth) and (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and ((lDepth > 0) or (lSrc^[lSliceOffset] > lRenderSurface)) then begin + inc(lDepth); + if (lSrc^[lSliceOffset] > lRenderSurface) then begin + lIntensity := lIntensity+ lSrc^[lSliceOffset]; + inc(lSamples); + end; + if (lDepth = 1) then begin + gBGImg.RenderDepthBuffer^[lPixel] := lSliceOffset - lSliceStart; + + if (gBGImg.RenderDepthBuffer^[lPixel]=lCLip ) or ((gBGImg.RenderDepthBuffer^[lPixel] > 1) and (lSrc^[lSliceOffset-1]>=lMaxInten)) then begin //cutout + if lSrc^[lSliceOffset-1]=lMaxInten-1 then + lIntensity := 0; + lDepth := lRenderDepth; + gBGImg.RenderDepthBuffer^[lPixel] := -gBGImg.RenderDepthBuffer^[lPixel]; //negative: this is a cutout + end; + if lShade then begin + if (gBGImg.RenderDepthBuffer^[lPixel] > 1) then begin //estimate surface depth with sub-pixel accuracy + lNear := lSrc^[lSliceOffset-1]; + lSubPixel := lIntensity-lNear; //delta + lSubPixel := round(((lRenderSurface-lNear)/lSubPixel)*10); + if lNear >= lMaxInten then //cutout + lSubPixel := 0; + end else + lSubpixel := 0; + lPreciseDepthBuffer^[lPixel] := (gBGImg.RenderDepthBuffer^[lPixel] * 10)+lSubPixel; + end; + end; + end; + inc(lSliceOffset,1); + + end; //while no voxel found + if lDepth > 0 then + lIntensity := lIntensity div lSamples; + //lIntensity := lIntensity div lDepth; //mean of nDepth voxels + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel 1..sliceSz + if (Smooth2D) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then //do not smooth labels + Smooth2DImage (lX,lY, lOutBuffer); //only smooth volume renderings - not MIPS (they looked embossed) + end; //if not MIP +end else begin //do not create depth buffer + for lPixel := 1 to lSliceSz do begin + lDepth := 0; + lSamples := 0; + lIntensity := 0; + lSliceOffset := ((lPixel-1)* lX)+1+lClip; //start with nearest slice + lSliceEnd := (lPixel* lX); + while (lDepth < lRenderDepth) and (lSliceOffset < lSliceEnd) do begin + if (lSrc^[lSliceOffset] < lMaxInten) and ((lDepth > 0) or (lSrc^[lSliceOffset] > lRenderSurface)) then begin + inc(lDepth); + if (lSrc^[lSliceOffset] > lRenderSurface) then begin + lIntensity := lIntensity+ lSrc^[lSliceOffset]; + inc(lSamples); + end; + end; + inc(lSliceOffset,1); + end; //while no voxel found + if lDepth > 0 then + lIntensity := lIntensity div lSamples; + //lIntensity := lIntensity div lDepth; //mean of nDepth voxels + lOutBuffer^[lPixel]:= lIntensity; + end; //for each pixel +end; //volume render without depth buffer + //RenderForm.Caption := inttostr(gettickcount - lTime)+' '+inttostr(lRenderDepth); + if (NormalizeIntensity) and (lRenderSurface < 254) then begin //do BEFORE shading! + for lPixel := 0 to 255 do + lLUT[lPixel] := 0; + for lPixel := lRenderSurface to 255 do + lLUT[lPixel] := round(255*(lPixel-lRenderSurface)/(255-lRenderSurface)); + for lPixel := 1 to lSliceSz do + lOutBuffer^[lPixel] := lLUT[lOutBuffer^[lPixel]]; + end; + if lShade then begin + if lShadePrecise then begin + SmoothShading (lX,lY,lPreciseDepthBuffer); + IlluminationShading(lX,lY,gRender.ShadePct,lOutBuffer,lPreciseDepthBuffer{gBGImg.RenderDepthBuffer} ); + freemem(lPreciseDepthBuffer); + end else + IlluminationShading(lX,lY,gRender.ShadePct,lOutBuffer,gBGImg.RenderDepthBuffer); + + end;//shading + + for lPixel := 0 to 255 do + lrgbLUT[lPixel] := lHdr.LUT[lPixel]; + if (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + LUTGainX(lrgbLUT,gRender.Bias,gRender.Gain ); //Mar2007 + + for lPixel := 1 to lSliceSz do + lQuadP^[lPixel]:= lrgbLUT[lOutBuffer^[lPixel]]; + if ((lClip >0) or (gRender.ShowCutout)) and (lCreateDepthBuffer) then begin //make cutout grayscale, shade edges + if gRender.ShowCutout then + ShadeCutoutCrease(lOutBuffer); + LUTLoad(gRender.cutoutLUTindex,lrgblut);//11/2007 + {for lPixel := 0 to 255 do begin + lrgbLUT[lPixel].rgbRed := lPixel; + lrgbLUT[lPixel].rgbGreen := lPixel; + lrgbLUT[lPixel].rgbBlue := lPixel; + lrgbLUT[lPixel].rgbReserved := kLUTalpha; + + end;}//create grayscale LUT + LUTBiasX(lrgbLUT); + for lPixel := 1 to lSliceSz do + if gBGImg.RenderDepthBuffer^[lPixel]<0 then //cutout + lQuadP^[lPixel]:= lrgbLUT[lOutBuffer^[lPixel]]; + end; //if BGimg with Cutout + Freemem(lOutBuffer); +end; + +function RenderDepth (lVal: integer): integer;//11/2007 +begin + if (lVal > 0) and (lVal < 16000) and (gBGImg.ScrnMM[1] > 0.1) and (gBGImg.ScrnMM[1] < 10) then begin + result:= round (lVal / gBGImg.ScrnMM[1]); + if result < 1 then + result := 1; + end else + result := lVal; +result := round(result * gRender.Zoom); +end; + +procedure DrawRender; +var + lBGQuadP, lOverlayQuadP, l2ndOverlayQuadP: RGBQuadp; + lUseBGSurface,lnOverlay,lOverlay, lX,lY,lZ,lSliceSz,lRenderSurface,lRenderDepth: longint; + lBG0Clr,lOverlay0Clr: DWord; + lSmooth : boolean; +begin + lRenderSurface := gRender.BGSurface; + //lRenderDepth:= gRender.BGDepth; + lRenderDepth:= RenderDepth(gRender.BGDepth);//11/2007 + lSmooth := gRender.SmoothBG; + lUseBGSurface := gRender.OverlayFromBGSurface ; + lX := gMRIcroOverlay[kBGOverlayNum].RenderDim; + lY := lX; + lZ := lX; + lSliceSz := (lX * lY); + if (gMRIcroOverlay[kBGOverlayNum].RenderBufferItems=0)or (lX < 2) or (lY < 2) or (lZ < 2) or ((lX*lY*lZ) > gMRIcroOverlay[kBGOverlayNum].RenderBufferItems{ScrnBufferItems}) then + exit; + GetMem ( lBGQuadP, lSliceSz*4); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[kBGOverlayNum], lX,lY,lZ,lRenderSurface,lRenderDepth, lBGQuadP, lSmooth, true,true,0); +//next: overlays + lSmooth := gRender.SmoothOverlay; + lRenderSurface := gRender.OverlaySurface; + //lRenderDepth:= gRender.OverlayDepth; + lRenderDepth:= RenderDepth(gRender.OverlayDepth);//11/2007 +lnOverlay := 0; +lBG0Clr:= TRGBQuad2DWord(gMRIcroOverlay[0].LUTinvisible);//just to avoid compiler warning hint - never used... +for lOverlay := knMaxOverlay downto 1 do begin + if gMRIcroOverlay[lOverlay].RenderBufferItems{ScrnBufferItems} > 0 then begin + if lOverlay = kVOIOverlayNum then //Aug2007 + lRenderSurface := 0 + else + lRenderSurface := gRender.OverlaySurface;// + inc(lnOverlay); + if lnOverlay = 1 then begin //top overlay + GetMem ( lOverlayQuadP , lSliceSz*4); + lBG0Clr:= TRGBQuad2DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay],lX,lY,lZ,lRenderSurface,lRenderDepth,lOverlayQuadP,lSmooth,false,false,lUseBGSurface); + end else begin //2nd or lower overlay + if lnOverlay = 2 then //2nd overlay + GetMem ( l2ndOverlayQuadP , lSliceSz*4); + CreateRender(gMRIcroOverlay[kBGOverlayNum],gMRIcroOverlay[lOverlay], lX,lY,lZ,lRenderSurface,lRenderDepth,l2ndOverlayQuadP,lSmooth,false,false,lUseBGSurface); + lOverlay0Clr:= TRGBQuad2DWord(gMRIcroOverlay[lOverlay].LUTinvisible); + AlphaBlend32(lOverlayQuadP,l2ndOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.OverlayTransPct); + end; //2nd overlay or more + end; //overlay loaded +end; //for knOverlay..1 +//Finally: draw overlays on BG +if lnOverlay > 0 then begin + lOverlay0Clr := lBG0Clr; + //lBG0Clr := DWord(lHdr.LUTinvisible); + lBG0Clr := 0;//0=impossible, no alpha DWord(lHdr.LUT[0]); + if lnOverlay > 1 then + FreeMem ( l2ndOverlayQuadP); + AlphaBlend32(lBGQuadP,lOverlayQuadP, lBG0Clr,lOverlay0Clr, lSliceSz,gBGImg.BGTransPct); + FreeMem ( lOverlayQuadP); +end; +//draw image + SetDimension32(lY,lX, lBGQuadP, gBGImg, RenderForm.RenderImage, RenderForm.RenderPanel); + SetDimension32(lY,lX, lBGQuadP, gBGImg, RenderForm.RenderImageBUP, RenderForm.RenderPanel); + FreeMem ( lBGQuadP); + if gBGImg.RenderDepthBufferItems > 0 then //negative depth was used for cutouts, now set to true depth + for lX := 1 to gBGImg.RenderDepthBufferItems do + gBGImg.RenderDepthBuffer^[lX] := abs(gBGImg.RenderDepthBuffer^[lX]); +end; + +procedure SliceToFrac(var lBGImg: TBGImg); +var + lInc: integer; +begin + SortCutOut (gRender.CutOut); + for lInc := 1 to 3 do begin + if lBGImg.ScrnDim[lInc] < 1 then begin + gRender.CutoutFrac.Lo[lInc] := round (0.5* kMaxFrac); + gRender.CutoutFrac.Hi[lInc] := kMaxFrac; + end else begin + gRender.CutoutFrac.Lo[lInc] := round(kMaxFrac * gRender.Cutout.Lo[lInc]/lBGImg.ScrnDim[lInc]); + gRender.CutoutFrac.Hi[lInc] := round(kMaxFrac * gRender.Cutout.Hi[lInc]/lBGImg.ScrnDim[lInc]); + end; + end; +end; + +procedure SetLimits(var lBGImg: TBGImg); +var lInc: integer; +lUpdateCutout: boolean; +lScale: single; +begin + SortCutOut (gRender.CutOutFrac); + if gRender.CutoutFrac.Lo[1] < 0 then + SliceToFrac(lBGImg); + lScale := 1/kMaxFrac; + for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := round(gBGImg.ScrnDim[lInc] * lScale * gRender.CutoutFrac.Lo[lInc]); + gRender.Cutout.Hi[lInc] := round(gBGImg.ScrnDim[lInc] * lScale * gRender.CutoutFrac.Hi[lInc]); + end; + lUpdateCutout := true; + for lInc := 1 to 3 do + if gRender.Cutout.Lo[lInc] <> gRender.Cutout.Hi[lInc] then lUpdateCutout := false; + if lUpdateCutout then + for lInc := 1 to 3 do begin + gRender.Cutout.Lo[lInc] := gBGImg.ScrnDim[lInc] div 2; + gRender.Cutout.Hi[lInc] := gBGImg.ScrnDim[lInc]; + end; + for lInc := 1 to 3 do begin + if gRender.Cutout.Lo[lInc] < 1 then gRender.Cutout.Lo[lInc] := 1; + if gRender.Cutout.Lo[lInc] > lBGImg.ScrnDim[lInc] then gRender.Cutout.Lo[lInc] := lBGImg.ScrnDim[lInc]; + if gRender.Cutout.Hi[lInc] < 1 then gRender.Cutout.Hi[lInc] := 1; + if gRender.Cutout.Hi[lInc] > lBGImg.ScrnDim[lInc] then gRender.Cutout.Hi[lInc] := lBGImg.ScrnDim[lInc]; + end; +end; + +procedure VolumeRotateMatrix (var lBGImg: TBGImg; var lHdr: TMRIcroHdr; var lMatrixIn: TMatrix; lBilinearSmooth,lRenderCutout,lIsBG: boolean {;lNearSlicesClipIn: integer}); +label 345; +const + kUgly2 = 10000; + //kSh = 10; //bits to shift + kUgly1 = (kUgly2 shl kSh) + (1 shl kSh); +var + + l: TRotateVals; + lZinc,lZ,lY,lX,lOutVolSz, + lOutPos,lInVolSz, + lYo,lZo,lnThreads: integer; + lBuffIn,lSrcBuff,lBuffOut: Bytep; + lXxp,lXyp,lXzp: Pointer; + lStartTime: DWord; + lM, lScale,lMatrix: TMatrix; + lZoomRatio: Single; + begin + + lMatrix := lMatrixIn; + + if (gRender.Zoom <> 0) and (gRender.Zoom <> 1 )then begin + lZoomRatio := 1/gRender.Zoom; + lScale := Matrix3D(lZoomRatio,0,0,0, 0,lZoomRatio,0,0, 0,0,lZoomRatio,0, 0,0,0,0); + lMatrix := MultiplyMatrices(lMatrixIn,lScale); + end else + gRender.Zoom := 1; + //lScale := Matrix3D(0,1,0,0, 1,0,0,0, 0,0,1,0, 0,0,0,0); + //lScale := Matrix3D(0,1,0,0, 0,0,1,0, 1,0,0,0, 0,0,0,0); + lScale := Matrix3D(0,1,0,0, 0,0,1,0, 1,0,0,0, 0,0,0,0); + lMatrix := MultiplyMatrices(lMatrix,lScale); + lStartTime := GetTickCount; + l.XdimIn := lBGImg.ScrnDim[1]; + l.YdimIn := lBGImg.ScrnDim[2]; + l.ZdimIn := lBGImg.ScrnDim[3];; + l.InSliceSz := l.XDimIn*l.YDimIn; + lInVolSz := l.XdimIn*l.YdimIn*l.ZdimIn; //InVolSz! + if (lHdr.ScrnBufferItems < lInVolSz) then + exit; + lSrcBuff := lHdr.ScrnBuffer; + l.OutDim := MaxDim(l.XDimIn,l.YDimIn,l.ZDimIn); + l.OutDim := round(gRender.Zoom * l.OutDim); //11/2007 + (*lNearSlicesClip := lNearSlicesClipIn;//May07 + if lNearSlicesClip >= l.OutDim then //May07 + lNearSlicesClip := 0; //May07*) + lBGImg.RenderDim := l.OutDim; + lHdr.RenderDim := l.OutDim; + //l.RenderCutout := false; + if (lRenderCutout) then begin + //l.RenderCutout := true; + + SetLimits(lBGImg); + GetMem(lBuffIn, lInVolSz); + Move(lSrcBuff^,lBuffIn^,lInVolSz); + for lZ := 1 to lInVolSz do + if lBuffIn^[lZ] >= 254 then lBuffIn^[lZ] := 253; + if lRenderCutout then begin + + for lZ := gRender.Cutout.Lo[3] to gRender.Cutout.Hi[3] do begin + lZo := (lZ-1) * l.InSliceSz; + Application.ProcessMessages; + for lY := gRender.Cutout.Lo[2] to gRender.Cutout.Hi[2] do begin + lYo := (lY-1) * l.XdimIn; + for lX := gRender.Cutout.Lo[1] to gRender.Cutout.Hi[1] do + lBuffIn^[lX+lYo+lZo] := 255; + end; //for lY + end; //for lZ + end; + end else + lBuffIn := lSrcBuff; + l.OutPivot := (lHdr.RenderDim+1) shr 1; //e.g. if DimMax=9, then pivot is 5 + l.XPivotIn := ((l.XdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.YPivotIn := ((l.YdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.ZPivotIn := ((l.ZdimIn+1) shr 1); //e.g. if DimMax=9, then pivot is 5 + l.YDimStart := -l.OutPivot+1; //e.g. if 9, start from -4 + l.ZDimStart := l.YDimStart ; + + l.YDimEnd := l.YDimStart+lHdr.RenderDim-1; //e.g. if 9, go to 4 + l.ZDimEnd := l.YDimEnd; + if l.ZDimStart >= l.ZDimEnd then + l.ZDImStart := l.ZDimStart; + l.OutSliceSz := sqr(lHdr.RenderDim); + lOutVolSz := lHdr.RenderDim*l.OutSliceSz; + if lHdr.RenderBufferItems <> lOutVolSz then begin + if lHdr.RenderBufferItems > 0 then + Freemem(lHdr.RenderBuffer); + lHdr.RenderBufferItems := lOutVolSz; + try + GetMem(lHdr.RenderBuffer,lOutVolSz); + except //12/2007 + showmessage('Volume Rotate Error: System memory exhausted.'); + lHdr.RenderBufferItems := 0; + exit; + end; + + end; + lBuffOut := lHdr.RenderBuffer; + fillchar(lBuffOut^,lOutVolSz,0); //set all to zero + + //lMatrix := InvertMatrix3D(lMatrix); + lZ := (sizeof(longint)* l.OutDim)+16; + GetMem(lXxp, lZ); + GetMem(lXyp, lZ); + GetMem(lXzp, lZ); +// if RenderForm.RenderRefreshTimer.enabled then goto 345;//abort + {$IFNDEF FPC} + l.XxRA := LongIntP($fffffff0 and (integer(lXxP)+15)); //data aligned to quad-word boundary + l.XyRA := LongIntP($fffffff0 and (integer(lXyP)+15)); //quad-word boundary + l.XzRA := LongIntP($fffffff0 and (integer(lXzP)+15)); //quad-word boundary} + {$ELSE} + l.XxRA := system.align(lXxP, 16); //data aligned to quad-word boundary + l.XyRA := system.align(lXyP, 16); //quad-word boundary + l.XzRA := system.align(lXzP, 16); //quad-word boundary + {$ENDIF} + for lX := 1 to l.OutDim do begin + l.XxRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[1,1]* (1 shl kSh) )+kUgly1; + l.XyRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[2,1]* (1 shl kSh) )+kUgly1; + l.XzRA^[lX] := round((lX-l.OutPivot)*lMatrix.matrix[3,1]* (1 shl kSh) )+kUgly1; + end; + l.XPivotInU2 := l.XPivotIn-kUgly2; + l.YPivotInU2 := l.YPivotIn-kUgly2; + l.ZPivotInU2 := l.ZPivotIn-kUgly2; + + {$IFNDEF NoThreads} + lnThreads := gnCPUThreads; + {$ELSE} + lnThreads := 1; + {$ENDIF} + //if lIsBG then + //TextForm.Memo1.Lines.Add( 'bg'+(inttostr(RenderForm.ThreadsRunning)+' '+inttostr(lnThreads))) + + //else + //TextForm.Memo1.Lines.Add( 'xx'+(inttostr(RenderForm.ThreadsRunning)+' '+inttostr(lnThreads))); + lZ := l.ZDimStart; + lZo := l.ZDimEnd; + lZinc := (l.ZDimEnd - l.ZDimStart) div lnThreads; + l.ZDimEnd := l.ZDimStart + lZinc; + //showmessage( inttostr(l.ZDimStart)+'..'+inttostr(l.ZDimEnd) +' '+inttostr(lZo)); + if l.ZDimEnd > ImgForm.ProgressBar1.Min then begin //crashes if max < min, so write order important... + ImgForm.ProgressBar1.Max := l.ZDimEnd+1; + ImgForm.ProgressBar1.Min := l.ZDimStart; + end else begin + ImgForm.ProgressBar1.Min := l.ZDimStart; + ImgForm.ProgressBar1.Max := l.ZDimEnd+1; + + end; +{$IFNDEF NoThreads} + Application.processmessages; + for lX := 1 to lnThreads do begin + if lX = lnThreads then + l.ZDimEnd := lZo; //avoid integer rounding error + //TextForm.Memo1.Lines.Add('+'+inttostr(lX)); + if (lBilinearSmooth) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + TTriRender.Create(ImgForm.ProgressBar1,lX,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut) + else + TNNRender.Create(ImgForm.ProgressBar1,lX,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut); + inc(ThreadsRunning); + l.ZDimStart := l.ZDimEnd + 1; + l.ZDimEnd := l.ZDimEnd + lZInc; + + end; //for each thread + l.ZDimStart := lZ; + + repeat + Application.processmessages; + until ThreadsRunning = 0; + Application.processmessages; +{$ELSE}//not threaded + l.ZDimEnd := lZo; //avoid integer rounding error + if (lBilinearSmooth) and (lHdr.NIFTIhdr.intent_code <> kNIFTI_INTENT_LABEL) then + TriRotate(ImgForm.ProgressBar1,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut) + else + NNRotate(ImgForm.ProgressBar1,l,lMatrix, lRenderCutout, lBuffIn,lBuffOut); +{$ENDIF} + + + FreeMem(lXxp); + FreeMem(lXyp); + FreeMem(lXzp); + if (lRenderCutout) then begin + FreeMem(lBuffIn); + end; + ImgForm.ProgressBar1.Position := l.ZDimStart; + ImgForm.StatusLabel.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); +end; //proceudre VolumeRotate; + +end. diff --git a/rendernothreads.pas b/rendernothreads.pas new file mode 100755 index 0000000..24c4844 --- /dev/null +++ b/rendernothreads.pas @@ -0,0 +1,301 @@ +unit rendernothreads; +interface +{$include isthreaded.inc} +{$mode objfpc}{$H+} + +uses +{$IFDEF SHOWPROG}Forms,{$ENDIF} + ComCtrls,Classes, SysUtils, define_types,GraphicsMathLibrary; +const + kSh = 10; //bits to shift - precision for integers to simulate floats + type + TRotateVals = record + InSliceSz,ZDimStart,ZDimEnd,YDimStart,YDimEnd,OutPivot,OutDim,OutSliceSz: integer; + XPivotInU2,YDimIN,YPivotInU2,ZDimIN,ZPivotInU2,XDimIN: integer; + XPivotIn,YPivotIn,ZPivotIn: integer; + Xxra,Xyra,Xzra: longintp; + //RenderCutout: boolean; + end; +procedure NNRotate (lBar: TProgressBar; l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +procedure TriRotate (lBar: TProgressBar; l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); + +implementation + +{$IFDEF SHOWPROG} +procedure VisualProg(lBar: TProgressBar; lPos: Integer); +begin + lBar.Position := lPos; + Application.ProcessMessages; +end; + +{$ENDIF}//IFDEF SHOWPROG + + +procedure FindXBounds (var lXMax,lXMin: integer; +lXDimIN,lYxiZxi,lXPivotInU2,lYDimIN,lYyiZyi,lYPivotInU2,lZDimIN,lYziZzi,lZPivotInU2,lOutDim:integer; + lXxra,lXyra,lXzra : LongIntP); +var + lXo,lYo,lZo,Xo_at_one,Xo_at_two,Xo_grad,Xo_offs,lShiftedOne : integer; + when_it_is_zero, when_it_is_max: double; + lReallySmall {, debugx0, debugx1, debugy0, debugy1, debugz0, debugz1}: double; + l2: integer; +begin + lXMax := lOutDim; + lXMin := 1; + l2 := 2; + lShiftedOne := 1 shl ksh; + lReallySmall := 1e-6; + Xo_at_one := lXxRA^[1] +lYxiZxi + (lXPivotInU2 shl kSh); + Xo_at_two := lXxRA^[l2] +lYxiZxi + (lXPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lXDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugx0 := when_it_is_zero; debugx1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + Xo_at_one := lXyRA^[1] +lYyiZyi + (lYPivotInU2 shl kSh); + Xo_at_two := lXyRA^[l2] +lYyiZyi + (lYPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lYDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugy0 := when_it_is_zero; debugy1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + Xo_at_one := lXzRA^[1] +lYziZzi + (lZPivotInU2 shl kSh); + Xo_at_two := lXzRA^[l2] +lYziZzi + (lZPivotInU2 shl kSh); + Xo_grad := Xo_at_two - Xo_at_one; Xo_offs := Xo_at_one - Xo_grad; + if Abs(Xo_grad) > lReallySmall then begin + when_it_is_zero := (lShiftedOne-Xo_offs) / Xo_grad; + when_it_is_max := ((lZDimIn shl kSh)-Xo_offs) / Xo_grad; + //debugz0 := when_it_is_zero; debugz1 := when_it_is_max; + if (when_it_is_zero < when_it_is_max) then begin + if when_it_is_zero > lXMin then lXMin := Round(when_it_is_zero+0.5); + if when_it_is_max < lXMax then lXMax := Round(when_it_is_max-0.5); + end else begin + if when_it_is_max > lXMin then lXMin := Round(when_it_is_max+0.5); + if when_it_is_zero < lXMax then lXMax := Round(when_it_is_zero-0.5); + end; + end; + // even with all the care about rounding, it's possible that we've got the + // edges wrong in ultra-high-gradient cases + if lXMin < lXMax then begin + while true do begin + lXo := ((lXxRA^[lXMin] +lYxiZxi) shr kSh)+lXPivotInU2; + lYo := ((lXyRA^[lXMin] +lYyiZyi) shr kSh)+lYPivotInU2; + lZo := ((lXzRA^[lXMin] +lYziZzi) shr kSh)+lZPivotInU2; + if (lXMin < lXMax) and ((lXo<1) or (lXo>lXDimIn) or (lYo<1) or (lYo>lYDimIn) or (lZo<1) or (lZo>lZDimIn)) then begin + lXMin := 1+lXMin; + end else + break; + end; + while true do begin + lXo := ((lXxRA^[lXMax] +lYxiZxi) shr kSh)+lXPivotInU2; + lYo := ((lXyRA^[lXMax] +lYyiZyi) shr kSh)+lYPivotInU2; + lZo := ((lXzRA^[lXMax] +lYziZzi) shr kSh)+lZPivotInU2; + if (lXMax > lXMin) and ((lXo<1) or (lXo>lXDimIn) or (lYo<1) or (lYo>lYDimIn) or (lZo<1) or (lZo>lZDimIn)) then begin + lXMax := lXMax-1; + end else + break; + end; + end; +end;//proc findXBounds + +procedure NNRotate (lBar: TProgressBar; l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +const kshx = ksh shr 1; +var + + lZxi,lZyi,lZzi,lYxiZxi,lYyiZyi,lYziZzi,lZ,lY,lX,lOutPos, + lMaxX,lMinX,lXo,lYo,lZo: integer; +begin + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := round(lZ*lM.matrix[1,3]* (1 shl kSh) ); + lZyi := round(lZ*lM.matrix[2,3]* (1 shl kSh) ); + lZzi := round(lZ*lM.matrix[3,3]* (1 shl kSh) ); + {$IFDEF SHOWPROG} //flicker with lazarus + if ((lZ mod 30)=0) then + VisualProg(lBar,lZ); + {$ENDIF} + //ImgForm.ProgressBar1.Position := lZ; + for lY := l.YDimStart to l.YDimEnd do begin + lYxiZxi := round(lY * lM.matrix[1,2]* (1 shl kSh) )+lZxi; + lYyiZyi := round(lY * lM.matrix[2,2]* (1 shl kSh) )+lZyi; + lYziZzi := round(lY * lM.matrix[3,2]* (1 shl kSh) )+lZzi; + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + //if gAbortRender > 0 then goto 345; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXo := ((l.XxRA^[lX] +lYxiZxi) shr kSh)+l.XPivotInU2; + lYo := ((l.XyRA^[lX] +lYyiZyi) shr kSh)+l.YPivotInU2; + lZo := ((l.XzRA^[lX] +lYziZzi) shr kSh)+l.ZPivotInU2; + {lXo := (lXo shr 1) + 1; + lYo := lYo shr 1; + lZo := lZo shr 1;} + lBuffOut[lX+lOutPos] := lBuffIn[(lXo)+((lYo-1)*l.XdimIn)+((lZo-1)*l.InSliceSz)] + end; + end; //for y + end; //for z +end; + +procedure TriRotate (lBar: TProgressBar; l: TRotateVals; var lM: TMatrix; lRenderCutout: boolean; var lBuffIn,lBuffOut: ByteP); +//Trilinear - this uses integer math, and on CoreDuo CPUs is 30% faster than Floating Point +//For precision, integers are multiplied by kSh (~2^10 bits) to simulate floats +// However, we will use 32-bit integers and the image intensity is 8 bit values, +// with the final interpolation multiplying X*Y*Z*intensity +// Therefore, this final interpolation adjusts kSh to be 2^8, avoiding overflow +var + lMi: TMatrixi; + lXr,lYr,lZr,lYxi,lYyi,lYzi,lXxi,lXyi,lXzi,lZxi,lZyi,lZzi, + lYxiZxi,lYyiZyi,lYziZzi,lZ,lY,lX,lOutPos, + lXPiv,lYPiv,lZPiv,lXrM1i,lYrM1i,lZrM1i, + lShr,lShl,lShlTo8,lShl8, + lMinZ,lMaxZ,lMinY,lMaxY,lMaxX,lMinX,lXo,lYo,lZo: integer; +begin + lShl := 1 shl kSh; + lShl8 := 1 shl 8; //8bit precision + lShlTo8 := (kSh - 8); //shr the kSh precision by this to get 8-bit precision + lShr := 24;//24-bits * 8 bit intensity = 32 bits + lXPiv := l.XPivotIn * lShl; + lYPiv := l.YPivotIn * lShl; + lZPiv := l.ZPivotIn * lShl; + for lX := 1 to 3 do + for lY := 1 to 3 do + lMi.matrix[lX,lY] := round(lM.matrix[lX,lY] * lShl); + if (lRenderCutout ) then begin //only separated to unroll IF rendercutout + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := (lZ*lMi.matrix[1,3] ); + lZyi := (lZ*lMi.matrix[2,3] ); + lZzi := (lZ*lMi.matrix[3,3] ); + {$IFDEF SHOWPROG} //flicker with lazarus + if ((lZ mod 30)=0) then + VisualProg(lBar,lZ); + {$ENDIF} + for lY := l.YDimStart to l.YDimEnd do begin + lYxi := lY * lMi.matrix[1,2]; + lYyi := lY * lMi.matrix[2,2]; + lYzi := lY * lMi.matrix[3,2]; + lYxiZxi := (lY * lMi.matrix[1,2] )+lZxi; + lYyiZyi := (lY * lMi.matrix[2,2] )+lZyi; + lYziZzi := (lY * lMi.matrix[3,2] )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXr := ( (lX*lMi.matrix[1,1])+lYxi+lZxi)+lXPiv; + lYr := ((lX*lMi.matrix[2,1])+lYyi+lZyi)+lYPiv; + lZr := ( (lX*lMi.matrix[3,1])+lYzi+lZzi)+lZPiv; + lXo := (lXr shr kSh); + lYo := (lYr shr kSh); + lZo := (lZr shr kSh); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXr := (lXr- (lXo * lShl)) shr lShlTo8; + lYr := (lYr- (lYo * lShl)) shr lShlTo8; + lZr := (lZr- (lZo * lShl)) shr lShlTo8; + lXrM1i := lShl8-lXr; + lYrM1i := lShl8-lYr; + lZrM1i := lShl8-lZr; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + if {(lRenderCutout ) and} ((lBuffIn^[lXo+lMinY+lMinZ]=255) or (lBuffIn^[lXo+1+lMinY+lMinZ]=255) + or (lBuffIn^[lXo+lMaxY+lMinZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMinZ]=255) + or (lBuffIn^[lXo+lMinY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMinY+lMaxZ]=255) + or (lBuffIn^[lXo+lMaxY+lMaxZ]=255) or (lBuffIn^[lXo+1+lMaxY+lMaxZ]=255)) + then lBuffOut^[lX+l.OutPivot+lOutPos] := 255 + else + lBuffOut^[lX+l.OutPivot+lOutPos] := ( + (lXrM1i*lYrM1i*lZrM1i *lBuffIn^[lXo+lMinY+lMinZ] ) + +(lXr*lYrM1i*lZrM1i *lBuffIn^[lXo+1+lMinY+lMinZ]) + +(lXrM1i*lYr*lZrM1i *lBuffIn^[lXo+lMaxY+lMinZ] ) + +(lXrM1i*lYrM1i*lZr *lBuffIn^[lXo+lMinY+lMaxZ] ) + +(lXr*lYr*lZrM1i *lBuffIn^[lXo+1+lMaxY+lMinZ] ) + +(lXr*lYrM1i*lZr *lBuffIn^[lXo+1+lMinY+lMaxZ] ) + +(lXrM1i*lYr*lZr *lBuffIn^[lXo+lMaxY+lMaxZ]) + +(lXr*lYr*lZr *lBuffIn^[lXo+1+lMaxY+lMaxZ] ) + ) shr lShr; + end; //values in range + end; //for x + end; //for y + end; //for z + exit; + end; //if RenderCutout + for lZ := l.ZDimStart to l.ZDimEnd do begin + lZxi := (lZ*lMi.matrix[1,3] ); + lZyi := (lZ*lMi.matrix[2,3] ); + lZzi := (lZ*lMi.matrix[3,3] ); + {$IFDEF SHOWPROG} //flicker with lazarus + if ((lZ mod 30)=0) then + VisualProg(lBar,lZ); + {$ENDIF} + for lY := l.YDimStart to l.YDimEnd do begin + lYxi := lY * lMi.matrix[1,2]; + lYyi := lY * lMi.matrix[2,2]; + lYzi := lY * lMi.matrix[3,2]; + lYxiZxi := (lY * lMi.matrix[1,2] )+lZxi; + lYyiZyi := (lY * lMi.matrix[2,2] )+lZyi; + lYziZzi := (lY * lMi.matrix[3,2] )+lZzi; + FindXBounds (lMaxX,lMinX,l.XDimIN,lYxiZxi,l.XPivotInU2,l.YDimIN,lYyiZyi,l.YPivotInU2,l.ZDimIN,lYziZzi,l.ZPivotInU2,l.OutDim,l.Xxra,l.Xyra,l.Xzra); + lMaxX := lMaxX - l.OutPivot -1 ; + lMinX := lMinX - l.OutPivot+1; + if lMaxX > lMinX then + for lX := lMinX to lMaxX do begin + lXr := ( (lX*lMi.matrix[1,1])+lYxi+lZxi)+lXPiv; + lYr := ((lX*lMi.matrix[2,1])+lYyi+lZyi)+lYPiv; + lZr := ( (lX*lMi.matrix[3,1])+lYzi+lZzi)+lZPiv; + lXo := (lXr shr kSh); + lYo := (lYr shr kSh); + lZo := (lZr shr kSh); + if (lXo > 0) and (lXo < l.XDimIn) + and (lYo > 0) and (lYo < l.YDimIn) and + (lZo > 0) and (lZo < l.ZDimIn) then begin + lXr := (lXr- (lXo * lShl)) shr lShlTo8; + lYr := (lYr- (lYo * lShl)) shr lShlTo8; + lZr := (lZr- (lZo * lShl)) shr lShlTo8; + lXrM1i := lShl8-lXr; + lYrM1i := lShl8-lYr; + lZrM1i := lShl8-lZr; + lMinY := ((lYo-1)*l.XdimIn); + lMinZ := ((lZo-1)*l.InSliceSz); + lMaxY := ((lYo)*l.XdimIn); + lMaxZ := ((lZo)*l.InSliceSz); + lOutPos := ((lZ+l.OutPivot-1)*l.OutSliceSz)+((lY+l.OutPivot-1)*l.Outdim); + lBuffOut^[lX+l.OutPivot+lOutPos] :=( + (lXrM1i*lYrM1i*lZrM1i *lBuffIn^[lXo+lMinY+lMinZ] ) + +(lXr*lYrM1i*lZrM1i *lBuffIn^[lXo+1+lMinY+lMinZ]) + +(lXrM1i*lYr*lZrM1i *lBuffIn^[lXo+lMaxY+lMinZ] ) + +(lXrM1i*lYrM1i*lZr *lBuffIn^[lXo+lMinY+lMaxZ] ) + +(lXr*lYr*lZrM1i *lBuffIn^[lXo+1+lMaxY+lMinZ] ) + +(lXr*lYrM1i*lZr *lBuffIn^[lXo+1+lMinY+lMaxZ] ) + +(lXrM1i*lYr*lZr *lBuffIn^[lXo+lMaxY+lMaxZ]) + +(lXr*lYr*lZr *lBuffIn^[lXo+1+lMaxY+lMaxZ] ) + ) shr lShr; + end; //values in range + end; //for x + end; //for y + end; //for z +end; + + +end. + diff --git a/reorient.dfm b/reorient.dfm new file mode 100755 index 0000000..7ae2227 Binary files /dev/null and b/reorient.dfm differ diff --git a/reorient.pas b/reorient.pas new file mode 100755 index 0000000..5b33b0f --- /dev/null +++ b/reorient.pas @@ -0,0 +1,121 @@ +unit reorient; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, RXSpin,nifti_hdr,graphicsMathLibrary, ExtCtrls; + +type + TReorientForm = class(TForm) + ZEdit: TRxSpinEdit; + YEdit: TRxSpinEdit; + XEdit: TRxSpinEdit; + ReorientTimer: TTimer; + PitchEdit: TRxSpinEdit; + RollEdit: TRxSpinEdit; + YawEdit: TRxSpinEdit; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + Label5: TLabel; + Label6: TLabel; + Xlabel: TLabel; + YLabel: TLabel; + ZLabel: TLabel; + procedure ReorientTimerTimer(Sender: TObject); + procedure EditChange(Sender: TObject); + private + { Private declarations } + public + procedure ApplyTransform ( var lHdr: TMRIcroHdr); + + { Public declarations } + end; + +var + ReorientForm: TReorientForm; + +implementation + +uses nifti_img_view,nifti_img, nifti_hdr_view; + +{$R *.DFM} + +procedure TReorientForm.ApplyTransform ( var lHdr: TMRIcroHdr); +var + lM,lRot: TMatrix; +begin + //exit; + if (XEdit.value = 0) and (YEdit.value = 0) and (ZEdit.value = 0) + and (PitchEdit.value = 0) and (YawEdit.value = 0) and (RollEdit.value = 0) then exit; + lRot := Matrix3D (1,0,0,XEdit.value, + 0,1,0,YEdit.value, + 0,0,1,ZEdit.value, + 0,0,0,1); + lM := Matrix3D ( + lHdr.NIFTIhdr.srow_x[0],lHdr.NIFTIhdr.srow_x[1],lHdr.NIFTIhdr.srow_x[2],lHdr.NIFTIhdr.srow_x[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_y[0],lHdr.NIFTIhdr.srow_y[1],lHdr.NIFTIhdr.srow_y[2],lHdr.NIFTIhdr.srow_y[3], // 3D "graphics" matrix + lHdr.NIFTIhdr.srow_z[0],lHdr.NIFTIhdr.srow_z[1],lHdr.NIFTIhdr.srow_z[2],lHdr.NIFTIhdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); + if PitchEdit.value <> 0 then RotatePitch(PitchEdit.value{-11.4592},lRot); + if RollEdit.value <> 0 then RotateRoll(RollEdit.value,lRot); + if YawEdit.value <> 0 then RotateYaw(YawEdit.value,lRot); + //lM := lRot; + lM := MultiplyMatrices(lRot,lM); + +(* WriteNiftiMatrix (lHdr.NiftiHdr, + lM.matrix[1,1],lM.matrix[1,2],lM.matrix[1,3],lM.matrix[1,4], + lM.matrix[2,1],lM.matrix[2,2],lM.matrix[1,3],lM.matrix[2,4], + lM.matrix[3,1],lM.matrix[3,2],lM.matrix[1,3],lM.matrix[3,4]); + + lHdr.Mat := lM; *) + //Caption := inttostr(random(888))+floattostr(lM.matrix[1,4]); + XLabel.caption:= floattostr(lM.matrix[1,1])+'x'+floattostr(lM.matrix[1,2])+'x'+floattostr(lM.matrix[1,3])+'x'+floattostr(lM.matrix[1,4]); + YLabel.caption:= floattostr(lM.matrix[2,1])+'x'+floattostr(lM.matrix[2,2])+'x'+floattostr(lM.matrix[2,3])+'x'+floattostr(lM.matrix[2,4]); + ZLabel.caption:= floattostr(lM.matrix[3,1])+'x'+floattostr(lM.matrix[3,2])+'x'+floattostr(lM.matrix[3,3])+'x'+floattostr(lM.matrix[3,4]); +end; +(*procedure DrawLine(lIMage: TImage; lXmm,lYmm,lZmm,lXmm2,lYmm2,lZmm2: integer); +var + lX,lY,lZ: integer; +begin + lImage.Canvas.Pen.Color:=gBGImg.XBarClr; + lImage.Canvas.Pen.Width := gBGImg.XBarThick; + MMToImgCoord( lX,lY,lZ, lXmm,lYmm,lZmm); + lImage.Canvas.MoveTo(lX,lY); + MMToImgCoord( lX,lY,lZ, lXmm2,lYmm2,lZmm2); + lImage.Canvas.LineTo(lX,lY); +end;*) + +procedure TReorientForm.ReorientTimerTimer(Sender: TObject); +begin + ReorientTimer.enabled := false; + //ImgForm.CloseOverlayImgClick(nil); + + (*DrawLine(ImgForm.PGImage2,0,-104,0,0,72,0);//horizontal line on Sag + DrawLine(ImgForm.PGImage2,0,0,78,0,0,-48);//horizontal line on Sag + DrawLine(ImgForm.PGImage3,0,0,77,0,0,-48);//horizontal line on Sag + DrawLine(ImgForm.PGImage3,-64,0,0,64,0,0);//horizontal line on Sag + *) + ApplyTransform(gMRIcroOverlay[kBGOverlayNum]); + //MMToImgCoord(var lX,lY,lZ: integer; var lXmm,lYmm,lZmm: single); +end; + +(*procedure TReorientForm.ReorientTimerTimer(Sender: TObject); +var + lFilename: string; +begin + ReorientTimer.enabled := false; + ImgForm.CloseOverlayImgClick(nil); + ReorientTimer.enabled := false; + lFilename := 'C:\pas\Delphi\niftiview\grey.voi'; + ImgForm.LoadOverlay (lFilename); +end; *) + +procedure TReorientForm.EditChange(Sender: TObject); +begin + ReorientTimer.enabled := true; +end; + +end. diff --git a/reslice_fsl.pas b/reslice_fsl.pas new file mode 100755 index 0000000..7700c8e --- /dev/null +++ b/reslice_fsl.pas @@ -0,0 +1,201 @@ +unit reslice_fsl; +{$H+} +interface +uses + nifti_hdr,define_types,metagraph,sysutils; + +function ResliceImg (lTargetImgName,lSrcImgName,lSrc2TargetMatName,lOutputName: string): boolean; +procedure ResliceFSL; + +implementation + +uses nifti_img_view,dialogs,nifti_img,text,graphx,math,nifti_hdr_view,GraphicsMathLibrary,classes; + +procedure ResliceFSL; +label + 666; +var + lInc,lNumberofFiles: integer; + lSrc2TargetMatName,lSrcImgName,lTargetImgName,lOutputName:string; + lStrings : TStringList; +begin + ImgForm.CloseImagesClick(nil); + if not OpenDialogExecute(kImgFilter,'Select source image[s]',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + lStrings := TStringList.Create; + lStrings.AddStrings(HdrForm.OpenHdrDlg.Files); + if not OpenDialogExecute('FSL (*.mat)|*.mat','Select FSL source-to-target matrix',false) then goto 666; + lSrc2TargetMatName := HdrForm.OpenHdrDlg.Filename; + if not OpenDialogExecute(kImgFilter,'Select target image (source image will be warped to this)',false) then goto 666; + lTargetImgName := HdrForm.OpenHdrDlg.Filename; + + TextForm.MemoT.Lines.Clear; + for lInc:= 1 to lNumberofFiles do begin + lSrcImgName := lStrings[lInc-1]; + lOutputName := ChangeFilePrefix (lSrcImgName,'w'); + TextForm.MemoT.Lines.Add(' Source->Matrix->Target '+lSrcImgName+'->'+ lSrc2TargetMatName+'->'+lTargetImgName); + ResliceImg (lTargetImgName,lSrcImgName,lSrc2TargetMatName,lOutputName); + end;//lLoop + TextForm.Show; + 666: + lStrings.free; +end; + +function ReadFSLMat (var lMat: TMatrix; lSrc2TargetMatName: string):boolean; +var + lF: TextFile; + xx,xy,xz,xo + ,yx,yy,yz,yo + ,zx,zy,zz,zo: double; +begin + result := false; + if not fileexists(lSrc2TargetMatName) then exit; + Assign(lF,lSrc2TargetMatName); + Filemode := 0; + Reset(lF); + readln(lF,xx,xy,xz,xo,yx,yy,yz,yo,zx,zy,zz,zo); + //read all with one readln - + // separate readlns only work for native eoln + CloseFile(lF); + lMat:= Matrix3D (xx,xy,xz,xo + ,yx,yy,yz,yo + ,zx,zy,zz,zo + ,0,0,0,1); + result := true; + Filemode := 2; +end; + +function Rx (var lDestHdr,lSrcHdr: TMRIcroHdr; var lInMat: TMatrix; var lOutputName: string):boolean; +var + lPos,lXYs,lXYZs,lXs,lYs,lZs,lXi,lYi,lZi,lX,lY,lZ, + lXo,lYo,lZo,lMinY,lMinZ,lMaxY,lMaxZ: integer; + lXrM1,lYrM1,lZrM1, + lXreal,lYreal,lZreal: double; + lOutImg: bytep; + lScale,lMat: TMatrix; +begin + result := false; + lXs := lSrcHdr.NIFTIhdr.Dim[1]; + lYs := lSrcHdr.NIFTIhdr.Dim[2]; + lZs := lSrcHdr.NIFTIhdr.Dim[3]; + if (gMRIcroOverlay[kBGOverlayNum].ScrnBufferItems <> lXs*lYs*lZs) then begin + showmessage('Reslice error: background image not loaded.'); + exit; + end; + lXYs:=lXs*lYs; //slicesz + lXYZs := lXYs*lZs; + lX := lDestHdr.NIFTIhdr.Dim[1]; + lY := lDestHdr.NIFTIhdr.Dim[2]; + lZ := lDestHdr.NIFTIhdr.Dim[3]; + //TextForm.Memo1.Lines.Add(inttostr(lXs)+'x'+inttostr(lYs)+'x'+inttostr(lZs)+'->'+inttostr(lX)+'x'+inttostr(lY)+'x'+inttostr(lZ)); + lDestHdr.NIFTIhdr.Dim[4] := 1; + getmem(lOutImg, lX*lY*lZ*sizeof(byte)); + lPos := 0; + //http://eeg.sourceforge.net/MJenkinson_coordtransforms.pdf + //FLIRT transforms are in world coordinates [mm] + //to convert to a vxl-vxl transform, the matrix must be + //PRE-multiplied by inv(Dest) and POST-multiplied by Src + //where Dest and Src are the spatial dimensions in mm +lScale:= Matrix3D (abs(lSrcHdr.NIFTIhdr.pixdim[1]),0,0,0 + ,0,abs(lSrcHdr.NIFTIhdr.pixdim[2]),0,0 + ,0,0,abs(lSrcHdr.NIFTIhdr.pixdim[3]),0 + ,0,0,0,1); + lScale := InvertMatrix3D(lScale); + lMat := MultiplyMatrices(lScale,lInMat); + lScale:= Matrix3D (abs(lDestHdr.NIFTIhdr.pixdim[1]),0,0,0 + ,0,abs(lDestHdr.NIFTIhdr.pixdim[2]),0,0 + ,0,0,abs(lDestHdr.NIFTIhdr.pixdim[3]),0 + ,0,0,0,1); + lMat := MultiplyMatrices(lMat,lScale); + for lZi := 0 to (lZ-1) do begin + for lYi := 0 to (lY-1) do begin + for lXi := 0 to (lX-1) do begin + inc(lPos); + lOutImg^[lPos] := 0; + lXreal := (lXi*lMat.matrix[1][1]+lYi*lMat.matrix[1][2]+lZi*lMat.matrix[1][3]+lMat.matrix[1][4]); + lYreal := (lXi*lMat.matrix[2][1]+lYi*lMat.matrix[2][2]+lZi*lMat.matrix[2][3]+lMat.matrix[2][4]); + lZreal := (lXi*lMat.matrix[3][1]+lYi*lMat.matrix[3][2]+lZi*lMat.matrix[3][3]+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXreal >= 0) and (lYreal >= 1) and (lZreal >= 1) and + (lXreal < (lXs -1)) and (lYreal < (lYs -1) ) and (lZreal < (lZs -1)) + then begin + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := ((lYo)*lXs); + lMinZ := ((lZo)*lXYs); + lMaxY := ((lYo+1)*lXs); + lMaxZ := ((lZo+1)*lXYs); + inc(lXo);//images incremented from 1 not 0 + {if lMax <(lXreal) then + lMax := lXreal; + if lMin >(lXreal) then + lMin := lXreal; } + lOutImg^[lPos] := + round ( + {all min} ( (lXrM1*lYrM1*lZrM1)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*gMRIcroOverlay[kBGOverlayNum].ScrnBuffer^[lXo+1+lMaxY+lMaxZ]) ); + end; + end;//z + end;//y + end;//z + deletefile(lOutputName); + SaveAsVOIorNIFTIcore (lOutputName,lOutImg, lX*lY*lZ, 1,1,lDestHdr.NIFTIhdr); + lPos := 1; + while (lPos <= (lX*lY*lZ)) and (lOutImg^[lPos] = 0) do + inc(lPos); + if lPos > (lX*lY*lZ) then + result := false + else + result := true; + freemem(lOutImg); +end; + +function ResliceImg (lTargetImgName,lSrcImgName,lSrc2TargetMatName,lOutputName: string): boolean; +label + 666; +var + lReslice,lOrtho : boolean; + lDestHdr,lSrcHdr: TMRIcroHdr; + lMat: TMatrix; +begin + result := false; + if not fileexists(lTargetImgName) then exit; + if not fileexists(lSrcImgName) then exit; + if not fileexists(lSrc2TargetMatName) then exit; + if not ReadFSLMat(lMat,lSrc2TargetMatName) then exit; + ImgForm.CloseImagesClick(nil); + lReslice := gBGImg.ResliceOnLoad; + lOrtho := gBGImg.OrthoReslice; + gBGImg.OrthoReslice := false; + gBGImg.ResliceOnLoad := false; + //if not HdrForm.OpenAndDisplayHdr(lTargetImgName,lDestHdr) then goto 666; + if not NIFTIhdr_LoadHdr(lTargetImgName, lDestHdr) then goto 666; + if not NIFTIhdr_LoadHdr(lSrcImgName, lSrcHdr) then goto 666; + ImgForm.OpenAndDisplayImg(lSrcImgName,True); + if not Rx(lDestHdr,lSrcHdr,lMat,lOutputName) then goto 666; + result := true; +666: + if not result then + showmessage('Error applying transform '+lSrcImgName+'->'+lTargetImgName+' using '+lSrc2TargetMatName); + gBGImg.ResliceOnLoad := lReslice; + gBGImg.OrthoReslice := lOrtho; +end; + + +end. + diff --git a/reslice_img.pas b/reslice_img.pas new file mode 100755 index 0000000..41e01f5 --- /dev/null +++ b/reslice_img.pas @@ -0,0 +1,544 @@ +unit reslice_img; +//12 April 2009 - added lTrilinearSmooth option to allow nearest neighbor interpolation +interface +uses +{$ifndef fpc}{windows,} {$endif} +GraphicsMathLibrary,nifti_hdr, nifti_types; +function Reslice_Img_To_Unaligned (var lTargHdr: TNIfTIhdr; var lSrcHdr: TMRIcroHdr; lTrilinearSmoothIn: boolean): boolean; +function Hdr2InvMat (lHdr: TNiftiHdr; var lOK: boolean): TMatrix; +procedure Voxel2mm(var X,Y,Z: single; var lHdr: TNIfTIHdr); +procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +implementation + + + +uses dialogs, define_types, SysUtils; + + +function Hdr2Mat (lHdr: TNIFTIhdr): TMatrix; +begin + Result := Matrix3D ( + lHdr.srow_x[0],lHdr.srow_x[1],lHdr.srow_x[2],lHdr.srow_x[3], // 3D "graphics" matrix + lHdr.srow_y[0],lHdr.srow_y[1],lHdr.srow_y[2],lHdr.srow_y[3], // 3D "graphics" matrix + lHdr.srow_z[0],lHdr.srow_z[1],lHdr.srow_z[2],lHdr.srow_z[3], // 3D "graphics" matrix + 0,0,0,1); +end; + +(*procedure ReportMatrix (lM:TMatrix); +const + kCR = chr (13); +begin + showmessage(RealToStr(lM.matrix[1,1],6)+','+RealToStr(lM.matrix[1,2],6)+','+RealToStr(lM.matrix[1,3],6)+','+RealToStr(lM.matrix[1,4],6)+kCR+ + RealToStr(lM.matrix[2,1],6)+','+RealToStr(lM.matrix[2,2],6)+','+RealToStr(lM.matrix[2,3],6)+','+RealToStr(lM.matrix[2,4],6)+kCR+ + RealToStr(lM.matrix[3,1],6)+','+RealToStr(lM.matrix[3,2],6)+','+RealToStr(lM.matrix[3,3],6)+','+RealToStr(lM.matrix[3,4],6)+kCR + +RealToStr(lM.matrix[4,1],6)+','+RealToStr(lM.matrix[4,2],6)+','+RealToStr(lM.matrix[4,3],6)+','+RealToStr(lM.matrix[4,4],6) + ); +end; *) + +(* +procedure SPMmat(var lDestMat: TMatrix); +//SPM matrices are indexed from 1 +//This function is only useful for direct comparisons with SPM +var + lTemp,lVS: TMatrix; +begin + lVS := Matrix3D (1,0,0,-1, + 0,1,0,-1, + 0,0,1,-1, 0,0,0,1);//VoxelShift + lTemp := lDestMat; + lDestMat := MultiplyMatrices(lTemp,lVS); +end;*) + +procedure Coord(var lV: TVector; var lMat: TMatrix); +//transform X Y Z by matrix +var + lXi,lYi,lZi: single; +begin + lXi := lV.x; lYi := lV.y; lZi := lV.z; + lV.x := (lXi*lMat.matrix[1][1]+lYi*lMat.matrix[1][2]+lZi*lMat.matrix[1][3]+lMat.matrix[1][4]); + lV.y := (lXi*lMat.matrix[2][1]+lYi*lMat.matrix[2][2]+lZi*lMat.matrix[2][3]+lMat.matrix[2][4]); + lV.z := (lXi*lMat.matrix[3][1]+lYi*lMat.matrix[3][2]+lZi*lMat.matrix[3][3]+lMat.matrix[3][4]); +end; + +procedure Transposemat(var lMat: TMatrix); +var + lTemp: TMatrix; + i,j: integer; +begin + lTemp := lMat; + for i := 1 to lMat.size do + for j := 1 to lMat.size do + lMat.matrix[i,j] := lTemp.matrix[j,i]; +end; + +function gaussj(VAR a: TMatrix): boolean;//Invert a Matrix - see Numerical Recipes +label + 666; +VAR + big,dum,pivinv: real; + n,i,icol,irow,j,k,l,ll: integer; + indxc,indxr,ipiv: array [1..4] of integer; +BEGIN + result := true; + icol := 1;//not used - avoids compiler warning + irow := 1;//not used - avoids compiler warning + n := a.size; + FOR j := 1 TO n DO BEGIN + ipiv[j] := 0 + END; + FOR i := 1 TO n DO BEGIN + big := 0.0; + FOR j := 1 TO n DO BEGIN + IF (ipiv[j] <> 1) THEN BEGIN + FOR k := 1 TO n DO BEGIN + IF (ipiv[k] = 0) THEN BEGIN + IF (abs(a.matrix[j,k]) >= big) THEN BEGIN + big := abs(a.matrix[j,k]); + irow := j; + icol := k + END + END ELSE IF (ipiv[k] > 1) THEN BEGIN + goto 666; + END + END + END + END; + ipiv[icol] := ipiv[icol]+1; + IF (irow <> icol) THEN BEGIN + FOR l := 1 TO n DO BEGIN + dum := a.matrix[irow,l]; + a.matrix[irow,l] := a.matrix[icol,l]; + a.matrix[icol,l] := dum + END; + END; + indxr[i] := irow; + indxc[i] := icol; + IF (a.matrix[icol,icol] = 0.0) THEN + goto 666; + pivinv := 1.0/a.matrix[icol,icol]; + a.matrix[icol,icol] := 1.0; + FOR l := 1 TO n DO BEGIN + a.matrix[icol,l] := a.matrix[icol,l]*pivinv + END; + FOR ll := 1 TO n DO BEGIN + IF (ll <> icol) THEN BEGIN + dum := a.matrix[ll,icol]; + a.matrix[ll,icol] := 0.0; + FOR l := 1 TO n DO BEGIN + a.matrix[ll,l] := a.matrix[ll,l]-a.matrix[icol,l]*dum + END; + END + END + END; + FOR l := n DOWNTO 1 DO BEGIN + IF (indxr[l] <> indxc[l]) THEN BEGIN + FOR k := 1 TO n DO BEGIN + dum := a.matrix[k,indxr[l]]; + a.matrix[k,indxr[l]] := a.matrix[k,indxc[l]]; + a.matrix[k,indxc[l]] := dum + END + END + END; + exit; + 666: //only get here if there is an error + Showmessage('error in reslice_img - singular matrix. Spatial orientation is ambiguous.'); + a := Eye3D; + result := false; +END; + +procedure SubVec (var lVx: TVector; lV0: TVector); +begin + lVx.x := lVx.x - lV0.x; + lVx.y := lVx.y - lV0.y; + lVx.z := lVx.z - lV0.z; +end; + +(*procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +//returns voxels indexed from 1 not 0! +var + lV: TVector; + lSrcMatInv,lSrcMat: TMatrix; +begin + lV := Vector3D (X,Y,Z); + lV := Transform (lV,lInvMat); + X := lV.x+1; + Y := lV.y+1; + Z := lV.z+1; +end;*) + +procedure mm2Voxel (var X,Y,Z: single; var lInvMat: TMatrix); +//returns voxels indexed from 1 not 0! +var + lV: TVector; + lSrcMatInv,lSrcMat: TMatrix; +begin + lV := Vector3D (X,Y,Z); + Coord (lV,lInvMat); + X := lV.x+1; + Y := lV.y+1; + Z := lV.z+1; +end; + +procedure Voxel2mm(var X,Y,Z: single; var lHdr: TNIfTIHdr); +var + lV: TVector; + lMat: TMatrix; +begin + //lV := Vector3D (X-1,Y-1,Z-1); + lV := Vector3D (X-1,Y-1,Z-1); + lMat := Hdr2Mat(lHdr); + Coord(lV,lMat); + X := lV.x; + Y := lV.y; + Z := lV.z; +end; + +function Voxel2Voxel (var lDestHdr,lSrcHdr: TNIFTIhdr): TMatrix; +//returns matrix for transforming voxels from one image to the other image +//results are in VOXELS not mm +var + lV0,lVx,lVy,lVz: TVector; + lDestMat,lSrcMatInv,lSrcMat: TMatrix; + +begin + //Step 1 - compute source coordinates in mm for 4 voxels + //the first vector is at 0,0,0, with the + //subsequent voxels being left, up or anterior + lDestMat := Hdr2Mat(lDestHdr); + //SPMmat(lDestMat); + lV0 := Vector3D (0,0,0); + lVx := Vector3D (1,0,0); + lVy := Vector3D (0,1,0); + lVz := Vector3D (0,0,1); + Coord(lV0,lDestMat); + Coord(lVx,lDestMat); + Coord(lVy,lDestMat); + Coord(lVz,lDestMat); + lSrcMat := Hdr2Mat(lSrcHdr); + //SPMmat(lSrcMat); + lSrcMatInv := lSrcMat; + gaussj(lSrcMatInv); + //the vectors should be rows not columns.... + //therefore we transpose the matrix + Transposemat(lSrcMatInv); + //the 'transform' multiplies the vector by the matrix + lV0 := Transform (lV0,lSrcMatInv); + lVx := Transform (lVx,lSrcMatInv); + lVy := Transform (lVy,lSrcMatInv); + lVz := Transform (lVz,lSrcMatInv); + //subtract each vector from the origin + // this reveals the voxel-space influence for each dimension + SubVec(lVx,lV0); + SubVec(lVy,lV0); + SubVec(lVz,lV0); + result := Matrix3D(lVx.x,lVy.x,lVz.x,lV0.x, + lVx.y,lVy.y,lVz.y,lV0.y, + lVx.z,lVy.z,lVz.z,lV0.z, 0,0,0,1); +end; + +procedure CopyHdrMat(var lTarg,lDest: TNIfTIHdr); +//destination has dimensions and rotations of destination +var + lI: integer; +begin + //destination will have dimensions of target + lDest.dim[0] := 3; //3D + for lI := 1 to 3 do + lDest.dim[lI] := lTarg.dim[lI]; + lDest.dim[4] := 1; //3D + //destination will have pixdim of target + for lI := 0 to 7 do + lDest.pixdim[lI] := lTarg.pixdim[lI]; + lDest.xyzt_units := lTarg.xyzt_units; //e.g. mm and sec + lDest.qform_code := lTarg.qform_code; + lDest.sform_code := lTarg.sform_code; + lDest.quatern_b := lTarg.quatern_b; + lDest.quatern_c := lTarg.quatern_c; + lDest.quatern_d := lTarg.quatern_d; + lDest.qoffset_x := lTarg.qoffset_x; + lDest.qoffset_y := lTarg.qoffset_y; + lDest.qoffset_z := lTarg.qoffset_z; + for lI := 0 to 3 do begin + lDest.srow_x[lI] := lTarg.srow_x[lI]; + lDest.srow_y[lI] := lTarg.srow_y[lI]; + lDest.srow_z[lI] := lTarg.srow_z[lI]; + end; +end; + +function OneToOne(lM:TMatrix): boolean; +var + lC,lR: integer; +begin + result := false; + for lC := 1 to 3 do + for lR := 1 to 3 do + if (lM.matrix[lC,lR] <> 0) and ((abs(lM.matrix[lC,lR])- 1) > 0.00001) then + exit; + result := true; +end; + + function Reslice_Img_To_Unaligned (var lTargHdr: TNIfTIhdr; var lSrcHdr: TMRIcroHdr; lTrilinearSmoothIn: boolean): boolean; +var + lXrM1,lYrM1,lZrM1,lZx,lZy,lZz,lYx,lYy,lYz,lXreal,lYreal,lZreal: single; + lXo,lYo,lZo,lMinY,lMaxY,lMinZ,lMaxZ, + lPos,lXs,lYs,lZs,lXYs,lXYZs,lX,lY,lZ,lOutVolItems, + lXi,lYi,lZi: integer; + lDestHdr: TNIFTIhdr; + lMat: TMatrix; + lTrilinearSmooth,lOverlap: boolean; + lXx,lXy,lXz: Singlep0; + l32fs,l32f : SingleP; + l16is,l16i : SmallIntP; + l8i,l8is,lSrcBuffer,lBuffUnaligned,lBuffAligned,lBuffOutUnaligned: bytep; +begin + lTrilinearSmooth := lTrilinearSmoothIn; + result := false; + lOverlap := false; + lDestHdr := lSrcHdr.NIfTIHdr; //destination has the comments and voxel BPP of source + CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + lXs := lSrcHdr.NIfTIHdr.Dim[1]; + lYs := lSrcHdr.NIfTIHdr.Dim[2]; + lZs := lSrcHdr.NIfTIHdr.Dim[3]; + + lXYs:=lXs*lYs; //slicesz + lXYZs := lXYs*lZs; + lX := lDestHdr.Dim[1]; + lY := lDestHdr.Dim[2]; + lZ := lDestHdr.Dim[3]; + lOutVolItems :=lX*lY*lZ; + if lSrcHdr.ImgBufferBPP = 4 then begin + l32fs := SingleP(lSrcHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(single))+16); + {$IFDEF FPC} + l32f := align(lBuffOutUnaligned,16); + {$ELSE} + l32f := SingleP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + {$ENDIF} + for lPos := 1 to lOutVolItems do + l32f^[lPos] := 0; //set all to zero + end else if lSrcHdr.ImgBufferBPP = 2 then begin + l16is := SmallIntP(lSrcHdr.ImgBuffer); + GetMem(lBuffOutUnaligned,(lOutVolItems*sizeof(smallint))+16); + {$IFDEF FPC} + l16i := align(lBuffOutUnaligned,16); + {$ELSE} + l16i := SmallIntP($fffffff0 and (integer(lBuffOutUnaligned)+15)); + {$ENDIF} + for lPos := 1 to lOutVolItems do + l16i^[lPos] := 0; //set all to zero + end else if lSrcHdr.ImgBufferBPP = 1 then begin + l8is := ByteP(lSrcHdr.ImgBuffer); + GetMem(l8i,lOutVolItems); + Fillchar(l8i^,lOutVolItems,0); //set all to zero + end; + lMat := Voxel2Voxel (lTargHdr,lSrcHdr.NIfTIHdr); + //lDestHdr := lSrcHdr; //destination has the comments and voxel BPP of source + //CopyHdrMat(lTargHdr,lDestHdr);//destination has dimensions and rotations of destination + //now we can apply the transforms... + //build lookup table - speed up inner loop + getmem(lXx, lX*sizeof(single)); + getmem(lXy, lX*sizeof(single)); + getmem(lXz, lX*sizeof(single)); + for lXi := 0 to (lX-1) do begin + lXx^[lXi] := lXi*lMat.matrix[1][1]; + lXy^[lXi] := lXi*lMat.matrix[2][1]; + lXz^[lXi] := lXi*lMat.matrix[3][1]; + end; + lPos := 0; + + + // if (lTrilinearSmooth) and (OneToOne(lMat)) then + // lTrilinearSmooth := false; +if lTrilinearSmooth then begin//compute trilinear interpolation + //compute trilinear interpolation + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + lXreal := (lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYreal := (lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZreal := (lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXreal >= 0) and (lYreal >= 0) and (lZreal >= 0) and + (lXreal < (lXs -1)) and (lYreal < (lYs -1) ) and (lZreal <= (lZs -1)) //June09 lZReal <= instead of < + then begin + //compute the contribution for each of the 8 source voxels + //nearest to the target + lOverlap := true; + lXo := trunc(lXreal); + lYo := trunc(lYreal); + lZo := trunc(lZreal); + lXreal := lXreal-lXo; + lYreal := lYreal-lYo; + lZreal := lZreal-lZo; + lXrM1 := 1-lXreal; + lYrM1 := 1-lYreal; + lZrM1 := 1-lZreal; + lMinY := lYo*lXs; + lMinZ := lZo*lXYs; + lMaxY := lMinY+lXs; + inc(lXo);//images incremented from 1 not 0 + //Check if sample is perfectly in the Z-plane. + //This requires only 8 samples, so its faster + //in addition, for very thin volumes, it allows us to sample to the edge + if lZReal = 0 then begin // perfectly in plane, only sample 4 voxels near each other + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] := + round ( ( (lXrM1*lYrM1)*l8is^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l8is^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l8is^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l8is^[lXo+1+lMaxY+lMinZ])); + 2: l16i^[lPos] := + round (( (lXrM1*lYrM1)*l16is^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l16is^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l16is^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l16is^[lXo+1+lMaxY+lMinZ])); + 4: l32f^[lPos] := + ( (lXrM1*lYrM1)*l32fs^[lXo+lMinY+lMinZ])+((lXreal*lYrM1)*l32fs^[lXo+1+lMinY+lMinZ])+((lXrM1*lYreal)*l32fs^[lXo+lMaxY+lMinZ])+((lXreal*lYreal)*l32fs^[lXo+1+lMaxY+lMinZ]); + end; //case + end else begin //not perfectly in plane... we need 8 samples... + lMaxZ := lMinZ+lXYs; + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] := + round ({all min} ( (lXrM1*lYrM1*lZrM1)*l8is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l8is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l8is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l8is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l8is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l8is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l8is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l8is^[lXo+1+lMaxY+lMaxZ]) ); + 2:l16i^[lPos] := + round ({all min} ( (lXrM1*lYrM1*lZrM1)*l16is^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l16is^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l16is^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l16is^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l16is^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l16is^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l16is^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l16is^[lXo+1+lMaxY+lMaxZ]) ); + 4: l32f^[lPos] := + {all min} ( (lXrM1*lYrM1*lZrM1)*l32fs^[lXo+lMinY+lMinZ]) + {x+1}+((lXreal*lYrM1*lZrM1)*l32fs^[lXo+1+lMinY+lMinZ]) + {y+1}+((lXrM1*lYreal*lZrM1)*l32fs^[lXo+lMaxY+lMinZ]) + {z+1}+((lXrM1*lYrM1*lZreal)*l32fs^[lXo+lMinY+lMaxZ]) + {x+1,y+1}+((lXreal*lYreal*lZrM1)*l32fs^[lXo+1+lMaxY+lMinZ]) + {x+1,z+1}+((lXreal*lYrM1*lZreal)*l32fs^[lXo+1+lMinY+lMaxZ]) + {y+1,z+1}+((lXrM1*lYreal*lZreal)*l32fs^[lXo+lMaxY+lMaxZ]) + {x+1,y+1,z+1}+((lXreal*lYreal*lZreal)*l32fs^[lXo+1+lMaxY+lMaxZ]) ; + end; //case + end; //not perfectly in plane + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z +end else begin //if trilinear, else nearest neighbor +//nearest neighbor - added 12 April 2009 + for lZi := 0 to (lZ-1) do begin + //these values are the same for all voxels in the slice + // compute once per slice + lZx := lZi*lMat.matrix[1][3]; + lZy := lZi*lMat.matrix[2][3]; + lZz := lZi*lMat.matrix[3][3]; + for lYi := 0 to (lY-1) do begin + //these values change once per row + // compute once per row + lYx := lYi*lMat.matrix[1][2]; + lYy := lYi*lMat.matrix[2][2]; + lYz := lYi*lMat.matrix[3][2]; + for lXi := 0 to (lX-1) do begin + //compute each column + inc(lPos); + lXo := round(lXx^[lXi]+lYx+lZx+lMat.matrix[1][4]); + lYo := round(lXy^[lXi]+lYy+lZy+lMat.matrix[2][4]); + lZo := round(lXz^[lXi]+lYz+lZz+lMat.matrix[3][4]); + //need to test Xreal as -0.01 truncates to zero + if (lXo >= 0) and (lYo >= 0{1}) and (lZo >= 0{1}) and + (lXo < (lXs)) and (lYo < (lYs) ) and (lZo < (lZs)) + //2012 removed -1 for nearest neighbor (lXo < (lXs -1)) and (lYo < (lYs -1) ) and (lZo < (lZs)) + then begin + lOverlap := true; + inc(lXo);//images incremented from 1 not 0 + lYo := lYo*lXs; + lZo := lZo*lXYs; + case lSrcHdr.ImgBufferBPP of + 1 : l8i^[lPos] :=l8is^[lXo+lYo+lZo]; + 2: l16i^[lPos] :=l16is^[lXo+lYo+lZo]; + 4: l32f^[lPos] :=l32fs^[lXo+lYo+lZo] ; + end; //case + end; //if voxel is in source image's bounding box + end;//z + end;//y + end;//z +//end nearest neighbor +end; + + //release lookup tables + freemem(lXx); + freemem(lXy); + freemem(lXz); + //check to see if image is empty... + if not lOverlap then + Showmessage('No overlap between overlay and background - these images do not appear coregistered.'); + + if lSrcHdr.ImgBufferBPP = 4 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(Single)) + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + lSrcHdr.ImgBufferItems := lOutVolItems; + move(l32f^,lSrcHdr.ImgBuffer^,(lOutVolItems*sizeof(Single))); + FreeMem(lBuffOutUnaligned); + end else if lSrcHdr.ImgBufferBPP = 2 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,(lOutVolItems*sizeof(SmallInt)) + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l16i),(lOutVolItems*sizeof(SmallInt))); + move(l16i^,lSrcHdr.ImgBuffer^,(lOutVolItems*sizeof(SmallInt))); + FreeMem(lBuffOutUnaligned); + end else if lSrcHdr.ImgBufferBPP = 1 then begin + FreeMem(lSrcHdr.ImgBufferUnaligned); + GetMem(lSrcHdr.ImgBufferUnaligned ,lOutVolItems + 16); + {$IFDEF FPC} + lSrcHdr.ImgBuffer := align(lSrcHdr.ImgBufferUnaligned,16); + {$ELSE} + lSrcHdr.ImgBuffer := ByteP($fffffff0 and (integer(lSrcHdr.ImgBufferUnaligned)+15)); + {$ENDIF} + lSrcHdr.ImgBufferItems := lOutVolItems; + //CopyMemory(Pointer(lSrcHdr.ImgBuffer),Pointer(l8i),lOutVolItems); + move(l8i^,lSrcHdr.ImgBuffer^,lOutVolItems); + FreeMem(l8i); + end; + lSrcHdr.NIfTIHdr := lDestHdr; //header inherits coordinates of target +end; + + +function Hdr2InvMat (lHdr: TNiftiHdr; var lOK: boolean): TMatrix; +var + lSrcMat,lSrcMatInv: TMatrix; +begin + lSrcMat := Hdr2Mat( lHdr); + lSrcMatInv := lSrcMat; + lOK := gaussj(lSrcMatInv); + //the vectors should be rows not columns.... + //therefore we transpose the matrix + //use this if you use transform instead of coord + //Transposemat(lSrcMatInv); + result := lSrcMatInv; +end; + +end. diff --git a/stat.pas b/stat.pas new file mode 100755 index 0000000..19c7291 --- /dev/null +++ b/stat.pas @@ -0,0 +1,543 @@ +Unit stat; +interface +uses Dialogs,define_types; + +const + ITMAX = 300; + EPS = 3.0e-7; + kMaxFact = 1700; {<= 1754} + gFactRAready : boolean = false; +type + FactRA = array[0..kMaxFact] of extended; +var + gFactRA : FactRA; +FUNCTION betai(a,b,x: double): double; +procedure AlertMsg (pWarningStr: String); +function gammq( a,x: real): real; +procedure Chi2x2 (A, B, C, D: integer; var pMinExp, pChi, p, puChi, pup: double); +function Liebermeister (A,B,C,D: integer): extended; +procedure EstimateFDR(lnTests: integer; Ps: SingleP; var lFDR05, lFDR01: double); +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); + +function Fisher1TailMidP (A,B,C,D: integer): double; { use instead of chi2x2: returns p-value} +procedure InitFact; + +implementation + +procedure InitFact; +var lX: word; +begin + gFactRA[0]:= 1; + gFactRA[1] := 1; + for lx := 2 to kMaxFact do + gFactRA[lx] := lx * gFactRA[lx-1]; + gFactRAready := true; +end; + +function FisherX (A,B,C,D: integer): double; {FisherExactTest, use instead of chi} +{FisherX computes odds for this specific config only, not more extreme cases} +{alternate to Chi Square, see Siegel & Castellan, Nonparametric Statistics} +{use instead of Chi when n <= 20} +{A= X hits, B= control hits, C = X misses, D = control misses} +var + N: word; +begin + N := A+B+C+D; + if (N <= kMaxFact) and (A>=0) and (B>=0) and (C>=0) and (D>=0) and (N > 0) then begin + FisherX := ( + (gFactRA[A+B]/gFactRA[A])* + (gFactRA[B+D]/gFactRA[B])* + (gFactRA[A+C]/gFactRA[C])* + (gFactRA[C+D]/gFactRA[D]) + )/ gFactRA[N]; + end else FisherX := 0; +end; + + + +function MidPKingFisher (lSmal,lCross1,lCross2,lSmalDiag: integer): extended; +var + lProb1, lProb2: extended; + lA,lB,lC,lD,lCnt: integer; + l1st : boolean; +begin + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb1:=0; + l1st := true; //set to true for midP + for lCnt := lA downto 0 do begin + if l1st then + lProb1 := 0.5* FisherX(lA,lB,lC,lD) + else + lProb1 := lProb1 + FisherX(lA,lB,lC,lD); + l1st := false; + dec(lA); + dec(lD); + inc(lB); + inc(lC); + end; + lA :=lSmal; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag; + lProb2:=0; + l1st := true; //alfa -set to true for MidP + while (lB >= 0) and (lC >= 0) do begin + if l1st then + lProb2 := 0.5* FisherX(lA,lB,lC,lD) + else + lProb2 := lProb2 + FisherX(lA,lB,lC,lD); + l1st := false; + inc(lA); + inc(lD); + dec(lB); + dec(lC); + end; + if lProb1 < lProb2 then + result := lProb1 + else + result := lProb2; + //result := lprob1; +end; + + +function Lieber (lSmal,lCross1,lCross2,lSmalDiag: integer): extended; +var + lA,lB,lC,lD,lCnt: integer; +begin + lA :=lSmal; + lB:=lCross1+1; + lC:=lCross2+1; + lD:=lSmalDiag; + result :=0; + for lCnt := lA downto 0 do begin + result := result + FisherX(lA,lB,lC,lD); + dec(lA); + dec(lD); + inc(lB); + inc(lC); + end; + //TabbedNotebookDlg.caption := realtostr(result,6) ; + //TabbedNotebookDlg.caption := realtostr(result,6) ; + if result <= 0.5 then + exit; + + lA :=lSmal+1; + lB:=lCross1; + lC:=lCross2; + lD:=lSmalDiag+1; + result:=0; + while (lB >= 0) and (lC >= 0) do begin + result := result + FisherX(lA,lB,lC,lD); + inc(lA); + inc(lD); + dec(lB); + dec(lC); + end; +end; + +function Liebermeister (A,B,C,D: integer): extended; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + result := 1; + if (A+B+C+D)<1 then + exit; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=Lieber(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=Lieber(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=Lieber(C,D,A,B) + else {d smallest} + result :=Lieber(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end; + +(*function Liebermeister (Ain,Bin,Cin,Din: integer): extended; +var + A,B,C,D: integer; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + A := Ain; + B := Bin; + C := Cin; + D := Din; + if (A+B+C+D)<1 then begin + result := 1; + exit; + end; + //easy way to calculate Lieberman - make more extreme, then calculate Fisher + if abs(A-D) > abs(B-C) then begin + inc(A); + inc(D); + end else begin + inc(B); + inc(C); + end; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=KingFisher(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=KingFisher(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=KingFisher(C,D,A,B) + else {d smallest} + result :=KingFisher(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end;*) +function Fisher1TailMidP (A,B,C,D: integer): double; +{A= X hits, B= control hits, C = X misses, D = control misses} +begin + if (A+B+C+D)<1 then begin + result := 1; + exit + end; + if not gFactRAready then InitFact; + if (A<=B) and (A<=C) and (A<=D) then {lA smallest} + result :=MidPKingFisher(A,B,C,D) + else if (B<=C) and (B<=D) then {lB smallest} + result :=MidPKingFisher(B,A,D,C) + else if (C<=D) then {lC smallest} + result :=MidPKingFisher(C,D,A,B) + else {d smallest} + result :=MidPKingFisher(D,C,B,A); + if ((A+C)>0) and ((B+D)>0) then begin + if (A/(A+C)) < (B/(B+D)) then + result := -result; + end; +end; + + +(*procedure Sort (first, last: integer; var DynDataRA:SingleP); +{Shell sort chuck uses this- see 'Numerical Recipes in C' for similar sorts.} +{less memory intensive than recursive quicksort} +label + 555; +const + tiny = 1.0e-5; + aln2i = 1.442695022; +var + n, nn, m, lognb2, l, k, j, i: INTEGER; + swap: Single; +begin + n := abs(last - first + 1); + lognb2 := trunc(ln(n) * aln2i + tiny); + m := last; + for nn := 1 to lognb2 do begin + m := m div 2; + k := last - m; + for j := 1 to k do begin + i := j; + 555: {<- LABEL} + l := i + m; + if (DynDataRA^[l] < DynDataRA^[i]) then begin + swap := DynDataRA^[i]; + DynDataRA^[i] := DynDataRA^[l]; + DynDataRA^[l] := swap; + i := i - m; + if (i >= 1) then + goto 555; + end + end + end +end;//sort *) + +procedure qsort(lower, upper : integer; var Data:SingleP); +//40ms - very recursive... +var + left, right : integer; + pivot,lswap: single; +begin + pivot:=Data^[(lower+upper) div 2]; + left:=lower; + right:=upper; + while left<=right do begin + while Data^[left] < pivot do left:=left+1; { Parting for left } + while Data^[right] > pivot do right:=right-1;{ Parting for right} + if left<=right then begin { Validate the change } + lswap := Data^[left]; + Data^[left] := Data^[right]; + Data^[right] := lswap; + left:=left+1; + right:=right-1; + end; //validate + end;//while left <=right + if right>lower then qsort(lower,right,Data); { Sort the LEFT part } + if upper>left then qsort(left ,upper,data); { Sort the RIGHT part } +end; + +procedure EstimateFDR2(lnTests: integer; var Ps: SingleP; var lFDR05, lFDR01,lnegFDR05, lnegFDR01: double); +var + lInc: integer; + lrPs,Qs: SingleP; +begin + //rank Pvalues + //ShaQuickSort(lnTests,Singlep0(Ps[1])); + qSort(1,lnTests,Ps); + //qSort(1,lnTests,Ps); + GetMem(Qs,lnTests*sizeof(single)); + //next findcrit FDR05 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lFDR05 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR05 := Ps^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lFDR01 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR01 := Ps^[lInc]; + //reverse + GetMem(lrPs,lnTests*sizeof(single)); + for lInc := 1 to lnTests do + lrPs^[lInc] := 1- Ps^[lnTests-lInc+1]; + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lnegFDR05 := 0; + for lInc := 1 to lnTests do + if lrPs^[lInc] <= Qs^[lInc] then + lnegFDR05 := lrPs^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lnegFDR01 := 0; + for lInc := 1 to lnTests do + if lrPs^[lInc] <= Qs^[lInc] then + lnegFDR01 := lrPs^[lInc]; + FreeMem(lrPs); + Freemem(Qs); +end; + +procedure EstimateFDR(lnTests: integer; Ps: SingleP; var lFDR05, lFDR01: double); +var + lInc: integer; + Qs: SingleP; +begin + //rank Pvalues + qSort(1,lnTests,Ps); + {lStr := 'sort='; + for lInc := 1 to knTests do + lStr := lStr+realtostr(Ps[lInc],4)+','; + Memo1.Lines.Add(lStr); } + GetMem(Qs,lnTests*sizeof(single)); + //next findcrit FDR05 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.05*lInc)/lnTests; + lFDR05 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR05 := Ps^[lInc]; + //next findcrit FDR01 + for lInc := 1 to lnTests do + Qs^[lInc] := (0.01*lInc)/lnTests; + lFDR01 := 0; + for lInc := 1 to lnTests do + if Ps^[lInc] <= Qs^[lInc] then + lFDR01 := Ps^[lInc]; + Freemem(Qs); +end; + +procedure AlertMsg (pWarningStr: String); +begin + MessageDLG(pWarningStr, mtWarning,[mbOK],0); +end; + +function gammln (xx: double): double; {Numerical Recipes for Pascal, p 177} + const + stp = 2.50662827465; + var + x, tmp, ser: double; +begin + x := xx - 1.0; + tmp := x + 5.5; + tmp := (x + 0.5) * ln(tmp) - tmp; + ser := 1.0 + 76.18009173 / (x + 1.0) - 86.50532033 / + (x + 2.0) + 24.01409822 / (x + 3.0) - 1.231739516 / (x + 4.0) + 0.120858003e-2 / (x + 5.0) - 0.536382e-5 / (x + 6.0); + gammln := tmp + ln(stp * ser) +end; {procedure gammln} + +FUNCTION betacf(a,b,x: double): double; +LABEL 1; +CONST + itmax=100; + eps=3.0e-7; +VAR + tem,qap,qam,qab,em,d: double; + bz,bpp,bp,bm,az,app: double; + am,aold,ap: double; + m: integer; +BEGIN + am := 1.0; + bm := 1.0; + az := 1.0; + qab := a+b; + qap := a+1.0; + qam := a-1.0; + bz := 1.0-qab*x/qap; + FOR m := 1 TO itmax DO BEGIN + em := m; + tem := em+em; + d := em*(b-m)*x/((qam+tem)*(a+tem)); + ap := az+d*am; + bp := bz+d*bm; + d := -(a+em)*(qab+em)*x/((a+tem)*(qap+tem)); + app := ap+d*az; + bpp := bp+d*bz; + aold := az; + am := ap/bpp; + bm := bp/bpp; + az := app/bpp; + bz := 1.0; + IF ((abs(az-aold)) < (eps*abs(az))) THEN GOTO 1 + END; + writeln('pause in BETACF'); + writeln('a or b too big, or itmax too small'); readln; +1: betacf := az +END; + + +FUNCTION betai(a,b,x: double): double; +VAR + bt: double; +BEGIN + IF ((x < 0.0) OR (x > 1.0)) THEN BEGIN + writeln('pause in routine BETAI'); readln + END; + IF ((x = 0.0) OR (x = 1.0)) THEN bt := 0.0 + ELSE bt := exp(gammln(a+b)-gammln(a)-gammln(b) + +a*ln(x)+b*ln(1.0-x)); + IF (x < ((a+1.0)/(a+b+2.0))) THEN + betai := bt*betacf(a,b,x)/a + ELSE betai := 1.0-bt*betacf(b,a,1.0-x)/b +END; + +procedure gser(var gamser, a,x, gln: real); +var n: integer; + sum, del, ap: real; +begin + gln := gammln(a); + if x <= 0.0 then begin + if x < 0.0 then AlertMsg('x less then 0 in routine GSER'); + gamser:= 0.0; + end else begin + ap := a; + sum := 1.0/a; + del := sum; + for n := 1 to ITMAX do begin + ap := ap + 1; + del := del * (x/ap); + sum := sum + del; + if (abs(del) < abs((sum)*EPS) )then begin + gamser := sum * exp(-x+a*ln(x)-gln); + exit; + end; + end; + Alertmsg('GSER error: ITMAX too small for requested a-value'); + end; +end; + +procedure gcf(var gammcf: real; a,x, gln: real); +var n: integer; + gold,fac,b1,b0,a0,g,ana,anf,an,a1: real; +begin + fac := 1.0; + b1 := 1.0; + b0 := 0.0; + a0 := 1.0; + gold := 0.0; + gln := gammln(a); + a1 := x; + for n := 1 to ITMAX do begin + an :=(n); + ana := an - a; + a0 := (a1 + a0*ana)*fac; + b0 := (b1 + b0*ana)*fac; + anf := an * fac; + a1 := x*a0+anf*a1; + b1 := x*b0+anf*b1; + if a1 <> 0 then begin + fac := 1.0/a1; + g := b1*fac; + if (abs((g-gold)/g)<EPS) then begin + gammcf := exp(-x+a*ln(x)-gln)*g; + exit; + end; + gold := g; + end; + end; + Alertmsg('GCF error: ITMAX too small for requested a-value'); +end; + +function gammq( a,x: real): real; + var gamser, gammcf, gln: real; +begin + gammq := 0; + if (x < 0) or (a <= 0.0) then alertmsg('Invalid arguments in routine GAMMQ') + else begin + if (x < (a+1.0)) then begin + gser(gamser,a,x,gln); + gammq := 1.0 - gamser; + end else begin + gcf(gammcf,a,x,gln); + gammq := gammcf; + end; + end; +end; + +procedure Chi2x2 (A, B, C, D: integer; var pMinExp, pChi, p, puChi, pup: double); + {A= X hits, B= control hits, C = X misses, D = control misses} + var + lA, lB, lC, lD, lN: extended; {AEXp, BExp, CExp, Dexp, } + lSameOdds: boolean; + begin + lA := A; {convert to extended} + lB := B; + lC := C; + lD := D; + ln := lA + lB + lC + lD; + if lN > 0 then begin {avoid divide by 0} + pMinExp := ((lA + lB) * (lA + lC)) / lN; + if (((lA + lB) * (lB + lD)) / lN) < pMinExp then + pMinExp := ((lA + lB) * (lB + lD)) / lN; + if (((lC + lD) * (lA + lC)) / lN) < pMinExp then + pMinExp := ((lC + lD) * (lA + lC)) / lN; + if (((lC + lD) * (lB + lD)) / lN) < pMinExp then + pMinExp := ((lC + lD) * (lB + lD)) / lN; + end else + pMinExp := 0; + lSameOdds := false; + if (lC > 0) and (lD > 0) then begin + if (lA / lC) = (lB / lD) then + lSameOdds := true; + end; + if (lC = 0) and (lD = 0) then + lSameOdds := true; + if ((lA+lC) = 0) or ((lB+lD) = 0) then + lSameOdds := true; + if (lSameOdds = true) then begin + pChi := 0; {same odds} + p := 1.0; + puChi := 0; + pup := 1.0; + end else begin + puChi := ((sqr((lA * lD) - (lB * lC))) * lN) / ((la + lb) * (lc + ld) * (lb + ld) * (la + lc)); + pup := gammq(0.5, 0.5 * puChi); {half df} + pChi := ((sqr(abs((lA * lD) - (lB * lC)) - (0.5 * lN))) * lN) / ((la + lb) * (lc + ld) * (lb + ld) * (la + lc)); + p := gammq(0.5, 0.5 * pChi); + end; + end; + + + end. diff --git a/statclustertable.pas b/statclustertable.pas new file mode 100755 index 0000000..8ab69ff --- /dev/null +++ b/statclustertable.pas @@ -0,0 +1,314 @@ +unit statclustertable; +//USED by stats to select only regions with a given number of connected/contiguous voxels +interface +{$H+} +uses define_types,dialogs,SysUtils,nifti_hdr,nifti_img, classes; + +//procedure FindClustersText (var lHdr: TMRIcroHdr; lThreshClusterSz: integer; lThresh: double); +procedure BatchCluster; + + +implementation + +uses text,nifti_img_view, nifti_hdr_view, readfloat, readint; + + + +procedure FindClustersText (var lHdr: TMRIcroHdr; lThreshIn: single; lMinClusterSz: integer); +var + lClusterMaxPos,lXdim,lYdim,lZdim,lScaledThresh,lClusterSz,lClusterFillVal,lQTail,lQHead,lSliceSz,lQSz,lInc,lVolSz: integer; + lThresh,lClusterMax: single; + lClusterBuffS: SingleP; + lQra: LongIntP; + lXcom,lYcom,lZcom,lBuffIn32 : SingleP; + lBuffIn16 : SmallIntP; + lCh: char; +procedure InitCenterOfMass; +begin + getmem(lXcom, lXDim*sizeof(single)); + getmem(lYcom, lYDim*sizeof(single)); + getmem(lZcom, lZDim*sizeof(single)); +end; + +procedure FreeCenterOfMass; +begin + freemem(lXcom); + freemem(lYcom); + freemem(lZcom); +end; + +procedure ClearCenterOfMass; +var + i: integer; +begin + for i := 1 to lXDim do + lXcom^[i] := 0; + for i := 1 to lYDim do + lYcom^[i] := 0; + for i := 1 to lZDim do + lZcom^[i] := 0; +end; + +procedure AddCenterOfMass (lVox: integer; lInten: single); +var + lXi,lYi,lZi: integer; +begin +//lukas + ImgPosToSlices(lVox,lXi,lYi,lZi); + lXcom^[lXi] := lXcom^[lXi] + lInten; + lYcom^[lYi] := lYcom^[lYi] + lInten; + lZcom^[lZi] := lZcom^[lZi] + lInten; +end; + +function CenterOfMassPosition: integer; +var + i : integer; + lSum,lXs,lYs,lZs: double; +begin + lSum := 0; + lXs := 0; + for i := 1 to lXDim do + lSum := lSum +lXcom^[i]; + for i := 1 to lXDim do + lXs := lXs +(i*lXcom^[i]); + if lSum > 0 then + lXs := lXs/lSum; + // + lSum := 0; + lYs := 0; + for i := 1 to lYDim do + lSum := lSum +lYcom^[i]; + for i := 1 to lYDim do + lYs := lYs +(i*lYcom^[i]); + if lSum > 0 then + lYs := lYs/lSum; + //Z + lSum := 0; + lZs := 0; + for i := 1 to lZDim do + lSum := lSum +lZcom^[i]; + for i := 1 to lZDim do + lZs := lZs +(i*lZcom^[i]); + if lSum > 0 then + lZs := lzs/lSum; + result := SlicesToImgPos(round(lXs),round(lYs),round(lZs)); + //fx(result, lXs,lYs,lZs); +end; + +function XYZstr (lPos: integer): string; +var lXmm,lYmm,lZmm: single; +begin + ImgPosToMM(lPos, lXmm,lYmm,lZmm); + result := inttostr(round(lXmm))+kTextSep+inttostr(round(lYmm))+kTextSep+inttostr(round(lZmm)); +end; + +procedure Report (lClusterMax: single; lClusterSz, lClusterMaxPos: integer); +var + lTemplateLabel: string; +begin + if lClusterSz < lMinClusterSz then + exit; + //lTemplateLabel := ImgForm.BGLabelString(lClusterMaxPos); + //burger ImgIntensityString + lTemplateLabel := ImgForm.ImgIntensityString(gMRIcroOverlay[2], lClusterMaxPos); + TextForm.MemoT.lines.add(XYZstr(lClusterMaxPos)+kTextSep+XYZstr(CenterOfMassPosition)+kTextSep+inttostr(lClusterSz)+kTextSep+lCh+floattostr(lClusterMax)+kTextSep+lTemplateLabel); +end; + +procedure ReportLabel; +begin + TextForm.MemoT.lines.add('# Data='+kTextSep+lHdr.HdrFileName +kTextSep+'Threshold='+kTextSep+floattostr(lThreshIn) +kTextSep+'MinCluster='+kTextSep+inttostr(lMinClusterSz)); + TextForm.MemoT.lines.add('#X'+kTextSep+'Y'+kTextSep+'Z'+kTextSep+'Xcom'+kTextSep+'Ycom'+kTextSep+'Zcom'+kTextSep+'ClusterSize[Vox]'+kTextSep+'Max'+kTextSep+'Template'); + +end; +Procedure IncQra(var lVal, lQSz: integer); +begin + inc(lVal); + if lVal >= lQSz then + lVal := 1; +end; + +procedure Check(lPixel: integer); +var + lVal: single; +begin + lVal := lClusterBuffS^[lPixel]; + if (lVal= 0) then + exit; + AddCenterOfMass(lPixel,lVal); + if lVal > lClusterMax then begin + lClusterMax := lVal; + lClusterMaxPos := lPixel; + end; + incQra(lQHead,lQSz); + inc(lClusterSz); + lClusterBuffS^[lPixel] := 0; + lQra^[lQHead] := lPixel; +end; + +PROCEDURE RetirePixel; //FIFO cleanup , 1410: added 18-voxel check +VAR + lVal,lValX,lXPos,lYPos,lZPos: integer; +BEGIN + lVal := lQra^[lQTail]; + if lVal = 0 then begin + incQra(lQTail,lQSz); //done with this pixel + exit; + end; + lXpos := lVal mod lXdim; + if lXpos = 0 then lXPos := lXdim; + lYpos := (1+((lVal-1) div lXdim)) mod lYDim; + if lYPos = 0 then lYPos := lYdim; + lZpos := ((lVal-1) div lSliceSz)+1; + if (lXPos <= 1) or (lXPos >= lXDim) or + (lYPos <= 1) or (lYPos >= lYDim) or + (lZPos <= 1) or (lZPos >= lZDim) then + // retire and exiT + else begin + //lXDimM := lXDim; + Check(lVal-1); //left + Check(lVal+1); //right + Check(lVal-lXDim); //up + Check(lVal+lXDim); //down + Check(lVal-lSliceSz); //up + Check(lVal+lSliceSz); //down + //check plane above + lValX := lVal + lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDim); //up + Check(lValX+lXDim); //down + //check plane below + lValX := lVal - lSLiceSz; + Check(lValX-1); //left + Check(lValX+1); //right + Check(lValX-lXDim); //up + Check(lValX+lXDim); //down + //check diagonals of current plane + Check(lVal-lXDim-1); //up, left + Check(lVal-lXDim+1); //up, right + Check(lVal+lXDim-1); //down, left + Check(lVal+lXDim+1); //down, right + end; //not edge + incQra(lQTail,lQSz); //done with this pixel +END; + +procedure FillStart (lPt: integer); {FIFO algorithm: keep memory VERY low} +var lI: integer; +begin + if (lClusterBuffS^[lPt]=0) then exit; + for lI := 1 to lQsz do + lQra^[lI] := 0; + lQHead := 0; + lQTail := 1; + Check(lPt); + RetirePixel; + // check that there was anything in the cluster at all + //showmessage('head'+inttostr(lQHead)+'.'+inttostr(lQTail)); + //if lQHead > 2 then begin + // and do the recursion to get rid of it + while ((lQHead+1) <> lQTail) do begin//complete until all voxels in buffer have been tested + RetirePixel; + if (lQHead = lQSz) and (lQTail = 1) then + exit; //break condition: avoids possible infinite loop where QTail is being incremented but QHead is stuck at maximum value + end; +end; + +begin + lCh := ' '; //assume positive values + lXDim := lHdr.NIFTIhdr.dim[1]; + lYDim := lHdr.NIFTIhdr.dim[2]; + lZDim := lHdr.NIFTIhdr.dim[3]; + InitCenterOfMass; + lVolSz := lXdim*lYdim*lZdim; + lSliceSz := lXdim * lYdim; + if (lXDim < 4) or (lYDim < 4) or (lZDim < 4) or (lVolSz < 1) or (lHdr.ImgBufferItems <> lVolSz) then exit; + GetMem(lClusterBuffS, lVolSz* sizeof(Single)); + ReportLabel; + if lHdr.ImgBufferBPP = 4 then begin + lBuffIn32 := SingleP(lHdr.ImgBuffer); + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lBuffIn32^[lInc]; + end else if lHdr.ImgBufferBPP = 2 then begin //not 32bit - if 16bit input + lBuffIn16 := SmallIntP(lHdr.ImgBuffer); + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lBuffIn16^[lInc]; + end else begin //not 16 or 32 bit input + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lHdr.ImgBuffer^[lInc]; + end; //8-bit input + //Next - apply scale and intercept + if (lHdr.NIFTIhdr.scl_slope <> 0) and (lHdr.NIFTIhdr.scl_slope <> 1) then //if one then no effect - zero is meaningless + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lClusterBuffS^[lInc]*lHdr.NIFTIhdr.scl_slope; + if (lHdr.NIFTIhdr.scl_inter <> 0) then //if zero then no effect + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := lClusterBuffS^[lInc]+lHdr.NIFTIhdr.scl_inter; + lThresh := lThreshIn; + if lThreshIn < 0 then begin //invert all values... + for lInc := 1 to lVolSz do + lClusterBuffS^[lInc] := -lClusterBuffS^[lInc]; + lThresh := -lThresh; + lCh := '-'; + end; + //Next - zero all voxels less than threshold + for lInc := 1 to lVolSz do + if (lClusterBuffS^[lInc]) < lThresh then + lClusterBuffS^[lInc] := 0; + //Next - get memory + lQSz := (lVolSz div 4)+8; + GetMem(lQra,lQsz * sizeof(longint) ); + //check positive clusters.... + ClearCenterOfMass; + for lInc := 1 to lVolSz do begin + if lClusterBuffS^[lInc] <> 0 then begin + lClusterSz := 0; + lClusterMax := 0; + FillStart(lInc); + // now fill the cluster with its size (=1 if the voxel was isolated) + Report (lClusterMax,lClusterSz,lClusterMaxPos); + ClearCenterOfMass; + end; + end; + FreeCenterOfMass; + Freemem(lQra); + Freemem(lClusterBuffS); +end; + +procedure BatchCluster; +var + lInc,lNumberofFiles,lMinClusterSz: integer; + lFilename,lTemplateName:string; + lPref: boolean; + lThresh: single; +begin + for lInc := 1 to (knMaxOverlay-1) do + FreeImgMemory(gMRIcroOverlay[lInc]); + ImgForm.UpdateLayerMenu; + lMinClusterSz := ReadIntForm.GetInt('Minimum cluster size [in voxels]: ', 1,4,9999); + lThresh := ReadFloatForm.GetFloat('Please enter statistical threshold. ', -9999,2.3,9999); + lTemplateName := ''; + if OpenDialogExecute(kImgFilter,'Select anatomical template (optional)',false) then begin + lTemplateName := HdrForm.OpenHdrDlg.Filename; + end; + if not OpenDialogExecute(kImgFilter,'Select statistical maps',true) then exit; + lNumberofFiles:= HdrForm.OpenHdrDlg.Files.Count; + if lNumberofFiles < 1 then + exit; + if not fileexists(lTemplateName) then + lTemplateName := ''; + TextForm.MemoT.Lines.Clear; + lPref := gBGImg.ResliceOnLoad; + gBGImg.ResliceOnLoad := false; + for lInc:= 1 to lNumberofFiles do begin + lFilename := HdrForm.OpenHdrDlg.Files[lInc-1]; + + ImgForm.OpenAndDisplayImg(lFilename,false); + if lTemplateName <> '' then + ImgForm.OverlayOpenCore ( lTemplateName, 2); + FindClustersText(gMRIcroOverlay[kBGOverlayNum], lThresh,lMinClusterSz); + end;//lLoop + gBGImg.ResliceOnLoad := lPref; + TextForm.Show; +end; + +end. \ No newline at end of file diff --git a/templates/aal.nii.gz b/templates/aal.nii.gz new file mode 100755 index 0000000..21e4a73 Binary files /dev/null and b/templates/aal.nii.gz differ diff --git a/templates/aal.nii.lut b/templates/aal.nii.lut new file mode 100755 index 0000000..7c8e0f8 Binary files /dev/null and b/templates/aal.nii.lut differ diff --git a/templates/brodmann.nii.gz b/templates/brodmann.nii.gz new file mode 100755 index 0000000..effe7be Binary files /dev/null and b/templates/brodmann.nii.gz differ diff --git a/templates/brodmann.nii.lut b/templates/brodmann.nii.lut new file mode 100755 index 0000000..6bdf199 Binary files /dev/null and b/templates/brodmann.nii.lut differ diff --git a/templates/ch2bet.nii.gz b/templates/ch2bet.nii.gz new file mode 100755 index 0000000..6daee0c Binary files /dev/null and b/templates/ch2bet.nii.gz differ diff --git a/text.lfm b/text.lfm new file mode 100755 index 0000000..2cf59e4 --- /dev/null +++ b/text.lfm @@ -0,0 +1,47 @@ +object TextForm: TTextForm + Left = 417 + Height = 480 + Top = 195 + Width = 696 + HorzScrollBar.Page = 695 + VertScrollBar.Page = 459 + ActiveControl = MemoT + Caption = 'Descriptive Statistics' + ClientHeight = 480 + ClientWidth = 696 + Font.Height = -11 + Menu = MainMenu1 + OnCreate = FormCreate + LCLVersion = '0.9.30.2' + object MemoT: TMemo + Left = 0 + Height = 480 + Top = 0 + Width = 696 + Align = alClient + ScrollBars = ssVertical + TabOrder = 0 + end + object MainMenu1: TMainMenu + left = 112 + top = 10 + object File1: TMenuItem + Caption = 'File' + object Save1: TMenuItem + Caption = 'Save' + OnClick = Save1Click + end + object Closewindow1: TMenuItem + Caption = 'Close window' + OnClick = Closewindow1Click + end + end + object Copy1: TMenuItem + Caption = 'Edit' + object Copy2: TMenuItem + Caption = 'Copy' + OnClick = Copy2Click + end + end + end +end diff --git a/text.lrs b/text.lrs new file mode 100644 index 0000000..8d0c29f --- /dev/null +++ b/text.lrs @@ -0,0 +1,15 @@ +LazarusResources.Add('TTextForm','FORMDATA',[ + 'TPF0'#9'TTextForm'#8'TextForm'#4'Left'#3#161#1#6'Height'#3#224#1#3'Top'#3#195 + +#0#5'Width'#3#184#2#18'HorzScrollBar.Page'#3#183#2#18'VertScrollBar.Page'#3 + +#203#1#13'ActiveControl'#7#5'MemoT'#7'Caption'#6#22'Descriptive Statistics' + +#12'ClientHeight'#3#224#1#11'ClientWidth'#3#184#2#11'Font.Height'#2#245#4'Me' + +'nu'#7#9'MainMenu1'#8'OnCreate'#7#10'FormCreate'#10'LCLVersion'#6#8'0.9.30.2' + +#0#5'TMemo'#5'MemoT'#4'Left'#2#0#6'Height'#3#224#1#3'Top'#2#0#5'Width'#3#184 + +#2#5'Align'#7#8'alClient'#10'ScrollBars'#7#10'ssVertical'#8'TabOrder'#2#0#0#0 + +#9'TMainMenu'#9'MainMenu1'#4'left'#2'p'#3'top'#2#10#0#9'TMenuItem'#5'File1'#7 + +'Caption'#6#4'File'#0#9'TMenuItem'#5'Save1'#7'Caption'#6#4'Save'#7'OnClick'#7 + +#10'Save1Click'#0#0#9'TMenuItem'#12'Closewindow1'#7'Caption'#6#12'Close wind' + +'ow'#7'OnClick'#7#17'Closewindow1Click'#0#0#0#9'TMenuItem'#5'Copy1'#7'Captio' + +'n'#6#4'Edit'#0#9'TMenuItem'#5'Copy2'#7'Caption'#6#4'Copy'#7'OnClick'#7#10'C' + +'opy2Click'#0#0#0#0#0 +]); diff --git a/text.pas b/text.pas new file mode 100755 index 0000000..794d1b4 --- /dev/null +++ b/text.pas @@ -0,0 +1,91 @@ +unit text; +{$H+} + +interface + +uses +{$IFDEF FPC}LResources,{$ENDIF} +{$IFNDEF Unix} Windows,{$ENDIF} + SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + Menus, StdCtrls,Define_Types; + +type + + { TTextForm } + + TTextForm = class(TForm) + MainMenu1: TMainMenu; + File1: TMenuItem; + Save1: TMenuItem; + Closewindow1: TMenuItem; + Copy1: TMenuItem; + Copy2: TMenuItem; + MemoT: TMemo; + procedure Closewindow1Click(Sender: TObject); + procedure Copy2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure Save1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + TextForm: TTextForm; + +implementation + + uses nifti_img_view; +{$IFNDEF FPC} +{$R *.DFM} +{$ENDIF} + +procedure TTextForm.Closewindow1Click(Sender: TObject); +begin + TextForm.Close; +end; + +procedure TTextForm.Copy2Click(Sender: TObject); +begin + {$IFDEF zxDarwin} + Showmessage('Copy not yet supported with OSX: use File/Save'); + exit; + {$ENDIF} + MemoT.SelectAll; + MemoT.CopyToClipboard; +end; + +procedure TTextForm.FormCreate(Sender: TObject); +begin + {$IFDEF Darwin} + {$IFNDEF LCLgtk} //only for Carbon compile + Copy2.ShortCut := ShortCut(Word('C'), [ssMeta]); + Save1.ShortCut := ShortCut(Word('S'), [ssMeta]); + Closewindow1.ShortCut := ShortCut(Word('W'), [ssMeta]); + {$ENDIF} + {$ENDIF} +end; + +procedure TTextForm.Save1Click(Sender: TObject); +begin + ImgForm.SaveDialog1.Filename := parsefilename(gMRIcroOverlay[kBGOverlayNum].HdrFilename); + if kTextSep = chr(9) then + ImgForm.SaveDialog1.Filter := 'Tab Separated (*.tab)|*.tab|Comma Separated (*.csv)|*.csv|Text (*.txt)|*.txt' + else + ImgForm.SaveDialog1.Filter := 'Comma Separated (*.csv)|*.csv|Tab Separated (*.tab)|*.tab|Text (*.txt)|*.txt'; + if kTextSep = chr(9) then + ImgForm.SaveDialog1.DefaultExt := '.tab' + else + ImgForm.SaveDialog1.DefaultExt := '.csv'; + if not ImgForm.SaveDialog1.Execute then exit; + MemoT.Lines.SaveToFile(ImgForm.SaveDialog1.Filename); +end; + +{$IFDEF FPC} +initialization + {$I Text.lrs} +{$ENDIF} + + +end. \ No newline at end of file diff --git a/unused/_build.bat b/unused/_build.bat new file mode 100755 index 0000000..4eb97ab --- /dev/null +++ b/unused/_build.bat @@ -0,0 +1,4 @@ +C:\lazarus\pp\bin\i386-win32\strip --verbose --strip-all "C:\lazarus\mricron\mricron.exe" +copy "C:\lazarus\mricron\mricron.exe" C:\mricron\mricron.exe +copy "C:\lazarus\mricron\dcm2nii\dcm2nii.exe" C:\mricron\dcm2nii.exe +"C:\Program Files\NSIS2\makensis" "C:\Program Files\NSIS2\mricron.nsi" diff --git a/unused/_clean.bat b/unused/_clean.bat new file mode 100755 index 0000000..9c0921d --- /dev/null +++ b/unused/_clean.bat @@ -0,0 +1,15 @@ +del /S *.a +del /S *.o +del /S *.ppu +del /S *.bak +del /S *.~* +del /S *.dcu +del /S *.dsk +del /S *.obj +del /S *.hpp +del /S *.ddp +del /S *.mps +del /S *.mpt +del /S *.exe +del /S *.old +rmdir /S /Q mricron.app diff --git a/unused/_dcm2nii.bat b/unused/_dcm2nii.bat new file mode 100755 index 0000000..22f9025 --- /dev/null +++ b/unused/_dcm2nii.bat @@ -0,0 +1,8 @@ +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr --cpu=x86_64 --compiler="/usr/local/bin/ppcx64" +mv ./dcm2nii/dcm2nii ../distro/dcm2nii64 + +./_xclean.bat +cp ./common/gui.inc ./common/isgui.inc diff --git a/unused/_delphi.bat b/unused/_delphi.bat new file mode 100755 index 0000000..c241a30 --- /dev/null +++ b/unused/_delphi.bat @@ -0,0 +1,34 @@ +del c:\mricron\*.ini + +call _clean.bat +copy /Y .\common\notgui.inc .\common\isgui.inc + +cd .\dcm2nii +C:\PROGRA~2\BORLAND\DELPHI7\BIN\dcc32 -CC -B dcm2nii.dpr +c:\strip dcm2nii.exe +copy /Y dcm2nii.exe c:\mricron +cd .. + +call _clean.bat +copy /Y .\common\gui.inc .\common\isgui.inc + +cd .\npm +C:\PROGRA~2\BORLAND\DELPHI7\BIN\dcc32 -U..\delphionly -B npm.dpr +c:\strip npm.exe +copy /Y npm.exe c:\mricron +cd .. + +cd .\dcm2nii +C:\PROGRA~2\BORLAND\DELPHI7\BIN\dcc32 -U..\delphionly;C:\pas\d7\rx275d7\Units -B dcm2niigui.dpr +c:\strip dcm2niigui.exe +copy /Y dcm2niigui.exe c:\mricron +cd .. + +call _clean.bat + +cd c:\pas\delphi\niftiview7 +C:\PROGRA~2\BORLAND\DELPHI7\BIN\dcc32 -UC:\pas\d7\rx275d7\Units;C:\PROGRA~2\PngComponents\Source -B mricron.dpr +c:\strip c:\pas\delphi\niftiview7\mricron.exe +copy /Y c:\pas\delphi\niftiview7\mricron.exe c:\mricron\ + + diff --git a/unused/_delphizip.bat b/unused/_delphizip.bat new file mode 100755 index 0000000..e4b8308 --- /dev/null +++ b/unused/_delphizip.bat @@ -0,0 +1,10 @@ +REM COMPILE MRIcron +call _delphi.bat + +REM compress MRIcron +c:\Progra~1\7-Zip\7z a -tzip c:\pas\wincron.zip c:\mricron +copy /Y c:\pas\wincron.zip Y:\mcbi\MCBI\CRNL\sw\mricron\win.zip + +REM compress Source +c:\Progra~1\7-Zip\7z a -tzip c:\pas\srccron.zip c:\pas\mricron +copy c:\pas\srccron.zip Y:\mcbi\MCBI\CRNL\sw\mricron\source.zip \ No newline at end of file diff --git a/unused/_gtall.bat b/unused/_gtall.bat new file mode 100755 index 0000000..f06aeeb --- /dev/null +++ b/unused/_gtall.bat @@ -0,0 +1,14 @@ + +cd ~/mricron +chmod 777 ./_gtscript.bat +./_gtscript.bat + + +cd ~/gtk1 +zip -r mricronlx mricron +mv mricronlx.zip .. + +cd ~/gtk2 +zip -r mricronlx2 mricron +mv mricronlx2.zip .. + diff --git a/unused/_gtall64.bat b/unused/_gtall64.bat new file mode 100755 index 0000000..fa066a3 --- /dev/null +++ b/unused/_gtall64.bat @@ -0,0 +1,14 @@ + +cd ~/mricron +chmod 777 ./_gtscript.bat +./_gtscript.bat + + +cd ~/gtk1 +zip -r mricronlx641 mricron + + +cd ~/gtk2 +zip -r mricronlx642 mricron + + diff --git a/unused/_gtscript.bat b/unused/_gtscript.bat new file mode 100755 index 0000000..b33c7d2 --- /dev/null +++ b/unused/_gtscript.bat @@ -0,0 +1,34 @@ +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr +cp ./dcm2nii/dcm2nii ../gtk1/mricron/dcm2nii +cp ./dcm2nii/dcm2nii ../gtk2/mricron/dcm2nii +cp ./dcm2nii/dcm2nii ../qt/mricron/dcm2nii + + +cp ./common/gui.inc ./common/isgui.inc + +./_xclean.bat +lazbuild ./mricron.lpr --ws=gtk +lazbuild ./npm/npm.lpr --ws=gtk +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=gtk +cp ./mricron ../gtk1/mricron/mricron +cp ./npm/npm ../gtk1/mricron/npm +cp ./dcm2nii/dcm2niigui ../gtk1/mricron/dcm2niigui + +./_xclean.bat +lazbuild ./mricron.lpr --ws=gtk2 +lazbuild ./npm/npm.lpr --ws=gtk2 +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=gtk2 +cp ./mricron ../gtk2/mricron/mricron +cp ./npm/npm ../gtk2/mricron/npm +cp ./dcm2nii/dcm2niigui ../gtk2/mricron/dcm2niigui + +./_xclean.bat +lazbuild ./mricron.lpr --ws=qt +lazbuild ./npm/npm.lpr --ws=qt +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=qt +cp ./mricron ../qt/mricron/mricron +cp ./npm/npm ../qt/mricron/npm +cp ./dcm2nii/dcm2niigui ../qt/mricron/dcm2niigui diff --git a/unused/_lxall.bat b/unused/_lxall.bat new file mode 100755 index 0000000..e1c026d --- /dev/null +++ b/unused/_lxall.bat @@ -0,0 +1,17 @@ + +cd ~/mricron +chmod 777 ./_qtscript.bat +./_qtscript.bat + +cd ~/qt +zip -r mricronqt mricron +mv mricronqt.zip .. + +cd ~/gtk1 +zip -r mricronlx mricron +mv mricronlx.zip .. + +cd ~/gtk2 +zip -r mricronlx2 mricron +mv mricronlx2.zip .. + diff --git a/unused/_maclipo.bat b/unused/_maclipo.bat new file mode 100755 index 0000000..5ce1a13 --- /dev/null +++ b/unused/_maclipo.bat @@ -0,0 +1,5 @@ +# lipo -create ../distro/ppc/dcm2nii ../distro/intel/dcm2nii -output ../distro/dcm2nii +cp ../distro/intel/dcm2nii ../distro/dcm2nii +lipo -create ../distro/ppc/mricron ../distro/intel/mricron -output ../distro/mricron.app/Contents/MacOS/mricron +lipo -create ../distro/ppc/dcm2niigui ../distro/intel/dcm2niigui -output ../distro/dcm2niigui.app/Contents/MacOS/dcm2niigui +lipo -create ../distro/ppc/npm ../distro/intel/npm -output ../distro/npm.app/Contents/MacOS/npm diff --git a/unused/_macscript.bat b/unused/_macscript.bat new file mode 100755 index 0000000..357be41 --- /dev/null +++ b/unused/_macscript.bat @@ -0,0 +1,16 @@ +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr +cp ./dcm2nii/dcm2nii ../distro/dcm2nii + +./_xclean.bat +cp ./common/gui.inc ./common/isgui.inc + +lazbuild ./mricron.lpr --ws=carbon +lazbuild ./npm/npm.lpr --ws=carbon +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=carbon + +cp ./mricron ../distro/mricron.app/mricron +cp ./npm/npm ../distro/npm.app/npm +cp ./dcm2nii/dcm2niigui ../distro/dcm2niigui.app/dcm2niigui diff --git a/unused/_macscriptintel.bat b/unused/_macscriptintel.bat new file mode 100755 index 0000000..bde8a1f --- /dev/null +++ b/unused/_macscriptintel.bat @@ -0,0 +1,27 @@ +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr --cpu=x86_64 --compiler="/usr/local/bin/ppcx64" +mv ./dcm2nii/dcm2nii ../distro/dcm2nii64 + +lazbuild ./dcm2nii/dcm2nii.lpr +cp ./dcm2nii/dcm2nii ../distro/intel/dcm2nii +#assume we will not lipo PPC versions... +cp ./dcm2nii/dcm2nii ../distro/dcm2nii + +./_xclean.bat +cp ./common/gui.inc ./common/isgui.inc + +lazbuild ./mricron.lpr --ws=carbon +lazbuild ./npm/npm.lpr --ws=carbon +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=carbon + +cp ./mricron ../distro/intel/mricron +cp ./npm/npm ../distro/intel/npm +cp ./dcm2nii/dcm2niigui ../distro/intel/dcm2niigui + +#assume we will not lipo PPC versions... +cp ./dcm2nii/dcm2nii ../distro/dcm2nii +cp ./mricron ../distro/mricron.app/contents/MacOS/mricron +cp ./npm/npm ../distro/npm.app/contents/MacOS/npm +cp ./dcm2nii/dcm2niigui ../distro/dcm2niigui.app/contents/MacOS/dcm2niigui diff --git a/unused/_macscriptintel104.bat b/unused/_macscriptintel104.bat new file mode 100755 index 0000000..1843d65 --- /dev/null +++ b/unused/_macscriptintel104.bat @@ -0,0 +1,16 @@ +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr="-va -k-macosx_version_min -k10.4 -XR/Developer/SDKs/MacOSX10.4u.sdk/" +cp ./dcm2nii/dcm2nii ../distro/intel/dcm2nii + +./_xclean.bat +cp ./common/gui.inc ./common/isgui.inc + +lazbuild ./mricron.lpr="-va -k-macosx_version_min -k10.4 -XR/Developer/SDKs/MacOSX10.4u.sdk/" --ws=carbon +lazbuild ./npm/npm.lpr="-va -k-macosx_version_min -k10.4 -XR/Developer/SDKs/MacOSX10.4u.sdk/" --ws=carbon +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=carbon + +cp ./mricron ../distro/intel/mricron +cp ./npm/npm ../distro/intel/npm +cp ./dcm2nii/dcm2niigui ../distro/intel/dcm2niigui diff --git a/unused/_macscriptppc.bat b/unused/_macscriptppc.bat new file mode 100755 index 0000000..135ab31 --- /dev/null +++ b/unused/_macscriptppc.bat @@ -0,0 +1,16 @@ +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr +cp ./dcm2nii/dcm2nii ../distro/ppc/dcm2nii + +./_xclean.bat +cp ./common/gui.inc ./common/isgui.inc + +lazbuild ./mricron.lpr --ws=carbon +lazbuild ./npm/npm.lpr --ws=carbon +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=carbon + +cp ./mricron ../distro/ppc/mricron +cp ./npm/npm ../distro/ppc/npm +cp ./dcm2nii/dcm2niigui ../distro/ppc/dcm2niigui diff --git a/unused/_qtscript.bat b/unused/_qtscript.bat new file mode 100755 index 0000000..43b41c2 --- /dev/null +++ b/unused/_qtscript.bat @@ -0,0 +1,34 @@ +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr +cp ./dcm2nii/dcm2nii ../gtk1/mricron/dcm2nii +cp ./dcm2nii/dcm2nii ../gtk2/mricron/dcm2nii +cp ./dcm2nii/dcm2nii ../qt/mricron/dcm2nii + + +cp ./common/gui.inc ./common/isgui.inc + +./_xclean.bat +lazbuild ./mricron.lpr +lazbuild ./npm/npm.lpr +lazbuild ./dcm2nii/dcm2niigui.lpr +cp ./mricron ../gtk1/mricron/mricron +cp ./npm/npm ../gtk1/mricron/npm +cp ./dcm2nii/dcm2niigui ../gtk1/mricron/dcm2niigui + +./_xclean.bat +lazbuild ./mricron.lpr --ws=gtk2 +lazbuild ./npm/npm.lpr --ws=gtk2 +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=gtk2 +cp ./mricron ../gtk2/mricron/mricron +cp ./npm/npm ../gtk2/mricron/npm +cp ./dcm2nii/dcm2niigui ../gtk2/mricron/dcm2niigui + +./_xclean.bat +lazbuild ./mricron.lpr --ws=qt +lazbuild ./npm/npm.lpr --ws=qt +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=qt +cp ./mricron ../qt/mricron/mricron +cp ./npm/npm ../qt/mricron/npm +cp ./dcm2nii/dcm2niigui ../qt/mricron/dcm2niigui diff --git a/unused/_script.bat b/unused/_script.bat new file mode 100755 index 0000000..8cb0619 --- /dev/null +++ b/unused/_script.bat @@ -0,0 +1,25 @@ +chmod 777 ./_xclean.bat +./_xclean.bat +cp ./common/notgui.inc ./common/isgui.inc +lazbuild ./dcm2nii/dcm2nii.lpr +cp ./dcm2nii/dcm2nii ../gtk1/mricron/dcm2nii +cp ./dcm2nii/dcm2nii ../gtk2/mricron/dcm2nii + +cp ./common/gui.inc ./common/isgui.inc + +./_xclean.bat +lazbuild ./mricron.lpr +lazbuild ./npm/npm.lpr +lazbuild ./dcm2nii/dcm2niigui.lpr +cp ./mricron ../gtk1/mricron/mricron +cp ./npm/npm ../gtk1/mricron/npm +cp ./dcm2nii/dcm2niigui ../gtk1/mricron/dcm2niigui + +./_xclean.bat +lazbuild ./mricron.lpr --ws=gtk2 +lazbuild ./npm/npm.lpr --ws=gtk2 +lazbuild ./dcm2nii/dcm2niigui.lpr --ws=gtk2 + +cp ./mricron ../gtk2/mricron/mricron +cp ./npm/npm ../gtk2/mricron/npm +cp ./dcm2nii/dcm2niigui ../gtk2/mricron/dcm2niigui diff --git a/unused/_winscript.bat b/unused/_winscript.bat new file mode 100755 index 0000000..5117287 --- /dev/null +++ b/unused/_winscript.bat @@ -0,0 +1,16 @@ +call _clean.bat +copy .\common\notgui.inc .\common\isgui.inc + +c:\lazarus\lazbuild .\dcm2nii\dcm2nii.lpr + +copy .\dcm2nii\dcm2nii.exe c:\mricron\dcm2nii.exe + +call _clean.bat +copy .\common\gui.inc .\common\isgui.inc +c:\lazarus\lazbuild .\npm\npm.lpr +copy .\npm\npm.exe c:\mricron\npm.exe +c:\lazarus\lazbuild .\dcm2nii\dcm2niigui.lpr +copy .\dcm2nii\dcm2niigui.exe c:\mricron\dcm2niigui.exe +c:\lazarus\lazbuild .\mricron.lpr +copy .\mricron.exe c:\mricron\mricron.exe +call _clean.bat diff --git a/unused/_xcarbon.bat b/unused/_xcarbon.bat new file mode 100755 index 0000000..2ce0519 --- /dev/null +++ b/unused/_xcarbon.bat @@ -0,0 +1,6 @@ +rm ~/Documents/mricron/mricron.app/mricron +ln -s ~/Documents/mricron/mricron ~/Documents/mricron/mricron.app/mricron +rm ~/Documents/mricron/npm/npm.app/npm +ln -s ~/Documents/mricron/npm/npm ~/Documents/mricron/npm/npm.app/npm +rm ~/Documents/mricron/dcm2nii/dcm2niigui.app/dcm2niigui +ln -s ~/Documents/mricron/dcm2nii/dcm2niigui ~/Documents/mricron/dcm2nii/dcm2niigui.app/dcm2niigui diff --git a/unused/xclip.bat b/unused/xclip.bat new file mode 100755 index 0000000..cb1a552 --- /dev/null +++ b/unused/xclip.bat @@ -0,0 +1 @@ +./mricron ./templates/ch2bet.nii.gz -s 3 -c pink -l 40 -h 120 -r ./example/clipnearr.ini \ No newline at end of file diff --git a/unused/xcut.bat b/unused/xcut.bat new file mode 100755 index 0000000..036fc9b --- /dev/null +++ b/unused/xcut.bat @@ -0,0 +1 @@ +./mricron ./templates/ch2bet.nii.gz -s 3 -c pink -l 40 -h 120 -r ./example/cutr.ini \ No newline at end of file diff --git a/unused/xfmri.bat b/unused/xfmri.bat new file mode 100755 index 0000000..5e1f23a --- /dev/null +++ b/unused/xfmri.bat @@ -0,0 +1 @@ +./mricron ./templates/ch2bet.nii.gz -s 3 -c -0 -l 20 -h 140 -b 40 -t -1 -r ./example/fmrir.ini -o ./example/saccades.nii.gz -l 1.96 -h 5 -z -o ./example/attention.nii.gz -l 1.96 -h 5 -z -x \ No newline at end of file diff --git a/unused/xfmri2.bat b/unused/xfmri2.bat new file mode 100755 index 0000000..bc20c44 --- /dev/null +++ b/unused/xfmri2.bat @@ -0,0 +1 @@ +./mricron ./templates/ch2.nii.gz -s 3 -l 0 -h 140 -c pink -o ./templates/ch2bet.nii.gz -c -0 -l 30 -h 200 -o ./example/attention.nii.gz -l 1.96 -h 5 -z -b 40 -t 50 -r ./example/fmri2r.ini \ No newline at end of file diff --git a/unused/xfmri3.bat b/unused/xfmri3.bat new file mode 100755 index 0000000..cd1155c --- /dev/null +++ b/unused/xfmri3.bat @@ -0,0 +1 @@ +./mricron ./templates/aal.nii.gz -o ./example/attention.nii.gz -c -0 -l 1.96 -h 5 -z -b 40 -t 50 -r ./example/fmri3r.ini \ No newline at end of file diff --git a/voismooth.lfm b/voismooth.lfm new file mode 100755 index 0000000..bc7cfa7 --- /dev/null +++ b/voismooth.lfm @@ -0,0 +1,127 @@ +object voismoothform: Tvoismoothform + Left = 650 + Height = 222 + Top = 241 + Width = 252 + ActiveControl = XROIfwhm + BorderIcons = [biSystemMenu] + BorderStyle = bsDialog + Caption = 'Blur VOI' + ClientHeight = 222 + ClientWidth = 252 + Constraints.MaxHeight = 222 + Constraints.MaxWidth = 252 + Constraints.MinHeight = 222 + Constraints.MinWidth = 252 + OnCreate = FormCreate + OnShow = FormShow + Position = poScreenCenter + LCLVersion = '0.9.29' + object Label37: TLabel + Left = 12 + Height = 17 + Top = 46 + Width = 62 + Caption = 'Threshold' + Font.CharSet = ANSI_CHARSET + ParentColor = False + ParentFont = False + end + object CancelBtn: TSpeedButton + Left = 94 + Height = 25 + Hint = 'Save to small-endian [Intel] format' + Top = 167 + Width = 66 + Caption = 'Cancel' + Color = clBtnFace + NumGlyphs = 0 + OnClick = BtnClick + ShowHint = True + ParentShowHint = False + end + object OKBtn: TSpeedButton + Tag = 1 + Left = 165 + Height = 25 + Hint = 'Save to big-endian [Sun] format' + Top = 167 + Width = 66 + Caption = 'OK' + Color = clBtnFace + NumGlyphs = 0 + OnClick = BtnClick + ShowHint = True + ParentShowHint = False + end + object HelpBtn: TSpeedButton + Tag = 2 + Left = 21 + Height = 25 + Top = 167 + Width = 66 + Caption = 'Help' + Color = clBtnFace + NumGlyphs = 0 + OnClick = HelpBtnClick + ParentShowHint = False + end + object Label38: TLabel + Left = 12 + Height = 17 + Top = 9 + Width = 143 + Caption = 'Smoothing (FWHM mm)' + Font.CharSet = ANSI_CHARSET + ParentColor = False + ParentFont = False + end + object ScaleSides: TComboBox + Left = 12 + Height = 21 + Top = 84 + Width = 229 + ItemHeight = 13 + Items.Strings = ( + 'Adjust sides in Z-plane only [SPM]' + 'Adjust sides in X,Y and Z planes' + ) + Style = csDropDownList + TabOrder = 0 + end + object xROIoutput: TComboBox + Left = 12 + Height = 21 + Top = 117 + Width = 229 + ItemHeight = 13 + Items.Strings = ( + 'ROI is 1 [reslice ROI]' + 'ROI is 0 [SPM object mask]' + ) + Style = csDropDownList + TabOrder = 1 + end + object XROIthresh: TFloatSpinEdit + Left = 175 + Height = 21 + Top = 41 + Width = 70 + DecimalPlaces = 4 + Increment = 0.00100000004749 + MaxValue = 1 + MinValue = 0 + TabOrder = 2 + Value = 1 + end + object XROIfwhm: TSpinEdit + Left = 175 + Height = 21 + Top = 4 + Width = 70 + MaxValue = 40 + MinValue = 1 + TabOrder = 3 + Value = 1 + end +end diff --git a/voismooth.lrs b/voismooth.lrs new file mode 100644 index 0000000..231667e --- /dev/null +++ b/voismooth.lrs @@ -0,0 +1,36 @@ +LazarusResources.Add('Tvoismoothform','FORMDATA',[ + 'TPF0'#14'Tvoismoothform'#13'voismoothform'#4'Left'#3#138#2#6'Height'#3#222#0 + +#3'Top'#3#241#0#5'Width'#3#252#0#13'ActiveControl'#7#8'XROIfwhm'#11'BorderIc' + +'ons'#11#12'biSystemMenu'#0#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#8'Blu' + +'r VOI'#12'ClientHeight'#3#222#0#11'ClientWidth'#3#252#0#21'Constraints.MaxH' + +'eight'#3#222#0#20'Constraints.MaxWidth'#3#252#0#21'Constraints.MinHeight'#3 + +#222#0#20'Constraints.MinWidth'#3#252#0#8'OnCreate'#7#10'FormCreate'#6'OnSho' + +'w'#7#8'FormShow'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'#6#6'0.9.29' + +#0#6'TLabel'#7'Label37'#4'Left'#2#12#6'Height'#2#17#3'Top'#2'.'#5'Width'#2'>' + +#7'Caption'#6#9'Threshold'#12'Font.CharSet'#7#12'ANSI_CHARSET'#11'ParentColo' + +'r'#8#10'ParentFont'#8#0#0#12'TSpeedButton'#9'CancelBtn'#4'Left'#2'^'#6'Heig' + +'ht'#2#25#4'Hint'#6'#Save to small-endian [Intel] format'#3'Top'#3#167#0#5'W' + +'idth'#2'B'#7'Caption'#6#6'Cancel'#5'Color'#7#9'clBtnFace'#9'NumGlyphs'#2#0#7 + +'OnClick'#7#8'BtnClick'#8'ShowHint'#9#14'ParentShowHint'#8#0#0#12'TSpeedButt' + +'on'#5'OKBtn'#3'Tag'#2#1#4'Left'#3#165#0#6'Height'#2#25#4'Hint'#6#31'Save to' + +' big-endian [Sun] format'#3'Top'#3#167#0#5'Width'#2'B'#7'Caption'#6#2'OK'#5 + +'Color'#7#9'clBtnFace'#9'NumGlyphs'#2#0#7'OnClick'#7#8'BtnClick'#8'ShowHint' + +#9#14'ParentShowHint'#8#0#0#12'TSpeedButton'#7'HelpBtn'#3'Tag'#2#2#4'Left'#2 + +#21#6'Height'#2#25#3'Top'#3#167#0#5'Width'#2'B'#7'Caption'#6#4'Help'#5'Color' + +#7#9'clBtnFace'#9'NumGlyphs'#2#0#7'OnClick'#7#12'HelpBtnClick'#14'ParentShow' + +'Hint'#8#0#0#6'TLabel'#7'Label38'#4'Left'#2#12#6'Height'#2#17#3'Top'#2#9#5'W' + +'idth'#3#143#0#7'Caption'#6#19'Smoothing (FWHM mm)'#12'Font.CharSet'#7#12'AN' + +'SI_CHARSET'#11'ParentColor'#8#10'ParentFont'#8#0#0#9'TComboBox'#10'ScaleSid' + +'es'#4'Left'#2#12#6'Height'#2#21#3'Top'#2'T'#5'Width'#3#229#0#10'ItemHeight' + +#2#13#13'Items.Strings'#1#6'"Adjust sides in Z-plane only [SPM]'#6' Adjust s' + +'ides in X,Y and Z planes'#0#5'Style'#7#14'csDropDownList'#8'TabOrder'#2#0#0 + +#0#9'TComboBox'#10'xROIoutput'#4'Left'#2#12#6'Height'#2#21#3'Top'#2'u'#5'Wid' + +'th'#3#229#0#10'ItemHeight'#2#13#13'Items.Strings'#1#6#22'ROI is 1 [reslice ' + +'ROI]'#6#26'ROI is 0 [SPM object mask]'#0#5'Style'#7#14'csDropDownList'#8'Ta' + +'bOrder'#2#1#0#0#14'TFloatSpinEdit'#10'XROIthresh'#4'Left'#3#175#0#6'Height' + +#2#21#3'Top'#2')'#5'Width'#2'F'#13'DecimalPlaces'#2#4#9'Increment'#5'Z'''#206 + +#251#255'n'#18#131#245'?'#8'MaxValue'#2#1#8'MinValue'#2#0#8'TabOrder'#2#2#5 + +'Value'#2#1#0#0#9'TSpinEdit'#8'XROIfwhm'#4'Left'#3#175#0#6'Height'#2#21#3'To' + +'p'#2#4#5'Width'#2'F'#8'MaxValue'#2'('#8'MinValue'#2#1#8'TabOrder'#2#3#5'Val' + +'ue'#2#1#0#0#0 +]); diff --git a/voismooth.pas b/voismooth.pas new file mode 100755 index 0000000..8c23431 --- /dev/null +++ b/voismooth.pas @@ -0,0 +1,497 @@ +unit voismooth; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, + Buttons, Spin,define_types; + +type + + { Tvoismoothform } + + Tvoismoothform = class(TForm) + CancelBtn: TSpeedButton; + Label37: TLabel; + Label38: TLabel; + OKBtn: TSpeedButton; + ScaleSides: TComboBox; + HelpBtn: TSpeedButton; + XROIfwhm: TSpinEdit; + xROIoutput: TComboBox; + XROIthresh: TFloatSpinEdit; + procedure FormCreate(Sender: TObject); + procedure SmoothOpenVOI(Sender: TObject); + procedure BtnClick(Sender: TObject); + procedure FormShow(Sender: TObject); + procedure HelpBtnClick(Sender: TObject); + procedure SmoothVOI_SPM5masks; + + private + { private declarations } + public + { public declarations } + end; + +var + voismoothform: Tvoismoothform; + +implementation +uses nifti_img_view,nifti_img; +{ Tvoismoothform } + +procedure Tvoismoothform.HelpBtnClick(Sender: TObject); +begin + Showmessage('The Full Width Half Maximum [FWHM] defines the width of the smoothing Gaussian. '+ + 'The threshold defines a binary cutoff boundary - signals greater than the threshold will be included in the output. '+ + 'A threshold of 0 will create an continuous 8-bit output (0..200 for signal 0..1)'); +end; + +procedure Tvoismoothform.SmoothOpenVOI(Sender: TObject); +var + lScaleXY,lOK,lResliceNotMask: boolean; + lYOutra,lROIrealRA: SingleP; + lIncX,lMissing,lZPos,lYPos,lSliceSz,lXt,lYt,lZt,lX,lY,lZ,lXoffset,lYOffset,lZOffset,lI,lI2,lImgSz,lcutoffvoxx,lcutoffvoxy,lcutoffvoxz: integer; + lScale,lThreshComp,lExpd,lThresh,lSig,lXmm,lYmm,lZmm,lcumgauss: single;//double; + lxra,lyra,lzra,lzraScaled,lxCutra,lyCutra,lzCutra:SingleP0;//x0P; + lStartTime,lEndTime: DWord; + lXDim,lYDim,lZDim,lPlanes,lMinX,lMaxX,lMinY,lMaxY,lMinZ,lMaxZ: integer; +begin + lXDim := gBGImg.ScrnDim[1]; + lYDim := gBGImg.ScrnDim[2]; + lZDim := gBGImg.ScrnDim[3]; + lXmm := gBGImg.ScrnMM[1]; + lYmm := gBGImg.ScrnMM[2]; + lZmm := gBGImg.ScrnMM[3]; + lResliceNotMask := false; + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + if (gBGImg.ScrnMM[1] = 0) or (lXmm = 0) or (lYmm = 0) or (lZmm =0) or (XROIfwhm.value=0) then begin + ShowMessage('At least one of the images ''size [mm]'' settings or the ''FWHM [mm]'' is zero. Smoothing requires the image size to be specified.'); + Exit; + end; + if ScaleSides.itemindex = 1 then + lScaleXY := true + else + lScaleXY := false; + lOK := true; + if lScaleXY then begin + lsig := (XROIfwhm.value / lXmm)/sqrt(8*ln(2)); // % FWHM -> sigma + lcutoffvoxX := round(6*lsig); + if (lcutoffvoxX *2) >= lXdim then lOK := false; + lsig := (XROIfwhm.value / lYmm)/sqrt(8*ln(2)); // % FWHM -> sigma + lcutoffvoxY := round(6*lsig); + if (lcutoffvoxY *2) >= lYdim then lOK := false; + end; {scaleXY} + lsig := (XROIfwhm.value / lZmm)/sqrt(8*ln(2)); // % FWHM -> sigma + lcutoffvoxZ := round(6*lsig); + if (lcutoffvoxZ *2) >= lZdim then lOK := false; + if not lOK then begin + showmessage('Unable to smooth image: image dimensions are too small for such a broad smoothing. Reduce the FWHM'); + exit; + end; + if xROIoutput.itemindex <> 1 then + lResliceNotMask := true; + lImgSz := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lImgSz < 1 then exit; + CreateUndoVol;//create gBGImg.VOIUndoVol + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + if lResliceNotMask then begin //reslice + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol^[lI] <> 0 then + gBGImg.VOIUndoVol^[lI] := 1; + end else begin //create mask: invert + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol^[lI] = 0 then + gBGImg.VOIUndoVol^[lI] := 1 + else + gBGImg.VOIUndoVol^[lI] := 0; + end; //create mask + lSliceSz := lXdim * lYdim; + //lZXi := lZdim*lXdim; //for swizzle + lPlanes := 0; + ImgForm.ProgressBar1.Position := 0; + ImgForm.ProgressBar1.Min := 0; + ImgForm.ProgressBar1.Max := lZdim * 3; + ImgForm.StatusLabel.caption := 'Smoothing slice data: X-plane'; + //lStartTime := GetTickCount; + lThresh := XRoiThresh.value; + lsig := (XROIfwhm.value / lXmm)/sqrt(8*ln(2)); // % FWHM -> sigma + if lsig = 0 then begin + Showmessage('Unable to compute gaussian with current FWHM'); + exit; + end; + lcutoffvoxx := round(6*lsig); // % highest / lowest voxel to go out to + getmem(lxra,(lcutoffvoxx+1)*sizeof(double {was extended})); + getmem(lxCutra,(lcutoffvoxx+1)*sizeof(double {was extended})); + lexpd := 2*lsig*lsig; + lCumGauss := 0; + for lI := 0 to lcutoffvoxx do begin + lxra^[lI] := exp(-1*(lI*lI)/lexpd) ; + lCumGauss := lCumGauss + lxra^[lI]; + end; + lCumGauss := 2*lCumGauss - lxra^[0]; + if lCumGauss <> 0 then + for lI := 0 to lcutoffvoxx do begin + lxra^[lI] := lxra^[lI]/lCumGauss; + end; + for lI := 1 to lcutoffvoxX do begin + lCumGauss := 0; + for lI2 := (lcutoffvoxX - lI) downto -lcutoffvoxX do + lCumGauss := lCumGauss + lXra^[abs(lI2)]; + if lCumGauss <> 0 then + lXCutra^[lI] := 1/lCumGauss; + end; + lXCutra^[0] := 1; + lsig := (XROIfwhm.value / lYmm)/sqrt(8*ln(2)); // % FWHM -> sigma + if lsig = 0 then begin + Showmessage('Unable to compute gaussian with current FWHM'); + exit; + end; + lcutoffvoxY := round(6*lsig); // % highest / lowest voxel to go out to + getmem(lYra,(lcutoffvoxY+1)*sizeof(double {was extended})); + getmem(lYCutra,(lcutoffvoxY+1)*sizeof(double {was extended})); + lexpd := 2*lsig*lsig; + lCumGauss := 0; + for lI := 0 to lcutoffvoxY do begin + lYra^[lI] := exp(-1*(lI*lI)/lexpd) ; + lCumGauss := lCumGauss + lYra^[lI]; + end; + lCumGauss := 2*lCumGauss - lYra^[0]; + if lCumGauss <> 0 then + for lI := 0 to lcutoffvoxY do begin + lYra^[lI] := lYra^[lI]/lCumGauss; + end; + + for lI := 1 to lcutoffvoxY do begin + lCumGauss := 0; + for lI2 := (lcutoffvoxY - lI) downto -lcutoffvoxY do + lCumGauss := lCumGauss + lYra^[abs(lI2)]; + if lCumGauss <> 0 then + lYCutra^[lI] := 1/lCumGauss; + end; + lYCutra^[0] := 1; + lsig := (XROIfwhm.value / lZmm)/sqrt(8*ln(2)); // % FWHM -> sigma + if lsig = 0 then begin + Showmessage('Unable to compute gaussian with current FWHM'); + exit; + end; + lcutoffvoxZ := round(6*lsig); // % highest / lowest voxel to go out to + getmem(lZra,(lcutoffvoxZ+1)*sizeof(double {was extended})); + getmem(lZraScaled,(lcutoffvoxZ+lcutoffvoxZ+1)*sizeof(double {was extended})); + getmem(lZCutra,(lcutoffvoxZ+1)*sizeof(double {was extended})); + lexpd := 2*lsig*lsig; + lCumGauss := 0; + for lI := 0 to lcutoffvoxZ do begin + lZra^[lI] := exp(-1*(lI*lI)/lexpd ); + lCumGauss := lCumGauss + lZra^[lI]; + end; + lCumGauss := 2*lCumGauss - lZra^[0]; + if lCumGauss <> 0 then + for lI := 0 to lcutoffvoxZ do begin + lZra^[lI] := lZra^[lI]/lCumGauss; + end; + for lI := 1 to lcutoffvoxZ do begin + lCumGauss := 0; + for lI2 := (lcutoffvoxZ - lI) downto -lcutoffvoxZ do + lCumGauss := lCumGauss + lZra^[abs(lI2)]; + if lCumGauss <> 0 then + lZCutra^[lI] := 1/lCumGauss; + end; + lZCutra^[0] := 1;(**) + GetMem ( lROIrealRA , sizeof(single)*lImgSz); + GetMem (lYOutRA, sizeof(single) * lYdim); + if lResliceNotMask then + for lI := 1 to lImgSz do + lROIrealRA^[lI] := 0 + else + for lI := 1 to lImgSz do + lROIrealRA^[lI] := 1; + //X-direction + for lZ := 1 to lZdim do begin + lZPos := (lZ-1)*lSliceSz; + for lY := 1 to lYdim do begin + lyPos := (lY-1)*lXdim; + for lX := 1 to lXdim do begin + lMinX := lX - lCutoffVoxX; + if lMinX < 1 then lMinX := 1; + lMaxX := lX + lCutoffVoxX; + if lMaxX > lXdim then lMaxX := lXdim; + lMissing := (2*lCutOffVoxX)-(lMaxX-lMinX); + if lScaleXY then + lScale := lXCutRA^[lMissing] + else + lScale := lXCutRA^[0]; + lCumGauss := 0; + for lXt := lMinX to lMaxX do begin + //SSE optimization? + if (gBGImg.VOIUndoVol^[lXt+lYPos+lZpos] <> 0) then + lCumGauss := lCumGauss + lScale*lXra^[abs(lX-lXt)] (*{kSmoothImg}*(gROIEXport[lXt+lYPos+lZpos]/255)*); + end; {for each position} + lROIrealRA^[lX+lYPos+lZpos] := lCumGauss; + end; {lX} + end; {lY} + + Application.ProcessMessages; + inc(lPlanes); + ImgForm.ProgressBar1.Position := lPLanes; + end; {lZ loop for X-plane} + ImgForm.StatusLabel.caption := 'Smoothing slice data: Y-plane'; + for lZ := 1 to lZdim do begin {Z loop for Y plane} + lZPos := (lZ-1)*lSliceSz; + for lX := 1 to lXdim do begin + for lY := 1 to lYdim do begin + lMinY := lY - lCutoffVoxY; + if lMinY < 1 then lMinY := 1; + lMaxY := lY + lCutoffVoxY; + if lMaxY > lYdim then lMaxY := lYdim; + lMissing := (2*lCutOffVoxY)-(lMaxY-lMinY); + if lScaleXY then + lScale := lYCutRA^[lMissing] + else + lScale := lYCutRA^[0]; + lCumGauss := 0; + for lYt := lMinY to lMaxY do begin + //SSE optimization? + lCumGauss := lCumGauss+ lScale*(lROIrealRA^[lX+((lYt-1)*lXdim)+lZpos])*lYra^[abs(lY-lYt)]; + end; {for each position} + lYOutRA^[lY] := lCumGauss; + end; {lY} + for lY := 1 to lYdim do begin + //SSE optimization + lROIrealRA^[lX+((lY-1)*lXdim)+lZpos] := lYOutRA^[lY]; + end; + end; {lX} + Application.ProcessMessages; + inc(lPlanes); + ImgForm.ProgressBar1.Position := lPlanes; + end; {Z loop for Y plane} + (*if (not lScaleXY) then begin + //lOrigZPos := (lFirstEmptySlice-1)*lSliceSz; + for lZ := lFirstEmptySlice to lZi do begin + if (lROIonSliceRA[lZ]=0) then begin + lZPos := (lZ-1)*lSliceSz; + for lX := 1 to lSliceSz do + //SSE optimization? + lROIrealRA[lX+lZPos] := lROIrealRA[lX+lOrigZPos]; + Application.ProcessMessages; + end; {no ROI on this slice} + end; {for n slices} + end; {not scaled} *) + lThreshComp := 1 - lThresh; + ImgForm.StatusLabel.caption := 'Smoothing slice data: Z-plane'; + lI := 0; + for lZ := 1 to lZdim do begin + lMinZ := lZ - lCutoffVoxZ; + if lMinZ < 1 then lMinZ := 1; + lMaxZ := lZ + lCutoffVoxZ; + if lMaxZ > lZdim then lMaxZ := lZdim; + lScale := 1; + lMissing := (2*lCutOffVoxZ)-(lMaxZ-lMinZ); + if (lMissing >= 0) and (lMissing <= lCutOffVoxZ) then + lScale := lZCutRA^[lMissing]; + if lThreshComp <> 1 then begin +if lResliceNotMask then begin + for lIncX := 1 to lcutoffvoxZ do + lZraScaled^[lcutoffvoxZ-lIncX] := lZra^[lIncX]*lScale; + for lIncX := 0 to lcutoffvoxZ do + lZraScaled^[lcutoffvoxZ+lIncX] := lZra^[lIncX]*lScale; + lZOffset := lcutoffvoxZ + lZ; + for lY := 1 to lYdim do begin + lyPos := (lY-1)*lXdim; + for lX := 1 to lXdim do begin + lCumGauss := 0; + lIncX := ((lMinZ-1)*lSliceSz)+lX+lYPos; + for lZt := lMinZ to lMaxZ do begin + lCumGauss := lCumGauss + lROIrealRA^[lIncX]*lZraScaled^[(lZoffset-lZt)]; + lIncX := lIncX+ lSliceSz + //SSE optimization + //lCumGauss := lCumGauss + lROIrealRA[lX+lYPos+(lZt-1)*lSliceSz]*lZra[abs(lZ-lZt)]*lScale; + end; + inc(lI); + if (lCumGauss < (1-lThreshComp)) then + gBGImg.VOIUndoVol^[lI] := 100 + else + gBGImg.VOIUndoVol^[lI] := 0; + end; {lX} + end; {lY} +end else begin //this is a mask -> unrolled loop means faster processing + for lY := 1 to lYdim do begin + lyPos := (lY-1)*lXdim; + for lX := 1 to lXdim do begin + lCumGauss := 0; + for lZt := lMinZ to lMaxZ do + lCumGauss := lCumGauss + lROIrealRA^[lX+lYPos+(lZt-1)*lSliceSz]*lZra^[abs(lZ-lZt)]*lScale; + inc(lI); + if lCumGauss > lThreshComp then + gBGImg.VOIUndoVol^[lI] := 0 + else + gBGImg.VOIUndoVol^[lI] := 100; + end; {lX} + end; {lY} +end; + end else begin //threshcomp = 1 analogua output + for lY := 1 to lYdim do begin + lyPos := (lY-1)*lXdim; + for lX := 1 to lXdim do begin + lCumGauss := 0; + for lZt := lMinZ to lMaxZ do + //SSE optimization? + lCumGauss := lCumGauss + lROIrealRA^[lX+lYPos+(lZt-1)*lSliceSz]*lZra^[abs(lZ-lZt)]*lScale; + inc(lI); + gBGImg.VOIUndoVol^[lI] := round(200 * lCumGauss); + end; {lX} + end; {lY} + end; //threshcomp=1 analogue output + Application.ProcessMessages; + inc(lPlanes); + ImgForm.ProgressBar1.Position := lPlanes; + end; {lZ loop} + //lEndTime := GetTickCOunt; + // ImgForm.StatusLabel.caption :=('Smoothing time(ms): '+inttostr(lEndTime-lStartTime)); + FreeMem (lROIrealRA); + FreeMem (lYOutRA); + Freemem(lXra); + Freemem(lYra); + Freemem(lZra); + Freemem(lZraScaled); + Freemem(lXCutra); + Freemem(lYCutra); + Freemem(lZCutra); + if (lThreshComp = 1) then begin //analogue output + //gGlMaxUnscaledS := 200; + //Scale.value := 0.0050000; + for lI := 1 to lImgSz do + gBGImg.VOIUndoVol^[lI] := 200 - gBGImg.VOIUndoVol^[lI]; + end else begin //threshcomp <> 1 + //gGlMaxUnscaledS := 100; + //Scale.value := 0.0100000; + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol^[lI] = 0 then + gBGImg.VOIUndoVol^[lI] := kVOI8bit + else + gBGImg.VOIUndoVol^[lI] := 0; + end; //Threshcomp <> 1 so digital output + lResliceNotMask := false; + gBGImg.VOIchanged := true; + ImgForm.ProgressBar1.Position := 0; + ImgForm.Undo1Click(nil); //show smoothed buffer + end; + +procedure Tvoismoothform.FormCreate(Sender: TObject); +begin + XROIthresh.value := 0.5; + XROIfwhm.value := 8; + ScaleSides.ItemIndex := 0; + xROIoutput.ItemIndex := 0; +end; + + +procedure Tvoismoothform.BtnClick(Sender: TObject); +begin + if (Sender as TSpeedButton).tag = 1 then + SmoothOpenVOI(Sender); + voismoothform.Close; +end; + +procedure Tvoismoothform.FormShow(Sender: TObject); +begin + // voismoothform.ModalResult := mrCancel; +end; + +procedure VOIinvert; +var + lI,lImgSz: integer; +begin + lImgSz := gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems; + if lImgSz < 1 then exit; + CreateUndoVol; + Move(gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer^,gBGImg.VOIUndoVol^,gBGImg.VOIUndoVolItems); + for lI := 1 to lImgSz do + if gBGImg.VOIUndoVol^[lI] = 0 then + gBGImg.VOIUndoVol^[lI] := 1 + else + gBGImg.VOIUndoVol^[lI] := 0; + gBGImg.VOIchanged := true; + ImgForm.Undo1Click(nil); //show smoothed buffer +end; + +procedure Tvoismoothform.SmoothVOI_SPM5masks; +var + lBGname,lmaskname,llesionname: string; + lorigFWHM , + lorigThresh : single; + lorigSS,lOrigOut: integer; +begin + if not IsVOIOpen then begin + ShowMessage('You have not created or opened a region of interest.'); + exit; + end; + lBGname := gMRIcroOverlay[kBGOverlayNum].HdrFileName; + if not gMRIcroOverlay[kBGOverlayNum].NIfTItransform then begin + //need to save BG as NIfTI + lBGName := ChangeFilePrefix(lBGname,'x'); + SaveAsVOIorNIFTIcore(lBGName,gMRIcroOverlay[kBGOverlayNum].ImgBuffer,gMRIcroOverlay[kBGOverlayNum].ImgBufferItems,gMRIcroOverlay[kBGOverlayNum].ImgBufferBPP,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + end; + lmaskname := ChangeFilePrefix(lBGname,'m'); + lmaskname := changefileextx(lmaskname, '.nii'); + llesionname := ChangeFilePrefix(lBGname,'l'); + llesionname := changefileextx(llesionname, '.nii'); + if (fileexists(lmaskname)) or (fileexists(llesionname)) then begin + showmessage ('Files already exist named '+lmaskname+' '+llesionname); + exit; + end; + //init + lorigFWHM := XROIfwhm.value; + lorigThresh := XROIthresh.value; + lorigSS := voismoothform.ScaleSides.itemindex; + lorigOut := xROIoutput.itemindex; + //compute mask + //XROIfwhm.value := 8; + XROIfwhm.value := gBGImg.LesionDilate; + XROIthresh.value := 0.001; + ScaleSides.itemindex:=(1); + xROIoutput.itemindex:=(1); + if gBGImg.LesionDilate <= 0 then + VOIinvert + else + SmoothOpenVOI(nil); + if (gBGImg.VOIUndoSlice < 1) or (gBGImg.VOIUndoOrient <> 4) then begin //should be impossible - smoothVOI creates undovol + showmessage('Serious error.'); + exit; + end; + ImgForm.StatusLabel.caption := 'Smoothed :'+lMaskName; + gMRIcroOverlay[kVOIOverlayNum].HdrFileName := lmaskname; + ImgForm.SaveVOIcore(false);//12/2010 //unmirrors image + //12/2010 SaveAsVOIorNIFTIcore (lmaskname, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + + //compute lesion + UndoVolVOI; + + XROIfwhm.value := gBGImg.LesionSmooth; + XROIthresh.value := 0.5; + //ScaleSides.setitemindex(0); + xROIoutput.itemindex:=(0); + SmoothOpenVOI(nil); + gMRIcroOverlay[kVOIOverlayNum].HdrFileName := llesionname; + ImgForm.SaveVOIcore(false);//12/2010 //unmirrors image + gMRIcroOverlay[kVOIOverlayNum].HdrFileName := lmaskname; + //SaveAsVOIorNIFTIcore (llesionname, gMRIcroOverlay[kVOIOverlayNum].ScrnBuffer,gMRIcroOverlay[kVOIOverlayNum].ScrnBufferItems, 1,1,gMRIcroOverlay[kBGOverlayNum].NiftiHdr); + //re-init + UndoVolVOI; + + XROIfwhm.value := round(lorigFWHM); + XROIthresh.value := lorigThresh; + ScaleSides.itemindex:=(lOrigSS); + xROIoutput.itemindex:=(lOrigOut); +end; + +initialization + {$I voismooth.lrs} + +end. + diff --git a/wgraphics.pas b/wgraphics.pas new file mode 100755 index 0000000..32dc51a --- /dev/null +++ b/wgraphics.pas @@ -0,0 +1,85 @@ +unit wgraphics; +//only for windows +{$mode objfpc}{$H+} + +interface + +uses + Interfaces, + + SysUtils, LCLType, LCLProc, InterfaceBase, FPImage, + IntfGraphics, Math, + Windows,Classes,define_types; + +procedure Draw32Bitmap(Dest: HDC; lWidth, lHeight: Integer; Bitmap: RGBQuadp); +procedure StretchDraw32Bitmap(Dest: HDC; DstWidth, DstHeight,SrcWidth, SrcHeight: Integer; Bitmap: RGBQuadp); + +implementation + + + +procedure StretchDraw32Bitmap(Dest: HDC; DstWidth, DstHeight,SrcWidth, SrcHeight: Integer; Bitmap: RGBQuadp); +var + Clip: TRect; + Info: BITMAPINFO; + DstX, DstY,SrcX, SrcY: integer; +begin + if (Bitmap = nil) then Exit; + if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit; + if (DstWidth <= 0) or (DstHeight <= 0) then Exit; + DstX := 0; DstY := 0; SrcX := 0; SrcY := 0; + Widgetset.GetClipBox(Dest, @Clip); + if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or + (DstX + DstWidth < Clip.Left) or (DstY + DstHeight < Clip.Top) then Exit; + if (DstWidth = SrcWidth) and (DstHeight = SrcHeight) then begin + Draw32Bitmap(Dest, SrcWidth, SrcHeight, Bitmap); + Exit; + end; + with Info.bmiHeader do begin + biSize := SizeOf(BITMAPINFOHEADER); + biWidth := SrcWidth; + biHeight := SrcHeight; + biPlanes := 1; + biBitCount := 32; + biCompression := BI_RGB; + biSizeImage := 0; + biClrImportant := 0; + end; + SetStretchBltMode(Dest, COLORONCOLOR); + StretchDIBits(Dest, DstX, Pred(DstY + DstHeight), DstWidth, -DstHeight, SrcX, SrcY, + SrcWidth, SrcHeight, Bitmap, Info, DIB_RGB_COLORS, SRCCOPY); +end; + +// ! SrcX < 0, SrcY < 0, SrcX + SrcWidth > Bitmap.Width, SrcY + SrcHeight > Bitmap.Height +// ! results in mash +procedure Draw32Bitmap(Dest: HDC; lWidth, lHeight: Integer; Bitmap: RGBQuadp); +var + Clip: TRect; + SrcX,SrcY,DstX,DstY:integer; + Info: BITMAPINFO; +begin + if (Bitmap = nil) then Exit; + if (lWidth <= 0) or (lHeight <= 0) then Exit; + Widgetset.GetClipBox(Dest, @Clip); + // clipping: + SrcX := 0; SrcY := 0;DstX := 0; DstY := 0; + //ClipDimension(Clip.Left, Clip.Right, DstX, SrcX, lWidth); + //ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, lHeight); + with Info.bmiHeader do + begin + biSize := SizeOf(BITMAPINFOHEADER); + biWidth := lWidth; + biHeight := lHeight; + biPlanes := 1; + biBitCount := 32; + biCompression := BI_RGB; + biSizeImage := 0; + biClrImportant := 0; + end; + SetStretchBltMode(Dest, COLORONCOLOR); + StretchDIBits(Dest, DstX, Pred(DstY + lHeight), lWidth, -lHeight, + SrcX, SrcY, lWidth, lHeight, Bitmap, Info, DIB_RGB_COLORS, SRCCOPY); +end; + +end. + diff --git a/winmemmap.pas b/winmemmap.pas new file mode 100755 index 0000000..2f4ecf4 --- /dev/null +++ b/winmemmap.pas @@ -0,0 +1,262 @@ +unit winmemmap; +{$H+} +interface +{ This Unit implements an interface to Win32 memory mapped files. It + can be used to map data simply residing in memory or data residing + in a file. The data can be fully mapped into the processes address + space or chunks can be mapped. It also provides capabilities for + processes to synchronize via mutexes. When mapping sections of the + memory, you must be aware that the Win32 memory mapped file interface + requires that when you are requesting an offset into the memory + region, this offset must be a multiple of the system's memory + allocation granularity (I've called it PageSize). At this point + it is 64K. This is not a concern when you are mapping anything less + than 64K. However, to map anything > 64K the total memory size + mapped must be a multiple of 64K or you will not have access to + the memorysize MOD 64K bytes left over. Basically there are five + rules to be successful when using these routines: + 1. Mapname must be unique for each different case you use + these objects (MyMap1 for case 1, MyMap2 for case 2 + etc.).However, each process using the same memory map + MUST use the same MapName. + 2. Call MapExisting before CreateMemMap or FCreateMemMap. + If another process has already started the mapping, + all you want to do is map to the existing map. ie. + If NOT MapExisting then CreateMemMap. + 3. If your processes are going to write to the mapped + memory, it is suggested you use the mutex stuff. + 4. Pay heed to the warning above concerning seeking + offsets into the mapped memory. Whenever you call + the seek function, always check for an error. Errors + in mapping to the file will result in the Memmap + pointer being Nil. + 5. You MUST call LeaveCriticalSection after calling + EnterCriticalSection or you will lock other processes wishing + to use the map into an infinite wait state. Always use + a Try..Finally block. +} +Uses + Classes,Windows; +Const + hMemMap = $FFFFFFFF; +Type + //Map to memory + TEMemMap = Class(TComponent) + Private + FhFile : THandle; //File handle, hMemMap when simple memory + FhMap : THandle; //Mapping handle + FMap : Pointer; //Memory Pointer + FMapSize : Cardinal; //Mapping Page Size + FMemSize : Cardinal; //Maximum size allocated, >=FileSize when a file + FPageSize : Cardinal; //Minimum System allocation size + FMaxSeeks : Cardinal; //Maximum seeks available,(FMemSize DIV PageSize)-1 + FMapError : Integer; //Error returned + FhMutex : THandle; //Mutex handle for sharing + FInMutex : Boolean; //Internal flag + Function SetMapError : Boolean; + Procedure SetMemSize(Size : Cardinal); + Public + Constructor Create(Aowner : TComponent); Override; + Destructor Destroy; Override; + //Create a mutex for sychronizing access + Function CreateMutex(Const MutexName : String) : Boolean; + //Use the mutex + Procedure EnterCriticalSection; + //Release the mutex + Procedure LeaveCriticalSection; + //Map to existing memory map + Function MapExisting(Const MapName : String; + Const MapSize : Cardinal) : Boolean;Virtual; + //Create a new memory map + Function CreateMemMap(Const MapName : String; + Const MapSize : Cardinal; + Const MapData ) : Boolean;Virtual; + //seek to an offset in the memory map + Function Seek(Const OffSet : Cardinal) : Boolean; + //duh? + Procedure RaiseMappingException;Virtual; + + Property MemMap : Pointer Read FMap; //The mapped memory + Property MapError : Integer Read FMapError Write FMapError; + Property MemSize : Cardinal Read FMemSize Write SetMemSize; //Memory size to allocate + Property PageSize : Cardinal Read FPageSize; //system returned page size + Property MaxSeeks : Cardinal Read FMaxSeeks; //maximum seeks allowed + end; + //map to a file + TEFileMap = Class(TEMemMap) + Public + Function FCreateMemMap(Const Filename : String; + Const MapName : String; + Const MapSize : Cardinal) : Boolean; + + Function FlushFileView : Boolean; + end; +implementation +Uses + SysUtils; +Type + EMappingException = class(Exception); +Constructor TEMemMap.Create(AOwner : TComponent); +Var + SysInfo : TSystemInfo; +begin + Inherited Create(AOwner); + FhFile:=hMemMap; + GetSystemInfo(SysInfo); + FPageSize:=SysInfo.dwAllocationGranularity; +end; +Destructor TEMemmap.Destroy; +begin + LeaveCriticalSection; + If FhMutex<>0 then + CloseHandle(FhMutex); + If FMap<>Nil then + UnMapViewOfFile(FMap); + If FHMap<>0 then + CloseHandle(FHMap); + Inherited Destroy; +end; +Function TEMemMap.CreateMutex(Const MutexName : String) : Boolean; +begin + If FhMutex=0 then + FhMutex:=Windows.CreateMutex(Nil,False,PChar(MutexName)); + If FhMutex=0 then + Result:=SetMapError + else + Result:=True; +end; +Procedure TEMemMap.EnterCriticalSection; +begin + If (NOT FInMutex) AND (FhMutex>0) then + begin + WaitForSingleObject(FhMutex,INFINITE); + FInMutex:=True; + end; +end; +Procedure TEMemMap.LeaveCriticalSection; +begin + If FInMutex AND (FhMutex>0) then + begin + ReleaseMutex(FhMutex); + FInMutex:=False; + end; +end; +Function TEMemMap.SetMapError : Boolean; +begin + FMapError:=GetLastError; + Result:=False; +end; +Procedure TEMemMap.RaiseMappingException; +Var + TError : Integer; +begin + If FMapError<>0 then + begin + LeaveCriticalSection; + TError:=FMapError; + FMapError:=0; + Raise EMappingException.Create('Memory Mapping Error #'+IntToStr(TError)); + end; +end; +Procedure TEMemMap.SetMemSize(Size : Cardinal); +begin + FMemSize:=Size; + If FMemSize>PageSize then + FMaxSeeks:=(FMemSize DIV PageSize)-1 + else + FMaxSeeks:=0; +end; +//map to an existing memory map described by MapName +Function TEMemMap.MapExisting(Const MapName : String; + Const MapSize : Cardinal) : Boolean; +begin + FMapSize:=MapSize; + FMap:=Nil; + FhMap:=OpenFileMapping(FILE_MAP_WRITE,BOOL(True),PChar(MapName)); + If FhMap<>0 then + begin + FMap:=MapViewOfFile(FhMap,FILE_MAP_WRITE,0,0,MapSize); + If FMap=Nil then + begin + CloseHandle(FHMap); + FHMap:=0; + SetMapError; + end; + end; + Result:=FMap<>Nil; +end; +//Create a new memory mapping +Function TEMemMap.CreateMemMap(Const MapName : String; + Const MapSize : Cardinal; + Const MapData ) : Boolean; +begin + If FMemSize=0 then + FMemSize:=MapSize; + FhMap:=CreateFileMapping(FhFile,nil,PAGE_READWRITE,0,FMemSize,PChar(MapName)); + If FhMap<>0 then + begin + FMap:=MapViewOfFile(FhMap,FILE_MAP_WRITE,0,0,MapSize); + If FMap<>Nil then + begin + If fHFile=hMemMap then + begin + EnterCriticalSection; + Try + Move(MapData,FMap^,MapSize); + Finally + LeaveCriticalSection; + end; + end; + Result:=True; + end + else + Result:=SetMapError; + end + else + Result:=SetMapError; +end; +//seek to a different position in map (0..MaxSeeks) +Function TEMemMap.Seek(Const OffSet : Cardinal) : Boolean; +begin + Result:=True; + If NOT UnMapViewOfFile(FMap) then + Result:=SetMapError + else + begin + FMap:=MapViewOfFile(FhMap,FILE_MAP_WRITE,0,OffSet*PageSize,FMapSize); + If FMap=Nil then + Result:=SetMapError; + end; +end; +//Create a file mapping +Function TEFileMap.FCreateMemMap(Const Filename : String; + Const MapName : String; + Const MapSize : Cardinal) : Boolean; +Var + TInt : Cardinal; +begin + FHFile:=CreateFile(PChar(FileName),GENERIC_READ OR GENERIC_WRITE, + FILE_SHARE_READ OR FILE_SHARE_WRITE,NIl,OPEN_EXISTING, + FILE_FLAG_RANDOM_ACCESS,0); + If FhFile<>0 then + begin + Try + Result:=CreateMemMap(MapName,MapSize,TInt); + Finally + CloseHandle(FhFile); + end; + end + else + Result:=SetMapError; +end; + +Function TEFileMap.FlushFileView : Boolean; +begin + EnterCriticalSection; + Try + Result:=FlushViewOfFile(FMap,FMapSize) OR SetMapError; + Finally + LeaveCriticalSection; + end; +end; +end. diff --git a/winres.res b/winres.res new file mode 100755 index 0000000..b5e4a11 Binary files /dev/null and b/winres.res differ diff --git a/yokesharemem.pas b/yokesharemem.pas new file mode 100755 index 0000000..6fdd32a --- /dev/null +++ b/yokesharemem.pas @@ -0,0 +1,135 @@ +unit yokesharemem; +{$mode objfpc}{$H+} +interface +//http://community.freepascal.org:10000/docs-html/rtl/ipc/shmctl +// call CreateSharedMem when an application is created and CloseSharedMem when a program is closed +// along with NInstances, these functions return the number of concurrent instances. +// if a program crashes, the values may not be reset until the next reboot + +uses + forms, classes, + {$IFDEF UNIX} + BaseUnix, SysUtils, ipc,dialogs; + {$ELSE} + winmemmap; + {$ENDIF} + function CreateSharedMem (lApp: TComponent): integer; //returns number of instances after including this one... + function CloseSharedMem: integer; //returns number of instances after after this one closes + function NInstances: integer; //returns number of instances + function SetShareFloats(lXmm,lYmm,lZmm: single): boolean; + function GetShareFloats(var lXmm,lYmm,lZmm: single): boolean; + +implementation + +type + TShareMem = record + Instances: integer; + Xmm,Ymm,Zmm: single; + end; + PIntBuffer = ^TShareMem; +var + gShareIntBuf: PIntBuffer; + gPrevShare : TShareMem; + +function NInstances: integer; +begin + result := gShareIntBuf^.Instances; +end; + +function SetShareFloats(lXmm,lYmm,lZmm: single): boolean; +begin + gShareIntBuf^.Xmm := lXmm; + gShareIntBuf^.Ymm := lYmm; + gShareIntBuf^.Zmm := lZmm; + gPrevShare := gShareIntBuf^; +end; + +function GetShareFloats(var lXmm,lYmm,lZmm: single): boolean; +begin + lXmm := gShareIntBuf^.Xmm; + lYmm := gShareIntBuf^.Ymm; + lZmm := gShareIntBuf^.Zmm; + if (lXmm = gPrevShare.Xmm) and (lYmm = gPrevShare.Ymm) and(lZmm = gPrevShare.Zmm) then + result := false + else + result := true; + gPrevShare := gShareIntBuf^; +end; +{$IFNDEF UNIX} //Windows implementation +var +EMemMap : TEMemMap; + +function CreateSharedMem (lApp: TComponent): integer; //returns number of instances after including this one... +var + I: integer; +begin + EMemMap:=TEMemMap.Create(lApp{Self}); + EMemMap.CreateMutex('MRICROMUTEX3'); + If NOT EMemMap.MapExisting('MRICROMAP3',SizeOf(TShareMem)) then begin + gPrevShare.Xmm:=0; + gPrevShare.Ymm:=0; + gPrevShare.Zmm:=0; + gPrevShare.Instances:=0; + If NOT EMemMap.CreateMemMap('MRICROMAP2',SizeOf(TShareMem),gPrevShare) then + EMemMap.RaiseMappingException; + gShareIntBuf := PINtBuffer(EMemMap.MemMap); + end else + gShareIntBuf^.Instances := gShareIntBuf^.Instances + 1; +end; + + +function CloseSharedMem: integer; //returns number of instances after after this one closesb +begin + EMemMap.Free; +end; + +{$ELSE} +var + fshmid: longint; + segptr : Pointer; + +function CreateSharedMem (lApp: TComponent): integer; //returns number of instances after including this one... + var + key : Tkey; + new: boolean; + const ftokpath = '.'#0; + begin + key := ftok (pchar(@ftokpath[1]),ord('S')); + fshmid := shmget(key,SizeOf(TShareMem) {segsize},IPC_CREAT or IPC_EXCL or 438); + If fshmid=-1 then begin + //showmessage('Loading existing memory.'); + new := false; + fshmid := shmget(key,SizeOf(TShareMem){segsize},0); + If fshmid = -1 then begin + showmessage ('Shared memory : Error !'+inttostr(fpgeterrno)); + halt(1); + end + end + else begin + new := true; + //showmessage ('Creating new shared memory segment.'); + end; + segptr:=shmat(fshmid,nil,0); + gShareIntBuf := segptr; + if new then + gShareIntBuf^.Instances := 1 + else + gShareIntBuf^.Instances :=gShareIntBuf^.Instances + 1; + result := gShareIntBuf^.Instances; +end; + +function CloseSharedMem: integer; +//returns number of instances after this application quits +begin + gShareIntBuf^.Instances := gShareIntBuf^.Instances -1; + result := gShareIntBuf^.Instances; + if Assigned (segptr) then + shmdt (segptr); + if result < 1 then begin //last running instance - close shared memory + if shmctl (FShmId, IPC_RMID, nil) = -1 then + Showmessage('unable to release shared memory'); + end; +end; +{$ENDIF} +end. + diff --git a/zconf.inc b/zconf.inc new file mode 100755 index 0000000..0f9e451 --- /dev/null +++ b/zconf.inc @@ -0,0 +1,24 @@ +{ -------------------------------------------------------------------- } + +{$DEFINE MAX_MATCH_IS_258} + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{- $DEFINE MAXSEG_64K} +{$IFNDEF WIN32} + {$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } +{$ENDIF} + +{$UNDEF DYNAMIC_CRC_TABLE} +{$UNDEF FASTEST} +{$define patch112} { apply patch from the zlib home page } +{ -------------------------------------------------------------------- } +{$IFDEF FPC} + {$DEFINE Use32} + {$UNDEF DPMI} + {$UNDEF MSDOS} + {$UNDEF UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } + {$UNDEF MAXSEG_64K} +{$ENDIF} +